1141 files changed, 386053 insertions, 0 deletions

diff --git a/.gitattributes b/.gitattributes
new file mode 100644
index 0000000..1f54ecd
--- /dev/null
+++ b/.gitattributes
@@ -0,0 +1,12 @@
+configure eol=lf
+*.sh eol=lf
+*.patch eol=lf
+tests/merlin-wrapper eol=lf
+
+src/ocaml/preprocess/menhirLib.ml text eol=lf
+src/ocaml/preprocess/menhirLib.mli text eol=lf
+src/ocaml/preprocess/parser_explain.ml text eol=lf
+src/ocaml/preprocess/parser_printer.ml text eol=lf
+src/ocaml/preprocess/parser_raw.ml text eol=lf
+src/ocaml/preprocess/parser_raw.mli text eol=lf
+src/ocaml/preprocess/parser_recover.ml text eol=lf
diff --git a/.github/workflows/emacs-lint.yml b/.github/workflows/emacs-lint.yml
new file mode 100644
index 0000000..eccd0f0
--- /dev/null
+++ b/.github/workflows/emacs-lint.yml
@@ -0,0 +1,40 @@
+name: Emacs lint
+
+on:
+  push:
+    paths:
+      - 'emacs/**'
+  pull_request:
+    paths:
+      - 'emacs/**'
+
+jobs:
+  build:
+    runs-on: ubuntu-latest
+    strategy:
+      matrix:
+        emacs_version:
+          #- 25.1
+          #- 25.2
+          #- 25.3
+          #- 26.1
+          #- 26.2
+          #- 26.3
+          #- 27.1
+          - 27.2
+          - snapshot
+        # include:
+        #   - emacs_version: 24.1
+        #     lint_ignore: 1
+        #   - emacs_version: 24.2
+        #     lint_ignore: 1
+    env:
+      EMACS_LINT_IGNORE: ${{ matrix.lint_ignore }}
+    steps:
+    - uses: purcell/setup-emacs@master
+      with:
+        version: ${{ matrix.emacs_version }}
+
+    - uses: actions/checkout@v2
+    - name: Run tests
+      run: 'cd emacs && ./check.sh'
diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml
new file mode 100644
index 0000000..8e5dec1
--- /dev/null
+++ b/.github/workflows/main.yml
@@ -0,0 +1,83 @@
+# This is a basic workflow to help you get started with Actions
+
+name: CI
+
+# Controls when the action will run. Triggers the workflow on push or pull request
+# events but only for the master branch
+on:
+  push:
+    branches: [ 413 ]
+    paths-ignore:
+      - '**.md'
+      - '**.txt'
+      - '.git*'
+      - 'doc/**'
+      - 'emacs/**'
+      - 'vim/**'
+  pull_request:
+    branches: [ 413 ]
+    paths-ignore:
+      - '**.md'
+      - '**.txt'
+      - '.git*'
+      - 'doc/**'
+      - 'emacs/**'
+      - 'vim/**'
+  schedule:
+    - cron: '0 12 */6 * *'
+
+# A workflow run is made up of one or more jobs that can run sequentially or in parallel
+jobs:
+  # This workflow contains a single job called "build"
+  build:
+    strategy:
+      fail-fast: false
+      matrix:
+        os:
+          - macos-latest
+          - ubuntu-latest
+          - windows-latest
+        ocaml-compiler:
+          - 4.13.x
+    # The type of runner that the job will run on
+    runs-on: ${{ matrix.os }}
+
+    # Steps represent a sequence of tasks that will be executed as part of the job
+    steps:
+      # Checks-out your repository under $GITHUB_WORKSPACE, so your job can access it
+      - uses: actions/checkout@v3
+
+      - name: Set up OCaml ${{ matrix.ocaml-compiler }}
+        uses: ocaml/setup-ocaml@v2
+        if: runner.os != 'Windows'
+        with:
+          # Version of the OCaml compiler to initialise
+          ocaml-compiler: ${{ matrix.ocaml-compiler }}
+          opam-repositories: |
+            default: https://github.com/ocaml/opam-repository.git
+            beta: https://github.com/ocaml/ocaml-beta-repository.git
+
+      - name: Set up OCaml ${{ matrix.ocaml-compiler }}
+        uses: ocaml/setup-ocaml@v2
+        if: runner.os == 'Windows'
+        with:
+          # Version of the OCaml compiler to initialise
+          ocaml-compiler: ${{ matrix.ocaml-compiler }}
+          opam-repositories: |
+            default: https://github.com/fdopen/opam-repository-mingw.git#opam2
+            beta: https://github.com/ocaml/ocaml-beta-repository.git
+
+      - name: Install dependencies
+        run: |
+          opam depext conf-jq --yes # opam depext bug
+          opam pin menhirLib 20201216
+          opam install . --deps-only --with-test
+
+      - name: Build and test in release mode
+        run: opam exec -- dune runtest -p merlin,dot-merlin-reader
+
+      - name: Build in dev mode to check parser changes
+        if: matrix.os == 'ubuntu-latest'
+        run: |
+          opam exec -- dune build
+          git diff --exit-code
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..a585db3
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,20 @@
+_build
+_opam
+.merlin
+jbuild-workspace
+dune-workspace
+*.install
+*.tar.gz
+*.pyc
+*.cmly
+*.elc
+
+/ocamlmerlin
+/ocamlmerlin-server
+/ocamlmerlin-lsp
+/dot-merlin-reader
+
+# Ignore garbage files from editors
+*.un~
+*.swp
+*.swo
diff --git a/CHANGES.md b/CHANGES.md
new file mode 100644
index 0000000..ed75736
--- /dev/null
+++ b/CHANGES.md
@@ -0,0 +1,1147 @@
+merlin 4.7
+==========
+Thu Nov 24 13:31:42 CEST 2022
+
+  + merlin binary
+    - Replace custom "holes" AST nodes by extensions. This restores binary
+      compatibility and fixes issues with PPXs when using typed-holes.
+      (#1503)
+    - Fix a parsing issue when declaring the `(??)` custom prefix operator.
+      (#1507, fixes #1506)
+    - Fix variant constructors' comments grouping (#1516, @mheiber, fixes #1513)
+    - Filter-out duplicates from the `enclosing` command result (#1512)
+  + editor modes
+    - vim: load the plugin when necessary if it wasn't loaded before (#1511)
+  + test suite
+    - Add tests for constructors' documentation (#1511)
+    - Add test cases for label comments documentation (#1526, @mheiber)
+    - Add a test for the `enclosing` command (#1512)
+
+merlin 4.6
+==========
+Fri Jul  1 12:51:42 CEST 2022
+
+  + merlin binary
+    - Type printing: use `best_module_path` for paths from `Mty_alias` (#1470)
+    - Attempt at finding the 'real' capitalization of files on windows (#1462 by
+      @mlasson)
+    - Use newer `Seq`-based API of Yojson 2.0, avoiding the need for the
+      deprecated `Stream` module (#1475 by @Leonidas-from-XIV)
+    - unify parsing of `MERLIN_LOG` (#1480 by @ulugbekna)
+    - Fix type deduplication in `type-enclosing` results (#1483, fixes #1477)
+    - Ignore unknown configuration tags from dune configuration provider but not
+      from dot-merlin-reader (#1486)
+    - typing recovery: recover at the granularity of `core_type` (#1484)
+  + editor modes
+    - Fix `merlin-locate-in-new-window` is ignored (#1461 by @emturner,
+      fixes #1460)
+    - add method imenu items for emacs (#1481, @mndrix)
+    - emacs: Make the prefix argument to `merlin-locate` optional, both for
+      consistency with Emacs convention and for backwards compatibility. (#1476,
+      @antalsz)
+    - emacs: fix duplicated prefix path in imenu entries (#1495, @bcc32)
+
+merlin 4.5
+==========
+Tue Apr  5 20:59:42 CEST 2022
+
+  + merlin binary
+    - don't reset the environment when running merlin in single mode so that the
+      parent environment is forwarded the the child processes (#1425)
+    - filter dups in source paths (#1218)
+    - improve load path performance (#1323)
+    - fix handlink of ppx's under Windows (#1413)
+    - locate: look for original source files before looking for preprocessed
+      files (#1219 by @ddickstein, fixes #894)
+    - handle `=` syntax in compiler flags (#1409)
+    - expose all destruct exceptions in the api (#1437)
+    - fix superfluous break in error reporting (#1432)
+    - recognise binding operators in locate and occurrences (#1398, @mattiase)
+    - remove dependency on Result (#1441, @kit-ty-kate)
+  + editor modes
+    - fix an issue in Neovim where the current line jumps to the top of the
+      window on repeated calls to `MerlinTypeOf` (#1433 by @ddickstein, fixes
+      #1221)
+    - add module, module type, and class imenu items for emacs (#1244, @ivg)
+    - add prefix argument to force or prevent opening in a new buffer in locate
+      command (#1426, @panglesd)
+    - add type-on-hover functionality for vim (#1439, @nilsbecker)
+    - add a dedicated buffer `*merlin-errors*` containing the last viewed error
+      (#1414, @panglesd)
+  + test suite
+    - make `merlin-wrapper` create a default `.merlin` file  only when there is
+      no `dune-project` to let tests use `dune ocaml-merlin` reader. (#1425)
+    - cover locate calls on module aliases with and without dune
+    - Add a test expliciting the interaction between locate and Dune's generated
+      source files (#1444)
+
+merlin 4.4
+==========
+Mon Jul 26 11:12:21 PM CET 2021
+
+  + ocaml support
+    - add support for 4.13
+    - stopped actively supporting version older than 4.12
+  + merlin binary
+    - Mbrowse.select_leaf: correctly ignore merlin.hide (#1376)
+    - enable `occurences` to work when looking for locally abstract types
+      (#1382)
+    - handle `-alert` compiler flag (#1401)
+    - avoid a race condition when the process started to read a configuration
+      file crashes/is not found (#1378, @antalsz)
+    - log the backtrace even when the exception is a Failure (#1377, @antalsz)
+    - ignore `-error-style` compiler flag (#1402, @nojb)
+    - fix handling of record field expressions (#1375)
+    - allow -pp to return an AST (#1394)
+    - fix merlin crashing due to short-paths (#1334, fixes #1322)
+  + editor modes
+    - update quick setup instructions for emacs (#1380, @ScriptDevil)
+  + test suite
+    - improve record field destruction testing (#1375)
+
+merlin 4.3.1
+============
+Mon Jul 26 04:45:37 PM CET 2021
+
+  + merlin binary
+    - recover ill-typed patterns (#1317, #1342)
+    - more accurate type-enclosing for methods (#1328, fixes #1124)
+    - fix location of patterns in Occurrences (#1324, fixes ocaml/ocaml-lsp#375)
+    - fix location of module definitions done via functors (#1329, fixes #1199)
+    - fix -cmt-path dirs mistakenly added to build path (#1330)
+    - add new module holes that can replace module expressions (#1333)
+    - add a new command `construct` that builds a list of possible terms when
+      called on a typed hole (#1318)
+    - `refactor-open` improvements (#1313, #1314, #1366, #1372)
+      - do not make paths absolute, simply prefix with the identifier under
+      the cursor
+        ```ocaml
+        open Foo (* calling refactor-open qualify on this open *)
+        let _ = Foo.bar (* previously could result in [Dune__exe.Foo.bar] *)
+        ```
+      - do not return identical (duplicate) edits
+      - do not return unnecessary edits that when applied do not change
+        the document
+      - handle record fields properly
+      - handle multi-line paths
+      - `unqualify` should not qualify
+    - Handle `Persistent_env.Error` in `Typemod.initial_env` (#1355)
+    - locate: reset global state from all entry points (#1364)
+    - Windows: replace user name by its SID in socketnames (#1345, @ttamttam)
+  + editor modes
+    - vim: add a simple interface to the new `construct` command:
+      `MerlinConstruct`. When several results are suggested, `<c-i>`
+      and `<c-u>` can be use to change the depth of the recursive
+      construction. (#1318)
+    - vim: add support for the `merlin-locate-type` command:
+      `MerlinLocateType` (#1359)
+    - emacs: add a simple interface to the new `construct` command:
+      `merlin-construct`. (#1352)
+    - emacs: add support for the `merlin-locate-type` command. (#1359)
+    - emacs: fix issue with `merlin--highlight` and  various minor improvements
+        (#1367, @mattiase)
+  + test suite
+    - cover the new `construct` command (#1318)
+    - disable tests failing in Opam's CI due to nested dune projects (#1373)
+
+merlin 4.2
+==========
+Tue Apr 12 11:44:22 AM CET 2021
+
+  + merlin binary
+    - external configuration reading:
+      + use relative paths to communicate with Dune when possible. This solves
+        issues related to symlinks on Unix and improve Windows support (#1271,
+        fixes #1288)
+      + make the `workdir` configuration value when using the
+        `dune ocaml-merlin` configuration provider the same as when using
+        `dot-merlin-reader` so that ppxes behaves in the same way as before
+        (#1284, fixes ocaml/dune#4479, discussion in #1292)
+    - destruct:
+      + improve prefixing of generated constructors in Destruct by filtering
+        opened modules (#1277)
+      + make the destruct command more resilient to ill-typed expressions and
+        when called without nodes (#1304, fixes #1300)
+    - reintroduce some record recovery and improve completion (#1276)
+    - introduce a new AST node for holes (`_`), allow correct typing of these
+      holes and add a new `holes` command that returns the locations of all
+      holes in the current file along with their types (#1242, #1289)
+    - Mppx: don't restore cookies after invocation. Ppx are invoked only once
+      so there is no need to manage cookies. This small change should increase
+      performance and should not change any other behavior (#1309)
+    - Windows: system command variant: do not open a window console when
+      launching a ppx (#1270, fixes #714)
+    - fix same file documentation bug (#1265 by @ulugbekna, fixes #1261)
+  + editor modes
+    - vim: Add `MerlinNextHole` and `MerlinPreviousHole` commands to navigate
+      between holes. Jump to the first hole after destruct (#1287, #1303)
+    - emacs: Add `merlin-next-hole` and `merlin-previous-hole` commands to
+      navigate holes. Jump to the first hole after calling destruct. (#1291)
+    - emacs: modernization of the elisp code and conformance with coding
+      guidelines (#1247, #1310 by Steve Purcell )
+    - vim & emacs : new client-side "merlin use package" commands, restoring
+      previous behavior (#1272, fixes #1191)
+  + test suite
+    - cover constructor disambiguation and record fields (#1276)
+    - cover the new `holes` command and AST node (#1242, #1289)
+    - cover the document fix (#1265, #1315)
+
+merlin 4.1
+==========
+Tue Feb 16 10:33:11 AM CET 2021
+
+  + merlin binary:
+    - fix windows paths canonicalization (#1254)
+    - fix hanging on windows (#1256, #1263)
+
+merlin 4.0
+==========
+Tue Feb  2 03:13:37 PM CET 2021
+
+  + ocaml support
+    Detailed list of changes on
+    https://tarides.com/blog/2021-01-26-recent-and-upcoming-changes-to-merlin#dropping-support-for-old-versions-of-ocaml
+    Summary:
+    - any revision of Merlin now only supports one version of OCaml. Support for
+      other versions will be found in other branches
+    - stopped actively supporting version older than 4.11
+    - add support for 4.12
+  + merlin binary
+    - add keyword completion (disabled by default) (#1243)
+    - fix a bug which caused type-enclosing to sometimes look at an incorrect
+      node (#1232, fixes #1226)
+    - properly report leaked parsing error (#1223, fixes #1222)
+    - wrap `merlin_analysis` and `merlin_utils` library
+  + editor modes
+    - emacs: add missing mandatory argument for define-obsolete-function-alias
+      (#1250, by Atharva Shukla, fixes #1234)
+    - emacs: use "opam var" instead of "opam config var" (#1249, by Raja Boujbel)
+    - vim: fix CursorMoved semantics (#1213, by @ddickstein)
+    - vim: add :MerlinLocateImpl and :MerlinLocateIntf (#1208 by Matthew Ryan)
+  + test suite
+    - replace mdx usage by dune's cram mechanism
+
+merlin 3.4.2
+============
+Fri Nov 13 12:16:42 CEST 2020
+
+  + merlin binary
+    - simplify local store implementation and API (#1188, #1184)
+    - fix a destruct issue allowing ill-typed match completions (#1194)
+
+merlin 3.4.1
+============
+Thu Oct  1 15:31:42 CEST 2020
+
+  + dot-merlin-reader
+    - fix issue when multiple packages with pxxes are declared in the
+    configuration. (#1181, fixes #1179)
+
+merlin 3.4.0
+============
+Wed Sep 16 15:00:42 CEST 2020
+
+  + merlin binary
+    - fix completion of pattern matchings with exception patterns (#1169)
+    - delegate configuration reading to external programs via a simple protocol
+    and create a new package `dot-merlin-reader` with a binary that reads
+    `.merlin` files. (#1123, #1152)
+
+merlin 3.3.8
+============
+Thu Aug 27 14:48:42 CEST 2020
+
+  + merlin binary
+    - dune: restore compatibility with dune 1.8.0 (#1157, #1153)
+
+merlin 3.3.7
+============
+Tue Aug 25 15:13:42 CEST 2020
+
+  + ocaml support
+    - full support from OCaml 4.02 to OCaml 4.11 (#1153)
+
+merlin 3.3.6
+============
+Fri Jun 12 10:51:42 CEST 2020
+
+  + merlin binary
+    - dune: remove duplicated rules for profile=release (#1143)
+  + test suite
+    - fix a test that required Dune 2.5 (#1146)
+    - fix another test that lacked reproducibility (#1146)
+
+merlin 3.3.5
+============
+Tue Jun  9 15:13:42 CEST 2020
+
+  + ocaml support
+    - alerts are no-more ignored and are reported as warnings (#1138)
+  + merlin binary
+    - fix completion of names containing `-` (#1142)
+    - fix several type-enclosing bugs by performing context-analysis (#1108)
+    - lsp: add deprecation flag to outline items (#1087)
+    - lsp: add go-to typedef (`Locate_type`) (#1067)
+
+merlin 3.3.4
+============
+Tue Apr 14 15:25:05 CEST 2020
+
+  + ocaml support
+    - full support from OCaml 4.02 to OCaml 4.10 (#1117, #1127)
+    - fix desynchronized cache (#1120)
+    - short path for OCaml 4.09 and OCaml 4.10 (#1082, #1117)
+    - catch and test environment initialization errors (#1083, #1130)
+    - restore type levels after recovery (#1092)
+  + merlin binary
+    - fix syntax errors in 4.08 and 4.09 (#1081)
+    - complete-prefix command accepts -kind option to filter results (#1071)
+    - code cleanup (#1093, #1079, #1112)
+    - better handling of expression and pattern extra nodes during browse tree
+      traversal (#1091, #1121)
+    - improve context detection (e.g. appropriate namespace for lookup) for
+      various queries (#1104, #1110)
+    - add stdlib to locate source path (#1085)
+  + editor modes
+    - vim: tweak heuristic to select python version (#1111)
+    - emacs: marlin/call
+    - lsp: move server to its own repository (#1069),
+      https://github.com/ocaml/ocaml-lsp
+  + test suite
+    - dune rules for the test suite are now generated, deterministic and
+      can be run individually (#1068, #1070, #1072)
+    - fix incorrect command-line arguments in tests (#1073)
+    - better coverage of frontend features (#1075, #1078, #1088, #1089, #1126)
+
+Build no longer relies on implicit transitive_deps (#1065).
+
+merlin 3.3.4~4.10preview1
+=========================
+Mon Mar  2 14:26:32 CET 2020
+
+This is a preview release that adds support for OCaml 4.10.
+Short-path is disabled.  Other versions of OCaml are not supported.
+
+merlin 3.3.3
+============
+Fri Nov 29 17:35:58 CET 2019
+
+  + backend
+    - support OCaml 4.09 (#1055)
+    - fix parse errors in 4.08 (#1037)
+    - update 4.08 support to OCaml 4.08.1 (#1053)
+    - support `without_cmis`
+    - separate reading from caching in file-cache, use caching in
+      `Env.check_state_consistency` (#1044)
+    - simplify compiler state management (#1056, #1059)
+    - fix creation of initial environment, improve compatibility with
+      upstream 4.08 (#1052)
+  + frontend
+    - code re-organization (#1042)
+    - error command: select which kind of errors to show (#995)
+    - print value types in outline (#1014)
+    - fix process handling in windows (#1005)
+  + editor modes
+    - emacs
+      + bugfixes in merlin-imenu, merlin-xref (#1000, #1021, #1001)
+      + show types in merlin-imenu (#1013)
+      + reset buffer local configurations when resetting server (#1004)
+      + remove merlin-use-tuareg-imenu
+      + fix stack overflow (#1024)
+      + fix merlin-occurrence (#1043)
+    - vim
+      + display warn-error warnings as errors (#1009)
+  + testsuite
+    - cover file-cache and `check_state_consistency` (#1044)
+    - check inconsistent assumptions, test server versus single modes (#1047)
+
+merlin 3.3.2
+============
+Mon Jul 15 11:10:35 CEST 2019
+
+  + backend
+    - `**` globbing in .merlin won't look into hidden directories
+      (starting with a '.') (by Daniel Bünzli, #990)
+    - fallback to "/dev/null" configuration for findlib
+    - better 4.08 support:
+      + support for letop (let+, and+, ...) (#986)
+      + fix parsing recovery for 4.08 constructions (#987)
+      + catch an exception raised by 4.08 Printtyp trying to rename a
+        persistent identifier (#991)
+    - locate: treat local locations differently from external locations (coming
+      from a cmi), this fixes "jump to definition" on mutually recursive
+      bindings (#984)
+    - when completing an infix operator in a sub-module, wrap with () (#992)
+    - disable arity checks on externals (for Bucklescript compatibility)
+    - remove parser preprocessing (simplify compilation for OCaml < 4.08) (#997)
+  + editor modes
+    - emacs
+      + fix position computation in presence of tabs or multi-byte characters (#981)
+      + log arguments in "merlin-debug-last-commands" (#981)
+    - vim
+      + install reason.vim file (by Hezekiah M. Carty, #974)
+
+merlin 3.3.1
+============
+Mon Jun 17 17:13:33 CEST 2019
+
+  + backend
+    - catch findlib initialization failures and keep going on
+
+merlin 3.3.0
+============
+Fri May 31 11:09:08 BST 2019
+
+  + backend
+    - interpret `-pp` flag
+    - backtrack warnings in all versions, not just 4.06
+    - silence C compiler warnings (by David Allsopp and Bernhard Schommer)
+    - remove sturgeon support
+    - allow to select sections to log
+    - better error message on ocaml version mismatch
+    - locate:
+      + handle functors and functor applications
+      + do not use the location coming from the environment
+    - tweaked caching policy
+    - fix environment when a file disappears
+    - fix -short-paths handling of classes and class types (by Leo White)
+    - don't select deprecated paths in -short-paths (by Leo White)
+    - return type info in outline query (by Andrey Popp)
+    - properly handle new lines in the lexer
+    - better tracking of errors reported by the parser and by preprocessors
+    - add support for OCaml 4.08
+    - tweaked the recovery strategy in presence of syntax errors
+    - timing information in replies now includes wall clock time.
+    - dump command can new dump the parsetree post preprocessing
+
+  + editors modes
+    - emacs
+      + fix merlin-xref.el install (by Emilio Jesus Gallego Arias)
+      + keep labels matching the prefix the user has typed rather than
+        dropping them (by Mitchell Plamann)
+      + remove unused `merlin--overlay` function (by Wilfred Hughes)
+      + show the number of errors in the modline (by Wilfred Hughes)
+      + call a logger on the client side if one is defined
+      + allow user to disable completion inside comments and strings
+      + show errors and types even when buffer is narrowed (by Wilfred Hughes)
+      + make sure PATH is updated when merlin-command is 'opam
+
+    - vim
+      + better FindBinary
+      + make the log buffer a scratch buffer (by Tom Johnson)
+      + execute buffer switching silently (by Fabian)
+      + restore view after updating merlin type buffer (by Fabian)
+
+  + testsuite
+    - Switched to mdx with cram syntax.
+
+Special thanks to Rudi Grinberg for helping us in reviewing and merging
+pull-requests.
+
+merlin 3.2.2
+============
+Tue Oct  9 11:25:12 BST 2018
+
+Update cmt magic number for 4.07.1
+
+merlin 3.2.1
+============
+Mon Oct  8 11:44:16 BST 2018
+
+Fix build on OCaml 4.02 to 4.04
+
+merlin 3.2.0
+============
+Mon Oct  8 10:41:24 BST 2018
+
+Switched build to dune (thanks to @nojb).
+Added support for 4.07.1
+Various bugfixes in the backend and in the editor modes.
+
+
+merlin 3.1.0
+============
+Wed Jun 20 14:05:04 BST 2018
+
+  + backend
+    - new "polarity search" feature: provides a Hoogle-like type-based search
+      for libraries that are in merlin's scope.
+      See https://github.com/ocaml/merlin/blob/master/doc/features.md#polarity-search
+    - new "open refactoring" feature: helps cleaning the code in the scope of an
+      open statement.
+      See https://github.com/ocaml/merlin/blob/master/doc/features.md#open-refactoring
+    - spell-checking: a simple spell-checker has been added to suggest
+      corrections when nothing can be directly completed.
+    - type-driven record completion: merlin will now make use of type
+      information from the context for narrowing and refining completion
+      candidates.
+    - support for `#require` directive in a source file, and will treat it as a
+      package use
+    - Add support for OCaml 4.07
+    - locate: various minor bugfixes, as well as the following general
+      improvements:
+      + improved context detection
+      + better tracking of namespaces
+      + fixed support for local bindings
+      + fixed support of disambiguated record fields and variant constructors
+      + improved support for functors: merlin will now jump through functor
+        application to the functor definitions and in some cases go back to the
+        argument that was given (if it is simply reexported).
+    - backport fixes of OCaml 4.06.1 to the 4.06 backend
+    - various minor bugfixes
+
+  + editor modes
+    - emacs
+      + proper handling of multibyte strings (by @Chris00)
+      + bind "q" to close type buffer (by @MiloDavis)
+      + make goto-point encoding independent
+      + add reason-mode to the guessed favorite mode list (by @Khady)
+      + sped up some tight loops (by @rgrinberg)
+      + add support for x-ref backend (by @rgrinberg)
+    - vim
+      + fix support for Neomake (by @bobbypriambodo and @statianzo)
+      + fix encoding issues in filepaths (by @Thelyria)
+      + fix handling of enclosing-type cache (by @ELLIOTTCABLE)
+      + add <silent> to prevent flashing when highlighting an enclosing (by @bluddy)
+
+Thanks to the people who contributed to this release: ELLIOTTCABLE, Louis Roché,
+Rudi Grinberg, Yotam Barnoy, Leo White, Daniel Below, Andreas Hauptmann,
+Christophe Troestler, Bobby Priambodo, Milo Davis.
+
+merlin 3.0.5
+============
+Mon Nov 13 18:30:02 CET 2017
+
+Fix magic numbers for 4.06 (issue #749, reported by @Fourchaux).
+
+merlin 3.0.4
+============
+Sun Nov 12 10:14:03 CET 2017
+
+Add support for 4.06.
+Use Leo White's short-path for 4.05.
+Various bug fixes (in locate, in emacs serialization).
+
+merlin 3.0.3
+============
+Mon Oct  2 12:56:23 CEST 2017
+
+The major change Windows support is contributed by David Allsopp.
+
+Other changes are a bunch of fixes:
+- compilation on FreeBSD contributed by Malcolm Matalka
+- improvement to emacs mode contributed by Olivier Andrieu, Christophe
+  Troestler and Steve Purcell
+- improvement to vim mode by Fabian Hemmer and Gregory Nisbet
+- fixes to ppx invocation by Keigo Imai
+- fixes to Merlin s-expr dialect to bring UTF-8 compatibility with Emacs (WIP)
+
+merlin 3.0.2
+============
+Wed Aug  2 15:09:07 CEST 2017
+
+Bug fix after 3.0.1:
+- CMT magic number for 4.05 was wrong
+- handle merlin.focus, merlin.ignore, merlin.loc/merlin.relaxed-loc and merlin.syntax-error
+- missing include preventing build on some platforms contributed by Bernhard Schommer
+
+merlin 3.0.1
+============
+Wed Jul 26 18:25:23 CEST 2017
+
+Bug fix release after 3.0.0 major release:
+- portability fixes by David Allsop in configure script and vim mode
+  (tough Windows support is not ready yet)
+- preliminary support for findlib toolchains with FINDLIB_TOOLCHAIN .merlin
+  directive
+- make ocamlmerlin.c frontend more portable
+- various fixes to the frontend
+
+merlin 3.0.0
+============
+Mon Jul 24 11:21:58 CEST 2017
+
+The major change is a new protocol that moves process management inside Merlin
+codebase, saving a lot of pain in Emacs and Vim. There are not much new user
+facing features.
+
+Windows support is not yet available.
+
+In editor configuration is now done with merlin-flags, merlin-extensions and
+merlin-use in Emacs and :MerlinFlags, :MerlinExtensions and :MerlinPackages in
+Vim.
+In previous versions, enabled extensions, flags and packages were retained
+while now only the last command is remembered.
+
+"M-x merlin-use a", "M-x merlin-use b" should be replaced by "M-x merlin-use a,b".
+":MerlinUse a", ":MerlinUse b" should be replaced by ":MerlinUse a b".
+
+The old protocol is still supported, so existing editor modes should not be
+affected (tested with Atom, Visual Studio and Sublime-text).
+
+Other main changes:
+- Support for OCaml 4.05 was added
+- Merlin uses a new implementation of short-path by Leo White which addresses
+  performance problems
+- Merlin now works with the upstream version of Menhir
+- numerous cleanup and refactoring to decrease the amount of changes to
+  upstream typechecker
+- emacs-imenu feature was contributed by tddsg. It is similar the "outline"
+  feature in vim for navigating in a buffer.
+
+Thanks to the many contributors (Jochen Bartl, tddsg, Ximin Luo, Jason Staten,
+Leo White, Leandro Ostera, Jacob Bass, Xavier Guérin, Yotam Barnoy, Jacques
+Pascal Deplaix, David Allsopp, ...).
+
+merlin 2.5.5
+============
+Wed Jun 14 14:54:32 CEST 2017
+
+Minor release:
+- fix flag parsing in .merlin (#661)
+
+merlin 2.5.4
+============
+Tue Apr 25 15:07:18 CEST 2017
+
+Minor release:
+- handle hole in 4.04
+- bug fixes in emacs mode
+- introduce merlin-imenu
+
+merlin 2.5.3
+============
+Mon Nov 28 09:54:57 CET 2016
+
+Minor release:
+- fix Windows build with MSVC (#605).
+- fix module level errors escaping
+
+merlin 2.5.2
+============
+Wed Nov 16 14:44:19 CET 2016
+
+This release mainly brings support for OCaml 4.04.
+Internal code was simplified and bugs were fixed in the meantime (cache
+invalidation, ast traversal, type error recovery, certain cases of completion,
+ppx working directory, locate, ...).
+
+merlin 2.5.1
+============
+Tue Oct 18 12:04:19 CEST 2016
+
+Bug fix release before major version.
+
+  - reintroduce lazy substitution to fix performance issue
+  - add "FINDLIB_PATH" directive to .merlin (contributed by Gerd Stolpmann)
+  - relax arity checks on externals (harmless, requested by Hongbo Zang)
+  - handle case insensitivity of OS X (fix longstanding bug)
+  - fix build under Cygwin
+  - minor cleanup, portability and usability improvements in build system and
+    editor modes
+
+merlin 2.5.0
+============
+Mon Jun 13 22:26:33 CEST 2016
+
+  + frontend:
+    - now all commands can take a context, this reduce the amount of state
+      in the command interpreter. Long term goal is to make protocol stateless
+    - merlin now supports customizable "readers": processes responsible for
+      parsing and pretty-printing. Main use-case is Reason, cppo/optcomp support
+      might be added later
+  + backend:
+    - drop support for 4.00 / 4.01
+    - support for 4.03 has been added
+    - new implementation of type recovery, should diverge less from upstream
+    - support for 4.02 was reimplemented to use the same design
+    - menhir's fork has been synchronized with upstream, recovery algorithm
+      is completely new
+  + vim: add support for python3, update to new protocol
+  + emacs: update to new protocol, bug fixes
+
+merlin 2.3.1
+============
+Wed Nov 25 15:01:47 CET 2015
+
+Bug fix release, fix builds under Mac OS X and Windows.
+
+  + backend:
+    - improve support for module aliases in completion, locate and short-path
+    - change management of flags
+    - Cuillère ou Dorade
+    - fix grammar for 4.02.3, support attributes on core_types
+
+  + emacs & vim: minor fixes
+
+merlin 2.3
+==========
+Wed Oct 28 14:32:48 CET 2015
+
+  + backend:
+    - locate: fix assert failure on first class modules inclusion
+    - outline: add support for classes and object types
+    - nonrec: enable by default for OCaml >= 4.02.2
+    - error reporting: less aggressive filtering on ghost locs
+    - finer-grained tracking of usage (values, opened modules, etc)
+    - significant improvement in the handling of PPX extensions:
+        + fix shell commandline and working directory
+        + normalize parsetree locations
+        + implement caching of intermediate rewriting
+    - merged support for MetaOCaml
+    - path to the standard library can now be specified with STDLIB command
+      in .merlin
+    - BrowseT: split into Browse_node (OCaml version specific) and
+      Merlin_browse, extract recursion scheme
+    - add Jump command, contributed by Tomasz Kołodziejski
+    - contextual-commands: optionnally specify the context (file, project)
+      in which each command is interpreted
+    - better support for trunk
+    - many bugfixes
+
+  + documentation:
+    - update ARCHITECTURE and PROTOCOL documentations
+
+  + emacs:
+    - make use of contextual-commands, non backward compatible protocol change
+    - new merlin-set-flags command
+    - split into multiple files
+    - cleanup symbol namespaces:
+        + merlin- for user targeted definitions
+        + merlin-- for internal definitions,
+        + merlin/ for API definitions
+    - usability tweaks, notably on error display and navigation
+    - general cleanup and bugfixes
+
+  + vim:
+    - expose custom .merlin loading through buffer variable
+    - cleanup and bugfixes, notably process liveness check and restart
+
+This release also contains contributions from: Rudi Grinberg, Fourchaux,
+Christopher Reichert, David Allsopp, Nick Borden, Mario Rodas, @Twinside,
+Pierre Chambart, Philipp Haselwarter, Tomasz Kołodziejski and Syohei Yoshida.
+
+merlin 2.2
+==========
+Wed May 20 09:44:55 EDT 2015
+
+  + backend:
+    - completion
+        + return the type of the expected argument when completing an
+          application.
+          This allows us to offer completion for named and optional parameters,
+          as well as polymorphic variants
+        + optionally associates ocamldoc comments to candidates
+        + adds field completion inside records ( #296 )
+    - locate:
+        + partially rewritten, introduces a new kind of cache
+          (so potentially noticeably bigger memory consumption)
+        + better handling of functors
+        + handle local modules
+        + fix occasional "inconsistent assumptions"
+    - error reporting:
+        + handle environment errors (inconsistent assumptions, …)
+        + filter duplicated messages
+        + fix type error reporting:
+            "this expression has type t = t but an expression was expected of
+            type u = u"
+          we now only print the equality when it adds some information
+        + less noisy pattern recovery: when every pattern is recovered, consider
+          that the matched expression is the the source of the problem, and
+          retry typing with "'a" as the type of the matched expression.
+    - add support for trunk
+    - add a "document" command: takes an ident and return its documentation (if
+      any)
+    - destruct: use more precise environments ( #389 )
+    - warnings:
+        + check signature inclusion to prevent spurious warnings about unused
+          declarations
+        + backport 4.02-style warning management
+        + add a dump command
+    - nonrec: update implementation to more-or-less match the upstream one
+      (upstream >= 4.02.2)
+    - parser: improve marking heuristic in presence of ;; or toplevel
+      directives.
+    - typeof: during verbose expansion, also print the type declaration if we
+      have a type constructor
+
+  + emacs:
+    - fix bindings of every completion backend
+    - bind ocamldoc comments to company (optional)
+    - detect race conditions when running synchronous commands
+    - cleanup "merlin-process-started-p"
+    - locate error messages were silently ignored, they are now printed
+    - drop text properties from commands sent to merlin (pull request #383 by
+      milanst)
+    - Tell merlin the content of the buffer when opening a new buffer.
+      This allows merlin idle-job to preload content if nothing else is
+      requested.
+    - remove call to merlin from the lighter
+
+  + vim:
+    - fix ctrlp binding for locate
+    - add (dwim) completion on :TypeOf
+    - while completing, candidates documentation can be displayed in the
+      "preview" window
+    - prefix every command name by "Merlin" ( #379 )
+    - Tell merlin the content of the buffer when opening a new buffer.
+      This allows merlin idle-job to preload content if nothing else is
+      requested.
+
+merlin 2.1.2
+============
+Tue Mar  3 12:20:08 UTC 2015
+
+  Main new feature is a faster short-path, and also a lot of buxfixes.
+
+  + backend:
+    - merge new implementation of short-path
+    - infrastructure for doing background computations
+    - fix exhaustivity checking of GADTs
+    - fix Typecore error reporting in 4.00.1 & 4.01.0
+    - delayed checks are now enabled (e.g warnings)
+    - special handling of "myocamlbuild.ml" (issue #363)
+    - better sharing/caching of global modules
+    - more customizable .merlin loading
+    - minor fixes (better error messages, typos, "fake" extensions)
+
+  + build system:
+    - allow bytecode builds, support OpenBSD (pull request #364 by madroach)
+    - Refuse/Resist... environment variables redefinition
+
+  + vim:
+    - fix charset/encoding detection (pull request #352 by rgrinberg)
+    - minor fixes and simplification
+
+  + emacs:
+    - better integration with emacs error management and asynchronous handling
+    - expose custom .merlin loading in merlin-grouping-function
+    - fixes, printf-debugging cleanup
+
+merlin 2.1.1
+============
+Wed Jan 28 08:59:20 GMT 2015
+
+  + backend:
+    - locate: merlin refused to locate things when it had no context (happens
+      when the buffer didn't parse for example) claiming it was at the
+      "definition point". Fixed.
+    - locate: use the cmt path when no ml file was found in the source path
+      (this might not be such a good idea, the cases when this work are the ones
+      where the user configuration is wrong...)
+    - destruct: qualify introduced constructors
+    - destruct: eliminate "impossible" GADT branches
+    - parser: handle '%' as an operator for 4.00 and 4.01 ( #345 )
+
+  + fake:
+    - add typerep support
+    - never generate `'_` type variables.
+
+  + vim:
+    - show duplicated outlines in CtrlP
+    - sort outlines by name length in CtrlP
+    - when split method is set to 'tab' *always* open a new tab.
+
+merlin 2.1
+===========
+Sun Jan 11 22:20:23 CET 2015
+
+  + backend:
+    - add PPX support
+    - make use of context before locating (#308, #316, #318).
+    - generate match patterns for arbitrary expressions and missing patterns
+      for incomplete matchings (#123).
+    - reintroduce type expansion (asking the times of the same expression
+      several times will resolve type aliases).
+    - "smart" (a.k.a "do what I mean") completion:
+          `L.m` will expand to `List.map ; List.m... ; ListLabels.map ; ...` if
+          `L` doesn't exist.
+    - simplify incremental parser and typer interfaces
+    - locate: better handling of packed modules (supposedly)
+    - more precise recovery on patterns (before the recovery was done at the
+      expression level, so the whole match was discarded, now only the pattern
+      is)
+
+  + emacs:
+    - don't use fringe in emacs23 (broken)
+    - remove obsolete aliases:
+        merlin-occurences => merlin-occurrences
+        merlin-to-end => merlin-error-check
+    - disable merlin-mode on type buffer
+    - require caml-types (needed for highlighting) (#331).
+
+  + misc:
+    - update README (#301).
+
+  + vim:
+    - add a type history buffer (#313, #322) -- only available for vim > 7.3.
+    - highlight types when displaying them in the command line -- only for vim >
+      7.3
+    - add tab completion for the argument of the `:Locate` command
+    - add support for text objects based on type enclosing
+    - introduce an interactive version of `:Rename`
+    - locate results can now be shown in a new or existing tab (#335)
+    - use `fileencoding` where necessary (#332)
+    - ctrlp bindings for outline and locate
+
+This release also contains contributions from: Geoff Gole, Rudi Grinberg, Markus
+Mottl, Roman Vorobets and Arthur Wendling.
+
+merlin 2.0
+==========
+Fri Oct 31 11:04:21 CET 2014
+
+This is a major release which we worked on for several months, rewriting many
+parts of the codebase. An exhaustive list of changes is therefore impossible to
+give, but here are some key points (from an user perspective):
+
+  - support for OCaml 4.02.{0,1}
+  - more precise recovery in presence of syntax errors
+  - more user-friendly messages for syntax errors
+  - locate now works on MLI files
+  - automatic reloading of .merlin files (when they are update or created), it
+    is no longer necessary to restart merlin
+  - introduced a small refactoring command: rename, who renames all occurrences
+    of an identifier. See: http://yawdp.com/~def/rename.webm
+
+
+This release also contains contributions from: Yotam Barnoy, Jacques-Pascal
+Deplaix, Geoff Gole, Rudi Grinberg, Steve Purcell and Jan Rehders.
+
+merlin 1.7.1
+============
+Fri Aug 22 10:01:58 CEST 2014
+
+Minor update to installation procedure
+
+merlin 1.7
+==========
+Mon Aug 18 17:08:00 BST 2014
+
+This release also marks the apparition of a proper opam install script.
+
+  + backend:
+    - fixes on locate
+    - print manifests even when -short-paths is set
+    - add an "occurrences" command to list every occurrence of an identifier ( #156 )
+    - new "version" command ( #180 )
+    - add CPU time to log files ( #192 )
+    - better error reporting from locate ( #190 )
+
+  + documentation:
+    - update vim doc file ( #204 )
+    - typo correction in the README by Philippe Wang ( #195 )
+
+  + emacs:
+    - fix most byte compilation warnings, by Geoff Gole ( #209 )
+    - numerous fixes
+
+  + vim:
+    - add error list independent from syntastic
+    - fix completion for vim<=703 (#223)
+
+merlin 1.6
+==========
+Tue Mar 11 14:33:55 CET 2014
+
+  + backend:
+    - small memory leak fix
+    - major improvements and bugfixes for locate (i.e. "jump to definition")
+
+  + emacs:
+    - fixed bug preventing merlin restart ( #167 )
+    - removed keybindings reserved to users ( #170 )
+      the full list is:
+        + `C-c l` previously bound to `merlin-use`
+        + `C-c r` previously bound to `merlin-restart-process`
+        + `C-c t` previously bound to `merlin-type-expr`
+    - removed keybindings on `C-<up>` and `C-<down>` as these already have a
+      meaning in emacs ( #129 )
+      They were bound to `merlin-type-enclosing-go-up` and
+      `merlin-type-enclosing-go-down` respectively.
+    - the emacs mode is now compiled (contribution from Jacques-Pascal Deplaix
+      #158 , with a follow up from Rudy Grinberg #165 )
+    - improved efficiency of completion at point
+
+  + extensions:
+    - added support for variantslib ( #132 )
+    - updated fieldslib support ( #169 , #185 )
+    - fix pa_lwt translation ( #182 )
+    - added support for pa_enumerate ( #187 )
+
+  + vim:
+    - the split method for locate can now be configured
+
+merlin 1.5
+==========
+Sat Dec 14 19:45:06 CET 2013
+
+  + backend:
+    - better handling of paths (both sources and build)
+    - split build path into cmi and cmt path.
+      New directives "CMI" and "CMT" are now available in .merlin files ("B"
+      still works as previously)
+    - doesn't get confused anymore when the user switch between buffers (the
+      state is cleaned)
+
+  + emacs:
+    - adds ability to enable/disable extensions manually
+    - adds a command to clear all the errors from a buffer
+    - displaying of errors can now be disabled
+
+  + extensions
+    - updated bin_prot for version >= 109.45.00
+    - bugfix for [with compare] in presence of parametrized types
+    - added support for "here" (when activated adds
+      [val _here_ : Lexing.position])
+    - added support for [assert_lwt]
+    - fixed typing of [while_lwt]
+
+  + vim:
+    - vim plugin can be installed into a custom directory and has its own
+      makefile target (contribution from Vsevolod Velichko)
+    - added "ClearEnclosing" command to remove merlin's overlay after a call to
+      TypeOf.
+
+merlin 1.4.1
+============
+Thu Sep 26 21:29:56 BST 2013
+
+  + documentation:
+    - updates of the emacs section of the readme by Ronan Lehy.
+
+  + emacs:
+    - bugfix for ac-mode: merlin-ac-prefix wasn't called.
+    - better formatting for completion suggestions.
+
+  + vim:
+    - bugfix for the "selectPhrase" command, an overflow on 32b plateform was
+      causing complete desynchronisation between vim and merlin.
+    - better formatting for completion suggestions.
+
+merlin 1.4.0
+============
+Tue Sep 24 23:02:04 BST 2013
+
+  + backend:
+    - lazy processing of open directives makes merlin much faster
+    - simplified buffer management
+    - tweak signal handling to improve windows compatibility
+    - track verbosity of query: repeated queries are considered more "verbose"
+    - type expansion: expand type aliases for verbose query
+    - add support for OUnit-like Benchmark extension
+    - more tolerant type checker, to provide completion on ill-typed
+      expressions
+    - proper version reporting with git revision
+    - refactored logging subsystem
+    - add support "val constructs" in implementation: report errors but add
+      definition to current environment
+    - add FLG, EXT and PRJ in .merlin
+    - "locate" command now works in much more situations
+    - one distribution for 4.00 and 4.01, introduced common interface between
+      both, typers now live in https://github.com/def-lkb/merlin-typers
+    - new implementation of the main merlin state tracking ast & types
+    - better error reporting thanks to a contribution from Ronan Lehy
+
+  + documentation:
+    - started a wiki (https://github.com/def-lkb/merlin/wiki)
+    - wrote 'from-scratch' guides to ease setting-up merlin in your editor
+
+  + emacs
+    - during completion with auto-complete, you can hit C-c C-l on a candidate
+      to jump on its definition
+    - made communication with merlin asynchronous (using transfer queues) hence
+      improving responsiveness
+    - when running a merlin command, the errors present in all phrases but the
+      current one are displayed
+    - fixed buffer cleaning
+    - successive call to C-c C-t do not climb the typed tree but improve merlin's
+      verbosity. To move inside the tree use C-down and C-up (which implements
+      phrase movement if there is no enclosing started).
+    - customize data for merlin
+    - refactoring and numerous bugfixes
+
+
+merlin 1.3.1
+============
+
+
+  Minor release, but merlin is now compatible with ocaml versions > 4.00.1.
+  The only noticeable changes since 1.3 is the use of short paths even with
+  version 4.00.1 of ocaml.
+
+merlin 1.3
+==========
+
+  + backend:
+    - added a "locate" command to find the definition location of the given
+      identifier
+      works on the local buffer out of the box and at project level if it the
+      build directories contain cmt files
+
+  + emacs:
+    - various bugfixes
+    - aesthetic changes for highlighting
+    - introduced "semantic movements":
+      add commands (and keybindings) to go to the next/previous phrase
+    - support for completion in emacs 23
+    - reporting of syntax errors
+    - removed "idle-typing" feature
+    - asynchronous fetching of types so that long signatures
+      won't make emacs hang
+
+  + extensions:
+    - add support for "type nonrec" declaration
+    - add support for "with compare" from type-conv
+    - add partial support for "with fields" from type-conv
+
+  + misc:
+    - added specific support for omake's polling mode
+
+  + vim:
+    - ':TypeOf' command now accepts an (optional) argument and tries to type it
+      in the current context (i.e. at cursor position)
+    - better catching of errors
+
+merlin 1.2
+==========
+
+  + emacs:
+    - add ML, MLI and merlin-goto-project-file commands
+    - prints the type of completed entry on completion
+    - various bugfixes
+
+  + extensions:
+    - merged support for ignoring P4_QUOTATION
+    - merged support for js_of_ocaml syntax
+    - support top-level lwt binding
+    - merged support for oUnit
+
+  + misc:
+    - introduced 'REC' flag in .merlin:
+        tells merlin to concatenate the current .merlin with the ones present in
+        parents directories
+    - added specific support for omake's polling mode.
+
+  + vim:
+    - bugfix for omnicompletion on versions <= 703
+
+merlin 1.1
+==========
+
+  + emacs:
+    - Ported the completion to the usual `completion-at-point' system, disabled
+      auto-complete-mode-by-default
+    - reset now tells merlin about the current buffer name
+    - merlin-mode comes with a menu
+    - improved documentation of the mode
+
+  + backend:
+    - code cleanup
+    - method completion
+
+  + vim plugin: refactored synchronization code out
+
+merlin 1.0
+==========
+First release
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..c334d32
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,19 @@
+Copyright (C) 2013 Frédéric Bour, Thomas Refis and Simon Castellan.
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in
+all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..fbec140
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,21 @@
+all: build ocamlmerlin ocamlmerlin-server dot-merlin-reader
+
+build:
+	dune build --always-show-command-line
+
+ocamlmerlin ocamlmerlin-server dot-merlin-reader:
+	ln -s _build/install/default/bin/$@ ./$@
+
+clean:
+	dune clean
+
+test: build
+	dune runtest
+
+preprocess:
+	dune build --always-show-command-line @preprocess
+
+promote:
+	dune promote
+
+.PHONY: all build dev clean test promote
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..816a25d
--- /dev/null
+++ b/README.md
@@ -0,0 +1,326 @@
+![merlin completion in vim](https://github.com/ocaml/merlin/wiki/vim_complete.png)
+
+[Merlin](https://ocaml.github.io/merlin/) is an editor service that provides modern IDE features for OCaml.
+
+Emacs and Vim support is provided out-of-the-box. To get editor support with Merlin in
+other editors, see [this](#other-editors).
+
+Easy installation with Opam
+===========================
+
+If you have a working [Opam](https://opam.ocaml.org/) installation, install Merlin running the following two commands in terminal:
+
+```shell
+opam install merlin
+opam user-setup install
+```
+
+[opam-user-setup](https://github.com/OCamlPro/opam-user-setup) takes care of configuring Emacs and Vim to make best use of your current install. You can also [configure the editor](#editor-setup) yourself, if you prefer.
+
+Manually building and installing Merlin
+=======================================
+
+Since version 4.0, merlin's repository has a dedicated branch per version of
+OCaml, and the branch name consist of the concatenation of OCaml major version
+and minor version. So, for instance, `OCaml 4.11.*` maps to branch `411`.
+The main branch is usually synchronized with the branch compatible with the
+latest (almost-)released version of OCaml.
+
+Note: if you're using an older version of OCaml (between 4.02 and 4.10) you will
+want to build the 3.4 branch, although it won't contain the most recent
+features.
+
+Compilation
+-----------
+
+Dependencies: ocamlfind, yojson >= 2.0.0, dune >= 2.7.
+
+```shell
+dune build -p dot-merlin-reader,merlin
+```
+
+Note: if you want to work on merlin, you'll want to avoid the `-p merlin`, to
+build in dev mode, with some extra warnings enabled. In that case you'll also
+need an extra dependency: menhir.
+
+Installation
+------------
+
+If you haven't encountered any errors in the previous step, just run:
+
+```shell
+dune install -p dot-merlin-reader,merlin
+```
+
+You can pass an explicit prefix to dune, using `--prefix`. It defaults to
+your current opam switch.
+
+Editor setup
+============
+
+To set up Emacs and Vim, you need to instruct them to run the appropriate script when an OCaml file is opened.
+
+In the rest of the document, \<SHARE\_DIR\> refers to the directory where Merlin data files are installed.
+
+It will usually be:
+
+- printed by the command `opam var share`, if you used opam
+- "\<prefix\>/share" if you explicitly specified a prefix when configuring Merlin
+
+### Vim setup
+
+Makes sure that ocamlmerlin binary can be found in PATH.
+
+The only setup needed is to have the following directory in vim runtime path (append this to your .vimrc):
+
+    :set rtp+=<SHARE_DIR>/merlin/vim
+
+The default configuration can be seen in:
+
+    <SHARE_DIR>/merlin/vim/plugin/merlin.vim
+
+After adding merlin to vim runtime path, you will probably want to run `:helptags <SHARE_DIR>/merlin/vim/doc` to register Merlin documentation inside vim.
+
+A more comprehensive documentation can be found on the [vim-from-scratch wiki](https://github.com/ocaml/merlin/wiki/vim-from-scratch).
+
+### Emacs setup
+
+#### Manual setup
+
+Merlin comes with an emacs library (file: emacs/merlin.el) that implements a minor-mode that is supposed to be used on top of tuareg-mode.
+
+All you need to do is add the following to your .emacs:
+
+```emacs
+(push "<SHARE_DIR>/emacs/site-lisp" load-path) ; directory containing merlin.el
+(setq merlin-command "<BIN_DIR>/ocamlmerlin")  ; needed only if ocamlmerlin not already in your PATH
+(autoload 'merlin-mode "merlin" "Merlin mode" t)
+(add-hook 'tuareg-mode-hook #'merlin-mode)
+(add-hook 'caml-mode-hook #'merlin-mode)
+;; Uncomment these lines if you want to enable integration with the corresponding packages
+;; (require 'merlin-iedit)       ; iedit.el editing of occurrences
+;; (require 'merlin-company)     ; company.el completion
+;; (require 'merlin-ac)          ; auto-complete.el completion
+```
+
+A more comprehensive documentation can be found on the [emacs-from-scratch wiki](https://github.com/ocaml/merlin/wiki/emacs-from-scratch).
+
+#### Setup via package.el
+
+An installable core `merlin` package is available via
+[MELPA](https://melpa.org), along with further small integration
+packages `merlin-company`, `merlin-iedit` and `merlin-ac` which users
+can install according to their needs.
+
+Having installed the required packages, the following code in your
+emacs startup file is sufficient:
+
+```el
+(setq merlin-command "<BIN_DIR>/ocamlmerlin")  ; needed only if ocamlmerlin not already in your PATH
+(add-hook 'tuareg-mode-hook #'merlin-mode)
+(add-hook 'caml-mode-hook #'merlin-mode)
+;; Uncomment these lines if you want to enable integration with the corresponding packages
+;; (require 'merlin-iedit)       ; iedit.el editing of occurrences
+;; (require 'merlin-company)     ; company.el completion
+;; (require 'merlin-ac)          ; auto-complete.el completion
+```
+
+### Other editors
+
+Merlin only supports Vim and Emacs out-of-the-box. This section describes shortly how to get
+merlin-based editor support in other editors.
+
+#### Visual Studio Code
+
+OCaml has official support for Visual Studio Code through an extension called `OCaml Platform` available in the [Visual Studio Marketplace](https://marketplace.visualstudio.com/items?itemName=ocamllabs.ocaml-platform). Project source is available [here](https://github.com/ocamllabs/vscode-ocaml-platform).
+*Note* that it requires [OCaml-LSP](https://github.com/ocaml/ocaml-lsp), an official
+[Language Server Protocol(LSP)](https://microsoft.github.io/language-server-protocol/specifications/specification-current/)
+implementation for OCaml based on merlin. It can be installed by running `opam install ocaml-lsp-server`.
+
+#### Editors without official support
+
+Consider using [OCaml-LSP](https://github.com/ocaml/ocaml-lsp) along with your editor's
+plugin for LSP if there is one.
+
+The wiki also contains pages for:
+
+- [Acme](https://github.com/ocaml/merlin/wiki/acme-from-scratch)
+- [Atom](https://github.com/ocaml/merlin/wiki/atom-from-scratch)
+- [Spacemacs](https://github.com/ocaml/merlin/wiki/spacemacs-from-scratch)
+
+External contributors have implemented modes for more editors:
+
+- [ocaml-merlin package for Atom](https://atom.io/packages/ocaml-merlin)
+- [nuclide for Atom](https://nuclide.io/) includes Merlin support
+- [Sublime Text 3](https://github.com/cynddl/sublime-text-merlin)
+
+Next steps
+==========
+
+To use Merlin with a multi-file project, it is necessary to have a [.merlin](https://github.com/ocaml/merlin/wiki/project-configuration) file
+unless your project is built using dune.
+Note that, in a project using Dune, user-created `.merlin` files will take precedence over the configuration provided by Dune to Merlin. 
+
+Read more in the [wiki](https://github.com/ocaml/merlin/wiki) to learn how to make full use of Merlin in your projects.
+
+Development of Merlin
+=====================
+
+Most of the development happens through the [github page](https://github.com/ocaml/merlin).
+
+The [mailing list](https://lists.forge.ocamlcore.org/cgi-bin/listinfo/merlin-discuss) welcomes general questions and discussions.
+
+Merlin Labels
+-------------
+
+[Area/Emacs](https://github.com/ocaml/merlin/labels/Area%2FEmacs): Related to Emacs
+
+[Area/Vim](https://github.com/ocaml/merlin/labels/Area%2FVim): Related to Vim
+
+[Kind/Bug](https://github.com/ocaml/merlin/labels/Kind%2FBug): This issue describes a problem
+
+[Kind/Docs](https://github.com/ocaml/merlin/labels/Kind%2FDocs): This issue describes a documentation change
+
+[Kind/Feature-Request](https://github.com/ocaml/merlin/labels/Kind%2FFeature-request): Solving this issue requires implementing a new feature
+
+[Kind/To-discuss](https://github.com/ocaml/merlin/labels/Kind%2FTo-discuss): Discussion needed to converge on a solution; often aesthetic. See mailing list for discussion
+
+[Status/0-More-info-needed](https://github.com/ocaml/merlin/labels/Status%2F0-More-info-needed): More information is needed before this issue can be triaged
+
+[Status/0-Triage](https://github.com/ocaml/merlin/labels/Status%2F0-Triage): This issue needs triaging
+
+[Status/1-Acknowledged](https://github.com/ocaml/merlin/labels/Status%2F1-Acknowledged): This issue has been triaged and is being investigated
+
+[Status/2-Regression](https://github.com/ocaml/merlin/labels/Status%2F2-Regression): Known workaround to be applied and tested
+
+[Status/3-Fixed-need-test](https://github.com/ocaml/merlin/labels/Status%2F3-Fixed-need-test): This issue has been fixed and needs checking
+
+[Status/4-Fixed](https://github.com/ocaml/merlin/labels/Status%2F4-Fixed): This issue has been fixed!
+
+[Status/5-Awaiting-feedback](https://github.com/ocaml/merlin/labels/Status%2F5-Awaiting-feedback): This issue requires feedback on a previous fix
+
+You can see current areas of development in our [Merlin Project Roadmaps](https://github.com/ocaml/merlin/projects) that we keep up to date.
+
+Contributing to Merlin
+----------------------
+
+Merlin needs your help and contributions!
+
+### Reporting Issues
+
+When you encounter an issue, please report it with as much detail as possible. A thorough bug report is always appreciated :)
+
+Check that our issue database doesn't already include that problem/suggestion. You can click "subscribe" on issues to follow their progress and updates.
+
+When reporting issues, please include:
+
+- steps to reproduce the problem, if possible with some code triggering the issue,
+- version of the tools you are using: operating system, editor, OCaml.
+
+Try to be as specific as possible:
+
+- avoid generic phrasing such as "doesn't work", explain *what* is happening (editor is freezing, you got an error message, the answer is not what was expected, ...)
+- include the content of error messages if there are any.
+
+If it seems relevant, also include information about your development environment:
+
+- the Opam version and switch in use,
+- other toolchains involved (OCaml flavors, cygwin, C compiler, shell, ...),
+- how the editor was setup.
+
+### Pull Requests
+
+Found a bug and know how to fix it? Or have a feature you can implement directly? We appreciate pull requests to improve Merlin, and any significant fix should start life as an issue first.
+
+### Documentation and wiki
+
+Help is greatly appreciated, the wiki needs love.
+
+If the wiki didn't cover a topic and you found out the answer, updating the page or pointing out the issue will be very useful for future users.
+
+### Discussing with other Merlin users and contributors
+
+Together with commenting on issues with direct feedback and relevant information, we use the [mailing list](https://lists.forge.ocamlcore.org/cgi-bin/listinfo/merlin-discuss) to discuss ideas and current designs/implementations. User input helps us to converge on solutions, especially those for aesthetic and user-oriented topics.
+
+List of Contributors
+--------------------
+
+We would like to thank all people who contributed to Merlin.
+
+Main collaborators:
+* [Frédéric Bour](https://github.com/let-def), main developer
+* [Thomas Refis](https://github.com/trefis), main developer
+* [Gemma Gordon](https://github.com/GemmaG), project manager
+* [Simon Castellan](https://github.com/asmanur), contributed the initial Emacs mode
+
+Contributors:
+* [Andrew Noyes](https://github.com/atn34)
+* [Andrey Popp](https://github.com/andreypopp)
+* [Anil Madhavapeddy](https://github.com/avsm)
+* [Anton Bachin](https://github.com/aantron)
+* [Armaël Guéneau](https://github.com/Armael)
+* [Arthur Wendling](https://github.com/art-w)
+* [Benjamin San Souci](https://github.com/bsansouci)
+* [Bernhard Schommer](https://github.com/bschommer)
+* [Bobby Priambodo](https://github.com/bobbypriambodo)
+* [Bryan Phelps](https://github.com/bryphe)
+* [Chris Konstad](https://github.com/chriskonstad)
+* [Christopher Reichert](https://github.com/creichert)
+* [Christophe Troestler](https://github.com/Chris00)
+* [David Allsopp](https://github.com/dra27)
+* [Fabian Hemmer](https://github.com/copy)
+* [Fourchaux](https://github.com/Fourchaux)
+* [Gabriel Scherer](https://github.com/gasche)
+* [Geoff Gole](https://github.com/gsg)
+* [Gerd Stolpmann](https://github.com/gerdstolpmann)
+* [Gregory Nisbet](https://github.com/gregory-nisbet)
+* [Jacob Bass](https://github.com/bassjacob)
+* [Jacques-Pascal Deplaix](https://github.com/jpdeplaix)
+* [Jah Rehders](https://github.com/sheijk)
+* [Jason Staten](https://github.com/statianzo)
+* [Jochen Bartl](https://github.com/verbosemode)
+* [Jordan Walke](https://github.com/jordwalke)
+* [Keigo Imai](https://github.com/keigoi)
+* [Leandro Ostera](https://github.com/ostera)
+* [Leo White](https://github.com/lpw25])
+* [Madroach](https://github.com/madroach)
+* [Malcolm Matalka](https://github.com/orbitz)
+* [Marc Weber](https://github.com/MarcWeber)
+* [Mario Rodas](https://github.com/marsam)
+* [Markus Mottl](https://github.com/mmottl)
+* [Milo Davis](https://github.com/MiloDavis)
+* [Nick Borden](https://github.com/hcwndbyw)
+* [Nicolás Ojeda Bar](https://github.com/nojb)
+* [Olivier Andrieu](https://github.com/oandrieu)
+* [Philipp Haselwarter](https://github.com/haselwarter)
+* [Pierre Chambart](https://github.com/chambart)
+* [Raman Varabets](https://github.com/cyberhuman)
+* [Raphaël Proust](https://github.com/raphael-proust)
+* [Ronan Le Hy](https://github.com/lehy-probayes) [(2)](https://github.com/lehy)
+* [Rudi Grinberg](https://github.com/rgrinberg)
+* [Steve Purcell](https://github.com/purcell)
+* [Syohei Yoshida](https://github.com/syohex)
+* ["tddsg"](https://github.com/tddsg)
+* [Tomasz Kołodziejski](https://github.com/neojski)
+* [Velichko Vsevolod](https://github.com/torkve)
+* [Vincent / Twinside](https://github.com/Twinside)
+* [Xavier Guérin](https://github.com/xguerin)
+* [Ximin Luo](https://github.com/infinity0)
+* [Yotam Barnoy](https://github.com/bluddy)
+
+### Sponsoring and donations
+
+We would like to thank [Jane Street](https://www.janestreet.com) for sponsoring and [OCaml Labs](https://github.com/ocamllabs) for providing support and management.
+
+And many thanks to our [Bountysource](https://www.bountysource.com/teams/the-lambda-church/backers) backers.
+
+### Other acknowledgements
+
+Distribution and configuration:
+* [Louis Gesbert](https://github.com/AltGr), [opam-user-setup](https://github.com/OCamlPro/opam-user-setup), out-of-the-box setup for Vim and Emacs
+* [Edgar Aroutinian](https://github.com/fxfactorial), [ocaml-starterkit](https://github.com/fxfactorial/ocaml-starterkit), collection of tools for beginners in OCaml
+
+Support for other editors:
+* [Luc Rocher](https://github.com/cynddl), [Sublime Text 3](https://github.com/cynddl/sublime-text-merlin)
+* [Pieter Goetschalckx](https://github.com/314eter), [ocaml-merlin package for Atom](https://atom.io/packages/ocaml-merlin)
+* various contributors, [nuclide package for Atom](https://nuclide.io/)
diff --git a/appveyor.cmd b/appveyor.cmd
new file mode 100644
index 0000000..70dfb9d
--- /dev/null
+++ b/appveyor.cmd
@@ -0,0 +1,37 @@
+@setlocal
+@echo off
+
+set Path=C:\cygwin\bin;%Path%
+set OCAML_PREV_PATH=%PATH%
+set OCAML_PREV_LIB=%LIB%
+set OCAML_PREV_INCLUDE=%INCLUDE%
+
+bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor.sh prepare mingw"
+if errorlevel 1 exit /b 1
+bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor.sh prepare mingw64"
+if errorlevel 1 exit /b 1
+call "C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin\SetEnv.cmd" /x86 /release
+bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor.sh prepare msvc"
+if errorlevel 1 exit /b 1
+set PATH=%OCAML_PREV_PATH%
+set LIB=%OCAML_PREV_LIB%
+set INCLUDE=%OCAML_PREV_INCLUDE%
+call "C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin\SetEnv.cmd" /x64 /release
+bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor.sh prepare msvc64"
+if errorlevel 1 exit /b 1
+bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor.sh matrix"
+bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor.sh build msvc64"
+if errorlevel 1 exit /b 1
+set PATH=%OCAML_PREV_PATH%
+set LIB=%OCAML_PREV_LIB%
+set INCLUDE=%OCAML_PREV_INCLUDE%
+call "C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin\SetEnv.cmd" /x86 /release
+bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor.sh build msvc"
+if errorlevel 1 exit /b 1
+set PATH=%OCAML_PREV_PATH%
+set LIB=%OCAML_PREV_LIB%
+set INCLUDE=%OCAML_PREV_INCLUDE%
+bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor.sh build mingw"
+if errorlevel 1 exit /b 1
+bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor.sh build mingw64"
+if errorlevel 1 exit /b 1
diff --git a/appveyor.sh b/appveyor.sh
new file mode 100644
index 0000000..efedbf3
--- /dev/null
+++ b/appveyor.sh
@@ -0,0 +1,251 @@
+#!/bin/bash
+
+TERM=st
+
+MODE=$1
+PORT=$2
+
+OCAML_VERSIONS="4.02.3 4.03.0 4.04.2 4.05.0"
+# Increment whenever the OCaml version or a package is updated to invalidate the caches
+SERIAL=1
+# Set to 0 if the testsuite may fail
+TESTSUITE_SOUND=0
+
+ROOT=C:/OCaml
+ROOT_CYG=$(echo $ROOT| cygpath -f -)
+APPVEYOR_BUILD_FOLDER=$(echo $APPVEYOR_BUILD_FOLDER| cygpath -f -)
+
+ERRORS_ALLOWED=0
+function quietly_log {
+  if ! script --quiet --return --append --command "$1" $LOG_FILE > /dev/null 2>&1 ; then
+    cat $LOG_FILE
+    if ((ERRORS_ALLOWED)) ; then
+      return 1
+    else
+      exit 1
+    fi
+  fi
+}
+
+function msvs_promote_path {
+  if [[ ${1%64} = "msvc" ]] ; then
+    eval $($ROOT_CYG/msvs-promote-path)
+  fi
+}
+
+case $MODE in
+  prepare)
+    BUILT_SOMETHING=0
+    for OCAML_VERSION in $OCAML_VERSIONS ; do
+      OCAML_BRANCH=${OCAML_VERSION%.*}
+      if ! cat $APPVEYOR_BUILD_FOLDER/appveyor.yml | tr -d '\015' | sed -e '1,/^cache:/d' -e '/^$/,$d' | grep -q "^ \+- \+C:\\\\OCaml\\\\$OCAML_BRANCH$" ; then
+        echo "$(tput setf 4)ERROR$(tput sgr0) C:\\OCaml\\$OCAML_BRANCH doesn't appear to be cached in appveyor.yml"
+        exit 1
+      fi
+
+      if [[ ! -e $ROOT_CYG/$OCAML_BRANCH/$PORT/bin/ocamlopt.exe || ! -e $ROOT_CYG/$OCAML_BRANCH/version || $(cat $ROOT_CYG/$OCAML_BRANCH/version) != "$OCAML_VERSION-$SERIAL" ]] ; then
+        if [[ -e $ROOT_CYG/$OCAML_BRANCH/version && $(cat $ROOT_CYG/$OCAML_BRANCH/version) != "$OCAML_VERSION-$SERIAL" ]] ; then
+          echo "Build cache for $OCAML_BRANCH has serial $(cat $ROOT_CYG/$OCAML_BRANCH/version); should be $OCAML_VERSION-$SERIAL -- clearing"
+          rm -rf $ROOT_CYG/$OCAML_BRANCH
+        elif [[ ! -e $ROOT_CYG/$OCAML_BRANCH/version ]] ; then
+          rm -rf $ROOT_CYG/$OCAML_BRANCH
+        fi
+
+        if ((BUILT_SOMETHING)) ; then
+          if [[ $PORT = "mingw" ]] ; then
+            appveyor AddMessage "OCaml $OCAML_VERSION needs to be built, but this run has already built a compiler set." -Detail "Assuming the build completes successfully, use the Re-build Commit option" -Category Warning
+          fi
+        else
+          PREFIX=$ROOT_CYG/$OCAML_BRANCH/$PORT
+          ROOT=$ROOT/$OCAML_BRANCH/$PORT
+          OCAML_BRANCH=${OCAML_BRANCH/.}
+
+          if [[ ! -d $APPVEYOR_BUILD_FOLDER/../src ]] ; then
+            mkdir -p $APPVEYOR_BUILD_FOLDER/../src
+            cd $APPVEYOR_BUILD_FOLDER/../src
+            git clone https://github.com/ocaml/ocaml.git
+            cd ocaml
+            mkdir -p $PREFIX
+            cp tools/msvs-promote-path $ROOT_CYG/
+            cd ..
+            appveyor DownloadFile "http://alain.frisch.fr/flexdll/flexdll-bin-0.35.zip" -FileName flexdll-bin-0.35.zip
+            appveyor DownloadFile "https://github.com/mjambon/biniou/archive/v1.2.0.tar.gz" -FileName biniou-1.2.0.tar.gz
+            appveyor DownloadFile "https://github.com/mjambon/cppo/archive/v1.5.0.tar.gz" -FileName cppo-1.5.0.tar.gz
+            appveyor DownloadFile "https://github.com/mjambon/easy-format/archive/v1.2.0.tar.gz" -FileName easy-format-1.2.0.tar.gz
+            appveyor DownloadFile "http://download.camlcity.org/download/findlib-1.7.3.tar.gz" -FileName findlib-1.7.3.tar.gz
+            appveyor DownloadFile "https://github.com/ocaml/dune/releases/download/1.0.1/dune-1.0.1.tbz" -FileName dune-1.0.1.tbz
+            appveyor DownloadFile "https://github.com/ocaml/ocamlbuild/archive/0.11.0.tar.gz" -FileName ocamlbuild-0.11.0.tar.gz
+            appveyor DownloadFile "https://github.com/ocaml-community/yojson/archive/v1.6.0.tar.gz" -FileName yojson-1.6.0.tar.gz
+            cp $APPVEYOR_BUILD_FOLDER/appveyor/*.patch $APPVEYOR_BUILD_FOLDER/../src/
+            [[ -e $PREFIX/../version ]] || echo $OCAML_VERSION-$SERIAL> $PREFIX/../version
+          fi
+
+          export PATH=$PREFIX/bin:$PATH
+
+          cd $APPVEYOR_BUILD_FOLDER/../src/ocaml
+          git checkout $OCAML_VERSION
+          git worktree add ../$OCAML_VERSION/$PORT/ocaml -b build-$OCAML_VERSION-$PORT
+          if [[ $OCAML_BRANCH -ge 403 ]] ; then
+            pushd ../$OCAML_VERSION/$PORT/ocaml
+            git submodule update --init
+            popd
+          fi
+          cd ../$OCAML_VERSION/$PORT/ocaml
+          if [[ $OCAML_BRANCH -ge 406 ]] ; then
+            cp config/s-nt.h byterun/caml/s.h
+            cp config/m-nt.h byterun/caml/m.h
+          else
+            cp config/s-nt.h config/s.h
+            cp config/m-nt.h config/m.h
+          fi
+          if [[ $OCAML_BRANCH -ge 405 ]] ; then
+            POST_WORLD=flexlink.opt
+          else
+            POST_WORLD=
+          fi
+          if [[ $OCAML_BRANCH -lt 403 ]] ; then
+            mkdir -p $PREFIX/bin
+            pushd $PREFIX/bin
+            case $PORT in
+              msvc)
+                MANIFEST=default.manifest;;
+              msvc64)
+                MANIFEST=default_amd64.manifest;;
+              *)
+                MANIFEST=;;
+            esac
+            unzip $APPVEYOR_BUILD_FOLDER/../src/flexdll-bin-0.35.zip flexdll_*$PORT.* flexdll.h flexlink.exe $MANIFEST
+            popd
+            PRE_WORLD=
+          else
+            PRE_WORLD=flexdll
+          fi
+          sed -e "s|PREFIX=[^\r]*|PREFIX=$ROOT|" config/Makefile.$PORT > config/Makefile
+          msvs_promote_path $PORT
+          cd ..
+          tar -xzf $APPVEYOR_BUILD_FOLDER/../src/findlib-1.7.3.tar.gz
+          cd findlib-1.7.3
+          # Upstreamed; not merged
+          patch -p1 -i $APPVEYOR_BUILD_FOLDER/../src/findlib-1.7.3.patch
+          # Not yet upstreamed
+          sed -i -e 's/\.a/$(LIB_SUFFIX)/g' src/findlib/Makefile
+          cd ..
+          tar -xzf $APPVEYOR_BUILD_FOLDER/../src/dune-1.0.1.tbz
+          tar -xzf $APPVEYOR_BUILD_FOLDER/../src/easy-format-1.2.0.tar.gz
+          cd easy-format-1.2.0
+          # Upstreaming not required: master has been converted to jbuilder
+          patch -p1 -i $APPVEYOR_BUILD_FOLDER/../src/easy-format-1.2.0.patch
+          cd ..
+          tar -xzf $APPVEYOR_BUILD_FOLDER/../src/biniou-1.2.0.tar.gz
+          if [[ $OCAML_BRANCH -ge 403 ]] ; then
+            tar -xzf $APPVEYOR_BUILD_FOLDER/../src/ocamlbuild-0.11.0.tar.gz
+            cd ocamlbuild-0.11.0
+            # Manually apply fix from a8d2e8
+            sed -i -e 's/pack\.o/pack$(EXT_OBJ)/g' Makefile
+            cd ..
+          fi
+          tar -xzf $APPVEYOR_BUILD_FOLDER/../src/cppo-1.5.0.tar.gz
+          tar -xzf $APPVEYOR_BUILD_FOLDER/../src/yojson-1.6.0.tar.gz
+          cd ocaml
+
+          LOG_FILE=OCaml-$OCAML_VERSION-$PORT.log
+          echo "Building OCaml $OCAML_VERSION for $PORT" | tee $LOG_FILE
+          echo "Please see $LOG_FILE for further information"
+          LOG_FILE="$APPVEYOR_BUILD_FOLDER/$LOG_FILE"
+          quietly_log "make -f Makefile.nt $PRE_WORLD world.opt $POST_WORLD install"
+          # Remove unnecessary executables to keep the build cache size down
+          # These are removed here to ensure findlib doesn't configure itself
+          # to use .opt commands
+          if [[ $OCAML_BRANCH -ge 404 ]] ; then
+            rm $PREFIX/bin/*.byte.exe  $PREFIX/bin/*.opt.exe
+          else
+            for i in $PREFIX/bin/*.opt.exe ; do
+              rm ${i%.opt.exe}.exe
+              mv $i ${i%.opt.exe}.exe
+            done
+          fi
+          cd ../findlib-1.7.3
+          quietly_log "./configure && make all opt && make install"
+          cd ../dune-1.0.1
+          quietly_log "ocaml bootstrap.ml && ./boot.exe && cp _build/default/bin/main.exe $PREFIX/bin/dune.exe"
+          cd ../easy-format-1.2.0
+          quietly_log "make && make install"
+          cd ../biniou-1.2.0
+          quietly_log "make && ocamlfind install biniou _build/install/default/lib/biniou/*"
+          if [[ $OCAML_BRANCH -ge 403 ]] ; then
+            cd ../ocamlbuild-0.11.0
+            quietly_log "make -f configure.make all OCAMLBUILD_PREFIX=$PREFIX OCAMLBUILD_BINDIR=$PREFIX/bin OCAMLBUILD_LIBDIR=$(ocamlfind printconf path) OCAML_NATIVE=true OCAML_NATIVE_TOOLS=false && make all findlib-install"
+            rm $PREFIX/bin/ocamlbuild.{byte,native}.exe
+          fi
+          cd ../cppo-1.5.0
+          quietly_log "make PREFIX=$PREFIX opt install-bin"
+          cd ../yojson-1.6.0
+          quietly_log "make && ocamlfind install yojson _build/install/default/lib/yojson/*"
+          # Remove unnecessary commands to keep the build cache size down
+          rm $PREFIX/bin/{ocaml,ocamlcp,ocamldebug,ocamldoc,ocamlmktop,ocamlobjinfo,ocamloptp,ocamlprof}.exe $PREFIX/lib/{expunge,extract_crc,objinfo_helper}.exe
+          # Remove unnecessary files
+          if [[ $OCAML_BRANCH -lt 405 && $OCAML_BRANCH -gt 402 ]] ; then
+            rm $PREFIX/*.txt
+          fi
+          find $PREFIX -name *.cmt* | xargs rm
+          find $PREFIX -name *.ml* | xargs rm
+          rm -f $PREFIX/lib/compiler-libs/*.cmx* $PREFIX/lib/compiler-libs/*.{lib,a} $PREFIX/lib/compiler-libs/ocamloptcomp.cma
+          echo "Complete"
+          appveyor PushArtifact $(echo $LOG_FILE| cygpath -m -f -)
+          BUILT_SOMETHING=1
+        fi
+      fi
+    done
+    ;;
+  matrix)
+    for OCAML_VERSION in $OCAML_VERSIONS ; do
+      OCAML_BRANCH=${OCAML_VERSION%.*}
+      for PORT in mingw mingw64 msvc msvc64 ; do
+        if [[ -e $ROOT_CYG/$OCAML_BRANCH/$PORT/bin/ocamlopt.exe ]] ; then
+          OUTCOME=None
+        else
+          OUTCOME=NotRunnable
+        fi
+        appveyor AddTest "OCaml $OCAML_VERSION ($PORT)" -Framework "OCaml $OCAML_VERSION" -Filename "ocamlmerlin-test.exe" -Outcome $OUTCOME
+      done
+    done
+    ;;
+  build)
+    msvs_promote_path $PORT
+    ORIG_PATH=$PATH
+    for OCAML_VERSION in $OCAML_VERSIONS ; do
+      OCAML_BRANCH=${OCAML_VERSION%.*}
+      if [[ -e $ROOT_CYG/$OCAML_BRANCH/$PORT/bin/ocamlopt.exe ]] ; then
+        echo "Building Merlin $PORT on $OCAML_VERSION"
+        SECONDS=0
+        appveyor UpdateTest "OCaml $OCAML_VERSION ($PORT)" -Outcome Running -Framework "OCaml $OCAML_VERSION" -Filename "ocamlmerlin-test.exe" -Duration 0
+        export PATH=$ROOT_CYG/$OCAML_BRANCH/$PORT/bin:$ORIG_PATH
+        mkdir -p $APPVEYOR_BUILD_FOLDER/../merlin-$OCAML_VERSION
+        cp -a $APPVEYOR_BUILD_FOLDER $APPVEYOR_BUILD_FOLDER/../merlin-$OCAML_VERSION/$PORT
+        cd $APPVEYOR_BUILD_FOLDER/../merlin-$OCAML_VERSION/$PORT
+        LOG_FILE=$APPVEYOR_BUILD_FOLDER/build-$OCAML_VERSION-$PORT.log
+        rm -f $LOG_FILE
+        ERRORS_ALLOWED=1
+        if quietly_log "./configure --prefix $ROOT_CYG/$OCAML_BRANCH/$PORT && make" ; then
+          appveyor UpdateTest "OCaml $OCAML_VERSION ($PORT)" -Outcome Running -Framework "OCaml $OCAML_VERSION" -Filename "ocamlmerlin-test.exe" -Duration $((SECONDS * 1000))
+          if quietly_log "make test" ; then
+            # Full pass
+            appveyor UpdateTest "OCaml $OCAML_VERSION ($PORT)" -Outcome Passed -Framework "OCaml $OCAML_VERSION" -Filename "ocamlmerlin-test.exe" -Duration $((SECONDS * 1000))
+          elif ((!TESTSUITE_SOUND)) ; then
+            # Permitted fail
+            appveyor UpdateTest "OCaml $OCAML_VERSION ($PORT)" -Outcome Passed -StdOut "$(tail -10 $LOG_FILE)" -Framework "OCaml $OCAML_VERSION" -Filename "ocamlmerlin-test.exe" -Duration $((SECONDS * 1000))
+          else
+            # Failure
+            appveyor UpdateTest "OCaml $OCAML_VERSION ($PORT)" -Outcome Failed -StdOut "$(tail -10 $LOG_FILE)" -Framework "OCaml $OCAML_VERSION" -Filename "ocamlmerlin-test.exe" -Duration $((SECONDS * 1000))
+          fi
+        else
+          # Build failure
+          appveyor UpdateTest "OCaml $OCAML_VERSION ($PORT)" -Outcome Failed -StdOut "$(tail -10 $LOG_FILE)" -Framework "OCaml $OCAML_VERSION" -Filename "ocamlmerlin-test.exe" -Duration $((SECONDS * 1000))
+        fi
+        appveyor PushArtifact $(echo $LOG_FILE| cygpath -m -f -)
+      else
+        echo "OCaml $OCAML_VERSION for $PORT does not appear to have been built -- skipping"
+      fi
+    done
+    ;;
+esac
diff --git a/appveyor.yml b/appveyor.yml
new file mode 100644
index 0000000..698e0c8
--- /dev/null
+++ b/appveyor.yml
@@ -0,0 +1,26 @@
+platform:
+  - x64
+
+clone_depth: 1
+
+environment:
+  global:
+    CYG_ROOT: C:/cygwin
+    CYG_MIRROR: http://mirrors.kernel.org/sourceware/cygwin/
+    CYG_CACHE: C:/cygwin/var/cache/setup
+
+cache:
+#  - C:\cygwin\var\cache\setup
+  - C:\OCaml\4.02
+  - C:\OCaml\4.03
+  - C:\OCaml\4.04
+  - C:\OCaml\4.05
+  - C:\OCaml\msvs-promote-path
+
+install:
+  - '%CYG_ROOT%\bin\bash -lc "date; cygcheck -dc cygwin"'
+  - '"%CYG_ROOT%\setup-x86.exe" --quiet-mode --no-shortcuts --only-site --root "%CYG_ROOT%" --site "%CYG_MIRROR%" --local-package-dir "%CYG_CACHE%" --packages diffutils,patch,make,mingw64-i686-gcc-core,mingw64-x86_64-gcc-core,unzip > NUL'
+  - '%CYG_ROOT%\bin\bash -lc "date; cygcheck -dc cygwin"'
+
+build_script:
+  - call "%APPVEYOR_BUILD_FOLDER%\appveyor.cmd"
diff --git a/appveyor/easy-format-1.2.0.patch b/appveyor/easy-format-1.2.0.patch
new file mode 100644
index 0000000..cb0ace3
--- /dev/null
+++ b/appveyor/easy-format-1.2.0.patch
@@ -0,0 +1,29 @@
+diff -Naur a/Makefile b/Makefile
+--- a/Makefile	2015-12-07 21:58:29.000000000 +0000
++++ b/Makefile	2017-07-21 14:19:28.720009800 +0100
+@@ -3,6 +3,7 @@
+ 
+ NATDYNLINK := $(shell if [ -f `ocamlfind ocamlc -where`/dynlink.cmxa ]; \
+                       then echo YES; else echo NO; fi)
++EXT_OBJ = $(shell ocamlc -config | sed -ne "s/ext_obj: //p" | tr -d '\r')
+ 
+ ifeq "${NATDYNLINK}" "YES"
+ CMXS=easy_format.cmxs
+@@ -53,7 +54,7 @@
+ 	caml2html easy_format_example.ml -t -o easy_format_example.html
+ 
+ soft-clean:
+-	rm -f *.cm[iox] *.cmxs *.o *.annot \
++	rm -f *.cm[iox] *.cmxs *.o *.obj *.annot \
+ 		test_easy_format lambda_example simple_example \
+ 		bytecode nativecode
+ 
+@@ -65,7 +66,7 @@
+ 
+ COMMON_INSTALL_FILES = META easy_format.cmi easy_format.mli
+ BC_INSTALL_FILES = easy_format.cmo
+-NC_INSTALL_FILES = easy_format.cmx easy_format.o $(CMXS)
++NC_INSTALL_FILES = easy_format.cmx easy_format$(EXT_OBJ) $(CMXS)
+ 
+ install:
+ 	echo "version = \"$(VERSION)\"" > META; cat META.tpl >> META
diff --git a/appveyor/findlib-1.7.3.patch b/appveyor/findlib-1.7.3.patch
new file mode 100644
index 0000000..84954d6
--- /dev/null
+++ b/appveyor/findlib-1.7.3.patch
@@ -0,0 +1,22 @@
+diff --git a/configure b/configure
+index 34c5115..e801760 100755
+--- a/configure
++++ b/configure
+@@ -191,7 +191,7 @@ for tool in sed awk ocaml ocamlc uname rm make cat m4 dirname basename; do
+     fi
+ done
+ 
+-lib_suffix=`ocamlc -config 2>/dev/null|grep '^ext_lib'|sed 's/ext_lib: //'`
++lib_suffix=`ocamlc -config 2>/dev/null|tr -d '\015'|sed -n -e 's/^ext_lib: //p'`
+ 
+ # Check for Cygwin:
+ 
+@@ -225,7 +225,7 @@ use_cygpath=0
+ # Whether we have to translate Unix paths to/from Windows paths.
+ 
+ if [ -z "$system" ]; then
+-    system=`ocamlc -config 2>/dev/null|grep '^system'|sed 's/system: //'`
++    system=`ocamlc -config 2>/dev/null|tr -d '\015'|sed -n -e 's/^system: //p'`
+     # This may be
+     # - mingw or mingw64
+     # - win32
diff --git a/changelog b/debian/changelog
index 5096a36..5096a36 100644
--- a/changelog
+++ b/debian/changelog
diff --git a/control b/debian/control
index 052d691..052d691 100644
--- a/control
+++ b/debian/control
diff --git a/copyright b/debian/copyright
index 7b5917d..7b5917d 100644
--- a/copyright
+++ b/debian/copyright
diff --git a/emacs-ocaml-merlin.install b/debian/emacs-ocaml-merlin.install
index 9032917..9032917 100644
--- a/emacs-ocaml-merlin.install
+++ b/debian/emacs-ocaml-merlin.install
diff --git a/lintian-overrides b/debian/lintian-overrides
index 4966982..4966982 100644
--- a/lintian-overrides
+++ b/debian/lintian-overrides
diff --git a/ocaml-merlin.docs b/debian/ocaml-merlin.docs
index 7153ed3..7153ed3 100644
--- a/ocaml-merlin.docs
+++ b/debian/ocaml-merlin.docs
diff --git a/ocaml-merlin.install b/debian/ocaml-merlin.install
index 2b73762..2b73762 100644
--- a/ocaml-merlin.install
+++ b/debian/ocaml-merlin.install
diff --git a/rules b/debian/rules
index b2d3446..b2d3446 100755
--- a/rules
+++ b/debian/rules
diff --git a/source/format b/debian/source/format
index 163aaf8..163aaf8 100644
--- a/source/format
+++ b/debian/source/format
diff --git a/upstream/metadata b/debian/upstream/metadata
index 25763f2..25763f2 100644
--- a/upstream/metadata
+++ b/debian/upstream/metadata
diff --git a/vim-ocaml-merlin.install b/debian/vim-ocaml-merlin.install
index 265dacd..265dacd 100644
--- a/vim-ocaml-merlin.install
+++ b/debian/vim-ocaml-merlin.install
diff --git a/vim-ocaml-merlin.neovim-addon b/debian/vim-ocaml-merlin.neovim-addon
index 1e0dc4a..1e0dc4a 120000
--- a/vim-ocaml-merlin.neovim-addon
+++ b/debian/vim-ocaml-merlin.neovim-addon
diff --git a/vim-ocaml-merlin.vim-addon b/debian/vim-ocaml-merlin.vim-addon
index c7605b5..c7605b5 100644
--- a/vim-ocaml-merlin.vim-addon
+++ b/debian/vim-ocaml-merlin.vim-addon
diff --git a/watch b/debian/watch
index d0ae532..d0ae532 100644
--- a/watch
+++ b/debian/watch
diff --git a/doc/dev/ARCHITECTURE.md b/doc/dev/ARCHITECTURE.md
new file mode 100644
index 0000000..4c14f41
--- /dev/null
+++ b/doc/dev/ARCHITECTURE.md
@@ -0,0 +1,200 @@
+Architecture
+------------
+
+### src/frontend
+
+`ocamlmerlin.c` implements the `ocamlmerlin` wrapper that takes care of
+spawning a server if necessary and passing queries. See [SERVER.md](SERVER.md).
+
+`ocamlmerlin_server.ml` is the entry point of `ocamlmerlin-server` binary. It
+reads argument from the command-line and decides which mode to start
+(old-protocol, single query or query server).
+
+`query_protocol.mli` defines the type of all queries and their results.
+
+`query_json.ml` implements conversion of results to a JSON-like type. Yojson or
+Sexp can be used for turning these into strings.
+
+`query_commands.ml` executes the queries defined by the protocol. It uses
+`src/kernel` for parse and typing. Then it uses `src/analysis` to get some
+results.
+
+`new/` implements a UNIX-like frontend: parametrized by arguments, reading
+content from stdin, outputting answer to stdout and logging to stderr.
+Command-line is turned into a `Query_protocol.t` query and executed with
+`Query_commands`.
+
+`old/` does the same job but for the previous, synchronous, version of the
+protocol (see [OLD-PROTOCOL.ml](OLD-PROTOCOL.md)).
+
+`test/ocamlmerlin_test.ml` implements the `ocamlmerlin-test` binary that runs a
+testsuite of queries. 
+
+Summary:
+* manage communication with outside world
+* get a query from the user by some mean, turn it into a `Query_protocol.t`
+* execute the query with `Query_commands`
+* return the result by some mean
+
+### src/kernel
+
+Kernel wraps the OCaml frontend into an incremental and error-resilient
+library.
+
+`mconfig.ml` defines a big record that contains all settings affecting Merlin
+behavior, as well as a setting parser and dumper.
+
+`mconfig_dot.ml` is used by `Mconfig` to process `.merlin` files
+
+`mocaml.ml` interfaces with the OCaml typechecker. It setup and restore state
+when entering/exiting the typechecker.
+
+`mpipeline.ml` implements a few high-level primitives that connect all pieces
+together
+
+`mppx.ml`: implements ppx rewriting, directed by an `Mconfig.t`
+
+`msource.ml`: represents is the representation of a source file in Merlin. It
+also computes the positions of contents in the source file. 
+
+`mreader.ml`: abstracts the parser of Merlin. It turns an `Msource.t` into an
+AST. `mreader_*` implement a parser for normal OCaml files. 
+
+`mreader_extent.ml`: a parser that delegates the work to (compatible) external
+commands. Mainly used by Reason. See `src/extend/`.
+
+`mreader_lexer.ml`, `mreader_parser.ml`, `mreader_recover.ml`,
+`mreader_explain.ml`: a parser for standard OCaml files. Main addition is
+recovery from syntax errors.
+
+`mbrowse.ml`: uniform navigation in typedtree, mainly answering "what is around
+this position?"
+
+`mtyper.ml`: wraps the OCaml typechecker, to type the ASTs produced by
+`mreader.ml`
+
+`extension.ml`: defines some OCaml dialects (lwt camlp4 and meta-ocaml)
+
+Summary:
+* isolate state of OCaml typechecker
+* maintain multiple parsing and typing contexts in parallel
+* robust to syntax and type errors
+
+### src/analysis
+
+Analysis offers different tools to work with the result of typechecking
+(produced by the kernel).
+These are independent of an OCaml version. A typechecker comes with modules to
+abstract the differences.
+
+`browse_misc.ml`: tools too small to deserve their own module (tail calls
+annotations, printing ...)
+
+`browse_tree.ml`: uniform traversal of typedtree, wrapping `Browse_raw`
+
+`ocamldoc.ml`: get documentation associated to a definition
+
+`typedtrie.ml`: a trie representation of a compilation unit, allowing quick lookup of OCaml paths
+
+`type_utils.ml`: light wrapper over some functions of OCaml typer
+
+`completion.ml`: generate list of completions
+
+`expansion.ml`: like completion, but generate fuzzy/spell corrected suggestions rather than type-directed
+
+`destruct.ml`: expand incomplete or coarse-grained patterns into more cases
+
+`outline.ml`: produce an overview of an OCaml module's structure and definitions 
+
+`locate.ml`: implement a jump-to-definition/declaration feature
+
+`jump.ml`: implement convenient navigation commands
+
+### src/ocaml/support
+
+Definitions useful to all versions of the typechecker.
+
+`clflags.ml`: compiler flags, unified between all versions
+
+`tbl.ml`, `identifiable.ml`: needed by all OCaml typecheckers
+
+`cmi_cache.ml`, `cmt_cache.ml`: cache for \*.cmi and \*.cmt files
+
+`fake.ml`: generate fake pieces of AST that implement the semantics of
+extensions from `src/kernel/extensions.ml`
+
+`msupport.ml`: bridge between extensions to OCaml typecheker and Merlin kernel.
+Mainly for warning and location management, capture of type errors and
+annotation of erroneous AST nodes
+
+`location_aux.ml`: small functions missing from location.ml (management of
+character ranges)
+
+`path_aux.ml`: small functions missing from path.ml (management of qualified
+identifiers)
+
+`preprocess/lexer_ident.mll`: a subset of the OCaml lexer to find identifiers
+in the middle of arbitrary text.
+
+### src/ocaml/typer (\_402, \_403, \_404)
+
+Wraps a version of the OCaml typechecker for Merlin.
+src/ocaml is a symlink to a concrete version selected at configure-time.
+
+`typing/`, `parsing/`: typechecker from upstream OCaml, with merlin-specific patches
+
+`browse_raw.ml`: fold over Typedtree in a uniform way
+
+`parser_raw.ml`, `parser_recover.ml`, `parser_explain.ml`, `parser_recover.ml`:
+an OCaml parser with extra information for recovery, produced by menhir and
+with custom preprocessors (see `preprocessors/`)
+
+`preprocess/lexer_raw.mll`: OCaml lexer, to be processed by `ocamllex`
+
+`printf_compat.ml`: fix a too restrictive signature of OCaml 4.02, empty in
+later versions
+
+`raw_compat.ml`: compatibility layer to process typechecker output, masking differences between versions
+
+`typer_raw.ml`: wrapper to invoke the typechecker, masking differences between versions
+
+`tail_analysis.ml`: low-level functions for determining tail-call positions
+
+`tast_helper.ml`: a few functions for manually producing pieces of typed AST 
+
+### src/platform
+
+Modules and stub to deal with platform specific features.
+
+`fs_case.c`: primitive to handle case insensitivity of macOS
+
+`os_ipc_stub.c`, `os_ipc.ml`: implements UNIX Domain Socket IPC for
+`ocamlmerlin-server`
+
+### src/sturgeon (\_null, \_stub)
+
+Abstraction of [sturgeon](https://github.com/let-def/sturgeon) UI.
+
+### src/utils
+
+Miscellaneous types and functions.
+
+`file_cache.ml`: generic caching infrastructure
+
+`local_store.ml`: snapshot and restore mutable state 
+
+`logger.ml`: generic logging functions
+
+`marg.ml`: generic commandline-like argument parsing (merlin gets arguments
+from different places)
+
+`misc.ml`, `std.ml`: standard library complements
+
+`menhirLib.ml`: patched menhir interpreter
+
+`ppxsetup.ml`: keep track of ppx preprocessors with their flags
+
+`sexp.ml`: a s-expression reader/writer
+
+`trace.ml`: log information structured as a trace (with enter and exit of
+sub-routines)
diff --git a/doc/dev/CACHING.md b/doc/dev/CACHING.md
new file mode 100644
index 0000000..4f23712
--- /dev/null
+++ b/doc/dev/CACHING.md
@@ -0,0 +1,92 @@
+# File\_id
+
+The basic abstraction to check if a file has changed on disk is `File_id.t`.
+
+These can be computed using `File_id.get`.  After that, `File_id.check` returns
+true if and only if the contents of the file didn't change:
+- file was missing and is still missing,
+- contents of the file changed.
+
+## Caching file identities
+
+Since the state of the disk is not supposed during the execution of a command,
+the results of `File_id.get` can be cached in some scope.
+
+Using `File_id.with_cache (fun () -> <body>)`, the results of calls to
+`File_id.get` will be memoized during the execution of `<body>`.
+
+# Caching file contents, the `File_cache` functor
+
+The `File_cache` functor caches the contents of a computation based on a
+filename for as long as the file don't change (as determined by `File_id`).
+
+For instance `Cmi_format.read` loads a cmi file from the disk. The OCaml
+compiler calls it directly as a cmi is not supposed to change while the
+compiler is working.
+
+Merlin will live for a long time and should reload files that have changed on
+disk. At the same time, not reloading files that haven't changed provide a
+significant speed up.
+
+`File_cache.Make(Cmi_format)` gives just that.
+
+- for .cmi, there is `Cmi_cache = File_cache.Make(Cmi_format)`
+- for .cmt, there is `Cmt_cache = File_cache.Make(Cmt_format)`
+- for .merlin, there is `Mconfig_dot.Cache`
+- existence of files (see below), there is `Misc.Exists_in_directory`
+
+# File existence
+
+To discover files on disk, Merlin follow OCaml approach of checking the load
+path in order for file existence.
+
+Doing this results in the lookup phase being quadratic: with n modules and m
+paths, there can be up to n * m calls to stat/file\_exists.
+
+In normal cases, a call to stat is cheap and this is insignificant. However,
+under some cicumstances this degenerates:
+- in some configurations (selinux?) we observed stat being up to two magnitude
+  orders more expensive (the same applies to NFS and other networked, although
+  supporting this situation is not of prime importance)
+- big projects with a naive .merlin tend to have a huge load path (hundreds of
+  entries, in part because of .merlin lack of expressivity).
+
+To speed up computations, determination of file existence is split in two steps:
+- first the `File_id` of the directory in which the file is stored is computed
+- the existence of the file is cached based on the id of the directory.
+
+While in the worst case this doesn't bring back a linear behavior, as most
+directories don't change this is fast enough in practice (the quadratic part
+happens all in memory).
+
+The important parts:
+- existence of a file depends on the id of its parent directory (because adding
+  or removing a file affect the contents of the directory)
+- contents of a file depends on the id of the file itself.
+
+# Refreshing cache
+
+A new function `Env.check_state_consistency` compares all global modules loaded
+in the environment to the version on disk.  If it returns false, the `Env.t`
+should be discarded and recomputed from zero.
+
+# Cache flush policy
+
+As time passes, the cache grows. Some files are kept in memory but aren't going
+to be used anymore.
+
+`Mocaml.flush_caches` remove all files that have changed on disk or that
+haven't been used for some time.  By default, `ocamlmerlin_server` remove
+entries that haven't been used in the last 300 seconds.
+
+Since this involve stating each entry, the check is done after answering.
+
+The policy is still quite naive, improvements are welcome (IDEA?).
+
+# Type environment cache
+
+Since the user is likely to ask many queries on the same environment in a row,
+the last 5 environments are cached (`Mtyper.cache`).
+
+This number might be adjusted... ? Also, entries could be filtered by time of
+last use.
diff --git a/doc/dev/OLD-PROTOCOL.md b/doc/dev/OLD-PROTOCOL.md
new file mode 100644
index 0000000..e0c7df5
--- /dev/null
+++ b/doc/dev/OLD-PROTOCOL.md
@@ -0,0 +1,462 @@
+This document describes Merlin protocol version 2.
+
+During a Merlin session, the editor launches an ocamlmerlin process and communicates with it by writing queries on stdin and reading responses on stdout.
+
+Merlin processes queries synchronously, reading them one by one and writing a response for each query, in the same order.  It will wait for more queries until stdin reaches end-of-file.
+
+The complete set of commands is defined in `src/frontend/protocol.ml`.
+
+Queries and responses can be serialized in two different formats:
+- JSON, defined in `src/frontend/IO.ml`;
+- SEXP, defined in `src/frontend/IO_sexp.ml`.
+
+JSON is the default, SEXP can be selected by passing `-protocol sexp` to Merlin process.
+
+The rest of the document will describe sample sessions and commands using JSON format.  The SEXP format is mechanically derived from JSON, flow is the same.
+
+# Merlin commands
+
+Commands can be classified in three categories:
+- _synchronization_, to share and update the content of the editor
+  buffer;
+- _query_, to ask Merlin for information (type, completion, documentation);
+- _context_, to describe the file being worked on and how it is
+  related to the environment (dependencies, include paths, ...).
+
+The basic workflow for an editor is to synchronize then run a query each time Merlin is invoked.
+
+When working on a project with multiple files, context becomes useful to switch between buffers.
+
+A simple session (user-commands prefixed by >, Merlin responses by <):
+
+```javascript
+> ["tell","start","end","let f x = x let () = ()"]
+< ["return",true]
+> ["type","expression","f","at","end"]
+< ["return","'a -> 'a"]
+```
+
+
+## Responses
+
+Responses are always of the form `[kind,payload]` where `payload` depends on the value of `kind`, which can be:
+
+`"return"` when the command succeeded, `payload` depends on the command being responded to.
+
+`"failure"` when Merlin was used in an incorrect way (e.g command was malformed or unknown), `payload` is a string describing the failure.  Editor mode should be fixed.
+
+`"error"` when something wrong prevented Merlin from answering: invalid files (for instance wrong OCaml version), missing packages, etc.  `payload` is a string describing the error, user should be notified to fix the environment.
+
+`"exception"` when something unexpected happened.  Merlin should be fixed, please report the error.  `payload` is an arbitrary json value.
+
+    
+## Synchronization
+
+Merlin maintains a copy of the buffer from your editor.
+Synchronization is done by replacing chunks of text from this copy by fresh content.
+
+### Position
+
+Most commands need to refer to a position in the buffer.  All positions are interpreted on the copy of the buffer, make sure Merlin is synchronized with the editor when you need to share a position.  
+A position is a JSON value that can be one of :
+
+```javascript
+"start" // first position of the buffer
+"end"   // last position of the buffer
+1234    // An integer is an offset, in bytes, from the beginning of the buffer
+{"line":12, "col":34} // Alternatively, you can specify a position as a line (first line is 1) and a column (indexed from 0).
+```
+
+### Tell
+
+All telling commands return a cursor state.
+
+```javascript
+["tell",start_pos,end_pos,"source"]
+```
+
+Replace the content between the two positions by `"source"`.
+
+The simplest way to synchronize your editor is to use `["tell","start","end","... full content of the buffer"]`.  It will update the whole buffer every time.
+
+### Configuration
+
+#### Flags
+
+```javascript
+["flags","set",["-rectypes", "-safe-string", ...]]
+```
+
+Set the flags you would pass to the OCaml compiler. Run `ocamlmerlin -help` to get a list of known flags.
+
+Returns `{"result":true}` if everything went well or `{"failures":string list, "result":true}` in case of error.
+
+
+```javascript
+["flags","get"]
+```
+
+Returns the `string list` (eg `["-rectypes","-safe-string"]`) that was set by previous invocation of `["flags","set",[...]]`.
+
+#### Findlib packages
+
+```javascript
+["find","use",["lwt","yojson",...]]
+```
+
+Load findlib packages in current buffer.
+Returns `{"result":true}` if everything went well or `{"failures":string list, "result":true}` in case of error.
+
+
+```javascript
+["find","list"]
+```
+
+Returns a `string list` of all known packages.
+
+#### Syntax extensions
+
+```javascript
+["extension","enable",["lwt","js",...]]
+["extension","disable",["lwt","js",...]]
+```
+
+Enable or disable syntax extensions in current buffer.
+
+
+```javascript
+["extension","list"]
+["extension","list","enabled"]
+["extension","list","disabled"]
+```
+
+List all known / currently enabled / currently disabled extensions as a `string list`.
+
+#### Paths
+
+```javascript
+["path","add","source",[path1, path2, ...]]
+["path","add","build",[path1, path2, ...]]
+["path","remove","source",[path1, path2, ...]]
+["path","remove","build",[path1, path2, ...]]
+```
+
+Merlin maintains different list of paths to process buffer and queries.
+`"source"` is where `.ml` and `.mli` files are searched for, `"build"` is for `.cmi` and `.cmt`.
+
+
+```javascript
+["path","list","source"]
+["path","list","build"]
+```
+
+Get current value of path variables as a `string list`.
+
+
+```javascript
+["path","reset"]
+```
+
+Reset path variables to default value (by default just the standard library and the buffer directory).
+
+### Queries
+
+#### Type-checking
+
+```javascript
+["type","expression",string,"at",position]
+```
+
+Returns the type of the expression when typechecked in the environment around the specified position.
+
+
+```javascript
+["type","enclosing","at",position]
+["type","enclosing",{"expr":string,"offset":int},position]
+```
+
+Returns a list of type information for all expressions at given position, sorted by increasing size.
+That is asking for type enlosing around `2` in `string_of_int 2` will return the types of `2 : int` and `string_of_int 2 : string`. 
+
+The `{"expr":string,"offset":int}` variant expects the string under cursor and the offset of the cursor in this string, to return more specific information. 
+
+The result is returned as a list of:
+```javascript
+{
+  "start": position,
+  "end": position,
+  "type": string,
+  // is this expression not in tail position, in tail position, or even a tail call?
+  "tail": ("no" | "position" | "call")
+}
+```
+
+
+```javascript
+["case","analysis","from",position,"to",position]
+```
+
+Try to destruct patterns in the specified range.
+It returns a value with the shape `[{"start": position, "end": position}, content]`. The editor is expected to replace content between `start` and `end` by `content`.
+
+#### Completion
+
+```javascript
+["complete","prefix",string,"at",position]
+["complete","prefix",string,"at",position,"with","doc"]
+["expand","prefix",string,"at",position]
+```
+
+These functions complete an identifier that the user started to type.
+They all return a list of possible completion. The "with doc" variant also try to lookup OCamldoc, which is slightly more time consuming.
+
+The expand function also try to complete partial or incorrect prefixes. For instance, `L.ma` can get expanded to `List.map`. This function is a useful fallback if normal completion gave no results.
+Be careful that it always return fully qualified paths, whereas normal completion only completes an identifier (last part of a module path). 
+
+The result has the form:
+```javascript
+{
+  context: (null | ["application",{"argument_type": string, "labels": [{"name":string,"type":string}]}]),
+  entries: [{"name":string,"kind":string,"desc":string,"info":string}]
+}
+```
+
+Context describe where completion is occurring. Only application is distinguished now: that's when one is completing the arguments to a function call. In this case, one gets the type expected at the cursor as well as the other labels.
+
+Entries is the list of possible completion. Each entry is made of:
+- a name, the text that should be put in the buffer if selected
+- a kind, one of `"value"`, `"variant"`, `"constructor"`, `"label"`, `"module"`, `"signature"`, `"type"`, `"method"`, `"#"` (for method calls), `"exn"`, `"class"`
+- a description, most of the time a type or a definition line, to be put next to the name in completion box
+- optional information which might not fit in the completion box, like signatures for modules or documentation string.
+
+
+```javascript
+["document",string,"at",position]
+["document",null,"at",position]
+```
+
+Returns OCamldoc documentation as a string, either for the given qualified identifier or the one under cursor.
+
+#### Navigation
+
+```javascript
+["occurrences","ident","at",position]
+```
+
+Returns a list of locations `{"start": position, "end": position}` of all occurrences in current buffer of the entity at the specified position.
+
+
+```javascript
+["locate",string,"ml","at",position]
+["locate",null,"ml","at",position]
+["locate",string,"mli","at",position]
+["locate",null,"mli","at",position]
+```
+
+Finds the declaration of entity at the specified position, or referred to by specified string.
+Returns either:
+- if location failed, a `string` describing the reason to the user,
+- `{"pos": position}` if the location is in the current buffer,
+- `{"file": string, "pos": position}` if definition is located in a different file.
+
+
+```javascript
+["which","path",string list]
+```
+
+Returns the full path of the first file with a name listed in the argument.
+E.g. `["which","path",["list.ml","list.mli"]]` should return the path of the standard _List_ implementation, unless another _List_ is defined in a user directory.
+
+
+```javascript
+["which","with_ext",string list]
+```
+
+Returns a list of module names for which a file exists in the path with an extension listed in the argument.
+
+`["which","with_ext",[".ml",".mli"]]` lists all top modules with either a signature or an implementation in current project.
+You can then use `["which","path",[module + ".ml", module + ".mli"]]` to open of them (in this case favoring implementations over interfaces).
+
+
+```javascript
+["outline"]
+```
+
+Returns a tree of objects `{"start": position, "end": position, "name": string, "kind": string, "children": subnodes}` describing the content of the buffer.
+
+
+```javascript
+["enclosing",position]
+```
+
+Returns a list of locations `{"start": position, "end": position}` in increasing size of all entities surrounding the position. Like s-exps around position but following OCaml syntax.
+
+#### Error management
+
+```javascript
+["errors"]
+```
+
+Returns a list of errors in current buffer.
+The value is a list where each item as the shape:
+
+```javascript
+{
+  "start" : position,
+  "end"   : position,
+  "valid" : bool,
+  "message" : string,
+  "type"  : ("type"|"parser"|"env"|"warning"|"unknown")
+}
+```
+
+`start` and `end` are omitted if error has no location (e.g. wrong file format), otherwise the editor should probably highlight / mark this range.
+`type` is an attempt to classify the error.
+`valid` is here mostly for informative purpose. It reflects whether Merlin was expecting such an error to be possible or not, and is useful for debugging purposes.
+`message` is the error description to be shown to the user.
+
+
+```javascript
+["project","get"]
+```
+
+Returns an object `{"result":string list,"failures":string list}` listing all _.merlin_ files loaded for current buffer and a list of failures that might have happened during loading (missing package for instance, ill-formed .merlin, etc).
+The `"failures"` field can be omitted if there has been no error.
+
+### Context
+
+Merlin keep tracks of multiple buffer. All commands apply to the active buffer.
+`"checkout"` command allows to change the active buffer.
+It returns a `cursor state` object describind the state of the checked out buffer (see `"tell"` command).
+
+
+```javascript
+["checkout", "ml"]
+["checkout", "mli"]
+```
+
+Switch to "default" buffer for "ml", "mli".
+It will be in the state you left it last time it was used, unless Merlin decided to garbage collect because of memory pressure (any buffer left in background is either untouched or reset because of collection).
+
+
+```javascript
+["checkout", "auto", string]
+["checkout", "ml"  , string]
+["checkout", "mli" , string]
+```
+
+Checkout buffer at a given path, interpreting it as an ml, an mli, or infer that from path extension (defaulting to ml).
+File at path is not loaded, path is only used as a key to refer to the buffer and look for _.merlin_ files.
+
+
+```javascript
+["checkout", "dot_merlin", string list, "auto", string]
+["checkout", "dot_merlin", string list, "ml"  , string]
+["checkout", "dot_merlin", string list, "mli" , string]
+```
+
+Same as `["checkout", _, string]`, but rather than inferring the _.merlin_ from the path, use the explicit list of files.
+
+#### Contextual commands
+
+An important variant of this scheme are the _contextual commands_.
+All Merlin commands except `"checkout"` can be wrapped in a dictionary looking like:
+
+```javascript
+{
+  "context": context,
+  "query": command
+}
+```
+
+Where `command` is a Merlin command and context would be the list of arguments passed to `"checkout"`.
+
+This has the same effect as executing:
+
+```javascript
+["checkout", context...]
+[command...]
+```
+
+This is useful to prevent race conditions resulting from concurrent manipulations of different buffers in the editor, by making sure each command is interpreted in the appropriate context.
+
+### Versioning
+
+```javascript
+["protocol","version",n]
+```
+
+This command notifies Merlin that the editor wants to communicate with protocol version `n`, where `n` is an integer.
+
+Merlin will answer with a triple `{"selected": n0, "latest": n1, "merlin": "Version string"}`, where: 
+- `n0` is the version that will be used for the rest of this session, 
+- `n1` is the most recent version the local distribution of Merlin is able to use, 
+- "Version string" is a human readable string describing the local installation of Merlin.
+
+```javascript
+["protocol","version"]
+```
+
+This command will return the same answer as the previous one, but won't try to select a protocol version.
+
+```javascript
+["version"]
+```
+
+Returns a string describing Merlin version.
+
+### Debugging Merlin
+
+Dump command allow to observe internal structures of Merlin.
+Result is an arbitrary json object, targeted toward human readers.
+
+```javascript
+["dump","env"]
+["dump","env","at",position]
+["dump","full_env"]
+["dump","full_env","at",position]
+```
+
+Dump content of environment.
+`"env"` is limited to local definition, `"full_env"` also includes `Pervasives` and default environment.
+
+
+```javascript
+["dump","sig"]
+```
+
+Dump definitions in environment as an ML signature.
+
+
+```javascript
+["dump","tokens"]
+["dump","parser"]
+["dump","recover"]
+```
+
+Dump output of the lexer, state of the parser and possible recoveries.
+
+
+```javascript
+["dump","browse"]
+["dump","typer","input"]
+["dump","typer","output"]
+```
+
+Dump state of typechecker.
+`"input"` is the AST has seen by the typer.
+`"output"` is the annotated AST produced by the typer.
+`"browse"` is a json-based tree built out of the `"output"`.
+
+
+```javascript
+["dump","flags"]
+["dump","warnings"]
+```
+
+List of the flags and warnings set for current buffers.
+
+# TODO
+
+Logging infrastructure.
+Explain responses verbosity.
diff --git a/doc/dev/PROTOCOL.md b/doc/dev/PROTOCOL.md
new file mode 100644
index 0000000..8981f7b
--- /dev/null
+++ b/doc/dev/PROTOCOL.md
@@ -0,0 +1,487 @@
+# Merlin 3 protocol documentation
+
+
+## Changes from merlin 2
+
+The communication protocol was redesigned between merlin 2 and 3. Answers have
+the same format, but merlin is no longer invoked as an asynchronous process: a
+new merlin process is started for each query.  Under the hood, merlin will make
+its best to manage resources in an efficient way (via a resident process called
+*ocamlmerlin-server*).
+
+In other word, editor modes no longer have to do process management.
+
+Finally, commands no longer maintain state on merlin side. In previous
+versions, buffer specific settings (compiler flags, findlib packages, syntax
+extensions, ...) were set by calling the appropriate commands.  State was split
+between merlin and the editor, which was hard to track and could cause
+desynchronization.
+
+In this version, all this settings are passed on the command line. Arguments
+look a lot like the ocaml compiler ones.
+
+Try calling:
+- `ocamlmerlin single -help` for general information
+- `ocamlmerlin single -flags-help` for a detailed list of accepted flags
+- `ocamlmerlin single -commands-help` for a list of supported commands
+
+### Backward compatibility
+
+This change is made in a backward compatible way: sessions that worked with
+merlin 2 should give the same answer with merlin 3.
+This new protocol is only enabled if a command is passed on the commandline.
+
+Two binaries are distributed: `ocamlmerlin` and `ocamlmerlin-server`.
+`ocamlmerlin` is a lightweight wrapper that will call the server in the way it
+determined to be appropriate.
+
+In simple cases, a new instance of ocamlmerlin-server is ran for each query.  A
+more efficient but more complex setup is to reuse an existing instance. The
+wrapper will take care of that transparently.
+
+`ocamlmerlin` is the only binary one should execute. `ocamlmerlin-server` will
+be used by the wrapper if necessary and should never be executed manually.
+
+The first argument passed to `ocamlmerlin` determines how merlin will behave:
+
+- `old-protocol` executes the merlin frontend from previous version.  It is a
+  top level reading and writing commands in a JSON form.
+
+- `single` is a simpler frontend that reads input from stdin, processes a
+  single query and outputs result on stdout.
+
+- `server` works like `single`, but uses a background process to speedup
+  processing.
+
+If the first argument is not one of these, Merlin fallbacks to `old-protocol`
+for compatibility. The new protocol is enabled only with `single` and `server`.
+
+Finally, `ocamlmerlin server stop-server` is a special case to shutdown the
+background server, if it is running.
+
+During development or debugging of the editor mode, one can use the single mode
+and switch to server mode for deployment: visible behavior shouldn't differ,
+the merlin server will be managed automatically.
+
+## Getting started
+
+You can play with Merlin from the commandline. This can give you a feeling of
+how Merlin could be driven from an editor:
+
+```shell
+$ cat test.ml
+let x = 5
+let y = 3.0 *. x
+$ ocamlmerlin single type-enclosing -position '1:5' -filename test.ml < test.ml 
+{
+  "class" : "return",
+  "value" : [
+    {
+      "tail" : "no",
+      "end" : {
+        "line" : 1,
+        "col" : 5
+      },
+      "type" : "int",
+      "start" : {
+        "line" : 1,
+        "col" : 4
+      }
+    }
+  ]
+}
+$ ocamlmerlin single complete-prefix -prefix 'List.m' -position '2:14' -filename test.ml < test.ml 
+{
+  "class" : "return",
+  "value" : {
+    "entries" : [
+      {
+        "info" : "",
+        "name" : "map",
+        "kind" : "Value",
+        "desc" : "('a -> 'b) -> 'a list -> 'b list"
+      },
+      {
+        "info" : "",
+        "name" : "map2",
+        "kind" : "Value",
+        "desc" : "('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list"
+      },
+      {
+        "name" : "mapi",
+        "info" : "",
+        "desc" : "(int -> 'a -> 'b) -> 'a list -> 'b list",
+        "kind" : "Value"
+      },
+      {
+        "name" : "mem",
+        "info" : "",
+        "desc" : "'a -> 'a list -> bool",
+        "kind" : "Value"
+      },
+      ... 
+    ],
+    "context" : null
+  }
+}
+$ ocamlmerlin single errors -filename test.ml < test.ml
+{
+  "class" : "return",
+  "value" : [
+    {
+      "message" : "Unbound value List.m",
+      "valid" : true,
+      "end" : {
+        "line" : 2,
+        "col" : 14
+      },
+      "sub" : [],
+      "type" : "error",
+      "start" : {
+        "col" : 8,
+        "line" : 2
+      }
+    }
+  ]
+}
+```
+
+## Anatomy of command line arguments
+
+Merlin command line looks like:
+
+```shell
+$ ocamlmerlin <single|server> <command-global-and-compiler-flags> < ml-source.ml
+```
+
+Command flags are described below. Global and compilers flags are described by
+`ocamlmerlin single -flags-help`.
+
+## Answers
+
+Merlin answers always have the same shape:
+
+```javascript
+{
+  "class": "return" | "failure" | "error" | "exception",
+  "value": <defined-by-class-and-request>,
+  "notifications": string list 
+}
+```
+
+If processing succeeded, class is "return" and "value" is defined by the
+command. Otherwise, value is a string:
+- "exception" means something bad happened to Merlin, you should fill a bug
+  report
+- "failure" means that Merlin couldn't understand your request, maybe there is
+  a typo, an argument missing, etc.
+- "error" means Merlin couldn't process the query because of some problem with
+  the setup: wrong OCaml version, missing file, etc.
+
+Notifications are messages to be reported to the user. For instance if there is
+a typo in the `.merlin` file, Merlin will generate a notification then ignore
+the error and continue processing.
+
+## Commands
+
+### `case-analysis -start <position> -end <position>`
+
+       -start <position>  Where analysis starts
+         -end <position>  Where analysis ends
+
+When the range determined by (-start, -end) positions is an expression,
+this command replaces it with [match expr with _] expression where a branch is introduced for each immediate value constructor of the type that was determined for expr.
+When it is a variable pattern, it is further expanded and new branches are introduced for each possible immediate constructor of this variable.
+The return value has the shape `[{'start': position, 'end': position}, content]`, where content is string.
+
+
+### `complete-prefix -position <position> [ -doc <bool> ] -prefix <string> [ -types <bool> ]`
+
+    -position <position>  Position to complete
+             -doc <bool>  Add docstring to entries (default is false)
+        -prefix <string>  Prefix to complete
+           -types <bool>  Report type information (default is true)
+
+This functions completes an identifier that the user started to type.
+It returns a list of possible completions.
+With '-types y' (default), each completion comes with type information.
+With '-doc y' it tries to lookup OCamldoc, which is slightly more time consuming.
+
+The result has the form:
+```javascript
+{
+  'context': (null | ['application',{'argument_type': string, 'labels': [{'name':string,'type':string}]}]),
+  'entries': [{'name':string,'kind':string,'desc':string,'info':string}]
+}
+```
+
+Context describe where completion is occurring. Only application is distinguished now: that's when one is completing the arguments to a function call. In this case, one gets the type expected at the cursor as well as the other labels.
+
+Entries is the list of possible completion. Each entry is made of:
+- a name, the text that should be put in the buffer if selected
+- a kind, one of `'value'`, `'variant'`, `'constructor'`, `'label'`, `'module'`, `'signature'`, `'type'`, `'method'`, `'#'` (for method calls), `'exn'`, `'class'`
+- a description, most of the time a type or a definition line, to be put next to the name in completion box
+- optional information which might not fit in the completion box, like signatures for modules or documentation string.
+
+### `construct -position <position> [ -with-values <none|local> -depth <int> ]`
+
+    -position <position>      Position where construct should happen
+    -with-values <none|local> Use values from the environment 
+                              (experimental, defaults to none)
+    -depth <int>              Depth of the search (defaults to 1)
+
+When the position determined by `-position` is a hole (`_`), this command
+  returns a list of possible terms that could replace it given its type.
+When `-with-values` is set to local, values in the current environment will be
+  used in the constructed terms. This feature is still under development.
+
+### `document -position <position> [ -identifier <string> ]`
+
+    -position <position>  Position to complete
+    -identifier <string>  Identifier
+
+Returns OCamldoc documentation as a string.
+If `-identifier ident` is specified, documentation for this ident is looked up from environment at `-position`.
+Otherwise, Merlin looks for the documentation for the entity under the cursor (at `-position`).
+
+### `enclosing -position <position>`
+
+    -position <position>  Position to complete
+
+Returns a list of locations `{'start': position, 'end': position}` in increasing size of all entities surrounding the position.
+(In a lisp, this would be the locations of all s-exps that contain the cursor.)
+
+### `errors`
+
+
+Returns a list of errors in current buffer.
+The value is a list where each item as the shape:
+
+```javascript
+{
+'start' : position,
+'end'   : position,
+'valid' : bool,
+'message' : string,
+'sub' : sub_error list,
+'type'  : ('type'|'parser'|'lexer'|'env'|'warning'|'unknown')
+}
+
+sub_error ::=
+{
+  'start'   : position,
+  'end'     : position,
+  'message' : string
+}
+```
+
+`start` and `end` are omitted if error has no location (e.g. wrong file format), otherwise the editor should probably highlight / mark this range.
+`type` is an attempt to classify the error.
+`valid` is here mostly for informative purpose. It reflects whether Merlin was expecting such an error to be possible or not, and is useful for debugging purposes.
+`message` is the error description to be shown to the user.
+`sub` is an experimental extension to put more detailed information about type errors (for instance the location of the field that mismatches between an interface and an implementation).
+
+### `expand-prefix -position <position> -prefix <string> [ -types <bool> ]`
+
+    -position <position>  Position to complete
+        -prefix <string>  Prefix to complete
+           -types <bool>  Report type information (default is false)
+
+
+The function behaves like `complete-prefix`, but it also handles partial, incorrect, or wrongly spelled prefixes (as determined by some heuristic).
+For instance, `L.ma` can get expanded to `List.map`. This function is a useful fallback if normal completion gave no results.
+Be careful that it always return fully qualified paths, whereas normal completion only completes an identifier (last part of a module path).
+
+### `extension-list [ -status <all|enabled|disabled> ]`
+
+-status <all|enabled|disabled>  Filter extensions
+
+List all known / currently enabled / currently disabled extensions as a list of strings.
+
+### `findlib-list`
+
+
+Returns all known findlib packages as a list of string.
+
+### `flags-list`
+
+
+Returns supported compiler flags.The purpose of this command is to implement interactive completion of compiler settings in an IDE.
+
+### `holes`
+
+This command will return the ordered list of the positions and types of all
+holes in the current document.
+
+### `jump -target <string> -position <position>`
+
+        -target <string>  Entity to jump to
+    -position <position>  Position to complete
+
+This command can be used to assist navigation in a source code buffer.
+Target is a string that can contain one or more of the 'fun', 'let', 'module' and 'match' words.
+It returns the starting position of the function, let definition, module or match expression that contains the cursor
+
+
+### `phrase -target <next|prev> -position <position>`
+
+     -target <next|prev>  Entity to jump to
+    -position <position>  Position to complete
+
+Returns the position of the next or previous phrase (top-level definition or module definition).
+
+### `list-modules [ -ext <extension> -ext ... ]`
+
+        -ext <extension>  file extensions to look for
+
+Looks into project source paths for files with an extension matching and prints the corresponding module name.
+
+### `locate [ -prefix <string> ] -position <position> [ -look-for <interface|implementation> ]`
+
+        -prefix <string>  Prefix to complete
+    -position <position>  Position to complete
+-look-for <interface|implementation>  Prefer opening interface or implementation
+
+Finds the declaration of entity at the specified position, Or referred to by specified string.
+Returns either:
+- if location failed, a `string` describing the reason to the user,
+- `{'pos': position}` if the location is in the current buffer,
+- `{'file': string, 'pos': position}` if definition is located in a different file.
+
+### `occurrences -identifier-at <position>`
+
+-identifier-at <position>  Position to complete
+
+Returns a list of locations `{'start': position, 'end': position}` of all occurrences in current buffer of the entity at the specified position.
+
+### `outline`
+
+
+Returns a tree of objects `{'start': position, 'end': position, 'name': string, 'kind': string, 'children': subnodes}` describing the content of the buffer.
+
+### `path-of-source -file <filename>`
+
+        -file <filename>  filename to look for in project paths
+
+Looks for first file with a matching name in the project source and build paths
+
+### `shape -position <position>`
+
+    -position <position>  Position 
+
+This command can be used to assist navigation in a source code buffer.
+It returns a tree of all relevant locations around the cursor.
+It is similar to outline without telling any information about the entity at a given location.
+```javascript
+shape =
+{
+  'start' : position,
+  'end'   : position,
+  'children' : [shape]
+}
+```
+
+
+### `type-enclosing -position <position> [ -expression <string> ] [ -cursor <int> ] [ -index <int> ]`
+
+    -position <position>  Position to complete
+    -expression <string>  Expression to type
+           -cursor <int>  Position of the cursor inside expression
+            -index <int>  Only print type of <index>'th result
+
+Returns a list of type information for all expressions at given position, sorted by increasing size.
+That is asking for type enlosing around `2` in `string_of_int 2` will return the types of `2 : int` and `string_of_int 2 : string`.
+
+If `-expression` and `-cursor` are specified, the first result will be the type
+relevant to the prefix ending at the `cursor` offset.
+
+`-index` can be used to print only one type information. This is useful to
+query the types lazily: normally, Merlin would return the signature of all
+enclosing modules, which can be very expensive.
+
+The result is returned as a list of:
+```javascript
+{
+  'start': position,
+  'end': position,
+  'type': string,
+  // is this expression not in tail position, in tail position, or even a tail call?
+  'tail': ('no' | 'position' | 'call')
+}
+```
+
+### `type-expression -position <position> -expression <string>`
+
+    -position <position>  Position to complete
+    -expression <string>  Expression to type
+
+Returns the type of the expression when typechecked in the environment around the specified position.
+
+### `check-configuration`
+
+
+This command checks that merlin project and options are correct.
+The return value has the shape:
+```javascript
+{
+  'dot_merlins': [path], // a list of string
+  'failures': [message]  // a list of string
+}
+```
+
+## Details about the client/server protocol
+
+single mode
+
+the wrapper
+socket rendez vous
+stopping server
+passing command line arguments
+passing environment variable
+
+## Miscellaneous
+
+`__MERLIN_MASTER_PID` environment variable is set in processes invoked by
+merlin.
+
+For PPX writers, the tool name is set to "merlin".
+
+### Locations in PPX rewriters
+
+FIXME: this should go somewhere else.
+
+When trying to match a location with an AST node, Merlin traverses the tree
+from the root, descending into all nodes that overlaps the location.
+
+The most important part is that the locations of the rewritten AST nodes
+actually form a tree.
+
+A few attributes can be added on AST nodes to guide Merlin.
+
+#### `[@merlin.loc]`
+
+The location of "merlin.loc" will be used instead of the normal location of the
+node when traversing the AST.  This is useful to extend the range of nodes.
+
+For instance in the AST for `let x = y in z` nothing can be said about the
+location of `in` as it doesn't appear in the abstract syntax.
+
+Thus if the cursor is after `y` and before `z`, merlin cannot tell which node
+to chose (should the completion use the context `y`, where `x` doesn't appear,
+or the context of `z` ?).
+
+This is solved by tweaking the parser to add `[@merlin.loc]` attributes, with
+the locations marked by `[]`: `let x =[ y ]in[ z]`.
+
+This way, merlin will pick `z` node after `in` and `y` node before. 
+
+#### `[@merlin.hide]` and `[@merlin.focus]`
+
+PPX rewriters sometime generate codes that need to be given a location so that
+errors are reported appropriately but for which other Merlin features are not
+meaningful (completion or type-enclosing).
+
+`[@merlin.hide]` attribute causes merlin to ignore a branch of the AST.
+
+When multiple branches overlap a location, `[@merlin.focus]` attribute forces
+merlin to select a single branch and ignore the others.
diff --git a/doc/dev/SERVER.md b/doc/dev/SERVER.md
new file mode 100644
index 0000000..d1cd785
--- /dev/null
+++ b/doc/dev/SERVER.md
@@ -0,0 +1,29 @@
+Merlin now implements a server. This simplify implementation of editor modes by
+allowing synchronous process executions.
+
+The `ocamlmerlin` binary is a wrapper, written in C, that redirects queries to
+`ocamlmerlin-server`.
+
+It can be used in a few different ways.
+
+`old-protocol` works as a repl: one writes a query (formatted as a json value)
+and reads an answer (also json). It is the protocol of merlin 1.x and 2.x.
+When detecting old-protocol, `ocamlmerlin` wrapper simply executes the
+ocamlmerlin-server. It is documented in [OLD-PROTOCOL.md](OLD-PROTOCOL.md).
+
+With the new protocol, the query is specified on the command-line and the
+content is read from standard input.  Merlin can now be used like a regular
+UNIX command. Answers are written on standard output as JSON-values (or
+optionally, S-expression).
+
+In `single` mode, the wrapper executes `ocamlmerlin-server` and processes a
+single query.
+In `server` mode, the wrapper looks for an existing server. If none are found,
+it executes a new one. Then it redirects the query to the server, wait for an
+answer and terminates.
+
+The editor plugin does the same work in both cases, caching & calling the
+server is transparent.
+
+Mode is specified as the first argument to `ocamlmerlin` binary, and defaults to
+`old-protocol` for compatibility with previous versions.
diff --git a/doc/features.md b/doc/features.md
new file mode 100644
index 0000000..e03ec48
--- /dev/null
+++ b/doc/features.md
@@ -0,0 +1,59 @@
+# Polarity search
+
+A Hoogle-like type-based search for libraries that are in merlin's scope.
+
+The commands `:MerlinSearch` (vim) / `merlin-search` (emacs) take a search query
+and return the list of identifiers that satisfy this query.
+
+The query language is simply a list of path identifiers prefixed by `+` or `-`,
+e.g. `-int`, `-int +string`, `-Hashtbl.t +int`.
+
+`-` is interpreted as "consuming" and `+` as "producing": `-int +string` looks
+for functions consuming an `int` and producing a `string`.
+
+The search algorithm uses type variance to filter results. Thus, search will
+proceed inside abstract types, continuation-passing-style, ... as long as
+variance annotations are available.
+
+# Open refactoring
+
+Merlin provides a pair of commands to help cleaning the code in the scope of an
+`open` statement.
+
+Two new commands (`:MerlinRefactorOpen`, `:MerlinRefactorOpenQualify` in vim,
+and `merlin-refactor-open`, `merlin-refactor-open-qualify` in Emacs) help
+cleaning the code in the scope of an `open` statement.
+
+When the cursor is on an open statement:
+- `:MerlinRefactorOpen` (vim) / `merlin-refactor-open` (emacs) will remove
+  references to the path of the open that are made useless
+- `:MerlinRefactorOpenQualify` (vim) / `merlin-refactor-open-qualify` (emacs)
+  will always add references to this path
+
+Starting from:
+
+```ocaml
+open Unix
+
+let times = Unix.times ()
+let f x = x.Unix.tms_stime, x.Unix.tms_utime
+```
+
+Calling `:MerlinRefactorOpen` with the cursor on the open statement will
+produce:
+
+```ocaml
+open Unix
+
+let times = times ()
+let f x = x.tms_stime, x.tms_utime
+```
+
+Calling `:MerlinRefactorOpenQualify` will restore:
+
+```ocaml
+open Unix
+
+let times = Unix.times ()
+let f x = x.Unix.tms_stime, x.Unix.tms_utime
+```
diff --git a/doc/next/Protocol.wiki b/doc/next/Protocol.wiki
new file mode 100644
index 0000000..086583a
--- /dev/null
+++ b/doc/next/Protocol.wiki
@@ -0,0 +1,42 @@
+Next merlin protocol should be stateless.
+Also worth taking a look: [[https://github.com/Microsoft/language-server-protocol|Microsoft/language-server-protocol]].
+
+The protocol is still implemented as a series of request/answer.
+
+{{{
+  request-format:
+  {
+    uri: "path to current document",
+    source: "full source text",
+    setup: merlin-setup,
+    query: merlin-query,
+    configuration: {
+      terminal_width: int,
+      verbosity: int,
+    },
+  }
+  
+  answer-format:
+  {
+    class: "return" | "failure" | "error" | "exception",
+    value: <defined-by-class-and-request>,
+    notifications: string list 
+  }
+  
+  merlin-query:
+  ...
+  
+  merlin-setup:
+  {
+    build_path: string list,
+    source_path: string list,
+    cmi_path: string list,
+    cmt_path: string list,
+    findlib: string,
+    stdlib: string,
+    packages: string list,
+    flags: string list,
+    reader: string list,
+    suffixes: (string * string) list
+  }
+}}}
diff --git a/doc/next/RATIONALE.wiki b/doc/next/RATIONALE.wiki
new file mode 100644
index 0000000..f1c6248
--- /dev/null
+++ b/doc/next/RATIONALE.wiki
@@ -0,0 +1,151 @@
+== Performance ==
+
+Merlin put a close attention on performance.  All was done to provide answer
+below reaction time for common queries.
+
+The idea was that the work done for answering should be proportional to the
+diff since the last query rather than the whole buffer size.
+
+To this end, the design was a bit more complex than necessary and didn't evolve
+well as new features were integrated.
+
+A recent requirement put the final nail in the coffin for this principle:
+syntax extensions expect to see the whole file at once, effectively defeating
+the purpose of sub-linear optimizations.
+
+This is the opportunity to redesign Merlin, in the hope of simplifying the work
+for all components involved in the toolchain: the core of Merlin, the OCaml
+typechecker, editors integration.
+
+== Protocol ==
+
+A new protocol will be designed. For compatibility reason, the old one will
+still be provided on top, but the expectation is that editor modes will be
+migrated to the new one over time.
+
+The main idea behind the new protocol is that queries should be self-contained:
+no implicit state is assumed between queries.
+
+Executing a query on an existing process and on a fresh one should lead to the
+same result, performance aside.
+
+Intended benefits:
+
+- reproducibility and stability; restarting always lead to the same
+  behavior, otherwise it is a bug
+
+- clear separation of responsibility; in particular buffer local state is
+  managed by the editor, and not split between processes
+
+- implementation is pure and performance comes from a memoization layer; the
+  pure layer offers a reference implementation, memoization shouldn't be
+  observable.
+
+== Asynchronicity: editors requirements ==
+
+NOTE: some of this might not be true in all circumstances, but would result in
+twisted implementation or editor specific design.
+
+*Vim* cannot do asynchronous operations.  *Emacs* cannot most of the time.
+Otherwise it can be implemented in CPS-style but we have to be very careful.
+*Neovim* and *Atom* should have no problem dealing with that.
+
+As a consequence protocol is synchronous by default (Merlin will anyway process
+queries serially) but editors can tweak the integration to provide better
+experience.
+
+== Asynchronicity: for optimization ==
+
+A different kind of optimization can be explored later: refining results
+asynchronously.
+
+The idea is that for completion, changes that happened in the last second might
+not be relevant for the query. Merlin could give an immediate answer from the
+out-of-date cache, and refine it after recomputation.
+
+The user always get a result in real-time, and potentially better suggestions
+after a reasonable latency (the normal one).
+
+The drawback is that this introduces more complexity on editor side. Not all
+editor can support that kind of interactions:
+- vim is out of scope,
+- emacs will be hard to get right,
+- modern editors such as Neovim and Atom should be easy,
+- not sure about Sublime Text.
+
+== Debugging ==
+
+In the current version of Merlin, debugging can be done in two ways:
+- via MERLIN_LOG file, where the whole communication is logged & some feature
+  specific Printf-debugging is available
+- via `dump` command, which exposes some internal structures.
+
+The stateless protocol should help debugging and reporting bug:
+- only the last command needs to be reported,
+- users can first check the output in a fresh process.
+
+The printf-debugging is feature specific and hardly readable.  The new
+intention is to produce a human-readable trace at the same time the code is
+executed, explaining intermediate decisions -- a dynamic counterpart to
+literate programming.
+
+As such, all internal structures will come with a human-friendly printer.
+
+The trace should help *profiling*, by tracking times between steps.  The trace
+should allow working at different level of precision, by unfolding sub parts of
+the computation.  At the basic level, no internal decisions are printed and so
+the cost should be negligible.  At the most verbose level, all steps are
+printed, which is probably expensive but shouldn't matter in debug mode.
+
+FIXME:
+- explore using sturgeon for interactive tracing
+- should we use ppx for deriving printers and logging code?
+
+== Documentation & testing ==
+
+Both are hard to achieve after the facts.  Each time a feature is ported to the
+new implementation, documentation and testing should be added.
+
+Documentation should not necessarily target the end-user but should explain
+design rationale and intended use cases, so that end-user documentation is easy
+to derive.
+
+I don't know how to do proper tests... When a feature seems hard to properly
+test, this should at least be documented, e.g. in a TODO file.  Otherwise,
+tests should embed as most state as possible and not rely on external files
+(OCaml / Opam setup, findlib packages, etc...).
+
+=== Editor integration ===
+
+Even more important is to do this when adding a feature in a specific mode.
+
+Most users won't care about actual implementation details but will care about
+how the feature is made accessible in their editor (prototypical example: local
+type-enclosing keymap with C-up C-down C-w in emacs).
+
+=== Documentation medium ===
+
+Another question worth asking is how the documentation is provided and written.
+
+For individual files, I am comfortable with markdown. Other text-based file
+formats are welcome too if they prove more appropriate.
+
+For multiple or structures files, I am considering directly using wiki
+language, or markdown-like wiki.
+
+== OCaml support ==
+
+In current Merlin, OCaml frontend received a non-negligible quantity of
+patches.
+
+Recent changes in the OCaml compiler made integration easier, mainly
+attributes/extensions and lazy substitution. The switch to PPX made support for
+CamlP4 less relevant, most built-in extensions will be removed.
+
+Merlin will still use a patched version of the compiler, but will try to stay
+close to upstream.
+
+Also some changes should be upstreamed soon:
+- custom short-path implementation
+- bidirectional typechecking of arguments
+- state isolation
diff --git a/doc/next/merlin.wiki b/doc/next/merlin.wiki
new file mode 100644
index 0000000..bc45e73
--- /dev/null
+++ b/doc/next/merlin.wiki
@@ -0,0 +1,21 @@
+@let-def: this design document gathers requirements and ideas for the next
+  version of merlin.  The purpose is to consolidate features that were added
+  lately and cleanup legacy cruft.
+
+== TL;DR ==
+
+* simpler & stateless protocol
+* pure implementation for reference
+* performance added on top, memoization & asynchronicity
+* traceability, log all decisions and print internal structures
+* maintenability, minimize change to OCaml codebase
+
+See [[RATIONALE]].
+
+== Implementation ==
+
+Merlin is split in three main components:
+
+* [[Protocol]], communicates with outside world
+* [[Kernel]], wraps the OCaml frontend
+* [[Analysis]], answers specific questions on the codebase
diff --git a/doc/pres/pres-meetup-21-05-13.tex b/doc/pres/pres-meetup-21-05-13.tex
new file mode 100644
index 0000000..f64082d
--- /dev/null
+++ b/doc/pres/pres-meetup-21-05-13.tex
@@ -0,0 +1,207 @@
+% Copyright 2013 Frederic Bour, all rights reserved
+\documentclass{beamer}
+
+\usepackage[french]{babel}
+\usepackage[utf8x]{inputenc}
+\usepackage[T1]{fontenc}
+\usepackage{default}
+\usepackage{tikz}
+
+\newcommand{\sectitle}{\frametitle{\insertsection}}
+
+\title{Merlin, an OCaml assistant}
+\author{Frédéric \bsc{Bour}}
+\date{May 21, 2013}
+
+\usetheme{Warsaw}
+
+\AtBeginSection[] {
+  \begin{frame}[plain]
+    \frametitle{Plan}
+    \tableofcontents[currentsection]
+  \end{frame}
+  \addtocounter{framenumber}{-1}
+}
+
+\newcommand{\Simley}[1]{%
+\begin{tikzpicture}[scale=0.11]
+    \newcommand*{\SmileyRadius}{1.0}%
+    \draw [fill=brown!10] (0,0) circle (\SmileyRadius)% outside circle
+        %node [yshift=-0.22*\SmileyRadius cm] {\tiny #1}% uncomment this to see the smile factor
+        ;  
+
+    \pgfmathsetmacro{\eyeX}{0.5*\SmileyRadius*cos(30)}
+    \pgfmathsetmacro{\eyeY}{0.5*\SmileyRadius*sin(30)}
+    \draw [fill=cyan,draw=none] (\eyeX,\eyeY) circle (0.15cm);
+    \draw [fill=cyan,draw=none] (-\eyeX,\eyeY) circle (0.15cm);
+
+    \pgfmathsetmacro{\xScale}{2*\eyeX/180}
+    \pgfmathsetmacro{\yScale}{1.0*\eyeY}
+    \draw[color=red, domain=-\eyeX:\eyeX]   
+        plot ({\x},{
+            -0.1+#1*0.15 % shift the smiley as smile decreases
+            -#1*1.75*\yScale*(sin((\x+\eyeX)/\xScale))-\eyeY});
+\end{tikzpicture}%
+}%
+\newcommand{\smiley}{\Simley{0.5}}
+
+\begin{document}
+
+\begin{frame}
+  \titlepage
+\end{frame}
+
+% \begin{frame}{Table des matières}
+%   \tableofcontents
+% \end{frame}
+
+\section{An assistant in your editor}
+
+\subsection{The usual toplevel}
+
+\begin{frame}
+  \sectitle
+
+  The toplevel as a tool to interact with OCaml during edition.
+
+  \pause
+
+  \begin{itemize}
+    \item Side-effects when evaluating phrases
+      \pause
+    \item Phrases evaluated in arbitrary order
+      \pause \\
+      (name shadowing, arbitrary scoping...)
+  \end{itemize}
+\end{frame}
+
+\subsection{Merlin}
+
+\begin{frame}
+  \sectitle
+
+  Merlin improves on this situation.
+  \pause
+
+  \begin{itemize}
+    \item Checks syntax and typing, but doesn't evaluate.
+      \pause
+    \item Works incrementally, in document order
+      (if you know Coq, think of ``Proof-General for OCaml'').
+      \pause
+    \item Resilient to syntax and typing errors (experimental).
+  \end{itemize}
+\end{frame}
+
+\section{In practice}
+
+\subsection{Upsides}
+
+\begin{frame}
+  \frametitle{Upsides}
+
+  \begin{block}{Typing information}
+    \begin{itemize}
+      \item completion at point, sensitive to the current typing environment
+        \pause
+      \item type of (sub)expressions at point
+        \pause
+      \item foundations are there for all kind of type-directed
+        feedback and analyses
+        \pause
+    \end{itemize}
+  \end{block}
+
+  \begin{block}{Instant feedback}
+    \begin{itemize}
+      \item Direct error feedback in the editor
+        \pause
+      \item can be a distraction \smiley
+        \pause
+    \end{itemize}
+  \end{block}
+
+  No surprise: the scoping, typing rules are exactly those of the
+  compiler.
+\end{frame}
+
+\subsection{(Current) Limitations}
+
+\begin{frame}
+  \frametitle{(Current) Limitations}
+  \begin{block}{Syntax extensions}
+    \begin{itemize}
+      \item No support for camlp4 planned
+        \pause
+      \item but we hard-code quotations and specific extensions \\
+        (\texttt{lwt}, \texttt{type-conv}, ...)
+        \pause
+    \end{itemize}
+  \end{block}
+
+  \begin{block}{Hard language constructs}
+    \begin{itemize}
+      \item recursive definitions
+        \pause
+      \item first-class modules, OOP, etc.
+        \pause
+      \item[$\Rightarrow$] hard to provide feedback on those when code
+        is not valid
+    \end{itemize}
+  \end{block}
+\end{frame}
+
+\subsection{Features}
+
+\begin{frame}
+  \sectitle
+
+  From both Vim and Emacs :
+
+  \begin{itemize}
+    \item identifier completion,
+    \item type feedback,
+    \item integrated error messages,
+    \item \texttt{ocamlfind} integration \\
+      {\small {\tt .merlin} file for projects},
+    \item a few syntax extensions.
+  \end{itemize}
+
+\end{frame}
+
+\subsection{The future}
+
+\begin{frame}
+  \frametitle{The future}
+
+  Short- to long-term.
+
+  \begin{itemize}
+    \item work on handling of syntax errors
+      \pause
+    \item coordination with other tools (\texttt{spotter}, \texttt{ocamldoc}),
+      \pause
+    \item more extensions. \\
+      {\small \texttt{js\_of\_ocaml} in experimental branch}
+  \end{itemize}
+
+\end{frame}
+
+\section*{Demo}
+
+\begin{frame}
+ \sectitle
+ 
+ Thanks for your attention.
+
+ \vfill
+
+ For more information : {\tt http://github.com/def-lkb/merlin} 
+
+ \vfill
+
+ And now for a small demo...
+ 
+\end{frame}
+
+\end{document}
diff --git a/dot-merlin-reader.opam b/dot-merlin-reader.opam
new file mode 100644
index 0000000..8593cab
--- /dev/null
+++ b/dot-merlin-reader.opam
@@ -0,0 +1,21 @@
+opam-version: "2.0"
+maintainer:   "defree@gmail.com"
+authors:      "The Merlin team"
+synopsis:     "Reads config files for merlin"
+homepage:     "https://github.com/ocaml/merlin"
+bug-reports:  "https://github.com/ocaml/merlin/issues"
+dev-repo:     "git+https://github.com/ocaml/merlin.git"
+license:      "MIT"
+build: [
+  ["dune" "subst"] {dev}
+  ["dune" "build" "-p" name "-j" jobs]
+]
+depends: [
+  "ocaml" {>= "4.06.1" & < "5.0.0"}
+  "dune" {>= "2.7.0"}
+  "yojson" {>= "1.6.0"}
+  "ocamlfind" {>= "1.6.0"}
+  "csexp" {>= "1.2.3"}
+]
+description:
+  "Helper process: reads .merlin files and gives the normalized content to merlin"
diff --git a/dune-project b/dune-project
new file mode 100644
index 0000000..9b5b3af
--- /dev/null
+++ b/dune-project
@@ -0,0 +1,7 @@
+(lang dune 2.9)
+(name merlin)
+(using menhir 2.0)
+
+(cram enable)
+(formatting disabled)
+(implicit_transitive_deps false)
diff --git a/dune-release.sh b/dune-release.sh
new file mode 100755
index 0000000..ab80ae2
--- /dev/null
+++ b/dune-release.sh
@@ -0,0 +1,32 @@
+#!/bin/sh
+
+TAG="$1"
+VER="$2"
+
+if [ -z "$TAG" ]; then
+  printf "Usage: ./dune-release.sh <tag-name> [<pkg-version>]\n"
+  printf "Please make sure that dune-release is available.\n"
+  exit 1
+fi
+
+FLAGS="-t $TAG"
+
+if [ -n "$VER" ]; then
+  FLAGS="$FLAGS --pkg-version=$VER"
+fi
+
+step()
+{
+  printf "Continue? [Yn] "
+  read action
+  if [ "x$action" == "xn" ]; then exit 2; fi
+  if [ "x$action" == "xN" ]; then exit 2; fi
+}
+
+dune-release distrib -p merlin -n merlin $FLAGS --skip-tests #--skip-lint
+step
+dune-release publish distrib -p merlin -n merlin $FLAGS
+step
+dune-release opam pkg -p merlin -n merlin $FLAGS
+step
+dune-release opam submit -p merlin -n merlin $FLAGS
diff --git a/emacs/check.sh b/emacs/check.sh
new file mode 100755
index 0000000..b72a473
--- /dev/null
+++ b/emacs/check.sh
@@ -0,0 +1,47 @@
+#!/bin/sh -e
+
+# Adapted from https://github.com/purcell/package-lint/blob/master/run-tests.sh
+EMACS="${EMACS:=emacs}"
+
+NEEDED_PACKAGES="package-lint company iedit auto-complete"
+
+TO_CHECK=*.el
+
+INIT_PACKAGE_EL="(progn \
+  (require 'package) \
+  (add-to-list 'package-archives \
+    '(\"melpa\" . \"https://melpa.org/packages/\") t) \
+  (package-initialize) \
+  (package-refresh-contents) \
+  (dolist (pkg '(${NEEDED_PACKAGES})) \
+    (unless (package-installed-p pkg) \
+      (package-install pkg))))"
+
+# Refresh package archives, because the test suite needs to see at least
+# package-lint and cl-lib.
+"$EMACS" -Q -batch \
+         --eval "$INIT_PACKAGE_EL"
+
+# Byte compile, failing on byte compiler errors, or on warnings unless ignored
+if [ -n "${EMACS_LINT_IGNORE+x}" ]; then
+    ERROR_ON_WARN=nil
+else
+    ERROR_ON_WARN=t
+fi
+
+"$EMACS" -Q -batch \
+         -L . \
+         --eval "$INIT_PACKAGE_EL" \
+         --eval "(setq byte-compile-error-on-warn ${ERROR_ON_WARN})" \
+         -f batch-byte-compile \
+         ${TO_CHECK}
+
+# Lint failures are ignored if EMACS_LINT_IGNORE is defined, so that lint
+# failures on Emacs 24.2 and below don't cause the tests to fail, as these
+# versions have buggy imenu that reports (defvar foo) as a definition of foo.
+"$EMACS" -Q -batch \
+         --eval "$INIT_PACKAGE_EL" \
+         -L . \
+         --eval "(require 'package-lint)" \
+         -f package-lint-batch-and-exit \
+         ${TO_CHECK} || [ -n "${EMACS_LINT_IGNORE+x}" ]
diff --git a/emacs/dune b/emacs/dune
new file mode 100644
index 0000000..0363159
--- /dev/null
+++ b/emacs/dune
@@ -0,0 +1,11 @@
+(install
+ (package merlin)
+ (section share_root)
+ (files (merlin-ac.el as emacs/site-lisp/merlin-ac.el)
+        (merlin-cap.el as emacs/site-lisp/merlin-cap.el)
+        (merlin-company.el as emacs/site-lisp/merlin-company.el)
+        (merlin-iedit.el as emacs/site-lisp/merlin-iedit.el)
+        (merlin-imenu.el as emacs/site-lisp/merlin-imenu.el)
+        (merlin-xref.el as emacs/site-lisp/merlin-xref.el)
+        (merlin.el as emacs/site-lisp/merlin.el)))
+
diff --git a/emacs/merlin-ac.el b/emacs/merlin-ac.el
new file mode 100644
index 0000000..64032d5
--- /dev/null
+++ b/emacs/merlin-ac.el
@@ -0,0 +1,166 @@
+;;; merlin-ac.el --- Merlin and auto-complete integration.   -*- coding: utf-8; lexical-binding: t -*-
+;; Licensed under the MIT license.
+
+;; Author: Simon Castellan <simon.castellan(_)iuwt.fr>
+;;         Frédéric Bour <frederic.bour(_)lakaban.net>
+;;         Thomas Refis <thomas.refis(_)gmail.com>
+;; Created: 15 May 2015
+;; Version: 0.1
+;; Keywords: ocaml languages
+;; Package-Requires: ((emacs "25.1") (merlin "3") (auto-complete "1.5"))
+;; URL: http://github.com/ocaml/merlin
+
+;;; Commentary:
+
+;; To integrate this auto-complete backend with Merlin, just (require
+;; 'merlin-ac) in your Emacs configuration files.  When `merlin-mode'
+;; is subsequently enabled in buffers, auto-complete will be set up
+;; too.  Some auto-complete settings will be overridden: to avoid this
+;; for finer control, customize the variable `merlin-ac-setup'.
+
+;;; Code:
+
+(require 'merlin)
+(require 'auto-complete)
+
+;; Customization group
+
+(defgroup merlin-ac nil
+  "Merlin integration to auto-complete"
+  :group 'merlin :prefix "merlin-ac-")
+
+(defcustom merlin-ac-setup 'easy
+  "Determine how `merlin' integrates with `auto-complete'."
+  :group 'merlin-ac
+  :type '(choice (const :tag "Integrate with auto-complete" t)
+                 (const :tag "Integrate with auto-complete, use sane default options" easy)
+                 (const :tag "Don't integrate with auto-complete" nil)))
+
+(defcustom merlin-ac-prefix-size 0
+  "If non-nil, specify the minimum number of characters to wait before allowing
+auto-complete"
+  :group 'merlin-ac :type 'integer)
+
+(defcustom merlin-ac-use-summary t
+  "Display types in :summary"
+  :group 'merlin-ac :type 'boolean)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Internal variables
+
+(defvar-local merlin-ac--point nil
+  "Stores the point of last completion (beginning of the prefix).")
+
+(defvar-local merlin-ac--cache nil
+  "Hold a table mapping completion cache for auto-complete.")
+
+(defvar-local merlin-ac--prefix ""
+  "The cache of the prefix for completion")
+
+(defvar-local merlin-ac--ac-prefix ""
+  "The original value of ac-prefix used when computing merlin-ac--prefix")
+
+;; Internal functions
+
+(defun merlin-ac--make-popup-item (data)
+  "Create a popup item from data DATA."
+  (let ((desc (merlin-completion-entry-short-description data)))
+    (popup-make-item
+     ;; Note: ac refuses to display an item if merlin-ac--ac-prefix is not a
+     ;; prefix the item. So "dwim" completion won't work with ac.
+     (merlin-completion-entry-text merlin-ac--prefix data)
+     :summary (when (and merlin-completion-types merlin-ac-use-summary) desc)
+     :symbol (format "%c" (elt (cdr (assoc 'kind data)) 0))
+     :document (let ((doc (cdr-safe (assoc 'info data))))
+                 (unless (equal doc "") doc)))))
+
+(defun merlin-ac--source-refresh-cache ()
+  "Refresh the cache of completion."
+  (setq merlin-ac--prefix (merlin-completion-prefix ac-prefix))
+  (setq merlin-ac--ac-prefix ac-prefix)
+  (setq merlin-ac--cache (mapcar #'merlin-ac--make-popup-item
+                                 (merlin-complete merlin-ac--prefix))))
+
+(defun merlin-ac--source-init ()
+  "Initialize the cache for `auto-complete' completion.
+Called at the beginning of a completion to fill the cache (the
+variable `merlin-ac--cache')."
+  (setq merlin-ac--point ac-point)
+  (merlin-ac--source-refresh-cache))
+
+(defun merlin-ac--prefix ()
+  "Retrieve the prefix for completion with merlin."
+  (let* ((bounds (merlin-completion-bounds))
+         (start  (car-safe bounds))
+         (end    (cdr-safe bounds)))
+    (unless (and bounds (< (- end start) merlin-ac-prefix-size))
+      start)))
+
+(defun merlin-ac--fetch-type ()
+  "Prints the type of the selected candidate"
+  (let ((candidate (merlin-buffer-substring merlin-ac--point (point))))
+    (when merlin-completion-types
+      (mapc (lambda (item)
+              (when (string-equal candidate item)
+                (message "%s: %s" candidate (popup-item-summary item))))
+            merlin-ac--cache))))
+
+(defun merlin-ac--candidates ()
+  "Return the candidates for auto-completion with auto-complete. If the cache is
+wrong then recompute it."
+  (unless (and (equal (merlin-completion-prefix ac-prefix) merlin-ac--prefix)
+               (string-prefix-p merlin-ac--ac-prefix ac-prefix))
+    (merlin-ac--source-refresh-cache))
+  merlin-ac--cache)
+
+;; Public functions
+
+;;;###autoload
+(defun merlin-ac-setup-easy ()
+  "Integrate merlin to auto-complete with sane defaults"
+  (auto-complete-mode t)
+  (local-set-key (kbd "C-c C-l") 'ac-merlin-locate)
+  (set (make-local-variable 'ac-auto-show-menu) t)
+  (set (make-local-variable 'ac-auto-start) nil)
+  (set (make-local-variable 'ac-delay) 0.0)
+  (set (make-local-variable 'ac-expand-on-auto-complete) nil)
+  (set (make-local-variable 'ac-ignore-case) nil)
+  (set (make-local-variable 'ac-trigger-commands) nil))
+
+;; I don't like it beginning by "ac" but it is the only way I found to get it
+;; working (otherwise the completion menu just closes itself)
+(defun ac-merlin-locate ()
+  "Locate the identifier currently selected in the ac-completion."
+  (interactive)
+  (when (ac-menu-live-p)
+    (when (popup-hidden-p ac-menu)
+      (ac-show-menu))
+    (let ((merlin-locate-in-new-window 'always))
+      (merlin-call-locate (ac-selected-candidate)))
+    (ac-show-menu)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Register into auto-complete and merlin ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar merlin-ac-source '((init . merlin-ac--source-init)
+                           (candidates . merlin-ac--candidates)
+                           (action . merlin-ac--fetch-type)
+                           (prefix . merlin-ac--prefix)))
+
+(ac-define-source "merlin" merlin-ac-source)
+
+(defun merlin-ac--setup ()
+  (when merlin-ac-setup
+    (if (equal merlin-ac-setup 'easy)
+        (merlin-ac-setup-easy)
+      (auto-complete-mode t))
+    (add-to-list 'ac-sources 'merlin-ac-source)))
+
+(add-hook 'merlin-mode-hook #'merlin-ac--setup)
+
+(provide 'merlin-ac)
+;;; merlin-ac.el ends here
diff --git a/emacs/merlin-cap.el b/emacs/merlin-cap.el
new file mode 100644
index 0000000..114043f
--- /dev/null
+++ b/emacs/merlin-cap.el
@@ -0,0 +1,85 @@
+;;; merlin-cap.el --- Merlin and completion-at-point integration.   -*- coding: utf-8; lexical-binding: t -*-
+;; Licensed under the MIT license.
+
+;; Author: Simon Castellan <simon.castellan(_)iuwt.fr>
+;;         Frédéric Bour <frederic.bour(_)lakaban.net>
+;;         Thomas Refis <thomas.refis(_)gmail.com>
+;; Created: 15 May 2015
+;; Version: 0.1
+;; Keywords: ocaml languages
+;; URL: http://github.com/ocaml/merlin
+
+(require 'merlin)
+
+;; Call merlin-completion-at-point when you want merlin guided completion-at-point.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Internal variables
+
+(defvar-local merlin-cap--table nil
+  "Hold a table mapping completion candidates to their types.")
+
+(defvar-local merlin-cap--cache (cons "" 0)
+  "The cache for calls to completion-at-point so that it does not
+trigger useless merlin calls.")
+
+;; Internal functions
+
+(defun merlin-cap--lookup (string _state)
+  "Lookup the entry STRING inside the completion table."
+  (let ((ret (assoc string merlin-cap--table)))
+    (if ret (message "%s%s" (car ret) (cdr ret)))))
+
+(defun merlin-cap--annotate (candidate)
+  "Retrieve the annotation for candidate CANDIDATE in
+`merlin-completion-annotate-table'."
+  (cdr (assoc candidate merlin-cap--table)))
+
+(defun merlin-cap--table (string pred action)
+  "Implement completion for merlin using `completion-at-point' API."
+  (if (eq 'metadata action)
+      (when merlin-completion-types
+        '(metadata ((annotation-function . merlin-cap--annotate)
+                    (exit-function . merlin-cap--lookup))))
+    (complete-with-action action merlin-cap--table string pred)))
+
+
+;; Public functions
+
+(defun merlin-cap ()
+  "Perform completion at point with merlin."
+  (let*
+      ((bounds       (merlin-completion-bounds))
+       (start        (car bounds))
+       (end          (cdr bounds))
+       (prefix       (merlin-buffer-substring start end))
+       (compl-prefix (merlin-completion-prefix prefix)))
+    (when (or (not merlin-cap--cache)
+              (not (equal (cons prefix start) merlin-cap--cache)))
+      (setq merlin-cap--cache (cons prefix start))
+      (setq merlin-cap--table
+            (mapcar
+             (lambda (a)
+               (cons (merlin-completion-entry-text compl-prefix a)
+                     (concat ": " (merlin-completion-entry-short-description a))))
+             (merlin-complete prefix))))
+    (list start end #'merlin-cap--table
+          . (:exit-function #'merlin-cap--lookup
+                            :annotation-function #'merlin-cap--annotate))))
+
+(defalias 'merlin-completion-at-point 'merlin-cap)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Register into completion-at-point ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun merlin-cap--setup ()
+  (add-hook 'completion-at-point-functions #'merlin-completion-at-point nil 'local))
+
+(add-hook 'merlin-mode-hook #'merlin-cap--setup)
+(when merlin-mode (merlin-cap--setup))
+
+(provide 'merlin-cap)
+;;; merlin-cap.el ends here
diff --git a/emacs/merlin-company.el b/emacs/merlin-company.el
new file mode 100644
index 0000000..c395630
--- /dev/null
+++ b/emacs/merlin-company.el
@@ -0,0 +1,141 @@
+;;; merlin-company.el --- Merlin and company mode integration.   -*- coding: utf-8; lexical-binding: t -*-
+;; Licensed under the MIT license.
+
+;; Author: Simon Castellan <simon.castellan(_)iuwt.fr>
+;;         Frédéric Bour <frederic.bour(_)lakaban.net>
+;;         Thomas Refis <thomas.refis(_)gmail.com>
+;; Created: 15 May 2015
+;; Version: 0.1
+;; Keywords: ocaml languages
+;; Package-Requires: ((emacs "25.1") (merlin "3") (company "0.9"))
+;; URL: http://github.com/ocaml/merlin
+
+;;; Commentary:
+
+;; (require 'merlin-company) should be enough to get merlin to work within
+;; company.
+;;
+;; If you always want company-mode to be available, consider adding:
+;;   (add-hook 'after-init-hook #'global-company-mode)
+;; in your .emacs.
+
+;;; Code:
+
+(require 'merlin)
+(require 'company)
+(require 'cl-lib)
+
+;; It would be nice to define a proper (somewhat stable) interface in merlin.el
+;; to be used by other modules.
+
+(defcustom merlin-company-everywhere t
+  "Non-nil to offer completions in comments and strings."
+  :type 'boolean
+  :group 'merlin)
+
+;; Internal functions
+
+(defun merlin-company--get-candidate-type (candidate)
+  (get-text-property 0 'merlin-compl-type candidate))
+
+(defun merlin-company--get-candidate-doc (candidate)
+  (get-text-property 0 'merlin-compl-doc candidate))
+
+(defun merlin-company--is-module (candidate)
+  (string-equal (merlin-company--get-candidate-type candidate) " <module>"))
+
+(defun merlin-company--has-doc (candidate)
+  (not (or (string-equal (merlin-company--get-candidate-doc candidate) "")
+           (merlin-company--is-module candidate))))
+
+(defun merlin-company--doc-buffer (candidate)
+  "Computes the /doc/ of CANDIDATE and returns the buffer where it printed it"
+  (cond
+   ((merlin-company--has-doc candidate)
+    (let* ((doc (merlin-company--get-candidate-doc candidate))
+                                        ; We add (** and *) around documentation so we can reuse the type buffer
+                                        ; without getting some weird highlighting.
+           (doc (concat
+                 "val " candidate " : "
+                 (merlin-company--get-candidate-type candidate)
+                 "\n\n(** " doc " *)")))
+      (merlin-display-in-type-buffer doc)))
+
+   ((merlin-company--is-module candidate)
+    (merlin-display-in-type-buffer
+     (merlin-call "type-expression"
+                  "-position" (merlin-unmake-point (point))
+                  "-expression" (substring-no-properties candidate))))
+
+   (t (merlin-display-in-type-buffer
+       (merlin-company--get-candidate-type candidate))))
+  (get-buffer merlin-type-buffer-name))
+
+(defun merlin-company--meta (candidate)
+  "Computes the information to display in the minibuffer for CANDIDATE"
+  (let* ((arg-type (get-text-property 0 'merlin-arg-type candidate))
+         (entry-ty (merlin-company--get-candidate-type candidate))
+         (default  (if (and merlin-completion-arg-type arg-type)
+                     (concat "Expected argument type: " arg-type)
+                     entry-ty)))
+    (cond
+      ((merlin-company--has-doc candidate)
+       (concat default " (press F1 to display documentation of " candidate ")"))
+      ((merlin-company--is-module candidate)
+       (concat "Press F1 to display the signature of module " candidate
+               " (successive calls will expand aliases)"))
+      (t default))))
+
+;; Public functions
+;;;###autoload
+(defun merlin-company-backend (command &optional arg &rest ignored)
+  (interactive (list 'interactive))
+  (when merlin-mode
+    (cl-case command
+      (interactive (company-begin-backend 'merlin-company-backend))
+      (prefix
+       (let* ((bounds (merlin-completion-bounds))
+              (result (merlin-buffer-substring (car bounds) (cdr bounds))))
+         (when (and (boundp 'company-candidates-cache)
+                    (or (string-match-p "\\.$" result)
+                        (member '("" "") company-candidates-cache)))
+           ;; for some reason, company doesn't always clear its cache
+           (setq company-candidates-cache nil))
+         result))
+      (no-cache t)
+      (sorted t)
+      (init t)
+      (require-match 'never)
+      (doc-buffer (merlin-company--doc-buffer arg))
+      (location
+       (ignore-errors
+         (let ((data (merlin-call-locate arg)))
+           (when (listp data)
+             (let ((filename (merlin-lookup 'file data (buffer-file-name)))
+                   (linum (cdr (assoc 'line (assoc 'pos data)))))
+               (cons filename linum))))))
+      (candidates
+       (when (or merlin-company-everywhere (not (company-in-string-or-comment)))
+         (let ((prefix (merlin-completion-prefix arg)))
+           (cl-loop for x in (merlin-complete arg)
+                    collect
+                    (propertize (merlin-completion-entry-text prefix x)
+                                'merlin-compl-type
+                                (merlin-completion-entry-short-description x)
+                                'merlin-arg-type (cdr (assoc 'argument_type x))
+                                'merlin-compl-doc (cdr (assoc 'info x)))))))
+      (post-completion
+       (let ((minibuffer-message-timeout nil))
+         (minibuffer-message "%s : %s" arg (merlin-company--get-candidate-type arg))))
+      (meta (merlin-company--meta arg))
+      (annotation
+       (concat " : " (merlin-company--get-candidate-type arg))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Register into company-mode ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(add-to-list 'company-backends 'merlin-company-backend)
+
+(provide 'merlin-company)
+;;; merlin-company.el ends here
diff --git a/emacs/merlin-iedit.el b/emacs/merlin-iedit.el
new file mode 100644
index 0000000..aaafc7c
--- /dev/null
+++ b/emacs/merlin-iedit.el
@@ -0,0 +1,66 @@
+;;; merlin-iedit.el --- Merlin and iedit integration.   -*- coding: utf-8; lexical-binding: t -*-
+;; Licensed under the MIT license.
+
+;; Author: Simon Castellan <simon.castellan(_)iuwt.fr>
+;;         Frédéric Bour <frederic.bour(_)lakaban.net>
+;;         Thomas Refis <thomas.refis(_)gmail.com>
+;; Created: 27 June 2014
+;; Version: 0.1
+;; Keywords: ocaml languages
+;; Package-Requires: ((emacs "25.1") (merlin "3") (iedit "0.9"))
+;; URL: http://github.com/ocaml/merlin
+
+;;; Commentary:
+
+;; Provides the command `merlin-iedit-occurrences', which allows the
+;; user to edit all the occurrences of the identifier at point using
+;; `iedit'.
+
+;;; Code:
+
+(require 'merlin)
+(require 'cl-lib)
+(require 'iedit)
+
+(defun merlin-iedit--printable (&rest _args)
+  "Stub substituting `iedit-printable' during merlin-iedit-occurrences."
+  "merlin-iedit-occurrences")
+
+(defun merlin-iedit--make-occurrences-overlays (occurrences)
+  "Stub substituting `iedit-make-occurrences-overlays' during
+merlin-iedit-occurrences."
+  (setq iedit-aborting nil)
+  (setq iedit-occurrences-overlays nil)
+  (setq iedit-read-only-occurrences-overlays nil)
+  (save-excursion
+    (save-window-excursion
+      (dolist (pos occurrences)
+        (let* ((start (assoc 'start pos))
+               (end   (assoc 'end   pos))
+               (beginning (merlin-make-point start))
+               (ending    (merlin-make-point end)))
+          (if (text-property-not-all beginning ending 'read-only nil)
+              (push (iedit-make-read-only-occurrence-overlay beginning ending)
+                    iedit-read-only-occurrences-overlays)
+            (push (iedit-make-occurrence-overlay beginning ending)
+                  iedit-occurrences-overlays))))))
+  (length occurrences))
+
+;;;###autoload
+(defun merlin-iedit-occurrences ()
+  "Edit occurrences of identifier under cursor using `iedit'."
+  (interactive)
+  (if iedit-mode (iedit-mode -1)
+    (let ((r (merlin-call "occurrences"
+                          "-identifier-at" (merlin-unmake-point (point)))))
+      (when r
+        (if (listp r)
+            (cl-letf (((symbol-function 'iedit-printable) #'merlin-iedit--printable)
+                      ((symbol-function 'iedit-make-occurrences-overlays)
+                       (lambda (a _b _c)
+                         (merlin-iedit--make-occurrences-overlays a))))
+              (iedit-start r (point-min) (point-max)))
+          (message r))))))
+
+(provide 'merlin-iedit)
+;;; merlin.el ends here
diff --git a/emacs/merlin-imenu.el b/emacs/merlin-imenu.el
new file mode 100644
index 0000000..4e916af
--- /dev/null
+++ b/emacs/merlin-imenu.el
@@ -0,0 +1,117 @@
+;;; merlin-imenu.el --- Merlin and imenu integration.   -*- coding: utf-8; lexical-binding: t -*-
+;; Licensed under the MIT license.
+
+;; Author: tddsg (Ta Quang Trung)
+;; Version: 0.3
+;; Release log:
+;;   - v0.1: July 2016
+;;   - v0.2: 27 April 2017
+;;   - v0.3: 21 August 2019
+;; Keywords: ocaml, imenu, merlin
+;; URL:
+
+(require 'imenu)
+(require 'subr-x)
+(require 'merlin)
+
+;; lists of different outline items
+(defvar-local merlin-imenu--value-list nil)
+(defvar-local merlin-imenu--type-list nil)
+(defvar-local merlin-imenu--exception-list nil)
+(defvar-local merlin-imenu--module-list nil)
+(defvar-local merlin-imenu--signature-list nil)
+(defvar-local merlin-imenu--class-list nil)
+(defvar-local merlin-imenu--method-list nil)
+
+(defun merlin-imenu-compute-position (line col)
+  "Get location of the item."
+  (save-excursion
+    (condition-case nil
+        (progn
+          (goto-char (point-min))
+          (forward-line (- line 1))
+          (move-to-column col)
+          (point))
+      (error -1))))
+
+(defun merlin-imenu-create-entry (prefix name type kind line col)
+  (let* ((name (concat prefix name))
+         (type (cond ((not (string= kind "Value")) "null")
+                     ((not (string= type "null")) type)
+                     (t (let* ((types (merlin-call
+                                       "type-enclosing"
+                                       "-position" (format "%d:%d" line col)
+                                       "-expression" name)))
+                          (cdr (nth 3 (car types)))))))
+         (type (replace-regexp-in-string "\n" " " type))
+         (type (propertize type 'face 'font-lock-doc-face)))
+    (if (string= type "null") name (concat name " : " type))))
+
+(defun merlin-imenu-parse-outline (prefix outline)
+  (dolist (item outline)
+    (let* ((line (cdr (assoc 'line (assoc 'start item))))
+           (col (cdr (assoc 'col (assoc 'start item))))
+           (name (cdr (assoc 'name item)))
+           (kind (cdr (assoc 'kind item)))
+           (type (cdr (assoc 'type item)))
+           (sub-trees (cdr (assoc 'children item)))
+           (entry (merlin-imenu-create-entry prefix name type kind line col))
+           (position (merlin-imenu-compute-position line col))
+           (marker (cons entry (set-marker (make-marker) position))))
+      (cond ((string= kind "Value")
+             (setq merlin-imenu--value-list (cons marker merlin-imenu--value-list)))
+            ((string= kind "Type")
+             (setq merlin-imenu--type-list (cons marker merlin-imenu--type-list)))
+            ((string= kind "Module")
+             (setq merlin-imenu--module-list (cons marker merlin-imenu--module-list)))
+            ((string= kind "Signature")
+             (setq merlin-imenu--signature-list (cons marker merlin-imenu--signature-list)))
+            ((string= kind "Class")
+             (setq merlin-imenu--class-list (cons marker merlin-imenu--class-list)))
+            ((string= kind "Method")
+             (setq merlin-imenu--method-list (cons marker merlin-imenu--method-list)))
+            ((string= kind "Exn")
+             (setq merlin-imenu--exception-list (cons marker merlin-imenu--exception-list))))
+      (when sub-trees
+        (merlin-imenu-parse-outline (concat entry ".") sub-trees)))))
+
+(defun merlin-imenu-create-index ()
+  "Create data for imenu using the merlin outline feature."
+  ;; Reset local vars
+  (setq merlin-imenu--value-list nil
+        merlin-imenu--type-list nil
+        merlin-imenu--module-list nil
+        merlin-imenu--signature-list nil
+        merlin-imenu--class-list nil
+        merlin-imenu--method-list nil
+        merlin-imenu--exception-list nil)
+  ;; Read outline tree
+  (merlin-imenu-parse-outline "" (merlin-call "outline"))
+  (let ((index nil))
+    (when merlin-imenu--value-list
+      (push (cons "Value" merlin-imenu--value-list) index))
+    (when merlin-imenu--exception-list
+      (push (cons "Exception" merlin-imenu--exception-list) index))
+    (when merlin-imenu--type-list
+      (push (cons "Type" merlin-imenu--type-list) index))
+    (when merlin-imenu--module-list
+      (push (cons "Module" merlin-imenu--module-list) index))
+    (when merlin-imenu--signature-list
+      (push (cons "Signature" merlin-imenu--signature-list) index))
+    (when merlin-imenu--class-list
+      (push (cons "Class" merlin-imenu--class-list) index))
+    (when merlin-imenu--method-list
+      (push (cons "Method" merlin-imenu--method-list) index))
+    index))
+
+;;;###autoload
+(defun merlin-use-merlin-imenu ()
+  "Merlin: use the custom imenu feature from Merlin"
+  (interactive)
+  ;; change the index function and force a rescan of imenu-index
+  (setq imenu-create-index-function 'merlin-imenu-create-index)
+  (imenu--cleanup)
+  (setq imenu--index-alist nil))
+
+(provide 'merlin-imenu)
+;;; merlin-imenu.el ends here
diff --git a/emacs/merlin-xref.el b/emacs/merlin-xref.el
new file mode 100644
index 0000000..31f23f3
--- /dev/null
+++ b/emacs/merlin-xref.el
@@ -0,0 +1,38 @@
+;; -*- lexical-binding: t -*-
+(require 'cl-lib)
+(require 'xref)
+(require 'merlin)
+
+;;;###autoload
+(defun merlin-xref-backend ()
+  "Merlin backend for Xref."
+  'merlin-xref)
+
+(defun merlin-xref--line (loc)
+  (save-excursion
+    (goto-char loc)
+    (buffer-substring (line-beginning-position) (line-end-position))))
+
+(cl-defmethod xref-backend-references ((_backend (eql merlin-xref)) _symbol)
+  (mapcar
+   (lambda (loc)
+     (let ((pt (merlin-make-point (alist-get 'start loc))))
+       (xref-make (merlin-xref--line pt)
+                  (xref-make-buffer-location (current-buffer) pt))))
+   (merlin--occurrences)))
+
+(cl-defmethod xref-backend-definitions ((_backend (eql merlin-xref)) _symbol)
+  (let* ((loc (merlin-call-locate))
+         (file (alist-get 'file loc))
+         (pos (alist-get 'pos loc))
+         (line (alist-get 'line pos))
+         (col (alist-get 'col pos)))
+    (save-excursion
+      (find-file file)
+      (let ((desc (merlin-xref--line (merlin-make-point pos))))
+        (list (xref-make desc (xref-make-file-location file line col)))))))
+
+(cl-defmethod xref-backend-identifier-completion-table ((_backend (eql merlin-xref)))
+  nil)
+
+(provide 'merlin-xref)
diff --git a/emacs/merlin.el b/emacs/merlin.el
new file mode 100644
index 0000000..74dc9d8
--- /dev/null
+++ b/emacs/merlin.el
@@ -0,0 +1,2066 @@
+;;; merlin.el --- Mode for Merlin, an assistant for OCaml   -*- coding: utf-8; lexical-binding: t -*-
+
+;; Licensed under the MIT license.
+
+;; Author: Frédéric Bour <frederic.bour(_)lakaban.net>
+;; Created: 30 August 2016
+;; Version: 3.0
+;; Keywords: ocaml languages
+;; Package-Requires: ((emacs "25.1"))
+;; URL: https://github.com/ocaml/merlin
+
+;;; Commentary:
+;; merlin-mode is an Emacs interface to merlin.  It allows you to perform
+;; queries such as getting the type of an expression, completion, and so on.
+
+;; Installation:
+;; You need merlin installed on your system (ocamlmerlin binary) for merlin-mode
+;; to work.
+
+;;; Usage:
+;; TODO
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'crm) ;; for completing-read-multiple
+;; caml-types for highlighting
+;; (https://github.com/ocaml/merlin/issues/331)
+(require 'caml-types nil 'noerror)
+
+;; silence free variable warning
+(defvar merlin-mode)
+
+(defgroup merlin nil
+  "merlin binding mode allowing completion and typing in OCaml files."
+  :group 'languages :prefix "merlin-")
+
+;;
+;; Faces
+;;
+
+(defface merlin-type-face
+  '((t :inherit caml-types-expr-face))
+  "Face for highlighting a typed expr."
+  :group 'merlin)
+
+(defface merlin-compilation-warning-face
+  '((t :inherit compilation-warning))
+  "Face to use to highlight merlin warnings."
+  :group 'merlin)
+
+(defface merlin-compilation-error-face
+  '((t :inherit compilation-error))
+  "Face to use to highlight merlin errors."
+  :group 'merlin)
+
+;;
+;; Customizable vars
+;;
+
+(defcustom merlin-show-instance-in-lighter t
+  "Show the current instance of the buffer in the lighter."
+  :group 'merlin :type 'boolean)
+
+(defcustom merlin-report-errors-in-lighter nil
+  "Report absence of .merlin or errors in .merlin in the lighter."
+  :group 'merlin :type 'boolean)
+
+(defcustom merlin-client-log-function nil
+  "The function takes four arguments:
+   - the path to the merlin binary
+   - the name of the command
+   - the total time spent in the server (or -1 if that information
+     is not available)
+   - the resulting state (\"return\", \"failure\" or \"interrupted\")
+Its return value is ignored."
+  :group 'merlin :type 'symbol)
+
+(defcustom merlin-configuration-function nil
+  "The function takes no argument and returns the configuration for the current
+buffer, in a form suitable for `merlin-buffer-configuration'."
+  :group 'merlin :type 'symbol)
+
+(defcustom merlin-grouping-function nil
+  "Deprecated, see `merlin-configuration-function'."
+  :group 'merlin :type 'symbol)
+
+(defcustom merlin-command 'opam
+  "The path to merlin in your installation."
+  :group 'merlin :type '(choice (file :tag "Filename (default binary is \"ocamlmerlin\")")
+                                (function :tag "Function returning path to the binary")
+                                (const :tag "Use current opam switch" opam)))
+
+(defcustom merlin-completion-with-doc nil
+  "If non-nil, tries to retrieve ocamldoc comments associated with each
+completion candidate."
+  :group 'merlin :type 'boolean)
+
+(defcustom merlin-completion-dwim t
+  "If non-nil, fallback to fuzzier completion when normal completion gives
+no result."
+  :group 'merlin :type 'boolean)
+
+(defcustom merlin-completion-types t
+  "If non-nil, print the types of the variables during completion."
+  :group 'merlin :type 'boolean)
+
+(defcustom merlin-completion-arg-type t
+  "If non-nil, print the type of the expected argument during completion
+on an application."
+  :group 'merlin :type 'boolean)
+
+(defcustom merlin-debug nil
+  "If non-nil, log the data sent and received from merlin into
+`merlin-log-buffer-name' buffer."
+  :group 'merlin :type 'boolean)
+
+(defcustom merlin-report-warnings t
+  "If non-nil, report warnings, otherwise ignore them."
+  :group 'merlin :type 'boolean)
+
+(defcustom merlin-occurrences-buffer-name "*merlin-occurrences*"
+  "The name of the buffer listing occurrences of an identifier after
+a call to `merlin-occurrences'."
+  :group 'merlin :type 'string)
+
+(defcustom merlin-type-buffer-name "*merlin-types*"
+  "The name of the buffer storing module signatures."
+  :group 'merlin :type 'string)
+
+(defcustom merlin-error-buffer-name "*merlin-errors*"
+  "The name of the buffer storing module signatures."
+  :group 'merlin :type 'string)
+
+(defcustom merlin-log-buffer-name "*merlin-log*"
+  "The name of the buffer storing log messages and debug information.
+See `merlin-debug'."
+  :group 'merlin :type 'string)
+
+(defcustom merlin-favourite-caml-mode nil
+  "The OCaml mode to use for the *merlin-types* buffer."
+  :group 'merlin :type 'symbol)
+
+(defcustom merlin-error-after-save '("ml" "mli")
+  "Determines whether merlin should check for errors after saving.
+If t, always check for errors after saving.
+If nil, never check.
+If a string list, check only if the extension of the buffer-file-name
+ is in the list."
+  :group 'merlin :type '(choice (repeat string) boolean))
+
+(defcustom merlin-error-in-fringe (>= emacs-major-version 24)
+  "If non-nil, display errors in fringe"
+  :group 'merlin :type 'boolean)
+
+(defcustom merlin-error-on-single-line nil
+  "Only highlight first line of multi-line error messages"
+  :group 'merlin :type 'boolean)
+
+(defcustom merlin-error-check-then-move t
+  "If t, merlin-error-next and merlin-error-prev first update the errors
+then move the cursor.
+If nil, they both update and move at the same time."
+  :group 'merlin :type 'boolean)
+
+(defcustom merlin-default-flags nil
+  "The flags to pass to ocamlmerlin."
+  :group 'merlin :type '(repeat string))
+
+(defcustom merlin-occurrences-show-buffer 'other
+  "Determine how to display the occurrences list after a call to
+`merlin-occurrences'."
+  :group 'merlin :type '(choice (const :tag "Don't show list" never)
+                                (const :tag "Show in the current window" same)
+                                (const :tag "Show in another window" other)))
+
+(defcustom merlin-locate-in-new-window 'diff
+  "Determine whether to display results of `merlin-locate' in
+a new window or not."
+  :group 'merlin :type '(choice (const :tag "Always open a new window" always)
+                                (const :tag "Never open a new window" never)
+                                (const :tag "Open a new window only if the target file is different from current buffer." diff)))
+
+(defcustom merlin-locate-preference 'ml
+  "Determine whether locate should in priority look in ml or mli files."
+  :group 'merlin :type '(choice (const :tag "Look at implementation" ml)
+                                (const :tag "Look at interfaces" mli)))
+
+(defcustom merlin-locate-focus-new-window t
+  "If non-nil, when locate opens a new window it will give it the focus."
+  :group 'merlin :type 'boolean)
+
+(defcustom merlin-logfile nil
+  "If non-nil, use this file for the log file (should be an absolute path)."
+  :group 'merlin :type 'filename)
+
+(defcustom merlin-arrow-keys-type-enclosing t
+  "If non-nil, after a type enclosing, C-up and C-down are used
+to go up and down the AST. In addition, C-w copies the type to the
+kill ring and C-d destructures the expression."
+  :group 'merlin :type 'boolean)
+
+(defcustom merlin-type-after-locate nil
+  "If non-nil, use type-enclosing after locate."
+  :group 'merlin :type 'boolean)
+
+(defcustom merlin-allow-sit-for t
+  "When user attention is required, merlin will use `sit-for' only if
+`merlin-allow-sit-for' is `t'."
+  :group 'merlin :type 'boolean)
+
+(defalias 'merlin-find-file 'find-file-other-window
+  "The function called when merlin try to open a file (doesn't apply to
+merlin-locate, see `merlin-locate-in-new-window').")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Buffer local settings ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar-local merlin-buffer-configuration nil
+  "An association list describing the configuration of merlin binary for the
+current buffer.  Customize `merlin-configuration-function` to initialize it.
+The association list can contain the following optional keys:
+- `flags': extra flags to give merlin
+
+- `command': command to run
+
+- `env': list of strings (of the shape VARIABLE=FOO) (see
+`process-environment') that will be prepended to the environment of merlin
+
+- `dot-merlin': path to a .merlin file
+
+- `logfile': path to the logfile
+
+- `name': a short name for this configuration, displayed in user notifications.
+
+- `do-not-cache-config': if set, refreshes the config on every command")
+
+(defvar-local merlin-buffer-packages nil
+   "List of packages loaded in the buffer")
+
+(defvar-local merlin-buffer-packages-path nil
+   "List of path of packages loaded in the buffer")
+
+(defvar-local merlin-buffer-extensions nil
+   "List of syntax extensions active in the buffer")
+
+(defvar-local merlin-buffer-flags ""
+   "Additional flags to pass to merlin")
+
+;;;;;;;;;;;;;;;;;;;;;;;;
+;; Internal variables ;;
+;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar merlin-opam-bin-path nil)
+
+;; If user did not specify its merlin-favourite-caml-mode, try to guess it from
+;; the buffer being edited
+(defvar merlin-guessed-favorite-caml-mode nil)
+
+(defvar merlin--idle-timer nil)
+
+;; Errors related variables
+
+(defvar-local merlin-erroneous-buffer nil
+  "Whether the buffer is erroneous or not")
+
+(defvar merlin-highlight-overlay nil
+  "Merlin overlay used for highlights.")
+
+;; Type related variables
+
+(defvar-local merlin-enclosing-types nil
+  "List containing the enclosing type.")
+
+(defvar-local merlin-enclosing-offset nil
+  "Current offset in `merlin-enclosing-types'.")
+
+;; Locate
+
+(defvar merlin-position-stack nil)
+
+;; Verbosity
+
+(defconst merlin-verbosity-context nil
+  "If non-nil, a simple key used to determine verbosity")
+
+(defvar-local merlin--verbosity-cache nil
+  "Cache last command to determine verbosity level")
+
+(defvar-local merlin-debug-last-commands nil
+  "Last merlin commands (for debugging)")
+
+;; Misc
+
+(defvar-local merlin--project-cache nil
+  "Cache for merlin--project-get")
+
+(defvar-local merlin--dwimed nil
+  "Remember if we used dwim for the current completion or not")
+
+;;;;;;;;;;;
+;; UTILS ;;
+;;;;;;;;;;;
+
+(defun merlin--completion-map-with-space (&optional map)
+  "Return a map suitable for `minibuffer-local-completion-map'
+but not overriding SPC binding."
+  (unless map (setq map minibuffer-local-completion-map ))
+  (setq map (make-composed-keymap nil map))
+  (define-key map (kbd "SPC") nil)
+  map)
+
+(defun merlin-debug (message &rest args)
+  "Output S to `merlin-log-buffer-name' if `merlin-debug' is non-nil
+in the current buffer."
+  (when merlin-debug
+    (with-current-buffer (get-buffer-create merlin-log-buffer-name)
+      (goto-char (point-max))
+      (if args (insert (apply 'format message args))
+        (insert message)))))
+
+(defun merlin-enable-debug ()
+  "Start recording merlin debug information to `merlin-log-buffer-name'."
+  (interactive)
+  (setq merlin-debug t)
+  (message "merlin: logging to %S buffer" merlin-log-buffer-name))
+
+(defun merlin-disable-debug ()
+  "Stop recording debug information."
+  (interactive)
+  (setq merlin-debug nil))
+
+(defun merlin-debug-last-commands ()
+  "Display last commands executed and their result (if any)"
+  (interactive)
+  (let (buf)
+    (dolist (command merlin-debug-last-commands)
+      (push (concat "- result: " (or (cdr command) "failed")) buf)
+      (push (mapconcat 'identity
+                       (merlin--map-flatten-to-string "command: " (car command))
+                       " ") buf))
+    (message "Last commands executed, most recent at the end:\n%s"
+             (mapconcat 'identity buf "\n"))))
+
+(defun merlin-buffer-substring (start end)
+  "Return content of buffer between two points or empty string
+if points are not valid."
+  (if (< start end) (buffer-substring-no-properties start end) ""))
+
+(defsubst merlin-lookup (key list &optional default)
+  "Lookup KEY in LIST which is a list of pairs. If not found,
+return DEFAULT or the value associated to KEY."
+  (assoc-default key list nil default))
+
+(defun merlin--differs-from-current-file (path)
+  (not (string-equal path (buffer-file-name))))
+
+(defun merlin--rev-map-flatten (f xs &optional acc)
+  (while (consp xs)
+    (setq acc (if (listp (car xs))
+                  (merlin--rev-map-flatten f (car xs) acc)
+                (cons (funcall f (car xs)) acc)))
+    (setq xs (cdr xs)))
+  (when xs
+    (setq acc (cons xs acc)))
+  acc)
+
+(defun merlin--map-flatten (f &rest xs)
+  (nreverse (merlin--rev-map-flatten f xs)))
+
+(defun merlin--map-flatten-to-string (&rest xs)
+  (merlin--map-flatten
+    (lambda (x) (if (stringp x) x (prin1-to-string x))) xs))
+
+(defun merlin--goto-file-and-point (data)
+  "Go to the file and position indicated by DATA which is an assoc list
+containing fields file, line and col."
+  (let* ((file (assoc 'file data))
+         (open-window (cond ((equal merlin-locate-in-new-window 'never) nil)
+                            ((equal merlin-locate-in-new-window 'always))
+                            (file (merlin--differs-from-current-file (cdr file)))))
+         (filename (if file (cdr file) (buffer-file-name (buffer-base-buffer))))
+         (focus-window (or (not open-window) merlin-locate-focus-new-window))
+         (do-open (lambda ()
+                    (push-mark)
+                    (if open-window
+                      (find-file-other-window filename)
+                      (find-file filename))
+                    (merlin--goto-point (cdr (assoc 'pos data))))))
+    (if focus-window
+        (progn
+          (push (cons (buffer-name) (point)) merlin-position-stack)
+          (funcall do-open)
+          (message "Use %s to go back."
+                   (substitute-command-keys "\\[merlin-pop-stack]")))
+      (save-excursion (save-selected-window (funcall do-open))))))
+
+(defun merlin-add-display-properties (overlay bitmap string &optional face)
+  "Add the necessary properties to OVERLAY to display it nicely."
+  (let ((prop (if window-system
+                  `(left-fringe ,bitmap . ,(if face (list face) nil))
+                `((margin left-margin) ,string))))
+    (when face (overlay-put overlay 'face face))
+    (overlay-put overlay 'before-string
+                 (propertize " " 'display prop))))
+
+(defun merlin--highlight (bounds face)
+  "Create an overlay on BOUNDS (of the form (START . END)) and give it FACE."
+  (remove-overlays nil nil 'merlin-kind 'highlight)
+  (let ((overlay (make-overlay (car bounds) (cdr bounds))))
+    (overlay-put overlay 'face face)
+    (overlay-put overlay 'merlin-kind 'highlight)
+    (if merlin-allow-sit-for
+        (unwind-protect (sit-for 60) (delete-overlay overlay))
+      (run-with-idle-timer 0.5 nil
+        (lambda () (delete-overlay overlay))))))
+
+;; Position management
+
+(defun merlin--goto-point (data)
+  "Go to the point indicated by DATA which must be an assoc list with fields
+line and col. If narrowing is in effect, widen if DATA is outside the visible
+region."
+  (let ((target-pos (merlin--point-of-pos data)))
+    ;; If our target position is outside the narrowed region, we'll
+    ;; have to widen.
+    (when (or (< target-pos (point-min))
+              (> target-pos (point-max)))
+      (widen))
+    (goto-char target-pos)))
+
+(defun merlin--point-of-pos (data)
+  "Transform DATA (a remote merlin position) into a point.
+DATA must be an assoc list with fields line and col."
+  (let ((line-num (merlin-lookup 'line data 0))
+        (col-byte-offset (merlin-lookup 'col data 0)))
+    (save-excursion
+      (save-restriction
+        (widen)
+        (goto-char (point-min))
+        (forward-line (1- line-num))
+        ;; Find the target position, converting the byte position to a
+        ;; character offset.
+        (let* ((bol-offset (position-bytes (point)))
+               (col-offset (max 0 col-byte-offset))
+               (target-off (+ bol-offset col-offset)))
+          (byte-to-position target-off))))))
+
+(defun merlin-make-point (data)
+  "Transform DATA (a remote merlin position) into a point."
+  (merlin--point-of-pos data))
+
+(defun merlin-unmake-point (point)
+  "Destruct POINT to line / col."
+  (save-excursion
+   (save-restriction
+     (widen)
+     (goto-char point)
+     (format "%d:%d" (line-number-at-pos)
+             (- (position-bytes (point))
+                (position-bytes (line-beginning-position)))))))
+
+(define-obsolete-function-alias 'merlin/unmake-point 'merlin-unmake-point "2021-01-27")
+
+(defun merlin--make-bounds (data)
+  "From a remote merlin object DATA {\"start\": LOC1; \"end\": LOC2},
+return (LOC1 . LOC2)."
+  (cons
+   (merlin-make-point (cdr (assoc 'start data)))
+   (merlin-make-point (cdr (assoc 'end data)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;
+;; PROCESS MANAGEMENT ;;
+;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun merlin--call-process (path args)
+  "Some workarounds for piping buffer content to a process"
+  (merlin-debug "# calling binary: %S with arguments: %S.\n" path args)
+  (let ((ib  (current-buffer))
+        (tmp (when merlin-debug (make-temp-file "merlin")))
+        (wd  (expand-file-name default-directory))
+        result)
+    (with-temp-buffer
+      (let ((ob (current-buffer)))
+        (with-current-buffer ib
+          (save-restriction
+            (widen)
+            (let ((default-directory wd))
+              (apply 'call-process-region (point-min) (point-max) path nil
+                     (list ob tmp) nil args)))))
+      (setq result (buffer-string))
+      (merlin-debug "# stdout\n%s" result)
+      (when tmp
+        (with-demoted-errors "Error when trying to read merlin log: %S"
+          (with-current-buffer merlin-log-buffer-name
+            (goto-char (point-max))
+            (insert "# stderr\n")
+            (insert-file-contents tmp)
+            (delete-file tmp))))
+      result)))
+
+(defun merlin--call-merlin (command &rest args)
+  "Invoke merlin binary with the proper setup to execute the command passed as
+argument (lookup appropriate binary, setup logging, pass global settings)"
+  ;; Really start process
+  (let ((binary      (merlin-command))
+        ;; (flags       (merlin-lookup 'flags merlin-buffer-configuration))
+        (process-environment (cl-copy-list process-environment))
+        (dot-merlin  (merlin-lookup 'dot-merlin merlin-buffer-configuration))
+        ;; FIXME use logfile
+        ;; (logfile     (or (merlin-lookup 'logfile merlin-buffer-configuration)
+        ;;                  merlin-logfile))
+        (extensions  (merlin--map-flatten (lambda (x) (cons "-extension" x))
+                                          merlin-buffer-extensions))
+        (packages    (merlin--map-flatten (lambda (x) (cons "-I" x))
+                                          merlin-buffer-packages-path))
+        (filename    (buffer-file-name (buffer-base-buffer))))
+    ;; Update environment
+    (dolist (binding (merlin-lookup 'env merlin-buffer-configuration))
+      (let* ((equal-pos (string-match-p "=" binding))
+             (prefix (if equal-pos
+                       (substring binding 0 (1+ equal-pos))
+                       binding))
+             (is-prefix (lambda (x) (string-prefix-p prefix x))))
+        (setq process-environment (cl-delete-if is-prefix process-environment))
+        (when equal-pos
+          (setq process-environment (cons binding process-environment)))))
+    ;; Compute verbosity
+    (when (eq merlin-verbosity-context t)
+      (setq merlin-verbosity-context (cons command args)))
+    (if (not merlin-verbosity-context)
+        (setq merlin--verbosity-cache nil)
+      (if (equal merlin-verbosity-context (car-safe merlin--verbosity-cache))
+          (setcdr merlin--verbosity-cache (1+ (cdr merlin--verbosity-cache)))
+        (setq merlin--verbosity-cache (cons merlin-verbosity-context 0))))
+    ;; Compute full command line.
+    (setq args (merlin--map-flatten-to-string
+                "server" command "-protocol" "sexp"
+                (when dot-merlin
+                  (list "-dot-merlin" dot-merlin))
+                ;; Is debug mode enabled
+                (when merlin-debug '("-log-file" "-"))
+                ;; If command is repeated, increase verbosity
+                (when merlin-verbosity-context
+                  (list "-verbosity" (cdr merlin--verbosity-cache)))
+                packages
+                extensions
+                (unless (string-equal merlin-buffer-flags "")
+                  (cons "-flags" merlin-buffer-flags))
+                (when filename
+                  (cons "-filename" filename))
+                args))
+    ;; Log last commands
+    (setq merlin-debug-last-commands
+          (cons (cons (cons binary args) nil) merlin-debug-last-commands))
+    (let ((cdr (nthcdr 5 merlin-debug-last-commands)))
+      (when cdr (setcdr cdr nil)))
+    ;; Call merlin process
+    (setcdr (car merlin-debug-last-commands) (merlin--call-process binary args))))
+
+(defun merlin-client-logger (binary cmd timing result)
+  (when merlin-client-log-function
+    (funcall merlin-client-log-function binary cmd timing result)))
+
+(defun merlin-call (command &rest args)
+  "Execute a command and parse output: return an sexp on success or throw an error"
+  (let* ((binary (merlin-command))
+         (result (merlin--call-merlin command args)))
+    (condition-case err
+        (setq result (car (read-from-string result)))
+      (error
+        (merlin-client-logger binary command -1 "failure")
+        (error "merlin: error %s trying to parse answer: %s"
+               err result))
+      (quit
+        (merlin-client-logger binary command -1 "interrupted")))
+    (let* ((notifications (cdr-safe (assoc 'notifications result)))
+           (timing (cdr-safe (assoc 'timing result)))
+           (class (cdr-safe (assoc 'class result)))
+           (value (cdr-safe (assoc 'value result))))
+      (merlin-client-logger binary command timing class)
+      (dolist (notification notifications)
+        (message "(merlin) %s" notification))
+      (pcase class
+        ("return" value)
+        ("failure" (error "merlin-mode failure: %s" value))
+        ("error" (error "merlin: %s" value))
+        (_ (error "unknown answer: %S:%S" class value))))))
+
+(define-obsolete-function-alias 'merlin/call 'merlin-call "2021-01-27")
+
+(defun merlin-stop-server ()
+  "Shutdown merlin server."
+  (interactive)
+  (unless merlin-mode (message "Buffer is not managed by merlin."))
+  (when merlin-mode
+    (merlin--call-merlin "stop-server")
+    ;; These are buffer-local variables, so reset them in all buffers.
+    (dolist (buf (buffer-list))
+      (with-current-buffer buf
+        (kill-local-variable 'merlin-buffer-configuration)
+        (kill-local-variable 'merlin-erroneous-buffer)))))
+
+;;;;;;;;;;;;;;;;;;;;
+;; FILE SWITCHING ;;
+;;;;;;;;;;;;;;;;;;;;
+
+(defun merlin-switch-list-by-ext (&rest exts)
+  "List filenames ending by any of EXTS in the path."
+  (merlin-call "list-modules"
+               (merlin--map-flatten (lambda (x) (cons "-ext" x)) exts)))
+
+(defun merlin-switch-to (name &rest exts)
+  "Switch to NAME.EXTS."
+  (let ((file (merlin-call "path-of-source"
+               (merlin--map-flatten
+                 (lambda (ext) (cons "-file" (concat name ext))) exts))))
+    (when file (merlin-find-file file))))
+
+(defun merlin-switch-to-ml (name)
+  "Switch to the ML file corresponding to the module NAME
+(fallback to MLI if no ML is provided)."
+  (interactive (list (ido-completing-read "Module: "
+                                          (merlin-switch-list-by-ext '(".ml" ".mli")))))
+  (merlin-switch-to name '(".ml" ".mli")))
+
+(defun merlin-switch-to-mli (name)
+  "Switch to the MLI file corresponding to the module NAME
+(fallback to ML if no MLI is provided)."
+  (interactive (list (ido-completing-read "Module: "
+                                          (merlin-switch-list-by-ext '(".mli" ".ml")))))
+  (merlin-switch-to name '(".mli" ".ml")))
+
+;;;;;;;;;;;;;;;;;;
+;; ERROR BUFFER ;;
+;;;;;;;;;;;;;;;;;;
+
+(defvar merlin-error-buffer-map
+  (let ((map (make-sparse-keymap)))
+    (set-keymap-parent map special-mode-map)
+    (define-key map "g" nil)
+    map)
+  "Keymap for error buffer.")
+
+(defun merlin-display-in-error-buffer (text)
+  "Change content of error-buffer."
+  (let ((curr-dir default-directory))
+    (with-current-buffer (get-buffer-create merlin-error-buffer-name)
+      (read-only-mode 0)
+      (erase-buffer)
+      (insert text)
+      (goto-char (point-min))
+      (read-only-mode 1)
+      (use-local-map merlin-error-buffer-map)
+      ;; finally make sure that the error buffer directory is the same as the
+      ;; last (ml) buffer we were in.
+      ;; Indeed if people move to that buffer and start looking for a file we
+      ;; want them to be in the directory they were in when they last requested a
+      ;; type, not in the directory they were in when they first requested a
+      ;; type (for long lived emacs sessions that directory might not even exist
+      ;; anymore).
+      (setq default-directory curr-dir))))
+
+(defun merlin--error-display (err)
+  "Display the error ERR."
+  (if (not err)
+      (message "<no information>")
+    (merlin-display-in-error-buffer err)
+    (message "%s" err)))
+
+;;;;;;;;;;;;;;;;;;
+;; ERROR REPORT ;;
+;;;;;;;;;;;;;;;;;;
+
+(defvar-local merlin--last-edit nil
+  "Coordinates (start . end) of last edit or nil, to prevent error messages
+from flickering when cursor is around the edit.")
+
+(defun merlin--on-edit (start end _length)
+  "Memorize coordinates of last edition to avoid flickering error messages
+around the cursor"
+  (setq merlin--last-edit (cons start end)))
+
+(defun merlin--error-position-delta (point err)
+  "Distance between point and error."
+  (setq err (cdr (assoc 'bounds err)))
+  (cond ((< point (car err)) (cons (- (car err) point) 0))
+        ((> point (cdr err)) (cons (- point (cdr err)) 0))
+        (t (cons 0 (min (- (cdr err) point) (- point (car err)))))))
+
+(defun merlin--error-at-position (point errors)
+  "Returns error from ERRORS list most relevant at POINT"
+  (let ((err nil) (d nil))
+    (dolist (err- errors err)
+      (let ((d- (merlin--error-position-delta point err-)))
+        (when (or (not err) (< (car d-) (car d))
+                  (and (= (car d-) (car d)) (< (cdr d-) (cdr d))))
+          (setq d d-) (setq err err-))))))
+
+(defun merlin-show-error-on-current-line ()
+  "Show the error of the current line in the echo area.
+If there is no error, do nothing."
+  (when (and merlin-mode (not (current-message)))
+    (let* ((errors (overlays-in (line-beginning-position) (line-end-position)))
+           (err nil))
+      (when (or (not merlin--last-edit)
+                (not (or (= (point) (car merlin--last-edit))
+                         (= (point) (cdr merlin--last-edit)))))
+        (setq errors (remove nil (mapcar 'merlin--overlay-pending-error errors)))
+        (setq err (merlin--error-at-position (point) errors))
+        (when err (merlin--error-display (cdr (assoc 'message err))))))))
+
+(defun merlin--overlay-next-property-set (point prop &optional limit)
+  "Find next point where PROP is set.
+(Like `next-single-char-property-change' but ensure that prop is not-nil)."
+  (setq point (next-single-char-property-change point prop nil limit))
+  (unless (cl-find-if (lambda (a) (overlay-get a prop)) (overlays-at point))
+    (setq point (next-single-char-property-change point prop nil limit)))
+  point)
+
+(defun merlin--overlay-previous-property-set (point prop &optional limit)
+  "Find previous point where PROP is set.
+(Like `previous-single-char-property-change' but ensure that prop is not-nil)."
+  (setq point (previous-single-char-property-change point prop nil limit))
+  (unless (cl-find-if (lambda (a) (overlay-get a prop)) (overlays-at point))
+    (setq point (previous-single-char-property-change point prop nil limit)))
+  point)
+
+(defun merlin--has-error-group-overlay-at-point (point group)
+  (cl-some (lambda (err) (eq (overlay-get err 'merlin-error-group) group))
+           (overlays-at point)))
+
+(defun merlin--error-group-next (point group &optional limit)
+  (let ((point (merlin--overlay-next-property-set point 'merlin-pending-error limit)))
+    (when group
+      (while (not (or (eq point (point-max))
+                      (merlin--has-error-group-overlay-at-point point group)))
+        (setq point (merlin--overlay-next-property-set point 'merlin-pending-error limit))))
+    point))
+
+(defun merlin--error-group-prev (point group &optional limit)
+  (let ((point (merlin--overlay-previous-property-set point 'merlin-pending-error limit)))
+    (when group
+      (while (not (or (eq point (point-min))
+                      (merlin--has-error-group-overlay-at-point point group)))
+        (setq point (merlin--overlay-next-property-set point 'merlin-pending-error limit))))
+    point))
+
+(defun merlin--errors-at-position (point)
+  (remove nil (mapcar 'merlin--overlay-pending-error (overlays-at point))))
+
+(defun merlin--error-prev-cycle (group)
+  "Returns previous error, cycling when reaching beginning of buffer"
+  (let ((point (point)) (errors nil) (err nil))
+    (setq point (merlin--error-group-prev point group))
+    (unless (eq point (point)) (setq errors (merlin--errors-at-position point))
+    (unless errors
+      (setq point (merlin--error-group-prev (point-max) group (point)))
+      (setq errors (merlin--errors-at-position point)))
+    (setq err (merlin--error-at-position point errors))
+    (if err (cons point err) nil))))
+
+(defun merlin--error-next-cycle (group)
+  "Returns next error, cycling when reaching end of buffer"
+  (let ((point (point)) (errors nil) (err nil))
+    (setq point (merlin--error-group-next point group))
+    (when (eq point (point-max))
+      (setq point (point-min))
+      (setq errors (merlin--errors-at-position point))
+      (unless errors
+        (setq point (merlin--error-group-next (point-min) group (point)))))
+    (unless errors
+      (setq errors (merlin--errors-at-position point)))
+    (setq err (merlin--error-at-position point errors))
+    (if err (cons point err) nil)))
+
+(defun merlin--after-save ()
+  (when (and merlin-mode merlin-error-after-save) (merlin-error-check)))
+
+(defadvice basic-save-buffer (after merlin--after-save activate)
+  "The save hook is called only if buffer was modified, but user might want fresh errors anyway"
+  (merlin--after-save))
+
+(defun merlin-error-prev (&optional group)
+  "Jump back to previous error."
+  (interactive)
+  (let ((old-errors merlin-erroneous-buffer))
+    (merlin--error-check nil)
+    (let ((err (merlin--error-prev-cycle group)))
+      (unless (or err merlin-erroneous-buffer) (message "No errors"))
+      (when err
+        (if (and merlin-error-check-then-move
+                 (not (equal old-errors merlin-erroneous-buffer)))
+            (message "(%d pending errors, use %s to jump)"
+                     (length merlin-erroneous-buffer)
+                     (substitute-command-keys "\\[merlin-error-prev]"))
+          (goto-char (car err))
+          (message "%s" (cdr (assoc 'message (cdr err))))
+          (merlin--highlight (cdr (assoc 'bounds (cdr err))) 'next-error))))))
+
+(defun merlin-error-next (&optional group)
+  "Jump to next error."
+  (interactive)
+  (let ((old-errors merlin-erroneous-buffer))
+    (merlin--error-check nil)
+    (let ((err (merlin--error-next-cycle group)))
+      (unless (or err merlin-erroneous-buffer) (message "No errors"))
+      (when err
+        (if (and merlin-error-check-then-move
+                 (not (equal old-errors merlin-erroneous-buffer)))
+            (message "(%d pending errors, use %s to jump)"
+                     (length merlin-erroneous-buffer)
+                     (substitute-command-keys "\\[merlin-error-next]"))
+          (goto-char (car err))
+          (message "%s" (cdr (assoc 'message (cdr err))))
+          (merlin--highlight (cdr (assoc 'bounds (cdr err))) 'next-error))))))
+
+(defun merlin-error-next-in-group ()
+  "Jump to next error in same group, if any, next error otherwise."
+  (interactive)
+  (let ((err (merlin--error-at-position
+               (point) (merlin--errors-at-position (point)))))
+    (merlin-error-next (when err (overlay-get err 'merlin-error-group)))))
+
+(defun merlin-error-prev-in-group ()
+  "Jump to previous error in same group, if any, previous error otherwise."
+  (interactive)
+  (let ((err (merlin--error-at-position
+               (point) (merlin--errors-at-position (point)))))
+    (merlin-error-prev (when err (overlay-get err 'merlin-error-group)))))
+
+(defun merlin--error-warning-p (msg)
+  "Tell if the message MSG is a warning."
+  (string-match-p "^Warning" msg))
+
+(defun merlin-error-reset ()
+  "Clear error list."
+  (interactive)
+  (setq merlin-erroneous-buffer nil)
+  (remove-overlays nil nil 'merlin-kind 'error))
+
+(defun merlin--overlay-pending-error (overlay)
+  "Returns non-nil if OVERLAY is about a pending error."
+  (if overlay (overlay-get overlay 'merlin-pending-error) nil))
+
+(defun merlin--kill-error-if-edited (overlay is-after _beg _end &optional _length)
+  "Remove an error from the pending error lists if it is edited by the user."
+  (when is-after (delete-overlay overlay)))
+
+(defun merlin--transform-add-error-bounds (err)
+  (let ((bounds (merlin--make-bounds err))
+        (subs (cdr-safe (assoc 'sub err))))
+    (when merlin-error-on-single-line
+      (setq bounds (cons (car bounds)
+                         (min (cdr bounds)
+                              (save-excursion
+                                (goto-char (car bounds))
+                                (line-end-position))))))
+    (when (= (car bounds) (cdr bounds))
+      (setq bounds (if (> (car bounds) (point-min))
+                       (cons (1- (car bounds)) (cdr bounds))
+                     (cons (car bounds) (1+ (cdr bounds))))))
+    (setq bounds (cons (copy-marker (car bounds))
+                       (copy-marker (cdr bounds))))
+    (cl-acons 'sub (mapcar 'merlin--transform-add-error-bounds subs)
+              (cl-acons 'bounds bounds err))))
+
+(defun merlin-transform-display-errors (errors)
+  "Populate the error list with ERRORS, transformed into an emacs-friendly
+form. Do display of error list."
+  (setq errors (mapcar 'merlin--transform-add-error-bounds errors))
+  (dolist (main errors)
+    (let ((subs (cdr-safe (assoc 'sub main))))
+      (dolist (err (cons main subs))
+        (let* ((bounds (cdr (assoc 'bounds err)))
+               (overlay (make-overlay (car bounds) (cdr bounds))))
+        (overlay-put overlay 'merlin-kind 'error)
+        (overlay-put overlay 'merlin-pending-error err)
+        (overlay-put overlay 'merlin-error-group main)
+        (push #'merlin--kill-error-if-edited
+              (overlay-get overlay 'modification-hooks))
+        (when (and merlin-error-in-fringe
+                   (not (and (eq err main) subs)))
+          (if (merlin--error-warning-p (cdr (assoc 'message err)))
+              (merlin-add-display-properties overlay
+                                             'question-mark
+                                             "?"
+                                             'merlin-compilation-warning-face)
+            (merlin-add-display-properties overlay
+                                           'exclamation-mark
+                                           "!"
+                                           'merlin-compilation-error-face)))))))
+  errors)
+
+(defun merlin--error-check (view-errors-p)
+  "Check for errors.
+Return t if there were not any or nil if there were.  Moreover, it displays the
+errors in the fringe.  If VIEW-ERRORS-P is non-nil, display a count of them."
+  (merlin-error-reset)
+  (let* ((errors (merlin-call "errors"))
+         (no-loc (cl-remove-if (lambda (e) (assoc 'start e)) errors)))
+    (setq errors (cl-remove-if-not (lambda (e) (assoc 'start e)) errors))
+    (unless merlin-report-warnings
+      (setq errors (cl-remove-if (lambda (e)
+                                   (or
+                                    (eq (cdr-safe (assoc 'message e)) "warning")
+                                    (merlin--error-warning-p (cdr (assoc 'message e)))))
+                                 errors)))
+    (setq merlin-erroneous-buffer (or errors no-loc))
+    (dolist (e no-loc)
+      (message "%s" (cdr (assoc 'message e))))
+    (merlin-transform-display-errors errors)
+    (when view-errors-p
+      (let ((prefix (current-message)))
+        (setq prefix (if prefix (concat prefix " ") ""))
+        (if merlin-erroneous-buffer
+          (message "%s(%d pending errors, use %s to jump)"
+                   prefix
+                   (length errors)
+                   (substitute-command-keys "\\[merlin-error-next]"))
+          (message "%sNo errors" prefix))))))
+
+(defun merlin-error-after-save ()
+  "Determine whether the buffer should be checked for errors depending on
+the value of merlin-error-after-save setting."
+  (cond
+    ((equal merlin-error-after-save t) t)
+    ((equal merlin-error-after-save nil) nil)
+    ((and (listp merlin-error-after-save)
+          (buffer-file-name (buffer-base-buffer)))
+     (member (file-name-extension (buffer-file-name (buffer-base-buffer)))
+             merlin-error-after-save))))
+
+(defun merlin-toggle-view-errors ()
+  "Toggle the viewing of errors in the buffer."
+  (interactive)
+  (setq merlin-error-after-save (not (merlin-error-after-save)))
+  (if (merlin-error-after-save)
+      (progn
+        (merlin--after-save)
+        (message "Errors are now reported. Use %s to stop reporting them."
+                 (substitute-command-keys "\\[merlin-toggle-view-errors]")))
+    (progn
+      (merlin-error-reset)
+      (message "Errors are not reported anymore. Use %s to start again reporting them."
+               (substitute-command-keys "\\[merlin-toggle-view-errors]")))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;
+;; COMPLETION HELPERS ;;
+;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun merlin-completion-entry-short-description (entry)
+  "Return a short string describing the content a completion entry (e.g kind of
+identifier, type of a value, etc)."
+  (let* ((kind (cdr (assoc 'kind entry)))
+         (desc (or  (cdr (assoc 'desc entry)) (cdr (assoc 'type entry))))
+         (type (cond ((member kind '("Module" "module")) " <module>")
+                     ((string-equal kind "Type") (format " [%s]" desc))
+                     (t desc))))
+    (replace-regexp-in-string "[\n ]+" " " type)))
+
+(defun merlin-completion-entry-text (compl-prefix entry)
+  "Return the text that should replace COMPL-PREFIX in the buffer if the user
+chooses this completion entry.
+COMPL-PREFIX is the prefix that was used to start completion."
+  (let ((entry-name (cdr (assoc 'name entry))))
+    (if merlin--dwimed entry-name (concat compl-prefix entry-name))))
+
+(defun merlin-completion-prefix (ident)
+  "Compute the prefix of IDENT.  The prefix of `Foo.bar' is `Foo.' and the
+prefix of `bar' is `'."
+  (car (merlin-completion-split-ident ident)))
+
+(defun merlin-completion-split-ident (ident)
+  "Split IDENT into a (cons prefix suffix). See merlin-completion-prefix."
+  (let* ((l (split-string ident "\\."))
+         (s (mapconcat 'identity (butlast l) "."))
+         (suffix (if l (car (last l)) ident))
+         (prefix (if (string-equal s "") s (concat s "."))))
+    (cons prefix suffix)))
+
+(defun merlin--completion-prepare-labels (labels prefix)
+  ;; Remove non-matching entry, adjusting optional labels if needed
+  (cl-loop for x in labels
+           for name = (cdr (assoc 'name x))
+           when (or (string-prefix-p prefix name)
+                    (when (equal (aref name 0) ??)
+                      (aset name 0 ?~)
+                      (string-prefix-p prefix name)))
+           collect (append x '((kind . "Label") (info . nil)))))
+
+(defun merlin-complete (ident)
+  "Return the data for completion of IDENT, i.e. a list of tuples of the form
+  '(NAME TYPE KIND INFO)."
+  (setq-local merlin--dwimed nil)
+  (let* ((merlin-verbosity-context t) ; increase verbosity level if necessary
+         (ident- (merlin-completion-split-ident ident))
+         (suffix (cdr ident-))
+         (data   (merlin-call "complete-prefix"
+                              "-position" (merlin-unmake-point (point))
+                              "-prefix" ident
+                              "-doc" (if merlin-completion-with-doc "y" "n")))
+         ;; all classic entries
+         (entries (cdr (assoc 'entries data)))
+         ;; context is 'null or ('application ...)
+         (context (cdr (assoc 'context data)))
+         (application (and (listp context)
+                           (equal (car context) "application")
+                           (cadr context)))
+         ;; Argument-type
+         (expected-ty (and application
+                           (not (string-equal "'_a"
+                                  (cdr (assoc 'argument_type application))))
+                           (cdr (assoc 'argument_type application))))
+         ;; labels
+         (labels (and application (cdr (assoc 'labels application)))))
+    (setq labels (merlin--completion-prepare-labels labels suffix))
+    ;; DWIM completion
+    (when (and merlin-completion-dwim (not labels) (not entries))
+      (setq data (merlin-call "expand-prefix"
+                              "-position" (merlin-unmake-point (point))
+                              "-prefix" ident))
+      (setq entries (cdr (assoc 'entries data)))
+      (setq-local merlin--dwimed t))
+    ;; Concat results
+    (let ((result (append labels entries)))
+      (if expected-ty
+          (cl-loop for x in result
+                   collect (append x `((argument_type . ,expected-ty))))
+        result))))
+
+;; FIXME: merlin shouldn't rely on editor to compute bounds
+(defun merlin-bounds-of-ocaml-atom-at-point ()
+  "Return the start and end points of an ocaml atom near point.
+An ocaml atom is any string containing [a-z_0-9A-Z`.]."
+  (save-excursion
+    (skip-chars-backward "a-z0-9A-Z_'.")
+    (skip-chars-backward "~?`" (1- (point)))
+    (save-match-data
+      (if (or (looking-at "[~?`]?['a-z_0-9A-Z.]*['a-z_A-Z0-9]")
+              (looking-at "[~?`]"))
+          (cons (point) (match-end 0)) ; returns the bounds
+        nil)))) ; no atom at point
+
+(put 'ocaml-atom 'bounds-of-thing-at-point
+     'merlin-bounds-of-ocaml-atom-at-point)
+
+(defun merlin-completion-bounds ()
+  "Returns a pair (start . end) of the content to complete"
+  (let ((bounds (bounds-of-thing-at-point 'ocaml-atom)))
+    (cons (if bounds (car bounds) (point))
+          (point))))
+
+;;;;;;;;;;;;;;;;;;;;;
+;; POLARITY SEARCH ;;
+;;;;;;;;;;;;;;;;;;;;;
+
+(defun merlin--search (query)
+  (merlin-call "search-by-polarity"
+               "-query" query
+               "-position" (merlin-unmake-point (point))))
+
+(defun merlin-search (query)
+  (interactive "sSearch pattern: ")
+  (let* ((result (merlin--search query))
+         (entries (cdr (assoc 'entries result)))
+         (transform
+          (lambda (entry)
+            (let ((text (merlin-completion-entry-text "" entry))
+                  (desc (merlin-completion-entry-short-description entry)))
+              (vector (concat text " : " desc)
+                      `(lambda () (insert ,text)))))))
+    (popup-menu (easy-menu-create-menu "Results" (mapcar transform entries)))))
+
+;;;;;;;;;;;;;;;;;
+;; TYPE BUFFER ;;
+;;;;;;;;;;;;;;;;;
+
+(defun merlin--is-short (text)
+  (let ((count 0)
+        (pos   0))
+    (save-match-data
+      (while (and (<= count 8)
+                  (string-match "\n" text pos))
+        (setq pos (match-end 0))
+        (setq count (1+ count))))
+    (<= count 8)))
+
+(defvar merlin-types-buffer-map
+  (let ((map (make-sparse-keymap)))
+    (set-keymap-parent map special-mode-map)
+    (define-key map "g" nil)
+    map)
+  "Keymap for types buffer.")
+
+(defun merlin-display-in-type-buffer (text)
+  "Change content of type-buffer."
+  (let ((curr-dir default-directory))
+    (with-current-buffer (get-buffer-create merlin-type-buffer-name)
+      (when (member major-mode '(nil fundamental-mode))
+        ;; Guess value for merlin-favourite-caml-mode
+        (let ((caml-mode (or merlin-favourite-caml-mode
+                             merlin-guessed-favorite-caml-mode)))
+          (when caml-mode
+            (with-demoted-errors "Error when setting up merlin type-buffer: %S"
+              (funcall caml-mode)))))
+      (read-only-mode 0)
+      (erase-buffer)
+      (insert text)
+      (goto-char (point-min))
+      (read-only-mode 1)
+      (use-local-map merlin-types-buffer-map)
+      ;; finally make sure that the type buffer directory is the same as the last
+      ;; (ml) buffer we were in.
+      ;; Indeed if people move to that buffer and start looking for a file we
+      ;; want them to be in the directory they were in when they last requested a
+      ;; type, not in the directory they were in when they first requested a
+      ;; type (for long lived emacs sessions that directory might not even exist
+      ;; anymore).
+      (setq default-directory curr-dir))))
+
+(define-obsolete-function-alias 'merlin/display-in-type-buffer 'merlin-display-in-type-buffer "2021-01-27")
+
+
+;;;;;;;;;;;;;;;;;;;;;;;
+;; EXPRESSION TYPING ;;
+;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun merlin--type-expression (exp callback-if-success &optional _callback-if-exn)
+  "Get the type of EXP inside the local context."
+  (when exp
+    (funcall callback-if-success
+             (merlin-call "type-expression"
+                          "-position" (merlin-unmake-point (point))
+                          "-expression" exp))
+    ;; FIXME: callback-if-exn
+    ))
+
+(defun merlin--type-display (bounds type &optional quiet)
+  "Display the type TYPE of the expression occurring at BOUNDS.
+If QUIET is non nil, then an overlay and the merlin types can be used."
+  (if (not type)
+      (unless quiet (message "<no information>"))
+    (merlin-display-in-type-buffer type)
+    (if (merlin--is-short type)
+        (message "%s"
+                 (with-current-buffer merlin-type-buffer-name
+                   (font-lock-fontify-region (point-min) (point-max))
+                   (buffer-string)))
+      (display-buffer merlin-type-buffer-name))
+    (if (and (not quiet) bounds)
+        (merlin--highlight bounds 'merlin-type-face))))
+
+(defun merlin--type-region ()
+  "Show the type of the region."
+  (let*
+      ((substring  (merlin-buffer-substring (region-beginning) (region-end)))
+       (on-success (lambda (type) (merlin--type-display nil type nil)))
+       (on-error   (lambda (err)
+                     (let ((msg (assoc 'message err))
+                           (typ (assoc 'type err)))
+                       (cond ((and typ (equal (cdr typ) "parser"))
+                              (message "Error: the content of the region failed to parse."))
+                             (msg (message "Error: %s" (cdr msg)))
+                             (t
+                              (message "Unexpected error")))))))
+    (merlin--type-expression substring on-success on-error)))
+
+(defun merlin-type-expr (exp)
+  "Prompt the user for expression EXP, then show its type."
+  (interactive "s# ")
+  (let ((on-success (lambda (type) (merlin--type-display nil type nil)))
+        (on-error   (lambda (err)
+                      (let ((msg (assoc 'message err)))
+                        (if msg (message "Error: %s" (cdr msg))
+                          (message "unknown error"))))))
+    (merlin--type-expression exp on-success on-error)))
+
+(defvar merlin-type-enclosing-map
+  (let ((keymap (make-sparse-keymap)))
+    (define-key keymap (kbd "C-<up>") #'merlin-type-enclosing-go-up)
+    (define-key keymap (kbd "C-<down>") #'merlin-type-enclosing-go-down)
+    (define-key keymap (kbd "C-d") #'merlin-destruct-enclosing)
+    (define-key keymap (kbd "C-w") #'merlin-copy-enclosing)
+    keymap)
+  "The local map to navigate type enclosing.")
+
+(defun merlin--type-enclosing-reset ()
+  "Clear enclosing information, necessary for destruct"
+  (setq merlin-enclosing-types nil)
+  (setq merlin-enclosing-offset -1))
+
+(defun merlin--type-enclosing-reset-hooked ()
+  "Reimplement on-exit logic from set-temporary-overlay-map for emacs pre 24.4"
+  (let ((map merlin-type-enclosing-map))
+    (unless (or (not (eq map (cadr overriding-terminal-local-map)))
+                (eq this-command (lookup-key map (this-command-keys-vector))))
+      (merlin--type-enclosing-reset)
+      (remove-hook 'pre-command-hook #'merlin--type-enclosing-reset-hooked))))
+
+(defun merlin--type-enclosing-text (item)
+  (if (stringp (car item))
+      (car item)
+    (with-demoted-errors "Error retrieving type enclosing: %S"
+      (let* ((key (car item))
+             (index     (elt key 0))
+             (position  (elt key 1))
+             (tail      (elt key 2))
+             (verbosity (elt key 3))
+             (types (merlin-call
+                      "type-enclosing" "-position" position "-index" index
+                      (when verbosity (cons "-verbosity" verbosity))))
+             (obj (elt types index))
+             (type (cdr (assoc 'type obj))))
+        (setcar item (concat type tail)))
+      (car item))))
+
+(defun merlin--type-enclosing-query ()
+  "Get the enclosings around point from merlin and sets MERLIN-ENCLOSING-TYPES."
+  (merlin--type-enclosing-reset)
+  (let* ((merlin-verbosity-context t) ; increase verbosity level if necessary
+         (position (merlin-unmake-point (point)))
+         (verbosity (cdr-safe merlin--verbosity-cache))
+         (types (merlin-call "type-enclosing" "-position" position "-index" 0))
+         (types (ignore-errors
+                  (mapcar (lambda (obj)
+                            (let* ((tail (cdr (assoc 'tail obj)))
+                                   (tail (cond ((equal tail "position")
+                                                " (* tail position *)")
+                                               ((equal tail "call")
+                                                " (* tail call *)")
+                                               (t "")))
+                                   (type (cdr (assoc 'type obj))))
+                              (cons (if (stringp type) (concat type tail)
+                                      (list type position tail verbosity))
+                                    (merlin--make-bounds obj))))
+                          types)))
+         (types (delq nil types)))
+    (when types
+      (setq merlin-enclosing-types types)
+      (setq merlin-enclosing-offset -1)
+      merlin-enclosing-types)))
+
+(defun merlin--type-enclosing-go ()
+  "Highlight the given corresponding enclosing data (of the form (TYPE . BOUNDS)."
+  (let ((data (elt merlin-enclosing-types merlin-enclosing-offset)))
+    (if (cddr data)
+        (merlin--type-display (cdr data) (merlin--type-enclosing-text data)))))
+
+(defun merlin-type-enclosing-go-up ()
+  "Go up in the enclosing type list."
+  (interactive)
+  (when merlin-enclosing-types
+    (if (>= merlin-enclosing-offset (1- (length merlin-enclosing-types)))
+        (setq merlin-enclosing-offset -1))
+    (setq merlin-enclosing-offset (1+ merlin-enclosing-offset))
+    (merlin--type-enclosing-go)))
+
+(defun merlin-type-enclosing-go-down ()
+  "Go down in the enclosing type list."
+  (interactive)
+  (when merlin-enclosing-types
+    (if (<= merlin-enclosing-offset 0)
+        (setq merlin-enclosing-offset (length merlin-enclosing-types)))
+    (setq merlin-enclosing-offset (1- merlin-enclosing-offset))
+    (merlin--type-enclosing-go)))
+
+(defun merlin-copy-enclosing ()
+  (interactive)
+  (let ((data (elt merlin-enclosing-types merlin-enclosing-offset)))
+    (when (cddr data)
+      (setq data (merlin--type-enclosing-text data))
+      (message "Copied %s to kill-ring" data)
+      (kill-new data))))
+
+(defun merlin--type-enclosing-after ()
+  (when (and (fboundp 'set-temporary-overlay-map)
+             merlin-arrow-keys-type-enclosing)
+    (if (version< emacs-version "24.4")
+        (progn
+          (set-temporary-overlay-map merlin-type-enclosing-map t)
+          (add-hook 'pre-command-hook #'merlin--type-enclosing-reset-hooked))
+      (set-temporary-overlay-map merlin-type-enclosing-map t
+                                 'merlin--type-enclosing-reset))))
+
+(defun merlin-type-enclosing ()
+  "Print the type of the expression under point (or of the region, if it exists).
+If called repeatedly, increase the verbosity of the type shown."
+  (interactive)
+  (if (region-active-p)
+      (merlin--type-region)
+    (when (merlin--type-enclosing-query)
+      (merlin-type-enclosing-go-up)
+      (merlin--type-enclosing-after))))
+
+(defun merlin--find-extents (list low high)
+  "Return the smallest extent in LIST that LOW and HIGH fit
+strictly within, or nil if there is no such element."
+  (cl-find-if (lambda (extent)
+                (let ((start (merlin--point-of-pos (assoc 'start extent)))
+                      (end (merlin--point-of-pos (assoc 'end extent))))
+                  (or (and (> low start)
+                           (<= high end))
+                      (and (< high end)
+                           (>= low start)))))
+              list))
+
+(defun merlin-enclosing-expand ()
+  "Select the construct enclosing point (or the region, if it is active)."
+  (interactive)
+  (let* ((enclosing-extents
+           (merlin-call "enclosing"
+                        "-position" (merlin-unmake-point (point))))
+         (extents (if (use-region-p)
+                      (merlin--find-extents enclosing-extents
+                                            (region-beginning)
+                                            (region-end))
+                    (cl-first enclosing-extents))))
+    (if (not extents)
+              (error "No enclosing construct")
+      (merlin--goto-point (cdr (assoc 'start extents)))
+      (push-mark (merlin--point-of-pos (cdr (assoc 'end extents)))
+                 t t))))
+
+;;;;;;;;;;;
+;; HOLES ;;
+;;;;;;;;;;;
+
+(defun merlin--holes ()
+  "Query the list of holes (and their types)"
+  (merlin-call "holes"))
+
+(defun merlin--first-hole-aux (holes current-point comp)
+  "Returns the first `hole` of the list such that
+    `(funcall comp hole current-point)`"
+  (when holes
+    (let* ((head (car holes))
+           (tail (cdr holes))
+           (start (merlin-lookup 'start head))
+           (hole-point (merlin-make-point start)))
+      (if (funcall comp hole-point current-point)
+        head
+        (merlin--first-hole-aux tail current-point comp)))))
+
+(defun merlin--first-hole (holes current-point comp)
+  "Returns the first `hole` of the list that such that
+    `(funcall comp hole current-point)`. If no hole match
+    that condition the first one of the list is returned."
+  (let ((hole (merlin--first-hole-aux holes current-point comp)))
+    (if hole hole (car holes))))
+
+(defun merlin-previous-hole ()
+  "Jump to the previous hole and print its type"
+  (interactive)
+  (let* ((current-point (point))
+         (holes (reverse (merlin--holes)))
+         (hole (merlin--first-hole holes current-point '<)))
+    (when hole
+      (progn
+        (merlin--goto-point (merlin-lookup 'start hole))
+        (message "%s" (merlin-lookup 'type hole))))))
+
+(defun merlin--next-hole-between (pmin pmax)
+  "Jump to the next hole and print its type only if it is in the given range"
+  (let* ((current-point (point))
+         (hole (merlin--first-hole (merlin--holes) current-point '>)))
+    (when hole
+      (let* ((start (merlin-lookup 'start hole))
+             (typ (merlin-lookup 'type hole))
+             (hole-point (merlin-make-point start)))
+        (if (and
+              (>= hole-point pmin)
+              (<= hole-point pmax))
+          (progn
+            (merlin--goto-point start)
+            (message "%s" typ)))))))
+
+(defun merlin--first-hole-between (pmin pmax)
+  "Jump to the first hole in the given range and prints its type"
+  (let* ((hole (merlin--first-hole (merlin--holes) pmin '>)))
+    (when hole
+      (let* ((start (merlin-lookup 'start hole))
+             (typ (merlin-lookup 'type hole))
+             (hole-point (merlin-make-point start)))
+        (if (<= hole-point pmax)
+          (progn
+            (merlin--goto-point start)
+            (message "%s" typ)))))))
+
+(defun merlin-next-hole ()
+  "Jump to the next hole and print its type"
+  (interactive)
+  (let* ((current-point (point))
+         (hole (merlin--first-hole (merlin--holes) current-point '>)))
+    (when hole
+      (progn
+        (merlin--goto-point (merlin-lookup 'start hole))
+        (message "%s" (merlin-lookup 'type hole))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; DESTRUCT / CASE ANALYSIS ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun merlin--replace-buff-portion (start stop txt)
+  (let ((start (merlin--point-of-pos start))
+        (stop  (merlin--point-of-pos stop)))
+    (progn
+      (save-excursion
+        (delete-region start stop)
+        (goto-char start)
+        (insert txt)
+        (indent-region start (point)))
+      (merlin--next-hole-between start (+ start (length txt))))))
+
+(defun merlin--destruct-bounds (bounds)
+  "Execute a case analysis on BOUNDS"
+  (let ((result (merlin-call "case-analysis"
+                            "-start" (merlin-unmake-point (car bounds))
+                            "-end" (merlin-unmake-point (cdr bounds)))))
+    (when result
+      (let* ((loc   (car result))
+             (start (cdr (assoc 'start loc)))
+             (stop  (cdr (assoc 'end loc))))
+        (merlin--replace-buff-portion start stop (cadr result))))
+    (merlin--type-enclosing-reset)))
+
+(defun merlin-destruct-enclosing ()
+  "Case analyse the current type enclosing"
+  (interactive)
+  (merlin--destruct-bounds
+    (cdr (elt merlin-enclosing-types merlin-enclosing-offset))))
+
+(defun merlin-destruct ()
+  "Case analyse the current point or region"
+  (interactive)
+  (merlin--destruct-bounds (if (region-active-p)
+                             (cons (region-beginning) (region-end))
+                             (cons (point) (point)))))
+
+;;;;;;;;;;;;;;;
+;; CONSTRUCT ;;
+;;;;;;;;;;;;;;;
+
+
+(defun merlin--construct-complete (start stop results)
+  (let ((start (merlin--point-of-pos start))
+        (stop  (merlin--point-of-pos stop)))
+    (cl-labels ((insert-choice (_b _e newtext)
+          (completion--replace start stop newtext)
+          (merlin--first-hole-between start (+ start (length newtext)))))
+      (if (= (length results) 1)
+        (insert-choice 0 0 (car results))
+        (with-output-to-temp-buffer "*Constructions*"
+          (progn
+            (with-current-buffer "*Constructions*"
+              (setq-local
+                completion-list-insert-choice-function
+                #'insert-choice))
+            (display-completion-list results)))))))
+
+(defun merlin--construct-point (point)
+  "Execute a construct on POINT"
+  (progn
+    (ignore point) ; Without this Emacs bytecode compiler complains about an
+                   ; unused variable. This may be a bug in the compiler
+    (let ((result (merlin-call "construct"
+                              "-position" (merlin-unmake-point (point)))))
+      (when result
+        (let* ((loc   (car result))
+              (start (cdr (assoc 'start loc)))
+              (stop  (cdr (assoc 'end loc))))
+          (merlin--construct-complete start stop (cadr result)))))))
+
+(defun merlin-construct ()
+  "Construct over the current hole"
+  (interactive)
+  (merlin--construct-point (cons (point) (point))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; PACKAGE, PROJECT AND FLAGS MANAGEMENT ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun merlin-get-packages ()
+  "Get the list of available findlib package."
+  (let* ((packages-string (shell-command-to-string "ocamlfind list"))
+        (packages-list (split-string packages-string "\n")))
+    (mapcar 'car (mapcar 'split-string packages-list))))
+
+(defun merlin--project-get ()
+  "Returns a pair of two string lists (dot_merlins . failures) with a list of
+.merlins file loaded and a list of error messages, if any error occurred during
+loading"
+  (let ((ret (merlin-call "check-configuration")))
+    (setq merlin--project-cache
+          (cons (cdr (assoc 'dot_merlins ret))
+                (cdr (assoc 'failures ret))))))
+
+(defun merlin-use (&rest pkgs)
+  "Load PKGS in merlin."
+  (interactive
+   (list (let ((crm-separator "[ 	]*[, 	][ 	]*")
+               (crm-local-completion-map
+                (merlin--completion-map-with-space crm-local-completion-map)))
+           (completing-read-multiple
+            "Packages to use: " (merlin-get-packages) nil nil
+            (mapconcat 'identity merlin-buffer-packages " ")))))
+  (setq merlin-buffer-packages
+        (delete-dups (merlin--map-flatten 'identity pkgs)))
+  (let* ((arguments (cons "ocamlfind query" merlin-buffer-packages))
+        (command (mapconcat 'identity arguments " "))
+        (paths (shell-command-to-string command)))
+    (setq merlin-buffer-packages-path (split-string paths "\n")))
+  (merlin-error-reset)
+  (merlin-configuration-check t))
+
+(defun merlin-extensions (&rest extensions)
+  "Enable EXTENSIONS in merlin."
+  (interactive
+   (list (completing-read-multiple
+          "Enabled extensions (separate with ','): "
+          (merlin-call "extension-list") nil nil
+          (mapconcat 'identity merlin-buffer-extensions ","))))
+  (setq merlin-buffer-extensions
+        (delete-dups (merlin--map-flatten 'identity extensions)))
+  (merlin-error-reset)
+  (merlin-configuration-check t))
+
+(defun merlin-goto-project-file ()
+  "Goto the merlin file corresponding to the current file."
+  (interactive)
+  (let ((dot_merlins (car (merlin--project-get))))
+    (if (consp dot_merlins)
+        (merlin-find-file (car dot_merlins))
+      (message "No project file for the current buffer."))))
+
+(defun merlin-flags (&rest flags)
+  "Set user flags for current buffer."
+  (interactive (list
+                (let ((crm-separator " ")
+                      (crm-local-completion-map
+                       (merlin--completion-map-with-space crm-local-completion-map)))
+                  (completing-read-multiple
+                   "Flags: " (merlin-call "flags-list") nil nil
+                   merlin-buffer-flags))))
+  (setq merlin-buffer-flags
+        (mapconcat 'identity (merlin--map-flatten 'identity flags) " "))
+  (merlin-error-reset)
+  (merlin-configuration-check t))
+
+;;;;;;;;;;;;
+;; LOCATE ;;
+;;;;;;;;;;;;
+
+(defun merlin-call-locate (&optional ident)
+  "Locate the identifier IDENT at point."
+  (let ((result (merlin-call "locate"
+                             (when ident (list "-prefix" ident))
+                             "-position" (merlin-unmake-point (point))
+                             "-look-for" merlin-locate-preference)))
+    (unless result
+      (error "Not found. (Check *Messages* for potential errors)"))
+    (unless (listp result)
+      (user-error "%s" result))
+    result))
+
+(defun merlin--locate-result (result)
+  "Default actions after getting results from locate"
+  (merlin--goto-file-and-point result)
+  (when merlin-type-after-locate (merlin-type-enclosing)))
+
+(defun merlin-locate-ident (ident)
+  "Locate the inputted identifier"
+  (interactive "s> ")
+  (merlin--locate-result (merlin-call-locate ident)))
+
+(defun merlin-locate (&optional in-new-window)
+  "Locate the identifier at point.
+
+Whether the result appears in a new window is controlled by
+`merlin-locate-in-new-window', but can be overridden with a
+prefix argument (IN-NEW-WINDOW): if prefixed once with
+\\[universal-argument], the result appears in the current window;
+if prefixed twice with \\[universal-argument], the result appears
+in a new window; otherwise, `merlin-locate-in-new-window' is
+obeyed."
+  (interactive "P")
+  (cl-letf ((merlin-locate-in-new-window
+    (cond
+     ((equal in-new-window '(4)) 'never)
+     ((equal in-new-window '(16)) 'always)
+     (t merlin-locate-in-new-window))))
+    (merlin--locate-result (merlin-call-locate))))
+
+(defun merlin-locate-type ()
+  "Locate the type of the expression under point."
+  (interactive)
+  (let ((result (merlin-call "locate-type"
+                             "-position" (merlin-unmake-point (point)))))
+    (unless result
+      (error "Not found. (Check *Messages* for potential errors)"))
+    (unless (listp result)
+      (user-error "%s" result))
+    (merlin--goto-file-and-point result)))
+
+(defun merlin-pop-stack ()
+  "Go back to the last position where the user did a locate."
+  (interactive)
+  (let ((r (pop merlin-position-stack)))
+    (cond ((not r) (message "empty stack"))
+          ((equal merlin-locate-in-new-window 'never)
+           (switch-to-buffer (car r)))
+          ((or (equal merlin-locate-in-new-window 'always)
+               (not (equal (buffer-name) (car r))))
+           (select-window (display-buffer (car r)))))
+    (when r (goto-char (cdr r)))))
+
+;;;;;;;;;;
+;; JUMP ;;
+;;;;;;;;;;
+
+(defun merlin-call-jump (&optional target)
+  "Jump to the TARGET"
+  (if (or (not target) (equal target ""))
+      (setq target "fun let module match"))
+  (let ((result (merlin-call "jump"
+                             "-position" (merlin-unmake-point (point))
+                             "-target" target)))
+    (unless result
+      (error "Not found. (Check *Messages* for potential errors)"))
+    (unless (listp result)
+      (user-error "%s" result))
+    result))
+
+(defun merlin-jump (&optional target)
+  "Jump to enclosing fun, let, module or match.
+
+Any combination of the above may be entered, separated by spaces, ex.:
+
+fun let or module or module fun match
+
+Empty string defaults to jumping to all these."
+  (interactive "sfun, let, module or match > ")
+  (merlin--goto-file-and-point (merlin-call-jump target)))
+
+(defun merlin-call-phrase (target)
+  "Move to next phrase (TARGET = 'next) or previous phrase (TARGET = 'prev)"
+  (if (or (not target) (equal target ""))
+      (setq target "fun let module match"))
+  (let ((result (merlin-call "phrase"
+                             "-position" (merlin-unmake-point (point))
+                             "-target" target)))
+    (unless result
+      (error "Not found. (Check *Messages* for potential errors)"))
+    (unless (listp result)
+      (error result))
+    result))
+
+(defun merlin-phrase-next ()
+  "Go to the beginning of the next phrase."
+  (interactive)
+  (merlin--goto-file-and-point (merlin-call-phrase 'next)))
+
+(defun merlin-phrase-prev ()
+  "Go to the beginning of the previous phrase."
+  (interactive)
+  (merlin--goto-file-and-point (merlin-call-phrase 'prev)))
+
+;;;;;;;;;;;;;;
+;; DOCUMENT ;;
+;;;;;;;;;;;;;;
+
+(defun merlin--document-pos (ident)
+  "Document the identifier IDENT at point and return the result."
+  (merlin-call "document"
+               "-position" (merlin-unmake-point (point))
+               (when ident (cons "-identifier" ident))))
+
+(defun merlin--document-pure (&optional ident)
+  "Document the identifier IDENT at point."
+  (let* ((raw-doc  (merlin--document-pos ident))
+         (doc      (concat "(*" raw-doc "*)")))
+    (merlin-display-in-type-buffer doc)
+    (with-current-buffer merlin-type-buffer-name
+      (if (> (line-number-at-pos (point-max)) 8)
+          (display-buffer merlin-type-buffer-name)
+        (font-lock-fontify-region (point-min) (point-max))
+        (message "%s" (buffer-string))))))
+
+(defun merlin-document ()
+  "Document the identifier under point"
+  (interactive)
+  (merlin--document-pure))
+
+;;;;;;;;;;;;;;;;;
+;; OCCURRENCES ;;
+;;;;;;;;;;;;;;;;;
+
+(defun merlin--occurrence-text (line-num marker start end source-buf)
+  (concat (propertize (format "%7d:" line-num)
+                      'font-lock-face 'shadow
+                      'occur-prefix t
+                      'occur-target marker
+                      'follow-link t
+                      'front-sticky t
+                      'rear-nonsticky t
+                      'mouse-face '(highlight))
+          (propertize (replace-regexp-in-string
+                       "\n"
+                       "\n       :"
+                       (with-current-buffer source-buf
+                         (buffer-substring
+                          (progn
+                            (goto-char start)
+                            (line-beginning-position))
+                          (progn
+                            (goto-char end)
+                            (line-end-position)))))
+                      'follow-link t
+                      'mouse-face '(highlight)
+                      'occur-target marker)
+          (propertize "\n" 'occur-target marker)))
+
+(defun merlin--get-occ-buff ()
+  (get-buffer-create merlin-occurrences-buffer-name))
+
+(defun merlin-occurrences-populate-buffer (lst)
+  (let ((src-buff (buffer-name))
+        (occ-buff (merlin--get-occ-buff))
+        (positions
+         (mapcar (lambda (pos)
+                   (cons
+                    (cons 'marker
+                          (copy-marker
+                           (merlin--point-of-pos (assoc 'start pos))))
+                    pos))
+                 lst)))
+    (with-current-buffer occ-buff
+      (let ((inhibit-read-only t)
+            (buffer-undo-list t)
+            (pending-line)
+            (pending-lines-text))
+        (erase-buffer)
+        (occur-mode)
+        (insert (propertize (format "%d occurrences in buffer: %s"
+                                    (length lst)
+                                    src-buff)
+                            'font-lock-face list-matching-lines-buffer-name-face
+                            'read-only t
+                            'occur-title (get-buffer src-buff)))
+        (insert "\n")
+        (dolist (pos positions)
+          (let* ((marker (cdr (assoc 'marker pos)))
+                 (start (assoc 'start pos))
+                 (end (assoc 'end pos))
+                 (line (cdr (assoc 'line start)))
+                 (start-buf-pos (with-current-buffer src-buff
+                                  (merlin--point-of-pos start)))
+                 (end-buf-pos (with-current-buffer src-buff
+                                (merlin--point-of-pos end)))
+                 (prefix-length 8)
+                 (start-offset (+ prefix-length
+                                  (cdr (assoc 'col start))))
+                 (lines-text
+                  (if (equal line pending-line)
+                      pending-lines-text
+                    (merlin--occurrence-text line
+                                            marker
+                                            start-buf-pos
+                                            end-buf-pos
+                                            src-buff))))
+
+            ;; Insert the critical text properties that occur-mode
+            ;; makes use of
+            (add-text-properties start-offset
+                                 (+ start-offset
+                                    (- end-buf-pos start-buf-pos))
+                                 (list 'occur-match t
+                                       'face list-matching-lines-face)
+                                 lines-text)
+
+            ;; Inserting text is delayed until non-equal lines are
+            ;; found in order to accumulate multiple matches within
+            ;; one line.
+            (when (and pending-lines-text
+                       (not (equal line pending-line)))
+              (insert pending-lines-text))
+            (setq pending-line line)
+            (setq pending-lines-text lines-text)))
+
+        ;; Catch final pending text
+        (when pending-lines-text
+          (insert pending-lines-text))
+        (goto-char (point-min))))))
+
+(defun merlin-occurrences-list (lst)
+  (save-excursion
+    (merlin-occurrences-populate-buffer lst)
+    (cl-case merlin-occurrences-show-buffer
+      ('same
+       (switch-to-buffer (merlin--get-occ-buff)))
+      ('other
+       (switch-to-buffer-other-window (merlin--get-occ-buff)))
+      (t nil))))
+
+(defun merlin--occurrences ()
+  (merlin-call "occurrences" "-identifier-at" (merlin-unmake-point (point))))
+
+(defun merlin-occurrences ()
+  "List all occurrences of identifier under cursor in buffer."
+  (interactive)
+  (let ((r (merlin--occurrences)))
+    (when r
+      (if (listp r)
+          (merlin-occurrences-list r)
+        (error "%s" r)))))
+
+;;;;;;;;;;;;;;;;;;;
+;; OPEN REFACTOR ;;
+;;;;;;;;;;;;;;;;;;;
+
+(defun merlin--refactor-open (mode)
+  "Refactor open statement under cursor. mode can be 'qualify or 'unqualify"
+  (save-excursion
+    (dolist (occurrence (nreverse (merlin-call
+                                   "refactor-open"
+                                   "-position" (merlin-unmake-point (point))
+                                   "-action" mode)))
+      (let ((bounds (merlin--make-bounds occurrence))
+            (content (cdr (assoc 'content occurrence))))
+        (unless (equal content (buffer-substring (car bounds) (cdr bounds)))
+          (goto-char (car bounds))
+          (delete-char (- (cdr bounds) (car bounds)))
+          (insert content))))))
+
+(defun merlin-refactor-open ()
+  "Refactor open statement under cursor: unqualify paths"
+  (interactive)
+  (merlin--refactor-open 'unqualify))
+
+(defun merlin-refactor-open-qualify ()
+  "Refactor open statement under cursor: qualify paths"
+  (interactive)
+  (merlin--refactor-open 'qualify))
+
+;;;;;;;;;;;;;;;;;;;;;;;
+;; SEMANTIC MOVEMENT ;;
+;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun merlin-error-check ()
+  "Update merlin to the end-of-file, reporting errors."
+  (interactive)
+  (when merlin-mode (merlin--error-check t)))
+
+(defun merlin-configuration-check (&optional only-failures)
+  "Display loaded .merlin files and eventual errors."
+  (interactive)
+  (let* ((project (merlin--project-get))
+         (dot_merlins (car project))
+         (messages (cdr project))) ; failures list
+    (unless only-failures
+      (when merlin-buffer-configuration
+        (push (format "Custom merlin setup: %S" merlin-buffer-configuration)
+              messages))
+      (push (format
+              "Custom buffer settings:\n- packages: %S\n- flags: %S\n- extensions: %S"
+              (or merlin-buffer-packages 'none)
+              (or merlin-buffer-flags 'none)
+              (or merlin-buffer-extensions 'none))
+            messages)
+      (push (if dot_merlins
+                (concat "Loaded .merlin files: " (mapconcat 'identity dot_merlins ", "))
+              "No .merlin loaded")
+            messages))
+    (message "%s" (mapconcat 'identity messages "\n"))))
+
+(defun merlin-customize ()
+  "Open the customize buffer for the group merlin."
+  (interactive)
+  (customize-group 'merlin))
+
+(defun merlin-version ()
+  "Print the version of the ocamlmerlin binary."
+  (interactive)
+  (with-demoted-errors "Error invoking merlin: %S"
+    (message "%s" (merlin--call-merlin "-version"))))
+
+(defun merlin--configuration ()
+  (when (or merlin-configuration-function merlin-grouping-function)
+    (with-demoted-errors
+      "merlin-command: invalid configuration (%S)"
+      (funcall (or merlin-configuration-function merlin-grouping-function)))))
+
+(defun merlin-command ()
+  "Return or update path of ocamlmerlin binary selected by configuration"
+  (when (or (not merlin-buffer-configuration)
+            (merlin-lookup 'do-not-cache-config merlin-buffer-configuration))
+    (setq merlin-buffer-configuration (merlin--configuration)))
+
+  (let ((command (merlin-lookup 'command merlin-buffer-configuration)))
+    (unless command
+      (setq
+       command
+       (cond
+        ((functionp merlin-command) (funcall merlin-command))
+        ((stringp merlin-command) merlin-command)
+        ((equal merlin-command 'opam)
+         (with-temp-buffer
+           (if (eq (call-process-shell-command
+                    "opam var bin" nil (current-buffer) nil) 0)
+               (let ((bin-path
+                      (replace-regexp-in-string "\n$" "" (buffer-string))))
+                 ;; the opam bin dir needs to be on the path, so if merlin
+                 ;; calls out to sub binaries (e.g. ocamlmerlin-reason), the
+                 ;; correct version is used rather than the version that
+                 ;; happens to be on the path
+
+                 ;; this was originally done via `opam exec' but that does not
+                 ;; work for opam 1, and added a performance hit
+                 (setq merlin-opam-bin-path (list (concat "PATH=" bin-path)))
+                 (concat bin-path "/ocamlmerlin"))
+
+             ;; best effort if opam is not available, lookup for the binary in
+             ;; the existing env
+             (progn
+               (message "merlin-command: opam var failed (%S)"
+                        (buffer-string))
+               "ocamlmerlin"))))))
+
+      ;; cache command in merlin-buffer configuration to avoid having to shell
+      ;; out to `opam` each time.
+      (push (cons 'command command) merlin-buffer-configuration)
+      (when merlin-opam-bin-path
+        (push (cons 'env merlin-opam-bin-path) merlin-buffer-configuration)))
+
+    command))
+
+;;;;;;;;;;;;;;;;
+;; MODE SETUP ;;
+;;;;;;;;;;;;;;;;
+
+(defvar merlin-mode-map
+  (let ((merlin-map (make-sparse-keymap))
+        (merlin-menu-map (make-sparse-keymap))
+        (merlin-show-type-map (make-sparse-keymap)))
+    (define-key merlin-map (kbd "C-c C-x") #'merlin-error-next)
+    (define-key merlin-map (kbd "C-c C-l") #'merlin-locate)
+    (define-key merlin-map (kbd "C-c &"  ) #'merlin-pop-stack)
+    (define-key merlin-map (kbd "C-c C-r") #'merlin-error-check)
+    (define-key merlin-map (kbd "C-c C-t") #'merlin-type-enclosing)
+    (define-key merlin-map (kbd "C-c C-d") #'merlin-destruct)
+    (define-key merlin-map (kbd "C-c C-n") #'merlin-phrase-next)
+    (define-key merlin-map (kbd "C-c C-p") #'merlin-phrase-prev)
+    (define-key merlin-menu-map [customize]
+      '("Customize merlin-mode" . merlin-customize))
+    (define-key merlin-menu-map [separator]
+      '("-"))
+    (define-key merlin-show-type-map [point]
+      '(menu-item "around the cursor" merlin-type-enclosing
+                  :help "Show the type of the smallest subexpression near cursor"))
+    (define-key merlin-show-type-map [exp]
+      '(menu-item "of an expression" merlin-type-expr
+                  :help "Input an expression and show its type"))
+    (define-key merlin-menu-map [showtype]
+      (cons "Show type..." merlin-show-type-map))
+    (define-key merlin-menu-map [use]
+      '(menu-item "Select packages" merlin-use
+                  :help "Load findlib packages."))
+    (define-key merlin-menu-map [error]
+      '(menu-item "Check for errors" merlin-error-check
+                  :help "Check current buffer for any error."))
+    (define-key merlin-menu-map [dot-merlin]
+      '(menu-item "Check configuration" merlin-configuration-check
+                  :help "Display status of '.merlin'."))
+    (define-key merlin-menu-map [setflags]
+      '(menu-item "Set compiler flags" merlin-flags
+                  :help "Pass specific compiler flags for current buffer."))
+    (define-key merlin-menu-map [extensions]
+      '(menu-item "Syntax extensions" merlin-extensions
+                  :help "Enable support for some dialects of OCaml."))
+    (define-key merlin-menu-map [restartmerlin]
+      '(menu-item "Shutdown merlin server" merlin-stop-server
+                  :help "Stop merlin server."))
+    (define-key merlin-menu-map [versionmerlin]
+      '(menu-item "Version" merlin-version
+                  :help "Print version of the merlin binary."))
+    (define-key merlin-map [menu-bar merlin] (cons "Merlin" merlin-menu-map))
+    merlin-map))
+
+(defun merlin-can-handle-buffer ()
+  "Simple sanity check (used to avoid running merlin on, e.g., completion buffer)."
+  (cond ((equal (buffer-name) merlin-type-buffer-name) nil)
+        ((buffer-file-name (buffer-base-buffer)) t)))
+
+(defun merlin-lighter ()
+  "Return the lighter for merlin which indicates the status of merlin process."
+  (let (messages
+        (num-errors (length merlin-erroneous-buffer)))
+    (when merlin-report-errors-in-lighter
+      (cond ((not merlin--project-cache) nil)
+            ((cdr-safe merlin--project-cache)
+             (push "check config!" messages))
+            ((not (car-safe merlin--project-cache))
+             (push "no .merlin" messages))))
+    (unless (zerop num-errors)
+      (push (format "%d error%s" num-errors (if (> num-errors 1) "s" ""))
+            messages))
+    (when (and merlin-show-instance-in-lighter
+               (merlin-lookup 'name merlin-buffer-configuration))
+      (push (merlin-lookup 'name merlin-buffer-configuration)
+            messages))
+    (if messages
+        (concat " Merlin (" (mapconcat 'identity messages ",") ")")
+      " Merlin")))
+
+;;; DEPRECATED FUNCTIONS
+
+(define-obsolete-function-alias 'merlin-project-check 'merlin-configuration-check "v3.0.0")
+
+(define-obsolete-function-alias 'merlin--copy-enclosing 'merlin-copy-enclosing "v3.0.0")
+(define-obsolete-function-alias 'merlin--destruct-enclosing 'merlin-destruct-enclosing "v3.0.0")
+
+(define-obsolete-function-alias 'merlin-restart-process 'merlin-stop-server "v3.0.0")
+
+;;;###autoload
+(define-minor-mode merlin-mode
+  "Minor mode for interacting with a merlin process.
+Runs a merlin process in the background and perform queries on it.
+
+Short cuts:
+\\{merlin-mode-map}"
+  :init-value nil
+  :lighter (:eval (merlin-lighter))
+  :keymap merlin-mode-map
+  (if merlin-mode
+      ;; When enabling merlin
+      (progn
+        (when (derived-mode-p 'tuareg-mode 'caml-mode 'reason-mode)
+	  (setq merlin-guessed-favorite-caml-mode major-mode))
+        (if (merlin-can-handle-buffer)
+            (progn
+              (let ((configuration (merlin--configuration)))
+                (when configuration (setq merlin-buffer-configuration configuration)))
+              (add-to-list 'after-change-functions 'merlin--on-edit)
+              (add-hook 'xref-backend-functions #'merlin-xref-backend nil t)
+              ;; TODO: Sanity check for selected merlin version
+              (unless merlin--idle-timer
+                (setq merlin--idle-timer
+                      (run-with-idle-timer 0.5 t 'merlin-show-error-on-current-line))))
+          (merlin-mode -1)))
+    ;; When disabling merlin
+    (progn
+      (when merlin-highlight-overlay
+        (delete-overlay merlin-highlight-overlay))
+      (remove-overlays nil nil 'merlin-kind 'highlight)
+      (remove-overlays nil nil 'merlin-kind 'error)
+      (remove-hook 'xref-backend-functions #'merlin-xref-backend t))))
+
+(provide 'merlin)
+
+;; Load these after (provide 'merlin) because they (require 'merlin)
+(require 'merlin-cap)
+(require 'merlin-xref)
+
+;;; merlin.el ends here
diff --git a/featuremap.tines b/featuremap.tines
new file mode 100644
index 0000000..5e47754
--- /dev/null
+++ b/featuremap.tines
@@ -0,0 +1,257 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<?hnb pos="0"?>
+<!-- generated by tines 1.10.0 (https://github.com/larrykollar/tines) -->
+
+<!DOCTYPE tree[
+	<!ELEMENT tree (node*)>
+	<!ELEMENT data (#PCDATA)> <!-- (max 4096 bytes long) -->
+	<!ELEMENT node (data?,node*)>
+	<!ATTLIST node done (yes|no) #IMPLIED
+	          type CDATA #IMPLIED
+	          expanded (yes|no) #IMPLIED
+	>]>
+
+<tree>
+<node expanded="yes"><data>Configuration (OK)</data>
+	<node type="todo" done="no"><data>OCaml settings</data>
+		<node type="text"><data>Goal is not to reproduce OCaml testsuite, just that settings are applied correctly and that the few Merlin specific behavior are affected.</data></node>
+		<node type="todo" done="no" expanded="yes"><data>include_dirs</data></node>
+		<node type="todo" done="no" expanded="yes"><data>no_std_include</data>
+			<node type="text"><data>check that it is possible to provide an alternative stdlib</data></node>
+		</node>
+		<node type="todo" done="no" expanded="yes"><data>unsafe</data>
+			<node type="text"><data>check that merlin is subject to the same syntactic quirks as OCaml</data></node>
+		</node>
+		<node type="todo" done="no" expanded="yes"><data>classic</data>
+			<node type="text"><data>write code that mixes different kind of arguments, check errors</data></node>
+		</node>
+		<node type="todo" done="no" expanded="yes"><data>principal</data>
+			<node type="text"><data>write non-principal code, check errors</data></node>
+		</node>
+		<node type="todo" done="no" expanded="yes"><data>threads</data>
+			<node type="text"><data>check that Thread/Mutex/Event libraries are found if the flag is specified</data></node>
+		</node>
+		<node type="todo" done="no" expanded="yes"><data>recursive_types</data>
+			<node type="text" expanded="yes"><data>write dubious code that wouldn&apos;t typecheck without it</data></node>
+		</node>
+		<node type="todo" done="no" expanded="yes"><data>strict_sequence</data>
+			<node type="text"><data>check that 5; () fails</data></node>
+		</node>
+		<node type="todo" done="no" expanded="yes"><data>applicative_functors</data>
+			<node type="text"><data>check that non-applicative functors are rejected, check quirks in Parser</data></node>
+		</node>
+		<node type="todo" done="no" expanded="yes"><data>unsafe_string</data>
+			<node type="todo" done="no"><data>check that environment is setup correctly with and without unsafe string</data></node>
+			<node type="todo" done="no"><data>check that Bytes and String deprecation warning are reported appropriately</data></node>
+		</node>
+		<node type="todo" done="no" expanded="yes"><data>nopervasives</data>
+			<node type="text" expanded="yes"><data>figure wtf happens in this case ?!</data></node>
+		</node>
+		<node type="todo" done="no" expanded="yes"><data>strict_formats</data>
+			<node type="text"><data>check it conforms to OCaml behavior, what is this expected to do?</data></node>
+		</node>
+		<node type="todo" done="no" expanded="yes"><data>open_modules</data>
+			<node type="text"><data>check environment is initialized as it should</data></node>
+		</node>
+		<node type="todo" done="no" expanded="yes"><data>ppx</data>
+			<node type="todo" done="no"><data>check Ast is rewritten as it should</data></node>
+			<node type="todo" done="no"><data>ensure graceful degradation if ppx is missing or broken</data></node>
+			<node type="todo" done="no"><data>check composition of multiple ppx work as expected</data></node>
+		</node>
+		<node type="todo" done="no" expanded="yes"><data>pp</data>
+			<node type="text"><data>check frontend/reader is affected as it should</data></node>
+		</node>
+		<node type="todo" done="no" expanded="yes"><data>warnings</data>
+			<node type="todo" done="no"><data>check that a few warnings are treated properly</data></node>
+		</node>
+		<node type="todo" done="no"><data>reals_paths / Short-path</data></node>
+	</node>
+	<node type="todo" done="no"><data>Findlib configuration</data>
+		<node type="todo" done="no" expanded="yes"><data>conf</data>
+			<node type="text"><data>check that it overrides location of findlib.conf</data></node>
+			<node type="text"><data>check behavior when file is missing or invalid (directory, wrong permission)</data></node>
+		</node>
+		<node type="todo" done="no" expanded="yes"><data>path</data>
+			<node type="text"><data>check that it actually adds new path to the findlib package directories</data></node>
+		</node>
+	</node>
+	<node type="todo" done="no"><data>Merlin settings</data>
+		<node type="todo" done="no"><data>TODO: define command line flags for each of these settings</data></node>
+		<node type="todo" done="no" expanded="yes"><data>build_path / source_path / cmi_path / cmt_path</data>
+			<node type="text"><data>specify which behavior are affected by each path variable</data></node>
+			<node type="text"><data>check that each variable is considered for corresponding lookups</data></node>
+		</node>
+		<node type="todo" done="no" expanded="yes"><data>extensions</data>
+			<node type="text"><data>check that corresponding extensions are enabled in lexer / parser / typer</data></node>
+		</node>
+		<node type="todo" done="no" expanded="yes"><data>suffixes</data>
+			<node type="text"><data>specify which behavior should be affected by suffixes</data></node>
+			<node type="text"><data>check that .ml(i) and .re(i) are correctly handled by default</data></node>
+		</node>
+		<node type="todo" done="no" expanded="yes"><data>stdlib</data>
+			<node type="text"><data>check that it is possible to use merlin with a different installation of OCaml</data></node>
+			<node type="text"><data>ensure graceful degradation if stdlib is incorrect</data></node>
+		</node>
+		<node type="todo" done="no" expanded="yes"><data>reader</data>
+			<node type="text"><data>ensure this setting is not ignored</data></node>
+		</node>
+		<node type="todo" done="no" expanded="yes"><data>dot_merlin</data>
+			<node type="text" expanded="yes"><data>specify the format for good</data></node>
+			<node type="text"><data>ensure all features are parsed and affects configuration</data></node>
+			<node type="text"><data>ensure recursive resolution is working properly</data></node>
+		</node>
+		<node type="todo" done="no" expanded="yes"><data>packages</data>
+			<node type="text"><data>ensure build path is updated correctly</data></node>
+			<node type="text"><data>ensure graceful degradation when loading unknown or invalid packages</data></node>
+			<node type="text" expanded="yes"><data>ensure that ppxs specified by packages are loaded correctly</data>
+				<node><data>ppx path should be resolved relative to package directory</data></node>
+			</node>
+		</node>
+	</node>
+	<node type="todo" done="no"><data>Query settings</data>
+		<node type="todo" done="no" expanded="yes"><data>directory</data>
+			<node type="text"><data>ensure this setting takes precedence over process working directory</data></node>
+		</node>
+		<node type="todo" done="no" expanded="yes"><data>filename</data>
+			<node type="text"><data>TODO: remove Msource.filename?</data></node>
+		</node>
+		<node type="todo" done="no" expanded="yes"><data>terminal_width</data>
+			<node type="text"><data>check that pretty printer / error behavior take this into account :)</data></node>
+			<node type="text"><data>or completely remove it?</data></node>
+		</node>
+		<node type="todo" done="no"><data>verbosity</data>
+			<node type="text"><data>check that various verbosity sensitive queries are affected</data></node>
+		</node>
+	</node>
+</node>
+<node expanded="yes"><data>Queries (WIP)</data>
+	<node type="todo" done="no"><data>Case analysis (destruct)</data></node>
+	<node type="todo" done="no"><data>Completion</data>
+		<node><data>Normal</data>
+			<node><data>Candidate enumeration</data>
+				<node><data>Polymorphic variants</data></node>
+				<node><data>Values</data></node>
+				<node><data>Value constructors</data></node>
+				<node><data>Type constructors</data></node>
+				<node><data>Modules</data>
+					<node><data>Signature expansion affected by verbosity</data></node>
+				</node>
+				<node><data>Module types</data></node>
+				<node><data>Record labels</data></node>
+			</node>
+		</node>
+		<node><data>Record fields</data>
+			<node><data>Normal</data></node>
+			<node><data>After module path</data></node>
+		</node>
+		<node><data>Method completion</data></node>
+		<node><data>Sorting</data>
+			<node><data>By categories</data>
+				<node><data>Expression</data></node>
+				<node><data>Structure</data></node>
+				<node><data>Pattern</data></node>
+				<node><data>Module</data></node>
+				<node><data>Module types</data></node>
+				<node><data>Signature </data></node>
+				<node><data>Type</data></node>
+			</node>
+			<node><data>By unification cost</data></node>
+			<node><data>By number of &quot;arrows&quot;</data></node>
+		</node>
+		<node><data>Arguments</data>
+			<node><data>Type-directed</data></node>
+			<node><data>For infix operator</data></node>
+			<node><data>Labelled argument</data></node>
+			<node><data>Optional argument</data></node>
+		</node>
+		<node><data>Expansion / spell checking</data>
+			<node><data>Path prefixes completion</data></node>
+			<node><data>Spell correction</data></node>
+		</node>
+		<node><data>Global modules</data></node>
+		<node><data>Filtering</data>
+			<node><data>Hidden namespace &apos;_&apos;</data></node>
+			<node><data>Janestreet modules containing &apos;__&apos;</data></node>
+		</node>
+	</node>
+	<node type="todo" done="no"><data>Document</data>
+		<node><data>check external doc comments are reported appropriately</data></node>
+		<node><data>check internal doc comments are reported appropriately</data></node>
+	</node>
+	<node type="todo" done="no"><data>Dump</data>
+		<node><data>parsetree</data></node>
+		<node><data>printast</data></node>
+		<node><data>env / fullenv</data></node>
+		<node><data>browse</data></node>
+		<node><data>tokens</data></node>
+		<node><data>flags</data></node>
+		<node><data>warnings</data></node>
+		<node><data>exn</data></node>
+		<node><data>paths</data></node>
+	</node>
+	<node type="todo" done="no"><data>Errors</data>
+		<node><data>Sources</data>
+			<node><data>Lexer</data></node>
+			<node><data>Parser</data></node>
+			<node><data>Typer</data>
+				<node><data>If a CMI is missing, only report this error (FIXME: these errors?)</data></node>
+				<node><data>Filter out type errors after a syntax error, they are likely to be noise</data></node>
+				<node><data>Top-level errors shouldn&apos;t escape</data></node>
+			</node>
+		</node>
+		<node><data>Sort by position</data></node>
+		<node><data>TODO: find a way to measure recovery quality</data></node>
+	</node>
+	<node type="todo" done="no"><data>Extensions</data>
+		<node><data>Meta OCaml</data></node>
+		<node><data>Lwt</data></node>
+	</node>
+	<node type="todo" done="no"><data>Findlib list</data>
+		<node><data>Check that custom findlib setups are supported</data></node>
+		<node><data>Fail gracefully if findlib not available? (JST)</data></node>
+	</node>
+	<node type="todo" done="no"><data>Jump</data></node>
+	<node type="todo" done="no"><data>Locate</data></node>
+	<node type="todo" done="no"><data>Occurrences</data>
+		<node><data>Look in the appropriate namespace, check correct behavior for each</data>
+			<node><data>Values</data></node>
+			<node><data>Constructors</data></node>
+			<node><data>Types</data></node>
+			<node><data>Modules</data></node>
+		</node>
+		<node><data>What is the behavior when exiting/entering a module</data>
+			<node><data>Plain identifier when referred to from outside the module?</data></node>
+			<node><data>Qualified identifier when referred to from inside the module</data></node>
+		</node>
+	</node>
+	<node type="todo" done="no"><data>Outline</data></node>
+	<node type="todo" done="no"><data>Shape</data></node>
+	<node type="todo" done="no"><data>Type enclosing</data>
+		<node><data>String argument (expro) is a bit redundant: only position should be provided.</data></node>
+	</node>
+	<node type="todo" done="no"><data>Type expression</data>
+		<node><data>Ensure expression is typed in the right environment</data></node>
+		<node><data>Explain how verbosity affects results</data></node>
+	</node>
+	<node type="todo" done="no"><data>Which (find source files)</data>
+		<node><data>With ext</data></node>
+		<node><data>Path</data></node>
+	</node>
+</node>
+<node><data>Reader (WIP)</data>
+	<node><data>check behaviors for builtin, -pp and external frontends</data></node>
+	<node><data>Lexer</data>
+		<node><data>Reconstruct identifiers</data></node>
+		<node><data>Decompose path components into tokens (TODO)</data></node>
+		<node><data>Check comments are reported appropriately</data></node>
+	</node>
+	<node><data>Parser</data>
+		<node><data>check support for ML &amp; MLI</data></node>
+	</node>
+	<node><data>Pretty-printer</data>
+		<node><data>of parsetree (for destruct)</data></node>
+		<node><data>of outcometree (for completion &amp; error report)</data></node>
+		<node><data>support for external readers</data></node>
+	</node>
+</node>
+</tree>
diff --git a/featuremap.txt b/featuremap.txt
new file mode 100644
index 0000000..779045a
--- /dev/null
+++ b/featuremap.txt
@@ -0,0 +1,195 @@
+Configuration (OK)
+	OCaml settings
+		Goal is not to reproduce OCaml testsuite, just that settings are applied correctly and that the few Merlin specific behavior are affected.
+		include_dirs
+		no_std_include
+			check that it is possible to provide an alternative stdlib
+		unsafe
+			check that merlin is subject to the same syntactic quirks as OCaml
+		classic
+			write code that mixes different kind of arguments, check errors
+		principal
+			write non-principal code, check errors
+		threads
+			check that Thread/Mutex/Event libraries are found if the flag is specified
+		recursive_types
+			write dubious code that wouldn't typecheck without it
+		strict_sequence
+			check that 5; () fails
+		applicative_functors
+			check that non-applicative functors are rejected, check quirks in Parser
+		unsafe_string
+			check that environment is setup correctly with and without unsafe string
+			check that Bytes and String deprecation warning are reported appropriately
+		nopervasives
+			figure wtf happens in this case ?!
+		strict_formats
+			check it conforms to OCaml behavior, what is this expected to do?
+		open_modules
+			check environment is initialized as it should
+		ppx
+			check Ast is rewritten as it should
+			ensure graceful degradation if ppx is missing or broken
+			check composition of multiple ppx work as expected
+		pp
+			check frontend/reader is affected as it should
+		warnings
+			check that a few warnings are treated properly
+		reals_paths / Short-path
+	Findlib configuration
+		conf
+			check that it overrides location of findlib.conf
+			check behavior when file is missing or invalid (directory, wrong permission)
+		path
+			check that it actually adds new path to the findlib package directories
+	Merlin settings
+		TODO: define command line flags for each of these settings
+		build_path / source_path / cmi_path / cmt_path
+			specify which behavior are affected by each path variable
+			check that each variable is considered for corresponding lookups
+		extensions
+			check that corresponding extensions are enabled in lexer / parser / typer
+		suffixes
+			specify which behavior should be affected by suffixes
+			check that .ml(i) and .re(i) are correctly handled by default
+		stdlib
+			check that it is possible to use merlin with a different installation of OCaml
+			ensure graceful degradation if stdlib is incorrect
+		reader
+			ensure this setting is not ignored
+		dot_merlin
+			specify the format for good
+			ensure all features are parsed and affects configuration
+			ensure recursive resolution is working properly
+		packages
+			ensure build path is updated correctly
+			ensure graceful degradation when loading unknown or invalid packages
+			ensure that ppxs specified by packages are loaded correctly
+				ppx path should be resolved relative to package directory
+	Query settings
+		directory
+			ensure this setting takes precedence over process working directory
+		filename
+			TODO: remove Msource.filename?
+		terminal_width
+			check that pretty printer / error behavior take this into account :)
+			or completely remove it?
+		verbosity
+			check that various verbosity sensitive queries are affected
+Queries (WIP)
+	Case analysis (destruct)
+		On a pattern
+			If exhaustive
+				Try and split the thing under the cursor (works
+				on variables and wildcards) into subpatterns
+			If not-exhaustive
+				Make it exhaustive
+		On an expression [e]
+			If it is a module
+				expand into "let module ..."
+			If it is a variant or record type
+				replace by [match e with <cases>]
+	Completion
+		Normal
+			Candidate enumeration
+				Polymorphic variants
+				Values
+				Value constructors
+				Type constructors
+				Modules
+					Signature expansion affected by verbosity
+				Module types
+				Record labels
+		Record fields
+			Normal
+			After module path
+		Method completion
+		Sorting
+			By categories
+				Expression
+				Structure
+				Pattern
+				Module
+				Module types
+				Signature 
+				Type
+			By unification cost
+			By number of "arrows"
+		Arguments
+			Type-directed
+			For infix operator
+			Labelled argument
+			Optional argument
+		Expansion / spell checking
+			Path prefixes completion
+			Spell correction
+		Global modules
+		Filtering
+			Hidden namespace '_'
+			Janestreet modules containing '__'
+	Document
+		check external doc comments are reported appropriately
+		check internal doc comments are reported appropriately
+	Dump
+		parsetree
+		printast
+		env / fullenv
+		browse
+		tokens
+		flags
+		warnings
+		exn
+		paths
+	Errors
+		Sources
+			Lexer
+			Parser
+			Typer
+				If a CMI is missing, only report this error (FIXME: these errors?)
+				Filter out type errors after a syntax error, they are likely to be noise
+				Top-level errors shouldn't escape
+		Sort by position
+		TODO: find a way to measure recovery quality
+	Extensions
+		Meta OCaml
+		Lwt
+	Findlib list
+		Check that custom findlib setups are supported
+		Fail gracefully if findlib not available? (JST)
+	Jump
+	Locate
+	Occurrences
+		Look in the appropriate namespace, check correct behavior for each
+			Values
+			Constructors
+			Types
+			Modules
+		What is the behavior when exiting/entering a module
+			Plain identifier when referred to from outside the module?
+			Qualified identifier when referred to from inside the module
+	Outline
+	Shape
+	Type enclosing
+		String argument (expro) is a bit redundant: only position should be provided.
+		↑ Wasn't that used to be able to do things like ":TypeOf FooBar.S"?
+		↓ See below, the string argument is used to approximate where the cursor is
+      (in the middle of a path or even a path component), since locations are
+      only stored at the granularity of one path
+	Type expression
+		Ensure expression is typed in the right environment
+		Explain how verbosity affects results
+	Which (find source files)
+		With ext
+		Path
+Reader (WIP)
+	check behaviors for builtin, -pp and external frontends
+	Lexer
+		Reconstruct identifiers
+		Decompose path components into tokens (TODO)
+		Check comments are reported appropriately
+	Parser
+		check support for ML & MLI
+	Pretty-printer
+		of parsetree (for destruct)
+		of outcometree (for completion & error report)
+		support for external readers
diff --git a/merlin.opam b/merlin.opam
new file mode 100644
index 0000000..c834644
--- /dev/null
+++ b/merlin.opam
@@ -0,0 +1,69 @@
+opam-version: "2.0"
+maintainer:   "defree@gmail.com"
+authors:      "The Merlin team"
+homepage:     "https://github.com/ocaml/merlin"
+bug-reports:  "https://github.com/ocaml/merlin/issues"
+dev-repo:     "git+https://github.com/ocaml/merlin.git"
+license:      "MIT"
+build: [
+  ["dune" "subst"] {dev}
+  ["dune" "build" "-p" name "-j" jobs]
+  ["dune" "runtest" "-p" "merlin,dot-merlin-reader" "-j" "1"] {with-test}
+]
+depends: [
+  "ocaml" {>= "4.13" & < "4.14"}
+  "dune" {>= "2.9.0"}
+  "dot-merlin-reader" {>= "4.0"}
+  "yojson" {>= "2.0.0"}
+  "conf-jq" {with-test}
+  "csexp" {>= "1.2.3"}
+  "menhir" {dev}
+  "menhirLib" {dev}
+  "menhirSdk" {dev}
+  "ppxlib" {with-test}
+]
+conflicts: "seq" {!= "base"}
+synopsis:
+  "Editor helper, provides completion, typing and source browsing in Vim and Emacs"
+description:
+  "Merlin is an assistant for editing OCaml code. It aims to provide the features available in modern IDEs: error reporting, auto completion, source browsing and much more."
+post-messages: [
+  "merlin installed.
+
+Quick setup for VIM
+-------------------
+Append this to your .vimrc to add merlin to vim's runtime-path:
+  let g:opamshare = substitute(system('opam var share'),'\\n$','','''')
+  execute \"set rtp+=\" . g:opamshare . \"/merlin/vim\"
+
+Also run the following line in vim to index the documentation:
+  :execute \"helptags \" . g:opamshare . \"/merlin/vim/doc\"
+
+Quick setup for EMACS
+-------------------
+Add opam emacs directory to your load-path by appending this to your .emacs:
+  (let ((opam-share (ignore-errors (car (process-lines \"opam\" \"var\" \"share\")))))
+   (when (and opam-share (file-directory-p opam-share))
+    ;; Register Merlin
+    (add-to-list 'load-path (expand-file-name \"emacs/site-lisp\" opam-share))
+    (autoload 'merlin-mode \"merlin\" nil t nil)
+    ;; Automatically start it in OCaml buffers
+    (add-hook 'tuareg-mode-hook 'merlin-mode t)
+    (add-hook 'caml-mode-hook 'merlin-mode t)
+    ;; Use opam switch to lookup ocamlmerlin binary
+    (setq merlin-command 'opam)))
+
+Take a look at https://github.com/ocaml/merlin for more information
+
+Quick setup with opam-user-setup
+--------------------------------
+
+Opam-user-setup support Merlin.
+
+  $ opam user-setup install
+
+should take care of basic setup.
+See https://github.com/OCamlPro/opam-user-setup
+"
+  {success & !user-setup:installed}
+]
diff --git a/src/analysis/browse_misc.ml b/src/analysis/browse_misc.ml
new file mode 100644
index 0000000..32b7c72
--- /dev/null
+++ b/src/analysis/browse_misc.ml
@@ -0,0 +1,151 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+
+let dummy_type_scheme desc =
+  Types.Private_type_expr.create desc ~level:0 ~id:0 ~scope:Btype.generic_level
+
+let print_constructor c =
+  let open Types in
+  match c.cstr_args with
+  | [] ->
+    Printtyp.tree_of_type_scheme
+      (dummy_type_scheme c.cstr_res.desc)
+  | args ->
+    let desc = Tarrow (Ast_helper.no_label,
+                       dummy_type_scheme (Ttuple args),
+                       c.cstr_res, Cok)
+    in
+    Printtyp.tree_of_type_scheme (dummy_type_scheme desc)
+
+let summary_prev = function
+  | Env.Env_empty -> None
+  | Env.Env_open (s,_)       | Env.Env_value (s,_,_)
+  | Env.Env_type (s,_,_)     | Env.Env_extension (s,_,_)
+  | Env.Env_module (s,_,_,_) | Env.Env_modtype (s,_,_)
+  | Env.Env_class (s,_,_)    | Env.Env_cltype (s,_,_)
+  | Env.Env_functor_arg (s,_)
+  | Env.Env_constraints (s,_)
+  | Env.Env_copy_types s
+  | Env.Env_persistent (s,_)
+  | Env.Env_value_unbound (s, _, _) | Env.Env_module_unbound (s, _, _) ->
+    Some s
+
+let signature_of_env ?(ignore_extensions=true) env =
+  let signature_of_summary =
+    let open Env in
+    let open Types in
+    (* FIXME: the use of [Exported] here is wrong... The compiler should export
+      that information. *)
+    function
+    | Env_value (_,i,v)      -> Some (Sig_value (i,v,Exported))
+    (* Trec_not == bluff, FIXME *)
+    | Env_type (_,i,t)       -> Some (Sig_type (i,t,Trec_not,Exported))
+    (* Texp_first == bluff, FIXME *)
+    | Env_extension (_,i,e)  ->
+      begin match e.ext_type_path with
+      | Path.Pident id when Ident.name id = "exn" ->
+        Some (Sig_typext (i,e, Text_exception, Exported))
+      | _ ->
+        Some (Sig_typext (i,e, Text_first, Exported))
+      end
+    | Env_module (_,i,pr,m)  -> Some (Sig_module (i,pr,m,Trec_not,Exported))
+    | Env_modtype (_,i,m)    -> Some (Sig_modtype (i,m,Exported))
+    | Env_class (_,i,c)      -> Some (Sig_class (i,c,Trec_not,Exported))
+    | Env_cltype (_,i,c)     -> Some (Sig_class_type (i,c,Trec_not,Exported))
+    | Env_open _ | Env_empty | Env_functor_arg _
+    | Env_constraints _ | Env_copy_types _ | Env_persistent _
+    | Env_value_unbound _ | Env_module_unbound _ -> None
+  in
+  let summary_module_ident_opt = function
+    | Env.Env_module (_,i,_,_) -> Some i
+    | _ -> None
+  in
+  let sg = ref [] in
+  let append item = sg := item :: !sg in
+  let rec aux summary =
+    match summary_module_ident_opt summary with
+    | Some i when ignore_extensions && i = Extension.ident -> ()
+    | _ ->
+      Option.iter ~f:append (signature_of_summary summary);
+      Option.iter ~f:aux (summary_prev summary)
+  in
+  aux (Env.summary env);
+  (* Since 4.08 one can't simply call [simplify]. *)
+  (* Typemod.simplify_signature *) (!sg)
+
+let dump_browse node =
+  let attr attr =
+    let ({Location . txt; loc},payload) = Ast_helper.Attr.as_tuple attr in
+    `Assoc [
+      "start"    , Lexing.json_of_position loc.Location.loc_start;
+      "end"      , Lexing.json_of_position loc.Location.loc_end;
+      "name"     , `String (txt ^ if payload = Parsetree.PStr [] then "" else " _")
+    ]
+  in
+  let rec append env node acc =
+    let loc = Mbrowse.node_loc node in
+    `Assoc [
+      "filename" , `String loc.Location.loc_start.Lexing.pos_fname;
+      "start"    , Lexing.json_of_position loc.Location.loc_start;
+      "end"      , Lexing.json_of_position loc.Location.loc_end;
+      "ghost"    , `Bool loc.Location.loc_ghost;
+      "attrs"    , `List (List.map ~f:attr (Browse_raw.node_attributes node));
+      "kind"     , `String (Browse_raw.string_of_node node);
+      "children" , dump_list env node
+    ] :: acc
+  and dump_list env node =
+    `List (List.sort ~cmp:compare @@
+           Mbrowse.fold_node append env node [])
+  in
+  `List (append Env.empty node [])
+
+let annotate_tail_calls (ts : Mbrowse.t) :
+  (Env.t * Browse_raw.node * Query_protocol.is_tail_position) list =
+  let is_one_of candidates node = List.mem node ~set:candidates in
+  let find_entry_points candidates (env, node) =
+    Tail_analysis.entry_points node,
+    (env, node, is_one_of candidates node) in
+  let _, entry_points = List.fold_n_map ts ~f:find_entry_points ~init:[] in
+  let propagate candidates (env, node, entry) =
+    let is_in_tail = entry || is_one_of candidates node in
+    (if is_in_tail
+     then Tail_analysis.tail_positions node
+     else []),
+    (env, node, is_in_tail) in
+  let _, tail_positions = List.fold_n_map entry_points ~f:propagate ~init:[] in
+  List.map ~f:(fun (env, node, tail) ->
+      env, node,
+      if not tail then
+        `No
+      else if Tail_analysis.is_call node then
+        `Tail_call
+      else
+        `Tail_position)
+    tail_positions
diff --git a/src/analysis/browse_tree.ml b/src/analysis/browse_tree.ml
new file mode 100644
index 0000000..cabcf10
--- /dev/null
+++ b/src/analysis/browse_tree.ml
@@ -0,0 +1,147 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+
+let default_loc = Location.none
+let default_env = Env.empty
+
+type t = {
+  t_node: Mbrowse.node;
+  t_loc : Location.t;
+  t_env : Env.t;
+  t_children: t list lazy_t;
+}
+
+let of_node ?(env=default_env) node =
+  let rec one t_env t_node =
+    let t_loc = Mbrowse.node_loc t_node in
+    let rec t = {t_node; t_env; t_loc; t_children = lazy (aux t)} in
+    t
+  and aux t =
+    Mbrowse.fold_node (fun env node acc -> one env node :: acc)
+      t.t_env t.t_node []
+  in
+  one (Browse_raw.node_update_env env node) node
+
+let of_browse b =
+  let env, node = Mbrowse.leaf_node b in
+  of_node ~env node
+
+let dummy = {
+  t_node = Browse_raw.Dummy;
+  t_loc = default_loc;
+  t_env = default_env;
+  t_children = lazy []
+}
+
+let rec normalize_type_expr env = function
+  | {Types.desc = Types.Tconstr (path,_,_); _ } ->
+    normalize_type_decl env (Env.find_type path env)
+  | _ -> raise Not_found
+
+and normalize_type_decl env decl = match decl.Types.type_manifest with
+  | Some expr -> normalize_type_expr env expr
+  | None -> decl
+
+let id_of_constr_decl c = c.Types.cd_id
+
+let same_constructor env a b =
+  let name = function
+    | `Description d -> d.Types.cstr_name
+    | `Declaration d -> Ident.name d.Typedtree.cd_id
+  in
+  if name a <> name b then false
+  else begin
+    let get_decls = function
+      | `Description d ->
+        let ty = normalize_type_expr env d.Types.cstr_res in
+        begin match ty.Types.type_kind with
+        | Types.Type_variant (decls, _) ->
+          List.map decls ~f:id_of_constr_decl
+        | _ -> assert false
+        end
+      | `Declaration d ->
+        [d.Typedtree.cd_id]
+    in
+    let a = get_decls a in
+    let b = get_decls b in
+    List.exists a ~f:(fun id -> List.exists b ~f:(Ident.same id))
+  end
+
+let all_occurrences path =
+  let rec aux acc t =
+    let acc =
+      let paths = Browse_raw.node_paths t.t_node in
+      let same l = Path.same path l.Location.txt in
+      match List.filter ~f:same paths with
+      | [] -> acc
+      | paths -> (t, paths) :: acc
+    in
+    List.fold_left ~f:aux ~init:acc (Lazy.force t.t_children)
+  in
+  aux []
+
+let all_constructor_occurrences ({t_env = env; _},d) t =
+  let rec aux acc t =
+    let acc =
+      match Browse_raw.node_is_constructor t.t_node with
+      | Some d' when (
+          (* Don't try this at home kids. *)
+          try same_constructor env d d'.Location.txt
+          with Not_found -> same_constructor t.t_env d d'.Location.txt
+        ) ->
+        {d' with Location.txt = t} :: acc
+      | _ -> acc
+    in
+    List.fold_left ~f:aux ~init:acc (Lazy.force t.t_children)
+  in
+  aux [] t
+
+let all_occurrences_of_prefix path node =
+  let rec path_prefix ~prefix path =
+    Path.same prefix path ||
+    match path with
+    | Pdot (p,_) -> path_prefix ~prefix p
+    | _ -> false
+  in
+  let rec aux env node acc =
+    let acc =
+      let paths_and_lids = Browse_raw.node_paths_and_longident node in
+      let has_prefix ({Location. txt; _}, _) =
+        match txt with
+        | Path.Pdot (p, _) -> path_prefix ~prefix:path p
+        | _ -> false
+      in
+      List.fold_right paths_and_lids ~init:acc ~f:(fun elt acc ->
+        if has_prefix elt then elt :: acc else acc
+      )
+    in
+    Browse_raw.fold_node aux env node acc
+  in
+  aux Env.empty node []
diff --git a/src/analysis/browse_tree.mli b/src/analysis/browse_tree.mli
new file mode 100644
index 0000000..24284e8
--- /dev/null
+++ b/src/analysis/browse_tree.mli
@@ -0,0 +1,55 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+type t = {
+  t_node     : Mbrowse.node;
+  t_loc      : Location.t;
+  t_env      : Env.t;
+  t_children : t list lazy_t;
+}
+
+val default_loc : Location.t
+val default_env : Env.t
+
+(** [of_node ?loc ?env node] produces a tree from [node], using [loc] and [env]
+  * as default annotation when nothing can be inferred from the [node].
+  * If they are not specified, annotations from child are used for approximation.
+  *)
+val of_node : ?env:Env.t -> Mbrowse.node -> t
+val of_browse : Mbrowse.t -> t
+
+val dummy : t
+
+val all_occurrences : Path.t -> t -> (t * Path.t Location.loc list) list
+val all_constructor_occurrences :
+  t * [ `Description of Types.constructor_description
+      | `Declaration of Typedtree.constructor_declaration ]
+  -> t -> t Location.loc list
+
+val all_occurrences_of_prefix :
+  Path.t -> Browse_raw.node -> (Path.t Location.loc * Longident.t) list
diff --git a/src/analysis/completion.ml b/src/analysis/completion.ml
new file mode 100644
index 0000000..f012523
--- /dev/null
+++ b/src/analysis/completion.ml
@@ -0,0 +1,808 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+                             Jeremie Dimino  <jeremie(_)dimino.org>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+
+open Browse_raw
+
+open Extend_protocol.Reader
+
+let {Logger. log} = Logger.for_section "Completion"
+
+type raw_info =
+  [ `Constructor of Types.constructor_description
+  | `Modtype of Types.module_type
+  | `Modtype_declaration of Ident.t * Types.modtype_declaration
+  | `None
+  | `String of string
+  | `Type_declaration of Ident.t * Types.type_declaration
+  | `Type_scheme of Types.type_expr
+  | `Variant of string * Types.type_expr option
+  ]
+
+let raw_info_printer : raw_info -> _ = function
+  | `Constructor c ->
+    `Print (Out_type (Browse_misc.print_constructor c))
+  | `Modtype mt ->
+    `Print (Out_module_type (Printtyp.tree_of_modtype mt))
+  | `Modtype_declaration (id, mtd) ->
+    `Print (Out_sig_item
+              (Printtyp.tree_of_modtype_declaration id mtd))
+  | `None -> `String ""
+  | `String s -> `String s
+  | `Type_declaration (id, tdecl) ->
+    `Print (Out_sig_item
+              (Printtyp.tree_of_type_declaration id tdecl Types.Trec_first))
+  | `Type_scheme te ->
+    `Print (Out_type (Printtyp.tree_of_type_scheme te))
+  | `Variant (label, arg) ->
+    begin match arg with
+      | None -> `String label
+      | Some te ->
+        `Concat (label ^ " of ",
+                 Out_type (Printtyp.tree_of_type_scheme te))
+    end
+
+(* List methods of an object.
+   Code taken from [uTop](https://github.com/diml/utop
+   with permission from Jeremie Dimino. *)
+let lookup_env f x env =
+  try Some (f x env)
+  with Not_found | Env.Error _ -> None
+
+let parenthesize_name name =
+  (* Qualified operators need parentheses *)
+  if name = "" || not (Oprint.parenthesized_ident name) then name else (
+    if name.[0] = '*' || name.[String.length name - 1] = '*' then
+      "( " ^ name ^ " )"
+    else
+      "(" ^ name ^ ")"
+  )
+
+let rec methods_of_type env ?(acc=[]) type_expr =
+  let open Types in
+  match type_expr.desc with
+  | Tlink type_expr | Tobject (type_expr, _) | Tpoly (type_expr, _) ->
+    methods_of_type env ~acc type_expr
+  | Tfield (name, _, ty, rest) ->
+    methods_of_type env ~acc:((name,ty) :: acc) rest
+  | Tconstr (path, _, _) -> begin
+      match lookup_env Env.find_type path env with
+      | None | Some { type_manifest = None; _ } -> acc
+      | Some { type_manifest = Some type_expr; _ } ->
+        methods_of_type env ~acc type_expr
+    end
+  | _ -> acc
+
+let classify_node = function
+  | Dummy                      -> `Expression
+  | Pattern                  _ -> `Pattern
+  | Expression               _ -> `Expression
+  | Case                     _ -> `Pattern
+  | Class_expr               _ -> `Expression
+  | Class_structure          _ -> `Expression
+  | Class_field              _ -> `Expression
+  | Class_field_kind         _ -> `Expression
+  | Module_expr              _ -> `Module
+  | Module_type_constraint   _ -> `Module_type
+  | Structure                _ -> `Structure
+  | Structure_item           _ -> `Structure
+  | Module_binding           _ -> `Module
+  | Value_binding            _ -> `Type
+  | Module_type              _ -> `Module_type
+  | Signature                _ -> `Signature
+  | Signature_item           _ -> `Signature
+  | Module_declaration       _ -> `Module
+  | Module_type_declaration  _ -> `Module_type
+  | With_constraint          _ -> `Type
+  | Core_type                _ -> `Type
+  | Package_type             _ -> `Module_type
+  | Row_field                _ -> `Expression
+  | Value_description        _ -> `Type
+  | Type_declaration         _ -> `Type
+  | Type_kind                _ -> `Type
+  | Type_extension           _ -> `Type
+  | Extension_constructor    _ -> `Type
+  | Label_declaration        _ -> `Type
+  | Constructor_declaration  _ -> `Type
+  | Class_type               _ -> `Type
+  | Class_signature          _ -> `Type
+  | Class_type_field         _ -> `Type
+  | Class_declaration        _ -> `Expression
+  | Class_description        _ -> `Type
+  | Class_type_declaration   _ -> `Type
+  | Method_call              _ -> `Expression
+  | Record_field             (`Expression _, _, _) -> `Expression
+  | Record_field             (`Pattern _, _, _) -> `Pattern
+  | Module_binding_name      _ -> `Module
+  | Module_declaration_name  _ -> `Module
+  | Module_type_declaration_name _ -> `Module_type
+  | Open_description _ -> `Module
+  | Open_declaration _ -> `Module
+  | Include_declaration _ -> `Module
+  | Include_description _ -> `Module
+
+open Query_protocol.Compl
+
+let map_entry f entry =
+  {entry with desc = f entry.desc; info = f entry.info}
+
+let make_candidate ~get_doc ~attrs ~exact ~prefix_path name ?loc ?path ty =
+  let ident = match path with
+    | Some path ->
+      (* this is not correct: the ident is not persistent, the printing of some
+         polymorphic variant type could (perhaps) be incorrect because of this
+         (though I haven't tried to add a test). But it would be incorrect with
+         any ident with synthesize at this point anyway.
+         And create_persistent is the only function which is available on all
+         the versions of ocaml we support. *)
+      Ident.create_persistent (Path.last path)
+    | None -> Extension.ident
+  in
+  let kind, text =
+    match ty with
+    | `Value v ->
+      (`Value, `Type_scheme v.Types.val_type)
+    | `Cons c  -> (`Constructor, `Constructor c)
+    | `Label label_descr ->
+      let desc =
+        Types.(Tarrow (Ast_helper.no_label,
+                       label_descr.lbl_res, label_descr.lbl_arg, Cok))
+      in
+      (`Label, `Type_scheme (Btype.newgenty desc))
+    | `Label_decl (ty,label_decl) ->
+      let desc =
+        Types.(Tarrow (Ast_helper.no_label,
+                       ty, label_decl.ld_type, Cok))
+      in
+      (`Label, `Type_scheme (Btype.newgenty desc))
+    | `Mod m   ->
+      begin try
+          if not exact then raise Exit;
+          let verbosity = !Type_utils.verbosity in
+          if Type_utils.mod_smallerthan (1000 * verbosity) m = None then raise Exit;
+          (`Module, `Modtype m)
+        with Exit -> (`Module, `None)
+      end
+    | `ModType m ->
+      if exact then
+        (`Modtype, `Modtype_declaration (ident, (*verbose_sig env*) m))
+      else
+        (`Modtype, `None)
+    | `Typ t ->
+      (`Type, `Type_declaration (ident, t))
+    | `Variant (label,arg) ->
+      (`Variant, `Variant (label, arg))
+  in
+  (* FIXME: When suggesting variants (and constructors) with parameters,
+     it could be nice to check precedence and add or not parenthesis.
+  let name = match ty with
+    | `Variant (_, Some _) -> "(" ^ name ^ " )"
+    | _ -> name
+  in*)
+  let name =
+    match prefix_path with
+    | None -> name
+    | Some _ -> parenthesize_name name
+  in
+  let desc =
+    match kind with
+    | `Module | `Modtype -> `None
+    | _ -> text
+  in
+  let info = match Type_utils.read_doc_attributes attrs, get_doc, kind with
+    | Some (str, _), _, _ -> `String str
+    | None, _, (`Module | `Modtype) -> text
+    | None, None, _ -> `None
+    | None, Some get_doc, kind ->
+      match path, loc with
+      | Some p, Some loc ->
+        let namespace = (* FIXME: that's just terrible *)
+          match kind with
+          | `Value -> `Vals
+          | `Type -> `Type
+          | _ -> assert false
+        in
+        begin match get_doc (`Completion_entry (namespace, p, loc)) with
+          | `Found str -> `String str
+          | _ -> `None
+          | exception _ -> `None
+        end
+      | _, _ -> `None
+  in
+  let deprecated = Type_utils.is_deprecated attrs in
+  {name; kind; desc; info; deprecated}
+
+let item_for_global_module name =
+  {name; kind = `Module; desc = `None; info = `None; deprecated = false}
+
+let fold_variant_constructors ~env ~init ~f =
+  let rec aux acc t =
+    let t = Ctype.repr t in
+    match t.Types.desc with
+    | Types.Tvariant { Types. row_fields; row_more; _ } ->
+      let acc =
+        let keep_if_present acc (lbl, row_field) =
+          match row_field with
+          | Types.Rpresent arg when lbl <> "" -> f ("`" ^ lbl) arg acc
+          | Types.Reither (_, lst, _, _) when lbl <> "" ->
+            let arg =
+              match lst with
+              | [ well_typed ] -> Some well_typed
+              | _ -> None
+            in
+            f ("`" ^ lbl) arg acc
+          | _ -> acc
+        in
+        List.fold_left ~init:acc row_fields ~f:keep_if_present
+      in
+      aux acc row_more
+    | Types.Tconstr _ ->
+      let t' = try Ctype.full_expand env ~may_forget_scope:true t with _ -> t in
+      if Types.TypeOps.equal t t' then
+        acc
+      else
+        aux acc t'
+    | _ -> acc
+  in
+  aux init
+
+let fold_sumtype_constructors ~env ~init ~f t =
+  let t = Ctype.repr t in
+  match t.desc with
+  | Tconstr (path, _, _) ->
+    log ~title:"fold_sumtype_constructors" "node type: %s"
+      (Path.name path);
+    begin match Env.find_type_descrs path env with
+    | exception Not_found -> init
+    | Type_record _ | Type_abstract | Type_open -> init
+    | Type_variant (constrs, _) ->
+      List.fold_right constrs ~init ~f
+    end
+  | _ ->
+    init
+
+let get_candidates ?get_doc ?target_type ?prefix_path ~prefix kind ~validate env branch =
+  let cstr_attributes c = c.Types.cstr_attributes in
+  let val_attributes v = v.Types.val_attributes in
+  let type_attributes t = t.Types.type_attributes in
+  let lbl_attributes l = l.Types.lbl_attributes in
+  let mtd_attributes t = t.Types.mtd_attributes in
+  let md_attributes t = t.Types.md_attributes in
+  let make_candidate ~attrs ~exact name ?loc ?path ty =
+    make_candidate ~get_doc ~prefix_path ~attrs ~exact name ?loc ?path ty in
+  let make_weighted_candidate ?(priority=0) ~attrs ~exact name ?loc ?path ty =
+    (* Just like [make_candidate] but associates some metadata to the candidate.
+       The candidates are later sorted using these metadata.
+
+       The ordering works as follow:
+       - first we compare the priority of the candidates
+       - we compare the cost of unification for both (using Btype.total_changes)
+       - if they are equal, then we compare their "binding time": things
+         introduced more recently will come before older bindings (i.e. we
+         prioritize the local context)
+       - if these are also equal, then we just use classic string ordering on
+         the candidate name. *)
+    let time =
+      try Path.scope (Option.get path)
+      with _ -> 0
+    in
+    let item = make_candidate ~attrs ~exact name ?loc ?path ty in
+    (- priority, - time, name), item
+  in
+  let is_internal name = name = "" || name.[0] = '_' in
+  let items =
+    let snap = Btype.snapshot () in
+    let rec arrow_arity n t =
+      match (Ctype.repr t).Types.desc with
+      | Types.Tarrow (_,_,rhs,_) -> arrow_arity (n + 1) rhs
+      | _ -> n
+    in
+    let rec nth_arrow n t =
+      if n <= 0 then t else
+      match (Ctype.repr t).Types.desc with
+      | Types.Tarrow (_,_,rhs,_) -> nth_arrow (n - 1) rhs
+      | _ -> t
+    in
+    let type_check =
+      (* Defines the priority of a candidate.
+         Priority is 1000 - cost - head_arrows, where:
+         - cost is the number unification variables instantiated to make the types unify
+         - head_arrows is 0 if types unified, or the number of arrows which
+           have been skipped to make them unify (i.e types would unify if the
+           user apply the function to head_arrows arguments).
+         Note that if no type is expected (context was not inferred), 0 will be
+         returned. *)
+      match target_type with
+      | None -> fun _ -> 0
+      | Some ty ->
+        let arity = arrow_arity 0 ty in
+        fun scheme ->
+        let cost =
+          let c = Btype.linked_variables in
+          try
+            let c' = c () in
+            Ctype.unify_var env ty (Ctype.instance scheme);
+            c () - c'
+          with _ ->
+            let arity = arrow_arity (-arity) scheme in
+            if arity > 0 then begin
+              let c' = c () in
+              Btype.backtrack snap;
+              let ty' = Ctype.instance scheme in
+              let ty' = nth_arrow arity ty' in
+              try Ctype.unify_var env ty ty'; arity + c () - c'
+              with _ -> 1000
+            end
+            else 1000
+        in
+        Btype.backtrack snap;
+        1000 - cost
+    in
+    let of_kind = function
+      | `Keywords -> [] (* cannot happen after a dot. *)
+      | `Variants ->
+        let add_variant name param candidates =
+          if not @@ validate `Variant `Variant name then candidates else
+            make_weighted_candidate name ~exact:false ~priority:2 ~attrs:[]
+              (`Variant (name, param))
+            :: candidates
+        in
+        let result = match target_type with
+          | None -> []
+          | Some t -> fold_variant_constructors t ~init:[] ~f:add_variant ~env
+        in
+        let result = match branch with
+          | _ :: (_, Expression {Typedtree. exp_type = t; _}) :: _
+          | (_, Expression {Typedtree. exp_type = t; _}) :: _ ->
+            fold_variant_constructors t ~init:result ~f:add_variant ~env
+          | _ -> result
+        in
+        result
+      | `Values ->
+        let type_check {Types. val_type; _} = type_check val_type in
+        Env.fold_values (fun name path v candidates ->
+          if not (validate `Lident `Value name) then candidates else
+          let priority = if is_internal name then 0 else type_check v in
+          make_weighted_candidate ~exact:(name = prefix) name ~priority ~path
+            ~attrs:(val_attributes v)
+            (`Value v) ~loc:v.Types.val_loc
+          :: candidates
+        ) prefix_path env []
+
+      | `Constructor ->
+        let type_check {Types. cstr_res; _} = type_check cstr_res in
+        let consider_constr constr candidates =
+          let name = constr.Types.cstr_name in
+          if not @@ validate `Lident `Cons name then candidates else
+          let priority = if is_internal name then 0 else type_check constr in
+          make_weighted_candidate ~exact:(name=prefix) name (`Cons constr)
+            ~priority ~attrs:(cstr_attributes constr)
+          :: candidates
+        in
+        let in_scope_candidates =
+          Env.fold_constructors consider_constr prefix_path env []
+        in
+        begin match prefix_path, target_type with
+        | Some _, _
+        | _, None -> in_scope_candidates
+        | None, Some ty ->
+          fold_sumtype_constructors ~env ~init:in_scope_candidates
+            ~f:consider_constr ty
+        end
+
+      | `Types ->
+        Env.fold_types (fun name path decl candidates ->
+          if not @@ validate `Lident `Typ name then candidates else
+          make_weighted_candidate ~exact:(name = prefix) name ~path (`Typ decl)
+            ~loc:decl.Types.type_loc ~attrs:(type_attributes decl)
+          :: candidates
+        ) prefix_path env []
+
+      | `Modules ->
+        Env.fold_modules (fun name path v candidates ->
+          let attrs = md_attributes v in
+          let v = v.Types.md_type in
+          if not @@ validate `Uident `Mod name then candidates else
+            make_weighted_candidate ~exact:(name = prefix) name ~path (`Mod v) ~attrs
+          :: candidates
+        ) prefix_path env []
+
+      | `Modules_type ->
+        Env.fold_modtypes (fun name path v candidates ->
+          if not @@ validate `Uident `Mod name then candidates else
+            make_weighted_candidate ~exact:(name=prefix) name ~path (`ModType v)
+              ~attrs:(mtd_attributes v)
+            :: candidates
+        ) prefix_path env []
+
+      | `Labels ->
+        Env.fold_labels (fun ({Types.lbl_name = name; _} as l) candidates ->
+          if not (validate `Lident `Label name) then candidates else
+            make_weighted_candidate ~exact:(name = prefix) name (`Label l)
+              ~attrs:(lbl_attributes l)
+            :: candidates
+        ) prefix_path env []
+    in
+    let of_kind_group = function
+      | #Query_protocol.Compl.kind as k -> of_kind k
+      | `Group kinds -> List.concat_map ~f:of_kind kinds
+    in
+    try of_kind_group kind
+    with exn ->
+      log ~title:"get_candidates/of_kind"
+        "Failed with exception: %a" Logger.exn exn;
+      []
+  in
+  let items = List.sort items ~cmp:(fun (a,_) (b,_) -> compare a b) in
+  let items = List.rev_map ~f:snd items in
+  items
+
+let gen_values = `Group [`Values; `Constructor]
+
+let default_kinds = [`Variants; gen_values; `Types; `Modules; `Modules_type]
+
+let completion_order = function
+  | `Expression  -> [`Variants; gen_values; `Types; `Modules; `Modules_type]
+  | `Structure   -> [gen_values; `Types; `Modules; `Modules_type]
+  | `Pattern     -> [`Variants; `Constructor; `Modules; `Labels; `Values; `Types; `Modules_type]
+  | `Module      -> [`Modules; `Modules_type; `Types; gen_values]
+  | `Module_type -> [`Modules_type; `Modules; `Types; gen_values]
+  | `Signature   -> [`Types; `Modules; `Modules_type; gen_values]
+  | `Type        -> [`Types; `Modules; `Modules_type; gen_values]
+
+type kinds = [kind | `Group of kind list] list
+
+let complete_methods ~env ~prefix obj =
+  let t = obj.Typedtree.exp_type in
+  let has_prefix (name,_) =
+    String.is_prefixed ~by:prefix name &&
+    (* Prevent identifiers introduced by type checker to leak *)
+    try ignore (String.index name ' ' : int); false
+    with Not_found -> true
+  in
+  let methods = List.filter ~f:has_prefix (methods_of_type env t) in
+  List.map methods ~f:(fun (name,ty) ->
+    let info = `None (* TODO: get documentation. *) in
+    { name; kind = `MethodCall; desc = `Type_scheme ty; info; deprecated = false }
+  )
+
+type is_label =
+  [ `No | `Maybe
+  | `Description of Types.label_description list
+  | `Declaration of Types.type_expr * Types.label_declaration list
+  ]
+
+let complete_prefix ?get_doc ?target_type ?(kinds=[]) ~keywords ~prefix
+    ~is_label config (env,node) branch =
+  Env.with_cmis @@ fun () ->
+  let seen = Hashtbl.create 7 in
+  let uniq n = if Hashtbl.mem seen n
+    then false
+    else (Hashtbl.add seen n (); true)
+  in
+  let make_candidate ~attrs ~exact name ?loc ?path ty =
+    make_candidate ~get_doc ~attrs ~exact name ?loc ?path ty in
+  let find ?prefix_path ~is_label prefix =
+    let valid tag name =
+      let no_leak () =
+        (* Prevent identifiers introduced by type checker
+          and recovery to leak *)
+        List.for_all ~f:(fun by -> not (String.is_prefixed ~by name))
+          ["self-"; "selfpat-"; "*type-"]
+      in
+      String.is_prefixed ~by:prefix name
+      && uniq (tag,name)
+      && no_leak ()
+    in
+    (* Hack to prevent extensions namespace to leak
+       + another to hide the "Library_name__Module" present at Jane Street *)
+    let validate ident tag name =
+      (if ident = `Uident
+       then name <> "" && name.[0] <> '_'
+            && (String.no_double_underscore name || tag <> `Mod)
+       else name <> "_")
+      && valid tag name
+    in
+    let add_label_description ({Types.lbl_name = name; _} as l) candidates =
+      if not (valid `Label name) then candidates else
+        make_candidate ~prefix_path ~exact:(name = prefix) name
+          (`Label l) ~attrs:[]
+        :: candidates
+    in
+    let add_label_declaration ty ({Types.ld_id = name; _} as l) candidates =
+      let name = Ident.name name in
+      if not (valid `Label name) then candidates else
+        make_candidate ~prefix_path ~exact:(name = prefix) name
+          (`Label_decl (ty,l)) ~attrs:[]
+        :: candidates
+    in
+    let base_completion = match (is_label : is_label) with
+      | `No -> []
+      | `Maybe ->
+        Env.fold_labels add_label_description prefix_path env []
+      | `Description lbls ->
+        List.fold_right ~f:add_label_description lbls ~init:[]
+      | `Declaration (ty,decls) ->
+        List.fold_right ~f:(add_label_declaration ty) decls ~init:[]
+    in
+    if base_completion = [] then
+      let order =
+        if kinds = [] then
+          let kind = classify_node node in
+          completion_order kind
+        else
+          (kinds : kind list :> kinds)
+      in
+      let add_completions acc kind =
+        get_candidates
+          ?get_doc ?target_type ?prefix_path ~prefix kind ~validate env branch
+        :: acc
+      in
+      List.fold_left ~f:add_completions order ~init:[]
+      |> List.concat
+    else base_completion
+  in
+  try
+    match prefix with
+    | Longident.Ldot (prefix_path, prefix) -> find ~prefix_path ~is_label prefix
+    | Longident.Lident prefix ->
+      (* Regular completion *)
+      let compl = find ~is_label prefix in
+      (* Keywords completion *)
+      let compl =
+        if not (List.mem `Keywords ~set:kinds) then
+          compl
+        else
+          List.fold_left keywords ~init:compl ~f:(fun candidates name ->
+            if String.is_prefixed ~by:prefix name then
+              { name; kind = `Keyword; desc = `None; info = `None
+              ; deprecated = false }
+              :: candidates
+            else
+              candidates
+          )
+      in
+      (* Add modules on path but not loaded *)
+      List.fold_left (Mconfig.global_modules config) ~init:compl ~f:(
+        fun candidates name ->
+          if not (String.no_double_underscore name) then candidates else
+          let default =
+            { name; kind = `Module; desc = `None; info = `None; deprecated = false } in
+          if name = prefix && uniq (`Mod, name) then
+            try
+              let path, md, attrs = Type_utils.lookup_module (Longident.Lident name) env in
+              make_candidate ~prefix_path:(Some prefix) ~exact:true ~path name
+                 (`Mod md) ~attrs
+              :: candidates
+            with Not_found ->
+              default :: candidates
+          else if String.is_prefixed ~by:prefix name && uniq (`Mod,name) then
+            default :: candidates
+          else
+            candidates
+      )
+    | _ -> find ~is_label (String.concat ~sep:"." @@ Longident.flatten prefix)
+  with Not_found -> []
+
+(* Propose completion from a particular node *)
+let branch_complete buffer ?get_doc ?target_type ?kinds ~keywords prefix =
+  function
+  | [] -> []
+  | (env, node) :: branch ->
+    match node with
+    | Method_call (obj,_,_) -> complete_methods ~env ~prefix obj
+    | Pattern    { Typedtree.pat_desc = Typedtree.Tpat_record _ ; pat_type = t ; _ }
+    | Expression { Typedtree.exp_desc = Typedtree.Texp_record _ ; exp_type = t ; _ } ->
+      let is_label =
+        try match t.Types.desc with
+          | Types.Tconstr (p, _, _) ->
+            (match (Env.find_type p env).Types.type_kind with
+             | Types.Type_record (labels, _) ->
+               `Declaration (t, labels)
+             | _ -> `Maybe)
+          | _ -> `Maybe
+        with _ -> `Maybe
+      in
+      let prefix, _is_label = Longident.(keep_suffix @@ parse prefix) in
+      complete_prefix ?get_doc ?target_type ?kinds ~keywords ~prefix ~is_label
+        buffer (env,node) branch
+    | Record_field (parent, lbl, _) ->
+      let prefix, _is_label = Longident.(keep_suffix @@ parse prefix) in
+      let snap = Btype.snapshot () in
+      let is_label = match lbl.Types.lbl_all with
+        | [||] ->
+          begin match
+              let ty = match parent with
+                | `Expression e -> e.Typedtree.exp_type
+                | `Pattern p -> p.Typedtree.pat_type
+              in
+              let p, _, decl = Ctype.extract_concrete_typedecl env ty in
+              (ty, p, decl)
+            with
+            | exception _ -> `Maybe
+            | (ty, p, decl) ->
+              try
+                let lbls = Datarepr.labels_of_type p decl in
+                let labels = List.map lbls ~f:(fun (_,lbl) ->
+                    try
+                      let _, lbl_arg, lbl_res = Ctype.instance_label false lbl in
+                      begin try
+                          Ctype.unify_var env ty lbl_res;
+                        with _ -> ()
+                      end;
+                      (* FIXME: the two subst can lose some sharing between types *)
+                      let lbl_res = Subst.type_expr Subst.identity lbl_res in
+                      let lbl_arg = Subst.type_expr Subst.identity lbl_arg in
+                      {lbl with Types. lbl_res; lbl_arg}
+                    with _ -> lbl
+                  ) in
+                `Description labels
+              with _ ->
+              match decl.Types.type_kind with
+              | Types.Type_record (lbls, _) ->
+                `Declaration (ty, lbls)
+              | _ -> `Maybe
+          end
+        | lbls ->
+          `Description (Array.to_list lbls)
+      in
+      let result =
+        complete_prefix ?get_doc ?target_type ?kinds ~keywords ~prefix ~is_label
+          buffer (env, node) branch
+      in
+      Btype.backtrack snap;
+      result
+    | _ ->
+      let prefix, is_label = Longident.(keep_suffix @@ parse prefix) in
+      complete_prefix ?get_doc ?target_type ?kinds ~keywords ~prefix buffer
+        ~is_label:(if is_label then `Maybe else `No)
+        (env, node) branch
+
+let expand_prefix ~global_modules ?(kinds=[]) env prefix =
+  Env.with_cmis @@ fun () ->
+  let lidents, last =
+    let ts = Expansion.explore ~global_modules env in
+    Expansion.get_lidents ts prefix
+  in
+  let validate' =
+    let last = Expansion.spell_index last in
+    fun s -> Expansion.spell_match last s
+  in
+  let validate _ _ s = validate' s in
+  let kinds = match kinds with
+    | [] -> default_kinds
+    | kinds -> (kinds : kind list :> kinds)
+  in
+  let process_prefix_path prefix_path =
+    let candidates =
+      let aux compl kind =
+        get_candidates ?prefix_path ~prefix:"" kind ~validate env [] :: compl in
+      List.fold_left ~f:aux kinds ~init:[]
+    in
+    match prefix_path with
+    | None ->
+      let f name =
+        if not (validate' name) then None else
+          Some (item_for_global_module name)
+      in
+      candidates @ [List.filter_map global_modules ~f]
+      |> List.flatten
+    | Some lident ->
+      let lident = Longident.flatten lident in
+      let lident = String.concat ~sep:"." lident ^ "." in
+      List.concat_map candidates ~f:(List.map ~f:(fun c ->
+          { c with name = lident ^ parenthesize_name c.name }))
+  in
+  List.concat_map ~f:process_prefix_path lidents
+
+open Typedtree
+
+let labels_of_application ~prefix = function
+  | {exp_desc = Texp_apply (f, args); exp_env; _} ->
+    let rec labels t =
+      let t = Ctype.repr t in
+      match t.Types.desc with
+      | Types.Tarrow (label, lhs, rhs, _) ->
+        (label, lhs) :: labels rhs
+      | _ ->
+        let t' = Ctype.full_expand ~may_forget_scope:true exp_env t in
+        if Types.TypeOps.equal t t' then
+          []
+        else
+          labels t'
+    in
+    let labels = labels f.exp_type in
+    let is_application_of label (label',expr) =
+      match expr with
+      | Some {exp_loc = {Location. loc_ghost; loc_start; loc_end}; _} ->
+        label = label'
+        && (Btype.prefixed_label_name label <> prefix)
+        && not loc_ghost
+        && not (loc_start = loc_end)
+      | None -> false
+    in
+    List.filter_map ~f:(fun (label, ty) ->
+        match label with
+        | Asttypes.Nolabel -> None
+        | label when List.exists ~f:(is_application_of label) args -> None
+        | Asttypes.Labelled str -> Some ("~" ^ str, ty)
+        | Asttypes.Optional str ->
+          let ty = match (Ctype.repr ty).Types.desc with
+            | Types.Tconstr (path, [ty], _)
+              when Path.same path Predef.path_option -> ty
+            | _ -> ty
+          in
+          Some ("?" ^ str, ty)
+      ) labels
+  | _ -> []
+
+
+let application_context ~prefix path =
+  let module Printtyp = Type_utils.Printtyp in
+  let target_type = ref (
+      match snd (List.hd path) with
+      | Expression { exp_type = ty ; _ }
+      | Pattern    { pat_type = ty ; _ } -> Some ty
+      | _ -> None
+    )
+  in
+  let context = match path with
+    | (_, Expression earg) ::
+      (_, Expression ({ exp_desc = Texp_apply (efun, _); _ } as app)) :: _
+      when earg != efun ->
+      (* Type variables shared across arguments should all be
+         printed with the same name.
+         [Printtyp.type_scheme] ensure that a name is unique within a given
+         type, but not across different invocations.
+         [reset] followed by calls to [mark_loops] and [type_sch] provide
+         that *)
+      Printtyp.reset ();
+      let pr t =
+        let ppf, to_string = Format.to_string () in
+        Printtyp.mark_loops t;
+        Printtyp.type_sch ppf t;
+        to_string ()
+      in
+      (* Special case for optional arguments applied with ~,
+         get the argument wrapped inside Some _ *)
+      let earg =
+        match Mbrowse.optional_label_sugar earg.exp_desc with
+        | None -> earg
+        | Some earg ->
+          target_type := Some earg.exp_type;
+          earg
+      in
+      let labels = labels_of_application ~prefix app in
+      `Application { argument_type = pr earg.exp_type;
+                     labels = List.map ~f:(fun (lbl,ty) -> lbl, pr ty) labels;
+                   }
+    | _ -> `Unknown
+  in
+  !target_type, context
diff --git a/src/analysis/completion.mli b/src/analysis/completion.mli
new file mode 100644
index 0000000..5d3df35
--- /dev/null
+++ b/src/analysis/completion.mli
@@ -0,0 +1,72 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Query_protocol
+
+(* TODO: document all the following functions *)
+
+type raw_info =
+  [ `Constructor of Types.constructor_description
+  | `Modtype of Types.module_type
+  | `Modtype_declaration of Ident.t * Types.modtype_declaration
+  | `None
+  | `String of string
+  | `Type_declaration of Ident.t * Types.type_declaration
+  | `Type_scheme of Types.type_expr
+  | `Variant of string * Types.type_expr option
+  ]
+
+val raw_info_printer : raw_info ->
+  [ `String of string
+  | `Print of Extend_protocol.Reader.outcometree
+  | `Concat of string * Extend_protocol.Reader.outcometree
+  ]
+
+val map_entry : ('a -> 'b) ->
+  'a Compl.raw_entry -> 'b Compl.raw_entry
+
+val branch_complete
+  :  Mconfig.t
+  -> ?get_doc:([> `Completion_entry of [> `Type | `Vals ] * Path.t * Location.t ]
+               -> [> `Found of string ])
+  -> ?target_type:Types.type_expr
+  -> ?kinds:Compl.kind list
+  -> keywords:string list
+  -> string
+  -> Mbrowse.t
+  -> raw_info Compl.raw_entry list
+
+val expand_prefix
+  : global_modules:string list
+  -> ?kinds:Compl.kind list
+  -> Env.t -> string
+  -> raw_info Compl.raw_entry list
+
+val application_context : prefix:Asttypes.label -> Mbrowse.t ->
+  Types.type_expr option *
+  [> `Application of Compl.application_context | `Unknown ]
diff --git a/src/analysis/construct.ml b/src/analysis/construct.ml
new file mode 100644
index 0000000..8cc0eb1
--- /dev/null
+++ b/src/analysis/construct.ml
@@ -0,0 +1,549 @@
+open Std
+open Typedtree
+
+let {Logger. log} = Logger.for_section "construct"
+
+type values_scope = Null | Local
+type what = Modtype | Mod
+
+exception Not_allowed of string
+exception Not_a_hole
+exception Modtype_not_found of what * string
+exception No_constraint
+
+let () =
+  Location.register_error_of_exn (function
+    | Not_a_hole ->
+      Some (Location.error "Construct only works on holes.")
+    | Modtype_not_found (Modtype, s) ->
+      let txt = Format.sprintf "Module type not found: %s" s in
+      Some (Location.error txt)
+    | Modtype_not_found (Mod, s) ->
+      let txt = Format.sprintf "Module not found: %s" s in
+      Some (Location.error txt)
+    | No_constraint ->
+      Some (Location.error
+        "Could not find a module type to construct from. \
+        Check that you used a correct constraint.")
+    | _ -> None
+  )
+module Util = struct
+  open Destruct.Path_utils
+  open Types
+
+  let predef_types =
+    let tbl = Hashtbl.create 14 in
+    let () =
+      let constant c =
+        Ast_helper.Exp.constant c
+      in
+      let construct s =
+        Ast_helper.Exp.construct (Location.mknoloc (Longident.Lident s)) None
+      in
+      let ident s =
+        Ast_helper.Exp.ident (Location.mknoloc (Longident.Lident s))
+      in
+      List.iter ~f:(fun (k, v) -> Hashtbl.add tbl k v)
+        Parsetree.[
+          Predef.path_int, constant (Pconst_integer("0", None)) ;
+          Predef.path_float, constant (Pconst_float("0.0", None)) ;
+          Predef.path_char, constant (Pconst_char 'c') ;
+          Predef.path_string,
+            constant (Pconst_string("", Location.none, None)) ;
+          Predef.path_bool, construct "true" ;
+          Predef.path_unit, construct "()" ;
+          Predef.path_exn, ident "exn" ;
+          Predef.path_array, Ast_helper.Exp.array [] ;
+          Predef.path_nativeint, constant (Pconst_integer("0", Some 'n')) ;
+          Predef.path_int32, constant (Pconst_integer("0", Some 'l')) ;
+          Predef.path_int64, constant (Pconst_integer("0", Some 'L')) ;
+          Predef.path_lazy_t, Ast_helper.Exp.lazy_ (construct "()")
+        ]
+    in
+    tbl
+
+  let prefix env ~env_check path name =
+    to_shortest_lid ~env ~env_check ~name path
+
+  let var_of_id id = Location.mknoloc @@ Ident.name id
+
+  let type_to_string t =
+    Printtyp.type_expr (Format.str_formatter) t;
+    Format.flush_str_formatter ()
+
+  let unifiable env type_expr type_expected =
+    let snap = Btype.snapshot () in
+    try
+      Ctype.unify env type_expected type_expr |> ignore;
+      Some snap
+    with Ctype.Unify _  ->
+      (* Unification failure *)
+      Btype.backtrack snap;
+      None
+
+  let is_in_stdlib path =
+    Path.head path |> Ident.name = "Stdlib"
+
+  (** [find_values_for_type env typ] searches the environment [env] for
+  {i values} with a return type compatible with [typ] *)
+  let find_values_for_type env typ =
+    let aux name path value_description acc =
+      (* [check_type| checks return type compatibility and lists parameters *)
+      let rec check_type type_expr params =
+        let type_expr = Btype.repr type_expr in
+        (* TODO is this test general enough ? *)
+        match unifiable env type_expr typ with
+        | Some snap ->
+          (* This will be called multiple times so we need to backtrack
+              See c-simple, test 6.2b for an example *)
+          Btype.backtrack snap;
+          Some params
+        | None ->
+          begin match type_expr.desc with
+          | Tarrow (arg_label, _, te, _) -> check_type te (arg_label::params)
+          | _ -> None
+      end
+      in
+      (* TODO we should probably sort the results better *)
+      match is_in_stdlib path, check_type value_description.val_type [] with
+      | false, Some params ->
+        Path.Map.add path (name, value_description, params) acc
+      | _, _ -> acc
+    in
+    (* We look for values in the current scope and in local unonpend submodules.
+      We also exclude the Stdlib modules from the search. *)
+    let fold_values path acc = Env.fold_values aux path env acc in
+    let init = fold_values None Path.Map.empty in
+    Env.fold_modules (fun _name path _module_decl acc ->
+      if not (is_in_stdlib path) && not (is_opened env path) then
+        (* We ignore opened modules. That means that is a value of an opened
+          module has been shadowed we won't suggest the one in the opened
+          module. *)
+        fold_values (Some (Untypeast.lident_of_path path)) acc
+      else acc) None env init
+
+
+  (** The idents_table is used to keep track of already used names when
+  generating function arguments in the same expression *)
+  let idents_table ~keywords =
+    let table = Hashtbl.create 50 in
+    (* We add keywords to the table so they are always numbered *)
+    List.iter keywords ~f:(fun k -> Hashtbl.add table k (-1));
+    table
+
+  (* Given a list [l] of n elements which are lists of choices,
+    [combination l] is a list of all possible combinations of
+    these choices (cartesian product). For example:
+
+    let l = [["a";"b"];["1";"2"]; ["x"]];;
+    combinations l;;
+    - : string list list =
+    [["a"; "1"; "x"]; ["b"; "1"; "x"];
+     ["a"; "2"; "x"]; ["b"; "2"; "x"]]
+
+    If the input is the empty list, the result is
+    the empty list singleton list.
+    *)
+  let combinations l =
+    List.fold_left l
+      ~init:[[]]
+      ~f:(fun acc_l choices_for_arg_i ->
+        List.fold_left choices_for_arg_i
+          ~init:[]
+          ~f:(fun acc choice_arg_i ->
+            let choices = List.map acc_l
+              ~f:(fun l -> List.rev (choice_arg_i :: l))
+            in
+            List.rev_append acc choices))
+
+  (** [panache2 l1 l2] returns a new list containing an interleaving of the
+  values in [l1] and [l2] *)
+  let panache2 l1 l2 =
+    let rec aux acc l1 l2 =
+      match l1, l2 with
+      | [], [] -> List.rev acc
+      | tl, [] | [], tl -> List.rev_append acc tl
+      | a::tl1, b::tl2 -> aux (a::b::acc) tl1 tl2
+  in aux [] l1 l2
+
+  (* Given a list [l] of n lists, [panache l] flattens the list
+    by starting with the first element of each, then the second one etc. *)
+  let panache l =
+    List.fold_left ~init:[] ~f:panache2 l
+end
+
+module Gen = struct
+  open Types
+
+  (* [make_value] generates the PAST repr of a value applied to holes *)
+  let make_value env (path, (name, _value_description, params)) =
+    let open Ast_helper in
+    let env_check = Env.find_value_by_name in
+    let lid = Location.mknoloc (Util.prefix env ~env_check path name) in
+    let params = List.map params
+      ~f:(fun label -> label, Exp.hole ())
+    in
+    if List.length params > 0 then
+      Exp.(apply (ident lid) params)
+    else Exp.ident lid
+
+  (* We never perform deep search when constructing modules *)
+  let rec module_ env =
+    let open Ast_helper in function
+    | Mty_ident path -> begin
+      try
+        let m = Env.find_modtype path env in
+        match m.mtd_type with
+        | Some t -> module_ env t
+        | None -> raise Not_found
+      with Not_found ->
+        let name = Ident.name (Path.head path) in
+        raise (Modtype_not_found (Modtype, name))
+      end
+    | Mty_signature sig_items ->
+      let env = Env.add_signature sig_items env in
+      Mod.structure @@ structure env sig_items
+    | Mty_functor (param, out) ->
+      let param = match param with
+        | Unit -> Parsetree.Unit
+        | Named (id, in_) ->
+          Parsetree.Named (
+            Location.mknoloc (Option.map ~f:Ident.name id),
+            Ptyp_of_type.module_type in_)
+      in
+      Mod.functor_ param @@ module_ env out
+    | Mty_alias path ->
+      begin try let m = Env.find_module path env in
+        module_ env m.md_type
+        with Not_found ->
+          let name = Ident.name (Path.head path) in
+          raise (Modtype_not_found (Mod, name))
+      end
+    | Mty_for_hole -> Mod.hole ()
+  and structure_item env =
+    let open Ast_helper in
+    function
+    | Sig_value (id, _vd, _visibility) ->
+      let vb = Vb.mk (Pat.var (Util.var_of_id id)) (Exp.hole ()) in
+      Str.value Nonrecursive [ vb ]
+    | Sig_type (id, type_declaration, rec_flag, _visibility) ->
+      let td = Ptyp_of_type.type_declaration id type_declaration in
+      let rec_flag = match rec_flag with
+        | Trec_first | Trec_next -> Asttypes.Recursive
+        | Trec_not -> Nonrecursive
+      in (* mutually recursive types are really handled by [structure] *)
+      Str.type_ rec_flag [td]
+    | Sig_modtype (id, { mtd_type; _ }, _visibility) ->
+      let mtd = Ast_helper.Mtd.mk
+        ?typ:(Option.map ~f:Ptyp_of_type.module_type mtd_type)
+        @@ Util.var_of_id id
+      in
+      Ast_helper.Str.modtype mtd
+    | Sig_module (id, _, mod_decl, _, _) ->
+      let module_binding =
+        Ast_helper.Mb.mk
+          (Location.mknoloc (Some (Ident.name id)))
+          @@ module_ env mod_decl.md_type
+      in
+      Str.module_ module_binding
+    | Sig_typext (id, ext_constructor, _, _) ->
+      let lid =
+        Untypeast.lident_of_path ext_constructor.ext_type_path
+        |> Location.mknoloc
+      in
+      Str.type_extension @@ Ast_helper.Te.mk
+        ~attrs:ext_constructor.ext_attributes
+        ~params:[]
+        ~priv:ext_constructor.ext_private
+        lid
+        [Ptyp_of_type.extension_constructor id ext_constructor]
+    | Sig_class_type (id, _class_type_decl, _, _) ->
+      let str = Format.asprintf "Construct does not handle class types yet. \
+      Please replace this comment by [%s]'s definition." (Ident.name id) in
+      Str.text [ Docstrings.docstring str Location.none ] |> List.hd
+    | Sig_class (id, _class_decl, _, _) ->
+      let str = Format.asprintf "Construct does not handle classes yet. \
+      Please replace this comment by [%s]'s definition." (Ident.name id) in
+      Str.text [ Docstrings.docstring str Location.none ] |> List.hd
+  and structure env (items : Types.signature_item list) =
+    List.map (Ptyp_of_type.group_items items) ~f:(function
+      | Ptyp_of_type.Item item -> structure_item env item
+      | Ptyp_of_type.Type (rec_flag, type_decls) ->
+        Ast_helper.Str.type_ rec_flag type_decls)
+
+  (* [expression values_scope ~depth env ty] generates a list of PAST
+    expressions that could fill a hole of type [ty] in the environment [env].
+    [depth] regulates the deep construction of recursive values. If
+    [values_scope] is set to [Local] the returned list will also contains
+    local values to choose from *)
+  let rec expression ~idents_table values_scope ~depth =
+    let exp_or_hole env typ =
+      if depth > 1 then
+        (* If max_depth has not been reached we recurse *)
+        expression ~idents_table values_scope ~depth:(depth - 1) env typ
+      else
+        (* else we return a hole *)
+        [ Ast_helper.Exp.hole () ]
+    in
+    let arrow_rhs env typ =
+      match (Ctype.repr typ).desc with
+      | Tarrow _ -> expression ~idents_table values_scope ~depth env typ
+      | _ -> exp_or_hole env typ
+    in
+
+    (* [make_arg] tries to provide a nice default name for function args *)
+    let make_arg =
+      let make_i n i =
+        Hashtbl.replace idents_table n i;
+        Printf.sprintf "%s_%i" n i
+      in
+      let uniq_name env n =
+        let id = Ident.create_local n in
+        try
+          let i = Hashtbl.find idents_table n + 1 in
+          make_i n i
+        with Not_found ->
+          try
+            let _ = Env.find_value (Path.Pident id) env in
+            make_i n 0
+          with Not_found -> Hashtbl.add idents_table n 0; n
+      in
+      fun env label ty ->
+        let open Asttypes in
+        match label with
+        | Labelled s | Optional s ->
+            (* Pun for labelled arguments *)
+            Ast_helper.Pat.var ( Location.mknoloc s), s
+        | Nolabel -> begin match ty.desc with
+          | Tconstr (path, _, _) ->
+            let name = uniq_name env (Path.last path) in
+            Ast_helper.Pat.var (Location.mknoloc name), name
+          | _ -> Ast_helper.Pat.any (), "_" end
+    in
+
+    let constructor env type_expr path constrs =
+      log ~title:"constructors" "[%s]"
+        (String.concat ~sep:"; "
+          (List.map constrs ~f:(fun c -> c.Types.cstr_name)));
+      (* [make_constr] builds the PAST repr of a type constructor applied
+      to holes *)
+      let make_constr env path type_expr cstr_descr =
+        let ty_args, ty_res, _ = Ctype.instance_constructor cstr_descr in
+        match Util.unifiable env type_expr ty_res with
+        | Some snap ->
+          let lid =
+            Util.prefix env ~env_check:Env.find_constructor_by_name
+              path cstr_descr.cstr_name
+            |> Location.mknoloc
+          in
+          let args = List.map ty_args ~f:(exp_or_hole env) in
+          let args_combinations = Util.combinations args in
+          let exps = List.map args_combinations
+            ~f:(function
+              | [] -> None
+              | [e] -> Some e
+              | l -> Some (Ast_helper.Exp.tuple l))
+          in
+          Btype.backtrack snap;
+          List.filter_map exps
+            ~f:(fun exp ->
+              let exp = Ast_helper.Exp.construct lid exp in
+              (* For gadts not all combinations will be valid.
+                See Test 6.1b in c-simple.t for an example.
+
+                We therefore check that constructed expressions
+                can be typed. *)
+              try
+                Typecore.type_expression env exp |> ignore;
+                Some exp
+              with _ -> None)
+        | None -> []
+      in
+      List.map constrs ~f:(make_constr env path type_expr)
+      |> Util.panache
+    in
+
+    let variant env _typ row_desc =
+      let fields =
+        List.filter
+          ~f:(fun (_lbl, row_field) -> match row_field with
+            | Rpresent _
+            | Reither (true, [], _, _)
+            | Reither (false, [_], _, _) -> true
+            | _ -> false)
+          row_desc.row_fields
+      in
+      match fields with
+      | [] -> raise (Not_allowed "empty variant type")
+      | row_descrs ->
+        List.map row_descrs ~f:(fun (lbl, row_field) ->
+          (match row_field with
+            | Reither (false, [ty], _, _) | Rpresent (Some ty) ->
+              List.map ~f:(fun s -> Some s) (exp_or_hole env ty)
+            | _ -> [None])
+            |> List.map ~f:(fun e ->
+              Ast_helper.Exp.variant lbl e)
+            )
+        |> List.flatten
+    in
+
+    let record env typ path labels =
+      log ~title:"record labels" "[%s]"
+        (String.concat ~sep:"; "
+          (List.map labels ~f:(fun l -> l.Types.lbl_name)));
+
+      let labels = List.map labels ~f:(fun ({ lbl_name; _ } as lbl) ->
+        let _, arg, res = Ctype.instance_label true lbl in
+        Ctype.unify env res typ ;
+        let lid =
+          Util.prefix env ~env_check:Env.find_label_by_name path lbl_name
+          |> Location.mknoloc
+        in
+        let exprs = exp_or_hole env arg in
+        lid, exprs)
+      in
+
+      let lbl_lids, lbl_exprs = List.split labels in
+      Util.combinations lbl_exprs
+      |> List.map
+          ~f:(fun lbl_exprs ->
+            let labels = List.map2 lbl_lids lbl_exprs
+              ~f:(fun lid exp -> (lid, exp))
+            in
+            Ast_helper.Exp.record labels None)
+    in
+
+    (* Given a typed hole, there is two possible forms of constructions:
+      - Use the type's definition to propose the correct type constructors,
+      - Look for values in the environment with compatible return type. *)
+    fun env typ ->
+      log ~title:"construct expr" "Looking for expressions of type %s"
+        (Util.type_to_string typ);
+      let rtyp =
+        Ctype.full_expand ~may_forget_scope:true env typ |> Btype.repr
+      in
+      let constructed_from_type = match rtyp.desc with
+        | Tlink _ | Tsubst _ ->
+          assert false
+        | Tpoly (texp, _)  ->
+          (* We are not going "deeper" so we don't call [exp_or_hole] here *)
+          expression ~idents_table values_scope ~depth env texp
+        | Tunivar _ | Tvar _ ->
+          [ ]
+        | Tconstr (path, [texp], _) when path = Predef.path_lazy_t ->
+          (* Special case for lazy *)
+          let exps = exp_or_hole env texp in
+          List.map exps ~f:Ast_helper.Exp.lazy_
+        | Tconstr (path, _params, _) ->
+          (* If this is a "basic" type we propose a default value *)
+          begin try
+            [ Hashtbl.find Util.predef_types path ]
+          with Not_found ->
+            let def = Env.find_type_descrs path env in
+            match def with
+            | Type_variant (constrs, _) -> constructor env rtyp path constrs
+            | Type_record (labels, _) -> record env rtyp path labels
+            | Type_abstract | Type_open -> []
+          end
+        | Tarrow (label, tyleft, tyright, _) ->
+          let argument, name = make_arg env label tyleft in
+          let value_description = {
+              val_type = tyleft;
+              val_kind = Val_reg;
+              val_loc = Location.none;
+              val_attributes = [];
+              val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+            }
+          in
+          let env = Env.add_value (Ident.create_local name) value_description env in
+          let exps = arrow_rhs env tyright in
+          List.map exps ~f:(Ast_helper.Exp.fun_ label None argument)
+        | Ttuple types ->
+          let choices = List.map types ~f:(exp_or_hole env)
+            |> Util.combinations
+          in
+          List.map choices  ~f:Ast_helper.Exp.tuple
+        | Tvariant row_desc -> variant env rtyp row_desc
+        | Tpackage (path, lids_args) -> begin
+          let open Ast_helper in
+          try
+            let ty =
+              Typemod.modtype_of_package env Location.none path lids_args
+            in
+            let ast =
+              Exp.constraint_
+                (Exp.pack (module_ env ty))
+                (Ptyp_of_type.core_type typ)
+            in
+            [ ast ]
+          with Typemod.Error _ ->
+            let name = Ident.name (Path.head path) in
+            raise (Modtype_not_found (Modtype, name)) end
+        | Tobject (fields, _) ->
+          let rec aux acc fields =
+            match fields.desc with
+            | Tnil -> acc
+            | Tvar _ | Tunivar _ -> acc
+            | Tfield ("*dummy method*", _, _, fields) -> aux acc fields
+            | Tfield (name, _, type_expr, fields) ->
+              let exprs = exp_or_hole env type_expr
+                |> List.map ~f:(fun expr ->
+                  let open Ast_helper in
+                  Cf.method_ (Location.mknoloc name) Asttypes.Public
+                  @@ Ast_helper.Cf.concrete Asttypes.Fresh expr)
+              in
+              aux (exprs :: acc) fields
+            | _ ->
+              failwith @@ Format.asprintf
+                "Unexpected type constructor in fields list: %a"
+                Printtyp.type_expr fields
+          in
+          let all_fields = aux [] fields |> Util.combinations in
+          List.map all_fields ~f:(fun fields ->
+            let open Ast_helper in
+            Exp.object_ @@ Ast_helper.Cstr.mk (Pat.any ()) fields)
+        | Tfield _ | Tnil -> failwith "Found a field type outside an object"
+      in
+      let matching_values =
+        if values_scope = Local then
+          Path.Map.bindings (Util.find_values_for_type env typ)
+          |> List.map ~f:(make_value env)
+        else []
+      in
+      List.append constructed_from_type matching_values
+end
+
+let needs_parentheses e = match e.Parsetree.pexp_desc with
+  | Pexp_fun _
+  | Pexp_lazy _
+  | Pexp_apply _
+  | Pexp_variant (_, Some _)
+  | Pexp_construct (_, Some _)
+  -> true
+  | _ -> false
+
+let to_string_with_parentheses exp =
+  let f : _ format6 =
+    if needs_parentheses exp then "(%a)"
+    else "%a"
+  in
+  Format.asprintf f Pprintast.expression exp
+
+let node ?(depth = 1) ~keywords ~values_scope node =
+  match node with
+  | Browse_raw.Expression { exp_type; exp_env; _ } ->
+      let idents_table = Util.idents_table ~keywords in
+      Gen.expression ~idents_table values_scope ~depth exp_env exp_type
+      |> List.map ~f:to_string_with_parentheses
+  | Browse_raw.Module_expr
+      { mod_desc = Tmod_constraint _ ; mod_type; mod_env; _ }
+  | Browse_raw.Module_expr
+      {  mod_desc = Tmod_apply _; mod_type; mod_env; _ } ->
+      let m = Gen.module_ mod_env mod_type in
+      [ Format.asprintf "%a" Pprintast.module_expr m ]
+  | Browse_raw.Module_expr _
+  | Browse_raw.Module_binding _ ->
+      (* Constructible modules have an explicit constraint or are functor
+        applications. In other cases we do not know what to construct.  *)
+      raise No_constraint
+  | _ -> raise Not_a_hole
diff --git a/src/analysis/construct.mli b/src/analysis/construct.mli
new file mode 100644
index 0000000..b0442f1
--- /dev/null
+++ b/src/analysis/construct.mli
@@ -0,0 +1,11 @@
+exception Not_allowed of string
+exception Not_a_hole
+
+type values_scope = Null | Local
+
+val node
+  : ?depth : int
+  -> keywords : string list
+  -> values_scope : values_scope
+  -> Browse_raw.node
+  -> string list
diff --git a/src/analysis/context.ml b/src/analysis/context.ml
new file mode 100644
index 0000000..dcd625c
--- /dev/null
+++ b/src/analysis/context.ml
@@ -0,0 +1,158 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+
+let {Logger. log} = Logger.for_section "context"
+
+type t =
+  | Constructor of Types.constructor_description * Location.t
+    (* We attach the constructor description here so in the case of
+      disambiguated constructors we actually directly look for the type
+      path (cf. #486, #794). *)
+  | Expr
+  | Label of Types.label_description (* Similar to constructors. *)
+  | Module_path
+  | Module_type
+  | Patt
+  | Type
+  | Constant
+  | Unknown
+
+let to_string = function
+  | Constructor (cd, _) -> Printf.sprintf "constructor %s" cd.cstr_name
+  | Expr -> "expression"
+  | Label lbl -> Printf.sprintf "record field %s" lbl.lbl_name
+  | Module_path -> "module path"
+  | Module_type -> "module type"
+  | Patt -> "pattern"
+  | Constant -> "constant"
+  | Type -> "type"
+  | Unknown -> "unknown"
+
+(* Distinguish between "Mo[d]ule.something" and "Module.some[t]hing" *)
+let cursor_on_longident_end
+    ~cursor:cursor_pos
+    ~lid_loc:{ Asttypes.loc; txt = lid }
+    name
+  =
+  match lid with
+  | Longident.Lident _ -> true
+  | _ ->
+    let end_offset = loc.loc_end.pos_cnum in
+    let cstr_name_size = String.length name in
+    let constr_pos =
+      { loc.loc_end
+        with pos_cnum = end_offset - cstr_name_size }
+    in
+    Lexing.compare_pos cursor_pos constr_pos >= 0
+
+let inspect_pattern (type a) ~cursor ~lid (p : a Typedtree.general_pattern) =
+  log ~title:"inspect_context" "%a" Logger.fmt
+    (fun fmt -> Format.fprintf fmt "current pattern is: %a"
+                  (Printtyped.pattern 0) p);
+  match p.pat_desc with
+  | Tpat_any when Longident.last lid = "_" -> None
+  | Tpat_var (_, str_loc) when (Longident.last lid) = str_loc.txt ->
+    None
+  | Tpat_alias (_, _, str_loc)
+    when (Longident.last lid) = str_loc.txt ->
+    (* Assumption: if [Browse.enclosing] stopped on this node and not on the
+      subpattern, then it must mean that the cursor is on the alias. *)
+    None
+  | Tpat_construct (lid_loc, cd, _, _)
+    when cursor_on_longident_end ~cursor ~lid_loc cd.cstr_name
+        && (Longident.last lid) = (Longident.last lid_loc.txt) ->
+    (* Assumption: if [Browse.enclosing] stopped on this node and not on the
+       subpattern, then it must mean that the cursor is on the constructor
+       itself.  *)
+    Some (Constructor (cd, lid_loc.loc))
+  | Tpat_construct _ -> Some Module_path
+  | _ ->
+    Some Patt
+
+let inspect_expression ~cursor ~lid e : t =
+  match e.Typedtree.exp_desc with
+  | Texp_construct (lid_loc, cd, _) ->
+    (* TODO: is this first test necessary ? *)
+    if (Longident.last lid) = (Longident.last lid_loc.txt) then
+      if cursor_on_longident_end ~cursor ~lid_loc cd.cstr_name then
+        Constructor (cd, lid_loc.loc)
+      else Module_path
+    else Module_path
+  | Texp_ident (p, lid_loc, _) ->
+    let name = Path.last p in
+    if name = "*type-error*" then
+      (* For type_enclosing: it is enough to return Module_path here.
+         - If the cursor was on the end of the lid typing should fail anyway
+         - If the cursor is on a segment of the path it should be typed ad a
+         Module_path
+         TODO: double check that this is correct-enough behavior for Locate *)
+      Module_path
+    else if cursor_on_longident_end ~cursor ~lid_loc name then
+      Expr
+    else
+      Module_path
+  | Texp_constant _ -> Constant
+  | _ ->
+    Expr
+
+let inspect_browse_tree ~cursor lid browse : t option =
+  log ~title:"inspect_context" "current node is: [%s]"
+    (String.concat ~sep:"|" (
+      List.map ~f:(Mbrowse.print ()) browse
+    ));
+  match Mbrowse.enclosing cursor browse with
+  | [] ->
+    log ~title:"inspect_context"
+      "no enclosing around: %a" Lexing.print_position cursor;
+    Some Unknown
+  | enclosings ->
+    let open Browse_raw in
+    let node = Browse_tree.of_browse enclosings in
+    log ~title:"inspect_context" "current enclosing node is: %s"
+      (string_of_node node.Browse_tree.t_node);
+    match node.Browse_tree.t_node with
+    | Pattern p -> inspect_pattern ~cursor ~lid p
+    | Value_description _
+    | Type_declaration _
+    | Extension_constructor _
+    | Module_binding_name _
+    | Module_declaration_name _ ->
+      None
+    | Module_expr _
+    | Open_description _ -> Some Module_path
+    | Module_type _ -> Some Module_type
+    | Core_type _ -> Some Type
+    | Record_field (_, lbl, _) when (Longident.last lid) = lbl.lbl_name ->
+      (* if we stopped here, then we're on the label itself, and whether or
+          not punning is happening is not important *)
+      Some (Label lbl)
+    | Expression e -> Some (inspect_expression ~cursor ~lid e)
+    | _ ->
+      Some Unknown
diff --git a/src/analysis/context.mli b/src/analysis/context.mli
new file mode 100644
index 0000000..6884f8d
--- /dev/null
+++ b/src/analysis/context.mli
@@ -0,0 +1,58 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+type t =
+  | Constructor of Types.constructor_description * Location.t
+    (* We attach the constructor description here so in the case of
+      disambiguated constructors we actually directly look for the type
+      path (cf. #486, #794). *)
+  | Expr
+  | Label of Types.label_description (* Similar to constructors. *)
+  | Module_path
+  | Module_type
+  | Patt
+  | Type
+  | Constant
+  | Unknown
+
+val to_string : t -> string
+
+(**
+  [inspect_browse_tree lid ~cursor mbrowse] tries to provide contextual
+  information given the selected identifier, the position of the cursor and the
+  typed tree. It is used by Locate and Type_enclosing.
+
+  The cursor position is used to distinguished whether a module path or an actual
+  constructor name is pointed at when the cursor is in the middle of a
+  longident, e.g. [Foo.B|ar.Constructor] (with | being the cursor).
+
+  FIXME: when cursor at (M.|A 3), the enclosing node returned is const 3, thus
+  breaking the context inference.
+*)
+val inspect_browse_tree :
+  cursor:Std.Lexing.position -> Longident.t -> Mbrowse.t list -> t option
diff --git a/src/analysis/destruct.ml b/src/analysis/destruct.ml
new file mode 100644
index 0000000..12cf05b
--- /dev/null
+++ b/src/analysis/destruct.ml
@@ -0,0 +1,658 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+open Browse_raw
+
+exception Not_allowed of string
+exception Useless_refine
+exception Nothing_to_do
+exception Ill_typed
+exception Wrong_parent of string
+
+let {Logger. log} = Logger.for_section "destruct"
+
+let () =
+  Location.register_error_of_exn (function
+    | Not_allowed s  -> Some (Location.error ("Destruct not allowed on " ^ s))
+    | Useless_refine -> Some (Location.error "Cannot refine an useless branch")
+    | Nothing_to_do  -> Some (Location.error "Nothing to do")
+    | Ill_typed  -> Some (
+        Location.error "The node on which destruct was called is ill-typed"
+      )
+    | _ -> None
+  )
+
+module Path_utils : sig
+  val is_opened : Env.t -> Path.t -> bool
+
+  val to_shortest_lid :
+    env:Env.t ->
+    ?name:string ->
+    env_check:(Longident.t -> Env.t -> 'a) -> Path.t -> Longident.t
+end = struct
+  let opens env =
+    let rec aux acc = function
+      | Env.Env_open (s, path) -> aux (path::acc) s
+      | s ->
+        Option.map ~f:(aux acc) (Browse_misc.summary_prev s)
+        |> Option.value ~default:acc
+    in
+    aux [] env
+
+  let is_opened env path = List.mem path ~set:(opens (Env.summary env))
+
+  let rec to_shortest_lid ~(opens : Path.t list) = function
+    | Path.Pdot (path, name) when List.exists ~f:(Path.same path) opens ->
+      Longident.Lident name
+    | Path.Pdot (path, name) -> Ldot (to_shortest_lid ~opens path, name)
+    | Pident ident -> Lident (Ident.name ident)
+    | _ -> assert false
+
+  let maybe_replace_name ?name lid =
+    let open Longident in
+    Option.value_map name
+      ~default:lid
+      ~f:(fun name -> match lid with
+        | Lident _ -> Lident name
+        | Ldot (lid, _) -> Ldot (lid, name)
+        | _ -> assert false)
+
+  let to_shortest_lid ~env ?name ~env_check path =
+    let opens = opens (Env.summary env) in
+    let lid =
+      to_shortest_lid ~opens path
+      |> maybe_replace_name ?name
+    in
+    try
+      env_check lid env |> ignore;
+      lid
+    with Not_found ->
+      maybe_replace_name ?name (Untypeast.lident_of_path path)
+end
+
+let mk_id s  = Location.mknoloc (Longident.Lident s)
+let mk_var s = Location.mknoloc s
+
+module Predef_types = struct
+  let char_ env ty =
+    let a = Tast_helper.Pat.constant env ty (Asttypes.Const_char 'a') in
+    let z = Patterns.omega in
+    [ a ; z ]
+
+  let int_ env ty =
+    let zero = Tast_helper.Pat.constant env ty (Asttypes.Const_int 0) in
+    let n = Patterns.omega in
+    [ zero ; n ]
+
+  let string_ env ty =
+    let empty =
+      Tast_helper.Pat.constant env ty (
+        Asttypes.Const_string ("", Location.none, None)
+      )
+    in
+    let s = Patterns.omega in
+    [ empty ; s ]
+
+  let tbl = Hashtbl.create 3
+
+  let () =
+    List.iter ~f:(fun (k, v) -> Hashtbl.add tbl k v) [
+      Predef.path_char, char_ ;
+      Predef.path_int, int_ ;
+      Predef.path_string, string_ ;
+    ]
+end
+
+let placeholder =
+  Ast_helper.Exp.hole ()
+
+let rec gen_patterns ?(recurse=true) env type_expr =
+  let open Types in
+  let type_expr = Btype.repr type_expr in
+  match type_expr.desc with
+  | Tlink _    -> assert false (* impossible after [Btype.repr] *)
+  | Tvar _     -> raise (Not_allowed "non-immediate type")
+  | Tarrow _   -> raise (Not_allowed "arrow type")
+  | Tobject _  -> raise (Not_allowed "object type")
+  | Tpackage _ -> raise (Not_allowed "modules")
+  | Ttuple lst ->
+    let patterns = Patterns.omega_list lst in
+    [ Tast_helper.Pat.tuple env type_expr patterns ]
+  | Tconstr (path, _params, _) ->
+    begin match Env.find_type_descrs path env with
+    | Type_record (labels, _) ->
+      let lst =
+        List.map labels ~f:(fun lbl_descr ->
+          let lidloc = mk_id lbl_descr.lbl_name in
+          lidloc, lbl_descr,
+          Tast_helper.Pat.var env type_expr (mk_var lbl_descr.lbl_name)
+        )
+      in
+      [ Tast_helper.Pat.record env type_expr lst Asttypes.Closed ]
+    | Type_variant (constructors, _) ->
+      let prefix =
+        let path = Printtyp.shorten_type_path env path in
+        fun name ->
+          let env_check = Env.find_constructor_by_name in
+          Path_utils.to_shortest_lid ~env ~name ~env_check path
+      in
+      let are_types_unifiable typ =
+        let snap = Btype.snapshot () in
+        let res =
+          try
+            ignore (
+              Ctype.unify_gadt ~equations_level:0
+                ~allow_recursive:true (* really? *)
+                (ref env) type_expr typ
+            );
+            true
+          with Ctype.Unify _trace -> false
+        in
+        Btype.backtrack snap ;
+        res
+      in
+      List.filter_map constructors ~f:(fun cstr_descr ->
+        if cstr_descr.cstr_generalized &&
+           not (are_types_unifiable cstr_descr.cstr_res)
+        then (
+          log ~title:"gen_patterns" "%a"
+            Logger.fmt (fun fmt ->
+              Format.fprintf fmt
+                "Eliminating '%s' branch, its return type is not\
+                \ compatible with the expected type (%a)"
+                cstr_descr.cstr_name Printtyp.type_expr type_expr);
+          None
+        ) else
+          let args =
+            if cstr_descr.cstr_arity <= 0 then [] else
+              Patterns.omegas cstr_descr.cstr_arity
+          in
+          let lidl = Location.mknoloc (prefix cstr_descr.cstr_name) in
+          Some (
+            Tast_helper.Pat.construct env type_expr lidl cstr_descr args None)
+      )
+    | _ ->
+      if recurse then from_type_decl env path type_expr else
+      raise (Not_allowed (sprintf "non-destructible type: %s" (Path.last path)))
+    end
+  | Tvariant row_desc ->
+    List.filter_map row_desc.row_fields ~f:(function
+      | lbl, Rpresent param_opt ->
+        let popt = Option.map param_opt ~f:(fun _ -> Patterns.omega) in
+        Some (Tast_helper.Pat.variant env type_expr lbl popt (ref row_desc))
+      | _, _ -> None
+    )
+  | _ ->
+    let fmt, to_string = Format.to_string () in
+    Printtyp.type_expr fmt type_expr ;
+    raise (Not_allowed (to_string ()))
+
+and from_type_decl env path texpr =
+  let tdecl = Env.find_type path env in
+  match tdecl.Types.type_manifest with
+  | Some te -> gen_patterns ~recurse:false env te
+  | None ->
+    try Hashtbl.find Predef_types.tbl path env texpr
+    with Not_found ->
+      raise (Not_allowed (sprintf "non-destructible type: %s" (Path.last path)))
+
+
+let rec needs_parentheses = function
+  | [] -> false
+  | t :: ts ->
+    match t with
+    | Structure _
+    | Structure_item _
+    | Value_binding _ -> false
+    | Expression e ->
+      begin match e.Typedtree.exp_desc with
+      | Texp_for _
+      | Texp_while _ -> false
+      | Texp_let _
+        (* We are after the "in" keyword, we need to look at the parent of the
+           binding. *)
+      | Texp_function {cases = [ _ ]; _ }
+        (* The assumption here is that we're not in a [function ... | ...]
+            situation but either in [fun param] or [let name param]. *)
+        ->
+        needs_parentheses ts
+      | _ -> true
+      end
+    | _ -> needs_parentheses ts
+
+let rec get_match = function
+| [] -> assert false
+| parent :: parents ->
+  match parent with
+  | Case _
+  | Pattern _ ->
+    (* We are still in the same branch, going up. *)
+    get_match parents
+  | Expression m ->
+    (match m.Typedtree.exp_desc with
+    | Typedtree.Texp_match (e, _, _) -> m, e.exp_type
+    | Typedtree.Texp_function _ ->
+      let typ = Ctype.repr m.exp_type in
+        (* Function must have arrow type. This arrow type
+           might be hidden behind type constructors *)
+        m, (match typ.desc with
+        | Tarrow (_, te, _, _) -> te
+        | Tconstr _ ->
+          (match (Ctype.full_expand ~may_forget_scope:true m.exp_env typ
+            |> Ctype.repr).desc with
+          | Tarrow (_, te, _, _) -> te
+          | _ -> assert false)
+        | _ -> assert false)
+    | _ ->
+      (* We were not in a match *)
+      let s = Mbrowse.print_node () parent in
+      raise  (Not_allowed s))
+  | _ ->
+    (* We were not in a match *)
+    let s = Mbrowse.print_node () parent in
+    raise  (Not_allowed s)
+
+let rec get_every_pattern = function
+  | [] -> assert false
+  | parent :: parents ->
+    match parent with
+    | Case _
+    | Pattern _ ->
+      (* We are still in the same branch, going up. *)
+      get_every_pattern parents
+    | Expression { exp_desc = Typedtree.Texp_ident (Path.Pident id, _, _) ; _}
+      when Ident.name id = "*type-error*" ->
+      raise (Ill_typed)
+    | Expression _ ->
+      (* We are on the right node *)
+      let patterns : Typedtree.pattern list =
+        Mbrowse.fold_node (fun env node acc ->
+            match node with
+            | Pattern _ -> (* Not expected here *) assert false
+            | Case _ ->
+              Mbrowse.fold_node (fun _env node acc ->
+                  match node with
+                  | Pattern p ->
+                    let ill_typed_pred : Typedtree.pattern_predicate =
+                      { f = fun p ->
+                            List.memq Msupport.incorrect_attribute
+                            ~set:p.pat_attributes }
+                    in
+                    if Typedtree.exists_general_pattern ill_typed_pred p then
+                      raise Ill_typed;
+                    begin match Typedtree.classify_pattern p with
+                      | Value -> let p : Typedtree.pattern = p in p :: acc
+                      | Computation -> let val_p, _ = Typedtree.split_pattern p in
+                        (* We ignore computation patterns *)
+                        begin match val_p with
+                          | Some val_p ->  val_p :: acc
+                          | None -> acc
+                        end
+                    end
+                  | _ -> acc
+                ) env node acc
+            | _ -> acc
+          ) Env.empty parent []
+      in
+      let loc =
+        Mbrowse.fold_node (fun _ node acc ->
+            let open Location in
+            let loc = Mbrowse.node_loc node in
+            if Lexing.compare_pos loc.loc_end acc.loc_end > 0 then loc else acc
+          ) Env.empty parent Location.none
+      in
+      loc, patterns
+    | _ ->
+      (* We were not in a match *)
+      let s = Mbrowse.print_node () parent in
+      raise  (Not_allowed s)
+
+let rec destructible patt =
+  let open Typedtree in
+  match patt.pat_desc with
+  | Tpat_any | Tpat_var _ -> true
+  | Tpat_alias (p, _, _)  -> destructible p
+  | _ -> false
+
+
+let is_package ty =
+  match ty.Types.desc with
+  | Types.Tpackage _ -> true
+  | _ -> false
+
+let filter_attr =
+  let default = Ast_mapper.default_mapper in
+  let keep attr =
+    let ({Location.txt;_},_) = Ast_helper.Attr.as_tuple attr in
+    not (String.is_prefixed ~by:"merlin." txt)
+  in
+  let attributes mapper attrs =
+    default.Ast_mapper.attributes mapper (List.filter ~f:keep attrs)
+  in
+  {default with Ast_mapper.attributes}
+
+let filter_expr_attr expr =
+  filter_attr.Ast_mapper.expr filter_attr expr
+
+let filter_pat_attr pat =
+  filter_attr.Ast_mapper.pat filter_attr pat
+
+let rec subst_patt initial ~by patt =
+  let f = subst_patt initial ~by in
+  if patt == initial then by else
+  let open Typedtree in
+  match patt.pat_desc with
+  | Tpat_any
+  | Tpat_var _
+  | Tpat_constant _ -> patt
+  | Tpat_alias (p,x,y) ->
+    { patt with pat_desc = Tpat_alias (f p, x, y) }
+  | Tpat_tuple lst ->
+    { patt with pat_desc = Tpat_tuple (List.map lst ~f) }
+  | Tpat_construct (lid, cd, lst, lco) ->
+    { patt with pat_desc = Tpat_construct (lid, cd, List.map lst ~f, lco) }
+  | Tpat_variant (lbl, pat_opt, row_desc) ->
+    { patt with pat_desc = Tpat_variant (lbl, Option.map pat_opt ~f, row_desc) }
+  | Tpat_record (sub, flg) ->
+    let sub' =
+      List.map sub ~f:(fun (lid, lbl_descr, patt) -> lid, lbl_descr, f patt)
+    in
+    { patt with pat_desc = Tpat_record (sub', flg) }
+  | Tpat_array lst ->
+    { patt with pat_desc = Tpat_array (List.map lst ~f) }
+  | Tpat_or (p1, p2, row) ->
+    { patt with pat_desc = Tpat_or (f p1, f p2, row) }
+  | Tpat_lazy p ->
+    { patt with pat_desc = Tpat_lazy (f p) }
+
+let rec rm_sub patt sub =
+  let f p = rm_sub p sub in
+  let open Typedtree in
+  match patt.pat_desc with
+  | Tpat_any
+  | Tpat_var _
+  | Tpat_constant _ -> patt
+  | Tpat_alias (p,x,y) ->
+    { patt with pat_desc = Tpat_alias (f p, x, y)  }
+  | Tpat_tuple lst ->
+    { patt with pat_desc = Tpat_tuple (List.map lst ~f) }
+  | Tpat_construct (lid, cd, lst, lco) ->
+    { patt with pat_desc = Tpat_construct (lid, cd, List.map lst ~f, lco) }
+  | Tpat_variant (lbl, pat_opt, row_desc) ->
+    { patt with pat_desc = Tpat_variant (lbl, Option.map pat_opt ~f, row_desc) }
+  | Tpat_record (sub, flg) ->
+    let sub' =
+      List.map sub ~f:(fun (lid, lbl_descr, patt) -> lid, lbl_descr, f patt)
+    in
+    { patt with pat_desc = Tpat_record (sub', flg) }
+  | Tpat_array lst ->
+    { patt with pat_desc = Tpat_array (List.map lst ~f) }
+  | Tpat_or (p1, p2, row) ->
+    if p1 == sub then p2 else if p2 == sub then p1 else
+      { patt with pat_desc = Tpat_or (f p1, f p2, row) }
+  | Tpat_lazy p ->
+    { patt with pat_desc = Tpat_lazy (f p) }
+
+let rec qualify_constructors ~unmangling_tables f pat  =
+  let open Typedtree in
+  let qualify_constructors = qualify_constructors ~unmangling_tables in
+  let pat_desc =
+    match pat.pat_desc with
+    | Tpat_alias (p, id, loc) -> Tpat_alias (qualify_constructors f p, id, loc)
+    | Tpat_tuple ps -> Tpat_tuple (List.map ps ~f:(qualify_constructors f))
+    | Tpat_record (labels, closed) ->
+      let labels =
+        let open Longident in
+        List.map labels
+          ~f:(fun ((Location.{ txt ; _ } as lid), lbl_des, pat) ->
+            let lid_name = flatten txt |> String.concat ~sep:"." in
+            let pat = qualify_constructors f pat in
+            (* Un-mangle *)
+            match unmangling_tables with
+            | Some (_, labels) ->
+              (match Hashtbl.find_opt labels lid_name with
+              | Some lbl_des -> (
+                  { lid with txt = Lident lbl_des.Types.lbl_name },
+                  lbl_des,
+                  pat
+                )
+              | None -> (lid, lbl_des, pat))
+            | None -> (lid, lbl_des, pat))
+      in
+      let closed =
+        if List.length labels > 0 then
+          let _, lbl_des, _ = List.hd labels in
+          if List.length labels = Array.length lbl_des.Types.lbl_all then
+            Asttypes.Closed
+          else Asttypes.Open
+        else closed
+      in
+      Tpat_record (labels, closed)
+    | Tpat_construct (lid, cstr_desc, ps, lco) ->
+      let lid =
+        match lid.Asttypes.txt with
+        | Longident.Lident name ->
+          (* Un-mangle *)
+          let name = match unmangling_tables with
+            | Some (constrs, _) ->
+              (match  Hashtbl.find_opt constrs name with
+              | Some cstr_des -> cstr_des.Types.cstr_name
+              | None -> name)
+            | None -> name
+          in
+          begin match (Btype.repr pat.pat_type).Types.desc with
+          | Types.Tconstr (path, _, _) ->
+            let path = f pat.pat_env path in
+            let env_check = Env.find_constructor_by_name in
+            let txt = Path_utils.to_shortest_lid ~env:pat.pat_env ~name ~env_check path in
+            { lid with Asttypes.txt }
+          | _ -> lid
+          end
+        | _ -> lid (* already qualified *)
+      in
+      Tpat_construct
+        (lid, cstr_desc, List.map ps ~f:(qualify_constructors f), lco)
+    | Tpat_array ps -> Tpat_array (List.map ps ~f:(qualify_constructors f))
+    | Tpat_or (p1, p2, row_desc) ->
+      Tpat_or (qualify_constructors f p1, qualify_constructors f p2, row_desc)
+    | Tpat_lazy p -> Tpat_lazy (qualify_constructors f p)
+    | desc -> desc
+  in
+  { pat with pat_desc = pat_desc }
+
+let find_branch patterns sub =
+  let rec is_sub_patt patt ~sub =
+    if patt == sub then true else
+      let open Typedtree in
+      match patt.pat_desc with
+      | Tpat_any
+      | Tpat_var _
+      | Tpat_constant _
+      | Tpat_variant (_, None, _) -> false
+      | Tpat_alias (p,_,_)
+      | Tpat_variant (_, Some p, _)
+      | Tpat_lazy p ->
+        is_sub_patt p ~sub
+      | Tpat_tuple lst
+      | Tpat_construct (_, _, lst, _)
+      | Tpat_array lst ->
+        List.exists lst ~f:(is_sub_patt ~sub)
+      | Tpat_record (subs, _) ->
+        List.exists subs ~f:(fun (_, _, p) -> is_sub_patt p ~sub)
+      | Tpat_or (p1, p2, _) ->
+        is_sub_patt p1 ~sub || is_sub_patt p2 ~sub
+  in
+  let rec aux before = function
+    | [] -> raise Not_found
+    | p :: after when is_sub_patt p ~sub -> before, after, p
+    | p :: ps -> aux (p :: before) ps
+  in
+  aux [] patterns
+
+let rec node config source selected_node parents =
+  let open Extend_protocol.Reader in
+  let loc = Mbrowse.node_loc selected_node in
+  match selected_node with
+  | Record_field (`Expression _, _, _) ->
+    begin match parents with
+    | Expression { exp_desc = Texp_field _; _ } as parent :: rest ->
+      node config source parent rest
+    | Expression e :: rest ->
+      node config source (Expression e) rest
+    | _ ->
+      raise (Not_allowed (string_of_node selected_node))
+    end
+  | Expression expr ->
+    let ty = expr.Typedtree.exp_type in
+    let pexp = filter_expr_attr (Untypeast.untype_expression expr) in
+    log ~title:"node_expression" "%a"
+      Logger.fmt (fun fmt -> Printast.expression 0 fmt pexp);
+    let needs_parentheses, result =
+      if is_package ty then (
+        let mode = Ast_helper.Mod.unpack pexp in
+        false, Ast_helper.Exp.letmodule_no_opt "M" mode placeholder
+      ) else (
+        let ps = gen_patterns expr.Typedtree.exp_env ty in
+        let cases  =
+          List.map ps ~f:(fun patt ->
+            let pc_lhs = filter_pat_attr (Untypeast.untype_pattern patt) in
+            { Parsetree. pc_lhs ; pc_guard = None ; pc_rhs = placeholder }
+          )
+        in
+        needs_parentheses parents, Ast_helper.Exp.match_ pexp cases
+      )
+    in
+    let str = Mreader.print_pretty
+        config source (Pretty_expression result) in
+    let str = if needs_parentheses then "(" ^ str ^ ")" else str in
+    loc, str
+  | Pattern patt ->
+    begin let last_case_loc, patterns = get_every_pattern parents in
+      (* Printf.eprintf "tot %d o%!"(List.length patterns); *)
+      List.iter patterns ~f:(fun p ->
+        let p = filter_pat_attr (Untypeast.untype_pattern p) in
+        log ~title:"EXISTING" "%t"
+          (fun () -> Mreader.print_pretty config source (Pretty_pattern p))
+      ) ;
+      let pss = List.map patterns ~f:(fun x -> [ x ]) in
+      let m, e_typ = get_match parents in
+      let pred = Typecore.partial_pred
+        ~lev:Btype.generic_level
+        m.Typedtree.exp_env
+        e_typ
+      in
+      begin match Parmatch.complete_partial ~pred pss with
+      | _ :: _ as patterns ->
+        let cases =
+          List.map patterns ~f:(fun (pat, unmangling_tables) ->
+            (* Unmangling and prefixing *)
+            let pat =
+              qualify_constructors ~unmangling_tables
+                Printtyp.shorten_type_path pat
+            in
+
+            (* Untyping and casing *)
+            let ppat = filter_pat_attr (Untypeast.untype_pattern pat) in
+            Ast_helper.Exp.case ppat placeholder
+          )
+        in
+        let loc =
+          let open Location in
+          { last_case_loc with loc_start = last_case_loc.loc_end }
+        in
+
+        (* Pretty printing *)
+        let str = Mreader.print_pretty config source (Pretty_case_list cases) in
+        loc, str
+      | [] ->
+        begin match Typedtree.classify_pattern patt with
+        | Computation -> raise (Not_allowed ("computation pattern"));
+        | Value ->
+          let _patt : Typedtree.value Typedtree.general_pattern = patt in
+          if not (destructible patt) then raise Nothing_to_do else
+            let ty = patt.Typedtree.pat_type in
+            (* Printf.eprintf "pouet cp \n%!" ; *)
+            begin match gen_patterns patt.Typedtree.pat_env ty with
+            | [] -> assert false (* we raise Not_allowed, but never return [] *)
+            | [ more_precise ] ->
+              (* Printf.eprintf "one cp \n%!" ; *)
+              (* If only one pattern is generated, then we're only refining the
+                current pattern, not generating new branches. *)
+              let ppat = filter_pat_attr (Untypeast.untype_pattern more_precise) in
+              let str = Mreader.print_pretty
+                  config source (Pretty_pattern ppat) in
+              patt.Typedtree.pat_loc, str
+            | sub_patterns ->
+              let rev_before, after, top_patt =
+                find_branch patterns patt
+              in
+              let new_branches =
+                List.map sub_patterns ~f:(fun by ->
+                  subst_patt patt ~by top_patt
+                )
+              in
+              let patterns =
+                List.rev_append rev_before
+                  (List.append new_branches after)
+              in
+              let unused = Parmatch.return_unused patterns in
+              let new_branches =
+                List.fold_left unused ~init:new_branches ~f:(fun branches u ->
+                  match u with
+                  | `Unused p -> List.remove ~phys:true p branches
+                  | `Unused_subs (p, lst) ->
+                    List.map branches ~f:(fun branch ->
+                      if branch != p then branch else
+                      List.fold_left lst ~init:branch ~f:rm_sub
+                    )
+                )
+              in
+              (* List.iter ~f:(Format.eprintf "multi cp %a \n%!" (Printtyped.pattern 0)) new_branches ; *)
+              match new_branches with
+              | [] -> raise Useless_refine
+              | p :: ps ->
+                let p =
+                  List.fold_left ps ~init:p ~f:(fun acc p ->
+                    Tast_helper.Pat.pat_or top_patt.Typedtree.pat_env
+                      top_patt.Typedtree.pat_type acc p
+                  )
+                in
+                (* Format.eprintf "por %a \n%!" (Printtyped.pattern 0) p; *)
+                let ppat = filter_pat_attr (Untypeast.untype_pattern p) in
+                (* Format.eprintf "ppor %a \n%!" (Pprintast.pattern) ppat; *)
+                let str = Mreader.print_pretty
+                    config source (Pretty_pattern ppat) in
+                (* Format.eprintf "STR: %s \n %!" str; *)
+                top_patt.Typedtree.pat_loc, str
+            end
+        end
+      end
+    end
+  | node ->
+    raise (Not_allowed (string_of_node node))
diff --git a/src/analysis/destruct.mli b/src/analysis/destruct.mli
new file mode 100644
index 0000000..5c2e479
--- /dev/null
+++ b/src/analysis/destruct.mli
@@ -0,0 +1,107 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+(** Destruct at the moment works in two contexts:
+
+      - an expression context:
+          It will replace the expression [e] under the cursor with
+
+          {[
+            match e with
+            | p1 -> _
+            | ...
+          ]}
+
+          This matching will be exhaustive.
+
+          If [e] has a "package" type, it will be replaced by
+          [let module M = (val e) in _]
+
+      - a pattern context:
+          Here two different behaviors can be observed:
+          + if your matching is not exhaustive, it will be made exhaustive.
+          + if your matching is exhaustive, it will refine the subpattern under
+            the cursor if possible (i.e. if your cursor is on a variable or _ ).
+
+
+                                * * *
+
+
+    Final remarks:
+      - Destruct will refuse to work on expression (resp. patterns) with a
+        functional or polymorphic type.
+
+      - Constructors of variant types will be prefixed by their path (if
+        necessary) but record labels will not.
+        The reason is that we don't control the way things are printed, we reuse
+        [Pprintast] which will print things like:
+        [{ Module.label1 = label1 ; Module.label2 = label2}] where one would
+        rather have [{ Module.label1 ; label2 }]. Since qualifying one label is
+        less annoying than rewriting the whole pattern, we decided to note
+        qualify labels (understanding that the code inserted by merlin in the
+        buffer will sometimes be wrong).
+
+*)
+
+(* TODO: document the following *)
+
+exception Not_allowed of string
+exception Useless_refine
+exception Nothing_to_do
+exception Ill_typed
+exception Wrong_parent of string
+
+module Path_utils : sig
+  (** [to_shortest_lid ~env ~env_check path] will make a [Longident.t] from the
+  provided [Path.t] and attempt to use the shortest prefix possible given the
+  currently opened modules. The result is checked by looking it up in the
+  environment using the [env_check : Longident.t -> Env.t -> 'a] function.
+
+  The check is needed because shadowing can cause subtle issues. A typical check
+  function would be [Env.find_constructor_by_name]. WHen the check fails the
+  function will return [Untypeast.lident_of_path path] instead of clever
+  prefix-less constructions.
+
+  Optionally a [name] can be provided that will be used as the last ident of the
+  path. *)
+  val to_shortest_lid :
+    env:Env.t ->
+    ?name:string ->
+    env_check:(Longident.t -> Env.t -> 'a) -> Path.t -> Longident.t
+
+  (* Return whether the given path is opened in the given environment *)
+  val is_opened : Env.t -> Path.t -> bool 
+end
+
+val node :
+  Mconfig.t -> Msource.t -> Browse_raw.node ->
+  Browse_raw.node list -> Location.t * string
+(** [node ~env parents current_node] returns a location indicating which
+    portion of the buffer must be replaced and the string to replace it with. *)
+
+val log : 'a Logger.printf
diff --git a/src/analysis/dune b/src/analysis/dune
new file mode 100644
index 0000000..8dbe895
--- /dev/null
+++ b/src/analysis/dune
@@ -0,0 +1,19 @@
+(library
+ (name merlin_analysis)
+ (flags
+  :standard
+  -open Ocaml_utils
+  -open Ocaml_parsing
+  -open Ocaml_typing
+  -open Merlin_utils)
+ (libraries
+  config
+  merlin_specific
+  merlin_extend
+  merlin_kernel
+  merlin_utils
+  ocaml_parsing
+  preprocess
+  query_protocol
+  ocaml_typing
+  ocaml_utils))
diff --git a/src/analysis/expansion.ml b/src/analysis/expansion.ml
new file mode 100644
index 0000000..05b9056
--- /dev/null
+++ b/src/analysis/expansion.ml
@@ -0,0 +1,136 @@
+open Std
+
+type t = Trie of (string * Longident.t * t list lazy_t)
+
+let rec explore_node lident env =
+  let add_module name _ _ l =
+    let lident = Longident.Ldot (lident, name) in
+    Trie (name, lident, lazy (explore_node lident env)) :: l
+  in
+  Env.fold_modules add_module (Some lident) env []
+
+let explore ?(global_modules=[]) env =
+  let seen =
+    let tbl = Hashtbl.create 7 in
+    fun name -> Hashtbl.mem tbl name || (Hashtbl.add tbl name (); false)
+  in
+  let add_module l name =
+    if seen name then l
+    else
+      let lident = Longident.Lident name in
+      Trie (name, lident, lazy (explore_node lident env)) :: l
+  in
+  let add_module' name _ _ l = add_module l name in
+  List.fold_left ~f:add_module global_modules
+    ~init:(Env.fold_modules add_module' None env [])
+
+(* This is a hacked up heuristic spell checking function.
+   It checks only the prefix of the key.
+   A proper damerau-levenshtein might be better but certainly not urgent.
+
+   Implementation is a fork of
+   https://github.com/c-cube/spelll/blob/master/src/spelll.ml
+   Thanks companion-cube :) *)
+let optimal_string_prefix_alignment key cutoff =
+  let equal_char : char -> char -> bool = (=) in
+  let min_int x y : int = if x < y then x else y in
+  if String.length key = 0
+  then (fun str -> String.length str)
+  else
+    (* distance vectors (v0=previous, v1=current) *)
+    let v0 = Array.make (String.length key + 1) 0 in
+    let v1 = Array.make (String.length key + 1) 0 in
+    fun str ->
+      let l1 = min (String.length str) (String.length key) in
+      if l1 = 0 then
+        String.length key
+      else if str = key then
+        0
+      else
+        try
+          (* initialize v0: v0(i) = A(0)(i) = delete i chars from t *)
+          for i = 0 to String.length key do
+            v0.(i) <- i
+          done;
+          (* main loop for the bottom up dynamic algorithm *)
+          for i = 0 to l1 - 1 do
+            (* first edit distance is the deletion of i+1 elements from s *)
+            v1.(0) <- i+1;
+
+            let min = ref (i+1) in
+            (* try add/delete/replace operations *)
+            for j = 0 to String.length key - 1 do
+              let cost = if equal_char str.[i] key.[j] then 0 else 1 in
+              v1.(j+1) <- min_int (v1.(j) + 1) (min_int (v0.(j+1) + 1) (v0.(j) + cost));
+              if i > 0 && j > 0 && str.[i] = key.[j-1] && str.[i-1] = key.[j] then
+                v1.(j+1) <- min_int v1.(j+1) (v0.(j-1) + cost);
+
+              min := min_int !min v1.(j+1)
+            done;
+
+            if !min > cutoff then raise Exit;
+
+            (* copy v1 into v0 for next iteration *)
+            Array.blit v1 0 v0 0 (String.length key + 1);
+          done;
+          let idx = String.length key in
+          min v1.(idx-1) v1.(idx)
+        with Exit -> cutoff + 1
+
+let spell_index s1 =
+  let cutoff = match String.length s1 with
+    | 0 -> 0
+    | 1 -> 0
+    | 2 -> 0
+    | 3 -> 1
+    | _ -> 2
+  in
+  let f = optimal_string_prefix_alignment s1 cutoff in
+  fun s2 -> (s1 = "" || s2 = "" || (s1.[0] = s2.[0] && (f s2 <= cutoff)))
+
+let spell_match index str = index str
+
+let filter path ts =
+  let path = List.map ~f:spell_index path in
+  let rec aux_ts ts = function
+    | [] -> []
+    | p0 :: ps -> List.filter_map ~f:(aux_t p0 ps) ts
+  and aux_t p0 ps (Trie (name, ident, ts)) =
+    if spell_match p0 name then
+      Some (Trie (name, ident, lazy (aux_ts (Lazy.force ts) ps)))
+    else
+      None
+  in
+  aux_ts ts path
+
+let rec to_lidents len acc = function
+  | Trie (_, lident, _) :: ts when len = 0 ->
+    to_lidents len (lident :: acc) ts
+  | Trie (_, _, lazy ts') :: ts ->
+    to_lidents len (to_lidents (len - 1) acc ts') ts
+  | [] -> acc
+
+let to_lidents len ts = to_lidents len [] ts
+
+let get_lidents ts path =
+  let open Longident in
+  let lident = parse path in
+  let lident, last = match lident with
+    | Ldot (l, id) -> l, id
+    | Lident id -> Lident "", id
+    | Lapply _ -> assert false
+  in
+  let rec components acc = function
+    | Lident "" -> acc
+    | Lident id -> id :: acc
+    | Lapply _ -> assert false
+    | Ldot (l, id) -> components (id :: acc) l
+  in
+  let lidents = match components [] lident with
+    | [] -> [None]
+    | components ->
+      let ts = filter components ts in
+      let lidents = to_lidents (List.length components - 1) ts in
+      List.map ~f:(fun x -> Some x) lidents
+  in
+  lidents, last
diff --git a/src/analysis/expansion.mli b/src/analysis/expansion.mli
new file mode 100644
index 0000000..330b843
--- /dev/null
+++ b/src/analysis/expansion.mli
@@ -0,0 +1,9 @@
+type t
+
+val explore : ?global_modules:string list -> Env.t -> t list
+
+val get_lidents : t list -> string -> Longident.t option list * string
+
+val spell_index : string -> string -> bool
+
+val spell_match : (string -> bool) -> string -> bool
diff --git a/src/analysis/jump.ml b/src/analysis/jump.ml
new file mode 100644
index 0000000..18063d0
--- /dev/null
+++ b/src/analysis/jump.ml
@@ -0,0 +1,219 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+                             Tomasz Kołodziejski  <tkolodziejski(_)gmail.com>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+
+open Typedtree
+open Browse_raw
+
+let is_node_fun = function
+  | Expression { exp_desc = Texp_function _; _ } -> true
+  | _ -> false
+;;
+
+let is_node_let = function
+  | Value_binding _ -> true
+  | _ -> false
+;;
+
+let is_node_pattern = function
+  | Case _ -> true
+  | _ -> false
+;;
+
+let fun_pred = fun all ->
+  (* For:
+     `let f x y z = ...` jump to f
+     For
+     `let f = fun x -> fun y -> fun z -> ...` jump to f
+     For
+     `List.map l ~f:(fun x -> ...)` jump to fun
+
+     Every fun is immediately followed by pattern in the typed tree.
+     Invariant: head is a fun.
+  *)
+  let rec normalize_fun = function
+    (* fun pat fun something *)
+    | node1 :: node2 :: node3 :: tail when is_node_fun node3 ->
+      assert (is_node_fun node1);
+      assert (is_node_pattern node2);
+      normalize_fun (node3 :: tail)
+    (* fun let something *)
+    | node1 :: node2 :: _ when is_node_let node2 ->
+      assert (is_node_fun node1);
+      node2
+    | node :: _ ->
+      assert (is_node_fun node);
+      node
+    | _ ->
+      assert false
+  in
+  match all with
+  | node :: _ when is_node_fun node -> Some (normalize_fun all)
+  | _ -> None
+;;
+
+let let_pred = function
+  | node :: _ when is_node_let node -> Some node
+  | _ -> None
+;;
+
+let module_pred = function
+  | (Module_binding _ as node) :: _ -> Some node
+  | _ -> None
+;;
+
+let match_pred = function
+  | (Expression { exp_desc = Texp_match _ ; _ } as node) :: _ -> Some node
+  | _ -> None
+;;
+
+let rec find_map ~f = function
+  | [] -> None
+  | head :: tail ->
+    match f head with
+    | Some v -> Some v
+    | None -> find_map tail ~f
+;;
+
+exception No_matching_target
+exception No_predicate of string
+
+(* Returns first node on the list matching a predicate *)
+let rec find_node preds nodes =
+  match nodes with
+  | [] -> raise No_matching_target
+  | _ :: tail ->
+    match find_map preds ~f:(fun pred -> pred nodes) with
+    | Some node -> node
+    | None -> find_node preds tail
+;;
+
+(* Skip all nodes that won't advance cursor's position *)
+let rec skip_non_moving pos = function
+  | (node :: tail) as all ->
+    let node_loc = Browse_raw.node_real_loc Location.none node in
+    let loc_start = node_loc.Location.loc_start in
+    if pos.Lexing.pos_lnum = loc_start.Lexing.pos_lnum then
+      skip_non_moving pos tail
+    else
+      all
+  | [] -> []
+;;
+
+let get typed_tree pos target =
+  let roots = Mbrowse.of_typedtree typed_tree in
+  let enclosings =
+    match Mbrowse.enclosing pos [roots] with
+    | [] -> []
+    | l -> List.map ~f:snd l
+  in
+
+  let all_preds = [
+    "fun", fun_pred;
+    "let", let_pred;
+    "module", module_pred;
+    "match", match_pred;
+  ] in
+  let targets = Str.split (Str.regexp "[, ]") target in
+  try
+    let preds =
+      List.map targets ~f:(fun target ->
+        match List.find_some all_preds ~f:(fun (name, _) -> name = target) with
+        | Some (_, f) -> f
+        | None -> raise (No_predicate target)
+      )
+    in
+    if String.length target = 0 then
+      `Error "Specify target"
+    else begin
+      let nodes = skip_non_moving pos enclosings in
+      let node = find_node preds nodes in
+      let node_loc = Browse_raw.node_real_loc Location.none node in
+      `Found node_loc.Location.loc_start
+    end
+  with
+  | No_predicate target ->
+    `Error ("No predicate for " ^ target)
+  | No_matching_target ->
+    `Error "No matching target"
+
+let phrase typed_tree pos target =
+  let roots = Mbrowse.of_typedtree typed_tree in
+  (* Select nodes around cursor.
+     If the cursor is around a module expression, also search inside it. *)
+  let enclosing = match Mbrowse.enclosing pos [roots] with
+    | (env, (Browse_raw.Module_expr _ as node)) :: enclosing ->
+      Browse_raw.fold_node (fun env node enclosing -> (env,node) :: enclosing)
+        env node enclosing
+    | enclosing -> enclosing
+  in
+  (* Drop environment, they are of no use here *)
+  let enclosing = List.map ~f:snd enclosing in
+  let find_item x xs = match target with
+    | `Prev -> List.rev (List.take_while ~f:((!=)x) xs)
+    | `Next -> match List.drop_while ~f:((!=)x) xs with _::xs -> xs | [] -> []
+  in
+  let find_pos prj xs =
+    match target with
+    | `Prev ->
+      let f x = Location_aux.compare_pos pos (prj x) > 0 in
+      List.rev (List.take_while ~f xs)
+    | `Next ->
+      let f x = Location_aux.compare_pos pos (prj x) >= 0 in
+      List.drop_while ~f xs
+  in
+  let rec seek_item = function
+    | [] -> None
+    | Browse_raw.Signature xs :: tail ->
+      begin match find_pos (fun x -> x.Typedtree.sig_loc) xs.Typedtree.sig_items with
+        | [] -> seek_item tail
+        | y :: _ -> Some y.Typedtree.sig_loc
+      end
+    | Browse_raw.Structure xs :: tail ->
+      begin match find_pos (fun x -> x.Typedtree.str_loc) xs.Typedtree.str_items with
+        | [] -> seek_item tail
+        | y :: _ -> Some y.Typedtree.str_loc
+      end
+    | Browse_raw.Signature_item (x,_) :: Browse_raw.Signature xs :: tail ->
+      begin match find_item x xs.Typedtree.sig_items with
+        | [] -> seek_item tail
+        | y :: _ -> Some y.Typedtree.sig_loc
+      end
+    | Browse_raw.Structure_item (x,_) :: Browse_raw.Structure xs :: tail ->
+      begin match find_item x xs.Typedtree.str_items with
+        | [] -> seek_item tail
+        | y :: _ -> Some y.Typedtree.str_loc
+      end
+    | _ :: xs -> seek_item xs
+  in
+  match seek_item enclosing, target with
+  | Some loc, _ -> `Logical (Lexing.split_pos loc.Location.loc_start)
+  | None, `Prev -> `Start
+  | None, `Next -> `End
diff --git a/src/analysis/jump.mli b/src/analysis/jump.mli
new file mode 100644
index 0000000..f42a950
--- /dev/null
+++ b/src/analysis/jump.mli
@@ -0,0 +1,38 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+                             Tomasz Kołodziejski  <tkolodziejski(_)gmail.com>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+val get :
+  Mtyper.typedtree ->
+  Std.Lexing.position ->
+  string -> [> `Error of string | `Found of Lexing.position ]
+
+val phrase :
+  Mtyper.typedtree ->
+  Std.Lexing.position ->
+  [< `Next | `Prev ] -> [> `End | `Logical of int * int | `Start ]
diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml
new file mode 100644
index 0000000..877d5df
--- /dev/null
+++ b/src/analysis/locate.ml
@@ -0,0 +1,895 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+
+let loadpath     = ref []
+
+let last_location = ref Location.none
+
+let {Logger. log} = Logger.for_section "locate"
+
+let erase_loadpath ~cwd ~new_path k =
+  let str_path_list =
+    List.map new_path ~f:(function
+      | "" ->
+        (* That's the cwd at the time of the generation of the cmt, I'm
+            guessing/hoping it will be the directory where we found it *)
+        log ~title:"erase_loadpath" "%s" cwd;
+        cwd
+      | x ->
+        log ~title:"erase_loadpath" "%s" x;
+        x
+    )
+  in
+  let_ref loadpath str_path_list k
+
+let restore_loadpath ~config k =
+  log ~title:"restore_loadpath" "Restored load path";
+  let_ref loadpath (Mconfig.cmt_path config) k
+
+module Fallback = struct
+  let fallback = ref None
+
+  let get () = !fallback
+
+  let set loc =
+    log ~title:"Fallback.set"
+      "%a" Logger.fmt (fun fmt -> Location.print_loc fmt loc);
+    fallback := Some loc
+
+  let reset () = fallback := None
+
+  let is_set () = !fallback <> None
+end
+
+module File : sig
+  type t = private
+    | ML   of string
+    | MLL  of string
+    | MLI  of string
+    | CMT  of string
+    | CMTI of string
+
+  val ml : string -> t
+  val mli : string -> t
+  val cmt : string -> t
+  val cmti : string -> t
+
+  val of_filename : string -> t option
+
+  val alternate : t -> t
+
+  val name : t -> string
+
+  val with_ext : ?src_suffix_pair:(string * string) -> t -> string
+
+  val explain_not_found :
+    ?doc_from:string -> string -> t -> [> `File_not_found of string ]
+end = struct
+  type t =
+    | ML   of string
+    | MLL  of string
+    | MLI  of string
+    | CMT  of string
+    | CMTI of string
+
+  let file_path_to_mod_name f =
+    Misc.unitname (Filename.basename f)
+
+  let ml   s = ML   (file_path_to_mod_name s)
+  let mll  s = MLL  (file_path_to_mod_name s)
+  let mli  s = MLI  (file_path_to_mod_name s)
+  let cmt  s = CMT  (file_path_to_mod_name s)
+  let cmti s = CMTI (file_path_to_mod_name s)
+
+  let of_filename fn =
+    match Misc.rev_string_split ~on:'.' fn with
+    | []
+    | [ _ ] -> None
+    | ext :: _ ->
+      let ext = String.lowercase ext in
+      Some (
+        match ext with
+        | "cmti" -> cmti fn
+        | "cmt"  -> cmt fn
+        | "mll"  -> mll fn
+        | _ -> if Filename.check_suffix ext "i" then mli fn else ml fn
+      )
+
+  let alternate = function
+    | ML  s
+    | MLL s -> MLI s
+    | MLI s -> ML s
+    | CMT s  -> CMTI s
+    | CMTI s -> CMT s
+
+  let name = function
+    | ML name
+    | MLL name
+    | MLI name
+    | CMT name
+    | CMTI name -> name
+
+  let ext src_suffix_pair = function
+    | ML _  -> fst src_suffix_pair
+    | MLI _  -> snd src_suffix_pair
+    | MLL _ -> ".mll"
+    | CMT _ -> ".cmt"
+    | CMTI _ -> ".cmti"
+
+  let with_ext ?(src_suffix_pair=(".ml",".mli")) t =
+    name t ^ ext src_suffix_pair t
+
+  let explain_not_found ?(doc_from="") str_ident path =
+    let msg =
+      match path with
+      | ML file ->
+        sprintf "'%s' seems to originate from '%s' whose ML file could not be \
+                 found" str_ident file
+      | MLL file ->
+        sprintf "'%s' seems to originate from '%s' whose MLL file could not be \
+                 found" str_ident file
+      | MLI file ->
+        sprintf "'%s' seems to originate from '%s' whose MLI file could not be \
+                 found" str_ident file
+      | CMT file ->
+        sprintf "Needed cmt file of module '%s' to locate '%s' but it is not \
+                 present" file str_ident
+      | CMTI file when file <> doc_from ->
+        sprintf "Needed cmti file of module '%s' to locate '%s' but it is not \
+                 present" file str_ident
+      | CMTI _ ->
+        sprintf "The documentation for '%s' originates in the current file, \
+                 but no cmt is available" str_ident
+    in
+    `File_not_found msg
+end
+
+module Preferences : sig
+  val set : [ `ML | `MLI ] -> unit
+
+  val src : string -> File.t
+  val build : string -> File.t
+
+  val is_preferred : string -> bool
+end = struct
+  let prioritize_impl = ref true
+
+  let set choice =
+    prioritize_impl :=
+      match choice with
+      | `ML -> true
+      | _ -> false
+
+  let src   file = if !prioritize_impl then File.ml  file else File.mli  file
+  let build file = if !prioritize_impl then File.cmt file else File.cmti file
+
+  let is_preferred fn =
+    match File.of_filename fn with
+    | Some ML _ -> !prioritize_impl
+    | Some MLI _ -> not !prioritize_impl
+    | _ -> false
+end
+
+module File_switching : sig
+  val reset : unit -> unit
+
+  val move_to : digest:Digest.t -> string -> unit
+
+  val where_am_i : unit -> string option
+
+  val source_digest : unit -> Digest.t option
+end = struct
+  type t = {
+    last_file_visited : string;
+    digest : Digest.t;
+  }
+
+  let last_file_visited t = t.last_file_visited
+  let digest t = t.digest
+
+  let state = ref None
+
+  let reset () = state := None
+
+  let move_to ~digest file =
+    log ~title:"File_switching.move_to" "%s" file;
+    state := Some { last_file_visited = file ; digest }
+
+  let where_am_i () = Option.map !state ~f:last_file_visited
+
+  let source_digest () = Option.map !state ~f:digest
+end
+
+
+module Utils = struct
+  let is_builtin_path = function
+    | Path.Pident id ->
+      let f (_, i) = Ident.same i id in
+      List.exists Predef.builtin_idents ~f
+      || List.exists Predef.builtin_values ~f
+    | _ -> false
+
+  let is_ghost_loc { Location. loc_ghost; _ } = loc_ghost
+
+  (* Reuse the code of [Misc.find_in_path_uncap] but returns all the files
+     matching, instead of the first one.
+     This is only used when looking for ml files, not cmts. Indeed for cmts we
+     know that the load path will only ever contain files with uniq names (in
+     the presence of packed modules we refine the loadpath as we go); this in
+     not the case for the "source path" however.
+     We therefore get all matching files and use an heuristic at the call site
+     to choose the appropriate file. *)
+  let find_all_in_path_uncap ?src_suffix_pair ~with_fallback path file =
+    let name = File.with_ext ?src_suffix_pair file in
+    let uname = String.uncapitalize name in
+    let fallback, ufallback =
+      let alt = File.alternate file in
+      let fallback = File.with_ext ?src_suffix_pair alt in
+      fallback, String.uncapitalize fallback
+    in
+    let try_file dirname basename acc =
+      if Misc.exact_file_exists ~dirname ~basename
+      then Misc.canonicalize_filename (Filename.concat dirname basename) :: acc
+      else acc
+    in
+    let try_dir acc dirname =
+      let acc = try_file dirname uname acc in
+      let acc = try_file dirname name acc in
+      let acc =
+        if with_fallback then
+          let acc = try_file dirname ufallback acc in
+          let acc = try_file dirname fallback acc in
+          acc
+        else
+          acc
+      in
+      acc
+    in
+    List.fold_left ~f:try_dir ~init:[] path
+
+  let find_all_matches ~config ?(with_fallback=false) file =
+    let files =
+      List.concat_map ~f:(fun synonym_pair ->
+        find_all_in_path_uncap ~src_suffix_pair:synonym_pair ~with_fallback
+          (Mconfig.source_path config) file
+      ) Mconfig.(config.merlin.suffixes)
+    in
+    List.dedup_adjacent files ~cmp:String.compare
+
+  let find_file_with_path ~config ?(with_fallback=false) file path =
+    if File.name file = Misc.unitname Mconfig.(config.query.filename) then
+      Some Mconfig.(config.query.filename)
+    else
+      let attempt_search src_suffix_pair =
+        let fallback =
+          if with_fallback then
+            Some (File.with_ext ~src_suffix_pair (File.alternate file))
+          else
+            None
+        in
+        let fname = File.with_ext ~src_suffix_pair file in
+        try Some (Misc.find_in_path_uncap ?fallback path fname)
+        with Not_found -> None
+      in
+      try
+        Some (List.find_map Mconfig.(config.merlin.suffixes) ~f:attempt_search)
+      with Not_found ->
+        None
+
+  let find_file ~config ?with_fallback (file : File.t) =
+    find_file_with_path ~config ?with_fallback file @@
+        match file with
+        | ML  _ | MLI _  | MLL _ -> Mconfig.source_path config
+        | CMT _ | CMTI _         -> !loadpath
+end
+
+exception Cmt_cache_store of Typedtrie.t
+
+let move_to_root root cmt_infos =
+  let digest =
+    (* [None] only for packs, and we wouldn't have a trie if the cmt was for a
+       pack. *)
+    let sourcefile_in_builddir =
+      Filename.concat
+        (cmt_infos.Cmt_format.cmt_builddir)
+        (Option.get cmt_infos.cmt_sourcefile)
+    in
+    match sourcefile_in_builddir |> String.split_on_char ~sep:'.' |> List.rev with
+    | ext :: "pp" :: rev_path ->
+      (* If the source file was a post-processed file (.pp.mli?), use the
+         regular .mli? file for locate. *)
+      let sourcefile_in_builddir =
+        (ext :: rev_path) |> List.rev |> String.concat ~sep:"."
+      in
+      (match
+         Misc.exact_file_exists
+           ~dirname:(Filename.dirname sourcefile_in_builddir)
+           ~basename:(Filename.basename sourcefile_in_builddir)
+       with
+       | true -> Digest.file sourcefile_in_builddir
+       | false -> Option.get cmt_infos.cmt_source_digest)
+    | _ -> Option.get cmt_infos.cmt_source_digest
+  in
+  File_switching.move_to ~digest root;
+;;
+
+let trie_of_cmt root =
+  let open Cmt_format in
+  let cached = Cmt_cache.read root in
+  log ~title:"browse_cmts" "inspecting %s" root ;
+  begin match cached.Cmt_cache.location_trie with
+  | Cmt_cache_store _ ->
+    move_to_root root cached.cmt_infos;
+    log ~title:"browse_cmts" "trie already cached"
+  | Not_found ->
+    let trie_of_nodes nodes =
+      move_to_root root cached.cmt_infos;
+      let trie =
+        Typedtrie.of_browses (List.map ~f:Browse_tree.of_node nodes)
+      in
+      cached.location_trie <- Cmt_cache_store trie
+    in
+    Option.iter ~f:trie_of_nodes (
+      match cached.Cmt_cache.cmt_infos.cmt_annots with
+      | Packed (_, _)       -> None
+      | Interface intf      -> Some [Browse_raw.Signature intf]
+      | Implementation impl -> Some [Browse_raw.Structure impl]
+      | Partial_interface parts
+      | Partial_implementation parts ->
+        log ~title:"browse_cmt" "working from partial cmt(i)";
+        let env = cached.cmt_infos.cmt_initial_env in
+        let nodes =
+          Array.to_list parts
+          |> List.map ~f:(Mbrowse.node_of_binary_part env)
+        in
+        Some nodes
+    )
+  | _ -> assert false
+  end;
+  cached.cmt_infos, cached.location_trie
+
+type locate_result =
+  | Found of Location.t * string option
+  | File_not_found of File.t
+  | Other_error (* FIXME *)
+
+let rec locate ~config ~context path trie : locate_result =
+  match Typedtrie.find ~remember_loc:Fallback.set ~context trie path with
+  | Typedtrie.Found (loc, doc_opt) -> Found (loc, doc_opt)
+  | Typedtrie.Resolves_to (new_path, state) ->
+    begin match Namespaced_path.head_exn new_path with
+    | Ident (_, `Mod) ->
+      log ~title:"locate" "resolves to %s" (Namespaced_path.to_unique_string new_path);
+      from_path ~config ~context:(Typedtrie.Resume state) new_path
+    | _ ->
+      log ~title:"locate" "new path (%s) is not a real path"
+        (Namespaced_path.to_unique_string new_path);
+      log ~title:"locate (typedtrie dump)" "%a"
+        Logger.fmt (fun fmt -> Typedtrie.dump fmt trie);
+      Other_error (* incorrect path *)
+    end
+
+and from_path ~config ~context path : locate_result =
+  log ~title:"from_path" "%s" (Namespaced_path.to_unique_string path) ;
+  match Namespaced_path.head_exn path with
+  | Ident (fname, `Mod) ->
+    let path = Namespaced_path.peal_head_exn path in
+    let fname = Namespaced_path.Id.name fname in
+    let file = Preferences.build fname in
+    let browse_cmt cmt_file =
+      let cmt_infos, trie = trie_of_cmt cmt_file in
+      match trie, Namespaced_path.head path with
+      | Not_found, None ->
+        Other_error (* Trying to stop on a packed module... *)
+      | Not_found, Some _ ->
+        log ~title:"from_path" "Saw packed module => erasing loadpath" ;
+        erase_loadpath ~cwd:(Filename.dirname cmt_file)
+          ~new_path:cmt_infos.cmt_loadpath
+          (fun () -> from_path ~context ~config path)
+      | Cmt_cache_store _, None ->
+        (* We found the module we were looking for, we can stop here. *)
+        let pos_fname =
+          match cmt_infos.cmt_sourcefile with
+          | None   -> fname
+          | Some f -> f
+        in
+        let pos = Lexing.make_pos ~pos_fname (1, 0) in
+        let loc = { Location. loc_start=pos ; loc_end=pos ; loc_ghost=true } in
+        (* TODO: retrieve "ocaml.text" floating attributes? *)
+        Found (loc, None)
+      | Cmt_cache_store trie, Some _ ->
+        locate ~config ~context path trie
+      | _, _ -> assert false
+    in
+    begin match Utils.find_file ~config ~with_fallback:true file with
+    | Some cmt_file -> browse_cmt cmt_file
+    | None ->
+      (* The following is ugly, and deserves some explanations:
+           As can be seen above, when encountering packed modules we override
+           the loadpath by the one used to create the pack.
+           This means that if the cmt files haven't been moved, we have access
+           to the cmt file of every unit included in the pack.
+           However, we might not have access to any other cmt (e.g. if others
+           paths in the loadpath reference only cmis of packs).
+           (Note that if we had access to other cmts, there might be conflicts,
+           and the paths order would matter unless we have reliable digests...)
+           Assuming we are in such a situation, if we do not find something in
+           our "erased" loadpath, it could mean that we are looking for a
+           persistent unit, and that's why we restore the initial loadpath. *)
+      restore_loadpath ~config (fun () ->
+        match Utils.find_file ~config ~with_fallback:true file with
+        | Some cmt_file -> browse_cmt cmt_file
+        | None ->
+          log ~title:"from_path" "failed to locate the cmt[i] of '%s'" fname;
+          File_not_found file
+      )
+    end
+  | _ ->
+    Other_error (* type error, [from_path] should only be called on modules *)
+
+let path_and_loc_of_cstr desc _ =
+  let open Types in
+  match desc.cstr_tag with
+  | Cstr_extension (path, _) -> path, desc.cstr_loc
+  | _ ->
+    match desc.cstr_res.desc with
+    | Tconstr (path, _, _) -> path, desc.cstr_loc
+    | _ -> assert false
+
+let path_and_loc_from_label desc env =
+  let open Types in
+  match desc.lbl_res.desc with
+  | Tconstr (path, _, _) ->
+    let typ_decl = Env.find_type path env in
+    path, typ_decl.Types.type_loc
+  | _ -> assert false
+
+type find_source_result =
+  | Found of string
+  | Not_found of File.t
+  | Multiple_matches of string list
+
+let find_source ~config loc =
+  log ~title:"find_source" "attempt to find %S"
+  loc.Location.loc_start.Lexing.pos_fname ;
+  let fname = loc.Location.loc_start.Lexing.pos_fname in
+  let with_fallback = loc.Location.loc_ghost in
+  let file =
+    match File.of_filename fname with
+    | Some file -> file
+    | None ->
+      (* no extension? we have to decide. *)
+      Preferences.src fname
+  in
+  let filename = File.name file in
+  let initial_path =
+    match File_switching.where_am_i () with
+    | None -> fname
+    | Some s -> s
+  in
+  let dir = Filename.dirname initial_path in
+  let dir =
+    match Mconfig.(config.query.directory) with
+    | "" -> dir
+    | cwd -> Misc.canonicalize_filename ~cwd dir
+  in
+  match Utils.find_all_matches ~config ~with_fallback file with
+  | [] ->
+    log ~title:"find_source" "failed to find %S in source path (fallback = %b)"
+       filename with_fallback ;
+    log ~title:"find_source" "looking for %S in %S" (File.name file) dir ;
+    begin match Utils.find_file_with_path ~config ~with_fallback file [dir] with
+    | Some source -> Found source
+    | None ->
+      log ~title:"find_source" "Trying to find %S in %S directly" fname dir;
+      try Found (Misc.find_in_path [dir] fname)
+      with _ -> Not_found file
+    end
+  | [ x ] -> Found x
+  | files ->
+    log ~title:(sprintf "find_source(%s)" filename)
+      "multiple matches in the source path : %s"
+      (String.concat ~sep:" , " files);
+    try
+      match File_switching.source_digest () with
+      | None ->
+        log ~title:"find_source"
+          "... no source digest available to select the right one" ;
+        raise Not_found
+      | Some digest ->
+        log ~title:"find_source"
+          "... trying to use source digest to find the right one" ;
+        log ~title:"find_source" "Source digest: %s" (Digest.to_hex digest) ;
+        Found (
+          List.find files ~f:(fun f ->
+            let fdigest = Digest.file f in
+            log ~title:"find_source" "  %s (%s)" f (Digest.to_hex fdigest) ;
+            fdigest = digest
+          )
+        )
+    with Not_found ->
+      log ~title:"find_source" "... using heuristic to select the right one" ;
+      log ~title:"find_source" "we are looking for a file named %s in %s" fname dir ;
+      let rev = String.reverse (Misc.canonicalize_filename ~cwd:dir fname) in
+      let lst =
+        List.map files ~f:(fun path ->
+          let path' = String.reverse path in
+          let priority = (String.common_prefix_len rev path') * 2 +
+                          if Preferences.is_preferred path
+                          then 1
+                          else 0
+          in
+          priority, path
+        )
+      in
+      let lst =
+        (* TODO: remove duplicates in [source_path] instead of using
+          [sort_uniq] here. *)
+        List.sort_uniq ~cmp:(fun ((i:int),s) ((j:int),t) ->
+          let tmp = compare j i in
+          if tmp <> 0 then tmp else
+          match compare s t with
+          | 0 -> 0
+          | n ->
+            (* Check if we are referring to the same files.
+                Especially useful on OSX case-insensitive FS.
+                FIXME: May be able handle symlinks and non-existing files,
+                CHECK *)
+            match File_id.get s, File_id.get t with
+            | s', t' when File_id.check s' t' ->
+              0
+            | _ -> n
+        ) lst
+      in
+      match lst with
+      | (i1, _) :: (i2, _) :: _ when i1 = i2 ->
+        Multiple_matches files
+      | (_, s) :: _ -> Found s
+      | _ -> assert false
+
+(* Well, that's just another hack.
+   [find_source] doesn't like the "-o" option of the compiler. This hack handles
+   Jane Street specific use case where "-o" is used to prefix a unit name by the
+   name of the library which contains it. *)
+let find_source ~config loc path =
+  let result =
+    match find_source ~config loc with
+    | Found _ as result -> result
+    | failure ->
+      let fname = loc.Location.loc_start.Lexing.pos_fname in
+      match
+        let i = String.first_double_underscore_end fname in
+        let pos = i + 1 in
+        let fname = String.sub fname ~pos ~len:(String.length fname - pos) in
+        let loc =
+          let lstart = { loc.Location.loc_start with Lexing.pos_fname = fname } in
+          { loc with Location.loc_start = lstart }
+        in
+        find_source ~config loc
+      with
+      | Found _ as result -> result
+      | _ -> failure
+      | exception _ -> failure
+  in
+  match result with
+  | Found src -> `Found (Some src, loc.Location.loc_start)
+  | Not_found f -> File.explain_not_found path f
+  | Multiple_matches lst ->
+    let matches = String.concat lst ~sep:", " in
+    `File_not_found (
+      sprintf "Several source files in your path have the same name, and \
+               merlin doesn't know which is the right one: %s"
+        matches)
+
+let recover _ =
+  match Fallback.get () with
+  | None -> assert false
+  | Some loc -> `Found (loc, None)
+
+module Namespace = struct
+  type under_type = [ `Constr | `Labels ]
+
+  type t = (* TODO: share with [Namespaced_path.Namespace.t] *)
+    [ `Type | `Mod | `Modtype | `Vals | under_type ]
+
+  type inferred =
+    [ t
+    | `This_label of Types.label_description
+    | `This_cstr of Types.constructor_description ]
+
+  let from_context : Context.t -> inferred list = function
+    | Type          -> [ `Type ; `Mod ; `Modtype ; `Constr ; `Labels ; `Vals ]
+    | Module_type   -> [ `Modtype ; `Mod ; `Type ; `Constr ; `Labels ; `Vals ]
+    | Expr | Constant ->
+      [ `Vals ; `Mod ; `Modtype ; `Constr ; `Labels ; `Type ]
+    | Patt          -> [ `Mod ; `Modtype ; `Type ; `Constr ; `Labels ; `Vals ]
+    | Unknown       -> [ `Vals ; `Type ; `Constr ; `Mod ; `Modtype ; `Labels ]
+    | Label lbl     -> [ `This_label lbl ]
+    | Module_path   -> [ `Mod ]
+    | Constructor (c, _) -> [ `This_cstr c ]
+end
+
+module Env_lookup : sig
+
+  val loc
+    : Path.t
+    -> Namespaced_path.Namespace.t
+    -> Env.t
+    -> Location.t option
+
+  val in_namespaces
+     : Namespace.inferred list
+    -> Longident.t
+    -> Env.t
+    -> (Path.t * Namespaced_path.t * Location.t) option
+
+end = struct
+
+  let loc path (namespace : Namespaced_path.Namespace.t) env =
+    try
+      Some (
+        match namespace with
+        | `Unknown
+        | `Apply
+        | `Vals -> (Env.find_value path env).val_loc
+        | `Constr
+        | `Labels
+        | `Type -> (Env.find_type path env).type_loc
+        | `Functor
+        | `Mod -> (Env.find_module path env).md_loc
+        | `Modtype -> (Env.find_modtype path env).mtd_loc)
+    with
+      Not_found -> None
+
+  exception Found of (Path.t * Namespaced_path.t * Location.t)
+
+  let in_namespaces (nss : Namespace.inferred list) ident env =
+    try
+      List.iter nss ~f:(fun namespace ->
+        try
+          match namespace with
+          | `This_cstr cd ->
+            log ~title:"lookup"
+              "got constructor, fetching path and loc in type namespace";
+            let path, loc = path_and_loc_of_cstr cd env in
+            (* TODO: Use [`Constr] here instead of [`Type] *)
+            raise (Found (path, Namespaced_path.of_path ~namespace:`Type path, loc))
+          | `Constr ->
+            log ~title:"lookup" "lookup in constructor namespace" ;
+            let cd = Env.find_constructor_by_name ident env in
+            let path, loc = path_and_loc_of_cstr cd env in
+            (* TODO: Use [`Constr] here instead of [`Type] *)
+            raise (Found (path, Namespaced_path.of_path ~namespace:`Type path, loc))
+          | `Mod ->
+            log ~title:"lookup" "lookup in module namespace" ;
+            let path, md = Env.find_module_by_name ident env in
+            raise (Found (path, Namespaced_path.of_path ~namespace:`Mod path, md.Types.md_loc))
+          | `Modtype ->
+            log ~title:"lookup" "lookup in module type namespace" ;
+            let path, mtd = Env.find_modtype_by_name ident env in
+            raise (Found (path, Namespaced_path.of_path ~namespace:`Modtype path, mtd.Types.mtd_loc))
+          | `Type ->
+            log ~title:"lookup" "lookup in type namespace" ;
+            let path, typ_decl = Env.find_type_by_name ident env in
+            raise (Found (path, Namespaced_path.of_path ~namespace:`Type path, typ_decl.Types.type_loc))
+          | `Vals ->
+            log ~title:"lookup" "lookup in value namespace" ;
+            let path, val_desc = Env.find_value_by_name ident env in
+            raise (Found (path, Namespaced_path.of_path ~namespace:`Vals path, val_desc.Types.val_loc))
+          | `This_label lbl ->
+            log ~title:"lookup"
+              "got label, fetching path and loc in type namespace";
+            let path, loc = path_and_loc_from_label lbl env in
+            (* TODO: Use [`Labels] here instead of [`Type] *)
+            raise (Found (path, Namespaced_path.of_path ~namespace:`Type path, loc))
+          | `Labels ->
+            log ~title:"lookup" "lookup in label namespace" ;
+            let lbl = Env.find_label_by_name ident env in
+            let path, loc = path_and_loc_from_label lbl env in
+            (* TODO: Use [`Labels] here instead of [`Type] *)
+            raise (Found (path, Namespaced_path.of_path ~namespace:`Type path, loc))
+        with Not_found -> ()
+      ) ;
+      log ~title:"lookup" "   ... not in the environment" ;
+      None
+    with Found x ->
+      Some x
+end
+
+let locate ~config ~ml_or_mli ~path ~lazy_trie ~pos ~str_ident loc =
+  Preferences.set ml_or_mli;
+  log ~title:"locate"
+    "present in the environment, walking up the typedtree looking for '%s'"
+    (Namespaced_path.to_unique_string path);
+  try
+    if not (Utils.is_ghost_loc loc) then Fallback.set loc;
+    let lazy trie = lazy_trie in
+    match locate ~config ~context:(Initial pos) path trie with
+    | Found (loc, doc) -> `Found (loc, doc)
+    | Other_error
+    | File_not_found _ when Fallback.is_set () -> recover str_ident
+    | Other_error -> `Not_found (str_ident, File_switching.where_am_i ())
+    | File_not_found f -> File.explain_not_found str_ident f
+  with
+  | _ when Fallback.is_set () -> recover str_ident
+  | Not_found -> `Not_found (str_ident, File_switching.where_am_i ())
+
+(* Only used to retrieve documentation *)
+let from_completion_entry ~config ~lazy_trie ~pos (namespace, path, loc) =
+  let str_ident = Path.name path in
+  let tagged_path = Namespaced_path.of_path ~namespace path in
+  locate ~config ~ml_or_mli:`MLI ~path:tagged_path ~pos ~str_ident loc
+    ~lazy_trie
+
+let from_longident ~config ~env ~lazy_trie ~pos nss ml_or_mli ident =
+  let str_ident = String.concat ~sep:"." (Longident.flatten ident) in
+  match Env_lookup.in_namespaces nss ident env with
+  | None -> `Not_in_env str_ident
+  | Some (path, tagged_path, loc) ->
+    if Utils.is_builtin_path path then
+      `Builtin
+    else
+      locate ~config ~ml_or_mli ~path:tagged_path ~lazy_trie ~pos ~str_ident loc
+
+let from_path ~config ~env ~local_defs ~pos ~namespace ml_or_mli path =
+  File_switching.reset ();
+  Fallback.reset ();
+  let str_ident = Path.name path in
+  if Utils.is_builtin_path path then
+    `Builtin
+  else
+    let browse = Mbrowse.of_typedtree local_defs in
+    let lazy_trie =
+      lazy (Typedtrie.of_browses ~local_buffer:true
+              [Browse_tree.of_browse browse])
+    in
+    let nss_path = Namespaced_path.of_path ~namespace path in
+    match Env_lookup.loc path namespace env with
+    | None -> `Not_in_env str_ident
+    | Some loc ->
+      match
+        locate ~config ~ml_or_mli ~path:nss_path ~lazy_trie ~pos ~str_ident loc
+      with
+      | `Not_found _
+      | `File_not_found _ as err -> err
+      | `Found (loc, _) -> find_source ~config loc str_ident
+
+let from_string ~config ~env ~local_defs ~pos ?namespaces switch path =
+  File_switching.reset ();
+  Fallback.reset ();
+  let browse = Mbrowse.of_typedtree local_defs in
+  let lazy_trie =
+    lazy (Typedtrie.of_browses ~local_buffer:true
+            [Browse_tree.of_browse browse])
+  in
+  let lid = Longident.parse path in
+  let ident, is_label = Longident.keep_suffix lid in
+  match
+    match namespaces with
+    | Some nss ->
+      if not is_label
+      then `Ok (nss :> Namespace.inferred list)
+      else if List.mem `Labels ~set:nss then (
+        log ~title:"from_string" "restricting namespaces to labels";
+        `Ok [ `Labels ]
+      ) else (
+        log ~title:"from_string"
+          "input is clearly a label, but the given namespaces don't cover that";
+        `Error `Missing_labels_namespace
+      )
+    | None ->
+      match Context.inspect_browse_tree ~cursor:pos lid [browse], is_label with
+      | None, _ ->
+        log ~title:"from_string" "already at origin, doing nothing" ;
+        `Error `At_origin
+      | Some (Label _ as ctxt), true
+      | Some ctxt, false ->
+        log ~title:"from_string"
+          "inferred context: %s" (Context.to_string ctxt);
+        `Ok (Namespace.from_context ctxt)
+      | _, true ->
+        log ~title:"from_string"
+          "dropping inferred context, it is not precise enough";
+        `Ok [ `Labels ]
+  with
+  | `Error e -> e
+  | `Ok nss ->
+    log ~title:"from_string"
+      "looking for the source of '%s' (prioritizing %s files)"
+      path (match switch with `ML -> ".ml" | `MLI -> ".mli");
+    let_ref loadpath (Mconfig.cmt_path config) @@ fun () ->
+    match from_longident ~config ~pos ~env ~lazy_trie nss switch ident with
+    | `File_not_found _ | `Not_found _ | `Not_in_env _ as err -> err
+    | `Builtin -> `Builtin path
+    | `Found (loc, _) -> find_source ~config loc path
+
+let get_doc ~config ~env ~local_defs ~comments ~pos =
+  File_switching.reset ();
+  Fallback.reset ();
+  let browse = Mbrowse.of_typedtree local_defs in
+  let lazy_trie = lazy (Typedtrie.of_browses ~local_buffer:true
+                          [Browse_tree.of_browse browse]) in
+  fun path ->
+  let_ref loadpath (Mconfig.cmt_path config) @@ fun () ->
+  let_ref last_location Location.none @@ fun () ->
+  match
+    match path with
+    | `Completion_entry entry -> from_completion_entry ~config ~pos ~lazy_trie entry
+    | `User_input path ->
+      let lid = Longident.parse path in
+      begin match Context.inspect_browse_tree ~cursor:pos lid [browse] with
+      | None ->
+        `Found ({ Location. loc_start=pos; loc_end=pos ; loc_ghost=true }, None)
+      | Some ctxt ->
+        let nss = Namespace.from_context ctxt in
+        log ~title:"get_doc" "looking for the doc of '%s'" path ;
+        from_longident ~config ~pos ~env ~lazy_trie nss `MLI lid
+      end
+  with
+  | `Found (_, Some doc) ->
+    `Found doc
+  | `Found (loc, None) ->
+    let comments =
+      match File_switching.where_am_i () with
+      | None -> comments
+      | Some cmt_path ->
+        let {Cmt_cache. cmt_infos; _ } = Cmt_cache.read cmt_path in
+        cmt_infos.Cmt_format.cmt_comments
+    in
+    log ~title:"get_doc" "%a" Logger.fmt (fun fmt ->
+        Format.fprintf fmt "looking around %a inside: [\n"
+          Location.print_loc !last_location;
+        List.iter comments ~f:(fun (c, l) ->
+            Format.fprintf fmt "  (%S, %a);\n" c
+              Location.print_loc l);
+        Format.fprintf fmt "]\n"
+      );
+    let (_, deepest_before) = List.hd @@ Mbrowse.deepest_before loc.loc_start [browse] in
+    (* based on https://v2.ocaml.org/manual/doccomments.html#ss:label-comments: *)
+    let after_only = begin match deepest_before with
+      | Browse_raw.Constructor_declaration _ -> true
+      (* The remaining `true` cases are currently not reachable *)
+      | Label_declaration _ | Record_field _ | Row_field _  -> true
+      | _ -> false
+    end in
+    begin match
+      Ocamldoc.associate_comment ~after_only comments loc !last_location
+    with
+    | None, _     -> `No_documentation
+    | Some doc, _ -> `Found doc
+    end
+  | `Builtin ->
+    begin match path with
+    | `User_input path -> `Builtin path
+    | `Completion_entry (_, path, _) -> `Builtin (Path.name path)
+    end
+  | `File_not_found _
+  | `Not_found _
+  | `Not_in_env _ as otherwise -> otherwise
diff --git a/src/analysis/locate.mli b/src/analysis/locate.mli
new file mode 100644
index 0000000..53454c1
--- /dev/null
+++ b/src/analysis/locate.mli
@@ -0,0 +1,78 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+val log : 'a Logger.printf
+
+module Namespace : sig
+  type t = [ `Type | `Mod | `Modtype | `Vals | `Constr | `Labels ]
+end
+
+val from_path
+  : config:Mconfig.t
+  -> env:Env.t
+  -> local_defs:Mtyper.typedtree
+  -> pos:Lexing.position
+  -> namespace:Namespaced_path.Namespace.t
+  -> [ `ML | `MLI ]
+  -> Path.t
+  -> [> `File_not_found of string
+     | `Found of string option * Lexing.position
+     | `Builtin
+     | `Not_in_env of string
+     | `Not_found of string * string option ]
+
+val from_string
+  :  config:Mconfig.t
+  -> env:Env.t
+  -> local_defs:Mtyper.typedtree
+  -> pos:Lexing.position
+  -> ?namespaces:Namespace.t list
+  -> [ `ML | `MLI ]
+  -> string
+  -> [> `File_not_found of string
+      | `Found of string option * Lexing.position
+      | `Builtin of string
+      | `Missing_labels_namespace
+      | `Not_found of string * string option
+      | `Not_in_env of string
+      | `At_origin ]
+
+val get_doc
+  :  config:Mconfig.t
+  -> env:Env.t
+  -> local_defs:Mtyper.typedtree
+  -> comments:(string * Location.t) list
+  -> pos:Lexing.position
+  -> [ `User_input of string
+     | `Completion_entry of (Namespaced_path.Namespace.t * Path.t * Location.t) ]
+  -> [> `File_not_found of string
+      | `Found of string
+      | `Builtin of string
+      | `Not_found of string * string option
+      | `Not_in_env of string
+      | `No_documentation ]
diff --git a/src/analysis/namespaced_path.ml b/src/analysis/namespaced_path.ml
new file mode 100644
index 0000000..2ade36f
--- /dev/null
+++ b/src/analysis/namespaced_path.ml
@@ -0,0 +1,133 @@
+open Std
+
+module Namespace = struct
+  type t = [
+    | `Vals
+    | `Type
+    | `Constr
+    | `Mod
+    | `Modtype
+    | `Functor
+    | `Labels
+    | `Unknown
+    | `Apply
+  ]
+
+  let to_tag_string = function
+    | `Mod -> ""
+    | `Functor -> "[functor]"
+    | `Labels -> "[label]"
+    | `Constr -> "[cstr]"
+    | `Type -> "[type]"
+    | `Vals -> "[val]"
+    | `Modtype -> "[Mty]"
+    | `Unknown -> "[?]"
+    | `Apply -> "[functor application]"
+
+  let to_string = function
+    | `Mod -> "(module) "
+    | `Functor -> "(functor)"
+    | `Labels -> "(label) "
+    | `Constr -> "(constructor) "
+    | `Type -> "(type) "
+    | `Vals -> "(value) "
+    | `Modtype -> "(module type) "
+    | `Unknown -> "(unknown)"
+    | `Apply -> "(functor application)"
+end
+
+module Id = struct
+  type t =
+    | Id of Ident.t
+    | String of string
+
+  let name = function
+    | Id id -> Ident.name id
+    | String s -> s
+
+  let unique_name = function
+    | Id id -> Ident.unique_toplevel_name id
+    | String s -> s
+
+  let equal mi1 mi2 =
+    match mi1, mi2 with
+    | Id i1, Id i2 -> Ident.equal i1 i2
+    | Id i, String s
+    | String s, Id i -> (Ident.name i) = s
+    | String s1, String s2 -> s1 = s2
+end
+
+type t = elt list
+and elt =
+  | Ident of Id.t * Namespace.t
+  | Applied_to of t
+
+let rec to_string ~name = function
+  | []
+  | Applied_to _ :: _ -> invalid_arg "Namespaced_path.to_string"
+  | Ident (id, ns) :: rest ->
+    List.fold_left rest ~init:(name id ^ Namespace.to_tag_string ns) ~f:(
+      fun acc elt ->
+        match elt with
+        | Ident (id, ns) ->
+          Printf.sprintf "%s.%s%s" acc (name id) (Namespace.to_tag_string ns)
+        | Applied_to arg ->
+          Printf.sprintf "%s(%s)" acc (to_string ~name arg)
+    )
+
+let to_unique_string l = to_string ~name:Id.unique_name l
+let to_string l = to_string ~name:Id.name l
+
+let of_path ~namespace p =
+  let rec aux namespace acc p =
+    let open Path in
+    match p with
+    | Pident id -> Ident (Id.Id id, namespace) :: acc
+    | Pdot (p, s) -> aux `Mod (Ident (Id.String s, namespace) :: acc) p
+    | Papply (p1, p2) ->
+      let acc =
+        Applied_to (aux `Mod [] p2) :: acc
+      in
+      aux `Mod acc p1
+  in
+  aux namespace [] p
+
+let head_exn = function
+  | [] -> invalid_arg "head"
+  | x :: _ -> x
+
+let head x =
+  try Some (head_exn x)
+  with Invalid_argument _ -> None
+
+let peal_head_exn = function
+  | [] -> invalid_arg "peal_head_exn"
+  | _head :: rest -> rest
+
+let peal_head p =
+  try Some (peal_head_exn p)
+  with Invalid_argument _ -> None
+
+let rec equal p1 p2 = List.equal ~eq:equal_elt p1 p2
+and equal_elt elt1 elt2 =
+  match elt1, elt2 with
+  | Ident (i1, ns1), Ident (i2, ns2) -> Id.equal i1 i2 && ns1 = ns2
+  | Applied_to p1, Applied_to p2 -> equal p1 p2
+  | _, _ -> false
+
+let rewrite_head ~new_prefix p = new_prefix @ p
+
+let strip_stamps =
+  List.map ~f:(function
+    | Ident (Id i, ns) -> Ident (String (Ident.name i), ns)
+    | elt -> elt
+  )
+
+let empty = []
+
+let rec subst_prefix ~old_prefix ~new_prefix p =
+  match old_prefix, p with
+  | [], _ -> Some (new_prefix @ p)
+  | op1 :: ops, elt1 :: p when equal_elt op1 elt1 ->
+    subst_prefix ~old_prefix:ops ~new_prefix p
+  | _ -> None
diff --git a/src/analysis/namespaced_path.mli b/src/analysis/namespaced_path.mli
new file mode 100644
index 0000000..4e4a75c
--- /dev/null
+++ b/src/analysis/namespaced_path.mli
@@ -0,0 +1,49 @@
+module Namespace : sig
+  type t = [
+    | `Vals
+    | `Type
+    | `Constr
+    | `Mod
+    | `Modtype
+    | `Functor
+    | `Labels
+    | `Unknown
+    | `Apply
+  ]
+
+  val to_string : t -> string
+end
+
+module Id : sig
+  type t = private
+    | Id of Ident.t
+    | String of string
+
+  val name : t -> string
+end
+
+type t (* = private elt list *)
+and elt = private
+  | Ident of Id.t * Namespace.t
+  | Applied_to of t
+
+val to_string : t -> string
+val to_unique_string : t -> string
+
+val head : t -> elt option
+val head_exn : t -> elt
+
+val peal_head : t -> t option
+val peal_head_exn : t -> t
+
+val equal : t -> t -> bool
+
+val rewrite_head : new_prefix:t -> t -> t
+
+val strip_stamps : t -> t
+
+val of_path : namespace:Namespace.t -> Path.t -> t
+
+val empty : t
+
+val subst_prefix : old_prefix:t -> new_prefix:t -> t -> t option
diff --git a/src/analysis/ocamldoc.ml b/src/analysis/ocamldoc.ml
new file mode 100644
index 0000000..3383b42
--- /dev/null
+++ b/src/analysis/ocamldoc.ml
@@ -0,0 +1,61 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Copyright 2013 OCamlPro                                               *)
+(*                                                                        *)
+(*  All rights reserved.  This file is distributed under the terms of     *)
+(*  the Lesser GNU Public License version 3.0.                            *)
+(*                                                                        *)
+(*  This software is distributed in the hope that it will be useful,      *)
+(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
+(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
+(*  Lesser GNU General Public License for more details.                   *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Pops comments from a list of comments (string * loc) to find the ones that
+   are associated to a given location. Also returns the remaining comments after
+   the location. *)
+let associate_comment ~after_only comments loc nextloc =
+  let lstart = loc.Location.loc_start.Lexing.pos_lnum
+  and lend =  loc.Location.loc_end.Lexing.pos_lnum in
+  let isnext c =
+    nextloc <> Location.none &&
+    nextloc.Location.loc_start.Lexing.pos_cnum <
+    c.Location.loc_end.Lexing.pos_cnum
+  in
+  let rec aux = function
+    | [] -> None, []
+    | (comment, cloc)::comments ->
+        let cstart = cloc.Location.loc_start.Lexing.pos_lnum
+        and cend =  cloc.Location.loc_end.Lexing.pos_lnum
+        in
+        let processed =
+          (* It seems 4.02.3 remove ** from doc comment string, but not from
+           * locations.  We can recognize doc comment by checking how the two
+           * differ. *)
+          (cloc.Location.loc_end.Lexing.pos_cnum -
+           cloc.Location.loc_start.Lexing.pos_cnum) =
+             String.length comment + 5
+        in
+        if cend < lstart - 1 || cstart < lend && after_only then
+          aux comments
+        else if cstart > lend + 1 ||
+                isnext cloc ||
+                cstart > lstart && cend < lend (* keep inner comments *)
+        then
+          None, (comment, cloc)::comments
+        else if String.length comment < 2 ||
+                (not processed && (comment.[0] <> '*' || comment.[1] = '*'))
+        then
+          aux comments
+        else
+        let comment =
+          if processed then comment else
+          String.sub comment 1 (String.length comment - 1)
+        in
+        let comment = String.trim comment in
+        match aux comments with
+        | None, comments -> Some comment, comments
+        | Some c, comments -> Some (String.concat "\n" [comment; c]), comments
+  in
+  aux comments
diff --git a/src/analysis/outline.ml b/src/analysis/outline.ml
new file mode 100644
index 0000000..c7628bd
--- /dev/null
+++ b/src/analysis/outline.ml
@@ -0,0 +1,216 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+open Option.Infix
+
+(* Réglisse la police *)
+open Typedtree
+
+open Browse_raw
+open Browse_tree
+
+let id_of_patt = function
+  | { pat_desc = Tpat_var (id, _) ; _ } -> Some id
+  | _ -> None
+
+let mk ?(children=[]) ~location ~deprecated outline_kind outline_type id =
+  { Query_protocol.  outline_kind; outline_type; location; children;
+    outline_name = Ident.name id ; deprecated }
+
+let get_class_field_desc_infos = function
+  | Typedtree.Tcf_val (str_loc,_,_,_,_) -> Some (str_loc, `Value)
+  | Typedtree.Tcf_method (str_loc,_,_)  -> Some (str_loc, `Method)
+  | _ -> None
+
+let outline_type ~env typ =
+  let ppf, to_string = Format.to_string () in
+  Printtyp.wrap_printing_env env (fun () ->
+  Type_utils.print_type_with_decl ~verbosity:0 env ppf typ);
+  Some (to_string ())
+
+let rec summarize node =
+  let location = node.t_loc in
+  match node.t_node with
+  | Value_binding vb      ->
+    let deprecated = Type_utils.is_deprecated vb.vb_attributes in
+    begin match id_of_patt vb.vb_pat with
+    | None -> None
+    | Some ident ->
+      let typ = outline_type ~env:node.t_env vb.vb_pat.pat_type in
+      Some (mk ~location ~deprecated `Value typ ident)
+    end
+  | Value_description vd  ->
+    let deprecated = Type_utils.is_deprecated vd.val_attributes in
+    let typ = outline_type ~env:node.t_env vd.val_val.val_type in
+    Some (mk ~location ~deprecated `Value typ vd.val_id)
+
+  | Module_declaration md ->
+    let children = get_mod_children node in
+    begin match md.md_id with
+    | None -> None
+    | Some id ->
+      let deprecated = Type_utils.is_deprecated md.md_attributes in
+      Some (mk ~children ~location ~deprecated `Module None id)
+    end
+
+  | Module_binding mb ->
+    let children = get_mod_children node in
+    begin match mb.mb_id with
+    | None -> None
+    | Some id ->
+      let deprecated = Type_utils.is_deprecated mb.mb_attributes in
+      Some (mk ~children ~location ~deprecated `Module None id)
+    end
+
+  | Module_type_declaration mtd ->
+    let children = get_mod_children node in
+    let deprecated = Type_utils.is_deprecated mtd.mtd_attributes in
+    Some (mk ~deprecated ~children ~location `Modtype None mtd.mtd_id)
+
+  | Type_declaration td ->
+    let children =
+      List.concat_map (Lazy.force node.t_children) ~f:(fun child ->
+        match child.t_node with
+        | Type_kind _ ->
+          List.map (Lazy.force child.t_children) ~f:(fun x ->
+            match x.t_node with
+            | Constructor_declaration c ->
+              let deprecated = Type_utils.is_deprecated c.cd_attributes in
+              mk `Constructor None c.cd_id ~deprecated ~location:c.cd_loc
+            | Label_declaration ld ->
+              let deprecated = Type_utils.is_deprecated ld.ld_attributes in
+              mk `Label None ld.ld_id ~deprecated ~location:ld.ld_loc
+            | _ -> assert false (* ! *)
+          )
+        | _ -> []
+      )
+    in
+    let deprecated = Type_utils.is_deprecated td.typ_attributes in
+    Some (mk ~children ~location ~deprecated `Type None td.typ_id)
+
+  | Type_extension te ->
+    let name = Path.name te.tyext_path in
+    let children =
+      List.filter_map (Lazy.force node.t_children) ~f:(fun x ->
+        summarize x >>| fun x -> { x with Query_protocol.outline_kind = `Constructor }
+      )
+    in
+    let deprecated = Type_utils.is_deprecated te.tyext_attributes in
+    Some { Query_protocol. outline_name = name; outline_kind = `Type
+         ; outline_type = None; location; children; deprecated }
+
+  | Extension_constructor ec ->
+    let deprecated = Type_utils.is_deprecated ec.ext_attributes in
+    Some (mk ~location `Exn None ec.ext_id ~deprecated)
+
+  | Class_declaration cd ->
+    let children =
+      List.concat_map (Lazy.force node.t_children) ~f:get_class_elements
+    in
+    let deprecated = Type_utils.is_deprecated cd.ci_attributes in
+    Some (mk ~children ~location `Class None cd.ci_id_class_type ~deprecated)
+
+  | _ -> None
+
+and get_class_elements node =
+  match node.t_node with
+  | Class_expr _ ->
+    List.concat_map (Lazy.force node.t_children) ~f:get_class_elements
+  | Class_structure _ ->
+    List.filter_map (Lazy.force node.t_children) ~f:(fun child ->
+      match child.t_node with
+      | Class_field cf ->
+        begin match get_class_field_desc_infos cf.cf_desc with
+        | Some (str_loc, outline_kind) ->
+          let deprecated = Type_utils.is_deprecated cf.cf_attributes in
+          Some { Query_protocol.
+            outline_name = str_loc.Location.txt;
+            outline_kind;
+            outline_type = None;
+            location = str_loc.Location.loc;
+            children = [];
+            deprecated
+          }
+        | None -> None
+        end
+      | _ -> None
+    )
+  | _ -> []
+
+and get_mod_children node =
+  List.concat_map (Lazy.force node.t_children) ~f:remove_mod_indir
+
+and remove_mod_indir node =
+  match node.t_node with
+  | Module_expr _
+  | Module_type _ ->
+    List.concat_map (Lazy.force node.t_children) ~f:remove_mod_indir
+  | _ -> remove_top_indir node
+
+and remove_top_indir t =
+  match t.t_node with
+  | Structure _
+  | Signature _ -> List.concat_map ~f:remove_top_indir (Lazy.force t.t_children)
+  | Signature_item _
+  | Structure_item _ -> List.filter_map (Lazy.force t.t_children) ~f:summarize
+  | _ -> []
+
+let get browses = List.concat @@ List.rev_map ~f:remove_top_indir browses
+
+let shape cursor nodes =
+  let rec aux node =
+    (* A node is selected if:
+       - part of the module language
+       - or under the cursor *)
+    let selected = match node.t_node with
+      | Module_expr _
+      | Module_type_constraint _
+      | Structure _
+      | Structure_item _
+      | Module_binding _
+      | Module_type _
+      | Signature _
+      | Signature_item _
+      | Module_declaration _
+      | Module_type_declaration _
+      | Module_binding_name _
+      | Module_declaration_name _
+      | Module_type_declaration_name _ -> not node.t_loc.Location.loc_ghost
+      | _ -> Location_aux.compare_pos cursor node.t_loc = 0 &&
+             Lexing.compare_pos node.t_loc.Location.loc_start cursor <> 0 &&
+             Lexing.compare_pos node.t_loc.Location.loc_end cursor <> 0
+    in
+    if selected then [{
+        Query_protocol.
+        shape_loc = node.t_loc;
+        shape_sub = List.concat_map ~f:aux (Lazy.force node.t_children)
+      }]
+    else []
+  in
+  List.concat_map ~f:aux nodes
diff --git a/src/analysis/outline.mli b/src/analysis/outline.mli
new file mode 100644
index 0000000..20ae50e
--- /dev/null
+++ b/src/analysis/outline.mli
@@ -0,0 +1,30 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+val get : Browse_tree.t list -> Query_protocol.outline
+val shape : Lexing.position -> Browse_tree.t list -> Query_protocol.shape list
diff --git a/src/analysis/polarity_search.ml b/src/analysis/polarity_search.ml
new file mode 100644
index 0000000..b26f12d
--- /dev/null
+++ b/src/analysis/polarity_search.ml
@@ -0,0 +1,138 @@
+open Std
+
+type t = Trie of (string * Longident.t * t list lazy_t)
+
+module PathSet = Set.Make(Path)
+
+type query = {
+  positive: PathSet.t;
+  pos_fun: int;
+
+  negative: PathSet.t;
+  neg_fun: int;
+}
+
+let remove cost set path =
+  if PathSet.mem path !set then (
+    decr cost;
+    set := PathSet.remove path !set
+  )
+
+let rec normalize_path env path =
+  match Env.find_type path env with
+  | exception Not_found -> path
+  | decl ->
+    match decl.Types.type_manifest with
+    | Some body when decl.Types.type_private = Asttypes.Public
+                  || decl.Types.type_kind <> Types.Type_abstract ->
+      begin match (Ctype.repr body).Types.desc with
+      | Types.Tconstr (path, _, _) -> normalize_path env path
+      | _ -> path
+      end
+    | _ -> path
+
+let match_query env query t =
+  let cost = ref 0 in
+  let rec traverse neg neg_fun pos pos_fun t =
+    incr cost;
+    incr cost;
+    match (Ctype.repr t).Types.desc with
+    | Types.Tconstr (path, params, _) ->
+      remove cost pos (normalize_path env path);
+      begin match Env.find_type path env with
+      | exception Not_found -> ()
+      | { Types.type_variance; _ } ->
+        List.iter2 type_variance params ~f:(fun var arg ->
+          if Types.Variance.mem Types.Variance.Inj var then (
+            if Types.Variance.mem Types.Variance.Pos var then
+              traverse neg neg_fun pos pos_fun arg;
+            if Types.Variance.mem Types.Variance.Neg var then
+              traverse pos pos_fun neg neg_fun arg
+          )
+        )
+      end
+
+    | Types.Tarrow (_, t1, t2, _) ->
+      decr pos_fun;
+      traverse neg neg_fun pos pos_fun t2;
+      traverse pos pos_fun neg neg_fun t1
+
+    | Types.Ttuple ts ->
+      List.iter ~f:(traverse neg neg_fun pos pos_fun) ts
+
+    | Types.Tvar _ | Types.Tunivar _ ->
+      decr cost (* Favor polymorphic defs *)
+
+    | _ -> ()
+  in
+  let neg     = ref query.negative and pos     = ref query.positive in
+  let neg_fun = ref query.neg_fun  and pos_fun = ref query.pos_fun  in
+  traverse neg neg_fun pos pos_fun t;
+  if PathSet.is_empty !pos
+     && PathSet.is_empty !neg
+     && !neg_fun <= 0
+     && !pos_fun <= 0
+  then
+    Some !cost
+  else
+    None
+
+let build_query ~positive ~negative env =
+  let prepare r l =
+    if l = Longident.Lident "fun" then (incr r; None) else
+    let set, _ = Env.find_type_by_name l env in
+    Some (normalize_path env set)
+  in
+  let pos_fun = ref 0 and neg_fun = ref 0 in
+  let positive = List.filter_map positive ~f:(prepare pos_fun) in
+  let negative = List.filter_map negative ~f:(prepare neg_fun) in
+  {
+    positive = PathSet.of_list positive;
+    negative = PathSet.of_list negative;
+    neg_fun = !neg_fun; pos_fun = !pos_fun;
+  }
+
+let directories ~global_modules env =
+  let rec explore lident env =
+    let add_module name _ md l =
+      match md.Types.md_type with
+      | Types.Mty_alias _ -> l
+      | _ ->
+        let lident = Longident.Ldot (lident, name) in
+        Trie (name, lident, lazy (explore lident env)) :: l
+    in
+    Env.fold_modules add_module (Some lident) env []
+  in
+  List.fold_left ~f:(fun l name ->
+      let lident = Longident.Lident name in
+      match Env.find_module_by_name lident env with
+      | exception _ -> l
+      | _ -> Trie (name, lident, lazy (explore lident env)) :: l
+    ) ~init:[] global_modules
+  (*Env.fold_modules (fun name _ _ l ->
+      ignore (seen name);
+      let lident = Longident.Lident name in
+      Trie (name, lident, lazy (explore lident env)) :: l
+    ) None env []*)
+
+let execute_query query env dirs =
+  let direct dir acc =
+    Env.fold_values (fun _ path desc acc ->
+        match match_query env query desc.Types.val_type with
+        | Some cost -> (cost, path, desc) :: acc
+        | None -> acc
+      ) dir env acc
+  in
+  let rec recurse acc (Trie (_, dir, children)) =
+    match
+      ignore (Env.find_module_by_name dir env);
+      Lazy.force children
+    with
+    | children ->
+      List.fold_left ~f:recurse ~init:(direct (Some dir) acc) children
+    | exception Not_found ->
+      Logger.notify ~section:"polarity-search" "%S not found"
+        (String.concat ~sep:"." (Longident.flatten dir));
+      acc
+  in
+  List.fold_left dirs ~init:(direct None []) ~f:recurse
diff --git a/src/analysis/ptyp_of_type.ml b/src/analysis/ptyp_of_type.ml
new file mode 100644
index 0000000..adcba0f
--- /dev/null
+++ b/src/analysis/ptyp_of_type.ml
@@ -0,0 +1,238 @@
+open Std
+open Typedtree
+open Types
+
+let var_of_id id = Location.mknoloc @@ Ident.name id
+
+type signature_elt =
+  | Item of Types.signature_item
+  | Type of Asttypes.rec_flag * Parsetree.type_declaration list
+
+let rec module_type =
+  let open Ast_helper in function
+  | Mty_for_hole -> failwith "Holes are not allowed in module types"
+  | Mty_signature signature_items ->
+    Mty.signature @@ signature signature_items
+  | Mty_ident path ->
+    Ast_helper.Mty.ident (Location.mknoloc (Untypeast.lident_of_path path))
+  | Mty_alias path ->
+    Ast_helper.Mty.alias (Location.mknoloc (Untypeast.lident_of_path path))
+  | Mty_functor (param, type_out) ->
+    let param = match param with
+      | Unit -> Parsetree.Unit
+      | Named (id, type_in) ->
+        Parsetree.Named (
+          Location.mknoloc (Option.map ~f:Ident.name id),
+          module_type type_in)
+    in
+    let out = module_type type_out in
+    Mty.functor_ param out
+and core_type type_expr =
+  let open Ast_helper in
+  let type_expr = Btype.repr type_expr in
+  match type_expr.desc with
+  | Tvar None | Tunivar None -> Typ.any ()
+  | Tvar (Some s) | Tunivar (Some s) -> Typ.var s
+  | Tarrow (label, type_expr, type_expr_out, _commutable) ->
+    Typ.arrow label
+      (core_type type_expr)
+      (core_type type_expr_out)
+  | Ttuple type_exprs -> Typ.tuple @@ List.map ~f:core_type type_exprs
+  | Tconstr (path, type_exprs, _abbrev) ->
+    let loc = Untypeast.lident_of_path path |> Location.mknoloc in
+    Typ.constr loc @@ List.map ~f:core_type type_exprs
+  | Tobject (type_expr, _class_) ->
+    let type_expr = Btype.repr type_expr in
+    let rec aux acc type_expr = match type_expr.desc with
+      | Tnil -> acc, Asttypes.Closed
+      | Tvar None | Tunivar None -> acc, Asttypes.Open
+      | Tfield ("*dummy method*", _, _, fields) -> aux acc fields
+      | Tfield (name, _, type_expr, fields) ->
+        let open Ast_helper in
+        let core_type = core_type type_expr in
+        let core_type = Of.tag (Location.mknoloc name) core_type in
+
+        aux (core_type :: acc) fields
+      | _ ->
+        failwith @@ Format.asprintf
+          "Unexpected type constructor in fields list: %a"
+          Printtyp.type_expr type_expr
+    in
+    let fields, closed = aux [] type_expr in
+    Typ.object_ fields closed
+  | Tfield _ ->  failwith "Found object field outside of object."
+  | Tnil -> Typ.object_ [] Closed
+  | Tlink type_expr | Tsubst (type_expr, _) -> core_type type_expr
+  | Tvariant { row_fields; row_closed; _ } ->
+    let field (label, row_field) =
+      let label = Location.mknoloc label in
+      match row_field with
+      | Rpresent None | Reither (true, _, _, _) ->
+        Rf.tag label true []
+      | Rpresent (Some type_expr) ->
+        let core_type = core_type type_expr in
+        Rf.tag label false [ core_type ]
+      | Reither (false, type_exprs, _, _) ->
+        Rf.tag label false @@ List.map ~f:core_type type_exprs
+      | Rabsent -> assert false
+    in
+    let closed = if row_closed then Asttypes.Closed else Asttypes.Open in
+    let fields = List.map ~f:field row_fields in
+    (* TODO NOT ALWAYS NONE *)
+    Typ.variant fields closed None
+  | Tpoly (type_expr, type_exprs) ->
+    let names = List.map ~f:(fun v -> match v.desc with
+      | Tunivar (Some name) | Tvar (Some name) -> mknoloc name
+      | _ -> failwith "poly: not a var")
+      type_exprs
+    in
+    Typ.poly names @@ core_type type_expr
+  | Tpackage (path, lids_type_exprs) ->
+    let loc = mknoloc (Untypeast.lident_of_path path) in
+    let args = List.map lids_type_exprs
+      ~f:(fun (id, t) -> mknoloc id, core_type t)
+    in
+    Typ.package loc args
+and modtype_declaration id { mtd_type; mtd_attributes; _ } =
+  Ast_helper.Mtd.mk
+    ~attrs:mtd_attributes
+    ?typ:(Option.map ~f:module_type mtd_type)
+    (var_of_id id)
+and module_declaration id { md_type; md_attributes; _ } =
+ let name = Location.mknoloc (Some (Ident.name id)) in
+ Ast_helper.Md.mk
+  ~attrs:md_attributes
+  name
+  @@ module_type md_type
+and extension_constructor id {
+  ext_args;
+  ext_ret_type;
+  ext_attributes;
+  _
+} =
+  Ast_helper.Te.decl
+    ~attrs:ext_attributes
+    ~args:(constructor_arguments ext_args)
+    ?res:(Option.map ~f:core_type ext_ret_type)
+    (var_of_id id)
+and value_description id { val_type; val_kind=_; val_loc; val_attributes; _ } =
+  let type_ = core_type val_type in
+  {
+    Parsetree.pval_name = var_of_id id;
+    pval_type = type_;
+    pval_prim = [];
+    pval_attributes = val_attributes;
+    pval_loc = val_loc
+  }
+and label_declaration { ld_id; ld_mutable; ld_type; ld_attributes; _ } =
+  Ast_helper.Type.field
+    ~attrs:ld_attributes
+    ~mut:ld_mutable
+    (var_of_id ld_id)
+    (core_type ld_type)
+and constructor_arguments = function
+  | Cstr_tuple type_exprs ->
+    Parsetree.Pcstr_tuple (List.map ~f:core_type type_exprs)
+  | Cstr_record label_decls ->
+    Parsetree.Pcstr_record (List.map ~f:label_declaration label_decls)
+and constructor_declaration { cd_id; cd_args; cd_res; cd_attributes; _} =
+  Ast_helper.Type.constructor
+    ~attrs:cd_attributes
+    ~args:(constructor_arguments cd_args)
+    ?res:(Option.map ~f:core_type cd_res)
+    @@ var_of_id cd_id
+and type_declaration id {
+  type_params;
+  type_variance;
+  type_manifest;
+  type_kind;
+  type_attributes;
+  type_private;
+  _ }
+  =
+  let params = List.map2 type_params type_variance ~f:(fun type_ variance ->
+    let core_type = core_type type_ in
+    let pos, neg, _inv, inj = Types.Variance.get_lower variance in
+    let v = if pos then  Asttypes.Covariant
+      else (if neg then Contravariant
+      else NoVariance)
+    in
+    let i = if inj then Asttypes.Injective else NoInjectivity in
+    core_type, (v, i))
+  in
+  let kind = match type_kind with
+    | Type_abstract -> Parsetree.Ptype_abstract
+    | Type_open -> Ptype_open
+    | Type_variant (constrs, _) ->
+      Ptype_variant (List.map ~f:constructor_declaration constrs)
+    | Type_record (labels, _repr) ->
+      Ptype_record (List.map ~f:label_declaration labels)
+  in
+  let manifest = Option.map ~f:core_type type_manifest in
+  Ast_helper.Type.mk
+    ~attrs:type_attributes
+    ~params
+    ~kind
+    ~priv:type_private
+    ?manifest
+    (var_of_id id)
+and signature_item (str_item : Types.signature_item) =
+  let open Ast_helper in
+  match str_item with
+  | Sig_value (id, vd, _visibility) ->
+    let vd = value_description id vd in
+    Sig.value  vd
+  | Sig_type (id, type_decl, rec_flag, _visibility) ->
+    let rec_flag = match rec_flag with
+      | Trec_first -> Asttypes.Recursive
+      | Trec_next -> Asttypes.Recursive
+      | Trec_not -> Nonrecursive
+    in (* mutually recursive types are really handled by [signature] *)
+    Sig.type_ rec_flag [type_declaration id type_decl]
+  | Sig_modtype (id, modtype_decl, _visibility) ->
+    Sig.modtype @@ modtype_declaration id modtype_decl
+  | Sig_module (id, _, mod_decl, _, _) ->
+    Sig.module_ @@ module_declaration id mod_decl
+  | Sig_typext (id, ext_constructor, _, _) ->
+    let ext = Te.mk
+      (Location.mknoloc @@ Longident.Lident (Ident.name id))
+      [ extension_constructor id ext_constructor]
+    in
+    Sig.type_extension ext
+  | Sig_class_type (id, _, _, _) ->
+    let str = Format.asprintf "Construct does not handle class types yet. \
+    Please replace this comment by [%s]'s definition." (Ident.name id) in
+    Sig.text [ Docstrings.docstring str Location.none ] |> List.hd
+  | Sig_class (id, _, _, _) ->
+    let str = Format.asprintf "Construct does not handle classes yet. \
+    Please replace this comment by [%s]'s definition." (Ident.name id) in
+    Sig.text [ Docstrings.docstring str Location.none ] |> List.hd
+and signature  (items : Types.signature_item list) =
+  List.map (group_items items)
+    ~f:(function
+    | Item item -> signature_item item
+    | Type (rec_flag, type_decls) -> Ast_helper.Sig.type_  rec_flag type_decls)
+and group_items (items : Types.signature_item list) =
+  let rec read_type type_acc items =
+    match items with
+    | Sig_type (id, type_decl, Trec_next, _) :: rest ->
+      let td = type_declaration id type_decl in
+      read_type (td :: type_acc) rest
+    | _ -> List.rev type_acc, items
+  in
+  let rec group acc items =
+    match items with
+    | Sig_type (id, type_decl, Trec_first, _) :: rest ->
+      let type_, rest = read_type [type_declaration id type_decl] rest in
+      group (Type (Asttypes.Recursive, type_) :: acc) rest
+    | Sig_type (id, type_decl, Trec_not, _) :: rest ->
+      let type_, rest = read_type [type_declaration id type_decl] rest in
+      group (Type (Asttypes.Nonrecursive, type_) :: acc) rest
+    | Sig_class _ as item :: _ :: _ :: _ :: rest ->
+      group (Item item :: acc) rest
+    | Sig_class_type _ as item :: _ :: _ :: rest ->
+      group (Item item :: acc) rest
+    | item :: rest -> group (Item item :: acc) rest
+    | [] -> List.rev acc
+  in
+  group [] items
diff --git a/src/analysis/ptyp_of_type.mli b/src/analysis/ptyp_of_type.mli
new file mode 100644
index 0000000..26fb46e
--- /dev/null
+++ b/src/analysis/ptyp_of_type.mli
@@ -0,0 +1,41 @@
+type signature_elt =
+| Item of Types.signature_item
+| Type of Asttypes.rec_flag * Parsetree.type_declaration list
+
+val module_type : Types.module_type -> Parsetree.module_type
+
+val core_type : Types.type_expr -> Parsetree.core_type
+
+val modtype_declaration :
+  Ident.t ->
+  Types.modtype_declaration ->
+  Parsetree.module_type_declaration
+
+val module_declaration :
+  Ident.t -> Types.module_declaration -> Parsetree.module_declaration
+
+val signature_item : Types.signature_item -> Parsetree.signature_item
+
+val extension_constructor :
+  Ident.t -> Types.extension_constructor -> Parsetree.extension_constructor
+
+val value_description :
+  Ident.t -> Types.value_description -> Parsetree.value_description
+
+val label_declaration : Types.label_declaration -> Parsetree.label_declaration
+
+val constructor_arguments :
+  Types.constructor_arguments -> Parsetree.constructor_arguments
+
+val constructor_declaration :
+  Types.constructor_declaration -> Parsetree.constructor_declaration
+
+val type_declaration :
+  Ident.t -> Types.type_declaration -> Parsetree.type_declaration
+
+val signature : Types.signature ->  Parsetree.signature
+
+(** [group_items sig_items] groups items from a signature in a more meaningful
+  way: type declaration of the same recursive type are group together and items
+  following a class or class_type items are discarded *)
+val group_items : Types.signature_item list -> signature_elt list
diff --git a/src/analysis/refactor_open.ml b/src/analysis/refactor_open.ml
new file mode 100644
index 0000000..8d9afc7
--- /dev/null
+++ b/src/analysis/refactor_open.ml
@@ -0,0 +1,52 @@
+open Std
+
+(** [qual_or_unqual_path mode ~open_lident ~open_path node_path node_lid] 
+    if mode is 
+      `Unqualify - returns [node_lid] or [node_lid] with prefix [open_lident] cut off, 
+        whichever is shorter
+
+      `Qualify - returns [node_path] with its prefix equal to [open_lident]
+
+    Returns [None] if [node_lid] doesn't need changes.
+
+    Note: by "prefix" we mean the leftmost consecutive part of a longident or a path. *)
+let qual_or_unqual_path mode ~open_lident ~open_path node_path node_lid =
+  let open_lid_head = Longident.head open_lident in
+  let node_lid_head = Longident.head node_lid in
+  let rec make_new_node_lid acc (p : Path.t) =
+    match p with
+    | Pident ident ->
+      Ident.name ident :: acc
+    | Pdot (path', s) when
+        mode = `Unqualify && 
+          (Path.same open_path path'
+          || String.equal s node_lid_head (* unqualify shouldn't enlarge lident *)) 
+      ->
+      s :: acc
+    | Pdot (_, s) when mode = `Qualify && s = open_lid_head ->
+      s :: acc
+    | Pdot (path', s) ->
+      make_new_node_lid (s :: acc) path'
+    | _ -> raise Not_found
+  in
+  let same_longident node_lid_head new_node_lid = 
+    (* this works because [make_new_node_lid] changes only prefix of a longident *)
+    String.equal node_lid_head (List.hd new_node_lid)
+  in
+  match make_new_node_lid [] node_path with
+  | new_node_lid when not (same_longident node_lid_head new_node_lid) ->
+    Some (String.concat ~sep:"." new_node_lid)
+  | _ | exception Not_found -> None
+
+let get_rewrites ~mode typer pos =
+  match Mbrowse.select_open_node (Mtyper.node_at typer pos) with
+  | None | Some (_, _, []) -> []
+  | Some (open_path, open_lident, ((_, node) :: _)) ->
+    let paths_and_lids = Browse_tree.all_occurrences_of_prefix open_path node in
+    List.filter_map paths_and_lids ~f:(fun ({Location. txt = path; loc}, lid) ->
+      if loc.Location.loc_ghost || Location_aux.compare_pos pos loc > 0 then
+        None
+      else
+        qual_or_unqual_path mode ~open_lident ~open_path path lid
+        |> Option.map ~f:(fun new_lid -> (new_lid, loc)))
+    |> List.sort_uniq ~cmp:(fun (_,l1) (_,l2) -> Location_aux.compare l1 l2)
diff --git a/src/analysis/refactor_open.mli b/src/analysis/refactor_open.mli
new file mode 100644
index 0000000..9a4f2cb
--- /dev/null
+++ b/src/analysis/refactor_open.mli
@@ -0,0 +1,6 @@
+
+val get_rewrites
+  : mode:[> `Qualify | `Unqualify ]
+  -> Mtyper.result
+  -> Lexing.position
+  -> (string * Location.t) list
diff --git a/src/analysis/tail_analysis.ml b/src/analysis/tail_analysis.ml
new file mode 100644
index 0000000..3e75a75
--- /dev/null
+++ b/src/analysis/tail_analysis.ml
@@ -0,0 +1,88 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+open Browse_raw
+open Typedtree
+
+let tail_operator = function
+  | {exp_desc = Texp_ident
+                  (_,_, {Types.val_kind =
+                           Types.Val_prim
+                             {Primitive.prim_name = "%sequand"|"%sequor"; _ }
+                        ; _ })
+    ; _ }
+    -> true
+  | _ -> false
+
+let expr_tail_positions = function
+  | Texp_apply (callee, args) when tail_operator callee ->
+    begin match List.last args with
+      | None | Some (_, None)-> []
+      | Some (_, Some expr) -> [Expression expr]
+    end
+  | Texp_instvar _ | Texp_setinstvar _ | Texp_override _ | Texp_assert _
+  | Texp_lazy _ | Texp_object _ | Texp_pack _
+  | Texp_function _ | Texp_apply _ | Texp_tuple _
+  | Texp_ident _ | Texp_constant _
+  | Texp_construct _ | Texp_variant _ | Texp_record _
+  | Texp_field _ | Texp_setfield _ | Texp_array _
+  | Texp_while _ | Texp_for _ | Texp_send _ | Texp_new _
+  | Texp_unreachable | Texp_extension_constructor _ | Texp_letop _ | Texp_hole
+    -> []
+  | Texp_match (_,cs,_)
+    -> List.map cs ~f:(fun c -> Case c)
+  | Texp_try (_,cs)
+    -> List.map cs ~f:(fun c -> Case c)
+  | Texp_letmodule (_,_,_,_,e) | Texp_letexception (_,e) | Texp_let (_,_,e)
+  | Texp_sequence (_,e) | Texp_ifthenelse (_,e,None) | Texp_open (_, e)
+    -> [Expression e]
+  | Texp_ifthenelse (_,e1,Some e2)
+    -> [Expression e1; Expression e2]
+
+
+let tail_positions = function
+  | Expression expr -> expr_tail_positions expr.exp_desc
+  | Case case -> [Expression case.c_rhs]
+  | _ -> []
+
+(* If the expression is a function, return all of its entry-points (which are
+   in tail-positions). Returns an empty list otherwise *)
+let expr_entry_points = function
+  | Texp_function {cases; _} -> List.map cases ~f:(fun c -> Case c)
+  | _ -> []
+
+let entry_points = function
+  | Expression expr -> expr_entry_points expr.exp_desc
+  | _ -> []
+
+(* FIXME: what about method call? It should be translated to a Texp_apply,
+   but I am not sure *)
+let is_call = function
+  | Expression {exp_desc = Texp_apply _; _} -> true
+  | _ -> false
diff --git a/src/analysis/tail_analysis.mli b/src/analysis/tail_analysis.mli
new file mode 100644
index 0000000..6e29c38
--- /dev/null
+++ b/src/analysis/tail_analysis.mli
@@ -0,0 +1,38 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+(* Assuming an expression (or other constructs occurring inside expressions,
+   like cases of a match statement) is in tail-position, returns all
+   sub-expression that will be evaluated in tail-position too *)
+val tail_positions: Browse_raw.node -> Browse_raw.node list
+
+(* If the node is a function, return all of its entry-points -- those are in
+   tail-position. Returns an empty list otherwise *)
+val entry_points: Browse_raw.node -> Browse_raw.node list
+
+val is_call: Browse_raw.node -> bool
diff --git a/src/analysis/type_enclosing.ml b/src/analysis/type_enclosing.ml
new file mode 100644
index 0000000..3eae428
--- /dev/null
+++ b/src/analysis/type_enclosing.ml
@@ -0,0 +1,130 @@
+open Std
+
+let log_section = "type-enclosing"
+let {Logger.log} = Logger.for_section log_section
+
+type type_info =
+  | Modtype of Env.t * Types.module_type
+  | Type of Env.t * Types.type_expr
+  | Type_decl of Env.t * Ident.t * Types.type_declaration
+  | String of string
+
+type typed_enclosings =
+  (Location.t * type_info * Query_protocol.is_tail_position) list
+
+let from_nodes ~path =
+  let aux (env, node, tail) =
+    let open Browse_raw in
+    let ret x = Some (Mbrowse.node_loc node, x, tail) in
+    match[@ocaml.warning "-9"] node with
+    | Expression {exp_type = t}
+    | Pattern {pat_type = t}
+    | Core_type {ctyp_type = t}
+    | Value_description { val_desc = { ctyp_type = t } } ->
+      ret (Type (env, t))
+    | Type_declaration { typ_id = id; typ_type = t} ->
+      ret (Type_decl (env, id, t))
+    | Module_expr {mod_type = Types.Mty_for_hole} -> None
+    | Module_expr {mod_type = m}
+    | Module_type {mty_type = m}
+    | Module_binding {mb_expr = {mod_type = m}}
+    | Module_declaration {md_type = {mty_type = m}}
+    | Module_type_declaration {mtd_type = Some {mty_type = m}}
+    | Module_binding_name {mb_expr = {mod_type = m}}
+    | Module_declaration_name {md_type = {mty_type = m}}
+    | Module_type_declaration_name {mtd_type = Some {mty_type = m}} ->
+      ret (Modtype (env, m))
+    | Class_field
+        { cf_desc =
+            Tcf_method
+              (_, _,
+               Tcfk_concrete
+                 (_, {exp_type = { desc = Tarrow (_, _, t, _) } })) } ->
+      ret (Type (env, t))
+    | Class_field
+        { cf_desc =
+            Tcf_val (_, _, _, Tcfk_concrete (_, {exp_type = t }), _) } ->
+      ret (Type (env, t))
+    | Class_field { cf_desc =
+                      Tcf_method (_, _, Tcfk_virtual {ctyp_type = t }) } ->
+      ret (Type (env, t))
+    | Class_field { cf_desc =
+                      Tcf_val (_, _, _, Tcfk_virtual {ctyp_type = t }, _) } ->
+      ret (Type (env, t))
+    | _ -> None
+  in
+  List.filter_map ~f:aux path
+
+let from_reconstructed ~nodes ~cursor ~verbosity exprs =
+  let open Browse_raw in
+  let env, node = Mbrowse.leaf_node nodes in
+  log ~title:"from_reconstructed" "node = %s\nexprs = [%s]"
+    (Browse_raw.string_of_node node)
+    (String.concat ~sep:";" (List.map exprs ~f:(fun l ->
+         l.Location.txt))
+    );
+  let include_lident = match node with
+    | Pattern _ -> false
+    | _ -> true
+  in
+  let include_uident = match node with
+    | Module_binding _
+    | Module_binding_name _
+    | Module_declaration _
+    | Module_declaration_name _
+    | Module_type_declaration _
+    | Module_type_declaration_name _
+      -> false
+    | _ -> true
+  in
+
+  let get_context lident =
+    Context.inspect_browse_tree
+      ~cursor
+      (Longident.parse lident)
+      [nodes]
+  in
+
+  let f =
+    fun {Location. txt = source; loc} ->
+      let context = get_context source in
+      Option.iter context ~f:(fun ctx ->
+          log ~title:"from_reconstructed" "source = %s; context = %s"
+            source (Context.to_string ctx));
+      match context with
+      (* Retrieve the type from the AST when it is possible *)
+      | Some (Context.Constructor (cd, loc)) ->
+        log ~title:"from_reconstructed" "ctx: constructor %s"
+          cd.cstr_name;
+        let ppf, to_string = Format.to_string () in
+        Type_utils.print_constr ~verbosity env ppf cd;
+        Some (loc, String (to_string ()), `No)
+      | Some Context.Constant -> None
+      | _ ->
+        let context = Option.value ~default:Context.Expr context in
+        (* Else use the reconstructed identifier *)
+        match source with
+        | "" ->
+          log ~title:"from_reconstructed" "no reconstructed identifier";
+          None
+        | source when not include_lident && Char.is_lowercase source.[0] ->
+          log ~title:"from_reconstructed" "skipping lident";
+          None
+        | source when not include_uident && Char.is_uppercase source.[0] ->
+          log ~title:"from_reconstructed" "skipping uident";
+          None
+        | source ->
+          try
+            let ppf, to_string = Format.to_string () in
+            if Type_utils.type_in_env ~verbosity ~context env ppf source then (
+              log ~title:"from_reconstructed" "typed %s" source;
+              Some (loc, String (to_string ()), `No)
+            )
+            else (
+              log ~title:"from_reconstructed" "FAILED to type %s" source;
+              None
+            )
+          with _ ->
+            None
+  in
+  List.filter_map exprs ~f
diff --git a/src/analysis/type_enclosing.mli b/src/analysis/type_enclosing.mli
new file mode 100644
index 0000000..8ffec0e
--- /dev/null
+++ b/src/analysis/type_enclosing.mli
@@ -0,0 +1,55 @@
+(** Provides type information around the cursor.
+
+    The information comes from two sources:
+    1. enclosing AST nodes: we just retrieve the types in the typedtree
+    2. if the cursor is on an identifier, by typing it in the current
+    environment
+
+    (2) is primarily useful in the following situations:
+    - when the identifier is polymorphic in the environment, but monomorphic in
+    the AST because it's been instantiated.
+    - when there is a syntax or type error in that area, and we don't have a
+    precise enough AST node for the position (i.e. we got a "recovered" node, of
+    type ['a]).
+
+    Furthermore, (2) has a finer granularity than (1): when the cursor is in the
+    middle of a longident, e.g. [Foo.B|ar.Baz.lol] (with | being the cursor),
+    then we'll have one AST node covering the whole ident.
+    But what we reconstruct gives us: [Foo.Bar], [Foo.Bar.Baz],
+    [Foo.Bar.Baz.lol]; and we return the type for each of them.
+    These are what we call "small enclosings".
+
+    There are however some issues with the small enclosings:
+    - one has to be careful of the context (obviously that information won't be
+    available in case of parse errors); because a given identifier could exist
+    in different namespaces, for instance:
+    {[
+      type t
+      module type t = sig val t : t end
+      let t (t : t) : (module t) = (module struct let t = t end)
+    ]}
+
+    - the information might be redundant with the one we get from the AST.
+*)
+
+val log_section : string
+
+type type_info =
+  | Modtype of Env.t * Types.module_type
+  | Type of Env.t * Types.type_expr
+  | Type_decl of Env.t * Ident.t * Types.type_declaration
+  | String of string
+
+type typed_enclosings =
+  (Location.t * type_info * Query_protocol.is_tail_position) list
+
+val from_nodes :
+  path:(Env.t * Browse_raw.node * Query_protocol.is_tail_position) list ->
+  typed_enclosings
+
+val from_reconstructed :
+  nodes:(Env.t * Browse_raw.node) list ->
+  cursor:Lexing.position ->
+  verbosity:int ->
+  string Location.loc list ->
+  typed_enclosings
diff --git a/src/analysis/type_utils.ml b/src/analysis/type_utils.ml
new file mode 100644
index 0000000..2f0d5d7
--- /dev/null
+++ b/src/analysis/type_utils.ml
@@ -0,0 +1,336 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+
+let parse_expr ?(keywords=Lexer_raw.keywords []) expr =
+  let lexbuf = Lexing.from_string expr in
+  let state = Lexer_raw.make keywords in
+  let rec lexer = function
+    | Lexer_raw.Fail (e,l) -> raise (Lexer_raw.Error (e,l))
+    | Lexer_raw.Return token -> token
+    | Lexer_raw.Refill k -> lexer (k ())
+  in
+  let lexer lexbuf = lexer (Lexer_raw.token_without_comments state lexbuf) in
+  Parser_raw.parse_expression lexer lexbuf
+
+let lookup_module name env =
+  let path, md = Env.find_module_by_name name env in
+  path, md.Types.md_type, md.Types.md_attributes
+
+let verbosity = ref 0
+
+module Printtyp = struct
+  include Printtyp
+
+  let expand_type env ty =
+    Env.with_cmis @@ fun () -> (* ?? Not sure *)
+    if !verbosity = 0 then ty
+    else
+      (* Fresh copy of the type to mutilate *)
+      let ty = Subst.type_expr Subst.identity ty in
+      let marks = Hashtbl.create 7 in
+      let mark ty =
+        if Hashtbl.mem marks ty.Types.id then false
+        else (Hashtbl.add marks ty.Types.id (); true)
+      in
+      let rec iter d ty0 =
+        let ty' = Ctype.repr ty0 in
+        if mark ty' then
+          let open Types in
+          let ty'' = Ctype.full_expand ~may_forget_scope:true env ty' in
+          if ty''.desc == ty'.desc then
+            Btype.iter_type_expr (iter d) ty0
+          else begin
+            let desc = match ty''.desc with
+              | Tvariant row ->
+                Tvariant {row with row_name = None}
+              | Tobject (ty, _) ->
+                Tobject (ty, ref None)
+              | desc -> desc
+            in
+            Types.Private_type_expr.set_desc ty0 desc;
+            if d > 0 then
+              Btype.iter_type_expr (iter (pred d)) ty0
+          end
+      in
+      iter !verbosity ty;
+      ty
+
+  let expand_type_decl env ty =
+    match ty.Types.type_manifest with
+    | Some m -> {ty with Types.type_manifest = Some (expand_type env m)}
+    | None -> ty
+
+  let expand_sig env mty =
+    Env.with_cmis @@ fun () ->
+    Env.scrape_alias env mty
+
+  let verbose_type_scheme env ppf t =
+    Printtyp.type_scheme ppf (expand_type env t)
+
+  let verbose_type_declaration env id ppf t =
+    Printtyp.type_declaration id ppf (expand_type_decl env t)
+
+  let verbose_modtype env ppf t =
+    Printtyp.modtype ppf (expand_sig env t)
+
+  let select_verbose a b env =
+    (if !verbosity = 0 then a else b env)
+
+  let type_scheme env ppf ty =
+    select_verbose type_scheme verbose_type_scheme env ppf ty
+
+  let type_declaration env id ppf =
+    select_verbose type_declaration verbose_type_declaration env id ppf
+
+  let modtype env ppf mty =
+    select_verbose modtype verbose_modtype env ppf mty
+
+  let wrap_printing_env env ~verbosity:v f =
+    let_ref verbosity v (fun () -> wrap_printing_env env f)
+end
+
+let si_modtype_opt = function
+  | Types.Sig_modtype (_, m, _) -> m.mtd_type
+  | Types.Sig_module (_, _, m, _, _) -> Some m.md_type
+  | _ -> None
+
+(* Check if module is smaller (= has less definition, counting nested ones)
+ * than a particular threshold. Return (Some n) if module has size n, or None
+ * otherwise (module is bigger than threshold).
+ * Used to skip printing big modules in completion. *)
+let rec mod_smallerthan n m =
+  if n < 0 then None
+  else
+    let open Types in
+    match m with
+    | Mty_ident _ -> Some 1
+    | Mty_signature s ->
+      begin match List.length_lessthan n s with
+        | None -> None
+        | Some _ ->
+          List.fold_left s ~init:(Some 0)
+            ~f:begin fun acc item ->
+              let sub n1 m = match mod_smallerthan (n - n1) m with
+                | Some n2 -> Some (n1 + n2)
+                | None -> None
+              in
+              match acc, si_modtype_opt item with
+              | None, _ -> None
+              | Some n', _ when n' > n -> None
+              | Some n1, Some mty -> sub n1 mty
+              | Some n', _ -> Some (succ n')
+            end
+      end
+    | Mty_functor _ ->
+    let (m1,m2) = unpack_functor m in
+    begin
+      match mod_smallerthan n m2, m1 with
+      | None, _ -> None
+      | result, Unit -> result
+      | Some n1, Named (_, mt) ->
+      match mod_smallerthan (n - n1) mt with
+      | None -> None
+      | Some n2 -> Some (n1 + n2)
+    end
+  | _ -> Some 1
+
+let print_short_modtype verbosity env ppf md  =
+  match mod_smallerthan 1000 md with
+  | None when verbosity = 0 ->
+    Format.pp_print_string ppf
+      "(* large signature, repeat to confirm *)";
+  | _ ->
+    Printtyp.modtype env ppf md
+
+let print_type_with_decl ~verbosity env ppf typ =
+  if verbosity > 0 then
+    match (Ctype.repr typ).Types.desc with
+    | Types.Tconstr (path, params, _) ->
+      let decl =
+        Env.with_cmis @@ fun () ->
+        Env.find_type path env
+      in
+      let is_abstract =
+        match decl.Types.type_kind with
+        | Types.Type_abstract -> true
+        | _ -> false
+      in
+      (* Print expression only if it is parameterized or abstract *)
+      let print_expr = is_abstract || params <> [] in
+      if print_expr then
+        Printtyp.type_scheme env ppf typ;
+      (* If not abstract, also print the declaration *)
+      if not is_abstract then
+        begin
+          (* Separator if expression was printed *)
+          if print_expr then
+            begin
+              Format.pp_print_newline ppf ();
+              Format.pp_print_newline ppf ();
+            end;
+          let ident = match path with
+            | Path.Papply _ -> assert false
+            | Path.Pdot _ -> Ident.create_persistent (Path.last path)
+            | Path.Pident ident -> ident
+          in
+          Printtyp.type_declaration env ident ppf decl
+        end
+    | _ -> Printtyp.type_scheme env ppf typ
+  else
+    Printtyp.type_scheme env ppf typ
+
+let print_exn ppf exn =
+  match Location.error_of_exn exn with
+  | None | Some `Already_displayed ->
+    Format.pp_print_string ppf (Printexc.to_string exn)
+  | Some (`Ok report) -> Location.print_main ppf report
+
+let print_type ppf env lid  =
+  let p, t = Env.find_type_by_name lid.Asttypes.txt env in
+  Printtyp.type_declaration env
+    (Ident.create_persistent (* Incorrect, but doesn't matter. *)
+       (Path.last p))
+    ppf t
+
+let print_modtype ppf verbosity env lid =
+  let _p, mtd = Env.find_modtype_by_name lid.Asttypes.txt env in
+  match mtd.mtd_type with
+  | Some mt -> print_short_modtype verbosity env ppf mt
+  | None -> Format.pp_print_string ppf "(* abstract module *)"
+
+let print_modpath ppf verbosity env lid =
+  let _path, md =
+    Env.find_module_by_name lid.Asttypes.txt env
+  in
+  print_short_modtype verbosity env ppf (md.md_type)
+
+let print_cstr_desc ppf cstr_desc =
+  !Oprint.out_type ppf (Browse_misc.print_constructor cstr_desc)
+
+let print_constr ppf env lid =
+  let cstr_desc =
+    Env.find_constructor_by_name lid.Asttypes.txt env
+  in
+  (* FIXME: support Reader printer *)
+  print_cstr_desc ppf cstr_desc
+
+exception Fallback
+let type_in_env ?(verbosity=0) ?keywords ~context env ppf expr =
+  let print_expr expression =
+    let (str, _sg, _) =
+      Env.with_cmis @@ fun () ->
+      Typemod.type_toplevel_phrase env
+        [Ast_helper.Str.eval expression]
+    in
+    let open Typedtree in
+    match str.str_items with
+    | [ { str_desc = Tstr_eval (exp,_); _ }] ->
+      print_type_with_decl ~verbosity env ppf exp.exp_type
+    | _ -> failwith "unhandled expression"
+  in
+  Printtyp.wrap_printing_env env ~verbosity @@ fun () ->
+  Msupport.uncatch_errors @@ fun () ->
+  match parse_expr ?keywords expr with
+  | exception exn -> print_exn ppf exn; false
+
+  | e ->
+    let extract_specific_parsing_info e =
+      match e.Parsetree.pexp_desc with
+      | Parsetree.Pexp_ident longident -> `Ident longident
+      | Parsetree.Pexp_construct (longident, _) -> `Constr longident
+      | _ -> `Other
+    in
+    let open Context in
+    match extract_specific_parsing_info e with
+    | `Ident longident | `Constr longident ->
+      begin try
+          begin match context with
+            | Label lbl_des ->
+              (* We use information from the context because `Env.find_label_by_name`
+              can fail *)
+              Printtyp.type_expr ppf lbl_des.lbl_arg;
+            | Type ->
+              print_type ppf env longident
+            (* TODO: special processing for module aliases ? *)
+            | Module_type ->
+              print_modtype ppf verbosity env longident
+            | Module_path ->
+              print_modpath ppf verbosity env longident
+            | Constructor _ ->
+              print_constr ppf env longident
+            | _ -> raise Fallback
+          end;
+          true
+        with _ ->
+        (* Fallback to contextless typing attempts *)
+        try
+          print_expr e;
+          true
+        with exn -> try
+            print_modpath ppf verbosity env longident;
+            true
+          with _ -> try
+              (* TODO: useless according to test suite *)
+              print_modtype ppf verbosity env longident;
+              true
+            with _ -> try
+                (* TODO: useless according to test suite *)
+                print_constr ppf env longident;
+                true
+              with _ -> print_exn ppf exn; false
+      end
+
+    | `Other ->
+      try print_expr e; true
+      with exn -> print_exn ppf exn; false
+
+let print_constr ~verbosity env ppf cd =
+  Printtyp.wrap_printing_env env ~verbosity @@ fun () ->
+  print_cstr_desc ppf cd
+
+(* From doc-ock
+   https://github.com/lpw25/doc-ock/blob/master/src/docOckAttrs.ml *)
+let read_doc_attributes attrs =
+  let rec loop = function
+    | ({Location.txt =
+          ("doc" | "ocaml.doc"); loc = _}, payload) :: _ ->
+      Ast_helper.extract_str_payload payload
+    | _ :: rest -> loop rest
+    | [] -> None
+  in
+  loop (List.map ~f:Ast_helper.Attr.as_tuple attrs)
+
+let is_deprecated =
+  List.exists ~f:(fun (attr : Parsetree.attribute) ->
+      match Ast_helper.Attr.as_tuple attr with
+      | {Location.txt =
+           ("deprecated" | "ocaml.deprecated"); loc = _}, _ ->
+        true
+      | _ -> false)
diff --git a/src/analysis/type_utils.mli b/src/analysis/type_utils.mli
new file mode 100644
index 0000000..ac997ba
--- /dev/null
+++ b/src/analysis/type_utils.mli
@@ -0,0 +1,74 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+
+val verbosity : int ref
+
+module Printtyp : sig
+  include module type of struct include Printtyp end
+
+  val type_declaration :
+    Env.t -> Ident.t -> Format.formatter -> Types.type_declaration -> unit
+
+  val type_scheme : Env.t -> Format.formatter -> Types.type_expr -> unit
+
+  val modtype : Env.t -> Format.formatter -> Types.module_type -> unit
+
+  val wrap_printing_env : Env.t -> verbosity:int -> (unit -> 'a) -> 'a
+end
+
+val mod_smallerthan : int -> Types.module_type -> int option
+(** Check if module is smaller (= has less definition, counting nested ones)
+    than a particular threshold. Return (Some n) if module has size n, or None
+    otherwise (module is bigger than threshold).
+    Used to skip printing big modules in completion. *)
+
+val type_in_env : ?verbosity:int -> ?keywords:Lexer_raw.keywords ->
+  context: Context.t -> Env.t -> Format.formatter -> string -> bool
+(** [type_in_env env ppf input] parses [input] and prints its type on [ppf].
+    Returning true if it printed a type, false otherwise. *)
+
+val print_type_with_decl : verbosity:int ->
+  Env.t -> Format.formatter -> Types.type_expr -> unit
+(** [print_type_or_decl] behaves like [Printtyp.type_scheme], it prints the
+    type expression, except if it is a type constructor and verbosity is set then
+    it also prints the type declaration. *)
+
+val lookup_module : Longident.t ->
+  Env.t -> Path.t * Types.module_type * Parsetree.attributes
+(** [lookup_module] is a fancier version of [Env.lookup_module] that also
+    returns the module type. *)
+
+val read_doc_attributes : Parsetree.attributes -> (string * Location.t) option
+(** [read_doc_attributes] looks for a docstring in an attribute list. *)
+
+val is_deprecated : Parsetree.attributes -> bool
+
+val print_constr : verbosity:int -> Env.t -> Format.formatter ->
+  Types.constructor_description -> unit
diff --git a/src/analysis/typedtrie.ml b/src/analysis/typedtrie.ml
new file mode 100644
index 0000000..d9c77e3
--- /dev/null
+++ b/src/analysis/typedtrie.ml
@@ -0,0 +1,851 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+open Browse_tree
+open Browse_raw
+
+let {Logger. log} = Logger.for_section "typedtrie"
+
+(* That's probably overkill, using a list would probably be just fine *)
+module StampMap = Map.Make(struct
+    type t = int
+    let compare (x : int) (y: int) = compare x y
+  end)
+
+module Trie : sig
+  [@@@ocaml.warning "-30"]
+
+  type t
+
+  and elt =
+    { loc : Location.t
+    ; doc : string option
+    ; namespace : Namespaced_path.Namespace.t
+    ; node : node }
+
+  and node =
+    | Leaf
+    | Internal of t Lazy.t
+    | Included of include_
+    | Alias    of Namespaced_path.t
+    | Functor  of functor_parameter * node
+    | Apply    of functor_application
+
+  and include_ =
+    | Named of Namespaced_path.t
+    | Items of t Lazy.t
+    | Apply of functor_application
+
+  and functor_parameter =
+    (Ident.t option * Location.t * node) option
+
+  and functor_application =
+    { funct : Location.t * functor_
+    ; arg   : Location.t * node }
+    (* The day where we want to support aliasing of functor arguments then arg
+       should be [elt] instead of [node] *)
+
+  and functor_ =
+    | Apply of functor_application
+    | Funct of functor_parameter * node
+    | Named of Namespaced_path.t
+    | Unpack
+
+  val empty : t
+
+  val add : Ident.t -> elt -> t -> t
+
+  val singleton : Ident.t -> elt -> t
+
+  val iter : (name:string -> stamp:int -> elt -> unit) -> t -> unit
+
+  val get : Namespaced_path.Id.t -> t -> elt list
+
+  val find_some :
+    (string -> int -> elt -> bool) -> t -> (string * int * elt) option
+end = struct
+  [@@@ocaml.warning "-30"]
+
+  type t = elt StampMap.t String.Map.t
+
+  and elt =
+    { loc : Location.t
+    ; doc : string option
+    ; namespace : Namespaced_path.Namespace.t
+    ; node : node }
+
+  (* This sort of merges [Types.module_type] and [Types.signature_item].
+     [Mty_ident] and [Mty_alias] are merged (into [Alias])) because from the
+     point of view of locate there's no difference between them.
+     [Included] is used to remember the origin of things
+     Most of the constructors of [signature_item] are represented by a [Leaf]
+     node. *)
+  and node =
+    | Leaf
+    | Internal of t Lazy.t
+    | Included of include_
+    | Alias    of Namespaced_path.t
+    | Functor  of functor_parameter * node
+    | Apply    of functor_application
+
+  and include_ = (* simply a subset of node. *)
+    | Named of Namespaced_path.t
+    | Items of t Lazy.t
+    | Apply of functor_application
+
+  and functor_parameter =
+    (Ident.t option * Location.t * node) option
+
+  and functor_application =
+    { funct : Location.t * functor_
+    ; arg   : Location.t * node }
+
+  and functor_ =
+    | Apply of functor_application
+    | Funct of functor_parameter * node
+    | Named of Namespaced_path.t
+    | Unpack
+
+  let empty = String.Map.empty
+
+  let add id elt t =
+    let key = Ident.name id in
+    match String.Map.find key t with
+    | exception Not_found ->
+      String.Map.add ~key ~data:(StampMap.singleton (Ident.stamp id) elt) t
+    | stamp_map ->
+      (* no replace? :'( *)
+      String.Map.add (String.Map.remove key t) ~key
+        ~data:(StampMap.add (Ident.stamp id) elt stamp_map)
+
+  let singleton id node = add id node empty
+
+  let iter f t =
+    String.Map.iter t ~f:(fun ~key:name ~data ->
+      StampMap.iter (fun stamp elt ->
+        f ~name ~stamp elt
+      ) data
+    )
+
+  let get (k : Namespaced_path.Id.t) t =
+    match k with
+    | Id id ->
+      [ StampMap.find (Ident.stamp id)
+          (String.Map.find (Ident.name id) t) ]
+    | String s ->
+      List.map (StampMap.bindings (String.Map.find s t)) ~f:snd
+
+  exception Found of string * int * elt
+
+  let find f (t : t) =
+    try
+      iter (fun ~name ~stamp data ->
+        if f name stamp data then
+          raise (Found (name, stamp, data))
+      ) t;
+      raise Not_found
+    with
+    | Found (name, stamp, data) -> name, stamp, data
+
+  let find_some f t =
+    try Some (find f t)
+    with Not_found -> None
+end
+
+type t = Trie.t
+
+let extract_doc (attrs : Parsetree.attributes) =
+  String.concat ~sep:"\n" (
+    List.filter_map attrs ~f:(fun attr ->
+      Option.map ~f:fst (Type_utils.read_doc_attributes [attr])
+    )
+  )
+
+
+let remove_top_indir =
+  List.concat_map ~f:(fun bt ->
+    match bt.t_node with
+    | Signature _
+    | Structure _ -> Lazy.force bt.t_children
+    | _ -> [ bt ]
+  )
+
+let of_structure s =
+  let env, node = Mbrowse.leaf_node (Mbrowse.of_structure s) in
+  Browse_tree.of_node ~env node
+
+let of_signature s =
+  let env, node = Mbrowse.leaf_node (Mbrowse.of_signature s) in
+  Browse_tree.of_node ~env node
+
+let remove_indir_me me =
+  match me.Typedtree.mod_desc with
+  | Typedtree.Tmod_ident (path, _) -> `Alias path
+  | Typedtree.Tmod_structure str -> `Str str
+  | Typedtree.Tmod_functor _ ->
+    let (fp,me) = Typedtree.unpack_functor_me me in
+    `Functor (fp, `Mod_expr me)
+  | Typedtree.Tmod_apply (me1, me2, _) -> `Apply (me1, me2)
+  | Typedtree.Tmod_constraint (me, _, _, _) -> `Mod_expr me
+  | Typedtree.Tmod_unpack _ -> `Unpack
+  | Typedtree.Tmod_hole -> `Hole
+
+let remove_indir_mty mty =
+  match mty.Typedtree.mty_desc with
+  | Typedtree.Tmty_alias (path, _) -> `Alias path
+  | Typedtree.Tmty_ident (path, _) -> `Ident path
+  | Typedtree.Tmty_signature sg -> `Sg sg
+  | Typedtree.Tmty_functor _ ->
+    let (fp,mty) = Typedtree.unpack_functor_mty mty in
+    `Functor (fp, `Mod_type mty)
+  | Typedtree.Tmty_with (mty, _) -> `Mod_type mty
+  | Typedtree.Tmty_typeof me -> `Mod_expr me
+
+let sig_item_idns item =
+  let open Types in
+  let ns =
+    match item with
+    | Sig_value _ -> `Vals
+    | Sig_type _ -> `Type
+    | Sig_typext _ -> `Type
+    | Sig_module _ -> `Mod
+    | Sig_modtype _ -> `Modtype
+    | Sig_class _ -> `Vals (* that's just silly *)
+    | Sig_class_type _ -> `Type (* :_D *)
+  in
+  signature_item_id item, ns
+
+let include_idents l = List.map ~f:sig_item_idns l
+
+let identify_str_includes item =
+  match item.Typedtree.str_desc with
+  | Typedtree.Tstr_include { Typedtree. incl_type ; incl_mod ; _ } ->
+    `Included (include_idents incl_type, `Mod_expr incl_mod)
+  | _ -> `Not_included
+
+let identify_sig_includes item =
+  match item.Typedtree.sig_desc with
+  | Typedtree.Tsig_include { Typedtree. incl_type ; incl_mod ; _ } ->
+    `Included (include_idents incl_type, `Mod_type incl_mod)
+  | _ -> `Not_included
+
+let rec build ~local_buffer ~trie browses : t =
+  let rec node_for_direct_mod namespace : _ -> Trie.node = function
+    | `Alias path -> Alias (Namespaced_path.of_path ~namespace path)
+    | `Ident path -> Alias (Namespaced_path.of_path ~namespace:`Modtype path)
+    | `Str s ->
+      Internal (lazy (build ~local_buffer ~trie:Trie.empty [of_structure s]))
+    | `Sg s ->
+      Internal (lazy (build ~local_buffer ~trie:Trie.empty [of_signature s]))
+    | `Mod_expr me -> node_for_direct_mod `Mod (remove_indir_me me)
+    | `Mod_type mty -> node_for_direct_mod `Modtype (remove_indir_mty mty)
+    | `Functor (fp, packed) ->
+      let param = match fp with
+        | Typedtree.Unit -> None
+        | Typedtree.Named (id, loc, mty) ->
+          let mty =
+            if local_buffer
+            then node_for_direct_mod `Modtype (remove_indir_mty mty)
+            else Trie.Leaf
+          in
+          Some (id, loc.Location.loc, mty)
+      in
+      Functor (param, node_for_direct_mod `Mod packed)
+    | `Apply (funct, arg) ->
+      let funct = funct.Typedtree.mod_loc, functor_ (remove_indir_me funct) in
+      let arg =
+        arg.Typedtree.mod_loc,
+        match remove_indir_me arg with
+        | `Str { str_items = []; _ } -> Trie.Leaf
+        | otherwise -> node_for_direct_mod `Mod otherwise
+      in
+      Apply { funct; arg }
+    | `Unpack -> (* TODO! *)
+      Leaf
+    | `Hole ->
+      Leaf
+  and functor_ : _ -> Trie.functor_ = function
+    | `Alias path
+    | `Ident path -> Named (Namespaced_path.of_path ~namespace:`Mod path)
+    | `Str _
+    | `Hole
+    | `Sg _ -> assert false
+    | `Mod_expr me -> functor_ (remove_indir_me me)
+    | `Mod_type _ -> assert false
+    | `Functor (fp, packed) ->
+      let param = match fp with
+        | Typedtree.Unit -> None
+        | Typedtree.Named (id, loc, mty) ->
+          let mty =
+            if local_buffer
+            then node_for_direct_mod `Modtype (remove_indir_mty mty)
+            else Trie.Leaf
+          in
+          Some (id, loc.Location.loc, mty)
+      in
+      Funct (param, node_for_direct_mod `Mod packed)
+    | `Apply (funct, arg) ->
+      let funct = funct.Typedtree.mod_loc, functor_ (remove_indir_me funct) in
+      let arg =
+        arg.Typedtree.mod_loc, node_for_direct_mod `Mod (remove_indir_me arg)
+      in
+      Apply { funct; arg }
+    | `Unpack -> Unpack
+  in
+  List.fold_left (remove_top_indir browses) ~init:trie ~f:(fun trie t ->
+    let open Typedtree in
+    let doc =
+      let attrs = node_attributes t.t_node in
+      let doc = extract_doc attrs in
+      if doc = "" then None else Some doc
+    in
+    match t.t_node with
+    | Signature _
+    | Structure _ ->
+      (* Removed by [get_top_items] *)
+      assert false
+    | Signature_item _
+    | Structure_item _ ->
+      begin match
+        match t.t_node with
+        | Signature_item (item, _) -> identify_sig_includes item
+        | Structure_item (item, _) -> identify_str_includes item
+        | _ -> assert false
+      with
+      | `Not_included -> build ~local_buffer ~trie (Lazy.force t.t_children)
+      | `Included (included_idents, packed) ->
+        let rec helper packed =
+          let f node =
+            List.fold_left included_idents ~init:trie ~f:(fun trie (id, ns) ->
+              Trie.add id
+                { loc = t.t_loc; doc = None; namespace = ns; node } trie
+            )
+          in
+          match
+            match packed with
+            | `Mod_expr me -> remove_indir_me  me
+            | `Mod_type mt -> remove_indir_mty mt
+          with
+          | `Alias path ->
+            let namespace =
+              match packed with
+              | `Mod_expr _ -> `Mod
+              | `Mod_type _ -> `Modtype
+            in
+            let p = Namespaced_path.of_path ~namespace path in
+            f (Included (Named p))
+          | `Ident p ->
+            let p = Namespaced_path.of_path ~namespace:`Modtype p in
+            f (Included (Named p))
+          | `Mod_type _
+          | `Mod_expr _ as packed -> helper packed
+          | `Functor _ ->
+            (* You can't include a functor, you can only include "structures". *)
+            assert false
+          | `Unpack -> f Leaf
+          | `Apply (funct, arg) ->
+            let funct =
+              funct.Typedtree.mod_loc, functor_ (remove_indir_me funct)
+            in
+            let arg =
+              arg.Typedtree.mod_loc,
+              node_for_direct_mod `Mod (remove_indir_me arg)
+            in
+            f (Included (Apply { funct; arg }))
+          | `Str str ->
+            let str = lazy (build ~local_buffer ~trie [of_structure str]) in
+            f (Included (Items str))
+          | `Sg  sg ->
+            let sg = lazy (build ~local_buffer ~trie [of_signature sg]) in
+            f (Included (Items sg))
+          | `Hole -> f Leaf
+        in
+        helper packed
+      end
+    | Value_binding vb ->
+      let trie =
+        List.fold_left ~init:trie ~f:(fun trie (id, { Asttypes.loc; _ }, _) ->
+            Trie.add id {loc; doc; namespace = `Vals; node = Leaf} trie
+        ) (Typedtree.pat_bound_idents_full vb.vb_pat)
+      in
+      if not local_buffer then
+        trie
+      else (
+        let id = Ident.create_local "?" in
+        let intern =
+          lazy (build ~local_buffer ~trie:Trie.empty (Lazy.force t.t_children))
+        in
+        let extra_children : Trie.elt =
+          { loc = t.t_loc
+          ; doc = None
+          ; namespace = `Unknown
+          ; node = Internal intern }
+        in
+        Trie.add id extra_children trie
+      )
+    | Value_description vd ->
+      Trie.add vd.val_id
+        { loc = t.t_loc; doc; namespace = `Vals; node = Leaf } trie
+    | Module_binding mb ->
+      let node =
+        node_for_direct_mod `Mod
+          (remove_indir_me mb.mb_expr)
+      in
+      begin match mb.mb_id with
+        | None -> trie
+        | Some id ->
+          Trie.add id { loc=t.t_loc; doc; namespace=`Mod; node } trie
+      end
+    | Module_declaration md ->
+      let node =
+        node_for_direct_mod `Mod
+          (remove_indir_mty md.md_type)
+      in
+      begin match md.md_id with
+        | None -> trie
+        | Some id ->
+          Trie.add id { loc=t.t_loc; doc; namespace=`Mod; node } trie
+      end
+    | Module_type_declaration mtd ->
+      let node =
+        match mtd.mtd_type with
+        | None -> Trie.Leaf
+        | Some m -> node_for_direct_mod `Modtype (remove_indir_mty m)
+      in
+      Trie.add mtd.mtd_id
+        { loc=t.t_loc; doc; namespace=`Modtype; node } trie
+    | Type_declaration td ->
+      (* TODO: add constructors and labels as well.
+         Because why the hell not. *)
+      Trie.add td.typ_id
+        { loc = t.t_loc; doc; namespace = `Type; node = Leaf } trie
+    | Type_extension te ->
+      List.fold_left ~init:trie ~f:(fun trie ec ->
+        Trie.add ec.ext_id
+          { loc = t.t_loc; doc; namespace = `Type; node = Leaf } trie
+      ) te.tyext_constructors
+    | Extension_constructor ec ->
+      Trie.add ec.ext_id
+        { loc = t.t_loc; doc; namespace = `Type; node = Leaf } trie
+    | Case _
+    | Expression _ when local_buffer ->
+      build ~local_buffer ~trie (Lazy.force t.t_children)
+    | Pattern p when local_buffer ->
+      List.fold_left ~init:trie ~f:(fun trie (id, { Asttypes.loc; _ }, _) ->
+          Trie.add id {loc; doc; namespace = `Vals; node = Leaf} trie
+      ) (Typedtree.pat_bound_idents_full p)
+    | ignored_node ->
+      log ~title:"build" "ignored node: %t"
+        (fun () -> string_of_node ignored_node);
+      trie
+  )
+
+let of_browses ?(local_buffer=false) browses =
+  build ~local_buffer ~trie:Trie.empty browses
+
+type scopes = (t * Lexing.position option) list
+
+type functor_argument =
+  | Handled of Namespaced_path.t * scopes
+  | Noop (* used for generative functors… and non handled constructions *)
+
+type substitution =
+  { old_prefix : Namespaced_path.t
+  ; new_prefix : Namespaced_path.t
+  ; scopes     : scopes }
+
+(* See mli for documentation. *)
+type result =
+  | Found of Location.t * string option
+  | Resolves_to of Namespaced_path.t * state
+
+and state =
+  { substs : substitution list
+  ; functor_arguments : functor_argument list
+  }
+
+let rec follow ~remember_loc ~state scopes ?before trie path =
+  let trie, before, path, scopes, state =
+    let rec try_substing_once path = function
+      | [] -> None
+      | { old_prefix; new_prefix; scopes } as subst :: substs ->
+        match Namespaced_path.subst_prefix ~old_prefix ~new_prefix path with
+        | Some new_path -> Some (new_path, scopes, substs)
+        | None ->
+          match try_substing_once path substs with
+          | None -> None
+          | Some (new_path, scopes, remaining_substs) ->
+            Some (new_path, scopes, subst :: remaining_substs)
+    in
+    (* exponential but terminates: at each new step [substs] will have lost one
+       element. *)
+    let rec try_substing (path, _, substs as acc) =
+      match try_substing_once path substs with
+      | None -> acc
+      | Some new_acc -> try_substing new_acc
+    in
+    let init = (path, (trie, before) :: scopes, state.substs) in
+    let res = try_substing init in
+    if res == init then
+      trie, before, path, scopes, state
+    else
+      match res with
+      | path, (trie, before) :: scopes, substs ->
+        trie, before, path, scopes, { state with substs }
+      | _ -> assert false
+  in
+  let try_next_scope () =
+    match scopes with
+    | [] -> Resolves_to (path, state) (* no englobing scope, give up *)
+    | (trie, before) :: scopes ->
+      follow ~remember_loc ~state scopes ?before trie path
+  in
+  match Namespaced_path.head_exn path with
+  | Applied_to path ->
+    (* FIXME: That's wrong. The scope should be the one where the query was
+       emitted. Not the point where we finally arrive on the application. *)
+    let functor_argument =
+      let scopes = (trie, before) :: scopes in
+      Handled (path, scopes)
+    in
+    let state =
+      { state with
+        functor_arguments = functor_argument :: state.functor_arguments
+      }
+    in
+    let new_path = Namespaced_path.peal_head_exn path in
+    log ~title:"applicative path" "%s"
+      (Namespaced_path.to_unique_string new_path);
+    follow ~remember_loc ~state scopes ?before trie new_path
+  | Ident (x, namespace) ->
+    try
+      let lst = Trie.get x trie in
+      let lst =
+        List.filter lst
+          ~f:(fun { Trie.namespace = ns; _ } -> ns = namespace || ns = `Unknown)
+      in
+      let lst =
+        match before with
+        | None -> lst
+        | Some before ->
+          List.filter lst ~f:(fun { Trie.loc; _ } ->
+            Lexing.compare_pos loc.Location.loc_start before < 0)
+      in
+      match
+        List.sort lst ~cmp:(fun { Trie.loc = l1; _ } { loc = l2; _ } ->
+          (* We wants the ones closed last to be at the beginning of the list. *)
+          Lexing.compare_pos l2.Location.loc_end l1.Location.loc_end)
+      with
+      | [] -> try_next_scope ()
+      | { loc; doc; node; namespace = _ } :: _ ->
+        let inspect_functor_arg : Trie.node -> _ = function
+          | Leaf -> Noop (* fuck it eh. *)
+          | Internal (lazy trie) ->
+            let scopes =
+              (trie, None) :: (trie, Some loc.Location.loc_start) :: scopes
+            in
+            Handled (Namespaced_path.empty, scopes)
+          | Included _ -> assert false (* that surely can't happen *)
+          | Alias path ->
+            let scopes = (trie, Some loc.Location.loc_start) :: scopes in
+            Handled (path, scopes)
+          | Functor _ ->
+            (* TODO *)
+            log ~title:"inspect_functor_arg"
+              "NOT HANDLED: functor given as functor argument";
+            Noop
+          | Apply _ ->
+            (* TODO *)
+            Noop
+        in
+        let rec inspect_functor path state : Trie.functor_ -> _ = function
+          | Named new_prefix ->
+            let path = Namespaced_path.rewrite_head ~new_prefix path in
+            log ~title:"inspect_functor" "resolves to %s"
+              (Namespaced_path.to_unique_string path);
+            follow ~remember_loc ~state ~before:loc.Location.loc_start scopes
+              trie path
+          | Unpack ->
+            log ~title:"inspect_functor" "Unpack";
+            Found (loc, doc)
+          | Funct _ -> assert false (* TODO *)
+          | Apply { funct; arg } ->
+            log ~title:"inspect_functor" "functor application";
+            let functor_argument = inspect_functor_arg (snd arg) in
+            let state =
+              { state with
+                functor_arguments = functor_argument :: state.functor_arguments
+              }
+            in
+            inspect_functor path state (snd funct)
+        in
+        let rec inspect_node state = function
+          | Trie.Leaf ->
+            (* we're not checking whether [xs = []] here, as we wouldn't be able to
+              lookup anything else which would be correct I think.
+              [xs] can be non-nil in this case when [x] is a first class module.
+              ... and perhaps in other situations I am not aware of.  *)
+            Found (loc, doc)
+          | Alias new_prefix ->
+            log ~title:"aliased" "%s%s= %s"
+              (Namespaced_path.Id.name x)
+              (Namespaced_path.Namespace.to_string namespace)
+              (Namespaced_path.to_unique_string new_prefix);
+            let path = Namespaced_path.peal_head_exn path in
+            let new_path = Namespaced_path.rewrite_head ~new_prefix path in
+            remember_loc loc;
+            follow ~remember_loc ~state ~before:loc.Location.loc_start scopes
+              trie new_path
+          | Included include_ ->
+            remember_loc loc;
+            let stampless = Namespaced_path.strip_stamps path in
+            begin match include_ with
+            | Named new_prefix ->
+              let path = Namespaced_path.rewrite_head ~new_prefix stampless in
+              log ~title:"include" "resolves to %s"
+                (Namespaced_path.to_unique_string path);
+              follow ~remember_loc ~state ~before:loc.Location.loc_start scopes
+                trie path
+            | Items t ->
+              follow ~remember_loc ~state scopes (Lazy.force t) stampless
+            | Apply { funct; arg } ->
+              log ~title:"include" "functor application";
+              let functor_argument = inspect_functor_arg (snd arg) in
+              let state =
+                { state with
+                  functor_arguments =
+                    functor_argument :: state.functor_arguments }
+              in
+              inspect_functor stampless state (snd funct)
+            end
+          | Internal t ->
+            let path = Namespaced_path.peal_head_exn path in
+            begin match Namespaced_path.head path with
+            | None -> Found (loc, doc)
+            | Some _ ->
+              let scopes = (trie, Some loc.Location.loc_start) :: scopes in
+              follow ~remember_loc ~state ?before scopes (Lazy.force t) path
+            end
+          | Functor (param, node) ->
+            log ~title:"node" "functor";
+            let path = Namespaced_path.peal_head_exn path in
+            begin match Namespaced_path.head path with
+            | None -> Found (loc, doc)
+            | _ ->
+              let state =
+                match state.functor_arguments with
+                | [] ->
+                  (* We can never end up inside a functor without having seen an
+                    application first. *)
+                  assert false
+                | Noop :: functor_arguments ->
+                  { state with functor_arguments }
+                | Handled (new_prefix, scopes) :: functor_arguments ->
+                  let id = match param with
+                    | None | Some (None, _, _) -> assert false (* sigh. *)
+                    | Some (Some id, _, _) -> id
+                  in
+                  let subst =
+                    { old_prefix =
+                        Namespaced_path.of_path ~namespace:`Mod (Pident id)
+                    ; new_prefix
+                    ; scopes }
+                  in
+                  { substs = subst :: state.substs; functor_arguments }
+              in
+              inspect_node state node
+            end
+          | Apply { funct; arg } ->
+            let path = Namespaced_path.peal_head_exn path in
+            begin match Namespaced_path.head path with
+            | None -> Found (loc, doc)
+            | Some _ ->
+              log ~title:"functor application" "";
+              let functor_argument = inspect_functor_arg (snd arg) in
+              let state =
+                { state with
+                  functor_arguments = functor_argument :: state.functor_arguments
+                }
+              in
+              inspect_functor path state (snd funct)
+            end
+        in
+        inspect_node state node
+    with
+    | Not_found ->
+      try_next_scope ()
+
+let initial_state = { substs = []; functor_arguments = [] }
+
+let rec find ~remember_loc ~before scopes trie path =
+  match
+    Trie.find_some (fun _name _stmap { loc; _ } ->
+      Lexing.compare_pos loc.Location.loc_start before < 0
+      && Lexing.compare_pos loc.Location.loc_end before > 0
+    ) trie
+  with
+  | None ->
+    log ~title:"find" "didn't find anything";
+    follow ~state:initial_state ~remember_loc ~before scopes trie path
+  | Some (_name, _stamp, { Trie.loc; node; _ }) ->
+    log ~title:"find" "inspecting %s" _name;
+    let rec inspect_node scopes : Trie.node -> _ = function
+      | Internal (lazy subtrie)  ->
+        let scopes = (trie, Some loc.Location.loc_start) :: scopes in
+        find ~remember_loc ~before scopes subtrie path
+      | Functor (None, fnode) -> inspect_node scopes fnode
+      | Functor (Some (id, ploc, node), fnode) ->
+        let param =
+          match id with
+          | None -> Trie.empty
+          | Some id ->
+            Trie.singleton id { loc = ploc; doc = None; namespace = `Mod; node }
+        in
+        if
+          Lexing.compare_pos ploc.Location.loc_start before < 0
+          && Lexing.compare_pos ploc.Location.loc_end before > 0
+        then
+          let scopes = (trie, Some loc.Location.loc_start) :: scopes in
+          find ~remember_loc ~before scopes param path
+        else
+          let scopes = (param, Some ploc.Location.loc_end) :: scopes in
+          inspect_node scopes fnode
+      | Apply { funct = (floc, f); arg = (_aloc, a) } ->
+        let scopes = (trie, Some loc.Location.loc_start) :: scopes in
+        if
+          Lexing.compare_pos floc.Location.loc_start before < 0
+          && Lexing.compare_pos floc.Location.loc_end before > 0
+        then
+          inspect_functor scopes f
+        else
+          inspect_node scopes a
+      | Leaf
+      | Included _
+      | Alias _ ->
+        (* FIXME: not quite right (i.e. not necessarily a leaf). *)
+        log ~title:"find" "cursor in a leaf, so we look only before the leaf";
+        follow ~state:initial_state ~remember_loc ~before:loc.Location.loc_start
+          scopes trie path
+    and inspect_functor scopes : Trie.functor_ -> _ = function
+      | Funct (None, fnode) -> inspect_node scopes fnode
+      | Funct (Some (id, ploc, node), fnode) ->
+        let param =
+          match id with
+          | None -> Trie.empty
+          | Some id ->
+            Trie.singleton id { loc = ploc; doc = None; namespace = `Mod; node }
+        in
+        if
+          Lexing.compare_pos ploc.Location.loc_start before < 0
+          && Lexing.compare_pos ploc.Location.loc_end before > 0
+        then
+          let scopes = (trie, Some loc.Location.loc_start) :: scopes in
+          find ~remember_loc ~before scopes param path
+        else
+          let scopes = (param, Some ploc.Location.loc_end) :: scopes in
+          inspect_node scopes fnode
+      | Apply { funct = (floc, f); arg = (_aloc, a) } ->
+        let scopes = (trie, Some loc.Location.loc_start) :: scopes in
+        if
+          Lexing.compare_pos floc.Location.loc_start before < 0
+          && Lexing.compare_pos floc.Location.loc_end before > 0
+        then
+          inspect_functor scopes f
+        else
+          inspect_node scopes a
+      | Unpack
+      | Named _ ->
+        (* FIXME: not quite right (i.e. not necessarily a leaf). *)
+        log ~title:"find" "cursor in a leaf, so we look only before the leaf";
+        follow ~state:initial_state ~remember_loc ~before:loc.Location.loc_start
+          scopes trie path
+    in
+    inspect_node scopes node
+
+type context =
+  | Initial of Lexing.position
+  | Resume of state
+
+let rec dump fmt trie =
+  let open Trie in
+  let rec dump_node fmt = function
+    | Leaf -> ()
+    | Included Named path ->
+      Format.fprintf fmt " <%s>" (Namespaced_path.to_string path)
+    | Alias path ->
+      Format.fprintf fmt " = %s" (Namespaced_path.to_string path)
+    | Included Items t
+    | Internal t ->
+      if Lazy.is_val t then
+        Format.fprintf fmt " = %a" dump (Lazy.force t)
+      else
+        Format.fprintf fmt " = <lazy>"
+    | Functor ((None | Some (None, _, _)), node) ->
+      Format.fprintf fmt " () ->%a" dump_node node
+    | Functor (Some (Some id, _, _), node) ->
+      Format.fprintf fmt " %s ->%a" (Ident.name id)
+        dump_node node
+    | Included Apply { funct; arg }
+    | Apply { funct; arg } ->
+      Format.fprintf fmt " %a(%a)" dump_functor funct dump_node (snd arg)
+  and dump_functor fmt (_loc, funct) =
+    match funct with
+    | Apply { funct; arg } ->
+      Format.fprintf fmt " %a(%a)" dump_functor funct dump_node (snd arg)
+    | Funct ((None | Some (None, _, _)), node) ->
+      Format.fprintf fmt " () ->%a" dump_node node
+    | Funct (Some (Some id, _, _), node) ->
+      Format.fprintf fmt " %s ->%a" (Ident.name id) dump_node node
+    | Named path ->
+      Format.fprintf fmt " = %s" (Namespaced_path.to_string path)
+    | Unpack ->
+      Format.fprintf fmt " !unpack!"
+  in
+  let dump_elt {loc; namespace; node; _} =
+    Format.pp_print_string fmt (Namespaced_path.Namespace.to_string namespace);
+    Location.print_loc fmt loc;
+    dump_node fmt node
+  in
+  Format.pp_print_string fmt "{\n" ;
+  Trie.iter (fun ~name ~stamp elt ->
+    Format.fprintf fmt "%s/%d -> " name stamp ;
+    dump_elt elt;
+    Format.pp_print_newline fmt ()
+  ) trie;
+  Format.pp_print_string fmt "}\n"
+
+let find ~remember_loc ~context trie path =
+  match context with
+  | Initial before ->
+    log ~title:"initial find"
+      "before %s, trie: %a"
+      (Lexing.print_position () before)
+      Logger.fmt (fun fmt -> dump fmt trie);
+    find ~remember_loc ~before [] trie path
+  | Resume   state -> follow ~remember_loc ~state [] trie path
diff --git a/src/analysis/typedtrie.mli b/src/analysis/typedtrie.mli
new file mode 100644
index 0000000..12319d9
--- /dev/null
+++ b/src/analysis/typedtrie.mli
@@ -0,0 +1,72 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+type t
+
+val of_browses : ?local_buffer:bool -> Browse_tree.t list -> t
+(** Constructs a trie from a list of [BrowseT.t].
+
+    If [?local_buffer] is [false] (the default) functor declaration, functor
+    application and value bindings will be leafs of the trie.
+    Otherwise they will be internal nodes; children of a value binding are local
+    module bindings (and their children). This is because [find] (see below)
+    first goes down the trie according to its [Lexing.position] parameter,
+    disregarding the path.
+    We don't create such nodes when [?local_buffer] is false because there is no
+    [cursor] in this case, so we can't be inside an expression, or a functor, …
+*)
+
+type state
+
+type context =
+  | Initial of Lexing.position
+  | Resume of state
+
+type result =
+  | Found of Location.t * string option
+    (** Found at location *)
+  | Resolves_to of Namespaced_path.t * state
+    (** Not found in trie, look for [path] in loadpath. *)
+
+val find
+   : remember_loc:(Location.t -> unit)
+  -> context:context
+  -> t
+  -> Namespaced_path.t
+  -> result
+(** [find ?before t path] starts by going down in [t] following branches
+    enclosing [before]. Then it will behave as [follow ?before].
+    If [follow] returns [Resolves_to (p, _)] it will go back up in the trie, and
+    will try to [follow] again with [before] set to the the start of the node we
+    just got up from.
+
+    @param remember_loc is used to capture a trace of the indirections that we
+    traverse. *)
+
+(* For debugging purposes. *)
+val dump : Format.formatter -> t -> unit
diff --git a/src/config/dune b/src/config/dune
new file mode 100644
index 0000000..ddd826e
--- /dev/null
+++ b/src/config/dune
@@ -0,0 +1,10 @@
+(rule
+ (targets my_config.ml)
+ (deps gen_config.ml)
+ (action (with-stdout-to %{targets}
+          (run %{ocaml} gen_config.ml %{ocaml_version}))))
+
+(library
+ (name config)
+ (wrapped false)
+ (modules my_config))
diff --git a/src/config/gen_config.ml b/src/config/gen_config.ml
new file mode 100644
index 0000000..3b38b32
--- /dev/null
+++ b/src/config/gen_config.ml
@@ -0,0 +1,20 @@
+let ocaml_version_val =
+  match
+    Scanf.sscanf Sys.argv.(1) "%s@.%s@.%d" (fun maj min p -> maj, min, p)
+  with
+  | "4", "02", _ ->
+      "`OCaml_4_02_3"
+  | "4", "07", p ->
+      Printf.sprintf "`OCaml_4_07_%d" p
+  | maj, min, _ ->
+      Printf.sprintf "`OCaml_%s_%s_0" maj min
+
+let () =
+  Printf.printf {|
+let version = "%%VERSION%%"
+let ocamlversion :
+  [ `OCaml_4_02_0 | `OCaml_4_02_1 | `OCaml_4_02_2 | `OCaml_4_02_3
+  | `OCaml_4_03_0 | `OCaml_4_04_0 | `OCaml_4_05_0 | `OCaml_4_06_0
+  | `OCaml_4_07_0 | `OCaml_4_07_1 | `OCaml_4_08_0 | `OCaml_4_09_0
+  | `OCaml_4_10_0 | `OCaml_4_11_0 | `OCaml_4_12_0 | `OCaml_4_13_0 ] = %s
+|} ocaml_version_val
diff --git a/src/dot-merlin/dot-protocol/dot_protocol.ml b/src/dot-merlin/dot-protocol/dot_protocol.ml
new file mode 100644
index 0000000..8628c73
--- /dev/null
+++ b/src/dot-merlin/dot-protocol/dot_protocol.ml
@@ -0,0 +1,165 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2019  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                      Thomas Refis  <refis.thomas(_)gmail.com>
+                      Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Merlin_utils.Std
+open Merlin_utils.Std.Result
+
+module Directive = struct
+  type include_path =
+    [ `B of string | `S of string | `CMI of string | `CMT of string ]
+
+  type no_processing_required =
+    [ `EXT of string list
+    | `FLG of string list
+    | `STDLIB of string
+    | `SUFFIX of string
+    | `READER of string list
+    | `EXCLUDE_QUERY_DIR
+    | `UNKNOWN_TAG of string ]
+
+  module Processed = struct
+    type acceptable_in_input = [ include_path | no_processing_required ]
+
+    type t =
+      [ acceptable_in_input
+      | `ERROR_MSG of string ]
+  end
+
+  module Raw = struct
+    type t =
+      [ Processed.acceptable_in_input
+      | `PKG of string list
+      | `FINDLIB of string
+      | `FINDLIB_PATH of string
+      | `FINDLIB_TOOLCHAIN of string ]
+  end
+end
+
+type directive = Directive.Processed.t
+
+module Sexp = struct
+  type t = Atom of string | List of t list
+
+  let atoms_of_strings = List.map ~f:(fun s -> Atom s)
+
+  let strings_of_atoms =
+    List.filter_map ~f:(function Atom s -> Some s | _ -> None)
+
+  let rec to_string = function
+  | Atom s -> s
+  | List l -> String.concat ~sep:" "
+    ( List.concat [["("]; List.map ~f:to_string l;[")"]])
+
+  let to_directive sexp =
+    match sexp with
+    | List [ Atom tag; Atom value ] ->
+      begin match tag with
+        | "S" -> `S value
+        | "B" -> `B value
+        | "CMI" -> `CMI value
+        | "CMT" -> `CMT value
+        | "STDLIB" -> `STDLIB value
+        | "SUFFIX" -> `SUFFIX value
+        | "ERROR" -> `ERROR_MSG value
+        | "FLG" ->
+            (* This means merlin asked dune 2.6 for configuration.
+              But the protocole evolved, only dune 2.8 should be used *)
+            `ERROR_MSG "No .merlin file found. Try building the project."
+        | tag -> `UNKNOWN_TAG tag
+      end
+    | List [ Atom tag; List l ] ->
+        let value = strings_of_atoms l in
+        begin match tag with
+        | "EXT" -> `EXT value
+        | "FLG" -> `FLG value
+        | "READER" -> `READER value
+        | tag -> `UNKNOWN_TAG tag
+      end
+    | List [ Atom "EXCLUDE_QUERY_DIR" ] -> `EXCLUDE_QUERY_DIR
+    | _ -> `ERROR_MSG "Unexpected output from external config reader"
+
+  let from_directives (directives : Directive.Processed.t list) =
+    let f t =
+      let tag, body =
+        let single s = [ Atom s ] in
+        match t with
+        | `B s -> ("B", single s)
+        | `S s -> ("S", single s)
+        | `CMI s -> ("CMI", single s)
+        | `CMT s -> ("CMT", single s)
+        | `EXT ss -> ("EXT", [ List (atoms_of_strings ss) ])
+        | `FLG ss -> ("FLG", [ List (atoms_of_strings ss) ])
+        | `STDLIB s -> ("STDLIB", single s)
+        | `SUFFIX s -> ("SUFFIX", single s)
+        | `READER ss -> ("READER", [ List (atoms_of_strings ss) ])
+        | `EXCLUDE_QUERY_DIR -> ("EXCLUDE_QUERY_DIR", [])
+        | `UNKNOWN_TAG tag -> ("ERROR", single @@
+            Printf.sprintf "Unknown tag in .merlin: %s" tag)
+        | `ERROR_MSG s -> ("ERROR", single s)
+      in
+      List (Atom tag :: body)
+    in
+    List (List.map ~f directives)
+end
+
+module Csexp = Csexp.Make (Sexp)
+
+module Commands = struct
+  type t = File of string | Halt | Unknown
+
+  let read_input in_channel =
+    let open Sexp in
+    match Csexp.input in_channel with
+    | Ok (List [Atom "File"; Atom path]) -> File path
+    | Ok (Atom "Halt") -> Halt
+    | Ok _ -> Unknown
+    | Error _msg -> Halt
+
+  let send_file ~out_channel path =
+    Sexp.(List [Atom "File"; Atom path])
+    |> Csexp.to_channel out_channel
+end
+
+type read_error =
+  | Unexpected_output of string
+  | Csexp_parse_error of string
+
+let read ~in_channel =
+  match Csexp.input in_channel with
+  | Ok (Sexp.List directives) ->
+      Ok (List.map directives ~f:Sexp.to_directive)
+  | Ok sexp ->
+    let msg = Printf.sprintf
+      "A list of directives was expected, instead got: \"%s\""
+      (Sexp.to_string sexp)
+    in
+    Error (Unexpected_output msg)
+  | Error msg -> Error (Csexp_parse_error msg)
+
+let write ~out_channel (directives : directive list) =
+  directives |> Sexp.from_directives |> Csexp.to_channel out_channel
diff --git a/src/dot-merlin/dot-protocol/dot_protocol.mli b/src/dot-merlin/dot-protocol/dot_protocol.mli
new file mode 100644
index 0000000..e04650d
--- /dev/null
+++ b/src/dot-merlin/dot-protocol/dot_protocol.mli
@@ -0,0 +1,92 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2019  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                      Thomas Refis  <refis.thomas(_)gmail.com>
+                      Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+(* EXCLUDE_QUERY_DIR
+
+If you're building with dune, all your build artifacts will be in
+_build, any .cmi (or .cmt) that will be found next to the source file
+is likely to be a source of conflicts.
+With this directive, .merlin files generated by dune can instruct merlin
+to disregard local build artifacts.
+
+This is especially useful when working on the compiler where two build
+system coexist: dune (used for development, which will generate the
+.merlin) and make, used for the actual build and testing of the compiler.
+Build artifacts generated by the makefile build will be at a different
+version than the one produced by dune, and understood by merlin. We
+really do not want to load them. *)
+
+module Directive : sig
+  type include_path =
+    [ `B of string | `S of string | `CMI of string | `CMT of string ]
+
+  type no_processing_required =
+    [ `EXT of string list
+    | `FLG of string list
+    | `STDLIB of string
+    | `SUFFIX of string
+    | `READER of string list
+    | `EXCLUDE_QUERY_DIR
+    | `UNKNOWN_TAG of string ]
+
+  module Processed : sig
+    type acceptable_in_input = [ include_path | no_processing_required ]
+
+    type t =
+      [  acceptable_in_input
+      | `ERROR_MSG of string ]
+  end
+
+  module Raw : sig
+    type t =
+      [ Processed.acceptable_in_input
+      | `PKG of string list
+      | `FINDLIB of string
+      | `FINDLIB_PATH of string
+      | `FINDLIB_TOOLCHAIN of string ]
+  end
+end
+
+type directive = Directive.Processed.t
+
+module Commands : sig
+  type t = File of string | Halt | Unknown
+
+  val read_input : in_channel -> t
+  val send_file : out_channel:out_channel -> string -> unit
+end
+
+type read_error =
+  | Unexpected_output of string
+  | Csexp_parse_error of string
+
+(** [read inc] reads one csexp from the channel [inc] and returns the list of
+  directives it represents *)
+val read : in_channel:in_channel -> (directive list, read_error) Merlin_utils.Std.Result.t
+
+val write : out_channel:out_channel -> directive list -> unit
diff --git a/src/dot-merlin/dot-protocol/dune b/src/dot-merlin/dot-protocol/dune
new file mode 100644
index 0000000..394f376
--- /dev/null
+++ b/src/dot-merlin/dot-protocol/dune
@@ -0,0 +1,4 @@
+(library
+ (name merlin_dot_protocol)
+ (wrapped false)
+ (libraries merlin_utils csexp))
diff --git a/src/dot-merlin/dot_merlin_reader.ml b/src/dot-merlin/dot_merlin_reader.ml
new file mode 100644
index 0000000..e5fdbbf
--- /dev/null
+++ b/src/dot-merlin/dot_merlin_reader.ml
@@ -0,0 +1,488 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2019  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                      Thomas Refis  <refis.thomas(_)gmail.com>
+                      Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Merlin_utils
+open Misc
+open Std
+open Std.Result
+
+let findlib_ok =
+  try
+    Ok (Findlib.init ())
+  with exn ->
+    let message = match exn with
+      | Failure message -> message
+      | exn -> Printexc.to_string exn
+    in
+    (* This is a quick and dirty workaround to get Merlin to work even when
+       findlib directory has been removed. *)
+    begin match Sys.getenv "OCAMLFIND_CONF" with
+    | exception Not_found ->
+      Unix.putenv "OCAMLFIND_CONF" "/dev/null"
+    | _ -> ()
+    end;
+    Error ("Error during findlib initialization: " ^ message)
+
+let {Logger. log} = Logger.for_section "Mconfig_dot"
+
+type file = {
+  recurse    : bool;
+  includes   : string list;
+  path       : string;
+  directives : Dot_protocol.Directive.Raw.t list;
+}
+
+module Cache = File_cache.Make (struct
+    type t = file
+    let read path =
+      let ic = open_in path in
+      let acc = ref [] in
+      let recurse = ref false in
+      let includes = ref [] in
+      let tell l = acc := l :: !acc in
+      try
+        let rec aux () =
+          let line = String.trim (input_line ic) in
+          if line = "" then ()
+
+          else if String.is_prefixed ~by:"B " line then
+            tell (`B (String.drop 2 line))
+          else if String.is_prefixed ~by:"S " line then
+            tell (`S (String.drop 2 line))
+          else if String.is_prefixed ~by:"SRC " line then
+            tell (`S (String.drop 4 line))
+          else if String.is_prefixed ~by:"CMI " line then
+            tell (`CMI (String.drop 4 line))
+          else if String.is_prefixed ~by:"CMT " line then
+            tell (`CMT (String.drop 4 line))
+          else if String.is_prefixed ~by:"PKG " line then
+            tell (`PKG (rev_split_words (String.drop 4 line)))
+          else if String.is_prefixed ~by:"EXT " line then
+            tell (`EXT (rev_split_words (String.drop 4 line)))
+          else if String.is_prefixed ~by:"FLG " line then
+            tell (`FLG (Shell.split_command (String.drop 4 line)))
+          else if String.is_prefixed ~by:"REC" line then
+            recurse := true
+          else if String.is_prefixed ~by:". " line then
+            includes := String.trim (String.drop 2 line) :: !includes
+          else if String.is_prefixed ~by:"STDLIB " line then
+            tell (`STDLIB (String.drop 7 line))
+          else if String.is_prefixed ~by:"FINDLIB " line then
+            tell (`FINDLIB (String.drop 8 line))
+          else if String.is_prefixed ~by:"SUFFIX " line then
+            tell (`SUFFIX (String.drop 7 line))
+          else if String.is_prefixed ~by:"READER " line then
+            tell (`READER (List.rev (rev_split_words (String.drop 7 line))))
+          else if String.is_prefixed ~by:"FINDLIB_PATH " line then
+            tell (`FINDLIB_PATH (String.drop 13 line))
+          else if String.is_prefixed ~by:"FINDLIB_TOOLCHAIN " line then
+            tell (`FINDLIB_TOOLCHAIN (String.drop 18 line))
+          else if String.is_prefixed ~by:"EXCLUDE_QUERY_DIR" line then
+            tell `EXCLUDE_QUERY_DIR
+          else if String.is_prefixed ~by:"#" line then
+            ()
+          else
+            tell (`UNKNOWN_TAG (String.split_on_char ~sep:' ' line |> List.hd));
+          aux ()
+        in
+        aux ()
+      with
+      | End_of_file ->
+        close_in_noerr ic;
+        let recurse = !recurse and includes = !includes in
+        {recurse; includes; path; directives = List.rev !acc}
+      | exn ->
+        close_in_noerr ic;
+        raise exn
+
+    let cache_name = "Mconfig_dot"
+  end)
+
+let find fname =
+  if Sys.file_exists fname && not (Sys.is_directory fname) then
+    Some fname
+  else
+    let rec loop dir =
+      let fname = Filename.concat dir ".merlin" in
+      if Sys.file_exists fname && not (Sys.is_directory fname)
+      then Some fname
+      else
+        let parent = Filename.dirname dir in
+        if parent <> dir
+        then loop parent
+        else None
+    in
+    loop fname
+
+let directives_of_files filenames =
+  let marked = Hashtbl.create 7 in
+  let rec process acc = function
+    | x :: rest when Hashtbl.mem marked x ->
+      process acc rest
+    | x :: rest ->
+      Hashtbl.add marked x ();
+      let file = Cache.read x in
+      let dir = Filename.dirname file.path in
+      let rest =
+        List.map ~f:(canonicalize_filename ~cwd:dir) file.includes @ rest
+      in
+      let rest =
+        if file.recurse then (
+          let dir =
+            if Filename.basename file.path <> ".merlin"
+            then dir else Filename.dirname dir
+          in
+          if dir <> file.path then
+            match find dir with
+            | Some fname -> fname :: rest
+            | None -> rest
+          else rest
+        ) else rest
+      in
+      process (file :: acc) rest
+    | [] -> List.rev acc
+  in
+  process [] filenames
+
+let ppx_of_package ?(predicates=[]) setup pkg =
+  let d = Findlib.package_directory pkg in
+  (* Determine the 'ppx' property: *)
+  let in_words ~comma s =
+    (* splits s in words separated by commas and/or whitespace *)
+    let l = String.length s in
+    let rec split i j =
+      if j < l then
+        match s.[j] with
+        | (' '|'\t'|'\n'|'\r'|',' as c) when c <> ',' || comma ->
+          if i<j then (String.sub s ~pos:i ~len:(j-i)) :: (split (j+1) (j+1))
+          else split (j+1) (j+1)
+        |	_ ->
+          split i (j+1)
+      else
+      if i<j then [ String.sub s ~pos:i ~len:(j-i) ] else []
+    in
+    split 0 0
+  in
+  let resolve_path = Findlib.resolve_path ~base:d ~explicit:true in
+  let ppx =
+    try Some(resolve_path (Findlib.package_property predicates pkg "ppx"))
+    with Not_found -> None
+  and ppxopts =
+    try
+      List.map ~f:(fun opt ->
+        match in_words ~comma:true opt with
+        | pkg :: opts ->
+          pkg, List.map ~f:resolve_path opts
+        | _ -> assert false
+      ) (in_words ~comma:false
+           (Findlib.package_property predicates pkg "ppxopt"))
+    with Not_found -> []
+  in
+  begin match ppx with
+    | None -> ()
+    | Some ppx -> log ~title:"ppx" "%s" ppx
+  end;
+  begin match ppxopts with
+    | [] -> ()
+    | lst ->
+      log ~title:"ppx options" "%a" Logger.json @@ fun () ->
+      let f (ppx,opts) =
+        `List [`String ppx; `List (List.map ~f:(fun s -> `String s) opts)]
+      in
+      `List (List.map ~f lst)
+  end;
+  let setup = match ppx with
+    | None -> setup
+    | Some ppx -> Ppxsetup.add_ppx ppx setup
+  in
+  List.fold_left ppxopts ~init:setup
+    ~f:(fun setup (ppx,opts) -> Ppxsetup.add_ppxopts ppx opts setup)
+
+let path_separator =
+  match Sys.os_type with
+    | "Cygwin"
+    | "Win32"  -> ";"
+    | _ -> ":"
+
+let set_findlib_path =
+  let findlib_cache = ref ("",[],"") in
+  fun ?(conf="") ?(path=[]) ?(toolchain="") () ->
+    let key = (conf,path,toolchain) in
+    if key <> !findlib_cache then begin
+      let env_ocamlpath = match path with
+        | [] -> None
+        | path -> Some (String.concat ~sep:path_separator path)
+      and config = match conf with
+        | "" -> None
+        | s -> Some s
+      and toolchain = match toolchain with
+        | "" -> None
+        | s -> Some s
+      in
+      log ~title:"set_findlib_path" "findlib_conf = %s; findlib_path = %s\n"
+        conf (String.concat ~sep:path_separator path);
+      Findlib.init ?env_ocamlpath ?config ?toolchain ();
+      findlib_cache := key
+    end
+
+let standard_library =
+  set_findlib_path ();
+  Findlib.ocaml_stdlib ()
+
+let is_package_optional name =
+  let last = String.length name - 1 in
+  last >= 0 && name.[last] = '?'
+
+let remove_option name =
+  let last = String.length name - 1 in
+  if last >= 0 && name.[last] = '?' then
+    String.sub name ~pos:0 ~len:last
+  else
+    name
+
+let path_of_packages ?conf ?path ?toolchain packages =
+  set_findlib_path ?conf ?path ?toolchain ();
+  let recorded_packages, invalid_packages =
+    List.partition packages
+      ~f:(fun name ->
+          match Findlib.package_directory (remove_option name) with
+          | _ -> true
+          | exception _ -> false)
+  in
+  let failures =
+    match
+      List.filter_map invalid_packages ~f:(fun pkg ->
+        if is_package_optional pkg then (
+          log ~title:"path_of_packages" "Uninstalled package %S" pkg;
+          None
+        ) else
+          Some pkg
+      )
+    with
+    | [] -> []
+    | xs -> ["Failed to load packages: " ^ String.concat ~sep:"," xs]
+  in
+  let recorded_packages = List.map ~f:remove_option recorded_packages in
+  let packages, failures =
+    match Findlib.package_deep_ancestors [] recorded_packages with
+    | packages -> packages, failures
+    | exception exn ->
+      [], (sprintf "Findlib failure: %S" (Printexc.to_string exn) :: failures)
+  in
+  let packages = List.filter_dup packages in
+  let path = List.map ~f:Findlib.package_directory packages in
+  let ppxs = List.fold_left ~f:ppx_of_package packages ~init:Ppxsetup.empty in
+  path, ppxs, failures
+
+type config = {
+  pass_forward : Dot_protocol.Directive.no_processing_required list;
+  to_canonicalize : (string * Dot_protocol.Directive.include_path) list;
+  stdlib : string option;
+  packages_to_load : string list;
+  findlib : string option;
+  findlib_path : string list;
+  findlib_toolchain : string option;
+}
+
+let empty_config = {
+  pass_forward      = [];
+  to_canonicalize   = [];
+  stdlib            = None;
+  packages_to_load  = [];
+  findlib           = None;
+  findlib_path      = [];
+  findlib_toolchain = None;
+}
+
+let prepend_config ~cwd ~cfg =
+  List.fold_left ~init:cfg ~f:(fun cfg (d : Dot_protocol.Directive.Raw.t) ->
+    match d with
+    | `B _ | `S _ | `CMI _ | `CMT _  as directive ->
+      { cfg with to_canonicalize = (cwd, directive) :: cfg.to_canonicalize }
+    | `EXT _ | `SUFFIX _ | `FLG _ | `READER _
+    | (`EXCLUDE_QUERY_DIR | `UNKNOWN_TAG _) as directive ->
+      { cfg with pass_forward = directive :: cfg.pass_forward }
+    | `PKG ps ->
+      { cfg with packages_to_load = ps @ cfg.packages_to_load }
+    | `STDLIB path ->
+      let canon_path = canonicalize_filename ~cwd path in
+      begin match cfg.stdlib with
+      | None -> ()
+      | Some p ->
+        log ~title:"conflicting paths for stdlib" "%s\n%s" p canon_path
+      end;
+      { cfg with stdlib = Some canon_path }
+    | `FINDLIB path ->
+      let canon_path = canonicalize_filename ~cwd path in
+      begin match cfg.stdlib with
+      | None -> ()
+      | Some p ->
+        log ~title:"conflicting paths for findlib" "%s\n%s" p canon_path
+      end;
+      { cfg with findlib = Some canon_path}
+    | `FINDLIB_PATH path ->
+      let canon_path = canonicalize_filename ~cwd path in
+      { cfg with findlib_path = canon_path :: cfg.findlib_path }
+    | `FINDLIB_TOOLCHAIN path ->
+      begin match cfg.stdlib with
+      | None -> ()
+      | Some p ->
+        log ~title:"conflicting paths for findlib toolchain" "%s\n%s" p path
+      end;
+      { cfg with findlib_toolchain = Some path}
+  )
+
+let process_one ~cfg {path;directives; _ } =
+  let cwd = Filename.dirname path in
+  prepend_config ~cwd ~cfg (List.rev directives)
+
+let expand =
+  let filter path =
+    let name = Filename.basename path in
+    name <> "" && name.[0] <> '.' &&
+    try Sys.is_directory path
+    with _ -> false
+  in
+  fun ~stdlib dir path ->
+    let path = expand_directory stdlib path in
+    let path = canonicalize_filename ~cwd:dir path in
+    expand_glob ~filter path []
+
+module Import_from_dune = struct
+  let escape_only c s =
+    let open String in
+    let n = ref 0 in
+    let len = length s in
+    for i = 0 to len - 1 do
+      if unsafe_get s i = c then incr n
+    done;
+    if !n = 0 then
+      s
+    else
+      let b = Bytes.create (len + !n) in
+      n := 0;
+      for i = 0 to len - 1 do
+        if unsafe_get s i = c then (
+          Bytes.unsafe_set b !n '\\';
+          incr n
+        );
+        Bytes.unsafe_set b !n (unsafe_get s i);
+        incr n
+      done;
+      Bytes.unsafe_to_string b
+
+  let need_quoting s =
+    let len = String.length s in
+    len = 0
+    ||
+    let rec loop i =
+      if i = len then
+        false
+      else
+        match s.[i] with
+        | ' '
+        | '\"'
+        | '('
+        | ')'
+        | '{'
+        | '}'
+        | ';'
+        | '#' ->
+          true
+        | _ -> loop (i + 1)
+    in
+    loop 0
+
+  let quote s =
+    let s =
+      if Sys.win32 then
+        (* We need this hack because merlin unescapes backslashes (except when
+           protected by single quotes). It is only a problem on windows because
+           Filename.quote is using double quotes. *)
+        escape_only '\\' s
+      else
+        s
+    in
+    if need_quoting s then
+      Filename.quote s
+    else
+      s
+end
+
+let postprocess cfg =
+  let stdlib = Option.value ~default:standard_library cfg.stdlib in
+  let pkg_paths, ppxsetup, failures = path_of_packages cfg.packages_to_load in
+  let ppx =
+    match Ppxsetup.command_line ppxsetup with
+    | [] -> []
+    | lst ->
+      let cmd = List.concat_map lst ~f:(fun pp -> ["-ppx"; pp])
+      in
+      [ `FLG  cmd]
+  in
+  List.concat
+    [ List.concat_map cfg.to_canonicalize ~f:(fun (dir, directive) ->
+        let dirs =
+          match directive with
+          | `B path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `B p)
+          | `S path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `S p)
+          | `CMI path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `CMI p)
+          | `CMT path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `CMT p)
+        in
+        (dirs :> Dot_protocol.directive list)
+      )
+    ; (cfg.pass_forward :> Dot_protocol.directive list)
+    ; List.concat_map pkg_paths ~f:(fun p -> [ `B p; `S p ])
+    ; ppx
+    ; List.map failures ~f:(fun s -> `ERROR_MSG s)
+    ]
+
+let load dot_merlin_file =
+  let directives = directives_of_files [ dot_merlin_file ] in
+  let cfg =
+    List.fold_left directives ~init:empty_config
+      ~f:(fun cfg file -> process_one ~cfg file)
+  in
+  let directives = postprocess cfg in
+  match cfg.packages_to_load, findlib_ok with
+  | [], _ | _, Ok _ -> directives
+  | _, Error msg -> (`ERROR_MSG msg) :: directives
+
+let dot_merlin_file =  Filename.concat (Sys.getcwd ()) ".merlin"
+
+let rec main () =
+  match Dot_protocol.Commands.read_input stdin with
+  | Halt -> exit 0
+  | File _path ->
+    let directives = load dot_merlin_file in
+    Dot_protocol.write ~out_channel:stdout directives;
+    flush stdout;
+    main ()
+  | Unknown -> main ()
+
+let () = main ()
diff --git a/src/dot-merlin/dune b/src/dot-merlin/dune
new file mode 100644
index 0000000..c933a9e
--- /dev/null
+++ b/src/dot-merlin/dune
@@ -0,0 +1,5 @@
+(executable
+ (package dot-merlin-reader)
+ (name dot_merlin_reader)
+ (public_name dot-merlin-reader)
+ (libraries findlib merlin_utils merlin_dot_protocol str))
diff --git a/src/extend/.gitignore b/src/extend/.gitignore
new file mode 100644
index 0000000..f7817ae
--- /dev/null
+++ b/src/extend/.gitignore
@@ -0,0 +1,20 @@
+*.annot
+*.cmo
+*.cma
+*.cmi
+*.a
+*.o
+*.cmx
+*.cmxs
+*.cmxa
+
+# ocamlbuild working directory
+_build/
+
+# ocamlbuild targets
+*.byte
+*.native
+
+# oasis generated files
+setup.data
+setup.log
diff --git a/src/extend/dune b/src/extend/dune
new file mode 100644
index 0000000..521e927
--- /dev/null
+++ b/src/extend/dune
@@ -0,0 +1,6 @@
+(library
+ (name      merlin_extend)
+ (wrapped   false)
+ (modules   (:standard \ extend_helper))
+ (flags :standard -open Ocaml_utils -open Ocaml_parsing -open Ocaml_typing)
+ (libraries ocaml_parsing ocaml_typing unix ocaml_utils))
diff --git a/src/extend/extend_driver.ml b/src/extend/extend_driver.ml
new file mode 100644
index 0000000..076621a
--- /dev/null
+++ b/src/extend/extend_driver.ml
@@ -0,0 +1,66 @@
+module P = Extend_protocol
+
+(** Helper for the driver (Merlin) *)
+
+type t = {
+  name: string;
+  capabilities: P.capabilities;
+  stdin: out_channel;
+  stdout: in_channel;
+  mutable pid: int;
+
+  notify: string -> unit;
+  debug: string -> unit;
+}
+
+exception Extension of string * string * string
+
+let run ?(notify=ignore) ?(debug=ignore) name =
+  let pstdin, stdin = Unix.pipe () in
+  let stdout, pstdout = Unix.pipe () in
+  Unix.set_close_on_exec pstdin;
+  Unix.set_close_on_exec stdin;
+  Unix.set_close_on_exec pstdout;
+  Unix.set_close_on_exec stdout;
+  let pid =
+    Unix.create_process
+      ("ocamlmerlin-" ^ name) [||]
+      pstdin pstdout Unix.stderr
+  in
+  Unix.close pstdout;
+  Unix.close pstdin;
+  let stdin  = Unix.out_channel_of_descr stdin in
+  let stdout = Unix.in_channel_of_descr stdout in
+  match Extend_main.Handshake.negotiate_driver name stdout stdin with
+  | capabilities -> {name; capabilities; stdin; stdout; pid; notify; debug}
+  | exception exn ->
+    close_out_noerr stdin;
+    close_in_noerr stdout;
+    raise exn
+
+let stop t =
+  close_out_noerr t.stdin;
+  close_in_noerr t.stdout;
+  if t.pid <> -1 then (
+    let _, _ = Unix.waitpid [] t.pid in
+    t.pid <- -1;
+  )
+
+let capabilities t = t.capabilities
+
+let reader t request =
+  if t.pid = -1 then
+    invalid_arg "Extend_main.Driver.reader: extension is closed";
+  output_value t.stdin (P.Reader_request request);
+  flush t.stdin;
+  let rec aux () =
+    match input_value t.stdout with
+    | P.Notify str -> t.notify str; aux ()
+    | P.Debug str -> t.debug str; aux ()
+    | P.Exception (kind, msg) ->
+      stop t;
+      raise (Extension (t.name, kind, msg))
+    | P.Reader_response response ->
+      response
+  in
+  aux ()
diff --git a/src/extend/extend_driver.mli b/src/extend/extend_driver.mli
new file mode 100644
index 0000000..baf7f6e
--- /dev/null
+++ b/src/extend/extend_driver.mli
@@ -0,0 +1,16 @@
+(** Helper for the driver (Merlin) *)
+open Extend_protocol
+
+type t
+
+exception Extension of string * string * string
+
+val run : ?notify:(string -> unit) -> ?debug:(string -> unit) -> string -> t
+
+val stop : t -> unit
+
+val capabilities : t -> capabilities
+
+val reader : t ->
+  Reader.request ->
+  Reader.response
diff --git a/src/extend/extend_helper.ml b/src/extend/extend_helper.ml
new file mode 100644
index 0000000..8aedb35
--- /dev/null
+++ b/src/extend/extend_helper.ml
@@ -0,0 +1,102 @@
+open Parsetree
+
+(** Generate an extension node that will be reported as a syntax error by
+    Merlin. *)
+let syntax_error msg loc : extension =
+  let str = Location.mkloc "merlin.syntax-error" loc in
+  let payload = PStr [{
+      pstr_loc = Location.none;
+      pstr_desc = Pstr_eval (
+        Ast_helper.(Exp.constant (const_string msg)), []
+      );
+    }]
+  in
+  (str, payload)
+;;
+
+
+(** Physical locations might be too precise for some features.
+
+    For instance in:
+       let x = f    in    y
+                 ^1    ^2
+
+    Merlin cannot distinguish position ^1 from ^2 in the normal AST,
+    because IN doesn't appear in abstract syntax. This is a problem when
+    completing, because a different environment should be selected for both
+    positions.
+
+    One can add relaxed_location attributes to make some locations closer to
+    the concrete syntax.
+
+    Here is the same line annotated with physical and relaxed locations:
+       let x = f    in    y
+              [ ]        [ ]  -- physical locations for f and y nodes
+              [     ][     ]  -- relaxed locations for f and y nodes
+*)
+let relaxed_location loc : attribute =
+  let str = Location.mkloc "merlin.relaxed-location" loc in
+  Ast_helper.Attr.mk str (PStr [])
+;;
+
+
+(** If some code should be ignored by merlin when reporting information to
+    the user, put a hide_node attribute.
+
+    This is useful for generated/desugared code which doesn't correspond to
+    anything in concrete syntax (example use-case: encoding of some
+    js_of_ocaml constructs).
+*)
+let hide_node : attribute =
+  Ast_helper.Attr.mk (Location.mknoloc "merlin.hide") (PStr [])
+
+(** The converse: when merlin should focus on a specific node of the AST.
+    The main use case is also for js_of_ocaml.
+
+    Assuming <code> is translated to:
+
+    let module M = struct
+      let prolog = ... (* boilerplate *)
+
+      let code = <mapping-of-code>
+
+      let epilog = ... (* boilerplate *)
+    end
+    in M.boilerplate
+
+    To make merlin focus on [M.code] and ignore the boilerplate ([M.prolog]
+    and [M.epilog]), add a [focus_node] attribute to the [M.code] item.
+*)
+let focus_node : attribute =
+  Ast_helper.Attr.mk (Location.mknoloc "merlin.focus") (PStr [])
+
+(* Projections for merlin attributes and extensions *)
+
+let classify_extension (id, _ : extension) : [`Other | `Syntax_error] =
+  match id.Location.txt with
+  | "merlin.syntax-error" -> `Syntax_error
+  | _ -> `Other
+
+let classify_attribute attr : [`Other | `Relaxed_location | `Hide | `Focus] =
+  let id, _ = Ast_helper.Attr.as_tuple attr in
+  match id.Location.txt with
+  | "merlin.relaxed-location" -> `Relaxed_location
+  | "merlin.hide" -> `Hide
+  | "merlin.focus" -> `Focus
+  | _ -> `Other
+
+let extract_syntax_error (id, payload : extension) : string * Location.t =
+  if id.Location.txt <> "merlin.syntax-error" then
+    invalid_arg "Merlin_extend.Reader_helper.extract_syntax_error";
+  let invalid_msg =
+      "Warning: extension produced an incorrect syntax-error node" in
+   let msg = match Ast_helper.extract_str_payload payload with
+     | Some (msg, _loc) -> msg
+     | None -> invalid_msg
+  in
+  msg, id.Location.loc
+
+let extract_relaxed_location attr : Location.t =
+  match Ast_helper.Attr.as_tuple attr with
+  | ({Location. txt = "merlin.relaxed-location"; loc} , _) -> loc
+  | _ -> invalid_arg "Merlin_extend.Reader_helper.extract_relaxed_location"
diff --git a/src/extend/extend_helper.mli b/src/extend/extend_helper.mli
new file mode 100644
index 0000000..3488b4f
--- /dev/null
+++ b/src/extend/extend_helper.mli
@@ -0,0 +1,66 @@
+open Parsetree
+
+(** Generate an extension node that will be reported as a syntax error by
+    Merlin. *)
+val syntax_error : string -> Location.t -> extension
+
+(** Physical locations might be too precise for some features.
+
+    For instance in:
+       let x = f    in    y
+                 ^1    ^2
+
+    Merlin cannot distinguish position ^1 from ^2 in the normal AST,
+    because IN doesn't appear in abstract syntax. This is a problem when
+    completing, because a different environment should be selected for both
+    positions.
+
+    One can add relaxed_location attributes to make some locations closer to
+    the concrete syntax.
+
+    Here is the same line annotated with physical and relaxed locations:
+       let x = f    in    y
+              [ ]        [ ]  -- physical locations for f and y nodes
+              [     ][     ]  -- relaxed locations for f and y nodes
+*)
+val relaxed_location : Location.t -> attribute
+
+(** If some code should be ignored by merlin when reporting information to
+    the user, put a hide_node attribute.
+
+    This is useful for generated/desugared code which doesn't correspond to
+    anything in concrete syntax (example use-case: encoding of some
+    js_of_ocaml constructs).
+*)
+val hide_node : attribute
+
+(** The converse: when merlin should focus on a specific node of the AST.
+    The main use case is also for js_of_ocaml.
+
+    Assuming <code> is translated to:
+
+    let module M = struct
+      let prolog = ... (* boilerplate *)
+
+      let code = <mapping-of-code>
+
+      let epilog = ... (* boilerplate *)
+    end
+    in M.boilerplate
+
+    To make merlin focus on [M.code] and ignore the boilerplate ([M.prolog]
+    and [M.epilog]), add a [focus_node] attribute to the [M.code] item.
+*)
+val focus_node : attribute
+
+(* Projections for merlin attributes and extensions *)
+
+val classify_extension : extension ->
+  [`Other | `Syntax_error]
+
+val extract_syntax_error : extension -> string * Location.t
+
+val classify_attribute : attribute ->
+  [`Other | `Relaxed_location | `Hide | `Focus]
+
+val extract_relaxed_location : attribute -> Location.t
diff --git a/src/extend/extend_main.ml b/src/extend/extend_main.ml
new file mode 100644
index 0000000..d7363d6
--- /dev/null
+++ b/src/extend/extend_main.ml
@@ -0,0 +1,186 @@
+module P = Extend_protocol
+module R = P.Reader
+
+module Description = struct
+  type t = P.description
+
+  let make_v0 ~name ~version = { P. name; version }
+end
+
+module Reader = struct
+  type t = (module R.V0)
+  let make_v0 (x : (module R.V0)) : t = x
+
+  module Make (V : R.V0) = struct
+
+    open P.Reader
+
+    let buffer = ref None
+
+    let get_buffer () =
+      match !buffer with
+      | None -> invalid_arg "No buffer loaded"
+      | Some buffer -> buffer
+
+    let exec = function
+      | Req_load buf ->
+        buffer := Some (V.load buf);
+        Res_loaded
+      | Req_parse ->
+        Res_parse (V.parse (get_buffer ()))
+      | Req_parse_line (pos, str) ->
+        Res_parse (V.parse_line (get_buffer ()) pos str)
+      | Req_parse_for_completion pos ->
+        let info, tree = V.for_completion (get_buffer ()) pos in
+        Res_parse_for_completion (info, tree)
+      | Req_get_ident_at pos ->
+        Res_get_ident_at (V.ident_at (get_buffer ()) pos)
+      | Req_print_outcome trees ->
+        let print t =
+          V.print_outcome Format.str_formatter t;
+          Format.flush_str_formatter ()
+        in
+        let trees = List.rev_map print trees in
+        Res_print_outcome (List.rev trees)
+      | Req_pretty_print p ->
+        V.pretty_print Format.str_formatter p;
+        Res_pretty_print (Format.flush_str_formatter ())
+
+  end
+end
+
+module Utils = struct
+
+  (* Postpone messages until ready *)
+  let send, set_ready =
+    let is_ready = ref false in
+    let postponed = ref [] in
+    let really_send msg = output_value stdout msg in
+    let set_ready () =
+      is_ready := true;
+      let postponed' = List.rev !postponed in
+      postponed := [];
+      List.iter really_send postponed'
+    in
+    let send msg =
+      if !is_ready then
+        really_send msg
+      else
+        postponed := msg :: !postponed
+    in
+    send, set_ready
+
+  let notify msg = send (P.Notify msg)
+  let debug msg = send (P.Debug msg)
+end
+
+module Handshake = struct
+  let magic_number : string = "MERLINEXTEND002"
+
+  type versions = {
+    ast_impl_magic_number : string;
+    ast_intf_magic_number : string;
+    cmi_magic_number : string;
+    cmt_magic_number : string;
+  }
+
+  let versions = Config.({
+      ast_impl_magic_number;
+      ast_intf_magic_number;
+      cmi_magic_number;
+      cmt_magic_number;
+    })
+
+ let negotiate (capabilities : P.capabilities) =
+    output_string stdout magic_number;
+    output_value stdout versions;
+    output_value stdout capabilities;
+    flush stdout;
+    Utils.set_ready ();
+    match input_value stdin with
+    | exception End_of_file -> exit 0
+    | P.Start_communication -> ()
+    | _ ->
+      prerr_endline "Unexpected value after handshake.";
+      exit 1
+
+  exception Error of string
+
+  let () =
+    Printexc.register_printer (function
+        | Error msg ->
+          Some (Printf.sprintf "Extend_main.Handshake.Error %S" msg)
+        | _ -> None
+      )
+
+  let negotiate_driver ext_name i o =
+    let magic' = really_input_string i (String.length magic_number) in
+    if magic' <> magic_number then (
+      let msg = Printf.sprintf
+          "Extension %s has incompatible protocol version %S (expected %S)"
+          ext_name magic' magic_number
+      in
+      raise (Error msg)
+    );
+    let versions' : versions = input_value i in
+    let check_v prj name =
+      if prj versions <> prj versions' then
+        let msg = Printf.sprintf
+            "Extension %s %s has incompatible version %S (expected %S)"
+            ext_name name (prj versions') (prj versions)
+        in
+        raise (Error msg)
+    in
+    check_v (fun x -> x.ast_impl_magic_number) "implementation AST";
+    check_v (fun x -> x.ast_intf_magic_number) "interface AST";
+    check_v (fun x -> x.cmi_magic_number) "compiled interface (CMI)";
+    check_v (fun x -> x.cmt_magic_number) "typedtree (CMT)";
+    output_value o P.Start_communication;
+    flush o;
+    let capabilities : P.capabilities =
+      input_value i
+    in
+    capabilities
+end
+
+(** The main entry point of an extension. *)
+let extension_main ?reader desc =
+  (* Check if invoked from Merlin *)
+  begin match Sys.getenv "__MERLIN_MASTER_PID" with
+  | exception Not_found ->
+    Printf.eprintf "This is %s merlin extension, version %s.\n\
+                    This binary should be invoked from merlin and \
+                    cannot be used directly.\n%!"
+      desc.P.name
+      desc.P.version;
+    exit 1;
+  | _ -> ()
+  end;
+  (* Communication happens on stdin/stdout. *)
+  Handshake.negotiate {P. reader = reader <> None};
+  let reader = match reader with
+    | None -> (fun _ -> failwith "No reader")
+    | Some (module R : R.V0) ->
+      let module M = Reader.Make(R) in
+      M.exec
+  in
+  let respond f =
+    match f () with
+    | (r : P.response) -> Utils.send r
+    | exception exn ->
+      let name = Printexc.exn_slot_name exn in
+      let desc = Printexc.to_string exn in
+      Utils.send (P.Exception (name, desc))
+  in
+  let rec loop () =
+    flush stdout;
+    match input_value stdin with
+    | exception End_of_file -> exit 0
+    | P.Start_communication ->
+      prerr_endline "Unexpected message.";
+      exit 2
+    | P.Reader_request request ->
+      respond (fun () -> P.Reader_response (reader request));
+      loop ()
+  in
+  loop ()
diff --git a/src/extend/extend_main.mli b/src/extend/extend_main.mli
new file mode 100644
index 0000000..0502019
--- /dev/null
+++ b/src/extend/extend_main.mli
@@ -0,0 +1,36 @@
+open Extend_protocol
+
+module Description : sig
+  type t
+  val make_v0 : name:string -> version:string -> t
+end
+
+module Utils : sig
+  val notify : string -> unit
+  val debug : string -> unit
+end
+
+module Reader : sig
+  type t
+  val make_v0 : (module Reader.V0) -> t
+end
+
+module Handshake : sig
+  val magic_number : string
+
+  type versions = {
+    ast_impl_magic_number : string;
+    ast_intf_magic_number : string;
+    cmi_magic_number : string;
+    cmt_magic_number : string;
+  }
+
+  exception Error of string
+
+  val versions : versions
+
+  val negotiate_driver : string -> in_channel -> out_channel -> capabilities
+end
+
+(** The main entry point of an extension. *)
+val extension_main : ?reader:Reader.t -> Description.t -> 'a
diff --git a/src/extend/extend_protocol.ml b/src/extend/extend_protocol.ml
new file mode 100644
index 0000000..b7c522d
--- /dev/null
+++ b/src/extend/extend_protocol.ml
@@ -0,0 +1,152 @@
+module Reader = struct
+
+  (** Description of a buffer managed by Merlin *)
+  type buffer = {
+
+    path : string;
+    (** Path of the buffer in the editor.
+        The path is absolute if it is backed by a file, although it might not yet
+        have been saved in the editor.
+        The path is relative if it is a temporary buffer. *)
+
+    flags : string list;
+    (** Any flag that has been passed to the reader in .merlin file *)
+
+    text : string;
+    (** Content of the buffer *)
+  }
+
+  (** ASTs exchanged with Merlin *)
+  type parsetree =
+
+    | Structure of Parsetree.structure
+      (** An implementation, usually coming from a .ml file *)
+
+    | Signature of Parsetree.signature
+      (** An interface, usually coming from a .mli file *)
+
+  (** Printing in error messages or completion items *)
+  type outcometree =
+    | Out_value          of Outcometree.out_value
+    | Out_type           of Outcometree.out_type
+    | Out_class_type     of Outcometree.out_class_type
+    | Out_module_type    of Outcometree.out_module_type
+    | Out_sig_item       of Outcometree.out_sig_item
+    | Out_signature      of Outcometree.out_sig_item list
+    | Out_type_extension of Outcometree.out_type_extension
+    | Out_phrase         of Outcometree.out_phrase
+
+  (** Printing in case destruction *)
+  type pretty_parsetree =
+    | Pretty_toplevel_phrase of Parsetree.toplevel_phrase
+    | Pretty_expression      of Parsetree.expression
+    | Pretty_core_type       of Parsetree.core_type
+    | Pretty_pattern         of Parsetree.pattern
+    | Pretty_signature       of Parsetree.signature
+    | Pretty_structure       of Parsetree.structure
+    | Pretty_case_list       of Parsetree.case list
+
+  (** Additional information useful for guiding completion *)
+  type complete_info = {
+    complete_labels : bool;
+    (** True if it is appropriate to suggest labels for this completion. *)
+  }
+
+  module type V0 = sig
+    (** Internal representation of a buffer for the extension.
+        Extension should avoid global state, cached information should be stored
+        in values of this type. *)
+    type t
+
+    (** Turns a merlin-buffer into an internal buffer.
+
+        This function should be total, an exception at this point is a
+        fatal-error.
+
+        Simplest implementation is identity, with type t = buffer.
+    *)
+    val load : buffer -> t
+
+    (** Get the main parsetree from the buffer.
+        This should return the AST corresponding to [buffer.source].
+    *)
+    val parse : t -> parsetree
+
+    (** Give the opportunity to optimize the parsetree when completing from a
+        specific position.
+
+        The simplest implementation is:
+
+            let for_completion t _ = ({complete_labels = true}, (tree t))
+
+        But it might be worthwhile to specialize the parsetree for a better
+        completion.
+    *)
+    val for_completion : t -> Lexing.position -> complete_info * parsetree
+
+    (** Parse a separate user-input in the context of this buffer.
+        Used when the user manually enters an expression and ask for its type or location.
+    *)
+    val parse_line : t -> Lexing.position -> string -> parsetree
+
+    (** Given a buffer and a position, return the components of the identifier
+        (actually the qualified path) under the cursor.
+
+        This should return the raw identifier names -- operators should not be
+        surrounded by parentheses.
+
+        An empty list is a valid result if no identifiers are under the cursor.
+    *)
+    val ident_at : t -> Lexing.position -> string Location.loc list
+
+    (** Opposite direction: pretty-print a tree.
+        This works on outcometree and is used for displaying answers to queries.
+        (type errors, signatures of modules in environment, completion candidates, etc).
+    *)
+    val print_outcome : Format.formatter -> outcometree -> unit
+
+    (* This one works on parsetree and is used for case destruction
+       (merlin-destruct) *)
+    val pretty_print : Format.formatter -> pretty_parsetree -> unit
+  end
+
+  type request =
+    | Req_load of buffer
+    | Req_parse
+    | Req_parse_line of Lexing.position * string
+    | Req_parse_for_completion of Lexing.position
+    | Req_get_ident_at of Lexing.position
+    | Req_print_outcome of outcometree list
+    | Req_pretty_print of pretty_parsetree
+
+  type response =
+    | Res_loaded
+    | Res_parse of parsetree
+    | Res_parse_for_completion of complete_info * parsetree
+    | Res_get_ident_at of string Location.loc list
+    | Res_print_outcome of string list
+    | Res_pretty_print of string
+
+end
+
+(* Name of the extension *)
+type description = {
+  name : string;
+  version : string;
+}
+
+(* Services an extension can provide *)
+type capabilities = {
+  reader: bool;
+}
+
+(* Main protocol *)
+type request =
+  | Start_communication
+  | Reader_request of Reader.request
+
+type response =
+  | Notify of string
+  | Debug of string
+  | Exception of string * string
+  | Reader_response of Reader.response
diff --git a/src/frontend/dune b/src/frontend/dune
new file mode 100644
index 0000000..86746fb
--- /dev/null
+++ b/src/frontend/dune
@@ -0,0 +1,26 @@
+(library
+ (name      query_protocol)
+ (modules   query_protocol)
+ (flags :standard -open Merlin_utils -open Ocaml_parsing)
+ (libraries merlin_kernel merlin_utils ocaml_parsing))
+
+(library
+ (name      query_commands)
+ (modules   query_commands)
+ (flags
+  :standard
+  -open Ocaml_utils
+  -open Ocaml_parsing
+  -open Ocaml_typing
+  -open Merlin_utils
+  -open Merlin_analysis)
+ (libraries
+  merlin_utils
+  merlin_kernel
+  ocaml_utils
+  ocaml_parsing
+  ocaml_typing
+  merlin_specific
+  config
+  merlin_analysis
+  query_protocol))
diff --git a/src/frontend/ocamlmerlin/dune b/src/frontend/ocamlmerlin/dune
new file mode 100644
index 0000000..faa01b9
--- /dev/null
+++ b/src/frontend/ocamlmerlin/dune
@@ -0,0 +1,37 @@
+(include_subdirs unqualified)
+
+(executable
+ (name ocamlmerlin_server)
+ (package merlin)
+ (public_name ocamlmerlin-server)
+ (flags
+  :standard
+  -open Ocaml_utils
+  -open Ocaml_parsing
+  -open Ocaml_typing
+  -open Merlin_utils
+  -open Merlin_analysis)
+ (modules (:standard \ gen_ccflags))
+ (libraries config yojson merlin_analysis merlin_kernel
+            merlin_utils os_ipc ocaml_parsing query_protocol query_commands
+            ocaml_typing ocaml_utils seq))
+
+(executable
+ (name      gen_ccflags)
+ (modules   gen_ccflags)
+ (libraries str))
+
+(rule
+ (targets pre-flags post-flags)
+ (deps    gen_ccflags.exe)
+ (action  (run %{deps} "%{ocaml-config:ccomp_type}" %{targets})))
+
+(rule
+ (targets ocamlmerlin.exe)
+ (deps    (:c ocamlmerlin.c) pre-flags post-flags)
+ (action  (run %{cc} "%{read-lines:pre-flags}%{targets}" %{c} %{read-lines:post-flags})))
+
+(install
+ (package merlin)
+ (section bin)
+ (files   (ocamlmerlin.exe as ocamlmerlin)))
diff --git a/src/frontend/ocamlmerlin/gen_ccflags.ml b/src/frontend/ocamlmerlin/gen_ccflags.ml
new file mode 100644
index 0000000..5095258
--- /dev/null
+++ b/src/frontend/ocamlmerlin/gen_ccflags.ml
@@ -0,0 +1,18 @@
+let ccomp_type   = Sys.argv.(1)
+let pre_flags_f  = Sys.argv.(2)
+let post_flags_f = Sys.argv.(3)
+
+let pre_flags, post_flags =
+  if Str.string_match (Str.regexp "msvc") ccomp_type 0 then
+    "/Fe", "advapi32.lib"
+  else
+    "-o", ""
+
+let write_lines f s =
+  let oc = open_out f in
+  output_string oc s;
+  close_out oc
+
+let () =
+  write_lines pre_flags_f pre_flags;
+  write_lines post_flags_f post_flags
diff --git a/src/frontend/ocamlmerlin/log_info.ml b/src/frontend/ocamlmerlin/log_info.ml
new file mode 100644
index 0000000..94e5923
--- /dev/null
+++ b/src/frontend/ocamlmerlin/log_info.ml
@@ -0,0 +1,8 @@
+let get () = 
+  let log_file, sections = 
+    match String.split_on_char ',' (Sys.getenv "MERLIN_LOG") with
+    | (value :: sections) -> (Some value, sections)
+    | [] -> (None, [])
+    | exception Not_found -> (None, [])
+  in 
+  `Log_file_path log_file, `Log_sections sections
\ No newline at end of file
diff --git a/src/frontend/ocamlmerlin/log_info.mli b/src/frontend/ocamlmerlin/log_info.mli
new file mode 100644
index 0000000..c74beb9
--- /dev/null
+++ b/src/frontend/ocamlmerlin/log_info.mli
@@ -0,0 +1,2 @@
+val get : 
+    unit -> [`Log_file_path of string option] * [`Log_sections of string list]
diff --git a/src/frontend/ocamlmerlin/new/new_commands.ml b/src/frontend/ocamlmerlin/new/new_commands.ml
new file mode 100644
index 0000000..cbf2343
--- /dev/null
+++ b/src/frontend/ocamlmerlin/new/new_commands.ml
@@ -0,0 +1,668 @@
+open Std
+
+type command =
+Command : string * Marg.docstring *
+          ([`Mandatory|`Optional|`Many] * 'args Marg.spec) list * 'args *
+          (Mpipeline.t -> 'args -> json) -> command
+
+let command name ?(doc="") ~spec ~default f =
+  Command (name, doc, spec, default, f)
+
+let arg ?(kind=`Mandatory) name doc action = (kind, (name, doc, action))
+let optional x = arg ~kind:`Optional x
+let many x = arg ~kind:`Many x
+
+let marg_position f = Marg.param "position"
+    (function
+      | "start" -> f `Start
+      | "end" -> f `End
+      | str -> match int_of_string str with
+        | n -> f (`Offset n)
+        | exception _ ->
+          match
+            let offset = String.index str ':' in
+            let line = String.sub str ~pos:0 ~len:offset in
+            let col = String.sub str ~pos:(offset+1)
+                ~len:(String.length str - offset - 1) in
+            `Logical (int_of_string line, int_of_string col)
+          with
+          | pos -> f pos
+          | exception _ ->
+            failwithf "expecting position, got %S. \
+                       position can be start|end|<offset>|<line>:<col>, \
+                       where offset, line and col are numbers, \
+                       lines are indexed from 1."
+              str
+    )
+
+let marg_completion_kind f = Marg.param "completion-kind"
+    (function
+      | "t" | "type" | "types"           -> f `Types
+      | "v" | "val" | "value" | "values" -> f `Values
+      | "variant" | "variants" | "var"   -> f `Variants
+      | "c" | "constr" | "constructor"   -> f `Constructor
+      | "l" | "label" | "labels"         -> f `Labels
+      | "m" | "mod" | "module"           -> f `Modules
+      | "mt" | "modtype" | "module-type" -> f `Modules_type
+      | "k" | "kw" | "keyword"           -> f `Keywords
+      | str ->
+        failwithf "expecting completion kind, got %S. \
+                   kind can be value, variant, constructor, \
+                   label, module or module-type"
+          str
+    )
+
+let rec find_command name = function
+  | [] -> raise Not_found
+  | (Command (name', _, _, _, _) as command) :: xs ->
+    if name = name' then
+      command
+    else find_command name xs
+
+let run pipeline query =
+  Logger.log ~section:"New_commands" ~title:"run(query)"
+    "%a" Logger.json (fun () -> Query_json.dump query);
+  let result = Query_commands.dispatch pipeline query in
+  let json = Query_json.json_of_response query result in
+  json
+
+let all_commands = [
+
+  command "case-analysis"
+    ~spec: [
+      arg "-start" "<position> Where analysis starts"
+        (marg_position (fun startp (_startp,endp) -> (startp,endp)));
+      arg "-end" "<position> Where analysis ends"
+        (marg_position (fun endp (startp,_endp) -> (startp,endp)));
+    ]
+~doc:"When the range determined by (-start, -end) positions is an expression,
+this command replaces it with [match expr with _] expression where a branch \
+is introduced for each immediate value constructor of the type that was \
+determined for expr.
+When it is a variable pattern, it is further expanded and new branches are \
+introduced for each possible immediate constructor of this variable.
+The return value has the shape \
+`[{'start': position, 'end': position}, content]`, where content is string.
+"
+    ~default:(`Offset (-1), `Offset (-1))
+    begin fun buffer -> function
+      | (`Offset (-1), _) -> failwith "-start <pos> is mandatory"
+      | (_, `Offset (-1)) -> failwith "-end <pos> is mandatory"
+      | (startp, endp) ->
+        run buffer (Query_protocol.Case_analysis (startp,endp))
+    end
+  ;
+
+  command "holes"
+    ~spec:[]
+    ~doc:"Returns the list of the positions of all the holes in the file."
+    ~default:()
+    begin fun buffer () ->
+      run buffer (Query_protocol.Holes)
+    end
+  ;
+
+  command "construct"
+    ~spec: [
+      arg "-position" "<position> Position where construct should happen"
+          (marg_position (fun pos (_pos, with_values, depth) ->
+            (pos, with_values, depth)));
+      optional "-with-values" "<none|local> Use values from the environment"
+        (Marg.param "<none|local>"
+          (fun with_values (pos, _with_values, depth) ->
+            match with_values with
+            | "none" -> (pos, None, depth)
+            | "local" -> (pos, Some `Local, depth)
+            | _ -> failwith "-with-values should be one of none or local"
+          ));
+      optional "-depth" "<int> Depth for the search (defaults to 1)"
+          (Marg.param "int" (fun depth (pos, with_values,_depth) ->
+              match int_of_string depth with
+              | depth ->
+                if depth >= 1 then (pos, with_values, Some depth)
+                else failwith "depth should be a positive integer"
+              | exception _ ->
+                failwith "depth should be a positive integer"
+            ));
+    ]
+~doc:"The construct command returns a list of expressions that could fill a
+hole at '-position' given its inferred type. The '-depth' parameter allows to
+recursively construct terms. Note that when '-depth' > 1 partial results of
+inferior depth will not be returned."
+    ~default:(`Offset (-1), None, None)
+    begin fun buffer (pos, with_values, max_depth) ->
+      match pos with
+      | `Offset (-1) -> failwith "-position <pos> is mandatory"
+      | pos -> run buffer (Query_protocol.Construct (pos, with_values, max_depth))
+    end
+  ;
+
+  command "complete-prefix"
+    ~spec: [
+      arg "-position" "<position> Position to complete"
+        (marg_position (fun pos (txt,_pos,kinds,doc,typ) -> (txt,pos,kinds,doc,typ)));
+      optional "-doc" "<bool> Add docstring to entries (default is false)"
+        (Marg.bool (fun doc (txt,pos,kinds,_doc,typ) -> (txt,pos,kinds,doc,typ)));
+      arg "-prefix" "<string> Prefix to complete"
+        (Marg.param "string" (fun txt (_,pos,kinds,doc,typ) -> (txt,pos,kinds,doc,typ)));
+      optional "-types" "<bool> Report type information (default is true)"
+        (Marg.bool (fun typ (txt,pos,kinds,doc,_typ) -> (txt,pos,kinds,doc,typ)));
+      optional "-kind" "<completion-kind> Namespace to complete (value, constructor, type, variant, label, module, module-type). Default is decided by cursor context"
+        (marg_completion_kind (fun kind (txt,pos,kinds,doc,typ) -> (txt,pos,kind::kinds,doc,typ)));
+    ]
+~doc:"This functions completes an identifier that the user started to type.
+It returns a list of possible completions.
+With '-types y' (default), each completion comes with type information.
+With '-doc y' it tries to lookup OCamldoc, which is slightly more time consuming.
+
+The result has the form:
+```javascript
+{
+  'context': (null | ['application',{'argument_type': string, 'labels': [{'name':string,'type':string}]}]),
+  'entries': [{'name':string,'kind':string,'desc':string,'info':string}]
+}
+```
+
+Context describe where completion is occurring. Only application is distinguished now: that's when one is completing the arguments to a function call. In this case, one gets the type expected at the cursor as well as the other labels.
+
+Entries is the list of possible completion. Each entry is made of:
+- a name, the text that should be put in the buffer if selected
+- a kind, one of `'value'`, `'variant'`, `'constructor'`, `'label'`, `'module'`, `'signature'`, `'type'`, `'method'`, `'#'` (for method calls), `'exn'`, `'class'`
+- a description, most of the time a type or a definition line, to be put next to the name in completion box
+- optional information which might not fit in the completion box, like signatures for modules or documentation string."
+    ~default:("",`None,[],false,true)
+    begin fun buffer (txt,pos,kinds,doc,typ) ->
+      match pos with
+      | `None -> failwith "-position <pos> is mandatory"
+      | #Msource.position as pos ->
+        run buffer (Query_protocol.Complete_prefix (txt,pos,List.rev kinds,doc,typ))
+    end
+  ;
+
+  command "document"
+~doc:"Returns OCamldoc documentation as a string.
+If `-identifier ident` is specified, documentation for this ident is looked \
+up from environment at `-position`.
+Otherwise, Merlin looks for the documentation for the entity under the cursor (at `-position`)."
+    ~spec: [
+      arg "-position" "<position> Position to complete"
+          (marg_position (fun pos (ident,_pos) -> (ident,pos)));
+      optional "-identifier" "<string> Identifier"
+          (Marg.param "string" (fun ident (_ident,pos) -> (Some ident,pos)));
+    ]
+    ~default:(None,`None)
+    begin fun buffer (ident,pos) ->
+      match pos with
+      | `None -> failwith "-position <pos> is mandatory"
+      | #Msource.position as pos ->
+        run buffer (Query_protocol.Document (ident, pos))
+    end
+  ;
+
+  command "enclosing"
+    ~spec: [
+      arg "-position" "<position> Position to complete"
+          (marg_position (fun pos _pos -> pos));
+    ]
+~doc:"Returns a list of locations `{'start': position, 'end': position}` in \
+increasing size of all entities surrounding the position.
+(In a lisp, this would be the locations of all s-exps that contain the cursor.)"
+    ~default:`None
+    begin fun buffer pos ->
+      match pos with
+      | `None -> failwith "-position <pos> is mandatory"
+      | #Msource.position as pos ->
+        run buffer (Query_protocol.Enclosing pos)
+    end
+  ;
+
+  command "errors"
+    ~spec:[
+      arg "-lexing" "<bool> Whether to report lexing errors or not"
+        (Marg.bool (fun l (_,p,t) -> (l,p,t)));
+      arg "-parsing" "<bool> Whether to report parsing errors or not"
+        (Marg.bool (fun p (l,_,t) -> (l,p,t)));
+      arg "-typing" "<bool> Whether to report typing errors or not"
+        (Marg.bool (fun t (l,p,_) -> (l,p,t)));
+    ]
+    ~doc:"Returns a list of errors in current buffer.
+The value is a list where each item as the shape:
+
+```javascript
+{
+'start' : position,
+'end'   : position,
+'valid' : bool,
+'message' : string,
+'type'  : ('type'|'parser'|'env'|'warning'|'unkown')
+}
+```
+
+`start` and `end` are omitted if error has no location \
+(e.g. wrong file format), otherwise the editor should probably highlight / \
+mark this range.
+`type` is an attempt to classify the error.
+`valid` is here mostly for informative purpose. \
+It reflects whether Merlin was expecting such an error to be possible or not, \
+and is useful for debugging purposes.
+`message` is the error description to be shown to the user."
+    ~default:(true, true, true)
+    begin fun buffer (lexing, parsing, typing) ->
+      run buffer (Query_protocol.Errors { lexing; parsing; typing })
+    end
+  ;
+
+  command "expand-prefix"
+~doc:"
+The function behaves like `complete-prefix`, but it also handles partial, \
+incorrect, or wrongly spelled prefixes (as determined by some heuristic).
+For instance, `L.ma` can get expanded to `List.map`. This function is a \
+useful fallback if normal completion gave no results.
+Be careful that it always return fully qualified paths, whereas normal \
+completion only completes an identifier (last part of a module path)."
+    ~spec: [
+      arg "-position" "<position> Position to complete"
+        (marg_position (fun pos (txt,_pos,kinds,typ) -> (txt,pos,kinds,typ)));
+      arg "-prefix" "<string> Prefix to complete"
+        (Marg.param "string" (fun txt (_prefix,pos,kinds,typ) -> (txt,pos,kinds,typ)));
+      optional "-types" "<bool> Report type information (default is false)"
+        (Marg.bool (fun typ (txt,pos,kinds,_typ) -> (txt,pos,kinds,typ)));
+      optional "-kind"
+        "<completion-kind> Namespace to complete (value, constructor, type, variant, label, module, module-type). Default is decided by cursor context"
+        (marg_completion_kind (fun kind (txt,pos,kinds,typ) -> (txt,pos,kind::kinds,typ)));
+    ]
+    ~default:("",`None,[],false)
+    begin fun buffer (txt,pos,kinds,typ) ->
+      match pos with
+      | `None -> failwith "-position <pos> is mandatory"
+      | #Msource.position as pos ->
+        run buffer (Query_protocol.Expand_prefix (txt,pos,List.rev kinds,typ))
+    end
+  ;
+
+  command "extension-list"
+    ~spec: [
+      optional "-status" "<all|enabled|disabled> Filter extensions"
+        (Marg.param "<all|enabled|disabled>"
+         (fun status _status -> match status with
+            | "all" -> `All
+            | "enabled" -> `Enabled
+            | "disabled" -> `Disabled
+            | _ -> failwith "-status should be one of all, disabled or enabled"
+         ));
+    ]
+    ~doc:"List all known / currently enabled / currently disabled extensions \
+          as a list of strings."
+    ~default:`All
+    begin fun buffer status ->
+      run buffer (Query_protocol.Extension_list status)
+    end
+  ;
+
+  command "findlib-list"
+    ~doc:"Returns all known findlib packages as a list of string."
+    ~spec:[]
+    ~default:()
+    begin fun buffer () ->
+      run buffer (Query_protocol.Findlib_list)
+    end
+  ;
+
+  command "flags-list"
+    ~spec:[]
+~doc:"Returns supported compiler flags.\
+The purpose of this command is to implement interactive completion of \
+compiler settings in an IDE."
+    ~default:()
+    begin fun _ () ->
+      `List (List.map ~f:Json.string (Mconfig.flags_for_completion ()))
+    end
+  ;
+
+  command "jump"
+    ~spec: [
+      arg "-target" "<string> Entity to jump to"
+        (Marg.param "string" (fun target (_,pos) -> (target,pos)));
+      arg "-position" "<position> Position to complete"
+        (marg_position (fun pos (target,_pos) -> (target,pos)));
+    ]
+~doc:"This command can be used to assist navigation in a source code buffer.
+Target is a string that can contain one or more of the 'fun', 'let', 'module' \
+and 'match' words.
+It returns the starting position of the function, let definition, module or \
+match expression that contains the cursor
+"
+    ~default:("",`None)
+    begin fun buffer (target,pos) ->
+      match pos with
+      | `None -> failwith "-position <pos> is mandatory"
+      | #Msource.position as pos ->
+        run buffer (Query_protocol.Jump (target,pos))
+    end
+  ;
+
+  command "phrase"
+    ~spec: [
+      arg "-target" "<next|prev> Entity to jump to"
+        (Marg.param "string" (fun target (_,pos) ->
+           match target with
+           | "next" -> (`Next,pos)
+           | "prev" -> (`Prev,pos)
+           | _ -> failwith "-target should be one of 'next' or 'prev'"
+         ));
+      arg "-position" "<position> Position to complete"
+        (marg_position (fun pos (target,_pos) -> (target,pos)));
+    ]
+    ~doc:"Returns the position of the next or previous phrase \
+          (top-level definition or module definition)."
+    ~default:(`Next,`None)
+    begin fun buffer (target,pos) ->
+      match pos with
+      | `None -> failwith "-position <pos> is mandatory"
+      | #Msource.position as pos ->
+        run buffer (Query_protocol.Phrase (target,pos))
+    end
+  ;
+
+  command "list-modules"
+    ~spec:[
+      many "-ext" "<extension> file extensions to look for"
+        (Marg.param "extension" (fun ext exts -> ext :: exts));
+    ]
+~doc:"Looks into project source paths for files with an extension \
+matching and prints the corresponding module name."
+    ~default:[]
+
+    begin fun buffer extensions ->
+      run buffer (Query_protocol.List_modules (List.rev extensions))
+    end
+  ;
+
+  command "locate"
+    ~spec: [
+      optional "-prefix" "<string> Prefix to complete"
+        (Marg.param "string" (fun txt (_,pos,kind) -> (Some txt,pos,kind)));
+      arg "-position" "<position> Position to complete"
+        (marg_position (fun pos (prefix,_pos,kind) -> (prefix,pos,kind)));
+      optional "-look-for" "<interface|implementation> Prefer opening interface or implementation"
+        (Marg.param "<interface|implementation>"
+          (fun kind (prefix,pos,_) -> match kind with
+            | "mli" | "interface" -> (prefix,pos,`MLI)
+            | "ml"  | "implementation" -> (prefix,pos,`ML)
+            | str ->
+              failwithf "expecting interface or implementation, got %S." str));
+    ]
+~doc:"Finds the declaration of entity at the specified position, \
+Or referred to by specified string.
+Returns either:
+- if location failed, a `string` describing the reason to the user,
+- `{'pos': position}` if the location is in the current buffer,
+- `{'file': string, 'pos': position}` if definition is located in a \
+different file."
+    ~default:(None,`None,`MLI)
+    begin fun buffer (prefix,pos,lookfor) ->
+      match pos with
+      | `None -> failwith "-position <pos> is mandatory"
+      | #Msource.position as pos ->
+        run buffer (Query_protocol.Locate (prefix,lookfor,pos))
+    end
+  ;
+
+  command "locate-type"
+    ~spec: [
+      arg "-position" "<position> Position to complete"
+        (marg_position (fun pos _ -> pos));
+    ]
+    ~doc: "Locate the declaration of the type of the expression"
+    ~default:`None
+    begin fun buffer pos ->
+      match pos with
+      | `None -> failwith "-position <pos> is mandatory"
+      | #Msource.position as pos ->
+        run buffer (Query_protocol.Locate_type pos)
+    end
+  ;
+
+  command "occurrences"
+    ~spec: [
+      arg "-identifier-at" "<position> Position to complete"
+        (marg_position (fun pos _pos -> (`Ident_at pos)));
+    ]
+~doc:"Returns a list of locations `{'start': position, 'end': position}` \
+of all occurrences in current buffer of the entity at the specified position."
+    ~default:`None
+    begin fun buffer -> function
+      | `None -> failwith "-identifier-at <pos> is mandatory"
+      | `Ident_at pos ->
+        run buffer (Query_protocol.Occurrences (`Ident_at pos))
+    end
+  ;
+
+  command "outline"
+    ~spec:[]
+~doc:"Returns a tree of objects `{'start': position, 'end': position, \
+'name': string, 'kind': string, 'children': subnodes}` describing the content \
+of the buffer."
+    ~default:()
+    begin fun buffer () ->
+      run buffer (Query_protocol.Outline)
+    end
+  ;
+
+  command "path-of-source"
+    ~doc:"Looks for first file with a matching name in the project source \
+          and build paths"
+    ~spec: [
+      arg "-file" "<filename> filename to look for in project paths"
+        (Marg.param "filename" (fun file files -> file :: files));
+    ]
+    ~default:[]
+
+    begin fun buffer filenames ->
+      run buffer (Query_protocol.Path_of_source (List.rev filenames))
+    end
+  ;
+
+  command "refactor-open"
+    ~doc:"refactor-open -position pos -action <qualify|unqualify>\n\t\
+          TODO"
+    ~spec: [
+      arg "-position" "<position> Position to complete"
+        (marg_position (fun pos (action,_pos) -> (action,pos)));
+      arg "-action" "<qualify|unqualify> Direction of rewriting"
+        (Marg.param "<qualify|unqualify>" (fun action (_action,pos) ->
+             match action with
+             | "qualify" -> (Some `Qualify,pos)
+             | "unqualify" -> (Some `Unqualify,pos)
+             | _ -> failwith "invalid -action"
+           )
+        );
+    ]
+    ~default:(None,`None)
+    begin fun buffer -> function
+      | (None, _) -> failwith "-action is mandatory"
+      | (_, `None) -> failwith "-position is mandatory"
+      | (Some action, (#Msource.position as pos)) ->
+        run buffer (Query_protocol.Refactor_open (action,pos))
+    end
+  ;
+
+  command "search-by-polarity"
+    ~doc:"search-by-polarity -position pos -query ident\n\t\
+          TODO"
+    ~spec: [
+      arg "-position" "<position> Position to complete"
+        (marg_position (fun pos (query,_pos) -> (query,pos)));
+      arg "-query" "<string> Query of the form TODO"
+        (Marg.param "string" (fun query (_prefix,pos) -> (query,pos)));
+    ]
+    ~default:("",`None)
+    begin fun buffer (query,pos) ->
+      match pos with
+      | `None -> failwith "-position <pos> is mandatory"
+      | #Msource.position as pos ->
+        run buffer (Query_protocol.Polarity_search (query,pos))
+    end
+  ;
+
+  command "shape"
+~doc:"This command can be used to assist navigation in a source code buffer.
+It returns a tree of all relevant locations around the cursor.
+It is similar to outline without telling any information about the entity \
+at a given location.
+```javascript
+shape =
+{
+  'start' : position,
+  'end'   : position,
+  'children' : [shape]
+}
+```
+"
+    ~spec: [
+      arg "-position" "<position> Position "
+        (marg_position (fun pos _pos -> pos));
+    ]
+    ~default:`None
+    begin fun buffer -> function
+      | `None -> failwith "-position <pos> is mandatory"
+      | #Msource.position as pos ->
+        run buffer (Query_protocol.Shape pos)
+    end
+  ;
+
+  command "type-enclosing"
+~doc:"Returns a list of type information for all expressions at given \
+position, sorted by increasing size.
+That is asking for type enlosing around `2` in `string_of_int 2` will return \
+the types of `2 : int` and `string_of_int 2 : string`.
+
+If `-expression` and `-cursor` are specified, the first result will be the type
+relevant to the prefix ending at the `cursor` offset.
+
+`-index` can be used to print only one type information. This is useful to
+query the types lazily: normally, Merlin would return the signature of all
+enclosing modules, which can be very expensive.
+
+The result is returned as a list of:
+```javascript
+{
+  'start': position,
+  'end': position,
+  'type': string,
+  // is this expression not in tail position, in tail position, \
+or even a tail call?
+  'tail': ('no' | 'position' | 'call')
+}
+```"
+    ~spec: [
+      arg "-position" "<position> Position to complete"
+        (marg_position (fun pos (expr,cursor,_pos,index) -> (expr,cursor,pos,index)));
+      optional "-expression" "<string> Expression to type"
+        (Marg.param "string" (fun expr (_expr,cursor,pos,index) -> (expr,cursor,pos,index)));
+      optional "-cursor" "<int> Position of the cursor inside expression"
+        (Marg.param "int" (fun cursor (expr,_cursor,pos,index) ->
+            match int_of_string cursor with
+            | cursor -> (expr,cursor,pos,index)
+            | exception _ ->
+              failwith "cursor should be an integer"
+          ));
+      optional "-index" "<int> Only print type of <index>'th result"
+        (Marg.param "int" (fun index (expr,cursor,pos,_index) ->
+            match int_of_string index with
+            | index -> (expr,cursor,pos,Some index)
+            | exception _ ->
+              failwith "index should be an integer"
+          ));
+    ]
+    ~default:("",-1,`None,None)
+    begin fun buffer (expr,cursor,pos,index) ->
+      match pos with
+      | `None -> failwith "-position <pos> is mandatory"
+      | #Msource.position as pos ->
+        let expr =
+          if expr = "" then None
+          else
+            let cursor = if cursor = -1 then String.length expr else cursor in
+            Some (expr, cursor)
+        in
+        run buffer (Query_protocol.Type_enclosing (expr,pos,index))
+    end
+  ;
+
+  command "type-expression"
+~doc:"Returns the type of the expression when typechecked in the environment \
+around the specified position."
+    ~spec: [
+      arg "-position" "<position> Position to complete"
+        (marg_position (fun pos (expr,_pos) -> (expr,pos)));
+      arg "-expression" "<string> Expression to type"
+        (Marg.param "string" (fun expr (_expr,pos) -> (expr,pos)));
+    ]
+    ~default:("",`None)
+    begin fun buffer (expr,pos) ->
+      match pos with
+      | `None -> failwith "-position <pos> is mandatory"
+      | #Msource.position as pos ->
+        run buffer (Query_protocol.Type_expr (expr,pos))
+    end
+  ;
+
+  (* Implemented without support from Query_protocol.  This command might be
+     refactored if it proves useful for old protocol too.  *)
+  command "check-configuration"
+    ~spec:[]
+~doc:"This command checks that merlin project and options are correct.
+The return value has the shape:
+```javascript
+{
+  'dot_merlins': [path], // a list of string
+  'failures': [message]  // a list of string
+}
+```"
+    ~default:()
+    begin fun pipeline () ->
+      let config = Mpipeline.final_config pipeline in
+      `Assoc [
+        (* TODO Remove support for multiple configuration files
+          The protocol could be changed to:
+          'config_file': path_to_dot_merlin_or_dune
+
+          For now, if the configurator is dune, the field 'dot_merlins'
+          will contain the path to the dune file (or jbuild, or dune-project)
+        *)
+
+        "dot_merlins", `List
+          (match Mconfig.(config.merlin.config_path) with
+          | Some path -> [Json.string path]
+          | None -> []);
+        "failures", `List (List.map ~f:Json.string
+                             Mconfig.(config.merlin.failures));
+      ]
+    end
+  ;
+
+  (* Used only for testing *)
+  command "dump"
+    ~spec:[
+      arg "-what" "<source|parsetree|ppxed-source|ppxed-parsetree|typedtree\
+                   |env|fullenv|browse|tokens|flags|warnings|exn|paths> \
+                   Information to dump ()"
+        (Marg.param "string" (fun what _ -> what));
+    ]
+    ~default:""
+    ~doc:"Not for the casual user, used for debugging merlin"
+    begin fun pipeline what ->
+      run pipeline (Query_protocol.Dump [`String what])
+    end
+  ;
+
+  (* Used only for testing *)
+  command "dump-configuration" ~spec:[] ~default:()
+    ~doc:"Not for the casual user, used for merlin tests"
+    begin fun pipeline () ->
+      Mconfig.dump (Mpipeline.final_config pipeline)
+    end
+  ;
+
+]
diff --git a/src/frontend/ocamlmerlin/new/new_commands.mli b/src/frontend/ocamlmerlin/new/new_commands.mli
new file mode 100644
index 0000000..2c6498a
--- /dev/null
+++ b/src/frontend/ocamlmerlin/new/new_commands.mli
@@ -0,0 +1,9 @@
+open Std
+
+type command =
+    Command : string * Marg.docstring * ([`Mandatory|`Optional|`Many] * 'args Marg.spec) list * 'args *
+              (Mpipeline.t -> 'args -> json) -> command
+
+val all_commands : command list
+
+val find_command : string -> command list -> command
diff --git a/src/frontend/ocamlmerlin/new/new_merlin.ml b/src/frontend/ocamlmerlin/new/new_merlin.ml
new file mode 100644
index 0000000..5231304
--- /dev/null
+++ b/src/frontend/ocamlmerlin/new/new_merlin.ml
@@ -0,0 +1,167 @@
+(** {1 Prepare command-line arguments} *)
+
+let {Logger. log} = Logger.for_section "New_merlin"
+
+let usage () =
+  prerr_endline
+    "Usage: ocamlmerlin command [options] -- [compiler flags]\n\
+     Help commands are:\n\
+    \  -version        Print version and exit\n\
+    \  -vnum           Print version number and exit\n\
+    \  -warn-help      Show description of warning numbers\n\
+    \  -flags-help     Show description of accepted compiler flags\n\
+    \  -commands-help  Describe all accepted commands\n"
+
+let commands_help () =
+  print_endline "Query commands are:";
+  List.iter (fun (New_commands.Command (name, doc, args, _, _)) ->
+      print_newline ();
+      let args = List.map (fun (kind, (key0,desc,_)) ->
+        let key1, desc =
+          let len = String.length desc in
+          match String.index desc ' ' with
+          | 0 -> key0, String.sub desc 1 (len - 1)
+          | idx -> key0 ^ " " ^ String.sub desc 0 idx,
+                   String.sub desc (idx + 1) (len - idx - 1)
+          | exception Not_found -> key0, desc
+        in
+        let key = match kind with
+          | `Mandatory -> key1
+          | `Optional  -> "[ " ^ key1 ^ " ]"
+          | `Many      -> "[ " ^ key1 ^ " " ^ key0 ^ " ... ]"
+        in
+        key, (key1, desc)
+      ) args in
+      let args, descs = List.split args in
+      print_endline ("### `" ^ String.concat " " (name :: args) ^ "`");
+      print_newline ();
+      let print_desc (k,d) = print_endline (Printf.sprintf "%24s  %s" k d) in
+      List.iter print_desc descs;
+      print_newline ();
+      print_endline doc
+    ) New_commands.all_commands
+
+let run = function
+  | [] ->
+    usage ();
+    1
+  | "-version" :: _ ->
+    Printf.printf "The Merlin toolkit version %s, for Ocaml %s\n"
+      My_config.version Sys.ocaml_version;
+    0
+  | "-vnum" :: _ ->
+    Printf.printf "%s\n" My_config.version;
+    0
+  | "-warn-help" :: _ ->
+    Warnings.help_warnings ();
+    0
+  | "-flags-help" :: _ ->
+    Mconfig.document_arguments stdout;
+    0
+  | "-commands-help" :: _ ->
+    commands_help ();
+    0
+  | query :: raw_args ->
+    match New_commands.find_command query New_commands.all_commands with
+    | exception Not_found ->
+      prerr_endline ("Unknown command " ^ query ^ ".\n");
+      usage ();
+      1
+    | New_commands.Command (_name, _doc, spec, command_args, command_action) ->
+      (* Setup notifications *)
+      let notifications = ref [] in
+      Logger.with_notifications notifications @@ fun () ->
+      (* Parse commandline *)
+      match begin
+        let start_cpu = Misc.time_spent () in
+        let start_clock = Unix.gettimeofday () *. 1000. in
+        let config, command_args =
+          let fails = ref [] in
+          let config, command_args =
+            Mconfig.parse_arguments
+              ~wd:(Sys.getcwd ()) ~warning:(fun w -> fails := w :: !fails)
+              (List.map snd spec) raw_args Mconfig.initial command_args
+          in
+          let config =
+            let failures = !fails @ config.merlin.failures in
+            Mconfig.({config with merlin = {config.merlin with failures}})
+          in
+          config, command_args
+        in
+        (* Start processing query *)
+        Logger.with_log_file Mconfig.(config.merlin.log_file)
+          ~sections:Mconfig.(config.merlin.log_sections) @@ fun () ->
+        File_id.with_cache @@ fun () ->
+        let source = Msource.make (Misc.string_of_file stdin) in
+        let pipeline = Mpipeline.make config source in
+        let json =
+          let class_, message =
+            Printexc.record_backtrace true;
+            match
+              Mpipeline.with_pipeline pipeline @@ fun () ->
+              command_action pipeline command_args
+            with
+            | result ->
+              ("return", result)
+            | exception (Failure str) ->
+              let trace = Printexc.get_backtrace () in
+              log ~title:"run" "Command error backtrace: %s" trace;
+              ("failure", `String str)
+            | exception exn ->
+              let trace = Printexc.get_backtrace () in
+              log ~title:"run" "Command error backtrace: %s" trace;
+              match Location.error_of_exn exn with
+              | None | Some `Already_displayed ->
+                ("exception", `String (Printexc.to_string exn ^ "\n" ^ trace))
+              | Some (`Ok err) ->
+                Location.print_main Format.str_formatter err;
+                ("error", `String (Format.flush_str_formatter ()))
+          in
+          let cpu_time = Misc.time_spent () -. start_cpu in
+          let clock_time = Unix.gettimeofday () *. 1000. -. start_clock in
+          let timing = Mpipeline.timing_information pipeline in
+          let pipeline_time =
+            List.fold_left (fun acc (_, k) -> k +. acc) 0.0 timing in
+          let timing = ("clock", clock_time) ::
+                       ("cpu", cpu_time) ::
+                       ("query", (cpu_time -. pipeline_time)) :: timing in
+          let notify { Logger.section; msg } =
+            `String (Printf.sprintf "%s: %s" section msg)
+          in
+          let format_timing (k,v) = (k, `Int (int_of_float (0.5 +. v))) in
+          `Assoc [
+            "class", `String class_; "value", message;
+            "notifications", `List (List.rev_map notify !notifications);
+            "timing", `Assoc (List.map format_timing timing)
+          ]
+        in
+        log ~title:"run(result)" "%a" Logger.json (fun () -> json);
+        begin match Mconfig.(config.merlin.protocol) with
+          | `Sexp -> Sexp.tell_sexp print_string (Sexp.of_json json)
+          | `Json -> Std.Json.to_channel stdout json
+        end;
+        print_newline ()
+      end with
+      | () -> 0
+      | exception exn ->
+        prerr_endline ("Exception: " ^ Printexc.to_string exn);
+        1
+
+let run ~new_env wd args =
+  begin match new_env with
+  | Some env ->
+    Os_ipc.merlin_set_environ env;
+    Unix.putenv "__MERLIN_MASTER_PID" (string_of_int (Unix.getpid ()))
+  | None -> () end;
+  let wd_msg = match wd with
+    | None -> "No working directory specified"
+    | Some wd ->
+      try Sys.chdir wd; Printf.sprintf "changed directory to %S" wd
+      with _ -> Printf.sprintf "cannot change working directory to %S" wd
+  in
+  let `Log_file_path log_file, `Log_sections sections =
+    Log_info.get ()
+  in
+  Logger.with_log_file log_file ~sections @@ fun () ->
+  log ~title:"run" "%s" wd_msg;
+  run args
diff --git a/src/frontend/ocamlmerlin/ocamlmerlin.c b/src/frontend/ocamlmerlin/ocamlmerlin.c
new file mode 100644
index 0000000..6e7ce9a
--- /dev/null
+++ b/src/frontend/ocamlmerlin/ocamlmerlin.c
@@ -0,0 +1,710 @@
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <signal.h>
+#ifdef _WIN32
+/* GetNamedPipeServerProcessId requires Windows Vista+ */
+#undef _WIN32_WINNT
+#define _WIN32_WINNT 0x600
+#include <windows.h>
+#include <Lmcons.h>
+#include <process.h>
+#include <sddl.h>       // ConvertSidToStringSid
+#ifndef STDIN_FILENO
+#define STDIN_FILENO 0
+#endif
+#ifndef STDOUT_FILENO
+#define STDOUT_FILENO 1
+#endif
+#ifndef STDERR_FILENO
+#define STDERR_FILENO 2
+#endif
+#ifdef _MSC_VER
+typedef SSIZE_T ssize_t;
+#define PATH_MAX MAX_PATH
+#ifndef _UCRT
+#define snprintf _snprintf
+#endif
+#endif
+#else
+#include <unistd.h>
+#include <sys/socket.h>
+#include <sys/un.h>
+#include <sys/stat.h>
+#include <sys/wait.h>
+#include <libgen.h>
+#endif
+#include <errno.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <limits.h>
+
+#if defined(__linux)
+#include <sys/param.h>
+#elif defined(__APPLE__)
+#include <sys/syslimits.h>
+#elif defined(__OpenBSD__)
+#include <sys/param.h>
+#endif
+
+/** Portability information **/
+
+/* Determine OS, http://stackoverflow.com/questions/6649936
+   __linux__       Defined on Linux
+   __sun           Defined on Solaris
+   __FreeBSD__     Defined on FreeBSD
+   __NetBSD__      Defined on NetBSD
+   __OpenBSD__     Defined on OpenBSD
+   __APPLE__       Defined on Mac OS X
+   __hpux          Defined on HP-UX
+   __osf__         Defined on Tru64 UNIX (formerly DEC OSF1)
+   __sgi           Defined on Irix
+   _AIX            Defined on AIX
+*/
+
+/* Compute executable path, http://stackoverflow.com/questions/1023306
+   Mac OS X       _NSGetExecutablePath() (man 3 dyld)
+   Linux          readlink /proc/self/exe
+   Solaris        getexecname()
+   FreeBSD        sysctl CTL_KERN KERN_PROC KERN_PROC_PATHNAME -1
+   NetBSD         readlink /proc/curproc/exe
+   DragonFly BSD  readlink /proc/curproc/file
+   Windows        GetModuleFileName() with hModule = NULL
+*/
+
+#define NO_EINTR(var, command) \
+  do { (var) = command; } while ((var) == -1 && errno == EINTR)
+
+static void dumpinfo(void);
+
+static void failwith_perror(const char *msg)
+{
+  perror(msg);
+  dumpinfo();
+  exit(EXIT_FAILURE);
+}
+
+static void failwith(const char *msg)
+{
+  fprintf(stderr, "%s\n", msg);
+  dumpinfo();
+  exit(EXIT_FAILURE);
+}
+
+#define PATHSZ (PATH_MAX+1)
+
+#define BEGIN_PROTECTCWD \
+  { char previous_cwd[PATHSZ]; \
+    if (!getcwd(previous_cwd, PATHSZ)) previous_cwd[0] = '\0';
+
+/* Return from chdir is ignored */
+#define END_PROTECTCWD \
+    if (previous_cwd[0] != '\0') if (chdir(previous_cwd)) {} }
+
+static const char *path_socketdir(void)
+{
+  static const char *tmpdir = NULL;
+  if (tmpdir == NULL)
+    tmpdir = getenv("TMPDIR");
+  if (tmpdir == NULL)
+    tmpdir = "/tmp";
+  return tmpdir;
+}
+
+#ifdef _WIN32
+/** Deal with Windows IPC **/
+
+static void ipc_send(HANDLE hPipe, unsigned char *buffer, size_t len, HANDLE fds[3])
+{
+  DWORD dwNumberOfBytesWritten;
+  if (!WriteFile(hPipe, fds, 3 * sizeof(HANDLE), &dwNumberOfBytesWritten, NULL) || dwNumberOfBytesWritten != 3 * sizeof(HANDLE))
+    failwith_perror("sendmsg");
+  if (!WriteFile(hPipe, buffer, len, &dwNumberOfBytesWritten, NULL) || dwNumberOfBytesWritten != len)
+    failwith_perror("send");
+}
+
+#else
+/** Deal with UNIX IPC **/
+
+static void ipc_send(int fd, unsigned char *buffer, size_t len, int fds[3])
+{
+  char msg_control[CMSG_SPACE(3 * sizeof(int))];
+  struct iovec iov = { .iov_base = buffer, .iov_len = len };
+  struct msghdr msg = {
+    .msg_iov = &iov, .msg_iovlen = 1,
+    .msg_controllen = CMSG_SPACE(3 * sizeof(int)),
+  };
+  msg.msg_control = &msg_control;
+  memset(msg.msg_control, 0, msg.msg_controllen);
+
+  struct cmsghdr *cm = CMSG_FIRSTHDR(&msg);
+  cm->cmsg_level = SOL_SOCKET;
+  cm->cmsg_type = SCM_RIGHTS;
+  cm->cmsg_len = CMSG_LEN(3 * sizeof(int));
+
+  int *fds0 = (int*)CMSG_DATA(cm);
+  fds0[0] = fds[0];
+  fds0[1] = fds[1];
+  fds0[2] = fds[2];
+
+  ssize_t sent;
+  NO_EINTR(sent, sendmsg(fd, &msg, 0));
+
+  if (sent == -1)
+    failwith_perror("sendmsg");
+
+  while (sent < len)
+  {
+    ssize_t sent_;
+    NO_EINTR(sent_, send(fd, buffer + sent, len - sent, 0));
+
+    if (sent_ == -1)
+      failwith_perror("sent");
+
+    sent += sent_;
+  }
+}
+#endif
+
+/* Serialize arguments */
+
+#define byte(x,n) ((unsigned)((x) >> (n * 8)) & 0xFF)
+
+static void append_argument(unsigned char *buffer, size_t len, ssize_t *pos, const char *p)
+{
+  ssize_t j = *pos;
+  while (*p && j < len)
+  {
+    buffer[j] = *p;
+    j += 1;
+    p += 1;
+  }
+
+  if (j >= len)
+    failwith("maximum number of arguments exceeded");
+
+  buffer[j] = 0;
+  j += 1;
+  *pos = j;
+}
+
+#ifdef _MSC_VER
+extern __declspec(dllimport) char **environ;
+#else
+extern char **environ;
+#endif
+
+static ssize_t prepare_args(unsigned char *buffer, size_t len, int argc, char **argv)
+{
+  int i = 0;
+  ssize_t j = 4;
+
+  /* First put the current working directory */
+
+  char cwd[PATHSZ];
+  if (!getcwd(cwd, PATHSZ)) cwd[0] = '\0';
+  append_argument(buffer, len, &j, cwd);
+
+  /* Then append environ */
+  for (i = 0; environ[i] != NULL; ++i)
+  {
+    const char *v = environ[i];
+    if (v[0] == '\0') continue;
+
+    append_argument(buffer, len, &j, environ[i]);
+  }
+
+  /* Env var delimiter */
+  append_argument(buffer, len, &j, "");
+
+  /* Append arguments */
+  for (i = 0; i < argc && j < len; ++i)
+  {
+    append_argument(buffer, len, &j, argv[i]);
+  }
+
+  /* Put size at the beginning */
+  buffer[0] = byte(j,0);
+  buffer[1] = byte(j,1);
+  buffer[2] = byte(j,2);
+  buffer[3] = byte(j,3);
+  return j;
+}
+
+#ifdef _WIN32
+#define IPC_SOCKET_TYPE HANDLE
+static HANDLE connect_socket(const char *socketname, int fail)
+{
+  HANDLE hPipe;
+  hPipe = CreateFile(socketname, GENERIC_READ | GENERIC_WRITE, 0, NULL, OPEN_EXISTING, 0, 0);
+  if (hPipe == INVALID_HANDLE_VALUE)
+    if (fail) failwith_perror("connect");
+  return hPipe;
+}
+#else
+#define IPC_SOCKET_TYPE int
+#define INVALID_HANDLE_VALUE -1
+static int connect_socket(const char *socketname, int fail)
+{
+  int sock = socket(PF_UNIX, SOCK_STREAM, 0);
+  if (sock == -1) failwith_perror("socket");
+
+  int err;
+
+  BEGIN_PROTECTCWD
+    struct sockaddr_un address;
+    int address_len;
+
+    /* Return from chdir is ignored */
+    err = chdir(path_socketdir());
+    address.sun_family = AF_UNIX;
+    snprintf(address.sun_path, 104, "./%s", socketname);
+    address_len = strlen(address.sun_path) + sizeof(address.sun_family) + 1;
+
+    NO_EINTR(err, connect(sock, (struct sockaddr*)&address, address_len));
+  END_PROTECTCWD
+
+  if (err == -1)
+  {
+    if (fail) failwith_perror("connect");
+    close(sock);
+    return -1;
+  }
+
+  return sock;
+}
+#endif
+
+#ifdef _WIN32
+static void start_server(const char *socketname, const char* eventname, const char *exec_path)
+{
+  char buf[PATHSZ];
+  PROCESS_INFORMATION pi;
+  STARTUPINFO si;
+  HANDLE hEvent = CreateEvent(NULL, FALSE, FALSE, eventname);
+  DWORD dwResult;
+  sprintf(buf, "%s server %s %s", exec_path, socketname, eventname);
+  ZeroMemory(&si, sizeof(si));
+  si.cb = sizeof(si);
+  ZeroMemory(&pi, sizeof(pi));
+  /* Note that DETACHED_PROCESS means that the process does not appear in Task Manager
+     but the server can still be stopped with ocamlmerlin server stop-server */
+  if (!CreateProcess(exec_path, buf, NULL, NULL, FALSE, DETACHED_PROCESS, NULL, NULL, &si, &pi))
+    failwith_perror("fork");
+  CloseHandle(pi.hProcess);
+  CloseHandle(pi.hThread);
+  if (WaitForSingleObject(hEvent, 5000) != WAIT_OBJECT_0)
+    failwith_perror("execlp");
+}
+#else
+static void make_daemon(int sock)
+{
+  /* On success: The child process becomes session leader */
+  if (setsid() < 0)
+    failwith_perror("setsid");
+
+  /* Close all open file descriptors */
+  close(0);
+  if (open("/dev/null", O_RDWR, 0) != 0)
+    failwith_perror("open");
+  dup2(0,1);
+  dup2(0,2);
+
+  /* Change directory to root, so that process still works if directory
+   * is delete. */
+  if (chdir("/") != 0)
+    failwith_perror("chdir");
+
+  //int x;
+  //for (x = sysconf(_SC_OPEN_MAX); x>2; x--)
+  //{
+  //  if (x != sock)
+  //    close(x);
+  //}
+
+  pid_t child = fork();
+  signal(SIGHUP, SIG_IGN);
+
+  /* An error occurred */
+  if (child < 0)
+    failwith_perror("fork");
+
+  /* Success: Let the parent terminate */
+  if (child > 0)
+    exit(EXIT_SUCCESS);
+}
+
+static void start_server(const char *socketname, const char* ignored, const char *exec_path)
+{
+  int sock = socket(PF_UNIX, SOCK_STREAM, 0);
+  if (sock == -1)
+    failwith_perror("socket");
+
+  int err;
+
+  BEGIN_PROTECTCWD
+    struct sockaddr_un address;
+    int address_len;
+
+    /* Return from chdir is ignored */
+    err = chdir(path_socketdir());
+    address.sun_family = AF_UNIX;
+    snprintf(address.sun_path, 104, "./%s", socketname);
+    address_len = strlen(address.sun_path) + sizeof(address.sun_family) + 1;
+    unlink(address.sun_path);
+
+    NO_EINTR(err, bind(sock, (struct sockaddr*)&address, address_len));
+  END_PROTECTCWD
+
+  if (err == -1)
+    failwith_perror("bind");
+
+  if (listen(sock, 5) == -1)
+    failwith_perror("listen");
+
+  pid_t child = fork();
+
+  if (child == -1)
+    failwith_perror("fork");
+
+  if (child == 0)
+  {
+    make_daemon(sock);
+
+    char socket_fd[50], socket_path[PATHSZ];
+    sprintf(socket_fd, "%d", sock);
+    snprintf(socket_path, PATHSZ, "%s/%s", path_socketdir(), socketname);
+    //execlp("nohup", "nohup", exec_path, "server", socket_path, socket_fd, NULL);
+    execlp(exec_path, exec_path, "server", socket_path, socket_fd, NULL);
+    failwith_perror("execlp");
+  }
+
+  close(sock);
+  wait(NULL);
+}
+#endif
+
+static IPC_SOCKET_TYPE connect_and_serve(const char *socket_path, const char* event_path, const char *exec_path)
+{
+  IPC_SOCKET_TYPE sock = connect_socket(socket_path, 0);
+
+  if (sock == INVALID_HANDLE_VALUE)
+  {
+    start_server(socket_path, event_path, exec_path);
+    sock = connect_socket(socket_path, 1);
+  }
+
+  if (sock == INVALID_HANDLE_VALUE)
+    abort();
+
+  return sock;
+}
+
+/* OCaml merlin path */
+
+static const char *search_in_path(const char *PATH, const char *argv0, char *merlin_path)
+{
+  static char binary_path[PATHSZ];
+#ifdef _WIN32
+  char *result = NULL;
+  DWORD dwResult;
+#endif
+
+  if (PATH == NULL || argv0 == NULL) return NULL;
+
+  while (*PATH)
+  {
+    int i = 0;
+    // Copy one path from PATH
+    while (i < PATHSZ-1 && *PATH && *PATH != ':')
+    {
+      binary_path[i] = *PATH;
+      i += 1;
+      PATH += 1;
+    }
+
+    // Append filename
+    {
+      const char *file = argv0;
+      binary_path[i] = '/';
+      i += 1;
+
+      while (i < PATHSZ-1 && *file)
+      {
+        binary_path[i] = *file;
+        i += 1;
+        file += 1;
+      }
+
+      binary_path[i] = 0;
+    }
+
+    // Check path
+#ifdef _WIN32
+    dwResult = GetFullPathName(binary_path, PATHSZ, merlin_path, NULL);
+    if (dwResult && dwResult < PATHSZ)
+      if (GetLongPathName(binary_path, NULL, 0))
+        result = binary_path;
+#else
+    char *result = realpath(binary_path, merlin_path);
+#endif
+    if (result != NULL)
+      return result;
+
+    // Seek next path in PATH
+    while (*PATH && *PATH != ':')
+      PATH += 1;
+
+    while (*PATH == ':')
+      PATH += 1;
+  }
+
+  return NULL;
+}
+
+static void prune_binary_name(char * buffer) {
+  size_t strsz = strlen(buffer);
+  while (strsz > 0 && buffer[strsz-1] != '/' && buffer[strsz-1] != '\\')
+    strsz -= 1;
+  buffer[strsz] = 0;
+}
+
+#ifdef _WIN32
+static char ocamlmerlin_server[] = "ocamlmerlin-server.exe";
+#else
+static char ocamlmerlin_server[] = "ocamlmerlin-server";
+#endif
+
+static void compute_merlinpath(char merlin_path[PATHSZ], const char *argv0, struct stat *st)
+{
+  char argv0_dirname[PATHSZ];
+  size_t strsz;
+
+  strcpy(argv0_dirname, argv0);
+  prune_binary_name(argv0_dirname);
+
+  // Check if we were called with a path or not
+  if (strlen(argv0_dirname) == 0) {
+    if (search_in_path(getenv("PATH"), argv0, merlin_path) == NULL)
+      failwith("cannot resolve path to ocamlmerlin");
+  } else {
+#ifdef _WIN32
+    // GetFullPathName does not resolve symbolic links, which realpath does.
+    // @@DRA GetLongPathName ensures that the file exists (better way?!).
+    // Not sure if this matters.
+    DWORD dwResult = GetFullPathName(argv0, PATHSZ, merlin_path, NULL);
+    if (!dwResult || dwResult >= PATHSZ || !GetLongPathName(merlin_path, NULL, 0))
+#else
+    if (realpath(argv0, merlin_path) == NULL)
+#endif
+      failwith("argv0 does not point to a valid file");
+  }
+
+  prune_binary_name(merlin_path);
+  strsz = strlen(merlin_path);
+
+  // Append ocamlmerlin-server
+  if (strsz + sizeof(ocamlmerlin_server) + 8 > PATHSZ)
+    failwith("path is too long");
+
+  strcpy(merlin_path + strsz, ocamlmerlin_server);
+
+  if (stat(merlin_path, st) != 0)
+  {
+    strcpy(merlin_path + strsz, "ocamlmerlin_server.exe");
+    if (stat(merlin_path, st) != 0)
+    {
+      strcpy(merlin_path + strsz, ocamlmerlin_server);
+      failwith_perror("stat(ocamlmerlin-server, also tried ocamlmerlin_server.exe)");
+    }
+  }
+}
+
+#ifdef _WIN32
+
+/* May return NULL */
+LPSTR retrieve_user_sid_string()
+{
+  LPSTR usidstr;
+  HANDLE process_token;
+  if ( ! OpenProcessToken( GetCurrentProcess(), TOKEN_QUERY, &process_token ) )
+    return NULL;
+
+  DWORD sid_buffer_size;
+  if ( ! GetTokenInformation(process_token, TokenUser, NULL, 0, &sid_buffer_size ) &&
+        ( GetLastError() != ERROR_INSUFFICIENT_BUFFER ) )
+  {
+    CloseHandle(process_token);
+    return NULL;
+  }
+
+  TOKEN_USER * token_user_ptr = (PTOKEN_USER) malloc(sid_buffer_size);
+  if ( ! token_user_ptr )
+  {
+    CloseHandle( process_token);
+    return NULL;
+  }
+
+  if ( ! GetTokenInformation(process_token, TokenUser, token_user_ptr,
+                             sid_buffer_size, &sid_buffer_size))
+  {
+    free(token_user_ptr);
+    CloseHandle(process_token);
+    return NULL;
+  }
+
+  if (! ConvertSidToStringSid(token_user_ptr->User.Sid, &usidstr))
+    usidstr = NULL;
+
+  free(token_user_ptr);
+  CloseHandle(process_token);
+
+  return usidstr;
+}
+
+static void compute_socketname(char socketname[PATHSZ], char eventname[PATHSZ], const char merlin_path[PATHSZ])
+#else
+static void compute_socketname(char socketname[PATHSZ], struct stat *st)
+#endif
+{
+#ifdef _WIN32
+  BY_HANDLE_FILE_INFORMATION info;
+  LPSTR user_sid_string;
+  HANDLE hFile = CreateFile(merlin_path, FILE_READ_ATTRIBUTES, FILE_SHARE_DELETE | FILE_SHARE_READ | FILE_SHARE_WRITE, NULL, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
+  if (hFile == INVALID_HANDLE_VALUE || !GetFileInformationByHandle(hFile, &info))
+    failwith_perror("stat (cannot find ocamlmerlin binary)");
+  CloseHandle(hFile);
+
+  user_sid_string = retrieve_user_sid_string() ;
+  if (! user_sid_string)
+    user_sid_string = LocalAlloc(LPTR, 1);
+
+  // @@DRA Need to use Windows API functions to get meaningful values for st_dev and st_ino
+  snprintf(eventname, PATHSZ,
+      "ocamlmerlin_%s_%lx_%llx",
+      user_sid_string,
+      info.dwVolumeSerialNumber,
+      ((__int64)info.nFileIndexHigh) << 32 | ((__int64)info.nFileIndexLow));
+  snprintf(socketname, PATHSZ,
+      "\\\\.\\pipe\\%s", eventname);
+
+  LocalFree(user_sid_string);
+#else
+  snprintf(socketname, PATHSZ,
+      "ocamlmerlin_%llu_%llu_%llu.socket",
+      (unsigned long long)getuid(),
+      (unsigned long long)st->st_dev,
+      (unsigned long long)st->st_ino);
+#endif
+}
+
+/* Main */
+
+static char
+  merlin_path[PATHSZ] = "<not computed yet>",
+  socketname[PATHSZ] = "<not computed yet>",
+  eventname[PATHSZ] = "<not computed yet>";
+static unsigned char argbuffer[262144];
+
+static void dumpinfo(void)
+{
+  fprintf(stderr,
+      "merlin path: %s\nsocket path: %s/%s\n", merlin_path, path_socketdir(), socketname);
+}
+
+static void unexpected_termination(int argc, char **argv)
+{
+  int sexp = 0;
+  int i;
+
+  for (i = 1; i < argc - 1; ++i)
+  {
+    if (strcmp(argv[i], "-protocol") == 0 &&
+        strcmp(argv[i+1], "sexp") == 0)
+      sexp = 1;
+  }
+
+  puts(sexp
+      ?  "((assoc) (class . \"failure\") (value . \"abnormal termination\") (notifications))"
+      : "{\"class\": \"failure\", \"value\": \"abnormal termination\", \"notifications\": [] }"
+      );
+  failwith("abnormal termination");
+}
+
+int main(int argc, char **argv)
+{
+  char result = 0;
+  int err = 0;
+  struct stat st;
+#ifdef _WIN32
+  HANDLE fds[3];
+  ULONG pid;
+  HANDLE hProcess, hServerProcess;
+  DWORD dwNumberOfBytesRead;
+  CHAR argv0[PATHSZ];
+  GetModuleFileName(NULL, argv0, PATHSZ);
+  compute_merlinpath(merlin_path, argv0, &st);
+#else
+  compute_merlinpath(merlin_path, argv[0], &st);
+#endif
+  if (argc >= 2 && strcmp(argv[1], "server") == 0)
+  {
+    IPC_SOCKET_TYPE sock;
+    ssize_t len;
+#ifdef _WIN32
+    compute_socketname(socketname, eventname, merlin_path);
+#else
+    compute_socketname(socketname, &st);
+#endif
+
+    sock = connect_and_serve(socketname, eventname, merlin_path);
+    len = prepare_args(argbuffer, sizeof(argbuffer), argc-2, argv+2);
+#ifdef _WIN32
+    hProcess = GetCurrentProcess();
+    if (!GetNamedPipeServerProcessId(sock, &pid))
+      failwith_perror("GetNamedPipeServerProcessId");
+    hServerProcess = OpenProcess(PROCESS_DUP_HANDLE, FALSE, pid);
+    if (hServerProcess == INVALID_HANDLE_VALUE)
+      failwith_perror("OpenProcess");
+    if (!DuplicateHandle(hProcess, GetStdHandle(STD_INPUT_HANDLE), hServerProcess, &fds[0], 0, FALSE, DUPLICATE_SAME_ACCESS))
+      failwith_perror("DuplicateHandle(stdin)");
+    if (!DuplicateHandle(hProcess, GetStdHandle(STD_OUTPUT_HANDLE), hServerProcess, &fds[1], 0, FALSE, DUPLICATE_SAME_ACCESS))
+      failwith_perror("DuplicateHandle(stdout)");
+    CloseHandle(GetStdHandle(STD_OUTPUT_HANDLE));
+    if (!DuplicateHandle(hProcess, GetStdHandle(STD_ERROR_HANDLE), hServerProcess, &fds[2], 0, FALSE, DUPLICATE_SAME_ACCESS))
+      failwith_perror("DuplicateHandle(stderr)");
+#else
+    int fds[3] = { STDIN_FILENO, STDOUT_FILENO, STDERR_FILENO };
+#endif
+    ipc_send(sock, argbuffer, len, fds);
+
+#ifdef _WIN32
+    if (ReadFile(sock, &result, 1, &dwNumberOfBytesRead, NULL) && dwNumberOfBytesRead == 1)
+      err = 1;
+#else
+    NO_EINTR(err, read(sock, &result, 1));
+#endif
+    if (err == 1)
+      exit(result);
+
+    unexpected_termination(argc, argv);
+  }
+  else
+  {
+    argv[0] = ocamlmerlin_server;
+#ifdef _WIN32
+    int err = _spawnvp(_P_WAIT, merlin_path, (const char *const *)argv);
+    if (err < 0)
+      failwith_perror("spawnvp(ocamlmerlin-server)");
+    else
+      exit(err);
+#else
+    execvp(merlin_path, argv);
+    failwith_perror("execvp(ocamlmerlin-server)");
+#endif
+  }
+
+  /* This is never reached */
+  return 0;
+}
diff --git a/src/frontend/ocamlmerlin/ocamlmerlin_server.ml b/src/frontend/ocamlmerlin/ocamlmerlin_server.ml
new file mode 100644
index 0000000..9bb1266
--- /dev/null
+++ b/src/frontend/ocamlmerlin/ocamlmerlin_server.ml
@@ -0,0 +1,98 @@
+let merlin_timeout =
+  try float_of_string (Sys.getenv "MERLIN_TIMEOUT")
+  with _ -> 600.0
+
+module Server = struct
+
+  let rec protect_eintr f =
+    match f () with
+    | exception (Unix.Unix_error(Unix.EINTR, _, _)) -> protect_eintr f
+    | result -> result
+
+  let process_request {Os_ipc. wd; environ; argv; context = _}  =
+    match Array.to_list argv with
+    | "stop-server" :: _ -> raise Exit
+    | args -> New_merlin.run ~new_env:(Some environ) (Some wd) args
+
+  let process_client client =
+    let context = client.Os_ipc.context in
+    Os_ipc.context_setup context;
+    let close_with return_code =
+      flush_all ();
+      Os_ipc.context_close context ~return_code
+    in
+    match process_request client with
+    | code -> close_with code
+    | exception Exit ->
+      close_with (-1);
+      raise Exit
+    | exception exn ->
+      Logger.log ~section:"server" ~title:"process failed" "%a"
+        Logger.exn exn;
+      close_with (-1)
+
+  let server_accept merlinid server =
+    let rec loop total =
+      Mocaml.flush_caches ~older_than:300.0 ();
+      let merlinid' = File_id.get Sys.executable_name in
+      if total > merlin_timeout ||
+         not (File_id.check merlinid merlinid') then
+        None
+      else
+        let timeout = max 10.0 (min 60.0 (merlin_timeout -. total)) in
+        match Os_ipc.server_accept server ~timeout with
+        | Some _ as result -> result
+        | None -> loop (total +. timeout)
+    in
+    match Os_ipc.server_accept server ~timeout:1.0 with
+    | Some _ as result -> result
+    | None -> loop 1.0
+
+  let rec loop merlinid server =
+    match server_accept merlinid server with
+    | None -> (* Timeout *)
+      ()
+    | Some client ->
+      let continue =
+        match process_client client with
+        | exception Exit -> false
+        | () -> true
+      in
+      if continue then loop merlinid server
+
+  let start socket_path socket_fd =
+    match Os_ipc.server_setup socket_path socket_fd with
+    | None ->
+      Logger.log ~section:"server" ~title:"cannot setup listener" ""
+    | Some server ->
+      loop (File_id.get Sys.executable_name) server;
+      Os_ipc.server_close server
+end
+
+let main () =
+  (* Setup env for extensions *)
+  Unix.putenv "__MERLIN_MASTER_PID" (string_of_int (Unix.getpid ()));
+  match List.tl (Array.to_list Sys.argv) with
+  | "single" :: args -> exit (New_merlin.run ~new_env:None None args)
+  | "old-protocol" :: args -> Old_merlin.run args
+  | ["server"; socket_path; socket_fd] -> Server.start socket_path socket_fd
+  | ("-help" | "--help" | "-h" | "server") :: _ ->
+    Printf.eprintf
+      "Usage: %s <frontend> <arguments...>\n\
+       Select the merlin frontend to execute. Valid values are:\n\
+      \n- 'old-protocol' executes the merlin frontend from previous version.\n\
+      \  It is a top level reading and writing commands in a JSON form.\n\
+      \n- 'single' is a simpler frontend that reads input from stdin,\n\
+      \  processes a single query and outputs result on stdout.\n\
+      \n- 'server' works like 'single', but uses a background process to\n\
+      \  speedup processing.\n\
+       If no frontend is specified, it defaults to 'old-protocol' for\n\
+       compatibility with existing editors.\n"
+      Sys.argv.(0)
+  | args -> Old_merlin.run args
+
+let () =
+  let `Log_file_path log_file, `Log_sections sections =
+    Log_info.get ()
+  in
+  Logger.with_log_file log_file ~sections main
diff --git a/src/frontend/ocamlmerlin/old/old_IO.ml b/src/frontend/ocamlmerlin/old/old_IO.ml
new file mode 100644
index 0000000..59a93df
--- /dev/null
+++ b/src/frontend/ocamlmerlin/old/old_IO.ml
@@ -0,0 +1,375 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+
+let latest_version : Old_protocol.protocol_version = `V3
+let current_version = ref `V2
+
+let default_context =
+  {Old_protocol.Context.
+    document = None; printer_width = None; printer_verbosity = None}
+
+let invalid_arguments () = failwith "invalid arguments"
+
+open Query_protocol
+open Old_protocol
+
+let pos_of_json = function
+  | `String "start" -> `Start
+  | `String "end" -> `End
+  | `Int offset -> `Offset offset
+  | `Assoc props ->
+    begin try match List.assoc "line" props, List.assoc "col" props with
+      | `Int line, `Int col -> `Logical (line,col)
+      | _ -> failwith "Incorrect position"
+      with Not_found -> failwith "Incorrect position"
+    end
+  | _ -> failwith "Incorrect position"
+
+let mandatory_position = function
+  | [`String "at"; jpos] -> pos_of_json jpos
+  | _ -> invalid_arguments ()
+
+let optional_string = function
+  | [`String name] -> Some name
+  | [] -> None
+  | _ -> invalid_arguments ()
+
+let string_list l =
+  List.map ~f:(function `String s -> s | _ -> invalid_arguments ()) l
+
+let source_or_build = function
+  | "source" -> `Source
+  | "build"  -> `Build
+  | _ -> invalid_arguments ()
+
+let ml_or_mli = function
+  | "ml" -> `ML
+  | "mli"  -> `MLI
+  | _ -> invalid_arguments ()
+
+let auto_ml_or_mli = function
+  | "auto" -> `Auto
+  | x -> ml_or_mli x
+
+let add_or_remove = function
+  | "add"    -> `Add
+  | "remove" -> `Rem
+  | _ -> invalid_arguments ()
+
+let with_failures failures assoc = match failures with
+  | `Ok -> assoc
+  | `Failures failures ->
+    let flags, extensions =
+      List.fold_left failures ~init:([],[]) ~f:(
+        fun (flgs, exts) (str,exn) ->
+          match exn with
+          | Arg.Bad _ -> str :: flgs, exts
+          | Extension.Unknown -> flgs, str :: exts
+          | _ -> assert false
+      )
+    in
+    let flags =
+      match flags with
+      | [] -> []
+      | failures ->
+        let str = String.concat ~sep:", " failures in
+        [ `String ("Unknown flags " ^ str) ]
+    in
+    let extensions =
+      match extensions with
+      | [] -> []
+      | failures ->
+        let str = String.concat ~sep:", " failures in
+        [ `String ("Unknown extensions " ^ str) ]
+    in
+    ("failures", `List (flags @ extensions)) :: assoc
+
+let document_of_json =
+  let make kind path dot_merlins =
+    {Context.dot_merlins;
+     kind = auto_ml_or_mli kind;
+     path = optional_string path;
+    }
+  in function
+    | (`String "dot_merlin" :: `List dot_merlins :: `String kind :: opt_name) ->
+      make kind opt_name (Some (string_list dot_merlins))
+    | (`String kind :: opt_name) ->
+      make kind opt_name None
+    | _ -> invalid_arguments ()
+
+let request_of_json context =
+  let request x = Request (context, x) in function
+    | (`String "type" :: `String "expression" :: `String expr :: opt_pos) ->
+      request (Query (Type_expr (expr, mandatory_position opt_pos)))
+    | [`String "type"; `String "enclosing";
+       `Assoc [ "expr", `String expr ; "offset", `Int offset] ; jpos] ->
+      request (Query (Type_enclosing (Some (expr, offset), pos_of_json jpos, None)))
+    | [`String "type"; `String "enclosing"; `String "at"; jpos] ->
+      request (Query (Type_enclosing (None, pos_of_json jpos, None)))
+    | [ `String "case"; `String "analysis"; `String "from"; x; `String "to"; y ] ->
+      request (Query (Case_analysis (pos_of_json x, pos_of_json y)))
+    | [`String "enclosing"; jpos] ->
+      request (Query (Enclosing (pos_of_json jpos)))
+    | [`String "complete"; `String "prefix"; `String prefix; `String "at"; jpos] ->
+      request (Query (Complete_prefix (prefix, pos_of_json jpos, [], false, true)))
+    | [`String "complete"; `String "prefix"; `String prefix; `String "at"; jpos;
+       `String "with"; `String "doc"] ->
+      request (Query (Complete_prefix (prefix, pos_of_json jpos, [], true, true)))
+    | [`String "expand"; `String "prefix"; `String prefix; `String "at"; jpos] ->
+      request (Query (Expand_prefix (prefix, pos_of_json jpos, [], true)))
+    | [`String "search"; `String "polarity"; `String query; `String "at"; jpos] ->
+      request (Query (Polarity_search (query, pos_of_json jpos)))
+    | (`String "document" :: (`String "" | `Null) :: pos) ->
+      request (Query (Document (None, mandatory_position pos)))
+    | (`String "document" :: `String path :: pos) ->
+      request (Query (Document (Some path, mandatory_position pos)))
+    | (`String "locate" :: (`String "" | `Null) :: `String choice :: pos) ->
+      request (Query (Locate (None, ml_or_mli choice, mandatory_position pos)))
+    | (`String "locate" :: `String path :: `String choice :: pos) ->
+      request (Query (Locate (Some path, ml_or_mli choice, mandatory_position pos)))
+    | (`String "jump" :: `String target :: pos) ->
+      request (Query (Jump (target, mandatory_position pos)))
+    | [`String "outline"] ->
+      request (Query Outline)
+    | [`String "shape"; pos] ->
+      request (Query (Shape (pos_of_json pos)))
+    | [`String "occurrences"; `String "ident"; `String "at"; jpos] ->
+      request (Query (Occurrences (`Ident_at (pos_of_json jpos))))
+    | (`String ("reset"|"checkout") :: document) ->
+      request (Sync (Checkout (document_of_json document)))
+    | [`String "refresh"] ->
+      request (Sync Refresh)
+    | [`String "errors"] ->
+      request (Query (Errors { lexing = true; parsing = true; typing = true }))
+    | (`String "dump" :: args) ->
+      request (Query (Dump args))
+    | [`String "which"; `String "path"; `String name] ->
+      request (Query (Path_of_source [name]))
+    | [`String "which"; `String "path"; `List names] ->
+      request (Query (Path_of_source (string_list names)))
+    | [`String "which"; `String "with_ext"; `String ext] ->
+      request (Query (List_modules [ext]))
+    | [`String "which"; `String "with_ext"; `List exts] ->
+      request (Query (List_modules (string_list exts)))
+    | [`String "flags" ; `String "set" ; `List flags ] ->
+      request (Sync (Flags_set (string_list flags)))
+    | [`String "flags" ; `String "get" ] ->
+      request (Sync (Flags_get))
+    | [`String "find"; `String "use"; `List packages]
+    | (`String "find" :: `String "use" :: packages) ->
+      request (Sync (Findlib_use (string_list packages)))
+    | [`String "find"; `String "list"] ->
+      request (Query Findlib_list)
+    | [`String "extension"; `String "enable"; `List extensions] ->
+      request (Sync (Extension_set (`Enabled,string_list extensions)))
+    | [`String "extension"; `String "disable"; `List extensions] ->
+      request (Sync (Extension_set (`Disabled,string_list extensions)))
+    | [`String "extension"; `String "list"] ->
+      request (Query (Extension_list `All))
+    | [`String "extension"; `String "list"; `String "enabled"] ->
+      request (Query (Extension_list `Enabled))
+    | [`String "extension"; `String "list"; `String "disabled"] ->
+      request (Query (Extension_list `Disabled))
+    | [`String "path"; `String "list";
+       `String ("source"|"build" as var)] ->
+      request (Query (Path_list (source_or_build var)))
+    | [`String "path"; `String "reset"] ->
+      request (Sync Path_reset)
+    | (`String "path" :: `String ("add"|"remove" as action) ::
+       `String ("source"|"build" as var) :: ((`List pathes :: []) | pathes)) ->
+      request (Sync (Path (source_or_build var, add_or_remove action, string_list pathes)))
+    | [`String "tell"; pos_start; pos_end; `String content] ->
+      request (Sync (Tell (pos_of_json pos_start, pos_of_json pos_end, content)))
+    | [`String "project"; `String "get"] ->
+      request (Sync Project_get)
+    | [`String "version"] ->
+      request (Query Version)
+    | [`String "protocol"; `String "version"] ->
+      request (Sync (Protocol_version None))
+    | [`String "protocol"; `String "version"; `Int n] ->
+      request (Sync (Protocol_version (Some n)))
+    | _ -> invalid_arguments ()
+
+let json_of_protocol_version : Old_protocol.protocol_version -> _ = function
+  | `V2 -> `Int 2
+  | `V3 -> `Int 3
+
+let json_of_sync_command (type a) (command : a sync_command) (response : a) : json =
+  match command, response with
+  | Tell _, () -> `Bool true
+  | Checkout _, () -> `Bool true
+  | Refresh, () -> `Bool true
+  | Flags_get, flags ->
+    `List (List.map ~f:Json.string flags)
+  | Flags_set _, failures ->
+    `Assoc (with_failures failures ["result", `Bool true])
+  | Findlib_use _, failures ->
+    `Assoc (with_failures failures ["result", `Bool true])
+  | Extension_set _, failures ->
+    `Assoc (with_failures failures ["result", `Bool true])
+  | Path _, () -> `Bool true
+  | Path_reset, () -> `Bool true
+  | Protocol_version _, (`Selected v, `Latest vm, version) ->
+    `Assoc ["selected", json_of_protocol_version v;
+            "latest", json_of_protocol_version vm;
+            "merlin",  `String version
+           ]
+  | Project_get, (strs, fails) ->
+    let failures = match fails with
+      | `Failures ((_::_) as fails) ->
+        ["failures", `List (List.map ~f:Json.string fails)]
+      | _ -> []
+    in
+    `Assoc (("result", `List (List.map ~f:Json.string strs))::failures)
+  | Idle_job, b -> `Bool b
+
+let classify_response = function
+  | Failure s | Exception (Failure s) -> ("failure", `String s)
+  | Error error -> ("error", error)
+  | Exception exn ->
+    begin match Location.error_of_exn exn with
+      | Some (`Ok error) -> ("error", Query_json.json_of_error error)
+      | None | Some `Already_displayed ->
+        ("exception", `String (Printexc.to_string exn))
+    end
+  | Return (Query cmd, response) ->
+    ("return", Query_json.json_of_response cmd response)
+  | Return (Sync cmd, response) ->
+    ("return", json_of_sync_command cmd response)
+
+let json_of_response_v2 response =
+  let class_, value = classify_response response in
+  `List [`String class_; value]
+
+let json_of_response_v3 ~notifications response =
+  let class_, value = classify_response response in
+  `Assoc [
+    "class", `String class_;
+    "value", value;
+    "notifications",
+    `List (List.map ~f:(fun { Logger.section; msg } ->
+        `Assoc ["section", `String section; "message", `String msg])
+        notifications);
+  ]
+
+let json_of_response notifications response =
+  match !current_version with
+  | `V2 -> json_of_response_v2 response
+  | `V3 -> json_of_response_v3 ~notifications response
+
+let request_of_json = function
+  | `Assoc _ as json ->
+    let open Json.Util in
+    let document =
+      let value = member "document" json in
+      let value =
+        if value = `Null then
+          member "context" json
+        else value
+      in
+      if value = `Null then
+        None
+      else Some (to_list value |> document_of_json)
+    in
+    let printer_width = member "printer_width" json |> to_int_option in
+    let printer_verbosity = member "printer_verbosity" json |> to_int_option in
+    let context = {Context. document; printer_verbosity; printer_width} in
+    let query = member "query" json |> to_list in
+    request_of_json context query
+  | `List jsons -> request_of_json default_context jsons
+  | _ -> invalid_arguments ()
+
+let make_json ?(on_read=ignore) ~input ~output () =
+  let rec read buf len =
+    on_read input;
+    try Unix.read input buf 0 len
+    with Unix.Unix_error (Unix.EINTR,_,_) ->
+      read buf len
+  in
+  let lexbuf  = Lexing.from_function read in
+  let input   =
+    (* This code is the compiler's implementation of `to_dispenser`.
+       Original: 0c249195f84fbc0ef475c1334594b53aaf5a3de7/stdlib/seq.ml#L669 *)
+    let s = ref (Yojson.Basic.(seq_from_lexbuf (init_lexer ()) lexbuf)) in
+    fun () ->
+      match (!s)() with
+      | Nil -> None
+      | Cons (x, xs) ->
+          s := xs;
+          Some x
+  in
+  let output  = Unix.out_channel_of_descr output in
+  let output' = Json.to_channel output in
+  let output json =
+    output' json;
+    output_char output '\n';
+    flush output
+  in
+  input, output
+
+let make_sexp ?on_read ~input ~output () =
+  (* Fix for emacs: emacs start-process doesn't distinguish between stdout and
+     stderr.  So we redirect stderr to /dev/null with sexp frontend. *)
+  begin match
+      begin
+        try Some (Unix.openfile "/dev/null" [Unix.O_WRONLY] 0o600)
+        with
+        | Unix.Unix_error _  ->
+          if Sys.os_type = "Win32" then
+            try Some (Unix.openfile "NUL" [Unix.O_WRONLY] 0o600)
+            with Unix.Unix_error _ -> None
+          else None
+      end
+      with
+      | None -> ()
+      | Some fd ->
+        Unix.dup2 fd Unix.stderr;
+        Unix.close fd
+  end;
+  let input' = Sexp.of_file_descr ?on_read input in
+  let input' () = Option.map ~f:Sexp.to_json (input' ()) in
+  let buf = Buffer.create 8192 in
+  let output json =
+    let sexp = Sexp.of_json json in
+    Sexp.to_buf sexp buf;
+    Buffer.add_char buf '\n';
+    let contents = Buffer.to_bytes buf in
+    let rec write_contents n l =
+      if l > 0 then
+        let l' = Unix.write output contents n l in
+        if l' > 0 then
+          write_contents (n + l') (l - l')
+    in
+    write_contents 0 (Bytes.length contents);
+    if Buffer.length buf > 100_000
+    then Buffer.reset buf
+    else Buffer.clear buf
+  in
+  input', output
diff --git a/src/frontend/ocamlmerlin/old/old_IO.mli b/src/frontend/ocamlmerlin/old/old_IO.mli
new file mode 100644
index 0000000..dbf9cf3
--- /dev/null
+++ b/src/frontend/ocamlmerlin/old/old_IO.mli
@@ -0,0 +1,49 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+
+val latest_version : Old_protocol.protocol_version
+val current_version : Old_protocol.protocol_version ref
+
+(* Misc *)
+val default_context : Old_protocol.Context.t
+
+val request_of_json : Json.t -> Old_protocol.request
+val json_of_response : Logger.notification list ->
+                       Old_protocol.response -> Json.t
+
+val make_json : ?on_read:(Unix.file_descr -> unit) ->
+                input:Unix.file_descr ->
+                output:Unix.file_descr ->
+                unit -> (unit -> Json.t option) * (Json.t -> unit)
+
+val make_sexp : ?on_read:(Unix.file_descr -> unit) ->
+                input:Unix.file_descr ->
+                output:Unix.file_descr ->
+                unit -> (unit -> Json.t option) * (Json.t -> unit)
diff --git a/src/frontend/ocamlmerlin/old/old_command.ml b/src/frontend/ocamlmerlin/old/old_command.ml
new file mode 100644
index 0000000..982f16b
--- /dev/null
+++ b/src/frontend/ocamlmerlin/old/old_command.ml
@@ -0,0 +1,252 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+open Old_protocol
+module Printtyp = Type_utils.Printtyp
+
+type customization = [
+  | `Ext of [`Enabled | `Disabled] * string
+  | `Flags of string list
+  | `Use of string list
+  | `Path of [`Build | `Source] * [`Add | `Rem] * string list
+]
+
+let customize config =
+  let open Mconfig in
+  function
+  | `Ext (`Enabled, ext) ->
+    let extensions = ext :: config.merlin.extensions in
+    {config with merlin = {config.merlin with extensions}};
+  | `Ext (`Disabled, ext) ->
+    let extensions = List.remove_all ext config.merlin.extensions in
+    {config with merlin = {config.merlin with extensions}};
+  | `Flags flags ->
+    let flags_to_apply = [{workdir = config.query.directory; workval = flags}] in
+    {config with merlin = {config.merlin with flags_to_apply}}
+  | `Use _pkgs ->
+    config
+  | `Path (var, action, paths) ->
+    let f l = match action with
+      | `Add -> List.filter_dup (paths @ l)
+      | `Rem -> List.filter l ~f:(fun x -> not (List.mem x ~set:paths))
+    in
+    let merlin = config.merlin in
+    let merlin =
+      match var with
+      | `Build -> {merlin with build_path = f merlin.build_path}
+      | `Source -> {merlin with source_path = f merlin.source_path}
+    in
+    {config with merlin}
+
+
+type buffer = {
+  path: string option;
+  dot_merlins: string list option;
+  mutable customization : customization list;
+  mutable source : Msource.t;
+}
+
+type state = {
+  mutable buffer : buffer;
+}
+
+let normalize_document doc =
+  doc.Context.path, doc.Context.dot_merlins
+
+let new_buffer (path, dot_merlins) =
+  { path; dot_merlins; customization = [];
+    source = Msource.make "" }
+
+let default_config = ref Mconfig.initial
+
+let configure (state : buffer) =
+  let config = !default_config in
+  let config = {config with Mconfig.query = match state.path with
+      | None -> config.Mconfig.query
+      | Some path -> {
+          config.Mconfig.query with
+          Mconfig.
+          filename = Filename.basename path;
+          directory = Misc.canonicalize_filename (Filename.dirname path);
+        }
+    } in
+  let config =
+    match state.dot_merlins with
+    | Some (first :: _) -> (* ignore anything but the first one... *)
+      Mconfig.get_external_config first config
+    | None | Some [] ->
+      match state.path with
+      | None -> config
+      | Some p -> Mconfig.get_external_config p config
+  in
+  List.fold_left ~f:customize ~init:config state.customization
+
+let new_state document =
+  { buffer = new_buffer document }
+
+let checkout_buffer_cache = ref []
+let checkout_buffer =
+  let cache_size = 8 in
+  fun document ->
+    let document = normalize_document document in
+    try List.assoc document !checkout_buffer_cache
+    with Not_found ->
+      let buffer = new_buffer document in
+      begin match document with
+        | Some _, _ ->
+          checkout_buffer_cache :=
+            (document, buffer) :: List.take_n cache_size !checkout_buffer_cache
+        | None, _ -> ()
+      end;
+      buffer
+
+let make_pipeline config buffer =
+  Mpipeline.make config buffer.source
+
+let dispatch_sync config state (type a) : a sync_command -> a = function
+  | Idle_job -> false
+
+  | Tell (pos_start, pos_end, text) ->
+    let source = Msource.substitute state.source pos_start pos_end text in
+    state.source <- source
+
+  | Refresh ->
+    checkout_buffer_cache := [];
+    Cmi_cache.flush ()
+
+  | Flags_set flags ->
+    state.customization <-
+      (`Flags flags) ::
+      List.filter ~f:(function `Flags _ -> false | _ -> true)
+        state.customization;
+    `Ok
+
+  | Findlib_use packages ->
+    state.customization <-
+      (`Use packages) ::
+      List.filter ~f:(function `Use _ -> false | _ -> true)
+        state.customization;
+    `Ok
+
+  | Extension_set (action,exts) ->
+    state.customization <-
+      List.map ~f:(fun ext -> `Ext (action, ext)) exts @
+      List.filter ~f:(function
+          | `Ext (_, ext) when List.mem ext ~set:exts -> false
+          | _ -> true
+        ) state.customization;
+    `Ok
+
+  | Path (var,_,paths) ->
+    state.customization <-
+      List.filter_map ~f:(function
+          | `Path (var', action', paths') when var = var' ->
+            let paths' = List.filter paths'
+                ~f:(fun path -> not (List.mem path ~set:paths))
+            in
+            if paths' = [] then None else Some (`Path (var', action', paths'))
+          | x -> Some x
+        ) state.customization
+
+  | Path_reset ->
+    state.customization <-
+      List.filter ~f:(function | `Path _ -> false
+          | _ -> true
+        ) state.customization;
+
+  | Protocol_version version ->
+    begin match version with
+      | None -> ()
+      | Some 2 -> Old_IO.current_version := `V2
+      | Some 3 -> Old_IO.current_version := `V3
+      | Some _ -> ()
+    end;
+    (`Selected !Old_IO.current_version,
+     `Latest Old_IO.latest_version,
+     Printf.sprintf "The Merlin toolkit version %s, for Ocaml %s\n"
+       My_config.version Sys.ocaml_version)
+
+  | Flags_get ->
+    let pipeline = make_pipeline config state in
+    let config = Mpipeline.final_config pipeline in
+    List.concat_map ~f:(fun f -> f.workval)
+      Mconfig.(config.merlin.flags_to_apply)
+
+  | Project_get ->
+    let failures = match  Mconfig.(config.merlin.failures) with
+      | [] -> `Ok
+      | failures -> `Failures failures in
+
+    (Option.cons Mconfig.(config.merlin.config_path) [], failures)
+
+  | Checkout _ -> failwith "invalid arguments"
+
+let default_state = lazy (new_state (None, None))
+
+let document_states
+  : (string option * string list option, state) Hashtbl.t
+  = Hashtbl.create 7
+
+let dispatch (type a) (context : Context.t) (cmd : a command) : a =
+  let open Context in
+  (* Document selection *)
+  let state = match context.document with
+    | None -> Lazy.force default_state
+    | Some document ->
+      let document = normalize_document document in
+      try Hashtbl.find document_states document
+      with Not_found ->
+        let state = new_state document in
+        Hashtbl.add document_states document state;
+        state
+  in
+  let config = configure state.buffer in
+  (* Printer verbosity *)
+  let config = match context.printer_verbosity with
+    | None -> config
+    | Some verbosity ->
+      Mconfig.({config with query = {config.query with verbosity}})
+  in
+  let config = match context.printer_width with
+    | None -> config
+    | Some printer_width ->
+      Mconfig.({config with query = {config.query with printer_width}})
+  in
+  (* Printer width *)
+  Format.default_width := Option.value ~default:0 context.printer_width;
+  (* Actual dispatch *)
+  match cmd with
+  | Query q ->
+    let pipeline = make_pipeline config state.buffer in
+    Mpipeline.with_pipeline pipeline @@ fun () ->
+    Query_commands.dispatch pipeline q
+  | Sync (Checkout context) when state == Lazy.force default_state ->
+    let buffer = checkout_buffer context in
+    state.buffer <- buffer
+  | Sync s -> dispatch_sync config state.buffer s
diff --git a/src/frontend/ocamlmerlin/old/old_command.mli b/src/frontend/ocamlmerlin/old/old_command.mli
new file mode 100644
index 0000000..d478106
--- /dev/null
+++ b/src/frontend/ocamlmerlin/old/old_command.mli
@@ -0,0 +1,31 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+val default_config : Mconfig.t ref
+
+val dispatch : Old_protocol.Context.t -> 'a Old_protocol.command -> 'a
diff --git a/src/frontend/ocamlmerlin/old/old_merlin.ml b/src/frontend/ocamlmerlin/old/old_merlin.ml
new file mode 100644
index 0000000..1269a78
--- /dev/null
+++ b/src/frontend/ocamlmerlin/old/old_merlin.ml
@@ -0,0 +1,146 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+
+let version_spec =
+  Printf.sprintf "The Merlin toolkit version %s, for Ocaml %s"
+    My_config.version Sys.ocaml_version
+
+let ocamlmerlin_args = [
+  (
+    "-ignore-sigint",
+    " Ignore SIGINT, useful when invoked from editor",
+    Marg.unit (fun acc ->
+        (try ignore (Sys.(signal sigint Signal_ignore))
+         with Invalid_argument _ -> ());
+        acc
+      )
+  );
+  (
+    "-version",
+    " Print version and exit",
+    Marg.unit (fun _ ->
+        print_endline version_spec;
+        exit 0
+      )
+  );
+  (
+    "-vnum",
+    " Print version number and exit",
+    Marg.unit (fun _ ->
+        Printf.printf "%s\n" My_config.version;
+        exit 0
+      )
+  );
+  (
+    "-warn-help",
+    " Show description of warning numbers",
+    Marg.unit (fun _ ->
+        Warnings.help_warnings ();
+        exit 0
+      )
+  );
+  (
+    "-protocol",
+    " Select frontend protocol ('json' or 'sexp')",
+    Marg.param "protocol" (fun arg _ ->
+        match arg with
+        | "json" -> `Json
+        | "sexp" -> `Sexp
+        | _ ->
+          prerr_endline "Valid protocols are 'json' and 'sexp'";
+          exit 1
+      )
+  );
+]
+
+let signal sg behavior =
+  try ignore (Sys.signal sg behavior)
+  with Invalid_argument _ (*Sys.signal: unavailable signal*) -> ()
+
+let rec merlin_loop input output =
+  let notifications = ref [] in
+  Logger.with_notifications notifications @@ fun () ->
+  match
+    match input () with
+    | Some (Old_protocol.Request (context, request)) ->
+      let answer = Old_command.dispatch context request in
+      output ~notifications:(List.rev !notifications)
+        (Old_protocol.Return (request, answer));
+      true
+    | None -> false
+  with
+  | exception exn ->
+    let trace =
+      { Logger.section = "backtrace"; msg = Printexc.get_backtrace () }
+    in
+    output ~notifications:(trace :: List.rev !notifications)
+      (Old_protocol.Exception exn);
+    merlin_loop input output
+  | true -> merlin_loop input output
+  | false -> ()
+
+let setup_system () =
+  (* Setup signals, unix is a disaster *)
+  signal Sys.sigusr1 Sys.Signal_ignore;
+  signal Sys.sigpipe Sys.Signal_ignore;
+  signal Sys.sighup  Sys.Signal_ignore
+
+let setup_merlin args =
+  let config, protocol =
+    Mconfig.parse_arguments
+      ~wd:(Sys.getcwd ()) ~warning:prerr_endline ocamlmerlin_args args
+      Mconfig.initial `Json
+  in
+  Old_command.default_config := config;
+  let protocol = match protocol with
+    | `Json -> Old_IO.make_json
+    | `Sexp -> Old_IO.make_sexp
+  in
+  let input, output = protocol ~input:Unix.stdin ~output:Unix.stdout () in
+  let input () = match input () with
+    | None -> None
+    | Some json ->
+      Logger.log ~section:"frontend" ~title:"input" "%a"
+        Logger.json (fun () -> json);
+      Some (Old_IO.request_of_json json)
+  in
+  let output ~notifications x =
+    let json = Old_IO.json_of_response notifications x in
+    Logger.log ~section:"frontend" ~title:"output" "%a"
+      Logger.json (fun () -> json);
+    output json
+  in
+  (input, output)
+
+let run args =
+  setup_system ();
+  let input, output = setup_merlin args in
+  merlin_loop input output;
+  exit 0
diff --git a/src/frontend/ocamlmerlin/old/old_merlin.mli b/src/frontend/ocamlmerlin/old/old_merlin.mli
new file mode 100644
index 0000000..805b85b
--- /dev/null
+++ b/src/frontend/ocamlmerlin/old/old_merlin.mli
@@ -0,0 +1 @@
+val run : string list -> 'a
diff --git a/src/frontend/ocamlmerlin/old/old_protocol.ml b/src/frontend/ocamlmerlin/old/old_protocol.ml
new file mode 100644
index 0000000..1ed34ee
--- /dev/null
+++ b/src/frontend/ocamlmerlin/old/old_protocol.ml
@@ -0,0 +1,98 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+
+type protocol_version =
+  [ `V2 (* First version to support versioning ! *)
+  | `V3 (* Responses are now assoc {class:string, value:..., notifications:string list} *)
+  ]
+
+module Context =
+struct
+  type document = {
+    kind: [`ML | `MLI | `Auto ];
+    path: string option;
+    dot_merlins: string list option;
+  }
+
+  type t = {
+    document: document option;
+    printer_width: int option;
+    printer_verbosity: int option;
+  }
+end
+
+type _ sync_command =
+  | Tell
+    : Msource.position * Msource.position * string
+    -> unit sync_command
+  | Refresh
+    :  unit sync_command
+  | Flags_set
+    :  string list
+    -> [ `Ok | `Failures of (string * exn) list ] sync_command
+  | Findlib_use
+    :  string list
+    -> [`Ok | `Failures of (string * exn) list] sync_command
+  | Extension_set
+    :  [`Enabled|`Disabled] * string list
+    -> [`Ok | `Failures of (string * exn) list] sync_command
+  | Path
+    :  [`Build|`Source]
+     * [`Add|`Rem]
+     * string list
+    -> unit sync_command
+  | Path_reset
+    :  unit sync_command
+  | Protocol_version
+    : int option
+    -> ([`Selected of protocol_version] *
+        [`Latest of protocol_version] *
+        string) sync_command
+  | Checkout
+    : Context.document
+    -> unit sync_command
+  | Idle_job
+    : bool sync_command
+  | Flags_get
+    :  string list sync_command
+  | Project_get
+    :  (string list * [`Ok | `Failures of string list]) sync_command
+
+type 'a command =
+  | Query of 'a Query_protocol.t
+  | Sync  of 'a sync_command
+
+type request = Request : Context.t * 'a command -> request
+
+type response =
+  | Return    : 'a command * 'a -> response
+  | Failure   : string -> response
+  | Error     : Json.t -> response
+  | Exception : exn -> response
diff --git a/src/frontend/ocamlmerlin/query_json.ml b/src/frontend/ocamlmerlin/query_json.ml
new file mode 100644
index 0000000..81a1c69
--- /dev/null
+++ b/src/frontend/ocamlmerlin/query_json.ml
@@ -0,0 +1,420 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+open Query_protocol
+
+let dump (type a) : a t -> json =
+  let mk command args =
+    `Assoc (
+      ("command", `String command) ::
+      args
+    ) in
+  let mk_position = function
+    | `Start -> `String "start"
+    | `End -> `String "end"
+    | `Offset n ->
+      `Assoc ["offset", `Int n]
+    | `Logical (line,col) ->
+      `Assoc ["line", `Int line; "column", `Int col]
+  in
+  let kinds_to_json kind =
+    `List (List.map ~f:(function
+        | `Constructor  -> `String "constructor"
+        | `Keywords     -> `String "keywords"
+        | `Labels       -> `String "label"
+        | `Modules      -> `String "module"
+        | `Modules_type -> `String "module-type"
+        | `Types        -> `String "type"
+        | `Values       -> `String "value"
+        | `Variants     -> `String "variant"
+      ) kind)
+  in
+  function
+  | Type_expr (expr, pos) ->
+    mk "type-expression" [
+      "expression", `String expr;
+      "position", mk_position pos;
+    ]
+
+  | Type_enclosing (opt_cursor, pos, index) ->
+    mk "type-enclosing" [
+      "cursor", (match opt_cursor with
+          | None -> `Null
+          | Some (text, offset) -> `Assoc [
+              "text", `String text;
+              "offset", `Int offset;
+            ]
+        );
+      "index", (match index with
+          | None -> `String "all"
+          | Some n -> `Int n
+        );
+      "position", mk_position pos;
+    ]
+
+  | Locate_type pos ->
+    mk "locate-type" [
+      "position", mk_position pos
+    ]
+
+  | Enclosing pos ->
+    mk "enclosing" [
+      "position", mk_position pos;
+    ]
+
+  | Complete_prefix (prefix, pos, kind, doc, typ) ->
+    mk "complete-prefix" [
+      "prefix", `String prefix;
+      "position", mk_position pos;
+      "with-doc", `Bool doc;
+      "with-types", `Bool typ;
+      "kind", kinds_to_json kind;
+    ]
+
+  | Expand_prefix (prefix, pos, kind, typ) ->
+    mk "expand-prefix" [
+      "prefix", `String prefix;
+      "position", mk_position pos;
+      "with-types", `Bool typ;
+      "kind", kinds_to_json kind;
+    ]
+  | Document (identifier, pos) ->
+    mk "document" [
+      "identifier", (match identifier with
+          | None -> `Null
+          | Some ident -> `String ident
+        );
+      "position", mk_position pos;
+    ]
+  | Locate (prefix, look_for, pos) ->
+    mk "locate" [
+      "prefix", (match prefix with
+          | None -> `Null
+          | Some prefix -> `String prefix
+        );
+      "look-for", (match look_for with
+          | `ML -> `String "implementation"
+          | `MLI -> `String "interface"
+        );
+      "position", mk_position pos;
+    ]
+  | Jump (target, pos) ->
+    mk "jump" [
+      "target", `String target;
+      "position", mk_position pos;
+    ]
+  | Phrase (target, pos) ->
+    mk "phrase" [
+      "target", `String (match target with `Next -> "next" | `Prev -> "prev");
+      "position", mk_position pos;
+    ]
+  | Case_analysis (pos_start,pos_end) ->
+    mk "case-analysis" [
+      "start", mk_position pos_start;
+      "end", mk_position pos_end;
+    ]
+  | Holes -> mk "holes" []
+  | Construct (pos, with_values, depth) ->
+    let depth = Option.value ~default:1 depth in
+    mk "construct" [
+      "position", mk_position pos;
+      "with_values", (match with_values with
+      | Some `None | None -> `String "none"
+      | Some `Local -> `String "local"
+      );
+      "depth", `Int depth
+    ]
+  | Outline -> mk "outline" []
+  | Errors { lexing; parsing; typing } ->
+    let args =
+      if lexing && parsing && typing
+      then []
+      else [
+        "lexing", `Bool lexing;
+        "parsing", `Bool parsing;
+        "typing", `Bool typing;
+      ]
+    in
+    mk "errors" args
+  | Shape pos ->
+    mk "shape" [
+      "position", mk_position pos;
+    ]
+  | Dump args ->
+    mk "dump" [
+      "args", `List args
+    ]
+  | Path_of_source paths ->
+    mk "path-of-source" [
+      "paths", `List (List.map ~f:Json.string paths)
+    ]
+  | List_modules exts ->
+    mk "list-modules" [
+      "extensions", `List (List.map ~f:Json.string exts)
+    ]
+  | Findlib_list -> mk "findlib-list" []
+  | Extension_list status ->
+    mk "extension-list" [
+      "filter", (match status with
+          | `All -> `String "all"
+          | `Enabled -> `String "enabled"
+          | `Disabled -> `String "disabled"
+        );
+    ]
+  | Path_list var ->
+    mk "path-list" [
+      "variable", (match var with
+          | `Build -> `String "build"
+          | `Source -> `String "source"
+        );
+    ]
+  | Polarity_search (query, pos) ->
+    mk "polarity-search" [
+      "query", `String query;
+      "position", mk_position pos;
+    ]
+  | Occurrences (`Ident_at pos) ->
+    mk "occurrences" [
+      "kind", `String "identifiers";
+      "position", mk_position pos;
+    ]
+  | Refactor_open (action, pos) ->
+    mk "refactor-open" [
+      "action", `String (match action with `Qualify -> "qualify"
+                                         | `Unqualify -> "unqualify");
+      "position", mk_position pos;
+    ]
+  | Version -> mk "version" []
+
+let string_of_completion_kind = function
+  | `Value       -> "Value"
+  | `Variant     -> "Variant"
+  | `Constructor -> "Constructor"
+  | `Label       -> "Label"
+  | `Module      -> "Module"
+  | `Modtype     -> "Signature"
+  | `Type        -> "Type"
+  | `Method      -> "Method"
+  | `MethodCall  -> "#"
+  | `Exn         -> "Exn"
+  | `Class       -> "Class"
+  | `Keyword     -> "Keyword"
+
+let with_location ?(skip_none=false) loc assoc =
+  if skip_none && loc = Location.none then
+    `Assoc assoc
+  else
+    `Assoc (("start", Lexing.json_of_position loc.Location.loc_start) ::
+            ("end",   Lexing.json_of_position loc.Location.loc_end) ::
+            assoc)
+
+let json_of_type_loc (loc,desc,tail) =
+  with_location loc [
+    "type", (match desc with
+        | `String _ as str -> str
+        | `Index n -> `Int n);
+    "tail", `String (match tail with
+        | `No -> "no"
+        | `Tail_position -> "position"
+        | `Tail_call -> "call")
+  ]
+
+let json_of_error (error : Location.error) =
+  let of_sub loc sub =
+    let msg =
+      Location.print_sub_msg Format.str_formatter sub;
+      String.trim (Format.flush_str_formatter ())
+    in
+    with_location ~skip_none:true loc ["message", `String msg]
+  in
+  let loc = Location.loc_of_report error in
+  let msg =
+    Format.asprintf "@[%a@]" Location.print_main error |> String.trim
+  in
+  let typ =
+    match error.source with
+    | Location.Lexer   -> "lexer"
+    | Location.Parser  -> "parser"
+    | Location.Typer   -> "typer"
+    | Location.Warning ->
+      if String.is_prefixed ~by:"Error" msg then
+        "typer" (* Handle warn-error (since 4.08) *)
+      else
+        "warning"
+    | Location.Unknown -> "unknown"
+    | Location.Env     -> "env"
+    | Location.Config     -> "config"
+  in
+  let content = [
+    "type"    , `String typ;
+    "sub"     , `List (List.map ~f:(of_sub loc) error.sub);
+    "valid"   , `Bool true;
+    "message" , `String msg;
+  ] in
+  with_location ~skip_none:true loc content
+
+let json_of_completion {Compl. name; kind; desc; info; deprecated} =
+  `Assoc ["name", `String name;
+          "kind", `String (string_of_completion_kind kind);
+          "desc", `String desc;
+          "info", `String info;
+          "deprecated", `Bool deprecated]
+
+let json_of_completions {Compl. entries; context } =
+  `Assoc [
+    "entries", `List (List.map ~f:json_of_completion entries);
+    "context", (match context with
+        | `Unknown -> `Null
+        | `Application {Compl. argument_type; labels} ->
+          let label (name,ty) = `Assoc ["name", `String name;
+                                        "type", `String ty] in
+          let a = `Assoc ["argument_type", `String argument_type;
+                          "labels", `List (List.map ~f:label labels)] in
+          `List [`String "application"; a])
+  ]
+
+let rec json_of_outline outline =
+  let json_of_item { outline_name ; outline_kind ; outline_type; location ; children ; deprecated } =
+    with_location location [
+      "name", `String outline_name;
+      "kind", `String (string_of_completion_kind outline_kind);
+      "type", (match outline_type with
+        | None -> `Null
+        | Some typ -> `String typ);
+      "children", `List (json_of_outline children);
+      "deprecated", `Bool deprecated
+    ]
+  in
+  List.map ~f:json_of_item outline
+
+let rec json_of_shape { shape_loc; shape_sub } =
+  with_location shape_loc [
+    "children", `List (List.map ~f:json_of_shape shape_sub);
+  ]
+
+let json_of_locate resp =
+  match resp with
+  | `At_origin -> `String "Already at definition point"
+  | `Builtin s ->
+    `String (sprintf "%S is a builtin, and it is therefore impossible \
+                      to jump to its definition" s)
+  | `Invalid_context -> `String "Not a valid identifier"
+  | `Not_found (id, None) -> `String ("didn't manage to find " ^ id)
+  | `Not_found (i, Some f) ->
+    `String
+      (sprintf "%s was supposed to be in %s but could not be found" i f)
+  | `Not_in_env str ->
+    `String (Printf.sprintf "Not in environment '%s'" str)
+  | `File_not_found msg ->
+    `String msg
+  | `Found (None,pos) ->
+    `Assoc ["pos", Lexing.json_of_position pos]
+  | `Found (Some file,pos) ->
+    `Assoc ["file",`String file; "pos", Lexing.json_of_position pos]
+
+let json_of_response (type a) (query : a t) (response : a) : json =
+  match query, response with
+  | Type_expr _, str -> `String str
+  | Type_enclosing _, results ->
+    `List (List.map ~f:json_of_type_loc results)
+  | Enclosing _, results ->
+    `List (List.map ~f:(fun loc -> with_location loc []) results)
+  | Complete_prefix _, compl ->
+    json_of_completions compl
+  | Expand_prefix _, compl ->
+    json_of_completions compl
+  | Polarity_search _, compl ->
+    json_of_completions compl
+  | Refactor_open _, locations ->
+    `List (List.map locations ~f:(fun (name,loc) ->
+        with_location loc ["content",`String name]))
+  | Document _, resp ->
+    begin match resp with
+      | `No_documentation -> `String "No documentation available"
+      | `Invalid_context -> `String "Not a valid identifier"
+      | `Builtin s ->
+        `String (sprintf "%S is a builtin, no documentation is available" s)
+      | `Not_found (id, None) -> `String ("didn't manage to find " ^ id)
+      | `Not_found (i, Some f) ->
+        `String
+          (sprintf "%s was supposed to be in %s but could not be found" i f)
+      | `Not_in_env str ->
+        `String (Printf.sprintf "Not in environment '%s'" str)
+      | `File_not_found msg ->
+        `String msg
+      | `Found doc ->
+        `String doc
+    end
+  | Locate_type _, resp -> json_of_locate resp
+  | Locate _, resp -> json_of_locate resp
+  | Jump _, resp ->
+    begin match resp with
+      | `Error str ->
+        `String str
+      | `Found pos ->
+        `Assoc ["pos", Lexing.json_of_position pos]
+    end
+  | Phrase _, pos ->
+    `Assoc ["pos", Lexing.json_of_position pos]
+  | Case_analysis _, ({ Location. loc_start ; loc_end; _ }, str) ->
+    let assoc =
+      `Assoc [
+        "start", Lexing.json_of_position loc_start  ;
+        "end", Lexing.json_of_position loc_end ;
+      ]
+    in
+    `List [ assoc ; `String str ]
+  | Holes, locations ->
+    `List (List.map locations
+            ~f:(fun (loc, typ) -> with_location loc ["type", `String typ]))
+  | Construct _, ({ Location. loc_start ; loc_end; _ }, strs) ->
+    let assoc =
+      `Assoc [
+        "start", Lexing.json_of_position loc_start  ;
+        "end", Lexing.json_of_position loc_end ;
+      ]
+    in
+    `List [ assoc ; `List (List.map ~f:Json.string strs) ]
+  | Outline, outlines ->
+    `List (json_of_outline outlines)
+  | Shape _, shapes ->
+    `List (List.map ~f:json_of_shape shapes)
+  | Errors _, errors ->
+    `List (List.map ~f:json_of_error errors)
+  | Dump _, json -> json
+  | Path_of_source _, str -> `String str
+  | List_modules _, strs -> `List (List.map ~f:Json.string strs)
+  | Findlib_list, strs -> `List (List.map ~f:Json.string strs)
+  | Extension_list _, strs -> `List (List.map ~f:Json.string strs)
+  | Path_list _, strs -> `List (List.map ~f:Json.string strs)
+  | Occurrences _, locations ->
+    `List (List.map locations
+             ~f:(fun loc -> with_location loc []))
+  | Version, version ->
+    `String version
diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml
new file mode 100644
index 0000000..568baa3
--- /dev/null
+++ b/src/frontend/query_commands.ml
@@ -0,0 +1,844 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Misc
+open Std
+open Query_protocol
+module Printtyp = Type_utils.Printtyp
+
+exception No_nodes
+
+let print_completion_entries ~with_types config source entries =
+  if with_types then
+    let input_ref = ref [] and output_ref = ref [] in
+    let preprocess entry =
+      match Completion.raw_info_printer entry with
+      | `String s -> `String s
+      | `Print t ->
+        let r = ref "" in
+        input_ref := t :: !input_ref;
+        output_ref := r :: !output_ref;
+        `Print r
+      | `Concat (s,t) ->
+        let r = ref "" in
+        input_ref := t :: !input_ref;
+        output_ref := r :: !output_ref;
+        `Concat (s,r)
+    in
+    let entries = List.rev_map ~f:(Completion.map_entry preprocess) entries in
+    let entries = List.rev entries in
+    let outcomes = Mreader.print_batch_outcome config source !input_ref in
+    List.iter2 ~f:(:=) !output_ref outcomes;
+    let postprocess = function
+      | `String s -> s
+      | `Print r -> !r
+      | `Concat (s,r) -> s ^ !r
+    in
+    List.rev_map ~f:(Completion.map_entry postprocess) entries
+  else List.rev_map ~f:(Completion.map_entry (fun _ -> "")) entries
+
+let for_completion pipeline position =
+  let pipeline = Mpipeline.for_completion position pipeline in
+  let typer = Mpipeline.typer_result pipeline in
+  (pipeline, typer)
+
+let verbosity pipeline =
+  Mconfig.((Mpipeline.final_config pipeline).query.verbosity)
+
+let dump pipeline = function
+  | [`String "ppxed-source"] ->
+    let ppf, to_string = Format.to_string () in
+    begin match Mpipeline.ppx_parsetree pipeline with
+      | `Interface s -> Pprintast.signature ppf s
+      | `Implementation s -> Pprintast.structure ppf s
+    end;
+    Format.pp_print_newline ppf ();
+    Format.pp_force_newline ppf ();
+    `String (to_string ())
+
+  | [`String "source"] ->
+    let ppf, to_string = Format.to_string () in
+    begin match Mpipeline.reader_parsetree pipeline with
+      | `Interface s -> Pprintast.signature ppf s
+      | `Implementation s -> Pprintast.structure ppf s
+    end;
+    Format.pp_print_newline ppf ();
+    Format.pp_force_newline ppf ();
+    `String (to_string ())
+
+  | [`String "parsetree"] ->
+    let ppf, to_string = Format.to_string () in
+    begin match Mpipeline.reader_parsetree pipeline with
+      | `Interface s -> Printast.interface ppf s
+      | `Implementation s -> Printast.implementation ppf s
+    end;
+    Format.pp_print_newline ppf ();
+    Format.pp_force_newline ppf ();
+    `String (to_string ())
+
+  | [`String "ppxed-parsetree"] ->
+    let ppf, to_string = Format.to_string () in
+    begin match Mpipeline.ppx_parsetree pipeline with
+      | `Interface s -> Printast.interface ppf s
+      | `Implementation s -> Printast.implementation ppf s
+    end;
+    Format.pp_print_newline ppf ();
+    Format.pp_force_newline ppf ();
+    `String (to_string ())
+
+  | (`String ("env" | "fullenv" as kind) :: opt_pos) ->
+    let typer = Mpipeline.typer_result pipeline in
+    let kind = if kind = "env" then `Normal else `Full in
+    let pos =
+      match opt_pos with
+      |  [`String "at"; jpos] ->
+        Some (match jpos with
+            | `String "start" -> `Start
+            | `String "end" -> `End
+            | `Int offset -> `Offset offset
+            | `Assoc props ->
+              begin match List.assoc "line" props, List.assoc "col" props with
+                | `Int line, `Int col -> `Logical (line,col)
+                | _ -> failwith "Incorrect position"
+                | exception Not_found -> failwith "Incorrect position"
+              end
+            | _ -> failwith "Incorrect position"
+          )
+      | [] -> None
+      | _ -> failwith "incorrect position"
+    in
+    let env = match pos with
+      | None -> Mtyper.get_env typer
+      | Some pos ->
+        let pos = Mpipeline.get_lexing_pos pipeline pos in
+        fst (Mbrowse.leaf_node (Mtyper.node_at typer pos))
+    in
+    let sg = Browse_misc.signature_of_env ~ignore_extensions:(kind = `Normal) env in
+    let aux item =
+      let ppf, to_string = Format.to_string () in
+      Printtyp.signature ppf [item];
+      `String (to_string ())
+    in
+    `List (List.map ~f:aux sg)
+
+  | [`String "browse"] ->
+    let typer = Mpipeline.typer_result pipeline in
+    let structure = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in
+    Browse_misc.dump_browse (snd (Mbrowse.leaf_node structure))
+
+  | [`String "current-level"] ->
+    let _typer = Mpipeline.typer_result pipeline in
+    `Int (Ctype.get_current_level ())
+
+  | [`String "tokens"] ->
+    failwith "TODO"
+
+  | [`String "flags"] ->
+    let prepare_flags flags =
+      Json.list Json.string (List.concat_map flags ~f:(fun f -> f.workval)) in
+    let user = prepare_flags
+        Mconfig.((Mpipeline.input_config pipeline).merlin.flags_to_apply) in
+    let applied = prepare_flags
+        Mconfig.((Mpipeline.final_config pipeline).merlin.flags_applied) in
+    `Assoc [ "user", user; "applied", applied ]
+
+  | [`String "warnings"] ->
+    let _typer = Mpipeline.typer_result pipeline in
+    Warnings.dump () (*TODO*)
+
+  | [`String "exn"] ->
+    let exns =
+      Mpipeline.reader_lexer_errors pipeline @
+      Mpipeline.reader_parser_errors pipeline @
+      Mpipeline.typer_errors pipeline
+    in
+    `List (List.map ~f:(fun x -> `String (Printexc.to_string x)) exns)
+
+  | [`String "paths"] ->
+    let paths = Mconfig.build_path (Mpipeline.final_config pipeline) in
+    `List (List.map paths ~f:(fun s -> `String s))
+
+  | [`String "typedtree"] ->
+    let tree =
+      Mpipeline.typer_result pipeline
+      |> Mtyper.get_typedtree
+    in
+    let ppf, to_string = Format.to_string () in
+    begin match tree with
+      | `Interface s -> Printtyped.interface ppf s
+      | `Implementation s -> Printtyped.implementation ppf s
+    end;
+    Format.pp_print_newline ppf ();
+    Format.pp_force_newline ppf ();
+    `String (to_string ())
+
+  | _ -> failwith "known dump commands: \
+                   paths, exn, warnings, flags, tokens, browse, source, \
+                   parsetree, ppxed-source, ppxed-parsetree, typedtree, \
+                   env/fullenv (at {col:, line:})"
+
+let reconstruct_identifier pipeline pos = function
+  | None ->
+    let path = Mreader.reconstruct_identifier
+        (Mpipeline.input_config pipeline)
+        (Mpipeline.raw_source pipeline)
+        pos
+    in
+    let path = Mreader_lexer.identifier_suffix path in
+    Logger.log
+      ~section:Type_enclosing.log_section
+      ~title:"reconstruct-identifier"
+      "paths: [%s]"
+      (String.concat ~sep:";" (List.map path
+        ~f:(fun l -> l.Location.txt)));
+    let reify dot =
+      if dot = "" ||
+         (dot.[0] >= 'a' && dot.[0] <= 'z') ||
+         (dot.[0] >= 'A' && dot.[0] <= 'Z')
+      then dot
+      else "(" ^ dot ^ ")"
+    in
+    begin match path with
+      | [] -> []
+      | base :: tail ->
+        let f {Location. txt=base; loc=bl} {Location. txt=dot; loc=dl} =
+          let loc = Location_aux.union bl dl in
+          let txt = base ^ "." ^ reify dot in
+          Location.mkloc txt loc
+        in
+        [ List.fold_left tail ~init:base ~f ]
+    end
+  | Some (expr, offset) ->
+    let loc_start =
+      let l, c = Lexing.split_pos pos in
+      Lexing.make_pos (l, c - offset)
+    in
+    let shift loc int =
+      let l, c = Lexing.split_pos loc in
+      Lexing.make_pos (l, c + int)
+    in
+    let add_loc source =
+      let loc =
+        { Location.
+          loc_start ;
+          loc_end = shift loc_start (String.length source) ;
+          loc_ghost = false ;
+        } in
+      Location.mkloc source loc
+    in
+    let len = String.length expr in
+    let rec aux acc i =
+      if i >= len then
+        List.rev_map ~f:add_loc (expr :: acc)
+      else if expr.[i] = '.' then
+        aux (String.sub expr ~pos:0 ~len:i :: acc) (succ i)
+      else
+        aux acc (succ i) in
+    aux [] offset
+
+let dispatch pipeline (type a) : a Query_protocol.t -> a =
+  function
+  | Type_expr (source, pos) ->
+    let typer = Mpipeline.typer_result pipeline in
+    let pos = Mpipeline.get_lexing_pos pipeline pos in
+    let env, _ = Mbrowse.leaf_node (Mtyper.node_at typer pos) in
+    let ppf, to_string = Format.to_string () in
+    let verbosity = verbosity pipeline in
+    let context = Context.Expr in
+    ignore (Type_utils.type_in_env ~verbosity ~context env ppf source : bool);
+    to_string ()
+
+  | Type_enclosing (expro, pos, index) ->
+    let typer = Mpipeline.typer_result pipeline in
+    let verbosity = verbosity pipeline in
+    let pos = Mpipeline.get_lexing_pos pipeline pos in
+    let structures = Mbrowse.enclosing pos
+      [Mbrowse.of_typedtree (Mtyper.get_typedtree typer)] in
+    let path = match structures with
+      | [] -> []
+      | browse -> Browse_misc.annotate_tail_calls browse
+    in
+
+    let result = Type_enclosing.from_nodes ~path in
+
+    (* enclosings of cursor in given expression *)
+    let exprs = reconstruct_identifier pipeline pos expro in
+    let () =
+      Logger.log ~section:Type_enclosing.log_section
+        ~title:"reconstruct identifier" "%a"
+        Logger.json (fun () ->
+          let lst =
+            List.map exprs ~f:(fun { Location.loc; txt } ->
+              `Assoc [ "start", Lexing.json_of_position loc.Location.loc_start
+                     ; "end",   Lexing.json_of_position loc.Location.loc_end
+                     ; "identifier", `String txt]
+            )
+          in
+          `List lst
+        )
+    in
+    let small_enclosings =
+      Type_enclosing.from_reconstructed exprs
+       ~nodes:structures ~cursor:pos ~verbosity
+    in
+    Logger.log ~section:Type_enclosing.log_section ~title:"small enclosing" "%a"
+      Logger.fmt (fun fmt ->
+        Format.fprintf fmt "result = [ %a ]"
+          (Format.pp_print_list ~pp_sep:Format.pp_print_space
+             (fun fmt (loc, _, _) -> Location.print_loc fmt loc))
+          small_enclosings
+      );
+
+    let ppf = Format.str_formatter in
+    let all_results = List.mapi (small_enclosings @ result)
+      ~f:(fun i (loc,text,tail) ->
+          let print = match index with None -> true | Some index -> index = i in
+          let ret x = (loc, x, tail) in
+          match text with
+          | Type_enclosing.String str -> ret (`String str)
+          | Type_enclosing.Type (env, t) when print ->
+            Printtyp.wrap_printing_env env ~verbosity
+              (fun () -> Type_utils.print_type_with_decl ~verbosity env ppf t);
+            ret (`String (Format.flush_str_formatter ()))
+          | Type_enclosing.Type_decl (env, id, t) when print ->
+            Printtyp.wrap_printing_env env ~verbosity
+              (fun () -> Printtyp.type_declaration env id ppf t);
+            ret (`String (Format.flush_str_formatter ()))
+          | Type_enclosing.Modtype (env, m) when print ->
+            Printtyp.wrap_printing_env env ~verbosity
+              (fun () -> Printtyp.modtype env ppf m);
+            ret (`String (Format.flush_str_formatter ()))
+          | _ -> ret (`Index i)
+        )
+    in
+    let normalize ({Location. loc_start; loc_end; _}, text, _tail) =
+      Lexing.split_pos loc_start, Lexing.split_pos loc_end, text
+    in
+    (* We remove duplicates from the list. Duplicates can appear when the type
+       from the reconstructed identifier is the same as the one stored in the
+       typedtree *)
+    List.merge_cons
+      ~f:(fun a b ->
+          if compare (normalize a) (normalize b) = 0 then Some b else None)
+      all_results
+
+  | Enclosing pos ->
+    let typer = Mpipeline.typer_result pipeline in
+    let structures = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in
+    let pos = Mpipeline.get_lexing_pos pipeline pos in
+    let mbrowse = Mbrowse.enclosing pos [structures] in
+    (* We remove possible duplicates from the list*)
+    List.fold_left mbrowse ~init:[] ~f:(fun acc node ->
+      let loc = Mbrowse.node_loc (snd node) in
+      match acc with
+      | hd::_ as acc when Location_aux.compare hd loc = 0 -> acc
+      | _ -> loc::acc)
+    |> List.rev
+
+  | Locate_type pos ->
+    let typer = Mpipeline.typer_result pipeline in
+    let structures = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in
+    let pos = Mpipeline.get_lexing_pos pipeline pos in
+    let node =
+      match Mbrowse.enclosing pos [structures] with
+      | path :: _ -> Some path
+      | [] -> None
+    in
+    let path =
+      Option.bind node ~f:(fun (env, node) ->
+          Locate.log ~title:"query_commands Locate_type"
+            "inspecting node: %s" (Browse_raw.string_of_node node);
+          match node with
+          | Browse_raw.Expression {exp_type = ty; _}
+          | Pattern {pat_type = ty; _}
+          | Core_type {ctyp_type = ty; _}
+          | Value_description { val_desc = { ctyp_type = ty; _ }; _ } ->
+            begin match (Ctype.repr ty).desc with
+              | Tconstr (path, _, _) -> Some (env, path)
+              | _ -> None
+            end
+          | _ -> None)
+    in
+    begin match path with
+      | None -> `Invalid_context
+      | Some (env, path) ->
+        Locate.log ~title:"debug" "found type: %s" (Path.name path);
+        let local_defs = Mtyper.get_typedtree typer in
+        match Locate.from_path
+                ~env
+                ~config:(Mpipeline.final_config pipeline)
+                ~local_defs ~pos ~namespace:`Type `MLI
+                path with
+        | `Builtin -> `Builtin (Path.name path)
+        | `Not_in_env _ as s -> s
+        | `Not_found _ as s -> s
+        | `Found _ as s -> s
+        | `File_not_found _ as s -> s
+    end
+
+  | Complete_prefix (prefix, pos, kinds, with_doc, with_types) ->
+    let pipeline, typer = for_completion pipeline pos in
+    let config = Mpipeline.final_config pipeline in
+    let verbosity = Mconfig.(config.query.verbosity) in
+    let no_labels = Mpipeline.reader_no_labels_for_completion pipeline in
+    let source = Mpipeline.input_source pipeline in
+    let pos = Mpipeline.get_lexing_pos pipeline pos in
+    let branch = Mtyper.node_at ~skip_recovered:true typer pos in
+    let env, _ = Mbrowse.leaf_node branch in
+    let target_type, context =
+      Completion.application_context ~prefix branch in
+    let get_doc =
+      if not with_doc then None else
+        let local_defs = Mtyper.get_typedtree typer in
+        Some (Locate.get_doc ~config ~env ~local_defs
+                ~comments:(Mpipeline.reader_comments pipeline) ~pos)
+    in
+    let keywords = Mpipeline.reader_lexer_keywords pipeline in
+    let entries =
+      Printtyp.wrap_printing_env env ~verbosity @@ fun () ->
+      Completion.branch_complete config ~kinds ?get_doc ?target_type ~keywords
+        prefix branch
+      |> print_completion_entries ~with_types config source
+    and context = match context with
+      | `Application context when no_labels ->
+        `Application {context with Compl.labels = []}
+      | context -> context
+    in
+    {Compl. entries; context }
+
+  | Expand_prefix (prefix, pos, kinds, with_types) ->
+    let pipeline, typer = for_completion pipeline pos in
+    let source = Mpipeline.input_source pipeline in
+    let pos = Mpipeline.get_lexing_pos pipeline pos in
+    let env, _ = Mbrowse.leaf_node (Mtyper.node_at typer pos) in
+    let config = Mpipeline.final_config pipeline in
+    let global_modules = Mconfig.global_modules config in
+    let entries =
+      Completion.expand_prefix env ~global_modules ~kinds prefix |>
+      print_completion_entries ~with_types config source
+    in
+    { Compl. entries ; context = `Unknown }
+
+  | Polarity_search (query, pos) ->
+    let typer = Mpipeline.typer_result pipeline in
+    let pos = Mpipeline.get_lexing_pos pipeline pos in
+    let env, _ = Mbrowse.leaf_node (Mtyper.node_at typer pos) in
+    let query =
+      let re = Str.regexp "[ |\t]+" in
+      let pos,neg = Str.split re query |> List.partition ~f:(fun s->s.[0]<>'-') in
+      let prepare s =
+        Longident.parse @@
+        if s.[0] = '-' || s.[0] = '+'
+        then String.sub s ~pos:1 ~len:(String.length s - 1)
+        else s
+      in
+      Polarity_search.build_query env
+        ~positive:(List.map pos ~f:prepare)
+        ~negative:(List.map neg ~f:prepare)
+    in
+    let config = Mpipeline.final_config pipeline in
+    let global_modules = Mconfig.global_modules config in
+    let dirs = Polarity_search.directories ~global_modules env in
+    ignore (Format.flush_str_formatter ());
+    let entries =
+      Polarity_search.execute_query query env dirs |>
+      List.sort ~cmp:compare |>
+      Printtyp.wrap_printing_env env ~verbosity:(verbosity pipeline) @@ fun () ->
+      List.map ~f:(fun (_, path, v) ->
+          Printtyp.path Format.str_formatter path;
+          let name = Format.flush_str_formatter () in
+          Printtyp.type_scheme env Format.str_formatter v.Types.val_type;
+          let desc = Format.flush_str_formatter () in
+          {Compl. name; kind = `Value; desc; info = ""; deprecated = false }
+        )
+    in
+    { Compl. entries ; context = `Unknown }
+
+  | Refactor_open (mode, pos) ->
+    let typer = Mpipeline.typer_result pipeline in
+    let pos = Mpipeline.get_lexing_pos pipeline pos in
+    Refactor_open.get_rewrites ~mode typer pos
+
+  | Document (patho, pos) ->
+    let typer = Mpipeline.typer_result pipeline in
+    let local_defs = Mtyper.get_typedtree typer in
+    let config = Mpipeline.final_config pipeline in
+    let pos = Mpipeline.get_lexing_pos pipeline pos in
+    let comments = Mpipeline.reader_comments pipeline in
+    let env, _ = Mbrowse.leaf_node (Mtyper.node_at typer pos) in
+    let path =
+      match patho with
+      | Some p -> p
+      | None ->
+        let path = reconstruct_identifier pipeline pos None in
+        let path = Mreader_lexer.identifier_suffix path in
+        let path = List.map ~f:(fun {Location. txt; _} -> txt) path in
+        String.concat ~sep:"." path
+    in
+    if path = "" then `Invalid_context else
+      Locate.get_doc ~config
+        ~env ~local_defs ~comments ~pos (`User_input path)
+
+  | Locate (patho, ml_or_mli, pos) ->
+    let typer = Mpipeline.typer_result pipeline in
+    let local_defs = Mtyper.get_typedtree typer in
+    let pos = Mpipeline.get_lexing_pos pipeline pos in
+    let env, _ = Mbrowse.leaf_node (Mtyper.node_at typer pos) in
+    let path =
+      match patho with
+      | Some p -> p
+      | None ->
+        let path = reconstruct_identifier pipeline pos None in
+        let path = Mreader_lexer.identifier_suffix path in
+        let path = List.map ~f:(fun {Location. txt; _} -> txt) path in
+        let path = String.concat ~sep:"." path in
+        Locate.log ~title:"reconstructed identifier" "%s" path;
+        path
+    in
+    if path = "" then `Invalid_context else
+    begin match
+      Locate.from_string
+        ~config:(Mpipeline.final_config pipeline)
+        ~env ~local_defs ~pos ml_or_mli path
+    with
+    | `Found (file, pos) ->
+      Locate.log ~title:"result"
+        "found: %s" (Option.value ~default:"<local buffer>" file);
+      `Found (file, pos)
+    | `Missing_labels_namespace ->
+      (* Can't happen because we haven't passed a namespace as input. *)
+      assert false
+    | (`Not_found _|`At_origin |`Not_in_env _|`File_not_found _|`Builtin _) as
+      otherwise ->
+      Locate.log ~title:"result" "not found";
+      otherwise
+    end
+
+  | Jump (target, pos) ->
+    let typer = Mpipeline.typer_result pipeline in
+    let typedtree = Mtyper.get_typedtree typer in
+    let pos = Mpipeline.get_lexing_pos pipeline pos in
+    Jump.get typedtree pos target
+
+  | Phrase (target, pos) ->
+    let typer = Mpipeline.typer_result pipeline in
+    let typedtree = Mtyper.get_typedtree typer in
+    let pos = Mpipeline.get_lexing_pos pipeline pos in
+    Mpipeline.get_lexing_pos pipeline (Jump.phrase typedtree pos target)
+
+  | Case_analysis (pos_start, pos_end) ->
+    let typer = Mpipeline.typer_result pipeline in
+    let pos_start = Mpipeline.get_lexing_pos pipeline pos_start in
+    let pos_end = Mpipeline.get_lexing_pos pipeline pos_end in
+    let browse = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in
+    let nodes = Mbrowse.enclosing pos_start [browse] in
+    let dump_node (_,node) =
+      let {Location. loc_start; loc_end; _} =
+        Mbrowse.node_loc node in
+      let l1,c1 = Lexing.split_pos loc_start in
+      let l2,c2 = Lexing.split_pos loc_end in
+      `List [
+         `String (Browse_raw.string_of_node node);
+         `Int l1; `Int c1;
+         `Int l2; `Int c2;
+       ]
+    in
+    Destruct.log ~title:"nodes before" "%a"
+      Logger.json (fun () -> `List (List.map nodes ~f:dump_node));
+    let nodes =
+      (* Drop nodes that:
+         - start inside the user's selection
+         - finish inside the user's selection
+      *)
+      List.drop_while nodes
+        ~f:(fun (_,t) ->
+          let {Location. loc_start; loc_end; _} = Mbrowse.node_loc t in
+          Lexing.compare_pos loc_start pos_start > 0 || Lexing.compare_pos loc_end pos_end < 0)
+    in
+    Destruct.log ~title:"nodes after" "%a"
+      Logger.json (fun () -> `List (List.map nodes ~f:dump_node));
+    begin match nodes with
+      | [] -> raise Destruct.Nothing_to_do
+      | (env,node) :: parents ->
+        let source = Mpipeline.input_source pipeline in
+        let config = Mpipeline.final_config pipeline in
+        let verbosity = verbosity pipeline in
+        Printtyp.wrap_printing_env env ~verbosity @@ fun () ->
+        Destruct.node config source node (List.map ~f:snd parents)
+    end
+
+  | Holes ->
+    let typer = Mpipeline.typer_result pipeline in
+    let verbosity = verbosity pipeline in
+    let nodes = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in
+    let ppf = Format.str_formatter in
+    let print ~nodes loc env type_ () =
+      match type_ with
+      | `Exp type_expr ->
+        Type_utils.print_type_with_decl ~verbosity env ppf type_expr
+      | `Mod module_type ->
+        (* For module_expr holes we need the type of the next enclosing
+          to get a useful result *)
+        match Mbrowse.enclosing (loc.Location.loc_start) [nodes] with
+        | _ :: (_, Browse_raw.Module_expr { mod_type; _}) :: _ ->
+          Printtyp.modtype env ppf mod_type
+        | _ ->
+          Printtyp.modtype env ppf module_type
+    in
+    let loc_and_types_of_holes node =
+      List.map (Browse_raw.all_holes node) ~f:(
+        fun (loc, env, type_) ->
+          Printtyp.wrap_printing_env env ~verbosity
+            (print ~nodes loc env type_);
+          (loc, Format.flush_str_formatter ()))
+    in
+    List.concat_map ~f:loc_and_types_of_holes nodes
+
+  | Construct (pos, with_values, depth) ->
+    let values_scope = match with_values with
+      | Some `None | None -> Construct.Null
+      | Some `Local -> Construct.Local
+    in
+    let keywords = Mpipeline.reader_lexer_keywords pipeline in
+    let typer = Mpipeline.typer_result pipeline in
+    let typedtree = Mtyper.get_typedtree typer in
+    let pos = Mpipeline.get_lexing_pos pipeline pos in
+    let structures = Mbrowse.enclosing pos
+      [Mbrowse.of_typedtree typedtree] in
+    begin match structures with
+    | (_, (Browse_raw.Module_expr { mod_desc = Tmod_hole; _ } as node_for_loc))
+      :: (_, node) :: _parents ->
+        let loc = Mbrowse.node_loc node_for_loc in
+        (loc, Construct.node ~keywords ?depth ~values_scope node)
+    | (_,  (Browse_raw.Expression { exp_desc = Texp_hole; _ } as node))
+      :: _parents ->
+      let loc = Mbrowse.node_loc node in
+      (loc, Construct.node ~keywords ?depth ~values_scope node)
+    | _ :: _ -> raise Construct.Not_a_hole
+    | [] -> raise No_nodes
+    end
+
+  | Outline ->
+    let typer = Mpipeline.typer_result pipeline in
+    let browse = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in
+    Outline.get [Browse_tree.of_browse browse]
+
+  | Shape pos ->
+    let typer = Mpipeline.typer_result pipeline in
+    let browse = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in
+    let pos = Mpipeline.get_lexing_pos pipeline pos in
+    Outline.shape pos [Browse_tree.of_browse browse]
+
+  | Errors { lexing; parsing; typing }->
+    let typer = Mpipeline.typer_result pipeline in
+    let verbosity = verbosity pipeline in
+    Printtyp.wrap_printing_env (Mtyper.get_env typer) ~verbosity @@ fun () ->
+    let lexer_errors  = Mpipeline.reader_lexer_errors pipeline  in
+    let parser_errors = Mpipeline.reader_parser_errors pipeline in
+    let typer_errors  = Mpipeline.typer_errors pipeline  in
+    (* When there is a cmi error, we will have a lot of meaningless errors,
+       there is no need to report them. *)
+    let typer_errors =
+      let cmi_error = function Magic_numbers.Cmi.Error _ -> true | _ -> false in
+      match List.find typer_errors ~f:cmi_error with
+      | e -> [e]
+      | exception Not_found -> typer_errors
+    in
+    let error_start e = (Location.loc_of_report e).Location.loc_start in
+    let error_end e = (Location.loc_of_report e).Location.loc_end in
+    (* Turn into Location.error, ignore ghost warnings *)
+    let filter_error exn =
+      match Location.error_of_exn exn with
+      | None | Some `Already_displayed -> None
+      | Some (`Ok (err : Location.error)) ->
+        if (Location.loc_of_report err).loc_ghost &&
+           (match exn with Msupport.Warning _ -> true | _ -> false)
+        then None
+        else Some err
+    in
+    let lexer_errors  = List.filter_map ~f:filter_error lexer_errors in
+    (* Ast can contain syntax error *)
+    let first_syntax_error = ref Lexing.dummy_pos in
+    let filter_typer_error exn =
+      let result = filter_error exn in
+      begin match result with
+        | Some ({Location. source = Location.Parser; _} as err)
+          when !first_syntax_error = Lexing.dummy_pos ||
+               Lexing.compare_pos !first_syntax_error (error_start err) > 0 ->
+          first_syntax_error := error_start err;
+        | _ -> ()
+      end;
+      result
+    in
+    let typer_errors  = List.filter_map ~f:filter_typer_error typer_errors in
+    (* Track first parsing error *)
+    let filter_parser_error = function
+      | Msupport.Warning _ as exn -> filter_error exn
+      | exn ->
+        let result = filter_error exn in
+        begin match result with
+          | None -> ()
+          | Some err ->
+            if !first_syntax_error = Lexing.dummy_pos ||
+               Lexing.compare_pos !first_syntax_error (error_start err) > 0
+            then first_syntax_error := error_start err;
+        end;
+        result
+    in
+    let parser_errors = List.filter_map ~f:filter_parser_error parser_errors in
+    (* Sort errors *)
+    let cmp e1 e2 =
+      let n = Lexing.compare_pos (error_start e1) (error_start e2) in
+      if n <> 0 then n else
+        Lexing.compare_pos (error_end e1) (error_end e2)
+    in
+    let errors =
+      List.sort_uniq ~cmp
+        ((if lexing then lexer_errors else []) @
+         (if parsing then parser_errors else []) @
+         (if typing then typer_errors else []))
+    in
+    (* Add configuration errors *)
+    let errors =
+      let cfg = Mpipeline.final_config pipeline in
+      let failures =
+        List.map ~f:(Location.error ~source:Location.Config) cfg.merlin.failures
+      in
+      failures @ errors
+    in
+    (* Filter anything after first parse error *)
+    let limit = !first_syntax_error in
+    if limit = Lexing.dummy_pos then errors else (
+      List.take_while errors
+        ~f:(fun err -> Lexing.compare_pos (error_start err) limit <= 0)
+    )
+
+  | Dump args -> dump pipeline args
+
+  | Path_of_source xs ->
+    let config = Mpipeline.final_config pipeline in
+    let rec aux = function
+      | [] -> raise Not_found
+      | x :: xs ->
+        try
+          find_in_path_uncap (Mconfig.source_path config) x
+        with Not_found -> try
+            find_in_path_uncap (Mconfig.build_path config) x
+          with Not_found ->
+            aux xs
+    in
+    aux xs
+
+  | List_modules exts ->
+    let config = Mpipeline.final_config pipeline in
+    let with_ext ext = modules_in_path ~ext
+        Mconfig.(config.merlin.source_path) in
+    List.concat_map ~f:with_ext exts
+
+  | Findlib_list ->
+    []
+
+  | Extension_list kind ->
+    let config = Mpipeline.final_config pipeline in
+    let enabled = Mconfig.(config.merlin.extensions) in
+    begin match kind with
+    | `All -> Extension.all
+    | `Enabled -> enabled
+    | `Disabled ->
+      List.fold_left ~f:(fun exts ext -> List.remove ext exts)
+        ~init:Extension.all enabled
+    end
+
+  | Path_list `Build ->
+    let config = Mpipeline.final_config pipeline in
+    Mconfig.(config.merlin.build_path)
+
+  | Path_list `Source ->
+    let config = Mpipeline.final_config pipeline in
+    Mconfig.(config.merlin.source_path)
+
+  | Occurrences (`Ident_at pos) ->
+    let typer = Mpipeline.typer_result pipeline in
+    let str = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in
+    let pos = Mpipeline.get_lexing_pos pipeline pos in
+    let enclosing = Mbrowse.enclosing pos [str] in
+    let curr_node =
+      let is_wildcard_pat = function
+        | Browse_raw.Pattern {pat_desc = Typedtree.Tpat_any; _} -> true
+        | _ -> false
+      in
+      List.find_some enclosing ~f:(fun (_, node) ->
+        (* it doesn't make sense to find occurrences of a wildcard pattern *)
+        not (is_wildcard_pat node))
+      |> Option.map ~f:(fun (env, node) -> Browse_tree.of_node ~env node)
+      |> Option.value ~default:Browse_tree.dummy
+    in
+    let str = Browse_tree.of_browse str in
+    let get_loc {Location.txt = _; loc} = loc in
+    let ident_occurrence () =
+      let paths = Browse_raw.node_paths curr_node.Browse_tree.t_node in
+      let under_cursor p = Location_aux.compare_pos pos (get_loc p) = 0 in
+      Logger.log ~section:"occurrences" ~title:"Occurrences paths" "%a"
+        Logger.json (fun () ->
+            let dump_path ({Location.txt; loc} as p) =
+              let ppf, to_string = Format.to_string () in
+              Printtyp.path ppf txt;
+              `Assoc [
+                "start", Lexing.json_of_position loc.Location.loc_start;
+                "end", Lexing.json_of_position loc.Location.loc_end;
+                "under_cursor", `Bool (under_cursor p);
+                "path", `String (to_string ())
+              ]
+            in
+            `List (List.map ~f:dump_path paths));
+      match List.filter paths ~f:under_cursor with
+      | [] -> []
+      | (path :: _) ->
+        let path = path.Location.txt in
+        let ts = Browse_tree.all_occurrences path str in
+        let loc (_t,paths) = List.map ~f:get_loc paths in
+        List.concat_map ~f:loc ts
+
+    in
+    let constructor_occurrence d =
+      let ts = Browse_tree.all_constructor_occurrences (curr_node,d) str in
+      List.map ~f:get_loc ts
+
+    in
+    let locs =
+      match Browse_raw.node_is_constructor curr_node.Browse_tree.t_node with
+      | Some d -> constructor_occurrence d.Location.txt
+      | None -> ident_occurrence ()
+    in
+    let loc_start l = l.Location.loc_start in
+    let cmp l1 l2 = Lexing.compare_pos (loc_start l1) (loc_start l2) in
+    List.sort ~cmp locs
+
+  | Version ->
+    Printf.sprintf "The Merlin toolkit version %s, for Ocaml %s\n"
+      My_config.version Sys.ocaml_version;
diff --git a/src/frontend/query_commands.mli b/src/frontend/query_commands.mli
new file mode 100644
index 0000000..7663d00
--- /dev/null
+++ b/src/frontend/query_commands.mli
@@ -0,0 +1,32 @@
+
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+exception No_nodes
+
+val dispatch : Mpipeline.t -> 'a Query_protocol.t -> 'a
diff --git a/src/frontend/query_protocol.ml b/src/frontend/query_protocol.ml
new file mode 100644
index 0000000..1322bc1
--- /dev/null
+++ b/src/frontend/query_protocol.ml
@@ -0,0 +1,200 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+module Compl =
+struct
+  type 'desc raw_entry = {
+    name: string;
+    kind: [`Value|`Constructor|`Variant|`Label|
+           `Module|`Modtype|`Type|`MethodCall|`Keyword];
+    desc: 'desc;
+    info: 'desc;
+    deprecated: bool;
+  }
+
+  type entry = string raw_entry
+
+  type application_context = {
+    argument_type: string;
+    labels : (string * string) list;
+  }
+
+  type t = {
+    entries: entry list;
+    context: [ `Unknown
+             | `Application of application_context
+             ]
+  }
+
+  type kind = [
+    | `Constructor
+    | `Labels
+    | `Modules
+    | `Modules_type
+    | `Types
+    | `Values
+    | `Variants
+    | `Keywords
+  ]
+end
+
+type completions = Compl.t
+
+type outline = item list
+and item = {
+  outline_name : string ;
+  outline_kind : [
+    | `Value
+    | `Constructor
+    | `Label
+    | `Module
+    | `Modtype
+    | `Type
+    | `Exn
+    | `Class
+    | `Method
+  ];
+  outline_type : string option ;
+  deprecated : bool ;
+  location : Location_aux.t ;
+  children : outline ;
+}
+
+type shape = {
+  shape_loc : Location_aux.t;
+  shape_sub : shape list;
+}
+
+type error_filter = {
+  lexing : bool;
+  parsing : bool;
+  typing : bool;
+}
+
+type is_tail_position = [`No | `Tail_position | `Tail_call]
+
+type _ _bool = bool
+
+type _ t =
+  | Type_expr(* *)
+    :  string * Msource.position
+    -> string t
+  | Type_enclosing(* *)
+    :  (string * int) option * Msource.position * int option
+    -> (Location.t * [`String of string | `Index of int] * is_tail_position) list t
+  | Enclosing(* *)
+    :  Msource.position
+    -> Location.t list t
+  | Complete_prefix(* *)
+    :  string * Msource.position * Compl.kind list *
+       [`with_documentation] _bool * [`with_types] _bool
+    -> completions t
+  | Expand_prefix(* *)
+    :  string * Msource.position * Compl.kind list * [`with_types] _bool
+    -> completions t
+  | Polarity_search
+    :  string * Msource.position
+    -> completions t
+  | Refactor_open
+    :  [`Qualify | `Unqualify] * Msource.position
+    -> (string * Location.t) list t
+  | Document(* *)
+    : string option * Msource.position
+    -> [ `Found of string
+       | `Invalid_context
+       | `Builtin of string
+       | `Not_in_env of string
+       | `File_not_found of string
+       | `Not_found of string * string option
+       | `No_documentation
+       ] t
+  | Locate_type
+    : Msource.position
+      -> [ `Found of string option * Lexing.position
+         | `Invalid_context
+         | `Builtin of string
+         | `Not_in_env of string
+         | `File_not_found of string
+         | `Not_found of string * string option
+         | `At_origin
+         ] t
+  | Locate(* *)
+    : string option * [ `ML | `MLI ] * Msource.position
+    -> [ `Found of string option * Lexing.position
+       | `Invalid_context
+       | `Builtin of string
+       | `Not_in_env of string
+       | `File_not_found of string
+       | `Not_found of string * string option
+       | `At_origin
+       ] t
+  | Jump(* *)
+    : string * Msource.position
+    -> [ `Found of Lexing.position
+       | `Error of string
+       ] t
+  | Phrase(* *)
+    : [`Next | `Prev] * Msource.position
+    -> Lexing.position t
+  | Case_analysis(* *)
+    : Msource.position * Msource.position -> (Location.t * string) t
+  | Holes(* *)
+    : (Location.t * string) list t
+  | Construct
+    : Msource.position * [`None | `Local] option * int option
+    -> (Location.t * string list) t
+  | Outline(* *)
+    :  outline t
+  | Shape(* *)
+    :  Msource.position
+    -> shape list t
+  | Errors(* *)
+    :  error_filter
+    -> Location.error list t
+  | Dump
+    :  Std.json list
+    -> Std.json t
+  | Path_of_source(* *)
+    :  string list
+    -> string t
+  | List_modules(* *)
+    :  string list
+    -> string list t
+  | Findlib_list
+    :  string list t
+  | Extension_list
+    :  [`All|`Enabled|`Disabled]
+    -> string list t
+  | Path_list
+    :  [`Build|`Source]
+    -> string list t
+  | Occurrences(* *)
+    : [`Ident_at of Msource.position]
+    -> Location.t list t
+  | Version
+    : string t
diff --git a/src/frontend/test/ocamlmerlin_test.ml b/src/frontend/test/ocamlmerlin_test.ml
new file mode 100644
index 0000000..f458058
--- /dev/null
+++ b/src/frontend/test/ocamlmerlin_test.ml
@@ -0,0 +1,214 @@
+open Std
+
+(* Poor man's test framework *)
+type name = string
+
+type test =
+  | Single of name * (unit -> unit)
+  | Group of name * test list
+
+let test name f = Single (name, f)
+
+let group name tests = Group (name, tests)
+
+exception Detail of exn * string
+let () = Printexc.register_printer (function
+    | (Detail (exn, msg)) ->
+      Some (Printexc.to_string exn ^ "\nAdditional information:\n" ^ msg)
+    | _ -> None
+  )
+
+let str_match ~re str =
+  Str.string_match (Str.regexp (re ^ "$")) str 0
+
+(* Setting up merlin *)
+module M = Mpipeline
+
+let process ?(with_config=fun x -> x) ?for_completion filename text =
+  let config = with_config Mconfig.initial in
+  let config = Mconfig.({config with query = {config.query with filename}}) in
+  let source = Msource.make Trace.null config text in
+  let pipeline = M.make Trace.null config source in
+  match for_completion with
+  | None -> pipeline
+  | Some pos -> M.for_completion pos pipeline
+
+(* All tests *)
+
+let assert_errors ?with_config
+    filename ?(lexer=0) ?(parser=0) ?(typer=0) ?(config=0) source =
+  test filename (fun () ->
+      let m = process ?with_config filename source in
+      let lexer_errors  = M.reader_lexer_errors m in
+      let parser_errors = M.reader_parser_errors m in
+      let failures, typer_errors  =
+        Mtyper.with_typer (M.typer_result m) @@ fun () ->
+        Mconfig.((M.final_config m).merlin.failures),
+        M.typer_errors m
+      in
+      let fmt_msg exn =
+        match Location.error_of_exn exn with
+        | None | Some `Already_displayed -> Printexc.to_string exn
+        | Some (`Ok err) -> err.Location.msg
+      in
+      let expect ~count str errors =
+        let count' = List.length errors in
+        if count <> count' then failwith (
+            "expecting " ^ string_of_int count ^ " " ^ str ^ " but got " ^
+            string_of_int count' ^ " errors\n" ^
+            String.concat "\n- " ("Errors: " :: List.map_end fmt_msg
+                                    (lexer_errors @ parser_errors @ typer_errors)
+                                    failures)
+          )
+      in
+      expect ~count:lexer "lexer errors" lexer_errors;
+      expect ~count:parser "parser errors" parser_errors;
+      expect ~count:typer "typer errors" typer_errors;
+      expect ~count:config "configuration failures" failures;
+    )
+
+let assertf b fmt =
+  if b then
+    Printf.ikfprintf ignore () fmt
+  else
+    Printf.ksprintf failwith fmt
+
+let validate_output ?with_config filename source query pred =
+  test filename (fun () ->
+      let pipeline = process ?with_config filename source in
+      let result = Query_commands.dispatch pipeline query in
+      try pred result
+      with exn ->
+        let info = `Assoc [
+            "query", Query_json.dump query;
+            "result", Query_json.json_of_response query result;
+          ] in
+        raise (Detail (exn, Json.pretty_to_string info))
+    )
+
+(* FIXME: this sucks. improve. *)
+let validate_failure ?with_config filename source query pred =
+  test filename (fun () ->
+      let pipeline = process ?with_config filename source in
+      let for_info, wrapped =
+        match Query_commands.dispatch pipeline query with
+        | exception e -> ("failure", `String (Printexc.to_string e)), `Error e
+        | res -> ("result", Query_json.json_of_response query res), `Ok res
+      in
+      try pred wrapped
+      with exn ->
+        let info = `Assoc [ "query", Query_json.dump query; for_info ] in
+        raise (Detail (exn, Json.pretty_to_string info))
+    )
+
+let tests = [
+
+  group "misc" (
+    [
+      assert_errors "relaxed_external.ml"
+        "external test : unit = \"bs\"";
+
+      validate_output "occurrences.ml"
+        "let foo _ = ()\nlet () = foo 4\n"
+        (Query_protocol.Occurrences (`Ident_at (`Offset 5)))
+        (fun locations ->
+           assertf (List.length locations = 2) "expected two locations");
+    ]
+  );
+
+  group "std" [
+
+    group "glob" (
+      let glob_match ~pattern str =
+        Glob.match_pattern (Glob.compile_pattern pattern) str in
+      let should_match name ~pattern str =
+        test name (fun () -> assertf (glob_match ~pattern str)
+                      "pattern %S should match %S" pattern str)
+      and shouldn't_match name ~pattern str =
+        test name (fun () -> assertf (not (glob_match ~pattern str))
+                      "pattern %S shouldn't match %S" pattern str)
+      in
+      [
+        should_match "empty" ~pattern:"" "";
+        shouldn't_match "not-empty" ~pattern:"" "x";
+        should_match "litteral" ~pattern:"x" "x";
+        shouldn't_match "not-litteral" ~pattern:"x" "y";
+        should_match "skip" ~pattern:"x?z" "xyz";
+        shouldn't_match "not-skip" ~pattern:"x?yz" "xyz";
+        should_match "joker1" ~pattern:"x*" "xyz";
+        shouldn't_match "not-joker1" ~pattern:"y*" "xyz";
+        should_match "joker2" ~pattern:"xy*xy*" "xyzxyz";
+        shouldn't_match "not-joker2" ~pattern:"xy*yz*" "xyzyxz";
+        should_match "joker3" ~pattern:"*bar*" "foobarbaz";
+      ]
+    );
+
+    group "shell" (
+      let string_list = function
+        | [] -> "[]"
+        | comps ->
+          let comps = List.map ~f:String.escaped comps in
+          "[\"" ^ String.concat ~sep:"\";\"" comps ^ "\"]"
+      in
+      let assert_split i (str, expected) =
+        test ("split_command-" ^ string_of_int i) @@ fun () ->
+        let result = Shell.split_command str in
+        assertf (result = expected)
+          "Shell.split_command %S = %s, expecting %s"
+          str (string_list result) (string_list expected)
+      in
+      List.mapi ~f:assert_split [
+        "a b c"     , ["a";"b";"c"];
+        "a'b'c"     , ["abc"];
+        "a 'b c'"   , ["a"; "b c"];
+        "a\"b'c\""  , ["ab'c"];
+        "a\\\"b'c'" , ["a\"bc"];
+      ]
+    );
+  ];
+]
+
+(* Driver *)
+
+let passed = ref 0
+let failed = ref 0
+
+let rec run_tests indent = function
+  | [] -> ()
+  | x :: xs ->
+    run_test indent x;
+    run_tests indent xs
+
+and run_test indent = function
+  | Single (name, f) ->
+    Printf.printf "%s%s:\t%!" indent name;
+    begin match f () with
+      | () ->
+        incr passed;
+        Printf.printf "OK\n%!"
+      | exception exn ->
+        let bt = Printexc.get_backtrace () in
+        incr failed;
+        Printf.printf "KO\n%!";
+        Printf.eprintf "%sTest %s failed with exception:\n%s%s\n%!"
+          indent name
+          indent
+          (match exn with
+           | Failure str -> str
+           | exn -> Printexc.to_string exn);
+        begin match Location.error_of_exn exn with
+          | None | Some `Already_displayed -> ()
+          | Some (`Ok {Location. msg; loc}) ->
+            Printf.eprintf "%sError message:\n%s\n%!" indent msg
+        end;
+        Printf.eprintf "%sBacktrace:\n%s\n%!" indent bt
+    end
+  | Group (name, tests) ->
+    Printf.printf "%s-> %s\n" indent name;
+    run_tests (indent ^ "  ") tests
+
+let () =
+  Printexc.record_backtrace true;
+  run_tests "  " tests;
+  Printf.printf "Passed %d, failed %d\n" !passed !failed;
+  if !failed > 0 then exit 1
diff --git a/src/kernel/dune b/src/kernel/dune
new file mode 100644
index 0000000..baafd19
--- /dev/null
+++ b/src/kernel/dune
@@ -0,0 +1,19 @@
+(rule (copy# ../ocaml/driver/pparse.ml  pparse.ml ))
+(rule (copy# ../ocaml/driver/pparse.mli pparse.mli))
+
+(library
+ (name merlin_kernel)
+ (wrapped false)
+ (flags
+  :standard
+  -open Ocaml_utils
+  -open Merlin_utils
+  -open Ocaml_parsing
+  -open Ocaml_typing)
+ (libraries config os_ipc ocaml_parsing preprocess ocaml_typing ocaml_utils
+            merlin_extend merlin_specific merlin_utils merlin_dot_protocol))
+
+(rule
+  (targets standard_library.ml)
+  (action
+    (write-file %{targets} "let path = {|%{ocaml-config:standard_library}|}")))
diff --git a/src/kernel/extension.ml b/src/kernel/extension.ml
new file mode 100644
index 0000000..119bfc3
--- /dev/null
+++ b/src/kernel/extension.ml
@@ -0,0 +1,194 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+open Parser_raw
+
+exception Unknown
+
+type t = {
+  name : string;
+  private_def : string list;
+  public_def : string list;
+  packages : string list;
+  keywords : (string * Parser_raw.token) list;
+}
+
+type set = string list
+
+(* Private definitions are put in a fake module named "_" with the following
+ * ident. Use it to test or find private definitions. *)
+let ident = Ident.create_persistent "_"
+
+(** Definition of each extension *)
+let ext_lwt = {
+  name = "lwt";
+  private_def = [
+    "module Lwt : sig
+      val un_lwt : 'a Lwt.t -> 'a
+      val in_lwt : 'a Lwt.t -> 'a Lwt.t
+      val to_lwt : 'a -> 'a Lwt.t
+      val finally' : 'a Lwt.t -> unit Lwt.t -> 'a Lwt.t
+      val un_stream : 'a Lwt_stream.t -> 'a
+      val unit_lwt : unit Lwt.t -> unit Lwt.t
+    end"
+  ];
+  public_def = [
+    "val (>>) : unit Lwt.t -> 'a Lwt.t -> 'a Lwt.t
+     val raise_lwt : exn -> 'a Lwt.t
+     val assert_lwt : bool -> unit Lwt.t"
+  ];
+  keywords = [
+    "lwt", LET_LWT;
+    "try_lwt", TRY_LWT;
+    "match_lwt", MATCH_LWT;
+    "finally", FINALLY_LWT;
+    "for_lwt", FOR_LWT;
+    "while_lwt", WHILE_LWT;
+  ];
+  packages = ["lwt.syntax"];
+}
+
+let ext_nonrec = {
+  name = "nonrec";
+  private_def = [];
+  public_def = [];
+  keywords = [
+    "nonrec", NONREC;
+  ];
+  packages = [];
+}
+
+let ext_meta = {
+  name = "meta";
+  private_def = [
+    "module Meta : sig
+      val code : 'a -> 'a code
+      val uncode : 'a code -> 'a
+    end"
+  ];
+  public_def = [];
+  keywords = [
+    ">.", GREATERDOT;
+  ];
+  packages = [];
+}
+
+(* Known extensions *)
+let registry = [ext_lwt;ext_meta]
+let registry =
+  List.fold_left registry ~init:String.Map.empty
+    ~f:(fun map ext -> String.Map.add map ~key:ext.name ~data:ext)
+
+let all = String.Map.keys registry
+
+let lookup s =
+  try Some (String.Map.find s registry)
+  with Not_found -> None
+
+let empty = []
+
+(* Compute set of extensions from package names (used to enable support for
+  "lwt" if "lwt.syntax" is loaded by user. *)
+let from ~extensions ~packages =
+  String.Map.fold registry ~init:[] ~f:(fun ~key:name ~data:ext set ->
+      if List.mem name ~set:extensions ||
+         List.exists ~f:(List.mem ~set:ext.packages) packages
+      then name :: set
+      else set
+    )
+
+(* Merlin expects a few extensions to be always enabled, otherwise error
+   recovery may fail arbitrarily *)
+let default = match My_config.ocamlversion with
+              | `OCaml_4_02_2 | `OCaml_4_03_0 -> [ext_nonrec]
+              | _ -> []
+
+let default_kw = List.concat_map ~f:(fun ext -> ext.keywords) default
+
+(* Lexer keywords needed by extensions *)
+let keywords set =
+  let add_kw kws ext =
+    match lookup ext with
+    | None -> kws
+    | Some def -> def.keywords @ kws
+  in
+  let all = List.fold_left set ~init:default_kw ~f:add_kw in
+  Lexer_raw.keywords all
+
+(* Register extensions in typing environment *)
+let parse_sig =
+  let keywords = Lexer_raw.keywords [] in fun str ->
+  let lexbuf = Lexing.from_string str in
+  let state = Lexer_raw.make keywords in
+  let rec lexer = function
+    | Lexer_raw.Fail _ -> assert false
+    | Lexer_raw.Return x -> x
+    | Lexer_raw.Refill k -> lexer (k ())
+  in
+  let lexer lexbuf = lexer (Lexer_raw.token_without_comments state lexbuf) in
+  (Parser_raw.interface lexer lexbuf : Parsetree.signature)
+
+let type_sig env sg =
+  let sg = Typemod.transl_signature env sg in
+  sg.Typedtree.sig_type
+
+(*
+let add_hidden_signature env sign =
+  let add_item env comp =
+    match comp with
+    | Types.Sig_value(id, decl)     -> Env.add_value (Ident.hide id) decl env
+    | Types.Sig_type(id, decl, _)   -> Env.add_type ~check:false (Ident.hide id) decl env
+    | Types.Sig_typext(id, decl, _) -> Env.add_extension ~check:false (Ident.hide id) decl env
+    | Types.Sig_module(id, mty, _)  -> Env.add_module (Ident.hide id) mty.Types.md_type env
+    | Types.Sig_modtype(id, decl)   -> Env.add_modtype (Ident.hide id) decl env
+    | Types.Sig_class(id, decl, _)  -> Env.add_class (Ident.hide id) decl env
+    | Types.Sig_class_type(id, decl, _) -> Env.add_cltype (Ident.hide id) decl env
+  in
+  List.fold_left ~f:add_item ~init:env sign
+*)
+
+let register exts env =
+  (* Log errors ? *)
+  let try_type sg' = try type_sig env sg' with _exn -> [] in
+  let exts = List.filter_dup exts in
+  let exts = List.filter_map ~f:(fun ext ->
+      match String.Map.find ext registry with
+      | ext -> Some ext
+      | exception Not_found -> None
+    ) exts
+  in
+  let process_ext e =
+    let prv = List.concat_map ~f:parse_sig e.private_def in
+    let pub = List.concat_map ~f:parse_sig e.public_def in
+    try_type prv, try_type pub
+  in
+  let fakes, tops = List.split (List.map ~f:process_ext exts) in
+  let env = Env.add_signature (List.concat tops) env in
+  Env.add_merlin_extension_module ident
+    (Types.Mty_signature (List.concat fakes)) env
diff --git a/src/kernel/extension.mli b/src/kernel/extension.mli
new file mode 100644
index 0000000..b46fd50
--- /dev/null
+++ b/src/kernel/extension.mli
@@ -0,0 +1,75 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+
+exception Unknown
+
+(* Adjust typing environment for syntax extensions.
+ * See [Fake] for AST part *)
+
+(* Extension environment is composed of two part:
+ * - private definitions, not exposed to user but accessed by AST rewriters,
+ * - public definitions, those are made available to user in default scope,
+ *   like the Pervasives module.
+ * See [Typer.initial_env] for initial environment generation.
+ *)
+
+(** Definition of an extension (as seen from Lexer and Typer) *)
+type t = {
+  name : string;
+  private_def : string list;
+  public_def : string list;
+  packages : string list;
+  keywords : (string * Parser_raw.token) list;
+}
+
+(* Private definitions are put in a fake module named "_" with the following
+ * ident. Use it to test or find private definitions. *)
+val ident : Ident.t
+
+(** Set of extension name *)
+type set = string list
+
+(* Lexer keywords needed by extensions *)
+val keywords : set -> Lexer_raw.keywords
+(* Register extensions in typing environment *)
+val register : set -> Env.t -> Env.t
+
+(* Known extensions *)
+val all : set
+val registry : t String.Map.t
+val lookup : string -> t option
+
+(* Compute set of extensions from package names (used to enable support for
+  "lwt" if "lwt.syntax" package is loaded by user. *)
+val from : extensions:string list -> packages:string list -> set
+
+(* Merlin expects a few extensions to be always enabled, otherwise error
+   recovery may fail arbitrarily *)
+val empty : set
diff --git a/src/kernel/mbrowse.ml b/src/kernel/mbrowse.ml
new file mode 100644
index 0000000..0a8b5b1
--- /dev/null
+++ b/src/kernel/mbrowse.ml
@@ -0,0 +1,260 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+open Typedtree
+open Browse_raw
+
+type node = Browse_raw.node
+type t = (Env.t * node) list
+
+let node_of_binary_part = Browse_raw.node_of_binary_part
+
+let fold_node f env t acc =
+  let acc =
+    match
+      Msupport.get_saved_types_from_attributes (Browse_raw.node_attributes t)
+    with
+    | [] -> acc
+    | parts ->
+      let rec aux acc = function
+        | [] -> acc
+        | part :: parts ->
+          let t = node_of_binary_part env part in
+          aux (f (Browse_raw.node_update_env env t) t acc) parts
+      in
+      aux acc parts
+  in
+  Browse_raw.fold_node f env t acc
+
+let approximate_loc get_loc node =
+  let loc = get_loc Location.none node in
+  if loc == Location.none then
+    let rec aux env node acc =
+      let loc = get_loc Location.none node in
+      if loc != Location.none then
+        Location_aux.union loc acc
+      else fold_node aux env node acc
+    in
+    aux Env.empty node Location.none
+  else
+    loc
+
+let node_loc node = approximate_loc Browse_raw.node_real_loc node
+
+(* Fuzzy locations, more likely to locate the appropriate node *)
+let node_merlin_loc node = approximate_loc Browse_raw.node_merlin_loc node
+
+let leaf_node = List.hd
+let leaf_loc t = node_loc (snd (leaf_node t))
+
+let drop_leaf t =
+  match t with
+  | [] | [ _ ] -> None
+  | _leaf :: parents -> Some parents
+
+let has_attr attr_name attrs =
+  List.exists ~f:(fun a ->
+    let (str,_) = Ast_helper.Attr.as_tuple a in
+    str.Location.txt = attr_name
+  ) attrs
+
+let select_leafs pos root =
+  let branches = ref [] in
+  let rec select_child branch env node has_selected =
+    let loc = node_merlin_loc node in
+    let attrs = Browse_raw.node_attributes node in
+    if Location_aux.compare_pos pos loc = 0 &&
+       not (has_attr "merlin.hide" attrs)
+    then
+      (traverse ((env, node) :: branch); true)
+    else
+      has_selected
+  and traverse branch =
+    let env, node = leaf_node branch in
+    let attrs = Browse_raw.node_attributes node in
+    if (has_attr "merlin.focus" attrs) then (
+      branches := [];
+      let has_leaves = fold_node (select_child branch) env node false in
+      if not has_leaves then
+        branches := [branch];
+      raise Exit
+    )
+    else if not (has_attr "merlin.hide" attrs) then (
+      let has_leaves = fold_node (select_child branch) env node false in
+      if not has_leaves then
+        branches := branch :: !branches
+    )
+  in
+  (try traverse root with Exit -> ());
+  !branches
+
+let compare_locations pos l1 l2 =
+  let t2_first = +1 in
+  let t1_first = -1 in
+  match
+    Location_aux.compare_pos pos l1,
+    Location_aux.compare_pos pos l2
+  with
+  | 0, 0 ->
+    (* Cursor inside both locations: favor closer to the end *)
+    Lexing.compare_pos l1.Location.loc_end l2.Location.loc_end
+  (* Cursor inside one location: it has priority *)
+  | 0, _ -> t1_first
+  | _, 0 -> t2_first
+  (* Cursor outside locations: favor before *)
+  | n, m when n > 0 && m < 0 -> t1_first
+  | n, m when m > 0 && n < 0 -> t2_first
+  (* Cursor is after both, select the closest one *)
+  | _, _ ->
+      Lexing.compare_pos l2.Location.loc_end l1.Location.loc_end
+
+let best_node pos = function
+  | [] -> []
+  | init :: xs ->
+    let f acc x =
+      if compare_locations pos (leaf_loc acc) (leaf_loc x) <= 0
+      then acc
+      else x
+    in
+    List.fold_left ~f ~init xs
+
+let enclosing pos roots =
+  match best_node pos roots with
+  | [] -> []
+  | root -> best_node pos (select_leafs pos root)
+
+let deepest_before pos roots =
+  match enclosing pos roots with
+  | [] -> []
+  | root ->
+    let rec aux path =
+      let env0, node0 = leaf_node path in
+      let loc0 = node_merlin_loc node0 in
+      let select_candidate env node acc =
+        let loc = node_merlin_loc node in
+        if path == root ||
+           Location_aux.compare_pos pos loc = 0 ||
+           Lexing.compare_pos loc.Location.loc_end loc0.Location.loc_end = 0
+        then match acc with
+          | Some (_,loc',_) when compare_locations pos loc' loc <= 0 -> acc
+          | Some _ | None -> Some (env,loc,node)
+        else acc
+      in
+      match fold_node select_candidate env0 node0 None with
+      | None -> path
+      | Some (env, _,node) ->
+        aux ((env,node) :: path)
+    in
+    (aux root)
+
+(* Select open nodes *)
+
+let rec select_open_node =
+  function[@warning "-9"]
+  | (_, ( Structure_item ({str_desc =
+                             Tstr_open { open_expr =
+                                           { mod_desc = Tmod_ident (p, {txt = longident}) }}},
+                          _)))
+    :: ancestors ->
+    Some (p, longident, ancestors)
+  | (_, ( Signature_item ({sig_desc = Tsig_open op}, _))) :: ancestors ->
+    let (p, { Asttypes.txt = longident; }) = op.open_expr in
+    Some (p, longident, ancestors)
+  | (_, Expression { exp_desc =
+          Texp_open ({ open_expr =
+                        { mod_desc = Tmod_ident (p, {txt = longident})}}, _); _})
+    :: _ as ancestors ->
+      Some (p, longident, ancestors)
+  | (_, Pattern {pat_extra; _}) :: ancestors
+    when List.exists pat_extra
+          ~f:(function (Tpat_open _, _ ,_) -> true | _ -> false) ->
+    let (p, longident) = List.find_map pat_extra
+        ~f:(function | Tpat_open (p,{ txt = longident; },_), _ ,_ -> Some (p, longident)
+                     | _ -> None)
+    in
+    Some (p, longident, ancestors)
+  | [] -> None
+  | _ :: ancestors -> select_open_node ancestors
+
+let of_structure str =
+  let env =
+    match str.str_items with
+    | [] -> str.str_final_env
+    | item :: _ -> item.str_env
+  in
+  [env, Browse_raw.Structure str]
+
+let of_signature sg =
+  let env =
+    match sg.sig_items with
+    | [] -> sg.sig_final_env
+    | item :: _ -> item.sig_env
+  in
+  [env, Browse_raw.Signature sg]
+
+let of_typedtree = function
+  | `Implementation str -> of_structure str
+  | `Interface sg -> of_signature sg
+
+let optional_label_sugar = function
+  | Typedtree.Texp_construct (id, _, [e])
+    when id.Location.loc.Location.loc_ghost
+      && id.Location.txt = Longident.Lident "Some" ->
+    Some e
+  | _ -> None
+
+let rec is_recovered_expression e =
+  match e.Typedtree.exp_desc with
+  | (* Recovery on arbitrary expressions *)
+    Texp_tuple [_] ->
+    true
+  | (* Recovery on unbound identifier *)
+    Texp_ident (Path.Pident id, _, _)
+    when Ident.name id = "*type-error*" ->
+    true
+  | (* Recovery on desugared optional label application *)
+    Texp_construct _ as cstr
+    when is_recovered_Texp_construct cstr ->
+    true
+  | _ -> false
+
+and is_recovered_Texp_construct cstr =
+  match optional_label_sugar cstr with
+  | Some e -> is_recovered_expression e
+  | _ -> false
+
+let is_recovered = function
+  | Expression e -> is_recovered_expression e
+  | _ -> false
+
+let print_node () node =
+  Browse_raw.string_of_node node
+
+let print () t =
+  List.print (fun () (_,node) -> print_node () node) () t
diff --git a/src/kernel/mbrowse.mli b/src/kernel/mbrowse.mli
new file mode 100644
index 0000000..4dc10b5
--- /dev/null
+++ b/src/kernel/mbrowse.mli
@@ -0,0 +1,78 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+
+type node = Browse_raw.node
+type t = (Env.t * node) list
+
+val fold_node : (Env.t -> Browse_raw.node -> 'a -> 'a) ->
+                 Env.t -> Browse_raw.node -> 'a -> 'a
+val node_loc : Browse_raw.node -> Location.t
+val leaf_node : t -> Env.t * node
+val drop_leaf : t -> t option
+
+(* Navigate through tree *)
+
+(** The deepest context inside or before the node, for instance, navigating
+ * through:
+ *    foo bar (baz :: tail) <cursor>
+ * asking for node from cursor position will return context of "tail".
+ * Returns the matching node and all its ancestors or the empty list. *)
+val deepest_before : Lexing.position -> t list -> t
+
+
+val select_open_node : t -> (Path.t * Longident.t * t) option
+
+val enclosing : Lexing.position -> t list -> t
+
+val of_structure : Typedtree.structure -> t
+val of_signature : Typedtree.signature -> t
+
+val of_typedtree :
+  [ `Implementation of Typedtree.structure
+  | `Interface of Typedtree.signature ] -> t
+
+val node_of_binary_part : Env.t -> Cmt_format.binary_part -> node
+
+(** Identify nodes introduced by recovery *)
+val is_recovered_expression : Typedtree.expression -> bool
+val is_recovered : Browse_raw.node -> bool
+
+(** When an optional argument is applied with labelled syntax
+    sugar (~a:v instead of ?a:(Some v)), the frontend will have
+    wrapped it in [Some _].
+    [optional_label_sugar exp] returns [Some exp'] with the sugar
+    removed in that case. *)
+val optional_label_sugar :
+  Typedtree.expression_desc -> Typedtree.expression option
+
+(** {1 Dump} *)
+
+val print_node : unit -> node -> string
+val print : unit -> t -> string
diff --git a/src/kernel/mconfig.ml b/src/kernel/mconfig.ml
new file mode 100644
index 0000000..e542384
--- /dev/null
+++ b/src/kernel/mconfig.ml
@@ -0,0 +1,755 @@
+open Std
+
+(** {1 OCaml commandline parsing} *)
+
+let {Logger. log} = Logger.for_section "Mconfig"
+
+type ocaml = {
+  include_dirs         : string list;
+  no_std_include       : bool;
+  unsafe               : bool;
+  classic              : bool;
+  principal            : bool;
+  real_paths           : bool;
+  threads              : [ `None | `Threads | `Vmthreads ];
+  recursive_types      : bool;
+  strict_sequence      : bool;
+  applicative_functors : bool;
+  unsafe_string        : bool;
+  nopervasives         : bool;
+  strict_formats       : bool;
+  open_modules         : string list;
+  ppx                  : string with_workdir list;
+  pp                   : string with_workdir option;
+  warnings             : Warnings.state;
+}
+
+let dump_warnings st =
+  let st' = Warnings.backup () in
+  Warnings.restore st;
+  Misc.try_finally Warnings.dump
+    ~always:(fun () -> Warnings.restore st')
+
+let dump_ocaml x = `Assoc [
+    "include_dirs"         , `List (List.map ~f:Json.string x.include_dirs);
+    "no_std_include"       , `Bool x.no_std_include;
+    "unsafe"               , `Bool x.unsafe;
+    "classic"              , `Bool x.classic;
+    "principal"            , `Bool x.principal;
+    "real_paths"           , `Bool x.real_paths;
+    "recursive_types"      , `Bool x.recursive_types;
+    "strict_sequence"      , `Bool x.strict_sequence;
+    "applicative_functors" , `Bool x.applicative_functors;
+    "unsafe_string"        , `Bool x.unsafe_string;
+    "nopervasives"         , `Bool x.nopervasives;
+    "strict_formats"       , `Bool x.strict_formats;
+    "open_modules"         , Json.list Json.string x.open_modules;
+    "ppx"                  , Json.list (dump_with_workdir Json.string) x.ppx;
+    "pp"                   , Json.option (dump_with_workdir Json.string) x.pp;
+    "warnings"             , dump_warnings x.warnings;
+  ]
+
+(** Some paths can be resolved relative to a current working directory *)
+
+let cwd = ref None
+
+let unsafe_get_cwd () = match !cwd with
+  | None -> assert false
+  | Some cwd -> cwd
+
+let canonicalize_filename path =
+  Misc.canonicalize_filename ?cwd:!cwd path
+
+let marg_path f =
+  Marg.param "path" (fun path acc -> f (canonicalize_filename path) acc)
+
+let marg_commandline f =
+  Marg.param "command"
+    (fun workval acc -> f {workdir = unsafe_get_cwd (); workval} acc)
+
+(** {1 Merlin high-level settings} *)
+
+type merlin = {
+  build_path  : string list;
+  source_path : string list;
+  cmi_path    : string list;
+  cmt_path    : string list;
+  extensions  : string list;
+  suffixes    : (string * string) list;
+  stdlib      : string option;
+  reader      : string list;
+  protocol    : [`Json | `Sexp];
+  log_file    : string option;
+  log_sections : string list;
+  config_path : string option;
+
+  exclude_query_dir : bool;
+
+  flags_to_apply : string list with_workdir list;
+
+  flags_applied : string list with_workdir list;
+
+  failures : string list;
+  extension_to_reader : (string * string) list
+
+}
+
+let dump_merlin x =
+  let dump_flag_list flags =
+    dump_with_workdir (Json.list Json.string) flags
+  in
+  `Assoc [
+    "build_path"   , `List (List.map ~f:Json.string x.build_path);
+    "source_path"  , `List (List.map ~f:Json.string x.source_path);
+    "cmi_path"     , `List (List.map ~f:Json.string x.cmi_path);
+    "cmt_path"     , `List (List.map ~f:Json.string x.cmt_path);
+    "flags_applied", `List (List.map ~f:dump_flag_list x.flags_applied);
+    "extensions"   , `List (List.map ~f:Json.string x.extensions);
+    "suffixes"     , `List (
+      List.map ~f:(fun (impl,intf) -> `Assoc [
+          "impl", `String impl;
+          "intf", `String intf;
+        ]) x.suffixes
+    );
+    "stdlib"       , Json.option Json.string x.stdlib;
+    "reader"       , `List (List.map ~f:Json.string x.reader);
+    "protocol"     , (match x.protocol with
+        | `Json -> `String "json"
+        | `Sexp -> `String "sexp"
+      );
+    "log_file"     , Json.option Json.string x.log_file;
+    "log_sections" , Json.list Json.string x.log_sections;
+    "flags_to_apply"   , `List (List.map ~f:dump_flag_list x.flags_to_apply);
+
+    "failures"         , `List (List.map ~f:Json.string x.failures);
+    "assoc_suffixes"   , `List (
+      List.map ~f:(fun (suffix,reader) -> `Assoc [
+          "extension", `String suffix;
+          "reader", `String reader;
+        ]) x.extension_to_reader
+    )
+  ]
+
+type query = {
+  filename  : string;
+  directory : string;
+  printer_width : int;
+  verbosity : int;
+}
+
+let dump_query x = `Assoc [
+    "filename"  , `String x.filename;
+    "directory" , `String x.directory;
+    "printer_width", `Int x.printer_width;
+    "verbosity" , `Int x.verbosity;
+  ]
+
+type t = {
+  ocaml   : ocaml;
+  merlin  : merlin;
+  query   : query;
+}
+
+let dump x = `Assoc [
+    "ocaml"   , dump_ocaml x.ocaml;
+    "merlin"  , dump_merlin x.merlin;
+    "query"   , dump_query x.query;
+  ]
+
+let arguments_table = Hashtbl.create 67
+
+let stdlib =
+  let env =
+    try Some (Sys.getenv "OCAMLLIB")
+    with Not_found ->
+    try Some (Sys.getenv "CAMLLIB")
+    with Not_found -> None
+  in
+  fun config ->
+    match config.merlin.stdlib with
+    | Some stdlib -> stdlib
+    | None -> match env with
+      | Some stdlib -> stdlib
+      | None -> Standard_library.path
+
+let normalize_step t =
+  let merlin = t.merlin in
+  if merlin.flags_to_apply <> [] then
+    let flagss = merlin.flags_to_apply in
+    let t = {t with merlin = { merlin with
+                               flags_to_apply = [];
+                               flags_applied = flagss @ merlin.flags_applied;
+                             } }
+    in
+    let failures = ref [] in
+    let warning failure = failures := failure :: !failures in
+    let t = List.fold_left ~f:(fun t {workdir; workval} -> fst (
+        let_ref cwd (Some workdir)
+          (Marg.parse_all ~warning arguments_table [] workval t)
+      )) ~init:t flagss
+    in
+    {t with merlin = {t.merlin with failures = !failures @ t.merlin.failures}}
+  else
+    t
+
+let is_normalized t =
+  let merlin = t.merlin in
+  merlin.flags_to_apply = []
+
+let rec normalize t =
+  if is_normalized t then (
+    log ~title:"normalize" "%a" Logger.json (fun () -> dump t);
+    t
+  ) else
+    normalize (normalize_step t)
+
+let get_external_config path t =
+  let path = Misc.canonicalize_filename path in
+  let directory = Filename.dirname path in
+  match Mconfig_dot.find_project_context directory with
+  | None -> t
+  | Some (ctxt, config_path) ->
+    let dot, failures = Mconfig_dot.get_config ctxt path in
+    let merlin = t.merlin in
+    let merlin = {
+      merlin with
+      build_path = dot.build_path @ merlin.build_path;
+      source_path = dot.source_path @ merlin.source_path;
+      cmi_path = dot.cmi_path @ merlin.cmi_path;
+      cmt_path = dot.cmt_path @ merlin.cmt_path;
+      exclude_query_dir = dot.exclude_query_dir || merlin.exclude_query_dir;
+      extensions = dot.extensions @ merlin.extensions;
+      suffixes = dot.suffixes @ merlin.suffixes;
+      stdlib = (if dot.stdlib = None then merlin.stdlib else dot.stdlib);
+      reader =
+        if dot.reader = []
+        then merlin.reader
+        else dot.reader;
+      flags_to_apply = dot.flags @ merlin.flags_to_apply;
+      failures = failures @ merlin.failures;
+      config_path = Some config_path;
+    } in
+    normalize { t with merlin }
+
+let merlin_flags = [
+  (
+    "-build-path",
+    marg_path (fun dir merlin ->
+        {merlin with build_path = dir :: merlin.build_path}),
+    "<dir> Add <dir> to merlin build path"
+  );
+  (
+    "-source-path",
+    marg_path (fun dir merlin ->
+        {merlin with source_path = dir :: merlin.source_path}),
+    "<dir> Add <dir> to merlin source path"
+  );
+  (
+    "-cmi-path",
+    marg_path (fun dir merlin ->
+        {merlin with cmi_path = dir :: merlin.cmi_path}),
+    "<dir> Add <dir> to merlin cmi path"
+  );
+  (
+    "-cmt-path",
+    marg_path (fun dir merlin ->
+        {merlin with cmt_path = dir :: merlin.cmt_path}),
+    "<dir> Add <dir> to merlin cmt path"
+  );
+  (
+    "-reader",
+    Marg.param "command" (fun reader merlin ->
+        {merlin with reader = Shell.split_command reader }),
+    "<command> Use <command> as a merlin reader"
+  );
+  (
+    "-assocsuffix",
+    Marg.param "suffix:reader"
+      (fun assoc_pair merlin ->
+         match Misc.rev_string_split ~on:':' assoc_pair with
+         | [reader;suffix] ->
+              {merlin with
+               extension_to_reader = (suffix,reader)::merlin.extension_to_reader}
+         | _ -> merlin
+      ),
+    "Associate suffix with reader"
+  );
+  (
+    "-addsuffix",
+    Marg.param "implementation Suffix, interface Suffix"
+    (fun suffix_pair merlin ->
+      match Misc.rev_string_split ~on:':' suffix_pair with
+      | [intf;impl] ->
+        {merlin with suffixes = (impl,intf)::merlin.suffixes}
+      | _ -> merlin
+    ),
+    "Add a suffix implementation,interface pair"
+  );
+  (
+    "-extension",
+    Marg.param "extension" (fun extension merlin ->
+        match Extension.lookup extension with
+        | None -> invalid_arg "Unknown extension"
+        | Some _ ->
+          {merlin with extensions = extension :: merlin.extensions}),
+    "<extension> Load merlin syntax extension"
+  );
+  (
+    "-flags",
+    Marg.param "string" (fun flags merlin ->
+        let flags =
+          { workdir = unsafe_get_cwd (); workval = Shell.split_command flags }
+        in
+        {merlin with flags_to_apply = flags :: merlin.flags_to_apply}),
+    "<quoted flags> Unescape argument and interpret it as more flags"
+  );
+  (
+    "-protocol",
+    Marg.param "protocol" (fun prot merlin ->
+        match prot with
+        | "json" -> {merlin with protocol = `Json}
+        | "sexp" -> {merlin with protocol = `Sexp}
+        | _ -> invalid_arg "Valid protocols are 'json' and 'sexp'";
+      ),
+    "<protocol> Select frontend protocol ('json' or 'sexp')"
+  );
+  (
+    "-log-file",
+    Marg.param "file" (fun file merlin -> {merlin with log_file = Some file}),
+    "<file> Log messages to specified file ('' for disabling, '-' for stderr)"
+  );
+  (
+    "-log-section",
+    Marg.param "file" (fun section merlin ->
+        let sections = String.split_on_char_ ',' section in
+        {merlin with log_sections = sections @ merlin.log_sections}),
+    "<section,...> Only log specific sections (separated by comma)"
+  );
+  (
+    "-ocamllib-path",
+    marg_path (fun path merlin -> {merlin with stdlib = Some path}),
+    "<path> Change path of ocaml standard library"
+  );
+  (
+    (* Legacy support for janestreet. Ignored. To be removed soon. *)
+    "-attributes-allowed",
+    Marg.unit_ignore,
+    " DEPRECATED"
+  );
+]
+
+let query_flags = [
+  (
+    "-verbosity",
+    Marg.param "integer" (fun verbosity query ->
+        let verbosity =
+          try int_of_string verbosity
+          with _ -> invalid_arg "argument should be an integer"
+        in
+        {query with verbosity}),
+    "<integer> Verbosity determines the number of expansions of aliases in answers"
+  );
+  (
+    "-printer-width",
+    Marg.param "integer" (fun width query ->
+        let printer_width =
+          try int_of_string width
+          with _ -> invalid_arg "argument should be an integer"
+        in
+        {query with printer_width}),
+    "<integer> Optimal width for formatting types, signatures, etc"
+  )
+]
+
+let ocaml_ignored_flags = [
+  "-a"; "-absname"; "-alias-deps"; "-annot"; "-app-funct"; "-bin-annot";
+  "-c"; "-compact"; "-compat-32"; "-config"; "-custom"; "-dalloc";
+  "-dclambda"; "-dcmm"; "-dcombine"; "-dcse"; "-dflambda";
+  "-dflambda-no-invariants"; "-dflambda-verbose"; "-dinstr"; "-dinterf";
+  "-dlambda"; "-dlinear"; "-dlive"; "-dparsetree"; "-dprefer";
+  "-drawclambda"; "-drawflambda"; "-drawlambda"; "-dreload"; "-dscheduling";
+  "-dsel"; "-dsource"; "-dspill"; "-dsplit"; "-dstartup"; "-dtimings";
+  "-dtypedtree"; "-dtypes"; "-dump-pass"; "-fno-PIC"; "-fPIC"; "-g"; "-i";
+  "-inlining-report"; "-keep-docs"; "-keep-docs"; "-keep-locs"; "-linkall";
+  "-make_runtime"; "-make-runtime"; "-modern"; "-no-alias-deps"; "-noassert";
+  "-noautolink"; "-no-check-prims"; "-nodynlink"; "-no-float-const-prop";
+  "-no-keep-locs"; "-no-principal"; "-no-rectypes"; "-no-strict-formats";
+  "-no-strict-sequence"; "-no-unbox-free-vars-of-clos";
+  "-no-unbox-specialised-args"; "-O2"; "-O3"; "-Oclassic"; "-opaque";
+  "-output-complete-obj"; "-output-obj"; "-p"; "-pack";
+  "-remove-unused-arguments"; "-S"; "-shared"; "-unbox-closures"; "-v";
+  "-verbose"; "-where";
+]
+
+let ocaml_ignored_parametrized_flags = [
+  "-cc"; "-cclib"; "-ccopt"; "-color"; "-dflambda-let"; "-dllib"; "-dllpath";
+  "-for-pack"; "-impl"; "-inline-alloc-cost"; "-inline-branch-cost";
+  "-inline-branch-factor"; "-inline-call-cost"; "-inline-indirect-cost";
+  "-inline-lifting-benefit"; "-inline-max-depth"; "-inline-max-unroll";
+  "-inline"; "-inline-prim-cost"; "-inline-toplevel"; "-intf";
+  "-intf_suffix"; "-intf-suffix"; "-o"; "-rounds"; "-runtime-variant";
+  "-unbox-closures-factor"; "-use-prims"; "-use_runtime"; "-use-runtime";
+  "-error-style";
+]
+
+let ocaml_warnings_spec ~error =
+  Marg.param "warning specification" (fun spec ocaml ->
+      let b' = Warnings.backup () in
+      Warnings.restore ocaml.warnings;
+      Misc.try_finally (fun () ->
+          ignore @@ Warnings.parse_options error spec;
+          { ocaml with warnings = Warnings.backup () })
+        ~always:(fun () -> Warnings.restore b'))
+
+let ocaml_alert_spec =
+  Marg.param "alert specification" (fun spec ocaml ->
+      let b' = Warnings.backup () in
+      Warnings.restore ocaml.warnings;
+      Misc.try_finally (fun () ->
+          Warnings.parse_alert_option spec;
+          { ocaml with warnings = Warnings.backup () })
+        ~always:(fun () -> Warnings.restore b'))
+
+let ocaml_flags = [
+  (
+    "-I",
+    marg_path (fun dir ocaml ->
+        {ocaml with include_dirs = dir :: ocaml.include_dirs}),
+    "<dir> Add <dir> to the list of include directories"
+  );
+  (
+    "-nostdlib",
+    Marg.unit (fun ocaml -> {ocaml with no_std_include = true}),
+    " Do not add default directory to the list of include directories"
+  );
+  (
+    "-unsafe",
+    Marg.unit (fun ocaml -> {ocaml with unsafe = true}),
+    " Do not compile bounds checking on array and string access"
+  );
+  (
+    "-labels",
+    Marg.unit (fun ocaml -> {ocaml with classic = false}),
+    " Use commuting label mode"
+  );
+  (
+    "-nolabels",
+    Marg.unit (fun ocaml -> {ocaml with classic = true}),
+    " Ignore non-optional labels in types"
+  );
+  (
+    "-principal",
+    Marg.unit (fun ocaml -> {ocaml with principal = true}),
+    " Check principality of type inference"
+  );
+  (
+    "-real-paths",
+    Marg.unit (fun ocaml -> {ocaml with real_paths = true}),
+    " Display real paths in types rather than short ones"
+  );
+  (
+    "-short-paths",
+    Marg.unit (fun ocaml -> {ocaml with real_paths = false}),
+    " Shorten paths in types"
+  );
+  (
+    "-rectypes",
+    Marg.unit (fun ocaml -> {ocaml with recursive_types = true}),
+    " Allow arbitrary recursive types"
+  );
+  (
+    "-strict-sequence",
+    Marg.unit (fun ocaml -> {ocaml with strict_sequence = true}),
+    " Left-hand part of a sequence must have type unit"
+  );
+  (
+    "-no-app-funct",
+    Marg.unit (fun ocaml -> {ocaml with applicative_functors = false}),
+    " Deactivate applicative functors"
+  );
+  (
+    "-thread",
+    Marg.unit (fun ocaml -> {ocaml with threads = `Threads}),
+    " Add support for system threads library"
+  );
+  (
+    "-vmthread",
+    Marg.unit (fun ocaml -> {ocaml with threads = `None}),
+    " Add support for VM-scheduled threads library"
+  );
+  (
+    "-unsafe-string",
+    Marg.unit (fun ocaml -> {ocaml with unsafe_string = true}),
+    Printf.sprintf
+      " Make strings mutable (default: %B)"
+      (not Config.safe_string)
+  );
+  (
+    "-safe-string",
+    Marg.unit (fun ocaml -> {ocaml with unsafe_string = false}),
+    Printf.sprintf
+      " Make strings immutable (default: %B)"
+      Config.safe_string
+  );
+  (
+    "-nopervasives",
+    Marg.unit (fun ocaml -> {ocaml with nopervasives = true}),
+    " Don't open Pervasives module (advanced)"
+  );
+  (
+    "-strict-formats",
+    Marg.unit (fun ocaml -> {ocaml with strict_formats = true}),
+    " Reject invalid formats accepted by legacy implementations"
+  );
+  (
+    "-open",
+    Marg.param "module" (fun md ocaml ->
+        {ocaml with open_modules = md :: ocaml.open_modules}),
+    "<module>  Opens the module <module> before typing"
+  );
+  (
+    "-ppx",
+    marg_commandline (fun command ocaml ->
+        {ocaml with ppx = command :: ocaml.ppx}),
+    "<command> Pipe abstract syntax trees through preprocessor <command>"
+  );
+  (
+    "-pp",
+    marg_commandline (fun pp ocaml -> {ocaml with pp = Some pp}),
+    "<command> Pipe sources through preprocessor <command>"
+  );
+  ( "-w",
+    ocaml_warnings_spec ~error:false,
+    Printf.sprintf
+      "<list>  Enable or disable warnings according to <list>:\n\
+      \        +<spec>   enable warnings in <spec>\n\
+      \        -<spec>   disable warnings in <spec>\n\
+      \        @<spec>   enable warnings in <spec> and treat them as errors\n\
+      \     <spec> can be:\n\
+      \        <num>             a single warning number\n\
+      \        <num1>..<num2>    a range of consecutive warning numbers\n\
+      \        <letter>          a predefined set\n\
+      \     default setting is %S"
+      Warnings.defaults_w
+  );
+  ( "-warn-error",
+    ocaml_warnings_spec ~error:true,
+    Printf.sprintf
+      "<list> Enable or disable error status for warnings according\n\
+      \     to <list>.  See option -w for the syntax of <list>.\n\
+      \     Default setting is %S"
+      Warnings.defaults_warn_error
+  );
+  ( "-alert",
+    ocaml_alert_spec,
+    Printf.sprintf
+      "<list>  Enable or disable alerts according to <list>:\n\
+      \        +<alertname>  enable alert <alertname>\n\
+      \        -<alertname>  disable alert <alertname>\n\
+      \        ++<alertname> treat <alertname> as fatal error\n\
+      \        --<alertname> treat <alertname> as non-fatal\n\
+      \        @<alertname>  enable <alertname> and treat it as fatal error\n\
+      \    <alertname> can be 'all' to refer to all alert names"
+  );
+]
+
+(** {1 Main configuration} *)
+
+let initial = {
+  ocaml = {
+    include_dirs         = [];
+    no_std_include       = false;
+    unsafe               = false;
+    classic              = false;
+    principal            = false;
+    real_paths           = true;
+    threads              = `None;
+    recursive_types      = false;
+    strict_sequence      = false;
+    applicative_functors = true;
+    unsafe_string        = not Config.safe_string;
+    nopervasives         = false;
+    strict_formats       = false;
+    open_modules         = [];
+    ppx                  = [];
+    pp                   = None;
+    warnings             = Warnings.backup ();
+  };
+  merlin = {
+    build_path  = [];
+    source_path = [];
+    cmi_path    = [];
+    cmt_path    = [];
+    extensions  = [];
+    suffixes    = [(".ml", ".mli"); (".re", ".rei")];
+    stdlib      = None;
+    reader      = [];
+    protocol    = `Json;
+    log_file    = None;
+    log_sections = [];
+    config_path = None;
+
+    exclude_query_dir = false;
+
+    flags_to_apply    = [];
+    flags_applied     = [];
+
+    failures = [];
+    extension_to_reader = [(".re","reason");(".rei","reason")];
+  };
+  query = {
+    filename = "*buffer*";
+    directory = Sys.getcwd ();
+    verbosity = 0;
+    printer_width = 0;
+  }
+}
+
+let parse_arguments ~wd ~warning local_spec args t local =
+  let_ref cwd (Some wd) @@ fun () ->
+  Marg.parse_all ~warning arguments_table local_spec args t local
+
+let global_flags = [
+  (
+    "-filename",
+    marg_path (fun path t ->
+        let query = t.query in
+        let path = Misc.canonicalize_filename path in
+        let filename = Filename.basename path in
+        let directory = Filename.dirname path in
+        let t = {t with query = {query with filename; directory}} in
+        Logger.with_log_file t.merlin.log_file
+          ~sections:t.merlin.log_sections @@ fun () ->
+        get_external_config path t),
+    "<path> Path of the buffer; \
+     extension determines the kind of file (interface or implementation), \
+     basename is used as name of the module being definer, \
+     directory is used to resolve other relative paths"
+  );
+  (
+    "-dot-merlin",
+    marg_path (fun dotmerlin t -> get_external_config dotmerlin t),
+    "<path> Load <path> as a .merlin; if it is a directory, \
+     look for .merlin here or in a parent directory"
+  );
+]
+
+let () =
+  List.iter ~f:(fun name -> Hashtbl.add arguments_table name Marg.unit_ignore)
+    ocaml_ignored_flags;
+  List.iter ~f:(fun name -> Hashtbl.add arguments_table name Marg.param_ignore)
+    ocaml_ignored_parametrized_flags;
+  let lens prj upd flag : _ Marg.t = fun args a ->
+    let cwd' = match !cwd with
+      | None when a.query.directory <> "" -> Some a.query.directory
+      | cwd -> cwd
+    in
+    let_ref cwd cwd' @@ fun () ->
+    let args, b = flag args (prj a) in
+    args, (upd a b)
+  in
+  let add prj upd (name,flag,_doc) =
+    assert (not (Hashtbl.mem arguments_table name));
+    Hashtbl.add arguments_table name (lens prj upd flag)
+  in
+  List.iter
+    ~f:(add (fun x -> x.ocaml) (fun x ocaml -> {x with ocaml}))
+    ocaml_flags;
+  List.iter
+    ~f:(add (fun x -> x.merlin) (fun x merlin -> {x with merlin}))
+    merlin_flags;
+  List.iter
+    ~f:(add (fun x -> x.query) (fun x query -> {x with query}))
+    query_flags;
+  List.iter
+    ~f:(add (fun x -> x) (fun _ x -> x))
+    global_flags
+
+let flags_for_completion () =
+  List.sort ~cmp:compare (
+    "-dot-merlin" :: "-reader" ::
+    List.map ~f:(fun (x,_,_) -> x) ocaml_flags
+  )
+
+let document_arguments oc =
+  let print_doc flags =
+    List.iter ~f:(fun (name,_flag,doc) -> Printf.fprintf oc "  %s\t%s\n" name doc)
+      flags
+  in
+  output_string oc "Flags affecting Merlin:\n";
+  print_doc merlin_flags;
+  print_doc query_flags;
+  output_string oc "Flags affecting OCaml frontend:\n";
+  print_doc ocaml_flags;
+  output_string oc "Flags accepted by ocamlc and ocamlopt but not affecting merlin will be ignored.\n"
+
+let source_path config =
+  let stdlib = if config.ocaml.no_std_include then [] else [stdlib config] in
+  List.concat
+    [[config.query.directory];
+     stdlib;
+     config.merlin.source_path]
+  |> List.filter_dup
+
+let build_path config = (
+  let dirs =
+    match config.ocaml.threads with
+    | `None -> config.ocaml.include_dirs
+    | `Threads -> "+threads" :: config.ocaml.include_dirs
+    | `Vmthreads -> "+vmthreads" :: config.ocaml.include_dirs
+  in
+  let dirs =
+    config.merlin.cmi_path @
+    config.merlin.build_path @
+    dirs
+  in
+  let stdlib = stdlib config in
+  let exp_dirs =
+    List.map ~f:(Misc.expand_directory stdlib) dirs
+  in
+  let stdlib = if config.ocaml.no_std_include then [] else [stdlib] in
+  let dirs = List.rev_append exp_dirs stdlib in
+  let result =
+    if config.merlin.exclude_query_dir
+    then dirs
+    else config.query.directory :: dirs
+  in
+  let result' = List.filter_dup result in
+  log ~title:"build_path" "%d items in path, %d after deduplication"
+    (List.length result) (List.length result');
+  result'
+)
+
+let cmt_path config = (
+  let dirs =
+    match config.ocaml.threads with
+    | `None -> config.ocaml.include_dirs
+    | `Threads -> "+threads" :: config.ocaml.include_dirs
+    | `Vmthreads -> "+vmthreads" :: config.ocaml.include_dirs
+  in
+  let dirs =
+    config.merlin.cmt_path @
+    config.merlin.build_path @
+    dirs
+  in
+  let stdlib = stdlib config in
+  let exp_dirs =
+    List.map ~f:(Misc.expand_directory stdlib) dirs
+  in
+  let stdlib = if config.ocaml.no_std_include then [] else [stdlib] in
+  config.query.directory :: List.rev_append exp_dirs stdlib
+)
+
+let global_modules ?(include_current=false) config = (
+  let modules = Misc.modules_in_path ~ext:".cmi" (build_path config) in
+  if include_current then modules
+  else match config.query.filename with
+    | "" -> modules
+    | filename -> List.remove (Misc.unitname filename) modules
+)
+
+(** {1 Accessors for other information} *)
+
+let filename t = t.query.filename
+
+let unitname t = Misc.unitname t.query.filename
diff --git a/src/kernel/mconfig.mli b/src/kernel/mconfig.mli
new file mode 100644
index 0000000..7f82ba7
--- /dev/null
+++ b/src/kernel/mconfig.mli
@@ -0,0 +1,106 @@
+open Std
+
+(** {1 OCaml commandline parsing} *)
+
+type ocaml = {
+  include_dirs         : string list;
+  no_std_include       : bool;
+  unsafe               : bool;
+  classic              : bool;
+  principal            : bool;
+  real_paths           : bool;
+  threads              : [ `None | `Threads | `Vmthreads ];
+  recursive_types      : bool;
+  strict_sequence      : bool;
+  applicative_functors : bool;
+  unsafe_string        : bool;
+  nopervasives         : bool;
+  strict_formats       : bool;
+  open_modules         : string list;
+  ppx                  : string with_workdir list;
+  pp                   : string with_workdir option;
+  warnings             : Warnings.state;
+}
+
+val dump_ocaml : ocaml -> json
+
+
+(** {1 Merlin high-level settings} *)
+
+type merlin = {
+  build_path  : string list;
+  source_path : string list;
+  cmi_path    : string list;
+  cmt_path    : string list;
+  extensions  : string list;
+  suffixes    : (string * string) list;
+  stdlib      : string option;
+  reader      : string list;
+  protocol    : [`Json | `Sexp];
+  log_file    : string option;
+  log_sections: string list;
+  config_path : string option;
+
+  exclude_query_dir : bool;
+
+  flags_to_apply : string list with_workdir list;
+
+  flags_applied : string list with_workdir list;
+
+  failures : string list;
+  extension_to_reader : (string * string) list
+}
+
+val dump_merlin : merlin -> json
+
+(** {1 Some flags affecting queries} *)
+
+type query = {
+  filename  : string;
+  directory : string;
+  printer_width : int;
+  verbosity : int;
+}
+
+(** {1 Main configuration} *)
+
+type t = {
+  ocaml   : ocaml;
+  merlin  : merlin;
+  query   : query;
+}
+
+val initial : t
+
+val dump : t -> json
+
+val get_external_config : string -> t -> t
+
+val normalize : t -> t
+
+val is_normalized : t -> bool
+
+val parse_arguments :
+  wd:string ->
+  warning:(string -> unit) -> 'a Marg.spec list -> string list ->
+  t -> 'a -> t * 'a
+
+val flags_for_completion : unit -> string list
+
+val document_arguments : out_channel -> unit
+
+(** {1 Computing project paths} *)
+
+val source_path : t -> string list
+
+val build_path : t -> string list
+
+val cmt_path : t -> string list
+
+val global_modules : ?include_current:bool -> t -> string list
+
+(** {1 Accessors for other information} *)
+
+val filename : t -> string
+
+val unitname : t -> string
diff --git a/src/kernel/mconfig_dot.ml b/src/kernel/mconfig_dot.ml
new file mode 100644
index 0000000..9d31d8c
--- /dev/null
+++ b/src/kernel/mconfig_dot.ml
@@ -0,0 +1,405 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+
+let {Logger. log} = Logger.for_section "Mconfig_dot"
+
+type directive = Dot_protocol.directive
+
+type config = {
+  build_path   : string list;
+  source_path  : string list;
+  cmi_path     : string list;
+  cmt_path     : string list;
+  flags        : string list with_workdir list;
+  extensions   : string list;
+  suffixes     : (string * string) list;
+  stdlib       : string option;
+  reader       : string list;
+  exclude_query_dir : bool;
+}
+
+let empty_config = {
+  build_path   = [];
+  source_path  = [];
+  cmi_path     = [];
+  cmt_path     = [];
+  extensions   = [];
+  suffixes     = [];
+  flags        = [];
+  stdlib       = None;
+  reader       = [];
+  exclude_query_dir = false;
+}
+
+let white_regexp = Str.regexp "[ \t]+"
+
+(* Parses suffixes pairs that were supplied as whitespace separated pairs
+   designating implementation/interface suffixes. These would be supplied in
+   the .merlin file as:
+
+   SUFFIX .sfx .sfxi   *)
+let parse_suffix str =
+  let trimmed = String.trim str in
+  let split_on_white = Str.split white_regexp trimmed in
+  if List.length split_on_white != 2 then []
+  else
+    let (first, second) = (List.nth split_on_white 0, List.nth split_on_white 1) in
+    if String.get first 0 != '.' || String.get second 0 != '.' then []
+    else [(first, second)]
+
+(* This module contains invariants around processes that need to be preserved *)
+module Configurator : sig
+  type t =
+    | Dot_merlin
+    | Dune
+
+  val of_string_opt : string -> t option
+  val to_string : t -> string
+
+  module Process : sig
+    type nonrec t = {
+      kind: t;
+      initial_cwd: string;
+      stdin: out_channel;
+      stdout: in_channel;
+      stderr: in_channel
+    }
+  end
+
+  (* [Some] if the process is live, [None] if the process died immediately after
+     spawning.  The check is a bit fragile, but is principally there to check if
+     `dot-merlin-reader` isn't installed or isn't on the PATH; it only needs to
+     be best-effort besides that. *)
+  val get_process : dir:string -> t -> Process.t option
+end = struct
+  type t =
+    | Dot_merlin
+    | Dune
+
+  let of_string_opt = function
+    | ".merlin" ->
+      Some Dot_merlin
+    | "dune-project" | "dune-workspace" ->
+      Some Dune
+    | _ -> None
+
+  let to_string = function
+    | Dot_merlin -> "dot-merlin-reader"
+    | Dune -> "dune"
+
+  module Process = struct
+    type nonrec t = {
+      kind : t;
+      initial_cwd : string;
+      stdin: out_channel;
+      stdout: in_channel;
+      stderr: in_channel;
+    }
+
+    module With_pid = struct
+      type nonrec t = {
+        pid: int;
+        process: t
+      }
+    end
+
+    let start ~dir cfg =
+      let prog, args =
+        match cfg with
+        | Dot_merlin ->
+          let prog = "dot-merlin-reader" in
+          prog, [| prog |]
+        | Dune ->
+          let prog = "dune" in
+          prog, [| prog; "ocaml-merlin"; "--no-print-directory" |]
+      in
+      let cwd = Sys.getcwd () in
+      let stdin_r, stdin_w = Unix.pipe () in
+      let stdout_r, stdout_w = Unix.pipe () in
+      let stderr_r, stderr_w = Unix.pipe () in
+      Unix.chdir dir;
+      Unix.set_close_on_exec stdin_w;
+      (* Set the windows equivalent of close on exec for and stdin stderr
+
+         Most processes spawned by merlin are supposed to inherit stderr to
+         output their debug information. This is fine because these processes
+         are short-lived.
+         However the dune helper we are about to spawn is long-lived, which can
+         cause issues with inherited descriptors because it will outlive
+         merlin's client process.
+         This is not an issue under Unix because file descriptors are replaced
+         (stdin/out/err are new), but under Windows, handle can accumulate.
+         This makes emacs block, synchronously waiting for the inherited (but
+         unused) stdout/stderr to be closed.
+
+         Os_ipc.merlin_dont_inherit_stdio is a no-op under Unix.
+      *)
+      Os_ipc.merlin_dont_inherit_stdio true;
+      log ~title:"get_config" "Starting %s configuration provider from dir %s."
+        (to_string cfg)
+        dir;
+      let pid = Unix.create_process prog args stdin_r stdout_w stderr_w in
+      Os_ipc.merlin_dont_inherit_stdio false;
+      Unix.chdir cwd;
+      Unix.close stdin_r;
+      Unix.close stdout_w;
+      Unix.close stderr_w;
+      let stdin = Unix.out_channel_of_descr stdin_w in
+      let stdout = Unix.in_channel_of_descr stdout_r in
+      let stderr = Unix.in_channel_of_descr stderr_r in
+      let initial_cwd =  Misc.canonicalize_filename dir in
+      With_pid.{
+        pid;
+        process = { kind = cfg; initial_cwd; stdin; stdout; stderr }
+      }
+  end
+
+  (* Invariant: Every PID in this hashtable can be waited on.  This means it's
+     either running or hasn't been waited on yet.  To ensure this invariant is
+     preserved, we don't expose the PIDs outside of the [Configurator]
+     module. *)
+  let running_processes : (string * t, Process.With_pid.t) Hashtbl.t =
+    Hashtbl.create 0
+
+  let get_process_with_pid ~dir configurator =
+    try
+      let p = Hashtbl.find running_processes (dir, configurator) in
+      let i, _ = Unix.waitpid [ WNOHANG ] p.pid in
+      if i = 0 then
+        p
+      else
+        let p = Process.start ~dir configurator in
+        Hashtbl.replace running_processes (dir, configurator) p;
+        p
+    with Not_found ->
+      let p = Process.start ~dir configurator in
+      Hashtbl.add running_processes (dir, configurator) p;
+      p
+
+  let get_process ~dir configurator =
+    let p = get_process_with_pid ~dir configurator in
+    match Unix.waitpid [ WNOHANG ] p.pid with
+    | 0, _ -> Some p.process
+    | _    -> begin
+      Hashtbl.remove running_processes (dir, configurator);
+      None
+    end
+end
+
+let prepend_config ~dir:cwd configurator (directives : directive list) config =
+  List.fold_left ~init:(config, []) ~f:(fun (config, errors) ->
+    function
+    | `B path -> {config with build_path = path :: config.build_path}, errors
+    | `S path -> {config with source_path = path :: config.source_path}, errors
+    | `CMI path -> {config with cmi_path = path :: config.cmi_path}, errors
+    | `CMT path -> {config with cmt_path = path :: config.cmt_path}, errors
+    | `EXT exts ->
+      {config with extensions = exts @ config.extensions}, errors
+    | `SUFFIX suffix ->
+      {config with suffixes = (parse_suffix suffix) @ config.suffixes}, errors
+    | `FLG flags ->
+      let flags = {workdir = cwd; workval = flags} in
+      {config with flags = flags :: config.flags}, errors
+    | `STDLIB path ->
+      {config with stdlib = Some path}, errors
+    | `READER reader ->
+      {config with reader}, errors
+    | `EXCLUDE_QUERY_DIR ->
+      {config with exclude_query_dir = true}, errors
+    | `ERROR_MSG str ->
+      config, str :: errors
+    | `UNKNOWN_TAG _ when configurator = Configurator.Dune ->
+      (* For easier forward compatibility we ignore unknown configuration tags
+         when they are provided by dune *)
+      config, errors
+    | `UNKNOWN_TAG tag  ->
+      let error =  Printf.sprintf "Unknown configuration tag \"%s\"" tag in
+      config, error :: errors
+  ) directives
+
+let postprocess_config config =
+  let clean list = List.rev (List.filter_dup list) in
+  {
+    build_path   = clean config.build_path;
+    source_path  = clean config.source_path;
+    cmi_path     = clean config.cmi_path;
+    cmt_path     = clean config.cmt_path;
+    extensions   = clean config.extensions;
+    suffixes     = clean config.suffixes;
+    flags        = clean config.flags;
+    stdlib      = config.stdlib;
+    reader      = config.reader;
+    exclude_query_dir = config.exclude_query_dir;
+  }
+
+type context = {
+  workdir: string;
+  configurator: Configurator.t;
+  process_dir: string;
+}
+
+exception Process_exited
+exception End_of_input
+
+let get_config { workdir; process_dir; configurator } path_abs =
+  let log_query path =
+    log
+      ~title:"get_config"
+      "Querying %s (inital cwd: %s) for file: %s.\nWorkdir: %s"
+      (Configurator.to_string configurator)
+      process_dir
+      path
+      workdir
+  in
+  let query path (p : Configurator.Process.t) =
+    log_query path;
+    Dot_protocol.Commands.send_file
+      ~out_channel:p.stdin
+      path;
+    flush p.stdin;
+    Dot_protocol.read ~in_channel:p.stdout
+  in
+  try
+    let p =
+      match Configurator.get_process ~dir:process_dir configurator with
+      | Some p -> p
+      | None -> raise Process_exited
+    in
+    (* Both [p.initial_cwd] and [path_abs] have gone through
+       [canonicalize_filename] *)
+    let path_rel =
+      String.chop_prefix ~prefix:p.initial_cwd path_abs
+      |> Option.map ~f:(fun path ->
+        (* We need to remove the leading path separator after chopping.
+           There is one case where no separator is left: when [initial_cwd]
+           was the root of the filesystem *)
+        if String.length path > 0 && path.[0] = Filename.dir_sep.[0] then
+          String.drop 1 path
+        else path)
+    in
+
+    let path =
+      match p.kind, path_rel with
+      | Dune, Some path_rel -> path_rel
+      | _, _ -> path_abs
+    in
+
+    (* Starting with Dune 2.8.3 relative paths are preferred. However to maintain
+       compatibility with 2.8 <= Dune <= 2.8.2  we always retry with an absolute
+       path if using a relative one failed *)
+    let answer =
+      match query path p with
+      | Ok ([`ERROR_MSG _]) when p.kind = Dune ->
+        query path_abs p
+      | answer -> answer
+    in
+
+    match answer with
+    | Ok directives ->
+      let cfg, failures =
+        prepend_config ~dir:workdir configurator directives empty_config
+      in
+      postprocess_config cfg, failures
+    | Error (Dot_protocol.Unexpected_output msg) -> empty_config, [ msg ]
+    | Error (Dot_protocol.Csexp_parse_error _) -> raise End_of_input
+  with
+    | Process_exited ->
+      (* This can happen
+      - If `dot-merlin-reader` is not installed and the project use `.merlin`
+        files
+      - There was a bug in the external reader causing a crash *)
+      let error = Printf.sprintf
+        "A problem occurred with merlin external configuration reader. %s If \
+         the problem persists, please file an issue on Merlin's tracker."
+        (match configurator with
+        | Dot_merlin -> "Check that `dot-merlin-reader` is installed."
+        | Dune -> "Check that `dune` is installed and up-to-date.")
+      in
+      empty_config, [ error ]
+    | End_of_input ->
+      (* This can happen
+        - if a project using old-dune has not been built and Merlin wrongly tries to
+          start `new-dune ocaml-merlin` in the absence of `.merlin` files
+        - the process stopped in the middle of its answer (which is very unlikely) *)
+      let error = Printf.sprintf
+        "Merlin could not load its configuration from the external reader. %s"
+        (match configurator with
+        | Dot_merlin -> "If the problem persists, please file an issue on \
+          Merlin's tracker."
+        | Dune -> "Building your project with `dune` might solve this issue.")
+      in
+      empty_config, [ error ]
+
+let find_project_context start_dir =
+  (* The workdir is the first directory we find which contains a [dune] file.
+    We need to keep track of this folder because [dune ocaml-merlin] might be
+    started from a folder that is a parent of the [workdir]. Thus we cannot
+    always use that starting folder as the workdir.  *)
+  let map_workdir dir = function
+    | Some dir -> Some dir
+    | None ->
+      let fnames = List.map ~f:(Filename.concat dir) ["dune"; "dune-file"] in
+      if List.exists ~f:(fun fname ->
+        Sys.file_exists fname && not (Sys.is_directory fname)) fnames
+      then Some dir else None
+  in
+
+  let rec loop workdir dir =
+    try
+      Some (
+        List.find_map [
+            ".merlin"; "dune-project"; "dune-workspace"
+          ]
+          ~f:(fun f ->
+            let fname = Filename.concat dir f in
+            if Sys.file_exists fname && not (Sys.is_directory fname)
+            then
+              (* When starting [dot-merlin-reader] from [dir]
+                the workdir is always [dir] *)
+              let workdir = if f = ".merlin" then None else workdir in
+              let workdir = Option.value ~default:dir workdir in
+              Some ({
+                workdir;
+                process_dir = dir;
+                configurator = Option.get (Configurator.of_string_opt f)
+              }, fname)
+            else None
+          )
+    )
+    with Not_found ->
+      let parent = Filename.dirname dir in
+      if parent <> dir
+      then
+        (* Was this directory the workdir ? *)
+        let workdir = map_workdir dir workdir in
+        loop workdir parent
+      else None
+  in
+  loop None start_dir
diff --git a/src/kernel/mconfig_dot.mli b/src/kernel/mconfig_dot.mli
new file mode 100644
index 0000000..03006b3
--- /dev/null
+++ b/src/kernel/mconfig_dot.mli
@@ -0,0 +1,60 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+
+type config = {
+  build_path   : string list;
+  source_path  : string list;
+  cmi_path     : string list;
+  cmt_path     : string list;
+  flags        : string list with_workdir list;
+  extensions   : string list;
+  suffixes     : (string * string) list;
+  stdlib       : string option;
+  reader       : string list;
+  exclude_query_dir : bool;
+}
+
+type context
+
+val get_config : context -> string -> config * string list
+
+val find_project_context : string -> (context * string) option
+(** [find_project_config dir] searches for a "project configuration file" in dir
+    and its parent directories. Stopping on the first one it finds and returning
+    a configuration context along with the path to the configuration file,
+    returning None otherwise (if '/' was reached without finding such a file).
+
+    A project configuration files is one of:
+    - .merlin
+    - dune-project
+    - dune-workspace
+
+    They are detected in that order. [dune] and [jbuild] file do not need to be taken into account because any project using a recent version of dune should have a dune-project file which is even auto-generated when it is missing. And only recent versions of dune will stop writing .merlin files.
+*)
diff --git a/src/kernel/mocaml.ml b/src/kernel/mocaml.ml
new file mode 100644
index 0000000..6b4cd38
--- /dev/null
+++ b/src/kernel/mocaml.ml
@@ -0,0 +1,115 @@
+open Std
+open Local_store
+
+(* Instance of environment cache & btype unification log  *)
+
+type typer_state = Local_store.store
+
+let current_state = s_ref None
+
+let new_state () =
+  let store = Local_store.fresh () in
+  Local_store.with_store store (fun () -> current_state := Some store);
+  store
+
+let with_state state f =
+  if Local_store.is_bound () then
+    failwith "Mocaml.with_state: another instance is already in use";
+  match Local_store.with_store state f with
+  | r -> Cmt_format.clear (); r
+  | exception exn -> Cmt_format.clear (); reraise exn
+
+let is_current_state state = match !current_state with
+  | Some state' -> state == state'
+  | None -> false
+
+(* Build settings *)
+
+let setup_reader_config config = (
+  assert Local_store.(is_bound ());
+  let open Mconfig in
+  let open Clflags in
+  let ocaml = config.ocaml in
+  Env.set_unit_name (Mconfig.unitname config);
+  Location.input_name  := config.query.filename;
+  fast                 := ocaml.unsafe ;
+  classic              := ocaml.classic ;
+  principal            := ocaml.principal ;
+  real_paths           := ocaml.real_paths ;
+  recursive_types      := ocaml.recursive_types ;
+  strict_sequence      := ocaml.strict_sequence ;
+  applicative_functors := ocaml.applicative_functors ;
+  unsafe_string        := ocaml.unsafe_string ;
+  nopervasives         := ocaml.nopervasives ;
+  strict_formats       := ocaml.strict_formats ;
+  open_modules         := ocaml.open_modules ;
+)
+
+let setup_typer_config config = (
+  setup_reader_config config;
+  Load_path.init (Mconfig.build_path config);
+)
+
+(** Switchable implementation of Oprint *)
+
+let default_out_value          = !Oprint.out_value
+let default_out_type           = !Oprint.out_type
+let default_out_class_type     = !Oprint.out_class_type
+let default_out_module_type    = !Oprint.out_module_type
+let default_out_sig_item       = !Oprint.out_sig_item
+let default_out_signature      = !Oprint.out_signature
+let default_out_type_extension = !Oprint.out_type_extension
+let default_out_phrase         = !Oprint.out_phrase
+
+let replacement_printer = ref None
+
+let oprint default inj ppf x = match !replacement_printer with
+  | None -> default ppf x
+  | Some printer -> printer ppf (inj x)
+
+let () =
+  let open Extend_protocol.Reader in
+  Oprint.out_value :=
+    oprint default_out_value (fun x -> Out_value x);
+  Oprint.out_type :=
+    oprint default_out_type (fun x -> Out_type x);
+  Oprint.out_class_type :=
+    oprint default_out_class_type (fun x -> Out_class_type x);
+  Oprint.out_module_type :=
+    oprint default_out_module_type (fun x -> Out_module_type x);
+  Oprint.out_sig_item :=
+    oprint default_out_sig_item (fun x -> Out_sig_item x);
+  Oprint.out_signature :=
+    oprint default_out_signature (fun x -> Out_signature x);
+  Oprint.out_type_extension :=
+    oprint default_out_type_extension (fun x -> Out_type_extension x);
+  Oprint.out_phrase :=
+    oprint default_out_phrase (fun x -> Out_phrase x)
+
+let default_printer ppf =
+  let open Extend_protocol.Reader in function
+  | Out_value x          -> default_out_value ppf x
+  | Out_type x           -> default_out_type ppf x
+  | Out_class_type x     -> default_out_class_type ppf x
+  | Out_module_type x    -> default_out_module_type ppf x
+  | Out_sig_item x       -> default_out_sig_item ppf x
+  | Out_signature x      -> default_out_signature ppf x
+  | Out_type_extension x -> default_out_type_extension ppf x
+  | Out_phrase x         -> default_out_phrase ppf x
+
+
+let with_printer printer f =
+  let_ref replacement_printer (Some printer) f
+
+(* Cleanup caches *)
+let clear_caches () = (
+  Cmi_cache.clear ();
+  Cmt_cache.clear ();
+  Directory_content_cache.clear ();
+)
+
+(* Flush cache *)
+let flush_caches ?older_than () = (
+  Cmi_cache.flush ?older_than ();
+  Cmt_cache.flush ?older_than ()
+)
diff --git a/src/kernel/mocaml.mli b/src/kernel/mocaml.mli
new file mode 100644
index 0000000..3a8fb6d
--- /dev/null
+++ b/src/kernel/mocaml.mli
@@ -0,0 +1,24 @@
+(* An instance of load path, environment cache & btype unification log  *)
+type typer_state
+
+val new_state : unit -> typer_state
+val with_state : typer_state -> (unit -> 'a) -> 'a
+val is_current_state : typer_state -> bool
+
+(* Build settings *)
+val setup_reader_config : Mconfig.t -> unit
+val setup_typer_config : Mconfig.t -> unit
+
+(* Replace Outcome printer *)
+val default_printer :
+  Format.formatter -> Extend_protocol.Reader.outcometree -> unit
+
+val with_printer :
+  (Format.formatter -> Extend_protocol.Reader.outcometree -> unit) ->
+  (unit -> 'a) -> 'a
+
+(* Clear caches, remove all items *)
+val clear_caches : unit -> unit
+
+(* Flush caches, remove outdated items *)
+val flush_caches : ?older_than:float -> unit -> unit
diff --git a/src/kernel/mpipeline.ml b/src/kernel/mpipeline.ml
new file mode 100644
index 0000000..7f58735
--- /dev/null
+++ b/src/kernel/mpipeline.ml
@@ -0,0 +1,197 @@
+open Std
+
+let {Logger. log} = Logger.for_section "Pipeline"
+
+let time_shift = ref 0.0
+
+let timed_lazy r x =
+  lazy (
+    let start = Misc.time_spent () in
+    let time_shift0 = !time_shift in
+    let update () =
+      let delta = Misc.time_spent () -. start in
+      let shift = !time_shift -. time_shift0 in
+      time_shift := time_shift0 +. delta;
+      r := !r +. delta -. shift;
+    in
+    match Lazy.force x with
+    | x -> update (); x
+    | exception exn -> update (); Std.reraise exn
+  )
+
+module Cache = struct
+  let cache = ref []
+
+  (* Values from configuration that are used as a key for the cache.
+     These values should:
+     - allow to maximize reuse; associating a single typechecker instance to a
+       filename and directory is natural, but keying also based on verbosity
+       makes no sense
+     - prevent reuse in different environments (if there is a change in
+       loadpath, a new typechecker should be produced).
+
+     It would be better to guarantee that the typechecker was well-behaved
+     when the loadpath changes (so that we can reusing the same instance, and
+     let the typechecker figure which part of its internal state should be
+     invalidated).
+     However we already had many bug related to that.  There are subtle changes
+     in the type checker behavior across the different versions of OCaml.
+     It is simpler to create new instances upfront.
+  *)
+
+  let key config =
+    Mconfig.(
+      config.query.filename,
+      config.query.directory,
+      config.ocaml,
+      {config.merlin with log_file = None; log_sections = []}
+    )
+
+  let get config =
+    let title = "pop_cache" in
+    let key = key config in
+    match List.assoc key !cache with
+    | state ->
+      cache := (key, state) :: List.remove_assoc key !cache;
+      log ~title "found entry for this configuration";
+      state
+    | exception Not_found ->
+      log ~title "nothing cached for this configuration";
+      let state = Mocaml.new_state () in
+      cache := (key, state) :: List.take_n 5 !cache;
+      state
+end
+
+module Typer = struct
+  type t = {
+    errors : exn list lazy_t;
+    result : Mtyper.result;
+  }
+end
+
+module Ppx = struct
+  type t = {
+    config : Mconfig.t;
+    errors : exn list;
+    parsetree : Mreader.parsetree;
+  }
+end
+
+type t = {
+  config : Mconfig.t;
+  state  : Mocaml.typer_state;
+  raw_source : Msource.t;
+  source : (Msource.t * Mreader.parsetree option) lazy_t;
+  reader : (Mreader.result * Mconfig.t) lazy_t;
+  ppx    : Ppx.t lazy_t;
+  typer  : Typer.t lazy_t;
+
+  pp_time     : float ref;
+  reader_time : float ref;
+  ppx_time    : float ref;
+  typer_time  : float ref;
+  error_time  : float ref;
+}
+
+let raw_source t = t.raw_source
+
+let input_config t = t.config
+let input_source t = fst (Lazy.force t.source)
+
+let with_pipeline t f =
+  Mocaml.with_state t.state @@ fun () ->
+  Mreader.with_ambient_reader t.config (input_source t) f
+
+let get_lexing_pos t pos =
+  Msource.get_lexing_pos
+    (input_source t) ~filename:(Mconfig.filename t.config) pos
+
+let reader t = Lazy.force t.reader
+
+let ppx    t = Lazy.force t.ppx
+let typer  t = Lazy.force t.typer
+
+let reader_config    t = (snd (reader t))
+let reader_parsetree t = (fst (reader t)).Mreader.parsetree
+let reader_comments  t = (fst (reader t)).Mreader.comments
+let reader_lexer_keywords  t = (fst (reader t)).Mreader.lexer_keywords
+let reader_lexer_errors  t = (fst (reader t)).Mreader.lexer_errors
+let reader_parser_errors t = (fst (reader t)).Mreader.parser_errors
+let reader_no_labels_for_completion t =
+  (fst (reader t)).Mreader.no_labels_for_completion
+
+let ppx_parsetree t = (ppx t).Ppx.parsetree
+let ppx_errors    t = (ppx t).Ppx.errors
+
+let final_config  t = (ppx t).Ppx.config
+
+let typer_result t = (typer t).Typer.result
+let typer_errors t = Lazy.force (typer t).Typer.errors
+
+let process
+    ?state
+    ?(pp_time=ref 0.0)
+    ?(reader_time=ref 0.0)
+    ?(ppx_time=ref 0.0)
+    ?(typer_time=ref 0.0)
+    ?(error_time=ref 0.0)
+    ?for_completion
+    config raw_source =
+  let state = match state with
+    | None -> Cache.get config
+    | Some state -> state
+  in
+  let source = timed_lazy pp_time (lazy (
+      match Mconfig.(config.ocaml.pp) with
+      | None -> raw_source, None
+      | Some { workdir; workval } ->
+        let source = Msource.text raw_source in
+        match
+          Pparse.apply_pp
+            ~workdir ~filename:Mconfig.(config.query.filename)
+            ~source ~pp:workval
+        with
+        | `Source source -> Msource.make source, None
+        | (`Interface _ | `Implementation _) as ast ->
+          raw_source, Some ast
+    )) in
+  let reader = timed_lazy reader_time (lazy (
+      let lazy source = source in
+      let config = Mconfig.normalize config in
+      Mocaml.setup_reader_config config;
+      let result = Mreader.parse ?for_completion config source in
+      result, config
+    )) in
+  let ppx = timed_lazy ppx_time (lazy (
+      let lazy ({Mreader.parsetree; _}, config) = reader in
+      let caught = ref [] in
+      Msupport.catch_errors Mconfig.(config.ocaml.warnings) caught @@ fun () ->
+      let parsetree = Mppx.rewrite config parsetree in
+      { Ppx. config; parsetree; errors = !caught }
+    )) in
+  let typer = timed_lazy typer_time (lazy (
+      let lazy { Ppx. config; parsetree; _ } = ppx in
+      Mocaml.setup_typer_config config;
+      let result = Mtyper.run config parsetree in
+      let errors = timed_lazy error_time (lazy (Mtyper.get_errors result)) in
+      { Typer. errors; result }
+    )) in
+  { config; state; raw_source; source; reader; ppx; typer;
+    pp_time; reader_time; ppx_time; typer_time; error_time }
+
+let make config source =
+  process (Mconfig.normalize config) source
+
+let for_completion position
+    {config; state; raw_source;
+     pp_time; reader_time; ppx_time; typer_time; error_time; _} =
+  process config raw_source ~for_completion:position
+    ~state ~pp_time ~reader_time ~ppx_time ~typer_time ~error_time
+
+let timing_information t = [
+  "pp"     , !(t.pp_time);
+  "reader" , !(t.reader_time);
+  "ppx"    , !(t.ppx_time);
+  "typer"  , !(t.typer_time);
+  "error"  , !(t.error_time);
+]
diff --git a/src/kernel/mpipeline.mli b/src/kernel/mpipeline.mli
new file mode 100644
index 0000000..24355f1
--- /dev/null
+++ b/src/kernel/mpipeline.mli
@@ -0,0 +1,28 @@
+type t
+val make : Mconfig.t -> Msource.t -> t
+val with_pipeline : t -> (unit -> 'a) -> 'a
+val for_completion : Msource.position -> t -> t
+
+val raw_source : t -> Msource.t
+
+val input_config : t -> Mconfig.t
+val input_source : t -> Msource.t
+val get_lexing_pos : t -> [< Msource.position] -> Lexing.position
+
+val reader_config : t -> Mconfig.t
+val reader_comments : t -> (string * Location.t) list
+val reader_parsetree : t -> Mreader.parsetree
+val reader_lexer_keywords : t -> string list
+val reader_lexer_errors : t -> exn list
+val reader_parser_errors : t -> exn list
+val reader_no_labels_for_completion : t -> bool
+
+val ppx_parsetree : t -> Mreader.parsetree
+val ppx_errors : t -> exn list
+
+val final_config : t -> Mconfig.t
+
+val typer_result : t -> Mtyper.result
+val typer_errors : t -> exn list
+
+val timing_information : t -> (string * float) list
diff --git a/src/kernel/mppx.ml b/src/kernel/mppx.ml
new file mode 100644
index 0000000..29056a7
--- /dev/null
+++ b/src/kernel/mppx.ml
@@ -0,0 +1,58 @@
+open Mconfig
+
+let {Logger. log} = Logger.for_section "Mppx"
+
+let change_directory dir =
+  log ~title:"changing_directory" "%s" dir;
+  match Sys.chdir dir with
+  | () -> true
+  | exception exn ->
+    log ~title:"changing directory"
+      "change_directory %S failed with %a" dir Logger.exn exn;
+    false
+
+
+let with_include_dir path f =
+  let saved = !Clflags.include_dirs in
+  let restore () = Clflags.include_dirs := saved in
+  Clflags.include_dirs := path;
+  let result =
+    begin
+      try
+        f ()
+      with
+      | e ->
+         restore ();
+         raise e
+    end
+  in
+  restore ();
+  result
+
+
+let rewrite cfg parsetree =
+  let ppx = cfg.ocaml.ppx in
+  let prev_dir = Sys.getcwd () in
+  let restore () =
+    if not (change_directory prev_dir) then
+      ignore (change_directory "/")
+  in
+  (* add include path attribute to the parsetree *)
+  with_include_dir (Mconfig.build_path cfg) @@ fun () ->
+  match
+    Pparse.apply_rewriters ~restore:false ~ppx ~tool_name:"merlin" parsetree
+  with
+  | parsetree ->
+    restore ();
+    parsetree
+  | exception exn ->
+    log ~title:"rewrite" "failed with %a" Logger.fmt (fun fmt ->
+      match Location.error_of_exn exn with
+      | None | Some `Already_displayed ->
+        Format.fprintf fmt "%s" (Printexc.to_string exn)
+      | Some (`Ok err) ->
+        Location.print_main fmt err
+    );
+    Msupport.raise_error exn;
+    restore ();
+    parsetree
diff --git a/src/kernel/mppx.mli b/src/kernel/mppx.mli
new file mode 100644
index 0000000..bae4dee
--- /dev/null
+++ b/src/kernel/mppx.mli
@@ -0,0 +1 @@
+val rewrite : Mconfig.t -> Mreader.parsetree -> Mreader.parsetree
diff --git a/src/kernel/mreader.ml b/src/kernel/mreader.ml
new file mode 100644
index 0000000..61a238e
--- /dev/null
+++ b/src/kernel/mreader.ml
@@ -0,0 +1,180 @@
+open Std
+
+type parsetree = [
+  | `Interface of Parsetree.signature
+  | `Implementation of Parsetree.structure
+]
+
+type comment = (string * Location.t)
+
+type result = {
+  lexer_keywords: string list;
+  lexer_errors  : exn list;
+  parser_errors : exn list;
+  comments      : comment list;
+  parsetree     : parsetree;
+  no_labels_for_completion : bool;
+}
+
+(* Normal entry point *)
+
+let normal_parse ?for_completion config source =
+  let kind =
+    let filename = Mconfig.(config.query.filename) in
+    let extension =
+      match String.rindex filename '.' with
+      | exception Not_found -> ""
+      | pos -> String.sub ~pos ~len:(String.length filename - pos) filename
+    in
+    Logger.log ~section:"Mreader" ~title:"run"
+      "extension(%S) = %S" filename extension;
+    if List.exists ~f:(fun (_impl,intf) -> intf = extension)
+        Mconfig.(config.merlin.suffixes)
+    then Mreader_parser.MLI
+    else Mreader_parser.ML
+  in
+  let lexer =
+    let keywords = Extension.keywords Mconfig.(config.merlin.extensions) in
+    Mreader_lexer.make Mconfig.(config.ocaml.warnings) keywords config source
+  in
+  let no_labels_for_completion, lexer = match for_completion with
+    | None -> false, lexer
+    | Some pos ->
+      let pos = Msource.get_lexing_pos source
+          ~filename:(Mconfig.filename config) pos
+      in
+      Mreader_lexer.for_completion lexer pos
+  in
+  let parser = Mreader_parser.make Mconfig.(config.ocaml.warnings) lexer kind in
+  let lexer_keywords = Mreader_lexer.keywords lexer
+  and lexer_errors = Mreader_lexer.errors lexer
+  and parser_errors = Mreader_parser.errors parser
+  and parsetree = Mreader_parser.result parser
+  and comments = Mreader_lexer.comments lexer
+  in
+  { lexer_keywords; lexer_errors; parser_errors; comments; parsetree;
+    no_labels_for_completion; }
+
+(* Pretty-printing *)
+
+type pretty_parsetree = Extend_protocol.Reader.pretty_parsetree
+type outcometree = Extend_protocol.Reader.outcometree
+
+let ambient_reader = ref None
+
+let instantiate_reader spec config source = match spec with
+  | [] -> ((lazy None), ignore)
+  | name :: args ->
+    let reader = lazy (Mreader_extend.start name args config source) in
+    (reader, (fun () ->
+       if Lazy.is_val reader then
+         match Lazy.force reader with
+         | None -> ()
+         | Some reader -> Mreader_extend.stop reader))
+
+let get_reader config =
+  let rec find_reader assocsuffixes =
+    match assocsuffixes with
+    | [] -> []
+    | (suffix,reader)::t ->
+      if Filename.check_suffix Mconfig.(config.query.filename) suffix then [reader] else find_reader t
+  in
+  match Mconfig.(config.merlin.reader) with
+  (* if a reader flag exists then this is explicitly used disregarding suffix association *)
+  | [] -> find_reader Mconfig.(config.merlin.extension_to_reader)
+  | x -> x
+
+let mocaml_printer reader ppf otree =
+  let str = match reader with
+    | lazy (Some reader) -> Mreader_extend.print_outcome otree reader
+    | _ -> None
+  in
+  match str with
+  | Some str -> Format.pp_print_string ppf str
+  | None -> Mocaml.default_printer ppf otree
+
+let with_ambient_reader config source f =
+  let ambient_reader' = !ambient_reader in
+  let reader_spec = get_reader config in
+  let reader, stop = instantiate_reader reader_spec config source in
+  ambient_reader := Some (reader, reader_spec, source);
+  Misc.try_finally
+    (fun () -> Mocaml.with_printer (mocaml_printer reader) f)
+    ~always:(fun () -> ambient_reader := ambient_reader'; stop ())
+
+let try_with_reader config source f =
+  let reader_spec = get_reader config in
+  let lazy reader, stop =
+    match !ambient_reader with
+    | Some (reader, reader_spec', source')
+      when compare reader_spec reader_spec' = 0 &&
+           compare source source' = 0 -> reader, ignore
+    | _ -> instantiate_reader reader_spec config source
+  in
+  match reader with
+  | None -> stop (); None
+  | Some reader ->
+    Misc.try_finally (fun () -> f reader) ~always:stop
+
+let print_pretty config source tree =
+  match try_with_reader config source
+          (Mreader_extend.print_pretty tree) with
+  | Some result -> result
+  | None ->
+    let ppf, to_string = Std.Format.to_string () in
+    let open Extend_protocol.Reader in
+    begin match tree with
+      | Pretty_case_list       x -> Pprintast.case_list       ppf x
+      | Pretty_core_type       x -> Pprintast.core_type       ppf x
+      | Pretty_expression      x -> Pprintast.expression      ppf x
+      | Pretty_pattern         x -> Pprintast.pattern         ppf x
+      | Pretty_signature       x -> Pprintast.signature       ppf x
+      | Pretty_structure       x -> Pprintast.structure       ppf x
+      | Pretty_toplevel_phrase x -> Pprintast.toplevel_phrase ppf x
+    end;
+    to_string ()
+
+let default_print_outcome tree =
+  Mocaml.default_printer Format.str_formatter tree;
+  Format.flush_str_formatter ()
+
+let print_outcome config source tree =
+  match try_with_reader config source
+          (Mreader_extend.print_outcome tree) with
+  | Some result -> result
+  | None -> default_print_outcome tree
+
+let print_batch_outcome config source tree =
+  match try_with_reader config source
+          (Mreader_extend.print_outcomes tree) with
+  | Some result -> result
+  | None -> List.map ~f:default_print_outcome tree
+
+let reconstruct_identifier config source pos =
+  match
+    try_with_reader config source
+      (Mreader_extend.reconstruct_identifier pos)
+  with
+  | None | Some [] -> Mreader_lexer.reconstruct_identifier config source pos
+  | Some result -> result
+
+(* Entry point *)
+
+let parse ?for_completion config = function
+  | (source, None) ->
+    begin match
+        try_with_reader config source
+          (Mreader_extend.parse ?for_completion)
+      with
+      | Some (`No_labels no_labels_for_completion, parsetree) ->
+        let (lexer_errors, parser_errors, comments) = ([], [], []) in
+        let lexer_keywords = [] (* TODO? *) in
+        { lexer_keywords; lexer_errors; parser_errors; comments;
+          parsetree; no_labels_for_completion; }
+      | None -> normal_parse ?for_completion config source
+    end
+  | (_, Some parsetree) ->
+    let (lexer_errors, parser_errors, comments) = ([], [], []) in
+    let lexer_keywords = [] in
+    { lexer_keywords; lexer_errors; parser_errors; comments; parsetree;
+      no_labels_for_completion = false; }
diff --git a/src/kernel/mreader.mli b/src/kernel/mreader.mli
new file mode 100644
index 0000000..2594d65
--- /dev/null
+++ b/src/kernel/mreader.mli
@@ -0,0 +1,43 @@
+type parsetree = [
+  | `Interface of Parsetree.signature
+  | `Implementation of Parsetree.structure
+]
+
+type comment = (string * Location.t)
+
+type result = {
+  lexer_keywords: string list;
+  lexer_errors  : exn list;
+  parser_errors : exn list;
+  comments      : comment list;
+  parsetree     : parsetree;
+  no_labels_for_completion : bool;
+}
+
+type pretty_parsetree = Extend_protocol.Reader.pretty_parsetree
+type outcometree = Extend_protocol.Reader.outcometree
+
+(* Ambient reader.
+
+   Some actions need to interact with an external process.
+   `with_ambient_reader' will setup this process to speed up later calls.
+*)
+
+val with_ambient_reader : Mconfig.t -> Msource.t -> (unit -> 'a) -> 'a
+
+(* Main functions *)
+
+val parse :
+  ?for_completion:Msource.position -> Mconfig.t -> Msource.t * parsetree option -> result
+
+val print_pretty :
+  Mconfig.t -> Msource.t -> pretty_parsetree -> string
+
+val print_outcome :
+  Mconfig.t -> Msource.t -> outcometree -> string
+
+val print_batch_outcome :
+  Mconfig.t -> Msource.t -> outcometree list -> string list
+
+val reconstruct_identifier:
+  Mconfig.t -> Msource.t -> Lexing.position -> string Location.loc list
diff --git a/src/kernel/mreader_explain.ml b/src/kernel/mreader_explain.ml
new file mode 100644
index 0000000..83c5186
--- /dev/null
+++ b/src/kernel/mreader_explain.ml
@@ -0,0 +1,104 @@
+open Parser_raw
+open MenhirInterpreter
+
+let opening (type a) : a terminal -> string option = function
+  | T_STRUCT       -> Some "struct"
+  | T_SIG          -> Some "sig"
+  | T_OBJECT       -> Some "object"
+  | T_BEGIN        -> Some "begin"
+  | T_LPAREN       -> Some "("
+  | T_LBRACKET     -> Some "["
+  | T_LBRACE       -> Some "{"
+  | T_LBRACKETBAR  -> Some "[|"
+  | T_LBRACKETLESS -> Some "[<"
+  | T_LBRACELESS   -> Some "{<"
+  | _ -> None
+
+let opening_st st =
+  match incoming_symbol st with
+  | T term -> opening term
+  | _ -> None
+
+let closing (type a) : a terminal -> bool = function
+  | T_END             -> true
+  | T_RPAREN          -> true
+  | T_RBRACKET        -> true
+  | T_RBRACE          -> true
+  | T_BARRBRACKET     -> true
+  | T_GREATERRBRACE   -> true
+  | T_GREATERRBRACKET -> true
+  | _ -> false
+
+let closing_st st =
+  match incoming_symbol st with
+  | T term -> closing term
+  | _ -> false
+
+type explanation = {
+  item: (string * Location.t) option;
+  unclosed: (string * Location.t) option;
+  location: Location.t;
+  popped: MenhirInterpreter.xsymbol list;
+  shifted: MenhirInterpreter.xsymbol option;
+  unexpected: MenhirInterpreter.token;
+}
+
+let explain env (unexpected, startp, endp) popped shifted =
+  let mkloc s e = {Location. loc_start = s; loc_end = e; loc_ghost = false} in
+  let open MenhirInterpreter in
+  let location = mkloc startp endp in
+  let closed = ref 0 in
+  let unclosed = ref None in
+  let return item =
+    { item; unclosed = !unclosed; location; popped; shifted; unexpected }
+  in
+  let rec process env = match top env with
+    | None -> return None
+    | Some (Element (st, _, startp, endp)) ->
+      if closing_st st then incr closed;
+      begin match opening_st st with
+        | None -> ()
+        | Some st ->
+          if !closed = 0 && !unclosed = None then
+            unclosed := Some (st, mkloc startp endp)
+          else
+            decr closed
+      end;
+      match Parser_explain.named_item_at (number st) with
+      | name -> return (Some (name, mkloc startp endp))
+      | exception Not_found ->
+        match pop env with
+        | None -> return None
+        | Some env -> process env
+  in
+  process env
+
+let to_error { item; unclosed; location; popped; shifted; unexpected = _ } =
+  let inside = match item with
+    | None -> ""
+    | Some (name, _) -> " inside `" ^ name ^ "'" in
+  let after = match unclosed with
+    | None -> ""
+    | Some (name, _) -> " after unclosed " ^ name in
+  let friendly_name sym = match sym with
+    | X (T _) -> "`" ^ Parser_printer.print_symbol sym ^ "'"
+    | X (N _) -> Parser_printer.print_symbol sym
+  in
+  let popped = String.concat " " (List.rev_map friendly_name popped) in
+  let expecting = match shifted with
+    | None -> if popped = "" then "" else ", maybe remove " ^ popped
+    | Some (X (T T_EOF)) -> ""
+    | Some sym ->
+      if popped = "" then ", expecting " ^ (friendly_name sym)
+      else ", maybe replace " ^ popped ^ " by " ^ (friendly_name sym)
+  in
+  let msg = Printf.sprintf "Syntax error%s%s%s" inside after expecting in
+  Location.error ~loc:location ~source:Location.Parser msg
+
+exception Syntax_explanation of explanation
+
+let syntax_explanation = function
+  | Syntax_explanation explanation -> Some (to_error explanation)
+  | _ -> None
+
+let () = Location.register_error_of_exn syntax_explanation
diff --git a/src/kernel/mreader_extend.ml b/src/kernel/mreader_extend.ml
new file mode 100644
index 0000000..b5c59a5
--- /dev/null
+++ b/src/kernel/mreader_extend.ml
@@ -0,0 +1,148 @@
+open Std
+open Extend_protocol.Reader
+
+let {Logger. log} = Logger.for_section "Mreader_extend"
+
+type t = {
+  name : string;
+  args : string list;
+  config : Mconfig.t;
+  source : Msource.t;
+  driver : Extend_driver.t;
+  mutable stopped : bool;
+}
+
+let print () t = t.name
+
+let incorrect_behavior fn t =
+  log ~title:fn "Extension %S has incorrect behavior" t.name
+
+let stop t =
+  if t.stopped then
+    log ~title:"stop" "%a: already closed" print t
+  else (
+    log ~title:"stop" "%a" print t;
+    t.stopped <- true;
+    Extend_driver.stop t.driver
+  )
+
+let stop_finalise t =
+  if not t.stopped then (
+    log ~title:"stop_finalise" "leaked process %s" t.name;
+    stop t
+  )
+
+let load_source t config source =
+  let buffer = {
+    path  = Mconfig.filename config;
+    flags = t.args;
+    text  = Msource.text source;
+  } in
+  match Extend_driver.reader t.driver (Req_load buffer) with
+  | Res_loaded -> Some t
+  | _ ->
+    Extend_driver.stop t.driver;
+    incorrect_behavior "load_source" t;
+    None
+
+let start name args config source =
+  let section = "(ext)" ^ name in
+  let notify str = Logger.notify ~section "%s" str in
+  let debug str = Logger.log ~section:"reader" ~title:section "%s" str in
+  let driver = Extend_driver.run ~notify ~debug name in
+  let process = { name; args; config; source; driver; stopped = false } in
+  Gc.finalise stop_finalise process;
+  load_source process config source
+
+let parsetree = function
+  | Signature sg -> `Interface sg
+  | Structure str -> `Implementation str
+
+let parse ?for_completion t =
+  log ~title:"parse" "?for_completion:%a %a"
+    (Option.print Msource.print_position) for_completion
+    print t;
+  assert (not t.stopped);
+  match
+    Extend_driver.reader t.driver
+      (match for_completion with
+       | None -> Req_parse
+       | Some pos ->
+         let pos = Msource.get_lexing_pos t.source
+             ~filename:(Mconfig.filename t.config) pos
+         in
+         Req_parse_for_completion pos)
+  with
+  | Res_parse ast ->
+    Some (`No_labels false, parsetree ast)
+  | Res_parse_for_completion (info, ast) ->
+    Some (`No_labels (not info.complete_labels), parsetree ast)
+  | _ ->
+    incorrect_behavior "parse" t;
+    None
+
+let reconstruct_identifier pos t =
+  log ~title:"reconstruct_identifier" "%a %a"
+    Lexing.print_position pos print t;
+  match Extend_driver.reader t.driver (Req_get_ident_at pos) with
+  | Res_get_ident_at ident -> Some ident
+  | _ ->
+    incorrect_behavior "reconstruct_identifier" t;
+    None
+
+let attr_cleaner =
+  let open Ast_mapper in
+  let attributes mapper attrs =
+    let not_merlin_attribute attr =
+      let (name,_) = Ast_helper.Attr.as_tuple attr in
+      not (String.is_prefixed ~by:"merlin." name.Location.txt) in
+    let attrs = List.filter ~f:not_merlin_attribute attrs in
+    default_mapper.attributes mapper attrs
+  in
+  { default_mapper with attributes }
+
+let clean_tree =
+  let open Ast_mapper in function
+  | Pretty_case_list x ->
+    Pretty_case_list (attr_cleaner.cases attr_cleaner x)
+  | Pretty_core_type x ->
+    Pretty_core_type (attr_cleaner.typ attr_cleaner x)
+  | Pretty_expression x ->
+    Pretty_expression (attr_cleaner.expr attr_cleaner x)
+  | Pretty_pattern x ->
+    Pretty_pattern (attr_cleaner.pat attr_cleaner x)
+  | Pretty_signature x ->
+    Pretty_signature (attr_cleaner.signature attr_cleaner x)
+  | Pretty_structure x ->
+    Pretty_structure (attr_cleaner.structure attr_cleaner x)
+  | Pretty_toplevel_phrase (Parsetree.Ptop_def x) ->
+    let x = attr_cleaner.structure attr_cleaner x in
+    Pretty_toplevel_phrase (Parsetree.Ptop_def x)
+  | Pretty_toplevel_phrase (Parsetree.Ptop_dir _) as tree -> tree
+
+let print_pretty tree t =
+  log ~title:"print_pretty" "TODO %a" print t;
+  let tree = clean_tree tree in
+  match Extend_driver.reader t.driver (Req_pretty_print tree) with
+  | Res_pretty_print str -> Some str
+  | _ ->
+    incorrect_behavior "pretty_print" t;
+    None
+
+let print_outcomes ts t =
+  log ~title:"print_outcomes" "TODO %a" print t;
+  match ts with
+  | [] -> Some []
+  | ts -> match Extend_driver.reader t.driver (Req_print_outcome ts) with
+    | Res_print_outcome ts -> Some ts
+    | _ ->
+      incorrect_behavior "print_batch_outcome" t;
+      None
+
+let print_outcome o t =
+  log ~title:"print_outcome" "TODO %a" print t;
+  match Extend_driver.reader t.driver (Req_print_outcome [o]) with
+  | Res_print_outcome [o] -> Some o
+  | _ ->
+    incorrect_behavior "print_batch_outcome" t;
+    None
diff --git a/src/kernel/mreader_extend.mli b/src/kernel/mreader_extend.mli
new file mode 100644
index 0000000..01ee90f
--- /dev/null
+++ b/src/kernel/mreader_extend.mli
@@ -0,0 +1,23 @@
+type t
+
+val stop : t -> unit
+
+val start : string -> string list -> Mconfig.t -> Msource.t -> t option
+
+val parse :
+  ?for_completion:Msource.position -> t ->
+  ([`No_labels of bool ] *
+   [`Implementation of Parsetree.structure | `Interface of Parsetree.signature])
+  option
+
+val reconstruct_identifier :
+  Lexing.position -> t -> string Location.loc list option
+
+val print_pretty :
+  Extend_protocol.Reader.pretty_parsetree -> t -> string option
+
+val print_outcomes :
+  Extend_protocol.Reader.outcometree list -> t -> string list option
+
+val print_outcome :
+  Extend_protocol.Reader.outcometree -> t -> string option
diff --git a/src/kernel/mreader_lexer.ml b/src/kernel/mreader_lexer.ml
new file mode 100644
index 0000000..c889790
--- /dev/null
+++ b/src/kernel/mreader_lexer.ml
@@ -0,0 +1,366 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+
+type keywords = Lexer_raw.keywords
+
+type triple = Parser_raw.token * Lexing.position * Lexing.position
+
+type item =
+  | Triple of triple
+  | Comment of (string * Location.t)
+  | Error of Lexer_raw.error * Location.t
+
+type t = {
+  keywords: keywords;
+  config: Mconfig.t;
+  source: Msource.t;
+  items: item list;
+}
+
+let get_tokens keywords pos text =
+  let state = Lexer_raw.make keywords in
+  let lexbuf = Lexing.from_string text in
+  Lexing.move lexbuf pos;
+  let rec aux items = function
+    | Lexer_raw.Return (Parser_raw.COMMENT comment) ->
+      continue (Comment comment :: items)
+    | Lexer_raw.Refill k -> aux items (k ())
+    | Lexer_raw.Return t ->
+      let triple = (t, lexbuf.Lexing.lex_start_p, lexbuf.Lexing.lex_curr_p) in
+      let items = Triple triple :: items in
+      if t = Parser_raw.EOF
+      then items
+      else continue items
+    | Lexer_raw.Fail (err, loc) ->
+      continue (Error (err, loc) :: items)
+
+  and continue items =
+    aux items (Lexer_raw.token state lexbuf)
+
+  in
+  function
+  | [] ->
+    (* First line: skip #! ... *)
+    aux [] (Lexer_raw.skip_sharp_bang state lexbuf)
+  | items ->
+    (* Resume *)
+    continue items
+
+let initial_position config =
+  { Lexing.
+    pos_fname = (Mconfig.filename config);
+    pos_lnum = 1;
+    pos_bol = 0;
+    pos_cnum = 0;
+  }
+
+let make warnings keywords config source =
+  Msupport.catch_errors warnings (ref []) @@ fun () ->
+  let items =
+    get_tokens keywords
+    (initial_position config)
+    (Msource.text source)
+    []
+  in
+  { keywords; items; config; source }
+
+let item_start = function
+  | Triple (_,s,_) -> s
+  | Comment (_, l) | Error (_, l) ->
+    l.Location.loc_start
+
+let item_end = function
+  | Triple (_,_,e) -> e
+  | Comment (_, l) | Error (_, l) ->
+    l.Location.loc_end
+
+let initial_position t =
+  initial_position t.config
+
+let rev_filter_map ~f lst =
+  let rec aux acc = function
+    | [] -> acc
+    | x :: xs ->
+      let acc =
+        match f x with
+        | Some x' -> x' :: acc
+        | None -> acc
+      in
+      aux acc xs
+  in
+  aux [] lst
+
+let tokens t =
+  rev_filter_map t.items
+    ~f:(function Triple t -> Some t | _ -> None)
+
+let keywords t =
+  Lexer_raw.list_keywords t.keywords
+
+let errors t =
+  rev_filter_map t.items
+    ~f:(function Error (err, loc) -> Some (Lexer_raw.Error (err, loc))
+               | _ -> None)
+
+let comments t =
+  rev_filter_map t.items
+    ~f:(function Comment t -> Some t | _ -> None)
+
+open Parser_raw
+
+let is_operator = function
+  | PREFIXOP s
+  | LETOP s | ANDOP s
+  | INFIXOP0 s | INFIXOP1 s | INFIXOP2 s | INFIXOP3 s | INFIXOP4 s -> Some s
+  | BANG -> Some "!"
+  | PERCENT -> Some "%"
+  | PLUS -> Some "+"        | PLUSDOT -> Some "+."
+  | MINUS -> Some "-"       | MINUSDOT -> Some "-."
+  | STAR -> Some "*"        | EQUAL -> Some "="
+  | LESS -> Some "<"        | GREATER -> Some ">"
+  | OR -> Some "or"         | BARBAR -> Some "||"
+  | AMPERSAND -> Some "&"   | AMPERAMPER -> Some "&&"
+  | COLONEQUAL -> Some ":=" | PLUSEQ -> Some "+="
+  | _ -> None
+
+(* [reconstruct_identifier] is impossible to read at the moment, here is a
+   pseudo code version of the function:
+   (many thanks to Gabriel for this contribution)
+
+        00| let h = parse (focus h) with
+        01|   | . { h+1 }
+        02|   | _ { h }
+        03| in
+        04| parse h with
+        05| | BOF x=operator       { [x] }
+        06| | ¬( x=operator        { [x] }
+        07| | ' x=ident            { [] }
+        08| | _ {
+        09|   let acc, h = parse (h ! tail h) with
+        10|     | x=ident !          { [x], h }
+        11|     | ( ! x=operator )   { [x], h }
+        12|     | ( x=operator ! )   { [x], h - 1 }
+        13|     | ( x=operator ) !   { [x], h - 2 }
+        14|     | _ { [], h }
+        15|   in
+        16|   let h = h - 1 in
+        17|   let rec head acc = parse (h !) with
+        18|     | tl x=ident . ! { head (x :: acc) tl }
+        19|     | x=ident . !    { ident :: acc }
+        20|     | _              { acc }
+        21|   in head acc
+        22| }
+
+   Now for the explanations:
+     line 0-3:  if we're on a dot, skip it and move to the right
+
+     line 5,6:  if we're on an operator not preceded by an opening parenthesis,
+                just return that.
+
+     line 7:    if we're on a type variable, don't return anything.
+                reconstruct_identifier is called when locating and getting the
+                type of an expression, in both cases there's nothing we can do
+                with a type variable.
+                See #317
+
+     line 8-22: two step approach:
+       - line 9-15:  retrieve the identifier
+                     OR retrieve the parenthesized operator and move before the
+                        opening parenthesis
+
+       - line 16-21: retrieve the "path" prefix of the identifier/operator we
+                     got in the previous step.
+
+
+   Additionally, the message of commit fc0b152 explains what we consider is an
+   identifier:
+
+     «
+        Interpreting an OCaml identifier out of context is a bit ambiguous.
+
+        A prefix of the form (UIDENT DOT)* is the module path,
+        A UIDENT suffix is either a module name, a module type name (in case the
+        whole path is a module path), or a value constructor.
+        A LIDENT suffix is either a value name, a type constructor or a module
+        type name.
+        A LPAREN OPERATOR RPAREN suffix is a value name (and soon, maybe a
+        value constructor if beginning by ':' ?!) .
+
+        In the middle, LIDENT DOT (UIDENT DOT)* is projection of the field of a
+        record.  In this case, merlin will drop everything up to the first
+        UIDENT and complete in the scope of the (UIDENT DOT)* interpreted as a
+        module path.
+        Soon, the last UIDENT might also be the type of an inline record.
+        (Module2.f.Module1.A <- type of the record of the value constructor named A of
+        type f, defined in Module1 and aliased in Module2, pfffff).
+     »
+*)
+
+let reconstruct_identifier_from_tokens tokens pos =
+  let rec look_for_component acc = function
+
+    (* Skip 'a and `A *)
+    | ((LIDENT _ | UIDENT _), _, _) ::
+      ((BACKQUOTE | QUOTE), _, _) :: items ->
+      check acc items
+
+    (* UIDENT is a regular a component *)
+    | (UIDENT _, _, _) as item :: items ->
+      look_for_dot (item :: acc) items
+
+    (* LIDENT always begin a new identifier *)
+    | (LIDENT _, _, _) as item :: items ->
+      if acc = []
+      then look_for_dot [item] items
+      else check acc (item :: items)
+
+    (* Reified operators behave like LIDENT *)
+    | (RPAREN, _, _) :: (token, _, _ as item) :: (LPAREN, _, _) :: items
+      when is_operator token <> None && acc = [] ->
+      look_for_dot [item] items
+
+    (* An operator alone is an identifier on its own *)
+    | (token, _, _ as item) :: items
+      when is_operator token <> None && acc = [] ->
+      check [item] items
+
+    (* Otherwise, check current accumulator and scan the rest of the input *)
+    | _ :: items ->
+      check acc items
+
+    | [] -> raise Not_found
+
+  and look_for_dot acc = function
+    | (DOT,_,_) :: items -> look_for_component acc items
+    | items -> check acc items
+
+  and check acc items =
+    if acc <> [] &&
+       (let startp = match acc with
+           | (_, startp, _) :: _ -> startp
+           | _ -> assert false in
+        Lexing.compare_pos startp pos <= 0) &&
+       (let endp = match List.last acc with
+           | Some ((_, _, endp)) -> endp
+           | _ -> assert false in
+        Lexing.compare_pos pos endp <= 0)
+    then acc
+    else match items with
+      | [] -> raise Not_found
+      | (_, _, endp) :: _ when Lexing.compare_pos endp pos < 0 ->
+        raise Not_found
+      | _ -> look_for_component [] items
+
+  in
+  match look_for_component [] tokens with
+  | exception Not_found -> []
+  | acc ->
+    let fmt (token, loc_start, loc_end) =
+      let id =
+        match token with
+        | UIDENT s | LIDENT s -> s
+        | _ -> match is_operator token with
+          | Some t -> t
+          | None -> assert false
+      in
+      Location.mkloc id {Location. loc_start; loc_end; loc_ghost = false}
+    in
+    let before_pos = function
+      | (_, s, _) ->
+        Lexing.compare_pos s pos <= 0
+    in
+    List.map ~f:fmt (List.filter ~f:before_pos acc)
+
+let reconstruct_identifier config source pos =
+  let rec lex acc lexbuf =
+    let token = Lexer_ident.token lexbuf in
+    let item = (token, lexbuf.Lexing.lex_start_p, lexbuf.Lexing.lex_curr_p) in
+    match token with
+    | EOF -> (item :: acc)
+    | EOL when Lexing.compare_pos lexbuf.Lexing.lex_curr_p pos > 0 ->
+      (item :: acc)
+    | EOL -> lex [] lexbuf
+    | _ -> lex (item :: acc) lexbuf
+  in
+  let lexbuf = Lexing.from_string (Msource.text source) in
+  Location.init lexbuf (Mconfig.filename config);
+  let tokens = lex [] lexbuf in
+  reconstruct_identifier_from_tokens tokens pos
+
+let is_uppercase {Location. txt = x; _} =
+  x <> "" && Char.is_uppercase x.[0]
+
+let rec drop_lowercase acc = function
+  | [x] -> List.rev (x :: acc)
+  | x :: xs when not (is_uppercase x) -> drop_lowercase [] xs
+  | x :: xs -> drop_lowercase (x :: acc) xs
+  | [] -> List.rev acc
+
+let for_completion t pos =
+  let no_labels = ref false in
+  let check_label = function
+    | Triple ((LABEL _ | OPTLABEL _), _, _) -> no_labels := true
+    | _ -> ()
+  in
+  let rec aux acc = function
+    (* Cursor is before item: continue *)
+    | item :: items when Lexing.compare_pos (item_start item) pos >= 0 ->
+      aux (item :: acc) items
+
+    (* Cursor is in the middle of item: stop *)
+    | item :: _ when Lexing.compare_pos (item_end item) pos > 0 ->
+      check_label item;
+      raise Exit
+
+    (* Cursor is at the end *)
+    | ((Triple (token, _, loc_end) as item) :: _) as items
+      when Lexing.compare_pos pos loc_end = 0 ->
+      check_label item;
+      begin match token with
+        (* Already on identifier, no need to introduce *)
+        | UIDENT _ | LIDENT _ -> raise Exit
+        | _ -> acc, items
+      end
+
+    | items -> acc, items
+  in
+  let t =
+    match aux [] t.items with
+    | exception Exit -> t
+    | acc, items ->
+      {t with items =
+                List.rev_append acc (Triple (LIDENT "", pos, pos) :: items)}
+  in
+  (!no_labels, t)
+
+let identifier_suffix ident =
+  match List.last ident with
+  | Some x when is_uppercase x -> drop_lowercase [] ident
+  | _ -> ident
diff --git a/src/kernel/mreader_lexer.mli b/src/kernel/mreader_lexer.mli
new file mode 100644
index 0000000..f9236a7
--- /dev/null
+++ b/src/kernel/mreader_lexer.mli
@@ -0,0 +1,50 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+type keywords = Lexer_raw.keywords
+
+type triple = Parser_raw.token * Lexing.position * Lexing.position
+
+type t
+
+val make : Warnings.state -> keywords -> Mconfig.t -> Msource.t -> t
+
+val for_completion: t -> Lexing.position ->
+  bool (* complete labels or not *) * t
+
+val initial_position : t -> Lexing.position
+
+val tokens   : t -> triple list
+val keywords : t -> string list
+val errors   : t -> exn list
+val comments : t -> (string * Location.t) list
+
+val reconstruct_identifier:
+  Mconfig.t -> Msource.t -> Lexing.position -> string Location.loc list
+
+val identifier_suffix: string Location.loc list -> string Location.loc list
diff --git a/src/kernel/mreader_parser.ml b/src/kernel/mreader_parser.ml
new file mode 100644
index 0000000..f05ec06
--- /dev/null
+++ b/src/kernel/mreader_parser.ml
@@ -0,0 +1,211 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+
+module I = Parser_raw.MenhirInterpreter
+
+type kind =
+  | ML
+  | MLI
+  (*| MLL | MLY*)
+
+module Dump = struct
+  let symbol () = Parser_printer.print_symbol
+end
+
+module R = Mreader_recover.Make
+    (I)
+    (struct
+      include Parser_recover
+
+      let default_value loc x =
+        Default.default_loc := loc;
+        default_value x
+
+      let guide (type a) : a I.symbol -> bool = function
+        | I.T I.T_BEGIN -> true
+        | _ -> false
+
+      let token_of_terminal = Parser_printer.token_of_terminal
+
+      let nullable = Parser_explain.nullable
+    end)
+   (Dump)
+
+type 'a step =
+  | Correct of 'a I.checkpoint
+  | Recovering of 'a R.candidates
+
+type tree = [
+  | `Interface of Parsetree.signature
+  | `Implementation of Parsetree.structure
+]
+
+type steps =[
+  | `Signature of (Parsetree.signature step * Mreader_lexer.triple) list
+  | `Structure of (Parsetree.structure step * Mreader_lexer.triple) list
+]
+
+type t = {
+  kind: kind;
+  tree: tree;
+  steps: steps;
+  errors: exn list;
+  lexer: Mreader_lexer.t;
+}
+
+let eof_token = (Parser_raw.EOF, Lexing.dummy_pos, Lexing.dummy_pos)
+
+let errors_ref = ref []
+
+let resume_parse =
+  let rec normal acc tokens = function
+    | I.InputNeeded env as checkpoint ->
+      let token, tokens = match tokens with
+        | token :: tokens -> token, tokens
+        | [] -> eof_token, []
+      in
+      check_for_error acc token tokens env (I.offer checkpoint token)
+
+    | I.Shifting (_,env,_) | I.AboutToReduce (env,_) as checkpoint ->
+      begin match I.resume checkpoint with
+        | checkpoint' -> normal acc tokens checkpoint'
+        | exception exn ->
+          Msupport.raise_error exn;
+          let token = match acc with
+            | [] -> assert false
+            (* Parser raised error before parsing anything *)
+            | (_, token) :: _ -> token
+          in
+          enter_error acc token tokens env
+      end
+
+    | I.Accepted v -> acc, v
+
+    | I.Rejected | I.HandlingError _ ->
+      assert false
+
+  and check_for_error acc token tokens env = function
+    | I.HandlingError _ ->
+      enter_error acc token tokens env
+
+    | I.Shifting _ | I.AboutToReduce _ as checkpoint ->
+      begin match I.resume checkpoint with
+        | checkpoint' -> check_for_error acc token tokens env checkpoint'
+        | exception exn ->
+          Msupport.raise_error exn;
+          enter_error acc token tokens env
+      end
+
+    | checkpoint ->
+      normal ((Correct checkpoint, token) :: acc) tokens checkpoint
+
+  and enter_error acc token tokens env =
+    let candidates = R.generate env in
+    let explanation =
+      Mreader_explain.explain env token
+        candidates.R.popped candidates.R.shifted
+    in
+    errors_ref := Mreader_explain.Syntax_explanation explanation :: !errors_ref;
+    recover acc (token :: tokens) candidates
+
+  and recover acc tokens candidates =
+    let token, tokens = match tokens with
+      | token :: tokens -> token, tokens
+      | [] -> eof_token, []
+    in
+    let acc' = ((Recovering candidates, token) :: acc) in
+    match R.attempt candidates token with
+    | `Fail ->
+      if tokens = [] then
+        match candidates.R.final with
+        | None -> failwith "Empty file"
+        | Some v -> acc', v
+      else
+        recover acc tokens candidates
+    | `Accept v -> acc', v
+    | `Ok (checkpoint, _) ->
+      normal ((Correct checkpoint, token) :: acc) tokens checkpoint
+  in
+  fun acc tokens -> function
+  | Correct checkpoint -> normal acc tokens checkpoint
+  | Recovering candidates -> recover acc tokens candidates
+
+let seek_step steps tokens =
+  let rec aux acc = function
+    | (step :: steps), (token :: tokens) when snd step = token ->
+      aux (step :: acc) (steps, tokens)
+    | _, tokens -> acc, tokens
+  in
+  aux [] (steps, tokens)
+
+let parse initial steps tokens initial_pos =
+  let acc, tokens = seek_step steps tokens in
+  let step =
+    match acc with
+    | (step, _) :: _ -> step
+    | [] -> Correct (initial initial_pos)
+  in
+  let acc, result = resume_parse acc tokens step in
+  List.rev acc, result
+
+let run_parser warnings lexer previous kind =
+  Msupport.catch_errors warnings errors_ref @@ fun () ->
+  let tokens = Mreader_lexer.tokens lexer in
+  let initial_pos = Mreader_lexer.initial_position lexer in
+  match kind with
+  | ML  ->
+    let steps = match previous with
+      | `Structure steps -> steps
+      | _ -> []
+    in
+    let steps, result =
+      let state = Parser_raw.Incremental.implementation in
+      parse state steps tokens initial_pos in
+    `Structure steps, `Implementation result
+  | MLI ->
+    let steps = match previous with
+      | `Signature steps -> steps
+      | _ -> []
+    in
+    let steps, result =
+      let state = Parser_raw.Incremental.interface in
+      parse state steps tokens initial_pos in
+    `Signature steps, `Interface result
+
+let make warnings lexer kind =
+  errors_ref := [];
+  let steps, tree = run_parser warnings lexer `None kind in
+  let errors = !errors_ref in
+  errors_ref := [];
+  {kind; steps; tree; errors; lexer}
+
+let result t = t.tree
+
+let errors t = t.errors
diff --git a/src/kernel/mreader_parser.mli b/src/kernel/mreader_parser.mli
new file mode 100644
index 0000000..d2b9ebf
--- /dev/null
+++ b/src/kernel/mreader_parser.mli
@@ -0,0 +1,45 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+type kind =
+  | ML
+  | MLI
+  (*| MLL | MLY*)
+
+type t
+
+val make : Warnings.state -> Mreader_lexer.t -> kind -> t
+
+type tree = [
+  | `Interface of Parsetree.signature
+  | `Implementation of Parsetree.structure
+]
+
+val result : t -> tree
+
+val errors : t -> exn list
diff --git a/src/kernel/mreader_recover.ml b/src/kernel/mreader_recover.ml
new file mode 100644
index 0000000..4015905
--- /dev/null
+++ b/src/kernel/mreader_recover.ml
@@ -0,0 +1,283 @@
+open Std
+
+let {Logger. log} = Logger.for_section "Mreader_recover"
+
+module Make
+    (Parser : MenhirLib.IncrementalEngine.EVERYTHING)
+    (Recovery : sig
+       val default_value : Location.t -> 'a Parser.symbol -> 'a
+
+       type action =
+         | Abort
+         | R of int
+         | S : 'a Parser.symbol -> action
+         | Sub of action list
+
+       type decision =
+         | Nothing
+         | One of action list
+         | Select of (int -> action list)
+
+       val depth : int array
+
+       val recover : int -> decision
+
+       val guide : 'a Parser.symbol -> bool
+
+       val token_of_terminal : 'a Parser.terminal -> 'a -> Parser.token
+
+       val nullable : 'a Parser.nonterminal -> bool
+     end)
+    (Dump : sig
+       val symbol  : unit -> Parser.xsymbol -> string
+     end) =
+struct
+
+  type 'a candidate = {
+    line: int;
+    min_col: int;
+    max_col: int;
+    env: 'a Parser.env;
+  }
+
+  type 'a candidates = {
+    popped: Parser.xsymbol list;
+    shifted: Parser.xsymbol option;
+    final: 'a option;
+    candidates: 'a candidate list;
+  }
+
+  module T = struct
+    (* FIXME: this is a bit ugly. We should ask for the type to be exported
+       publicly by MenhirLib. *)
+
+    [@@@ocaml.warning "-37"]
+
+    type 'a checkpoint =
+      | InputNeeded of 'a Parser.env
+      | Shifting of 'a Parser.env * 'a Parser.env * bool
+      | AboutToReduce of 'a Parser.env * Parser.production
+      | HandlingError of 'a Parser.env
+      | Accepted of 'a
+      | Rejected
+    external inj : 'a checkpoint -> 'a Parser.checkpoint = "%identity"
+  end
+
+  (*let env_state env =
+    match Parser.top env with
+    | None -> -1
+    | Some (Parser.Element (state, _, _, _)) ->
+      Parser.number state*)
+
+  let feed_token ~allow_reduction token env =
+    let rec aux allow_reduction = function
+      | Parser.HandlingError _ | Parser.Rejected -> `Fail
+      | Parser.AboutToReduce _ when not allow_reduction -> `Fail
+      | Parser.Accepted v -> `Accept v
+      | Parser.Shifting _ | Parser.AboutToReduce _ as checkpoint ->
+        aux true (Parser.resume checkpoint)
+      | Parser.InputNeeded env as checkpoint -> `Recovered (checkpoint, env)
+    in
+    aux allow_reduction (Parser.offer (T.inj (T.InputNeeded env)) token)
+
+  let rec follow_guide col env = match Parser.top env with
+    | None -> col
+    | Some (Parser.Element (state, _, pos, _)) ->
+      if Recovery.guide (Parser.incoming_symbol state) then
+        match Parser.pop env with
+        | None -> col
+        | Some env -> follow_guide (snd (Lexing.split_pos pos)) env
+      else
+        col
+
+  let candidate env =
+    let line, min_col, max_col =
+      match Parser.top env with
+      | None -> 1, 0, 0
+      | Some (Parser.Element (state, _, pos, _)) ->
+        let depth = Recovery.depth.(Parser.number state) in
+        let line, col = Lexing.split_pos pos in
+        if depth = 0 then
+          line, col, col
+        else
+          let col' = match Parser.pop_many depth env with
+            | None -> max_int
+            | Some env ->
+              match Parser.top env with
+              | None -> max_int
+              | Some (Parser.Element (_, _, pos, _)) ->
+                follow_guide (snd (Lexing.split_pos pos)) env
+          in
+          line, min col col', max col col'
+    in
+    { line; min_col; max_col; env }
+
+  let attempt r token =
+    let _, startp, _ = token in
+    let line, col = Lexing.split_pos startp in
+    let more_indented candidate =
+      line <> candidate.line && candidate.min_col > col in
+    let recoveries = List.drop_while ~f:more_indented r.candidates in
+    let same_indented candidate =
+      line = candidate.line ||
+      (candidate.min_col <= col && col <= candidate.max_col)
+    in
+    let recoveries = List.take_while ~f:same_indented recoveries in
+    let rec aux = function
+      | [] -> `Fail
+      | x :: xs -> match feed_token ~allow_reduction:true token x.env with
+        | `Fail ->
+          (*if not (is_closed k) then
+            printf k "Couldn't resume %d with %S.\n"
+              (env_state x.env) (let (t,_,_) = token in Dump.token t);*)
+          aux xs
+        | `Recovered (checkpoint, _) -> `Ok (checkpoint, x.env)
+        | `Accept v ->
+          begin match aux xs with
+            | `Fail -> `Accept v
+            | x -> x
+          end
+    in
+    aux recoveries
+
+  let decide env =
+    let rec nth_state env n =
+      if n = 0 then
+        match Parser.top env with
+        | None -> -1 (*allow giving up recovery on empty files*)
+        | Some (Parser.Element (state, _, _, _)) -> Parser.number state
+      else
+        match Parser.pop env with
+        | None -> assert (n = 1); -1
+        | Some env -> nth_state env (n - 1)
+    in
+    let st = nth_state env 0 in
+    match Recovery.recover st with
+    | Recovery.Nothing -> []
+    | Recovery.One actions -> actions
+    | Recovery.Select f -> f (nth_state env Recovery.depth.(st))
+
+  let generate (type a) (env : a Parser.env) =
+    let module E = struct
+      exception Result of a
+    end in
+    let shifted = ref None in
+    let rec aux acc env =
+      match Parser.top env with
+      | None -> None, acc
+      | Some (Parser.Element (state, _, _startp, endp)) ->
+        (*Dump.element k elt;*)
+        log ~title:"decide state" "%d" (Parser.number state);
+        let actions = decide env in
+        let candidate0 = candidate env in
+        let rec eval (env : a Parser.env) : Recovery.action -> a Parser.env = function
+          | Recovery.Abort ->
+            log ~title:"eval Abort" "";
+            raise Not_found
+          | Recovery.R prod ->
+            log ~title:"eval Reduce" "";
+            let prod = Parser.find_production prod in
+            Parser.force_reduction prod env
+          | Recovery.S (Parser.N n as sym) ->
+            let xsym = Parser.X sym in
+            if !shifted = None && not (Recovery.nullable n) then
+              shifted := Some xsym;
+            log ~title:"eval Shift N" "%a" Dump.symbol xsym;
+            (* FIXME: if this is correct remove the fixme, otherwise use
+               [startp] *)
+            let loc = {Location. loc_start = endp; loc_end = endp; loc_ghost = true} in
+            let v = Recovery.default_value loc sym in
+            Parser.feed sym endp v endp env
+          | Recovery.S (Parser.T t as sym) ->
+            let xsym = Parser.X sym in
+            if !shifted = None then shifted := Some xsym;
+            log ~title:"eval Shift T" "%a" Dump.symbol xsym;
+            let loc = {Location. loc_start = endp; loc_end = endp; loc_ghost = true} in
+            let v = Recovery.default_value loc sym in
+            let token = (Recovery.token_of_terminal t v, endp, endp) in
+            begin match feed_token ~allow_reduction:true token env with
+              | `Fail -> assert false
+              | `Accept v -> raise (E.Result v)
+              | `Recovered (_,env) -> env
+            end
+          | Recovery.Sub actions ->
+            log ~title:"enter Sub" "";
+            let env = List.fold_left ~f:eval ~init:env actions in
+            log ~title:"leave Sub" "";
+            env
+        in
+        match
+          List.rev_scan_left [] ~f:eval ~init:env actions
+          |> List.map ~f:(fun env -> {candidate0 with env})
+        with
+        | exception Not_found -> None, acc
+        | exception (E.Result v) -> Some v, acc
+        | [] -> None, acc
+        | (candidate :: _) as candidates ->
+          aux (candidates @ acc) candidate.env
+    in
+    let popped = ref [] in
+    (*let should_pop stack =
+      let Parser.Element (state, _, _, _) = Parser.stack_element stack in
+      match Parser.incoming_symbol state with
+      | (Parser.T term) as t1 when Recovery.can_pop term ->
+        log "Pop" "pop %s"
+          (Dump.symbol (Parser.X t1));
+        begin match Parser.stack_next stack with
+          | None -> false
+          | Some stack' ->
+            let rec check_next = function
+              | Recovery.S (Parser.T term' as t2) :: _
+                when Parser.X t1 = Parser.X t2 ->
+                false
+              | Recovery.S sym :: _ ->
+                log "Pop" "then push %s"
+                  (Dump.symbol (Parser.X sym));
+                popped := Parser.X t1 :: !popped;
+                true
+              | Recovery.Sub xs :: _ ->
+                check_next xs
+              | _ ->
+                popped := Parser.X t1 :: !popped;
+                true
+            in
+            check_next (decide stack')
+        end
+      | _ -> false
+      in*)
+    let final, candidates = aux [] env in
+    (List.rev !popped, !shifted, final, candidates)
+
+  let generate env =
+    let popped, shifted, final, candidates = generate env in
+    let candidates = List.rev_filter candidates
+        ~f:(fun t -> not (Parser.env_has_default_reduction t.env))
+    in
+    { popped; shifted; final; candidates = (candidate env) :: candidates }
+
+  (*let dump {Nav. nav; body; _} ~wrong:(t,s,_ as token) ~rest:tokens env =
+    if not (is_closed body) then (
+      let l, c = Lexing.split_pos s in
+      printf body "Unexpected %S at %d:%d, " (Dump.token t) l c;
+      link body "see recoveries"
+        (fun _ -> Nav.push nav "Recoveries" @@ fun {Nav. body; _} ->
+          let r = generate body env in
+          let rec aux = function
+            | [] -> ()
+            | token :: tokens ->
+              match attempt body r token with
+              | `Fail -> aux tokens
+              | `Accept _ ->
+                text body "\nCouldn't resume, generated final AST.\n"
+              | `Ok (_, recovered_from) ->
+                printf body "\nResumed with %S from:\n"
+                  (let (t,_,_) = token in Dump.token t);
+                Dump.env body recovered_from
+          in
+          aux (token :: tokens)
+        );
+      text body ".\n";
+      Dump.env body env;
+      text body "\n"
+    )*)
+end
diff --git a/src/kernel/mreader_recover.mli b/src/kernel/mreader_recover.mli
new file mode 100644
index 0000000..5cf5c0a
--- /dev/null
+++ b/src/kernel/mreader_recover.mli
@@ -0,0 +1,56 @@
+module Make
+    (Parser : MenhirLib.IncrementalEngine.EVERYTHING)
+    (Recovery : sig
+       val default_value : Location.t -> 'a Parser.symbol -> 'a
+
+       type action =
+         | Abort
+         | R of int
+         | S : 'a Parser.symbol -> action
+         | Sub of action list
+
+       type decision =
+         | Nothing
+         | One of action list
+         | Select of (int -> action list)
+
+       val depth : int array
+
+       val can_pop : 'a Parser.terminal -> bool
+
+       val recover : int -> decision
+
+       val guide : 'a Parser.symbol -> bool
+
+       val token_of_terminal : 'a Parser.terminal -> 'a -> Parser.token
+
+       val nullable : 'a Parser.nonterminal -> bool
+     end)
+    (Dump : sig
+       val symbol  : unit -> Parser.xsymbol -> string
+     end) :
+sig
+
+  type 'a candidate = {
+    line: int;
+    min_col: int;
+    max_col: int;
+    env: 'a Parser.env;
+  }
+
+  type 'a candidates = {
+    popped: Parser.xsymbol list;
+    shifted: Parser.xsymbol option;
+    final: 'a option;
+    candidates: 'a candidate list;
+  }
+
+  val attempt : 'a candidates ->
+    Parser.token * Lexing.position * Lexing.position ->
+    [> `Accept of 'a
+    | `Fail
+    | `Ok of 'a Parser.checkpoint * 'a Parser.env ]
+
+  val generate : 'a Parser.env -> 'a candidates
+
+end
diff --git a/src/kernel/msource.ml b/src/kernel/msource.ml
new file mode 100644
index 0000000..f8991e9
--- /dev/null
+++ b/src/kernel/msource.ml
@@ -0,0 +1,149 @@
+(* Merlin representation of a textual source code *)
+open Std
+
+let {Logger. log} = Logger.for_section "Msource"
+
+type t = {
+  text: string;
+}
+
+let dump t = `Assoc [
+    "text"     , `String t.text;
+  ]
+
+let print_position () = function
+  | `Start -> "start"
+  | `Offset o -> string_of_int o
+  | `Logical (l,c) -> string_of_int l ^ ":" ^ string_of_int c
+  | `End -> "end"
+
+let make text = {text}
+
+(* Position management *)
+
+type position = [
+  | `Start
+  | `Offset of int
+  | `Logical of int * int
+  | `End
+]
+
+exception Found of int
+
+let find_line line {text} =
+  if line <= 0 then
+    Printf.ksprintf invalid_arg
+      "Msource.find_line: invalid line number %d. \
+       Numbering starts from 1" line;
+  if line = 1 then 0 else
+    let line' = ref line in
+    try
+      for i = 0 to String.length text - 1 do
+        if text.[i] = '\n' then begin
+          decr line';
+          if !line' = 1 then
+            raise (Found i);
+        end
+      done;
+      log ~title:"find_line" "line %d out of bounds (max = %d)"
+        line (line - !line');
+      String.length text
+    with Found n ->
+      n + 1
+
+let find_offset ({text} as t) line col =
+  assert (col >= 0);
+  let offset = find_line line t in
+  if col = 0 then offset else
+    try
+      for i = offset to min (offset + col) (String.length text) - 1 do
+        if text.[i] = '\n' then begin
+          log ~title:"find_offset"
+            "%d:%d out of line bounds, line %d only has %d columns"
+            line col line (i - offset);
+          raise (Found i)
+        end
+      done;
+      if (offset + col) > (String.length text) then begin
+        log ~title:"find_offset" "%d:%d out of file bounds" line col
+      end;
+      offset + col
+    with Found off -> off
+
+let get_offset t = function
+  | `Start -> `Offset 0
+  | `Offset x ->
+    assert (x >= 0);
+    if x <= String.length t.text then
+      (`Offset x)
+    else begin
+      log ~title:"get_offset"
+        "offset %d out of bounds (size is %d)" x (String.length t.text);
+      (`Offset (String.length t.text))
+    end
+  | `End ->
+    `Offset (String.length t.text)
+  | `Logical (line, col) ->
+    `Offset (find_offset t line col)
+
+let get_logical {text} = function
+  | `Start -> `Logical (1, 0)
+  | `Logical _ as p -> p
+  | `Offset _ | `End as r ->
+    let len = String.length text in
+    let offset = match r with
+      | `Offset x when x > len ->
+        log ~title:"get_logical" "offset %d out of bounds (size is %d)" x len;
+        len
+      | `Offset x ->
+        assert (x >= 0);
+        x
+      | `End -> len
+    in
+    let line = ref 1 in
+    let cnum = ref 0 in
+    for i = 0 to offset - 1 do
+      if text.[i] = '\n' then begin
+        incr line;
+        cnum := i + 1;
+      end;
+    done;
+    `Logical (!line, offset - !cnum)
+
+let get_lexing_pos t ~filename pos =
+  let `Offset o = get_offset t pos in
+  let `Logical (line, col) = get_logical t pos in
+  { Lexing.
+    pos_fname = filename;
+    pos_lnum = line;
+    pos_bol  = o - col;
+    pos_cnum = o;
+  }
+
+let substitute t starting ending text =
+  let len = String.length t.text in
+  let `Offset starting = get_offset t starting in
+  let `Offset ending = match ending with
+    | `End -> `Offset len
+    | `Length l ->
+      if starting + l <= len then
+        `Offset (starting + l)
+      else begin
+        log ~title:"substitute"
+          "offset %d + length %d out of bounds (size is %d)" starting l len;
+        `Offset len
+      end
+    | #position as p -> get_offset t p
+  in
+  if ending < starting then
+    invalid_arg "Source.substitute: ending < starting";
+  let text =
+    String.sub t.text ~pos:0 ~len:starting ^
+    text ^
+    String.sub t.text ~pos:ending ~len:(len - ending)
+  in
+  {text}
+
+(* Accessing content *)
+
+let text t = t.text
diff --git a/src/kernel/msource.mli b/src/kernel/msource.mli
new file mode 100644
index 0000000..e8e2bbe
--- /dev/null
+++ b/src/kernel/msource.mli
@@ -0,0 +1,36 @@
+(** {0 Merlin representation of a textual source code}
+
+    It bundles filename and a content, and offers functions for computing
+    positions in the source.
+*)
+type t
+
+(** Making a content from name and contents. *)
+val make : string -> t
+
+(** {1 Position management} *)
+
+type position = [
+  | `Start
+  | `Offset of int
+  | `Logical of int * int
+  | `End
+]
+
+val get_offset     : t -> [< position] -> [> `Offset of int]
+
+val get_logical    : t -> [< position] -> [> `Logical of int * int]
+
+val get_lexing_pos : t -> filename:string -> [< position] -> Lexing.position
+
+(** {1 Managing content} *)
+
+(** Updating content *)
+val substitute : t -> [< position] -> [< position | `Length of int] -> string -> t
+
+(** Source code of the file *)
+val text : t -> string
+
+val dump : t -> Std.json
+
+val print_position : unit -> [< position] -> string
diff --git a/src/kernel/mtyper.ml b/src/kernel/mtyper.ml
new file mode 100644
index 0000000..986b9b7
--- /dev/null
+++ b/src/kernel/mtyper.ml
@@ -0,0 +1,208 @@
+open Std
+open Local_store
+
+let {Logger. log} = Logger.for_section "Mtyper"
+
+type ('p,'t) item = {
+  parsetree_item: 'p;
+  typedtree_items: 't list * Types.signature_item list;
+  part_snapshot  : Btype.snapshot;
+  part_env       : Env.t;
+  part_errors    : exn list;
+  part_checks    : Typecore.delayed_check list;
+  part_warnings  : Warnings.state;
+}
+
+type typedtree = [
+  | `Interface of Typedtree.signature
+  | `Implementation of Typedtree.structure
+]
+
+let cache = s_ref None
+
+let fresh_env config =
+  let env0 = Typer_raw.fresh_env () in
+  let env0 = Extension.register Mconfig.(config.merlin.extensions) env0 in
+  let snap0 = Btype.snapshot () in
+  (env0, snap0)
+
+let get_cache config =
+  match !cache with
+  | Some (env0, snap0, items) when Btype.is_valid snap0 ->
+    env0, snap0, Some items
+  | Some _ | None ->
+    let env0, snap0 = fresh_env config in
+    env0, snap0, None
+
+let return_and_cache status =
+  cache := Some status;
+  status
+
+type result = {
+  config : Mconfig.t;
+  initial_env : Env.t;
+  initial_snapshot : Btype.snapshot;
+  typedtree : [
+    | `Interface of
+        (Parsetree.signature_item, Typedtree.signature_item) item list
+    | `Implementation of
+        (Parsetree.structure_item, Typedtree.structure_item) item list
+  ];
+}
+
+let compatible_prefix result_items tree_items =
+  let rec aux acc = function
+    | (ritem :: ritems, pitem :: pitems)
+      when Btype.is_valid ritem.part_snapshot
+        && compare ritem.parsetree_item pitem = 0 ->
+      aux (ritem :: acc) (ritems, pitems)
+    | (_, pitems) ->
+      log ~title:"compatible_prefix" "reusing %d items, %d new items to type"
+        (List.length acc) (List.length pitems);
+      acc, pitems
+  in
+  aux [] (result_items, tree_items)
+
+let rec type_structure caught env = function
+  | parsetree_item :: rest ->
+    let items, _, part_env =
+      Typemod.merlin_type_structure env [parsetree_item]
+    in
+    let typedtree_items =
+      (items.Typedtree.str_items, items.Typedtree.str_type) in
+    let item = {
+      parsetree_item; typedtree_items; part_env;
+      part_snapshot = Btype.snapshot ();
+      part_errors   = !caught;
+      part_checks   = !Typecore.delayed_checks;
+      part_warnings = Warnings.backup ();
+    } in
+    item :: type_structure caught part_env rest
+  | [] -> []
+
+let rec type_signature caught env = function
+  | parsetree_item :: rest ->
+    let {Typedtree. sig_final_env = part_env; sig_items; sig_type} =
+      Typemod.merlin_transl_signature env [parsetree_item] in
+    let item = {
+      parsetree_item; typedtree_items = (sig_items, sig_type); part_env;
+      part_snapshot = Btype.snapshot ();
+      part_errors   = !caught;
+      part_checks   = !Typecore.delayed_checks;
+      part_warnings = Warnings.backup ();
+    } in
+    item :: type_signature caught part_env rest
+  | [] -> []
+
+let type_implementation config caught parsetree =
+  let env0, snap0, prefix = get_cache config in
+  let prefix, parsetree =
+    match prefix with
+    | Some (`Implementation items) -> compatible_prefix items parsetree
+    | Some (`Interface _) | None -> ([], parsetree)
+  in
+  let env', snap', warn' = match prefix with
+    | [] -> (env0, snap0, Warnings.backup ())
+    | x :: _ ->
+      caught := x.part_errors;
+      Typecore.delayed_checks := x.part_checks;
+      (x.part_env, x.part_snapshot, x.part_warnings)
+  in
+  Btype.backtrack snap';
+  Warnings.restore warn';
+  let suffix = type_structure caught env' parsetree in
+  return_and_cache
+    (env0, snap0, `Implementation (List.rev_append prefix suffix))
+
+let type_interface config caught parsetree =
+  let env0, snap0, prefix = get_cache config in
+  let prefix, parsetree =
+    match prefix with
+    | Some (`Interface items) -> compatible_prefix items parsetree
+    | Some (`Implementation _) | None -> ([], parsetree)
+  in
+  let env', snap', warn' = match prefix with
+    | [] -> (env0, snap0, Warnings.backup ())
+    | x :: _ ->
+      caught := x.part_errors;
+      Typecore.delayed_checks := x.part_checks;
+      (x.part_env, x.part_snapshot, x.part_warnings)
+  in
+  Btype.backtrack snap';
+  Warnings.restore warn';
+  let suffix = type_signature caught env' parsetree in
+  return_and_cache
+    (env0, snap0, `Interface (List.rev_append prefix suffix))
+
+let run config parsetree =
+  if not (Env.check_state_consistency ()) then (
+    (* Resetting the local store will clear the load_path cache.
+       Save it now, reset the store and then restore the path. *)
+    let load_path = Load_path.get_paths () in
+    Mocaml.flush_caches ();
+    Local_store.reset ();
+    Load_path.reset ();
+    Load_path.init load_path;
+  );
+  let caught = ref [] in
+  Msupport.catch_errors Mconfig.(config.ocaml.warnings) caught @@ fun () ->
+  Typecore.reset_delayed_checks ();
+  let initial_env, initial_snapshot, typedtree = match parsetree with
+    | `Implementation parsetree -> type_implementation config caught parsetree
+    | `Interface parsetree -> type_interface config caught parsetree
+  in
+  Typecore.reset_delayed_checks ();
+  { config; initial_env; initial_snapshot; typedtree }
+
+let get_env ?pos:_ t =
+  Option.value ~default:t.initial_env (
+    match t.typedtree with
+    | `Implementation l -> Option.map ~f:(fun x -> x.part_env) (List.last l)
+    | `Interface l ->  Option.map ~f:(fun x -> x.part_env) (List.last l)
+  )
+
+let get_errors t =
+  let errors, checks = Option.value ~default:([],[]) (
+      let f x = x.part_errors, x.part_checks in
+      match t.typedtree with
+      | `Implementation l -> Option.map ~f (List.last l)
+      | `Interface l ->  Option.map ~f (List.last l)
+    )
+  in
+  let caught = ref errors in
+  Typecore.delayed_checks := checks;
+  Msupport.catch_errors Mconfig.(t.config.ocaml.warnings) caught
+    Typecore.force_delayed_checks;
+  Typecore.reset_delayed_checks ();
+  (!caught)
+
+let get_typedtree t =
+  let split_items l =
+    let typd, typs = List.split (List.map ~f:(fun x -> x.typedtree_items) l) in
+    (List.concat typd, List.concat typs)
+  in
+  match t.typedtree with
+  | `Implementation l ->
+    let str_items, str_type = split_items l in
+    `Implementation {Typedtree. str_items; str_type; str_final_env = get_env t}
+  | `Interface l ->
+    let sig_items, sig_type = split_items l in
+    `Interface {Typedtree. sig_items; sig_type; sig_final_env = get_env t}
+
+let node_at ?(skip_recovered=false) t pos_cursor =
+  let node = Mbrowse.of_typedtree (get_typedtree t) in
+  log ~title:"node_at" "Node: %s" (Mbrowse.print () node);
+  let rec select = function
+    (* If recovery happens, the incorrect node is kept and a recovery node
+       is introduced, so the node to check for recovery is the second one. *)
+    | (_,_) :: ((_,node') :: _ as ancestors)
+      when Mbrowse.is_recovered node' -> select ancestors
+    | l -> l
+  in
+  match Mbrowse.deepest_before pos_cursor [node] with
+  | [] -> [get_env t, Browse_raw.Dummy]
+  | path when skip_recovered -> select path
+  | path ->
+    log ~title:"node_at" "Deepest before %s"
+      (Mbrowse.print () path);
+    path
diff --git a/src/kernel/mtyper.mli b/src/kernel/mtyper.mli
new file mode 100644
index 0000000..b667e63
--- /dev/null
+++ b/src/kernel/mtyper.mli
@@ -0,0 +1,40 @@
+(** {1 Result of typechecker}
+
+    [Mtyper] essentially produces a typedtree, but to make sense of it
+    the OCaml typechecker need to be in a specific state.
+
+    The [result] type wraps a snapshot of this state with the typedtree to
+    ensure correct accesses.
+*)
+
+type result
+
+type typedtree = [
+  | `Interface of Typedtree.signature
+  | `Implementation of Typedtree.structure
+]
+
+val run : Mconfig.t -> Mreader.parsetree -> result
+
+val get_env : ?pos:Msource.position -> result -> Env.t
+
+val get_typedtree : result -> typedtree
+
+val get_errors : result -> exn list
+
+(** Heuristic to find suitable environment to complete / type at given position.
+ *  1. Try to find environment near given cursor.
+ *  2. Check if there is an invalid construct between found env and cursor :
+ *    Case a.
+ *      > let x = valid_expr ||
+ *      The env found is the right most env from valid_expr, it's a correct
+ *      answer.
+ *    Case b.
+ *      > let x = valid_expr
+ *      > let y = invalid_construction||
+ *      In this case, the env found is the same as in case a, however it is
+ *      preferable to use env from enclosing module rather than an env from
+ *      inside x definition.
+ *)
+val node_at :
+  ?skip_recovered:bool -> result -> Lexing.position -> Mbrowse.t
diff --git a/src/ocaml/driver/pparse.ml b/src/ocaml/driver/pparse.ml
new file mode 100644
index 0000000..4a60742
--- /dev/null
+++ b/src/ocaml/driver/pparse.ml
@@ -0,0 +1,201 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*        Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt     *)
+(*                                                                     *)
+(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+open Std
+
+let {Logger. log} = Logger.for_section "Pparse"
+
+type error =
+  | CannotRun of string
+  | WrongMagic of string
+
+(* Note: some of the functions here should go to Ast_mapper instead,
+   which would encapsulate the "binary AST" protocol. *)
+
+let write_ast magic ast =
+  let fn = Filename.temp_file "camlppx" "" in
+  let oc = open_out_bin fn in
+  output_string oc magic;
+  output_value oc !Location.input_name;
+  output_value oc ast;
+  close_out oc;
+  fn
+
+let report_error = function
+  | CannotRun cmd ->
+    log ~title:"report_error"
+      "Error while running external preprocessor. Command line: %s" cmd
+  | WrongMagic cmd ->
+    log ~title:"report_error"
+      "External preprocessor does not produce a valid file. Command line: %s" cmd
+
+external merlin_system_command : string -> int = "ml_merlin_system_command"
+
+let ppx_commandline cmd fn_in fn_out =
+  Printf.sprintf "%s %s %s%s"
+    cmd (Filename.quote fn_in) (Filename.quote fn_out)
+    (if Sys.win32 then "" else " 1>&2")
+
+let apply_rewriter magic ppx (fn_in, failures) =
+  let title = "apply_rewriter" in
+  let fn_out = Filename.temp_file "camlppx" "" in
+  let comm = ppx_commandline ppx.workval fn_in fn_out in
+  log ~title "running %s from directory %S" comm ppx.workdir;
+  Logger.log_flush ();
+  begin
+    try Sys.chdir ppx.workdir
+    with exn ->
+      log ~title "cannot change directory %S: %a" ppx.workdir Logger.exn exn
+  end;
+  let failure =
+    let ok = merlin_system_command comm = 0 in
+    if not ok then Some (CannotRun comm)
+    else if not (Sys.file_exists fn_out) then
+      Some (WrongMagic comm)
+    else
+      (* check magic before passing to the next ppx *)
+      let ic = open_in_bin fn_out in
+      let buffer =
+        try really_input_string ic (String.length magic)
+        with End_of_file -> ""
+      in
+      close_in ic;
+      if buffer <> magic then
+        Some (WrongMagic comm)
+      else
+        None
+  in
+  match failure with
+  | Some err ->
+    Misc.remove_file fn_out;
+    let fallback =
+      let fallback =
+        Filename.concat (Filename.get_temp_dir_name ())
+          ("camlppx.lastfail" ^ string_of_int failures)
+      in
+      match Sys.rename fn_in fallback with
+      | () -> fallback
+      | exception exn ->
+        log ~title "exception while renaming ast: %a"
+          Logger.exn exn;
+        fn_in
+    in
+    report_error err;
+    (fallback, failures + 1)
+  | None ->
+    Misc.remove_file fn_in;
+    (fn_out, failures)
+
+let read_ast magic fn =
+  let ic = open_in_bin fn in
+  try
+    let buffer = really_input_string ic (String.length magic) in
+    assert(buffer = magic); (* already checked by apply_rewriter *)
+    Location.input_name := input_value ic;
+    let ast = input_value ic in
+    close_in ic;
+    Misc.remove_file fn;
+    ast
+  with exn ->
+    close_in ic;
+    Misc.remove_file fn;
+    raise exn
+
+let rewrite magic ast ppxs =
+  let fn_out, _ =
+    List.fold_right
+      ~f:(apply_rewriter magic) ~init:(write_ast magic ast, 0) ppxs
+  in
+  read_ast magic fn_out
+
+
+let apply_rewriters_str ~ppx ?(restore = true) ~tool_name ast =
+  match ppx with
+  | [] -> ast
+  | ppxs ->
+      let ast = Ast_mapper.add_ppx_context_str ~tool_name ast in
+      let ast = rewrite Config.ast_impl_magic_number ast ppxs in
+      Ast_mapper.drop_ppx_context_str ~restore ast
+
+let apply_rewriters_sig ~ppx ?(restore = true) ~tool_name ast =
+  match ppx with
+  | [] -> ast
+  | ppxs ->
+      let ast = Ast_mapper.add_ppx_context_sig ~tool_name ast in
+      let ast = rewrite Config.ast_intf_magic_number ast ppxs in
+      Ast_mapper.drop_ppx_context_sig ~restore ast
+
+let apply_rewriters ~ppx ?restore ~tool_name = function
+  | `Interface ast ->
+    `Interface (apply_rewriters_sig ~ppx ?restore ~tool_name ast)
+  | `Implementation ast ->
+    `Implementation (apply_rewriters_str ~ppx ?restore ~tool_name ast)
+
+let pp_commandline cmd fn_in fn_out =
+  Printf.sprintf "%s %s 1>%s"
+    cmd (Filename.quote fn_in) (Filename.quote fn_out)
+
+(* FIXME: remove this once we drop support for 4.02 *)
+type ('a, 'b) res = Ok of 'a | Error of 'b
+
+let apply_pp ~workdir ~filename ~source ~pp =
+  let fn_in = Filename.temp_file "merlinpp" (Filename.basename filename) in
+  begin
+    try Sys.chdir workdir
+    with exn ->
+      log ~title:"apply_pp" "cannot change directory %S: %a"
+        workdir Logger.exn exn
+  end;
+  begin
+    let oc = open_out_bin fn_in in
+    output_string oc source;
+    close_out oc
+  end;
+  let fn_out = fn_in ^ ".out" in
+  let comm = pp_commandline pp fn_in fn_out in
+  let ok = merlin_system_command comm = 0 in
+  Misc.remove_file fn_in;
+  if not ok then begin
+    Misc.remove_file fn_out;
+    Error (CannotRun comm)
+  end else if not (Sys.file_exists fn_out) then
+    Error (WrongMagic comm)
+  else
+    let ic = open_in fn_out in
+    let result = Misc.string_of_file ic in
+    close_in ic;
+    Ok result
+
+let decode_potential_ast source =
+  let decoder =
+    if Std.String.is_prefixed ~by:Config.ast_impl_magic_number source then
+      Some (fun x -> `Implementation (Obj.obj x : Parsetree.structure))
+    else if Std.String.is_prefixed ~by:Config.ast_intf_magic_number source then
+      Some (fun x -> `Interface (Obj.obj x : Parsetree.signature))
+    else
+      None
+  in
+  match decoder with
+  | None -> `Source source
+  | Some inj ->
+    let offset = String.length Config.ast_impl_magic_number in
+    Location.input_name := Marshal.from_string source offset;
+    let offset = offset + Marshal.total_size (Bytes.unsafe_of_string source) offset in
+    let ast = Marshal.from_string source offset in
+    inj ast
+
+let apply_pp ~workdir ~filename ~source ~pp =
+  match apply_pp ~workdir ~filename ~source ~pp with
+  | Ok result -> decode_potential_ast result
+  | Error err ->
+    report_error err;
+    `Source source
diff --git a/src/ocaml/driver/pparse.mli b/src/ocaml/driver/pparse.mli
new file mode 100644
index 0000000..2f3ea5b
--- /dev/null
+++ b/src/ocaml/driver/pparse.mli
@@ -0,0 +1,24 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*        Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt     *)
+(*                                                                     *)
+(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+open Std
+
+(** If [restore = true] (the default), cookies set by external rewriters will be
+    kept for later calls. *)
+
+val apply_rewriters_str: ppx:string with_workdir list -> ?restore:bool -> tool_name:string -> Parsetree.structure -> Parsetree.structure
+val apply_rewriters_sig: ppx:string with_workdir list -> ?restore:bool -> tool_name:string -> Parsetree.signature -> Parsetree.signature
+
+val apply_rewriters: ppx:string with_workdir list -> ?restore:bool -> tool_name:string -> Mreader.parsetree -> Mreader.parsetree
+
+val apply_pp : workdir:string -> filename:string -> source:string -> pp:string ->
+  [ `Implementation of Parsetree.structure | `Interface of Parsetree.signature | `Source of string ]
diff --git a/src/ocaml/merlin_specific/browse_raw.ml b/src/ocaml/merlin_specific/browse_raw.ml
new file mode 100644
index 0000000..40b27ae
--- /dev/null
+++ b/src/ocaml/merlin_specific/browse_raw.ml
@@ -0,0 +1,968 @@
+(* {{{ Copying *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2017  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+[@@@ocaml.warning "-9"]
+
+open Std
+
+type constructor_declaration = Typedtree.constructor_declaration
+
+open Typedtree
+
+type node =
+  | Dummy
+  | Pattern                  : _ general_pattern -> node
+  | Expression               of expression
+  | Case                     : _ case -> node
+  | Class_expr               of class_expr
+  | Class_structure          of class_structure
+  | Class_field              of class_field
+  | Class_field_kind         of class_field_kind
+  | Module_expr              of module_expr
+  | Module_type_constraint   of module_type_constraint
+  | Structure                of structure
+  | Signature                of signature
+  | Structure_item           of structure_item * Env.t
+  | Signature_item           of signature_item * Env.t
+  | Module_binding           of module_binding
+  | Value_binding            of value_binding
+  | Module_type              of module_type
+  | Module_declaration       of module_declaration
+  | Module_type_declaration  of module_type_declaration
+  | With_constraint          of with_constraint
+  | Core_type                of core_type
+  | Package_type             of package_type
+  | Row_field                of row_field
+  | Value_description        of value_description
+  | Type_declaration         of type_declaration
+  | Type_kind                of type_kind
+  | Type_extension           of type_extension
+  | Extension_constructor    of extension_constructor
+  | Label_declaration        of label_declaration
+  | Constructor_declaration  of constructor_declaration
+  | Class_type               of class_type
+  | Class_signature          of class_signature
+  | Class_type_field         of class_type_field
+  | Class_declaration        of class_declaration
+  | Class_description        of class_description
+  | Class_type_declaration   of class_type_declaration
+
+  | Include_description      of include_description
+  | Include_declaration      of include_declaration
+  | Open_description         of open_description
+  | Open_declaration         of open_declaration
+
+  | Method_call              of expression * meth * Location.t
+  | Record_field             of [`Expression of expression | `Pattern of pattern]
+                                * Types.label_description
+                                * Longident.t Location.loc
+  | Module_binding_name      of module_binding
+  | Module_declaration_name  of module_declaration
+  | Module_type_declaration_name of module_type_declaration
+
+let node_update_env env0 = function
+  | Pattern        {pat_env = env}  | Expression     {exp_env = env}
+  | Class_expr     {cl_env = env}   | Method_call    ({exp_env = env}, _, _)
+  | Record_field   (`Expression {exp_env = env}, _, _)
+  | Record_field   (`Pattern {pat_env = env}, _, _)
+  | Module_expr    {mod_env = env}  | Module_type    {mty_env = env}
+  | Structure_item (_, env)         | Signature_item (_, env)
+  | Core_type      {ctyp_env = env} | Class_type     {cltyp_env = env}
+    -> env
+  | Dummy                     | Case                    _
+  | Class_structure         _ | Class_signature         _
+  | Class_field             _ | Class_field_kind        _
+  | Type_extension          _ | Extension_constructor   _
+  | Package_type            _ | Row_field               _
+  | Type_declaration        _ | Type_kind               _
+  | Module_binding          _ | Module_declaration      _
+  | Module_binding_name     _ | Module_declaration_name _
+  | Module_type_declaration _ | Module_type_constraint  _
+  | Module_type_declaration_name _ | With_constraint    _
+  | Structure               _ | Signature               _
+  | Value_description       _ | Value_binding           _
+  | Constructor_declaration _ | Label_declaration       _
+  | Class_declaration       _ | Class_description       _
+  | Class_type_declaration  _ | Class_type_field        _
+  | Include_description     _ | Include_declaration     _
+  | Open_description        _ | Open_declaration        _
+    -> env0
+
+let node_real_loc loc0 = function
+  | Expression              {exp_loc = loc}
+  | Pattern                 {pat_loc = loc}
+  | Method_call             (_, _, loc)
+  | Record_field            (_, _, {loc})
+  | Class_expr              {cl_loc = loc}
+  | Module_expr             {mod_loc = loc}
+  | Structure_item          ({str_loc = loc}, _)
+  | Signature_item          ({sig_loc = loc}, _)
+  | Module_type             {mty_loc = loc}
+  | Core_type               {ctyp_loc = loc}
+  | Class_type              {cltyp_loc = loc}
+  | Class_field             {cf_loc = loc}
+  | Module_binding          {mb_loc = loc}
+  | Module_declaration      {md_loc = loc}
+  | Module_type_declaration {mtd_loc = loc}
+  | Value_description       {val_loc = loc}
+  | Value_binding           {vb_loc = loc}
+  | Type_declaration        {typ_loc = loc}
+  | Label_declaration       {ld_loc = loc}
+  | Constructor_declaration {cd_loc = loc}
+  | Class_type_field        {ctf_loc = loc}
+  | Class_declaration       {ci_loc = loc}
+  | Class_description       {ci_loc = loc}
+  | Class_type_declaration  {ci_loc = loc}
+  | Extension_constructor   {ext_loc = loc}
+  | Include_description     {incl_loc = loc}
+  | Include_declaration     {incl_loc = loc}
+  | Open_description        {open_loc = loc}
+  | Open_declaration        {open_loc = loc}
+    -> loc
+  | Module_type_declaration_name {mtd_name = loc}
+    -> loc.Location.loc
+  | Module_declaration_name      {md_name = loc}
+  | Module_binding_name          {mb_name = loc}
+    -> loc.Location.loc
+  | Structure _ | Signature _ | Case _ | Class_structure _ | Type_extension _
+  | Class_field_kind _ | Module_type_constraint _ | With_constraint _
+  | Row_field _ | Type_kind _ | Class_signature _ | Package_type _
+  | Dummy
+    -> loc0
+
+let node_attributes = function
+  | Expression exp        -> exp.exp_attributes
+  | Pattern pat           -> pat.pat_attributes
+  | Class_expr cl         -> cl.cl_attributes
+  | Class_field cf        -> cf.cf_attributes
+  | Module_expr me        -> me.mod_attributes
+  | Structure_item ({str_desc = Tstr_eval (_,attr)},_) -> attr
+  | Structure_item ({str_desc = Tstr_attribute a},_) -> [a]
+  | Signature_item ({sig_desc = Tsig_attribute a},_) -> [a]
+  | Module_binding mb     -> mb.mb_attributes
+  | Value_binding vb      -> vb.vb_attributes
+  | Module_type mt        -> mt.mty_attributes
+  | Module_declaration md -> md.md_attributes
+  | Module_type_declaration mtd -> mtd.mtd_attributes
+  | Open_description o    -> o.open_attributes
+  | Include_declaration i -> i.incl_attributes
+  | Include_description i -> i.incl_attributes
+  | Core_type ct          -> ct.ctyp_attributes
+  | Row_field rf          -> rf.rf_attributes
+  | Value_description vd  -> vd.val_attributes
+  | Type_declaration td   -> td.typ_attributes
+  | Label_declaration ld  -> ld.ld_attributes
+  | Constructor_declaration cd -> cd.cd_attributes
+  | Type_extension te     -> te.tyext_attributes
+  | Extension_constructor ec -> ec.ext_attributes
+  | Class_type ct         -> ct.cltyp_attributes
+  | Class_type_field ctf  -> ctf.ctf_attributes
+  | Class_declaration ci -> ci.ci_attributes
+  | Class_description ci -> ci.ci_attributes
+  | Class_type_declaration ci -> ci.ci_attributes
+  | Method_call (obj,_,_) -> obj.exp_attributes
+  | Record_field (`Expression obj,_,_) -> obj.exp_attributes
+  | Record_field (`Pattern obj,_,_) -> obj.pat_attributes
+  | _ -> []
+
+let node_merlin_loc loc0 node =
+  let attributes = node_attributes node in
+  let loc =
+    let open Parsetree in
+    let pred { attr_name = loc; _ } = Location_aux.is_relaxed_location loc in
+    match List.find attributes ~f:pred with
+    | { attr_name; _ } -> attr_name.Location.loc
+    | exception Not_found -> node_real_loc loc0 node
+  in
+  let loc = match node with
+    | Expression {exp_extra; _} ->
+      List.fold_left ~f:(fun loc0 (_,loc,_) -> Location_aux.union loc0 loc)
+        ~init:loc exp_extra
+    | Pattern {pat_extra; _} ->
+      List.fold_left ~f:(fun loc0 (_,loc,_) -> Location_aux.union loc0 loc)
+        ~init:loc pat_extra
+    | _ -> loc
+  in
+  loc
+
+let app node env f acc =
+  f (node_update_env env node)
+    node acc
+
+type 'a f0 = Env.t -> node -> 'a -> 'a
+type ('b,'a) f1 = 'b -> Env.t -> 'a f0 -> 'a -> 'a
+
+let id_fold _env (_f : _ f0) acc = acc
+
+let ( ** ) f1 f2 env (f : _ f0) acc =
+  f2 env f (f1 env f acc)
+
+let rec list_fold (f' : _ f1) xs env f acc = match xs with
+  | x :: xs -> list_fold f' xs env f (f' x env f acc)
+  | [] -> acc
+
+let array_fold (f' : _ f1) arr env f acc =
+  let acc = ref acc in
+  for i = 0 to Array.length arr - 1 do
+    acc := f' arr.(i) env f !acc
+  done;
+  !acc
+
+let rec list_fold_with_next (f' : _ -> _ f1) xs env f acc = match xs with
+  | x :: (y :: _ as xs) -> list_fold_with_next f' xs env f (f' (Some y) x env f acc)
+  | [x] -> f' None x env f acc
+  | [] -> acc
+
+let option_fold f' o env (f : _ f0) acc = match o with
+  | None -> acc
+  | Some x -> f' x env f acc
+
+let of_core_type ct = app (Core_type ct)
+
+let of_exp_extra (exp,_,_) = match exp with
+  | Texp_constraint ct ->
+    of_core_type ct
+  | Texp_coerce (cto,ct) ->
+    of_core_type ct ** option_fold of_core_type cto
+  | Texp_poly cto ->
+    option_fold of_core_type cto
+  | Texp_newtype' _
+  | Texp_newtype _ ->
+    id_fold
+let of_expression e = app (Expression e) ** list_fold of_exp_extra e.exp_extra
+
+let of_pat_extra (pat,_,_) = match pat with
+  | Tpat_constraint ct -> of_core_type ct
+  | Tpat_type _ | Tpat_unpack | Tpat_open _ -> id_fold
+
+let of_pattern (type k) (p : k general_pattern) =
+  app (Pattern p) ** list_fold of_pat_extra p.pat_extra
+
+let of_case c = app (Case c)
+let of_label_declaration ct = app (Label_declaration ct)
+let of_value_binding vb = app (Value_binding vb)
+let of_module_type mt = app (Module_type mt)
+let of_module_expr me = app (Module_expr me)
+let of_typ_param (ct,_) = of_core_type ct
+let of_constructor_arguments = function
+  | Cstr_tuple cts -> list_fold of_core_type cts
+  | Cstr_record lbls -> list_fold of_label_declaration lbls
+
+let of_bop { bop_op_path = _; bop_op_val = _; bop_exp; _ } =
+  of_expression bop_exp
+
+let of_record_field obj loc lbl =
+  fun env (f : _ f0) acc ->
+  app (Record_field (obj,lbl,loc)) env f acc
+
+let of_exp_record_field obj lid_loc lbl =
+  of_record_field (`Expression obj) lid_loc lbl
+
+let of_pat_record_field obj loc lbl =
+  of_record_field (`Pattern obj) loc lbl
+
+let of_pattern_desc (type k) (desc : k pattern_desc) =
+  match desc with
+  | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> id_fold
+  | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) | Tpat_lazy p
+  | Tpat_exception p -> of_pattern p
+  | Tpat_value p -> of_pattern (p :> value general_pattern)
+  | Tpat_tuple ps | Tpat_construct (_,_,ps,None) | Tpat_array ps ->
+    list_fold of_pattern ps
+  | Tpat_construct (_,_,ps,Some (_, ct)) ->
+    list_fold of_pattern ps ** of_core_type ct
+  | Tpat_record (ls,_) ->
+    list_fold (fun (lid_loc,desc,p) ->
+        of_pat_record_field p lid_loc desc ** of_pattern p) ls
+  | Tpat_or (p1,p2,_) ->
+    of_pattern p1 ** of_pattern p2
+
+let of_method_call obj meth arg loc =
+  fun env (f : _ f0) acc ->
+  let loc_start = obj.exp_loc.Location.loc_end in
+  let loc_end = match arg with
+    | None -> loc.Location.loc_end
+    | Some e -> e.exp_loc.Location.loc_start
+  in
+  let loc = {loc with Location. loc_start; loc_end} in
+  app (Method_call (obj,meth,loc)) env f acc
+
+let of_expression_desc loc = function
+  | Texp_ident _ | Texp_constant _ | Texp_instvar _
+  | Texp_variant (_,None) | Texp_new _ | Texp_hole -> id_fold
+  | Texp_let (_,vbs,e) ->
+    of_expression e ** list_fold of_value_binding vbs
+  | Texp_function { cases; _ } ->
+    list_fold of_case cases
+  | Texp_apply (e,ls) ->
+    of_expression e **
+    list_fold (function
+        | (_,None) -> id_fold
+        | (_,Some e) -> of_expression e)
+      ls
+  | Texp_match (e,cs,_) ->
+    of_expression e **
+    list_fold of_case cs
+  | Texp_try (e,cs) ->
+    of_expression e **
+    list_fold of_case cs
+  | Texp_tuple es | Texp_construct (_,_,es) | Texp_array es ->
+    list_fold of_expression es
+  | Texp_variant (_,Some e)
+  | Texp_assert e | Texp_lazy e | Texp_setinstvar (_,_,_,e) ->
+    of_expression e
+  | Texp_record { fields; extended_expression } ->
+    option_fold of_expression extended_expression **
+    let fold_field = function
+      | (_,Typedtree.Kept _) -> id_fold
+      | (desc,Typedtree.Overridden (lid_loc,e)) ->
+        of_exp_record_field e lid_loc desc ** of_expression e
+    in
+    array_fold fold_field fields
+  | Texp_field (e,lid_loc,lbl) ->
+    of_expression e ** of_exp_record_field e lid_loc lbl
+  | Texp_setfield (e1,lid_loc,lbl,e2) ->
+    of_expression e1 ** of_expression e2 ** of_exp_record_field e1 lid_loc lbl
+  | Texp_ifthenelse (e1,e2,None)
+  | Texp_sequence (e1,e2) | Texp_while (e1,e2) ->
+    of_expression e1 ** of_expression e2
+  | Texp_ifthenelse (e1,e2,Some e3) | Texp_for (_,_,e1,e2,_,e3) ->
+    of_expression e1 ** of_expression e2 ** of_expression e3
+  | Texp_send (e,meth,eo) ->
+    of_expression e **
+    of_method_call e meth eo loc **
+    option_fold of_expression eo
+  | Texp_override (_,ls) ->
+    list_fold (fun (_,_,e) -> of_expression e) ls
+  | Texp_letmodule (mb_id, mb_name, mb_presence, mb_expr, e) ->
+    let mb =
+      {mb_id;mb_name;mb_expr;mb_loc=Location.none;mb_attributes=[]
+      ; mb_presence }
+    in
+    app (Module_binding mb) ** of_expression e
+  | Texp_letexception (ec,e) ->
+    app (Extension_constructor ec) ** of_expression e
+  | Texp_object (cs,_) ->
+    app (Class_structure cs)
+  | Texp_pack me ->
+    of_module_expr me
+  | Texp_unreachable | Texp_extension_constructor _ ->
+    id_fold
+  | Texp_letop { let_; ands; body; _ } ->
+    of_bop let_ **
+    list_fold of_bop ands **
+    of_case body
+  | Texp_open (od, e) ->
+    app (Module_expr od.open_expr) ** of_expression e
+
+and of_class_expr_desc = function
+  | Tcl_ident (_,_,cts) ->
+    list_fold of_core_type cts
+  | Tcl_structure cs ->
+    app (Class_structure cs)
+  | Tcl_fun (_,p,es,ce,_) ->
+    list_fold (fun (_,e) -> of_expression e) es **
+    of_pattern p **
+    app (Class_expr ce)
+  | Tcl_apply (ce,es) ->
+    list_fold (function
+        | (_,None) -> id_fold
+        | (_,Some e) -> of_expression e)
+      es **
+    app (Class_expr ce)
+  | Tcl_let (_,vbs,es,ce) ->
+    list_fold of_value_binding vbs **
+    list_fold (fun (_,e) -> of_expression e) es **
+    app (Class_expr ce)
+  | Tcl_constraint (ce,cto,_,_,_) ->
+    option_fold (fun ct -> app (Class_type ct)) cto **
+    app (Class_expr ce)
+  | Tcl_open (_,ce) ->
+    app (Class_expr ce)
+
+and of_class_field_desc = function
+  | Tcf_inherit (_,ce,_,_,_) ->
+    app (Class_expr ce)
+  | Tcf_val (_,_,_,cfk,_) | Tcf_method (_,_,cfk) ->
+    app (Class_field_kind cfk)
+  | Tcf_constraint (ct1,ct2) ->
+    of_core_type ct1 ** of_core_type ct2
+  | Tcf_initializer e ->
+    of_expression e
+  | Tcf_attribute _ ->
+    id_fold (*TODO*)
+
+and of_module_expr_desc = function
+  | Tmod_ident _ -> id_fold
+  | Tmod_structure str ->
+    app (Structure str)
+  | Tmod_functor (Unit,me) -> of_module_expr me
+  | Tmod_functor (Named (_, _, mt),me) ->
+    of_module_type mt ** of_module_expr me
+  | Tmod_apply (me1,me2,_) ->
+    of_module_expr me1 **
+    of_module_expr me2
+  | Tmod_constraint (me,_,mtc,_) ->
+    of_module_expr me **
+    app (Module_type_constraint mtc)
+  | Tmod_unpack (e,_) ->
+    of_expression e
+  | Tmod_hole -> id_fold
+
+and of_structure_item_desc = function
+  | Tstr_eval (e,_) ->
+    of_expression e
+  | Tstr_value (_,vbs) ->
+    list_fold of_value_binding vbs
+  | Tstr_primitive vd ->
+    app (Value_description vd)
+  | Tstr_type (_,tds) ->
+    list_fold (fun td -> app (Type_declaration td)) tds
+  | Tstr_typext text ->
+    app (Type_extension text)
+  | Tstr_exception texn ->
+    app (Extension_constructor texn.tyexn_constructor)
+  | Tstr_module mb ->
+    app (Module_binding mb)
+  | Tstr_recmodule mbs ->
+    list_fold (fun x -> app (Module_binding x)) mbs
+  | Tstr_modtype mtd ->
+    app (Module_type_declaration mtd)
+  | Tstr_class cds ->
+    list_fold (fun (cd,_) -> app (Class_declaration cd)) cds
+  | Tstr_class_type ctds ->
+    list_fold (fun (_,_,ctd) -> app (Class_type_declaration ctd)) ctds
+  | Tstr_include i ->
+    app (Include_declaration i)
+  | Tstr_open d ->
+    app (Open_declaration d)
+  | Tstr_attribute _ ->
+    id_fold
+
+and of_module_type_desc = function
+  | Tmty_ident _ | Tmty_alias _ -> id_fold
+  | Tmty_signature sg ->
+    app (Signature sg)
+  | Tmty_functor (Named (_,_,mt1),mt2) ->
+    of_module_type mt1 ** of_module_type mt2
+  | Tmty_functor (Unit,mt) -> of_module_type mt
+  | Tmty_with (mt,wcs) ->
+    list_fold (fun (_,_,wc) -> app (With_constraint wc)) wcs **
+    of_module_type mt
+  | Tmty_typeof me ->
+    of_module_expr me
+
+and of_signature_item_desc = function
+  | Tsig_attribute _ ->
+    id_fold
+  | Tsig_open d ->
+    app (Open_description d)
+  | Tsig_value vd ->
+    app (Value_description vd)
+  | Tsig_type (_,tds) ->
+    list_fold (fun td -> app (Type_declaration td)) tds
+  | Tsig_typext text ->
+    app (Type_extension text)
+  | Tsig_exception texn ->
+    app (Extension_constructor texn.tyexn_constructor)
+  | Tsig_module md ->
+    app (Module_declaration md)
+  | Tsig_recmodule mds ->
+    list_fold (fun md -> app (Module_declaration md)) mds
+  | Tsig_modtype mtd ->
+    app (Module_type_declaration mtd)
+  | Tsig_include i ->
+    app (Include_description i)
+  | Tsig_class cds ->
+    list_fold (fun cd -> app (Class_description cd)) cds
+  | Tsig_class_type ctds ->
+    list_fold (fun ctd -> app (Class_type_declaration ctd)) ctds
+  | Tsig_typesubst tds ->
+    (* FIXME: shitty approximation *)
+    list_fold (fun td -> app (Type_declaration td)) tds
+  | Tsig_modsubst _ms ->
+    (* TODO. *)
+    id_fold
+  | Tsig_modtypesubst _mts ->
+    (* TODO. *)
+    id_fold
+
+and of_core_type_desc = function
+  | Ttyp_any | Ttyp_var _ -> id_fold
+  | Ttyp_arrow (_,ct1,ct2) ->
+    of_core_type ct1 ** of_core_type ct2
+  | Ttyp_tuple cts | Ttyp_constr (_,_,cts) | Ttyp_class (_,_,cts) ->
+    list_fold of_core_type cts
+  | Ttyp_object (cts,_) ->
+    list_fold (fun of_ ->
+      match of_.of_desc with
+      | OTtag (_,ct)
+      | OTinherit ct -> of_core_type ct
+    ) cts
+  | Ttyp_poly (_,ct) | Ttyp_alias (ct,_) ->
+    of_core_type ct
+  | Ttyp_variant (rfs,_,_) ->
+    list_fold (fun rf -> app (Row_field rf)) rfs
+  | Ttyp_package pt ->
+    app (Package_type pt)
+
+and of_class_type_desc = function
+  | Tcty_constr (_,_,cts) ->
+    list_fold of_core_type cts
+  | Tcty_signature cs ->
+    app (Class_signature cs)
+  | Tcty_arrow (_,ct,clt) ->
+    of_core_type ct ** app (Class_type clt)
+  | Tcty_open (_,ct) ->
+    app (Class_type ct)
+
+and of_class_type_field_desc = function
+  | Tctf_inherit ct ->
+    app (Class_type ct)
+  | Tctf_val (_,_,_,ct) | Tctf_method (_,_,_,ct) ->
+    of_core_type ct
+  | Tctf_constraint (ct1,ct2) ->
+    of_core_type ct1 ** of_core_type ct2
+  | Tctf_attribute _ ->
+    id_fold
+
+let of_node = function
+  | Dummy -> id_fold
+  | Pattern { pat_desc; pat_extra=_ } ->
+    of_pattern_desc pat_desc
+  | Expression { exp_desc; exp_extra=_; exp_loc } ->
+    of_expression_desc exp_loc exp_desc
+  | Case { c_lhs; c_guard; c_rhs } ->
+    of_pattern c_lhs ** of_expression c_rhs **
+    option_fold of_expression c_guard
+  | Class_expr { cl_desc } ->
+    of_class_expr_desc cl_desc
+  | Class_structure { cstr_self; cstr_fields } ->
+    of_pattern cstr_self **
+    list_fold (fun f -> app (Class_field f)) cstr_fields
+  | Class_field { cf_desc } ->
+    of_class_field_desc cf_desc
+  | Class_field_kind (Tcfk_virtual ct) ->
+    of_core_type ct
+  | Class_field_kind (Tcfk_concrete (_,e)) ->
+    of_expression e
+  | Module_expr { mod_desc } ->
+    of_module_expr_desc mod_desc
+  | Module_type_constraint Tmodtype_implicit ->
+    id_fold
+  | Module_type_constraint (Tmodtype_explicit mt) ->
+    of_module_type mt
+  | Structure { str_items; str_final_env } ->
+    list_fold_with_next (fun next item ->
+        match next with
+        | None -> app (Structure_item (item, str_final_env))
+        | Some item' -> app (Structure_item (item, item'.str_env)))
+      str_items
+  | Structure_item ({ str_desc }, _) ->
+    of_structure_item_desc str_desc
+  | Module_binding mb ->
+    app (Module_expr mb.mb_expr) **
+    app (Module_binding_name mb)
+  | Value_binding { vb_pat; vb_expr } ->
+    of_pattern vb_pat **
+    of_expression vb_expr
+  | Module_type { mty_desc } ->
+    of_module_type_desc mty_desc
+  | Signature { sig_items; sig_final_env } ->
+    list_fold_with_next (fun next item ->
+        match next with
+        | None -> app (Signature_item (item, sig_final_env))
+        | Some item' -> app (Signature_item (item, item'.sig_env)))
+      sig_items
+  | Signature_item ({ sig_desc }, _) ->
+    of_signature_item_desc sig_desc
+  | Module_declaration md ->
+    of_module_type md.md_type **
+    app (Module_declaration_name md)
+  | Module_type_declaration mtd ->
+    option_fold of_module_type mtd.mtd_type **
+    app (Module_type_declaration_name mtd)
+  | With_constraint (Twith_type td | Twith_typesubst td) ->
+    app (Type_declaration td)
+  | With_constraint (Twith_module _ | Twith_modsubst _) ->
+    id_fold
+  | With_constraint (Twith_modtype mt | Twith_modtypesubst mt) ->
+    of_module_type mt
+  | Core_type { ctyp_desc } ->
+    of_core_type_desc ctyp_desc
+  | Package_type { pack_fields } ->
+    list_fold (fun (_,ct) -> of_core_type ct) pack_fields
+  | Row_field rf -> begin
+      match rf.rf_desc with
+      | Ttag (_,_,cts) -> list_fold of_core_type cts
+      | Tinherit ct -> of_core_type ct
+    end
+  | Value_description { val_desc } ->
+    of_core_type val_desc
+  | Type_declaration { typ_params; typ_cstrs; typ_kind; typ_manifest } ->
+    let of_typ_cstrs (ct1,ct2,_) = of_core_type ct1 ** of_core_type ct2 in
+    option_fold of_core_type typ_manifest **
+    list_fold of_typ_param typ_params **
+    app (Type_kind typ_kind) **
+    list_fold of_typ_cstrs typ_cstrs
+  | Type_kind (Ttype_abstract | Ttype_open) ->
+    id_fold
+  | Type_kind (Ttype_variant cds) ->
+    list_fold (fun cd -> app (Constructor_declaration cd)) cds
+  | Type_kind (Ttype_record lds) ->
+    list_fold of_label_declaration lds
+  | Type_extension { tyext_params; tyext_constructors } ->
+    list_fold of_typ_param tyext_params **
+    list_fold (fun ec -> app (Extension_constructor ec)) tyext_constructors
+  | Extension_constructor { ext_kind = Text_decl (carg,cto) } ->
+    option_fold of_core_type cto **
+    of_constructor_arguments carg
+  | Extension_constructor { ext_kind = Text_rebind _ } ->
+    id_fold
+  | Label_declaration { ld_type } ->
+    of_core_type ld_type
+  | Constructor_declaration { cd_args; cd_res } ->
+    option_fold of_core_type cd_res **
+    of_constructor_arguments cd_args
+  | Class_type { cltyp_desc } ->
+    of_class_type_desc cltyp_desc
+  | Class_signature { csig_self; csig_fields } ->
+    of_core_type csig_self **
+    list_fold (fun x -> app (Class_type_field x)) csig_fields
+  | Class_type_field { ctf_desc } ->
+    of_class_type_field_desc ctf_desc
+  | Class_declaration { ci_params; ci_expr } ->
+    app (Class_expr ci_expr) **
+    list_fold of_typ_param ci_params
+  | Class_description { ci_params; ci_expr } ->
+    app (Class_type ci_expr) **
+    list_fold of_typ_param ci_params
+  | Class_type_declaration { ci_params; ci_expr } ->
+    app (Class_type ci_expr) **
+    list_fold of_typ_param ci_params
+  | Method_call _ -> id_fold
+  | Record_field _ -> id_fold
+  | Module_binding_name _ -> id_fold
+  | Module_declaration_name _ -> id_fold
+  | Module_type_declaration_name _ -> id_fold
+  | Open_description _ -> id_fold
+  | Open_declaration od ->
+    app (Module_expr od.open_expr)
+  | Include_declaration i ->
+    of_module_expr i.incl_mod
+  | Include_description i ->
+    of_module_type i.incl_mod
+
+let fold_node f env node acc =
+  of_node node env f acc
+
+(** Accessors for information specific to a node *)
+
+let string_of_node = function
+  | Dummy -> "dummy"
+  | Pattern                 p ->
+    let fmt, printer = Format.to_string () in
+    Printtyped.pattern 0 fmt p ;
+    printer ()
+  | Expression              _ -> "expression"
+  | Case                    _ -> "case"
+  | Class_expr              _ -> "class_expr"
+  | Class_structure         _ -> "class_structure"
+  | Class_field             _ -> "class_field"
+  | Class_field_kind        _ -> "class_field_kind"
+  | Module_expr             _ -> "module_expr"
+  | Module_type_constraint  _ -> "module_type_constraint"
+  | Structure               _ -> "structure"
+  | Structure_item          _ -> "structure_item"
+  | Module_binding          _ -> "module_binding"
+  | Value_binding           _ -> "value_binding"
+  | Module_type             _ -> "module_type"
+  | Signature               _ -> "signature"
+  | Signature_item          _ -> "signature_item"
+  | Module_declaration      _ -> "module_declaration"
+  | Module_type_declaration _ -> "module_type_declaration"
+  | With_constraint         _ -> "with_constraint"
+  | Core_type               _ -> "core_type"
+  | Package_type            _ -> "package_type"
+  | Row_field               _ -> "row_field"
+  | Value_description       _ -> "value_description"
+  | Type_declaration        _ -> "type_declaration"
+  | Type_kind               _ -> "type_kind"
+  | Type_extension          _ -> "type_extension"
+  | Extension_constructor   _ -> "extension_constructor"
+  | Label_declaration       _ -> "label_declaration"
+  | Constructor_declaration _ -> "constructor_declaration"
+  | Class_type              _ -> "class_type"
+  | Class_signature         _ -> "class_signature"
+  | Class_type_field        _ -> "class_type_field"
+  | Class_declaration       _ -> "class_declaration"
+  | Class_description       _ -> "class_description"
+  | Class_type_declaration  _ -> "class_type_declaration"
+  | Method_call             _ -> "method_call"
+  | Record_field            _ -> "record_field"
+  | Module_binding_name     _ -> "module_binding_name"
+  | Module_declaration_name _ -> "module_declaration_name"
+  | Module_type_declaration_name _ -> "module_type_declaration_name"
+  | Open_description        _ -> "open_description"
+  | Open_declaration        _ -> "open_declaration"
+  | Include_description     _ -> "include_description"
+  | Include_declaration     _ -> "include_declaration"
+
+let mkloc = Location.mkloc
+let reloc txt loc = {loc with Location. txt}
+
+let mk_lident x = Longident.Lident x
+
+let type_constructor_path = function
+  | {Types.desc = Types.Tconstr (p,_,_)} -> p
+  | _ -> raise Not_found
+
+(* Build a fake path for value constructors and labels *)
+let fake_path {Location.loc ; txt = lid} typ name =
+  match type_constructor_path typ with
+  | Path.Pdot (p, _) ->
+    [mkloc (Path.Pdot (p, name)) loc, Some lid]
+  | Path.Pident _ ->
+    [mkloc (Path.Pident (Ident.create_persistent name)) loc, Some lid]
+  | _ | exception Not_found -> []
+
+let pattern_paths (type k) { Typedtree. pat_desc; pat_extra; _ } =
+  let init =
+    match (pat_desc : k pattern_desc) with
+    | Tpat_construct (lid_loc,{Types. cstr_name; cstr_res; _},_,_) ->
+      fake_path lid_loc cstr_res cstr_name
+    | Tpat_var (id, {Location. loc; txt}) ->
+      [mkloc (Path.Pident id) loc, Some (Longident.Lident txt)]
+    | Tpat_alias (_,id,loc) ->
+      [reloc (Path.Pident id) loc, Some (Longident.Lident loc.txt)]
+    | _ -> []
+  in
+  List.fold_left ~init pat_extra
+    ~f:(fun acc (extra,_,_) ->
+      match extra with
+      | Tpat_open (path,loc,_) | Tpat_type (path,loc) ->
+        (reloc path loc, Some loc.txt) :: acc
+      | _ -> acc)
+
+let module_expr_paths { Typedtree. mod_desc } =
+  match mod_desc with
+  | Tmod_ident (path, loc) -> [reloc path loc, Some loc.txt]
+  | Tmod_functor (Named (Some id, loc, _), _) ->
+    [reloc (Path.Pident id) loc, Option.map ~f:mk_lident loc.txt]
+  | _ -> []
+
+let bindop_path { bop_op_name; bop_op_path } =
+  let loc = bop_op_name in
+  let path = bop_op_path in
+  (reloc path loc, Some (Longident.Lident loc.txt))
+
+let expression_paths { Typedtree. exp_desc; exp_extra; _ } =
+  let init =
+    match exp_desc with
+    | Texp_ident (path,loc,_) -> [reloc path loc, Some loc.txt]
+    | Texp_letop {let_; ands} ->
+      bindop_path let_ :: List.map ~f:bindop_path ands
+    | Texp_new (path,loc,_) -> [reloc path loc, Some loc.txt]
+    | Texp_instvar (_,path,loc)  -> [reloc path loc, Some (Lident loc.txt)]
+    | Texp_setinstvar (_,path,loc,_) -> [reloc path loc, Some (Lident loc.txt)]
+    | Texp_override (_,ps) ->
+      List.map ~f:(fun (path,loc,_) ->
+        reloc path loc, Some (Longident.Lident loc.txt)
+      ) ps
+    | Texp_letmodule (Some id,loc,_,_,_) ->
+      [reloc (Path.Pident id) loc, Option.map ~f:mk_lident loc.txt]
+    | Texp_for (id,{Parsetree.ppat_loc = loc; ppat_desc},_,_,_,_) ->
+      let lid =
+        match ppat_desc with
+        | Ppat_any -> None
+        | Ppat_var {txt} -> Some (Longident.Lident txt)
+        | _ -> assert false
+      in
+      [mkloc (Path.Pident id) loc, lid]
+    | Texp_construct (lid_loc, {Types. cstr_name; cstr_res; _}, _) ->
+      fake_path lid_loc cstr_res cstr_name
+    | Texp_open (od,_) -> module_expr_paths od.open_expr
+    | _ -> []
+  in
+  List.fold_left ~init exp_extra
+    ~f:(fun acc (extra, _, _) ->
+      match extra with
+      | Texp_newtype' (id, label_loc) ->
+        let path = Path.Pident id in
+        let lid = Longident.Lident (label_loc.txt) in
+        (mkloc path label_loc.loc, Some lid) :: acc
+      | _ -> acc)
+
+let core_type_paths { Typedtree. ctyp_desc } =
+  match ctyp_desc with
+  | Ttyp_constr (path,loc,_) -> [reloc path loc, Some loc.txt]
+  | Ttyp_class (path,loc,_) -> [reloc path loc, Some loc.txt]
+  | _ -> []
+
+let class_expr_paths { Typedtree. cl_desc } =
+  match cl_desc with
+  | Tcl_ident (path, loc, _) -> [reloc path loc, Some loc.txt]
+  | _ -> []
+
+let class_field_paths { Typedtree. cf_desc } =
+  match cf_desc with
+  | Tcf_val (loc,_,id,_,_) ->
+    [reloc (Path.Pident id) loc, Some (Longident.Lident loc.txt)]
+  | _ -> []
+
+let structure_item_paths { Typedtree. str_desc } =
+  match str_desc with
+  | Tstr_class_type cls ->
+    List.map ~f:(fun (id,loc,_) ->
+      reloc (Path.Pident id) loc, Some (Longident.Lident loc.txt)
+    ) cls
+  | Tstr_open od -> module_expr_paths od.open_expr
+  | _ -> []
+
+let module_type_paths { Typedtree. mty_desc } =
+  match mty_desc with
+  | Tmty_ident (path, loc) | Tmty_alias (path, loc) ->
+    [reloc path loc, Some loc.txt]
+  | Tmty_functor (Named (Some id,loc,_),_) ->
+    [reloc (Path.Pident id) loc, Option.map ~f:mk_lident loc.txt]
+  | Tmty_with (_,ls) ->
+    List.map ~f:(fun (p,l,_) -> reloc p l, Some l.txt) ls
+  | _ -> []
+
+let signature_item_paths { Typedtree. sig_desc } =
+  match sig_desc with
+  | Tsig_open { Typedtree. open_expr = (open_path, open_txt); _ } ->
+    [reloc open_path open_txt, Some open_txt.txt]
+  | _ -> []
+
+let with_constraint_paths = function
+  | Twith_module (path,loc) | Twith_modsubst (path,loc) ->
+    [reloc path loc, Some loc.txt]
+  | _ -> []
+
+let ci_paths {Typedtree. ci_id_name; ci_id_class } =
+  [reloc (Path.Pident ci_id_class) ci_id_name,
+   Some (Longident.Lident ci_id_name.txt)]
+
+let node_paths_full =
+  let open Typedtree in function
+  | Pattern p -> pattern_paths p
+  | Expression e -> expression_paths e
+  | Class_expr e -> class_expr_paths e
+  | Class_field f -> class_field_paths f
+  | Module_expr me -> module_expr_paths me
+  | Structure_item (i,_) -> structure_item_paths i
+  | Module_binding_name { mb_id = Some mb_id; mb_name } ->
+    [reloc (Path.Pident mb_id) mb_name, Option.map ~f:mk_lident mb_name.txt]
+  | Module_type mt -> module_type_paths mt
+  | Signature_item (i,_) -> signature_item_paths i
+  | Module_declaration_name { md_id = Some md_id; md_name } ->
+    [reloc (Path.Pident md_id) md_name, Option.map ~f:mk_lident md_name.txt]
+  | Module_type_declaration_name { mtd_id; mtd_name } ->
+    [reloc (Path.Pident mtd_id) mtd_name, Some (Lident mtd_name.txt) ]
+  | With_constraint c -> with_constraint_paths c
+  | Core_type ct -> core_type_paths ct
+  | Package_type { pack_path; pack_txt } ->
+    [reloc pack_path pack_txt, Some pack_txt.txt]
+  | Value_description { val_id; val_name } ->
+    [reloc (Path.Pident val_id) val_name, Some (Lident val_name.txt)]
+  | Type_declaration { typ_id; typ_name } ->
+    [reloc (Path.Pident typ_id) typ_name, Some (Lident typ_name.txt)]
+  | Type_extension { tyext_path; tyext_txt } ->
+    [reloc tyext_path tyext_txt, Some tyext_txt.txt]
+  | Extension_constructor { ext_id; ext_name } ->
+    [reloc (Path.Pident ext_id) ext_name, Some (Lident ext_name.txt)]
+  | Label_declaration { ld_id; ld_name } ->
+    [reloc (Path.Pident ld_id) ld_name, Some (Lident ld_name.txt)]
+  | Constructor_declaration { cd_id; cd_name } ->
+    [reloc (Path.Pident cd_id) cd_name, Some (Lident cd_name.txt)]
+  | Class_declaration ci -> ci_paths ci
+  | Class_description ci -> ci_paths ci
+  | Class_type_declaration ci -> ci_paths ci
+  | Record_field (_,{Types.lbl_res; lbl_name; _},lid_loc) ->
+    fake_path lid_loc lbl_res lbl_name
+  | _ -> []
+
+let node_paths t = List.map (node_paths_full t) ~f:fst
+let node_paths_and_longident t =
+  List.filter_map (node_paths_full t) ~f:(function
+    | _, None -> None
+    | p, Some lid -> Some (p, lid)
+  )
+
+let node_is_constructor = function
+  | Constructor_declaration decl ->
+    Some {decl.cd_name with Location.txt = `Declaration decl}
+  | Expression {exp_desc = Texp_construct (loc, desc, _)} ->
+    Some {loc with Location.txt = `Description desc}
+  | Pattern {pat_desc = Tpat_construct (loc, desc, _, _)} ->
+    Some {loc with Location.txt = `Description desc}
+  | _ -> None
+
+let node_of_binary_part env part =
+  let open Cmt_format in
+  match part with
+  | Partial_structure x ->
+    Structure x
+  | Partial_structure_item x ->
+    Structure_item (x, env)
+  | Partial_expression x ->
+    Expression x
+  | Partial_pattern (_, x) ->
+    Pattern x
+  | Partial_class_expr x ->
+    Class_expr x
+  | Partial_signature x ->
+    Signature x
+  | Partial_signature_item x ->
+    Signature_item (x, env)
+  | Partial_module_type x ->
+    Module_type x
+
+let all_holes (env, node) =
+  let rec aux acc (env, node) =
+    let f env node acc = match node with
+      | Expression {
+          exp_desc = Texp_hole;
+          exp_loc;
+          exp_type;
+          exp_env;
+          _
+        } -> (exp_loc, exp_env, `Exp exp_type) :: acc
+      | Module_expr {
+          mod_desc = Tmod_hole;
+          mod_loc;
+          mod_type;
+          mod_env;
+          _
+        } -> (mod_loc, mod_env, `Mod mod_type) :: acc
+      | _ -> aux acc (env, node)
+    in
+    fold_node f env node acc
+  in
+  aux [] (env, node) |> List.rev
diff --git a/src/ocaml/merlin_specific/browse_raw.mli b/src/ocaml/merlin_specific/browse_raw.mli
new file mode 100644
index 0000000..0e919a9
--- /dev/null
+++ b/src/ocaml/merlin_specific/browse_raw.mli
@@ -0,0 +1,126 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2014  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+(** [Browse_node] offers a uniform interface to traverse constructions from
+  * [TypedTree].
+  *
+  * Mutually recursive types from [TypedTree] are wrapped into different
+  * constructors of the type [node].
+  * Then the [fold] function traverses one-level of sub-nodes.
+  *
+  * In the meantime, the most specific environment and location are threaded
+  * (FIXME: should these two be managed separately?).
+  *
+  * Finally [BrowseT] module a node into a tree which structure mimics
+  * the recursive structure of the [TypedTree] node.
+  *
+  *)
+
+(* Compatibility with previous versions of OCaml *)
+type constructor_declaration = Typedtree.constructor_declaration
+
+open Typedtree
+
+type node =
+  | Dummy
+  | Pattern                  : _ general_pattern -> node
+  | Expression               of expression
+  | Case                     : _ case -> node
+  | Class_expr               of class_expr
+  | Class_structure          of class_structure
+  | Class_field              of class_field
+  | Class_field_kind         of class_field_kind
+  | Module_expr              of module_expr
+  | Module_type_constraint   of module_type_constraint
+  | Structure                of structure
+  | Signature                of signature
+  | (* Items come with their final environment *)
+    Structure_item           of structure_item * Env.t
+  | Signature_item           of signature_item * Env.t
+  | Module_binding           of module_binding
+  | Value_binding            of value_binding
+  | Module_type              of module_type
+  | Module_declaration       of module_declaration
+  | Module_type_declaration  of module_type_declaration
+  | With_constraint          of with_constraint
+  | Core_type                of core_type
+  | Package_type             of package_type
+  | Row_field                of row_field
+  | Value_description        of value_description
+  | Type_declaration         of type_declaration
+  | Type_kind                of type_kind
+  | Type_extension           of type_extension
+  | Extension_constructor    of extension_constructor
+  | Label_declaration        of label_declaration
+  | Constructor_declaration  of constructor_declaration
+  | Class_type               of class_type
+  | Class_signature          of class_signature
+  | Class_type_field         of class_type_field
+  | Class_declaration        of class_declaration
+  | Class_description        of class_description
+  | Class_type_declaration   of class_type_declaration
+
+  | Include_description      of include_description
+  | Include_declaration      of include_declaration
+  | Open_description         of open_description
+  | Open_declaration         of open_declaration
+
+  | Method_call              of expression * meth * Location.t
+  | Record_field             of [ `Expression of expression
+                                | `Pattern of pattern ]
+                                * Types.label_description
+                                * Longident.t Location.loc
+  | Module_binding_name      of module_binding
+  | Module_declaration_name  of module_declaration
+  | Module_type_declaration_name of module_type_declaration
+
+val fold_node : (Env.t -> node -> 'a -> 'a) -> Env.t -> node -> 'a -> 'a
+
+(** Accessors for information specific to a node *)
+
+val node_update_env : Env.t -> node -> Env.t
+val node_real_loc : Location.t -> node -> Location.t
+val node_merlin_loc : Location.t -> node -> Location.t
+val node_attributes : node -> attribute list
+
+val string_of_node : node -> string
+
+val node_paths : node -> Path.t Location.loc list
+val node_paths_and_longident : node -> (Path.t Location.loc * Longident.t) list
+
+val node_is_constructor : node ->
+  [ `Description of Types.constructor_description
+  | `Declaration of Typedtree.constructor_declaration ] Location.loc option
+
+val node_of_binary_part : Env.t -> Cmt_format.binary_part -> node
+
+val all_holes :
+  Env.t * node ->
+  (Location.t *
+    Env.t *
+    [`Exp of Types.type_expr | `Mod of Types.module_type]) list
diff --git a/src/ocaml/merlin_specific/dune b/src/ocaml/merlin_specific/dune
new file mode 100644
index 0000000..b41c3d0
--- /dev/null
+++ b/src/ocaml/merlin_specific/dune
@@ -0,0 +1,10 @@
+(library
+  (name merlin_specific)
+  (wrapped false)
+  (flags
+   :standard
+   -open Ocaml_utils
+   -open Ocaml_parsing
+   -open Ocaml_typing
+   -open Merlin_utils)
+  (libraries merlin_utils ocaml_parsing preprocess ocaml_typing ocaml_utils))
diff --git a/src/ocaml/merlin_specific/tast_helper.ml b/src/ocaml/merlin_specific/tast_helper.ml
new file mode 100644
index 0000000..1664fa1
--- /dev/null
+++ b/src/ocaml/merlin_specific/tast_helper.ml
@@ -0,0 +1,40 @@
+open Typedtree
+
+module Pat = struct
+  let pat_extra = []
+  let pat_attributes = []
+
+  let constant ?(loc=Location.none) pat_env pat_type c =
+    let pat_desc = Tpat_constant c in
+    { pat_desc; pat_loc = loc; pat_extra; pat_attributes; pat_type; pat_env }
+
+  let var ?loc pat_env pat_type str =
+    let pat_loc =
+      match loc with
+      | None -> str.Asttypes.loc
+      | Some loc -> loc
+    in
+    let pat_desc = Tpat_var (Ident.create_local str.Asttypes.txt, str) in
+    { pat_desc; pat_loc; pat_extra; pat_attributes; pat_type; pat_env }
+
+  let record ?(loc=Location.none) pat_env pat_type lst closed_flag =
+    let pat_desc = Tpat_record (lst, closed_flag) in
+    { pat_desc; pat_loc = loc; pat_extra; pat_attributes; pat_type; pat_env }
+
+  let tuple ?(loc=Location.none) pat_env pat_type lst =
+    let pat_desc = Tpat_tuple lst in
+    { pat_desc; pat_loc = loc; pat_extra; pat_attributes; pat_type; pat_env }
+
+  let construct ?(loc=Location.none) 
+    pat_env pat_type lid cstr_desc args locs_coretype =
+    let pat_desc = Tpat_construct (lid, cstr_desc, args, locs_coretype) in
+    { pat_desc; pat_loc = loc; pat_extra; pat_attributes; pat_type; pat_env }
+
+  let pat_or ?(loc=Location.none) ?row_desc pat_env pat_type p1 p2 =
+    let pat_desc = Tpat_or (p1, p2, row_desc) in
+    { pat_desc; pat_loc = loc; pat_extra; pat_attributes; pat_type; pat_env }
+
+  let variant ?(loc=Location.none) pat_env pat_type lbl sub rd =
+    let pat_desc = Tpat_variant (lbl, sub, rd) in
+    { pat_desc; pat_loc = loc; pat_extra; pat_attributes; pat_type; pat_env }
+end
diff --git a/src/ocaml/merlin_specific/typer_raw.ml b/src/ocaml/merlin_specific/typer_raw.ml
new file mode 100644
index 0000000..87d265a
--- /dev/null
+++ b/src/ocaml/merlin_specific/typer_raw.ml
@@ -0,0 +1,588 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+open Location
+open Parsetree
+
+let fresh_env () =
+  (*Ident.reinit();*)
+  let initially_opened_module =
+    if !Clflags.nopervasives then
+      None
+    else
+      Some "Stdlib"
+  in
+  Typemod.initial_env
+    ~loc:(Location.in_file "command line")
+    ~safe_string:(not !Clflags.unsafe_string)
+    ~initially_opened_module
+    ~open_implicit_modules:(List.rev !Clflags.open_modules)
+
+module Rewrite_loc = struct
+  let queue = ref []
+
+  let update l =
+    if l <> none then
+      match !queue with
+      | [] -> assert false
+      | l' :: ls -> queue := Location_aux.union l l' :: ls
+
+  let enter () = queue := Location.none :: !queue
+  let leave l0 = match !queue with
+    | [] -> assert false
+    | [l] -> queue := []; Location_aux.extend l0 l
+    | l :: l' :: ls ->
+      let l = Location_aux.extend l0 l in
+      queue := Location_aux.union l l' :: ls;
+      l
+
+  let start () = assert (!queue = []); enter ()
+  let exit () = match !queue with
+    | [_] -> queue := []
+    | _ -> assert false
+
+  let u_option f = function
+    | None -> None
+    | Some x -> Some (f x)
+
+  let u_loc (loc : _ Location.loc) =
+    update loc.loc; loc
+
+  let rec u_attribute { attr_name = loc ; attr_payload; attr_loc } =
+    let loc = if Location_aux.is_relaxed_location loc then loc else u_loc loc in
+    { attr_name = loc
+    ; attr_payload = u_payload attr_payload
+    ; attr_loc }
+
+  and u_extension (loc, payload) =
+    let loc = if Location_aux.is_relaxed_location loc then loc else u_loc loc in
+    (loc, u_payload payload)
+
+  and u_attributes l = List.map ~f:u_attribute l
+
+  and u_payload = function
+    | PStr str -> PStr (u_structure str)
+    | PSig sg -> PSig (u_signature sg)
+    | PTyp ct  -> PTyp (u_core_type ct)
+    | PPat (p, eo) -> PPat (u_pattern p, u_option u_expression eo)
+
+  and u_core_type {ptyp_desc; ptyp_attributes; ptyp_loc; ptyp_loc_stack} =
+    enter ();
+    let ptyp_desc = u_core_type_desc ptyp_desc in
+    let ptyp_attributes = u_attributes ptyp_attributes in
+    let ptyp_loc = leave ptyp_loc in
+    {ptyp_desc; ptyp_loc; ptyp_attributes; ptyp_loc_stack}
+
+  and u_core_type_desc = function
+    | Ptyp_any | Ptyp_var _ as desc -> desc
+    | Ptyp_arrow (l, t1, t2) -> Ptyp_arrow (l, u_core_type t1, u_core_type t2)
+    | Ptyp_tuple ts -> Ptyp_tuple (List.map ~f:u_core_type ts)
+    | Ptyp_constr (loc, ts) -> Ptyp_constr (u_loc loc, List.map ~f:u_core_type ts)
+    | Ptyp_object (fields, flag) ->
+      let object_field_desc = function
+        | Otag (lbl, ct) -> Otag (lbl, u_core_type ct)
+        | Oinherit ct -> Oinherit (u_core_type ct)
+      in
+      let object_field { pof_desc; pof_loc; pof_attributes } =
+        { pof_desc = object_field_desc pof_desc
+        ; pof_attributes = u_attributes pof_attributes
+        ; pof_loc }
+      in
+      Ptyp_object (List.map ~f:object_field fields, flag)
+    | Ptyp_class (loc, ts) -> Ptyp_class (u_loc loc, List.map ~f:u_core_type ts)
+    | Ptyp_alias (ct, name) -> Ptyp_alias (u_core_type ct, name)
+    | Ptyp_variant (fields, flag, label) -> Ptyp_variant (List.map ~f:u_row_field fields, flag, label)
+    | Ptyp_poly (ss,ct) -> Ptyp_poly (ss, u_core_type ct)
+    | Ptyp_package pt -> Ptyp_package (u_package_type pt)
+    | Ptyp_extension ext -> Ptyp_extension (u_extension ext)
+
+  and u_package_type (loc, cts) =
+    (u_loc loc, List.map ~f:(fun (l,ct) -> u_loc l, u_core_type ct) cts)
+
+  and u_row_field { prf_desc; prf_loc; prf_attributes } =
+    let desc = function
+      | Rtag (l,has_const,cts) ->
+        Rtag (l, has_const, List.map ~f:u_core_type cts)
+      | Rinherit ct -> Rinherit (u_core_type ct)
+    in
+    { prf_desc = desc prf_desc
+    ; prf_loc
+    ; prf_attributes = u_attributes prf_attributes }
+
+  and u_pattern {ppat_desc; ppat_loc; ppat_attributes; ppat_loc_stack} =
+    enter ();
+    let ppat_desc = u_pattern_desc ppat_desc in
+    let ppat_attributes = u_attributes ppat_attributes in
+    let ppat_loc = leave ppat_loc in
+    {ppat_desc; ppat_loc; ppat_attributes; ppat_loc_stack}
+
+  and u_pattern_desc = function
+    | Ppat_any | Ppat_constant _ | Ppat_interval _ as p -> p
+    | Ppat_var l -> Ppat_var (u_loc l)
+    | Ppat_alias (p, l) -> Ppat_alias (u_pattern p, u_loc l)
+    | Ppat_tuple ps -> Ppat_tuple (List.map ~f:u_pattern ps)
+    | Ppat_construct (loc, po) -> Ppat_construct (u_loc loc, u_option
+        (fun (locs, p) -> locs, u_pattern p) po)
+    | Ppat_variant (lbl, po) -> Ppat_variant (lbl, u_option u_pattern po)
+    | Ppat_record (fields, flag) -> Ppat_record (List.map ~f:(fun (l,p) -> (u_loc l, u_pattern p)) fields, flag)
+    | Ppat_array ps -> Ppat_array (List.map ~f:u_pattern ps)
+    | Ppat_or (p1, p2) -> Ppat_or (u_pattern p1, u_pattern p2)
+    | Ppat_constraint (p, ct) -> Ppat_constraint (u_pattern p, u_core_type ct)
+    | Ppat_type loc -> Ppat_type (u_loc loc)
+    | Ppat_lazy p -> Ppat_lazy (u_pattern p)
+    | Ppat_unpack loc -> Ppat_unpack (u_loc loc)
+    | Ppat_exception p -> Ppat_exception (u_pattern p)
+    | Ppat_extension ext -> Ppat_extension (u_extension ext)
+    | Ppat_open (l,p) -> Ppat_open (u_loc l, u_pattern p)
+
+  and u_expression {pexp_desc; pexp_loc; pexp_attributes; pexp_loc_stack} =
+    enter ();
+    let pexp_desc = u_expression_desc pexp_desc in
+    let pexp_attributes = u_attributes pexp_attributes in
+    let pexp_loc = leave pexp_loc in
+    {pexp_desc; pexp_loc; pexp_attributes; pexp_loc_stack}
+
+  and u_expression_desc = function
+    | Pexp_ident loc -> Pexp_ident (u_loc loc)
+    | Pexp_constant _ as e -> e
+    | Pexp_let (flag, vs, e) ->
+      Pexp_let (flag, List.map ~f:u_value_binding vs, u_expression e)
+    | Pexp_function cs ->
+      Pexp_function (List.map ~f:u_case cs)
+    | Pexp_fun (lbl, eo, pattern, expr) ->
+      Pexp_fun (lbl, u_option u_expression eo, u_pattern pattern, u_expression expr)
+    | Pexp_apply (e, les) ->
+      Pexp_apply (u_expression e, List.map ~f:(fun (l,e) -> (l, u_expression e)) les)
+    | Pexp_match (e, cs) -> Pexp_match (u_expression e, List.map ~f:u_case cs)
+    | Pexp_try (e, cs) -> Pexp_try (u_expression e, List.map ~f:u_case cs)
+    | Pexp_tuple es -> Pexp_tuple (List.map ~f:u_expression es)
+    | Pexp_construct (loc, eo) ->
+      Pexp_construct (u_loc loc, u_option u_expression eo)
+    | Pexp_variant (lbl, eo) ->
+      Pexp_variant (lbl, u_option u_expression eo)
+    | Pexp_record (les, eo) ->
+      Pexp_record (List.map ~f:(fun (loc,e) -> (u_loc loc, u_expression e)) les, u_option u_expression eo)
+    | Pexp_field (e, loc) -> Pexp_field (u_expression e, u_loc loc)
+    | Pexp_setfield (e1, loc, e2) -> Pexp_setfield (u_expression e1, u_loc loc, u_expression e2)
+    | Pexp_array es -> Pexp_array (List.map ~f:u_expression es)
+    | Pexp_ifthenelse (e1,e2,e3) -> Pexp_ifthenelse (u_expression e1, u_expression e2, u_option u_expression e3)
+    | Pexp_sequence (e1, e2) -> Pexp_sequence (u_expression e1, u_expression e2)
+    | Pexp_while (e1, e2) -> Pexp_while (u_expression e1, u_expression e2)
+    | Pexp_for (p, e1, e2, flag, e3) -> Pexp_for (u_pattern p, u_expression e1, u_expression e2, flag, u_expression e3)
+    | Pexp_constraint (e, ct) -> Pexp_constraint (u_expression e, u_core_type ct)
+    | Pexp_coerce (e, cto, ct) -> Pexp_coerce (u_expression e, u_option u_core_type cto, u_core_type ct)
+    | Pexp_send (e, s) -> Pexp_send (u_expression e, s)
+    | Pexp_new loc -> Pexp_new (u_loc loc)
+    | Pexp_setinstvar (s, e) -> Pexp_setinstvar (u_loc s, u_expression e)
+    | Pexp_override es -> Pexp_override (List.map ~f:(fun (loc,e) -> (u_loc loc, u_expression e)) es)
+    | Pexp_letmodule (s, me, e) -> Pexp_letmodule (u_loc s, u_module_expr me, u_expression e)
+    | Pexp_letexception (c, e) -> Pexp_letexception (u_extension_constructor c, u_expression e)
+    | Pexp_assert e -> Pexp_assert (u_expression e)
+    | Pexp_lazy e -> Pexp_lazy (u_expression e)
+    | Pexp_poly (e, cto) -> Pexp_poly (u_expression e, u_option u_core_type cto)
+    | Pexp_object cs -> Pexp_object (u_class_structure cs)
+    | Pexp_newtype (s, e) -> Pexp_newtype (s, u_expression e)
+    | Pexp_pack me -> Pexp_pack (u_module_expr me)
+    | Pexp_open (od, e) -> Pexp_open (u_open_declaration od, u_expression e)
+    | Pexp_extension ext -> Pexp_extension (u_extension ext)
+    | Pexp_unreachable -> Pexp_unreachable
+    | Pexp_letop { let_; ands; body } ->
+      Pexp_letop {
+        let_ = u_binding_op let_;
+        ands = List.map ~f:u_binding_op ands;
+        body = u_expression body;
+      }
+
+  and u_binding_op { pbop_op; pbop_pat; pbop_exp; pbop_loc } =
+    { pbop_op = u_loc pbop_op
+    ; pbop_pat = u_pattern pbop_pat
+    ; pbop_exp = u_expression pbop_exp
+    ; pbop_loc }
+
+  and u_case {pc_lhs; pc_guard; pc_rhs} = {
+    pc_lhs = u_pattern pc_lhs;
+    pc_guard = u_option u_expression pc_guard;
+    pc_rhs = u_expression pc_rhs;
+  }
+
+  and u_value_description {pval_name; pval_type; pval_prim; pval_attributes; pval_loc} =
+    enter ();
+    let pval_name = u_loc pval_name in
+    let pval_type = u_core_type pval_type in
+    let pval_attributes = u_attributes pval_attributes in
+    let pval_loc = leave pval_loc in
+    {pval_name; pval_type; pval_prim; pval_attributes; pval_loc}
+
+  and u_type_declaration {ptype_name; ptype_params; ptype_cstrs; ptype_kind;
+                        ptype_private; ptype_manifest; ptype_attributes; ptype_loc} =
+    enter ();
+    let ptype_name = u_loc ptype_name
+    and ptype_params = List.map ~f:(fun (ct,v) -> (u_core_type ct, v)) ptype_params
+    and ptype_cstrs = List.map ~f:(fun (ct1,ct2,l) ->
+        update l; (u_core_type ct1, u_core_type ct2, l)) ptype_cstrs
+    and ptype_kind = u_type_kind ptype_kind
+    and ptype_manifest = u_option u_core_type ptype_manifest
+    and ptype_attributes = u_attributes ptype_attributes
+    in
+    let ptype_loc = leave ptype_loc in
+    {ptype_name; ptype_params; ptype_cstrs; ptype_kind;
+     ptype_private; ptype_manifest; ptype_attributes; ptype_loc}
+
+  and u_type_kind = function
+    | Ptype_abstract | Ptype_open as k -> k
+    | Ptype_variant cstrs -> Ptype_variant (List.map ~f:u_constructor_declaration cstrs)
+    | Ptype_record lbls -> Ptype_record (List.map ~f:u_label_declaration lbls)
+
+  and u_label_declaration {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes} =
+    enter ();
+    let pld_name = u_loc pld_name in
+    let pld_type = u_core_type pld_type in
+    let pld_attributes = u_attributes pld_attributes in
+    let pld_loc = leave pld_loc in
+    {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes}
+
+  and u_constructor_declaration {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} =
+    enter ();
+    let pcd_name = u_loc pcd_name in
+    let pcd_args = u_constructor_arguments pcd_args in
+    let pcd_res = u_option u_core_type pcd_res in
+    let pcd_attributes = u_attributes pcd_attributes in
+    let pcd_loc = leave pcd_loc in
+    {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes}
+
+  and u_constructor_arguments = function
+    | Pcstr_tuple cts -> Pcstr_tuple (List.map ~f:u_core_type cts)
+    | Pcstr_record lbls -> Pcstr_record (List.map ~f:u_label_declaration lbls)
+
+  and u_type_extension
+        {ptyext_path; ptyext_params; ptyext_constructors; ptyext_private
+        ; ptyext_attributes; ptyext_loc } =
+    let ptyext_path = u_loc ptyext_path in
+    let ptyext_params = List.map ~f:(fun (ct,v) -> (u_core_type ct, v)) ptyext_params in
+    let ptyext_constructors = List.map ~f:u_extension_constructor ptyext_constructors in
+    let ptyext_attributes = u_attributes ptyext_attributes in
+    {ptyext_path; ptyext_params; ptyext_constructors; ptyext_private
+    ; ptyext_attributes; ptyext_loc }
+
+  and u_extension_constructor {pext_name; pext_kind; pext_loc; pext_attributes} =
+    enter ();
+    let pext_name = u_loc pext_name in
+    let pext_kind = u_extension_constructor_kind pext_kind in
+    let pext_attributes = u_attributes pext_attributes in
+    let pext_loc = leave pext_loc in
+    {pext_name; pext_kind; pext_loc; pext_attributes}
+
+  and u_extension_constructor_kind = function
+    | Pext_decl (cargs, cto) ->
+      Pext_decl (u_constructor_arguments cargs, u_option u_core_type cto)
+    | Pext_rebind loc -> Pext_rebind (u_loc loc)
+
+  (** {2 Class language} *)
+
+  (* Type expressions for the class language *)
+
+  and u_class_type {pcty_desc; pcty_loc; pcty_attributes} =
+    enter ();
+    let pcty_desc = u_class_type_desc pcty_desc in
+    let pcty_attributes = u_attributes pcty_attributes in
+    let pcty_loc = leave pcty_loc in
+    {pcty_desc; pcty_loc; pcty_attributes}
+
+  and u_class_type_desc = function
+    | Pcty_constr (loc, cts) ->
+      Pcty_constr (u_loc loc, List.map ~f:u_core_type cts)
+    | Pcty_signature cs -> Pcty_signature (u_class_signature cs)
+    | Pcty_arrow (lbl, ct, clt) ->
+      Pcty_arrow (lbl, u_core_type ct, u_class_type clt)
+    | Pcty_extension ext ->
+      Pcty_extension (u_extension ext)
+    | Pcty_open (od, cty) ->
+      Pcty_open (u_open_description od, u_class_type cty)
+
+  and u_class_signature {pcsig_self; pcsig_fields} =
+    let pcsig_self = u_core_type pcsig_self in
+    let pcsig_fields = List.map ~f:u_class_type_field pcsig_fields in
+    {pcsig_self; pcsig_fields}
+
+  and u_class_type_field {pctf_desc; pctf_loc; pctf_attributes} =
+    enter ();
+    let pctf_desc = u_class_type_field_desc pctf_desc in
+    let pctf_attributes = u_attributes pctf_attributes in
+    let pctf_loc = leave pctf_loc in
+    {pctf_desc; pctf_loc; pctf_attributes}
+
+  and u_class_type_field_desc = function
+    | Pctf_inherit clt -> Pctf_inherit (u_class_type clt)
+    | Pctf_val (s, fl1, fl2, ct) -> Pctf_val (s, fl1, fl2, u_core_type ct)
+    | Pctf_method (s, fl1, fl2, ct) -> Pctf_method (s, fl1, fl2, u_core_type ct)
+    | Pctf_constraint (ct1, ct2) -> Pctf_constraint (u_core_type ct1, u_core_type ct2)
+    | Pctf_attribute attr ->
+      Pctf_attribute (u_attribute attr)
+    | Pctf_extension ext -> Pctf_extension (u_extension ext)
+
+  and u_class_infos : 'a 'b. ('a -> 'b) -> 'a class_infos -> 'b class_infos =
+    fun u_a {pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes} ->
+    enter ();
+    let pci_params = List.map ~f:(fun (ct,v) -> (u_core_type ct, v)) pci_params in
+    let pci_name = u_loc pci_name in
+    let pci_expr = u_a pci_expr in
+    let pci_attributes = u_attributes pci_attributes in
+    let pci_loc = leave pci_loc in
+    {pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes}
+
+  and u_class_description clt = u_class_infos u_class_type clt
+
+  and u_class_type_declaration clt = u_class_infos u_class_type clt
+
+  and u_class_expr {pcl_desc; pcl_loc; pcl_attributes} =
+    enter ();
+    let pcl_desc = u_class_expr_desc pcl_desc in
+    let pcl_attributes = u_attributes pcl_attributes in
+    let pcl_loc = leave pcl_loc in
+    {pcl_desc; pcl_loc; pcl_attributes}
+
+  and u_class_expr_desc = function
+    | Pcl_constr (loc, cts) -> Pcl_constr (u_loc loc, List.map ~f:u_core_type cts)
+    | Pcl_structure cs -> Pcl_structure (u_class_structure cs)
+    | Pcl_fun (lbl, eo, p, ce) ->
+      Pcl_fun (lbl, u_option u_expression eo, u_pattern p, u_class_expr ce)
+    | Pcl_apply (ce, les) ->
+      Pcl_apply (u_class_expr ce, List.map ~f:(fun (l,e) -> (l, u_expression e)) les)
+    | Pcl_let (rf, vbs, ce) ->
+      Pcl_let (rf, List.map ~f:u_value_binding vbs, u_class_expr ce)
+    | Pcl_constraint (ce, ct) -> Pcl_constraint (u_class_expr ce, u_class_type ct)
+    | Pcl_extension ext -> Pcl_extension (u_extension ext)
+    | Pcl_open (od, ce) ->
+      Pcl_open (u_open_description od, u_class_expr ce)
+
+  and u_class_structure {pcstr_self; pcstr_fields} =
+    let pcstr_self = u_pattern pcstr_self in
+    let pcstr_fields = List.map ~f:u_class_field pcstr_fields in
+    {pcstr_self; pcstr_fields}
+
+  and u_class_field {pcf_desc; pcf_loc; pcf_attributes} =
+    enter ();
+    let pcf_desc = u_class_field_desc pcf_desc in
+    let pcf_attributes = u_attributes pcf_attributes in
+    let pcf_loc = leave pcf_loc in
+    {pcf_desc; pcf_loc; pcf_attributes}
+
+  and u_class_field_desc = function
+    | Pcf_inherit (fl, ce, so) -> Pcf_inherit (fl, u_class_expr ce, so)
+    | Pcf_val (loc, fl, cfk) -> Pcf_val (u_loc loc, fl, u_class_field_kind cfk)
+    | Pcf_method (loc, fl, cfk) -> Pcf_method (u_loc loc, fl, u_class_field_kind cfk)
+    | Pcf_constraint (c1, c2) -> Pcf_constraint (u_core_type c1, u_core_type c2)
+    | Pcf_initializer e -> Pcf_initializer (u_expression e)
+    | Pcf_attribute attr -> Pcf_attribute (u_attribute attr)
+    | Pcf_extension ext -> Pcf_extension (u_extension ext)
+
+  and u_class_field_kind = function
+    | Cfk_virtual ct -> Cfk_virtual (u_core_type ct)
+    | Cfk_concrete (fl,e) -> Cfk_concrete (fl, u_expression e)
+
+  and u_class_declaration cd = u_class_infos u_class_expr cd
+
+  and u_module_type {pmty_desc; pmty_loc; pmty_attributes} =
+    enter ();
+    let pmty_desc = u_module_type_desc pmty_desc in
+    let pmty_attributes = u_attributes pmty_attributes in
+    let pmty_loc = leave pmty_loc in
+    {pmty_desc; pmty_loc; pmty_attributes}
+
+  and u_module_type_desc = function
+    | Pmty_ident loc -> Pmty_ident (u_loc loc)
+    | Pmty_signature sg -> Pmty_signature (u_signature sg)
+    | Pmty_functor (fp, mt) -> Pmty_functor (u_functor_parameter fp, u_module_type mt)
+    | Pmty_with (mt, wts) -> Pmty_with (u_module_type mt, List.map ~f:u_with_constraint wts)
+    | Pmty_typeof me -> Pmty_typeof (u_module_expr me)
+    | Pmty_extension ext -> Pmty_extension (u_extension ext)
+    | Pmty_alias loc -> Pmty_alias (u_loc loc)
+
+  and u_functor_parameter = function
+    | Unit -> Unit
+    | Named (name, mt) -> Named (u_loc name, u_module_type mt)
+
+  and u_signature l = List.map ~f:u_signature_item l
+
+  and u_signature_item {psig_desc; psig_loc} =
+    enter ();
+    let psig_desc = u_signature_item_desc psig_desc in
+    let psig_loc = leave psig_loc in
+    {psig_desc; psig_loc}
+
+  and u_signature_item_desc = function
+    | Psig_value vd -> Psig_value (u_value_description vd)
+    | Psig_type (fl, tds) -> Psig_type (fl, List.map ~f:u_type_declaration tds)
+    | Psig_typext text -> Psig_typext (u_type_extension text)
+    | Psig_exception texn -> Psig_exception (u_type_exception texn)
+    | Psig_module md -> Psig_module (u_module_declaration md)
+    | Psig_recmodule mds -> Psig_recmodule (List.map ~f:u_module_declaration mds)
+    | Psig_modtype mtd -> Psig_modtype (u_module_type_declaration mtd)
+    | Psig_open od -> Psig_open (u_open_description od)
+    | Psig_include id -> Psig_include (u_include_description id)
+    | Psig_class cds -> Psig_class (List.map ~f:u_class_description cds)
+    | Psig_class_type cts -> Psig_class_type (List.map ~f:u_class_type_declaration cts)
+    | Psig_attribute attr -> Psig_attribute (u_attribute attr)
+    | Psig_extension (ext, attrs) -> Psig_extension (u_extension ext, u_attributes attrs)
+    | Psig_typesubst tds -> Psig_typesubst (List.map ~f:u_type_declaration tds)
+    | Psig_modsubst ms -> Psig_modsubst (u_module_substitution ms)
+    | Psig_modtypesubst mtd -> Psig_modtype (u_module_type_declaration mtd)
+
+  and u_type_exception {ptyexn_constructor; ptyexn_loc; ptyexn_attributes } =
+    { ptyexn_constructor = u_extension_constructor ptyexn_constructor
+    ; ptyexn_loc
+    ; ptyexn_attributes = u_attributes ptyexn_attributes }
+
+  and u_module_declaration {pmd_name; pmd_type; pmd_attributes; pmd_loc} =
+    enter ();
+    let pmd_name = u_loc pmd_name in
+    let pmd_type = u_module_type pmd_type in
+    let pmd_attributes = u_attributes pmd_attributes in
+    let pmd_loc = leave pmd_loc in
+    {pmd_name; pmd_type; pmd_attributes; pmd_loc}
+
+  and u_module_substitution {pms_name; pms_manifest; pms_attributes; pms_loc} =
+    let pms_name = u_loc pms_name in
+    let pms_manifest = u_loc pms_manifest in
+    let pms_attributes = u_attributes pms_attributes in
+    { pms_name; pms_manifest; pms_attributes; pms_loc }
+
+  and u_module_type_declaration {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} =
+    enter ();
+    let pmtd_name = u_loc pmtd_name in
+    let pmtd_type = u_option u_module_type pmtd_type in
+    let pmtd_attributes = u_attributes pmtd_attributes in
+    let pmtd_loc = leave pmtd_loc in
+    {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc}
+
+  and u_open_declaration {popen_expr; popen_override; popen_loc; popen_attributes} =
+    enter ();
+    let popen_expr = u_module_expr popen_expr in
+    let popen_attributes = u_attributes popen_attributes in
+    let popen_loc = leave popen_loc in
+    {popen_expr; popen_override; popen_loc; popen_attributes}
+
+  and u_open_description {popen_expr; popen_override; popen_loc; popen_attributes} =
+    enter ();
+    let popen_expr = u_loc popen_expr in
+    let popen_attributes = u_attributes popen_attributes in
+    let popen_loc = leave popen_loc in
+    {popen_expr; popen_override; popen_loc; popen_attributes}
+
+  and u_include_infos : 'a 'b . ('a -> 'b) -> 'a include_infos -> 'b include_infos =
+    fun u_a {pincl_mod; pincl_loc; pincl_attributes} ->
+    enter ();
+    let pincl_mod = u_a pincl_mod in
+    let pincl_attributes = u_attributes pincl_attributes in
+    let pincl_loc = leave pincl_loc in
+    {pincl_mod; pincl_loc; pincl_attributes}
+
+  and u_include_description id = u_include_infos u_module_type id
+  and u_include_declaration id = u_include_infos u_module_expr id
+
+  and u_with_constraint = function
+    | Pwith_type (loc, td) -> Pwith_type (u_loc loc, u_type_declaration td)
+    | Pwith_module (loc1, loc2) -> Pwith_module (u_loc loc1, u_loc loc2)
+    | Pwith_typesubst (loc, td) ->
+      Pwith_typesubst (u_loc loc, u_type_declaration td)
+    | Pwith_modsubst (loc1, loc2) -> Pwith_modsubst (u_loc loc1, u_loc loc2)
+    | Pwith_modtype (loc, mt) -> Pwith_modtype (u_loc loc, u_module_type mt)
+    | Pwith_modtypesubst (loc, mt) ->
+      Pwith_modtypesubst (u_loc loc, u_module_type mt)
+
+  and u_module_expr {pmod_desc; pmod_loc; pmod_attributes} =
+    enter ();
+    let pmod_desc = u_module_expr_desc pmod_desc in
+    let pmod_attributes = u_attributes pmod_attributes in
+    let pmod_loc = leave pmod_loc in
+    {pmod_desc; pmod_loc; pmod_attributes}
+
+  and u_module_expr_desc = function
+    | Pmod_ident loc -> Pmod_ident (u_loc loc)
+    | Pmod_structure str -> Pmod_structure (u_structure str)
+    | Pmod_functor (fp, me) ->
+      Pmod_functor (u_functor_parameter fp, u_module_expr me)
+    | Pmod_apply (me1, me2) ->
+      Pmod_apply (u_module_expr me1, u_module_expr me2)
+    | Pmod_constraint (me, mt) ->
+      Pmod_constraint (u_module_expr me, u_module_type mt)
+    | Pmod_unpack e -> Pmod_unpack (u_expression e)
+    | Pmod_extension ext -> Pmod_extension (u_extension ext)
+
+  and u_structure l = List.map ~f:u_structure_item l
+
+  and u_structure_item {pstr_desc; pstr_loc} =
+    enter ();
+    let pstr_desc = u_structure_item_desc pstr_desc in
+    let pstr_loc = leave pstr_loc in
+    {pstr_desc; pstr_loc}
+
+  and u_structure_item_desc = function
+    | Pstr_eval (expr, attrs) -> Pstr_eval (u_expression expr, u_attributes attrs)
+    | Pstr_value (fl, vbs) -> Pstr_value (fl, List.map ~f:u_value_binding vbs)
+    | Pstr_primitive vd -> Pstr_primitive (u_value_description vd)
+    | Pstr_type (fl, tds) -> Pstr_type (fl, List.map ~f:u_type_declaration tds)
+    | Pstr_typext text -> Pstr_typext (u_type_extension text)
+    | Pstr_exception texn -> Pstr_exception (u_type_exception texn)
+    | Pstr_module mb -> Pstr_module (u_module_binding mb)
+    | Pstr_recmodule mbs -> Pstr_recmodule (List.map ~f:u_module_binding mbs)
+    | Pstr_modtype mtd -> Pstr_modtype (u_module_type_declaration mtd)
+    | Pstr_open od -> Pstr_open (u_open_declaration od)
+    | Pstr_class cds -> Pstr_class (List.map ~f:u_class_declaration cds)
+    | Pstr_class_type ctds -> Pstr_class_type (List.map ~f:u_class_type_declaration ctds)
+    | Pstr_include id -> Pstr_include (u_include_declaration id)
+    | Pstr_attribute attr -> Pstr_attribute (u_attribute attr)
+    | Pstr_extension (ext, attrs) -> Pstr_extension (u_extension ext, u_attributes attrs)
+
+  and u_value_binding {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} =
+    enter ();
+    let pvb_pat = u_pattern pvb_pat in
+    let pvb_expr = u_expression pvb_expr in
+    let pvb_attributes = u_attributes pvb_attributes in
+    let pvb_loc = leave pvb_loc in
+    {pvb_pat; pvb_expr; pvb_attributes; pvb_loc}
+
+  and u_module_binding {pmb_name; pmb_expr; pmb_attributes; pmb_loc} =
+    enter ();
+    let pmb_name = u_loc pmb_name in
+    let pmb_expr = u_module_expr pmb_expr in
+    let pmb_attributes = u_attributes pmb_attributes in
+    let pmb_loc = leave pmb_loc in
+    {pmb_name; pmb_expr; pmb_attributes; pmb_loc}
+end
+
+let rewrite_loc t =
+  Rewrite_loc.start ();
+  let t = match t with
+    | `str str -> `str (Rewrite_loc.u_structure str)
+    | `fake str -> `fake (Rewrite_loc.u_structure str)
+    | `sg sg -> `sg (Rewrite_loc.u_signature sg)
+  in
+  Rewrite_loc.exit ();
+  t
diff --git a/src/ocaml/merlin_specific/typer_raw.mli b/src/ocaml/merlin_specific/typer_raw.mli
new file mode 100644
index 0000000..669bdf1
--- /dev/null
+++ b/src/ocaml/merlin_specific/typer_raw.mli
@@ -0,0 +1,35 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+val fresh_env : unit -> Env.t
+
+val rewrite_loc :
+  [ `str of Parsetree.structure | `sg of Parsetree.signature
+  | `fake of Parsetree.structure ] ->
+  [ `str of Parsetree.structure | `sg of Parsetree.signature
+  | `fake of Parsetree.structure ]
diff --git a/src/ocaml/parsing/ast_helper.ml b/src/ocaml/parsing/ast_helper.ml
new file mode 100644
index 0000000..e181b9a
--- /dev/null
+++ b/src/ocaml/parsing/ast_helper.ml
@@ -0,0 +1,691 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Helpers to produce Parsetree fragments *)
+
+open Asttypes
+open Parsetree
+open Docstrings
+open Msupport_parsing
+
+type 'a with_loc = 'a Location.loc
+type loc = Location.t
+
+type lid = Longident.t with_loc
+type str = string with_loc
+type str_opt = string option with_loc
+type attrs = attribute list
+
+let default_loc = ref Location.none
+
+let const_string s = Pconst_string (s, !default_loc, None)
+
+let with_default_loc l f =
+  Misc.protect_refs [Misc.R (default_loc, l)] f
+
+module Const = struct
+  let integer ?suffix i = Pconst_integer (i, suffix)
+  let int ?suffix i = integer ?suffix (Int.to_string i)
+  let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i)
+  let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i)
+  let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i)
+  let float ?suffix f = Pconst_float (f, suffix)
+  let char c = Pconst_char c
+  let string ?quotation_delimiter ?(loc= !default_loc) s =
+    Pconst_string (s, loc, quotation_delimiter)
+end
+
+module Attr = struct
+  let mk ?(loc= !default_loc) name payload =
+    { attr_name = name;
+      attr_payload = payload;
+      attr_loc = loc }
+
+  let as_tuple { attr_name; attr_payload; _ } = (attr_name, attr_payload)
+end
+
+module Typ = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {ptyp_desc = d;
+     ptyp_loc = loc;
+     ptyp_loc_stack = [];
+     ptyp_attributes = attrs}
+
+  let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]}
+
+  let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any
+  let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a)
+  let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c))
+  let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a)
+  let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b))
+  let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b))
+  let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b))
+  let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b))
+  let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c))
+  let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b))
+  let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b))
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a)
+
+  let force_poly t =
+    match t.ptyp_desc with
+    | Ptyp_poly _ -> t
+    | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *)
+
+  let varify_constructors var_names t =
+    let check_variable vl loc v =
+      if List.mem v vl then
+        raise_error Syntaxerr.(Error(Variable_in_scope(loc,v))) in
+    let var_names = List.map (fun v -> v.txt) var_names in
+    let rec loop t =
+      let desc =
+        match t.ptyp_desc with
+        | Ptyp_any -> Ptyp_any
+        | Ptyp_var x ->
+            check_variable var_names t.ptyp_loc x;
+            Ptyp_var x
+        | Ptyp_arrow (label,core_type,core_type') ->
+            Ptyp_arrow(label, loop core_type, loop core_type')
+        | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst)
+        | Ptyp_constr( { txt = Longident.Lident s }, [])
+          when List.mem s var_names ->
+            Ptyp_var s
+        | Ptyp_constr(longident, lst) ->
+            Ptyp_constr(longident, List.map loop lst)
+        | Ptyp_object (lst, o) ->
+            Ptyp_object (List.map loop_object_field lst, o)
+        | Ptyp_class (longident, lst) ->
+            Ptyp_class (longident, List.map loop lst)
+        | Ptyp_alias(core_type, string) ->
+            check_variable var_names t.ptyp_loc string;
+            Ptyp_alias(loop core_type, string)
+        | Ptyp_variant(row_field_list, flag, lbl_lst_option) ->
+            Ptyp_variant(List.map loop_row_field row_field_list,
+                         flag, lbl_lst_option)
+        | Ptyp_poly(string_lst, core_type) ->
+          List.iter (fun v ->
+            check_variable var_names t.ptyp_loc v.txt) string_lst;
+            Ptyp_poly(string_lst, loop core_type)
+        | Ptyp_package(longident,lst) ->
+            Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst)
+        | Ptyp_extension (s, arg) ->
+            Ptyp_extension (s, arg)
+      in
+      {t with ptyp_desc = desc}
+    and loop_row_field field =
+      let prf_desc = match field.prf_desc with
+        | Rtag(label,flag,lst) ->
+            Rtag(label,flag,List.map loop lst)
+        | Rinherit t ->
+            Rinherit (loop t)
+      in
+      { field with prf_desc; }
+    and loop_object_field field =
+      let pof_desc = match field.pof_desc with
+        | Otag(label, t) ->
+            Otag(label, loop t)
+        | Oinherit t ->
+            Oinherit (loop t)
+      in
+      { field with pof_desc; }
+    in
+    loop t
+
+end
+
+module Pat = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {ppat_desc = d;
+     ppat_loc = loc;
+     ppat_loc_stack = [];
+     ppat_attributes = attrs}
+  let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]}
+
+  let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any
+  let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a)
+  let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b))
+  let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a)
+  let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b))
+  let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a)
+  let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b))
+  let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b))
+  let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b))
+  let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a)
+  let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b))
+  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b))
+  let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a)
+  let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a)
+  let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a)
+  let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b))
+  let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a)
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a)
+end
+
+(* Merlin's holes *)
+let hole_txt = "merlin.hole"
+
+module Exp = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {pexp_desc = d;
+     pexp_loc = loc;
+     pexp_loc_stack = [];
+     pexp_attributes = attrs}
+  let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]}
+
+  let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a)
+  let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a)
+  let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c))
+  let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d))
+  let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a)
+  let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b))
+  let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b))
+  let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b))
+  let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a)
+  let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b))
+  let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b))
+  let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b))
+  let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b))
+  let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c))
+  let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a)
+  let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c))
+  let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b))
+  let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b))
+  let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e))
+  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b))
+  let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c))
+  let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b))
+  let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a)
+  let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b))
+  let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a)
+  let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c))
+  let letmodule_no_opt ?loc ?attrs s b c=
+    let a = Location.mknoloc (Some s) in
+    mk ?loc ?attrs (Pexp_letmodule (a, b, c))
+  let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b))
+  let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a)
+  let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a)
+  let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b))
+  let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a)
+  let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b))
+  let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a)
+  let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_open (a, b))
+  let letop ?loc ?attrs let_ ands body =
+    mk ?loc ?attrs (Pexp_letop {let_; ands; body})
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a)
+  let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable
+  let hole ?(loc = !default_loc) ?attrs () =
+    let id = Location.mkloc hole_txt loc in
+    mk ~loc ?attrs  @@ Pexp_extension (id, PStr [])
+
+  let case lhs ?guard rhs =
+    {
+     pc_lhs = lhs;
+     pc_guard = guard;
+     pc_rhs = rhs;
+    }
+
+  let binding_op op pat exp loc =
+    {
+      pbop_op = op;
+      pbop_pat = pat;
+      pbop_exp = exp;
+      pbop_loc = loc;
+    }
+end
+
+module Mty = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs}
+  let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]}
+
+  let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a)
+  let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a)
+  let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a)
+  let functor_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_functor (a, b))
+  let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b))
+  let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a)
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a)
+end
+
+module Mod = struct
+let mk ?(loc = !default_loc) ?(attrs = []) d =
+  {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs}
+  let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]}
+
+  let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x)
+  let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x)
+  let functor_ ?loc ?attrs arg body =
+    mk ?loc ?attrs (Pmod_functor (arg, body))
+  let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2))
+  let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty))
+  let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e)
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a)
+  let hole ?(loc = !default_loc) ?attrs () =
+    let id = Location.mkloc hole_txt loc in
+    mk ~loc ?attrs  @@ Pmod_extension (id, PStr [])
+end
+
+module Sig = struct
+  let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc}
+
+  let value ?loc a = mk ?loc (Psig_value a)
+  let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a))
+  let type_subst ?loc a = mk ?loc (Psig_typesubst a)
+  let type_extension ?loc a = mk ?loc (Psig_typext a)
+  let exception_ ?loc a = mk ?loc (Psig_exception a)
+  let module_ ?loc a = mk ?loc (Psig_module a)
+  let mod_subst ?loc a = mk ?loc (Psig_modsubst a)
+  let rec_module ?loc a = mk ?loc (Psig_recmodule a)
+  let modtype ?loc a = mk ?loc (Psig_modtype a)
+  let modtype_subst ?loc a = mk ?loc (Psig_modtypesubst a)
+  let open_ ?loc a = mk ?loc (Psig_open a)
+  let include_ ?loc a = mk ?loc (Psig_include a)
+  let class_ ?loc a = mk ?loc (Psig_class a)
+  let class_type ?loc a = mk ?loc (Psig_class_type a)
+  let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs))
+  let attribute ?loc a = mk ?loc (Psig_attribute a)
+  let text txt =
+    let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
+    List.map
+      (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
+      f_txt
+end
+
+module Str = struct
+  let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc}
+
+  let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs))
+  let value ?loc a b = mk ?loc (Pstr_value (a, b))
+  let primitive ?loc a = mk ?loc (Pstr_primitive a)
+  let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a))
+  let type_extension ?loc a = mk ?loc (Pstr_typext a)
+  let exception_ ?loc a = mk ?loc (Pstr_exception a)
+  let module_ ?loc a = mk ?loc (Pstr_module a)
+  let rec_module ?loc a = mk ?loc (Pstr_recmodule a)
+  let modtype ?loc a = mk ?loc (Pstr_modtype a)
+  let open_ ?loc a = mk ?loc (Pstr_open a)
+  let class_ ?loc a = mk ?loc (Pstr_class a)
+  let class_type ?loc a = mk ?loc (Pstr_class_type a)
+  let include_ ?loc a = mk ?loc (Pstr_include a)
+  let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs))
+  let attribute ?loc a = mk ?loc (Pstr_attribute a)
+  let text txt =
+    let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
+    List.map
+      (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
+      f_txt
+end
+
+module Cl = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {
+     pcl_desc = d;
+     pcl_loc = loc;
+     pcl_attributes = attrs;
+    }
+  let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]}
+
+  let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b))
+  let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a)
+  let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d))
+  let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b))
+  let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c))
+  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b))
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a)
+  let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_open (a, b))
+end
+
+module Cty = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {
+     pcty_desc = d;
+     pcty_loc = loc;
+     pcty_attributes = attrs;
+    }
+  let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]}
+
+  let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b))
+  let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a)
+  let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c))
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a)
+  let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcty_open (a, b))
+end
+
+module Ctf = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+           ?(docs = empty_docs) d =
+    {
+     pctf_desc = d;
+     pctf_loc = loc;
+     pctf_attributes = add_docs_attrs docs attrs;
+    }
+
+  let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a)
+  let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d))
+  let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d))
+  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b))
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a)
+  let attribute ?loc a = mk ?loc (Pctf_attribute a)
+  let text txt =
+   let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
+     List.map
+      (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
+      f_txt
+
+  let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]}
+
+end
+
+module Cf = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) d =
+    {
+     pcf_desc = d;
+     pcf_loc = loc;
+     pcf_attributes = add_docs_attrs docs attrs;
+    }
+
+  let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c))
+  let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c))
+  let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c))
+  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b))
+  let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a)
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a)
+  let attribute ?loc a = mk ?loc (Pcf_attribute a)
+  let text txt =
+    let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
+    List.map
+      (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
+      f_txt
+
+  let virtual_ ct = Cfk_virtual ct
+  let concrete o e = Cfk_concrete (o, e)
+
+  let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]}
+
+end
+
+module Val = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+        ?(prim = []) name typ =
+    {
+     pval_name = name;
+     pval_type = typ;
+     pval_attributes = add_docs_attrs docs attrs;
+     pval_loc = loc;
+     pval_prim = prim;
+    }
+end
+
+module Md = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = []) name typ =
+    {
+     pmd_name = name;
+     pmd_type = typ;
+     pmd_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pmd_loc = loc;
+    }
+end
+
+module Ms = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = []) name syn =
+    {
+     pms_name = name;
+     pms_manifest = syn;
+     pms_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pms_loc = loc;
+    }
+end
+
+module Mtd = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = []) ?typ name =
+    {
+     pmtd_name = name;
+     pmtd_type = typ;
+     pmtd_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pmtd_loc = loc;
+    }
+end
+
+module Mb = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = []) name expr =
+    {
+     pmb_name = name;
+     pmb_expr = expr;
+     pmb_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pmb_loc = loc;
+    }
+end
+
+module Opn = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+        ?(override = Fresh) expr =
+    {
+     popen_expr = expr;
+     popen_override = override;
+     popen_loc = loc;
+     popen_attributes = add_docs_attrs docs attrs;
+    }
+end
+
+module Incl = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr =
+    {
+     pincl_mod = mexpr;
+     pincl_loc = loc;
+     pincl_attributes = add_docs_attrs docs attrs;
+    }
+
+end
+
+module Vb = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+        ?(text = []) pat expr =
+    {
+     pvb_pat = pat;
+     pvb_expr = expr;
+     pvb_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pvb_loc = loc;
+    }
+end
+
+module Ci = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = [])
+        ?(virt = Concrete) ?(params = []) name expr =
+    {
+     pci_virt = virt;
+     pci_params = params;
+     pci_name = name;
+     pci_expr = expr;
+     pci_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pci_loc = loc;
+    }
+end
+
+module Type = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = [])
+      ?(params = [])
+      ?(cstrs = [])
+      ?(kind = Ptype_abstract)
+      ?(priv = Public)
+      ?manifest
+      name =
+    {
+     ptype_name = name;
+     ptype_params = params;
+     ptype_cstrs = cstrs;
+     ptype_kind = kind;
+     ptype_private = priv;
+     ptype_manifest = manifest;
+     ptype_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     ptype_loc = loc;
+    }
+
+  let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info)
+        ?(args = Pcstr_tuple []) ?res name =
+    {
+     pcd_name = name;
+     pcd_args = args;
+     pcd_res = res;
+     pcd_loc = loc;
+     pcd_attributes = add_info_attrs info attrs;
+    }
+
+  let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info)
+        ?(mut = Immutable) name typ =
+    {
+     pld_name = name;
+     pld_mutable = mut;
+     pld_type = typ;
+     pld_loc = loc;
+     pld_attributes = add_info_attrs info attrs;
+    }
+
+end
+
+(** Type extensions *)
+module Te = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+        ?(params = []) ?(priv = Public) path constructors =
+    {
+     ptyext_path = path;
+     ptyext_params = params;
+     ptyext_constructors = constructors;
+     ptyext_private = priv;
+     ptyext_loc = loc;
+     ptyext_attributes = add_docs_attrs docs attrs;
+    }
+
+  let mk_exception ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+      constructor =
+    {
+     ptyexn_constructor = constructor;
+     ptyexn_loc = loc;
+     ptyexn_attributes = add_docs_attrs docs attrs;
+    }
+
+  let constructor ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(info = empty_info) name kind =
+    {
+     pext_name = name;
+     pext_kind = kind;
+     pext_loc = loc;
+     pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
+    }
+
+  let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+             ?(info = empty_info) ?(args = Pcstr_tuple []) ?res name =
+    {
+     pext_name = name;
+     pext_kind = Pext_decl(args, res);
+     pext_loc = loc;
+     pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
+    }
+
+  let rebind ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(info = empty_info) name lid =
+    {
+     pext_name = name;
+     pext_kind = Pext_rebind lid;
+     pext_loc = loc;
+     pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
+    }
+
+end
+
+module Csig = struct
+  let mk self fields =
+    {
+     pcsig_self = self;
+     pcsig_fields = fields;
+    }
+end
+
+module Cstr = struct
+  let mk self fields =
+    {
+     pcstr_self = self;
+     pcstr_fields = fields;
+    }
+end
+
+(** Row fields *)
+module Rf = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) desc = {
+    prf_desc = desc;
+    prf_loc = loc;
+    prf_attributes = attrs;
+  }
+  let tag ?loc ?attrs label const tys =
+    mk ?loc ?attrs (Rtag (label, const, tys))
+  let inherit_?loc ty =
+    mk ?loc (Rinherit ty)
+end
+
+(** Object fields *)
+module Of = struct
+  let mk ?(loc = !default_loc) ?(attrs=[]) desc = {
+    pof_desc = desc;
+    pof_loc = loc;
+    pof_attributes = attrs;
+  }
+  let tag ?loc ?attrs label ty =
+    mk ?loc ?attrs (Otag (label, ty))
+  let inherit_ ?loc ty =
+    mk ?loc (Oinherit ty)
+end
+
+(** merlin: refactored out of Parser *)
+
+type let_binding =
+  { lb_pattern: pattern;
+    lb_expression: expression;
+    lb_is_pun: bool;
+    lb_attributes: attributes;
+    lb_docs: docs Lazy.t;
+    lb_text: text Lazy.t;
+    lb_loc: Location.t; }
+
+type let_bindings =
+  { lbs_bindings: let_binding list;
+    lbs_rec: rec_flag;
+    lbs_extension: string Asttypes.loc option }
+
+
+(* merlin specific *)
+
+let no_label = Nolabel
+
+(* Can't be put in Raw_compat because that module depends on library "parsing",
+   but we need that function in this library *)
+let extract_str_payload = function
+  | PStr [{ pstr_desc = Pstr_eval (
+      {Parsetree. pexp_loc; pexp_desc =
+         Parsetree.Pexp_constant (Parsetree.Pconst_string (msg, _, _)) ; _ }, _
+    ); _ }] ->
+    Some (msg, pexp_loc)
+  | _ -> None
diff --git a/src/ocaml/parsing/ast_helper.mli b/src/ocaml/parsing/ast_helper.mli
new file mode 100644
index 0000000..941d210
--- /dev/null
+++ b/src/ocaml/parsing/ast_helper.mli
@@ -0,0 +1,524 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Helpers to produce Parsetree fragments
+
+  {b Warning} This module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Asttypes
+open Docstrings
+open Parsetree
+
+type 'a with_loc = 'a Location.loc
+type loc = Location.t
+
+type lid = Longident.t with_loc
+type str = string with_loc
+type str_opt = string option with_loc
+type attrs = attribute list
+
+val const_string : string -> constant
+
+(** {1 Default locations} *)
+
+val default_loc: loc ref
+    (** Default value for all optional location arguments. *)
+
+val with_default_loc: loc -> (unit -> 'a) -> 'a
+    (** Set the [default_loc] within the scope of the execution
+        of the provided function. *)
+
+(** {1 Constants} *)
+
+module Const : sig
+  val char : char -> constant
+  val string :
+    ?quotation_delimiter:string -> ?loc:Location.t -> string -> constant
+  val integer : ?suffix:char -> string -> constant
+  val int : ?suffix:char -> int -> constant
+  val int32 : ?suffix:char -> int32 -> constant
+  val int64 : ?suffix:char -> int64 -> constant
+  val nativeint : ?suffix:char -> nativeint -> constant
+  val float : ?suffix:char -> string -> constant
+end
+
+(** {1 Attributes} *)
+module Attr : sig
+  val mk: ?loc:loc -> str -> payload -> attribute
+
+  val as_tuple : attribute -> str * payload
+end
+
+(** {1 Core language} *)
+
+(** Type expressions *)
+module Typ :
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type
+    val attr: core_type -> attribute -> core_type
+
+    val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type
+    val var: ?loc:loc -> ?attrs:attrs -> string -> core_type
+    val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type
+               -> core_type
+    val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type
+    val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
+    val object_: ?loc:loc -> ?attrs:attrs -> object_field list
+                   -> closed_flag -> core_type
+    val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
+    val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type
+    val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag
+                 -> label list option -> core_type
+    val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type
+    val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list
+                 -> core_type
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type
+
+    val force_poly: core_type -> core_type
+
+    val varify_constructors: str list -> core_type -> core_type
+    (** [varify_constructors newtypes te] is type expression [te], of which
+        any of nullary type constructor [tc] is replaced by type variable of
+        the same name, if [tc]'s name appears in [newtypes].
+        Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te]
+        appears in [newtypes].
+        @since 4.05
+     *)
+  end
+
+(** Patterns *)
+module Pat:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern
+    val attr:pattern -> attribute -> pattern
+
+    val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern
+    val var: ?loc:loc -> ?attrs:attrs -> str -> pattern
+    val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern
+    val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern
+    val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern
+    val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern
+    val construct: ?loc:loc -> ?attrs:attrs ->
+      lid -> (str list * pattern) option -> pattern
+    val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern
+    val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag
+                -> pattern
+    val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern
+    val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern
+    val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern
+    val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern
+    val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern
+    val unpack: ?loc:loc -> ?attrs:attrs -> str_opt -> pattern
+    val open_: ?loc:loc -> ?attrs:attrs  -> lid -> pattern -> pattern
+    val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern
+  end
+
+(** Expressions *)
+module Exp:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression
+    val attr: expression -> attribute -> expression
+
+    val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression
+    val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression
+    val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list
+              -> expression -> expression
+    val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option
+              -> pattern -> expression -> expression
+    val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression
+    val apply: ?loc:loc -> ?attrs:attrs -> expression
+               -> (arg_label * expression) list -> expression
+    val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list
+                -> expression
+    val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression
+    val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression
+    val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option
+                   -> expression
+    val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option
+                 -> expression
+    val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list
+                -> expression option -> expression
+    val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression
+    val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression
+                  -> expression
+    val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression
+    val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression
+                    -> expression option -> expression
+    val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression
+                  -> expression
+    val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression
+                -> expression
+    val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression
+              -> direction_flag -> expression -> expression
+    val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option
+                -> core_type -> expression
+    val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type
+                     -> expression
+    val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression
+    val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression
+    val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression
+    val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list
+                  -> expression
+    val letmodule: ?loc:loc -> ?attrs:attrs -> str_opt -> module_expr
+                   -> expression -> expression
+    val letmodule_no_opt: ?loc:loc -> ?attrs:attrs -> label -> module_expr
+                   -> expression -> expression
+    val letexception:
+      ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression
+      -> expression
+    val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression
+    val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression
+    val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option
+              -> expression
+    val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression
+    val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression
+    val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression
+    val open_: ?loc:loc -> ?attrs:attrs -> open_declaration -> expression
+               -> expression
+    val letop: ?loc:loc -> ?attrs:attrs -> binding_op
+               -> binding_op list -> expression -> expression
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression
+    val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression
+
+    val case: pattern -> ?guard:expression -> expression -> case
+    val binding_op: str -> pattern -> expression -> loc -> binding_op
+    val hole: ?loc:loc -> ?attrs:attrs -> unit -> expression
+  end
+
+(** Value declarations *)
+module Val:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
+      ?prim:string list -> str -> core_type -> value_description
+  end
+
+(** Type declarations *)
+module Type:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      ?params:(core_type * (variance * injectivity)) list ->
+      ?cstrs:(core_type * core_type * loc) list ->
+      ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str ->
+      type_declaration
+
+    val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info ->
+      ?args:constructor_arguments -> ?res:core_type -> str ->
+      constructor_declaration
+    val field: ?loc:loc -> ?attrs:attrs -> ?info:info ->
+      ?mut:mutable_flag -> str -> core_type -> label_declaration
+  end
+
+(** Type extensions *)
+module Te:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
+      ?params:(core_type * (variance * injectivity)) list -> ?priv:private_flag ->
+      lid -> extension_constructor list -> type_extension
+
+    val mk_exception: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
+      extension_constructor -> type_exception
+
+    val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
+      str -> extension_constructor_kind -> extension_constructor
+
+    val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
+      ?args:constructor_arguments -> ?res:core_type -> str ->
+      extension_constructor
+    val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
+      str -> lid -> extension_constructor
+  end
+
+(** {1 Module language} *)
+
+(** Module type expressions *)
+module Mty:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type
+    val attr: module_type -> attribute -> module_type
+
+    val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type
+    val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type
+    val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type
+    val functor_: ?loc:loc -> ?attrs:attrs ->
+      functor_parameter -> module_type -> module_type
+    val with_: ?loc:loc -> ?attrs:attrs -> module_type ->
+      with_constraint list -> module_type
+    val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type
+  end
+
+(** Module expressions *)
+module Mod:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr
+    val attr: module_expr -> attribute -> module_expr
+
+    val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr
+    val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr
+    val functor_: ?loc:loc -> ?attrs:attrs ->
+      functor_parameter -> module_expr -> module_expr
+    val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr ->
+      module_expr
+    val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type ->
+      module_expr
+    val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr
+    val hole: ?loc:loc -> ?attrs:attrs -> unit -> module_expr
+  end
+
+(** Signature items *)
+module Sig:
+  sig
+    val mk: ?loc:loc -> signature_item_desc -> signature_item
+
+    val value: ?loc:loc -> value_description -> signature_item
+    val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item
+    val type_subst: ?loc:loc -> type_declaration list -> signature_item
+    val type_extension: ?loc:loc -> type_extension -> signature_item
+    val exception_: ?loc:loc -> type_exception -> signature_item
+    val module_: ?loc:loc -> module_declaration -> signature_item
+    val mod_subst: ?loc:loc -> module_substitution -> signature_item
+    val rec_module: ?loc:loc -> module_declaration list -> signature_item
+    val modtype: ?loc:loc -> module_type_declaration -> signature_item
+    val modtype_subst: ?loc:loc -> module_type_declaration -> signature_item
+    val open_: ?loc:loc -> open_description -> signature_item
+    val include_: ?loc:loc -> include_description -> signature_item
+    val class_: ?loc:loc -> class_description list -> signature_item
+    val class_type: ?loc:loc -> class_type_declaration list -> signature_item
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item
+    val attribute: ?loc:loc -> attribute -> signature_item
+    val text: text -> signature_item list
+  end
+
+(** Structure items *)
+module Str:
+  sig
+    val mk: ?loc:loc -> structure_item_desc -> structure_item
+
+    val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item
+    val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item
+    val primitive: ?loc:loc -> value_description -> structure_item
+    val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item
+    val type_extension: ?loc:loc -> type_extension -> structure_item
+    val exception_: ?loc:loc -> type_exception -> structure_item
+    val module_: ?loc:loc -> module_binding -> structure_item
+    val rec_module: ?loc:loc -> module_binding list -> structure_item
+    val modtype: ?loc:loc -> module_type_declaration -> structure_item
+    val open_: ?loc:loc -> open_declaration -> structure_item
+    val class_: ?loc:loc -> class_declaration list -> structure_item
+    val class_type: ?loc:loc -> class_type_declaration list -> structure_item
+    val include_: ?loc:loc -> include_declaration -> structure_item
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item
+    val attribute: ?loc:loc -> attribute -> structure_item
+    val text: text -> structure_item list
+  end
+
+(** Module declarations *)
+module Md:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      str_opt -> module_type -> module_declaration
+  end
+
+(** Module substitutions *)
+module Ms:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      str -> lid -> module_substitution
+  end
+
+(** Module type declarations *)
+module Mtd:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      ?typ:module_type -> str -> module_type_declaration
+  end
+
+(** Module bindings *)
+module Mb:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      str_opt -> module_expr -> module_binding
+  end
+
+(** Opens *)
+module Opn:
+  sig
+    val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs ->
+      ?override:override_flag -> 'a -> 'a open_infos
+  end
+
+(** Includes *)
+module Incl:
+  sig
+    val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos
+  end
+
+(** Value bindings *)
+module Vb:
+  sig
+    val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      pattern -> expression -> value_binding
+  end
+
+
+(** {1 Class language} *)
+
+(** Class type expressions *)
+module Cty:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type
+    val attr: class_type -> attribute -> class_type
+
+    val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type
+    val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type
+    val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type ->
+      class_type -> class_type
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type
+    val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_type
+               -> class_type
+  end
+
+(** Class type fields *)
+module Ctf:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
+      class_type_field_desc -> class_type_field
+    val attr: class_type_field -> attribute -> class_type_field
+
+    val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field
+    val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag ->
+      virtual_flag -> core_type -> class_type_field
+    val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag ->
+      virtual_flag -> core_type -> class_type_field
+    val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type ->
+      class_type_field
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field
+    val attribute: ?loc:loc -> attribute -> class_type_field
+    val text: text -> class_type_field list
+  end
+
+(** Class expressions *)
+module Cl:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr
+    val attr: class_expr -> attribute -> class_expr
+
+    val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr
+    val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr
+    val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option ->
+      pattern -> class_expr -> class_expr
+    val apply: ?loc:loc -> ?attrs:attrs -> class_expr ->
+      (arg_label * expression) list -> class_expr
+    val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list ->
+      class_expr -> class_expr
+    val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type ->
+      class_expr
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr
+    val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_expr
+               -> class_expr
+  end
+
+(** Class fields *)
+module Cf:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc ->
+      class_field
+    val attr: class_field -> attribute -> class_field
+
+    val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr ->
+      str option -> class_field
+    val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag ->
+      class_field_kind -> class_field
+    val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag ->
+      class_field_kind -> class_field
+    val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type ->
+      class_field
+    val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field
+    val attribute: ?loc:loc -> attribute -> class_field
+    val text: text -> class_field list
+
+    val virtual_: core_type -> class_field_kind
+    val concrete: override_flag -> expression -> class_field_kind
+
+  end
+
+(** Classes *)
+module Ci:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      ?virt:virtual_flag ->
+      ?params:(core_type * (variance * injectivity)) list ->
+      str -> 'a -> 'a class_infos
+  end
+
+(** Class signatures *)
+module Csig:
+  sig
+    val mk: core_type -> class_type_field list -> class_signature
+  end
+
+(** Class structures *)
+module Cstr:
+  sig
+    val mk: pattern -> class_field list -> class_structure
+  end
+
+(** Row fields *)
+module Rf:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> row_field_desc -> row_field
+    val tag: ?loc:loc -> ?attrs:attrs ->
+      label with_loc -> bool -> core_type list -> row_field
+    val inherit_: ?loc:loc -> core_type -> row_field
+  end
+
+(** Object fields *)
+module Of:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs ->
+      object_field_desc -> object_field
+    val tag: ?loc:loc -> ?attrs:attrs ->
+      label with_loc -> core_type -> object_field
+    val inherit_: ?loc:loc -> core_type -> object_field
+  end
+
+(** merlin: refactored out of Parser *)
+
+type let_binding =
+  { lb_pattern: pattern;
+    lb_expression: expression;
+    lb_is_pun: bool;
+    lb_attributes: attributes;
+    lb_docs: docs Lazy.t;
+    lb_text: text Lazy.t;
+    lb_loc: Location.t; }
+
+type let_bindings =
+  { lbs_bindings: let_binding list;
+    lbs_rec: rec_flag;
+    lbs_extension: string Asttypes.loc option }
+
+
+(* merlin specific *)
+
+val no_label : arg_label
+val extract_str_payload : payload -> (string * Location.t) option
+val hole_txt : string
diff --git a/src/ocaml/parsing/ast_iterator.ml b/src/ocaml/parsing/ast_iterator.ml
new file mode 100644
index 0000000..0b88be7
--- /dev/null
+++ b/src/ocaml/parsing/ast_iterator.ml
@@ -0,0 +1,682 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Nicolas Ojeda Bar, LexiFi                         *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* A generic Parsetree mapping class *)
+
+(*
+[@@@ocaml.warning "+9"]
+  (* Ensure that record patterns don't miss any field. *)
+*)
+
+
+open Parsetree
+open Location
+
+type iterator = {
+  attribute: iterator -> attribute -> unit;
+  attributes: iterator -> attribute list -> unit;
+  binding_op: iterator -> binding_op -> unit;
+  case: iterator -> case -> unit;
+  cases: iterator -> case list -> unit;
+  class_declaration: iterator -> class_declaration -> unit;
+  class_description: iterator -> class_description -> unit;
+  class_expr: iterator -> class_expr -> unit;
+  class_field: iterator -> class_field -> unit;
+  class_signature: iterator -> class_signature -> unit;
+  class_structure: iterator -> class_structure -> unit;
+  class_type: iterator -> class_type -> unit;
+  class_type_declaration: iterator -> class_type_declaration -> unit;
+  class_type_field: iterator -> class_type_field -> unit;
+  constructor_declaration: iterator -> constructor_declaration -> unit;
+  expr: iterator -> expression -> unit;
+  extension: iterator -> extension -> unit;
+  extension_constructor: iterator -> extension_constructor -> unit;
+  include_declaration: iterator -> include_declaration -> unit;
+  include_description: iterator -> include_description -> unit;
+  label_declaration: iterator -> label_declaration -> unit;
+  location: iterator -> Location.t -> unit;
+  module_binding: iterator -> module_binding -> unit;
+  module_declaration: iterator -> module_declaration -> unit;
+  module_substitution: iterator -> module_substitution -> unit;
+  module_expr: iterator -> module_expr -> unit;
+  module_type: iterator -> module_type -> unit;
+  module_type_declaration: iterator -> module_type_declaration -> unit;
+  open_declaration: iterator -> open_declaration -> unit;
+  open_description: iterator -> open_description -> unit;
+  pat: iterator -> pattern -> unit;
+  payload: iterator -> payload -> unit;
+  signature: iterator -> signature -> unit;
+  signature_item: iterator -> signature_item -> unit;
+  structure: iterator -> structure -> unit;
+  structure_item: iterator -> structure_item -> unit;
+  typ: iterator -> core_type -> unit;
+  row_field: iterator -> row_field -> unit;
+  object_field: iterator -> object_field -> unit;
+  type_declaration: iterator -> type_declaration -> unit;
+  type_extension: iterator -> type_extension -> unit;
+  type_exception: iterator -> type_exception -> unit;
+  type_kind: iterator -> type_kind -> unit;
+  value_binding: iterator -> value_binding -> unit;
+  value_description: iterator -> value_description -> unit;
+  with_constraint: iterator -> with_constraint -> unit;
+}
+(** A [iterator] record implements one "method" per syntactic category,
+    using an open recursion style: each method takes as its first
+    argument the iterator to be applied to children in the syntax
+    tree. *)
+
+let iter_fst f (x, _) = f x
+let iter_snd f (_, y) = f y
+let iter_tuple f1 f2 (x, y) = f1 x; f2 y
+let iter_tuple3 f1 f2 f3 (x, y, z) = f1 x; f2 y; f3 z
+let iter_opt f = function None -> () | Some x -> f x
+
+let iter_loc sub {loc; txt = _} = sub.location sub loc
+
+module T = struct
+  (* Type expressions for the core language *)
+
+  let row_field sub {
+      prf_desc;
+      prf_loc;
+      prf_attributes;
+    } =
+    sub.location sub prf_loc;
+    sub.attributes sub prf_attributes;
+    match prf_desc with
+    | Rtag (_, _, tl) -> List.iter (sub.typ sub) tl
+    | Rinherit t -> sub.typ sub t
+
+  let object_field sub {
+      pof_desc;
+      pof_loc;
+      pof_attributes;
+    } =
+    sub.location sub pof_loc;
+    sub.attributes sub pof_attributes;
+    match pof_desc with
+    | Otag (_, t) -> sub.typ sub t
+    | Oinherit t -> sub.typ sub t
+
+  let iter sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Ptyp_any
+    | Ptyp_var _ -> ()
+    | Ptyp_arrow (_lab, t1, t2) ->
+        sub.typ sub t1; sub.typ sub t2
+    | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl
+    | Ptyp_constr (lid, tl) ->
+        iter_loc sub lid; List.iter (sub.typ sub) tl
+    | Ptyp_object (ol, _o) ->
+        List.iter (object_field sub) ol
+    | Ptyp_class (lid, tl) ->
+        iter_loc sub lid; List.iter (sub.typ sub) tl
+    | Ptyp_alias (t, _) -> sub.typ sub t
+    | Ptyp_variant (rl, _b, _ll) ->
+        List.iter (row_field sub) rl
+    | Ptyp_poly (_, t) -> sub.typ sub t
+    | Ptyp_package (lid, l) ->
+        iter_loc sub lid;
+        List.iter (iter_tuple (iter_loc sub) (sub.typ sub)) l
+    | Ptyp_extension x -> sub.extension sub x
+
+  let iter_type_declaration sub
+      {ptype_name; ptype_params; ptype_cstrs;
+       ptype_kind;
+       ptype_private = _;
+       ptype_manifest;
+       ptype_attributes;
+       ptype_loc} =
+    iter_loc sub ptype_name;
+    List.iter (iter_fst (sub.typ sub)) ptype_params;
+    List.iter
+      (iter_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub))
+      ptype_cstrs;
+    sub.type_kind sub ptype_kind;
+    iter_opt (sub.typ sub) ptype_manifest;
+    sub.location sub ptype_loc;
+    sub.attributes sub ptype_attributes
+
+  let iter_type_kind sub = function
+    | Ptype_abstract -> ()
+    | Ptype_variant l ->
+        List.iter (sub.constructor_declaration sub) l
+    | Ptype_record l -> List.iter (sub.label_declaration sub) l
+    | Ptype_open -> ()
+
+  let iter_constructor_arguments sub = function
+    | Pcstr_tuple l -> List.iter (sub.typ sub) l
+    | Pcstr_record l ->
+        List.iter (sub.label_declaration sub) l
+
+  let iter_type_extension sub
+      {ptyext_path; ptyext_params;
+       ptyext_constructors;
+       ptyext_private = _;
+       ptyext_loc;
+       ptyext_attributes} =
+    iter_loc sub ptyext_path;
+    List.iter (sub.extension_constructor sub) ptyext_constructors;
+    List.iter (iter_fst (sub.typ sub)) ptyext_params;
+    sub.location sub ptyext_loc;
+    sub.attributes sub ptyext_attributes
+
+  let iter_type_exception sub
+      {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} =
+    sub.extension_constructor sub ptyexn_constructor;
+    sub.location sub ptyexn_loc;
+    sub.attributes sub ptyexn_attributes
+
+  let iter_extension_constructor_kind sub = function
+      Pext_decl(ctl, cto) ->
+        iter_constructor_arguments sub ctl; iter_opt (sub.typ sub) cto
+    | Pext_rebind li ->
+        iter_loc sub li
+
+  let iter_extension_constructor sub
+      {pext_name;
+       pext_kind;
+       pext_loc;
+       pext_attributes} =
+    iter_loc sub pext_name;
+    iter_extension_constructor_kind sub pext_kind;
+    sub.location sub pext_loc;
+    sub.attributes sub pext_attributes
+
+end
+
+module CT = struct
+  (* Type expressions for the class language *)
+
+  let iter sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pcty_constr (lid, tys) ->
+        iter_loc sub lid; List.iter (sub.typ sub) tys
+    | Pcty_signature x -> sub.class_signature sub x
+    | Pcty_arrow (_lab, t, ct) ->
+        sub.typ sub t; sub.class_type sub ct
+    | Pcty_extension x -> sub.extension sub x
+    | Pcty_open (o, e) ->
+        sub.open_description sub o; sub.class_type sub e
+
+  let iter_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
+    =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pctf_inherit ct -> sub.class_type sub ct
+    | Pctf_val (_s, _m, _v, t) -> sub.typ sub t
+    | Pctf_method (_s, _p, _v, t) -> sub.typ sub t
+    | Pctf_constraint (t1, t2) ->
+        sub.typ sub t1; sub.typ sub t2
+    | Pctf_attribute x -> sub.attribute sub x
+    | Pctf_extension x -> sub.extension sub x
+
+  let iter_signature sub {pcsig_self; pcsig_fields} =
+    sub.typ sub pcsig_self;
+    List.iter (sub.class_type_field sub) pcsig_fields
+end
+
+let iter_functor_param sub = function
+  | Unit -> ()
+  | Named (name, mty) ->
+    iter_loc sub name;
+    sub.module_type sub mty
+
+module MT = struct
+  (* Type expressions for the module language *)
+
+  let iter sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pmty_ident s -> iter_loc sub s
+    | Pmty_alias s -> iter_loc sub s
+    | Pmty_signature sg -> sub.signature sub sg
+    | Pmty_functor (param, mt2) ->
+        iter_functor_param sub param;
+        sub.module_type sub mt2
+    | Pmty_with (mt, l) ->
+        sub.module_type sub mt;
+        List.iter (sub.with_constraint sub) l
+    | Pmty_typeof me -> sub.module_expr sub me
+    | Pmty_extension x -> sub.extension sub x
+
+  let iter_with_constraint sub = function
+    | Pwith_type (lid, d) ->
+        iter_loc sub lid; sub.type_declaration sub d
+    | Pwith_module (lid, lid2) ->
+        iter_loc sub lid; iter_loc sub lid2
+    | Pwith_modtype (lid, mty) ->
+        iter_loc sub lid; sub.module_type sub mty
+    | Pwith_typesubst (lid, d) ->
+        iter_loc sub lid; sub.type_declaration sub d
+    | Pwith_modsubst (s, lid) ->
+        iter_loc sub s; iter_loc sub lid
+    | Pwith_modtypesubst (lid, mty) ->
+        iter_loc sub lid; sub.module_type sub mty
+
+  let iter_signature_item sub {psig_desc = desc; psig_loc = loc} =
+    sub.location sub loc;
+    match desc with
+    | Psig_value vd -> sub.value_description sub vd
+    | Psig_type (_, l)
+    | Psig_typesubst l ->
+      List.iter (sub.type_declaration sub) l
+    | Psig_typext te -> sub.type_extension sub te
+    | Psig_exception ed -> sub.type_exception sub ed
+    | Psig_module x -> sub.module_declaration sub x
+    | Psig_modsubst x -> sub.module_substitution sub x
+    | Psig_recmodule l ->
+        List.iter (sub.module_declaration sub) l
+    | Psig_modtype x | Psig_modtypesubst x -> sub.module_type_declaration sub x
+    | Psig_open x -> sub.open_description sub x
+    | Psig_include x -> sub.include_description sub x
+    | Psig_class l -> List.iter (sub.class_description sub) l
+    | Psig_class_type l ->
+        List.iter (sub.class_type_declaration sub) l
+    | Psig_extension (x, attrs) ->
+        sub.attributes sub attrs;
+        sub.extension sub x
+    | Psig_attribute x -> sub.attribute sub x
+end
+
+
+module M = struct
+  (* Value expressions for the module language *)
+
+  let iter sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pmod_ident x -> iter_loc sub x
+    | Pmod_structure str -> sub.structure sub str
+    | Pmod_functor (param, body) ->
+        iter_functor_param sub param;
+        sub.module_expr sub body
+    | Pmod_apply (m1, m2) ->
+        sub.module_expr sub m1; sub.module_expr sub m2
+    | Pmod_constraint (m, mty) ->
+        sub.module_expr sub m; sub.module_type sub mty
+    | Pmod_unpack e -> sub.expr sub e
+    | Pmod_extension x -> sub.extension sub x
+
+  let iter_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
+    sub.location sub loc;
+    match desc with
+    | Pstr_eval (x, attrs) ->
+        sub.attributes sub attrs; sub.expr sub x
+    | Pstr_value (_r, vbs) -> List.iter (sub.value_binding sub) vbs
+    | Pstr_primitive vd -> sub.value_description sub vd
+    | Pstr_type (_rf, l) -> List.iter (sub.type_declaration sub) l
+    | Pstr_typext te -> sub.type_extension sub te
+    | Pstr_exception ed -> sub.type_exception sub ed
+    | Pstr_module x -> sub.module_binding sub x
+    | Pstr_recmodule l -> List.iter (sub.module_binding sub) l
+    | Pstr_modtype x -> sub.module_type_declaration sub x
+    | Pstr_open x -> sub.open_declaration sub x
+    | Pstr_class l -> List.iter (sub.class_declaration sub) l
+    | Pstr_class_type l ->
+        List.iter (sub.class_type_declaration sub) l
+    | Pstr_include x -> sub.include_declaration sub x
+    | Pstr_extension (x, attrs) ->
+        sub.attributes sub attrs; sub.extension sub x
+    | Pstr_attribute x -> sub.attribute sub x
+end
+
+module E = struct
+  (* Value expressions for the core language *)
+
+  let iter sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pexp_ident x -> iter_loc sub x
+    | Pexp_constant _ -> ()
+    | Pexp_let (_r, vbs, e) ->
+        List.iter (sub.value_binding sub) vbs;
+        sub.expr sub e
+    | Pexp_fun (_lab, def, p, e) ->
+        iter_opt (sub.expr sub) def;
+        sub.pat sub p;
+        sub.expr sub e
+    | Pexp_function pel -> sub.cases sub pel
+    | Pexp_apply (e, l) ->
+        sub.expr sub e; List.iter (iter_snd (sub.expr sub)) l
+    | Pexp_match (e, pel) ->
+        sub.expr sub e; sub.cases sub pel
+    | Pexp_try (e, pel) -> sub.expr sub e; sub.cases sub pel
+    | Pexp_tuple el -> List.iter (sub.expr sub) el
+    | Pexp_construct (lid, arg) ->
+        iter_loc sub lid; iter_opt (sub.expr sub) arg
+    | Pexp_variant (_lab, eo) ->
+        iter_opt (sub.expr sub) eo
+    | Pexp_record (l, eo) ->
+        List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) l;
+        iter_opt (sub.expr sub) eo
+    | Pexp_field (e, lid) ->
+        sub.expr sub e; iter_loc sub lid
+    | Pexp_setfield (e1, lid, e2) ->
+        sub.expr sub e1; iter_loc sub lid;
+        sub.expr sub e2
+    | Pexp_array el -> List.iter (sub.expr sub) el
+    | Pexp_ifthenelse (e1, e2, e3) ->
+        sub.expr sub e1; sub.expr sub e2;
+        iter_opt (sub.expr sub) e3
+    | Pexp_sequence (e1, e2) ->
+        sub.expr sub e1; sub.expr sub e2
+    | Pexp_while (e1, e2) ->
+        sub.expr sub e1; sub.expr sub e2
+    | Pexp_for (p, e1, e2, _d, e3) ->
+        sub.pat sub p; sub.expr sub e1; sub.expr sub e2;
+        sub.expr sub e3
+    | Pexp_coerce (e, t1, t2) ->
+        sub.expr sub e; iter_opt (sub.typ sub) t1;
+        sub.typ sub t2
+    | Pexp_constraint (e, t) ->
+        sub.expr sub e; sub.typ sub t
+    | Pexp_send (e, _s) -> sub.expr sub e
+    | Pexp_new lid -> iter_loc sub lid
+    | Pexp_setinstvar (s, e) ->
+        iter_loc sub s; sub.expr sub e
+    | Pexp_override sel ->
+        List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) sel
+    | Pexp_letmodule (s, me, e) ->
+        iter_loc sub s; sub.module_expr sub me;
+        sub.expr sub e
+    | Pexp_letexception (cd, e) ->
+        sub.extension_constructor sub cd;
+        sub.expr sub e
+    | Pexp_assert e -> sub.expr sub e
+    | Pexp_lazy e -> sub.expr sub e
+    | Pexp_poly (e, t) ->
+        sub.expr sub e; iter_opt (sub.typ sub) t
+    | Pexp_object cls -> sub.class_structure sub cls
+    | Pexp_newtype (_s, e) -> sub.expr sub e
+    | Pexp_pack me -> sub.module_expr sub me
+    | Pexp_open (o, e) ->
+        sub.open_declaration sub o; sub.expr sub e
+    | Pexp_letop {let_; ands; body} ->
+        sub.binding_op sub let_;
+        List.iter (sub.binding_op sub) ands;
+        sub.expr sub body
+    | Pexp_extension x -> sub.extension sub x
+    | Pexp_unreachable -> ()
+
+  let iter_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} =
+    iter_loc sub pbop_op;
+    sub.pat sub pbop_pat;
+    sub.expr sub pbop_exp;
+    sub.location sub pbop_loc
+
+end
+
+module P = struct
+  (* Patterns *)
+
+  let iter sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Ppat_any -> ()
+    | Ppat_var s -> iter_loc sub s
+    | Ppat_alias (p, s) -> sub.pat sub p; iter_loc sub s
+    | Ppat_constant _ -> ()
+    | Ppat_interval _ -> ()
+    | Ppat_tuple pl -> List.iter (sub.pat sub) pl
+    | Ppat_construct (l, p) ->
+        iter_loc sub l;
+        iter_opt
+          (fun (vl,p) ->
+            List.iter (iter_loc sub) vl;
+            sub.pat sub p)
+          p
+    | Ppat_variant (_l, p) -> iter_opt (sub.pat sub) p
+    | Ppat_record (lpl, _cf) ->
+        List.iter (iter_tuple (iter_loc sub) (sub.pat sub)) lpl
+    | Ppat_array pl -> List.iter (sub.pat sub) pl
+    | Ppat_or (p1, p2) -> sub.pat sub p1; sub.pat sub p2
+    | Ppat_constraint (p, t) ->
+        sub.pat sub p; sub.typ sub t
+    | Ppat_type s -> iter_loc sub s
+    | Ppat_lazy p -> sub.pat sub p
+    | Ppat_unpack s -> iter_loc sub s
+    | Ppat_exception p -> sub.pat sub p
+    | Ppat_extension x -> sub.extension sub x
+    | Ppat_open (lid, p) ->
+        iter_loc sub lid; sub.pat sub p
+
+end
+
+module CE = struct
+  (* Value expressions for the class language *)
+
+  let iter sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pcl_constr (lid, tys) ->
+        iter_loc sub lid; List.iter (sub.typ sub) tys
+    | Pcl_structure s ->
+        sub.class_structure sub s
+    | Pcl_fun (_lab, e, p, ce) ->
+        iter_opt (sub.expr sub) e;
+        sub.pat sub p;
+        sub.class_expr sub ce
+    | Pcl_apply (ce, l) ->
+        sub.class_expr sub ce;
+        List.iter (iter_snd (sub.expr sub)) l
+    | Pcl_let (_r, vbs, ce) ->
+        List.iter (sub.value_binding sub) vbs;
+        sub.class_expr sub ce
+    | Pcl_constraint (ce, ct) ->
+        sub.class_expr sub ce; sub.class_type sub ct
+    | Pcl_extension x -> sub.extension sub x
+    | Pcl_open (o, e) ->
+        sub.open_description sub o; sub.class_expr sub e
+
+  let iter_kind sub = function
+    | Cfk_concrete (_o, e) -> sub.expr sub e
+    | Cfk_virtual t -> sub.typ sub t
+
+  let iter_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pcf_inherit (_o, ce, _s) -> sub.class_expr sub ce
+    | Pcf_val (s, _m, k) -> iter_loc sub s; iter_kind sub k
+    | Pcf_method (s, _p, k) ->
+        iter_loc sub s; iter_kind sub k
+    | Pcf_constraint (t1, t2) ->
+        sub.typ sub t1; sub.typ sub t2
+    | Pcf_initializer e -> sub.expr sub e
+    | Pcf_attribute x -> sub.attribute sub x
+    | Pcf_extension x -> sub.extension sub x
+
+  let iter_structure sub {pcstr_self; pcstr_fields} =
+    sub.pat sub pcstr_self;
+    List.iter (sub.class_field sub) pcstr_fields
+
+  let class_infos sub f {pci_virt = _; pci_params = pl; pci_name; pci_expr;
+                         pci_loc; pci_attributes} =
+    List.iter (iter_fst (sub.typ sub)) pl;
+    iter_loc sub pci_name;
+    f pci_expr;
+    sub.location sub pci_loc;
+    sub.attributes sub pci_attributes
+end
+
+(* Now, a generic AST mapper, to be extended to cover all kinds and
+   cases of the OCaml grammar.  The default behavior of the mapper is
+   the identity. *)
+
+let default_iterator =
+  {
+    structure = (fun this l -> List.iter (this.structure_item this) l);
+    structure_item = M.iter_structure_item;
+    module_expr = M.iter;
+    signature = (fun this l -> List.iter (this.signature_item this) l);
+    signature_item = MT.iter_signature_item;
+    module_type = MT.iter;
+    with_constraint = MT.iter_with_constraint;
+    class_declaration =
+      (fun this -> CE.class_infos this (this.class_expr this));
+    class_expr = CE.iter;
+    class_field = CE.iter_field;
+    class_structure = CE.iter_structure;
+    class_type = CT.iter;
+    class_type_field = CT.iter_field;
+    class_signature = CT.iter_signature;
+    class_type_declaration =
+      (fun this -> CE.class_infos this (this.class_type this));
+    class_description =
+      (fun this -> CE.class_infos this (this.class_type this));
+    type_declaration = T.iter_type_declaration;
+    type_kind = T.iter_type_kind;
+    typ = T.iter;
+    row_field = T.row_field;
+    object_field = T.object_field;
+    type_extension = T.iter_type_extension;
+    type_exception = T.iter_type_exception;
+    extension_constructor = T.iter_extension_constructor;
+    value_description =
+      (fun this {pval_name; pval_type; pval_prim = _; pval_loc;
+                 pval_attributes} ->
+        iter_loc this pval_name;
+        this.typ this pval_type;
+        this.location this pval_loc;
+        this.attributes this pval_attributes;
+      );
+
+    pat = P.iter;
+    expr = E.iter;
+    binding_op = E.iter_binding_op;
+
+    module_declaration =
+      (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} ->
+         iter_loc this pmd_name;
+         this.module_type this pmd_type;
+         this.location this pmd_loc;
+         this.attributes this pmd_attributes;
+      );
+
+    module_substitution =
+      (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} ->
+         iter_loc this pms_name;
+         iter_loc this pms_manifest;
+         this.location this pms_loc;
+         this.attributes this pms_attributes;
+      );
+
+    module_type_declaration =
+      (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} ->
+         iter_loc this pmtd_name;
+         iter_opt (this.module_type this) pmtd_type;
+         this.location this pmtd_loc;
+         this.attributes this pmtd_attributes;
+      );
+
+    module_binding =
+      (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} ->
+         iter_loc this pmb_name; this.module_expr this pmb_expr;
+         this.location this pmb_loc;
+         this.attributes this pmb_attributes;
+      );
+
+    open_declaration =
+      (fun this {popen_expr; popen_override = _; popen_attributes; popen_loc} ->
+         this.module_expr this popen_expr;
+         this.location this popen_loc;
+         this.attributes this popen_attributes
+      );
+
+    open_description =
+      (fun this {popen_expr; popen_override = _; popen_attributes; popen_loc} ->
+         iter_loc this popen_expr;
+         this.location this popen_loc;
+         this.attributes this popen_attributes
+      );
+
+
+    include_description =
+      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+         this.module_type this pincl_mod;
+         this.location this pincl_loc;
+         this.attributes this pincl_attributes
+      );
+
+    include_declaration =
+      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+         this.module_expr this pincl_mod;
+         this.location this pincl_loc;
+         this.attributes this pincl_attributes
+      );
+
+
+    value_binding =
+      (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} ->
+         this.pat this pvb_pat;
+         this.expr this pvb_expr;
+         this.location this pvb_loc;
+         this.attributes this pvb_attributes
+      );
+
+
+    constructor_declaration =
+      (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} ->
+         iter_loc this pcd_name;
+         T.iter_constructor_arguments this pcd_args;
+         iter_opt (this.typ this) pcd_res;
+         this.location this pcd_loc;
+         this.attributes this pcd_attributes
+      );
+
+    label_declaration =
+      (fun this {pld_name; pld_type; pld_loc; pld_mutable = _; pld_attributes}->
+         iter_loc this pld_name;
+         this.typ this pld_type;
+         this.location this pld_loc;
+         this.attributes this pld_attributes
+      );
+
+    cases = (fun this l -> List.iter (this.case this) l);
+    case =
+      (fun this {pc_lhs; pc_guard; pc_rhs} ->
+         this.pat this pc_lhs;
+         iter_opt (this.expr this) pc_guard;
+         this.expr this pc_rhs
+      );
+
+    location = (fun _this _l -> ());
+
+    extension = (fun this (s, e) -> iter_loc this s; this.payload this e);
+    attribute = (fun this a ->
+      iter_loc this a.attr_name;
+      this.payload this a.attr_payload;
+      this.location this a.attr_loc
+    );
+    attributes = (fun this l -> List.iter (this.attribute this) l);
+    payload =
+      (fun this -> function
+         | PStr x -> this.structure this x
+         | PSig x -> this.signature this x
+         | PTyp x -> this.typ this x
+         | PPat (x, g) -> this.pat this x; iter_opt (this.expr this) g
+      );
+  }
diff --git a/src/ocaml/parsing/ast_iterator.mli b/src/ocaml/parsing/ast_iterator.mli
new file mode 100644
index 0000000..26308d2
--- /dev/null
+++ b/src/ocaml/parsing/ast_iterator.mli
@@ -0,0 +1,83 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Nicolas Ojeda Bar, LexiFi                         *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** {!iterator} enables AST inspection using open recursion.  A
+    typical mapper would be based on {!default_iterator}, a trivial iterator,
+    and will fall back on it for handling the syntax it does not modify.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Parsetree
+
+(** {1 A generic Parsetree iterator} *)
+
+type iterator = {
+  attribute: iterator -> attribute -> unit;
+  attributes: iterator -> attribute list -> unit;
+  binding_op: iterator -> binding_op -> unit;
+  case: iterator -> case -> unit;
+  cases: iterator -> case list -> unit;
+  class_declaration: iterator -> class_declaration -> unit;
+  class_description: iterator -> class_description -> unit;
+  class_expr: iterator -> class_expr -> unit;
+  class_field: iterator -> class_field -> unit;
+  class_signature: iterator -> class_signature -> unit;
+  class_structure: iterator -> class_structure -> unit;
+  class_type: iterator -> class_type -> unit;
+  class_type_declaration: iterator -> class_type_declaration -> unit;
+  class_type_field: iterator -> class_type_field -> unit;
+  constructor_declaration: iterator -> constructor_declaration -> unit;
+  expr: iterator -> expression -> unit;
+  extension: iterator -> extension -> unit;
+  extension_constructor: iterator -> extension_constructor -> unit;
+  include_declaration: iterator -> include_declaration -> unit;
+  include_description: iterator -> include_description -> unit;
+  label_declaration: iterator -> label_declaration -> unit;
+  location: iterator -> Location.t -> unit;
+  module_binding: iterator -> module_binding -> unit;
+  module_declaration: iterator -> module_declaration -> unit;
+  module_substitution: iterator -> module_substitution -> unit;
+  module_expr: iterator -> module_expr -> unit;
+  module_type: iterator -> module_type -> unit;
+  module_type_declaration: iterator -> module_type_declaration -> unit;
+  open_declaration: iterator -> open_declaration -> unit;
+  open_description: iterator -> open_description -> unit;
+  pat: iterator -> pattern -> unit;
+  payload: iterator -> payload -> unit;
+  signature: iterator -> signature -> unit;
+  signature_item: iterator -> signature_item -> unit;
+  structure: iterator -> structure -> unit;
+  structure_item: iterator -> structure_item -> unit;
+  typ: iterator -> core_type -> unit;
+  row_field: iterator -> row_field -> unit;
+  object_field: iterator -> object_field -> unit;
+  type_declaration: iterator -> type_declaration -> unit;
+  type_extension: iterator -> type_extension -> unit;
+  type_exception: iterator -> type_exception -> unit;
+  type_kind: iterator -> type_kind -> unit;
+  value_binding: iterator -> value_binding -> unit;
+  value_description: iterator -> value_description -> unit;
+  with_constraint: iterator -> with_constraint -> unit;
+}
+(** A [iterator] record implements one "method" per syntactic category,
+    using an open recursion style: each method takes as its first
+    argument the iterator to be applied to children in the syntax
+    tree. *)
+
+val default_iterator: iterator
+(** A default iterator, which implements a "do not do anything" mapping. *)
diff --git a/src/ocaml/parsing/ast_mapper.ml b/src/ocaml/parsing/ast_mapper.ml
new file mode 100644
index 0000000..d6c6d58
--- /dev/null
+++ b/src/ocaml/parsing/ast_mapper.ml
@@ -0,0 +1,1079 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* A generic Parsetree mapping class *)
+
+(*
+[@@@ocaml.warning "+9"]
+  (* Ensure that record patterns don't miss any field. *)
+*)
+
+open Parsetree
+open Ast_helper
+open Location
+
+module String = Misc.String
+
+type mapper = {
+  attribute: mapper -> attribute -> attribute;
+  attributes: mapper -> attribute list -> attribute list;
+  binding_op: mapper -> binding_op -> binding_op;
+  case: mapper -> case -> case;
+  cases: mapper -> case list -> case list;
+  class_declaration: mapper -> class_declaration -> class_declaration;
+  class_description: mapper -> class_description -> class_description;
+  class_expr: mapper -> class_expr -> class_expr;
+  class_field: mapper -> class_field -> class_field;
+  class_signature: mapper -> class_signature -> class_signature;
+  class_structure: mapper -> class_structure -> class_structure;
+  class_type: mapper -> class_type -> class_type;
+  class_type_declaration: mapper -> class_type_declaration
+                          -> class_type_declaration;
+  class_type_field: mapper -> class_type_field -> class_type_field;
+  constant: mapper -> constant -> constant;
+  constructor_declaration: mapper -> constructor_declaration
+                           -> constructor_declaration;
+  expr: mapper -> expression -> expression;
+  extension: mapper -> extension -> extension;
+  extension_constructor: mapper -> extension_constructor
+                         -> extension_constructor;
+  include_declaration: mapper -> include_declaration -> include_declaration;
+  include_description: mapper -> include_description -> include_description;
+  label_declaration: mapper -> label_declaration -> label_declaration;
+  location: mapper -> Location.t -> Location.t;
+  module_binding: mapper -> module_binding -> module_binding;
+  module_declaration: mapper -> module_declaration -> module_declaration;
+  module_substitution: mapper -> module_substitution -> module_substitution;
+  module_expr: mapper -> module_expr -> module_expr;
+  module_type: mapper -> module_type -> module_type;
+  module_type_declaration: mapper -> module_type_declaration
+                           -> module_type_declaration;
+  open_declaration: mapper -> open_declaration -> open_declaration;
+  open_description: mapper -> open_description -> open_description;
+  pat: mapper -> pattern -> pattern;
+  payload: mapper -> payload -> payload;
+  signature: mapper -> signature -> signature;
+  signature_item: mapper -> signature_item -> signature_item;
+  structure: mapper -> structure -> structure;
+  structure_item: mapper -> structure_item -> structure_item;
+  typ: mapper -> core_type -> core_type;
+  type_declaration: mapper -> type_declaration -> type_declaration;
+  type_extension: mapper -> type_extension -> type_extension;
+  type_exception: mapper -> type_exception -> type_exception;
+  type_kind: mapper -> type_kind -> type_kind;
+  value_binding: mapper -> value_binding -> value_binding;
+  value_description: mapper -> value_description -> value_description;
+  with_constraint: mapper -> with_constraint -> with_constraint;
+}
+
+let map_fst f (x, y) = (f x, y)
+let map_snd f (x, y) = (x, f y)
+let map_tuple f1 f2 (x, y) = (f1 x, f2 y)
+let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
+let map_opt f = function None -> None | Some x -> Some (f x)
+
+let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}
+
+module C = struct
+  (* Constants *)
+
+  let map sub c = match c with
+    | Pconst_integer _
+    | Pconst_char _
+    | Pconst_float _
+      -> c
+    | Pconst_string (s, loc, quotation_delimiter) ->
+        let loc = sub.location sub loc in
+        Const.string ~loc ?quotation_delimiter s
+end
+
+module T = struct
+  (* Type expressions for the core language *)
+
+  let row_field sub {
+      prf_desc;
+      prf_loc;
+      prf_attributes;
+    } =
+    let loc = sub.location sub prf_loc in
+    let attrs = sub.attributes sub prf_attributes in
+    let desc = match prf_desc with
+      | Rtag (l, b, tl) -> Rtag (map_loc sub l, b, List.map (sub.typ sub) tl)
+      | Rinherit t -> Rinherit (sub.typ sub t)
+    in
+    Rf.mk ~loc ~attrs desc
+
+  let object_field sub {
+      pof_desc;
+      pof_loc;
+      pof_attributes;
+    } =
+    let loc = sub.location sub pof_loc in
+    let attrs = sub.attributes sub pof_attributes in
+    let desc = match pof_desc with
+      | Otag (l, t) -> Otag (map_loc sub l, sub.typ sub t)
+      | Oinherit t -> Oinherit (sub.typ sub t)
+    in
+    Of.mk ~loc ~attrs desc
+
+  let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
+    let open Typ in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Ptyp_any -> any ~loc ~attrs ()
+    | Ptyp_var s -> var ~loc ~attrs s
+    | Ptyp_arrow (lab, t1, t2) ->
+        arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2)
+    | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
+    | Ptyp_constr (lid, tl) ->
+        constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
+    | Ptyp_object (l, o) ->
+        object_ ~loc ~attrs (List.map (object_field sub) l) o
+    | Ptyp_class (lid, tl) ->
+        class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
+    | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s
+    | Ptyp_variant (rl, b, ll) ->
+        variant ~loc ~attrs (List.map (row_field sub) rl) b ll
+    | Ptyp_poly (sl, t) -> poly ~loc ~attrs
+                             (List.map (map_loc sub) sl) (sub.typ sub t)
+    | Ptyp_package (lid, l) ->
+        package ~loc ~attrs (map_loc sub lid)
+          (List.map (map_tuple (map_loc sub) (sub.typ sub)) l)
+    | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_type_declaration sub
+      {ptype_name; ptype_params; ptype_cstrs;
+       ptype_kind;
+       ptype_private;
+       ptype_manifest;
+       ptype_attributes;
+       ptype_loc} =
+    let loc = sub.location sub ptype_loc in
+    let attrs = sub.attributes sub ptype_attributes in
+    Type.mk ~loc ~attrs (map_loc sub ptype_name)
+      ~params:(List.map (map_fst (sub.typ sub)) ptype_params)
+      ~priv:ptype_private
+      ~cstrs:(List.map
+                (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub))
+                ptype_cstrs)
+      ~kind:(sub.type_kind sub ptype_kind)
+      ?manifest:(map_opt (sub.typ sub) ptype_manifest)
+
+  let map_type_kind sub = function
+    | Ptype_abstract -> Ptype_abstract
+    | Ptype_variant l ->
+        Ptype_variant (List.map (sub.constructor_declaration sub) l)
+    | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l)
+    | Ptype_open -> Ptype_open
+
+  let map_constructor_arguments sub = function
+    | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l)
+    | Pcstr_record l ->
+        Pcstr_record (List.map (sub.label_declaration sub) l)
+
+  let map_type_extension sub
+      {ptyext_path; ptyext_params;
+       ptyext_constructors;
+       ptyext_private;
+       ptyext_loc;
+       ptyext_attributes} =
+    let loc = sub.location sub ptyext_loc in
+    let attrs = sub.attributes sub ptyext_attributes in
+    Te.mk ~loc ~attrs
+      (map_loc sub ptyext_path)
+      (List.map (sub.extension_constructor sub) ptyext_constructors)
+      ~params:(List.map (map_fst (sub.typ sub)) ptyext_params)
+      ~priv:ptyext_private
+
+  let map_type_exception sub
+      {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} =
+    let loc = sub.location sub ptyexn_loc in
+    let attrs = sub.attributes sub ptyexn_attributes in
+    Te.mk_exception ~loc ~attrs
+      (sub.extension_constructor sub ptyexn_constructor)
+
+  let map_extension_constructor_kind sub = function
+      Pext_decl(ctl, cto) ->
+        Pext_decl(map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto)
+    | Pext_rebind li ->
+        Pext_rebind (map_loc sub li)
+
+  let map_extension_constructor sub
+      {pext_name;
+       pext_kind;
+       pext_loc;
+       pext_attributes} =
+    let loc = sub.location sub pext_loc in
+    let attrs = sub.attributes sub pext_attributes in
+    Te.constructor ~loc ~attrs
+      (map_loc sub pext_name)
+      (map_extension_constructor_kind sub pext_kind)
+
+end
+
+module CT = struct
+  (* Type expressions for the class language *)
+
+  let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} =
+    let open Cty in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pcty_constr (lid, tys) ->
+        constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
+    | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x)
+    | Pcty_arrow (lab, t, ct) ->
+        arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct)
+    | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x)
+    | Pcty_open (o, ct) ->
+        open_ ~loc ~attrs (sub.open_description sub o) (sub.class_type sub ct)
+
+  let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
+    =
+    let open Ctf in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct)
+    | Pctf_val (s, m, v, t) ->
+        val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t)
+    | Pctf_method (s, p, v, t) ->
+        method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t)
+    | Pctf_constraint (t1, t2) ->
+        constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
+    | Pctf_attribute x -> attribute ~loc (sub.attribute sub x)
+    | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_signature sub {pcsig_self; pcsig_fields} =
+    Csig.mk
+      (sub.typ sub pcsig_self)
+      (List.map (sub.class_type_field sub) pcsig_fields)
+end
+
+let map_functor_param sub = function
+  | Unit -> Unit
+  | Named (s, mt) -> Named (map_loc sub s, sub.module_type sub mt)
+
+module MT = struct
+  (* Type expressions for the module language *)
+
+  let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} =
+    let open Mty in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s)
+    | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s)
+    | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg)
+    | Pmty_functor (param, mt) ->
+        functor_ ~loc ~attrs
+          (map_functor_param sub param)
+          (sub.module_type sub mt)
+    | Pmty_with (mt, l) ->
+        with_ ~loc ~attrs (sub.module_type sub mt)
+          (List.map (sub.with_constraint sub) l)
+    | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me)
+    | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_with_constraint sub = function
+    | Pwith_type (lid, d) ->
+        Pwith_type (map_loc sub lid, sub.type_declaration sub d)
+    | Pwith_module (lid, lid2) ->
+        Pwith_module (map_loc sub lid, map_loc sub lid2)
+    | Pwith_modtype (lid, mty) ->
+        Pwith_modtype (map_loc sub lid, sub.module_type sub mty)
+    | Pwith_typesubst (lid, d) ->
+        Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d)
+    | Pwith_modsubst (s, lid) ->
+        Pwith_modsubst (map_loc sub s, map_loc sub lid)
+    | Pwith_modtypesubst (lid, mty) ->
+        Pwith_modtypesubst (map_loc sub lid, sub.module_type sub mty)
+
+  let map_signature_item sub {psig_desc = desc; psig_loc = loc} =
+    let open Sig in
+    let loc = sub.location sub loc in
+    match desc with
+    | Psig_value vd -> value ~loc (sub.value_description sub vd)
+    | Psig_type (rf, l) ->
+        type_ ~loc rf (List.map (sub.type_declaration sub) l)
+    | Psig_typesubst l ->
+        type_subst ~loc (List.map (sub.type_declaration sub) l)
+    | Psig_typext te -> type_extension ~loc (sub.type_extension sub te)
+    | Psig_exception ed -> exception_ ~loc (sub.type_exception sub ed)
+    | Psig_module x -> module_ ~loc (sub.module_declaration sub x)
+    | Psig_modsubst x -> mod_subst ~loc (sub.module_substitution sub x)
+    | Psig_recmodule l ->
+        rec_module ~loc (List.map (sub.module_declaration sub) l)
+    | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
+    | Psig_modtypesubst x ->
+        modtype_subst ~loc (sub.module_type_declaration sub x)
+    | Psig_open x -> open_ ~loc (sub.open_description sub x)
+    | Psig_include x -> include_ ~loc (sub.include_description sub x)
+    | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l)
+    | Psig_class_type l ->
+        class_type ~loc (List.map (sub.class_type_declaration sub) l)
+    | Psig_extension (x, attrs) ->
+        let attrs = sub.attributes sub attrs in
+        extension ~loc ~attrs (sub.extension sub x)
+    | Psig_attribute x -> attribute ~loc (sub.attribute sub x)
+end
+
+
+module M = struct
+  (* Value expressions for the module language *)
+
+  let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} =
+    let open Mod in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x)
+    | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str)
+    | Pmod_functor (param, body) ->
+        functor_ ~loc ~attrs
+          (map_functor_param sub param)
+          (sub.module_expr sub body)
+    | Pmod_apply (m1, m2) ->
+        apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2)
+    | Pmod_constraint (m, mty) ->
+        constraint_ ~loc ~attrs (sub.module_expr sub m)
+                    (sub.module_type sub mty)
+    | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e)
+    | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
+    let open Str in
+    let loc = sub.location sub loc in
+    match desc with
+    | Pstr_eval (x, attrs) ->
+        let attrs = sub.attributes sub attrs in
+        eval ~loc ~attrs (sub.expr sub x)
+    | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs)
+    | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd)
+    | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l)
+    | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te)
+    | Pstr_exception ed -> exception_ ~loc (sub.type_exception sub ed)
+    | Pstr_module x -> module_ ~loc (sub.module_binding sub x)
+    | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l)
+    | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
+    | Pstr_open x -> open_ ~loc (sub.open_declaration sub x)
+    | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l)
+    | Pstr_class_type l ->
+        class_type ~loc (List.map (sub.class_type_declaration sub) l)
+    | Pstr_include x -> include_ ~loc (sub.include_declaration sub x)
+    | Pstr_extension (x, attrs) ->
+        let attrs = sub.attributes sub attrs in
+        extension ~loc ~attrs (sub.extension sub x)
+    | Pstr_attribute x -> attribute ~loc (sub.attribute sub x)
+end
+
+module E = struct
+  (* Value expressions for the core language *)
+
+  let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} =
+    let open Exp in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x)
+    | Pexp_constant x -> constant ~loc ~attrs (sub.constant sub x)
+    | Pexp_let (r, vbs, e) ->
+        let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
+          (sub.expr sub e)
+    | Pexp_fun (lab, def, p, e) ->
+        fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p)
+          (sub.expr sub e)
+    | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel)
+    | Pexp_apply (e, l) ->
+        apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l)
+    | Pexp_match (e, pel) ->
+        match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
+    | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
+    | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el)
+    | Pexp_construct (lid, arg) ->
+        construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg)
+    | Pexp_variant (lab, eo) ->
+        variant ~loc ~attrs lab (map_opt (sub.expr sub) eo)
+    | Pexp_record (l, eo) ->
+        record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l)
+          (map_opt (sub.expr sub) eo)
+    | Pexp_field (e, lid) ->
+        field ~loc ~attrs (sub.expr sub e) (map_loc sub lid)
+    | Pexp_setfield (e1, lid, e2) ->
+        setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid)
+          (sub.expr sub e2)
+    | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el)
+    | Pexp_ifthenelse (e1, e2, e3) ->
+        ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
+          (map_opt (sub.expr sub) e3)
+    | Pexp_sequence (e1, e2) ->
+        sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
+    | Pexp_while (e1, e2) ->
+        while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
+    | Pexp_for (p, e1, e2, d, e3) ->
+        for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d
+          (sub.expr sub e3)
+    | Pexp_coerce (e, t1, t2) ->
+        coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1)
+          (sub.typ sub t2)
+    | Pexp_constraint (e, t) ->
+        constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t)
+    | Pexp_send (e, s) ->
+        send ~loc ~attrs (sub.expr sub e) (map_loc sub s)
+    | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid)
+    | Pexp_setinstvar (s, e) ->
+        setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e)
+    | Pexp_override sel ->
+        override ~loc ~attrs
+          (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel)
+    | Pexp_letmodule (s, me, e) ->
+        letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me)
+          (sub.expr sub e)
+    | Pexp_letexception (cd, e) ->
+        letexception ~loc ~attrs
+          (sub.extension_constructor sub cd)
+          (sub.expr sub e)
+    | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e)
+    | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e)
+    | Pexp_poly (e, t) ->
+        poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t)
+    | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls)
+    | Pexp_newtype (s, e) ->
+        newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e)
+    | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me)
+    | Pexp_open (o, e) ->
+        open_ ~loc ~attrs (sub.open_declaration sub o) (sub.expr sub e)
+    | Pexp_letop {let_; ands; body} ->
+        letop ~loc ~attrs (sub.binding_op sub let_)
+          (List.map (sub.binding_op sub) ands) (sub.expr sub body)
+    | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x)
+    | Pexp_unreachable -> unreachable ~loc ~attrs ()
+
+  let map_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} =
+    let open Exp in
+    let op = map_loc sub pbop_op in
+    let pat = sub.pat sub pbop_pat in
+    let exp = sub.expr sub pbop_exp in
+    let loc = sub.location sub pbop_loc in
+    binding_op op pat exp loc
+
+end
+
+module P = struct
+  (* Patterns *)
+
+  let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} =
+    let open Pat in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Ppat_any -> any ~loc ~attrs ()
+    | Ppat_var s -> var ~loc ~attrs (map_loc sub s)
+    | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s)
+    | Ppat_constant c -> constant ~loc ~attrs (sub.constant sub c)
+    | Ppat_interval (c1, c2) ->
+        interval ~loc ~attrs (sub.constant sub c1) (sub.constant sub c2)
+    | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl)
+    | Ppat_construct (l, p) ->
+        construct ~loc ~attrs (map_loc sub l)
+          (map_opt
+             (fun (vl, p) -> List.map (map_loc sub) vl, sub.pat sub p)
+             p)
+    | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p)
+    | Ppat_record (lpl, cf) ->
+        record ~loc ~attrs
+               (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf
+    | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl)
+    | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2)
+    | Ppat_constraint (p, t) ->
+        constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t)
+    | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s)
+    | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p)
+    | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s)
+    | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p)
+    | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p)
+    | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x)
+end
+
+module CE = struct
+  (* Value expressions for the class language *)
+
+  let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} =
+    let open Cl in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pcl_constr (lid, tys) ->
+        constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
+    | Pcl_structure s ->
+        structure ~loc ~attrs (sub.class_structure sub s)
+    | Pcl_fun (lab, e, p, ce) ->
+        fun_ ~loc ~attrs lab
+          (map_opt (sub.expr sub) e)
+          (sub.pat sub p)
+          (sub.class_expr sub ce)
+    | Pcl_apply (ce, l) ->
+        apply ~loc ~attrs (sub.class_expr sub ce)
+          (List.map (map_snd (sub.expr sub)) l)
+    | Pcl_let (r, vbs, ce) ->
+        let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
+          (sub.class_expr sub ce)
+    | Pcl_constraint (ce, ct) ->
+        constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct)
+    | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x)
+    | Pcl_open (o, ce) ->
+        open_ ~loc ~attrs (sub.open_description sub o) (sub.class_expr sub ce)
+
+  let map_kind sub = function
+    | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e)
+    | Cfk_virtual t -> Cfk_virtual (sub.typ sub t)
+
+  let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} =
+    let open Cf in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pcf_inherit (o, ce, s) ->
+        inherit_ ~loc ~attrs o (sub.class_expr sub ce)
+          (map_opt (map_loc sub) s)
+    | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k)
+    | Pcf_method (s, p, k) ->
+        method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k)
+    | Pcf_constraint (t1, t2) ->
+        constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
+    | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e)
+    | Pcf_attribute x -> attribute ~loc (sub.attribute sub x)
+    | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_structure sub {pcstr_self; pcstr_fields} =
+    {
+      pcstr_self = sub.pat sub pcstr_self;
+      pcstr_fields = List.map (sub.class_field sub) pcstr_fields;
+    }
+
+  let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr;
+                         pci_loc; pci_attributes} =
+    let loc = sub.location sub pci_loc in
+    let attrs = sub.attributes sub pci_attributes in
+    Ci.mk ~loc ~attrs
+     ~virt:pci_virt
+     ~params:(List.map (map_fst (sub.typ sub)) pl)
+      (map_loc sub pci_name)
+      (f pci_expr)
+end
+
+(* Now, a generic AST mapper, to be extended to cover all kinds and
+   cases of the OCaml grammar.  The default behavior of the mapper is
+   the identity. *)
+
+let default_mapper =
+  {
+    constant = C.map;
+    structure = (fun this l -> List.map (this.structure_item this) l);
+    structure_item = M.map_structure_item;
+    module_expr = M.map;
+    signature = (fun this l -> List.map (this.signature_item this) l);
+    signature_item = MT.map_signature_item;
+    module_type = MT.map;
+    with_constraint = MT.map_with_constraint;
+    class_declaration =
+      (fun this -> CE.class_infos this (this.class_expr this));
+    class_expr = CE.map;
+    class_field = CE.map_field;
+    class_structure = CE.map_structure;
+    class_type = CT.map;
+    class_type_field = CT.map_field;
+    class_signature = CT.map_signature;
+    class_type_declaration =
+      (fun this -> CE.class_infos this (this.class_type this));
+    class_description =
+      (fun this -> CE.class_infos this (this.class_type this));
+    type_declaration = T.map_type_declaration;
+    type_kind = T.map_type_kind;
+    typ = T.map;
+    type_extension = T.map_type_extension;
+    type_exception = T.map_type_exception;
+    extension_constructor = T.map_extension_constructor;
+    value_description =
+      (fun this {pval_name; pval_type; pval_prim; pval_loc;
+                 pval_attributes} ->
+        Val.mk
+          (map_loc this pval_name)
+          (this.typ this pval_type)
+          ~attrs:(this.attributes this pval_attributes)
+          ~loc:(this.location this pval_loc)
+          ~prim:pval_prim
+      );
+
+    pat = P.map;
+    expr = E.map;
+    binding_op = E.map_binding_op;
+
+    module_declaration =
+      (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} ->
+         Md.mk
+           (map_loc this pmd_name)
+           (this.module_type this pmd_type)
+           ~attrs:(this.attributes this pmd_attributes)
+           ~loc:(this.location this pmd_loc)
+      );
+
+    module_substitution =
+      (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} ->
+         Ms.mk
+           (map_loc this pms_name)
+           (map_loc this pms_manifest)
+           ~attrs:(this.attributes this pms_attributes)
+           ~loc:(this.location this pms_loc)
+      );
+
+    module_type_declaration =
+      (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} ->
+         Mtd.mk
+           (map_loc this pmtd_name)
+           ?typ:(map_opt (this.module_type this) pmtd_type)
+           ~attrs:(this.attributes this pmtd_attributes)
+           ~loc:(this.location this pmtd_loc)
+      );
+
+    module_binding =
+      (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} ->
+         Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr)
+           ~attrs:(this.attributes this pmb_attributes)
+           ~loc:(this.location this pmb_loc)
+      );
+
+
+    open_declaration =
+      (fun this {popen_expr; popen_override; popen_attributes; popen_loc} ->
+         Opn.mk (this.module_expr this popen_expr)
+           ~override:popen_override
+           ~loc:(this.location this popen_loc)
+           ~attrs:(this.attributes this popen_attributes)
+      );
+
+    open_description =
+      (fun this {popen_expr; popen_override; popen_attributes; popen_loc} ->
+         Opn.mk (map_loc this popen_expr)
+           ~override:popen_override
+           ~loc:(this.location this popen_loc)
+           ~attrs:(this.attributes this popen_attributes)
+      );
+
+    include_description =
+      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+         Incl.mk (this.module_type this pincl_mod)
+           ~loc:(this.location this pincl_loc)
+           ~attrs:(this.attributes this pincl_attributes)
+      );
+
+    include_declaration =
+      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+         Incl.mk (this.module_expr this pincl_mod)
+           ~loc:(this.location this pincl_loc)
+           ~attrs:(this.attributes this pincl_attributes)
+      );
+
+
+    value_binding =
+      (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} ->
+         Vb.mk
+           (this.pat this pvb_pat)
+           (this.expr this pvb_expr)
+           ~loc:(this.location this pvb_loc)
+           ~attrs:(this.attributes this pvb_attributes)
+      );
+
+
+    constructor_declaration =
+      (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} ->
+        Type.constructor
+          (map_loc this pcd_name)
+          ~args:(T.map_constructor_arguments this pcd_args)
+          ?res:(map_opt (this.typ this) pcd_res)
+          ~loc:(this.location this pcd_loc)
+          ~attrs:(this.attributes this pcd_attributes)
+      );
+
+    label_declaration =
+      (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} ->
+         Type.field
+           (map_loc this pld_name)
+           (this.typ this pld_type)
+           ~mut:pld_mutable
+           ~loc:(this.location this pld_loc)
+           ~attrs:(this.attributes this pld_attributes)
+      );
+
+    cases = (fun this l -> List.map (this.case this) l);
+    case =
+      (fun this {pc_lhs; pc_guard; pc_rhs} ->
+         {
+           pc_lhs = this.pat this pc_lhs;
+           pc_guard = map_opt (this.expr this) pc_guard;
+           pc_rhs = this.expr this pc_rhs;
+         }
+      );
+
+
+
+    location = (fun _this l -> l);
+
+    extension = (fun this (s, e) -> (map_loc this s, this.payload this e));
+    attribute = (fun this a ->
+      {
+        attr_name = map_loc this a.attr_name;
+        attr_payload = this.payload this a.attr_payload;
+        attr_loc = this.location this a.attr_loc
+      }
+    );
+    attributes = (fun this l -> List.map (this.attribute this) l);
+    payload =
+      (fun this -> function
+         | PStr x -> PStr (this.structure this x)
+         | PSig x -> PSig (this.signature this x)
+         | PTyp x -> PTyp (this.typ this x)
+         | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g)
+      );
+  }
+
+let extension_of_error {kind; main; sub} =
+  if kind <> Location.Report_error then
+    raise (Invalid_argument "extension_of_error: expected kind Report_error");
+  let str_of_pp pp_msg = Format.asprintf "%t" pp_msg in
+  let extension_of_sub sub =
+    { loc = sub.loc; txt = "ocaml.error" },
+    PStr ([Str.eval (Exp.constant
+                       (Pconst_string (str_of_pp sub.txt, sub.loc, None)))])
+  in
+  { loc = main.loc; txt = "ocaml.error" },
+  PStr (Str.eval (Exp.constant
+                    (Pconst_string (str_of_pp main.txt, main.loc, None))) ::
+        List.map (fun msg -> Str.extension (extension_of_sub msg)) sub)
+
+let attribute_of_warning loc s =
+  Attr.mk
+    {loc; txt = "ocaml.ppwarning" }
+    (PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, loc, None)))]))
+
+let cookies = ref String.Map.empty
+
+let get_cookie k =
+  try Some (String.Map.find k !cookies)
+  with Not_found -> None
+
+let set_cookie k v =
+  cookies := String.Map.add k v !cookies
+
+let tool_name_ref = ref "_none_"
+
+let tool_name () = !tool_name_ref
+
+
+module PpxContext = struct
+  open Longident
+  open Asttypes
+  open Ast_helper
+
+  let lid name = { txt = Lident name; loc = Location.none }
+
+  let make_string s = Exp.constant (Const.string s)
+
+  let make_bool x =
+    if x
+    then Exp.construct (lid "true") None
+    else Exp.construct (lid "false") None
+
+  let rec make_list f lst =
+    match lst with
+    | x :: rest ->
+      Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest]))
+    | [] ->
+      Exp.construct (lid "[]") None
+
+  let make_pair f1 f2 (x1, x2) =
+    Exp.tuple [f1 x1; f2 x2]
+
+  let make_option f opt =
+    match opt with
+    | Some x -> Exp.construct (lid "Some") (Some (f x))
+    | None   -> Exp.construct (lid "None") None
+
+  let get_cookies () =
+    lid "cookies",
+    make_list (make_pair make_string (fun x -> x))
+      (String.Map.bindings !cookies)
+
+  let mk fields =
+    {
+      attr_name = { txt = "ocaml.ppx.context"; loc = Location.none };
+      attr_payload = Parsetree.PStr [Str.eval (Exp.record fields None)];
+      attr_loc = Location.none
+    }
+
+  let make ~tool_name () =
+    let fields =
+      [
+        lid "tool_name",    make_string tool_name;
+        lid "include_dirs", make_list make_string !Clflags.include_dirs;
+        lid "load_path",    make_list make_string (Load_path.get_paths ());
+        lid "open_modules", make_list make_string !Clflags.open_modules;
+        lid "for_package",  make_option make_string !Clflags.for_package;
+        lid "debug",        make_bool !Clflags.debug;
+        lid "use_threads",  make_bool false;
+        lid "use_vmthreads", make_bool false;
+        lid "recursive_types", make_bool !Clflags.recursive_types;
+        lid "principal", make_bool !Clflags.principal;
+        lid "transparent_modules", make_bool !Clflags.transparent_modules;
+        lid "unboxed_types", make_bool !Clflags.unboxed_types;
+        lid "unsafe_string", make_bool !Clflags.unsafe_string;
+        get_cookies ()
+      ]
+    in
+    mk fields
+
+  let get_fields = function
+    | PStr [{pstr_desc = Pstr_eval
+                 ({ pexp_desc = Pexp_record (fields, None) }, [])}] ->
+        fields
+    | _ ->
+        raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax"
+
+  let restore fields =
+    let field name payload =
+      let rec get_string = function
+        | { pexp_desc = Pexp_constant (Pconst_string (str, _, None)) } -> str
+        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
+                             { %s }] string syntax" name
+      and get_bool pexp =
+        match pexp with
+        | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"},
+                                       None)} ->
+            true
+        | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"},
+                                       None)} ->
+            false
+        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
+                             { %s }] bool syntax" name
+      and get_list elem = function
+        | {pexp_desc =
+             Pexp_construct ({txt = Longident.Lident "::"},
+                             Some {pexp_desc = Pexp_tuple [exp; rest]}) } ->
+            elem exp :: get_list elem rest
+        | {pexp_desc =
+             Pexp_construct ({txt = Longident.Lident "[]"}, None)} ->
+            []
+        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
+                             { %s }] list syntax" name
+      and get_pair f1 f2 = function
+        | {pexp_desc = Pexp_tuple [e1; e2]} ->
+            (f1 e1, f2 e2)
+        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
+                             { %s }] pair syntax" name
+      and get_option elem = function
+        | { pexp_desc =
+              Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } ->
+            Some (elem exp)
+        | { pexp_desc =
+              Pexp_construct ({ txt = Longident.Lident "None" }, None) } ->
+            None
+        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
+                             { %s }] option syntax" name
+      in
+      match name with
+      | "tool_name" ->
+          tool_name_ref := get_string payload
+      | "include_dirs" ->
+          Clflags.include_dirs := get_list get_string payload
+      | "load_path" ->
+          Load_path.init (get_list get_string payload)
+      | "open_modules" ->
+          Clflags.open_modules := get_list get_string payload
+      | "for_package" ->
+          Clflags.for_package := get_option get_string payload
+      | "debug" ->
+          Clflags.debug := get_bool payload
+      (*| "use_threads" ->
+          Clflags.use_threads := get_bool payload
+      | "use_vmthreads" ->
+          if get_bool payload then
+            raise_errorf "Internal error: vmthreads not supported after 4.09.0"
+        *)
+      | "recursive_types" ->
+          Clflags.recursive_types := get_bool payload
+      | "principal" ->
+          Clflags.principal := get_bool payload
+      | "transparent_modules" ->
+          Clflags.transparent_modules := get_bool payload
+      | "unboxed_types" ->
+          Clflags.unboxed_types := get_bool payload
+      | "unsafe_string" ->
+          Clflags.unsafe_string := get_bool payload
+      | "cookies" ->
+          let l = get_list (get_pair get_string (fun x -> x)) payload in
+          cookies :=
+            List.fold_left
+              (fun s (k, v) -> String.Map.add k v s) String.Map.empty
+              l
+      | _ ->
+          ()
+    in
+    List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields
+
+  let update_cookies fields =
+    let fields =
+      List.filter
+        (function ({txt=Lident "cookies"}, _) -> false | _ -> true)
+        fields
+    in
+    fields @ [get_cookies ()]
+end
+
+let ppx_context = PpxContext.make
+
+let extension_of_exn exn =
+  match error_of_exn exn with
+  | Some (`Ok error) -> extension_of_error error
+  | Some `Already_displayed ->
+      { loc = Location.none; txt = "ocaml.error" }, PStr []
+  | None -> raise exn
+
+
+let apply_lazy ~source ~target mapper =
+  let implem ast =
+    let fields, ast =
+      match ast with
+      | {pstr_desc = Pstr_attribute ({attr_name = {txt = "ocaml.ppx.context"};
+                                      attr_payload = x})} :: l ->
+          PpxContext.get_fields x, l
+      | _ -> [], ast
+    in
+    PpxContext.restore fields;
+    let ast =
+      try
+        let mapper = mapper () in
+        mapper.structure mapper ast
+      with exn ->
+        [{pstr_desc = Pstr_extension (extension_of_exn exn, []);
+          pstr_loc  = Location.none}]
+    in
+    let fields = PpxContext.update_cookies fields in
+    Str.attribute (PpxContext.mk fields) :: ast
+  in
+  let iface ast =
+    let fields, ast =
+      match ast with
+      | {psig_desc = Psig_attribute ({attr_name = {txt = "ocaml.ppx.context"};
+                                      attr_payload = x;
+                                      attr_loc = _})} :: l ->
+          PpxContext.get_fields x, l
+      | _ -> [], ast
+    in
+    PpxContext.restore fields;
+    let ast =
+      try
+        let mapper = mapper () in
+        mapper.signature mapper ast
+      with exn ->
+        [{psig_desc = Psig_extension (extension_of_exn exn, []);
+          psig_loc  = Location.none}]
+    in
+    let fields = PpxContext.update_cookies fields in
+    Sig.attribute (PpxContext.mk fields) :: ast
+  in
+
+  let ic = open_in_bin source in
+  let magic =
+    really_input_string ic (String.length Config.ast_impl_magic_number)
+  in
+
+  let rewrite transform =
+    Location.input_name := input_value ic;
+    let ast = input_value ic in
+    close_in ic;
+    let ast = transform ast in
+    let oc = open_out_bin target in
+    output_string oc magic;
+    output_value oc !Location.input_name;
+    output_value oc ast;
+    close_out oc
+  and fail () =
+    close_in ic;
+    failwith "Ast_mapper: OCaml version mismatch or malformed input";
+  in
+
+  if magic = Config.ast_impl_magic_number then
+    rewrite (implem : structure -> structure)
+  else if magic = Config.ast_intf_magic_number then
+    rewrite (iface : signature -> signature)
+  else fail ()
+
+let drop_ppx_context_str ~restore = function
+  | {pstr_desc = Pstr_attribute
+                   {attr_name = {Location.txt = "ocaml.ppx.context"};
+                    attr_payload = a;
+                    attr_loc = _}}
+    :: items ->
+      if restore then
+        PpxContext.restore (PpxContext.get_fields a);
+      items
+  | items -> items
+
+let drop_ppx_context_sig ~restore = function
+  | {psig_desc = Psig_attribute
+                   {attr_name = {Location.txt = "ocaml.ppx.context"};
+                    attr_payload = a;
+                    attr_loc = _}}
+    :: items ->
+      if restore then
+        PpxContext.restore (PpxContext.get_fields a);
+      items
+  | items -> items
+
+let add_ppx_context_str ~tool_name ast =
+  Ast_helper.Str.attribute (ppx_context ~tool_name ()) :: ast
+
+let add_ppx_context_sig ~tool_name ast =
+  Ast_helper.Sig.attribute (ppx_context ~tool_name ()) :: ast
+
+
+let apply ~source ~target mapper =
+  apply_lazy ~source ~target (fun () -> mapper)
+
+let run_main mapper =
+  try
+    let a = Sys.argv in
+    let n = Array.length a in
+    if n > 2 then
+      let mapper () =
+        try mapper (Array.to_list (Array.sub a 1 (n - 3)))
+        with exn ->
+          (* PR#6463 *)
+          let f _ _ = raise exn in
+          {default_mapper with structure = f; signature = f}
+      in
+      apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) mapper
+    else begin
+      Printf.eprintf "Usage: %s [extra_args] <infile> <outfile>\n%!"
+                     Sys.executable_name;
+      exit 2
+    end
+  with exn ->
+    prerr_endline (Printexc.to_string exn);
+    exit 2
+
+let register_function = ref (fun _name f -> run_main f)
+let register name f = !register_function name f
diff --git a/src/ocaml/parsing/ast_mapper.mli b/src/ocaml/parsing/ast_mapper.mli
new file mode 100644
index 0000000..69f6b01
--- /dev/null
+++ b/src/ocaml/parsing/ast_mapper.mli
@@ -0,0 +1,208 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** The interface of a -ppx rewriter
+
+  A -ppx rewriter is a program that accepts a serialized abstract syntax
+  tree and outputs another, possibly modified, abstract syntax tree.
+  This module encapsulates the interface between the compiler and
+  the -ppx rewriters, handling such details as the serialization format,
+  forwarding of command-line flags, and storing state.
+
+  {!mapper} enables AST rewriting using open recursion.
+  A typical mapper would be based on {!default_mapper}, a deep
+  identity mapper, and will fall back on it for handling the syntax it
+  does not modify. For example:
+
+  {[
+open Asttypes
+open Parsetree
+open Ast_mapper
+
+let test_mapper argv =
+  { default_mapper with
+    expr = fun mapper expr ->
+      match expr with
+      | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} ->
+        Ast_helper.Exp.constant (Const_int 42)
+      | other -> default_mapper.expr mapper other; }
+
+let () =
+  register "ppx_test" test_mapper]}
+
+  This -ppx rewriter, which replaces [[%test]] in expressions with
+  the constant [42], can be compiled using
+  [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml].
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+  *)
+
+open Parsetree
+
+(** {1 A generic Parsetree mapper} *)
+
+type mapper = {
+  attribute: mapper -> attribute -> attribute;
+  attributes: mapper -> attribute list -> attribute list;
+  binding_op: mapper -> binding_op -> binding_op;
+  case: mapper -> case -> case;
+  cases: mapper -> case list -> case list;
+  class_declaration: mapper -> class_declaration -> class_declaration;
+  class_description: mapper -> class_description -> class_description;
+  class_expr: mapper -> class_expr -> class_expr;
+  class_field: mapper -> class_field -> class_field;
+  class_signature: mapper -> class_signature -> class_signature;
+  class_structure: mapper -> class_structure -> class_structure;
+  class_type: mapper -> class_type -> class_type;
+  class_type_declaration: mapper -> class_type_declaration
+                          -> class_type_declaration;
+  class_type_field: mapper -> class_type_field -> class_type_field;
+  constant: mapper -> constant -> constant;
+  constructor_declaration: mapper -> constructor_declaration
+                           -> constructor_declaration;
+  expr: mapper -> expression -> expression;
+  extension: mapper -> extension -> extension;
+  extension_constructor: mapper -> extension_constructor
+                         -> extension_constructor;
+  include_declaration: mapper -> include_declaration -> include_declaration;
+  include_description: mapper -> include_description -> include_description;
+  label_declaration: mapper -> label_declaration -> label_declaration;
+  location: mapper -> Location.t -> Location.t;
+  module_binding: mapper -> module_binding -> module_binding;
+  module_declaration: mapper -> module_declaration -> module_declaration;
+  module_substitution: mapper -> module_substitution -> module_substitution;
+  module_expr: mapper -> module_expr -> module_expr;
+  module_type: mapper -> module_type -> module_type;
+  module_type_declaration: mapper -> module_type_declaration
+                           -> module_type_declaration;
+  open_declaration: mapper -> open_declaration -> open_declaration;
+  open_description: mapper -> open_description -> open_description;
+  pat: mapper -> pattern -> pattern;
+  payload: mapper -> payload -> payload;
+  signature: mapper -> signature -> signature;
+  signature_item: mapper -> signature_item -> signature_item;
+  structure: mapper -> structure -> structure;
+  structure_item: mapper -> structure_item -> structure_item;
+  typ: mapper -> core_type -> core_type;
+  type_declaration: mapper -> type_declaration -> type_declaration;
+  type_extension: mapper -> type_extension -> type_extension;
+  type_exception: mapper -> type_exception -> type_exception;
+  type_kind: mapper -> type_kind -> type_kind;
+  value_binding: mapper -> value_binding -> value_binding;
+  value_description: mapper -> value_description -> value_description;
+  with_constraint: mapper -> with_constraint -> with_constraint;
+}
+(** A mapper record implements one "method" per syntactic category,
+    using an open recursion style: each method takes as its first
+    argument the mapper to be applied to children in the syntax
+    tree. *)
+
+val default_mapper: mapper
+(** A default mapper, which implements a "deep identity" mapping. *)
+
+(** {1 Apply mappers to compilation units} *)
+
+val tool_name: unit -> string
+(** Can be used within a ppx preprocessor to know which tool is
+    calling it ["ocamlc"], ["ocamlopt"], ["ocamldoc"], ["ocamldep"],
+    ["ocaml"], ...  Some global variables that reflect command-line
+    options are automatically synchronized between the calling tool
+    and the ppx preprocessor: {!Clflags.include_dirs},
+    {!Load_path}, {!Clflags.open_modules}, {!Clflags.for_package},
+    {!Clflags.debug}. *)
+
+
+val apply: source:string -> target:string -> mapper -> unit
+(** Apply a mapper (parametrized by the unit name) to a dumped
+    parsetree found in the [source] file and put the result in the
+    [target] file. The [structure] or [signature] field of the mapper
+    is applied to the implementation or interface.  *)
+
+val run_main: (string list -> mapper) -> unit
+(** Entry point to call to implement a standalone -ppx rewriter from a
+    mapper, parametrized by the command line arguments.  The current
+    unit name can be obtained from {!Location.input_name}.  This
+    function implements proper error reporting for uncaught
+    exceptions. *)
+
+(** {1 Registration API} *)
+
+val register_function: (string -> (string list -> mapper) -> unit) ref
+
+val register: string -> (string list -> mapper) -> unit
+(** Apply the [register_function].  The default behavior is to run the
+    mapper immediately, taking arguments from the process command
+    line.  This is to support a scenario where a mapper is linked as a
+    stand-alone executable.
+
+    It is possible to overwrite the [register_function] to define
+    "-ppx drivers", which combine several mappers in a single process.
+    Typically, a driver starts by defining [register_function] to a
+    custom implementation, then lets ppx rewriters (linked statically
+    or dynamically) register themselves, and then run all or some of
+    them.  It is also possible to have -ppx drivers apply rewriters to
+    only specific parts of an AST.
+
+    The first argument to [register] is a symbolic name to be used by
+    the ppx driver.  *)
+
+
+(** {1 Convenience functions to write mappers} *)
+
+val map_opt: ('a -> 'b) -> 'a option -> 'b option
+
+val extension_of_error: Location.error -> extension
+(** Encode an error into an 'ocaml.error' extension node which can be
+    inserted in a generated Parsetree.  The compiler will be
+    responsible for reporting the error. *)
+
+val attribute_of_warning: Location.t -> string -> attribute
+(** Encode a warning message into an 'ocaml.ppwarning' attribute which can be
+    inserted in a generated Parsetree.  The compiler will be
+    responsible for reporting the warning. *)
+
+(** {1 Helper functions to call external mappers} *)
+
+val add_ppx_context_str:
+    tool_name:string -> Parsetree.structure -> Parsetree.structure
+(** Extract information from the current environment and encode it
+    into an attribute which is prepended to the list of structure
+    items in order to pass the information to an external
+    processor. *)
+
+val add_ppx_context_sig:
+    tool_name:string -> Parsetree.signature -> Parsetree.signature
+(** Same as [add_ppx_context_str], but for signatures. *)
+
+val drop_ppx_context_str:
+    restore:bool -> Parsetree.structure -> Parsetree.structure
+(** Drop the ocaml.ppx.context attribute from a structure.  If
+    [restore] is true, also restore the associated data in the current
+    process. *)
+
+val drop_ppx_context_sig:
+    restore:bool -> Parsetree.signature -> Parsetree.signature
+(** Same as [drop_ppx_context_str], but for signatures. *)
+
+(** {1 Cookies} *)
+
+(** Cookies are used to pass information from a ppx processor to
+    a further invocation of itself, when called from the OCaml
+    toplevel (or other tools that support cookies). *)
+
+val set_cookie: string -> Parsetree.expression -> unit
+val get_cookie: string -> Parsetree.expression option
diff --git a/src/ocaml/parsing/asttypes.mli b/src/ocaml/parsing/asttypes.mli
new file mode 100644
index 0000000..f4745fb
--- /dev/null
+++ b/src/ocaml/parsing/asttypes.mli
@@ -0,0 +1,67 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Auxiliary AST types used by parsetree and typedtree.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type constant =
+    Const_int of int
+  | Const_char of char
+  | Const_string of string * Location.t * string option
+  | Const_float of string
+  | Const_int32 of int32
+  | Const_int64 of int64
+  | Const_nativeint of nativeint
+
+type rec_flag = Nonrecursive | Recursive
+
+type direction_flag = Upto | Downto
+
+(* Order matters, used in polymorphic comparison *)
+type private_flag = Private | Public
+
+type mutable_flag = Immutable | Mutable
+
+type virtual_flag = Virtual | Concrete
+
+type override_flag = Override | Fresh
+
+type closed_flag = Closed | Open
+
+type label = string
+
+type arg_label =
+    Nolabel
+  | Labelled of string (*  label:T -> ... *)
+  | Optional of string (* ?label:T -> ... *)
+
+type 'a loc = 'a Location.loc = {
+  txt : 'a;
+  loc : Location.t;
+}
+
+
+type variance =
+  | Covariant
+  | Contravariant
+  | NoVariance
+
+type injectivity =
+  | Injective
+  | NoInjectivity
diff --git a/src/ocaml/parsing/attr_helper.ml b/src/ocaml/parsing/attr_helper.ml
new file mode 100644
index 0000000..0a616cd
--- /dev/null
+++ b/src/ocaml/parsing/attr_helper.ml
@@ -0,0 +1,54 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                  Jeremie Dimino, Jane Street Europe                    *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Parsetree
+
+type error =
+  | Multiple_attributes of string
+  | No_payload_expected of string
+
+exception Error of Location.t * error
+
+let get_no_payload_attribute alt_names attrs =
+  match List.filter (fun a -> List.mem a.attr_name.txt alt_names) attrs with
+  | [] -> None
+  | [ {attr_name = name; attr_payload = PStr []; attr_loc = _} ] -> Some name
+  | [ {attr_name = name; _} ] ->
+    raise (Error (name.loc, No_payload_expected name.txt))
+  | _ :: {attr_name = name; _} :: _ ->
+    raise (Error (name.loc, Multiple_attributes name.txt))
+
+let has_no_payload_attribute alt_names attrs =
+  match get_no_payload_attribute alt_names attrs with
+  | None   -> false
+  | Some _ -> true
+
+open Format
+
+let report_error ppf = function
+  | Multiple_attributes name ->
+    fprintf ppf "Too many `%s' attributes" name
+  | No_payload_expected name ->
+    fprintf ppf "Attribute `%s' does not accept a payload" name
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, err) ->
+        Some (Location.error_of_printer ~loc report_error err)
+      | _ ->
+        None
+    )
diff --git a/src/ocaml/parsing/attr_helper.mli b/src/ocaml/parsing/attr_helper.mli
new file mode 100644
index 0000000..a3ddc0c
--- /dev/null
+++ b/src/ocaml/parsing/attr_helper.mli
@@ -0,0 +1,41 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                  Jeremie Dimino, Jane Street Europe                    *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Helpers for attributes
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Asttypes
+open Parsetree
+
+type error =
+  | Multiple_attributes of string
+  | No_payload_expected of string
+
+(** The [string list] argument of the following functions is a list of
+    alternative names for the attribute we are looking for. For instance:
+
+    {[
+      ["foo"; "ocaml.foo"]
+    ]} *)
+val get_no_payload_attribute : string list -> attributes -> string loc option
+val has_no_payload_attribute : string list -> attributes -> bool
+
+exception Error of Location.t * error
+
+val report_error: Format.formatter -> error -> unit
diff --git a/src/ocaml/parsing/builtin_attributes.ml b/src/ocaml/parsing/builtin_attributes.ml
new file mode 100644
index 0000000..0db2133
--- /dev/null
+++ b/src/ocaml/parsing/builtin_attributes.ml
@@ -0,0 +1,289 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Parsetree
+
+let string_of_cst = function
+  | Pconst_string(s, _, _) -> Some s
+  | _ -> None
+
+let string_of_payload = function
+  | PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant c},_)}] ->
+      string_of_cst c
+  | _ -> None
+
+let string_of_opt_payload p =
+  match string_of_payload p with
+  | Some s -> s
+  | None -> ""
+
+let error_of_extension ext =
+  let submessage_from main_loc main_txt = function
+    | {pstr_desc=Pstr_extension
+           (({txt = ("ocaml.error"|"error"); loc}, p), _)} ->
+        begin match p with
+        | PStr([{pstr_desc=Pstr_eval
+                     ({pexp_desc=Pexp_constant(Pconst_string(msg,_,_))}, _)}
+               ]) ->
+            { Location.loc; txt = fun ppf -> Format.pp_print_text ppf msg }
+        | _ ->
+            { Location.loc; txt = fun ppf ->
+                Format.fprintf ppf
+                  "Invalid syntax for sub-message of extension '%s'." main_txt }
+        end
+    | {pstr_desc=Pstr_extension (({txt; loc}, _), _)} ->
+        { Location.loc; txt = fun ppf ->
+            Format.fprintf ppf "Uninterpreted extension '%s'." txt }
+    | _ ->
+        { Location.loc = main_loc; txt = fun ppf ->
+            Format.fprintf ppf
+              "Invalid syntax for sub-message of extension '%s'." main_txt }
+  in
+  match ext with
+  | ({txt = ("ocaml.error"|"error") as txt; loc}, p) ->
+      begin match p with
+      | PStr [] -> raise Location.Already_displayed_error
+      | PStr({pstr_desc=Pstr_eval
+                  ({pexp_desc=Pexp_constant(Pconst_string(msg,_,_))}, _)}::
+             inner) ->
+          let sub = List.map (submessage_from loc txt) inner in
+          Location.error_of_printer ~loc ~sub Format.pp_print_text msg
+      | _ ->
+          Location.errorf ~loc "Invalid syntax for extension '%s'." txt
+      end
+  | ({txt; loc}, _) ->
+      Location.errorf ~loc "Uninterpreted extension '%s'." txt
+
+let kind_and_message = function
+  | PStr[
+      {pstr_desc=
+         Pstr_eval
+           ({pexp_desc=Pexp_apply
+                 ({pexp_desc=Pexp_ident{txt=Longident.Lident id}},
+                  [Nolabel,{pexp_desc=Pexp_constant (Pconst_string(s,_,_))}])
+            },_)}] ->
+      Some (id, s)
+  | PStr[
+      {pstr_desc=
+         Pstr_eval
+           ({pexp_desc=Pexp_ident{txt=Longident.Lident id}},_)}] ->
+      Some (id, "")
+  | _ -> None
+
+let cat s1 s2 =
+  if s2 = "" then s1 else s1 ^ "\n" ^ s2
+
+let alert_attr x =
+  match x.attr_name.txt with
+  | "ocaml.deprecated"|"deprecated" ->
+      Some (x, "deprecated", string_of_opt_payload x.attr_payload)
+  | "ocaml.alert"|"alert" ->
+      begin match kind_and_message x.attr_payload with
+      | Some (kind, message) -> Some (x, kind, message)
+      | None -> None (* note: bad payloads detected by warning_attribute *)
+      end
+  | _ -> None
+
+let alert_attrs l =
+  List.filter_map alert_attr l
+
+let alerts_of_attrs l =
+  List.fold_left
+    (fun acc (_, kind, message) ->
+       let upd = function
+         | None | Some "" -> Some message
+         | Some s -> Some (cat s message)
+       in
+       Misc.String.Map.update kind upd acc
+    )
+    Misc.String.Map.empty
+    (alert_attrs l)
+
+let check_alerts loc attrs s =
+  Misc.String.Map.iter
+    (fun kind message -> Location.alert loc ~kind (cat s message))
+    (alerts_of_attrs attrs)
+
+let check_alerts_inclusion ~def ~use loc attrs1 attrs2 s =
+  let m2 = alerts_of_attrs attrs2 in
+  Misc.String.Map.iter
+    (fun kind msg ->
+       if not (Misc.String.Map.mem kind m2) then
+         Location.alert ~def ~use ~kind loc (cat s msg)
+    )
+    (alerts_of_attrs attrs1)
+
+let rec deprecated_mutable_of_attrs = function
+  | [] -> None
+  | {attr_name =  {txt = "ocaml.deprecated_mutable"|"deprecated_mutable"; _};
+     attr_payload = p} :: _ ->
+     Some (string_of_opt_payload p)
+  | _ :: tl -> deprecated_mutable_of_attrs tl
+
+let check_deprecated_mutable loc attrs s =
+  match deprecated_mutable_of_attrs attrs with
+  | None -> ()
+  | Some txt ->
+      Location.deprecated loc (Printf.sprintf "mutating field %s" (cat s txt))
+
+let check_deprecated_mutable_inclusion ~def ~use loc attrs1 attrs2 s =
+  match deprecated_mutable_of_attrs attrs1,
+        deprecated_mutable_of_attrs attrs2
+  with
+  | None, _ | Some _, Some _ -> ()
+  | Some txt, None ->
+      Location.deprecated ~def ~use loc
+        (Printf.sprintf "mutating field %s" (cat s txt))
+
+let rec attrs_of_sig = function
+  | {psig_desc = Psig_attribute a} :: tl ->
+      a :: attrs_of_sig tl
+  | _ ->
+      []
+
+let alerts_of_sig sg = alerts_of_attrs (attrs_of_sig sg)
+
+let rec attrs_of_str = function
+  | {pstr_desc = Pstr_attribute a} :: tl ->
+      a :: attrs_of_str tl
+  | _ ->
+      []
+
+let alerts_of_str str = alerts_of_attrs (attrs_of_str str)
+
+let check_no_alert attrs =
+  List.iter
+    (fun (a, _, _) ->
+       Location.prerr_warning a.attr_loc
+         (Warnings.Misplaced_attribute a.attr_name.txt)
+    )
+    (alert_attrs attrs)
+
+let warn_payload loc txt msg =
+  Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg))
+
+let warning_attribute ?(ppwarning = true) =
+  let process loc txt errflag payload =
+    match string_of_payload payload with
+    | Some s ->
+        begin try
+          Option.iter (Location.prerr_alert loc)
+            (Warnings.parse_options errflag s)
+        with Arg.Bad msg -> warn_payload loc txt msg
+        end
+    | None ->
+        warn_payload loc txt "A single string literal is expected"
+  in
+  let process_alert loc txt = function
+    | PStr[{pstr_desc=
+              Pstr_eval(
+                {pexp_desc=Pexp_constant(Pconst_string(s,_,_))},
+                _)
+           }] ->
+        begin try Warnings.parse_alert_option s
+        with Arg.Bad msg -> warn_payload loc txt msg
+        end
+    | k ->
+        match kind_and_message k with
+        | Some ("all", _) ->
+            warn_payload loc txt "The alert name 'all' is reserved"
+        | Some _ -> ()
+        | None -> warn_payload loc txt "Invalid payload"
+  in
+  function
+  | {attr_name = {txt = ("ocaml.warning"|"warning") as txt; _};
+     attr_loc;
+     attr_payload;
+     } ->
+      process attr_loc txt false attr_payload
+  | {attr_name = {txt = ("ocaml.warnerror"|"warnerror") as txt; _};
+     attr_loc;
+     attr_payload
+    } ->
+      process attr_loc txt true attr_payload
+  | {attr_name = {txt="ocaml.ppwarning"|"ppwarning"; _};
+     attr_loc = _;
+     attr_payload =
+       PStr [
+         { pstr_desc=
+             Pstr_eval({pexp_desc=Pexp_constant (Pconst_string (s, _, _))},_);
+           pstr_loc }
+       ];
+    } when ppwarning ->
+     Location.prerr_warning pstr_loc (Warnings.Preprocessor s)
+  | {attr_name = {txt = ("ocaml.alert"|"alert") as txt; _};
+     attr_loc;
+     attr_payload;
+     } ->
+      process_alert attr_loc txt attr_payload
+  | _ ->
+     ()
+
+let warning_scope ?ppwarning attrs f =
+  let prev = Warnings.backup () in
+  try
+    List.iter (warning_attribute ?ppwarning) (List.rev attrs);
+    let ret = f () in
+    Warnings.restore prev;
+    ret
+  with exn ->
+    Warnings.restore prev;
+    raise exn
+
+
+let warn_on_literal_pattern =
+  List.exists
+    (fun a -> match a.attr_name.txt with
+       | "ocaml.warn_on_literal_pattern"|"warn_on_literal_pattern" -> true
+       | _ -> false
+    )
+
+let explicit_arity =
+  List.exists
+    (fun a -> match a.attr_name.txt with
+       | "ocaml.explicit_arity"|"explicit_arity" -> true
+       | _ -> false
+    )
+
+let immediate =
+  List.exists
+    (fun a -> match a.attr_name.txt with
+       | "ocaml.immediate"|"immediate" -> true
+       | _ -> false
+    )
+
+let immediate64 =
+  List.exists
+    (fun a -> match a.attr_name.txt with
+       | "ocaml.immediate64"|"immediate64" -> true
+       | _ -> false
+    )
+
+(* The "ocaml.boxed (default)" and "ocaml.unboxed (default)"
+   attributes cannot be input by the user, they are added by the
+   compiler when applying the default setting. This is done to record
+   in the .cmi the default used by the compiler when compiling the
+   source file because the default can change between compiler
+   invocations. *)
+
+let check l a = List.mem a.attr_name.txt l
+
+let has_unboxed attr =
+  List.exists (check ["ocaml.unboxed"; "unboxed"])
+    attr
+
+let has_boxed attr =
+  List.exists (check ["ocaml.boxed"; "boxed"]) attr
diff --git a/src/ocaml/parsing/builtin_attributes.mli b/src/ocaml/parsing/builtin_attributes.mli
new file mode 100644
index 0000000..6200fd7
--- /dev/null
+++ b/src/ocaml/parsing/builtin_attributes.mli
@@ -0,0 +1,84 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Support for some of the builtin attributes
+
+    - ocaml.deprecated
+    - ocaml.alert
+    - ocaml.error
+    - ocaml.ppwarning
+    - ocaml.warning
+    - ocaml.warnerror
+    - ocaml.explicit_arity (for camlp4/camlp5)
+    - ocaml.warn_on_literal_pattern
+    - ocaml.deprecated_mutable
+    - ocaml.immediate
+    - ocaml.immediate64
+    - ocaml.boxed / ocaml.unboxed
+
+    {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+val check_alerts: Location.t -> Parsetree.attributes -> string -> unit
+val check_alerts_inclusion:
+  def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes ->
+  Parsetree.attributes -> string -> unit
+val alerts_of_attrs: Parsetree.attributes -> Misc.alerts
+val alerts_of_sig: Parsetree.signature -> Misc.alerts
+val alerts_of_str: Parsetree.structure -> Misc.alerts
+
+val check_deprecated_mutable:
+    Location.t -> Parsetree.attributes -> string -> unit
+val check_deprecated_mutable_inclusion:
+  def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes ->
+  Parsetree.attributes -> string -> unit
+
+val check_no_alert: Parsetree.attributes -> unit
+
+val error_of_extension: Parsetree.extension -> Location.error
+
+val warning_attribute: ?ppwarning:bool -> Parsetree.attribute -> unit
+  (** Apply warning settings from the specified attribute.
+      "ocaml.warning"/"ocaml.warnerror" (and variants without the prefix)
+      are processed and other attributes are ignored.
+
+      Also implement ocaml.ppwarning (unless ~ppwarning:false is
+      passed).
+  *)
+
+val warning_scope:
+  ?ppwarning:bool ->
+  Parsetree.attributes -> (unit -> 'a) -> 'a
+  (** Execute a function in a new scope for warning settings.  This
+      means that the effect of any call to [warning_attribute] during
+      the execution of this function will be discarded after
+      execution.
+
+      The function also takes a list of attributes which are processed
+      with [warning_attribute] in the fresh scope before the function
+      is executed.
+  *)
+
+val warn_on_literal_pattern: Parsetree.attributes -> bool
+val explicit_arity: Parsetree.attributes -> bool
+
+
+val immediate: Parsetree.attributes -> bool
+val immediate64: Parsetree.attributes -> bool
+
+val has_unboxed: Parsetree.attributes -> bool
+val has_boxed: Parsetree.attributes -> bool
diff --git a/src/ocaml/parsing/docstrings.ml b/src/ocaml/parsing/docstrings.ml
new file mode 100644
index 0000000..a39f75d
--- /dev/null
+++ b/src/ocaml/parsing/docstrings.ml
@@ -0,0 +1,425 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                               Leo White                                *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Location
+
+(* Docstrings *)
+
+(* A docstring is "attached" if it has been inserted in the AST. This
+   is used for generating unexpected docstring warnings. *)
+type ds_attached =
+  | Unattached   (* Not yet attached anything.*)
+  | Info         (* Attached to a field or constructor. *)
+  | Docs         (* Attached to an item or as floating text. *)
+
+(* A docstring is "associated" with an item if there are no blank lines between
+   them. This is used for generating docstring ambiguity warnings. *)
+type ds_associated =
+  | Zero             (* Not associated with an item *)
+  | One              (* Associated with one item *)
+  | Many             (* Associated with multiple items (ambiguity) *)
+
+type docstring =
+  { ds_body: string;
+    ds_loc: Location.t;
+    mutable ds_attached: ds_attached;
+    mutable ds_associated: ds_associated; }
+
+(* List of docstrings *)
+
+let docstrings : docstring list ref = ref []
+
+(* Warn for unused and ambiguous docstrings *)
+
+let warn_bad_docstrings () =
+  if Warnings.is_active (Warnings.Unexpected_docstring true) then begin
+    List.iter
+      (fun ds ->
+         match ds.ds_attached with
+         | Info -> ()
+         | Unattached ->
+           prerr_warning ds.ds_loc (Warnings.Unexpected_docstring true)
+         | Docs ->
+             match ds.ds_associated with
+             | Zero | One -> ()
+             | Many ->
+               prerr_warning ds.ds_loc (Warnings.Unexpected_docstring false))
+      (List.rev !docstrings)
+end
+
+(* Docstring constructors and destructors *)
+
+let docstring body loc =
+  let ds =
+    { ds_body = body;
+      ds_loc = loc;
+      ds_attached = Unattached;
+      ds_associated = Zero; }
+  in
+  ds
+
+let register ds =
+  docstrings := ds :: !docstrings
+
+let docstring_body ds = ds.ds_body
+
+let docstring_loc ds = ds.ds_loc
+
+(* Docstrings attached to items *)
+
+type docs =
+  { docs_pre: docstring option;
+    docs_post: docstring option; }
+
+let empty_docs = { docs_pre = None; docs_post = None }
+
+let doc_loc = {txt = "ocaml.doc"; loc = Location.none}
+
+let docs_attr ds =
+  let open Parsetree in
+  let body = ds.ds_body in
+  let loc = ds.ds_loc in
+  let exp =
+    { pexp_desc = Pexp_constant (Pconst_string(body, loc, None));
+      pexp_loc = loc;
+      pexp_loc_stack = [];
+      pexp_attributes = []; }
+  in
+  let item =
+    { pstr_desc = Pstr_eval (exp, []); pstr_loc = loc }
+  in
+  { attr_name = doc_loc;
+    attr_payload = PStr [item];
+    attr_loc = loc }
+
+let add_docs_attrs docs attrs =
+  let attrs =
+    match docs.docs_pre with
+    | None | Some { ds_body=""; _ } -> attrs
+    | Some ds -> docs_attr ds :: attrs
+  in
+  let attrs =
+    match docs.docs_post with
+    | None | Some { ds_body=""; _ } -> attrs
+    | Some ds -> attrs @ [docs_attr ds]
+  in
+  attrs
+
+(* Docstrings attached to constructors or fields *)
+
+type info = docstring option
+
+let empty_info = None
+
+let info_attr = docs_attr
+
+let add_info_attrs info attrs =
+  match info with
+  | None | Some {ds_body=""; _} -> attrs
+  | Some ds -> attrs @ [info_attr ds]
+
+(* Docstrings not attached to a specific item *)
+
+type text = docstring list
+
+let empty_text = []
+let empty_text_lazy = lazy []
+
+let text_loc = {txt = "ocaml.text"; loc = Location.none}
+
+let text_attr ds =
+  let open Parsetree in
+  let body = ds.ds_body in
+  let loc = ds.ds_loc in
+  let exp =
+    { pexp_desc = Pexp_constant (Pconst_string(body, loc, None));
+      pexp_loc = loc;
+      pexp_loc_stack = [];
+      pexp_attributes = []; }
+  in
+  let item =
+    { pstr_desc = Pstr_eval (exp, []); pstr_loc = loc }
+  in
+  { attr_name = text_loc;
+    attr_payload = PStr [item];
+    attr_loc = loc }
+
+let add_text_attrs dsl attrs =
+  let fdsl = List.filter (function {ds_body=""} -> false| _ ->true) dsl in
+  (List.map text_attr fdsl) @ attrs
+
+(* Find the first non-info docstring in a list, attach it and return it *)
+let get_docstring ~info dsl =
+  let rec loop = function
+    | [] -> None
+    | {ds_attached = Info; _} :: rest -> loop rest
+    | ds :: _ ->
+        ds.ds_attached <- if info then Info else Docs;
+        Some ds
+  in
+  loop dsl
+
+(* Find all the non-info docstrings in a list, attach them and return them *)
+let get_docstrings dsl =
+  let rec loop acc = function
+    | [] -> List.rev acc
+    | {ds_attached = Info; _} :: rest -> loop acc rest
+    | ds :: rest ->
+        ds.ds_attached <- Docs;
+        loop (ds :: acc) rest
+  in
+    loop [] dsl
+
+(* "Associate" all the docstrings in a list *)
+let associate_docstrings dsl =
+  List.iter
+    (fun ds ->
+       match ds.ds_associated with
+       | Zero -> ds.ds_associated <- One
+       | (One | Many) -> ds.ds_associated <- Many)
+    dsl
+
+(* Map from positions to pre docstrings *)
+
+let pre_table : (Lexing.position, docstring list) Hashtbl.t =
+  Hashtbl.create 50
+
+let set_pre_docstrings pos dsl =
+  if dsl <> [] then Hashtbl.add pre_table pos dsl
+
+let get_pre_docs pos =
+  try
+    let dsl = Hashtbl.find pre_table pos in
+      associate_docstrings dsl;
+      get_docstring ~info:false dsl
+  with Not_found -> None
+
+let mark_pre_docs pos =
+  try
+    let dsl = Hashtbl.find pre_table pos in
+      associate_docstrings dsl
+  with Not_found -> ()
+
+(* Map from positions to post docstrings *)
+
+let post_table : (Lexing.position, docstring list) Hashtbl.t =
+  Hashtbl.create 50
+
+let set_post_docstrings pos dsl =
+  if dsl <> [] then Hashtbl.add post_table pos dsl
+
+let get_post_docs pos =
+  try
+    let dsl = Hashtbl.find post_table pos in
+      associate_docstrings dsl;
+      get_docstring ~info:false dsl
+  with Not_found -> None
+
+let mark_post_docs pos =
+  try
+    let dsl = Hashtbl.find post_table pos in
+      associate_docstrings dsl
+  with Not_found -> ()
+
+let get_info pos =
+  try
+    let dsl = Hashtbl.find post_table pos in
+      get_docstring ~info:true dsl
+  with Not_found -> None
+
+(* Map from positions to floating docstrings *)
+
+let floating_table : (Lexing.position, docstring list) Hashtbl.t =
+  Hashtbl.create 50
+
+let set_floating_docstrings pos dsl =
+  if dsl <> [] then Hashtbl.add floating_table pos dsl
+
+let get_text pos =
+  try
+    let dsl = Hashtbl.find floating_table pos in
+      get_docstrings dsl
+  with Not_found -> []
+
+let get_post_text pos =
+  try
+    let dsl = Hashtbl.find post_table pos in
+      get_docstrings dsl
+  with Not_found -> []
+
+(* Maps from positions to extra docstrings *)
+
+let pre_extra_table : (Lexing.position, docstring list) Hashtbl.t =
+  Hashtbl.create 50
+
+let set_pre_extra_docstrings pos dsl =
+  if dsl <> [] then Hashtbl.add pre_extra_table pos dsl
+
+let get_pre_extra_text pos =
+  try
+    let dsl = Hashtbl.find pre_extra_table pos in
+      get_docstrings dsl
+  with Not_found -> []
+
+let post_extra_table : (Lexing.position, docstring list) Hashtbl.t =
+  Hashtbl.create 50
+
+let set_post_extra_docstrings pos dsl =
+  if dsl <> [] then Hashtbl.add post_extra_table pos dsl
+
+let get_post_extra_text pos =
+  try
+    let dsl = Hashtbl.find post_extra_table pos in
+      get_docstrings dsl
+  with Not_found -> []
+
+(* Docstrings from parser actions *)
+module WithParsing = struct
+let symbol_docs () =
+  { docs_pre = get_pre_docs (Parsing.symbol_start_pos ());
+    docs_post = get_post_docs (Parsing.symbol_end_pos ()); }
+
+let symbol_docs_lazy () =
+  let p1 = Parsing.symbol_start_pos () in
+  let p2 = Parsing.symbol_end_pos () in
+    lazy { docs_pre = get_pre_docs p1;
+           docs_post = get_post_docs p2; }
+
+let rhs_docs pos1 pos2 =
+  { docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1);
+    docs_post = get_post_docs (Parsing.rhs_end_pos pos2); }
+
+let rhs_docs_lazy pos1 pos2 =
+  let p1 = Parsing.rhs_start_pos pos1 in
+  let p2 = Parsing.rhs_end_pos pos2 in
+    lazy { docs_pre = get_pre_docs p1;
+           docs_post = get_post_docs p2; }
+
+let mark_symbol_docs () =
+  mark_pre_docs (Parsing.symbol_start_pos ());
+  mark_post_docs (Parsing.symbol_end_pos ())
+
+let mark_rhs_docs pos1 pos2 =
+  mark_pre_docs (Parsing.rhs_start_pos pos1);
+  mark_post_docs (Parsing.rhs_end_pos pos2)
+
+let symbol_info () =
+  get_info (Parsing.symbol_end_pos ())
+
+let rhs_info pos =
+  get_info (Parsing.rhs_end_pos pos)
+
+let symbol_text () =
+  get_text (Parsing.symbol_start_pos ())
+
+let symbol_text_lazy () =
+  let pos = Parsing.symbol_start_pos () in
+    lazy (get_text pos)
+
+let rhs_text pos =
+  get_text (Parsing.rhs_start_pos pos)
+
+let rhs_post_text pos =
+  get_post_text (Parsing.rhs_end_pos pos)
+
+let rhs_text_lazy pos =
+  let pos = Parsing.rhs_start_pos pos in
+    lazy (get_text pos)
+
+let symbol_pre_extra_text () =
+  get_pre_extra_text (Parsing.symbol_start_pos ())
+
+let symbol_post_extra_text () =
+  get_post_extra_text (Parsing.symbol_end_pos ())
+
+let rhs_pre_extra_text pos =
+  get_pre_extra_text (Parsing.rhs_start_pos pos)
+
+let rhs_post_extra_text pos =
+  get_post_extra_text (Parsing.rhs_end_pos pos)
+end
+
+include WithParsing
+
+module WithMenhir = struct
+let symbol_docs (startpos, endpos) =
+  { docs_pre = get_pre_docs startpos;
+    docs_post = get_post_docs endpos; }
+
+let symbol_docs_lazy (p1, p2) =
+  lazy { docs_pre = get_pre_docs p1;
+         docs_post = get_post_docs p2; }
+
+let rhs_docs pos1 pos2 =
+  { docs_pre = get_pre_docs pos1;
+    docs_post = get_post_docs pos2; }
+
+let rhs_docs_lazy p1 p2 =
+    lazy { docs_pre = get_pre_docs p1;
+           docs_post = get_post_docs p2; }
+
+let mark_symbol_docs (startpos, endpos) =
+  mark_pre_docs startpos;
+  mark_post_docs endpos;
+  ()
+
+let mark_rhs_docs pos1 pos2 =
+  mark_pre_docs pos1;
+  mark_post_docs pos2;
+  ()
+
+let symbol_info endpos =
+  get_info endpos
+
+let rhs_info endpos =
+  get_info endpos
+
+let symbol_text startpos =
+  get_text startpos
+
+let symbol_text_lazy startpos =
+  lazy (get_text startpos)
+
+let rhs_text pos =
+  get_text pos
+
+let rhs_post_text pos =
+  get_post_text pos
+
+let rhs_text_lazy pos =
+  lazy (get_text pos)
+
+let symbol_pre_extra_text startpos =
+  get_pre_extra_text startpos
+
+let symbol_post_extra_text endpos =
+  get_post_extra_text endpos
+
+let rhs_pre_extra_text pos =
+  get_pre_extra_text pos
+
+let rhs_post_extra_text pos =
+  get_post_extra_text pos
+end
+
+(* (Re)Initialise all comment state *)
+
+let init () =
+  docstrings := [];
+  Hashtbl.reset pre_table;
+  Hashtbl.reset post_table;
+  Hashtbl.reset floating_table;
+  Hashtbl.reset pre_extra_table;
+  Hashtbl.reset post_extra_table
diff --git a/src/ocaml/parsing/docstrings.mli b/src/ocaml/parsing/docstrings.mli
new file mode 100644
index 0000000..bf2508f
--- /dev/null
+++ b/src/ocaml/parsing/docstrings.mli
@@ -0,0 +1,223 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                               Leo White                                *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Documentation comments
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+(** (Re)Initialise all docstring state *)
+val init : unit -> unit
+
+(** Emit warnings for unattached and ambiguous docstrings *)
+val warn_bad_docstrings : unit -> unit
+
+(** {2 Docstrings} *)
+
+(** Documentation comments *)
+type docstring
+
+(** Create a docstring *)
+val docstring : string -> Location.t -> docstring
+
+(** Register a docstring *)
+val register : docstring -> unit
+
+(** Get the text of a docstring *)
+val docstring_body : docstring -> string
+
+(** Get the location of a docstring *)
+val docstring_loc : docstring -> Location.t
+
+(** {2 Set functions}
+
+   These functions are used by the lexer to associate docstrings to
+   the locations of tokens. *)
+
+(** Docstrings immediately preceding a token *)
+val set_pre_docstrings : Lexing.position -> docstring list -> unit
+
+(** Docstrings immediately following a token *)
+val set_post_docstrings : Lexing.position -> docstring list -> unit
+
+(** Docstrings not immediately adjacent to a token *)
+val set_floating_docstrings : Lexing.position -> docstring list -> unit
+
+(** Docstrings immediately following the token which precedes this one *)
+val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit
+
+(** Docstrings immediately preceding the token which follows this one *)
+val set_post_extra_docstrings : Lexing.position -> docstring list -> unit
+
+(** {2 Items}
+
+    The {!docs} type represents documentation attached to an item. *)
+
+type docs =
+  { docs_pre: docstring option;
+    docs_post: docstring option; }
+
+val empty_docs : docs
+
+val docs_attr : docstring -> Parsetree.attribute
+
+(** Convert item documentation to attributes and add them to an
+    attribute list *)
+val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes
+
+(** Fetch the item documentation for the current symbol. This also
+    marks this documentation (for ambiguity warnings). *)
+val symbol_docs : unit -> docs
+val symbol_docs_lazy : unit -> docs Lazy.t
+
+(** Fetch the item documentation for the symbols between two
+    positions. This also marks this documentation (for ambiguity
+    warnings). *)
+val rhs_docs : int -> int -> docs
+val rhs_docs_lazy : int -> int -> docs Lazy.t
+
+(** Mark the item documentation for the current symbol (for ambiguity
+    warnings). *)
+val mark_symbol_docs : unit -> unit
+
+(** Mark as associated the item documentation for the symbols between
+    two positions (for ambiguity warnings) *)
+val mark_rhs_docs : int -> int -> unit
+
+(** {2 Fields and constructors}
+
+    The {!info} type represents documentation attached to a field or
+    constructor. *)
+
+type info = docstring option
+
+val empty_info : info
+
+val info_attr : docstring -> Parsetree.attribute
+
+(** Convert field info to attributes and add them to an
+    attribute list *)
+val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes
+
+(** Fetch the field info for the current symbol. *)
+val symbol_info : unit -> info
+
+(** Fetch the field info following the symbol at a given position. *)
+val rhs_info : int -> info
+
+(** {2 Unattached comments}
+
+    The {!text} type represents documentation which is not attached to
+    anything. *)
+
+type text = docstring list
+
+val empty_text : text
+val empty_text_lazy : text Lazy.t
+
+val text_attr : docstring -> Parsetree.attribute
+
+(** Convert text to attributes and add them to an attribute list *)
+val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes
+
+(** Fetch the text preceding the current symbol. *)
+val symbol_text : unit -> text
+val symbol_text_lazy : unit -> text Lazy.t
+
+(** Fetch the text preceding the symbol at the given position. *)
+val rhs_text : int -> text
+val rhs_text_lazy : int -> text Lazy.t
+
+(** {2 Extra text}
+
+    There may be additional text attached to the delimiters of a block
+    (e.g. [struct] and [end]). This is fetched by the following
+    functions, which are applied to the contents of the block rather
+    than the delimiters. *)
+
+(** Fetch additional text preceding the current symbol *)
+val symbol_pre_extra_text : unit -> text
+
+(** Fetch additional text following the current symbol *)
+val symbol_post_extra_text : unit -> text
+
+(** Fetch additional text preceding the symbol at the given position *)
+val rhs_pre_extra_text : int -> text
+
+(** Fetch additional text following the symbol at the given position *)
+val rhs_post_extra_text : int -> text
+
+(** Fetch text following the symbol at the given position *)
+val rhs_post_text : int -> text
+
+module WithMenhir: sig
+(** Fetch the item documentation for the current symbol. This also
+    marks this documentation (for ambiguity warnings). *)
+val symbol_docs : Lexing.position * Lexing.position -> docs
+val symbol_docs_lazy : Lexing.position * Lexing.position -> docs Lazy.t
+
+(** Fetch the item documentation for the symbols between two
+    positions. This also marks this documentation (for ambiguity
+    warnings). *)
+val rhs_docs : Lexing.position -> Lexing.position -> docs
+val rhs_docs_lazy : Lexing.position -> Lexing.position -> docs Lazy.t
+
+(** Mark the item documentation for the current symbol (for ambiguity
+    warnings). *)
+val mark_symbol_docs : Lexing.position * Lexing.position -> unit
+
+(** Mark as associated the item documentation for the symbols between
+    two positions (for ambiguity warnings) *)
+val mark_rhs_docs : Lexing.position -> Lexing.position -> unit
+
+(** Fetch the field info for the current symbol. *)
+val symbol_info : Lexing.position -> info
+
+(** Fetch the field info following the symbol at a given position. *)
+val rhs_info : Lexing.position -> info
+
+(** Fetch the text preceding the current symbol. *)
+val symbol_text : Lexing.position -> text
+val symbol_text_lazy : Lexing.position -> text Lazy.t
+
+(** Fetch the text preceding the symbol at the given position. *)
+val rhs_text : Lexing.position -> text
+val rhs_text_lazy : Lexing.position -> text Lazy.t
+
+(** {3 Extra text}
+
+    There may be additional text attached to the delimiters of a block
+    (e.g. [struct] and [end]). This is fetched by the following
+    functions, which are applied to the contents of the block rather
+    than the delimiters. *)
+
+(** Fetch additional text preceding the current symbol *)
+val symbol_pre_extra_text : Lexing.position -> text
+
+(** Fetch additional text following the current symbol *)
+val symbol_post_extra_text : Lexing.position -> text
+
+(** Fetch additional text preceding the symbol at the given position *)
+val rhs_pre_extra_text : Lexing.position -> text
+
+(** Fetch additional text following the symbol at the given position *)
+val rhs_post_extra_text : Lexing.position -> text
+
+(** Fetch text following the symbol at the given position *)
+val rhs_post_text : Lexing.position -> text
+
+end
diff --git a/src/ocaml/parsing/dune b/src/ocaml/parsing/dune
new file mode 100644
index 0000000..83dea9a
--- /dev/null
+++ b/src/ocaml/parsing/dune
@@ -0,0 +1,8 @@
+(rule (copy# ../../extend/extend_helper.ml  extend_helper.ml ))
+(rule (copy# ../../extend/extend_helper.mli extend_helper.mli))
+
+(library
+  (name ocaml_parsing)
+  (flags -open Ocaml_utils -open Merlin_utils (:standard -w -9))
+  (modules_without_implementation asttypes parsetree)
+  (libraries merlin_utils ocaml_utils))
diff --git a/src/ocaml/parsing/fake.ml b/src/ocaml/parsing/fake.ml
new file mode 100644
index 0000000..19716c3
--- /dev/null
+++ b/src/ocaml/parsing/fake.ml
@@ -0,0 +1,74 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Parsetree
+
+let app a b =
+  let loc =
+    if a.pexp_loc.Location.loc_ghost
+    then {b.pexp_loc with Location.loc_ghost = true}
+    else b.pexp_loc
+  in
+  Ast_helper.Exp.apply ~loc a [Ast_helper.no_label, b]
+
+let pat_app f (pat,expr) = pat, app f expr
+
+let prim_ident prim = Longident.parse ("_." ^ prim)
+let prim ?(ghost=true) prim =
+  let open Location in
+  let ident = mknoloc (prim_ident prim) in
+  let ident = if ghost
+    then ident
+    else {ident with loc = {ident.loc with loc_ghost = false}}
+  in
+  Ast_helper.Exp.ident ~loc:ident.loc ident
+
+(* Lwt extension *)
+module Lwt = struct
+  let un_lwt = prim "Lwt.un_lwt"
+  let to_lwt = prim "Lwt.to_lwt"
+  let in_lwt = prim "Lwt.in_lwt"
+  let unit_lwt = prim "Lwt.unit_lwt"
+  let un_stream = prim "Lwt.un_stream"
+  let finally_ = prim "Lwt.finally'"
+  let raise_lwt_ = prim_ident "Lwt.raise_lwt'"
+end
+
+(* MetaOCaml support *)
+module Meta = struct
+  let prim_code = prim "Meta.code"
+  let prim_uncode = prim "Meta.uncode"
+
+  let code loc_start loc_end expr =
+    let loc = {expr.pexp_loc with Location. loc_start; loc_end} in
+    Ast_helper.Exp.apply ~loc prim_code [Ast_helper.no_label, expr]
+
+  let uncode loc_start loc_end expr =
+    let loc = {expr.pexp_loc with Location. loc_start; loc_end} in
+    Ast_helper.Exp.apply ~loc prim_uncode [Ast_helper.no_label, expr]
+end
diff --git a/src/ocaml/parsing/fake.mli b/src/ocaml/parsing/fake.mli
new file mode 100644
index 0000000..3dbbc19
--- /dev/null
+++ b/src/ocaml/parsing/fake.mli
@@ -0,0 +1,55 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+(* Definitions to help generating or rewriting pieces of AST,
+ * used to simulate some CamlP4 extensions. *)
+
+(* Generate AST faking value application *)
+val app : Parsetree.expression ->
+  Parsetree.expression -> Parsetree.expression
+val pat_app : Parsetree.expression ->
+  ('a * Parsetree.expression) -> ('a * Parsetree.expression )
+
+(* Lwt extension *)
+module Lwt : sig
+  val un_lwt     : Parsetree.expression
+  val to_lwt     : Parsetree.expression
+  val in_lwt     : Parsetree.expression
+  val unit_lwt   : Parsetree.expression
+  val un_stream  : Parsetree.expression
+  val finally_   : Parsetree.expression
+  val raise_lwt_ : Longident.t
+end
+
+(* MetaOCaml support *)
+module Meta : sig
+  val code : Lexing.position -> Lexing.position ->
+    Parsetree.expression -> Parsetree.expression
+  val uncode : Lexing.position -> Lexing.position ->
+    Parsetree.expression -> Parsetree.expression
+end
diff --git a/src/ocaml/parsing/location.ml b/src/ocaml/parsing/location.ml
new file mode 100644
index 0000000..bfb71c0
--- /dev/null
+++ b/src/ocaml/parsing/location.ml
@@ -0,0 +1,820 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Lexing
+
+type t = Warnings.loc =
+  { loc_start: position; loc_end: position; loc_ghost: bool };;
+
+let in_file name =
+  let loc = { dummy_pos with pos_fname = name } in
+  { loc_start = loc; loc_end = loc; loc_ghost = true }
+;;
+
+let none = in_file "_none_";;
+let is_none l = (l = none);;
+
+let curr lexbuf = {
+  loc_start = lexbuf.lex_start_p;
+  loc_end = lexbuf.lex_curr_p;
+  loc_ghost = false
+};;
+
+let init lexbuf fname =
+  lexbuf.lex_curr_p <- {
+    pos_fname = fname;
+    pos_lnum = 1;
+    pos_bol = 0;
+    pos_cnum = 0;
+  }
+;;
+
+let symbol_rloc () = {
+  loc_start = Parsing.symbol_start_pos ();
+  loc_end = Parsing.symbol_end_pos ();
+  loc_ghost = false;
+};;
+
+let symbol_gloc () = {
+  loc_start = Parsing.symbol_start_pos ();
+  loc_end = Parsing.symbol_end_pos ();
+  loc_ghost = true;
+};;
+
+let rhs_loc n = {
+  loc_start = Parsing.rhs_start_pos n;
+  loc_end = Parsing.rhs_end_pos n;
+  loc_ghost = false;
+};;
+
+let rhs_interval m n = {
+  loc_start = Parsing.rhs_start_pos m;
+  loc_end = Parsing.rhs_end_pos n;
+  loc_ghost = false;
+};;
+
+(* return file, line, char from the given position *)
+let get_pos_info pos =
+  (pos.pos_fname, pos.pos_lnum, pos.pos_cnum - pos.pos_bol)
+;;
+
+type 'a loc = {
+  txt : 'a;
+  loc : t;
+}
+
+let mkloc txt loc = { txt ; loc }
+let mknoloc txt = mkloc txt none
+
+(******************************************************************************)
+(* Input info *)
+
+let input_name = ref "_none_"
+let input_lexbuf = ref (None : lexbuf option)
+
+(******************************************************************************)
+(* Terminal info *)
+
+(* The number of lines already printed after input.
+
+   This is used by [highlight_terminfo] to identify the current position of the
+   input in the terminal. This would not be possible without this information,
+   since printing several warnings/errors adds text between the user input and
+   the bottom of the terminal.
+*)
+let num_loc_lines = ref 0
+
+(* This is used by the toplevel to reset [num_loc_lines] before each phrase *)
+let reset () =
+  num_loc_lines := 0
+
+(* This is used by the toplevel *)
+let echo_eof () =
+  print_newline ();
+  incr num_loc_lines
+
+(* Code printing errors and warnings must be wrapped using this function, in
+   order to update [num_loc_lines].
+
+   [print_updating_num_loc_lines ppf f arg] is equivalent to calling [f ppf
+   arg], and additionally updates [num_loc_lines]. *)
+let print_updating_num_loc_lines ppf f arg =
+  let open Format in
+  let out_functions = pp_get_formatter_out_functions ppf () in
+  let out_string str start len =
+    let rec count i c =
+      if i = start + len then c
+      else if String.get str i = '\n' then count (succ i) (succ c)
+      else count (succ i) c in
+    num_loc_lines := !num_loc_lines + count start 0 ;
+    out_functions.out_string str start len in
+  pp_set_formatter_out_functions ppf
+    { out_functions with out_string } ;
+  f ppf arg ;
+  pp_print_flush ppf ();
+  pp_set_formatter_out_functions ppf out_functions
+
+(******************************************************************************)
+(* Printing locations, e.g. 'File "foo.ml", line 3, characters 10-12' *)
+
+let rewrite_absolute_path path =
+  (*
+  match Misc.get_build_path_prefix_map () with
+  | None -> path
+  | Some map -> Build_path_prefix_map.rewrite map path
+  *)
+  path
+
+let absolute_path s = (* This function could go into Filename *)
+  let open Filename in
+  let s =
+    if not (is_relative s) then s
+    else (rewrite_absolute_path (concat (Sys.getcwd ()) s))
+  in
+  (* Now simplify . and .. components *)
+  let rec aux s =
+    let base = basename s in
+    let dir = dirname s in
+    if dir = s then dir
+    else if base = current_dir_name then aux dir
+    else if base = parent_dir_name then dirname (aux dir)
+    else concat (aux dir) base
+  in
+  aux s
+
+let show_filename file =
+  (* if !Clflags.absname then absolute_path file else *) file
+
+let print_filename ppf file =
+  Format.pp_print_string ppf (show_filename file)
+
+(* Best-effort printing of the text describing a location, of the form
+   'File "foo.ml", line 3, characters 10-12'.
+
+   Some of the information (filename, line number or characters numbers) in the
+   location might be invalid; in which case we do not print it.
+ *)
+let print_loc ppf loc =
+  let file_valid = function
+    | "_none_" ->
+        (* This is a dummy placeholder, but we print it anyway to please editors
+           that parse locations in error messages (e.g. Emacs). *)
+        true
+    | "" | "//toplevel//" -> false
+    | _ -> true
+  in
+  let line_valid line = line > 0 in
+  let chars_valid ~startchar ~endchar = startchar <> -1 && endchar <> -1 in
+
+  let file =
+    (* According to the comment in location.mli, if [pos_fname] is "", we must
+       use [!input_name]. *)
+    if loc.loc_start.pos_fname = "" then !input_name
+    else loc.loc_start.pos_fname
+  in
+  let line = loc.loc_start.pos_lnum in
+  let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in
+  let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_bol in
+
+  let first = ref true in
+  let capitalize s =
+    if !first then (first := false; String.capitalize_ascii s)
+    else s in
+  let comma () =
+    if !first then () else Format.fprintf ppf ", " in
+
+  Format.fprintf ppf "@{<loc>";
+
+  if file_valid file then
+    Format.fprintf ppf "%s \"%a\"" (capitalize "file") print_filename file;
+
+  (* Print "line 1" in the case of a dummy line number. This is to please the
+     existing setup of editors that parse locations in error messages (e.g.
+     Emacs). *)
+  comma ();
+  Format.fprintf ppf "%s %i" (capitalize "line")
+    (if line_valid line then line else 1);
+
+  if chars_valid ~startchar ~endchar then (
+    comma ();
+    Format.fprintf ppf "%s %i-%i" (capitalize "characters") startchar endchar
+  );
+
+  Format.fprintf ppf "@}"
+
+(* Print a comma-separated list of locations *)
+let print_locs ppf locs =
+  Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ")
+    print_loc ppf locs
+
+(******************************************************************************)
+(* An interval set structure; additionally, it stores user-provided information
+   at interval boundaries.
+
+   The implementation provided here is naive and assumes the number of intervals
+   to be small, but the interface would allow for a more efficient
+   implementation if needed.
+
+   Note: the structure only stores maximal intervals (that therefore do not
+   overlap).
+*)
+
+(*
+module ISet : sig
+  type 'a bound = 'a * int
+  type 'a t
+  (* bounds are included *)
+  val of_intervals : ('a bound * 'a bound) list -> 'a t
+
+  val mem : 'a t -> pos:int -> bool
+  val find_bound_in : 'a t -> range:(int * int) -> 'a bound option
+
+  val is_start : 'a t -> pos:int -> 'a option
+  val is_end : 'a t -> pos:int -> 'a option
+
+  val extrema : 'a t -> ('a bound * 'a bound) option
+end
+=
+struct
+  type 'a bound = 'a * int
+
+  (* non overlapping intervals *)
+  type 'a t = ('a bound * 'a bound) list
+
+  let of_intervals intervals =
+    let pos =
+      List.map (fun ((a, x), (b, y)) ->
+        if x > y then [] else [((a, x), `S); ((b, y), `E)]
+      ) intervals
+      |> List.flatten
+      |> List.sort (fun ((_, x), k) ((_, y), k') ->
+        (* Make `S come before `E so that consecutive intervals get merged
+           together in the fold below *)
+        let kn = function `S -> 0 | `E -> 1 in
+        compare (x, kn k) (y, kn k'))
+    in
+    let nesting, acc =
+      List.fold_left (fun (nesting, acc) (a, kind) ->
+        match kind, nesting with
+        | `S, `Outside -> `Inside (a, 0), acc
+        | `S, `Inside (s, n) -> `Inside (s, n+1), acc
+        | `E, `Outside -> assert false
+        | `E, `Inside (s, 0) -> `Outside, ((s, a) :: acc)
+        | `E, `Inside (s, n) -> `Inside (s, n-1), acc
+      ) (`Outside, []) pos in
+    assert (nesting = `Outside);
+    List.rev acc
+
+  let mem iset ~pos =
+    List.exists (fun ((_, s), (_, e)) -> s <= pos && pos <= e) iset
+
+  let find_bound_in iset ~range:(start, end_)  =
+    try Some (
+    List.find_map ~f:(fun ((a, x), (b, y)) ->
+      if start <= x && x <= end_ then Some (a, x)
+      else if start <= y && y <= end_ then Some (b, y)
+      else None
+    ) iset
+    ) with Not_found -> None
+
+  let is_start iset ~pos =
+    try Some (
+    List.find_map ~f:(fun ((a, x), _) ->
+      if pos = x then Some a else None
+    ) iset
+    ) with Not_found -> None
+
+  let is_end iset ~pos =
+    try Some (
+    List.find_map ~f:(fun (_, (b, y)) ->
+      if pos = y then Some b else None
+    ) iset
+    ) with Not_found -> None
+
+  let extrema iset =
+    if iset = [] then None
+    else Some (fst (List.hd iset), snd (List.hd (List.rev iset)))
+end
+*)
+
+
+(* Highlight the location by printing it again.
+
+   There are two different styles for highlighting errors in "dumb" mode,
+   depending if the error fits on a single line or spans across several lines.
+
+   For single-line errors,
+
+     foo the_error bar
+
+   gets displayed as follows, where X is the line number:
+
+     X | foo the_error bar
+             ^^^^^^^^^
+
+
+   For multi-line errors,
+
+     foo the_
+     error bar
+
+   gets displayed as:
+
+     X1 | ....the_
+     X2 | error....
+
+   An ellipsis hides the middle lines of the multi-line error if it has more
+   than [max_lines] lines.
+
+   If [locs] is empty then this function is a no-op.
+*)
+
+(*
+type input_line = {
+  text : string;
+  start_pos : int;
+}
+*)
+
+(* Takes a list of lines with possibly missing line numbers.
+
+   If the line numbers that are present are consistent with the number of lines
+   between them, then infer the intermediate line numbers.
+
+   This is not always the case, typically if lexer line directives are
+   involved... *)
+(*
+let infer_line_numbers
+    (lines: (int option * input_line) list):
+  (int option * input_line) list
+  =
+  let (_, offset, consistent) =
+    List.fold_left (fun (i, offset, consistent) (lnum, _) ->
+      match lnum, offset with
+      | None, _ -> (i+1, offset, consistent)
+      | Some n, None -> (i+1, Some (n - i), consistent)
+      | Some n, Some m -> (i+1, offset, consistent && n = m + i)
+    ) (0, None, true) lines
+  in
+  match offset, consistent with
+  | Some m, true ->
+      List.mapi (fun i (_, line) -> (Some (m + i), line)) lines
+  | _, _ ->
+      lines
+*)
+(* [get_lines] must return the lines to highlight, given starting and ending
+   positions.
+
+   See [lines_around_from_current_input] below for an instantiation of
+   [get_lines] that reads from the current input.
+*)
+
+
+
+(*
+let lines_around
+    ~(start_pos: position) ~(end_pos: position)
+    ~(seek: int -> unit)
+    ~(read_char: unit -> char option):
+  input_line list
+  =
+  seek start_pos.pos_bol;
+  let lines = ref [] in
+  let bol = ref start_pos.pos_bol in
+  let cur = ref start_pos.pos_bol in
+  let b = Buffer.create 80 in
+  let add_line () =
+    if !bol < !cur then begin
+      let text = Buffer.contents b in
+      Buffer.clear b;
+      lines := { text; start_pos = !bol } :: !lines;
+      bol := !cur
+    end
+  in
+  let rec loop () =
+    if !bol >= end_pos.pos_cnum then ()
+    else begin
+      match read_char () with
+      | None ->
+          (* end of input *)
+          add_line ()
+      | Some c ->
+          incr cur;
+          match c with
+          | '\r' -> loop ()
+          | '\n' -> add_line (); loop ()
+          | _ -> Buffer.add_char b c; loop ()
+    end
+  in
+  loop ();
+  List.rev !lines
+*)
+
+(*
+(* Try to get lines from a lexbuf *)
+let lines_around_from_lexbuf
+    ~(start_pos: position) ~(end_pos: position)
+    (lb: lexbuf):
+  input_line list
+  =
+  (* Converts a global position to one that is relative to the lexing buffer *)
+  let rel n = n - lb.lex_abs_pos in
+  if rel start_pos.pos_bol < 0 then begin
+    (* Do nothing if the buffer does not contain the input (because it has been
+       refilled while lexing it) *)
+    []
+  end else begin
+    let pos = ref 0 in (* relative position *)
+    let seek n = pos := rel n in
+    let read_char () =
+      if !pos >= lb.lex_buffer_len then (* end of buffer *) None
+      else
+        let c = Bytes.get lb.lex_buffer !pos in
+        incr pos; Some c
+    in
+    lines_around ~start_pos ~end_pos ~seek ~read_char
+  end
+*)
+
+(*
+(* Get lines from a file *)
+let lines_around_from_file
+    ~(start_pos: position) ~(end_pos: position)
+    (filename: string):
+  input_line list
+  =
+  try
+    let cin = open_in_bin filename in
+    let read_char () =
+      try Some (input_char cin) with End_of_file -> None
+    in
+    let lines =
+      lines_around ~start_pos ~end_pos ~seek:(seek_in cin) ~read_char
+    in
+    close_in cin;
+    lines
+  with Sys_error _ -> []
+*)
+
+(*
+(* A [get_lines] function for [highlight_quote] that reads from the current
+   input.
+
+   It first tries to read from [!input_lexbuf], then if that fails (because the
+   lexbuf no longer contains the input we want), it reads from [!input_name]
+   directly *)
+let lines_around_from_current_input ~start_pos ~end_pos =
+  (* Be a bit defensive, and do not try to open one of the possible
+     [!input_name] values that we know do not denote valid filenames. *)
+  let file_valid = function
+    | "//toplevel//" | "_none_" | "" -> false
+    | _ -> true
+  in
+  let from_file () =
+    if file_valid !input_name then
+      lines_around_from_file !input_name ~start_pos ~end_pos
+    else
+      []
+  in
+  match !input_lexbuf with
+  | Some lb ->
+      begin match lines_around_from_lexbuf lb ~start_pos ~end_pos with
+      | [] -> (* The input is likely not in the lexbuf anymore *)
+          from_file ()
+      | lines ->
+          lines
+      end
+  | None ->
+      from_file ()
+*)
+
+(******************************************************************************)
+(* Reporting errors and warnings *)
+
+type msg = (Format.formatter -> unit) loc
+
+let msg ?(loc = none) fmt =
+  Format.kdprintf (fun txt -> { loc; txt }) fmt
+
+type report_kind =
+  | Report_error
+  | Report_warning of string
+  | Report_warning_as_error of string
+  | Report_alert of string
+  | Report_alert_as_error of string
+
+type error_source = Lexer | Parser | Typer | Warning | Unknown | Env | Config
+
+type report = {
+  kind : report_kind;
+  main : msg;
+  sub : msg list;
+  source : error_source;
+}
+
+let loc_of_report { main; _ } = main.loc
+let print_msg fmt msg = msg.txt fmt
+let print_main fmt { main; _ } = print_msg fmt main
+let print_sub_msg = print_msg
+
+
+type report_printer = {
+  (* The entry point *)
+  pp : report_printer ->
+    Format.formatter -> report -> unit;
+
+  pp_report_kind : report_printer -> report ->
+    Format.formatter -> report_kind -> unit;
+  pp_main_loc : report_printer -> report ->
+    Format.formatter -> t -> unit;
+  pp_main_txt : report_printer -> report ->
+    Format.formatter -> (Format.formatter -> unit) -> unit;
+  pp_submsgs : report_printer -> report ->
+    Format.formatter -> msg list -> unit;
+  pp_submsg : report_printer -> report ->
+    Format.formatter -> msg -> unit;
+  pp_submsg_loc : report_printer -> report ->
+    Format.formatter -> t -> unit;
+  pp_submsg_txt : report_printer -> report ->
+    Format.formatter -> (Format.formatter -> unit) -> unit;
+}
+
+(*
+let is_dummy_loc loc =
+  (* Fixme: this should be just [loc.loc_ghost] and the function should be
+     inlined below. However, currently, the compiler emits in some places ghost
+     locations with valid ranges that should still be printed. These locations
+     should be made non-ghost -- in the meantime we just check if the ranges are
+     valid. *)
+  loc.loc_start.pos_cnum = -1 || loc.loc_end.pos_cnum = -1
+*)
+
+(* It only makes sense to highlight (i.e. quote or underline the corresponding
+   source code) locations that originate from the current input.
+
+   As of now, this should only happen in the following cases:
+
+   - if dummy locs or ghost locs leak out of the compiler or a buggy ppx;
+
+   - more generally, if some code uses the compiler-libs API and feeds it
+   locations that do not match the current values of [!Location.input_name],
+   [!Location.input_lexbuf];
+
+   - when calling the compiler on a .ml file that contains lexer line directives
+   indicating an other file. This should happen relatively rarely in practice --
+   in particular this is not what happens when using -pp or -ppx or a ppx
+   driver.
+*)
+                                 (*
+let is_quotable_loc loc =
+  not (is_dummy_loc loc)
+  && loc.loc_start.pos_fname = !input_name
+  && loc.loc_end.pos_fname = !input_name
+
+let error_style () =
+  let open Misc.Error_style in
+  match !Clflags.error_style with
+  | Some Contextual | None -> Contextual
+  | Some Short -> Short
+                                 *)
+
+let batch_mode_printer : report_printer =
+  let pp_loc _self _report _ppf _loc =
+    (*
+    let tag = match report.kind with
+      | Report_warning_as_error _
+      | Report_alert_as_error _
+      | Report_error -> "error"
+      | Report_warning _
+      | Report_alert _ -> "warning"
+    in
+    let highlight ppf loc =
+      match error_style () with
+      | Misc.Error_style.Contextual ->
+          if is_quotable_loc loc then
+            highlight_quote ppf
+              ~get_lines:lines_around_from_current_input
+              tag [loc]
+      | Misc.Error_style.Short ->
+          ()
+    in
+    Format.fprintf ppf "@[<v>%a:@ %a@]" print_loc loc highlight loc
+    *)
+    ()
+  in
+  let pp_txt ppf txt = Format.fprintf ppf "@[%t@]" txt in
+  let pp self ppf report =
+    (* Make sure we keep [num_loc_lines] updated.
+        The tabulation box is here to give submessage the option
+        to be aligned with the main message box
+    *)
+    print_updating_num_loc_lines ppf (fun ppf () ->
+      Format.fprintf ppf "@[<v>%a%a%a: %a%a%a%a@]@."
+      Format.pp_open_tbox ()
+      (self.pp_main_loc self report) report.main.loc
+      (self.pp_report_kind self report) report.kind
+      Format.pp_set_tab ()
+      (self.pp_main_txt self report) report.main.txt
+      (self.pp_submsgs self report) report.sub
+      Format.pp_close_tbox ()
+    ) ()
+  in
+  let pp_report_kind _self _ ppf = function
+    | Report_error -> Format.fprintf ppf "@{<error>Error@}"
+    | Report_warning w -> Format.fprintf ppf "@{<warning>Warning@} %s" w
+    | Report_warning_as_error w ->
+        Format.fprintf ppf "@{<error>Error@} (warning %s)" w
+    | Report_alert w -> Format.fprintf ppf "@{<warning>Alert@} %s" w
+    | Report_alert_as_error w ->
+        Format.fprintf ppf "@{<error>Error@} (alert %s)" w
+  in
+  let pp_main_loc self report ppf loc =
+    pp_loc self report ppf loc
+  in
+  let pp_main_txt _self _ ppf txt =
+    pp_txt ppf txt
+  in
+  let pp_submsgs self report ppf msgs =
+    List.iter (fun msg ->
+      Format.fprintf ppf "@,%a" (self.pp_submsg self report) msg
+    ) msgs
+  in
+  let pp_submsg self report ppf { loc; txt } =
+    Format.fprintf ppf "@[%a  %a@]"
+      (self.pp_submsg_loc self report) loc
+      (self.pp_submsg_txt self report) txt
+  in
+  let pp_submsg_loc self report ppf loc =
+    if not loc.loc_ghost then
+      pp_loc self report ppf loc
+  in
+  let pp_submsg_txt _self _ ppf loc =
+    pp_txt ppf loc
+  in
+  { pp; pp_report_kind; pp_main_loc; pp_main_txt;
+    pp_submsgs; pp_submsg; pp_submsg_loc; pp_submsg_txt }
+
+(* Creates a printer for the current input *)
+let default_report_printer () : report_printer =
+  batch_mode_printer
+
+let report_printer = ref default_report_printer
+
+let print_report ppf report =
+  let printer = !report_printer () in
+  printer.pp printer ppf report
+
+(******************************************************************************)
+(* Reporting errors *)
+
+type error = report
+
+let report_error ppf err =
+  print_report ppf err
+
+let mkerror loc sub txt source =
+  { kind = Report_error; main = { loc; txt }; sub; source }
+
+let errorf ?(loc = none) ?(sub = []) ?(source=Typer) =
+  Format.kdprintf (fun msg -> mkerror loc sub msg source)
+
+let error ?(loc = none) ?(sub = []) ?(source=Typer) msg_str =
+  mkerror loc sub (fun ppf -> Format.pp_print_string ppf msg_str) source
+
+let error_of_printer ?(loc = none) ?(sub = []) ?(source=Typer) pp x =
+  mkerror loc sub (fun ppf -> pp ppf x) source
+
+let error_of_printer_file ?source print x =
+  error_of_printer ?source ~loc:(in_file !input_name) print x
+
+(******************************************************************************)
+(* Reporting warnings: generating a report from a warning number using the
+   information in [Warnings] + convenience functions. *)
+
+let default_warning_alert_reporter ?(source = Typer) report mk (loc: t) w : report option =
+  match report w with
+  | `Inactive -> None
+  | `Active { Warnings.id; message; is_error; sub_locs } ->
+      let msg_of_str str = fun ppf -> Format.pp_print_string ppf str in
+      let kind = mk is_error id in
+      let main = { loc; txt = msg_of_str message } in
+      let sub = List.map (fun (loc, sub_message) ->
+        { loc; txt = msg_of_str sub_message }
+      ) sub_locs in
+      Some { kind; main; sub; source }
+
+
+let default_warning_reporter =
+  default_warning_alert_reporter
+    Warnings.report
+    (fun is_error id ->
+       if is_error then Report_warning_as_error id
+       else Report_warning id
+    )
+
+let warning_reporter = ref default_warning_reporter
+let report_warning loc w = !warning_reporter loc w
+
+let formatter_for_warnings = ref Format.err_formatter
+
+let print_warning loc ppf w =
+  match report_warning loc w with
+  | None -> ()
+  | Some report -> print_report ppf report
+
+let prerr_warning_ref =
+  ref (fun loc w -> print_warning loc !formatter_for_warnings w);;
+let prerr_warning loc w = !prerr_warning_ref loc w
+
+let default_alert_reporter =
+  default_warning_alert_reporter
+    Warnings.report_alert
+    (fun is_error id ->
+       if is_error then Report_alert_as_error id
+       else Report_alert id
+    )
+
+let alert_reporter = ref default_alert_reporter
+let report_alert loc w = !alert_reporter loc w
+
+let print_alert loc ppf w =
+  match report_alert loc w with
+  | None -> ()
+  | Some report -> print_report ppf report
+
+let prerr_alert_ref =
+  ref (fun loc w -> print_alert loc !formatter_for_warnings w)
+
+let prerr_alert loc w = !prerr_alert_ref loc w
+
+let alert ?(def = none) ?(use = none) ~kind loc message =
+  prerr_alert loc {Warnings.kind; message; def; use}
+
+let deprecated ?def ?use loc message =
+  alert ?def ?use ~kind:"deprecated" loc message
+
+(******************************************************************************)
+(* Reporting errors on exceptions *)
+
+let error_of_exn : (exn -> error option) list ref = ref []
+
+let register_error_of_exn f = error_of_exn := f :: !error_of_exn
+
+exception Already_displayed_error = Warnings.Errors
+
+let error_of_exn exn =
+  match exn with
+  | Already_displayed_error -> Some `Already_displayed
+  | _ ->
+     let rec loop = function
+       | [] -> None
+       | f :: rest ->
+          match f exn with
+          | Some error -> Some (`Ok error)
+          | None -> loop rest
+     in
+     loop !error_of_exn
+
+let () =
+  register_error_of_exn
+    (function
+      | Sys_error msg ->
+          Some (errorf ~loc:(in_file !input_name) "I/O error: %s" msg)
+      | _ -> None
+    )
+
+external reraise : exn -> 'a = "%reraise"
+
+let report_exception ppf exn =
+  let rec loop n exn =
+    match error_of_exn exn with
+    | None -> reraise exn
+    | Some `Already_displayed -> ()
+    | Some (`Ok err) -> report_error ppf err
+    | exception exn when n > 0 -> loop (n-1) exn
+  in
+  loop 5 exn
+
+exception Error of error
+
+let () =
+  register_error_of_exn
+    (function
+      | Error e -> Some e
+      | _ -> None
+    )
+
+let raise_errorf ?(loc = none) ?(sub = []) ?(source = Typer)=
+  Format.kdprintf (fun txt -> raise (Error (mkerror loc sub txt source)))
diff --git a/src/ocaml/parsing/location.mli b/src/ocaml/parsing/location.mli
new file mode 100644
index 0000000..63038ca
--- /dev/null
+++ b/src/ocaml/parsing/location.mli
@@ -0,0 +1,280 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Source code locations (ranges of positions), used in parsetree.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Format
+
+type t = Warnings.loc = {
+  loc_start: Lexing.position;
+  loc_end: Lexing.position;
+  loc_ghost: bool;
+}
+
+(** Note on the use of Lexing.position in this module.
+   If [pos_fname = ""], then use [!input_name] instead.
+   If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and
+     re-parse the file to get the line and character numbers.
+   Else all fields are correct.
+*)
+
+val none : t
+(** An arbitrary value of type [t]; describes an empty ghost range. *)
+
+val is_none : t -> bool
+
+val in_file : string -> t
+(** Return an empty ghost range located in a given file. *)
+
+val init : Lexing.lexbuf -> string -> unit
+(** Set the file name and line number of the [lexbuf] to be the start
+    of the named file. *)
+
+val curr : Lexing.lexbuf -> t
+(** Get the location of the current token from the [lexbuf]. *)
+
+val symbol_rloc: unit -> t
+val symbol_gloc: unit -> t
+
+(** [rhs_loc n] returns the location of the symbol at position [n], starting
+  at 1, in the current parser rule. *)
+val rhs_loc: int -> t
+
+val rhs_interval: int -> int -> t
+
+val get_pos_info: Lexing.position -> string * int * int
+(** file, line, char *)
+
+type 'a loc = {
+  txt : 'a;
+  loc : t;
+}
+
+val mknoloc : 'a -> 'a loc
+val mkloc : 'a -> t -> 'a loc
+
+
+(** {1 Input info} *)
+
+val input_name: string ref
+val input_lexbuf: Lexing.lexbuf option ref
+
+
+(** {1 Toplevel-specific functions} *)
+
+val echo_eof: unit -> unit
+val reset: unit -> unit
+
+
+(** {1 Printing locations} *)
+
+val rewrite_absolute_path: string -> string
+    (** rewrite absolute path to honor the BUILD_PATH_PREFIX_MAP
+        variable (https://reproducible-builds.org/specs/build-path-prefix-map/)
+        if it is set. *)
+
+val absolute_path: string -> string
+
+val show_filename: string -> string
+    (** In -absname mode, return the absolute path for this filename.
+        Otherwise, returns the filename unchanged. *)
+
+val print_filename: formatter -> string -> unit
+
+val print_loc: formatter -> t -> unit
+val print_locs: formatter -> t list -> unit
+
+
+
+(** {1 Reporting errors and warnings} *)
+
+(** {2 The type of reports and report printers} *)
+
+type msg = (Format.formatter -> unit) loc
+
+val msg: ?loc:t -> ('a, Format.formatter, unit, msg) format4 -> 'a
+
+type report_kind =
+  | Report_error
+  | Report_warning of string
+  | Report_warning_as_error of string
+  | Report_alert of string
+  | Report_alert_as_error of string
+
+type error_source = Lexer | Parser | Typer | Warning | Unknown | Env | Config
+
+type report = {
+  kind : report_kind;
+  main : msg;
+  sub : msg list;
+  source : error_source;
+}
+
+val loc_of_report: report -> t
+val print_main : formatter -> report -> unit
+val print_sub_msg : formatter -> msg -> unit
+
+type report_printer = {
+  (* The entry point *)
+  pp : report_printer ->
+    Format.formatter -> report -> unit;
+
+  pp_report_kind : report_printer -> report ->
+    Format.formatter -> report_kind -> unit;
+  pp_main_loc : report_printer -> report ->
+    Format.formatter -> t -> unit;
+  pp_main_txt : report_printer -> report ->
+    Format.formatter -> (Format.formatter -> unit) -> unit;
+  pp_submsgs : report_printer -> report ->
+    Format.formatter -> msg list -> unit;
+  pp_submsg : report_printer -> report ->
+    Format.formatter -> msg -> unit;
+  pp_submsg_loc : report_printer -> report ->
+    Format.formatter -> t -> unit;
+  pp_submsg_txt : report_printer -> report ->
+    Format.formatter -> (Format.formatter -> unit) -> unit;
+}
+(** A printer for [report]s, defined using open-recursion.
+    The goal is to make it easy to define new printers by re-using code from
+    existing ones.
+*)
+
+(** {2 Report printers used in the compiler} *)
+
+val batch_mode_printer: report_printer
+
+(** {2 Printing a [report]} *)
+
+val print_report: formatter -> report -> unit
+(** Display an error or warning report. *)
+
+val report_printer: (unit -> report_printer) ref
+(** Hook for redefining the printer of reports.
+
+    The hook is a [unit -> report_printer] and not simply a [report_printer]:
+    this is useful so that it can detect the type of the output (a file, a
+    terminal, ...) and select a printer accordingly. *)
+
+val default_report_printer: unit -> report_printer
+(** Original report printer for use in hooks. *)
+
+
+(** {1 Reporting warnings} *)
+
+(** {2 Converting a [Warnings.t] into a [report]} *)
+
+val report_warning: t -> Warnings.t -> report option
+(** [report_warning loc w] produces a report for the given warning [w], or
+   [None] if the warning is not to be printed. *)
+
+val warning_reporter: (t -> Warnings.t -> report option) ref
+(** Hook for intercepting warnings. *)
+
+val default_warning_reporter: t -> Warnings.t -> report option
+(** Original warning reporter for use in hooks. *)
+
+(** {2 Printing warnings} *)
+
+val formatter_for_warnings : formatter ref
+
+val print_warning: t -> formatter -> Warnings.t -> unit
+(** Prints a warning. This is simply the composition of [report_warning] and
+   [print_report]. *)
+
+val prerr_warning_ref: (t -> Warnings.t -> unit) ref
+
+val prerr_warning: t -> Warnings.t -> unit
+(** Same as [print_warning], but uses [!formatter_for_warnings] as output
+   formatter. *)
+
+(** {1 Reporting alerts} *)
+
+(** {2 Converting an [Alert.t] into a [report]} *)
+
+val report_alert: t -> Warnings.alert -> report option
+(** [report_alert loc w] produces a report for the given alert [w], or
+   [None] if the alert is not to be printed. *)
+
+val alert_reporter: (t -> Warnings.alert -> report option) ref
+(** Hook for intercepting alerts. *)
+
+val default_alert_reporter: t -> Warnings.alert -> report option
+(** Original alert reporter for use in hooks. *)
+
+(** {2 Printing alerts} *)
+
+val print_alert: t -> formatter -> Warnings.alert -> unit
+(** Prints an alert. This is simply the composition of [report_alert] and
+   [print_report]. *)
+
+val prerr_alert_ref: (t -> Warnings.alert -> unit) ref
+
+val prerr_alert: t -> Warnings.alert -> unit
+(** Same as [print_alert], but uses [!formatter_for_warnings] as output
+   formatter. *)
+
+val deprecated: ?def:t -> ?use:t -> t -> string -> unit
+(** Prints a deprecation alert. *)
+
+val alert: ?def:t -> ?use:t -> kind:string -> t -> string -> unit
+(** Prints an arbitrary alert. *)
+
+
+(** {1 Reporting errors} *)
+
+type error = report
+(** An [error] is a [report] which [report_kind] must be [Report_error]. *)
+
+val error: ?loc:t -> ?sub:msg list -> ?source:error_source -> string -> error
+
+val errorf: ?loc:t -> ?sub:msg list -> ?source:error_source ->
+  ('a, Format.formatter, unit, error) format4 -> 'a
+
+val error_of_printer: ?loc:t -> ?sub:msg list -> ?source:error_source ->
+  (formatter -> 'a -> unit) -> 'a -> error
+
+val error_of_printer_file: ?source:error_source -> (formatter -> 'a -> unit) -> 'a -> error
+
+
+(** {1 Automatically reporting errors for raised exceptions} *)
+
+val register_error_of_exn: (exn -> error option) -> unit
+(** Each compiler module which defines a custom type of exception
+    which can surface as a user-visible error should register
+    a "printer" for this exception using [register_error_of_exn].
+    The result of the printer is an [error] value containing
+    a location, a message, and optionally sub-messages (each of them
+    being located as well). *)
+
+val error_of_exn: exn -> [ `Ok of error | `Already_displayed ] option
+
+exception Error of error
+(** Raising [Error e] signals an error [e]; the exception will be caught and the
+   error will be printed. *)
+
+exception Already_displayed_error
+(** Raising [Already_displayed_error] signals an error which has already been
+   printed. The exception will be caught, but nothing will be printed *)
+
+val raise_errorf: ?loc:t -> ?sub:msg list -> ?source:error_source ->
+  ('a, Format.formatter, unit, 'b) format4 -> 'a
+
+val report_exception: formatter -> exn -> unit
+(** Reraise the exception if it is unknown. *)
diff --git a/src/ocaml/parsing/location_aux.ml b/src/ocaml/parsing/location_aux.ml
new file mode 100644
index 0000000..966ebdd
--- /dev/null
+++ b/src/ocaml/parsing/location_aux.ml
@@ -0,0 +1,94 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+
+type t
+  = Location.t
+  = { loc_start: Lexing.position; loc_end: Lexing.position; loc_ghost: bool }
+
+let compare (l1: t) (l2: t) =
+  match Lexing.compare_pos l1.loc_start l2.loc_start with
+  | (-1 | 1) as r -> r
+  | 0 -> Lexing.compare_pos l1.loc_end l2.loc_end
+  | _ -> assert false
+
+let compare_pos pos loc =
+  if Lexing.compare_pos pos loc.Location.loc_start < 0 then
+    -1
+  else if Lexing.compare_pos pos loc.Location.loc_end > 0 then
+    1
+  else
+    0
+
+let union l1 l2 =
+  if l1 = Location.none then l2
+  else if l2 = Location.none then l1
+  else {
+    Location.
+    loc_start = Lexing.min_pos l1.Location.loc_start l2.Location.loc_start;
+    loc_end   = Lexing.max_pos l1.Location.loc_end l2.Location.loc_end;
+    loc_ghost = l1.Location.loc_ghost && l2.Location.loc_ghost;
+  }
+
+let extend l1 l2 =
+  if l1 = Location.none then l2
+  else if l2 = Location.none then l1
+  else {
+    Location.
+    loc_start = Lexing.min_pos l1.Location.loc_start l2.Location.loc_start;
+    loc_end   = Lexing.max_pos l1.Location.loc_end l2.Location.loc_end;
+    loc_ghost = l1.Location.loc_ghost;
+  }
+
+(** Filter valid errors, log invalid ones *)
+let prepare_errors exns =
+  List.filter_map exns
+    ~f:(fun exn ->
+        match Location.error_of_exn exn with
+        | None ->
+          Logger.log ~section:"Mreader" ~title:"errors"
+            "Location.error_of_exn (%a) = None"
+            (fun () -> Printexc.to_string) exn;
+          None
+        | Some `Already_displayed ->  None
+        | Some (`Ok err) -> Some err
+      )
+
+let print () {Location. loc_start; loc_end; loc_ghost}  =
+  let l1, c1 = Lexing.split_pos loc_start in
+  let l2, c2 = Lexing.split_pos loc_end in
+  sprintf "%d:%d-%d:%d%s"
+    l1 c1 l2 c2 (if loc_ghost then "{ghost}" else "")
+
+let print_loc f () {Location. txt; loc} =
+  sprintf "%a@%a" f txt print loc
+
+let is_relaxed_location = function
+  | { Location. txt = "merlin.relaxed-location" | "merlin.loc"; _ } -> true
+  | _ -> false
diff --git a/src/ocaml/parsing/location_aux.mli b/src/ocaml/parsing/location_aux.mli
new file mode 100644
index 0000000..7d99d36
--- /dev/null
+++ b/src/ocaml/parsing/location_aux.mli
@@ -0,0 +1,53 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+type t
+  = Location.t
+  = { loc_start: Lexing.position; loc_end: Lexing.position; loc_ghost: bool }
+
+(** [compare l1 l2] compares start positions, if equal compares end positions *)
+val compare : t -> t -> int
+
+val compare_pos: Lexing.position -> t -> int
+
+(** Return the smallest location covered by both arguments,
+    ghost if both are ghosts *)
+val union : t -> t -> t
+
+(** Like location_union, but keep loc_ghost'ness of first argument *)
+val extend : t -> t -> t
+
+(** Filter valid errors, log invalid ones *)
+val prepare_errors : exn list -> Location.error list
+
+(** {1 Dump} *)
+
+val print : unit -> t -> string
+val print_loc : (unit -> 'a -> string) -> unit -> 'a Location.loc -> string
+
+val is_relaxed_location : string Location.loc -> bool
diff --git a/src/ocaml/parsing/longident.ml b/src/ocaml/parsing/longident.ml
new file mode 100644
index 0000000..837c6a9
--- /dev/null
+++ b/src/ocaml/parsing/longident.ml
@@ -0,0 +1,80 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t =
+    Lident of string
+  | Ldot of t * string
+  | Lapply of t * t
+
+let rec flat accu = function
+    Lident s -> s :: accu
+  | Ldot(lid, s) -> flat (s :: accu) lid
+  | Lapply(_, _) -> Misc.fatal_error "Longident.flat"
+
+let flatten lid = flat [] lid
+
+let rec head = function
+    Lident s -> s
+  | Ldot(lid, _) -> head lid
+  | Lapply(_, _) -> assert false
+
+let last = function
+    Lident s -> s
+  | Ldot(_, s) -> s
+  | Lapply(_, _) -> Misc.fatal_error "Longident.last"
+
+
+let rec split_at_dots s pos =
+  try
+    let dot = String.index_from s pos '.' in
+    String.sub s pos (dot - pos) :: split_at_dots s (dot + 1)
+  with Not_found ->
+    [String.sub s pos (String.length s - pos)]
+
+let unflatten l =
+  match l with
+  | [] -> None
+  | hd :: tl -> Some (List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl)
+
+let parse s =
+  match unflatten (split_at_dots s 0) with
+  | None -> Lident ""  (* should not happen, but don't put assert false
+                          so as not to crash the toplevel (see Genprintval) *)
+  | Some v -> v
+
+let keep_suffix =
+  let rec aux = function
+    | Lident str ->
+      if String.uncapitalize_ascii str <> str then
+        Some (Lident str, false)
+      else
+        None
+    | Ldot (t, str) ->
+      if String.uncapitalize_ascii str <> str then
+        match aux t with
+        | None -> Some (Lident str, true)
+        | Some (t, is_label) -> Some (Ldot (t, str), is_label)
+      else
+        None
+    | t -> Some (t, false) (* Can be improved... *)
+  in
+  function
+  | Lident s -> Lident s, false
+  | Ldot (t, s) ->
+    begin match aux t with
+    | None -> Lident s, true
+    | Some (t, is_label) -> Ldot (t, s), is_label
+    end
+  | otherwise -> otherwise, false
diff --git a/src/ocaml/parsing/longident.mli b/src/ocaml/parsing/longident.mli
new file mode 100644
index 0000000..72c5964
--- /dev/null
+++ b/src/ocaml/parsing/longident.mli
@@ -0,0 +1,74 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Long identifiers, used in parsetree.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+  To print a longident, see {!Pprintast.longident}, using
+    {!Format.asprintf} to convert to a string.
+
+*)
+
+type t =
+    Lident of string
+  | Ldot of t * string
+  | Lapply of t * t
+
+val flatten: t -> string list
+val unflatten: string list -> t option
+(** For a non-empty list [l], [unflatten l] is [Some lid] where [lid] is
+    the long identifier created by concatenating the elements of [l]
+    with [Ldot].
+    [unflatten []] is [None].
+*)
+
+(** [head lid] returns the leftmost part of [lid], e.g., 
+    given [String.Map.empty], returns [String].
+    
+    @raise Assert_failure if encounters [Lapply] *)
+val head: t -> string
+val last: t -> string
+val parse: string -> t
+  (* (* disabled in merlin. *)
+[@@deprecated "this function may misparse its input,\n\
+use \"Parse.longident\" or \"Longident.unflatten\""]
+     *)
+(**
+
+   This function is broken on identifiers that are not just "Word.Word.word";
+   for example, it returns incorrect results on infix operators
+   and extended module paths.
+
+   If you want to generate long identifiers that are a list of
+   dot-separated identifiers, the function {!unflatten} is safer and faster.
+   {!unflatten} is available since OCaml 4.06.0.
+
+   If you want to parse any identifier correctly, use the long-identifiers
+   functions from the {!Parse} module, in particular {!Parse.longident}.
+   They are available since OCaml 4.11, and also provide proper
+   input-location support.
+
+*)
+
+(* Merlin specific. *)
+
+val keep_suffix : t -> t * bool
+(** if [li', b = keep_suffix li] then:
+    - the prefix of [li'] is a module path
+    - [b = false] iff [li' = li].
+    Corollary: [b = true] if [li] is a label access
+               (i.e. [li = X.Y.z.Foo.Bar...]) *)
diff --git a/src/ocaml/parsing/msupport_parsing.ml b/src/ocaml/parsing/msupport_parsing.ml
new file mode 100644
index 0000000..567e5e2
--- /dev/null
+++ b/src/ocaml/parsing/msupport_parsing.ml
@@ -0,0 +1,6 @@
+(* Filled in from Msupport. *)
+let msupport_raise_error : (exn -> unit) ref =
+  ref raise
+
+let raise_error exn =
+  !msupport_raise_error exn
diff --git a/src/ocaml/parsing/parsetree.mli b/src/ocaml/parsing/parsetree.mli
new file mode 100644
index 0000000..2359b4b
--- /dev/null
+++ b/src/ocaml/parsing/parsetree.mli
@@ -0,0 +1,977 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Abstract syntax tree produced by parsing
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Asttypes
+
+type constant =
+    Pconst_integer of string * char option
+  (* 3 3l 3L 3n
+
+     Suffixes [g-z][G-Z] are accepted by the parser.
+     Suffixes except 'l', 'L' and 'n' are rejected by the typechecker
+  *)
+  | Pconst_char of char
+  (* 'c' *)
+  | Pconst_string of string * Location.t * string option
+  (* "constant"
+     {delim|other constant|delim}
+
+     The location span the content of the string, without the delimiters.
+  *)
+  | Pconst_float of string * char option
+  (* 3.4 2e5 1.4e-4
+
+     Suffixes [g-z][G-Z] are accepted by the parser.
+     Suffixes are rejected by the typechecker.
+  *)
+
+type location_stack = Location.t list
+
+(** {1 Extension points} *)
+
+type attribute = {
+    attr_name : string loc;
+    attr_payload : payload;
+    attr_loc : Location.t;
+  }
+       (* [@id ARG]
+          [@@id ARG]
+
+          Metadata containers passed around within the AST.
+          The compiler ignores unknown attributes.
+       *)
+
+and extension = string loc * payload
+      (* [%id ARG]
+         [%%id ARG]
+
+         Sub-language placeholder -- rejected by the typechecker.
+      *)
+
+and attributes = attribute list
+
+and payload =
+  | PStr of structure
+  | PSig of signature (* : SIG *)
+  | PTyp of core_type  (* : T *)
+  | PPat of pattern * expression option  (* ? P  or  ? P when E *)
+
+(** {1 Core language} *)
+
+(* Type expressions *)
+
+and core_type =
+    {
+     ptyp_desc: core_type_desc;
+     ptyp_loc: Location.t;
+     ptyp_loc_stack: location_stack;
+     ptyp_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and core_type_desc =
+  | Ptyp_any
+        (*  _ *)
+  | Ptyp_var of string
+        (* 'a *)
+  | Ptyp_arrow of arg_label * core_type * core_type
+        (* T1 -> T2       Simple
+           ~l:T1 -> T2    Labelled
+           ?l:T1 -> T2    Optional
+         *)
+  | Ptyp_tuple of core_type list
+        (* T1 * ... * Tn
+
+           Invariant: n >= 2
+        *)
+  | Ptyp_constr of Longident.t loc * core_type list
+        (* tconstr
+           T tconstr
+           (T1, ..., Tn) tconstr
+         *)
+  | Ptyp_object of object_field list * closed_flag
+        (* < l1:T1; ...; ln:Tn >     (flag = Closed)
+           < l1:T1; ...; ln:Tn; .. > (flag = Open)
+         *)
+  | Ptyp_class of Longident.t loc * core_type list
+        (* #tconstr
+           T #tconstr
+           (T1, ..., Tn) #tconstr
+         *)
+  | Ptyp_alias of core_type * string
+        (* T as 'a *)
+  | Ptyp_variant of row_field list * closed_flag * label list option
+        (* [ `A|`B ]         (flag = Closed; labels = None)
+           [> `A|`B ]        (flag = Open;   labels = None)
+           [< `A|`B ]        (flag = Closed; labels = Some [])
+           [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"])
+         *)
+  | Ptyp_poly of string loc list * core_type
+        (* 'a1 ... 'an. T
+
+           Can only appear in the following context:
+
+           - As the core_type of a Ppat_constraint node corresponding
+             to a constraint on a let-binding: let x : 'a1 ... 'an. T
+             = e ...
+
+           - Under Cfk_virtual for methods (not values).
+
+           - As the core_type of a Pctf_method node.
+
+           - As the core_type of a Pexp_poly node.
+
+           - As the pld_type field of a label_declaration.
+
+           - As a core_type of a Ptyp_object node.
+         *)
+
+  | Ptyp_package of package_type
+        (* (module S) *)
+  | Ptyp_extension of extension
+        (* [%id] *)
+
+and package_type = Longident.t loc * (Longident.t loc * core_type) list
+      (*
+        (module S)
+        (module S with type t1 = T1 and ... and tn = Tn)
+       *)
+
+and row_field = {
+  prf_desc : row_field_desc;
+  prf_loc : Location.t;
+  prf_attributes : attributes;
+}
+
+and row_field_desc =
+  | Rtag of label loc * bool * core_type list
+        (* [`A]                   ( true,  [] )
+           [`A of T]              ( false, [T] )
+           [`A of T1 & .. & Tn]   ( false, [T1;...Tn] )
+           [`A of & T1 & .. & Tn] ( true,  [T1;...Tn] )
+
+          - The 'bool' field is true if the tag contains a
+            constant (empty) constructor.
+          - '&' occurs when several types are used for the same constructor
+            (see 4.2 in the manual)
+        *)
+  | Rinherit of core_type
+        (* [ | T ] *)
+
+and object_field = {
+  pof_desc : object_field_desc;
+  pof_loc : Location.t;
+  pof_attributes : attributes;
+}
+
+and object_field_desc =
+  | Otag of label loc * core_type
+  | Oinherit of core_type
+
+(* Patterns *)
+
+and pattern =
+    {
+     ppat_desc: pattern_desc;
+     ppat_loc: Location.t;
+     ppat_loc_stack: location_stack;
+     ppat_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and pattern_desc =
+  | Ppat_any
+        (* _ *)
+  | Ppat_var of string loc
+        (* x *)
+  | Ppat_alias of pattern * string loc
+        (* P as 'a *)
+  | Ppat_constant of constant
+        (* 1, 'a', "true", 1.0, 1l, 1L, 1n *)
+  | Ppat_interval of constant * constant
+        (* 'a'..'z'
+
+           Other forms of interval are recognized by the parser
+           but rejected by the type-checker. *)
+  | Ppat_tuple of pattern list
+        (* (P1, ..., Pn)
+
+           Invariant: n >= 2
+        *)
+  | Ppat_construct of
+      Longident.t loc * (string loc list * pattern) option
+        (* C                    None
+           C P                  Some ([], P)
+           C (P1, ..., Pn)      Some ([], Ppat_tuple [P1; ...; Pn])
+           C (type a b) P       Some ([a; b], P)
+         *)
+  | Ppat_variant of label * pattern option
+        (* `A             (None)
+           `A P           (Some P)
+         *)
+  | Ppat_record of (Longident.t loc * pattern) list * closed_flag
+        (* { l1=P1; ...; ln=Pn }     (flag = Closed)
+           { l1=P1; ...; ln=Pn; _}   (flag = Open)
+
+           Invariant: n > 0
+         *)
+  | Ppat_array of pattern list
+        (* [| P1; ...; Pn |] *)
+  | Ppat_or of pattern * pattern
+        (* P1 | P2 *)
+  | Ppat_constraint of pattern * core_type
+        (* (P : T) *)
+  | Ppat_type of Longident.t loc
+        (* #tconst *)
+  | Ppat_lazy of pattern
+        (* lazy P *)
+  | Ppat_unpack of string option loc
+        (* (module P)        Some "P"
+           (module _)        None
+
+           Note: (module P : S) is represented as
+           Ppat_constraint(Ppat_unpack, Ptyp_package)
+         *)
+  | Ppat_exception of pattern
+        (* exception P *)
+  | Ppat_extension of extension
+        (* [%id] *)
+  | Ppat_open of Longident.t loc * pattern
+        (* M.(P) *)
+
+(* Value expressions *)
+
+and expression =
+    {
+     pexp_desc: expression_desc;
+     pexp_loc: Location.t;
+     pexp_loc_stack: location_stack;
+     pexp_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and expression_desc =
+  | Pexp_ident of Longident.t loc
+        (* x
+           M.x
+         *)
+  | Pexp_constant of constant
+        (* 1, 'a', "true", 1.0, 1l, 1L, 1n *)
+  | Pexp_let of rec_flag * value_binding list * expression
+        (* let P1 = E1 and ... and Pn = EN in E       (flag = Nonrecursive)
+           let rec P1 = E1 and ... and Pn = EN in E   (flag = Recursive)
+         *)
+  | Pexp_function of case list
+        (* function P1 -> E1 | ... | Pn -> En *)
+  | Pexp_fun of arg_label * expression option * pattern * expression
+        (* fun P -> E1                          (Simple, None)
+           fun ~l:P -> E1                       (Labelled l, None)
+           fun ?l:P -> E1                       (Optional l, None)
+           fun ?l:(P = E0) -> E1                (Optional l, Some E0)
+
+           Notes:
+           - If E0 is provided, only Optional is allowed.
+           - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun.
+           - "let f P = E" is represented using Pexp_fun.
+         *)
+  | Pexp_apply of expression * (arg_label * expression) list
+        (* E0 ~l1:E1 ... ~ln:En
+           li can be empty (non labeled argument) or start with '?'
+           (optional argument).
+
+           Invariant: n > 0
+         *)
+  | Pexp_match of expression * case list
+        (* match E0 with P1 -> E1 | ... | Pn -> En *)
+  | Pexp_try of expression * case list
+        (* try E0 with P1 -> E1 | ... | Pn -> En *)
+  | Pexp_tuple of expression list
+        (* (E1, ..., En)
+
+           Invariant: n >= 2
+        *)
+  | Pexp_construct of Longident.t loc * expression option
+        (* C                None
+           C E              Some E
+           C (E1, ..., En)  Some (Pexp_tuple[E1;...;En])
+        *)
+  | Pexp_variant of label * expression option
+        (* `A             (None)
+           `A E           (Some E)
+         *)
+  | Pexp_record of (Longident.t loc * expression) list * expression option
+        (* { l1=P1; ...; ln=Pn }     (None)
+           { E0 with l1=P1; ...; ln=Pn }   (Some E0)
+
+           Invariant: n > 0
+         *)
+  | Pexp_field of expression * Longident.t loc
+        (* E.l *)
+  | Pexp_setfield of expression * Longident.t loc * expression
+        (* E1.l <- E2 *)
+  | Pexp_array of expression list
+        (* [| E1; ...; En |] *)
+  | Pexp_ifthenelse of expression * expression * expression option
+        (* if E1 then E2 else E3 *)
+  | Pexp_sequence of expression * expression
+        (* E1; E2 *)
+  | Pexp_while of expression * expression
+        (* while E1 do E2 done *)
+  | Pexp_for of
+      pattern *  expression * expression * direction_flag * expression
+        (* for i = E1 to E2 do E3 done      (flag = Upto)
+           for i = E1 downto E2 do E3 done  (flag = Downto)
+         *)
+  | Pexp_constraint of expression * core_type
+        (* (E : T) *)
+  | Pexp_coerce of expression * core_type option * core_type
+        (* (E :> T)        (None, T)
+           (E : T0 :> T)   (Some T0, T)
+         *)
+  | Pexp_send of expression * label loc
+        (*  E # m *)
+  | Pexp_new of Longident.t loc
+        (* new M.c *)
+  | Pexp_setinstvar of label loc * expression
+        (* x <- 2 *)
+  | Pexp_override of (label loc * expression) list
+        (* {< x1 = E1; ...; Xn = En >} *)
+  | Pexp_letmodule of string option loc * module_expr * expression
+        (* let module M = ME in E *)
+  | Pexp_letexception of extension_constructor * expression
+        (* let exception C in E *)
+  | Pexp_assert of expression
+        (* assert E
+           Note: "assert false" is treated in a special way by the
+           type-checker. *)
+  | Pexp_lazy of expression
+        (* lazy E *)
+  | Pexp_poly of expression * core_type option
+        (* Used for method bodies.
+
+           Can only be used as the expression under Cfk_concrete
+           for methods (not values). *)
+  | Pexp_object of class_structure
+        (* object ... end *)
+  | Pexp_newtype of string loc * expression
+        (* fun (type t) -> E *)
+  | Pexp_pack of module_expr
+        (* (module ME)
+
+           (module ME : S) is represented as
+           Pexp_constraint(Pexp_pack, Ptyp_package S) *)
+  | Pexp_open of open_declaration * expression
+        (* M.(E)
+           let open M in E
+           let! open M in E *)
+  | Pexp_letop of letop
+        (* let* P = E in E
+           let* P = E and* P = E in E *)
+  | Pexp_extension of extension
+        (* [%id] *)
+  | Pexp_unreachable
+
+and case =   (* (P -> E) or (P when E0 -> E) *)
+    {
+     pc_lhs: pattern;
+     pc_guard: expression option;
+     pc_rhs: expression;
+   }
+
+and letop =
+  {
+    let_ : binding_op;
+    ands : binding_op list;
+    body : expression;
+  }
+
+and binding_op =
+  {
+    pbop_op : string loc;
+    pbop_pat : pattern;
+    pbop_exp : expression;
+    pbop_loc : Location.t;
+  }
+
+(* Value descriptions *)
+
+and value_description =
+    {
+     pval_name: string loc;
+     pval_type: core_type;
+     pval_prim: string list;
+     pval_attributes: attributes;  (* ... [@@id1] [@@id2] *)
+     pval_loc: Location.t;
+    }
+
+(*
+  val x: T                            (prim = [])
+  external x: T = "s1" ... "sn"       (prim = ["s1";..."sn"])
+*)
+
+(* Type declarations *)
+
+and type_declaration =
+    {
+     ptype_name: string loc;
+     ptype_params: (core_type * (variance * injectivity)) list;
+           (* ('a1,...'an) t; None represents  _*)
+     ptype_cstrs: (core_type * core_type * Location.t) list;
+           (* ... constraint T1=T1'  ... constraint Tn=Tn' *)
+     ptype_kind: type_kind;
+     ptype_private: private_flag;   (* = private ... *)
+     ptype_manifest: core_type option;  (* = T *)
+     ptype_attributes: attributes;   (* ... [@@id1] [@@id2] *)
+     ptype_loc: Location.t;
+    }
+
+(*
+  type t                     (abstract, no manifest)
+  type t = T0                (abstract, manifest=T0)
+  type t = C of T | ...      (variant,  no manifest)
+  type t = T0 = C of T | ... (variant,  manifest=T0)
+  type t = {l: T; ...}       (record,   no manifest)
+  type t = T0 = {l : T; ...} (record,   manifest=T0)
+  type t = ..                (open,     no manifest)
+*)
+
+and type_kind =
+  | Ptype_abstract
+  | Ptype_variant of constructor_declaration list
+  | Ptype_record of label_declaration list
+        (* Invariant: non-empty list *)
+  | Ptype_open
+
+and label_declaration =
+    {
+     pld_name: string loc;
+     pld_mutable: mutable_flag;
+     pld_type: core_type;
+     pld_loc: Location.t;
+     pld_attributes: attributes; (* l : T [@id1] [@id2] *)
+    }
+
+(*  { ...; l: T; ... }            (mutable=Immutable)
+    { ...; mutable l: T; ... }    (mutable=Mutable)
+
+    Note: T can be a Ptyp_poly.
+*)
+
+and constructor_declaration =
+    {
+     pcd_name: string loc;
+     pcd_args: constructor_arguments;
+     pcd_res: core_type option;
+     pcd_loc: Location.t;
+     pcd_attributes: attributes; (* C of ... [@id1] [@id2] *)
+    }
+
+and constructor_arguments =
+  | Pcstr_tuple of core_type list
+  | Pcstr_record of label_declaration list
+
+(*
+  | C of T1 * ... * Tn     (res = None,    args = Pcstr_tuple [])
+  | C: T0                  (res = Some T0, args = [])
+  | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple)
+  | C of {...}             (res = None,    args = Pcstr_record)
+  | C: {...} -> T0         (res = Some T0, args = Pcstr_record)
+  | C of {...} as t        (res = None,    args = Pcstr_record)
+*)
+
+and type_extension =
+    {
+     ptyext_path: Longident.t loc;
+     ptyext_params: (core_type * (variance * injectivity)) list;
+     ptyext_constructors: extension_constructor list;
+     ptyext_private: private_flag;
+     ptyext_loc: Location.t;
+     ptyext_attributes: attributes;   (* ... [@@id1] [@@id2] *)
+    }
+(*
+  type t += ...
+*)
+
+and extension_constructor =
+    {
+     pext_name: string loc;
+     pext_kind : extension_constructor_kind;
+     pext_loc : Location.t;
+     pext_attributes: attributes; (* C of ... [@id1] [@id2] *)
+   }
+
+(* exception E *)
+and type_exception =
+  {
+    ptyexn_constructor: extension_constructor;
+    ptyexn_loc: Location.t;
+    ptyexn_attributes: attributes; (* ... [@@id1] [@@id2] *)
+  }
+
+and extension_constructor_kind =
+    Pext_decl of constructor_arguments * core_type option
+      (*
+         | C of T1 * ... * Tn     ([T1; ...; Tn], None)
+         | C: T0                  ([], Some T0)
+         | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0)
+       *)
+  | Pext_rebind of Longident.t loc
+      (*
+         | C = D
+       *)
+
+(** {1 Class language} *)
+
+(* Type expressions for the class language *)
+
+and class_type =
+    {
+     pcty_desc: class_type_desc;
+     pcty_loc: Location.t;
+     pcty_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and class_type_desc =
+  | Pcty_constr of Longident.t loc * core_type list
+        (* c
+           ['a1, ..., 'an] c *)
+  | Pcty_signature of class_signature
+        (* object ... end *)
+  | Pcty_arrow of arg_label * core_type * class_type
+        (* T -> CT       Simple
+           ~l:T -> CT    Labelled l
+           ?l:T -> CT    Optional l
+         *)
+  | Pcty_extension of extension
+        (* [%id] *)
+  | Pcty_open of open_description * class_type
+        (* let open M in CT *)
+
+and class_signature =
+    {
+     pcsig_self: core_type;
+     pcsig_fields: class_type_field list;
+    }
+(* object('selfpat) ... end
+   object ... end             (self = Ptyp_any)
+ *)
+
+and class_type_field =
+    {
+     pctf_desc: class_type_field_desc;
+     pctf_loc: Location.t;
+     pctf_attributes: attributes; (* ... [@@id1] [@@id2] *)
+    }
+
+and class_type_field_desc =
+  | Pctf_inherit of class_type
+        (* inherit CT *)
+  | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type)
+        (* val x: T *)
+  | Pctf_method  of (label loc * private_flag * virtual_flag * core_type)
+        (* method x: T
+
+           Note: T can be a Ptyp_poly.
+         *)
+  | Pctf_constraint  of (core_type * core_type)
+        (* constraint T1 = T2 *)
+  | Pctf_attribute of attribute
+        (* [@@@id] *)
+  | Pctf_extension of extension
+        (* [%%id] *)
+
+and 'a class_infos =
+    {
+     pci_virt: virtual_flag;
+     pci_params: (core_type * (variance * injectivity)) list;
+     pci_name: string loc;
+     pci_expr: 'a;
+     pci_loc: Location.t;
+     pci_attributes: attributes;  (* ... [@@id1] [@@id2] *)
+    }
+(* class c = ...
+   class ['a1,...,'an] c = ...
+   class virtual c = ...
+
+   Also used for "class type" declaration.
+*)
+
+and class_description = class_type class_infos
+
+and class_type_declaration = class_type class_infos
+
+(* Value expressions for the class language *)
+
+and class_expr =
+    {
+     pcl_desc: class_expr_desc;
+     pcl_loc: Location.t;
+     pcl_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and class_expr_desc =
+  | Pcl_constr of Longident.t loc * core_type list
+        (* c
+           ['a1, ..., 'an] c *)
+  | Pcl_structure of class_structure
+        (* object ... end *)
+  | Pcl_fun of arg_label * expression option * pattern * class_expr
+        (* fun P -> CE                          (Simple, None)
+           fun ~l:P -> CE                       (Labelled l, None)
+           fun ?l:P -> CE                       (Optional l, None)
+           fun ?l:(P = E0) -> CE                (Optional l, Some E0)
+         *)
+  | Pcl_apply of class_expr * (arg_label * expression) list
+        (* CE ~l1:E1 ... ~ln:En
+           li can be empty (non labeled argument) or start with '?'
+           (optional argument).
+
+           Invariant: n > 0
+         *)
+  | Pcl_let of rec_flag * value_binding list * class_expr
+        (* let P1 = E1 and ... and Pn = EN in CE      (flag = Nonrecursive)
+           let rec P1 = E1 and ... and Pn = EN in CE  (flag = Recursive)
+         *)
+  | Pcl_constraint of class_expr * class_type
+        (* (CE : CT) *)
+  | Pcl_extension of extension
+  (* [%id] *)
+  | Pcl_open of open_description * class_expr
+  (* let open M in CE *)
+
+
+and class_structure =
+    {
+     pcstr_self: pattern;
+     pcstr_fields: class_field list;
+    }
+(* object(selfpat) ... end
+   object ... end           (self = Ppat_any)
+ *)
+
+and class_field =
+    {
+     pcf_desc: class_field_desc;
+     pcf_loc: Location.t;
+     pcf_attributes: attributes; (* ... [@@id1] [@@id2] *)
+    }
+
+and class_field_desc =
+  | Pcf_inherit of override_flag * class_expr * string loc option
+        (* inherit CE
+           inherit CE as x
+           inherit! CE
+           inherit! CE as x
+         *)
+  | Pcf_val of (label loc * mutable_flag * class_field_kind)
+        (* val x = E
+           val virtual x: T
+         *)
+  | Pcf_method of (label loc * private_flag * class_field_kind)
+        (* method x = E            (E can be a Pexp_poly)
+           method virtual x: T     (T can be a Ptyp_poly)
+         *)
+  | Pcf_constraint of (core_type * core_type)
+        (* constraint T1 = T2 *)
+  | Pcf_initializer of expression
+        (* initializer E *)
+  | Pcf_attribute of attribute
+        (* [@@@id] *)
+  | Pcf_extension of extension
+        (* [%%id] *)
+
+and class_field_kind =
+  | Cfk_virtual of core_type
+  | Cfk_concrete of override_flag * expression
+
+and class_declaration = class_expr class_infos
+
+(** {1 Module language} *)
+
+(* Type expressions for the module language *)
+
+and module_type =
+    {
+     pmty_desc: module_type_desc;
+     pmty_loc: Location.t;
+     pmty_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and module_type_desc =
+  | Pmty_ident of Longident.t loc
+        (* S *)
+  | Pmty_signature of signature
+        (* sig ... end *)
+  | Pmty_functor of functor_parameter * module_type
+        (* functor(X : MT1) -> MT2 *)
+  | Pmty_with of module_type * with_constraint list
+        (* MT with ... *)
+  | Pmty_typeof of module_expr
+        (* module type of ME *)
+  | Pmty_extension of extension
+        (* [%id] *)
+  | Pmty_alias of Longident.t loc
+        (* (module M) *)
+
+and functor_parameter =
+  | Unit
+        (* () *)
+  | Named of string option loc * module_type
+        (* (X : MT)          Some X, MT
+           (_ : MT)          None, MT *)
+
+and signature = signature_item list
+
+and signature_item =
+    {
+     psig_desc: signature_item_desc;
+     psig_loc: Location.t;
+    }
+
+and signature_item_desc =
+  | Psig_value of value_description
+        (*
+          val x: T
+          external x: T = "s1" ... "sn"
+         *)
+  | Psig_type of rec_flag * type_declaration list
+        (* type t1 = ... and ... and tn  = ... *)
+  | Psig_typesubst of type_declaration list
+        (* type t1 := ... and ... and tn := ...  *)
+  | Psig_typext of type_extension
+        (* type t1 += ... *)
+  | Psig_exception of type_exception
+        (* exception C of T *)
+  | Psig_module of module_declaration
+        (* module X = M
+           module X : MT *)
+  | Psig_modsubst of module_substitution
+        (* module X := M *)
+  | Psig_recmodule of module_declaration list
+        (* module rec X1 : MT1 and ... and Xn : MTn *)
+  | Psig_modtype of module_type_declaration
+        (* module type S = MT
+           module type S *)
+  | Psig_modtypesubst of module_type_declaration
+        (* module type S :=  ...  *)
+  | Psig_open of open_description
+        (* open X *)
+  | Psig_include of include_description
+        (* include MT *)
+  | Psig_class of class_description list
+        (* class c1 : ... and ... and cn : ... *)
+  | Psig_class_type of class_type_declaration list
+        (* class type ct1 = ... and ... and ctn = ... *)
+  | Psig_attribute of attribute
+        (* [@@@id] *)
+  | Psig_extension of extension * attributes
+        (* [%%id] *)
+
+and module_declaration =
+    {
+     pmd_name: string option loc;
+     pmd_type: module_type;
+     pmd_attributes: attributes; (* ... [@@id1] [@@id2] *)
+     pmd_loc: Location.t;
+    }
+(* S : MT *)
+
+and module_substitution =
+    {
+     pms_name: string loc;
+     pms_manifest: Longident.t loc;
+     pms_attributes: attributes; (* ... [@@id1] [@@id2] *)
+     pms_loc: Location.t;
+    }
+
+and module_type_declaration =
+    {
+     pmtd_name: string loc;
+     pmtd_type: module_type option;
+     pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *)
+     pmtd_loc: Location.t;
+    }
+(* S = MT
+   S       (abstract module type declaration, pmtd_type = None)
+*)
+
+and 'a open_infos =
+    {
+     popen_expr: 'a;
+     popen_override: override_flag;
+     popen_loc: Location.t;
+     popen_attributes: attributes;
+    }
+(* open! X - popen_override = Override (silences the 'used identifier
+                              shadowing' warning)
+   open  X - popen_override = Fresh
+ *)
+
+and open_description = Longident.t loc open_infos
+(* open M.N
+   open M(N).O *)
+
+and open_declaration = module_expr open_infos
+(* open M.N
+   open M(N).O
+   open struct ... end *)
+
+and 'a include_infos =
+    {
+     pincl_mod: 'a;
+     pincl_loc: Location.t;
+     pincl_attributes: attributes;
+    }
+
+and include_description = module_type include_infos
+(* include MT *)
+
+and include_declaration = module_expr include_infos
+(* include ME *)
+
+and with_constraint =
+  | Pwith_type of Longident.t loc * type_declaration
+        (* with type X.t = ...
+
+           Note: the last component of the longident must match
+           the name of the type_declaration. *)
+  | Pwith_module of Longident.t loc * Longident.t loc
+        (* with module X.Y = Z *)
+  | Pwith_modtype of Longident.t loc * module_type
+        (* with module type X.Y = Z *)
+  | Pwith_modtypesubst of Longident.t loc * module_type
+        (* with module type X.Y := sig end *)
+  | Pwith_typesubst of Longident.t loc * type_declaration
+        (* with type X.t := ..., same format as [Pwith_type] *)
+  | Pwith_modsubst of Longident.t loc * Longident.t loc
+        (* with module X.Y := Z *)
+
+(* Value expressions for the module language *)
+
+and module_expr =
+    {
+     pmod_desc: module_expr_desc;
+     pmod_loc: Location.t;
+     pmod_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and module_expr_desc =
+  | Pmod_ident of Longident.t loc
+        (* X *)
+  | Pmod_structure of structure
+        (* struct ... end *)
+  | Pmod_functor of functor_parameter * module_expr
+        (* functor(X : MT1) -> ME *)
+  | Pmod_apply of module_expr * module_expr
+        (* ME1(ME2) *)
+  | Pmod_constraint of module_expr * module_type
+        (* (ME : MT) *)
+  | Pmod_unpack of expression
+        (* (val E) *)
+  | Pmod_extension of extension
+        (* [%id] *)
+
+and structure = structure_item list
+
+and structure_item =
+    {
+     pstr_desc: structure_item_desc;
+     pstr_loc: Location.t;
+    }
+
+and structure_item_desc =
+  | Pstr_eval of expression * attributes
+        (* E *)
+  | Pstr_value of rec_flag * value_binding list
+        (* let P1 = E1 and ... and Pn = EN       (flag = Nonrecursive)
+           let rec P1 = E1 and ... and Pn = EN   (flag = Recursive)
+         *)
+  | Pstr_primitive of value_description
+        (*  val x: T
+            external x: T = "s1" ... "sn" *)
+  | Pstr_type of rec_flag * type_declaration list
+        (* type t1 = ... and ... and tn = ... *)
+  | Pstr_typext of type_extension
+        (* type t1 += ... *)
+  | Pstr_exception of type_exception
+        (* exception C of T
+           exception C = M.X *)
+  | Pstr_module of module_binding
+        (* module X = ME *)
+  | Pstr_recmodule of module_binding list
+        (* module rec X1 = ME1 and ... and Xn = MEn *)
+  | Pstr_modtype of module_type_declaration
+        (* module type S = MT *)
+  | Pstr_open of open_declaration
+        (* open X *)
+  | Pstr_class of class_declaration list
+        (* class c1 = ... and ... and cn = ... *)
+  | Pstr_class_type of class_type_declaration list
+        (* class type ct1 = ... and ... and ctn = ... *)
+  | Pstr_include of include_declaration
+        (* include ME *)
+  | Pstr_attribute of attribute
+        (* [@@@id] *)
+  | Pstr_extension of extension * attributes
+        (* [%%id] *)
+
+and value_binding =
+  {
+    pvb_pat: pattern;
+    pvb_expr: expression;
+    pvb_attributes: attributes;
+    pvb_loc: Location.t;
+  }
+
+and module_binding =
+    {
+     pmb_name: string option loc;
+     pmb_expr: module_expr;
+     pmb_attributes: attributes;
+     pmb_loc: Location.t;
+    }
+(* X = ME *)
+
+(** {1 Toplevel} *)
+
+(* Toplevel phrases *)
+
+type toplevel_phrase =
+  | Ptop_def of structure
+  | Ptop_dir of toplevel_directive
+     (* #use, #load ... *)
+
+and toplevel_directive =
+  {
+    pdir_name : string loc;
+    pdir_arg : directive_argument option;
+    pdir_loc : Location.t;
+  }
+
+and directive_argument =
+  {
+    pdira_desc : directive_argument_desc;
+    pdira_loc : Location.t;
+  }
+
+and directive_argument_desc =
+  | Pdir_string of string
+  | Pdir_int of string * char option
+  | Pdir_ident of Longident.t
+  | Pdir_bool of bool
diff --git a/src/ocaml/parsing/pprintast.ml b/src/ocaml/parsing/pprintast.ml
new file mode 100644
index 0000000..ebcfc3f
--- /dev/null
+++ b/src/ocaml/parsing/pprintast.ml
@@ -0,0 +1,1757 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Thomas Gazagnaire, OCamlPro                       *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*               Hongbo Zhang, University of Pennsylvania                 *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Original Code from Ber-metaocaml, modified for 3.12.0 and fixed *)
+(* Printing code expressions *)
+(* Authors:  Ed Pizzi, Fabrice Le Fessant *)
+(* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *)
+(* TODO more fine-grained precedence pretty-printing *)
+
+open Asttypes
+open Format
+open Location
+open Longident
+open Parsetree
+open Ast_helper
+
+let prefix_symbols  = [ '!'; '?'; '~' ] ;;
+let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/';
+                      '$'; '%'; '#' ]
+
+(* type fixity = Infix| Prefix  *)
+let special_infix_strings =
+  ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ]
+
+let letop s =
+  String.length s > 3
+  && s.[0] = 'l'
+  && s.[1] = 'e'
+  && s.[2] = 't'
+  && List.mem s.[3] infix_symbols
+
+let andop s =
+  String.length s > 3
+  && s.[0] = 'a'
+  && s.[1] = 'n'
+  && s.[2] = 'd'
+  && List.mem s.[3] infix_symbols
+
+(* determines if the string is an infix string.
+   checks backwards, first allowing a renaming postfix ("_102") which
+   may have resulted from Pexp -> Texp -> Pexp translation, then checking
+   if all the characters in the beginning of the string are valid infix
+   characters. *)
+let fixity_of_string  = function
+  | "" -> `Normal
+  | s when List.mem s special_infix_strings -> `Infix s
+  | s when List.mem s.[0] infix_symbols -> `Infix s
+  | s when List.mem s.[0] prefix_symbols -> `Prefix s
+  | s when s.[0] = '.' -> `Mixfix s
+  | s when letop s -> `Letop s
+  | s when andop s -> `Andop s
+  | _ -> `Normal
+
+let view_fixity_of_exp = function
+  | {pexp_desc = Pexp_ident {txt=Lident l;_}; pexp_attributes = []} ->
+      fixity_of_string l
+  | _ -> `Normal
+
+let is_infix  = function `Infix _ -> true | _  -> false
+let is_mixfix = function `Mixfix _ -> true | _ -> false
+let is_kwdop = function `Letop _ | `Andop _ -> true | _ -> false
+
+let first_is c str =
+  str <> "" && str.[0] = c
+let last_is c str =
+  str <> "" && str.[String.length str - 1] = c
+
+let first_is_in cs str =
+  str <> "" && List.mem str.[0] cs
+
+(* which identifiers are in fact operators needing parentheses *)
+let needs_parens txt =
+  let fix = fixity_of_string txt in
+  is_infix fix
+  || is_mixfix fix
+  || is_kwdop fix
+  || first_is_in prefix_symbols txt
+
+(* some infixes need spaces around parens to avoid clashes with comment
+   syntax *)
+let needs_spaces txt =
+  first_is '*' txt || last_is '*' txt
+
+let string_loc ppf x = fprintf ppf "%s" x.txt
+
+(* add parentheses to binders when they are in fact infix or prefix operators *)
+let protect_ident ppf txt =
+  let format : (_, _, _) format =
+    if not (needs_parens txt) then "%s"
+    else if needs_spaces txt then "(@;%s@;)"
+    else "(%s)"
+  in fprintf ppf format txt
+
+let protect_longident ppf print_longident longprefix txt =
+  let format : (_, _, _) format =
+    if not (needs_parens txt) then "%a.%s"
+    else if needs_spaces txt then  "%a.(@;%s@;)"
+    else "%a.(%s)" in
+  fprintf ppf format print_longident longprefix txt
+
+type space_formatter = (unit, Format.formatter, unit) format
+
+let override = function
+  | Override -> "!"
+  | Fresh -> ""
+
+(* variance encoding: need to sync up with the [parser.mly] *)
+let type_variance = function
+  | NoVariance -> ""
+  | Covariant -> "+"
+  | Contravariant -> "-"
+
+let type_injectivity = function
+  | NoInjectivity -> ""
+  | Injective -> "!"
+
+type construct =
+  [ `cons of expression list
+  | `list of expression list
+  | `nil
+  | `normal
+  | `simple of Longident.t
+  | `tuple ]
+
+let view_expr x =
+  match x.pexp_desc with
+  | Pexp_construct ( {txt= Lident "()"; _},_) -> `tuple
+  | Pexp_construct ( {txt= Lident "[]";_},_) -> `nil
+  | Pexp_construct ( {txt= Lident"::";_},Some _) ->
+      let rec loop exp acc = match exp with
+          | {pexp_desc=Pexp_construct ({txt=Lident "[]";_},_);
+             pexp_attributes = []} ->
+              (List.rev acc,true)
+          | {pexp_desc=
+             Pexp_construct ({txt=Lident "::";_},
+                             Some ({pexp_desc= Pexp_tuple([e1;e2]);
+                                    pexp_attributes = []}));
+             pexp_attributes = []}
+            ->
+              loop e2 (e1::acc)
+          | e -> (List.rev (e::acc),false) in
+      let (ls,b) = loop x []  in
+      if b then
+        `list ls
+      else `cons ls
+  | Pexp_construct (x,None) -> `simple (x.txt)
+  | _ -> `normal
+
+let is_simple_construct :construct -> bool = function
+  | `nil | `tuple | `list _ | `simple _  -> true
+  | `cons _ | `normal -> false
+
+let pp = fprintf
+
+type ctxt = {
+  pipe : bool;
+  semi : bool;
+  ifthenelse : bool;
+}
+
+let reset_ctxt = { pipe=false; semi=false; ifthenelse=false }
+let under_pipe ctxt = { ctxt with pipe=true }
+let under_semi ctxt = { ctxt with semi=true }
+let under_ifthenelse ctxt = { ctxt with ifthenelse=true }
+(*
+let reset_semi ctxt = { ctxt with semi=false }
+let reset_ifthenelse ctxt = { ctxt with ifthenelse=false }
+let reset_pipe ctxt = { ctxt with pipe=false }
+*)
+
+let list : 'a . ?sep:space_formatter -> ?first:space_formatter ->
+  ?last:space_formatter -> (Format.formatter -> 'a -> unit) ->
+  Format.formatter -> 'a list -> unit
+  = fun ?sep ?first ?last fu f xs ->
+    let first = match first with Some x -> x |None -> ("": _ format6)
+    and last = match last with Some x -> x |None -> ("": _ format6)
+    and sep = match sep with Some x -> x |None -> ("@ ": _ format6) in
+    let aux f = function
+      | [] -> ()
+      | [x] -> fu f x
+      | xs ->
+          let rec loop  f = function
+            | [x] -> fu f x
+            | x::xs ->  fu f x; pp f sep; loop f xs;
+            | _ -> assert false in begin
+            pp f first; loop f xs; pp f last;
+          end in
+    aux f xs
+
+let option : 'a. ?first:space_formatter -> ?last:space_formatter ->
+  (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit
+  = fun  ?first  ?last fu f a ->
+    let first = match first with Some x -> x | None -> ("": _ format6)
+    and last = match last with Some x -> x | None -> ("": _ format6) in
+    match a with
+    | None -> ()
+    | Some x -> pp f first; fu f x; pp f last
+
+let paren: 'a . ?first:space_formatter -> ?last:space_formatter ->
+  bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit
+  = fun  ?(first=("": _ format6)) ?(last=("": _ format6)) b fu f x ->
+    if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")")
+    else fu f x
+
+let rec longident f = function
+  | Lident s -> protect_ident f s
+  | Ldot(y,s) -> protect_longident f longident y s
+  | Lapply (y,s) ->
+      pp f "%a(%a)" longident y longident s
+
+let longident_loc f x = pp f "%a" longident x.txt
+
+let constant f = function
+  | Pconst_char i ->
+      pp f "%C"  i
+  | Pconst_string (i, _, None) ->
+      pp f "%S" i
+  | Pconst_string (i, _, Some delim) ->
+      pp f "{%s|%s|%s}" delim i delim
+  | Pconst_integer (i, None) ->
+      paren (first_is '-' i) (fun f -> pp f "%s") f i
+  | Pconst_integer (i, Some m) ->
+      paren (first_is '-' i) (fun f (i, m) -> pp f "%s%c" i m) f (i,m)
+  | Pconst_float (i, None) ->
+      paren (first_is '-' i) (fun f -> pp f "%s") f i
+  | Pconst_float (i, Some m) ->
+      paren (first_is '-' i) (fun f (i,m) -> pp f "%s%c" i m) f (i,m)
+
+(* trailing space*)
+let mutable_flag f = function
+  | Immutable -> ()
+  | Mutable -> pp f "mutable@;"
+let virtual_flag f  = function
+  | Concrete -> ()
+  | Virtual -> pp f "virtual@;"
+
+(* trailing space added *)
+let rec_flag f rf =
+  match rf with
+  | Nonrecursive -> ()
+  | Recursive -> pp f "rec "
+let nonrec_flag f rf =
+  match rf with
+  | Nonrecursive -> pp f "nonrec "
+  | Recursive -> ()
+let direction_flag f = function
+  | Upto -> pp f "to@ "
+  | Downto -> pp f "downto@ "
+let private_flag f = function
+  | Public -> ()
+  | Private -> pp f "private@ "
+
+let iter_loc f ctxt {txt; loc = _} = f ctxt txt
+
+let constant_string f s = pp f "%S" s
+
+let tyvar ppf s =
+  if String.length s >= 2 && s.[1] = '\'' then
+    (* without the space, this would be parsed as
+       a character literal *)
+    Format.fprintf ppf "' %s" s
+  else
+    Format.fprintf ppf "'%s" s
+
+let tyvar_loc f str = tyvar f str.txt
+let string_quot f x = pp f "`%s" x
+
+(* c ['a,'b] *)
+let rec class_params_def ctxt f =  function
+  | [] -> ()
+  | l ->
+      pp f "[%a] " (* space *)
+        (list (type_param ctxt) ~sep:",") l
+
+and type_with_label ctxt f (label, c) =
+  match label with
+  | Nolabel    -> core_type1 ctxt f c (* otherwise parenthesize *)
+  | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c
+  | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c
+
+and core_type ctxt f x =
+  if x.ptyp_attributes <> [] then begin
+    pp f "((%a)%a)" (core_type ctxt) {x with ptyp_attributes=[]}
+      (attributes ctxt) x.ptyp_attributes
+  end
+  else match x.ptyp_desc with
+    | Ptyp_arrow (l, ct1, ct2) ->
+        pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
+          (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2
+    | Ptyp_alias (ct, s) ->
+        pp f "@[<2>%a@;as@;%a@]" (core_type1 ctxt) ct tyvar s
+    | Ptyp_poly ([], ct) ->
+        core_type ctxt f ct
+    | Ptyp_poly (sl, ct) ->
+        pp f "@[<2>%a%a@]"
+          (fun f l ->
+             pp f "%a"
+               (fun f l -> match l with
+                  | [] -> ()
+                  | _ ->
+                      pp f "%a@;.@;"
+                        (list tyvar_loc ~sep:"@;")  l)
+               l)
+          sl (core_type ctxt) ct
+    | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x
+
+and core_type1 ctxt f x =
+  if x.ptyp_attributes <> [] then core_type ctxt f x
+  else match x.ptyp_desc with
+    | Ptyp_any -> pp f "_";
+    | Ptyp_var s -> tyvar f  s;
+    | Ptyp_tuple l ->  pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l
+    | Ptyp_constr (li, l) ->
+        pp f (* "%a%a@;" *) "%a%a"
+          (fun f l -> match l with
+             |[] -> ()
+             |[x]-> pp f "%a@;" (core_type1 ctxt)  x
+             | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l)
+          l longident_loc li
+    | Ptyp_variant (l, closed, low) ->
+        let first_is_inherit =
+          match l with
+          | {Parsetree.prf_desc = Rinherit _}::_ -> true
+          | _ -> false in
+        let type_variant_helper f x =
+          match x.prf_desc with
+          | Rtag (l, _, ctl) ->
+              pp f "@[<2>%a%a@;%a@]" (iter_loc string_quot) l
+                (fun f l -> match l with
+                   |[] -> ()
+                   | _ -> pp f "@;of@;%a"
+                            (list (core_type ctxt) ~sep:"&")  ctl) ctl
+                (attributes ctxt) x.prf_attributes
+          | Rinherit ct -> core_type ctxt f ct in
+        pp f "@[<2>[%a%a]@]"
+          (fun f l ->
+             match l, closed with
+             | [], Closed -> ()
+             | [], Open -> pp f ">" (* Cf #7200: print [>] correctly *)
+             | _ ->
+                 pp f "%s@;%a"
+                   (match (closed,low) with
+                    | (Closed,None) -> if first_is_inherit then " |" else ""
+                    | (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*)
+                    | (Open,_) -> ">")
+                   (list type_variant_helper ~sep:"@;<1 -2>| ") l) l
+          (fun f low -> match low with
+             |Some [] |None -> ()
+             |Some xs ->
+                 pp f ">@ %a"
+                   (list string_quot) xs) low
+    | Ptyp_object (l, o) ->
+        let core_field_type f x = match x.pof_desc with
+          | Otag (l, ct) ->
+            (* Cf #7200 *)
+            pp f "@[<hov2>%s: %a@ %a@ @]" l.txt
+              (core_type ctxt) ct (attributes ctxt) x.pof_attributes
+          | Oinherit ct ->
+            pp f "@[<hov2>%a@ @]" (core_type ctxt) ct
+        in
+        let field_var f = function
+          | Asttypes.Closed -> ()
+          | Asttypes.Open ->
+              match l with
+              | [] -> pp f ".."
+              | _ -> pp f " ;.."
+        in
+        pp f "@[<hov2><@ %a%a@ > @]"
+          (list core_field_type ~sep:";") l
+          field_var o (* Cf #7200 *)
+    | Ptyp_class (li, l) ->   (*FIXME*)
+        pp f "@[<hov2>%a#%a@]"
+          (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") l
+          longident_loc li
+    | Ptyp_package (lid, cstrs) ->
+        let aux f (s, ct) =
+          pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct  in
+        (match cstrs with
+         |[] -> pp f "@[<hov2>(module@ %a)@]" longident_loc lid
+         |_ ->
+             pp f "@[<hov2>(module@ %a@ with@ %a)@]" longident_loc lid
+               (list aux  ~sep:"@ and@ ")  cstrs)
+    | Ptyp_extension e -> extension ctxt f e
+    | _ -> paren true (core_type ctxt) f x
+
+(********************pattern********************)
+(* be cautious when use [pattern], [pattern1] is preferred *)
+and pattern ctxt f x =
+  if x.ppat_attributes <> [] then begin
+    pp f "((%a)%a)" (pattern ctxt) {x with ppat_attributes=[]}
+      (attributes ctxt) x.ppat_attributes
+  end
+  else match x.ppat_desc with
+    | Ppat_alias (p, s) ->
+        pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt
+    | _ -> pattern_or ctxt f x
+
+and pattern_or ctxt f x =
+  let rec left_associative x acc = match x with
+    | {ppat_desc= Ppat_or (p1,p2); ppat_attributes = []} ->
+        left_associative p1 (p2::acc)
+    | x -> x::acc
+  in
+  match left_associative x [] with
+  | [] -> assert false
+  | [x] -> pattern1 ctxt f x
+  | orpats ->
+      pp f "@[<hov0>%a@]" (list ~sep:"@ |" (pattern1 ctxt)) orpats
+
+and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit =
+  let rec pattern_list_helper f = function
+    | {ppat_desc =
+         Ppat_construct
+           ({ txt = Lident("::") ;_},
+            Some ([], {ppat_desc = Ppat_tuple([pat1; pat2]);_}));
+       ppat_attributes = []}
+
+      ->
+        pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*)
+    | p -> pattern1 ctxt f p
+  in
+  if x.ppat_attributes <> [] then pattern ctxt f x
+  else match x.ppat_desc with
+    | Ppat_variant (l, Some p) ->
+        pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) p
+    | Ppat_construct (({txt=Lident("()"|"[]");_}), _) ->
+        simple_pattern ctxt f x
+    | Ppat_construct (({txt;_} as li), po) ->
+        (* FIXME The third field always false *)
+        if txt = Lident "::" then
+          pp f "%a" pattern_list_helper x
+        else
+          (match po with
+           | Some ([], x) ->
+               pp f "%a@;%a"  longident_loc li (simple_pattern ctxt) x
+           | Some (vl, x) ->
+               pp f "%a@ (type %a)@;%a" longident_loc li
+                 (list ~sep:"@ " string_loc) vl
+                 (simple_pattern ctxt) x
+           | None -> pp f "%a" longident_loc li)
+    | _ -> simple_pattern ctxt f x
+
+and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit =
+  if x.ppat_attributes <> [] then pattern ctxt f x
+  else match x.ppat_desc with
+    | Ppat_construct (({txt=Lident ("()"|"[]" as x);_}), None) ->
+        pp f  "%s" x
+    | Ppat_any -> pp f "_";
+    | Ppat_var ({txt = txt;_}) -> protect_ident f txt
+    | Ppat_array l ->
+        pp f "@[<2>[|%a|]@]"  (list (pattern1 ctxt) ~sep:";") l
+    | Ppat_unpack { txt = None } ->
+        pp f "(module@ _)@ "
+    | Ppat_unpack { txt = Some s } ->
+        pp f "(module@ %s)@ " s
+    | Ppat_type li ->
+        pp f "#%a" longident_loc li
+    | Ppat_record (l, closed) ->
+        let longident_x_pattern f (li, p) =
+          match (li,p) with
+          | ({txt=Lident s;_ },
+             {ppat_desc=Ppat_var {txt;_};
+              ppat_attributes=[]; _})
+            when s = txt ->
+              pp f "@[<2>%a@]"  longident_loc li
+          | _ ->
+              pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p
+        in
+        begin match closed with
+        | Closed ->
+            pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l
+        | _ ->
+            pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l
+        end
+    | Ppat_tuple l ->
+        pp f "@[<1>(%a)@]" (list  ~sep:",@;" (pattern1 ctxt))  l (* level1*)
+    | Ppat_constant (c) -> pp f "%a" constant c
+    | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2
+    | Ppat_variant (l,None) ->  pp f "`%s" l
+    | Ppat_constraint (p, ct) ->
+        pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct
+    | Ppat_lazy p ->
+        pp f "@[<2>(lazy@;%a)@]" (simple_pattern ctxt) p
+    | Ppat_exception p ->
+        pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p
+    | Ppat_extension e -> extension ctxt f e
+    | Ppat_open (lid, p) ->
+        let with_paren =
+        match p.ppat_desc with
+        | Ppat_array _ | Ppat_record _
+        | Ppat_construct (({txt=Lident ("()"|"[]");_}), None) -> false
+        | _ -> true in
+        pp f "@[<2>%a.%a @]" longident_loc lid
+          (paren with_paren @@ pattern1 ctxt) p
+    | _ -> paren true (pattern ctxt) f x
+
+and label_exp ctxt f (l,opt,p) =
+  match l with
+  | Nolabel ->
+      (* single case pattern parens needed here *)
+      pp f "%a@ " (simple_pattern ctxt) p
+  | Optional rest ->
+      begin match p with
+      | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []}
+        when txt = rest ->
+          (match opt with
+           | Some o -> pp f "?(%s=@;%a)@;" rest  (expression ctxt) o
+           | None -> pp f "?%s@ " rest)
+      | _ ->
+          (match opt with
+           | Some o ->
+               pp f "?%s:(%a=@;%a)@;"
+                 rest (pattern1 ctxt) p (expression ctxt) o
+           | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p)
+      end
+  | Labelled l -> match p with
+    | {ppat_desc  = Ppat_var {txt;_}; ppat_attributes = []}
+      when txt = l ->
+        pp f "~%s@;" l
+    | _ ->  pp f "~%s:%a@;" l (simple_pattern ctxt) p
+
+and sugar_expr ctxt f e =
+  if e.pexp_attributes <> [] then false
+  else match e.pexp_desc with
+  | Pexp_apply ({ pexp_desc = Pexp_ident {txt = id; _};
+                  pexp_attributes=[]; _}, args)
+    when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin
+      let print_indexop a path_prefix assign left sep right print_index indices
+          rem_args =
+        let print_path ppf = function
+          | None -> ()
+          | Some m -> pp ppf ".%a" longident m in
+        match assign, rem_args with
+            | false, [] ->
+              pp f "@[%a%a%s%a%s@]"
+                (simple_expr ctxt) a print_path path_prefix
+                left (list ~sep print_index) indices right; true
+            | true, [v] ->
+              pp f "@[%a%a%s%a%s@ <-@;<1 2>%a@]"
+                (simple_expr ctxt) a print_path path_prefix
+                left (list ~sep print_index) indices right
+                (simple_expr ctxt) v; true
+            | _ -> false in
+      match id, List.map snd args with
+      | Lident "!", [e] ->
+        pp f "@[<hov>!%a@]" (simple_expr ctxt) e; true
+      | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin
+          let assign = func = "set" in
+          let print = print_indexop a None assign in
+          match path, other_args with
+          | Lident "Array", i :: rest ->
+            print ".(" "" ")" (expression ctxt) [i] rest
+          | Lident "String", i :: rest ->
+            print ".[" "" "]" (expression ctxt) [i] rest
+          | Ldot (Lident "Bigarray", "Array1"), i1 :: rest ->
+            print ".{" "," "}" (simple_expr ctxt) [i1] rest
+          | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest ->
+            print ".{" "," "}" (simple_expr ctxt) [i1; i2] rest
+          | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest ->
+            print ".{" "," "}" (simple_expr ctxt) [i1; i2; i3] rest
+          | Ldot (Lident "Bigarray", "Genarray"),
+            {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest ->
+              print ".{" "," "}" (simple_expr ctxt) indexes rest
+          | _ -> false
+        end
+      | (Lident s | Ldot(_,s)) , a :: i :: rest
+        when first_is '.' s ->
+          (* extract operator:
+             assignment operators end with [right_bracket ^ "<-"],
+             access operators end with [right_bracket] directly
+          *)
+          let multi_indices = String.contains s ';' in
+          let i =
+              match i.pexp_desc with
+                | Pexp_array l when multi_indices -> l
+                | _ -> [ i ] in
+          let assign = last_is '-' s in
+          let kind =
+            (* extract the right end bracket *)
+            let n = String.length s in
+            if assign then s.[n - 3] else s.[n - 1] in
+          let left, right = match kind with
+            | ')' -> '(', ")"
+            | ']' -> '[', "]"
+            | '}' -> '{', "}"
+            | _ -> assert false in
+          let path_prefix = match id with
+            | Ldot(m,_) -> Some m
+            | _ -> None in
+          let left = String.sub s 0 (1+String.index s left) in
+          print_indexop a path_prefix assign left ";" right
+            (if multi_indices then expression ctxt else simple_expr ctxt)
+            i rest
+      | _ -> false
+    end
+  | _ -> false
+
+and uncurry params e =
+  match e.pexp_desc with
+  | Pexp_fun (l, e0, p, e) ->
+    uncurry ((l, e0, p) :: params) e
+  | _ -> List.rev params, e
+
+and expression ctxt f x =
+  if x.pexp_attributes <> [] then
+    pp f "((%a)@,%a)" (expression ctxt) {x with pexp_attributes=[]}
+      (attributes ctxt) x.pexp_attributes
+  else match x.pexp_desc with
+    | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _
+    | Pexp_newtype _
+      when ctxt.pipe || ctxt.semi ->
+        paren true (expression reset_ctxt) f x
+    | Pexp_ifthenelse _ | Pexp_sequence _ when ctxt.ifthenelse ->
+        paren true (expression reset_ctxt) f x
+    | Pexp_let _ | Pexp_letmodule _ | Pexp_open _
+      | Pexp_letexception _ | Pexp_letop _
+        when ctxt.semi ->
+        paren true (expression reset_ctxt) f x
+    | Pexp_fun (l, e0, p, e) ->
+        let params, body = uncurry [l, e0, p] e in
+        pp f "@[<2>fun@;%a->@;%a@]"
+          (pp_print_list (label_exp ctxt)) params
+          (expression ctxt) body
+    | Pexp_newtype (lid, e) ->
+        pp f "@[<2>fun@;(type@;%s)@;->@;%a@]" lid.txt
+          (expression ctxt) e
+    | Pexp_function l ->
+        pp f "@[<hv>function%a@]" (case_list ctxt) l
+    | Pexp_match (e, l) ->
+        pp f "@[<hv0>@[<hv0>@[<2>match %a@]@ with@]%a@]"
+          (expression reset_ctxt) e (case_list ctxt) l
+
+    | Pexp_try (e, l) ->
+        pp f "@[<0>@[<hv2>try@ %a@]@ @[<0>with%a@]@]"
+             (* "try@;@[<2>%a@]@\nwith@\n%a"*)
+          (expression reset_ctxt) e  (case_list ctxt) l
+    | Pexp_let (rf, l, e) ->
+        (* pp f "@[<2>let %a%a in@;<1 -2>%a@]"
+           (*no indentation here, a new line*) *)
+        (*   rec_flag rf *)
+        pp f "@[<2>%a in@;<1 -2>%a@]"
+          (bindings reset_ctxt) (rf,l)
+          (expression ctxt) e
+    | Pexp_apply (e, l) ->
+        begin if not (sugar_expr ctxt f x) then
+            match view_fixity_of_exp e with
+            | `Infix s ->
+                begin match l with
+                | [ (Nolabel, _) as arg1; (Nolabel, _) as arg2 ] ->
+                    (* FIXME associativity label_x_expression_param *)
+                    pp f "@[<2>%a@;%s@;%a@]"
+                      (label_x_expression_param reset_ctxt) arg1 s
+                      (label_x_expression_param ctxt) arg2
+                | _ ->
+                    pp f "@[<2>%a %a@]"
+                      (simple_expr ctxt) e
+                      (list (label_x_expression_param ctxt)) l
+                end
+            | `Prefix s ->
+                let s =
+                  if List.mem s ["~+";"~-";"~+.";"~-."] &&
+                   (match l with
+                    (* See #7200: avoid turning (~- 1) into (- 1) which is
+                       parsed as an int literal *)
+                    |[(_,{pexp_desc=Pexp_constant _})] -> false
+                    | _ -> true)
+                  then String.sub s 1 (String.length s -1)
+                  else s in
+                begin match l with
+                | [(Nolabel, x)] ->
+                  pp f "@[<2>%s@;%a@]" s (simple_expr ctxt) x
+                | _   ->
+                  pp f "@[<2>%a %a@]" (simple_expr ctxt) e
+                    (list (label_x_expression_param ctxt)) l
+                end
+            | _ ->
+                pp f "@[<hov2>%a@]" begin fun f (e,l) ->
+                  pp f "%a@ %a" (expression2 ctxt) e
+                    (list (label_x_expression_param reset_ctxt))  l
+                    (* reset here only because [function,match,try,sequence]
+                       are lower priority *)
+                end (e,l)
+        end
+
+    | Pexp_construct (li, Some eo)
+      when not (is_simple_construct (view_expr x))-> (* Not efficient FIXME*)
+        (match view_expr x with
+         | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;"
+         | `normal ->
+             pp f "@[<2>%a@;%a@]" longident_loc li
+               (simple_expr ctxt) eo
+         | _ -> assert false)
+    | Pexp_setfield (e1, li, e2) ->
+        pp f "@[<2>%a.%a@ <-@ %a@]"
+          (simple_expr ctxt) e1 longident_loc li (simple_expr ctxt) e2
+    | Pexp_ifthenelse (e1, e2, eo) ->
+        (* @;@[<2>else@ %a@]@] *)
+        let fmt:(_,_,_)format ="@[<hv0>@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" in
+        let expression_under_ifthenelse = expression (under_ifthenelse ctxt) in
+        pp f fmt expression_under_ifthenelse e1 expression_under_ifthenelse e2
+          (fun f eo -> match eo with
+             | Some x ->
+                 pp f "@;@[<2>else@;%a@]" (expression (under_semi ctxt)) x
+             | None -> () (* pp f "()" *)) eo
+    | Pexp_sequence _ ->
+        let rec sequence_helper acc = function
+          | {pexp_desc=Pexp_sequence(e1,e2); pexp_attributes = []} ->
+              sequence_helper (e1::acc) e2
+          | v -> List.rev (v::acc) in
+        let lst = sequence_helper [] x in
+        pp f "@[<hv>%a@]"
+          (list (expression (under_semi ctxt)) ~sep:";@;") lst
+    | Pexp_new (li) ->
+        pp f "@[<hov2>new@ %a@]" longident_loc li;
+    | Pexp_setinstvar (s, e) ->
+        pp f "@[<hov2>%s@ <-@ %a@]" s.txt (expression ctxt) e
+    | Pexp_override l -> (* FIXME *)
+        let string_x_expression f (s, e) =
+          pp f "@[<hov2>%s@ =@ %a@]" s.txt (expression ctxt) e in
+        pp f "@[<hov2>{<%a>}@]"
+          (list string_x_expression  ~sep:";"  )  l;
+    | Pexp_letmodule (s, me, e) ->
+        pp f "@[<hov2>let@ module@ %s@ =@ %a@ in@ %a@]"
+          (Option.value s.txt ~default:"_")
+          (module_expr reset_ctxt) me (expression ctxt) e
+    | Pexp_letexception (cd, e) ->
+        pp f "@[<hov2>let@ exception@ %a@ in@ %a@]"
+          (extension_constructor ctxt) cd
+          (expression ctxt) e
+    | Pexp_assert e ->
+        pp f "@[<hov2>assert@ %a@]" (simple_expr ctxt) e
+    | Pexp_lazy (e) ->
+        pp f "@[<hov2>lazy@ %a@]" (simple_expr ctxt) e
+    (* Pexp_poly: impossible but we should print it anyway, rather than
+       assert false *)
+    | Pexp_poly (e, None) ->
+        pp f "@[<hov2>!poly!@ %a@]" (simple_expr ctxt) e
+    | Pexp_poly (e, Some ct) ->
+        pp f "@[<hov2>(!poly!@ %a@ : %a)@]"
+          (simple_expr ctxt) e (core_type ctxt) ct
+    | Pexp_open (o, e) ->
+        pp f "@[<2>let open%s %a in@;%a@]"
+          (override o.popen_override) (module_expr ctxt) o.popen_expr
+          (expression ctxt) e
+    | Pexp_variant (l,Some eo) ->
+        pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo
+    | Pexp_letop {let_; ands; body} ->
+        pp f "@[<2>@[<v>%a@,%a@] in@;<1 -2>%a@]"
+          (binding_op ctxt) let_
+          (list ~sep:"@," (binding_op ctxt)) ands
+          (expression ctxt) body
+    | Pexp_extension ({ txt; _ }, _) when txt = Ast_helper.hole_txt ->
+        pp f "%a" (simple_expr ctxt) x
+    | Pexp_extension e -> extension ctxt f e
+    | Pexp_unreachable -> pp f "."
+    | _ -> expression1 ctxt f x
+
+and expression1 ctxt f x =
+  if x.pexp_attributes <> [] then expression ctxt f x
+  else match x.pexp_desc with
+    | Pexp_object cs -> pp f "%a" (class_structure ctxt) cs
+    | _ -> expression2 ctxt f x
+(* used in [Pexp_apply] *)
+
+and expression2 ctxt f x =
+  if x.pexp_attributes <> [] then expression ctxt f x
+  else match x.pexp_desc with
+    | Pexp_field (e, li) ->
+        pp f "@[<hov2>%a.%a@]" (simple_expr ctxt) e longident_loc li
+    | Pexp_send (e, s) -> pp f "@[<hov2>%a#%s@]" (simple_expr ctxt) e s.txt
+
+    | _ -> simple_expr ctxt f x
+
+and simple_expr ctxt f x =
+  if x.pexp_attributes <> [] then expression ctxt f x
+  else match x.pexp_desc with
+    | Pexp_construct _  when is_simple_construct (view_expr x) ->
+        (match view_expr x with
+         | `nil -> pp f "[]"
+         | `tuple -> pp f "()"
+         | `list xs ->
+             pp f "@[<hv0>[%a]@]"
+               (list (expression (under_semi ctxt)) ~sep:";@;") xs
+         | `simple x -> longident f x
+         | _ -> assert false)
+    | Pexp_ident li ->
+        longident_loc f li
+    (* (match view_fixity_of_exp x with *)
+    (* |`Normal -> longident_loc f li *)
+    (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *)
+    | Pexp_constant c -> constant f c;
+    | Pexp_pack me ->
+        pp f "(module@;%a)" (module_expr ctxt) me
+    | Pexp_tuple l ->
+        pp f "@[<hov2>(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l
+    | Pexp_constraint (e, ct) ->
+        pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct
+    | Pexp_coerce (e, cto1, ct) ->
+        pp f "(%a%a :> %a)" (expression ctxt) e
+          (option (core_type ctxt) ~first:" : " ~last:" ") cto1 (* no sep hint*)
+          (core_type ctxt) ct
+    | Pexp_variant (l, None) -> pp f "`%s" l
+    | Pexp_record (l, eo) ->
+        let longident_x_expression f ( li, e) =
+          match e with
+          |  {pexp_desc=Pexp_ident {txt;_};
+              pexp_attributes=[]; _} when li.txt = txt ->
+              pp f "@[<hov2>%a@]" longident_loc li
+          | _ ->
+              pp f "@[<hov2>%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e
+        in
+        pp f "@[<hv0>@[<hv2>{@;%a%a@]@;}@]"(* "@[<hov2>{%a%a}@]" *)
+          (option ~last:" with@;" (simple_expr ctxt)) eo
+          (list longident_x_expression ~sep:";@;") l
+    | Pexp_array (l) ->
+        pp f "@[<0>@[<2>[|%a|]@]@]"
+          (list (simple_expr (under_semi ctxt)) ~sep:";") l
+    | Pexp_while (e1, e2) ->
+        let fmt : (_,_,_) format = "@[<2>while@;%a@;do@;%a@;done@]" in
+        pp f fmt (expression ctxt) e1 (expression ctxt) e2
+    | Pexp_for (s, e1, e2, df, e3) ->
+        let fmt:(_,_,_)format =
+          "@[<hv0>@[<hv2>@[<2>for %a =@;%a@;%a%a@;do@]@;%a@]@;done@]" in
+        let expression = expression ctxt in
+        pp f fmt (pattern ctxt) s expression e1 direction_flag
+          df expression e2 expression e3
+    | Pexp_extension ({ txt; _ }, _) when txt = Ast_helper.hole_txt ->
+        pp f "_"
+    | _ ->  paren true (expression ctxt) f x
+
+and attributes ctxt f l =
+  List.iter (attribute ctxt f) l
+
+and item_attributes ctxt f l =
+  List.iter (item_attribute ctxt f) l
+
+and attribute ctxt f a =
+  pp f "@[<2>[@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload
+
+and item_attribute ctxt f a =
+  pp f "@[<2>[@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload
+
+and floating_attribute ctxt f a =
+  pp f "@[<2>[@@@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload
+
+and value_description ctxt f x =
+  (* note: value_description has an attribute field,
+           but they're already printed by the callers this method *)
+  pp f "@[<hov2>%a%a@]" (core_type ctxt) x.pval_type
+    (fun f x ->
+       if x.pval_prim <> []
+       then pp f "@ =@ %a" (list constant_string) x.pval_prim
+    ) x
+
+and extension ctxt f (s, e) =
+  pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e
+
+and item_extension ctxt f (s, e) =
+  pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e
+
+and exception_declaration ctxt f x =
+  pp f "@[<hov2>exception@ %a@]%a"
+    (extension_constructor ctxt) x.ptyexn_constructor
+    (item_attributes ctxt) x.ptyexn_attributes
+
+and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} =
+  let class_type_field f x =
+    match x.pctf_desc with
+    | Pctf_inherit (ct) ->
+        pp f "@[<2>inherit@ %a@]%a" (class_type ctxt) ct
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_val (s, mf, vf, ct) ->
+        pp f "@[<2>val @ %a%a%s@ :@ %a@]%a"
+          mutable_flag mf virtual_flag vf s.txt (core_type ctxt) ct
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_method (s, pf, vf, ct) ->
+        pp f "@[<2>method %a %a%s :@;%a@]%a"
+          private_flag pf virtual_flag vf s.txt (core_type ctxt) ct
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_constraint (ct1, ct2) ->
+        pp f "@[<2>constraint@ %a@ =@ %a@]%a"
+          (core_type ctxt) ct1 (core_type ctxt) ct2
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_attribute a -> floating_attribute ctxt f a
+    | Pctf_extension e ->
+        item_extension ctxt f e;
+        item_attributes ctxt f x.pctf_attributes
+  in
+  pp f "@[<hv0>@[<hv2>object@[<1>%a@]@ %a@]@ end@]"
+    (fun f -> function
+         {ptyp_desc=Ptyp_any; ptyp_attributes=[]; _} -> ()
+       | ct -> pp f " (%a)" (core_type ctxt) ct) ct
+    (list class_type_field ~sep:"@;") l
+
+(* call [class_signature] called by [class_signature] *)
+and class_type ctxt f x =
+  match x.pcty_desc with
+  | Pcty_signature cs ->
+      class_signature ctxt f cs;
+      attributes ctxt f x.pcty_attributes
+  | Pcty_constr (li, l) ->
+      pp f "%a%a%a"
+        (fun f l -> match l with
+           | [] -> ()
+           | _  -> pp f "[%a]@ " (list (core_type ctxt) ~sep:"," ) l) l
+        longident_loc li
+        (attributes ctxt) x.pcty_attributes
+  | Pcty_arrow (l, co, cl) ->
+      pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
+        (type_with_label ctxt) (l,co)
+        (class_type ctxt) cl
+  | Pcty_extension e ->
+      extension ctxt f e;
+      attributes ctxt f x.pcty_attributes
+  | Pcty_open (o, e) ->
+      pp f "@[<2>let open%s %a in@;%a@]"
+        (override o.popen_override) longident_loc o.popen_expr
+        (class_type ctxt) e
+
+(* [class type a = object end] *)
+and class_type_declaration_list ctxt f l =
+  let class_type_declaration kwd f x =
+    let { pci_params=ls; pci_name={ txt; _ }; _ } = x in
+    pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd
+      virtual_flag x.pci_virt
+      (class_params_def ctxt) ls txt
+      (class_type ctxt) x.pci_expr
+      (item_attributes ctxt) x.pci_attributes
+  in
+  match l with
+  | [] -> ()
+  | [x] -> class_type_declaration "class type" f x
+  | x :: xs ->
+      pp f "@[<v>%a@,%a@]"
+        (class_type_declaration "class type") x
+        (list ~sep:"@," (class_type_declaration "and")) xs
+
+and class_field ctxt f x =
+  match x.pcf_desc with
+  | Pcf_inherit (ovf, ce, so) ->
+      pp f "@[<2>inherit@ %s@ %a%a@]%a" (override ovf)
+        (class_expr ctxt) ce
+        (fun f so -> match so with
+           | None -> ();
+           | Some (s) -> pp f "@ as %s" s.txt ) so
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_val (s, mf, Cfk_concrete (ovf, e)) ->
+      pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf)
+        mutable_flag mf s.txt
+        (expression ctxt) e
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_method (s, pf, Cfk_virtual ct) ->
+      pp f "@[<2>method virtual %a %s :@;%a@]%a"
+        private_flag pf s.txt
+        (core_type ctxt) ct
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_val (s, mf, Cfk_virtual ct) ->
+      pp f "@[<2>val virtual %a%s :@ %a@]%a"
+        mutable_flag mf s.txt
+        (core_type ctxt) ct
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_method (s, pf, Cfk_concrete (ovf, e)) ->
+      let bind e =
+        binding ctxt f
+          {pvb_pat=
+             {ppat_desc=Ppat_var s;
+              ppat_loc=Location.none;
+              ppat_loc_stack=[];
+              ppat_attributes=[]};
+           pvb_expr=e;
+           pvb_attributes=[];
+           pvb_loc=Location.none;
+          }
+      in
+      pp f "@[<2>method%s %a%a@]%a"
+        (override ovf)
+        private_flag pf
+        (fun f -> function
+           | {pexp_desc=Pexp_poly (e, Some ct); pexp_attributes=[]; _} ->
+               pp f "%s :@;%a=@;%a"
+                 s.txt (core_type ctxt) ct (expression ctxt) e
+           | {pexp_desc=Pexp_poly (e, None); pexp_attributes=[]; _} ->
+               bind e
+           | _ -> bind e) e
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_constraint (ct1, ct2) ->
+      pp f "@[<2>constraint %a =@;%a@]%a"
+        (core_type ctxt) ct1
+        (core_type ctxt) ct2
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_initializer (e) ->
+      pp f "@[<2>initializer@ %a@]%a"
+        (expression ctxt) e
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_attribute a -> floating_attribute ctxt f a
+  | Pcf_extension e ->
+      item_extension ctxt f e;
+      item_attributes ctxt f x.pcf_attributes
+
+and class_structure ctxt f { pcstr_self = p; pcstr_fields =  l } =
+  pp f "@[<hv0>@[<hv2>object%a@;%a@]@;end@]"
+    (fun f p -> match p.ppat_desc with
+       | Ppat_any -> ()
+       | Ppat_constraint _ -> pp f " %a" (pattern ctxt) p
+       | _ -> pp f " (%a)" (pattern ctxt) p) p
+    (list (class_field ctxt)) l
+
+and class_expr ctxt f x =
+  if x.pcl_attributes <> [] then begin
+    pp f "((%a)%a)" (class_expr ctxt) {x with pcl_attributes=[]}
+      (attributes ctxt) x.pcl_attributes
+  end else
+    match x.pcl_desc with
+    | Pcl_structure (cs) -> class_structure ctxt f cs
+    | Pcl_fun (l, eo, p, e) ->
+        pp f "fun@ %a@ ->@ %a"
+          (label_exp ctxt) (l,eo,p)
+          (class_expr ctxt) e
+    | Pcl_let (rf, l, ce) ->
+        pp f "%a@ in@ %a"
+          (bindings ctxt) (rf,l)
+          (class_expr ctxt) ce
+    | Pcl_apply (ce, l) ->
+        pp f "((%a)@ %a)" (* Cf: #7200 *)
+          (class_expr ctxt) ce
+          (list (label_x_expression_param ctxt)) l
+    | Pcl_constr (li, l) ->
+        pp f "%a%a"
+          (fun f l-> if l <>[] then
+              pp f "[%a]@ "
+                (list (core_type ctxt) ~sep:",") l) l
+          longident_loc li
+    | Pcl_constraint (ce, ct) ->
+        pp f "(%a@ :@ %a)"
+          (class_expr ctxt) ce
+          (class_type ctxt) ct
+    | Pcl_extension e -> extension ctxt f e
+    | Pcl_open (o, e) ->
+        pp f "@[<2>let open%s %a in@;%a@]"
+          (override o.popen_override) longident_loc o.popen_expr
+          (class_expr ctxt) e
+
+and module_type ctxt f x =
+  if x.pmty_attributes <> [] then begin
+    pp f "((%a)%a)" (module_type ctxt) {x with pmty_attributes=[]}
+      (attributes ctxt) x.pmty_attributes
+  end else
+    match x.pmty_desc with
+    | Pmty_functor (Unit, mt2) ->
+        pp f "@[<hov2>functor () ->@ %a@]" (module_type ctxt) mt2
+    | Pmty_functor (Named (s, mt1), mt2) ->
+        begin match s.txt with
+        | None ->
+            pp f "@[<hov2>%a@ ->@ %a@]"
+              (module_type1 ctxt) mt1 (module_type ctxt) mt2
+        | Some name ->
+            pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" name
+              (module_type ctxt) mt1 (module_type ctxt) mt2
+        end
+    | Pmty_with (mt, []) -> module_type ctxt f mt
+    | Pmty_with (mt, l) ->
+        pp f "@[<hov2>%a@ with@ %a@]"
+          (module_type1 ctxt) mt
+          (list (with_constraint ctxt) ~sep:"@ and@ ") l
+    | _ -> module_type1 ctxt f x
+
+and with_constraint ctxt f = function
+  | Pwith_type (li, ({ptype_params= ls ;_} as td)) ->
+      let ls = List.map fst ls in
+      pp f "type@ %a %a =@ %a"
+        (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")")
+        ls longident_loc li (type_declaration ctxt) td
+  | Pwith_module (li, li2) ->
+      pp f "module %a =@ %a" longident_loc li longident_loc li2;
+  | Pwith_modtype (li, mty) ->
+      pp f "module type %a =@ %a" longident_loc li (module_type ctxt) mty;
+  | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) ->
+      let ls = List.map fst ls in
+      pp f "type@ %a %a :=@ %a"
+        (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")")
+        ls longident_loc li
+        (type_declaration ctxt) td
+  | Pwith_modsubst (li, li2) ->
+      pp f "module %a :=@ %a" longident_loc li longident_loc li2
+  | Pwith_modtypesubst (li, mty) ->
+      pp f "module type %a :=@ %a" longident_loc li (module_type ctxt) mty;
+
+
+and module_type1 ctxt f x =
+  if x.pmty_attributes <> [] then module_type ctxt f x
+  else match x.pmty_desc with
+    | Pmty_ident li ->
+        pp f "%a" longident_loc li;
+    | Pmty_alias li ->
+        pp f "(module %a)" longident_loc li;
+    | Pmty_signature (s) ->
+        pp f "@[<hv0>@[<hv2>sig@ %a@]@ end@]" (* "@[<hov>sig@ %a@ end@]" *)
+          (list (signature_item ctxt)) s (* FIXME wrong indentation*)
+    | Pmty_typeof me ->
+        pp f "@[<hov2>module@ type@ of@ %a@]" (module_expr ctxt) me
+    | Pmty_extension e -> extension ctxt f e
+    | _ -> paren true (module_type ctxt) f x
+
+and signature ctxt f x =  list ~sep:"@\n" (signature_item ctxt) f x
+
+and signature_item ctxt f x : unit =
+  match x.psig_desc with
+  | Psig_type (rf, l) ->
+      type_def_list ctxt f (rf, true, l)
+  | Psig_typesubst l ->
+      (* Psig_typesubst is never recursive, but we specify [Recursive] here to
+         avoid printing a [nonrec] flag, which would be rejected by the parser.
+      *)
+      type_def_list ctxt f (Recursive, false, l)
+  | Psig_value vd ->
+      let intro = if vd.pval_prim = [] then "val" else "external" in
+      pp f "@[<2>%s@ %a@ :@ %a@]%a" intro
+        protect_ident vd.pval_name.txt
+        (value_description ctxt) vd
+        (item_attributes ctxt) vd.pval_attributes
+  | Psig_typext te ->
+      type_extension ctxt f te
+  | Psig_exception ed ->
+      exception_declaration ctxt f ed
+  | Psig_class l ->
+      let class_description kwd f ({pci_params=ls;pci_name={txt;_};_} as x) =
+        pp f "@[<2>%s %a%a%s@;:@;%a@]%a" kwd
+          virtual_flag x.pci_virt
+          (class_params_def ctxt) ls txt
+          (class_type ctxt) x.pci_expr
+          (item_attributes ctxt) x.pci_attributes
+      in begin
+        match l with
+        | [] -> ()
+        | [x] -> class_description "class" f x
+        | x :: xs ->
+            pp f "@[<v>%a@,%a@]"
+              (class_description "class") x
+              (list ~sep:"@," (class_description "and")) xs
+      end
+  | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias;
+                            pmty_attributes=[]; _};_} as pmd) ->
+      pp f "@[<hov>module@ %s@ =@ %a@]%a"
+        (Option.value pmd.pmd_name.txt ~default:"_")
+        longident_loc alias
+        (item_attributes ctxt) pmd.pmd_attributes
+  | Psig_module pmd ->
+      pp f "@[<hov>module@ %s@ :@ %a@]%a"
+        (Option.value pmd.pmd_name.txt ~default:"_")
+        (module_type ctxt) pmd.pmd_type
+        (item_attributes ctxt) pmd.pmd_attributes
+  | Psig_modsubst pms ->
+      pp f "@[<hov>module@ %s@ :=@ %a@]%a" pms.pms_name.txt
+        longident_loc pms.pms_manifest
+        (item_attributes ctxt) pms.pms_attributes
+  | Psig_open od ->
+      pp f "@[<hov2>open%s@ %a@]%a"
+        (override od.popen_override)
+        longident_loc od.popen_expr
+        (item_attributes ctxt) od.popen_attributes
+  | Psig_include incl ->
+      pp f "@[<hov2>include@ %a@]%a"
+        (module_type ctxt) incl.pincl_mod
+        (item_attributes ctxt) incl.pincl_attributes
+  | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
+      pp f "@[<hov2>module@ type@ %s%a@]%a"
+        s.txt
+        (fun f md -> match md with
+           | None -> ()
+           | Some mt ->
+               pp_print_space f () ;
+               pp f "@ =@ %a" (module_type ctxt) mt
+        ) md
+        (item_attributes ctxt) attrs
+  | Psig_modtypesubst {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
+      let md = match md with
+        | None -> assert false (* ast invariant *)
+        | Some mt -> mt in
+      pp f "@[<hov2>module@ type@ %s@ :=@ %a@]%a"
+        s.txt (module_type ctxt) md
+        (item_attributes ctxt) attrs
+  | Psig_class_type (l) -> class_type_declaration_list ctxt f l
+  | Psig_recmodule decls ->
+      let rec  string_x_module_type_list f ?(first=true) l =
+        match l with
+        | [] -> () ;
+        | pmd :: tl ->
+            if not first then
+              pp f "@ @[<hov2>and@ %s:@ %a@]%a"
+                (Option.value pmd.pmd_name.txt ~default:"_")
+                (module_type1 ctxt) pmd.pmd_type
+                (item_attributes ctxt) pmd.pmd_attributes
+            else
+              pp f "@[<hov2>module@ rec@ %s:@ %a@]%a"
+                (Option.value pmd.pmd_name.txt ~default:"_")
+                (module_type1 ctxt) pmd.pmd_type
+                (item_attributes ctxt) pmd.pmd_attributes;
+            string_x_module_type_list f ~first:false tl
+      in
+      string_x_module_type_list f decls
+  | Psig_attribute a -> floating_attribute ctxt f a
+  | Psig_extension(e, a) ->
+      item_extension ctxt f e;
+      item_attributes ctxt f a
+
+and module_expr ctxt f x =
+  if x.pmod_attributes <> [] then
+    pp f "((%a)%a)" (module_expr ctxt) {x with pmod_attributes=[]}
+      (attributes ctxt) x.pmod_attributes
+  else match x.pmod_desc with
+    | Pmod_structure (s) ->
+        pp f "@[<hv2>struct@;@[<0>%a@]@;<1 -2>end@]"
+          (list (structure_item ctxt) ~sep:"@\n") s;
+    | Pmod_constraint (me, mt) ->
+        pp f "@[<hov2>(%a@ :@ %a)@]"
+          (module_expr ctxt) me
+          (module_type ctxt) mt
+    | Pmod_ident (li) ->
+        pp f "%a" longident_loc li;
+    | Pmod_functor (Unit, me) ->
+        pp f "functor ()@;->@;%a" (module_expr ctxt) me
+    | Pmod_functor (Named (s, mt), me) ->
+        pp f "functor@ (%s@ :@ %a)@;->@;%a"
+          (Option.value s.txt ~default:"_")
+          (module_type ctxt) mt (module_expr ctxt) me
+    | Pmod_apply (me1, me2) ->
+        pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2
+        (* Cf: #7200 *)
+    | Pmod_unpack e ->
+        pp f "(val@ %a)" (expression ctxt) e
+    | Pmod_extension ({ txt; _ }, _) when txt = Ast_helper.hole_txt ->
+        pp f "_"
+    | Pmod_extension e -> extension ctxt f e
+
+and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x
+
+and payload ctxt f = function
+  | PStr [{pstr_desc = Pstr_eval (e, attrs)}] ->
+      pp f "@[<2>%a@]%a"
+        (expression ctxt) e
+        (item_attributes ctxt) attrs
+  | PStr x -> structure ctxt f x
+  | PTyp x -> pp f ":@ "; core_type ctxt f x
+  | PSig x -> pp f ":@ "; signature ctxt f x
+  | PPat (x, None) -> pp f "?"; pattern ctxt f x
+  | PPat (x, Some e) ->
+      pp f "?@ "; pattern ctxt f x;
+      pp f " when "; expression ctxt f e
+
+(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *)
+and binding ctxt f {pvb_pat=p; pvb_expr=x; _} =
+  (* .pvb_attributes have already been printed by the caller, #bindings *)
+  let rec pp_print_pexp_function f x =
+    if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x
+    else match x.pexp_desc with
+      | Pexp_fun (label, eo, p, e) ->
+          if label=Nolabel then
+            pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e
+          else
+            pp f "%a@ %a"
+              (label_exp ctxt) (label,eo,p) pp_print_pexp_function e
+      | Pexp_newtype (str,e) ->
+          pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e
+      | _ -> pp f "=@;%a" (expression ctxt) x
+  in
+  let tyvars_str tyvars = List.map (fun v -> v.txt) tyvars in
+  let is_desugared_gadt p e =
+    let gadt_pattern =
+      match p with
+      | {ppat_desc=Ppat_constraint({ppat_desc=Ppat_var _} as pat,
+                                   {ptyp_desc=Ptyp_poly (args_tyvars, rt)});
+         ppat_attributes=[]}->
+          Some (pat, args_tyvars, rt)
+      | _ -> None in
+    let rec gadt_exp tyvars e =
+      match e with
+      | {pexp_desc=Pexp_newtype (tyvar, e); pexp_attributes=[]} ->
+          gadt_exp (tyvar :: tyvars) e
+      | {pexp_desc=Pexp_constraint (e, ct); pexp_attributes=[]} ->
+          Some (List.rev tyvars, e, ct)
+      | _ -> None in
+    let gadt_exp = gadt_exp [] e in
+    match gadt_pattern, gadt_exp with
+    | Some (p, pt_tyvars, pt_ct), Some (e_tyvars, e, e_ct)
+      when tyvars_str pt_tyvars = tyvars_str e_tyvars ->
+      let ety = Typ.varify_constructors e_tyvars e_ct in
+      if ety = pt_ct then
+      Some (p, pt_tyvars, e_ct, e) else None
+    | _ -> None in
+  if x.pexp_attributes <> []
+  then
+    match p with
+    | {ppat_desc=Ppat_constraint({ppat_desc=Ppat_var _; _} as pat,
+				 ({ptyp_desc=Ptyp_poly _; _} as typ));
+       ppat_attributes=[]; _} ->
+	pp f "%a@;: %a@;=@;%a"
+	  (simple_pattern ctxt) pat (core_type ctxt) typ (expression ctxt) x
+    | _ ->
+	pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x
+  else
+  match is_desugared_gadt p x with
+  | Some (p, [], ct, e) ->
+      pp f "%a@;: %a@;=@;%a"
+        (simple_pattern ctxt) p (core_type ctxt) ct (expression ctxt) e
+  | Some (p, tyvars, ct, e) -> begin
+    pp f "%a@;: type@;%a.@;%a@;=@;%a"
+    (simple_pattern ctxt) p (list pp_print_string ~sep:"@;")
+    (tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e
+    end
+  | None -> begin
+      match p with
+      | {ppat_desc=Ppat_constraint(p ,ty);
+         ppat_attributes=[]} -> (* special case for the first*)
+          begin match ty with
+          | {ptyp_desc=Ptyp_poly _; ptyp_attributes=[]} ->
+              pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p
+                (core_type ctxt) ty (expression ctxt) x
+          | _ ->
+              pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p
+                (core_type ctxt) ty (expression ctxt) x
+          end
+      | {ppat_desc=Ppat_var _; ppat_attributes=[]} ->
+          pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x
+      | _ ->
+          pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x
+    end
+
+(* [in] is not printed *)
+and bindings ctxt f (rf,l) =
+  let binding kwd rf f x =
+    pp f "@[<2>%s %a%a@]%a" kwd rec_flag rf
+      (binding ctxt) x (item_attributes ctxt) x.pvb_attributes
+  in
+  match l with
+  | [] -> ()
+  | [x] -> binding "let" rf f x
+  | x::xs ->
+      pp f "@[<v>%a@,%a@]"
+        (binding "let" rf) x
+        (list ~sep:"@," (binding "and" Nonrecursive)) xs
+
+and binding_op ctxt f x =
+  match x.pbop_pat, x.pbop_exp with
+  | {ppat_desc = Ppat_var { txt=pvar; _ }; ppat_attributes = []; _},
+    {pexp_desc = Pexp_ident { txt=Lident evar; _}; pexp_attributes = []; _}
+       when pvar = evar ->
+     pp f "@[<2>%s %s@]" x.pbop_op.txt evar
+  | pat, exp ->
+     pp f "@[<2>%s %a@;=@;%a@]"
+       x.pbop_op.txt (pattern ctxt) pat (expression ctxt) exp
+
+and structure_item ctxt f x =
+  match x.pstr_desc with
+  | Pstr_eval (e, attrs) ->
+      pp f "@[<hov2>;;%a@]%a"
+        (expression ctxt) e
+        (item_attributes ctxt) attrs
+  | Pstr_type (_, []) -> assert false
+  | Pstr_type (rf, l)  -> type_def_list ctxt f (rf, true, l)
+  | Pstr_value (rf, l) ->
+      (* pp f "@[<hov2>let %a%a@]"  rec_flag rf bindings l *)
+      pp f "@[<2>%a@]" (bindings ctxt) (rf,l)
+  | Pstr_typext te -> type_extension ctxt f te
+  | Pstr_exception ed -> exception_declaration ctxt f ed
+  | Pstr_module x ->
+      let rec module_helper = function
+        | {pmod_desc=Pmod_functor(arg_opt,me'); pmod_attributes = []} ->
+            begin match arg_opt with
+            | Unit -> pp f "()"
+            | Named (s, mt) ->
+              pp f "(%s:%a)" (Option.value s.txt ~default:"_")
+                (module_type ctxt) mt
+            end;
+            module_helper me'
+        | me -> me
+      in
+      pp f "@[<hov2>module %s%a@]%a"
+        (Option.value x.pmb_name.txt ~default:"_")
+        (fun f me ->
+           let me = module_helper me in
+           match me with
+           | {pmod_desc=
+                Pmod_constraint
+                  (me',
+                   ({pmty_desc=(Pmty_ident (_)
+                               | Pmty_signature (_));_} as mt));
+              pmod_attributes = []} ->
+               pp f " :@;%a@;=@;%a@;"
+                 (module_type ctxt) mt (module_expr ctxt) me'
+           | _ -> pp f " =@ %a" (module_expr ctxt) me
+        ) x.pmb_expr
+        (item_attributes ctxt) x.pmb_attributes
+  | Pstr_open od ->
+      pp f "@[<2>open%s@;%a@]%a"
+        (override od.popen_override)
+        (module_expr ctxt) od.popen_expr
+        (item_attributes ctxt) od.popen_attributes
+  | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
+      pp f "@[<hov2>module@ type@ %s%a@]%a"
+        s.txt
+        (fun f md -> match md with
+           | None -> ()
+           | Some mt ->
+               pp_print_space f () ;
+               pp f "@ =@ %a" (module_type ctxt) mt
+        ) md
+        (item_attributes ctxt) attrs
+  | Pstr_class l ->
+      let extract_class_args cl =
+        let rec loop acc = function
+          | {pcl_desc=Pcl_fun (l, eo, p, cl'); pcl_attributes = []} ->
+              loop ((l,eo,p) :: acc) cl'
+          | cl -> List.rev acc, cl
+        in
+        let args, cl = loop [] cl in
+        let constr, cl =
+          match cl with
+          | {pcl_desc=Pcl_constraint (cl', ct); pcl_attributes = []} ->
+              Some ct, cl'
+          | _ -> None, cl
+        in
+        args, constr, cl
+      in
+      let class_constraint f ct = pp f ": @[%a@] " (class_type ctxt) ct in
+      let class_declaration kwd f
+          ({pci_params=ls; pci_name={txt;_}; _} as x) =
+        let args, constr, cl = extract_class_args x.pci_expr in
+        pp f "@[<2>%s %a%a%s %a%a=@;%a@]%a" kwd
+          virtual_flag x.pci_virt
+          (class_params_def ctxt) ls txt
+          (list (label_exp ctxt)) args
+          (option class_constraint) constr
+          (class_expr ctxt) cl
+          (item_attributes ctxt) x.pci_attributes
+      in begin
+        match l with
+        | [] -> ()
+        | [x] -> class_declaration "class" f x
+        | x :: xs ->
+            pp f "@[<v>%a@,%a@]"
+              (class_declaration "class") x
+              (list ~sep:"@," (class_declaration "and")) xs
+      end
+  | Pstr_class_type l -> class_type_declaration_list ctxt f l
+  | Pstr_primitive vd ->
+      pp f "@[<hov2>external@ %a@ :@ %a@]%a"
+        protect_ident vd.pval_name.txt
+        (value_description ctxt) vd
+        (item_attributes ctxt) vd.pval_attributes
+  | Pstr_include incl ->
+      pp f "@[<hov2>include@ %a@]%a"
+        (module_expr ctxt) incl.pincl_mod
+        (item_attributes ctxt) incl.pincl_attributes
+  | Pstr_recmodule decls -> (* 3.07 *)
+      let aux f = function
+        | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) ->
+            pp f "@[<hov2>@ and@ %s:%a@ =@ %a@]%a"
+              (Option.value pmb.pmb_name.txt ~default:"_")
+              (module_type ctxt) typ
+              (module_expr ctxt) expr
+              (item_attributes ctxt) pmb.pmb_attributes
+        | pmb ->
+            pp f "@[<hov2>@ and@ %s@ =@ %a@]%a"
+              (Option.value pmb.pmb_name.txt ~default:"_")
+              (module_expr ctxt) pmb.pmb_expr
+              (item_attributes ctxt) pmb.pmb_attributes
+      in
+      begin match decls with
+      | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 ->
+          pp f "@[<hv>@[<hov2>module@ rec@ %s:%a@ =@ %a@]%a@ %a@]"
+            (Option.value pmb.pmb_name.txt ~default:"_")
+            (module_type ctxt) typ
+            (module_expr ctxt) expr
+            (item_attributes ctxt) pmb.pmb_attributes
+            (fun f l2 -> List.iter (aux f) l2) l2
+      | pmb :: l2 ->
+          pp f "@[<hv>@[<hov2>module@ rec@ %s@ =@ %a@]%a@ %a@]"
+            (Option.value pmb.pmb_name.txt ~default:"_")
+            (module_expr ctxt) pmb.pmb_expr
+            (item_attributes ctxt) pmb.pmb_attributes
+            (fun f l2 -> List.iter (aux f) l2) l2
+      | _ -> assert false
+      end
+  | Pstr_attribute a -> floating_attribute ctxt f a
+  | Pstr_extension(e, a) ->
+      item_extension ctxt f e;
+      item_attributes ctxt f a
+
+and type_param ctxt f (ct, (a,b)) =
+  pp f "%s%s%a" (type_variance a) (type_injectivity b) (core_type ctxt) ct
+
+and type_params ctxt f = function
+  | [] -> ()
+  | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l
+
+and type_def_list ctxt f (rf, exported, l) =
+  let type_decl kwd rf f x =
+    let eq =
+      if (x.ptype_kind = Ptype_abstract)
+         && (x.ptype_manifest = None) then ""
+      else if exported then " ="
+      else " :="
+    in
+    pp f "@[<2>%s %a%a%s%s%a@]%a" kwd
+      nonrec_flag rf
+      (type_params ctxt) x.ptype_params
+      x.ptype_name.txt eq
+      (type_declaration ctxt) x
+      (item_attributes ctxt) x.ptype_attributes
+  in
+  match l with
+  | [] -> assert false
+  | [x] -> type_decl "type" rf f x
+  | x :: xs -> pp f "@[<v>%a@,%a@]"
+                 (type_decl "type" rf) x
+                 (list ~sep:"@," (type_decl "and" Recursive)) xs
+
+and record_declaration ctxt f lbls =
+  let type_record_field f pld =
+    pp f "@[<2>%a%s:@;%a@;%a@]"
+      mutable_flag pld.pld_mutable
+      pld.pld_name.txt
+      (core_type ctxt) pld.pld_type
+      (attributes ctxt) pld.pld_attributes
+  in
+  pp f "{@\n%a}"
+    (list type_record_field ~sep:";@\n" )  lbls
+
+and type_declaration ctxt f x =
+  (* type_declaration has an attribute field,
+     but it's been printed by the caller of this method *)
+  let priv f =
+    match x.ptype_private with
+    | Public -> ()
+    | Private -> pp f "@;private"
+  in
+  let manifest f =
+    match x.ptype_manifest with
+    | None -> ()
+    | Some y ->
+        if x.ptype_kind = Ptype_abstract then
+          pp f "%t@;%a" priv (core_type ctxt) y
+        else
+          pp f "@;%a" (core_type ctxt) y
+  in
+  let constructor_declaration f pcd =
+    pp f "|@;";
+    constructor_declaration ctxt f
+      (pcd.pcd_name.txt, pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes)
+  in
+  let repr f =
+    let intro f =
+      if x.ptype_manifest = None then ()
+      else pp f "@;="
+    in
+    match x.ptype_kind with
+    | Ptype_variant xs ->
+      let variants fmt xs =
+        if xs = [] then pp fmt " |" else
+          pp fmt "@\n%a" (list ~sep:"@\n" constructor_declaration) xs
+      in pp f "%t%t%a" intro priv variants xs
+    | Ptype_abstract -> ()
+    | Ptype_record l ->
+        pp f "%t%t@;%a" intro priv (record_declaration ctxt) l
+    | Ptype_open -> pp f "%t%t@;.." intro priv
+  in
+  let constraints f =
+    List.iter
+      (fun (ct1,ct2,_) ->
+         pp f "@[<hov2>@ constraint@ %a@ =@ %a@]"
+           (core_type ctxt) ct1 (core_type ctxt) ct2)
+      x.ptype_cstrs
+  in
+  pp f "%t%t%t" manifest repr constraints
+
+and type_extension ctxt f x =
+  let extension_constructor f x =
+    pp f "@\n|@;%a" (extension_constructor ctxt) x
+  in
+  pp f "@[<2>type %a%a += %a@ %a@]%a"
+    (fun f -> function
+       | [] -> ()
+       | l ->
+           pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l)
+    x.ptyext_params
+    longident_loc x.ptyext_path
+    private_flag x.ptyext_private (* Cf: #7200 *)
+    (list ~sep:"" extension_constructor)
+    x.ptyext_constructors
+    (item_attributes ctxt) x.ptyext_attributes
+
+and constructor_declaration ctxt f (name, args, res, attrs) =
+  let name =
+    match name with
+    | "::" -> "(::)"
+    | s -> s in
+  match res with
+  | None ->
+      pp f "%s%a@;%a" name
+        (fun f -> function
+           | Pcstr_tuple [] -> ()
+           | Pcstr_tuple l ->
+             pp f "@;of@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l
+           | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l
+        ) args
+        (attributes ctxt) attrs
+  | Some r ->
+      pp f "%s:@;%a@;%a" name
+        (fun f -> function
+           | Pcstr_tuple [] -> core_type1 ctxt f r
+           | Pcstr_tuple l -> pp f "%a@;->@;%a"
+                                (list (core_type1 ctxt) ~sep:"@;*@;") l
+                                (core_type1 ctxt) r
+           | Pcstr_record l ->
+               pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r
+        )
+        args
+        (attributes ctxt) attrs
+
+and extension_constructor ctxt f x =
+  (* Cf: #7200 *)
+  match x.pext_kind with
+  | Pext_decl(l, r) ->
+      constructor_declaration ctxt f (x.pext_name.txt, l, r, x.pext_attributes)
+  | Pext_rebind li ->
+      pp f "%s@;=@;%a%a" x.pext_name.txt
+        longident_loc li
+        (attributes ctxt) x.pext_attributes
+
+and case_list ctxt f l : unit =
+  let aux f {pc_lhs; pc_guard; pc_rhs} =
+    pp f "@;| @[<2>%a%a@;->@;%a@]"
+      (pattern ctxt) pc_lhs (option (expression ctxt) ~first:"@;when@;")
+      pc_guard (expression (under_pipe ctxt)) pc_rhs
+  in
+  list aux f l ~sep:""
+
+and label_x_expression_param ctxt f (l,e) =
+  let simple_name = match e with
+    | {pexp_desc=Pexp_ident {txt=Lident l;_};
+       pexp_attributes=[]} -> Some l
+    | _ -> None
+  in match l with
+  | Nolabel  -> expression2 ctxt f e (* level 2*)
+  | Optional str ->
+      if Some str = simple_name then
+        pp f "?%s" str
+      else
+        pp f "?%s:%a" str (simple_expr ctxt) e
+  | Labelled lbl ->
+      if Some lbl = simple_name then
+        pp f "~%s" lbl
+      else
+        pp f "~%s:%a" lbl (simple_expr ctxt) e
+
+and directive_argument f x =
+  match x.pdira_desc with
+  | Pdir_string (s) -> pp f "@ %S" s
+  | Pdir_int (n, None) -> pp f "@ %s" n
+  | Pdir_int (n, Some m) -> pp f "@ %s%c" n m
+  | Pdir_ident (li) -> pp f "@ %a" longident li
+  | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b)
+
+let toplevel_phrase f x =
+  match x with
+  | Ptop_def (s) ->pp f "@[<hov0>%a@]"  (list (structure_item reset_ctxt)) s
+   (* pp_open_hvbox f 0; *)
+   (* pp_print_list structure_item f s ; *)
+   (* pp_close_box f (); *)
+  | Ptop_dir {pdir_name; pdir_arg = None; _} ->
+   pp f "@[<hov2>#%s@]" pdir_name.txt
+  | Ptop_dir {pdir_name; pdir_arg = Some pdir_arg; _} ->
+   pp f "@[<hov2>#%s@ %a@]" pdir_name.txt directive_argument pdir_arg
+
+let expression f x =
+  pp f "@[%a@]" (expression reset_ctxt) x
+
+let string_of_expression x =
+  ignore (flush_str_formatter ()) ;
+  let f = str_formatter in
+  expression f x;
+  flush_str_formatter ()
+
+let string_of_structure x =
+  ignore (flush_str_formatter ());
+  let f = str_formatter in
+  structure reset_ctxt f x;
+  flush_str_formatter ()
+
+let top_phrase f x =
+  pp_print_newline f ();
+  toplevel_phrase f x;
+  pp f ";;";
+  pp_print_newline f ()
+
+let core_type = core_type reset_ctxt
+let pattern = pattern reset_ctxt
+let signature = signature reset_ctxt
+let structure = structure reset_ctxt
+let module_expr = module_expr reset_ctxt
+let case_list = case_list reset_ctxt
+
+let prepare_error err =
+  let source = Location.Parser in
+  let open Syntaxerr in
+  match err with
+  | Unclosed(opening_loc, opening, closing_loc, closing) ->
+      Location.errorf
+        ~source
+        ~loc:closing_loc
+        ~sub:[
+          Location.msg ~loc:opening_loc
+            "This '%s' might be unmatched" opening
+        ]
+        "Syntax error: '%s' expected" closing
+
+  | Expecting (loc, nonterm) ->
+      Location.errorf ~source ~loc "Syntax error: %s expected." nonterm
+  | Not_expecting (loc, nonterm) ->
+      Location.errorf ~source ~loc "Syntax error: %s not expected." nonterm
+  | Applicative_path loc ->
+      Location.errorf ~source ~loc
+        "Syntax error: applicative paths of the form F(X).t \
+         are not supported when the option -no-app-func is set."
+  | Variable_in_scope (loc, var) ->
+      Location.errorf ~source ~loc
+        "In this scoped type, variable %a \
+         is reserved for the local type %s."
+        tyvar var var
+  | Other loc ->
+      Location.errorf ~source ~loc "Syntax error"
+  | Ill_formed_ast (loc, s) ->
+      Location.errorf ~loc
+        "broken invariant in parsetree: %s" s
+  | Invalid_package_type (loc, s) ->
+      Location.errorf ~source ~loc "invalid package type: %s" s
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Syntaxerr.Error err -> Some (prepare_error err)
+      | _ -> None
+    )
diff --git a/src/ocaml/parsing/pprintast.mli b/src/ocaml/parsing/pprintast.mli
new file mode 100644
index 0000000..6288883
--- /dev/null
+++ b/src/ocaml/parsing/pprintast.mli
@@ -0,0 +1,49 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Hongbo Zhang (University of Pennsylvania)                  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+
+(** Pretty-printers for {!Parsetree}
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type space_formatter = (unit, Format.formatter, unit) format
+
+val longident : Format.formatter -> Longident.t -> unit
+val expression : Format.formatter -> Parsetree.expression -> unit
+val string_of_expression : Parsetree.expression -> string
+
+val pattern: Format.formatter -> Parsetree.pattern -> unit
+
+val core_type: Format.formatter -> Parsetree.core_type -> unit
+
+val signature: Format.formatter -> Parsetree.signature -> unit
+val structure: Format.formatter -> Parsetree.structure -> unit
+val string_of_structure: Parsetree.structure -> string
+
+val module_expr: Format.formatter -> Parsetree.module_expr -> unit
+
+val toplevel_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit
+val top_phrase: Format.formatter -> Parsetree.toplevel_phrase -> unit
+
+
+val tyvar: Format.formatter -> string -> unit
+  (** Print a type variable name, taking care of the special treatment
+      required for the single quote character in second position. *)
+
+(* merlin *)
+val case_list : Format.formatter -> Parsetree.case list -> unit
diff --git a/src/ocaml/parsing/printast.ml b/src/ocaml/parsing/printast.ml
new file mode 100644
index 0000000..647dfe9
--- /dev/null
+++ b/src/ocaml/parsing/printast.ml
@@ -0,0 +1,981 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*              Damien Doligez, projet Para, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes;;
+open Format;;
+open Lexing;;
+open Location;;
+open Parsetree;;
+
+let fmt_position with_name f l =
+  let fname = if with_name then l.pos_fname else "" in
+  if l.pos_lnum = -1
+  then fprintf f "%s[%d]" fname l.pos_cnum
+  else fprintf f "%s[%d,%d+%d]" fname l.pos_lnum l.pos_bol
+               (l.pos_cnum - l.pos_bol)
+;;
+
+let fmt_location f loc =
+  if not !Clflags.locations then ()
+  else begin
+    let p_2nd_name = loc.loc_start.pos_fname <> loc.loc_end.pos_fname in
+    fprintf f "(%a..%a)" (fmt_position true) loc.loc_start
+                         (fmt_position p_2nd_name) loc.loc_end;
+    if loc.loc_ghost then fprintf f " ghost";
+  end
+;;
+
+let rec fmt_longident_aux f x =
+  match x with
+  | Longident.Lident (s) -> fprintf f "%s" s;
+  | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s;
+  | Longident.Lapply (y, z) ->
+      fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z;
+;;
+
+let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x;;
+
+let fmt_longident_loc f (x : Longident.t loc) =
+  fprintf f "\"%a\" %a" fmt_longident_aux x.txt fmt_location x.loc;
+;;
+
+let fmt_string_loc f (x : string loc) =
+  fprintf f "\"%s\" %a" x.txt fmt_location x.loc;
+;;
+
+let fmt_str_opt_loc f (x : string option loc) =
+  fprintf f "\"%s\" %a" (Option.value x.txt ~default:"_") fmt_location x.loc;
+;;
+
+let fmt_char_option f = function
+  | None -> fprintf f "None"
+  | Some c -> fprintf f "Some %c" c
+
+let fmt_constant f x =
+  match x with
+  | Pconst_integer (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m;
+  | Pconst_char (c) -> fprintf f "PConst_char %02x" (Char.code c);
+  | Pconst_string (s, strloc, None) ->
+      fprintf f "PConst_string(%S,%a,None)" s fmt_location strloc ;
+  | Pconst_string (s, strloc, Some delim) ->
+      fprintf f "PConst_string (%S,%a,Some %S)" s fmt_location strloc delim;
+  | Pconst_float (s,m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m;
+;;
+
+let fmt_mutable_flag f x =
+  match x with
+  | Immutable -> fprintf f "Immutable";
+  | Mutable -> fprintf f "Mutable";
+;;
+
+let fmt_virtual_flag f x =
+  match x with
+  | Virtual -> fprintf f "Virtual";
+  | Concrete -> fprintf f "Concrete";
+;;
+
+let fmt_override_flag f x =
+  match x with
+  | Override -> fprintf f "Override";
+  | Fresh -> fprintf f "Fresh";
+;;
+
+let fmt_closed_flag f x =
+  match x with
+  | Closed -> fprintf f "Closed"
+  | Open -> fprintf f "Open"
+
+let fmt_rec_flag f x =
+  match x with
+  | Nonrecursive -> fprintf f "Nonrec";
+  | Recursive -> fprintf f "Rec";
+;;
+
+let fmt_direction_flag f x =
+  match x with
+  | Upto -> fprintf f "Up";
+  | Downto -> fprintf f "Down";
+;;
+
+let fmt_private_flag f x =
+  match x with
+  | Public -> fprintf f "Public";
+  | Private -> fprintf f "Private";
+;;
+
+let line i f s (*...*) =
+  fprintf f "%s" (String.make ((2*i) mod 72) ' ');
+  fprintf f s (*...*)
+;;
+
+let list i f ppf l =
+  match l with
+  | [] -> line i ppf "[]\n";
+  | _ :: _ ->
+     line i ppf "[\n";
+     List.iter (f (i+1) ppf) l;
+     line i ppf "]\n";
+;;
+
+let option i f ppf x =
+  match x with
+  | None -> line i ppf "None\n";
+  | Some x ->
+      line i ppf "Some\n";
+      f (i+1) ppf x;
+;;
+
+let longident_loc i ppf li = line i ppf "%a\n" fmt_longident_loc li;;
+let string i ppf s = line i ppf "\"%s\"\n" s;;
+let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s;;
+let str_opt_loc i ppf s = line i ppf "%a\n" fmt_str_opt_loc s;;
+let arg_label i ppf = function
+  | Nolabel -> line i ppf "Nolabel\n"
+  | Optional s -> line i ppf "Optional \"%s\"\n" s
+  | Labelled s -> line i ppf "Labelled \"%s\"\n" s
+;;
+
+let rec core_type i ppf x =
+  line i ppf "core_type %a\n" fmt_location x.ptyp_loc;
+  attributes i ppf x.ptyp_attributes;
+  let i = i+1 in
+  match x.ptyp_desc with
+  | Ptyp_any -> line i ppf "Ptyp_any\n";
+  | Ptyp_var (s) -> line i ppf "Ptyp_var %s\n" s;
+  | Ptyp_arrow (l, ct1, ct2) ->
+      line i ppf "Ptyp_arrow\n";
+      arg_label i ppf l;
+      core_type i ppf ct1;
+      core_type i ppf ct2;
+  | Ptyp_tuple l ->
+      line i ppf "Ptyp_tuple\n";
+      list i core_type ppf l;
+  | Ptyp_constr (li, l) ->
+      line i ppf "Ptyp_constr %a\n" fmt_longident_loc li;
+      list i core_type ppf l;
+  | Ptyp_variant (l, closed, low) ->
+      line i ppf "Ptyp_variant closed=%a\n" fmt_closed_flag closed;
+      list i label_x_bool_x_core_type_list ppf l;
+      option i (fun i -> list i string) ppf low
+  | Ptyp_object (l, c) ->
+      line i ppf "Ptyp_object %a\n" fmt_closed_flag c;
+      let i = i + 1 in
+      List.iter (fun field ->
+        match field.pof_desc with
+          | Otag (l, t) ->
+            line i ppf "method %s\n" l.txt;
+            attributes i ppf field.pof_attributes;
+            core_type (i + 1) ppf t
+          | Oinherit ct ->
+              line i ppf "Oinherit\n";
+              core_type (i + 1) ppf ct
+      ) l
+  | Ptyp_class (li, l) ->
+      line i ppf "Ptyp_class %a\n" fmt_longident_loc li;
+      list i core_type ppf l
+  | Ptyp_alias (ct, s) ->
+      line i ppf "Ptyp_alias \"%s\"\n" s;
+      core_type i ppf ct;
+  | Ptyp_poly (sl, ct) ->
+      line i ppf "Ptyp_poly%a\n"
+        (fun ppf ->
+           List.iter (fun x -> fprintf ppf " %a" Pprintast.tyvar x.txt)
+        )
+        sl;
+      core_type i ppf ct;
+  | Ptyp_package (s, l) ->
+      line i ppf "Ptyp_package %a\n" fmt_longident_loc s;
+      list i package_with ppf l;
+  | Ptyp_extension (s, arg) ->
+      line i ppf "Ptyp_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and package_with i ppf (s, t) =
+  line i ppf "with type %a\n" fmt_longident_loc s;
+  core_type i ppf t
+
+and pattern i ppf x =
+  line i ppf "pattern %a\n" fmt_location x.ppat_loc;
+  attributes i ppf x.ppat_attributes;
+  let i = i+1 in
+  match x.ppat_desc with
+  | Ppat_any -> line i ppf "Ppat_any\n";
+  | Ppat_var (s) -> line i ppf "Ppat_var %a\n" fmt_string_loc s;
+  | Ppat_alias (p, s) ->
+      line i ppf "Ppat_alias %a\n" fmt_string_loc s;
+      pattern i ppf p;
+  | Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c;
+  | Ppat_interval (c1, c2) ->
+      line i ppf "Ppat_interval %a..%a\n" fmt_constant c1 fmt_constant c2;
+  | Ppat_tuple (l) ->
+      line i ppf "Ppat_tuple\n";
+      list i pattern ppf l;
+  | Ppat_construct (li, po) ->
+      line i ppf "Ppat_construct %a\n" fmt_longident_loc li;
+      option i
+        (fun i ppf (vl, p) ->
+          list i string_loc ppf vl;
+          pattern i ppf p)
+        ppf po
+  | Ppat_variant (l, po) ->
+      line i ppf "Ppat_variant \"%s\"\n" l;
+      option i pattern ppf po;
+  | Ppat_record (l, c) ->
+      line i ppf "Ppat_record %a\n" fmt_closed_flag c;
+      list i longident_x_pattern ppf l;
+  | Ppat_array (l) ->
+      line i ppf "Ppat_array\n";
+      list i pattern ppf l;
+  | Ppat_or (p1, p2) ->
+      line i ppf "Ppat_or\n";
+      pattern i ppf p1;
+      pattern i ppf p2;
+  | Ppat_lazy p ->
+      line i ppf "Ppat_lazy\n";
+      pattern i ppf p;
+  | Ppat_constraint (p, ct) ->
+      line i ppf "Ppat_constraint\n";
+      pattern i ppf p;
+      core_type i ppf ct;
+  | Ppat_type (li) ->
+      line i ppf "Ppat_type\n";
+      longident_loc i ppf li
+  | Ppat_unpack s ->
+      line i ppf "Ppat_unpack %a\n" fmt_str_opt_loc s;
+  | Ppat_exception p ->
+      line i ppf "Ppat_exception\n";
+      pattern i ppf p
+  | Ppat_open (m,p) ->
+      line i ppf "Ppat_open \"%a\"\n" fmt_longident_loc m;
+      pattern i ppf p
+  | Ppat_extension (s, arg) ->
+      line i ppf "Ppat_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and expression i ppf x =
+  line i ppf "expression %a\n" fmt_location x.pexp_loc;
+  attributes i ppf x.pexp_attributes;
+  let i = i+1 in
+  match x.pexp_desc with
+  | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li;
+  | Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c;
+  | Pexp_let (rf, l, e) ->
+      line i ppf "Pexp_let %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l;
+      expression i ppf e;
+  | Pexp_function l ->
+      line i ppf "Pexp_function\n";
+      list i case ppf l;
+  | Pexp_fun (l, eo, p, e) ->
+      line i ppf "Pexp_fun\n";
+      arg_label i ppf l;
+      option i expression ppf eo;
+      pattern i ppf p;
+      expression i ppf e;
+  | Pexp_apply (e, l) ->
+      line i ppf "Pexp_apply\n";
+      expression i ppf e;
+      list i label_x_expression ppf l;
+  | Pexp_match (e, l) ->
+      line i ppf "Pexp_match\n";
+      expression i ppf e;
+      list i case ppf l;
+  | Pexp_try (e, l) ->
+      line i ppf "Pexp_try\n";
+      expression i ppf e;
+      list i case ppf l;
+  | Pexp_tuple (l) ->
+      line i ppf "Pexp_tuple\n";
+      list i expression ppf l;
+  | Pexp_construct (li, eo) ->
+      line i ppf "Pexp_construct %a\n" fmt_longident_loc li;
+      option i expression ppf eo;
+  | Pexp_variant (l, eo) ->
+      line i ppf "Pexp_variant \"%s\"\n" l;
+      option i expression ppf eo;
+  | Pexp_record (l, eo) ->
+      line i ppf "Pexp_record\n";
+      list i longident_x_expression ppf l;
+      option i expression ppf eo;
+  | Pexp_field (e, li) ->
+      line i ppf "Pexp_field\n";
+      expression i ppf e;
+      longident_loc i ppf li;
+  | Pexp_setfield (e1, li, e2) ->
+      line i ppf "Pexp_setfield\n";
+      expression i ppf e1;
+      longident_loc i ppf li;
+      expression i ppf e2;
+  | Pexp_array (l) ->
+      line i ppf "Pexp_array\n";
+      list i expression ppf l;
+  | Pexp_ifthenelse (e1, e2, eo) ->
+      line i ppf "Pexp_ifthenelse\n";
+      expression i ppf e1;
+      expression i ppf e2;
+      option i expression ppf eo;
+  | Pexp_sequence (e1, e2) ->
+      line i ppf "Pexp_sequence\n";
+      expression i ppf e1;
+      expression i ppf e2;
+  | Pexp_while (e1, e2) ->
+      line i ppf "Pexp_while\n";
+      expression i ppf e1;
+      expression i ppf e2;
+  | Pexp_for (p, e1, e2, df, e3) ->
+      line i ppf "Pexp_for %a\n" fmt_direction_flag df;
+      pattern i ppf p;
+      expression i ppf e1;
+      expression i ppf e2;
+      expression i ppf e3;
+  | Pexp_constraint (e, ct) ->
+      line i ppf "Pexp_constraint\n";
+      expression i ppf e;
+      core_type i ppf ct;
+  | Pexp_coerce (e, cto1, cto2) ->
+      line i ppf "Pexp_coerce\n";
+      expression i ppf e;
+      option i core_type ppf cto1;
+      core_type i ppf cto2;
+  | Pexp_send (e, s) ->
+      line i ppf "Pexp_send \"%s\"\n" s.txt;
+      expression i ppf e;
+  | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident_loc li;
+  | Pexp_setinstvar (s, e) ->
+      line i ppf "Pexp_setinstvar %a\n" fmt_string_loc s;
+      expression i ppf e;
+  | Pexp_override (l) ->
+      line i ppf "Pexp_override\n";
+      list i string_x_expression ppf l;
+  | Pexp_letmodule (s, me, e) ->
+      line i ppf "Pexp_letmodule %a\n" fmt_str_opt_loc s;
+      module_expr i ppf me;
+      expression i ppf e;
+  | Pexp_letexception (cd, e) ->
+      line i ppf "Pexp_letexception\n";
+      extension_constructor i ppf cd;
+      expression i ppf e;
+  | Pexp_assert (e) ->
+      line i ppf "Pexp_assert\n";
+      expression i ppf e;
+  | Pexp_lazy (e) ->
+      line i ppf "Pexp_lazy\n";
+      expression i ppf e;
+  | Pexp_poly (e, cto) ->
+      line i ppf "Pexp_poly\n";
+      expression i ppf e;
+      option i core_type ppf cto;
+  | Pexp_object s ->
+      line i ppf "Pexp_object\n";
+      class_structure i ppf s
+  | Pexp_newtype (s, e) ->
+      line i ppf "Pexp_newtype \"%s\"\n" s.txt;
+      expression i ppf e
+  | Pexp_pack me ->
+      line i ppf "Pexp_pack\n";
+      module_expr i ppf me
+  | Pexp_open (o, e) ->
+      line i ppf "Pexp_open %a\n" fmt_override_flag o.popen_override;
+      module_expr i ppf o.popen_expr;
+      expression i ppf e
+  | Pexp_letop {let_; ands; body} ->
+      line i ppf "Pexp_letop\n";
+      binding_op i ppf let_;
+      list i binding_op ppf ands;
+      expression i ppf body
+  | Pexp_extension (s, arg) ->
+      line i ppf "Pexp_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+  | Pexp_unreachable ->
+      line i ppf "Pexp_unreachable"
+
+and value_description i ppf x =
+  line i ppf "value_description %a %a\n" fmt_string_loc
+       x.pval_name fmt_location x.pval_loc;
+  attributes i ppf x.pval_attributes;
+  core_type (i+1) ppf x.pval_type;
+  list (i+1) string ppf x.pval_prim
+
+and type_parameter i ppf (x, _variance) = core_type i ppf x
+
+and type_declaration i ppf x =
+  line i ppf "type_declaration %a %a\n" fmt_string_loc x.ptype_name
+       fmt_location x.ptype_loc;
+  attributes i ppf x.ptype_attributes;
+  let i = i+1 in
+  line i ppf "ptype_params =\n";
+  list (i+1) type_parameter ppf x.ptype_params;
+  line i ppf "ptype_cstrs =\n";
+  list (i+1) core_type_x_core_type_x_location ppf x.ptype_cstrs;
+  line i ppf "ptype_kind =\n";
+  type_kind (i+1) ppf x.ptype_kind;
+  line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private;
+  line i ppf "ptype_manifest =\n";
+  option (i+1) core_type ppf x.ptype_manifest
+
+and attribute i ppf k a =
+  line i ppf "%s \"%s\"\n" k a.attr_name.txt;
+  payload i ppf a.attr_payload;
+
+and attributes i ppf l =
+  let i = i + 1 in
+  List.iter (fun a ->
+    line i ppf "attribute \"%s\"\n" a.attr_name.txt;
+    payload (i + 1) ppf a.attr_payload;
+  ) l;
+
+and payload i ppf = function
+  | PStr x -> structure i ppf x
+  | PSig x -> signature i ppf x
+  | PTyp x -> core_type i ppf x
+  | PPat (x, None) -> pattern i ppf x
+  | PPat (x, Some g) ->
+    pattern i ppf x;
+    line i ppf "<when>\n";
+    expression (i + 1) ppf g
+
+
+and type_kind i ppf x =
+  match x with
+  | Ptype_abstract ->
+      line i ppf "Ptype_abstract\n"
+  | Ptype_variant l ->
+      line i ppf "Ptype_variant\n";
+      list (i+1) constructor_decl ppf l;
+  | Ptype_record l ->
+      line i ppf "Ptype_record\n";
+      list (i+1) label_decl ppf l;
+  | Ptype_open ->
+      line i ppf "Ptype_open\n";
+
+and type_extension i ppf x =
+  line i ppf "type_extension\n";
+  attributes i ppf x.ptyext_attributes;
+  let i = i+1 in
+  line i ppf "ptyext_path = %a\n" fmt_longident_loc x.ptyext_path;
+  line i ppf "ptyext_params =\n";
+  list (i+1) type_parameter ppf x.ptyext_params;
+  line i ppf "ptyext_constructors =\n";
+  list (i+1) extension_constructor ppf x.ptyext_constructors;
+  line i ppf "ptyext_private = %a\n" fmt_private_flag x.ptyext_private;
+
+and type_exception i ppf x =
+  line i ppf "type_exception\n";
+  attributes i ppf x.ptyexn_attributes;
+  let i = i+1 in
+  line i ppf "ptyext_constructor =\n";
+  let i = i+1 in
+  extension_constructor i ppf x.ptyexn_constructor
+
+and extension_constructor i ppf x =
+  line i ppf "extension_constructor %a\n" fmt_location x.pext_loc;
+  attributes i ppf x.pext_attributes;
+  let i = i + 1 in
+  line i ppf "pext_name = \"%s\"\n" x.pext_name.txt;
+  line i ppf "pext_kind =\n";
+  extension_constructor_kind (i + 1) ppf x.pext_kind;
+
+and extension_constructor_kind i ppf x =
+  match x with
+      Pext_decl(a, r) ->
+        line i ppf "Pext_decl\n";
+        constructor_arguments (i+1) ppf a;
+        option (i+1) core_type ppf r;
+    | Pext_rebind li ->
+        line i ppf "Pext_rebind\n";
+        line (i+1) ppf "%a\n" fmt_longident_loc li;
+
+and class_type i ppf x =
+  line i ppf "class_type %a\n" fmt_location x.pcty_loc;
+  attributes i ppf x.pcty_attributes;
+  let i = i+1 in
+  match x.pcty_desc with
+  | Pcty_constr (li, l) ->
+      line i ppf "Pcty_constr %a\n" fmt_longident_loc li;
+      list i core_type ppf l;
+  | Pcty_signature (cs) ->
+      line i ppf "Pcty_signature\n";
+      class_signature i ppf cs;
+  | Pcty_arrow (l, co, cl) ->
+      line i ppf "Pcty_arrow\n";
+      arg_label i ppf l;
+      core_type i ppf co;
+      class_type i ppf cl;
+  | Pcty_extension (s, arg) ->
+      line i ppf "Pcty_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+  | Pcty_open (o, e) ->
+      line i ppf "Pcty_open %a %a\n" fmt_override_flag o.popen_override
+        fmt_longident_loc o.popen_expr;
+      class_type i ppf e
+
+and class_signature i ppf cs =
+  line i ppf "class_signature\n";
+  core_type (i+1) ppf cs.pcsig_self;
+  list (i+1) class_type_field ppf cs.pcsig_fields;
+
+and class_type_field i ppf x =
+  line i ppf "class_type_field %a\n" fmt_location x.pctf_loc;
+  let i = i+1 in
+  attributes i ppf x.pctf_attributes;
+  match x.pctf_desc with
+  | Pctf_inherit (ct) ->
+      line i ppf "Pctf_inherit\n";
+      class_type i ppf ct;
+  | Pctf_val (s, mf, vf, ct) ->
+      line i ppf "Pctf_val \"%s\" %a %a\n" s.txt fmt_mutable_flag mf
+           fmt_virtual_flag vf;
+      core_type (i+1) ppf ct;
+  | Pctf_method (s, pf, vf, ct) ->
+      line i ppf "Pctf_method \"%s\" %a %a\n" s.txt fmt_private_flag pf
+           fmt_virtual_flag vf;
+      core_type (i+1) ppf ct;
+  | Pctf_constraint (ct1, ct2) ->
+      line i ppf "Pctf_constraint\n";
+      core_type (i+1) ppf ct1;
+      core_type (i+1) ppf ct2;
+  | Pctf_attribute a ->
+      attribute i ppf "Pctf_attribute" a
+  | Pctf_extension (s, arg) ->
+      line i ppf "Pctf_extension \"%s\"\n" s.txt;
+     payload i ppf arg
+
+and class_description i ppf x =
+  line i ppf "class_description %a\n" fmt_location x.pci_loc;
+  attributes i ppf x.pci_attributes;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.pci_params;
+  line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
+  line i ppf "pci_expr =\n";
+  class_type (i+1) ppf x.pci_expr;
+
+and class_type_declaration i ppf x =
+  line i ppf "class_type_declaration %a\n" fmt_location x.pci_loc;
+  attributes i ppf x.pci_attributes;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.pci_params;
+  line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
+  line i ppf "pci_expr =\n";
+  class_type (i+1) ppf x.pci_expr;
+
+and class_expr i ppf x =
+  line i ppf "class_expr %a\n" fmt_location x.pcl_loc;
+  attributes i ppf x.pcl_attributes;
+  let i = i+1 in
+  match x.pcl_desc with
+  | Pcl_constr (li, l) ->
+      line i ppf "Pcl_constr %a\n" fmt_longident_loc li;
+      list i core_type ppf l;
+  | Pcl_structure (cs) ->
+      line i ppf "Pcl_structure\n";
+      class_structure i ppf cs;
+  | Pcl_fun (l, eo, p, e) ->
+      line i ppf "Pcl_fun\n";
+      arg_label i ppf l;
+      option i expression ppf eo;
+      pattern i ppf p;
+      class_expr i ppf e;
+  | Pcl_apply (ce, l) ->
+      line i ppf "Pcl_apply\n";
+      class_expr i ppf ce;
+      list i label_x_expression ppf l;
+  | Pcl_let (rf, l, ce) ->
+      line i ppf "Pcl_let %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l;
+      class_expr i ppf ce;
+  | Pcl_constraint (ce, ct) ->
+      line i ppf "Pcl_constraint\n";
+      class_expr i ppf ce;
+      class_type i ppf ct;
+  | Pcl_extension (s, arg) ->
+      line i ppf "Pcl_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+  | Pcl_open (o, e) ->
+      line i ppf "Pcl_open %a %a\n" fmt_override_flag o.popen_override
+        fmt_longident_loc o.popen_expr;
+      class_expr i ppf e
+
+and class_structure i ppf { pcstr_self = p; pcstr_fields = l } =
+  line i ppf "class_structure\n";
+  pattern (i+1) ppf p;
+  list (i+1) class_field ppf l;
+
+and class_field i ppf x =
+  line i ppf "class_field %a\n" fmt_location x.pcf_loc;
+  let i = i + 1 in
+  attributes i ppf x.pcf_attributes;
+  match x.pcf_desc with
+  | Pcf_inherit (ovf, ce, so) ->
+      line i ppf "Pcf_inherit %a\n" fmt_override_flag ovf;
+      class_expr (i+1) ppf ce;
+      option (i+1) string_loc ppf so;
+  | Pcf_val (s, mf, k) ->
+      line i ppf "Pcf_val %a\n" fmt_mutable_flag mf;
+      line (i+1) ppf "%a\n" fmt_string_loc s;
+      class_field_kind (i+1) ppf k
+  | Pcf_method (s, pf, k) ->
+      line i ppf "Pcf_method %a\n" fmt_private_flag pf;
+      line (i+1) ppf "%a\n" fmt_string_loc s;
+      class_field_kind (i+1) ppf k
+  | Pcf_constraint (ct1, ct2) ->
+      line i ppf "Pcf_constraint\n";
+      core_type (i+1) ppf ct1;
+      core_type (i+1) ppf ct2;
+  | Pcf_initializer (e) ->
+      line i ppf "Pcf_initializer\n";
+      expression (i+1) ppf e;
+  | Pcf_attribute a ->
+      attribute i ppf "Pcf_attribute" a
+  | Pcf_extension (s, arg) ->
+      line i ppf "Pcf_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and class_field_kind i ppf = function
+  | Cfk_concrete (o, e) ->
+      line i ppf "Concrete %a\n" fmt_override_flag o;
+      expression i ppf e
+  | Cfk_virtual t ->
+      line i ppf "Virtual\n";
+      core_type i ppf t
+
+and class_declaration i ppf x =
+  line i ppf "class_declaration %a\n" fmt_location x.pci_loc;
+  attributes i ppf x.pci_attributes;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.pci_params;
+  line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
+  line i ppf "pci_expr =\n";
+  class_expr (i+1) ppf x.pci_expr;
+
+and module_type i ppf x =
+  line i ppf "module_type %a\n" fmt_location x.pmty_loc;
+  attributes i ppf x.pmty_attributes;
+  let i = i+1 in
+  match x.pmty_desc with
+  | Pmty_ident li -> line i ppf "Pmty_ident %a\n" fmt_longident_loc li;
+  | Pmty_alias li -> line i ppf "Pmty_alias %a\n" fmt_longident_loc li;
+  | Pmty_signature (s) ->
+      line i ppf "Pmty_signature\n";
+      signature i ppf s;
+  | Pmty_functor (Unit, mt2) ->
+      line i ppf "Pmty_functor ()\n";
+      module_type i ppf mt2;
+  | Pmty_functor (Named (s, mt1), mt2) ->
+      line i ppf "Pmty_functor %a\n" fmt_str_opt_loc s;
+      module_type i ppf mt1;
+      module_type i ppf mt2;
+  | Pmty_with (mt, l) ->
+      line i ppf "Pmty_with\n";
+      module_type i ppf mt;
+      list i with_constraint ppf l;
+  | Pmty_typeof m ->
+      line i ppf "Pmty_typeof\n";
+      module_expr i ppf m;
+  | Pmty_extension (s, arg) ->
+      line i ppf "Pmod_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and signature i ppf x = list i signature_item ppf x
+
+and signature_item i ppf x =
+  line i ppf "signature_item %a\n" fmt_location x.psig_loc;
+  let i = i+1 in
+  match x.psig_desc with
+  | Psig_value vd ->
+      line i ppf "Psig_value\n";
+      value_description i ppf vd;
+  | Psig_type (rf, l) ->
+      line i ppf "Psig_type %a\n" fmt_rec_flag rf;
+      list i type_declaration ppf l;
+  | Psig_typesubst l ->
+      line i ppf "Psig_typesubst\n";
+      list i type_declaration ppf l;
+  | Psig_typext te ->
+      line i ppf "Psig_typext\n";
+      type_extension i ppf te
+  | Psig_exception te ->
+      line i ppf "Psig_exception\n";
+      type_exception i ppf te
+  | Psig_module pmd ->
+      line i ppf "Psig_module %a\n" fmt_str_opt_loc pmd.pmd_name;
+      attributes i ppf pmd.pmd_attributes;
+      module_type i ppf pmd.pmd_type
+  | Psig_modsubst pms ->
+      line i ppf "Psig_modsubst %a = %a\n"
+        fmt_string_loc pms.pms_name
+        fmt_longident_loc pms.pms_manifest;
+      attributes i ppf pms.pms_attributes;
+  | Psig_recmodule decls ->
+      line i ppf "Psig_recmodule\n";
+      list i module_declaration ppf decls;
+  | Psig_modtype x ->
+      line i ppf "Psig_modtype %a\n" fmt_string_loc x.pmtd_name;
+      attributes i ppf x.pmtd_attributes;
+      modtype_declaration i ppf x.pmtd_type
+  | Psig_modtypesubst x ->
+      line i ppf "Psig_modtypesubst %a\n" fmt_string_loc x.pmtd_name;
+      attributes i ppf x.pmtd_attributes;
+      modtype_declaration i ppf x.pmtd_type
+  | Psig_open od ->
+      line i ppf "Psig_open %a %a\n" fmt_override_flag od.popen_override
+        fmt_longident_loc od.popen_expr;
+      attributes i ppf od.popen_attributes
+  | Psig_include incl ->
+      line i ppf "Psig_include\n";
+      module_type i ppf incl.pincl_mod;
+      attributes i ppf incl.pincl_attributes
+  | Psig_class (l) ->
+      line i ppf "Psig_class\n";
+      list i class_description ppf l;
+  | Psig_class_type (l) ->
+      line i ppf "Psig_class_type\n";
+      list i class_type_declaration ppf l;
+  | Psig_extension ((s, arg), attrs) ->
+      line i ppf "Psig_extension \"%s\"\n" s.txt;
+      attributes i ppf attrs;
+      payload i ppf arg
+  | Psig_attribute a ->
+      attribute i ppf "Psig_attribute" a
+
+and modtype_declaration i ppf = function
+  | None -> line i ppf "#abstract"
+  | Some mt -> module_type (i+1) ppf mt
+
+and with_constraint i ppf x =
+  match x with
+  | Pwith_type (lid, td) ->
+      line i ppf "Pwith_type %a\n" fmt_longident_loc lid;
+      type_declaration (i+1) ppf td;
+  | Pwith_typesubst (lid, td) ->
+      line i ppf "Pwith_typesubst %a\n" fmt_longident_loc lid;
+      type_declaration (i+1) ppf td;
+  | Pwith_module (lid1, lid2) ->
+      line i ppf "Pwith_module %a = %a\n"
+        fmt_longident_loc lid1
+        fmt_longident_loc lid2;
+  | Pwith_modsubst (lid1, lid2) ->
+      line i ppf "Pwith_modsubst %a = %a\n"
+        fmt_longident_loc lid1
+        fmt_longident_loc lid2;
+  | Pwith_modtype (lid1, mty) ->
+      line i ppf "Pwith_modtype %a\n"
+        fmt_longident_loc lid1;
+      module_type (i+1) ppf mty
+  | Pwith_modtypesubst (lid1, mty) ->
+     line i ppf "Pwith_modtypesubst %a\n"
+        fmt_longident_loc lid1;
+      module_type (i+1) ppf mty
+
+and module_expr i ppf x =
+  line i ppf "module_expr %a\n" fmt_location x.pmod_loc;
+  attributes i ppf x.pmod_attributes;
+  let i = i+1 in
+  match x.pmod_desc with
+  | Pmod_ident (li) -> line i ppf "Pmod_ident %a\n" fmt_longident_loc li;
+  | Pmod_structure (s) ->
+      line i ppf "Pmod_structure\n";
+      structure i ppf s;
+  | Pmod_functor (Unit, me) ->
+      line i ppf "Pmod_functor ()\n";
+      module_expr i ppf me;
+  | Pmod_functor (Named (s, mt), me) ->
+      line i ppf "Pmod_functor %a\n" fmt_str_opt_loc s;
+      module_type i ppf mt;
+      module_expr i ppf me;
+  | Pmod_apply (me1, me2) ->
+      line i ppf "Pmod_apply\n";
+      module_expr i ppf me1;
+      module_expr i ppf me2;
+  | Pmod_constraint (me, mt) ->
+      line i ppf "Pmod_constraint\n";
+      module_expr i ppf me;
+      module_type i ppf mt;
+  | Pmod_unpack (e) ->
+      line i ppf "Pmod_unpack\n";
+      expression i ppf e;
+  | Pmod_extension (s, arg) ->
+      line i ppf "Pmod_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and structure i ppf x = list i structure_item ppf x
+
+and structure_item i ppf x =
+  line i ppf "structure_item %a\n" fmt_location x.pstr_loc;
+  let i = i+1 in
+  match x.pstr_desc with
+  | Pstr_eval (e, attrs) ->
+      line i ppf "Pstr_eval\n";
+      attributes i ppf attrs;
+      expression i ppf e;
+  | Pstr_value (rf, l) ->
+      line i ppf "Pstr_value %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l;
+  | Pstr_primitive vd ->
+      line i ppf "Pstr_primitive\n";
+      value_description i ppf vd;
+  | Pstr_type (rf, l) ->
+      line i ppf "Pstr_type %a\n" fmt_rec_flag rf;
+      list i type_declaration ppf l;
+  | Pstr_typext te ->
+      line i ppf "Pstr_typext\n";
+      type_extension i ppf te
+  | Pstr_exception te ->
+      line i ppf "Pstr_exception\n";
+      type_exception i ppf te
+  | Pstr_module x ->
+      line i ppf "Pstr_module\n";
+      module_binding i ppf x
+  | Pstr_recmodule bindings ->
+      line i ppf "Pstr_recmodule\n";
+      list i module_binding ppf bindings;
+  | Pstr_modtype x ->
+      line i ppf "Pstr_modtype %a\n" fmt_string_loc x.pmtd_name;
+      attributes i ppf x.pmtd_attributes;
+      modtype_declaration i ppf x.pmtd_type
+  | Pstr_open od ->
+      line i ppf "Pstr_open %a\n" fmt_override_flag od.popen_override;
+      module_expr i ppf od.popen_expr;
+      attributes i ppf od.popen_attributes
+  | Pstr_class (l) ->
+      line i ppf "Pstr_class\n";
+      list i class_declaration ppf l;
+  | Pstr_class_type (l) ->
+      line i ppf "Pstr_class_type\n";
+      list i class_type_declaration ppf l;
+  | Pstr_include incl ->
+      line i ppf "Pstr_include";
+      attributes i ppf incl.pincl_attributes;
+      module_expr i ppf incl.pincl_mod
+  | Pstr_extension ((s, arg), attrs) ->
+      line i ppf "Pstr_extension \"%s\"\n" s.txt;
+      attributes i ppf attrs;
+      payload i ppf arg
+  | Pstr_attribute a ->
+      attribute i ppf "Pstr_attribute" a
+
+and module_declaration i ppf pmd =
+  str_opt_loc i ppf pmd.pmd_name;
+  attributes i ppf pmd.pmd_attributes;
+  module_type (i+1) ppf pmd.pmd_type;
+
+and module_binding i ppf x =
+  str_opt_loc i ppf x.pmb_name;
+  attributes i ppf x.pmb_attributes;
+  module_expr (i+1) ppf x.pmb_expr
+
+and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
+  line i ppf "<constraint> %a\n" fmt_location l;
+  core_type (i+1) ppf ct1;
+  core_type (i+1) ppf ct2;
+
+and constructor_decl i ppf
+                     {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} =
+  line i ppf "%a\n" fmt_location pcd_loc;
+  line (i+1) ppf "%a\n" fmt_string_loc pcd_name;
+  attributes i ppf pcd_attributes;
+  constructor_arguments (i+1) ppf pcd_args;
+  option (i+1) core_type ppf pcd_res
+
+and constructor_arguments i ppf = function
+  | Pcstr_tuple l -> list i core_type ppf l
+  | Pcstr_record l -> list i label_decl ppf l
+
+and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes}=
+  line i ppf "%a\n" fmt_location pld_loc;
+  attributes i ppf pld_attributes;
+  line (i+1) ppf "%a\n" fmt_mutable_flag pld_mutable;
+  line (i+1) ppf "%a" fmt_string_loc pld_name;
+  core_type (i+1) ppf pld_type
+
+and longident_x_pattern i ppf (li, p) =
+  line i ppf "%a\n" fmt_longident_loc li;
+  pattern (i+1) ppf p;
+
+and case i ppf {pc_lhs; pc_guard; pc_rhs} =
+  line i ppf "<case>\n";
+  pattern (i+1) ppf pc_lhs;
+  begin match pc_guard with
+  | None -> ()
+  | Some g -> line (i+1) ppf "<when>\n"; expression (i + 2) ppf g
+  end;
+  expression (i+1) ppf pc_rhs;
+
+and value_binding i ppf x =
+  line i ppf "<def>\n";
+  attributes (i+1) ppf x.pvb_attributes;
+  pattern (i+1) ppf x.pvb_pat;
+  expression (i+1) ppf x.pvb_expr
+
+and binding_op i ppf x =
+  line i ppf "<binding_op> %a %a"
+    fmt_string_loc x.pbop_op fmt_location x.pbop_loc;
+  pattern (i+1) ppf x.pbop_pat;
+  expression (i+1) ppf x.pbop_exp;
+
+and string_x_expression i ppf (s, e) =
+  line i ppf "<override> %a\n" fmt_string_loc s;
+  expression (i+1) ppf e;
+
+and longident_x_expression i ppf (li, e) =
+  line i ppf "%a\n" fmt_longident_loc li;
+  expression (i+1) ppf e;
+
+and label_x_expression i ppf (l,e) =
+  line i ppf "<arg>\n";
+  arg_label i ppf l;
+  expression (i+1) ppf e;
+
+and label_x_bool_x_core_type_list i ppf x =
+  match x.prf_desc with
+    Rtag (l, b, ctl) ->
+      line i ppf "Rtag \"%s\" %s\n" l.txt (string_of_bool b);
+      attributes (i+1) ppf x.prf_attributes;
+      list (i+1) core_type ppf ctl
+  | Rinherit (ct) ->
+      line i ppf "Rinherit\n";
+      core_type (i+1) ppf ct
+;;
+
+let rec toplevel_phrase i ppf x =
+  match x with
+  | Ptop_def (s) ->
+      line i ppf "Ptop_def\n";
+      structure (i+1) ppf s;
+  | Ptop_dir {pdir_name; pdir_arg; _} ->
+      line i ppf "Ptop_dir \"%s\"\n" pdir_name.txt;
+      match pdir_arg with
+      | None -> ()
+      | Some da -> directive_argument i ppf da;
+
+and directive_argument i ppf x =
+  match x.pdira_desc with
+  | Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s;
+  | Pdir_int (n, None) -> line i ppf "Pdir_int %s\n" n;
+  | Pdir_int (n, Some m) -> line i ppf "Pdir_int %s%c\n" n m;
+  | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident li;
+  | Pdir_bool (b) -> line i ppf "Pdir_bool %s\n" (string_of_bool b);
+;;
+
+let interface ppf x = list 0 signature_item ppf x;;
+
+let implementation ppf x = list 0 structure_item ppf x;;
+
+let top_phrase ppf x = toplevel_phrase 0 ppf x;;
diff --git a/src/ocaml/parsing/printast.mli b/src/ocaml/parsing/printast.mli
new file mode 100644
index 0000000..8215654
--- /dev/null
+++ b/src/ocaml/parsing/printast.mli
@@ -0,0 +1,32 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*              Damien Doligez, projet Para, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Raw printer for {!Parsetree}
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Parsetree;;
+open Format;;
+
+val interface : formatter -> signature_item list -> unit;;
+val implementation : formatter -> structure_item list -> unit;;
+val top_phrase : formatter -> toplevel_phrase -> unit;;
+
+val expression: int -> formatter -> expression -> unit
+val structure: int -> formatter -> structure -> unit
+val payload: int -> formatter -> payload -> unit
diff --git a/src/ocaml/parsing/syntaxerr.ml b/src/ocaml/parsing/syntaxerr.ml
new file mode 100644
index 0000000..49372b9
--- /dev/null
+++ b/src/ocaml/parsing/syntaxerr.ml
@@ -0,0 +1,43 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Auxiliary type for reporting syntax errors *)
+
+type error =
+    Unclosed of Location.t * string * Location.t * string
+  | Expecting of Location.t * string
+  | Not_expecting of Location.t * string
+  | Applicative_path of Location.t
+  | Variable_in_scope of Location.t * string
+  | Other of Location.t
+  | Ill_formed_ast of Location.t * string
+  | Invalid_package_type of Location.t * string
+
+exception Error of error
+exception Escape_error
+
+let location_of_error = function
+  | Unclosed(l,_,_,_)
+  | Applicative_path l
+  | Variable_in_scope(l,_)
+  | Other l
+  | Not_expecting (l, _)
+  | Ill_formed_ast (l, _)
+  | Invalid_package_type (l, _)
+  | Expecting (l, _) -> l
+
+
+let ill_formed_ast loc s =
+  raise (Error (Ill_formed_ast (loc, s)))
diff --git a/src/ocaml/parsing/syntaxerr.mli b/src/ocaml/parsing/syntaxerr.mli
new file mode 100644
index 0000000..26ba712
--- /dev/null
+++ b/src/ocaml/parsing/syntaxerr.mli
@@ -0,0 +1,37 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Auxiliary type for reporting syntax errors
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type error =
+    Unclosed of Location.t * string * Location.t * string
+  | Expecting of Location.t * string
+  | Not_expecting of Location.t * string
+  | Applicative_path of Location.t
+  | Variable_in_scope of Location.t * string
+  | Other of Location.t
+  | Ill_formed_ast of Location.t * string
+  | Invalid_package_type of Location.t * string
+
+exception Error of error
+exception Escape_error
+
+val location_of_error: error -> Location.t
+val ill_formed_ast: Location.t -> string -> 'a
diff --git a/src/ocaml/preprocess/dune b/src/ocaml/preprocess/dune
new file mode 100644
index 0000000..defd153
--- /dev/null
+++ b/src/ocaml/preprocess/dune
@@ -0,0 +1,48 @@
+(ocamllex lexer_ident lexer_raw)
+
+(library
+  (name preprocess)
+  (wrapped false)
+  (flags :standard -open Ocaml_parsing -open Ocaml_utils -open Merlin_utils)
+  (libraries ocaml_parsing ocaml_utils merlin_utils))
+
+(menhir
+ (modules parser_raw)
+ (enabled_if (<> %{profile} "release"))
+ (mode    promote)
+ (flags :standard --inspection --table --cmly))
+
+(rule
+  (targets parser_recover.ml)
+  (enabled_if (<> %{profile} "release"))
+  (deps    parser_raw.cmly)
+  (mode    promote)
+  (action
+    (with-stdout-to %{targets}
+       (run %{exe:./recover/gen_recover.exe} %{deps}))))
+
+(rule
+  (targets parser_explain.ml)
+  (enabled_if (<> %{profile} "release"))
+  (deps    parser_raw.cmly)
+  (mode    promote)
+  (action
+    (with-stdout-to %{targets}
+       (run %{exe:./explain/gen_explain.exe} %{deps}))))
+
+(rule
+  (targets parser_printer.ml)
+  (enabled_if (<> %{profile} "release"))
+  (deps    parser_raw.cmly)
+  (mode    promote)
+  (action
+    (with-stdout-to %{targets}
+       (run %{exe:./printer/gen_printer.exe} %{deps}))))
+
+(rule
+ (targets menhirLib.ml menhirLib.mli)
+ (mode promote)
+ (action
+  (progn
+   (copy %{lib:menhirLib:menhirLib.ml}  menhirLib.ml)
+   (copy %{lib:menhirLib:menhirLib.mli} menhirLib.mli))))
diff --git a/src/ocaml/preprocess/explain/dune b/src/ocaml/preprocess/explain/dune
new file mode 100644
index 0000000..86650a6
--- /dev/null
+++ b/src/ocaml/preprocess/explain/dune
@@ -0,0 +1,3 @@
+(executable
+ (name gen_explain)
+ (libraries unix menhirSdk))
diff --git a/src/ocaml/preprocess/explain/gen_explain.ml b/src/ocaml/preprocess/explain/gen_explain.ml
new file mode 100644
index 0000000..a71f295
--- /dev/null
+++ b/src/ocaml/preprocess/explain/gen_explain.ml
@@ -0,0 +1,51 @@
+open MenhirSdk
+open Printf
+
+module G = Cmly_read.Read(struct let filename = Sys.argv.(1) end)
+
+open G
+
+let print_header () =
+  let name = Filename.chop_extension (Filename.basename Sys.argv.(1)) in
+  printf "open %s\n" (String.capitalize_ascii name)
+
+let attributes_at st =
+  List.fold_left
+    (fun attrs (prod, pos) ->
+       if pos > 0 then
+         let _, _, attrs' = (G.Production.rhs prod).(pos - 1) in
+         attrs' @ attrs
+       else
+         attrs)
+    [] (Lr0.items (Lr1.lr0 st))
+
+let print_named_items () =
+  let print_item st =
+    match List.filter (Attribute.has_label "item") (attributes_at st) with
+    | [] -> ()
+    | (x :: _) as xs ->
+      let xs = List.map Attribute.payload xs |> List.sort_uniq compare in
+      if List.length xs > 1 then
+        eprintf "Warning: state %d has multiple items, %s.\n"
+          (Lr1.to_int st) (String.concat " " xs);
+      printf "  | %d -> %s\n"
+        (Lr1.to_int st) (Attribute.payload x)
+  in
+  printf "let named_item_at = function\n";
+  Lr1.iter print_item;
+  printf "  | _ -> raise Not_found\n\n"
+
+let print_nullable () =
+  let print_n n =
+    if Nonterminal.nullable n then
+      printf "  | N_%s -> true\n" (Nonterminal.mangled_name n)
+  in
+  printf "let nullable (type a) : a MenhirInterpreter.nonterminal -> bool =\n\
+         \  let open MenhirInterpreter in function\n";
+  Nonterminal.iter print_n;
+  printf "  | _ -> false\n"
+
+let () =
+  print_header ();
+  print_named_items ();
+  print_nullable ()
diff --git a/src/ocaml/preprocess/lexer_ident.mli b/src/ocaml/preprocess/lexer_ident.mli
new file mode 100644
index 0000000..c95e9c8
--- /dev/null
+++ b/src/ocaml/preprocess/lexer_ident.mli
@@ -0,0 +1,29 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+val token: Lexing.lexbuf -> Parser_raw.token
diff --git a/src/ocaml/preprocess/lexer_ident.mll b/src/ocaml/preprocess/lexer_ident.mll
new file mode 100644
index 0000000..e9690db
--- /dev/null
+++ b/src/ocaml/preprocess/lexer_ident.mll
@@ -0,0 +1,186 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* The lexer definition *)
+
+{
+open Std
+open Lexing
+open Parser_raw
+
+(* Update the current location with file name and line number. *)
+
+let update_loc lexbuf file line absolute chars =
+  let pos = lexbuf.lex_curr_p in
+  let new_file = match file with
+                 | None -> pos.pos_fname
+                 | Some s -> s
+  in
+  lexbuf.lex_curr_p <- { pos with
+    pos_fname = new_file;
+    pos_lnum = if absolute then line else pos.pos_lnum + line;
+    pos_bol = pos.pos_cnum - chars;
+  }
+}
+
+let newline = ('\013'* '\010')
+let blank = [' ' '\009' '\012']
+let lowercase = ['a'-'z' '_']
+let uppercase = ['A'-'Z']
+let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9']
+let lowercase_latin1 = ['a'-'z' '\223'-'\246' '\248'-'\255' '_']
+let uppercase_latin1 = ['A'-'Z' '\192'-'\214' '\216'-'\222']
+let identchar_latin1 =
+  ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
+let symbolchar =
+  ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
+let symbolcharnopercent =
+  ['!' '$' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
+let decimal_literal =
+  ['0'-'9'] ['0'-'9' '_']*
+let hex_literal =
+  '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']['0'-'9' 'A'-'F' 'a'-'f' '_']*
+let oct_literal =
+  '0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']*
+let bin_literal =
+  '0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']*
+let int_literal =
+  decimal_literal | hex_literal | oct_literal | bin_literal
+let float_literal =
+  ['0'-'9'] ['0'-'9' '_']*
+  ('.' ['0'-'9' '_']* )?
+  (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)?
+let dotsymbolchar =
+  ['!' '$' '%' '&' '*' '+' '-' '/' ':' '=' '>' '?' '@' '^' '|']
+let kwdopchar =
+  ['$' '&' '*' '+' '-' '/' '<' '=' '>' '@' '^' '|']
+
+rule token = parse
+  | "_" { EOL }
+  | newline
+      { update_loc lexbuf None 1 false 0;
+        token lexbuf }
+  | blank +
+      { token lexbuf }
+  | "~" (lowercase identchar *) as label ':'
+      { LABEL label }
+  | "~" (lowercase_latin1 identchar_latin1 *) as label ':'
+      { LABEL label }
+  | "?"
+      { QUESTION }
+  | "?" (lowercase identchar *) as label ':'
+      { OPTLABEL label }
+  | "?" (lowercase_latin1 identchar_latin1 *) as label ':'
+      { OPTLABEL label }
+  | ("let" kwdopchar dotsymbolchar *) as op { LETOP op }
+  | ("and" kwdopchar dotsymbolchar *) as op { ANDOP op }
+  | (lowercase identchar *) as ident
+    { LIDENT ident }
+  | (lowercase_latin1 identchar_latin1 *) as ident
+    { LIDENT ident }
+  | (uppercase identchar *) as ident
+    { UIDENT ident }
+  | "`"  { BACKQUOTE }
+  | "'"  { QUOTE }
+  | "("  { LPAREN }
+  | ")"  { RPAREN }
+  | "."  { DOT }
+  | "!" symbolchar +
+            { PREFIXOP(Lexing.lexeme lexbuf) }
+  | ['~' '?'] symbolchar +
+            { PREFIXOP(Lexing.lexeme lexbuf) }
+  | ['=' '<' '|' '&' '$' '>'] symbolchar *
+            { INFIXOP0(Lexing.lexeme lexbuf) }
+  | ['@' '^'] symbolchar *
+            { INFIXOP1(Lexing.lexeme lexbuf) }
+  | ['+' '-'] symbolchar *
+            { INFIXOP2(Lexing.lexeme lexbuf) }
+  | "**" symbolchar *
+            { INFIXOP4(Lexing.lexeme lexbuf) }
+  | '%'     { PERCENT }
+  | ['*' '/' '%'] symbolchar *
+            { INFIXOP3(Lexing.lexeme lexbuf) }
+  | '#' (symbolchar | '#') +
+            { let s = Lexing.lexeme lexbuf in
+              HASHOP s }
+  | eof { EOF }
+  | "'" newline "'"
+      { update_loc lexbuf None 1 false 1;
+        EOL }
+  | "'\\" newline
+      { update_loc lexbuf None 1 false 0;
+        EOL }
+  | int_literal
+  | float_literal
+  | int_literal "l"
+  | int_literal "L"
+  | int_literal "n"
+  | ".<"
+  | ">."
+  | ".~"
+  | "~"
+  | "\""
+  | "{" lowercase* "|"
+  | "'" [^ '\\' '\'' '\010' '\013'] "'"
+  | "'\\" ['\\' '\'' '"' 'n' 't' 'b' 'r' ' '] "'"
+  | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
+  | "'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "'"
+  | "'\\" _
+  | "(*"
+  | "(*)"
+  | "*)"
+  | "#"
+  | "&"
+  | "&&"
+  | "*"
+  | ","
+  | "->"
+  | ".."
+  | ":"
+  | "::"
+  | ":="
+  | ":>"
+  | ";"
+  | ";;"
+  | "<"
+  | "<-"
+  | "="
+  | "["
+  | "[|"
+  | "[<"
+  | "[>"
+  | "]"
+  | "{"
+  | "{<"
+  | "|"
+  | "||"
+  | "|]"
+  | ">"
+  | ">]"
+  | "}"
+  | ">}"
+  | "[@"
+  | "[%"
+  | "[%%"
+  | "[@@"
+  | "[@@@"
+  | "!"
+
+  | "!="
+  | "+"
+  | "+."
+  | "+="
+  | "-"
+  | "-."
+    { EOL }
+  | _ { EOL }
+
diff --git a/src/ocaml/preprocess/lexer_raw.mli b/src/ocaml/preprocess/lexer_raw.mli
new file mode 100644
index 0000000..67965e9
--- /dev/null
+++ b/src/ocaml/preprocess/lexer_raw.mli
@@ -0,0 +1,65 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+open Std
+
+(* Possible errors *)
+type error =
+  | Illegal_character of char
+  | Illegal_escape of string * string option
+  | Reserved_sequence of string * string option
+  | Unterminated_comment of Location.t
+  | Unterminated_string
+  | Unterminated_string_in_comment of Location.t * Location.t
+  | Empty_character_literal
+  | Keyword_as_label of string
+  | Invalid_literal of string
+exception Error of error * Location.t
+
+(* Keywords, manipulated by extensions *)
+type keywords
+val keywords: (string * Parser_raw.token) list -> keywords
+
+val list_keywords : keywords -> string list
+(* [list_keywords kws] not only lists the keys of [kw], but also OCaml's
+   keywords. *)
+
+(* Monad in which the lexer evaluates *)
+type 'a result =
+  | Return of 'a
+  | Refill of (unit -> 'a result)
+  | Fail of error * Location.t
+
+type preprocessor = (Lexing.lexbuf -> Parser_raw.token) -> Lexing.lexbuf -> Parser_raw.token
+
+type state = {
+  keywords: keywords;
+  mutable buffer: Buffer.t;
+  mutable string_start_loc: Location.t;
+  mutable comment_start_loc: Location.t list;
+  mutable preprocessor: preprocessor option;
+}
+
+val make: ?preprocessor:preprocessor -> keywords -> state
+
+(* The lexical analyzer *)
+
+val skip_sharp_bang: state -> Lexing.lexbuf -> Parser_raw.token result
+val token: state -> Lexing.lexbuf -> Parser_raw.token result
+
+(* Comments are filtered out from the token rule and stored in a global
+   variable. *)
+type comment = string * Location.t
+
+(* If you want to get the raw output, including comments, from the lexer, use
+   the [token_with_comments] entry point. *)
+val token_without_comments : state -> Lexing.lexbuf -> Parser_raw.token result
diff --git a/src/ocaml/preprocess/lexer_raw.mll b/src/ocaml/preprocess/lexer_raw.mll
new file mode 100644
index 0000000..726e408
--- /dev/null
+++ b/src/ocaml/preprocess/lexer_raw.mll
@@ -0,0 +1,811 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* The lexer definition *)
+
+{
+open Misc
+open Std
+open Lexing
+open Parser_raw
+
+type keywords = (string, Parser_raw.token) Hashtbl.t
+
+type error =
+  | Illegal_character of char
+  | Illegal_escape of string * string option
+  | Reserved_sequence of string * string option
+  | Unterminated_comment of Location.t
+  | Unterminated_string
+  | Unterminated_string_in_comment of Location.t * Location.t
+  | Empty_character_literal
+  | Keyword_as_label of string
+  | Invalid_literal of string
+
+exception Error of error * Location.t
+
+(* Monad in which the lexer evaluates *)
+type 'a result =
+  | Return of 'a
+  | Refill of (unit -> 'a result)
+  | Fail of error * Location.t
+
+let return a = Return a
+
+let fail lexbuf e = Fail (e, Location.curr lexbuf)
+let fail_loc e l = Fail (e,l)
+
+let rec (>>=) (m : 'a result) (f : 'a -> 'b result) : 'b result =
+  match m with
+  | Return a -> f a
+  | Refill u ->
+    Refill (fun () -> u () >>= f)
+  | Fail _ as e -> e
+
+type preprocessor = (Lexing.lexbuf -> Parser_raw.token) -> Lexing.lexbuf -> Parser_raw.token
+
+type state = {
+  keywords: keywords;
+  mutable buffer: Buffer.t;
+  mutable string_start_loc: Location.t;
+  mutable comment_start_loc: Location.t list;
+  mutable preprocessor: preprocessor option;
+}
+
+let make ?preprocessor keywords = {
+  keywords;
+  buffer = Buffer.create 17;
+  string_start_loc = Location.none;
+  comment_start_loc = [];
+  preprocessor;
+}
+
+let lABEL m = m >>= fun v -> return (LABEL v)
+let oPTLABEL m = m >>= fun v -> return (OPTLABEL v)
+
+let rec catch m f = match m with
+  | Fail (e,l) -> f e l
+  | Refill next -> Refill (fun () -> catch (next ()) f)
+  | Return _ -> m
+
+(* The table of keywords *)
+
+let keyword_table : keywords =
+  create_hashtable 149 [
+    "and", AND;
+    "as", AS;
+    "assert", ASSERT;
+    "begin", BEGIN;
+    "class", CLASS;
+    "constraint", CONSTRAINT;
+    "do", DO;
+    "done", DONE;
+    "downto", DOWNTO;
+    "else", ELSE;
+    "end", END;
+    "exception", EXCEPTION;
+    "external", EXTERNAL;
+    "false", FALSE;
+    "for", FOR;
+    "fun", FUN;
+    "function", FUNCTION;
+    "functor", FUNCTOR;
+    "if", IF;
+    "in", IN;
+    "include", INCLUDE;
+    "inherit", INHERIT;
+    "initializer", INITIALIZER;
+    "lazy", LAZY;
+    "let", LET;
+    "match", MATCH;
+    "method", METHOD;
+    "module", MODULE;
+    "mutable", MUTABLE;
+    "new", NEW;
+    "nonrec", NONREC;
+    "object", OBJECT;
+    "of", OF;
+    "open", OPEN;
+    "or", OR;
+(*  "parser", PARSER; *)
+    "private", PRIVATE;
+    "rec", REC;
+    "sig", SIG;
+    "struct", STRUCT;
+    "then", THEN;
+    "to", TO;
+    "true", TRUE;
+    "try", TRY;
+    "type", TYPE;
+    "val", VAL;
+    "virtual", VIRTUAL;
+    "when", WHEN;
+    "while", WHILE;
+    "with", WITH;
+
+    "lor", INFIXOP3("lor"); (* Should be INFIXOP2 *)
+    "lxor", INFIXOP3("lxor"); (* Should be INFIXOP2 *)
+    "mod", INFIXOP3("mod");
+    "land", INFIXOP3("land");
+    "lsl", INFIXOP4("lsl");
+    "lsr", INFIXOP4("lsr");
+    "asr", INFIXOP4("asr");
+]
+
+let keywords l = create_hashtable 11 l
+
+let list_keywords =
+  let add_kw str _tok kws = str :: kws in
+  let init = Hashtbl.fold add_kw keyword_table [] in
+  fun keywords ->
+    Hashtbl.fold add_kw keywords init
+
+(* To store the position of the beginning of a string and comment *)
+let in_comment state = state.comment_start_loc <> []
+
+(* Escaped chars are interpreted in strings unless they are in comments. *)
+let store_escaped_uchar state lexbuf u =
+  if in_comment state
+  then Buffer.add_string state.buffer (Lexing.lexeme lexbuf)
+  else Buffer.add_utf_8_uchar state.buffer u
+
+
+let compute_quoted_string_idloc {Location.loc_start = orig_loc; _ } shift id =
+  let id_start_pos = orig_loc.Lexing.pos_cnum + shift in
+  let loc_start =
+    Lexing.{orig_loc with pos_cnum = id_start_pos }
+  in
+  let loc_end =
+    Lexing.{orig_loc with pos_cnum = id_start_pos + String.length id }
+  in
+  {Location. loc_start ; loc_end ; loc_ghost = false }
+
+let wrap_string_lexer f state lexbuf =
+  Buffer.reset state.buffer;
+  state.string_start_loc <- Location.curr lexbuf;
+  f state lexbuf >>= fun loc_end ->
+  lexbuf.lex_start_p <- state.string_start_loc.Location.loc_start;
+  state.string_start_loc <- Location.none;
+  let loc =
+    Location.{
+      loc_ghost = false;
+      loc_start = state.string_start_loc.Location.loc_start;
+      loc_end;
+    }
+  in
+  return (Buffer.contents state.buffer, loc)
+
+(* to translate escape sequences *)
+
+let digit_value c =
+  match c with
+  | 'a' .. 'f' -> 10 + Char.code c - Char.code 'a'
+  | 'A' .. 'F' -> 10 + Char.code c - Char.code 'A'
+  | '0' .. '9' -> Char.code c - Char.code '0'
+  | _ -> assert false
+
+let num_value lexbuf ~base ~first ~last =
+  let c = ref 0 in
+  for i = first to last do
+    let v = digit_value (Lexing.lexeme_char lexbuf i) in
+    assert(v < base);
+    c := (base * !c) + v
+  done;
+  !c
+
+let char_for_backslash = function
+  | 'n' -> '\010'
+  | 'r' -> '\013'
+  | 'b' -> '\008'
+  | 't' -> '\009'
+  | c   -> c
+
+let illegal_escape lexbuf reason =
+  let error = Illegal_escape (Lexing.lexeme lexbuf, Some reason) in
+  fail lexbuf error
+
+let char_for_decimal_code state lexbuf i =
+  let c = num_value lexbuf ~base:10 ~first:i ~last:(i+2) in
+  if (c < 0 || c > 255) then
+    if in_comment state
+    then return 'x'
+    else
+      illegal_escape lexbuf
+        (Printf.sprintf
+          "%d is outside the range of legal characters (0-255)." c)
+  else return (Char.chr c)
+
+let char_for_octal_code state lexbuf i =
+  let c = num_value lexbuf ~base:8 ~first:i ~last:(i+2) in
+  if (c < 0 || c > 255) then
+    if in_comment state
+    then return 'x'
+    else
+      illegal_escape lexbuf
+        (Printf.sprintf
+          "o%o (=%d) is outside the range of legal characters (0-255)." c c)
+  else return (Char.chr c)
+
+let char_for_hexadecimal_code lexbuf i =
+  Char.chr (num_value lexbuf ~base:16 ~first:i ~last:(i+1))
+
+let uchar_for_uchar_escape lexbuf =
+  let illegal_escape lexbuf reason =
+    let error = Illegal_escape (Lexing.lexeme lexbuf, Some reason) in
+    raise (Error (error, Location.curr lexbuf))
+  in
+  let len = Lexing.lexeme_end lexbuf - Lexing.lexeme_start lexbuf in
+  let first = 3 (* skip opening \u{ *) in
+  let last = len - 2 (* skip closing } *) in
+  let digit_count = last - first + 1 in
+  match digit_count > 6 with
+  | true ->
+      illegal_escape lexbuf
+        "too many digits, expected 1 to 6 hexadecimal digits"
+  | false ->
+      let cp = num_value lexbuf ~base:16 ~first ~last in
+      if Uchar.is_valid cp then Uchar.unsafe_of_int cp else
+      illegal_escape lexbuf
+        (Printf.sprintf "%X is not a Unicode scalar value" cp)
+
+let keyword_or state s default =
+  try Hashtbl.find state.keywords s
+      with Not_found -> try Hashtbl.find keyword_table s
+  with Not_found -> default
+
+let is_keyword name = Hashtbl.mem keyword_table name
+
+let check_label_name lexbuf name =
+  if is_keyword name
+  then fail lexbuf (Keyword_as_label name)
+  else return name
+
+(* Update the current location with file name and line number. *)
+
+let update_loc lexbuf _file line absolute chars =
+  let pos = lexbuf.lex_curr_p in
+  let new_file = pos.pos_fname
+    (*match file with
+      | None -> pos.pos_fname
+      | Some s -> s*)
+  in
+  lexbuf.lex_curr_p <- { pos with
+    pos_fname = new_file;
+    pos_lnum = if absolute then line else pos.pos_lnum + line;
+    pos_bol = pos.pos_cnum - chars;
+  }
+;;
+
+(* Warn about Latin-1 characters used in idents *)
+
+let warn_latin1 lexbuf =
+  Location.deprecated (Location.curr lexbuf)
+    "ISO-Latin1 characters in identifiers"
+;;
+
+(* Error report *)
+
+open Format
+
+let prepare_error loc = function
+  | Illegal_character c ->
+      Location.errorf ~loc "Illegal character (%s)" (Char.escaped c)
+  | Illegal_escape (s, explanation) ->
+      Location.errorf ~loc
+        "Illegal backslash escape in string or character (%s)%t" s
+        (fun ppf -> match explanation with
+           | None -> ()
+           | Some expl -> fprintf ppf ": %s" expl)
+  | Reserved_sequence (s, explanation) ->
+      Location.errorf ~loc
+        "Reserved character sequence: %s%t" s
+        (fun ppf -> match explanation with
+           | None -> ()
+           | Some expl -> fprintf ppf " %s" expl)
+  | Unterminated_comment _ ->
+      Location.errorf ~loc "Comment not terminated"
+  | Unterminated_string ->
+      Location.errorf ~loc "String literal not terminated"
+  | Unterminated_string_in_comment (_, literal_loc) ->
+      Location.errorf ~loc
+        "This comment contains an unterminated string literal"
+        ~sub:[Location.msg ~loc:literal_loc "String literal begins here"]
+  | Empty_character_literal ->
+      let msg = "Illegal empty character literal ''" in
+      let sub =
+        [Location.msg
+           "Hint: Did you mean ' ' or a type variable 'a?"] in
+      Location.error ~loc ~sub msg
+  | Keyword_as_label kwd ->
+      Location.errorf ~loc
+        "`%s' is a keyword, it cannot be used as label name" kwd
+  | Invalid_literal s ->
+      Location.errorf ~loc "Invalid literal %s" s
+(* FIXME: Invalid_directive? *)
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (err, loc) ->
+        Some (prepare_error loc err)
+      | _ ->
+        None
+    )
+
+}
+
+let newline = ('\013'* '\010')
+let blank = [' ' '\009' '\012']
+let lowercase = ['a'-'z' '_']
+let uppercase = ['A'-'Z']
+let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9' '\128'-'\255']
+let lowercase_latin1 = ['a'-'z' '\223'-'\246' '\248'-'\255' '_']
+let uppercase_latin1 = ['A'-'Z' '\192'-'\214' '\216'-'\222']
+let identchar_latin1 = identchar
+  (*['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']*)
+let symbolchar =
+  ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
+let symbolcharnopercent =
+  ['!' '$' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
+let dotsymbolchar =
+  ['!' '$' '%' '&' '*' '+' '-' '/' ':' '=' '>' '?' '@' '^' '|']
+let symbolchar_or_hash =
+  symbolchar | '#'
+let kwdopchar =
+  ['$' '&' '*' '+' '-' '/' '<' '=' '>' '@' '^' '|']
+
+let ident = (lowercase | uppercase) identchar*
+let extattrident = ident ('.' ident)*
+
+let decimal_literal =
+  ['0'-'9'] ['0'-'9' '_']*
+let hex_digit =
+  ['0'-'9' 'A'-'F' 'a'-'f']
+let hex_literal =
+  '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']['0'-'9' 'A'-'F' 'a'-'f' '_']*
+let oct_literal =
+  '0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']*
+let bin_literal =
+  '0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']*
+let int_literal =
+  decimal_literal | hex_literal | oct_literal | bin_literal
+let float_literal =
+  ['0'-'9'] ['0'-'9' '_']*
+  ('.' ['0'-'9' '_']* )?
+  (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*) ?
+let hex_float_literal =
+  '0' ['x' 'X']
+  ['0'-'9' 'A'-'F' 'a'-'f'] ['0'-'9' 'A'-'F' 'a'-'f' '_']*
+  ('.' ['0'-'9' 'A'-'F' 'a'-'f' '_']* )?
+  (['p' 'P'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )?
+let literal_modifier = ['G'-'Z' 'g'-'z']
+
+
+refill {fun k lexbuf -> Refill (fun () -> k lexbuf)}
+
+rule token state = parse
+  | ("\\" as bs) newline {
+      match state.preprocessor with
+      | None -> fail lexbuf (Illegal_character bs)
+      | Some _ ->
+        update_loc lexbuf None 1 false 0;
+        token state lexbuf }
+  | newline
+      { update_loc lexbuf None 1 false 0;
+        match state.preprocessor with
+        | None -> token state lexbuf
+        | Some _ -> return EOL
+      }
+  | blank +
+      { token state lexbuf }
+  | ".<"
+      { return DOTLESS }
+  | ">."
+      { return (keyword_or state (Lexing.lexeme lexbuf) (INFIXOP0 ">.")) }
+  | ".~"
+      { return (keyword_or state (Lexing.lexeme lexbuf) DOTTILDE) }
+  | "_"
+      { return UNDERSCORE }
+  | "~"
+      { return TILDE }
+      (*
+  | ".~"
+      { fail lexbuf
+          (Reserved_sequence (".~", Some "is reserved for use in MetaOCaml")) }
+      *)
+  | "~" (lowercase identchar * as name) ':'
+      { lABEL (check_label_name lexbuf name) }
+  | "~" (lowercase_latin1 identchar_latin1 * as name) ':'
+      { warn_latin1 lexbuf;
+        return (LABEL name) }
+  | "?"
+      { return QUESTION }
+  | "?" (lowercase identchar * as name) ':'
+      { oPTLABEL (check_label_name lexbuf name) }
+  | "?" (lowercase_latin1 identchar_latin1 * as name) ':'
+      { warn_latin1 lexbuf; return (OPTLABEL name) }
+  | lowercase identchar * as name
+    { return (try Hashtbl.find state.keywords name
+              with Not_found ->
+              try Hashtbl.find keyword_table name
+              with Not_found ->
+                LIDENT name) }
+  | lowercase_latin1 identchar_latin1 * as name
+      { warn_latin1 lexbuf; return (LIDENT name) }
+  | uppercase identchar * as name
+    { (* Capitalized keywords for OUnit *)
+      return (try Hashtbl.find state.keywords name
+              with Not_found ->
+              try Hashtbl.find keyword_table name
+              with Not_found ->
+                UIDENT name) }
+  | uppercase_latin1 identchar_latin1 * as name
+    { warn_latin1 lexbuf; return (UIDENT name) }
+  | int_literal as lit { return (INT (lit, None)) }
+  | (int_literal as lit) (literal_modifier as modif)
+    { return (INT (lit, Some modif)) }
+  | float_literal | hex_float_literal as lit
+    { return (FLOAT (lit, None)) }
+  | (float_literal | hex_float_literal as lit) (literal_modifier as modif)
+    { return (FLOAT (lit, Some modif)) }
+  | (float_literal | hex_float_literal | int_literal) identchar+ as invalid
+    { fail lexbuf (Invalid_literal invalid) }
+  | "\""
+      { wrap_string_lexer string state lexbuf >>= fun (str, loc) ->
+        return (STRING (str, loc, None)) }
+  | "\'\'"
+      { wrap_string_lexer string state lexbuf >>= fun (str, loc) ->
+        return (STRING (str, loc, None)) }
+  | "{" (lowercase* as delim) "|"
+      { wrap_string_lexer (quoted_string delim) state lexbuf
+        >>= fun (str, loc) ->
+        return (STRING (str, loc, Some delim)) }
+  | "{%" (extattrident as id) "|"
+      { let orig_loc = Location.curr lexbuf in
+        wrap_string_lexer (quoted_string "") state lexbuf
+        >>= fun (str, loc) ->
+        let idloc = compute_quoted_string_idloc orig_loc 2 id in
+        return (QUOTED_STRING_EXPR (id, idloc, str, loc, Some "")) }
+  | "{%" (extattrident as id) blank+ (lowercase* as delim) "|"
+      { let orig_loc = Location.curr lexbuf in
+        wrap_string_lexer (quoted_string delim) state lexbuf
+        >>= fun (str, loc) ->
+        let idloc = compute_quoted_string_idloc orig_loc 2 id in
+        return (QUOTED_STRING_EXPR (id, idloc, str, loc, Some delim)) }
+  | "{%%" (extattrident as id) "|"
+      { let orig_loc = Location.curr lexbuf in
+        wrap_string_lexer (quoted_string "") state lexbuf
+        >>= fun (str, loc) ->
+        let idloc = compute_quoted_string_idloc orig_loc 3 id in
+        return (QUOTED_STRING_ITEM (id, idloc, str, loc, Some "")) }
+  | "{%%" (extattrident as id) blank+ (lowercase* as delim) "|"
+      { let orig_loc = Location.curr lexbuf in
+        wrap_string_lexer (quoted_string delim) state lexbuf
+        >>= fun (str, loc) ->
+        let idloc = compute_quoted_string_idloc orig_loc 3 id in
+        return (QUOTED_STRING_ITEM (id, idloc, str, loc, Some delim)) }
+  | "\'" newline "\'"
+    { update_loc lexbuf None 1 false 1;
+      (* newline is ('\013'* '\010') *)
+      return (CHAR '\n') }
+  | "\'" ([^ '\\' '\'' '\010' '\013'] as c) "\'"
+    { return (CHAR c) }
+  | "\'\\" (['\\' '\'' '\"' 'n' 't' 'b' 'r' ' '] as c) "\'"
+    { return (CHAR (char_for_backslash c)) }
+  | "\'\\" 'o' ['0'-'3'] ['0'-'7'] ['0'-'7'] "\'"
+    { char_for_octal_code state lexbuf 3 >>= fun c -> return (CHAR c) }
+  | "\'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "\'"
+    { char_for_decimal_code state lexbuf 2 >>= fun c -> return (CHAR c) }
+  | "\'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "\'"
+    { return (CHAR (char_for_hexadecimal_code lexbuf 3)) }
+  | "\'" ("\\" _ as esc)
+      { fail lexbuf (Illegal_escape (esc, None)) }
+  | "(*"
+      { let start_loc = Location.curr lexbuf in
+        state.comment_start_loc <- [start_loc];
+        Buffer.reset state.buffer;
+        comment state lexbuf >>= fun end_loc ->
+        let s = Buffer.contents state.buffer in
+        Buffer.reset state.buffer;
+        return (COMMENT (s, { start_loc with
+                              Location.loc_end = end_loc.Location.loc_end }))
+      }
+  | "(*)"
+      { let loc = Location.curr lexbuf in
+        Location.prerr_warning loc Warnings.Comment_start;
+        state.comment_start_loc <- [loc];
+        Buffer.reset state.buffer;
+        comment state lexbuf >>= fun end_loc ->
+        let s = Buffer.contents state.buffer in
+        Buffer.reset state.buffer;
+        return (COMMENT (s, { loc with Location.loc_end = end_loc.Location.loc_end }))
+      }
+  | "*)"
+      { let loc = Location.curr lexbuf in
+        Location.prerr_warning loc Warnings.Comment_not_end;
+        lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1;
+        let curpos = lexbuf.lex_curr_p in
+        lexbuf.lex_curr_p <- { curpos with pos_cnum = curpos.pos_cnum - 1 };
+        return STAR
+      }
+  | "#" [' ' '\t']* (['0'-'9']+ as num) [' ' '\t']*
+        ("\"" ([^ '\010' '\013' '\"' ] * as name) "\"")?
+        [^ '\010' '\013'] * newline
+      { update_loc lexbuf name (int_of_string num) true 0;
+        token state lexbuf
+      }
+  | "#"  { return HASH }
+  | "&"  { return AMPERSAND }
+  | "&&" { return AMPERAMPER }
+  | "`"  { return BACKQUOTE }
+  | "\'" { return QUOTE }
+  | "("  { return LPAREN }
+  | ")"  { return RPAREN }
+  | "*"  { return STAR }
+  | ","  { return COMMA }
+  | "->" { return MINUSGREATER }
+  | "."  { return DOT }
+  | "." (dotsymbolchar symbolchar* as op) { return (DOTOP op) }
+  | ".." { return DOTDOT }
+  | ":"  { return COLON }
+  | "::" { return COLONCOLON }
+  | ":=" { return COLONEQUAL }
+  | ":>" { return COLONGREATER }
+  | ";"  { return SEMI }
+  | ";;" { return SEMISEMI }
+  | "<"  { return LESS }
+  | "<-" { return LESSMINUS }
+  | "="  { return EQUAL }
+  | "["  { return LBRACKET }
+  | "[|" { return LBRACKETBAR }
+  | "[<" { return LBRACKETLESS }
+  | "[>" { return LBRACKETGREATER }
+  | "]"  { return RBRACKET }
+  | "{"  { return LBRACE }
+  | "{<" { return LBRACELESS }
+  | "|"  { return BAR }
+  | "||" { return BARBAR }
+  | "|]" { return BARRBRACKET }
+  | ">"  { return GREATER }
+  | ">]" { return GREATERRBRACKET }
+  | "}"  { return RBRACE }
+  | ">}" { return GREATERRBRACE }
+  | "[@" { return LBRACKETAT }
+  | "[@@"  { return LBRACKETATAT }
+  | "[@@@" { return LBRACKETATATAT }
+  | "[%" { return LBRACKETPERCENT }
+  | "[%%" { return LBRACKETPERCENTPERCENT }
+  | "!"  { return BANG }
+  | "!=" { return (INFIXOP0 "!=") }
+  | "+"  { return PLUS }
+  | "+." { return PLUSDOT }
+  | "+=" { return PLUSEQ }
+  | "-"  { return MINUS }
+  | "-." { return MINUSDOT }
+
+  | "!" symbolchar_or_hash + as op
+            { return (PREFIXOP op) }
+  | ['~' '?'] symbolchar_or_hash + as op
+            { return (PREFIXOP op) }
+  | ['=' '<' '|' '&' '$' '>'] symbolchar * as op
+            { return (keyword_or state op
+                       (INFIXOP0 op)) }
+  | ['@' '^'] symbolchar * as op
+            { return (INFIXOP1 op) }
+  | ['+' '-'] symbolchar * as op
+            { return (INFIXOP2 op) }
+  | "**" symbolchar * as op
+            { return (INFIXOP4 op) }
+  | '%'     { return PERCENT }
+  | ['*' '/' '%'] symbolchar * as op
+            { return (INFIXOP3 op) }
+  (* Old style js_of_ocaml support is implemented by generating a custom token *)
+  | '#' symbolchar_or_hash + as op
+            { return (try Hashtbl.find state.keywords op
+                      with Not_found -> HASHOP op) }
+  | "let" kwdopchar dotsymbolchar * as op
+            { return (LETOP op) }
+  | "and" kwdopchar dotsymbolchar * as op
+            { return (ANDOP op) }
+  | eof { return EOF }
+
+  | _ as illegal_char
+      { fail lexbuf (Illegal_character illegal_char) }
+
+and comment state = parse
+    "(*"
+      { state.comment_start_loc <- (Location.curr lexbuf) :: state.comment_start_loc;
+      Buffer.add_string state.buffer (Lexing.lexeme lexbuf);
+      comment state lexbuf
+    }
+  | "*)"
+      { match state.comment_start_loc with
+        | [] -> assert false
+        | [_] -> state.comment_start_loc <- []; return (Location.curr lexbuf)
+        | _ :: l -> state.comment_start_loc <- l;
+                  Buffer.add_string state.buffer (Lexing.lexeme lexbuf);
+                  comment state lexbuf
+       }
+  | "\""
+      {
+        state.string_start_loc <- Location.curr lexbuf;
+        Buffer.add_char state.buffer '\"';
+        let buffer = state.buffer in
+        state.buffer <- Buffer.create 15;
+        (catch (string state lexbuf) (fun e l -> match e with
+             | Unterminated_string ->
+               begin match state.comment_start_loc with
+                 | [] -> assert false
+                 | loc :: _ ->
+                   let start = List.hd (List.rev state.comment_start_loc) in
+                   state.comment_start_loc <- [];
+                   fail_loc (Unterminated_string_in_comment (start, l)) loc
+               end
+             | e -> fail_loc e l
+           )
+        ) >>= fun _loc ->
+      state.string_start_loc <- Location.none;
+      Buffer.add_string buffer (String.escaped (Buffer.contents state.buffer));
+      state.buffer <- buffer;
+      Buffer.add_char state.buffer '\"';
+      comment state lexbuf }
+  | "{" ('%' '%'? extattrident blank*)? lowercase* "|"
+      {
+        let delim = Lexing.lexeme lexbuf in
+        let delim = String.sub delim ~pos:1 ~len:(String.length delim - 2) in
+        state.string_start_loc <- Location.curr lexbuf;
+        Buffer.add_string state.buffer (Lexing.lexeme lexbuf);
+        (catch (quoted_string delim state lexbuf) (fun e l -> match e with
+             | Unterminated_string ->
+               begin match state.comment_start_loc with
+                 | [] -> assert false
+                 | loc :: _ ->
+                   let start = List.hd (List.rev state.comment_start_loc) in
+                   state.comment_start_loc <- [];
+                   fail_loc (Unterminated_string_in_comment (start, l)) loc
+               end
+             | e -> fail_loc e l
+           )
+        ) >>= fun _loc ->
+        state.string_start_loc <- Location.none;
+        Buffer.add_char state.buffer '|';
+        Buffer.add_string state.buffer delim;
+        Buffer.add_char state.buffer '}';
+        comment state lexbuf }
+
+  | "''"
+      { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf }
+  | "'" newline "'"
+      { update_loc lexbuf None 1 false 1;
+        Buffer.add_string state.buffer (Lexing.lexeme lexbuf);
+        comment state lexbuf
+      }
+  | "'" [^ '\\' '\'' '\010' '\013' ] "'"
+      { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf }
+  | "'\\" ['\\' '\"' '\'' 'n' 't' 'b' 'r' ' '] "'"
+      { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf }
+  | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
+      { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf }
+  | "\'\\" 'o' ['0'-'3'] ['0'-'7'] ['0'-'7'] "\'"
+      { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf }
+  | "'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "'"
+      { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf }
+  | eof
+      { match state.comment_start_loc with
+        | [] -> assert false
+        | loc :: _ ->
+          let start = List.hd (List.rev state.comment_start_loc) in
+          state.comment_start_loc <- [];
+          fail_loc (Unterminated_comment start) loc
+      }
+  | newline
+      { update_loc lexbuf None 1 false 0;
+        Buffer.add_string state.buffer (Lexing.lexeme lexbuf);
+        comment state lexbuf
+      }
+  | (lowercase | uppercase) identchar *
+      { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf }
+  | _
+      { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf }
+
+and string state = parse
+    '\"'
+      { return lexbuf.lex_start_p  }
+  | '\\' newline ([' ' '\t'] * as space)
+      { update_loc lexbuf None 1 false (String.length space);
+        string state lexbuf
+      }
+  | '\\' ['\\' '\'' '\"' 'n' 't' 'b' 'r' ' ']
+      { Buffer.add_char state.buffer
+          (char_for_backslash (Lexing.lexeme_char lexbuf 1));
+        string state lexbuf }
+  | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9']
+      { char_for_decimal_code state lexbuf 1 >>= fun c ->
+        Buffer.add_char state.buffer c;
+        string state lexbuf }
+  | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F']
+      { Buffer.add_char state.buffer (char_for_hexadecimal_code lexbuf 2);
+        string state lexbuf }
+  | '\\' 'u' '{' hex_digit+ '}'
+      { store_escaped_uchar state lexbuf (uchar_for_uchar_escape lexbuf);
+        string state lexbuf }
+  | '\\' _
+      { if in_comment state
+        then string state lexbuf
+        else begin
+(*  Should be an error, but we are very lax.
+                  fail (Illegal_escape (Lexing.lexeme lexbuf),
+                        (Location.curr lexbuf)
+*)
+          let loc = Location.curr lexbuf in
+          Location.prerr_warning loc Warnings.Illegal_backslash;
+          Buffer.add_char state.buffer (Lexing.lexeme_char lexbuf 0);
+          Buffer.add_char state.buffer (Lexing.lexeme_char lexbuf 1);
+          string state lexbuf
+        end
+      }
+  | newline
+      { if not (in_comment state) then
+          Location.prerr_warning (Location.curr lexbuf) Warnings.Eol_in_string;
+        update_loc lexbuf None 1 false 0;
+        Buffer.add_string state.buffer (Lexing.lexeme lexbuf);
+        string state lexbuf
+      }
+  | eof
+      { let loc = state.string_start_loc in
+        state.string_start_loc <- Location.none;
+        fail_loc Unterminated_string loc }
+  | _
+      { Buffer.add_char state.buffer (Lexing.lexeme_char lexbuf 0);
+        string state lexbuf }
+
+and quoted_string delim state = parse
+  | newline
+      { update_loc lexbuf None 1 false 0;
+        Buffer.add_string state.buffer (Lexing.lexeme lexbuf);
+        quoted_string delim state lexbuf
+      }
+  | eof
+      { let loc = state.string_start_loc in
+        state.string_start_loc <- Location.none;
+        fail_loc Unterminated_string loc }
+  | "|" lowercase* "}"
+      {
+        let edelim = Lexing.lexeme lexbuf in
+        let edelim = String.sub edelim ~pos:1 ~len:(String.length edelim - 2) in
+        if delim = edelim then return lexbuf.lex_start_p
+        else (Buffer.add_string state.buffer (Lexing.lexeme lexbuf);
+              quoted_string delim state lexbuf)
+      }
+  | _
+      { Buffer.add_char state.buffer (Lexing.lexeme_char lexbuf 0);
+        quoted_string delim state lexbuf }
+
+and skip_sharp_bang state = parse
+  | "#!" [^ '\n']* '\n' [^ '\n']* "\n!#\n"
+      { update_loc lexbuf None 3 false 0; token state lexbuf }
+  | "#!" [^ '\n']* '\n'
+      { update_loc lexbuf None 1 false 0; token state lexbuf }
+  | "" { token state lexbuf }
+
+{
+  type comment = string * Location.t
+
+  (* preprocessor support not implemented, not compatible with monadic
+     interface *)
+
+  let rec token_without_comments state lexbuf =
+    token state lexbuf >>= function
+    | COMMENT _ ->
+      token_without_comments state lexbuf
+    | tok -> return tok
+}
diff --git a/src/ocaml/preprocess/menhirLib.ml b/src/ocaml/preprocess/menhirLib.ml
new file mode 100644
index 0000000..f178293
--- /dev/null
+++ b/src/ocaml/preprocess/menhirLib.ml
@@ -0,0 +1,3789 @@
+module General = struct
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* --------------------------------------------------------------------------- *)
+
+(* Lists. *)
+
+let rec take n xs =
+  match n, xs with
+  | 0, _
+  | _, [] ->
+      []
+  | _, (x :: xs as input) ->
+     let xs' = take (n - 1) xs in
+     if xs == xs' then
+       input
+     else
+       x :: xs'
+
+let rec drop n xs =
+  match n, xs with
+  | 0, _ ->
+      xs
+  | _, [] ->
+      []
+  | _, _ :: xs ->
+      drop (n - 1) xs
+
+let rec uniq1 cmp x ys =
+  match ys with
+  | [] ->
+      []
+  | y :: ys ->
+      if cmp x y = 0 then
+        uniq1 cmp x ys
+      else
+        y :: uniq1 cmp y ys
+
+let uniq cmp xs =
+  match xs with
+  | [] ->
+      []
+  | x :: xs ->
+      x :: uniq1 cmp x xs
+
+let weed cmp xs =
+  uniq cmp (List.sort cmp xs)
+
+(* --------------------------------------------------------------------------- *)
+
+(* Streams. *)
+
+type 'a stream =
+    'a head Lazy.t
+
+and 'a head =
+  | Nil
+  | Cons of 'a * 'a stream
+
+(* The length of a stream. *)
+
+let rec length xs =
+  match Lazy.force xs with
+  | Nil ->
+      0
+  | Cons (_, xs) ->
+      1 + length xs
+
+(* Folding over a stream. *)
+
+let rec foldr f xs accu =
+  match Lazy.force xs with
+  | Nil ->
+      accu
+  | Cons (x, xs) ->
+      f x (foldr f xs accu)
+end
+module Convert = struct
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* An ocamlyacc-style, or Menhir-style, parser requires access to
+   the lexer, which must be parameterized with a lexing buffer, and
+   to the lexing buffer itself, where it reads position information. *)
+
+(* This traditional API is convenient when used with ocamllex, but
+   inelegant when used with other lexer generators. *)
+
+type ('token, 'semantic_value) traditional =
+    (Lexing.lexbuf -> 'token) -> Lexing.lexbuf -> 'semantic_value
+
+(* This revised API is independent of any lexer generator. Here, the
+   parser only requires access to the lexer, and the lexer takes no
+   parameters. The tokens returned by the lexer may contain position
+   information. *)
+
+type ('token, 'semantic_value) revised =
+    (unit -> 'token) -> 'semantic_value
+
+(* --------------------------------------------------------------------------- *)
+
+(* Converting a traditional parser, produced by ocamlyacc or Menhir,
+   into a revised parser. *)
+
+(* A token of the revised lexer is essentially a triple of a token
+   of the traditional lexer (or raw token), a start position, and
+   and end position. The three [get] functions are accessors. *)
+
+(* We do not require the type ['token] to actually be a triple type.
+   This enables complex applications where it is a record type with
+   more than three fields. It also enables simple applications where
+   positions are of no interest, so ['token] is just ['raw_token]
+   and [get_startp] and [get_endp] return dummy positions. *)
+
+let traditional2revised
+  (get_raw_token : 'token -> 'raw_token)
+  (get_startp    : 'token -> Lexing.position)
+  (get_endp      : 'token -> Lexing.position)
+  (parser : ('raw_token, 'semantic_value) traditional)
+: ('token, 'semantic_value) revised =
+
+  (* Accept a revised lexer. *)
+
+  fun (lexer : unit -> 'token) ->
+
+    (* Create a dummy lexing buffer. *)
+
+    let lexbuf : Lexing.lexbuf =
+      Lexing.from_string ""
+    in
+
+    (* Wrap the revised lexer as a traditional lexer. A traditional
+       lexer returns a raw token and updates the fields of the lexing
+       buffer with new positions, which will be read by the parser. *)
+
+    let lexer (lexbuf : Lexing.lexbuf) : 'raw_token =
+      let token : 'token = lexer() in
+      lexbuf.Lexing.lex_start_p <- get_startp token;
+      lexbuf.Lexing.lex_curr_p <- get_endp token;
+      get_raw_token token
+    in
+
+    (* Invoke the traditional parser. *)
+
+    parser lexer lexbuf
+
+(* --------------------------------------------------------------------------- *)
+
+(* Converting a revised parser back to a traditional parser. *)
+
+let revised2traditional
+  (make_token : 'raw_token -> Lexing.position -> Lexing.position -> 'token)
+  (parser : ('token, 'semantic_value) revised)
+: ('raw_token, 'semantic_value) traditional =
+
+  (* Accept a traditional lexer and a lexing buffer. *)
+
+  fun (lexer : Lexing.lexbuf -> 'raw_token) (lexbuf : Lexing.lexbuf) ->
+
+    (* Wrap the traditional lexer as a revised lexer. *)
+
+    let lexer () : 'token =
+      let token : 'raw_token = lexer lexbuf in
+      make_token token lexbuf.Lexing.lex_start_p lexbuf.Lexing.lex_curr_p
+    in
+
+    (* Invoke the revised parser. *)
+
+    parser lexer
+
+(* --------------------------------------------------------------------------- *)
+
+(* Simplified versions of the above, where concrete triples are used. *)
+
+module Simplified = struct
+
+  let traditional2revised parser =
+    traditional2revised
+      (fun (token, _, _)  -> token)
+      (fun (_, startp, _) -> startp)
+      (fun (_, _, endp)   -> endp)
+      parser
+
+  let revised2traditional parser =
+    revised2traditional
+      (fun token startp endp -> (token, startp, endp))
+      parser
+
+end
+end
+module IncrementalEngine = struct
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+type position = Lexing.position
+
+open General
+
+(* This signature describes the incremental LR engine. *)
+
+(* In this mode, the user controls the lexer, and the parser suspends
+   itself when it needs to read a new token. *)
+
+module type INCREMENTAL_ENGINE = sig
+
+  type token
+
+  (* A value of type [production] is (an index for) a production. The start
+     productions (which do not exist in an \mly file, but are constructed by
+     Menhir internally) are not part of this type. *)
+
+  type production
+
+  (* The type ['a checkpoint] represents an intermediate or final state of the
+     parser. An intermediate checkpoint is a suspension: it records the parser's
+     current state, and allows parsing to be resumed. The parameter ['a] is
+     the type of the semantic value that will eventually be produced if the
+     parser succeeds. *)
+
+  (* [Accepted] and [Rejected] are final checkpoints. [Accepted] carries a
+     semantic value. *)
+
+  (* [InputNeeded] is an intermediate checkpoint. It means that the parser wishes
+     to read one token before continuing. *)
+
+  (* [Shifting] is an intermediate checkpoint. It means that the parser is taking
+     a shift transition. It exposes the state of the parser before and after
+     the transition. The Boolean parameter tells whether the parser intends to
+     request a new token after this transition. (It always does, except when
+     it is about to accept.) *)
+
+  (* [AboutToReduce] is an intermediate checkpoint. It means that the parser is
+     about to perform a reduction step. It exposes the parser's current
+     state as well as the production that is about to be reduced. *)
+
+  (* [HandlingError] is an intermediate checkpoint. It means that the parser has
+     detected an error and is currently handling it, in several steps. *)
+
+  (* A value of type ['a env] represents a configuration of the automaton:
+     current state, stack, lookahead token, etc. The parameter ['a] is the
+     type of the semantic value that will eventually be produced if the parser
+     succeeds. *)
+
+  (* In normal operation, the parser works with checkpoints: see the functions
+     [offer] and [resume]. However, it is also possible to work directly with
+     environments (see the functions [pop], [force_reduction], and [feed]) and
+     to reconstruct a checkpoint out of an environment (see [input_needed]).
+     This is considered advanced functionality; its purpose is to allow error
+     recovery strategies to be programmed by the user. *)
+
+  type 'a env
+
+  type 'a checkpoint = private
+    | InputNeeded of 'a env
+    | Shifting of 'a env * 'a env * bool
+    | AboutToReduce of 'a env * production
+    | HandlingError of 'a env
+    | Accepted of 'a
+    | Rejected
+
+  (* [offer] allows the user to resume the parser after it has suspended
+     itself with a checkpoint of the form [InputNeeded env]. [offer] expects
+     the old checkpoint as well as a new token and produces a new checkpoint.
+     It does not raise any exception. *)
+
+  val offer:
+    'a checkpoint ->
+    token * position * position ->
+    'a checkpoint
+
+  (* [resume] allows the user to resume the parser after it has suspended
+     itself with a checkpoint of the form [AboutToReduce (env, prod)] or
+     [HandlingError env]. [resume] expects the old checkpoint and produces a
+     new checkpoint. It does not raise any exception. *)
+
+  (* The optional argument [strategy] influences the manner in which [resume]
+     deals with checkpoints of the form [ErrorHandling _]. Its default value
+     is [`Legacy]. It can be briefly described as follows:
+
+     - If the [error] token is used only to report errors (that is, if the
+       [error] token appears only at the end of a production, whose semantic
+       action raises an exception) then the simplified strategy should be
+       preferred. (This includes the case where the [error] token does not
+       appear at all in the grammar.)
+
+     - If the [error] token is used to recover after an error, or if
+       perfect backward compatibility is required, the legacy strategy
+       should be selected.
+
+     More details on these strategies appear in the file [Engine.ml]. *)
+
+  type strategy =
+    [ `Legacy | `Simplified ]
+
+  val resume:
+    ?strategy:strategy ->
+    'a checkpoint ->
+    'a checkpoint
+
+  (* A token supplier is a function of no arguments which delivers a new token
+     (together with its start and end positions) every time it is called. *)
+
+  type supplier =
+    unit -> token * position * position
+
+  (* A pair of a lexer and a lexing buffer can be easily turned into a
+     supplier. *)
+
+  val lexer_lexbuf_to_supplier:
+    (Lexing.lexbuf -> token) ->
+    Lexing.lexbuf ->
+    supplier
+
+  (* The functions [offer] and [resume] are sufficient to write a parser loop.
+     One can imagine many variations (which is why we expose these functions
+     in the first place!). Here, we expose a few variations of the main loop,
+     ready for use. *)
+
+  (* [loop supplier checkpoint] begins parsing from [checkpoint], reading
+     tokens from [supplier]. It continues parsing until it reaches a
+     checkpoint of the form [Accepted v] or [Rejected]. In the former case, it
+     returns [v]. In the latter case, it raises the exception [Error].
+     The optional argument [strategy], whose default value is [Legacy],
+     is passed to [resume] and influences the error-handling strategy. *)
+
+  val loop: ?strategy:strategy -> supplier -> 'a checkpoint -> 'a
+
+  (* [loop_handle succeed fail supplier checkpoint] begins parsing from
+     [checkpoint], reading tokens from [supplier]. It continues parsing until
+     it reaches a checkpoint of the form [Accepted v] or [HandlingError env]
+     (or [Rejected], but that should not happen, as [HandlingError _] will be
+     observed first). In the former case, it calls [succeed v]. In the latter
+     case, it calls [fail] with this checkpoint. It cannot raise [Error].
+
+     This means that Menhir's error-handling procedure does not get a chance
+     to run. For this reason, there is no [strategy] parameter. Instead, the
+     user can implement her own error handling code, in the [fail]
+     continuation. *)
+
+  val loop_handle:
+    ('a -> 'answer) ->
+    ('a checkpoint -> 'answer) ->
+    supplier -> 'a checkpoint -> 'answer
+
+  (* [loop_handle_undo] is analogous to [loop_handle], except it passes a pair
+     of checkpoints to the failure continuation.
+
+     The first (and oldest) checkpoint is the last [InputNeeded] checkpoint that
+     was encountered before the error was detected. The second (and newest)
+     checkpoint is where the error was detected, as in [loop_handle]. Going back
+     to the first checkpoint can be thought of as undoing any reductions that
+     were performed after seeing the problematic token. (These reductions must
+     be default reductions or spurious reductions.)
+
+     [loop_handle_undo] must initially be applied to an [InputNeeded] checkpoint.
+     The parser's initial checkpoints satisfy this constraint. *)
+
+  val loop_handle_undo:
+    ('a -> 'answer) ->
+    ('a checkpoint -> 'a checkpoint -> 'answer) ->
+    supplier -> 'a checkpoint -> 'answer
+
+  (* [shifts checkpoint] assumes that [checkpoint] has been obtained by
+     submitting a token to the parser. It runs the parser from [checkpoint],
+     through an arbitrary number of reductions, until the parser either
+     accepts this token (i.e., shifts) or rejects it (i.e., signals an error).
+     If the parser decides to shift, then [Some env] is returned, where [env]
+     is the parser's state just before shifting. Otherwise, [None] is
+     returned. *)
+
+  (* It is desirable that the semantic actions be side-effect free, or that
+     their side-effects be harmless (replayable). *)
+
+  val shifts: 'a checkpoint -> 'a env option
+
+  (* The function [acceptable] allows testing, after an error has been
+     detected, which tokens would have been accepted at this point. It is
+     implemented using [shifts]. Its argument should be an [InputNeeded]
+     checkpoint. *)
+
+  (* For completeness, one must undo any spurious reductions before carrying out
+     this test -- that is, one must apply [acceptable] to the FIRST checkpoint
+     that is passed by [loop_handle_undo] to its failure continuation. *)
+
+  (* This test causes some semantic actions to be run! The semantic actions
+     should be side-effect free, or their side-effects should be harmless. *)
+
+  (* The position [pos] is used as the start and end positions of the
+     hypothetical token, and may be picked up by the semantic actions. We
+     suggest using the position where the error was detected. *)
+
+  val acceptable: 'a checkpoint -> token -> position -> bool
+
+  (* The abstract type ['a lr1state] describes the non-initial states of the
+     LR(1) automaton. The index ['a] represents the type of the semantic value
+     associated with this state's incoming symbol. *)
+
+  type 'a lr1state
+
+  (* The states of the LR(1) automaton are numbered (from 0 and up). *)
+
+  val number: _ lr1state -> int
+
+  (* Productions are numbered. *)
+
+  (* [find_production i] requires the index [i] to be valid. Use with care. *)
+
+  val production_index: production -> int
+  val find_production: int -> production
+
+  (* An element is a pair of a non-initial state [s] and a semantic value [v]
+     associated with the incoming symbol of this state. The idea is, the value
+     [v] was pushed onto the stack just before the state [s] was entered. Thus,
+     for some type ['a], the state [s] has type ['a lr1state] and the value [v]
+     has type ['a]. In other words, the type [element] is an existential type. *)
+
+  type element =
+    | Element: 'a lr1state * 'a * position * position -> element
+
+  (* The parser's stack is (or, more precisely, can be viewed as) a stream of
+     elements. The type [stream] is defined by the module [General]. *)
+
+  (* As of 2017/03/31, the types [stream] and [stack] and the function [stack]
+     are DEPRECATED. They might be removed in the future. An alternative way
+     of inspecting the stack is via the functions [top] and [pop]. *)
+
+  type stack = (* DEPRECATED *)
+    element stream
+
+  (* This is the parser's stack, a stream of elements. This stream is empty if
+     the parser is in an initial state; otherwise, it is non-empty.  The LR(1)
+     automaton's current state is the one found in the top element of the
+     stack. *)
+
+  val stack: 'a env -> stack (* DEPRECATED *)
+
+  (* [top env] returns the parser's top stack element. The state contained in
+     this stack element is the current state of the automaton. If the stack is
+     empty, [None] is returned. In that case, the current state of the
+     automaton must be an initial state. *)
+
+  val top: 'a env -> element option
+
+  (* [pop_many i env] pops [i] cells off the automaton's stack. This is done
+     via [i] successive invocations of [pop]. Thus, [pop_many 1] is [pop]. The
+     index [i] must be nonnegative. The time complexity is O(i). *)
+
+  val pop_many: int -> 'a env -> 'a env option
+
+  (* [get i env] returns the parser's [i]-th stack element. The index [i] is
+     0-based: thus, [get 0] is [top]. If [i] is greater than or equal to the
+     number of elements in the stack, [None] is returned. The time complexity
+     is O(i). *)
+
+  val get: int -> 'a env -> element option
+
+  (* [current_state_number env] is (the integer number of) the automaton's
+     current state. This works even if the automaton's stack is empty, in
+     which case the current state is an initial state. This number can be
+     passed as an argument to a [message] function generated by [menhir
+     --compile-errors]. *)
+
+  val current_state_number: 'a env -> int
+
+  (* [equal env1 env2] tells whether the parser configurations [env1] and
+     [env2] are equal in the sense that the automaton's current state is the
+     same in [env1] and [env2] and the stack is *physically* the same in
+     [env1] and [env2]. If [equal env1 env2] is [true], then the sequence of
+     the stack elements, as observed via [pop] and [top], must be the same in
+     [env1] and [env2]. Also, if [equal env1 env2] holds, then the checkpoints
+     [input_needed env1] and [input_needed env2] must be equivalent. The
+     function [equal] has time complexity O(1). *)
+
+  val equal: 'a env -> 'a env -> bool
+
+  (* These are the start and end positions of the current lookahead token. If
+     invoked in an initial state, this function returns a pair of twice the
+     initial position. *)
+
+  val positions: 'a env -> position * position
+
+  (* When applied to an environment taken from a checkpoint of the form
+     [AboutToReduce (env, prod)], the function [env_has_default_reduction]
+     tells whether the reduction that is about to take place is a default
+     reduction. *)
+
+  val env_has_default_reduction: 'a env -> bool
+
+  (* [state_has_default_reduction s] tells whether the state [s] has a default
+     reduction. This includes the case where [s] is an accepting state. *)
+
+  val state_has_default_reduction: _ lr1state -> bool
+
+  (* [pop env] returns a new environment, where the parser's top stack cell
+     has been popped off. (If the stack is empty, [None] is returned.) This
+     amounts to pretending that the (terminal or nonterminal) symbol that
+     corresponds to this stack cell has not been read. *)
+
+  val pop: 'a env -> 'a env option
+
+  (* [force_reduction prod env] should be called only if in the state [env]
+     the parser is capable of reducing the production [prod]. If this
+     condition is satisfied, then this production is reduced, which means that
+     its semantic action is executed (this can have side effects!) and the
+     automaton makes a goto (nonterminal) transition. If this condition is not
+     satisfied, [Invalid_argument _] is raised. *)
+
+  val force_reduction: production -> 'a env -> 'a env
+
+  (* [input_needed env] returns [InputNeeded env]. That is, out of an [env]
+     that might have been obtained via a series of calls to the functions
+     [pop], [force_reduction], [feed], etc., it produces a checkpoint, which
+     can be used to resume normal parsing, by supplying this checkpoint as an
+     argument to [offer]. *)
+
+  (* This function should be used with some care. It could "mess up the
+     lookahead" in the sense that it allows parsing to resume in an arbitrary
+     state [s] with an arbitrary lookahead symbol [t], even though Menhir's
+     reachability analysis (menhir --list-errors) might well think that it is
+     impossible to reach this particular configuration. If one is using
+     Menhir's new error reporting facility, this could cause the parser to
+     reach an error state for which no error message has been prepared. *)
+
+  val input_needed: 'a env -> 'a checkpoint
+
+end
+
+(* This signature is a fragment of the inspection API that is made available
+   to the user when [--inspection] is used. This fragment contains type
+   definitions for symbols. *)
+
+module type SYMBOLS = sig
+
+  (* The type ['a terminal] represents a terminal symbol. The type ['a
+     nonterminal] represents a nonterminal symbol. In both cases, the index
+     ['a] represents the type of the semantic values associated with this
+     symbol. The concrete definitions of these types are generated. *)
+
+  type 'a terminal
+  type 'a nonterminal
+
+  (* The type ['a symbol] represents a terminal or nonterminal symbol. It is
+     the disjoint union of the types ['a terminal] and ['a nonterminal]. *)
+
+  type 'a symbol =
+    | T : 'a terminal -> 'a symbol
+    | N : 'a nonterminal -> 'a symbol
+
+  (* The type [xsymbol] is an existentially quantified version of the type
+     ['a symbol]. This type is useful in situations where the index ['a]
+     is not statically known. *)
+
+  type xsymbol =
+    | X : 'a symbol -> xsymbol
+
+end
+
+(* This signature describes the inspection API that is made available to the
+   user when [--inspection] is used. *)
+
+module type INSPECTION = sig
+
+  (* The types of symbols are described above. *)
+
+  include SYMBOLS
+
+  (* The type ['a lr1state] is meant to be the same as in [INCREMENTAL_ENGINE]. *)
+
+  type 'a lr1state
+
+  (* The type [production] is meant to be the same as in [INCREMENTAL_ENGINE].
+     It represents a production of the grammar. A production can be examined
+     via the functions [lhs] and [rhs] below. *)
+
+  type production
+
+  (* An LR(0) item is a pair of a production [prod] and a valid index [i] into
+     this production. That is, if the length of [rhs prod] is [n], then [i] is
+     comprised between 0 and [n], inclusive. *)
+
+  type item =
+      production * int
+
+  (* Ordering functions. *)
+
+  val compare_terminals: _ terminal -> _ terminal -> int
+  val compare_nonterminals: _ nonterminal -> _ nonterminal -> int
+  val compare_symbols: xsymbol -> xsymbol -> int
+  val compare_productions: production -> production -> int
+  val compare_items: item -> item -> int
+
+  (* [incoming_symbol s] is the incoming symbol of the state [s], that is,
+     the symbol that the parser must recognize before (has recognized when)
+     it enters the state [s]. This function gives access to the semantic
+     value [v] stored in a stack element [Element (s, v, _, _)]. Indeed,
+     by case analysis on the symbol [incoming_symbol s], one discovers the
+     type ['a] of the value [v]. *)
+
+  val incoming_symbol: 'a lr1state -> 'a symbol
+
+  (* [items s] is the set of the LR(0) items in the LR(0) core of the LR(1)
+     state [s]. This set is not epsilon-closed. This set is presented as a
+     list, in an arbitrary order. *)
+
+  val items: _ lr1state -> item list
+
+  (* [lhs prod] is the left-hand side of the production [prod]. This is
+     always a non-terminal symbol. *)
+
+  val lhs: production -> xsymbol
+
+  (* [rhs prod] is the right-hand side of the production [prod]. This is
+     a (possibly empty) sequence of (terminal or nonterminal) symbols. *)
+
+  val rhs: production -> xsymbol list
+
+  (* [nullable nt] tells whether the non-terminal symbol [nt] is nullable.
+     That is, it is true if and only if this symbol produces the empty
+     word [epsilon]. *)
+
+  val nullable: _ nonterminal -> bool
+
+  (* [first nt t] tells whether the FIRST set of the nonterminal symbol [nt]
+     contains the terminal symbol [t]. That is, it is true if and only if
+     [nt] produces a word that begins with [t]. *)
+
+  val first: _ nonterminal -> _ terminal -> bool
+
+  (* [xfirst] is analogous to [first], but expects a first argument of type
+     [xsymbol] instead of [_ terminal]. *)
+
+  val xfirst: xsymbol -> _ terminal -> bool
+
+  (* [foreach_terminal] enumerates the terminal symbols, including [error].
+     [foreach_terminal_but_error] enumerates the terminal symbols, excluding
+     [error]. *)
+
+  val foreach_terminal:           (xsymbol -> 'a -> 'a) -> 'a -> 'a
+  val foreach_terminal_but_error: (xsymbol -> 'a -> 'a) -> 'a -> 'a
+
+  (* The type [env] is meant to be the same as in [INCREMENTAL_ENGINE]. *)
+
+  type 'a env
+
+  (* [feed symbol startp semv endp env] causes the parser to consume the
+     (terminal or nonterminal) symbol [symbol], accompanied with the semantic
+     value [semv] and with the start and end positions [startp] and [endp].
+     Thus, the automaton makes a transition, and reaches a new state. The
+     stack grows by one cell. This operation is permitted only if the current
+     state (as determined by [env]) has an outgoing transition labeled with
+     [symbol]. Otherwise, [Invalid_argument _] is raised. *)
+
+  val feed: 'a symbol -> position -> 'a -> position -> 'b env -> 'b env
+
+end
+
+(* This signature combines the incremental API and the inspection API. *)
+
+module type EVERYTHING = sig
+
+  include INCREMENTAL_ENGINE
+
+  include INSPECTION
+    with type 'a lr1state := 'a lr1state
+    with type production := production
+    with type 'a env := 'a env
+
+end
+end
+module EngineTypes = struct
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* This file defines several types and module types that are used in the
+   specification of module [Engine]. *)
+
+(* --------------------------------------------------------------------------- *)
+
+(* It would be nice if we could keep the structure of stacks and environments
+   hidden. However, stacks and environments must be accessible to semantic
+   actions, so the following data structure definitions must be public. *)
+
+(* --------------------------------------------------------------------------- *)
+
+(* A stack is a linked list of cells. A sentinel cell -- which is its own
+   successor -- is used to mark the bottom of the stack. The sentinel cell
+   itself is not significant -- it contains dummy values. *)
+
+type ('state, 'semantic_value) stack = {
+
+  (* The state that we should go back to if we pop this stack cell. *)
+
+  (* This convention means that the state contained in the top stack cell is
+     not the current state [env.current]. It also means that the state found
+     within the sentinel is a dummy -- it is never consulted. This convention
+     is the same as that adopted by the code-based back-end. *)
+
+  state: 'state;
+
+  (* The semantic value associated with the chunk of input that this cell
+     represents. *)
+
+  semv: 'semantic_value;
+
+  (* The start and end positions of the chunk of input that this cell
+     represents. *)
+
+  startp: Lexing.position;
+  endp: Lexing.position;
+
+  (* The next cell down in the stack. If this is a self-pointer, then this
+     cell is the sentinel, and the stack is conceptually empty. *)
+
+  next: ('state, 'semantic_value) stack;
+
+}
+
+(* --------------------------------------------------------------------------- *)
+
+(* A parsing environment contains all of the parser's state (except for the
+   current program point). *)
+
+type ('state, 'semantic_value, 'token) env = {
+
+  (* If this flag is true, then the first component of [env.triple] should
+     be ignored, as it has been logically overwritten with the [error]
+     pseudo-token. *)
+
+  error: bool;
+
+  (* The last token that was obtained from the lexer, together with its start
+     and end positions. Warning: before the first call to the lexer has taken
+     place, a dummy (and possibly invalid) token is stored here. *)
+
+  triple: 'token * Lexing.position * Lexing.position;
+
+  (* The stack. In [CodeBackend], it is passed around on its own,
+     whereas, here, it is accessed via the environment. *)
+
+  stack: ('state, 'semantic_value) stack;
+
+  (* The current state. In [CodeBackend], it is passed around on its
+     own, whereas, here, it is accessed via the environment. *)
+
+  current: 'state;
+
+}
+
+(* --------------------------------------------------------------------------- *)
+
+(* This signature describes the parameters that must be supplied to the LR
+   engine. *)
+
+module type TABLE = sig
+
+  (* The type of automaton states. *)
+
+  type state
+
+  (* States are numbered. *)
+
+  val number: state -> int
+
+  (* The type of tokens. These can be thought of as real tokens, that is,
+     tokens returned by the lexer. They carry a semantic value. This type
+     does not include the [error] pseudo-token. *)
+
+  type token
+
+  (* The type of terminal symbols. These can be thought of as integer codes.
+     They do not carry a semantic value. This type does include the [error]
+     pseudo-token. *)
+
+  type terminal
+
+  (* The type of nonterminal symbols. *)
+
+  type nonterminal
+
+  (* The type of semantic values. *)
+
+  type semantic_value
+
+  (* A token is conceptually a pair of a (non-[error]) terminal symbol and
+     a semantic value. The following two functions are the pair projections. *)
+
+  val token2terminal: token -> terminal
+  val token2value: token -> semantic_value
+
+  (* Even though the [error] pseudo-token is not a real token, it is a
+     terminal symbol. Furthermore, for regularity, it must have a semantic
+     value. *)
+
+  val error_terminal: terminal
+  val error_value: semantic_value
+
+  (* [foreach_terminal] allows iterating over all terminal symbols. *)
+
+  val foreach_terminal: (terminal -> 'a -> 'a) -> 'a -> 'a
+
+  (* The type of productions. *)
+
+  type production
+
+  val production_index: production -> int
+  val find_production: int -> production
+
+  (* If a state [s] has a default reduction on production [prod], then, upon
+     entering [s], the automaton should reduce [prod] without consulting the
+     lookahead token. The following function allows determining which states
+     have default reductions. *)
+
+  (* Instead of returning a value of a sum type -- either [DefRed prod], or
+     [NoDefRed] -- it accepts two continuations, and invokes just one of
+     them. This mechanism allows avoiding a memory allocation. *)
+
+  val default_reduction:
+    state ->
+    ('env -> production -> 'answer) ->
+    ('env -> 'answer) ->
+    'env -> 'answer
+
+  (* An LR automaton can normally take three kinds of actions: shift, reduce,
+     or fail. (Acceptance is a particular case of reduction: it consists in
+     reducing a start production.) *)
+
+  (* There are two variants of the shift action. [shift/discard s] instructs
+     the automaton to discard the current token, request a new one from the
+     lexer, and move to state [s]. [shift/nodiscard s] instructs it to move to
+     state [s] without requesting a new token. This instruction should be used
+     when [s] has a default reduction on [#]. See [CodeBackend.gettoken] for
+     details. *)
+
+  (* This is the automaton's action table. It maps a pair of a state and a
+     terminal symbol to an action. *)
+
+  (* Instead of returning a value of a sum type -- one of shift/discard,
+     shift/nodiscard, reduce, or fail -- this function accepts three
+     continuations, and invokes just one them. This mechanism allows avoiding
+     a memory allocation. *)
+
+  (* In summary, the parameters to [action] are as follows:
+
+     - the first two parameters, a state and a terminal symbol, are used to
+       look up the action table;
+
+     - the next parameter is the semantic value associated with the above
+       terminal symbol; it is not used, only passed along to the shift
+       continuation, as explained below;
+
+     - the shift continuation expects an environment; a flag that tells
+       whether to discard the current token; the terminal symbol that
+       is being shifted; its semantic value; and the target state of
+       the transition;
+
+     - the reduce continuation expects an environment and a production;
+
+     - the fail continuation expects an environment;
+
+     - the last parameter is the environment; it is not used, only passed
+       along to the selected continuation. *)
+
+  val action:
+    state ->
+    terminal ->
+    semantic_value ->
+    ('env -> bool -> terminal -> semantic_value -> state -> 'answer) ->
+    ('env -> production -> 'answer) ->
+    ('env -> 'answer) ->
+    'env -> 'answer
+
+  (* This is the automaton's goto table. This table maps a pair of a state
+     and a nonterminal symbol to a new state. By extension, it also maps a
+     pair of a state and a production to a new state. *)
+
+  (* The function [goto_nt] can be applied to [s] and [nt] ONLY if the state
+     [s] has an outgoing transition labeled [nt]. Otherwise, its result is
+     undefined. Similarly, the call [goto_prod prod s] is permitted ONLY if
+     the state [s] has an outgoing transition labeled with the nonterminal
+     symbol [lhs prod]. The function [maybe_goto_nt] involves an additional
+     dynamic check and CAN be called even if there is no outgoing transition. *)
+
+  val       goto_nt  : state -> nonterminal -> state
+  val       goto_prod: state -> production  -> state
+  val maybe_goto_nt:   state -> nonterminal -> state option
+
+  (* [is_start prod] tells whether the production [prod] is a start production. *)
+
+  val is_start: production -> bool
+
+  (* By convention, a semantic action is responsible for:
+
+     1. fetching whatever semantic values and positions it needs off the stack;
+
+     2. popping an appropriate number of cells off the stack, as dictated
+        by the length of the right-hand side of the production;
+
+     3. computing a new semantic value, as well as new start and end positions;
+
+     4. pushing a new stack cell, which contains the three values
+        computed in step 3;
+
+     5. returning the new stack computed in steps 2 and 4.
+
+     Point 1 is essentially forced upon us: if semantic values were fetched
+     off the stack by this interpreter, then the calling convention for
+     semantic actions would be variadic: not all semantic actions would have
+     the same number of arguments. The rest follows rather naturally. *)
+
+  (* Semantic actions are allowed to raise [Error]. *)
+
+  exception Error
+
+  type semantic_action =
+      (state, semantic_value, token) env -> (state, semantic_value) stack
+
+  val semantic_action: production -> semantic_action
+
+  (* [may_reduce state prod] tests whether the state [state] is capable of
+     reducing the production [prod]. This function is currently costly and
+     is not used by the core LR engine. It is used in the implementation
+     of certain functions, such as [force_reduction], which allow the engine
+     to be driven programmatically. *)
+
+  val may_reduce: state -> production -> bool
+
+  (* The LR engine requires a number of hooks, which are used for logging. *)
+
+  (* The comments below indicate the conventional messages that correspond
+     to these hooks in the code-based back-end; see [CodeBackend]. *)
+
+  (* If the flag [log] is false, then the logging functions are not called.
+     If it is [true], then they are called. *)
+
+  val log : bool
+
+  module Log : sig
+
+    (* State %d: *)
+
+    val state: state -> unit
+
+    (* Shifting (<terminal>) to state <state> *)
+
+    val shift: terminal -> state -> unit
+
+    (* Reducing a production should be logged either as a reduction
+       event (for regular productions) or as an acceptance event (for
+       start productions). *)
+
+    (* Reducing production <production> / Accepting *)
+
+    val reduce_or_accept: production -> unit
+
+    (* Lookahead token is now <terminal> (<pos>-<pos>) *)
+
+    val lookahead_token: terminal -> Lexing.position -> Lexing.position -> unit
+
+    (* Initiating error handling *)
+
+    val initiating_error_handling: unit -> unit
+
+    (* Resuming error handling *)
+
+    val resuming_error_handling: unit -> unit
+
+    (* Handling error in state <state> *)
+
+    val handling_error: state -> unit
+
+  end
+
+end
+
+(* --------------------------------------------------------------------------- *)
+
+(* This signature describes the monolithic (traditional) LR engine. *)
+
+(* In this interface, the parser controls the lexer. *)
+
+module type MONOLITHIC_ENGINE = sig
+
+  type state
+
+  type token
+
+  type semantic_value
+
+  (* An entry point to the engine requires a start state, a lexer, and a lexing
+     buffer. It either succeeds and produces a semantic value, or fails and
+     raises [Error]. *)
+
+  exception Error
+
+  val entry:
+    (* strategy: *) [ `Legacy | `Simplified ] -> (* see [IncrementalEngine] *)
+    state ->
+    (Lexing.lexbuf -> token) ->
+    Lexing.lexbuf ->
+    semantic_value
+
+end
+
+(* --------------------------------------------------------------------------- *)
+
+(* The following signatures describe the incremental LR engine. *)
+
+(* First, see [INCREMENTAL_ENGINE] in the file [IncrementalEngine.ml]. *)
+
+(* The [start] function is set apart because we do not wish to publish
+   it as part of the generated [parser.mli] file. Instead, the table
+   back-end will publish specialized versions of it, with a suitable
+   type cast. *)
+
+module type INCREMENTAL_ENGINE_START = sig
+
+  (* [start] is an entry point. It requires a start state and a start position
+     and begins the parsing process. If the lexer is based on an OCaml lexing
+     buffer, the start position should be [lexbuf.lex_curr_p]. [start] produces
+     a checkpoint, which usually will be an [InputNeeded] checkpoint. (It could
+     be [Accepted] if this starting state accepts only the empty word. It could
+     be [Rejected] if this starting state accepts no word at all.) It does not
+     raise any exception. *)
+
+  (* [start s pos] should really produce a checkpoint of type ['a checkpoint],
+     for a fixed ['a] that depends on the state [s]. We cannot express this, so
+     we use [semantic_value checkpoint], which is safe. The table back-end uses
+     [Obj.magic] to produce safe specialized versions of [start]. *)
+
+  type state
+  type semantic_value
+  type 'a checkpoint
+
+  val start:
+    state ->
+    Lexing.position ->
+    semantic_value checkpoint
+
+end
+
+(* --------------------------------------------------------------------------- *)
+
+(* This signature describes the LR engine, which combines the monolithic
+   and incremental interfaces. *)
+
+module type ENGINE = sig
+
+  include MONOLITHIC_ENGINE
+
+  include IncrementalEngine.INCREMENTAL_ENGINE
+    with type token := token
+     and type 'a lr1state = state (* useful for us; hidden from the end user *)
+
+  include INCREMENTAL_ENGINE_START
+    with type state := state
+     and type semantic_value := semantic_value
+     and type 'a checkpoint := 'a checkpoint
+
+end
+end
+module Engine = struct
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+type position = Lexing.position
+open EngineTypes
+
+(* The LR parsing engine. *)
+
+(* This module is used:
+
+   - at compile time, if so requested by the user, via the --interpret options;
+   - at run time, in the table-based back-end. *)
+
+module Make (T : TABLE) = struct
+
+  (* This propagates type and exception definitions. The functions [number],
+     [production_index], [find_production], too, are defined by this [include]
+     declaration. *)
+
+  include T
+
+  type 'a env =
+      (state, semantic_value, token) EngineTypes.env
+
+  (* ------------------------------------------------------------------------ *)
+
+  (* The type [checkpoint] represents an intermediate or final result of the
+     parser. See [EngineTypes]. *)
+
+  (* The type [checkpoint] is presented to the user as a private type (see
+     [IncrementalEngine]). This prevents the user from manufacturing
+     checkpoints (i.e., continuations) that do not make sense. (Such
+     continuations could potentially violate the LR invariant and lead to
+     crashes.) *)
+
+  (* 2017/03/29 Although [checkpoint] is a private type, we now expose a
+     constructor function, [input_needed]. This function allows manufacturing
+     a checkpoint out of an environment. For this reason, the type [env] must
+     also be parameterized with ['a]. *)
+
+  type 'a checkpoint =
+    | InputNeeded of 'a env
+    | Shifting of 'a env * 'a env * bool
+    | AboutToReduce of 'a env * production
+    | HandlingError of 'a env
+    | Accepted of 'a
+    | Rejected
+
+  (* ------------------------------------------------------------------------ *)
+
+  (* As of 2020/12/16, we introduce a choice between multiple error handling
+     strategies. *)
+
+  (* Regardless of the strategy, when a syntax error is encountered, the
+     function [initiate] is called, a [HandlingError] checkpoint is produced,
+     and (after resuming) the function [error] is called. This function checks
+     whether the current state allows shifting, reducing, or neither, when the
+     lookahead token is [error]. Its behavior, then, depends on the strategy,
+     as follows. *)
+
+  (* In the legacy strategy, which until now was the only strategy,
+
+     - If shifting is possible, then a [Shifting] checkpoint is produced,
+       whose field [please_discard] is [true], so (after resuming) an
+       [InputNeeded] checkpoint is produced, and (after a new token
+       has been provided) the parser leaves error-handling mode and
+       returns to normal mode.
+
+     - If reducing is possible, then one or more reductions are performed.
+       Default reductions are announced via [AboutToReduce] checkpoints,
+       whereas ordinary reductions are performed silently. (It is unclear
+       why this is so.) The parser remains in error-handling mode, so
+       another [HandlingError] checkpoint is produced, and the function
+       [error] is called again.
+
+     - If neither action is possible and if the stack is nonempty, then a
+       cell is popped off the stack, then a [HandlingError] checkpoint is
+       produced, and the function [error] is called again.
+
+     - If neither action is possible and if the stack is empty, then the
+       parse dies with a [Reject] checkpoint. *)
+
+  (* The simplified strategy differs from the legacy strategy as follows:
+
+     - When shifting, a [Shifting] checkpoint is produced, whose field
+       [please_discard] is [false], so the parser does not request another
+       token, and the parser remains in error-handling mode. (If the
+       destination state of this shift transition has a default reduction,
+       then the parser will perform this reduction as its next step.)
+
+     - When reducing, all reductions are announced by [AboutToReduce]
+       checkpoints.
+
+     - If neither shifting [error] nor reducing on [error] is possible,
+       then the parser dies with a [Reject] checkpoint. (The parser does
+       not attempt to pop cells off the stack one by one.)
+
+     This simplified strategy is appropriate when the grammar uses the [error]
+     token in a limited way, where the [error] token always appears at the end
+     of a production whose semantic action raises an exception (whose purpose
+     is to signal a syntax error and perhaps produce a custom message). Then,
+     the parser must not request one token past the syntax error. (In a REPL,
+     that would be undesirable.) It must perform as many reductions on [error]
+     as possible, then (if possible) shift the [error] token and move to a new
+     state where a default reduction will be possible. (Because the [error]
+     token always appears at the end of a production, no other action can
+     exist in that state, so a default reduction must exist.) The semantic
+     action raises an exception, and that is it. *)
+
+  (* Let us note that it is also possible to perform no error handling at
+     all, or to perform customized error handling, by stopping as soon as
+     the first [ErrorHandling] checkpoint appears. *)
+
+  type strategy =
+    [ `Legacy | `Simplified ]
+
+  (* ------------------------------------------------------------------------ *)
+
+  (* In the code-based back-end, the [run] function is sometimes responsible
+     for pushing a new cell on the stack. This is motivated by code sharing
+     concerns. In this interpreter, there is no such concern; [run]'s caller
+     is always responsible for updating the stack. *)
+
+  (* In the code-based back-end, there is a [run] function for each state
+     [s]. This function can behave in two slightly different ways, depending
+     on when it is invoked, or (equivalently) depending on [s].
+
+     If [run] is invoked after shifting a terminal symbol (or, equivalently,
+     if [s] has a terminal incoming symbol), then [run] discards a token,
+     unless [s] has a default reduction on [#]. (Indeed, in that case,
+     requesting the next token might drive the lexer off the end of the input
+     stream.)
+
+     If, on the other hand, [run] is invoked after performing a goto
+     transition, or invoked directly by an entry point, then there is nothing
+     to discard.
+
+     These two cases are reflected in [CodeBackend.gettoken].
+
+     Here, the code is structured in a slightly different way. It is up to the
+     caller of [run] to indicate whether to discard a token, via the parameter
+     [please_discard]. This flag is set when [s] is being entered by shifting
+     a terminal symbol and [s] does not have a default reduction on [#]. *)
+
+  (* The following recursive group of functions are tail recursive, produce a
+     checkpoint of type [semantic_value checkpoint], and cannot raise an
+     exception. A semantic action can raise [Error], but this exception is
+     immediately caught within [reduce]. *)
+
+  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;
+
+    (* If [please_discard] is set, we discard the current lookahead token and
+       fetch the next one. In order to request a token from the user, we
+       return an [InputNeeded] continuation, which, when invoked by the user,
+       will take us to [discard]. If [please_discard] is not set, we skip this
+       step and jump directly to [check_for_default_reduction]. *)
+
+    if please_discard then
+      InputNeeded env
+    else
+      check_for_default_reduction env
+
+  (* [discard env triple] stores [triple] into [env], overwriting the previous
+     token. It is invoked by [offer], which itself is invoked by the user in
+     response to an [InputNeeded] checkpoint. *)
+
+  and discard env triple =
+    if log then begin
+      let (token, startp, endp) = triple in
+      Log.lookahead_token (T.token2terminal token) startp endp
+    end;
+    let env = { env with error = false; triple } in
+    check_for_default_reduction env
+
+  and check_for_default_reduction env =
+
+    (* Examine what situation we are in. This case analysis is analogous to
+       that performed in [CodeBackend.gettoken], in the sub-case where we do
+       not have a terminal incoming symbol. *)
+
+    T.default_reduction
+      env.current
+      announce_reduce       (* there is a default reduction; perform it *)
+      check_for_error_token (* there is none; continue below *)
+      env
+
+  and check_for_error_token env =
+
+    (* There is no default reduction. Consult the current lookahead token
+       so as to determine which action should be taken. *)
+
+    (* Peeking at the first input token, without taking it off the input
+       stream, is done by reading [env.triple]. We are careful to first
+       check [env.error]. *)
+
+    (* Note that, if [please_discard] was true, then we have just called
+       [discard], so the lookahead token cannot be [error]. *)
+
+    (* Returning [HandlingError env] is like calling [error ~strategy env]
+       directly, except it allows the user to regain control and choose an
+       error-handling strategy. *)
+
+    if env.error then begin
+      if log then
+        Log.resuming_error_handling();
+      HandlingError env
+    end
+    else
+      let (token, _, _) = env.triple in
+
+      (* We consult the two-dimensional action table, indexed by the
+         current state and the current lookahead token, in order to
+         determine which action should be taken. *)
+
+      T.action
+        env.current                    (* determines a row *)
+        (T.token2terminal token)       (* determines a column *)
+        (T.token2value token)
+        shift                          (* shift continuation *)
+        announce_reduce                (* reduce continuation *)
+        initiate                       (* failure continuation *)
+        env
+
+  (* ------------------------------------------------------------------------ *)
+
+  (* This function takes care of shift transitions along a terminal symbol.
+     (Goto transitions are taken care of within [reduce] below.) The symbol
+     can be either an actual token or the [error] pseudo-token. *)
+
+  (* Here, the lookahead token CAN be [error]. *)
+
+  and shift env
+      (please_discard : bool)
+      (terminal : terminal)
+      (value : semantic_value)
+      (s' : state) =
+
+    (* Log the transition. *)
+
+    if log then
+      Log.shift terminal s';
+
+    (* Push a new cell onto the stack, containing the identity of the
+       state that we are leaving. *)
+
+    let (_, startp, endp) = env.triple in
+    let stack = {
+      state = env.current;
+      semv = value;
+      startp;
+      endp;
+      next = env.stack;
+    } in
+
+    (* Switch to state [s']. *)
+
+    let new_env = { env with stack; current = s' } in
+
+    (* Expose the transition to the user. (In principle, we have a choice
+       between exposing the transition before we take it, after we take
+       it, or at some point in between. This affects the number and type
+       of the parameters carried by [Shifting]. Here, we choose to expose
+       the transition after we take it; this allows [Shifting] to carry
+       only three parameters, whose meaning is simple.) *)
+
+    Shifting (env, new_env, please_discard)
+
+  (* ------------------------------------------------------------------------ *)
+
+  (* The function [announce_reduce] stops the parser and returns a checkpoint
+     which allows the parser to be resumed by calling [reduce]. *)
+
+  (* Only ordinary productions are exposed to the user. Start productions
+     are not exposed to the user. Reducing a start production simply leads
+     to the successful termination of the parser. *)
+
+  and announce_reduce env (prod : production) =
+    if T.is_start prod then
+      accept env prod
+    else
+      AboutToReduce (env, prod)
+
+  (* The function [reduce] takes care of reductions. It is invoked by
+     [resume] after an [AboutToReduce] event has been produced. *)
+
+  (* Here, the lookahead token CAN be [error]. *)
+
+  (* The production [prod] CANNOT be a start production. *)
+
+  and reduce env (prod : production) =
+
+    (* Log a reduction event. *)
+
+    if log then
+      Log.reduce_or_accept prod;
+
+    (* Invoke the semantic action. The semantic action is responsible for
+       truncating the stack and pushing a new cell onto the stack, which
+       contains a new semantic value. It can raise [Error]. *)
+
+    (* If the semantic action terminates normally, it returns a new stack,
+       which becomes the current stack. *)
+
+    (* If the semantic action raises [Error], we catch it and initiate error
+       handling. *)
+
+    (* This [match/with/exception] construct requires OCaml 4.02. *)
+
+    match T.semantic_action prod env with
+    | stack ->
+
+        (* By our convention, the semantic action has produced an updated
+           stack. The state now found in the top stack cell is the return
+           state. *)
+
+        (* Perform a goto transition. The target state is determined
+           by consulting the goto table at the return state and at
+           production [prod]. *)
+
+        let current = T.goto_prod stack.state prod in
+        let env = { env with stack; current } in
+        run env false
+
+    | exception Error ->
+        initiate env
+
+  and accept env prod =
+    (* Log an accept event. *)
+    if log then
+      Log.reduce_or_accept prod;
+    (* Extract the semantic value out of the stack. *)
+    let v = env.stack.semv in
+    (* Finish. *)
+    Accepted v
+
+  (* ------------------------------------------------------------------------ *)
+
+  (* The following functions deal with errors. *)
+
+  (* [initiate] initiates or resumes error handling. *)
+
+  (* Here, the lookahead token CAN be [error]. *)
+
+  and initiate env =
+    if log then
+      Log.initiating_error_handling();
+    let env = { env with error = true } in
+    HandlingError env
+
+  (* [error] handles errors. *)
+
+  and error ~strategy env =
+    assert env.error;
+
+    (* Consult the column associated with the [error] pseudo-token in the
+       action table. *)
+
+    T.action
+      env.current                    (* determines a row *)
+      T.error_terminal               (* determines a column *)
+      T.error_value
+      (error_shift ~strategy)        (* shift continuation *)
+      (error_reduce ~strategy)       (* reduce continuation *)
+      (error_fail ~strategy)         (* failure continuation *)
+      env
+
+  and error_shift ~strategy env please_discard terminal value s' =
+    assert (terminal = T.error_terminal && value = T.error_value);
+
+    (* This state is capable of shifting the [error] token. *)
+
+    if log then
+      Log.handling_error env.current;
+
+    (* In the simplified strategy, we change [please_discard] to [false],
+       which means that we won't request the next token and (therefore)
+       we will remain in error-handling mode after shifting the [error]
+       token. *)
+
+    let please_discard =
+      match strategy with `Legacy -> please_discard | `Simplified -> false
+    in
+
+    shift env please_discard terminal value s'
+
+  and error_reduce ~strategy env prod =
+
+    (* This state is capable of performing a reduction on [error]. *)
+
+    if log then
+      Log.handling_error env.current;
+
+    (* In the legacy strategy, we call [reduce] instead of [announce_reduce],
+       apparently in an attempt to hide the reduction steps performed during
+       error handling. This seems inconsistent, as the default reduction steps
+       are still announced. In the simplified strategy, all reductions are
+       announced. *)
+
+    match strategy with
+    | `Legacy ->
+        reduce env prod
+    | `Simplified ->
+        announce_reduce env prod
+
+  and error_fail ~strategy env =
+
+    (* This state is unable to handle errors. In the simplified strategy, we
+       die immediately. In the legacy strategy, we attempt to pop a stack
+       cell. (This amounts to forgetting part of what we have just read, in
+       the hope of reaching a state where we can shift the [error] token and
+       resume parsing in normal mode. Forgetting past input is not appropriate
+       when the goal is merely to produce a good syntax error message.) *)
+
+    match strategy with
+    | `Simplified ->
+        Rejected
+    | `Legacy ->
+
+    (* Attempt to pop a stack cell. *)
+
+    let cell = env.stack in
+    let next = cell.next in
+    if next == cell then
+
+      (* The stack is empty. Die. *)
+
+      Rejected
+
+    else begin
+
+      (* The stack is nonempty. Pop a cell, updating the current state
+         with that found in the popped cell, and try again. *)
+
+      let env = { env with
+        stack = next;
+        current = cell.state
+      } in
+      HandlingError env
+
+    end
+
+  (* End of the nest of tail recursive functions. *)
+
+  (* ------------------------------------------------------------------------ *)
+  (* ------------------------------------------------------------------------ *)
+
+  (* The incremental interface. See [EngineTypes]. *)
+
+  (* [start s] begins the parsing process. *)
+
+  let start (s : state) (initial : 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
+       be accessed (by a semantic action) if an epsilon production is reduced
+       when the stack is empty. *)
+
+    let rec empty = {
+      state = s;                          (* dummy *)
+      semv = T.error_value;               (* dummy *)
+      startp = initial;                   (* dummy *)
+      endp = initial;
+      next = empty;
+    } in
+
+    (* Build an initial environment. *)
+
+    (* Unfortunately, there is no type-safe way of constructing a
+       dummy token. Tokens carry semantic values, which in general
+       we cannot manufacture. This instance of [Obj.magic] could
+       be avoided by adopting a different representation (e.g., no
+       [env.error] field, and an option in the first component of
+       [env.triple]), but I like this representation better. *)
+
+    let dummy_token = Obj.magic () in
+    let env = {
+      error = false;
+      triple = (dummy_token, initial, initial); (* dummy *)
+      stack = empty;
+      current = s;
+    } in
+
+    (* Begin parsing. *)
+
+    (* The parameter [please_discard] here is [true], which means we know
+       that we must read at least one token. This claim relies on the fact
+       that we have ruled out the two special cases where a start symbol
+       recognizes the empty language or the singleton language {epsilon}. *)
+
+    run env true
+
+  (* [offer checkpoint triple] is invoked by the user in response to a
+     checkpoint of the form [InputNeeded env]. It checks that [checkpoint] is
+     indeed of this form, and invokes [discard]. *)
+
+  (* [resume checkpoint] is invoked by the user in response to a checkpoint of
+     the form [AboutToReduce (env, prod)] or [HandlingError env]. It checks
+     that [checkpoint] is indeed of this form, and invokes [reduce] or
+     [error], as appropriate. *)
+
+  (* In reality, [offer] and [resume] accept an argument of type
+     [semantic_value checkpoint] and produce a checkpoint of the same type.
+     The choice of [semantic_value] is forced by the fact that this is the
+     parameter of the checkpoint [Accepted]. *)
+
+  (* We change this as follows. *)
+
+  (* We change the argument and result type of [offer] and [resume] from
+     [semantic_value checkpoint] to ['a checkpoint]. This is safe, in this
+     case, because we give the user access to values of type [t checkpoint]
+     only if [t] is indeed the type of the eventual semantic value for this
+     run. (More precisely, by examining the signatures [INCREMENTAL_ENGINE]
+     and [INCREMENTAL_ENGINE_START], one finds that the user can build a value
+     of type ['a checkpoint] only if ['a] is [semantic_value]. The table
+     back-end goes further than this and produces versions of [start] composed
+     with a suitable cast, which give the user access to a value of type
+     [t checkpoint] where [t] is the type of the start symbol.) *)
+
+  let offer : 'a . 'a checkpoint ->
+                   token * position * position ->
+                   'a checkpoint
+  = function
+    | InputNeeded env ->
+        Obj.magic discard env
+    | _ ->
+        invalid_arg "offer expects InputNeeded"
+
+  let resume : 'a . ?strategy:strategy -> 'a checkpoint -> 'a checkpoint =
+  fun ?(strategy=`Legacy) checkpoint ->
+    match checkpoint with
+    | HandlingError env ->
+        Obj.magic error ~strategy env
+    | Shifting (_, env, please_discard) ->
+        Obj.magic run env please_discard
+    | AboutToReduce (env, prod) ->
+        Obj.magic reduce env prod
+    | _ ->
+        invalid_arg "resume expects HandlingError | Shifting | AboutToReduce"
+
+  (* ------------------------------------------------------------------------ *)
+  (* ------------------------------------------------------------------------ *)
+
+  (* The traditional interface. See [EngineTypes]. *)
+
+  (* ------------------------------------------------------------------------ *)
+
+  (* Wrapping a lexer and lexbuf as a token supplier. *)
+
+  type supplier =
+    unit -> token * position * position
+
+  let lexer_lexbuf_to_supplier
+      (lexer : Lexing.lexbuf -> token)
+      (lexbuf : Lexing.lexbuf)
+  : supplier =
+    fun () ->
+      let token = lexer lexbuf in
+      let startp = lexbuf.Lexing.lex_start_p
+      and endp = lexbuf.Lexing.lex_curr_p in
+      token, startp, endp
+
+  (* ------------------------------------------------------------------------ *)
+
+  (* The main loop repeatedly handles intermediate checkpoints, until a final
+     checkpoint is obtained. This allows implementing the monolithic interface
+     ([entry]) in terms of the incremental interface ([start], [offer],
+     [handle], [reduce]). *)
+
+  (* By convention, acceptance is reported by returning a semantic value,
+     whereas rejection is reported by raising [Error]. *)
+
+  (* [loop] is polymorphic in ['a]. No cheating is involved in achieving this.
+     All of the cheating resides in the types assigned to [offer] and [handle]
+     above. *)
+
+  let rec loop : 'a . ?strategy:strategy -> supplier -> 'a checkpoint -> 'a =
+    fun ?(strategy=`Legacy) read checkpoint ->
+    match checkpoint with
+    | InputNeeded _ ->
+        (* The parser needs a token. Request one from the lexer,
+           and offer it to the parser, which will produce a new
+           checkpoint. Then, repeat. *)
+        let triple = read() in
+        let checkpoint = offer checkpoint triple in
+        loop ~strategy read checkpoint
+    | Shifting _
+    | AboutToReduce _
+    | HandlingError _ ->
+        (* The parser has suspended itself, but does not need
+           new input. Just resume the parser. Then, repeat. *)
+        let checkpoint = resume ~strategy checkpoint in
+        loop ~strategy read checkpoint
+    | Accepted v ->
+        (* The parser has succeeded and produced a semantic value.
+           Return this semantic value to the user. *)
+        v
+    | Rejected ->
+        (* The parser rejects this input. Raise an exception. *)
+        raise Error
+
+  let entry strategy (s : state) lexer lexbuf : semantic_value =
+    let initial = lexbuf.Lexing.lex_curr_p in
+    loop ~strategy (lexer_lexbuf_to_supplier lexer lexbuf) (start s initial)
+
+  (* ------------------------------------------------------------------------ *)
+
+  (* [loop_handle] stops if it encounters an error, and at this point, invokes
+     its failure continuation, without letting Menhir do its own traditional
+     error-handling (which involves popping the stack, etc.). *)
+
+  let rec loop_handle succeed fail read checkpoint =
+    match checkpoint with
+    | InputNeeded _ ->
+        let triple = read() in
+        let checkpoint = offer checkpoint triple in
+        loop_handle succeed fail read checkpoint
+    | Shifting _
+    | AboutToReduce _ ->
+        (* Which strategy is passed to [resume] here is irrelevant,
+           since this checkpoint is not [HandlingError _]. *)
+        let checkpoint = resume checkpoint in
+        loop_handle succeed fail read checkpoint
+    | HandlingError _
+    | Rejected ->
+        (* The parser has detected an error. Invoke the failure continuation. *)
+        fail checkpoint
+    | Accepted v ->
+        (* The parser has succeeded and produced a semantic value. Invoke the
+           success continuation. *)
+        succeed v
+
+  (* ------------------------------------------------------------------------ *)
+
+  (* [loop_handle_undo] is analogous to [loop_handle], except it passes a pair
+     of checkpoints to the failure continuation.
+
+     The first (and oldest) checkpoint is the last [InputNeeded] checkpoint
+     that was encountered before the error was detected. The second (and
+     newest) checkpoint is where the error was detected, as in [loop_handle].
+     Going back to the first checkpoint can be thought of as undoing any
+     reductions that were performed after seeing the problematic token. (These
+     reductions must be default reductions or spurious reductions.) *)
+
+  let rec loop_handle_undo succeed fail read (inputneeded, checkpoint) =
+    match checkpoint with
+    | InputNeeded _ ->
+        (* Update the last recorded [InputNeeded] checkpoint. *)
+        let inputneeded = checkpoint in
+        let triple = read() in
+        let checkpoint = offer checkpoint triple in
+        loop_handle_undo succeed fail read (inputneeded, checkpoint)
+    | Shifting _
+    | AboutToReduce _ ->
+        (* Which strategy is passed to [resume] here is irrelevant,
+           since this checkpoint is not [HandlingError _]. *)
+        let checkpoint = resume checkpoint in
+        loop_handle_undo succeed fail read (inputneeded, checkpoint)
+    | HandlingError _
+    | Rejected ->
+        fail inputneeded checkpoint
+    | Accepted v ->
+        succeed v
+
+  (* For simplicity, we publish a version of [loop_handle_undo] that takes a
+     single checkpoint as an argument, instead of a pair of checkpoints. We
+     check that the argument is [InputNeeded _], and duplicate it. *)
+
+  (* The parser cannot accept or reject before it asks for the very first
+     character of input. (Indeed, we statically reject a symbol that
+     generates the empty language or the singleton language {epsilon}.)
+     So, the [start] checkpoint must match [InputNeeded _]. Hence, it is
+     permitted to call [loop_handle_undo] with a [start] checkpoint. *)
+
+  let loop_handle_undo succeed fail read checkpoint =
+    assert (match checkpoint with InputNeeded _ -> true | _ -> false);
+    loop_handle_undo succeed fail read (checkpoint, checkpoint)
+
+  (* ------------------------------------------------------------------------ *)
+
+  let rec shifts checkpoint =
+    match checkpoint with
+    | Shifting (env, _, _) ->
+        (* The parser is about to shift, which means it is willing to
+           consume the terminal symbol that we have fed it. Return the
+           state just before this transition. *)
+        Some env
+    | AboutToReduce _ ->
+        (* The parser wishes to reduce. Just follow. *)
+        (* Which strategy is passed to [resume] here is irrelevant,
+           since this checkpoint is not [HandlingError _]. *)
+        shifts (resume checkpoint)
+    | HandlingError _ ->
+        (* The parser fails, which means it rejects the terminal symbol
+           that we have fed it. *)
+        None
+    | InputNeeded _
+    | Accepted _
+    | Rejected ->
+        (* None of these cases can arise. Indeed, after a token is submitted
+           to it, the parser must shift, reduce, or signal an error, before
+           it can request another token or terminate. *)
+        assert false
+
+  let acceptable checkpoint token pos =
+    let triple = (token, pos, pos) in
+    let checkpoint = offer checkpoint triple in
+    match shifts checkpoint with
+    | None      -> false
+    | Some _env -> true
+
+  (* ------------------------------------------------------------------------ *)
+
+  (* The type ['a lr1state] describes the (non-initial) states of the LR(1)
+     automaton. The index ['a] represents the type of the semantic value
+     associated with the state's incoming symbol. *)
+
+  (* The type ['a lr1state] is defined as an alias for [state], which itself
+     is usually defined as [int] (see [TableInterpreter]). So, ['a lr1state]
+     is technically a phantom type, but should really be thought of as a GADT
+     whose data constructors happen to be represented as integers. It is
+     presented to the user as an abstract type (see [IncrementalEngine]). *)
+
+  type 'a lr1state =
+      state
+
+  (* ------------------------------------------------------------------------ *)
+
+  (* Stack inspection. *)
+
+  (* We offer a read-only view of the parser's state as a stream of elements.
+     Each element contains a pair of a (non-initial) state and a semantic
+     value associated with (the incoming symbol of) this state. Note that the
+     type [element] is an existential type. *)
+
+  (* As of 2017/03/31, the type [stack] and the function [stack] are DEPRECATED.
+     If desired, they could now be implemented outside Menhir, by relying on
+     the functions [top] and [pop]. *)
+
+  type element =
+    | Element: 'a lr1state * 'a * position * position -> element
+
+  open General
+
+  type stack =
+    element stream
+
+  (* If [current] is the current state and [cell] is the top stack cell,
+     then [stack cell current] is a view of the parser's state as a stream
+     of elements. *)
+
+  let rec stack cell current : element stream =
+    lazy (
+      (* The stack is empty iff the top stack cell is its own successor. In
+         that case, the current state [current] should be an initial state
+         (which has no incoming symbol).
+         We do not allow the user to inspect this state. *)
+      let next = cell.next in
+      if next == cell then
+        Nil
+      else
+        (* Construct an element containing the current state [current] as well
+           as the semantic value contained in the top stack cell. This semantic
+           value is associated with the incoming symbol of this state, so it
+           makes sense to pair them together. The state has type ['a state] and
+           the semantic value has type ['a], for some type ['a]. Here, the OCaml
+           type-checker thinks ['a] is [semantic_value] and considers this code
+           well-typed. Outside, we will use magic to provide the user with a way
+           of inspecting states and recovering the value of ['a]. *)
+        let element = Element (
+          current,
+          cell.semv,
+          cell.startp,
+          cell.endp
+        ) in
+        Cons (element, stack next cell.state)
+    )
+
+  let stack env : element stream =
+    stack env.stack env.current
+
+  (* As explained above, the function [top] allows access to the top stack
+     element only if the stack is nonempty, i.e., only if the current state
+     is not an initial state. *)
+
+  let top env : element option =
+    let cell = env.stack in
+    let next = cell.next in
+    if next == cell then
+      None
+    else
+      Some (Element (env.current, cell.semv, cell.startp, cell.endp))
+
+  (* [equal] compares the stacks for physical equality, and compares the
+     current states via their numbers (this seems cleaner than using OCaml's
+     polymorphic equality). *)
+
+  (* The two fields that are not compared by [equal], namely [error] and
+     [triple], are overwritten by the function [discard], which handles
+     [InputNeeded] checkpoints. Thus, if [equal env1 env2] holds, then the
+     checkpoints [input_needed env1] and [input_needed env2] are
+     equivalent: they lead the parser to behave in the same way. *)
+
+  let equal env1 env2 =
+    env1.stack == env2.stack &&
+    number env1.current = number env2.current
+
+  let current_state_number env =
+    number env.current
+
+  (* ------------------------------------------------------------------------ *)
+
+  (* Access to the position of the lookahead token. *)
+
+  let positions { triple = (_, startp, endp); _ } =
+    startp, endp
+
+  (* ------------------------------------------------------------------------ *)
+
+  (* Access to information about default reductions. *)
+
+  (* This can be a function of states, or a function of environments.
+     We offer both. *)
+
+  (* Instead of a Boolean result, we could return a [production option].
+     However, we would have to explicitly test whether [prod] is a start
+     production, and in that case, return [None], I suppose. Indeed, we
+     have decided not to expose the start productions. *)
+
+  let state_has_default_reduction (state : _ lr1state) : bool =
+    T.default_reduction state
+      (fun _env _prod -> true)
+      (fun _env -> false)
+      ()
+
+  let env_has_default_reduction env =
+    state_has_default_reduction env.current
+
+  (* ------------------------------------------------------------------------ *)
+
+  (* The following functions work at the level of environments (as opposed to
+     checkpoints). The function [pop] causes the automaton to go back into the
+     past, pretending that the last input symbol has never been read. The
+     function [force_reduction] causes the automaton to re-interpret the past,
+     by recognizing the right-hand side of a production and reducing this
+     production. The function [feed] causes the automaton to progress into the
+     future by pretending that a (terminal or nonterminal) symbol has been
+     read. *)
+
+  (* The function [feed] would ideally be defined here. However, for this
+     function to be type-safe, the GADT ['a symbol] is needed. For this
+     reason, we move its definition to [InspectionTableInterpreter], where
+     the inspection API is available. *)
+
+  (* [pop] pops one stack cell. It cannot go wrong. *)
+
+  let pop (env : 'a env) : 'a env option =
+    let cell = env.stack in
+    let next = cell.next in
+    if next == cell then
+      (* The stack is empty. *)
+      None
+    else
+      (* The stack is nonempty. Pop off one cell. *)
+      Some { env with stack = next; current = cell.state }
+
+  (* [force_reduction] is analogous to [reduce], except that it does not
+     continue by calling [run env] or [initiate env]. Instead, it returns
+     [env] to the user. *)
+
+  (* [force_reduction] is dangerous insofar as it executes a semantic action.
+     This semantic action could have side effects: nontermination, state,
+     exceptions, input/output, etc. *)
+
+  let force_reduction prod (env : 'a env) : 'a env =
+    (* Check if this reduction is permitted. This check is REALLY important.
+       The stack must have the correct shape: that is, it must be sufficiently
+       high, and must contain semantic values of appropriate types, otherwise
+       the semantic action will crash and burn. *)
+    (* We currently check whether the current state is WILLING to reduce this
+       production (i.e., there is a reduction action in the action table row
+       associated with this state), whereas it would be more liberal to check
+       whether this state is CAPABLE of reducing this production (i.e., the
+       stack has an appropriate shape). We currently have no means of
+       performing such a check. *)
+    if not (T.may_reduce env.current prod) then
+      invalid_arg "force_reduction: this reduction is not permitted in this state"
+    else begin
+      (* We do not expose the start productions to the user, so this cannot be
+         a start production. Hence, it has a semantic action. *)
+      assert (not (T.is_start prod));
+      (* Invoke the semantic action. *)
+      let stack = T.semantic_action prod env in
+      (* Perform a goto transition. *)
+      let current = T.goto_prod stack.state prod in
+      { env with stack; current }
+    end
+
+  (* The environment manipulation functions -- [pop] and [force_reduction]
+     above, plus [feed] -- manipulate the automaton's stack and current state,
+     but do not affect the automaton's lookahead symbol. When the function
+     [input_needed] is used to go back from an environment to a checkpoint
+     (and therefore, resume normal parsing), the lookahead symbol is clobbered
+     anyway, since the only action that the user can take is to call [offer].
+     So far, so good. One problem, though, is that this call to [offer] may
+     well place the automaton in a configuration of a state [s] and a
+     lookahead symbol [t] that is normally unreachable. Also, perhaps the
+     state [s] is a state where an input symbol normally is never demanded, so
+     this [InputNeeded] checkpoint is fishy. There does not seem to be a deep
+     problem here, but, when programming an error recovery strategy, one
+     should pay some attention to this issue. Ideally, perhaps, one should use
+     [input_needed] only in a state [s] where an input symbol is normally
+     demanded, that is, a state [s] whose incoming symbol is a terminal symbol
+     and which does not have a default reduction on [#]. *)
+
+  let input_needed (env : 'a env) : 'a checkpoint =
+    InputNeeded env
+
+  (* The following functions are compositions of [top] and [pop]. *)
+
+  let rec pop_many i env =
+    if i = 0 then
+      Some env
+    else match pop env with
+    | None ->
+        None
+    | Some env ->
+        pop_many (i - 1) env
+
+  let get i env =
+    match pop_many i env with
+    | None ->
+        None
+    | Some env ->
+        top env
+
+end
+end
+module ErrorReports = struct
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* -------------------------------------------------------------------------- *)
+
+(* A two-place buffer stores zero, one, or two elements. *)
+
+type 'a content =
+| Zero
+| One of 'a
+| Two of 'a * (* most recent: *) 'a
+
+type 'a buffer =
+  'a content ref
+
+(* [update buffer x] pushes [x] into [buffer], causing the buffer to slide. *)
+
+let update buffer x =
+  buffer :=
+    match !buffer, x with
+    | Zero, _ ->
+        One x
+    | One x1, x2
+    | Two (_, x1), x2 ->
+        Two (x1, x2)
+
+let show f buffer : string =
+  match !buffer with
+  | Zero ->
+      (* The buffer cannot be empty. If we have read no tokens,
+         we cannot have detected a syntax error. *)
+      assert false
+  | One invalid ->
+      (* It is unlikely, but possible, that we have read just one token. *)
+      Printf.sprintf "before '%s'" (f invalid)
+  | Two (valid, invalid) ->
+      (* In the most likely case, we have read two tokens. *)
+      Printf.sprintf "after '%s' and before '%s'" (f valid) (f invalid)
+
+let last buffer =
+  match !buffer with
+  | Zero ->
+      (* The buffer cannot be empty. If we have read no tokens,
+         we cannot have detected a syntax error. *)
+      assert false
+  | One invalid
+  | Two (_, invalid) ->
+      invalid
+
+open Lexing
+
+let wrap lexer =
+  let buffer = ref Zero in
+  buffer,
+  fun lexbuf ->
+    let token = lexer lexbuf in
+    update buffer (lexbuf.lex_start_p, lexbuf.lex_curr_p);
+    token
+
+let wrap_supplier supplier =
+  let buffer = ref Zero in
+  buffer,
+  fun () ->
+    let (_token, pos1, pos2) as triple = supplier() in
+    update buffer (pos1, pos2);
+    triple
+
+(* -------------------------------------------------------------------------- *)
+
+let extract text (pos1, pos2) : string =
+  let ofs1 = pos1.pos_cnum
+  and ofs2 = pos2.pos_cnum in
+  let len = ofs2 - ofs1 in
+  try
+    String.sub text ofs1 len
+  with Invalid_argument _ ->
+    (* In principle, this should not happen, but if it does, let's make this
+       a non-fatal error. *)
+    "???"
+
+let sanitize text =
+  String.map (fun c ->
+    if Char.code c < 32 then ' ' else c
+  ) text
+
+(* If we were willing to depend on [Str], we could implement [compress] as
+   follows:
+
+   let compress text =
+     Str.global_replace (Str.regexp "[ \t\n\r]+") " " text
+
+ *)
+
+let rec compress n b i j skipping =
+  if j < n then
+    let c, j = Bytes.get b j, j + 1 in
+    match c with
+    | ' ' | '\t' | '\n' | '\r' ->
+        let i = if not skipping then (Bytes.set b i ' '; i + 1) else i in
+        let skipping = true in
+        compress n b i j skipping
+    | _ ->
+        let i = Bytes.set b i c; i + 1 in
+        let skipping = false in
+        compress n b i j skipping
+  else
+    Bytes.sub_string b 0 i
+
+let compress text =
+  let b = Bytes.of_string text in
+  let n = Bytes.length b in
+  compress n b 0 0 false
+
+let shorten k text =
+  let n = String.length text in
+  if n <= 2 * k + 3 then
+    text
+  else
+    String.sub text 0 k ^
+    "..." ^
+    String.sub text (n - k) k
+
+let is_digit c =
+  let c = Char.code c in
+  Char.code '0' <= c && c <= Char.code '9'
+
+exception Copy
+
+let expand f text =
+  let n = String.length text in
+  let b = Buffer.create n in
+  let rec loop i =
+    if i < n then begin
+      let c, i = text.[i], i + 1 in
+      loop (
+        try
+          if c <> '$' then raise Copy;
+          let j = ref i in
+          while !j < n && is_digit text.[!j] do incr j done;
+          if i = !j then raise Copy;
+          let k = int_of_string (String.sub text i (!j - i)) in
+          Buffer.add_string b (f k);
+          !j
+        with Copy ->
+          (* We reach this point if either [c] is not '$' or [c] is '$'
+             but is not followed by an integer literal. *)
+          Buffer.add_char b c;
+          i
+      )
+    end
+    else
+      Buffer.contents b
+  in
+  loop 0
+end
+module LexerUtil = struct
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+open Lexing
+open Printf
+
+let init filename lexbuf =
+  lexbuf.lex_curr_p <- {
+    pos_fname = filename;
+    pos_lnum  = 1;
+    pos_bol   = 0;
+    pos_cnum  = 0
+  };
+  lexbuf
+
+let read filename =
+  let c = open_in filename in
+  let text = really_input_string c (in_channel_length c) in
+  close_in c;
+  let lexbuf = Lexing.from_string text in
+  text, init filename lexbuf
+
+let newline lexbuf =
+  let pos = lexbuf.lex_curr_p in
+  lexbuf.lex_curr_p <- { pos with
+    pos_lnum = pos.pos_lnum + 1;
+    pos_bol = pos.pos_cnum;
+  }
+
+let is_dummy (pos1, pos2) =
+  pos1 == dummy_pos || pos2 == dummy_pos
+
+let range ((pos1, pos2) as range) =
+  if is_dummy range then
+    sprintf "At an unknown location:\n"
+  else
+    let file = pos1.pos_fname in
+    let line = pos1.pos_lnum in
+    let char1 = pos1.pos_cnum - pos1.pos_bol in
+    let char2 = pos2.pos_cnum - pos1.pos_bol in (* yes, [pos1.pos_bol] *)
+    sprintf "File \"%s\", line %d, characters %d-%d:\n"
+      file line char1 char2
+      (* use [char1 + 1] and [char2 + 1] if *not* using Caml mode *)
+end
+module Printers = struct
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+module Make
+  (I : IncrementalEngine.EVERYTHING)
+  (User : sig
+    val print: string -> unit
+    val print_symbol: I.xsymbol -> unit
+    val print_element: (I.element -> unit) option
+  end)
+= struct
+
+  let arrow = " -> "
+  let dot = "."
+  let space = " "
+  let newline = "\n"
+
+  open User
+  open I
+
+  (* Printing a list of symbols. An optional dot is printed at offset
+     [i] into the list [symbols], if this offset lies between [0] and
+     the length of the list (included). *)
+
+  let rec print_symbols i symbols =
+    if i = 0 then begin
+      print dot;
+      print space;
+      print_symbols (-1) symbols
+    end
+    else begin
+      match symbols with
+      | [] ->
+          ()
+      | symbol :: symbols ->
+          print_symbol symbol;
+          print space;
+          print_symbols (i - 1) symbols
+    end
+
+  (* Printing an element as a symbol. *)
+
+  let print_element_as_symbol element =
+    match element with
+    | Element (s, _, _, _) ->
+        print_symbol (X (incoming_symbol s))
+
+  (* Some of the functions that follow need an element printer. They use
+     [print_element] if provided by the user; otherwise they use
+     [print_element_as_symbol]. *)
+
+  let print_element =
+    match print_element with
+    | Some print_element ->
+        print_element
+    | None ->
+        print_element_as_symbol
+
+  (* Printing a stack as a list of symbols. Stack bottom on the left,
+     stack top on the right. *)
+
+  let rec print_stack env =
+    match top env, pop env with
+    | Some element, Some env ->
+        print_stack env;
+        print space;
+        print_element element
+    | _, _ ->
+        ()
+
+  let print_stack env =
+    print_stack env;
+    print newline
+
+  (* Printing an item. *)
+
+  let print_item (prod, i) =
+    print_symbol (lhs prod);
+    print arrow;
+    print_symbols i (rhs prod);
+    print newline
+
+  (* Printing a list of symbols (public version). *)
+
+  let print_symbols symbols =
+    print_symbols (-1) symbols
+
+  (* Printing a production (without a dot). *)
+
+  let print_production prod =
+    print_item (prod, -1)
+
+  (* Printing the current LR(1) state. *)
+
+  let print_current_state env =
+    print "Current LR(1) state: ";
+    match top env with
+    | None ->
+        print "<some initial state>"; (* TEMPORARY unsatisfactory *)
+        print newline
+    | Some (Element (current, _, _, _)) ->
+        print (string_of_int (number current));
+        print newline;
+        List.iter print_item (items current)
+
+  let print_env env =
+    print_stack env;
+    print_current_state env;
+    print newline
+
+end
+end
+module InfiniteArray = struct
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+(** This module implements infinite arrays, that is, arrays that grow
+    transparently upon demand. *)
+
+type 'a t = {
+    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 *)
+
+let make x = {
+  default = x;
+  table = Array.make default_size x;
+  extent = 0;
+}
+
+let rec new_length length i =
+  if i < length then
+    length
+  else
+    new_length (2 * length) i
+
+let ensure a i =
+  assert (0 <= i);
+  let table = a.table in
+  let length = Array.length table in
+  if i >= length then begin
+    let table' = Array.make (new_length (2 * length) i) a.default in
+    Array.blit table 0 table' 0 length;
+    a.table <- table'
+  end
+
+let get a i =
+  ensure a i;
+  Array.unsafe_get a.table (i)
+
+let set a i x =
+  ensure a i;
+  Array.unsafe_set a.table (i) x;
+  if a.extent <= i then
+    a.extent <- i + 1
+
+let extent a =
+  a.extent
+
+let domain a =
+  Array.sub a.table 0 a.extent
+
+end
+module PackedIntArray = struct
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* A packed integer array is represented as a pair of an integer [k] and
+   a string [s]. The integer [k] is the number of bits per integer that we
+   use. The string [s] is just an array of bits, which is read in 8-bit
+   chunks. *)
+
+(* The ocaml programming language treats string literals and array literals
+   in slightly different ways: the former are statically allocated, while
+   the latter are dynamically allocated. (This is rather arbitrary.) In the
+   context of Menhir's table-based back-end, where compact, immutable
+   integer arrays are needed, ocaml strings are preferable to ocaml arrays. *)
+
+type t =
+  int * string
+
+(* The magnitude [k] of an integer [v] is the number of bits required
+   to represent [v]. It is rounded up to the nearest power of two, so
+   that [k] divides [Sys.word_size]. *)
+
+let magnitude (v : int) =
+  if v < 0 then
+    Sys.word_size
+  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]. *)
+      else
+        check (2 * k) (max * max)
+    in
+    check 1 2
+
+(* [pack a] turns an array of integers into a packed integer array. *)
+
+(* Because the sign bit is the most significant bit, the magnitude of
+   any negative number is the word size. In other words, [pack] does
+   not achieve any space savings as soon as [a] contains any negative
+   numbers, even if they are ``small''. *)
+
+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. *)
+
+  let k =
+    Array.fold_left (fun k v ->
+      max k (magnitude v)
+    ) 1 a
+  in
+
+  (* Because access to ocaml strings is performed on an 8-bit basis,
+     two cases arise. If [k] is less than 8, then we can pack multiple
+     array entries into a single character. If [k] is greater than 8,
+     then we must use multiple characters to represent a single array
+     entry. *)
+
+  if k <= 8 then begin
+
+    (* [w] is the number of array entries that we pack in a character. *)
+
+    assert (8 mod k = 0);
+    let w = 8 / k in
+
+    (* [n] is the length of the string that we allocate. *)
+
+    let n =
+      if m mod w = 0 then
+        m / w
+      else
+        m / w + 1
+    in
+
+    let s =
+      Bytes.create n
+    in
+
+    (* Define a reader for the source array. The reader might run off
+       the end if [w] does not divide [m]. *)
+
+    let i = ref 0 in
+    let next () =
+      let ii = !i in
+      if ii = m then
+        0 (* ran off the end, pad with zeroes *)
+      else
+        let v = a.(ii) in
+        i := ii + 1;
+        v
+    in
+
+    (* Fill up the string. *)
+
+    for j = 0 to n - 1 do
+      let c = ref 0 in
+      for _x = 1 to w do
+        c := (!c lsl k) lor next()
+      done;
+      Bytes.set s j (Char.chr !c)
+    done;
+
+    (* Done. *)
+
+    k, Bytes.unsafe_to_string s
+
+  end
+  else begin (* k > 8 *)
+
+    (* [w] is the number of characters that we use to encode an array entry. *)
+
+    assert (k mod 8 = 0);
+    let w = k / 8 in
+
+    (* [n] is the length of the string that we allocate. *)
+
+    let n =
+      m * w
+    in
+
+    let s =
+      Bytes.create n
+    in
+
+    (* Fill up the string. *)
+
+    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
+      done
+    done;
+
+    (* Done. *)
+
+    k, Bytes.unsafe_to_string s
+
+  end
+
+(* Access to a string. *)
+
+let read (s : string) (i : int) : int =
+  Char.code (String.unsafe_get s i)
+
+(* [get1 t i] returns the integer stored in the packed array [t] at index [i].
+   It assumes (and does not check) that the array's bit width is [1]. The
+   parameter [t] is just a string. *)
+
+let get1 (s : string) (i : int) : int =
+  let c = read s (i lsr 3) in
+  let c = c lsr ((lnot i) land 0b111) in
+  let c = c land 0b1 in
+  c
+
+(* [get t i] returns the integer stored in the packed array [t] at index [i]. *)
+
+(* Together, [pack] and [get] satisfy the following property: if the index [i]
+   is within bounds, then [get (pack a) i] equals [a.(i)]. *)
+
+let get ((k, s) : t) (i : int) : int =
+  match k with
+  | 1 ->
+      get1 s i
+  | 2 ->
+      let c = read s (i lsr 2) in
+      let c = c lsr (2 * ((lnot i) land 0b11)) in
+      let c = c land 0b11 in
+      c
+  | 4 ->
+      let c = read s (i lsr 1) in
+      let c = c lsr (4 * ((lnot i) land 0b1)) in
+      let c = c land 0b1111 in
+      c
+  | 8 ->
+      read s i
+  | 16 ->
+      let j = 2 * i in
+      (read s j) lsl 8 + read s (j + 1)
+  | _ ->
+      assert (k = 32); (* 64 bits unlikely, not supported *)
+      let j = 4 * i in
+      (((read s j lsl 8) + read s (j + 1)) lsl 8 + read s (j + 2)) lsl 8 + read s (j + 3)
+
+(* [unflatten1 (n, data) i j] accesses the two-dimensional bitmap
+   represented by [(n, data)] at indices [i] and [j]. The integer
+   [n] is the width of the bitmap; the string [data] is the second
+   component of the packed array obtained by encoding the table as
+   a one-dimensional array. *)
+
+let unflatten1 (n, data) i j =
+   get1 data (n * i + j)
+
+end
+module RowDisplacement = struct
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* This module compresses a two-dimensional table, where some values
+   are considered insignificant, via row displacement. *)
+
+(* This idea reportedly appears in Aho and Ullman's ``Principles
+   of Compiler Design'' (1977). It is evaluated in Tarjan and Yao's
+   ``Storing a Sparse Table'' (1979) and in Dencker, Dürre, and Heuft's
+   ``Optimization of Parser Tables for Portable Compilers'' (1984). *)
+
+(* A compressed table is represented as a pair of arrays. The
+   displacement array is an array of offsets into the data array. *)
+
+type 'a table =
+    int array * (* displacement *)
+     'a array   (* data *)
+
+(* In a natural version of this algorithm, displacements would be greater
+   than (or equal to) [-n]. However, in the particular setting of Menhir,
+   both arrays are intended to be compressed with [PackedIntArray], which
+   does not efficiently support negative numbers. For this reason, we are
+   careful not to produce negative displacements. *)
+
+(* In order to avoid producing negative displacements, we simply use the
+   least significant bit as the sign bit. This is implemented by [encode]
+   and [decode] below. *)
+
+(* One could also think, say, of adding [n] to every displacement, so as
+   to ensure that all displacements are nonnegative. This would work, but
+   would require [n] to be published, for use by the decoder. *)
+
+let encode (displacement : int) : int =
+  if displacement >= 0 then
+    displacement lsl 1
+  else
+    (-displacement) lsl 1 + 1
+
+let decode (displacement : int) : int =
+  if displacement land 1 = 0 then
+    displacement lsr 1
+  else
+    -(displacement lsr 1)
+
+(* It is reasonable to assume that, as matrices grow large, their
+   density becomes low, i.e., they have many insignificant entries.
+   As a result, it is important to work with a sparse data structure
+   for rows. We internally represent a row as a list of its
+   significant entries, where each entry is a pair of a [j] index and
+   an element. *)
+
+type 'a row =
+    (int * 'a) list
+
+(* [compress equal insignificant dummy m n t] turns the two-dimensional table
+   [t] into a compressed table. The parameter [equal] is equality of data
+   values. The parameter [wildcard] tells which data values are insignificant,
+   and can thus be overwritten with other values. The parameter [dummy] is
+   used to fill holes in the data array. [m] and [n] are the integer
+   dimensions of the table [t]. *)
+
+let compress
+    (equal : 'a -> 'a -> bool)
+    (insignificant : 'a -> bool)
+    (dummy : 'a)
+    (m : int) (n : int)
+    (t : 'a array array)
+    : 'a table =
+
+  (* Be defensive. *)
+
+  assert (Array.length t = m);
+  assert begin
+    for i = 0 to m - 1 do
+      assert (Array.length t.(i) = n)
+    done;
+    true
+  end;
+
+  (* This turns a row-as-array into a row-as-sparse-list. The row is
+     accompanied by its index [i] and by its rank (the number of its
+     significant entries, that is, the length of the row-as-a-list. *)
+
+  let sparse (i : int) (line : 'a array) : int * int * 'a row (* index, rank, row *) =
+
+    let rec loop (j : int) (rank : int) (row : 'a row) =
+      if j < 0 then
+        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)
+    in
+
+    loop (n - 1) 0 []
+
+  in
+
+  (* Construct an array of all rows, together with their index and rank. *)
+
+  let rows : (int * int * 'a row) array = (* index, rank, row *)
+    Array.mapi sparse t
+  in
+
+  (* Sort this array by decreasing rank. This does not have any impact
+     on correctness, but reportedly improves compression. The
+     intuitive idea is that rows with few significant elements are
+     easy to fit, so they should be inserted last, after the problem
+     has become quite constrained by fitting the heavier rows. This
+     heuristic is attributed to Ziegler. *)
+
+  Array.fast_sort (fun (_, rank1, _) (_, rank2, _) ->
+    compare rank2 rank1
+  ) rows;
+
+  (* Allocate a one-dimensional array of displacements. *)
+
+  let displacement : int array =
+    Array.make m 0
+  in
+
+  (* Allocate a one-dimensional, infinite array of values. Indices
+     into this array are written [k]. *)
+
+  let data : 'a InfiniteArray.t =
+    InfiniteArray.make dummy
+  in
+
+  (* Determine whether [row] fits at offset [k] within the current [data]
+     array, up to extension of this array. *)
+
+  (* Note that this check always succeeds when [k] equals the length of
+     the [data] array. Indeed, the loop is then skipped. This property
+     guarantees the termination of the recursive function [fit] below. *)
+
+  let fits k (row : 'a row) : bool =
+
+    let d = InfiniteArray.extent data in
+
+    let rec loop = function
+      | [] ->
+          true
+      | (j, x) :: row ->
+
+          (* [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
+
+    in
+    loop row
+
+  in
+
+  (* Find the leftmost position where a row fits. *)
+
+  (* If the leftmost significant element in this row is at offset [j],
+     then we can hope to fit as far left as [-j] -- so this element
+     lands at offset [0] in the data array. *)
+
+  (* Note that displacements may be negative. This means that, for
+     insignificant elements, accesses to the data array could fail: they could
+     be out of bounds, either towards the left or towards the right. This is
+     not a problem, as long as [get] is invoked only at significant
+     elements. *)
+
+  let rec fit k row : int =
+    if fits k row then
+      k
+    else
+      fit (k + 1) row
+  in
+
+  let fit row =
+    match row with
+    | [] ->
+        0 (* irrelevant *)
+    | (j, _) :: _ ->
+        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
+  in
+
+  (* Iterate over the sorted array of rows. Fit and write each row at
+     the leftmost compatible offset. Update the displacement table. *)
+
+  Array.iter (fun (i, _, row) ->
+    let k = fit row in (* if [row] has leading insignificant elements, then [k] can be negative *)
+    write k row;
+    displacement.(i) <- encode k
+  ) rows;
+
+  (* Return the compressed tables. *)
+
+  displacement, InfiniteArray.domain data
+
+(* [get ct i j] returns the value found at indices [i] and [j] in the
+   compressed table [ct]. This function call is permitted only if the
+   value found at indices [i] and [j] in the original table is
+   significant -- otherwise, it could fail abruptly. *)
+
+(* Together, [compress] and [get] have the property that, if the value
+   found at indices [i] and [j] in an uncompressed table [t] is
+   significant, then [get (compress t) i j] is equal to that value. *)
+
+let get (displacement, data) i j =
+  assert (0 <= i && i < Array.length displacement);
+  let k = decode displacement.(i) in
+  assert (0 <= k + j && k + j < Array.length data);
+    (* failure of this assertion indicates an attempt to access an
+       insignificant element that happens to be mapped out of the bounds
+       of the [data] array. *)
+  data.(k + j)
+
+(* [getget] is a variant of [get] which only requires read access,
+   via accessors, to the two components of the table. *)
+
+let getget get_displacement get_data (displacement, data) i j =
+  let k = decode (get_displacement displacement i) in
+  get_data data (k + j)
+end
+module LinearizedArray = struct
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* The [entry] array contains offsets into the [data] array. It has [n+1]
+   elements if the original (unencoded) array has [n] elements. The value
+   of [entry.(n)] is the length of the [data] array. This convention is
+   natural and allows avoiding a special case. *)
+
+type 'a t =
+  (* data: *)   'a array *
+  (* entry: *) int array
+
+let make (a : 'a array array) : 'a t =
+  let n = Array.length a in
+  (* Build the entry array. *)
+  let size = ref 0 in
+  let entry = Array.init (n + 1) (fun i ->
+    let s = !size in
+    if i < n then
+      size := s + Array.length a.(i);
+    s
+  ) in
+  assert (entry.(n) = !size);
+  (* Build the data array. *)
+  let i = ref 0
+  and j = ref 0 in
+  let data = Array.init !size (fun _ ->
+    while !j = Array.length a.(!i) do
+      i := !i + 1;
+      j := 0;
+    done;
+    let x = a.(!i).(!j) in
+    j := !j + 1;
+    x
+  ) in
+  data, entry
+
+let length ((_, entry) : 'a t) : int =
+  Array.length entry
+
+let row_length ((_, entry) : 'a t) i : int =
+  entry.(i + 1) - entry.(i)
+
+let row_length_via get_entry i =
+  get_entry (i + 1) - get_entry i
+
+let read ((data, entry) as la : 'a t) i j : 'a =
+  assert (0 <= j && j < row_length la i);
+  data.(entry.(i) + j)
+
+let read_via get_data get_entry i j =
+  assert (0 <= j && j < row_length_via get_entry i);
+  get_data (get_entry i + j)
+
+let write ((data, entry) as la : 'a t) i j (v : 'a) : unit =
+  assert (0 <= j && j < row_length la i);
+  data.(entry.(i) + j) <- v
+
+let rec read_interval_via get_data i j =
+  if i = j then
+    []
+  else
+    get_data i :: read_interval_via get_data (i + 1) j
+
+let read_row_via get_data get_entry i =
+  read_interval_via get_data (get_entry i) (get_entry (i + 1))
+
+let read_row ((data, entry) : 'a t) i : 'a list =
+  read_row_via (Array.get data) (Array.get entry) i
+
+end
+module TableFormat = struct
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* This signature defines the format of the parse tables. It is used as
+   an argument to [TableInterpreter.Make]. *)
+
+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. *)
+
+  val token2terminal: token -> int
+
+  (* This is the integer code for the error pseudo-token. *)
+
+  val error_terminal: int
+
+  (* This maps a token to its semantic value. *)
+
+  val token2value: token -> Obj.t
+
+  (* Traditionally, an LR automaton is described by two tables, namely, an
+     action table and a goto table. See, for instance, the Dragon book.
+
+     The action table is a two-dimensional matrix that maps a state and a
+     lookahead token to an action. An action is one of: shift to a certain
+     state, reduce a certain production, accept, or fail.
+
+     The goto table is a two-dimensional matrix that maps a state and a
+     non-terminal symbol to either a state or undefined. By construction, this
+     table is sparse: its undefined entries are never looked up. A compression
+     technique is free to overlap them with other entries.
+
+     In Menhir, things are slightly different. If a state has a default
+     reduction on token [#], then that reduction must be performed without
+     consulting the lookahead token. As a result, we must first determine
+     whether that is the case, before we can obtain a lookahead token and use it
+     as an index in the action table.
+
+     Thus, Menhir's tables are as follows.
+
+     A one-dimensional default reduction table maps a state to either ``no
+     default reduction'' (encoded as: 0) or ``by default, reduce prod''
+     (encoded as: 1 + prod). The action table is looked up only when there
+     is no default reduction. *)
+
+  val default_reduction: PackedIntArray.t
+
+  (* Menhir follows Dencker, Dürre and Heuft, who point out that, although the
+     action table is not sparse by nature (i.e., the error entries are
+     significant), it can be made sparse by first factoring out a binary error
+     matrix, then replacing the error entries in the action table with undefined
+     entries. Thus:
+
+     A two-dimensional error bitmap maps a state and a terminal to either
+     ``fail'' (encoded as: 0) or ``do not fail'' (encoded as: 1). The action
+     table, which is now sparse, is looked up only in the latter case. *)
+
+  (* The error bitmap is flattened into a one-dimensional table; its width is
+     recorded so as to allow indexing. The table is then compressed via
+     [PackedIntArray]. The bit width of the resulting packed array must be
+     [1], so it is not explicitly recorded. *)
+
+  (* The error bitmap does not contain a column for the [#] pseudo-terminal.
+     Thus, its width is [Terminal.n - 1]. We exploit the fact that the integer
+     code assigned to [#] is greatest: the fact that the right-most column
+     in the bitmap is missing does not affect the code for accessing it. *)
+
+  val error: int (* width of the bitmap *) * string (* second component of [PackedIntArray.t] *)
+
+  (* A two-dimensional action table maps a state and a terminal to one of
+     ``shift to state s and discard the current token'' (encoded as: s | 10),
+     ``shift to state s without discarding the current token'' (encoded as: s |
+     11), or ``reduce prod'' (encoded as: prod | 01). *)
+
+  (* The action table is first compressed via [RowDisplacement], then packed
+     via [PackedIntArray]. *)
+
+  (* Like the error bitmap, the action table does not contain a column for the
+     [#] pseudo-terminal. *)
+
+  val action: PackedIntArray.t * PackedIntArray.t
+
+  (* A one-dimensional lhs table maps a production to its left-hand side (a
+     non-terminal symbol). *)
+
+  val lhs: PackedIntArray.t
+
+  (* A two-dimensional goto table maps a state and a non-terminal symbol to
+     either undefined (encoded as: 0) or a new state s (encoded as: 1 + s). *)
+
+  (* The goto table is first compressed via [RowDisplacement], then packed
+     via [PackedIntArray]. *)
+
+  val goto: PackedIntArray.t * PackedIntArray.t
+
+  (* The number of start productions. A production [prod] is a start
+     production if and only if [prod < start] holds. This is also the
+     number of start symbols. A nonterminal symbol [nt] is a start
+     symbol if and only if [nt < start] holds. *)
+
+  val start: int
+
+  (* A one-dimensional semantic action table maps productions to semantic
+     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
+
+  (* The parser defines its own [Error] exception. This exception can be
+     raised by semantic actions and caught by the engine, and raised by the
+     engine towards the final user. *)
+
+  exception Error
+
+  (* The parser indicates whether to generate a trace. Generating a
+     trace requires two extra tables, which respectively map a
+     terminal symbol and a production to a string. *)
+
+  val trace: (string array * string array) option
+
+end
+end
+module InspectionTableFormat = struct
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* This signature defines the format of the tables that are produced (in
+   addition to the tables described in [TableFormat]) when the command line
+   switch [--inspection] is enabled. It is used as an argument to
+   [InspectionTableInterpreter.Make]. *)
+
+module type TABLES = sig
+
+  (* The types of symbols. *)
+
+  include IncrementalEngine.SYMBOLS
+
+  (* The type ['a lr1state] describes an LR(1) state. The generated parser defines
+     it internally as [int]. *)
+
+  type 'a lr1state
+
+  (* Some of the tables that follow use encodings of (terminal and
+     nonterminal) symbols as integers. So, we need functions that
+     map the integer encoding of a symbol to its algebraic encoding. *)
+
+  val    terminal: int -> xsymbol
+  val nonterminal: int -> xsymbol
+
+  (* The left-hand side of every production already appears in the
+     signature [TableFormat.TABLES], so we need not repeat it here. *)
+
+  (* The right-hand side of every production. This a linearized array
+     of arrays of integers, whose [data] and [entry] components have
+     been packed. The encoding of symbols as integers in described in
+     [TableBackend]. *)
+
+  val rhs: PackedIntArray.t * PackedIntArray.t
+
+  (* A mapping of every (non-initial) state to its LR(0) core. *)
+
+  val lr0_core: PackedIntArray.t
+
+  (* A mapping of every LR(0) state to its set of LR(0) items. Each item is
+     represented in its packed form (see [Item]) as an integer. Thus the
+     mapping is an array of arrays of integers, which is linearized and
+     packed, like [rhs]. *)
+
+  val lr0_items: PackedIntArray.t * PackedIntArray.t
+
+  (* A mapping of every LR(0) state to its incoming symbol, if it has one. *)
+
+  val lr0_incoming: PackedIntArray.t
+
+  (* A table that tells which non-terminal symbols are nullable. *)
+
+  val nullable: string
+    (* This is a packed int array of bit width 1. It can be read
+       using [PackedIntArray.get1]. *)
+
+  (* A two-table dimensional table, indexed by a nonterminal symbol and
+     by a terminal symbol (other than [#]), encodes the FIRST sets. *)
+
+  val first: int (* width of the bitmap *) * string (* second component of [PackedIntArray.t] *)
+
+end
+
+end
+module InspectionTableInterpreter = struct
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* -------------------------------------------------------------------------- *)
+
+(* The type functor. *)
+
+module Symbols (T : sig
+
+  type 'a terminal
+  type 'a nonterminal
+
+end) = struct
+
+  open T
+
+  (* This should be the only place in the whole library (and generator!)
+     where these types are defined. *)
+
+  type 'a symbol =
+    | T : 'a terminal -> 'a symbol
+    | N : 'a nonterminal -> 'a symbol
+
+  type xsymbol =
+    | X : 'a symbol -> xsymbol
+
+end
+
+(* -------------------------------------------------------------------------- *)
+
+(* The code functor. *)
+
+module Make
+  (TT : TableFormat.TABLES)
+  (IT : InspectionTableFormat.TABLES
+        with type 'a lr1state = int)
+  (ET : EngineTypes.TABLE
+        with type terminal = int
+         and type nonterminal = int
+         and type semantic_value = Obj.t)
+  (E : sig
+     type 'a env = (ET.state, ET.semantic_value, ET.token) EngineTypes.env
+   end)
+= struct
+
+  (* Including [IT] is an easy way of inheriting the definitions of the types
+     [symbol] and [xsymbol]. *)
+
+  include IT
+
+  (* This auxiliary function decodes a packed linearized array, as created by
+     [TableBackend.linearize_and_marshal1]. Here, we read a row all at once. *)
+
+  let read_packed_linearized
+    (data, entry : PackedIntArray.t * PackedIntArray.t) (i : int) : int list
+  =
+    LinearizedArray.read_row_via
+      (PackedIntArray.get data)
+      (PackedIntArray.get entry)
+      i
+
+  (* This auxiliary function decodes a symbol. The encoding was done by
+     [encode_symbol] or [encode_symbol_option] in the table back-end. *)
+
+  let decode_symbol (symbol : int) : IT.xsymbol =
+    (* If [symbol] is 0, then we have no symbol. This could mean e.g.
+       that the function [incoming_symbol] has been applied to an
+       initial state. In principle, this cannot happen. *)
+    assert (symbol > 0);
+    (* The low-order bit distinguishes terminal and nonterminal symbols. *)
+    let kind = symbol land 1 in
+    let symbol = symbol lsr 1 in
+    if kind = 0 then
+      IT.terminal (symbol - 1)
+    else
+      IT.nonterminal symbol
+
+  (* These auxiliary functions convert a symbol to its integer code. For speed
+     and for convenience, we use an unsafe type cast. This relies on the fact
+     that the data constructors of the [terminal] and [nonterminal] GADTs are
+     declared in an order that reflects their internal code. In the case of
+     nonterminal symbols, we add [start] to account for the presence of the
+     start symbols. *)
+
+  let n2i (nt : 'a IT.nonterminal) : int =
+    let answer = TT.start + Obj.magic nt in
+    (* For safety, check that the above cast produced a correct result. *)
+    assert (IT.nonterminal answer = X (N nt));
+    answer
+
+  let t2i (t : 'a IT.terminal) : int =
+    let answer = Obj.magic t in
+    (* For safety, check that the above cast produced a correct result. *)
+    assert (IT.terminal answer = X (T t));
+    answer
+
+  (* Ordering functions. *)
+
+  let compare_terminals t1 t2 =
+    (* Subtraction is safe because overflow is impossible. *)
+    t2i t1 - t2i t2
+
+  let compare_nonterminals nt1 nt2 =
+    (* Subtraction is safe because overflow is impossible. *)
+    n2i nt1 - n2i nt2
+
+  let compare_symbols symbol1 symbol2 =
+    match symbol1, symbol2 with
+    | X (T _), X (N _) ->
+        -1
+    | X (N _), X (T _) ->
+        1
+    | X (T t1), X (T t2) ->
+        compare_terminals t1 t2
+    | X (N nt1), X (N nt2) ->
+        compare_nonterminals nt1 nt2
+
+  let compare_productions prod1 prod2 =
+    (* Subtraction is safe because overflow is impossible. *)
+    prod1 - prod2
+
+  let compare_items (prod1, index1) (prod2, index2) =
+    let c = compare_productions prod1 prod2 in
+    (* Subtraction is safe because overflow is impossible. *)
+    if c <> 0 then c else index1 - index2
+
+  (* The function [incoming_symbol] goes through the tables [IT.lr0_core] and
+     [IT.lr0_incoming]. This yields a representation of type [xsymbol], out of
+     which we strip the [X] quantifier, so as to get a naked symbol. This last
+     step is ill-typed and potentially dangerous. It is safe only because this
+     function is used at type ['a lr1state -> 'a symbol], which forces an
+     appropriate choice of ['a]. *)
+
+  let incoming_symbol (s : 'a IT.lr1state) : 'a IT.symbol =
+    let core = PackedIntArray.get IT.lr0_core s in
+    let symbol = decode_symbol (PackedIntArray.get IT.lr0_incoming core) in
+    match symbol with
+    | IT.X symbol ->
+        Obj.magic symbol
+
+  (* The function [lhs] reads the table [TT.lhs] and uses [IT.nonterminal]
+     to decode the symbol. *)
+
+  let lhs prod =
+    IT.nonterminal (PackedIntArray.get TT.lhs prod)
+
+  (* The function [rhs] reads the table [IT.rhs] and uses [decode_symbol]
+     to decode the symbol. *)
+
+  let rhs prod =
+    List.map decode_symbol (read_packed_linearized IT.rhs prod)
+
+  (* The function [items] maps the LR(1) state [s] to its LR(0) core,
+     then uses [core] as an index into the table [IT.lr0_items]. The
+     items are then decoded by the function [export] below, which is
+     essentially a copy of [Item.export]. *)
+
+  type item =
+      int * int
+
+  let low_bits =
+    10
+
+  let low_limit =
+    1 lsl low_bits
+
+  let export t : item =
+    (t lsr low_bits, t mod low_limit)
+
+  let items s =
+    (* Map [s] to its LR(0) core. *)
+    let core = PackedIntArray.get IT.lr0_core s in
+    (* Now use [core] to look up the table [IT.lr0_items]. *)
+    List.map export (read_packed_linearized IT.lr0_items core)
+
+  (* The function [nullable] maps the nonterminal symbol [nt] to its
+     integer code, which it uses to look up the array [IT.nullable].
+     This yields 0 or 1, which we map back to a Boolean result. *)
+
+  let decode_bool i =
+    assert (i = 0 || i = 1);
+    i = 1
+
+  let nullable nt =
+    decode_bool (PackedIntArray.get1 IT.nullable (n2i nt))
+
+  (* The function [first] maps the symbols [nt] and [t] to their integer
+     codes, which it uses to look up the matrix [IT.first]. *)
+
+  let first nt t =
+    decode_bool (PackedIntArray.unflatten1 IT.first (n2i nt) (t2i t))
+
+  let xfirst symbol t =
+    match symbol with
+    | X (T t') ->
+        compare_terminals t t' = 0
+    | X (N nt) ->
+        first nt t
+
+  (* The function [foreach_terminal] exploits the fact that the
+     first component of [TT.error] is [Terminal.n - 1], i.e., the
+     number of terminal symbols, including [error] but not [#]. *)
+
+  let rec foldij i j f accu =
+    if i = j then
+      accu
+    else
+      foldij (i + 1) j f (f i accu)
+
+  let foreach_terminal f accu =
+    let n, _ = TT.error in
+    foldij 0 n (fun i accu ->
+      f (IT.terminal i) accu
+    ) accu
+
+  let foreach_terminal_but_error f accu =
+    let n, _ = TT.error in
+    foldij 0 n (fun i accu ->
+      if i = TT.error_terminal then
+        accu
+      else
+        f (IT.terminal i) accu
+    ) accu
+
+  (* ------------------------------------------------------------------------ *)
+
+  (* The following is the implementation of the function [feed]. This function
+     is logically part of the LR engine, so it would be nice if it were placed
+     in the module [Engine], but it must be placed here because, to ensure
+     type safety, its arguments must be a symbol of type ['a symbol] and a
+     semantic value of type ['a]. The type ['a symbol] is not available in
+     [Engine]. It is available here. *)
+
+  open EngineTypes
+  open ET
+  open E
+
+  (* [feed] fails if the current state does not have an outgoing transition
+     labeled with the desired symbol. This check is carried out at runtime. *)
+
+  let feed_failure () =
+    invalid_arg "feed: outgoing transition does not exist"
+
+  (* Feeding a nonterminal symbol [nt]. Here, [nt] has type [nonterminal],
+     which is a synonym for [int], and [semv] has type [semantic_value],
+     which is a synonym for [Obj.t]. This type is unsafe, because pushing
+     a semantic value of arbitrary type into the stack can later cause a
+     semantic action to crash and burn. The function [feed] is given a safe
+     type below. *)
+
+  let feed_nonterminal
+        (nt : nonterminal) startp (semv : semantic_value) endp (env : 'b env)
+      : 'b env
+  =
+    (* Check if the source state has an outgoing transition labeled [nt].
+       This is done by consulting the [goto] table. *)
+    let source = env.current in
+    match ET.maybe_goto_nt source nt with
+    | None ->
+        feed_failure()
+    | Some target ->
+        (* Push a new cell onto the stack, containing the identity of the state
+           that we are leaving. The semantic value [semv] and positions [startp]
+           and [endp] contained in the new cell are provided by the caller. *)
+        let stack = { state = source; semv; startp; endp; next = env.stack } in
+        (* Move to the target state. *)
+        { env with stack; current = target }
+
+  let reduce   _env _prod = feed_failure()
+  let initiate _env       = feed_failure()
+
+  let feed_terminal
+        (terminal : terminal) startp (semv : semantic_value) endp (env : 'b env)
+      : 'b env
+  =
+    (* Check if the source state has an outgoing transition labeled [terminal].
+       This is done by consulting the [action] table. *)
+    let source = env.current in
+    ET.action source terminal semv
+      (fun env _please_discard _terminal semv target ->
+        (* There is indeed a transition toward the state [target].
+           Push a new cell onto the stack and move to the target state. *)
+        let stack = { state = source; semv; startp; endp; next = env.stack } in
+        { env with stack; current = target }
+      ) reduce initiate env
+
+  (* The type assigned to [feed] ensures that the type of the semantic value
+     [semv] is appropriate: it must be the semantic-value type of the symbol
+     [symbol]. *)
+
+  let feed (symbol : 'a symbol) startp (semv : 'a) endp env =
+    let semv : semantic_value = Obj.repr semv in
+    match symbol with
+    | N nt ->
+        feed_nonterminal (n2i nt) startp semv endp env
+    | T terminal ->
+        feed_terminal (t2i terminal) startp semv endp env
+
+end
+end
+module TableInterpreter = struct
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+module MakeEngineTable (T : TableFormat.TABLES) = struct
+
+  type state =
+      int
+
+  let number s = s
+
+  type token =
+      T.token
+
+  type terminal =
+      int
+
+  type nonterminal =
+      int
+
+  type semantic_value =
+      Obj.t
+
+  let token2terminal =
+    T.token2terminal
+
+  let token2value =
+    T.token2value
+
+  let error_terminal =
+    T.error_terminal
+
+  let error_value =
+    Obj.repr ()
+
+  (* The function [foreach_terminal] exploits the fact that the
+     first component of [T.error] is [Terminal.n - 1], i.e., the
+     number of terminal symbols, including [error] but not [#]. *)
+
+  (* There is similar code in [InspectionTableInterpreter]. The
+     code there contains an additional conversion of the type
+     [terminal] to the type [xsymbol]. *)
+
+  let rec foldij i j f accu =
+    if i = j then
+      accu
+    else
+      foldij (i + 1) j f (f i accu)
+
+  let foreach_terminal f accu =
+    let n, _ = T.error in
+    foldij 0 n (fun i accu ->
+      f i accu
+    ) accu
+
+  type production =
+      int
+
+  (* In principle, only non-start productions are exposed to the user,
+     at type [production] or at type [int]. This is checked dynamically. *)
+  let non_start_production i =
+    assert (T.start <= i && i - T.start < Array.length T.semantic_action)
+
+  let production_index i =
+    non_start_production i;
+    i
+
+  let find_production i =
+    non_start_production i;
+    i
+
+  let default_reduction state defred nodefred env =
+    let code = PackedIntArray.get T.default_reduction state in
+    if code = 0 then
+      nodefred env
+    else
+      defred env (code - 1)
+
+  let is_start prod =
+    prod < T.start
+
+  (* This auxiliary function helps access a compressed, two-dimensional
+     matrix, like the action and goto tables. *)
+
+  let unmarshal2 table i j =
+    RowDisplacement.getget
+      PackedIntArray.get
+      PackedIntArray.get
+      table
+      i j
+
+  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
+    | c ->
+        assert (c = 0);
+        fail env
+
+  let goto_nt state nt =
+    let code = unmarshal2 T.goto state nt in
+    (* code = 1 + state *)
+    code - 1
+
+  let goto_prod state prod =
+    goto_nt state (PackedIntArray.get T.lhs prod)
+
+  let maybe_goto_nt state nt =
+    let code = unmarshal2 T.goto state nt in
+    (* If [code] is 0, there is no outgoing transition.
+       If [code] is [1 + state], there is a transition towards [state]. *)
+    assert (0 <= code);
+    if code = 0 then None else Some (code - 1)
+
+  exception 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)
+
+  (* [may_reduce state prod] tests whether the state [state] is capable of
+     reducing the production [prod]. This information could be determined
+     in constant time if we were willing to create a bitmap for it, but
+     that would take up a lot of space. Instead, we obtain this information
+     by iterating over a line in the action table. This is costly, but this
+     function is not normally used by the LR engine anyway; it is supposed
+     to be used only by programmers who wish to develop error recovery
+     strategies. *)
+
+  (* In the future, if desired, we could memoize this function, so as
+     to pay the cost in (memory) space only if and where this function
+     is actually used. We could also replace [foreach_terminal] with a
+     function [exists_terminal] which stops as soon as the accumulator
+     is [true]. *)
+
+  let may_reduce state prod =
+    (* Test if there is a default reduction of [prod]. *)
+    default_reduction state
+      (fun () prod' -> prod = prod')
+      (fun () ->
+        (* If not, then for each terminal [t], ... *)
+        foreach_terminal (fun t accu ->
+          accu ||
+          (* ... test if there is a reduction of [prod] on [t]. *)
+          action state t ()
+            (* shift:  *) (fun () _ _ () _ -> false)
+            (* reduce: *) (fun () prod' -> prod = prod')
+            (* fail:   *) (fun () -> false)
+            ()
+        ) false
+      )
+      ()
+
+  (* 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, _) ->
+          fprintf stderr "Lookahead token is now %s (%d-%d)\n%!"
+            terminals.(token)
+            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
+end
+module StaticVersion = struct
+let require_20201216 = ()
+end
diff --git a/src/ocaml/preprocess/menhirLib.mli b/src/ocaml/preprocess/menhirLib.mli
new file mode 100644
index 0000000..98db99e
--- /dev/null
+++ b/src/ocaml/preprocess/menhirLib.mli
@@ -0,0 +1,1807 @@
+module General : sig
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* This module offers general-purpose functions on lists and streams. *)
+
+(* As of 2017/03/31, this module is DEPRECATED. It might be removed in
+   the future. *)
+
+(* --------------------------------------------------------------------------- *)
+
+(* Lists. *)
+
+(* [take n xs] returns the [n] first elements of the list [xs]. It is
+   acceptable  for the list [xs] to have length less than [n], in
+   which case [xs] itself is returned. *)
+
+val take: int -> 'a list -> 'a list
+
+(* [drop n xs] returns the list [xs], deprived of its [n] first elements.
+   It is acceptable for the list [xs] to have length less than [n], in
+   which case an empty list is returned. *)
+
+val drop: int -> 'a list -> 'a list
+
+(* [uniq cmp xs] assumes that the list [xs] is sorted according to the
+   ordering [cmp] and returns the list [xs] deprived of any duplicate
+   elements. *)
+
+val uniq: ('a -> 'a -> int) -> 'a list -> 'a list
+
+(* [weed cmp xs] returns the list [xs] deprived of any duplicate elements. *)
+
+val weed: ('a -> 'a -> int) -> 'a list -> 'a list
+
+(* --------------------------------------------------------------------------- *)
+
+(* A stream is a list whose elements are produced on demand. *)
+
+type 'a stream =
+    'a head Lazy.t
+
+and 'a head =
+  | Nil
+  | Cons of 'a * 'a stream
+
+(* The length of a stream. *)
+
+val length: 'a stream -> int
+
+(* Folding over a stream. *)
+
+val foldr: ('a -> 'b -> 'b) -> 'a stream -> 'b -> 'b
+end
+module Convert : sig
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* An ocamlyacc-style, or Menhir-style, parser requires access to
+   the lexer, which must be parameterized with a lexing buffer, and
+   to the lexing buffer itself, where it reads position information. *)
+
+(* This traditional API is convenient when used with ocamllex, but
+   inelegant when used with other lexer generators. *)
+
+type ('token, 'semantic_value) traditional =
+    (Lexing.lexbuf -> 'token) -> Lexing.lexbuf -> 'semantic_value
+
+(* This revised API is independent of any lexer generator. Here, the
+   parser only requires access to the lexer, and the lexer takes no
+   parameters. The tokens returned by the lexer may contain position
+   information. *)
+
+type ('token, 'semantic_value) revised =
+    (unit -> 'token) -> 'semantic_value
+
+(* --------------------------------------------------------------------------- *)
+
+(* Converting a traditional parser, produced by ocamlyacc or Menhir,
+   into a revised parser. *)
+
+(* A token of the revised lexer is essentially a triple of a token
+   of the traditional lexer (or raw token), a start position, and
+   and end position. The three [get] functions are accessors. *)
+
+(* We do not require the type ['token] to actually be a triple type.
+   This enables complex applications where it is a record type with
+   more than three fields. It also enables simple applications where
+   positions are of no interest, so ['token] is just ['raw_token]
+   and [get_startp] and [get_endp] return dummy positions. *)
+
+val traditional2revised:
+  ('token -> 'raw_token) ->
+  ('token -> Lexing.position) ->
+  ('token -> Lexing.position) ->
+  ('raw_token, 'semantic_value) traditional ->
+  ('token, 'semantic_value) revised
+
+(* --------------------------------------------------------------------------- *)
+
+(* Converting a revised parser back to a traditional parser. *)
+
+val revised2traditional:
+  ('raw_token -> Lexing.position -> Lexing.position -> 'token) ->
+  ('token, 'semantic_value) revised ->
+  ('raw_token, 'semantic_value) traditional
+
+(* --------------------------------------------------------------------------- *)
+
+(* Simplified versions of the above, where concrete triples are used. *)
+
+module Simplified : sig
+
+  val traditional2revised:
+    ('token, 'semantic_value) traditional ->
+    ('token * Lexing.position * Lexing.position, 'semantic_value) revised
+
+  val revised2traditional:
+    ('token * Lexing.position * Lexing.position, 'semantic_value) revised ->
+    ('token, 'semantic_value) traditional
+
+end
+end
+module IncrementalEngine : sig
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+type position = Lexing.position
+
+open General
+
+(* This signature describes the incremental LR engine. *)
+
+(* In this mode, the user controls the lexer, and the parser suspends
+   itself when it needs to read a new token. *)
+
+module type INCREMENTAL_ENGINE = sig
+
+  type token
+
+  (* A value of type [production] is (an index for) a production. The start
+     productions (which do not exist in an \mly file, but are constructed by
+     Menhir internally) are not part of this type. *)
+
+  type production
+
+  (* The type ['a checkpoint] represents an intermediate or final state of the
+     parser. An intermediate checkpoint is a suspension: it records the parser's
+     current state, and allows parsing to be resumed. The parameter ['a] is
+     the type of the semantic value that will eventually be produced if the
+     parser succeeds. *)
+
+  (* [Accepted] and [Rejected] are final checkpoints. [Accepted] carries a
+     semantic value. *)
+
+  (* [InputNeeded] is an intermediate checkpoint. It means that the parser wishes
+     to read one token before continuing. *)
+
+  (* [Shifting] is an intermediate checkpoint. It means that the parser is taking
+     a shift transition. It exposes the state of the parser before and after
+     the transition. The Boolean parameter tells whether the parser intends to
+     request a new token after this transition. (It always does, except when
+     it is about to accept.) *)
+
+  (* [AboutToReduce] is an intermediate checkpoint. It means that the parser is
+     about to perform a reduction step. It exposes the parser's current
+     state as well as the production that is about to be reduced. *)
+
+  (* [HandlingError] is an intermediate checkpoint. It means that the parser has
+     detected an error and is currently handling it, in several steps. *)
+
+  (* A value of type ['a env] represents a configuration of the automaton:
+     current state, stack, lookahead token, etc. The parameter ['a] is the
+     type of the semantic value that will eventually be produced if the parser
+     succeeds. *)
+
+  (* In normal operation, the parser works with checkpoints: see the functions
+     [offer] and [resume]. However, it is also possible to work directly with
+     environments (see the functions [pop], [force_reduction], and [feed]) and
+     to reconstruct a checkpoint out of an environment (see [input_needed]).
+     This is considered advanced functionality; its purpose is to allow error
+     recovery strategies to be programmed by the user. *)
+
+  type 'a env
+
+  type 'a checkpoint = private
+    | InputNeeded of 'a env
+    | Shifting of 'a env * 'a env * bool
+    | AboutToReduce of 'a env * production
+    | HandlingError of 'a env
+    | Accepted of 'a
+    | Rejected
+
+  (* [offer] allows the user to resume the parser after it has suspended
+     itself with a checkpoint of the form [InputNeeded env]. [offer] expects
+     the old checkpoint as well as a new token and produces a new checkpoint.
+     It does not raise any exception. *)
+
+  val offer:
+    'a checkpoint ->
+    token * position * position ->
+    'a checkpoint
+
+  (* [resume] allows the user to resume the parser after it has suspended
+     itself with a checkpoint of the form [AboutToReduce (env, prod)] or
+     [HandlingError env]. [resume] expects the old checkpoint and produces a
+     new checkpoint. It does not raise any exception. *)
+
+  (* The optional argument [strategy] influences the manner in which [resume]
+     deals with checkpoints of the form [ErrorHandling _]. Its default value
+     is [`Legacy]. It can be briefly described as follows:
+
+     - If the [error] token is used only to report errors (that is, if the
+       [error] token appears only at the end of a production, whose semantic
+       action raises an exception) then the simplified strategy should be
+       preferred. (This includes the case where the [error] token does not
+       appear at all in the grammar.)
+
+     - If the [error] token is used to recover after an error, or if
+       perfect backward compatibility is required, the legacy strategy
+       should be selected.
+
+     More details on these strategies appear in the file [Engine.ml]. *)
+
+  type strategy =
+    [ `Legacy | `Simplified ]
+
+  val resume:
+    ?strategy:strategy ->
+    'a checkpoint ->
+    'a checkpoint
+
+  (* A token supplier is a function of no arguments which delivers a new token
+     (together with its start and end positions) every time it is called. *)
+
+  type supplier =
+    unit -> token * position * position
+
+  (* A pair of a lexer and a lexing buffer can be easily turned into a
+     supplier. *)
+
+  val lexer_lexbuf_to_supplier:
+    (Lexing.lexbuf -> token) ->
+    Lexing.lexbuf ->
+    supplier
+
+  (* The functions [offer] and [resume] are sufficient to write a parser loop.
+     One can imagine many variations (which is why we expose these functions
+     in the first place!). Here, we expose a few variations of the main loop,
+     ready for use. *)
+
+  (* [loop supplier checkpoint] begins parsing from [checkpoint], reading
+     tokens from [supplier]. It continues parsing until it reaches a
+     checkpoint of the form [Accepted v] or [Rejected]. In the former case, it
+     returns [v]. In the latter case, it raises the exception [Error].
+     The optional argument [strategy], whose default value is [Legacy],
+     is passed to [resume] and influences the error-handling strategy. *)
+
+  val loop: ?strategy:strategy -> supplier -> 'a checkpoint -> 'a
+
+  (* [loop_handle succeed fail supplier checkpoint] begins parsing from
+     [checkpoint], reading tokens from [supplier]. It continues parsing until
+     it reaches a checkpoint of the form [Accepted v] or [HandlingError env]
+     (or [Rejected], but that should not happen, as [HandlingError _] will be
+     observed first). In the former case, it calls [succeed v]. In the latter
+     case, it calls [fail] with this checkpoint. It cannot raise [Error].
+
+     This means that Menhir's error-handling procedure does not get a chance
+     to run. For this reason, there is no [strategy] parameter. Instead, the
+     user can implement her own error handling code, in the [fail]
+     continuation. *)
+
+  val loop_handle:
+    ('a -> 'answer) ->
+    ('a checkpoint -> 'answer) ->
+    supplier -> 'a checkpoint -> 'answer
+
+  (* [loop_handle_undo] is analogous to [loop_handle], except it passes a pair
+     of checkpoints to the failure continuation.
+
+     The first (and oldest) checkpoint is the last [InputNeeded] checkpoint that
+     was encountered before the error was detected. The second (and newest)
+     checkpoint is where the error was detected, as in [loop_handle]. Going back
+     to the first checkpoint can be thought of as undoing any reductions that
+     were performed after seeing the problematic token. (These reductions must
+     be default reductions or spurious reductions.)
+
+     [loop_handle_undo] must initially be applied to an [InputNeeded] checkpoint.
+     The parser's initial checkpoints satisfy this constraint. *)
+
+  val loop_handle_undo:
+    ('a -> 'answer) ->
+    ('a checkpoint -> 'a checkpoint -> 'answer) ->
+    supplier -> 'a checkpoint -> 'answer
+
+  (* [shifts checkpoint] assumes that [checkpoint] has been obtained by
+     submitting a token to the parser. It runs the parser from [checkpoint],
+     through an arbitrary number of reductions, until the parser either
+     accepts this token (i.e., shifts) or rejects it (i.e., signals an error).
+     If the parser decides to shift, then [Some env] is returned, where [env]
+     is the parser's state just before shifting. Otherwise, [None] is
+     returned. *)
+
+  (* It is desirable that the semantic actions be side-effect free, or that
+     their side-effects be harmless (replayable). *)
+
+  val shifts: 'a checkpoint -> 'a env option
+
+  (* The function [acceptable] allows testing, after an error has been
+     detected, which tokens would have been accepted at this point. It is
+     implemented using [shifts]. Its argument should be an [InputNeeded]
+     checkpoint. *)
+
+  (* For completeness, one must undo any spurious reductions before carrying out
+     this test -- that is, one must apply [acceptable] to the FIRST checkpoint
+     that is passed by [loop_handle_undo] to its failure continuation. *)
+
+  (* This test causes some semantic actions to be run! The semantic actions
+     should be side-effect free, or their side-effects should be harmless. *)
+
+  (* The position [pos] is used as the start and end positions of the
+     hypothetical token, and may be picked up by the semantic actions. We
+     suggest using the position where the error was detected. *)
+
+  val acceptable: 'a checkpoint -> token -> position -> bool
+
+  (* The abstract type ['a lr1state] describes the non-initial states of the
+     LR(1) automaton. The index ['a] represents the type of the semantic value
+     associated with this state's incoming symbol. *)
+
+  type 'a lr1state
+
+  (* The states of the LR(1) automaton are numbered (from 0 and up). *)
+
+  val number: _ lr1state -> int
+
+  (* Productions are numbered. *)
+
+  (* [find_production i] requires the index [i] to be valid. Use with care. *)
+
+  val production_index: production -> int
+  val find_production: int -> production
+
+  (* An element is a pair of a non-initial state [s] and a semantic value [v]
+     associated with the incoming symbol of this state. The idea is, the value
+     [v] was pushed onto the stack just before the state [s] was entered. Thus,
+     for some type ['a], the state [s] has type ['a lr1state] and the value [v]
+     has type ['a]. In other words, the type [element] is an existential type. *)
+
+  type element =
+    | Element: 'a lr1state * 'a * position * position -> element
+
+  (* The parser's stack is (or, more precisely, can be viewed as) a stream of
+     elements. The type [stream] is defined by the module [General]. *)
+
+  (* As of 2017/03/31, the types [stream] and [stack] and the function [stack]
+     are DEPRECATED. They might be removed in the future. An alternative way
+     of inspecting the stack is via the functions [top] and [pop]. *)
+
+  type stack = (* DEPRECATED *)
+    element stream
+
+  (* This is the parser's stack, a stream of elements. This stream is empty if
+     the parser is in an initial state; otherwise, it is non-empty.  The LR(1)
+     automaton's current state is the one found in the top element of the
+     stack. *)
+
+  val stack: 'a env -> stack (* DEPRECATED *)
+
+  (* [top env] returns the parser's top stack element. The state contained in
+     this stack element is the current state of the automaton. If the stack is
+     empty, [None] is returned. In that case, the current state of the
+     automaton must be an initial state. *)
+
+  val top: 'a env -> element option
+
+  (* [pop_many i env] pops [i] cells off the automaton's stack. This is done
+     via [i] successive invocations of [pop]. Thus, [pop_many 1] is [pop]. The
+     index [i] must be nonnegative. The time complexity is O(i). *)
+
+  val pop_many: int -> 'a env -> 'a env option
+
+  (* [get i env] returns the parser's [i]-th stack element. The index [i] is
+     0-based: thus, [get 0] is [top]. If [i] is greater than or equal to the
+     number of elements in the stack, [None] is returned. The time complexity
+     is O(i). *)
+
+  val get: int -> 'a env -> element option
+
+  (* [current_state_number env] is (the integer number of) the automaton's
+     current state. This works even if the automaton's stack is empty, in
+     which case the current state is an initial state. This number can be
+     passed as an argument to a [message] function generated by [menhir
+     --compile-errors]. *)
+
+  val current_state_number: 'a env -> int
+
+  (* [equal env1 env2] tells whether the parser configurations [env1] and
+     [env2] are equal in the sense that the automaton's current state is the
+     same in [env1] and [env2] and the stack is *physically* the same in
+     [env1] and [env2]. If [equal env1 env2] is [true], then the sequence of
+     the stack elements, as observed via [pop] and [top], must be the same in
+     [env1] and [env2]. Also, if [equal env1 env2] holds, then the checkpoints
+     [input_needed env1] and [input_needed env2] must be equivalent. The
+     function [equal] has time complexity O(1). *)
+
+  val equal: 'a env -> 'a env -> bool
+
+  (* These are the start and end positions of the current lookahead token. If
+     invoked in an initial state, this function returns a pair of twice the
+     initial position. *)
+
+  val positions: 'a env -> position * position
+
+  (* When applied to an environment taken from a checkpoint of the form
+     [AboutToReduce (env, prod)], the function [env_has_default_reduction]
+     tells whether the reduction that is about to take place is a default
+     reduction. *)
+
+  val env_has_default_reduction: 'a env -> bool
+
+  (* [state_has_default_reduction s] tells whether the state [s] has a default
+     reduction. This includes the case where [s] is an accepting state. *)
+
+  val state_has_default_reduction: _ lr1state -> bool
+
+  (* [pop env] returns a new environment, where the parser's top stack cell
+     has been popped off. (If the stack is empty, [None] is returned.) This
+     amounts to pretending that the (terminal or nonterminal) symbol that
+     corresponds to this stack cell has not been read. *)
+
+  val pop: 'a env -> 'a env option
+
+  (* [force_reduction prod env] should be called only if in the state [env]
+     the parser is capable of reducing the production [prod]. If this
+     condition is satisfied, then this production is reduced, which means that
+     its semantic action is executed (this can have side effects!) and the
+     automaton makes a goto (nonterminal) transition. If this condition is not
+     satisfied, [Invalid_argument _] is raised. *)
+
+  val force_reduction: production -> 'a env -> 'a env
+
+  (* [input_needed env] returns [InputNeeded env]. That is, out of an [env]
+     that might have been obtained via a series of calls to the functions
+     [pop], [force_reduction], [feed], etc., it produces a checkpoint, which
+     can be used to resume normal parsing, by supplying this checkpoint as an
+     argument to [offer]. *)
+
+  (* This function should be used with some care. It could "mess up the
+     lookahead" in the sense that it allows parsing to resume in an arbitrary
+     state [s] with an arbitrary lookahead symbol [t], even though Menhir's
+     reachability analysis (menhir --list-errors) might well think that it is
+     impossible to reach this particular configuration. If one is using
+     Menhir's new error reporting facility, this could cause the parser to
+     reach an error state for which no error message has been prepared. *)
+
+  val input_needed: 'a env -> 'a checkpoint
+
+end
+
+(* This signature is a fragment of the inspection API that is made available
+   to the user when [--inspection] is used. This fragment contains type
+   definitions for symbols. *)
+
+module type SYMBOLS = sig
+
+  (* The type ['a terminal] represents a terminal symbol. The type ['a
+     nonterminal] represents a nonterminal symbol. In both cases, the index
+     ['a] represents the type of the semantic values associated with this
+     symbol. The concrete definitions of these types are generated. *)
+
+  type 'a terminal
+  type 'a nonterminal
+
+  (* The type ['a symbol] represents a terminal or nonterminal symbol. It is
+     the disjoint union of the types ['a terminal] and ['a nonterminal]. *)
+
+  type 'a symbol =
+    | T : 'a terminal -> 'a symbol
+    | N : 'a nonterminal -> 'a symbol
+
+  (* The type [xsymbol] is an existentially quantified version of the type
+     ['a symbol]. This type is useful in situations where the index ['a]
+     is not statically known. *)
+
+  type xsymbol =
+    | X : 'a symbol -> xsymbol
+
+end
+
+(* This signature describes the inspection API that is made available to the
+   user when [--inspection] is used. *)
+
+module type INSPECTION = sig
+
+  (* The types of symbols are described above. *)
+
+  include SYMBOLS
+
+  (* The type ['a lr1state] is meant to be the same as in [INCREMENTAL_ENGINE]. *)
+
+  type 'a lr1state
+
+  (* The type [production] is meant to be the same as in [INCREMENTAL_ENGINE].
+     It represents a production of the grammar. A production can be examined
+     via the functions [lhs] and [rhs] below. *)
+
+  type production
+
+  (* An LR(0) item is a pair of a production [prod] and a valid index [i] into
+     this production. That is, if the length of [rhs prod] is [n], then [i] is
+     comprised between 0 and [n], inclusive. *)
+
+  type item =
+      production * int
+
+  (* Ordering functions. *)
+
+  val compare_terminals: _ terminal -> _ terminal -> int
+  val compare_nonterminals: _ nonterminal -> _ nonterminal -> int
+  val compare_symbols: xsymbol -> xsymbol -> int
+  val compare_productions: production -> production -> int
+  val compare_items: item -> item -> int
+
+  (* [incoming_symbol s] is the incoming symbol of the state [s], that is,
+     the symbol that the parser must recognize before (has recognized when)
+     it enters the state [s]. This function gives access to the semantic
+     value [v] stored in a stack element [Element (s, v, _, _)]. Indeed,
+     by case analysis on the symbol [incoming_symbol s], one discovers the
+     type ['a] of the value [v]. *)
+
+  val incoming_symbol: 'a lr1state -> 'a symbol
+
+  (* [items s] is the set of the LR(0) items in the LR(0) core of the LR(1)
+     state [s]. This set is not epsilon-closed. This set is presented as a
+     list, in an arbitrary order. *)
+
+  val items: _ lr1state -> item list
+
+  (* [lhs prod] is the left-hand side of the production [prod]. This is
+     always a non-terminal symbol. *)
+
+  val lhs: production -> xsymbol
+
+  (* [rhs prod] is the right-hand side of the production [prod]. This is
+     a (possibly empty) sequence of (terminal or nonterminal) symbols. *)
+
+  val rhs: production -> xsymbol list
+
+  (* [nullable nt] tells whether the non-terminal symbol [nt] is nullable.
+     That is, it is true if and only if this symbol produces the empty
+     word [epsilon]. *)
+
+  val nullable: _ nonterminal -> bool
+
+  (* [first nt t] tells whether the FIRST set of the nonterminal symbol [nt]
+     contains the terminal symbol [t]. That is, it is true if and only if
+     [nt] produces a word that begins with [t]. *)
+
+  val first: _ nonterminal -> _ terminal -> bool
+
+  (* [xfirst] is analogous to [first], but expects a first argument of type
+     [xsymbol] instead of [_ terminal]. *)
+
+  val xfirst: xsymbol -> _ terminal -> bool
+
+  (* [foreach_terminal] enumerates the terminal symbols, including [error].
+     [foreach_terminal_but_error] enumerates the terminal symbols, excluding
+     [error]. *)
+
+  val foreach_terminal:           (xsymbol -> 'a -> 'a) -> 'a -> 'a
+  val foreach_terminal_but_error: (xsymbol -> 'a -> 'a) -> 'a -> 'a
+
+  (* The type [env] is meant to be the same as in [INCREMENTAL_ENGINE]. *)
+
+  type 'a env
+
+  (* [feed symbol startp semv endp env] causes the parser to consume the
+     (terminal or nonterminal) symbol [symbol], accompanied with the semantic
+     value [semv] and with the start and end positions [startp] and [endp].
+     Thus, the automaton makes a transition, and reaches a new state. The
+     stack grows by one cell. This operation is permitted only if the current
+     state (as determined by [env]) has an outgoing transition labeled with
+     [symbol]. Otherwise, [Invalid_argument _] is raised. *)
+
+  val feed: 'a symbol -> position -> 'a -> position -> 'b env -> 'b env
+
+end
+
+(* This signature combines the incremental API and the inspection API. *)
+
+module type EVERYTHING = sig
+
+  include INCREMENTAL_ENGINE
+
+  include INSPECTION
+    with type 'a lr1state := 'a lr1state
+    with type production := production
+    with type 'a env := 'a env
+
+end
+end
+module EngineTypes : sig
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* This file defines several types and module types that are used in the
+   specification of module [Engine]. *)
+
+(* --------------------------------------------------------------------------- *)
+
+(* It would be nice if we could keep the structure of stacks and environments
+   hidden. However, stacks and environments must be accessible to semantic
+   actions, so the following data structure definitions must be public. *)
+
+(* --------------------------------------------------------------------------- *)
+
+(* A stack is a linked list of cells. A sentinel cell -- which is its own
+   successor -- is used to mark the bottom of the stack. The sentinel cell
+   itself is not significant -- it contains dummy values. *)
+
+type ('state, 'semantic_value) stack = {
+
+  (* The state that we should go back to if we pop this stack cell. *)
+
+  (* This convention means that the state contained in the top stack cell is
+     not the current state [env.current]. It also means that the state found
+     within the sentinel is a dummy -- it is never consulted. This convention
+     is the same as that adopted by the code-based back-end. *)
+
+  state: 'state;
+
+  (* The semantic value associated with the chunk of input that this cell
+     represents. *)
+
+  semv: 'semantic_value;
+
+  (* The start and end positions of the chunk of input that this cell
+     represents. *)
+
+  startp: Lexing.position;
+  endp: Lexing.position;
+
+  (* The next cell down in the stack. If this is a self-pointer, then this
+     cell is the sentinel, and the stack is conceptually empty. *)
+
+  next: ('state, 'semantic_value) stack;
+
+}
+
+(* --------------------------------------------------------------------------- *)
+
+(* A parsing environment contains all of the parser's state (except for the
+   current program point). *)
+
+type ('state, 'semantic_value, 'token) env = {
+
+  (* If this flag is true, then the first component of [env.triple] should
+     be ignored, as it has been logically overwritten with the [error]
+     pseudo-token. *)
+
+  error: bool;
+
+  (* The last token that was obtained from the lexer, together with its start
+     and end positions. Warning: before the first call to the lexer has taken
+     place, a dummy (and possibly invalid) token is stored here. *)
+
+  triple: 'token * Lexing.position * Lexing.position;
+
+  (* The stack. In [CodeBackend], it is passed around on its own,
+     whereas, here, it is accessed via the environment. *)
+
+  stack: ('state, 'semantic_value) stack;
+
+  (* The current state. In [CodeBackend], it is passed around on its
+     own, whereas, here, it is accessed via the environment. *)
+
+  current: 'state;
+
+}
+
+(* --------------------------------------------------------------------------- *)
+
+(* This signature describes the parameters that must be supplied to the LR
+   engine. *)
+
+module type TABLE = sig
+
+  (* The type of automaton states. *)
+
+  type state
+
+  (* States are numbered. *)
+
+  val number: state -> int
+
+  (* The type of tokens. These can be thought of as real tokens, that is,
+     tokens returned by the lexer. They carry a semantic value. This type
+     does not include the [error] pseudo-token. *)
+
+  type token
+
+  (* The type of terminal symbols. These can be thought of as integer codes.
+     They do not carry a semantic value. This type does include the [error]
+     pseudo-token. *)
+
+  type terminal
+
+  (* The type of nonterminal symbols. *)
+
+  type nonterminal
+
+  (* The type of semantic values. *)
+
+  type semantic_value
+
+  (* A token is conceptually a pair of a (non-[error]) terminal symbol and
+     a semantic value. The following two functions are the pair projections. *)
+
+  val token2terminal: token -> terminal
+  val token2value: token -> semantic_value
+
+  (* Even though the [error] pseudo-token is not a real token, it is a
+     terminal symbol. Furthermore, for regularity, it must have a semantic
+     value. *)
+
+  val error_terminal: terminal
+  val error_value: semantic_value
+
+  (* [foreach_terminal] allows iterating over all terminal symbols. *)
+
+  val foreach_terminal: (terminal -> 'a -> 'a) -> 'a -> 'a
+
+  (* The type of productions. *)
+
+  type production
+
+  val production_index: production -> int
+  val find_production: int -> production
+
+  (* If a state [s] has a default reduction on production [prod], then, upon
+     entering [s], the automaton should reduce [prod] without consulting the
+     lookahead token. The following function allows determining which states
+     have default reductions. *)
+
+  (* Instead of returning a value of a sum type -- either [DefRed prod], or
+     [NoDefRed] -- it accepts two continuations, and invokes just one of
+     them. This mechanism allows avoiding a memory allocation. *)
+
+  val default_reduction:
+    state ->
+    ('env -> production -> 'answer) ->
+    ('env -> 'answer) ->
+    'env -> 'answer
+
+  (* An LR automaton can normally take three kinds of actions: shift, reduce,
+     or fail. (Acceptance is a particular case of reduction: it consists in
+     reducing a start production.) *)
+
+  (* There are two variants of the shift action. [shift/discard s] instructs
+     the automaton to discard the current token, request a new one from the
+     lexer, and move to state [s]. [shift/nodiscard s] instructs it to move to
+     state [s] without requesting a new token. This instruction should be used
+     when [s] has a default reduction on [#]. See [CodeBackend.gettoken] for
+     details. *)
+
+  (* This is the automaton's action table. It maps a pair of a state and a
+     terminal symbol to an action. *)
+
+  (* Instead of returning a value of a sum type -- one of shift/discard,
+     shift/nodiscard, reduce, or fail -- this function accepts three
+     continuations, and invokes just one them. This mechanism allows avoiding
+     a memory allocation. *)
+
+  (* In summary, the parameters to [action] are as follows:
+
+     - the first two parameters, a state and a terminal symbol, are used to
+       look up the action table;
+
+     - the next parameter is the semantic value associated with the above
+       terminal symbol; it is not used, only passed along to the shift
+       continuation, as explained below;
+
+     - the shift continuation expects an environment; a flag that tells
+       whether to discard the current token; the terminal symbol that
+       is being shifted; its semantic value; and the target state of
+       the transition;
+
+     - the reduce continuation expects an environment and a production;
+
+     - the fail continuation expects an environment;
+
+     - the last parameter is the environment; it is not used, only passed
+       along to the selected continuation. *)
+
+  val action:
+    state ->
+    terminal ->
+    semantic_value ->
+    ('env -> bool -> terminal -> semantic_value -> state -> 'answer) ->
+    ('env -> production -> 'answer) ->
+    ('env -> 'answer) ->
+    'env -> 'answer
+
+  (* This is the automaton's goto table. This table maps a pair of a state
+     and a nonterminal symbol to a new state. By extension, it also maps a
+     pair of a state and a production to a new state. *)
+
+  (* The function [goto_nt] can be applied to [s] and [nt] ONLY if the state
+     [s] has an outgoing transition labeled [nt]. Otherwise, its result is
+     undefined. Similarly, the call [goto_prod prod s] is permitted ONLY if
+     the state [s] has an outgoing transition labeled with the nonterminal
+     symbol [lhs prod]. The function [maybe_goto_nt] involves an additional
+     dynamic check and CAN be called even if there is no outgoing transition. *)
+
+  val       goto_nt  : state -> nonterminal -> state
+  val       goto_prod: state -> production  -> state
+  val maybe_goto_nt:   state -> nonterminal -> state option
+
+  (* [is_start prod] tells whether the production [prod] is a start production. *)
+
+  val is_start: production -> bool
+
+  (* By convention, a semantic action is responsible for:
+
+     1. fetching whatever semantic values and positions it needs off the stack;
+
+     2. popping an appropriate number of cells off the stack, as dictated
+        by the length of the right-hand side of the production;
+
+     3. computing a new semantic value, as well as new start and end positions;
+
+     4. pushing a new stack cell, which contains the three values
+        computed in step 3;
+
+     5. returning the new stack computed in steps 2 and 4.
+
+     Point 1 is essentially forced upon us: if semantic values were fetched
+     off the stack by this interpreter, then the calling convention for
+     semantic actions would be variadic: not all semantic actions would have
+     the same number of arguments. The rest follows rather naturally. *)
+
+  (* Semantic actions are allowed to raise [Error]. *)
+
+  exception Error
+
+  type semantic_action =
+      (state, semantic_value, token) env -> (state, semantic_value) stack
+
+  val semantic_action: production -> semantic_action
+
+  (* [may_reduce state prod] tests whether the state [state] is capable of
+     reducing the production [prod]. This function is currently costly and
+     is not used by the core LR engine. It is used in the implementation
+     of certain functions, such as [force_reduction], which allow the engine
+     to be driven programmatically. *)
+
+  val may_reduce: state -> production -> bool
+
+  (* The LR engine requires a number of hooks, which are used for logging. *)
+
+  (* The comments below indicate the conventional messages that correspond
+     to these hooks in the code-based back-end; see [CodeBackend]. *)
+
+  (* If the flag [log] is false, then the logging functions are not called.
+     If it is [true], then they are called. *)
+
+  val log : bool
+
+  module Log : sig
+
+    (* State %d: *)
+
+    val state: state -> unit
+
+    (* Shifting (<terminal>) to state <state> *)
+
+    val shift: terminal -> state -> unit
+
+    (* Reducing a production should be logged either as a reduction
+       event (for regular productions) or as an acceptance event (for
+       start productions). *)
+
+    (* Reducing production <production> / Accepting *)
+
+    val reduce_or_accept: production -> unit
+
+    (* Lookahead token is now <terminal> (<pos>-<pos>) *)
+
+    val lookahead_token: terminal -> Lexing.position -> Lexing.position -> unit
+
+    (* Initiating error handling *)
+
+    val initiating_error_handling: unit -> unit
+
+    (* Resuming error handling *)
+
+    val resuming_error_handling: unit -> unit
+
+    (* Handling error in state <state> *)
+
+    val handling_error: state -> unit
+
+  end
+
+end
+
+(* --------------------------------------------------------------------------- *)
+
+(* This signature describes the monolithic (traditional) LR engine. *)
+
+(* In this interface, the parser controls the lexer. *)
+
+module type MONOLITHIC_ENGINE = sig
+
+  type state
+
+  type token
+
+  type semantic_value
+
+  (* An entry point to the engine requires a start state, a lexer, and a lexing
+     buffer. It either succeeds and produces a semantic value, or fails and
+     raises [Error]. *)
+
+  exception Error
+
+  val entry:
+    (* strategy: *) [ `Legacy | `Simplified ] -> (* see [IncrementalEngine] *)
+    state ->
+    (Lexing.lexbuf -> token) ->
+    Lexing.lexbuf ->
+    semantic_value
+
+end
+
+(* --------------------------------------------------------------------------- *)
+
+(* The following signatures describe the incremental LR engine. *)
+
+(* First, see [INCREMENTAL_ENGINE] in the file [IncrementalEngine.ml]. *)
+
+(* The [start] function is set apart because we do not wish to publish
+   it as part of the generated [parser.mli] file. Instead, the table
+   back-end will publish specialized versions of it, with a suitable
+   type cast. *)
+
+module type INCREMENTAL_ENGINE_START = sig
+
+  (* [start] is an entry point. It requires a start state and a start position
+     and begins the parsing process. If the lexer is based on an OCaml lexing
+     buffer, the start position should be [lexbuf.lex_curr_p]. [start] produces
+     a checkpoint, which usually will be an [InputNeeded] checkpoint. (It could
+     be [Accepted] if this starting state accepts only the empty word. It could
+     be [Rejected] if this starting state accepts no word at all.) It does not
+     raise any exception. *)
+
+  (* [start s pos] should really produce a checkpoint of type ['a checkpoint],
+     for a fixed ['a] that depends on the state [s]. We cannot express this, so
+     we use [semantic_value checkpoint], which is safe. The table back-end uses
+     [Obj.magic] to produce safe specialized versions of [start]. *)
+
+  type state
+  type semantic_value
+  type 'a checkpoint
+
+  val start:
+    state ->
+    Lexing.position ->
+    semantic_value checkpoint
+
+end
+
+(* --------------------------------------------------------------------------- *)
+
+(* This signature describes the LR engine, which combines the monolithic
+   and incremental interfaces. *)
+
+module type ENGINE = sig
+
+  include MONOLITHIC_ENGINE
+
+  include IncrementalEngine.INCREMENTAL_ENGINE
+    with type token := token
+     and type 'a lr1state = state (* useful for us; hidden from the end user *)
+
+  include INCREMENTAL_ENGINE_START
+    with type state := state
+     and type semantic_value := semantic_value
+     and type 'a checkpoint := 'a checkpoint
+
+end
+end
+module Engine : sig
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+open EngineTypes
+
+(* The LR parsing engine. *)
+
+module Make (T : TABLE)
+: ENGINE
+  with type state = T.state
+   and type token = T.token
+   and type semantic_value = T.semantic_value
+   and type production = T.production
+   and type 'a env = (T.state, T.semantic_value, T.token) EngineTypes.env
+
+(* We would prefer not to expose the definition of the type [env].
+   However, it must be exposed because some of the code in the
+   inspection API needs access to the engine's internals; see
+   [InspectionTableInterpreter]. Everything would be simpler if
+   --inspection was always ON, but that would lead to bigger parse
+   tables for everybody. *)
+end
+module ErrorReports : sig
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* -------------------------------------------------------------------------- *)
+
+(* The following functions help keep track of the start and end positions of
+   the last two tokens in a two-place buffer. This is used to nicely display
+   where a syntax error took place. *)
+
+type 'a buffer
+
+(* [wrap lexer] returns a pair of a new (initially empty) buffer and a lexer
+   which internally relies on [lexer] and updates [buffer] on the fly whenever
+   a token is demanded. *)
+
+(* The type of the buffer is [(position * position) buffer], which means that
+   it stores two pairs of positions, which are the start and end positions of
+   the last two tokens. *)
+
+open Lexing
+
+val wrap:
+  (lexbuf -> 'token) ->
+  (position * position) buffer * (lexbuf -> 'token)
+
+val wrap_supplier:
+  (unit -> 'token * position * position) ->
+  (position * position) buffer * (unit -> 'token * position * position)
+
+(* [show f buffer] prints the contents of the buffer, producing a string that
+   is typically of the form "after '%s' and before '%s'". The function [f] is
+   used to print an element. The buffer MUST be nonempty. *)
+
+val show: ('a -> string) -> 'a buffer -> string
+
+(* [last buffer] returns the last element of the buffer. The buffer MUST be
+   nonempty. *)
+
+val last: 'a buffer -> 'a
+
+(* -------------------------------------------------------------------------- *)
+
+(* [extract text (pos1, pos2)] extracts the sub-string of [text] delimited
+   by the positions [pos1] and [pos2]. *)
+
+val extract: string -> position * position -> string
+
+(* [sanitize text] eliminates any special characters from the text [text].
+   A special character is a character whose ASCII code is less than 32.
+   Every special character is replaced with a single space character. *)
+
+val sanitize: string -> string
+
+(* [compress text] replaces every run of at least one whitespace character
+   with exactly one space character. *)
+
+val compress: string -> string
+
+(* [shorten k text] limits the length of [text] to [2k+3] characters. If the
+   text is too long, a fragment in the middle is replaced with an ellipsis. *)
+
+val shorten: int -> string -> string
+
+(* [expand f text] searches [text] for occurrences of [$k], where [k]
+   is a nonnegative integer literal, and replaces each such occurrence
+   with the string [f k]. *)
+
+val expand: (int -> string) -> string -> string
+end
+module LexerUtil : sig
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+open Lexing
+
+(* [init filename lexbuf] initializes the lexing buffer [lexbuf] so
+   that the positions that are subsequently read from it refer to the
+   file [filename]. It returns [lexbuf]. *)
+
+val init: string -> lexbuf -> lexbuf
+
+(* [read filename] reads the entire contents of the file [filename] and
+   returns a pair of this content (a string) and a lexing buffer that
+   has been initialized, based on this string. *)
+
+val read: string -> string * lexbuf
+
+(* [newline lexbuf] increments the line counter stored within [lexbuf]. It
+   should be invoked by the lexer itself every time a newline character is
+   consumed. This allows maintaining a current the line number in [lexbuf]. *)
+
+val newline: lexbuf -> unit
+
+(* [range (startpos, endpos)] prints a textual description of the range
+   delimited by the start and end positions [startpos] and [endpos].
+   This description is one line long and ends in a newline character.
+   This description mentions the file name, the line number, and a range
+   of characters on this line. The line number is correct only if [newline]
+   has been correctly used, as described dabove. *)
+
+val range: position * position -> string
+end
+module Printers : sig
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* This module is part of MenhirLib. *)
+
+module Make
+
+  (I : IncrementalEngine.EVERYTHING)
+
+  (User : sig
+
+    (* [print s] is supposed to send the string [s] to some output channel. *)
+
+    val print: string -> unit
+
+    (* [print_symbol s] is supposed to print a representation of the symbol [s]. *)
+
+    val print_symbol: I.xsymbol -> unit
+
+    (* [print_element e] is supposed to print a representation of the element [e].
+       This function is optional; if it is not provided, [print_element_as_symbol]
+       (defined below) is used instead. *)
+
+    val print_element: (I.element -> unit) option
+
+  end)
+
+: sig
+
+  open I
+
+  (* Printing a list of symbols. *)
+
+  val print_symbols: xsymbol list -> unit
+
+  (* Printing an element as a symbol. This prints just the symbol
+     that this element represents; nothing more. *)
+
+  val print_element_as_symbol: element -> unit
+
+  (* Printing a stack as a list of elements. This function needs an element
+     printer. It uses [print_element] if provided by the user; otherwise
+     it uses [print_element_as_symbol]. (Ending with a newline.) *)
+
+  val print_stack: 'a env -> unit
+
+  (* Printing an item. (Ending with a newline.) *)
+
+  val print_item: item -> unit
+
+  (* Printing a production. (Ending with a newline.) *)
+
+  val print_production: production -> unit
+
+  (* Printing the current LR(1) state. The current state is first displayed
+     as a number; then the list of its LR(0) items is printed. (Ending with
+     a newline.) *)
+
+  val print_current_state: 'a env -> unit
+
+  (* Printing a summary of the stack and current state. This function just
+     calls [print_stack] and [print_current_state] in succession. *)
+
+  val print_env: 'a env -> unit
+
+end
+end
+module InfiniteArray : sig
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+(** This module implements infinite arrays. **)
+type 'a t
+
+(** [make x] creates an infinite array, where every slot contains [x]. **)
+val make: 'a -> 'a t
+
+(** [get a i] returns the element contained at offset [i] in the array [a].
+   Slots are numbered 0 and up. **)
+val get: 'a t -> int -> 'a
+
+(** [set a i x] sets the element contained at offset [i] in the array
+    [a] to [x]. Slots are numbered 0 and up. **)
+val set: 'a t -> int -> 'a -> unit
+
+(** [extent a] is the length of an initial segment of the array [a]
+    that is sufficiently large to contain all [set] operations ever
+    performed. In other words, all elements beyond that segment have
+    the default value. *)
+val extent: 'a t -> int
+
+(** [domain a] is a fresh copy of an initial segment of the array [a]
+    whose length is [extent a]. *)
+val domain: 'a t -> 'a array
+end
+module PackedIntArray : sig
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* A packed integer array is represented as a pair of an integer [k] and
+   a string [s]. The integer [k] is the number of bits per integer that we
+   use. The string [s] is just an array of bits, which is read in 8-bit
+   chunks. *)
+
+(* The ocaml programming language treats string literals and array literals
+   in slightly different ways: the former are statically allocated, while
+   the latter are dynamically allocated. (This is rather arbitrary.) In the
+   context of Menhir's table-based back-end, where compact, immutable
+   integer arrays are needed, ocaml strings are preferable to ocaml arrays. *)
+
+type t =
+  int * string
+
+(* [pack a] turns an array of integers into a packed integer array. *)
+
+(* Because the sign bit is the most significant bit, the magnitude of
+   any negative number is the word size. In other words, [pack] does
+   not achieve any space savings as soon as [a] contains any negative
+   numbers, even if they are ``small''. *)
+
+val pack: int array -> t
+
+(* [get t i] returns the integer stored in the packed array [t] at index [i]. *)
+
+(* Together, [pack] and [get] satisfy the following property: if the index [i]
+   is within bounds, then [get (pack a) i] equals [a.(i)]. *)
+
+val get: t -> int -> int
+
+(* [get1 t i] returns the integer stored in the packed array [t] at index [i].
+   It assumes (and does not check) that the array's bit width is [1]. The
+   parameter [t] is just a string. *)
+
+val get1: string -> int -> int
+
+(* [unflatten1 (n, data) i j] accesses the two-dimensional bitmap
+   represented by [(n, data)] at indices [i] and [j]. The integer
+   [n] is the width of the bitmap; the string [data] is the second
+   component of the packed array obtained by encoding the table as
+   a one-dimensional array. *)
+
+val unflatten1: int * string -> int -> int -> int
+
+end
+module RowDisplacement : sig
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* This module compresses a two-dimensional table, where some values
+   are considered insignificant, via row displacement. *)
+
+(* A compressed table is represented as a pair of arrays. The
+   displacement array is an array of offsets into the data array. *)
+
+type 'a table =
+    int array * (* displacement *)
+     'a array   (* data *)
+
+(* [compress equal insignificant dummy m n t] turns the two-dimensional table
+   [t] into a compressed table. The parameter [equal] is equality of data
+   values. The parameter [wildcard] tells which data values are insignificant,
+   and can thus be overwritten with other values. The parameter [dummy] is
+   used to fill holes in the data array. [m] and [n] are the integer
+   dimensions of the table [t]. *)
+
+val compress:
+  ('a -> 'a -> bool) ->
+  ('a -> bool) ->
+  'a ->
+  int -> int ->
+  'a array array ->
+  'a table
+
+(* [get ct i j] returns the value found at indices [i] and [j] in the
+   compressed table [ct]. This function call is permitted only if the
+   value found at indices [i] and [j] in the original table is
+   significant -- otherwise, it could fail abruptly. *)
+
+(* Together, [compress] and [get] have the property that, if the value
+   found at indices [i] and [j] in an uncompressed table [t] is
+   significant, then [get (compress t) i j] is equal to that value. *)
+
+val get:
+  'a table ->
+  int -> int ->
+  'a
+
+(* [getget] is a variant of [get] which only requires read access,
+   via accessors, to the two components of the table. *)
+
+val getget:
+  ('displacement -> int -> int) ->
+  ('data -> int -> 'a) ->
+  'displacement * 'data ->
+  int -> int ->
+  'a
+
+end
+module LinearizedArray : sig
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* An array of arrays (of possibly different lengths!) can be ``linearized'',
+   i.e., encoded as a data array (by concatenating all of the little arrays)
+   and an entry array (which contains offsets into the data array). *)
+
+type 'a t =
+  (* data: *)   'a array *
+  (* entry: *) int array
+
+(* [make a] turns the array of arrays [a] into a linearized array. *)
+
+val make: 'a array array -> 'a t
+
+(* [read la i j] reads the linearized array [la] at indices [i] and [j].
+   Thus, [read (make a) i j] is equivalent to [a.(i).(j)]. *)
+
+val read: 'a t -> int -> int -> 'a
+
+(* [write la i j v] writes the value [v] into the linearized array [la]
+   at indices [i] and [j]. *)
+
+val write: 'a t -> int -> int -> 'a -> unit
+
+(* [length la] is the number of rows of the array [la]. Thus, [length (make
+   a)] is equivalent to [Array.length a]. *)
+
+val length: 'a t -> int
+
+(* [row_length la i] is the length of the row at index [i] in the linearized
+   array [la]. Thus, [row_length (make a) i] is equivalent to [Array.length
+   a.(i)]. *)
+
+val row_length: 'a t -> int -> int
+
+(* [read_row la i] reads the row at index [i], producing a list. Thus,
+   [read_row (make a) i] is equivalent to [Array.to_list a.(i)]. *)
+
+val read_row: 'a t -> int -> 'a list
+
+(* The following variants read the linearized array via accessors
+   [get_data : int -> 'a] and [get_entry : int -> int]. *)
+
+val row_length_via:
+  (* get_entry: *) (int -> int) ->
+  (* i: *)         int ->
+                   int
+
+val read_via:
+  (* get_data: *)  (int -> 'a) ->
+  (* get_entry: *) (int -> int) ->
+  (* i: *)         int ->
+  (* j: *)         int ->
+                   'a
+
+val read_row_via:
+  (* get_data: *)  (int -> 'a) ->
+  (* get_entry: *) (int -> int) ->
+  (* i: *)         int ->
+                   'a list
+
+end
+module TableFormat : sig
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* This signature defines the format of the parse tables. It is used as
+   an argument to [TableInterpreter.Make]. *)
+
+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. *)
+
+  val token2terminal: token -> int
+
+  (* This is the integer code for the error pseudo-token. *)
+
+  val error_terminal: int
+
+  (* This maps a token to its semantic value. *)
+
+  val token2value: token -> Obj.t
+
+  (* Traditionally, an LR automaton is described by two tables, namely, an
+     action table and a goto table. See, for instance, the Dragon book.
+
+     The action table is a two-dimensional matrix that maps a state and a
+     lookahead token to an action. An action is one of: shift to a certain
+     state, reduce a certain production, accept, or fail.
+
+     The goto table is a two-dimensional matrix that maps a state and a
+     non-terminal symbol to either a state or undefined. By construction, this
+     table is sparse: its undefined entries are never looked up. A compression
+     technique is free to overlap them with other entries.
+
+     In Menhir, things are slightly different. If a state has a default
+     reduction on token [#], then that reduction must be performed without
+     consulting the lookahead token. As a result, we must first determine
+     whether that is the case, before we can obtain a lookahead token and use it
+     as an index in the action table.
+
+     Thus, Menhir's tables are as follows.
+
+     A one-dimensional default reduction table maps a state to either ``no
+     default reduction'' (encoded as: 0) or ``by default, reduce prod''
+     (encoded as: 1 + prod). The action table is looked up only when there
+     is no default reduction. *)
+
+  val default_reduction: PackedIntArray.t
+
+  (* Menhir follows Dencker, Dürre and Heuft, who point out that, although the
+     action table is not sparse by nature (i.e., the error entries are
+     significant), it can be made sparse by first factoring out a binary error
+     matrix, then replacing the error entries in the action table with undefined
+     entries. Thus:
+
+     A two-dimensional error bitmap maps a state and a terminal to either
+     ``fail'' (encoded as: 0) or ``do not fail'' (encoded as: 1). The action
+     table, which is now sparse, is looked up only in the latter case. *)
+
+  (* The error bitmap is flattened into a one-dimensional table; its width is
+     recorded so as to allow indexing. The table is then compressed via
+     [PackedIntArray]. The bit width of the resulting packed array must be
+     [1], so it is not explicitly recorded. *)
+
+  (* The error bitmap does not contain a column for the [#] pseudo-terminal.
+     Thus, its width is [Terminal.n - 1]. We exploit the fact that the integer
+     code assigned to [#] is greatest: the fact that the right-most column
+     in the bitmap is missing does not affect the code for accessing it. *)
+
+  val error: int (* width of the bitmap *) * string (* second component of [PackedIntArray.t] *)
+
+  (* A two-dimensional action table maps a state and a terminal to one of
+     ``shift to state s and discard the current token'' (encoded as: s | 10),
+     ``shift to state s without discarding the current token'' (encoded as: s |
+     11), or ``reduce prod'' (encoded as: prod | 01). *)
+
+  (* The action table is first compressed via [RowDisplacement], then packed
+     via [PackedIntArray]. *)
+
+  (* Like the error bitmap, the action table does not contain a column for the
+     [#] pseudo-terminal. *)
+
+  val action: PackedIntArray.t * PackedIntArray.t
+
+  (* A one-dimensional lhs table maps a production to its left-hand side (a
+     non-terminal symbol). *)
+
+  val lhs: PackedIntArray.t
+
+  (* A two-dimensional goto table maps a state and a non-terminal symbol to
+     either undefined (encoded as: 0) or a new state s (encoded as: 1 + s). *)
+
+  (* The goto table is first compressed via [RowDisplacement], then packed
+     via [PackedIntArray]. *)
+
+  val goto: PackedIntArray.t * PackedIntArray.t
+
+  (* The number of start productions. A production [prod] is a start
+     production if and only if [prod < start] holds. This is also the
+     number of start symbols. A nonterminal symbol [nt] is a start
+     symbol if and only if [nt < start] holds. *)
+
+  val start: int
+
+  (* A one-dimensional semantic action table maps productions to semantic
+     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
+
+  (* The parser defines its own [Error] exception. This exception can be
+     raised by semantic actions and caught by the engine, and raised by the
+     engine towards the final user. *)
+
+  exception Error
+
+  (* The parser indicates whether to generate a trace. Generating a
+     trace requires two extra tables, which respectively map a
+     terminal symbol and a production to a string. *)
+
+  val trace: (string array * string array) option
+
+end
+end
+module InspectionTableFormat : sig
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* This signature defines the format of the tables that are produced (in
+   addition to the tables described in [TableFormat]) when the command line
+   switch [--inspection] is enabled. It is used as an argument to
+   [InspectionTableInterpreter.Make]. *)
+
+module type TABLES = sig
+
+  (* The types of symbols. *)
+
+  include IncrementalEngine.SYMBOLS
+
+  (* The type ['a lr1state] describes an LR(1) state. The generated parser defines
+     it internally as [int]. *)
+
+  type 'a lr1state
+
+  (* Some of the tables that follow use encodings of (terminal and
+     nonterminal) symbols as integers. So, we need functions that
+     map the integer encoding of a symbol to its algebraic encoding. *)
+
+  val    terminal: int -> xsymbol
+  val nonterminal: int -> xsymbol
+
+  (* The left-hand side of every production already appears in the
+     signature [TableFormat.TABLES], so we need not repeat it here. *)
+
+  (* The right-hand side of every production. This a linearized array
+     of arrays of integers, whose [data] and [entry] components have
+     been packed. The encoding of symbols as integers in described in
+     [TableBackend]. *)
+
+  val rhs: PackedIntArray.t * PackedIntArray.t
+
+  (* A mapping of every (non-initial) state to its LR(0) core. *)
+
+  val lr0_core: PackedIntArray.t
+
+  (* A mapping of every LR(0) state to its set of LR(0) items. Each item is
+     represented in its packed form (see [Item]) as an integer. Thus the
+     mapping is an array of arrays of integers, which is linearized and
+     packed, like [rhs]. *)
+
+  val lr0_items: PackedIntArray.t * PackedIntArray.t
+
+  (* A mapping of every LR(0) state to its incoming symbol, if it has one. *)
+
+  val lr0_incoming: PackedIntArray.t
+
+  (* A table that tells which non-terminal symbols are nullable. *)
+
+  val nullable: string
+    (* This is a packed int array of bit width 1. It can be read
+       using [PackedIntArray.get1]. *)
+
+  (* A two-table dimensional table, indexed by a nonterminal symbol and
+     by a terminal symbol (other than [#]), encodes the FIRST sets. *)
+
+  val first: int (* width of the bitmap *) * string (* second component of [PackedIntArray.t] *)
+
+end
+
+end
+module InspectionTableInterpreter : sig
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* This functor is invoked inside the generated parser, in [--table] mode. It
+   produces no code! It simply constructs the types [symbol] and [xsymbol] on
+   top of the generated types [terminal] and [nonterminal]. *)
+
+module Symbols (T : sig
+
+  type 'a terminal
+  type 'a nonterminal
+
+end)
+
+: IncrementalEngine.SYMBOLS
+  with type 'a terminal := 'a T.terminal
+   and type 'a nonterminal := 'a T.nonterminal
+
+(* This functor is invoked inside the generated parser, in [--table] mode. It
+   constructs the inspection API on top of the inspection tables described in
+   [InspectionTableFormat]. *)
+
+module Make
+  (TT : TableFormat.TABLES)
+  (IT : InspectionTableFormat.TABLES
+        with type 'a lr1state = int)
+  (ET : EngineTypes.TABLE
+        with type terminal = int
+         and type nonterminal = int
+         and type semantic_value = Obj.t)
+  (E : sig
+     type 'a env = (ET.state, ET.semantic_value, ET.token) EngineTypes.env
+   end)
+
+: IncrementalEngine.INSPECTION
+  with type 'a terminal := 'a IT.terminal
+   and type 'a nonterminal := 'a IT.nonterminal
+   and type 'a lr1state := 'a IT.lr1state
+   and type production := int
+   and type 'a env := 'a E.env
+end
+module TableInterpreter : sig
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU Library General Public License version 2, with a         *)
+(*  special exception on linking, as described in the file LICENSE.           *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* This module provides a thin decoding layer for the generated tables, thus
+   providing an API that is suitable for use by [Engine.Make]. It is part of
+   [MenhirLib]. *)
+
+(* The exception [Error] is declared within the generated parser. This is
+   preferable to pre-declaring it here, as it ensures that each parser gets
+   its own, distinct [Error] exception. This is consistent with the code-based
+   back-end. *)
+
+(* This functor is invoked by the generated parser. *)
+
+module MakeEngineTable
+  (T : TableFormat.TABLES)
+: EngineTypes.TABLE
+    with type state = int
+     and type token = T.token
+     and type semantic_value = Obj.t
+     and type production = int
+     and type terminal = int
+     and type nonterminal = int
+end
+module StaticVersion : sig
+val require_20201216: unit
+end
diff --git a/src/ocaml/preprocess/parser_explain.ml b/src/ocaml/preprocess/parser_explain.ml
new file mode 100644
index 0000000..ef02f70
--- /dev/null
+++ b/src/ocaml/preprocess/parser_explain.ml
@@ -0,0 +1,51 @@
+open Parser_raw
+let named_item_at = function
+  | _ -> raise Not_found
+
+let nullable (type a) : a MenhirInterpreter.nonterminal -> bool =
+  let open MenhirInterpreter in function
+  | N_virtual_flag -> true
+  | N_type_variance -> true
+  | N_type_parameters -> true
+  | N_type_kind -> true
+  | N_structure -> true
+  | N_signature -> true
+  | N_reversed_llist_preceded_CONSTRAINT_constrain__ -> true
+  | N_rec_flag -> true
+  | N_private_virtual_flags -> true
+  | N_private_flag -> true
+  | N_payload -> true
+  | N_option_type_constraint_ -> true
+  | N_option_preceded_EQUAL_seq_expr__ -> true
+  | N_option_preceded_EQUAL_pattern__ -> true
+  | N_option_preceded_EQUAL_module_type__ -> true
+  | N_option_preceded_EQUAL_expr__ -> true
+  | N_option_preceded_COLON_core_type__ -> true
+  | N_option_preceded_AS_mkrhs_LIDENT___ -> true
+  | N_option_SEMI_ -> true
+  | N_option_BAR_ -> true
+  | N_opt_ampersand -> true
+  | N_mutable_virtual_flags -> true
+  | N_mutable_flag -> true
+  | N_list_use_file_element_ -> true
+  | N_list_text_str_structure_item__ -> true
+  | N_list_text_cstr_class_field__ -> true
+  | N_list_text_csig_class_sig_field__ -> true
+  | N_list_structure_element_ -> true
+  | N_list_signature_element_ -> true
+  | N_list_post_item_attribute_ -> true
+  | N_list_generic_and_type_declaration_type_subst_kind__ -> true
+  | N_list_generic_and_type_declaration_type_kind__ -> true
+  | N_list_attribute_ -> true
+  | N_list_and_module_declaration_ -> true
+  | N_list_and_module_binding_ -> true
+  | N_list_and_class_type_declaration_ -> true
+  | N_list_and_class_description_ -> true
+  | N_list_and_class_declaration_ -> true
+  | N_index_mod -> true
+  | N_generalized_constructor_arguments -> true
+  | N_formal_class_parameters -> true
+  | N_ext -> true
+  | N_class_self_type -> true
+  | N_class_self_pattern -> true
+  | _ -> false
diff --git a/src/ocaml/preprocess/parser_printer.ml b/src/ocaml/preprocess/parser_printer.ml
new file mode 100644
index 0000000..390eca1
--- /dev/null
+++ b/src/ocaml/preprocess/parser_printer.ml
@@ -0,0 +1,976 @@
+open Parser_raw
+
+  let string_of_INT = function
+    | (s, None) -> Printf.sprintf "INT(%s)" s
+    | (s, Some c) -> Printf.sprintf "INT(%s%c)" s c
+
+  let string_of_FLOAT = function
+    | (s, None) -> Printf.sprintf "FLOAT(%s)" s
+    | (s, Some c) -> Printf.sprintf "FLOAT(%s%c)" s c
+
+  let string_of_STRING = function
+    | s, _, Some s' -> Printf.sprintf "STRING(%S,%S)" s s'
+    | s, _, None -> Printf.sprintf "STRING(%S)" s
+
+  let string_of_quoted_STRING = function
+    | _, _, s, _, Some s' -> Printf.sprintf "QUOTED_STRING(%S,%S)" s s'
+    | _, _, s, _, None -> Printf.sprintf "QUOTED_STRING(%S)" s
+
+
+let print_symbol = function
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_error) -> "error"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_WITH) -> "with"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_WHILE_LWT) -> "while_lwt"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_WHILE) -> "while"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_WHEN) -> "when"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_VIRTUAL) -> "virtual"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_VAL) -> "val"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_UNDERSCORE) -> "_"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_UIDENT) -> "UIDENT"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_TYPE) -> "type"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_TRY_LWT) -> "try_lwt"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_TRY) -> "try"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_TRUE) -> "true"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_TO) -> "to"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_TILDE) -> "~"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_THEN) -> "then"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_STRUCT) -> "struct"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_STRING) -> "STRING"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_STAR) -> "*"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_SIG) -> "sig"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_SEMISEMI) -> ";;"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_SEMI) -> ";"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_RPAREN) -> ")"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_REC) -> "rec"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_RBRACKET) -> "]"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_RBRACE) -> "}"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_QUOTED_STRING_ITEM) -> "QUOTED_STRING_ITEM"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_QUOTED_STRING_EXPR) -> "QUOTED_STRING_EXPR"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_QUOTE) -> "'"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_QUESTION) -> "?"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_PRIVATE) -> "private"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_PREFIXOP) -> "!+" (* chosen with care; see above *)
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_PLUSEQ) -> "+="
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_PLUSDOT) -> "+."
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_PLUS) -> "+"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_PERCENT) -> "%"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_OR) -> "or"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_OPTLABEL) -> "?<label>"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_OPEN) -> "open"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_OF) -> "of"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_OBJECT) -> "object"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_NONREC) -> "nonrec"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_NEW) -> "new"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_MUTABLE) -> "mutable"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_MODULE) -> "module"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_MINUSGREATER) -> "->"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_MINUSDOT) -> "-."
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_MINUS) -> "-"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_METHOD) -> "method"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_MATCH_LWT) -> "match_lwt"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_MATCH) -> "match"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_LPAREN) -> ")"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_LIDENT) -> "LIDENT"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_LET_LWT) -> "lwt"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_LETOP) -> "LETOP"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_LET) -> "let"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_LESSMINUS) -> "<-"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_LESS) -> "<"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_LBRACKETPERCENTPERCENT) -> "[%%"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_LBRACKETPERCENT) -> "[%"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_LBRACKETLESS) -> "[<"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_LBRACKETGREATER) -> "[>"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_LBRACKETBAR) -> "[|"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_LBRACKETATATAT) -> "[@@@"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_LBRACKETATAT) -> "[@@"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_LBRACKETAT) -> "[@"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_LBRACKET) -> "["
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_LBRACELESS) -> "{<"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_LBRACE) -> "{"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_LAZY) -> "lazy"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_LABEL) -> "label"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_INT) -> "INT"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_INITIALIZER) -> "initializer"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_INHERIT) -> "inherit"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_INFIXOP4) -> "INFIXOP4"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_INFIXOP3) -> "INFIXOP3"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_INFIXOP2) -> "INFIXOP2"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_INFIXOP1) -> "INFIXOP1"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_INFIXOP0) -> "INFIXOP0"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_INCLUDE) -> "include"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_IN) -> "in"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_IF) -> "if"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_HASHOP) -> "#<op>"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_HASH) -> "#"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_GREATERRBRACKET) -> ">]"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_GREATERRBRACE) -> ">}"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_GREATERDOT) -> ">."
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_GREATER) -> ">"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_FUNCTOR) -> "functor"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_FUNCTION) -> "function"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_FUN) -> "fun"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_FOR_LWT) -> "for_lwt"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_FOR) -> "for"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_FLOAT) -> "FLOAT"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_FINALLY_LWT) -> "finally"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_FALSE) -> "false"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_EXTERNAL) -> "external"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_EXCEPTION) -> "exception"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_EQUAL) -> "="
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_EOL) -> "EOL"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_EOF) -> "EOF"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_END) -> "end"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_ELSE) -> "else"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_DOWNTO) -> "downto"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_DOTTILDE) -> ".~"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_DOTOP) -> "DOTOP"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_DOTLESS) -> ".<"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_DOTDOT) -> ".."
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_DOT) -> "."
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_DONE) -> "done"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_DOCSTRING) -> "DOCSTRING"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_DO) -> "do"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_CONSTRAINT) -> "constraint"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_COMMENT) -> "COMMENT"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_COMMA) -> ","
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_COLONGREATER) -> ":>"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_COLONEQUAL) -> ":="
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_COLONCOLON) -> "::"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_COLON) -> ":"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_CLASS) -> "class"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_CHAR) -> "CHAR"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_BEGIN) -> "begin"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_BARRBRACKET) -> "|]"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_BARBAR) -> "||"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_BAR) -> "|"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_BANG) -> "!"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_BACKQUOTE) -> "`"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_ASSERT) -> "assert"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_AS) -> "as"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_ANDOP) -> "ANDOP"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_AND) -> "and"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_AMPERSAND) -> "&"
+  | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_AMPERAMPER) -> "&&"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_with_type_binder) -> "with_type_binder"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_with_constraint) -> "with_constraint"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_virtual_with_private_flag) -> "virtual_with_private_flag"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_virtual_with_mutable_flag) -> "virtual_with_mutable_flag"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_virtual_flag) -> "virtual_flag"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_value_description) -> "value_description"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_value) -> "value"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_val_longident) -> "val_longident"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_val_ident) -> "val_ident"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_val_extra_ident) -> "val_extra_ident"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_use_file) -> "use_file"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_type_variance) -> "type_variance"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_type_variable) -> "type_variable"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_type_parameters) -> "type_parameters"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_type_parameter) -> "type_parameter"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_type_longident) -> "type_longident"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_type_kind) -> "type_kind"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_type_constraint) -> "type_constraint"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_tuple_type) -> "tuple_type"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_toplevel_phrase) -> "toplevel_phrase"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_toplevel_directive) -> "toplevel_directive"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_tag_field) -> "tag_field"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_subtractive) -> "subtractive"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_structure_item) -> "structure_item"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_structure) -> "structure"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_strict_binding) -> "strict_binding"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_str_exception_declaration) -> "str_exception_declaration"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_single_attr_id) -> "single_attr_id"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_simple_pattern_not_ident) -> "simple_pattern_not_ident"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_simple_pattern) -> "simple_pattern"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_simple_expr) -> "simple_expr"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_simple_delimited_pattern) -> "simple_delimited_pattern"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_signed_constant) -> "signed_constant"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_signature_item) -> "signature_item"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_signature) -> "signature"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_sig_exception_declaration) -> "sig_exception_declaration"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_seq_expr) -> "seq_expr"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_separated_or_terminated_nonempty_list_SEMI_record_expr_field_) -> "separated_or_terminated_nonempty_list_SEMI_record_expr_field_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_separated_or_terminated_nonempty_list_SEMI_pattern_) -> "separated_or_terminated_nonempty_list_SEMI_pattern_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_separated_or_terminated_nonempty_list_SEMI_object_expr_field_) -> "separated_or_terminated_nonempty_list_SEMI_object_expr_field_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_separated_or_terminated_nonempty_list_SEMI_expr_) -> "separated_or_terminated_nonempty_list_SEMI_expr_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_row_field) -> "row_field"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nontrivial_llist_STAR_atomic_type_) -> "reversed_separated_nontrivial_llist_STAR_atomic_type_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nontrivial_llist_COMMA_expr_) -> "reversed_separated_nontrivial_llist_COMMA_expr_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nontrivial_llist_COMMA_core_type_) -> "reversed_separated_nontrivial_llist_COMMA_core_type_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nonempty_llist_STAR_atomic_type_) -> "reversed_separated_nonempty_llist_STAR_atomic_type_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nonempty_llist_COMMA_type_parameter_) -> "reversed_separated_nonempty_llist_COMMA_type_parameter_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nonempty_llist_COMMA_core_type_) -> "reversed_separated_nonempty_llist_COMMA_core_type_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nonempty_llist_BAR_row_field_) -> "reversed_separated_nonempty_llist_BAR_row_field_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nonempty_llist_AND_with_constraint_) -> "reversed_separated_nonempty_llist_AND_with_constraint_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nonempty_llist_AMPERSAND_core_type_no_attr_) -> "reversed_separated_nonempty_llist_AMPERSAND_core_type_no_attr_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_reversed_preceded_or_separated_nonempty_llist_BAR_match_case_) -> "reversed_preceded_or_separated_nonempty_llist_BAR_match_case_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_reversed_nonempty_llist_typevar_) -> "reversed_nonempty_llist_typevar_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_reversed_nonempty_llist_name_tag_) -> "reversed_nonempty_llist_name_tag_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_reversed_nonempty_llist_labeled_simple_expr_) -> "reversed_nonempty_llist_labeled_simple_expr_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_reversed_nonempty_llist_functor_arg_) -> "reversed_nonempty_llist_functor_arg_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_reversed_llist_preceded_CONSTRAINT_constrain__) -> "reversed_llist_preceded_CONSTRAINT_constrain__"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_reversed_bar_llist_extension_constructor_declaration_) -> "reversed_bar_llist_extension_constructor_declaration_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_reversed_bar_llist_extension_constructor_) -> "reversed_bar_llist_extension_constructor_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_reversed_bar_llist_constructor_declaration_) -> "reversed_bar_llist_constructor_declaration_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_record_expr_content) -> "record_expr_content"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_rec_flag) -> "rec_flag"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_private_virtual_flags) -> "private_virtual_flags"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_private_flag) -> "private_flag"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_primitive_declaration) -> "primitive_declaration"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_post_item_attribute) -> "post_item_attribute"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_possibly_poly_core_type_no_attr_) -> "possibly_poly_core_type_no_attr_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_possibly_poly_core_type_) -> "possibly_poly_core_type_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_payload) -> "payload"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_pattern_var) -> "pattern_var"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_pattern_no_exn) -> "pattern_no_exn"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_pattern_gen) -> "pattern_gen"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_pattern_comma_list_pattern_no_exn_) -> "pattern_comma_list_pattern_no_exn_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_pattern_comma_list_pattern_) -> "pattern_comma_list_pattern_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_pattern) -> "pattern"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_parse_val_longident) -> "parse_val_longident"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_parse_pattern) -> "parse_pattern"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_parse_mty_longident) -> "parse_mty_longident"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_parse_mod_longident) -> "parse_mod_longident"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_parse_mod_ext_longident) -> "parse_mod_ext_longident"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_parse_expression) -> "parse_expression"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_parse_core_type) -> "parse_core_type"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_parse_constr_longident) -> "parse_constr_longident"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_parse_any_longident) -> "parse_any_longident"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_paren_module_expr) -> "paren_module_expr"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_optlabel) -> "optlabel"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_option_type_constraint_) -> "option_type_constraint_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_option_preceded_EQUAL_seq_expr__) -> "option_preceded_EQUAL_seq_expr__"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_option_preceded_EQUAL_pattern__) -> "option_preceded_EQUAL_pattern__"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_option_preceded_EQUAL_module_type__) -> "option_preceded_EQUAL_module_type__"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_option_preceded_EQUAL_expr__) -> "option_preceded_EQUAL_expr__"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_option_preceded_COLON_core_type__) -> "option_preceded_COLON_core_type__"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_option_preceded_AS_mkrhs_LIDENT___) -> "option_preceded_AS_mkrhs_LIDENT___"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_option_SEMI_) -> "option_SEMI_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_option_BAR_) -> "option_BAR_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_opt_ampersand) -> "opt_ampersand"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_operator) -> "operator"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_open_description) -> "open_description"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_open_declaration) -> "open_declaration"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_nonempty_type_kind) -> "nonempty_type_kind"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_nonempty_list_raw_string_) -> "nonempty_list_raw_string_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_nonempty_list_mkrhs_LIDENT__) -> "nonempty_list_mkrhs_LIDENT__"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_name_tag) -> "name_tag"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_mutable_virtual_flags) -> "mutable_virtual_flags"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_mutable_flag) -> "mutable_flag"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_mty_longident) -> "mty_longident"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_module_type_subst) -> "module_type_subst"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_module_type_declaration) -> "module_type_declaration"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_module_type) -> "module_type"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_module_subst) -> "module_subst"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_module_name) -> "module_name"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_module_expr) -> "module_expr"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_module_declaration_body) -> "module_declaration_body"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_module_binding_body) -> "module_binding_body"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_mod_longident) -> "mod_longident"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_mod_ext_longident) -> "mod_ext_longident"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_mk_longident_mod_longident_val_ident_) -> "mk_longident_mod_longident_val_ident_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_mk_longident_mod_longident_UIDENT_) -> "mk_longident_mod_longident_UIDENT_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_mk_longident_mod_longident_LIDENT_) -> "mk_longident_mod_longident_LIDENT_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_mk_longident_mod_ext_longident_ident_) -> "mk_longident_mod_ext_longident_ident_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_mk_longident_mod_ext_longident___anonymous_41_) -> "mk_longident_mod_ext_longident___anonymous_41_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_mk_longident_mod_ext_longident_UIDENT_) -> "mk_longident_mod_ext_longident_UIDENT_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_mk_longident_mod_ext_longident_LIDENT_) -> "mk_longident_mod_ext_longident_LIDENT_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_method_) -> "method_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_meth_list) -> "meth_list"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_match_case) -> "match_case"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_lwt_bindings) -> "lwt_bindings"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_lwt_binding) -> "lwt_binding"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_listx_SEMI_record_pat_field_UNDERSCORE_) -> "listx_SEMI_record_pat_field_UNDERSCORE_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_list_use_file_element_) -> "list_use_file_element_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_list_text_str_structure_item__) -> "list_text_str_structure_item__"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_list_text_cstr_class_field__) -> "list_text_cstr_class_field__"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_list_text_csig_class_sig_field__) -> "list_text_csig_class_sig_field__"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_list_structure_element_) -> "list_structure_element_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_list_signature_element_) -> "list_signature_element_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_list_post_item_attribute_) -> "list_post_item_attribute_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_list_generic_and_type_declaration_type_subst_kind__) -> "list_generic_and_type_declaration_type_subst_kind__"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_list_generic_and_type_declaration_type_kind__) -> "list_generic_and_type_declaration_type_kind__"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_list_attribute_) -> "list_attribute_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_list_and_module_declaration_) -> "list_and_module_declaration_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_list_and_module_binding_) -> "list_and_module_binding_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_list_and_class_type_declaration_) -> "list_and_class_type_declaration_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_list_and_class_description_) -> "list_and_class_description_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_list_and_class_declaration_) -> "list_and_class_declaration_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_letop_bindings) -> "letop_bindings"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_letop_binding_body) -> "letop_binding_body"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_let_pattern) -> "let_pattern"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_let_bindings_no_ext_) -> "let_bindings_no_ext_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_let_bindings_ext_) -> "let_bindings_ext_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_let_binding_body_no_punning) -> "let_binding_body_no_punning"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_let_binding_body) -> "let_binding_body"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_labeled_simple_pattern) -> "labeled_simple_pattern"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_labeled_simple_expr) -> "labeled_simple_expr"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_label_longident) -> "label_longident"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_label_let_pattern) -> "label_let_pattern"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_label_declarations) -> "label_declarations"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_label_declaration_semi) -> "label_declaration_semi"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_label_declaration) -> "label_declaration"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_item_extension) -> "item_extension"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_interface) -> "interface"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_index_mod) -> "index_mod"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_implementation) -> "implementation"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_ident) -> "ident"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_generic_type_declaration_nonrec_flag_type_kind_) -> "generic_type_declaration_nonrec_flag_type_kind_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_generic_type_declaration_no_nonrec_flag_type_subst_kind_) -> "generic_type_declaration_no_nonrec_flag_type_subst_kind_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_generic_constructor_declaration_epsilon_) -> "generic_constructor_declaration_epsilon_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_generic_constructor_declaration_BAR_) -> "generic_constructor_declaration_BAR_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_generalized_constructor_arguments) -> "generalized_constructor_arguments"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_functor_args) -> "functor_args"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_functor_arg) -> "functor_arg"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_function_type) -> "function_type"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_fun_def) -> "fun_def"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_fun_binding) -> "fun_binding"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_formal_class_parameters) -> "formal_class_parameters"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_floating_attribute) -> "floating_attribute"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_extension_constructor_rebind_epsilon_) -> "extension_constructor_rebind_epsilon_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_extension_constructor_rebind_BAR_) -> "extension_constructor_rebind_BAR_"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_extension) -> "extension"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_ext) -> "ext"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_expr) -> "expr"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_direction_flag) -> "direction_flag"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_core_type) -> "core_type"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_constructor_declarations) -> "constructor_declarations"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_constructor_arguments) -> "constructor_arguments"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_constrain_field) -> "constrain_field"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_constr_longident) -> "constr_longident"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_constr_ident) -> "constr_ident"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_constr_extra_nonprefix_ident) -> "constr_extra_nonprefix_ident"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_constant) -> "constant"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_clty_longident) -> "clty_longident"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_class_type_declarations) -> "class_type_declarations"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_class_type) -> "class_type"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_class_simple_expr) -> "class_simple_expr"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_class_signature) -> "class_signature"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_class_sig_field) -> "class_sig_field"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_class_self_type) -> "class_self_type"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_class_self_pattern) -> "class_self_pattern"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_class_longident) -> "class_longident"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_class_fun_def) -> "class_fun_def"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_class_fun_binding) -> "class_fun_binding"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_class_field) -> "class_field"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_class_expr) -> "class_expr"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_attribute) -> "attribute"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_attr_id) -> "attr_id"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_atomic_type) -> "atomic_type"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_any_longident) -> "any_longident"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_and_let_binding) -> "and_let_binding"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_alias_type) -> "alias_type"
+  | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_additive) -> "additive"
+
+let print_value (type a) : a MenhirInterpreter.symbol -> a -> string = function
+  | MenhirInterpreter.T MenhirInterpreter.T_error -> (fun _ -> "error")
+  | MenhirInterpreter.T MenhirInterpreter.T_WITH -> (fun _ -> "with")
+  | MenhirInterpreter.T MenhirInterpreter.T_WHILE_LWT -> (fun _ -> "while_lwt")
+  | MenhirInterpreter.T MenhirInterpreter.T_WHILE -> (fun _ -> "while")
+  | MenhirInterpreter.T MenhirInterpreter.T_WHEN -> (fun _ -> "when")
+  | MenhirInterpreter.T MenhirInterpreter.T_VIRTUAL -> (fun _ -> "virtual")
+  | MenhirInterpreter.T MenhirInterpreter.T_VAL -> (fun _ -> "val")
+  | MenhirInterpreter.T MenhirInterpreter.T_UNDERSCORE -> (fun _ -> "_")
+  | MenhirInterpreter.T MenhirInterpreter.T_UIDENT -> (Printf.sprintf "UIDENT(%S)")
+  | MenhirInterpreter.T MenhirInterpreter.T_TYPE -> (fun _ -> "type")
+  | MenhirInterpreter.T MenhirInterpreter.T_TRY_LWT -> (fun _ -> "try_lwt")
+  | MenhirInterpreter.T MenhirInterpreter.T_TRY -> (fun _ -> "try")
+  | MenhirInterpreter.T MenhirInterpreter.T_TRUE -> (fun _ -> "true")
+  | MenhirInterpreter.T MenhirInterpreter.T_TO -> (fun _ -> "to")
+  | MenhirInterpreter.T MenhirInterpreter.T_TILDE -> (fun _ -> "~")
+  | MenhirInterpreter.T MenhirInterpreter.T_THEN -> (fun _ -> "then")
+  | MenhirInterpreter.T MenhirInterpreter.T_STRUCT -> (fun _ -> "struct")
+  | MenhirInterpreter.T MenhirInterpreter.T_STRING -> (string_of_STRING)
+  | MenhirInterpreter.T MenhirInterpreter.T_STAR -> (fun _ -> "*")
+  | MenhirInterpreter.T MenhirInterpreter.T_SIG -> (fun _ -> "sig")
+  | MenhirInterpreter.T MenhirInterpreter.T_SEMISEMI -> (fun _ -> ";;")
+  | MenhirInterpreter.T MenhirInterpreter.T_SEMI -> (fun _ -> ";")
+  | MenhirInterpreter.T MenhirInterpreter.T_RPAREN -> (fun _ -> ")")
+  | MenhirInterpreter.T MenhirInterpreter.T_REC -> (fun _ -> "rec")
+  | MenhirInterpreter.T MenhirInterpreter.T_RBRACKET -> (fun _ -> "]")
+  | MenhirInterpreter.T MenhirInterpreter.T_RBRACE -> (fun _ -> "}")
+  | MenhirInterpreter.T MenhirInterpreter.T_QUOTED_STRING_ITEM -> (string_of_quoted_STRING)
+  | MenhirInterpreter.T MenhirInterpreter.T_QUOTED_STRING_EXPR -> (string_of_quoted_STRING)
+  | MenhirInterpreter.T MenhirInterpreter.T_QUOTE -> (fun _ -> "'")
+  | MenhirInterpreter.T MenhirInterpreter.T_QUESTION -> (fun _ -> "?")
+  | MenhirInterpreter.T MenhirInterpreter.T_PRIVATE -> (fun _ -> "private")
+  | MenhirInterpreter.T MenhirInterpreter.T_PREFIXOP -> (Printf.sprintf "PREFIXOP(%S)")
+  | MenhirInterpreter.T MenhirInterpreter.T_PLUSEQ -> (fun _ -> "+=")
+  | MenhirInterpreter.T MenhirInterpreter.T_PLUSDOT -> (fun _ -> "+.")
+  | MenhirInterpreter.T MenhirInterpreter.T_PLUS -> (fun _ -> "+")
+  | MenhirInterpreter.T MenhirInterpreter.T_PERCENT -> (fun _ -> "%")
+  | MenhirInterpreter.T MenhirInterpreter.T_OR -> (fun _ -> "or")
+  | MenhirInterpreter.T MenhirInterpreter.T_OPTLABEL -> (Printf.sprintf "OPTLABEL(%S)")
+  | MenhirInterpreter.T MenhirInterpreter.T_OPEN -> (fun _ -> "open")
+  | MenhirInterpreter.T MenhirInterpreter.T_OF -> (fun _ -> "of")
+  | MenhirInterpreter.T MenhirInterpreter.T_OBJECT -> (fun _ -> "object")
+  | MenhirInterpreter.T MenhirInterpreter.T_NONREC -> (fun _ -> "nonrec")
+  | MenhirInterpreter.T MenhirInterpreter.T_NEW -> (fun _ -> "new")
+  | MenhirInterpreter.T MenhirInterpreter.T_MUTABLE -> (fun _ -> "mutable")
+  | MenhirInterpreter.T MenhirInterpreter.T_MODULE -> (fun _ -> "module")
+  | MenhirInterpreter.T MenhirInterpreter.T_MINUSGREATER -> (fun _ -> "->")
+  | MenhirInterpreter.T MenhirInterpreter.T_MINUSDOT -> (fun _ -> "-.")
+  | MenhirInterpreter.T MenhirInterpreter.T_MINUS -> (fun _ -> "-")
+  | MenhirInterpreter.T MenhirInterpreter.T_METHOD -> (fun _ -> "method")
+  | MenhirInterpreter.T MenhirInterpreter.T_MATCH_LWT -> (fun _ -> "match_lwt")
+  | MenhirInterpreter.T MenhirInterpreter.T_MATCH -> (fun _ -> "match")
+  | MenhirInterpreter.T MenhirInterpreter.T_LPAREN -> (fun _ -> ")")
+  | MenhirInterpreter.T MenhirInterpreter.T_LIDENT -> (Printf.sprintf "LIDENT(%S)")
+  | MenhirInterpreter.T MenhirInterpreter.T_LET_LWT -> (fun _ -> "lwt")
+  | MenhirInterpreter.T MenhirInterpreter.T_LETOP -> (fun _ -> "LETOP")
+  | MenhirInterpreter.T MenhirInterpreter.T_LET -> (fun _ -> "let")
+  | MenhirInterpreter.T MenhirInterpreter.T_LESSMINUS -> (fun _ -> "<-")
+  | MenhirInterpreter.T MenhirInterpreter.T_LESS -> (fun _ -> "<")
+  | MenhirInterpreter.T MenhirInterpreter.T_LBRACKETPERCENTPERCENT -> (fun _ -> "[%%")
+  | MenhirInterpreter.T MenhirInterpreter.T_LBRACKETPERCENT -> (fun _ -> "[%")
+  | MenhirInterpreter.T MenhirInterpreter.T_LBRACKETLESS -> (fun _ -> "[<")
+  | MenhirInterpreter.T MenhirInterpreter.T_LBRACKETGREATER -> (fun _ -> "[>")
+  | MenhirInterpreter.T MenhirInterpreter.T_LBRACKETBAR -> (fun _ -> "[|")
+  | MenhirInterpreter.T MenhirInterpreter.T_LBRACKETATATAT -> (fun _ -> "[@@@")
+  | MenhirInterpreter.T MenhirInterpreter.T_LBRACKETATAT -> (fun _ -> "[@@")
+  | MenhirInterpreter.T MenhirInterpreter.T_LBRACKETAT -> (fun _ -> "[@")
+  | MenhirInterpreter.T MenhirInterpreter.T_LBRACKET -> (fun _ -> "[")
+  | MenhirInterpreter.T MenhirInterpreter.T_LBRACELESS -> (fun _ -> "{<")
+  | MenhirInterpreter.T MenhirInterpreter.T_LBRACE -> (fun _ -> "{")
+  | MenhirInterpreter.T MenhirInterpreter.T_LAZY -> (fun _ -> "lazy")
+  | MenhirInterpreter.T MenhirInterpreter.T_LABEL -> (Printf.sprintf "LABEL(%S)")
+  | MenhirInterpreter.T MenhirInterpreter.T_INT -> (string_of_INT)
+  | MenhirInterpreter.T MenhirInterpreter.T_INITIALIZER -> (fun _ -> "initializer")
+  | MenhirInterpreter.T MenhirInterpreter.T_INHERIT -> (fun _ -> "inherit")
+  | MenhirInterpreter.T MenhirInterpreter.T_INFIXOP4 -> (Printf.sprintf "INFIXOP4(%S)")
+  | MenhirInterpreter.T MenhirInterpreter.T_INFIXOP3 -> (Printf.sprintf "INFIXOP3(%S)")
+  | MenhirInterpreter.T MenhirInterpreter.T_INFIXOP2 -> (Printf.sprintf "INFIXOP2(%S)")
+  | MenhirInterpreter.T MenhirInterpreter.T_INFIXOP1 -> (Printf.sprintf "INFIXOP1(%S)")
+  | MenhirInterpreter.T MenhirInterpreter.T_INFIXOP0 -> (Printf.sprintf "INFIXOP0(%S)")
+  | MenhirInterpreter.T MenhirInterpreter.T_INCLUDE -> (fun _ -> "include")
+  | MenhirInterpreter.T MenhirInterpreter.T_IN -> (fun _ -> "in")
+  | MenhirInterpreter.T MenhirInterpreter.T_IF -> (fun _ -> "if")
+  | MenhirInterpreter.T MenhirInterpreter.T_HASHOP -> (Printf.sprintf "HASHOP(%S)")
+  | MenhirInterpreter.T MenhirInterpreter.T_HASH -> (fun _ -> "#")
+  | MenhirInterpreter.T MenhirInterpreter.T_GREATERRBRACKET -> (fun _ -> ">]")
+  | MenhirInterpreter.T MenhirInterpreter.T_GREATERRBRACE -> (fun _ -> ">}")
+  | MenhirInterpreter.T MenhirInterpreter.T_GREATERDOT -> (fun _ -> ">.")
+  | MenhirInterpreter.T MenhirInterpreter.T_GREATER -> (fun _ -> ">")
+  | MenhirInterpreter.T MenhirInterpreter.T_FUNCTOR -> (fun _ -> "functor")
+  | MenhirInterpreter.T MenhirInterpreter.T_FUNCTION -> (fun _ -> "function")
+  | MenhirInterpreter.T MenhirInterpreter.T_FUN -> (fun _ -> "fun")
+  | MenhirInterpreter.T MenhirInterpreter.T_FOR_LWT -> (fun _ -> "for_lwt")
+  | MenhirInterpreter.T MenhirInterpreter.T_FOR -> (fun _ -> "for")
+  | MenhirInterpreter.T MenhirInterpreter.T_FLOAT -> (string_of_FLOAT)
+  | MenhirInterpreter.T MenhirInterpreter.T_FINALLY_LWT -> (fun _ -> "finally")
+  | MenhirInterpreter.T MenhirInterpreter.T_FALSE -> (fun _ -> "false")
+  | MenhirInterpreter.T MenhirInterpreter.T_EXTERNAL -> (fun _ -> "external")
+  | MenhirInterpreter.T MenhirInterpreter.T_EXCEPTION -> (fun _ -> "exception")
+  | MenhirInterpreter.T MenhirInterpreter.T_EQUAL -> (fun _ -> "=")
+  | MenhirInterpreter.T MenhirInterpreter.T_EOL -> (fun _ -> "EOL")
+  | MenhirInterpreter.T MenhirInterpreter.T_EOF -> (fun _ -> "EOF")
+  | MenhirInterpreter.T MenhirInterpreter.T_END -> (fun _ -> "end")
+  | MenhirInterpreter.T MenhirInterpreter.T_ELSE -> (fun _ -> "else")
+  | MenhirInterpreter.T MenhirInterpreter.T_DOWNTO -> (fun _ -> "downto")
+  | MenhirInterpreter.T MenhirInterpreter.T_DOTTILDE -> (fun _ -> ".~")
+  | MenhirInterpreter.T MenhirInterpreter.T_DOTOP -> (fun _ -> "DOTOP")
+  | MenhirInterpreter.T MenhirInterpreter.T_DOTLESS -> (fun _ -> ".<")
+  | MenhirInterpreter.T MenhirInterpreter.T_DOTDOT -> (fun _ -> "..")
+  | MenhirInterpreter.T MenhirInterpreter.T_DOT -> (fun _ -> ".")
+  | MenhirInterpreter.T MenhirInterpreter.T_DONE -> (fun _ -> "done")
+  | MenhirInterpreter.T MenhirInterpreter.T_DOCSTRING -> (fun _ -> "DOCSTRING")
+  | MenhirInterpreter.T MenhirInterpreter.T_DO -> (fun _ -> "do")
+  | MenhirInterpreter.T MenhirInterpreter.T_CONSTRAINT -> (fun _ -> "constraint")
+  | MenhirInterpreter.T MenhirInterpreter.T_COMMENT -> (fun _ -> "COMMENT")
+  | MenhirInterpreter.T MenhirInterpreter.T_COMMA -> (fun _ -> ",")
+  | MenhirInterpreter.T MenhirInterpreter.T_COLONGREATER -> (fun _ -> ":>")
+  | MenhirInterpreter.T MenhirInterpreter.T_COLONEQUAL -> (fun _ -> ":=")
+  | MenhirInterpreter.T MenhirInterpreter.T_COLONCOLON -> (fun _ -> "::")
+  | MenhirInterpreter.T MenhirInterpreter.T_COLON -> (fun _ -> ":")
+  | MenhirInterpreter.T MenhirInterpreter.T_CLASS -> (fun _ -> "class")
+  | MenhirInterpreter.T MenhirInterpreter.T_CHAR -> (fun _ -> "CHAR")
+  | MenhirInterpreter.T MenhirInterpreter.T_BEGIN -> (fun _ -> "begin")
+  | MenhirInterpreter.T MenhirInterpreter.T_BARRBRACKET -> (fun _ -> "|]")
+  | MenhirInterpreter.T MenhirInterpreter.T_BARBAR -> (fun _ -> "||")
+  | MenhirInterpreter.T MenhirInterpreter.T_BAR -> (fun _ -> "|")
+  | MenhirInterpreter.T MenhirInterpreter.T_BANG -> (fun _ -> "!")
+  | MenhirInterpreter.T MenhirInterpreter.T_BACKQUOTE -> (fun _ -> "`")
+  | MenhirInterpreter.T MenhirInterpreter.T_ASSERT -> (fun _ -> "assert")
+  | MenhirInterpreter.T MenhirInterpreter.T_AS -> (fun _ -> "as")
+  | MenhirInterpreter.T MenhirInterpreter.T_ANDOP -> (fun _ -> "ANDOP")
+  | MenhirInterpreter.T MenhirInterpreter.T_AND -> (fun _ -> "and")
+  | MenhirInterpreter.T MenhirInterpreter.T_AMPERSAND -> (fun _ -> "&")
+  | MenhirInterpreter.T MenhirInterpreter.T_AMPERAMPER -> (fun _ -> "&&")
+  | MenhirInterpreter.N MenhirInterpreter.N_with_type_binder -> (fun _ -> "with_type_binder")
+  | MenhirInterpreter.N MenhirInterpreter.N_with_constraint -> (fun _ -> "with_constraint")
+  | MenhirInterpreter.N MenhirInterpreter.N_virtual_with_private_flag -> (fun _ -> "virtual_with_private_flag")
+  | MenhirInterpreter.N MenhirInterpreter.N_virtual_with_mutable_flag -> (fun _ -> "virtual_with_mutable_flag")
+  | MenhirInterpreter.N MenhirInterpreter.N_virtual_flag -> (fun _ -> "virtual_flag")
+  | MenhirInterpreter.N MenhirInterpreter.N_value_description -> (fun _ -> "value_description")
+  | MenhirInterpreter.N MenhirInterpreter.N_value -> (fun _ -> "value")
+  | MenhirInterpreter.N MenhirInterpreter.N_val_longident -> (fun _ -> "val_longident")
+  | MenhirInterpreter.N MenhirInterpreter.N_val_ident -> (fun _ -> "val_ident")
+  | MenhirInterpreter.N MenhirInterpreter.N_val_extra_ident -> (fun _ -> "val_extra_ident")
+  | MenhirInterpreter.N MenhirInterpreter.N_use_file -> (fun _ -> "use_file")
+  | MenhirInterpreter.N MenhirInterpreter.N_type_variance -> (fun _ -> "type_variance")
+  | MenhirInterpreter.N MenhirInterpreter.N_type_variable -> (fun _ -> "type_variable")
+  | MenhirInterpreter.N MenhirInterpreter.N_type_parameters -> (fun _ -> "type_parameters")
+  | MenhirInterpreter.N MenhirInterpreter.N_type_parameter -> (fun _ -> "type_parameter")
+  | MenhirInterpreter.N MenhirInterpreter.N_type_longident -> (fun _ -> "type_longident")
+  | MenhirInterpreter.N MenhirInterpreter.N_type_kind -> (fun _ -> "type_kind")
+  | MenhirInterpreter.N MenhirInterpreter.N_type_constraint -> (fun _ -> "type_constraint")
+  | MenhirInterpreter.N MenhirInterpreter.N_tuple_type -> (fun _ -> "tuple_type")
+  | MenhirInterpreter.N MenhirInterpreter.N_toplevel_phrase -> (fun _ -> "toplevel_phrase")
+  | MenhirInterpreter.N MenhirInterpreter.N_toplevel_directive -> (fun _ -> "toplevel_directive")
+  | MenhirInterpreter.N MenhirInterpreter.N_tag_field -> (fun _ -> "tag_field")
+  | MenhirInterpreter.N MenhirInterpreter.N_subtractive -> (fun _ -> "subtractive")
+  | MenhirInterpreter.N MenhirInterpreter.N_structure_item -> (fun _ -> "structure_item")
+  | MenhirInterpreter.N MenhirInterpreter.N_structure -> (fun _ -> "structure")
+  | MenhirInterpreter.N MenhirInterpreter.N_strict_binding -> (fun _ -> "strict_binding")
+  | MenhirInterpreter.N MenhirInterpreter.N_str_exception_declaration -> (fun _ -> "str_exception_declaration")
+  | MenhirInterpreter.N MenhirInterpreter.N_single_attr_id -> (fun _ -> "single_attr_id")
+  | MenhirInterpreter.N MenhirInterpreter.N_simple_pattern_not_ident -> (fun _ -> "simple_pattern_not_ident")
+  | MenhirInterpreter.N MenhirInterpreter.N_simple_pattern -> (fun _ -> "simple_pattern")
+  | MenhirInterpreter.N MenhirInterpreter.N_simple_expr -> (fun _ -> "simple_expr")
+  | MenhirInterpreter.N MenhirInterpreter.N_simple_delimited_pattern -> (fun _ -> "simple_delimited_pattern")
+  | MenhirInterpreter.N MenhirInterpreter.N_signed_constant -> (fun _ -> "signed_constant")
+  | MenhirInterpreter.N MenhirInterpreter.N_signature_item -> (fun _ -> "signature_item")
+  | MenhirInterpreter.N MenhirInterpreter.N_signature -> (fun _ -> "signature")
+  | MenhirInterpreter.N MenhirInterpreter.N_sig_exception_declaration -> (fun _ -> "sig_exception_declaration")
+  | MenhirInterpreter.N MenhirInterpreter.N_seq_expr -> (fun _ -> "seq_expr")
+  | MenhirInterpreter.N MenhirInterpreter.N_separated_or_terminated_nonempty_list_SEMI_record_expr_field_ -> (fun _ -> "separated_or_terminated_nonempty_list_SEMI_record_expr_field_")
+  | MenhirInterpreter.N MenhirInterpreter.N_separated_or_terminated_nonempty_list_SEMI_pattern_ -> (fun _ -> "separated_or_terminated_nonempty_list_SEMI_pattern_")
+  | MenhirInterpreter.N MenhirInterpreter.N_separated_or_terminated_nonempty_list_SEMI_object_expr_field_ -> (fun _ -> "separated_or_terminated_nonempty_list_SEMI_object_expr_field_")
+  | MenhirInterpreter.N MenhirInterpreter.N_separated_or_terminated_nonempty_list_SEMI_expr_ -> (fun _ -> "separated_or_terminated_nonempty_list_SEMI_expr_")
+  | MenhirInterpreter.N MenhirInterpreter.N_row_field -> (fun _ -> "row_field")
+  | MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nontrivial_llist_STAR_atomic_type_ -> (fun _ -> "reversed_separated_nontrivial_llist_STAR_atomic_type_")
+  | MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nontrivial_llist_COMMA_expr_ -> (fun _ -> "reversed_separated_nontrivial_llist_COMMA_expr_")
+  | MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nontrivial_llist_COMMA_core_type_ -> (fun _ -> "reversed_separated_nontrivial_llist_COMMA_core_type_")
+  | MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nonempty_llist_STAR_atomic_type_ -> (fun _ -> "reversed_separated_nonempty_llist_STAR_atomic_type_")
+  | MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nonempty_llist_COMMA_type_parameter_ -> (fun _ -> "reversed_separated_nonempty_llist_COMMA_type_parameter_")
+  | MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nonempty_llist_COMMA_core_type_ -> (fun _ -> "reversed_separated_nonempty_llist_COMMA_core_type_")
+  | MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nonempty_llist_BAR_row_field_ -> (fun _ -> "reversed_separated_nonempty_llist_BAR_row_field_")
+  | MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nonempty_llist_AND_with_constraint_ -> (fun _ -> "reversed_separated_nonempty_llist_AND_with_constraint_")
+  | MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nonempty_llist_AMPERSAND_core_type_no_attr_ -> (fun _ -> "reversed_separated_nonempty_llist_AMPERSAND_core_type_no_attr_")
+  | MenhirInterpreter.N MenhirInterpreter.N_reversed_preceded_or_separated_nonempty_llist_BAR_match_case_ -> (fun _ -> "reversed_preceded_or_separated_nonempty_llist_BAR_match_case_")
+  | MenhirInterpreter.N MenhirInterpreter.N_reversed_nonempty_llist_typevar_ -> (fun _ -> "reversed_nonempty_llist_typevar_")
+  | MenhirInterpreter.N MenhirInterpreter.N_reversed_nonempty_llist_name_tag_ -> (fun _ -> "reversed_nonempty_llist_name_tag_")
+  | MenhirInterpreter.N MenhirInterpreter.N_reversed_nonempty_llist_labeled_simple_expr_ -> (fun _ -> "reversed_nonempty_llist_labeled_simple_expr_")
+  | MenhirInterpreter.N MenhirInterpreter.N_reversed_nonempty_llist_functor_arg_ -> (fun _ -> "reversed_nonempty_llist_functor_arg_")
+  | MenhirInterpreter.N MenhirInterpreter.N_reversed_llist_preceded_CONSTRAINT_constrain__ -> (fun _ -> "reversed_llist_preceded_CONSTRAINT_constrain__")
+  | MenhirInterpreter.N MenhirInterpreter.N_reversed_bar_llist_extension_constructor_declaration_ -> (fun _ -> "reversed_bar_llist_extension_constructor_declaration_")
+  | MenhirInterpreter.N MenhirInterpreter.N_reversed_bar_llist_extension_constructor_ -> (fun _ -> "reversed_bar_llist_extension_constructor_")
+  | MenhirInterpreter.N MenhirInterpreter.N_reversed_bar_llist_constructor_declaration_ -> (fun _ -> "reversed_bar_llist_constructor_declaration_")
+  | MenhirInterpreter.N MenhirInterpreter.N_record_expr_content -> (fun _ -> "record_expr_content")
+  | MenhirInterpreter.N MenhirInterpreter.N_rec_flag -> (fun _ -> "rec_flag")
+  | MenhirInterpreter.N MenhirInterpreter.N_private_virtual_flags -> (fun _ -> "private_virtual_flags")
+  | MenhirInterpreter.N MenhirInterpreter.N_private_flag -> (fun _ -> "private_flag")
+  | MenhirInterpreter.N MenhirInterpreter.N_primitive_declaration -> (fun _ -> "primitive_declaration")
+  | MenhirInterpreter.N MenhirInterpreter.N_post_item_attribute -> (fun _ -> "post_item_attribute")
+  | MenhirInterpreter.N MenhirInterpreter.N_possibly_poly_core_type_no_attr_ -> (fun _ -> "possibly_poly_core_type_no_attr_")
+  | MenhirInterpreter.N MenhirInterpreter.N_possibly_poly_core_type_ -> (fun _ -> "possibly_poly_core_type_")
+  | MenhirInterpreter.N MenhirInterpreter.N_payload -> (fun _ -> "payload")
+  | MenhirInterpreter.N MenhirInterpreter.N_pattern_var -> (fun _ -> "pattern_var")
+  | MenhirInterpreter.N MenhirInterpreter.N_pattern_no_exn -> (fun _ -> "pattern_no_exn")
+  | MenhirInterpreter.N MenhirInterpreter.N_pattern_gen -> (fun _ -> "pattern_gen")
+  | MenhirInterpreter.N MenhirInterpreter.N_pattern_comma_list_pattern_no_exn_ -> (fun _ -> "pattern_comma_list_pattern_no_exn_")
+  | MenhirInterpreter.N MenhirInterpreter.N_pattern_comma_list_pattern_ -> (fun _ -> "pattern_comma_list_pattern_")
+  | MenhirInterpreter.N MenhirInterpreter.N_pattern -> (fun _ -> "pattern")
+  | MenhirInterpreter.N MenhirInterpreter.N_parse_val_longident -> (fun _ -> "parse_val_longident")
+  | MenhirInterpreter.N MenhirInterpreter.N_parse_pattern -> (fun _ -> "parse_pattern")
+  | MenhirInterpreter.N MenhirInterpreter.N_parse_mty_longident -> (fun _ -> "parse_mty_longident")
+  | MenhirInterpreter.N MenhirInterpreter.N_parse_mod_longident -> (fun _ -> "parse_mod_longident")
+  | MenhirInterpreter.N MenhirInterpreter.N_parse_mod_ext_longident -> (fun _ -> "parse_mod_ext_longident")
+  | MenhirInterpreter.N MenhirInterpreter.N_parse_expression -> (fun _ -> "parse_expression")
+  | MenhirInterpreter.N MenhirInterpreter.N_parse_core_type -> (fun _ -> "parse_core_type")
+  | MenhirInterpreter.N MenhirInterpreter.N_parse_constr_longident -> (fun _ -> "parse_constr_longident")
+  | MenhirInterpreter.N MenhirInterpreter.N_parse_any_longident -> (fun _ -> "parse_any_longident")
+  | MenhirInterpreter.N MenhirInterpreter.N_paren_module_expr -> (fun _ -> "paren_module_expr")
+  | MenhirInterpreter.N MenhirInterpreter.N_optlabel -> (fun _ -> "optlabel")
+  | MenhirInterpreter.N MenhirInterpreter.N_option_type_constraint_ -> (fun _ -> "option_type_constraint_")
+  | MenhirInterpreter.N MenhirInterpreter.N_option_preceded_EQUAL_seq_expr__ -> (fun _ -> "option_preceded_EQUAL_seq_expr__")
+  | MenhirInterpreter.N MenhirInterpreter.N_option_preceded_EQUAL_pattern__ -> (fun _ -> "option_preceded_EQUAL_pattern__")
+  | MenhirInterpreter.N MenhirInterpreter.N_option_preceded_EQUAL_module_type__ -> (fun _ -> "option_preceded_EQUAL_module_type__")
+  | MenhirInterpreter.N MenhirInterpreter.N_option_preceded_EQUAL_expr__ -> (fun _ -> "option_preceded_EQUAL_expr__")
+  | MenhirInterpreter.N MenhirInterpreter.N_option_preceded_COLON_core_type__ -> (fun _ -> "option_preceded_COLON_core_type__")
+  | MenhirInterpreter.N MenhirInterpreter.N_option_preceded_AS_mkrhs_LIDENT___ -> (fun _ -> "option_preceded_AS_mkrhs_LIDENT___")
+  | MenhirInterpreter.N MenhirInterpreter.N_option_SEMI_ -> (fun _ -> "option_SEMI_")
+  | MenhirInterpreter.N MenhirInterpreter.N_option_BAR_ -> (fun _ -> "option_BAR_")
+  | MenhirInterpreter.N MenhirInterpreter.N_opt_ampersand -> (fun _ -> "opt_ampersand")
+  | MenhirInterpreter.N MenhirInterpreter.N_operator -> (fun _ -> "operator")
+  | MenhirInterpreter.N MenhirInterpreter.N_open_description -> (fun _ -> "open_description")
+  | MenhirInterpreter.N MenhirInterpreter.N_open_declaration -> (fun _ -> "open_declaration")
+  | MenhirInterpreter.N MenhirInterpreter.N_nonempty_type_kind -> (fun _ -> "nonempty_type_kind")
+  | MenhirInterpreter.N MenhirInterpreter.N_nonempty_list_raw_string_ -> (fun _ -> "nonempty_list_raw_string_")
+  | MenhirInterpreter.N MenhirInterpreter.N_nonempty_list_mkrhs_LIDENT__ -> (fun _ -> "nonempty_list_mkrhs_LIDENT__")
+  | MenhirInterpreter.N MenhirInterpreter.N_name_tag -> (fun _ -> "name_tag")
+  | MenhirInterpreter.N MenhirInterpreter.N_mutable_virtual_flags -> (fun _ -> "mutable_virtual_flags")
+  | MenhirInterpreter.N MenhirInterpreter.N_mutable_flag -> (fun _ -> "mutable_flag")
+  | MenhirInterpreter.N MenhirInterpreter.N_mty_longident -> (fun _ -> "mty_longident")
+  | MenhirInterpreter.N MenhirInterpreter.N_module_type_subst -> (fun _ -> "module_type_subst")
+  | MenhirInterpreter.N MenhirInterpreter.N_module_type_declaration -> (fun _ -> "module_type_declaration")
+  | MenhirInterpreter.N MenhirInterpreter.N_module_type -> (fun _ -> "module_type")
+  | MenhirInterpreter.N MenhirInterpreter.N_module_subst -> (fun _ -> "module_subst")
+  | MenhirInterpreter.N MenhirInterpreter.N_module_name -> (fun _ -> "module_name")
+  | MenhirInterpreter.N MenhirInterpreter.N_module_expr -> (fun _ -> "module_expr")
+  | MenhirInterpreter.N MenhirInterpreter.N_module_declaration_body -> (fun _ -> "module_declaration_body")
+  | MenhirInterpreter.N MenhirInterpreter.N_module_binding_body -> (fun _ -> "module_binding_body")
+  | MenhirInterpreter.N MenhirInterpreter.N_mod_longident -> (fun _ -> "mod_longident")
+  | MenhirInterpreter.N MenhirInterpreter.N_mod_ext_longident -> (fun _ -> "mod_ext_longident")
+  | MenhirInterpreter.N MenhirInterpreter.N_mk_longident_mod_longident_val_ident_ -> (fun _ -> "mk_longident_mod_longident_val_ident_")
+  | MenhirInterpreter.N MenhirInterpreter.N_mk_longident_mod_longident_UIDENT_ -> (fun _ -> "mk_longident_mod_longident_UIDENT_")
+  | MenhirInterpreter.N MenhirInterpreter.N_mk_longident_mod_longident_LIDENT_ -> (fun _ -> "mk_longident_mod_longident_LIDENT_")
+  | MenhirInterpreter.N MenhirInterpreter.N_mk_longident_mod_ext_longident_ident_ -> (fun _ -> "mk_longident_mod_ext_longident_ident_")
+  | MenhirInterpreter.N MenhirInterpreter.N_mk_longident_mod_ext_longident___anonymous_41_ -> (fun _ -> "mk_longident_mod_ext_longident___anonymous_41_")
+  | MenhirInterpreter.N MenhirInterpreter.N_mk_longident_mod_ext_longident_UIDENT_ -> (fun _ -> "mk_longident_mod_ext_longident_UIDENT_")
+  | MenhirInterpreter.N MenhirInterpreter.N_mk_longident_mod_ext_longident_LIDENT_ -> (fun _ -> "mk_longident_mod_ext_longident_LIDENT_")
+  | MenhirInterpreter.N MenhirInterpreter.N_method_ -> (fun _ -> "method_")
+  | MenhirInterpreter.N MenhirInterpreter.N_meth_list -> (fun _ -> "meth_list")
+  | MenhirInterpreter.N MenhirInterpreter.N_match_case -> (fun _ -> "match_case")
+  | MenhirInterpreter.N MenhirInterpreter.N_lwt_bindings -> (fun _ -> "lwt_bindings")
+  | MenhirInterpreter.N MenhirInterpreter.N_lwt_binding -> (fun _ -> "lwt_binding")
+  | MenhirInterpreter.N MenhirInterpreter.N_listx_SEMI_record_pat_field_UNDERSCORE_ -> (fun _ -> "listx_SEMI_record_pat_field_UNDERSCORE_")
+  | MenhirInterpreter.N MenhirInterpreter.N_list_use_file_element_ -> (fun _ -> "list_use_file_element_")
+  | MenhirInterpreter.N MenhirInterpreter.N_list_text_str_structure_item__ -> (fun _ -> "list_text_str_structure_item__")
+  | MenhirInterpreter.N MenhirInterpreter.N_list_text_cstr_class_field__ -> (fun _ -> "list_text_cstr_class_field__")
+  | MenhirInterpreter.N MenhirInterpreter.N_list_text_csig_class_sig_field__ -> (fun _ -> "list_text_csig_class_sig_field__")
+  | MenhirInterpreter.N MenhirInterpreter.N_list_structure_element_ -> (fun _ -> "list_structure_element_")
+  | MenhirInterpreter.N MenhirInterpreter.N_list_signature_element_ -> (fun _ -> "list_signature_element_")
+  | MenhirInterpreter.N MenhirInterpreter.N_list_post_item_attribute_ -> (fun _ -> "list_post_item_attribute_")
+  | MenhirInterpreter.N MenhirInterpreter.N_list_generic_and_type_declaration_type_subst_kind__ -> (fun _ -> "list_generic_and_type_declaration_type_subst_kind__")
+  | MenhirInterpreter.N MenhirInterpreter.N_list_generic_and_type_declaration_type_kind__ -> (fun _ -> "list_generic_and_type_declaration_type_kind__")
+  | MenhirInterpreter.N MenhirInterpreter.N_list_attribute_ -> (fun _ -> "list_attribute_")
+  | MenhirInterpreter.N MenhirInterpreter.N_list_and_module_declaration_ -> (fun _ -> "list_and_module_declaration_")
+  | MenhirInterpreter.N MenhirInterpreter.N_list_and_module_binding_ -> (fun _ -> "list_and_module_binding_")
+  | MenhirInterpreter.N MenhirInterpreter.N_list_and_class_type_declaration_ -> (fun _ -> "list_and_class_type_declaration_")
+  | MenhirInterpreter.N MenhirInterpreter.N_list_and_class_description_ -> (fun _ -> "list_and_class_description_")
+  | MenhirInterpreter.N MenhirInterpreter.N_list_and_class_declaration_ -> (fun _ -> "list_and_class_declaration_")
+  | MenhirInterpreter.N MenhirInterpreter.N_letop_bindings -> (fun _ -> "letop_bindings")
+  | MenhirInterpreter.N MenhirInterpreter.N_letop_binding_body -> (fun _ -> "letop_binding_body")
+  | MenhirInterpreter.N MenhirInterpreter.N_let_pattern -> (fun _ -> "let_pattern")
+  | MenhirInterpreter.N MenhirInterpreter.N_let_bindings_no_ext_ -> (fun _ -> "let_bindings_no_ext_")
+  | MenhirInterpreter.N MenhirInterpreter.N_let_bindings_ext_ -> (fun _ -> "let_bindings_ext_")
+  | MenhirInterpreter.N MenhirInterpreter.N_let_binding_body_no_punning -> (fun _ -> "let_binding_body_no_punning")
+  | MenhirInterpreter.N MenhirInterpreter.N_let_binding_body -> (fun _ -> "let_binding_body")
+  | MenhirInterpreter.N MenhirInterpreter.N_labeled_simple_pattern -> (fun _ -> "labeled_simple_pattern")
+  | MenhirInterpreter.N MenhirInterpreter.N_labeled_simple_expr -> (fun _ -> "labeled_simple_expr")
+  | MenhirInterpreter.N MenhirInterpreter.N_label_longident -> (fun _ -> "label_longident")
+  | MenhirInterpreter.N MenhirInterpreter.N_label_let_pattern -> (fun _ -> "label_let_pattern")
+  | MenhirInterpreter.N MenhirInterpreter.N_label_declarations -> (fun _ -> "label_declarations")
+  | MenhirInterpreter.N MenhirInterpreter.N_label_declaration_semi -> (fun _ -> "label_declaration_semi")
+  | MenhirInterpreter.N MenhirInterpreter.N_label_declaration -> (fun _ -> "label_declaration")
+  | MenhirInterpreter.N MenhirInterpreter.N_item_extension -> (fun _ -> "item_extension")
+  | MenhirInterpreter.N MenhirInterpreter.N_interface -> (fun _ -> "interface")
+  | MenhirInterpreter.N MenhirInterpreter.N_index_mod -> (fun _ -> "index_mod")
+  | MenhirInterpreter.N MenhirInterpreter.N_implementation -> (fun _ -> "implementation")
+  | MenhirInterpreter.N MenhirInterpreter.N_ident -> (fun _ -> "ident")
+  | MenhirInterpreter.N MenhirInterpreter.N_generic_type_declaration_nonrec_flag_type_kind_ -> (fun _ -> "generic_type_declaration_nonrec_flag_type_kind_")
+  | MenhirInterpreter.N MenhirInterpreter.N_generic_type_declaration_no_nonrec_flag_type_subst_kind_ -> (fun _ -> "generic_type_declaration_no_nonrec_flag_type_subst_kind_")
+  | MenhirInterpreter.N MenhirInterpreter.N_generic_constructor_declaration_epsilon_ -> (fun _ -> "generic_constructor_declaration_epsilon_")
+  | MenhirInterpreter.N MenhirInterpreter.N_generic_constructor_declaration_BAR_ -> (fun _ -> "generic_constructor_declaration_BAR_")
+  | MenhirInterpreter.N MenhirInterpreter.N_generalized_constructor_arguments -> (fun _ -> "generalized_constructor_arguments")
+  | MenhirInterpreter.N MenhirInterpreter.N_functor_args -> (fun _ -> "functor_args")
+  | MenhirInterpreter.N MenhirInterpreter.N_functor_arg -> (fun _ -> "functor_arg")
+  | MenhirInterpreter.N MenhirInterpreter.N_function_type -> (fun _ -> "function_type")
+  | MenhirInterpreter.N MenhirInterpreter.N_fun_def -> (fun _ -> "fun_def")
+  | MenhirInterpreter.N MenhirInterpreter.N_fun_binding -> (fun _ -> "fun_binding")
+  | MenhirInterpreter.N MenhirInterpreter.N_formal_class_parameters -> (fun _ -> "formal_class_parameters")
+  | MenhirInterpreter.N MenhirInterpreter.N_floating_attribute -> (fun _ -> "floating_attribute")
+  | MenhirInterpreter.N MenhirInterpreter.N_extension_constructor_rebind_epsilon_ -> (fun _ -> "extension_constructor_rebind_epsilon_")
+  | MenhirInterpreter.N MenhirInterpreter.N_extension_constructor_rebind_BAR_ -> (fun _ -> "extension_constructor_rebind_BAR_")
+  | MenhirInterpreter.N MenhirInterpreter.N_extension -> (fun _ -> "extension")
+  | MenhirInterpreter.N MenhirInterpreter.N_ext -> (fun _ -> "ext")
+  | MenhirInterpreter.N MenhirInterpreter.N_expr -> (fun _ -> "expr")
+  | MenhirInterpreter.N MenhirInterpreter.N_direction_flag -> (fun _ -> "direction_flag")
+  | MenhirInterpreter.N MenhirInterpreter.N_core_type -> (fun _ -> "core_type")
+  | MenhirInterpreter.N MenhirInterpreter.N_constructor_declarations -> (fun _ -> "constructor_declarations")
+  | MenhirInterpreter.N MenhirInterpreter.N_constructor_arguments -> (fun _ -> "constructor_arguments")
+  | MenhirInterpreter.N MenhirInterpreter.N_constrain_field -> (fun _ -> "constrain_field")
+  | MenhirInterpreter.N MenhirInterpreter.N_constr_longident -> (fun _ -> "constr_longident")
+  | MenhirInterpreter.N MenhirInterpreter.N_constr_ident -> (fun _ -> "constr_ident")
+  | MenhirInterpreter.N MenhirInterpreter.N_constr_extra_nonprefix_ident -> (fun _ -> "constr_extra_nonprefix_ident")
+  | MenhirInterpreter.N MenhirInterpreter.N_constant -> (fun _ -> "constant")
+  | MenhirInterpreter.N MenhirInterpreter.N_clty_longident -> (fun _ -> "clty_longident")
+  | MenhirInterpreter.N MenhirInterpreter.N_class_type_declarations -> (fun _ -> "class_type_declarations")
+  | MenhirInterpreter.N MenhirInterpreter.N_class_type -> (fun _ -> "class_type")
+  | MenhirInterpreter.N MenhirInterpreter.N_class_simple_expr -> (fun _ -> "class_simple_expr")
+  | MenhirInterpreter.N MenhirInterpreter.N_class_signature -> (fun _ -> "class_signature")
+  | MenhirInterpreter.N MenhirInterpreter.N_class_sig_field -> (fun _ -> "class_sig_field")
+  | MenhirInterpreter.N MenhirInterpreter.N_class_self_type -> (fun _ -> "class_self_type")
+  | MenhirInterpreter.N MenhirInterpreter.N_class_self_pattern -> (fun _ -> "class_self_pattern")
+  | MenhirInterpreter.N MenhirInterpreter.N_class_longident -> (fun _ -> "class_longident")
+  | MenhirInterpreter.N MenhirInterpreter.N_class_fun_def -> (fun _ -> "class_fun_def")
+  | MenhirInterpreter.N MenhirInterpreter.N_class_fun_binding -> (fun _ -> "class_fun_binding")
+  | MenhirInterpreter.N MenhirInterpreter.N_class_field -> (fun _ -> "class_field")
+  | MenhirInterpreter.N MenhirInterpreter.N_class_expr -> (fun _ -> "class_expr")
+  | MenhirInterpreter.N MenhirInterpreter.N_attribute -> (fun _ -> "attribute")
+  | MenhirInterpreter.N MenhirInterpreter.N_attr_id -> (fun _ -> "attr_id")
+  | MenhirInterpreter.N MenhirInterpreter.N_atomic_type -> (fun _ -> "atomic_type")
+  | MenhirInterpreter.N MenhirInterpreter.N_any_longident -> (fun _ -> "any_longident")
+  | MenhirInterpreter.N MenhirInterpreter.N_and_let_binding -> (fun _ -> "and_let_binding")
+  | MenhirInterpreter.N MenhirInterpreter.N_alias_type -> (fun _ -> "alias_type")
+  | MenhirInterpreter.N MenhirInterpreter.N_additive -> (fun _ -> "additive")
+
+let print_token = function
+  | WITH -> print_value (MenhirInterpreter.T MenhirInterpreter.T_WITH) ()
+  | WHILE_LWT -> print_value (MenhirInterpreter.T MenhirInterpreter.T_WHILE_LWT) ()
+  | WHILE -> print_value (MenhirInterpreter.T MenhirInterpreter.T_WHILE) ()
+  | WHEN -> print_value (MenhirInterpreter.T MenhirInterpreter.T_WHEN) ()
+  | VIRTUAL -> print_value (MenhirInterpreter.T MenhirInterpreter.T_VIRTUAL) ()
+  | VAL -> print_value (MenhirInterpreter.T MenhirInterpreter.T_VAL) ()
+  | UNDERSCORE -> print_value (MenhirInterpreter.T MenhirInterpreter.T_UNDERSCORE) ()
+  | UIDENT v -> print_value (MenhirInterpreter.T MenhirInterpreter.T_UIDENT) v
+  | TYPE -> print_value (MenhirInterpreter.T MenhirInterpreter.T_TYPE) ()
+  | TRY_LWT -> print_value (MenhirInterpreter.T MenhirInterpreter.T_TRY_LWT) ()
+  | TRY -> print_value (MenhirInterpreter.T MenhirInterpreter.T_TRY) ()
+  | TRUE -> print_value (MenhirInterpreter.T MenhirInterpreter.T_TRUE) ()
+  | TO -> print_value (MenhirInterpreter.T MenhirInterpreter.T_TO) ()
+  | TILDE -> print_value (MenhirInterpreter.T MenhirInterpreter.T_TILDE) ()
+  | THEN -> print_value (MenhirInterpreter.T MenhirInterpreter.T_THEN) ()
+  | STRUCT -> print_value (MenhirInterpreter.T MenhirInterpreter.T_STRUCT) ()
+  | STRING v -> print_value (MenhirInterpreter.T MenhirInterpreter.T_STRING) v
+  | STAR -> print_value (MenhirInterpreter.T MenhirInterpreter.T_STAR) ()
+  | SIG -> print_value (MenhirInterpreter.T MenhirInterpreter.T_SIG) ()
+  | SEMISEMI -> print_value (MenhirInterpreter.T MenhirInterpreter.T_SEMISEMI) ()
+  | SEMI -> print_value (MenhirInterpreter.T MenhirInterpreter.T_SEMI) ()
+  | RPAREN -> print_value (MenhirInterpreter.T MenhirInterpreter.T_RPAREN) ()
+  | REC -> print_value (MenhirInterpreter.T MenhirInterpreter.T_REC) ()
+  | RBRACKET -> print_value (MenhirInterpreter.T MenhirInterpreter.T_RBRACKET) ()
+  | RBRACE -> print_value (MenhirInterpreter.T MenhirInterpreter.T_RBRACE) ()
+  | QUOTED_STRING_ITEM v -> print_value (MenhirInterpreter.T MenhirInterpreter.T_QUOTED_STRING_ITEM) v
+  | QUOTED_STRING_EXPR v -> print_value (MenhirInterpreter.T MenhirInterpreter.T_QUOTED_STRING_EXPR) v
+  | QUOTE -> print_value (MenhirInterpreter.T MenhirInterpreter.T_QUOTE) ()
+  | QUESTION -> print_value (MenhirInterpreter.T MenhirInterpreter.T_QUESTION) ()
+  | PRIVATE -> print_value (MenhirInterpreter.T MenhirInterpreter.T_PRIVATE) ()
+  | PREFIXOP v -> print_value (MenhirInterpreter.T MenhirInterpreter.T_PREFIXOP) v
+  | PLUSEQ -> print_value (MenhirInterpreter.T MenhirInterpreter.T_PLUSEQ) ()
+  | PLUSDOT -> print_value (MenhirInterpreter.T MenhirInterpreter.T_PLUSDOT) ()
+  | PLUS -> print_value (MenhirInterpreter.T MenhirInterpreter.T_PLUS) ()
+  | PERCENT -> print_value (MenhirInterpreter.T MenhirInterpreter.T_PERCENT) ()
+  | OR -> print_value (MenhirInterpreter.T MenhirInterpreter.T_OR) ()
+  | OPTLABEL v -> print_value (MenhirInterpreter.T MenhirInterpreter.T_OPTLABEL) v
+  | OPEN -> print_value (MenhirInterpreter.T MenhirInterpreter.T_OPEN) ()
+  | OF -> print_value (MenhirInterpreter.T MenhirInterpreter.T_OF) ()
+  | OBJECT -> print_value (MenhirInterpreter.T MenhirInterpreter.T_OBJECT) ()
+  | NONREC -> print_value (MenhirInterpreter.T MenhirInterpreter.T_NONREC) ()
+  | NEW -> print_value (MenhirInterpreter.T MenhirInterpreter.T_NEW) ()
+  | MUTABLE -> print_value (MenhirInterpreter.T MenhirInterpreter.T_MUTABLE) ()
+  | MODULE -> print_value (MenhirInterpreter.T MenhirInterpreter.T_MODULE) ()
+  | MINUSGREATER -> print_value (MenhirInterpreter.T MenhirInterpreter.T_MINUSGREATER) ()
+  | MINUSDOT -> print_value (MenhirInterpreter.T MenhirInterpreter.T_MINUSDOT) ()
+  | MINUS -> print_value (MenhirInterpreter.T MenhirInterpreter.T_MINUS) ()
+  | METHOD -> print_value (MenhirInterpreter.T MenhirInterpreter.T_METHOD) ()
+  | MATCH_LWT -> print_value (MenhirInterpreter.T MenhirInterpreter.T_MATCH_LWT) ()
+  | MATCH -> print_value (MenhirInterpreter.T MenhirInterpreter.T_MATCH) ()
+  | LPAREN -> print_value (MenhirInterpreter.T MenhirInterpreter.T_LPAREN) ()
+  | LIDENT v -> print_value (MenhirInterpreter.T MenhirInterpreter.T_LIDENT) v
+  | LET_LWT -> print_value (MenhirInterpreter.T MenhirInterpreter.T_LET_LWT) ()
+  | LETOP v -> print_value (MenhirInterpreter.T MenhirInterpreter.T_LETOP) v
+  | LET -> print_value (MenhirInterpreter.T MenhirInterpreter.T_LET) ()
+  | LESSMINUS -> print_value (MenhirInterpreter.T MenhirInterpreter.T_LESSMINUS) ()
+  | LESS -> print_value (MenhirInterpreter.T MenhirInterpreter.T_LESS) ()
+  | LBRACKETPERCENTPERCENT -> print_value (MenhirInterpreter.T MenhirInterpreter.T_LBRACKETPERCENTPERCENT) ()
+  | LBRACKETPERCENT -> print_value (MenhirInterpreter.T MenhirInterpreter.T_LBRACKETPERCENT) ()
+  | LBRACKETLESS -> print_value (MenhirInterpreter.T MenhirInterpreter.T_LBRACKETLESS) ()
+  | LBRACKETGREATER -> print_value (MenhirInterpreter.T MenhirInterpreter.T_LBRACKETGREATER) ()
+  | LBRACKETBAR -> print_value (MenhirInterpreter.T MenhirInterpreter.T_LBRACKETBAR) ()
+  | LBRACKETATATAT -> print_value (MenhirInterpreter.T MenhirInterpreter.T_LBRACKETATATAT) ()
+  | LBRACKETATAT -> print_value (MenhirInterpreter.T MenhirInterpreter.T_LBRACKETATAT) ()
+  | LBRACKETAT -> print_value (MenhirInterpreter.T MenhirInterpreter.T_LBRACKETAT) ()
+  | LBRACKET -> print_value (MenhirInterpreter.T MenhirInterpreter.T_LBRACKET) ()
+  | LBRACELESS -> print_value (MenhirInterpreter.T MenhirInterpreter.T_LBRACELESS) ()
+  | LBRACE -> print_value (MenhirInterpreter.T MenhirInterpreter.T_LBRACE) ()
+  | LAZY -> print_value (MenhirInterpreter.T MenhirInterpreter.T_LAZY) ()
+  | LABEL v -> print_value (MenhirInterpreter.T MenhirInterpreter.T_LABEL) v
+  | INT v -> print_value (MenhirInterpreter.T MenhirInterpreter.T_INT) v
+  | INITIALIZER -> print_value (MenhirInterpreter.T MenhirInterpreter.T_INITIALIZER) ()
+  | INHERIT -> print_value (MenhirInterpreter.T MenhirInterpreter.T_INHERIT) ()
+  | INFIXOP4 v -> print_value (MenhirInterpreter.T MenhirInterpreter.T_INFIXOP4) v
+  | INFIXOP3 v -> print_value (MenhirInterpreter.T MenhirInterpreter.T_INFIXOP3) v
+  | INFIXOP2 v -> print_value (MenhirInterpreter.T MenhirInterpreter.T_INFIXOP2) v
+  | INFIXOP1 v -> print_value (MenhirInterpreter.T MenhirInterpreter.T_INFIXOP1) v
+  | INFIXOP0 v -> print_value (MenhirInterpreter.T MenhirInterpreter.T_INFIXOP0) v
+  | INCLUDE -> print_value (MenhirInterpreter.T MenhirInterpreter.T_INCLUDE) ()
+  | IN -> print_value (MenhirInterpreter.T MenhirInterpreter.T_IN) ()
+  | IF -> print_value (MenhirInterpreter.T MenhirInterpreter.T_IF) ()
+  | HASHOP v -> print_value (MenhirInterpreter.T MenhirInterpreter.T_HASHOP) v
+  | HASH -> print_value (MenhirInterpreter.T MenhirInterpreter.T_HASH) ()
+  | GREATERRBRACKET -> print_value (MenhirInterpreter.T MenhirInterpreter.T_GREATERRBRACKET) ()
+  | GREATERRBRACE -> print_value (MenhirInterpreter.T MenhirInterpreter.T_GREATERRBRACE) ()
+  | GREATERDOT -> print_value (MenhirInterpreter.T MenhirInterpreter.T_GREATERDOT) ()
+  | GREATER -> print_value (MenhirInterpreter.T MenhirInterpreter.T_GREATER) ()
+  | FUNCTOR -> print_value (MenhirInterpreter.T MenhirInterpreter.T_FUNCTOR) ()
+  | FUNCTION -> print_value (MenhirInterpreter.T MenhirInterpreter.T_FUNCTION) ()
+  | FUN -> print_value (MenhirInterpreter.T MenhirInterpreter.T_FUN) ()
+  | FOR_LWT -> print_value (MenhirInterpreter.T MenhirInterpreter.T_FOR_LWT) ()
+  | FOR -> print_value (MenhirInterpreter.T MenhirInterpreter.T_FOR) ()
+  | FLOAT v -> print_value (MenhirInterpreter.T MenhirInterpreter.T_FLOAT) v
+  | FINALLY_LWT -> print_value (MenhirInterpreter.T MenhirInterpreter.T_FINALLY_LWT) ()
+  | FALSE -> print_value (MenhirInterpreter.T MenhirInterpreter.T_FALSE) ()
+  | EXTERNAL -> print_value (MenhirInterpreter.T MenhirInterpreter.T_EXTERNAL) ()
+  | EXCEPTION -> print_value (MenhirInterpreter.T MenhirInterpreter.T_EXCEPTION) ()
+  | EQUAL -> print_value (MenhirInterpreter.T MenhirInterpreter.T_EQUAL) ()
+  | EOL -> print_value (MenhirInterpreter.T MenhirInterpreter.T_EOL) ()
+  | EOF -> print_value (MenhirInterpreter.T MenhirInterpreter.T_EOF) ()
+  | END -> print_value (MenhirInterpreter.T MenhirInterpreter.T_END) ()
+  | ELSE -> print_value (MenhirInterpreter.T MenhirInterpreter.T_ELSE) ()
+  | DOWNTO -> print_value (MenhirInterpreter.T MenhirInterpreter.T_DOWNTO) ()
+  | DOTTILDE -> print_value (MenhirInterpreter.T MenhirInterpreter.T_DOTTILDE) ()
+  | DOTOP v -> print_value (MenhirInterpreter.T MenhirInterpreter.T_DOTOP) v
+  | DOTLESS -> print_value (MenhirInterpreter.T MenhirInterpreter.T_DOTLESS) ()
+  | DOTDOT -> print_value (MenhirInterpreter.T MenhirInterpreter.T_DOTDOT) ()
+  | DOT -> print_value (MenhirInterpreter.T MenhirInterpreter.T_DOT) ()
+  | DONE -> print_value (MenhirInterpreter.T MenhirInterpreter.T_DONE) ()
+  | DOCSTRING v -> print_value (MenhirInterpreter.T MenhirInterpreter.T_DOCSTRING) v
+  | DO -> print_value (MenhirInterpreter.T MenhirInterpreter.T_DO) ()
+  | CONSTRAINT -> print_value (MenhirInterpreter.T MenhirInterpreter.T_CONSTRAINT) ()
+  | COMMENT v -> print_value (MenhirInterpreter.T MenhirInterpreter.T_COMMENT) v
+  | COMMA -> print_value (MenhirInterpreter.T MenhirInterpreter.T_COMMA) ()
+  | COLONGREATER -> print_value (MenhirInterpreter.T MenhirInterpreter.T_COLONGREATER) ()
+  | COLONEQUAL -> print_value (MenhirInterpreter.T MenhirInterpreter.T_COLONEQUAL) ()
+  | COLONCOLON -> print_value (MenhirInterpreter.T MenhirInterpreter.T_COLONCOLON) ()
+  | COLON -> print_value (MenhirInterpreter.T MenhirInterpreter.T_COLON) ()
+  | CLASS -> print_value (MenhirInterpreter.T MenhirInterpreter.T_CLASS) ()
+  | CHAR v -> print_value (MenhirInterpreter.T MenhirInterpreter.T_CHAR) v
+  | BEGIN -> print_value (MenhirInterpreter.T MenhirInterpreter.T_BEGIN) ()
+  | BARRBRACKET -> print_value (MenhirInterpreter.T MenhirInterpreter.T_BARRBRACKET) ()
+  | BARBAR -> print_value (MenhirInterpreter.T MenhirInterpreter.T_BARBAR) ()
+  | BAR -> print_value (MenhirInterpreter.T MenhirInterpreter.T_BAR) ()
+  | BANG -> print_value (MenhirInterpreter.T MenhirInterpreter.T_BANG) ()
+  | BACKQUOTE -> print_value (MenhirInterpreter.T MenhirInterpreter.T_BACKQUOTE) ()
+  | ASSERT -> print_value (MenhirInterpreter.T MenhirInterpreter.T_ASSERT) ()
+  | AS -> print_value (MenhirInterpreter.T MenhirInterpreter.T_AS) ()
+  | ANDOP v -> print_value (MenhirInterpreter.T MenhirInterpreter.T_ANDOP) v
+  | AND -> print_value (MenhirInterpreter.T MenhirInterpreter.T_AND) ()
+  | AMPERSAND -> print_value (MenhirInterpreter.T MenhirInterpreter.T_AMPERSAND) ()
+  | AMPERAMPER -> print_value (MenhirInterpreter.T MenhirInterpreter.T_AMPERAMPER) ()
+
+let token_of_terminal (type a) (t : a MenhirInterpreter.terminal) (v : a) : token =
+  match t with
+  | MenhirInterpreter.T_error -> assert false
+  | MenhirInterpreter.T_WITH -> WITH
+  | MenhirInterpreter.T_WHILE_LWT -> WHILE_LWT
+  | MenhirInterpreter.T_WHILE -> WHILE
+  | MenhirInterpreter.T_WHEN -> WHEN
+  | MenhirInterpreter.T_VIRTUAL -> VIRTUAL
+  | MenhirInterpreter.T_VAL -> VAL
+  | MenhirInterpreter.T_UNDERSCORE -> UNDERSCORE
+  | MenhirInterpreter.T_UIDENT -> UIDENT v
+  | MenhirInterpreter.T_TYPE -> TYPE
+  | MenhirInterpreter.T_TRY_LWT -> TRY_LWT
+  | MenhirInterpreter.T_TRY -> TRY
+  | MenhirInterpreter.T_TRUE -> TRUE
+  | MenhirInterpreter.T_TO -> TO
+  | MenhirInterpreter.T_TILDE -> TILDE
+  | MenhirInterpreter.T_THEN -> THEN
+  | MenhirInterpreter.T_STRUCT -> STRUCT
+  | MenhirInterpreter.T_STRING -> STRING v
+  | MenhirInterpreter.T_STAR -> STAR
+  | MenhirInterpreter.T_SIG -> SIG
+  | MenhirInterpreter.T_SEMISEMI -> SEMISEMI
+  | MenhirInterpreter.T_SEMI -> SEMI
+  | MenhirInterpreter.T_RPAREN -> RPAREN
+  | MenhirInterpreter.T_REC -> REC
+  | MenhirInterpreter.T_RBRACKET -> RBRACKET
+  | MenhirInterpreter.T_RBRACE -> RBRACE
+  | MenhirInterpreter.T_QUOTED_STRING_ITEM -> QUOTED_STRING_ITEM v
+  | MenhirInterpreter.T_QUOTED_STRING_EXPR -> QUOTED_STRING_EXPR v
+  | MenhirInterpreter.T_QUOTE -> QUOTE
+  | MenhirInterpreter.T_QUESTION -> QUESTION
+  | MenhirInterpreter.T_PRIVATE -> PRIVATE
+  | MenhirInterpreter.T_PREFIXOP -> PREFIXOP v
+  | MenhirInterpreter.T_PLUSEQ -> PLUSEQ
+  | MenhirInterpreter.T_PLUSDOT -> PLUSDOT
+  | MenhirInterpreter.T_PLUS -> PLUS
+  | MenhirInterpreter.T_PERCENT -> PERCENT
+  | MenhirInterpreter.T_OR -> OR
+  | MenhirInterpreter.T_OPTLABEL -> OPTLABEL v
+  | MenhirInterpreter.T_OPEN -> OPEN
+  | MenhirInterpreter.T_OF -> OF
+  | MenhirInterpreter.T_OBJECT -> OBJECT
+  | MenhirInterpreter.T_NONREC -> NONREC
+  | MenhirInterpreter.T_NEW -> NEW
+  | MenhirInterpreter.T_MUTABLE -> MUTABLE
+  | MenhirInterpreter.T_MODULE -> MODULE
+  | MenhirInterpreter.T_MINUSGREATER -> MINUSGREATER
+  | MenhirInterpreter.T_MINUSDOT -> MINUSDOT
+  | MenhirInterpreter.T_MINUS -> MINUS
+  | MenhirInterpreter.T_METHOD -> METHOD
+  | MenhirInterpreter.T_MATCH_LWT -> MATCH_LWT
+  | MenhirInterpreter.T_MATCH -> MATCH
+  | MenhirInterpreter.T_LPAREN -> LPAREN
+  | MenhirInterpreter.T_LIDENT -> LIDENT v
+  | MenhirInterpreter.T_LET_LWT -> LET_LWT
+  | MenhirInterpreter.T_LETOP -> LETOP v
+  | MenhirInterpreter.T_LET -> LET
+  | MenhirInterpreter.T_LESSMINUS -> LESSMINUS
+  | MenhirInterpreter.T_LESS -> LESS
+  | MenhirInterpreter.T_LBRACKETPERCENTPERCENT -> LBRACKETPERCENTPERCENT
+  | MenhirInterpreter.T_LBRACKETPERCENT -> LBRACKETPERCENT
+  | MenhirInterpreter.T_LBRACKETLESS -> LBRACKETLESS
+  | MenhirInterpreter.T_LBRACKETGREATER -> LBRACKETGREATER
+  | MenhirInterpreter.T_LBRACKETBAR -> LBRACKETBAR
+  | MenhirInterpreter.T_LBRACKETATATAT -> LBRACKETATATAT
+  | MenhirInterpreter.T_LBRACKETATAT -> LBRACKETATAT
+  | MenhirInterpreter.T_LBRACKETAT -> LBRACKETAT
+  | MenhirInterpreter.T_LBRACKET -> LBRACKET
+  | MenhirInterpreter.T_LBRACELESS -> LBRACELESS
+  | MenhirInterpreter.T_LBRACE -> LBRACE
+  | MenhirInterpreter.T_LAZY -> LAZY
+  | MenhirInterpreter.T_LABEL -> LABEL v
+  | MenhirInterpreter.T_INT -> INT v
+  | MenhirInterpreter.T_INITIALIZER -> INITIALIZER
+  | MenhirInterpreter.T_INHERIT -> INHERIT
+  | MenhirInterpreter.T_INFIXOP4 -> INFIXOP4 v
+  | MenhirInterpreter.T_INFIXOP3 -> INFIXOP3 v
+  | MenhirInterpreter.T_INFIXOP2 -> INFIXOP2 v
+  | MenhirInterpreter.T_INFIXOP1 -> INFIXOP1 v
+  | MenhirInterpreter.T_INFIXOP0 -> INFIXOP0 v
+  | MenhirInterpreter.T_INCLUDE -> INCLUDE
+  | MenhirInterpreter.T_IN -> IN
+  | MenhirInterpreter.T_IF -> IF
+  | MenhirInterpreter.T_HASHOP -> HASHOP v
+  | MenhirInterpreter.T_HASH -> HASH
+  | MenhirInterpreter.T_GREATERRBRACKET -> GREATERRBRACKET
+  | MenhirInterpreter.T_GREATERRBRACE -> GREATERRBRACE
+  | MenhirInterpreter.T_GREATERDOT -> GREATERDOT
+  | MenhirInterpreter.T_GREATER -> GREATER
+  | MenhirInterpreter.T_FUNCTOR -> FUNCTOR
+  | MenhirInterpreter.T_FUNCTION -> FUNCTION
+  | MenhirInterpreter.T_FUN -> FUN
+  | MenhirInterpreter.T_FOR_LWT -> FOR_LWT
+  | MenhirInterpreter.T_FOR -> FOR
+  | MenhirInterpreter.T_FLOAT -> FLOAT v
+  | MenhirInterpreter.T_FINALLY_LWT -> FINALLY_LWT
+  | MenhirInterpreter.T_FALSE -> FALSE
+  | MenhirInterpreter.T_EXTERNAL -> EXTERNAL
+  | MenhirInterpreter.T_EXCEPTION -> EXCEPTION
+  | MenhirInterpreter.T_EQUAL -> EQUAL
+  | MenhirInterpreter.T_EOL -> EOL
+  | MenhirInterpreter.T_EOF -> EOF
+  | MenhirInterpreter.T_END -> END
+  | MenhirInterpreter.T_ELSE -> ELSE
+  | MenhirInterpreter.T_DOWNTO -> DOWNTO
+  | MenhirInterpreter.T_DOTTILDE -> DOTTILDE
+  | MenhirInterpreter.T_DOTOP -> DOTOP v
+  | MenhirInterpreter.T_DOTLESS -> DOTLESS
+  | MenhirInterpreter.T_DOTDOT -> DOTDOT
+  | MenhirInterpreter.T_DOT -> DOT
+  | MenhirInterpreter.T_DONE -> DONE
+  | MenhirInterpreter.T_DOCSTRING -> DOCSTRING v
+  | MenhirInterpreter.T_DO -> DO
+  | MenhirInterpreter.T_CONSTRAINT -> CONSTRAINT
+  | MenhirInterpreter.T_COMMENT -> COMMENT v
+  | MenhirInterpreter.T_COMMA -> COMMA
+  | MenhirInterpreter.T_COLONGREATER -> COLONGREATER
+  | MenhirInterpreter.T_COLONEQUAL -> COLONEQUAL
+  | MenhirInterpreter.T_COLONCOLON -> COLONCOLON
+  | MenhirInterpreter.T_COLON -> COLON
+  | MenhirInterpreter.T_CLASS -> CLASS
+  | MenhirInterpreter.T_CHAR -> CHAR v
+  | MenhirInterpreter.T_BEGIN -> BEGIN
+  | MenhirInterpreter.T_BARRBRACKET -> BARRBRACKET
+  | MenhirInterpreter.T_BARBAR -> BARBAR
+  | MenhirInterpreter.T_BAR -> BAR
+  | MenhirInterpreter.T_BANG -> BANG
+  | MenhirInterpreter.T_BACKQUOTE -> BACKQUOTE
+  | MenhirInterpreter.T_ASSERT -> ASSERT
+  | MenhirInterpreter.T_AS -> AS
+  | MenhirInterpreter.T_ANDOP -> ANDOP v
+  | MenhirInterpreter.T_AND -> AND
+  | MenhirInterpreter.T_AMPERSAND -> AMPERSAND
+  | MenhirInterpreter.T_AMPERAMPER -> AMPERAMPER
diff --git a/src/ocaml/preprocess/parser_printer.mli b/src/ocaml/preprocess/parser_printer.mli
new file mode 100644
index 0000000..db6dd2f
--- /dev/null
+++ b/src/ocaml/preprocess/parser_printer.mli
@@ -0,0 +1,6 @@
+open Parser_raw
+
+val print_symbol : MenhirInterpreter.xsymbol -> string
+val print_value : 'a MenhirInterpreter.symbol -> 'a -> string
+val print_token : token -> string
+val token_of_terminal : 'a MenhirInterpreter.terminal -> 'a -> token
diff --git a/src/ocaml/preprocess/parser_raw.ml b/src/ocaml/preprocess/parser_raw.ml
new file mode 100644
index 0000000..ae13a6c
--- /dev/null
+++ b/src/ocaml/preprocess/parser_raw.ml
@@ -0,0 +1,46065 @@
+
+(* This generated code requires the following version of MenhirLib: *)
+
+let () =
+  MenhirLib.StaticVersion.require_20201216
+
+module MenhirBasics = struct
+  
+  exception Error
+  
+  type token = 
+    | WITH
+    | WHILE_LWT
+    | WHILE
+    | WHEN
+    | VIRTUAL
+    | VAL
+    | UNDERSCORE
+    | UIDENT of (
+# 839 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 23 "src/ocaml/preprocess/parser_raw.ml"
+  )
+    | TYPE
+    | TRY_LWT
+    | TRY
+    | TRUE
+    | TO
+    | TILDE
+    | THEN
+    | STRUCT
+    | STRING of (
+# 825 "src/ocaml/preprocess/parser_raw.mly"
+       (string * Location.t * string option)
+# 36 "src/ocaml/preprocess/parser_raw.ml"
+  )
+    | STAR
+    | SIG
+    | SEMISEMI
+    | SEMI
+    | RPAREN
+    | REC
+    | RBRACKET
+    | RBRACE
+    | QUOTED_STRING_ITEM of (
+# 830 "src/ocaml/preprocess/parser_raw.mly"
+  (string * Location.t * string * Location.t * string option)
+# 49 "src/ocaml/preprocess/parser_raw.ml"
+  )
+    | QUOTED_STRING_EXPR of (
+# 827 "src/ocaml/preprocess/parser_raw.mly"
+  (string * Location.t * string * Location.t * string option)
+# 54 "src/ocaml/preprocess/parser_raw.ml"
+  )
+    | QUOTE
+    | QUESTION
+    | PRIVATE
+    | PREFIXOP of (
+# 811 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 62 "src/ocaml/preprocess/parser_raw.ml"
+  )
+    | PLUSEQ
+    | PLUSDOT
+    | PLUS
+    | PERCENT
+    | OR
+    | OPTLABEL of (
+# 804 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 72 "src/ocaml/preprocess/parser_raw.ml"
+  )
+    | OPEN
+    | OF
+    | OBJECT
+    | NONREC
+    | NEW
+    | MUTABLE
+    | MODULE
+    | MINUSGREATER
+    | MINUSDOT
+    | MINUS
+    | METHOD
+    | MATCH_LWT
+    | MATCH
+    | LPAREN
+    | LIDENT of (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 91 "src/ocaml/preprocess/parser_raw.ml"
+  )
+    | LET_LWT
+    | LETOP of (
+# 769 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 97 "src/ocaml/preprocess/parser_raw.ml"
+  )
+    | LET
+    | LESSMINUS
+    | LESS
+    | LBRACKETPERCENTPERCENT
+    | LBRACKETPERCENT
+    | LBRACKETLESS
+    | LBRACKETGREATER
+    | LBRACKETBAR
+    | LBRACKETATATAT
+    | LBRACKETATAT
+    | LBRACKETAT
+    | LBRACKET
+    | LBRACELESS
+    | LBRACE
+    | LAZY
+    | LABEL of (
+# 774 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 117 "src/ocaml/preprocess/parser_raw.ml"
+  )
+    | INT of (
+# 773 "src/ocaml/preprocess/parser_raw.mly"
+       (string * char option)
+# 122 "src/ocaml/preprocess/parser_raw.ml"
+  )
+    | INITIALIZER
+    | INHERIT
+    | INFIXOP4 of (
+# 767 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 129 "src/ocaml/preprocess/parser_raw.ml"
+  )
+    | INFIXOP3 of (
+# 766 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 134 "src/ocaml/preprocess/parser_raw.ml"
+  )
+    | INFIXOP2 of (
+# 765 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 139 "src/ocaml/preprocess/parser_raw.ml"
+  )
+    | INFIXOP1 of (
+# 764 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 144 "src/ocaml/preprocess/parser_raw.ml"
+  )
+    | INFIXOP0 of (
+# 763 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 149 "src/ocaml/preprocess/parser_raw.ml"
+  )
+    | INCLUDE
+    | IN
+    | IF
+    | HASHOP of (
+# 822 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 157 "src/ocaml/preprocess/parser_raw.ml"
+  )
+    | HASH
+    | GREATERRBRACKET
+    | GREATERRBRACE
+    | GREATERDOT
+    | GREATER
+    | FUNCTOR
+    | FUNCTION
+    | FUN
+    | FOR_LWT
+    | FOR
+    | FLOAT of (
+# 752 "src/ocaml/preprocess/parser_raw.mly"
+       (string * char option)
+# 172 "src/ocaml/preprocess/parser_raw.ml"
+  )
+    | FINALLY_LWT
+    | FALSE
+    | EXTERNAL
+    | EXCEPTION
+    | EQUAL
+    | EOL
+    | EOF
+    | END
+    | ELSE
+    | DOWNTO
+    | DOTTILDE
+    | DOTOP of (
+# 768 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 188 "src/ocaml/preprocess/parser_raw.ml"
+  )
+    | DOTLESS
+    | DOTDOT
+    | DOT
+    | DONE
+    | DOCSTRING of (
+# 847 "src/ocaml/preprocess/parser_raw.mly"
+       (Docstrings.docstring)
+# 197 "src/ocaml/preprocess/parser_raw.ml"
+  )
+    | DO
+    | CONSTRAINT
+    | COMMENT of (
+# 846 "src/ocaml/preprocess/parser_raw.mly"
+       (string * Location.t)
+# 204 "src/ocaml/preprocess/parser_raw.ml"
+  )
+    | COMMA
+    | COLONGREATER
+    | COLONEQUAL
+    | COLONCOLON
+    | COLON
+    | CLASS
+    | CHAR of (
+# 732 "src/ocaml/preprocess/parser_raw.mly"
+       (char)
+# 215 "src/ocaml/preprocess/parser_raw.ml"
+  )
+    | BEGIN
+    | BARRBRACKET
+    | BARBAR
+    | BAR
+    | BANG
+    | BACKQUOTE
+    | ASSERT
+    | AS
+    | ANDOP of (
+# 770 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 228 "src/ocaml/preprocess/parser_raw.ml"
+  )
+    | AND
+    | AMPERSAND
+    | AMPERAMPER
+  
+end
+
+include MenhirBasics
+
+let _eRR =
+  MenhirBasics.Error
+
+# 25 "src/ocaml/preprocess/parser_raw.mly"
+  
+
+[@@@ocaml.warning "-9"]
+
+open Asttypes
+open Longident
+open Parsetree
+open Ast_helper
+open Docstrings
+open Docstrings.WithMenhir
+open Msupport_parsing
+
+let mkloc = Location.mkloc
+let mknoloc = Location.mknoloc
+
+let make_loc (startpos, endpos) = {
+  Location.loc_start = startpos;
+  Location.loc_end = endpos;
+  Location.loc_ghost = false;
+}
+
+let ghost_loc (startpos, endpos) = {
+  Location.loc_start = startpos;
+  Location.loc_end = endpos;
+  Location.loc_ghost = true;
+}
+
+let mktyp ~loc ?attrs d = Typ.mk ~loc:(make_loc loc) ?attrs d
+let mkpat ~loc d = Pat.mk ~loc:(make_loc loc) d
+let mkexp ~loc d = Exp.mk ~loc:(make_loc loc) d
+let mkmty ~loc ?attrs d = Mty.mk ~loc:(make_loc loc) ?attrs d
+let mksig ~loc d = Sig.mk ~loc:(make_loc loc) d
+let mkmod ~loc ?attrs d = Mod.mk ~loc:(make_loc loc) ?attrs d
+let mkstr ~loc d = Str.mk ~loc:(make_loc loc) d
+let mkclass ~loc ?attrs d = Cl.mk ~loc:(make_loc loc) ?attrs d
+let mkcty ~loc ?attrs d = Cty.mk ~loc:(make_loc loc) ?attrs d
+
+let pstr_typext (te, ext) =
+  (Pstr_typext te, ext)
+let pstr_primitive (vd, ext) =
+  (Pstr_primitive vd, ext)
+let pstr_type ((nr, ext), tys) =
+  (Pstr_type (nr, tys), ext)
+let pstr_exception (te, ext) =
+  (Pstr_exception te, ext)
+let pstr_include (body, ext) =
+  (Pstr_include body, ext)
+let pstr_recmodule (ext, bindings) =
+  (Pstr_recmodule bindings, ext)
+
+let psig_typext (te, ext) =
+  (Psig_typext te, ext)
+let psig_value (vd, ext) =
+  (Psig_value vd, ext)
+let psig_type ((nr, ext), tys) =
+  (Psig_type (nr, tys), ext)
+let psig_typesubst ((nr, ext), tys) =
+  assert (nr = Recursive); (* see [no_nonrec_flag] *)
+  (Psig_typesubst tys, ext)
+let psig_exception (te, ext) =
+  (Psig_exception te, ext)
+let psig_include (body, ext) =
+  (Psig_include body, ext)
+
+let mkctf ~loc ?attrs ?docs d =
+  Ctf.mk ~loc:(make_loc loc) ?attrs ?docs d
+let mkcf ~loc ?attrs ?docs d =
+  Cf.mk ~loc:(make_loc loc) ?attrs ?docs d
+
+let mkrhs rhs loc = mkloc rhs (make_loc loc)
+let ghrhs rhs loc = mkloc rhs (ghost_loc loc)
+
+let push_loc x acc =
+  if x.Location.loc_ghost
+  then acc
+  else x :: acc
+
+let reloc_pat ~loc x =
+  { x with ppat_loc = make_loc loc;
+           ppat_loc_stack = push_loc x.ppat_loc x.ppat_loc_stack };;
+let reloc_exp ~loc x =
+  { x with pexp_loc = make_loc loc;
+           pexp_loc_stack = push_loc x.pexp_loc x.pexp_loc_stack };;
+let reloc_typ ~loc x =
+  { x with ptyp_loc = make_loc loc;
+           ptyp_loc_stack = push_loc x.ptyp_loc x.ptyp_loc_stack };;
+
+let mkexpvar ~loc (name : string) =
+  mkexp ~loc (Pexp_ident(mkrhs (Lident name) loc))
+
+let mkoperator =
+  mkexpvar
+
+let mkpatvar ~loc name =
+  mkpat ~loc (Ppat_var (mkrhs name loc))
+
+(*
+  Ghost expressions and patterns:
+  expressions and patterns that do not appear explicitly in the
+  source file they have the loc_ghost flag set to true.
+  Then the profiler will not try to instrument them and the
+  -annot option will not try to display their type.
+
+  Every grammar rule that generates an element with a location must
+  make at most one non-ghost element, the topmost one.
+
+  How to tell whether your location must be ghost:
+  A location corresponds to a range of characters in the source file.
+  If the location contains a piece of code that is syntactically
+  valid (according to the documentation), and corresponds to the
+  AST node, then the location must be real; in all other cases,
+  it must be ghost.
+*)
+let ghexp ~loc d = Exp.mk ~loc:(ghost_loc loc) d
+let ghpat ~loc d = Pat.mk ~loc:(ghost_loc loc) d
+let ghtyp ~loc d = Typ.mk ~loc:(ghost_loc loc) d
+let ghloc ~loc d = { txt = d; loc = ghost_loc loc }
+let ghstr ~loc d = Str.mk ~loc:(ghost_loc loc) d
+let ghsig ~loc d = Sig.mk ~loc:(ghost_loc loc) d
+
+let mkinfix arg1 op arg2 =
+  Pexp_apply(op, [Nolabel, arg1; Nolabel, arg2])
+
+let neg_string f =
+  if String.length f > 0 && f.[0] = '-'
+  then String.sub f 1 (String.length f - 1)
+  else "-" ^ f
+
+let mkuminus ~oploc name arg =
+  match name, arg.pexp_desc with
+  | "-", Pexp_constant(Pconst_integer (n,m)) ->
+      Pexp_constant(Pconst_integer(neg_string n,m))
+  | ("-" | "-."), Pexp_constant(Pconst_float (f, m)) ->
+      Pexp_constant(Pconst_float(neg_string f, m))
+  | _ ->
+      Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg])
+
+let mkuplus ~oploc name arg =
+  let desc = arg.pexp_desc in
+  match name, desc with
+  | "+", Pexp_constant(Pconst_integer _)
+  | ("+" | "+."), Pexp_constant(Pconst_float _) -> desc
+  | _ ->
+      Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg])
+
+(* TODO define an abstraction boundary between locations-as-pairs
+   and locations-as-Location.t; it should be clear when we move from
+   one world to the other *)
+
+let mkexp_cons_desc consloc args =
+  Pexp_construct(mkrhs (Lident "::") consloc, Some args)
+let mkexp_cons ~loc consloc args =
+  mkexp ~loc (mkexp_cons_desc consloc args)
+
+let mkpat_cons_desc consloc args =
+  Ppat_construct(mkrhs (Lident "::") consloc, Some ([], args))
+let mkpat_cons ~loc consloc args =
+  mkpat ~loc (mkpat_cons_desc consloc args)
+
+let ghexp_cons_desc consloc args =
+  Pexp_construct(ghrhs (Lident "::") consloc, Some args)
+let ghpat_cons_desc consloc args =
+  Ppat_construct(ghrhs (Lident "::") consloc, Some ([], args))
+
+let rec mktailexp nilloc = let open Location in function
+    [] ->
+      let nil = ghloc ~loc:nilloc (Lident "[]") in
+      Pexp_construct (nil, None), nilloc
+  | e1 :: el ->
+      let exp_el, el_loc = mktailexp nilloc el in
+      let loc = (e1.pexp_loc.loc_start, snd el_loc) in
+      let arg = ghexp ~loc (Pexp_tuple [e1; ghexp ~loc:el_loc exp_el]) in
+      ghexp_cons_desc loc arg, loc
+
+let rec mktailpat nilloc = let open Location in function
+    [] ->
+      let nil = ghloc ~loc:nilloc (Lident "[]") in
+      Ppat_construct (nil, None), nilloc
+  | p1 :: pl ->
+      let pat_pl, el_loc = mktailpat nilloc pl in
+      let loc = (p1.ppat_loc.loc_start, snd el_loc) in
+      let arg = ghpat ~loc (Ppat_tuple [p1; ghpat ~loc:el_loc pat_pl]) in
+      ghpat_cons_desc loc arg, loc
+
+let mkstrexp e attrs =
+  { pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc }
+
+let mkexp_constraint ~loc e (t1, t2) =
+  match t1, t2 with
+  | Some t, None -> ghexp ~loc (Pexp_constraint(e, t))
+  | _, Some t -> ghexp ~loc (Pexp_coerce(e, t1, t))
+  | None, None -> assert false
+
+let mkexp_opt_constraint ~loc e = function
+  | None -> e
+  | Some constraint_ -> mkexp_constraint ~loc e constraint_
+
+let mkpat_opt_constraint ~loc p = function
+  | None -> p
+  | Some typ -> ghpat ~loc (Ppat_constraint(p, typ))
+
+
+(*let syntax_error () =
+  raise Syntaxerr.Escape_error*)
+
+
+(* Using the function [not_expecting] in a semantic action means that this
+   syntactic form is recognized by the parser but is in fact incorrect. This
+   idiom is used in a few places to produce ad hoc syntax error messages. *)
+
+(* This idiom should be used as little as possible, because it confuses the
+   analyses performed by Menhir. Because Menhir views the semantic action as
+   opaque, it believes that this syntactic form is correct. This can lead
+   [make generate-parse-errors] to produce sentences that cause an early
+   (unexpected) syntax error and do not achieve the desired effect. This could
+   also lead a completion system to propose completions which in fact are
+   incorrect. In order to avoid these problems, the productions that use
+   [not_expecting] should be marked with AVOID. *)
+
+let not_expecting loc nonterm =
+  raise_error Syntaxerr.(Error(Not_expecting(make_loc loc, nonterm)))
+
+(*
+let unclosed opening_name opening_loc closing_name closing_loc =
+  raise(Syntaxerr.Error(Syntaxerr.Unclosed(make_loc opening_loc, opening_name,
+                                           make_loc closing_loc, closing_name)))
+*)
+
+let expecting loc nonterm =
+    raise_error Syntaxerr.(Error(Expecting(make_loc loc, nonterm)))
+
+(* Helper functions for desugaring array indexing operators *)
+type paren_kind = Paren | Brace | Bracket
+
+(* We classify the dimension of indices: Bigarray distinguishes
+   indices of dimension 1,2,3, or more. Similarly, user-defined
+   indexing operator behave differently for indices of dimension 1
+   or more.
+*)
+type index_dim =
+  | One
+  | Two
+  | Three
+  | Many
+type ('dot,'index) array_family = {
+  name:
+    Lexing.position * Lexing.position -> 'dot -> assign:bool -> paren_kind
+  -> index_dim -> Longident.t Location.loc
+  (*
+    This functions computes the name of the explicit indexing operator
+    associated with a sugared array indexing expression.
+    For instance, for builtin arrays, if Clflags.unsafe is set,
+    * [ a.[index] ]     =>  [String.unsafe_get]
+    * [ a.{x,y} <- 1 ]  =>  [ Bigarray.Array2.unsafe_set]
+    User-defined indexing operator follows a more local convention:
+    * [ a .%(index)]     => [ (.%()) ]
+    * [ a.![1;2] <- 0 ]  => [(.![;..]<-)]
+    * [ a.My.Map.?(0) => [My.Map.(.?())]
+  *);
+  index:
+    Lexing.position * Lexing.position -> paren_kind -> 'index
+    -> index_dim * (arg_label * expression) list
+   (*
+     [index (start,stop) paren index] computes the dimension of the
+     index argument and how it should be desugared when transformed
+     to a list of arguments for the indexing operator.
+     In particular, in both the Bigarray case and the user-defined case,
+     beyond a certain dimension, multiple indices are packed into a single
+     array argument:
+     * [ a.(x) ]       => [ [One, [Nolabel, <<x>>] ]
+     * [ a.{1,2} ]     => [ [Two, [Nolabel, <<1>>; Nolabel, <<2>>] ]
+     * [ a.{1,2,3,4} ] => [ [Many, [Nolabel, <<[|1;2;3;4|]>>] ] ]
+   *);
+}
+
+let bigarray_untuplify = function
+    { pexp_desc = Pexp_tuple explist; pexp_loc = _ } -> explist
+  | exp -> [exp]
+
+let builtin_arraylike_name loc _ ~assign paren_kind n =
+  let opname = if assign then "set" else "get" in
+  let opname = if !Clflags.fast then "unsafe_" ^ opname else opname in
+  let prefix = match paren_kind with
+    | Paren -> Lident "Array"
+    | Bracket -> Lident "String"
+    | Brace ->
+       let submodule_name = match n with
+         | One -> "Array1"
+         | Two -> "Array2"
+         | Three -> "Array3"
+         | Many -> "Genarray" in
+       Ldot(Lident "Bigarray", submodule_name) in
+   ghloc ~loc (Ldot(prefix,opname))
+
+let builtin_arraylike_index loc paren_kind index = match paren_kind with
+    | Paren | Bracket -> One, [Nolabel, index]
+    | Brace ->
+       (* Multi-indices for bigarray are comma-separated ([a.{1,2,3,4}]) *)
+       match bigarray_untuplify index with
+     | [x] -> One, [Nolabel, x]
+     | [x;y] -> Two, [Nolabel, x; Nolabel, y]
+     | [x;y;z] -> Three, [Nolabel, x; Nolabel, y; Nolabel, z]
+     | coords -> Many, [Nolabel, ghexp ~loc (Pexp_array coords)]
+
+let builtin_indexing_operators : (unit, expression) array_family  =
+  { index = builtin_arraylike_index; name = builtin_arraylike_name }
+
+let paren_to_strings = function
+  | Paren -> "(", ")"
+  | Bracket -> "[", "]"
+  | Brace -> "{", "}"
+
+let user_indexing_operator_name loc (prefix,ext) ~assign paren_kind n =
+  let name =
+    let assign = if assign then "<-" else "" in
+    let mid = match n with
+        | Many | Three | Two  -> ";.."
+        | One -> "" in
+    let left, right = paren_to_strings paren_kind in
+    String.concat "" ["."; ext; left; mid; right; assign] in
+  let lid = match prefix with
+    | None -> Lident name
+    | Some p -> Ldot(p,name) in
+  ghloc ~loc lid
+
+let user_index loc _ index =
+  (* Multi-indices for user-defined operators are semicolon-separated
+     ([a.%[1;2;3;4]]) *)
+  match index with
+    | [a] -> One, [Nolabel, a]
+    | l -> Many, [Nolabel, mkexp ~loc (Pexp_array l)]
+
+let user_indexing_operators:
+      (Longident.t option * string, expression list) array_family
+  = { index = user_index; name = user_indexing_operator_name }
+
+let mk_indexop_expr array_indexing_operator ~loc
+      (array,dot,paren,index,set_expr) =
+  let assign = match set_expr with None -> false | Some _ -> true in
+  let n, index = array_indexing_operator.index loc paren index in
+  let fn = array_indexing_operator.name loc dot ~assign paren n in
+  let set_arg = match set_expr with
+    | None -> []
+    | Some expr -> [Nolabel, expr] in
+  let args = (Nolabel,array) :: index @ set_arg in
+  mkexp ~loc (Pexp_apply(ghexp ~loc (Pexp_ident fn), args))
+
+  (*
+let indexop_unclosed_error loc_s s loc_e =
+  let left, right = paren_to_strings s in
+  unclosed left loc_s right loc_e
+  *)
+
+let lapply ~loc p1 p2 =
+  if !Clflags.applicative_functors
+  then Lapply(p1, p2)
+  else raise (Syntaxerr.Error(
+                  Syntaxerr.Applicative_path (make_loc loc)))
+
+(* [loc_map] could be [Location.map]. *)
+let loc_map (f : 'a -> 'b) (x : 'a Location.loc) : 'b Location.loc =
+  { x with txt = f x.txt }
+
+let make_ghost x = { x with loc = { x.loc with loc_ghost = true }}
+
+let loc_last (id : Longident.t Location.loc) : string Location.loc =
+  loc_map Longident.last id
+
+let loc_lident (id : string Location.loc) : Longident.t Location.loc =
+  loc_map (fun x -> Lident x) id
+
+let exp_of_longident ~loc lid =
+  let lid = make_ghost (loc_map (fun id -> Lident (Longident.last id)) lid) in
+  ghexp ~loc (Pexp_ident lid)
+
+let exp_of_label ~loc lbl =
+  mkexp ~loc (Pexp_ident (loc_lident lbl))
+
+let pat_of_label lbl =
+  Pat.mk ~loc:lbl.loc  (Ppat_var (loc_last lbl))
+
+let mk_newtypes ~loc newtypes exp =
+  let mkexp = mkexp ~loc in
+  List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp)))
+    newtypes exp
+
+let wrap_type_annotation ~loc newtypes core_type body =
+  let mkexp, ghtyp = mkexp ~loc, ghtyp ~loc in
+  let mk_newtypes = mk_newtypes ~loc in
+  let exp = mkexp(Pexp_constraint(body,core_type)) in
+  let exp = mk_newtypes newtypes exp in
+  (exp, ghtyp(Ptyp_poly(newtypes, Typ.varify_constructors newtypes core_type)))
+
+let wrap_exp_attrs ~loc body (ext, attrs) =
+  let ghexp = ghexp ~loc in
+  (* todo: keep exact location for the entire attribute *)
+  let body = {body with pexp_attributes = attrs @ body.pexp_attributes} in
+  match ext with
+  | None -> body
+  | Some id -> ghexp(Pexp_extension (id, PStr [mkstrexp body []]))
+
+let mkexp_attrs ~loc d attrs =
+  wrap_exp_attrs ~loc (mkexp ~loc d) attrs
+
+let wrap_typ_attrs ~loc typ (ext, attrs) =
+  (* todo: keep exact location for the entire attribute *)
+  let typ = {typ with ptyp_attributes = attrs @ typ.ptyp_attributes} in
+  match ext with
+  | None -> typ
+  | Some id -> ghtyp ~loc (Ptyp_extension (id, PTyp typ))
+
+let wrap_pat_attrs ~loc pat (ext, attrs) =
+  (* todo: keep exact location for the entire attribute *)
+  let pat = {pat with ppat_attributes = attrs @ pat.ppat_attributes} in
+  match ext with
+  | None -> pat
+  | Some id -> ghpat ~loc (Ppat_extension (id, PPat (pat, None)))
+
+let mkpat_attrs ~loc d attrs =
+  wrap_pat_attrs ~loc (mkpat ~loc d) attrs
+
+let wrap_class_attrs ~loc:_ body attrs =
+  {body with pcl_attributes = attrs @ body.pcl_attributes}
+let wrap_mod_attrs ~loc:_ attrs body =
+  {body with pmod_attributes = attrs @ body.pmod_attributes}
+let wrap_mty_attrs ~loc:_ attrs body =
+  {body with pmty_attributes = attrs @ body.pmty_attributes}
+
+let wrap_str_ext ~loc body ext =
+  match ext with
+  | None -> body
+  | Some id -> ghstr ~loc (Pstr_extension ((id, PStr [body]), []))
+
+let wrap_mkstr_ext ~loc (item, ext) =
+  wrap_str_ext ~loc (mkstr ~loc item) ext
+
+let wrap_sig_ext ~loc body ext =
+  match ext with
+  | None -> body
+  | Some id -> ghsig ~loc (Psig_extension ((id, PSig [body]), []))
+
+let wrap_mksig_ext ~loc (item, ext) =
+  wrap_sig_ext ~loc (mksig ~loc item) ext
+
+let mk_quotedext ~loc (id, idloc, str, strloc, delim) =
+  let exp_id = mkloc id idloc in
+  let e = ghexp ~loc (Pexp_constant (Pconst_string (str, strloc, delim))) in
+  (exp_id, PStr [mkstrexp e []])
+
+let text_str pos = Str.text (rhs_text pos)
+let text_sig pos = Sig.text (rhs_text pos)
+let text_cstr pos = Cf.text (rhs_text pos)
+let text_csig pos = Ctf.text (rhs_text pos)
+let text_def pos =
+  List.map (fun def -> Ptop_def [def]) (Str.text (rhs_text pos))
+
+let extra_text startpos endpos text items =
+  match items with
+  | [] ->
+      let post = rhs_post_text endpos in
+      let post_extras = rhs_post_extra_text endpos in
+      text post @ text post_extras
+  | _ :: _ ->
+      let pre_extras = rhs_pre_extra_text startpos in
+      let post_extras = rhs_post_extra_text endpos in
+        text pre_extras @ items @ text post_extras
+
+let extra_str p1 p2 items = extra_text p1 p2 Str.text items
+let extra_sig p1 p2 items = extra_text p1 p2 Sig.text items
+let extra_cstr p1 p2 items = extra_text p1 p2 Cf.text items
+let extra_csig p1 p2 items = extra_text p1 p2 Ctf.text  items
+let extra_def p1 p2 items =
+  extra_text p1 p2
+    (fun txt -> List.map (fun def -> Ptop_def [def]) (Str.text txt))
+    items
+
+let extra_rhs_core_type ct ~pos =
+  let docs = rhs_info pos in
+  { ct with ptyp_attributes = add_info_attrs docs ct.ptyp_attributes }
+
+(*
+type let_binding =
+  { lb_pattern: pattern;
+    lb_expression: expression;
+    lb_is_pun: bool;
+    lb_attributes: attributes;
+    lb_docs: docs Lazy.t;
+    lb_text: text Lazy.t;
+    lb_loc: Location.t; }
+
+type let_bindings =
+  { lbs_bindings: let_binding list;
+    lbs_rec: rec_flag;
+    lbs_extension: string Asttypes.loc option }
+*)
+
+let mklb first ~loc (p, e, is_pun) attrs =
+  {
+    lb_pattern = p;
+    lb_expression = e;
+    lb_is_pun = is_pun;
+    lb_attributes = attrs;
+    lb_docs = symbol_docs_lazy loc;
+    lb_text = (if first then empty_text_lazy
+               else symbol_text_lazy (fst loc));
+    lb_loc = make_loc loc;
+  }
+
+let addlb lbs lb =
+  if lb.lb_is_pun && lbs.lbs_extension = None then (
+    let err =
+      Syntaxerr.Expecting (lb.lb_loc, "let-extension (with punning)")
+    in
+    raise_error (Syntaxerr.Error err)
+  );
+  { lbs with lbs_bindings = lb :: lbs.lbs_bindings }
+
+let mklbs ext rf lb =
+  let lbs = {
+    lbs_bindings = [];
+    lbs_rec = rf;
+    lbs_extension = ext;
+  } in
+  addlb lbs lb
+
+let val_of_let_bindings ~loc lbs =
+  let bindings =
+    List.map
+      (fun lb ->
+         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
+           ~docs:(Lazy.force lb.lb_docs)
+           ~text:(Lazy.force lb.lb_text)
+           lb.lb_pattern lb.lb_expression)
+      lbs.lbs_bindings
+  in
+  let str = mkstr ~loc (Pstr_value(lbs.lbs_rec, List.rev bindings)) in
+  match lbs.lbs_extension with
+  | None -> str
+  | Some id -> ghstr ~loc (Pstr_extension((id, PStr [str]), []))
+
+let expr_of_let_bindings ~loc lbs body =
+  let bindings =
+    List.map
+      (fun lb ->
+         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
+           lb.lb_pattern lb.lb_expression)
+      lbs.lbs_bindings
+  in
+    mkexp_attrs ~loc (Pexp_let(lbs.lbs_rec, List.rev bindings, body))
+      (lbs.lbs_extension, [])
+
+let class_of_let_bindings ~loc lbs body =
+  let bindings =
+    List.map
+      (fun lb ->
+         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
+           lb.lb_pattern lb.lb_expression)
+      lbs.lbs_bindings
+  in
+    (* Our use of let_bindings(no_ext) guarantees the following: *)
+    assert (lbs.lbs_extension = None);
+    mkclass ~loc (Pcl_let (lbs.lbs_rec, List.rev bindings, body))
+
+(* Alternatively, we could keep the generic module type in the Parsetree
+   and extract the package type during type-checking. In that case,
+   the assertions below should be turned into explicit checks. *)
+let package_type_of_module_type pmty =
+  let err loc s =
+    raise_error (Syntaxerr.Error (Syntaxerr.Invalid_package_type (loc, s)))
+  in
+  let map_cstr = function
+    | Pwith_type (lid, ptyp) ->
+        let loc = ptyp.ptype_loc in
+        if ptyp.ptype_params <> [] then
+          err loc "parametrized types are not supported";
+        if ptyp.ptype_cstrs <> [] then
+          err loc "constrained types are not supported";
+        if ptyp.ptype_private <> Public then
+          err loc "private types are not supported";
+
+        (* restrictions below are checked by the 'with_constraint' rule *)
+        (* assert (ptyp.ptype_kind = Ptype_abstract); *)
+        (* assert (ptyp.ptype_attributes = []); *)
+        begin match ptyp.ptype_manifest with
+        | Some ty -> Some (lid, ty)
+        | None -> None
+        end
+    | _ ->
+        err pmty.pmty_loc "only 'with type t =' constraints are supported";
+        None
+  in
+  match pmty with
+  | {pmty_desc = Pmty_ident lid} -> (lid, [], pmty.pmty_attributes)
+  | {pmty_desc = Pmty_with({pmty_desc = Pmty_ident lid}, cstrs)} ->
+      (lid, List.filter_map map_cstr cstrs, pmty.pmty_attributes)
+  | _ ->
+      err pmty.pmty_loc
+        "only module type identifier and 'with type' constraints are supported"
+      ; (Location.mkloc (Lident "_") pmty.pmty_loc, [], [])
+
+let mk_directive_arg ~loc k =
+  { pdira_desc = k;
+    pdira_loc = make_loc loc;
+  }
+
+let mk_directive ~loc name arg =
+  Ptop_dir {
+      pdir_name = name;
+      pdir_arg = arg;
+      pdir_loc = make_loc loc;
+    }
+
+let merloc startpos ?endpos x =
+  let endpos = match endpos with
+    | None -> x.pexp_loc.Location.loc_end
+    | Some endpos -> endpos
+  in
+  let loc = make_loc (startpos, endpos) in
+  let str = mkloc "merlin.loc" loc in
+  let attr = { attr_name = str; attr_loc = loc; attr_payload = PStr [] } in
+  { x with pexp_attributes = attr :: x.pexp_attributes }
+
+let val_of_lwt_bindings ~loc lbs =
+  let bindings =
+    List.map
+      (fun lb ->
+         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
+           ~docs:(Lazy.force lb.lb_docs)
+           ~text:(Lazy.force lb.lb_text)
+           lb.lb_pattern (Fake.app Fake.Lwt.un_lwt lb.lb_expression))
+      lbs.lbs_bindings
+  in
+  let str = mkstr ~loc (Pstr_value(lbs.lbs_rec, List.rev bindings)) in
+  match lbs.lbs_extension with
+  | None -> str
+  | Some id -> ghstr ~loc (Pstr_extension((id, PStr [str]), []))
+
+let expr_of_lwt_bindings ~loc lbs body =
+  let bindings =
+    List.map
+      (fun lb ->
+         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
+           lb.lb_pattern (Fake.app Fake.Lwt.un_lwt lb.lb_expression))
+      lbs.lbs_bindings
+  in
+  Fake.app Fake.Lwt.in_lwt
+    (mkexp_attrs ~loc (Pexp_let(lbs.lbs_rec, List.rev bindings, body))
+       (lbs.lbs_extension, []))
+
+
+# 892 "src/ocaml/preprocess/parser_raw.ml"
+
+module Tables = struct
+  
+  include MenhirBasics
+  
+  let token2terminal : token -> int =
+    fun _tok ->
+      match _tok with
+      | AMPERAMPER ->
+          132
+      | AMPERSAND ->
+          131
+      | AND ->
+          130
+      | ANDOP _ ->
+          129
+      | AS ->
+          128
+      | ASSERT ->
+          127
+      | BACKQUOTE ->
+          126
+      | BANG ->
+          125
+      | BAR ->
+          124
+      | BARBAR ->
+          123
+      | BARRBRACKET ->
+          122
+      | BEGIN ->
+          121
+      | CHAR _ ->
+          120
+      | CLASS ->
+          119
+      | COLON ->
+          118
+      | COLONCOLON ->
+          117
+      | COLONEQUAL ->
+          116
+      | COLONGREATER ->
+          115
+      | COMMA ->
+          114
+      | COMMENT _ ->
+          113
+      | CONSTRAINT ->
+          112
+      | DO ->
+          111
+      | DOCSTRING _ ->
+          110
+      | DONE ->
+          109
+      | DOT ->
+          108
+      | DOTDOT ->
+          107
+      | DOTLESS ->
+          106
+      | DOTOP _ ->
+          105
+      | DOTTILDE ->
+          104
+      | DOWNTO ->
+          103
+      | ELSE ->
+          102
+      | END ->
+          101
+      | EOF ->
+          100
+      | EOL ->
+          99
+      | EQUAL ->
+          98
+      | EXCEPTION ->
+          97
+      | EXTERNAL ->
+          96
+      | FALSE ->
+          95
+      | FINALLY_LWT ->
+          94
+      | FLOAT _ ->
+          93
+      | FOR ->
+          92
+      | FOR_LWT ->
+          91
+      | FUN ->
+          90
+      | FUNCTION ->
+          89
+      | FUNCTOR ->
+          88
+      | GREATER ->
+          87
+      | GREATERDOT ->
+          86
+      | GREATERRBRACE ->
+          85
+      | GREATERRBRACKET ->
+          84
+      | HASH ->
+          83
+      | HASHOP _ ->
+          82
+      | IF ->
+          81
+      | IN ->
+          80
+      | INCLUDE ->
+          79
+      | INFIXOP0 _ ->
+          78
+      | INFIXOP1 _ ->
+          77
+      | INFIXOP2 _ ->
+          76
+      | INFIXOP3 _ ->
+          75
+      | INFIXOP4 _ ->
+          74
+      | INHERIT ->
+          73
+      | INITIALIZER ->
+          72
+      | INT _ ->
+          71
+      | LABEL _ ->
+          70
+      | LAZY ->
+          69
+      | LBRACE ->
+          68
+      | LBRACELESS ->
+          67
+      | LBRACKET ->
+          66
+      | LBRACKETAT ->
+          65
+      | LBRACKETATAT ->
+          64
+      | LBRACKETATATAT ->
+          63
+      | LBRACKETBAR ->
+          62
+      | LBRACKETGREATER ->
+          61
+      | LBRACKETLESS ->
+          60
+      | LBRACKETPERCENT ->
+          59
+      | LBRACKETPERCENTPERCENT ->
+          58
+      | LESS ->
+          57
+      | LESSMINUS ->
+          56
+      | LET ->
+          55
+      | LETOP _ ->
+          54
+      | LET_LWT ->
+          53
+      | LIDENT _ ->
+          52
+      | LPAREN ->
+          51
+      | MATCH ->
+          50
+      | MATCH_LWT ->
+          49
+      | METHOD ->
+          48
+      | MINUS ->
+          47
+      | MINUSDOT ->
+          46
+      | MINUSGREATER ->
+          45
+      | MODULE ->
+          44
+      | MUTABLE ->
+          43
+      | NEW ->
+          42
+      | NONREC ->
+          41
+      | OBJECT ->
+          40
+      | OF ->
+          39
+      | OPEN ->
+          38
+      | OPTLABEL _ ->
+          37
+      | OR ->
+          36
+      | PERCENT ->
+          35
+      | PLUS ->
+          34
+      | PLUSDOT ->
+          33
+      | PLUSEQ ->
+          32
+      | PREFIXOP _ ->
+          31
+      | PRIVATE ->
+          30
+      | QUESTION ->
+          29
+      | QUOTE ->
+          28
+      | QUOTED_STRING_EXPR _ ->
+          27
+      | QUOTED_STRING_ITEM _ ->
+          26
+      | RBRACE ->
+          25
+      | RBRACKET ->
+          24
+      | REC ->
+          23
+      | RPAREN ->
+          22
+      | SEMI ->
+          21
+      | SEMISEMI ->
+          20
+      | SIG ->
+          19
+      | STAR ->
+          18
+      | STRING _ ->
+          17
+      | STRUCT ->
+          16
+      | THEN ->
+          15
+      | TILDE ->
+          14
+      | TO ->
+          13
+      | TRUE ->
+          12
+      | TRY ->
+          11
+      | TRY_LWT ->
+          10
+      | TYPE ->
+          9
+      | UIDENT _ ->
+          8
+      | UNDERSCORE ->
+          7
+      | VAL ->
+          6
+      | VIRTUAL ->
+          5
+      | WHEN ->
+          4
+      | WHILE ->
+          3
+      | WHILE_LWT ->
+          2
+      | WITH ->
+          1
+  
+  and error_terminal =
+    0
+  
+  and token2value : token -> Obj.t =
+    fun _tok ->
+      match _tok with
+      | AMPERAMPER ->
+          Obj.repr ()
+      | AMPERSAND ->
+          Obj.repr ()
+      | AND ->
+          Obj.repr ()
+      | ANDOP _v ->
+          Obj.repr _v
+      | AS ->
+          Obj.repr ()
+      | ASSERT ->
+          Obj.repr ()
+      | BACKQUOTE ->
+          Obj.repr ()
+      | BANG ->
+          Obj.repr ()
+      | BAR ->
+          Obj.repr ()
+      | BARBAR ->
+          Obj.repr ()
+      | BARRBRACKET ->
+          Obj.repr ()
+      | BEGIN ->
+          Obj.repr ()
+      | CHAR _v ->
+          Obj.repr _v
+      | CLASS ->
+          Obj.repr ()
+      | COLON ->
+          Obj.repr ()
+      | COLONCOLON ->
+          Obj.repr ()
+      | COLONEQUAL ->
+          Obj.repr ()
+      | COLONGREATER ->
+          Obj.repr ()
+      | COMMA ->
+          Obj.repr ()
+      | COMMENT _v ->
+          Obj.repr _v
+      | CONSTRAINT ->
+          Obj.repr ()
+      | DO ->
+          Obj.repr ()
+      | DOCSTRING _v ->
+          Obj.repr _v
+      | DONE ->
+          Obj.repr ()
+      | DOT ->
+          Obj.repr ()
+      | DOTDOT ->
+          Obj.repr ()
+      | DOTLESS ->
+          Obj.repr ()
+      | DOTOP _v ->
+          Obj.repr _v
+      | DOTTILDE ->
+          Obj.repr ()
+      | DOWNTO ->
+          Obj.repr ()
+      | ELSE ->
+          Obj.repr ()
+      | END ->
+          Obj.repr ()
+      | EOF ->
+          Obj.repr ()
+      | EOL ->
+          Obj.repr ()
+      | EQUAL ->
+          Obj.repr ()
+      | EXCEPTION ->
+          Obj.repr ()
+      | EXTERNAL ->
+          Obj.repr ()
+      | FALSE ->
+          Obj.repr ()
+      | FINALLY_LWT ->
+          Obj.repr ()
+      | FLOAT _v ->
+          Obj.repr _v
+      | FOR ->
+          Obj.repr ()
+      | FOR_LWT ->
+          Obj.repr ()
+      | FUN ->
+          Obj.repr ()
+      | FUNCTION ->
+          Obj.repr ()
+      | FUNCTOR ->
+          Obj.repr ()
+      | GREATER ->
+          Obj.repr ()
+      | GREATERDOT ->
+          Obj.repr ()
+      | GREATERRBRACE ->
+          Obj.repr ()
+      | GREATERRBRACKET ->
+          Obj.repr ()
+      | HASH ->
+          Obj.repr ()
+      | HASHOP _v ->
+          Obj.repr _v
+      | IF ->
+          Obj.repr ()
+      | IN ->
+          Obj.repr ()
+      | INCLUDE ->
+          Obj.repr ()
+      | INFIXOP0 _v ->
+          Obj.repr _v
+      | INFIXOP1 _v ->
+          Obj.repr _v
+      | INFIXOP2 _v ->
+          Obj.repr _v
+      | INFIXOP3 _v ->
+          Obj.repr _v
+      | INFIXOP4 _v ->
+          Obj.repr _v
+      | INHERIT ->
+          Obj.repr ()
+      | INITIALIZER ->
+          Obj.repr ()
+      | INT _v ->
+          Obj.repr _v
+      | LABEL _v ->
+          Obj.repr _v
+      | LAZY ->
+          Obj.repr ()
+      | LBRACE ->
+          Obj.repr ()
+      | LBRACELESS ->
+          Obj.repr ()
+      | LBRACKET ->
+          Obj.repr ()
+      | LBRACKETAT ->
+          Obj.repr ()
+      | LBRACKETATAT ->
+          Obj.repr ()
+      | LBRACKETATATAT ->
+          Obj.repr ()
+      | LBRACKETBAR ->
+          Obj.repr ()
+      | LBRACKETGREATER ->
+          Obj.repr ()
+      | LBRACKETLESS ->
+          Obj.repr ()
+      | LBRACKETPERCENT ->
+          Obj.repr ()
+      | LBRACKETPERCENTPERCENT ->
+          Obj.repr ()
+      | LESS ->
+          Obj.repr ()
+      | LESSMINUS ->
+          Obj.repr ()
+      | LET ->
+          Obj.repr ()
+      | LETOP _v ->
+          Obj.repr _v
+      | LET_LWT ->
+          Obj.repr ()
+      | LIDENT _v ->
+          Obj.repr _v
+      | LPAREN ->
+          Obj.repr ()
+      | MATCH ->
+          Obj.repr ()
+      | MATCH_LWT ->
+          Obj.repr ()
+      | METHOD ->
+          Obj.repr ()
+      | MINUS ->
+          Obj.repr ()
+      | MINUSDOT ->
+          Obj.repr ()
+      | MINUSGREATER ->
+          Obj.repr ()
+      | MODULE ->
+          Obj.repr ()
+      | MUTABLE ->
+          Obj.repr ()
+      | NEW ->
+          Obj.repr ()
+      | NONREC ->
+          Obj.repr ()
+      | OBJECT ->
+          Obj.repr ()
+      | OF ->
+          Obj.repr ()
+      | OPEN ->
+          Obj.repr ()
+      | OPTLABEL _v ->
+          Obj.repr _v
+      | OR ->
+          Obj.repr ()
+      | PERCENT ->
+          Obj.repr ()
+      | PLUS ->
+          Obj.repr ()
+      | PLUSDOT ->
+          Obj.repr ()
+      | PLUSEQ ->
+          Obj.repr ()
+      | PREFIXOP _v ->
+          Obj.repr _v
+      | PRIVATE ->
+          Obj.repr ()
+      | QUESTION ->
+          Obj.repr ()
+      | QUOTE ->
+          Obj.repr ()
+      | QUOTED_STRING_EXPR _v ->
+          Obj.repr _v
+      | QUOTED_STRING_ITEM _v ->
+          Obj.repr _v
+      | RBRACE ->
+          Obj.repr ()
+      | RBRACKET ->
+          Obj.repr ()
+      | REC ->
+          Obj.repr ()
+      | RPAREN ->
+          Obj.repr ()
+      | SEMI ->
+          Obj.repr ()
+      | SEMISEMI ->
+          Obj.repr ()
+      | SIG ->
+          Obj.repr ()
+      | STAR ->
+          Obj.repr ()
+      | STRING _v ->
+          Obj.repr _v
+      | STRUCT ->
+          Obj.repr ()
+      | THEN ->
+          Obj.repr ()
+      | TILDE ->
+          Obj.repr ()
+      | TO ->
+          Obj.repr ()
+      | TRUE ->
+          Obj.repr ()
+      | TRY ->
+          Obj.repr ()
+      | TRY_LWT ->
+          Obj.repr ()
+      | TYPE ->
+          Obj.repr ()
+      | UIDENT _v ->
+          Obj.repr _v
+      | UNDERSCORE ->
+          Obj.repr ()
+      | VAL ->
+          Obj.repr ()
+      | VIRTUAL ->
+          Obj.repr ()
+      | WHEN ->
+          Obj.repr ()
+      | WHILE ->
+          Obj.repr ()
+      | WHILE_LWT ->
+          Obj.repr ()
+      | WITH ->
+          Obj.repr ()
+  
+  and default_reduction =
+    (16, "\000\000\000\000\000\000\002\214\002\213\002\212\002\211\002\210\002\165\002\209\002\208\002\207\002\206\002\205\002\204\002\203\002\202\002\201\002\200\002\199\002\198\002\197\002\196\002\195\002\194\002\193\002\192\002\191\002\164\002\190\002\189\002\188\002\187\002\186\002\185\002\184\002\183\002\182\002\181\002\180\002\179\002\178\002\177\002\176\002\175\002\174\002\173\002\172\002\171\002\170\002\169\002\168\002\167\002\166\000\000\000\000\000*\000\188\000\000\000\000\000\000\000\000\000\000\000\000\002\134\001W\000\000\000\000\000\000\000\000\000\000\000\000\000f\000a\000\190\000\000\000\000\000\000\000\000\001U\000\000\000\000\001X\001V\001]\000A\002u\000\000\001\024\000\000\001\174\000d\000\000\003\025\000\000\000\000\000\000\000\000\000\000\000\000\001\153\001\171\001\170\001\169\001\175\001\179\001\173\001\172\001\154\001\177\001\168\001\167\001\166\001\165\001\164\001\162\001\178\001\176\000\000\000\000\000\000\000\223\000\000\000\000\001\157\000\000\000\000\000\000\001\159\000\000\000\000\000\000\001\161\001\183\001\180\001\163\001\155\001\181\001\182\000\000\003\024\000\000\000\000\000\024\001K\000\000\000\219\000\220\000\023\000\000\000\000\001\205\001\204\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\021\000\000\003\016\000\000\000\000\003\018\000\000\003\020\000\000\003\017\003\019\000\000\003\011\000\000\003\n\003\006\002,\000\000\003\t\000\000\002-\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001I\000\000\000\000\000\000\000\000\000\000\000\000\001\187\000\000\000\000\000%\000\000\000\000\000\000\000\000\000\000\000\000\001\\\000\000\001L\001[\000\000\001J\000^\000\030\000\000\000\000\001\130\000\025\000\000\000\000\000\000\000\000\003\005\000(\000\000\000\000\000\031\000\026\000\000\000\000\000\000\000\203\000\000\000\000\000\000\000\205\0026\002(\000\000\000\"\000\000\002)\000\000\000\000\001\184\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\017\002\241\000\000\002\242\000\000\000u\000\000\000\000\000!\000\000\000\000\000\000\000#\000\000\000$\000\000\000&\000\000\000\000\000'\002\030\002\029\000\000\000\000\002 \000\000\000\000\000\000\000\000\000\000\000\000\001A\001;\000\000\000\000\001<\000\000\000\029\000\000\000\028\000\000\000\000\000\204\000\000\000h\000\000\000\000\000\000\000 \000\027\000\000\000\000\000\000\000\021\000\000\000\000\000\000\000c\000\000\001|\000\000\000\000\000\000\000\000\000\000\000\000\000\228\000\000\001\146\000\000\000\231\000\229\000e\001\142\000\000\000g\000\000\000\000\000\000\000\000\000\000\000\000\000q\000\000\000\000\000\000\000\210\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\213\000i\000\000\000\000\002\r\002\011\002\012\000\000\001\138\000\000\000\000\000\214\000\000\000\000\001\145\001\141\003\004\000\000\000\000\000\000\000\000\000\000\001\148\001\144\001\140\000\000\000\000\001\147\001\143\001\139\001\137\000\000\002\023\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\023\000\000\000\000\000\000\000\000\000\000\000\000\001\030\000\218\000\000\000\000\002\001\000\000\000\000\000\000\000\000\000\000\000\000\000l\000\000\000\000\000\000\000\000\000k\000\000\000\191\000m\000\000\002\230\002\018\002\019\002\014\002\016\002\015\002\017\000\000\000\000\000\000\000\192\003\b\000\000\000\000\002\023\000\000\000\217\000\000\000\000\000\000\000\000\002\229\000\000\000\226\000\015\000\014\000\000\000\000\000\000\000\000\001k\000\000\000\000\000\000\000\000\000\000\000\000\002\152\000\000\002`\002a\000\000\002^\002_\000\000\000\000\000\000\000\000\000\000\001m\001l\000\000\002\150\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\240\002\239\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\b\000\000\000\000\000\000\000\000\000\234\000\000\002b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000_\000\000\002\157\000b\000`\002\146\003\026\002\147\001\236\002\149\000\000\000\000\002\154\002]\002\156\000\000\000\000\000\000\002\160\000\000\000\000\000\000\001\232\001\223\000\000\000\000\000\000\000\000\000\000\001\222\000\000\001\235\002\163\000\000\000\000\000\000\000\000\001\132\000\000\000\000\001\234\002\155\000\000\000\000\002\148\000\000\000\000\000\000\000\000\002\162\000\000\000\000\000\000\001\224\001\233\001\227\000\000\002\161\000\000\002\159\000\000\002c\000\000\000\000\002@\002\158\000\000\000\000\000\000\000\000\001\189\0013\0014\002e\000\000\002d\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\244\000\245\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\244\000\000\000\000\000\000\000\000\000\000\000\000\000\242\001\243\000\243\000\000\000\000\000\000\000\000\000\000\000\246\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\206\000\000\000\000\000\000\000\000\000\000\000\000\002\026\000\000\000\000\001t\000\000\000\000\000\000\000\000\000\000\000\000\0031\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001s\000\000\000\000\000\000\001T\001z\001S\001w\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002&\000\000\000\000\002'\002\025\000\000\001r\000\000\000\207\000\000\000\000\001e\000\000\000\000\001i\000\000\001\207\000\000\000\000\001\206\001h\001f\000\000\001j\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002x\001Y\002}\002{\000\000\000\000\000\000\002\135\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\237\000\000\000\238\000\000\000\000\000\000\002\131\000\000\000\000\000\000\002j\000\000\000\000\000\000\000\000\003\027\002\133\002z\002y\000\000\000\000\000x\0016\000\000\000\000\000\172\000\000\000\000\000\000\000\000\000\000\000\186\000\000\000\000\000\000\000\171\000\000\000\000\000\000\002G\002F\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\255\000\000\000\000\000\254\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\240\001\238\001\239\000\000\000\000\000\000\000\248\000\000\000\018\001\001\0017\000\000\000\000\000\000\002l\000\000\000\000\002k\000\000\000\000\000\000\000\000\002n\000\000\000\000\002:\000\000\000\000\002r\000\000\000\000\002p\002\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\028\002\027\000\170\000\000\002m\000\000\000\000\002q\000\000\000\000\002o\001\t\000\000\000\000\001\n\000\000\000\000\000\173\000\000\001\012\001\011\000\000\000\000\002\129\000\000\002\141\000\000\002\140\000\000\002\144\000\000\002\143\000\000\000\000\002\130\000\000\000\000\000\000\002\n\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\203\000\000\000\000\000\000\002C\002\t\000\000\002\137\000\000\000\000\000\000\001Z\000\000\000v\000w\000\000\000\000\000\000\000\000\000\142\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\127\000\198\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\199\000\247\000\000\000\200\000\201\000\136\000\000\000\135\000\000\000\000\0019\000\000\001:\0018\002\"\000\000\000\000\002#\002!\000\000\000\000\000\000\000\000\000\000\002t\000\000\002s\000\000\000\000\002f\000\000\000\000\002\136\000\000\000\000\000\000\002=\002\127\000\000\002~\000\000\002\142\002\139\000\000\002\138\000\133\000\000\000\000\000\000\000\000\000\132\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\130\000\000\001`\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\131\000\000\000\000\000\000\000\000\001\000\002\217\000\000\000\000\000\197\000\196\000\000\002\218\002\219\001\007\001\201\000\000\000\240\000\241\000\000\000\000\000\000\000\000\000\000\000\000\000\253\000\000\000\000\000\000\000\000\000\252\000\000\000\000\000\251\000\250\000\000\0015\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\208\000\000\000\000\001\211\000\000\000\000\001\209\000\000\000\000\001\210\000\000\000\000\002\151\000\000\000B\000\000\000\000\000C\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\030\000\000\000\000\003 \000\000\0006\000\000\000\000\003&\000\000\003%\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\029\000\000\000\000\003\031\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001H\000\000\000\000\000\000\000\000\000\000\001F\000\000\001D\000\000\0007\000\000\000\000\003)\000\000\003(\000\000\000\000\000\000\001B\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001G\000\000\000\000\001E\001C\000\000\000\000\000\000\000\000\000\000\001\249\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001x\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\020\002\233\000\000\000\000\002\232\000\000\000\000\000\000\000\000\000\000\000\000\002\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\134\000\000\001\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\216\000\000\000\000\002H\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\152\000\000\000\000\000\000\001\151\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001y\000\000\000\000\000\000\000\000\000\000\001n\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\022\002V\000\000\000\000\000\000\002T\000\000\000\000\000\000\002S\000\000\001b\000\000\000\000\000\000\000\000\002Z\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003#\000\000\000\000\000\000\000\195\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000E\000\000\000\000\000\000\000\000\001\129\000\000\001\128\000\000\000\000\000\000\000\000\000H\000\000\000\000\000\000\002\006\000\000\002\005\000\000\000\000\000\000\000\000\000I\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000N\000\000\000\000\000\000\000O\000M\000\000\000Q\000\000\000\000\000\000\000\000\000\000\000G\000\000\000\000\000\000\000\000\000\000\000\000\000J\000\000\000P\000\000\000K\000L\000\000\001'\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\018\000]\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000Z\000\000\000\\\000[\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\016\002[\002L\000\000\002R\002M\002Y\002X\002W\002U\001!\000\000\002J\000\000\000\000\000\000\000\000\000\000\002\023\000\000\000\000\001\026\002N\000\000\000\000\000\000\000\000\000\000\000\000\002\023\000\000\000\000\001\028\002O\002K\002\\\001 \001\246\002I\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0009\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\003\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000V\000\000\000\000\000\000\000\000\000\000\000\000\0003\000\000\000\000\000U\000\000\0001\001\004\000\000\000@\000-\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\002\000\000\000T\000\000\000\000\000W\000\000\000\000\001\191\000\000\0005\000\000\000\000\000\000\0004\000\000\000\000\000\000\0008\000\000\000X\000\000\000:\000;\000\000\001)\000\000\000\000\000\000\000\000\000\000\000\000\000>\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\014\002\236\002\227\000\000\000\000\002\231\002\215\002\226\002\235\002\234\000\000\001%\000\000\000\000\002\224\000\000\002\228\002\225\002\237\001\245\000\000\000\000\002\221\000\000\000\193\000\000\002\220\000\000\000\000\000\225\000\000\000\145\000\000\001c\000\000\001\150\000\000\000\000\000\000\001\149\000\000\000\000\001$\001#\000\000\001\254\000\216\000\000\000\000\000\000\000\000\002Q\002\022\002\020\002\021\000\000\000\000\000\000\002\023\000\000\000\215\000\000\000\000\000\000\000\000\002P\000\000\001o\000\000\000\022\000\000\003!\000\000\000\189\002|\000\000\000\000\000\000\000\000\002v\000\000\000\000\002w\000\000\002h\000\000\002i\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000}\000\000\000|\000\000\000\000\000\000\000\141\000\000\000+\000\000\000\000\000\000\000\000\000~\000\000\000\221\000\001\000\000\000\000\000\224\000\002\000\000\000\000\000\000\001N\001O\000\003\000\000\000\000\000\000\000\000\001Q\001R\001P\000\019\001M\000\020\000\000\001\212\000\000\000\004\000\000\001\213\000\000\000\005\000\000\001\214\000\000\000\000\001\215\000\006\000\000\000\007\000\000\001\216\000\000\000\b\000\000\001\217\000\000\000\t\000\000\001\218\000\000\000\000\001\219\000\n\000\000\000\000\001\220\000\011\000\000\000\000\000\000\000\000\000\000\002\249\002\244\002\245\002\248\002\246\000\000\002\253\000\012\000\000\002\252\000\000\001+\000\000\000\000\002\250\000\000\002\251\000\000\000\000\000\000\000\000\001/\0010\000\000\000\000\001.\001-\000\r\000\000\000\000\000\000\003\023\000\000\003\022")
+  
+  and error =
+    (133, "3\248H1b\171\1273=\001@}\200\160\001\199\001\141\194\000\139\133\027\248\147\232\002\003\232\005\000\0068\023\183d@\130\254*@\0010p:q\193`Ph\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\223\235f\245\155\175\252\205\255%C\247\018\162\015<\011\219\178 A\127\021 \000\1528\0298\224\176(4\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012n\016\004X(\223\196\159@\016\031@(\0001\192\189\187\"\004\023\241R\000\t\131\129\211\142\011\002\131C?\132\139V*\183\2433\208\020\007\220\n\000<p\024\220 \b\184Q\191\137>\128 >\128P\000c\128\198\225\000E\130\141\252I\244\001\001\244\002\128\003\028\0067\b\002,\020o\226G\160\b\015\160\020\000\024\224\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012n\016\004\\(\223\196\159@\016\031@(\0001\192cp\128\"\193F\254$\250\000\128\250\001@\001\142\003\027\132\001\022\n7\241#\208\004\007\208\n\000\012p\024\220 \b\184Q\191\137>\128 >\128P\000c\128\198\225\000E\130\141\252I\244\001\001\244\002\128\003\028\0067\b\002,\020o\226G\160\b\015\160\020\000\024\224\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\016\128\"\000@0$r\000\000\n\001@\001\140\000\b\000\000\001\000\000\128\004\000\000\000\000\000\000\000\000\000@\000\000\000\000\004\000 \000\000\000\000\000\000\000\000\002\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\004\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006\255[\191\236\223\127\239\255\249:?\185\150\0169\228\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\141\195\016\143\197[\250\145\233\243\011\233\007\000f\186\192\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\024\132!\016\002\001\129#\144\000\000P\n\000\012`\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001{vD\b/\226\164\000\019\007\003\167\028\022\005\006\134\127\t\022\172Uo\230g\160(\015\184\020\000x\224\000\000\000\000\016\000\024\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\192\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006\000\000\000\000\000\000\000\000\000\000\000\000@\003\240\006\004\128\000|B\000@\128\016(\176\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\160\000\000\000\000\000\000\000\000\000\000\192\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\006\000\000p\016\000ap\128\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\000\000\224 @\194\225\000\000\128\000\000\000\000\000\000 \004\004\004\002\006\004\016\000\000 \000\000\000\000\000\001\000  \000\0160 \128\000\001\000\000\000\000\000\000\b\001\001\000\000\129\129\000\000\000\b\000\000\000\000\000! \005P\001\006\n\144\224\000\136\000v\004\012\128\016\t\000 \128\b \000\133\000\004\000\003\016\000\004\000\000H\001\004\000A\000\004 \000 \000\024\128\000 \000\001\128\000\t0A\024\000@\b\000\000\000\000\000\004\000\012\000\000I\002\b\192\002\000@\000\000\000\000\000 \000`\000\002H\016F\000\000\002\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\128\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006\000\000$\128\004`\000\000 \000\000\000\000\000\016\000 \000\001\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000I\000\b\000\000\000@\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\016@\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000$\128\004\000\000\000 \000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\018\000E\004\016@\001\012\000\b\000\007`\004H\001\000b\000\007\129\000\006\023\n\000\004\000@\004\000\002\000\004\128\017@\006\016*C\128\002 \001\152\017\006\016@\024\128\001\192@\001\133\194\128\001\000\016\001\000\000\128\000\192\001\014\002\004\012.\016\000\b\000\000\000\002\000\001\011\000\187\128\b24\135\003\004D\003\176\002\204\"\1920\000\003\000\000\003\011\132\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\000\000\192\000\000\194\225\000\000\136\000\000\128\000\000\000 \001\000\000\000\002\000\000\000\004@\000\000\000\128\000\003\000\0008\b\0000\184@\000 \000\000\000\000\000\000\b\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\001@\0184\000\002D\016\224`\b\128\018\004H\000@\006\000\000p\016\000ap\128\000@\000\000\000\000(\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\128\000\028\004\000\024\\ \000\016\000\000\000\000\002\000\012\000\004\224 \000\194\225\000\000\128\000\000\000\000P\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\000\0008\b\0000\184@\000 \000\000\000\000\004\000\024\000\001\192@\001\133\194\000\001\000\000\000\000\000\160\000@\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000 \000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\016\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\000\000\224 \000\194\225\000\000\128\000\000\000\000\016\000 \000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000! \007p\001\006B\144\224`\136\128v\000X\132X\006\000\000p\016\000ap\128\000@\000\000\000\000\000\bH\005\220\000A\144\1648\024\" \029\128\022!\022\001\128\000\024\000\000\024\\ \000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\133\128]\192\004\025\026C\129\130\"\001\216\001b\017`\b\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0000\000\003\000\000\003\011\132\000\002\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\012\000\000\224 \000\194\225\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\133\128]\192\004\025\026C\129\130\"\001\216\001b\017`\024\000\001\128\000\001\133\194\000\001\000\000\000\000\000\000!`\023p\001\006F\144\224`\136\128v\000X\132X\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\000\0008\b\0000\184@\000 \000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\128\000\000 \000\000\128\000\000\000\004\000\006\000\000p\016\000ap\128\000@\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\128\000\028\004\000\024\\ \000\016\000\000\000\000\000\000\000\000\004\000\000\000\000\002\000\000\b\000\000\000\000@\128`\000\007\001\000\006\023\b\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\004\000\000\016\000\000\000\000\137\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\002\000\000\b\000\000\000\000D\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\128\000\002\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000! \007p\001\006B\144\224`\136\128v\000X\132P\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\012\000\000\224 \000\194\225\000\000\128\000\000\000\000\016\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\004\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000\004\000\000\000\002\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\128\000\028\004\000\024\\ \000\016\000\000\000\000\000\000\000\000\"\000\000\000\000\002\000\000\b\000\000\000\000\004\000\000\001\000\000\000\000\000\016\000\000@\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\002\000\000\000\000\000\000\024\000\001\128\000\001\133\198\000\001\016\000\001\000\000\000\000\192\000\012\000\000\012.\016\000\b\128\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\004\000\000\000\b\000\000\000\017\000\000\000\000\000\000\012\000\000\192\000\000\194\225\000\000\136\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\128\000\000\000\000\128\000\002\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\001\128\000\028\004\000\024\\ \000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\002\000\000\000@\000\000\000\000\004\000\000\000\b\000\000\000\000\000\000\002\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\000\000\224 \000\194\225\000\000\128\000\000\000\000\000\000\000\000\128\000\000\000\000\016\000\000\000\000\000\b\000\000\000\000\004\000\000\000\000\000\128\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\192\000\014\002\000\012.\016\000\b\000\000\000\000\000\000\000\000\b\000\000\000\000\001\000\000\000\000\000\000\128\000\0000\000\019\128\128\003\011\132\000\002\000\000\000\000\001@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\192\000\014\002\000\012.\016\000\b\000\000\000\000\000\000\000\000\017\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\136\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\016\b\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\001\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\022@E\000\016@\169\r\000\b\128\014`\004\b\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\001 \004P\001\132\002\144\224\000\136\000f\000A\132\016\006\000\000`\000\000ap\160\000@\000\000\000\000\000\000\000\000\000\000\002\001\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\000\0000\000\0000\184@\000 \000\000\000\000\000\000,\002\138\000 \192\210\028\000\025\000\012\192\b\016\130\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\000\162\128\b 4\135\000\006@\0030\002\004 \1280\000\003\000\000\003\011\133\000\002\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\012\000\000\192\000\000\194\225\000\000\128\000\000\000\000\000\000\176\002(\000\130\003Hp\000d\0003\000 B\b\005\128Q@\004\024\026C\128\003 \001\152\001\002\016@$\000\138\000 \128R\028\000\017\000\012\192\b\016\130\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000H\001\020\000A\000\1640\000\"\000\025\128\016!\004\000\136\000\000\000\000\016\000 \000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000$\000\138\000 \128R\028\000\017\000\012\192\b\016\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\000\"\128\012 \020\135\000\004@\0030\002\012 \128H\001\020\000A\000\1648\000\"\000\025\128\016!\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128@\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\000\"\128\b \020\135\000\004@\003\176\002\004\000\128\017\000\000@\000\002\000\005\000\000\000 \002\000\001\000\000\136\000\000\000\000\016\000(\000\000\001\000\016\000\b\000\000\000\000\000\000\128@\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@ \000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\024\128\001\224@\001\133\194\128\001\000\016\001\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\000\"\128\b \000\134\000\004\000\0030\002\004\000\139\219\178 A\127\021 \000\1528\0298\224\176(43\248H\181b\171\1273=\001@}\192\160\003\199\000\012\000\000I\130\b\192\002\000@\000\000\000\000\000 \000`\000\002H\016F\000\016\002\000\000\000\000\000\001\000\003\000\000\018@\1300\000\000\016\000\000\000\000\000\b\000\024\000\000\146\000\017\128\000\000\128\000\000\000\000\000@\000@\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\t\000\"\130\b \020\134\000\004@\003\176\002\004\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002@\b\160\002\b\005!\128\001\016\000\204\000\129\000 \012\000\000\224 \000\194\225\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\b\000\000\000\000\003\000\0008\b\0000\184@\000 \000\000\000\000\000\004$\000\170\000 \192R\028\000\017\000\014\192\t\016\002\001 \004P\001\004B\144\192`\200\000f\000@\128\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\004@\000\016\000\000\128\001\000\000\000\b\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\016\000\000\000\000 \000@\000\000\002\000\000\000\016\000\b\128\000\000\000\001\000\002\000\000\000\016\000\000\000\000\001 \004P\001\132\002\144\224\000\136\000v\000\001\132\000\002 \000\000\000\000@\000\128\000\000\004\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\144\002(\000\130\001Hp\000D\0003\002\000B\000\001\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000H\001\020\000A\000\1648\000\"\000\025\128\000!\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\144\002(\000\130\001H`\000D\0003\000\000B\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\144\002(\000\194\001Hp\000D\000;\000\000\194\000\001\016\000\000\000\000 \000@\000\000\002\000\000\000\000\000$\000\138\000 \128R\028\000\017\000\012\192\000\016\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\002@\b\160\130\b\005!\128\001\016\000\236\000\129\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\144\002(\000\130\001H`\000D\0003\000 @\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000D\000\001\000\000\b\000\016\000\000\000\128\000\000\004\000\002 \000\000\000\000@\000\128\000\000\004\000\000\000 \000H\001\020\000A\000\1640\000\"\000\025\128\000!\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\159\194E\139\021[\249\153\232\n\003\238e\000\0148\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\192@\b\b\000\b\b \000\000@\000\000\000\002\000\006\002\000@@\000@A\000\000\002\000\000\000\000\000\0000\016\002\000\000\002\002\b\000\000\016\000\000\000\000\000\001\128\128\016\000\000\016\016\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\254\018\012X\170\223\204\223@P\031q(\000q\192g\240\144b\197V\254fz\002\128\251\137@\003\142\000 \000\002\001\000\t\002\020\012\000\000\000@\b\000\000\001\000\000\016\000\000H\016\160`\000\000\002\000@\000\000\b\000\000\128\000\002@\132\003\000\000\000\016\002\000\000\0001\b\002\004\000#\002E\160\002\000\168\000\000\016@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0001\012B?\001cJE\167\198 \172\b\001\146\203\000\000\002\000\000\000\000\000\001\000\000\004\000\000\000\000\000\012\000\000\000\128\000\000\002\000\000\000\000\000\000\000\000\000`\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\003\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\016\016\000\b\024\016\000\000\000\128\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\003\001\000 \000\000  \128\000\001\000\000\000\000\000\000\024\b\001\000\000\001\001\000\000\000\b\000\000\000\000\000\001\192@\b\000\000\b\b\000\000\000@\000\000\000\000\000\198\225\000E\130\141\252I\244\001\001\244\002\128\003\028\0067\b\002,\020o\226G\160\b\015\160\020\000\024\224\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012n\016\004\\(\223\196\159@\016\031@(\0001\192cp\128\"\193F\254$\250\000\128\250\001@\001\142\003\027\132\001\022\n7\241#\208\004\007\208\n\000\012p\024\220 \b\184Q\191\137>\128 >\128P\000c\128\198\225\000E\130\141\252I\244\001\001\244\002\128\003\028\0067\b\002,\020o\226G\160\b\015\160\020\000\024\224C\207n\245\254/\157\243\251\255\183\007\239\237\191\254y\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\000b\016D\012\000F\004\155@\004\001@\000\000 \128\003\016\130 @\0020$\218\000 \n\000\000\001\004\000\024\132\017\002\000\017\129\"\208\001\000P\000\000\b \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006!\000@\128\004`H\180\000@\020\000\000\002\b\0001\b\002\004\000#\002E\160\002\000\168\000\000\020@\001\136@\144 \001\024\018-\000\016\005@\000\000\130\000\004\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002 \000\000\000\000\000\000\000\000\016\000\001\000\000\006\000\000p\016\000ap\128\000@\000\000\000\000\000\000\000\000\136\000\000\000\000\b\000\000\000\004\000\000\000\000\000\000\004@\000\000\000\000\000\000\000\000 \000\000\000\000\012B\000\129\000\b\192\145h\000\128*\000\000\004\016\000b\016\004\012\000F\004\154@\004\001@\000\000 \128\003\016\128 @\0020$\210\000 \n\000\000\001\004\000\024\132\001\002\000\017\129\"\144\001\000P\000\000\b \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0011H\218\132\128\163\002M`\018\000\165\002\006\213P\000\000@\000 \001\000\000\001\000\000\004\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\152\164mB@Q\129&\240\t\000V\128\131j\168\000@\000\000\000\000\b\001\020\000\000\000\000\000\000\000\000\006!\b@\128\004`H\180\000@\021\000\000\018\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\136@\0160\001\024\018m\000\016\005@\000\000\130\000\012B\000\129\000\b\192\147h\000\128*\000\000\004\016\000b\016\004\b\000F\004\139@\004\001P\000\000 \128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\003`\000\002\000\000 \000@\000\020\000\019\020@\006!\000@\128\004`H\180\000@\021\000\000\002\b\001\000\000\216\000\000\128\000\b\000\016\000\005\000\004\197\016\001\136@\016 \001\024\018-\000\016\005@\000\000\130\000@\0006\000\000 \000\002\000\004\000\001@\0011D\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\019\016\141\160@\n0$\218\001 \n\208\000MU\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000&!\027@\128\020`I\180\002@\021\160\000\154\170\0009\012B?\001cJE\167\198 \172\b\001\146\203\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000@\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\024\132\001\002\000\017\129\"\144\001\000P\000\000\b \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000 \000\000\128\000\000\000\000\000\000\002\000\000\000\000\000@\000\000\000\000\000&\b\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000b\016\004\b\000F\004\139@\004\001P\000\000 \128\016\000\r\128\000\b\000\000\128\001\000\000P\000LQ\000\024\000\001\192@\001\133\194\000\001\000\000\000\000\000\000\000\000\001\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0001\b\002\004\000#\002E\160\002\000\168\000\000\016@\b\000\006\192\000\004\000\000@\000\128\000(\000&(\128\000\000\000\000\000\000\192\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000 \000\000\000\000\000\018\004@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0001\b\018\004\000#\002E\160\002\000\168\000\000\016@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\000\000\000\000\000\128\000\000\000\000\000HQ\000\024\132\t\002\000\017\129\"\208\001\000T\000\000\n \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\136\000\000\000\000\b\000\000\000\000\000\004\129\016\000\000\004@\000\000\000\000\000\000\000\000\000\000\000\000\000\012\000\002\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\001\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\030RE\1610H\233\159X\012\128/`\001\188U\000\000\000\000\000\000\006\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\002\000\000 \000\000\192\000\014\002\000\012.\016\000\b\000\000\000\000\000\000\000\000\b\000\000\000\000\001\000\000\000\000\128\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\002\000\000\000\000\024\220 \b\176Q\191\137\030\128 >\128P\000c\128\006!\000@\128\004`H\180\000@\020\000\000\002\b\0001H\002\132\128#\002M`\018\000\164\000\004\209X\001\000\000\000\000\000\024\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000b\016\004\b\000F\004\139@\004\001P\000\000 \128\000\000\004\000\000\000\000\000\128\000\000\000@\000L\017\000\024\000\001\192@\001\133\194\000\001\000\000\000\000\000\000\000\000\001\000\000\000\000\000 \000\000\000\016\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\144\196#\240\0224\164Z|b\n\192\128\025,\176\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006)\000P\144\004`H\172\000@\020\128\000J\b\0001\b\002\004\000#\002E \002\000\160\000\000\016@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\000b\016D\012\130F\004\155@\004\001P\000\000 \128\003\001\000  \000  \128\000\001\000\000\000\000\b\000\024\b\001\001\000\001\001\004\000\000\b\000\000\000\000\000\000\192@\b\000\000\b\b \000\000@\000\000\000\000\000\006\002\000@\000\000@@\000\000\002\000\000\000\000\000\000\000\000\000\000\000\002\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\012\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\b\001\001\000\000\129\129\000\000\000\b\000\000\000\000\000\000@\b\b\000\004\012\b\000\000\000@\000\000\000\000\000\000\000\000\000\000\000@\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\001\000  \000\0160 \000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000! \005P\001\006\002\144\224\000\136\000v\000\b\128\016\001\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\0000\000\001$\000#\000\000\001\000\000\000\000\000\000\128\000\128\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000@\000\000`\000\007\129\000\006\023\b\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\024\000\001\192@\001\133\194\000\001\000\000\000\000\000\000! \005P\001\006\002\144\224\000\136\000v\000\b\128P\006\000\000p\016\000ap\128\000@\000\000\000\000\000\bH\001T\000A\128\1648\000\"\000\029\128\018 \020B@\n\160\002\012\005!\192\001\016\000\236\000\145\000 \006\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\016\000\000\b\001\001\000\000\129\129\000\000\000\b\000\000\000\000\000! \005P\001\006\002\144\224\000\136\000v\000\b\128\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\001\000\000\000\000\128\000\000\000\000\b\000\000\000\000\000\000\000\000\000\002\018\000U\000\016`\169\014\000\b\128\007`@\200\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000@@\000 `@\000\000\002\000\000\000\000\000\bH\001T\000A\128\1648\000\"\000\029\128\002 \004\000\128\016\016\000\b\024\016\000\000\000\128\000\000\000\000\002\018\000U\000\016`)\014\000\b\128\007`\000\136\001\000\000\000\000\000\000\000\000\000\000\000\000\b\002\002\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004$\000\170\000 \193R\028\000\017\000\014\192\129\016\002\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\bH\001T\000A\130\1648\000\"\000\029\129\002 \004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\018\000U\000\016`)\014\000\b\128\007`\000\136\001\000\016\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\001\000\000\002\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000@\000\000\128\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000` \004\000\000\004\004\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004$\000\170\000 \193R\028\000\025\000\014\192\0010\002\001\192A\b\000\000\b\b\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\002\000\b\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\128\128\000@\192\128\000\000\004\000\000\000\000\000\016\000\000\128\000\001\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\t\000*\128\b0T\135\000\006@\003\176 L\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000@\000\128\000\000\000\000\000\001\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\012n\016\004X(\223\196\143@\016\031@(\0009\192cp\129\"\193F\254$z\000\128\250\001@\001\142\000\000\000\000\000\000\000\128\000\000\000@\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\002\000\016\000\000\000\000\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\0001\b\002 \004\003\002G \000\000\160\020\000\024\192@\000\004@\000\000\000\000\000\0000\000 H\018\000\000\012B\000\136\001\000\192\145\200\000\000(\005\000\0060\012n\016\004X(\223\196\143@\016\031@(\0001\192\003\016\128\" @0$\242\000\000\n\001@\001\140\000\024\132\001\016\002\001\129'\144\000\000P\n\000\012`\000\196 \b\128\016\012\t\028\128\000\002\128P\000c\000\198\225\000E\194\141\252I\244\001\001\244\018\128\003\028\0067\b\002,\020o\226O\160\b\015\160\148\000\024\2241\184@\017`\163\127\018=\000@}\004\160\000\199\001\141\194\000\139\133\027\248\147\232\002\003\232\005\000\0068\012n\016\004X(\223\196\159@\016\031@(\0001\192cp\128\"\193F\254$z\000\128\250\001@\001\142\000\024\132\001\003\000\017\129&\208\001\000T\000\000\b\160\000\196 \b\016\000\140\t6\128\b\002\160\000\000E\000\006!\000@\128\004`H\180\000@\021\000\000\002(\0001\b\002\004\000#\002E\160\002\000\168\000\000\016@\b\000\000\000\000\004\000\000@\000\000\000\000\000$\b\129\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\000b\144\005\r\000F\004\154\192\004\001@\000\000 \128\003\020\128(H\0020$\214\000 \n\000\000\001\004\000\024\164\001B@\017\129\"\176\001\000P\000\000\b \000\2281\b\252\005\141)\022\159\024\130\176 \006K,\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\001\138@\020$\005\024\018+\000\016\005\000\000\002\130\001\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\000b\016\004\012\000F\004\155@\004\001P\000\000 \128\003\016\128 @\0020$\218\000 \n\128\000\001\004\000\024\132\001\002\000\017\129\"\208\001\000T\000\000\b \000\000\000\000\000\000\000\000 \000@\000\016\000\018\004@\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\0001\b\002\006\000#\002M\160\002\000\168\000\000\016@\001\136@\016 \001\024\018m\000\016\005@\000\000\130\000\012B\000\129\000\b\192\145h\000\128*\000\000\004\016\000\000\000\000\000\000\000\000\016\000\000\000\b\000\t\002 cp\128\"\193F\254$z\000\128\250\001@\001\142\000\024\132\001\016\002\001\129#\144\000\000P\n\000\012`\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\030{w\175\241|\235\159\223\253\184?\127m\255\247\192 \000\000\000\000\006\000\142\000\000\000\000\000\000\000\000cp\196#\241V\254\164z|\194\250A\192\025\174\176\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\024\220!\b\176Q\191\137\030\128 >\128P\000c\128\198\225\bE\130\141\252H\244\001\001\244\002\128\003\028\0000\016\002\002\000\002\002\b\000\000\016\000\000\000\000\000\001\128\128\016\000\000\016\016@\000\000\128\000\000\000\000\000\012\004\000\128\000\000\128\128\000\000\004\000\000\000\000\000\000\000\000\000\000\000\004\000\016\000\000\000\000\000\000\128\000\001\000  \000\0160 \000\000\001\000\000\000\000\000\004\000\000 \000\000@\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\198\225\bE\130\141\252H\244\001\001\244\002\128\003\028\0067\bB,\020o\226G\160\b\015\160\020\000\024\224\001\136B\016 \001\024\018-\000\016\005\000\000\000\130\000\000\000\000\000\000\000\000\002\000\000\000\001\000\0010D\000`\000\007\001\000\006\023\b\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000@\000\000\000\003\027\132\001\022\n7\241#\208\004\007\208\n\000\012p\000\196 \b\136\016\012\t<\128\000\002\128P\000c\000\006!\000D\000\128`I\228\000\000\020\002\128\003\024\0001\b\002 \004\003\002G \000\000\160\020\000\024\192BE.\224\250\015\133a\192\255\183\002\239M\1918x\012B\000\136\001\000\192\145\200\000\000(\005\000\0060\016\243\219\189\127\139\231\\\254\255\237\193\251\251o\255\190\000\000\000\000\000\000 \000P\000\000\000\000\000\000\000\003\027\132\001\022\n7\241#\208\004\007\208\n\000\012p\024\220 \b\176Q\191\137\030\128 >\128P\000c\129\015=\187\215\248\190u\207\239\254\220\031\191\182\255\249\224\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\016\128\"\000@0$r\000\000\n\001@\001\140\004<\246\239_\226\249\215?\191\251p~\254\219\255\239\128\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\003\000\005\000\000\000\000\000\000\000\0001\184@\017`\163\127\018=\000@}\000\160\000\199\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\132\138]\193\244\031\n\195\129\255.\005\222\011~p\243\027\132\001\022\n7\241#\208\004\007\208\n\000\012p!\231\183z\255\023\206\185\253\255\219\131\247\246\223\255=\t\020\187\131\232>\021\135\003\254\220\011\1896\252\225\224\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000C\027\132\001\022\n7\241#\208\004\007\208\n\000\012p\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\0041\184@\017`\163\127\018=\000@}\000\160\000\199\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\145K\184>\131\225Xp?\229\192\187\193o\206\030cp\128\"\193F\254$z\000\128\250\001@\001\142\004$R\238\015\160\248V\028\015\249p.\240[\243\135\152\220 \b\176Q\191\137\030\128 >\128P\000c\129\t\020\187\131\232>\021\135\003\254\\\011\188\022\252\225\224\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000C\207n\245\254/\157s\251\255\183\007\239\237\191\254z\018)w\007\208|+\014\007\253\184\023zm\249\195\204n\016\004X(\223\196\143@\016\031@(\0001\192\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\007?\214\239\031\170\255\247?\223\253w\254\250[\255\247\175n\200\129\005\252T\128\002`\224t\227\130\192\160\208\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\016\145K\184>\131\225Xp?\229\192\187\193o\206\030cp\128\"\193F\254$z\000\128\250\001@\001\142\004$R\238\015\160\248V\028\015\249p.\240[\243\135\152\220 \b\176Q\191\137\030\128 >\128P\000c\129\t\020\187\131\232>\021\135\003\254\\\011\188\022\252\225\2307\b\002,\020o\226G\160\b\015\160\020\000\024\224BE.\224\250\015\133a\192\255\151\002\239\005\1918y\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\016\145K\184>\131\225Xp?\229\192\187\193o\206\030cp\128\"\193F\254$z\000\128\250\001@\001\142\004$R\238\015\160\248V\028\015\249p.\240[\243\135\152\220 \b\176Q\191\137\030\128 >\128P\000c\129\t\020\187\131\232>\021\135\003\254\\\011\188\022\252\225\2307\b\002,\020o\226G\160\b\015\160\020\000\024\224BE.\224\250\015\133a\192\255\151\002\239\005\1918y\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\016\145K\184>\131\225Xp?\229\192\187\193o\206\030cp\128\"\193F\254$z\000\128\250\001@\001\142\004$R\238\015\160\248V\028\015\249p.\240[\243\135\152\220 \b\176Q\191\137\030\128 >\128P\000c\129\t\020\187\131\232>\021\135\003\254\\\011\188\022\252\225\2307\b\002,\020o\226G\160\b\015\160\020\000\024\224BE.\224\250\015\133a\192\255\151\002\239\005\1918y\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\016\145K\184>\131\225Xp?\229\192\187\193o\206\030cp\128\"\193F\254$z\000\128\250\001@\001\142\004$R\238\015\160\248V\028\015\249p.\240[\243\135\152\220 \b\176Q\191\137\030\128 >\128P\000c\129\t\020\187\131\232>\021\135\003\254\\\011\188\022\252\225\2307\b\002,\020o\226G\160\b\015\160\020\000\024\224BE.\224\250\015\133a\192\255\151\002\239\005\1918y\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\016\145K\184>\131\225Xp?\229\192\187\193o\206\030cp\128\"\193F\254$z\000\128\250\001@\001\142\004$R\238\015\160\248V\028\015\249p.\240[\243\135\152\220 \b\176Q\191\137\030\128 >\128P\000c\129\t\020\187\131\232>\021\135\003\254\\\011\188\022\252\225\2307\b\002,\020o\226G\160\b\015\160\020\000\024\224BE.\224\250\015\133a\192\255\151\002\239\005\1918x\012B\000\129\000\b\192\147h\000\128(\000\000\004\016\000b\016\004\b\000F\004\139@\004\001@\000\000 \128\000\000\000\000\000\000\000\000\128\000\000\000@\000L\017\000\024\000\001\192@\001\133\194\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\016\000\000\000\000\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000 \000$\b\129\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\016\128 @\0020$Z\000 \n\128\000\001\004\000\000\000\000\000\000\000\000\004\000\000\000\002\000\002@\136\000\196 \b\016\000\140\t\022\128\b\002\160\000\000A\000\000\000\000\000\000\000\000\001\000\000\000\000\128\000\144\"\0001\b\002\004\000#\002E\160\002\000\168\000\000\016@\000\000\000\000\000\000\000\000@\000\000\000 \000$\b\128\000\000\000\000\000\000\192\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\016\000\018\004@\006!\000@\128\004`H\180\000@\021\000\000\002\b\000\000\000\000\000\000\000\000\b\000\000\000\004\000\004\129\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\018\000E\000\016@)\012\000\012\128\006`\000\b\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000!\"\151p}\007\194\176\224\127\203\129w\130\223\156<\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\128\000\000\000\000\000\000\000\000\b\000\020\000\000\000\000\000\000\000\000\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0016\007\192\024\002\002\001\240\b\001\000\001a\128\204n\016\180X(\223\196\143@\016\031@(\0009\192\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\027\132\001\022\n7\241#\208\004\007\208\n\000\012p\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0067\b\002,\020o\226G\160\b\015\160\020\000\024\224\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\016\128\"\000@0$r\000\000\n\001@\001\140\004<\246\239_\226\249\215?\191\251p~\254\219\255\239\128\000\000\000\000\000\b\000\020\000\000\000\000\000\000\000\000\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000C\207n\245\254/\157\243\251\255\183\007\239\237\191\254y\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\016\145K\184>\131\225Xp?\229\192\187\193o\206\030cp\128\"\193F\254$z\000\128\250\001@\001\142\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000!\231\183z\255\023\206\249\253\255\219\131\247\246\223\255<\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\bH\165\220\031A\240\1728\031\242\224]\224\183\231\0151\184@\017`\163\127\018=\000@}\000\160\000\199\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\016\243\219\189\127\139\231|\254\255\237\193\251\251o\255\158cp\128\"\193F\254$z\000\128\250\001@\001\142\004$R\238\015\160\248V\028\015\249p.\240[\243\135\128@\000\000\000\000\012\000\020\000\000\000\000\000\000\000\000\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000C\207n\245\254/\157\243\251\255\183\007\239\237\191\254y\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\016\145K\184>\131\225Xp?\229\192\187\193o\206\030cp\128\"\193F\254$z\000\128\250\001@\001\142\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000!\231\183z\255\023\206\249\253\255\219\131\247\246\223\255<\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\bH\165\220\031A\240\1728\031\242\224]\224\183\231\0151\184@\017`\163\127\018=\000@}\000\160\000\199\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\016\243\219\189\127\139\231|\254\255\237\193\251\251o\255\158cp\128\"\193F\254$z\000\128\250\001@\001\142\004$R\238\015\160\248V\028\015\249p.\240[\243\135\128\000\000\000\000\000\000\000\000\000\000\000\000$\000\000\000\000\000\000\000\000\000@\000\160\000\000\000\000\000\000\000\0067\b\002,\020o\226G\160\b\015\160\020\000\024\224\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\002\030{w\175\241|\239\159\223\253\184?\127m\255\243\204n\016\004X(\223\196\143@\016\031@(\0001\192\132\138]\193\244\031\n\195\129\255.\005\222\011~p\243\027\132\001\022\n7\241#\208\004\007\208\n\000\012p\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\001\015=\187\215\248\190w\207\239\254\220\031\191\182\255\249\2307\b\002,\020o\226G\160\b\015\160\020\000\024\224BE.\224\250\015\133a\192\255\151\002\239\005\1918y\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\135\158\221\235\252_;\231\247\255n\015\223\219\127\252\243\027\132\001\022\n7\241#\208\004\007\208\n\000\012p!\"\151p}\007\194\176\224\127\203\129w\130\223\156=\015=\187\215\248\190w\207\239\254\220\031\191\182\255\249\2307\b\002,\020o\226G\160\b\015\160\020\000\024\224BE.\224\250\015\133a\192\255\151\002\239\005\1918z\030{w\175\241|\235\159\223\253\184?\127m\255\247\208\243\219\189\127\139\231\\\254\255\229\193\251\233o\255\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0001\184@\017`\163\127\018=\000@}\000\160\000\199\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000cp\128\"\193F\254$z\000\128\250\001@\001\142\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\004\000\004\129\0161\184@\017`\163\127\018=\000@}\000\160\000\199\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\000\016cp\128\"\193F\254$z\000\128\250\001@\001\142\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\196 \b\016\000\140\t\022\128\b\002\128\000\000A\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\136B\017\000 \024\0189\000\000\005\000\160\000\198\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000cp\128\"\193F\254$z\000\128\250\001@\001\206\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0067\b\018,\020o\226G\160\b\015\160\020\000\024\224\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006!\000D\000\128`H\228\000\000\020\002\128\003\024\b\000\000\000\000\000\000\000\000\000\006\000\000\t\000\000\000\000\128\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\016\000\000\000\000\000\000\000\000\b\000\004\128\000\003\000\0008\b\0000\184@\000 \000\000\000\000\000\000\000\000d\000\000\000\000\004\000\000\000\002\000\000\000\000\000\192\000\014\002\000\012.\016\000\b\000\000\000\000\000\000\000\000\025\000\000\000\000\001\000\000\000\000\128\000@\000\0000\000\003\128\128\003\011\132\000\002\000\000\000\000\000\000\000\000\006@\000\000\000\000@\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\016\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\b\128\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\004\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\001\128\000\002@\000\000\000 \000\000\000\000\006\000\142\000\000\000\000\000\000\000\000\128\000\b\128\000\000\000\000\000\000`\000@\144$\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0001\184@\017`\163\127\018=\000@}\000\160\000\199\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\012n\016\004X(\223\196\143@\016\031@(\0001\192\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\000\001\000\000\000\000\000\000\000\000\000\000\000@\000\000\000cp\128\"\193F\254$z\000\128\250\001@\001\142\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\024\220 \b\176Q\191\137\030\128 >\128P\000c\128\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\014C\016\143\192X\210\145i\241\136+\002\000d\178\192\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\024\164\001B@Q\129\"\176\001\000P\000\000( \000\192\000\012\000\000\012.\016\000\b\000\000\000\000\000\000\002\000\000\000\000\016 \000\000\000@\000\000\000\000\000\0067\b\002,\020o\226G\160\b\015\160\020\000\024\224\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000b\144\005\t\001F\004\138\192\004\001@\000\000\160\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006)\000P\144\020`H\172\000@\020\000\000\n\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\001\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000cp\128\"\193F\254$z\000\128\250\001P\001\142\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\bH\165\220\031A\240\1728\031\242\224]\224\183\231\015\001\136@\016 \001\024\018-\000\016\005@\000\000\130\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\027\132\001\022\n7\241#\208\004\007\208\n\000\012p!\"\151p}\007\194\176\224\127\203\129w\130\223\156<\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\bH\165\220\031A\240\1728\031\242\224]\224\183\231\015\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\132\138]\193\244\031\n\195\129\255n\005\222\155~p\240\000\002\000\015\1280\004\004\003\2240\002\000\002\193\001\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\015=\187\215\248\190u\207\239\254\220\031\191\182\255\251\224\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\"\007\192\024\002\002\001\240(\001\000\001`\128\192\000\001\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006\002\000@\000\000@A\000\000\002\000\000\000\000\000\0000\016\002\000\000\002\002\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\016\000@\000\128\000\000\000\000\000\001\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\000\000\000 \000\000\000\128\000\000\000\000\000\000\000\000\024\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000\192\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\128\000\b\000\0000\016\002\000\000\002\002\000\000\000\016\000\000\000\000\000\002@\b\160\002\b\021!\192\001\144\000\204\000\001\000 \004\000\128\128\000@\192\128\000\000\004\000\000\000\000\000\016\000\000\000\000\001\000\000\016\000\000\000\b\000\000\000\000\003\001\000 \000\000  \000\000\001\000\000\000\000\000\000$\000\138\000 \129R\028\000\025\000\012\192\000\016\002\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000 \000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\"\000\000\004\000\004\000\024\000\000\000@\000\000\000\000\001\016\000\000\000\000 \000\192\000\000\002\000\000\000\000\000\b\128\000\000\000\001\000\002\000\000\000\016\000\000\000\000\000\000\000\000\000\128\000\000 \000@\000\000\000\001\000\000\000\000\000\000\000\000\000\001\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\0001\184@\017`\163\127\018=\000@}\000\160\000\199\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000b\016D\b\000F\004\155@\004\001@\000\000 \128\003\016\130 @\0020$Z\000 \n\000\000\001\004\000\024\132\001\002\000\017\129\"\208\001\000P\000\000\b \001 \004P\001\004\002\144\192\000\200\000f\000\000\128\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\001\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\024\164\001B@\017\129\"\176\001\000R\000\001( \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\028\000\001\192@\001\133\194\000\001\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\0000\000\003\128\128\003\011\132\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000 \000\000\000\001\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\016\000\000\000\024\000\001\192@\001\133\194\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\016\000\000\000\000\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\001\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000$\000\138\000 \128R\024\000\025\000\012\192\000\016\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\t\020\187\131\232>\021\135\003\254\\\011\188\022\252\225\232\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\136@\016 \001\024\018-\000\016\005@\000\000\138\002\018)w\007\208|+\014\007\252\184\023x-\249\195\208\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\016\128 @\0020$Z\000 \n\128\000\001\020\004$R\238\015\160\248V\028\015\249p.\240[\243\135\128\000\017\000|\001\128  \031\000\128\016\000\031\b\012\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\002\002\000\001\003\002\000\000\000\016\000\000\000\000\000@\000\002\000\000\004\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \004\004\000\002\006\004\000\000\000 \000\000\000\000\000\128\000\004\000\000\b\000\000\128\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\b\b\000\004\012\b\000\000\000@\000\000\000\000\001\000\000\b\000\000\016\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000B@\n\160\002\012\021!\192\001\016\000\236\000\017\000\"\000\000\016\000\000 \000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\128\000\000\000\000\000L\017\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\192\000\014\002\000\012.\016\000\b\000\000\000\000\000\000\000\000\b\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000 \000\000\128!\000\192\000\000\004\000\128\000\000 \000\000\000\000\128@\002\000\000\000\000\000\000\000 \000\000\000\000\000\004\002\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000 \016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\t\000\000\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\001\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000@\000\001\000C\001\128\000\000\b\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\b\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\024\000\001\192@\001\133\194\000\001\000\000\000\000\000\000\001\000\000\016\000\000@\016\224`\000\000\002\000@\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\002@\0001\184@\017`\163\127\018=\000@}\000\160\000\199\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000cp\128\"\193F\254$z\000\128\250\001@\001\142\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\001\000\000\004\000 \000\000\000\000\000\000\002\000\000\000\000\b\000\000 \001\000\000\000\000\000\000\000\000\000\000\000\000@\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\012R\000\161 \b\192\145X\000\128)\000\000\020\016\000p\000\007\001\000\006\023\b\000\004\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\192\000\014\002\000\012.\016\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\128\000\000\000\0067\b\002,\020o\226G\160\b\015\160\020\000\024\224\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000@\000\000\000`\000\007\001\000\006\023\b\000\004\000\000\000\000\000\000\004\000\000@\000\001\000C\129\128\000\000H\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\024\220 \b\176Q\191\137\030\128 >\128P\000c\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\004\000\000\016\0048\024\000\000\004\128\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\001\000\000\004\001\012\006\000\000\000 \004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\004\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000`\000\007\001\000\006\023\b\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\197 \n\018\000\140\t\021\128\b\002\144\000\001A\000\007\000\000p\016\000ap\128\000@\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\012\000\000\224 \000\194\225\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\b\000\000\000\000cp\128\"\193F\254$z\000\128\250\001@\001\142\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\246\236\136\016_\197H\000&\014\007N8,\n\r\012\254\018-X\170\223\204\207@P\031p(\000\241\192\003\016\128 @\0020$Z\000 \n\128\000\001\004\000\128\000\b\000\000\000\000\004\000\000\000\000\000\002@\136\024\220 \b\176Q\191\137\030\128 >\128P\000c\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0008\000 \002\000\000\000\b\000\000\000\000\000\000\000\000\000\128\000\000\016\000\b\000@\000\000\000\000\000\000\000\000\004\000\000\000\000\000@\002\000\000\000\000\000\000\000\000\000 \000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\004\128\017@\004\016\nC\000\002 \001\216\000\002\000\000\b\001\001\000\000\129\129\000\000\000\b\000\000\000\000\000! \004P\001\006\002\144\224\000\136\000f\000\000\128\000\t\000\"\128\b \020\134\000\004@\0030\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\128\001\000\000\000\000\000@\000\000\000\000\000\000\000\000\012\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000`\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\000@\000\004\000\000$\000\138\000 \128R\024\000\017\000\012\192\000\016\002\001 \004P\001\004\002\144\128\000\136\000f\000\000\128\016\006\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\0000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000 \000\002\000\000\018\000E\000\016@)\012\000\b\128\006`\000\b\001\000\144\002(\000\130\001H@\000D\0003\000\000@\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\016\000\001\000\000\t\000\"\128\b \020\134\000\004@\0030\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000^\221\145\002\011\248\169\000\004\193\192\233\199\005\129A\161\159\194E\171\021[\249\153\232\n\003\238\005\000\0308\000` \004\004\000\004\004\016\000\000 \000\000\000\000\000\003\001\000 \000\000  \128\000\001\000\000\000\000\000\000\024\b\001\000\000\001\001\000\000\000\b\000\000\000\000\000\001 \004P\001\004\n\144\224\000\136\000f\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\003\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\024\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\192\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\003\000\0008\b\0000\184@\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\002\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\001\"\128\b \020\134\000\004@\0030\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002@\b\160\002\b\005!\128\001\016\000\204\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\"\000\000\004\000\004\000\024\000\000\000@\000\000\000\000\001\016\000\000\000\000 \000\192\000\000\002\000\000\000\000\000\b\128\000\000\000\001\000\002\000\000\000\016\000\000\000\000\001 \004P\001\132\002\144\224\000\136\000v\000\001\128\000\002 \000\000\000\000@\000\128\000\000\004\000\000\000\000\000H\001\020\000A\000\1648\000\"\000\025\128\000 \000\002@\b\160\002\b\005!\128\001\016\000\204\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\144\002(\000\130\001Hp\000D\0003\000\000@\000\004\128\017@\004\016\nC\000\002 \001\152\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\224\004^\003\004\012>\144\000\136\000`\000\000\128\000\t\000\"\128\b \000\132\000\004\000\0030\000\004\000\000\016\000\000\002\000\000\000\b\000\000\000\000\000\000\000\128\000\128\000\000\016\000\000\000@\000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\128\017@\004\016 C\000\002\000\001\152\016\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000H\001\020\000A\002\0040\000 \000\025\129\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\014\000\b\000\128\000\000\002\000\000\000\000\000\000\000\000\000 \000\000\004\000\002\000\016\000\000\000\000\000\000\000\000\001\000\000\000\000\000\016\000\128\000\000\000\000\000\000\000\000\b\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\001 \004P\001\004\000\016\192\000\128\000v\000\004\128\000\002\000@@\000 `@\000\000\002\000\000\000\000\000\bH\001\020\000A\128\0048\000 \000\025\128\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\000\b\000\000\000\000\002\000\000\000\000\000\000\000\000\000`\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\000@\000\020\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001 \004P\001\004\b\016\192\000\128\000f\004\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\004\000\128\128\000@\192\128\000\000\004\000\000\000\000\000\016\144\002(\000\131\000\bp\000@\0003\000\000@\b\004\128\017@\004\016\000B\000\002\000\001\152\000\002\000@\024\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000\192\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\016\002\002\000\001\003\002\000\000\000\016\000\000\000\000\000B@\b\160\002\012\000!\192\001\000\000\204\000\001\000 \018\000E\000\016@\001\b\000\b\000\006`\000\b\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\002\000\000 \000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\000\"\128\b \000\134\000\004\000\0030 \004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\016\016\000\b\024\016\000\000\000\128\000\000\000\000\002\018\000E\000\016`\001\014\000\b\000\006`\000\b\000\000\144\002(\000\130\000\b`\000@\0003\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000@@@ `A\000\000\002\000\000\000\000\000\000\016\002\002\000\001\003\002\b\000\000\016\000\000\000\000\000\000\128\016\016\000\b\024\016\000\000\000\128\000\000\000\000\002\018\000E\000\016`\001\014\000\b\000\006`\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\016\000\000 \000 \000\192\000\000\002\000\000\000\000\000\b\128\000\000\000\001\000\006\000\000\000\016\000\000\000\000\000D\000\000\000\000\b\000\016\000\000\000\128\000\000\000\000\t\000\"\128\012 \000\135\000\004\000\0030\000\012\000\000\136\000\000\002\000\001\000\012\000\000\000\000\000\000\000\000\004\000\000\000\016\000\b\000`\000\000\000\000\000\000\000\000 \000\000\000\000\000@\003\000\000\000\000\000\000\000\000\001\000\000\000\000\000\002\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\002\000\000\000\000\000\000\000\000\000\128\000\004\144\000\128\000\000\004\000\000\000\000\000\002\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000 \000\004\000 \002D\b\000\000\000\000\000\000\000\000\004\000\000@\000\001 B\128\128\000\000\b\001\000\000\000 \000\002\000\000\t\002\016\004\000\000\000@\b\000\000\000\192\000\014\002\000\012.\016\000\b\000\000\000\000\000\000\000\000\b\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000 \000\000\128!\000@\000\000\004\000\128\000\000 \000\000\000\000\128@\002\000\000\000\000\000\000\000\000\001\000\000\000\000\004\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\012\000\000\224 \000\194\225\000\000\128\000\000\000\000\000\000\128\000\b\000\000 \bp\016\000\000\001\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000 \000\000\128\004\000\000\000\000\000\000\000\000\002\000\000\001\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\024\000\001\192@\001\133\194\000\001\000\000\000\000\000\000\001\000\000\016\000\000@\016\192 \000\000\002\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\002\000\016\001\"\012\000\000\000\000\000\000\000\000\000\128\000\016\000\128\t\016 \000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\016\000\000\000\000\000\000\001\000\001\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\004\000\000\000\002\000\000@\002\000$@\128\000\000\000\000\000\000\000\0000\000\003\128\128\003\011\132\000\002\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000 \000\000\004\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\000\0008\b\0000\184@\000 \000\000\000\000\000\000\000\000\b\000\000\000\000\004\000\000\000\000\000\002\000\000\000\000\000@\000\000\000\000 \000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002@\n\160\002\b\133!\192A\016\000\236\000\129\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\016\000\000\000\b\000\001\000\b\000\145\002\000\000\000\000\000\000\000\000\001 \005P\001\004B\144\224 \136\000v\000@\128\016\b\000\000\128\000\002\000\135\001\000\000\000\016\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\128\000\028\004\000\024\\`\000\016\000\000\000\000\000\000\012\000\000\224 \000\194\225\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\b\000\000\000\000\003\000\0008\b\0000\184@\000 \000\000\000\000\000\000 \000\002\000\000\b\002\028\012\000\000\000@\b\000\000\001\000\000\016\000\000@\016\192 \000\000\002\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\001\000\000\004\001\012\002\000\000\000 \004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\002\000\000\b\002\016\004\000\000\000@\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\000\"\128\b \020\135\000\004@\0030\000\004\000\128H\001\020\000A\000\164 \000\"\000\025\128\000 \004\004\000\000\000\000\000\b\000`\000\000\000\000\000\000\000\000 \000\000\000\000\000@\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000@\000\b\000@\004\136\016\000\000\000\000\000\000\000\000\t\000\"\128\b \020\135\000\004@\0030\000\004\000\128H\001\020\000A\000\164 \000\"\000\025\128\000 \004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\002\000\024\000\000\000\000\000\000\000\000\b\000\000\000\000\000\016\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\0000\000\003\128\144\003+\132\000\002\000\000\000\000\000\000\002\192*\160\002\012\b!\192\001\016\000\236\000\003\000 \012\000\000\192\000\000\194\225\000\000\128\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\003\000\0008\t\0002\184@\000 \000\000\000\000\000\000\024\000\001\192@\001\133\194\000\001\000\000\000\000\000\160\000\000\000@\000\000\000\000 \000\000\000\000\000\016\004\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\0000\000\003\128\144\003+\132\000\002\000\000\000\000\000\000\001\128\000\024\000\000\024\\ \000\016\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000`\000\007\001 \006W\b\000\004\000\000\000\000\000\000\005\128U@\004\024\016C\128\002 \001\216\000\002\000@,\002\170\000 \192\130\028\000\017\000\014\192\000\016\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\000*\128\b \000\135\000\004\000\003\176\000\004\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\018\000E\000\016@\001\012\000\b\000\006`\000\b\001\000\144\002(\000\130\000\b@\000@\0003\000\000@\b\b\000\000\000\000\000\016\000\192\000\000\000\000\000\000\000\000@\000\000\000\000\000\128\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\001\128\000\028\004\128\025\\ \000\016\000\000\000\000\000\000\018\000E\000\016@\001\012\000\b\000\006`\000\b\001\000\144\002(\000\130\000\b@\000@\0003\000\000@\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\000\"\128\b \000\132\000\004\000\0030\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\000\"\128\b \000\134\000\004\000\0030\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002@\b\160\002\b\000!\000\001\000\000\204\000\001\000 \b\000\000I\000\b\192\002\000@\000\000\000\000\000 \000@\000\002H\000F\000\000\002\000\000\000\000\000\001\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000$\000\138\000 \128R\024\000\017\000\014\192\b\016\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\000\"\128\b \020\134\000\004@\0030\002\004\000\128H\001\020\000A\000\164 \000\"\000\025\128\000 \004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\144\002(\000\130\000\b@\000@\0003\000\000@\b\002\000\000\018@\0020\000\128\016\000\000\000\000\000\b\000\016\000\000\146\000\017\128\000\000\128\000\000\000\000\000@\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\0001\000\003\192\128\003\011\133\000\002\000 \002\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\018\000E\000\016@\001\012\000\b\000\006`\004\b\001\000\144\002(\000\130\000\b@\000@\0003\000\000@\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\016\000\000\000\000\000\000\000\000\b\128\000\000 \000\016\000\192\000\000\000\000\000\000\000\000@\000\000\000\000\000\128\006\000\000\000\000\000\000\000\000\002\000\000\000\000\000\004\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\001\138@\020$\001\024\018+\000\016\005 \000\002\130\000\004\000\000\128\004\000\200\129\000\000\001\000\000\000\000\000\000\128\000\b\000\000$\bP0\000\000\001\000 \000\000\004\000\000@\000\001 B\001\128\000\000\b\001\000\000\000 \000\002\000\000\b\002\016\012\000\000\000@\b\000\000\024\220 \b\176Q\191\137>\128 >\128P\000c\128\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\000@\000\004\000\000\016\0040\024\000\000\000\128\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\128\004\000\200\131\000\000\001\000\000\000\000 \000 \000\004\000 \006D\024\000\000\b\000\000\000\000\000\001\000\000 \001\0002 @\000\000@\000\000\000\000\000\b\000\001\000\b\001\145\002\000\000\002\000\000\000\000\000\000\196 \136\025\000\140\t6\128\b\002\128\000\000A\001{vD\b/\226\164\000\019\007\003\167\028\022\005\006\1281\b\"\004\000#\002M\160\002\000\160\000\000\016@\001\136A\016 \001\024\018-\000\016\005\000\000\000\130\000\012B\000\129\000\b\192\145h\000\128(\000\000\004\016\000\000\000\000\000\000\000\000 \000 \000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\004\000\000\000\000\000\000\000@\000@\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\001\000\000\000\000\128\000\016\000\128\025\016 \000\000 \000\000\000\000\000\012\000\000\224 \000\194\225\000\000\128\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\b\000\000\001\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\197 \n\018\000\140\t5\128\b\002\128\000\000A\000\006)\000P\144\004`H\172\000@\020\000\000\002\b\0001H\002\132\128\163\002E`\002\000\160\000\000\016@\000\128\000\016\000\128\025\016 \000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\001\000 \000\004\000 \006D\b\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000<\164\171Pb\137\211?\188\017\000\\\202\b<j\001\229%Z\131\020N\153\253\224\136\002\230PA\227P\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000H\001T\000A\016\1648\024\"\000\025\128\016`\020\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\144\002\168\000\130!Hp0D\0003\000 \192(\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001 \005P\001\004B\144\224`\136\000f\000A\128P\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\001\000\000\000\000\128\000\016\000\128\025\016 \000\000 \000\000\000\000\000\018\000U\000\016D)\014\006\b\128\006`\004\024\005\000b\016D\b\000F\004\139@\004\001@\000\000 \128\003\016\128 @\0020$Z\000 \n\000\000\001\004\000\000\000\000\000\000\000\000\b\000\b\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\001\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\128\000\028\004\128\025\\ \000\016\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000@\000\001\000C\129\128\000\000\b\001\000\001\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\128\000\002\000\134\003\000\000\000\016\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\016\000\128\025\016 \000\000 \000\000\000\000\000\016\000\001\000\000\004\001\014\006\000\000\000 \004\000\004\000\128\000\b\000\000 \b`0\000\000\001\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\024\000\001\192@\001\133\198\000\001\000\000\000\000\000\000\000\192\000\014\002\000\012.\016\000\b\000\000\000\000\000\000\b\000\000\128\000\002\000\134\003\000\000\000\016\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\b\000\000 \b`0\000\000\001\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\016\000\000@\016\128`\000\000\002\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000H\001\020\000A\000\1648\000\"\000\025\128\000 \004\001\128\000\028\004\128\025\\ \000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000 \000\004\000 \006D\b\000\000\b\000\000\000\000\000\004\128\017@\004\016\nC\128\002 \001\152\000\002\000@\024\164\001B@\017\129\"\176\001\000R\000\000( \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\000\"\128\b \020\134\000\004@\0030\000\004\000\128H\001\020\000A\000\164 \000\"\000\025\128\000 \004\004\000\000\000\000\000\b\000`\000\000\000\000\000\000\000\000 \000\000\000\000\000@\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\024\164\001B@\017\129\"\176\001\000R\000\000( \001 \004P\001\004\002\144\192\000\136\000f\000\000\128\016\t\000\"\128\b \020\132\000\004@\0030\000\004\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\144\002(\000\130\001H@\000@\0003\000\000@\000\003\016\130 `\0020$\218\000 \n\000\000\001\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\018\000E\000\016@)\b\000\b\128\006`\000\b\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\128\017@\004\016\nB\000\002 \001\152\000\002\000@$\000\138\000 \128R\024\000\017\000\012\192\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\000\"\128\b \020\132\000\004@\0030\000\004\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\128\017@\004\016\nC\000\002\000\001\152\000\002\000\000$\000\138\000 \128R\016\000\016\000\012\192\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002@\b\160\002\b\005!\000\001\144\000\204\000\001\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\144\002(\000\130\001H@\000d\0003\000\000@\b\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\018\000E\000\016@\169\014\000\b\128\006`\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\001\000 \000\000  \128\000\001\000\000\000\000\000\000\024\b\001\000\000\001\001\000\000\000\b\000\000\000\000\000\001 \004P\001\004\n\144\224\000\136\000f\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000H\001\020\000A\000\1640\000 \000\025\128\000 \000\002@\b\160\002\b\005!\000\001\000\000\204\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\017\000\000@\000\002\000\004\000\000\000 \000\000\001\000\000\136\000\000\000\000\016\000 \000\000\001\000\000\000\b\000\018\000E\000\016@\001\012\000\b\000\006`\000\b@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000H\001\020\016A\000\0040\000 \000\029\128\017 \004\001\136\000\030\004\000\024\\(\000\016\001\000\016\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\144\002(\000\130\000\b`\000@\0003\000 @\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000D\000\001\000\000\b\000\016\000\000\000\128\000\000\004\000\002 \000\000\000\000@\000\128\000\000\004\000\000\000 \000H\001\020\000A\000\0040\000 \000\025\128\000!\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\004\000\000\b\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001 \004P\001\004\002\144\224\000\136\000f\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000` \004\004\000\004\004\016\000\000 \000\000\000\000\000\003\001\000 \000\000  \128\000\001\000\000\000\000\000\000\024\b\001\000\000\001\001\000\000\000\b\000\000\000\000\000\000\000\001\000\000\000\b\000 \000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\002\002\000\001\003\002\000\000\000\016\000\000\000\000\000@\000\002\000\000\004\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\004\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0001\b\002\004\000#\002E\160\002\000\168\000\000\017@BE.\224\250\015\133a\192\255\151\002\239\005\1918z\018)w\007\208|+\014\007\252\184\023x-\249\195\192b\016\004\b\000F\004\139@\004\001P\000\000\"\128\132\138]\193\244\031\n\195\129\255.\005\222\011~p\243\027\132\001\022\n7\241#\208\004\007\208\n\000\012p\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\001\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\0001\184@\017`\163\127\018=\000@}\000\160\000\199\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\000 \128\b \000\132\000\004\000\003 \000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\"\000\000\000\000\006\000\b\000\000\000@\000\000\000\000\000\000D\003\240\006\004\128\000|B\000@\128\024(\176\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\b\000\000\000\004\000\000\000\000\000\192\000\000\000\000\000\000\000\000\000\000\000\b\000~\000\192\144\000\015\136@\b\016\003\005\022\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\128\000\000\000\001\000\002\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\128\000\028\004\000\024\\ \000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\027\132\001\022\n7\241#\208\004\007\208\n\000\012p\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\002\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000  \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\024\132\001\002\000\017\129\"\208\001\000T\000\000\b \000\000\000\000\000\000\000\000 \000\000\000\004\000\018\004@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\024\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000@\000\000\000\000\012\000\000\000\000\000\000\000\000\000\000\207\225 \197\138\173\252\204\244\005A\247\"\128\007\028\000\016\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\002\200H \002\b\029!\001\001\016\001\200\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\000 \128\b \020\132\000\004@\003  \004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\128\016@\004\016\nB\000\002\000\001\128\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\254\018\012X\170\223\204\207@T\031r(\000q\192g\240\144b\197V\254fz\002\160\251\145@\003\142\000$\000\130\000 \128R\016\000\017\000\012\128\000\016\000\001 \004\016\001\004\002\144\128\000\136\000d\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002@\b \002\b\005!\128\001\016\000\200\000\001\000\000\018\000A\000\016@)\b\000\b\128\006@\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001 \004\016\001\004\002\144\192\000\136\000d\000\000\128\000\t\000 \128\b \020\132\000\004@\003 \000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000")
+  
+  and start =
+    13
+  
+  and action =
+    ((16, "I\186T|N\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\023\018N\160\000\000\000\000\022\022N\160I\186T|\022\022\000\003\000\000\000\000T|\022\022\000\003T|\022\022\000\003\000\000\000\000\000\000\018\022\025\174\003\168\000h\000\000\000\159\001<\000\000\000\000\000\000\000\000\000\000\022\022\000\000G\174\000\000\000\000x\158\000\000N\160I\186\022|\003\168\0001i^\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\015\238\0014\000\003\000\000\000\230\002\224\000\000\000\242\001\030\004J\000\000\005L\001 \006Z\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\150\000\000\001\192K(\000\000\000\000\004J\000\000\000\000\000\000\003<\003Z\000\000\000\000L$P\172\022\022Q\168b\236\022\022`\140TB\022\022^\208\000\000\004\250\000\000Yj\005*\000\000\028x\000\000\000\016\000\000\000\000\001\166\000\000\004J\000\000\000\000\000\000\001\206\000\000\028x\000\000\004\178|l\131\130i\244\134BO\016YX\\F\000\000\139\128\026\018^H\004Jy\"[\140\000\000K([\140\000\000K(\136\188\000\208\006V\000\208\002\164\000\000\0050\000\000\000\000\007(\000\000\000\000\000\000K(\004J\000\000\000\000^\208K(^\006\\F\000\000\000\000[J\000\208\000\000\000\000\\F\005\014K(\000\000\\4\\F]\030\000\000\000\000\000\000\002l\000\000K(\000\000\021\024\139\212\000\000K(\006NK(\000\000\031,\005\248\004J\000\000\000\000 *\000\000\007L\000\000`\194\003(\000\000\005PK(\0040\000\000\004|\000\000\003\138\000\000\000\003\005Z\000\000\000\000\000\000\005\022\004J\000\000K(%x\004j\b\158\022\022\140\224\000\000\000\000\029\012\140\250\000\000&v\000\000\005\164\000\000\006JK(\000\000\007>\000\000\005\136\b&\000\208\000\000\000\000K(\005V\006\150\000\000K(\007\148\136\188\000\000\000=\000\000\007\140\007|^H\022\022\007<\021\220\000\000\t\146\000\000\002\254\000\000\000\000\000\000\000\000n\016\000\000\002>\n\030tr\\F\000=\nj\000\000\n\166\\FdB\000\000j\158\\F\n\242\\Fn\174d\234\022\022\000\000\000\000\127.\005\170\000\000\000\000\000\000\127\146\000\000tr\022\022\000\000\000=\011h\000\000\000\000\000\000{\206\025z\026x\000=\011\134\000\000\000\000\000\000\000=\011\164\000\000\000\000\000\000\000\000\131\130\000\000\129nN\160I\186TB\022\022i\136Yj\bV|l\000\000\129nK(\002vK(k\002u\014\000\000\000\000\011\252\027v\000\000\022\232\005\170y\192\016\158\006f\012\030\000\000\002\004\003\154\011r\012\132\000\000\022\022\000\000\000\000\131\188\000\000\000\000\000\000\000\000\000\000\000\000\000\000y\200\016\158\022\022\000\000\000\000\b\144|l\000\000\129n\000\000\012v\027v\022\232\131\188\000\000I\186\000\000\000\000\000\000I\244I\244\003\168\004\176\000\000\022\022I\186N\006\021\218P\240]L\000\000\000\025\000\000\000\000\001\030\000\000\000\000P\130\000 \002\248\002\160\000\t\000\000\000\000\006\166\000\000Q\168\012\172\012r\003\168\004\176\004\176\022\022\000\003\000\000\000\000T|\022\022\000\003T|\022\022\000\003\000\252\000\003Tr\022\022\129\226\000\000]L|\188\1284\000h\000\000\r\022\000\000\023\164K(\028\168\bP]LTr\022\022]L\000\000\000\208\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000ZR\027\146\000\000\000\000\000\000\001\254\026\002|\188\000\000Tr\022\022]L\000\000\000\000Z\160]L\137\146]L\137\236\000\000_t\000\000\000\000`\024P\130\004\180\004\180\000\000\rB]L\000\000\000\000\001\030\028N\000\000]L\138\030K(\t:\000\000]L\138l\0001\000\000\000\000\000\000\022Z\000\000\128\158\000\000\rH\000\000R\252]L\000\000\000\000H\250\007\158\005\182\b\156\000\000\000\000\000\000\000\000\012\162\000\000O\138\001H\rF\001rK(\017\138\r\152\000\000\000\000\005b\rF\006h\000\003]La\156\004\006\000\000]L\024\144K(\017\168\006h\r\166\000\000\000\000\000\000Q~\004\180\014\004oP]L\000\000\000\003T|P&I\244\003\168\004\176\003\168\006\n\000\t\000\000\rLQ\168Q\168\003\168\006\n\n\014\000\000\r\232Q\168\000\000o\212\011$Yj\000h\007\168\140$\000\000K(k\140K(eNl\020\t|\t\142\t\240Q\168p\\\000\000\007T\n\"c0\000\000\000\000\000\000\000\000Q\168p\228Q\168ql\006\b\000\208e\216\001<\000\208fb\000\000q\244\011$\000\000\000\000\023f\000\000\025\228\000\000\r\236\004\176\000\000c\186S\184\000\000\000$\000\000Q\168\026P\000\000\000\000\000\000bb\000\000\000$\000\003I\186K\178\003\n\001\136\000\003\024\006L\184\018\022\000\003T|\022\022\018\022T|\022\022J\182T|\022\022\000\003Tr\022\022]L]LH\250\000\003Tr\022\022}VRz\004\180\014,u\168\000\003Tr\022\022]L\028N\000\003Tr\022\022]L\030J\000\003\018\022\000\000\000\000\000\000\000\000\001\250\023rH\180\000\000UPV$I\244\003\168\004\176\007\002Q\168\026b\000\000V\248W\204{\138\029LK(\b\178\000\003T|\022\022\018\022\024\006\018\022\003\002\017\254\000\003\000\003\018\022\r\242\000\000\r\248\000\000\018\022\004\n\014\004\000\000\031\246\000\003\014B\000\000\027\254\000\003\019\020\025\004\000\000\000\000\000\000\000\000\006\158\000\003\000\000\000\000\b\194\000\003\000\000\028\252\000\003\029\250\000\003\030\248\000\000\020\018\026\002\000\003\000\000\000\003N\160\000\003\000\000\000\000\000\003\031\246\000\003 \244\000\003!\242\000\003\"\240\000\003#\238\000\003$\236\000\003%\234\000\003&\232\000\003'\230\000\003(\228\000\003)\226\000\003*\224\000\003+\222\000\003,\220\000\003-\218\000\003.\216\000\003/\214\000\0030\212\000\0031\210\000\0032\208\022\022]L\029\134K(\t\200\000\003\000\000\030\132\000\003\000\000]L \128]L!D]L!~\0001\000\000\000\000\000\000\"B]L\"|\000\000u\014\000\000\000\000\000\0003\206\000\003\014R\000\000\000\003\014R\000\000\t\240\018\252\000\003\014\128\000\000f\238J\182\000\000\000\003\014\130\000\000\000\003\014\136\000\000\000\000\018\022\005\018\019\250\000\003\014\144\006\026\000\0034\204\000\003\014\144\007\024\000\0035\202\000\003\014\144\b\022\000\0036\200#\238\000\003\014\164\t\020\000\0037\198\000\003\014\176\n\018\000\0038\196\000\003\014\180\011\016\000\0039\194\n\028\020\248\000\003\014\192\012\014\000\003:\192\000\003\014\216\r\012\000\003;\190\000\003\014\234\014\n\000\003<\188\015\b\000\003=\186\016\006\021\016\000\000\000\000\000\000\014\242\000\000\000\003\014\248\000\000\000\003\014\252\000\000\000\000#@\000\003\000\000\n\134\000\003\000\000]L\000\000\000\000z\134\015\n\000\000K\178\000\000\014L\000\000X\158\000\000\015\020\000\000\003\n\014\172\000\000\024\006\027\252\000h\000\000\029\196K(\027\226K($\248K(#\154\000\000\tN\0114\016\170\000\000\000\000\015&\000\000\001r\028\252Q\132\000\000\011$\000\000\000\000\000\003\014|\000\003\014\132\000\000\014\140\000\003\014\146\000\000\000\003\011$\000\003\014\150\000\003\014\166\000\000\000\000Sv\004\180\015Vu\168\\F\000\208\000\003\000\000\000\000u\168\000\000\000\000\000\000u\168\000\000\0158\000\003\000\000\000\003\000\000\000\000\000\000>\184]L\000\000\000\000\015\140\000\003?\182\000\003@\180\000\000\014\230\000\000\027\000f\238\000\000\017\014\015\134\000\000rf\011\030\n\200\000\000\000\000\015\016\000\000\015\140\000\000\000\000\014\202\000\000\000\000\003\168\004\176\002\236\000\003\000\000\002\248\002\160\000\t\006\n\004\176}\190Q\168\016\186\004\176~H\015 \000\003\000\000\006\n\000\000K\198\022\022\005\170\000\230\002v\015.\000\003\000\000\022\022\129\226]Lu\014\000\000\000\000\015\026\000\003\000\000\000\000oP\000\000\000\000\000\000\000\000\015\184\000\000\000\000^H\004\180\015\018K(\011\160\000\003\000\000\t\024K(\011\196\000\003\000\000\015B\000\003\000\000\000\000u\014\000\000A\178\016\024]LB\176\016\026]LC\174r\224\000\000Q\168\027N\000\000Q\168\029\206\000\000Q\168\027`\000\000l\158\028^\000\000\030J\000\000K(\t\252\000\000[Z\022f\003\218\000=\015\190\b\006\000\003\000\000\015h\000\003\000\000Q\254\000\000\b\210\006\020\000\000\011\188\000\000\015\204\015RK(H\180\015\218\b~\000\003\000\000\015\146\000\003\000\000\022\138\003\168\011\132\015\240v*\140Z\004\180\015\132K(\012h\000\003\000\000\011\174K(O\156\015\164\000\003\000\000UP\000\000Q\254\000\000\017\180\012\\\000\000\rT\000\000\016\002\015\146^H\000\000\016\024v\172\140\170\004\180\015\184K(\012n\000\003\000\000\015\228\000\003\000\000\000\000N\160I\186]LN,\000\003\000\000I~\025\174\003\168\004J\132 Q\168\129\nu\014\000\000\004\002\006\018\000\t\006\nu\014\134\160\002\160\000\t\006\nu\014\134\160\000\000\000\000\006\nu\014\000\000N\160I\186I\244\003\168\004\176u\014\000\000\022|\003\168\0001\015\204K(\012\158\016\156\132\134\000\000u\014\000\000K\198\022\022\005\170z\b\016\158\022\022u\014\000\000\022\022u\014\000\000m m \023\152\002\248\002\160\000\208\136|\000\000\002\160\000\208\136|\000\000JP\025\174\003\168\004J\132 Q\168\132\190\000\000\004\002\t\188\007f\000\208\136|\000\000\000\t\015\224Q\168\132\190Y\252\002\160\000\t\015\246Q\168\132\190Y\252\000\000\000\000\007x\000\003u\014\000\000Q\168\134\212u\014\000\000\007x\000\000P\172\022\022Q\168\132\190\000\000K\198\022\022\005\170tr$\240\031f\021\220\017\184\000\000\011\246\028x\012\220\000\000\016\128\016R 0\021\218`\210K(\012D\000\000`\024\003\218\t\208\t`\000\000\rz\000\000\016\176\0168K(a\136\000\000\003\168\021\182\r\b\000\000\r\184\000\000\016\198\016H^HQ\254\000\000\022\022 0\016\250\004j\002\160\000\003\n\234 0K(\r\n\000\208\000\000K(\n\224\011\222\000\000\000\000s\132\000\000\000\003\012\130 0t\014a\136\000\000\022\022K(\rfK(V\248Q\254\000\000\016\128\000\000Q\254\000\000\000\000`\024\000\000u\014\135r\021\220\017\184\011\246\016\246\016\156 0u\014\135r\000\000\000\000\021\220\017\184\011\246\016\252\016\132\138\196Y<\\F\017\024\138\196\136\188\028\202\017 \138\196\\F\017,\138\196w8w\184\000\000aL\000\000\000\000u\014\138\130\021\220\017\184\011\246\017 \016\172\138\196u\014\138\130\000\000\000\000\000\000m \000\000\000\000\000\000\000\000\000\000\000\000\000\000u\014\000\000\135\128\022\022M\004\017H|l\000\000\129n\135\128\000\000\000\000\139P\022\022M\004\017X\016\220\131\130\000\000\129n\139P\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\026$\240\021\220\017\184\011\246\017^xRJ\224\021\218P\240[Z\022\022\000\003Q\254\000\000\022<\022\022J\224J\224{\bN\160\022\022\129\226]L\t\192\000\000\nf\002\160\000\003\012\230J\224K(\r\218\000h\000\000\022\022xR{\138J\224\t\194J\224\000\000L\166M\160\000\000gJ\000\000\000\000g\212\000\000\000\000h^\000\003\r\188J\224h\232\129\226]L\t\192\000\000\n8\000\000\138\196\017\184\000\000G\174\017\130\000\000Q\254\000\000J\224G\174Q\254\000\000\022\022K(Q\254\000\000\017P\000\000Q\254\000\000\000\000[Z\000\000\130N\138\196\017ZJ\224\130\178xR\000\000u\014\136\028\021\220\017\184\011\246\017\196xRu\014\136\028\000\000\000\000\000\000\137<Tr\000\000\000\000\000\000\000\000\000\000\133\"\000\000\133\200u\014\000\000\135\128\000\000\000\000\000\000\000\000u\014\137<\000\000\018\006\000\000\133F\000\000\133\200\018\020\000\000\017\136\000\000\017\156\000\000u\014\000\000\003\168\004\176u\014\000\000u\014\137<\000\000\000\000\0188\000\000\000\000\0188\027v\029P\132\190\000\000\000\000\000\000\000\000\rL\130\234\131\130\000\000\129n\000\000\018:\027v\029P\132\190\000\000\017\196\000\000\030\204\000\000u\014\000\000\018`\000\000\000\000I\244\003\168\004\176\002\236\000\000Q\168\030\242\000\000\011H\000\000\018t\000\000\018\182]LD\172E\170]LF\168\000\003\000\000\000\003\000\000\017\224\000\003\017\236\000\000\018\152\000\000\000\003\017\236\000\003\017\242\000\000\018\006\000\000\000\000m \018\020\000\000\000\000\027\000i^\018\192\000\000\000\000\000\000\bR\024\216ml\018\198\000\000\000\000\000\000\000\000\000\000\000\000\0180\000\000\016\158\000\000\018L\000\000K(\000\000\007\002\000\000\000\003\018`\000\000\000\000\000\208\000\000\012\012\000\000\000\003\000\000\n\234\000\000\t\142\000\000\018b\000\000]L\024\144\000\000\000\000\025\004\018l\000\000\000\000\018b\025\178J\182\004J~\202\000\000\000\000\000\000\000\000\000\000\137t\000\000\000\000\019\026\000\000\141n\000\000\r\246\019$\000\000\019(\000\000K\178K\178\139b\139b\000\000\000\000u\014\139b\000\000\000\000\000\000u\014\139b\018\156\000\000\018\158\000\000"), (16, "\t\017\000\006\000\246\007R\007V\t\017\001\002\001\006\t\017\001\n\001\022\001\"\t\017\004\234\t\017\0129\001&\t\017\t\202\t\017\t\017\t\017\005\233\t\017\t\017\t\017\001*\001\142\001v\001F\001.\t\017\006\238\006\242\012\182\t\017\0129\t\017\006\161\007\018\n\194\0012\002\178\t\017\t\017\007\130\007\134\t\017\007\138\007\150\001f\007\162\007\170\tZ\t\170\002\182\t\017\t\017\001z\007*\001\006\n\234\t\017\t\017\t\017\n\238\n\242\n\254\011\014\n\182\007\246\t\017\t\017\t\017\t\017\t\017\t\017\t\017\t\017\t\017\011&\007.\t\017\000\238\t\017\t\017\t\017\007*\0112\011J\011j\011~\b\002\t\017\005\030\t\017\t\017\t\017\n\230\t\017\t\017\t\017\t\017\011\006\001>\011\n\001\230\016\146\t\017\007.\t\017\t\017\002B\t\017\t\017\t\017\t\017\t\017\t\017\b\006\011\026\t\017\t\017\t\017\011\146\003j\011\246\012a\t\017\t\017\t\017\t\017\012a\012a\012a\012a\n\198\001\238\012a\012a\012a\012a\001\226\012a\012a\003u\012a\012a\012a\016^\012a\012a\012a\012a\005:\012a\003\002\012a\012a\012a\012a\012a\012a\012a\012a\006\173\001J\001\254\012a\002\014\012a\012a\012a\012a\012a\001\226\003u\012a\012a\012a\003A\012a\007\166\012a\012a\012a\001\165\003\146\012a\012a\012a\012a\012a\012a\012a\003A\012a\012a\012a\012a\012a\012a\012a\012a\012a\012a\012a\003\157\012a\012a\001N\012a\012a\012a\0076\t.\tF\007\005\002\190\012a\012a\012a\012a\012a\012a\0022\012a\012a\012a\012a\012a\012a\012a\005^\012a\012a\007:\012a\012a\002\194\012a\012a\012a\012a\012a\012a\012a\012a\012a\012a\012a\012a\012a\002\214\001\165\012a\012a\012a\012a\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\007\005\001\165\003\157\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\015\234\n\250\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\t6\001\165\001\165\001\165\001\165\001\165\001n\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\003\202\001\165\001\165\001\165\001\165\001\165\001\165\001\165\002:\004Y\004Y\002\218\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\003F\011\170\001\165\b6\001\165\001\165\006n\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\001\165\000\238\001\165\001\165\001\165\001\165\001\165\n\r\002\233\002\233\003>\006m\n\r\n\r\n\r\n\r\004Y\026\218\n\r\n\r\n\r\n\r\000\238\n\r\n\r\004\170\n\r\n\r\n\r\003\149\n\r\n\r\n\r\n\r\006.\n\r\000\n\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\001\242\n\182\004\234\n\r\004\030\n\r\n\r\n\r\n\r\n\r\003\206\005\233\n\r\n\r\n\r\000\238\n\r\n\246\n\r\n\r\n\r\002\233\003J\n\r\n\r\n\r\n\r\n\r\n\r\n\r\017&\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\002Z\n\r\n\r\001J\n\r\n\r\n\r\004Y\016\246\004Y\004Y\004>\n\r\n\r\n\r\n\r\n\r\n\r\004Y\n\r\n\r\n\r\n\r\n\r\012\014\n\r\026\222\012>\n\r\004Y\n\r\n\r\004Y\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\006r\n\r\n\r\n\r\n\r\n\r\003\185\004Y\004Y\004Y\tf\003\185\003\185\003\185\003\185\004Y\b\213\003\185\003\185\003\185\003\185\000\238\003\185\003\185\004Y\003\185\003\185\003\185\004B\003\185\003\185\003\185\003\185\004Y\003\185\002^\003\185\003\185\003\185\003\185\003\185\003\185\003\185\003\185\004Y\002J\000\238\003\185\004.\003\185\003\185\003\185\003\185\003\185\tj\t\134\003\185\003\185\003\185\006u\003\185\004Y\003\185\003\185\003\185\003\206\000\238\003\185\003\185\003\185\003\185\003\185\003\185\003\185\004Y\003\185\003\185\003\185\003\185\003\185\003\185\003\185\003\185\003\185\003\185\003\185\0046\012\006\0126\002N\003\185\003\185\003\185\002\002\007z\007\006\001\006\002B\003\185\003\185\003\185\003\185\003\185\003\185\007\n\003\185\003\185\003\185\003\185\003\185\012\014\003\185\006\t\012>\003\185\001*\003\185\003\185\000\238\003\185\003\185\003\185\003\185\003\185\003\185\003\185\003\185\003\185\003\185\003\185\003\185\003\185\0121\003\185\003\185\003\185\003\185\003\185\003\173\007v\004Y\002\230\b\134\003\173\003\173\003\173\003\173\001z\003\206\003\173\003\173\003\173\003\173\0121\003\173\003\173\0125\003\173\003\173\003\173\003N\003\173\003\173\003\173\003\173\007\217\003\173\004Z\003\173\003\173\003\173\003\173\003\173\003\173\003\173\003\173\t\190\0125\022.\003\173\003\166\003\173\003\173\003\173\003\173\003\173\003\206\001\226\003\173\003\173\003\173\003u\003\173\b\189\003\173\003\173\003\173\004J\006\t\003\173\003\173\003\173\003\173\003\173\003\173\003\173\000\238\003\173\003\173\003\173\003\173\003\173\003\173\003\173\003\173\003\173\003\173\003\173\004\182\012\006\0126\005*\003\173\003\173\003\173\001\"\t\n\001\006\tN\017\206\003\173\003\173\003\173\003\173\003\173\003\173\000\238\003\173\003\173\003\173\003\173\003\173\012\014\003\173\004\197\012>\003\173\004b\003\173\003\173\002\150\003\173\003\173\003\173\003\173\003\173\003\173\003\173\003\173\003\173\003\173\003\173\003\173\003\173\005.\003\173\003\173\003\173\003\173\003\173\t\177\001>\007R\007V\002\162\t\177\t\177\t\177\t\177\0052\003\250\t\177\t\177\t\177\t\177\b\189\t\177\t\177\019\234\t\177\t\177\t\177\004&\t\177\t\177\t\177\t\177\004\154\t\177\003j\t\177\t\177\t\177\t\177\t\177\t\177\t\177\t\177\005\030\018\190\004\198\t\177\t\198\t\177\t\177\t\177\t\177\t\177\012\141\004Y\t\177\t\177\t\177\006}\t\177\014F\t\177\t\177\t\177\001n\007\029\t\177\t\177\t\177\t\177\t\177\t\177\t\177\004\162\t\177\t\177\t\177\t\177\t\177\t\177\t\177\t\177\t\177\t\177\t\177\003>\t\177\t\177\004\210\t\177\t\177\t\177\002\018\nn\017>\000\238\007^\t\177\t\177\t\177\t\177\t\177\t\177\nv\t\177\t\177\t\177\t\177\t\177\t\177\t\177\nz\t\177\t\177\017F\t\177\t\177\004Y\t\177\t\177\t\177\t\177\t\177\t\177\t\177\t\177\t\177\t\177\t\177\t\177\t\177\000\238\t\193\t\177\t\177\t\177\t\177\t\193\t\193\t\193\t\193\tV\003V\t\193\t\193\t\193\t\193\003N\t\193\t\193\012r\t\193\t\193\t\193\004Y\t\193\t\193\t\193\t\193\006b\t\193\003\234\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\005\002\n\182\004\174\t\193\003\137\t\193\t\193\t\193\t\193\t\193\004\214\b\217\t\193\t\193\t\193\000\238\t\193\014Z\t\193\t\193\t\193\003Z\007b\t\193\t\193\t\193\t\193\t\193\t\193\t\193\rf\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\003>\t\193\t\193\b\193\t\193\t\193\t\193\t\006\027\207\005\173\000\238\004\193\t\193\t\193\t\193\t\193\t\193\t\193\t\198\t\193\t\193\t\193\t\193\t\193\t\193\t\193\011\206\t\193\t\193\004\242\t\193\t\193\b\217\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\000\238\t\185\t\193\t\193\t\193\t\193\t\185\t\185\t\185\t\185\005\173\nB\t\185\t\185\t\185\t\185\002B\t\185\t\185\0216\t\185\t\185\t\185\b\217\t\185\t\185\t\185\t\185\020\242\t\185\005\173\t\185\t\185\t\185\t\185\t\185\t\185\t\185\t\185\021B\002B\004\246\t\185\n\n\t\185\t\185\t\185\t\185\t\185\b\193\007\021\t\185\t\185\t\185\007\021\t\185\014n\t\185\t\185\t\185\003\002\n\018\t\185\t\185\t\185\t\185\t\185\t\185\t\185\002B\t\185\t\185\t\185\t\185\t\185\t\185\t\185\t\185\t\185\t\185\t\185\003>\t\185\t\185\006\026\t\185\t\185\t\185\t\014\004r\018\154\004\186\006\237\t\185\t\185\t\185\t\185\t\185\t\185\018\186\t\185\t\185\t\185\t\185\t\185\t\185\t\185\015\174\t\185\t\185\015\182\t\185\t\185\006\194\t\185\t\185\t\185\t\185\t\185\t\185\t\185\t\185\t\185\t\185\t\185\t\185\t\185\007\230\t\165\t\185\t\185\t\185\t\185\t\165\t\165\t\165\t\165\018\194\027\134\t\165\t\165\t\165\t\165\000\238\t\165\t\165\005\233\t\165\t\165\t\165\018\226\t\165\t\165\t\165\t\165\004\249\t\165\004Z\t\165\t\165\t\165\t\165\t\165\t\165\t\165\t\165\012\130\015\174\b\186\t\165\015\182\t\165\t\165\t\165\t\165\t\165\011\242\007\005\t\165\t\165\t\165\007\005\t\165\014\134\t\165\t\165\t\165\001\006\n*\t\165\t\165\t\165\t\165\t\165\t\165\t\165\002v\t\165\t\165\t\165\t\165\t\165\t\165\t\165\t\165\t\165\t\165\t\165\021\210\t\165\t\165\000\238\t\165\t\165\t\165\005\014\rf\005\249\007R\020\238\t\165\t\165\t\165\t\165\t\165\t\165\021\206\t\165\t\165\t\165\t\165\t\165\t\165\t\165\020\254\t\165\t\165\017\242\t\165\t\165\002N\t\165\t\165\t\165\t\165\t\165\t\165\t\165\t\165\t\165\t\165\t\165\t\165\t\165\n\250\t\173\t\165\t\165\t\165\t\165\t\173\t\173\t\173\t\173\021\214\018~\t\173\t\173\t\173\t\173\nF\t\173\t\173\005\241\t\173\t\173\t\173\005\254\t\173\t\173\t\173\t\173\000\238\t\173\004\226\t\173\t\173\t\173\t\173\t\173\t\173\t\173\t\173\004q\024\170\024\254\t\173\003=\t\173\t\173\t\173\t\173\t\173\t\198\004Y\t\173\t\173\t\173\000\238\t\173\014\154\t\173\t\173\t\173\002N\rz\t\173\t\173\t\173\t\173\t\173\t\173\t\173\005F\t\173\t\173\t\173\t\173\t\173\t\173\t\173\t\173\t\173\t\173\t\173\n2\t\173\t\173\000\238\t\173\t\173\t\173\r\246\004q\rf\001F\005N\t\173\t\173\t\173\t\173\t\173\t\173\nZ\t\173\t\173\t\173\t\173\t\173\t\173\t\173\000\238\t\173\t\173\014\186\t\173\t\173\001F\t\173\t\173\t\173\t\173\t\173\t\173\t\173\t\173\t\173\t\173\t\173\t\173\t\173\b\169\t\169\t\173\t\173\t\173\t\173\t\169\t\169\t\169\t\169\025\002\015N\t\169\t\169\t\169\t\169\n\246\t\169\t\169\t\254\t\169\t\169\t\169\015\250\t\169\t\169\t\169\t\169\016\238\t\169\005f\t\169\t\169\t\169\t\169\t\169\t\169\t\169\t\169\015\210\024v\000\238\t\169\t\001\t\169\t\169\t\169\t\169\t\169\b\237\026\238\t\169\t\169\t\169\n&\t\169\014\174\t\169\t\169\t\169\015V\022:\t\169\t\169\t\169\t\169\t\169\t\169\t\169\005\174\t\169\t\169\t\169\t\169\t\169\t\169\t\169\t\169\t\169\t\169\t\169\027\255\t\169\t\169\005\206\t\169\t\169\t\169\006J\nv\b\169\018\198\b\233\t\169\t\169\t\169\t\169\t\169\t\169\005\226\t\169\t\169\t\169\t\169\t\169\t\169\t\169\004Z\t\169\t\169\007\253\t\169\t\169\015\254\t\169\t\169\t\169\t\169\t\169\t\169\t\169\t\169\t\169\t\169\t\169\t\169\t\169\b\165\t\181\t\169\t\169\t\169\t\169\t\181\t\181\t\181\t\181\000\238\005\237\t\181\t\181\t\181\t\181\015\174\t\181\t\181\015\182\t\181\t\181\t\181\006F\t\181\t\181\t\181\t\181\000\238\t\181\006f\t\181\t\181\t\181\t\181\t\181\t\181\t\181\t\181\006v\003\005\000\238\t\181\017\230\t\181\t\181\t\181\t\181\t\181\021\190\003>\t\181\t\181\t\181\021\150\t\181\014\202\t\181\t\181\t\181\019*\017\250\t\181\t\181\t\181\t\181\t\181\t\181\t\181\019V\t\181\t\181\t\181\t\181\t\181\t\181\t\181\t\181\t\181\t\181\t\181\006z\t\181\t\181\006\214\t\181\t\181\t\181\007j\007n\b\165\012\153\000\238\t\181\t\181\t\181\t\181\t\181\t\181\027\239\t\181\t\181\t\181\t\181\t\181\t\181\t\181\003J\t\181\t\181\000\238\t\181\t\181\000\238\t\181\t\181\t\181\t\181\t\181\t\181\t\181\t\181\t\181\t\181\t\181\t\181\t\181\021\158\t\197\t\181\t\181\t\181\t\181\t\197\t\197\t\197\t\197\000\238\022r\t\197\t\197\t\197\t\197\019\030\t\197\t\197\019\142\t\197\t\197\t\197\022F\t\197\t\197\t\197\t\197\021\254\t\197\007\210\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\nv\002B\019^\t\197\020V\t\197\t\197\t\197\t\197\t\197\b\146\b\r\t\197\t\197\t\197\b\234\t\197\014\222\t\197\t\197\t\197\021\218\024\130\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\"\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t2\t\197\t\197\026~\t\197\t\197\t\197\b\001\nv\002\218\022\006\tB\t\197\t\197\t\197\t\197\t\197\t\197\t\130\t\197\t\197\t\197\t\197\t\197\t\197\t\197\005\245\t\197\t\197\000\238\t\197\t\197\022N\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\024\142\t\189\t\197\t\197\t\197\t\197\t\189\t\189\t\189\t\189\004q\b\t\t\189\t\189\t\189\t\189\022\142\t\189\t\189\t\154\t\189\t\189\t\189\t\210\t\189\t\189\t\189\t\189\t\238\t\189\n\170\t\189\t\189\t\189\t\189\t\189\t\189\t\189\t\189\011b\012\"\024\226\t\189\012*\t\189\t\189\t\189\t\189\t\189\012:\012J\t\189\t\189\t\189\005\254\t\189\014\242\t\189\t\189\t\189\r\226\r\238\t\189\t\189\t\189\t\189\t\189\t\189\t\189\nv\t\189\t\189\t\189\t\189\t\189\t\189\t\189\t\189\t\189\t\189\t\189\014\002\t\189\t\189\014\026\t\189\t\189\t\189\014&\014B\022N\014V\014j\t\189\t\189\t\189\t\189\t\189\t\189\014\130\t\189\t\189\t\189\t\189\t\189\t\189\t\189\014\150\t\189\t\189\014\170\t\189\t\189\014\198\t\189\t\189\t\189\t\189\t\189\t\189\t\189\t\189\t\189\t\189\t\189\t\189\t\189\014\218\t\253\t\189\t\189\t\189\t\189\t\253\t\253\t\253\t\253\014\238\015\030\t\253\t\253\t\253\t\253\015*\t\253\t\253\0156\t\253\t\253\t\253\015j\t\253\t\253\t\253\t\253\015z\t\253\015\138\t\253\t\253\t\253\t\253\t\253\t\253\t\253\t\253\015\150\015\226\016\n\t\253\016\018\t\253\t\253\t\253\t\253\t\253\016\026\016\"\t\253\t\253\t\253\0166\t\253\014\254\t\253\t\253\t\253\016>\016R\t\253\t\253\t\253\t\253\t\253\t\253\t\253\016\134\t\253\t\253\t\253\t\253\t\253\t\253\t\253\t\253\t\253\t\253\t\253\016\178\t\253\t\253\016\202\t\253\t\253\t\253\016\226\016\254\017\006\017\018\017Z\t\253\t\253\t\253\t\253\t\253\t\253\017\130\t\253\t\253\t\253\t\253\t\253\t\253\t\253\017\166\t\253\t\253\017\202\t\253\t\253\017\222\t\253\t\253\t\253\t\253\t\253\t\253\t\253\t\253\t\253\t\253\t\253\t\253\t\253\018\006\003\169\t\253\t\253\t\253\t\253\003\169\003\169\003\169\003\169\018\"\018.\003\169\003\169\003\169\003\169\018\150\003\169\003\169\018\166\003\169\003\169\003\169\018\206\003\169\003\169\003\169\003\169\018\210\003\169\018\222\003\169\003\169\003\169\003\169\003\169\003\169\003\169\003\169\001\222\018\238\019\006\003\169\019\022\003\169\003\169\003\169\003\169\003\169\0196\019f\003\169\003\169\003\169\001\246\003\169\002\006\003\169\003\169\003\169\019j\019v\003\169\003\169\003\169\003\169\003\169\003\169\003\169\019\134\003\169\003\169\003\169\003\169\003\169\003\169\003\169\003\169\003\169\003\169\003\169\019\154\012\006\0126\001\006\003\169\003\169\003\169\001\"\020N\001\006\t\250\020Z\003\169\003\169\003\169\003\169\003\169\003\169\021\006\003\169\003\169\003\169\003\169\003\169\012\014\003\169\t\005\012>\003\169\021\030\003\169\003\169\021\166\003\169\003\169\003\169\003\169\003\169\003\169\003\169\003\169\003\169\003\169\003\169\003\169\003\169\006^\003\169\003\169\003\169\003\169\003\169\t\153\001>\nb\021\170\021\226\t\153\t\153\t\153\t\153\0052\021\230\t\153\t\153\t\153\t\153\022\014\t\153\t\153\022\018\t\153\t\153\t\153\000\238\t\153\t\153\t\153\t\153\022*\t\153\022\162\t\153\t\153\t\153\t\153\t\153\t\153\t\153\t\153\005\030\022\210\022\214\t\153\022\250\t\153\t\153\t\153\t\153\t\153\022\254\023\014\t\153\t\153\t\153\023\030\t\153\017N\t\153\t\153\t\153\023*\023^\t\153\t\153\t\153\t\153\t\153\t\153\t\153\023b\t\153\t\153\t\153\t\153\t\153\t\153\t\153\t\153\t\153\t\153\t\153\023\178\012\006\0126\003\161\t\153\t\153\t\153\019R\023\218\021\142\023\222\024\"\t\153\t\153\t\153\t\153\t\153\t\153\004\021\t\153\t\153\t\153\t\153\t\153\012\014\t\153\025\n\012>\t\153\025\022\t\153\t\153\019Z\t\153\t\153\t\153\t\153\t\153\t\153\t\153\t\153\t\153\t\153\t\153\t\153\t\153\000\238\t\153\t\153\t\153\t\153\t\153\002\001\025F\007\253\025j\012\133\002\001\001\002\001\006\002\001\000\238\025\146\001\"\002\001\012\030\002\001\025\254\001&\002\001\012\133\002\001\002\001\002\001\026\018\002\001\002\001\002\001\001*\003\161\012&\026\026\001.\002\001\002\001\002\001\002\001\002\001\012.\002\001\012\018\026\"\026R\0012\004\021\002\001\002\001\002\001\002\001\002\001\026^\026\150\001f\001v\002\001\015\"\002\001\015.\002\001\002\001\001z\026\170\026\194\n\234\002\001\002\001\002\001\n\238\n\242\n\254\026\246\014.\007\246\002\001\002\001\002\001\002\001\002\001\002\001\002\001\002\001\002\001\026\254\012\006\0126\027&\002\001\002\001\002\001\027.\0276\027B\027J\027S\b\002\002\001\005\030\002\001\002\001\002\001\027c\002\001\002\001\002\001\002\001\011\006\0146\011\n\027v\014v\002\001\027\146\002\001\002\001\027\175\002\001\002\001\002\001\002\001\002\001\002\001\b\006\011\026\002\001\002\001\002\001\011\146\003j\027\191\t\233\002\001\002\001\002\001\002\001\t\233\001\002\001\006\t\233\027\219\028\015\001\"\t\233\t\233\t\233\028+\001&\t\233\0286\t\233\t\233\t\233\028k\t\233\t\233\t\233\001*\028\127\t\233\028\135\001.\t\233\t\233\t\233\t\233\t\233\t\233\t\233\r\250\028\195\028\203\0012\000\000\t\233\t\233\t\233\t\233\t\233\000\000\000\000\001f\001v\t\233\014\018\t\233\014\030\t\233\t\233\001z\000\000\000\000\n\234\t\233\t\233\t\233\n\238\n\242\n\254\000\000\t\233\007\246\t\233\t\233\t\233\t\233\t\233\t\233\t\233\t\233\t\233\000\000\t\233\t\233\000\000\t\233\t\233\t\233\000\000\000\000\000\000\000\000\000\000\b\002\t\233\005\030\t\233\t\233\t\233\000\000\t\233\t\233\t\233\t\233\011\006\t\233\011\n\000\000\t\233\t\233\000\000\t\233\t\233\000\000\t\233\t\233\t\233\t\233\t\233\t\233\b\006\011\026\t\233\t\233\t\233\011\146\003j\000\000\t\229\t\233\t\233\t\233\t\233\t\229\001\002\001\006\t\229\000\000\000\000\001\"\t\229\t\229\t\229\000\000\001&\t\229\000\000\t\229\t\229\t\229\000\000\t\229\t\229\t\229\001*\000\000\t\229\000\000\001.\t\229\t\229\t\229\t\229\t\229\t\229\t\229\014:\000\000\000\000\0012\000\000\t\229\t\229\t\229\t\229\t\229\000\000\000\000\001f\001v\t\229\014N\t\229\014b\t\229\t\229\001z\000\000\000\000\n\234\t\229\t\229\t\229\n\238\n\242\n\254\000\000\t\229\007\246\t\229\t\229\t\229\t\229\t\229\t\229\t\229\t\229\t\229\000\000\t\229\t\229\000\000\t\229\t\229\t\229\000\000\000\000\000\000\000\000\000\000\b\002\t\229\005\030\t\229\t\229\t\229\000\000\t\229\t\229\t\229\t\229\011\006\t\229\011\n\000\000\t\229\t\229\000\000\t\229\t\229\000\000\t\229\t\229\t\229\t\229\t\229\t\229\b\006\011\026\t\229\t\229\t\229\011\146\003j\000\000\002E\t\229\t\229\t\229\t\229\002E\001\002\001\006\002E\000\000\000\000\001\"\002E\012\030\002E\000\000\001&\002E\000\000\002E\002E\002E\000\000\002E\002E\002E\001*\004Y\012&\000\000\001.\002E\002E\002E\002E\002E\012.\002E\014\190\000\000\000\000\0012\003\218\002E\002E\002E\002E\002E\000\000\000\000\001f\001v\002E\014\210\002E\014\230\002E\002E\001z\000\000\000\000\n\234\002E\002E\002E\n\238\n\242\n\254\000\238\014.\007\246\002E\002E\002E\002E\002E\002E\002E\002E\002E\000\000\000\000\002E\000\000\002E\002E\002E\021\250\000\000\000\000\004Y\000\000\b\002\002E\005\030\002E\002E\002E\000\000\002E\002E\002E\002E\011\006\000\000\011\n\004Y\000\000\002E\000\000\002E\002E\022\002\002E\002E\002E\002E\002E\002E\b\006\011\026\002E\002E\002E\011\146\003j\004Y\004Y\002E\002E\002E\002E\004Y\004Y\b\005\004Y\004Y\004Y\004Y\004Y\004Y\004Y\004Y\000\000\004Y\000\000\004Y\004Y\004Y\004Y\004Y\004Y\000\000\004Y\004Y\004Y\004Y\004Y\004Y\004Y\004Y\004Y\000\000\004Y\004Y\000\238\000\238\004Y\004Y\000\000\004Y\004Y\004Y\004Y\004Y\004Y\004Y\004Y\004Y\004Y\004Y\004Y\004Y\004Y\004Y\004Y\b\218\004Y\004Y\004Y\004Y\004Y\004Y\004Y\004Y\000\238\004Y\004Y\004Y\004Y\004Y\004Y\004Y\004Y\004Y\000\000\004Y\000\000\004Y\004Y\004Y\004Y\004Y\004Y\000\238\004Y\000\n\004Y\004Y\004Y\004Y\004Y\004Y\004Y\000\000\004Y\004Y\004Y\000\000\000\238\004Y\004Y\002\233\002\233\004Y\000\238\004Y\004Y\000\000\004Y\004Y\000\000\004Y\005*\000\000\000\000\002\233\001\"\000\000\004Y\004Y\004Y\000\000\000\238\004Y\004Y\004Y\004Y\000\161\000\161\004Y\000\161\000\161\000\161\000\161\000\161\000\161\000\161\000\161\000\000\000\161\000\000\000\161\000\161\024J\000\161\000\161\000\000\b\170\000\161\000\161\bb\000\161\000\161\000\161\000\161\005.\000\161\b\190\000\161\000\161\000\000\b\198\000\161\000\161\018\138\000\161\000\161\000\161\t\250\000\161\0052\000\161\000\161\000\161\000\161\000\161\000\161\000\161\000\161\000\161\000\161\001J\018\250\000\161\000\161\000\000\000\000\000\161\000\161\n\154\000\161\000\161\000\161\000\161\000\161\000\161\000\161\000\161\000\161\005\030\002\233\000\161\000\000\000\000\000\161\000\000\000\161\000\000\000\161\000\000\000\000\000\000\nb\000\161\000\161\000\161\000\161\000\161\000\161\006\253\000\161\000\161\000\161\006\253\011\174\001v\000\161\000\n\006R\000\161\000\000\000\161\000\238\000\222\000\000\015n\000\000\000\161\000\000\015~\015\142\015\154\000\000\000\161\000\161\000\161\000\161\000\000\0029\000\161\000\161\000\161\000\161\0029\001\002\001\006\0029\002\233\000\000\001\"\0029\000\000\0029\000\000\001&\0029\000\000\0029\0029\0029\000\000\0029\0029\0029\001*\000\000\000\000\000\000\001.\0029\0029\0029\0029\0029\000\000\0029\000\000\000\000\000\000\0012\000\000\0029\0029\0029\0029\0029\006\253\000\000\001f\011\002\0029\000\000\0029\000\000\0029\0029\001z\000\000\000\000\n\234\0029\0029\0029\n\238\n\242\n\254\007\218\020\162\007\246\0029\0029\0029\0029\0029\0029\0029\0029\0029\000\000\012\006\0126\000\000\0029\0029\0029\000\000\000\000\000\000\004\017\000\000\b\002\0029\005\030\0029\0029\0029\000\000\0029\0029\0029\0029\011\006\012\014\011\n\000\000\012>\0029\000\000\0029\0029\nF\0029\0029\0029\0029\0029\0029\b\006\011\026\0029\0029\0029\011\146\003j\000\000\002Q\0029\0029\0029\0029\002Q\000\238\001\006\002Q\000\000\000\000\000\000\002Q\000\000\002Q\000\000\000\000\002Q\000\000\002Q\002Q\002Q\000\000\002Q\002Q\002Q\000\000\000\000\027\138\002N\000\000\002Q\002Q\002Q\002Q\002Q\000\000\002Q\000\000\004\017\000\000\028\027\000\000\002Q\002Q\002Q\002Q\002Q\000\000\000\000\001\142\001v\002Q\000\000\002Q\b\170\002Q\002Q\bb\tr\000\000\000\000\002Q\002Q\002Q\b\190\005*\000\000\000\000\b\198\001\"\002Q\002Q\002Q\002Q\002Q\002Q\002Q\002Q\002Q\000\000\012\006\0126\000\000\002Q\002Q\002Q\000\000\005\194\000\000\000\000\000\000\002\233\002Q\001J\002Q\002Q\002Q\000\000\002Q\002Q\002Q\002Q\000\000\012\014\000\000\000\000\012>\002Q\005.\002Q\002Q\t\250\002Q\002Q\002Q\002Q\002Q\002Q\000\n\000\000\002Q\002Q\002Q\0052\000\000\005\218\002M\002Q\002Q\002Q\002Q\002M\n\162\001J\002M\002\233\001\142\001v\002M\000\000\002M\005!\000\000\002M\000\000\002M\002M\002M\002\233\002M\002M\002M\005\030\000\000\005!\nb\000\000\002M\002M\002M\002M\002M\000\000\002M\005\230\t\250\000\000\000\000\000\000\002M\002M\002M\002M\002M\t\250\000\238\b:\000\000\002M\000\000\002M\005&\002M\002M\000\000\005!\n\206\007\190\002M\002M\002M\b\222\005*\007\198\000\000\011\214\001\"\002M\002M\002M\002M\002M\002M\002M\002M\002M\000\000\012\006\0126\nb\002M\002M\002M\000\000\000\000\000\000\005!\000\000\nb\002M\005!\002M\002M\002M\000\000\002M\002M\002M\002M\000\238\012\014\000\000\000\000\012>\002M\005.\002M\002M\000\238\002M\002M\002M\002M\002M\002M\000\000\000\000\002M\002M\002M\0052\003\014\005\198\002=\002M\002M\002M\002M\002=\000\000\002v\002=\000\000\000\000\001\"\002=\000\000\002=\000\000\000\000\002=\000\000\002=\002=\002=\000\000\002=\002=\002=\005\030\000\000\000\000\000\000\000\000\002=\002=\002=\002=\002=\000\000\002=\005\210\t\250\000\000\000\000\000\000\002=\002=\002=\002=\002=\t\250\000\000\027n\002N\002=\000\000\002=\005&\002=\002=\000\000\000\000\018F\000\000\002=\002=\002=\0052\007\253\000\000\000\000\018^\007\253\002=\002=\002=\002=\002=\002=\002=\002=\002=\000\000\012\006\0126\nb\002=\002=\002=\000\000\006J\001&\000\000\000\000\nb\002=\005\030\002=\002=\002=\000\000\002=\002=\002=\002=\000\238\012\014\000\000\007&\012>\002=\007\253\002=\002=\000\238\002=\002=\002=\002=\002=\002=\0072\000\000\002=\002=\002=\007\253\000\000\015\162\002I\002=\002=\002=\002=\002I\012\005\012\005\002I\000\000\012\005\000\000\002I\000\000\002I\000\000\007\246\002I\000\000\002I\002I\002I\000\000\002I\002I\002I\007\253\000\000\000\000\000\000\000\000\002I\002I\002I\002I\002I\000\000\002I\b\002\000\000\000\000\000\000\000\000\002I\002I\002I\002I\002I\t\250\000\000\000\238\000\000\002I\000\000\002I\007\253\002I\002I\000\000\000\000\000\000\b\166\002I\002I\002I\b\006\000\000\012-\000\000\018j\000\000\002I\002I\002I\002I\002I\002I\002I\002I\002I\012\006\0126\002I\012\005\002I\002I\002I\000\000\012-\000\000\000\000\002\142\nb\002I\002\146\002I\002I\002I\000\000\002I\002I\002I\002I\012\014\000\238\007\001\012>\002\158\002I\007\001\002I\002I\000\238\012R\002I\002I\002I\002I\002I\011z\000\000\002I\002I\002I\000\000\b\165\000\000\t\r\002I\002I\002I\002I\t\r\000\000\001J\t\r\002\170\016&\000\000\t\r\000\000\t\r\002B\000\000\012\142\000\000\t\r\012\178\t\r\000\238\t\r\t\r\t\r\b\170\000\000\004\134\bb\b\178\012\198\012\222\012\230\012\206\012\238\b\190\t\r\000\000\000\238\b\198\000\000\000\000\t\r\t\r\012\246\012\254\t\r\000\000\005*\011\174\015\238\t\r\001\"\t\r\007\001\r\006\t\r\002\174\003\002\000\000\015n\t\r\t\r\000\238\015~\015\142\015\154\000\000\000\000\000\000\t\r\t\r\012\150\012\214\r\014\r\022\r&\t\r\t\r\000\000\000\000\t\r\000\000\t\r\t\r\r.\000\000\b\165\000\000\003\146\000\000\005.\t\r\004\253\t\r\t\r\r6\b\217\t\r\t\r\t\r\t\r\000\000\007\157\t\250\000\000\0052\t\r\000\000\t\r\t\r\000\000\rV\t\r\r^\r\030\t\r\t\r\000\000\007%\t\r\r>\t\r\007%\000\000\018R\002}\t\r\t\r\rF\rN\002}\nI\000\000\002}\005\030\007\157\000\000\002}\000\000\002}\000\000\000\000\002}\000\000\002}\002}\002}\nb\002}\002}\002}\007\157\000\000\000\000\007\157\011\234\002}\002}\002}\002}\002}\007\157\002}\005\130\nI\007\157\000\000\000\238\002}\002}\002}\002}\002}\000\000\000\000\000\000\000\000\002}\000\000\002}\nI\002}\002}\nI\rr\000\000\018r\002}\002}\002}\nI\000\000\000\000\000\000\nI\007%\002}\002}\012\150\002}\002}\002}\002}\002}\002}\000\000\000\000\002}\000\000\002}\002}\002}\015\174\000\000\000\000\015\182\000\000\018V\002}\000\000\002}\002}\002}\000\000\002}\002}\002}\002}\000\000\000\238\t\250\000\000\000\000\002}\000\000\002}\002}\000\000\002}\002}\002}\002}\002}\002}\000\000\000\000\002}\002}\002}\t\250\000\000\026\178\002e\002}\002}\002}\002}\002e\000\238\000\000\002e\000\000\011\142\000\000\002e\000\000\002e\000\000\000\000\002e\026\230\002e\002e\002e\nb\002e\002e\002e\b\170\000\000\000\000\bb\018v\002e\002e\002e\002e\002e\b\190\002e\000\000\r\134\b\198\nb\000\238\002e\002e\002e\002e\002e\000\000\b\145\000\000\000\000\002e\000\000\002e\r\142\002e\002e\r\150\002\233\000\000\000\238\002e\002e\002e\r\158\000\000\000\000\000\000\r\166\000\000\002e\002e\012\150\002e\002e\002e\002e\002e\002e\000\000\000\000\002e\000\000\002e\002e\002e\000\000\000\000\000\n\b\145\000\000\000\000\002e\000\000\002e\002e\002e\000\000\002e\002e\002e\002e\000\000\000\000\000\000\002\233\000\000\002e\000\000\002e\002e\b\145\002e\002e\002e\002e\002e\002e\002\233\002\233\002e\002e\002e\000\000\000\000\000\000\002q\002e\002e\002e\002e\002q\000\000\001\006\002q\000\000\000\000\000\000\002q\000\000\002q\000\000\000\000\012\142\000\000\002q\002q\002q\b\145\002q\002q\002q\003\246\000\000\000\000\b\145\000\000\002q\002q\002q\012\206\002q\002B\002q\000\000\000\000\000\000\000\000\000\000\002q\002q\002q\002q\002q\000\000\b\141\012B\001>\002q\000\000\002q\001*\002q\002q\000\000\000\000\000\000\000\000\002q\002q\002q\r\218\000\000\r\230\021\174\000\000\000\000\002q\002q\012\150\012\214\002q\002q\002q\002q\002q\003\002\000\000\002q\022&\002q\002q\002q\001z\000\000\000\000\b\141\000\000\000\000\002q\022>\002q\002q\002q\000\000\002q\002q\002q\002q\000\000\000\000\000\000\000\000\000\000\002q\000\000\002q\002q\b\141\002q\002q\002q\002q\002q\002q\000\000\000\000\002q\002q\002q\000\000\000\000\000\000\002\129\002q\002q\002q\002q\002\129\000\238\000\000\002\129\000\000\000\000\000\000\002\129\000\000\002\129\000\000\000\000\002\129\000\000\002\129\002\129\002\129\b\141\002\129\002\129\002\129\003\246\000\000\000\000\b\141\000\000\002\129\002\129\002\129\002\129\002\129\000\000\002\129\000\000\007\153\000\000\000\000\000\000\002\129\002\129\002\129\002\129\002\129\000\000\000\000\000\000\000\000\002\129\000\000\002\129\007\153\002\129\002\129\bb\000\000\000\000\000\000\002\129\002\129\002\129\007\153\000\000\000\000\000\000\007\153\000\000\002\129\002\129\012\150\002\129\002\129\002\129\002\129\002\129\002\129\000\000\000\000\002\129\000\000\002\129\002\129\002\129\000\000\000\000\000\000\000\000\000\000\000\000\002\129\000\000\002\129\002\129\002\129\000\000\002\129\002\129\002\129\002\129\000\000\007\177\000\000\000\000\000\000\002\129\000\000\002\129\002\129\000\000\002\129\002\129\002\129\002\129\002\129\002\129\000\000\000\000\002\129\002\129\002\129\000\000\000\000\000\000\002a\002\129\002\129\002\129\002\129\002a\000\238\000\000\002a\000\000\007\177\000\000\002a\000\000\002a\000\000\000\000\002a\000\000\002a\002a\002a\000\000\002a\002a\002a\007\177\000\000\000\000\bb\000\000\002a\002a\002a\002a\002a\007\177\002a\000\000\007\197\007\177\000\000\000\000\002a\002a\002a\002a\002a\000\000\000\000\000\000\000\000\002a\000\000\002a\b\170\002a\002a\bb\000\000\000\000\000\000\002a\002a\002a\007\197\000\000\000\000\000\000\007\197\000\000\002a\002a\012\150\002a\002a\002a\002a\002a\002a\000\000\000\000\002a\000\000\002a\002a\002a\000\000\000\000\000\000\000\000\000\000\000\000\002a\000\000\002a\002a\002a\000\000\002a\002a\002a\002a\000\000\007\193\000\000\000\000\000\000\002a\000\000\002a\002a\000\000\002a\002a\002a\002a\002a\002a\000\000\000\000\002a\002a\002a\000\000\000\000\000\000\002m\002a\002a\002a\002a\002m\000\238\000\000\002m\000\000\007\193\000\000\002m\000\000\002m\000\000\000\000\012\142\000\000\002m\002m\002m\000\000\002m\002m\002m\r\186\000\000\000\000\007\193\000\000\002m\002m\002m\012\206\002m\007\193\002m\000\000\007\149\007\193\000\000\000\000\002m\002m\002m\002m\002m\000\000\000\000\000\000\000\000\002m\000\000\002m\007\149\002m\002m\bb\000\000\000\000\000\000\002m\002m\002m\007\149\000\000\000\000\000\000\007\149\000\000\002m\002m\012\150\012\214\002m\002m\002m\002m\002m\000\000\000\000\002m\000\000\002m\002m\002m\000\000\000\000\000\000\000\000\000\000\000\000\002m\000\000\002m\002m\002m\000\000\002m\002m\002m\002m\000\000\000\238\012\001\012\001\000\000\002m\012\001\002m\002m\000\000\002m\002m\002m\002m\002m\002m\000\000\000\000\002m\002m\002m\000\000\000\000\000\000\002i\002m\002m\002m\002m\002i\000\000\001\006\002i\000\000\015B\000\000\002i\000\000\002i\000\000\000\000\012\142\000\000\002i\002i\002i\000\238\002i\002i\002i\r\142\000\000\000\000\r\150\000\000\002i\002i\002i\012\206\002i\r\158\002i\000\000\000\000\r\166\000\000\000\000\002i\002i\002i\002i\002i\000\000\000\000\014z\001>\002i\000\000\002i\012\001\002i\002i\000\000\000\000\000\000\000\000\002i\002i\002i\014\142\000\000\014\162\000\000\000\000\000\000\002i\002i\012\150\012\214\002i\002i\002i\002i\002i\000\000\000\000\002i\000\000\002i\002i\002i\000\000\000\000\000\000\000\000\000\000\000\000\002i\000\000\002i\002i\002i\000\000\002i\002i\002i\002i\000\000\000\000\000\000\000\000\000\000\002i\000\000\002i\002i\000\000\002i\002i\002i\002i\002i\002i\000\000\000\000\002i\002i\002i\000\000\000\000\000\000\002\145\002i\002i\002i\002i\002\145\002\233\000\000\002\145\000\000\021\130\000\000\002\145\000\000\002\145\000\000\000\000\012\142\000\000\002\145\002\145\002\145\000\000\002\145\002\145\002\145\011\253\011\253\000\000\000\000\011\253\012\198\012\222\012\230\012\206\012\238\000\n\002\145\000\000\000\000\000\000\000\000\000\000\002\145\002\145\012\246\012\254\002\145\000\000\000\000\000\000\000\000\002\145\002\233\002\145\000\000\r\006\002\145\000\000\000\000\000\000\000\000\002\145\002\145\000\238\000\000\002\233\002\233\000\000\000\000\000\238\002\145\002\145\012\150\012\214\r\014\r\022\r&\002\145\002\145\000\000\000\000\002\145\000\000\002\145\002\145\r.\000\000\000\000\000\000\007\241\000\000\000\000\002\145\007\241\002\145\002\145\r6\000\000\002\145\002\145\002\145\002\145\011\253\000\000\000\000\000\000\000\000\002\145\000\000\002\145\002\145\000\000\002\145\002\145\002\145\r\030\002\145\002\145\000\000\015\190\002\145\r>\002\145\000\000\000\000\000\000\002y\002\145\002\145\rF\rN\002y\000\000\007\241\002y\000\000\000\000\000\000\002y\000\000\002y\000\000\000\000\012\142\000\000\002y\002y\002y\000\000\002y\002y\002y\000\000\000\000\000\000\007\241\000\000\002y\002y\002y\012\206\002y\000\000\002y\000\000\000\000\000\000\000\000\000\000\002y\002y\002y\002y\002y\000\000\000\000\000\000\000\000\002y\000\000\002y\000\000\002y\002y\000\000\000\000\000\000\000\000\002y\002y\002y\000\000\000\000\000\000\000\000\000\000\003\246\002y\002y\012\150\012\214\002y\002y\002y\002y\002y\000\000\000\000\002y\000\000\002y\002y\002y\000\000\000\000\000\000\007\237\000\000\000\000\002y\007\237\002y\002y\002y\000\000\002y\002y\002y\002y\000\000\000\000\000\000\000\000\000\000\002y\000\000\002y\002y\000\000\002y\002y\002y\002y\002y\002y\000\000\000\000\002y\002y\002y\000\000\000\000\000\000\002u\002y\002y\002y\002y\002u\000\000\007\237\002u\000\000\000\000\000\000\002u\000\000\002u\000\000\000\000\012\142\000\000\002u\002u\002u\000\000\002u\002u\002u\000\000\000\000\000\000\007\237\000\000\002u\002u\002u\012\206\002u\000\000\002u\000\000\000\000\000\000\000\000\000\000\002u\002u\002u\002u\002u\000\000\000\000\000\000\000\000\002u\000\000\002u\000\000\002u\002u\000\000\000\000\000\000\000\000\002u\002u\002u\000\000\000\000\000\000\000\000\000\000\003\246\002u\002u\012\150\012\214\002u\002u\002u\002u\002u\000\000\000\000\002u\000\000\002u\002u\002u\000\000\000\000\000\000\000\000\000\000\000\000\002u\000\000\002u\002u\002u\000\000\002u\002u\002u\002u\000\000\000\000\000\000\000\000\000\000\002u\000\000\002u\002u\000\000\002u\002u\002u\002u\002u\002u\000\000\000\000\002u\002u\002u\000\000\000\000\000\000\002\137\002u\002u\002u\002u\002\137\000\000\000\000\002\137\000\000\000\000\000\000\002\137\000\000\002\137\000\000\000\000\012\142\000\000\002\137\002\137\002\137\000\000\002\137\002\137\002\137\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\002\137\000\000\002\137\000\000\000\000\000\000\000\000\000\000\002\137\002\137\012\246\012\254\002\137\000\000\000\000\000\000\000\000\002\137\000\000\002\137\000\000\002\137\002\137\000\000\000\000\000\000\000\000\002\137\002\137\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\137\002\137\012\150\012\214\r\014\r\022\002\137\002\137\002\137\000\000\000\000\002\137\000\000\002\137\002\137\002\137\000\000\000\000\000\000\000\000\000\000\000\000\002\137\000\000\002\137\002\137\002\137\000\000\002\137\002\137\002\137\002\137\000\000\000\000\000\000\000\000\000\000\002\137\000\000\002\137\002\137\000\000\002\137\002\137\002\137\r\030\002\137\002\137\000\000\000\000\002\137\002\137\002\137\000\000\000\000\000\000\002]\002\137\002\137\002\137\002\137\002]\000\000\000\000\002]\000\000\000\000\000\000\002]\000\000\002]\000\000\000\000\012\142\000\000\002]\002]\002]\000\000\002]\002]\002]\000\000\000\000\000\000\000\000\000\000\002]\002]\002]\012\206\002]\000\000\002]\000\000\000\000\000\000\000\000\000\000\002]\002]\002]\002]\002]\000\000\000\000\000\000\000\000\002]\000\000\002]\000\000\002]\002]\000\000\000\000\000\000\000\000\002]\002]\002]\000\000\000\000\000\000\000\000\000\000\000\000\002]\002]\012\150\012\214\002]\002]\002]\002]\002]\000\000\000\000\002]\000\000\002]\002]\002]\000\000\000\000\000\000\000\000\000\000\000\000\002]\000\000\002]\002]\002]\000\000\002]\002]\002]\002]\000\000\000\000\000\000\000\000\000\000\002]\000\000\002]\002]\000\000\002]\002]\002]\002]\002]\002]\000\000\000\000\002]\002]\002]\000\000\000\000\000\000\002Y\002]\002]\002]\002]\002Y\000\000\000\000\002Y\000\000\000\000\000\000\002Y\000\000\002Y\000\000\000\000\012\142\000\000\002Y\002Y\002Y\000\000\002Y\002Y\002Y\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\002Y\000\000\002Y\000\000\000\000\000\000\000\000\000\000\002Y\002Y\012\246\012\254\002Y\000\000\000\000\000\000\000\000\002Y\000\000\002Y\000\000\002Y\002Y\000\000\000\000\000\000\000\000\002Y\002Y\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002Y\002Y\012\150\012\214\r\014\r\022\002Y\002Y\002Y\000\000\000\000\002Y\000\000\002Y\002Y\002Y\000\000\000\000\000\000\000\000\000\000\000\000\002Y\000\000\002Y\002Y\002Y\000\000\002Y\002Y\002Y\002Y\000\000\000\000\000\000\000\000\000\000\002Y\000\000\002Y\002Y\000\000\002Y\002Y\002Y\r\030\002Y\002Y\000\000\000\000\002Y\002Y\002Y\000\000\000\000\000\000\002\181\002Y\002Y\002Y\002Y\002\181\000\000\000\000\002\181\000\000\000\000\000\000\002\181\000\000\002\181\000\000\000\000\012\142\000\000\002\181\002\181\002\181\000\000\002\181\002\181\002\181\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\002\181\000\000\002\181\000\000\000\000\000\000\000\000\000\000\002\181\002\181\012\246\012\254\002\181\000\000\000\000\000\000\000\000\002\181\000\000\002\181\000\000\002\181\002\181\000\000\000\000\000\000\000\000\002\181\002\181\002\181\000\000\000\000\000\000\000\000\000\000\000\000\002\181\002\181\012\150\012\214\r\014\002\181\002\181\002\181\002\181\000\000\000\000\002\181\000\000\002\181\002\181\002\181\000\000\000\000\000\000\000\000\000\000\000\000\002\181\000\000\002\181\002\181\002\181\000\000\002\181\002\181\002\181\002\181\000\000\000\000\000\000\000\000\000\000\002\181\000\000\002\181\002\181\000\000\002\181\002\181\002\181\r\030\002\181\002\181\000\000\000\000\002\181\002\181\002\181\000\000\000\000\000\000\002U\002\181\002\181\002\181\002\181\002U\000\000\000\000\002U\000\000\000\000\000\000\002U\000\000\002U\000\000\000\000\012\142\000\000\002U\002U\002U\000\000\002U\002U\002U\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\002U\000\000\002U\000\000\000\000\000\000\000\000\000\000\002U\002U\012\246\012\254\002U\000\000\000\000\000\000\000\000\002U\000\000\002U\000\000\002U\002U\000\000\000\000\000\000\000\000\002U\002U\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002U\002U\012\150\012\214\r\014\r\022\002U\002U\002U\000\000\000\000\002U\000\000\002U\002U\002U\000\000\000\000\000\000\000\000\000\000\000\000\002U\000\000\002U\002U\002U\000\000\002U\002U\002U\002U\000\000\000\000\000\000\000\000\000\000\002U\000\000\002U\002U\000\000\002U\002U\002U\r\030\002U\002U\000\000\000\000\002U\002U\002U\000\000\000\000\000\000\002\141\002U\002U\002U\002U\002\141\000\000\000\000\002\141\000\000\000\000\000\000\002\141\000\000\002\141\000\000\000\000\012\142\000\000\002\141\002\141\002\141\000\000\002\141\002\141\002\141\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\002\141\000\000\002\141\000\000\000\000\000\000\000\000\000\000\002\141\002\141\012\246\012\254\002\141\000\000\000\000\000\000\000\000\002\141\000\000\002\141\000\000\002\141\002\141\000\000\000\000\000\000\000\000\002\141\002\141\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\141\002\141\012\150\012\214\r\014\r\022\002\141\002\141\002\141\000\000\000\000\002\141\000\000\002\141\002\141\002\141\000\000\000\000\000\000\000\000\000\000\000\000\002\141\000\000\002\141\002\141\002\141\000\000\002\141\002\141\002\141\002\141\000\000\000\000\000\000\000\000\000\000\002\141\000\000\002\141\002\141\000\000\002\141\002\141\002\141\r\030\002\141\002\141\000\000\000\000\002\141\002\141\002\141\000\000\000\000\000\000\002\133\002\141\002\141\002\141\002\141\002\133\000\000\000\000\002\133\000\000\000\000\000\000\002\133\000\000\002\133\000\000\000\000\012\142\000\000\002\133\002\133\002\133\000\000\002\133\002\133\002\133\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\002\133\000\000\002\133\000\000\000\000\000\000\000\000\000\000\002\133\002\133\012\246\012\254\002\133\000\000\000\000\000\000\000\000\002\133\000\000\002\133\000\000\002\133\002\133\000\000\000\000\000\000\000\000\002\133\002\133\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\133\002\133\012\150\012\214\r\014\r\022\002\133\002\133\002\133\000\000\000\000\002\133\000\000\002\133\002\133\002\133\000\000\000\000\000\000\000\000\000\000\000\000\002\133\000\000\002\133\002\133\002\133\000\000\002\133\002\133\002\133\002\133\000\000\000\000\000\000\000\000\000\000\002\133\000\000\002\133\002\133\000\000\002\133\002\133\002\133\r\030\002\133\002\133\000\000\000\000\002\133\002\133\002\133\000\000\000\000\000\000\002\149\002\133\002\133\002\133\002\133\002\149\000\000\000\000\002\149\000\000\000\000\000\000\002\149\000\000\002\149\000\000\000\000\012\142\000\000\002\149\002\149\002\149\000\000\002\149\002\149\002\149\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\012\238\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002\149\002\149\012\246\012\254\002\149\000\000\000\000\000\000\000\000\002\149\000\000\002\149\000\000\r\006\002\149\000\000\000\000\000\000\000\000\002\149\002\149\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\149\002\149\012\150\012\214\r\014\r\022\r&\002\149\002\149\000\000\000\000\002\149\000\000\002\149\002\149\r.\000\000\000\000\000\000\000\000\000\000\000\000\002\149\000\000\002\149\002\149\r6\000\000\002\149\002\149\002\149\002\149\000\000\000\000\000\000\000\000\000\000\002\149\000\000\002\149\002\149\000\000\002\149\002\149\002\149\r\030\002\149\002\149\000\000\000\000\002\149\r>\002\149\000\000\000\000\000\000\002\153\002\149\002\149\rF\rN\002\153\000\000\000\000\002\153\000\000\000\000\000\000\002\153\000\000\002\153\000\000\000\000\012\142\000\000\002\153\002\153\002\153\000\000\002\153\002\153\002\153\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\002\153\000\000\002\153\000\000\000\000\000\000\000\000\000\000\002\153\002\153\012\246\012\254\002\153\000\000\000\000\000\000\000\000\002\153\000\000\002\153\000\000\r\006\002\153\000\000\000\000\000\000\000\000\002\153\002\153\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\153\002\153\012\150\012\214\r\014\r\022\r&\002\153\002\153\000\000\000\000\002\153\000\000\002\153\002\153\r.\000\000\000\000\000\000\000\000\000\000\000\000\002\153\000\000\002\153\002\153\r6\000\000\002\153\002\153\002\153\002\153\000\000\000\000\000\000\000\000\000\000\002\153\000\000\002\153\002\153\000\000\002\153\002\153\002\153\r\030\002\153\002\153\000\000\000\000\002\153\002\153\002\153\000\000\000\000\000\000\002\157\002\153\002\153\rF\rN\002\157\000\000\000\000\002\157\000\000\000\000\000\000\002\157\000\000\002\157\000\000\000\000\012\142\000\000\002\157\002\157\002\157\000\000\002\157\002\157\002\157\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\002\157\000\000\002\157\000\000\000\000\000\000\000\000\000\000\002\157\002\157\012\246\012\254\002\157\000\000\000\000\000\000\000\000\002\157\000\000\002\157\000\000\r\006\002\157\000\000\000\000\000\000\000\000\002\157\002\157\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\157\002\157\012\150\012\214\r\014\r\022\r&\002\157\002\157\000\000\000\000\002\157\000\000\002\157\002\157\r.\000\000\000\000\000\000\000\000\000\000\000\000\002\157\000\000\002\157\002\157\r6\000\000\002\157\002\157\002\157\002\157\000\000\000\000\000\000\000\000\000\000\002\157\000\000\002\157\002\157\000\000\002\157\002\157\002\157\r\030\002\157\002\157\000\000\000\000\002\157\002\157\002\157\000\000\000\000\000\000\b\201\002\157\002\157\rF\rN\b\201\000\000\000\000\b\201\000\000\000\000\000\000\b\201\000\000\b\201\000\000\000\000\012\142\000\000\b\201\b\201\b\201\000\000\b\201\b\201\b\201\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\012\238\000\000\b\201\000\000\000\000\000\000\000\000\000\000\b\201\b\201\012\246\012\254\b\201\000\000\000\000\000\000\000\000\b\201\000\000\b\201\000\000\r\006\b\201\000\000\000\000\000\000\000\000\b\201\b\201\000\238\000\000\000\000\000\000\000\000\000\000\000\000\b\201\b\201\012\150\012\214\r\014\r\022\r&\b\201\b\201\000\000\000\000\b\201\000\000\b\201\b\201\r.\000\000\000\000\000\000\000\000\000\000\000\000\b\201\000\000\b\201\b\201\r6\000\000\b\201\b\201\b\201\b\201\000\000\000\000\000\000\000\000\000\000\b\201\000\000\b\201\b\201\000\000\b\201\b\201\b\201\r\030\b\201\b\201\000\000\000\000\b\201\r>\b\201\000\000\000\000\000\000\002\161\b\201\b\201\rF\rN\002\161\000\000\000\000\002\161\000\000\000\000\000\000\002\161\000\000\002\161\000\000\000\000\012\142\000\000\002\161\002\161\002\161\000\000\002\161\002\161\002\161\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\012\238\000\000\002\161\000\000\000\000\000\000\000\000\000\000\002\161\002\161\012\246\012\254\002\161\000\000\000\000\000\000\000\000\002\161\000\000\002\161\000\000\r\006\002\161\000\000\000\000\000\000\000\000\002\161\002\161\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\161\002\161\012\150\012\214\r\014\r\022\r&\002\161\002\161\000\000\000\000\002\161\000\000\002\161\002\161\r.\000\000\000\000\000\000\000\000\000\000\000\000\002\161\000\000\002\161\002\161\r6\000\000\002\161\002\161\002\161\002\161\000\000\000\000\000\000\000\000\000\000\002\161\000\000\002\161\002\161\000\000\rV\002\161\r^\r\030\002\161\002\161\000\000\000\000\002\161\r>\002\161\000\000\000\000\000\000\b\197\002\161\002\161\rF\rN\b\197\000\000\000\000\b\197\000\000\000\000\000\000\b\197\000\000\b\197\000\000\000\000\012\142\000\000\b\197\b\197\b\197\000\000\b\197\b\197\b\197\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\012\238\000\000\b\197\000\000\000\000\000\000\000\000\000\000\b\197\b\197\012\246\012\254\b\197\000\000\000\000\000\000\000\000\b\197\000\000\b\197\000\000\r\006\b\197\000\000\000\000\000\000\000\000\b\197\b\197\000\238\000\000\000\000\000\000\000\000\000\000\000\000\b\197\b\197\012\150\012\214\r\014\r\022\r&\b\197\b\197\000\000\000\000\b\197\000\000\b\197\b\197\r.\000\000\000\000\000\000\000\000\000\000\000\000\b\197\000\000\b\197\b\197\r6\000\000\b\197\b\197\b\197\b\197\000\000\000\000\000\000\000\000\000\000\b\197\000\000\b\197\b\197\000\000\b\197\b\197\b\197\r\030\b\197\b\197\000\000\000\000\b\197\r>\b\197\000\000\000\000\000\000\002\205\b\197\b\197\rF\rN\002\205\000\000\000\000\002\205\000\000\000\000\000\000\002\205\000\000\002\205\000\000\000\000\012\142\000\000\002\205\002\205\002\205\000\000\002\205\002\205\002\205\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\012\238\000\000\002\205\000\000\000\000\000\000\000\000\000\000\002\205\002\205\012\246\012\254\002\205\000\000\000\000\000\000\000\000\002\205\000\000\002\205\000\000\r\006\002\205\000\000\000\000\000\000\000\000\002\205\002\205\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\205\002\205\012\150\012\214\r\014\r\022\r&\002\205\002\205\000\000\000\000\002\205\000\000\002\205\002\205\r.\000\000\000\000\000\000\000\000\000\000\000\000\002\205\000\000\002\205\002\205\r6\000\000\002\205\002\205\002\205\002\205\000\000\000\000\000\000\000\000\000\000\002\205\000\000\002\205\002\205\000\000\rV\002\205\r^\r\030\002\205\002\205\000\000\000\000\002\205\r>\002\205\000\000\000\000\000\000\002\221\002\205\002\205\rF\rN\002\221\000\000\000\000\002\221\000\000\000\000\000\000\002\221\000\000\002\221\000\000\000\000\012\142\000\000\002\221\002\221\002\221\000\000\002\221\002\221\002\221\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\012\238\000\000\002\221\000\000\000\000\000\000\000\000\000\000\002\221\002\221\012\246\012\254\002\221\000\000\000\000\000\000\000\000\002\221\000\000\002\221\000\000\r\006\002\221\000\000\000\000\000\000\000\000\002\221\002\221\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\221\002\221\012\150\012\214\r\014\r\022\r&\002\221\002\221\000\000\000\000\002\221\000\000\002\221\002\221\r.\000\000\000\000\000\000\000\000\000\000\000\000\002\221\000\000\002\221\002\221\r6\000\000\002\221\002\221\002\221\002\221\000\000\000\000\000\000\000\000\000\000\002\221\000\000\002\221\002\221\000\000\rV\002\221\r^\r\030\002\221\002\221\000\000\000\000\002\221\r>\002\221\000\000\000\000\000\000\002\213\002\221\002\221\rF\rN\002\213\000\000\000\000\002\213\000\000\000\000\000\000\002\213\000\000\002\213\000\000\000\000\012\142\000\000\002\213\002\213\002\213\000\000\002\213\002\213\002\213\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\012\238\000\000\002\213\000\000\000\000\000\000\000\000\000\000\002\213\002\213\012\246\012\254\002\213\000\000\000\000\000\000\000\000\002\213\000\000\002\213\000\000\r\006\002\213\000\000\000\000\000\000\000\000\002\213\002\213\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\213\002\213\012\150\012\214\r\014\r\022\r&\002\213\002\213\000\000\000\000\002\213\000\000\002\213\002\213\r.\000\000\000\000\000\000\000\000\000\000\000\000\002\213\000\000\002\213\002\213\r6\000\000\002\213\002\213\002\213\002\213\000\000\000\000\000\000\000\000\000\000\002\213\000\000\002\213\002\213\000\000\rV\002\213\r^\r\030\002\213\002\213\000\000\000\000\002\213\r>\002\213\000\000\000\000\000\000\002\193\002\213\002\213\rF\rN\002\193\000\000\000\000\002\193\000\000\000\000\000\000\002\193\000\000\002\193\000\000\000\000\012\142\000\000\002\193\002\193\002\193\000\000\002\193\002\193\002\193\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\012\238\000\000\002\193\000\000\000\000\000\000\000\000\000\000\002\193\002\193\012\246\012\254\002\193\000\000\000\000\000\000\000\000\002\193\000\000\002\193\000\000\r\006\002\193\000\000\000\000\000\000\000\000\002\193\002\193\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\193\002\193\012\150\012\214\r\014\r\022\r&\002\193\002\193\000\000\000\000\002\193\000\000\002\193\002\193\r.\000\000\000\000\000\000\000\000\000\000\000\000\002\193\000\000\002\193\002\193\r6\000\000\002\193\002\193\002\193\002\193\000\000\000\000\000\000\000\000\000\000\002\193\000\000\002\193\002\193\000\000\rV\002\193\r^\r\030\002\193\002\193\000\000\000\000\002\193\r>\002\193\000\000\000\000\000\000\002\201\002\193\002\193\rF\rN\002\201\000\000\000\000\002\201\000\000\000\000\000\000\002\201\000\000\002\201\000\000\000\000\012\142\000\000\002\201\002\201\002\201\000\000\002\201\002\201\002\201\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\012\238\000\000\002\201\000\000\000\000\000\000\000\000\000\000\002\201\002\201\012\246\012\254\002\201\000\000\000\000\000\000\000\000\002\201\000\000\002\201\000\000\r\006\002\201\000\000\000\000\000\000\000\000\002\201\002\201\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\201\002\201\012\150\012\214\r\014\r\022\r&\002\201\002\201\000\000\000\000\002\201\000\000\002\201\002\201\r.\000\000\000\000\000\000\000\000\000\000\000\000\002\201\000\000\002\201\002\201\r6\000\000\002\201\002\201\002\201\002\201\000\000\000\000\000\000\000\000\000\000\002\201\000\000\002\201\002\201\000\000\rV\002\201\r^\r\030\002\201\002\201\000\000\000\000\002\201\r>\002\201\000\000\000\000\000\000\002\197\002\201\002\201\rF\rN\002\197\000\000\000\000\002\197\000\000\000\000\000\000\002\197\000\000\002\197\000\000\000\000\012\142\000\000\002\197\002\197\002\197\000\000\002\197\002\197\002\197\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\012\238\000\000\002\197\000\000\000\000\000\000\000\000\000\000\002\197\002\197\012\246\012\254\002\197\000\000\000\000\000\000\000\000\002\197\000\000\002\197\000\000\r\006\002\197\000\000\000\000\000\000\000\000\002\197\002\197\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\197\002\197\012\150\012\214\r\014\r\022\r&\002\197\002\197\000\000\000\000\002\197\000\000\002\197\002\197\r.\000\000\000\000\000\000\000\000\000\000\000\000\002\197\000\000\002\197\002\197\r6\000\000\002\197\002\197\002\197\002\197\000\000\000\000\000\000\000\000\000\000\002\197\000\000\002\197\002\197\000\000\rV\002\197\r^\r\030\002\197\002\197\000\000\000\000\002\197\r>\002\197\000\000\000\000\000\000\002\209\002\197\002\197\rF\rN\002\209\000\000\000\000\002\209\000\000\000\000\000\000\002\209\000\000\002\209\000\000\000\000\012\142\000\000\002\209\002\209\002\209\000\000\002\209\002\209\002\209\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\012\238\000\000\002\209\000\000\000\000\000\000\000\000\000\000\002\209\002\209\012\246\012\254\002\209\000\000\000\000\000\000\000\000\002\209\000\000\002\209\000\000\r\006\002\209\000\000\000\000\000\000\000\000\002\209\002\209\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\209\002\209\012\150\012\214\r\014\r\022\r&\002\209\002\209\000\000\000\000\002\209\000\000\002\209\002\209\r.\000\000\000\000\000\000\000\000\000\000\000\000\002\209\000\000\002\209\002\209\r6\000\000\002\209\002\209\002\209\002\209\000\000\000\000\000\000\000\000\000\000\002\209\000\000\002\209\002\209\000\000\rV\002\209\r^\r\030\002\209\002\209\000\000\000\000\002\209\r>\002\209\000\000\000\000\000\000\002\225\002\209\002\209\rF\rN\002\225\000\000\000\000\002\225\000\000\000\000\000\000\002\225\000\000\002\225\000\000\000\000\012\142\000\000\002\225\002\225\002\225\000\000\002\225\002\225\002\225\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\012\238\000\000\002\225\000\000\000\000\000\000\000\000\000\000\002\225\002\225\012\246\012\254\002\225\000\000\000\000\000\000\000\000\002\225\000\000\002\225\000\000\r\006\002\225\000\000\000\000\000\000\000\000\002\225\002\225\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\225\002\225\012\150\012\214\r\014\r\022\r&\002\225\002\225\000\000\000\000\002\225\000\000\002\225\002\225\r.\000\000\000\000\000\000\000\000\000\000\000\000\002\225\000\000\002\225\002\225\r6\000\000\002\225\002\225\002\225\002\225\000\000\000\000\000\000\000\000\000\000\002\225\000\000\002\225\002\225\000\000\rV\002\225\r^\r\030\002\225\002\225\000\000\000\000\002\225\r>\002\225\000\000\000\000\000\000\002\217\002\225\002\225\rF\rN\002\217\000\000\000\000\002\217\000\000\000\000\000\000\002\217\000\000\002\217\000\000\000\000\012\142\000\000\002\217\002\217\002\217\000\000\002\217\002\217\002\217\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\012\238\000\000\002\217\000\000\000\000\000\000\000\000\000\000\002\217\002\217\012\246\012\254\002\217\000\000\000\000\000\000\000\000\002\217\000\000\002\217\000\000\r\006\002\217\000\000\000\000\000\000\000\000\002\217\002\217\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\217\002\217\012\150\012\214\r\014\r\022\r&\002\217\002\217\000\000\000\000\002\217\000\000\002\217\002\217\r.\000\000\000\000\000\000\000\000\000\000\000\000\002\217\000\000\002\217\002\217\r6\000\000\002\217\002\217\002\217\002\217\000\000\000\000\000\000\000\000\000\000\002\217\000\000\002\217\002\217\000\000\rV\002\217\r^\r\030\002\217\002\217\000\000\000\000\002\217\r>\002\217\000\000\000\000\000\000\002\189\002\217\002\217\rF\rN\002\189\000\000\000\000\002\189\000\000\000\000\000\000\002\189\000\000\002\189\000\000\000\000\012\142\000\000\002\189\002\189\002\189\000\000\002\189\002\189\002\189\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\012\238\000\000\002\189\000\000\000\000\000\000\000\000\000\000\002\189\002\189\012\246\012\254\002\189\000\000\000\000\000\000\000\000\002\189\000\000\002\189\000\000\r\006\002\189\000\000\000\000\000\000\000\000\002\189\002\189\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\189\002\189\012\150\012\214\r\014\r\022\r&\002\189\002\189\000\000\000\000\002\189\000\000\002\189\002\189\r.\000\000\000\000\000\000\000\000\000\000\000\000\002\189\000\000\002\189\002\189\r6\000\000\002\189\002\189\002\189\002\189\000\000\000\000\000\000\000\000\000\000\002\189\000\000\002\189\002\189\000\000\rV\002\189\r^\r\030\002\189\002\189\000\000\000\000\002\189\r>\002\189\000\000\000\000\000\000\002\021\002\189\002\189\rF\rN\002\021\000\000\000\000\002\021\000\000\000\000\000\000\002\021\000\000\002\021\000\000\000\000\002\021\000\000\002\021\002\021\002\021\000\000\002\021\002\021\002\021\000\000\000\000\000\000\000\000\000\000\002\021\002\021\002\021\002\021\002\021\000\000\002\021\000\000\000\000\000\000\000\000\000\000\002\021\002\021\002\021\002\021\002\021\000\000\000\000\000\000\000\000\002\021\000\000\002\021\000\000\002\021\002\021\000\000\000\000\000\000\000\000\002\021\002\021\002\021\000\000\000\000\000\000\000\000\000\000\000\000\002\021\002\021\002\021\002\021\002\021\002\021\002\021\002\021\002\021\000\000\000\000\002\021\000\000\002\021\002\021\002\021\000\000\000\000\000\000\000\000\000\000\000\000\002\021\000\000\002\021\002\021\002\021\000\000\002\021\002\021\002\021\002\021\000\000\000\000\000\000\000\000\000\000\002\021\000\000\002\021\002\021\000\000\002\021\002\021\002\021\002\021\002\021\002\021\000\000\000\000\002\021\002\021\016\162\000\000\000\000\000\000\002-\002\021\002\021\002\021\002\021\002-\000\000\000\000\002-\000\000\000\000\000\000\002-\000\000\002-\000\000\000\000\012\142\000\000\002-\002-\002-\000\000\002-\002-\002-\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\012\238\000\000\002-\000\000\000\000\000\000\000\000\000\000\002-\002-\012\246\012\254\002-\000\000\000\000\000\000\000\000\002-\000\000\002-\000\000\r\006\002-\000\000\000\000\000\000\000\000\002-\002-\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002-\002-\012\150\012\214\r\014\r\022\r&\002-\002-\000\000\000\000\002-\000\000\002-\002-\r.\000\000\000\000\000\000\000\000\000\000\000\000\002-\000\000\002-\002-\r6\000\000\002-\002-\016\186\002-\000\000\000\000\000\000\000\000\000\000\002-\000\000\002-\002-\000\000\rV\002-\r^\r\030\002-\002-\000\000\000\000\002-\r>\002-\000\000\000\000\000\000\002)\002-\002-\rF\rN\002)\000\000\000\000\002)\000\000\000\000\000\000\002)\000\000\002)\000\000\000\000\012\142\000\000\002)\002)\002)\000\000\002)\002)\002)\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\012\238\000\000\002)\000\000\000\000\000\000\000\000\000\000\002)\002)\012\246\012\254\002)\000\000\000\000\000\000\000\000\002)\000\000\002)\000\000\r\006\002)\000\000\000\000\000\000\000\000\002)\002)\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002)\002)\012\150\012\214\r\014\r\022\r&\002)\002)\000\000\000\000\002)\000\000\002)\002)\r.\000\000\000\000\000\000\000\000\000\000\000\000\002)\000\000\002)\002)\r6\000\000\002)\002)\002)\002)\000\000\000\000\000\000\000\000\000\000\002)\000\000\002)\002)\000\000\rV\002)\r^\r\030\002)\002)\000\000\000\000\002)\r>\002)\000\000\000\000\000\000\002\185\002)\002)\rF\rN\002\185\000\000\000\000\002\185\000\000\000\000\000\000\002\185\000\000\002\185\000\000\000\000\012\142\000\000\002\185\002\185\002\185\000\000\002\185\002\185\002\185\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\012\238\000\000\002\185\000\000\000\000\000\000\000\000\000\000\002\185\002\185\012\246\012\254\002\185\000\000\000\000\000\000\000\000\002\185\000\000\002\185\000\000\r\006\002\185\000\000\000\000\000\000\000\000\002\185\002\185\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\185\002\185\012\150\012\214\r\014\r\022\r&\002\185\002\185\000\000\000\000\002\185\000\000\002\185\002\185\r.\000\000\000\000\000\000\000\000\000\000\000\000\002\185\000\000\002\185\002\185\r6\000\000\002\185\002\185\002\185\002\185\000\000\000\000\000\000\000\000\000\000\002\185\000\000\002\185\002\185\000\000\rV\002\185\r^\r\030\002\185\002\185\000\000\000\000\002\185\r>\002\185\000\000\000\000\000\000\002!\002\185\002\185\rF\rN\002!\000\000\000\000\002!\000\000\000\000\000\000\002!\000\000\002!\000\000\000\000\002!\000\000\002!\002!\002!\000\000\002!\002!\002!\000\000\000\000\000\000\000\000\000\000\002!\002!\002!\002!\002!\000\000\002!\000\000\000\000\000\000\000\000\000\000\002!\002!\002!\002!\002!\000\000\000\000\000\000\000\000\002!\000\000\002!\000\000\002!\002!\000\000\000\000\000\000\000\000\002!\002!\002!\000\000\000\000\000\000\000\000\000\000\000\000\002!\002!\002!\002!\002!\002!\002!\002!\002!\000\000\000\000\002!\000\000\002!\002!\002!\000\000\000\000\000\000\000\000\000\000\000\000\002!\000\000\002!\002!\002!\000\000\002!\002!\002!\002!\000\000\000\000\000\000\000\000\000\000\002!\000\000\002!\002!\000\000\002!\002!\002!\002!\002!\002!\000\000\000\000\002!\002!\016\162\000\000\000\000\000\000\001\225\002!\002!\002!\002!\001\225\000\000\000\000\001\225\000\000\000\000\000\000\001\225\000\000\001\225\000\000\000\000\001\225\000\000\001\225\001\225\001\225\000\000\001\225\001\225\001\225\000\000\000\000\000\000\000\000\000\000\001\225\001\225\001\225\001\225\001\225\000\000\001\225\000\000\000\000\000\000\000\000\000\000\001\225\001\225\001\225\001\225\001\225\000\000\000\000\000\000\000\000\001\225\000\000\001\225\000\000\001\225\001\225\000\000\000\000\000\000\000\000\001\225\001\225\001\225\000\000\000\000\000\000\000\000\000\000\000\000\001\225\001\225\001\225\001\225\001\225\001\225\001\225\001\225\001\225\000\000\000\000\001\225\000\000\001\225\001\225\001\225\000\000\000\000\000\000\000\000\000\000\000\000\001\225\000\000\001\225\001\225\001\225\000\000\001\225\001\225\001\225\001\225\000\000\000\000\000\000\000\000\000\000\001\225\000\000\001\225\001\225\000\000\001\225\001\225\001\225\001\225\001\225\001\225\000\000\000\000\001\225\001\225\016\162\000\000\000\000\000\000\002%\001\225\001\225\001\225\001\225\002%\000\000\000\000\002%\000\000\000\000\000\000\002%\000\000\002%\000\000\000\000\002%\000\000\002%\002%\002%\000\000\002%\002%\002%\000\000\000\000\000\000\000\000\000\000\002%\002%\002%\002%\002%\000\000\002%\000\000\000\000\000\000\000\000\000\000\002%\002%\002%\002%\002%\000\000\000\000\000\000\000\000\002%\000\000\002%\000\000\002%\002%\000\000\000\000\000\000\000\000\002%\002%\002%\000\000\000\000\000\000\000\000\000\000\000\000\002%\002%\002%\002%\002%\002%\002%\002%\002%\000\000\000\000\002%\000\000\002%\002%\002%\000\000\000\000\000\000\000\000\000\000\000\000\002%\000\000\002%\002%\002%\000\000\002%\002%\002%\002%\000\000\000\000\000\000\000\000\000\000\002%\000\000\002%\002%\000\000\002%\002%\002%\002%\002%\002%\000\000\000\000\002%\002%\016\162\000\000\000\000\000\000\027\n\002%\002%\002%\002%\001\229\000\000\000\000\001\229\000\000\000\000\000\000\001\229\000\000\001\229\000\000\000\000\001\229\000\000\001\229\001\229\001\229\000\000\001\229\001\229\001\229\000\000\000\000\000\000\000\000\000\000\001\229\001\229\001\229\001\229\001\229\000\000\001\229\000\000\000\000\000\000\000\000\000\000\001\229\001\229\001\229\001\229\001\229\000\000\000\000\000\000\000\000\001\229\000\000\001\229\000\000\001\229\001\229\000\000\000\000\000\000\000\000\001\229\001\229\001\229\000\000\000\000\000\000\000\000\000\000\000\000\001\229\001\229\001\229\001\229\001\229\001\229\001\229\001\229\001\229\000\000\000\000\001\229\000\000\001\229\001\229\001\229\000\000\000\000\000\000\000\000\000\000\000\000\027\026\000\000\001\229\001\229\001\229\000\000\001\229\001\229\001\229\001\229\000\000\000\000\000\000\000\000\000\000\001\229\000\000\001\229\001\229\000\000\001\229\001\229\001\229\001\229\001\229\001\229\000\000\000\000\001\229\001\229\001\229\000\000\000\000\000\000\001\233\001\229\001\229\001\229\001\229\001\233\000\000\000\000\001\233\000\000\000\000\000\000\001\233\000\000\001\233\000\000\000\000\001\233\000\000\001\233\001\233\001\233\000\000\001\233\001\233\001\233\000\000\000\000\000\000\000\000\000\000\001\233\001\233\001\233\001\233\001\233\000\000\001\233\000\000\000\000\000\000\000\000\000\000\001\233\001\233\001\233\001\233\001\233\000\000\000\000\000\000\000\000\001\233\000\000\001\233\000\000\001\233\001\233\000\000\000\000\000\000\000\000\001\233\001\233\001\233\000\000\000\000\000\000\000\000\000\000\000\000\001\233\001\233\001\233\001\233\001\233\001\233\001\233\001\233\001\233\000\000\000\000\001\233\000\000\001\233\001\233\001\233\000\000\000\000\000\000\000\000\000\000\000\000\027\018\000\000\001\233\001\233\001\233\000\000\001\233\001\233\001\233\001\233\000\000\000\000\000\000\000\000\000\000\001\233\000\000\001\233\001\233\000\000\001\233\001\233\001\233\001\233\001\233\001\233\000\000\000\000\001\233\001\233\016\162\000\000\000\000\000\000\000\000\001\233\001\233\001\233\001\233\000\006\000\246\000\000\000\000\006\245\001\002\001\006\000\000\001\n\001\022\001\"\000\000\000\000\000\000\000\000\001&\001j\000\000\000\000\000\000\001n\000\000\000\000\000\000\006\245\001*\000\000\000\000\000\000\001r\001\150\011\182\011\186\001\162\001\166\000\000\000\000\000\000\007\018\000\000\0012\000\000\026\202\000\000\011\218\011\222\006\245\007\138\007\150\001f\007\162\007\170\011\226\t\170\000\000\001\182\006\245\001z\000\000\000\000\n\234\006\245\006\245\000\238\n\238\n\242\n\254\011\014\000\000\007\246\006\245\006\245\001\186\001\190\001\194\001\198\001\202\000\000\000\000\011&\001\206\000\000\000\000\000\000\000\000\001\210\000\000\0112\011J\011j\011~\b\002\000\000\005\030\000\000\000\000\001\214\000\000\000\000\006\245\000\000\000\000\011\006\001\218\011\n\000\000\000\000\000\000\000\000\000\000\006\245\000\000\000\000\000\000\002\022\006b\000\000\000\000\b\006\011\026\000\000\002\026\000\000\015b\003j\011\246\025\018\002\"\000\000\002&\002*\000\006\000\246\000\000\000\000\012m\001\002\001\006\000\000\001\n\001\022\001\"\000\000\000\000\000\000\000\000\001&\001j\000\000\000\000\000\000\011\178\000\000\000\000\000\000\012m\001*\000\000\000\000\000\000\001r\001\150\011\182\011\186\001\162\001\166\000\000\000\000\011F\007\018\000\000\0012\000\000\011\190\000\000\011\218\011\222\012m\007\138\007\150\001f\007\162\007\170\011\226\t\170\007\025\001\182\012m\001z\007\025\000\000\n\234\012m\012m\000\238\n\238\n\242\n\254\011\014\000\000\007\246\012m\012m\001\186\001\190\001\194\001\198\001\202\000\000\016\142\011&\001\206\000\000\000\000\000\000\000\000\001\210\000\000\0112\011J\011j\011~\b\002\000\000\005\030\000\000\000\000\001\214\000\000\000\238\012m\000\000\000\000\011\006\001\218\011\n\000\000\002\233\002\233\019\194\000\000\012m\000\000\000\000\000\000\002\022\006v\000\000\000\000\b\006\011\026\000\000\002\026\002\233\015b\003j\011\246\000\000\002\"\000\000\002&\002*\000\006\000\246\000\000\000\n\001\130\001\002\001\006\006\006\001\n\001\022\001\"\000\000\000\000\000\000\000\000\001&\b\170\000\000\006\230\bb\000\000\000\000\004\133\000\000\006\234\001*\b\190\019\174\000\000\001.\b\198\006\238\006\242\002\233\002\233\002\233\006\246\000\000\007\018\000\000\0012\000\000\019\190\002\233\007\130\007\134\000\000\007\138\007\150\001f\007\162\007\170\tZ\t\170\002\233\000\000\019\166\001z\000\000\000\000\n\234\020\"\000\n\000\000\n\238\n\242\n\254\011\014\000\000\007\246\000\000\000\000\000\000\000\000\000\000\000\000\000\000\020*\002\233\011&\002\233\002\233\020\202\000\000\000\000\000\000\002\233\0112\011J\011j\011~\b\002\002\233\005\030\020>\020j\002\233\000\000\004\133\004\133\000\000\000\000\011\006\000\000\011\n\000\000\000\000\000\000\000\n\000\000\000\000\000\000\000\000\000\000\000\000\002\233\020\150\024\014\b\006\011\026\017\n\000\000\000\000\011\146\003j\011\246\000\006\000\246\000\000\000\000\001\130\001\002\001\006\006\006\001\n\001\022\001\"\000\000\002\233\000\000\000\000\001&\000\000\000\000\004\165\000\000\b\225\000\000\b\225\b\225\006\234\001*\006\250\001\006\000\000\001.\000\000\006\238\006\242\000\000\000\000\000\000\006\246\000\000\007\018\000\000\0012\000\000\019\190\000\000\007\130\007\134\001*\007\138\007\150\001f\007\162\007\170\tZ\t\170\000\000\000\000\019\166\001z\000\000\024*\n\234\020\"\002>\002B\n\238\n\242\n\254\011\014\000\000\007\246\024R\001>\000\000\000\000\024V\000\000\000\000\020*\001z\011&\000\000\028>\001*\002F\002V\024\134\000\000\0112\011J\011j\011~\b\002\002b\005\030\020>\020j\000\000\000\000\028_\016\194\000\000\000\000\011\006\000\000\011\n\000\000\002f\002\250\000\000\024\150\000\000\000\000\003\006\000\000\001z\003\026\003&\024\014\b\006\011\026\b\225\0032\000\000\011\146\003j\011\246\000\006\000\246\000\000\000\000\001\130\001\002\001\006\006\006\001\n\001\022\001\"\000\000\0036\000\000\000\000\001&\002\233\000\000\028\142\000\000\002\233\000\000\004\226\000\000\006\234\001*\000\000\000\000\000\000\001.\000\000\006\238\006\242\000\000\000\000\000\000\006\246\000\000\007\018\000\000\0012\000\000\019\190\000\n\007\130\007\134\000\000\007\138\007\150\001f\007\162\007\170\tZ\t\170\000\000\003j\019\166\001z\000\000\002\233\n\234\020\"\002>\002B\n\238\n\242\n\254\011\014\000\000\007\246\000\000\000\000\000\000\002\233\002\233\000\000\000\000\020*\000\000\011&\000\000\028>\001*\002F\002V\000\000\000\000\0112\011J\011j\011~\b\002\002b\005\030\020>\020j\000\000\000\000\004\173\002j\000\000\000\000\011\006\002\233\011\n\000\000\002f\002\250\000\000\000\000\000\000\000\000\003\006\000\000\001z\003\026\003&\024\014\b\006\011\026\015r\0032\000\000\011\146\003j\011\246\000\173\001\002\001\006\000\173\012a\000\000\001\"\000\000\012\030\000\000\000\000\001&\0036\000\000\000\173\000\000\000\173\000\000\000\173\000\000\000\173\001*\000\000\012&\005Q\001.\000\000\000\000\005Q\000\000\000\000\012.\000\173\000\000\000\000\000\000\0012\000\000\000\173\000\000\000\000\000\000\000\173\000\000\000\000\001f\001v\000\173\012-\000\173\000\000\000\000\000\173\001z\000\000\000\000\n\234\000\173\000\173\000\173\n\238\n\242\n\254\000\000\014.\007\246\000\173\000\173\000\000\012-\000\000\000\000\002\142\000\173\000\000\002\146\000\000\000\173\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012a\012a\b\002\002\158\005\030\000\173\000\173\002\166\012\025\000\173\000\173\000\000\000\000\011\006\000\000\011\n\005Q\000\000\000\000\000\000\000\000\000\173\000\000\012a\000\000\000\000\012a\000\173\000\173\b\006\011\026\000\000\002\170\005Q\011\146\003j\005Q\000\173\000\000\000\173\000\197\001\002\001\006\000\197\000\000\000\000\001\"\000\000\012\030\000\000\000\000\001&\000\000\000\000\000\197\000\000\000\197\000\000\000\197\000\000\000\197\001*\000\000\012&\000\000\001.\000\000\000\000\000\000\000\000\000\000\012.\000\197\000\000\000\000\000\000\0012\000\000\000\197\000\000\000\000\002\174\000\197\000\000\000\000\001f\001v\000\197\000\000\000\197\000\000\002\233\000\197\001z\000\000\000\000\n\234\000\197\000\197\000\197\n\238\n\242\n\254\000\000\014.\007\246\000\197\000\197\019\182\000\000\000\000\002\233\000\000\000\197\000\000\000\000\000\000\000\197\000\000\000\000\000\n\000\000\000\000\000\000\000\000\000\000\000\000\b\002\007\221\005\030\000\197\000\197\000\000\002\233\000\197\000\197\002\233\000\000\011\006\000\000\011\n\000\000\000\000\002\233\000\000\000\000\000\197\000\000\002\233\000\000\002\233\000\000\000\197\000\197\b\006\011\026\000\000\002\233\002\233\011\146\003j\000\000\000\197\000\014\000\197\000\018\000\022\000\026\000\030\000\238\000\"\000&\000\000\000*\000.\0002\000\000\0006\000:\000\000\000\000\000>\000\000\000\000\000\000\000B\002\233\000\000\000\000\000\000\000\000\000\000\000F\000\000\000\000\000\000\000\000\002\233\000J\000\000\000N\000R\000V\000Z\000^\000b\000f\000\000\000\000\000\000\000j\000\000\000n\000\000\000r\000\000\000\000\000v\b\170\000\000\000\000\bb\000\000\000\000\000\000\002>\002B\000\000\b\190\000\000\000\000\000z\b\198\000\000\000~\000\130\000\000\000\000\000\000\000\000\001n\000\134\000\138\000\142\000\000\001*\002F\002V\000\000\000\000\000\146\000\150\000\154\000\000\000\158\002b\000\000\000\162\000\166\000\170\000\000\000\000\002j\000\174\000\178\000\182\000\000\000\000\000\000\002f\002\250\000\186\000\000\000\190\000\194\003\006\000\000\001z\003\026\003&\000\000\000\198\000\000\000\202\0032\003\225\007\"\001\006\003\225\000\206\000\210\001\"\000\214\t*\007\233\000\000\001&\000\000\000\000\003\225\000\000\0036\000\000\003\225\000\000\003\225\001*\000\000\tJ\000\000\000\000\000\000\000\000\007&\007\233\000\000\tb\003\225\000\000\000\000\000\000\000\000\000\000\003\225\000\000\000\000\0072\000\000\000\000\000\000\t\142\001v\003\225\000\000\003\225\004\170\007\233\003\225\001z\000\000\000\000\007\190\003\225\003\225\nE\007\194\007\233\007\198\000\000\t\158\007\246\007\233\007\233\000\238\000\000\000\000\000\000\000\000\003\225\003\225\007\233\007\233\007\250\000\000\002\233\002\233\000\000\000\000\000\000\000\000\000\000\000\000\b\002\002\233\005\030\003\225\003\225\t\166\000\000\003\225\003\225\000\000\000\000\000\000\002\233\000\000\007\233\000\000\000\000\007\233\000\000\000\000\000\n\nE\015\174\000\000\nE\017\210\003\225\b\006\007\233\000\000\000\000\nE\000\000\003j\000\000\nE\002\233\003\225\007\"\001\006\b\130\000\000\000\000\001\"\002\233\000\000\000\000\000\000\001&\001j\002\233\000\000\000\000\001n\000\000\000\000\000\000\000\000\001*\000\000\002\233\000\000\001\146\001\150\001\154\007B\001\162\001\166\000\000\000\000\000\000\002\233\000\000\002\233\000\000\007F\000\000\001\170\b\158\002\233\000\000\000\000\007>\001v\000\000\001\178\000\000\000\n\001\182\000\000\001z\000\000\001\r\007\190\000\000\000\000\002\233\007\194\000\000\007\198\007\234\000\000\007\246\002\233\002\233\001\186\001\190\001\194\001\198\001\202\t\178\002\233\001\r\001\206\007\250\000\000\000\000\002\233\001\210\000\000\000\000\000\000\000\000\000\000\b\002\000\000\005\030\000\000\bB\001\214\000\000\000\000\000\000\000\000\001\r\000\000\001\218\007\030\000\000\000\000\002\233\000\000\000\000\000\000\001\r\000\000\000\000\002\022\006b\001\r\000\000\b\006\000\000\000\000\002\026\000\000\002\030\003j\001\r\001\r\002\"\012a\002&\002*\007\"\001\006\t\146\000\000\000\000\001\"\000\000\000\000\000\000\000\000\001&\001j\000\000\000\000\000\000\001n\000\000\005U\000\000\000\000\001*\005U\002v\001\r\001\146\001\150\001\154\007B\001\162\001\166\000\000\000\000\000\000\002z\001\r\000\000\000\000\007F\000\000\001\170\b\158\001*\000\000\000\000\007>\001v\000\000\001\178\000\000\000\000\001\182\000\000\001z\000\000\000\000\007\190\000\000\000\000\007f\007\194\000\000\007\198\007\234\004q\007\246\t\214\002N\001\186\001\190\001\194\001\198\001\202\000\000\001z\000\000\001\206\007\250\000\000\012a\012a\001\210\000\000\000\000\004q\000\000\000\000\b\002\000\000\005\030\000\000\bB\001\214\000\000\000\000\005U\000\000\000\000\000\000\001\218\000\000\000\000\012a\t\218\000\000\012a\004q\000\000\000\000\000\000\002\022\006b\005U\000\000\b\006\005U\004q\002\026\000\000\002\030\003j\004q\005\254\002\"\000\000\002&\002*\007\"\001\006\011Z\004q\004q\001\"\000\000\000\000\000\000\000\000\001&\001j\000\000\000\000\000\000\001n\000\000\000\000\000\000\000\000\001*\000\000\000\000\000\000\001\146\001\150\001\154\007B\001\162\001\166\000\000\000\000\004q\000\000\000\000\000\000\000\000\007F\000\000\001\170\b\158\000\000\000\000\004q\007>\001v\000\000\001\178\000\000\000\000\001\182\000\000\001z\000\000\000\000\007\190\000\000\000\000\000\000\007\194\000\000\007\198\007\234\000\000\007\246\000\000\000\000\001\186\001\190\001\194\001\198\001\202\000\000\000\000\000\000\001\206\007\250\000\000\000\000\b\242\001\210\000\000\b\245\000\000\000\000\000\000\b\002\000\000\005\030\000\000\bB\001\214\000\000\000\000\000\000\000\000\000\000\000\000\001\218\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\022\006b\000\000\000\000\b\006\000\000\000\000\002\026\000\000\002\030\003j\000\000\000\000\002\"\000\238\002&\002*\007\"\001\006\016J\000\000\000\000\001\"\000\000\000\000\000\000\000\000\001&\001j\000\000\000\000\000\000\001n\000\000\000\000\000\000\000\000\001*\000\000\000\000\000\000\001\146\001\150\001\154\007B\001\162\001\166\000\000\000\000\007z\007\006\001\006\000\000\000\000\007F\000\000\001\170\b\158\000\000\007\n\000\000\007>\001v\b\170\001\178\n\186\bb\001\182\000\000\001z\001*\b\245\007\190\b\190\000\000\000\000\007\194\b\198\007\198\007\234\000\000\007\246\000\000\000\000\001\186\001\190\001\194\001\198\001\202\000\000\000\000\000\000\001\206\007\250\007v\000\000\000\000\001\210\000\000\000\000\000\000\000\000\001z\b\002\000\000\005\030\000\000\bB\001\214\000\000\000\000\000\000\000\000\000\000\000\000\001\218\000\000\000\000\000\000\002\233\002\233\000\000\000\000\000\000\000\000\000\000\002\022\006b\000\000\000\000\b\006\t\190\000\000\002\026\000\000\002\030\003j\000\000\000\000\002\"\002\233\002&\002*\002\233\002\233\000\000\002\233\000\n\002\233\002\233\002\233\002\233\002\233\002\233\000\000\000\000\000\000\000\000\002\233\002\233\000\000\000\000\000\000\002\233\002\233\002\233\000\000\000\000\002\233\000\000\002\233\000\n\002\233\002\233\002\233\002\233\000\n\002\233\000\000\t\174\000\000\002\233\000\000\002\233\000\000\017.\000\000\002\233\002\233\000\000\002\233\002\233\002\233\002\233\002\233\002\233\002\233\000\000\002\233\000\000\002\233\002\233\002\233\002\233\002\233\002\233\002\233\002\233\002\233\002\233\002\233\000\000\002\233\000\000\000\000\000\000\000\000\000\000\000\000\002\233\000\000\000\000\002\233\000\000\002\233\000\000\000\000\000\000\000\000\002\233\002\233\002\233\002\233\002\233\002\233\000\000\002\233\002\233\017j\000\000\000\000\000\000\002\233\000\000\000\000\002\233\000\000\002\233\000\000\0009\0009\000\000\000\000\007\229\0009\0009\002\233\0009\0009\0009\002\233\002\233\002\233\000\000\0009\000\000\002\233\002\233\002\233\006\165\000\000\000\000\000\000\007\229\0009\000\000\000\000\000\000\0009\000\000\0009\0009\000\000\000\000\000\000\000\000\000\000\0009\000\000\0009\000\000\000\000\000\000\0009\0009\007\229\0009\0009\0009\0009\0009\0009\0009\000\000\000\000\007\229\0009\000\000\000\000\0009\007\229\007\229\000\238\0009\0009\0009\0009\000\000\0009\007\229\007\229\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0009\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0009\0009\0009\0009\0009\000\000\0009\000\000\000\000\007\229\000\000\000\000\007\229\000\000\000\000\0009\000\000\0009\000\000\0005\0005\000\000\000\000\007\229\0005\0005\000\000\0005\0005\0005\000\000\0009\0009\000\000\0005\000\000\0009\0009\0009\006\161\000\000\000\000\000\000\000\000\0005\000\000\000\000\000\000\0005\000\000\0005\0005\000\000\000\000\000\000\000\000\000\000\0005\000\000\0005\000\000\000\000\000\000\0005\0005\000\000\0005\0005\0005\0005\0005\0005\0005\000\000\000\000\000\000\0005\000\000\000\000\0005\000\000\000\000\000\000\0005\0005\0005\0005\000\000\0005\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0005\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0005\0005\0005\0005\0005\000\000\0005\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0005\000\000\0005\000\000\011\189\011\189\000\000\000\000\001\181\011\189\011\189\000\000\011\189\011\189\011\189\000\000\0005\0005\000\000\011\189\000\000\0005\0005\0005\006\177\000\000\000\000\000\000\001\181\011\189\000\000\000\000\000\000\011\189\000\000\011\189\011\189\000\000\000\000\000\000\000\000\000\000\011\189\000\000\011\189\000\000\000\000\000\000\011\189\011\189\001\181\011\189\011\189\011\189\011\189\011\189\011\189\011\189\000\000\000\000\001\181\011\189\000\000\000\000\011\189\001\181\001\181\000\238\011\189\011\189\011\189\011\189\000\000\011\189\001\181\001\181\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\189\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\189\011\189\011\189\011\189\011\189\000\000\011\189\000\000\000\000\000\000\000\000\000\000\001\181\000\000\000\000\011\189\000\000\011\189\000\000\011\185\011\185\000\000\000\000\001\181\011\185\011\185\000\000\011\185\011\185\011\185\000\000\011\189\011\189\000\000\011\185\000\000\011\189\011\189\011\189\006\173\000\000\000\000\000\000\000\000\011\185\000\000\000\000\000\000\011\185\000\000\011\185\011\185\000\000\000\000\000\000\000\000\000\000\011\185\000\000\011\185\000\000\000\000\000\000\011\185\011\185\000\000\011\185\011\185\011\185\011\185\011\185\011\185\011\185\000\000\000\000\000\000\011\185\000\000\000\000\011\185\000\000\000\000\000\000\011\185\011\185\011\185\011\185\000\000\011\185\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\185\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\185\011\185\011\185\011\185\011\185\000\000\011\185\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\185\000\000\011\185\000\006\000\246\000\000\000\000\000\000\001\002\001\006\000\000\001\n\001\022\001\"\000\000\000\000\011\185\011\185\001&\000\000\000\000\011\185\011\185\011\185\000\000\015\130\000\000\000\000\001*\000\000\000\000\000\000\001.\000\000\006\238\006\242\000\000\000\000\000\000\000\000\000\000\007\018\000\000\0012\000\000\000\000\000\000\007\130\007\134\000\000\007\138\007\150\001f\007\162\007\170\tZ\t\170\000\000\000\000\000\000\001z\000\000\000\000\n\234\000\000\000\000\000\000\n\238\n\242\n\254\011\014\000\000\007\246\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011&\000\000\000\000\000\000\005!\000\000\005!\005!\0112\011J\011j\011~\b\002\005!\005\030\000\000\005!\000\000\005!\000\000\005!\005!\005!\011\006\005!\011\n\000\000\000\000\012-\012\025\005!\000\000\005!\005!\005!\000\000\005!\005!\005!\b\006\011\026\000\000\005!\005!\011\146\003j\011\246\000\000\000\000\012-\005!\000\000\002\142\000\000\000\000\002\146\005!\005!\000\000\000\000\005!\005!\005!\005!\005!\005!\000\000\005!\002\158\000\000\005!\000\000\002\166\012\025\000\000\005!\005!\005!\000\000\000\000\000\000\005!\000\000\000\000\005!\005!\000\000\000\000\000\000\000\000\000\000\005!\000\000\000\000\005!\005!\005!\002\170\005!\005!\004Q\000\000\000\000\004Q\000\000\000\000\000\000\000\000\005!\005!\005!\000\000\005!\005!\004Q\000\000\023\006\005!\004Q\000\000\004Q\000\000\000\000\000\000\005!\000\000\005!\005!\005!\000\000\002\254\005!\004Q\000\000\000\000\000\000\005!\000\000\004Q\000\000\005!\na\005!\005!\na\na\002\174\000\000\000\000\na\000\000\na\004Q\000\000\na\000\000\000\000\004Q\na\na\000\000\na\na\000\000\na\000\000\na\000\000\000\000\000\000\000\000\na\000\000\004Q\na\000\000\000\000\000\000\000\000\000\000\007\129\000\000\na\000\000\na\000\000\000\000\000\000\na\na\004Q\004Q\000\000\000\000\004Q\004Q\na\007\129\007\129\na\007\129\007\129\na\na\000\000\na\000\000\na\na\000\000\000\000\000\000\000\000\004Q\000\000\000\000\000\000\na\000\000\000\000\na\007\129\000\000\000\000\021\018\000\000\000\000\000\000\000\000\000\000\na\000\000\na\000\000\000\000\na\000\000\na\000\000\000\000\000\000\007\129\000\000\000\000\b\"\000\000\000\000\000\000\000\000\000\000\000\000\na\na\000\000\na\na\007\129\na\000\000\na\000\000\na\b\205\na\000\000\na\000\000\b\205\000\000\002B\b\205\000\000\000\000\000\000\007\129\018\134\007\129\000\000\000\000\b\205\000\000\b\205\b\205\b\205\000\000\b\205\b\205\b\205\000\000\000\000\bZ\000\000\000\000\007\129\007\129\006\234\000\000\000\000\007\129\b\205\007\129\006\229\006\229\000\000\007\129\b\205\b\205\000\000\000\000\b\205\000\000\000\000\000\000\003\002\b\205\000\000\b\205\018\246\003*\b\205\000\000\006\229\006\229\006\229\b\205\b\205\b\205\019\166\000\000\000\000\000\000\006\229\020\"\b\205\b\205\000\000\000\000\000\000\000\000\000\000\b\205\0246\024F\000\000\003\146\006\229\006\229\000\000\b\205\000\000\000\000\006\229\000\000\006\229\006\229\006\229\000\000\b\205\b\205\b\205\006\229\b\205\b\205\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\157\000\000\000\000\b\205\000\000\b\205\b\205\006\229\000\000\011\245\b\205\0252\000\000\000\000\011\245\b\205\002B\011\245\000\000\b\205\000\000\b\205\b\205\000\000\002>\002B\003\178\000\000\011\245\011\245\011\245\000\000\011\245\011\245\011\245\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001*\002F\011\245\000\000\003\030\000\000\006\229\000\000\011\245\011\245\000\000\000\000\011\245\000\000\000\000\000\000\003\002\011\245\000\000\011\245\000\000\000\000\011\245\000\000\002f\003\002\000\000\011\245\011\245\011\245\003\006\000\000\001z\003\026\003&\000\000\011\245\011\245\000\000\0032\000\000\005>\000\000\011\245\000\000\000\000\000\000\003\146\000\000\000\000\000\000\011\245\000\000\000\000\000\000\000\000\0036\000\000\000\000\000\000\011\245\011\245\011\245\000\000\011\245\011\245\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\245\000\000\011\245\011\245\000\000\000\000\b\209\011\245\000\000\000\000\000\000\b\209\011\245\002B\b\209\000\000\011\245\000\000\011\245\011\245\000\000\000\000\000\000\b\209\000\000\b\209\b\209\b\209\000\000\b\209\b\209\b\209\000\000\000\000\000\000\007\"\001\006\000\000\000\000\000\000\001\"\000\000\000\000\b\209\000\000\001&\000\000\000\000\000\000\b\209\b\209\000\000\b\249\b\209\000\000\001*\000\000\003\002\b\209\000\000\b\209\000\000\007&\b\209\000\000\000\000\000\000\000\000\b\209\b\209\b\209\000\000\000\000\000\000\000\000\0072\000\000\b\209\b\209\007>\001v\000\000\000\000\000\000\b\209\000\000\000\000\001z\003\146\000\000\007\190\000\000\b\209\000\000\007\194\000\000\007\198\007\234\000\000\007\246\000\000\b\209\b\209\b\209\000\000\b\209\b\209\000\000\000\000\000\000\000\000\007\250\000\000\000\000\000\000\000\000\000\000\b\209\000\000\b\209\b\209\b\002\011\249\005\030\b\209\bB\000\000\011\249\000\000\b\209\011\249\000\000\000\000\b\209\000\000\b\209\b\209\000\000\000\000\003\130\000\000\011\249\011\249\011\249\000\000\011\249\011\249\011\249\b\006\000\000\b\249\000\000\011>\000\000\003j\000\000\000\000\000\000\000\000\011\249\000\000\002>\002B\017\214\000\000\011\249\011\249\000\000\000\000\011\249\000\000\000\000\000\000\000\000\011\249\000\000\011\249\000\000\000\000\011\249\000\000\001*\003\018\002V\011\249\011\249\011\249\000\000\000\000\000\000\000\000\002b\000\000\011\249\011\249\000\000\000\000\000\000\000\000\000\000\011\249\000\000\000\000\000\000\011\249\002f\002\250\000\000\011\249\000\000\000\000\003\006\000\000\001z\003\026\003&\000\000\011\249\011\249\011\249\0032\011\249\011\249\003%\000\000\000\000\000\000\000\000\003%\012-\012\025\003%\000\000\011\249\000\000\011\249\011\249\0036\000\000\000\000\011\249\000\000\003%\003%\003%\011\249\003%\003%\003%\011\249\012-\011\249\011\249\002\142\000\000\000\000\002\146\000\000\000\000\000\000\003%\000\000\000\000\002\154\000\000\000\000\003%\003z\000\000\002\158\003%\000\000\000\000\002\166\012\025\003%\000\000\003%\000\000\000\000\003%\000\000\000\000\000\000\000\000\003%\003%\003%\000\000\000\000\000\000\000\000\000\000\000\000\003%\003%\000\000\000\000\002\170\000\000\000\000\003%\000\000\000\000\000\000\003%\000\000\000\000\nm\003%\000\000\007\"\001\006\000\000\000\000\000\000\001\"\000\000\003%\003%\003%\001&\003%\003%\000\000\nm\nm\000\000\nm\nm\000\000\001*\000\000\000\000\003%\000\000\003%\003%\007&\000\000\000\000\003%\000\000\000\000\000\000\000\000\003%\002\174\000\000\nm\003%\0072\003%\003%\000\000\007>\001v\000\000\000\000\000\000\000\000\000\000\000\000\001z\000\000\000\000\007\190\000\000\000\000\nm\007\194\000\000\007\198\007\234\000\000\007\246\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\nm\000\000\000\000\007\250\000\000\000\000\ni\000\000\021\198\007\"\001\006\000\000\000\000\b\002\001\"\005\030\000\000\bB\nm\001&\nm\000\000\000\000\ni\ni\000\000\ni\ni\006\234\001*\000\000\000\000\000\000\000\000\nm\000\000\007&\nm\nm\000\000\b\006\000\000\nm\000\000\nm\000\000\003j\ni\nm\0072\021\242\000\000\000\000\b~\001v\000\000\000\000\000\000\000\000\000\000\019\166\001z\000\000\000\000\007\190\020\"\001\130\ni\007\194\002\130\007\198\007\234\000\000\007\246\000\000\022\030\000\000\000\000\000\000\000\000\020\154\000\000\ni\000\000\000\000\007\250\006\234\000\000\001\205\000\000\000\000\000\000\000\000\001\205\000\000\b\002\001\205\005\030\020\158\bB\ni\001\021\ni\004\149\020\198\000\000\000\000\001\205\001\205\001\205\000\000\001\205\001\205\001\205\022\130\000\000\ni\000\000\019\166\ni\ni\001\021\b\006\020\"\ni\001\205\ni\000\000\003j\000\000\ni\001\205\001\205\000\000\000\000\001\205\000\000\000\000\000\000\021Z\001\205\000\000\001\205\001\021\000\000\001\205\021\182\000\000\000\000\000\000\001\205\001\205\001\205\001\021\000\000\000\000\020>\021n\001\021\001\205\001\205\004y\001a\000\000\000\000\001a\001\205\000\000\001\021\000\000\001\205\000\000\000\000\000\000\001\205\000\000\001a\000\000\001a\021~\001a\000\000\001a\001\205\001\205\001\205\000\000\001\205\001\205\000\000\000\000\000\000\004q\000\000\001a\000\000\001\021\000\000\000\000\001\205\001a\001\205\001\205\007\"\001\006\000\000\001\205\001\021\001\"\000\000\t*\001\205\004q\001&\001a\003\246\000\000\001\205\000\000\001a\001a\000\238\000\000\001*\000\000\tJ\000\000\000\000\000\000\000\000\007&\000\000\000\000\tb\004q\001a\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0072\004q\000\000\000\000\t\142\001v\004q\005\254\000\238\001a\001a\001a\001z\001a\001a\007\190\004q\000\000\nE\007\194\000\000\007\198\000\000\t\158\007\246\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001a\004\029\000\000\000\000\007\250\000\000\000\000\000\000\000\000\000\000\000\000\001a\004q\000\000\b\002\000\000\005\030\000\000\000\000\t\166\000\000\005\153\000\000\004q\000\000\000\000\005\153\000\000\000\000\005\153\000\000\000\000\000\000\000\000\000\000\nE\000\000\000\000\nE\nE\005\153\b\006\005\153\000\000\005\153\nE\005\153\003j\000\000\nE\004\029\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\153\000\000\000\000\000\000\000\000\000\000\005\153\005\153\000\000\000\000\000\000\000\000\000\000\005\153\000\000\005\153\000\000\005\153\000\000\000\000\005\153\000\000\000\000\000\000\000\000\005\153\005\153\005\153\000\000\000\000\000\000\000\000\003i\000\000\000\000\000\000\000\000\003i\000\000\000\000\003i\005\153\005\153\000\000\000\000\005\153\000\000\000\000\000\000\000\000\000\000\003i\000\000\003i\000\000\003i\000\000\003i\005\153\005\153\005\153\000\000\005\153\005\153\000\000\000\000\003i\000\000\000\000\003i\nv\003i\000\000\000\000\003i\003i\003i\005\153\000\000\000\000\005\153\005\153\005)\000\000\003i\003i\003i\003i\000\000\003i\000\000\003i\005\153\000\000\003i\003i\003i\000\000\000\000\000\000\000\000\000\000\000\000\003i\000\000\000\000\000\000\000\000\000\000\003i\003i\000\000\000\000\000\000\003i\000\000\005-\000\000\003i\000\000\003i\000\000\000\000\003i\000\000\000\000\000\000\003i\003i\003i\003i\003i\003i\000\000\000\000\005\141\000\000\000\000\000\000\005)\005\141\000\000\000\000\005\141\003i\000\000\003i\003i\003i\000\000\003i\000\000\000\000\000\000\005\141\000\000\005\141\000\000\005\141\000\000\005\141\003i\003i\003i\000\000\003i\003i\000\000\000\000\000\000\000\000\000\000\005\141\005-\000\000\000\000\000\000\000\000\005\141\005\141\003i\003i\000\000\000\000\003i\n\182\000\000\005\141\000\000\005\141\000\000\000\000\005\141\000\000\000\000\003i\000\000\005\141\005\141\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\189\000\000\002B\001\189\000\000\005\141\005\141\000\000\000\000\005\141\000\000\000\000\b\185\000\000\001\189\000\000\000\000\000\000\001\189\000\000\001\189\000\000\005\141\005\141\005\141\000\000\005\141\005\141\000\000\000\000\000\000\000\000\001\189\000\000\000\000\000\000\000\000\000\000\001\189\001\189\000\000\005\141\000\000\000\000\005\141\005\141\003\002\001\189\000\000\001\189\000\000\000\000\001\189\000\000\000\000\000\000\005\141\001\189\001\189\001\189\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\189\001\189\000\000\000\000\003\146\000\000\000\000\000\000\000\000\000\000\000\000\003M\000\000\002B\003M\000\000\000\000\001\189\001\189\000\000\000\000\001\189\001\189\b\181\000\000\003M\000\000\000\000\000\000\003M\000\000\003M\000\000\001\189\000\000\000\000\000\000\000\000\000\000\000\000\001\189\000\000\000\000\003M\000\000\001\189\000\000\000\000\000\000\003M\001\185\001\189\000\000\000\000\000\000\000\000\bY\003\002\003M\000\000\003M\bY\000\000\003M\bY\000\000\000\000\000\000\003M\003M\003M\000\000\000\000\000\000\000\000\bY\000\000\bY\000\000\bY\000\000\bY\000\000\000\000\003M\003M\000\000\000\000\003\146\000\000\000\000\000\000\000\000\bY\000\000\000\000\000\000\000\000\000\000\bY\bY\003M\003M\000\000\000\000\003M\003M\000\000\bY\000\000\bY\000\000\000\000\bY\000\000\000\000\000\000\003M\bY\bY\bY\000\000\000\000\000\000\003M\012\173\000\000\000\000\000\000\003M\012\173\000\000\000\000\012\173\bY\003M\000\000\000\000\bY\000\000\000\000\000\000\000\000\000\000\012\173\000\000\012\173\000\000\012\173\000\000\012\173\bY\bY\bY\000\000\bY\bY\000\000\000\000\000\000\000\000\000\000\012\173\000\000\000\000\000\000\000\000\bY\012\173\012\173\bY\000\000\000\000\000\000\bY\003>\000\000\012\173\000\000\012\173\000\000\000\000\012\173\003\246\000\000\bY\000\000\012\173\012\173\012\173\000\000\000\000\000\000\000\000\012\177\000\000\000\000\000\000\000\000\012\177\000\000\000\000\012\177\012\173\000\000\000\000\000\000\012\173\000\000\000\000\000\000\000\000\000\000\012\177\000\000\012\177\000\000\012\177\000\000\012\177\012\173\012\173\012\173\000\000\012\173\012\173\000\000\000\000\000\000\000\000\000\000\012\177\003J\000\000\000\000\000\000\000\000\012\177\012\177\012\173\000\000\000\000\000\000\012\173\003>\000\000\012\177\000\000\012\177\000\000\000\000\012\177\000\000\000\000\012\173\000\000\012\177\012\177\012\177\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\177\000\000\000\000\000\000\012\177\000\000\000\000\000\000\000\000\012\142\000\000\000\000\014\n\b\221\000\000\b\221\b\221\012\177\012\177\012\177\000\000\012\177\012\177\012\198\012\222\012\230\012\206\012\238\000\000\003J\000\000\000\000\000\000\000\000\000\000\000\000\012\177\012\246\012\254\000\000\012\177\000\000\000\000\000\181\000\000\000\000\000\181\000\000\r\006\000\000\000\000\012\177\000\000\000\000\000\000\000\000\000\238\000\181\000\000\000\181\000\000\000\181\000\000\000\181\000\000\012\150\012\214\r\014\r\022\r&\000\000\000\000\000\000\000\000\000\000\000\181\000\000\016\214\r.\000\000\000\000\000\181\000\000\000\000\000\000\000\181\000\000\000\000\000\000\r6\000\181\000\000\000\181\000\000\000\000\000\181\000\000\000\000\000\000\000\000\000\181\000\181\000\238\000\000\000\000\rV\000\000\r^\r\030\000\181\000\181\000\000\000\249\b\221\r>\000\249\000\181\000\000\000\000\000\000\000\181\000\000\rF\rN\000\000\000\000\000\249\000\000\000\249\000\000\000\249\000\000\000\249\000\181\000\181\000\000\000\000\000\181\000\181\000\000\000\000\000\000\000\000\000\000\000\249\000\000\000\000\000\000\000\000\000\181\000\249\000\000\000\000\000\000\000\249\000\181\000\181\000\000\000\000\000\249\000\000\000\249\000\000\000\000\000\249\000\181\000\000\000\181\000\000\000\249\000\249\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\249\000\249\000\000\000\189\000\000\000\000\000\189\000\249\000\000\000\000\000\000\000\249\000\000\000\000\000\000\000\000\000\000\000\189\000\000\000\189\000\000\000\189\000\000\000\189\000\249\000\249\000\000\000\000\000\249\000\249\000\000\000\000\000\000\000\000\000\000\000\189\000\000\000\000\000\000\000\000\000\249\000\189\000\000\000\000\000\000\000\189\000\249\000\249\000\000\000\000\000\189\000\000\000\189\000\000\000\000\000\189\000\249\000\000\000\249\000\000\000\189\000\189\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\189\000\189\000\000\000\185\000\000\000\000\000\185\000\189\000\000\000\000\000\000\000\189\000\000\000\000\000\000\000\000\000\000\000\185\000\000\000\185\000\000\000\185\000\000\000\185\000\189\000\189\000\000\000\000\000\189\000\189\000\000\000\000\000\000\000\000\000\000\000\185\000\000\000\000\000\000\000\000\000\189\000\185\000\000\000\000\000\000\000\185\000\189\000\189\000\000\000\000\000\185\000\000\000\185\000\000\000\000\000\185\000\189\000\000\000\189\000\000\000\185\000\185\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\185\000\185\000\000\000\000\000\000\001j\000\000\000\185\000\000\001n\000\000\000\185\000\000\000\000\000\000\012-\012\025\000\000\001\146\001\150\001\154\001\158\001\162\001\166\000\185\000\185\000\000\000\000\000\185\000\185\000\000\000\000\000\000\001\170\001\174\000\000\012-\000\000\000\000\002\142\000\185\001\178\002\146\000\000\001\182\000\000\000\185\000\185\000\000\006\018\000\000\000\000\000\000\000\000\000\000\002\158\000\185\000\000\000\185\002\166\012\025\001\186\001\190\001\194\001\198\001\202\000\000\000\000\001\153\001\206\000\000\001\153\000\000\000\000\001\210\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\153\000\000\002\170\001\214\001\153\000\000\001\153\000\000\000\000\000\000\001\218\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\153\001\153\000\000\002\022\027r\000\000\001\153\000\000\000\000\000\000\002\026\000\000\002\030\005)\000\000\001\153\002\"\001\153\002&\002*\001\153\000\000\000\000\000\000\000\000\001\153\001\153\001\153\000\000\000\000\000\000\000\000\000\000\002\174\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\153\000\000\000\000\000\000\001\153\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\185\000\000\002B\001\185\000\000\001\153\001\153\000\000\000\000\001\153\001\153\000\000\b\181\000\000\001\185\000\000\000\000\005)\001\185\000\000\001\185\001\153\000\000\000\000\000\000\000\000\000\000\001\153\001\153\000\000\000\000\000\000\001\185\001\153\000\000\000\000\000\000\000\000\001\185\001\153\000\000\000\000\000\000\000\000\000\000\b]\003\002\001\185\000\000\001\185\b]\000\000\001\185\b]\000\000\000\000\000\000\001\185\001\185\001\185\000\000\000\000\000\000\000\000\b]\000\000\b]\000\000\b]\000\000\b]\000\000\000\000\001\185\001\185\000\000\000\000\003\146\000\000\000\000\000\000\000\000\b]\000\000\000\000\000\000\000\000\000\000\b]\b]\001\185\001\185\000\000\000\000\001\185\001\185\000\000\b]\000\000\b]\000\000\000\000\b]\000\000\000\000\000\000\001\185\b]\b]\000\238\000\000\000\000\000\000\001\185\012\169\000\000\000\000\000\000\001\185\012\169\000\000\000\000\012\169\b]\001\185\000\000\000\000\b]\000\000\000\000\000\000\000\000\000\000\012\169\000\000\012\169\000\000\012\169\000\000\012\169\b]\b]\b]\000\000\b]\b]\000\000\000\000\000\000\000\000\000\000\012\169\000\000\000\000\000\000\000\000\b]\012\169\012\169\b]\000\000\000\000\000\000\b]\000\000\000\000\012\169\000\000\012\169\000\000\000\000\012\169\000\000\000\000\b]\000\000\012\169\012\169\012\169\000\000\000\000\000\000\012\165\000\000\000\000\000\000\000\000\012\165\000\000\000\000\012\165\000\000\012\169\000\000\000\000\000\000\012\169\000\000\000\000\000\000\000\000\012\165\000\000\012\165\000\000\012\165\000\000\012\165\000\000\012\169\012\169\012\169\000\000\012\169\012\169\000\000\000\000\000\000\000\000\012\165\000\000\000\000\000\000\000\000\000\000\012\165\012\165\000\000\012\169\000\000\000\000\000\000\012\169\000\000\012\165\000\000\012\165\000\000\000\000\012\165\000\000\003\246\000\000\012\169\012\165\012\165\012\165\000\000\000\000\000\000\000\000\005\193\000\000\000\000\000\000\000\000\005\193\000\000\000\000\005\193\012\165\000\000\000\000\000\000\012\165\000\000\000\000\000\000\000\000\000\000\005\193\000\000\005\193\000\000\005\193\000\000\005\193\012\165\012\165\012\165\000\000\012\165\012\165\000\000\000\000\000\000\000\000\000\000\005\193\000\000\000\000\000\000\000\000\006&\005\193\005\193\012\165\000\000\000\000\000\000\012\165\n\182\000\000\005\193\000\000\005\193\000\000\000\000\005\193\000\000\000\000\012\165\000\000\005\193\005\193\000\238\000\000\000\000\000\000\000\000\000\000\001\130\002>\002B\002\130\000\000\000\000\000\000\000\000\005\193\000\000\000\000\000\000\005\193\000\000\020\154\000\000\000\000\000\000\004y\000\000\006\234\001*\002F\002V\000\000\005\193\005\193\005\193\000\000\005\193\005\193\002b\020\158\000\000\000\000\000\000\000\000\000\000\020\198\000\000\000\000\000\000\000\000\000\000\005\193\002f\002\250\000\000\005\193\000\000\001j\003\006\019\166\001z\003\026\003&\000\000\020\"\000\000\005\193\0032\000\000\000\000\001\146\001\150\001\154\001\158\001\162\001\166\000\000\000\000\000\000\000\000\021Z\000\000\000\000\000\000\0036\001\170\001\174\000\000\000\000\000\000\000\000\000\000\000\000\001\178\000\000\000\000\001\182\020>\021n\000\000\000\000\004y\004y\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\186\001\190\001\194\001\198\001\202\000\000\000\000\021~\001\206\000\000\000\000\000\000\000\000\001\210\001\197\000\000\005*\001\197\000\000\000\000\001\"\000\000\000\000\000\000\001\214\000\000\000\000\000\000\001\197\000\000\000\000\001\218\001\197\000\000\001\197\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\022\027\142\000\000\000\000\001\197\000\000\000\000\002\026\000\000\002\030\001\197\000\000\000\000\002\"\000\000\002&\002*\005.\000\000\001\197\000\000\001\197\000\000\000\000\001\197\000\000\000\000\000\000\000\000\001\197\001\197\000\000\0052\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\197\000\000\000\000\000\000\001\197\000\000\003I\000\000\002B\003I\000\000\000\000\000\000\000\000\000\000\000\000\005\030\001\197\001\197\000\000\003I\001\197\001\197\000\000\003I\000\000\003I\000\000\000\000\000\000\000\000\000\000\000\000\001\197\000\000\000\000\000\000\000\000\003I\000\000\001\197\000\000\000\000\000\000\003I\000\000\000\000\000\000\000\000\000\000\000\000\001\197\003\002\003I\000\000\003I\000\000\000\000\003I\000\000\000\000\000\000\000\000\003I\003I\003I\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003I\003I\000\000\000\000\003\146\000\000\000\000\000\000\000\000\007\"\001\006\000\000\000\000\000\000\001\"\000\000\t*\003I\003I\001&\000\000\003I\003I\000\000\000\000\000\000\000\000\000\000\000\000\001*\000\000\tJ\000\000\003I\000\000\000\000\007&\000\000\000\000\tb\003I\000\000\000\000\000\000\000\000\003I\000\000\000\000\000\000\0072\000\000\003I\000\000\t\142\001v\000\000\000\000\000\000\000\000\000\000\000\000\001z\000\000\000\000\007\190\000\000\000\000\000\000\007\194\t\250\007\198\000\000\t\158\007\246\005\189\000\000\000\000\005\189\000\000\000\000\000\000\000\000\000\000\000\000\000\000\007\250\000\000\000\000\005\189\000\000\005\189\000\000\005\189\000\000\005\189\b\002\000\000\005\030\000\000\000\000\t\166\000\000\000\000\000\000\000\000\000\000\005\189\000\000\000\000\000\000\000\000\000\000\005\189\nb\000\000\000\000\000\000\015\174\000\000\000\000\015\182\005\189\b\006\005\189\000\000\000\000\005\189\000\000\003j\000\000\000\000\005\189\005\189\000\238\000\000\000\000\000\000\012\181\000\000\000\000\000\000\000\000\012\181\000\000\000\000\012\181\000\000\005\189\000\000\000\000\000\000\005\189\000\000\000\000\000\000\000\000\012\181\000\000\012\181\000\000\012\181\000\000\012\181\000\000\005\189\005\189\005\189\000\000\005\189\005\189\000\000\000\000\000\000\000\000\012\181\000\000\000\000\000\000\000\000\000\000\012\181\012\181\000\000\005\189\000\000\000\000\000\000\005\189\000\000\012\181\000\000\012\181\000\000\000\000\012\181\000\000\000\000\000\000\005\189\012\181\012\181\000\238\000\000\000\000\000\000\012\185\000\000\000\000\000\000\000\000\012\185\000\000\000\000\012\185\000\000\012\181\000\000\000\000\000\000\012\181\000\000\000\000\000\000\000\000\012\185\000\000\012\185\000\000\012\185\000\000\012\185\000\000\012\181\012\181\012\181\000\000\012\181\012\181\000\000\000\000\000\000\000\000\012\185\000\000\000\000\000\000\000\000\000\000\012\185\nb\000\000\012\181\000\000\000\000\000\000\012\181\000\000\012\185\000\000\012\185\000\000\000\000\012\185\000\000\000\000\000\000\012\181\012\185\012\185\000\238\000\000\000\000\000\000\t\250\000\000\000\000\000\000\000\000\005\209\000\000\000\000\005\209\000\000\012\185\000\000\000\000\000\000\012\185\000\000\000\000\000\000\000\000\005\209\000\000\005\209\000\000\005\209\000\000\005\209\000\000\012\185\012\185\012\185\000\000\012\185\012\185\000\000\000\000\000\000\000\000\005\209\000\000\000\000\000\000\000\000\000\000\005\209\nb\000\000\012\185\000\000\000\000\000\000\012\185\000\000\005\209\000\000\005\209\000\000\000\000\005\209\000\000\000\000\000\000\012\185\005\209\005\209\000\238\000\000\000\000\000\000\005\213\000\000\000\000\000\000\000\000\005\213\000\000\000\000\005\213\000\000\005\209\000\000\000\000\000\000\005\209\000\000\000\000\000\000\000\000\005\213\000\000\005\213\000\000\005\213\000\000\005\213\000\000\005\209\005\209\005\209\000\000\005\209\005\209\000\000\000\000\000\000\000\000\005\213\000\000\000\000\000\000\000\000\000\000\005\213\005\213\000\000\005\209\000\000\000\000\000\000\005\209\000\000\005\213\000\000\005\213\000\000\000\000\005\213\000\000\000\000\000\000\005\209\005\213\005\213\005\213\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\142\000\000\000\000\007\t\005\213\000\000\000\000\007\t\005\213\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\012\238\000\000\000\000\005\213\005\213\005\213\000\000\005\213\005\213\000\000\012\246\012\254\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\r\006\005\213\000\000\000\000\000\000\005\213\000\000\000\000\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\138\012\150\012\214\r\014\r\022\r&\012\142\000\000\000\000\000\000\018:\000\000\007\t\000\000\r.\000\000\000\000\000\000\000\000\000\000\012\198\012\222\012\230\012\206\012\238\r6\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\246\012\254\000\000\000\000\000\000\000\000\000\000\rV\000\000\r^\r\030\r\006\000\000\000\000\000\000\000\000\r>\000\000\000\000\000\238\000\000\000\000\000\000\000\000\rF\rN\000\000\000\000\012\150\012\214\r\014\r\022\r&\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\r.\001I\000\000\000\000\001I\000\000\000\000\000\000\000\000\000\000\000\000\r6\000\000\000\000\000\000\001I\000\000\001I\000\000\001I\000\000\001I\000\000\000\000\000\000\000\000\000\000\rV\018>\r^\r\030\018J\000\000\001I\000\000\000\000\r>\000\000\000\000\001I\000\000\000\000\000\000\001I\rF\rN\000\000\000\000\001I\000\000\001I\000\000\000\000\001I\000\000\000\000\000\000\000\000\001I\001I\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001I\000\000\001E\000\000\000\000\001E\001I\000\000\000\000\000\000\001I\000\000\000\000\000\000\000\000\000\000\001E\000\000\001E\000\000\001E\000\000\001E\001I\001I\001I\000\000\001I\001I\000\000\000\000\000\000\000\000\000\000\001E\000\000\000\000\000\000\000\000\001I\001E\000\000\000\000\000\000\001E\000\000\001I\000\000\000\000\001E\000\000\001E\003A\000\000\001E\003A\000\000\001I\000\000\001E\001E\000\238\000\000\000\000\000\000\000\000\003A\000\000\000\000\001E\003A\000\000\003A\000\000\000\000\001E\000\000\000\000\000\000\001E\000\000\000\000\000\000\000\000\003A\005:\000\000\000\000\000\000\000\000\003A\000\000\001E\001E\001E\000\000\001E\001E\000\000\003A\000\000\003A\000\000\000\000\003A\000\000\000\000\000\000\001E\003A\003A\003A\000\000\000\000\000\000\001E\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003A\001E\000\000\000\000\003A\004q\000\000\000\000\004q\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003A\003A\004q\000\000\003A\003A\004q\000\000\004q\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003A\000\000\000\000\000\000\004q\000\000\005^\003A\000\000\000\000\004q\000\000\003A\000\000\004q\000\000\000\000\n\182\003A\004q\000\000\004q\000\000\000\000\004q\000\000\000\000\000\000\000\000\004q\005\254\000\238\000\000\000\000\000\000\000\000\000\000\000\000\004q\004q\000\000\000\000\000\000\000\000\000\000\004q\004q\000\000\000\000\004q\007\"\001\006\000\000\000\000\000\000\001\"\000\000\t*\000\000\000\000\001&\000\000\004q\004q\000\000\000\000\004q\004q\000\000\000\000\001*\000\000\tJ\000\000\nv\000\000\000\000\007&\004q\000\000\tb\000\000\000\000\000\000\000\000\004q\000\000\000\000\011f\000\000\0072\000\000\000\000\000\000\016F\001v\004q\000\000\000\000\000\000\000\000\000\000\001z\000\000\000\000\007\190\000\000\000\000\000\000\007\194\000\000\007\198\000\000\t\158\007\246\007\"\001\006\000\000\000\000\000\000\001\"\000\000\t*\000\000\000\000\001&\007\250\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001*\b\002\tJ\005\030\000\000\000\000\000\000\007&\000\000\000\000\tb\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0072\000\000\000\000\000\000\t\142\001v\016V\000\000\b\006\000\000\000\000\000\000\001z\000\000\003j\007\190\000\000\000\000\000\000\007\194\000\000\007\198\000\000\t\158\007\246\007\"\001\006\000\000\000\000\000\000\001\"\000\000\t*\000\000\000\000\001&\007\250\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001*\b\002\tJ\005\030\000\000\000\000\t\166\007&\000\000\000\000\tb\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0072\000\000\000\000\000\000\t\142\001v\019\n\000\000\b\006\000\000\000\000\000\000\001z\000\000\003j\007\190\000\000\000\000\000\000\007\194\000\000\007\198\000\000\t\158\007\246\000\000\000\000\000\000\000\000\001u\000\000\012\017\001u\000\000\000\000\000\000\007\250\000\000\000\000\000\000\000\000\012\017\000\000\001u\000\000\001u\b\002\001u\005\030\001u\000\000\t\166\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001u\000\000\000\000\000\000\000\000\000\000\001u\012\017\000\000\000\000\019z\000\000\b\006\000\000\012\017\000\000\000\000\000\000\003j\000\000\001u\000\000\000\000\000\000\000\000\001u\001u\001u\000\000\000\000\000\000\000\000\0019\000\000\000\157\0019\000\000\000\000\000\000\000\000\000\000\001u\000\000\000\000\000\157\012\017\0019\000\000\0019\000\000\0019\000\000\0019\000\000\000\000\000\000\000\000\000\000\001u\001u\001u\000\000\001u\001u\0019\000\000\000\000\000\000\000\000\000\000\0019\000\157\000\000\000\000\000\000\000\000\000\000\000\000\000\157\000\000\000\000\001u\000\000\000\000\0019\000\000\000\000\000\000\000\000\0019\0019\0019\001u\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0019\000\000\000\000\000\000\000\157\007\"\001\006\000\000\000\000\000\000\001\"\000\000\t*\000\000\000\000\001&\000\000\0019\0019\0019\000\000\0019\0019\000\000\000\000\001*\000\000\tJ\000\000\000\000\000\000\000\000\007&\000\000\000\000\tb\000\000\000\000\000\000\000\000\0019\000\000\000\000\001\002\001\006\0072\000\000\000\000\001\"\007>\001v\0019\000\000\001&\000\000\000\000\000\000\001z\006a\000\000\007\190\000\000\000\000\001*\007\194\000\000\007\198\001.\t\158\007\246\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0012\000\000\000\000\007\250\000\000\000\000\000\000\000\000\000\000\001f\001v\000\000\000\000\b\002\000\000\005\030\000\000\001z\024&\000\000\n\234\000\000\000\000\000\000\n\238\n\242\n\254\000\000\000\000\007\246\000Y\000\000\000Y\000\000\000\000\000\000\000\000\000\000\025b\000\000\b\006\000\000\000Y\000\000\000\000\000Y\003j\000\000\000\000\000Y\000Y\b\002\by\005\030\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\006\000\000\011\n\000\000\000\000\000\000\000\000\000Y\000\000\000\000\000Y\000\000\000\000\000\000\000Y\000\000\b\006\011\026\000\000\000\000\000Y\011\146\003j\000\000\000\000\000Y\000Y\000Y\000\000\000\000\000\000\000\000\000\000\000\000\000Y\000Y\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000Y\000\000\003A\000\000\000Y\003A\003A\000\000\000\000\003A\000\000\000\000\000\000\000\000\000\000\000Y\003A\000\000\000Y\000\000\003A\000\000\003A\000\000\003A\by\003A\000\000\000\000\000Y\000\000\000\000\000Y\000\000\003A\005:\000\000\000\000\003A\005:\003A\003A\000\000\000\000\003A\000Y\000\000\000\000\000\000\003A\000\000\003A\003A\003A\003A\003A\003A\000\000\003A\003A\003A\003A\000\000\003A\003A\003A\000\000\000\000\000\000\000\000\003A\005:\000\000\000\000\000\000\003A\003A\000\000\000\000\003A\000\000\000\000\000\000\003A\000\000\003A\000\000\003A\000\000\000\000\003A\000\000\003A\003A\006Z\003A\003A\003A\006\174\000\000\003A\003A\001\002\001\006\000\000\000\000\000\000\001\"\000\000\000\000\000\000\003A\001&\000\000\005^\003A\000\000\006\137\005^\003A\003A\000\000\001*\000\000\003A\000\000\001.\000\000\003A\003A\020z\000\000\003A\003A\000\000\000\000\000\000\0012\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001f\001v\000\000\000\000\005^\003A\000\000\000\000\001z\000\000\000\000\n\234\000\000\000\000\000\000\n\238\n\242\n\254\000\000\000\000\007\246\004Y\004Y\000\000\000\000\000\000\004Y\000\000\000\000\000\000\000\000\004Y\000\000\000\000\000\000\000\000\000\000\004Y\000\000\000\000\000\000\004Y\b\002\000\000\005\030\000\000\000\000\000\000\004Y\024Z\000\000\000\000\024r\011\006\000\000\011\n\000\000\000\000\000\000\000\000\000\000\004Y\000\000\000\000\000\000\004Y\004Y\000\000\000\000\b\006\011\026\000\000\000\000\004Y\011\146\003j\004Y\000\000\000\000\000\238\004Y\000\000\004Y\004Y\000\000\004Y\007\"\001\006\000\000\000\000\000\000\001\"\000\000\t*\000\000\000\000\001&\004Y\000\000\000\000\000\000\006e\000\000\000\000\000\000\000\000\001*\004Y\tJ\004Y\000\000\000\000\000\000\007&\000\000\000\000\tb\000\000\000\000\006\025\000\000\000\000\006\025\000\000\024\162\000\000\0072\000\000\000\000\000\000\007>\001v\000\000\006\025\004Y\000\000\000\000\006\025\001z\006\025\004Y\007\190\000\000\000\000\000\000\007\194\000\000\007\198\007\234\t\158\007\246\006\025\000\000\000\000\000\000\000\000\000\000\006\025\000\000\000\000\000\000\000\000\007\250\000\000\000\000\000\000\006\025\000\000\006\025\000\000\000\000\006\025\b\002\000\000\005\030\000\000\006\025\006\025\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006\025\000\000\000\000\000\000\006\025\000\000\012\t\b\006\000\000\012\t\000\000\000\000\000\000\003j\000\000\000\000\000\000\006\025\006\025\005\190\012\t\006\025\006\025\000\000\012\t\000\000\012\t\000\000\000\000\000\000\000\000\000\000\005!\006\025\000\000\000\000\000\000\000\000\012\t\000\000\006\025\000\000\000\000\000\000\012\t\000\000\000\000\007\"\001\006\000\000\000\000\006\025\001\"\012\t\000\000\012\t\000\000\001&\012\t\000\000\000\000\000\000\b>\012\t\012\t\000\000\000\000\001*\000\000\000\000\000\000\000\000\000\000\000\000\007&\000\000\000\000\000\000\000\000\012\t\000\000\000\000\000\000\012\t\000\000\000\000\000\000\0072\000\000\000\000\000\000\007>\001v\000\000\000\000\000\000\012\t\012\t\002\234\001z\012\t\012\t\007\190\000\000\000\000\000\000\007\194\000\000\007\198\007\234\000\000\007\246\012\t\000\000\000\000\000\000\005\242\000\000\000\000\012\t\000\000\000\000\000\000\007\250\007\"\001\006\000\000\000\000\000\000\001\"\012\t\t*\000\000\b\002\001&\005\030\000\000\bB\000\000\000\000\000\000\000\000\000\000\000\000\001*\000\000\tJ\000\000\000\000\000\000\000\000\007&\000\000\000\000\tb\000\000\000\000\006v\000\000\000\000\b\006\000\000\t\026\000\000\0072\000\000\003j\000\000\011V\001v\000\000\000\000\000\000\000\000\000\000\005u\001z\000\000\005u\007\190\000\000\000\000\000\000\007\194\000\000\007\198\000\000\t\158\007\246\005u\000\000\000\000\000\000\005u\000\000\005u\000\000\000\000\000\000\000\000\007\250\000\000\000\000\000\000\000\000\000\000\000\000\005u\000\000\000\000\b\002\000\000\005\030\005u\000\000\000\000\000\000\000\000\000\000\000\000\n\182\000\000\005u\000\000\005u\000\000\000\000\005u\000\000\000\000\000\000\000\000\005u\005u\000\238\000\000\000\000\b\006\000\000\000\000\000\000\000\000\000\000\003j\005y\000\000\000\000\005y\005u\005u\000\000\000\000\005u\000\000\000\000\000\000\000\000\000\000\005y\000\000\000\000\000\000\005y\000\000\005y\005u\005u\000\000\000\000\005u\005u\000\000\000\000\000\000\000\000\000\000\005y\000\000\000\000\000\000\000\000\000\000\005y\000\000\000\000\000\000\000\000\000\000\005u\n\182\000\000\005y\000\000\005y\000\000\000\000\005y\000\000\000\000\005u\000\000\005y\005y\000\238\000\000\000\000\000\000\000\000\000\000\011\201\000\000\001\006\011\201\000\000\000\000\028F\000\000\005y\005y\000\000\028J\005y\000\000\011\201\000\000\000\000\000\000\000\000\000\000\011\201\000\000\000\000\000\000\000\000\005y\005y\000\000\000\000\005y\005y\000\000\011\201\000\000\000\000\000\000\000\000\000\000\011\201\000\000\000\000\000\000\000\000\000\000\000\000\001\142\001v\011\201\005y\011\201\001\201\000\000\011\201\001\201\000\000\000\000\000\000\011\201\000\000\005y\000\000\000\000\000\000\000\000\001\201\028N\000\000\000\000\001\201\000\000\001\201\000\000\000\000\011\201\000\000\000\000\000\000\011\201\000\000\000\000\000\000\000\000\001\201\000\000\000\000\000\000\000\000\000\000\001\201\028R\011\201\011\201\000\000\000\000\011\201\000\000\000\000\001\201\000\000\001\201\006\029\000\000\001\201\006\029\000\000\000\000\000\000\001\201\001\201\000\000\000\000\000\000\000\000\011\201\006\029\000\000\000\000\000\000\006\029\000\000\006\029\000\000\000\000\001\201\000\000\000\000\000\000\001\201\000\000\000\000\000\000\000\000\006\029\000\000\000\000\000\000\000\000\000\000\006\029\000\000\001\201\001\201\000\000\000\000\001\201\001\201\000\000\006\029\000\000\006\029\000\000\000\000\006\029\000\000\000\000\000\000\001\201\006\029\006\029\000\238\000\000\000\000\000\000\001\201\000\000\000\000\000\000\000\000\005\130\000\000\000\000\000\000\000\000\006\029\001\201\000\000\000\000\006\029\000\000\000\000\000\000\000\000\007\"\001\006\000\000\000\000\000\000\001\"\000\000\000\000\006\029\006\029\001&\000\000\006\029\006\029\000\000\000\000\000\000\004\226\000\000\000\000\001*\000\000\000\000\000\000\006\029\000\000\000\000\007&\000\000\000\000\000\000\006\029\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0072\000\000\006\029\000\000\007>\001v\000\000\000\000\000\000\000\000\000\000\000\000\001z\007\"\001\006\007\190\000\000\000\000\001\"\007\194\000\000\007\198\007\234\001&\007\246\000\000\000\000\000\000\000\000\000\000\b\226\000\000\000\000\001*\000\000\000\000\007\250\000\000\000\000\000\000\007&\000\000\000\000\000\000\000\000\000\000\b\002\000\000\005\030\000\000\bB\000\000\000\000\0072\000\000\000\000\000\000\007>\001v\000\000\000\000\t\250\000\000\000\000\000\000\001z\007\017\000\000\007\190\007\017\000\000\000\000\007\194\b\006\007\198\007\234\000\000\007\246\000\000\003j\007\017\000\000\000\000\000\000\007\017\000\000\007\017\000\000\000\000\007\250\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\007\017\b\002\000\000\005\030\000\000\bB\007\017\nb\000\000\000\000\000\000\000\000\000\000\000\000\000\000\007\017\000\000\007\017\004q\000\000\007\017\004q\000\000\000\000\000\000\007\017\007\017\000\238\b\006\000\000\000\000\000\000\004q\000\000\003j\000\000\004q\000\000\004q\000\000\000\000\007\017\000\000\000\000\000\000\007\017\000\000\000\000\000\000\000\000\004q\000\000\000\000\000\000\000\000\000\000\004q\000\000\007\017\007\017\000\000\000\000\007\017\007\017\000\000\004q\000\000\004q\000\000\000\000\004q\000\000\000\000\000\000\000\000\004q\005\254\b\025\b\025\000\000\000\000\007\017\b\025\000\000\000\000\000\000\000\000\b\025\000\000\000\000\000\000\004q\000\000\007\182\000\000\004q\000\000\b\025\000\000\000\000\000\000\000\000\000\000\000\000\b\025\000\000\000\000\000\000\004q\004q\000\000\000\000\004q\004q\000\000\000\000\000\000\b\025\000\000\000\000\000\000\b\025\b\025\000\000\006&\000\000\000\000\000\000\000\000\b\025\000\237\004q\b\025\000\237\000\000\000\000\b\025\000\000\b\025\b\025\000\000\b\025\004q\000\000\000\237\000\000\000\000\000\000\000\237\000\000\000\237\000\000\000\000\b\025\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\237\b\025\000\000\b\025\000\000\000\000\000\237\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\237\000\000\000\237\000\241\000\000\000\237\000\241\000\000\000\000\000\000\000\237\000\237\000\238\b\025\000\000\000\000\000\000\000\241\000\000\b\025\000\000\000\241\000\000\000\241\000\000\000\000\000\237\000\000\000\000\000\000\000\237\012\t\000\000\000\000\012\t\000\241\000\000\000\000\000\000\000\000\000\000\000\241\000\000\000\237\000\237\012\t\000\000\000\237\000\237\012\t\000\241\012\t\000\241\000\000\000\000\000\241\000\000\005!\000\000\000\000\000\241\000\241\000\238\012\t\000\000\000\000\000\237\000\000\000\000\012\t\000\000\000\000\000\000\000\000\000\000\000\000\000\241\000\237\000\000\000\000\000\241\000\000\000\000\012\t\000\000\000\000\000\000\000\000\012\t\012\t\000\000\000\000\000\000\000\241\000\241\000\000\000\000\000\241\000\241\000\000\000\000\000\000\000\000\000\000\012\t\000\000\000\000\000\000\002>\002\238\000\000\000\000\000\000\001\"\000\000\000\000\000\241\000\000\000\000\000\000\000\000\012\t\012\t\002\234\000\000\012\t\012\t\000\241\001*\002F\002V\002\242\000\000\000\000\000\000\000\000\004q\012\t\002b\004q\000\000\026\130\000\000\000\000\012\t\000\000\000\000\000\000\000\000\000\000\004q\000\000\002\246\002\250\004q\012\t\004q\000\000\003\006\000\000\001z\003\026\003&\000\000\000\000\000\000\000\000\004\222\004q\005\166\000\000\000\000\000\000\000\000\004q\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004q\0036\004q\007\r\000\000\004q\007\r\000\000\000\000\000\000\004q\005\254\000\000\005\030\000\000\000\000\000\000\007\r\000\000\000\000\000\000\007\r\000\000\007\r\000\000\005\178\004q\000\000\000\000\000\000\004q\000\000\000\000\000\000\000\000\007\r\000\000\000\000\000\000\000\000\000\000\007\r\005&\004q\004q\000\000\000\000\004q\004q\000\000\007\r\000\000\007\r\000\000\006\017\007\r\000\000\006\017\000\000\000\000\007\r\007\r\000\000\000\000\000\000\020Z\004q\000\000\006\017\000\000\000\000\006R\006\017\000\000\006\017\000\000\007\r\t\250\000\000\000\000\007\r\000\000\004q\000\000\000\000\004q\006\017\000\000\000\000\000\000\000\000\000\000\006\017\007\r\007\r\019\210\004q\007\r\007\r\000\000\004q\006\017\004q\006\017\000\000\000\000\006\017\000\000\000\000\000\000\000\000\006\017\006\017\020\218\004q\000\000\007\r\000\000\000\000\000\000\004q\nb\000\000\000\000\000\000\000\000\000\000\006\017\000\000\000\000\000\000\006\017\011u\000\000\004q\011u\000\000\000\000\000\000\004q\005\254\000\238\000\000\000\000\006\017\006\017\011u\000\000\006\017\006\017\011u\000\000\011u\011u\000\000\004q\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011u\000\000\000\000\006\017\011u\000\000\011u\000\000\004q\004q\000\000\000\000\004q\004q\000\000\011u\000\000\011u\011u\000\000\011u\000\000\000\000\000\000\011u\011u\000\000\000\000\000\000\000\000\000\000\004q\000\000\011u\000\000\011u\005\130\000\000\011u\000\000\000\000\011u\004q\011u\000\000\011u\000\000\000\000\000\000\000\000\000\000\011y\000\000\000\000\011y\000\000\000\000\000\000\011u\011u\012r\000\000\011u\011u\000\000\011y\000\000\000\000\000\000\011y\000\000\011y\000\000\000\000\000\000\000\000\011u\011u\000\000\000\000\011u\011u\000\000\011y\000\000\000\000\000\000\000\000\000\000\011y\000\000\000\000\rf\000\000\000\000\000\000\000\000\000\000\011y\011u\011y\000\000\000\000\011y\000\000\000\000\000\000\000\000\011y\000\000\rf\000\000\000\000\002>\002\238\000\000\000\000\000\000\001\"\000\000\000\000\000\000\000\000\000\000\011y\012\130\000\000\000\000\011y\000\000\000\000\000\000\000\000\001*\002F\002V\000\000\000\000\000\000\000\000\000\000\011y\011y\002b\000\000\011y\011y\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\246\002\250\004I\000\000\000\000\004I\003\006\011y\001z\003\026\003&\000\000\000\000\000\000\000\000\004\222\004I\004\230\rf\000\000\004I\000\000\004I\t\250\000\000\000\000\000\000\000\000\005\129\000\000\000\000\005\129\0036\000\000\004I\000\000\000\000\000\000\000\000\000\000\004I\000\000\005\129\000\000\005\030\000\000\005\129\000\000\005\129\004I\000\000\004I\000\000\000\000\004I\000\000\005\"\000\000\000\000\004I\005\129\000\000\000\000\000\000\000\000\000\000\005\129\nb\000\000\000\000\000\000\000\000\000\000\005&\000\000\004I\000\000\000\000\000\000\004I\005\129\000\000\000\000\000\000\000\000\005\129\005\129\000\238\000\000\000\000\000\000\000\000\004I\004I\000\000\000\000\004I\004I\000\000\000\000\000\000\005\129\000\000\000\000\000\000\000\000\000\000\004A\000\000\000\000\004A\000\000\000\000\000\000\004a\004I\000\000\004a\005\129\005\129\000\000\004A\005\129\005\129\000\000\004A\019\250\004A\004a\000\000\000\000\000\000\004a\000\000\004a\000\000\000\000\000\000\000\000\004A\000\000\005\129\000\000\000\000\000\000\004A\004a\000\000\000\000\000\000\000\000\000\000\004a\000\000\004A\000\000\004A\000\000\000\000\004A\000\000\004a\000\000\004a\004A\000\000\004a\000\000\000\000\000\000\000\000\004a\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004A\000\000\000\000\000\000\004A\000\000\000\000\004a\000\000\000\000\000\000\004a\0041\000\000\000\000\0041\000\000\004A\004A\000\000\000\000\004A\004A\000\000\004a\004a\0041\000\000\004a\004a\0041\000\000\0041\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004A\000\000\000\000\000\000\0041\000\000\000\000\004a\000\000\000\000\0041\022\194\000\000\000\000\000\000\000\000\000\000\000\000\023\166\0041\004q\0041\000\000\004q\0041\000\000\000\000\000\000\000\000\0041\000\000\000\000\000\000\000\000\004q\000\000\000\000\000\000\004q\000\000\004q\000\000\000\000\000\000\000\000\0041\000\000\000\000\000\000\0041\000\000\000\000\004q\002>\002B\000\000\000\000\000\000\004q\000\000\000\000\000\000\0041\0041\000\000\003>\0041\0041\000\000\000\000\004\226\000\000\004q\001*\002F\002V\000\000\004q\005\254\000\000\000\000\000\000\000\000\002b\000\000\0041\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004q\000\000\000\000\025\130\002f\002\250\000\000\000\000\000\000\000\000\003\006\000\000\001z\003\026\003&\000\000\000\000\004q\004q\0032\000\000\004q\004q\001\130\000\000\000\000\006\006\000\000\000\000\003J\000\000\000\000\000\000\000\000\000\000\000\000\0036\006\230\000\000\000\000\004q\004\133\000\000\006\234\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\217\000\000\000\000\011\217\006\246\000\000\000\000\000\000\000\000\000\000\019\190\000\000\000\000\007\141\011\217\000\000\000\000\000\000\000\000\007\170\011\217\025\174\000\000\000\000\019\166\000\000\003f\000\000\003j\020\"\007\141\007\141\011\217\007\141\007\141\000\000\000\000\000\000\011\217\000\000\000\000\000\000\000\000\000\000\000\000\020*\000\000\011\217\000\000\011\217\000\000\000\000\011\217\000\000\007\141\000\000\000\000\011\217\007q\000\000\000\000\000\000\020>\020j\000\000\000\000\004\133\004\133\000\000\000\000\000\000\000\000\000\000\011\217\000\238\007q\007q\011\217\007q\007q\000\000\000\000\000\000\007\145\000\000\024\014\000\000\000\000\000\000\007\141\011\217\011\217\000\000\000\000\011\217\000\000\000\000\000\000\000\000\007q\007\145\007\145\0286\007\145\007\145\000\000\000\000\007\141\000\000\007\141\000\000\000\000\000\000\011\217\000\000\000\000\000\000\000\000\000\000\007q\000\000\000\000\007\133\007\141\007\145\000\000\bb\007\141\000\000\000\000\000\000\007\141\000\000\007\141\007q\0049\000\000\007\141\0049\007\133\007\133\000\000\007\133\007\133\000\238\000\000\000\000\000\000\000\000\0049\000\000\000\000\007q\0049\007q\0049\000\000\000\000\000\000\007\145\000\000\000\000\000\000\007\133\000\000\000\000\000\000\0049\007q\002>\002B\bb\007q\0049\000\000\000\000\007q\007\145\007q\007\145\000\000\000\000\007q\000\238\000\000\000\000\000\000\0049\000\000\001*\002F\002V\0049\007\145\000\000\000\000\bb\007\145\007\133\002b\000\000\007\145\021\174\007\145\000\000\000\000\000\000\007\145\0049\000\000\000\000\000\000\000\000\002f\023\002\000\000\007\133\022&\007\133\003\006\000\000\001z\003\026\003&\000\000\0049\0049\000\000\023\018\0049\0049\000\000\b\170\000\000\000\000\bb\007\133\000\000\004i\000\000\007\133\004i\007\133\000\000\000\000\0036\007\133\001\130\0049\000\000\006\006\000\000\004i\000\000\000\000\000\000\004i\000\000\004i\023N\000\000\028\142\000\000\002>\002B\000\000\000\000\006\234\000\000\000\000\004i\000\000\000\000\000\000\000\000\000\000\004i\000\000\000\000\006\246\000\000\000\000\000\000\001*\002F\019\190\000\000\000\000\000\000\000\000\004i\000\000\000\000\000\000\007\170\004i\025\174\000\000\000\000\019\166\000\000\000\000\000\000\000\000\020\"\006\225\006\225\002f\003\n\000\000\000\000\004i\000\000\003\006\000\000\001z\003\026\003&\000\000\000\000\020*\000\000\0032\000\000\028>\006\225\006\225\006\225\004i\004i\000\000\000\000\004i\004i\000\000\006\225\000\000\020>\020j\0036\000\000\004\173\000\000\004\146\000\000\012\189\012\189\000\000\000\000\006\225\006\225\004i\000\000\000\000\000\000\006\225\000\000\006\225\006\225\006\225\024\014\000\000\023\206\004z\006\225\012\189\012\189\012\189\n\014\000\000\000\000\000\000\002>\002B\019\014\012\189\000\000\000\000\000\000\000\000\000\000\006\225\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\189\012\189\000\000\001*\003\018\002V\012\189\000\000\012\189\012\189\012\189\000\000\000\000\002b\000\000\012\189\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002>\002B\019~\000\000\002f\002\250\000\000\000\000\000\000\012\189\003\006\000\000\001z\003\026\003&\000\000\000\000\003\222\000\000\0032\001*\003\018\002V\000\000\000\000\000\000\000\000\002>\002B\000\000\002b\000\000\000\000\000\000\000\000\000\000\0036\000\000\000\000\000\000\002>\002B\000\000\000\000\002f\002\250\000\000\001*\002F\000\000\003\006\000\000\001z\003\026\003&\000\000\000\000\000\000\000\000\0032\001*\002F\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002f\003\n\000\000\000\000\000\000\0036\003\006\000\000\001z\003\026\003&\000\000\000\000\002f\003\n\0032\000\000\000\000\000\000\003\006\000\000\001z\003\026\003&\000\000\000\000\001\130\000\000\0032\006\006\000\000\000\000\0036\000\000\000\000\000\000\004\241\000\000\000\000\000\000\004\165\000\000\000\000\000\000\000\000\0036\006\234\000\000\000\000\004\245\000\000\000\000\000\000\000\000\000\000\000\000\004z\000\000\006\246\000\000\000\000\000\000\000\000\000\000\019\190\000\000\000\000\000\000\000\000\004z\000\000\000\000\000\000\007\170\000\000\025\174\000\000\000\000\019\166\000\000\000\000\000\000\000\000\020\"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\020*\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\020>\020j\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\024\014"))
+  
+  and lhs =
+    (8, "\012\011\n\t\b\007\006\005\004\003\002\001\000\221\221\220\220\219\218\218\217\217\217\217\217\217\217\217\217\217\217\217\217\217\217\217\217\217\217\217\216\216\215\214\214\214\214\214\214\214\214\213\213\213\213\213\213\213\213\212\212\212\211\211\210\209\209\209\208\208\207\207\207\207\207\207\206\206\206\206\206\206\206\205\205\205\205\205\204\204\204\204\203\202\201\201\201\201\200\200\200\200\199\199\199\198\198\198\198\197\196\196\196\195\195\194\194\193\193\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\192\191\191\190\190\189\188\187\186\186\185\185\184\184\184\184\183\183\183\183\182\182\181\180\180\180\180\179\178\177\177\176\176\175\175\174\173\173\172\171\171\170\169\168\168\168\167\167\166\165\165\165\165\165\164\164\164\164\164\164\164\164\163\163\162\162\162\162\162\162\161\161\160\160\160\159\159\158\158\158\158\157\157\156\156\155\155\154\154\153\153\152\152\151\151\150\150\149\149\148\148\147\147\147\146\146\146\146\145\145\144\144\143\143\142\142\142\142\142\141\141\141\141\140\139\139\138\138\138\137\137\137\137\137\137\137\136\136\136\136\136\136\136\135\135\134\134\133\133\133\133\133\133\132\132\131\131\130\130\129\129\128\128\127~~~}}|||||||||{{zyyyyyyyyyxwvuutttttsrrqqppppppppppppppoonnmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmllkkjjiihhggffeeddccbbaaaaaa`_^]\\[ZYXWWWWWWWVVUUTTTTTSSSSSSRRQQQQQPPOONMLLKKKKKJJIIHHHGGGGGGFFFEEDDCCBBAA@@@??>>==<<;;::9988776655544433322211110/...................-----,,,,++++++++++++++++++++++++++++++++++++++++++++**))))))))))))))))(((((((((((((((((((((((((((((((((((((((((((((((((((''&&&%%$$$$$$$$$$$$$$$$$##\"\"!!!!!!!    \031\031\030\030\030\029\029\028\027\026\026\026\025\025\024\024\024\024\024\024\024\024\024\024\023\023\022\021\021\020\019\019\019\019\019\018\017\017\016\016\016\015\015\015\014\014\014\014\014\014\r\r")
+  
+  and goto =
+    ((16, "\000%\001?\0009\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\014\000\000\000\000\001\029\000*\000\030\001\031\000\003\n\200\000\000\000\000\000\229\000\178\011z\000\171\000\216\011\198\000\000\000\000\000\000\003\232\000\163\0018\0012\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\014\000\000\t\164\000\000\000\000\003\232\000\000\002\024\001|\000O\003\186\000\031\000p\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000B\000\000\000\000\000\000\000\144\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000J,\000\000\000\000\000\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006\222\000\156\003\192\000\211\000\000\003\238\b\024\000\204\004\022\001V\000\000\000\000\000\000\003\252\000\000\000\000\002\206\000\000\000\000\000\000\000\000\002&\000\000\0010\000\000\000\000\000\000\000\000\000\000\002>\000\000\0007\002h)\200\000\000\000\192\006\222\000\000\002\172\000\000\002\n\000\000\022D\001R\000\000\001\246\000\000>\182\002\026\000\000>\212ET\000\159\000\000\000\213\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000?8\001\192\000\000\000\000\000\000\016\172\000\000\002\248\000\000\000\000\000:\000\200\000\000\000\000\004\230\000\000\0220\000\000\000:\004\210\000:\000\000\000\000\000\000\000\000\000\000Ed\000\000\004\190\002\132\000\000\018\202\004\208\012f\000\000\000\000\000\000\002\"\000\000\000\000\000\000\000\000\002\146\000\000\000\000\000\000\000\000\000\000?\146\000\000\000\000\000\000\000\000\000\000\000\000\000A\003\128\000\000\000\000\000\000\000\000\003\012\000\000\018\020\000\000\005\"\000\000\005\184\004\148\000\000\000\000\000:\004\194\000\000\000\000\000\000\000\000\000\000\000\000\023,\000\000\000\000\000\000\000\000\001\224\006\140\000\000\000\000Jx\002\146\002\146\000\000J\234\002\146ET\000\000\003\016\000\000\000\000\000\000H:\006f\000\000\006\140\000\000\000\000\000\000\003\222\000\000\000\000\000\000\000\000\001\011\000\000\000\000\000\000\003j\001\020\004\\\000\000\000\000\000\000\006\180\000:\000\000\000:\003\228\000\000\bJ\000:\000:\006\164\000\000\000\000\003\244\001\011\000\000\000\000\000\000\002\146\000\000\003\250\0072\000\000\004\168\000\000\000\000\000\000\000\000\002\146\002J\002\168\006\006\000\000\000\000\000\000\000\000\006z\000\000\000\000\000\000\000\000\000\000*~\005\130\000u\002\166\002`\004\182\007V\004\168\006t\007\156\002h\005\186\001\252K(\002\146KP\002\146\003\"\000\000\000\000\000\000\005\234\000\000\000\130\000Q\003j\000\245\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\007x\000\000\000\000\000\206\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\250\005&\007\162\000\000\000\000\bf\006Z\006J\004\"\000\000\000\000\006\\\000\198\003z\000\000\b\160\000\000\000\000\000\000\005\148\005\192\007\188\001f\000\000\007\232\006\216\006\016\007\254\006v?\220\000\000\000\000\000\000\000\000\000\000\000\000\000\000;\\\000\000\006\172\bT\007J\000\000\000\000\000\000\000\000\005n\000\000\000\000\bV\001x\002\240\b\144*\242\000\000\000\000\006\238\t\006\011\236\006\252\tJ\012F\000\000+>\007H\t\172\b\216\000\000\t\n;\200;\236\000}\000\000\000\000\000\000\b\188Kh\002\146\b\202@\"\bB\t\178?V\000\000\b|\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\250\000\000\000\000\000\000\000\000\t\132@V\000\000\bb\t\212@\202\000\000\000\000\000\000@\230\bbA2\bb\000\000A\194\bb\000\000A\212;\\\tF\t\150\000\000\000\000Ip\000\000\000\000\000\000\bb\000\000A\230\bbK\146\002\146\000\000A\248\bb\002\252\000\000\bb\bb\bb\000\000;\236\000\000\000\000\000\000\bb<v\000\000\000\000\bb\000\000\001\180\t\204\000\000\000\000\000\000\000\000\000\000\000\000B\182\000\000\t\132\000\000K\208\002\146\000\000\000\000\000\000\000\000\t\156\n^\012\1848\234E\244\n\138\000\000<\016\bbL\"\002\146\n~\000\000\000\000\000\000\000\000;\\\nl\000\000<\184I\162\000\000\r$\t\252\n\030\nF\t\226\004J\n\012\002\018\011\012\000\000\000\000\tX\n@\n\020\003\024\n\162\000\000\000\000\n\168\000\000\002 \000:\007,\002.\012\000\000\000\000\000P.\000\000P\226\011\164\000\000\002\\\003\166\000\000\011\162\002 \000\000\000\000\n\220\000\000\000\000\000\000\000\000\000\000\012\152\002 \rn\002 \000\000\003\160\000\000\000\000\003\252\000\000\000\000\000\000\012 \000\000\000\000\002 \000\000\002 \000\000\000\000\006\022\000\000\004\240\002\240\000\000\004\240\000\000\014\026\002 \000\000\000\000\000\000\000\000\000\000\004\240\r\132\000x\r\192\011\226\011\148+HB\196\000\000\027z,&\n\236\n(\027\252\n\252\n4\014\168\011\024\nr\014\200\011D\n\144\005\176<\220\bb\015\026\011P\n\164H\136;\\\012\002\000\000E\184\015\140\011n\n\184B\232\bb\016$\011t\n\190B\242\bb\016\134\"8\000\000\000\000\000\000\000\000\000\000\004N\t\252\000\000\000\000\000\000\011z\n\200\006\132\004\240\014\232\002 \000\000\000\000\000\0008\234\000\000L,\002\146\016\144\011~\n\218#\028\000\000$\000\000\000\000\000\016\232,0\000&\000\000\000\000\000\000\000\000$\228\000\000\000\000\000\000\002\152\017\154\000\000\000\000\000\000,|%\200\000\000\000\000\000\000\000\000\000\000\011^\017\206\000\000\000\000\011b\018\026\000\000\011r,\134\011r-d\011r\000\000&\172\000\000-n\011r\018f\004\194\018\154\000\000\000\000-\186\011r-\196\011r.\162\011r.\172\011r.\248\011r/\002\011r/\224\011r/\234\011r06\011r0@\011r1\030\011r1(\011r1t\011r1~\011r2\\\011r2f\011r2\178\011r2\188\011r3\154\011r3\164\011r\n\2489.\000\000LN\002\146\019L\000\000\011x\019\152\000\000CT\bbC\178\bbD`\bb\005\172\000\000\000\000\000\000\000\000Dj\bb\000\000\005 \000\000\000\000\000\000\011r\020\024\000\000\000\000\020\138\000\000\000\000\000\000\000\000\020\204\000\000\000\000\011r\021<\000\000\021\144\000\000\000\000\022\000\000\000\000\000\000\000'\144\000\000\000\000\022n\000\000\000\0003\240\011r\022\196\000\000\000\0003\250\011r\0232\000\000\000\0004\216\011r\007\244\023\162\000\000\000\0004\226\011r\023\246\000\000\000\0005.\011r\024f\000\000\000\00058\011r\000\000\000\000\024\168\000\000\000\0006\022\011r\025\026\000\000\000\0006 \011r\025l\000\000\000\0006l\011r\000\0006v\011r\000\000\001\198\000\000\000\000\011r\000\000\000\000\025t\000\000\000\000\026R\000\000\000\000\000\000\011x\026t\000\000\000\000\0278\000\000=f\000\000\000\000\"8\000\000\000\000\027X\000\000\000\000\000\000\028\028\000\000\000\000\000\000\012\206\000\000\000\000Dr\000\000\004~\000\000\004\212L\170\002\146I\018\002\146L\186\002\146\000\000\012l\000\000\b$\000\000\000\000\000\000\000\000\000\000\004N\000\000\000\000\011\210\000\000\000\000\028<\000\000\029\000\000\000\000\000\000\000\029 \000\000\000\000\029\228\011\224\030\004\000\000\030\200\000\000\000\000\000\000;\\\012\140\000\000F,\th\000:\030\232\000\000\000\000FP\000\000\000\000\000\000G\014\000\000\000\000\031\172\000\000\031\204\000\000\000\000\000\000\000\000=\202\000\000\000\000\000\0007T\011r7^\011r\000\000\000\000\000\000\000\000\011r\000\000\000\000\000\000\000\000\011r\000\000\r\014\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\006\006\172\004\240 \144\000\000\012\024\011\n\012\164\005D\b\028\004\240\015\"\002 \b\218\004\240\000\000 \176\000\000\005P\000\000\012*\011\018\006f\012t\011\024\000\000!t\000\000\011\030\r\1369R\006\250\000\000\000\000\000\000!\148\000\000\000\000>\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000I\018\r<\000\000M\b\002\146\"X\000\000\000\000M4\002\146\"x\000\000\000\000#<\000\000\000\000\br\000\000\011r\000\0009\136\000\000\000\000:T\000\000\011r\000\000\015J\002 \000\000\015|\002 \000\000\016D\002 \000\000\004\240\002 \000\000\bb\000\000Mt\002\146\000\000\000\145\000R\011\"\r:\000\000\r\250#\\\000\000\000\000$ \000\000\b\148\000\000\005\246\000\000\000\000\000\000\000\000\000\000\000\000M\134\002\146\000\000\014\002$@\000\000\000\000%\004\000\000\000T\011(\r\170\000\000Gv\002\020\rb\000\000M\196\002\146%$\000\000\000\000N\016\002\146\000\000%\232\000\000\002\146\000\000\b\246\000\000\000L\000\000\000\000\000\000\000\000\000\000\000\000\002f\000\000\000\000G\172\005\250\rn\000\000N^\002\146&\b\000\000\000\000&\204\000\000\000\000\004\216\003DD\160\bb&\236\000\000\012\214\012\216\011:\012\250\r\168\016r\002 \t\240\000\000\011F\r\138\r\148\005|\n\212\rd\011\130\r\162\007(\n\216\r|\000\000\000\000\007v\011b\000\000\007h\004(\r:\011\144\t\138\005j\000\000\r>\011\172\t|\000\000N\144\002\146\r\222\0140\000\000\011\232\000\000\r\162\011\238\b:\r\204\b\\\012\n\011\234\000\000\012\018\012<\000\000\b\230\014\b\r\214\r\216\0122\007~\012\150\000\000\012@\007\240\012\160\000\000\r\246\014\014\012T\014:\r\168\017b\002 \000\000\012^\014\172\000\000\tf\012\242\000\000\014\174\000\000\019\132\007\n\014\128\012b\014\196\000\000\020b\007 \014\140\000\000\000\000\004|\t\174\r\006\000\000\020\252\002 \r\024\000\000\005p\000\000\014F\012\158\021&\007(\000\000\014J\012\176\t\246\r\204\014R\014z\012\202\015\240\000\000\014\162\005V\000\000\000\000\000\000\000\000\002.\012\224\014zN\160\002\146\000\000\006\192\r\004\015D\000\000\000\000\000\000\000\000\000\000\000\000N\236\b@\000\000\r \015\170\000\000\000\000\000\000\000\000\000\000\000\000\019\198\r(\000\000\rz\011\004\000\000\r~\r\140\nj\000\000\011\030I\200\000\000\t\208\000\000O\018\002\146\002\146\000\000\000\000\b\146\000\000\n\202\000\000\012\022\b\146\b\146\000\000\r\154I\156\002\146O*\002\146\rH\000\000\000\000\000\000\rV\000\000\000\000\t\166\000\000\t\156\015*\r\156\016J\015\000\000\000\000\000\012\240\t\228\015X\000\000\000\000\r\172\016z\015L\000\000\000\000\t\192\000\000\005\172\000\000).ED\002\146\000\000Oj\006\144\000\000Oz\000\000\000\000\000\000\b\146\000\000\000\000\rh\015\140\r\174\016\162\015T\000\000\000\000O\204\rl\015\148\000\000\000\000\000\000 \242\000\000\000\000\000\000\000\000\000\000\000\000\000\000\rv\000\000\015\164\r\180\n\184\000\000\016\152\016N\r\224\015\178\000\000\000\000\015\182\r\184\n\212\000\000\000\0007\164\016X\014\014\015\196\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\146\015r\r\190\016\210\015\134\000\000=\192\000\233\r\238\015\\\005\206\014 '\176\014^\000\000\014*\0146\000\171\000W\014D\br\014H\016p:0\014\210\000\000\014T\014V\n\214\000\000\003\004I\250\000\000\t\020\000\000\014ZG\198G\208\004\028\015P\006,\000\000A\n\001\198\000\000\004B\000\000\000\000\004B\000\000\000\000\004B\011`\000\000\006\244\004B\016z:\152\014\228\000\000\004B\000\000O\238\000\000\000\000\004B\000\000\000\000\014\248\000\000\007\n\th\014\254\000\000\014bJ\014\015\022\000\000\000\000\000\000\015P\000\000\000\000\007\006\000\000\004BP&\000\000\007@\004BH\006\000\000\015j\015\222\014\148\016\254\015\182\000\000H\018\015\196\015\250\000\000\000\000\000\000\027\152\t\252\000\000\000\000\000\000\000\000\000\000\011^\000\000\011b\015\212\000\000\016\b\000\000\000\000\000\000\000\000\015\218\031*\000\000\000\000\000\000\011^\000\000\011b\000\000\000\000\000\000\000\000\000\000\000\000\006\222\000\000\014\184\t\172\tH\000\000\015\252 \014\000\000\000\000\000\000\000\000\000\000\000\000\016\160\000y\000j\000\000\000\000\000\000\000\000\n\138\006Z8:\016\190\016\004\000\000\000\000\016\182\000~\002B\000\000\000\000\000\000\002 \000\000\n*\000\000\000\000\000\000\000\000\015\214\014\208\n\180\004\240\000\000\022v\002 \000\000\017\026\000\000\000\000\000\000\000\000:\242\000\000\000\000:\252\000\000'\208\000\000(\148\000\000\000\000(\180\000\000\000\000\000\000\000\000)x\000\000)\152\000\000\000\000\000\000\000\000\000\000\003\160\000\000\000\000\000\000\000\b\000p\000\000\000\000\000\000\000\000\000\000\000\004\000p\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\194\000\000\000\000\000\000\014$\000\000\002\146\000\000\nh\000\000\000\000\000\000\002\136\000\000\000\000\000\000\003\152\000\000\000\000\000\000\005\214\000\000\000\000\000\000>b\bb\000\000\000\000\003\"\000\000\000\000\000\000\000\000\004N\005\016\015\252\004\140\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000H\204\000\000\016\024\000\000\000\000\000\000\000\000\005\244\007\188\026\254\028~\000\000\000\000\016\026\029b\000\000\000\000\000\000\016\"\030F\000\000\000\000\000\000\000\000"), (16, "\006j\006\151\002\230\002\231\002\004\001\155\000\142\002\004\000U\006\207\006\154\000Q\0007\002}\000U\000V\006\172\003\006\006k\006\212\001\142\006m\000\209\002\144\006\230\003\007\006\223\002\148\000\213\000\213\006n\006|\000;\006j\001\018\002\230\002\231\002\004\003\020\002\230\002\231\002\004\000Q\002\161\006*\000U\000V\0007\000?\000\207\003\006\006k\006{\004\217\006m\000\213\000\216\000\231\003\007\006o\004\172\0007\003\194\006n\006|\000Q\001N\001_\000U\001\243\002\149\003\020\006\134\000X\006,\006*\001\160\000D\001\162\001\244\002\230\002\231\002\004\001\021\000Q\002\150\003\195\000U\000V\006-\006\150\002\162\006o\006p\006/\003\006\006\205\003\022\006X\006S\006\224\000\207\006q\003\007\001\246\006,\000G\000\213\000\226\002\234\000N\003\024\000U\004D\004\221\006U\003\020\006*\006\157\006\158\006-\006\129\003\031\000\217\000\221\006/\006p\000\222\006\130\006D\003\022\001\142\006\225\006\168\002\233\006q\001\163\006\232\000\213\001g\001_\006V\002\234\006\131\003\024\000U\002\234\006,\003\024\000U\000@\000\224\000b\006u\006\129\003\031\006\214\000\207\006w\001\150\001_\006\130\006-\000\213\000\226\000\140\000\221\006/\001`\006y\001\184\006?\003\025\000{\003#\003\022\006\131\006\231\004\210\006\233\003)\001\142\001\162\003\027\003\197\006z\006u\002\234\000:\003\024\000U\006w\004\174\004\212\000\232\000\175\001S\006\159\001\175\003\028\003\031\006\155\006y\003+\006\234\003\025\000\127\003#\006j\003\025\002\230\002\231\002\004\003)\000X\001\162\003\027\003\026\006z\001\162\003\027\003 \006\235\0009\000\207\003\006\006k\006{\000\207\006m\000\213\000\226\006\156\003\007\000\213\000\216\003+\000=\006n\006|\000E\006\157\006\158\001\167\001\168\000\131\003\020\002\230\002\231\002\004\003\025\001\164\003\130\001\169\001\170\000\149\000X\000X\003)\000H\001\162\003\027\001g\001_\001\171\001_\000\207\006o\0011\000\156\003\194\006\176\000\213\000\226\001c\001d\002\172\001\167\001\168\000\252\000Q\003+\001\165\000U\000V\002\172\000\227\001\169\001\170\000\221\001e\001f\001\166\000\162\000\221\001g\001_\000\222\001\171\001_\000\179\006p\000\230\006\138\000X\003\022\002\183\000O\0007\000U\006q\000\175\004\153\000\236\000\184\002\183\001\006\002\234\000U\003\024\000U\000\224\006j\000X\002\230\002\231\002\004\000\178\000\227\006\129\003\031\004\202\001\142\002y\001V\000\221\006\130\001\136\000\222\003\006\006k\006{\002\233\006m\000\198\000Q\004\205\003\007\000U\001\243\001\142\006\131\006n\006|\002\234\001W\003\024\000U\000\201\002F\003\020\006u\000\224\000W\000\232\001`\006w\001\142\000\207\002\184\000\221\000X\004\202\001(\000\213\000\226\000\204\006y\002\184\0007\003\025\006o\003#\000\175\001\246\006\148\000\180\004\220\003)\000\207\001\162\003\027\003\196\006z\000\207\000\213\000\226\000\224\001&\000\220\000\213\000\226\001\144\0023\002\004\000\232\000Q\000\207\000\221\000U\001\243\003+\001`\000\213\000\216\006p\006\250\003\025\000\181\003\022\0059\007\n\002\231\002\004\006q\003\026\002\n\001\162\003\027\002\155\000\249\002\234\000U\003\024\000U\000\207\006j\006\169\002\230\002\231\002\004\000\213\000\226\006\129\003\031\002\130\002\170\002\165\001\000\000\252\006\130\000\227\006\251\003\006\006k\006{\000\227\006m\000\213\003}\004\208\003\007\000U\001\243\002y\006\131\006n\006|\006\156\005\151\000\207\001c\001d\002\172\003\020\006u\000\213\000\226\001!\001\142\006w\005\152\005\222\000\236\000`\005\175\001\006\002\143\001{\007\012\000\252\006y\001g\001_\003\025\006o\003#\000\227\003\139\006\132\002\176\004\208\003)\002\183\001\162\003\027\000U\006z\000\207\001<\005\223\006\216\005\224\000Q\000\213\000\226\000U\000V\001c\001d\002\230\002\231\002\004\001\142\000\236\003+\000\221\001\006\007\r\006p\003\024\000U\000\227\003\022\000\175\001v\000\185\001\175\006q\001g\001_\005\225\000Y\006\178\001\005\002\234\006*\003\024\000U\001\143\006j\006\254\002\230\002\231\002\004\001\129\001S\006\129\003\031\000\236\001C\001E\001G\001\020\006\130\001\024\002\184\003\006\006k\006{\000\227\006m\003\253\002\004\005\226\003\007\006,\002{\002\165\006\131\006n\006|\002\011\005\227\005\228\002\140\005\229\006\255\003\020\006u\000U\006-\002\157\001\185\006w\002\144\006/\000\228\000\213\002\148\0066\000\213\007\022\002\231\002\004\006y\000X\001\142\003\025\006o\003#\006\002\001<\006\127\000\221\002\233\003)\001]\001\162\003\027\000\175\006z\001\176\001\175\001\165\003\234\000\207\002\234\000c\003\024\000U\000\157\000\213\000\226\001\166\005\231\006\218\000\221\002\160\003+\005\233\005\243\002\149\006p\000\213\000\221\002\172\003\022\003\242\0007\006G\005\254\006q\000Q\000\160\000\221\000U\000V\000\233\002\234\0007\003\024\000U\001F\001E\001G\006j\005\255\002\230\002\231\002\004\006\129\003\031\002\185\000\163\001<\002\183\001\180\006\130\000U\007\025\007\026\000\224\003\006\007\028\001b\006*\006m\000\227\001h\003\025\003\007\000X\006\131\001Y\000X\006n\007\030\003\026\005S\001\162\003\027\000Q\006u\003\020\000U\001\243\000\175\006w\007\023\000\180\003\024\000U\001<\000\207\001\\\006,\003\243\000X\006y\000\213\000\226\003\025\001 \003#\006o\001Q\001E\001G\002\181\003)\006-\001\162\003\027\001\142\006z\006/\000\207\000X\002\184\0063\003\235\005g\000\213\000\226\000\207\001#\003k\002\004\002\003\002\004\000\213\000\226\003+\000\221\000\207\005U\005\195\001\003\006p\0061\000\213\000\226\003\022\001k\001E\001G\001\001\006q\002\005\002\020\001\142\002\007\002\b\001\127\002\234\000\227\003\024\000U\004\179\006j\000\224\002\230\002\231\002\004\007-\001\155\006\129\003\031\000U\002\181\007!\004(\000\221\001\131\007%\000\222\003\006\007&\000\227\004V\006m\001\137\001!\003s\003\007\004Z\000\227\001\028\006\131\006n\007.\002\021\002}\002\022\002\209\004\154\000\227\003\020\006u\000\224\005V\000X\002\144\006w\003/\001!\002\148\004\253\000\213\004\202\000X\006\238\001\148\000\238\006y\004\235\007\002\003\025\006o\003#\005\015\001\178\002\028\000\236\004\230\003)\002\182\001\162\003\027\000\175\006z\001\134\001\175\000\207\002\r\004Y\001\173\000U\001\162\000\213\000\226\004Y\000\232\001\155\007\003\004+\000U\000\221\003+\002\149\005\202\000X\006p\001\179\002\144\002\172\003\022\005U\002\148\004\183\000\213\006q\001\030\004Y\002\150\000\221\006Q\001<\002\234\001\183\003\024\000U\000\207\006j\000\224\002\230\002\231\002\004\000\213\000\226\006\129\003\031\002\173\0072\006\140\002\183\000\221\002\182\000U\000\222\003\006\006k\006\136\006S\006m\000\227\000Q\002\030\003\007\000U\000V\002\149\006\131\006n\006|\002\031\001\192\001\162\002\011\006U\002\172\003\020\006u\000\224\006\239\001-\001\162\006w\001s\001E\001G\000\175\000\236\002\129\001\175\001<\000X\000\252\006y\006*\002\172\003\025\006o\003#\000\227\006V\001\142\002\243\004\208\003)\002\183\001\162\003\027\000U\006z\000\207\001\198\000\207\002\184\001@\001\142\000\213\000\216\000\213\000\226\002\181\000\232\004I\001\142\006,\002\183\000\236\003+\000U\001\006\000\207\006p\0007\001B\001\142\003\022\000\213\000\226\001\142\006-\006q\001x\001E\001G\006/\001^\001\145\002\234\0060\003\024\000U\000\207\006j\005\168\002\230\002\231\002\004\000\213\000\226\006\129\003\031\000Q\004^\001_\000U\000V\006\130\007%\002\184\003\006\007&\006\139\000Q\006m\000\227\000U\000V\003\007\000X\005\170\004\161\006\131\006n\007)\0010\004g\005\002\006W\002\184\001\211\003\020\006u\000\227\005D\006*\005\172\006w\000X\005\222\000Q\001\215\000\236\000U\000V\005J\006*\000\252\006y\005[\000X\003\025\006o\003#\000\227\006S\005\173\001i\0014\003)\001U\001\162\003\027\001\228\006z\006,\005\007\005\223\006\170\005\224\001\231\006U\005,\006*\000\221\001\132\006,\003\246\000\213\002\182\006-\000\236\003+\004Y\001\006\006/\006p\000\207\001\181\006:\003\022\006-\001\161\000\213\000\226\006q\006/\006V\005\225\002\000\006J\002\143\002\234\006,\003\024\000U\0007\006j\001\236\002\230\002\231\002\004\002\143\001\174\006\129\003\031\002\143\007,\006-\001\142\002\172\000X\004Y\006/\003\006\006k\001\193\006\\\006m\0050\003\174\005\226\003\007\000U\001\243\000\213\006\131\006n\006\144\000X\005\227\005\228\005\222\005\229\001\142\003\020\006u\004Q\001\196\005\n\002\183\006w\000\221\000U\000Q\000\222\000X\000U\001\243\001\199\001\142\001\142\006y\002J\002\004\003\025\006o\003#\006\002\003\191\005\223\006\001\005\224\003)\000\207\001\162\003\027\000X\006z\000\224\000\213\000\226\001\155\003\\\002\020\000U\002\007\002\b\000\207\005|\000X\001\239\005\231\003\235\000\213\000\226\003+\005\233\005\243\000\207\006p\005\225\001\212\001\221\003\022\000\213\000\226\001\249\005\254\006q\001\142\002A\000X\002\184\004\134\002\172\002\234\000\221\003\024\000U\005\019\002\004\000\232\000X\005\255\003a\003m\003n\006\129\003\031\005\160\004\173\001\224\001\252\005\226\006\147\000\227\005\030\001_\002\230\002\231\002\004\004U\005\227\005\228\002\183\005\229\002?\000U\002\018\006\131\001\142\000\207\005 \003\006\001\162\001\005\002\028\000\213\000\226\006u\000\221\003\007\001[\005\199\006w\000X\000X\006\187\002\r\002\181\006\002\000U\002\027\000Q\003\020\006y\000U\000V\003\025\004\211\003#\006\024\002\230\002\231\002\004\002$\003)\000\224\001\162\003\027\001\229\006z\001\142\006K\005\231\000X\005\154\003\006\002}\005\233\005\243\002\168\002\172\003q\004\133\003\007\000\252\002\184\002\144\003+\005\254\003\218\002\148\000\227\000\213\005>\000\207\006\003\003\020\002\172\006\143\000\213\000\213\000\226\001\232\002#\005\255\000\140\001\142\005\014\005\201\002\030\002\183\003\022\001\142\000U\002\230\002\231\002\004\002\031\000\236\001\162\002\011\001\006\002E\002\234\006\142\003\024\000U\002\183\005O\003\006\000U\000U\000X\002\149\006%\003\028\003\031\003\007\000\207\006\165\005\176\001\142\005\174\006\246\000\213\005\204\000\207\002P\002\150\000\140\003\020\001\237\000\213\000\216\001\253\003\022\000\227\003 \000\175\002U\005\236\001\175\002\230\002\231\002\004\002\182\000X\002\234\005\170\003\024\000U\002\019\000\175\002\184\005\246\001\175\005\184\003\006\002o\003\028\003\031\0061\004\248\004\023\005\172\003\007\003\025\006\248\003#\004r\002\184\006\201\002}\002c\003)\002\166\001\162\003\027\003\020\002q\005\205\003 \002\144\002x\005\173\002`\002\148\005\154\000\213\003\022\002f\006\175\005\152\002\198\005\210\000X\005\207\003+\000X\002\201\005\147\002\234\005\142\003\024\000U\000U\001\142\000\236\001\142\002\172\003\025\004c\003#\003\028\003\031\000X\005_\001_\003)\000\207\001\162\003\027\000X\005\154\002}\000\213\000\226\002~\004G\002\149\002\204\002\230\002\231\002\004\002\144\003 \006\182\003\022\002\148\002\183\000\213\003+\000U\000X\002\150\002\207\003\006\000X\002n\002\234\005\156\003\024\000U\000U\003\007\002\213\006 \000X\001\005\000U\006\194\003\028\003\031\000X\003\025\002\221\003#\003\020\002\226\002\230\002\231\002\004\003)\002\242\001\162\003\027\004\254\001\142\005\003\002t\000\207\002\149\003\000\003 \003\006\002z\000\213\000\216\002\230\002\231\002\004\002\135\003\007\000\207\000X\003+\002\150\003[\006\191\000\213\000\216\002\137\002\184\003\006\004H\003\020\004N\002\147\002\164\000X\004]\003\007\003\025\004`\003#\004?\004d\004\139\004\164\000X\003)\004\192\001\162\003\027\003\020\0068\003\022\004;\000U\000X\004\243\002\197\000X\002\230\002\231\002\004\004\250\000X\002\234\002\200\003\024\000U\005\151\003+\001\142\001\142\000X\005\b\003\006\002}\003\028\003\031\002\142\002\203\005\152\005\151\003\007\000\221\005\159\002\144\000\222\000X\004\136\002\148\003\022\000\213\005\000\005\152\000X\003\020\000X\005\153\003 \005\r\000X\002\206\002\234\000X\003\024\000U\000X\002\212\000X\003\022\000\224\000X\001\142\005\018\003\028\003\031\002\230\002\231\002\004\002\216\000X\002\234\002\220\003\024\000U\002\225\000X\003\025\002\241\003#\002\255\003\006\002\149\003\028\003\031\003)\003 \001\162\003\027\003\007\005\026\005\"\003u\000\207\003t\004q\005\029\002\150\003(\000\213\000\216\003l\003\020\000\232\003\022\003 \000X\001\142\003+\003\229\005!\003\244\001\142\000X\005$\003\025\002\234\003#\003\024\000U\002\230\002\231\002\004\003)\004\001\001\162\003\027\000X\003\028\003\031\005+\004\012\005%\000\207\003\025\003\006\003#\005/\004\020\000\213\000\226\004=\003)\003\007\001\162\003\027\003+\0055\002}\004h\003 \002\152\005;\001\142\005F\005\151\003\020\004M\002\144\004O\000X\003\022\002\148\001\142\000\213\003+\004\\\005\152\002\230\002\231\002\004\005\158\001\142\002\234\000X\003\024\000U\005-\000X\003\025\001\142\003#\0051\003\006\005Y\003\028\003\031\003)\000\252\001\162\003\027\003\007\004_\005^\000X\000\227\001\142\004F\002\230\002\231\002\004\000X\000\207\001\142\003\020\002\149\005c\003 \000\213\000\216\003+\000X\001\142\003\006\001\142\003\022\000X\005m\000X\001\142\002\150\003\007\000\236\005?\004e\000\253\004w\002\234\004\165\003\024\000U\004A\005\222\005P\003\020\005s\003\025\004\169\003#\003\028\003\031\004\187\005T\004\193\003)\004\197\001\162\003\027\000X\005~\005\135\004\225\004\249\004\242\004\244\002}\000\221\000X\002\154\000\222\005\223\003 \005\224\003\022\005\151\002\144\005\167\003+\004\247\002\148\000X\000\213\001\142\005\171\005\006\002\234\005\152\003\024\000U\004\252\005\183\000X\005\211\000\224\005\219\005\005\005\001\003\028\003\031\005\232\003\025\005\225\003#\003\022\005\137\001\142\005\155\005\004\003)\000X\001\162\003\027\005\012\005\141\005\017\002\234\005\025\003\024\000U\003 \005\162\005\178\002\149\000X\002\230\002\231\002\004\003\028\003\031\005\188\005\213\003+\006\242\005\235\005\226\005\245\000\232\002\150\006\006\003\006\002\230\002\231\002\004\005\227\005\228\001\142\005\229\003\007\003\025\003 \003#\002}\005\240\0042\002\179\003\006\003)\005\024\001\162\003\027\003\020\002\144\006\012\003\007\005\028\002\148\000\207\000\213\000X\004,\000X\006\000\000\213\000\226\005#\005\251\003\020\000X\003\025\003+\003\130\002\230\002\231\002\004\000X\000X\003)\006\015\001\162\003\027\005.\005*\006I\000X\000X\005\231\003\006\000X\006\020\000X\005\233\005\243\000X\001\142\003\007\006;\005:\006\025\002\149\003+\004!\005\254\001\142\0067\006\031\006\017\006'\003\020\0054\003\022\006N\000\252\001\142\002\150\0056\001\142\000X\005\255\000\227\005M\005A\002\234\006\243\003\024\000U\003\022\005L\001\142\002\230\002\231\002\004\005G\005K\003\028\003\031\006b\005X\002\234\005]\003\024\000U\000X\005\187\003\006\002}\000\236\000X\002\245\001\006\003\028\003\031\003\007\000X\006\141\002\144\003 \001\142\004\017\002\148\000X\000\213\000X\005b\006\028\003\020\006\181\003\022\000X\000X\001\142\000X\003 \006>\002}\000X\005e\004S\005i\002\234\005q\003\024\000U\006H\002\144\003\025\006L\003#\002\148\005x\000\213\003\028\003\031\003)\002}\001\162\003\027\004\145\006P\005\131\000X\003\025\002\149\003#\002\144\002\230\002\231\002\004\002\148\003)\000\213\001\162\003\027\003 \005\186\001\142\003+\002\150\000X\002}\003\006\005\179\004\148\001\142\003\022\005\180\001\142\006T\003\007\002\144\000X\002\149\003+\002\148\004\006\000\213\002\234\005\185\003\024\000U\006`\003\020\003\025\001\142\003#\005\189\002\150\001\142\003\028\003\031\003)\002\149\001\162\003\027\002\230\002\231\002\004\001\142\001\142\002\230\002\231\002\004\001\142\005\190\005\221\005\214\002\150\005\215\005\220\003\006\003 \005\242\005\238\003+\003\006\005\239\002\149\003\007\005\241\005\253\005\250\000\221\003\007\003\254\000\222\006g\005\252\006\005\003\207\006\007\003\020\002\150\006\b\006v\006\r\003\020\006}\006\026\0062\003\025\003\022\003#\006<\002\230\002\231\002\004\006i\003)\000\224\001\162\003\027\006c\002\234\006\145\003\024\000U\006d\006\164\003\006\002}\006h\006x\004\151\006\153\003\028\003\031\003\007\007\031\007*\002\144\003+\006\163\007/\002\148\006\167\000\213\003\199\006\180\006\189\003\020\007\017\000\000\002}\000\000\000\000\004\246\003 \000\000\000\000\003\022\000\000\000\232\002\144\000\000\003\022\000\000\002\148\000\000\000\213\000\000\000\000\002\234\000\000\003\024\000U\000\000\002\234\000\000\003\024\000U\000\000\000\000\000\000\003\028\003\031\003\025\002\149\003#\003\028\003\031\000\000\000\207\000\000\003)\000\000\001\162\003\027\000\213\000\226\000\000\000\000\002\150\002\230\002\231\002\004\003 \000\000\000\000\003\022\002\149\003 \000\000\000\000\000\000\000\000\000\000\003+\003\006\000\000\000\000\002\234\000\000\003\024\000U\002\150\003\007\000\000\000\000\002\230\002\231\002\004\003\018\003\028\003\031\003\025\000\000\003#\000\000\003\020\003\025\000\000\003#\003)\003\006\001\162\003\027\000\239\003)\000\000\001\162\003\027\003\007\000\000\000\227\003 \000\000\000\000\003\030\000\000\000\000\000\000\000\000\000\000\000\000\003\020\003+\002\230\002\231\002\004\000\000\003+\000\221\002}\000\000\000\222\0058\000\000\000\000\000\000\000\000\000\236\003\006\002\144\003\025\000\000\003\130\002\148\000\000\000\213\003\007\000\000\003)\000\000\001\162\003\027\003\"\000\000\003\022\000\224\000\000\000\000\000\000\003\020\000\000\002\230\002\231\002\004\000\000\000\000\002\234\000\000\003\024\000U\000\000\003+\000\000\000\000\000\000\000\000\003\006\000\000\003\028\003\031\003\022\000\000\000\000\000\000\003\007\000\000\002\149\002\230\002\231\002\004\0031\000\000\002\234\000\000\003\024\000U\000\000\003\020\000\232\000\000\003 \002\150\003\006\000\000\003\028\003\031\000\000\000\000\000\000\000\000\003\007\000\000\000\000\000\000\000\000\000\000\0030\000\000\003\022\000\221\000\000\000\000\000\222\003\020\000\000\000\000\003 \000\000\000\207\003\025\002\234\003#\003\024\000U\000\213\000\226\000\000\003)\000\000\001\162\003\027\000\000\003\028\003\031\000\000\000\000\000\224\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\250\003\025\003\022\003#\000\000\000\000\003+\000\000\000\000\003)\003 \001\162\003\027\000\000\002\234\000\000\003\024\000U\000\000\000\000\000\000\000\000\002\230\002\231\002\004\000\000\003\028\003\031\003\022\000\252\000\000\000\000\003+\000\000\000\000\000\232\000\227\003\006\000\000\003\025\002\234\003#\003\024\000U\000\000\003\007\000\000\003)\003 \001\162\003\027\003`\003\028\003\031\000\000\000\000\000\000\000\000\003\020\000\000\002\230\002\231\002\004\000\236\000\000\000\207\001\026\000\000\000\000\000\000\003+\000\213\000\226\000\000\003 \003\006\000\000\003\025\000\000\003#\000\000\000\000\000\000\003\007\000\000\003)\000\000\001\162\003\027\003c\000\000\000\221\000\000\000\000\000\222\000\000\003\020\000\000\000\000\000\000\000\000\000\000\000\000\003\025\000\000\003#\000\000\000\000\003+\000\000\000\000\003)\000\000\001\162\003\027\000\000\000\000\003\022\000\224\000\000\000\252\000\000\000\000\000\000\002\230\002\231\002\004\000\227\004\202\002\234\000\000\003\024\000U\000\000\003+\000\000\000\000\000\000\000\000\003\006\000\000\003\028\003\031\005\134\000\000\000\000\000\000\003\007\002}\000\000\000\000\005C\000\000\003x\000\236\003\022\000\000\001\002\002\144\000\000\003\020\000\232\002\148\003 \000\213\000\000\000\000\002\234\000\000\003\024\000U\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\028\003\031\002\230\002\231\002\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\207\003\025\000\000\003#\000\000\003\006\000\213\000\226\000\000\003)\003 \001\162\003\027\003\007\002\149\000\000\000\000\000\000\000\000\003{\000\000\000\000\000\000\002\230\002\231\002\004\003\020\000\000\003\022\002\150\000\000\000\000\003+\000\000\000\000\000\000\000\000\000\000\003\006\003\025\002\234\003#\003\024\000U\000\000\000\000\003\007\003)\000\000\001\162\003\027\000\000\003\028\003\031\000\000\000\252\003\128\000\000\000\000\003\020\000\000\000\000\000\227\000\000\000\000\000\000\004\208\000\000\002}\000\000\003+\005I\000\000\000\000\003 \000\000\000\000\000\000\002\144\002\230\002\231\002\004\002\148\000\000\000\213\003\022\000\000\000\000\000\000\000\236\000\000\000\000\001\006\000\000\003\006\000\000\000\000\002\234\000\000\003\024\000U\000\000\003\007\003\025\000\000\003#\000\000\000\000\000\000\003\028\003\031\003)\003\132\001\162\003\027\003\020\000\000\000\000\003\022\000\000\000\000\002\230\002\231\002\004\000\000\002\149\000\000\000\000\000\000\000\000\002\234\003 \003\024\000U\003+\000\000\003\006\000\000\000\000\000\000\002\150\000\000\003\028\003\031\003\007\002}\000\000\000\000\005R\000\000\000\000\000\000\000\000\000\000\003\134\002\144\000\000\003\020\000\000\002\148\003\025\000\213\003#\000\000\003 \000\000\002}\000\000\003)\005Z\001\162\003\027\000\000\000\000\003\022\000\000\002\144\002\230\002\231\002\004\002\148\000\000\000\213\000\000\000\000\000\000\002\234\000\000\003\024\000U\000\000\003+\003\006\003\025\000\000\003\130\000\000\000\000\003\028\003\031\003\007\003)\002\149\001\162\003\027\000\000\000\000\000\000\000\000\000\221\003\137\000\000\000\222\003\020\000\000\000\000\003\022\002\150\000\000\000\221\003 \000\000\000\222\002\149\003+\000\000\000\000\000\000\002\234\000\000\003\024\000U\002\230\002\231\002\004\000\000\000\224\000\000\002\150\000\000\003\028\003\031\000\000\000\000\000\000\000\000\000\224\003\006\000\000\003\025\000\000\003\130\000\000\000\000\000\000\003\007\001\022\003)\000\000\001\162\003\027\000\000\003 \000\000\000\000\003\144\000\000\000\000\003\020\000\000\001\027\000\000\003\022\000\000\000\000\002\230\002\231\002\004\000\000\000\232\003+\000\000\000\000\000\000\002\234\000\000\003\024\000U\000\000\000\232\003\006\003\025\000\000\003\130\000\000\000\000\003\028\003\031\003\007\003)\000\000\001\162\003\027\000\000\000\000\000\000\000\000\000\000\003\149\000\207\000\000\003\020\000\000\000\000\000\000\000\213\000\226\000\000\003 \000\207\000\000\000\000\003+\000\000\000\000\000\213\000\226\003\022\000\000\000\000\002\230\002\231\002\004\000\000\002}\000\221\000\000\006\185\000\222\002\234\000\000\003\024\000U\000\000\002\144\003\006\000\000\003\025\002\148\003\130\000\213\003\028\003\031\003\007\000\000\003)\000\000\001\162\003\027\000\000\000\000\000\000\000\224\003\154\000\235\000\000\003\020\000\000\000\000\000\000\003\022\000\227\000\000\003 \000\252\000\000\000\000\000\000\003+\000\000\000\000\000\227\002\234\000\000\003\024\000U\002\230\002\231\002\004\000\000\000\000\002\149\000\000\000\000\003\028\003\031\000\000\000\000\000\236\000\000\000\000\003\006\003\025\000\000\003\130\000\232\002\150\000\000\000\236\003\007\003)\001$\001\162\003\027\000\000\003\160\003 \000\000\000\000\000\000\000\000\000\000\003\020\000\000\000\000\003\022\000\000\000\000\002\230\002\231\002\004\000\000\000\000\003+\000\000\000\207\000\000\002\234\000\000\003\024\000U\000\213\000\226\003\006\000\000\003\025\000\000\003\130\000\000\003\028\003\031\003\007\000\000\003)\000\000\001\162\003\027\003\165\000\000\000\000\000\000\000\000\000\000\000\000\003\020\000\000\000\000\000\000\000\000\000\000\000\000\003 \000\000\000\000\000\000\000\000\003+\000\000\000\000\000\000\000\000\003\022\000\000\000\000\002\230\002\231\002\004\000\000\000\000\000\000\001*\000\000\000\000\002\234\000\000\003\024\000U\000\227\000\000\003\006\003\025\000\000\003\130\000\000\000\000\003\028\003\031\003\007\003)\000\000\001\162\003\027\000\000\003\170\000\000\000\000\000\000\002\230\002\231\002\004\003\020\000\000\000\000\003\022\000\236\000\000\000\000\003 \000\000\000\000\000\000\003+\003\006\000\000\000\000\002\234\000\000\003\024\000U\000\000\003\007\000\000\000\000\000\000\000\000\000\000\000\000\003\028\003\031\000\000\003\177\000\000\000\000\003\020\000\000\000\000\003\025\000\000\003#\000\000\000\000\000\000\000\000\000\000\003)\000\000\001\162\003\027\000\000\003 \000\000\000\000\000\000\000\000\002\230\002\231\002\004\000\000\000\000\003\022\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003+\000\000\003\006\000\000\002\234\000\000\003\024\000U\000\000\000\000\003\007\003\025\000\000\003#\000\000\000\000\003\028\003\031\000\000\003)\003\182\001\162\003\027\003\020\000\000\003\022\000\000\000\000\002\230\002\231\002\004\000\000\002\230\002\231\002\004\000\000\000\000\002\234\003 \003\024\000U\000\000\003+\003\006\000\000\000\000\000\000\003\006\000\000\003\028\003\031\003\007\000\000\000\000\000\000\003\007\000\000\000\000\000\000\000\000\000\000\003\187\000\000\000\000\003\020\003\202\000\000\003\025\003\020\003#\000\000\003 \000\000\000\000\000\000\003)\000\000\001\162\003\027\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\234\000\000\003\024\000U\003+\000\000\003\025\000\000\003\130\000\000\000\000\000\000\003\028\003\031\003)\000\000\001\162\003\027\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\022\000\000\000\000\000\000\003\022\003 \000\000\000\000\003+\000\000\000\000\000\000\002\234\000\000\003\024\000U\002\234\000\000\003\024\000U\002\230\002\231\002\004\000\000\003\028\003\031\000\000\000\000\003\028\003\031\000\000\000\000\000\000\000\000\003\025\003\006\003\130\002\230\002\231\002\004\000\000\000\000\003)\003\007\001\162\003\027\003 \000\000\000\000\000\000\003 \000\000\003\006\003\205\000\000\000\000\003\020\000\000\000\000\000\000\003\007\000\000\000\000\000\000\000\000\003+\003\210\000\000\000\000\000\000\000\000\000\000\000\000\003\020\000\000\003\025\000\000\003\130\000\000\003\025\000\000\003\130\000\000\003)\000\000\001\162\003\027\003)\000\000\001\162\003\027\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006j\000\000\003+\000\000\000\000\000\000\003+\000\000\000\000\000\000\000\000\003\022\000\000\000\000\000\000\007%\000\000\000\000\007&\000\000\000\000\006m\000\000\002\234\000\000\003\024\000U\000\000\003\022\000\000\006n\002\230\002\231\002\004\000\000\003\028\003\031\000\000\000\000\000\000\002\234\000\000\003\024\000U\000\000\000\000\003\006\002\230\002\231\002\004\000\000\000\000\003\028\003\031\003\007\000\000\000\000\003 \000\000\006o\003\213\000\000\003\006\000\000\002\230\002\231\002\004\003\020\000\000\000\000\003\007\000\000\000\000\000\000\003 \000\000\000\000\006j\000\000\000\000\003\222\000\000\000\000\003\020\000\000\000\000\003\025\0047\003\130\000\000\000\000\000\000\000\000\006p\003)\006k\001\162\003\027\006m\000\000\000\000\000\000\006q\003\025\000\000\003#\000\000\006n\000\000\000\000\000\000\003)\000\000\001\162\003\027\000\000\000\000\003+\000\000\000\000\000\000\006r\003\031\000\000\007(\000\000\003\022\000\000\000\000\002\230\002\231\002\004\000\000\000\000\003+\000\000\006o\000\000\002\234\000\000\003\024\000U\003\022\006t\000\000\002\230\002\231\002\004\000\000\000\000\003\028\003\031\0044\006u\002\234\000\000\003\024\000U\006w\002\233\003\006\002\230\002\231\002\004\000\000\000\000\003\028\003\031\003\007\006y\006p\002\234\003 \003\024\000U\000\000\003\006\000\000\003\226\006q\000\000\003\020\000\000\000\000\003\007\006z\000\000\000\000\003 \000\000\004\002\000\000\006j\000\000\000\000\000\000\000\000\003\020\006r\003\031\000\000\003\025\000\000\003#\000\000\006s\000\000\007%\000\000\003)\007&\001\162\003\027\006m\000\000\000\000\000\000\003\025\000\000\003\130\006t\000\000\006n\000\000\002\233\003)\000\000\001\162\003\027\000\000\006u\000\000\003+\000\000\003\025\006w\002\234\000\000\003\024\000U\003\022\000\000\003\026\000\000\001\162\003\027\006y\000\000\003+\000\000\000\000\006o\002\234\000\000\003\024\000U\003\022\000\000\000\000\002\230\002\231\002\004\006z\000\000\003\028\003\031\000\000\000\000\002\234\000\000\003\024\000U\000\000\000\000\003\006\002\230\002\231\002\004\000\000\000\000\003\028\003\031\003\007\000\000\000\000\006p\003 \000\000\004\004\000\000\003\006\000\000\000\000\000\000\006q\003\020\000\000\000\000\003\007\003\025\000\000\000\000\003 \000\000\004\b\000\000\006j\003\026\000\000\001\162\003\027\003\020\000\000\006r\003\031\003\025\007'\003\130\000\000\000\000\000\000\007%\000\000\003)\007&\001\162\003\027\006m\000\000\000\000\000\000\003\025\000\000\003#\000\000\006t\006n\000\000\000\000\003)\000\000\001\162\003\027\000\000\000\000\006u\003+\000\000\000\000\000\000\006w\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\000\000\000\000\006y\003+\000\000\000\000\006o\002\234\000\000\003\024\000U\003\022\000\000\000\000\002\230\002\231\002\004\000\000\006z\003\028\003\031\000\000\000\000\002\234\000\000\003\024\000U\000\000\000\000\003\006\002\230\002\231\002\004\000\000\000\000\003\028\003\031\003\007\000\000\000\000\006p\003 \000\000\004\011\000\000\003\006\000\000\000\000\000\000\006q\003\020\000\000\000\000\003\007\000\000\000\000\000\000\003 \000\000\004\r\000\000\006j\000\000\000\000\000\000\000\000\003\020\000\000\006r\003\031\003\025\007+\003#\000\000\000\000\000\000\007%\000\000\003)\007&\001\162\003\027\006m\000\000\000\000\000\000\003\025\000\000\003#\000\000\006t\006n\000\000\000\000\003)\000\000\001\162\003\027\000\000\000\000\006u\003+\000\000\000\000\000\000\006w\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\000\000\000\000\006y\003+\000\000\000\000\006o\002\234\000\000\003\024\000U\003\022\000\000\000\000\002\230\002\231\002\004\000\000\006z\003\028\003\031\000\000\000\000\002\234\000\000\003\024\000U\000\000\000\000\003\006\002\230\002\231\002\004\000\000\000\000\003\028\003\031\003\007\000\000\000\000\006p\003 \000\000\004\015\000\000\003\006\000\000\000\000\000\000\006q\003\020\000\000\000\000\003\007\000\000\000\000\000\000\003 \000\000\004\025\000\000\006j\000\000\000\000\000\000\000\000\003\020\000\000\006r\003\031\003\025\0070\003#\000\000\000\000\000\000\000\000\000\000\003)\006k\001\162\003\027\006m\000\000\000\000\000\000\003\025\000\000\003#\000\000\006t\006n\000\000\000\000\003)\000\000\001\162\003\027\000\000\000\000\006u\003+\000\000\000\000\000\000\006w\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\000\000\000\000\006y\003+\000\000\000\000\006o\002\234\000\000\003\024\000U\003\022\000\000\000\000\002\230\002\231\002\004\000\000\006z\003\028\003\031\000\000\000\000\002\234\000\000\003\024\000U\000\000\000\000\003\006\002\230\002\231\002\004\000\000\000\000\003\028\003\031\003\007\000\000\000\000\006p\003 \000\000\004#\000\000\003\006\000\000\000\000\000\000\006q\003\020\000\000\000\000\003\007\000\000\000\000\000\000\003 \000\000\004&\000\000\006j\000\000\000\000\000\000\000\000\003\020\000\000\006r\003\031\003\025\000\000\003#\000\000\000\000\006~\000\000\000\000\003)\006k\001\162\003\027\006m\000\000\000\000\000\000\003\025\000\000\003#\000\000\006t\006n\000\000\000\000\003)\000\000\001\162\003\027\000\000\000\000\006u\003+\000\000\000\000\000\000\006w\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\000\000\000\000\006y\003+\000\000\000\000\006o\002\234\000\000\003\024\000U\003\022\000\000\000\000\002\230\002\231\002\004\000\000\006z\003\028\003\031\000\000\000\000\002\234\000\000\003\024\000U\000\000\000\000\003\006\002\230\002\231\002\004\000\000\000\000\003\028\003\031\003\007\000\000\000\000\006p\003 \000\000\004K\000\000\003\006\000\000\000\000\000\000\006q\003\020\000\000\000\000\003\007\000\000\000\000\000\000\003 \000\000\004X\000\000\005\222\000\000\000\000\000\000\000\000\003\020\000\000\006r\003\031\003\025\000\000\003#\000\000\000\000\006\146\000\000\000\000\003)\000\000\001\162\003\027\000\000\000\000\000\000\000\000\003\025\000\000\003#\005\223\006t\005\224\000\000\000\000\003)\000\000\001\162\003\027\000\000\000\000\006u\003+\000\000\000\000\000\000\006w\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\000\000\000\000\006y\003+\000\000\000\000\005\225\002\234\000\000\003\024\000U\003\022\000\000\000\000\002\230\002\231\002\004\000\000\006z\003\028\003\031\000\000\000\000\002\234\000\000\003\024\000U\000\000\000\000\003\006\002\230\002\231\002\004\000\000\000\000\003\028\003\031\003\007\000\000\005\226\000\000\003 \000\000\004b\000\000\003\006\000\000\000\000\005\227\005\228\003\020\005\229\000\000\003\007\000\000\000\000\000\000\003 \000\000\004k\000\000\000\000\000\000\000\000\000\000\000\000\003\020\000\000\000\000\000\000\003\025\000\000\003#\000\000\000\000\000\000\005\230\000\000\003)\000\000\001\162\003\027\000\000\000\000\000\000\000\000\003\025\000\000\003#\000\000\000\000\000\000\000\000\000\000\003)\000\000\001\162\003\027\000\000\000\000\005\231\003+\000\000\000\000\000\000\005\233\005\243\000\000\000\000\003\022\000\000\000\000\002\230\002\231\002\004\000\000\005\254\003+\000\000\000\000\000\000\002\234\000\000\003\024\000U\003\022\000\000\000\000\002\230\002\231\002\004\000\000\005\255\003\028\003\031\002\232\000\000\002\234\000\000\003\024\000U\000\000\000\000\003\006\002\230\002\231\002\004\000\000\000\000\003\028\003\031\003\007\000\000\000\000\000\000\003 \000\000\004{\000\000\003\006\000\000\000\000\000\000\000\000\003\020\000\000\000\000\003\007\000\000\000\000\000\000\003 \000\000\004\128\000\000\000\000\000\000\000\000\000\000\000\000\003\020\000\000\000\000\000\000\003\025\000\000\003#\000\000\000\000\000\000\000\000\000\000\003)\000\000\001\162\003\027\000\000\000\000\000\000\000\000\003\025\000\000\003#\000\000\000\000\000\000\000\000\002\233\003)\000\000\001\162\003\027\000\000\000\000\000\000\003+\000\000\000\000\000\000\002\234\000\000\003\024\000U\003\022\000\000\000\000\002\230\002\231\002\004\000\000\000\000\003+\000\000\000\000\000\000\002\234\000\000\003\024\000U\003\022\000\000\000\000\002\230\002\231\002\004\000\000\000\000\003\028\003\031\003\001\000\000\002\234\000\000\003\024\000U\000\000\000\000\003\006\002\230\002\231\002\004\000\000\000\000\003\028\003\031\003\007\000\000\000\000\000\000\003 \000\000\004\131\000\000\003\006\000\000\000\000\000\000\000\000\003\020\000\000\000\000\003\007\003\025\000\000\000\000\003 \000\000\004\168\000\000\000\000\003\026\000\000\001\162\003\027\003\020\000\000\000\000\000\000\003\025\000\000\003#\000\000\000\000\000\000\000\000\000\000\003)\000\000\001\162\003\027\000\000\000\000\000\000\000\000\003\025\000\000\003#\000\000\000\000\000\000\000\000\002\233\003)\000\000\001\162\003\027\000\000\000\000\000\000\003+\000\000\000\000\000\000\002\234\000\000\003\024\000U\003\022\000\000\000\000\002\230\002\231\002\004\000\000\000\000\003+\000\000\000\000\000\000\002\234\000\000\003\024\000U\003\022\000\000\000\000\002\230\002\231\002\004\000\000\000\000\003\028\003\031\003\003\000\000\002\234\000\000\003\024\000U\000\000\000\000\003\006\002\230\002\231\002\004\000\000\000\000\003\028\003\031\003\007\000\000\000\000\000\000\003 \000\000\004\171\000\000\003\006\000\000\000\000\000\000\000\000\003\020\000\000\000\000\003\007\003\025\000\000\000\000\003 \000\000\004\186\000\000\000\000\003\026\000\000\001\162\003\027\003\020\000\000\000\000\000\000\003\025\000\000\003#\000\000\000\000\000\000\000\000\000\000\003)\000\000\001\162\003\027\000\000\000\000\000\000\000\000\003\025\000\000\003#\000\000\000\000\000\000\000\000\002\233\003)\000\000\001\162\003\027\000\000\000\000\000\000\003+\000\000\000\000\000\000\002\234\000\000\003\024\000U\003\022\000\000\000\000\002\230\002\231\002\004\000\000\000\000\003+\000\000\000\000\000\000\002\234\000\000\003\024\000U\003\022\000\000\000\000\002\230\002\231\002\004\000\000\000\000\003\028\003\031\003\r\000\000\002\234\000\000\003\024\000U\000\000\000\000\003\006\002\230\002\231\002\004\000\000\000\000\003\028\003\031\003\007\000\000\000\000\000\000\003 \000\000\004\189\000\000\003\006\000\000\000\000\000\000\000\000\003\020\000\000\000\000\003\007\003\025\000\000\000\000\003 \000\000\004\201\000\000\000\000\003\026\000\000\001\162\003\027\003\020\000\000\000\000\000\000\003\025\000\000\003#\000\000\000\000\000\000\000\000\000\000\003)\000\000\001\162\003\027\000\000\000\000\000\000\000\000\003\025\000\000\003#\000\000\000\000\000\000\000\000\002\233\003)\000\000\001\162\003\027\000\000\000\000\000\000\003+\000\000\000\000\000\000\002\234\000\000\003\024\000U\003\022\000\000\000\000\002\230\002\231\002\004\000\000\000\000\003+\000\000\000\000\000\000\002\234\000\000\003\024\000U\003\022\000\000\000\000\002\230\002\231\002\004\000\000\000\000\003\028\003\031\003\023\000\000\002\234\000\000\003\024\000U\000\000\000\000\003\006\002\230\002\231\002\004\000\000\000\000\003\028\003\031\003\007\000\000\000\000\000\000\003 \000\000\004\207\000\000\003\006\000\000\000\000\000\000\000\000\003\020\000\000\000\000\003\007\003\025\000\000\000\000\003 \000\000\004\229\000\000\000\000\003\026\000\000\001\162\003\027\003\020\000\000\000\000\000\000\003\025\000\000\003#\000\000\000\000\000\000\000\000\000\000\003)\000\000\001\162\003\027\000\000\000\000\000\000\000\000\003\025\000\000\003#\000\000\000\000\000\000\000\000\002\233\003)\000\000\001\162\003\027\000\000\000\000\000\000\003+\000\000\000\000\000\000\002\234\000\000\003\024\000U\003\022\000\000\000\000\002\230\002\231\002\004\000\000\000\000\003+\000\000\000\000\000\000\002\234\000\000\003\024\000U\003\022\000\000\000\000\002\230\002\231\002\004\000\000\000\000\003\028\003\031\003*\000\000\002\234\000\000\003\024\000U\000\000\000\000\003\006\002\230\002\231\002\004\000\000\000\000\003\028\003\031\003\007\000\000\000\000\000\000\003 \000\000\004\232\000\000\003\006\000\000\000\000\000\000\000\000\003\020\000\000\000\000\003\007\003\025\000\000\000\000\003 \000\000\004\239\000\000\000\000\003\026\000\000\001\162\003\027\003\020\000\000\000\000\000\000\003\025\000\000\003#\000\000\000\000\000\000\000\000\000\000\003)\000\000\001\162\003\027\000\000\000\000\000\000\000\000\003\025\000\000\003#\000\000\000\000\000\000\000\000\002\233\003)\000\000\001\162\003\027\000\000\000\000\000\000\003+\000\000\000\000\000\000\002\234\000\000\003\024\000U\003\022\000\000\000\000\002\230\002\231\002\004\000\000\000\000\003+\000\000\000\000\000\000\002\234\000\000\003\024\000U\003\022\000\000\000\000\002\230\002\231\002\004\000\000\000\000\003\028\003\031\003\141\000\000\002\234\000\000\003\024\000U\000\000\000\000\003\006\002\230\002\231\002\004\000\000\000\000\003\028\003\031\003\007\000\000\000\000\000\000\003 \000\000\006\016\000\000\003\006\000\000\000\000\000\000\000\000\003\020\000\000\000\000\003\007\003\025\000\000\000\000\003 \000\000\006\198\000\000\000\000\003\026\000\000\001\162\003\027\003\020\000\000\000\000\000\000\003\025\000\000\003#\000\000\000\000\000\000\000\000\000\000\003)\000\000\001\162\003\027\000\000\000\000\000\000\000\000\003\025\000\000\003#\000\000\000\000\000\000\000\000\002\233\003)\000\000\001\162\003\027\000\000\000\000\000\000\003+\000\000\000\000\000\000\002\234\000\000\003\024\000U\003\022\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003+\000\000\000\000\000\000\002\234\000\000\003\024\000U\003\022\000\000\000\000\002\230\002\231\002\004\000\000\000\000\003\028\003\031\000\000\000\000\002\234\000\000\003\024\000U\000\000\000\000\003\006\002\230\002\231\002\004\000\000\000\000\003\028\003\031\003\007\000\000\000\000\000\000\003 \000\000\006\200\000\000\003\006\000\000\000\000\000\000\000\000\003\020\000\000\000\000\003\007\003\025\000\000\000\000\003 \000\000\006\203\000\000\000\000\003\026\000\000\001\162\003\027\003\020\000\000\000\000\000\000\003\025\000\000\003#\000\000\000\000\000\000\000\000\000\000\003)\000\000\001\162\003\027\000\000\000\000\000\000\000\000\003\025\000\000\003#\000\000\000\000\000\000\000\000\000\000\003)\000\000\001\162\003\027\000\000\000\221\000\000\003+\005\199\000\000\000\000\000\000\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003+\000\000\000\000\000\000\002\234\000\000\003\024\000U\003\022\000\224\000\000\002\230\002\231\002\004\000\000\000\000\003\028\003\031\000\000\000\000\002\234\000\000\003\024\000U\000\000\000\000\003\006\002\230\002\231\002\004\000\000\000\000\003\028\003\031\003\007\000\000\000\000\000\000\003 \000\000\006\208\000\000\003\006\000\000\000\000\000\000\000\000\003\020\000\000\000\000\003\007\000\000\005\201\000\000\003 \000\000\006\210\000\000\000\000\000\221\000\000\000\000\000\222\003\020\000\000\000\000\000\000\003\025\000\000\003#\000\000\000\000\000\000\000\000\000\000\003)\000\000\001\162\003\027\000\000\000\000\000\000\000\207\003\025\000\000\003#\000\224\000\000\000\213\005\204\000\000\003)\000\000\001\162\003\027\000\000\000\000\000\000\003+\000\000\000\000\000\000\000\000\001`\000\000\000\000\003\022\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003+\000\000\000\000\000\000\002\234\000\000\003\024\000U\003\022\000\000\000\000\000\000\000\000\000\000\000\000\000\232\003\028\003\031\000\000\000\000\002\234\000\000\003\024\000U\000\000\000\000\000\000\000\000\000\000\001n\005\205\000\000\003\028\003\031\000\000\000\000\000\221\000\000\003 \000\222\000\000\000\000\005\152\000\000\005\209\000\207\005\207\000\000\000\000\000\000\000\000\000\213\000\226\000\000\003 \000\000\000\000\000\236\000\000\000\000\000\000\000\000\000\000\000\224\000\000\000\000\000\000\003\025\000\000\003#\000\000\000\000\000\000\000\000\000\000\003)\000\000\001\162\003\027\000\000\001`\000\000\000\000\003\025\000\000\003#\002\230\002\231\002\004\000\000\000\000\003)\000\000\001\162\003\027\001c\001d\000\000\003+\000\000\000\252\003\006\000\000\000\000\000\000\000\000\000\232\000\227\000\000\003\007\000\000\001o\001|\000\000\003+\000\000\001g\001_\000\000\000\000\001~\000\000\003\020\000\000\002\230\002\231\002\004\000\000\000\000\002\230\002\231\002\004\000\000\000\000\000\236\000\000\000\207\001\006\000\000\003\006\000\000\000\000\000\213\000\226\003\006\000\000\000\000\003\007\000\000\000\000\000\000\000\000\003\007\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\020\000\000\000\000\000\000\000\000\003\020\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\001c\001d\000\000\000\000\000\000\000\252\000\000\002\234\000\000\003\024\000U\000\000\000\227\000\000\000\000\000\000\001o\001|\000\000\003\028\003\031\001g\001_\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\003\022\000\236\000\000\003 \001\006\000\000\000\000\002\234\000\000\003\024\000U\000\000\002\234\000\000\003\024\000U\002\230\002\231\002\004\003\028\003\031\002\230\002\231\002\004\003\028\003\031\000\000\000\000\000\000\000\000\000\000\003\006\003\025\000\000\004\142\000\000\003\006\000\000\000\000\003\007\003)\003 \001\162\003\027\003\007\000\000\003 \000\000\000\000\000\000\000\000\000\000\003\020\000\000\000\000\000\000\000\000\003\020\000\000\002\230\002\231\002\004\000\000\003+\002\230\002\231\002\004\000\000\000\000\000\000\003\025\000\000\004\135\000\000\003\006\003\025\000\000\004:\003)\003\006\001\162\003\027\003\007\003)\000\000\001\162\003\027\003\007\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\020\000\000\000\000\000\000\000\000\003\020\003+\000\000\000\000\000\000\000\000\003+\000\000\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\000\000\000\000\002\234\000\000\003\024\000U\000\000\002\234\000\000\003\024\000U\000\000\000\000\000\000\003\028\003\031\000\000\000\000\000\000\003\028\003\031\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\022\000\000\000\000\003 \000\000\003\022\000\000\000\000\003 \000\000\000\000\000\000\002\234\000\000\003\024\000U\000\000\002\234\000\000\003\024\000U\002\230\002\231\002\004\003\028\003\031\002\230\002\231\002\004\003\028\003\031\000\000\003\025\000\000\0045\000\000\003\006\003\025\000\000\003\198\003)\003\006\001\162\003\027\003\007\003)\003 \001\162\003\027\003\007\000\000\003 \000\000\000\000\000\000\000\000\000\000\003\020\000\000\000\000\000\000\000\000\003\020\003+\002\230\002\231\002\004\000\000\003+\002\230\002\231\002\004\000\000\000\000\000\000\003\025\000\000\003v\000\000\003\006\003\025\000\000\003%\003)\003\006\001\162\003\027\003\007\003)\000\000\001\162\003\027\003\007\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\020\000\000\000\000\000\000\000\000\003\020\003+\000\000\000\000\000\000\000\000\003+\000\000\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\000\000\000\000\002\234\000\000\003\024\000U\000\000\002\234\000\000\003\024\000U\000\000\000\000\000\000\003\028\003\031\000\000\000\000\000\000\003\028\003\031\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\022\000\000\000\000\003 \000\000\003\022\000\000\000\000\003 \000\000\000\000\000\000\002\234\000\000\003\024\000U\000\000\002\234\000\000\003\024\000U\002\230\002\231\002\004\003\028\003\031\002\230\002\231\002\004\003\028\003\031\000\000\003\025\000\000\003'\000\000\003\006\003\025\000\000\003,\003)\003\006\001\162\003\027\003\007\003)\003 \001\162\003\027\003\007\000\000\003 \000\000\000\000\000\000\000\000\000\000\003\020\000\000\000\000\000\000\000\000\003\020\003+\002\230\002\231\002\004\000\000\003+\002\230\002\231\002\004\000\000\000\000\000\000\003\025\000\000\0033\000\000\003\006\003\025\000\000\0035\003)\003\006\001\162\003\027\003\007\003)\000\000\001\162\003\027\003\007\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\020\000\000\000\000\000\000\000\000\003\020\003+\000\000\000\000\000\000\000\000\003+\000\000\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\000\000\000\000\002\234\000\000\003\024\000U\000\000\002\234\000\000\003\024\000U\000\000\000\000\000\000\003\028\003\031\000\000\000\000\000\000\003\028\003\031\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\022\000\000\000\000\003 \000\000\003\022\000\000\000\000\003 \000\000\000\000\000\000\002\234\000\000\003\024\000U\000\000\002\234\000\000\003\024\000U\002\230\002\231\002\004\003\028\003\031\002\230\002\231\002\004\003\028\003\031\000\000\003\025\000\000\0037\000\000\003\006\003\025\000\000\0039\003)\003\006\001\162\003\027\003\007\003)\003 \001\162\003\027\003\007\000\000\003 \000\000\000\000\000\000\000\000\000\000\003\020\000\000\000\000\000\000\000\000\003\020\003+\002\230\002\231\002\004\000\000\003+\002\230\002\231\002\004\000\000\000\000\000\000\003\025\000\000\003;\000\000\003\006\003\025\000\000\003=\003)\003\006\001\162\003\027\003\007\003)\000\000\001\162\003\027\003\007\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\020\000\000\000\000\000\000\000\000\003\020\003+\000\000\000\000\000\000\000\000\003+\000\000\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\000\000\000\000\002\234\000\000\003\024\000U\000\000\002\234\000\000\003\024\000U\000\000\000\000\000\000\003\028\003\031\000\000\000\000\000\000\003\028\003\031\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\022\000\000\000\000\003 \000\000\003\022\000\000\000\000\003 \000\000\000\000\000\000\002\234\000\000\003\024\000U\000\000\002\234\000\000\003\024\000U\002\230\002\231\002\004\003\028\003\031\002\230\002\231\002\004\003\028\003\031\000\000\003\025\000\000\003?\000\000\003\006\003\025\000\000\003A\003)\003\006\001\162\003\027\003\007\003)\003 \001\162\003\027\003\007\000\000\003 \000\000\000\000\000\000\000\000\000\000\003\020\000\000\000\000\000\000\000\000\003\020\003+\002\230\002\231\002\004\000\000\003+\002\230\002\231\002\004\000\000\000\000\000\000\003\025\000\000\003C\000\000\003\006\003\025\000\000\003E\003)\003\006\001\162\003\027\003\007\003)\000\000\001\162\003\027\003\007\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\020\000\000\000\000\000\000\000\000\003\020\003+\000\000\000\000\000\000\000\000\003+\000\000\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\000\000\000\000\002\234\000\000\003\024\000U\000\000\002\234\000\000\003\024\000U\000\000\000\000\000\000\003\028\003\031\000\000\000\000\000\000\003\028\003\031\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\022\000\000\000\000\003 \000\000\003\022\000\000\000\000\003 \000\000\000\000\000\000\002\234\000\000\003\024\000U\000\000\002\234\000\000\003\024\000U\002\230\002\231\002\004\003\028\003\031\002\230\002\231\002\004\003\028\003\031\000\000\003\025\000\000\003G\000\000\003\006\003\025\000\000\003I\003)\003\006\001\162\003\027\003\007\003)\003 \001\162\003\027\003\007\000\000\003 \000\000\000\000\000\000\000\000\000\000\003\020\000\000\000\000\000\000\000\000\003\020\003+\002\230\002\231\002\004\000\000\003+\002\230\002\231\002\004\000\000\000\000\000\000\003\025\000\000\003K\000\000\003\006\003\025\000\000\003M\003)\003\006\001\162\003\027\003\007\003)\000\000\001\162\003\027\003\007\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\020\000\000\000\000\000\000\000\000\003\020\003+\000\000\000\000\000\000\000\000\003+\000\000\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\000\000\000\000\002\234\000\000\003\024\000U\000\000\002\234\000\000\003\024\000U\000\000\000\000\000\000\003\028\003\031\000\000\000\000\000\000\003\028\003\031\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\022\000\000\000\000\003 \000\000\003\022\000\000\000\000\003 \000\000\000\000\000\000\002\234\000\000\003\024\000U\000\000\002\234\000\000\003\024\000U\002\230\002\231\002\004\003\028\003\031\002\230\002\231\002\004\003\028\003\031\000\000\003\025\000\000\003O\000\000\003\006\003\025\000\000\003Q\003)\003\006\001\162\003\027\003\007\003)\003 \001\162\003\027\003\007\000\000\003 \000\000\000\000\000\000\000\000\000\000\003\020\000\000\000\000\000\000\000\000\003\020\003+\002\230\002\231\002\004\000\000\003+\002\230\002\231\002\004\000\000\000\000\000\000\003\025\000\000\003S\000\000\003\006\003\025\000\000\003U\003)\003\006\001\162\003\027\003\007\003)\000\000\001\162\003\027\003\007\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\020\000\000\000\000\000\000\000\000\003\020\003+\000\000\000\000\000\000\000\000\003+\000\000\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\000\000\000\000\002\234\000\000\003\024\000U\000\000\002\234\000\000\003\024\000U\000\000\000\000\000\000\003\028\003\031\000\000\000\000\000\000\003\028\003\031\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\022\000\000\000\000\003 \000\000\003\022\000\000\000\000\003 \000\000\000\000\000\000\002\234\000\000\003\024\000U\000\000\002\234\000\000\003\024\000U\002\230\002\231\002\004\003\028\003\031\002\230\002\231\002\004\003\028\003\031\000\000\003\025\000\000\003W\000\000\003\006\003\025\000\000\003Y\003)\003\006\001\162\003\027\003\007\003)\003 \001\162\003\027\003\007\000\000\003 \000\000\000\000\000\000\000\000\000\000\003\020\000\000\000\000\000\000\000\000\003\020\003+\002\230\002\231\002\004\000\000\003+\002\230\002\231\002\004\000\000\000\000\000\000\003\025\000\000\003\147\000\000\003\006\003\025\000\000\003\152\003)\003\006\001\162\003\027\003\007\003)\000\000\001\162\003\027\003\007\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\020\000\000\000\000\000\000\000\000\003\020\003+\000\000\000\000\000\000\000\000\003+\000\000\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\000\000\000\000\002\234\000\000\003\024\000U\000\000\002\234\000\000\003\024\000U\000\000\000\000\000\000\003\028\003\031\000\000\000\000\000\000\003\028\003\031\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\022\000\000\000\000\003 \000\000\003\022\000\000\000\000\003 \000\000\000\000\000\000\002\234\000\000\003\024\000U\000\000\002\234\000\000\003\024\000U\002\230\002\231\002\004\003\028\003\031\002\230\002\231\002\004\003\028\003\031\000\000\003\025\000\000\003\157\000\000\003\006\003\025\000\000\003\163\003)\003\006\001\162\003\027\003\007\003)\003 \001\162\003\027\003\007\000\000\003 \000\000\000\000\000\000\000\000\000\000\003\020\000\000\000\000\000\000\000\000\003\020\003+\002\230\002\231\002\004\000\000\003+\002\230\002\231\002\004\000\000\000\000\000\000\003\025\000\000\003\168\000\000\003\006\003\025\000\000\003\173\003)\003\006\001\162\003\027\003\007\003)\000\000\001\162\003\027\003\007\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\020\000\000\000\000\000\000\000\000\003\020\003+\000\000\000\000\000\000\000\000\003+\000\000\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\000\000\000\000\002\234\000\000\003\024\000U\000\000\002\234\000\000\003\024\000U\000\000\000\000\000\000\003\028\003\031\000\000\000\000\000\000\003\028\003\031\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\022\000\000\000\000\003 \000\000\003\022\000\000\000\000\003 \000\000\000\000\000\000\002\234\000\000\003\024\000U\000\000\002\234\000\000\003\024\000U\002\230\002\231\002\004\003\028\003\031\002\230\002\231\002\004\003\028\003\031\000\000\003\025\000\000\003\180\000\000\003\006\003\025\000\000\003\185\003)\003\006\001\162\003\027\003\007\003)\003 \001\162\003\027\003\007\000\000\003 \000\000\000\000\000\000\000\000\000\000\003\020\000\000\000\000\000\000\000\000\003\020\003+\000\000\000\000\000\000\000\000\003+\000\221\000\000\000\000\000\222\000\000\000\000\003\025\000\000\003\190\000\000\000\000\003\025\000\000\003\193\003)\000\000\001\162\003\027\000\000\003)\000\000\001\162\003\027\000\000\000\000\000\000\000\000\000\224\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003+\000\000\000\000\000\000\000\000\003+\000\000\001`\000\000\000\000\003\022\000\000\000\000\000\000\000\000\003\022\000\000\000\000\000\000\000\000\000\000\000\000\002\234\000\000\003\024\000U\000\000\002\234\000\000\003\024\000U\000\000\000\000\000\232\003\028\003\031\000\000\000\000\000\221\003\028\003\031\000\222\000\000\000\000\000\000\000\000\000\000\005\249\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003 \000\000\000\000\000\000\000\000\003 \000\000\000\207\000\000\000\224\000\000\000\000\000\000\000\213\000\226\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001`\000\000\000\000\003\025\000\000\004.\000\000\000\000\003\025\000\000\0040\003)\000\000\001\162\003\027\000\000\003)\000\000\001\162\003\027\000\000\000\000\000\000\000\000\000\000\000\000\000\232\000\000\000\000\000\000\000\000\001c\001d\000\000\003+\000\000\000\252\002X\002\004\003+\006\162\000\000\000\000\000\227\000\000\000\000\000\000\001o\001|\000\000\000\000\000\000\001g\001_\000\000\000\000\000\207\002\005\002\250\000\000\002\007\002\b\000\213\000\226\000\000\000\000\000\000\000\000\000\000\000\000\000\236\002J\002\004\001\006\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002J\002\004\003\\\002\020\000\000\002\007\002\b\000\000\000\000\000\000\003\208\003m\003n\000\000\000\000\000\000\000\000\001c\001d\000\000\003\\\002\020\000\252\002\007\002\b\000\000\000\000\002\003\002\004\000\227\000\000\000\000\000\000\001o\001|\000\000\000\000\000\000\001g\001_\000\000\000\000\002\028\000\000\003a\003m\003n\002\005\002\020\000\000\002\007\002\b\000\000\000\000\002\r\000\000\000\236\000U\000\000\001\006\000\000\000\000\003a\003m\003n\000\000\000\000\000\000\000\000\000\000\004\138\000\000\000\000\000\000\000\000\000\000\002\028\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\211\003\216\000\000\000\000\002\r\000\000\002\021\000U\002\022\002\209\002\028\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\r\000\000\000\000\000U\000\000\002J\002\004\000\000\000\000\000\000\000\000\002\030\000\000\000\000\000\000\002\028\000\000\003q\003r\002\031\000\000\001\162\002\011\002\003\002\004\003\\\002\020\002\r\002\007\002\b\000U\000\000\000\000\000\000\000\000\003q\004f\000\000\004+\000\000\000\000\000\000\000\000\002\005\002\020\002\030\002\007\002\b\000\000\000\000\000\000\000\000\000\000\002\031\000\000\001\162\002\011\002J\002\004\000\000\000\000\000\000\000\000\002\030\000\000\000\000\004\141\003a\003m\003n\000\000\002\031\000\000\001\162\002\011\000\000\000\000\003\\\002\020\000\000\002\007\002\b\000\000\000\000\000\000\000\000\002\021\000\000\002\022\002\209\002\030\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\031\002\028\001\162\002\011\002\003\002\004\000\000\000\000\000\000\002\003\002\004\000\000\000\000\002\r\000\000\000\000\000U\000\000\000\000\002\028\000\000\003a\003m\003n\002\005\002\020\000\000\002\007\002\b\002\005\002\020\002\r\002\007\002\b\000U\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004+\000\000\000\000\000\000\000\000\006\193\003q\006\027\000\000\000\000\006\196\002\028\000\000\000\000\000\000\002\003\002\004\000\000\000\000\000\000\000\000\000\000\000\000\002\r\000\000\002\021\000U\002\022\002\209\000\000\002\021\000\000\002\022\002\209\002\030\002\005\002\020\000\000\002\007\002\b\000\000\000\000\002\031\000\000\001\162\002\011\000\000\000\000\000\000\000\000\000\000\000\000\002\030\000\000\000\000\000\000\002\028\000\000\003q\006=\002\031\002\028\001\162\002\011\000\000\000\000\000\000\000\000\002\r\002\003\002\004\000U\000\000\002\r\000\000\000\000\000U\000\000\002\021\004+\002\022\002)\000\000\000\000\004+\000\000\002\030\002\003\002\004\002\005\002\020\000\000\002\007\002\b\002\031\000\000\001\162\002\011\000\000\002H\000\000\000\000\000\000\000\140\000\000\002\003\002\004\002\005\002\020\002\028\002\007\002\b\000\000\000\000\000\000\000\000\000\000\002:\000\000\000\000\000\000\002\r\000\000\000\000\000U\002\005\002\020\000\000\002\007\002\b\000\000\002\030\002\021\000\000\002\022\002<\002\030\000\000\000\000\002\031\000\000\001\162\002\011\000\000\002\031\000\000\001\162\002\011\000\000\000\000\002\021\000\000\002\022\002<\000\000\000\000\002\003\002\004\000\000\000\000\000\000\000\000\000\000\002\028\000\000\000\000\000\000\000\000\002\021\000\000\002\022\002\\\000\000\000\000\000\000\002\r\002\005\002\020\000U\002\007\002\b\002\028\000\000\000\000\002\030\000\000\002>\000\000\000\000\002\003\002\004\000\000\002\031\002\r\001\162\002\011\000U\000\000\004i\002\028\000\000\000\000\000\000\000\000\000\000\000\000\004l\002\003\002\004\002\005\004\026\002\r\002\007\002\b\000U\000\000\000\000\000\000\000\000\002\021\000\000\002\022\002<\000\000\000\000\000\000\000\000\002\005\002\020\000\000\002\007\002\b\000\000\000\000\000\000\000\000\000\000\000\000\002\030\000\000\000\000\000\000\000\000\002_\000\000\000\000\002\031\000\000\001\162\002\011\002\028\000\000\000\000\000\000\000\000\000\000\002\030\000\000\000\000\000\000\000\000\000\000\002\r\000\000\002\031\000U\001\162\002\011\000\000\000\000\002\021\000\000\002\022\002\209\002\030\000\000\002X\002\004\000\000\000\000\000\000\000\000\002\031\002\012\001\162\002\011\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\r\002\005\002\250\000U\002\007\002\b\002\028\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\r\000\000\000\000\000U\000\000\000\000\000\000\000\000\002\003\002\004\000\000\004'\002\030\002\003\002\004\000\000\000\000\000\000\000\000\004m\002\031\000\000\001\162\002\011\000\000\003\208\003m\003n\002\005\004\026\000\000\002\007\002\b\002\005\002\020\000\000\002\007\002\b\000\000\000\000\004o\002\003\002\004\000\000\000\000\002\030\000\000\000\000\000\000\000\000\004i\000\000\000\000\002'\000\000\001\162\002\011\002\028\004l\000\000\000\000\002\005\004\026\002\030\002\007\002\b\000\000\000\000\000\000\002\r\000\000\002\031\000U\001\162\002\011\000\000\002\021\000\000\002\022\002\209\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\003\002\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\215\000\000\002\012\000\000\000\000\000\000\000\000\002\028\000\000\002\005\002\020\000\000\002\007\002\b\002\r\000\000\000\000\000U\000\000\002\r\000\000\000\000\000U\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004*\000\000\002\030\000\000\000\000\002\012\000\000\000\000\000\221\000\000\002\031\000\222\001\162\002\011\000\240\000\000\000\000\002\r\000\000\000\000\000U\006]\002\021\000\221\002\022\007\006\000\222\007\b\000\000\000\240\000\000\000\000\000\000\000\000\000\241\000\224\000\000\000\000\000\000\000\000\000\000\001\015\000\000\000\000\000\000\000\000\000\000\002\030\000\000\000\241\000\224\000\000\002\030\002\028\004m\002'\001\r\001\162\002\011\000\000\002\031\000\000\001\162\002\011\000\000\002\r\000\000\000\000\000U\006_\000\000\000\000\000\000\000\221\000\000\004n\000\222\000\000\000\232\000\240\002\030\002\003\002\004\000\000\000\000\000\000\000\000\000\000\002'\000\000\001\162\002\011\000\000\000\232\000\000\000\246\000\000\000\000\000\000\000\241\000\224\002\005\002\006\000\000\002\007\002\b\000\242\000\000\000\207\000\000\000\246\000\000\000\000\000\000\000\213\000\226\000\000\000\000\000\221\000\000\000\000\000\222\000\000\000\207\000\240\000\000\000\000\000\000\002\030\000\213\000\226\000\000\000\000\000\000\000\000\000\000\002\031\000\000\001\162\002\011\000\000\000\000\000\000\000\232\000\241\000\224\000\000\000\000\002\003\002\004\000\000\001\011\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\246\000\000\000\000\000\252\000\000\000\000\000\000\000\000\002\005\002\020\000\227\002\007\002\b\000\207\001\004\002\012\000\000\000\000\000\252\000\213\000\226\000\000\000\000\002\003\002\004\000\227\000\000\002\r\000\232\001\004\000U\000\000\000\000\000\000\000\000\000\000\000\000\000\236\000\000\000\000\001\006\000\000\000\000\002\005\002\020\000\246\002\007\002\b\000\000\002\003\002\004\002\021\000\236\002\022\004\156\001\006\000\000\000\000\000\207\000\000\000\000\000\000\000\000\000\000\000\213\000\226\000\000\000\000\000\252\002\005\002\020\000\000\002\007\002\b\000\000\000\227\000\000\000\000\000\000\001\004\000\000\000\000\002\028\000\000\000\000\000\000\002\021\000\000\002\022\002@\002\030\000\000\000\000\000\000\002\r\000\000\000\000\000U\002'\000\000\001\162\002\011\000\236\000\000\000\000\001\006\000\000\002\003\002\004\000\000\000\000\000\000\002\021\000\252\002\022\0026\000\000\002\028\000\000\000\000\000\227\002\003\002\004\000\000\001\004\000\000\000\000\002\005\002\020\002\r\002\007\002\b\000U\000\000\000\000\000\000\000\000\000\000\002\230\002\231\002\004\002\005\002\020\002\028\002\007\002\b\000\000\000\236\000\000\000\000\001\006\000\000\000\000\000\000\000\000\002\r\000\000\002\030\000U\002\003\002\004\003\194\000\000\000\000\000\000\002\031\000\000\001\162\002\011\000\000\002\021\000\000\002\022\0025\000\000\000\000\000\000\000\000\000\000\002\005\002\020\000\000\002\007\002\b\002\021\006.\002\022\002\024\000\000\000\000\000\000\000\000\002\030\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\031\002\028\001\162\002\011\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\r\000\000\002\028\000U\000\000\002\030\000\000\000\000\000\000\002\021\000\000\002\022\002\026\002\031\002\r\001\162\002\011\000U\002\003\002\004\002\233\000\000\000\000\000\000\000\000\000\000\000\000\002\003\002\004\000\000\000\000\000\000\002\234\000\000\003\024\000U\002\003\002\004\002\005\002\020\002\028\002\007\002\b\000\000\000\000\002\003\002\004\002\005\002\020\000\000\002\007\002\b\002\r\000\000\000\000\000U\002\005\002\020\000\000\002\007\002\b\000\000\000\000\002\030\000\000\002\005\002\020\000\000\002\007\002\b\003\197\002\031\000\000\001\162\002\011\000\000\000\000\002\030\000\000\000\000\000\000\002\021\000\000\002\022\002\029\002\031\000\000\001\162\002\011\000\000\002\021\000\000\002\022\0024\000\000\003\025\000\000\000\000\000\000\002\021\000\000\002\022\002,\003\026\000\000\001\162\003\027\000\000\002\021\000\000\002\022\0021\002\028\000\000\000\000\002\030\000\000\000\000\000\000\000\000\000\000\002\028\000\000\002\031\002\r\001\162\002\011\000U\000\000\000\000\002\028\000\000\000\000\002\r\000\000\000\000\000U\000\000\000\000\002\028\002\003\002\004\002\r\000\000\000\000\000U\002\230\002\231\002\004\004\129\000\000\002\r\000\000\000\000\000U\000\000\000\000\004\132\000\000\000\000\002\005\004\026\000\000\002\007\002\b\002\003\002\004\000\000\000\000\003\232\002\003\002\004\000\000\000\000\000\000\000\000\003\247\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\005\002\020\002\030\002\007\002\b\002\005\002\020\000\000\002\007\002\b\002\031\002\030\001\162\002\011\0048\000\000\000\000\000\000\000\000\002\031\002\030\001\162\002\011\000\000\000\000\000\000\000\000\000\000\002\031\002\030\001\162\002\011\000\000\000\000\002\003\002\004\000\000\002\031\000\000\001\162\002\011\000\000\000\000\002\021\000\000\002\022\002\222\000\000\002\021\002\012\002\022\002\227\000\000\000\000\002\005\002\020\002\233\002\007\002\b\000\000\000\000\002\r\000\000\000\000\000U\000\000\000\000\000\000\003\250\000\000\003\024\000U\001\243\000\000\002\028\000\000\000\000\000\000\000\000\002\028\000\000\002\003\002\004\000\000\000\000\000\000\002\r\000\000\000\000\000U\000\000\002\r\000\000\000\000\000U\000\000\000\000\002\021\004m\002\022\003e\002\005\002\020\000\000\002\007\002\b\000\000\003\235\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\030\000\000\000\000\000\000\002\028\000\000\000\000\003\025\002'\000\000\001\162\002\011\000\000\000\000\000\000\003\026\002\r\001\162\003\027\000U\002\021\000\000\002\022\003g\000\000\002\030\000\000\000\000\000\000\000\000\002\030\000\000\000\000\002\031\000\000\001\162\002\011\000\000\002\031\000\000\001\162\002\011\000\000\000\000\002\003\002\004\000\000\000\000\000\000\002\003\002\004\002\028\002\230\002\231\002\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\r\002\005\002\020\000U\002\007\002\b\002\005\002\020\000\000\002\007\002\b\000\000\003\232\002\003\002\004\000\000\002\030\000\000\000\000\003\247\000\000\000\000\000\000\000\000\002\031\000\000\001\162\002\011\000\000\000\000\000\000\000\000\000\000\002\005\002\020\000\000\002\007\002\b\000\000\000\000\000\000\000\000\003\248\000\000\002\021\000\000\002\022\003i\000\000\002\021\000\000\002\022\003p\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\030\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\031\000\000\001\162\002\011\002\028\002\021\000\000\002\022\004\237\002\028\000\000\000\000\000\000\002\233\000\000\000\000\002\r\000\000\000\000\000U\000\000\002\r\000\000\000\000\000U\003\250\000\000\003\024\000U\001\243\000\000\000\221\000\000\000\000\000\222\000\000\002\028\001\007\000\000\000\221\000\000\000\000\000\222\000\000\000\000\001\007\000\000\000\221\002\r\000\000\000\222\000U\000\000\000\240\000\000\000\000\000\000\001\t\000\224\000\000\000\000\000\000\000\000\005\145\003\235\001\t\000\224\000\000\000\000\000\000\000\000\000\000\000\000\000\245\000\224\000\000\000\000\000\000\000\000\002\030\000\000\000\000\002\003\002\004\002\030\000\000\000\000\002\031\003\025\001\162\002\011\000\000\002\031\000\000\001\162\002\011\003\026\000\000\001\162\003\027\000\000\000\232\002\005\004\026\000\000\002\007\002\b\000\000\000\000\000\232\000\000\002\030\002\003\002\004\000\000\000\000\000\000\000\232\000\246\002\031\000\000\001\162\002\011\000\000\000\000\000\000\000\246\000\000\000\000\004p\000\000\000\207\002\005\004\026\000\246\002\007\002\b\000\213\000\226\000\207\002\003\002\004\000\000\000\000\000\000\000\213\000\226\000\207\000\000\000\000\000\000\000\000\000\000\000\213\000\226\000\000\000\000\000\000\002\003\002\004\002\005\004\026\000\000\002\007\002\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\012\000\000\002\005\004\026\000\000\002\007\002\b\000\000\000\000\000\000\000\252\000\000\002\r\000\000\000\000\000U\000\000\000\227\000\252\000\000\000\000\005\198\000\000\000\000\000\000\000\227\000\252\000\000\000\000\001\004\002\012\000\000\000\000\000\227\000\000\000\000\000\000\001\004\000\000\000\000\000\000\000\000\002\r\000\000\000\236\000U\000\000\001\006\000\000\004\027\000\000\000\000\000\236\000\000\000\000\001\006\000\000\000\000\002\012\000\000\000\236\000\000\000\000\001\006\000\000\000\000\000\000\000\000\000\000\004\030\002\r\000\000\000\000\000U\000\000\002\030\002\012\002\003\002\004\004m\000\000\000\000\000\000\002'\000\000\001\162\002\011\000\000\002\r\000\000\000\000\000U\000\000\000\000\000\000\000\000\000\000\002\005\004\026\000\000\002\007\002\b\000\000\000\000\000\000\002\030\000\000\004\027\000\000\000\000\000\000\000\000\000\000\002'\000\000\001\162\002\011\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\027\000\000\004\029\000\000\002\003\002\004\000\000\000\000\002\030\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002'\000\000\001\162\002\011\004\028\004\209\000\000\000\000\002\005\004\026\002\030\002\007\002\b\000\000\000\000\002\003\002\004\000\000\002'\000\000\001\162\002\011\000\000\000\000\000\000\000\000\000\000\000\000\002\003\002\004\002\012\000\000\004\233\002\003\002\004\002\005\004\026\000\000\002\007\002\b\000\000\000\000\002\r\000\000\000\000\000U\000\000\000\000\002\005\004\026\000\000\002\007\002\b\002\005\004\026\000\000\002\007\002\b\000\000\000\000\002\003\002\004\000\000\000\000\000\000\000\000\002\003\002\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\027\002\005\004\026\002\012\002\007\002\b\000\000\002\005\004\026\000\000\002\007\002\b\000\000\000\000\000\221\002\r\000\000\000\222\000U\000\000\004 \000\000\000\000\000\000\000\000\000\000\002\030\000\000\000\000\000\000\002\012\000\000\000\000\000\000\002'\000\000\001\162\002\011\000\000\000\000\000\000\000\224\002\r\002\012\000\000\000U\002\003\002\004\002\012\000\000\000\000\001\022\004m\000\000\000\000\002\r\000\000\000\000\000U\000\000\002\r\000\000\000\000\000U\000\000\001?\002\005\004\026\000\000\002\007\002\b\000\000\000\000\000\000\000\000\002\012\000\000\006j\002\030\004m\000\000\002\012\000\000\000\000\000\232\000\000\002'\002\r\001\162\002\011\000U\000\000\006(\002\r\000\000\007\028\000U\006(\006m\000\000\000\000\000\000\000\000\000\000\000\000\002\030\000\000\006n\000\000\000\000\000\000\000\000\000\000\002'\000\207\001\162\002\011\000\000\002\030\000\000\000\213\000\226\000\221\002\030\006]\000\222\002'\000\000\001\162\002\011\006]\002'\000\000\001\162\002\011\000\000\006o\000\000\000\000\0065\002\012\000\000\000\000\000\000\0064\000\000\000\000\000\000\000\000\000\224\002\030\000\000\002\r\000\000\000\000\000U\002\030\000\000\002'\004|\001\162\002\011\002\003\002\004\002'\000\000\001\162\002\011\000\000\000\252\006p\000\000\006^\000\000\000\000\000\000\000\227\000\000\006f\006q\000\000\000\000\002\005\002&\000\000\002\007\002\b\002\003\002\004\004\031\000\000\000\221\000\232\000\000\000\222\000\000\000\000\000\000\006r\003\031\000\000\000\000\007\029\000\236\000\000\000\000\001$\002\005\002i\000\000\002\007\002\b\000\000\000\221\000\000\002\030\000\222\000\000\000\224\000\000\006t\000\000\000\207\002'\000\000\001\162\002\011\000\000\000\213\000\226\006u\000\000\000\000\000\000\000\000\006w\000\000\000\000\000\221\000\000\000\224\000\222\000\000\000\000\000\000\005\145\006y\000\000\000\221\000\000\000\000\000\222\000\000\000\000\000\000\000\000\002\012\000\000\000\000\000\000\000\000\000\232\006z\000\221\000\000\000\224\000\222\000\000\002\r\000\000\006#\000U\000\000\000\000\000\000\000\224\000\000\000\252\000\000\000\000\000\000\002\012\000\000\000\232\000\227\000\000\000\000\000\000\003\239\000\000\000\224\000\207\000\000\002\r\000\000\000\000\000U\000\213\000\226\000\000\000\000\000\221\000\000\000\000\000\222\000\000\000\000\000\000\000\232\000\000\000\000\000\236\000\000\000\207\001\006\000\000\000\000\000\000\000\232\000\213\000\226\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\224\000\000\000\000\002\030\000\000\000\232\000\000\000\000\000\000\000\000\000\207\002'\000\000\001\162\002\011\000\000\000\213\000\226\000\252\000\000\000\207\000\000\000\000\000\000\000\000\000\227\000\213\000\226\002\030\005\163\000\221\000\000\005\166\000\222\000\000\000\207\002'\000\000\001\162\002\011\000\252\000\213\000\226\000\232\000\000\000\000\000\000\000\227\000\000\000\000\000\000\005\150\000\236\000\000\000\000\001\006\000\000\000\224\000\000\000\000\000\000\000\221\000\000\000\000\000\222\000\252\000\000\000\000\000\000\000\000\000\000\000\000\000\227\000\207\000\236\000\252\005\150\001\006\000\000\000\213\000\226\000\221\000\227\000\000\000\222\000\000\005\163\000\000\000\224\006O\000\252\000\000\000\000\000\221\000\000\000\000\000\222\000\227\000\000\000\236\000\232\006\174\001\006\000\000\000\000\000\000\000\000\000\000\000\224\000\236\000\000\000\000\001\006\000\000\000\221\000\000\000\000\000\222\000\000\000\000\000\224\000\000\000\000\000\000\000\236\000\000\000\000\001\006\000\252\000\000\000\207\000\232\000\000\000\000\000\000\000\227\000\213\000\226\000\000\0013\000\000\000\224\000\000\000\000\000\000\000\221\000\000\000\000\000\222\000\000\000\000\000\232\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\207\000\236\000\232\000\000\001\006\000\000\000\213\000\226\000\000\000\000\000\000\000\224\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\207\000\000\000\000\000\232\000\252\000\221\000\213\000\226\000\222\000\000\000\221\000\227\000\207\000\222\000\000\0017\000\000\000\000\000\213\000\226\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\221\000\000\000\000\000\222\000\000\000\224\000\207\000\232\000\252\000\000\000\224\000\236\000\213\000\226\001\006\000\227\000\000\000\000\000\000\001\139\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\224\000\252\000\000\000\000\000\000\000\000\000\000\000\000\000\227\000\000\000\207\000\000\001\141\000\252\000\000\000\236\000\213\000\226\001\006\000\221\000\227\000\232\000\222\000\000\001\248\000\000\000\232\000\221\000\000\000\000\000\222\000\000\000\000\000\000\000\252\000\236\000\000\000\000\001\006\000\000\000\000\000\227\000\000\000\232\000\000\002.\000\224\000\236\000\000\000\000\001\006\000\207\000\000\000\000\000\224\000\000\000\207\000\213\000\226\000\000\000\000\000\000\000\213\000\226\000\000\000\252\000\221\000\000\000\236\000\222\000\000\001\006\000\227\000\207\000\000\000\000\002O\000\000\000\000\000\213\000\226\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\221\000\232\000\000\000\222\000\000\000\224\000\000\000\000\000\000\000\232\000\000\000\236\000\000\000\000\001\006\000\000\000\000\000\000\000\252\000\000\000\000\000\000\000\000\000\252\000\000\000\227\000\000\000\224\000\000\002^\000\227\000\207\000\221\000\000\002\252\000\222\000\000\000\213\000\226\000\207\000\252\000\221\000\000\000\000\000\222\000\213\000\226\000\227\000\232\000\000\000\000\003^\000\236\000\000\000\000\001\006\000\000\000\236\000\000\000\224\001\006\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\224\000\000\000\232\000\000\000\221\000\000\000\236\000\222\000\000\001\006\000\207\000\000\000\000\000\000\000\000\000\000\000\213\000\226\000\252\000\000\000\000\000\000\000\000\000\000\000\000\000\227\000\252\000\000\000\000\003\237\000\000\000\224\000\207\000\227\000\232\000\000\000\000\003\241\000\213\000\226\000\000\000\000\000\221\000\232\000\000\000\222\000\000\000\000\000\000\000\000\000\000\000\000\000\236\000\000\000\000\001\006\000\000\000\000\000\000\000\000\000\236\000\000\000\000\001\006\000\207\000\252\000\000\000\000\000\000\000\224\000\213\000\226\000\227\000\207\000\232\000\000\004y\000\000\000\000\000\213\000\226\000\221\000\000\000\000\000\222\000\000\000\000\000\252\000\000\000\000\000\000\000\000\000\000\000\000\000\227\000\000\000\000\000\000\004~\000\236\000\000\000\000\001\006\000\000\000\207\000\000\000\221\000\000\000\224\000\222\000\213\000\226\000\232\000\000\000\221\000\000\000\000\000\222\000\000\000\252\000\000\000\236\000\000\000\000\001\006\000\000\000\227\000\000\000\252\000\000\004\159\000\000\000\000\000\224\000\000\000\227\000\000\000\000\000\000\004\182\000\000\000\224\000\207\000\000\000\000\000\000\000\000\000\000\000\213\000\226\000\000\000\232\000\221\000\236\000\000\000\222\001\006\000\000\000\000\000\252\000\000\000\000\000\236\000\000\000\000\001\006\000\227\000\000\000\000\000\000\004\199\000\221\000\000\000\000\000\222\000\000\000\232\000\000\000\000\000\224\000\000\000\207\000\000\000\221\000\232\000\000\000\222\000\213\000\226\000\000\000\000\000\000\000\000\000\236\000\000\000\000\001\006\000\252\000\224\000\000\000\000\000\000\000\000\000\000\000\227\000\000\000\207\000\000\004\204\000\000\000\224\000\000\000\213\000\226\000\207\000\221\000\000\000\000\005\199\000\000\000\213\000\226\000\232\000\221\000\000\000\000\005\199\000\000\000\000\000\000\000\000\000\236\000\000\000\000\001\006\000\000\000\252\000\000\000\000\000\000\000\000\000\232\000\224\000\227\000\000\000\000\000\000\004\227\000\000\000\000\000\224\000\000\000\207\000\232\000\000\000\000\000\000\000\000\000\213\000\226\000\000\000\252\000\000\000\000\000\221\000\000\000\000\005\199\000\227\000\252\000\236\000\207\005\021\001\006\000\000\000\000\000\227\000\213\000\226\000\000\005o\000\221\000\000\000\207\005\199\005\201\000\000\000\000\000\000\000\213\000\226\000\224\000\000\005\201\000\000\000\236\000\000\000\000\001\006\000\000\000\000\000\000\000\000\000\236\000\000\000\000\001\006\000\252\000\224\000\221\000\000\000\000\005\199\000\221\000\227\000\207\000\222\000\000\005{\000\000\000\000\000\213\005\204\000\207\000\000\000\000\000\252\000\000\000\000\000\213\005\204\000\000\000\000\000\227\005\201\000\000\000\224\005\149\000\252\000\000\000\224\000\236\000\000\000\000\001\006\000\227\000\000\000\000\000\000\005\165\000\000\005\201\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\236\000\000\000\000\001\006\000\207\000\000\000\000\000\000\000\000\000\000\000\213\005\204\000\236\000\000\000\000\001\006\000\000\005\205\000\000\005\201\000\000\000\207\000\000\000\232\000\000\005\205\000\000\000\213\005\204\005\152\000\000\005\208\000\000\005\207\000\000\000\000\000\000\005\152\000\000\005\206\000\000\005\207\000\000\000\221\000\236\000\000\000\222\000\000\000\000\000\207\000\000\000\000\000\236\000\207\000\000\000\213\005\204\000\000\000\000\000\213\000\226\000\000\000\000\000\000\000\000\000\000\005\205\000\000\000\000\000\000\000\224\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\152\000\000\005\218\000\000\005\207\005\205\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\236\000\000\005\152\000\000\006B\000\000\005\207\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\252\000\000\000\236\005\205\000\000\000\232\000\000\000\227\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\152\000\000\006Z\000\000\005\207\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\236\000\000\000\000\000\000\000\236\000\207\000\000\002\134\000\000\000\000\000\000\000\213\000\226\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\252\000\000\000\000\000\000\000\000\000\000\000\000\000\227\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\236\000\000\000\000\002\136"))
+  
+  and semantic_action =
+    [|
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3915 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( "+" )
+# 1473 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3916 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( "+." )
+# 1498 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.core_type) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.core_type) = 
+# 3466 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 1523 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = tyvar;
+          MenhirLib.EngineTypes.startp = _startpos_tyvar_;
+          MenhirLib.EngineTypes.endp = _endpos_tyvar_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = ty;
+                MenhirLib.EngineTypes.startp = _startpos_ty_;
+                MenhirLib.EngineTypes.endp = _endpos_ty_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let tyvar : (string) = Obj.magic tyvar in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let ty : (Parsetree.core_type) = Obj.magic ty in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_ty_ in
+        let _endpos = _endpos_tyvar_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 = 
+# 3469 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ptyp_alias(ty, tyvar) )
+# 1570 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let (_endpos__1_, _startpos__1_) = (_endpos_tyvar_, _startpos_ty_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 1579 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3471 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 1585 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined2;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = body;
+            MenhirLib.EngineTypes.startp = _startpos_body_;
+            MenhirLib.EngineTypes.endp = _endpos_body_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let body : (Parsetree.pattern * Parsetree.expression * bool) = Obj.magic body in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined2_ in
+        let _v : (Ast_helper.let_binding) = let attrs2 =
+          let _1 = _1_inlined2 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 1633 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_attrs2_ = _endpos__1_inlined2_ in
+        let attrs1 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 1642 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_attrs2_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2715 "src/ocaml/preprocess/parser_raw.mly"
+    (
+      let attrs = attrs1 @ attrs2 in
+      mklb ~loc:_sloc false body attrs
+    )
+# 1654 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Longident.t) = 
+# 3800 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 1679 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Longident.t) = 
+# 3801 "src/ocaml/preprocess/parser_raw.mly"
+                                 ( Lident _1 )
+# 1704 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (Parsetree.core_type) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.core_type) = 
+# 3527 "src/ocaml/preprocess/parser_raw.mly"
+      ( _2 )
+# 1743 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined3;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined2;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined1;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _2;
+                  MenhirLib.EngineTypes.startp = _startpos__2_;
+                  MenhirLib.EngineTypes.endp = _endpos__2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let _1_inlined3 : (Parsetree.module_type) = Obj.magic _1_inlined3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.core_type) = let _4 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 3587 "src/ocaml/preprocess/parser_raw.mly"
+      ( let (lid, cstrs, attrs) = package_type_of_module_type _1 in
+        let descr = Ptyp_package (lid, cstrs) in
+        mktyp ~loc:_sloc ~attrs descr )
+# 1810 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _3 =
+          let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+          let _2 =
+            let _1 = _1_inlined1 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 1820 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 1826 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__5_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3529 "src/ocaml/preprocess/parser_raw.mly"
+      ( wrap_typ_attrs ~loc:_sloc (reloc_typ ~loc:_sloc _4) _3 )
+# 1835 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (string) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 = 
+# 3532 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ptyp_var _2 )
+# 1868 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos__2_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 1877 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3564 "src/ocaml/preprocess/parser_raw.mly"
+  ( _1 )
+# 1883 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 = 
+# 3534 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ptyp_any )
+# 1909 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 1917 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3564 "src/ocaml/preprocess/parser_raw.mly"
+  ( _1 )
+# 1923 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 =
+            let tid =
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 1954 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let tys = 
+# 3579 "src/ocaml/preprocess/parser_raw.mly"
+      ( [] )
+# 1960 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 3537 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ptyp_constr(tid, tys) )
+# 1965 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 1974 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3564 "src/ocaml/preprocess/parser_raw.mly"
+  ( _1 )
+# 1980 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = ty;
+            MenhirLib.EngineTypes.startp = _startpos_ty_;
+            MenhirLib.EngineTypes.endp = _endpos_ty_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let ty : (Parsetree.core_type) = Obj.magic ty in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_ty_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 =
+            let tid =
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 2018 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let tys = 
+# 3581 "src/ocaml/preprocess/parser_raw.mly"
+      ( [ty] )
+# 2024 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 3537 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ptyp_constr(tid, tys) )
+# 2029 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _startpos__1_ = _startpos_ty_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 2039 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3564 "src/ocaml/preprocess/parser_raw.mly"
+  ( _1 )
+# 2045 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = xs;
+              MenhirLib.EngineTypes.startp = _startpos_xs_;
+              MenhirLib.EngineTypes.endp = _endpos_xs_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (Longident.t) = Obj.magic _1_inlined1 in
+        let _3 : unit = Obj.magic _3 in
+        let xs : (Parsetree.core_type list) = Obj.magic xs in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 =
+            let tid =
+              let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 2098 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let tys =
+              let tys =
+                let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 2106 "src/ocaml/preprocess/parser_raw.ml"
+                 in
+                
+# 1142 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 2111 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 3583 "src/ocaml/preprocess/parser_raw.mly"
+      ( tys )
+# 2117 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 3537 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ptyp_constr(tid, tys) )
+# 2123 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__1_inlined1_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 2133 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3564 "src/ocaml/preprocess/parser_raw.mly"
+  ( _1 )
+# 2139 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (Parsetree.object_field list * Asttypes.closed_flag) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 = 
+# 3539 "src/ocaml/preprocess/parser_raw.mly"
+        ( let (f, c) = _2 in Ptyp_object (f, c) )
+# 2179 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos__3_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 2188 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3564 "src/ocaml/preprocess/parser_raw.mly"
+  ( _1 )
+# 2194 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 = 
+# 3541 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ptyp_object ([], Closed) )
+# 2227 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos__2_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 2236 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3564 "src/ocaml/preprocess/parser_raw.mly"
+  ( _1 )
+# 2242 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _2 : unit = Obj.magic _2 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__2_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 =
+            let cid =
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 2280 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let tys = 
+# 3579 "src/ocaml/preprocess/parser_raw.mly"
+      ( [] )
+# 2286 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 3545 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ptyp_class(cid, tys) )
+# 2291 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _startpos__1_ = _startpos__2_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 2301 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3564 "src/ocaml/preprocess/parser_raw.mly"
+  ( _1 )
+# 2307 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = ty;
+              MenhirLib.EngineTypes.startp = _startpos_ty_;
+              MenhirLib.EngineTypes.endp = _endpos_ty_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _2 : unit = Obj.magic _2 in
+        let ty : (Parsetree.core_type) = Obj.magic ty in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_ty_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 =
+            let cid =
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 2352 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let tys = 
+# 3581 "src/ocaml/preprocess/parser_raw.mly"
+      ( [ty] )
+# 2358 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 3545 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ptyp_class(cid, tys) )
+# 2363 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _startpos__1_ = _startpos_ty_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 2373 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3564 "src/ocaml/preprocess/parser_raw.mly"
+  ( _1 )
+# 2379 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = xs;
+                MenhirLib.EngineTypes.startp = _startpos_xs_;
+                MenhirLib.EngineTypes.endp = _endpos_xs_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (Longident.t) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _3 : unit = Obj.magic _3 in
+        let xs : (Parsetree.core_type list) = Obj.magic xs in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 =
+            let cid =
+              let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 2439 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let tys =
+              let tys =
+                let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 2447 "src/ocaml/preprocess/parser_raw.ml"
+                 in
+                
+# 1142 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 2452 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 3583 "src/ocaml/preprocess/parser_raw.mly"
+      ( tys )
+# 2458 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 3545 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ptyp_class(cid, tys) )
+# 2464 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__1_inlined1_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 2474 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3564 "src/ocaml/preprocess/parser_raw.mly"
+  ( _1 )
+# 2480 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (Parsetree.row_field) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 = 
+# 3548 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ptyp_variant([_2], Closed, None) )
+# 2520 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos__3_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 2529 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3564 "src/ocaml/preprocess/parser_raw.mly"
+  ( _1 )
+# 2535 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = xs;
+            MenhirLib.EngineTypes.startp = _startpos_xs_;
+            MenhirLib.EngineTypes.endp = _endpos_xs_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : unit = Obj.magic _4 in
+        let xs : (Parsetree.row_field list) = Obj.magic xs in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 =
+            let _3 =
+              let _1 =
+                let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 2585 "src/ocaml/preprocess/parser_raw.ml"
+                 in
+                
+# 1114 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 2590 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 3593 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 2596 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 3550 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ptyp_variant(_3, Closed, None) )
+# 2602 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__4_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 2612 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3564 "src/ocaml/preprocess/parser_raw.mly"
+  ( _1 )
+# 2618 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = xs;
+            MenhirLib.EngineTypes.startp = _startpos_xs_;
+            MenhirLib.EngineTypes.endp = _endpos_xs_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let xs : (Parsetree.row_field list) = Obj.magic xs in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (Parsetree.row_field) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 =
+            let _4 =
+              let _1 =
+                let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 2675 "src/ocaml/preprocess/parser_raw.ml"
+                 in
+                
+# 1114 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 2680 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 3593 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 2686 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 3552 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ptyp_variant(_2 :: _4, Closed, None) )
+# 2692 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__5_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 2702 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3564 "src/ocaml/preprocess/parser_raw.mly"
+  ( _1 )
+# 2708 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = xs;
+            MenhirLib.EngineTypes.startp = _startpos_xs_;
+            MenhirLib.EngineTypes.endp = _endpos_xs_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : unit = Obj.magic _4 in
+        let xs : (Parsetree.row_field list) = Obj.magic xs in
+        let _2 : (unit option) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 =
+            let _3 =
+              let _1 =
+                let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 2758 "src/ocaml/preprocess/parser_raw.ml"
+                 in
+                
+# 1114 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 2763 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 3593 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 2769 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 3554 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ptyp_variant(_3, Open, None) )
+# 2775 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__4_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 2785 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3564 "src/ocaml/preprocess/parser_raw.mly"
+  ( _1 )
+# 2791 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 = 
+# 3556 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ptyp_variant([], Open, None) )
+# 2824 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos__2_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 2833 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3564 "src/ocaml/preprocess/parser_raw.mly"
+  ( _1 )
+# 2839 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = xs;
+            MenhirLib.EngineTypes.startp = _startpos_xs_;
+            MenhirLib.EngineTypes.endp = _endpos_xs_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : unit = Obj.magic _4 in
+        let xs : (Parsetree.row_field list) = Obj.magic xs in
+        let _2 : (unit option) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 =
+            let _3 =
+              let _1 =
+                let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 2889 "src/ocaml/preprocess/parser_raw.ml"
+                 in
+                
+# 1114 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 2894 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 3593 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 2900 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 3558 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ptyp_variant(_3, Closed, Some []) )
+# 2906 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__4_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 2916 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3564 "src/ocaml/preprocess/parser_raw.mly"
+  ( _1 )
+# 2922 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _6;
+          MenhirLib.EngineTypes.startp = _startpos__6_;
+          MenhirLib.EngineTypes.endp = _endpos__6_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = xs_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos_xs_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos_xs_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _4;
+              MenhirLib.EngineTypes.startp = _startpos__4_;
+              MenhirLib.EngineTypes.endp = _endpos__4_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = xs;
+                MenhirLib.EngineTypes.startp = _startpos_xs_;
+                MenhirLib.EngineTypes.endp = _endpos_xs_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _2;
+                  MenhirLib.EngineTypes.startp = _startpos__2_;
+                  MenhirLib.EngineTypes.endp = _endpos__2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _6 : unit = Obj.magic _6 in
+        let xs_inlined1 : (string list) = Obj.magic xs_inlined1 in
+        let _4 : unit = Obj.magic _4 in
+        let xs : (Parsetree.row_field list) = Obj.magic xs in
+        let _2 : (unit option) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__6_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 =
+            let _5 =
+              let xs = xs_inlined1 in
+              let _1 =
+                let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 2987 "src/ocaml/preprocess/parser_raw.ml"
+                 in
+                
+# 1082 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 2992 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 3621 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 2998 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let _3 =
+              let _1 =
+                let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 3006 "src/ocaml/preprocess/parser_raw.ml"
+                 in
+                
+# 1114 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 3011 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 3593 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 3017 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 3560 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ptyp_variant(_3, Closed, Some _5) )
+# 3023 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__6_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 3033 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3564 "src/ocaml/preprocess/parser_raw.mly"
+  ( _1 )
+# 3039 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.extension) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 = 
+# 3562 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ptyp_extension _1 )
+# 3065 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 3073 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3564 "src/ocaml/preprocess/parser_raw.mly"
+  ( _1 )
+# 3079 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string Location.loc) = let _1 =
+          let _1 = 
+# 3982 "src/ocaml/preprocess/parser_raw.mly"
+                     ( _1 )
+# 3105 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1010 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkloc _1 (make_loc _sloc) )
+# 3113 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3984 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 3119 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (string Location.loc) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (string Location.loc) = let _1 =
+          let _1 = 
+# 3983 "src/ocaml/preprocess/parser_raw.mly"
+                                 ( _1 ^ "." ^ _3.txt )
+# 3159 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos__3_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1010 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkloc _1 (make_loc _sloc) )
+# 3168 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3984 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 3174 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (Parsetree.payload) = Obj.magic _3 in
+        let _2 : (string Location.loc) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (Parsetree.attribute) = let _endpos = _endpos__4_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3988 "src/ocaml/preprocess/parser_raw.mly"
+    ( Attr.mk ~loc:(make_loc _sloc) _2 _3 )
+# 3223 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.class_expr) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.class_expr) = 
+# 1974 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 3248 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.class_expr) = Obj.magic _3 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.class_expr) = let _2 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 3289 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__3_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 1976 "src/ocaml/preprocess/parser_raw.mly"
+      ( wrap_class_attrs ~loc:_sloc _3 _2 )
+# 3298 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.class_expr) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Ast_helper.let_bindings) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.class_expr) = let _endpos = _endpos__3_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 1978 "src/ocaml/preprocess/parser_raw.mly"
+      ( class_of_let_bindings ~loc:_sloc _1 _3 )
+# 3340 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _7;
+          MenhirLib.EngineTypes.startp = _startpos__7_;
+          MenhirLib.EngineTypes.endp = _endpos__7_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _6;
+            MenhirLib.EngineTypes.startp = _startpos__6_;
+            MenhirLib.EngineTypes.endp = _endpos__6_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined2;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined1;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _2;
+                  MenhirLib.EngineTypes.startp = _startpos__2_;
+                  MenhirLib.EngineTypes.endp = _endpos__2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _7 : (Parsetree.class_expr) = Obj.magic _7 in
+        let _6 : unit = Obj.magic _6 in
+        let _1_inlined2 : (Longident.t) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__7_ in
+        let _v : (Parsetree.class_expr) = let _5 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 3405 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__5_ = _endpos__1_inlined2_ in
+        let _4 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 3414 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _3 = 
+# 3907 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Fresh )
+# 3420 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let _endpos = _endpos__7_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 1980 "src/ocaml/preprocess/parser_raw.mly"
+      ( let loc = (_startpos__2_, _endpos__5_) in
+        let od = Opn.mk ~override:_3 ~loc:(make_loc loc) _5 in
+        mkclass ~loc:_sloc ~attrs:_4 (Pcl_open(od, _7)) )
+# 3430 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _7;
+          MenhirLib.EngineTypes.startp = _startpos__7_;
+          MenhirLib.EngineTypes.endp = _endpos__7_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _6;
+            MenhirLib.EngineTypes.startp = _startpos__6_;
+            MenhirLib.EngineTypes.endp = _endpos__6_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined3;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _2;
+                    MenhirLib.EngineTypes.startp = _startpos__2_;
+                    MenhirLib.EngineTypes.endp = _endpos__2_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = _1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _7 : (Parsetree.class_expr) = Obj.magic _7 in
+        let _6 : unit = Obj.magic _6 in
+        let _1_inlined3 : (Longident.t) = Obj.magic _1_inlined3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : unit = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__7_ in
+        let _v : (Parsetree.class_expr) = let _5 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 3502 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__5_ = _endpos__1_inlined3_ in
+        let _4 =
+          let _1 = _1_inlined2 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 3511 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _3 =
+          let _1 = _1_inlined1 in
+          
+# 3908 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Override )
+# 3519 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__7_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 1980 "src/ocaml/preprocess/parser_raw.mly"
+      ( let loc = (_startpos__2_, _endpos__5_) in
+        let od = Opn.mk ~override:_3 ~loc:(make_loc loc) _5 in
+        mkclass ~loc:_sloc ~attrs:_4 (Pcl_open(od, _7)) )
+# 3530 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.attribute) = Obj.magic _2 in
+        let _1 : (Parsetree.class_expr) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.class_expr) = 
+# 1984 "src/ocaml/preprocess/parser_raw.mly"
+      ( Cl.attr _1 _2 )
+# 3562 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let xs : ((Asttypes.arg_label * Parsetree.expression) list) = Obj.magic xs in
+        let _1 : (Parsetree.class_expr) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.class_expr) = let _1 =
+          let _1 =
+            let _2 =
+              let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 3597 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              
+# 1082 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 3602 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 1987 "src/ocaml/preprocess/parser_raw.mly"
+        ( Pcl_apply(_1, _2) )
+# 3608 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos_xs_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1033 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkclass ~loc:_sloc _1 )
+# 3618 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1990 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 3624 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.extension) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.class_expr) = let _1 =
+          let _1 = 
+# 1989 "src/ocaml/preprocess/parser_raw.mly"
+        ( Pcl_extension _1 )
+# 3650 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1033 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkclass ~loc:_sloc _1 )
+# 3658 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1990 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 3664 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined2;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = self;
+            MenhirLib.EngineTypes.startp = _startpos_self_;
+            MenhirLib.EngineTypes.endp = _endpos_self_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _4;
+              MenhirLib.EngineTypes.startp = _startpos__4_;
+              MenhirLib.EngineTypes.endp = _endpos__4_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined1;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let self : (string Location.loc option) = Obj.magic self in
+        let _4 : (Parsetree.class_expr) = Obj.magic _4 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined2_ in
+        let _v : (Parsetree.class_field) = let _6 =
+          let _1 = _1_inlined2 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 3719 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__6_ = _endpos__1_inlined2_ in
+        let _3 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 3728 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _2 = 
+# 3907 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Fresh )
+# 3734 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let _endpos = _endpos__6_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2045 "src/ocaml/preprocess/parser_raw.mly"
+      ( let docs = symbol_docs _sloc in
+        mkcf ~loc:_sloc (Pcf_inherit (_2, _4, self)) ~attrs:(_3@_6) ~docs )
+# 3743 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined3;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = self;
+            MenhirLib.EngineTypes.startp = _startpos_self_;
+            MenhirLib.EngineTypes.endp = _endpos_self_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _4;
+              MenhirLib.EngineTypes.startp = _startpos__4_;
+              MenhirLib.EngineTypes.endp = _endpos__4_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let self : (string Location.loc option) = Obj.magic self in
+        let _4 : (Parsetree.class_expr) = Obj.magic _4 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : unit = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined3_ in
+        let _v : (Parsetree.class_field) = let _6 =
+          let _1 = _1_inlined3 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 3805 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__6_ = _endpos__1_inlined3_ in
+        let _3 =
+          let _1 = _1_inlined2 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 3814 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _2 =
+          let _1 = _1_inlined1 in
+          
+# 3908 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Override )
+# 3822 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__6_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2045 "src/ocaml/preprocess/parser_raw.mly"
+      ( let docs = symbol_docs _sloc in
+        mkcf ~loc:_sloc (Pcf_inherit (_2, _4, self)) ~attrs:(_3@_6) ~docs )
+# 3832 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _2 : ((string Location.loc * Asttypes.mutable_flag * Parsetree.class_field_kind) *
+  Parsetree.attributes) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (Parsetree.class_field) = let _3 =
+          let _1 = _1_inlined1 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 3874 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__3_ = _endpos__1_inlined1_ in
+        let _endpos = _endpos__3_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2048 "src/ocaml/preprocess/parser_raw.mly"
+      ( let v, attrs = _2 in
+        let docs = symbol_docs _sloc in
+        mkcf ~loc:_sloc (Pcf_val v) ~attrs:(attrs@_3) ~docs )
+# 3886 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _2 : ((string Location.loc * Asttypes.private_flag * Parsetree.class_field_kind) *
+  Parsetree.attributes) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (Parsetree.class_field) = let _3 =
+          let _1 = _1_inlined1 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 3928 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__3_ = _endpos__1_inlined1_ in
+        let _endpos = _endpos__3_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2052 "src/ocaml/preprocess/parser_raw.mly"
+      ( let meth, attrs = _2 in
+        let docs = symbol_docs _sloc in
+        mkcf ~loc:_sloc (Pcf_method meth) ~attrs:(attrs@_3) ~docs )
+# 3940 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined2;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _3 : (Parsetree.core_type * Parsetree.core_type) = Obj.magic _3 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined2_ in
+        let _v : (Parsetree.class_field) = let _4 =
+          let _1 = _1_inlined2 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 3988 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__4_ = _endpos__1_inlined2_ in
+        let _2 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 3997 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__4_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2056 "src/ocaml/preprocess/parser_raw.mly"
+      ( let docs = symbol_docs _sloc in
+        mkcf ~loc:_sloc (Pcf_constraint _3) ~attrs:(_2@_4) ~docs )
+# 4007 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined2;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _3 : (Parsetree.expression) = Obj.magic _3 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined2_ in
+        let _v : (Parsetree.class_field) = let _4 =
+          let _1 = _1_inlined2 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 4055 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__4_ = _endpos__1_inlined2_ in
+        let _2 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 4064 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__4_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2059 "src/ocaml/preprocess/parser_raw.mly"
+      ( let docs = symbol_docs _sloc in
+        mkcf ~loc:_sloc (Pcf_initializer _3) ~attrs:(_2@_4) ~docs )
+# 4074 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : (Parsetree.extension) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (Parsetree.class_field) = let _2 =
+          let _1 = _1_inlined1 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 4108 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__2_ = _endpos__1_inlined1_ in
+        let _endpos = _endpos__2_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2062 "src/ocaml/preprocess/parser_raw.mly"
+      ( let docs = symbol_docs _sloc in
+        mkcf ~loc:_sloc (Pcf_extension _1) ~attrs:_2 ~docs )
+# 4119 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.attribute) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.class_field) = let _1 =
+          let _1 = 
+# 2065 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pcf_attribute _1 )
+# 4145 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1031 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkcf ~loc:_sloc _1 )
+# 4153 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2066 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 4159 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.class_expr) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.class_expr) = 
+# 1954 "src/ocaml/preprocess/parser_raw.mly"
+      ( _2 )
+# 4191 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : (Parsetree.class_expr) = Obj.magic _4 in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (Parsetree.class_type) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (Parsetree.class_expr) = let _1 =
+          let _1 = 
+# 1957 "src/ocaml/preprocess/parser_raw.mly"
+        ( Pcl_constraint(_4, _2) )
+# 4238 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos__4_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1033 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkclass ~loc:_sloc _1 )
+# 4247 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1960 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 4253 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.class_expr) = Obj.magic _2 in
+        let _1 : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.class_expr) = let _1 =
+          let _1 = 
+# 1959 "src/ocaml/preprocess/parser_raw.mly"
+      ( let (l,o,p) = _1 in Pcl_fun(l, o, p, _2) )
+# 4286 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos__2_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1033 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkclass ~loc:_sloc _1 )
+# 4295 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1960 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 4301 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = e;
+          MenhirLib.EngineTypes.startp = _startpos_e_;
+          MenhirLib.EngineTypes.endp = _endpos_e_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let e : (Parsetree.class_expr) = Obj.magic e in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_e_ in
+        let _v : (Parsetree.class_expr) = let _1 =
+          let _1 = 
+# 2021 "src/ocaml/preprocess/parser_raw.mly"
+      ( let (l,o,p) = _1 in Pcl_fun(l, o, p, e) )
+# 4341 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos_e_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1033 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkclass ~loc:_sloc _1 )
+# 4350 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2022 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 4356 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = e;
+          MenhirLib.EngineTypes.startp = _startpos_e_;
+          MenhirLib.EngineTypes.endp = _endpos_e_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let e : (Parsetree.class_expr) = Obj.magic e in
+        let _1 : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_e_ in
+        let _v : (Parsetree.class_expr) = let _1 =
+          let _1 = 
+# 2021 "src/ocaml/preprocess/parser_raw.mly"
+      ( let (l,o,p) = _1 in Pcl_fun(l, o, p, e) )
+# 4389 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos_e_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1033 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkclass ~loc:_sloc _1 )
+# 4398 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2022 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 4404 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Longident.t) = 
+# 3790 "src/ocaml/preprocess/parser_raw.mly"
+                                       ( _1 )
+# 4429 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (Parsetree.pattern) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.pattern) = let _endpos = _endpos__3_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2030 "src/ocaml/preprocess/parser_raw.mly"
+      ( reloc_pat ~loc:_sloc _2 )
+# 4471 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let _4 : (Parsetree.core_type) = Obj.magic _4 in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (Parsetree.pattern) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 = 
+# 2032 "src/ocaml/preprocess/parser_raw.mly"
+      ( Ppat_constraint(_2, _4) )
+# 4525 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos__5_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 4534 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2033 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 4540 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Parsetree.pattern) = let _endpos = _endpos__0_ in
+        let _symbolstartpos = _endpos in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2035 "src/ocaml/preprocess/parser_raw.mly"
+      ( ghpat ~loc:_sloc Ppat_any )
+# 4561 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (Parsetree.core_type) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.core_type) = 
+# 2162 "src/ocaml/preprocess/parser_raw.mly"
+      ( _2 )
+# 4600 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 = 
+# 2163 "src/ocaml/preprocess/parser_raw.mly"
+                      ( Ptyp_any )
+# 4619 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos__0_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _endpos in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 4628 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2164 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 4634 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined2;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _3 : (Parsetree.class_type) = Obj.magic _3 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined2_ in
+        let _v : (Parsetree.class_type_field) = let _4 =
+          let _1 = _1_inlined2 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 4682 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__4_ = _endpos__1_inlined2_ in
+        let _2 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 4691 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__4_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2172 "src/ocaml/preprocess/parser_raw.mly"
+      ( let docs = symbol_docs _sloc in
+        mkctf ~loc:_sloc (Pctf_inherit _3) ~attrs:(_2@_4) ~docs )
+# 4701 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined3;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = ty;
+            MenhirLib.EngineTypes.startp = _startpos_ty_;
+            MenhirLib.EngineTypes.endp = _endpos_ty_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = flags;
+                  MenhirLib.EngineTypes.startp = _startpos_flags_;
+                  MenhirLib.EngineTypes.endp = _endpos_flags_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1_inlined1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = _1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let ty : (Parsetree.core_type) = Obj.magic ty in
+        let _3 : unit = Obj.magic _3 in
+        let _1_inlined2 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 4761 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined2 in
+        let flags : (Asttypes.mutable_flag * Asttypes.virtual_flag) = Obj.magic flags in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined3_ in
+        let _v : (Parsetree.class_type_field) = let _4 =
+          let _1 = _1_inlined3 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 4774 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__4_ = _endpos__1_inlined3_ in
+        let _3 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let label =
+            let _1 = 
+# 3661 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 4784 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 4792 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2197 "src/ocaml/preprocess/parser_raw.mly"
+  (
+    let mut, virt = flags in
+    label, mut, virt, ty
+  )
+# 4801 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _2 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 4809 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__4_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2175 "src/ocaml/preprocess/parser_raw.mly"
+      ( let docs = symbol_docs _sloc in
+        mkctf ~loc:_sloc (Pctf_val _3) ~attrs:(_2@_4) ~docs )
+# 4819 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined4;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined4_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined3;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _5;
+              MenhirLib.EngineTypes.startp = _startpos__5_;
+              MenhirLib.EngineTypes.endp = _endpos__5_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _3;
+                  MenhirLib.EngineTypes.startp = _startpos__3_;
+                  MenhirLib.EngineTypes.endp = _endpos__3_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1_inlined1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = _1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined4 : (Parsetree.attributes) = Obj.magic _1_inlined4 in
+        let _1_inlined3 : (Parsetree.core_type) = Obj.magic _1_inlined3 in
+        let _5 : unit = Obj.magic _5 in
+        let _1_inlined2 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 4879 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined2 in
+        let _3 : (Asttypes.private_flag * Asttypes.virtual_flag) = Obj.magic _3 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined4_ in
+        let _v : (Parsetree.class_type_field) = let _7 =
+          let _1 = _1_inlined4 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 4892 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__7_ = _endpos__1_inlined4_ in
+        let _6 =
+          let _1 = _1_inlined3 in
+          
+# 3432 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 4901 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _4 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let _1 = 
+# 3661 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 4909 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 4917 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _2 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 4925 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__7_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2179 "src/ocaml/preprocess/parser_raw.mly"
+      ( let (p, v) = _3 in
+        let docs = symbol_docs _sloc in
+        mkctf ~loc:_sloc (Pctf_method (_4, p, v, _6)) ~attrs:(_2@_7) ~docs )
+# 4936 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined2;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _3 : (Parsetree.core_type * Parsetree.core_type) = Obj.magic _3 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined2_ in
+        let _v : (Parsetree.class_type_field) = let _4 =
+          let _1 = _1_inlined2 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 4984 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__4_ = _endpos__1_inlined2_ in
+        let _2 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 4993 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__4_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2183 "src/ocaml/preprocess/parser_raw.mly"
+      ( let docs = symbol_docs _sloc in
+        mkctf ~loc:_sloc (Pctf_constraint _3) ~attrs:(_2@_4) ~docs )
+# 5003 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : (Parsetree.extension) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (Parsetree.class_type_field) = let _2 =
+          let _1 = _1_inlined1 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 5037 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__2_ = _endpos__1_inlined1_ in
+        let _endpos = _endpos__2_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2186 "src/ocaml/preprocess/parser_raw.mly"
+      ( let docs = symbol_docs _sloc in
+        mkctf ~loc:_sloc (Pctf_extension _1) ~attrs:_2 ~docs )
+# 5048 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.attribute) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.class_type_field) = let _1 =
+          let _1 = 
+# 2189 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pctf_attribute _1 )
+# 5074 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1029 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkctf ~loc:_sloc _1 )
+# 5082 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2190 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 5088 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.class_type) = let _1 =
+          let _1 =
+            let cid =
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 5119 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let tys =
+              let tys = 
+# 2148 "src/ocaml/preprocess/parser_raw.mly"
+      ( [] )
+# 5126 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              
+# 2154 "src/ocaml/preprocess/parser_raw.mly"
+    ( tys )
+# 5131 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2129 "src/ocaml/preprocess/parser_raw.mly"
+        ( Pcty_constr (cid, tys) )
+# 5137 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1027 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkcty ~loc:_sloc _1 )
+# 5146 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2132 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 5152 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = xs;
+              MenhirLib.EngineTypes.startp = _startpos_xs_;
+              MenhirLib.EngineTypes.endp = _endpos_xs_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (Longident.t) = Obj.magic _1_inlined1 in
+        let _3 : unit = Obj.magic _3 in
+        let xs : (Parsetree.core_type list) = Obj.magic xs in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (Parsetree.class_type) = let _1 =
+          let _1 =
+            let cid =
+              let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 5205 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let tys =
+              let tys =
+                let params =
+                  let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 5214 "src/ocaml/preprocess/parser_raw.ml"
+                   in
+                  
+# 1114 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 5219 "src/ocaml/preprocess/parser_raw.ml"
+                  
+                in
+                
+# 2150 "src/ocaml/preprocess/parser_raw.mly"
+      ( params )
+# 5225 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 2154 "src/ocaml/preprocess/parser_raw.mly"
+    ( tys )
+# 5231 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2129 "src/ocaml/preprocess/parser_raw.mly"
+        ( Pcty_constr (cid, tys) )
+# 5237 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__1_inlined1_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1027 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkcty ~loc:_sloc _1 )
+# 5247 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2132 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 5253 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.extension) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.class_type) = let _1 =
+          let _1 = 
+# 2131 "src/ocaml/preprocess/parser_raw.mly"
+        ( Pcty_extension _1 )
+# 5279 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1027 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkcty ~loc:_sloc _1 )
+# 5287 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2132 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 5293 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = xss;
+            MenhirLib.EngineTypes.startp = _startpos_xss_;
+            MenhirLib.EngineTypes.endp = _endpos_xss_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined2;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined1;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : unit = Obj.magic _4 in
+        let xss : (Parsetree.class_type_field list list) = Obj.magic xss in
+        let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (Parsetree.class_type) = let _3 =
+          let _1 = _1_inlined2 in
+          let _2 =
+            let _1 =
+              let _1 = 
+# 260 "<standard.mly>"
+    ( List.flatten xss )
+# 5350 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              
+# 2168 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 5355 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_xss_) in
+            let _endpos = _endpos__1_ in
+            let _startpos = _startpos__1_ in
+            
+# 975 "src/ocaml/preprocess/parser_raw.mly"
+                               ( extra_csig _startpos _endpos _1 )
+# 5364 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2158 "src/ocaml/preprocess/parser_raw.mly"
+      ( Csig.mk _1 _2 )
+# 5370 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _2 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 5378 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__4_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2134 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkcty ~loc:_sloc ~attrs:_2 (Pcty_signature _3) )
+# 5387 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.attribute) = Obj.magic _2 in
+        let _1 : (Parsetree.class_type) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.class_type) = 
+# 2140 "src/ocaml/preprocess/parser_raw.mly"
+      ( Cty.attr _1 _2 )
+# 5419 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _7;
+          MenhirLib.EngineTypes.startp = _startpos__7_;
+          MenhirLib.EngineTypes.endp = _endpos__7_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _6;
+            MenhirLib.EngineTypes.startp = _startpos__6_;
+            MenhirLib.EngineTypes.endp = _endpos__6_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined2;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined1;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _2;
+                  MenhirLib.EngineTypes.startp = _startpos__2_;
+                  MenhirLib.EngineTypes.endp = _endpos__2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _7 : (Parsetree.class_type) = Obj.magic _7 in
+        let _6 : unit = Obj.magic _6 in
+        let _1_inlined2 : (Longident.t) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__7_ in
+        let _v : (Parsetree.class_type) = let _5 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 5484 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__5_ = _endpos__1_inlined2_ in
+        let _4 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 5493 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _3 = 
+# 3907 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Fresh )
+# 5499 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let _endpos = _endpos__7_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2142 "src/ocaml/preprocess/parser_raw.mly"
+      ( let loc = (_startpos__2_, _endpos__5_) in
+        let od = Opn.mk ~override:_3 ~loc:(make_loc loc) _5 in
+        mkcty ~loc:_sloc ~attrs:_4 (Pcty_open(od, _7)) )
+# 5509 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _7;
+          MenhirLib.EngineTypes.startp = _startpos__7_;
+          MenhirLib.EngineTypes.endp = _endpos__7_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _6;
+            MenhirLib.EngineTypes.startp = _startpos__6_;
+            MenhirLib.EngineTypes.endp = _endpos__6_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined3;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _2;
+                    MenhirLib.EngineTypes.startp = _startpos__2_;
+                    MenhirLib.EngineTypes.endp = _endpos__2_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = _1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _7 : (Parsetree.class_type) = Obj.magic _7 in
+        let _6 : unit = Obj.magic _6 in
+        let _1_inlined3 : (Longident.t) = Obj.magic _1_inlined3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : unit = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__7_ in
+        let _v : (Parsetree.class_type) = let _5 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 5581 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__5_ = _endpos__1_inlined3_ in
+        let _4 =
+          let _1 = _1_inlined2 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 5590 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _3 =
+          let _1 = _1_inlined1 in
+          
+# 3908 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Override )
+# 5598 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__7_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2142 "src/ocaml/preprocess/parser_raw.mly"
+      ( let loc = (_startpos__2_, _endpos__5_) in
+        let od = Opn.mk ~override:_3 ~loc:(make_loc loc) _5 in
+        mkcty ~loc:_sloc ~attrs:_4 (Pcty_open(od, _7)) )
+# 5609 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (Parsetree.class_expr) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.class_expr) = 
+# 1994 "src/ocaml/preprocess/parser_raw.mly"
+      ( _2 )
+# 5648 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.class_expr) = let _1 =
+          let _1 =
+            let cid =
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 5679 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let tys =
+              let tys = 
+# 2148 "src/ocaml/preprocess/parser_raw.mly"
+      ( [] )
+# 5686 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              
+# 2154 "src/ocaml/preprocess/parser_raw.mly"
+    ( tys )
+# 5691 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2001 "src/ocaml/preprocess/parser_raw.mly"
+        ( Pcl_constr(cid, tys) )
+# 5697 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1033 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkclass ~loc:_sloc _1 )
+# 5706 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2012 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 5712 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = xs;
+              MenhirLib.EngineTypes.startp = _startpos_xs_;
+              MenhirLib.EngineTypes.endp = _endpos_xs_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (Longident.t) = Obj.magic _1_inlined1 in
+        let _3 : unit = Obj.magic _3 in
+        let xs : (Parsetree.core_type list) = Obj.magic xs in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (Parsetree.class_expr) = let _1 =
+          let _1 =
+            let cid =
+              let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 5765 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let tys =
+              let tys =
+                let params =
+                  let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 5774 "src/ocaml/preprocess/parser_raw.ml"
+                   in
+                  
+# 1114 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 5779 "src/ocaml/preprocess/parser_raw.ml"
+                  
+                in
+                
+# 2150 "src/ocaml/preprocess/parser_raw.mly"
+      ( params )
+# 5785 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 2154 "src/ocaml/preprocess/parser_raw.mly"
+    ( tys )
+# 5791 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2001 "src/ocaml/preprocess/parser_raw.mly"
+        ( Pcl_constr(cid, tys) )
+# 5797 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__1_inlined1_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1033 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkclass ~loc:_sloc _1 )
+# 5807 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2012 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 5813 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let _4 : (Parsetree.class_type) = Obj.magic _4 in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (Parsetree.class_expr) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.class_expr) = let _1 =
+          let _1 = 
+# 2007 "src/ocaml/preprocess/parser_raw.mly"
+        ( Pcl_constraint(_2, _4) )
+# 5867 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos__5_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1033 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkclass ~loc:_sloc _1 )
+# 5876 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2012 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 5882 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = xss;
+            MenhirLib.EngineTypes.startp = _startpos_xss_;
+            MenhirLib.EngineTypes.endp = _endpos_xss_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined2;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined1;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : unit = Obj.magic _4 in
+        let xss : (Parsetree.class_field list list) = Obj.magic xss in
+        let _1_inlined2 : (Parsetree.pattern) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (Parsetree.class_expr) = let _3 =
+          let _1 = _1_inlined2 in
+          let _2 =
+            let _1 =
+              let _1 = 
+# 260 "<standard.mly>"
+    ( List.flatten xss )
+# 5939 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              
+# 2039 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 5944 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_xss_) in
+            let _endpos = _endpos__1_ in
+            let _startpos = _startpos__1_ in
+            
+# 974 "src/ocaml/preprocess/parser_raw.mly"
+                               ( extra_cstr _startpos _endpos _1 )
+# 5953 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2026 "src/ocaml/preprocess/parser_raw.mly"
+       ( Cstr.mk _1 _2 )
+# 5959 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _2 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 5967 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__4_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2014 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkclass ~loc:_sloc ~attrs:_2 (Pcl_structure _3) )
+# 5976 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.class_type) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.class_type) = 
+# 2117 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 6001 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = codomain;
+          MenhirLib.EngineTypes.startp = _startpos_codomain_;
+          MenhirLib.EngineTypes.endp = _endpos_codomain_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = domain;
+              MenhirLib.EngineTypes.startp = _startpos_domain_;
+              MenhirLib.EngineTypes.endp = _endpos_domain_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = label;
+                MenhirLib.EngineTypes.startp = _startpos_label_;
+                MenhirLib.EngineTypes.endp = _endpos_label_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let codomain : (Parsetree.class_type) = Obj.magic codomain in
+        let _3 : unit = Obj.magic _3 in
+        let domain : (Parsetree.core_type) = Obj.magic domain in
+        let label : (string) = Obj.magic label in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_label_ in
+        let _endpos = _endpos_codomain_ in
+        let _v : (Parsetree.class_type) = let _1 =
+          let _1 =
+            let label = 
+# 3495 "src/ocaml/preprocess/parser_raw.mly"
+      ( Optional label )
+# 6049 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 2123 "src/ocaml/preprocess/parser_raw.mly"
+        ( Pcty_arrow(label, domain, codomain) )
+# 6054 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1027 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkcty ~loc:_sloc _1 )
+# 6064 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2124 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 6070 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = codomain;
+          MenhirLib.EngineTypes.startp = _startpos_codomain_;
+          MenhirLib.EngineTypes.endp = _endpos_codomain_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = domain;
+              MenhirLib.EngineTypes.startp = _startpos_domain_;
+              MenhirLib.EngineTypes.endp = _endpos_domain_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = label;
+                  MenhirLib.EngineTypes.startp = _startpos_label_;
+                  MenhirLib.EngineTypes.endp = _endpos_label_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let codomain : (Parsetree.class_type) = Obj.magic codomain in
+        let _3 : unit = Obj.magic _3 in
+        let domain : (Parsetree.core_type) = Obj.magic domain in
+        let _2 : unit = Obj.magic _2 in
+        let label : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 6119 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic label in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_label_ in
+        let _endpos = _endpos_codomain_ in
+        let _v : (Parsetree.class_type) = let _1 =
+          let _1 =
+            let label = 
+# 3497 "src/ocaml/preprocess/parser_raw.mly"
+      ( Labelled label )
+# 6129 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 2123 "src/ocaml/preprocess/parser_raw.mly"
+        ( Pcty_arrow(label, domain, codomain) )
+# 6134 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1027 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkcty ~loc:_sloc _1 )
+# 6144 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2124 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 6150 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = codomain;
+          MenhirLib.EngineTypes.startp = _startpos_codomain_;
+          MenhirLib.EngineTypes.endp = _endpos_codomain_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = domain;
+              MenhirLib.EngineTypes.startp = _startpos_domain_;
+              MenhirLib.EngineTypes.endp = _endpos_domain_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let codomain : (Parsetree.class_type) = Obj.magic codomain in
+        let _3 : unit = Obj.magic _3 in
+        let domain : (Parsetree.core_type) = Obj.magic domain in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_domain_ in
+        let _endpos = _endpos_codomain_ in
+        let _v : (Parsetree.class_type) = let _1 =
+          let _1 =
+            let label = 
+# 3499 "src/ocaml/preprocess/parser_raw.mly"
+      ( Nolabel )
+# 6191 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 2123 "src/ocaml/preprocess/parser_raw.mly"
+        ( Pcty_arrow(label, domain, codomain) )
+# 6196 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_domain_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1027 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkcty ~loc:_sloc _1 )
+# 6206 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2124 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 6212 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = bs;
+          MenhirLib.EngineTypes.startp = _startpos_bs_;
+          MenhirLib.EngineTypes.endp = _endpos_bs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined3;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = csig;
+              MenhirLib.EngineTypes.startp = _startpos_csig_;
+              MenhirLib.EngineTypes.endp = _endpos_csig_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _8;
+                MenhirLib.EngineTypes.startp = _startpos__8_;
+                MenhirLib.EngineTypes.endp = _endpos__8_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined2;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = params;
+                    MenhirLib.EngineTypes.startp = _startpos_params_;
+                    MenhirLib.EngineTypes.endp = _endpos_params_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = virt;
+                      MenhirLib.EngineTypes.startp = _startpos_virt_;
+                      MenhirLib.EngineTypes.endp = _endpos_virt_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = _1_inlined1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _;
+                          MenhirLib.EngineTypes.semv = ext;
+                          MenhirLib.EngineTypes.startp = _startpos_ext_;
+                          MenhirLib.EngineTypes.endp = _endpos_ext_;
+                          MenhirLib.EngineTypes.next = {
+                            MenhirLib.EngineTypes.state = _;
+                            MenhirLib.EngineTypes.semv = _2;
+                            MenhirLib.EngineTypes.startp = _startpos__2_;
+                            MenhirLib.EngineTypes.endp = _endpos__2_;
+                            MenhirLib.EngineTypes.next = {
+                              MenhirLib.EngineTypes.state = _menhir_s;
+                              MenhirLib.EngineTypes.semv = _1;
+                              MenhirLib.EngineTypes.startp = _startpos__1_;
+                              MenhirLib.EngineTypes.endp = _endpos__1_;
+                              MenhirLib.EngineTypes.next = _menhir_stack;
+                            };
+                          };
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let bs : (Parsetree.class_type Parsetree.class_infos list) = Obj.magic bs in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let csig : (Parsetree.class_type) = Obj.magic csig in
+        let _8 : unit = Obj.magic _8 in
+        let _1_inlined2 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 6297 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined2 in
+        let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in
+        let virt : (Asttypes.virtual_flag) = Obj.magic virt in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_bs_ in
+        let _v : (string Location.loc option * Parsetree.class_type_declaration list) = let _1 =
+          let a =
+            let attrs2 =
+              let _1 = _1_inlined3 in
+              
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 6315 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let _endpos_attrs2_ = _endpos__1_inlined3_ in
+            let id =
+              let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 6327 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let attrs1 =
+              let _1 = _1_inlined1 in
+              
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 6335 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let _endpos = _endpos_attrs2_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 2264 "src/ocaml/preprocess/parser_raw.mly"
+    (
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc _sloc in
+      let docs = symbol_docs _sloc in
+      ext,
+      Ci.mk id csig ~virt ~params ~attrs ~loc ~docs
+    )
+# 6350 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 1211 "src/ocaml/preprocess/parser_raw.mly"
+    ( let (x, b) = a in x, b :: bs )
+# 6356 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2252 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 6362 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Longident.t) = 
+# 3787 "src/ocaml/preprocess/parser_raw.mly"
+                                           ( _1 )
+# 6387 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 773 "src/ocaml/preprocess/parser_raw.mly"
+       (string * char option)
+# 6408 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.constant) = 
+# 3667 "src/ocaml/preprocess/parser_raw.mly"
+                 ( let (n, m) = _1 in Pconst_integer (n, m) )
+# 6416 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 732 "src/ocaml/preprocess/parser_raw.mly"
+       (char)
+# 6437 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.constant) = 
+# 3668 "src/ocaml/preprocess/parser_raw.mly"
+                 ( Pconst_char _1 )
+# 6445 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 825 "src/ocaml/preprocess/parser_raw.mly"
+       (string * Location.t * string option)
+# 6466 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.constant) = 
+# 3669 "src/ocaml/preprocess/parser_raw.mly"
+                 ( let (s, strloc, d) = _1 in Pconst_string (s, strloc, d) )
+# 6474 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 752 "src/ocaml/preprocess/parser_raw.mly"
+       (string * char option)
+# 6495 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.constant) = 
+# 3670 "src/ocaml/preprocess/parser_raw.mly"
+                 ( let (f, m) = _1 in Pconst_float (f, m) )
+# 6503 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (string) = 
+# 3742 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( "[]" )
+# 6535 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (string) = 
+# 3743 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( "()" )
+# 6567 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3744 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( "false" )
+# 6592 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3745 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( "true" )
+# 6617 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 839 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 6638 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3748 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 6646 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (string) = let _1 = 
+# 3739 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( "::" )
+# 6685 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3749 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 6690 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3750 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 6715 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Longident.t) = 
+# 3753 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 6740 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__2_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__2_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _2_inlined1 : unit = Obj.magic _2_inlined1 in
+        let _1_inlined1 : unit = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Longident.t) = let _3 =
+          let (_2, _1) = (_2_inlined1, _1_inlined1) in
+          
+# 3739 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( "::" )
+# 6795 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3754 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Ldot(_1,_3) )
+# 6801 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Longident.t) = let _1 = 
+# 3739 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( "::" )
+# 6840 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3755 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Lident _1 )
+# 6845 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Longident.t) = 
+# 3756 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Lident _1 )
+# 6870 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.core_type) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.core_type) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.core_type * Parsetree.core_type) = 
+# 2208 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1, _3 )
+# 6909 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let x : (Parsetree.core_type) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos_x_ in
+        let _v : (Parsetree.constructor_arguments) = let tys =
+          let xs =
+            let xs = 
+# 1098 "src/ocaml/preprocess/parser_raw.mly"
+    ( [ x ] )
+# 6936 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 6941 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 1118 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 6947 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3298 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pcstr_tuple tys )
+# 6953 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = xs;
+              MenhirLib.EngineTypes.startp = _startpos_xs_;
+              MenhirLib.EngineTypes.endp = _endpos_xs_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let x : (Parsetree.core_type) = Obj.magic x in
+        let _2 : unit = Obj.magic _2 in
+        let xs : (Parsetree.core_type list) = Obj.magic xs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xs_ in
+        let _endpos = _endpos_x_ in
+        let _v : (Parsetree.constructor_arguments) = let tys =
+          let xs =
+            let xs = 
+# 1102 "src/ocaml/preprocess/parser_raw.mly"
+    ( x :: xs )
+# 6994 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 6999 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 1118 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 7005 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3298 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pcstr_tuple tys )
+# 7011 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (Parsetree.label_declaration list) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.constructor_arguments) = 
+# 3300 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pcstr_record _2 )
+# 7050 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.constructor_declaration list) = 
+# 3219 "src/ocaml/preprocess/parser_raw.mly"
+      ( [] )
+# 7075 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let xs : (Parsetree.constructor_declaration list) = Obj.magic xs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xs_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.constructor_declaration list) = let cs = 
+# 1203 "src/ocaml/preprocess/parser_raw.mly"
+    ( List.rev xs )
+# 7100 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3221 "src/ocaml/preprocess/parser_raw.mly"
+      ( cs )
+# 7105 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.core_type) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.core_type) = let _1 = 
+# 3457 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 7130 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3447 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 7135 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.attribute) = Obj.magic _2 in
+        let _1 : (Parsetree.core_type) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.core_type) = 
+# 3449 "src/ocaml/preprocess/parser_raw.mly"
+      ( Typ.attr _1 _2 )
+# 7167 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Asttypes.direction_flag) = 
+# 3852 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Upto )
+# 7192 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Asttypes.direction_flag) = 
+# 3853 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Downto )
+# 7217 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.expression) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Ast_helper.let_bindings) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.expression) = let _endpos = _endpos__3_ in
+        let _startpos = _startpos__1_ in
+        let _loc = (_startpos, _endpos) in
+        
+# 4062 "src/ocaml/preprocess/parser_raw.mly"
+    ( expr_of_lwt_bindings ~loc:_loc _1 (merloc _endpos__2_ _3) )
+# 7259 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.case list) = Obj.magic xs in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (Parsetree.expression) = Obj.magic _3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.expression) = let _5 =
+          let xs =
+            let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 7321 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 1175 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 7326 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2759 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 7332 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__5_ = _endpos_xs_ in
+        let _2 =
+          let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+          let _2 =
+            let _1 = _1_inlined1 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 7343 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 7349 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__5_ in
+        let _startpos = _startpos__1_ in
+        let _loc = (_startpos, _endpos) in
+        
+# 4064 "src/ocaml/preprocess/parser_raw.mly"
+    ( let expr = mkexp_attrs ~loc:_loc
+          (Pexp_match(Fake.app Fake.Lwt.un_lwt _3, List.rev _5)) _2 in
+      Fake.app Fake.Lwt.in_lwt expr )
+# 7360 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined2;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.expression) = Obj.magic _3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.expression) = let _2 =
+          let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+          let _2 =
+            let _1 = _1_inlined1 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 7410 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 7416 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__3_ in
+        let _startpos = _startpos__1_ in
+        let _loc = (_startpos, _endpos) in
+        
+# 4068 "src/ocaml/preprocess/parser_raw.mly"
+    ( reloc_exp ~loc:_loc (Fake.app Fake.Lwt.in_lwt _3) )
+# 7425 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.case list) = Obj.magic xs in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (Parsetree.expression) = Obj.magic _3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.expression) = let _5 =
+          let xs =
+            let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 7487 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 1175 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 7492 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2759 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 7498 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__5_ = _endpos_xs_ in
+        let _2 =
+          let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+          let _2 =
+            let _1 = _1_inlined1 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 7509 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 7515 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__5_ in
+        let _startpos = _startpos__1_ in
+        let _loc = (_startpos, _endpos) in
+        
+# 4070 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp_attrs ~loc:_loc
+        (Pexp_try(Fake.app Fake.Lwt.in_lwt _3, List.rev _5)) _2 )
+# 7525 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : (Parsetree.expression) = Obj.magic _5 in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (Parsetree.expression) = Obj.magic _3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.expression) = let _2 =
+          let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+          let _2 =
+            let _1 = _1_inlined1 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 7589 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 7595 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 4073 "src/ocaml/preprocess/parser_raw.mly"
+    ( Fake.app (Fake.app Fake.Lwt.finally_ _3) _5 )
+# 7601 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _7;
+          MenhirLib.EngineTypes.startp = _startpos__7_;
+          MenhirLib.EngineTypes.endp = _endpos__7_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _6;
+            MenhirLib.EngineTypes.startp = _startpos__6_;
+            MenhirLib.EngineTypes.endp = _endpos__6_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = xs;
+              MenhirLib.EngineTypes.startp = _startpos_xs_;
+              MenhirLib.EngineTypes.endp = _endpos_xs_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _4;
+                MenhirLib.EngineTypes.startp = _startpos__4_;
+                MenhirLib.EngineTypes.endp = _endpos__4_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _3;
+                  MenhirLib.EngineTypes.startp = _startpos__3_;
+                  MenhirLib.EngineTypes.endp = _endpos__3_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1_inlined2;
+                    MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _1_inlined1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _menhir_s;
+                        MenhirLib.EngineTypes.semv = _1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_;
+                        MenhirLib.EngineTypes.next = _menhir_stack;
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _7 : (Parsetree.expression) = Obj.magic _7 in
+        let _6 : unit = Obj.magic _6 in
+        let xs : (Parsetree.case list) = Obj.magic xs in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (Parsetree.expression) = Obj.magic _3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__7_ in
+        let _v : (Parsetree.expression) = let _5 =
+          let xs =
+            let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 7677 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 1175 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 7682 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2759 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 7688 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _2 =
+          let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+          let _2 =
+            let _1 = _1_inlined1 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 7698 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 7704 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__7_ in
+        let _startpos = _startpos__1_ in
+        let _loc = (_startpos, _endpos) in
+        
+# 4075 "src/ocaml/preprocess/parser_raw.mly"
+    ( let expr = mkexp_attrs ~loc:_loc
+        (Pexp_try (Fake.app Fake.Lwt.in_lwt _3, List.rev _5)) _2 in
+      Fake.app (Fake.app Fake.Lwt.finally_ expr) _7 )
+# 7715 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _6;
+          MenhirLib.EngineTypes.startp = _startpos__6_;
+          MenhirLib.EngineTypes.endp = _endpos__6_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _5;
+            MenhirLib.EngineTypes.startp = _startpos__5_;
+            MenhirLib.EngineTypes.endp = _endpos__5_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _4;
+              MenhirLib.EngineTypes.startp = _startpos__4_;
+              MenhirLib.EngineTypes.endp = _endpos__4_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _3;
+                MenhirLib.EngineTypes.startp = _startpos__3_;
+                MenhirLib.EngineTypes.endp = _endpos__3_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined2;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1_inlined1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = _1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _6 : unit = Obj.magic _6 in
+        let _5 : (Parsetree.expression) = Obj.magic _5 in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (Parsetree.expression) = Obj.magic _3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__6_ in
+        let _v : (Parsetree.expression) = let _2 =
+          let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+          let _2 =
+            let _1 = _1_inlined1 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 7786 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 7792 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__6_ in
+        let _startpos = _startpos__1_ in
+        let _loc = (_startpos, _endpos) in
+        
+# 4079 "src/ocaml/preprocess/parser_raw.mly"
+  ( let expr = Pexp_while (_3, Fake.(app Lwt.un_lwt _5)) in
+    Fake.(app Lwt.to_lwt (mkexp_attrs ~loc:_loc expr _2)) )
+# 7802 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _10;
+          MenhirLib.EngineTypes.startp = _startpos__10_;
+          MenhirLib.EngineTypes.endp = _endpos__10_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _9;
+            MenhirLib.EngineTypes.startp = _startpos__9_;
+            MenhirLib.EngineTypes.endp = _endpos__9_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _8;
+              MenhirLib.EngineTypes.startp = _startpos__8_;
+              MenhirLib.EngineTypes.endp = _endpos__8_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _7;
+                MenhirLib.EngineTypes.startp = _startpos__7_;
+                MenhirLib.EngineTypes.endp = _endpos__7_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _6;
+                  MenhirLib.EngineTypes.startp = _startpos__6_;
+                  MenhirLib.EngineTypes.endp = _endpos__6_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _5;
+                    MenhirLib.EngineTypes.startp = _startpos__5_;
+                    MenhirLib.EngineTypes.endp = _endpos__5_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _4;
+                      MenhirLib.EngineTypes.startp = _startpos__4_;
+                      MenhirLib.EngineTypes.endp = _endpos__4_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = _3;
+                        MenhirLib.EngineTypes.startp = _startpos__3_;
+                        MenhirLib.EngineTypes.endp = _endpos__3_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _;
+                          MenhirLib.EngineTypes.semv = _1_inlined2;
+                          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                          MenhirLib.EngineTypes.next = {
+                            MenhirLib.EngineTypes.state = _;
+                            MenhirLib.EngineTypes.semv = _1_inlined1;
+                            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                            MenhirLib.EngineTypes.next = {
+                              MenhirLib.EngineTypes.state = _menhir_s;
+                              MenhirLib.EngineTypes.semv = _1;
+                              MenhirLib.EngineTypes.startp = _startpos__1_;
+                              MenhirLib.EngineTypes.endp = _endpos__1_;
+                              MenhirLib.EngineTypes.next = _menhir_stack;
+                            };
+                          };
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _10 : unit = Obj.magic _10 in
+        let _9 : (Parsetree.expression) = Obj.magic _9 in
+        let _8 : unit = Obj.magic _8 in
+        let _7 : (Parsetree.expression) = Obj.magic _7 in
+        let _6 : (Asttypes.direction_flag) = Obj.magic _6 in
+        let _5 : (Parsetree.expression) = Obj.magic _5 in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (Parsetree.pattern) = Obj.magic _3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__10_ in
+        let _v : (Parsetree.expression) = let _2 =
+          let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+          let _2 =
+            let _1 = _1_inlined1 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 7901 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 7907 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__10_ in
+        let _startpos = _startpos__1_ in
+        let _loc = (_startpos, _endpos) in
+        
+# 4082 "src/ocaml/preprocess/parser_raw.mly"
+    ( let expr = Pexp_for (_3, _5, _7, _6, Fake.(app Lwt.un_lwt _9)) in
+      Fake.(app Lwt.to_lwt (mkexp_attrs ~loc:_loc expr _2)) )
+# 7917 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _8;
+          MenhirLib.EngineTypes.startp = _startpos__8_;
+          MenhirLib.EngineTypes.endp = _endpos__8_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _7;
+            MenhirLib.EngineTypes.startp = _startpos__7_;
+            MenhirLib.EngineTypes.endp = _endpos__7_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _6;
+              MenhirLib.EngineTypes.startp = _startpos__6_;
+              MenhirLib.EngineTypes.endp = _endpos__6_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _5;
+                MenhirLib.EngineTypes.startp = _startpos__5_;
+                MenhirLib.EngineTypes.endp = _endpos__5_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _4;
+                  MenhirLib.EngineTypes.startp = _startpos__4_;
+                  MenhirLib.EngineTypes.endp = _endpos__4_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _3;
+                    MenhirLib.EngineTypes.startp = _startpos__3_;
+                    MenhirLib.EngineTypes.endp = _endpos__3_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _1_inlined2;
+                      MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = _1_inlined1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _menhir_s;
+                          MenhirLib.EngineTypes.semv = _1;
+                          MenhirLib.EngineTypes.startp = _startpos__1_;
+                          MenhirLib.EngineTypes.endp = _endpos__1_;
+                          MenhirLib.EngineTypes.next = _menhir_stack;
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _8 : unit = Obj.magic _8 in
+        let _7 : (Parsetree.expression) = Obj.magic _7 in
+        let _6 : unit = Obj.magic _6 in
+        let _5 : (Parsetree.expression) = Obj.magic _5 in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (Parsetree.pattern) = Obj.magic _3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__8_ in
+        let _v : (Parsetree.expression) = let _2 =
+          let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+          let _2 =
+            let _1 = _1_inlined1 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 8002 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 8008 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__8_ in
+        let _startpos = _startpos__1_ in
+        let _loc = (_startpos, _endpos) in
+        
+# 4085 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp_attrs ~loc:_loc
+          (Pexp_let (Nonrecursive, [Vb.mk _3 (Fake.(app Lwt.un_stream _5))],
+             Fake.(app Lwt.unit_lwt _7)))
+          _2
+    )
+# 8021 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.expression) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.expression) = 
+# 2375 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 8046 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _7;
+          MenhirLib.EngineTypes.startp = _startpos__7_;
+          MenhirLib.EngineTypes.endp = _endpos__7_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _6;
+            MenhirLib.EngineTypes.startp = _startpos__6_;
+            MenhirLib.EngineTypes.endp = _endpos__6_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _5;
+              MenhirLib.EngineTypes.startp = _startpos__5_;
+              MenhirLib.EngineTypes.endp = _endpos__5_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined3;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined2;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1_inlined1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _2;
+                      MenhirLib.EngineTypes.startp = _startpos__2_;
+                      MenhirLib.EngineTypes.endp = _endpos__2_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _menhir_s;
+                        MenhirLib.EngineTypes.semv = _1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_;
+                        MenhirLib.EngineTypes.next = _menhir_stack;
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _7 : (Parsetree.expression) = Obj.magic _7 in
+        let _6 : unit = Obj.magic _6 in
+        let _5 : (Parsetree.module_expr) = Obj.magic _5 in
+        let _1_inlined3 : (string option) = Obj.magic _1_inlined3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__7_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _4 =
+            let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 8126 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _3 =
+            let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+            let _2 =
+              let _1 = _1_inlined1 in
+              
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 8136 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 8142 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2410 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_letmodule(_4, _5, (merloc _endpos__6_ _7)), _3 )
+# 8148 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__1_ = _endpos__7_ in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2377 "src/ocaml/preprocess/parser_raw.mly"
+      ( let desc, attrs = _1 in
+        mkexp_attrs ~loc:_sloc desc attrs )
+# 8159 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _6;
+          MenhirLib.EngineTypes.startp = _startpos__6_;
+          MenhirLib.EngineTypes.endp = _endpos__6_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _5;
+            MenhirLib.EngineTypes.startp = _startpos__5_;
+            MenhirLib.EngineTypes.endp = _endpos__5_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined4;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined4_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined4_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2_inlined1;
+                MenhirLib.EngineTypes.startp = _startpos__2_inlined1_;
+                MenhirLib.EngineTypes.endp = _endpos__2_inlined1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined3;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1_inlined2;
+                    MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _1_inlined1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = _2;
+                        MenhirLib.EngineTypes.startp = _startpos__2_;
+                        MenhirLib.EngineTypes.endp = _endpos__2_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _menhir_s;
+                          MenhirLib.EngineTypes.semv = _1;
+                          MenhirLib.EngineTypes.startp = _startpos__1_;
+                          MenhirLib.EngineTypes.endp = _endpos__1_;
+                          MenhirLib.EngineTypes.next = _menhir_stack;
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _6 : (Parsetree.expression) = Obj.magic _6 in
+        let _5 : unit = Obj.magic _5 in
+        let _1_inlined4 : (Parsetree.attributes) = Obj.magic _1_inlined4 in
+        let _2_inlined1 : (Parsetree.constructor_arguments * Parsetree.core_type option) = Obj.magic _2_inlined1 in
+        let _1_inlined3 : (string) = Obj.magic _1_inlined3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__6_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _4 =
+            let (_endpos__1_inlined1_, _endpos__1_, _startpos__1_, _1_inlined1, _2, _1) = (_endpos__1_inlined4_, _endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined4, _2_inlined1, _1_inlined3) in
+            let _3 =
+              let _1 = _1_inlined1 in
+              
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 8245 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let _endpos__3_ = _endpos__1_inlined1_ in
+            let _1 =
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 8256 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let _endpos = _endpos__3_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 3283 "src/ocaml/preprocess/parser_raw.mly"
+      ( let args, res = _2 in
+        Te.decl _1 ~args ?res ~attrs:_3 ~loc:(make_loc _sloc) )
+# 8266 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _3 =
+            let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+            let _2 =
+              let _1 = _1_inlined1 in
+              
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 8276 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 8282 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2412 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_letexception(_4, _6), _3 )
+# 8288 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__1_ = _endpos__6_ in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2377 "src/ocaml/preprocess/parser_raw.mly"
+      ( let desc, attrs = _1 in
+        mkexp_attrs ~loc:_sloc desc attrs )
+# 8299 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _7;
+          MenhirLib.EngineTypes.startp = _startpos__7_;
+          MenhirLib.EngineTypes.endp = _endpos__7_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _6;
+            MenhirLib.EngineTypes.startp = _startpos__6_;
+            MenhirLib.EngineTypes.endp = _endpos__6_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _5;
+              MenhirLib.EngineTypes.startp = _startpos__5_;
+              MenhirLib.EngineTypes.endp = _endpos__5_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _2;
+                    MenhirLib.EngineTypes.startp = _startpos__2_;
+                    MenhirLib.EngineTypes.endp = _endpos__2_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = _1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _7 : (Parsetree.expression) = Obj.magic _7 in
+        let _6 : unit = Obj.magic _6 in
+        let _5 : (Parsetree.module_expr) = Obj.magic _5 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__7_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _4 =
+            let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+            let _2 =
+              let _1 = _1_inlined1 in
+              
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 8371 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 8377 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _3 = 
+# 3907 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Fresh )
+# 8383 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          
+# 2414 "src/ocaml/preprocess/parser_raw.mly"
+      ( let open_loc = make_loc (_startpos__2_, _endpos__5_) in
+        let od = Opn.mk _5 ~override:_3 ~loc:open_loc in
+        Pexp_open(od, (merloc _endpos__6_ _7)), _4 )
+# 8390 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__1_ = _endpos__7_ in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2377 "src/ocaml/preprocess/parser_raw.mly"
+      ( let desc, attrs = _1 in
+        mkexp_attrs ~loc:_sloc desc attrs )
+# 8401 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _7;
+          MenhirLib.EngineTypes.startp = _startpos__7_;
+          MenhirLib.EngineTypes.endp = _endpos__7_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _6;
+            MenhirLib.EngineTypes.startp = _startpos__6_;
+            MenhirLib.EngineTypes.endp = _endpos__6_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _5;
+              MenhirLib.EngineTypes.startp = _startpos__5_;
+              MenhirLib.EngineTypes.endp = _endpos__5_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined3;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined2;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1_inlined1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _2;
+                      MenhirLib.EngineTypes.startp = _startpos__2_;
+                      MenhirLib.EngineTypes.endp = _endpos__2_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _menhir_s;
+                        MenhirLib.EngineTypes.semv = _1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_;
+                        MenhirLib.EngineTypes.next = _menhir_stack;
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _7 : (Parsetree.expression) = Obj.magic _7 in
+        let _6 : unit = Obj.magic _6 in
+        let _5 : (Parsetree.module_expr) = Obj.magic _5 in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let _1_inlined2 : (string Location.loc option) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : unit = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__7_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _4 =
+            let (_1_inlined1, _1) = (_1_inlined3, _1_inlined2) in
+            let _2 =
+              let _1 = _1_inlined1 in
+              
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 8480 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 8486 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _3 =
+            let _1 = _1_inlined1 in
+            
+# 3908 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Override )
+# 8494 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2414 "src/ocaml/preprocess/parser_raw.mly"
+      ( let open_loc = make_loc (_startpos__2_, _endpos__5_) in
+        let od = Opn.mk _5 ~override:_3 ~loc:open_loc in
+        Pexp_open(od, (merloc _endpos__6_ _7)), _4 )
+# 8502 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__1_ = _endpos__7_ in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2377 "src/ocaml/preprocess/parser_raw.mly"
+      ( let desc, attrs = _1 in
+        mkexp_attrs ~loc:_sloc desc attrs )
+# 8513 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined2;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.case list) = Obj.magic xs in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _3 =
+            let xs =
+              let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 8562 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              
+# 1175 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 8567 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2759 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 8573 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _2 =
+            let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+            let _2 =
+              let _1 = _1_inlined1 in
+              
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 8583 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 8589 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2418 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_function _3, _2 )
+# 8595 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__1_ = _endpos_xs_ in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2377 "src/ocaml/preprocess/parser_raw.mly"
+      ( let desc, attrs = _1 in
+        mkexp_attrs ~loc:_sloc desc attrs )
+# 8606 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined2;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined1;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : (Parsetree.expression) = Obj.magic _4 in
+        let _3 : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = Obj.magic _3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _2 =
+            let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+            let _2 =
+              let _1 = _1_inlined1 in
+              
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 8664 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 8670 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2420 "src/ocaml/preprocess/parser_raw.mly"
+      ( let (l,o,p) = _3 in
+        Pexp_fun(l, o, p, _4), _2 )
+# 8677 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__1_ = _endpos__4_ in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2377 "src/ocaml/preprocess/parser_raw.mly"
+      ( let desc, attrs = _1 in
+        mkexp_attrs ~loc:_sloc desc attrs )
+# 8688 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _7;
+          MenhirLib.EngineTypes.startp = _startpos__7_;
+          MenhirLib.EngineTypes.endp = _endpos__7_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _6;
+            MenhirLib.EngineTypes.startp = _startpos__6_;
+            MenhirLib.EngineTypes.endp = _endpos__6_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = xs;
+              MenhirLib.EngineTypes.startp = _startpos_xs_;
+              MenhirLib.EngineTypes.endp = _endpos_xs_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _4;
+                MenhirLib.EngineTypes.startp = _startpos__4_;
+                MenhirLib.EngineTypes.endp = _endpos__4_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _3;
+                  MenhirLib.EngineTypes.startp = _startpos__3_;
+                  MenhirLib.EngineTypes.endp = _endpos__3_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1_inlined2;
+                    MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _1_inlined1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _menhir_s;
+                        MenhirLib.EngineTypes.semv = _1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_;
+                        MenhirLib.EngineTypes.next = _menhir_stack;
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _7 : (Parsetree.expression) = Obj.magic _7 in
+        let _6 : unit = Obj.magic _6 in
+        let xs : (string Location.loc list) = Obj.magic xs in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : unit = Obj.magic _3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__7_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _5 = 
+# 2639 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 8763 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _2 =
+            let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+            let _2 =
+              let _1 = _1_inlined1 in
+              
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 8772 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 8778 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos__7_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 2423 "src/ocaml/preprocess/parser_raw.mly"
+      ( (mk_newtypes ~loc:_sloc _5 _7).pexp_desc, _2 )
+# 8787 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__1_ = _endpos__7_ in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2377 "src/ocaml/preprocess/parser_raw.mly"
+      ( let desc, attrs = _1 in
+        mkexp_attrs ~loc:_sloc desc attrs )
+# 8798 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.case list) = Obj.magic xs in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (Parsetree.expression) = Obj.magic _3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _5 =
+            let xs =
+              let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 8861 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              
+# 1175 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 8866 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2759 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 8872 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _2 =
+            let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+            let _2 =
+              let _1 = _1_inlined1 in
+              
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 8882 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 8888 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2425 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_match(_3, _5), _2 )
+# 8894 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__1_ = _endpos_xs_ in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2377 "src/ocaml/preprocess/parser_raw.mly"
+      ( let desc, attrs = _1 in
+        mkexp_attrs ~loc:_sloc desc attrs )
+# 8905 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.case list) = Obj.magic xs in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (Parsetree.expression) = Obj.magic _3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _5 =
+            let xs =
+              let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 8968 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              
+# 1175 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 8973 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2759 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 8979 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _2 =
+            let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+            let _2 =
+              let _1 = _1_inlined1 in
+              
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 8989 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 8995 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2427 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_try(_3, _5), _2 )
+# 9001 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__1_ = _endpos_xs_ in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2377 "src/ocaml/preprocess/parser_raw.mly"
+      ( let desc, attrs = _1 in
+        mkexp_attrs ~loc:_sloc desc attrs )
+# 9012 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _7;
+          MenhirLib.EngineTypes.startp = _startpos__7_;
+          MenhirLib.EngineTypes.endp = _endpos__7_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _6;
+            MenhirLib.EngineTypes.startp = _startpos__6_;
+            MenhirLib.EngineTypes.endp = _endpos__6_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _5;
+              MenhirLib.EngineTypes.startp = _startpos__5_;
+              MenhirLib.EngineTypes.endp = _endpos__5_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _4;
+                MenhirLib.EngineTypes.startp = _startpos__4_;
+                MenhirLib.EngineTypes.endp = _endpos__4_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _3;
+                  MenhirLib.EngineTypes.startp = _startpos__3_;
+                  MenhirLib.EngineTypes.endp = _endpos__3_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1_inlined2;
+                    MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _1_inlined1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _menhir_s;
+                        MenhirLib.EngineTypes.semv = _1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_;
+                        MenhirLib.EngineTypes.next = _menhir_stack;
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _7 : (Parsetree.expression) = Obj.magic _7 in
+        let _6 : unit = Obj.magic _6 in
+        let _5 : (Parsetree.expression) = Obj.magic _5 in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (Parsetree.expression) = Obj.magic _3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__7_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _2 =
+            let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+            let _2 =
+              let _1 = _1_inlined1 in
+              
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 9091 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 9097 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2433 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_ifthenelse(_3, (merloc _endpos__4_ _5), Some (merloc _endpos__6_ _7)), _2 )
+# 9103 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__1_ = _endpos__7_ in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2377 "src/ocaml/preprocess/parser_raw.mly"
+      ( let desc, attrs = _1 in
+        mkexp_attrs ~loc:_sloc desc attrs )
+# 9114 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : (Parsetree.expression) = Obj.magic _5 in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (Parsetree.expression) = Obj.magic _3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _2 =
+            let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+            let _2 =
+              let _1 = _1_inlined1 in
+              
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 9179 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 9185 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2435 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_ifthenelse(_3, (merloc _endpos__4_ _5), None), _2 )
+# 9191 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__1_ = _endpos__5_ in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2377 "src/ocaml/preprocess/parser_raw.mly"
+      ( let desc, attrs = _1 in
+        mkexp_attrs ~loc:_sloc desc attrs )
+# 9202 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _6;
+          MenhirLib.EngineTypes.startp = _startpos__6_;
+          MenhirLib.EngineTypes.endp = _endpos__6_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _5;
+            MenhirLib.EngineTypes.startp = _startpos__5_;
+            MenhirLib.EngineTypes.endp = _endpos__5_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _4;
+              MenhirLib.EngineTypes.startp = _startpos__4_;
+              MenhirLib.EngineTypes.endp = _endpos__4_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _3;
+                MenhirLib.EngineTypes.startp = _startpos__3_;
+                MenhirLib.EngineTypes.endp = _endpos__3_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined2;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1_inlined1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = _1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _6 : unit = Obj.magic _6 in
+        let _5 : (Parsetree.expression) = Obj.magic _5 in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (Parsetree.expression) = Obj.magic _3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__6_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _2 =
+            let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+            let _2 =
+              let _1 = _1_inlined1 in
+              
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 9274 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 9280 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2437 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_while(_3, (merloc _endpos__4_ _5)), _2 )
+# 9286 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__1_ = _endpos__6_ in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2377 "src/ocaml/preprocess/parser_raw.mly"
+      ( let desc, attrs = _1 in
+        mkexp_attrs ~loc:_sloc desc attrs )
+# 9297 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _10;
+          MenhirLib.EngineTypes.startp = _startpos__10_;
+          MenhirLib.EngineTypes.endp = _endpos__10_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _9;
+            MenhirLib.EngineTypes.startp = _startpos__9_;
+            MenhirLib.EngineTypes.endp = _endpos__9_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _8;
+              MenhirLib.EngineTypes.startp = _startpos__8_;
+              MenhirLib.EngineTypes.endp = _endpos__8_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _7;
+                MenhirLib.EngineTypes.startp = _startpos__7_;
+                MenhirLib.EngineTypes.endp = _endpos__7_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _6;
+                  MenhirLib.EngineTypes.startp = _startpos__6_;
+                  MenhirLib.EngineTypes.endp = _endpos__6_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _5;
+                    MenhirLib.EngineTypes.startp = _startpos__5_;
+                    MenhirLib.EngineTypes.endp = _endpos__5_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _4;
+                      MenhirLib.EngineTypes.startp = _startpos__4_;
+                      MenhirLib.EngineTypes.endp = _endpos__4_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = _3;
+                        MenhirLib.EngineTypes.startp = _startpos__3_;
+                        MenhirLib.EngineTypes.endp = _endpos__3_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _;
+                          MenhirLib.EngineTypes.semv = _1_inlined2;
+                          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                          MenhirLib.EngineTypes.next = {
+                            MenhirLib.EngineTypes.state = _;
+                            MenhirLib.EngineTypes.semv = _1_inlined1;
+                            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                            MenhirLib.EngineTypes.next = {
+                              MenhirLib.EngineTypes.state = _menhir_s;
+                              MenhirLib.EngineTypes.semv = _1;
+                              MenhirLib.EngineTypes.startp = _startpos__1_;
+                              MenhirLib.EngineTypes.endp = _endpos__1_;
+                              MenhirLib.EngineTypes.next = _menhir_stack;
+                            };
+                          };
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _10 : unit = Obj.magic _10 in
+        let _9 : (Parsetree.expression) = Obj.magic _9 in
+        let _8 : unit = Obj.magic _8 in
+        let _7 : (Parsetree.expression) = Obj.magic _7 in
+        let _6 : (Asttypes.direction_flag) = Obj.magic _6 in
+        let _5 : (Parsetree.expression) = Obj.magic _5 in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (Parsetree.pattern) = Obj.magic _3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__10_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _2 =
+            let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+            let _2 =
+              let _1 = _1_inlined1 in
+              
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 9397 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 9403 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2440 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_for(_3, (merloc _endpos__4_ _5), (merloc _endpos__6_ _7), _6, (merloc _endpos__8_ _9)), _2 )
+# 9409 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__1_ = _endpos__10_ in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2377 "src/ocaml/preprocess/parser_raw.mly"
+      ( let desc, attrs = _1 in
+        mkexp_attrs ~loc:_sloc desc attrs )
+# 9420 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined2;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.expression) = Obj.magic _3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _2 =
+            let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+            let _2 =
+              let _1 = _1_inlined1 in
+              
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 9471 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 9477 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2442 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_assert _3, _2 )
+# 9483 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__1_ = _endpos__3_ in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2377 "src/ocaml/preprocess/parser_raw.mly"
+      ( let desc, attrs = _1 in
+        mkexp_attrs ~loc:_sloc desc attrs )
+# 9494 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined2;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.expression) = Obj.magic _3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _2 =
+            let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+            let _2 =
+              let _1 = _1_inlined1 in
+              
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 9545 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 9551 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2444 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_lazy _3, _2 )
+# 9557 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__1_ = _endpos__3_ in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2377 "src/ocaml/preprocess/parser_raw.mly"
+      ( let desc, attrs = _1 in
+        mkexp_attrs ~loc:_sloc desc attrs )
+# 9568 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = xss;
+            MenhirLib.EngineTypes.startp = _startpos_xss_;
+            MenhirLib.EngineTypes.endp = _endpos_xss_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined3;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : unit = Obj.magic _4 in
+        let xss : (Parsetree.class_field list list) = Obj.magic xss in
+        let _1_inlined3 : (Parsetree.pattern) = Obj.magic _1_inlined3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _3 =
+            let _1 = _1_inlined3 in
+            let _2 =
+              let _1 =
+                let _1 = 
+# 260 "<standard.mly>"
+    ( List.flatten xss )
+# 9633 "src/ocaml/preprocess/parser_raw.ml"
+                 in
+                
+# 2039 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 9638 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_xss_) in
+              let _endpos = _endpos__1_ in
+              let _startpos = _startpos__1_ in
+              
+# 974 "src/ocaml/preprocess/parser_raw.mly"
+                               ( extra_cstr _startpos _endpos _1 )
+# 9647 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2026 "src/ocaml/preprocess/parser_raw.mly"
+       ( Cstr.mk _1 _2 )
+# 9653 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _2 =
+            let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+            let _2 =
+              let _1 = _1_inlined1 in
+              
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 9663 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 9669 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2446 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_object _3, _2 )
+# 9675 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__1_ = _endpos__4_ in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2377 "src/ocaml/preprocess/parser_raw.mly"
+      ( let desc, attrs = _1 in
+        mkexp_attrs ~loc:_sloc desc attrs )
+# 9686 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let xs : ((Asttypes.arg_label * Parsetree.expression) list) = Obj.magic xs in
+        let _1 : (Parsetree.expression) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let _2 =
+              let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 9721 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              
+# 1082 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 9726 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2454 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_apply(_1, _2) )
+# 9732 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos_xs_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 9742 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 9748 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let xs : (Parsetree.expression list) = Obj.magic xs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xs_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let _1 =
+              let es =
+                let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 9777 "src/ocaml/preprocess/parser_raw.ml"
+                 in
+                
+# 1142 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 9782 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 2787 "src/ocaml/preprocess/parser_raw.mly"
+    ( es )
+# 9788 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2456 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_tuple(_1) )
+# 9794 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_xs_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 9804 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 9810 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.expression) = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let _1 =
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 9848 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2458 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_construct(_1, Some _2) )
+# 9854 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__2_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 9864 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 9870 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.expression) = Obj.magic _2 in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 = 
+# 2460 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_variant(_1, Some _2) )
+# 9903 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos__2_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 9912 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 9918 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = e2;
+          MenhirLib.EngineTypes.startp = _startpos_e2_;
+          MenhirLib.EngineTypes.endp = _endpos_e2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = op;
+            MenhirLib.EngineTypes.startp = _startpos_op_;
+            MenhirLib.EngineTypes.endp = _endpos_op_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = e1;
+              MenhirLib.EngineTypes.startp = _startpos_e1_;
+              MenhirLib.EngineTypes.endp = _endpos_e1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let e2 : (Parsetree.expression) = Obj.magic e2 in
+        let op : (
+# 763 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 9952 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic op in
+        let e1 : (Parsetree.expression) = Obj.magic e1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_e1_ in
+        let _endpos = _endpos_e2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let op =
+              let _1 = 
+# 3713 "src/ocaml/preprocess/parser_raw.mly"
+                  ( op )
+# 9964 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let (_endpos__1_, _startpos__1_) = (_endpos_op_, _startpos_op_) in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1007 "src/ocaml/preprocess/parser_raw.mly"
+   ( mkoperator ~loc:_sloc _1 )
+# 9973 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2462 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkinfix e1 op e2 )
+# 9979 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 9989 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 9995 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = e2;
+          MenhirLib.EngineTypes.startp = _startpos_e2_;
+          MenhirLib.EngineTypes.endp = _endpos_e2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = op;
+            MenhirLib.EngineTypes.startp = _startpos_op_;
+            MenhirLib.EngineTypes.endp = _endpos_op_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = e1;
+              MenhirLib.EngineTypes.startp = _startpos_e1_;
+              MenhirLib.EngineTypes.endp = _endpos_e1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let e2 : (Parsetree.expression) = Obj.magic e2 in
+        let op : (
+# 764 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 10029 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic op in
+        let e1 : (Parsetree.expression) = Obj.magic e1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_e1_ in
+        let _endpos = _endpos_e2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let op =
+              let _1 = 
+# 3714 "src/ocaml/preprocess/parser_raw.mly"
+                  ( op )
+# 10041 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let (_endpos__1_, _startpos__1_) = (_endpos_op_, _startpos_op_) in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1007 "src/ocaml/preprocess/parser_raw.mly"
+   ( mkoperator ~loc:_sloc _1 )
+# 10050 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2462 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkinfix e1 op e2 )
+# 10056 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 10066 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 10072 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = e2;
+          MenhirLib.EngineTypes.startp = _startpos_e2_;
+          MenhirLib.EngineTypes.endp = _endpos_e2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = op;
+            MenhirLib.EngineTypes.startp = _startpos_op_;
+            MenhirLib.EngineTypes.endp = _endpos_op_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = e1;
+              MenhirLib.EngineTypes.startp = _startpos_e1_;
+              MenhirLib.EngineTypes.endp = _endpos_e1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let e2 : (Parsetree.expression) = Obj.magic e2 in
+        let op : (
+# 765 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 10106 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic op in
+        let e1 : (Parsetree.expression) = Obj.magic e1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_e1_ in
+        let _endpos = _endpos_e2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let op =
+              let _1 = 
+# 3715 "src/ocaml/preprocess/parser_raw.mly"
+                  ( op )
+# 10118 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let (_endpos__1_, _startpos__1_) = (_endpos_op_, _startpos_op_) in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1007 "src/ocaml/preprocess/parser_raw.mly"
+   ( mkoperator ~loc:_sloc _1 )
+# 10127 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2462 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkinfix e1 op e2 )
+# 10133 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 10143 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 10149 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = e2;
+          MenhirLib.EngineTypes.startp = _startpos_e2_;
+          MenhirLib.EngineTypes.endp = _endpos_e2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = op;
+            MenhirLib.EngineTypes.startp = _startpos_op_;
+            MenhirLib.EngineTypes.endp = _endpos_op_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = e1;
+              MenhirLib.EngineTypes.startp = _startpos_e1_;
+              MenhirLib.EngineTypes.endp = _endpos_e1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let e2 : (Parsetree.expression) = Obj.magic e2 in
+        let op : (
+# 766 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 10183 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic op in
+        let e1 : (Parsetree.expression) = Obj.magic e1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_e1_ in
+        let _endpos = _endpos_e2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let op =
+              let _1 = 
+# 3716 "src/ocaml/preprocess/parser_raw.mly"
+                  ( op )
+# 10195 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let (_endpos__1_, _startpos__1_) = (_endpos_op_, _startpos_op_) in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1007 "src/ocaml/preprocess/parser_raw.mly"
+   ( mkoperator ~loc:_sloc _1 )
+# 10204 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2462 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkinfix e1 op e2 )
+# 10210 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 10220 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 10226 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = e2;
+          MenhirLib.EngineTypes.startp = _startpos_e2_;
+          MenhirLib.EngineTypes.endp = _endpos_e2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = op;
+            MenhirLib.EngineTypes.startp = _startpos_op_;
+            MenhirLib.EngineTypes.endp = _endpos_op_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = e1;
+              MenhirLib.EngineTypes.startp = _startpos_e1_;
+              MenhirLib.EngineTypes.endp = _endpos_e1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let e2 : (Parsetree.expression) = Obj.magic e2 in
+        let op : (
+# 767 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 10260 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic op in
+        let e1 : (Parsetree.expression) = Obj.magic e1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_e1_ in
+        let _endpos = _endpos_e2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let op =
+              let _1 = 
+# 3717 "src/ocaml/preprocess/parser_raw.mly"
+                  ( op )
+# 10272 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let (_endpos__1_, _startpos__1_) = (_endpos_op_, _startpos_op_) in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1007 "src/ocaml/preprocess/parser_raw.mly"
+   ( mkoperator ~loc:_sloc _1 )
+# 10281 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2462 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkinfix e1 op e2 )
+# 10287 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 10297 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 10303 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = e2;
+          MenhirLib.EngineTypes.startp = _startpos_e2_;
+          MenhirLib.EngineTypes.endp = _endpos_e2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = e1;
+              MenhirLib.EngineTypes.startp = _startpos_e1_;
+              MenhirLib.EngineTypes.endp = _endpos_e1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let e2 : (Parsetree.expression) = Obj.magic e2 in
+        let _1 : unit = Obj.magic _1 in
+        let e1 : (Parsetree.expression) = Obj.magic e1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_e1_ in
+        let _endpos = _endpos_e2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let op =
+              let _1 = 
+# 3718 "src/ocaml/preprocess/parser_raw.mly"
+                   ("+")
+# 10345 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1007 "src/ocaml/preprocess/parser_raw.mly"
+   ( mkoperator ~loc:_sloc _1 )
+# 10353 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2462 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkinfix e1 op e2 )
+# 10359 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 10369 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 10375 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = e2;
+          MenhirLib.EngineTypes.startp = _startpos_e2_;
+          MenhirLib.EngineTypes.endp = _endpos_e2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = e1;
+              MenhirLib.EngineTypes.startp = _startpos_e1_;
+              MenhirLib.EngineTypes.endp = _endpos_e1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let e2 : (Parsetree.expression) = Obj.magic e2 in
+        let _1 : unit = Obj.magic _1 in
+        let e1 : (Parsetree.expression) = Obj.magic e1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_e1_ in
+        let _endpos = _endpos_e2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let op =
+              let _1 = 
+# 3719 "src/ocaml/preprocess/parser_raw.mly"
+                  ("+.")
+# 10417 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1007 "src/ocaml/preprocess/parser_raw.mly"
+   ( mkoperator ~loc:_sloc _1 )
+# 10425 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2462 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkinfix e1 op e2 )
+# 10431 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 10441 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 10447 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = e2;
+          MenhirLib.EngineTypes.startp = _startpos_e2_;
+          MenhirLib.EngineTypes.endp = _endpos_e2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = e1;
+              MenhirLib.EngineTypes.startp = _startpos_e1_;
+              MenhirLib.EngineTypes.endp = _endpos_e1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let e2 : (Parsetree.expression) = Obj.magic e2 in
+        let _1 : unit = Obj.magic _1 in
+        let e1 : (Parsetree.expression) = Obj.magic e1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_e1_ in
+        let _endpos = _endpos_e2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let op =
+              let _1 = 
+# 3720 "src/ocaml/preprocess/parser_raw.mly"
+                  ("+=")
+# 10489 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1007 "src/ocaml/preprocess/parser_raw.mly"
+   ( mkoperator ~loc:_sloc _1 )
+# 10497 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2462 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkinfix e1 op e2 )
+# 10503 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 10513 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 10519 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = e2;
+          MenhirLib.EngineTypes.startp = _startpos_e2_;
+          MenhirLib.EngineTypes.endp = _endpos_e2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = e1;
+              MenhirLib.EngineTypes.startp = _startpos_e1_;
+              MenhirLib.EngineTypes.endp = _endpos_e1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let e2 : (Parsetree.expression) = Obj.magic e2 in
+        let _1 : unit = Obj.magic _1 in
+        let e1 : (Parsetree.expression) = Obj.magic e1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_e1_ in
+        let _endpos = _endpos_e2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let op =
+              let _1 = 
+# 3721 "src/ocaml/preprocess/parser_raw.mly"
+                   ("-")
+# 10561 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1007 "src/ocaml/preprocess/parser_raw.mly"
+   ( mkoperator ~loc:_sloc _1 )
+# 10569 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2462 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkinfix e1 op e2 )
+# 10575 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 10585 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 10591 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = e2;
+          MenhirLib.EngineTypes.startp = _startpos_e2_;
+          MenhirLib.EngineTypes.endp = _endpos_e2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = e1;
+              MenhirLib.EngineTypes.startp = _startpos_e1_;
+              MenhirLib.EngineTypes.endp = _endpos_e1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let e2 : (Parsetree.expression) = Obj.magic e2 in
+        let _1 : unit = Obj.magic _1 in
+        let e1 : (Parsetree.expression) = Obj.magic e1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_e1_ in
+        let _endpos = _endpos_e2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let op =
+              let _1 = 
+# 3722 "src/ocaml/preprocess/parser_raw.mly"
+                  ("-.")
+# 10633 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1007 "src/ocaml/preprocess/parser_raw.mly"
+   ( mkoperator ~loc:_sloc _1 )
+# 10641 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2462 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkinfix e1 op e2 )
+# 10647 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 10657 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 10663 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = e2;
+          MenhirLib.EngineTypes.startp = _startpos_e2_;
+          MenhirLib.EngineTypes.endp = _endpos_e2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = e1;
+              MenhirLib.EngineTypes.startp = _startpos_e1_;
+              MenhirLib.EngineTypes.endp = _endpos_e1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let e2 : (Parsetree.expression) = Obj.magic e2 in
+        let _1 : unit = Obj.magic _1 in
+        let e1 : (Parsetree.expression) = Obj.magic e1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_e1_ in
+        let _endpos = _endpos_e2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let op =
+              let _1 = 
+# 3723 "src/ocaml/preprocess/parser_raw.mly"
+                   ("*")
+# 10705 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1007 "src/ocaml/preprocess/parser_raw.mly"
+   ( mkoperator ~loc:_sloc _1 )
+# 10713 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2462 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkinfix e1 op e2 )
+# 10719 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 10729 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 10735 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = e2;
+          MenhirLib.EngineTypes.startp = _startpos_e2_;
+          MenhirLib.EngineTypes.endp = _endpos_e2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = e1;
+              MenhirLib.EngineTypes.startp = _startpos_e1_;
+              MenhirLib.EngineTypes.endp = _endpos_e1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let e2 : (Parsetree.expression) = Obj.magic e2 in
+        let _1 : unit = Obj.magic _1 in
+        let e1 : (Parsetree.expression) = Obj.magic e1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_e1_ in
+        let _endpos = _endpos_e2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let op =
+              let _1 = 
+# 3724 "src/ocaml/preprocess/parser_raw.mly"
+                   ("%")
+# 10777 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1007 "src/ocaml/preprocess/parser_raw.mly"
+   ( mkoperator ~loc:_sloc _1 )
+# 10785 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2462 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkinfix e1 op e2 )
+# 10791 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 10801 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 10807 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = e2;
+          MenhirLib.EngineTypes.startp = _startpos_e2_;
+          MenhirLib.EngineTypes.endp = _endpos_e2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = e1;
+              MenhirLib.EngineTypes.startp = _startpos_e1_;
+              MenhirLib.EngineTypes.endp = _endpos_e1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let e2 : (Parsetree.expression) = Obj.magic e2 in
+        let _1 : unit = Obj.magic _1 in
+        let e1 : (Parsetree.expression) = Obj.magic e1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_e1_ in
+        let _endpos = _endpos_e2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let op =
+              let _1 = 
+# 3725 "src/ocaml/preprocess/parser_raw.mly"
+                   ("=")
+# 10849 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1007 "src/ocaml/preprocess/parser_raw.mly"
+   ( mkoperator ~loc:_sloc _1 )
+# 10857 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2462 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkinfix e1 op e2 )
+# 10863 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 10873 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 10879 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = e2;
+          MenhirLib.EngineTypes.startp = _startpos_e2_;
+          MenhirLib.EngineTypes.endp = _endpos_e2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = e1;
+              MenhirLib.EngineTypes.startp = _startpos_e1_;
+              MenhirLib.EngineTypes.endp = _endpos_e1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let e2 : (Parsetree.expression) = Obj.magic e2 in
+        let _1 : unit = Obj.magic _1 in
+        let e1 : (Parsetree.expression) = Obj.magic e1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_e1_ in
+        let _endpos = _endpos_e2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let op =
+              let _1 = 
+# 3726 "src/ocaml/preprocess/parser_raw.mly"
+                   ("<")
+# 10921 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1007 "src/ocaml/preprocess/parser_raw.mly"
+   ( mkoperator ~loc:_sloc _1 )
+# 10929 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2462 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkinfix e1 op e2 )
+# 10935 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 10945 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 10951 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = e2;
+          MenhirLib.EngineTypes.startp = _startpos_e2_;
+          MenhirLib.EngineTypes.endp = _endpos_e2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = e1;
+              MenhirLib.EngineTypes.startp = _startpos_e1_;
+              MenhirLib.EngineTypes.endp = _endpos_e1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let e2 : (Parsetree.expression) = Obj.magic e2 in
+        let _1 : unit = Obj.magic _1 in
+        let e1 : (Parsetree.expression) = Obj.magic e1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_e1_ in
+        let _endpos = _endpos_e2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let op =
+              let _1 = 
+# 3727 "src/ocaml/preprocess/parser_raw.mly"
+                   (">")
+# 10993 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1007 "src/ocaml/preprocess/parser_raw.mly"
+   ( mkoperator ~loc:_sloc _1 )
+# 11001 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2462 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkinfix e1 op e2 )
+# 11007 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 11017 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 11023 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = e2;
+          MenhirLib.EngineTypes.startp = _startpos_e2_;
+          MenhirLib.EngineTypes.endp = _endpos_e2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = e1;
+              MenhirLib.EngineTypes.startp = _startpos_e1_;
+              MenhirLib.EngineTypes.endp = _endpos_e1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let e2 : (Parsetree.expression) = Obj.magic e2 in
+        let _1 : unit = Obj.magic _1 in
+        let e1 : (Parsetree.expression) = Obj.magic e1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_e1_ in
+        let _endpos = _endpos_e2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let op =
+              let _1 = 
+# 3728 "src/ocaml/preprocess/parser_raw.mly"
+                  ("or")
+# 11065 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1007 "src/ocaml/preprocess/parser_raw.mly"
+   ( mkoperator ~loc:_sloc _1 )
+# 11073 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2462 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkinfix e1 op e2 )
+# 11079 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 11089 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 11095 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = e2;
+          MenhirLib.EngineTypes.startp = _startpos_e2_;
+          MenhirLib.EngineTypes.endp = _endpos_e2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = e1;
+              MenhirLib.EngineTypes.startp = _startpos_e1_;
+              MenhirLib.EngineTypes.endp = _endpos_e1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let e2 : (Parsetree.expression) = Obj.magic e2 in
+        let _1 : unit = Obj.magic _1 in
+        let e1 : (Parsetree.expression) = Obj.magic e1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_e1_ in
+        let _endpos = _endpos_e2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let op =
+              let _1 = 
+# 3729 "src/ocaml/preprocess/parser_raw.mly"
+                  ("||")
+# 11137 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1007 "src/ocaml/preprocess/parser_raw.mly"
+   ( mkoperator ~loc:_sloc _1 )
+# 11145 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2462 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkinfix e1 op e2 )
+# 11151 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 11161 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 11167 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = e2;
+          MenhirLib.EngineTypes.startp = _startpos_e2_;
+          MenhirLib.EngineTypes.endp = _endpos_e2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = e1;
+              MenhirLib.EngineTypes.startp = _startpos_e1_;
+              MenhirLib.EngineTypes.endp = _endpos_e1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let e2 : (Parsetree.expression) = Obj.magic e2 in
+        let _1 : unit = Obj.magic _1 in
+        let e1 : (Parsetree.expression) = Obj.magic e1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_e1_ in
+        let _endpos = _endpos_e2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let op =
+              let _1 = 
+# 3730 "src/ocaml/preprocess/parser_raw.mly"
+                   ("&")
+# 11209 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1007 "src/ocaml/preprocess/parser_raw.mly"
+   ( mkoperator ~loc:_sloc _1 )
+# 11217 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2462 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkinfix e1 op e2 )
+# 11223 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 11233 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 11239 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = e2;
+          MenhirLib.EngineTypes.startp = _startpos_e2_;
+          MenhirLib.EngineTypes.endp = _endpos_e2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = e1;
+              MenhirLib.EngineTypes.startp = _startpos_e1_;
+              MenhirLib.EngineTypes.endp = _endpos_e1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let e2 : (Parsetree.expression) = Obj.magic e2 in
+        let _1 : unit = Obj.magic _1 in
+        let e1 : (Parsetree.expression) = Obj.magic e1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_e1_ in
+        let _endpos = _endpos_e2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let op =
+              let _1 = 
+# 3731 "src/ocaml/preprocess/parser_raw.mly"
+                  ("&&")
+# 11281 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1007 "src/ocaml/preprocess/parser_raw.mly"
+   ( mkoperator ~loc:_sloc _1 )
+# 11289 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2462 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkinfix e1 op e2 )
+# 11295 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 11305 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 11311 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = e2;
+          MenhirLib.EngineTypes.startp = _startpos_e2_;
+          MenhirLib.EngineTypes.endp = _endpos_e2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = e1;
+              MenhirLib.EngineTypes.startp = _startpos_e1_;
+              MenhirLib.EngineTypes.endp = _endpos_e1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let e2 : (Parsetree.expression) = Obj.magic e2 in
+        let _1 : unit = Obj.magic _1 in
+        let e1 : (Parsetree.expression) = Obj.magic e1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_e1_ in
+        let _endpos = _endpos_e2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let op =
+              let _1 = 
+# 3732 "src/ocaml/preprocess/parser_raw.mly"
+                  (":=")
+# 11353 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1007 "src/ocaml/preprocess/parser_raw.mly"
+   ( mkoperator ~loc:_sloc _1 )
+# 11361 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2462 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkinfix e1 op e2 )
+# 11367 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 11377 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 11383 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.expression) = Obj.magic _2 in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let _loc__1_ = (_startpos__1_, _endpos__1_) in
+            
+# 2464 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkuminus ~oploc:_loc__1_ _1 _2 )
+# 11418 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__2_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 11428 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 11434 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.expression) = Obj.magic _2 in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let _loc__1_ = (_startpos__1_, _endpos__1_) in
+            
+# 2466 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkuplus ~oploc:_loc__1_ _1 _2 )
+# 11469 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__2_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 11479 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2380 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 11485 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.expression) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Ast_helper.let_bindings) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.expression) = let _endpos = _endpos__3_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2382 "src/ocaml/preprocess/parser_raw.mly"
+      ( expr_of_let_bindings ~loc:_sloc _1 (merloc _endpos__2_ _3) )
+# 11527 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = body;
+          MenhirLib.EngineTypes.startp = _startpos_body_;
+          MenhirLib.EngineTypes.endp = _endpos_body_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = bindings;
+              MenhirLib.EngineTypes.startp = _startpos_bindings_;
+              MenhirLib.EngineTypes.endp = _endpos_bindings_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let body : (Parsetree.expression) = Obj.magic body in
+        let _3 : unit = Obj.magic _3 in
+        let bindings : (Parsetree.pattern * Parsetree.expression * Parsetree.binding_op list) = Obj.magic bindings in
+        let _1 : (
+# 769 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 11569 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_body_ in
+        let _v : (Parsetree.expression) = let pbop_op =
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 11581 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _startpos_pbop_op_ = _startpos__1_ in
+        let _endpos = _endpos_body_ in
+        let _symbolstartpos = _startpos_pbop_op_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2384 "src/ocaml/preprocess/parser_raw.mly"
+      ( let (pbop_pat, pbop_exp, rev_ands) = bindings in
+        let ands = List.rev rev_ands in
+        let pbop_loc = make_loc _sloc in
+        let let_ = {pbop_op; pbop_pat; pbop_exp; pbop_loc} in
+        mkexp ~loc:_sloc (Pexp_letop{ let_; ands; body}) )
+# 11595 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.expression) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.expression) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.expression) = let _endpos = _endpos__3_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _loc__2_ = (_startpos__2_, _endpos__2_) in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2390 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkexp_cons ~loc:_sloc _loc__2_ (ghexp ~loc:_sloc (Pexp_tuple[_1;(merloc _endpos__2_ _3)])) )
+# 11638 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.expression) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 11673 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 = 
+# 3661 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 11682 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 11690 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__3_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2392 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkexp ~loc:_sloc (Pexp_setinstvar(_1, _3)) )
+# 11699 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : (Parsetree.expression) = Obj.magic _5 in
+        let _4 : unit = Obj.magic _4 in
+        let _1_inlined1 : (Longident.t) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.expression) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.expression) = let _3 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 11757 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__5_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2394 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkexp ~loc:_sloc (Pexp_setfield(_1, _3, _5)) )
+# 11766 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = v;
+          MenhirLib.EngineTypes.startp = _startpos_v_;
+          MenhirLib.EngineTypes.endp = _endpos_v_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _5;
+              MenhirLib.EngineTypes.startp = _startpos__5_;
+              MenhirLib.EngineTypes.endp = _endpos__5_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = i;
+                MenhirLib.EngineTypes.startp = _startpos_i_;
+                MenhirLib.EngineTypes.endp = _endpos_i_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _3;
+                  MenhirLib.EngineTypes.startp = _startpos__3_;
+                  MenhirLib.EngineTypes.endp = _endpos__3_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = d;
+                    MenhirLib.EngineTypes.startp = _startpos_d_;
+                    MenhirLib.EngineTypes.endp = _endpos_d_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = array;
+                      MenhirLib.EngineTypes.startp = _startpos_array_;
+                      MenhirLib.EngineTypes.endp = _endpos_array_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let v : (Parsetree.expression) = Obj.magic v in
+        let _1 : unit = Obj.magic _1 in
+        let _5 : unit = Obj.magic _5 in
+        let i : (Parsetree.expression) = Obj.magic i in
+        let _3 : unit = Obj.magic _3 in
+        let d : unit = Obj.magic d in
+        let array : (Parsetree.expression) = Obj.magic array in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_array_ in
+        let _endpos = _endpos_v_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let r = 
+# 2395 "src/ocaml/preprocess/parser_raw.mly"
+                                                 (Some v)
+# 11834 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          
+# 2355 "src/ocaml/preprocess/parser_raw.mly"
+    ( array, d, Paren,   i, r )
+# 11839 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2396 "src/ocaml/preprocess/parser_raw.mly"
+    ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 )
+# 11849 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = v;
+          MenhirLib.EngineTypes.startp = _startpos_v_;
+          MenhirLib.EngineTypes.endp = _endpos_v_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _5;
+              MenhirLib.EngineTypes.startp = _startpos__5_;
+              MenhirLib.EngineTypes.endp = _endpos__5_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = i;
+                MenhirLib.EngineTypes.startp = _startpos_i_;
+                MenhirLib.EngineTypes.endp = _endpos_i_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _3;
+                  MenhirLib.EngineTypes.startp = _startpos__3_;
+                  MenhirLib.EngineTypes.endp = _endpos__3_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = d;
+                    MenhirLib.EngineTypes.startp = _startpos_d_;
+                    MenhirLib.EngineTypes.endp = _endpos_d_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = array;
+                      MenhirLib.EngineTypes.startp = _startpos_array_;
+                      MenhirLib.EngineTypes.endp = _endpos_array_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let v : (Parsetree.expression) = Obj.magic v in
+        let _1 : unit = Obj.magic _1 in
+        let _5 : unit = Obj.magic _5 in
+        let i : (Parsetree.expression) = Obj.magic i in
+        let _3 : unit = Obj.magic _3 in
+        let d : unit = Obj.magic d in
+        let array : (Parsetree.expression) = Obj.magic array in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_array_ in
+        let _endpos = _endpos_v_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let r = 
+# 2395 "src/ocaml/preprocess/parser_raw.mly"
+                                                 (Some v)
+# 11917 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          
+# 2357 "src/ocaml/preprocess/parser_raw.mly"
+    ( array, d, Brace,   i, r )
+# 11922 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2396 "src/ocaml/preprocess/parser_raw.mly"
+    ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 )
+# 11932 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = v;
+          MenhirLib.EngineTypes.startp = _startpos_v_;
+          MenhirLib.EngineTypes.endp = _endpos_v_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _5;
+              MenhirLib.EngineTypes.startp = _startpos__5_;
+              MenhirLib.EngineTypes.endp = _endpos__5_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = i;
+                MenhirLib.EngineTypes.startp = _startpos_i_;
+                MenhirLib.EngineTypes.endp = _endpos_i_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _3;
+                  MenhirLib.EngineTypes.startp = _startpos__3_;
+                  MenhirLib.EngineTypes.endp = _endpos__3_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = d;
+                    MenhirLib.EngineTypes.startp = _startpos_d_;
+                    MenhirLib.EngineTypes.endp = _endpos_d_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = array;
+                      MenhirLib.EngineTypes.startp = _startpos_array_;
+                      MenhirLib.EngineTypes.endp = _endpos_array_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let v : (Parsetree.expression) = Obj.magic v in
+        let _1 : unit = Obj.magic _1 in
+        let _5 : unit = Obj.magic _5 in
+        let i : (Parsetree.expression) = Obj.magic i in
+        let _3 : unit = Obj.magic _3 in
+        let d : unit = Obj.magic d in
+        let array : (Parsetree.expression) = Obj.magic array in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_array_ in
+        let _endpos = _endpos_v_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let r = 
+# 2395 "src/ocaml/preprocess/parser_raw.mly"
+                                                 (Some v)
+# 12000 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          
+# 2359 "src/ocaml/preprocess/parser_raw.mly"
+    ( array, d, Bracket, i, r )
+# 12005 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2396 "src/ocaml/preprocess/parser_raw.mly"
+    ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 )
+# 12015 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = v;
+          MenhirLib.EngineTypes.startp = _startpos_v_;
+          MenhirLib.EngineTypes.endp = _endpos_v_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _5;
+              MenhirLib.EngineTypes.startp = _startpos__5_;
+              MenhirLib.EngineTypes.endp = _endpos__5_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = es;
+                MenhirLib.EngineTypes.startp = _startpos_es_;
+                MenhirLib.EngineTypes.endp = _endpos_es_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _3;
+                  MenhirLib.EngineTypes.startp = _startpos__3_;
+                  MenhirLib.EngineTypes.endp = _endpos__3_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _2;
+                    MenhirLib.EngineTypes.startp = _startpos__2_;
+                    MenhirLib.EngineTypes.endp = _endpos__2_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = array;
+                      MenhirLib.EngineTypes.startp = _startpos_array_;
+                      MenhirLib.EngineTypes.endp = _endpos_array_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let v : (Parsetree.expression) = Obj.magic v in
+        let _1 : unit = Obj.magic _1 in
+        let _5 : unit = Obj.magic _5 in
+        let es : (Parsetree.expression list) = Obj.magic es in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (
+# 768 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 12077 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _2 in
+        let array : (Parsetree.expression) = Obj.magic array in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_array_ in
+        let _endpos = _endpos_v_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let r = 
+# 2397 "src/ocaml/preprocess/parser_raw.mly"
+                                                                   (Some v)
+# 12087 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let i = 
+# 2827 "src/ocaml/preprocess/parser_raw.mly"
+    ( es )
+# 12092 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let d =
+            let _1 = 
+# 124 "<standard.mly>"
+    ( None )
+# 12098 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 2371 "src/ocaml/preprocess/parser_raw.mly"
+                                                               ( _1, _2 )
+# 12103 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2355 "src/ocaml/preprocess/parser_raw.mly"
+    ( array, d, Paren,   i, r )
+# 12109 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2398 "src/ocaml/preprocess/parser_raw.mly"
+    ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 )
+# 12119 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = v;
+          MenhirLib.EngineTypes.startp = _startpos_v_;
+          MenhirLib.EngineTypes.endp = _endpos_v_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _5;
+              MenhirLib.EngineTypes.startp = _startpos__5_;
+              MenhirLib.EngineTypes.endp = _endpos__5_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = es;
+                MenhirLib.EngineTypes.startp = _startpos_es_;
+                MenhirLib.EngineTypes.endp = _endpos_es_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _3;
+                  MenhirLib.EngineTypes.startp = _startpos__3_;
+                  MenhirLib.EngineTypes.endp = _endpos__3_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _2;
+                    MenhirLib.EngineTypes.startp = _startpos__2_;
+                    MenhirLib.EngineTypes.endp = _endpos__2_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _2_inlined1;
+                      MenhirLib.EngineTypes.startp = _startpos__2_inlined1_;
+                      MenhirLib.EngineTypes.endp = _endpos__2_inlined1_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = _1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _menhir_s;
+                          MenhirLib.EngineTypes.semv = array;
+                          MenhirLib.EngineTypes.startp = _startpos_array_;
+                          MenhirLib.EngineTypes.endp = _endpos_array_;
+                          MenhirLib.EngineTypes.next = _menhir_stack;
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let v : (Parsetree.expression) = Obj.magic v in
+        let _1_inlined1 : unit = Obj.magic _1_inlined1 in
+        let _5 : unit = Obj.magic _5 in
+        let es : (Parsetree.expression list) = Obj.magic es in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (
+# 768 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 12193 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _2 in
+        let _2_inlined1 : (Longident.t) = Obj.magic _2_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let array : (Parsetree.expression) = Obj.magic array in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_array_ in
+        let _endpos = _endpos_v_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let r =
+            let _1 = _1_inlined1 in
+            
+# 2397 "src/ocaml/preprocess/parser_raw.mly"
+                                                                   (Some v)
+# 12207 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let i = 
+# 2827 "src/ocaml/preprocess/parser_raw.mly"
+    ( es )
+# 12213 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let d =
+            let _1 =
+              let _2 = _2_inlined1 in
+              let x = 
+# 2371 "src/ocaml/preprocess/parser_raw.mly"
+                                                   (_2)
+# 12221 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              
+# 126 "<standard.mly>"
+    ( Some x )
+# 12226 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2371 "src/ocaml/preprocess/parser_raw.mly"
+                                                               ( _1, _2 )
+# 12232 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2355 "src/ocaml/preprocess/parser_raw.mly"
+    ( array, d, Paren,   i, r )
+# 12238 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2398 "src/ocaml/preprocess/parser_raw.mly"
+    ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 )
+# 12248 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = v;
+          MenhirLib.EngineTypes.startp = _startpos_v_;
+          MenhirLib.EngineTypes.endp = _endpos_v_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _5;
+              MenhirLib.EngineTypes.startp = _startpos__5_;
+              MenhirLib.EngineTypes.endp = _endpos__5_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = es;
+                MenhirLib.EngineTypes.startp = _startpos_es_;
+                MenhirLib.EngineTypes.endp = _endpos_es_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _3;
+                  MenhirLib.EngineTypes.startp = _startpos__3_;
+                  MenhirLib.EngineTypes.endp = _endpos__3_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _2;
+                    MenhirLib.EngineTypes.startp = _startpos__2_;
+                    MenhirLib.EngineTypes.endp = _endpos__2_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = array;
+                      MenhirLib.EngineTypes.startp = _startpos_array_;
+                      MenhirLib.EngineTypes.endp = _endpos_array_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let v : (Parsetree.expression) = Obj.magic v in
+        let _1 : unit = Obj.magic _1 in
+        let _5 : unit = Obj.magic _5 in
+        let es : (Parsetree.expression list) = Obj.magic es in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (
+# 768 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 12310 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _2 in
+        let array : (Parsetree.expression) = Obj.magic array in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_array_ in
+        let _endpos = _endpos_v_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let r = 
+# 2397 "src/ocaml/preprocess/parser_raw.mly"
+                                                                   (Some v)
+# 12320 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let i = 
+# 2827 "src/ocaml/preprocess/parser_raw.mly"
+    ( es )
+# 12325 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let d =
+            let _1 = 
+# 124 "<standard.mly>"
+    ( None )
+# 12331 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 2371 "src/ocaml/preprocess/parser_raw.mly"
+                                                               ( _1, _2 )
+# 12336 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2357 "src/ocaml/preprocess/parser_raw.mly"
+    ( array, d, Brace,   i, r )
+# 12342 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2398 "src/ocaml/preprocess/parser_raw.mly"
+    ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 )
+# 12352 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = v;
+          MenhirLib.EngineTypes.startp = _startpos_v_;
+          MenhirLib.EngineTypes.endp = _endpos_v_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _5;
+              MenhirLib.EngineTypes.startp = _startpos__5_;
+              MenhirLib.EngineTypes.endp = _endpos__5_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = es;
+                MenhirLib.EngineTypes.startp = _startpos_es_;
+                MenhirLib.EngineTypes.endp = _endpos_es_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _3;
+                  MenhirLib.EngineTypes.startp = _startpos__3_;
+                  MenhirLib.EngineTypes.endp = _endpos__3_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _2;
+                    MenhirLib.EngineTypes.startp = _startpos__2_;
+                    MenhirLib.EngineTypes.endp = _endpos__2_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _2_inlined1;
+                      MenhirLib.EngineTypes.startp = _startpos__2_inlined1_;
+                      MenhirLib.EngineTypes.endp = _endpos__2_inlined1_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = _1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _menhir_s;
+                          MenhirLib.EngineTypes.semv = array;
+                          MenhirLib.EngineTypes.startp = _startpos_array_;
+                          MenhirLib.EngineTypes.endp = _endpos_array_;
+                          MenhirLib.EngineTypes.next = _menhir_stack;
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let v : (Parsetree.expression) = Obj.magic v in
+        let _1_inlined1 : unit = Obj.magic _1_inlined1 in
+        let _5 : unit = Obj.magic _5 in
+        let es : (Parsetree.expression list) = Obj.magic es in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (
+# 768 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 12426 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _2 in
+        let _2_inlined1 : (Longident.t) = Obj.magic _2_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let array : (Parsetree.expression) = Obj.magic array in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_array_ in
+        let _endpos = _endpos_v_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let r =
+            let _1 = _1_inlined1 in
+            
+# 2397 "src/ocaml/preprocess/parser_raw.mly"
+                                                                   (Some v)
+# 12440 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let i = 
+# 2827 "src/ocaml/preprocess/parser_raw.mly"
+    ( es )
+# 12446 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let d =
+            let _1 =
+              let _2 = _2_inlined1 in
+              let x = 
+# 2371 "src/ocaml/preprocess/parser_raw.mly"
+                                                   (_2)
+# 12454 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              
+# 126 "<standard.mly>"
+    ( Some x )
+# 12459 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2371 "src/ocaml/preprocess/parser_raw.mly"
+                                                               ( _1, _2 )
+# 12465 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2357 "src/ocaml/preprocess/parser_raw.mly"
+    ( array, d, Brace,   i, r )
+# 12471 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2398 "src/ocaml/preprocess/parser_raw.mly"
+    ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 )
+# 12481 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = v;
+          MenhirLib.EngineTypes.startp = _startpos_v_;
+          MenhirLib.EngineTypes.endp = _endpos_v_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _5;
+              MenhirLib.EngineTypes.startp = _startpos__5_;
+              MenhirLib.EngineTypes.endp = _endpos__5_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = es;
+                MenhirLib.EngineTypes.startp = _startpos_es_;
+                MenhirLib.EngineTypes.endp = _endpos_es_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _3;
+                  MenhirLib.EngineTypes.startp = _startpos__3_;
+                  MenhirLib.EngineTypes.endp = _endpos__3_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _2;
+                    MenhirLib.EngineTypes.startp = _startpos__2_;
+                    MenhirLib.EngineTypes.endp = _endpos__2_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = array;
+                      MenhirLib.EngineTypes.startp = _startpos_array_;
+                      MenhirLib.EngineTypes.endp = _endpos_array_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let v : (Parsetree.expression) = Obj.magic v in
+        let _1 : unit = Obj.magic _1 in
+        let _5 : unit = Obj.magic _5 in
+        let es : (Parsetree.expression list) = Obj.magic es in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (
+# 768 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 12543 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _2 in
+        let array : (Parsetree.expression) = Obj.magic array in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_array_ in
+        let _endpos = _endpos_v_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let r = 
+# 2397 "src/ocaml/preprocess/parser_raw.mly"
+                                                                   (Some v)
+# 12553 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let i = 
+# 2827 "src/ocaml/preprocess/parser_raw.mly"
+    ( es )
+# 12558 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let d =
+            let _1 = 
+# 124 "<standard.mly>"
+    ( None )
+# 12564 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 2371 "src/ocaml/preprocess/parser_raw.mly"
+                                                               ( _1, _2 )
+# 12569 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2359 "src/ocaml/preprocess/parser_raw.mly"
+    ( array, d, Bracket, i, r )
+# 12575 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2398 "src/ocaml/preprocess/parser_raw.mly"
+    ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 )
+# 12585 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = v;
+          MenhirLib.EngineTypes.startp = _startpos_v_;
+          MenhirLib.EngineTypes.endp = _endpos_v_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _5;
+              MenhirLib.EngineTypes.startp = _startpos__5_;
+              MenhirLib.EngineTypes.endp = _endpos__5_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = es;
+                MenhirLib.EngineTypes.startp = _startpos_es_;
+                MenhirLib.EngineTypes.endp = _endpos_es_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _3;
+                  MenhirLib.EngineTypes.startp = _startpos__3_;
+                  MenhirLib.EngineTypes.endp = _endpos__3_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _2;
+                    MenhirLib.EngineTypes.startp = _startpos__2_;
+                    MenhirLib.EngineTypes.endp = _endpos__2_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _2_inlined1;
+                      MenhirLib.EngineTypes.startp = _startpos__2_inlined1_;
+                      MenhirLib.EngineTypes.endp = _endpos__2_inlined1_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = _1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _menhir_s;
+                          MenhirLib.EngineTypes.semv = array;
+                          MenhirLib.EngineTypes.startp = _startpos_array_;
+                          MenhirLib.EngineTypes.endp = _endpos_array_;
+                          MenhirLib.EngineTypes.next = _menhir_stack;
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let v : (Parsetree.expression) = Obj.magic v in
+        let _1_inlined1 : unit = Obj.magic _1_inlined1 in
+        let _5 : unit = Obj.magic _5 in
+        let es : (Parsetree.expression list) = Obj.magic es in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (
+# 768 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 12659 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _2 in
+        let _2_inlined1 : (Longident.t) = Obj.magic _2_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let array : (Parsetree.expression) = Obj.magic array in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_array_ in
+        let _endpos = _endpos_v_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let r =
+            let _1 = _1_inlined1 in
+            
+# 2397 "src/ocaml/preprocess/parser_raw.mly"
+                                                                   (Some v)
+# 12673 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let i = 
+# 2827 "src/ocaml/preprocess/parser_raw.mly"
+    ( es )
+# 12679 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let d =
+            let _1 =
+              let _2 = _2_inlined1 in
+              let x = 
+# 2371 "src/ocaml/preprocess/parser_raw.mly"
+                                                   (_2)
+# 12687 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              
+# 126 "<standard.mly>"
+    ( Some x )
+# 12692 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2371 "src/ocaml/preprocess/parser_raw.mly"
+                                                               ( _1, _2 )
+# 12698 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2359 "src/ocaml/preprocess/parser_raw.mly"
+    ( array, d, Bracket, i, r )
+# 12704 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2398 "src/ocaml/preprocess/parser_raw.mly"
+    ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 )
+# 12714 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.attribute) = Obj.magic _2 in
+        let _1 : (Parsetree.expression) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.expression) = 
+# 2400 "src/ocaml/preprocess/parser_raw.mly"
+      ( Exp.attr _1 _2 )
+# 12746 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (string Location.loc option) = 
+# 4008 "src/ocaml/preprocess/parser_raw.mly"
+                    ( None )
+# 12764 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (string Location.loc) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (string Location.loc option) = 
+# 4009 "src/ocaml/preprocess/parser_raw.mly"
+                    ( Some _2 )
+# 12796 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (Parsetree.payload) = Obj.magic _3 in
+        let _2 : (string Location.loc) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (Parsetree.extension) = 
+# 4021 "src/ocaml/preprocess/parser_raw.mly"
+                                             ( (_2, _3) )
+# 12842 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 827 "src/ocaml/preprocess/parser_raw.mly"
+  (string * Location.t * string * Location.t * string option)
+# 12863 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.extension) = let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 4023 "src/ocaml/preprocess/parser_raw.mly"
+    ( mk_quotedext ~loc:_sloc _1 )
+# 12874 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined3;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined2;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined1;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let _1_inlined2 : (Longident.t) = Obj.magic _1_inlined2 in
+        let _3 : unit = Obj.magic _3 in
+        let _1_inlined1 : (string) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined3_ in
+        let _v : (Parsetree.extension_constructor) = let attrs =
+          let _1 = _1_inlined3 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 12929 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_attrs_ = _endpos__1_inlined3_ in
+        let lid =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 12941 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let cid =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 12952 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_attrs_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3367 "src/ocaml/preprocess/parser_raw.mly"
+      ( let info = symbol_info _endpos in
+        Te.rebind cid lid ~attrs ~loc:(make_loc _sloc) ~info )
+# 12962 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined2;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (Longident.t) = Obj.magic _1_inlined1 in
+        let _3 : unit = Obj.magic _3 in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined2_ in
+        let _v : (Parsetree.extension_constructor) = let attrs =
+          let _1 = _1_inlined2 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 13010 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_attrs_ = _endpos__1_inlined2_ in
+        let lid =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 13022 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let cid =
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 13032 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _startpos_cid_ = _startpos__1_ in
+        let _1 = 
+# 3826 "src/ocaml/preprocess/parser_raw.mly"
+    ( () )
+# 13039 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let _endpos = _endpos_attrs_ in
+        let _symbolstartpos = _startpos_cid_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3367 "src/ocaml/preprocess/parser_raw.mly"
+      ( let info = symbol_info _endpos in
+        Te.rebind cid lid ~attrs ~loc:(make_loc _sloc) ~info )
+# 13048 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (Parsetree.payload) = Obj.magic _3 in
+        let _2 : (string Location.loc) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (Parsetree.attribute) = let _endpos = _endpos__4_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3996 "src/ocaml/preprocess/parser_raw.mly"
+    ( mark_symbol_docs _sloc;
+      Attr.mk ~loc:(make_loc _sloc) _2 _3 )
+# 13098 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = let params = 
+# 2148 "src/ocaml/preprocess/parser_raw.mly"
+      ( [] )
+# 13116 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 1965 "src/ocaml/preprocess/parser_raw.mly"
+    ( params )
+# 13121 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = xs;
+            MenhirLib.EngineTypes.startp = _startpos_xs_;
+            MenhirLib.EngineTypes.endp = _endpos_xs_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let xs : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic xs in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = let params =
+          let params =
+            let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 13162 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 1114 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 13167 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2150 "src/ocaml/preprocess/parser_raw.mly"
+      ( params )
+# 13173 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1965 "src/ocaml/preprocess/parser_raw.mly"
+    ( params )
+# 13179 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.expression) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.expression) = 
+# 2745 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 13204 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.expression) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.core_type option * Parsetree.core_type option) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.expression) = let _endpos = _endpos__3_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2747 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkexp_constraint ~loc:_sloc _3 _1 )
+# 13246 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.expression) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.expression) = 
+# 2772 "src/ocaml/preprocess/parser_raw.mly"
+      ( (merloc _endpos__1_ _2) )
+# 13278 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : (Parsetree.expression) = Obj.magic _4 in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (Parsetree.core_type) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 = 
+# 2774 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_constraint ((merloc _endpos__3_ _4), _2) )
+# 13325 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos__4_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 13334 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2775 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 13340 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.expression) = Obj.magic _2 in
+        let _1 : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.expression) = let _endpos = _endpos__2_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2778 "src/ocaml/preprocess/parser_raw.mly"
+      (
+       let (l,o,p) = _1 in
+       ghexp ~loc:_sloc (Pexp_fun(l, o, p, _2))
+      )
+# 13378 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = xs;
+              MenhirLib.EngineTypes.startp = _startpos_xs_;
+              MenhirLib.EngineTypes.endp = _endpos_xs_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : (Parsetree.expression) = Obj.magic _5 in
+        let _4 : unit = Obj.magic _4 in
+        let xs : (string Location.loc list) = Obj.magic xs in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.expression) = let _3 = 
+# 2639 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 13431 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let _endpos = _endpos__5_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2783 "src/ocaml/preprocess/parser_raw.mly"
+      ( mk_newtypes ~loc:_sloc _3 _5 )
+# 13439 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = ty;
+          MenhirLib.EngineTypes.startp = _startpos_ty_;
+          MenhirLib.EngineTypes.endp = _endpos_ty_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let ty : (Parsetree.core_type) = Obj.magic ty in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_ty_ in
+        let _endpos = _endpos_ty_ in
+        let _v : (Parsetree.core_type) = 
+# 3483 "src/ocaml/preprocess/parser_raw.mly"
+      ( ty )
+# 13464 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = codomain;
+          MenhirLib.EngineTypes.startp = _startpos_codomain_;
+          MenhirLib.EngineTypes.endp = _endpos_codomain_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = label;
+                MenhirLib.EngineTypes.startp = _startpos_label_;
+                MenhirLib.EngineTypes.endp = _endpos_label_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let codomain : (Parsetree.core_type) = Obj.magic codomain in
+        let _3 : unit = Obj.magic _3 in
+        let _1 : (Parsetree.core_type) = Obj.magic _1 in
+        let label : (string) = Obj.magic label in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_label_ in
+        let _endpos = _endpos_codomain_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 =
+            let domain = 
+# 978 "src/ocaml/preprocess/parser_raw.mly"
+                              ( extra_rhs_core_type _1 ~pos:_endpos__1_ )
+# 13512 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let label = 
+# 3495 "src/ocaml/preprocess/parser_raw.mly"
+      ( Optional label )
+# 13517 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 3489 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ptyp_arrow(label, domain, codomain) )
+# 13522 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 13532 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3491 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 13538 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = codomain;
+          MenhirLib.EngineTypes.startp = _startpos_codomain_;
+          MenhirLib.EngineTypes.endp = _endpos_codomain_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = label;
+                  MenhirLib.EngineTypes.startp = _startpos_label_;
+                  MenhirLib.EngineTypes.endp = _endpos_label_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let codomain : (Parsetree.core_type) = Obj.magic codomain in
+        let _3 : unit = Obj.magic _3 in
+        let _1 : (Parsetree.core_type) = Obj.magic _1 in
+        let _2 : unit = Obj.magic _2 in
+        let label : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 13587 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic label in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_label_ in
+        let _endpos = _endpos_codomain_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 =
+            let domain = 
+# 978 "src/ocaml/preprocess/parser_raw.mly"
+                              ( extra_rhs_core_type _1 ~pos:_endpos__1_ )
+# 13597 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let label = 
+# 3497 "src/ocaml/preprocess/parser_raw.mly"
+      ( Labelled label )
+# 13602 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 3489 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ptyp_arrow(label, domain, codomain) )
+# 13607 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 13617 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3491 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 13623 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = codomain;
+          MenhirLib.EngineTypes.startp = _startpos_codomain_;
+          MenhirLib.EngineTypes.endp = _endpos_codomain_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let codomain : (Parsetree.core_type) = Obj.magic codomain in
+        let _3 : unit = Obj.magic _3 in
+        let _1 : (Parsetree.core_type) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_codomain_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 =
+            let domain = 
+# 978 "src/ocaml/preprocess/parser_raw.mly"
+                              ( extra_rhs_core_type _1 ~pos:_endpos__1_ )
+# 13664 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let label = 
+# 3499 "src/ocaml/preprocess/parser_raw.mly"
+      ( Nolabel )
+# 13669 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 3489 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ptyp_arrow(label, domain, codomain) )
+# 13674 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos_codomain_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 13684 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3491 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 13690 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Lexing.position * Parsetree.functor_parameter) = let _startpos = _startpos__1_ in
+        
+# 1359 "src/ocaml/preprocess/parser_raw.mly"
+      ( _startpos, Unit )
+# 13723 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = mty;
+            MenhirLib.EngineTypes.startp = _startpos_mty_;
+            MenhirLib.EngineTypes.endp = _endpos_mty_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined1;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let mty : (Parsetree.module_type) = Obj.magic mty in
+        let _3 : unit = Obj.magic _3 in
+        let _1_inlined1 : (string option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Lexing.position * Parsetree.functor_parameter) = let x =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 13781 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _startpos = _startpos__1_ in
+        
+# 1362 "src/ocaml/preprocess/parser_raw.mly"
+      ( _startpos, Named (x, mty) )
+# 13788 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : ((Lexing.position * Parsetree.functor_parameter) list) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : ((Lexing.position * Parsetree.functor_parameter) list) = 
+# 1351 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 13813 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Parsetree.constructor_arguments * Parsetree.core_type option) = 
+# 3287 "src/ocaml/preprocess/parser_raw.mly"
+                                  ( (Pcstr_tuple [],None) )
+# 13831 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.constructor_arguments) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.constructor_arguments * Parsetree.core_type option) = 
+# 3288 "src/ocaml/preprocess/parser_raw.mly"
+                                  ( (_2,None) )
+# 13863 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : (Parsetree.core_type) = Obj.magic _4 in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (Parsetree.constructor_arguments) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (Parsetree.constructor_arguments * Parsetree.core_type option) = 
+# 3290 "src/ocaml/preprocess/parser_raw.mly"
+                                  ( (_2,Some _4) )
+# 13909 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.core_type) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.constructor_arguments * Parsetree.core_type option) = 
+# 3292 "src/ocaml/preprocess/parser_raw.mly"
+                                  ( (Pcstr_tuple [],Some _2) )
+# 13941 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined2;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = args_res;
+            MenhirLib.EngineTypes.startp = _startpos_args_res_;
+            MenhirLib.EngineTypes.endp = _endpos_args_res_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let args_res : (Parsetree.constructor_arguments * Parsetree.core_type option) = Obj.magic args_res in
+        let _1_inlined1 : (string) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined2_ in
+        let _v : (Ocaml_parsing.Ast_helper.str * Parsetree.constructor_arguments *
+  Parsetree.core_type option * Parsetree.attributes * Location.t *
+  Ocaml_parsing.Docstrings.info) = let attrs =
+          let _1 = _1_inlined2 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 13991 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_attrs_ = _endpos__1_inlined2_ in
+        let cid =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 14003 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_attrs_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3235 "src/ocaml/preprocess/parser_raw.mly"
+    (
+      let args, res = args_res in
+      let info = symbol_info _endpos in
+      let loc = make_loc _sloc in
+      cid, args, res, attrs, loc, info
+    )
+# 14017 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = args_res;
+            MenhirLib.EngineTypes.startp = _startpos_args_res_;
+            MenhirLib.EngineTypes.endp = _endpos_args_res_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let args_res : (Parsetree.constructor_arguments * Parsetree.core_type option) = Obj.magic args_res in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (Ocaml_parsing.Ast_helper.str * Parsetree.constructor_arguments *
+  Parsetree.core_type option * Parsetree.attributes * Location.t *
+  Ocaml_parsing.Docstrings.info) = let attrs =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 14060 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_attrs_ = _endpos__1_inlined1_ in
+        let cid =
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 14071 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _startpos_cid_ = _startpos__1_ in
+        let _1 = 
+# 3826 "src/ocaml/preprocess/parser_raw.mly"
+    ( () )
+# 14078 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let _endpos = _endpos_attrs_ in
+        let _symbolstartpos = _startpos_cid_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3235 "src/ocaml/preprocess/parser_raw.mly"
+    (
+      let args, res = args_res in
+      let info = symbol_info _endpos in
+      let loc = make_loc _sloc in
+      cid, args, res, attrs, loc, info
+    )
+# 14091 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined4;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined4_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = xs;
+            MenhirLib.EngineTypes.startp = _startpos_xs_;
+            MenhirLib.EngineTypes.endp = _endpos_xs_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined3;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined2;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = params;
+                    MenhirLib.EngineTypes.startp = _startpos_params_;
+                    MenhirLib.EngineTypes.endp = _endpos_params_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _1_inlined1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = ext;
+                        MenhirLib.EngineTypes.startp = _startpos_ext_;
+                        MenhirLib.EngineTypes.endp = _endpos_ext_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _menhir_s;
+                          MenhirLib.EngineTypes.semv = _1;
+                          MenhirLib.EngineTypes.startp = _startpos__1_;
+                          MenhirLib.EngineTypes.endp = _endpos__1_;
+                          MenhirLib.EngineTypes.next = _menhir_stack;
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined4 : (Parsetree.attributes) = Obj.magic _1_inlined4 in
+        let xs : ((Parsetree.core_type * Parsetree.core_type * Location.t) list) = Obj.magic xs in
+        let _2 : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = Obj.magic _2 in
+        let _1_inlined3 : unit = Obj.magic _1_inlined3 in
+        let _1_inlined2 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 14164 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined2 in
+        let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined4_ in
+        let _v : ((Asttypes.rec_flag * string Location.loc option) *
+  Parsetree.type_declaration) = let attrs2 =
+          let _1 = _1_inlined4 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 14179 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_attrs2_ = _endpos__1_inlined4_ in
+        let cstrs =
+          let _1 =
+            let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 14188 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 1064 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 14193 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 3138 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 14199 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let kind_priv_manifest =
+          let _1 = _1_inlined3 in
+          
+# 3173 "src/ocaml/preprocess/parser_raw.mly"
+      ( _2 )
+# 14207 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let id =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 14218 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let flag = 
+# 3846 "src/ocaml/preprocess/parser_raw.mly"
+                ( Recursive )
+# 14224 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let attrs1 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 14231 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_attrs2_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3110 "src/ocaml/preprocess/parser_raw.mly"
+    (
+      let (kind, priv, manifest) = kind_priv_manifest in
+      let docs = symbol_docs _sloc in
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc _sloc in
+      (flag, ext),
+      Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs
+    )
+# 14247 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined5;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined5_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = xs;
+            MenhirLib.EngineTypes.startp = _startpos_xs_;
+            MenhirLib.EngineTypes.endp = _endpos_xs_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined4;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined4_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined4_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined3;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = params;
+                    MenhirLib.EngineTypes.startp = _startpos_params_;
+                    MenhirLib.EngineTypes.endp = _endpos_params_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _1_inlined2;
+                      MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = _1_inlined1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _;
+                          MenhirLib.EngineTypes.semv = ext;
+                          MenhirLib.EngineTypes.startp = _startpos_ext_;
+                          MenhirLib.EngineTypes.endp = _endpos_ext_;
+                          MenhirLib.EngineTypes.next = {
+                            MenhirLib.EngineTypes.state = _menhir_s;
+                            MenhirLib.EngineTypes.semv = _1;
+                            MenhirLib.EngineTypes.startp = _startpos__1_;
+                            MenhirLib.EngineTypes.endp = _endpos__1_;
+                            MenhirLib.EngineTypes.next = _menhir_stack;
+                          };
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined5 : (Parsetree.attributes) = Obj.magic _1_inlined5 in
+        let xs : ((Parsetree.core_type * Parsetree.core_type * Location.t) list) = Obj.magic xs in
+        let _2 : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = Obj.magic _2 in
+        let _1_inlined4 : unit = Obj.magic _1_inlined4 in
+        let _1_inlined3 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 14326 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined3 in
+        let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in
+        let _1_inlined2 : unit = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined5_ in
+        let _v : ((Asttypes.rec_flag * string Location.loc option) *
+  Parsetree.type_declaration) = let attrs2 =
+          let _1 = _1_inlined5 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 14342 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_attrs2_ = _endpos__1_inlined5_ in
+        let cstrs =
+          let _1 =
+            let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 14351 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 1064 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 14356 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 3138 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 14362 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let kind_priv_manifest =
+          let _1 = _1_inlined4 in
+          
+# 3173 "src/ocaml/preprocess/parser_raw.mly"
+      ( _2 )
+# 14370 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let id =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 14381 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let flag =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let _endpos = _endpos__1_ in
+          let _startpos = _startpos__1_ in
+          let _loc = (_startpos, _endpos) in
+          
+# 3848 "src/ocaml/preprocess/parser_raw.mly"
+                ( not_expecting _loc "nonrec flag"; Recursive )
+# 14392 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let attrs1 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 14400 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_attrs2_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3110 "src/ocaml/preprocess/parser_raw.mly"
+    (
+      let (kind, priv, manifest) = kind_priv_manifest in
+      let docs = symbol_docs _sloc in
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc _sloc in
+      (flag, ext),
+      Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs
+    )
+# 14416 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined3;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = xs;
+            MenhirLib.EngineTypes.startp = _startpos_xs_;
+            MenhirLib.EngineTypes.endp = _endpos_xs_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = kind_priv_manifest;
+              MenhirLib.EngineTypes.startp = _startpos_kind_priv_manifest_;
+              MenhirLib.EngineTypes.endp = _endpos_kind_priv_manifest_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = params;
+                  MenhirLib.EngineTypes.startp = _startpos_params_;
+                  MenhirLib.EngineTypes.endp = _endpos_params_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1_inlined1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = ext;
+                      MenhirLib.EngineTypes.startp = _startpos_ext_;
+                      MenhirLib.EngineTypes.endp = _endpos_ext_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _menhir_s;
+                        MenhirLib.EngineTypes.semv = _1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_;
+                        MenhirLib.EngineTypes.next = _menhir_stack;
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let xs : ((Parsetree.core_type * Parsetree.core_type * Location.t) list) = Obj.magic xs in
+        let kind_priv_manifest : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = Obj.magic kind_priv_manifest in
+        let _1_inlined2 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 14482 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined2 in
+        let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined3_ in
+        let _v : ((Asttypes.rec_flag * string Location.loc option) *
+  Parsetree.type_declaration) = let attrs2 =
+          let _1 = _1_inlined3 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 14497 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_attrs2_ = _endpos__1_inlined3_ in
+        let cstrs =
+          let _1 =
+            let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 14506 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 1064 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 14511 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 3138 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 14517 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let id =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 14528 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let flag = 
+# 3842 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Recursive )
+# 14534 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let attrs1 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 14541 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_attrs2_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3110 "src/ocaml/preprocess/parser_raw.mly"
+    (
+      let (kind, priv, manifest) = kind_priv_manifest in
+      let docs = symbol_docs _sloc in
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc _sloc in
+      (flag, ext),
+      Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs
+    )
+# 14557 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined4;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined4_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = xs;
+            MenhirLib.EngineTypes.startp = _startpos_xs_;
+            MenhirLib.EngineTypes.endp = _endpos_xs_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = kind_priv_manifest;
+              MenhirLib.EngineTypes.startp = _startpos_kind_priv_manifest_;
+              MenhirLib.EngineTypes.endp = _endpos_kind_priv_manifest_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined3;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = params;
+                  MenhirLib.EngineTypes.startp = _startpos_params_;
+                  MenhirLib.EngineTypes.endp = _endpos_params_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1_inlined2;
+                    MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _1_inlined1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = ext;
+                        MenhirLib.EngineTypes.startp = _startpos_ext_;
+                        MenhirLib.EngineTypes.endp = _endpos_ext_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _menhir_s;
+                          MenhirLib.EngineTypes.semv = _1;
+                          MenhirLib.EngineTypes.startp = _startpos__1_;
+                          MenhirLib.EngineTypes.endp = _endpos__1_;
+                          MenhirLib.EngineTypes.next = _menhir_stack;
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined4 : (Parsetree.attributes) = Obj.magic _1_inlined4 in
+        let xs : ((Parsetree.core_type * Parsetree.core_type * Location.t) list) = Obj.magic xs in
+        let kind_priv_manifest : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = Obj.magic kind_priv_manifest in
+        let _1_inlined3 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 14629 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined3 in
+        let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in
+        let _1_inlined2 : unit = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined4_ in
+        let _v : ((Asttypes.rec_flag * string Location.loc option) *
+  Parsetree.type_declaration) = let attrs2 =
+          let _1 = _1_inlined4 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 14645 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_attrs2_ = _endpos__1_inlined4_ in
+        let cstrs =
+          let _1 =
+            let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 14654 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 1064 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 14659 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 3138 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 14665 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let id =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 14676 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let flag =
+          let _1 = _1_inlined2 in
+          
+# 3843 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Nonrecursive )
+# 14684 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let attrs1 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 14692 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_attrs2_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3110 "src/ocaml/preprocess/parser_raw.mly"
+    (
+      let (kind, priv, manifest) = kind_priv_manifest in
+      let docs = symbol_docs _sloc in
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc _sloc in
+      (flag, ext),
+      Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs
+    )
+# 14708 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 839 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 14729 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3683 "src/ocaml/preprocess/parser_raw.mly"
+                              ( _1 )
+# 14737 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 14758 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3684 "src/ocaml/preprocess/parser_raw.mly"
+                              ( _1 )
+# 14766 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.structure) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.structure) = 
+# 1235 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 14798 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (string) = 
+# 3735 "src/ocaml/preprocess/parser_raw.mly"
+  ( "" )
+# 14816 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (string) = 
+# 3736 "src/ocaml/preprocess/parser_raw.mly"
+              ( ";.." )
+# 14848 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.signature) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.signature) = 
+# 1242 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 14880 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (Parsetree.payload) = Obj.magic _3 in
+        let _2 : (string Location.loc) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (Parsetree.extension) = 
+# 4026 "src/ocaml/preprocess/parser_raw.mly"
+                                                    ( (_2, _3) )
+# 14926 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 830 "src/ocaml/preprocess/parser_raw.mly"
+  (string * Location.t * string * Location.t * string option)
+# 14947 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.extension) = let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 4028 "src/ocaml/preprocess/parser_raw.mly"
+    ( mk_quotedext ~loc:_sloc _1 )
+# 14958 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined3;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined2;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined1;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in
+        let _3 : unit = Obj.magic _3 in
+        let _1_inlined1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 15006 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined1 in
+        let _1 : (Asttypes.mutable_flag) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined3_ in
+        let _v : (Parsetree.label_declaration) = let _5 =
+          let _1 = _1_inlined3 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 15017 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__5_ = _endpos__1_inlined3_ in
+        let _4 =
+          let _1 = _1_inlined2 in
+          
+# 3436 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 15026 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _2 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _1 = 
+# 3661 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 15034 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 15042 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _startpos__2_ = _startpos__1_inlined1_ in
+        let _endpos = _endpos__5_ in
+        let _symbolstartpos = if _startpos__1_ != _endpos__1_ then
+          _startpos__1_
+        else
+          _startpos__2_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3309 "src/ocaml/preprocess/parser_raw.mly"
+      ( let info = symbol_info _endpos in
+        Type.field _2 _4 ~mut:_1 ~attrs:_5 ~loc:(make_loc _sloc) ~info )
+# 15056 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined4;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined4_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _6;
+            MenhirLib.EngineTypes.startp = _startpos__6_;
+            MenhirLib.EngineTypes.endp = _endpos__6_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined3;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _3;
+                  MenhirLib.EngineTypes.startp = _startpos__3_;
+                  MenhirLib.EngineTypes.endp = _endpos__3_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1_inlined1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = _1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined4 : (Parsetree.attributes) = Obj.magic _1_inlined4 in
+        let _6 : unit = Obj.magic _6 in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in
+        let _3 : unit = Obj.magic _3 in
+        let _1_inlined1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 15118 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined1 in
+        let _1 : (Asttypes.mutable_flag) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined4_ in
+        let _v : (Parsetree.label_declaration) = let _7 =
+          let _1 = _1_inlined4 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 15129 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__7_ = _endpos__1_inlined4_ in
+        let _5 =
+          let _1 = _1_inlined3 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 15138 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__5_ = _endpos__1_inlined3_ in
+        let _4 =
+          let _1 = _1_inlined2 in
+          
+# 3436 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 15147 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _2 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _1 = 
+# 3661 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 15155 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 15163 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _startpos__2_ = _startpos__1_inlined1_ in
+        let _endpos = _endpos__7_ in
+        let _symbolstartpos = if _startpos__1_ != _endpos__1_ then
+          _startpos__1_
+        else
+          _startpos__2_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3314 "src/ocaml/preprocess/parser_raw.mly"
+      ( let info =
+          match rhs_info _endpos__5_ with
+          | Some _ as info_before_semi -> info_before_semi
+          | None -> symbol_info _endpos
+       in
+       Type.field _2 _4 ~mut:_1 ~attrs:(_5 @ _7) ~loc:(make_loc _sloc) ~info )
+# 15181 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.label_declaration) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.label_declaration list) = 
+# 3303 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( [_1] )
+# 15206 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.label_declaration) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.label_declaration list) = 
+# 3304 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( [_1] )
+# 15231 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.label_declaration list) = Obj.magic _2 in
+        let _1 : (Parsetree.label_declaration) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.label_declaration list) = 
+# 3305 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 :: _2 )
+# 15263 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 15284 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string * Parsetree.pattern) = let x =
+          let _1 =
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 15297 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 2343 "src/ocaml/preprocess/parser_raw.mly"
+      ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) )
+# 15306 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2335 "src/ocaml/preprocess/parser_raw.mly"
+      ( x )
+# 15312 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = cty;
+          MenhirLib.EngineTypes.startp = _startpos_cty_;
+          MenhirLib.EngineTypes.endp = _endpos_cty_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let cty : (Parsetree.core_type) = Obj.magic cty in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 15347 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_cty_ in
+        let _v : (string * Parsetree.pattern) = let x =
+          let _1 =
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 15360 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 2343 "src/ocaml/preprocess/parser_raw.mly"
+      ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) )
+# 15369 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _startpos_x_ = _startpos__1_ in
+        let _endpos = _endpos_cty_ in
+        let _symbolstartpos = _startpos_x_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2337 "src/ocaml/preprocess/parser_raw.mly"
+      ( let lab, pat = x in
+        lab,
+        mkpat ~loc:_sloc (Ppat_constraint (pat, cty)) )
+# 15381 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Longident.t) = 
+# 3766 "src/ocaml/preprocess/parser_raw.mly"
+                                        ( _1 )
+# 15406 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.expression) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Asttypes.arg_label * Parsetree.expression) = 
+# 2625 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Nolabel, _1) )
+# 15431 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.expression) = Obj.magic _2 in
+        let _1 : (
+# 774 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 15459 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Asttypes.arg_label * Parsetree.expression) = 
+# 2627 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Labelled _1, _2) )
+# 15467 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = label;
+          MenhirLib.EngineTypes.startp = _startpos_label_;
+          MenhirLib.EngineTypes.endp = _endpos_label_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let label : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 15494 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic label in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_label_ in
+        let _v : (Asttypes.arg_label * Parsetree.expression) = let _loc_label_ = (_startpos_label_, _endpos_label_) in
+        
+# 2629 "src/ocaml/preprocess/parser_raw.mly"
+      ( let loc = _loc_label_ in
+        (Labelled label, mkexpvar ~loc label) )
+# 15505 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = label;
+          MenhirLib.EngineTypes.startp = _startpos_label_;
+          MenhirLib.EngineTypes.endp = _endpos_label_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let label : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 15532 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic label in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_label_ in
+        let _v : (Asttypes.arg_label * Parsetree.expression) = let _loc_label_ = (_startpos_label_, _endpos_label_) in
+        
+# 2632 "src/ocaml/preprocess/parser_raw.mly"
+      ( let loc = _loc_label_ in
+        (Optional label, mkexpvar ~loc label) )
+# 15543 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.expression) = Obj.magic _2 in
+        let _1 : (
+# 804 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 15571 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Asttypes.arg_label * Parsetree.expression) = 
+# 2635 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Optional _1, _2) )
+# 15579 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let _1_inlined1 : (Parsetree.expression option) = Obj.magic _1_inlined1 in
+        let _3 : (string * Parsetree.pattern) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = let _4 =
+          let _1 = _1_inlined1 in
+          
+# 2331 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 15634 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2305 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Optional (fst _3), _4, snd _3) )
+# 15640 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 15667 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = let _2 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _1 =
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 15682 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 2343 "src/ocaml/preprocess/parser_raw.mly"
+      ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) )
+# 15691 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2307 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Optional (fst _2), None, snd _2) )
+# 15697 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let _1_inlined1 : (Parsetree.expression option) = Obj.magic _1_inlined1 in
+        let _3 : (Parsetree.pattern) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (
+# 804 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 15746 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = let _4 =
+          let _1 = _1_inlined1 in
+          
+# 2331 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 15756 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2309 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Optional _1, _4, _3) )
+# 15762 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.pattern) = Obj.magic _2 in
+        let _1 : (
+# 804 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 15790 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = 
+# 2311 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Optional _1, None, _2) )
+# 15798 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (string * Parsetree.pattern) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = 
+# 2313 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Labelled (fst _3), None, snd _3) )
+# 15844 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 15871 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = let _2 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _1 =
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 15886 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 2343 "src/ocaml/preprocess/parser_raw.mly"
+      ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) )
+# 15895 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2315 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Labelled (fst _2), None, snd _2) )
+# 15901 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.pattern) = Obj.magic _2 in
+        let _1 : (
+# 774 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 15929 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = 
+# 2317 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Labelled _1, None, _2) )
+# 15937 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = 
+# 2319 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Nolabel, None, _1) )
+# 15962 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.pattern * Parsetree.expression) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.pattern * Parsetree.expression * bool) = 
+# 2682 "src/ocaml/preprocess/parser_raw.mly"
+      ( let p,e = _1 in (p,e,false) )
+# 15987 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.pattern * Parsetree.expression * bool) = let _endpos = _endpos__1_ in
+        let _startpos = _startpos__1_ in
+        let _loc = (_startpos, _endpos) in
+        
+# 2685 "src/ocaml/preprocess/parser_raw.mly"
+      ( (mkpatvar ~loc:_loc _1, mkexpvar ~loc:_loc _1, true) )
+# 16015 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.expression) = Obj.magic _2 in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.pattern * Parsetree.expression) = let _1 =
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 2642 "src/ocaml/preprocess/parser_raw.mly"
+              ( mkpatvar ~loc:_sloc _1 )
+# 16051 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2646 "src/ocaml/preprocess/parser_raw.mly"
+      ( (_1, _2) )
+# 16057 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : (Parsetree.expression) = Obj.magic _4 in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (Parsetree.core_type option * Parsetree.core_type option) = Obj.magic _2 in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (Parsetree.pattern * Parsetree.expression) = let _1 =
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 2642 "src/ocaml/preprocess/parser_raw.mly"
+              ( mkpatvar ~loc:_sloc _1 )
+# 16107 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__4_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2648 "src/ocaml/preprocess/parser_raw.mly"
+      ( let v = _1 in (* PR#7344 *)
+        let t =
+          match _2 with
+            Some t, None -> t
+          | _, Some t -> t
+          | _ -> assert false
+        in
+        let loc = Location.(t.ptyp_loc.loc_start, t.ptyp_loc.loc_end) in
+        let typ = ghtyp ~loc (Ptyp_poly([],t)) in
+        let patloc = (_startpos__1_, _endpos__2_) in
+        (ghpat ~loc:patloc (Ppat_constraint(v, typ)),
+         mkexp_constraint ~loc:_sloc _4 _2) )
+# 16127 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _7;
+          MenhirLib.EngineTypes.startp = _startpos__7_;
+          MenhirLib.EngineTypes.endp = _endpos__7_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _6;
+            MenhirLib.EngineTypes.startp = _startpos__6_;
+            MenhirLib.EngineTypes.endp = _endpos__6_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _5;
+              MenhirLib.EngineTypes.startp = _startpos__5_;
+              MenhirLib.EngineTypes.endp = _endpos__5_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _4;
+                MenhirLib.EngineTypes.startp = _startpos__4_;
+                MenhirLib.EngineTypes.endp = _endpos__4_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = xs;
+                  MenhirLib.EngineTypes.startp = _startpos_xs_;
+                  MenhirLib.EngineTypes.endp = _endpos_xs_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _2;
+                    MenhirLib.EngineTypes.startp = _startpos__2_;
+                    MenhirLib.EngineTypes.endp = _endpos__2_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = _1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _7 : (Parsetree.expression) = Obj.magic _7 in
+        let _6 : unit = Obj.magic _6 in
+        let _5 : (Parsetree.core_type) = Obj.magic _5 in
+        let _4 : unit = Obj.magic _4 in
+        let xs : (string Location.loc list) = Obj.magic xs in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__7_ in
+        let _v : (Parsetree.pattern * Parsetree.expression) = let _3 =
+          let _1 =
+            let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 16196 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 1082 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 16201 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 3418 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 16207 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _startpos__3_ = _startpos_xs_ in
+        let _1 =
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 2642 "src/ocaml/preprocess/parser_raw.mly"
+              ( mkpatvar ~loc:_sloc _1 )
+# 16218 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2664 "src/ocaml/preprocess/parser_raw.mly"
+      ( let typloc = (_startpos__3_, _endpos__5_) in
+        let patloc = (_startpos__1_, _endpos__5_) in
+        (ghpat ~loc:patloc
+           (Ppat_constraint(_1, ghtyp ~loc:typloc (Ptyp_poly(_3,_5)))),
+         _7) )
+# 16228 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _8;
+          MenhirLib.EngineTypes.startp = _startpos__8_;
+          MenhirLib.EngineTypes.endp = _endpos__8_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _7;
+            MenhirLib.EngineTypes.startp = _startpos__7_;
+            MenhirLib.EngineTypes.endp = _endpos__7_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _6;
+              MenhirLib.EngineTypes.startp = _startpos__6_;
+              MenhirLib.EngineTypes.endp = _endpos__6_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _5;
+                MenhirLib.EngineTypes.startp = _startpos__5_;
+                MenhirLib.EngineTypes.endp = _endpos__5_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = xs;
+                  MenhirLib.EngineTypes.startp = _startpos_xs_;
+                  MenhirLib.EngineTypes.endp = _endpos_xs_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _3;
+                    MenhirLib.EngineTypes.startp = _startpos__3_;
+                    MenhirLib.EngineTypes.endp = _endpos__3_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _2;
+                      MenhirLib.EngineTypes.startp = _startpos__2_;
+                      MenhirLib.EngineTypes.endp = _endpos__2_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _menhir_s;
+                        MenhirLib.EngineTypes.semv = _1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_;
+                        MenhirLib.EngineTypes.next = _menhir_stack;
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _8 : (Parsetree.expression) = Obj.magic _8 in
+        let _7 : unit = Obj.magic _7 in
+        let _6 : (Parsetree.core_type) = Obj.magic _6 in
+        let _5 : unit = Obj.magic _5 in
+        let xs : (string Location.loc list) = Obj.magic xs in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__8_ in
+        let _v : (Parsetree.pattern * Parsetree.expression) = let _4 = 
+# 2639 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 16302 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let _1 =
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 2642 "src/ocaml/preprocess/parser_raw.mly"
+              ( mkpatvar ~loc:_sloc _1 )
+# 16311 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__8_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2670 "src/ocaml/preprocess/parser_raw.mly"
+      ( let exp, poly =
+          wrap_type_annotation ~loc:_sloc _4 _6 _8 in
+        let loc = (_startpos__1_, _endpos__6_) in
+        (ghpat ~loc (Ppat_constraint(_1, poly)), exp) )
+# 16323 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.expression) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.pattern * Parsetree.expression) = 
+# 2675 "src/ocaml/preprocess/parser_raw.mly"
+      ( (_1, _3) )
+# 16362 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : (Parsetree.expression) = Obj.magic _5 in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (Parsetree.core_type) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.pattern * Parsetree.expression) = 
+# 2677 "src/ocaml/preprocess/parser_raw.mly"
+      ( let loc = (_startpos__1_, _endpos__3_) in
+        (ghpat ~loc (Ppat_constraint(_1, _3)), _5) )
+# 16416 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined2;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = body;
+            MenhirLib.EngineTypes.startp = _startpos_body_;
+            MenhirLib.EngineTypes.endp = _endpos_body_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = rec_flag;
+              MenhirLib.EngineTypes.startp = _startpos_rec_flag_;
+              MenhirLib.EngineTypes.endp = _endpos_rec_flag_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined1;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = ext;
+                  MenhirLib.EngineTypes.startp = _startpos_ext_;
+                  MenhirLib.EngineTypes.endp = _endpos_ext_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let body : (Parsetree.pattern * Parsetree.expression * bool) = Obj.magic body in
+        let rec_flag : (Asttypes.rec_flag) = Obj.magic rec_flag in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined2_ in
+        let _v : (Ast_helper.let_bindings) = let _1 =
+          let attrs2 =
+            let _1 = _1_inlined2 in
+            
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 16479 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos_attrs2_ = _endpos__1_inlined2_ in
+          let attrs1 =
+            let _1 = _1_inlined1 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 16488 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos_attrs2_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 2705 "src/ocaml/preprocess/parser_raw.mly"
+    (
+      let attrs = attrs1 @ attrs2 in
+      mklbs ext rec_flag (mklb ~loc:_sloc true body attrs)
+    )
+# 16500 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2695 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 16506 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Ast_helper.let_binding) = Obj.magic _2 in
+        let _1 : (Ast_helper.let_bindings) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Ast_helper.let_bindings) = 
+# 2696 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( addlb _1 _2 )
+# 16538 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined2;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = body;
+            MenhirLib.EngineTypes.startp = _startpos_body_;
+            MenhirLib.EngineTypes.endp = _endpos_body_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = rec_flag;
+              MenhirLib.EngineTypes.startp = _startpos_rec_flag_;
+              MenhirLib.EngineTypes.endp = _endpos_rec_flag_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined1;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let body : (Parsetree.pattern * Parsetree.expression * bool) = Obj.magic body in
+        let rec_flag : (Asttypes.rec_flag) = Obj.magic rec_flag in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined2_ in
+        let _v : (Ast_helper.let_bindings) = let _1 =
+          let attrs2 =
+            let _1 = _1_inlined2 in
+            
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 16594 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos_attrs2_ = _endpos__1_inlined2_ in
+          let attrs1 =
+            let _1 = _1_inlined1 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 16603 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let ext = 
+# 4012 "src/ocaml/preprocess/parser_raw.mly"
+                    ( None )
+# 16609 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos_attrs2_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 2705 "src/ocaml/preprocess/parser_raw.mly"
+    (
+      let attrs = attrs1 @ attrs2 in
+      mklbs ext rec_flag (mklb ~loc:_sloc true body attrs)
+    )
+# 16620 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2695 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 16626 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined3;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = body;
+            MenhirLib.EngineTypes.startp = _startpos_body_;
+            MenhirLib.EngineTypes.endp = _endpos_body_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = rec_flag;
+              MenhirLib.EngineTypes.startp = _startpos_rec_flag_;
+              MenhirLib.EngineTypes.endp = _endpos_rec_flag_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _2;
+                  MenhirLib.EngineTypes.startp = _startpos__2_;
+                  MenhirLib.EngineTypes.endp = _endpos__2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1_inlined1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = _1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let body : (Parsetree.pattern * Parsetree.expression * bool) = Obj.magic body in
+        let rec_flag : (Asttypes.rec_flag) = Obj.magic rec_flag in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _2 : (string Location.loc) = Obj.magic _2 in
+        let _1_inlined1 : unit = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined3_ in
+        let _v : (Ast_helper.let_bindings) = let _1 =
+          let attrs2 =
+            let _1 = _1_inlined3 in
+            
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 16696 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos_attrs2_ = _endpos__1_inlined3_ in
+          let attrs1 =
+            let _1 = _1_inlined2 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 16705 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let ext =
+            let (_startpos__1_, _1) = (_startpos__1_inlined1_, _1_inlined1) in
+            let _endpos = _endpos__2_ in
+            let _startpos = _startpos__1_ in
+            let _loc = (_startpos, _endpos) in
+            
+# 4014 "src/ocaml/preprocess/parser_raw.mly"
+                    ( not_expecting _loc "extension"; None )
+# 16716 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos_attrs2_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 2705 "src/ocaml/preprocess/parser_raw.mly"
+    (
+      let attrs = attrs1 @ attrs2 in
+      mklbs ext rec_flag (mklb ~loc:_sloc true body attrs)
+    )
+# 16728 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2695 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 16734 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Ast_helper.let_binding) = Obj.magic _2 in
+        let _1 : (Ast_helper.let_bindings) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Ast_helper.let_bindings) = 
+# 2696 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( addlb _1 _2 )
+# 16766 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.pattern) = 
+# 2347 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 16791 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.core_type) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 = 
+# 2349 "src/ocaml/preprocess/parser_raw.mly"
+      ( Ppat_constraint(_1, _3) )
+# 16831 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos__3_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 16840 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2350 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 16846 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = exp;
+          MenhirLib.EngineTypes.startp = _startpos_exp_;
+          MenhirLib.EngineTypes.endp = _endpos_exp_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let exp : (Parsetree.expression) = Obj.magic exp in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_exp_ in
+        let _v : (Parsetree.pattern * Parsetree.expression) = let pat =
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 2642 "src/ocaml/preprocess/parser_raw.mly"
+              ( mkpatvar ~loc:_sloc _1 )
+# 16882 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2722 "src/ocaml/preprocess/parser_raw.mly"
+      ( (pat, exp) )
+# 16888 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.pattern * Parsetree.expression) = let _endpos = _endpos__1_ in
+        let _startpos = _startpos__1_ in
+        let _loc = (_startpos, _endpos) in
+        
+# 2725 "src/ocaml/preprocess/parser_raw.mly"
+      ( (mkpatvar ~loc:_loc _1, mkexpvar ~loc:_loc _1) )
+# 16916 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = exp;
+          MenhirLib.EngineTypes.startp = _startpos_exp_;
+          MenhirLib.EngineTypes.endp = _endpos_exp_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = typ;
+              MenhirLib.EngineTypes.startp = _startpos_typ_;
+              MenhirLib.EngineTypes.endp = _endpos_typ_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = pat;
+                  MenhirLib.EngineTypes.startp = _startpos_pat_;
+                  MenhirLib.EngineTypes.endp = _endpos_pat_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let exp : (Parsetree.expression) = Obj.magic exp in
+        let _4 : unit = Obj.magic _4 in
+        let typ : (Parsetree.core_type) = Obj.magic typ in
+        let _2 : unit = Obj.magic _2 in
+        let pat : (Parsetree.pattern) = Obj.magic pat in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_pat_ in
+        let _endpos = _endpos_exp_ in
+        let _v : (Parsetree.pattern * Parsetree.expression) = 
+# 2727 "src/ocaml/preprocess/parser_raw.mly"
+      ( let loc = (_startpos_pat_, _endpos_typ_) in
+        (ghpat ~loc (Ppat_constraint(pat, typ)), exp) )
+# 16970 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = exp;
+          MenhirLib.EngineTypes.startp = _startpos_exp_;
+          MenhirLib.EngineTypes.endp = _endpos_exp_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = pat;
+              MenhirLib.EngineTypes.startp = _startpos_pat_;
+              MenhirLib.EngineTypes.endp = _endpos_pat_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let exp : (Parsetree.expression) = Obj.magic exp in
+        let _2 : unit = Obj.magic _2 in
+        let pat : (Parsetree.pattern) = Obj.magic pat in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_pat_ in
+        let _endpos = _endpos_exp_ in
+        let _v : (Parsetree.pattern * Parsetree.expression) = 
+# 2730 "src/ocaml/preprocess/parser_raw.mly"
+      ( (pat, exp) )
+# 17009 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = body;
+          MenhirLib.EngineTypes.startp = _startpos_body_;
+          MenhirLib.EngineTypes.endp = _endpos_body_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let body : (Parsetree.pattern * Parsetree.expression) = Obj.magic body in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_body_ in
+        let _endpos = _endpos_body_ in
+        let _v : (Parsetree.pattern * Parsetree.expression * Parsetree.binding_op list) = 
+# 2734 "src/ocaml/preprocess/parser_raw.mly"
+      ( let let_pat, let_exp = body in
+        let_pat, let_exp, [] )
+# 17035 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = body;
+          MenhirLib.EngineTypes.startp = _startpos_body_;
+          MenhirLib.EngineTypes.endp = _endpos_body_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = bindings;
+              MenhirLib.EngineTypes.startp = _startpos_bindings_;
+              MenhirLib.EngineTypes.endp = _endpos_bindings_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let body : (Parsetree.pattern * Parsetree.expression) = Obj.magic body in
+        let _1 : (
+# 770 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 17069 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let bindings : (Parsetree.pattern * Parsetree.expression * Parsetree.binding_op list) = Obj.magic bindings in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_bindings_ in
+        let _endpos = _endpos_body_ in
+        let _v : (Parsetree.pattern * Parsetree.expression * Parsetree.binding_op list) = let pbop_op =
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 17082 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_body_ in
+        let _symbolstartpos = _startpos_bindings_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2737 "src/ocaml/preprocess/parser_raw.mly"
+      ( let let_pat, let_exp, rev_ands = bindings in
+        let pbop_pat, pbop_exp = body in
+        let pbop_loc = make_loc _sloc in
+        let and_ = {pbop_op; pbop_pat; pbop_exp; pbop_loc} in
+        let_pat, let_exp, and_ :: rev_ands )
+# 17095 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Parsetree.class_expr Parsetree.class_infos list) = 
+# 211 "<standard.mly>"
+    ( [] )
+# 17113 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined3;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = body;
+              MenhirLib.EngineTypes.startp = _startpos_body_;
+              MenhirLib.EngineTypes.endp = _endpos_body_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = params;
+                  MenhirLib.EngineTypes.startp = _startpos_params_;
+                  MenhirLib.EngineTypes.endp = _endpos_params_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = virt;
+                    MenhirLib.EngineTypes.startp = _startpos_virt_;
+                    MenhirLib.EngineTypes.endp = _endpos_virt_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _1_inlined1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _menhir_s;
+                        MenhirLib.EngineTypes.semv = _1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_;
+                        MenhirLib.EngineTypes.next = _menhir_stack;
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.class_expr Parsetree.class_infos list) = Obj.magic xs in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let body : (Parsetree.class_expr) = Obj.magic body in
+        let _1_inlined2 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 17179 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined2 in
+        let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in
+        let virt : (Asttypes.virtual_flag) = Obj.magic virt in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.class_expr Parsetree.class_infos list) = let x =
+          let attrs2 =
+            let _1 = _1_inlined3 in
+            
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 17194 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos_attrs2_ = _endpos__1_inlined3_ in
+          let id =
+            let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 17206 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let attrs1 =
+            let _1 = _1_inlined1 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 17214 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos_attrs2_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1943 "src/ocaml/preprocess/parser_raw.mly"
+  (
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc _sloc in
+    let docs = symbol_docs _sloc in
+    let text = symbol_text _symbolstartpos in
+    Ci.mk id body ~virt ~params ~attrs ~loc ~text ~docs
+  )
+# 17229 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 213 "<standard.mly>"
+    ( x :: xs )
+# 17235 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Parsetree.class_type Parsetree.class_infos list) = 
+# 211 "<standard.mly>"
+    ( [] )
+# 17253 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined3;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = cty;
+              MenhirLib.EngineTypes.startp = _startpos_cty_;
+              MenhirLib.EngineTypes.endp = _endpos_cty_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _6;
+                MenhirLib.EngineTypes.startp = _startpos__6_;
+                MenhirLib.EngineTypes.endp = _endpos__6_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined2;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = params;
+                    MenhirLib.EngineTypes.startp = _startpos_params_;
+                    MenhirLib.EngineTypes.endp = _endpos_params_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = virt;
+                      MenhirLib.EngineTypes.startp = _startpos_virt_;
+                      MenhirLib.EngineTypes.endp = _endpos_virt_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = _1_inlined1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _menhir_s;
+                          MenhirLib.EngineTypes.semv = _1;
+                          MenhirLib.EngineTypes.startp = _startpos__1_;
+                          MenhirLib.EngineTypes.endp = _endpos__1_;
+                          MenhirLib.EngineTypes.next = _menhir_stack;
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.class_type Parsetree.class_infos list) = Obj.magic xs in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let cty : (Parsetree.class_type) = Obj.magic cty in
+        let _6 : unit = Obj.magic _6 in
+        let _1_inlined2 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 17326 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined2 in
+        let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in
+        let virt : (Asttypes.virtual_flag) = Obj.magic virt in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.class_type Parsetree.class_infos list) = let x =
+          let attrs2 =
+            let _1 = _1_inlined3 in
+            
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 17341 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos_attrs2_ = _endpos__1_inlined3_ in
+          let id =
+            let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 17353 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let attrs1 =
+            let _1 = _1_inlined1 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 17361 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos_attrs2_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 2242 "src/ocaml/preprocess/parser_raw.mly"
+    (
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc _sloc in
+      let docs = symbol_docs _sloc in
+      let text = symbol_text _symbolstartpos in
+      Ci.mk id cty ~virt ~params ~attrs ~loc ~text ~docs
+    )
+# 17376 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 213 "<standard.mly>"
+    ( x :: xs )
+# 17382 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Parsetree.class_type Parsetree.class_infos list) = 
+# 211 "<standard.mly>"
+    ( [] )
+# 17400 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined3;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = csig;
+              MenhirLib.EngineTypes.startp = _startpos_csig_;
+              MenhirLib.EngineTypes.endp = _endpos_csig_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _6;
+                MenhirLib.EngineTypes.startp = _startpos__6_;
+                MenhirLib.EngineTypes.endp = _endpos__6_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined2;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = params;
+                    MenhirLib.EngineTypes.startp = _startpos_params_;
+                    MenhirLib.EngineTypes.endp = _endpos_params_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = virt;
+                      MenhirLib.EngineTypes.startp = _startpos_virt_;
+                      MenhirLib.EngineTypes.endp = _endpos_virt_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = _1_inlined1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _menhir_s;
+                          MenhirLib.EngineTypes.semv = _1;
+                          MenhirLib.EngineTypes.startp = _startpos__1_;
+                          MenhirLib.EngineTypes.endp = _endpos__1_;
+                          MenhirLib.EngineTypes.next = _menhir_stack;
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.class_type Parsetree.class_infos list) = Obj.magic xs in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let csig : (Parsetree.class_type) = Obj.magic csig in
+        let _6 : unit = Obj.magic _6 in
+        let _1_inlined2 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 17473 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined2 in
+        let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in
+        let virt : (Asttypes.virtual_flag) = Obj.magic virt in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.class_type Parsetree.class_infos list) = let x =
+          let attrs2 =
+            let _1 = _1_inlined3 in
+            
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 17488 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos_attrs2_ = _endpos__1_inlined3_ in
+          let id =
+            let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 17500 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let attrs1 =
+            let _1 = _1_inlined1 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 17508 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos_attrs2_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 2281 "src/ocaml/preprocess/parser_raw.mly"
+    (
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc _sloc in
+      let docs = symbol_docs _sloc in
+      let text = symbol_text _symbolstartpos in
+      Ci.mk id csig ~virt ~params ~attrs ~loc ~text ~docs
+    )
+# 17523 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 213 "<standard.mly>"
+    ( x :: xs )
+# 17529 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Parsetree.module_binding list) = 
+# 211 "<standard.mly>"
+    ( [] )
+# 17547 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined3;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = body;
+              MenhirLib.EngineTypes.startp = _startpos_body_;
+              MenhirLib.EngineTypes.endp = _endpos_body_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.module_binding list) = Obj.magic xs in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let body : (Parsetree.module_expr) = Obj.magic body in
+        let _1_inlined2 : (string option) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.module_binding list) = let x =
+          let attrs2 =
+            let _1 = _1_inlined3 in
+            
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 17610 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos_attrs2_ = _endpos__1_inlined3_ in
+          let name =
+            let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 17622 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let attrs1 =
+            let _1 = _1_inlined1 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 17630 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos_attrs2_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1599 "src/ocaml/preprocess/parser_raw.mly"
+  (
+    let loc = make_loc _sloc in
+    let attrs = attrs1 @ attrs2 in
+    let docs = symbol_docs _sloc in
+    let text = symbol_text _symbolstartpos in
+    Mb.mk name body ~attrs ~loc ~text ~docs
+  )
+# 17645 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 213 "<standard.mly>"
+    ( x :: xs )
+# 17651 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Parsetree.module_declaration list) = 
+# 211 "<standard.mly>"
+    ( [] )
+# 17669 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined3;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = mty;
+              MenhirLib.EngineTypes.startp = _startpos_mty_;
+              MenhirLib.EngineTypes.endp = _endpos_mty_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _4;
+                MenhirLib.EngineTypes.startp = _startpos__4_;
+                MenhirLib.EngineTypes.endp = _endpos__4_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined2;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1_inlined1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = _1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.module_declaration list) = Obj.magic xs in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let mty : (Parsetree.module_type) = Obj.magic mty in
+        let _4 : unit = Obj.magic _4 in
+        let _1_inlined2 : (string option) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.module_declaration list) = let x =
+          let attrs2 =
+            let _1 = _1_inlined3 in
+            
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 17739 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos_attrs2_ = _endpos__1_inlined3_ in
+          let name =
+            let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 17751 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let attrs1 =
+            let _1 = _1_inlined1 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 17759 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos_attrs2_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1884 "src/ocaml/preprocess/parser_raw.mly"
+  (
+    let attrs = attrs1 @ attrs2 in
+    let docs = symbol_docs _sloc in
+    let loc = make_loc _sloc in
+    let text = symbol_text _symbolstartpos in
+    Md.mk name mty ~attrs ~loc ~text ~docs
+  )
+# 17774 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 213 "<standard.mly>"
+    ( x :: xs )
+# 17780 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Parsetree.attributes) = 
+# 211 "<standard.mly>"
+    ( [] )
+# 17798 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = x;
+            MenhirLib.EngineTypes.startp = _startpos_x_;
+            MenhirLib.EngineTypes.endp = _endpos_x_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.attributes) = Obj.magic xs in
+        let x : (Parsetree.attribute) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.attributes) = 
+# 213 "<standard.mly>"
+    ( x :: xs )
+# 17830 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Parsetree.type_declaration list) = 
+# 211 "<standard.mly>"
+    ( [] )
+# 17848 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined3;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = xs_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos_xs_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos_xs_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = kind_priv_manifest;
+                MenhirLib.EngineTypes.startp = _startpos_kind_priv_manifest_;
+                MenhirLib.EngineTypes.endp = _endpos_kind_priv_manifest_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined2;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = params;
+                    MenhirLib.EngineTypes.startp = _startpos_params_;
+                    MenhirLib.EngineTypes.endp = _endpos_params_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _1_inlined1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _menhir_s;
+                        MenhirLib.EngineTypes.semv = _1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_;
+                        MenhirLib.EngineTypes.next = _menhir_stack;
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.type_declaration list) = Obj.magic xs in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let xs_inlined1 : ((Parsetree.core_type * Parsetree.core_type * Location.t) list) = Obj.magic xs_inlined1 in
+        let kind_priv_manifest : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = Obj.magic kind_priv_manifest in
+        let _1_inlined2 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 17915 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined2 in
+        let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.type_declaration list) = let x =
+          let xs = xs_inlined1 in
+          let attrs2 =
+            let _1 = _1_inlined3 in
+            
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 17930 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos_attrs2_ = _endpos__1_inlined3_ in
+          let cstrs =
+            let _1 =
+              let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 17939 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              
+# 1064 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 17944 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 3138 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 17950 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let id =
+            let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 17961 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let attrs1 =
+            let _1 = _1_inlined1 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 17969 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos_attrs2_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 3127 "src/ocaml/preprocess/parser_raw.mly"
+    (
+      let (kind, priv, manifest) = kind_priv_manifest in
+      let docs = symbol_docs _sloc in
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc _sloc in
+      let text = symbol_text _symbolstartpos in
+      Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ~text
+    )
+# 17985 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 213 "<standard.mly>"
+    ( x :: xs )
+# 17991 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Parsetree.type_declaration list) = 
+# 211 "<standard.mly>"
+    ( [] )
+# 18009 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined4;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined4_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = xs_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos_xs_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos_xs_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined3;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1_inlined2;
+                    MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = params;
+                      MenhirLib.EngineTypes.startp = _startpos_params_;
+                      MenhirLib.EngineTypes.endp = _endpos_params_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = _1_inlined1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _menhir_s;
+                          MenhirLib.EngineTypes.semv = _1;
+                          MenhirLib.EngineTypes.startp = _startpos__1_;
+                          MenhirLib.EngineTypes.endp = _endpos__1_;
+                          MenhirLib.EngineTypes.next = _menhir_stack;
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.type_declaration list) = Obj.magic xs in
+        let _1_inlined4 : (Parsetree.attributes) = Obj.magic _1_inlined4 in
+        let xs_inlined1 : ((Parsetree.core_type * Parsetree.core_type * Location.t) list) = Obj.magic xs_inlined1 in
+        let _2 : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = Obj.magic _2 in
+        let _1_inlined3 : unit = Obj.magic _1_inlined3 in
+        let _1_inlined2 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 18083 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined2 in
+        let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.type_declaration list) = let x =
+          let xs = xs_inlined1 in
+          let attrs2 =
+            let _1 = _1_inlined4 in
+            
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 18098 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos_attrs2_ = _endpos__1_inlined4_ in
+          let cstrs =
+            let _1 =
+              let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 18107 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              
+# 1064 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 18112 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 3138 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 18118 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let kind_priv_manifest =
+            let _1 = _1_inlined3 in
+            
+# 3173 "src/ocaml/preprocess/parser_raw.mly"
+      ( _2 )
+# 18126 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let id =
+            let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 18137 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let attrs1 =
+            let _1 = _1_inlined1 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 18145 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos_attrs2_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 3127 "src/ocaml/preprocess/parser_raw.mly"
+    (
+      let (kind, priv, manifest) = kind_priv_manifest in
+      let docs = symbol_docs _sloc in
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc _sloc in
+      let text = symbol_text _symbolstartpos in
+      Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ~text
+    )
+# 18161 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 213 "<standard.mly>"
+    ( x :: xs )
+# 18167 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Parsetree.attributes) = 
+# 211 "<standard.mly>"
+    ( [] )
+# 18185 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = x;
+            MenhirLib.EngineTypes.startp = _startpos_x_;
+            MenhirLib.EngineTypes.endp = _endpos_x_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.attributes) = Obj.magic xs in
+        let x : (Parsetree.attribute) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.attributes) = 
+# 213 "<standard.mly>"
+    ( x :: xs )
+# 18217 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Parsetree.signature_item list list) = 
+# 211 "<standard.mly>"
+    ( [] )
+# 18235 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.signature_item list list) = Obj.magic xs in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.signature_item list list) = let x =
+          let _1 =
+            let _startpos = _startpos__1_ in
+            
+# 990 "src/ocaml/preprocess/parser_raw.mly"
+  ( text_sig _startpos )
+# 18270 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 1741 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 18276 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 213 "<standard.mly>"
+    ( x :: xs )
+# 18282 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.signature_item list list) = Obj.magic xs in
+        let _1 : (Parsetree.signature_item) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.signature_item list list) = let x =
+          let _1 =
+            let _startpos = _startpos__1_ in
+            
+# 988 "src/ocaml/preprocess/parser_raw.mly"
+  ( text_sig _startpos @ [_1] )
+# 18317 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 1741 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 18323 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 213 "<standard.mly>"
+    ( x :: xs )
+# 18329 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Parsetree.structure_item list list) = 
+# 211 "<standard.mly>"
+    ( [] )
+# 18347 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.structure_item list list) = Obj.magic xs in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.structure_item list list) = let x =
+          let _1 =
+            let ys =
+              let items = 
+# 1050 "src/ocaml/preprocess/parser_raw.mly"
+    ( [] )
+# 18382 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              
+# 1482 "src/ocaml/preprocess/parser_raw.mly"
+    ( items )
+# 18387 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let xs =
+              let _startpos = _startpos__1_ in
+              
+# 986 "src/ocaml/preprocess/parser_raw.mly"
+  ( text_str _startpos )
+# 18395 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 267 "<standard.mly>"
+    ( xs @ ys )
+# 18401 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 1498 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 18407 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 213 "<standard.mly>"
+    ( x :: xs )
+# 18413 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = e;
+              MenhirLib.EngineTypes.startp = _startpos_e_;
+              MenhirLib.EngineTypes.endp = _endpos_e_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.structure_item list list) = Obj.magic xs in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let e : (Parsetree.expression) = Obj.magic e in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.structure_item list list) = let x =
+          let _1 =
+            let ys =
+              let (_endpos__1_, _1) = (_endpos__1_inlined1_, _1_inlined1) in
+              let items =
+                let x =
+                  let _1 =
+                    let _1 =
+                      let attrs = 
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 18467 "src/ocaml/preprocess/parser_raw.ml"
+                       in
+                      
+# 1489 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkstrexp e attrs )
+# 18472 "src/ocaml/preprocess/parser_raw.ml"
+                      
+                    in
+                    let _startpos__1_ = _startpos_e_ in
+                    let _startpos = _startpos__1_ in
+                    
+# 984 "src/ocaml/preprocess/parser_raw.mly"
+  ( text_str _startpos @ [_1] )
+# 18480 "src/ocaml/preprocess/parser_raw.ml"
+                    
+                  in
+                  let _startpos__1_ = _startpos_e_ in
+                  let _endpos = _endpos__1_ in
+                  let _startpos = _startpos__1_ in
+                  
+# 1003 "src/ocaml/preprocess/parser_raw.mly"
+  ( mark_rhs_docs _startpos _endpos;
+    _1 )
+# 18490 "src/ocaml/preprocess/parser_raw.ml"
+                  
+                in
+                
+# 1052 "src/ocaml/preprocess/parser_raw.mly"
+    ( x )
+# 18496 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 1482 "src/ocaml/preprocess/parser_raw.mly"
+    ( items )
+# 18502 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let xs =
+              let _startpos = _startpos__1_ in
+              
+# 986 "src/ocaml/preprocess/parser_raw.mly"
+  ( text_str _startpos )
+# 18510 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 267 "<standard.mly>"
+    ( xs @ ys )
+# 18516 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 1498 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 18522 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 213 "<standard.mly>"
+    ( x :: xs )
+# 18528 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.structure_item list list) = Obj.magic xs in
+        let _1 : (Parsetree.structure_item) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.structure_item list list) = let x =
+          let _1 =
+            let _startpos = _startpos__1_ in
+            
+# 984 "src/ocaml/preprocess/parser_raw.mly"
+  ( text_str _startpos @ [_1] )
+# 18563 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 1498 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 18569 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 213 "<standard.mly>"
+    ( x :: xs )
+# 18575 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Parsetree.class_type_field list list) = 
+# 211 "<standard.mly>"
+    ( [] )
+# 18593 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.class_type_field list list) = Obj.magic xs in
+        let _1 : (Parsetree.class_type_field) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.class_type_field list list) = let x =
+          let _startpos = _startpos__1_ in
+          
+# 998 "src/ocaml/preprocess/parser_raw.mly"
+  ( text_csig _startpos @ [_1] )
+# 18627 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 213 "<standard.mly>"
+    ( x :: xs )
+# 18633 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Parsetree.class_field list list) = 
+# 211 "<standard.mly>"
+    ( [] )
+# 18651 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.class_field list list) = Obj.magic xs in
+        let _1 : (Parsetree.class_field) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.class_field list list) = let x =
+          let _startpos = _startpos__1_ in
+          
+# 996 "src/ocaml/preprocess/parser_raw.mly"
+  ( text_cstr _startpos @ [_1] )
+# 18685 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 213 "<standard.mly>"
+    ( x :: xs )
+# 18691 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Parsetree.structure_item list list) = 
+# 211 "<standard.mly>"
+    ( [] )
+# 18709 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.structure_item list list) = Obj.magic xs in
+        let _1 : (Parsetree.structure_item) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.structure_item list list) = let x =
+          let _startpos = _startpos__1_ in
+          
+# 984 "src/ocaml/preprocess/parser_raw.mly"
+  ( text_str _startpos @ [_1] )
+# 18743 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 213 "<standard.mly>"
+    ( x :: xs )
+# 18749 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Parsetree.toplevel_phrase list list) = 
+# 211 "<standard.mly>"
+    ( [] )
+# 18767 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.toplevel_phrase list list) = Obj.magic xs in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.toplevel_phrase list list) = let x =
+          let _1 =
+            let x =
+              let _1 = 
+# 1050 "src/ocaml/preprocess/parser_raw.mly"
+    ( [] )
+# 18802 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              
+# 1282 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 18807 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 183 "<standard.mly>"
+    ( x )
+# 18813 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 1294 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 18819 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 213 "<standard.mly>"
+    ( x :: xs )
+# 18825 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = e;
+              MenhirLib.EngineTypes.startp = _startpos_e_;
+              MenhirLib.EngineTypes.endp = _endpos_e_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.toplevel_phrase list list) = Obj.magic xs in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let e : (Parsetree.expression) = Obj.magic e in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.toplevel_phrase list list) = let x =
+          let _1 =
+            let x =
+              let _1 = _1_inlined1 in
+              let _1 =
+                let x =
+                  let _1 =
+                    let _1 =
+                      let attrs = 
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 18879 "src/ocaml/preprocess/parser_raw.ml"
+                       in
+                      
+# 1489 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkstrexp e attrs )
+# 18884 "src/ocaml/preprocess/parser_raw.ml"
+                      
+                    in
+                    
+# 994 "src/ocaml/preprocess/parser_raw.mly"
+  ( Ptop_def [_1] )
+# 18890 "src/ocaml/preprocess/parser_raw.ml"
+                    
+                  in
+                  let _startpos__1_ = _startpos_e_ in
+                  let _startpos = _startpos__1_ in
+                  
+# 992 "src/ocaml/preprocess/parser_raw.mly"
+  ( text_def _startpos @ [_1] )
+# 18898 "src/ocaml/preprocess/parser_raw.ml"
+                  
+                in
+                
+# 1052 "src/ocaml/preprocess/parser_raw.mly"
+    ( x )
+# 18904 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 1282 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 18910 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 183 "<standard.mly>"
+    ( x )
+# 18916 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 1294 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 18922 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 213 "<standard.mly>"
+    ( x :: xs )
+# 18928 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.toplevel_phrase list list) = Obj.magic xs in
+        let _1 : (Parsetree.structure_item) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.toplevel_phrase list list) = let x =
+          let _1 =
+            let _1 = 
+# 994 "src/ocaml/preprocess/parser_raw.mly"
+  ( Ptop_def [_1] )
+# 18962 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let _startpos = _startpos__1_ in
+            
+# 992 "src/ocaml/preprocess/parser_raw.mly"
+  ( text_def _startpos @ [_1] )
+# 18968 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 1294 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 18974 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 213 "<standard.mly>"
+    ( x :: xs )
+# 18980 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.toplevel_phrase list list) = Obj.magic xs in
+        let _1 : (Parsetree.toplevel_phrase) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.toplevel_phrase list list) = let x =
+          let _1 =
+            let _1 =
+              let _endpos = _endpos__1_ in
+              let _startpos = _startpos__1_ in
+              
+# 1003 "src/ocaml/preprocess/parser_raw.mly"
+  ( mark_rhs_docs _startpos _endpos;
+    _1 )
+# 19018 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let _startpos = _startpos__1_ in
+            
+# 992 "src/ocaml/preprocess/parser_raw.mly"
+  ( text_def _startpos @ [_1] )
+# 19025 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 1294 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 19031 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 213 "<standard.mly>"
+    ( x :: xs )
+# 19037 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = opat;
+          MenhirLib.EngineTypes.startp = _startpos_opat_;
+          MenhirLib.EngineTypes.endp = _endpos_opat_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = octy;
+            MenhirLib.EngineTypes.startp = _startpos_octy_;
+            MenhirLib.EngineTypes.endp = _endpos_octy_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let opat : (Parsetree.pattern option) = Obj.magic opat in
+        let octy : (Parsetree.core_type option) = Obj.magic octy in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_opat_ in
+        let _v : ((Longident.t Location.loc * Parsetree.pattern) list * unit option) = let _2 = 
+# 124 "<standard.mly>"
+    ( None )
+# 19076 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let x =
+          let label =
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 19086 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _startpos_label_ = _startpos__1_ in
+          let _endpos = _endpos_opat_ in
+          let _symbolstartpos = _startpos_label_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 3013 "src/ocaml/preprocess/parser_raw.mly"
+    ( let label, pat =
+        match opat with
+        | None ->
+            (* No pattern; this is a pun. Desugar it.
+               But that the pattern was there and the label reconstructed (which
+               piece of AST is marked as ghost is important for warning
+               emission). *)
+            make_ghost label, pat_of_label label
+        | Some pat ->
+            label, pat
+      in
+      label, mkpat_opt_constraint ~loc:_sloc pat octy
+    )
+# 19108 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1219 "src/ocaml/preprocess/parser_raw.mly"
+    ( [x], None )
+# 19114 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = opat;
+            MenhirLib.EngineTypes.startp = _startpos_opat_;
+            MenhirLib.EngineTypes.endp = _endpos_opat_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = octy;
+              MenhirLib.EngineTypes.startp = _startpos_octy_;
+              MenhirLib.EngineTypes.endp = _endpos_octy_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let x : unit = Obj.magic x in
+        let opat : (Parsetree.pattern option) = Obj.magic opat in
+        let octy : (Parsetree.core_type option) = Obj.magic octy in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_x_ in
+        let _v : ((Longident.t Location.loc * Parsetree.pattern) list * unit option) = let _2 = 
+# 126 "<standard.mly>"
+    ( Some x )
+# 19160 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let x =
+          let label =
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 19170 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _startpos_label_ = _startpos__1_ in
+          let _endpos = _endpos_opat_ in
+          let _symbolstartpos = _startpos_label_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 3013 "src/ocaml/preprocess/parser_raw.mly"
+    ( let label, pat =
+        match opat with
+        | None ->
+            (* No pattern; this is a pun. Desugar it.
+               But that the pattern was there and the label reconstructed (which
+               piece of AST is marked as ghost is important for warning
+               emission). *)
+            make_ghost label, pat_of_label label
+        | Some pat ->
+            label, pat
+      in
+      label, mkpat_opt_constraint ~loc:_sloc pat octy
+    )
+# 19192 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1219 "src/ocaml/preprocess/parser_raw.mly"
+    ( [x], None )
+# 19198 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = y;
+            MenhirLib.EngineTypes.startp = _startpos_y_;
+            MenhirLib.EngineTypes.endp = _endpos_y_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = opat;
+                MenhirLib.EngineTypes.startp = _startpos_opat_;
+                MenhirLib.EngineTypes.endp = _endpos_opat_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = octy;
+                  MenhirLib.EngineTypes.startp = _startpos_octy_;
+                  MenhirLib.EngineTypes.endp = _endpos_octy_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : (unit option) = Obj.magic _4 in
+        let y : unit = Obj.magic y in
+        let _2 : unit = Obj.magic _2 in
+        let opat : (Parsetree.pattern option) = Obj.magic opat in
+        let octy : (Parsetree.core_type option) = Obj.magic octy in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : ((Longident.t Location.loc * Parsetree.pattern) list * unit option) = let x =
+          let label =
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 19263 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _startpos_label_ = _startpos__1_ in
+          let _endpos = _endpos_opat_ in
+          let _symbolstartpos = _startpos_label_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 3013 "src/ocaml/preprocess/parser_raw.mly"
+    ( let label, pat =
+        match opat with
+        | None ->
+            (* No pattern; this is a pun. Desugar it.
+               But that the pattern was there and the label reconstructed (which
+               piece of AST is marked as ghost is important for warning
+               emission). *)
+            make_ghost label, pat_of_label label
+        | Some pat ->
+            label, pat
+      in
+      label, mkpat_opt_constraint ~loc:_sloc pat octy
+    )
+# 19285 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1221 "src/ocaml/preprocess/parser_raw.mly"
+    ( [x], Some y )
+# 19291 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = tail;
+          MenhirLib.EngineTypes.startp = _startpos_tail_;
+          MenhirLib.EngineTypes.endp = _endpos_tail_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = opat;
+              MenhirLib.EngineTypes.startp = _startpos_opat_;
+              MenhirLib.EngineTypes.endp = _endpos_opat_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = octy;
+                MenhirLib.EngineTypes.startp = _startpos_octy_;
+                MenhirLib.EngineTypes.endp = _endpos_octy_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let tail : ((Longident.t Location.loc * Parsetree.pattern) list * unit option) = Obj.magic tail in
+        let _2 : unit = Obj.magic _2 in
+        let opat : (Parsetree.pattern option) = Obj.magic opat in
+        let octy : (Parsetree.core_type option) = Obj.magic octy in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_tail_ in
+        let _v : ((Longident.t Location.loc * Parsetree.pattern) list * unit option) = let x =
+          let label =
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 19349 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _startpos_label_ = _startpos__1_ in
+          let _endpos = _endpos_opat_ in
+          let _symbolstartpos = _startpos_label_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 3013 "src/ocaml/preprocess/parser_raw.mly"
+    ( let label, pat =
+        match opat with
+        | None ->
+            (* No pattern; this is a pun. Desugar it.
+               But that the pattern was there and the label reconstructed (which
+               piece of AST is marked as ghost is important for warning
+               emission). *)
+            make_ghost label, pat_of_label label
+        | Some pat ->
+            label, pat
+      in
+      label, mkpat_opt_constraint ~loc:_sloc pat octy
+    )
+# 19371 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1225 "src/ocaml/preprocess/parser_raw.mly"
+    ( let xs, y = tail in
+      x :: xs, y )
+# 19378 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined3;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let _4 : (Parsetree.pattern * Parsetree.expression * bool) = Obj.magic _4 in
+        let _3 : (Asttypes.rec_flag) = Obj.magic _3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined3_ in
+        let _v : (Ast_helper.let_bindings) = let _5 =
+          let _1 = _1_inlined3 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 19440 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _2 =
+          let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+          let _2 =
+            let _1 = _1_inlined1 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 19450 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 19456 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _loc__4_ = (_startpos__4_, _endpos__4_) in
+        
+# 4052 "src/ocaml/preprocess/parser_raw.mly"
+      ( let (ext, attr) = _2 in
+        mklbs ext _3 (mklb ~loc:_loc__4_ true _4 (attr@_5)) )
+# 19464 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Ast_helper.let_bindings) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Ast_helper.let_bindings) = 
+# 4056 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 19489 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Ast_helper.let_binding) = Obj.magic _2 in
+        let _1 : (Ast_helper.let_bindings) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Ast_helper.let_bindings) = 
+# 4057 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( addlb _1 _2 )
+# 19521 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.expression) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.case) = 
+# 2763 "src/ocaml/preprocess/parser_raw.mly"
+      ( Exp.case _1 (merloc _endpos__2_ _3) )
+# 19560 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : (Parsetree.expression) = Obj.magic _5 in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (Parsetree.expression) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.case) = 
+# 2765 "src/ocaml/preprocess/parser_raw.mly"
+      ( Exp.case _1 ~guard:(merloc _endpos__2_ _3) (merloc _endpos__4_ _5) )
+# 19613 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.case) = let _loc__3_ = (_startpos__3_, _endpos__3_) in
+        
+# 2767 "src/ocaml/preprocess/parser_raw.mly"
+      ( Exp.case _1 (merloc _endpos__2_
+                       (Exp.unreachable ~loc:(make_loc _loc__3_) ())) )
+# 19654 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = tail;
+          MenhirLib.EngineTypes.startp = _startpos_tail_;
+          MenhirLib.EngineTypes.endp = _endpos_tail_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined3;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _5;
+              MenhirLib.EngineTypes.startp = _startpos__5_;
+              MenhirLib.EngineTypes.endp = _endpos__5_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _2;
+                    MenhirLib.EngineTypes.startp = _startpos__2_;
+                    MenhirLib.EngineTypes.endp = _endpos__2_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = _1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let tail : (Parsetree.object_field list * Asttypes.closed_flag) = Obj.magic tail in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let _5 : unit = Obj.magic _5 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (Parsetree.core_type) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 19717 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_tail_ in
+        let _v : (Parsetree.object_field list * Asttypes.closed_flag) = let head =
+          let _6 =
+            let _1 = _1_inlined3 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 19728 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__6_ = _endpos__1_inlined3_ in
+          let _4 =
+            let _1 = _1_inlined2 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 19737 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__4_ = _endpos__1_inlined2_ in
+          let _3 =
+            let _1 = _1_inlined1 in
+            
+# 3436 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 19746 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _1 =
+            let _1 = 
+# 3661 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 19753 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 19761 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos__6_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 3646 "src/ocaml/preprocess/parser_raw.mly"
+    ( let info =
+        match rhs_info _endpos__4_ with
+        | Some _ as info_before_semi -> info_before_semi
+        | None -> symbol_info _endpos
+      in
+      let attrs = add_info_attrs info (_4 @ _6) in
+      Of.tag ~loc:(make_loc _sloc) ~attrs _1 _3 )
+# 19776 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3627 "src/ocaml/preprocess/parser_raw.mly"
+      ( let (f, c) = tail in (head :: f, c) )
+# 19782 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = tail;
+          MenhirLib.EngineTypes.startp = _startpos_tail_;
+          MenhirLib.EngineTypes.endp = _endpos_tail_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = ty;
+              MenhirLib.EngineTypes.startp = _startpos_ty_;
+              MenhirLib.EngineTypes.endp = _endpos_ty_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let tail : (Parsetree.object_field list * Asttypes.closed_flag) = Obj.magic tail in
+        let _2 : unit = Obj.magic _2 in
+        let ty : (Parsetree.core_type) = Obj.magic ty in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_ty_ in
+        let _endpos = _endpos_tail_ in
+        let _v : (Parsetree.object_field list * Asttypes.closed_flag) = let head =
+          let _endpos = _endpos_ty_ in
+          let _symbolstartpos = _startpos_ty_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 3657 "src/ocaml/preprocess/parser_raw.mly"
+    ( Of.inherit_ ~loc:(make_loc _sloc) ty )
+# 19825 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3627 "src/ocaml/preprocess/parser_raw.mly"
+      ( let (f, c) = tail in (head :: f, c) )
+# 19831 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined3;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _5;
+            MenhirLib.EngineTypes.startp = _startpos__5_;
+            MenhirLib.EngineTypes.endp = _endpos__5_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined2;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined1;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _2;
+                  MenhirLib.EngineTypes.startp = _startpos__2_;
+                  MenhirLib.EngineTypes.endp = _endpos__2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let _5 : unit = Obj.magic _5 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (Parsetree.core_type) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 19887 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined3_ in
+        let _v : (Parsetree.object_field list * Asttypes.closed_flag) = let head =
+          let _6 =
+            let _1 = _1_inlined3 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 19898 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__6_ = _endpos__1_inlined3_ in
+          let _4 =
+            let _1 = _1_inlined2 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 19907 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__4_ = _endpos__1_inlined2_ in
+          let _3 =
+            let _1 = _1_inlined1 in
+            
+# 3436 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 19916 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _1 =
+            let _1 = 
+# 3661 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 19923 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 19931 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos__6_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 3646 "src/ocaml/preprocess/parser_raw.mly"
+    ( let info =
+        match rhs_info _endpos__4_ with
+        | Some _ as info_before_semi -> info_before_semi
+        | None -> symbol_info _endpos
+      in
+      let attrs = add_info_attrs info (_4 @ _6) in
+      Of.tag ~loc:(make_loc _sloc) ~attrs _1 _3 )
+# 19946 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3630 "src/ocaml/preprocess/parser_raw.mly"
+      ( [head], Closed )
+# 19952 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = ty;
+            MenhirLib.EngineTypes.startp = _startpos_ty_;
+            MenhirLib.EngineTypes.endp = _endpos_ty_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let ty : (Parsetree.core_type) = Obj.magic ty in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_ty_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.object_field list * Asttypes.closed_flag) = let head =
+          let _endpos = _endpos_ty_ in
+          let _symbolstartpos = _startpos_ty_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 3657 "src/ocaml/preprocess/parser_raw.mly"
+    ( Of.inherit_ ~loc:(make_loc _sloc) ty )
+# 19988 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3630 "src/ocaml/preprocess/parser_raw.mly"
+      ( [head], Closed )
+# 19994 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined2;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (Parsetree.core_type) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 20036 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined2_ in
+        let _v : (Parsetree.object_field list * Asttypes.closed_flag) = let head =
+          let _4 =
+            let _1 = _1_inlined2 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 20047 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__4_ = _endpos__1_inlined2_ in
+          let _3 =
+            let _1 = _1_inlined1 in
+            
+# 3436 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 20056 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _1 =
+            let _1 = 
+# 3661 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 20063 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 20071 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos__4_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 3639 "src/ocaml/preprocess/parser_raw.mly"
+    ( let info = symbol_info _endpos in
+      let attrs = add_info_attrs info _4 in
+      Of.tag ~loc:(make_loc _sloc) ~attrs _1 _3 )
+# 20082 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3633 "src/ocaml/preprocess/parser_raw.mly"
+      ( [head], Closed )
+# 20088 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = ty;
+          MenhirLib.EngineTypes.startp = _startpos_ty_;
+          MenhirLib.EngineTypes.endp = _endpos_ty_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let ty : (Parsetree.core_type) = Obj.magic ty in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_ty_ in
+        let _endpos = _endpos_ty_ in
+        let _v : (Parsetree.object_field list * Asttypes.closed_flag) = let head =
+          let _endpos = _endpos_ty_ in
+          let _symbolstartpos = _startpos_ty_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 3657 "src/ocaml/preprocess/parser_raw.mly"
+    ( Of.inherit_ ~loc:(make_loc _sloc) ty )
+# 20117 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3633 "src/ocaml/preprocess/parser_raw.mly"
+      ( [head], Closed )
+# 20123 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.object_field list * Asttypes.closed_flag) = 
+# 3635 "src/ocaml/preprocess/parser_raw.mly"
+      ( [], Open )
+# 20148 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined2;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _5;
+            MenhirLib.EngineTypes.startp = _startpos__5_;
+            MenhirLib.EngineTypes.endp = _endpos__5_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = private_;
+                MenhirLib.EngineTypes.startp = _startpos_private__;
+                MenhirLib.EngineTypes.endp = _endpos_private__;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in
+        let _5 : unit = Obj.magic _5 in
+        let _1_inlined1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 20195 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined1 in
+        let private_ : (Asttypes.private_flag) = Obj.magic private_ in
+        let _1 : (Parsetree.attributes) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined2_ in
+        let _v : ((string Location.loc * Asttypes.private_flag * Parsetree.class_field_kind) *
+  Parsetree.attributes) = let ty =
+          let _1 = _1_inlined2 in
+          
+# 3432 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 20208 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let label =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _1 = 
+# 3661 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 20216 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 20224 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let attrs = 
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 20230 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let _1 = 
+# 3904 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Fresh )
+# 20235 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 2087 "src/ocaml/preprocess/parser_raw.mly"
+      ( (label, private_, Cfk_virtual ty), attrs )
+# 20240 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : (Parsetree.expression) = Obj.magic _5 in
+        let _1_inlined1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 20280 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined1 in
+        let _3 : (Asttypes.private_flag) = Obj.magic _3 in
+        let _1 : (Parsetree.attributes) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : ((string Location.loc * Asttypes.private_flag * Parsetree.class_field_kind) *
+  Parsetree.attributes) = let _4 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _1 = 
+# 3661 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 20293 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 20301 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _2 = 
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 20307 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let _1 = 
+# 3907 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Fresh )
+# 20312 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 2089 "src/ocaml/preprocess/parser_raw.mly"
+      ( let e = _5 in
+        let loc = Location.(e.pexp_loc.loc_start, e.pexp_loc.loc_end) in
+        (_4, _3,
+        Cfk_concrete (_1, ghexp ~loc (Pexp_poly (e, None)))), _2 )
+# 20320 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined2;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined1;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : (Parsetree.expression) = Obj.magic _5 in
+        let _1_inlined2 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 20366 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined2 in
+        let _3 : (Asttypes.private_flag) = Obj.magic _3 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : ((string Location.loc * Asttypes.private_flag * Parsetree.class_field_kind) *
+  Parsetree.attributes) = let _4 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let _1 = 
+# 3661 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 20380 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 20388 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _2 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 20396 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _1 = 
+# 3908 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Override )
+# 20402 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 2089 "src/ocaml/preprocess/parser_raw.mly"
+      ( let e = _5 in
+        let loc = Location.(e.pexp_loc.loc_start, e.pexp_loc.loc_end) in
+        (_4, _3,
+        Cfk_concrete (_1, ghexp ~loc (Pexp_poly (e, None)))), _2 )
+# 20410 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _8;
+          MenhirLib.EngineTypes.startp = _startpos__8_;
+          MenhirLib.EngineTypes.endp = _endpos__8_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _7;
+            MenhirLib.EngineTypes.startp = _startpos__7_;
+            MenhirLib.EngineTypes.endp = _endpos__7_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined2;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _5;
+                MenhirLib.EngineTypes.startp = _startpos__5_;
+                MenhirLib.EngineTypes.endp = _endpos__5_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _3;
+                    MenhirLib.EngineTypes.startp = _startpos__3_;
+                    MenhirLib.EngineTypes.endp = _endpos__3_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = _1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _8 : (Parsetree.expression) = Obj.magic _8 in
+        let _7 : unit = Obj.magic _7 in
+        let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in
+        let _5 : unit = Obj.magic _5 in
+        let _1_inlined1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 20471 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined1 in
+        let _3 : (Asttypes.private_flag) = Obj.magic _3 in
+        let _1 : (Parsetree.attributes) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__8_ in
+        let _v : ((string Location.loc * Asttypes.private_flag * Parsetree.class_field_kind) *
+  Parsetree.attributes) = let _6 =
+          let _1 = _1_inlined2 in
+          
+# 3432 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 20484 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _startpos__6_ = _startpos__1_inlined2_ in
+        let _4 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _1 = 
+# 3661 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 20493 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 20501 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _2 = 
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 20507 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let _1 = 
+# 3907 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Fresh )
+# 20512 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 2095 "src/ocaml/preprocess/parser_raw.mly"
+      ( let poly_exp =
+          let loc = (_startpos__6_, _endpos__8_) in
+          ghexp ~loc (Pexp_poly(_8, Some _6)) in
+        (_4, _3, Cfk_concrete (_1, poly_exp)), _2 )
+# 20520 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _8;
+          MenhirLib.EngineTypes.startp = _startpos__8_;
+          MenhirLib.EngineTypes.endp = _endpos__8_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _7;
+            MenhirLib.EngineTypes.startp = _startpos__7_;
+            MenhirLib.EngineTypes.endp = _endpos__7_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined3;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _5;
+                MenhirLib.EngineTypes.startp = _startpos__5_;
+                MenhirLib.EngineTypes.endp = _endpos__5_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined2;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _3;
+                    MenhirLib.EngineTypes.startp = _startpos__3_;
+                    MenhirLib.EngineTypes.endp = _endpos__3_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _1_inlined1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _menhir_s;
+                        MenhirLib.EngineTypes.semv = _1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_;
+                        MenhirLib.EngineTypes.next = _menhir_stack;
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _8 : (Parsetree.expression) = Obj.magic _8 in
+        let _7 : unit = Obj.magic _7 in
+        let _1_inlined3 : (Parsetree.core_type) = Obj.magic _1_inlined3 in
+        let _5 : unit = Obj.magic _5 in
+        let _1_inlined2 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 20587 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined2 in
+        let _3 : (Asttypes.private_flag) = Obj.magic _3 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__8_ in
+        let _v : ((string Location.loc * Asttypes.private_flag * Parsetree.class_field_kind) *
+  Parsetree.attributes) = let _6 =
+          let _1 = _1_inlined3 in
+          
+# 3432 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 20601 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _startpos__6_ = _startpos__1_inlined3_ in
+        let _4 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let _1 = 
+# 3661 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 20610 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 20618 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _2 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 20626 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _1 = 
+# 3908 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Override )
+# 20632 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 2095 "src/ocaml/preprocess/parser_raw.mly"
+      ( let poly_exp =
+          let loc = (_startpos__6_, _endpos__8_) in
+          ghexp ~loc (Pexp_poly(_8, Some _6)) in
+        (_4, _3, Cfk_concrete (_1, poly_exp)), _2 )
+# 20640 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _11;
+          MenhirLib.EngineTypes.startp = _startpos__11_;
+          MenhirLib.EngineTypes.endp = _endpos__11_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _10;
+            MenhirLib.EngineTypes.startp = _startpos__10_;
+            MenhirLib.EngineTypes.endp = _endpos__10_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _9;
+              MenhirLib.EngineTypes.startp = _startpos__9_;
+              MenhirLib.EngineTypes.endp = _endpos__9_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _8;
+                MenhirLib.EngineTypes.startp = _startpos__8_;
+                MenhirLib.EngineTypes.endp = _endpos__8_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = xs;
+                  MenhirLib.EngineTypes.startp = _startpos_xs_;
+                  MenhirLib.EngineTypes.endp = _endpos_xs_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _6;
+                    MenhirLib.EngineTypes.startp = _startpos__6_;
+                    MenhirLib.EngineTypes.endp = _endpos__6_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _5;
+                      MenhirLib.EngineTypes.startp = _startpos__5_;
+                      MenhirLib.EngineTypes.endp = _endpos__5_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = _1_inlined1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _;
+                          MenhirLib.EngineTypes.semv = _3;
+                          MenhirLib.EngineTypes.startp = _startpos__3_;
+                          MenhirLib.EngineTypes.endp = _endpos__3_;
+                          MenhirLib.EngineTypes.next = {
+                            MenhirLib.EngineTypes.state = _menhir_s;
+                            MenhirLib.EngineTypes.semv = _1;
+                            MenhirLib.EngineTypes.startp = _startpos__1_;
+                            MenhirLib.EngineTypes.endp = _endpos__1_;
+                            MenhirLib.EngineTypes.next = _menhir_stack;
+                          };
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _11 : (Parsetree.expression) = Obj.magic _11 in
+        let _10 : unit = Obj.magic _10 in
+        let _9 : (Parsetree.core_type) = Obj.magic _9 in
+        let _8 : unit = Obj.magic _8 in
+        let xs : (string Location.loc list) = Obj.magic xs in
+        let _6 : unit = Obj.magic _6 in
+        let _5 : unit = Obj.magic _5 in
+        let _1_inlined1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 20722 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined1 in
+        let _3 : (Asttypes.private_flag) = Obj.magic _3 in
+        let _1 : (Parsetree.attributes) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__11_ in
+        let _v : ((string Location.loc * Asttypes.private_flag * Parsetree.class_field_kind) *
+  Parsetree.attributes) = let _7 = 
+# 2639 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 20733 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let _startpos__7_ = _startpos_xs_ in
+        let _4 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _1 = 
+# 3661 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 20741 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 20749 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _startpos__4_ = _startpos__1_inlined1_ in
+        let _2 = 
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 20756 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let (_endpos__2_, _startpos__2_) = (_endpos__1_, _startpos__1_) in
+        let _1 = 
+# 3907 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Fresh )
+# 20762 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let (_endpos__1_, _startpos__1_) = (_endpos__0_, _endpos__0_) in
+        let _endpos = _endpos__11_ in
+        let _symbolstartpos = if _startpos__1_ != _endpos__1_ then
+          _startpos__1_
+        else
+          if _startpos__2_ != _endpos__2_ then
+            _startpos__2_
+          else
+            if _startpos__3_ != _endpos__3_ then
+              _startpos__3_
+            else
+              _startpos__4_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2101 "src/ocaml/preprocess/parser_raw.mly"
+      ( let poly_exp_loc = (_startpos__7_, _endpos__11_) in
+        let poly_exp =
+          let exp, poly =
+            (* it seems odd to use the global ~loc here while poly_exp_loc
+               is tighter, but this is what ocamlyacc does;
+               TODO improve parser.mly *)
+            wrap_type_annotation ~loc:_sloc _7 _9 _11 in
+          ghexp ~loc:poly_exp_loc (Pexp_poly(exp, Some poly)) in
+        (_4, _3,
+        Cfk_concrete (_1, poly_exp)), _2 )
+# 20789 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _11;
+          MenhirLib.EngineTypes.startp = _startpos__11_;
+          MenhirLib.EngineTypes.endp = _endpos__11_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _10;
+            MenhirLib.EngineTypes.startp = _startpos__10_;
+            MenhirLib.EngineTypes.endp = _endpos__10_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _9;
+              MenhirLib.EngineTypes.startp = _startpos__9_;
+              MenhirLib.EngineTypes.endp = _endpos__9_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _8;
+                MenhirLib.EngineTypes.startp = _startpos__8_;
+                MenhirLib.EngineTypes.endp = _endpos__8_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = xs;
+                  MenhirLib.EngineTypes.startp = _startpos_xs_;
+                  MenhirLib.EngineTypes.endp = _endpos_xs_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _6;
+                    MenhirLib.EngineTypes.startp = _startpos__6_;
+                    MenhirLib.EngineTypes.endp = _endpos__6_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _5;
+                      MenhirLib.EngineTypes.startp = _startpos__5_;
+                      MenhirLib.EngineTypes.endp = _endpos__5_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = _1_inlined2;
+                        MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _;
+                          MenhirLib.EngineTypes.semv = _3;
+                          MenhirLib.EngineTypes.startp = _startpos__3_;
+                          MenhirLib.EngineTypes.endp = _endpos__3_;
+                          MenhirLib.EngineTypes.next = {
+                            MenhirLib.EngineTypes.state = _;
+                            MenhirLib.EngineTypes.semv = _1_inlined1;
+                            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                            MenhirLib.EngineTypes.next = {
+                              MenhirLib.EngineTypes.state = _menhir_s;
+                              MenhirLib.EngineTypes.semv = _1;
+                              MenhirLib.EngineTypes.startp = _startpos__1_;
+                              MenhirLib.EngineTypes.endp = _endpos__1_;
+                              MenhirLib.EngineTypes.next = _menhir_stack;
+                            };
+                          };
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _11 : (Parsetree.expression) = Obj.magic _11 in
+        let _10 : unit = Obj.magic _10 in
+        let _9 : (Parsetree.core_type) = Obj.magic _9 in
+        let _8 : unit = Obj.magic _8 in
+        let xs : (string Location.loc list) = Obj.magic xs in
+        let _6 : unit = Obj.magic _6 in
+        let _5 : unit = Obj.magic _5 in
+        let _1_inlined2 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 20877 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined2 in
+        let _3 : (Asttypes.private_flag) = Obj.magic _3 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__11_ in
+        let _v : ((string Location.loc * Asttypes.private_flag * Parsetree.class_field_kind) *
+  Parsetree.attributes) = let _7 = 
+# 2639 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 20889 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let _startpos__7_ = _startpos_xs_ in
+        let _4 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let _1 = 
+# 3661 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 20897 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 20905 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _startpos__4_ = _startpos__1_inlined2_ in
+        let _2 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 20914 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let (_endpos__2_, _startpos__2_) = (_endpos__1_inlined1_, _startpos__1_inlined1_) in
+        let _1 = 
+# 3908 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Override )
+# 20921 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let _endpos = _endpos__11_ in
+        let _symbolstartpos = if _startpos__1_ != _endpos__1_ then
+          _startpos__1_
+        else
+          if _startpos__2_ != _endpos__2_ then
+            _startpos__2_
+          else
+            if _startpos__3_ != _endpos__3_ then
+              _startpos__3_
+            else
+              _startpos__4_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2101 "src/ocaml/preprocess/parser_raw.mly"
+      ( let poly_exp_loc = (_startpos__7_, _endpos__11_) in
+        let poly_exp =
+          let exp, poly =
+            (* it seems odd to use the global ~loc here while poly_exp_loc
+               is tighter, but this is what ocamlyacc does;
+               TODO improve parser.mly *)
+            wrap_type_annotation ~loc:_sloc _7 _9 _11 in
+          ghexp ~loc:poly_exp_loc (Pexp_poly(exp, Some poly)) in
+        (_4, _3,
+        Cfk_concrete (_1, poly_exp)), _2 )
+# 20947 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 20968 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Longident.t) = 
+# 3759 "src/ocaml/preprocess/parser_raw.mly"
+                      ( Lident _1 )
+# 20976 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 21009 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Longident.t) = 
+# 3760 "src/ocaml/preprocess/parser_raw.mly"
+                      ( Ldot(_1,_3) )
+# 21019 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 839 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 21040 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Longident.t) = 
+# 3759 "src/ocaml/preprocess/parser_raw.mly"
+                      ( Lident _1 )
+# 21048 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (
+# 839 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 21081 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Longident.t) = 
+# 3760 "src/ocaml/preprocess/parser_raw.mly"
+                      ( Ldot(_1,_3) )
+# 21091 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Longident.t) = let _1 = 
+# 3799 "src/ocaml/preprocess/parser_raw.mly"
+                                                  ( _1 )
+# 21116 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3759 "src/ocaml/preprocess/parser_raw.mly"
+                      ( Lident _1 )
+# 21121 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Longident.t) = let _1 =
+          let _1 = 
+# 3739 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( "::" )
+# 21161 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          
+# 3799 "src/ocaml/preprocess/parser_raw.mly"
+                                                  ( _1 )
+# 21166 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3759 "src/ocaml/preprocess/parser_raw.mly"
+                      ( Lident _1 )
+# 21172 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Longident.t) = let _1 = 
+# 3799 "src/ocaml/preprocess/parser_raw.mly"
+                                                  ( _1 )
+# 21197 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3759 "src/ocaml/preprocess/parser_raw.mly"
+                      ( Lident _1 )
+# 21202 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (string) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (Longident.t) = let _3 =
+          let _1 = _1_inlined1 in
+          
+# 3799 "src/ocaml/preprocess/parser_raw.mly"
+                                                  ( _1 )
+# 21243 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3760 "src/ocaml/preprocess/parser_raw.mly"
+                      ( Ldot(_1,_3) )
+# 21249 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__2_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__2_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _2_inlined1 : unit = Obj.magic _2_inlined1 in
+        let _1_inlined1 : unit = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Longident.t) = let _3 =
+          let (_2, _1) = (_2_inlined1, _1_inlined1) in
+          let _1 = 
+# 3739 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( "::" )
+# 21304 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          
+# 3799 "src/ocaml/preprocess/parser_raw.mly"
+                                                  ( _1 )
+# 21309 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3760 "src/ocaml/preprocess/parser_raw.mly"
+                      ( Ldot(_1,_3) )
+# 21315 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (string) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (Longident.t) = let _3 =
+          let _1 = _1_inlined1 in
+          
+# 3799 "src/ocaml/preprocess/parser_raw.mly"
+                                                  ( _1 )
+# 21356 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3760 "src/ocaml/preprocess/parser_raw.mly"
+                      ( Ldot(_1,_3) )
+# 21362 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Longident.t) = 
+# 3759 "src/ocaml/preprocess/parser_raw.mly"
+                      ( Lident _1 )
+# 21387 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (string) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Longident.t) = 
+# 3760 "src/ocaml/preprocess/parser_raw.mly"
+                      ( Ldot(_1,_3) )
+# 21426 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 21447 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Longident.t) = 
+# 3759 "src/ocaml/preprocess/parser_raw.mly"
+                      ( Lident _1 )
+# 21455 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 21488 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Longident.t) = 
+# 3760 "src/ocaml/preprocess/parser_raw.mly"
+                      ( Ldot(_1,_3) )
+# 21498 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 839 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 21519 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Longident.t) = 
+# 3759 "src/ocaml/preprocess/parser_raw.mly"
+                      ( Lident _1 )
+# 21527 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (
+# 839 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 21560 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Longident.t) = 
+# 3760 "src/ocaml/preprocess/parser_raw.mly"
+                      ( Ldot(_1,_3) )
+# 21570 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Longident.t) = 
+# 3759 "src/ocaml/preprocess/parser_raw.mly"
+                      ( Lident _1 )
+# 21595 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (string) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Longident.t) = 
+# 3760 "src/ocaml/preprocess/parser_raw.mly"
+                      ( Ldot(_1,_3) )
+# 21634 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Longident.t) = 
+# 3775 "src/ocaml/preprocess/parser_raw.mly"
+                                            ( _1 )
+# 21659 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (Longident.t) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (Longident.t) = let _endpos = _endpos__4_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3777 "src/ocaml/preprocess/parser_raw.mly"
+      ( lapply ~loc:_sloc _1 _3 )
+# 21708 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Longident.t) = 
+# 3772 "src/ocaml/preprocess/parser_raw.mly"
+                                        ( _1 )
+# 21733 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = me;
+          MenhirLib.EngineTypes.startp = _startpos_me_;
+          MenhirLib.EngineTypes.endp = _endpos_me_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let me : (Parsetree.module_expr) = Obj.magic me in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_me_ in
+        let _v : (Parsetree.module_expr) = 
+# 1558 "src/ocaml/preprocess/parser_raw.mly"
+      ( me )
+# 21765 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = me;
+          MenhirLib.EngineTypes.startp = _startpos_me_;
+          MenhirLib.EngineTypes.endp = _endpos_me_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = mty;
+              MenhirLib.EngineTypes.startp = _startpos_mty_;
+              MenhirLib.EngineTypes.endp = _endpos_mty_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let me : (Parsetree.module_expr) = Obj.magic me in
+        let _3 : unit = Obj.magic _3 in
+        let mty : (Parsetree.module_type) = Obj.magic mty in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_me_ in
+        let _v : (Parsetree.module_expr) = let _1 =
+          let _1 = 
+# 1561 "src/ocaml/preprocess/parser_raw.mly"
+        ( Pmod_constraint(me, mty) )
+# 21812 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos_me_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1023 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkmod ~loc:_sloc _1 )
+# 21821 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1565 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 21827 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = body;
+          MenhirLib.EngineTypes.startp = _startpos_body_;
+          MenhirLib.EngineTypes.endp = _endpos_body_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = arg_and_pos;
+            MenhirLib.EngineTypes.startp = _startpos_arg_and_pos_;
+            MenhirLib.EngineTypes.endp = _endpos_arg_and_pos_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let body : (Parsetree.module_expr) = Obj.magic body in
+        let arg_and_pos : (Lexing.position * Parsetree.functor_parameter) = Obj.magic arg_and_pos in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_arg_and_pos_ in
+        let _endpos = _endpos_body_ in
+        let _v : (Parsetree.module_expr) = let _1 =
+          let _1 = 
+# 1563 "src/ocaml/preprocess/parser_raw.mly"
+        ( let (_, arg) = arg_and_pos in
+          Pmod_functor(arg, body) )
+# 21861 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let (_endpos__1_, _startpos__1_) = (_endpos_body_, _startpos_arg_and_pos_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1023 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkmod ~loc:_sloc _1 )
+# 21870 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1565 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 21876 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = mty;
+          MenhirLib.EngineTypes.startp = _startpos_mty_;
+          MenhirLib.EngineTypes.endp = _endpos_mty_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let mty : (Parsetree.module_type) = Obj.magic mty in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_mty_ in
+        let _v : (Parsetree.module_type) = 
+# 1808 "src/ocaml/preprocess/parser_raw.mly"
+      ( mty )
+# 21908 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = body;
+          MenhirLib.EngineTypes.startp = _startpos_body_;
+          MenhirLib.EngineTypes.endp = _endpos_body_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = arg_and_pos;
+            MenhirLib.EngineTypes.startp = _startpos_arg_and_pos_;
+            MenhirLib.EngineTypes.endp = _endpos_arg_and_pos_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let body : (Parsetree.module_type) = Obj.magic body in
+        let arg_and_pos : (Lexing.position * Parsetree.functor_parameter) = Obj.magic arg_and_pos in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_arg_and_pos_ in
+        let _endpos = _endpos_body_ in
+        let _v : (Parsetree.module_type) = let _1 =
+          let _1 = 
+# 1811 "src/ocaml/preprocess/parser_raw.mly"
+        ( let (_, arg) = arg_and_pos in
+          Pmty_functor(arg, body) )
+# 21942 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let (_endpos__1_, _startpos__1_) = (_endpos_body_, _startpos_arg_and_pos_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1025 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkmty ~loc:_sloc _1 )
+# 21951 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1814 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 21957 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = s;
+            MenhirLib.EngineTypes.startp = _startpos_s_;
+            MenhirLib.EngineTypes.endp = _endpos_s_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : unit = Obj.magic _4 in
+        let s : (Parsetree.structure) = Obj.magic s in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (Parsetree.module_expr) = let attrs =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 22005 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__4_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 1385 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkmod ~loc:_sloc ~attrs (Pmod_structure s) )
+# 22014 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = me;
+          MenhirLib.EngineTypes.startp = _startpos_me_;
+          MenhirLib.EngineTypes.endp = _endpos_me_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = args;
+              MenhirLib.EngineTypes.startp = _startpos_args_;
+              MenhirLib.EngineTypes.endp = _endpos_args_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined1;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let me : (Parsetree.module_expr) = Obj.magic me in
+        let _4 : unit = Obj.magic _4 in
+        let args : ((Lexing.position * Parsetree.functor_parameter) list) = Obj.magic args in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_me_ in
+        let _v : (Parsetree.module_expr) = let attrs =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 22069 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_me_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 1391 "src/ocaml/preprocess/parser_raw.mly"
+      ( wrap_mod_attrs ~loc:_sloc attrs (
+          List.fold_left (fun acc (startpos, arg) ->
+            mkmod ~loc:(startpos, _endpos) (Pmod_functor (arg, acc))
+          ) me args
+        ) )
+# 22082 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = me;
+          MenhirLib.EngineTypes.startp = _startpos_me_;
+          MenhirLib.EngineTypes.endp = _endpos_me_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let me : (Parsetree.module_expr) = Obj.magic me in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_me_ in
+        let _endpos = _endpos_me_ in
+        let _v : (Parsetree.module_expr) = 
+# 1397 "src/ocaml/preprocess/parser_raw.mly"
+      ( me )
+# 22107 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = attr;
+          MenhirLib.EngineTypes.startp = _startpos_attr_;
+          MenhirLib.EngineTypes.endp = _endpos_attr_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = me;
+            MenhirLib.EngineTypes.startp = _startpos_me_;
+            MenhirLib.EngineTypes.endp = _endpos_me_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let attr : (Parsetree.attribute) = Obj.magic attr in
+        let me : (Parsetree.module_expr) = Obj.magic me in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_me_ in
+        let _endpos = _endpos_attr_ in
+        let _v : (Parsetree.module_expr) = 
+# 1399 "src/ocaml/preprocess/parser_raw.mly"
+      ( Mod.attr me attr )
+# 22139 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.module_expr) = let _1 =
+          let _1 =
+            let x =
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 22170 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 1403 "src/ocaml/preprocess/parser_raw.mly"
+        ( Pmod_ident x )
+# 22176 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1023 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkmod ~loc:_sloc _1 )
+# 22185 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1419 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 22191 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = me2;
+          MenhirLib.EngineTypes.startp = _startpos_me2_;
+          MenhirLib.EngineTypes.endp = _endpos_me2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = me1;
+            MenhirLib.EngineTypes.startp = _startpos_me1_;
+            MenhirLib.EngineTypes.endp = _endpos_me1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let me2 : (Parsetree.module_expr) = Obj.magic me2 in
+        let me1 : (Parsetree.module_expr) = Obj.magic me1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_me1_ in
+        let _endpos = _endpos_me2_ in
+        let _v : (Parsetree.module_expr) = let _1 =
+          let _1 = 
+# 1406 "src/ocaml/preprocess/parser_raw.mly"
+        ( Pmod_apply(me1, me2) )
+# 22224 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let (_endpos__1_, _startpos__1_) = (_endpos_me2_, _startpos_me1_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1023 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkmod ~loc:_sloc _1 )
+# 22233 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1419 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 22239 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = me1;
+              MenhirLib.EngineTypes.startp = _startpos_me1_;
+              MenhirLib.EngineTypes.endp = _endpos_me1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let me1 : (Parsetree.module_expr) = Obj.magic me1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_me1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.module_expr) = let _1 =
+          let _1 =
+            let _endpos = _endpos__3_ in
+            let _symbolstartpos = _startpos_me1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 1409 "src/ocaml/preprocess/parser_raw.mly"
+        ( (* TODO review mkmod location *)
+          Pmod_apply(me1, mkmod ~loc:_sloc (Pmod_structure [])) )
+# 22284 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos__3_, _startpos_me1_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1023 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkmod ~loc:_sloc _1 )
+# 22294 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1419 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 22300 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = ex;
+          MenhirLib.EngineTypes.startp = _startpos_ex_;
+          MenhirLib.EngineTypes.endp = _endpos_ex_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let ex : (Parsetree.extension) = Obj.magic ex in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_ex_ in
+        let _endpos = _endpos_ex_ in
+        let _v : (Parsetree.module_expr) = let _1 =
+          let _1 = 
+# 1413 "src/ocaml/preprocess/parser_raw.mly"
+        ( Pmod_extension ex )
+# 22326 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let (_endpos__1_, _startpos__1_) = (_endpos_ex_, _startpos_ex_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1023 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkmod ~loc:_sloc _1 )
+# 22335 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1419 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 22341 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.module_expr) = let _1 =
+          let _1 =
+            let _endpos = _endpos__1_ in
+            let _startpos = _startpos__1_ in
+            let _loc = (_startpos, _endpos) in
+            
+# 1416 "src/ocaml/preprocess/parser_raw.mly"
+        ( let id = mkrhs Ast_helper.hole_txt _loc in
+          Pmod_extension (id, PStr []) )
+# 22372 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1023 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkmod ~loc:_sloc _1 )
+# 22381 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1419 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 22387 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let x : (
+# 839 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 22408 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos_x_ in
+        let _v : (string option) = 
+# 1368 "src/ocaml/preprocess/parser_raw.mly"
+      ( Some x )
+# 22416 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string option) = 
+# 1371 "src/ocaml/preprocess/parser_raw.mly"
+      ( None )
+# 22441 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined4;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined4_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined3;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _5;
+              MenhirLib.EngineTypes.startp = _startpos__5_;
+              MenhirLib.EngineTypes.endp = _endpos__5_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = ext;
+                    MenhirLib.EngineTypes.startp = _startpos_ext_;
+                    MenhirLib.EngineTypes.endp = _endpos_ext_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = _1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined4 : (Parsetree.attributes) = Obj.magic _1_inlined4 in
+        let _1_inlined3 : (Longident.t) = Obj.magic _1_inlined3 in
+        let _5 : unit = Obj.magic _5 in
+        let _1_inlined2 : (
+# 839 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 22501 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined4_ in
+        let _v : (Parsetree.module_substitution * string Location.loc option) = let attrs2 =
+          let _1 = _1_inlined4 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 22514 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_attrs2_ = _endpos__1_inlined4_ in
+        let body =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 22526 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let uid =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 22537 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let attrs1 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 22545 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_attrs2_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 1844 "src/ocaml/preprocess/parser_raw.mly"
+  (
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc _sloc in
+    let docs = symbol_docs _sloc in
+    Ms.mk uid body ~attrs ~loc ~docs, ext
+  )
+# 22559 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = s;
+            MenhirLib.EngineTypes.startp = _startpos_s_;
+            MenhirLib.EngineTypes.endp = _endpos_s_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : unit = Obj.magic _4 in
+        let s : (Parsetree.signature) = Obj.magic s in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (Parsetree.module_type) = let attrs =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 22607 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__4_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 1690 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkmty ~loc:_sloc ~attrs (Pmty_signature s) )
+# 22616 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = mty;
+          MenhirLib.EngineTypes.startp = _startpos_mty_;
+          MenhirLib.EngineTypes.endp = _endpos_mty_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = args;
+              MenhirLib.EngineTypes.startp = _startpos_args_;
+              MenhirLib.EngineTypes.endp = _endpos_args_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined1;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let mty : (Parsetree.module_type) = Obj.magic mty in
+        let _4 : unit = Obj.magic _4 in
+        let args : ((Lexing.position * Parsetree.functor_parameter) list) = Obj.magic args in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_mty_ in
+        let _v : (Parsetree.module_type) = let attrs =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 22671 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_mty_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 1698 "src/ocaml/preprocess/parser_raw.mly"
+      ( wrap_mty_attrs ~loc:_sloc attrs (
+          List.fold_left (fun acc (startpos, arg) ->
+            mkmty ~loc:(startpos, _endpos) (Pmty_functor (arg, acc))
+          ) mty args
+        ) )
+# 22684 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : (Parsetree.module_expr) = Obj.magic _5 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.module_type) = let _4 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 22739 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__5_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 1704 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkmty ~loc:_sloc ~attrs:_4 (Pmty_typeof _5) )
+# 22748 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (Parsetree.module_type) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.module_type) = 
+# 1706 "src/ocaml/preprocess/parser_raw.mly"
+      ( _2 )
+# 22787 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.attribute) = Obj.magic _2 in
+        let _1 : (Parsetree.module_type) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.module_type) = 
+# 1712 "src/ocaml/preprocess/parser_raw.mly"
+      ( Mty.attr _1 _2 )
+# 22819 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.module_type) = let _1 =
+          let _1 =
+            let _1 =
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 22850 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 1715 "src/ocaml/preprocess/parser_raw.mly"
+        ( Pmty_ident _1 )
+# 22856 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1025 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkmty ~loc:_sloc _1 )
+# 22865 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1726 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 22871 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.module_type) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.module_type) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.module_type) = let _1 =
+          let _1 = 
+# 1718 "src/ocaml/preprocess/parser_raw.mly"
+        ( Pmty_functor(Named (mknoloc None, _1), _3) )
+# 22911 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos__3_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1025 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkmty ~loc:_sloc _1 )
+# 22920 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1726 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 22926 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.with_constraint list) = Obj.magic xs in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.module_type) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.module_type) = let _1 =
+          let _1 =
+            let _3 =
+              let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 22968 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              
+# 1114 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 22973 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 1720 "src/ocaml/preprocess/parser_raw.mly"
+        ( Pmty_with(_1, _3) )
+# 22979 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos_xs_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1025 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkmty ~loc:_sloc _1 )
+# 22989 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1726 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 22995 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.extension) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.module_type) = let _1 =
+          let _1 = 
+# 1724 "src/ocaml/preprocess/parser_raw.mly"
+        ( Pmty_extension _1 )
+# 23021 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1025 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkmty ~loc:_sloc _1 )
+# 23029 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1726 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 23035 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined3;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = typ;
+            MenhirLib.EngineTypes.startp = _startpos_typ_;
+            MenhirLib.EngineTypes.endp = _endpos_typ_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined2;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined1;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = ext;
+                  MenhirLib.EngineTypes.startp = _startpos_ext_;
+                  MenhirLib.EngineTypes.endp = _endpos_ext_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _2;
+                    MenhirLib.EngineTypes.startp = _startpos__2_;
+                    MenhirLib.EngineTypes.endp = _endpos__2_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = _1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let typ : (Parsetree.module_type option) = Obj.magic typ in
+        let _1_inlined2 : (string) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined3_ in
+        let _v : (Parsetree.module_type_declaration * string Location.loc option) = let attrs2 =
+          let _1 = _1_inlined3 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 23104 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_attrs2_ = _endpos__1_inlined3_ in
+        let id =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 23116 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let attrs1 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 23124 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_attrs2_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 1636 "src/ocaml/preprocess/parser_raw.mly"
+  (
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc _sloc in
+    let docs = symbol_docs _sloc in
+    Mtd.mk id ?typ ~attrs ~loc ~docs, ext
+  )
+# 23138 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined3;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = typ;
+            MenhirLib.EngineTypes.startp = _startpos_typ_;
+            MenhirLib.EngineTypes.endp = _endpos_typ_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _6;
+              MenhirLib.EngineTypes.startp = _startpos__6_;
+              MenhirLib.EngineTypes.endp = _endpos__6_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = ext;
+                    MenhirLib.EngineTypes.startp = _startpos_ext_;
+                    MenhirLib.EngineTypes.endp = _endpos_ext_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _2;
+                      MenhirLib.EngineTypes.startp = _startpos__2_;
+                      MenhirLib.EngineTypes.endp = _endpos__2_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _menhir_s;
+                        MenhirLib.EngineTypes.semv = _1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_;
+                        MenhirLib.EngineTypes.next = _menhir_stack;
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let typ : (Parsetree.module_type) = Obj.magic typ in
+        let _6 : unit = Obj.magic _6 in
+        let _1_inlined2 : (string) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined3_ in
+        let _v : (Parsetree.module_type_declaration * string Location.loc option) = let attrs2 =
+          let _1 = _1_inlined3 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 23214 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_attrs2_ = _endpos__1_inlined3_ in
+        let id =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 23226 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let attrs1 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 23234 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_attrs2_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 1902 "src/ocaml/preprocess/parser_raw.mly"
+  (
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc _sloc in
+    let docs = symbol_docs _sloc in
+    Mtd.mk id ~typ ~attrs ~loc ~docs, ext
+  )
+# 23248 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Longident.t) = 
+# 3784 "src/ocaml/preprocess/parser_raw.mly"
+                                          ( _1 )
+# 23273 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Asttypes.mutable_flag) = 
+# 3864 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Immutable )
+# 23291 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Asttypes.mutable_flag) = 
+# 3865 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Mutable )
+# 23316 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = 
+# 3873 "src/ocaml/preprocess/parser_raw.mly"
+      ( Immutable, Concrete )
+# 23334 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = 
+# 3875 "src/ocaml/preprocess/parser_raw.mly"
+      ( Mutable, Concrete )
+# 23359 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = 
+# 3877 "src/ocaml/preprocess/parser_raw.mly"
+      ( Immutable, Virtual )
+# 23384 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = 
+# 3880 "src/ocaml/preprocess/parser_raw.mly"
+      ( Mutable, Virtual )
+# 23416 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = 
+# 3880 "src/ocaml/preprocess/parser_raw.mly"
+      ( Mutable, Virtual )
+# 23448 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (string) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (string) = 
+# 3835 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _2 )
+# 23480 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 23501 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string Location.loc list) = let x =
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 23513 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 221 "<standard.mly>"
+    ( [ x ] )
+# 23519 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let xs : (string Location.loc list) = Obj.magic xs in
+        let _1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 23547 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (string Location.loc list) = let x =
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 23559 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 223 "<standard.mly>"
+    ( x :: xs )
+# 23565 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = s;
+          MenhirLib.EngineTypes.startp = _startpos_s_;
+          MenhirLib.EngineTypes.endp = _endpos_s_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let s : (
+# 825 "src/ocaml/preprocess/parser_raw.mly"
+       (string * Location.t * string option)
+# 23586 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic s in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_s_ in
+        let _endpos = _endpos_s_ in
+        let _v : (string list) = let x = 
+# 3831 "src/ocaml/preprocess/parser_raw.mly"
+    ( let body, _, _ = s in body )
+# 23594 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 221 "<standard.mly>"
+    ( [ x ] )
+# 23599 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = s;
+            MenhirLib.EngineTypes.startp = _startpos_s_;
+            MenhirLib.EngineTypes.endp = _endpos_s_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let xs : (string list) = Obj.magic xs in
+        let s : (
+# 825 "src/ocaml/preprocess/parser_raw.mly"
+       (string * Location.t * string option)
+# 23627 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic s in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_s_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (string list) = let x = 
+# 3831 "src/ocaml/preprocess/parser_raw.mly"
+    ( let body, _, _ = s in body )
+# 23635 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 223 "<standard.mly>"
+    ( x :: xs )
+# 23640 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = ty;
+          MenhirLib.EngineTypes.startp = _startpos_ty_;
+          MenhirLib.EngineTypes.endp = _endpos_ty_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let ty : (Parsetree.core_type) = Obj.magic ty in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_ty_ in
+        let _endpos = _endpos_ty_ in
+        let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = 
+# 3860 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Public )
+# 23665 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3147 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Ptype_abstract, priv, Some ty) )
+# 23670 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = ty;
+          MenhirLib.EngineTypes.startp = _startpos_ty_;
+          MenhirLib.EngineTypes.endp = _endpos_ty_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let ty : (Parsetree.core_type) = Obj.magic ty in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_ty_ in
+        let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = 
+# 3861 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Private )
+# 23702 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3147 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Ptype_abstract, priv, Some ty) )
+# 23707 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = cs;
+          MenhirLib.EngineTypes.startp = _startpos_cs_;
+          MenhirLib.EngineTypes.endp = _endpos_cs_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let cs : (Parsetree.constructor_declaration list) = Obj.magic cs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_cs_ in
+        let _endpos = _endpos_cs_ in
+        let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = 
+# 3860 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Public )
+# 23732 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let oty =
+          let _1 = 
+# 124 "<standard.mly>"
+    ( None )
+# 23738 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          
+# 3163 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 23743 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3151 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Ptype_variant cs, priv, oty) )
+# 23749 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = cs;
+          MenhirLib.EngineTypes.startp = _startpos_cs_;
+          MenhirLib.EngineTypes.endp = _endpos_cs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let cs : (Parsetree.constructor_declaration list) = Obj.magic cs in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_cs_ in
+        let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = 
+# 3861 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Private )
+# 23781 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let oty =
+          let _1 = 
+# 124 "<standard.mly>"
+    ( None )
+# 23787 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          
+# 3163 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 23792 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3151 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Ptype_variant cs, priv, oty) )
+# 23798 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = cs;
+          MenhirLib.EngineTypes.startp = _startpos_cs_;
+          MenhirLib.EngineTypes.endp = _endpos_cs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = x;
+              MenhirLib.EngineTypes.startp = _startpos_x_;
+              MenhirLib.EngineTypes.endp = _endpos_x_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let cs : (Parsetree.constructor_declaration list) = Obj.magic cs in
+        let _2 : unit = Obj.magic _2 in
+        let x : (Parsetree.core_type) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos_cs_ in
+        let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = 
+# 3860 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Public )
+# 23837 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let oty =
+          let _1 =
+            let x = 
+# 191 "<standard.mly>"
+    ( x )
+# 23844 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 126 "<standard.mly>"
+    ( Some x )
+# 23849 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 3163 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 23855 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3151 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Ptype_variant cs, priv, oty) )
+# 23861 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = cs;
+          MenhirLib.EngineTypes.startp = _startpos_cs_;
+          MenhirLib.EngineTypes.endp = _endpos_cs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = x;
+                MenhirLib.EngineTypes.startp = _startpos_x_;
+                MenhirLib.EngineTypes.endp = _endpos_x_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let cs : (Parsetree.constructor_declaration list) = Obj.magic cs in
+        let _1 : unit = Obj.magic _1 in
+        let _2 : unit = Obj.magic _2 in
+        let x : (Parsetree.core_type) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos_cs_ in
+        let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = 
+# 3861 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Private )
+# 23907 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let oty =
+          let _1 =
+            let x = 
+# 191 "<standard.mly>"
+    ( x )
+# 23914 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 126 "<standard.mly>"
+    ( Some x )
+# 23919 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 3163 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 23925 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3151 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Ptype_variant cs, priv, oty) )
+# 23931 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__3_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = 
+# 3860 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Public )
+# 23956 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let oty =
+          let _1 = 
+# 124 "<standard.mly>"
+    ( None )
+# 23962 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          
+# 3163 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 23967 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3155 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Ptype_open, priv, oty) )
+# 23973 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = 
+# 3861 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Private )
+# 24005 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let oty =
+          let _1 = 
+# 124 "<standard.mly>"
+    ( None )
+# 24011 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          
+# 3163 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 24016 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3155 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Ptype_open, priv, oty) )
+# 24022 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = x;
+              MenhirLib.EngineTypes.startp = _startpos_x_;
+              MenhirLib.EngineTypes.endp = _endpos_x_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let x : (Parsetree.core_type) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = 
+# 3860 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Public )
+# 24061 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let oty =
+          let _1 =
+            let x = 
+# 191 "<standard.mly>"
+    ( x )
+# 24068 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 126 "<standard.mly>"
+    ( Some x )
+# 24073 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 3163 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 24079 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3155 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Ptype_open, priv, oty) )
+# 24085 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = x;
+                MenhirLib.EngineTypes.startp = _startpos_x_;
+                MenhirLib.EngineTypes.endp = _endpos_x_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _1 : unit = Obj.magic _1 in
+        let _2 : unit = Obj.magic _2 in
+        let x : (Parsetree.core_type) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = 
+# 3861 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Private )
+# 24131 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let oty =
+          let _1 =
+            let x = 
+# 191 "<standard.mly>"
+    ( x )
+# 24138 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 126 "<standard.mly>"
+    ( Some x )
+# 24143 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 3163 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 24149 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3155 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Ptype_open, priv, oty) )
+# 24155 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = ls;
+            MenhirLib.EngineTypes.startp = _startpos_ls_;
+            MenhirLib.EngineTypes.endp = _endpos_ls_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let ls : (Parsetree.label_declaration list) = Obj.magic ls in
+        let _3 : unit = Obj.magic _3 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__3_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = 
+# 3860 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Public )
+# 24194 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let oty =
+          let _1 = 
+# 124 "<standard.mly>"
+    ( None )
+# 24200 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          
+# 3163 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 24205 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3159 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Ptype_record ls, priv, oty) )
+# 24211 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = ls;
+            MenhirLib.EngineTypes.startp = _startpos_ls_;
+            MenhirLib.EngineTypes.endp = _endpos_ls_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let ls : (Parsetree.label_declaration list) = Obj.magic ls in
+        let _3 : unit = Obj.magic _3 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = 
+# 3861 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Private )
+# 24257 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let oty =
+          let _1 = 
+# 124 "<standard.mly>"
+    ( None )
+# 24263 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          
+# 3163 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 24268 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3159 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Ptype_record ls, priv, oty) )
+# 24274 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = ls;
+            MenhirLib.EngineTypes.startp = _startpos_ls_;
+            MenhirLib.EngineTypes.endp = _endpos_ls_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = x;
+                  MenhirLib.EngineTypes.startp = _startpos_x_;
+                  MenhirLib.EngineTypes.endp = _endpos_x_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let ls : (Parsetree.label_declaration list) = Obj.magic ls in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let x : (Parsetree.core_type) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = 
+# 3860 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Public )
+# 24327 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let oty =
+          let _1 =
+            let x = 
+# 191 "<standard.mly>"
+    ( x )
+# 24334 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 126 "<standard.mly>"
+    ( Some x )
+# 24339 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 3163 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 24345 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3159 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Ptype_record ls, priv, oty) )
+# 24351 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = ls;
+            MenhirLib.EngineTypes.startp = _startpos_ls_;
+            MenhirLib.EngineTypes.endp = _endpos_ls_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _2;
+                  MenhirLib.EngineTypes.startp = _startpos__2_;
+                  MenhirLib.EngineTypes.endp = _endpos__2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = x;
+                    MenhirLib.EngineTypes.startp = _startpos_x_;
+                    MenhirLib.EngineTypes.endp = _endpos_x_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let ls : (Parsetree.label_declaration list) = Obj.magic ls in
+        let _3 : unit = Obj.magic _3 in
+        let _1 : unit = Obj.magic _1 in
+        let _2 : unit = Obj.magic _2 in
+        let x : (Parsetree.core_type) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = 
+# 3861 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Private )
+# 24411 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let oty =
+          let _1 =
+            let x = 
+# 191 "<standard.mly>"
+    ( x )
+# 24418 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 126 "<standard.mly>"
+    ( Some x )
+# 24423 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 3163 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 24429 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3159 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Ptype_record ls, priv, oty) )
+# 24435 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined2;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = me;
+            MenhirLib.EngineTypes.startp = _startpos_me_;
+            MenhirLib.EngineTypes.endp = _endpos_me_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = ext;
+                MenhirLib.EngineTypes.startp = _startpos_ext_;
+                MenhirLib.EngineTypes.endp = _endpos_ext_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let me : (Parsetree.module_expr) = Obj.magic me in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined2_ in
+        let _v : (Parsetree.module_expr Parsetree.open_infos * string Location.loc option) = let attrs2 =
+          let _1 = _1_inlined2 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 24490 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_attrs2_ = _endpos__1_inlined2_ in
+        let attrs1 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 24499 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let override = 
+# 3907 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Fresh )
+# 24505 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let _endpos = _endpos_attrs2_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 1655 "src/ocaml/preprocess/parser_raw.mly"
+  (
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc _sloc in
+    let docs = symbol_docs _sloc in
+    Opn.mk me ~override ~attrs ~loc ~docs, ext
+  )
+# 24518 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined3;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = me;
+            MenhirLib.EngineTypes.startp = _startpos_me_;
+            MenhirLib.EngineTypes.endp = _endpos_me_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined2;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = ext;
+                MenhirLib.EngineTypes.startp = _startpos_ext_;
+                MenhirLib.EngineTypes.endp = _endpos_ext_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let me : (Parsetree.module_expr) = Obj.magic me in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1_inlined1 : unit = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined3_ in
+        let _v : (Parsetree.module_expr Parsetree.open_infos * string Location.loc option) = let attrs2 =
+          let _1 = _1_inlined3 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 24580 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_attrs2_ = _endpos__1_inlined3_ in
+        let attrs1 =
+          let _1 = _1_inlined2 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 24589 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let override =
+          let _1 = _1_inlined1 in
+          
+# 3908 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Override )
+# 24597 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_attrs2_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 1655 "src/ocaml/preprocess/parser_raw.mly"
+  (
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc _sloc in
+    let docs = symbol_docs _sloc in
+    Opn.mk me ~override ~attrs ~loc ~docs, ext
+  )
+# 24611 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined3;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined2;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = ext;
+                MenhirLib.EngineTypes.startp = _startpos_ext_;
+                MenhirLib.EngineTypes.endp = _endpos_ext_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let _1_inlined2 : (Longident.t) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined3_ in
+        let _v : (Longident.t Location.loc Parsetree.open_infos * string Location.loc option) = let attrs2 =
+          let _1 = _1_inlined3 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 24666 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_attrs2_ = _endpos__1_inlined3_ in
+        let id =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 24678 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let attrs1 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 24686 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let override = 
+# 3907 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Fresh )
+# 24692 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let _endpos = _endpos_attrs2_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 1670 "src/ocaml/preprocess/parser_raw.mly"
+  (
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc _sloc in
+    let docs = symbol_docs _sloc in
+    Opn.mk id ~override ~attrs ~loc ~docs, ext
+  )
+# 24705 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined4;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined4_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined3;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined2;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = ext;
+                MenhirLib.EngineTypes.startp = _startpos_ext_;
+                MenhirLib.EngineTypes.endp = _endpos_ext_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined4 : (Parsetree.attributes) = Obj.magic _1_inlined4 in
+        let _1_inlined3 : (Longident.t) = Obj.magic _1_inlined3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1_inlined1 : unit = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined4_ in
+        let _v : (Longident.t Location.loc Parsetree.open_infos * string Location.loc option) = let attrs2 =
+          let _1 = _1_inlined4 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 24767 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_attrs2_ = _endpos__1_inlined4_ in
+        let id =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 24779 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let attrs1 =
+          let _1 = _1_inlined2 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 24787 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let override =
+          let _1 = _1_inlined1 in
+          
+# 3908 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Override )
+# 24795 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_attrs2_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 1670 "src/ocaml/preprocess/parser_raw.mly"
+  (
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc _sloc in
+    let docs = symbol_docs _sloc in
+    Opn.mk id ~override ~attrs ~loc ~docs, ext
+  )
+# 24809 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 811 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 24830 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3699 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 24838 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 769 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 24859 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3700 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 24867 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 770 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 24888 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3701 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 24896 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (string) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (
+# 768 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 24938 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (string) = 
+# 3702 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( "."^ _1 ^"(" ^ _3 ^ ")" )
+# 24946 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (string) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (
+# 768 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 24995 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (string) = 
+# 3703 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( "."^ _1 ^ "(" ^ _3 ^ ")<-" )
+# 25003 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (string) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (
+# 768 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 25045 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (string) = 
+# 3704 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( "."^ _1 ^"[" ^ _3 ^ "]" )
+# 25053 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (string) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (
+# 768 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 25102 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (string) = 
+# 3705 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( "."^ _1 ^ "[" ^ _3 ^ "]<-" )
+# 25110 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (string) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (
+# 768 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 25152 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (string) = 
+# 3706 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( "."^ _1 ^"{" ^ _3 ^ "}" )
+# 25160 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (string) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (
+# 768 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 25209 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (string) = 
+# 3707 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( "."^ _1 ^ "{" ^ _3 ^ "}<-" )
+# 25217 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 822 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 25238 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3708 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 25246 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3709 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( "!" )
+# 25271 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = op;
+          MenhirLib.EngineTypes.startp = _startpos_op_;
+          MenhirLib.EngineTypes.endp = _endpos_op_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let op : (
+# 763 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 25292 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic op in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_op_ in
+        let _endpos = _endpos_op_ in
+        let _v : (string) = let _1 = 
+# 3713 "src/ocaml/preprocess/parser_raw.mly"
+                  ( op )
+# 25300 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3710 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 25305 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = op;
+          MenhirLib.EngineTypes.startp = _startpos_op_;
+          MenhirLib.EngineTypes.endp = _endpos_op_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let op : (
+# 764 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 25326 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic op in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_op_ in
+        let _endpos = _endpos_op_ in
+        let _v : (string) = let _1 = 
+# 3714 "src/ocaml/preprocess/parser_raw.mly"
+                  ( op )
+# 25334 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3710 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 25339 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = op;
+          MenhirLib.EngineTypes.startp = _startpos_op_;
+          MenhirLib.EngineTypes.endp = _endpos_op_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let op : (
+# 765 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 25360 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic op in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_op_ in
+        let _endpos = _endpos_op_ in
+        let _v : (string) = let _1 = 
+# 3715 "src/ocaml/preprocess/parser_raw.mly"
+                  ( op )
+# 25368 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3710 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 25373 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = op;
+          MenhirLib.EngineTypes.startp = _startpos_op_;
+          MenhirLib.EngineTypes.endp = _endpos_op_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let op : (
+# 766 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 25394 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic op in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_op_ in
+        let _endpos = _endpos_op_ in
+        let _v : (string) = let _1 = 
+# 3716 "src/ocaml/preprocess/parser_raw.mly"
+                  ( op )
+# 25402 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3710 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 25407 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = op;
+          MenhirLib.EngineTypes.startp = _startpos_op_;
+          MenhirLib.EngineTypes.endp = _endpos_op_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let op : (
+# 767 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 25428 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic op in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_op_ in
+        let _endpos = _endpos_op_ in
+        let _v : (string) = let _1 = 
+# 3717 "src/ocaml/preprocess/parser_raw.mly"
+                  ( op )
+# 25436 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3710 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 25441 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = let _1 = 
+# 3718 "src/ocaml/preprocess/parser_raw.mly"
+                   ("+")
+# 25466 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3710 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 25471 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = let _1 = 
+# 3719 "src/ocaml/preprocess/parser_raw.mly"
+                  ("+.")
+# 25496 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3710 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 25501 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = let _1 = 
+# 3720 "src/ocaml/preprocess/parser_raw.mly"
+                  ("+=")
+# 25526 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3710 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 25531 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = let _1 = 
+# 3721 "src/ocaml/preprocess/parser_raw.mly"
+                   ("-")
+# 25556 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3710 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 25561 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = let _1 = 
+# 3722 "src/ocaml/preprocess/parser_raw.mly"
+                  ("-.")
+# 25586 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3710 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 25591 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = let _1 = 
+# 3723 "src/ocaml/preprocess/parser_raw.mly"
+                   ("*")
+# 25616 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3710 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 25621 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = let _1 = 
+# 3724 "src/ocaml/preprocess/parser_raw.mly"
+                   ("%")
+# 25646 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3710 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 25651 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = let _1 = 
+# 3725 "src/ocaml/preprocess/parser_raw.mly"
+                   ("=")
+# 25676 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3710 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 25681 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = let _1 = 
+# 3726 "src/ocaml/preprocess/parser_raw.mly"
+                   ("<")
+# 25706 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3710 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 25711 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = let _1 = 
+# 3727 "src/ocaml/preprocess/parser_raw.mly"
+                   (">")
+# 25736 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3710 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 25741 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = let _1 = 
+# 3728 "src/ocaml/preprocess/parser_raw.mly"
+                  ("or")
+# 25766 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3710 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 25771 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = let _1 = 
+# 3729 "src/ocaml/preprocess/parser_raw.mly"
+                  ("||")
+# 25796 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3710 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 25801 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = let _1 = 
+# 3730 "src/ocaml/preprocess/parser_raw.mly"
+                   ("&")
+# 25826 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3710 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 25831 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = let _1 = 
+# 3731 "src/ocaml/preprocess/parser_raw.mly"
+                  ("&&")
+# 25856 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3710 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 25861 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = let _1 = 
+# 3732 "src/ocaml/preprocess/parser_raw.mly"
+                  (":=")
+# 25886 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3710 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 25891 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (bool) = 
+# 3612 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( true )
+# 25916 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (bool) = 
+# 3613 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( false )
+# 25934 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (unit option) = 
+# 114 "<standard.mly>"
+    ( None )
+# 25952 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let x : unit = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos_x_ in
+        let _v : (unit option) = 
+# 116 "<standard.mly>"
+    ( Some x )
+# 25977 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (unit option) = 
+# 114 "<standard.mly>"
+    ( None )
+# 25995 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let x : unit = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos_x_ in
+        let _v : (unit option) = 
+# 116 "<standard.mly>"
+    ( Some x )
+# 26020 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (string Location.loc option) = 
+# 114 "<standard.mly>"
+    ( None )
+# 26038 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 26065 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (string Location.loc option) = let x =
+          let x =
+            let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 26080 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 183 "<standard.mly>"
+    ( x )
+# 26086 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 116 "<standard.mly>"
+    ( Some x )
+# 26092 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Parsetree.core_type option) = 
+# 114 "<standard.mly>"
+    ( None )
+# 26110 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let x : (Parsetree.core_type) = Obj.magic x in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_x_ in
+        let _v : (Parsetree.core_type option) = let x = 
+# 183 "<standard.mly>"
+    ( x )
+# 26142 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 116 "<standard.mly>"
+    ( Some x )
+# 26147 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Parsetree.expression option) = 
+# 114 "<standard.mly>"
+    ( None )
+# 26165 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let x : (Parsetree.expression) = Obj.magic x in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_x_ in
+        let _v : (Parsetree.expression option) = let x = 
+# 183 "<standard.mly>"
+    ( x )
+# 26197 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 116 "<standard.mly>"
+    ( Some x )
+# 26202 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Parsetree.module_type option) = 
+# 114 "<standard.mly>"
+    ( None )
+# 26220 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let x : (Parsetree.module_type) = Obj.magic x in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_x_ in
+        let _v : (Parsetree.module_type option) = let x = 
+# 183 "<standard.mly>"
+    ( x )
+# 26252 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 116 "<standard.mly>"
+    ( Some x )
+# 26257 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Parsetree.pattern option) = 
+# 114 "<standard.mly>"
+    ( None )
+# 26275 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let x : (Parsetree.pattern) = Obj.magic x in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_x_ in
+        let _v : (Parsetree.pattern option) = let x = 
+# 183 "<standard.mly>"
+    ( x )
+# 26307 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 116 "<standard.mly>"
+    ( Some x )
+# 26312 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Parsetree.expression option) = 
+# 114 "<standard.mly>"
+    ( None )
+# 26330 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let x : (Parsetree.expression) = Obj.magic x in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_x_ in
+        let _v : (Parsetree.expression option) = let x = 
+# 183 "<standard.mly>"
+    ( x )
+# 26362 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 116 "<standard.mly>"
+    ( Some x )
+# 26367 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : ((Parsetree.core_type option * Parsetree.core_type option) option) = 
+# 114 "<standard.mly>"
+    ( None )
+# 26385 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let x : (Parsetree.core_type option * Parsetree.core_type option) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos_x_ in
+        let _v : ((Parsetree.core_type option * Parsetree.core_type option) option) = 
+# 116 "<standard.mly>"
+    ( Some x )
+# 26410 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 804 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 26431 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3919 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 26439 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 26473 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (string) = 
+# 3920 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _2 )
+# 26482 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = mty;
+            MenhirLib.EngineTypes.startp = _startpos_mty_;
+            MenhirLib.EngineTypes.endp = _endpos_mty_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = me;
+                MenhirLib.EngineTypes.startp = _startpos_me_;
+                MenhirLib.EngineTypes.endp = _endpos_me_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let mty : (Parsetree.module_type) = Obj.magic mty in
+        let _3 : unit = Obj.magic _3 in
+        let me : (Parsetree.module_expr) = Obj.magic me in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.module_expr) = let _endpos = _endpos__5_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 1428 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkmod ~loc:_sloc (Pmod_constraint(me, mty)) )
+# 26538 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = me;
+            MenhirLib.EngineTypes.startp = _startpos_me_;
+            MenhirLib.EngineTypes.endp = _endpos_me_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let me : (Parsetree.module_expr) = Obj.magic me in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.module_expr) = 
+# 1435 "src/ocaml/preprocess/parser_raw.mly"
+      ( me (* TODO consider reloc *) )
+# 26577 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = e;
+            MenhirLib.EngineTypes.startp = _startpos_e_;
+            MenhirLib.EngineTypes.endp = _endpos_e_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let e : (Parsetree.expression) = Obj.magic e in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.module_expr) = let e = 
+# 1458 "src/ocaml/preprocess/parser_raw.mly"
+      ( e )
+# 26630 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let attrs =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 26637 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__5_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 1443 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) )
+# 26646 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined2;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__2_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__2_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = e;
+                MenhirLib.EngineTypes.startp = _startpos_e_;
+                MenhirLib.EngineTypes.endp = _endpos_e_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _2;
+                    MenhirLib.EngineTypes.startp = _startpos__2_;
+                    MenhirLib.EngineTypes.endp = _endpos__2_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = _1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let _1_inlined2 : (Parsetree.module_type) = Obj.magic _1_inlined2 in
+        let _2_inlined1 : unit = Obj.magic _2_inlined1 in
+        let e : (Parsetree.expression) = Obj.magic e in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.module_expr) = let e =
+          let (_endpos__1_, _startpos__1_, _1, _2) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2, _2_inlined1) in
+          let ty =
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 3587 "src/ocaml/preprocess/parser_raw.mly"
+      ( let (lid, cstrs, attrs) = package_type_of_module_type _1 in
+        let descr = Ptyp_package (lid, cstrs) in
+        mktyp ~loc:_sloc ~attrs descr )
+# 26721 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos_ty_ = _endpos__1_ in
+          let _endpos = _endpos_ty_ in
+          let _startpos = _startpos_e_ in
+          let _loc = (_startpos, _endpos) in
+          
+# 1460 "src/ocaml/preprocess/parser_raw.mly"
+      ( ghexp ~loc:_loc (Pexp_constraint (e, ty)) )
+# 26731 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let attrs =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 26739 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__5_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 1443 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) )
+# 26748 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined3;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _4;
+              MenhirLib.EngineTypes.startp = _startpos__4_;
+              MenhirLib.EngineTypes.endp = _endpos__4_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _2_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__2_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__2_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = e;
+                    MenhirLib.EngineTypes.startp = _startpos_e_;
+                    MenhirLib.EngineTypes.endp = _endpos_e_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _1_inlined1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = _2;
+                        MenhirLib.EngineTypes.startp = _startpos__2_;
+                        MenhirLib.EngineTypes.endp = _endpos__2_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _menhir_s;
+                          MenhirLib.EngineTypes.semv = _1;
+                          MenhirLib.EngineTypes.startp = _startpos__1_;
+                          MenhirLib.EngineTypes.endp = _endpos__1_;
+                          MenhirLib.EngineTypes.next = _menhir_stack;
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let _1_inlined3 : (Parsetree.module_type) = Obj.magic _1_inlined3 in
+        let _4 : unit = Obj.magic _4 in
+        let _1_inlined2 : (Parsetree.module_type) = Obj.magic _1_inlined2 in
+        let _2_inlined1 : unit = Obj.magic _2_inlined1 in
+        let e : (Parsetree.expression) = Obj.magic e in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.module_expr) = let e =
+          let (_endpos__1_inlined1_, _startpos__1_inlined1_, _endpos__1_, _startpos__1_, _1_inlined1, _1, _2) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined3, _1_inlined2, _2_inlined1) in
+          let ty2 =
+            let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 3587 "src/ocaml/preprocess/parser_raw.mly"
+      ( let (lid, cstrs, attrs) = package_type_of_module_type _1 in
+        let descr = Ptyp_package (lid, cstrs) in
+        mktyp ~loc:_sloc ~attrs descr )
+# 26838 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos_ty2_ = _endpos__1_inlined1_ in
+          let ty1 =
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 3587 "src/ocaml/preprocess/parser_raw.mly"
+      ( let (lid, cstrs, attrs) = package_type_of_module_type _1 in
+        let descr = Ptyp_package (lid, cstrs) in
+        mktyp ~loc:_sloc ~attrs descr )
+# 26851 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos_ty2_ in
+          let _startpos = _startpos_e_ in
+          let _loc = (_startpos, _endpos) in
+          
+# 1462 "src/ocaml/preprocess/parser_raw.mly"
+      ( ghexp ~loc:_loc (Pexp_coerce (e, Some ty1, ty2)) )
+# 26860 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let attrs =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 26868 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__5_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 1443 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) )
+# 26877 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined2;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__2_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__2_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = e;
+                MenhirLib.EngineTypes.startp = _startpos_e_;
+                MenhirLib.EngineTypes.endp = _endpos_e_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _2;
+                    MenhirLib.EngineTypes.startp = _startpos__2_;
+                    MenhirLib.EngineTypes.endp = _endpos__2_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = _1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let _1_inlined2 : (Parsetree.module_type) = Obj.magic _1_inlined2 in
+        let _2_inlined1 : unit = Obj.magic _2_inlined1 in
+        let e : (Parsetree.expression) = Obj.magic e in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.module_expr) = let e =
+          let (_endpos__1_, _startpos__1_, _1, _2) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2, _2_inlined1) in
+          let ty2 =
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 3587 "src/ocaml/preprocess/parser_raw.mly"
+      ( let (lid, cstrs, attrs) = package_type_of_module_type _1 in
+        let descr = Ptyp_package (lid, cstrs) in
+        mktyp ~loc:_sloc ~attrs descr )
+# 26952 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos_ty2_ = _endpos__1_ in
+          let _endpos = _endpos_ty2_ in
+          let _startpos = _startpos_e_ in
+          let _loc = (_startpos, _endpos) in
+          
+# 1464 "src/ocaml/preprocess/parser_raw.mly"
+      ( ghexp ~loc:_loc (Pexp_coerce (e, None, ty2)) )
+# 26962 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let attrs =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 26970 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__5_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 1443 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) )
+# 26979 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Longident.t) = 
+# 1340 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 27011 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Longident.t) = 
+# 1325 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 27043 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.core_type) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.core_type) = 
+# 1300 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 27075 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.expression) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.expression) = 
+# 1305 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 27107 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Longident.t) = 
+# 1330 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 27139 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Longident.t) = 
+# 1335 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 27171 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Longident.t) = 
+# 1315 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 27203 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.pattern) = 
+# 1310 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 27235 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Longident.t) = 
+# 1320 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 27267 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.pattern) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _endpos = _endpos__3_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _loc__2_ = (_startpos__2_, _endpos__2_) in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 2872 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkpat_cons ~loc:_sloc _loc__2_ (ghpat ~loc:_sloc (Ppat_tuple[_1;_3])) )
+# 27311 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2860 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 27317 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.attribute) = Obj.magic _2 in
+        let _1 : (Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.pattern) = let _1 = 
+# 2874 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pat.attr _1 _2 )
+# 27349 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 2860 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 27354 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.pattern) = let _1 = 
+# 2876 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 27379 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 2860 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 27384 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (string) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 =
+            let _1 =
+              let _3 =
+                let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+                let _endpos = _endpos__1_ in
+                let _symbolstartpos = _startpos__1_ in
+                let _sloc = (_symbolstartpos, _endpos) in
+                
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 27431 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 2879 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ppat_alias(_1, _3) )
+# 27437 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let _endpos__1_ = _endpos__1_inlined1_ in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 27447 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2890 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 27453 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2860 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 27459 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.pattern list) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 =
+            let _1 = 
+# 2883 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ppat_tuple(List.rev _1) )
+# 27486 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 27494 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2890 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 27500 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2860 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 27506 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.pattern) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 =
+            let _1 = 
+# 2887 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ppat_or(_1, _3) )
+# 27547 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let _endpos__1_ = _endpos__3_ in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 27556 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2890 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 27562 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2860 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 27568 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined2;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.pattern) = Obj.magic _3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.pattern) = let _2 =
+          let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+          let _2 =
+            let _1 = _1_inlined1 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 27618 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 27624 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__3_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2862 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkpat_attrs ~loc:_sloc (Ppat_exception _3) _2)
+# 27633 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.pattern) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.pattern list) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.pattern list) = 
+# 2993 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _3 :: _1 )
+# 27672 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.pattern) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.pattern list) = 
+# 2994 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( [_3; _1] )
+# 27711 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.pattern) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.pattern list) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.pattern list) = 
+# 2993 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _3 :: _1 )
+# 27750 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.pattern) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.pattern list) = 
+# 2994 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( [_3; _1] )
+# 27789 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.pattern) = 
+# 2895 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 27814 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.pattern) = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 =
+            let _1 =
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 27852 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2898 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ppat_construct(_1, Some ([], _2)) )
+# 27858 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__2_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 27868 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2904 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 27874 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = pat;
+          MenhirLib.EngineTypes.startp = _startpos_pat_;
+          MenhirLib.EngineTypes.endp = _endpos_pat_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _5;
+            MenhirLib.EngineTypes.startp = _startpos__5_;
+            MenhirLib.EngineTypes.endp = _endpos__5_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = xs;
+              MenhirLib.EngineTypes.startp = _startpos_xs_;
+              MenhirLib.EngineTypes.endp = _endpos_xs_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _3;
+                MenhirLib.EngineTypes.startp = _startpos__3_;
+                MenhirLib.EngineTypes.endp = _endpos__3_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _2;
+                  MenhirLib.EngineTypes.startp = _startpos__2_;
+                  MenhirLib.EngineTypes.endp = _endpos__2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let pat : (Parsetree.pattern) = Obj.magic pat in
+        let _5 : unit = Obj.magic _5 in
+        let xs : (string Location.loc list) = Obj.magic xs in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_pat_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 =
+            let newtypes = 
+# 2639 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 27936 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let constr =
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 27945 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2901 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ppat_construct(constr, Some (newtypes, pat)) )
+# 27951 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos_pat_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 27961 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2904 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 27967 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.pattern) = Obj.magic _2 in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 = 
+# 2903 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ppat_variant(_1, Some _2) )
+# 28000 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos__2_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 28009 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2904 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 28015 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined2;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.pattern) = Obj.magic _3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.pattern) = let _2 =
+          let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+          let _2 =
+            let _1 = _1_inlined1 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 28065 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 28071 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__3_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2906 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkpat_attrs ~loc:_sloc (Ppat_lazy _3) _2)
+# 28080 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.pattern) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _endpos = _endpos__3_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _loc__2_ = (_startpos__2_, _endpos__2_) in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 2872 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkpat_cons ~loc:_sloc _loc__2_ (ghpat ~loc:_sloc (Ppat_tuple[_1;_3])) )
+# 28124 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2867 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 28130 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.attribute) = Obj.magic _2 in
+        let _1 : (Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.pattern) = let _1 = 
+# 2874 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pat.attr _1 _2 )
+# 28162 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 2867 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 28167 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.pattern) = let _1 = 
+# 2876 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 28192 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 2867 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 28197 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (string) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 =
+            let _1 =
+              let _3 =
+                let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+                let _endpos = _endpos__1_ in
+                let _symbolstartpos = _startpos__1_ in
+                let _sloc = (_symbolstartpos, _endpos) in
+                
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 28244 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 2879 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ppat_alias(_1, _3) )
+# 28250 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let _endpos__1_ = _endpos__1_inlined1_ in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 28260 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2890 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 28266 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2867 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 28272 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.pattern list) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 =
+            let _1 = 
+# 2883 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ppat_tuple(List.rev _1) )
+# 28299 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 28307 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2890 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 28313 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2867 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 28319 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.pattern) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 =
+            let _1 = 
+# 2887 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ppat_or(_1, _3) )
+# 28360 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let _endpos__1_ = _endpos__3_ in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 28369 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2890 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 28375 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2867 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 28381 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 28402 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 =
+            let _1 =
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 28416 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2324 "src/ocaml/preprocess/parser_raw.mly"
+                        ( Ppat_var _1 )
+# 28422 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 28431 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2326 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 28437 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 = 
+# 2325 "src/ocaml/preprocess/parser_raw.mly"
+                        ( Ppat_any )
+# 28463 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 28471 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2326 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 28477 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.structure) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.payload) = 
+# 4031 "src/ocaml/preprocess/parser_raw.mly"
+              ( PStr _1 )
+# 28502 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.signature) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.payload) = 
+# 4032 "src/ocaml/preprocess/parser_raw.mly"
+                    ( PSig _2 )
+# 28534 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.core_type) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.payload) = 
+# 4033 "src/ocaml/preprocess/parser_raw.mly"
+                    ( PTyp _2 )
+# 28566 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.pattern) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.payload) = 
+# 4034 "src/ocaml/preprocess/parser_raw.mly"
+                     ( PPat (_2, None) )
+# 28598 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : (Parsetree.expression) = Obj.magic _4 in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (Parsetree.pattern) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (Parsetree.payload) = 
+# 4035 "src/ocaml/preprocess/parser_raw.mly"
+                                   ( PPat (_2, Some _4) )
+# 28644 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.core_type) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.core_type) = 
+# 3426 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 28669 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = xs;
+              MenhirLib.EngineTypes.startp = _startpos_xs_;
+              MenhirLib.EngineTypes.endp = _endpos_xs_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.core_type) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let xs : (string Location.loc list) = Obj.magic xs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xs_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 =
+            let _1 =
+              let _1 =
+                let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 28712 "src/ocaml/preprocess/parser_raw.ml"
+                 in
+                
+# 1082 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 28717 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 3418 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 28723 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 3422 "src/ocaml/preprocess/parser_raw.mly"
+    ( Ptyp_poly(_1, _3) )
+# 28729 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos__3_, _startpos_xs_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 28739 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3428 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 28745 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.core_type) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.core_type) = let _1 = 
+# 3457 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 28770 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3426 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 28775 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = xs;
+              MenhirLib.EngineTypes.startp = _startpos_xs_;
+              MenhirLib.EngineTypes.endp = _endpos_xs_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _1 : (Parsetree.core_type) = Obj.magic _1 in
+        let _2 : unit = Obj.magic _2 in
+        let xs : (string Location.loc list) = Obj.magic xs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xs_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 =
+            let _3 = 
+# 3457 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 28816 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let _1 =
+              let _1 =
+                let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 28823 "src/ocaml/preprocess/parser_raw.ml"
+                 in
+                
+# 1082 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 28828 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 3418 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 28834 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 3422 "src/ocaml/preprocess/parser_raw.mly"
+    ( Ptyp_poly(_1, _3) )
+# 28840 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _startpos__1_ = _startpos_xs_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 28850 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3428 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 28856 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (Parsetree.payload) = Obj.magic _3 in
+        let _2 : (string Location.loc) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (Parsetree.attribute) = let _endpos = _endpos__4_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3992 "src/ocaml/preprocess/parser_raw.mly"
+    ( Attr.mk ~loc:(make_loc _sloc) _2 _3 )
+# 28905 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined3;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = prim;
+            MenhirLib.EngineTypes.startp = _startpos_prim_;
+            MenhirLib.EngineTypes.endp = _endpos_prim_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _7;
+              MenhirLib.EngineTypes.startp = _startpos__7_;
+              MenhirLib.EngineTypes.endp = _endpos__7_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = ty;
+                MenhirLib.EngineTypes.startp = _startpos_ty_;
+                MenhirLib.EngineTypes.endp = _endpos_ty_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _5;
+                  MenhirLib.EngineTypes.startp = _startpos__5_;
+                  MenhirLib.EngineTypes.endp = _endpos__5_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1_inlined2;
+                    MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _1_inlined1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = ext;
+                        MenhirLib.EngineTypes.startp = _startpos_ext_;
+                        MenhirLib.EngineTypes.endp = _endpos_ext_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _menhir_s;
+                          MenhirLib.EngineTypes.semv = _1;
+                          MenhirLib.EngineTypes.startp = _startpos__1_;
+                          MenhirLib.EngineTypes.endp = _endpos__1_;
+                          MenhirLib.EngineTypes.next = _menhir_stack;
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let prim : (string list) = Obj.magic prim in
+        let _7 : unit = Obj.magic _7 in
+        let ty : (Parsetree.core_type) = Obj.magic ty in
+        let _5 : unit = Obj.magic _5 in
+        let _1_inlined2 : (string) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined3_ in
+        let _v : (Parsetree.value_description * string Location.loc option) = let attrs2 =
+          let _1 = _1_inlined3 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 28988 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_attrs2_ = _endpos__1_inlined3_ in
+        let id =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 29000 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let attrs1 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 29008 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_attrs2_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3057 "src/ocaml/preprocess/parser_raw.mly"
+    ( let attrs = attrs1 @ attrs2 in
+      let loc = make_loc _sloc in
+      let docs = symbol_docs _sloc in
+      Val.mk id ty ~prim ~attrs ~loc ~docs,
+      ext )
+# 29021 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Asttypes.private_flag) = let _1 = 
+# 3860 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Public )
+# 29039 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3857 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 29044 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Asttypes.private_flag) = let _1 = 
+# 3861 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Private )
+# 29069 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 3857 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 29074 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = 
+# 3883 "src/ocaml/preprocess/parser_raw.mly"
+                 ( Public, Concrete )
+# 29092 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = 
+# 3884 "src/ocaml/preprocess/parser_raw.mly"
+            ( Private, Concrete )
+# 29117 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = 
+# 3885 "src/ocaml/preprocess/parser_raw.mly"
+            ( Public, Virtual )
+# 29142 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = 
+# 3886 "src/ocaml/preprocess/parser_raw.mly"
+                    ( Private, Virtual )
+# 29174 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = 
+# 3887 "src/ocaml/preprocess/parser_raw.mly"
+                    ( Private, Virtual )
+# 29206 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Asttypes.rec_flag) = 
+# 3838 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Nonrecursive )
+# 29224 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Asttypes.rec_flag) = 
+# 3839 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Recursive )
+# 29249 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = fields;
+          MenhirLib.EngineTypes.startp = _startpos_fields_;
+          MenhirLib.EngineTypes.endp = _endpos_fields_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let fields : ((Longident.t Location.loc * Parsetree.expression) list) = Obj.magic fields in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_fields_ in
+        let _endpos = _endpos_fields_ in
+        let _v : (Parsetree.expression option *
+  (Longident.t Location.loc * Parsetree.expression) list) = let eo = 
+# 124 "<standard.mly>"
+    ( None )
+# 29275 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 2792 "src/ocaml/preprocess/parser_raw.mly"
+    ( eo, fields )
+# 29280 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = fields;
+          MenhirLib.EngineTypes.startp = _startpos_fields_;
+          MenhirLib.EngineTypes.endp = _endpos_fields_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = x;
+              MenhirLib.EngineTypes.startp = _startpos_x_;
+              MenhirLib.EngineTypes.endp = _endpos_x_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let fields : ((Longident.t Location.loc * Parsetree.expression) list) = Obj.magic fields in
+        let _2 : unit = Obj.magic _2 in
+        let x : (Parsetree.expression) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos_fields_ in
+        let _v : (Parsetree.expression option *
+  (Longident.t Location.loc * Parsetree.expression) list) = let eo =
+          let x = 
+# 191 "<standard.mly>"
+    ( x )
+# 29321 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          
+# 126 "<standard.mly>"
+    ( Some x )
+# 29326 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2792 "src/ocaml/preprocess/parser_raw.mly"
+    ( eo, fields )
+# 29332 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = d;
+          MenhirLib.EngineTypes.startp = _startpos_d_;
+          MenhirLib.EngineTypes.endp = _endpos_d_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let d : (Ocaml_parsing.Ast_helper.str * Parsetree.constructor_arguments *
+  Parsetree.core_type option * Parsetree.attributes * Location.t *
+  Ocaml_parsing.Docstrings.info) = Obj.magic d in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_d_ in
+        let _endpos = _endpos_d_ in
+        let _v : (Parsetree.constructor_declaration list) = let x = 
+# 3244 "src/ocaml/preprocess/parser_raw.mly"
+    (
+      let cid, args, res, attrs, loc, info = d in
+      Type.constructor cid ~args ?res ~attrs ~loc ~info
+    )
+# 29362 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 1192 "src/ocaml/preprocess/parser_raw.mly"
+      ( [x] )
+# 29367 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = d;
+          MenhirLib.EngineTypes.startp = _startpos_d_;
+          MenhirLib.EngineTypes.endp = _endpos_d_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let d : (Ocaml_parsing.Ast_helper.str * Parsetree.constructor_arguments *
+  Parsetree.core_type option * Parsetree.attributes * Location.t *
+  Ocaml_parsing.Docstrings.info) = Obj.magic d in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_d_ in
+        let _endpos = _endpos_d_ in
+        let _v : (Parsetree.constructor_declaration list) = let x = 
+# 3244 "src/ocaml/preprocess/parser_raw.mly"
+    (
+      let cid, args, res, attrs, loc, info = d in
+      Type.constructor cid ~args ?res ~attrs ~loc ~info
+    )
+# 29397 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 1195 "src/ocaml/preprocess/parser_raw.mly"
+      ( [x] )
+# 29402 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = d;
+          MenhirLib.EngineTypes.startp = _startpos_d_;
+          MenhirLib.EngineTypes.endp = _endpos_d_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = xs;
+            MenhirLib.EngineTypes.startp = _startpos_xs_;
+            MenhirLib.EngineTypes.endp = _endpos_xs_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let d : (Ocaml_parsing.Ast_helper.str * Parsetree.constructor_arguments *
+  Parsetree.core_type option * Parsetree.attributes * Location.t *
+  Ocaml_parsing.Docstrings.info) = Obj.magic d in
+        let xs : (Parsetree.constructor_declaration list) = Obj.magic xs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xs_ in
+        let _endpos = _endpos_d_ in
+        let _v : (Parsetree.constructor_declaration list) = let x = 
+# 3244 "src/ocaml/preprocess/parser_raw.mly"
+    (
+      let cid, args, res, attrs, loc, info = d in
+      Type.constructor cid ~args ?res ~attrs ~loc ~info
+    )
+# 29439 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 1199 "src/ocaml/preprocess/parser_raw.mly"
+      ( x :: xs )
+# 29444 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = d;
+          MenhirLib.EngineTypes.startp = _startpos_d_;
+          MenhirLib.EngineTypes.endp = _endpos_d_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let d : (Ocaml_parsing.Ast_helper.str * Parsetree.constructor_arguments *
+  Parsetree.core_type option * Parsetree.attributes * Location.t *
+  Ocaml_parsing.Docstrings.info) = Obj.magic d in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_d_ in
+        let _endpos = _endpos_d_ in
+        let _v : (Parsetree.extension_constructor list) = let x =
+          let _1 = 
+# 3356 "src/ocaml/preprocess/parser_raw.mly"
+    (
+      let cid, args, res, attrs, loc, info = d in
+      Te.decl cid ~args ?res ~attrs ~loc ~info
+    )
+# 29475 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          
+# 3350 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 29480 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1192 "src/ocaml/preprocess/parser_raw.mly"
+      ( [x] )
+# 29486 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.extension_constructor) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.extension_constructor list) = let x = 
+# 3352 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 29511 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 1192 "src/ocaml/preprocess/parser_raw.mly"
+      ( [x] )
+# 29516 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = d;
+          MenhirLib.EngineTypes.startp = _startpos_d_;
+          MenhirLib.EngineTypes.endp = _endpos_d_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let d : (Ocaml_parsing.Ast_helper.str * Parsetree.constructor_arguments *
+  Parsetree.core_type option * Parsetree.attributes * Location.t *
+  Ocaml_parsing.Docstrings.info) = Obj.magic d in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_d_ in
+        let _endpos = _endpos_d_ in
+        let _v : (Parsetree.extension_constructor list) = let x =
+          let _1 = 
+# 3356 "src/ocaml/preprocess/parser_raw.mly"
+    (
+      let cid, args, res, attrs, loc, info = d in
+      Te.decl cid ~args ?res ~attrs ~loc ~info
+    )
+# 29547 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          
+# 3350 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 29552 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1195 "src/ocaml/preprocess/parser_raw.mly"
+      ( [x] )
+# 29558 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.extension_constructor) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.extension_constructor list) = let x = 
+# 3352 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 29583 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 1195 "src/ocaml/preprocess/parser_raw.mly"
+      ( [x] )
+# 29588 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = d;
+          MenhirLib.EngineTypes.startp = _startpos_d_;
+          MenhirLib.EngineTypes.endp = _endpos_d_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = xs;
+            MenhirLib.EngineTypes.startp = _startpos_xs_;
+            MenhirLib.EngineTypes.endp = _endpos_xs_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let d : (Ocaml_parsing.Ast_helper.str * Parsetree.constructor_arguments *
+  Parsetree.core_type option * Parsetree.attributes * Location.t *
+  Ocaml_parsing.Docstrings.info) = Obj.magic d in
+        let xs : (Parsetree.extension_constructor list) = Obj.magic xs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xs_ in
+        let _endpos = _endpos_d_ in
+        let _v : (Parsetree.extension_constructor list) = let x =
+          let _1 = 
+# 3356 "src/ocaml/preprocess/parser_raw.mly"
+    (
+      let cid, args, res, attrs, loc, info = d in
+      Te.decl cid ~args ?res ~attrs ~loc ~info
+    )
+# 29626 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          
+# 3350 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 29631 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1199 "src/ocaml/preprocess/parser_raw.mly"
+      ( x :: xs )
+# 29637 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = xs;
+            MenhirLib.EngineTypes.startp = _startpos_xs_;
+            MenhirLib.EngineTypes.endp = _endpos_xs_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _1 : (Parsetree.extension_constructor) = Obj.magic _1 in
+        let xs : (Parsetree.extension_constructor list) = Obj.magic xs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xs_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.extension_constructor list) = let x = 
+# 3352 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 29669 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 1199 "src/ocaml/preprocess/parser_raw.mly"
+      ( x :: xs )
+# 29674 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = d;
+          MenhirLib.EngineTypes.startp = _startpos_d_;
+          MenhirLib.EngineTypes.endp = _endpos_d_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let d : (Ocaml_parsing.Ast_helper.str * Parsetree.constructor_arguments *
+  Parsetree.core_type option * Parsetree.attributes * Location.t *
+  Ocaml_parsing.Docstrings.info) = Obj.magic d in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_d_ in
+        let _endpos = _endpos_d_ in
+        let _v : (Parsetree.extension_constructor list) = let x = 
+# 3356 "src/ocaml/preprocess/parser_raw.mly"
+    (
+      let cid, args, res, attrs, loc, info = d in
+      Te.decl cid ~args ?res ~attrs ~loc ~info
+    )
+# 29704 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 1192 "src/ocaml/preprocess/parser_raw.mly"
+      ( [x] )
+# 29709 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = d;
+          MenhirLib.EngineTypes.startp = _startpos_d_;
+          MenhirLib.EngineTypes.endp = _endpos_d_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let d : (Ocaml_parsing.Ast_helper.str * Parsetree.constructor_arguments *
+  Parsetree.core_type option * Parsetree.attributes * Location.t *
+  Ocaml_parsing.Docstrings.info) = Obj.magic d in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_d_ in
+        let _endpos = _endpos_d_ in
+        let _v : (Parsetree.extension_constructor list) = let x = 
+# 3356 "src/ocaml/preprocess/parser_raw.mly"
+    (
+      let cid, args, res, attrs, loc, info = d in
+      Te.decl cid ~args ?res ~attrs ~loc ~info
+    )
+# 29739 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 1195 "src/ocaml/preprocess/parser_raw.mly"
+      ( [x] )
+# 29744 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = d;
+          MenhirLib.EngineTypes.startp = _startpos_d_;
+          MenhirLib.EngineTypes.endp = _endpos_d_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = xs;
+            MenhirLib.EngineTypes.startp = _startpos_xs_;
+            MenhirLib.EngineTypes.endp = _endpos_xs_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let d : (Ocaml_parsing.Ast_helper.str * Parsetree.constructor_arguments *
+  Parsetree.core_type option * Parsetree.attributes * Location.t *
+  Ocaml_parsing.Docstrings.info) = Obj.magic d in
+        let xs : (Parsetree.extension_constructor list) = Obj.magic xs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xs_ in
+        let _endpos = _endpos_d_ in
+        let _v : (Parsetree.extension_constructor list) = let x = 
+# 3356 "src/ocaml/preprocess/parser_raw.mly"
+    (
+      let cid, args, res, attrs, loc, info = d in
+      Te.decl cid ~args ?res ~attrs ~loc ~info
+    )
+# 29781 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 1199 "src/ocaml/preprocess/parser_raw.mly"
+      ( x :: xs )
+# 29786 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : ((Parsetree.core_type * Parsetree.core_type * Location.t) list) = 
+# 1058 "src/ocaml/preprocess/parser_raw.mly"
+    ( [] )
+# 29804 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = xs;
+                  MenhirLib.EngineTypes.startp = _startpos_xs_;
+                  MenhirLib.EngineTypes.endp = _endpos_xs_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.core_type) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1_inlined1 : (Parsetree.core_type) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let xs : ((Parsetree.core_type * Parsetree.core_type * Location.t) list) = Obj.magic xs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xs_ in
+        let _endpos = _endpos__3_ in
+        let _v : ((Parsetree.core_type * Parsetree.core_type * Location.t) list) = let x =
+          let x =
+            let (_startpos__1_, _1) = (_startpos__1_inlined1_, _1_inlined1) in
+            let _endpos = _endpos__3_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 2204 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1, _3, make_loc _sloc )
+# 29863 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 183 "<standard.mly>"
+    ( x )
+# 29869 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1060 "src/ocaml/preprocess/parser_raw.mly"
+    ( x :: xs )
+# 29875 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let x : (Lexing.position * Parsetree.functor_parameter) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos_x_ in
+        let _v : ((Lexing.position * Parsetree.functor_parameter) list) = 
+# 1072 "src/ocaml/preprocess/parser_raw.mly"
+    ( [ x ] )
+# 29900 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = xs;
+            MenhirLib.EngineTypes.startp = _startpos_xs_;
+            MenhirLib.EngineTypes.endp = _endpos_xs_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let x : (Lexing.position * Parsetree.functor_parameter) = Obj.magic x in
+        let xs : ((Lexing.position * Parsetree.functor_parameter) list) = Obj.magic xs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xs_ in
+        let _endpos = _endpos_x_ in
+        let _v : ((Lexing.position * Parsetree.functor_parameter) list) = 
+# 1074 "src/ocaml/preprocess/parser_raw.mly"
+    ( x :: xs )
+# 29932 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let x : (Asttypes.arg_label * Parsetree.expression) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos_x_ in
+        let _v : ((Asttypes.arg_label * Parsetree.expression) list) = 
+# 1072 "src/ocaml/preprocess/parser_raw.mly"
+    ( [ x ] )
+# 29957 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = xs;
+            MenhirLib.EngineTypes.startp = _startpos_xs_;
+            MenhirLib.EngineTypes.endp = _endpos_xs_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let x : (Asttypes.arg_label * Parsetree.expression) = Obj.magic x in
+        let xs : ((Asttypes.arg_label * Parsetree.expression) list) = Obj.magic xs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xs_ in
+        let _endpos = _endpos_x_ in
+        let _v : ((Asttypes.arg_label * Parsetree.expression) list) = 
+# 1074 "src/ocaml/preprocess/parser_raw.mly"
+    ( x :: xs )
+# 29989 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let x : (string) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos_x_ in
+        let _v : (string list) = 
+# 1072 "src/ocaml/preprocess/parser_raw.mly"
+    ( [ x ] )
+# 30014 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = xs;
+            MenhirLib.EngineTypes.startp = _startpos_xs_;
+            MenhirLib.EngineTypes.endp = _endpos_xs_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let x : (string) = Obj.magic x in
+        let xs : (string list) = Obj.magic xs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xs_ in
+        let _endpos = _endpos_x_ in
+        let _v : (string list) = 
+# 1074 "src/ocaml/preprocess/parser_raw.mly"
+    ( x :: xs )
+# 30046 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (string) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (string Location.loc list) = let x =
+          let _2 =
+            let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 30084 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 3414 "src/ocaml/preprocess/parser_raw.mly"
+    ( _2 )
+# 30090 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1072 "src/ocaml/preprocess/parser_raw.mly"
+    ( [ x ] )
+# 30096 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = xs;
+              MenhirLib.EngineTypes.startp = _startpos_xs_;
+              MenhirLib.EngineTypes.endp = _endpos_xs_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (string) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let xs : (string Location.loc list) = Obj.magic xs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xs_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (string Location.loc list) = let x =
+          let _2 =
+            let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 30141 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 3414 "src/ocaml/preprocess/parser_raw.mly"
+    ( _2 )
+# 30147 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1074 "src/ocaml/preprocess/parser_raw.mly"
+    ( x :: xs )
+# 30153 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let x : (Parsetree.case) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos_x_ in
+        let _v : (Parsetree.case list) = let _1 = 
+# 124 "<standard.mly>"
+    ( None )
+# 30178 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 1163 "src/ocaml/preprocess/parser_raw.mly"
+    ( [x] )
+# 30183 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = x_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos_x_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos_x_inlined1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let x : (Parsetree.case) = Obj.magic x in
+        let x_inlined1 : unit = Obj.magic x_inlined1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_inlined1_ in
+        let _endpos = _endpos_x_ in
+        let _v : (Parsetree.case list) = let _1 =
+          let x = x_inlined1 in
+          
+# 126 "<standard.mly>"
+    ( Some x )
+# 30217 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1163 "src/ocaml/preprocess/parser_raw.mly"
+    ( [x] )
+# 30223 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = xs;
+              MenhirLib.EngineTypes.startp = _startpos_xs_;
+              MenhirLib.EngineTypes.endp = _endpos_xs_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let x : (Parsetree.case) = Obj.magic x in
+        let _2 : unit = Obj.magic _2 in
+        let xs : (Parsetree.case list) = Obj.magic xs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xs_ in
+        let _endpos = _endpos_x_ in
+        let _v : (Parsetree.case list) = 
+# 1167 "src/ocaml/preprocess/parser_raw.mly"
+    ( x :: xs )
+# 30262 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.core_type) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.core_type list) = let xs =
+          let x = 
+# 3457 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 30288 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          
+# 1098 "src/ocaml/preprocess/parser_raw.mly"
+    ( [ x ] )
+# 30293 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1106 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 30299 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = xs;
+              MenhirLib.EngineTypes.startp = _startpos_xs_;
+              MenhirLib.EngineTypes.endp = _endpos_xs_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _1 : (Parsetree.core_type) = Obj.magic _1 in
+        let _2 : unit = Obj.magic _2 in
+        let xs : (Parsetree.core_type list) = Obj.magic xs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xs_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.core_type list) = let xs =
+          let x = 
+# 3457 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 30339 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          
+# 1102 "src/ocaml/preprocess/parser_raw.mly"
+    ( x :: xs )
+# 30344 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1106 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 30350 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let x : (Parsetree.with_constraint) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos_x_ in
+        let _v : (Parsetree.with_constraint list) = let xs = 
+# 1098 "src/ocaml/preprocess/parser_raw.mly"
+    ( [ x ] )
+# 30375 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 1106 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 30380 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = xs;
+              MenhirLib.EngineTypes.startp = _startpos_xs_;
+              MenhirLib.EngineTypes.endp = _endpos_xs_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let x : (Parsetree.with_constraint) = Obj.magic x in
+        let _2 : unit = Obj.magic _2 in
+        let xs : (Parsetree.with_constraint list) = Obj.magic xs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xs_ in
+        let _endpos = _endpos_x_ in
+        let _v : (Parsetree.with_constraint list) = let xs = 
+# 1102 "src/ocaml/preprocess/parser_raw.mly"
+    ( x :: xs )
+# 30419 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 1106 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 30424 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let x : (Parsetree.row_field) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos_x_ in
+        let _v : (Parsetree.row_field list) = let xs = 
+# 1098 "src/ocaml/preprocess/parser_raw.mly"
+    ( [ x ] )
+# 30449 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 1106 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 30454 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = xs;
+              MenhirLib.EngineTypes.startp = _startpos_xs_;
+              MenhirLib.EngineTypes.endp = _endpos_xs_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let x : (Parsetree.row_field) = Obj.magic x in
+        let _2 : unit = Obj.magic _2 in
+        let xs : (Parsetree.row_field list) = Obj.magic xs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xs_ in
+        let _endpos = _endpos_x_ in
+        let _v : (Parsetree.row_field list) = let xs = 
+# 1102 "src/ocaml/preprocess/parser_raw.mly"
+    ( x :: xs )
+# 30493 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 1106 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 30498 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let x : (Parsetree.core_type) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos_x_ in
+        let _v : (Parsetree.core_type list) = let xs = 
+# 1098 "src/ocaml/preprocess/parser_raw.mly"
+    ( [ x ] )
+# 30523 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 1106 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 30528 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = xs;
+              MenhirLib.EngineTypes.startp = _startpos_xs_;
+              MenhirLib.EngineTypes.endp = _endpos_xs_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let x : (Parsetree.core_type) = Obj.magic x in
+        let _2 : unit = Obj.magic _2 in
+        let xs : (Parsetree.core_type list) = Obj.magic xs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xs_ in
+        let _endpos = _endpos_x_ in
+        let _v : (Parsetree.core_type list) = let xs = 
+# 1102 "src/ocaml/preprocess/parser_raw.mly"
+    ( x :: xs )
+# 30567 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 1106 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 30572 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let x : (Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos_x_ in
+        let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = let xs = 
+# 1098 "src/ocaml/preprocess/parser_raw.mly"
+    ( [ x ] )
+# 30597 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 1106 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 30602 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = xs;
+              MenhirLib.EngineTypes.startp = _startpos_xs_;
+              MenhirLib.EngineTypes.endp = _endpos_xs_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let x : (Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) = Obj.magic x in
+        let _2 : unit = Obj.magic _2 in
+        let xs : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic xs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xs_ in
+        let _endpos = _endpos_x_ in
+        let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = let xs = 
+# 1102 "src/ocaml/preprocess/parser_raw.mly"
+    ( x :: xs )
+# 30641 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 1106 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 30646 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let x : (Parsetree.core_type) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos_x_ in
+        let _v : (Parsetree.core_type list) = let xs = 
+# 1098 "src/ocaml/preprocess/parser_raw.mly"
+    ( [ x ] )
+# 30671 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 1106 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 30676 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = xs;
+              MenhirLib.EngineTypes.startp = _startpos_xs_;
+              MenhirLib.EngineTypes.endp = _endpos_xs_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let x : (Parsetree.core_type) = Obj.magic x in
+        let _2 : unit = Obj.magic _2 in
+        let xs : (Parsetree.core_type list) = Obj.magic xs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xs_ in
+        let _endpos = _endpos_x_ in
+        let _v : (Parsetree.core_type list) = let xs = 
+# 1102 "src/ocaml/preprocess/parser_raw.mly"
+    ( x :: xs )
+# 30715 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 1106 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 30720 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = xs;
+              MenhirLib.EngineTypes.startp = _startpos_xs_;
+              MenhirLib.EngineTypes.endp = _endpos_xs_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let x : (Parsetree.core_type) = Obj.magic x in
+        let _2 : unit = Obj.magic _2 in
+        let xs : (Parsetree.core_type list) = Obj.magic xs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xs_ in
+        let _endpos = _endpos_x_ in
+        let _v : (Parsetree.core_type list) = 
+# 1129 "src/ocaml/preprocess/parser_raw.mly"
+    ( x :: xs )
+# 30759 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x2;
+          MenhirLib.EngineTypes.startp = _startpos_x2_;
+          MenhirLib.EngineTypes.endp = _endpos_x2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = x1;
+              MenhirLib.EngineTypes.startp = _startpos_x1_;
+              MenhirLib.EngineTypes.endp = _endpos_x1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let x2 : (Parsetree.core_type) = Obj.magic x2 in
+        let _2 : unit = Obj.magic _2 in
+        let x1 : (Parsetree.core_type) = Obj.magic x1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x1_ in
+        let _endpos = _endpos_x2_ in
+        let _v : (Parsetree.core_type list) = 
+# 1133 "src/ocaml/preprocess/parser_raw.mly"
+    ( [ x2; x1 ] )
+# 30798 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = xs;
+              MenhirLib.EngineTypes.startp = _startpos_xs_;
+              MenhirLib.EngineTypes.endp = _endpos_xs_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let x : (Parsetree.expression) = Obj.magic x in
+        let _2 : unit = Obj.magic _2 in
+        let xs : (Parsetree.expression list) = Obj.magic xs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xs_ in
+        let _endpos = _endpos_x_ in
+        let _v : (Parsetree.expression list) = 
+# 1129 "src/ocaml/preprocess/parser_raw.mly"
+    ( x :: xs )
+# 30837 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x2;
+          MenhirLib.EngineTypes.startp = _startpos_x2_;
+          MenhirLib.EngineTypes.endp = _endpos_x2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = x1;
+              MenhirLib.EngineTypes.startp = _startpos_x1_;
+              MenhirLib.EngineTypes.endp = _endpos_x1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let x2 : (Parsetree.expression) = Obj.magic x2 in
+        let _2 : unit = Obj.magic _2 in
+        let x1 : (Parsetree.expression) = Obj.magic x1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x1_ in
+        let _endpos = _endpos_x2_ in
+        let _v : (Parsetree.expression list) = 
+# 1133 "src/ocaml/preprocess/parser_raw.mly"
+    ( [ x2; x1 ] )
+# 30876 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = xs;
+              MenhirLib.EngineTypes.startp = _startpos_xs_;
+              MenhirLib.EngineTypes.endp = _endpos_xs_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let x : (Parsetree.core_type) = Obj.magic x in
+        let _2 : unit = Obj.magic _2 in
+        let xs : (Parsetree.core_type list) = Obj.magic xs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xs_ in
+        let _endpos = _endpos_x_ in
+        let _v : (Parsetree.core_type list) = 
+# 1129 "src/ocaml/preprocess/parser_raw.mly"
+    ( x :: xs )
+# 30915 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x2;
+          MenhirLib.EngineTypes.startp = _startpos_x2_;
+          MenhirLib.EngineTypes.endp = _endpos_x2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = x1;
+              MenhirLib.EngineTypes.startp = _startpos_x1_;
+              MenhirLib.EngineTypes.endp = _endpos_x1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let x2 : (Parsetree.core_type) = Obj.magic x2 in
+        let _2 : unit = Obj.magic _2 in
+        let x1 : (Parsetree.core_type) = Obj.magic x1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x1_ in
+        let _endpos = _endpos_x2_ in
+        let _v : (Parsetree.core_type list) = 
+# 1133 "src/ocaml/preprocess/parser_raw.mly"
+    ( [ x2; x1 ] )
+# 30954 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.row_field) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.row_field) = 
+# 3597 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 30979 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.core_type) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.row_field) = let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3599 "src/ocaml/preprocess/parser_raw.mly"
+      ( Rf.inherit_ ~loc:(make_loc _sloc) _1 )
+# 31007 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let x : (Parsetree.expression) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos_x_ in
+        let _v : (Parsetree.expression list) = let _2 = 
+# 124 "<standard.mly>"
+    ( None )
+# 31032 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 1150 "src/ocaml/preprocess/parser_raw.mly"
+    ( [x] )
+# 31037 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos_x_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos_x_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = x;
+            MenhirLib.EngineTypes.startp = _startpos_x_;
+            MenhirLib.EngineTypes.endp = _endpos_x_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let x_inlined1 : unit = Obj.magic x_inlined1 in
+        let x : (Parsetree.expression) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos_x_inlined1_ in
+        let _v : (Parsetree.expression list) = let _2 =
+          let x = x_inlined1 in
+          
+# 126 "<standard.mly>"
+    ( Some x )
+# 31071 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1150 "src/ocaml/preprocess/parser_raw.mly"
+    ( [x] )
+# 31077 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = x;
+              MenhirLib.EngineTypes.startp = _startpos_x_;
+              MenhirLib.EngineTypes.endp = _endpos_x_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.expression list) = Obj.magic xs in
+        let _2 : unit = Obj.magic _2 in
+        let x : (Parsetree.expression) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.expression list) = 
+# 1154 "src/ocaml/preprocess/parser_raw.mly"
+    ( x :: xs )
+# 31116 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = oe;
+          MenhirLib.EngineTypes.startp = _startpos_oe_;
+          MenhirLib.EngineTypes.endp = _endpos_oe_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let oe : (Parsetree.expression option) = Obj.magic oe in
+        let _1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 31144 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_oe_ in
+        let _v : ((string Location.loc * Parsetree.expression) list) = let _2 = 
+# 124 "<standard.mly>"
+    ( None )
+# 31152 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let x =
+          let label =
+            let _1 = 
+# 3661 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 31159 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 31167 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _startpos_label_ = _startpos__1_ in
+          let _endpos = _endpos_oe_ in
+          let _symbolstartpos = _startpos_label_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 2815 "src/ocaml/preprocess/parser_raw.mly"
+      ( let e =
+          match oe with
+          | None ->
+              (* No expression; this is a pun. Desugar it. *)
+              exp_of_label ~loc:_sloc label
+          | Some e ->
+              e
+        in
+        label, e )
+# 31185 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1150 "src/ocaml/preprocess/parser_raw.mly"
+    ( [x] )
+# 31191 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = oe;
+            MenhirLib.EngineTypes.startp = _startpos_oe_;
+            MenhirLib.EngineTypes.endp = _endpos_oe_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let x : unit = Obj.magic x in
+        let oe : (Parsetree.expression option) = Obj.magic oe in
+        let _1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 31226 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_x_ in
+        let _v : ((string Location.loc * Parsetree.expression) list) = let _2 = 
+# 126 "<standard.mly>"
+    ( Some x )
+# 31234 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let x =
+          let label =
+            let _1 = 
+# 3661 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 31241 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 31249 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _startpos_label_ = _startpos__1_ in
+          let _endpos = _endpos_oe_ in
+          let _symbolstartpos = _startpos_label_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 2815 "src/ocaml/preprocess/parser_raw.mly"
+      ( let e =
+          match oe with
+          | None ->
+              (* No expression; this is a pun. Desugar it. *)
+              exp_of_label ~loc:_sloc label
+          | Some e ->
+              e
+        in
+        label, e )
+# 31267 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1150 "src/ocaml/preprocess/parser_raw.mly"
+    ( [x] )
+# 31273 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = oe;
+              MenhirLib.EngineTypes.startp = _startpos_oe_;
+              MenhirLib.EngineTypes.endp = _endpos_oe_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let xs : ((string Location.loc * Parsetree.expression) list) = Obj.magic xs in
+        let _2 : unit = Obj.magic _2 in
+        let oe : (Parsetree.expression option) = Obj.magic oe in
+        let _1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 31315 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : ((string Location.loc * Parsetree.expression) list) = let x =
+          let label =
+            let _1 = 
+# 3661 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 31325 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 31333 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _startpos_label_ = _startpos__1_ in
+          let _endpos = _endpos_oe_ in
+          let _symbolstartpos = _startpos_label_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 2815 "src/ocaml/preprocess/parser_raw.mly"
+      ( let e =
+          match oe with
+          | None ->
+              (* No expression; this is a pun. Desugar it. *)
+              exp_of_label ~loc:_sloc label
+          | Some e ->
+              e
+        in
+        label, e )
+# 31351 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1154 "src/ocaml/preprocess/parser_raw.mly"
+    ( x :: xs )
+# 31357 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let x : (Parsetree.pattern) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos_x_ in
+        let _v : (Parsetree.pattern list) = let _2 = 
+# 124 "<standard.mly>"
+    ( None )
+# 31382 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 1150 "src/ocaml/preprocess/parser_raw.mly"
+    ( [x] )
+# 31387 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos_x_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos_x_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = x;
+            MenhirLib.EngineTypes.startp = _startpos_x_;
+            MenhirLib.EngineTypes.endp = _endpos_x_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let x_inlined1 : unit = Obj.magic x_inlined1 in
+        let x : (Parsetree.pattern) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos_x_inlined1_ in
+        let _v : (Parsetree.pattern list) = let _2 =
+          let x = x_inlined1 in
+          
+# 126 "<standard.mly>"
+    ( Some x )
+# 31421 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1150 "src/ocaml/preprocess/parser_raw.mly"
+    ( [x] )
+# 31427 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = x;
+              MenhirLib.EngineTypes.startp = _startpos_x_;
+              MenhirLib.EngineTypes.endp = _endpos_x_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let xs : (Parsetree.pattern list) = Obj.magic xs in
+        let _2 : unit = Obj.magic _2 in
+        let x : (Parsetree.pattern) = Obj.magic x in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_x_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.pattern list) = 
+# 1154 "src/ocaml/preprocess/parser_raw.mly"
+    ( x :: xs )
+# 31466 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = eo;
+          MenhirLib.EngineTypes.startp = _startpos_eo_;
+          MenhirLib.EngineTypes.endp = _endpos_eo_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = c;
+            MenhirLib.EngineTypes.startp = _startpos_c_;
+            MenhirLib.EngineTypes.endp = _endpos_c_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let eo : (Parsetree.expression option) = Obj.magic eo in
+        let c : ((Parsetree.core_type option * Parsetree.core_type option) option) = Obj.magic c in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_eo_ in
+        let _v : ((Longident.t Location.loc * Parsetree.expression) list) = let _2 = 
+# 124 "<standard.mly>"
+    ( None )
+# 31505 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let x =
+          let label =
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 31515 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _startpos_label_ = _startpos__1_ in
+          let _endpos = _endpos_eo_ in
+          let _symbolstartpos = _startpos_label_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 2798 "src/ocaml/preprocess/parser_raw.mly"
+      ( let e =
+          match eo with
+          | None ->
+              (* No pattern; this is a pun. Desugar it. *)
+              exp_of_longident ~loc:_sloc label
+          | Some e ->
+              e
+        in
+        label, mkexp_opt_constraint ~loc:_sloc e c )
+# 31533 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1150 "src/ocaml/preprocess/parser_raw.mly"
+    ( [x] )
+# 31539 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = x;
+          MenhirLib.EngineTypes.startp = _startpos_x_;
+          MenhirLib.EngineTypes.endp = _endpos_x_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = eo;
+            MenhirLib.EngineTypes.startp = _startpos_eo_;
+            MenhirLib.EngineTypes.endp = _endpos_eo_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = c;
+              MenhirLib.EngineTypes.startp = _startpos_c_;
+              MenhirLib.EngineTypes.endp = _endpos_c_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let x : unit = Obj.magic x in
+        let eo : (Parsetree.expression option) = Obj.magic eo in
+        let c : ((Parsetree.core_type option * Parsetree.core_type option) option) = Obj.magic c in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_x_ in
+        let _v : ((Longident.t Location.loc * Parsetree.expression) list) = let _2 = 
+# 126 "<standard.mly>"
+    ( Some x )
+# 31585 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let x =
+          let label =
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 31595 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _startpos_label_ = _startpos__1_ in
+          let _endpos = _endpos_eo_ in
+          let _symbolstartpos = _startpos_label_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 2798 "src/ocaml/preprocess/parser_raw.mly"
+      ( let e =
+          match eo with
+          | None ->
+              (* No pattern; this is a pun. Desugar it. *)
+              exp_of_longident ~loc:_sloc label
+          | Some e ->
+              e
+        in
+        label, mkexp_opt_constraint ~loc:_sloc e c )
+# 31613 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1150 "src/ocaml/preprocess/parser_raw.mly"
+    ( [x] )
+# 31619 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = eo;
+              MenhirLib.EngineTypes.startp = _startpos_eo_;
+              MenhirLib.EngineTypes.endp = _endpos_eo_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = c;
+                MenhirLib.EngineTypes.startp = _startpos_c_;
+                MenhirLib.EngineTypes.endp = _endpos_c_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let xs : ((Longident.t Location.loc * Parsetree.expression) list) = Obj.magic xs in
+        let _2 : unit = Obj.magic _2 in
+        let eo : (Parsetree.expression option) = Obj.magic eo in
+        let c : ((Parsetree.core_type option * Parsetree.core_type option) option) = Obj.magic c in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : ((Longident.t Location.loc * Parsetree.expression) list) = let x =
+          let label =
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 31677 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _startpos_label_ = _startpos__1_ in
+          let _endpos = _endpos_eo_ in
+          let _symbolstartpos = _startpos_label_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 2798 "src/ocaml/preprocess/parser_raw.mly"
+      ( let e =
+          match eo with
+          | None ->
+              (* No pattern; this is a pun. Desugar it. *)
+              exp_of_longident ~loc:_sloc label
+          | Some e ->
+              e
+        in
+        label, mkexp_opt_constraint ~loc:_sloc e c )
+# 31695 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1154 "src/ocaml/preprocess/parser_raw.mly"
+    ( x :: xs )
+# 31701 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.expression) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.expression) = 
+# 2293 "src/ocaml/preprocess/parser_raw.mly"
+                                  ( _1 )
+# 31726 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.expression) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.expression) = 
+# 2294 "src/ocaml/preprocess/parser_raw.mly"
+                                  ( _1 )
+# 31758 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.expression) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.expression) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 = 
+# 2296 "src/ocaml/preprocess/parser_raw.mly"
+    ( Pexp_sequence(_1, _3) )
+# 31798 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos__3_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 31807 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2297 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 31813 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : (Parsetree.expression) = Obj.magic _5 in
+        let _4 : (string Location.loc) = Obj.magic _4 in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.expression) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.expression) = let _endpos = _endpos__5_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2299 "src/ocaml/preprocess/parser_raw.mly"
+    ( let seq = mkexp ~loc:_sloc (Pexp_sequence (_1, _5)) in
+      let payload = PStr [mkstrexp seq []] in
+      mkexp ~loc:_sloc (Pexp_extension (_4, payload)) )
+# 31871 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined4;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined4_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined3;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = args_res;
+              MenhirLib.EngineTypes.startp = _startpos_args_res_;
+              MenhirLib.EngineTypes.endp = _endpos_args_res_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = ext;
+                    MenhirLib.EngineTypes.startp = _startpos_ext_;
+                    MenhirLib.EngineTypes.endp = _endpos_ext_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = _1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined4 : (Parsetree.attributes) = Obj.magic _1_inlined4 in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let args_res : (Parsetree.constructor_arguments * Parsetree.core_type option) = Obj.magic args_res in
+        let _1_inlined2 : (string) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined4_ in
+        let _v : (Parsetree.type_exception * string Location.loc option) = let attrs =
+          let _1 = _1_inlined4 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 31940 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_attrs_ = _endpos__1_inlined4_ in
+        let attrs2 =
+          let _1 = _1_inlined3 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 31949 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_attrs2_ = _endpos__1_inlined3_ in
+        let id =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 31961 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let attrs1 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 31969 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_attrs_ in
+        let _startpos = _startpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3274 "src/ocaml/preprocess/parser_raw.mly"
+    ( let args, res = args_res in
+      let loc = make_loc (_startpos, _endpos_attrs2_) in
+      let docs = symbol_docs _sloc in
+      Te.mk_exception ~attrs
+        (Te.decl id ~args ?res ~attrs:(attrs1 @ attrs2) ~loc ~docs)
+      , ext )
+# 31984 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = xss;
+          MenhirLib.EngineTypes.startp = _startpos_xss_;
+          MenhirLib.EngineTypes.endp = _endpos_xss_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let xss : (Parsetree.signature_item list list) = Obj.magic xss in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xss_ in
+        let _endpos = _endpos_xss_ in
+        let _v : (Parsetree.signature) = let _1 =
+          let _1 = 
+# 260 "<standard.mly>"
+    ( List.flatten xss )
+# 32010 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_xss_) in
+          let _endpos = _endpos__1_ in
+          let _startpos = _startpos__1_ in
+          
+# 973 "src/ocaml/preprocess/parser_raw.mly"
+                              ( extra_sig _startpos _endpos _1 )
+# 32018 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1732 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 32024 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : (Parsetree.extension) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (Parsetree.signature_item) = let _2 =
+          let _1 = _1_inlined1 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 32058 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__2_ = _endpos__1_inlined1_ in
+        let _endpos = _endpos__2_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 1747 "src/ocaml/preprocess/parser_raw.mly"
+      ( let docs = symbol_docs _sloc in
+        mksig ~loc:_sloc (Psig_extension (_1, (add_docs_attrs docs _2))) )
+# 32069 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.attribute) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.signature_item) = let _1 =
+          let _1 = 
+# 1751 "src/ocaml/preprocess/parser_raw.mly"
+        ( Psig_attribute _1 )
+# 32095 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1021 "src/ocaml/preprocess/parser_raw.mly"
+    ( mksig ~loc:_sloc _1 )
+# 32103 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1753 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 32109 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.value_description * string Location.loc option) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.signature_item) = let _1 =
+          let _1 = 
+# 1756 "src/ocaml/preprocess/parser_raw.mly"
+        ( psig_value _1 )
+# 32135 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1038 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mksig_ext ~loc:_sloc _1 )
+# 32143 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1788 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 32149 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.value_description * string Location.loc option) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.signature_item) = let _1 =
+          let _1 = 
+# 1758 "src/ocaml/preprocess/parser_raw.mly"
+        ( psig_value _1 )
+# 32175 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1038 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mksig_ext ~loc:_sloc _1 )
+# 32183 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1788 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 32189 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = bs;
+          MenhirLib.EngineTypes.startp = _startpos_bs_;
+          MenhirLib.EngineTypes.endp = _endpos_bs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = a;
+            MenhirLib.EngineTypes.startp = _startpos_a_;
+            MenhirLib.EngineTypes.endp = _endpos_a_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let bs : (Parsetree.type_declaration list) = Obj.magic bs in
+        let a : ((Asttypes.rec_flag * string Location.loc option) *
+  Parsetree.type_declaration) = Obj.magic a in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_a_ in
+        let _endpos = _endpos_bs_ in
+        let _v : (Parsetree.signature_item) = let _1 =
+          let _1 =
+            let _1 =
+              let _1 =
+                let _1 = 
+# 1211 "src/ocaml/preprocess/parser_raw.mly"
+    ( let (x, b) = a in x, b :: bs )
+# 32226 "src/ocaml/preprocess/parser_raw.ml"
+                 in
+                
+# 3093 "src/ocaml/preprocess/parser_raw.mly"
+  ( _1 )
+# 32231 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 3076 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 32237 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 1760 "src/ocaml/preprocess/parser_raw.mly"
+        ( psig_type _1 )
+# 32243 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_bs_, _startpos_a_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1038 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mksig_ext ~loc:_sloc _1 )
+# 32253 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1788 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 32259 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = bs;
+          MenhirLib.EngineTypes.startp = _startpos_bs_;
+          MenhirLib.EngineTypes.endp = _endpos_bs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = a;
+            MenhirLib.EngineTypes.startp = _startpos_a_;
+            MenhirLib.EngineTypes.endp = _endpos_a_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let bs : (Parsetree.type_declaration list) = Obj.magic bs in
+        let a : ((Asttypes.rec_flag * string Location.loc option) *
+  Parsetree.type_declaration) = Obj.magic a in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_a_ in
+        let _endpos = _endpos_bs_ in
+        let _v : (Parsetree.signature_item) = let _1 =
+          let _1 =
+            let _1 =
+              let _1 =
+                let _1 = 
+# 1211 "src/ocaml/preprocess/parser_raw.mly"
+    ( let (x, b) = a in x, b :: bs )
+# 32296 "src/ocaml/preprocess/parser_raw.ml"
+                 in
+                
+# 3093 "src/ocaml/preprocess/parser_raw.mly"
+  ( _1 )
+# 32301 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 3081 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 32307 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 1762 "src/ocaml/preprocess/parser_raw.mly"
+        ( psig_typesubst _1 )
+# 32313 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_bs_, _startpos_a_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1038 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mksig_ext ~loc:_sloc _1 )
+# 32323 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1788 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 32329 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined3;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = xs;
+            MenhirLib.EngineTypes.startp = _startpos_xs_;
+            MenhirLib.EngineTypes.endp = _endpos_xs_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = priv;
+              MenhirLib.EngineTypes.startp = _startpos_priv_;
+              MenhirLib.EngineTypes.endp = _endpos_priv_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _7;
+                MenhirLib.EngineTypes.startp = _startpos__7_;
+                MenhirLib.EngineTypes.endp = _endpos__7_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined2;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = params;
+                    MenhirLib.EngineTypes.startp = _startpos_params_;
+                    MenhirLib.EngineTypes.endp = _endpos_params_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _1_inlined1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = ext;
+                        MenhirLib.EngineTypes.startp = _startpos_ext_;
+                        MenhirLib.EngineTypes.endp = _endpos_ext_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _menhir_s;
+                          MenhirLib.EngineTypes.semv = _1;
+                          MenhirLib.EngineTypes.startp = _startpos__1_;
+                          MenhirLib.EngineTypes.endp = _endpos__1_;
+                          MenhirLib.EngineTypes.next = _menhir_stack;
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let xs : (Parsetree.extension_constructor list) = Obj.magic xs in
+        let priv : (Asttypes.private_flag) = Obj.magic priv in
+        let _7 : unit = Obj.magic _7 in
+        let _1_inlined2 : (Longident.t) = Obj.magic _1_inlined2 in
+        let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined3_ in
+        let _v : (Parsetree.signature_item) = let _1 =
+          let _1 =
+            let _1 =
+              let _1 =
+                let attrs2 =
+                  let _1 = _1_inlined3 in
+                  
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 32416 "src/ocaml/preprocess/parser_raw.ml"
+                  
+                in
+                let _endpos_attrs2_ = _endpos__1_inlined3_ in
+                let cs = 
+# 1203 "src/ocaml/preprocess/parser_raw.mly"
+    ( List.rev xs )
+# 32423 "src/ocaml/preprocess/parser_raw.ml"
+                 in
+                let tid =
+                  let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+                  let _endpos = _endpos__1_ in
+                  let _symbolstartpos = _startpos__1_ in
+                  let _sloc = (_symbolstartpos, _endpos) in
+                  
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 32433 "src/ocaml/preprocess/parser_raw.ml"
+                  
+                in
+                let _4 = 
+# 3846 "src/ocaml/preprocess/parser_raw.mly"
+                ( Recursive )
+# 32439 "src/ocaml/preprocess/parser_raw.ml"
+                 in
+                let attrs1 =
+                  let _1 = _1_inlined1 in
+                  
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 32446 "src/ocaml/preprocess/parser_raw.ml"
+                  
+                in
+                let _endpos = _endpos_attrs2_ in
+                let _symbolstartpos = _startpos__1_ in
+                let _sloc = (_symbolstartpos, _endpos) in
+                
+# 3343 "src/ocaml/preprocess/parser_raw.mly"
+    ( let docs = symbol_docs _sloc in
+      let attrs = attrs1 @ attrs2 in
+      Te.mk tid cs ~params ~priv ~attrs ~docs,
+      ext )
+# 32458 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 3330 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 32464 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 1764 "src/ocaml/preprocess/parser_raw.mly"
+        ( psig_typext _1 )
+# 32470 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__1_inlined3_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1038 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mksig_ext ~loc:_sloc _1 )
+# 32480 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1788 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 32486 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined4;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined4_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = xs;
+            MenhirLib.EngineTypes.startp = _startpos_xs_;
+            MenhirLib.EngineTypes.endp = _endpos_xs_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = priv;
+              MenhirLib.EngineTypes.startp = _startpos_priv_;
+              MenhirLib.EngineTypes.endp = _endpos_priv_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _7;
+                MenhirLib.EngineTypes.startp = _startpos__7_;
+                MenhirLib.EngineTypes.endp = _endpos__7_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined3;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = params;
+                    MenhirLib.EngineTypes.startp = _startpos_params_;
+                    MenhirLib.EngineTypes.endp = _endpos_params_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _1_inlined2;
+                      MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = _1_inlined1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _;
+                          MenhirLib.EngineTypes.semv = ext;
+                          MenhirLib.EngineTypes.startp = _startpos_ext_;
+                          MenhirLib.EngineTypes.endp = _endpos_ext_;
+                          MenhirLib.EngineTypes.next = {
+                            MenhirLib.EngineTypes.state = _menhir_s;
+                            MenhirLib.EngineTypes.semv = _1;
+                            MenhirLib.EngineTypes.startp = _startpos__1_;
+                            MenhirLib.EngineTypes.endp = _endpos__1_;
+                            MenhirLib.EngineTypes.next = _menhir_stack;
+                          };
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined4 : (Parsetree.attributes) = Obj.magic _1_inlined4 in
+        let xs : (Parsetree.extension_constructor list) = Obj.magic xs in
+        let priv : (Asttypes.private_flag) = Obj.magic priv in
+        let _7 : unit = Obj.magic _7 in
+        let _1_inlined3 : (Longident.t) = Obj.magic _1_inlined3 in
+        let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in
+        let _1_inlined2 : unit = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined4_ in
+        let _v : (Parsetree.signature_item) = let _1 =
+          let _1 =
+            let _1 =
+              let _1 =
+                let attrs2 =
+                  let _1 = _1_inlined4 in
+                  
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 32580 "src/ocaml/preprocess/parser_raw.ml"
+                  
+                in
+                let _endpos_attrs2_ = _endpos__1_inlined4_ in
+                let cs = 
+# 1203 "src/ocaml/preprocess/parser_raw.mly"
+    ( List.rev xs )
+# 32587 "src/ocaml/preprocess/parser_raw.ml"
+                 in
+                let tid =
+                  let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in
+                  let _endpos = _endpos__1_ in
+                  let _symbolstartpos = _startpos__1_ in
+                  let _sloc = (_symbolstartpos, _endpos) in
+                  
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 32597 "src/ocaml/preprocess/parser_raw.ml"
+                  
+                in
+                let _4 =
+                  let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+                  let _endpos = _endpos__1_ in
+                  let _startpos = _startpos__1_ in
+                  let _loc = (_startpos, _endpos) in
+                  
+# 3848 "src/ocaml/preprocess/parser_raw.mly"
+                ( not_expecting _loc "nonrec flag"; Recursive )
+# 32608 "src/ocaml/preprocess/parser_raw.ml"
+                  
+                in
+                let attrs1 =
+                  let _1 = _1_inlined1 in
+                  
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 32616 "src/ocaml/preprocess/parser_raw.ml"
+                  
+                in
+                let _endpos = _endpos_attrs2_ in
+                let _symbolstartpos = _startpos__1_ in
+                let _sloc = (_symbolstartpos, _endpos) in
+                
+# 3343 "src/ocaml/preprocess/parser_raw.mly"
+    ( let docs = symbol_docs _sloc in
+      let attrs = attrs1 @ attrs2 in
+      Te.mk tid cs ~params ~priv ~attrs ~docs,
+      ext )
+# 32628 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 3330 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 32634 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 1764 "src/ocaml/preprocess/parser_raw.mly"
+        ( psig_typext _1 )
+# 32640 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__1_inlined4_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1038 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mksig_ext ~loc:_sloc _1 )
+# 32650 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1788 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 32656 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.type_exception * string Location.loc option) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.signature_item) = let _1 =
+          let _1 = 
+# 1766 "src/ocaml/preprocess/parser_raw.mly"
+        ( psig_exception _1 )
+# 32682 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1038 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mksig_ext ~loc:_sloc _1 )
+# 32690 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1788 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 32696 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined3;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = body;
+            MenhirLib.EngineTypes.startp = _startpos_body_;
+            MenhirLib.EngineTypes.endp = _endpos_body_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined2;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined1;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = ext;
+                  MenhirLib.EngineTypes.startp = _startpos_ext_;
+                  MenhirLib.EngineTypes.endp = _endpos_ext_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let body : (Parsetree.module_type) = Obj.magic body in
+        let _1_inlined2 : (string option) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined3_ in
+        let _v : (Parsetree.signature_item) = let _1 =
+          let _1 =
+            let _1 =
+              let attrs2 =
+                let _1 = _1_inlined3 in
+                
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 32761 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              let _endpos_attrs2_ = _endpos__1_inlined3_ in
+              let name =
+                let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+                let _endpos = _endpos__1_ in
+                let _symbolstartpos = _startpos__1_ in
+                let _sloc = (_symbolstartpos, _endpos) in
+                
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 32773 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              let attrs1 =
+                let _1 = _1_inlined1 in
+                
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 32781 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              let _endpos = _endpos_attrs2_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1797 "src/ocaml/preprocess/parser_raw.mly"
+  (
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc _sloc in
+    let docs = symbol_docs _sloc in
+    Md.mk name body ~attrs ~loc ~docs, ext
+  )
+# 32795 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 1768 "src/ocaml/preprocess/parser_raw.mly"
+        ( let (body, ext) = _1 in (Psig_module body, ext) )
+# 32801 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__1_inlined3_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1038 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mksig_ext ~loc:_sloc _1 )
+# 32811 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1788 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 32817 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined4;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined4_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined3;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _5;
+              MenhirLib.EngineTypes.startp = _startpos__5_;
+              MenhirLib.EngineTypes.endp = _endpos__5_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = ext;
+                    MenhirLib.EngineTypes.startp = _startpos_ext_;
+                    MenhirLib.EngineTypes.endp = _endpos_ext_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = _1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined4 : (Parsetree.attributes) = Obj.magic _1_inlined4 in
+        let _1_inlined3 : (Longident.t) = Obj.magic _1_inlined3 in
+        let _5 : unit = Obj.magic _5 in
+        let _1_inlined2 : (string option) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined4_ in
+        let _v : (Parsetree.signature_item) = let _1 =
+          let _1 =
+            let _1 =
+              let attrs2 =
+                let _1 = _1_inlined4 in
+                
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 32889 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              let _endpos_attrs2_ = _endpos__1_inlined4_ in
+              let body =
+                let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in
+                let id =
+                  let _endpos = _endpos__1_ in
+                  let _symbolstartpos = _startpos__1_ in
+                  let _sloc = (_symbolstartpos, _endpos) in
+                  
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 32902 "src/ocaml/preprocess/parser_raw.ml"
+                  
+                in
+                let (_endpos_id_, _startpos_id_) = (_endpos__1_, _startpos__1_) in
+                let _endpos = _endpos_id_ in
+                let _symbolstartpos = _startpos_id_ in
+                let _sloc = (_symbolstartpos, _endpos) in
+                
+# 1834 "src/ocaml/preprocess/parser_raw.mly"
+    ( Mty.alias ~loc:(make_loc _sloc) id )
+# 32912 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              let name =
+                let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+                let _endpos = _endpos__1_ in
+                let _symbolstartpos = _startpos__1_ in
+                let _sloc = (_symbolstartpos, _endpos) in
+                
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 32923 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              let attrs1 =
+                let _1 = _1_inlined1 in
+                
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 32931 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              let _endpos = _endpos_attrs2_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1825 "src/ocaml/preprocess/parser_raw.mly"
+  (
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc _sloc in
+    let docs = symbol_docs _sloc in
+    Md.mk name body ~attrs ~loc ~docs, ext
+  )
+# 32945 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 1770 "src/ocaml/preprocess/parser_raw.mly"
+        ( let (body, ext) = _1 in (Psig_module body, ext) )
+# 32951 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__1_inlined4_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1038 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mksig_ext ~loc:_sloc _1 )
+# 32961 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1788 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 32967 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.module_substitution * string Location.loc option) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.signature_item) = let _1 =
+          let _1 = 
+# 1772 "src/ocaml/preprocess/parser_raw.mly"
+        ( let (body, ext) = _1 in (Psig_modsubst body, ext) )
+# 32993 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1038 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mksig_ext ~loc:_sloc _1 )
+# 33001 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1788 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 33007 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = bs;
+          MenhirLib.EngineTypes.startp = _startpos_bs_;
+          MenhirLib.EngineTypes.endp = _endpos_bs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined3;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = mty;
+              MenhirLib.EngineTypes.startp = _startpos_mty_;
+              MenhirLib.EngineTypes.endp = _endpos_mty_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _6;
+                MenhirLib.EngineTypes.startp = _startpos__6_;
+                MenhirLib.EngineTypes.endp = _endpos__6_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined2;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _4;
+                    MenhirLib.EngineTypes.startp = _startpos__4_;
+                    MenhirLib.EngineTypes.endp = _endpos__4_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _1_inlined1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = ext;
+                        MenhirLib.EngineTypes.startp = _startpos_ext_;
+                        MenhirLib.EngineTypes.endp = _endpos_ext_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _menhir_s;
+                          MenhirLib.EngineTypes.semv = _1;
+                          MenhirLib.EngineTypes.startp = _startpos__1_;
+                          MenhirLib.EngineTypes.endp = _endpos__1_;
+                          MenhirLib.EngineTypes.next = _menhir_stack;
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let bs : (Parsetree.module_declaration list) = Obj.magic bs in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let mty : (Parsetree.module_type) = Obj.magic mty in
+        let _6 : unit = Obj.magic _6 in
+        let _1_inlined2 : (string option) = Obj.magic _1_inlined2 in
+        let _4 : unit = Obj.magic _4 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_bs_ in
+        let _v : (Parsetree.signature_item) = let _1 =
+          let _1 =
+            let _1 =
+              let _1 =
+                let a =
+                  let attrs2 =
+                    let _1 = _1_inlined3 in
+                    
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 33095 "src/ocaml/preprocess/parser_raw.ml"
+                    
+                  in
+                  let _endpos_attrs2_ = _endpos__1_inlined3_ in
+                  let name =
+                    let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+                    let _endpos = _endpos__1_ in
+                    let _symbolstartpos = _startpos__1_ in
+                    let _sloc = (_symbolstartpos, _endpos) in
+                    
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 33107 "src/ocaml/preprocess/parser_raw.ml"
+                    
+                  in
+                  let attrs1 =
+                    let _1 = _1_inlined1 in
+                    
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 33115 "src/ocaml/preprocess/parser_raw.ml"
+                    
+                  in
+                  let _endpos = _endpos_attrs2_ in
+                  let _symbolstartpos = _startpos__1_ in
+                  let _sloc = (_symbolstartpos, _endpos) in
+                  
+# 1870 "src/ocaml/preprocess/parser_raw.mly"
+  (
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc _sloc in
+    let docs = symbol_docs _sloc in
+    ext, Md.mk name mty ~attrs ~loc ~docs
+  )
+# 33129 "src/ocaml/preprocess/parser_raw.ml"
+                  
+                in
+                
+# 1211 "src/ocaml/preprocess/parser_raw.mly"
+    ( let (x, b) = a in x, b :: bs )
+# 33135 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 1859 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 33141 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 1774 "src/ocaml/preprocess/parser_raw.mly"
+        ( let (ext, l) = _1 in (Psig_recmodule l, ext) )
+# 33147 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos_bs_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1038 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mksig_ext ~loc:_sloc _1 )
+# 33157 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1788 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 33163 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.module_type_declaration * string Location.loc option) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.signature_item) = let _1 =
+          let _1 = 
+# 1776 "src/ocaml/preprocess/parser_raw.mly"
+        ( let (body, ext) = _1 in (Psig_modtype body, ext) )
+# 33189 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1038 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mksig_ext ~loc:_sloc _1 )
+# 33197 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1788 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 33203 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.module_type_declaration * string Location.loc option) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.signature_item) = let _1 =
+          let _1 = 
+# 1778 "src/ocaml/preprocess/parser_raw.mly"
+        ( let (body, ext) = _1 in (Psig_modtypesubst body, ext) )
+# 33229 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1038 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mksig_ext ~loc:_sloc _1 )
+# 33237 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1788 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 33243 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Longident.t Location.loc Parsetree.open_infos * string Location.loc option) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.signature_item) = let _1 =
+          let _1 = 
+# 1780 "src/ocaml/preprocess/parser_raw.mly"
+        ( let (body, ext) = _1 in (Psig_open body, ext) )
+# 33269 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1038 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mksig_ext ~loc:_sloc _1 )
+# 33277 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1788 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 33283 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined2;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = thing;
+            MenhirLib.EngineTypes.startp = _startpos_thing_;
+            MenhirLib.EngineTypes.endp = _endpos_thing_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = ext;
+                MenhirLib.EngineTypes.startp = _startpos_ext_;
+                MenhirLib.EngineTypes.endp = _endpos_ext_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let thing : (Parsetree.module_type) = Obj.magic thing in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined2_ in
+        let _v : (Parsetree.signature_item) = let _1 =
+          let _1 =
+            let _1 =
+              let attrs2 =
+                let _1 = _1_inlined2 in
+                
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 33341 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              let _endpos_attrs2_ = _endpos__1_inlined2_ in
+              let attrs1 =
+                let _1 = _1_inlined1 in
+                
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 33350 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              let _endpos = _endpos_attrs2_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1620 "src/ocaml/preprocess/parser_raw.mly"
+  (
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc _sloc in
+    let docs = symbol_docs _sloc in
+    Incl.mk thing ~attrs ~loc ~docs, ext
+  )
+# 33364 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 1782 "src/ocaml/preprocess/parser_raw.mly"
+        ( psig_include _1 )
+# 33370 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__1_inlined2_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1038 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mksig_ext ~loc:_sloc _1 )
+# 33380 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1788 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 33386 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = bs;
+          MenhirLib.EngineTypes.startp = _startpos_bs_;
+          MenhirLib.EngineTypes.endp = _endpos_bs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined3;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = cty;
+              MenhirLib.EngineTypes.startp = _startpos_cty_;
+              MenhirLib.EngineTypes.endp = _endpos_cty_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _7;
+                MenhirLib.EngineTypes.startp = _startpos__7_;
+                MenhirLib.EngineTypes.endp = _endpos__7_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined2;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = params;
+                    MenhirLib.EngineTypes.startp = _startpos_params_;
+                    MenhirLib.EngineTypes.endp = _endpos_params_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = virt;
+                      MenhirLib.EngineTypes.startp = _startpos_virt_;
+                      MenhirLib.EngineTypes.endp = _endpos_virt_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = _1_inlined1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _;
+                          MenhirLib.EngineTypes.semv = ext;
+                          MenhirLib.EngineTypes.startp = _startpos_ext_;
+                          MenhirLib.EngineTypes.endp = _endpos_ext_;
+                          MenhirLib.EngineTypes.next = {
+                            MenhirLib.EngineTypes.state = _menhir_s;
+                            MenhirLib.EngineTypes.semv = _1;
+                            MenhirLib.EngineTypes.startp = _startpos__1_;
+                            MenhirLib.EngineTypes.endp = _endpos__1_;
+                            MenhirLib.EngineTypes.next = _menhir_stack;
+                          };
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let bs : (Parsetree.class_type Parsetree.class_infos list) = Obj.magic bs in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let cty : (Parsetree.class_type) = Obj.magic cty in
+        let _7 : unit = Obj.magic _7 in
+        let _1_inlined2 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 33465 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined2 in
+        let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in
+        let virt : (Asttypes.virtual_flag) = Obj.magic virt in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_bs_ in
+        let _v : (Parsetree.signature_item) = let _1 =
+          let _1 =
+            let _1 =
+              let _1 =
+                let a =
+                  let attrs2 =
+                    let _1 = _1_inlined3 in
+                    
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 33485 "src/ocaml/preprocess/parser_raw.ml"
+                    
+                  in
+                  let _endpos_attrs2_ = _endpos__1_inlined3_ in
+                  let id =
+                    let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+                    let _endpos = _endpos__1_ in
+                    let _symbolstartpos = _startpos__1_ in
+                    let _sloc = (_symbolstartpos, _endpos) in
+                    
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 33497 "src/ocaml/preprocess/parser_raw.ml"
+                    
+                  in
+                  let attrs1 =
+                    let _1 = _1_inlined1 in
+                    
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 33505 "src/ocaml/preprocess/parser_raw.ml"
+                    
+                  in
+                  let _endpos = _endpos_attrs2_ in
+                  let _symbolstartpos = _startpos__1_ in
+                  let _sloc = (_symbolstartpos, _endpos) in
+                  
+# 2225 "src/ocaml/preprocess/parser_raw.mly"
+    (
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc _sloc in
+      let docs = symbol_docs _sloc in
+      ext,
+      Ci.mk id cty ~virt ~params ~attrs ~loc ~docs
+    )
+# 33520 "src/ocaml/preprocess/parser_raw.ml"
+                  
+                in
+                
+# 1211 "src/ocaml/preprocess/parser_raw.mly"
+    ( let (x, b) = a in x, b :: bs )
+# 33526 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 2213 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 33532 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 1784 "src/ocaml/preprocess/parser_raw.mly"
+        ( let (ext, l) = _1 in (Psig_class l, ext) )
+# 33538 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos_bs_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1038 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mksig_ext ~loc:_sloc _1 )
+# 33548 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1788 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 33554 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (string Location.loc option * Parsetree.class_type_declaration list) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.signature_item) = let _1 =
+          let _1 = 
+# 1786 "src/ocaml/preprocess/parser_raw.mly"
+        ( let (ext, l) = _1 in (Psig_class_type l, ext) )
+# 33580 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1038 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mksig_ext ~loc:_sloc _1 )
+# 33588 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1788 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 33594 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.constant) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.constant) = 
+# 3673 "src/ocaml/preprocess/parser_raw.mly"
+                 ( _1 )
+# 33619 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (
+# 773 "src/ocaml/preprocess/parser_raw.mly"
+       (string * char option)
+# 33646 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.constant) = 
+# 3674 "src/ocaml/preprocess/parser_raw.mly"
+                 ( let (n, m) = _2 in Pconst_integer("-" ^ n, m) )
+# 33655 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (
+# 752 "src/ocaml/preprocess/parser_raw.mly"
+       (string * char option)
+# 33682 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.constant) = 
+# 3675 "src/ocaml/preprocess/parser_raw.mly"
+                 ( let (f, m) = _2 in Pconst_float("-" ^ f, m) )
+# 33691 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (
+# 773 "src/ocaml/preprocess/parser_raw.mly"
+       (string * char option)
+# 33718 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.constant) = 
+# 3676 "src/ocaml/preprocess/parser_raw.mly"
+                 ( let (n, m) = _2 in Pconst_integer (n, m) )
+# 33727 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (
+# 752 "src/ocaml/preprocess/parser_raw.mly"
+       (string * char option)
+# 33754 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.constant) = 
+# 3677 "src/ocaml/preprocess/parser_raw.mly"
+                 ( let (f, m) = _2 in Pconst_float(f, m) )
+# 33763 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _1_inlined1 : ((Longident.t Location.loc * Parsetree.pattern) list * unit option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 =
+            let _2 =
+              let _1 = _1_inlined1 in
+              
+# 3005 "src/ocaml/preprocess/parser_raw.mly"
+    ( let fields, closed = _1 in
+      let closed = match closed with Some () -> Open | None -> Closed in
+      fields, closed )
+# 33808 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2976 "src/ocaml/preprocess/parser_raw.mly"
+      ( let (fields, closed) = _2 in
+        Ppat_record(fields, closed) )
+# 33815 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__3_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 33825 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2990 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 33831 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = ps;
+            MenhirLib.EngineTypes.startp = _startpos_ps_;
+            MenhirLib.EngineTypes.endp = _endpos_ps_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let ps : (Parsetree.pattern list) = Obj.magic ps in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 =
+            let _2 = 
+# 2999 "src/ocaml/preprocess/parser_raw.mly"
+    ( ps )
+# 33872 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let _loc__3_ = (_startpos__3_, _endpos__3_) in
+            
+# 2981 "src/ocaml/preprocess/parser_raw.mly"
+      ( fst (mktailpat _loc__3_ _2) )
+# 33878 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__3_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 33888 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2990 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 33894 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = ps;
+            MenhirLib.EngineTypes.startp = _startpos_ps_;
+            MenhirLib.EngineTypes.endp = _endpos_ps_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let ps : (Parsetree.pattern list) = Obj.magic ps in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 =
+            let _2 = 
+# 2999 "src/ocaml/preprocess/parser_raw.mly"
+    ( ps )
+# 33935 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 2985 "src/ocaml/preprocess/parser_raw.mly"
+      ( Ppat_array _2 )
+# 33940 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__3_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 33950 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2990 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 33956 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 = 
+# 2987 "src/ocaml/preprocess/parser_raw.mly"
+      ( Ppat_array [] )
+# 33989 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos__2_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 33998 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2990 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 34004 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (Parsetree.expression) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.expression) = let _endpos = _endpos__3_ in
+        let _startpos = _startpos__1_ in
+        
+# 4040 "src/ocaml/preprocess/parser_raw.mly"
+    ( Fake.Meta.code _startpos _endpos _2 )
+# 34045 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.expression) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.expression) = let _endpos = _endpos__2_ in
+        let _startpos = _startpos__1_ in
+        
+# 4042 "src/ocaml/preprocess/parser_raw.mly"
+    ( Fake.Meta.uncode _startpos _endpos _2 )
+# 34079 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (Parsetree.expression) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.expression) = let _endpos = _endpos__3_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2471 "src/ocaml/preprocess/parser_raw.mly"
+      ( reloc_exp ~loc:_sloc _2 )
+# 34121 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : (Parsetree.core_type option * Parsetree.core_type option) = Obj.magic _3 in
+        let _2 : (Parsetree.expression) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (Parsetree.expression) = let _endpos = _endpos__4_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2477 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkexp_constraint ~loc:_sloc _2 _3 )
+# 34170 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = i;
+            MenhirLib.EngineTypes.startp = _startpos_i_;
+            MenhirLib.EngineTypes.endp = _endpos_i_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = d;
+                MenhirLib.EngineTypes.startp = _startpos_d_;
+                MenhirLib.EngineTypes.endp = _endpos_d_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = array;
+                  MenhirLib.EngineTypes.startp = _startpos_array_;
+                  MenhirLib.EngineTypes.endp = _endpos_array_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let i : (Parsetree.expression) = Obj.magic i in
+        let _3 : unit = Obj.magic _3 in
+        let d : unit = Obj.magic d in
+        let array : (Parsetree.expression) = Obj.magic array in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_array_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let r = 
+# 2478 "src/ocaml/preprocess/parser_raw.mly"
+                                ( None )
+# 34224 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          
+# 2355 "src/ocaml/preprocess/parser_raw.mly"
+    ( array, d, Paren,   i, r )
+# 34229 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2479 "src/ocaml/preprocess/parser_raw.mly"
+      ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 )
+# 34239 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = i;
+            MenhirLib.EngineTypes.startp = _startpos_i_;
+            MenhirLib.EngineTypes.endp = _endpos_i_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = d;
+                MenhirLib.EngineTypes.startp = _startpos_d_;
+                MenhirLib.EngineTypes.endp = _endpos_d_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = array;
+                  MenhirLib.EngineTypes.startp = _startpos_array_;
+                  MenhirLib.EngineTypes.endp = _endpos_array_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let i : (Parsetree.expression) = Obj.magic i in
+        let _3 : unit = Obj.magic _3 in
+        let d : unit = Obj.magic d in
+        let array : (Parsetree.expression) = Obj.magic array in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_array_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let r = 
+# 2478 "src/ocaml/preprocess/parser_raw.mly"
+                                ( None )
+# 34293 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          
+# 2357 "src/ocaml/preprocess/parser_raw.mly"
+    ( array, d, Brace,   i, r )
+# 34298 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2479 "src/ocaml/preprocess/parser_raw.mly"
+      ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 )
+# 34308 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = i;
+            MenhirLib.EngineTypes.startp = _startpos_i_;
+            MenhirLib.EngineTypes.endp = _endpos_i_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = d;
+                MenhirLib.EngineTypes.startp = _startpos_d_;
+                MenhirLib.EngineTypes.endp = _endpos_d_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = array;
+                  MenhirLib.EngineTypes.startp = _startpos_array_;
+                  MenhirLib.EngineTypes.endp = _endpos_array_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let i : (Parsetree.expression) = Obj.magic i in
+        let _3 : unit = Obj.magic _3 in
+        let d : unit = Obj.magic d in
+        let array : (Parsetree.expression) = Obj.magic array in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_array_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let r = 
+# 2478 "src/ocaml/preprocess/parser_raw.mly"
+                                ( None )
+# 34362 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          
+# 2359 "src/ocaml/preprocess/parser_raw.mly"
+    ( array, d, Bracket, i, r )
+# 34367 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2479 "src/ocaml/preprocess/parser_raw.mly"
+      ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 )
+# 34377 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = es;
+            MenhirLib.EngineTypes.startp = _startpos_es_;
+            MenhirLib.EngineTypes.endp = _endpos_es_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = array;
+                  MenhirLib.EngineTypes.startp = _startpos_array_;
+                  MenhirLib.EngineTypes.endp = _endpos_array_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let es : (Parsetree.expression list) = Obj.magic es in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (
+# 768 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 34425 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _2 in
+        let array : (Parsetree.expression) = Obj.magic array in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_array_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let r = 
+# 2480 "src/ocaml/preprocess/parser_raw.mly"
+                                                  ( None )
+# 34435 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let i = 
+# 2827 "src/ocaml/preprocess/parser_raw.mly"
+    ( es )
+# 34440 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let d =
+            let _1 = 
+# 124 "<standard.mly>"
+    ( None )
+# 34446 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 2371 "src/ocaml/preprocess/parser_raw.mly"
+                                                               ( _1, _2 )
+# 34451 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2355 "src/ocaml/preprocess/parser_raw.mly"
+    ( array, d, Paren,   i, r )
+# 34457 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2481 "src/ocaml/preprocess/parser_raw.mly"
+      ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 )
+# 34467 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = es;
+            MenhirLib.EngineTypes.startp = _startpos_es_;
+            MenhirLib.EngineTypes.endp = _endpos_es_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _2_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__2_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__2_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = array;
+                      MenhirLib.EngineTypes.startp = _startpos_array_;
+                      MenhirLib.EngineTypes.endp = _endpos_array_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let es : (Parsetree.expression list) = Obj.magic es in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (
+# 768 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 34527 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _2 in
+        let _2_inlined1 : (Longident.t) = Obj.magic _2_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let array : (Parsetree.expression) = Obj.magic array in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_array_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let r = 
+# 2480 "src/ocaml/preprocess/parser_raw.mly"
+                                                  ( None )
+# 34539 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let i = 
+# 2827 "src/ocaml/preprocess/parser_raw.mly"
+    ( es )
+# 34544 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let d =
+            let _1 =
+              let _2 = _2_inlined1 in
+              let x = 
+# 2371 "src/ocaml/preprocess/parser_raw.mly"
+                                                   (_2)
+# 34552 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              
+# 126 "<standard.mly>"
+    ( Some x )
+# 34557 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2371 "src/ocaml/preprocess/parser_raw.mly"
+                                                               ( _1, _2 )
+# 34563 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2355 "src/ocaml/preprocess/parser_raw.mly"
+    ( array, d, Paren,   i, r )
+# 34569 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2481 "src/ocaml/preprocess/parser_raw.mly"
+      ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 )
+# 34579 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = es;
+            MenhirLib.EngineTypes.startp = _startpos_es_;
+            MenhirLib.EngineTypes.endp = _endpos_es_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = array;
+                  MenhirLib.EngineTypes.startp = _startpos_array_;
+                  MenhirLib.EngineTypes.endp = _endpos_array_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let es : (Parsetree.expression list) = Obj.magic es in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (
+# 768 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 34627 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _2 in
+        let array : (Parsetree.expression) = Obj.magic array in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_array_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let r = 
+# 2480 "src/ocaml/preprocess/parser_raw.mly"
+                                                  ( None )
+# 34637 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let i = 
+# 2827 "src/ocaml/preprocess/parser_raw.mly"
+    ( es )
+# 34642 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let d =
+            let _1 = 
+# 124 "<standard.mly>"
+    ( None )
+# 34648 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 2371 "src/ocaml/preprocess/parser_raw.mly"
+                                                               ( _1, _2 )
+# 34653 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2357 "src/ocaml/preprocess/parser_raw.mly"
+    ( array, d, Brace,   i, r )
+# 34659 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2481 "src/ocaml/preprocess/parser_raw.mly"
+      ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 )
+# 34669 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = es;
+            MenhirLib.EngineTypes.startp = _startpos_es_;
+            MenhirLib.EngineTypes.endp = _endpos_es_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _2_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__2_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__2_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = array;
+                      MenhirLib.EngineTypes.startp = _startpos_array_;
+                      MenhirLib.EngineTypes.endp = _endpos_array_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let es : (Parsetree.expression list) = Obj.magic es in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (
+# 768 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 34729 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _2 in
+        let _2_inlined1 : (Longident.t) = Obj.magic _2_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let array : (Parsetree.expression) = Obj.magic array in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_array_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let r = 
+# 2480 "src/ocaml/preprocess/parser_raw.mly"
+                                                  ( None )
+# 34741 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let i = 
+# 2827 "src/ocaml/preprocess/parser_raw.mly"
+    ( es )
+# 34746 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let d =
+            let _1 =
+              let _2 = _2_inlined1 in
+              let x = 
+# 2371 "src/ocaml/preprocess/parser_raw.mly"
+                                                   (_2)
+# 34754 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              
+# 126 "<standard.mly>"
+    ( Some x )
+# 34759 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2371 "src/ocaml/preprocess/parser_raw.mly"
+                                                               ( _1, _2 )
+# 34765 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2357 "src/ocaml/preprocess/parser_raw.mly"
+    ( array, d, Brace,   i, r )
+# 34771 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2481 "src/ocaml/preprocess/parser_raw.mly"
+      ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 )
+# 34781 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = es;
+            MenhirLib.EngineTypes.startp = _startpos_es_;
+            MenhirLib.EngineTypes.endp = _endpos_es_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = array;
+                  MenhirLib.EngineTypes.startp = _startpos_array_;
+                  MenhirLib.EngineTypes.endp = _endpos_array_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let es : (Parsetree.expression list) = Obj.magic es in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (
+# 768 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 34829 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _2 in
+        let array : (Parsetree.expression) = Obj.magic array in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_array_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let r = 
+# 2480 "src/ocaml/preprocess/parser_raw.mly"
+                                                  ( None )
+# 34839 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let i = 
+# 2827 "src/ocaml/preprocess/parser_raw.mly"
+    ( es )
+# 34844 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let d =
+            let _1 = 
+# 124 "<standard.mly>"
+    ( None )
+# 34850 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 2371 "src/ocaml/preprocess/parser_raw.mly"
+                                                               ( _1, _2 )
+# 34855 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2359 "src/ocaml/preprocess/parser_raw.mly"
+    ( array, d, Bracket, i, r )
+# 34861 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2481 "src/ocaml/preprocess/parser_raw.mly"
+      ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 )
+# 34871 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = es;
+            MenhirLib.EngineTypes.startp = _startpos_es_;
+            MenhirLib.EngineTypes.endp = _endpos_es_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _2_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__2_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__2_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = array;
+                      MenhirLib.EngineTypes.startp = _startpos_array_;
+                      MenhirLib.EngineTypes.endp = _endpos_array_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let es : (Parsetree.expression list) = Obj.magic es in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (
+# 768 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 34931 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _2 in
+        let _2_inlined1 : (Longident.t) = Obj.magic _2_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let array : (Parsetree.expression) = Obj.magic array in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_array_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let r = 
+# 2480 "src/ocaml/preprocess/parser_raw.mly"
+                                                  ( None )
+# 34943 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let i = 
+# 2827 "src/ocaml/preprocess/parser_raw.mly"
+    ( es )
+# 34948 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let d =
+            let _1 =
+              let _2 = _2_inlined1 in
+              let x = 
+# 2371 "src/ocaml/preprocess/parser_raw.mly"
+                                                   (_2)
+# 34956 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              
+# 126 "<standard.mly>"
+    ( Some x )
+# 34961 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2371 "src/ocaml/preprocess/parser_raw.mly"
+                                                               ( _1, _2 )
+# 34967 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2359 "src/ocaml/preprocess/parser_raw.mly"
+    ( array, d, Bracket, i, r )
+# 34973 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2481 "src/ocaml/preprocess/parser_raw.mly"
+      ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 )
+# 34983 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = e;
+            MenhirLib.EngineTypes.startp = _startpos_e_;
+            MenhirLib.EngineTypes.endp = _endpos_e_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = ext;
+                MenhirLib.EngineTypes.startp = _startpos_ext_;
+                MenhirLib.EngineTypes.endp = _endpos_ext_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let e : (Parsetree.expression) = Obj.magic e in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let attrs =
+            let _1 = _1_inlined1 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 35039 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2494 "src/ocaml/preprocess/parser_raw.mly"
+      ( e.pexp_desc, (ext, attrs @ e.pexp_attributes) )
+# 35045 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__1_ = _endpos__5_ in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2487 "src/ocaml/preprocess/parser_raw.mly"
+    ( let desc, attrs = _1 in
+      mkexp_attrs ~loc:_sloc desc attrs )
+# 35056 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined2;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _2 =
+            let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+            let _2 =
+              let _1 = _1_inlined1 in
+              
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 35107 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 35113 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos__3_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 2496 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_construct (mkloc (Lident "()") (make_loc _sloc), None), _2 )
+# 35122 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__1_ = _endpos__3_ in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2487 "src/ocaml/preprocess/parser_raw.mly"
+    ( let desc, attrs = _1 in
+      mkexp_attrs ~loc:_sloc desc attrs )
+# 35133 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined3;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined2;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined3 : (Longident.t) = Obj.magic _1_inlined3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined3_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _3 =
+            let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 35185 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _2 =
+            let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+            let _2 =
+              let _1 = _1_inlined1 in
+              
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 35195 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 35201 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2502 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_new(_3), _2 )
+# 35207 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__1_ = _endpos__1_inlined3_ in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2487 "src/ocaml/preprocess/parser_raw.mly"
+    ( let desc, attrs = _1 in
+      mkexp_attrs ~loc:_sloc desc attrs )
+# 35218 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined2;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined1;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _2;
+                  MenhirLib.EngineTypes.startp = _startpos__2_;
+                  MenhirLib.EngineTypes.endp = _endpos__2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let _4 : (Parsetree.module_expr) = Obj.magic _4 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _3 =
+            let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+            let _2 =
+              let _1 = _1_inlined1 in
+              
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 35283 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 35289 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 2504 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_pack _4, _3 )
+# 35295 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__1_ = _endpos__5_ in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2487 "src/ocaml/preprocess/parser_raw.mly"
+    ( let desc, attrs = _1 in
+      mkexp_attrs ~loc:_sloc desc attrs )
+# 35306 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _7;
+          MenhirLib.EngineTypes.startp = _startpos__7_;
+          MenhirLib.EngineTypes.endp = _endpos__7_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined3;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _5;
+              MenhirLib.EngineTypes.startp = _startpos__5_;
+              MenhirLib.EngineTypes.endp = _endpos__5_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _4;
+                MenhirLib.EngineTypes.startp = _startpos__4_;
+                MenhirLib.EngineTypes.endp = _endpos__4_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined2;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1_inlined1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _2;
+                      MenhirLib.EngineTypes.startp = _startpos__2_;
+                      MenhirLib.EngineTypes.endp = _endpos__2_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _menhir_s;
+                        MenhirLib.EngineTypes.semv = _1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_;
+                        MenhirLib.EngineTypes.next = _menhir_stack;
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _7 : unit = Obj.magic _7 in
+        let _1_inlined3 : (Parsetree.module_type) = Obj.magic _1_inlined3 in
+        let _5 : unit = Obj.magic _5 in
+        let _4 : (Parsetree.module_expr) = Obj.magic _4 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__7_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _6 =
+            let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 3587 "src/ocaml/preprocess/parser_raw.mly"
+      ( let (lid, cstrs, attrs) = package_type_of_module_type _1 in
+        let descr = Ptyp_package (lid, cstrs) in
+        mktyp ~loc:_sloc ~attrs descr )
+# 35388 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _3 =
+            let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+            let _2 =
+              let _1 = _1_inlined1 in
+              
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 35398 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 35404 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos__7_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 2506 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_constraint (ghexp ~loc:_sloc (Pexp_pack _4), _6), _3 )
+# 35413 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__1_ = _endpos__7_ in
+        let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2487 "src/ocaml/preprocess/parser_raw.mly"
+    ( let desc, attrs = _1 in
+      mkexp_attrs ~loc:_sloc desc attrs )
+# 35424 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let _1 =
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 35455 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2514 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_ident (_1) )
+# 35461 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 35470 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 35476 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.constant) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 = 
+# 2516 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_constant _1 )
+# 35502 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 35510 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 35516 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let _1 =
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 35547 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2518 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_construct(_1, None) )
+# 35553 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 35562 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 35568 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 = 
+# 2520 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_variant(_1, None) )
+# 35594 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 35602 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 35608 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.expression) = Obj.magic _2 in
+        let _1 : (
+# 811 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 35636 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let _1 =
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1007 "src/ocaml/preprocess/parser_raw.mly"
+   ( mkoperator ~loc:_sloc _1 )
+# 35650 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2522 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_apply(_1, [Nolabel,_2]) )
+# 35656 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__2_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 35666 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 35672 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.expression) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let _1 =
+              let _1 = 
+# 2523 "src/ocaml/preprocess/parser_raw.mly"
+            ("!")
+# 35707 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1007 "src/ocaml/preprocess/parser_raw.mly"
+   ( mkoperator ~loc:_sloc _1 )
+# 35715 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2524 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_apply(_1, [Nolabel,_2]) )
+# 35721 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__2_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 35731 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 35737 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = xs;
+            MenhirLib.EngineTypes.startp = _startpos_xs_;
+            MenhirLib.EngineTypes.endp = _endpos_xs_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let xs : ((string Location.loc * Parsetree.expression) list) = Obj.magic xs in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let _2 = 
+# 2810 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 35778 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 2526 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_override _2 )
+# 35783 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__3_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 35793 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 35799 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 = 
+# 2532 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_override [] )
+# 35832 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos__2_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 35841 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 35847 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (Longident.t) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.expression) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let _3 =
+              let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 35893 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2534 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_field(_1, _3) )
+# 35899 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__1_inlined1_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 35909 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 35915 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let _4 : (Parsetree.expression) = Obj.magic _4 in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let od =
+              let _1 =
+                let _endpos = _endpos__1_ in
+                let _symbolstartpos = _startpos__1_ in
+                let _sloc = (_symbolstartpos, _endpos) in
+                
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 35975 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              let _loc__1_ = (_startpos__1_, _endpos__1_) in
+              
+# 1679 "src/ocaml/preprocess/parser_raw.mly"
+  ( let loc = make_loc _loc__1_ in
+    let me = Mod.ident ~loc _1 in
+    Opn.mk ~loc me )
+# 35984 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2536 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_open(od, _4) )
+# 35990 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__5_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 36000 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 36006 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = xs;
+            MenhirLib.EngineTypes.startp = _startpos_xs_;
+            MenhirLib.EngineTypes.endp = _endpos_xs_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let xs : ((string Location.loc * Parsetree.expression) list) = Obj.magic xs in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let _4 = 
+# 2810 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 36061 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let od =
+              let _1 =
+                let _endpos = _endpos__1_ in
+                let _symbolstartpos = _startpos__1_ in
+                let _sloc = (_symbolstartpos, _endpos) in
+                
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 36071 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              let _loc__1_ = (_startpos__1_, _endpos__1_) in
+              
+# 1679 "src/ocaml/preprocess/parser_raw.mly"
+  ( let loc = make_loc _loc__1_ in
+    let me = Mod.ident ~loc _1 in
+    Opn.mk ~loc me )
+# 36080 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let _startpos_od_ = _startpos__1_ in
+            let _endpos = _endpos__5_ in
+            let _symbolstartpos = _startpos_od_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 2538 "src/ocaml/preprocess/parser_raw.mly"
+      ( (* TODO: review the location of Pexp_override *)
+        Pexp_open(od, mkexp ~loc:_sloc (Pexp_override _4)) )
+# 36091 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__5_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 36101 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 36107 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 36140 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.expression) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let _3 =
+              let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+              let _1 = 
+# 3661 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 36154 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 36162 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2545 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_send(_1, _3) )
+# 36168 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__1_inlined1_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 36178 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 36184 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.expression) = Obj.magic _3 in
+        let _1_inlined1 : (
+# 822 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 36218 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined1 in
+        let _1 : (Parsetree.expression) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let _2 =
+              let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1007 "src/ocaml/preprocess/parser_raw.mly"
+   ( mkoperator ~loc:_sloc _1 )
+# 36234 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2547 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkinfix _1 _2 _3 )
+# 36240 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__3_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 36250 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 36256 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.extension) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 = 
+# 2549 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_extension _1 )
+# 36282 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 36290 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 36296 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let _endpos = _endpos__1_ in
+            let _startpos = _startpos__1_ in
+            let _loc = (_startpos, _endpos) in
+            
+# 2551 "src/ocaml/preprocess/parser_raw.mly"
+      ( let id = mkrhs Ast_helper.hole_txt _loc in
+        Pexp_extension (id, PStr []) )
+# 36327 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 36336 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 36342 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__2_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__2_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _2_inlined1 : unit = Obj.magic _2_inlined1 in
+        let _1_inlined1 : unit = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_inlined1_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let _3 =
+              let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in
+              let _1 = 
+# 2553 "src/ocaml/preprocess/parser_raw.mly"
+                                                    (Lident "()")
+# 36392 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let _endpos__1_ = _endpos__2_ in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 36401 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let (_endpos__3_, _startpos__3_) = (_endpos__2_inlined1_, _startpos__1_inlined1_) in
+            let od =
+              let _1 =
+                let _endpos = _endpos__1_ in
+                let _symbolstartpos = _startpos__1_ in
+                let _sloc = (_symbolstartpos, _endpos) in
+                
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 36413 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              let _loc__1_ = (_startpos__1_, _endpos__1_) in
+              
+# 1679 "src/ocaml/preprocess/parser_raw.mly"
+  ( let loc = make_loc _loc__1_ in
+    let me = Mod.ident ~loc _1 in
+    Opn.mk ~loc me )
+# 36422 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let _loc__3_ = (_startpos__3_, _endpos__3_) in
+            
+# 2554 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_open(od, mkexp ~loc:(_loc__3_) (Pexp_construct(_3, None))) )
+# 36429 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__2_inlined1_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 36439 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 36445 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (Parsetree.expression option *
+  (Longident.t Location.loc * Parsetree.expression) list) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 = 
+# 2560 "src/ocaml/preprocess/parser_raw.mly"
+      ( let (exten, fields) = _2 in
+        Pexp_record(fields, exten) )
+# 36487 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos__3_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 36496 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 36502 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let _4 : (Parsetree.expression option *
+  (Longident.t Location.loc * Parsetree.expression) list) = Obj.magic _4 in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let od =
+              let _1 =
+                let _endpos = _endpos__1_ in
+                let _symbolstartpos = _startpos__1_ in
+                let _sloc = (_symbolstartpos, _endpos) in
+                
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 36563 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              let _loc__1_ = (_startpos__1_, _endpos__1_) in
+              
+# 1679 "src/ocaml/preprocess/parser_raw.mly"
+  ( let loc = make_loc _loc__1_ in
+    let me = Mod.ident ~loc _1 in
+    Opn.mk ~loc me )
+# 36572 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let _endpos = _endpos__5_ in
+            
+# 2567 "src/ocaml/preprocess/parser_raw.mly"
+      ( let (exten, fields) = _4 in
+        Pexp_open(od, mkexp ~loc:(_startpos__3_, _endpos)
+                        (Pexp_record(fields, exten))) )
+# 36581 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__5_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 36591 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 36597 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = es;
+            MenhirLib.EngineTypes.startp = _startpos_es_;
+            MenhirLib.EngineTypes.endp = _endpos_es_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let es : (Parsetree.expression list) = Obj.magic es in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let _2 = 
+# 2827 "src/ocaml/preprocess/parser_raw.mly"
+    ( es )
+# 36638 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 2575 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_array(_2) )
+# 36643 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__3_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 36653 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 36659 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 = 
+# 2581 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_array [] )
+# 36692 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos__2_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 36701 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 36707 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = es;
+            MenhirLib.EngineTypes.startp = _startpos_es_;
+            MenhirLib.EngineTypes.endp = _endpos_es_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let es : (Parsetree.expression list) = Obj.magic es in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let _4 = 
+# 2827 "src/ocaml/preprocess/parser_raw.mly"
+    ( es )
+# 36762 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let od =
+              let _1 =
+                let _endpos = _endpos__1_ in
+                let _symbolstartpos = _startpos__1_ in
+                let _sloc = (_symbolstartpos, _endpos) in
+                
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 36772 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              let _loc__1_ = (_startpos__1_, _endpos__1_) in
+              
+# 1679 "src/ocaml/preprocess/parser_raw.mly"
+  ( let loc = make_loc _loc__1_ in
+    let me = Mod.ident ~loc _1 in
+    Opn.mk ~loc me )
+# 36781 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let _endpos = _endpos__5_ in
+            
+# 2583 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_open(od, mkexp ~loc:(_startpos__3_, _endpos) (Pexp_array(_4))) )
+# 36788 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__5_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 36798 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 36804 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let od =
+              let _1 =
+                let _endpos = _endpos__1_ in
+                let _symbolstartpos = _startpos__1_ in
+                let _sloc = (_symbolstartpos, _endpos) in
+                
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 36857 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              let _loc__1_ = (_startpos__1_, _endpos__1_) in
+              
+# 1679 "src/ocaml/preprocess/parser_raw.mly"
+  ( let loc = make_loc _loc__1_ in
+    let me = Mod.ident ~loc _1 in
+    Opn.mk ~loc me )
+# 36866 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let _endpos = _endpos__4_ in
+            
+# 2585 "src/ocaml/preprocess/parser_raw.mly"
+      ( (* TODO: review the location of Pexp_array *)
+        Pexp_open(od, mkexp ~loc:(_startpos__3_, _endpos) (Pexp_array [])) )
+# 36874 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__4_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 36884 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 36890 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = es;
+            MenhirLib.EngineTypes.startp = _startpos_es_;
+            MenhirLib.EngineTypes.endp = _endpos_es_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let es : (Parsetree.expression list) = Obj.magic es in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let _2 = 
+# 2827 "src/ocaml/preprocess/parser_raw.mly"
+    ( es )
+# 36931 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let _loc__3_ = (_startpos__3_, _endpos__3_) in
+            
+# 2593 "src/ocaml/preprocess/parser_raw.mly"
+      ( fst (mktailexp _loc__3_ _2) )
+# 36937 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__3_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 36947 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 36953 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = es;
+            MenhirLib.EngineTypes.startp = _startpos_es_;
+            MenhirLib.EngineTypes.endp = _endpos_es_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let es : (Parsetree.expression list) = Obj.magic es in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let _4 = 
+# 2827 "src/ocaml/preprocess/parser_raw.mly"
+    ( es )
+# 37008 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let od =
+              let _1 =
+                let _endpos = _endpos__1_ in
+                let _symbolstartpos = _startpos__1_ in
+                let _sloc = (_symbolstartpos, _endpos) in
+                
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 37018 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              let _loc__1_ = (_startpos__1_, _endpos__1_) in
+              
+# 1679 "src/ocaml/preprocess/parser_raw.mly"
+  ( let loc = make_loc _loc__1_ in
+    let me = Mod.ident ~loc _1 in
+    Opn.mk ~loc me )
+# 37027 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let _endpos = _endpos__5_ in
+            let _loc__5_ = (_startpos__5_, _endpos__5_) in
+            
+# 2599 "src/ocaml/preprocess/parser_raw.mly"
+      ( let list_exp =
+          (* TODO: review the location of list_exp *)
+          let tail_exp, _tail_loc = mktailexp _loc__5_ _4 in
+          mkexp ~loc:(_startpos__3_, _endpos) tail_exp in
+        Pexp_open(od, list_exp) )
+# 37039 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__5_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 37049 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 37055 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__2_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__2_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _2_inlined1 : unit = Obj.magic _2_inlined1 in
+        let _1_inlined1 : unit = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_inlined1_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let _3 =
+              let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in
+              let _1 = 
+# 2604 "src/ocaml/preprocess/parser_raw.mly"
+                                                        (Lident "[]")
+# 37105 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let _endpos__1_ = _endpos__2_ in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 37114 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let (_endpos__3_, _startpos__3_) = (_endpos__2_inlined1_, _startpos__1_inlined1_) in
+            let od =
+              let _1 =
+                let _endpos = _endpos__1_ in
+                let _symbolstartpos = _startpos__1_ in
+                let _sloc = (_symbolstartpos, _endpos) in
+                
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 37126 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              let _loc__1_ = (_startpos__1_, _endpos__1_) in
+              
+# 1679 "src/ocaml/preprocess/parser_raw.mly"
+  ( let loc = make_loc _loc__1_ in
+    let me = Mod.ident ~loc _1 in
+    Opn.mk ~loc me )
+# 37135 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let _loc__3_ = (_startpos__3_, _endpos__3_) in
+            
+# 2605 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pexp_open(od, mkexp ~loc:_loc__3_ (Pexp_construct(_3, None))) )
+# 37142 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__2_inlined1_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 37152 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 37158 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _9;
+          MenhirLib.EngineTypes.startp = _startpos__9_;
+          MenhirLib.EngineTypes.endp = _endpos__9_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined3;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _7;
+              MenhirLib.EngineTypes.startp = _startpos__7_;
+              MenhirLib.EngineTypes.endp = _endpos__7_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _6;
+                MenhirLib.EngineTypes.startp = _startpos__6_;
+                MenhirLib.EngineTypes.endp = _endpos__6_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined2;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1_inlined1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _4;
+                      MenhirLib.EngineTypes.startp = _startpos__4_;
+                      MenhirLib.EngineTypes.endp = _endpos__4_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = _3;
+                        MenhirLib.EngineTypes.startp = _startpos__3_;
+                        MenhirLib.EngineTypes.endp = _endpos__3_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _;
+                          MenhirLib.EngineTypes.semv = _2;
+                          MenhirLib.EngineTypes.startp = _startpos__2_;
+                          MenhirLib.EngineTypes.endp = _endpos__2_;
+                          MenhirLib.EngineTypes.next = {
+                            MenhirLib.EngineTypes.state = _menhir_s;
+                            MenhirLib.EngineTypes.semv = _1;
+                            MenhirLib.EngineTypes.startp = _startpos__1_;
+                            MenhirLib.EngineTypes.endp = _endpos__1_;
+                            MenhirLib.EngineTypes.next = _menhir_stack;
+                          };
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _9 : unit = Obj.magic _9 in
+        let _1_inlined3 : (Parsetree.module_type) = Obj.magic _1_inlined3 in
+        let _7 : unit = Obj.magic _7 in
+        let _6 : (Parsetree.module_expr) = Obj.magic _6 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _4 : unit = Obj.magic _4 in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__9_ in
+        let _v : (Parsetree.expression) = let _1 =
+          let _1 =
+            let _8 =
+              let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 3587 "src/ocaml/preprocess/parser_raw.mly"
+      ( let (lid, cstrs, attrs) = package_type_of_module_type _1 in
+        let descr = Ptyp_package (lid, cstrs) in
+        mktyp ~loc:_sloc ~attrs descr )
+# 37255 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let _5 =
+              let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+              let _2 =
+                let _1 = _1_inlined1 in
+                
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 37265 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 37271 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let od =
+              let _1 =
+                let _endpos = _endpos__1_ in
+                let _symbolstartpos = _startpos__1_ in
+                let _sloc = (_symbolstartpos, _endpos) in
+                
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 37282 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              let _loc__1_ = (_startpos__1_, _endpos__1_) in
+              
+# 1679 "src/ocaml/preprocess/parser_raw.mly"
+  ( let loc = make_loc _loc__1_ in
+    let me = Mod.ident ~loc _1 in
+    Opn.mk ~loc me )
+# 37291 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let _startpos_od_ = _startpos__1_ in
+            let _endpos = _endpos__9_ in
+            let _symbolstartpos = _startpos_od_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 2613 "src/ocaml/preprocess/parser_raw.mly"
+      ( let modexp =
+          mkexp_attrs ~loc:(_startpos__3_, _endpos)
+            (Pexp_constraint (ghexp ~loc:_sloc (Pexp_pack _6), _8)) _5 in
+        Pexp_open(od, modexp) )
+# 37304 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__9_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1013 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkexp ~loc:_sloc _1 )
+# 37314 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2490 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 37320 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 =
+            let _1 =
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 37351 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2910 "src/ocaml/preprocess/parser_raw.mly"
+      ( Ppat_var (_1) )
+# 37357 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 37366 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2911 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 37372 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.pattern) = 
+# 2912 "src/ocaml/preprocess/parser_raw.mly"
+                             ( _1 )
+# 37397 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (Parsetree.pattern) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.pattern) = let _endpos = _endpos__3_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2917 "src/ocaml/preprocess/parser_raw.mly"
+      ( reloc_pat ~loc:_sloc _2 )
+# 37439 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.pattern) = 
+# 2919 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 37464 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined3;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined2;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined1;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _2;
+                  MenhirLib.EngineTypes.startp = _startpos__2_;
+                  MenhirLib.EngineTypes.endp = _endpos__2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let _1_inlined3 : (string option) = Obj.magic _1_inlined3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.pattern) = let _4 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 37529 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _3 =
+          let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+          let _2 =
+            let _1 = _1_inlined1 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 37539 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 37545 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__5_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2921 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkpat_attrs ~loc:_sloc (Ppat_unpack _4) _3 )
+# 37554 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _7;
+          MenhirLib.EngineTypes.startp = _startpos__7_;
+          MenhirLib.EngineTypes.endp = _endpos__7_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined4;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined4_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _5;
+              MenhirLib.EngineTypes.startp = _startpos__5_;
+              MenhirLib.EngineTypes.endp = _endpos__5_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined3;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined2;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1_inlined1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _2;
+                      MenhirLib.EngineTypes.startp = _startpos__2_;
+                      MenhirLib.EngineTypes.endp = _endpos__2_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _menhir_s;
+                        MenhirLib.EngineTypes.semv = _1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_;
+                        MenhirLib.EngineTypes.next = _menhir_stack;
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _7 : unit = Obj.magic _7 in
+        let _1_inlined4 : (Parsetree.module_type) = Obj.magic _1_inlined4 in
+        let _5 : unit = Obj.magic _5 in
+        let _1_inlined3 : (string option) = Obj.magic _1_inlined3 in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string Location.loc option) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__7_ in
+        let _v : (Parsetree.pattern) = let _6 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined4_, _startpos__1_inlined4_, _1_inlined4) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 3587 "src/ocaml/preprocess/parser_raw.mly"
+      ( let (lid, cstrs, attrs) = package_type_of_module_type _1 in
+        let descr = Ptyp_package (lid, cstrs) in
+        mktyp ~loc:_sloc ~attrs descr )
+# 37635 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _4 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 37646 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let (_endpos__4_, _startpos__4_) = (_endpos__1_inlined3_, _startpos__1_inlined3_) in
+        let _3 =
+          let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in
+          let _2 =
+            let _1 = _1_inlined1 in
+            
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 37657 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 4018 "src/ocaml/preprocess/parser_raw.mly"
+                    ( _1, _2 )
+# 37663 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__7_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _loc__4_ = (_startpos__4_, _endpos__4_) in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2923 "src/ocaml/preprocess/parser_raw.mly"
+      ( mkpat_attrs ~loc:_sloc
+          (Ppat_constraint(mkpat ~loc:_loc__4_ (Ppat_unpack _4), _6))
+          _3 )
+# 37675 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 = 
+# 2931 "src/ocaml/preprocess/parser_raw.mly"
+      ( Ppat_any )
+# 37701 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 37709 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2927 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 37715 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.constant) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 = 
+# 2933 "src/ocaml/preprocess/parser_raw.mly"
+      ( Ppat_constant _1 )
+# 37741 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 37749 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2927 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 37755 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.constant) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.constant) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 = 
+# 2935 "src/ocaml/preprocess/parser_raw.mly"
+      ( Ppat_interval (_1, _3) )
+# 37795 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos__3_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 37804 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2927 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 37810 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 =
+            let _1 =
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 37841 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2937 "src/ocaml/preprocess/parser_raw.mly"
+      ( Ppat_construct(_1, None) )
+# 37847 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 37856 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2927 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 37862 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 = 
+# 2939 "src/ocaml/preprocess/parser_raw.mly"
+      ( Ppat_variant(_1, None) )
+# 37888 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 37896 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2927 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 37902 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (Longident.t) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 =
+            let _2 =
+              let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 37941 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2941 "src/ocaml/preprocess/parser_raw.mly"
+      ( Ppat_type (_2) )
+# 37947 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__1_inlined1_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 37957 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2927 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 37963 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : (Parsetree.pattern) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 =
+            let _1 =
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 38008 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2943 "src/ocaml/preprocess/parser_raw.mly"
+      ( Ppat_open(_1, _3) )
+# 38014 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__3_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 38024 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2927 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 38030 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__2_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__2_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _2_inlined1 : unit = Obj.magic _2_inlined1 in
+        let _1_inlined1 : unit = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_inlined1_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 =
+            let _3 =
+              let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in
+              let _1 = 
+# 2944 "src/ocaml/preprocess/parser_raw.mly"
+                                                     (Lident "[]")
+# 38080 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let _endpos__1_ = _endpos__2_ in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 38089 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let _endpos__3_ = _endpos__2_inlined1_ in
+            let _1 =
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 38100 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let _endpos = _endpos__3_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 2945 "src/ocaml/preprocess/parser_raw.mly"
+    ( Ppat_open(_1, mkpat ~loc:_sloc (Ppat_construct(_3, None))) )
+# 38109 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__2_inlined1_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 38119 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2927 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 38125 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__2_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__2_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _2_inlined1 : unit = Obj.magic _2_inlined1 in
+        let _1_inlined1 : unit = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_inlined1_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 =
+            let _3 =
+              let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in
+              let _1 = 
+# 2946 "src/ocaml/preprocess/parser_raw.mly"
+                                                 (Lident "()")
+# 38175 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              let _endpos__1_ = _endpos__2_ in
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 38184 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let _endpos__3_ = _endpos__2_inlined1_ in
+            let _1 =
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 38195 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let _endpos = _endpos__3_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 2947 "src/ocaml/preprocess/parser_raw.mly"
+    ( Ppat_open(_1, mkpat ~loc:_sloc (Ppat_construct(_3, None))) )
+# 38204 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__2_inlined1_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 38214 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2927 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 38220 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let _4 : (Parsetree.pattern) = Obj.magic _4 in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 =
+            let _1 =
+              let _endpos = _endpos__1_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 38279 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 2949 "src/ocaml/preprocess/parser_raw.mly"
+      ( Ppat_open (_1, _4) )
+# 38285 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__5_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 38295 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2927 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 38301 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : unit = Obj.magic _5 in
+        let _4 : (Parsetree.core_type) = Obj.magic _4 in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (Parsetree.pattern) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 = 
+# 2959 "src/ocaml/preprocess/parser_raw.mly"
+      ( Ppat_constraint(_2, _4) )
+# 38355 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos__5_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 38364 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2927 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 38370 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.extension) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.pattern) = let _1 =
+          let _1 = 
+# 2970 "src/ocaml/preprocess/parser_raw.mly"
+      ( Ppat_extension _1 )
+# 38396 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1015 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkpat ~loc:_sloc _1 )
+# 38404 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 2927 "src/ocaml/preprocess/parser_raw.mly"
+      ( _1 )
+# 38410 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 38431 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3926 "src/ocaml/preprocess/parser_raw.mly"
+           ( _1 )
+# 38439 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 839 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 38460 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3927 "src/ocaml/preprocess/parser_raw.mly"
+           ( _1 )
+# 38468 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3928 "src/ocaml/preprocess/parser_raw.mly"
+        ( "and" )
+# 38493 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3929 "src/ocaml/preprocess/parser_raw.mly"
+       ( "as" )
+# 38518 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3930 "src/ocaml/preprocess/parser_raw.mly"
+           ( "assert" )
+# 38543 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3931 "src/ocaml/preprocess/parser_raw.mly"
+          ( "begin" )
+# 38568 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3932 "src/ocaml/preprocess/parser_raw.mly"
+          ( "class" )
+# 38593 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3933 "src/ocaml/preprocess/parser_raw.mly"
+               ( "constraint" )
+# 38618 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3934 "src/ocaml/preprocess/parser_raw.mly"
+       ( "do" )
+# 38643 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3935 "src/ocaml/preprocess/parser_raw.mly"
+         ( "done" )
+# 38668 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3936 "src/ocaml/preprocess/parser_raw.mly"
+           ( "downto" )
+# 38693 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3937 "src/ocaml/preprocess/parser_raw.mly"
+         ( "else" )
+# 38718 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3938 "src/ocaml/preprocess/parser_raw.mly"
+        ( "end" )
+# 38743 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3939 "src/ocaml/preprocess/parser_raw.mly"
+              ( "exception" )
+# 38768 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3940 "src/ocaml/preprocess/parser_raw.mly"
+             ( "external" )
+# 38793 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3941 "src/ocaml/preprocess/parser_raw.mly"
+          ( "false" )
+# 38818 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3942 "src/ocaml/preprocess/parser_raw.mly"
+        ( "for" )
+# 38843 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3943 "src/ocaml/preprocess/parser_raw.mly"
+        ( "fun" )
+# 38868 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3944 "src/ocaml/preprocess/parser_raw.mly"
+             ( "function" )
+# 38893 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3945 "src/ocaml/preprocess/parser_raw.mly"
+            ( "functor" )
+# 38918 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3946 "src/ocaml/preprocess/parser_raw.mly"
+       ( "if" )
+# 38943 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3947 "src/ocaml/preprocess/parser_raw.mly"
+       ( "in" )
+# 38968 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3948 "src/ocaml/preprocess/parser_raw.mly"
+            ( "include" )
+# 38993 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3949 "src/ocaml/preprocess/parser_raw.mly"
+            ( "inherit" )
+# 39018 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3950 "src/ocaml/preprocess/parser_raw.mly"
+                ( "initializer" )
+# 39043 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3951 "src/ocaml/preprocess/parser_raw.mly"
+         ( "lazy" )
+# 39068 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3952 "src/ocaml/preprocess/parser_raw.mly"
+        ( "let" )
+# 39093 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3953 "src/ocaml/preprocess/parser_raw.mly"
+          ( "match" )
+# 39118 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3954 "src/ocaml/preprocess/parser_raw.mly"
+           ( "method" )
+# 39143 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3955 "src/ocaml/preprocess/parser_raw.mly"
+           ( "module" )
+# 39168 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3956 "src/ocaml/preprocess/parser_raw.mly"
+            ( "mutable" )
+# 39193 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3957 "src/ocaml/preprocess/parser_raw.mly"
+        ( "new" )
+# 39218 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3958 "src/ocaml/preprocess/parser_raw.mly"
+           ( "nonrec" )
+# 39243 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3959 "src/ocaml/preprocess/parser_raw.mly"
+           ( "object" )
+# 39268 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3960 "src/ocaml/preprocess/parser_raw.mly"
+       ( "of" )
+# 39293 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3961 "src/ocaml/preprocess/parser_raw.mly"
+         ( "open" )
+# 39318 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3962 "src/ocaml/preprocess/parser_raw.mly"
+       ( "or" )
+# 39343 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3963 "src/ocaml/preprocess/parser_raw.mly"
+            ( "private" )
+# 39368 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3964 "src/ocaml/preprocess/parser_raw.mly"
+        ( "rec" )
+# 39393 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3965 "src/ocaml/preprocess/parser_raw.mly"
+        ( "sig" )
+# 39418 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3966 "src/ocaml/preprocess/parser_raw.mly"
+           ( "struct" )
+# 39443 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3967 "src/ocaml/preprocess/parser_raw.mly"
+         ( "then" )
+# 39468 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3968 "src/ocaml/preprocess/parser_raw.mly"
+       ( "to" )
+# 39493 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3969 "src/ocaml/preprocess/parser_raw.mly"
+         ( "true" )
+# 39518 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3970 "src/ocaml/preprocess/parser_raw.mly"
+        ( "try" )
+# 39543 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3971 "src/ocaml/preprocess/parser_raw.mly"
+         ( "type" )
+# 39568 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3972 "src/ocaml/preprocess/parser_raw.mly"
+        ( "val" )
+# 39593 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3973 "src/ocaml/preprocess/parser_raw.mly"
+            ( "virtual" )
+# 39618 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3974 "src/ocaml/preprocess/parser_raw.mly"
+         ( "when" )
+# 39643 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3975 "src/ocaml/preprocess/parser_raw.mly"
+          ( "while" )
+# 39668 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3976 "src/ocaml/preprocess/parser_raw.mly"
+         ( "with" )
+# 39693 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.type_exception * string Location.loc option) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.type_exception * string Location.loc option) = 
+# 3251 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 39718 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined5;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined5_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined4;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined4_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined3;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _5;
+                MenhirLib.EngineTypes.startp = _startpos__5_;
+                MenhirLib.EngineTypes.endp = _endpos__5_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined2;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1_inlined1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = ext;
+                      MenhirLib.EngineTypes.startp = _startpos_ext_;
+                      MenhirLib.EngineTypes.endp = _endpos_ext_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _menhir_s;
+                        MenhirLib.EngineTypes.semv = _1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_;
+                        MenhirLib.EngineTypes.next = _menhir_stack;
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined5 : (Parsetree.attributes) = Obj.magic _1_inlined5 in
+        let _1_inlined4 : (Parsetree.attributes) = Obj.magic _1_inlined4 in
+        let _1_inlined3 : (Longident.t) = Obj.magic _1_inlined3 in
+        let _5 : unit = Obj.magic _5 in
+        let _1_inlined2 : (string) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined5_ in
+        let _v : (Parsetree.type_exception * string Location.loc option) = let attrs =
+          let _1 = _1_inlined5 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 39794 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_attrs_ = _endpos__1_inlined5_ in
+        let attrs2 =
+          let _1 = _1_inlined4 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 39803 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let lid =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 39814 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let id =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 39825 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let attrs1 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 39833 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_attrs_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3260 "src/ocaml/preprocess/parser_raw.mly"
+  ( let loc = make_loc _sloc in
+    let docs = symbol_docs _sloc in
+    Te.mk_exception ~attrs
+      (Te.rebind id lid ~attrs:(attrs1 @ attrs2) ~loc ~docs)
+    , ext )
+# 39846 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.expression) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.expression) = 
+# 2751 "src/ocaml/preprocess/parser_raw.mly"
+      ( _2 )
+# 39878 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.expression) = Obj.magic _2 in
+        let _1 : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.expression) = let _endpos = _endpos__2_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2753 "src/ocaml/preprocess/parser_raw.mly"
+      ( let (l, o, p) = _1 in ghexp ~loc:_sloc (Pexp_fun(l, o, p, _2)) )
+# 39913 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _5;
+          MenhirLib.EngineTypes.startp = _startpos__5_;
+          MenhirLib.EngineTypes.endp = _endpos__5_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = xs;
+              MenhirLib.EngineTypes.startp = _startpos_xs_;
+              MenhirLib.EngineTypes.endp = _endpos_xs_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _5 : (Parsetree.expression) = Obj.magic _5 in
+        let _4 : unit = Obj.magic _4 in
+        let xs : (string Location.loc list) = Obj.magic xs in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__5_ in
+        let _v : (Parsetree.expression) = let _3 = 
+# 2639 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 39966 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let _endpos = _endpos__5_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2755 "src/ocaml/preprocess/parser_raw.mly"
+      ( mk_newtypes ~loc:_sloc _3 _5 )
+# 39974 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = xss;
+          MenhirLib.EngineTypes.startp = _startpos_xss_;
+          MenhirLib.EngineTypes.endp = _endpos_xss_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let xss : (Parsetree.structure_item list list) = Obj.magic xss in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xss_ in
+        let _endpos = _endpos_xss_ in
+        let _v : (Parsetree.structure) = let _1 =
+          let _1 =
+            let ys = 
+# 260 "<standard.mly>"
+    ( List.flatten xss )
+# 40001 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let xs =
+              let items = 
+# 1050 "src/ocaml/preprocess/parser_raw.mly"
+    ( [] )
+# 40007 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              
+# 1482 "src/ocaml/preprocess/parser_raw.mly"
+    ( items )
+# 40012 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 267 "<standard.mly>"
+    ( xs @ ys )
+# 40018 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_xss_) in
+          let _endpos = _endpos__1_ in
+          let _startpos = _startpos__1_ in
+          
+# 972 "src/ocaml/preprocess/parser_raw.mly"
+                              ( extra_str _startpos _endpos _1 )
+# 40027 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1475 "src/ocaml/preprocess/parser_raw.mly"
+  ( _1 )
+# 40033 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xss;
+          MenhirLib.EngineTypes.startp = _startpos_xss_;
+          MenhirLib.EngineTypes.endp = _endpos_xss_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = e;
+              MenhirLib.EngineTypes.startp = _startpos_e_;
+              MenhirLib.EngineTypes.endp = _endpos_e_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let xss : (Parsetree.structure_item list list) = Obj.magic xss in
+        let _1 : (Parsetree.attributes) = Obj.magic _1 in
+        let e : (Parsetree.expression) = Obj.magic e in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_e_ in
+        let _endpos = _endpos_xss_ in
+        let _v : (Parsetree.structure) = let _1 =
+          let _1 =
+            let ys = 
+# 260 "<standard.mly>"
+    ( List.flatten xss )
+# 40074 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let xs =
+              let items =
+                let x =
+                  let _1 =
+                    let _1 =
+                      let attrs = 
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 40084 "src/ocaml/preprocess/parser_raw.ml"
+                       in
+                      
+# 1489 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkstrexp e attrs )
+# 40089 "src/ocaml/preprocess/parser_raw.ml"
+                      
+                    in
+                    let _startpos__1_ = _startpos_e_ in
+                    let _startpos = _startpos__1_ in
+                    
+# 984 "src/ocaml/preprocess/parser_raw.mly"
+  ( text_str _startpos @ [_1] )
+# 40097 "src/ocaml/preprocess/parser_raw.ml"
+                    
+                  in
+                  let _startpos__1_ = _startpos_e_ in
+                  let _endpos = _endpos__1_ in
+                  let _startpos = _startpos__1_ in
+                  
+# 1003 "src/ocaml/preprocess/parser_raw.mly"
+  ( mark_rhs_docs _startpos _endpos;
+    _1 )
+# 40107 "src/ocaml/preprocess/parser_raw.ml"
+                  
+                in
+                
+# 1052 "src/ocaml/preprocess/parser_raw.mly"
+    ( x )
+# 40113 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 1482 "src/ocaml/preprocess/parser_raw.mly"
+    ( items )
+# 40119 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 267 "<standard.mly>"
+    ( xs @ ys )
+# 40125 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_e_) in
+          let _endpos = _endpos__1_ in
+          let _startpos = _startpos__1_ in
+          
+# 972 "src/ocaml/preprocess/parser_raw.mly"
+                              ( extra_str _startpos _endpos _1 )
+# 40134 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1475 "src/ocaml/preprocess/parser_raw.mly"
+  ( _1 )
+# 40140 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Ast_helper.let_bindings) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.structure_item) = let _endpos = _endpos__1_ in
+        let _startpos = _startpos__1_ in
+        let _loc = (_startpos, _endpos) in
+        
+# 4048 "src/ocaml/preprocess/parser_raw.mly"
+    ( val_of_lwt_bindings ~loc:_loc _1 )
+# 40168 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Ast_helper.let_bindings) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.structure_item) = let _endpos = _endpos__1_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 1504 "src/ocaml/preprocess/parser_raw.mly"
+      ( val_of_let_bindings ~loc:_sloc _1 )
+# 40196 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : (Parsetree.extension) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (Parsetree.structure_item) = let _1 =
+          let _1 =
+            let _2 =
+              let _1 = _1_inlined1 in
+              
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 40232 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let _endpos__2_ = _endpos__1_inlined1_ in
+            let _endpos = _endpos__2_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 1507 "src/ocaml/preprocess/parser_raw.mly"
+        ( let docs = symbol_docs _sloc in
+          Pstr_extension (_1, add_docs_attrs docs _2) )
+# 40243 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__1_inlined1_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1019 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkstr ~loc:_sloc _1 )
+# 40253 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1538 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 40259 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.attribute) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.structure_item) = let _1 =
+          let _1 = 
+# 1510 "src/ocaml/preprocess/parser_raw.mly"
+        ( Pstr_attribute _1 )
+# 40285 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1019 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkstr ~loc:_sloc _1 )
+# 40293 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1538 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 40299 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.value_description * string Location.loc option) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.structure_item) = let _1 =
+          let _1 = 
+# 1514 "src/ocaml/preprocess/parser_raw.mly"
+        ( pstr_primitive _1 )
+# 40325 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1036 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mkstr_ext ~loc:_sloc _1 )
+# 40333 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1538 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 40339 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.value_description * string Location.loc option) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.structure_item) = let _1 =
+          let _1 = 
+# 1516 "src/ocaml/preprocess/parser_raw.mly"
+        ( pstr_primitive _1 )
+# 40365 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1036 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mkstr_ext ~loc:_sloc _1 )
+# 40373 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1538 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 40379 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = bs;
+          MenhirLib.EngineTypes.startp = _startpos_bs_;
+          MenhirLib.EngineTypes.endp = _endpos_bs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = a;
+            MenhirLib.EngineTypes.startp = _startpos_a_;
+            MenhirLib.EngineTypes.endp = _endpos_a_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let bs : (Parsetree.type_declaration list) = Obj.magic bs in
+        let a : ((Asttypes.rec_flag * string Location.loc option) *
+  Parsetree.type_declaration) = Obj.magic a in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_a_ in
+        let _endpos = _endpos_bs_ in
+        let _v : (Parsetree.structure_item) = let _1 =
+          let _1 =
+            let _1 =
+              let _1 =
+                let _1 = 
+# 1211 "src/ocaml/preprocess/parser_raw.mly"
+    ( let (x, b) = a in x, b :: bs )
+# 40416 "src/ocaml/preprocess/parser_raw.ml"
+                 in
+                
+# 3093 "src/ocaml/preprocess/parser_raw.mly"
+  ( _1 )
+# 40421 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 3076 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 40427 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 1518 "src/ocaml/preprocess/parser_raw.mly"
+        ( pstr_type _1 )
+# 40433 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_bs_, _startpos_a_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1036 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mkstr_ext ~loc:_sloc _1 )
+# 40443 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1538 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 40449 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined3;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = xs;
+            MenhirLib.EngineTypes.startp = _startpos_xs_;
+            MenhirLib.EngineTypes.endp = _endpos_xs_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = priv;
+              MenhirLib.EngineTypes.startp = _startpos_priv_;
+              MenhirLib.EngineTypes.endp = _endpos_priv_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _7;
+                MenhirLib.EngineTypes.startp = _startpos__7_;
+                MenhirLib.EngineTypes.endp = _endpos__7_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined2;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = params;
+                    MenhirLib.EngineTypes.startp = _startpos_params_;
+                    MenhirLib.EngineTypes.endp = _endpos_params_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _1_inlined1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = ext;
+                        MenhirLib.EngineTypes.startp = _startpos_ext_;
+                        MenhirLib.EngineTypes.endp = _endpos_ext_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _menhir_s;
+                          MenhirLib.EngineTypes.semv = _1;
+                          MenhirLib.EngineTypes.startp = _startpos__1_;
+                          MenhirLib.EngineTypes.endp = _endpos__1_;
+                          MenhirLib.EngineTypes.next = _menhir_stack;
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let xs : (Parsetree.extension_constructor list) = Obj.magic xs in
+        let priv : (Asttypes.private_flag) = Obj.magic priv in
+        let _7 : unit = Obj.magic _7 in
+        let _1_inlined2 : (Longident.t) = Obj.magic _1_inlined2 in
+        let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined3_ in
+        let _v : (Parsetree.structure_item) = let _1 =
+          let _1 =
+            let _1 =
+              let _1 =
+                let attrs2 =
+                  let _1 = _1_inlined3 in
+                  
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 40536 "src/ocaml/preprocess/parser_raw.ml"
+                  
+                in
+                let _endpos_attrs2_ = _endpos__1_inlined3_ in
+                let cs = 
+# 1203 "src/ocaml/preprocess/parser_raw.mly"
+    ( List.rev xs )
+# 40543 "src/ocaml/preprocess/parser_raw.ml"
+                 in
+                let tid =
+                  let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+                  let _endpos = _endpos__1_ in
+                  let _symbolstartpos = _startpos__1_ in
+                  let _sloc = (_symbolstartpos, _endpos) in
+                  
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 40553 "src/ocaml/preprocess/parser_raw.ml"
+                  
+                in
+                let _4 = 
+# 3846 "src/ocaml/preprocess/parser_raw.mly"
+                ( Recursive )
+# 40559 "src/ocaml/preprocess/parser_raw.ml"
+                 in
+                let attrs1 =
+                  let _1 = _1_inlined1 in
+                  
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 40566 "src/ocaml/preprocess/parser_raw.ml"
+                  
+                in
+                let _endpos = _endpos_attrs2_ in
+                let _symbolstartpos = _startpos__1_ in
+                let _sloc = (_symbolstartpos, _endpos) in
+                
+# 3343 "src/ocaml/preprocess/parser_raw.mly"
+    ( let docs = symbol_docs _sloc in
+      let attrs = attrs1 @ attrs2 in
+      Te.mk tid cs ~params ~priv ~attrs ~docs,
+      ext )
+# 40578 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 3326 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 40584 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 1520 "src/ocaml/preprocess/parser_raw.mly"
+        ( pstr_typext _1 )
+# 40590 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__1_inlined3_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1036 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mkstr_ext ~loc:_sloc _1 )
+# 40600 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1538 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 40606 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined4;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined4_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = xs;
+            MenhirLib.EngineTypes.startp = _startpos_xs_;
+            MenhirLib.EngineTypes.endp = _endpos_xs_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = priv;
+              MenhirLib.EngineTypes.startp = _startpos_priv_;
+              MenhirLib.EngineTypes.endp = _endpos_priv_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _7;
+                MenhirLib.EngineTypes.startp = _startpos__7_;
+                MenhirLib.EngineTypes.endp = _endpos__7_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined3;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = params;
+                    MenhirLib.EngineTypes.startp = _startpos_params_;
+                    MenhirLib.EngineTypes.endp = _endpos_params_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _1_inlined2;
+                      MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = _1_inlined1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _;
+                          MenhirLib.EngineTypes.semv = ext;
+                          MenhirLib.EngineTypes.startp = _startpos_ext_;
+                          MenhirLib.EngineTypes.endp = _endpos_ext_;
+                          MenhirLib.EngineTypes.next = {
+                            MenhirLib.EngineTypes.state = _menhir_s;
+                            MenhirLib.EngineTypes.semv = _1;
+                            MenhirLib.EngineTypes.startp = _startpos__1_;
+                            MenhirLib.EngineTypes.endp = _endpos__1_;
+                            MenhirLib.EngineTypes.next = _menhir_stack;
+                          };
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined4 : (Parsetree.attributes) = Obj.magic _1_inlined4 in
+        let xs : (Parsetree.extension_constructor list) = Obj.magic xs in
+        let priv : (Asttypes.private_flag) = Obj.magic priv in
+        let _7 : unit = Obj.magic _7 in
+        let _1_inlined3 : (Longident.t) = Obj.magic _1_inlined3 in
+        let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in
+        let _1_inlined2 : unit = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined4_ in
+        let _v : (Parsetree.structure_item) = let _1 =
+          let _1 =
+            let _1 =
+              let _1 =
+                let attrs2 =
+                  let _1 = _1_inlined4 in
+                  
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 40700 "src/ocaml/preprocess/parser_raw.ml"
+                  
+                in
+                let _endpos_attrs2_ = _endpos__1_inlined4_ in
+                let cs = 
+# 1203 "src/ocaml/preprocess/parser_raw.mly"
+    ( List.rev xs )
+# 40707 "src/ocaml/preprocess/parser_raw.ml"
+                 in
+                let tid =
+                  let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in
+                  let _endpos = _endpos__1_ in
+                  let _symbolstartpos = _startpos__1_ in
+                  let _sloc = (_symbolstartpos, _endpos) in
+                  
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 40717 "src/ocaml/preprocess/parser_raw.ml"
+                  
+                in
+                let _4 =
+                  let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+                  let _endpos = _endpos__1_ in
+                  let _startpos = _startpos__1_ in
+                  let _loc = (_startpos, _endpos) in
+                  
+# 3848 "src/ocaml/preprocess/parser_raw.mly"
+                ( not_expecting _loc "nonrec flag"; Recursive )
+# 40728 "src/ocaml/preprocess/parser_raw.ml"
+                  
+                in
+                let attrs1 =
+                  let _1 = _1_inlined1 in
+                  
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 40736 "src/ocaml/preprocess/parser_raw.ml"
+                  
+                in
+                let _endpos = _endpos_attrs2_ in
+                let _symbolstartpos = _startpos__1_ in
+                let _sloc = (_symbolstartpos, _endpos) in
+                
+# 3343 "src/ocaml/preprocess/parser_raw.mly"
+    ( let docs = symbol_docs _sloc in
+      let attrs = attrs1 @ attrs2 in
+      Te.mk tid cs ~params ~priv ~attrs ~docs,
+      ext )
+# 40748 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 3326 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 40754 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 1520 "src/ocaml/preprocess/parser_raw.mly"
+        ( pstr_typext _1 )
+# 40760 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__1_inlined4_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1036 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mkstr_ext ~loc:_sloc _1 )
+# 40770 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1538 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 40776 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.type_exception * string Location.loc option) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.structure_item) = let _1 =
+          let _1 = 
+# 1522 "src/ocaml/preprocess/parser_raw.mly"
+        ( pstr_exception _1 )
+# 40802 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1036 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mkstr_ext ~loc:_sloc _1 )
+# 40810 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1538 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 40816 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined3;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = body;
+            MenhirLib.EngineTypes.startp = _startpos_body_;
+            MenhirLib.EngineTypes.endp = _endpos_body_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined2;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined1;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = ext;
+                  MenhirLib.EngineTypes.startp = _startpos_ext_;
+                  MenhirLib.EngineTypes.endp = _endpos_ext_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let body : (Parsetree.module_expr) = Obj.magic body in
+        let _1_inlined2 : (string option) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined3_ in
+        let _v : (Parsetree.structure_item) = let _1 =
+          let _1 =
+            let _1 =
+              let attrs2 =
+                let _1 = _1_inlined3 in
+                
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 40881 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              let _endpos_attrs2_ = _endpos__1_inlined3_ in
+              let name =
+                let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+                let _endpos = _endpos__1_ in
+                let _symbolstartpos = _startpos__1_ in
+                let _sloc = (_symbolstartpos, _endpos) in
+                
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 40893 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              let attrs1 =
+                let _1 = _1_inlined1 in
+                
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 40901 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              let _endpos = _endpos_attrs2_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1548 "src/ocaml/preprocess/parser_raw.mly"
+    ( let docs = symbol_docs _sloc in
+      let loc = make_loc _sloc in
+      let attrs = attrs1 @ attrs2 in
+      let body = Mb.mk name body ~attrs ~loc ~docs in
+      Pstr_module body, ext )
+# 40914 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 1524 "src/ocaml/preprocess/parser_raw.mly"
+        ( _1 )
+# 40920 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__1_inlined3_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1036 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mkstr_ext ~loc:_sloc _1 )
+# 40930 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1538 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 40936 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = bs;
+          MenhirLib.EngineTypes.startp = _startpos_bs_;
+          MenhirLib.EngineTypes.endp = _endpos_bs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined3;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = body;
+              MenhirLib.EngineTypes.startp = _startpos_body_;
+              MenhirLib.EngineTypes.endp = _endpos_body_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _4;
+                  MenhirLib.EngineTypes.startp = _startpos__4_;
+                  MenhirLib.EngineTypes.endp = _endpos__4_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1_inlined1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = ext;
+                      MenhirLib.EngineTypes.startp = _startpos_ext_;
+                      MenhirLib.EngineTypes.endp = _endpos_ext_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _menhir_s;
+                        MenhirLib.EngineTypes.semv = _1;
+                        MenhirLib.EngineTypes.startp = _startpos__1_;
+                        MenhirLib.EngineTypes.endp = _endpos__1_;
+                        MenhirLib.EngineTypes.next = _menhir_stack;
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let bs : (Parsetree.module_binding list) = Obj.magic bs in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let body : (Parsetree.module_expr) = Obj.magic body in
+        let _1_inlined2 : (string option) = Obj.magic _1_inlined2 in
+        let _4 : unit = Obj.magic _4 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_bs_ in
+        let _v : (Parsetree.structure_item) = let _1 =
+          let _1 =
+            let _1 =
+              let _1 =
+                let a =
+                  let attrs2 =
+                    let _1 = _1_inlined3 in
+                    
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 41017 "src/ocaml/preprocess/parser_raw.ml"
+                    
+                  in
+                  let _endpos_attrs2_ = _endpos__1_inlined3_ in
+                  let name =
+                    let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+                    let _endpos = _endpos__1_ in
+                    let _symbolstartpos = _startpos__1_ in
+                    let _sloc = (_symbolstartpos, _endpos) in
+                    
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 41029 "src/ocaml/preprocess/parser_raw.ml"
+                    
+                  in
+                  let attrs1 =
+                    let _1 = _1_inlined1 in
+                    
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 41037 "src/ocaml/preprocess/parser_raw.ml"
+                    
+                  in
+                  let _endpos = _endpos_attrs2_ in
+                  let _symbolstartpos = _startpos__1_ in
+                  let _sloc = (_symbolstartpos, _endpos) in
+                  
+# 1583 "src/ocaml/preprocess/parser_raw.mly"
+  (
+    let loc = make_loc _sloc in
+    let attrs = attrs1 @ attrs2 in
+    let docs = symbol_docs _sloc in
+    ext,
+    Mb.mk name body ~attrs ~loc ~docs
+  )
+# 41052 "src/ocaml/preprocess/parser_raw.ml"
+                  
+                in
+                
+# 1211 "src/ocaml/preprocess/parser_raw.mly"
+    ( let (x, b) = a in x, b :: bs )
+# 41058 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 1571 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 41064 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 1526 "src/ocaml/preprocess/parser_raw.mly"
+        ( pstr_recmodule _1 )
+# 41070 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos_bs_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1036 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mkstr_ext ~loc:_sloc _1 )
+# 41080 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1538 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 41086 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.module_type_declaration * string Location.loc option) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.structure_item) = let _1 =
+          let _1 = 
+# 1528 "src/ocaml/preprocess/parser_raw.mly"
+        ( let (body, ext) = _1 in (Pstr_modtype body, ext) )
+# 41112 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1036 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mkstr_ext ~loc:_sloc _1 )
+# 41120 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1538 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 41126 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Parsetree.module_expr Parsetree.open_infos * string Location.loc option) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.structure_item) = let _1 =
+          let _1 = 
+# 1530 "src/ocaml/preprocess/parser_raw.mly"
+        ( let (body, ext) = _1 in (Pstr_open body, ext) )
+# 41152 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1036 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mkstr_ext ~loc:_sloc _1 )
+# 41160 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1538 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 41166 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = bs;
+          MenhirLib.EngineTypes.startp = _startpos_bs_;
+          MenhirLib.EngineTypes.endp = _endpos_bs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined3;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = body;
+              MenhirLib.EngineTypes.startp = _startpos_body_;
+              MenhirLib.EngineTypes.endp = _endpos_body_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = params;
+                  MenhirLib.EngineTypes.startp = _startpos_params_;
+                  MenhirLib.EngineTypes.endp = _endpos_params_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = virt;
+                    MenhirLib.EngineTypes.startp = _startpos_virt_;
+                    MenhirLib.EngineTypes.endp = _endpos_virt_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _;
+                      MenhirLib.EngineTypes.semv = _1_inlined1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                      MenhirLib.EngineTypes.next = {
+                        MenhirLib.EngineTypes.state = _;
+                        MenhirLib.EngineTypes.semv = ext;
+                        MenhirLib.EngineTypes.startp = _startpos_ext_;
+                        MenhirLib.EngineTypes.endp = _endpos_ext_;
+                        MenhirLib.EngineTypes.next = {
+                          MenhirLib.EngineTypes.state = _menhir_s;
+                          MenhirLib.EngineTypes.semv = _1;
+                          MenhirLib.EngineTypes.startp = _startpos__1_;
+                          MenhirLib.EngineTypes.endp = _endpos__1_;
+                          MenhirLib.EngineTypes.next = _menhir_stack;
+                        };
+                      };
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let bs : (Parsetree.class_expr Parsetree.class_infos list) = Obj.magic bs in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let body : (Parsetree.class_expr) = Obj.magic body in
+        let _1_inlined2 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 41238 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined2 in
+        let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in
+        let virt : (Asttypes.virtual_flag) = Obj.magic virt in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_bs_ in
+        let _v : (Parsetree.structure_item) = let _1 =
+          let _1 =
+            let _1 =
+              let _1 =
+                let a =
+                  let attrs2 =
+                    let _1 = _1_inlined3 in
+                    
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 41258 "src/ocaml/preprocess/parser_raw.ml"
+                    
+                  in
+                  let _endpos_attrs2_ = _endpos__1_inlined3_ in
+                  let id =
+                    let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+                    let _endpos = _endpos__1_ in
+                    let _symbolstartpos = _startpos__1_ in
+                    let _sloc = (_symbolstartpos, _endpos) in
+                    
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 41270 "src/ocaml/preprocess/parser_raw.ml"
+                    
+                  in
+                  let attrs1 =
+                    let _1 = _1_inlined1 in
+                    
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 41278 "src/ocaml/preprocess/parser_raw.ml"
+                    
+                  in
+                  let _endpos = _endpos_attrs2_ in
+                  let _symbolstartpos = _startpos__1_ in
+                  let _sloc = (_symbolstartpos, _endpos) in
+                  
+# 1927 "src/ocaml/preprocess/parser_raw.mly"
+  (
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc _sloc in
+    let docs = symbol_docs _sloc in
+    ext,
+    Ci.mk id body ~virt ~params ~attrs ~loc ~docs
+  )
+# 41293 "src/ocaml/preprocess/parser_raw.ml"
+                  
+                in
+                
+# 1211 "src/ocaml/preprocess/parser_raw.mly"
+    ( let (x, b) = a in x, b :: bs )
+# 41299 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 1916 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 41305 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 1532 "src/ocaml/preprocess/parser_raw.mly"
+        ( let (ext, l) = _1 in (Pstr_class l, ext) )
+# 41311 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos_bs_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1036 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mkstr_ext ~loc:_sloc _1 )
+# 41321 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1538 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 41327 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (string Location.loc option * Parsetree.class_type_declaration list) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.structure_item) = let _1 =
+          let _1 = 
+# 1534 "src/ocaml/preprocess/parser_raw.mly"
+        ( let (ext, l) = _1 in (Pstr_class_type l, ext) )
+# 41353 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1036 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mkstr_ext ~loc:_sloc _1 )
+# 41361 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1538 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 41367 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined2;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = thing;
+            MenhirLib.EngineTypes.startp = _startpos_thing_;
+            MenhirLib.EngineTypes.endp = _endpos_thing_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = ext;
+                MenhirLib.EngineTypes.startp = _startpos_ext_;
+                MenhirLib.EngineTypes.endp = _endpos_ext_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in
+        let thing : (Parsetree.module_expr) = Obj.magic thing in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined2_ in
+        let _v : (Parsetree.structure_item) = let _1 =
+          let _1 =
+            let _1 =
+              let attrs2 =
+                let _1 = _1_inlined2 in
+                
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 41425 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              let _endpos_attrs2_ = _endpos__1_inlined2_ in
+              let attrs1 =
+                let _1 = _1_inlined1 in
+                
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 41434 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              let _endpos = _endpos_attrs2_ in
+              let _symbolstartpos = _startpos__1_ in
+              let _sloc = (_symbolstartpos, _endpos) in
+              
+# 1620 "src/ocaml/preprocess/parser_raw.mly"
+  (
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc _sloc in
+    let docs = symbol_docs _sloc in
+    Incl.mk thing ~attrs ~loc ~docs, ext
+  )
+# 41448 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 1536 "src/ocaml/preprocess/parser_raw.mly"
+        ( pstr_include _1 )
+# 41454 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _endpos__1_ = _endpos__1_inlined2_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1036 "src/ocaml/preprocess/parser_raw.mly"
+    ( wrap_mkstr_ext ~loc:_sloc _1 )
+# 41464 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1538 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 41470 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3911 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( "-" )
+# 41495 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3912 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( "-." )
+# 41520 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = xs;
+            MenhirLib.EngineTypes.startp = _startpos_xs_;
+            MenhirLib.EngineTypes.endp = _endpos_xs_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _3;
+              MenhirLib.EngineTypes.startp = _startpos__3_;
+              MenhirLib.EngineTypes.endp = _endpos__3_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let xs : (Parsetree.core_type list) = Obj.magic xs in
+        let _3 : (bool) = Obj.magic _3 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (Parsetree.row_field) = let _5 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 41575 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__5_ = _endpos__1_inlined1_ in
+        let _4 =
+          let _1 =
+            let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 41584 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 1114 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 41589 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 3617 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 41595 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _1 =
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 41605 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__5_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3603 "src/ocaml/preprocess/parser_raw.mly"
+      ( let info = symbol_info _endpos in
+        let attrs = add_info_attrs info _5 in
+        Rf.tag ~loc:(make_loc _sloc) ~attrs _1 _3 _4 )
+# 41616 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (Parsetree.row_field) = let _2 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 41650 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__2_ = _endpos__1_inlined1_ in
+        let _1 =
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 41661 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__2_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3607 "src/ocaml/preprocess/parser_raw.mly"
+      ( let info = symbol_info _endpos in
+        let attrs = add_info_attrs info _2 in
+        Rf.tag ~loc:(make_loc _sloc) ~attrs _1 true [] )
+# 41672 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined1;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _1_inlined1 : (string) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined1_ in
+        let _v : (Parsetree.toplevel_phrase) = let arg = 
+# 124 "<standard.mly>"
+    ( None )
+# 41704 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let _endpos_arg_ = _endpos__1_inlined1_ in
+        let dir =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 41715 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_arg_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3809 "src/ocaml/preprocess/parser_raw.mly"
+    ( mk_directive ~loc:_sloc dir arg )
+# 41724 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined2;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined2 : (
+# 825 "src/ocaml/preprocess/parser_raw.mly"
+       (string * Location.t * string option)
+# 41757 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined2_ in
+        let _v : (Parsetree.toplevel_phrase) = let arg =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let x =
+            let _1 = 
+# 3813 "src/ocaml/preprocess/parser_raw.mly"
+                  ( let (s, _, _) = _1 in Pdir_string s )
+# 41770 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 1041 "src/ocaml/preprocess/parser_raw.mly"
+    ( mk_directive_arg ~loc:_sloc _1 )
+# 41778 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 126 "<standard.mly>"
+    ( Some x )
+# 41784 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_arg_ = _endpos__1_inlined2_ in
+        let dir =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 41796 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_arg_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3809 "src/ocaml/preprocess/parser_raw.mly"
+    ( mk_directive ~loc:_sloc dir arg )
+# 41805 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined2;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined2 : (
+# 773 "src/ocaml/preprocess/parser_raw.mly"
+       (string * char option)
+# 41838 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined2_ in
+        let _v : (Parsetree.toplevel_phrase) = let arg =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let x =
+            let _1 = 
+# 3814 "src/ocaml/preprocess/parser_raw.mly"
+                  ( let (n, m) = _1 in Pdir_int (n ,m) )
+# 41851 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 1041 "src/ocaml/preprocess/parser_raw.mly"
+    ( mk_directive_arg ~loc:_sloc _1 )
+# 41859 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 126 "<standard.mly>"
+    ( Some x )
+# 41865 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_arg_ = _endpos__1_inlined2_ in
+        let dir =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 41877 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_arg_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3809 "src/ocaml/preprocess/parser_raw.mly"
+    ( mk_directive ~loc:_sloc dir arg )
+# 41886 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined2;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined2 : (Longident.t) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined2_ in
+        let _v : (Parsetree.toplevel_phrase) = let arg =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let x =
+            let _1 = 
+# 3815 "src/ocaml/preprocess/parser_raw.mly"
+                  ( Pdir_ident _1 )
+# 41928 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 1041 "src/ocaml/preprocess/parser_raw.mly"
+    ( mk_directive_arg ~loc:_sloc _1 )
+# 41936 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 126 "<standard.mly>"
+    ( Some x )
+# 41942 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_arg_ = _endpos__1_inlined2_ in
+        let dir =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 41954 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_arg_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3809 "src/ocaml/preprocess/parser_raw.mly"
+    ( mk_directive ~loc:_sloc dir arg )
+# 41963 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined2;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined2 : (Longident.t) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined2_ in
+        let _v : (Parsetree.toplevel_phrase) = let arg =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let x =
+            let _1 = 
+# 3816 "src/ocaml/preprocess/parser_raw.mly"
+                  ( Pdir_ident _1 )
+# 42005 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 1041 "src/ocaml/preprocess/parser_raw.mly"
+    ( mk_directive_arg ~loc:_sloc _1 )
+# 42013 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 126 "<standard.mly>"
+    ( Some x )
+# 42019 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_arg_ = _endpos__1_inlined2_ in
+        let dir =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 42031 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_arg_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3809 "src/ocaml/preprocess/parser_raw.mly"
+    ( mk_directive ~loc:_sloc dir arg )
+# 42040 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined2;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined2 : unit = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined2_ in
+        let _v : (Parsetree.toplevel_phrase) = let arg =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let x =
+            let _1 = 
+# 3817 "src/ocaml/preprocess/parser_raw.mly"
+                  ( Pdir_bool false )
+# 42082 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 1041 "src/ocaml/preprocess/parser_raw.mly"
+    ( mk_directive_arg ~loc:_sloc _1 )
+# 42090 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 126 "<standard.mly>"
+    ( Some x )
+# 42096 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_arg_ = _endpos__1_inlined2_ in
+        let dir =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 42108 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_arg_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3809 "src/ocaml/preprocess/parser_raw.mly"
+    ( mk_directive ~loc:_sloc dir arg )
+# 42117 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined2;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined1;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined2 : unit = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (string) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined2_ in
+        let _v : (Parsetree.toplevel_phrase) = let arg =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let x =
+            let _1 = 
+# 3818 "src/ocaml/preprocess/parser_raw.mly"
+                  ( Pdir_bool true )
+# 42159 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let _endpos = _endpos__1_ in
+            let _symbolstartpos = _startpos__1_ in
+            let _sloc = (_symbolstartpos, _endpos) in
+            
+# 1041 "src/ocaml/preprocess/parser_raw.mly"
+    ( mk_directive_arg ~loc:_sloc _1 )
+# 42167 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 126 "<standard.mly>"
+    ( Some x )
+# 42173 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_arg_ = _endpos__1_inlined2_ in
+        let dir =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 42185 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_arg_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3809 "src/ocaml/preprocess/parser_raw.mly"
+    ( mk_directive ~loc:_sloc dir arg )
+# 42194 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = e;
+              MenhirLib.EngineTypes.startp = _startpos_e_;
+              MenhirLib.EngineTypes.endp = _endpos_e_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.attributes) = Obj.magic _1 in
+        let e : (Parsetree.expression) = Obj.magic e in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_e_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.toplevel_phrase) = let _1 =
+          let _1 =
+            let _1 =
+              let attrs = 
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 42236 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              
+# 1489 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkstrexp e attrs )
+# 42241 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            let _startpos__1_ = _startpos_e_ in
+            let _startpos = _startpos__1_ in
+            
+# 984 "src/ocaml/preprocess/parser_raw.mly"
+  ( text_str _startpos @ [_1] )
+# 42249 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let _startpos__1_ = _startpos_e_ in
+          let _endpos = _endpos__1_ in
+          let _startpos = _startpos__1_ in
+          
+# 972 "src/ocaml/preprocess/parser_raw.mly"
+                              ( extra_str _startpos _endpos _1 )
+# 42258 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1251 "src/ocaml/preprocess/parser_raw.mly"
+    ( Ptop_def _1 )
+# 42264 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = xss;
+            MenhirLib.EngineTypes.startp = _startpos_xss_;
+            MenhirLib.EngineTypes.endp = _endpos_xss_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let xss : (Parsetree.structure_item list list) = Obj.magic xss in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xss_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.toplevel_phrase) = let _1 =
+          let _1 = 
+# 260 "<standard.mly>"
+    ( List.flatten xss )
+# 42297 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_xss_) in
+          let _endpos = _endpos__1_ in
+          let _startpos = _startpos__1_ in
+          
+# 972 "src/ocaml/preprocess/parser_raw.mly"
+                              ( extra_str _startpos _endpos _1 )
+# 42305 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1255 "src/ocaml/preprocess/parser_raw.mly"
+    ( Ptop_def _1 )
+# 42311 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : (Parsetree.toplevel_phrase) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.toplevel_phrase) = 
+# 1259 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 42343 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.toplevel_phrase) = 
+# 1262 "src/ocaml/preprocess/parser_raw.mly"
+    ( raise End_of_file )
+# 42368 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = ty;
+          MenhirLib.EngineTypes.startp = _startpos_ty_;
+          MenhirLib.EngineTypes.endp = _endpos_ty_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let ty : (Parsetree.core_type) = Obj.magic ty in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_ty_ in
+        let _endpos = _endpos_ty_ in
+        let _v : (Parsetree.core_type) = 
+# 3509 "src/ocaml/preprocess/parser_raw.mly"
+      ( ty )
+# 42393 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let xs : (Parsetree.core_type list) = Obj.magic xs in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xs_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 =
+            let tys =
+              let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 42421 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              
+# 1142 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 42426 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 3512 "src/ocaml/preprocess/parser_raw.mly"
+        ( Ptyp_tuple tys )
+# 42432 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_xs_) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 42442 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3514 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 42448 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.core_type) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.core_type option * Parsetree.core_type option) = 
+# 2830 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( (Some _2, None) )
+# 42480 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _4;
+          MenhirLib.EngineTypes.startp = _startpos__4_;
+          MenhirLib.EngineTypes.endp = _endpos__4_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _2;
+              MenhirLib.EngineTypes.startp = _startpos__2_;
+              MenhirLib.EngineTypes.endp = _endpos__2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _4 : (Parsetree.core_type) = Obj.magic _4 in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (Parsetree.core_type) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__4_ in
+        let _v : (Parsetree.core_type option * Parsetree.core_type option) = 
+# 2831 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( (Some _2, Some _4) )
+# 42526 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.core_type) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.core_type option * Parsetree.core_type option) = 
+# 2832 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( (None, Some _2) )
+# 42558 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = 
+# 3167 "src/ocaml/preprocess/parser_raw.mly"
+      ( (Ptype_abstract, Public, None) )
+# 42576 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = 
+# 3169 "src/ocaml/preprocess/parser_raw.mly"
+      ( _2 )
+# 42608 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Longident.t) = 
+# 3769 "src/ocaml/preprocess/parser_raw.mly"
+                                            ( _1 )
+# 42633 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : (Parsetree.core_type) = Obj.magic _2 in
+        let _1 : (Asttypes.variance * Asttypes.injectivity) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) = 
+# 3184 "src/ocaml/preprocess/parser_raw.mly"
+                                       ( _2, _1 )
+# 42665 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = 
+# 3177 "src/ocaml/preprocess/parser_raw.mly"
+      ( [] )
+# 42683 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = p;
+          MenhirLib.EngineTypes.startp = _startpos_p_;
+          MenhirLib.EngineTypes.endp = _endpos_p_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let p : (Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) = Obj.magic p in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_p_ in
+        let _endpos = _endpos_p_ in
+        let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = 
+# 3179 "src/ocaml/preprocess/parser_raw.mly"
+      ( [p] )
+# 42708 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = xs;
+            MenhirLib.EngineTypes.startp = _startpos_xs_;
+            MenhirLib.EngineTypes.endp = _endpos_xs_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let xs : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic xs in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = let ps =
+          let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 42748 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          
+# 1114 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 42753 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3181 "src/ocaml/preprocess/parser_raw.mly"
+      ( ps )
+# 42759 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = tyvar;
+          MenhirLib.EngineTypes.startp = _startpos_tyvar_;
+          MenhirLib.EngineTypes.endp = _endpos_tyvar_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let tyvar : (string) = Obj.magic tyvar in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_tyvar_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 = 
+# 3189 "src/ocaml/preprocess/parser_raw.mly"
+      ( Ptyp_var tyvar )
+# 42792 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos__1_ = _endpos_tyvar_ in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 42801 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3192 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 42807 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Parsetree.core_type) = let _1 =
+          let _1 = 
+# 3191 "src/ocaml/preprocess/parser_raw.mly"
+      ( Ptyp_any )
+# 42833 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 1017 "src/ocaml/preprocess/parser_raw.mly"
+    ( mktyp ~loc:_sloc _1 )
+# 42841 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3192 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 42847 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Asttypes.variance * Asttypes.injectivity) = 
+# 3196 "src/ocaml/preprocess/parser_raw.mly"
+                                            ( NoVariance, NoInjectivity )
+# 42865 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Asttypes.variance * Asttypes.injectivity) = 
+# 3197 "src/ocaml/preprocess/parser_raw.mly"
+                                            ( Covariant, NoInjectivity )
+# 42890 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Asttypes.variance * Asttypes.injectivity) = 
+# 3198 "src/ocaml/preprocess/parser_raw.mly"
+                                            ( Contravariant, NoInjectivity )
+# 42915 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Asttypes.variance * Asttypes.injectivity) = 
+# 3199 "src/ocaml/preprocess/parser_raw.mly"
+                                            ( NoVariance, Injective )
+# 42940 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Asttypes.variance * Asttypes.injectivity) = 
+# 3200 "src/ocaml/preprocess/parser_raw.mly"
+                                            ( Covariant, Injective )
+# 42972 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Asttypes.variance * Asttypes.injectivity) = 
+# 3200 "src/ocaml/preprocess/parser_raw.mly"
+                                            ( Covariant, Injective )
+# 43004 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Asttypes.variance * Asttypes.injectivity) = 
+# 3201 "src/ocaml/preprocess/parser_raw.mly"
+                                            ( Contravariant, Injective )
+# 43036 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Asttypes.variance * Asttypes.injectivity) = 
+# 3201 "src/ocaml/preprocess/parser_raw.mly"
+                                            ( Contravariant, Injective )
+# 43068 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 765 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 43089 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Asttypes.variance * Asttypes.injectivity) = let _loc__1_ = (_startpos__1_, _endpos__1_) in
+        
+# 3203 "src/ocaml/preprocess/parser_raw.mly"
+      ( if _1 = "+!" then Covariant, Injective else
+        if _1 = "-!" then Contravariant, Injective else
+        (expecting _loc__1_ "type_variance";
+         NoVariance, NoInjectivity) )
+# 43101 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 811 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 43122 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Asttypes.variance * Asttypes.injectivity) = let _loc__1_ = (_startpos__1_, _endpos__1_) in
+        
+# 3208 "src/ocaml/preprocess/parser_raw.mly"
+      ( if _1 = "!+" then Covariant, Injective else
+        if _1 = "!-" then Contravariant, Injective else
+        (expecting _loc__1_ "type_variance";
+         NoVariance, NoInjectivity) )
+# 43134 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = xss;
+            MenhirLib.EngineTypes.startp = _startpos_xss_;
+            MenhirLib.EngineTypes.endp = _endpos_xss_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let xss : (Parsetree.toplevel_phrase list list) = Obj.magic xss in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_xss_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.toplevel_phrase list) = let _1 =
+          let _1 =
+            let ys = 
+# 260 "<standard.mly>"
+    ( List.flatten xss )
+# 43168 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let xs =
+              let _1 = 
+# 1050 "src/ocaml/preprocess/parser_raw.mly"
+    ( [] )
+# 43174 "src/ocaml/preprocess/parser_raw.ml"
+               in
+              
+# 1282 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 43179 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 267 "<standard.mly>"
+    ( xs @ ys )
+# 43185 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_xss_) in
+          let _endpos = _endpos__1_ in
+          let _startpos = _startpos__1_ in
+          
+# 976 "src/ocaml/preprocess/parser_raw.mly"
+                              ( extra_def _startpos _endpos _1 )
+# 43194 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1275 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 43200 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = xss;
+            MenhirLib.EngineTypes.startp = _startpos_xss_;
+            MenhirLib.EngineTypes.endp = _endpos_xss_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = e;
+                MenhirLib.EngineTypes.startp = _startpos_e_;
+                MenhirLib.EngineTypes.endp = _endpos_e_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let xss : (Parsetree.toplevel_phrase list list) = Obj.magic xss in
+        let _1 : (Parsetree.attributes) = Obj.magic _1 in
+        let e : (Parsetree.expression) = Obj.magic e in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos_e_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Parsetree.toplevel_phrase list) = let _1 =
+          let _1 =
+            let ys = 
+# 260 "<standard.mly>"
+    ( List.flatten xss )
+# 43248 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            let xs =
+              let _1 =
+                let x =
+                  let _1 =
+                    let _1 =
+                      let attrs = 
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 43258 "src/ocaml/preprocess/parser_raw.ml"
+                       in
+                      
+# 1489 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkstrexp e attrs )
+# 43263 "src/ocaml/preprocess/parser_raw.ml"
+                      
+                    in
+                    
+# 994 "src/ocaml/preprocess/parser_raw.mly"
+  ( Ptop_def [_1] )
+# 43269 "src/ocaml/preprocess/parser_raw.ml"
+                    
+                  in
+                  let _startpos__1_ = _startpos_e_ in
+                  let _startpos = _startpos__1_ in
+                  
+# 992 "src/ocaml/preprocess/parser_raw.mly"
+  ( text_def _startpos @ [_1] )
+# 43277 "src/ocaml/preprocess/parser_raw.ml"
+                  
+                in
+                
+# 1052 "src/ocaml/preprocess/parser_raw.mly"
+    ( x )
+# 43283 "src/ocaml/preprocess/parser_raw.ml"
+                
+              in
+              
+# 1282 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 43289 "src/ocaml/preprocess/parser_raw.ml"
+              
+            in
+            
+# 267 "<standard.mly>"
+    ( xs @ ys )
+# 43295 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_e_) in
+          let _endpos = _endpos__1_ in
+          let _startpos = _startpos__1_ in
+          
+# 976 "src/ocaml/preprocess/parser_raw.mly"
+                              ( extra_def _startpos _endpos _1 )
+# 43304 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 1275 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 43310 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _3;
+          MenhirLib.EngineTypes.startp = _startpos__3_;
+          MenhirLib.EngineTypes.endp = _endpos__3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _2;
+            MenhirLib.EngineTypes.startp = _startpos__2_;
+            MenhirLib.EngineTypes.endp = _endpos__2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _menhir_s;
+              MenhirLib.EngineTypes.semv = _1;
+              MenhirLib.EngineTypes.startp = _startpos__1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_;
+              MenhirLib.EngineTypes.next = _menhir_stack;
+            };
+          };
+        } = _menhir_stack in
+        let _3 : unit = Obj.magic _3 in
+        let _2 : (string) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__3_ in
+        let _v : (string) = 
+# 3687 "src/ocaml/preprocess/parser_raw.mly"
+                              ( _2 )
+# 43349 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 43370 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3695 "src/ocaml/preprocess/parser_raw.mly"
+                              ( _1 )
+# 43378 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (string) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (string) = 
+# 3696 "src/ocaml/preprocess/parser_raw.mly"
+                              ( _1 )
+# 43403 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : (Longident.t) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Longident.t) = 
+# 3763 "src/ocaml/preprocess/parser_raw.mly"
+                                           ( _1 )
+# 43428 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = ty;
+          MenhirLib.EngineTypes.startp = _startpos_ty_;
+          MenhirLib.EngineTypes.endp = _endpos_ty_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _5;
+            MenhirLib.EngineTypes.startp = _startpos__5_;
+            MenhirLib.EngineTypes.endp = _endpos__5_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = mutable_;
+                MenhirLib.EngineTypes.startp = _startpos_mutable__;
+                MenhirLib.EngineTypes.endp = _endpos_mutable__;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let ty : (Parsetree.core_type) = Obj.magic ty in
+        let _5 : unit = Obj.magic _5 in
+        let _1_inlined1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 43475 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined1 in
+        let mutable_ : (Asttypes.mutable_flag) = Obj.magic mutable_ in
+        let _1 : (Parsetree.attributes) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_ty_ in
+        let _v : ((string Location.loc * Asttypes.mutable_flag * Parsetree.class_field_kind) *
+  Parsetree.attributes) = let label =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _1 = 
+# 3661 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 43488 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 43496 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let attrs = 
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 43502 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let _1 = 
+# 3904 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Fresh )
+# 43507 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 2073 "src/ocaml/preprocess/parser_raw.mly"
+      ( (label, mutable_, Cfk_virtual ty), attrs )
+# 43512 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _6;
+          MenhirLib.EngineTypes.startp = _startpos__6_;
+          MenhirLib.EngineTypes.endp = _endpos__6_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _5;
+            MenhirLib.EngineTypes.startp = _startpos__5_;
+            MenhirLib.EngineTypes.endp = _endpos__5_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _3;
+                MenhirLib.EngineTypes.startp = _startpos__3_;
+                MenhirLib.EngineTypes.endp = _endpos__3_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _6 : (Parsetree.expression) = Obj.magic _6 in
+        let _5 : unit = Obj.magic _5 in
+        let _1_inlined1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 43559 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined1 in
+        let _3 : (Asttypes.mutable_flag) = Obj.magic _3 in
+        let _1 : (Parsetree.attributes) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__6_ in
+        let _v : ((string Location.loc * Asttypes.mutable_flag * Parsetree.class_field_kind) *
+  Parsetree.attributes) = let _4 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _1 = 
+# 3661 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 43572 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 43580 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _2 = 
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 43586 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let _1 = 
+# 3907 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Fresh )
+# 43591 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 2075 "src/ocaml/preprocess/parser_raw.mly"
+      ( (_4, _3, Cfk_concrete (_1, _6)), _2 )
+# 43596 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _6;
+          MenhirLib.EngineTypes.startp = _startpos__6_;
+          MenhirLib.EngineTypes.endp = _endpos__6_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _5;
+            MenhirLib.EngineTypes.startp = _startpos__5_;
+            MenhirLib.EngineTypes.endp = _endpos__5_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined2;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _3;
+                MenhirLib.EngineTypes.startp = _startpos__3_;
+                MenhirLib.EngineTypes.endp = _endpos__3_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _6 : (Parsetree.expression) = Obj.magic _6 in
+        let _5 : unit = Obj.magic _5 in
+        let _1_inlined2 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 43649 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined2 in
+        let _3 : (Asttypes.mutable_flag) = Obj.magic _3 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__6_ in
+        let _v : ((string Location.loc * Asttypes.mutable_flag * Parsetree.class_field_kind) *
+  Parsetree.attributes) = let _4 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let _1 = 
+# 3661 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 43663 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 43671 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _2 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 43679 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _1 = 
+# 3908 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Override )
+# 43685 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        
+# 2075 "src/ocaml/preprocess/parser_raw.mly"
+      ( (_4, _3, Cfk_concrete (_1, _6)), _2 )
+# 43690 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _7;
+          MenhirLib.EngineTypes.startp = _startpos__7_;
+          MenhirLib.EngineTypes.endp = _endpos__7_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _6;
+            MenhirLib.EngineTypes.startp = _startpos__6_;
+            MenhirLib.EngineTypes.endp = _endpos__6_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _5;
+              MenhirLib.EngineTypes.startp = _startpos__5_;
+              MenhirLib.EngineTypes.endp = _endpos__5_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined1;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _3;
+                  MenhirLib.EngineTypes.startp = _startpos__3_;
+                  MenhirLib.EngineTypes.endp = _endpos__3_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _7 : (Parsetree.expression) = Obj.magic _7 in
+        let _6 : unit = Obj.magic _6 in
+        let _5 : (Parsetree.core_type option * Parsetree.core_type option) = Obj.magic _5 in
+        let _1_inlined1 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 43744 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined1 in
+        let _3 : (Asttypes.mutable_flag) = Obj.magic _3 in
+        let _1 : (Parsetree.attributes) = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__7_ in
+        let _v : ((string Location.loc * Asttypes.mutable_flag * Parsetree.class_field_kind) *
+  Parsetree.attributes) = let _4 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _1 = 
+# 3661 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 43757 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 43765 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _startpos__4_ = _startpos__1_inlined1_ in
+        let _2 = 
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 43772 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let (_endpos__2_, _startpos__2_) = (_endpos__1_, _startpos__1_) in
+        let _1 = 
+# 3907 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Fresh )
+# 43778 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let (_endpos__1_, _startpos__1_) = (_endpos__0_, _endpos__0_) in
+        let _endpos = _endpos__7_ in
+        let _symbolstartpos = if _startpos__1_ != _endpos__1_ then
+          _startpos__1_
+        else
+          if _startpos__2_ != _endpos__2_ then
+            _startpos__2_
+          else
+            if _startpos__3_ != _endpos__3_ then
+              _startpos__3_
+            else
+              _startpos__4_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2078 "src/ocaml/preprocess/parser_raw.mly"
+      ( let e = mkexp_constraint ~loc:_sloc _7 _5 in
+        (_4, _3, Cfk_concrete (_1, e)), _2
+      )
+# 43798 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _7;
+          MenhirLib.EngineTypes.startp = _startpos__7_;
+          MenhirLib.EngineTypes.endp = _endpos__7_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _6;
+            MenhirLib.EngineTypes.startp = _startpos__6_;
+            MenhirLib.EngineTypes.endp = _endpos__6_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _5;
+              MenhirLib.EngineTypes.startp = _startpos__5_;
+              MenhirLib.EngineTypes.endp = _endpos__5_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _3;
+                  MenhirLib.EngineTypes.startp = _startpos__3_;
+                  MenhirLib.EngineTypes.endp = _endpos__3_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = _1_inlined1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = _1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _7 : (Parsetree.expression) = Obj.magic _7 in
+        let _6 : unit = Obj.magic _6 in
+        let _5 : (Parsetree.core_type option * Parsetree.core_type option) = Obj.magic _5 in
+        let _1_inlined2 : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 43858 "src/ocaml/preprocess/parser_raw.ml"
+        ) = Obj.magic _1_inlined2 in
+        let _3 : (Asttypes.mutable_flag) = Obj.magic _3 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__7_ in
+        let _v : ((string Location.loc * Asttypes.mutable_flag * Parsetree.class_field_kind) *
+  Parsetree.attributes) = let _4 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let _1 = 
+# 3661 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( _1 )
+# 43872 "src/ocaml/preprocess/parser_raw.ml"
+           in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 43880 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _startpos__4_ = _startpos__1_inlined2_ in
+        let _2 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 43889 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let (_endpos__2_, _startpos__2_) = (_endpos__1_inlined1_, _startpos__1_inlined1_) in
+        let _1 = 
+# 3908 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Override )
+# 43896 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        let _endpos = _endpos__7_ in
+        let _symbolstartpos = if _startpos__1_ != _endpos__1_ then
+          _startpos__1_
+        else
+          if _startpos__2_ != _endpos__2_ then
+            _startpos__2_
+          else
+            if _startpos__3_ != _endpos__3_ then
+              _startpos__3_
+            else
+              _startpos__4_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 2078 "src/ocaml/preprocess/parser_raw.mly"
+      ( let e = mkexp_constraint ~loc:_sloc _7 _5 in
+        (_4, _3, Cfk_concrete (_1, e)), _2
+      )
+# 43915 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined3;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined3_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined3_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = ty;
+            MenhirLib.EngineTypes.startp = _startpos_ty_;
+            MenhirLib.EngineTypes.endp = _endpos_ty_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _5;
+              MenhirLib.EngineTypes.startp = _startpos__5_;
+              MenhirLib.EngineTypes.endp = _endpos__5_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined2;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _1_inlined1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _;
+                    MenhirLib.EngineTypes.semv = ext;
+                    MenhirLib.EngineTypes.startp = _startpos_ext_;
+                    MenhirLib.EngineTypes.endp = _endpos_ext_;
+                    MenhirLib.EngineTypes.next = {
+                      MenhirLib.EngineTypes.state = _menhir_s;
+                      MenhirLib.EngineTypes.semv = _1;
+                      MenhirLib.EngineTypes.startp = _startpos__1_;
+                      MenhirLib.EngineTypes.endp = _endpos__1_;
+                      MenhirLib.EngineTypes.next = _menhir_stack;
+                    };
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in
+        let ty : (Parsetree.core_type) = Obj.magic ty in
+        let _5 : unit = Obj.magic _5 in
+        let _1_inlined2 : (string) = Obj.magic _1_inlined2 in
+        let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in
+        let ext : (string Location.loc option) = Obj.magic ext in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined3_ in
+        let _v : (Parsetree.value_description * string Location.loc option) = let attrs2 =
+          let _1 = _1_inlined3 in
+          
+# 4001 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 43984 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos_attrs2_ = _endpos__1_inlined3_ in
+        let id =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 43996 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let attrs1 =
+          let _1 = _1_inlined1 in
+          
+# 4005 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 44004 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos_attrs2_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3038 "src/ocaml/preprocess/parser_raw.mly"
+    ( let attrs = attrs1 @ attrs2 in
+      let loc = make_loc _sloc in
+      let docs = symbol_docs _sloc in
+      Val.mk id ty ~attrs ~loc ~docs,
+      ext )
+# 44017 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let _menhir_s = _menhir_env.MenhirLib.EngineTypes.current in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _endpos = _startpos in
+        let _v : (Asttypes.virtual_flag) = 
+# 3868 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Concrete )
+# 44035 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Asttypes.virtual_flag) = 
+# 3869 "src/ocaml/preprocess/parser_raw.mly"
+                                                ( Virtual )
+# 44060 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Asttypes.mutable_flag) = 
+# 3892 "src/ocaml/preprocess/parser_raw.mly"
+            ( Immutable )
+# 44085 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Asttypes.mutable_flag) = 
+# 3893 "src/ocaml/preprocess/parser_raw.mly"
+                    ( Mutable )
+# 44117 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Asttypes.mutable_flag) = 
+# 3894 "src/ocaml/preprocess/parser_raw.mly"
+                    ( Mutable )
+# 44149 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Asttypes.private_flag) = 
+# 3899 "src/ocaml/preprocess/parser_raw.mly"
+            ( Public )
+# 44174 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Asttypes.private_flag) = 
+# 3900 "src/ocaml/preprocess/parser_raw.mly"
+                    ( Private )
+# 44206 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Asttypes.private_flag) = 
+# 3901 "src/ocaml/preprocess/parser_raw.mly"
+                    ( Private )
+# 44238 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = xs;
+          MenhirLib.EngineTypes.startp = _startpos_xs_;
+          MenhirLib.EngineTypes.endp = _endpos_xs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _1_inlined2;
+            MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+            MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _4;
+              MenhirLib.EngineTypes.startp = _startpos__4_;
+              MenhirLib.EngineTypes.endp = _endpos__4_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _1_inlined1;
+                MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _;
+                  MenhirLib.EngineTypes.semv = _2;
+                  MenhirLib.EngineTypes.startp = _startpos__2_;
+                  MenhirLib.EngineTypes.endp = _endpos__2_;
+                  MenhirLib.EngineTypes.next = {
+                    MenhirLib.EngineTypes.state = _menhir_s;
+                    MenhirLib.EngineTypes.semv = _1;
+                    MenhirLib.EngineTypes.startp = _startpos__1_;
+                    MenhirLib.EngineTypes.endp = _endpos__1_;
+                    MenhirLib.EngineTypes.next = _menhir_stack;
+                  };
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let xs : ((Parsetree.core_type * Parsetree.core_type * Location.t) list) = Obj.magic xs in
+        let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in
+        let _4 : (Asttypes.private_flag) = Obj.magic _4 in
+        let _1_inlined1 : (Longident.t) = Obj.magic _1_inlined1 in
+        let _2 : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_xs_ in
+        let _v : (Parsetree.with_constraint) = let _6 =
+          let _1 =
+            let xs = 
+# 253 "<standard.mly>"
+    ( List.rev xs )
+# 44300 "src/ocaml/preprocess/parser_raw.ml"
+             in
+            
+# 1064 "src/ocaml/preprocess/parser_raw.mly"
+    ( xs )
+# 44305 "src/ocaml/preprocess/parser_raw.ml"
+            
+          in
+          
+# 3138 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 44311 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__6_ = _endpos_xs_ in
+        let _5 =
+          let _1 = _1_inlined2 in
+          
+# 3457 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 44320 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _3 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 44331 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__6_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3376 "src/ocaml/preprocess/parser_raw.mly"
+      ( let lident = loc_last _3 in
+        Pwith_type
+          (_3,
+           (Type.mk lident
+              ~params:_2
+              ~cstrs:_6
+              ~manifest:_5
+              ~priv:_4
+              ~loc:(make_loc _sloc))) )
+# 44348 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined2;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in
+        let _4 : unit = Obj.magic _4 in
+        let _1_inlined1 : (Longident.t) = Obj.magic _1_inlined1 in
+        let _2 : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined2_ in
+        let _v : (Parsetree.with_constraint) = let _5 =
+          let _1 = _1_inlined2 in
+          
+# 3457 "src/ocaml/preprocess/parser_raw.mly"
+    ( _1 )
+# 44403 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos__5_ = _endpos__1_inlined2_ in
+        let _3 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 44415 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _endpos = _endpos__5_ in
+        let _symbolstartpos = _startpos__1_ in
+        let _sloc = (_symbolstartpos, _endpos) in
+        
+# 3389 "src/ocaml/preprocess/parser_raw.mly"
+      ( let lident = loc_last _3 in
+        Pwith_typesubst
+         (_3,
+           (Type.mk lident
+              ~params:_2
+              ~manifest:_5
+              ~loc:(make_loc _sloc))) )
+# 44430 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined2;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined2 : (Longident.t) = Obj.magic _1_inlined2 in
+        let _3 : unit = Obj.magic _3 in
+        let _1_inlined1 : (Longident.t) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined2_ in
+        let _v : (Parsetree.with_constraint) = let _4 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 44481 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _2 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 44492 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3397 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pwith_module (_2, _4) )
+# 44498 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _1_inlined2;
+          MenhirLib.EngineTypes.startp = _startpos__1_inlined2_;
+          MenhirLib.EngineTypes.endp = _endpos__1_inlined2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _3;
+            MenhirLib.EngineTypes.startp = _startpos__3_;
+            MenhirLib.EngineTypes.endp = _endpos__3_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _menhir_s;
+                MenhirLib.EngineTypes.semv = _1;
+                MenhirLib.EngineTypes.startp = _startpos__1_;
+                MenhirLib.EngineTypes.endp = _endpos__1_;
+                MenhirLib.EngineTypes.next = _menhir_stack;
+              };
+            };
+          };
+        } = _menhir_stack in
+        let _1_inlined2 : (Longident.t) = Obj.magic _1_inlined2 in
+        let _3 : unit = Obj.magic _3 in
+        let _1_inlined1 : (Longident.t) = Obj.magic _1_inlined1 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_inlined2_ in
+        let _v : (Parsetree.with_constraint) = let _4 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 44549 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        let _2 =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 44560 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3399 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pwith_modsubst (_2, _4) )
+# 44566 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = rhs;
+          MenhirLib.EngineTypes.startp = _startpos_rhs_;
+          MenhirLib.EngineTypes.endp = _endpos_rhs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let rhs : (Parsetree.module_type) = Obj.magic rhs in
+        let _4 : unit = Obj.magic _4 in
+        let _1_inlined1 : (Longident.t) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_rhs_ in
+        let _v : (Parsetree.with_constraint) = let l =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 44624 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3401 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pwith_modtype (l, rhs) )
+# 44630 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = rhs;
+          MenhirLib.EngineTypes.startp = _startpos_rhs_;
+          MenhirLib.EngineTypes.endp = _endpos_rhs_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _;
+            MenhirLib.EngineTypes.semv = _4;
+            MenhirLib.EngineTypes.startp = _startpos__4_;
+            MenhirLib.EngineTypes.endp = _endpos__4_;
+            MenhirLib.EngineTypes.next = {
+              MenhirLib.EngineTypes.state = _;
+              MenhirLib.EngineTypes.semv = _1_inlined1;
+              MenhirLib.EngineTypes.startp = _startpos__1_inlined1_;
+              MenhirLib.EngineTypes.endp = _endpos__1_inlined1_;
+              MenhirLib.EngineTypes.next = {
+                MenhirLib.EngineTypes.state = _;
+                MenhirLib.EngineTypes.semv = _2;
+                MenhirLib.EngineTypes.startp = _startpos__2_;
+                MenhirLib.EngineTypes.endp = _endpos__2_;
+                MenhirLib.EngineTypes.next = {
+                  MenhirLib.EngineTypes.state = _menhir_s;
+                  MenhirLib.EngineTypes.semv = _1;
+                  MenhirLib.EngineTypes.startp = _startpos__1_;
+                  MenhirLib.EngineTypes.endp = _endpos__1_;
+                  MenhirLib.EngineTypes.next = _menhir_stack;
+                };
+              };
+            };
+          };
+        } = _menhir_stack in
+        let rhs : (Parsetree.module_type) = Obj.magic rhs in
+        let _4 : unit = Obj.magic _4 in
+        let _1_inlined1 : (Longident.t) = Obj.magic _1_inlined1 in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos_rhs_ in
+        let _v : (Parsetree.with_constraint) = let l =
+          let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in
+          let _endpos = _endpos__1_ in
+          let _symbolstartpos = _startpos__1_ in
+          let _sloc = (_symbolstartpos, _endpos) in
+          
+# 980 "src/ocaml/preprocess/parser_raw.mly"
+    ( mkrhs _1 _sloc )
+# 44688 "src/ocaml/preprocess/parser_raw.ml"
+          
+        in
+        
+# 3403 "src/ocaml/preprocess/parser_raw.mly"
+      ( Pwith_modtypesubst (l, rhs) )
+# 44694 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = _1;
+          MenhirLib.EngineTypes.startp = _startpos__1_;
+          MenhirLib.EngineTypes.endp = _endpos__1_;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        } = _menhir_stack in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__1_ in
+        let _v : (Asttypes.private_flag) = 
+# 3406 "src/ocaml/preprocess/parser_raw.mly"
+                   ( Public )
+# 44719 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+      (fun _menhir_env ->
+        let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in
+        let {
+          MenhirLib.EngineTypes.state = _;
+          MenhirLib.EngineTypes.semv = _2;
+          MenhirLib.EngineTypes.startp = _startpos__2_;
+          MenhirLib.EngineTypes.endp = _endpos__2_;
+          MenhirLib.EngineTypes.next = {
+            MenhirLib.EngineTypes.state = _menhir_s;
+            MenhirLib.EngineTypes.semv = _1;
+            MenhirLib.EngineTypes.startp = _startpos__1_;
+            MenhirLib.EngineTypes.endp = _endpos__1_;
+            MenhirLib.EngineTypes.next = _menhir_stack;
+          };
+        } = _menhir_stack in
+        let _2 : unit = Obj.magic _2 in
+        let _1 : unit = Obj.magic _1 in
+        let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in
+        let _startpos = _startpos__1_ in
+        let _endpos = _endpos__2_ in
+        let _v : (Asttypes.private_flag) = 
+# 3407 "src/ocaml/preprocess/parser_raw.mly"
+                   ( Private )
+# 44751 "src/ocaml/preprocess/parser_raw.ml"
+         in
+        {
+          MenhirLib.EngineTypes.state = _menhir_s;
+          MenhirLib.EngineTypes.semv = Obj.repr _v;
+          MenhirLib.EngineTypes.startp = _startpos;
+          MenhirLib.EngineTypes.endp = _endpos;
+          MenhirLib.EngineTypes.next = _menhir_stack;
+        });
+    |]
+  
+  and trace =
+    None
+  
+end
+
+module MenhirInterpreter = struct
+  
+  module ET = MenhirLib.TableInterpreter.MakeEngineTable (Tables)
+  
+  module TI = MenhirLib.Engine.Make (ET)
+  
+  include TI
+  
+  module Symbols = struct
+    
+    type _ terminal = 
+      | T_error : unit terminal
+      | T_WITH : unit terminal
+      | T_WHILE_LWT : unit terminal
+      | T_WHILE : unit terminal
+      | T_WHEN : unit terminal
+      | T_VIRTUAL : unit terminal
+      | T_VAL : unit terminal
+      | T_UNDERSCORE : unit terminal
+      | T_UIDENT : (
+# 839 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 44789 "src/ocaml/preprocess/parser_raw.ml"
+    ) terminal
+      | T_TYPE : unit terminal
+      | T_TRY_LWT : unit terminal
+      | T_TRY : unit terminal
+      | T_TRUE : unit terminal
+      | T_TO : unit terminal
+      | T_TILDE : unit terminal
+      | T_THEN : unit terminal
+      | T_STRUCT : unit terminal
+      | T_STRING : (
+# 825 "src/ocaml/preprocess/parser_raw.mly"
+       (string * Location.t * string option)
+# 44802 "src/ocaml/preprocess/parser_raw.ml"
+    ) terminal
+      | T_STAR : unit terminal
+      | T_SIG : unit terminal
+      | T_SEMISEMI : unit terminal
+      | T_SEMI : unit terminal
+      | T_RPAREN : unit terminal
+      | T_REC : unit terminal
+      | T_RBRACKET : unit terminal
+      | T_RBRACE : unit terminal
+      | T_QUOTED_STRING_ITEM : (
+# 830 "src/ocaml/preprocess/parser_raw.mly"
+  (string * Location.t * string * Location.t * string option)
+# 44815 "src/ocaml/preprocess/parser_raw.ml"
+    ) terminal
+      | T_QUOTED_STRING_EXPR : (
+# 827 "src/ocaml/preprocess/parser_raw.mly"
+  (string * Location.t * string * Location.t * string option)
+# 44820 "src/ocaml/preprocess/parser_raw.ml"
+    ) terminal
+      | T_QUOTE : unit terminal
+      | T_QUESTION : unit terminal
+      | T_PRIVATE : unit terminal
+      | T_PREFIXOP : (
+# 811 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 44828 "src/ocaml/preprocess/parser_raw.ml"
+    ) terminal
+      | T_PLUSEQ : unit terminal
+      | T_PLUSDOT : unit terminal
+      | T_PLUS : unit terminal
+      | T_PERCENT : unit terminal
+      | T_OR : unit terminal
+      | T_OPTLABEL : (
+# 804 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 44838 "src/ocaml/preprocess/parser_raw.ml"
+    ) terminal
+      | T_OPEN : unit terminal
+      | T_OF : unit terminal
+      | T_OBJECT : unit terminal
+      | T_NONREC : unit terminal
+      | T_NEW : unit terminal
+      | T_MUTABLE : unit terminal
+      | T_MODULE : unit terminal
+      | T_MINUSGREATER : unit terminal
+      | T_MINUSDOT : unit terminal
+      | T_MINUS : unit terminal
+      | T_METHOD : unit terminal
+      | T_MATCH_LWT : unit terminal
+      | T_MATCH : unit terminal
+      | T_LPAREN : unit terminal
+      | T_LIDENT : (
+# 787 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 44857 "src/ocaml/preprocess/parser_raw.ml"
+    ) terminal
+      | T_LET_LWT : unit terminal
+      | T_LETOP : (
+# 769 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 44863 "src/ocaml/preprocess/parser_raw.ml"
+    ) terminal
+      | T_LET : unit terminal
+      | T_LESSMINUS : unit terminal
+      | T_LESS : unit terminal
+      | T_LBRACKETPERCENTPERCENT : unit terminal
+      | T_LBRACKETPERCENT : unit terminal
+      | T_LBRACKETLESS : unit terminal
+      | T_LBRACKETGREATER : unit terminal
+      | T_LBRACKETBAR : unit terminal
+      | T_LBRACKETATATAT : unit terminal
+      | T_LBRACKETATAT : unit terminal
+      | T_LBRACKETAT : unit terminal
+      | T_LBRACKET : unit terminal
+      | T_LBRACELESS : unit terminal
+      | T_LBRACE : unit terminal
+      | T_LAZY : unit terminal
+      | T_LABEL : (
+# 774 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 44883 "src/ocaml/preprocess/parser_raw.ml"
+    ) terminal
+      | T_INT : (
+# 773 "src/ocaml/preprocess/parser_raw.mly"
+       (string * char option)
+# 44888 "src/ocaml/preprocess/parser_raw.ml"
+    ) terminal
+      | T_INITIALIZER : unit terminal
+      | T_INHERIT : unit terminal
+      | T_INFIXOP4 : (
+# 767 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 44895 "src/ocaml/preprocess/parser_raw.ml"
+    ) terminal
+      | T_INFIXOP3 : (
+# 766 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 44900 "src/ocaml/preprocess/parser_raw.ml"
+    ) terminal
+      | T_INFIXOP2 : (
+# 765 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 44905 "src/ocaml/preprocess/parser_raw.ml"
+    ) terminal
+      | T_INFIXOP1 : (
+# 764 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 44910 "src/ocaml/preprocess/parser_raw.ml"
+    ) terminal
+      | T_INFIXOP0 : (
+# 763 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 44915 "src/ocaml/preprocess/parser_raw.ml"
+    ) terminal
+      | T_INCLUDE : unit terminal
+      | T_IN : unit terminal
+      | T_IF : unit terminal
+      | T_HASHOP : (
+# 822 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 44923 "src/ocaml/preprocess/parser_raw.ml"
+    ) terminal
+      | T_HASH : unit terminal
+      | T_GREATERRBRACKET : unit terminal
+      | T_GREATERRBRACE : unit terminal
+      | T_GREATERDOT : unit terminal
+      | T_GREATER : unit terminal
+      | T_FUNCTOR : unit terminal
+      | T_FUNCTION : unit terminal
+      | T_FUN : unit terminal
+      | T_FOR_LWT : unit terminal
+      | T_FOR : unit terminal
+      | T_FLOAT : (
+# 752 "src/ocaml/preprocess/parser_raw.mly"
+       (string * char option)
+# 44938 "src/ocaml/preprocess/parser_raw.ml"
+    ) terminal
+      | T_FINALLY_LWT : unit terminal
+      | T_FALSE : unit terminal
+      | T_EXTERNAL : unit terminal
+      | T_EXCEPTION : unit terminal
+      | T_EQUAL : unit terminal
+      | T_EOL : unit terminal
+      | T_EOF : unit terminal
+      | T_END : unit terminal
+      | T_ELSE : unit terminal
+      | T_DOWNTO : unit terminal
+      | T_DOTTILDE : unit terminal
+      | T_DOTOP : (
+# 768 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 44954 "src/ocaml/preprocess/parser_raw.ml"
+    ) terminal
+      | T_DOTLESS : unit terminal
+      | T_DOTDOT : unit terminal
+      | T_DOT : unit terminal
+      | T_DONE : unit terminal
+      | T_DOCSTRING : (
+# 847 "src/ocaml/preprocess/parser_raw.mly"
+       (Docstrings.docstring)
+# 44963 "src/ocaml/preprocess/parser_raw.ml"
+    ) terminal
+      | T_DO : unit terminal
+      | T_CONSTRAINT : unit terminal
+      | T_COMMENT : (
+# 846 "src/ocaml/preprocess/parser_raw.mly"
+       (string * Location.t)
+# 44970 "src/ocaml/preprocess/parser_raw.ml"
+    ) terminal
+      | T_COMMA : unit terminal
+      | T_COLONGREATER : unit terminal
+      | T_COLONEQUAL : unit terminal
+      | T_COLONCOLON : unit terminal
+      | T_COLON : unit terminal
+      | T_CLASS : unit terminal
+      | T_CHAR : (
+# 732 "src/ocaml/preprocess/parser_raw.mly"
+       (char)
+# 44981 "src/ocaml/preprocess/parser_raw.ml"
+    ) terminal
+      | T_BEGIN : unit terminal
+      | T_BARRBRACKET : unit terminal
+      | T_BARBAR : unit terminal
+      | T_BAR : unit terminal
+      | T_BANG : unit terminal
+      | T_BACKQUOTE : unit terminal
+      | T_ASSERT : unit terminal
+      | T_AS : unit terminal
+      | T_ANDOP : (
+# 770 "src/ocaml/preprocess/parser_raw.mly"
+       (string)
+# 44994 "src/ocaml/preprocess/parser_raw.ml"
+    ) terminal
+      | T_AND : unit terminal
+      | T_AMPERSAND : unit terminal
+      | T_AMPERAMPER : unit terminal
+    
+    type _ nonterminal = 
+      | N_with_type_binder : (Asttypes.private_flag) nonterminal
+      | N_with_constraint : (Parsetree.with_constraint) nonterminal
+      | N_virtual_with_private_flag : (Asttypes.private_flag) nonterminal
+      | N_virtual_with_mutable_flag : (Asttypes.mutable_flag) nonterminal
+      | N_virtual_flag : (Asttypes.virtual_flag) nonterminal
+      | N_value_description : (Parsetree.value_description * string Location.loc option) nonterminal
+      | N_value : ((string Location.loc * Asttypes.mutable_flag * Parsetree.class_field_kind) *
+  Parsetree.attributes) nonterminal
+      | N_val_longident : (Longident.t) nonterminal
+      | N_val_ident : (string) nonterminal
+      | N_val_extra_ident : (string) nonterminal
+      | N_use_file : (Parsetree.toplevel_phrase list) nonterminal
+      | N_type_variance : (Asttypes.variance * Asttypes.injectivity) nonterminal
+      | N_type_variable : (Parsetree.core_type) nonterminal
+      | N_type_parameters : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) nonterminal
+      | N_type_parameter : (Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) nonterminal
+      | N_type_longident : (Longident.t) nonterminal
+      | N_type_kind : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) nonterminal
+      | N_type_constraint : (Parsetree.core_type option * Parsetree.core_type option) nonterminal
+      | N_tuple_type : (Parsetree.core_type) nonterminal
+      | N_toplevel_phrase : (Parsetree.toplevel_phrase) nonterminal
+      | N_toplevel_directive : (Parsetree.toplevel_phrase) nonterminal
+      | N_tag_field : (Parsetree.row_field) nonterminal
+      | N_subtractive : (string) nonterminal
+      | N_structure_item : (Parsetree.structure_item) nonterminal
+      | N_structure : (Parsetree.structure) nonterminal
+      | N_strict_binding : (Parsetree.expression) nonterminal
+      | N_str_exception_declaration : (Parsetree.type_exception * string Location.loc option) nonterminal
+      | N_single_attr_id : (string) nonterminal
+      | N_simple_pattern_not_ident : (Parsetree.pattern) nonterminal
+      | N_simple_pattern : (Parsetree.pattern) nonterminal
+      | N_simple_expr : (Parsetree.expression) nonterminal
+      | N_simple_delimited_pattern : (Parsetree.pattern) nonterminal
+      | N_signed_constant : (Parsetree.constant) nonterminal
+      | N_signature_item : (Parsetree.signature_item) nonterminal
+      | N_signature : (Parsetree.signature) nonterminal
+      | N_sig_exception_declaration : (Parsetree.type_exception * string Location.loc option) nonterminal
+      | N_seq_expr : (Parsetree.expression) nonterminal
+      | N_separated_or_terminated_nonempty_list_SEMI_record_expr_field_ : ((Longident.t Location.loc * Parsetree.expression) list) nonterminal
+      | N_separated_or_terminated_nonempty_list_SEMI_pattern_ : (Parsetree.pattern list) nonterminal
+      | N_separated_or_terminated_nonempty_list_SEMI_object_expr_field_ : ((string Location.loc * Parsetree.expression) list) nonterminal
+      | N_separated_or_terminated_nonempty_list_SEMI_expr_ : (Parsetree.expression list) nonterminal
+      | N_row_field : (Parsetree.row_field) nonterminal
+      | N_reversed_separated_nontrivial_llist_STAR_atomic_type_ : (Parsetree.core_type list) nonterminal
+      | N_reversed_separated_nontrivial_llist_COMMA_expr_ : (Parsetree.expression list) nonterminal
+      | N_reversed_separated_nontrivial_llist_COMMA_core_type_ : (Parsetree.core_type list) nonterminal
+      | N_reversed_separated_nonempty_llist_STAR_atomic_type_ : (Parsetree.core_type list) nonterminal
+      | N_reversed_separated_nonempty_llist_COMMA_type_parameter_ : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) nonterminal
+      | N_reversed_separated_nonempty_llist_COMMA_core_type_ : (Parsetree.core_type list) nonterminal
+      | N_reversed_separated_nonempty_llist_BAR_row_field_ : (Parsetree.row_field list) nonterminal
+      | N_reversed_separated_nonempty_llist_AND_with_constraint_ : (Parsetree.with_constraint list) nonterminal
+      | N_reversed_separated_nonempty_llist_AMPERSAND_core_type_no_attr_ : (Parsetree.core_type list) nonterminal
+      | N_reversed_preceded_or_separated_nonempty_llist_BAR_match_case_ : (Parsetree.case list) nonterminal
+      | N_reversed_nonempty_llist_typevar_ : (string Location.loc list) nonterminal
+      | N_reversed_nonempty_llist_name_tag_ : (string list) nonterminal
+      | N_reversed_nonempty_llist_labeled_simple_expr_ : ((Asttypes.arg_label * Parsetree.expression) list) nonterminal
+      | N_reversed_nonempty_llist_functor_arg_ : ((Lexing.position * Parsetree.functor_parameter) list) nonterminal
+      | N_reversed_llist_preceded_CONSTRAINT_constrain__ : ((Parsetree.core_type * Parsetree.core_type * Location.t) list) nonterminal
+      | N_reversed_bar_llist_extension_constructor_declaration_ : (Parsetree.extension_constructor list) nonterminal
+      | N_reversed_bar_llist_extension_constructor_ : (Parsetree.extension_constructor list) nonterminal
+      | N_reversed_bar_llist_constructor_declaration_ : (Parsetree.constructor_declaration list) nonterminal
+      | N_record_expr_content : (Parsetree.expression option *
+  (Longident.t Location.loc * Parsetree.expression) list) nonterminal
+      | N_rec_flag : (Asttypes.rec_flag) nonterminal
+      | N_private_virtual_flags : (Asttypes.private_flag * Asttypes.virtual_flag) nonterminal
+      | N_private_flag : (Asttypes.private_flag) nonterminal
+      | N_primitive_declaration : (Parsetree.value_description * string Location.loc option) nonterminal
+      | N_post_item_attribute : (Parsetree.attribute) nonterminal
+      | N_possibly_poly_core_type_no_attr_ : (Parsetree.core_type) nonterminal
+      | N_possibly_poly_core_type_ : (Parsetree.core_type) nonterminal
+      | N_payload : (Parsetree.payload) nonterminal
+      | N_pattern_var : (Parsetree.pattern) nonterminal
+      | N_pattern_no_exn : (Parsetree.pattern) nonterminal
+      | N_pattern_gen : (Parsetree.pattern) nonterminal
+      | N_pattern_comma_list_pattern_no_exn_ : (Parsetree.pattern list) nonterminal
+      | N_pattern_comma_list_pattern_ : (Parsetree.pattern list) nonterminal
+      | N_pattern : (Parsetree.pattern) nonterminal
+      | N_parse_val_longident : (Longident.t) nonterminal
+      | N_parse_pattern : (Parsetree.pattern) nonterminal
+      | N_parse_mty_longident : (Longident.t) nonterminal
+      | N_parse_mod_longident : (Longident.t) nonterminal
+      | N_parse_mod_ext_longident : (Longident.t) nonterminal
+      | N_parse_expression : (Parsetree.expression) nonterminal
+      | N_parse_core_type : (Parsetree.core_type) nonterminal
+      | N_parse_constr_longident : (Longident.t) nonterminal
+      | N_parse_any_longident : (Longident.t) nonterminal
+      | N_paren_module_expr : (Parsetree.module_expr) nonterminal
+      | N_optlabel : (string) nonterminal
+      | N_option_type_constraint_ : ((Parsetree.core_type option * Parsetree.core_type option) option) nonterminal
+      | N_option_preceded_EQUAL_seq_expr__ : (Parsetree.expression option) nonterminal
+      | N_option_preceded_EQUAL_pattern__ : (Parsetree.pattern option) nonterminal
+      | N_option_preceded_EQUAL_module_type__ : (Parsetree.module_type option) nonterminal
+      | N_option_preceded_EQUAL_expr__ : (Parsetree.expression option) nonterminal
+      | N_option_preceded_COLON_core_type__ : (Parsetree.core_type option) nonterminal
+      | N_option_preceded_AS_mkrhs_LIDENT___ : (string Location.loc option) nonterminal
+      | N_option_SEMI_ : (unit option) nonterminal
+      | N_option_BAR_ : (unit option) nonterminal
+      | N_opt_ampersand : (bool) nonterminal
+      | N_operator : (string) nonterminal
+      | N_open_description : (Longident.t Location.loc Parsetree.open_infos * string Location.loc option) nonterminal
+      | N_open_declaration : (Parsetree.module_expr Parsetree.open_infos * string Location.loc option) nonterminal
+      | N_nonempty_type_kind : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) nonterminal
+      | N_nonempty_list_raw_string_ : (string list) nonterminal
+      | N_nonempty_list_mkrhs_LIDENT__ : (string Location.loc list) nonterminal
+      | N_name_tag : (string) nonterminal
+      | N_mutable_virtual_flags : (Asttypes.mutable_flag * Asttypes.virtual_flag) nonterminal
+      | N_mutable_flag : (Asttypes.mutable_flag) nonterminal
+      | N_mty_longident : (Longident.t) nonterminal
+      | N_module_type_subst : (Parsetree.module_type_declaration * string Location.loc option) nonterminal
+      | N_module_type_declaration : (Parsetree.module_type_declaration * string Location.loc option) nonterminal
+      | N_module_type : (Parsetree.module_type) nonterminal
+      | N_module_subst : (Parsetree.module_substitution * string Location.loc option) nonterminal
+      | N_module_name : (string option) nonterminal
+      | N_module_expr : (Parsetree.module_expr) nonterminal
+      | N_module_declaration_body : (Parsetree.module_type) nonterminal
+      | N_module_binding_body : (Parsetree.module_expr) nonterminal
+      | N_mod_longident : (Longident.t) nonterminal
+      | N_mod_ext_longident : (Longident.t) nonterminal
+      | N_mk_longident_mod_longident_val_ident_ : (Longident.t) nonterminal
+      | N_mk_longident_mod_longident_UIDENT_ : (Longident.t) nonterminal
+      | N_mk_longident_mod_longident_LIDENT_ : (Longident.t) nonterminal
+      | N_mk_longident_mod_ext_longident_ident_ : (Longident.t) nonterminal
+      | N_mk_longident_mod_ext_longident___anonymous_41_ : (Longident.t) nonterminal
+      | N_mk_longident_mod_ext_longident_UIDENT_ : (Longident.t) nonterminal
+      | N_mk_longident_mod_ext_longident_LIDENT_ : (Longident.t) nonterminal
+      | N_method_ : ((string Location.loc * Asttypes.private_flag * Parsetree.class_field_kind) *
+  Parsetree.attributes) nonterminal
+      | N_meth_list : (Parsetree.object_field list * Asttypes.closed_flag) nonterminal
+      | N_match_case : (Parsetree.case) nonterminal
+      | N_lwt_bindings : (Ast_helper.let_bindings) nonterminal
+      | N_lwt_binding : (Ast_helper.let_bindings) nonterminal
+      | N_listx_SEMI_record_pat_field_UNDERSCORE_ : ((Longident.t Location.loc * Parsetree.pattern) list * unit option) nonterminal
+      | N_list_use_file_element_ : (Parsetree.toplevel_phrase list list) nonterminal
+      | N_list_text_str_structure_item__ : (Parsetree.structure_item list list) nonterminal
+      | N_list_text_cstr_class_field__ : (Parsetree.class_field list list) nonterminal
+      | N_list_text_csig_class_sig_field__ : (Parsetree.class_type_field list list) nonterminal
+      | N_list_structure_element_ : (Parsetree.structure_item list list) nonterminal
+      | N_list_signature_element_ : (Parsetree.signature_item list list) nonterminal
+      | N_list_post_item_attribute_ : (Parsetree.attributes) nonterminal
+      | N_list_generic_and_type_declaration_type_subst_kind__ : (Parsetree.type_declaration list) nonterminal
+      | N_list_generic_and_type_declaration_type_kind__ : (Parsetree.type_declaration list) nonterminal
+      | N_list_attribute_ : (Parsetree.attributes) nonterminal
+      | N_list_and_module_declaration_ : (Parsetree.module_declaration list) nonterminal
+      | N_list_and_module_binding_ : (Parsetree.module_binding list) nonterminal
+      | N_list_and_class_type_declaration_ : (Parsetree.class_type Parsetree.class_infos list) nonterminal
+      | N_list_and_class_description_ : (Parsetree.class_type Parsetree.class_infos list) nonterminal
+      | N_list_and_class_declaration_ : (Parsetree.class_expr Parsetree.class_infos list) nonterminal
+      | N_letop_bindings : (Parsetree.pattern * Parsetree.expression * Parsetree.binding_op list) nonterminal
+      | N_letop_binding_body : (Parsetree.pattern * Parsetree.expression) nonterminal
+      | N_let_pattern : (Parsetree.pattern) nonterminal
+      | N_let_bindings_no_ext_ : (Ast_helper.let_bindings) nonterminal
+      | N_let_bindings_ext_ : (Ast_helper.let_bindings) nonterminal
+      | N_let_binding_body_no_punning : (Parsetree.pattern * Parsetree.expression) nonterminal
+      | N_let_binding_body : (Parsetree.pattern * Parsetree.expression * bool) nonterminal
+      | N_labeled_simple_pattern : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) nonterminal
+      | N_labeled_simple_expr : (Asttypes.arg_label * Parsetree.expression) nonterminal
+      | N_label_longident : (Longident.t) nonterminal
+      | N_label_let_pattern : (string * Parsetree.pattern) nonterminal
+      | N_label_declarations : (Parsetree.label_declaration list) nonterminal
+      | N_label_declaration_semi : (Parsetree.label_declaration) nonterminal
+      | N_label_declaration : (Parsetree.label_declaration) nonterminal
+      | N_item_extension : (Parsetree.extension) nonterminal
+      | N_interface : (Parsetree.signature) nonterminal
+      | N_index_mod : (string) nonterminal
+      | N_implementation : (Parsetree.structure) nonterminal
+      | N_ident : (string) nonterminal
+      | N_generic_type_declaration_nonrec_flag_type_kind_ : ((Asttypes.rec_flag * string Location.loc option) *
+  Parsetree.type_declaration) nonterminal
+      | N_generic_type_declaration_no_nonrec_flag_type_subst_kind_ : ((Asttypes.rec_flag * string Location.loc option) *
+  Parsetree.type_declaration) nonterminal
+      | N_generic_constructor_declaration_epsilon_ : (Ocaml_parsing.Ast_helper.str * Parsetree.constructor_arguments *
+  Parsetree.core_type option * Parsetree.attributes * Location.t *
+  Ocaml_parsing.Docstrings.info) nonterminal
+      | N_generic_constructor_declaration_BAR_ : (Ocaml_parsing.Ast_helper.str * Parsetree.constructor_arguments *
+  Parsetree.core_type option * Parsetree.attributes * Location.t *
+  Ocaml_parsing.Docstrings.info) nonterminal
+      | N_generalized_constructor_arguments : (Parsetree.constructor_arguments * Parsetree.core_type option) nonterminal
+      | N_functor_args : ((Lexing.position * Parsetree.functor_parameter) list) nonterminal
+      | N_functor_arg : (Lexing.position * Parsetree.functor_parameter) nonterminal
+      | N_function_type : (Parsetree.core_type) nonterminal
+      | N_fun_def : (Parsetree.expression) nonterminal
+      | N_fun_binding : (Parsetree.expression) nonterminal
+      | N_formal_class_parameters : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) nonterminal
+      | N_floating_attribute : (Parsetree.attribute) nonterminal
+      | N_extension_constructor_rebind_epsilon_ : (Parsetree.extension_constructor) nonterminal
+      | N_extension_constructor_rebind_BAR_ : (Parsetree.extension_constructor) nonterminal
+      | N_extension : (Parsetree.extension) nonterminal
+      | N_ext : (string Location.loc option) nonterminal
+      | N_expr : (Parsetree.expression) nonterminal
+      | N_direction_flag : (Asttypes.direction_flag) nonterminal
+      | N_core_type : (Parsetree.core_type) nonterminal
+      | N_constructor_declarations : (Parsetree.constructor_declaration list) nonterminal
+      | N_constructor_arguments : (Parsetree.constructor_arguments) nonterminal
+      | N_constrain_field : (Parsetree.core_type * Parsetree.core_type) nonterminal
+      | N_constr_longident : (Longident.t) nonterminal
+      | N_constr_ident : (string) nonterminal
+      | N_constr_extra_nonprefix_ident : (string) nonterminal
+      | N_constant : (Parsetree.constant) nonterminal
+      | N_clty_longident : (Longident.t) nonterminal
+      | N_class_type_declarations : (string Location.loc option * Parsetree.class_type_declaration list) nonterminal
+      | N_class_type : (Parsetree.class_type) nonterminal
+      | N_class_simple_expr : (Parsetree.class_expr) nonterminal
+      | N_class_signature : (Parsetree.class_type) nonterminal
+      | N_class_sig_field : (Parsetree.class_type_field) nonterminal
+      | N_class_self_type : (Parsetree.core_type) nonterminal
+      | N_class_self_pattern : (Parsetree.pattern) nonterminal
+      | N_class_longident : (Longident.t) nonterminal
+      | N_class_fun_def : (Parsetree.class_expr) nonterminal
+      | N_class_fun_binding : (Parsetree.class_expr) nonterminal
+      | N_class_field : (Parsetree.class_field) nonterminal
+      | N_class_expr : (Parsetree.class_expr) nonterminal
+      | N_attribute : (Parsetree.attribute) nonterminal
+      | N_attr_id : (string Location.loc) nonterminal
+      | N_atomic_type : (Parsetree.core_type) nonterminal
+      | N_any_longident : (Longident.t) nonterminal
+      | N_and_let_binding : (Ast_helper.let_binding) nonterminal
+      | N_alias_type : (Parsetree.core_type) nonterminal
+      | N_additive : (string) nonterminal
+    
+  end
+  
+  include Symbols
+  
+  include MenhirLib.InspectionTableInterpreter.Make (Tables) (struct
+    
+    include TI
+    
+    include Symbols
+    
+    include MenhirLib.InspectionTableInterpreter.Symbols (Symbols)
+    
+    let terminal =
+      fun t ->
+        match t with
+        | 0 ->
+            X (T T_error)
+        | 1 ->
+            X (T T_WITH)
+        | 2 ->
+            X (T T_WHILE_LWT)
+        | 3 ->
+            X (T T_WHILE)
+        | 4 ->
+            X (T T_WHEN)
+        | 5 ->
+            X (T T_VIRTUAL)
+        | 6 ->
+            X (T T_VAL)
+        | 7 ->
+            X (T T_UNDERSCORE)
+        | 8 ->
+            X (T T_UIDENT)
+        | 9 ->
+            X (T T_TYPE)
+        | 10 ->
+            X (T T_TRY_LWT)
+        | 11 ->
+            X (T T_TRY)
+        | 12 ->
+            X (T T_TRUE)
+        | 13 ->
+            X (T T_TO)
+        | 14 ->
+            X (T T_TILDE)
+        | 15 ->
+            X (T T_THEN)
+        | 16 ->
+            X (T T_STRUCT)
+        | 17 ->
+            X (T T_STRING)
+        | 18 ->
+            X (T T_STAR)
+        | 19 ->
+            X (T T_SIG)
+        | 20 ->
+            X (T T_SEMISEMI)
+        | 21 ->
+            X (T T_SEMI)
+        | 22 ->
+            X (T T_RPAREN)
+        | 23 ->
+            X (T T_REC)
+        | 24 ->
+            X (T T_RBRACKET)
+        | 25 ->
+            X (T T_RBRACE)
+        | 26 ->
+            X (T T_QUOTED_STRING_ITEM)
+        | 27 ->
+            X (T T_QUOTED_STRING_EXPR)
+        | 28 ->
+            X (T T_QUOTE)
+        | 29 ->
+            X (T T_QUESTION)
+        | 30 ->
+            X (T T_PRIVATE)
+        | 31 ->
+            X (T T_PREFIXOP)
+        | 32 ->
+            X (T T_PLUSEQ)
+        | 33 ->
+            X (T T_PLUSDOT)
+        | 34 ->
+            X (T T_PLUS)
+        | 35 ->
+            X (T T_PERCENT)
+        | 36 ->
+            X (T T_OR)
+        | 37 ->
+            X (T T_OPTLABEL)
+        | 38 ->
+            X (T T_OPEN)
+        | 39 ->
+            X (T T_OF)
+        | 40 ->
+            X (T T_OBJECT)
+        | 41 ->
+            X (T T_NONREC)
+        | 42 ->
+            X (T T_NEW)
+        | 43 ->
+            X (T T_MUTABLE)
+        | 44 ->
+            X (T T_MODULE)
+        | 45 ->
+            X (T T_MINUSGREATER)
+        | 46 ->
+            X (T T_MINUSDOT)
+        | 47 ->
+            X (T T_MINUS)
+        | 48 ->
+            X (T T_METHOD)
+        | 49 ->
+            X (T T_MATCH_LWT)
+        | 50 ->
+            X (T T_MATCH)
+        | 51 ->
+            X (T T_LPAREN)
+        | 52 ->
+            X (T T_LIDENT)
+        | 53 ->
+            X (T T_LET_LWT)
+        | 54 ->
+            X (T T_LETOP)
+        | 55 ->
+            X (T T_LET)
+        | 56 ->
+            X (T T_LESSMINUS)
+        | 57 ->
+            X (T T_LESS)
+        | 58 ->
+            X (T T_LBRACKETPERCENTPERCENT)
+        | 59 ->
+            X (T T_LBRACKETPERCENT)
+        | 60 ->
+            X (T T_LBRACKETLESS)
+        | 61 ->
+            X (T T_LBRACKETGREATER)
+        | 62 ->
+            X (T T_LBRACKETBAR)
+        | 63 ->
+            X (T T_LBRACKETATATAT)
+        | 64 ->
+            X (T T_LBRACKETATAT)
+        | 65 ->
+            X (T T_LBRACKETAT)
+        | 66 ->
+            X (T T_LBRACKET)
+        | 67 ->
+            X (T T_LBRACELESS)
+        | 68 ->
+            X (T T_LBRACE)
+        | 69 ->
+            X (T T_LAZY)
+        | 70 ->
+            X (T T_LABEL)
+        | 71 ->
+            X (T T_INT)
+        | 72 ->
+            X (T T_INITIALIZER)
+        | 73 ->
+            X (T T_INHERIT)
+        | 74 ->
+            X (T T_INFIXOP4)
+        | 75 ->
+            X (T T_INFIXOP3)
+        | 76 ->
+            X (T T_INFIXOP2)
+        | 77 ->
+            X (T T_INFIXOP1)
+        | 78 ->
+            X (T T_INFIXOP0)
+        | 79 ->
+            X (T T_INCLUDE)
+        | 80 ->
+            X (T T_IN)
+        | 81 ->
+            X (T T_IF)
+        | 82 ->
+            X (T T_HASHOP)
+        | 83 ->
+            X (T T_HASH)
+        | 84 ->
+            X (T T_GREATERRBRACKET)
+        | 85 ->
+            X (T T_GREATERRBRACE)
+        | 86 ->
+            X (T T_GREATERDOT)
+        | 87 ->
+            X (T T_GREATER)
+        | 88 ->
+            X (T T_FUNCTOR)
+        | 89 ->
+            X (T T_FUNCTION)
+        | 90 ->
+            X (T T_FUN)
+        | 91 ->
+            X (T T_FOR_LWT)
+        | 92 ->
+            X (T T_FOR)
+        | 93 ->
+            X (T T_FLOAT)
+        | 94 ->
+            X (T T_FINALLY_LWT)
+        | 95 ->
+            X (T T_FALSE)
+        | 96 ->
+            X (T T_EXTERNAL)
+        | 97 ->
+            X (T T_EXCEPTION)
+        | 98 ->
+            X (T T_EQUAL)
+        | 99 ->
+            X (T T_EOL)
+        | 100 ->
+            X (T T_EOF)
+        | 101 ->
+            X (T T_END)
+        | 102 ->
+            X (T T_ELSE)
+        | 103 ->
+            X (T T_DOWNTO)
+        | 104 ->
+            X (T T_DOTTILDE)
+        | 105 ->
+            X (T T_DOTOP)
+        | 106 ->
+            X (T T_DOTLESS)
+        | 107 ->
+            X (T T_DOTDOT)
+        | 108 ->
+            X (T T_DOT)
+        | 109 ->
+            X (T T_DONE)
+        | 110 ->
+            X (T T_DOCSTRING)
+        | 111 ->
+            X (T T_DO)
+        | 112 ->
+            X (T T_CONSTRAINT)
+        | 113 ->
+            X (T T_COMMENT)
+        | 114 ->
+            X (T T_COMMA)
+        | 115 ->
+            X (T T_COLONGREATER)
+        | 116 ->
+            X (T T_COLONEQUAL)
+        | 117 ->
+            X (T T_COLONCOLON)
+        | 118 ->
+            X (T T_COLON)
+        | 119 ->
+            X (T T_CLASS)
+        | 120 ->
+            X (T T_CHAR)
+        | 121 ->
+            X (T T_BEGIN)
+        | 122 ->
+            X (T T_BARRBRACKET)
+        | 123 ->
+            X (T T_BARBAR)
+        | 124 ->
+            X (T T_BAR)
+        | 125 ->
+            X (T T_BANG)
+        | 126 ->
+            X (T T_BACKQUOTE)
+        | 127 ->
+            X (T T_ASSERT)
+        | 128 ->
+            X (T T_AS)
+        | 129 ->
+            X (T T_ANDOP)
+        | 130 ->
+            X (T T_AND)
+        | 131 ->
+            X (T T_AMPERSAND)
+        | 132 ->
+            X (T T_AMPERAMPER)
+        | _ ->
+            assert false
+    
+    and nonterminal =
+      fun nt ->
+        match nt with
+        | 221 ->
+            X (N N_additive)
+        | 220 ->
+            X (N N_alias_type)
+        | 219 ->
+            X (N N_and_let_binding)
+        | 218 ->
+            X (N N_any_longident)
+        | 217 ->
+            X (N N_atomic_type)
+        | 216 ->
+            X (N N_attr_id)
+        | 215 ->
+            X (N N_attribute)
+        | 214 ->
+            X (N N_class_expr)
+        | 213 ->
+            X (N N_class_field)
+        | 212 ->
+            X (N N_class_fun_binding)
+        | 211 ->
+            X (N N_class_fun_def)
+        | 210 ->
+            X (N N_class_longident)
+        | 209 ->
+            X (N N_class_self_pattern)
+        | 208 ->
+            X (N N_class_self_type)
+        | 207 ->
+            X (N N_class_sig_field)
+        | 206 ->
+            X (N N_class_signature)
+        | 205 ->
+            X (N N_class_simple_expr)
+        | 204 ->
+            X (N N_class_type)
+        | 203 ->
+            X (N N_class_type_declarations)
+        | 202 ->
+            X (N N_clty_longident)
+        | 201 ->
+            X (N N_constant)
+        | 200 ->
+            X (N N_constr_extra_nonprefix_ident)
+        | 199 ->
+            X (N N_constr_ident)
+        | 198 ->
+            X (N N_constr_longident)
+        | 197 ->
+            X (N N_constrain_field)
+        | 196 ->
+            X (N N_constructor_arguments)
+        | 195 ->
+            X (N N_constructor_declarations)
+        | 194 ->
+            X (N N_core_type)
+        | 193 ->
+            X (N N_direction_flag)
+        | 192 ->
+            X (N N_expr)
+        | 191 ->
+            X (N N_ext)
+        | 190 ->
+            X (N N_extension)
+        | 189 ->
+            X (N N_extension_constructor_rebind_BAR_)
+        | 188 ->
+            X (N N_extension_constructor_rebind_epsilon_)
+        | 187 ->
+            X (N N_floating_attribute)
+        | 186 ->
+            X (N N_formal_class_parameters)
+        | 185 ->
+            X (N N_fun_binding)
+        | 184 ->
+            X (N N_fun_def)
+        | 183 ->
+            X (N N_function_type)
+        | 182 ->
+            X (N N_functor_arg)
+        | 181 ->
+            X (N N_functor_args)
+        | 180 ->
+            X (N N_generalized_constructor_arguments)
+        | 179 ->
+            X (N N_generic_constructor_declaration_BAR_)
+        | 178 ->
+            X (N N_generic_constructor_declaration_epsilon_)
+        | 177 ->
+            X (N N_generic_type_declaration_no_nonrec_flag_type_subst_kind_)
+        | 176 ->
+            X (N N_generic_type_declaration_nonrec_flag_type_kind_)
+        | 175 ->
+            X (N N_ident)
+        | 174 ->
+            X (N N_implementation)
+        | 173 ->
+            X (N N_index_mod)
+        | 172 ->
+            X (N N_interface)
+        | 171 ->
+            X (N N_item_extension)
+        | 170 ->
+            X (N N_label_declaration)
+        | 169 ->
+            X (N N_label_declaration_semi)
+        | 168 ->
+            X (N N_label_declarations)
+        | 167 ->
+            X (N N_label_let_pattern)
+        | 166 ->
+            X (N N_label_longident)
+        | 165 ->
+            X (N N_labeled_simple_expr)
+        | 164 ->
+            X (N N_labeled_simple_pattern)
+        | 163 ->
+            X (N N_let_binding_body)
+        | 162 ->
+            X (N N_let_binding_body_no_punning)
+        | 161 ->
+            X (N N_let_bindings_ext_)
+        | 160 ->
+            X (N N_let_bindings_no_ext_)
+        | 159 ->
+            X (N N_let_pattern)
+        | 158 ->
+            X (N N_letop_binding_body)
+        | 157 ->
+            X (N N_letop_bindings)
+        | 156 ->
+            X (N N_list_and_class_declaration_)
+        | 155 ->
+            X (N N_list_and_class_description_)
+        | 154 ->
+            X (N N_list_and_class_type_declaration_)
+        | 153 ->
+            X (N N_list_and_module_binding_)
+        | 152 ->
+            X (N N_list_and_module_declaration_)
+        | 151 ->
+            X (N N_list_attribute_)
+        | 150 ->
+            X (N N_list_generic_and_type_declaration_type_kind__)
+        | 149 ->
+            X (N N_list_generic_and_type_declaration_type_subst_kind__)
+        | 148 ->
+            X (N N_list_post_item_attribute_)
+        | 147 ->
+            X (N N_list_signature_element_)
+        | 146 ->
+            X (N N_list_structure_element_)
+        | 145 ->
+            X (N N_list_text_csig_class_sig_field__)
+        | 144 ->
+            X (N N_list_text_cstr_class_field__)
+        | 143 ->
+            X (N N_list_text_str_structure_item__)
+        | 142 ->
+            X (N N_list_use_file_element_)
+        | 141 ->
+            X (N N_listx_SEMI_record_pat_field_UNDERSCORE_)
+        | 140 ->
+            X (N N_lwt_binding)
+        | 139 ->
+            X (N N_lwt_bindings)
+        | 138 ->
+            X (N N_match_case)
+        | 137 ->
+            X (N N_meth_list)
+        | 136 ->
+            X (N N_method_)
+        | 135 ->
+            X (N N_mk_longident_mod_ext_longident_LIDENT_)
+        | 134 ->
+            X (N N_mk_longident_mod_ext_longident_UIDENT_)
+        | 133 ->
+            X (N N_mk_longident_mod_ext_longident___anonymous_41_)
+        | 132 ->
+            X (N N_mk_longident_mod_ext_longident_ident_)
+        | 131 ->
+            X (N N_mk_longident_mod_longident_LIDENT_)
+        | 130 ->
+            X (N N_mk_longident_mod_longident_UIDENT_)
+        | 129 ->
+            X (N N_mk_longident_mod_longident_val_ident_)
+        | 128 ->
+            X (N N_mod_ext_longident)
+        | 127 ->
+            X (N N_mod_longident)
+        | 126 ->
+            X (N N_module_binding_body)
+        | 125 ->
+            X (N N_module_declaration_body)
+        | 124 ->
+            X (N N_module_expr)
+        | 123 ->
+            X (N N_module_name)
+        | 122 ->
+            X (N N_module_subst)
+        | 121 ->
+            X (N N_module_type)
+        | 120 ->
+            X (N N_module_type_declaration)
+        | 119 ->
+            X (N N_module_type_subst)
+        | 118 ->
+            X (N N_mty_longident)
+        | 117 ->
+            X (N N_mutable_flag)
+        | 116 ->
+            X (N N_mutable_virtual_flags)
+        | 115 ->
+            X (N N_name_tag)
+        | 114 ->
+            X (N N_nonempty_list_mkrhs_LIDENT__)
+        | 113 ->
+            X (N N_nonempty_list_raw_string_)
+        | 112 ->
+            X (N N_nonempty_type_kind)
+        | 111 ->
+            X (N N_open_declaration)
+        | 110 ->
+            X (N N_open_description)
+        | 109 ->
+            X (N N_operator)
+        | 108 ->
+            X (N N_opt_ampersand)
+        | 107 ->
+            X (N N_option_BAR_)
+        | 106 ->
+            X (N N_option_SEMI_)
+        | 105 ->
+            X (N N_option_preceded_AS_mkrhs_LIDENT___)
+        | 104 ->
+            X (N N_option_preceded_COLON_core_type__)
+        | 103 ->
+            X (N N_option_preceded_EQUAL_expr__)
+        | 102 ->
+            X (N N_option_preceded_EQUAL_module_type__)
+        | 101 ->
+            X (N N_option_preceded_EQUAL_pattern__)
+        | 100 ->
+            X (N N_option_preceded_EQUAL_seq_expr__)
+        | 99 ->
+            X (N N_option_type_constraint_)
+        | 98 ->
+            X (N N_optlabel)
+        | 97 ->
+            X (N N_paren_module_expr)
+        | 96 ->
+            X (N N_parse_any_longident)
+        | 95 ->
+            X (N N_parse_constr_longident)
+        | 94 ->
+            X (N N_parse_core_type)
+        | 93 ->
+            X (N N_parse_expression)
+        | 92 ->
+            X (N N_parse_mod_ext_longident)
+        | 91 ->
+            X (N N_parse_mod_longident)
+        | 90 ->
+            X (N N_parse_mty_longident)
+        | 89 ->
+            X (N N_parse_pattern)
+        | 88 ->
+            X (N N_parse_val_longident)
+        | 87 ->
+            X (N N_pattern)
+        | 86 ->
+            X (N N_pattern_comma_list_pattern_)
+        | 85 ->
+            X (N N_pattern_comma_list_pattern_no_exn_)
+        | 84 ->
+            X (N N_pattern_gen)
+        | 83 ->
+            X (N N_pattern_no_exn)
+        | 82 ->
+            X (N N_pattern_var)
+        | 81 ->
+            X (N N_payload)
+        | 80 ->
+            X (N N_possibly_poly_core_type_)
+        | 79 ->
+            X (N N_possibly_poly_core_type_no_attr_)
+        | 78 ->
+            X (N N_post_item_attribute)
+        | 77 ->
+            X (N N_primitive_declaration)
+        | 76 ->
+            X (N N_private_flag)
+        | 75 ->
+            X (N N_private_virtual_flags)
+        | 74 ->
+            X (N N_rec_flag)
+        | 73 ->
+            X (N N_record_expr_content)
+        | 72 ->
+            X (N N_reversed_bar_llist_constructor_declaration_)
+        | 71 ->
+            X (N N_reversed_bar_llist_extension_constructor_)
+        | 70 ->
+            X (N N_reversed_bar_llist_extension_constructor_declaration_)
+        | 69 ->
+            X (N N_reversed_llist_preceded_CONSTRAINT_constrain__)
+        | 68 ->
+            X (N N_reversed_nonempty_llist_functor_arg_)
+        | 67 ->
+            X (N N_reversed_nonempty_llist_labeled_simple_expr_)
+        | 66 ->
+            X (N N_reversed_nonempty_llist_name_tag_)
+        | 65 ->
+            X (N N_reversed_nonempty_llist_typevar_)
+        | 64 ->
+            X (N N_reversed_preceded_or_separated_nonempty_llist_BAR_match_case_)
+        | 63 ->
+            X (N N_reversed_separated_nonempty_llist_AMPERSAND_core_type_no_attr_)
+        | 62 ->
+            X (N N_reversed_separated_nonempty_llist_AND_with_constraint_)
+        | 61 ->
+            X (N N_reversed_separated_nonempty_llist_BAR_row_field_)
+        | 60 ->
+            X (N N_reversed_separated_nonempty_llist_COMMA_core_type_)
+        | 59 ->
+            X (N N_reversed_separated_nonempty_llist_COMMA_type_parameter_)
+        | 58 ->
+            X (N N_reversed_separated_nonempty_llist_STAR_atomic_type_)
+        | 57 ->
+            X (N N_reversed_separated_nontrivial_llist_COMMA_core_type_)
+        | 56 ->
+            X (N N_reversed_separated_nontrivial_llist_COMMA_expr_)
+        | 55 ->
+            X (N N_reversed_separated_nontrivial_llist_STAR_atomic_type_)
+        | 54 ->
+            X (N N_row_field)
+        | 53 ->
+            X (N N_separated_or_terminated_nonempty_list_SEMI_expr_)
+        | 52 ->
+            X (N N_separated_or_terminated_nonempty_list_SEMI_object_expr_field_)
+        | 51 ->
+            X (N N_separated_or_terminated_nonempty_list_SEMI_pattern_)
+        | 50 ->
+            X (N N_separated_or_terminated_nonempty_list_SEMI_record_expr_field_)
+        | 49 ->
+            X (N N_seq_expr)
+        | 48 ->
+            X (N N_sig_exception_declaration)
+        | 47 ->
+            X (N N_signature)
+        | 46 ->
+            X (N N_signature_item)
+        | 45 ->
+            X (N N_signed_constant)
+        | 44 ->
+            X (N N_simple_delimited_pattern)
+        | 43 ->
+            X (N N_simple_expr)
+        | 42 ->
+            X (N N_simple_pattern)
+        | 41 ->
+            X (N N_simple_pattern_not_ident)
+        | 40 ->
+            X (N N_single_attr_id)
+        | 39 ->
+            X (N N_str_exception_declaration)
+        | 38 ->
+            X (N N_strict_binding)
+        | 37 ->
+            X (N N_structure)
+        | 36 ->
+            X (N N_structure_item)
+        | 35 ->
+            X (N N_subtractive)
+        | 34 ->
+            X (N N_tag_field)
+        | 33 ->
+            X (N N_toplevel_directive)
+        | 32 ->
+            X (N N_toplevel_phrase)
+        | 31 ->
+            X (N N_tuple_type)
+        | 30 ->
+            X (N N_type_constraint)
+        | 29 ->
+            X (N N_type_kind)
+        | 28 ->
+            X (N N_type_longident)
+        | 27 ->
+            X (N N_type_parameter)
+        | 26 ->
+            X (N N_type_parameters)
+        | 25 ->
+            X (N N_type_variable)
+        | 24 ->
+            X (N N_type_variance)
+        | 23 ->
+            X (N N_use_file)
+        | 22 ->
+            X (N N_val_extra_ident)
+        | 21 ->
+            X (N N_val_ident)
+        | 20 ->
+            X (N N_val_longident)
+        | 19 ->
+            X (N N_value)
+        | 18 ->
+            X (N N_value_description)
+        | 17 ->
+            X (N N_virtual_flag)
+        | 16 ->
+            X (N N_virtual_with_mutable_flag)
+        | 15 ->
+            X (N N_virtual_with_private_flag)
+        | 14 ->
+            X (N N_with_constraint)
+        | 13 ->
+            X (N N_with_type_binder)
+        | _ ->
+            assert false
+    
+    and lr0_incoming =
+      (16, "\000\000\000\006\000H\000\004\000\b\000\n\000\012\000\014\000\018\000\020\000\024\000\026\000\028\000 \000\"\000(\0000\000>\000J\000N\000P\000R\000T\000V\000X\000Z\000b\000f\000j\000p\000\140\000\146\000\148\000\160\000\162\000\164\000\178\000\180\000\182\000\186\000\192\000\194\000\196\000\204\000\206\000\208\000\220\000\224\000\226\000\240\000\244\001\000\001\002\001\006\000Q\000\218\001\177\001\177\001\127\000\132\001\177\000\b\001\127\001/\000\016\000\018\000\022\001\127\001/\000\024\001\127\001/\000\026\000$\0008\000@\000V\001\127\001/\000j\000\255\000\218\000\018\000j\001\005\001\007\001\165\001\175\001/\000h\000&\000.\000@\000j\000x\001\177\000\014\001\127\001/\000h\000@\000B\000D\000F\000H\000J\000^\000`\000n\000t\000\150\000\152\000\154\000\156\000\158\000\166\000\176\000\198\000\212\000h\000,\000\216\001[\000.\000r\000\134\001[\0002\000r\000\138\001[\0004\000r\000\234\000\248\000\252\001\004\001\b\001\n\000\219\000.\000+\000\238\000\016\000\018\000:\000\018\000j\001_\000<\000j\000\238\000L\000h\000Z\001\127\001/\000\018\000(\001/\000\020\001\127\001/\000@\000F\000\252\000T\000`\000\252\000h\000\154\000\252\000F\000`\0001\000\016\000:\001_\0003\0007\000w\000.\000\230\0007\0005\000j\000\198\000\018\000>\000h\000j\000\238\000j\000t\000j\000\238\000:\001_\000z\000\250\000\215\000|\0002\000\215\000\134\000\168\001\001\000h\001\001\000.\000\218\000\018\001\r\000\218\000j\001\015\001\149\000\250\000\254\001_\0009\000?\000\\\000o\000&\001\015\001}\001\179\000\168\001\149\0009\000\197\000?\000\\\001o\001\179\000&\001\179\001o\000E\000m\000{\0002\000\250\000m\000\231\000P\001\b\000\217\000\127\001\b\001o\001\185\001\002\000:\001_\001/\001\185\001/\001\133\001\175\001\185\000E\0002\000m\000\250\000{\0002\000{\0002\000{\0002\000\176\000\133\0002\000\231\000\231\000\131\000:\001_\000\218\001\185\000\159\001/\000,\001/\000\216\001\019\001\179\000,\001\019\001\185\000\176\001\019\000\176\000?\000\\\001o\000\236\000.\000s\000.\000\168\001\149\0009\000\230\001\133\001\133\000.\000\230\001\133\000\134\0002\000\138\000X\000\235\000j\000\238\000\159\001/\000,\001/\001Q\0004\001S\001Q\001U\000\192\000\216\000\250\000\018\000h\000\134\001\143\000P\000\138\001Q\0004\000u\000&\001\179\001\137\001\179\000\238\001\137\000\\\001\179\001\179\001i\001/\001\145\000\145\000\250\001g\001e\001g\001\133\001\135\001\143\001i\001/\000\138\001Q\0004\000\216\000\225\001\133\000\198\000>\000\138\001Q\0004\000\216\001\135\000\138\001Q\0004\000\216\001\135\001\135\000\234\000\225\000\139\000\130\001\177\000\020\001\127\001/\000T\0005\000j\000;\000\139\000\226\001\133\000\198\001\133\000\157\001)\001)\0009\000B\000>\000\153\000\250\001\143\000\198\000h\000\236\000.\000\255\000\218\000h\000\236\000.\001\141\001/\001\145\000\143\001)\001g\001{\001e\001g\001y\001{\001\143\000\198\001\141\001/\0007\0005\000j\000;\000\139\001)\0009\000B\000\153\000\143\001)\000*\0006\000D\000F\000N\000\252\001\127\001/\000\016\000\"\001/\000R\001\127\001/\000h\000\016\000F\000\144\000\188\000`\000\144\000\188\000h\000F\000Z\001\127\001/\000\016\000\018\000\247\000.\000\238\000Z\000\020\000P\001/\000h\000\014\001/\000^\000`\000d\001\127\001/\000f\001\127\001/\000j\000r\000l\001\127\001/\0000\000\149\000~\000\134\000\138\001\007\001\027\0004\001M\000\238\001\133\000\209\000\198\000\140\001\127\001/\000\144\000\168\0009\000\188\000\242\000+\000-\000S\000U\000Y\000[\000\216\000[\001\147\000\231\000\255\000\218\000h\000.\000\196\001\127\001/\000U\000\169\000\173\000\230\000\175\000\230\000\175\000\236\000\175\000\250\000\175\001\002\000+\001\175\000\231\000\175\001}\001\141\000h\000\020\000j\000\229\000\229\000.\000U\001\141\000`\000\175\000.\000\238\001\133\000.\000\175\000\175\000\175\000.\000\134\0002\000g\0002\000\175\000,\000g\000Y\000\175\000\203\000,\000\016\000,\000\213\001\027\000\246\000g\000\246\000+\000\030\000h\000j\000\238\001\133\001O\000.\000j\000<\000h\001O\000\198\000n\000+\000L\000\016\000h\000\175\000\238\001\133\001?\000\201\000.\000j\000\165\000h\000\020\000\229\000.\000\142\000U\000\198\000p\000N\000\252\001\127\001/\000\178\001/\000h\000.\000\247\000\238\000h\000\178\001/\000\137\001m\001k\000\\\000\237\000\243\000\004\000\020\0005\001M\000\198\000>\000\234\001\185\000\027\001\185\000\139\000Z\000\020\000\237\000\198\000\243\000\\\000\243\001\175\001\001\000\218\000\018\001_\001\t\001_\001}\000\234\000\243\000\255\000\198\001\001\000\218\000\234\001\001\000\029\000}\001\006\000\029\001m\000\243\000.\000\243\000.\001k\000\\\000\195\000\249\000h\000.\000\249\000.\000\238\000\243\000.\000\195\001\175\000\255\001}\000\249\000\162\000~\000\134\000\136\000j\000\198\000\138\000j\000\210\000\214\000\140\001\127\001/\000\244\001\127\001/\000\164\001\127\001/\000\180\001\127\001/\000\250\000\175\000\n\000\182\001\127\001/\000h\000\020\000\229\000.\000\\\000\184\001\127\001/\000\175\000\162\000\186\001\127\001/\000\175\000\198\000\252\000)\000+\000W\000\166\000W\000\168\000j\000\212\000h\001\000\001\127\001/\000W\000\218\000h\000G\000W\000\030\000j\000<\000j\000L\000W\000\231\000\255\000\218\000h\000.\000D\000F\000Z\001\127\001/\000\249\000\238\000\243\000.\000^\000`\000n\000U\000\238\001\133\000\198\000c\000q\000\230\000\231\000W\001\003\001}\001\141\001\147\001\023\000\162\000c\001\025\001C\000\162\000c\001\129\000&\001\129\000B\001\129\000D\001\129\000F\001\129\000H\001\129\000J\001\129\000^\001\129\000`\001\129\000t\001\129\000\150\001\129\000\152\001\129\000\154\001\129\000\156\001\129\000\158\001\129\000\176\001\129\000\198\001\129\000\230\001\129\000\234\001\129\000\236\001\129\000\248\001\129\001\b\001\129\001\n\001\129\001\175\001\141\000W\001\187\001\129\000,\000H\001\177\000c\000c\001\006\001/\000S\000\238\001\133\000\198\000c\000\167\000\198\000c\000\230\000\175\000\236\000\175\000\250\000\175\001\002\000+\001\175\000\169\000\171\000\230\000\175\001E\001G\001)\001\183\001\183\001\129\000\167\000\198\000c\001;\000\162\000c\001\004\001=\001=\000\252\000c\000.\000~\000\246\000k\000\246\001\129\000,\000k\000\134\0002\000k\0002\000\136\000i\000\172\000\138\000W\000\004\000e\001M\000\232\001\133\000\238\001\133\000\232\001\133\000=\000\199\000\207\000,\000e\000e\000\147\0004\000\255\000\218\000j\000+\000\142\000W\000\212\000h\000k\000.\000r\001\129\000\134\000k\0002\000r\001\129\000\138\000k\0004\000r\001\129\000\218\000h\000c\000.\000r\001\129\000\134\000c\0002\000r\001\129\000\138\000c\0004\000r\001\129\000\255\000\212\000h\000k\000.\000r\001\129\000\134\000k\0002\000r\001\129\000\138\000k\0004\000r\001\129\001M\000r\001\129\000W\000\135\001K\001K\001\129\000c\000.\000\134\000c\0002\000\138\000c\0004\000\255\000\212\000h\000k\000.\000\134\000k\0002\000\138\000k\0004\001M\000k\000.\000\134\000k\0002\000\138\000k\0004\000c\000\028\000\208\001\131\000c\000\224\000c\000\220\000c\000\224\000c\000\220\000\198\000c\001\131\000c\000\224\000c\000\220\000c\000h\000\020\000\229\000.\000\238\001\179\000\\\000c\000U\001I\001q\001q\001q\001I\001q\000c\000\\\000c\000\\\000\218\000c\001\021\000\129\000\250\001\021\001\021\000c\000 \001\129\000\206\001\129\000\204\000c\000\204\000W\001\129\000\174\000W\000\147\0004\001\129\000\207\000,\000i\000\172\000i\000\172\000k\0002\000\246\000k\000\246\000c\001\127\001/\000\249\000\162\000c\000Z\001\127\001/\000\247\000\198\000\249\000\238\000\243\000\198\000\249\000\253\000\162\000c\001m\000\253\000\196\001\127\001/\001\143\001i\001/\000\162\000c\001\127\001/\000\149\001G\001)\000c\000=\000\198\000c\000M\001I\001s\001s\000M\000c\000\201\000.\000j\000\238\000\020\000\229\000\218\001\133\000\198\000c\000\131\000\218\001\133\000\198\000c\000=\000\198\000c\000M\001G\001)\001\129\000c\000\004\000\129\000c\000\004\000\129\001\129\000.\000\232\000\243\000.\000\238\000\243\000.\000\232\000\243\000.\000\249\000\243\000.\000\175\000.\000\238\001\133\000.\001\163\000\014\000\252\001/\000\235\000j\000\198\000c\000=\000\198\000c\000'\001)\001/\000\012\000X\000X\000\012\000!\000j\000\238\001\133\000\235\000j\000\198\000c\000=\000\198\000c\000b\000\252\001/\000\153\000j\000\238\000\020\000\229\000\218\001\133\000\198\000c\000\131\000\218\001\133\000\161\000\198\000c\001\133\000M\001\017\001)\001/\000\012\000>\000>\000\012\000\031\000j\000\238\000\161\000\153\000j\000\238\000\020\000\229\000\218\001\133\000\198\000c\000\161\000\198\000c\000M\000v\001\177\000<\000\175\000\n\000c\000Z\000\020\001\127\001/\001_\000\198\000\243\000\205\001)\001\127\001/\0000\000\247\000\253\001)\001\006\001/\000\247\000\253\001)\0013\0013\000\247\000\253\001)\000\128\001\177\000\160\001\127\001/\000\249\001)\000\194\001\127\001/\000+\000\238\001\133\000\198\000$\000\227\000\227\001)\000\196\001\127\001/\001\143\000\198\001\141\001/\001)\001i\001/\001)\000\238\000*\000N\000\252\001\127\001/\001\001\001)\001\127\001/\001\001\001)\000Z\000\020\001\127\001/\001_\000\234\000\243\001)\001\127\001/\000\018\000\234\001\001\001)\0000\000\247\000\238\000\243\001)\001\006\001/\000\247\000\238\000\243\001)\0011\0011\000\247\000\198\000\255\001)\000\238\000\243\000\251\001)\001m\000\251\000\160\001\127\001/\000\243\001)\000\196\001\127\001/\001\143\000\240\000\020\001\127\001/\000\012\000#\000\134\000w\0002\001u\000j\000\198\000R\001/\000h\001\133\000.\001\161\000\014\001/\000\012\000X\000X\000\012\000\233\000j\000\238\001\133\001)\000b\001/\000\012\000>\000>\000\012\000\151\000j\000\238\000\161\001)\000\148\001/\000p\000N\000\252\001/\000\255\000\162\000\134\000y\0002\001\149\000\230\001\133\001\133\001}\001\149\001\157\001\175\001/\000\255\000\162\001\157\001\157\001)\000\226\001/\001\133\000\198\001\133\001\139\001)\001#\000\204\001W\001)\001w\001\159\001#\001\157\001)\001\006\001/\000#\001u\000j\000\198\001\157\001)\0015\0015\001\127\001/\000#\001u\000j\000\238\000j\000\238\000?\000\\\000\134\001\133\000?\000\\\000\197\000?\000\\\001\015\001}\001\153\001\157\001\153\001\153\001\153\001)\001\006\001/\000#\001u\000j\000\238\001\153\001)\0017\0017\000%\000]\000a\000\155\000\221\000\239\000\241\000\245\001'\001W\001)\001a\001\006\001/\0005\000j\000;\000\139\001)\001-\001-\001c\001\006\001/\0005\000j\000\234\000\225\000\139\001)\001+\001+\001w\001\151\001'\000_\001'\001\133\000\240\001\127\001/\000#\001u\000j\000\198\000R\001/\001\163\000\146\001/\000c\001)\000\148\000\252\001/\000h\000p\000H\001\177\001/\000\149\001G\001)\000N\000\252\001/\000\255\000\162\000\134\000y\0002\001\165\000\182\001/\001I\000\\\001A\000\162\001}\001\155\000\135\001\165\001\173\001\175\001\183\001\173\001\167\001\167\001\173\001/\000\255\000\162\001\173\001/\000\149\001G\001)\001\173\000.\000\238\001\153\000.\001\173\001\002\000j\000\211\001)\001/\001\173\000\211\001)\000\226\001/\001\139\001)\001!\000\204\001W\001)\001w\001\171\001!\001\173\000\238\001\153\000\198\001\173\001I\001\169\001\169\001)\001\006\001/\000#\001u\000j\001\169\001)\0019\0019\000%\000I\000p\000O\000a\000\155\000\223\000\241\001\023\001%\001C\001W\001)\001a\001-\001w\001\151\000K\000c\001)\001%\000\163\0002\001\023\001%\001C\000\163\0002\001!\000\204\000K\000\204\000\249\001)\001\127\001/\000\249\001)\000c\001)\001%\001%\000\163\0002\001)\0009\000B\000\153\000\141\001)\001g\001e\001g\0005\000j\000\234\000\225\000\139\001)\0009\000B\000\153\000\141\001)\000_\000\204\000\243\000.\001\133\001)\000\163\0002\000W\000Z\001\127\001/\000\249\000.\000\238\000\243\000.\000c\000.\000=\000.\000c\000\004\000\129\000c\000\004\000\129\000\190\000c\000\190\000c\000c\000\224\000c\000\220\000\163\0002\001/\000c\000\224\000c\000\220\000K\000\202\001]\000\000\000_\000\202\001Y\000\000\000h\000\236\000.\000-\000\193\001\001\000\218\000h\000\236\000.\000-\001_\001\011\001_\001\145\001\181\000\202\000\000\000\191\001\141\000\202\000\000\000\189\001\133\000\202\000\000\000c\000\202\000\187\000\000\000\185\001\001\000\202\000\000\000\183\000\255\000\202\000\000\000\181\000\237\000\202\000\000\000\175\000\202\000\179\000\000\000)\000\202\000\177\000\255\000\218\000\000\000\168\001_\000\026\000$\000\144\000\192\000)\000\255\000\202\000A\000C\000*\000I\001\031\000c\001)\000*\001\031\000*\000\000\000*\000C\000I\001\029\001\029\000c\001)\001\029\001\029\000/\000c\001)\001\029\000\202\001\029\000\202")
+    
+    and rhs =
+      ((16, "\001]\001Y\000\193\000\191\000\189\000\187\000\185\000\183\000\181\000\179\000\177\000A\000/\000F\000D\001o\001\185\001\002\000:\001_\001\006\001/\001G\001)\001\011\001\145\000h\001\133\000.\000h\000Z\001\127\001/\000\243\000.\000:\001_\000\016\0009\001\179\0009\000h\000s\000.\0009\000t\001\019\000\176\000t\000\176\000\168\001\149\001\179\000\168\001\149\000h\000s\000.\000\168\001\149\000\134\000E\0002\000\134\000\250\000{\0002\000\134\000m\000\250\000{\0002\000|\000\215\000{\0002\000|\0002\000z\000\215\000{\0002\000z\000\215\000{\000\176\000\133\0002\001}\000Q\000Q\000\218\001\177\000\132\001\177\000\163\0002\001\155\000\182\001/\001\167\001A\000\162\001\173\000p\000N\001/\000\255\000\162\001\173\000p\000N\000\252\001/\000\255\000\162\001\173\001\173\001\175\001\155\000\135\001}\000\148\001/\001\173\000\211\001)\000\148\000\252\001/\001\173\000\211\001)\000\014\000'\001)\000b\001\017\001)\000\226\001/\001\139\001)\000\146\001/\000c\001)\001W\001)\001w\000\198\001\173\000\238\001\153\000\198\001\173\001I\001\169\001I\000\\\001\173\001I\001\167\001\007\000h\000\175\000.\000h\000\175\000\238\001\133\000.\000h\001\133\000.\000\148\001/\001\157\001)\000\014\001/\000\233\000j\000\238\001\133\001)\000b\001/\000\151\000j\000\238\000\161\001)\000\226\001/\001\139\001)\001W\001)\001w\001\149\000\134\000y\0002\001\149\001}\000R\001/\001\161\001#\000\204\001\157\001\175\000p\000N\001/\000\255\000\162\001\157\000p\000N\000\252\001/\000\255\000\162\001\157\000h\001\173\000.\001\165\000\134\000y\0002\001\165\000h\001\173\000\238\001\153\000.\000R\001/\001\163\001!\000\204\001\157\000\197\000?\000\\\001\153\000j\000\238\000?\000\\\001\153\000?\000\\\001\153\000\240\000\020\001\127\001/\000#\001u\000j\000\198\001\157\001)\0015\001\015\000\144\000\242\000$\000\188\000\134\0002\000h\000.\000\192\000\026\000\018\000h\000\236\000.\001\145\000\255\000\255\000\218\000h\000\236\000.\000h\000\236\000.\001\145\001\133\000\198\001\133\001\179\000u\000&\001\179\000\138\001Q\0004\000\250\000\145\001\185\001\133\001\175\000\028\000\208\001\023\000\162\000c\000d\001\127\001/\000c\000\004\000\129\000\022\001\127\001/\000c\000\022\001\127\001/\000c\000\004\000\129\000\022\001\127\001/\000c\000\190\000c\000\022\001\127\001/\000c\000\004\000\129\000\190\000c\000\006\001\127\001/\000c\000\224\000c\000\220\000\184\001\127\001/\000\175\000\198\000c\001\131\000c\000\224\000c\000\220\000\184\001\127\001/\000\175\000\162\000c\000\224\000c\000\220\000W\000p\000Z\001\127\001/\000\247\000\253\000\162\000c\000p\000\196\001\127\001/\001\143\001i\001/\000\162\000c\000p\000N\001\127\001/\000\249\000\162\000c\000p\000N\000\252\001\127\001/\000\249\000\162\000c\000\180\001\127\001/\000\129\000\182\001\127\001/\001I\001q\000\182\001\127\001/\000h\000\020\000\229\000.\001q\000f\001\127\001/\000c\000\004\000\129\000\024\001\127\001/\000c\000\004\000\129\000\164\001\127\001/\000c\000 \001\129\000\206\001\129\000\164\001\127\001/\000c\000 \001\129\000\b\001\127\001/\000c\000\224\000c\000\220\000\186\001\127\001/\000\175\000\198\000c\001\131\000c\000\224\000c\000\220\001\000\001\127\001/\000W\000\140\001\127\001/\000W\000R\001\127\001/\001\163\001!\000\204\000W\000\135\000q\001\141\000W\000\231\000W\001\129\000\158\001\129\001\129\000\156\001\129\001\129\000\154\001\129\001\129\000\152\001\129\001\129\000\150\001\129\001\129\000F\001\129\001\129\000D\001\129\001\129\000B\001\129\001\129\000`\001\129\001\129\000^\001\129\001\129\000&\001\129\001\129\000H\001\129\001\129\000\198\001\129\001\129\000t\001\129\001\129\000\176\001\129\001\129\000J\001\129\001\129\000\248\001\129\001\129\001\b\001\129\001\129\001\n\001\129\001\129\000\234\001\129\000G\001\129\001\187\001\129\001C\000\162\000c\000n\001;\000\162\000c\001\129\000\236\001\129\000j\000r\001\129\000W\000\218\001M\000r\001\129\000W\000\218\000h\000c\000.\000r\001\129\000W\000\218\000\138\000c\0004\000r\001\129\000W\000\218\000\134\000c\0002\000r\001\129\000W\000\212\000h\000k\000.\000r\001\129\000W\000\218\000\255\000\212\000h\000k\000.\000r\001\129\000W\000\212\000\138\000k\0004\000r\001\129\000W\000\218\000\255\000\212\000\138\000k\0004\000r\001\129\000W\000\212\000\134\000k\0002\000r\001\129\000W\000\218\000\255\000\212\000\134\000k\0002\000r\001\129\001\129\001\175\000H\001\177\000x\001\177\000\163\0002\0008\000\250\001\143\000\198\001\141\001/\001\143\000\198\001\141\001/\000\128\001\177\000\163\0002\000\134\000w\0002\000M\000=\000\198\000c\000\\\000c\000\238\001\179\000\\\000c\001I\001q\000h\000\020\000\229\000.\001q\000?\000\197\000?\000\\\001o\000j\000\238\000?\000\\\001o\000?\000\\\001o\000h\000.\000h\000\247\000\238\000\243\000.\000\137\000P\001\137\000\238\001\137\000\\\001\179\000\238\001\179\000\250\001\143\001i\001/\001\143\001i\001/\000\020\001\127\001/\0005\000j\000\234\000\225\000\139\001)\000\020\001\127\001/\000T\0005\000j\000\234\000\225\000\139\001)\000\020\001\127\001/\0005\000j\000;\000\139\001)\000\020\001\127\001/\000T\0005\000j\000;\000\139\001)\000\018\000j\000K\000\202\000,\000\216\000_\000\202\000v\001\177\000\163\0002\0006\000\235\000j\000\238\000\159\001/\000\235\000j\000\238\000\159\001/\000,\001/\001U\001S\001S\001Q\000j\000j\000\238\001\133\001\007\000W\000\142\000W\000\030\000j\000<\000j\000L\000W\000<\000h\001O\000\201\000.\000<\000j\000L\000h\001?\000\201\000.\000L\000\165\000\030\000h\001O\000.\000\030\000j\000\142\000U\000U\001E\000+\000+\000M\000+\000=\000\198\000c\000+\000\238\000\131\000\218\001\133\000\198\000c\000+\000\238\000\020\000\229\000\218\001\133\000\198\000c\000\167\000\198\000c\000S\000\238\001\133\000\198\000c\000p\001\127\001/\000\149\001G\001)\001C\001\183\000p\001/\000\149\001G\001)\000p\000H\001\177\001/\000\149\001G\001)\001A\001\183\000\175\000\175\000\238\001\133\000+\000M\000+\000U\000\238\001\133\000\198\000c\000\167\000\198\000c\001=\001;\001\004\001=\001\006\001/\000#\001u\000j\001\169\001)\0019\001\006\001/\000#\001u\000j\000\238\001\153\001)\0017\001\006\001/\000#\001u\000j\000\198\001\157\001)\0015\001\006\001/\000\247\000\253\001)\0013\001\006\001/\000\247\000\238\000\243\001)\0011\001\175\001/\001\006\001/\0005\000j\000;\000\139\001)\001-\001\006\001/\0005\000j\000\234\000\225\000\139\001)\001+\000\157\001)\000*\001'\000]\001'\000*\001%\000*\000c\001)\001%\000I\001%\001\159\001#\001\171\001!\000I\001\031\000*\001\029\000*\000c\001)\001\029\000I\001\029\000C\001\029\001M\000\209\000\203\001M\000\209\000\203\000,\001M\000\209\000\203\000,\000\016\000\213\001M\000\209\000\203\000,\001\027\000l\001\127\001/\000\149\001G\001)\001\025\001\023\001\183\000\175\000\\\000c\000\175\000\n\000c\000\\\000c\000\175\000\\\000\218\000j\000\238\000\159\001/\000,\001/\001\019\001\179\000,\001\019\000j\000\238\000\159\001/\000,\001/\001\179\000,\000j\000\238\000\159\001/\001\179\000\216\001/\000\031\000j\000\238\000\161\001/\000\153\000j\000M\000\252\001/\000\153\000j\000M\001/\000\153\000j\000\238\000\161\000\198\000c\000\252\001/\000\153\000j\000\238\000\161\000\198\000c\001/\000\153\000j\000\238\000\020\000\229\000\218\001\133\000\198\000c\000\252\001/\000\153\000j\000\238\000\020\000\229\000\218\001\133\000\198\000c\000j\001\001\000\218\000j\000\018\001\001\000\218\000\018\001_\000h\000\236\000.\000-\001\001\000\218\001_\001\001\000\218\000h\000\236\000.\001\001\000\218\000-\001_\001\001\000\218\001_\000j\000\255\000\218\000j\000\018\000\255\000\218\000\018\000+\000\255\000\218\000+\001\r\001\001\000h\001\001\000.\001\005\000\198\000\249\000\238\000\243\000\198\000\249\001m\000\253\000\238\000\243\001m\000\251\000\"\001/\000K\000\204\000\178\001/\001k\000\\\000\249\000\195\000\249\001\175\000\255\000\249\000\195\000\249\000h\000.\001}\000\016\000\018\000\016\000Z\001\127\001/\000\018\000\234\001\001\001)\000(\001/\000_\000\204\000\178\001/\001k\000\\\000\243\000Z\000\020\000P\001/\000\249\000h\000\243\000.\000\243\001\175\000\237\000\243\000\\\000\243\000\243\000\004\000}\001}\000Z\000\020\001\127\001/\001_\000\205\001)\000Z\000\020\001\127\001/\001_\000\234\000\243\001)\001\t\000X\000X\000\012\000X\000\012\000\012\000X\000\254\001_\000j\000j\000\229\000$\000$\000\227\001\133\000>\001\133\001\135\000>\001\135\001\133\000\198\001\135\001\133\000\198\000>\001\135\000\216\000>\000\216\001\133\000\198\000\216\001\133\000\198\000>\000\216\000\138\001Q\0004\000>\000\138\001Q\0004\001\133\000\198\000\138\001Q\0004\001\133\000\198\000>\000\138\001Q\0004\000N\001\127\001/\000\249\001)\000N\000\252\001\127\001/\000\249\001)\000N\001\127\001/\001\001\001)\000N\000\252\001\127\001/\001\001\001)\000@\000n\001\004\000\212\000h\001[\000.\000\212\000h\001[\000.\000r\000\212\000\134\001[\0002\000\212\000\134\001[\0002\000r\000\212\000\138\001[\0004\000\212\000\138\001[\0004\000r\000\166\000\252\000\158\000\156\000\154\000\152\000\150\000F\000D\000B\000`\000^\000&\000H\000\198\000t\000\176\000J\000\248\001\b\001\n\000\234\001\b\000\250\000,\001\002\000j\000\238\001\133\000\198\001\129\000\198\000\243\000\198\000\175\000\198\000c\000=\000L\000<\000j\000\238\000h\000\249\000\238\000\243\000.\000h\000\249\000.\000h\000\014\001/\001\129\000.\000h\000\014\001/\001\129\000\238\000\243\000.\000h\000\014\001/\001\129\000\238\000\243\000\232\000\243\000.\000h\000\014\001/\001\129\000\232\000\243\000.\001\181\000\202\001\141\000\202\001\133\000\202\000c\000\202\001\001\000\202\000\255\000\202\000\237\000\202\000\175\000\202\000)\000\202\000\175\000\236\000\175\000\175\001\175\000\169\000\175\001\002\000+\000\173\000\175\000\250\000\175\000\196\001\127\001/\000\175\000\173\000\230\000\175\000\175\000\230\000\175\000\171\000\230\000\175\000\167\000\230\000\175\000U\001\141\000\175\001\141\000h\000\020\000\229\000.\000U\000\231\000\175\000\140\001\127\001/\000U\000\167\000\236\000\175\000\167\001\175\000\169\000\167\001\002\000+\000\171\000\167\000\250\000\175\000j\000\016\000K\000\238\000_\000\238\001\133\000<\000\175\000<\000\175\000\n\000c\001\133\000\131\000\218\001\133\001\185\000\131\000\218\001\185\000\130\001\177\000\163\0002\000\194\001\127\001/\000+\000\238\001\133\000\198\000\227\001)\000>\000>\000\012\000>\000\012\000\012\000>\0000\000e\000W\000\004\000e\001e\001g\000\145\001g\001e\001y\001g\001{\000\143\001g\000\143\001{\001e\001g\000\141\001g\000\139\000\226\001\133\000\198\001\133\001m\000\137\001m\001K\000\135\001K\000\231\000\133\000\231\000:\001_\000\131\000:\001_\001\021\000\250\001\021\000\129\000\250\001\021\001\185\000\127\001\b\001\185\000\029\000}\001\006\000\029\000m\000{\000\250\000m\001\133\000y\000\230\001\133\0007\000w\000\230\0007\001\179\000u\000&\001\179\000s\000\230\001\133\001\133\000\230\001\133\000q\000\230\001\129\001\129\000\230\001\129\000o\000&\001\179\001\179\000&\001\179\000E\001\133\001\129\001\129\000,\001\129\000,\000k\000j\000\207\000j\000\207\000,\000j\000\207\000,\000i\000\175\000\175\000,\000\175\000,\000g\001M\000\199\000\207\001M\000\199\000\207\000,\001M\000\199\000\207\000,\000e\001\129\001\129\000,\001\129\000,\000c\001\129\000,\000H\001\177\000c\000\196\001\127\001/\001\143\001i\001/\001)\001'\001W\001)\001w\000%\000\155\001a\001-\001c\001+\000\020\001\127\001/\0005\0009\000B\000\153\000\141\001)\000\020\001\127\001/\000T\0005\0009\000B\000\153\000\141\001)\000a\000Z\001\127\001/\000\247\000\251\001)\000Z\001\127\001/\000\247\000\198\000\255\001)\000\245\000Z\001\127\001/\0000\000\247\000\238\000\243\001)\0011\000\241\000\239\000\221\000\160\001\127\001/\000\243\001)\000\240\001\127\001/\000#\001u\000j\000\238\001\153\001)\0017\001\151\001\147\000`\000\144\000`\000\188\000F\000\144\000F\000\188\000\138\001\027\0004\000\134\000g\0002\000~\000g\000\246\000~\000\246\000\214\001\129\000\174\000\210\000W\000h\000c\000.\000h\000c\000=\000.\000W\000\218\000h\000c\000.\000W\000\218\000\138\000c\0004\000W\000\218\000\134\000c\0002\000W\000\212\000h\000k\000.\000W\000\218\000\255\000\212\000h\000k\000.\000W\000\212\000\138\000k\0004\000W\000\218\000\255\000\212\000\138\000k\0004\000W\000\212\000\134\000k\0002\000W\000\218\000\255\000\212\000\134\000k\0002\000\244\001\127\001/\000c\000\204\000\244\001\127\001/\000\204\000V\001\127\001/\001\165\000h\000Z\001\127\001/\000\249\000.\000h\000Z\001\127\001/\000\249\000\238\000\243\000.\000)\001\147\001\141\000\231\000@\000W\000\252\000W\000\136\000i\000\172\000\136\000\172\000W\000\218\001M\000\255\000\218\000h\000c\000.\000\255\000\218\000\136\000i\000\172\000W\000\168\000j\000W\000\166\000W\001}\000\016\000\255\000\218\000h\000.\000\138\000\147\0004\000\255\000\218\000\138\000\147\0004\000~\000k\000\246\000~\000\246\000\255\000\218\000~\000k\000\246\000\255\000\218\000~\000\246\000\134\000k\0002\000\255\000\218\000\134\000k\0002\000\255\000\218\000\134\0002\000\255\000\218\000h\000Z\001\127\001/\000\249\000\238\000\243\000.\000+\000S\000h\000\175\000.\000Y\000h\000Z\001\127\001/\000\247\000.\000h\000Z\001\127\001/\000\247\000\238\000\243\000.\000\016\000[\000[\000\216\000[\001\141\000\231\000\168\0009\000\255\000\218\000Y\000\255\000\218\000\134\0002\000\255\000\218\000h\000.\000\255\000\218\000h\000\175\000.\000h\000\175\000\238\001\133\000.\001}\000j\000\018\001\006\001\002\001\000\000\244\000\240\000\226\000\224\000\220\000\208\000\206\000\204\000\196\000\194\000\192\000\186\000\182\000\180\000\178\000\164\000\162\000\160\000\148\000\146\000\140\000p\000f\000b\000Z\000X\000V\000T\000R\000P\000N\000J\000>\0000\000(\000\"\000 \000\028\000\026\000\024\000\020\000\014\000\012\000\n\000\b\000\004\000a\000\196\001\127\001/\001\143\000\198\001\141\001/\001)\000\198\000c\001I\001s\000h\000\020\000\229\000.\001s\001%\000c\001)\001%\001\023\001C\001W\001)\001w\000\155\000%\001a\001-\000\020\001\127\001/\0005\0009\000B\000\153\000\143\001)\000\020\001\127\001/\000T\0005\0009\000B\000\153\000\143\001)\000O\000Z\001\127\001/\000\247\000\253\001)\000Z\001\127\001/\0000\000\247\000\253\001)\0013\000\241\000\223\000\240\001\127\001/\000#\001u\000j\001\169\001)\0019\001\151\000\160\001\127\001/\000\249\001)\000`\000^\000\231\000P\000\217\000\127\001/\000\231\001/\000\168\001_\000\168\001_\000$\000\168\001_\000\144\000\168\001_\000)\000\168\001_\000\255\000\168\001_\000\192\000\168\001_\000\026\000c\001)\000*\001\031\000*\000C\000*\000\202\001\179\000o\000\238\001\133\000\238\001\133\000\232\001\133\000\232\001\133\000\198\000\225\001\015\0001\0003\0007\000h\000w\000.\000:\001_\000\016\000F\000`\000\252\000F\000\252\000\252\000F\000`\000\252\000\252\000`\000\154\000@\001\029\000\202\000c\001)\001\029\000\202\000h\000\219\000.\000j\000-\001\003\001/\000!\000j\000\238\001\133\001/\000\235\000j\000\198\000c\000\252\001/\000\235\000j\000\198\000c\001/\000\235\000j\000=\000\198\000c\000\252\001/\000\235\000j\000=\000\198\000c\000\014\001\127\001/\000+\000\238\001\133\001)\000\012\000\012\000X\000\012\000\012\000X\000\012\000>\000\012\000\012\000>\000\020\0005\001M\000\027\001\185\000\139\000\020\0005\001M\000\234\001\185\000Z\000\255\000\198\001\001\000Z\000\255\000\234\001\001\000Z\000\020\000\237\000\198\000\243\000Z\000\020\000\237\000\234\000\243\000\198\000\198\000>"), (16, "\000\000\000\001\000\002\000\003\000\004\000\005\000\006\000\007\000\b\000\t\000\n\000\011\000\012\000\r\000\014\000\015\000\016\000\020\000\024\000\025\000\026\000\029\000#\000%\000&\000'\000)\000-\0000\0002\0004\0007\000<\000?\000C\000H\000L\000N\000R\000X\000Y\000Z\000]\000a\000b\000e\000h\000n\000u\000w\000y\000z\000\127\000\133\000\136\000\139\000\143\000\147\000\149\000\150\000\152\000\156\000\158\000\161\000\163\000\164\000\167\000\172\000\172\000\175\000\175\000\179\000\186\000\193\000\197\000\199\000\200\000\201\000\205\000\206\000\211\000\213\000\219\000\226\000\229\000\230\000\234\000\239\000\244\000\245\000\249\000\254\001\001\001\012\001\r\001\014\001\015\001\016\001\017\001\019\001\021\001\022\001\023\001\024\001\027\001\028\001\029\001\"\001%\001&\001)\001*\001-\0010\0011\0012\0013\0015\0016\0017\001:\001@\001D\001J\001P\001X\001_\001j\001s\001t\001|\001\133\001\140\001\148\001\152\001\157\001\165\001\171\001\177\001\185\001\191\001\198\001\209\001\213\001\217\001\223\001\225\001\226\001\228\001\230\001\233\001\236\001\239\001\242\001\245\001\248\001\251\001\254\002\001\002\004\002\007\002\n\002\r\002\016\002\019\002\022\002\025\002\028\002\031\002\"\002$\002&\002)\002-\0020\0023\0028\002?\002F\002M\002T\002]\002d\002m\002t\002}\002\127\002\127\002\129\002\133\002\134\002\139\002\143\002\147\002\147\002\150\002\151\002\154\002\156\002\160\002\162\002\167\002\168\002\172\002\177\002\180\002\182\002\187\002\188\002\188\002\190\002\194\002\196\002\200\002\203\002\212\002\222\002\230\002\239\002\240\002\241\002\243\002\243\002\245\002\247\002\251\002\252\003\001\003\b\003\t\003\n\003\012\003\r\003\016\003\017\003\018\003\020\003\022\003\024\003\026\003\031\003!\003&\003(\003,\003.\0030\0031\0032\0033\0035\0039\003@\003H\003K\003P\003V\003X\003]\003d\003f\003g\003j\003l\003m\003r\003u\003v\003y\003y\003\129\003\129\003\138\003\138\003\147\003\147\003\153\003\153\003\160\003\160\003\162\003\162\003\170\003\170\003\179\003\179\003\181\003\181\003\183\003\185\003\185\003\187\003\191\003\193\003\193\003\195\003\195\003\197\003\197\003\199\003\199\003\201\003\205\003\207\003\209\003\212\003\216\003\222\003\227\003\233\003\234\003\236\003\239\003\244\003\247\003\254\004\001\004\007\004\t\004\r\004\014\004\015\004\020\004\024\004\029\004$\004,\0046\004A\004B\004E\004F\004I\004J\004M\004N\004Q\004V\004Y\004Z\004]\004^\004a\004b\004e\004f\004i\004j\004n\004o\004q\004u\004w\004y\004{\004\127\004\132\004\133\004\135\004\136\004\138\004\141\004\142\004\143\004\144\004\145\004\152\004\156\004\161\004\166\004\169\004\171\004\172\004\175\004\178\004\179\004\186\004\194\004\195\004\195\004\196\004\196\004\197\004\198\004\200\004\202\004\204\004\205\004\207\004\208\004\210\004\211\004\213\004\214\004\216\004\219\004\223\004\224\004\226\004\229\004\233\004\236\004\240\004\245\004\251\005\000\005\006\005\011\005\017\005\018\005\019\005\020\005\024\005\029\005!\005&\005*\005/\0050\0051\0052\0053\0054\0055\0056\0057\0058\0059\005:\005;\005<\005=\005>\005?\005@\005A\005B\005C\005D\005E\005F\005F\005F\005G\005G\005H\005H\005J\005J\005L\005L\005N\005N\005P\005P\005R\005R\005T\005T\005U\005V\005Y\005^\005a\005f\005m\005v\005}\005\127\005\129\005\131\005\133\005\135\005\137\005\139\005\141\005\143\005\146\005\148\005\149\005\152\005\153\005\156\005\160\005\163\005\166\005\169\005\172\005\173\005\175\005\181\005\183\005\187\005\190\005\192\005\193\005\196\005\197\005\200\005\201\005\202\005\203\005\205\005\207\005\209\005\213\005\214\005\217\005\218\005\221\005\225\005\234\005\234\005\235\005\235\005\236\005\237\005\239\005\241\005\241\005\242\005\243\005\246\005\247\005\248\005\250\005\251\005\252\005\253\005\254\006\000\006\002\006\003\006\004\006\006\006\006\006\011\006\012\006\014\006\015\006\017\006\018\006\020\006\022\006\025\006\026\006\028\006\031\006 \006#\006$\006'\006(\006+\006,\006/\0060\0063\0064\0067\006:\006=\006@\006C\006F\006I\006J\006K\006L\006N\006Q\006S\006V\006Z\006[\006]\006`\006c\006g\006l\006m\006o\006r\006w\006~\006\127\006\129\006\130\006\131\006\132\006\134\006\136\006\145\006\155\006\156\006\162\006\169\006\170\006\179\006\180\006\181\006\182\006\187\006\197\006\198\006\199\006\201\006\203\006\205\006\207\006\210\006\213\006\216\006\218\006\221\006\223\006\226\006\230\006\235\006\240\006\245\006\250\007\001\007\006\007\r\007\018\007\025\007\030\007\"\007&\007,\0074\0075\0076\0077\0078\007:\007<\007?\007A\007D\007I\007N\007Q\007T\007U\007V\007Z\007]\007b\007e\007g\007l\007p\007s\007x\007|\007\134\007\135\007\136\007\139\007\140\007\146\007\154\007\155\007\156\007\159\007\160\007\161\007\163\007\166\007\170\007\174\007\179\007\184\007\185\007\186\007\187\007\188\007\189\007\190\007\191\007\192\007\193\007\194\007\195\007\196\007\197\007\198\007\199\007\200\007\201\007\202\007\203\007\204\007\205\007\206\007\207\007\208\007\209\007\210\007\211\007\212\007\213\007\214\007\215\007\216\007\217\007\218\007\219\007\220\007\221\007\222\007\223\007\224\007\225\007\226\007\227\007\228\007\229\007\230\007\231\007\232\007\233\007\234\007\235\007\236\007\237\007\245\007\247\007\249\007\254\007\255\b\002\b\003\b\004\b\006\b\007\b\b\b\t\b\011\b\020\b\030\b\031\b%\b-\b.\b/\b8\b9\b>\b?\b@\bE\bG\bI\bL\bO\bR\bU\bX\b[\b^\b`\bb\bc\bd\be\bg\bk\bm\bm\bo\bp\br\br\bs\bv\bx\by\by\bz\b{\b|\b~\b\128\b\130\b\132\b\133\b\134\b\136\b\140\b\143\b\144\b\145\b\146\b\151\b\156\b\162\b\168\b\175\b\182\b\182\b\183\b\184\b\186\b\188\b\189\b\191\b\193\b\199\b\204\b\208\b\212\b\217\b\222\b\223\b\225"))
+    
+    and lr0_core =
+      (16, "\000\000\000\001\000\002\000\003\000\004\000\005\000\006\000\007\000\b\000\t\000\n\000\011\000\012\000\r\000\014\000\015\000\016\000\017\000\018\000\019\000\020\000\021\000\022\000\023\000\024\000\025\000\026\000\027\000\028\000\029\000\030\000\031\000 \000!\000\"\000#\000$\000%\000&\000'\000(\000)\000*\000+\000,\000-\000.\000/\0000\0001\0002\0003\0004\0005\0006\0007\0008\0009\000:\000;\000<\000=\000>\000?\000@\000A\000B\000C\000D\000E\000F\000G\000H\000I\000J\000K\000L\000M\000N\000O\000P\000Q\000R\000S\000T\000U\000V\000W\000X\000Y\000Z\000[\000\\\000]\000^\000_\000`\000a\000b\000c\000d\000e\000f\000g\000h\000i\000j\000k\000l\000m\000n\000o\000p\000q\000r\000s\000t\000u\000v\000w\000x\000y\000z\000{\000|\000}\000~\000\127\000\128\000\129\000\130\000\131\000\132\000\133\000\134\000\135\000\136\000\137\000\138\000\139\000\140\000\141\000\142\000\143\000\144\000\145\000\146\000\147\000\148\000\149\000\150\000\151\000\152\000\153\000\154\000\155\000\156\000\157\000\158\000\159\000\160\000\161\000\162\000\163\000\164\000\165\000\166\000\167\000\168\000\169\000\170\000\171\000\172\000\173\000\174\000\175\000\176\000\177\000\178\000\179\000\180\000\181\000\182\000\183\000\184\000\185\000\186\000\187\000\188\000\189\000\190\000\191\000\192\000\193\000\194\000\195\000\196\000\197\000\198\000\199\000\200\000\201\000\202\000\203\000\204\000\205\000\206\000\207\000\208\000\209\000\210\000\211\000\212\000\213\000\214\000\215\000\216\000\217\000\218\000\219\000\220\000\221\000\222\000\223\000\224\000\225\000\226\000\227\000\228\000\229\000\230\000\231\000\232\000\233\000\234\000\235\000\236\000\237\000\238\000\239\000\240\000\241\000\242\000\243\000\244\000\245\000\246\000\247\000\248\000\249\000\250\000\251\000\252\000\253\000\254\000\255\001\000\001\001\001\002\001\003\001\004\001\005\001\006\001\007\001\b\001\t\001\n\001\011\001\012\001\r\001\014\001\015\001\016\001\017\001\018\001\019\001\020\001\021\001\022\001\023\001\024\001\025\001\026\001\027\001\028\001\029\001\030\001\031\001 \001!\001\"\001#\001$\001%\001&\001'\001(\001)\001*\001+\001,\001-\001.\001/\0010\0011\0012\0013\0014\0015\0016\0017\0018\0019\001:\001;\001<\001=\001>\001?\001@\001A\001B\001C\001D\001E\001F\001G\001H\001I\001J\001K\001L\001M\001N\001O\001P\001Q\001R\001S\001T\001U\001V\001W\001X\001Y\001Z\001[\001\\\001]\001^\001_\001`\001a\001b\001c\001d\001e\001f\001g\001h\001i\001j\001k\001l\001m\001n\001o\001p\001q\001r\001s\001t\001u\001v\001w\001x\001y\001z\001{\001|\001}\001~\001\127\001\128\001\129\001\130\001\131\001\132\001\133\001\134\001\135\001\136\001\137\001\138\001\139\001\140\001\141\001\142\001\143\001\144\001\145\001\146\001\147\001\148\001\149\001\150\001\151\001\152\001\153\001\154\001\155\001\156\001\157\001\158\001\159\001\160\001\161\001\162\001\163\001\164\001\165\001\166\001\167\001\168\001\169\001\170\001\171\001\172\001\173\001\174\001\175\001\176\001\177\001\178\001\179\001\180\001\181\001\182\001\183\001\184\001\185\001\186\001\187\001\188\001\189\001\190\001\191\001\192\001\193\001\194\001\195\001\196\001\197\001\198\001\199\001\200\001\201\001\202\001\203\001\204\001\205\001\206\001\207\001\208\001\209\001\210\001\211\001\212\001\213\001\214\001\215\001\216\001\217\001\218\001\219\001\220\001\221\001\222\001\223\001\224\001\225\001\226\001\227\001\228\001\229\001\230\001\231\001\232\001\233\001\234\001\235\001\236\001\237\001\238\001\239\001\240\001\241\001\242\001\243\001\244\001\245\001\246\001\247\001\248\001\249\001\250\001\251\001\252\001\253\001\254\001\255\002\000\002\001\002\002\002\003\002\004\002\005\002\006\002\007\002\b\002\t\002\n\002\011\002\012\002\r\002\014\002\015\002\016\002\017\002\018\002\019\002\020\002\021\002\022\002\023\002\026\002\027\002 \002!\002\"\002#\002$\002%\002&\002'\002(\002)\002*\002+\002,\002-\002.\002/\002\024\002\025\0020\0021\0022\002\028\002\029\002\030\002\031\0023\0024\0025\0026\0027\0028\0029\002:\002;\002<\002=\002>\002?\002@\002A\002B\002C\002D\002E\002F\002G\002H\002I\002J\002K\002L\002M\002N\002O\002P\002Q\002R\002S\002T\002U\002V\002W\002X\002Y\002Z\002[\002\\\002]\002^\002_\002`\002a\002b\002c\002d\002e\002f\002g\002h\002i\002j\002k\002l\002m\002n\002o\002p\002q\002r\002s\002t\002u\002v\002w\002x\002y\002z\002{\002|\002}\002~\002\127\002\128\002\129\002\130\002\131\002\132\002\133\002\134\002\135\002\136\002\137\002\138\002\139\002\140\002\141\002\144\002\145\002\146\002\147\002\148\002\149\002\150\002\151\002\152\002\153\002\142\002\143\002\154\002\155\002\156\002\157\002\158\002\159\002\160\002\161\002\162\002\163\002\164\002\165\002\166\002\167\002\168\002\169\002\170\002\171\002\172\002\173\002\174\002\175\002\176\002\177\002\178\002\179\002\180\002\181\002\182\002\183\002\184\002\185\002\186\002\187\002\188\002\189\002\190\002\191\002\192\002\193\002\194\002\195\002\196\002\197\002\198\002\199\002\200\002\201\002\202\002\203\002\204\002\205\002\206\002\207\002\208\002\209\002\210\002\211\002\212\002\213\002\214\002\215\002\216\002\217\002\218\002\219\002\220\002\221\002\222\002\223\002\224\002\225\002\226\002\227\002\228\002\229\002\230\002\231\002\252\002\253\002\254\002\255\003\000\003\001\003\002\003\003\003\004\003\005\003\006\003\007\003\b\003\t\003\n\003\011\003\012\003\r\003\014\003\015\003\016\002\238\002\239\002\240\002\241\002\232\002\233\002\236\002\237\002\244\002\245\002\246\002\247\002\248\002\249\002\250\002\251\002\234\002\235\002\242\002\243\003\225\003\226\003\018\003\019\003\020\003\021\003\022\003\023\003\024\003\025\003\026\003\027\003\028\003\029\003\030\003\031\003 \003!\003\"\003#\0034\0035\003N\003O\003P\003Q\003R\003S\003T\003U\003V\003W\003$\003%\003*\003+\0036\0037\003&\003'\003(\003)\003,\003-\003.\003/\0030\0031\0032\0033\0038\0039\003:\003;\003F\003G\003<\003=\003>\003?\003@\003A\003H\003I\003J\003K\003L\003M\003B\003C\003D\003E\003X\003Y\003Z\003[\003\\\003]\003^\003_\003`\003a\003b\003c\003d\003e\003f\003g\003h\003i\003j\003k\003l\003m\003n\003o\003p\003q\003r\003s\003t\003\227\003\228\003\229\003\230\003\231\003\232\003\233\003\234\003\235\003\236\003\237\003\133\003\134\003\135\003\238\003\239\003\240\003\241\003\242\003\243\003\244\003\166\003\167\003\168\003\169\003\170\003\171\003\172\003\173\003\174\003\175\003\176\003\177\003\178\003\179\003\180\003\181\003\182\003\183\003\184\003\185\003\186\003\187\003\188\003\189\003\190\003\191\003\192\003\193\003\194\003\195\003\196\003\197\003\198\003\199\003\200\003\201\003\202\003\203\003\204\003\205\003\206\003\207\003\208\003\209\003\210\003\211\003\212\003\213\003\214\003\215\003\216\003\217\003\218\003\219\003\220\003\221\003\222\003\223\003\224\003\245\003\246\003\247\003\248\003\249\003\250\003\251\003\252\003\017\003u\003v\003w\003x\003y\003z\003{\003|\003}\003~\003\127\003\128\003\129\003\130\003\131\003\132\003\136\003\137\003\138\003\139\003\140\003\141\003\142\003\143\003\144\003\145\003\146\003\147\003\148\003\149\003\150\003\151\003\152\003\153\003\154\003\155\003\156\003\157\003\158\003\159\003\160\003\161\003\162\003\163\003\164\003\165\003\253\003\254\003\255\004\000\004\001\004\002\004\003\004\004\004\005\004\006\004\007\004\b\004\t\004\n\004\011\004\012\004\r\004\014\004\015\004\016\004\017\004\018\004\019\004\020\004\021\004\022\004\023\004\024\004\025\004\026\004\027\004\028\004\029\004\030\004\031\004 \004!\004\"\004#\004$\004%\004&\004'\004(\004)\004*\004+\004,\004-\004.\004/\0040\0041\0042\0043\0044\0045\0046\0047\0048\0049\004:\004;\004<\004=\004>\004?\004@\004A\004B\004C\004D\004E\004F\004G\004H\004I\004J\004K\004L\004M\004N\004O\004P\004Q\004R\004S\004T\004U\004V\004W\004X\004Y\004Z\004[\004\\\004]\004^\004_\004`\004a\004b\004c\004d\004e\004f\004g\004h\004i\004j\004k\004l\004m\004n\004o\004p\004q\004r\004s\004t\004u\004v\004w\004x\004y\004z\004{\004|\004}\004~\004\127\004\128\004\129\004\130\004\131\004\132\004\133\004\134\004\135\004\136\004\137\004\138\004\139\004\140\004\141\004\142\004\143\004\144\004\145\004\146\004\147\004\148\004\149\004\150\004\151\004\152\004\153\004\154\004\155\004\156\004\157\004\158\004\159\004\160\004\161\004\162\004\163\004\164\004\165\004\166\004\167\004\168\004\169\004\170\004\171\004\172\004\173\004\174\004\175\004\176\004\177\004\178\004\179\004\180\004\181\004\182\004\183\004\184\004\185\004\186\004\187\004\188\004\189\004\190\004\191\004\192\004\193\004\194\004\195\004\196\004\197\004\198\004\199\004\200\004\201\004\202\004\203\004\204\004\205\004\206\004\207\004\208\004\209\004\210\004\211\004\212\004\213\004\214\004\215\004\216\004\217\004\218\004\219\004\220\004\221\004\222\004\223\004\224\004\225\004\226\004\227\004\228\004\229\004\230\004\231\004\232\004\233\004\234\004\235\004\236\004\237\004\238\004\239\004\240\004\241\004\242\004\243\004\244\004\245\004\246\004\247\004\248\004\249\004\250\004\251\004\252\004\253\004\254\004\255\005\000\005\001\005\002\005\003\005\004\005\005\005\006\005\007\005\b\005\t\005\n\005\011\005\012\005\r\005\014\005\015\005\016\005\017\005\018\005\019\005\020\005\021\005\022\005\023\005\024\005\025\005\026\005\027\005\028\005\029\005\030\005\031\005 \005!\005\"\005#\005$\005%\005&\005'\005(\005)\005*\005+\005,\005-\005.\005/\0050\0051\0052\0053\0054\0055\0056\0057\0058\0059\005:\005;\005<\005=\005>\005?\005@\005A\005B\005C\005D\005E\005F\005G\005H\005I\005J\005K\005L\005M\005N\005O\005P\005Q\005R\005S\005T\005U\005V\005W\005X\005Y\005Z\005[\005\\\005]\005^\005_\005`\005a\005b\005c\005d\005e\005f\005g\005h\005i\005j\005k\005l\005m\005n\005o\005p\005q\005r\005s\005t\005u\005v\005w\005x\005y\005z\005{\005|\005}\005~\005\127\005\128\005\129\005\130\005\131\005\132\005\133\005\134\005\135\005\136\005\137\005\138\005\139\005\140\005\141\005\142\005\143\005\144\005\145\005\146\005\147\005\148\005\149\005\150\005\151\005\152\005\153\005\154\005\155\005\156\005\157\005\158\005\159\005\160\005\161\005\162\005\163\005\164\005\165\005\166\005\167\005\168\005\169\005\170\005\171\005\172\005\173\005\174\005\175\005\176\005\177\005\178\005\179\005\180\005\181\005\182\005\183\005\184\005\185\005\186\005\187\005\188\005\189\005\190\005\191\005\192\005\193\005\194\005\195\005\196\005\197\005\198\005\199\005\200\005\201\005\202\005\203\005\204\005\205\005\206\005\207\005\208\005\209\005\210\005\211\005\212\005\213\005\214\005\215\005\216\005\217\005\218\005\219\005\220\005\221\005\222\005\223\005\224\005\225\005\226\005\227\005\228\005\229\005\230\005\231\005\232\005\233\005\234\005\235\005\236\005\237\005\238\005\239\005\240\005\241\005\242\005\243\005\244\005\245\005\246\005\247\005\248\005\249\005\250\005\251\005\252\005\253\005\254\005\255\006\000\006\001\006\002\006\003\006\004\006\005\006\006\006\007\006\b\006\t\006\n\006\011\006\012\006\r\006\014\006\015\006\016\006\017\006\018\006\019\006\020\006\021\006\022\006\023\006\024\006\025\006\026\006\027\006\028\006\029\006\030\006\031\006 \006!\006\"\006#\006$\006%\006&\006'\006(\006)\006*\006+\006,\006-\006.\006/\0060\0061\0062\0063\0064\0065\0066\0067\0068\0069\006:\006;\006<\006=\006>\006?\006@\006A\006B\006C\006D\006E\006F\006G\006H\006I\006J\006K\006L\006M\006N\006O\006P\006Q\006R\006S\006T\006U\006V\006W\006X\006Y\006Z\006[\006\\\006]\006^\006_\006`\006a\006b\006c\006d\006e\006f\006g\006h\006i\006j\006k\006l\006m\006n\006o\006p\006q\006r\006s\006t\006u\006v\006w\006x\006y\006z\006{\006|\006}\006~\006\127\006\128\006\129\006\130\006\131\006\132\006\133\006\134\006\135\006\136\006\137\006\138\006\139\006\140\006\141\006\142\006\143\006\144\006\145\006\146\006\147\006\148\006\149\006\150\006\151\006\152\006\153\006\154\006\155\006\156\006\157\006\158\006\159\006\160\006\161\006\162\006\163\006\164\006\165\006\166\006\167\006\168\006\169\006\170\006\171\006\172\006\173\006\174\006\175\006\176\006\177\006\178\006\179\006\180\006\181\006\182\006\183\006\184\006\185\006\186\006\187\006\188\006\189\006\190\006\191\006\192\006\193\006\194\006\195\006\196\006\197\006\198\006\199\006\200\006\201\006\202\006\203\006\204\006\205\006\206\006\207\006\208\006\209\006\210\006\211\006\212\006\213\006\214\006\215\006\216\006\217\006\218\006\219\006\220\006\221\006\222\006\223\006\224\006\225\006\226\006\227\006\228\006\229\006\230\006\231\006\232\006\233\006\234\006\235\006\236\006\237\006\238\006\239\006\240\006\241\006\242\006\243\006\244\006\245\006\246\006\247\006\248\006\249\006\250\006\251\006\252\006\253\006\254\006\255\007\000\007\001\007\002\007\003\007\004\007\005\007\006\007\007\007\b\007\t\007\n\007\011\007\012\007\r\007\014\007\015\007\016\007\017\007\018\007\019\007\020\007\021\007\022\007\023\007\024\007\025\007\026\007\027\007\028\007\029\007\030\007\031\007 \007!\007\"\007#\007$\007%\007&\007'\007(\007)\007*\007+\007,\007-\007.\007/\0070\0071\0072")
+    
+    and lr0_items =
+      ((32, "\000\000\000\000\000\001\244\001\000\002\236\001\000\011T\001\000\011P\001\000\011L\001\000\011H\001\000\011D\001\000\n\144\001\000\011@\001\000\011<\001\000\0118\001\000\0114\001\000\0110\001\000\011,\001\000\011(\001\000\011$\001\000\011 \001\000\011\028\001\000\011\024\001\000\011\020\001\000\011\016\001\000\011\012\001\000\011\b\001\000\011\004\001\000\011\000\001\000\n\252\001\000\n\248\001\000\n\140\001\000\n\244\001\000\n\240\001\000\n\236\001\000\n\232\001\000\n\228\001\000\n\224\001\000\n\220\001\000\n\216\001\000\n\212\001\000\n\208\001\000\n\204\001\000\n\200\001\000\n\196\001\000\n\192\001\000\n\188\001\000\n\184\001\000\n\180\001\000\n\176\001\000\n\172\001\000\n\168\001\000\n\164\001\000\n\160\001\000\n\156\001\000\n\152\001\000\n\148\001\000\000\164\001\000\000\160\001\000\000\164\002\000\000\164\003\000\002\236\002\000\001\244\002\000\000\168\001\000\000\168\002\000\0020\001\000\0020\002\000\0020\003\000\n\020\001\000\005X\001\000\001\240\001\000\001\236\001\000\001\232\001\000\001\228\001\000\001\240\002\000\001\236\002\000\001\232\002\000\001\228\002\000\001\240\003\000\001\236\003\000\001\232\003\000\001\228\003\000\002$\001\000\002$\002\000\002$\003\000\001\148\001\000\001\128\001\000\002\244\001\000\t\236\001\000\t\208\001\000\t\208\002\000\t\208\003\000\005P\001\000\005\\\001\000\005T\001\000\005\\\002\000\005T\002\000\005\\\003\000\005T\003\000\005p\001\000\001\000\001\000\t\208\004\000\004\\\001\000\004\\\002\000\012\\\001\000\t\216\001\000\t\212\001\000\t\160\001\000\t\156\001\000\001\172\001\000\001\140\001\000\006\180\001\000\001\140\002\000\t\236\001\000\006`\001\000\012`\001\000\002\240\001\000\002\240\002\000\012\128\001\000\012\128\002\000\012\128\003\000\012\\\001\000\006`\001\000\006\168\001\000\006\164\001\000\006\160\001\000\006\184\001\000\006\200\001\000\006\176\001\000\006\172\001\000\006d\001\000\006\192\001\000\006\156\001\000\006\152\001\000\006\148\001\000\006\144\001\000\006\140\001\000\006\132\001\000\006\196\001\000\006\188\001\000\006\128\001\000\006|\001\000\006x\001\000\006t\001\000\006p\001\000\006l\001\000\006p\002\000\006l\002\000\003x\001\000\003x\002\000\006p\003\000\006l\003\000\006p\004\000\006l\004\000\006p\005\000\006x\002\000\006t\002\000\006x\003\000\006t\003\000\006x\004\000\006t\004\000\006x\005\000\006\128\002\000\006|\002\000\006\128\003\000\006|\003\000\006\128\004\000\006|\004\000\006\128\005\000\006\216\001\000\006\204\001\000\006\136\001\000\006h\001\000\006\208\001\000\006\212\001\000\012\\\002\000\012\\\003\000\012\128\004\000\012\128\005\000\000\\\001\000\005(\001\000\000X\001\000\003h\001\000\003l\001\000\000X\002\000\0070\001\000\0070\002\000\0070\003\000\007,\001\000\000|\001\000\000h\001\000\000T\001\000\000P\001\000\000T\002\000\000T\003\000\000T\004\000\005(\001\000\003h\001\000\005\184\001\000\005\184\002\000\t@\001\000\t<\001\000\003d\001\000\003`\001\000\003\\\001\000\003X\001\000\t@\002\000\t<\002\000\003d\002\000\003`\002\000\003\\\002\000\003X\002\000\t@\003\000\t<\003\000\003d\003\000\003`\003\000\003\\\003\000\003X\003\000\012P\001\000\012<\001\000\0120\001\000\012<\002\000\t@\004\000\003d\004\000\003\\\004\000\012D\001\000\0124\001\000\012D\002\000\012 \001\000\012L\001\000\012H\001\000\012@\001\000\0128\001\000\012@\002\000\012H\002\000\012\020\001\000\012(\001\000\012$\001\000\012$\002\000\012\020\002\000\b\172\001\000\012 \002\000\b\176\001\000\012 \003\000\b\176\002\000\b\176\003\000\t@\005\000\003d\005\000\003\\\005\000\005 \001\000\003d\006\000\003\\\006\000\012\012\001\000\005(\001\000\001\152\001\000\006D\001\000\0064\001\000\006$\001\000\006\028\001\000\001\156\001\000\001\140\001\000\000|\001\000\000h\001\000\000T\001\000\000P\001\000\005 \001\000\003,\001\000\003,\002\000\005 \001\000\000p\001\000\000l\001\000\005 \001\000\004\248\001\000\004\240\001\000\004\232\001\000\004\248\002\000\004\240\002\000\004\232\002\000\bx\001\000\000X\001\000\bx\002\000\000X\002\000\000\152\001\000\000\148\001\000\006\232\001\000\000\152\002\000\000\148\002\000\000\144\001\000\000\140\001\000\000\144\002\000\000\140\002\000\000\136\001\000\000\132\001\000\000\128\001\000\000t\001\000\005l\001\000\005,\001\000\005$\001\000\005l\002\000\005l\003\000\005l\001\000\005,\001\000\005l\004\000\005,\002\000\005,\003\000\005h\001\000\005,\002\000\005$\002\000\005$\003\000\001t\001\000\000t\002\000\000\132\002\000\006\004\001\000\006\004\002\000\000`\001\000\0030\001\000\003$\001\000\0030\002\000\011\248\001\000\b\204\001\000\b\204\002\000\012\016\001\000\000\156\001\000\b\204\003\000\000x\001\000\000d\001\000\000x\002\000\000x\003\000\000d\002\000\003(\001\000\003(\002\000\003(\003\000\003(\004\000\011\244\001\000\b\208\001\000\000x\001\000\000d\001\000\b\208\002\000\b\208\003\000\000x\001\000\000d\001\000\0030\003\000\b\212\001\000\b\156\001\000\b\160\001\000\000\132\003\000\000\132\004\000\b\160\002\000\b\160\003\000\011\196\001\000\011\192\001\000\011\192\002\000\006\220\001\000\011\192\003\000\011\192\004\000\b\144\001\000\b\144\002\000\000<\001\000\b\144\003\000\000@\001\000\000@\002\000\000@\003\000\000@\004\000\011\192\005\000\b\140\001\000\000@\001\000\011\196\002\000\b\216\001\000\001\208\001\000\001\208\002\000\001\204\001\000\000@\001\000\b\212\001\000\000\128\002\000\000\128\003\000\000\136\002\000\000\136\003\000\b\160\001\000\000\136\004\000\000\136\005\000\b\160\001\000\000\140\003\000\000\140\004\000\b\160\001\000\000\152\003\000\000\148\003\000\000\148\004\000\000\152\004\000\bt\001\000\000\152\005\000\000\152\006\000\bt\002\000\bp\001\000\b|\001\000\007\240\001\000\b|\002\000\b|\003\000\007\240\002\000\007\240\003\000\000@\001\000\004\248\003\000\004\240\003\000\004\232\003\000\004\248\004\000\004\240\004\000\004\232\004\000\004\240\005\000\004\232\005\000\004\240\006\000\004\232\006\000\005\000\001\000\004\232\007\000\004\252\001\000\004\244\001\000\004\236\001\000\000x\001\000\000d\001\000\004\244\002\000\004\236\002\000\004\236\003\000\007\236\001\000\000@\001\000\000p\002\000\000l\002\000\000l\003\000\003,\003\000\003,\004\000\003,\005\000\001\156\002\000\001\156\003\000\b\188\001\000\000|\002\000\000h\002\000\000|\003\000\000h\003\000\000|\004\000\000|\005\000\000h\004\000\b\188\002\000\b\188\003\000\001\208\001\000\b\192\001\000\001\208\001\000\000P\002\000\000P\003\000\b\192\002\000\b\192\003\000\001\208\001\000\001\136\001\000\000\136\001\000\000\132\001\000\000\128\001\000\001\136\002\000\006D\002\000\005\236\001\000\003\140\001\000\003\136\001\000\003\140\002\000\003\136\002\000\003\140\003\000\003\136\003\000\003\140\004\000\003\136\004\000\003\140\005\000\003\136\005\000\003\140\006\000\003\140\007\000\006D\003\000\006D\004\000\003\152\001\000\003\148\001\000\003\152\002\000\003\144\001\000\001\144\001\000\0064\002\000\003P\001\000\001\196\001\000\001\152\001\000\001\156\001\000\001\140\001\000\001\136\001\000\003P\002\000\003D\001\000\001\192\001\000\001\192\002\000\001\192\003\000\b\184\001\000\001\188\001\000\b\184\002\000\001\188\002\000\b\184\003\000\001\188\003\000\000x\001\000\000d\001\000\003D\002\000\b\180\001\000\001\184\001\000\000x\001\000\000d\001\000\003L\001\000\003H\001\000\003H\002\000\003H\003\000\003H\004\000\000x\001\000\000d\001\000\b\180\001\000\003L\002\000\001\184\001\000\000x\001\000\000d\001\000\003P\003\000\003P\004\000\001\160\001\000\b0\001\000\001\200\001\000\003P\001\000\b0\002\000\b(\001\000\b,\001\000\006\028\002\000\001\208\001\000\006$\002\000\003T\001\000\003T\002\000\003T\003\000\006@\001\000\006@\002\000\006@\003\000\0060\001\000\012\012\002\000\006L\001\000\006H\001\000\006<\001\000\0068\001\000\006,\001\000\006(\001\000\006\024\001\000\001\208\001\000\006L\002\000\006H\002\000\006<\002\000\0068\002\000\006,\002\000\006(\002\000\006L\003\000\006<\003\000\006,\003\000\006L\004\000\006L\005\000\006L\006\000\006<\004\000\006,\004\000\006H\003\000\006H\004\000\006H\005\000\0068\003\000\006(\003\000\006 \001\000\003\\\007\000\003\\\b\000\b\\\001\000\003\\\t\000\007\244\001\000\007\244\002\000\011\148\001\000\011\144\001\000\003d\001\000\003`\001\000\011\148\002\000\011\144\002\000\003d\002\000\003`\002\000\011\148\003\000\011\144\003\000\003d\003\000\003`\003\000\011\148\004\000\003d\004\000\011\148\005\000\003d\005\000\005 \001\000\003d\006\000\003d\007\000\b\\\001\000\003d\b\000\b\\\002\000\b\\\003\000\001\208\001\000\b\\\004\000\b\\\005\000\001\208\001\000\004t\001\000\004t\002\000\003d\t\000\011\148\006\000\011\148\007\000\b\000\001\000\011\148\b\000\003P\001\000\002\248\001\000\003P\002\000\002\248\002\000\002\248\003\000\001\172\001\000\001\140\001\000\001\172\002\000\001\172\003\000\005\\\001\000\001\168\001\000\001\164\001\000\005\\\002\000\001\168\002\000\001\168\003\000\001\168\004\000\001\168\005\000\002\248\004\000\002\248\005\000\001\176\001\000\011\148\t\000\bH\001\000\bD\001\000\011\148\n\000\bD\002\000\bH\002\000\b4\001\000\b<\001\000\b8\001\000\b@\001\000\003T\001\000\002\252\001\000\002\252\002\000\002\252\003\000\002\252\004\000\012\028\001\000\011\144\004\000\003`\004\000\005 \001\000\003`\005\000\003`\006\000\b\\\001\000\003`\007\000\003`\b\000\011\144\005\000\011\144\006\000\011\144\007\000\011\144\b\000\bH\001\000\bD\001\000\011\144\t\000\004\140\001\000\004\136\001\000\003\132\001\000\0008\001\000\0004\001\000\006T\001\000\006P\001\000\006T\002\000\006T\003\000\006T\004\000\005\168\001\000\005\136\001\000\005\136\002\000\002@\001\000\002@\002\000\002@\003\000\001\b\001\000\001\004\001\000\n\\\001\000\t\128\001\000\t|\001\000\t|\002\000\t\128\002\000\tx\001\000\tt\001\000\tt\002\000\tx\002\000\012\\\001\000\n\132\001\000\nX\001\000\nT\001\000\nL\001\000\001\172\001\000\001\140\001\000\t\128\001\000\t|\001\000\006\160\001\000\nX\002\000\nT\002\000\nX\003\000\nT\003\000\nX\004\000\nT\004\000\005\176\001\000\005\172\001\000\nX\005\000\nT\005\000\nT\006\000\nX\006\000\005\192\001\000\005\192\002\000\005\192\003\000\005\192\004\000\007H\001\000\007D\001\000\007@\001\000\007<\001\000\0078\001\000\0074\001\000\007H\002\000\007D\002\000\007@\002\000\007<\002\000\007H\003\000\007D\003\000\007@\003\000\007<\003\000\011\188\001\000\011\184\001\000\001\224\001\000\001\224\002\000\001\224\003\000\002 \001\000\002 \002\000\002 \003\000\012`\001\000\002\184\001\000\002\184\002\000\004\208\001\000\004\208\002\000\004\208\003\000\b\028\001\000\004\208\004\000\t\144\001\000\t\140\001\000\t\136\001\000\001\136\001\000\t\132\001\000\003\164\001\000\t\132\002\000\t\132\003\000\004\204\001\000\004\200\001\000\004\196\001\000\004\192\001\000\007\000\001\000\007\000\002\000\001\208\001\000\004\204\002\000\004\200\002\000\004\196\002\000\004\192\002\000\007\024\001\000\007\172\001\000\007\172\002\000\007\172\003\000\001x\001\000\np\001\000\np\002\000\001\132\001\000\001|\001\000\nD\001\000\012d\001\000\nH\001\000\007\172\004\000\nP\001\000\nd\001\000\n`\001\000\nd\002\000\nd\003\000\tp\001\000\nl\001\000\n\128\001\000\n|\001\000\nx\001\000\nt\001\000\005\\\001\000\001\168\001\000\001\164\001\000\n\128\002\000\n|\002\000\nx\002\000\nt\002\000\005\\\002\000\001\168\002\000\n\128\003\000\n|\003\000\001\168\003\000\n|\004\000\007\136\001\000\007\136\002\000\007\136\003\000\007\156\001\000\007x\001\000\007\140\001\000\007\128\001\000\007\140\002\000\007\144\001\000\007\140\003\000\007\132\001\000\007|\001\000\007t\001\000\007p\001\000\007\144\002\000\007\144\003\000\007\144\001\000\007\132\001\000\007|\001\000\007t\001\000\007p\001\000\007p\002\000\007\144\001\000\007\132\001\000\007|\001\000\007t\001\000\007p\003\000\007p\001\000\007\132\002\000\007\144\001\000\007\132\003\000\007\132\001\000\007|\001\000\007t\001\000\007p\001\000\007|\002\000\007|\003\000\007t\002\000\nl\001\000\007\168\001\000\007\168\002\000\007\144\001\000\007\132\001\000\007|\001\000\007t\001\000\007p\001\000\n\136\001\000\nh\001\000\007\164\001\000\007\160\001\000\012\\\001\000\n\132\001\000\nX\001\000\nT\001\000\nL\001\000\007\164\002\000\001\172\001\000\001\140\001\000\007\164\003\000\006\012\001\000\006\b\001\000\006\012\002\000\007\164\004\000\007\164\005\000\007\164\006\000\nh\001\000\tx\001\000\tt\001\000\006\172\001\000\n\132\002\000\nL\002\000\007\144\001\000\007\132\001\000\007|\001\000\007t\001\000\007p\001\000\nL\003\000\n\132\003\000\n\132\004\000\001\208\001\000\n\132\005\000\007\160\002\000\007\144\001\000\007\132\001\000\007|\001\000\007t\001\000\007p\001\000\007\144\001\000\007\136\004\000\007\132\001\000\007|\001\000\007t\001\000\007p\001\000\n\128\004\000\007\144\001\000\007\132\001\000\007|\001\000\007t\001\000\007p\001\000\n\128\005\000\nx\003\000\t\136\001\000\nx\004\000\t\136\002\000\t\136\003\000\b\252\001\000\b\248\001\000\b\244\001\000\007\144\001\000\007\132\001\000\007|\001\000\007t\001\000\007p\001\000\b\252\002\000\b\248\002\000\b\252\003\000\nt\003\000\007\144\001\000\007\132\001\000\007|\001\000\007t\001\000\007p\001\000\007\024\002\000\004\204\003\000\004\200\003\000\004\196\003\000\004\192\003\000\004\204\004\000\004\200\004\000\004\196\004\000\004\200\005\000\006\240\001\000\004\200\006\000\004\204\005\000\t\144\002\000\t\140\002\000\t\140\003\000\nD\001\000\003\240\001\000\003\236\001\000\003\232\001\000\003\228\001\000\003\224\001\000\003\208\001\000\003\204\001\000\003\204\002\000\003\160\001\000\003\156\001\000\003\160\002\000\003\160\003\000\001\208\001\000\003\204\003\000\003\204\004\000\003\208\002\000\003\192\001\000\003\188\001\000\003\188\002\000\003\188\003\000\007 \001\000\002\176\001\000\nD\001\000\004\028\001\000\004\024\001\000\003\200\001\000\003\196\001\000\007\204\001\000\003\196\002\000\007\144\001\000\007\132\001\000\007|\001\000\007t\001\000\007p\001\000\004\020\001\000\004\016\001\000\004\020\002\000\004\020\003\000\001\208\001\000\003\196\003\000\003\196\004\000\003\196\005\000\007\200\001\000\003\200\002\000\012\\\001\000\011h\001\000\n\132\001\000\nX\001\000\nT\001\000\nL\001\000\001\172\001\000\001\140\001\000\011h\002\000\011h\003\000\011h\004\000\003\212\001\000\003\212\002\000\011`\001\000\003\252\001\000\002\016\001\000\002\012\001\000\002\b\001\000\002\004\001\000\002\016\002\000\002\012\002\000\002\016\003\000\002\016\004\000\002\016\005\000\005\140\001\000\005\140\002\000\0038\001\000\0034\001\000\0034\002\000\0038\002\000\0038\003\000\005\196\001\000\005\188\001\000\005\188\002\000\bd\001\000\003<\001\000\bd\002\000\005\188\003\000\005\188\004\000\005\204\001\000\005\212\001\000\005\208\001\000\005\200\001\000\005\188\005\000\005\212\002\000\012\168\001\000\012\164\001\000\012\168\002\000\012\164\002\000\012\168\003\000\012\164\003\000\012\192\001\000\012\188\001\000\012\192\002\000\012\168\004\000\012\168\005\000\000@\001\000\012\164\004\000\012\164\005\000\000@\001\000\012\164\006\000\b\\\001\000\012\184\001\000\012\180\001\000\012\176\001\000\012\172\001\000\012\184\002\000\012\180\002\000\012\184\003\000\012\180\003\000\012\180\004\000\012\180\005\000\005\212\001\000\005\208\001\000\005\200\001\000\005\208\002\000\005\212\001\000\005\208\003\000\005\208\001\000\005\200\001\000\005\200\002\000\005l\001\000\005L\001\000\005,\001\000\005L\002\000\005,\002\000\005,\003\000\003h\001\000\005L\003\000\005\228\001\000\005H\001\000\005\216\001\000\012\184\004\000\012\184\005\000\005\212\001\000\005\208\001\000\005\200\001\000\012\176\002\000\012\172\002\000\005\\\001\000\012\172\003\000\012\172\004\000\005l\001\000\005,\001\000\005\\\002\000\012\176\003\000\012\176\004\000\005l\001\000\005,\001\000\b\148\001\000\b\152\001\000\005\212\003\000\b\152\002\000\b\152\003\000\b`\001\000\005\212\001\000\005\208\001\000\005\200\001\000\005\196\002\000\005\196\003\000\005\212\001\000\005\208\001\000\005\200\001\000\0038\004\000\0038\005\000\005\140\003\000\005\140\004\000\005\144\001\000\005\160\001\000\005\156\001\000\005\148\001\000\005\140\005\000\007H\001\000\007D\001\000\007@\001\000\007<\001\000\0078\001\000\0074\001\000\005\160\002\000\005\160\003\000\0078\002\000\0074\002\000\005\160\001\000\005\156\001\000\005\148\001\000\0078\003\000\0074\003\000\0074\004\000\005\212\001\000\005\208\001\000\005\200\001\000\0074\005\000\005\156\002\000\005\148\002\000\005\152\001\000\005\\\001\000\005\164\001\000\005\160\001\000\005\156\001\000\005\148\001\000\002\016\006\000\002\016\007\000\n(\001\000\n$\001\000\n4\001\000\001\136\001\000\t\248\001\000\t\244\001\000\b\240\001\000\b\236\001\000\b\232\001\000\007\b\001\000\n\028\001\000\012`\001\000\005P\001\000\t\152\001\000\t\148\001\000\002<\001\000\002<\002\000\002<\003\000\t\204\001\000\t\200\001\000\t\204\002\000\t\200\002\000\t\204\003\000\t\200\003\000\002,\001\000\002(\001\000\002,\002\000\002(\002\000\002,\003\000\002(\003\000\002\020\001\000\002\020\002\000\002\020\003\000\b\132\001\000\007\144\001\000\007\132\001\000\007|\001\000\007t\001\000\007p\001\000\004\228\001\000\004\224\001\000\004\220\001\000\004\224\002\000\002\028\001\000\002\024\001\000\002\028\002\000\002\024\002\000\002\028\003\000\002\024\003\000\012\\\001\000\n\132\001\000\nX\001\000\nT\001\000\nL\001\000\002\028\004\000\001\172\001\000\001\140\001\000\002\028\005\000\002\028\006\000\002\028\007\000\003\020\001\000\001\252\001\000\001\248\001\000\001\252\002\000\001\248\002\000\001\252\003\000\001\248\003\000\007\144\001\000\007\132\001\000\007|\001\000\007t\001\000\007p\001\000\001\252\004\000\001\248\004\000\001\252\005\000\0024\001\000\0024\002\000\0024\003\000\007\144\001\000\007\132\001\000\007|\001\000\007t\001\000\007p\001\000\0024\004\000\0024\005\000\t\240\001\000\t\220\001\000\005`\001\000\n\012\001\000\n\b\001\000\t\252\001\000\t\240\002\000\t\196\001\000\t\192\001\000\t\188\001\000\t\184\001\000\t\180\001\000\t\176\001\000\t\172\001\000\t\168\001\000\t\164\001\000\n\012\002\000\n\012\003\000\n\012\001\000\n\b\001\000\t\252\001\000\t\196\001\000\t\192\001\000\t\188\001\000\t\184\001\000\t\180\001\000\t\176\001\000\t\172\001\000\t\168\001\000\t\164\001\000\n\b\002\000\n\b\003\000\t\192\002\000\t\184\002\000\t\176\002\000\t\176\003\000\0028\001\000\0028\002\000\0028\003\000\n\012\001\000\n\b\001\000\t\252\001\000\t\196\001\000\t\192\001\000\t\188\001\000\t\184\001\000\t\180\001\000\t\176\001\000\t\172\001\000\t\168\001\000\t\164\001\000\0028\004\000\t\252\002\000\t\196\002\000\t\188\002\000\t\180\002\000\t\172\002\000\t\168\002\000\t\164\002\000\t\164\003\000\002\164\001\000\n\012\001\000\n\b\001\000\t\252\001\000\t\196\001\000\t\192\001\000\t\188\001\000\t\184\001\000\t\180\001\000\t\176\001\000\t\172\001\000\t\168\001\000\t\164\001\000\002\224\001\000\002\220\001\000\002\216\001\000\002\212\001\000\002\208\001\000\002\204\001\000\002\200\001\000\002\196\001\000\002\192\001\000\002\188\001\000\002D\001\000\002\000\001\000\003\176\001\000\003\176\002\000\003\180\001\000\003\180\002\000\003\184\001\000\n\012\001\000\n\b\001\000\t\252\001\000\t\196\001\000\t\192\001\000\t\188\001\000\t\184\001\000\t\180\001\000\t\176\001\000\t\172\001\000\t\168\001\000\t\164\001\000\003\184\002\000\t\232\001\000\n@\001\000\n<\001\000\n8\001\000\n0\001\000\n,\001\000\n \001\000\n\024\001\000\n\004\001\000\n\000\001\000\005d\001\000\005\\\001\000\001\168\001\000\001\164\001\000\n@\002\000\n<\002\000\n8\002\000\n0\002\000\n,\002\000\n \002\000\n\024\002\000\n\004\002\000\n\000\002\000\005d\002\000\005\\\002\000\001\168\002\000\012\\\001\000\n@\003\000\n\024\003\000\n\000\003\000\001\168\003\000\n\024\004\000\006\164\001\000\0008\001\000\006\160\001\000\0004\001\000\n@\004\000\n@\005\000\n@\006\000\n@\007\000\005\160\001\000\005\156\001\000\005\148\001\000\n@\b\000\n@\t\000\005\212\001\000\005\208\001\000\005\200\001\000\n@\n\000\011\188\001\000\006\176\001\000\011\184\001\000\006\172\001\000\006d\001\000\002\176\001\000\007\156\001\000\004 \001\000\004 \002\000\004 \003\000\001\208\001\000\004 \004\000\004 \005\000\b\196\001\000\002H\001\000\b\196\002\000\t\232\001\000\002P\001\000\n\012\001\000\n\b\001\000\t\252\001\000\t\196\001\000\t\192\001\000\t\188\001\000\t\184\001\000\t\180\001\000\t\176\001\000\t\172\001\000\t\168\001\000\t\164\001\000\002P\002\000\012h\001\000\n\016\001\000\t\228\001\000\t\224\001\000\004\216\001\000\001\220\001\000\001\220\002\000\001\220\003\000\004\212\001\000\004\000\001\000\002\172\001\000\002\172\002\000\002\172\003\000\t\024\001\000\t\020\001\000\t\016\001\000\t\012\001\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\002|\002\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\003\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\002p\002\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\003\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\002l\002\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\003\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\002h\002\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\003\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\002\128\002\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\003\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\002\144\002\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\003\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\002x\002\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\003\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\002t\002\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\003\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\002\136\002\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\003\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\002d\002\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\003\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\002`\002\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\003\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\002\\\002\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\003\000\002\\\001\000\002X\001\000\002T\001\000\002X\002\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\003\000\002X\001\000\002T\001\000\002T\002\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\003\000\002T\001\000\002\140\002\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\003\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\002\132\002\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\003\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\b\200\002\000\b\200\003\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\002\160\002\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\003\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\002\180\002\000\b\200\001\000\002\228\001\000\002\180\003\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\002\148\002\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\003\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\002\152\002\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\003\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\002\156\002\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\003\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\002\228\002\000\t\228\001\000\002L\001\000\n\012\001\000\n\b\001\000\t\252\001\000\t\196\001\000\t\192\001\000\t\188\001\000\t\184\001\000\t\180\001\000\t\176\001\000\t\172\001\000\t\168\001\000\t\164\001\000\002L\002\000\002\168\001\000\b\200\001\000\002\228\001\000\002\180\001\000\002\168\002\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\t\024\002\000\t\020\002\000\t\016\002\000\t\024\003\000\t\024\004\000\t\024\005\000\t\020\003\000\000D\001\000\000D\002\000\nH\001\000\003\248\001\000\003\248\002\000\003\248\003\000\001\208\001\000\003\248\004\000\003\248\005\000\007\196\001\000\007\188\001\000\007\180\001\000\007\176\001\000\007\152\001\000\003\244\001\000\003\244\002\000\003\244\003\000\007\152\002\000\007\152\003\000\007\144\001\000\007\132\001\000\007|\001\000\007t\001\000\007p\001\000\007\176\002\000\007\176\003\000\007\144\001\000\007\132\001\000\007|\001\000\007t\001\000\007p\001\000\007\196\002\000\007\196\003\000\007\144\001\000\007\132\001\000\007|\001\000\007t\001\000\007p\001\000\007\188\002\000\007\188\003\000\007\180\002\000\007\184\001\000\007\192\001\000\007\148\001\000\007\148\002\000\007\148\003\000\007\144\001\000\007\132\001\000\007|\001\000\007t\001\000\007p\001\000\003\220\001\000\000D\003\000\000D\004\000\004\000\002\000\004\216\002\000\b\200\001\000\b\196\003\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\007\196\001\000\007\188\001\000\007\180\001\000\007\176\001\000\007\152\001\000\004$\001\000\004$\002\000\004$\003\000\004,\001\000\002\176\002\000\002\176\003\000\002\176\004\000\004,\002\000\004,\003\000\004(\001\000\t\240\001\000\006\136\001\000\n\000\004\000\n\000\005\000\n0\003\000\n,\003\000\n0\004\000\n,\004\000\n,\005\000\b\228\001\000\b\224\001\000\b\220\001\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\b\228\002\000\b\224\002\000\b\228\003\000\n<\003\000\n8\003\000\n<\004\000\n8\004\000\n8\005\000\n\004\003\000\n\004\004\000\n\004\005\000\n \003\000\n\012\001\000\n\b\001\000\t\252\001\000\t\196\001\000\t\192\001\000\t\188\001\000\t\184\001\000\t\180\001\000\t\176\001\000\t\172\001\000\t\168\001\000\t\164\001\000\b$\001\000\b$\002\000\b$\003\000\t\b\001\000\t\004\001\000\t\000\001\000\012\004\001\000\012\004\002\000\001\208\001\000\012\000\001\000\011\252\001\000\012\000\002\000\011\252\002\000\001\208\001\000\012\000\003\000\012\000\004\000\001\208\001\000\007(\001\000\t\b\002\000\t\004\002\000\t\000\002\000\t\b\003\000\t\004\003\000\t\000\003\000\t\b\004\000\t\004\004\000\t\b\005\000\b \001\000\n \004\000\n \005\000\n@\001\000\n<\001\000\n8\001\000\n0\001\000\n,\001\000\n \001\000\n\024\001\000\n\004\001\000\n\000\001\000\005d\001\000\005\\\001\000\005T\001\000\001\168\001\000\001\164\001\000\n@\002\000\n<\002\000\n8\002\000\n0\002\000\n,\002\000\n \002\000\n\024\002\000\n\004\002\000\n\000\002\000\005d\002\000\005\\\002\000\005T\002\000\001\168\002\000\012`\001\000\005T\003\000\005d\003\000\003\172\001\000\n\012\001\000\n\b\001\000\t\252\001\000\t\196\001\000\t\192\001\000\t\188\001\000\t\184\001\000\t\180\001\000\t\176\001\000\t\172\001\000\t\168\001\000\t\164\001\000\003\172\002\000\t\192\002\000\t\184\002\000\t\176\002\000\002\220\002\000\002\212\002\000\002\204\002\000\t\176\003\000\002\204\003\000\t\176\004\000\002\204\004\000\t\176\005\000\002\204\005\000\002\204\006\000\b\200\001\000\002\228\001\000\002\204\007\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\t\192\003\000\002\220\003\000\t\192\004\000\002\220\004\000\t\192\005\000\002\220\005\000\002\220\006\000\b\200\001\000\002\228\001\000\002\220\007\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\t\184\003\000\002\212\003\000\t\184\004\000\002\212\004\000\t\184\005\000\002\212\005\000\002\212\006\000\b\200\001\000\002\228\001\000\002\212\007\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\t\252\002\000\t\196\002\000\t\188\002\000\t\180\002\000\t\172\002\000\t\168\002\000\t\164\002\000\002\224\002\000\002\216\002\000\002\208\002\000\002\200\002\000\002\196\002\000\002\192\002\000\002\188\002\000\t\164\003\000\002\192\003\000\t\164\004\000\002\192\004\000\t\164\005\000\002\192\005\000\002\192\006\000\b\200\001\000\002\228\001\000\002\192\007\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\t\172\003\000\002\200\003\000\t\172\004\000\002\200\004\000\t\172\005\000\002\200\005\000\002\200\006\000\b\200\001\000\002\228\001\000\002\200\007\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\t\168\003\000\002\196\003\000\t\168\004\000\002\196\004\000\t\168\005\000\002\196\005\000\002\196\006\000\b\200\001\000\002\228\001\000\002\196\007\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\t\196\003\000\t\188\003\000\t\180\003\000\005\\\001\000\005T\001\000\002\224\003\000\002\216\003\000\002\208\003\000\t\196\004\000\t\188\004\000\t\180\004\000\002\224\004\000\002\216\004\000\002\208\004\000\t\180\005\000\002\208\005\000\t\180\006\000\002\208\006\000\t\180\007\000\002\208\007\000\002\208\b\000\b\200\001\000\002\228\001\000\002\208\t\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\t\196\005\000\002\224\005\000\t\196\006\000\002\224\006\000\t\196\007\000\002\224\007\000\002\224\b\000\b\200\001\000\002\228\001\000\002\224\t\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\t\188\005\000\002\216\005\000\t\188\006\000\002\216\006\000\t\188\007\000\002\216\007\000\002\216\b\000\b\200\001\000\002\228\001\000\002\216\t\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\t\252\003\000\002\188\003\000\002\188\004\000\b\200\001\000\002\228\001\000\002\188\005\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\n\012\001\000\n\b\001\000\t\252\001\000\t\196\001\000\t\192\001\000\t\188\001\000\t\184\001\000\t\180\001\000\t\176\001\000\t\172\001\000\t\168\001\000\t\164\001\000\003\168\001\000\bl\001\000\002D\002\000\bl\002\000\bh\001\000\b\200\001\000\002\228\001\000\002\180\001\000\002\164\002\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\t\164\004\000\t\164\005\000\t\172\003\000\t\172\004\000\t\172\005\000\t\168\003\000\t\168\004\000\t\168\005\000\t\196\003\000\t\188\003\000\t\180\003\000\005\\\001\000\005T\001\000\t\196\004\000\t\188\004\000\t\180\004\000\t\180\005\000\t\180\006\000\t\180\007\000\t\196\005\000\t\196\006\000\t\196\007\000\t\188\005\000\t\188\006\000\t\188\007\000\t\252\003\000\t\176\004\000\t\176\005\000\t\192\003\000\t\192\004\000\t\192\005\000\t\184\003\000\t\184\004\000\t\184\005\000\0024\006\000\001\212\001\000\001\216\001\000\0024\007\000\0024\b\000\0024\t\000\0024\n\000\0024\011\000\001\252\006\000\001\252\007\000\001\252\b\000\001\252\t\000\001\248\005\000\001\248\006\000\001\248\007\000\001\248\b\000\001\248\t\000\001\248\n\000\001\248\011\000\003\020\002\000\012\\\001\000\n\132\001\000\nX\001\000\nT\001\000\nL\001\000\003 \001\000\001\172\001\000\001\140\001\000\003 \002\000\003 \003\000\003 \004\000\003\024\001\000\003\024\002\000\000x\001\000\000d\001\000\003\024\003\000\003\024\004\000\003\216\001\000\003\028\001\000\003\028\002\000\003 \005\000\002\028\b\000\002\024\004\000\002\024\005\000\004\224\003\000\004\224\004\000\004\224\005\000\004\228\002\000\004\220\002\000\004\228\003\000\004\220\003\000\b\132\002\000\b\136\001\000\002\020\004\000\b\136\002\000\b\136\003\000\b\128\001\000\002,\004\000\002(\004\000\002,\005\000\002(\005\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\002,\006\000\002(\006\000\002(\007\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\002(\b\000\t\204\004\000\t\200\004\000\t\200\005\000\n\012\001\000\n\b\001\000\t\252\001\000\t\196\001\000\t\192\001\000\t\188\001\000\t\184\001\000\t\180\001\000\t\176\001\000\t\172\001\000\t\168\001\000\t\164\001\000\002<\004\000\t\148\002\000\b\200\001\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\t\148\003\000\n\012\001\000\n\b\001\000\t\252\001\000\t\196\001\000\t\192\001\000\t\188\001\000\t\184\001\000\t\180\001\000\t\176\001\000\t\172\001\000\t\168\001\000\t\164\001\000\t\152\002\000\n\028\002\000\n\028\003\000\b\200\001\000\007\b\002\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\b\240\002\000\b\236\002\000\b\232\002\000\b\240\003\000\b\236\003\000\b\240\004\000\t\248\002\000\t\244\002\000\t\244\003\000\n4\002\000\n4\003\000\n(\002\000\n$\002\000\n$\003\000\002\016\b\000\002\012\003\000\002\012\004\000\005\160\001\000\005\156\001\000\005\148\001\000\002\012\005\000\002\012\006\000\002\012\007\000\002\004\002\000\002\004\003\000\002\004\004\000\002\004\005\000\005t\001\000\005\160\001\000\005\156\001\000\005\148\001\000\005t\002\000\005x\001\000\005\212\001\000\005\208\001\000\005\200\001\000\005x\002\000\005x\003\000\005\160\001\000\005\156\001\000\005\148\001\000\005x\004\000\002\004\006\000\002\004\007\000\002\004\b\000\005|\001\000\005|\002\000\002\b\002\000\002\b\003\000\002\b\004\000\002\b\005\000\002\b\006\000\002\b\007\000\002\b\b\000\002\b\t\000\003\252\002\000\003\252\003\000\003\252\004\000\003\252\005\000\003\252\006\000\011`\002\000\003\016\001\000\003\016\002\000\003\016\003\000\003\012\001\000\011d\001\000\011d\002\000\011h\005\000\004\024\002\000\007 \002\000\003\188\004\000\003\188\005\000\003\192\002\000\012\000\001\000\011\252\001\000\003\240\002\000\003\236\002\000\003\240\003\000\003\240\004\000\003\240\005\000\003\240\006\000\001\208\001\000\003\240\007\000\003\240\b\000\b|\001\000\003\236\003\000\003\236\004\000\003\236\005\000\001\208\001\000\003\236\006\000\003\236\007\000\003\232\002\000\003\232\003\000\003\232\004\000\003\228\002\000\004\208\005\000\004\208\006\000\b\200\001\000\002\228\001\000\002\184\003\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\002 \004\000\002 \005\000\b\136\001\000\002 \006\000\001\224\004\000\001\224\005\000\b\136\001\000\001\224\006\000\b\200\001\000\007H\004\000\007D\004\000\007@\004\000\007<\004\000\002\228\001\000\002\180\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\144\001\000\002\140\001\000\002\136\001\000\002\132\001\000\002\128\001\000\002|\001\000\002x\001\000\002t\001\000\002p\001\000\002l\001\000\002h\001\000\002d\001\000\002`\001\000\002\\\001\000\002X\001\000\002T\001\000\007<\005\000\007H\005\000\007H\006\000\005\212\001\000\005\208\001\000\005\200\001\000\007H\007\000\007D\005\000\007@\005\000\007D\006\000\007@\006\000\005\212\001\000\005\208\001\000\005\200\001\000\007@\007\000\007D\007\000\007D\b\000\005\212\001\000\005\208\001\000\005\200\001\000\007D\t\000\005\192\005\000\005\160\001\000\005\156\001\000\005\148\001\000\nX\007\000\005\212\001\000\005\208\001\000\005\200\001\000\nX\b\000\007\144\001\000\007\132\001\000\007|\001\000\007t\001\000\007p\001\000\001\b\002\000\001\004\002\000\001\004\003\000\001\b\003\000\001\208\001\000\001\b\004\000\001\b\005\000\002@\004\000\000\212\001\000\012|\001\000\012t\001\000\012|\002\000\012t\002\000\012|\003\000\012t\003\000\012|\004\000\012t\004\000\012t\005\000\012t\006\000\012|\005\000\012|\006\000\012|\007\000\000\212\002\000\000\212\003\000\012x\001\000\012p\001\000\012l\001\000\012\148\001\000\012\140\001\000\012\148\002\000\012\144\001\000\005\236\001\000\012\144\002\000\012l\002\000\012l\003\000\012l\004\000\012l\005\000\001\208\001\000\012x\002\000\012p\002\000\012x\003\000\012p\003\000\012p\004\000\012p\005\000\012x\004\000\012x\005\000\012x\006\000\000\216\001\000\005\028\001\000\005\020\001\000\005\012\001\000\005\028\002\000\005\020\002\000\005\012\002\000\005\028\003\000\005\020\003\000\005\012\003\000\005\028\004\000\005\020\004\000\005\012\004\000\005\028\005\000\005\020\005\000\005\028\006\000\005\028\007\000\005\028\b\000\005\028\t\000\001\208\001\000\005\028\n\000\005\028\011\000\b|\001\000\007\232\001\000\007\232\002\000\007\232\003\000\001\208\001\000\005\020\006\000\005\020\007\000\005\020\b\000\007\228\001\000\001\208\001\000\005\012\005\000\000\216\002\000\000\216\003\000\005\024\001\000\005\016\001\000\005\b\001\000\005\004\001\000\012\160\001\000\012\152\001\000\012\160\002\000\012\156\001\000\b\000\001\000\012\156\002\000\005\004\002\000\005\004\003\000\005\004\004\000\005\004\005\000\005\024\002\000\005\016\002\000\005\b\002\000\005\024\003\000\005\016\003\000\005\b\003\000\005\024\004\000\005\016\004\000\005\024\005\000\005\024\006\000\005\024\007\000\005\024\b\000\001\208\001\000\005\024\t\000\005\024\n\000\005\016\005\000\005\016\006\000\005\016\007\000\005\b\004\000\003\128\001\000\003\128\002\000\007\224\001\000\007\220\001\000\007\224\002\000\007\220\002\000\007\144\001\000\007\132\001\000\007|\001\000\007t\001\000\007p\001\000\007\224\003\000\007\224\004\000\011\160\001\000\011\156\001\000\005\220\001\000\005\220\002\000\005\220\003\000\005\220\004\000\005\220\005\000\007\016\001\000\007\016\002\000\005\212\001\000\005\208\001\000\005\200\001\000\005\220\006\000\005\220\007\000\011\160\002\000\011\156\002\000\011\160\003\000\011\156\003\000\011\160\004\000\011\160\005\000\011\160\006\000\011\160\007\000\004L\001\000\004L\002\000\004L\003\000\004L\004\000\004L\005\000\004L\006\000\011\160\b\000\011\156\004\000\011\156\005\000\011\156\006\000\003\000\001\000\003\000\002\000\011\180\001\000\011\180\002\000\011\180\003\000\011\180\004\000\005\160\001\000\005\156\001\000\005\148\001\000\011\180\005\000\007\248\001\000\007\248\002\000\007\248\003\000\007\248\004\000\007\248\005\000\007\248\006\000\001\208\001\000\007\248\007\000\006\020\001\000\006\016\001\000\006\020\002\000\007\248\b\000\007\248\t\000\011\\\001\000\t\028\001\000\011\\\002\000\t\028\002\000\011\\\003\000\t\028\003\000\011\\\004\000\t\028\004\000\011\\\005\000\011\\\006\000\011\\\007\000\011\\\b\000\t\028\005\000\t\028\006\000\t\028\007\000\007\216\001\000\007\212\001\000\004|\001\000\006\\\001\000\006X\001\000\006\\\002\000\006\\\003\000\006\\\004\000\006\\\005\000\005l\001\000\005,\001\000\006\\\006\000\006X\002\000\006X\003\000\006X\004\000\005l\001\000\005,\001\000\006X\005\000\tT\001\000\tL\001\000\tH\001\000\005\224\001\000\005\220\001\000\005\180\001\000\005\224\002\000\005\220\002\000\005\224\003\000\005\220\003\000\005\224\004\000\005\220\004\000\005\224\005\000\005\220\005\000\005\224\006\000\005\224\007\000\005\212\001\000\005\208\001\000\005\200\001\000\005\224\b\000\tT\002\000\tL\002\000\tH\002\000\005\180\002\000\tT\003\000\tL\003\000\tH\003\000\005\180\003\000\005\180\004\000\005\172\001\000\005\180\005\000\005\180\006\000\005l\001\000\005,\001\000\005\180\007\000\tT\004\000\tT\005\000\tT\006\000\tT\007\000\005\212\001\000\005\208\001\000\005\200\001\000\tT\b\000\004T\001\000\004T\002\000\004T\003\000\004T\004\000\005\212\001\000\005\208\001\000\005\200\001\000\004T\005\000\004T\006\000\004T\007\000\tT\t\000\tL\004\000\tH\004\000\tL\005\000\tL\006\000\005\\\001\000\tL\007\000\005\128\001\000\005\212\001\000\005\208\001\000\005\200\001\000\005\128\002\000\tH\005\000\tH\006\000\005\132\001\000\005\132\002\000\td\001\000\td\002\000\td\003\000\td\004\000\005\212\001\000\005\208\001\000\005\200\001\000\td\005\000\t\028\001\000\t\028\002\000\t\028\003\000\t\028\004\000\th\001\000\001p\001\000\001p\002\000\001p\003\000\001p\004\000\012\136\001\000\001p\005\000\003\b\001\000\b\176\001\000\003\b\002\000\003\b\003\000\001p\006\000\001p\007\000\001p\b\000\001<\001\000\001<\002\000\001\016\001\000\001\208\001\000\001\016\002\000\001\016\003\000\001<\003\000\001\028\001\000\001\028\002\000\006\000\001\000\005\248\001\000\006\000\002\000\005\252\001\000\005\244\001\000\005\252\002\000\001\028\003\000\001\028\004\000\001\028\005\000\001\208\001\000\001\028\006\000\001\028\007\000\001 \001\000\001 \002\000\b\020\001\000\b\012\001\000\b\020\002\000\b\016\001\000\b\b\001\000\b\016\002\000\001 \003\000\001 \004\000\001 \005\000\001 \006\000\001 \007\000\001\024\001\000\001\024\002\000\001H\001\000\001D\001\000\001H\002\000\001D\002\000\001H\003\000\001H\004\000\005\\\001\000\001H\005\000\001H\006\000\0014\001\000\b\168\001\000\0014\002\000\0014\003\000\0014\004\000\b\168\002\000\b\168\003\000\001\208\001\000\b\164\001\000\001\208\001\000\0018\001\000\0010\001\000\001H\007\000\001@\001\000\001@\002\000\001D\003\000\005\\\001\000\001D\004\000\001D\005\000\001D\006\000\001@\001\000\001@\001\000\001\024\003\000\001\024\004\000\001$\001\000\001$\002\000\001\208\001\000\001\180\001\000\001\180\002\000\001\208\001\000\001\180\003\000\001$\003\000\001$\004\000\001<\004\000\001<\005\000\001(\001\000\001(\002\000\001,\001\000\004\152\001\000\004\152\002\000\001p\t\000\001@\001\000\001p\n\000\004D\001\000\004D\002\000\004D\003\000\004D\004\000\004D\005\000\004D\006\000\004D\007\000\001@\001\000\004D\b\000\004D\t\000\001p\011\000\th\002\000\th\003\000\th\004\000\th\005\000\th\006\000\th\007\000\005 \001\000\001h\001\000\001h\002\000\001h\003\000\001h\004\000\0014\001\000\000\136\001\000\000\132\001\000\000\128\001\000\b\216\001\000\b\164\001\000\001\208\001\000\001l\001\000\001l\002\000\001d\001\000\001d\002\000\001d\003\000\012\016\001\000\001t\001\000\0018\001\000\000\156\001\000\001d\004\000\001`\001\000\001@\001\000\001l\003\000\001h\005\000\th\b\000\th\t\000\004<\001\000\004<\002\000\004<\003\000\004<\004\000\004<\005\000\004<\006\000\004<\007\000\004<\b\000\004<\t\000\th\n\000\t,\001\000\004\128\001\000\tD\001\000\t0\001\000\t`\001\000\t\\\001\000\tX\001\000\tP\001\000\004\128\002\000\t$\001\000\t$\002\000\t4\001\000\004d\001\000\004d\002\000\004d\003\000\004d\004\000\004d\005\000\b\\\001\000\004d\006\000\004d\007\000\004d\b\000\t4\002\000\t8\001\000\004l\001\000\004l\002\000\004l\003\000\004l\004\000\004l\005\000\004l\006\000\b\\\001\000\004l\007\000\004l\b\000\004l\t\000\t8\002\000\t(\001\000\tl\001\000\004|\002\000\007\212\002\000\t \001\000\007\216\002\000\001\208\001\000\011\172\001\000\001p\001\000\011\172\002\000\011\172\003\000\011\172\004\000\011\172\005\000\011\172\006\000\000\236\001\000\001\\\001\000\001\\\002\000\001\\\003\000\000\224\001\000\000\224\002\000\000\224\003\000\000\224\004\000\000\208\001\000\000\204\001\000\000\208\002\000\000\208\003\000\001X\001\000\001L\001\000\004\b\001\000\004\004\001\000\000\188\001\000\000\184\001\000\004\b\002\000\004\b\003\000\004\b\004\000\004\b\005\000\004\b\006\000\004\b\007\000\000\188\002\000\000\184\002\000\000\188\003\000\000\188\004\000\005\\\001\000\000\188\005\000\000\188\006\000\001T\001\000\b\168\001\000\001T\002\000\001T\003\000\001T\004\000\000\176\001\000\000\176\002\000\000\252\001\000\000\248\001\000\000\248\002\000\004\012\001\000\000\180\001\000\000\180\002\000\000\200\001\000\000\196\001\000\000\172\001\000\bl\001\000\000\196\002\000\001P\001\000\000\192\001\000\000\180\003\000\000\192\002\000\004\012\002\000\000\248\003\000\000\192\001\000\000\252\002\000\000\176\003\000\000\192\001\000\000\188\007\000\000\184\003\000\005\\\001\000\000\184\004\000\000\184\005\000\000\192\001\000\000\184\006\000\004\004\002\000\004\004\003\000\004\004\004\000\004\004\005\000\001X\002\000\001L\002\000\000\192\001\000\001L\003\000\001X\003\000\001X\004\000\001X\005\000\000\208\004\000\000\192\001\000\006\248\001\000\006\248\002\000\000\208\005\000\000\208\006\000\000\204\002\000\000\204\003\000\000\192\001\000\000\204\004\000\000\204\005\000\000\220\001\000\000\220\002\000\000\220\003\000\000\220\004\000\001\\\004\000\001\\\005\000\000\228\001\000\000\228\002\000\000\232\001\000\004\160\001\000\004\160\002\000\000\236\002\000\000\192\001\000\000\240\001\000\000\240\002\000\000\240\003\000\000\240\004\000\000\192\001\000\000\244\001\000\000\244\002\000\011\172\007\000\011\172\b\000\0044\001\000\0044\002\000\0044\003\000\0044\004\000\0044\005\000\0044\006\000\0044\007\000\0044\b\000\011\172\t\000\011\136\001\000\004\144\001\000\003\252\001\000\011\152\001\000\011X\001\000\011\132\001\000\011\168\001\000\011\164\001\000\011t\001\000\004\216\001\000\004\144\002\000\011x\001\000\004\000\001\000\011|\001\000\011|\002\000\011\140\001\000\011\140\002\000\011\128\001\000\011\176\001\000\007\208\001\000\011p\001\000\011p\002\000\011p\003\000\003\000\003\000\003\000\004\000\011t\001\000\004\216\001\000\001\220\001\000\011l\001\000\011x\001\000\004\000\001\000\002\172\001\000\003\128\003\000\003\128\004\000\002@\005\000\002@\006\000\005\136\003\000\005\136\004\000\006T\005\000\005\160\001\000\005\156\001\000\005\148\001\000\006T\006\000\006P\002\000\006P\003\000\006P\004\000\005\160\001\000\005\156\001\000\005\148\001\000\006P\005\000\004\140\002\000\004\140\003\000\004\140\004\000\004\136\002\000\007\244\003\000\007\244\004\000\003\\\n\000\t@\006\000\t@\007\000\t@\b\000\t@\t\000\bT\001\000\t@\n\000\bT\002\000\bL\001\000\bP\001\000\t<\004\000\003`\004\000\003X\004\000\005 \001\000\003`\005\000\003X\005\000\003X\006\000\003X\007\000\b\\\001\000\003X\b\000\003X\t\000\t<\005\000\t<\006\000\t<\007\000\t<\b\000\bT\001\000\t<\t\000\005\184\003\000\005\184\004\000\005\212\001\000\005\208\001\000\005\200\001\000\000T\005\000\000T\006\000\012\128\006\000\001\208\001\000\012\128\007\000\002\240\003\000\002\240\004\000\n\012\001\000\n\b\001\000\t\252\001\000\t\236\002\000\t\196\001\000\t\192\001\000\t\188\001\000\t\184\001\000\t\180\001\000\t\176\001\000\t\172\001\000\t\168\001\000\t\164\001\000\t\216\002\000\t\212\002\000\t\216\003\000\t\212\003\000\t\216\004\000\t\212\004\000\t\216\005\000\t\212\005\000\005\160\001\000\005\156\001\000\005\148\001\000\t\212\006\000\t\216\006\000\t\216\007\000\005\212\001\000\005\208\001\000\005\200\001\000\t\216\b\000\t\160\002\000\t\156\002\000\t\156\003\000\t\160\003\000\t\160\004\000\002$\004\000\002$\005\000\b\136\001\000\002$\006\000\001\240\004\000\001\236\004\000\001\232\004\000\001\228\004\000\001\240\005\000\001\232\005\000\b\136\001\000\001\240\006\000\001\232\006\000\001\240\007\000\001\240\b\000\001\236\005\000\001\236\006\000\0020\004\000\0020\005\000\0020\006\000\0020\007\000\000\168\003\000\000\168\004\000\001\244\003\000\001\244\004\000\001\244\005\000\001\244\006\000\001\244\007\000\003p\001\000\003p\002\000\000\000\001\000\000\004\000\000\003|\001\000\003|\002\000\000\004\001\000\000\b\000\000\012\\\001\000\0054\001\000\001\140\001\000\0054\002\000\0054\003\000\0058\001\000\000\b\001\000\005l\001\000\005D\001\000\005@\001\000\005<\001\000\005,\001\000\005D\002\000\005@\002\000\005<\002\000\005,\002\000\012\\\001\000\005@\003\000\005@\004\000\005@\005\000\005D\003\000\005<\003\000\000H\001\000\0050\001\000\000L\001\000\007L\001\000\007L\002\000\000\012\000\000\000\012\001\000\007P\001\000\007P\002\000\000\016\000\000\000\016\001\000\007T\001\000\001\208\001\000\007T\002\000\000\020\000\000\007X\001\000\007X\002\000\000\020\001\000\000\024\000\000\000\024\001\000\007\\\001\000\005l\001\000\005,\001\000\007\\\002\000\000\028\000\000\000\028\001\000\007`\001\000\005\\\001\000\007`\002\000\000 \000\000\000 \001\000\007d\001\000\007d\002\000\000$\000\000\007\144\001\000\007\132\001\000\007|\001\000\007t\001\000\007p\001\000\007h\001\000\007h\002\000\000$\001\000\000(\000\000\007l\001\000\007l\002\000\000(\001\000\005d\001\000\005\\\001\000\005d\002\000\005\\\002\000\000,\000\000\011\224\001\000\011\220\001\000\011\216\001\000\011\212\001\000\011\208\001\000\011\204\001\000\011\200\001\000\011\224\002\000\011\220\002\000\011\216\002\000\011\212\002\000\011\208\002\000\011\204\002\000\011\200\002\000\011\224\003\000\011\204\003\000\011\208\003\000\011\220\003\000\011\212\003\000\011\216\003\000\005d\001\000\005\\\001\000\011\240\001\000\000,\001\000\011\236\001\000\011\236\002\000\004\168\001\000\004\168\002\000\011\228\001\000\011\228\002\000\011\228\003\000\011\232\001\000\011\232\002\000\0000\000\000\004\180\001\000\004\176\001\000\004\188\001\000\004\184\001\000\004\184\002\000\004\188\002\000\004\180\002\000\004\180\003\000\004\180\004\000\004\176\002\000\0000\001\000\012X\001\000\012X\002\000\012X\003\000\012X\004\000\012T\001\000\012T\002"), (16, "\000\000\000\001\000\002\000\003\000\004\000\005\000\006\000\007\000\b\000\t\000\n\000\011\000\012\000\r\000\014\000\015\000\016\000\017\000\018\000\019\000\020\000\021\000\022\000\023\000\024\000\025\000\026\000\027\000\028\000\029\000\030\000\031\000 \000!\000\"\000#\000$\000%\000&\000'\000(\000)\000*\000+\000,\000-\000.\000/\0000\0001\0002\0003\0004\0005\0006\0008\0009\000:\000;\000<\000=\000>\000?\000@\000A\000B\000C\000G\000K\000O\000P\000Q\000R\000S\000T\000U\000V\000W\000X\000Y\000Z\000\\\000^\000_\000`\000a\000b\000c\000d\000e\000l\000m\000n\000p\000q\000r\000s\000t\000u\000v\000w\000x\000y\000z\000{\000|\000}\000~\000\127\000\128\000\129\000\130\000\131\000\132\000\133\000\134\000\135\000\136\000\137\000\143\000\145\000\146\000\147\000\149\000\151\000\152\000\154\000\156\000\158\000\159\000\161\000\163\000\165\000\166\000\167\000\168\000\169\000\170\000\171\000\172\000\173\000\174\000\175\000\176\000\177\000\178\000\179\000\180\000\181\000\182\000\183\000\184\000\185\000\186\000\190\000\191\000\192\000\193\000\195\000\196\000\197\000\203\000\209\000\215\000\216\000\218\000\219\000\222\000\224\000\225\000\226\000\227\000\230\000\231\000\232\000\233\000\234\000\235\000\236\000\237\000\238\000\240\000\241\000\242\000\243\000\246\000\249\000\250\000\252\001\000\001\006\001\b\001\t\001\n\001\012\001\016\001\019\001\021\001\023\001\025\001\026\001\028\001\030\001\031\001 \001#\001$\001'\001(\001+\001,\001-\001.\001/\0011\0012\0013\0014\0015\0016\0017\0018\001:\001;\001=\001>\001?\001@\001C\001D\001E\001F\001G\001H\001I\001J\001N\001O\001R\001S\001T\001U\001W\001X\001Y\001Z\001\\\001]\001^\001_\001a\001b\001c\001e\001f\001g\001h\001i\001k\001l\001n\001o\001q\001s\001t\001u\001v\001x\001y\001{\001|\001\127\001\128\001\129\001\131\001\132\001\133\001\134\001\136\001\137\001\138\001\139\001\141\001\144\001\147\001\149\001\151\001\152\001\153\001\158\001\160\001\161\001\163\001\164\001\165\001\166\001\167\001\168\001\169\001\170\001\171\001\174\001\176\001\177\001\178\001\179\001\180\001\182\001\185\001\186\001\187\001\189\001\193\001\194\001\195\001\196\001\198\001\200\001\202\001\204\001\206\001\207\001\208\001\209\001\210\001\212\001\213\001\214\001\215\001\216\001\218\001\219\001\221\001\222\001\223\001\224\001\225\001\226\001\227\001\229\001\231\001\235\001\236\001\240\001\242\001\243\001\244\001\247\001\252\001\253\001\254\001\255\002\001\002\002\002\003\002\004\002\005\002\007\002\b\002\t\002\n\002\011\002\012\002\r\002\014\002\015\002\016\002\024\002\030\002!\002\"\002#\002$\002%\002&\002'\002(\002)\002*\002+\002,\002-\002.\0020\0021\0022\0026\002:\002>\002@\002B\002D\002E\002G\002H\002J\002K\002M\002N\002O\002P\002Q\002R\002S\002T\002V\002X\002Y\002[\002\\\002]\002`\002b\002c\002d\002e\002f\002g\002h\002k\002l\002m\002n\002o\002p\002q\002r\002t\002u\002v\002w\002x\002z\002|\002}\002\127\002\128\002\129\002\130\002\131\002\134\002\135\002\137\002\138\002\139\002\140\002\142\002\143\002\144\002\145\002\146\002\147\002\148\002\149\002\150\002\151\002\153\002\154\002\156\002\157\002\158\002\160\002\161\002\162\002\169\002\172\002\174\002\176\002\178\002\179\002\180\002\182\002\183\002\184\002\185\002\186\002\187\002\188\002\194\002\198\002\202\002\203\002\204\002\205\002\206\002\207\002\208\002\209\002\210\002\212\002\213\002\214\002\215\002\216\002\217\002\218\002\220\002\222\002\223\002\224\002\225\002\226\002\230\002\231\002\233\002\237\002\238\002\239\002\240\002\241\002\242\002\243\002\244\002\245\002\246\002\247\002\248\002\249\002\250\002\251\002\253\002\254\002\255\003\000\003\001\003\b\003\014\003\017\003\018\003\019\003\020\003\021\003\022\003\023\003\025\003\026\003 \003!\003'\003(\003.\003/\0035\0036\0037\0038\003:\003@\003A\003D\003L\003M\003O\003P\003Q\003R\003S\003T\003W\003^\003_\003`\003b\003c\003i\003o\003u\003v\003x\003y\003z\003{\003\131\003\133\003\134\003\135\003\141\003\145\003\148\003\149\003\150\003\151\003\152\003\153\003\154\003\155\003\161\003\163\003\164\003\166\003\167\003\169\003\170\003\171\003\172\003\174\003\175\003\176\003\177\003\178\003\181\003\183\003\184\003\185\003\192\003\193\003\195\003\196\003\197\003\198\003\199\003\200\003\208\003\209\003\210\003\211\003\212\003\213\003\214\003\219\003\221\003\222\003\223\003\224\003\225\003\226\003\228\003\229\003\230\003\231\003\232\003\233\003\234\003\236\003\237\003\238\003\239\003\240\003\244\003\245\003\247\003\249\003\251\003\253\003\254\003\255\004\001\004\002\004\004\004\006\004\n\004\012\004\014\004\015\004\019\004\020\004\024\004\025\004\028\004\030\004 \004!\004\"\004#\004$\004%\004)\004,\004-\0040\0041\0042\0045\0046\0048\0049\004:\004;\004?\004@\004D\004E\004F\004G\004H\004L\004S\004T\004Y\004Z\004[\004_\004`\004a\004b\004d\004e\004i\004j\004l\004n\004p\004s\004t\004u\004w\004x\004y\004z\004{\004|\004~\004\128\004\130\004\132\004\134\004\136\004\137\004\138\004\139\004\140\004\148\004\149\004\151\004\153\004\155\004\163\004\164\004\165\004\166\004\167\004\169\004\171\004\173\004\180\004\181\004\182\004\183\004\184\004\190\004\191\004\192\004\193\004\194\004\207\004\208\004\221\004\222\004\223\004\226\004\227\004\228\004\229\004\230\004\243\004\250\004\251\004\252\005\020\005\021\005\022\005\023\005\024\005\025\005&\005'\0054\005@\005E\005F\005H\005J\005K\005L\005M\005Q\005R\005V\005W\005Y\005[\005]\005_\005`\005b\005c\005d\005f\005g\005i\005v\005w\005x\005y\005z\005|\005}\005~\005\127\005\129\005\130\005\131\005\158\005\159\005\183\005\184\005\208\005\209\005\233\005\234\006\002\006\003\006\027\006\028\0064\0065\006M\006N\006f\006g\006\127\006\128\006\152\006\153\006\177\006\178\006\202\006\203\006\227\006\228\006\252\006\253\007\021\007\022\007.\007/\007G\007H\007`\007a\007y\007z\007\146\007\147\007\171\007\172\007\196\007\197\007\199\007\212\007\213\007\237\007\240\007\241\007\242\007\243\007\244\007\245\007\246\007\248\007\249\007\251\007\252\007\253\b\003\b\004\b\005\b\006\b\012\b\r\b\019\b\020\b\026\b\027\b\028\b\029\b\030\b \b!\b'\b(\b)\b*\b+\b,\bD\bJ\bK\bL\bN\bO\bP\bQ\bR\bS\bU\bV\bW\bY\bZ\b[\b\\\bv\bx\by\b{\b|\b}\b~\b\127\b\128\b\129\b\130\b\143\b\144\b\145\b\148\b\149\b\151\b\153\b\156\b\157\b\159\b\160\b\163\b\166\b\168\b\169\b\170\b\171\b\172\b\186\b\199\b\201\b\202\b\203\b\216\b\222\b\224\b\226\b\228\b\229\b\253\b\255\t\001\t\003\t\004\t\028\t\030\t \t\"\t#\t;\tI\tK\tM\tO\tP\th\tj\tl\tn\to\t\135\t\137\t\139\t\141\t\142\t\166\t\174\t\180\t\182\t\184\t\186\t\187\t\211\t\213\t\215\t\217\t\218\t\242\t\244\t\246\t\248\t\249\n\017\n\019\n\020\n,\n9\n;\n<\n=\nU\nV\nW\nX\nY\nZ\n[\n\\\n]\nb\ne\nf\ng\nh\ni\nj\nk\nl\nm\nn\no\np\nq\nr\ns\nt\nu\nv\nw\nx\ny\nz\n{\n|\n}\n~\n\127\n\128\n\129\n\130\n\131\n\132\n\133\n\134\n\135\n\136\n\137\n\138\n\139\n\147\n\148\n\149\n\150\n\151\n\154\n\155\n\156\n\157\n\158\n\159\n\160\n\161\n\162\n\163\n\164\n\165\n\166\n\168\n\169\n\170\n\171\n\173\n\174\n\175\n\176\n\178\n\180\n\205\n\206\n\230\n\231\n\232\n\233\n\246\011\014\011\015\011\028\011\029\011\030\0116\0119\011;\011<\011=\011>\011?\011@\011A\011B\011C\011D\011E\011F\011G\011K\011L\011M\011N\011O\011P\011Q\011R\011V\011W\011[\011\\\011`\011a\011b\011c\011d\011e\011f\011g\011h\011i\011j\011k\011l\011m\011n\011o\011p\011q\011r\011s\011t\011u\011v\011w\011x\011y\011z\011{\011|\011}\011~\011\127\011\131\011\132\011\133\011\134\011\136\011\137\011\138\011\140\011\141\011\143\011\144\011\145\011\146\011\147\011\148\011\149\011\150\011\151\011\175\011\176\011\177\011\179\011\180\011\181\011\183\011\210\011\211\011\212\011\216\011\217\011\219\011\224\011\225\011\226\011\230\011\231\011\235\011\239\011\240\011\247\011\248\011\249\011\251\011\252\011\253\011\254\012\000\012\002\012\004\012\006\012\007\012\b\012\t\012\n\012\011\012\012\012\r\012\016\012\018\012\019\012\021\012\022\012\023\012\024\012\025\012\027\012\029\012\031\012 \012!\012\"\012#\012$\012%\012(\012+\012.\0121\0123\0124\0125\0126\0128\0129\012:\012<\012=\012?\012@\012A\012B\012D\012E\012F\012G\012K\012M\012N\012P\012Q\012R\012S\012T\012U\012X\012[\012]\012^\012_\012`\012b\012c\012d\012e\012f\012g\012h\012i\012j\012l\012s\012t\012u\012x\012y\012z\012{\012|\012}\012\129\012\130\012\131\012\133\012\135\012\136\012\137\012\138\012\139\012\140\012\141\012\142\012\143\012\144\012\145\012\146\012\147\012\148\012\149\012\150\012\151\012\152\012\153\012\154\012\158\012\159\012\160\012\161\012\162\012\163\012\164\012\166\012\167\012\169\012\170\012\171\012\172\012\174\012\176\012\178\012\180\012\181\012\182\012\183\012\184\012\185\012\186\012\187\012\189\012\190\012\192\012\193\012\194\012\195\012\198\012\199\012\200\012\201\012\204\012\205\012\211\012\213\012\215\012\217\012\219\012\220\012\224\012\225\012\229\012\233\012\235\012\236\012\239\012\240\012\241\012\242\012\243\012\247\012\248\012\249\012\250\012\251\012\252\r\000\r\001\r\002\r\003\r\005\r\006\r\b\r\t\r\n\r\014\r\015\r\016\r\017\r\018\r\019\r\020\r\021\r\025\r\026\r\027\r\028\r\029\r\030\r \r!\r\"\r#\r$\r%\r&\r(\r)\r*\r+\r,\r-\r.\r/\r1\r2\r3\r4\r5\r7\r8\r:\r;\r<\r=\r>\r@\rA\rB\rC\rE\rF\rH\rI\rJ\rK\rL\rM\rN\rO\rP\rR\rT\rU\rV\rX\rY\rZ\r\\\r]\r^\r_\ra\rc\rd\re\rg\rh\ri\rk\rl\rn\rp\rq\rr\rs\ru\rv\rx\ry\rz\r{\r|\r}\r~\r\127\r\128\r\129\r\131\r\132\r\133\r\134\r\135\r\136\r\137\r\138\r\140\r\141\r\142\r\143\r\144\r\145\r\146\r\147\r\148\r\149\r\151\r\152\r\153\r\154\r\158\r\161\r\162\r\163\r\164\r\165\r\166\r\168\r\170\r\171\r\173\r\174\r\175\r\176\r\177\r\178\r\179\r\180\r\181\r\182\r\183\r\184\r\185\r\186\r\187\r\188\r\189\r\190\r\191\r\192\r\193\r\194\r\195\r\196\r\197\r\198\r\199\r\200\r\201\r\202\r\203\r\204\r\206\r\207\r\208\r\209\r\210\r\211\r\212\r\213\r\214\r\215\r\216\r\218\r\219\r\220\r\221\r\222\r\223\r\224\r\225\r\226\r\228\r\230\r\231\r\232\r\233\r\234\r\235\r\236\r\237\r\238\r\239\r\240\r\241\r\242\r\243\r\245\r\246\r\247\r\249\r\253\r\254\r\255\014\000\014\001\014\002\014\003\014\005\014\006\014\007\014\t\014\n\014\011\014\r\014\014\014\015\014\016\014\017\014\019\014\020\014\022\014\023\014\024\014\026\014\028\014\029\014\031\014 \014!\014#\014$\014%\014'\014(\014*\014+\014-\014.\014/\0140\0141\0144\0145\0146\0147\0148\014:\014;\014<\014=\014>\014?\014A\014B\014C\014D\014E\014F\014G\014H\014I\014J\014K\014L\014M\014N\014P\014Q\014R\014S\014U\014V\014W\014X\014Y\014Z\014[\014\\\014]\014^\014_\014`\014a\014b\014c\014d\014e\014f\014g\014h\014i\014j\014l\014m\014o\014p\014q\014r\014s\014t\014u\014v\014w\014x\014y\014z\014{\014~\014\127\014\130\014\131\014\132\014\133\014\134\014\135\014\136\014\140\014\141\014\142\014\143\014\147\014\148\014\149\014\150\014\151\014\152\014\153\014\154\014\155\014\156\014\157\014\158\014\160\014\161\014\162\014\163\014\164\014\167\014\170\014\171\014\172\014\174\014\175\014\176\014\177\014\178\014\180\014\181\014\182\014\183\014\187\014\188\014\190\014\191\014\192\014\193\014\206\014\208\014\210\014\212\014\217\014\218\014\219\014\223\014\224\014\226\014\227\014\228\014\229\014\230\014\231\014\233\014\237\014\239\014\242\014\243\014\244\014\245\014\246\014\247\014\248\014\249\014\250\014\251\014\252\014\253\014\254\014\255\015\000\015\001\015\002\015\003\015\004\015\005\015\006\015\007\015\b\015\t\015\012\015\r\015\014\015\015\015\016\015\021\015\025\015\027\015\028\015\029\015\030\015\031\015 \015!\015\"\015#\015$\015%\015&\015'\015(\015)\015*\015,\015-\015.\015/\0150\0151\0152\0153\0156\0157\0158\0159\015;\015<\015=\015>\015?\015@\015A\015G\015H\015I\015J\015K\015L\015M\015O\015Q\015R\015Y\015`\015a\015b\015c\015d\015e\015h\015i\015j\015k\015l\015m\015n\015o\015p\015q\015r\015s\015t\015v\015w\015x\015y\015z\015{\015|\015}\015~\015\127\015\128\015\129\015\130\015\131\015\132\015\133"))
+    
+    and nullable =
+      "\000\000@\164\004\001\000\000\0048@\000\031\248\012\000\000\003\255\248\000\004\b!\000\000\192\000"
+    
+    and first =
+      (133, "3\248H1b\171\1273=\001P}\200\160\001\199\001\159\194A\139\021[\249\153\232\n\131\238E\000\0148\000 \000\000\000\000\006\000\000\000\000\000\000\000\000\000\000\003\016\128 @\0020$Z\000 \n\128\000\001\004\000\b\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0067\b\002,\020o\226G\160\b\015\160\020\000\024\224\001\128\000\028\004\000\024\\ \000\016\000\000\000\000\000\000\004@\000\000\000\000\128\001\000\000\000\b\000\000\000\000\000\"\000\000\000\000\006\000\b\000\000\000@\000\000\000\000\004\128\016@\004\016\000B\000\002\000\001\144\000\002\000\003?\132\131\022*\183\2433\208\020\007\220\138\000\028p\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\001\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\128\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000 \016\000\128\000\000\000\000\000\000\b\000\b\000\000\000\000\001\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\006\127\t\006,Uo\230g\160*\015\185\020\0008\224\000\000\000\001 \001\000\000\000\b\000\000\000\000\000\004\000\b\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\002H\000D\000\000\002\000\000\000\000\000\001\000\002\000\000\018@\002\000\000\000\016\000\000\000\000\000\b\000\b\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000H\000\0000\000\003\000\000\003\011\132\000\002\000\000\000\000\000\0003\248H1b\171\1273=\001P}\200\160\001\199\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\006\000\000\000\000\000\000\000\000\000\000\000$\000\002\000 \128R\016\000\016\000\012\000\000\016\000\025\252$\024\177U\191\153\158\128\160>\224P\000\227\128\006)\000P\144\004`H\172\000@\020\128\000\002\b\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000^\221\145\002\011\248\169\000\004\193\192\233\199\005\129A\160\012B\000\129\000\b\128\145H\000\128(\000\000\004\016\000b\016\004\b\000F\004\138@\004\001@\000\000 \128\003\016\128\"\000@0$r\000\000\n\001@\001\140\000\000\000\000\000\000\000\000\"\128\000\000\000\000\000\000\000\000\000 \000\016\000\128\000\000\128\000\002\000\000\000@\000\t\000\000\128\b \000\132\000\004\000\003\000\000\004\000\000H\001\004\000A\000\004 \000 \000\024\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\001\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\000 \000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\003\016\128 @\0020$Z\000 \n\128\000\001\004\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\024\220 \b\176Q\191\137\030\128 >\128P\000c\128\006\000\000p\016\000ap\128\000@\000\000\000\000\b\0000\000\003\000\000\003\011\132\000\002\000\000\000\000\000\0001\184@\017`\163\127\018=\000@}\000\160\000\199\000\012\000\000\224 \000\194\225\000\000\128\000\000\000\000\000\000`\000\006\000\000\006\023\b\000\004\000\000\000\000\000\000\002\000\000\018@\002\000\000\000\016\000\000\000\000\000\b\000\024\000\001\192@\001\133\194\000\001\000\000\000\000\000\000\000\192\000\014\002\000\012.\016\000\b\000\000\000\000\001\000\001\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\0000\000\003\128\128\003\011\132\000\002\000\000\000\000\000\000\001\136@\016 \001\024\018-\000\016\005@\000\000\138\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\003\020\128*\b@0$v\000\000\n\001@\001\140\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\002 \000\000\000\000@\000\128\000\000\004\000\000\000 \000\017\000\000\000\000\002\000\004\000\000\000 \000\000\001\000\000\136\000\000\000\000\016\000 \000\000\001\000\000\000\b\000\012B\000\136\001\000\192\145\200\000\000(\005\000\0060\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\0000\000\003\128\128\003\011\132\000\002\000\000\000\000\000\000\001\128\000\028\004\000\024\\ \000\016\000\000\000\000\000\001\159\194A\171\021[\249\153\232\n\003\238\005\000\0308\000@\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\003\016\128 @\0020$Z\000 \n\000\000\001\004\000\024\132\001\002\000\017\129\"\208\001\000P\000\000\b \000\196 \b\016\000\140\t\022\128\b\002\128\000\000A\000\006!\000@\128\004`H\180\000@\021\000\000\002\b\0001\b\002\004\000#\002E\160\002\000\168\000\000\016@\000\128\000\000\000\000\024\000\000\000\000\000\000\000\000\000\000\012B\000\129\000\b\192\145h\000\128*\000\000\004\016\000 \000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\024\220 \b\176Q\191\137\030\128 >\128P\000c\128\006\000\000p\016\000ap\128\000@\000\000\000\000\000\000\017\000\000\000\000\002\000\004\000\000\000 \000\000\000\000\000\136\000\000\000\000\024\000 \000\000\001\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000$\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\016\000\252\001\129 \000\031\016\128\016 \004\n,\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\001\136\000\030\004\000\024\\(\000\016\001\000\016\000\b\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000@\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\004\000\128\128\000@\192\128\000\000\004\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\003\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\024\b\001\000\000\001\001\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000@\000\000\000\000\000\128\000\b\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\192\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\012\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\004\000\000\002\000\000\b\000@\000\000\000\000\000\000\004\000\012\000\000\192\000\000\194\225\000\000\128\000\000\128\000\000\000b\016\004\b\000F\004\139@\004\001P\000\000 \128\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\t\000 \128\b \020\132\000\004@\003\000\000\004\000\000H\000\004\000A\000\164 \000 \000\024\000\000 \000\002\000\000 \000\000\128!\000\192\000\000\000\000\128\000\000\016\000\001\000\000\004\001\b\002\000\000\000\000\004\000\000\000\144\002\b\000\130\001H@\000@\0000\000\000@\000\004\128\016@\004\016\000B\000\002\000\001\128\000\002\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\196 \b\016\000\140\t\022\128\b\002\128\000\000A\000\006!\000@\128\004`H\180\000@\020\000\000\002\b\0001\b\002\004\000#\002E\160\002\000\168\000\000\016@\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000b\016\004\b\000F\004\139@\004\001@\000\000 \128\003\016\128 @\0020$Z\000 \n\000\000\001\004\000\024\164\001B@\017\129\"\176\001\000P\000\000\b \000\197 \n\130\016\012\t\029\128\000\002\128P\000c\000\002\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\002\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000@\000\000\000\000\000\000\000\000\000$\000\130\000 \128\002\016\000\016\000\012\128\000\016\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\207\225 \197\138\173\252\204\244\005\001\247\"\128\007\028\000\016\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\"\000\000\000\000\004\000\b\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000 \000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\0000\000\003\128\128\003\011\132\000\002\000\000\000\000\000\000\001\138@\020$\005\024\018+\000\016\005\000\000\002\130\000\012R\000\161 \b\192\145X\000\128)\000\000\148\016\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\b\128\000\000\000\001\000\002\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000@\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\0001\184@\017`\163\127\018=\000@}\000\160\000\199\000\000 \000\000\000\000\000\000\000\000\000\000\b\000\000\000\000`\000\007\001\000\006\023\b\000\004\000\000\000\000\000\000\001\016\000\000\000\000 \000@\000\000\002\000\000\000\016\000\024\000\001\128\000\001\133\194\128\001\000\000\000\000\000\000\000\192\000\014\002\000\012.\016\000\b\000\000\000\000\000\000\002 \000\000\000\000@\000\128\000\000\004\000\000\000\000\000\017\000\000\000\000\002\000\004\000\000\000 \000\000\000\000\000\b\000\000\000\000\016\000 \000\000\001\000\000\000\000\000\000\002\000\000\000\000\000\000\b\000\000 \000\000\004\000\000 \000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\024\000\001\192H\001\149\194\000\001\000\000\000\000\000\000\000@\000\000\000@\012\000\016\000\000\000\000\000\000\000\000\002\000\000@\002\000$@\128\000\000\000\000\000\000\000\000@\000\004\000\000\016\004 \b\000\000\000\000\016\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\003\020\128(H\0020$V\000 \n\000\000\001\004\000\024\164\001B@\017\129\"\176\001\000R\000\000( \001\000\000\016\000\000@\016\128`\000\000\000\000@\000\000\002\000\000@\002\000d@\128\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000^\221\145\002\011\248\169\000\004\193\192\233\199\005\129A\160\012\000\000\192\000\000\194\225\000\000\128\000\000\000\000\000\000\"\000\000\000\000\006\000\b\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\024\000\001\192@\001\133\194\000\001\000\000\000\000\000\000\000\000\000\0000\000\000\000\000\000\000\000\000\000\000\000\000")
+    
+  end) (ET) (TI)
+  
+end
+
+let use_file =
+  fun lexer lexbuf ->
+    (Obj.magic (MenhirInterpreter.entry `Legacy 1826 lexer lexbuf) : (Parsetree.toplevel_phrase list))
+
+and toplevel_phrase =
+  fun lexer lexbuf ->
+    (Obj.magic (MenhirInterpreter.entry `Legacy 1806 lexer lexbuf) : (Parsetree.toplevel_phrase))
+
+and parse_val_longident =
+  fun lexer lexbuf ->
+    (Obj.magic (MenhirInterpreter.entry `Legacy 1800 lexer lexbuf) : (Longident.t))
+
+and parse_pattern =
+  fun lexer lexbuf ->
+    (Obj.magic (MenhirInterpreter.entry `Legacy 1796 lexer lexbuf) : (Parsetree.pattern))
+
+and parse_mty_longident =
+  fun lexer lexbuf ->
+    (Obj.magic (MenhirInterpreter.entry `Legacy 1792 lexer lexbuf) : (Longident.t))
+
+and parse_mod_longident =
+  fun lexer lexbuf ->
+    (Obj.magic (MenhirInterpreter.entry `Legacy 1788 lexer lexbuf) : (Longident.t))
+
+and parse_mod_ext_longident =
+  fun lexer lexbuf ->
+    (Obj.magic (MenhirInterpreter.entry `Legacy 1784 lexer lexbuf) : (Longident.t))
+
+and parse_expression =
+  fun lexer lexbuf ->
+    (Obj.magic (MenhirInterpreter.entry `Legacy 1780 lexer lexbuf) : (Parsetree.expression))
+
+and parse_core_type =
+  fun lexer lexbuf ->
+    (Obj.magic (MenhirInterpreter.entry `Legacy 1776 lexer lexbuf) : (Parsetree.core_type))
+
+and parse_constr_longident =
+  fun lexer lexbuf ->
+    (Obj.magic (MenhirInterpreter.entry `Legacy 1772 lexer lexbuf) : (Longident.t))
+
+and parse_any_longident =
+  fun lexer lexbuf ->
+    (Obj.magic (MenhirInterpreter.entry `Legacy 1754 lexer lexbuf) : (Longident.t))
+
+and interface =
+  fun lexer lexbuf ->
+    (Obj.magic (MenhirInterpreter.entry `Legacy 1750 lexer lexbuf) : (Parsetree.signature))
+
+and implementation =
+  fun lexer lexbuf ->
+    (Obj.magic (MenhirInterpreter.entry `Legacy 0 lexer lexbuf) : (Parsetree.structure))
+
+module Incremental = struct
+  
+  let use_file =
+    fun initial_position ->
+      (Obj.magic (MenhirInterpreter.start 1826 initial_position) : (Parsetree.toplevel_phrase list) MenhirInterpreter.checkpoint)
+  
+  and toplevel_phrase =
+    fun initial_position ->
+      (Obj.magic (MenhirInterpreter.start 1806 initial_position) : (Parsetree.toplevel_phrase) MenhirInterpreter.checkpoint)
+  
+  and parse_val_longident =
+    fun initial_position ->
+      (Obj.magic (MenhirInterpreter.start 1800 initial_position) : (Longident.t) MenhirInterpreter.checkpoint)
+  
+  and parse_pattern =
+    fun initial_position ->
+      (Obj.magic (MenhirInterpreter.start 1796 initial_position) : (Parsetree.pattern) MenhirInterpreter.checkpoint)
+  
+  and parse_mty_longident =
+    fun initial_position ->
+      (Obj.magic (MenhirInterpreter.start 1792 initial_position) : (Longident.t) MenhirInterpreter.checkpoint)
+  
+  and parse_mod_longident =
+    fun initial_position ->
+      (Obj.magic (MenhirInterpreter.start 1788 initial_position) : (Longident.t) MenhirInterpreter.checkpoint)
+  
+  and parse_mod_ext_longident =
+    fun initial_position ->
+      (Obj.magic (MenhirInterpreter.start 1784 initial_position) : (Longident.t) MenhirInterpreter.checkpoint)
+  
+  and parse_expression =
+    fun initial_position ->
+      (Obj.magic (MenhirInterpreter.start 1780 initial_position) : (Parsetree.expression) MenhirInterpreter.checkpoint)
+  
+  and parse_core_type =
+    fun initial_position ->
+      (Obj.magic (MenhirInterpreter.start 1776 initial_position) : (Parsetree.core_type) MenhirInterpreter.checkpoint)
+  
+  and parse_constr_longident =
+    fun initial_position ->
+      (Obj.magic (MenhirInterpreter.start 1772 initial_position) : (Longident.t) MenhirInterpreter.checkpoint)
+  
+  and parse_any_longident =
+    fun initial_position ->
+      (Obj.magic (MenhirInterpreter.start 1754 initial_position) : (Longident.t) MenhirInterpreter.checkpoint)
+  
+  and interface =
+    fun initial_position ->
+      (Obj.magic (MenhirInterpreter.start 1750 initial_position) : (Parsetree.signature) MenhirInterpreter.checkpoint)
+  
+  and implementation =
+    fun initial_position ->
+      (Obj.magic (MenhirInterpreter.start 0 initial_position) : (Parsetree.structure) MenhirInterpreter.checkpoint)
+  
+end
+
+# 4092 "src/ocaml/preprocess/parser_raw.mly"
+  
+
+# 46061 "src/ocaml/preprocess/parser_raw.ml"
+
+# 269 "<standard.mly>"
+  
+
+# 46066 "src/ocaml/preprocess/parser_raw.ml"
diff --git a/src/ocaml/preprocess/parser_raw.mli b/src/ocaml/preprocess/parser_raw.mli
new file mode 100644
index 0000000..bf1248a
--- /dev/null
+++ b/src/ocaml/preprocess/parser_raw.mli
@@ -0,0 +1,577 @@
+
+(* The type of tokens. *)
+
+type token = 
+  | WITH
+  | WHILE_LWT
+  | WHILE
+  | WHEN
+  | VIRTUAL
+  | VAL
+  | UNDERSCORE
+  | UIDENT of (string)
+  | TYPE
+  | TRY_LWT
+  | TRY
+  | TRUE
+  | TO
+  | TILDE
+  | THEN
+  | STRUCT
+  | STRING of (string * Location.t * string option)
+  | STAR
+  | SIG
+  | SEMISEMI
+  | SEMI
+  | RPAREN
+  | REC
+  | RBRACKET
+  | RBRACE
+  | QUOTED_STRING_ITEM of (string * Location.t * string * Location.t * string option)
+  | QUOTED_STRING_EXPR of (string * Location.t * string * Location.t * string option)
+  | QUOTE
+  | QUESTION
+  | PRIVATE
+  | PREFIXOP of (string)
+  | PLUSEQ
+  | PLUSDOT
+  | PLUS
+  | PERCENT
+  | OR
+  | OPTLABEL of (string)
+  | OPEN
+  | OF
+  | OBJECT
+  | NONREC
+  | NEW
+  | MUTABLE
+  | MODULE
+  | MINUSGREATER
+  | MINUSDOT
+  | MINUS
+  | METHOD
+  | MATCH_LWT
+  | MATCH
+  | LPAREN
+  | LIDENT of (string)
+  | LET_LWT
+  | LETOP of (string)
+  | LET
+  | LESSMINUS
+  | LESS
+  | LBRACKETPERCENTPERCENT
+  | LBRACKETPERCENT
+  | LBRACKETLESS
+  | LBRACKETGREATER
+  | LBRACKETBAR
+  | LBRACKETATATAT
+  | LBRACKETATAT
+  | LBRACKETAT
+  | LBRACKET
+  | LBRACELESS
+  | LBRACE
+  | LAZY
+  | LABEL of (string)
+  | INT of (string * char option)
+  | INITIALIZER
+  | INHERIT
+  | INFIXOP4 of (string)
+  | INFIXOP3 of (string)
+  | INFIXOP2 of (string)
+  | INFIXOP1 of (string)
+  | INFIXOP0 of (string)
+  | INCLUDE
+  | IN
+  | IF
+  | HASHOP of (string)
+  | HASH
+  | GREATERRBRACKET
+  | GREATERRBRACE
+  | GREATERDOT
+  | GREATER
+  | FUNCTOR
+  | FUNCTION
+  | FUN
+  | FOR_LWT
+  | FOR
+  | FLOAT of (string * char option)
+  | FINALLY_LWT
+  | FALSE
+  | EXTERNAL
+  | EXCEPTION
+  | EQUAL
+  | EOL
+  | EOF
+  | END
+  | ELSE
+  | DOWNTO
+  | DOTTILDE
+  | DOTOP of (string)
+  | DOTLESS
+  | DOTDOT
+  | DOT
+  | DONE
+  | DOCSTRING of (Docstrings.docstring)
+  | DO
+  | CONSTRAINT
+  | COMMENT of (string * Location.t)
+  | COMMA
+  | COLONGREATER
+  | COLONEQUAL
+  | COLONCOLON
+  | COLON
+  | CLASS
+  | CHAR of (char)
+  | BEGIN
+  | BARRBRACKET
+  | BARBAR
+  | BAR
+  | BANG
+  | BACKQUOTE
+  | ASSERT
+  | AS
+  | ANDOP of (string)
+  | AND
+  | AMPERSAND
+  | AMPERAMPER
+
+(* This exception is raised by the monolithic API functions. *)
+
+exception Error
+
+(* The monolithic API. *)
+
+val use_file: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Parsetree.toplevel_phrase list)
+
+val toplevel_phrase: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Parsetree.toplevel_phrase)
+
+val parse_val_longident: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Longident.t)
+
+val parse_pattern: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Parsetree.pattern)
+
+val parse_mty_longident: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Longident.t)
+
+val parse_mod_longident: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Longident.t)
+
+val parse_mod_ext_longident: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Longident.t)
+
+val parse_expression: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Parsetree.expression)
+
+val parse_core_type: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Parsetree.core_type)
+
+val parse_constr_longident: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Longident.t)
+
+val parse_any_longident: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Longident.t)
+
+val interface: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Parsetree.signature)
+
+val implementation: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Parsetree.structure)
+
+module MenhirInterpreter : sig
+  
+  (* The incremental API. *)
+  
+  include MenhirLib.IncrementalEngine.INCREMENTAL_ENGINE
+    with type token = token
+  
+  (* The indexed type of terminal symbols. *)
+  
+  type _ terminal = 
+    | T_error : unit terminal
+    | T_WITH : unit terminal
+    | T_WHILE_LWT : unit terminal
+    | T_WHILE : unit terminal
+    | T_WHEN : unit terminal
+    | T_VIRTUAL : unit terminal
+    | T_VAL : unit terminal
+    | T_UNDERSCORE : unit terminal
+    | T_UIDENT : (string) terminal
+    | T_TYPE : unit terminal
+    | T_TRY_LWT : unit terminal
+    | T_TRY : unit terminal
+    | T_TRUE : unit terminal
+    | T_TO : unit terminal
+    | T_TILDE : unit terminal
+    | T_THEN : unit terminal
+    | T_STRUCT : unit terminal
+    | T_STRING : (string * Location.t * string option) terminal
+    | T_STAR : unit terminal
+    | T_SIG : unit terminal
+    | T_SEMISEMI : unit terminal
+    | T_SEMI : unit terminal
+    | T_RPAREN : unit terminal
+    | T_REC : unit terminal
+    | T_RBRACKET : unit terminal
+    | T_RBRACE : unit terminal
+    | T_QUOTED_STRING_ITEM : (string * Location.t * string * Location.t * string option) terminal
+    | T_QUOTED_STRING_EXPR : (string * Location.t * string * Location.t * string option) terminal
+    | T_QUOTE : unit terminal
+    | T_QUESTION : unit terminal
+    | T_PRIVATE : unit terminal
+    | T_PREFIXOP : (string) terminal
+    | T_PLUSEQ : unit terminal
+    | T_PLUSDOT : unit terminal
+    | T_PLUS : unit terminal
+    | T_PERCENT : unit terminal
+    | T_OR : unit terminal
+    | T_OPTLABEL : (string) terminal
+    | T_OPEN : unit terminal
+    | T_OF : unit terminal
+    | T_OBJECT : unit terminal
+    | T_NONREC : unit terminal
+    | T_NEW : unit terminal
+    | T_MUTABLE : unit terminal
+    | T_MODULE : unit terminal
+    | T_MINUSGREATER : unit terminal
+    | T_MINUSDOT : unit terminal
+    | T_MINUS : unit terminal
+    | T_METHOD : unit terminal
+    | T_MATCH_LWT : unit terminal
+    | T_MATCH : unit terminal
+    | T_LPAREN : unit terminal
+    | T_LIDENT : (string) terminal
+    | T_LET_LWT : unit terminal
+    | T_LETOP : (string) terminal
+    | T_LET : unit terminal
+    | T_LESSMINUS : unit terminal
+    | T_LESS : unit terminal
+    | T_LBRACKETPERCENTPERCENT : unit terminal
+    | T_LBRACKETPERCENT : unit terminal
+    | T_LBRACKETLESS : unit terminal
+    | T_LBRACKETGREATER : unit terminal
+    | T_LBRACKETBAR : unit terminal
+    | T_LBRACKETATATAT : unit terminal
+    | T_LBRACKETATAT : unit terminal
+    | T_LBRACKETAT : unit terminal
+    | T_LBRACKET : unit terminal
+    | T_LBRACELESS : unit terminal
+    | T_LBRACE : unit terminal
+    | T_LAZY : unit terminal
+    | T_LABEL : (string) terminal
+    | T_INT : (string * char option) terminal
+    | T_INITIALIZER : unit terminal
+    | T_INHERIT : unit terminal
+    | T_INFIXOP4 : (string) terminal
+    | T_INFIXOP3 : (string) terminal
+    | T_INFIXOP2 : (string) terminal
+    | T_INFIXOP1 : (string) terminal
+    | T_INFIXOP0 : (string) terminal
+    | T_INCLUDE : unit terminal
+    | T_IN : unit terminal
+    | T_IF : unit terminal
+    | T_HASHOP : (string) terminal
+    | T_HASH : unit terminal
+    | T_GREATERRBRACKET : unit terminal
+    | T_GREATERRBRACE : unit terminal
+    | T_GREATERDOT : unit terminal
+    | T_GREATER : unit terminal
+    | T_FUNCTOR : unit terminal
+    | T_FUNCTION : unit terminal
+    | T_FUN : unit terminal
+    | T_FOR_LWT : unit terminal
+    | T_FOR : unit terminal
+    | T_FLOAT : (string * char option) terminal
+    | T_FINALLY_LWT : unit terminal
+    | T_FALSE : unit terminal
+    | T_EXTERNAL : unit terminal
+    | T_EXCEPTION : unit terminal
+    | T_EQUAL : unit terminal
+    | T_EOL : unit terminal
+    | T_EOF : unit terminal
+    | T_END : unit terminal
+    | T_ELSE : unit terminal
+    | T_DOWNTO : unit terminal
+    | T_DOTTILDE : unit terminal
+    | T_DOTOP : (string) terminal
+    | T_DOTLESS : unit terminal
+    | T_DOTDOT : unit terminal
+    | T_DOT : unit terminal
+    | T_DONE : unit terminal
+    | T_DOCSTRING : (Docstrings.docstring) terminal
+    | T_DO : unit terminal
+    | T_CONSTRAINT : unit terminal
+    | T_COMMENT : (string * Location.t) terminal
+    | T_COMMA : unit terminal
+    | T_COLONGREATER : unit terminal
+    | T_COLONEQUAL : unit terminal
+    | T_COLONCOLON : unit terminal
+    | T_COLON : unit terminal
+    | T_CLASS : unit terminal
+    | T_CHAR : (char) terminal
+    | T_BEGIN : unit terminal
+    | T_BARRBRACKET : unit terminal
+    | T_BARBAR : unit terminal
+    | T_BAR : unit terminal
+    | T_BANG : unit terminal
+    | T_BACKQUOTE : unit terminal
+    | T_ASSERT : unit terminal
+    | T_AS : unit terminal
+    | T_ANDOP : (string) terminal
+    | T_AND : unit terminal
+    | T_AMPERSAND : unit terminal
+    | T_AMPERAMPER : unit terminal
+  
+  (* The indexed type of nonterminal symbols. *)
+  
+  type _ nonterminal = 
+    | N_with_type_binder : (Asttypes.private_flag) nonterminal
+    | N_with_constraint : (Parsetree.with_constraint) nonterminal
+    | N_virtual_with_private_flag : (Asttypes.private_flag) nonterminal
+    | N_virtual_with_mutable_flag : (Asttypes.mutable_flag) nonterminal
+    | N_virtual_flag : (Asttypes.virtual_flag) nonterminal
+    | N_value_description : (Parsetree.value_description * string Location.loc option) nonterminal
+    | N_value : ((string Location.loc * Asttypes.mutable_flag * Parsetree.class_field_kind) *
+  Parsetree.attributes) nonterminal
+    | N_val_longident : (Longident.t) nonterminal
+    | N_val_ident : (string) nonterminal
+    | N_val_extra_ident : (string) nonterminal
+    | N_use_file : (Parsetree.toplevel_phrase list) nonterminal
+    | N_type_variance : (Asttypes.variance * Asttypes.injectivity) nonterminal
+    | N_type_variable : (Parsetree.core_type) nonterminal
+    | N_type_parameters : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) nonterminal
+    | N_type_parameter : (Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) nonterminal
+    | N_type_longident : (Longident.t) nonterminal
+    | N_type_kind : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) nonterminal
+    | N_type_constraint : (Parsetree.core_type option * Parsetree.core_type option) nonterminal
+    | N_tuple_type : (Parsetree.core_type) nonterminal
+    | N_toplevel_phrase : (Parsetree.toplevel_phrase) nonterminal
+    | N_toplevel_directive : (Parsetree.toplevel_phrase) nonterminal
+    | N_tag_field : (Parsetree.row_field) nonterminal
+    | N_subtractive : (string) nonterminal
+    | N_structure_item : (Parsetree.structure_item) nonterminal
+    | N_structure : (Parsetree.structure) nonterminal
+    | N_strict_binding : (Parsetree.expression) nonterminal
+    | N_str_exception_declaration : (Parsetree.type_exception * string Location.loc option) nonterminal
+    | N_single_attr_id : (string) nonterminal
+    | N_simple_pattern_not_ident : (Parsetree.pattern) nonterminal
+    | N_simple_pattern : (Parsetree.pattern) nonterminal
+    | N_simple_expr : (Parsetree.expression) nonterminal
+    | N_simple_delimited_pattern : (Parsetree.pattern) nonterminal
+    | N_signed_constant : (Parsetree.constant) nonterminal
+    | N_signature_item : (Parsetree.signature_item) nonterminal
+    | N_signature : (Parsetree.signature) nonterminal
+    | N_sig_exception_declaration : (Parsetree.type_exception * string Location.loc option) nonterminal
+    | N_seq_expr : (Parsetree.expression) nonterminal
+    | N_separated_or_terminated_nonempty_list_SEMI_record_expr_field_ : ((Longident.t Location.loc * Parsetree.expression) list) nonterminal
+    | N_separated_or_terminated_nonempty_list_SEMI_pattern_ : (Parsetree.pattern list) nonterminal
+    | N_separated_or_terminated_nonempty_list_SEMI_object_expr_field_ : ((string Location.loc * Parsetree.expression) list) nonterminal
+    | N_separated_or_terminated_nonempty_list_SEMI_expr_ : (Parsetree.expression list) nonterminal
+    | N_row_field : (Parsetree.row_field) nonterminal
+    | N_reversed_separated_nontrivial_llist_STAR_atomic_type_ : (Parsetree.core_type list) nonterminal
+    | N_reversed_separated_nontrivial_llist_COMMA_expr_ : (Parsetree.expression list) nonterminal
+    | N_reversed_separated_nontrivial_llist_COMMA_core_type_ : (Parsetree.core_type list) nonterminal
+    | N_reversed_separated_nonempty_llist_STAR_atomic_type_ : (Parsetree.core_type list) nonterminal
+    | N_reversed_separated_nonempty_llist_COMMA_type_parameter_ : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) nonterminal
+    | N_reversed_separated_nonempty_llist_COMMA_core_type_ : (Parsetree.core_type list) nonterminal
+    | N_reversed_separated_nonempty_llist_BAR_row_field_ : (Parsetree.row_field list) nonterminal
+    | N_reversed_separated_nonempty_llist_AND_with_constraint_ : (Parsetree.with_constraint list) nonterminal
+    | N_reversed_separated_nonempty_llist_AMPERSAND_core_type_no_attr_ : (Parsetree.core_type list) nonterminal
+    | N_reversed_preceded_or_separated_nonempty_llist_BAR_match_case_ : (Parsetree.case list) nonterminal
+    | N_reversed_nonempty_llist_typevar_ : (string Location.loc list) nonterminal
+    | N_reversed_nonempty_llist_name_tag_ : (string list) nonterminal
+    | N_reversed_nonempty_llist_labeled_simple_expr_ : ((Asttypes.arg_label * Parsetree.expression) list) nonterminal
+    | N_reversed_nonempty_llist_functor_arg_ : ((Lexing.position * Parsetree.functor_parameter) list) nonterminal
+    | N_reversed_llist_preceded_CONSTRAINT_constrain__ : ((Parsetree.core_type * Parsetree.core_type * Location.t) list) nonterminal
+    | N_reversed_bar_llist_extension_constructor_declaration_ : (Parsetree.extension_constructor list) nonterminal
+    | N_reversed_bar_llist_extension_constructor_ : (Parsetree.extension_constructor list) nonterminal
+    | N_reversed_bar_llist_constructor_declaration_ : (Parsetree.constructor_declaration list) nonterminal
+    | N_record_expr_content : (Parsetree.expression option *
+  (Longident.t Location.loc * Parsetree.expression) list) nonterminal
+    | N_rec_flag : (Asttypes.rec_flag) nonterminal
+    | N_private_virtual_flags : (Asttypes.private_flag * Asttypes.virtual_flag) nonterminal
+    | N_private_flag : (Asttypes.private_flag) nonterminal
+    | N_primitive_declaration : (Parsetree.value_description * string Location.loc option) nonterminal
+    | N_post_item_attribute : (Parsetree.attribute) nonterminal
+    | N_possibly_poly_core_type_no_attr_ : (Parsetree.core_type) nonterminal
+    | N_possibly_poly_core_type_ : (Parsetree.core_type) nonterminal
+    | N_payload : (Parsetree.payload) nonterminal
+    | N_pattern_var : (Parsetree.pattern) nonterminal
+    | N_pattern_no_exn : (Parsetree.pattern) nonterminal
+    | N_pattern_gen : (Parsetree.pattern) nonterminal
+    | N_pattern_comma_list_pattern_no_exn_ : (Parsetree.pattern list) nonterminal
+    | N_pattern_comma_list_pattern_ : (Parsetree.pattern list) nonterminal
+    | N_pattern : (Parsetree.pattern) nonterminal
+    | N_parse_val_longident : (Longident.t) nonterminal
+    | N_parse_pattern : (Parsetree.pattern) nonterminal
+    | N_parse_mty_longident : (Longident.t) nonterminal
+    | N_parse_mod_longident : (Longident.t) nonterminal
+    | N_parse_mod_ext_longident : (Longident.t) nonterminal
+    | N_parse_expression : (Parsetree.expression) nonterminal
+    | N_parse_core_type : (Parsetree.core_type) nonterminal
+    | N_parse_constr_longident : (Longident.t) nonterminal
+    | N_parse_any_longident : (Longident.t) nonterminal
+    | N_paren_module_expr : (Parsetree.module_expr) nonterminal
+    | N_optlabel : (string) nonterminal
+    | N_option_type_constraint_ : ((Parsetree.core_type option * Parsetree.core_type option) option) nonterminal
+    | N_option_preceded_EQUAL_seq_expr__ : (Parsetree.expression option) nonterminal
+    | N_option_preceded_EQUAL_pattern__ : (Parsetree.pattern option) nonterminal
+    | N_option_preceded_EQUAL_module_type__ : (Parsetree.module_type option) nonterminal
+    | N_option_preceded_EQUAL_expr__ : (Parsetree.expression option) nonterminal
+    | N_option_preceded_COLON_core_type__ : (Parsetree.core_type option) nonterminal
+    | N_option_preceded_AS_mkrhs_LIDENT___ : (string Location.loc option) nonterminal
+    | N_option_SEMI_ : (unit option) nonterminal
+    | N_option_BAR_ : (unit option) nonterminal
+    | N_opt_ampersand : (bool) nonterminal
+    | N_operator : (string) nonterminal
+    | N_open_description : (Longident.t Location.loc Parsetree.open_infos * string Location.loc option) nonterminal
+    | N_open_declaration : (Parsetree.module_expr Parsetree.open_infos * string Location.loc option) nonterminal
+    | N_nonempty_type_kind : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) nonterminal
+    | N_nonempty_list_raw_string_ : (string list) nonterminal
+    | N_nonempty_list_mkrhs_LIDENT__ : (string Location.loc list) nonterminal
+    | N_name_tag : (string) nonterminal
+    | N_mutable_virtual_flags : (Asttypes.mutable_flag * Asttypes.virtual_flag) nonterminal
+    | N_mutable_flag : (Asttypes.mutable_flag) nonterminal
+    | N_mty_longident : (Longident.t) nonterminal
+    | N_module_type_subst : (Parsetree.module_type_declaration * string Location.loc option) nonterminal
+    | N_module_type_declaration : (Parsetree.module_type_declaration * string Location.loc option) nonterminal
+    | N_module_type : (Parsetree.module_type) nonterminal
+    | N_module_subst : (Parsetree.module_substitution * string Location.loc option) nonterminal
+    | N_module_name : (string option) nonterminal
+    | N_module_expr : (Parsetree.module_expr) nonterminal
+    | N_module_declaration_body : (Parsetree.module_type) nonterminal
+    | N_module_binding_body : (Parsetree.module_expr) nonterminal
+    | N_mod_longident : (Longident.t) nonterminal
+    | N_mod_ext_longident : (Longident.t) nonterminal
+    | N_mk_longident_mod_longident_val_ident_ : (Longident.t) nonterminal
+    | N_mk_longident_mod_longident_UIDENT_ : (Longident.t) nonterminal
+    | N_mk_longident_mod_longident_LIDENT_ : (Longident.t) nonterminal
+    | N_mk_longident_mod_ext_longident_ident_ : (Longident.t) nonterminal
+    | N_mk_longident_mod_ext_longident___anonymous_41_ : (Longident.t) nonterminal
+    | N_mk_longident_mod_ext_longident_UIDENT_ : (Longident.t) nonterminal
+    | N_mk_longident_mod_ext_longident_LIDENT_ : (Longident.t) nonterminal
+    | N_method_ : ((string Location.loc * Asttypes.private_flag * Parsetree.class_field_kind) *
+  Parsetree.attributes) nonterminal
+    | N_meth_list : (Parsetree.object_field list * Asttypes.closed_flag) nonterminal
+    | N_match_case : (Parsetree.case) nonterminal
+    | N_lwt_bindings : (Ast_helper.let_bindings) nonterminal
+    | N_lwt_binding : (Ast_helper.let_bindings) nonterminal
+    | N_listx_SEMI_record_pat_field_UNDERSCORE_ : ((Longident.t Location.loc * Parsetree.pattern) list * unit option) nonterminal
+    | N_list_use_file_element_ : (Parsetree.toplevel_phrase list list) nonterminal
+    | N_list_text_str_structure_item__ : (Parsetree.structure_item list list) nonterminal
+    | N_list_text_cstr_class_field__ : (Parsetree.class_field list list) nonterminal
+    | N_list_text_csig_class_sig_field__ : (Parsetree.class_type_field list list) nonterminal
+    | N_list_structure_element_ : (Parsetree.structure_item list list) nonterminal
+    | N_list_signature_element_ : (Parsetree.signature_item list list) nonterminal
+    | N_list_post_item_attribute_ : (Parsetree.attributes) nonterminal
+    | N_list_generic_and_type_declaration_type_subst_kind__ : (Parsetree.type_declaration list) nonterminal
+    | N_list_generic_and_type_declaration_type_kind__ : (Parsetree.type_declaration list) nonterminal
+    | N_list_attribute_ : (Parsetree.attributes) nonterminal
+    | N_list_and_module_declaration_ : (Parsetree.module_declaration list) nonterminal
+    | N_list_and_module_binding_ : (Parsetree.module_binding list) nonterminal
+    | N_list_and_class_type_declaration_ : (Parsetree.class_type Parsetree.class_infos list) nonterminal
+    | N_list_and_class_description_ : (Parsetree.class_type Parsetree.class_infos list) nonterminal
+    | N_list_and_class_declaration_ : (Parsetree.class_expr Parsetree.class_infos list) nonterminal
+    | N_letop_bindings : (Parsetree.pattern * Parsetree.expression * Parsetree.binding_op list) nonterminal
+    | N_letop_binding_body : (Parsetree.pattern * Parsetree.expression) nonterminal
+    | N_let_pattern : (Parsetree.pattern) nonterminal
+    | N_let_bindings_no_ext_ : (Ast_helper.let_bindings) nonterminal
+    | N_let_bindings_ext_ : (Ast_helper.let_bindings) nonterminal
+    | N_let_binding_body_no_punning : (Parsetree.pattern * Parsetree.expression) nonterminal
+    | N_let_binding_body : (Parsetree.pattern * Parsetree.expression * bool) nonterminal
+    | N_labeled_simple_pattern : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) nonterminal
+    | N_labeled_simple_expr : (Asttypes.arg_label * Parsetree.expression) nonterminal
+    | N_label_longident : (Longident.t) nonterminal
+    | N_label_let_pattern : (string * Parsetree.pattern) nonterminal
+    | N_label_declarations : (Parsetree.label_declaration list) nonterminal
+    | N_label_declaration_semi : (Parsetree.label_declaration) nonterminal
+    | N_label_declaration : (Parsetree.label_declaration) nonterminal
+    | N_item_extension : (Parsetree.extension) nonterminal
+    | N_interface : (Parsetree.signature) nonterminal
+    | N_index_mod : (string) nonterminal
+    | N_implementation : (Parsetree.structure) nonterminal
+    | N_ident : (string) nonterminal
+    | N_generic_type_declaration_nonrec_flag_type_kind_ : ((Asttypes.rec_flag * string Location.loc option) *
+  Parsetree.type_declaration) nonterminal
+    | N_generic_type_declaration_no_nonrec_flag_type_subst_kind_ : ((Asttypes.rec_flag * string Location.loc option) *
+  Parsetree.type_declaration) nonterminal
+    | N_generic_constructor_declaration_epsilon_ : (Ocaml_parsing.Ast_helper.str * Parsetree.constructor_arguments *
+  Parsetree.core_type option * Parsetree.attributes * Location.t *
+  Ocaml_parsing.Docstrings.info) nonterminal
+    | N_generic_constructor_declaration_BAR_ : (Ocaml_parsing.Ast_helper.str * Parsetree.constructor_arguments *
+  Parsetree.core_type option * Parsetree.attributes * Location.t *
+  Ocaml_parsing.Docstrings.info) nonterminal
+    | N_generalized_constructor_arguments : (Parsetree.constructor_arguments * Parsetree.core_type option) nonterminal
+    | N_functor_args : ((Lexing.position * Parsetree.functor_parameter) list) nonterminal
+    | N_functor_arg : (Lexing.position * Parsetree.functor_parameter) nonterminal
+    | N_function_type : (Parsetree.core_type) nonterminal
+    | N_fun_def : (Parsetree.expression) nonterminal
+    | N_fun_binding : (Parsetree.expression) nonterminal
+    | N_formal_class_parameters : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) nonterminal
+    | N_floating_attribute : (Parsetree.attribute) nonterminal
+    | N_extension_constructor_rebind_epsilon_ : (Parsetree.extension_constructor) nonterminal
+    | N_extension_constructor_rebind_BAR_ : (Parsetree.extension_constructor) nonterminal
+    | N_extension : (Parsetree.extension) nonterminal
+    | N_ext : (string Location.loc option) nonterminal
+    | N_expr : (Parsetree.expression) nonterminal
+    | N_direction_flag : (Asttypes.direction_flag) nonterminal
+    | N_core_type : (Parsetree.core_type) nonterminal
+    | N_constructor_declarations : (Parsetree.constructor_declaration list) nonterminal
+    | N_constructor_arguments : (Parsetree.constructor_arguments) nonterminal
+    | N_constrain_field : (Parsetree.core_type * Parsetree.core_type) nonterminal
+    | N_constr_longident : (Longident.t) nonterminal
+    | N_constr_ident : (string) nonterminal
+    | N_constr_extra_nonprefix_ident : (string) nonterminal
+    | N_constant : (Parsetree.constant) nonterminal
+    | N_clty_longident : (Longident.t) nonterminal
+    | N_class_type_declarations : (string Location.loc option * Parsetree.class_type_declaration list) nonterminal
+    | N_class_type : (Parsetree.class_type) nonterminal
+    | N_class_simple_expr : (Parsetree.class_expr) nonterminal
+    | N_class_signature : (Parsetree.class_type) nonterminal
+    | N_class_sig_field : (Parsetree.class_type_field) nonterminal
+    | N_class_self_type : (Parsetree.core_type) nonterminal
+    | N_class_self_pattern : (Parsetree.pattern) nonterminal
+    | N_class_longident : (Longident.t) nonterminal
+    | N_class_fun_def : (Parsetree.class_expr) nonterminal
+    | N_class_fun_binding : (Parsetree.class_expr) nonterminal
+    | N_class_field : (Parsetree.class_field) nonterminal
+    | N_class_expr : (Parsetree.class_expr) nonterminal
+    | N_attribute : (Parsetree.attribute) nonterminal
+    | N_attr_id : (string Location.loc) nonterminal
+    | N_atomic_type : (Parsetree.core_type) nonterminal
+    | N_any_longident : (Longident.t) nonterminal
+    | N_and_let_binding : (Ast_helper.let_binding) nonterminal
+    | N_alias_type : (Parsetree.core_type) nonterminal
+    | N_additive : (string) nonterminal
+  
+  (* The inspection API. *)
+  
+  include MenhirLib.IncrementalEngine.INSPECTION
+    with type 'a lr1state := 'a lr1state
+    with type production := production
+    with type 'a terminal := 'a terminal
+    with type 'a nonterminal := 'a nonterminal
+    with type 'a env := 'a env
+  
+end
+
+(* The entry point(s) to the incremental API. *)
+
+module Incremental : sig
+  
+  val use_file: Lexing.position -> (Parsetree.toplevel_phrase list) MenhirInterpreter.checkpoint
+  
+  val toplevel_phrase: Lexing.position -> (Parsetree.toplevel_phrase) MenhirInterpreter.checkpoint
+  
+  val parse_val_longident: Lexing.position -> (Longident.t) MenhirInterpreter.checkpoint
+  
+  val parse_pattern: Lexing.position -> (Parsetree.pattern) MenhirInterpreter.checkpoint
+  
+  val parse_mty_longident: Lexing.position -> (Longident.t) MenhirInterpreter.checkpoint
+  
+  val parse_mod_longident: Lexing.position -> (Longident.t) MenhirInterpreter.checkpoint
+  
+  val parse_mod_ext_longident: Lexing.position -> (Longident.t) MenhirInterpreter.checkpoint
+  
+  val parse_expression: Lexing.position -> (Parsetree.expression) MenhirInterpreter.checkpoint
+  
+  val parse_core_type: Lexing.position -> (Parsetree.core_type) MenhirInterpreter.checkpoint
+  
+  val parse_constr_longident: Lexing.position -> (Longident.t) MenhirInterpreter.checkpoint
+  
+  val parse_any_longident: Lexing.position -> (Longident.t) MenhirInterpreter.checkpoint
+  
+  val interface: Lexing.position -> (Parsetree.signature) MenhirInterpreter.checkpoint
+  
+  val implementation: Lexing.position -> (Parsetree.structure) MenhirInterpreter.checkpoint
+  
+end
diff --git a/src/ocaml/preprocess/parser_raw.mly b/src/ocaml/preprocess/parser_raw.mly
new file mode 100644
index 0000000..287196c
--- /dev/null
+++ b/src/ocaml/preprocess/parser_raw.mly
@@ -0,0 +1,4092 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 1996 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* The parser definition */
+
+/* The commands [make list-parse-errors] and [make generate-parse-errors]
+   run Menhir on a modified copy of the parser where every block of
+   text comprised between the markers [BEGIN AVOID] and -----------
+   [END AVOID] has been removed. This file should be formatted in
+   such a way that this results in a clean removal of certain
+   symbols, productions, or declarations. */
+
+%{
+
+[@@@ocaml.warning "-9"]
+
+open Asttypes
+open Longident
+open Parsetree
+open Ast_helper
+open Docstrings
+open Docstrings.WithMenhir
+open Msupport_parsing
+
+let mkloc = Location.mkloc
+let mknoloc = Location.mknoloc
+
+let make_loc (startpos, endpos) = {
+  Location.loc_start = startpos;
+  Location.loc_end = endpos;
+  Location.loc_ghost = false;
+}
+
+let ghost_loc (startpos, endpos) = {
+  Location.loc_start = startpos;
+  Location.loc_end = endpos;
+  Location.loc_ghost = true;
+}
+
+let mktyp ~loc ?attrs d = Typ.mk ~loc:(make_loc loc) ?attrs d
+let mkpat ~loc d = Pat.mk ~loc:(make_loc loc) d
+let mkexp ~loc d = Exp.mk ~loc:(make_loc loc) d
+let mkmty ~loc ?attrs d = Mty.mk ~loc:(make_loc loc) ?attrs d
+let mksig ~loc d = Sig.mk ~loc:(make_loc loc) d
+let mkmod ~loc ?attrs d = Mod.mk ~loc:(make_loc loc) ?attrs d
+let mkstr ~loc d = Str.mk ~loc:(make_loc loc) d
+let mkclass ~loc ?attrs d = Cl.mk ~loc:(make_loc loc) ?attrs d
+let mkcty ~loc ?attrs d = Cty.mk ~loc:(make_loc loc) ?attrs d
+
+let pstr_typext (te, ext) =
+  (Pstr_typext te, ext)
+let pstr_primitive (vd, ext) =
+  (Pstr_primitive vd, ext)
+let pstr_type ((nr, ext), tys) =
+  (Pstr_type (nr, tys), ext)
+let pstr_exception (te, ext) =
+  (Pstr_exception te, ext)
+let pstr_include (body, ext) =
+  (Pstr_include body, ext)
+let pstr_recmodule (ext, bindings) =
+  (Pstr_recmodule bindings, ext)
+
+let psig_typext (te, ext) =
+  (Psig_typext te, ext)
+let psig_value (vd, ext) =
+  (Psig_value vd, ext)
+let psig_type ((nr, ext), tys) =
+  (Psig_type (nr, tys), ext)
+let psig_typesubst ((nr, ext), tys) =
+  assert (nr = Recursive); (* see [no_nonrec_flag] *)
+  (Psig_typesubst tys, ext)
+let psig_exception (te, ext) =
+  (Psig_exception te, ext)
+let psig_include (body, ext) =
+  (Psig_include body, ext)
+
+let mkctf ~loc ?attrs ?docs d =
+  Ctf.mk ~loc:(make_loc loc) ?attrs ?docs d
+let mkcf ~loc ?attrs ?docs d =
+  Cf.mk ~loc:(make_loc loc) ?attrs ?docs d
+
+let mkrhs rhs loc = mkloc rhs (make_loc loc)
+let ghrhs rhs loc = mkloc rhs (ghost_loc loc)
+
+let push_loc x acc =
+  if x.Location.loc_ghost
+  then acc
+  else x :: acc
+
+let reloc_pat ~loc x =
+  { x with ppat_loc = make_loc loc;
+           ppat_loc_stack = push_loc x.ppat_loc x.ppat_loc_stack };;
+let reloc_exp ~loc x =
+  { x with pexp_loc = make_loc loc;
+           pexp_loc_stack = push_loc x.pexp_loc x.pexp_loc_stack };;
+let reloc_typ ~loc x =
+  { x with ptyp_loc = make_loc loc;
+           ptyp_loc_stack = push_loc x.ptyp_loc x.ptyp_loc_stack };;
+
+let mkexpvar ~loc (name : string) =
+  mkexp ~loc (Pexp_ident(mkrhs (Lident name) loc))
+
+let mkoperator =
+  mkexpvar
+
+let mkpatvar ~loc name =
+  mkpat ~loc (Ppat_var (mkrhs name loc))
+
+(*
+  Ghost expressions and patterns:
+  expressions and patterns that do not appear explicitly in the
+  source file they have the loc_ghost flag set to true.
+  Then the profiler will not try to instrument them and the
+  -annot option will not try to display their type.
+
+  Every grammar rule that generates an element with a location must
+  make at most one non-ghost element, the topmost one.
+
+  How to tell whether your location must be ghost:
+  A location corresponds to a range of characters in the source file.
+  If the location contains a piece of code that is syntactically
+  valid (according to the documentation), and corresponds to the
+  AST node, then the location must be real; in all other cases,
+  it must be ghost.
+*)
+let ghexp ~loc d = Exp.mk ~loc:(ghost_loc loc) d
+let ghpat ~loc d = Pat.mk ~loc:(ghost_loc loc) d
+let ghtyp ~loc d = Typ.mk ~loc:(ghost_loc loc) d
+let ghloc ~loc d = { txt = d; loc = ghost_loc loc }
+let ghstr ~loc d = Str.mk ~loc:(ghost_loc loc) d
+let ghsig ~loc d = Sig.mk ~loc:(ghost_loc loc) d
+
+let mkinfix arg1 op arg2 =
+  Pexp_apply(op, [Nolabel, arg1; Nolabel, arg2])
+
+let neg_string f =
+  if String.length f > 0 && f.[0] = '-'
+  then String.sub f 1 (String.length f - 1)
+  else "-" ^ f
+
+let mkuminus ~oploc name arg =
+  match name, arg.pexp_desc with
+  | "-", Pexp_constant(Pconst_integer (n,m)) ->
+      Pexp_constant(Pconst_integer(neg_string n,m))
+  | ("-" | "-."), Pexp_constant(Pconst_float (f, m)) ->
+      Pexp_constant(Pconst_float(neg_string f, m))
+  | _ ->
+      Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg])
+
+let mkuplus ~oploc name arg =
+  let desc = arg.pexp_desc in
+  match name, desc with
+  | "+", Pexp_constant(Pconst_integer _)
+  | ("+" | "+."), Pexp_constant(Pconst_float _) -> desc
+  | _ ->
+      Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg])
+
+(* TODO define an abstraction boundary between locations-as-pairs
+   and locations-as-Location.t; it should be clear when we move from
+   one world to the other *)
+
+let mkexp_cons_desc consloc args =
+  Pexp_construct(mkrhs (Lident "::") consloc, Some args)
+let mkexp_cons ~loc consloc args =
+  mkexp ~loc (mkexp_cons_desc consloc args)
+
+let mkpat_cons_desc consloc args =
+  Ppat_construct(mkrhs (Lident "::") consloc, Some ([], args))
+let mkpat_cons ~loc consloc args =
+  mkpat ~loc (mkpat_cons_desc consloc args)
+
+let ghexp_cons_desc consloc args =
+  Pexp_construct(ghrhs (Lident "::") consloc, Some args)
+let ghpat_cons_desc consloc args =
+  Ppat_construct(ghrhs (Lident "::") consloc, Some ([], args))
+
+let rec mktailexp nilloc = let open Location in function
+    [] ->
+      let nil = ghloc ~loc:nilloc (Lident "[]") in
+      Pexp_construct (nil, None), nilloc
+  | e1 :: el ->
+      let exp_el, el_loc = mktailexp nilloc el in
+      let loc = (e1.pexp_loc.loc_start, snd el_loc) in
+      let arg = ghexp ~loc (Pexp_tuple [e1; ghexp ~loc:el_loc exp_el]) in
+      ghexp_cons_desc loc arg, loc
+
+let rec mktailpat nilloc = let open Location in function
+    [] ->
+      let nil = ghloc ~loc:nilloc (Lident "[]") in
+      Ppat_construct (nil, None), nilloc
+  | p1 :: pl ->
+      let pat_pl, el_loc = mktailpat nilloc pl in
+      let loc = (p1.ppat_loc.loc_start, snd el_loc) in
+      let arg = ghpat ~loc (Ppat_tuple [p1; ghpat ~loc:el_loc pat_pl]) in
+      ghpat_cons_desc loc arg, loc
+
+let mkstrexp e attrs =
+  { pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc }
+
+let mkexp_constraint ~loc e (t1, t2) =
+  match t1, t2 with
+  | Some t, None -> ghexp ~loc (Pexp_constraint(e, t))
+  | _, Some t -> ghexp ~loc (Pexp_coerce(e, t1, t))
+  | None, None -> assert false
+
+let mkexp_opt_constraint ~loc e = function
+  | None -> e
+  | Some constraint_ -> mkexp_constraint ~loc e constraint_
+
+let mkpat_opt_constraint ~loc p = function
+  | None -> p
+  | Some typ -> ghpat ~loc (Ppat_constraint(p, typ))
+
+
+(*let syntax_error () =
+  raise Syntaxerr.Escape_error*)
+
+
+(* Using the function [not_expecting] in a semantic action means that this
+   syntactic form is recognized by the parser but is in fact incorrect. This
+   idiom is used in a few places to produce ad hoc syntax error messages. *)
+
+(* This idiom should be used as little as possible, because it confuses the
+   analyses performed by Menhir. Because Menhir views the semantic action as
+   opaque, it believes that this syntactic form is correct. This can lead
+   [make generate-parse-errors] to produce sentences that cause an early
+   (unexpected) syntax error and do not achieve the desired effect. This could
+   also lead a completion system to propose completions which in fact are
+   incorrect. In order to avoid these problems, the productions that use
+   [not_expecting] should be marked with AVOID. *)
+
+let not_expecting loc nonterm =
+  raise_error Syntaxerr.(Error(Not_expecting(make_loc loc, nonterm)))
+
+(*
+let unclosed opening_name opening_loc closing_name closing_loc =
+  raise(Syntaxerr.Error(Syntaxerr.Unclosed(make_loc opening_loc, opening_name,
+                                           make_loc closing_loc, closing_name)))
+*)
+
+let expecting loc nonterm =
+    raise_error Syntaxerr.(Error(Expecting(make_loc loc, nonterm)))
+
+(* Helper functions for desugaring array indexing operators *)
+type paren_kind = Paren | Brace | Bracket
+
+(* We classify the dimension of indices: Bigarray distinguishes
+   indices of dimension 1,2,3, or more. Similarly, user-defined
+   indexing operator behave differently for indices of dimension 1
+   or more.
+*)
+type index_dim =
+  | One
+  | Two
+  | Three
+  | Many
+type ('dot,'index) array_family = {
+  name:
+    Lexing.position * Lexing.position -> 'dot -> assign:bool -> paren_kind
+  -> index_dim -> Longident.t Location.loc
+  (*
+    This functions computes the name of the explicit indexing operator
+    associated with a sugared array indexing expression.
+    For instance, for builtin arrays, if Clflags.unsafe is set,
+    * [ a.[index] ]     =>  [String.unsafe_get]
+    * [ a.{x,y} <- 1 ]  =>  [ Bigarray.Array2.unsafe_set]
+    User-defined indexing operator follows a more local convention:
+    * [ a .%(index)]     => [ (.%()) ]
+    * [ a.![1;2] <- 0 ]  => [(.![;..]<-)]
+    * [ a.My.Map.?(0) => [My.Map.(.?())]
+  *);
+  index:
+    Lexing.position * Lexing.position -> paren_kind -> 'index
+    -> index_dim * (arg_label * expression) list
+   (*
+     [index (start,stop) paren index] computes the dimension of the
+     index argument and how it should be desugared when transformed
+     to a list of arguments for the indexing operator.
+     In particular, in both the Bigarray case and the user-defined case,
+     beyond a certain dimension, multiple indices are packed into a single
+     array argument:
+     * [ a.(x) ]       => [ [One, [Nolabel, <<x>>] ]
+     * [ a.{1,2} ]     => [ [Two, [Nolabel, <<1>>; Nolabel, <<2>>] ]
+     * [ a.{1,2,3,4} ] => [ [Many, [Nolabel, <<[|1;2;3;4|]>>] ] ]
+   *);
+}
+
+let bigarray_untuplify = function
+    { pexp_desc = Pexp_tuple explist; pexp_loc = _ } -> explist
+  | exp -> [exp]
+
+let builtin_arraylike_name loc _ ~assign paren_kind n =
+  let opname = if assign then "set" else "get" in
+  let opname = if !Clflags.fast then "unsafe_" ^ opname else opname in
+  let prefix = match paren_kind with
+    | Paren -> Lident "Array"
+    | Bracket -> Lident "String"
+    | Brace ->
+       let submodule_name = match n with
+         | One -> "Array1"
+         | Two -> "Array2"
+         | Three -> "Array3"
+         | Many -> "Genarray" in
+       Ldot(Lident "Bigarray", submodule_name) in
+   ghloc ~loc (Ldot(prefix,opname))
+
+let builtin_arraylike_index loc paren_kind index = match paren_kind with
+    | Paren | Bracket -> One, [Nolabel, index]
+    | Brace ->
+       (* Multi-indices for bigarray are comma-separated ([a.{1,2,3,4}]) *)
+       match bigarray_untuplify index with
+     | [x] -> One, [Nolabel, x]
+     | [x;y] -> Two, [Nolabel, x; Nolabel, y]
+     | [x;y;z] -> Three, [Nolabel, x; Nolabel, y; Nolabel, z]
+     | coords -> Many, [Nolabel, ghexp ~loc (Pexp_array coords)]
+
+let builtin_indexing_operators : (unit, expression) array_family  =
+  { index = builtin_arraylike_index; name = builtin_arraylike_name }
+
+let paren_to_strings = function
+  | Paren -> "(", ")"
+  | Bracket -> "[", "]"
+  | Brace -> "{", "}"
+
+let user_indexing_operator_name loc (prefix,ext) ~assign paren_kind n =
+  let name =
+    let assign = if assign then "<-" else "" in
+    let mid = match n with
+        | Many | Three | Two  -> ";.."
+        | One -> "" in
+    let left, right = paren_to_strings paren_kind in
+    String.concat "" ["."; ext; left; mid; right; assign] in
+  let lid = match prefix with
+    | None -> Lident name
+    | Some p -> Ldot(p,name) in
+  ghloc ~loc lid
+
+let user_index loc _ index =
+  (* Multi-indices for user-defined operators are semicolon-separated
+     ([a.%[1;2;3;4]]) *)
+  match index with
+    | [a] -> One, [Nolabel, a]
+    | l -> Many, [Nolabel, mkexp ~loc (Pexp_array l)]
+
+let user_indexing_operators:
+      (Longident.t option * string, expression list) array_family
+  = { index = user_index; name = user_indexing_operator_name }
+
+let mk_indexop_expr array_indexing_operator ~loc
+      (array,dot,paren,index,set_expr) =
+  let assign = match set_expr with None -> false | Some _ -> true in
+  let n, index = array_indexing_operator.index loc paren index in
+  let fn = array_indexing_operator.name loc dot ~assign paren n in
+  let set_arg = match set_expr with
+    | None -> []
+    | Some expr -> [Nolabel, expr] in
+  let args = (Nolabel,array) :: index @ set_arg in
+  mkexp ~loc (Pexp_apply(ghexp ~loc (Pexp_ident fn), args))
+
+  (*
+let indexop_unclosed_error loc_s s loc_e =
+  let left, right = paren_to_strings s in
+  unclosed left loc_s right loc_e
+  *)
+
+let lapply ~loc p1 p2 =
+  if !Clflags.applicative_functors
+  then Lapply(p1, p2)
+  else raise (Syntaxerr.Error(
+                  Syntaxerr.Applicative_path (make_loc loc)))
+
+(* [loc_map] could be [Location.map]. *)
+let loc_map (f : 'a -> 'b) (x : 'a Location.loc) : 'b Location.loc =
+  { x with txt = f x.txt }
+
+let make_ghost x = { x with loc = { x.loc with loc_ghost = true }}
+
+let loc_last (id : Longident.t Location.loc) : string Location.loc =
+  loc_map Longident.last id
+
+let loc_lident (id : string Location.loc) : Longident.t Location.loc =
+  loc_map (fun x -> Lident x) id
+
+let exp_of_longident ~loc lid =
+  let lid = make_ghost (loc_map (fun id -> Lident (Longident.last id)) lid) in
+  ghexp ~loc (Pexp_ident lid)
+
+let exp_of_label ~loc lbl =
+  mkexp ~loc (Pexp_ident (loc_lident lbl))
+
+let pat_of_label lbl =
+  Pat.mk ~loc:lbl.loc  (Ppat_var (loc_last lbl))
+
+let mk_newtypes ~loc newtypes exp =
+  let mkexp = mkexp ~loc in
+  List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp)))
+    newtypes exp
+
+let wrap_type_annotation ~loc newtypes core_type body =
+  let mkexp, ghtyp = mkexp ~loc, ghtyp ~loc in
+  let mk_newtypes = mk_newtypes ~loc in
+  let exp = mkexp(Pexp_constraint(body,core_type)) in
+  let exp = mk_newtypes newtypes exp in
+  (exp, ghtyp(Ptyp_poly(newtypes, Typ.varify_constructors newtypes core_type)))
+
+let wrap_exp_attrs ~loc body (ext, attrs) =
+  let ghexp = ghexp ~loc in
+  (* todo: keep exact location for the entire attribute *)
+  let body = {body with pexp_attributes = attrs @ body.pexp_attributes} in
+  match ext with
+  | None -> body
+  | Some id -> ghexp(Pexp_extension (id, PStr [mkstrexp body []]))
+
+let mkexp_attrs ~loc d attrs =
+  wrap_exp_attrs ~loc (mkexp ~loc d) attrs
+
+let wrap_typ_attrs ~loc typ (ext, attrs) =
+  (* todo: keep exact location for the entire attribute *)
+  let typ = {typ with ptyp_attributes = attrs @ typ.ptyp_attributes} in
+  match ext with
+  | None -> typ
+  | Some id -> ghtyp ~loc (Ptyp_extension (id, PTyp typ))
+
+let wrap_pat_attrs ~loc pat (ext, attrs) =
+  (* todo: keep exact location for the entire attribute *)
+  let pat = {pat with ppat_attributes = attrs @ pat.ppat_attributes} in
+  match ext with
+  | None -> pat
+  | Some id -> ghpat ~loc (Ppat_extension (id, PPat (pat, None)))
+
+let mkpat_attrs ~loc d attrs =
+  wrap_pat_attrs ~loc (mkpat ~loc d) attrs
+
+let wrap_class_attrs ~loc:_ body attrs =
+  {body with pcl_attributes = attrs @ body.pcl_attributes}
+let wrap_mod_attrs ~loc:_ attrs body =
+  {body with pmod_attributes = attrs @ body.pmod_attributes}
+let wrap_mty_attrs ~loc:_ attrs body =
+  {body with pmty_attributes = attrs @ body.pmty_attributes}
+
+let wrap_str_ext ~loc body ext =
+  match ext with
+  | None -> body
+  | Some id -> ghstr ~loc (Pstr_extension ((id, PStr [body]), []))
+
+let wrap_mkstr_ext ~loc (item, ext) =
+  wrap_str_ext ~loc (mkstr ~loc item) ext
+
+let wrap_sig_ext ~loc body ext =
+  match ext with
+  | None -> body
+  | Some id -> ghsig ~loc (Psig_extension ((id, PSig [body]), []))
+
+let wrap_mksig_ext ~loc (item, ext) =
+  wrap_sig_ext ~loc (mksig ~loc item) ext
+
+let mk_quotedext ~loc (id, idloc, str, strloc, delim) =
+  let exp_id = mkloc id idloc in
+  let e = ghexp ~loc (Pexp_constant (Pconst_string (str, strloc, delim))) in
+  (exp_id, PStr [mkstrexp e []])
+
+let text_str pos = Str.text (rhs_text pos)
+let text_sig pos = Sig.text (rhs_text pos)
+let text_cstr pos = Cf.text (rhs_text pos)
+let text_csig pos = Ctf.text (rhs_text pos)
+let text_def pos =
+  List.map (fun def -> Ptop_def [def]) (Str.text (rhs_text pos))
+
+let extra_text startpos endpos text items =
+  match items with
+  | [] ->
+      let post = rhs_post_text endpos in
+      let post_extras = rhs_post_extra_text endpos in
+      text post @ text post_extras
+  | _ :: _ ->
+      let pre_extras = rhs_pre_extra_text startpos in
+      let post_extras = rhs_post_extra_text endpos in
+        text pre_extras @ items @ text post_extras
+
+let extra_str p1 p2 items = extra_text p1 p2 Str.text items
+let extra_sig p1 p2 items = extra_text p1 p2 Sig.text items
+let extra_cstr p1 p2 items = extra_text p1 p2 Cf.text items
+let extra_csig p1 p2 items = extra_text p1 p2 Ctf.text  items
+let extra_def p1 p2 items =
+  extra_text p1 p2
+    (fun txt -> List.map (fun def -> Ptop_def [def]) (Str.text txt))
+    items
+
+let extra_rhs_core_type ct ~pos =
+  let docs = rhs_info pos in
+  { ct with ptyp_attributes = add_info_attrs docs ct.ptyp_attributes }
+
+(*
+type let_binding =
+  { lb_pattern: pattern;
+    lb_expression: expression;
+    lb_is_pun: bool;
+    lb_attributes: attributes;
+    lb_docs: docs Lazy.t;
+    lb_text: text Lazy.t;
+    lb_loc: Location.t; }
+
+type let_bindings =
+  { lbs_bindings: let_binding list;
+    lbs_rec: rec_flag;
+    lbs_extension: string Asttypes.loc option }
+*)
+
+let mklb first ~loc (p, e, is_pun) attrs =
+  {
+    lb_pattern = p;
+    lb_expression = e;
+    lb_is_pun = is_pun;
+    lb_attributes = attrs;
+    lb_docs = symbol_docs_lazy loc;
+    lb_text = (if first then empty_text_lazy
+               else symbol_text_lazy (fst loc));
+    lb_loc = make_loc loc;
+  }
+
+let addlb lbs lb =
+  if lb.lb_is_pun && lbs.lbs_extension = None then (
+    let err =
+      Syntaxerr.Expecting (lb.lb_loc, "let-extension (with punning)")
+    in
+    raise_error (Syntaxerr.Error err)
+  );
+  { lbs with lbs_bindings = lb :: lbs.lbs_bindings }
+
+let mklbs ext rf lb =
+  let lbs = {
+    lbs_bindings = [];
+    lbs_rec = rf;
+    lbs_extension = ext;
+  } in
+  addlb lbs lb
+
+let val_of_let_bindings ~loc lbs =
+  let bindings =
+    List.map
+      (fun lb ->
+         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
+           ~docs:(Lazy.force lb.lb_docs)
+           ~text:(Lazy.force lb.lb_text)
+           lb.lb_pattern lb.lb_expression)
+      lbs.lbs_bindings
+  in
+  let str = mkstr ~loc (Pstr_value(lbs.lbs_rec, List.rev bindings)) in
+  match lbs.lbs_extension with
+  | None -> str
+  | Some id -> ghstr ~loc (Pstr_extension((id, PStr [str]), []))
+
+let expr_of_let_bindings ~loc lbs body =
+  let bindings =
+    List.map
+      (fun lb ->
+         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
+           lb.lb_pattern lb.lb_expression)
+      lbs.lbs_bindings
+  in
+    mkexp_attrs ~loc (Pexp_let(lbs.lbs_rec, List.rev bindings, body))
+      (lbs.lbs_extension, [])
+
+let class_of_let_bindings ~loc lbs body =
+  let bindings =
+    List.map
+      (fun lb ->
+         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
+           lb.lb_pattern lb.lb_expression)
+      lbs.lbs_bindings
+  in
+    (* Our use of let_bindings(no_ext) guarantees the following: *)
+    assert (lbs.lbs_extension = None);
+    mkclass ~loc (Pcl_let (lbs.lbs_rec, List.rev bindings, body))
+
+(* Alternatively, we could keep the generic module type in the Parsetree
+   and extract the package type during type-checking. In that case,
+   the assertions below should be turned into explicit checks. *)
+let package_type_of_module_type pmty =
+  let err loc s =
+    raise_error (Syntaxerr.Error (Syntaxerr.Invalid_package_type (loc, s)))
+  in
+  let map_cstr = function
+    | Pwith_type (lid, ptyp) ->
+        let loc = ptyp.ptype_loc in
+        if ptyp.ptype_params <> [] then
+          err loc "parametrized types are not supported";
+        if ptyp.ptype_cstrs <> [] then
+          err loc "constrained types are not supported";
+        if ptyp.ptype_private <> Public then
+          err loc "private types are not supported";
+
+        (* restrictions below are checked by the 'with_constraint' rule *)
+        (* assert (ptyp.ptype_kind = Ptype_abstract); *)
+        (* assert (ptyp.ptype_attributes = []); *)
+        begin match ptyp.ptype_manifest with
+        | Some ty -> Some (lid, ty)
+        | None -> None
+        end
+    | _ ->
+        err pmty.pmty_loc "only 'with type t =' constraints are supported";
+        None
+  in
+  match pmty with
+  | {pmty_desc = Pmty_ident lid} -> (lid, [], pmty.pmty_attributes)
+  | {pmty_desc = Pmty_with({pmty_desc = Pmty_ident lid}, cstrs)} ->
+      (lid, List.filter_map map_cstr cstrs, pmty.pmty_attributes)
+  | _ ->
+      err pmty.pmty_loc
+        "only module type identifier and 'with type' constraints are supported"
+      ; (Location.mkloc (Lident "_") pmty.pmty_loc, [], [])
+
+let mk_directive_arg ~loc k =
+  { pdira_desc = k;
+    pdira_loc = make_loc loc;
+  }
+
+let mk_directive ~loc name arg =
+  Ptop_dir {
+      pdir_name = name;
+      pdir_arg = arg;
+      pdir_loc = make_loc loc;
+    }
+
+let merloc startpos ?endpos x =
+  let endpos = match endpos with
+    | None -> x.pexp_loc.Location.loc_end
+    | Some endpos -> endpos
+  in
+  let loc = make_loc (startpos, endpos) in
+  let str = mkloc "merlin.loc" loc in
+  let attr = { attr_name = str; attr_loc = loc; attr_payload = PStr [] } in
+  { x with pexp_attributes = attr :: x.pexp_attributes }
+
+let val_of_lwt_bindings ~loc lbs =
+  let bindings =
+    List.map
+      (fun lb ->
+         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
+           ~docs:(Lazy.force lb.lb_docs)
+           ~text:(Lazy.force lb.lb_text)
+           lb.lb_pattern (Fake.app Fake.Lwt.un_lwt lb.lb_expression))
+      lbs.lbs_bindings
+  in
+  let str = mkstr ~loc (Pstr_value(lbs.lbs_rec, List.rev bindings)) in
+  match lbs.lbs_extension with
+  | None -> str
+  | Some id -> ghstr ~loc (Pstr_extension((id, PStr [str]), []))
+
+let expr_of_lwt_bindings ~loc lbs body =
+  let bindings =
+    List.map
+      (fun lb ->
+         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
+           lb.lb_pattern (Fake.app Fake.Lwt.un_lwt lb.lb_expression))
+      lbs.lbs_bindings
+  in
+  Fake.app Fake.Lwt.in_lwt
+    (mkexp_attrs ~loc (Pexp_let(lbs.lbs_rec, List.rev bindings, body))
+       (lbs.lbs_extension, []))
+
+%}
+
+%[@printer.header
+  let string_of_INT = function
+    | (s, None) -> Printf.sprintf "INT(%s)" s
+    | (s, Some c) -> Printf.sprintf "INT(%s%c)" s c
+
+  let string_of_FLOAT = function
+    | (s, None) -> Printf.sprintf "FLOAT(%s)" s
+    | (s, Some c) -> Printf.sprintf "FLOAT(%s%c)" s c
+
+  let string_of_STRING = function
+    | s, _, Some s' -> Printf.sprintf "STRING(%S,%S)" s s'
+    | s, _, None -> Printf.sprintf "STRING(%S)" s
+
+  let string_of_quoted_STRING = function
+    | _, _, s, _, Some s' -> Printf.sprintf "QUOTED_STRING(%S,%S)" s s'
+    | _, _, s, _, None -> Printf.sprintf "QUOTED_STRING(%S)" s
+]
+
+%[@recovery.header
+  open Parsetree
+  open Ast_helper
+
+  let default_loc = ref Location.none
+
+  let default_expr () =
+    let id = Location.mkloc Ast_helper.hole_txt !default_loc in
+    Exp.mk ~loc:!default_loc (Pexp_extension (id, PStr []))
+
+  let default_pattern () = Pat.any ~loc:!default_loc ()
+
+  let default_module_expr () = Mod.structure ~loc:!default_loc []
+  let default_module_type () = Mty.signature ~loc:!default_loc []
+]
+
+/* Tokens */
+
+/* The alias that follows each token is used by Menhir when it needs to
+   produce a sentence (that is, a sequence of tokens) in concrete syntax. */
+
+/* Some tokens represent multiple concrete strings. In most cases, an
+   arbitrary concrete string can be chosen. In a few cases, one must
+   be careful: e.g., in PREFIXOP and INFIXOP2, one must choose a concrete
+   string that will not trigger a syntax error; see how [not_expecting]
+   is used in the definition of [type_variance]. */
+
+%token AMPERAMPER [@symbol "&&"]
+%token AMPERSAND [@symbol "&"]
+%token AND [@symbol "and"]
+%token AS [@symbol "as"]
+%token ASSERT [@symbol "assert"]
+%token BACKQUOTE [@symbol "`"]
+%token BANG [@symbol "!"]
+%token BAR [@symbol "|"]
+%token BARBAR [@symbol "||"]
+%token BARRBRACKET [@symbol "|]"]
+%token BEGIN [@symbol "begin"]
+%token <char> CHAR [@cost 2] [@recovery '_']
+%token CLASS [@symbol "class"]
+%token COLON [@symbol ":"]
+%token COLONCOLON [@symbol "::"]
+%token COLONEQUAL [@symbol ":="]
+%token COLONGREATER [@symbol ":>"]
+%token COMMA [@symbol ","]
+%token CONSTRAINT [@symbol "constraint"]
+%token DO [@symbol "do"]
+%token DONE [@symbol "done"]
+%token DOT [@symbol "."]
+%token DOTDOT [@symbol ".."]
+%token DOWNTO [@symbol "downto"]
+%token ELSE [@symbol "else"]
+%token END [@symbol "end"]
+%token EOF
+%token EQUAL [@symbol "="]
+%token EXCEPTION [@symbol "exception"]
+%token EXTERNAL [@symbol "external"]
+%token FALSE [@symbol "false"]
+%token <string * char option> FLOAT [@cost 2] [@recovery ("0.",None)] [@printer string_of_FLOAT]
+%token FOR [@symbol "for"]
+%token FUN [@symbol "fun"]
+%token FUNCTION [@symbol "function"]
+%token FUNCTOR [@symbol "functor"]
+%token GREATER [@symbol ">"]
+%token GREATERRBRACE [@symbol ">}"]
+%token GREATERRBRACKET [@symbol ">]"]
+%token IF [@symbol "if"]
+%token IN [@symbol "in"]
+%token INCLUDE [@symbol "include"]
+%token <string> INFIXOP0 [@cost 2] [@recovery "_"][@printer Printf.sprintf "INFIXOP0(%S)"]
+%token <string> INFIXOP1 [@cost 2] [@recovery "_"][@printer Printf.sprintf "INFIXOP1(%S)"]
+%token <string> INFIXOP2 [@cost 2] [@recovery "_"][@printer Printf.sprintf "INFIXOP2(%S)"]
+%token <string> INFIXOP3 [@cost 2] [@recovery "_"][@printer Printf.sprintf "INFIXOP3(%S)"]
+%token <string> INFIXOP4 [@cost 2] [@recovery "_"][@printer Printf.sprintf "INFIXOP4(%S)"]
+%token <string> DOTOP
+%token <string> LETOP /* TODO: recovery & printing */
+%token <string> ANDOP /* TODO: recovery & printing */
+%token INHERIT [@symbol "inherit"]
+%token INITIALIZER [@symbol "initializer"]
+%token <string * char option> INT [@cost 1] [@recovery ("0",None)] [@printer string_of_INT]
+%token <string> LABEL [@cost 2] [@recovery "_"][@printer Printf.sprintf "LABEL(%S)"] [@symbol "label"]
+%token LAZY [@symbol "lazy"]
+%token LBRACE [@symbol "{"]
+%token LBRACELESS [@symbol "{<"]
+%token LBRACKET [@symbol "["]
+%token LBRACKETBAR [@symbol "[|"]
+%token LBRACKETLESS [@symbol "[<"]
+%token LBRACKETGREATER [@symbol "[>"]
+%token LBRACKETPERCENT [@symbol "[%"]
+%token LBRACKETPERCENTPERCENT [@symbol "[%%"]
+%token LESS [@symbol "<"]
+%token LESSMINUS [@symbol "<-"] [@cost 2]
+%token LET [@symbol "let"]
+%token <string> LIDENT [@cost 2] [@recovery "_"][@printer Printf.sprintf "LIDENT(%S)"]
+%token LPAREN [@symbol ")"]
+%token LBRACKETAT [@symbol "[@"]
+%token LBRACKETATAT [@symbol "[@@"]
+%token LBRACKETATATAT [@symbol "[@@@"]
+%token MATCH [@symbol "match"]
+%token METHOD [@symbol "method"]
+%token MINUS [@symbol "-"]
+%token MINUSDOT [@symbol "-."]
+%token MINUSGREATER [@symbol "->"]
+%token MODULE [@symbol "module"]
+%token MUTABLE [@symbol "mutable"]
+%token NEW [@symbol "new"]
+%token NONREC [@cost 1] [@symbol "nonrec"]
+%token OBJECT [@symbol "object"]
+%token OF [@symbol "of"]
+%token OPEN [@symbol "open"]
+%token <string> OPTLABEL [@cost 2] [@recovery "_"][@printer Printf.sprintf "OPTLABEL(%S)"] [@symbol "?<label>"]
+%token OR [@symbol "or"]
+/* %token PARSER */
+%token PERCENT [@symbol "%"]
+%token PLUS [@symbol "+"]
+%token PLUSDOT [@symbol "+."]
+%token PLUSEQ [@symbol "+="]
+%token <string> PREFIXOP [@cost 2] [@recovery "!+"][@printer Printf.sprintf "PREFIXOP(%S)"] [@symbol "!+" (* chosen with care; see above *)]
+%token PRIVATE [@symbol "private"]
+%token QUESTION [@symbol "?"]
+%token QUOTE [@symbol "'"]
+%token RBRACE [@symbol "}"]
+%token RBRACKET [@symbol "]"]
+%token REC [@symbol "rec"]
+%token RPAREN [@symbol ")"]
+%token SEMI [@symbol ";"]
+%token SEMISEMI [@symbol ";;"]
+%token HASH [@symbol "#"]
+%token <string> HASHOP [@cost 2] [@recovery ""][@printer Printf.sprintf "HASHOP(%S)"] [@symbol "#<op>"]
+%token SIG [@symbol "sig"]
+%token STAR [@symbol "*"]
+%token <string * Location.t * string option> STRING "\"hello\"" [@cost 1] [@recovery ("", Location.none, None)][@printer string_of_STRING]
+%token
+  <string * Location.t * string * Location.t * string option>
+  QUOTED_STRING_EXPR "{%hello|world|}" [@cost 1] [@recovery ("", Location.none, "", Location.none, None)][@printer string_of_quoted_STRING]
+%token
+  <string * Location.t * string * Location.t * string option>
+  QUOTED_STRING_ITEM "{%%hello|world|}" [@cost 1] [@recovery ("", Location.none, "", Location.none, None)][@printer string_of_quoted_STRING]
+%token STRUCT [@symbol "struct"]
+%token THEN [@symbol "then"]
+%token TILDE [@symbol "~"]
+%token TO [@symbol "to"]
+%token TRUE [@symbol "true"]
+%token TRY [@symbol "try"]
+%token TYPE [@symbol "type"]
+%token <string> UIDENT [@cost 2][@recovery "_"][@printer Printf.sprintf "UIDENT(%S)"]
+%token UNDERSCORE [@symbol "_"]
+%token VAL [@symbol "val"]
+%token VIRTUAL [@symbol "virtual"]
+%token WHEN [@symbol "when"]
+%token WHILE [@symbol "while"]
+%token WITH [@symbol "with"]
+%token <string * Location.t> COMMENT "(* comment *)" [@cost 2][@recovery ("", Location.none)]
+%token <Docstrings.docstring> DOCSTRING "(** documentation *)"
+
+%token EOL                    "\\n"      (* not great, but EOL is unused *)
+
+%token LET_LWT [@cost 1] [@symbol "lwt"]
+%token TRY_LWT [@cost 1] [@symbol "try_lwt"]
+%token MATCH_LWT [@cost 1] [@symbol "match_lwt"]
+%token FINALLY_LWT [@cost 1] [@symbol "finally"]
+%token FOR_LWT [@cost 1] [@symbol "for_lwt"]
+%token WHILE_LWT [@cost 1] [@symbol "while_lwt"]
+
+%token DOTLESS [@cost 1] [@symbol ".<"]
+%token DOTTILDE [@cost 1] [@symbol ".~"]
+%token GREATERDOT [@cost 1] [@symbol ">."]
+
+/* Precedences and associativities.
+
+Tokens and rules have precedences.  A reduce/reduce conflict is resolved
+in favor of the first rule (in source file order).  A shift/reduce conflict
+is resolved by comparing the precedence and associativity of the token to
+be shifted with those of the rule to be reduced.
+
+By default, a rule has the precedence of its rightmost terminal (if any).
+
+When there is a shift/reduce conflict between a rule and a token that
+have the same precedence, it is resolved using the associativity:
+if the token is left-associative, the parser will reduce; if
+right-associative, the parser will shift; if non-associative,
+the parser will declare a syntax error.
+
+We will only use associativities with operators of the kind  x * x -> x
+for example, in the rules of the form    expr: expr BINOP expr
+in all other cases, we define two precedences if needed to resolve
+conflicts.
+
+The precedences must be listed from low to high.
+*/
+
+%nonassoc IN
+%nonassoc below_SEMI
+%nonassoc SEMI                          /* below EQUAL ({lbl=...; lbl=...}) */
+%nonassoc LET LET_LWT                   /* above SEMI ( ...; let ... in ...) */
+%nonassoc below_WITH
+%nonassoc FUNCTION WITH                 /* below BAR  (match ... with ...) */
+%nonassoc FINALLY_LWT
+%nonassoc AND             /* above WITH (module rec A: SIG with ... and ...) */
+%nonassoc THEN                          /* below ELSE (if ... then ...) */
+%nonassoc ELSE                          /* (if ... then ... else ...) */
+%nonassoc LESSMINUS                     /* below COLONEQUAL (lbl <- x := e) */
+%right    COLONEQUAL                    /* expr (e := e := e) */
+%nonassoc AS
+%left     BAR                           /* pattern (p|p|p) */
+%nonassoc below_COMMA
+%left     COMMA                         /* expr/expr_comma_list (e,e,e) */
+%right    MINUSGREATER                  /* function_type (t -> t -> t) */
+%right    OR BARBAR                     /* expr (e || e || e) */
+%right    AMPERSAND AMPERAMPER          /* expr (e && e && e) */
+%nonassoc below_EQUAL
+%left     INFIXOP0 EQUAL LESS GREATER   /* expr (e OP e OP e) */
+%right    INFIXOP1                      /* expr (e OP e OP e) */
+%nonassoc below_LBRACKETAT
+%nonassoc LBRACKETAT
+%right    COLONCOLON                    /* expr (e :: e :: e) */
+%left     INFIXOP2 PLUS PLUSDOT MINUS MINUSDOT PLUSEQ /* expr (e OP e OP e) */
+%left     PERCENT INFIXOP3 STAR                 /* expr (e OP e OP e) */
+%right    INFIXOP4                      /* expr (e OP e OP e) */
+%nonassoc prec_unary_minus prec_unary_plus /* unary - */
+%nonassoc prec_constant_constructor     /* cf. simple_expr (C versus C x) */
+%nonassoc prec_constr_appl              /* above AS BAR COLONCOLON COMMA */
+%left     prec_escape
+%nonassoc below_HASH
+%nonassoc HASH                        /* simple_expr/toplevel_directive */
+%left     HASHOP
+%nonassoc below_DOT
+%nonassoc DOT DOTOP
+/* Finally, the first tokens of simple_expr are above everything else. */
+%nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT INT
+          LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN
+          NEW PREFIXOP STRING TRUE UIDENT UNDERSCORE
+          LBRACKETPERCENT QUOTED_STRING_EXPR
+          DOTLESS DOTTILDE GREATERDOT
+
+
+/* Entry points */
+
+/* Several start symbols are marked with AVOID so that they are not used by
+   [make generate-parse-errors]. The three start symbols that we keep are
+   [implementation], [use_file], and [toplevel_phrase]. The latter two are
+   of marginal importance; only [implementation] really matters, since most
+   states in the automaton are reachable from it. */
+
+%start implementation                   /* for implementation files */
+%type <Parsetree.structure> implementation
+/* BEGIN AVOID */
+%start interface                        /* for interface files */
+%type <Parsetree.signature> interface
+/* END AVOID */
+%start toplevel_phrase                  /* for interactive use */
+%type <Parsetree.toplevel_phrase> toplevel_phrase
+%start use_file                         /* for the #use directive */
+%type <Parsetree.toplevel_phrase list> use_file
+/* BEGIN AVOID */
+%start parse_core_type
+%type <Parsetree.core_type> parse_core_type
+%start parse_expression
+%type <Parsetree.expression> parse_expression
+%start parse_pattern
+%type <Parsetree.pattern> parse_pattern
+%start parse_constr_longident
+%type <Longident.t> parse_constr_longident
+%start parse_val_longident
+%type <Longident.t> parse_val_longident
+%start parse_mty_longident
+%type <Longident.t> parse_mty_longident
+%start parse_mod_ext_longident
+%type <Longident.t> parse_mod_ext_longident
+%start parse_mod_longident
+%type <Longident.t> parse_mod_longident
+%start parse_any_longident
+%type <Longident.t> parse_any_longident
+/* END AVOID */
+
+%%
+
+/* macros */
+%inline extra_str(symb): symb { extra_str $startpos $endpos $1 };
+%inline extra_sig(symb): symb { extra_sig $startpos $endpos $1 };
+%inline extra_cstr(symb): symb { extra_cstr $startpos $endpos $1 };
+%inline extra_csig(symb): symb { extra_csig $startpos $endpos $1 };
+%inline extra_def(symb): symb { extra_def $startpos $endpos $1 };
+%inline extra_text(symb): symb { extra_text $startpos $endpos $1 };
+%inline extra_rhs(symb): symb { extra_rhs_core_type $1 ~pos:$endpos($1) };
+%inline mkrhs(symb): symb
+    { mkrhs $1 $sloc }
+;
+
+%inline text_str(symb): symb
+  { text_str $startpos @ [$1] }
+%inline text_str_SEMISEMI: SEMISEMI
+  { text_str $startpos }
+%inline text_sig(symb): symb
+  { text_sig $startpos @ [$1] }
+%inline text_sig_SEMISEMI: SEMISEMI
+  { text_sig $startpos }
+%inline text_def(symb): symb
+  { text_def $startpos @ [$1] }
+%inline top_def(symb): symb
+  { Ptop_def [$1] }
+%inline text_cstr(symb): symb
+  { text_cstr $startpos @ [$1] }
+%inline text_csig(symb): symb
+  { text_csig $startpos @ [$1] }
+
+(* Using this %inline definition means that we do not control precisely
+   when [mark_rhs_docs] is called, but I dont think this matters. *)
+%inline mark_rhs_docs(symb): symb
+  { mark_rhs_docs $startpos $endpos;
+    $1 }
+
+%inline op(symb): symb
+   { mkoperator ~loc:$sloc $1 }
+
+%inline mkloc(symb): symb
+    { mkloc $1 (make_loc $sloc) }
+
+%inline mkexp(symb): symb
+    { mkexp ~loc:$sloc $1 }
+%inline mkpat(symb): symb
+    { mkpat ~loc:$sloc $1 }
+%inline mktyp(symb): symb
+    { mktyp ~loc:$sloc $1 }
+%inline mkstr(symb): symb
+    { mkstr ~loc:$sloc $1 }
+%inline mksig(symb): symb
+    { mksig ~loc:$sloc $1 }
+%inline mkmod(symb): symb
+    { mkmod ~loc:$sloc $1 }
+%inline mkmty(symb): symb
+    { mkmty ~loc:$sloc $1 }
+%inline mkcty(symb): symb
+    { mkcty ~loc:$sloc $1 }
+%inline mkctf(symb): symb
+    { mkctf ~loc:$sloc $1 }
+%inline mkcf(symb): symb
+    { mkcf ~loc:$sloc $1 }
+%inline mkclass(symb): symb
+    { mkclass ~loc:$sloc $1 }
+
+%inline wrap_mkstr_ext(symb): symb
+    { wrap_mkstr_ext ~loc:$sloc $1 }
+%inline wrap_mksig_ext(symb): symb
+    { wrap_mksig_ext ~loc:$sloc $1 }
+
+%inline mk_directive_arg(symb): symb
+    { mk_directive_arg ~loc:$sloc $1 }
+
+/* Generic definitions */
+
+(* [iloption(X)] recognizes either nothing or [X]. Assuming [X] produces
+   an OCaml list, it produces an OCaml list, too. *)
+
+%inline iloption(X):
+  /* nothing */
+    { [] }
+| x = X
+    { x }
+
+(* [llist(X)] recognizes a possibly empty list of [X]s. It is left-recursive. *)
+
+reversed_llist(X):
+  /* empty */
+    { [] }
+| xs = reversed_llist(X) x = X
+    { x :: xs }
+
+%inline llist(X):
+  xs = rev(reversed_llist(X))
+    { xs }
+
+(* [reversed_nonempty_llist(X)] recognizes a nonempty list of [X]s, and produces
+   an OCaml list in reverse order -- that is, the last element in the input text
+   appears first in this list. Its definition is left-recursive. *)
+
+reversed_nonempty_llist(X):
+  x = X
+    { [ x ] }
+| xs = reversed_nonempty_llist(X) x = X
+    { x :: xs }
+
+(* [nonempty_llist(X)] recognizes a nonempty list of [X]s, and produces an OCaml
+   list in direct order -- that is, the first element in the input text appears
+   first in this list. *)
+
+%inline nonempty_llist(X):
+  xs = rev(reversed_nonempty_llist(X))
+    { xs }
+
+(* [reversed_separated_nonempty_llist(separator, X)] recognizes a nonempty list
+   of [X]s, separated with [separator]s, and produces an OCaml list in reverse
+   order -- that is, the last element in the input text appears first in this
+   list. Its definition is left-recursive. *)
+
+(* [inline_reversed_separated_nonempty_llist(separator, X)] is semantically
+   equivalent to [reversed_separated_nonempty_llist(separator, X)], but is
+   marked %inline, which means that the case of a list of length one and
+   the case of a list of length more than one will be distinguished at the
+   use site, and will give rise there to two productions. This can be used
+   to avoid certain conflicts. *)
+
+%inline inline_reversed_separated_nonempty_llist(separator, X):
+  x = X
+    { [ x ] }
+| xs = reversed_separated_nonempty_llist(separator, X)
+  separator
+  x = X
+    { x :: xs }
+
+reversed_separated_nonempty_llist(separator, X):
+  xs = inline_reversed_separated_nonempty_llist(separator, X)
+    { xs }
+
+(* [separated_nonempty_llist(separator, X)] recognizes a nonempty list of [X]s,
+   separated with [separator]s, and produces an OCaml list in direct order --
+   that is, the first element in the input text appears first in this list. *)
+
+%inline separated_nonempty_llist(separator, X):
+  xs = rev(reversed_separated_nonempty_llist(separator, X))
+    { xs }
+
+%inline inline_separated_nonempty_llist(separator, X):
+  xs = rev(inline_reversed_separated_nonempty_llist(separator, X))
+    { xs }
+
+(* [reversed_separated_nontrivial_llist(separator, X)] recognizes a list of at
+   least two [X]s, separated with [separator]s, and produces an OCaml list in
+   reverse order -- that is, the last element in the input text appears first
+   in this list. Its definition is left-recursive. *)
+
+reversed_separated_nontrivial_llist(separator, X):
+  xs = reversed_separated_nontrivial_llist(separator, X)
+  separator
+  x = X
+    { x :: xs }
+| x1 = X
+  separator
+  x2 = X
+    { [ x2; x1 ] }
+
+(* [separated_nontrivial_llist(separator, X)] recognizes a list of at least
+   two [X]s, separated with [separator]s, and produces an OCaml list in direct
+   order -- that is, the first element in the input text appears first in this
+   list. *)
+
+%inline separated_nontrivial_llist(separator, X):
+  xs = rev(reversed_separated_nontrivial_llist(separator, X))
+    { xs }
+
+(* [separated_or_terminated_nonempty_list(delimiter, X)] recognizes a nonempty
+   list of [X]s, separated with [delimiter]s, and optionally terminated with a
+   final [delimiter]. Its definition is right-recursive. *)
+
+separated_or_terminated_nonempty_list(delimiter, X):
+  x = X ioption(delimiter)
+    { [x] }
+| x = X
+  delimiter
+  xs = separated_or_terminated_nonempty_list(delimiter, X)
+    { x :: xs }
+
+(* [reversed_preceded_or_separated_nonempty_llist(delimiter, X)] recognizes a
+   nonempty list of [X]s, separated with [delimiter]s, and optionally preceded
+   with a leading [delimiter]. It produces an OCaml list in reverse order. Its
+   definition is left-recursive. *)
+
+reversed_preceded_or_separated_nonempty_llist(delimiter, X):
+  ioption(delimiter) x = X
+    { [x] }
+| xs = reversed_preceded_or_separated_nonempty_llist(delimiter, X)
+  delimiter
+  x = X
+    { x :: xs }
+
+(* [preceded_or_separated_nonempty_llist(delimiter, X)] recognizes a nonempty
+   list of [X]s, separated with [delimiter]s, and optionally preceded with a
+   leading [delimiter]. It produces an OCaml list in direct order. *)
+
+%inline preceded_or_separated_nonempty_llist(delimiter, X):
+  xs = rev(reversed_preceded_or_separated_nonempty_llist(delimiter, X))
+    { xs }
+
+(* [bar_llist(X)] recognizes a nonempty list of [X]s, separated with BARs,
+   with an optional leading BAR. We assume that [X] is itself parameterized
+   with an opening symbol, which can be [epsilon] or [BAR]. *)
+
+(* This construction may seem needlessly complicated: one might think that
+   using [preceded_or_separated_nonempty_llist(BAR, X)], where [X] is *not*
+   itself parameterized, would be sufficient. Indeed, this simpler approach
+   would recognize the same language. However, the two approaches differ in
+   the footprint of [X]. We want the start location of [X] to include [BAR]
+   when present. In the future, we might consider switching to the simpler
+   definition, at the cost of producing slightly different locations. TODO *)
+
+reversed_bar_llist(X):
+    (* An [X] without a leading BAR. *)
+    x = X(epsilon)
+      { [x] }
+  | (* An [X] with a leading BAR. *)
+    x = X(BAR)
+      { [x] }
+  | (* An initial list, followed with a BAR and an [X]. *)
+    xs = reversed_bar_llist(X)
+    x = X(BAR)
+      { x :: xs }
+
+%inline bar_llist(X):
+  xs = reversed_bar_llist(X)
+    { List.rev xs }
+
+(* [xlist(A, B)] recognizes [AB*]. We assume that the semantic value for [A]
+   is a pair [x, b], while the semantic value for [B*] is a list [bs].
+   We return the pair [x, b :: bs]. *)
+
+%inline xlist(A, B):
+  a = A bs = B*
+    { let (x, b) = a in x, b :: bs }
+
+(* [listx(delimiter, X, Y)] recognizes a nonempty list of [X]s, optionally
+   followed with a [Y], separated-or-terminated with [delimiter]s. The
+   semantic value is a pair of a list of [X]s and an optional [Y]. *)
+
+listx(delimiter, X, Y):
+| x = X ioption(delimiter)
+    { [x], None }
+| x = X delimiter y = Y delimiter?
+    { [x], Some y }
+| x = X
+  delimiter
+  tail = listx(delimiter, X, Y)
+    { let xs, y = tail in
+      x :: xs, y }
+
+(* -------------------------------------------------------------------------- *)
+
+(* Entry points. *)
+
+(* An .ml file. *)
+implementation:
+  structure EOF
+    { $1 }
+;
+
+/* BEGIN AVOID */
+(* An .mli file. *)
+interface:
+  signature EOF
+    { $1 }
+;
+/* END AVOID */
+
+(* A toplevel phrase. *)
+toplevel_phrase:
+  (* An expression with attributes, ended by a double semicolon. *)
+  extra_str(text_str(str_exp))
+  SEMISEMI
+    { Ptop_def $1 }
+| (* A list of structure items, ended by a double semicolon. *)
+  extra_str(flatten(text_str(structure_item)*))
+  SEMISEMI
+    { Ptop_def $1 }
+| (* A directive, ended by a double semicolon. *)
+  toplevel_directive
+  SEMISEMI
+    { $1 }
+| (* End of input. *)
+  EOF
+    { raise End_of_file }
+;
+
+(* An .ml file that is read by #use. *)
+use_file:
+  (* An optional standalone expression,
+     followed with a series of elements,
+     followed with EOF. *)
+  extra_def(append(
+    optional_use_file_standalone_expression,
+    flatten(use_file_element*)
+  ))
+  EOF
+    { $1 }
+;
+
+(* An optional standalone expression is just an expression with attributes
+   (str_exp), with extra wrapping. *)
+%inline optional_use_file_standalone_expression:
+  iloption(text_def(top_def(str_exp)))
+    { $1 }
+;
+
+(* An element in a #used file is one of the following:
+   - a double semicolon followed with an optional standalone expression;
+   - a structure item;
+   - a toplevel directive.
+ *)
+%inline use_file_element:
+  preceded(SEMISEMI, optional_use_file_standalone_expression)
+| text_def(top_def(structure_item))
+| text_def(mark_rhs_docs(toplevel_directive))
+      { $1 }
+;
+
+/* BEGIN AVOID */
+parse_core_type:
+  core_type EOF
+    { $1 }
+;
+
+parse_expression:
+  seq_expr EOF
+    { $1 }
+;
+
+parse_pattern:
+  pattern EOF
+    { $1 }
+;
+
+parse_mty_longident:
+  mty_longident EOF
+    { $1 }
+;
+
+parse_val_longident:
+  val_longident EOF
+    { $1 }
+;
+
+parse_constr_longident:
+  constr_longident EOF
+    { $1 }
+;
+
+parse_mod_ext_longident:
+  mod_ext_longident EOF
+    { $1 }
+;
+
+parse_mod_longident:
+  mod_longident EOF
+    { $1 }
+;
+
+parse_any_longident:
+  any_longident EOF
+    { $1 }
+;
+/* END AVOID */
+
+(* -------------------------------------------------------------------------- *)
+
+(* Functor arguments appear in module expressions and module types. *)
+
+(* There was an inline here, but I removed it. *)
+functor_args [@recovery []]:
+  reversed_nonempty_llist(functor_arg)
+    { $1 }
+    (* Produce a reversed list on purpose;
+       later processed using [fold_left]. *)
+;
+
+functor_arg:
+    (* An anonymous and untyped argument. *)
+    LPAREN RPAREN
+      { $startpos, Unit }
+  | (* An argument accompanied with an explicit type. *)
+    LPAREN x = mkrhs(module_name) COLON mty = module_type RPAREN
+      { $startpos, Named (x, mty) }
+;
+
+module_name:
+    (* A named argument. *)
+    x = UIDENT
+      { Some x }
+  | (* An anonymous argument. *)
+    UNDERSCORE
+      { None }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+(* Module expressions. *)
+
+(* The syntax of module expressions is not properly stratified. The cases of
+   functors, functor applications, and attributes interact and cause conflicts,
+   which are resolved by precedence declarations. This is concise but fragile.
+   Perhaps in the future an explicit stratification could be used. *)
+
+module_expr [@recovery default_module_expr ()]:
+  | STRUCT attrs = attributes s = structure END
+      { mkmod ~loc:$sloc ~attrs (Pmod_structure s) }
+  (*
+  | STRUCT attributes structure error
+      { unclosed "struct" $loc($1) "end" $loc($4) }
+  *)
+  | FUNCTOR attrs = attributes args = functor_args MINUSGREATER me = module_expr
+      { wrap_mod_attrs ~loc:$sloc attrs (
+          List.fold_left (fun acc (startpos, arg) ->
+            mkmod ~loc:(startpos, $endpos) (Pmod_functor (arg, acc))
+          ) me args
+        ) }
+  | me = paren_module_expr
+      { me }
+  | me = module_expr attr = attribute
+      { Mod.attr me attr }
+  | mkmod(
+      (* A module identifier. *)
+      x = mkrhs(mod_longident)
+        { Pmod_ident x }
+    | (* In a functor application, the actual argument must be parenthesized. *)
+      me1 = module_expr me2 = paren_module_expr
+        { Pmod_apply(me1, me2) }
+    | (* Application to unit is sugar for application to an empty structure. *)
+      me1 = module_expr LPAREN RPAREN
+        { (* TODO review mkmod location *)
+          Pmod_apply(me1, mkmod ~loc:$sloc (Pmod_structure [])) }
+    | (* An extension. *)
+      ex = extension
+        { Pmod_extension ex }
+    | (* A hole. *)
+      UNDERSCORE
+        { let id = mkrhs Ast_helper.hole_txt $loc in
+          Pmod_extension (id, PStr []) }
+    )
+    { $1 }
+;
+
+(* A parenthesized module expression is a module expression that begins
+   and ends with parentheses. *)
+
+paren_module_expr:
+    (* A module expression annotated with a module type. *)
+    LPAREN me = module_expr COLON mty = module_type RPAREN
+      { mkmod ~loc:$sloc (Pmod_constraint(me, mty)) }
+  (*
+  | LPAREN module_expr COLON module_type error
+      { unclosed "(" $loc($1) ")" $loc($5) }
+  *)
+  | (* A module expression within parentheses. *)
+    LPAREN me = module_expr RPAREN
+      { me (* TODO consider reloc *) }
+  (*
+  | LPAREN module_expr error
+      { unclosed "(" $loc($1) ")" $loc($3) }
+  *)
+  | (* A core language expression that produces a first-class module.
+       This expression can be annotated in various ways. *)
+    LPAREN VAL attrs = attributes e = expr_colon_package_type RPAREN
+      { mkmod ~loc:$sloc ~attrs (Pmod_unpack e) }
+  (*
+  | LPAREN VAL attributes expr COLON error
+      { unclosed "(" $loc($1) ")" $loc($6) }
+  | LPAREN VAL attributes expr COLONGREATER error
+      { unclosed "(" $loc($1) ")" $loc($6) }
+  | LPAREN VAL attributes expr error
+      { unclosed "(" $loc($1) ")" $loc($5) }
+  *)
+;
+
+(* The various ways of annotating a core language expression that
+   produces a first-class module that we wish to unpack. *)
+%inline expr_colon_package_type:
+    e = expr
+      { e }
+  | e = expr COLON ty = package_type
+      { ghexp ~loc:$loc (Pexp_constraint (e, ty)) }
+  | e = expr COLON ty1 = package_type COLONGREATER ty2 = package_type
+      { ghexp ~loc:$loc (Pexp_coerce (e, Some ty1, ty2)) }
+  | e = expr COLONGREATER ty2 = package_type
+      { ghexp ~loc:$loc (Pexp_coerce (e, None, ty2)) }
+;
+
+(* A structure, which appears between STRUCT and END (among other places),
+   begins with an optional standalone expression, and continues with a list
+   of structure elements. *)
+structure [@recovery []]:
+  extra_str(append(
+    optional_structure_standalone_expression,
+    flatten(structure_element*)
+  ))
+  { $1 }
+;
+
+(* An optional standalone expression is just an expression with attributes
+   (str_exp), with extra wrapping. *)
+%inline optional_structure_standalone_expression:
+  items = iloption(mark_rhs_docs(text_str(str_exp)))
+    { items }
+;
+
+(* An expression with attributes, wrapped as a structure item. *)
+%inline str_exp:
+  e = seq_expr
+  attrs = post_item_attributes
+    { mkstrexp e attrs }
+;
+
+(* A structure element is one of the following:
+   - a double semicolon followed with an optional standalone expression;
+   - a structure item. *)
+%inline structure_element:
+    append(text_str_SEMISEMI, optional_structure_standalone_expression)
+  | text_str(structure_item)
+      { $1 }
+;
+
+(* A structure item. *)
+%public structure_item:
+    let_bindings(ext)
+      { val_of_let_bindings ~loc:$sloc $1 }
+  | mkstr(
+      item_extension post_item_attributes
+        { let docs = symbol_docs $sloc in
+          Pstr_extension ($1, add_docs_attrs docs $2) }
+    | floating_attribute
+        { Pstr_attribute $1 }
+    )
+  | wrap_mkstr_ext(
+      primitive_declaration
+        { pstr_primitive $1 }
+    | value_description
+        { pstr_primitive $1 }
+    | type_declarations
+        { pstr_type $1 }
+    | str_type_extension
+        { pstr_typext $1 }
+    | str_exception_declaration
+        { pstr_exception $1 }
+    | module_binding
+        { $1 }
+    | rec_module_bindings
+        { pstr_recmodule $1 }
+    | module_type_declaration
+        { let (body, ext) = $1 in (Pstr_modtype body, ext) }
+    | open_declaration
+        { let (body, ext) = $1 in (Pstr_open body, ext) }
+    | class_declarations
+        { let (ext, l) = $1 in (Pstr_class l, ext) }
+    | class_type_declarations
+        { let (ext, l) = $1 in (Pstr_class_type l, ext) }
+    | include_statement(module_expr)
+        { pstr_include $1 }
+    )
+    { $1 }
+;
+
+(* A single module binding. *)
+%inline module_binding:
+  MODULE
+  ext = ext attrs1 = attributes
+  name = mkrhs(module_name)
+  body = module_binding_body
+  attrs2 = post_item_attributes
+    { let docs = symbol_docs $sloc in
+      let loc = make_loc $sloc in
+      let attrs = attrs1 @ attrs2 in
+      let body = Mb.mk name body ~attrs ~loc ~docs in
+      Pstr_module body, ext }
+;
+
+(* The body (right-hand side) of a module binding. *)
+module_binding_body:
+    EQUAL me = module_expr
+      { me }
+  | mkmod(
+      COLON mty = module_type EQUAL me = module_expr
+        { Pmod_constraint(me, mty) }
+    | arg_and_pos = functor_arg body = module_binding_body
+        { let (_, arg) = arg_and_pos in
+          Pmod_functor(arg, body) }
+  ) { $1 }
+;
+
+(* A group of recursive module bindings. *)
+%inline rec_module_bindings:
+  xlist(rec_module_binding, and_module_binding)
+    { $1 }
+;
+
+(* The first binding in a group of recursive module bindings. *)
+%inline rec_module_binding:
+  MODULE
+  ext = ext
+  attrs1 = attributes
+  REC
+  name = mkrhs(module_name)
+  body = module_binding_body
+  attrs2 = post_item_attributes
+  {
+    let loc = make_loc $sloc in
+    let attrs = attrs1 @ attrs2 in
+    let docs = symbol_docs $sloc in
+    ext,
+    Mb.mk name body ~attrs ~loc ~docs
+  }
+;
+
+(* The following bindings in a group of recursive module bindings. *)
+%inline and_module_binding:
+  AND
+  attrs1 = attributes
+  name = mkrhs(module_name)
+  body = module_binding_body
+  attrs2 = post_item_attributes
+  {
+    let loc = make_loc $sloc in
+    let attrs = attrs1 @ attrs2 in
+    let docs = symbol_docs $sloc in
+    let text = symbol_text $symbolstartpos in
+    Mb.mk name body ~attrs ~loc ~text ~docs
+  }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+(* Shared material between structures and signatures. *)
+
+(* An [include] statement can appear in a structure or in a signature,
+   which is why this definition is parameterized. *)
+%inline include_statement(thing):
+  INCLUDE
+  ext = ext
+  attrs1 = attributes
+  thing = thing
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Incl.mk thing ~attrs ~loc ~docs, ext
+  }
+;
+
+(* A module type declaration. *)
+module_type_declaration:
+  MODULE TYPE
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(ident)
+  typ = preceded(EQUAL, module_type)?
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Mtd.mk id ?typ ~attrs ~loc ~docs, ext
+  }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+(* Opens. *)
+
+open_declaration:
+  OPEN
+  override = override_flag
+  ext = ext
+  attrs1 = attributes
+  me = module_expr
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Opn.mk me ~override ~attrs ~loc ~docs, ext
+  }
+;
+
+open_description:
+  OPEN
+  override = override_flag
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(mod_ext_longident)
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Opn.mk id ~override ~attrs ~loc ~docs, ext
+  }
+;
+
+%inline open_dot_declaration: mkrhs(mod_longident)
+  { let loc = make_loc $loc($1) in
+    let me = Mod.ident ~loc $1 in
+    Opn.mk ~loc me }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+/* Module types */
+
+module_type [@recovery default_module_type ()]:
+  | SIG attrs = attributes s = signature END
+      { mkmty ~loc:$sloc ~attrs (Pmty_signature s) }
+  (*
+  | SIG attributes signature error
+      { unclosed "sig" $loc($1) "end" $loc($4) }
+  *)
+  | FUNCTOR attrs = attributes args = functor_args
+    MINUSGREATER mty = module_type
+      %prec below_WITH
+      { wrap_mty_attrs ~loc:$sloc attrs (
+          List.fold_left (fun acc (startpos, arg) ->
+            mkmty ~loc:(startpos, $endpos) (Pmty_functor (arg, acc))
+          ) mty args
+        ) }
+  | MODULE TYPE OF attributes module_expr %prec below_LBRACKETAT
+      { mkmty ~loc:$sloc ~attrs:$4 (Pmty_typeof $5) }
+  | LPAREN module_type RPAREN
+      { $2 }
+  (*
+  | LPAREN module_type error
+      { unclosed "(" $loc($1) ")" $loc($3) }
+  *)
+  | module_type attribute
+      { Mty.attr $1 $2 }
+  | mkmty(
+      mkrhs(mty_longident)
+        { Pmty_ident $1 }
+    | module_type MINUSGREATER module_type
+        %prec below_WITH
+        { Pmty_functor(Named (mknoloc None, $1), $3) }
+    | module_type WITH separated_nonempty_llist(AND, with_constraint)
+        { Pmty_with($1, $3) }
+/*  | LPAREN MODULE mkrhs(mod_longident) RPAREN
+        { Pmty_alias $3 } */
+    | extension
+        { Pmty_extension $1 }
+    )
+    { $1 }
+;
+(* A signature, which appears between SIG and END (among other places),
+   is a list of signature elements. *)
+signature:
+  extra_sig(flatten(signature_element*))
+    { $1 }
+;
+
+(* A signature element is one of the following:
+   - a double semicolon;
+   - a signature item. *)
+%inline signature_element:
+    text_sig_SEMISEMI
+  | text_sig(signature_item)
+      { $1 }
+;
+
+(* A signature item. *)
+signature_item:
+  | item_extension post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mksig ~loc:$sloc (Psig_extension ($1, (add_docs_attrs docs $2))) }
+  | mksig(
+      floating_attribute
+        { Psig_attribute $1 }
+    )
+    { $1 }
+  | wrap_mksig_ext(
+      value_description
+        { psig_value $1 }
+    | primitive_declaration
+        { psig_value $1 }
+    | type_declarations
+        { psig_type $1 }
+    | type_subst_declarations
+        { psig_typesubst $1 }
+    | sig_type_extension
+        { psig_typext $1 }
+    | sig_exception_declaration
+        { psig_exception $1 }
+    | module_declaration
+        { let (body, ext) = $1 in (Psig_module body, ext) }
+    | module_alias
+        { let (body, ext) = $1 in (Psig_module body, ext) }
+    | module_subst
+        { let (body, ext) = $1 in (Psig_modsubst body, ext) }
+    | rec_module_declarations
+        { let (ext, l) = $1 in (Psig_recmodule l, ext) }
+    | module_type_declaration
+        { let (body, ext) = $1 in (Psig_modtype body, ext) }
+    | module_type_subst
+        { let (body, ext) = $1 in (Psig_modtypesubst body, ext) }
+    | open_description
+        { let (body, ext) = $1 in (Psig_open body, ext) }
+    | include_statement(module_type)
+        { psig_include $1 }
+    | class_descriptions
+        { let (ext, l) = $1 in (Psig_class l, ext) }
+    | class_type_declarations
+        { let (ext, l) = $1 in (Psig_class_type l, ext) }
+    )
+    { $1 }
+
+(* A module declaration. *)
+%inline module_declaration:
+  MODULE
+  ext = ext attrs1 = attributes
+  name = mkrhs(module_name)
+  body = module_declaration_body
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Md.mk name body ~attrs ~loc ~docs, ext
+  }
+;
+
+(* The body (right-hand side) of a module declaration. *)
+module_declaration_body:
+    COLON mty = module_type
+      { mty }
+  | mkmty(
+      arg_and_pos = functor_arg body = module_declaration_body
+        { let (_, arg) = arg_and_pos in
+          Pmty_functor(arg, body) }
+    )
+    { $1 }
+;
+
+(* A module alias declaration (in a signature). *)
+%inline module_alias:
+  MODULE
+  ext = ext attrs1 = attributes
+  name = mkrhs(module_name)
+  EQUAL
+  body = module_expr_alias
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Md.mk name body ~attrs ~loc ~docs, ext
+  }
+;
+%inline module_expr_alias:
+  id = mkrhs(mod_longident)
+    { Mty.alias ~loc:(make_loc $sloc) id }
+;
+(* A module substitution (in a signature). *)
+module_subst:
+  MODULE
+  ext = ext attrs1 = attributes
+  uid = mkrhs(UIDENT)
+  COLONEQUAL
+  body = mkrhs(mod_ext_longident)
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Ms.mk uid body ~attrs ~loc ~docs, ext
+  }
+(*
+| MODULE ext attributes mkrhs(UIDENT) COLONEQUAL error
+    { expecting $loc($6) "module path" }
+*)
+;
+
+(* A group of recursive module declarations. *)
+%inline rec_module_declarations:
+  xlist(rec_module_declaration, and_module_declaration)
+    { $1 }
+;
+%inline rec_module_declaration:
+  MODULE
+  ext = ext
+  attrs1 = attributes
+  REC
+  name = mkrhs(module_name)
+  COLON
+  mty = module_type
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    ext, Md.mk name mty ~attrs ~loc ~docs
+  }
+;
+%inline and_module_declaration:
+  AND
+  attrs1 = attributes
+  name = mkrhs(module_name)
+  COLON
+  mty = module_type
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let docs = symbol_docs $sloc in
+    let loc = make_loc $sloc in
+    let text = symbol_text $symbolstartpos in
+    Md.mk name mty ~attrs ~loc ~text ~docs
+  }
+;
+
+(* A module type substitution *)
+module_type_subst:
+  MODULE TYPE
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(ident)
+  COLONEQUAL
+  typ=module_type
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Mtd.mk id ~typ ~attrs ~loc ~docs, ext
+  }
+
+
+(* -------------------------------------------------------------------------- *)
+
+(* Class declarations. *)
+
+%inline class_declarations:
+  xlist(class_declaration, and_class_declaration)
+    { $1 }
+;
+%inline class_declaration:
+  CLASS
+  ext = ext
+  attrs1 = attributes
+  virt = virtual_flag
+  params = formal_class_parameters
+  id = mkrhs(LIDENT)
+  body = class_fun_binding
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    ext,
+    Ci.mk id body ~virt ~params ~attrs ~loc ~docs
+  }
+;
+%inline and_class_declaration:
+  AND
+  attrs1 = attributes
+  virt = virtual_flag
+  params = formal_class_parameters
+  id = mkrhs(LIDENT)
+  body = class_fun_binding
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    let text = symbol_text $symbolstartpos in
+    Ci.mk id body ~virt ~params ~attrs ~loc ~text ~docs
+  }
+;
+
+class_fun_binding:
+    EQUAL class_expr
+      { $2 }
+  | mkclass(
+      COLON class_type EQUAL class_expr
+        { Pcl_constraint($4, $2) }
+    | labeled_simple_pattern class_fun_binding
+      { let (l,o,p) = $1 in Pcl_fun(l, o, p, $2) }
+    ) { $1 }
+;
+
+formal_class_parameters:
+  params = class_parameters(type_parameter)
+    { params }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+(* Class expressions. *)
+
+class_expr:
+    class_simple_expr
+      { $1 }
+  | FUN attributes class_fun_def
+      { wrap_class_attrs ~loc:$sloc $3 $2 }
+  | let_bindings(no_ext) IN class_expr
+      { class_of_let_bindings ~loc:$sloc $1 $3 }
+  | LET OPEN override_flag attributes mkrhs(mod_longident) IN class_expr
+      { let loc = ($startpos($2), $endpos($5)) in
+        let od = Opn.mk ~override:$3 ~loc:(make_loc loc) $5 in
+        mkclass ~loc:$sloc ~attrs:$4 (Pcl_open(od, $7)) }
+  | class_expr attribute
+      { Cl.attr $1 $2 }
+  | mkclass(
+      class_simple_expr nonempty_llist(labeled_simple_expr)
+        { Pcl_apply($1, $2) }
+    | extension
+        { Pcl_extension $1 }
+    ) { $1 }
+;
+class_simple_expr:
+  | LPAREN class_expr RPAREN
+      { $2 }
+  (*
+  | LPAREN class_expr error
+      { unclosed "(" $loc($1) ")" $loc($3) }
+  *)
+  | mkclass(
+      tys = actual_class_parameters cid = mkrhs(class_longident)
+        { Pcl_constr(cid, tys) }
+    (*
+    | OBJECT attributes class_structure error
+        { unclosed "object" $loc($1) "end" $loc($4) }
+    *)
+    | LPAREN class_expr COLON class_type RPAREN
+        { Pcl_constraint($2, $4) }
+    (*
+    | LPAREN class_expr COLON class_type error
+        { unclosed "(" $loc($1) ")" $loc($5) }
+    *)
+    ) { $1 }
+  | OBJECT attributes class_structure END
+    { mkclass ~loc:$sloc ~attrs:$2 (Pcl_structure $3) }
+;
+
+class_fun_def:
+  mkclass(
+    labeled_simple_pattern MINUSGREATER e = class_expr
+  | labeled_simple_pattern e = class_fun_def
+      { let (l,o,p) = $1 in Pcl_fun(l, o, p, e) }
+  ) { $1 }
+;
+%inline class_structure:
+  |  class_self_pattern extra_cstr(class_fields)
+       { Cstr.mk $1 $2 }
+;
+class_self_pattern:
+    LPAREN pattern RPAREN
+      { reloc_pat ~loc:$sloc $2 }
+  | mkpat(LPAREN pattern COLON core_type RPAREN
+      { Ppat_constraint($2, $4) })
+      { $1 }
+  | /* empty */
+      { ghpat ~loc:$sloc Ppat_any }
+;
+%inline class_fields:
+  flatten(text_cstr(class_field)*)
+    { $1 }
+;
+class_field:
+  | INHERIT override_flag attributes class_expr
+    self = preceded(AS, mkrhs(LIDENT))?
+    post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkcf ~loc:$sloc (Pcf_inherit ($2, $4, self)) ~attrs:($3@$6) ~docs }
+  | VAL value post_item_attributes
+      { let v, attrs = $2 in
+        let docs = symbol_docs $sloc in
+        mkcf ~loc:$sloc (Pcf_val v) ~attrs:(attrs@$3) ~docs }
+  | METHOD method_ post_item_attributes
+      { let meth, attrs = $2 in
+        let docs = symbol_docs $sloc in
+        mkcf ~loc:$sloc (Pcf_method meth) ~attrs:(attrs@$3) ~docs }
+  | CONSTRAINT attributes constrain_field post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkcf ~loc:$sloc (Pcf_constraint $3) ~attrs:($2@$4) ~docs }
+  | INITIALIZER attributes seq_expr post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkcf ~loc:$sloc (Pcf_initializer $3) ~attrs:($2@$4) ~docs }
+  | item_extension post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkcf ~loc:$sloc (Pcf_extension $1) ~attrs:$2 ~docs }
+  | mkcf(floating_attribute
+      { Pcf_attribute $1 })
+      { $1 }
+;
+value:
+    no_override_flag
+    attrs = attributes
+    mutable_ = virtual_with_mutable_flag
+    label = mkrhs(label) COLON ty = core_type
+      { (label, mutable_, Cfk_virtual ty), attrs }
+  | override_flag attributes mutable_flag mkrhs(label) EQUAL seq_expr
+      { ($4, $3, Cfk_concrete ($1, $6)), $2 }
+  | override_flag attributes mutable_flag mkrhs(label) type_constraint
+    EQUAL seq_expr
+      { let e = mkexp_constraint ~loc:$sloc $7 $5 in
+        ($4, $3, Cfk_concrete ($1, e)), $2
+      }
+;
+method_:
+    no_override_flag
+    attrs = attributes
+    private_ = virtual_with_private_flag
+    label = mkrhs(label) COLON ty = poly_type
+      { (label, private_, Cfk_virtual ty), attrs }
+  | override_flag attributes private_flag mkrhs(label) strict_binding
+      { let e = $5 in
+        let loc = Location.(e.pexp_loc.loc_start, e.pexp_loc.loc_end) in
+        ($4, $3,
+        Cfk_concrete ($1, ghexp ~loc (Pexp_poly (e, None)))), $2 }
+  | override_flag attributes private_flag mkrhs(label)
+    COLON poly_type EQUAL seq_expr
+      { let poly_exp =
+          let loc = ($startpos($6), $endpos($8)) in
+          ghexp ~loc (Pexp_poly($8, Some $6)) in
+        ($4, $3, Cfk_concrete ($1, poly_exp)), $2 }
+  | override_flag attributes private_flag mkrhs(label) COLON TYPE lident_list
+    DOT core_type EQUAL seq_expr
+      { let poly_exp_loc = ($startpos($7), $endpos($11)) in
+        let poly_exp =
+          let exp, poly =
+            (* it seems odd to use the global ~loc here while poly_exp_loc
+               is tighter, but this is what ocamlyacc does;
+               TODO improve parser.mly *)
+            wrap_type_annotation ~loc:$sloc $7 $9 $11 in
+          ghexp ~loc:poly_exp_loc (Pexp_poly(exp, Some poly)) in
+        ($4, $3,
+        Cfk_concrete ($1, poly_exp)), $2 }
+;
+
+/* Class types */
+
+class_type:
+    class_signature
+      { $1 }
+  | mkcty(
+      label = arg_label
+      domain = tuple_type
+      MINUSGREATER
+      codomain = class_type
+        { Pcty_arrow(label, domain, codomain) }
+    ) { $1 }
+ ;
+class_signature:
+    mkcty(
+      tys = actual_class_parameters cid = mkrhs(clty_longident)
+        { Pcty_constr (cid, tys) }
+    | extension
+        { Pcty_extension $1 }
+    ) { $1 }
+  | OBJECT attributes class_sig_body END
+      { mkcty ~loc:$sloc ~attrs:$2 (Pcty_signature $3) }
+  (*
+  | OBJECT attributes class_sig_body error
+      { unclosed "object" $loc($1) "end" $loc($4) }
+  *)
+  | class_signature attribute
+      { Cty.attr $1 $2 }
+  | LET OPEN override_flag attributes mkrhs(mod_longident) IN class_signature
+      { let loc = ($startpos($2), $endpos($5)) in
+        let od = Opn.mk ~override:$3 ~loc:(make_loc loc) $5 in
+        mkcty ~loc:$sloc ~attrs:$4 (Pcty_open(od, $7)) }
+;
+%inline class_parameters(parameter):
+  | /* empty */
+      { [] }
+  | LBRACKET params = separated_nonempty_llist(COMMA, parameter) RBRACKET
+      { params }
+;
+%inline actual_class_parameters:
+  tys = class_parameters(core_type)
+    { tys }
+;
+%inline class_sig_body:
+    class_self_type extra_csig(class_sig_fields)
+      { Csig.mk $1 $2 }
+;
+class_self_type:
+    LPAREN core_type RPAREN
+      { $2 }
+  | mktyp((* empty *) { Ptyp_any })
+      { $1 }
+;
+%inline class_sig_fields:
+  flatten(text_csig(class_sig_field)*)
+    { $1 }
+;
+class_sig_field:
+    INHERIT attributes class_signature post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkctf ~loc:$sloc (Pctf_inherit $3) ~attrs:($2@$4) ~docs }
+  | VAL attributes value_type post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkctf ~loc:$sloc (Pctf_val $3) ~attrs:($2@$4) ~docs }
+  | METHOD attributes private_virtual_flags mkrhs(label) COLON poly_type
+    post_item_attributes
+      { let (p, v) = $3 in
+        let docs = symbol_docs $sloc in
+        mkctf ~loc:$sloc (Pctf_method ($4, p, v, $6)) ~attrs:($2@$7) ~docs }
+  | CONSTRAINT attributes constrain_field post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkctf ~loc:$sloc (Pctf_constraint $3) ~attrs:($2@$4) ~docs }
+  | item_extension post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkctf ~loc:$sloc (Pctf_extension $1) ~attrs:$2 ~docs }
+  | mkctf(floating_attribute
+      { Pctf_attribute $1 })
+      { $1 }
+;
+%inline value_type:
+  flags = mutable_virtual_flags
+  label = mkrhs(label)
+  COLON
+  ty = core_type
+  {
+    let mut, virt = flags in
+    label, mut, virt, ty
+  }
+;
+%inline constrain:
+    core_type EQUAL core_type
+    { $1, $3, make_loc $sloc }
+;
+constrain_field:
+  core_type EQUAL core_type
+    { $1, $3 }
+;
+(* A group of class descriptions. *)
+%inline class_descriptions:
+  xlist(class_description, and_class_description)
+    { $1 }
+;
+%inline class_description:
+  CLASS
+  ext = ext
+  attrs1 = attributes
+  virt = virtual_flag
+  params = formal_class_parameters
+  id = mkrhs(LIDENT)
+  COLON
+  cty = class_type
+  attrs2 = post_item_attributes
+    {
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let docs = symbol_docs $sloc in
+      ext,
+      Ci.mk id cty ~virt ~params ~attrs ~loc ~docs
+    }
+;
+%inline and_class_description:
+  AND
+  attrs1 = attributes
+  virt = virtual_flag
+  params = formal_class_parameters
+  id = mkrhs(LIDENT)
+  COLON
+  cty = class_type
+  attrs2 = post_item_attributes
+    {
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let docs = symbol_docs $sloc in
+      let text = symbol_text $symbolstartpos in
+      Ci.mk id cty ~virt ~params ~attrs ~loc ~text ~docs
+    }
+;
+class_type_declarations:
+  xlist(class_type_declaration, and_class_type_declaration)
+    { $1 }
+;
+%inline class_type_declaration:
+  CLASS TYPE
+  ext = ext
+  attrs1 = attributes
+  virt = virtual_flag
+  params = formal_class_parameters
+  id = mkrhs(LIDENT)
+  EQUAL
+  csig = class_signature
+  attrs2 = post_item_attributes
+    {
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let docs = symbol_docs $sloc in
+      ext,
+      Ci.mk id csig ~virt ~params ~attrs ~loc ~docs
+    }
+;
+%inline and_class_type_declaration:
+  AND
+  attrs1 = attributes
+  virt = virtual_flag
+  params = formal_class_parameters
+  id = mkrhs(LIDENT)
+  EQUAL
+  csig = class_signature
+  attrs2 = post_item_attributes
+    {
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let docs = symbol_docs $sloc in
+      let text = symbol_text $symbolstartpos in
+      Ci.mk id csig ~virt ~params ~attrs ~loc ~text ~docs
+    }
+;
+
+/* Core expressions */
+
+seq_expr:
+  | expr        %prec below_SEMI  { $1 }
+  | expr SEMI                     { $1 }
+  | mkexp(expr SEMI seq_expr
+    { Pexp_sequence($1, $3) })
+    { $1 }
+  | expr SEMI PERCENT attr_id seq_expr
+    { let seq = mkexp ~loc:$sloc (Pexp_sequence ($1, $5)) in
+      let payload = PStr [mkstrexp seq []] in
+      mkexp ~loc:$sloc (Pexp_extension ($4, payload)) }
+;
+labeled_simple_pattern:
+    QUESTION LPAREN label_let_pattern opt_default RPAREN
+      { (Optional (fst $3), $4, snd $3) }
+  | QUESTION label_var
+      { (Optional (fst $2), None, snd $2) }
+  | OPTLABEL LPAREN let_pattern opt_default RPAREN
+      { (Optional $1, $4, $3) }
+  | OPTLABEL pattern_var
+      { (Optional $1, None, $2) }
+  | TILDE LPAREN label_let_pattern RPAREN
+      { (Labelled (fst $3), None, snd $3) }
+  | TILDE label_var
+      { (Labelled (fst $2), None, snd $2) }
+  | LABEL simple_pattern
+      { (Labelled $1, None, $2) }
+  | simple_pattern
+      { (Nolabel, None, $1) }
+;
+
+pattern_var:
+  mkpat(
+      mkrhs(LIDENT)     { Ppat_var $1 }
+    | UNDERSCORE        { Ppat_any }
+  ) { $1 }
+;
+
+%inline opt_default:
+  preceded(EQUAL, seq_expr)?
+    { $1 }
+;
+label_let_pattern:
+    x = label_var
+      { x }
+  | x = label_var COLON cty = core_type
+      { let lab, pat = x in
+        lab,
+        mkpat ~loc:$sloc (Ppat_constraint (pat, cty)) }
+;
+%inline label_var:
+    mkrhs(LIDENT)
+      { ($1.Location.txt, mkpat ~loc:$sloc (Ppat_var $1)) }
+;
+let_pattern [@recovery default_pattern ()]:
+    pattern
+      { $1 }
+  | mkpat(pattern COLON core_type
+      { Ppat_constraint($1, $3) })
+      { $1 }
+;
+
+%inline indexop_expr(dot, index, right):
+  | array=simple_expr d=dot LPAREN i=index RPAREN r=right
+    { array, d, Paren,   i, r }
+  | array=simple_expr d=dot LBRACE i=index RBRACE r=right
+    { array, d, Brace,   i, r }
+  | array=simple_expr d=dot LBRACKET i=index RBRACKET r=right
+    { array, d, Bracket, i, r }
+;
+
+(*%inline indexop_error(dot, index):
+  | simple_expr dot _p=LPAREN index  _e=error
+    { indexop_unclosed_error $loc(_p)  Paren $loc(_e) }
+  | simple_expr dot _p=LBRACE index  _e=error
+    { indexop_unclosed_error $loc(_p) Brace $loc(_e) }
+  | simple_expr dot _p=LBRACKET index  _e=error
+    { indexop_unclosed_error $loc(_p) Bracket $loc(_e) }
+;*)
+
+%inline qualified_dotop: ioption(DOT mod_longident {$2}) DOTOP { $1, $2 };
+
+%public expr [@recovery default_expr ()]:
+    simple_expr %prec below_HASH
+      { $1 }
+  | expr_attrs
+      { let desc, attrs = $1 in
+        mkexp_attrs ~loc:$sloc desc attrs }
+  | mkexp(expr_)
+      { $1 }
+  | let_bindings(ext) IN seq_expr
+      { expr_of_let_bindings ~loc:$sloc $1 (merloc $endpos($2) $3) }
+  | pbop_op = mkrhs(LETOP) bindings = letop_bindings IN body = seq_expr
+      { let (pbop_pat, pbop_exp, rev_ands) = bindings in
+        let ands = List.rev rev_ands in
+        let pbop_loc = make_loc $sloc in
+        let let_ = {pbop_op; pbop_pat; pbop_exp; pbop_loc} in
+        mkexp ~loc:$sloc (Pexp_letop{ let_; ands; body}) }
+  | expr COLONCOLON expr
+      { mkexp_cons ~loc:$sloc $loc($2) (ghexp ~loc:$sloc (Pexp_tuple[$1;(merloc $endpos($2) $3)])) }
+  | mkrhs(label) LESSMINUS expr
+      { mkexp ~loc:$sloc (Pexp_setinstvar($1, $3)) }
+  | simple_expr DOT mkrhs(label_longident) LESSMINUS expr
+      { mkexp ~loc:$sloc (Pexp_setfield($1, $3, $5)) }
+  | indexop_expr(DOT, seq_expr, LESSMINUS v=expr {Some v})
+    { mk_indexop_expr builtin_indexing_operators ~loc:$sloc $1 }
+  | indexop_expr(qualified_dotop, expr_semi_list, LESSMINUS v=expr {Some v})
+    { mk_indexop_expr user_indexing_operators ~loc:$sloc $1 }
+  | expr attribute
+      { Exp.attr $1 $2 }
+  (*
+/* BEGIN AVOID */
+  | UNDERSCORE
+     { not_expecting $loc($1) "wildcard \"_\"" }
+/* END AVOID */
+  *)
+;
+%inline expr_attrs:
+  | LET MODULE ext_attributes mkrhs(module_name) module_binding_body IN seq_expr
+      { Pexp_letmodule($4, $5, (merloc $endpos($6) $7)), $3 }
+  | LET EXCEPTION ext_attributes let_exception_declaration IN seq_expr
+      { Pexp_letexception($4, $6), $3 }
+  | LET OPEN override_flag ext_attributes module_expr IN seq_expr
+      { let open_loc = make_loc ($startpos($2), $endpos($5)) in
+        let od = Opn.mk $5 ~override:$3 ~loc:open_loc in
+        Pexp_open(od, (merloc $endpos($6) $7)), $4 }
+  | FUNCTION ext_attributes match_cases
+      { Pexp_function $3, $2 }
+  | FUN ext_attributes labeled_simple_pattern fun_def
+      { let (l,o,p) = $3 in
+        Pexp_fun(l, o, p, $4), $2 }
+  | FUN ext_attributes LPAREN TYPE lident_list RPAREN fun_def
+      { (mk_newtypes ~loc:$sloc $5 $7).pexp_desc, $2 }
+  | MATCH ext_attributes seq_expr WITH match_cases
+      { Pexp_match($3, $5), $2 }
+  | TRY ext_attributes seq_expr WITH match_cases
+      { Pexp_try($3, $5), $2 }
+  (*
+  | TRY ext_attributes seq_expr WITH error
+      { syntax_error() }
+  *)
+  | IF ext_attributes seq_expr THEN expr ELSE expr
+      { Pexp_ifthenelse($3, (merloc $endpos($4) $5), Some (merloc $endpos($6) $7)), $2 }
+  | IF ext_attributes seq_expr THEN expr
+      { Pexp_ifthenelse($3, (merloc $endpos($4) $5), None), $2 }
+  | WHILE ext_attributes seq_expr DO seq_expr DONE
+      { Pexp_while($3, (merloc $endpos($4) $5)), $2 }
+  | FOR ext_attributes pattern EQUAL seq_expr direction_flag seq_expr DO
+    seq_expr DONE
+      { Pexp_for($3, (merloc $endpos($4) $5), (merloc $endpos($6) $7), $6, (merloc $endpos($8) $9)), $2 }
+  | ASSERT ext_attributes simple_expr %prec below_HASH
+      { Pexp_assert $3, $2 }
+  | LAZY ext_attributes simple_expr %prec below_HASH
+      { Pexp_lazy $3, $2 }
+  | OBJECT ext_attributes class_structure END
+      { Pexp_object $3, $2 }
+  (*
+  | OBJECT ext_attributes class_structure error
+      { unclosed "object" $loc($1) "end" $loc($4) }
+  *)
+;
+%inline expr_:
+  | simple_expr nonempty_llist(labeled_simple_expr)
+      { Pexp_apply($1, $2) }
+  | expr_comma_list %prec below_COMMA
+      { Pexp_tuple($1) }
+  | mkrhs(constr_longident) simple_expr %prec below_HASH
+      { Pexp_construct($1, Some $2) }
+  | name_tag simple_expr %prec below_HASH
+      { Pexp_variant($1, Some $2) }
+  | e1 = expr op = op(infix_operator) e2 = expr
+      { mkinfix e1 op e2 }
+  | subtractive expr %prec prec_unary_minus
+      { mkuminus ~oploc:$loc($1) $1 $2 }
+  | additive expr %prec prec_unary_plus
+      { mkuplus ~oploc:$loc($1) $1 $2 }
+;
+
+%public simple_expr:
+  | LPAREN seq_expr RPAREN
+      { reloc_exp ~loc:$sloc $2 }
+  (*
+  | LPAREN seq_expr error
+      { unclosed "(" $loc($1) ")" $loc($3) }
+  *)
+  | LPAREN seq_expr type_constraint RPAREN
+      { mkexp_constraint ~loc:$sloc $2 $3 }
+  | indexop_expr(DOT, seq_expr, { None })
+      { mk_indexop_expr builtin_indexing_operators ~loc:$sloc $1 }
+  | indexop_expr(qualified_dotop, expr_semi_list, { None })
+      { mk_indexop_expr user_indexing_operators ~loc:$sloc $1 }
+(*
+  | indexop_error (DOT, seq_expr) { $1 }
+  | indexop_error (qualified_dotop, expr_semi_list) { $1 }
+*)
+  | simple_expr_attrs
+    { let desc, attrs = $1 in
+      mkexp_attrs ~loc:$sloc desc attrs }
+  | mkexp(simple_expr_)
+      { $1 }
+;
+%inline simple_expr_attrs:
+  | BEGIN ext = ext attrs = attributes e = seq_expr END
+      { e.pexp_desc, (ext, attrs @ e.pexp_attributes) }
+  | BEGIN ext_attributes END
+      { Pexp_construct (mkloc (Lident "()") (make_loc $sloc), None), $2 }
+  (*
+  | BEGIN ext_attributes seq_expr error
+      { unclosed "begin" $loc($1) "end" $loc($4) }
+  *)
+  | NEW ext_attributes mkrhs(class_longident)
+      { Pexp_new($3), $2 }
+  | LPAREN MODULE ext_attributes module_expr RPAREN
+      { Pexp_pack $4, $3 }
+  | LPAREN MODULE ext_attributes module_expr COLON package_type RPAREN
+      { Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $4), $6), $3 }
+  (*
+  | LPAREN MODULE ext_attributes module_expr COLON error
+      { unclosed "(" $loc($1) ")" $loc($6) }
+  *)
+;
+%inline simple_expr_:
+  | mkrhs(val_longident)
+      { Pexp_ident ($1) }
+  | constant
+      { Pexp_constant $1 }
+  | mkrhs(constr_longident) %prec prec_constant_constructor
+      { Pexp_construct($1, None) }
+  | name_tag %prec prec_constant_constructor
+      { Pexp_variant($1, None) }
+  | op(PREFIXOP) simple_expr
+      { Pexp_apply($1, [Nolabel,$2]) }
+  | op(BANG {"!"}) simple_expr
+      { Pexp_apply($1, [Nolabel,$2]) }
+  | LBRACELESS object_expr_content GREATERRBRACE
+      { Pexp_override $2 }
+  (*
+  | LBRACELESS object_expr_content error
+      { unclosed "{<" $loc($1) ">}" $loc($3) }
+  *)
+  | LBRACELESS GREATERRBRACE
+      { Pexp_override [] }
+  | simple_expr DOT mkrhs(label_longident)
+      { Pexp_field($1, $3) }
+  | od=open_dot_declaration DOT LPAREN seq_expr RPAREN
+      { Pexp_open(od, $4) }
+  | od=open_dot_declaration DOT LBRACELESS object_expr_content GREATERRBRACE
+      { (* TODO: review the location of Pexp_override *)
+        Pexp_open(od, mkexp ~loc:$sloc (Pexp_override $4)) }
+  (*
+  | mod_longident DOT LBRACELESS object_expr_content error
+      { unclosed "{<" $loc($3) ">}" $loc($5) }
+  *)
+  | simple_expr HASH mkrhs(label)
+      { Pexp_send($1, $3) }
+  | simple_expr op(HASHOP) simple_expr
+      { mkinfix $1 $2 $3 }
+  | extension
+      { Pexp_extension $1 }
+  | UNDERSCORE
+      { let id = mkrhs Ast_helper.hole_txt $loc in
+        Pexp_extension (id, PStr []) }
+  | od=open_dot_declaration DOT mkrhs(LPAREN RPAREN {Lident "()"})
+      { Pexp_open(od, mkexp ~loc:($loc($3)) (Pexp_construct($3, None))) }
+  (*
+  | mod_longident DOT LPAREN seq_expr error
+      { unclosed "(" $loc($3) ")" $loc($5) }
+  *)
+  | LBRACE record_expr_content RBRACE
+      { let (exten, fields) = $2 in
+        Pexp_record(fields, exten) }
+  (*
+  | LBRACE record_expr_content error
+      { unclosed "{" $loc($1) "}" $loc($3) }
+  *)
+  | od=open_dot_declaration DOT LBRACE record_expr_content RBRACE
+      { let (exten, fields) = $4 in
+        Pexp_open(od, mkexp ~loc:($startpos($3), $endpos)
+                        (Pexp_record(fields, exten))) }
+  (*
+  | mod_longident DOT LBRACE record_expr_content error
+      { unclosed "{" $loc($3) "}" $loc($5) }
+  *)
+  | LBRACKETBAR expr_semi_list BARRBRACKET
+      { Pexp_array($2) }
+  (*
+  | LBRACKETBAR expr_semi_list error
+      { unclosed "[|" $loc($1) "|]" $loc($3) }
+  *)
+  | LBRACKETBAR BARRBRACKET
+      { Pexp_array [] }
+  | od=open_dot_declaration DOT LBRACKETBAR expr_semi_list BARRBRACKET
+      { Pexp_open(od, mkexp ~loc:($startpos($3), $endpos) (Pexp_array($4))) }
+  | od=open_dot_declaration DOT LBRACKETBAR BARRBRACKET
+      { (* TODO: review the location of Pexp_array *)
+        Pexp_open(od, mkexp ~loc:($startpos($3), $endpos) (Pexp_array [])) }
+  (*
+  | mod_longident DOT
+    LBRACKETBAR expr_semi_list error
+      { unclosed "[|" $loc($3) "|]" $loc($5) }
+  *)
+  | LBRACKET expr_semi_list RBRACKET
+      { fst (mktailexp $loc($3) $2) }
+  (*
+  | LBRACKET expr_semi_list error
+      { unclosed "[" $loc($1) "]" $loc($3) }
+  *)
+  | od=open_dot_declaration DOT LBRACKET expr_semi_list RBRACKET
+      { let list_exp =
+          (* TODO: review the location of list_exp *)
+          let tail_exp, _tail_loc = mktailexp $loc($5) $4 in
+          mkexp ~loc:($startpos($3), $endpos) tail_exp in
+        Pexp_open(od, list_exp) }
+  | od=open_dot_declaration DOT mkrhs(LBRACKET RBRACKET {Lident "[]"})
+      { Pexp_open(od, mkexp ~loc:$loc($3) (Pexp_construct($3, None))) }
+  (*
+  | mod_longident DOT
+    LBRACKET expr_semi_list error
+      { unclosed "[" $loc($3) "]" $loc($5) }
+  *)
+  | od=open_dot_declaration DOT LPAREN MODULE ext_attributes module_expr COLON
+    package_type RPAREN
+      { let modexp =
+          mkexp_attrs ~loc:($startpos($3), $endpos)
+            (Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $6), $8)) $5 in
+        Pexp_open(od, modexp) }
+  (*
+  | mod_longident DOT
+    LPAREN MODULE ext_attributes module_expr COLON error
+      { unclosed "(" $loc($3) ")" $loc($8) }
+  *)
+;
+labeled_simple_expr:
+    simple_expr %prec below_HASH
+      { (Nolabel, $1) }
+  | LABEL simple_expr %prec below_HASH
+      { (Labelled $1, $2) }
+  | TILDE label = LIDENT
+      { let loc = $loc(label) in
+        (Labelled label, mkexpvar ~loc label) }
+  | QUESTION label = LIDENT
+      { let loc = $loc(label) in
+        (Optional label, mkexpvar ~loc label) }
+  | OPTLABEL simple_expr %prec below_HASH
+      { (Optional $1, $2) }
+;
+%inline lident_list:
+  xs = mkrhs(LIDENT)+
+    { xs }
+;
+%inline let_ident:
+    val_ident { mkpatvar ~loc:$sloc $1 }
+;
+let_binding_body_no_punning:
+    let_ident strict_binding
+      { ($1, $2) }
+  | let_ident type_constraint EQUAL seq_expr
+      { let v = $1 in (* PR#7344 *)
+        let t =
+          match $2 with
+            Some t, None -> t
+          | _, Some t -> t
+          | _ -> assert false
+        in
+        let loc = Location.(t.ptyp_loc.loc_start, t.ptyp_loc.loc_end) in
+        let typ = ghtyp ~loc (Ptyp_poly([],t)) in
+        let patloc = ($startpos($1), $endpos($2)) in
+        (ghpat ~loc:patloc (Ppat_constraint(v, typ)),
+         mkexp_constraint ~loc:$sloc $4 $2) }
+  | let_ident COLON typevar_list DOT core_type EQUAL seq_expr
+      (* TODO: could replace [typevar_list DOT core_type]
+               with [mktyp(poly(core_type))]
+               and simplify the semantic action? *)
+      { let typloc = ($startpos($3), $endpos($5)) in
+        let patloc = ($startpos($1), $endpos($5)) in
+        (ghpat ~loc:patloc
+           (Ppat_constraint($1, ghtyp ~loc:typloc (Ptyp_poly($3,$5)))),
+         $7) }
+  | let_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr
+      { let exp, poly =
+          wrap_type_annotation ~loc:$sloc $4 $6 $8 in
+        let loc = ($startpos($1), $endpos($6)) in
+        (ghpat ~loc (Ppat_constraint($1, poly)), exp) }
+  | pattern_no_exn EQUAL seq_expr
+      { ($1, $3) }
+  | simple_pattern_not_ident COLON core_type EQUAL seq_expr
+      { let loc = ($startpos($1), $endpos($3)) in
+        (ghpat ~loc (Ppat_constraint($1, $3)), $5) }
+;
+let_binding_body:
+  | let_binding_body_no_punning
+      { let p,e = $1 in (p,e,false) }
+/* BEGIN AVOID */
+  | val_ident %prec below_HASH
+      { (mkpatvar ~loc:$loc $1, mkexpvar ~loc:$loc $1, true) }
+  (* The production that allows puns is marked so that [make list-parse-errors]
+     does not attempt to exploit it. That would be problematic because it
+     would then generate bindings such as [let x], which are rejected by the
+     auxiliary function [addlb] via a call to [syntax_error]. *)
+/* END AVOID */
+;
+(* The formal parameter EXT can be instantiated with ext or no_ext
+   so as to indicate whether an extension is allowed or disallowed. *)
+let_bindings(EXT):
+    let_binding(EXT)                            { $1 }
+  | let_bindings(EXT) and_let_binding           { addlb $1 $2 }
+;
+%inline let_binding(EXT):
+  LET
+  ext = EXT
+  attrs1 = attributes
+  rec_flag = rec_flag
+  body = let_binding_body
+  attrs2 = post_item_attributes
+    {
+      let attrs = attrs1 @ attrs2 in
+      mklbs ext rec_flag (mklb ~loc:$sloc true body attrs)
+    }
+;
+and_let_binding:
+  AND
+  attrs1 = attributes
+  body = let_binding_body
+  attrs2 = post_item_attributes
+    {
+      let attrs = attrs1 @ attrs2 in
+      mklb ~loc:$sloc false body attrs
+    }
+;
+letop_binding_body:
+    pat = let_ident exp = strict_binding
+      { (pat, exp) }
+  | val_ident
+      (* Let-punning *)
+      { (mkpatvar ~loc:$loc $1, mkexpvar ~loc:$loc $1) }
+  | pat = simple_pattern COLON typ = core_type EQUAL exp = seq_expr
+      { let loc = ($startpos(pat), $endpos(typ)) in
+        (ghpat ~loc (Ppat_constraint(pat, typ)), exp) }
+  | pat = pattern_no_exn EQUAL exp = seq_expr
+      { (pat, exp) }
+;
+letop_bindings:
+    body = letop_binding_body
+      { let let_pat, let_exp = body in
+        let_pat, let_exp, [] }
+  | bindings = letop_bindings pbop_op = mkrhs(ANDOP) body = letop_binding_body
+      { let let_pat, let_exp, rev_ands = bindings in
+        let pbop_pat, pbop_exp = body in
+        let pbop_loc = make_loc $sloc in
+        let and_ = {pbop_op; pbop_pat; pbop_exp; pbop_loc} in
+        let_pat, let_exp, and_ :: rev_ands }
+;
+fun_binding:
+    strict_binding
+      { $1 }
+  | type_constraint EQUAL seq_expr
+      { mkexp_constraint ~loc:$sloc $3 $1 }
+;
+strict_binding:
+    EQUAL seq_expr
+      { $2 }
+  | labeled_simple_pattern fun_binding
+      { let (l, o, p) = $1 in ghexp ~loc:$sloc (Pexp_fun(l, o, p, $2)) }
+  | LPAREN TYPE lident_list RPAREN fun_binding
+      { mk_newtypes ~loc:$sloc $3 $5 }
+;
+%inline match_cases:
+  xs = preceded_or_separated_nonempty_llist(BAR, match_case)
+    { xs }
+;
+match_case:
+    pattern MINUSGREATER seq_expr
+      { Exp.case $1 (merloc $endpos($2) $3) }
+  | pattern WHEN seq_expr MINUSGREATER seq_expr
+      { Exp.case $1 ~guard:(merloc $endpos($2) $3) (merloc $endpos($4) $5) }
+  | pattern MINUSGREATER DOT [@cost infinity]
+      { Exp.case $1 (merloc $endpos($2)
+                       (Exp.unreachable ~loc:(make_loc $loc($3)) ())) }
+;
+fun_def:
+    MINUSGREATER seq_expr
+      { (merloc $endpos($1) $2) }
+  | mkexp(COLON atomic_type MINUSGREATER seq_expr
+      { Pexp_constraint ((merloc $endpos($3) $4), $2) })
+      { $1 }
+/* Cf #5939: we used to accept (fun p when e0 -> e) */
+  | labeled_simple_pattern fun_def
+      {
+       let (l,o,p) = $1 in
+       ghexp ~loc:$sloc (Pexp_fun(l, o, p, $2))
+      }
+  | LPAREN TYPE lident_list RPAREN fun_def
+      { mk_newtypes ~loc:$sloc $3 $5 }
+;
+%inline expr_comma_list:
+  es = separated_nontrivial_llist(COMMA, expr)
+    { es }
+;
+record_expr_content:
+  eo = ioption(terminated(simple_expr, WITH))
+  fields = separated_or_terminated_nonempty_list(SEMI, record_expr_field)
+    { eo, fields }
+;
+%inline record_expr_field:
+  | label = mkrhs(label_longident)
+    c = type_constraint?
+    eo = preceded(EQUAL, expr)?
+      { let e =
+          match eo with
+          | None ->
+              (* No pattern; this is a pun. Desugar it. *)
+              exp_of_longident ~loc:$sloc label
+          | Some e ->
+              e
+        in
+        label, mkexp_opt_constraint ~loc:$sloc e c }
+;
+%inline object_expr_content:
+  xs = separated_or_terminated_nonempty_list(SEMI, object_expr_field)
+    { xs }
+;
+%inline object_expr_field:
+    label = mkrhs(label)
+    oe = preceded(EQUAL, expr)?
+      { let e =
+          match oe with
+          | None ->
+              (* No expression; this is a pun. Desugar it. *)
+              exp_of_label ~loc:$sloc label
+          | Some e ->
+              e
+        in
+        label, e }
+;
+%inline expr_semi_list:
+  es = separated_or_terminated_nonempty_list(SEMI, expr)
+    { es }
+;
+type_constraint:
+    COLON core_type                             { (Some $2, None) }
+  | COLON core_type COLONGREATER core_type      { (Some $2, Some $4) }
+  | COLONGREATER core_type                      { (None, Some $2) }
+  (*| COLON error                                 { syntax_error() } *)
+  (*| COLONGREATER error                          { syntax_error() } *)
+;
+
+/* Patterns */
+
+(* Whereas [pattern] is an arbitrary pattern, [pattern_no_exn] is a pattern
+   that does not begin with the [EXCEPTION] keyword. Thus, [pattern_no_exn]
+   is the intersection of the context-free language [pattern] with the
+   regular language [^EXCEPTION .*].
+
+   Ideally, we would like to use [pattern] everywhere and check in a later
+   phase that EXCEPTION patterns are used only where they are allowed (there
+   is code in typing/typecore.ml to this end). Unfortunately, in the
+   definition of [let_binding_body], we cannot allow [pattern]. That would
+   create a shift/reduce conflict: upon seeing LET EXCEPTION ..., the parser
+   wouldnt know whether this is the beginning of a LET EXCEPTION construct or
+   the beginning of a LET construct whose pattern happens to begin with
+   EXCEPTION. The conflict is avoided there by using [pattern_no_exn] in the
+   definition of [let_binding_body].
+
+   In order to avoid duplication between the definitions of [pattern] and
+   [pattern_no_exn], we create a parameterized definition [pattern_(self)]
+   and instantiate it twice. *)
+
+pattern [@recovery default_pattern ()]:
+    pattern_(pattern)
+      { $1 }
+  | EXCEPTION ext_attributes pattern %prec prec_constr_appl
+      { mkpat_attrs ~loc:$sloc (Ppat_exception $3) $2}
+;
+
+pattern_no_exn:
+    pattern_(pattern_no_exn)
+      { $1 }
+;
+
+%inline pattern_(self):
+  | self COLONCOLON pattern
+      { mkpat_cons ~loc:$sloc $loc($2) (ghpat ~loc:$sloc (Ppat_tuple[$1;$3])) }
+  | self attribute
+      { Pat.attr $1 $2 }
+  | pattern_gen
+      { $1 }
+  | mkpat(
+      self AS mkrhs(val_ident)
+        { Ppat_alias($1, $3) }
+    (*| self AS error
+        { expecting $loc($3) "identifier" } *)
+    | pattern_comma_list(self) %prec below_COMMA
+        { Ppat_tuple(List.rev $1) }
+    (*| self COLONCOLON error
+        { expecting $loc($3) "pattern" } *)
+    | self BAR pattern
+        { Ppat_or($1, $3) }
+    (*| self BAR error
+        { expecting $loc($3) "pattern" } *)
+  ) { $1 }
+;
+
+pattern_gen:
+    simple_pattern
+      { $1 }
+  | mkpat(
+      mkrhs(constr_longident) pattern %prec prec_constr_appl
+        { Ppat_construct($1, Some ([], $2)) }
+    | constr=mkrhs(constr_longident) LPAREN TYPE newtypes=lident_list RPAREN
+        pat=simple_pattern
+        { Ppat_construct(constr, Some (newtypes, pat)) }
+    | name_tag pattern %prec prec_constr_appl
+        { Ppat_variant($1, Some $2) }
+    ) { $1 }
+  | LAZY ext_attributes simple_pattern
+      { mkpat_attrs ~loc:$sloc (Ppat_lazy $3) $2}
+;
+simple_pattern:
+    mkpat(mkrhs(val_ident) %prec below_EQUAL
+      { Ppat_var ($1) })
+      { $1 }
+  | simple_pattern_not_ident { $1 }
+;
+
+simple_pattern_not_ident:
+  | LPAREN pattern RPAREN
+      { reloc_pat ~loc:$sloc $2 }
+  | simple_delimited_pattern
+      { $1 }
+  | LPAREN MODULE ext_attributes mkrhs(module_name) RPAREN
+      { mkpat_attrs ~loc:$sloc (Ppat_unpack $4) $3 }
+  | LPAREN MODULE ext_attributes mkrhs(module_name) COLON package_type RPAREN
+      { mkpat_attrs ~loc:$sloc
+          (Ppat_constraint(mkpat ~loc:$loc($4) (Ppat_unpack $4), $6))
+          $3 }
+  | mkpat(simple_pattern_not_ident_)
+      { $1 }
+;
+%inline simple_pattern_not_ident_:
+  | UNDERSCORE
+      { Ppat_any }
+  | signed_constant
+      { Ppat_constant $1 }
+  | signed_constant DOTDOT signed_constant
+      { Ppat_interval ($1, $3) }
+  | mkrhs(constr_longident)
+      { Ppat_construct($1, None) }
+  | name_tag
+      { Ppat_variant($1, None) }
+  | HASH mkrhs(type_longident)
+      { Ppat_type ($2) }
+  | mkrhs(mod_longident) DOT simple_delimited_pattern
+      { Ppat_open($1, $3) }
+  | mkrhs(mod_longident) DOT mkrhs(LBRACKET RBRACKET {Lident "[]"})
+    { Ppat_open($1, mkpat ~loc:$sloc (Ppat_construct($3, None))) }
+  | mkrhs(mod_longident) DOT mkrhs(LPAREN RPAREN {Lident "()"})
+    { Ppat_open($1, mkpat ~loc:$sloc (Ppat_construct($3, None))) }
+  | mkrhs(mod_longident) DOT LPAREN pattern RPAREN
+      { Ppat_open ($1, $4) }
+  (*
+  | mod_longident DOT LPAREN pattern error
+      { unclosed "(" $loc($3) ")" $loc($5)  }
+  | mod_longident DOT LPAREN error
+      { expecting $loc($4) "pattern" }
+  | LPAREN pattern error
+      { unclosed "(" $loc($1) ")" $loc($3) }
+  *)
+  | LPAREN pattern COLON core_type RPAREN
+      { Ppat_constraint($2, $4) }
+  (*
+  | LPAREN pattern COLON core_type error
+      { unclosed "(" $loc($1) ")" $loc($5) }
+  | LPAREN pattern COLON error
+      { expecting $loc($4) "type" }
+  | LPAREN MODULE ext_attributes module_name COLON package_type
+    error
+      { unclosed "(" $loc($1) ")" $loc($7) }
+  *)
+  | extension
+      { Ppat_extension $1 }
+;
+
+simple_delimited_pattern:
+  mkpat(
+      LBRACE record_pat_content RBRACE
+      { let (fields, closed) = $2 in
+        Ppat_record(fields, closed) }
+    (*| LBRACE record_pat_content error
+      { unclosed "{" $loc($1) "}" $loc($3) } *)
+    | LBRACKET pattern_semi_list RBRACKET
+      { fst (mktailpat $loc($3) $2) }
+    (*| LBRACKET pattern_semi_list error
+      { unclosed "[" $loc($1) "]" $loc($3) } *)
+    | LBRACKETBAR pattern_semi_list BARRBRACKET
+      { Ppat_array $2 }
+    | LBRACKETBAR BARRBRACKET
+      { Ppat_array [] }
+    (*| LBRACKETBAR pattern_semi_list error
+      { unclosed "[|" $loc($1) "|]" $loc($3) } *)
+  ) { $1 }
+
+pattern_comma_list(self):
+    pattern_comma_list(self) COMMA pattern      { $3 :: $1 }
+  | self COMMA pattern                          { [$3; $1] }
+  (*| self COMMA error                            { expecting $loc($3) "pattern" } *)
+;
+%inline pattern_semi_list:
+  ps = separated_or_terminated_nonempty_list(SEMI, pattern)
+    { ps }
+;
+(* A label-pattern list is a nonempty list of label-pattern pairs, optionally
+   followed with an UNDERSCORE, separated-or-terminated with semicolons. *)
+%inline record_pat_content:
+  listx(SEMI, record_pat_field, UNDERSCORE)
+    { let fields, closed = $1 in
+      let closed = match closed with Some () -> Open | None -> Closed in
+      fields, closed }
+;
+%inline record_pat_field:
+  label = mkrhs(label_longident)
+  octy = preceded(COLON, core_type)?
+  opat = preceded(EQUAL, pattern)?
+    { let label, pat =
+        match opat with
+        | None ->
+            (* No pattern; this is a pun. Desugar it.
+               But that the pattern was there and the label reconstructed (which
+               piece of AST is marked as ghost is important for warning
+               emission). *)
+            make_ghost label, pat_of_label label
+        | Some pat ->
+            label, pat
+      in
+      label, mkpat_opt_constraint ~loc:$sloc pat octy
+    }
+;
+
+/* Value descriptions */
+
+value_description:
+  VAL
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(val_ident)
+  COLON
+  ty = core_type
+  attrs2 = post_item_attributes
+    { let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let docs = symbol_docs $sloc in
+      Val.mk id ty ~attrs ~loc ~docs,
+      ext }
+;
+
+/* Primitive declarations */
+
+primitive_declaration:
+  EXTERNAL
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(val_ident)
+  COLON
+  ty = core_type
+  EQUAL
+  prim = raw_string+
+  attrs2 = post_item_attributes
+    { let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let docs = symbol_docs $sloc in
+      Val.mk id ty ~prim ~attrs ~loc ~docs,
+      ext }
+;
+
+(* Type declarations and type substitutions. *)
+
+(* Type declarations [type t = u] and type substitutions [type t := u] are very
+   similar, so we view them as instances of [generic_type_declarations]. In the
+   case of a type declaration, the use of [nonrec_flag] means that [NONREC] may
+   be absent or present, whereas in the case of a type substitution, the use of
+   [no_nonrec_flag] means that [NONREC] must be absent. The use of [type_kind]
+   versus [type_subst_kind] means that in the first case, we expect an [EQUAL]
+   sign, whereas in the second case, we expect [COLONEQUAL]. *)
+
+%inline type_declarations:
+  generic_type_declarations(nonrec_flag, type_kind)
+    { $1 }
+;
+
+%inline type_subst_declarations:
+  generic_type_declarations(no_nonrec_flag, type_subst_kind)
+    { $1 }
+;
+
+(* A set of type declarations or substitutions begins with a
+   [generic_type_declaration] and continues with a possibly empty list of
+   [generic_and_type_declaration]s. *)
+
+%inline generic_type_declarations(flag, kind):
+  xlist(
+    generic_type_declaration(flag, kind),
+    generic_and_type_declaration(kind)
+  )
+  { $1 }
+;
+
+(* [generic_type_declaration] and [generic_and_type_declaration] look similar,
+   but are in reality different enough that it is difficult to share anything
+   between them. *)
+
+generic_type_declaration(flag, kind):
+  TYPE
+  ext = ext
+  attrs1 = attributes
+  flag = flag
+  params = type_parameters
+  id = mkrhs(LIDENT)
+  kind_priv_manifest = kind
+  cstrs = constraints
+  attrs2 = post_item_attributes
+    {
+      let (kind, priv, manifest) = kind_priv_manifest in
+      let docs = symbol_docs $sloc in
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      (flag, ext),
+      Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs
+    }
+;
+%inline generic_and_type_declaration(kind):
+  AND
+  attrs1 = attributes
+  params = type_parameters
+  id = mkrhs(LIDENT)
+  kind_priv_manifest = kind
+  cstrs = constraints
+  attrs2 = post_item_attributes
+    {
+      let (kind, priv, manifest) = kind_priv_manifest in
+      let docs = symbol_docs $sloc in
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let text = symbol_text $symbolstartpos in
+      Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ~text
+    }
+;
+%inline constraints:
+  llist(preceded(CONSTRAINT, constrain))
+    { $1 }
+;
+(* Lots of %inline expansion are required for [nonempty_type_kind] to be
+   LR(1). At the cost of some manual expansion, it would be possible to give a
+   definition that leads to a smaller grammar (after expansion) and therefore
+   a smaller automaton. *)
+nonempty_type_kind:
+  | priv = inline_private_flag
+    ty = core_type
+      { (Ptype_abstract, priv, Some ty) }
+  | oty = type_synonym
+    priv = inline_private_flag
+    cs = constructor_declarations
+      { (Ptype_variant cs, priv, oty) }
+  | oty = type_synonym
+    priv = inline_private_flag
+    DOTDOT
+      { (Ptype_open, priv, oty) }
+  | oty = type_synonym
+    priv = inline_private_flag
+    LBRACE ls = label_declarations RBRACE
+      { (Ptype_record ls, priv, oty) }
+;
+%inline type_synonym:
+  ioption(terminated(core_type, EQUAL))
+    { $1 }
+;
+type_kind:
+    /*empty*/
+      { (Ptype_abstract, Public, None) }
+  | EQUAL nonempty_type_kind
+      { $2 }
+;
+%inline type_subst_kind:
+    COLONEQUAL nonempty_type_kind
+      { $2 }
+;
+type_parameters:
+    /* empty */
+      { [] }
+  | p = type_parameter
+      { [p] }
+  | LPAREN ps = separated_nonempty_llist(COMMA, type_parameter) RPAREN
+      { ps }
+;
+type_parameter:
+    type_variance type_variable        { $2, $1 }
+;
+type_variable:
+  mktyp(
+    QUOTE tyvar = ident
+      { Ptyp_var tyvar }
+  | UNDERSCORE
+      { Ptyp_any }
+  ) { $1 }
+;
+
+type_variance:
+    /* empty */                             { NoVariance, NoInjectivity }
+  | PLUS                                    { Covariant, NoInjectivity }
+  | MINUS                                   { Contravariant, NoInjectivity }
+  | BANG                                    { NoVariance, Injective }
+  | PLUS BANG | BANG PLUS                   { Covariant, Injective }
+  | MINUS BANG | BANG MINUS                 { Contravariant, Injective }
+  | INFIXOP2
+      { if $1 = "+!" then Covariant, Injective else
+        if $1 = "-!" then Contravariant, Injective else
+        (expecting $loc($1) "type_variance";
+         NoVariance, NoInjectivity) }
+  | PREFIXOP
+      { if $1 = "!+" then Covariant, Injective else
+        if $1 = "!-" then Contravariant, Injective else
+        (expecting $loc($1) "type_variance";
+         NoVariance, NoInjectivity) }
+;
+
+(* A sequence of constructor declarations is either a single BAR, which
+   means that the list is empty, or a nonempty BAR-separated list of
+   declarations, with an optional leading BAR. *)
+constructor_declarations:
+  | BAR
+      { [] }
+  | cs = bar_llist(constructor_declaration)
+      { cs }
+;
+(* A constructor declaration begins with an opening symbol, which can
+   be either epsilon or BAR. Note that this opening symbol is included
+   in the footprint $sloc. *)
+(* Because [constructor_declaration] and [extension_constructor_declaration]
+   are identical except for their semantic actions, we introduce the symbol
+   [generic_constructor_declaration], whose semantic action is neutral -- it
+   merely returns a tuple. *)
+generic_constructor_declaration(opening):
+  opening
+  cid = mkrhs(constr_ident)
+  args_res = generalized_constructor_arguments
+  attrs = attributes
+    {
+      let args, res = args_res in
+      let info = symbol_info $endpos in
+      let loc = make_loc $sloc in
+      cid, args, res, attrs, loc, info
+    }
+;
+%inline constructor_declaration(opening):
+  d = generic_constructor_declaration(opening)
+    {
+      let cid, args, res, attrs, loc, info = d in
+      Type.constructor cid ~args ?res ~attrs ~loc ~info
+    }
+;
+str_exception_declaration:
+  sig_exception_declaration
+    { $1 }
+| EXCEPTION
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(constr_ident)
+  EQUAL
+  lid = mkrhs(constr_longident)
+  attrs2 = attributes
+  attrs = post_item_attributes
+  { let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Te.mk_exception ~attrs
+      (Te.rebind id lid ~attrs:(attrs1 @ attrs2) ~loc ~docs)
+    , ext }
+;
+sig_exception_declaration:
+  EXCEPTION
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(constr_ident)
+  args_res = generalized_constructor_arguments
+  attrs2 = attributes
+  attrs = post_item_attributes
+    { let args, res = args_res in
+      let loc = make_loc ($startpos, $endpos(attrs2)) in
+      let docs = symbol_docs $sloc in
+      Te.mk_exception ~attrs
+        (Te.decl id ~args ?res ~attrs:(attrs1 @ attrs2) ~loc ~docs)
+      , ext }
+;
+%inline let_exception_declaration:
+    mkrhs(constr_ident) generalized_constructor_arguments attributes
+      { let args, res = $2 in
+        Te.decl $1 ~args ?res ~attrs:$3 ~loc:(make_loc $sloc) }
+;
+generalized_constructor_arguments:
+    /*empty*/                     { (Pcstr_tuple [],None) }
+  | OF constructor_arguments      { ($2,None) }
+  | COLON constructor_arguments MINUSGREATER atomic_type %prec below_HASH
+                                  { ($2,Some $4) }
+  | COLON atomic_type %prec below_HASH
+                                  { (Pcstr_tuple [],Some $2) }
+;
+
+constructor_arguments:
+  | tys = inline_separated_nonempty_llist(STAR, atomic_type)
+    %prec below_HASH
+      { Pcstr_tuple tys }
+  | LBRACE label_declarations RBRACE
+      { Pcstr_record $2 }
+;
+label_declarations:
+    label_declaration                           { [$1] }
+  | label_declaration_semi                      { [$1] }
+  | label_declaration_semi label_declarations   { $1 :: $2 }
+;
+label_declaration:
+    mutable_flag mkrhs(label) COLON poly_type_no_attr attributes
+      { let info = symbol_info $endpos in
+        Type.field $2 $4 ~mut:$1 ~attrs:$5 ~loc:(make_loc $sloc) ~info }
+;
+label_declaration_semi:
+    mutable_flag mkrhs(label) COLON poly_type_no_attr attributes SEMI attributes
+      { let info =
+          match rhs_info $endpos($5) with
+          | Some _ as info_before_semi -> info_before_semi
+          | None -> symbol_info $endpos
+       in
+       Type.field $2 $4 ~mut:$1 ~attrs:($5 @ $7) ~loc:(make_loc $sloc) ~info }
+;
+
+/* Type Extensions */
+
+%inline str_type_extension:
+  type_extension(extension_constructor)
+    { $1 }
+;
+%inline sig_type_extension:
+  type_extension(extension_constructor_declaration)
+    { $1 }
+;
+%inline type_extension(declaration):
+  TYPE
+  ext = ext
+  attrs1 = attributes
+  no_nonrec_flag
+  params = type_parameters
+  tid = mkrhs(type_longident)
+  PLUSEQ
+  priv = private_flag
+  cs = bar_llist(declaration)
+  attrs2 = post_item_attributes
+    { let docs = symbol_docs $sloc in
+      let attrs = attrs1 @ attrs2 in
+      Te.mk tid cs ~params ~priv ~attrs ~docs,
+      ext }
+;
+%inline extension_constructor(opening):
+    extension_constructor_declaration(opening)
+      { $1 }
+  | extension_constructor_rebind(opening)
+      { $1 }
+;
+%inline extension_constructor_declaration(opening):
+  d = generic_constructor_declaration(opening)
+    {
+      let cid, args, res, attrs, loc, info = d in
+      Te.decl cid ~args ?res ~attrs ~loc ~info
+    }
+;
+extension_constructor_rebind(opening):
+  opening
+  cid = mkrhs(constr_ident)
+  EQUAL
+  lid = mkrhs(constr_longident)
+  attrs = attributes
+      { let info = symbol_info $endpos in
+        Te.rebind cid lid ~attrs ~loc:(make_loc $sloc) ~info }
+;
+
+/* "with" constraints (additional type equations over signature components) */
+
+with_constraint:
+    TYPE type_parameters mkrhs(label_longident) with_type_binder
+    core_type_no_attr constraints
+      { let lident = loc_last $3 in
+        Pwith_type
+          ($3,
+           (Type.mk lident
+              ~params:$2
+              ~cstrs:$6
+              ~manifest:$5
+              ~priv:$4
+              ~loc:(make_loc $sloc))) }
+    /* used label_longident instead of type_longident to disallow
+       functor applications in type path */
+  | TYPE type_parameters mkrhs(label_longident)
+    COLONEQUAL core_type_no_attr
+      { let lident = loc_last $3 in
+        Pwith_typesubst
+         ($3,
+           (Type.mk lident
+              ~params:$2
+              ~manifest:$5
+              ~loc:(make_loc $sloc))) }
+  | MODULE mkrhs(mod_longident) EQUAL mkrhs(mod_ext_longident)
+      { Pwith_module ($2, $4) }
+  | MODULE mkrhs(mod_longident) COLONEQUAL mkrhs(mod_ext_longident)
+      { Pwith_modsubst ($2, $4) }
+  | MODULE TYPE l=mkrhs(mty_longident) EQUAL rhs=module_type
+      { Pwith_modtype (l, rhs) }
+  | MODULE TYPE l=mkrhs(mty_longident) COLONEQUAL rhs=module_type
+      { Pwith_modtypesubst (l, rhs) }
+;
+with_type_binder:
+    EQUAL          { Public }
+  | EQUAL PRIVATE  { Private }
+;
+
+/* Polymorphic types */
+
+%inline typevar:
+  QUOTE mkrhs(ident)
+    { $2 }
+;
+%inline typevar_list:
+  nonempty_llist(typevar)
+    { $1 }
+;
+%inline poly(X):
+  typevar_list DOT X
+    { Ptyp_poly($1, $3) }
+;
+possibly_poly(X):
+  X
+    { $1 }
+| mktyp(poly(X))
+    { $1 }
+;
+%inline poly_type:
+  possibly_poly(core_type)
+    { $1 }
+;
+%inline poly_type_no_attr:
+  possibly_poly(core_type_no_attr)
+    { $1 }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+(* Core language types. *)
+
+(* A core type (core_type) is a core type without attributes (core_type_no_attr)
+   followed with a list of attributes. *)
+core_type:
+    core_type_no_attr
+      { $1 }
+  | core_type attribute
+      { Typ.attr $1 $2 }
+;
+
+(* A core type without attributes is currently defined as an alias type, but
+   this could change in the future if new forms of types are introduced. From
+   the outside, one should use core_type_no_attr. *)
+%inline core_type_no_attr:
+  alias_type
+    { $1 }
+;
+
+(* Alias types include:
+   - function types (see below);
+   - proper alias types:                  'a -> int as 'a
+ *)
+alias_type:
+    function_type
+      { $1 }
+  | mktyp(
+      ty = alias_type AS QUOTE tyvar = ident
+        { Ptyp_alias(ty, tyvar) }
+    )
+    { $1 }
+;
+
+(* Function types include:
+   - tuple types (see below);
+   - proper function types:               int -> int
+                                          foo: int -> int
+                                          ?foo: int -> int
+ *)
+function_type:
+  | ty = tuple_type
+    %prec MINUSGREATER
+      { ty }
+  | mktyp(
+      label = arg_label
+      domain = extra_rhs(tuple_type)
+      MINUSGREATER
+      codomain = function_type
+        { Ptyp_arrow(label, domain, codomain) }
+    )
+    { $1 }
+;
+%inline arg_label:
+  | label = optlabel
+      { Optional label }
+  | label = LIDENT COLON
+      { Labelled label }
+  | /* empty */
+      { Nolabel }
+;
+(* Tuple types include:
+   - atomic types (see below);
+   - proper tuple types:                  int * int * int list
+   A proper tuple type is a star-separated list of at least two atomic types.
+ *)
+tuple_type:
+  | ty = atomic_type
+    %prec below_HASH
+      { ty }
+  | mktyp(
+      tys = separated_nontrivial_llist(STAR, atomic_type)
+        { Ptyp_tuple tys }
+    )
+    { $1 }
+;
+
+(* Atomic types are the most basic level in the syntax of types.
+   Atomic types include:
+   - types between parentheses:           (int -> int)
+   - first-class module types:            (module S)
+   - type variables:                      'a
+   - applications of type constructors:   int, int list, int option list
+   - variant types:                       [`A]
+ *)
+atomic_type:
+  | LPAREN core_type RPAREN
+      { $2 }
+  | LPAREN MODULE ext_attributes package_type RPAREN
+      { wrap_typ_attrs ~loc:$sloc (reloc_typ ~loc:$sloc $4) $3 }
+  | mktyp( /* begin mktyp group */
+      QUOTE ident
+        { Ptyp_var $2 }
+    | UNDERSCORE
+        { Ptyp_any }
+    | tys = actual_type_parameters
+      tid = mkrhs(type_longident)
+        { Ptyp_constr(tid, tys) }
+    | LESS meth_list GREATER
+        { let (f, c) = $2 in Ptyp_object (f, c) }
+    | LESS GREATER
+        { Ptyp_object ([], Closed) }
+    | tys = actual_type_parameters
+      HASH
+      cid = mkrhs(clty_longident)
+        { Ptyp_class(cid, tys) }
+    | LBRACKET tag_field RBRACKET
+        (* not row_field; see CONFLICTS *)
+        { Ptyp_variant([$2], Closed, None) }
+    | LBRACKET BAR row_field_list RBRACKET
+        { Ptyp_variant($3, Closed, None) }
+    | LBRACKET row_field BAR row_field_list RBRACKET
+        { Ptyp_variant($2 :: $4, Closed, None) }
+    | LBRACKETGREATER BAR? row_field_list RBRACKET
+        { Ptyp_variant($3, Open, None) }
+    | LBRACKETGREATER RBRACKET
+        { Ptyp_variant([], Open, None) }
+    | LBRACKETLESS BAR? row_field_list RBRACKET
+        { Ptyp_variant($3, Closed, Some []) }
+    | LBRACKETLESS BAR? row_field_list GREATER name_tag_list RBRACKET
+        { Ptyp_variant($3, Closed, Some $5) }
+    | extension
+        { Ptyp_extension $1 }
+  )
+  { $1 } /* end mktyp group */
+;
+
+(* This is the syntax of the actual type parameters in an application of
+   a type constructor, such as int, int list, or (int, bool) Hashtbl.t.
+   We allow one of the following:
+   - zero parameters;
+   - one parameter:
+     an atomic type;
+     among other things, this can be an arbitrary type between parentheses;
+   - two or more parameters:
+     arbitrary types, between parentheses, separated with commas.
+ *)
+%inline actual_type_parameters:
+  | /* empty */
+      { [] }
+  | ty = atomic_type
+      { [ty] }
+  | LPAREN tys = separated_nontrivial_llist(COMMA, core_type) RPAREN
+      { tys }
+;
+
+%inline package_type: module_type
+      { let (lid, cstrs, attrs) = package_type_of_module_type $1 in
+        let descr = Ptyp_package (lid, cstrs) in
+        mktyp ~loc:$sloc ~attrs descr }
+;
+%inline row_field_list:
+  separated_nonempty_llist(BAR, row_field)
+    { $1 }
+;
+row_field:
+    tag_field
+      { $1 }
+  | core_type
+      { Rf.inherit_ ~loc:(make_loc $sloc) $1 }
+;
+tag_field:
+    mkrhs(name_tag) OF opt_ampersand amper_type_list attributes
+      { let info = symbol_info $endpos in
+        let attrs = add_info_attrs info $5 in
+        Rf.tag ~loc:(make_loc $sloc) ~attrs $1 $3 $4 }
+  | mkrhs(name_tag) attributes
+      { let info = symbol_info $endpos in
+        let attrs = add_info_attrs info $2 in
+        Rf.tag ~loc:(make_loc $sloc) ~attrs $1 true [] }
+;
+opt_ampersand:
+    AMPERSAND                                   { true }
+  | /* empty */                                 { false }
+;
+%inline amper_type_list:
+  separated_nonempty_llist(AMPERSAND, core_type_no_attr)
+    { $1 }
+;
+%inline name_tag_list:
+  nonempty_llist(name_tag)
+    { $1 }
+;
+(* A method list (in an object type). *)
+meth_list:
+    head = field_semi         tail = meth_list
+  | head = inherit_field SEMI tail = meth_list
+      { let (f, c) = tail in (head :: f, c) }
+  | head = field_semi
+  | head = inherit_field SEMI
+      { [head], Closed }
+  | head = field
+  | head = inherit_field
+      { [head], Closed }
+  | DOTDOT
+      { [], Open }
+;
+%inline field:
+  mkrhs(label) COLON poly_type_no_attr attributes
+    { let info = symbol_info $endpos in
+      let attrs = add_info_attrs info $4 in
+      Of.tag ~loc:(make_loc $sloc) ~attrs $1 $3 }
+;
+
+%inline field_semi:
+  mkrhs(label) COLON poly_type_no_attr attributes SEMI attributes
+    { let info =
+        match rhs_info $endpos($4) with
+        | Some _ as info_before_semi -> info_before_semi
+        | None -> symbol_info $endpos
+      in
+      let attrs = add_info_attrs info ($4 @ $6) in
+      Of.tag ~loc:(make_loc $sloc) ~attrs $1 $3 }
+;
+
+%inline inherit_field:
+  ty = atomic_type
+    { Of.inherit_ ~loc:(make_loc $sloc) ty }
+;
+
+%inline label:
+    LIDENT                                      { $1 }
+;
+
+/* Constants */
+
+constant:
+  | INT          { let (n, m) = $1 in Pconst_integer (n, m) }
+  | CHAR         { Pconst_char $1 }
+  | STRING       { let (s, strloc, d) = $1 in Pconst_string (s, strloc, d) }
+  | FLOAT        { let (f, m) = $1 in Pconst_float (f, m) }
+;
+signed_constant:
+    constant     { $1 }
+  | MINUS INT    { let (n, m) = $2 in Pconst_integer("-" ^ n, m) }
+  | MINUS FLOAT  { let (f, m) = $2 in Pconst_float("-" ^ f, m) }
+  | PLUS INT     { let (n, m) = $2 in Pconst_integer (n, m) }
+  | PLUS FLOAT   { let (f, m) = $2 in Pconst_float(f, m) }
+;
+
+/* Identifiers and long identifiers */
+
+ident:
+    UIDENT                    { $1 }
+  | LIDENT                    { $1 }
+;
+val_extra_ident:
+  | LPAREN operator RPAREN    { $2 }
+  (*
+  | LPAREN operator error     { unclosed "(" $loc($1) ")" $loc($3) }
+  | LPAREN error              { expecting $loc($2) "operator" }
+  | LPAREN MODULE error       { expecting $loc($3) "module-expr" }
+  *)
+;
+val_ident:
+    LIDENT                    { $1 }
+  | val_extra_ident           { $1 }
+;
+operator:
+    PREFIXOP                                    { $1 }
+  | LETOP                                       { $1 }
+  | ANDOP                                       { $1 }
+  | DOTOP LPAREN index_mod RPAREN               { "."^ $1 ^"(" ^ $3 ^ ")" }
+  | DOTOP LPAREN index_mod RPAREN LESSMINUS     { "."^ $1 ^ "(" ^ $3 ^ ")<-" }
+  | DOTOP LBRACKET index_mod RBRACKET           { "."^ $1 ^"[" ^ $3 ^ "]" }
+  | DOTOP LBRACKET index_mod RBRACKET LESSMINUS { "."^ $1 ^ "[" ^ $3 ^ "]<-" }
+  | DOTOP LBRACE index_mod RBRACE               { "."^ $1 ^"{" ^ $3 ^ "}" }
+  | DOTOP LBRACE index_mod RBRACE LESSMINUS     { "."^ $1 ^ "{" ^ $3 ^ "}<-" }
+  | HASHOP                                      { $1 }
+  | BANG                                        { "!" }
+  | infix_operator                              { $1 }
+;
+%inline infix_operator:
+  | op = INFIXOP0 { op }
+  | op = INFIXOP1 { op }
+  | op = INFIXOP2 { op }
+  | op = INFIXOP3 { op }
+  | op = INFIXOP4 { op }
+  | PLUS           {"+"}
+  | PLUSDOT       {"+."}
+  | PLUSEQ        {"+="}
+  | MINUS          {"-"}
+  | MINUSDOT      {"-."}
+  | STAR           {"*"}
+  | PERCENT        {"%"}
+  | EQUAL          {"="}
+  | LESS           {"<"}
+  | GREATER        {">"}
+  | OR            {"or"}
+  | BARBAR        {"||"}
+  | AMPERSAND      {"&"}
+  | AMPERAMPER    {"&&"}
+  | COLONEQUAL    {":="}
+;
+index_mod:
+| { "" }
+| SEMI DOTDOT { ";.." }
+;
+%inline constr_extra_ident:
+  | LPAREN COLONCOLON RPAREN                    { "::" }
+;
+constr_extra_nonprefix_ident:
+  | LBRACKET RBRACKET                           { "[]" }
+  | LPAREN RPAREN                               { "()" }
+  | FALSE                                       { "false" }
+  | TRUE                                        { "true" }
+;
+constr_ident:
+    UIDENT                                      { $1 }
+  | constr_extra_ident                          { $1 }
+  | constr_extra_nonprefix_ident                { $1 }
+;
+constr_longident:
+    mod_longident       %prec below_DOT         { $1 } /* A.B.x vs (A).B.x */
+  | mod_longident DOT constr_extra_ident        { Ldot($1,$3) }
+  | constr_extra_ident                          { Lident $1 }
+  | constr_extra_nonprefix_ident                { Lident $1 }
+;
+mk_longident(prefix,final):
+  | final             { Lident $1 }
+  | prefix DOT final  { Ldot($1,$3) }
+;
+val_longident:
+    mk_longident(mod_longident, val_ident) { $1 }
+;
+label_longident:
+    mk_longident(mod_longident, LIDENT) { $1 }
+;
+type_longident:
+    mk_longident(mod_ext_longident, LIDENT) { $1 }
+;
+mod_longident:
+    mk_longident(mod_longident, UIDENT) { $1 }
+;
+mod_ext_longident:
+    mk_longident(mod_ext_longident, UIDENT) { $1 }
+  | mod_ext_longident LPAREN mod_ext_longident RPAREN
+      { lapply ~loc:$sloc $1 $3 }
+  (*
+  | mod_ext_longident LPAREN error
+      { expecting $loc($3) "module path" }
+  *)
+;
+mty_longident:
+    mk_longident(mod_ext_longident,ident) { $1 }
+;
+clty_longident:
+    mk_longident(mod_ext_longident,LIDENT) { $1 }
+;
+class_longident:
+    mk_longident(mod_longident,LIDENT) { $1 }
+;
+
+/* BEGIN AVOID */
+/* For compiler-libs: parse all valid longidents and a little more:
+   final identifiers which are value specific are accepted even when
+   the path prefix is only valid for types: (e.g. F(X).(::)) */
+any_longident:
+  | mk_longident (mod_ext_longident,
+     ident | constr_extra_ident | val_extra_ident { $1 }
+    ) { $1 }
+  | constr_extra_nonprefix_ident { Lident $1 }
+/* END AVOID */
+
+/* Toplevel directives */
+
+toplevel_directive:
+  HASH dir = mkrhs(ident)
+  arg = ioption(mk_directive_arg(toplevel_directive_argument))
+    { mk_directive ~loc:$sloc dir arg }
+;
+
+%inline toplevel_directive_argument:
+  | STRING        { let (s, _, _) = $1 in Pdir_string s }
+  | INT           { let (n, m) = $1 in Pdir_int (n ,m) }
+  | val_longident { Pdir_ident $1 }
+  | mod_longident { Pdir_ident $1 }
+  | FALSE         { Pdir_bool false }
+  | TRUE          { Pdir_bool true }
+;
+
+/* Miscellaneous */
+
+(* The symbol epsilon can be used instead of an /* empty */ comment. *)
+%inline epsilon:
+  /* empty */
+    { () }
+;
+
+%inline raw_string:
+  s = STRING
+    { let body, _, _ = s in body }
+;
+
+name_tag:
+    BACKQUOTE ident                             { $2 }
+;
+rec_flag:
+    /* empty */                                 { Nonrecursive }
+  | REC                                         { Recursive }
+;
+%inline nonrec_flag:
+    /* empty */                                 { Recursive }
+  | NONREC                                      { Nonrecursive }
+;
+%inline no_nonrec_flag:
+    /* empty */ { Recursive }
+/* BEGIN AVOID */
+  | NONREC      { not_expecting $loc "nonrec flag"; Recursive }
+/* END AVOID */
+;
+direction_flag:
+    TO                                          { Upto }
+  | DOWNTO                                      { Downto }
+;
+private_flag:
+  inline_private_flag
+    { $1 }
+;
+%inline inline_private_flag:
+    /* empty */                                 { Public }
+  | PRIVATE                                     { Private }
+;
+mutable_flag:
+    /* empty */                                 { Immutable }
+  | MUTABLE                                     { Mutable }
+;
+virtual_flag:
+    /* empty */                                 { Concrete }
+  | VIRTUAL                                     { Virtual }
+;
+mutable_virtual_flags:
+    /* empty */
+      { Immutable, Concrete }
+  | MUTABLE
+      { Mutable, Concrete }
+  | VIRTUAL
+      { Immutable, Virtual }
+  | MUTABLE VIRTUAL
+  | VIRTUAL MUTABLE
+      { Mutable, Virtual }
+;
+private_virtual_flags:
+    /* empty */  { Public, Concrete }
+  | PRIVATE { Private, Concrete }
+  | VIRTUAL { Public, Virtual }
+  | PRIVATE VIRTUAL { Private, Virtual }
+  | VIRTUAL PRIVATE { Private, Virtual }
+;
+(* This nonterminal symbol indicates the definite presence of a VIRTUAL
+   keyword and the possible presence of a MUTABLE keyword. *)
+virtual_with_mutable_flag:
+  | VIRTUAL { Immutable }
+  | MUTABLE VIRTUAL { Mutable }
+  | VIRTUAL MUTABLE { Mutable }
+;
+(* This nonterminal symbol indicates the definite presence of a VIRTUAL
+   keyword and the possible presence of a PRIVATE keyword. *)
+virtual_with_private_flag:
+  | VIRTUAL { Public }
+  | PRIVATE VIRTUAL { Private }
+  | VIRTUAL PRIVATE { Private }
+;
+%inline no_override_flag:
+    /* empty */                                 { Fresh }
+;
+%inline override_flag:
+    /* empty */                                 { Fresh }
+  | BANG                                        { Override }
+;
+subtractive:
+  | MINUS                                       { "-" }
+  | MINUSDOT                                    { "-." }
+;
+additive:
+  | PLUS                                        { "+" }
+  | PLUSDOT                                     { "+." }
+;
+optlabel:
+   | OPTLABEL                                   { $1 }
+   | QUESTION LIDENT COLON                      { $2 }
+;
+
+/* Attributes and extensions */
+
+single_attr_id:
+    LIDENT { $1 }
+  | UIDENT { $1 }
+  | AND { "and" }
+  | AS { "as" }
+  | ASSERT { "assert" }
+  | BEGIN { "begin" }
+  | CLASS { "class" }
+  | CONSTRAINT { "constraint" }
+  | DO { "do" }
+  | DONE { "done" }
+  | DOWNTO { "downto" }
+  | ELSE { "else" }
+  | END { "end" }
+  | EXCEPTION { "exception" }
+  | EXTERNAL { "external" }
+  | FALSE { "false" }
+  | FOR { "for" }
+  | FUN { "fun" }
+  | FUNCTION { "function" }
+  | FUNCTOR { "functor" }
+  | IF { "if" }
+  | IN { "in" }
+  | INCLUDE { "include" }
+  | INHERIT { "inherit" }
+  | INITIALIZER { "initializer" }
+  | LAZY { "lazy" }
+  | LET { "let" }
+  | MATCH { "match" }
+  | METHOD { "method" }
+  | MODULE { "module" }
+  | MUTABLE { "mutable" }
+  | NEW { "new" }
+  | NONREC { "nonrec" }
+  | OBJECT { "object" }
+  | OF { "of" }
+  | OPEN { "open" }
+  | OR { "or" }
+  | PRIVATE { "private" }
+  | REC { "rec" }
+  | SIG { "sig" }
+  | STRUCT { "struct" }
+  | THEN { "then" }
+  | TO { "to" }
+  | TRUE { "true" }
+  | TRY { "try" }
+  | TYPE { "type" }
+  | VAL { "val" }
+  | VIRTUAL { "virtual" }
+  | WHEN { "when" }
+  | WHILE { "while" }
+  | WITH { "with" }
+/* mod/land/lor/lxor/lsl/lsr/asr are not supported for now */
+;
+
+attr_id:
+  mkloc(
+      single_attr_id { $1 }
+    | single_attr_id DOT attr_id { $1 ^ "." ^ $3.txt }
+  ) { $1 }
+;
+attribute:
+  LBRACKETAT attr_id payload RBRACKET
+    { Attr.mk ~loc:(make_loc $sloc) $2 $3 }
+;
+post_item_attribute:
+  LBRACKETATAT attr_id payload RBRACKET
+    { Attr.mk ~loc:(make_loc $sloc) $2 $3 }
+;
+floating_attribute:
+  LBRACKETATATAT attr_id payload RBRACKET
+    { mark_symbol_docs $sloc;
+      Attr.mk ~loc:(make_loc $sloc) $2 $3 }
+;
+%inline post_item_attributes:
+  post_item_attribute*
+    { $1 }
+;
+%inline attributes:
+  attribute*
+    { $1 }
+;
+ext:
+  | /* empty */     { None }
+  | PERCENT attr_id { Some $2 }
+;
+%inline no_ext:
+  | /* empty */     { None }
+/* BEGIN AVOID */
+  | PERCENT attr_id { not_expecting $loc "extension"; None }
+/* END AVOID */
+;
+%inline ext_attributes:
+  ext attributes    { $1, $2 }
+;
+extension:
+  | LBRACKETPERCENT attr_id payload RBRACKET { ($2, $3) }
+  | QUOTED_STRING_EXPR
+    { mk_quotedext ~loc:$sloc $1 }
+;
+item_extension:
+  | LBRACKETPERCENTPERCENT attr_id payload RBRACKET { ($2, $3) }
+  | QUOTED_STRING_ITEM
+    { mk_quotedext ~loc:$sloc $1 }
+;
+payload:
+    structure { PStr $1 }
+  | COLON signature { PSig $2 }
+  | COLON core_type { PTyp $2 }
+  | QUESTION pattern { PPat ($2, None) }
+  | QUESTION pattern WHEN seq_expr { PPat ($2, Some $4) }
+;
+
+%public simple_expr:
+| DOTLESS expr GREATERDOT
+    { Fake.Meta.code $startpos $endpos $2 }
+| DOTTILDE simple_expr %prec prec_escape
+    { Fake.Meta.uncode $startpos $endpos $2 }
+;
+
+(* Lwt *)
+%public structure_item:
+| lwt_bindings
+    { val_of_lwt_bindings ~loc:$loc $1 }
+
+lwt_binding:
+    LET_LWT ext_attributes rec_flag let_binding_body post_item_attributes
+      { let (ext, attr) = $2 in
+        mklbs ext $3 (mklb ~loc:$loc($4) true $4 (attr@$5)) }
+;
+lwt_bindings:
+    lwt_binding                                 { $1 }
+  | lwt_bindings and_let_binding                { addlb $1 $2 }
+;
+
+%public expr:
+| lwt_bindings IN seq_expr
+    { expr_of_lwt_bindings ~loc:$loc $1 (merloc $endpos($2) $3) }
+| MATCH_LWT ext_attributes seq_expr WITH match_cases
+    { let expr = mkexp_attrs ~loc:$loc
+          (Pexp_match(Fake.app Fake.Lwt.un_lwt $3, List.rev $5)) $2 in
+      Fake.app Fake.Lwt.in_lwt expr }
+| TRY_LWT ext_attributes seq_expr %prec below_WITH
+    { reloc_exp ~loc:$loc (Fake.app Fake.Lwt.in_lwt $3) }
+| TRY_LWT ext_attributes seq_expr WITH match_cases
+    { mkexp_attrs ~loc:$loc
+        (Pexp_try(Fake.app Fake.Lwt.in_lwt $3, List.rev $5)) $2 }
+| TRY_LWT ext_attributes seq_expr FINALLY_LWT seq_expr
+    { Fake.app (Fake.app Fake.Lwt.finally_ $3) $5 }
+| TRY_LWT ext_attributes seq_expr WITH match_cases FINALLY_LWT seq_expr
+    { let expr = mkexp_attrs ~loc:$loc
+        (Pexp_try (Fake.app Fake.Lwt.in_lwt $3, List.rev $5)) $2 in
+      Fake.app (Fake.app Fake.Lwt.finally_ expr) $7 }
+| WHILE_LWT ext_attributes seq_expr DO seq_expr DONE
+  { let expr = Pexp_while ($3, Fake.(app Lwt.un_lwt $5)) in
+    Fake.(app Lwt.to_lwt (mkexp_attrs ~loc:$loc expr $2)) }
+| FOR_LWT ext_attributes pattern EQUAL seq_expr direction_flag seq_expr DO seq_expr DONE
+    { let expr = Pexp_for ($3, $5, $7, $6, Fake.(app Lwt.un_lwt $9)) in
+      Fake.(app Lwt.to_lwt (mkexp_attrs ~loc:$loc expr $2)) }
+| FOR_LWT ext_attributes pattern IN seq_expr DO seq_expr DONE
+    { mkexp_attrs ~loc:$loc
+          (Pexp_let (Nonrecursive, [Vb.mk $3 (Fake.(app Lwt.un_stream $5))],
+             Fake.(app Lwt.unit_lwt $7)))
+          $2
+    }
+;
+
+%%
diff --git a/src/ocaml/preprocess/parser_recover.ml b/src/ocaml/preprocess/parser_recover.ml
new file mode 100644
index 0000000..39ad3dc
--- /dev/null
+++ b/src/ocaml/preprocess/parser_recover.ml
@@ -0,0 +1,3530 @@
+open Parser_raw
+
+module Default = struct
+
+  open Parsetree
+  open Ast_helper
+
+  let default_loc = ref Location.none
+
+  let default_expr () =
+    let id = Location.mkloc Ast_helper.hole_txt !default_loc in
+    Exp.mk ~loc:!default_loc (Pexp_extension (id, PStr []))
+
+  let default_pattern () = Pat.any ~loc:!default_loc ()
+
+  let default_module_expr () = Mod.structure ~loc:!default_loc []
+  let default_module_type () = Mty.signature ~loc:!default_loc []
+
+  let value (type a) : a MenhirInterpreter.symbol -> a = function
+    | MenhirInterpreter.T MenhirInterpreter.T_error -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_WITH -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_WHILE_LWT -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_WHILE -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_WHEN -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_VIRTUAL -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_VAL -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_UNDERSCORE -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_UIDENT -> "_"
+    | MenhirInterpreter.T MenhirInterpreter.T_TYPE -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_TRY_LWT -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_TRY -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_TRUE -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_TO -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_TILDE -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_THEN -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_STRUCT -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_STRING -> ("", Location.none, None)
+    | MenhirInterpreter.T MenhirInterpreter.T_STAR -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_SIG -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_SEMISEMI -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_SEMI -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_RPAREN -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_REC -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_RBRACKET -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_RBRACE -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_QUOTED_STRING_ITEM -> ("", Location.none, "", Location.none, None)
+    | MenhirInterpreter.T MenhirInterpreter.T_QUOTED_STRING_EXPR -> ("", Location.none, "", Location.none, None)
+    | MenhirInterpreter.T MenhirInterpreter.T_QUOTE -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_QUESTION -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_PRIVATE -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_PREFIXOP -> "!+"
+    | MenhirInterpreter.T MenhirInterpreter.T_PLUSEQ -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_PLUSDOT -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_PLUS -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_PERCENT -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_OR -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_OPTLABEL -> "_"
+    | MenhirInterpreter.T MenhirInterpreter.T_OPEN -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_OF -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_OBJECT -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_NONREC -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_NEW -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_MUTABLE -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_MODULE -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_MINUSGREATER -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_MINUSDOT -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_MINUS -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_METHOD -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_MATCH_LWT -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_MATCH -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_LPAREN -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_LIDENT -> "_"
+    | MenhirInterpreter.T MenhirInterpreter.T_LET_LWT -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_LETOP -> raise Not_found
+    | MenhirInterpreter.T MenhirInterpreter.T_LET -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_LESSMINUS -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_LESS -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_LBRACKETPERCENTPERCENT -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_LBRACKETPERCENT -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_LBRACKETLESS -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_LBRACKETGREATER -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_LBRACKETBAR -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_LBRACKETATATAT -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_LBRACKETATAT -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_LBRACKETAT -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_LBRACKET -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_LBRACELESS -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_LBRACE -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_LAZY -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_LABEL -> "_"
+    | MenhirInterpreter.T MenhirInterpreter.T_INT -> ("0",None)
+    | MenhirInterpreter.T MenhirInterpreter.T_INITIALIZER -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_INHERIT -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_INFIXOP4 -> "_"
+    | MenhirInterpreter.T MenhirInterpreter.T_INFIXOP3 -> "_"
+    | MenhirInterpreter.T MenhirInterpreter.T_INFIXOP2 -> "_"
+    | MenhirInterpreter.T MenhirInterpreter.T_INFIXOP1 -> "_"
+    | MenhirInterpreter.T MenhirInterpreter.T_INFIXOP0 -> "_"
+    | MenhirInterpreter.T MenhirInterpreter.T_INCLUDE -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_IN -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_IF -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_HASHOP -> ""
+    | MenhirInterpreter.T MenhirInterpreter.T_HASH -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_GREATERRBRACKET -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_GREATERRBRACE -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_GREATERDOT -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_GREATER -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_FUNCTOR -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_FUNCTION -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_FUN -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_FOR_LWT -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_FOR -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_FLOAT -> ("0.",None)
+    | MenhirInterpreter.T MenhirInterpreter.T_FINALLY_LWT -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_FALSE -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_EXTERNAL -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_EXCEPTION -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_EQUAL -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_EOL -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_EOF -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_END -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_ELSE -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_DOWNTO -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_DOTTILDE -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_DOTOP -> raise Not_found
+    | MenhirInterpreter.T MenhirInterpreter.T_DOTLESS -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_DOTDOT -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_DOT -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_DONE -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_DOCSTRING -> raise Not_found
+    | MenhirInterpreter.T MenhirInterpreter.T_DO -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_CONSTRAINT -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_COMMENT -> ("", Location.none)
+    | MenhirInterpreter.T MenhirInterpreter.T_COMMA -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_COLONGREATER -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_COLONEQUAL -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_COLONCOLON -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_COLON -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_CLASS -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_CHAR -> '_'
+    | MenhirInterpreter.T MenhirInterpreter.T_BEGIN -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_BARRBRACKET -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_BARBAR -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_BAR -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_BANG -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_BACKQUOTE -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_ASSERT -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_AS -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_ANDOP -> raise Not_found
+    | MenhirInterpreter.T MenhirInterpreter.T_AND -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_AMPERSAND -> ()
+    | MenhirInterpreter.T MenhirInterpreter.T_AMPERAMPER -> ()
+    | MenhirInterpreter.N MenhirInterpreter.N_with_type_binder -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_with_constraint -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_virtual_with_private_flag -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_virtual_with_mutable_flag -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_virtual_flag -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_value_description -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_value -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_val_longident -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_val_ident -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_val_extra_ident -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_use_file -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_type_variance -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_type_variable -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_type_parameters -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_type_parameter -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_type_longident -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_type_kind -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_type_constraint -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_tuple_type -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_toplevel_phrase -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_toplevel_directive -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_tag_field -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_subtractive -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_structure_item -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_structure -> []
+    | MenhirInterpreter.N MenhirInterpreter.N_strict_binding -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_str_exception_declaration -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_single_attr_id -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_simple_pattern_not_ident -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_simple_pattern -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_simple_expr -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_simple_delimited_pattern -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_signed_constant -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_signature_item -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_signature -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_sig_exception_declaration -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_seq_expr -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_separated_or_terminated_nonempty_list_SEMI_record_expr_field_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_separated_or_terminated_nonempty_list_SEMI_pattern_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_separated_or_terminated_nonempty_list_SEMI_object_expr_field_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_separated_or_terminated_nonempty_list_SEMI_expr_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_row_field -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nontrivial_llist_STAR_atomic_type_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nontrivial_llist_COMMA_expr_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nontrivial_llist_COMMA_core_type_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nonempty_llist_STAR_atomic_type_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nonempty_llist_COMMA_type_parameter_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nonempty_llist_COMMA_core_type_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nonempty_llist_BAR_row_field_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nonempty_llist_AND_with_constraint_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_reversed_separated_nonempty_llist_AMPERSAND_core_type_no_attr_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_reversed_preceded_or_separated_nonempty_llist_BAR_match_case_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_reversed_nonempty_llist_typevar_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_reversed_nonempty_llist_name_tag_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_reversed_nonempty_llist_labeled_simple_expr_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_reversed_nonempty_llist_functor_arg_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_reversed_llist_preceded_CONSTRAINT_constrain__ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_reversed_bar_llist_extension_constructor_declaration_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_reversed_bar_llist_extension_constructor_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_reversed_bar_llist_constructor_declaration_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_record_expr_content -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_rec_flag -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_private_virtual_flags -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_private_flag -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_primitive_declaration -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_post_item_attribute -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_possibly_poly_core_type_no_attr_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_possibly_poly_core_type_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_payload -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_pattern_var -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_pattern_no_exn -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_pattern_gen -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_pattern_comma_list_pattern_no_exn_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_pattern_comma_list_pattern_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_pattern -> default_pattern ()
+    | MenhirInterpreter.N MenhirInterpreter.N_parse_val_longident -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_parse_pattern -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_parse_mty_longident -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_parse_mod_longident -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_parse_mod_ext_longident -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_parse_expression -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_parse_core_type -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_parse_constr_longident -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_parse_any_longident -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_paren_module_expr -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_optlabel -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_option_type_constraint_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_option_preceded_EQUAL_seq_expr__ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_option_preceded_EQUAL_pattern__ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_option_preceded_EQUAL_module_type__ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_option_preceded_EQUAL_expr__ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_option_preceded_COLON_core_type__ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_option_preceded_AS_mkrhs_LIDENT___ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_option_SEMI_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_option_BAR_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_opt_ampersand -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_operator -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_open_description -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_open_declaration -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_nonempty_type_kind -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_nonempty_list_raw_string_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_nonempty_list_mkrhs_LIDENT__ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_name_tag -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_mutable_virtual_flags -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_mutable_flag -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_mty_longident -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_module_type_subst -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_module_type_declaration -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_module_type -> default_module_type ()
+    | MenhirInterpreter.N MenhirInterpreter.N_module_subst -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_module_name -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_module_expr -> default_module_expr ()
+    | MenhirInterpreter.N MenhirInterpreter.N_module_declaration_body -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_module_binding_body -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_mod_longident -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_mod_ext_longident -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_mk_longident_mod_longident_val_ident_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_mk_longident_mod_longident_UIDENT_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_mk_longident_mod_longident_LIDENT_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_mk_longident_mod_ext_longident_ident_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_mk_longident_mod_ext_longident___anonymous_41_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_mk_longident_mod_ext_longident_UIDENT_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_mk_longident_mod_ext_longident_LIDENT_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_method_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_meth_list -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_match_case -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_lwt_bindings -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_lwt_binding -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_listx_SEMI_record_pat_field_UNDERSCORE_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_list_use_file_element_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_list_text_str_structure_item__ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_list_text_cstr_class_field__ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_list_text_csig_class_sig_field__ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_list_structure_element_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_list_signature_element_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_list_post_item_attribute_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_list_generic_and_type_declaration_type_subst_kind__ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_list_generic_and_type_declaration_type_kind__ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_list_attribute_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_list_and_module_declaration_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_list_and_module_binding_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_list_and_class_type_declaration_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_list_and_class_description_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_list_and_class_declaration_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_letop_bindings -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_letop_binding_body -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_let_pattern -> default_pattern ()
+    | MenhirInterpreter.N MenhirInterpreter.N_let_bindings_no_ext_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_let_bindings_ext_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_let_binding_body_no_punning -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_let_binding_body -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_labeled_simple_pattern -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_labeled_simple_expr -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_label_longident -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_label_let_pattern -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_label_declarations -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_label_declaration_semi -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_label_declaration -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_item_extension -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_interface -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_index_mod -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_implementation -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_ident -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_generic_type_declaration_nonrec_flag_type_kind_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_generic_type_declaration_no_nonrec_flag_type_subst_kind_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_generic_constructor_declaration_epsilon_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_generic_constructor_declaration_BAR_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_generalized_constructor_arguments -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_functor_args -> []
+    | MenhirInterpreter.N MenhirInterpreter.N_functor_arg -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_function_type -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_fun_def -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_fun_binding -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_formal_class_parameters -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_floating_attribute -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_extension_constructor_rebind_epsilon_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_extension_constructor_rebind_BAR_ -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_extension -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_ext -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_expr -> default_expr ()
+    | MenhirInterpreter.N MenhirInterpreter.N_direction_flag -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_core_type -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_constructor_declarations -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_constructor_arguments -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_constrain_field -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_constr_longident -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_constr_ident -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_constr_extra_nonprefix_ident -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_constant -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_clty_longident -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_class_type_declarations -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_class_type -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_class_simple_expr -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_class_signature -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_class_sig_field -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_class_self_type -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_class_self_pattern -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_class_longident -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_class_fun_def -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_class_fun_binding -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_class_field -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_class_expr -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_attribute -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_attr_id -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_atomic_type -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_any_longident -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_and_let_binding -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_alias_type -> raise Not_found
+    | MenhirInterpreter.N MenhirInterpreter.N_additive -> raise Not_found
+end
+
+let default_value = Default.value
+
+open MenhirInterpreter
+
+type action =
+  | Abort
+  | R of int
+  | S : 'a symbol -> action
+  | Sub of action list
+
+type decision =
+  | Nothing
+  | One of action list
+  | Select of (int -> action list)
+
+let depth =
+  [|0;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;2;3;2;2;1;2;1;2;3;1;1;1;2;3;1;2;3;1;1;1;1;1;2;3;1;1;2;3;3;1;1;4;1;2;1;1;2;1;1;1;2;1;2;3;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;2;1;2;3;4;5;2;3;4;5;2;3;4;5;1;1;1;1;1;1;2;3;4;5;1;1;1;1;1;2;1;2;3;1;1;2;3;4;1;1;2;1;2;3;1;1;2;4;1;2;1;1;1;2;2;1;1;1;2;2;1;2;3;2;3;5;6;1;1;1;1;1;2;1;1;1;2;1;2;1;1;2;1;2;2;1;1;1;2;3;4;2;3;1;2;3;1;2;2;1;2;1;1;2;1;2;1;1;3;2;3;2;1;2;3;4;1;2;3;3;1;1;3;4;2;3;1;2;1;3;4;2;1;3;2;3;4;5;1;2;1;2;1;2;3;2;3;4;5;3;4;3;4;4;5;6;2;1;1;2;3;2;3;3;4;5;6;1;7;1;2;3;1;2;2;3;3;4;5;2;3;2;3;4;5;4;2;3;2;3;2;3;1;2;2;1;1;2;3;4;5;6;7;3;4;1;2;1;1;2;1;1;1;1;2;1;1;2;3;1;2;3;2;1;1;2;3;4;2;3;4;1;1;1;2;1;1;2;2;1;2;3;1;2;3;1;2;1;2;3;4;5;6;4;4;3;4;5;3;3;1;7;8;9;1;2;1;2;3;4;5;6;7;8;2;3;4;5;1;2;9;6;7;1;8;1;2;3;1;2;3;1;2;3;4;5;4;5;1;9;10;2;2;1;1;1;1;1;2;3;4;1;4;5;6;7;8;5;6;7;8;9;1;1;1;1;1;2;3;4;1;1;2;1;2;3;1;1;1;2;2;1;2;2;1;1;2;3;4;1;1;5;6;6;1;2;3;4;1;2;3;1;1;1;2;3;1;2;3;1;2;1;2;3;1;4;1;1;1;1;2;3;1;1;2;2;1;1;2;3;1;1;2;1;1;1;1;1;4;1;1;2;3;1;1;1;2;3;4;1;2;3;1;1;1;2;3;2;3;2;1;2;1;1;2;3;1;2;4;5;6;1;1;2;3;2;3;3;4;5;2;3;2;3;2;4;4;5;3;4;2;3;1;2;3;3;2;3;4;5;1;6;5;2;2;3;1;1;2;1;2;3;3;4;2;1;2;3;1;1;1;1;1;2;1;2;3;3;4;5;1;2;1;2;3;4;1;2;1;1;2;3;4;5;1;2;1;2;2;3;1;1;2;1;2;3;4;1;5;2;1;2;3;1;2;4;5;4;5;6;1;2;3;4;5;2;1;2;3;3;1;1;1;4;5;2;3;2;3;4;2;3;4;1;3;2;3;1;2;3;4;5;3;4;1;5;2;3;2;3;3;4;5;2;2;1;1;6;7;1;1;1;1;1;1;1;1;1;1;2;3;1;2;3;1;2;3;1;2;3;1;1;2;1;2;3;4;5;6;7;1;1;2;3;4;5;1;2;3;4;5;1;1;1;2;1;1;2;3;4;1;1;4;5;6;7;8;9;10;1;1;1;1;2;3;4;1;2;3;4;2;3;2;3;1;1;1;2;1;2;1;2;2;3;2;3;4;5;1;2;1;2;1;1;1;1;1;2;3;1;1;2;3;1;2;3;2;3;2;1;2;1;2;2;3;4;5;3;2;3;2;3;2;3;2;3;2;3;2;3;2;3;2;3;2;3;2;3;2;3;2;3;2;3;2;3;2;3;2;3;2;3;2;3;2;3;2;3;1;2;1;2;3;4;5;1;2;3;2;3;2;3;2;3;2;3;2;1;1;2;3;1;3;4;2;2;3;3;4;5;3;4;5;3;4;5;6;7;1;2;3;5;6;7;5;6;7;3;1;2;2;3;4;5;6;7;3;4;5;6;7;3;4;5;6;7;2;3;4;5;6;7;3;4;5;6;7;3;4;5;6;7;3;4;5;6;7;8;9;5;6;7;8;9;5;6;7;8;9;3;4;5;1;2;2;1;2;4;5;3;4;5;3;4;5;5;1;2;3;2;3;4;2;3;1;1;4;5;3;4;4;5;3;4;4;5;3;4;5;3;1;2;3;1;1;2;1;2;3;4;1;2;3;4;5;1;4;5;1;2;3;3;6;1;1;7;8;9;10;11;6;7;8;9;5;6;7;8;9;10;11;2;1;2;3;4;1;2;3;4;1;1;2;5;8;4;5;3;4;5;2;3;3;2;4;2;3;1;4;5;6;7;8;4;4;5;4;2;3;2;2;3;2;2;3;4;2;2;3;2;3;2;2;3;8;3;4;5;6;7;2;3;4;5;1;2;1;2;3;4;6;7;8;1;2;2;3;4;5;6;7;8;9;2;3;4;5;6;2;1;2;3;1;1;2;5;2;2;4;5;2;2;3;4;5;6;7;8;3;4;5;6;7;2;3;4;2;5;6;3;4;5;6;4;5;6;4;5;5;6;7;5;6;7;7;8;9;5;7;8;2;3;3;4;5;4;1;1;2;3;4;5;6;5;6;7;2;3;1;1;2;1;2;2;3;4;5;2;3;4;5;4;5;6;1;1;2;3;4;5;6;7;8;9;10;11;1;2;3;6;7;8;1;5;2;3;1;1;2;1;2;2;3;4;5;2;3;4;5;6;7;8;9;10;5;6;7;4;1;2;1;2;3;4;1;2;3;4;5;1;2;6;7;2;3;4;5;6;7;1;2;3;4;5;6;8;4;5;6;1;2;1;2;3;4;5;1;2;3;4;5;6;7;1;2;8;9;1;2;3;4;5;6;7;8;5;6;7;1;1;1;2;3;4;5;6;2;3;4;5;1;2;3;4;5;6;7;8;2;3;4;5;6;7;4;5;6;7;8;1;2;3;4;5;6;7;9;4;5;6;7;1;2;5;6;1;2;1;2;3;4;5;1;2;3;4;1;2;3;4;1;5;1;2;3;6;7;8;1;2;1;2;3;3;1;2;1;2;1;2;3;4;5;6;7;1;2;1;2;1;2;3;4;5;6;7;1;2;1;2;3;4;5;6;1;2;3;4;2;3;1;1;1;7;2;3;4;5;6;3;4;1;2;1;2;3;3;4;4;5;1;2;1;1;2;9;10;1;2;3;4;5;6;7;8;9;11;2;3;4;5;6;7;1;2;3;4;1;1;1;2;1;2;3;1;1;4;1;3;5;8;9;1;2;3;4;5;6;7;8;9;10;1;1;1;1;1;1;1;1;2;1;2;1;1;2;3;4;5;6;7;8;2;1;1;2;3;4;5;6;7;8;9;2;1;1;2;2;1;2;1;2;3;4;5;6;1;1;2;3;1;2;3;4;1;2;3;1;1;2;3;4;5;6;7;2;3;4;5;6;1;2;3;4;1;2;1;2;1;2;1;1;2;1;3;2;2;3;2;3;7;3;4;5;6;2;3;4;5;2;3;3;4;5;4;1;2;5;6;2;3;4;5;1;2;3;4;4;5;1;2;1;1;2;2;1;2;3;4;1;2;7;8;1;2;3;4;5;6;7;8;9;1;1;1;1;1;1;1;1;1;2;1;1;2;1;2;1;1;1;1;2;3;3;4;1;1;1;3;4;5;6;3;4;5;6;2;3;4;5;2;3;4;2;3;4;10;6;7;8;9;10;2;1;1;4;5;6;7;8;9;5;6;7;8;9;3;4;5;6;6;7;3;4;2;2;3;4;5;6;6;7;8;2;3;3;4;4;5;6;4;5;6;7;8;5;6;4;5;6;7;3;4;3;4;5;6;7;1;2;1;0;1;2;1;0;1;2;3;1;1;1;2;3;4;5;3;3;1;1;1;1;2;0;1;1;2;0;1;1;2;0;1;2;1;0;1;1;2;0;1;1;2;0;1;1;2;0;1;2;1;0;1;2;1;1;2;0;1;2;3;3;3;3;3;3;1;1;1;2;1;2;1;2;3;1;2;0;1;1;1;2;2;2;3;4;2;1;1;2;3;4;1;2;|]
+
+let can_pop (type a) : a terminal -> bool = function
+  | T_WITH -> true
+  | T_WHILE_LWT -> true
+  | T_WHILE -> true
+  | T_WHEN -> true
+  | T_VIRTUAL -> true
+  | T_VAL -> true
+  | T_UNDERSCORE -> true
+  | T_TYPE -> true
+  | T_TRY_LWT -> true
+  | T_TRY -> true
+  | T_TRUE -> true
+  | T_TO -> true
+  | T_TILDE -> true
+  | T_THEN -> true
+  | T_STRUCT -> true
+  | T_STAR -> true
+  | T_SIG -> true
+  | T_SEMISEMI -> true
+  | T_SEMI -> true
+  | T_RPAREN -> true
+  | T_REC -> true
+  | T_RBRACKET -> true
+  | T_RBRACE -> true
+  | T_QUOTE -> true
+  | T_QUESTION -> true
+  | T_PRIVATE -> true
+  | T_PLUSEQ -> true
+  | T_PLUSDOT -> true
+  | T_PLUS -> true
+  | T_PERCENT -> true
+  | T_OR -> true
+  | T_OPEN -> true
+  | T_OF -> true
+  | T_OBJECT -> true
+  | T_NONREC -> true
+  | T_NEW -> true
+  | T_MUTABLE -> true
+  | T_MODULE -> true
+  | T_MINUSGREATER -> true
+  | T_MINUSDOT -> true
+  | T_MINUS -> true
+  | T_METHOD -> true
+  | T_MATCH_LWT -> true
+  | T_MATCH -> true
+  | T_LPAREN -> true
+  | T_LET_LWT -> true
+  | T_LET -> true
+  | T_LESSMINUS -> true
+  | T_LESS -> true
+  | T_LBRACKETPERCENTPERCENT -> true
+  | T_LBRACKETPERCENT -> true
+  | T_LBRACKETLESS -> true
+  | T_LBRACKETGREATER -> true
+  | T_LBRACKETBAR -> true
+  | T_LBRACKETATATAT -> true
+  | T_LBRACKETATAT -> true
+  | T_LBRACKETAT -> true
+  | T_LBRACKET -> true
+  | T_LBRACELESS -> true
+  | T_LBRACE -> true
+  | T_LAZY -> true
+  | T_INITIALIZER -> true
+  | T_INHERIT -> true
+  | T_INCLUDE -> true
+  | T_IN -> true
+  | T_IF -> true
+  | T_HASH -> true
+  | T_GREATERRBRACKET -> true
+  | T_GREATERRBRACE -> true
+  | T_GREATERDOT -> true
+  | T_GREATER -> true
+  | T_FUNCTOR -> true
+  | T_FUNCTION -> true
+  | T_FUN -> true
+  | T_FOR_LWT -> true
+  | T_FOR -> true
+  | T_FINALLY_LWT -> true
+  | T_FALSE -> true
+  | T_EXTERNAL -> true
+  | T_EXCEPTION -> true
+  | T_EQUAL -> true
+  | T_EOL -> true
+  | T_END -> true
+  | T_ELSE -> true
+  | T_DOWNTO -> true
+  | T_DOTTILDE -> true
+  | T_DOTLESS -> true
+  | T_DOTDOT -> true
+  | T_DOT -> true
+  | T_DONE -> true
+  | T_DO -> true
+  | T_CONSTRAINT -> true
+  | T_COMMA -> true
+  | T_COLONGREATER -> true
+  | T_COLONEQUAL -> true
+  | T_COLONCOLON -> true
+  | T_COLON -> true
+  | T_CLASS -> true
+  | T_BEGIN -> true
+  | T_BARRBRACKET -> true
+  | T_BARBAR -> true
+  | T_BAR -> true
+  | T_BANG -> true
+  | T_BACKQUOTE -> true
+  | T_ASSERT -> true
+  | T_AS -> true
+  | T_AND -> true
+  | T_AMPERSAND -> true
+  | T_AMPERAMPER -> true
+  | _ -> false
+
+let recover =
+  let r0 = [R 579] in
+  let r1 = S (N N_expr) :: r0 in
+  let r2 = [R 125] in
+  let r3 = S (T T_DONE) :: r2 in
+  let r4 = Sub (r1) :: r3 in
+  let r5 = S (T T_DO) :: r4 in
+  let r6 = Sub (r1) :: r5 in
+  let r7 = R 278 :: r6 in
+  let r8 = [R 677] in
+  let r9 = S (T T_AND) :: r8 in
+  let r10 = [R 40] in
+  let r11 = Sub (r9) :: r10 in
+  let r12 = [R 187] in
+  let r13 = [R 41] in
+  let r14 = [R 500] in
+  let r15 = S (N N_structure) :: r14 in
+  let r16 = [R 42] in
+  let r17 = S (T T_RBRACKET) :: r16 in
+  let r18 = Sub (r15) :: r17 in
+  let r19 = [R 140] in
+  let r20 = S (T T_DONE) :: r19 in
+  let r21 = Sub (r1) :: r20 in
+  let r22 = S (T T_DO) :: r21 in
+  let r23 = Sub (r1) :: r22 in
+  let r24 = R 278 :: r23 in
+  let r25 = [R 645] in
+  let r26 = [R 342] in
+  let r27 = [R 121] in
+  let r28 = Sub (r1) :: r27 in
+  let r29 = R 278 :: r28 in
+  let r30 = [R 311] in
+  let r31 = Sub (r1) :: r30 in
+  let r32 = S (T T_MINUSGREATER) :: r31 in
+  let r33 = S (N N_pattern) :: r32 in
+  let r34 = [R 544] in
+  let r35 = Sub (r33) :: r34 in
+  let r36 = [R 137] in
+  let r37 = Sub (r35) :: r36 in
+  let r38 = S (T T_WITH) :: r37 in
+  let r39 = Sub (r1) :: r38 in
+  let r40 = R 278 :: r39 in
+  let r41 = [R 189] in
+  let r42 = S (T T_UNDERSCORE) :: r25 in
+  let r43 = [R 635] in
+  let r44 = [R 340] in
+  let r45 = S (T T_LIDENT) :: r44 in
+  let r46 = [R 64] in
+  let r47 = Sub (r45) :: r46 in
+  let r48 = [R 628] in
+  let r49 = Sub (r47) :: r48 in
+  let r50 = R 278 :: r49 in
+  let r51 = [R 341] in
+  let r52 = S (T T_LIDENT) :: r51 in
+  let r53 = [R 343] in
+  let r54 = [R 348] in
+  let r55 = [R 279] in
+  let r56 = [R 615] in
+  let r57 = S (T T_RPAREN) :: r56 in
+  let r58 = [R 99] in
+  let r59 = [R 792] in
+  let r60 = [R 188] in
+  let r61 = S (T T_RBRACKET) :: r60 in
+  let r62 = Sub (r15) :: r61 in
+  let r63 = S (T T_LIDENT) :: r59 in
+  let r64 = [R 23] in
+  let r65 = S (T T_UNDERSCORE) :: r64 in
+  let r66 = [R 765] in
+  let r67 = Sub (r65) :: r66 in
+  let r68 = [R 201] in
+  let r69 = Sub (r67) :: r68 in
+  let r70 = [R 15] in
+  let r71 = Sub (r69) :: r70 in
+  let r72 = [R 115] in
+  let r73 = Sub (r71) :: r72 in
+  let r74 = [R 800] in
+  let r75 = R 284 :: r74 in
+  let r76 = Sub (r73) :: r75 in
+  let r77 = S (T T_COLON) :: r76 in
+  let r78 = Sub (r63) :: r77 in
+  let r79 = R 278 :: r78 in
+  let r80 = [R 437] in
+  let r81 = S (T T_AMPERAMPER) :: r80 in
+  let r82 = [R 791] in
+  let r83 = S (T T_RPAREN) :: r82 in
+  let r84 = Sub (r81) :: r83 in
+  let r85 = [R 411] in
+  let r86 = S (T T_RPAREN) :: r85 in
+  let r87 = R 221 :: r86 in
+  let r88 = [R 222] in
+  let r89 = [R 413] in
+  let r90 = S (T T_RBRACKET) :: r89 in
+  let r91 = [R 415] in
+  let r92 = S (T T_RBRACE) :: r91 in
+  let r93 = [R 330] in
+  let r94 = [R 219] in
+  let r95 = S (T T_LIDENT) :: r94 in
+  let r96 = [R 22] in
+  let r97 = Sub (r95) :: r96 in
+  let r98 = [R 460] in
+  let r99 = S (T T_COLON) :: r98 in
+  let r100 = [R 21] in
+  let r101 = S (T T_RPAREN) :: r100 in
+  let r102 = S (N N_module_type) :: r101 in
+  let r103 = R 278 :: r102 in
+  let r104 = R 186 :: r103 in
+  let r105 = [R 584] in
+  let r106 = R 286 :: r105 in
+  let r107 = [R 366] in
+  let r108 = S (T T_END) :: r107 in
+  let r109 = Sub (r106) :: r108 in
+  let r110 = [R 216] in
+  let r111 = R 284 :: r110 in
+  let r112 = R 534 :: r111 in
+  let r113 = R 770 :: r112 in
+  let r114 = S (T T_LIDENT) :: r113 in
+  let r115 = R 774 :: r114 in
+  let r116 = R 278 :: r115 in
+  let r117 = R 186 :: r116 in
+  let r118 = [R 328] in
+  let r119 = S (T T_LIDENT) :: r118 in
+  let r120 = [R 772] in
+  let r121 = Sub (r119) :: r120 in
+  let r122 = [R 100] in
+  let r123 = S (T T_FALSE) :: r122 in
+  let r124 = [R 104] in
+  let r125 = Sub (r123) :: r124 in
+  let r126 = [R 213] in
+  let r127 = R 278 :: r126 in
+  let r128 = R 208 :: r127 in
+  let r129 = Sub (r125) :: r128 in
+  let r130 = [R 531] in
+  let r131 = Sub (r129) :: r130 in
+  let r132 = [R 591] in
+  let r133 = R 284 :: r132 in
+  let r134 = Sub (r131) :: r133 in
+  let r135 = R 511 :: r134 in
+  let r136 = S (T T_PLUSEQ) :: r135 in
+  let r137 = Sub (r121) :: r136 in
+  let r138 = R 774 :: r137 in
+  let r139 = R 278 :: r138 in
+  let r140 = [R 217] in
+  let r141 = R 284 :: r140 in
+  let r142 = R 534 :: r141 in
+  let r143 = R 770 :: r142 in
+  let r144 = S (T T_LIDENT) :: r143 in
+  let r145 = R 774 :: r144 in
+  let r146 = [R 592] in
+  let r147 = R 284 :: r146 in
+  let r148 = Sub (r131) :: r147 in
+  let r149 = R 511 :: r148 in
+  let r150 = S (T T_PLUSEQ) :: r149 in
+  let r151 = Sub (r121) :: r150 in
+  let r152 = [R 778] in
+  let r153 = S (T T_UNDERSCORE) :: r152 in
+  let r154 = [R 773] in
+  let r155 = Sub (r153) :: r154 in
+  let r156 = R 779 :: r155 in
+  let r157 = [R 555] in
+  let r158 = Sub (r156) :: r157 in
+  let r159 = [R 776] in
+  let r160 = S (T T_RPAREN) :: r159 in
+  let r161 = [R 777] in
+  let r162 = [R 556] in
+  let r163 = [R 396] in
+  let r164 = S (T T_DOTDOT) :: r163 in
+  let r165 = [R 771] in
+  let r166 = [R 397] in
+  let r167 = [R 103] in
+  let r168 = S (T T_RPAREN) :: r167 in
+  let r169 = [R 203] in
+  let r170 = Sub (r69) :: r169 in
+  let r171 = S (T T_MINUSGREATER) :: r170 in
+  let r172 = Sub (r67) :: r171 in
+  let r173 = [R 28] in
+  let r174 = [R 507] in
+  let r175 = Sub (r71) :: r174 in
+  let r176 = [R 318] in
+  let r177 = R 278 :: r176 in
+  let r178 = Sub (r175) :: r177 in
+  let r179 = [R 542] in
+  let r180 = [R 566] in
+  let r181 = Sub (r73) :: r180 in
+  let r182 = [R 551] in
+  let r183 = Sub (r181) :: r182 in
+  let r184 = [R 37] in
+  let r185 = S (T T_RBRACKET) :: r184 in
+  let r186 = Sub (r183) :: r185 in
+  let r187 = [R 36] in
+  let r188 = [R 35] in
+  let r189 = S (T T_RBRACKET) :: r188 in
+  let r190 = [R 385] in
+  let r191 = Sub (r95) :: r190 in
+  let r192 = S (T T_BACKQUOTE) :: r191 in
+  let r193 = [R 753] in
+  let r194 = R 278 :: r193 in
+  let r195 = Sub (r192) :: r194 in
+  let r196 = [R 32] in
+  let r197 = S (T T_RBRACKET) :: r196 in
+  let r198 = [R 93] in
+  let r199 = Sub (r119) :: r198 in
+  let r200 = [R 29] in
+  let r201 = [R 331] in
+  let r202 = S (T T_UIDENT) :: r201 in
+  let r203 = S (T T_DOT) :: r202 in
+  let r204 = [R 329] in
+  let r205 = S (T T_LIDENT) :: r204 in
+  let r206 = S (T T_UIDENT) :: r93 in
+  let r207 = [R 346] in
+  let r208 = Sub (r206) :: r207 in
+  let r209 = [R 347] in
+  let r210 = S (T T_RPAREN) :: r209 in
+  let r211 = [R 33] in
+  let r212 = S (T T_RBRACKET) :: r211 in
+  let r213 = [R 204] in
+  let r214 = [R 563] in
+  let r215 = [R 30] in
+  let r216 = [R 202] in
+  let r217 = Sub (r69) :: r216 in
+  let r218 = S (T T_MINUSGREATER) :: r217 in
+  let r219 = [R 564] in
+  let r220 = [R 552] in
+  let r221 = [R 547] in
+  let r222 = Sub (r71) :: r221 in
+  let r223 = [R 752] in
+  let r224 = R 278 :: r223 in
+  let r225 = Sub (r222) :: r224 in
+  let r226 = [R 548] in
+  let r227 = [R 16] in
+  let r228 = Sub (r95) :: r227 in
+  let r229 = [R 34] in
+  let r230 = S (T T_RBRACKET) :: r229 in
+  let r231 = Sub (r183) :: r230 in
+  let r232 = [R 540] in
+  let r233 = Sub (r192) :: r232 in
+  let r234 = [R 38] in
+  let r235 = S (T T_RBRACKET) :: r234 in
+  let r236 = [R 508] in
+  let r237 = Sub (r71) :: r236 in
+  let r238 = [R 543] in
+  let r239 = [R 316] in
+  let r240 = [R 27] in
+  let r241 = [R 26] in
+  let r242 = Sub (r121) :: r241 in
+  let r243 = [R 31] in
+  let r244 = [R 559] in
+  let r245 = [R 20] in
+  let r246 = [R 560] in
+  let r247 = [R 98] in
+  let r248 = [R 226] in
+  let r249 = R 278 :: r248 in
+  let r250 = Sub (r175) :: r249 in
+  let r251 = S (T T_COLON) :: r250 in
+  let r252 = S (T T_LIDENT) :: r251 in
+  let r253 = R 378 :: r252 in
+  let r254 = [R 228] in
+  let r255 = Sub (r253) :: r254 in
+  let r256 = [R 401] in
+  let r257 = S (T T_RBRACE) :: r256 in
+  let r258 = [R 227] in
+  let r259 = R 278 :: r258 in
+  let r260 = S (T T_SEMI) :: r259 in
+  let r261 = R 278 :: r260 in
+  let r262 = Sub (r175) :: r261 in
+  let r263 = S (T T_COLON) :: r262 in
+  let r264 = [R 212] in
+  let r265 = R 278 :: r264 in
+  let r266 = R 208 :: r265 in
+  let r267 = [R 110] in
+  let r268 = Sub (r65) :: r267 in
+  let r269 = [R 209] in
+  let r270 = [R 112] in
+  let r271 = S (T T_RBRACE) :: r270 in
+  let r272 = [R 111] in
+  let r273 = Sub (r65) :: r272 in
+  let r274 = [R 211] in
+  let r275 = [R 210] in
+  let r276 = Sub (r65) :: r275 in
+  let r277 = Sub (r125) :: r266 in
+  let r278 = [R 400] in
+  let r279 = S (T T_RBRACE) :: r278 in
+  let r280 = [R 398] in
+  let r281 = [R 399] in
+  let r282 = [R 403] in
+  let r283 = S (T T_RBRACE) :: r282 in
+  let r284 = [R 402] in
+  let r285 = S (T T_RBRACE) :: r284 in
+  let r286 = [R 215] in
+  let r287 = R 284 :: r286 in
+  let r288 = R 534 :: r287 in
+  let r289 = [R 509] in
+  let r290 = S (T T_RBRACKET) :: r289 in
+  let r291 = Sub (r15) :: r290 in
+  let r292 = [R 525] in
+  let r293 = Sub (r129) :: r292 in
+  let r294 = [R 740] in
+  let r295 = R 284 :: r294 in
+  let r296 = Sub (r293) :: r295 in
+  let r297 = R 511 :: r296 in
+  let r298 = S (T T_PLUSEQ) :: r297 in
+  let r299 = Sub (r121) :: r298 in
+  let r300 = R 774 :: r299 in
+  let r301 = R 278 :: r300 in
+  let r302 = [R 741] in
+  let r303 = R 284 :: r302 in
+  let r304 = Sub (r293) :: r303 in
+  let r305 = R 511 :: r304 in
+  let r306 = S (T T_PLUSEQ) :: r305 in
+  let r307 = Sub (r121) :: r306 in
+  let r308 = [R 535] in
+  let r309 = Sub (r73) :: r308 in
+  let r310 = S (T T_EQUAL) :: r309 in
+  let r311 = [R 285] in
+  let r312 = [R 108] in
+  let r313 = Sub (r123) :: r312 in
+  let r314 = [R 190] in
+  let r315 = R 278 :: r314 in
+  let r316 = [R 107] in
+  let r317 = S (T T_RPAREN) :: r316 in
+  let r318 = S (T T_UIDENT) :: r53 in
+  let r319 = [R 106] in
+  let r320 = S (T T_RPAREN) :: r319 in
+  let r321 = S (T T_COLONCOLON) :: r320 in
+  let r322 = [R 191] in
+  let r323 = R 278 :: r322 in
+  let r324 = [R 290] in
+  let r325 = [R 404] in
+  let r326 = R 284 :: r325 in
+  let r327 = S (N N_module_expr) :: r326 in
+  let r328 = R 278 :: r327 in
+  let r329 = [R 405] in
+  let r330 = R 284 :: r329 in
+  let r331 = S (N N_module_expr) :: r330 in
+  let r332 = R 278 :: r331 in
+  let r333 = [R 354] in
+  let r334 = S (T T_END) :: r333 in
+  let r335 = S (N N_structure) :: r334 in
+  let r336 = [R 144] in
+  let r337 = S (T T_END) :: r336 in
+  let r338 = R 295 :: r337 in
+  let r339 = R 67 :: r338 in
+  let r340 = R 278 :: r339 in
+  let r341 = [R 65] in
+  let r342 = S (T T_RPAREN) :: r341 in
+  let r343 = [R 663] in
+  let r344 = [R 607] in
+  let r345 = [R 605] in
+  let r346 = [R 659] in
+  let r347 = S (T T_RPAREN) :: r346 in
+  let r348 = [R 364] in
+  let r349 = S (T T_UNDERSCORE) :: r348 in
+  let r350 = [R 661] in
+  let r351 = S (T T_RPAREN) :: r350 in
+  let r352 = Sub (r349) :: r351 in
+  let r353 = R 278 :: r352 in
+  let r354 = [R 662] in
+  let r355 = S (T T_RPAREN) :: r354 in
+  let r356 = [R 368] in
+  let r357 = S (N N_module_expr) :: r356 in
+  let r358 = R 278 :: r357 in
+  let r359 = S (T T_OF) :: r358 in
+  let r360 = [R 462] in
+  let r361 = S (T T_RPAREN) :: r360 in
+  let r362 = [R 463] in
+  let r363 = S (T T_RPAREN) :: r362 in
+  let r364 = S (N N_expr) :: r363 in
+  let r365 = [R 120] in
+  let r366 = Sub (r35) :: r365 in
+  let r367 = S (T T_WITH) :: r366 in
+  let r368 = Sub (r1) :: r367 in
+  let r369 = R 278 :: r368 in
+  let r370 = [R 136] in
+  let r371 = Sub (r35) :: r370 in
+  let r372 = S (T T_WITH) :: r371 in
+  let r373 = Sub (r1) :: r372 in
+  let r374 = R 278 :: r373 in
+  let r375 = [R 174] in
+  let r376 = [R 248] in
+  let r377 = Sub (r63) :: r376 in
+  let r378 = [R 308] in
+  let r379 = R 284 :: r378 in
+  let r380 = Sub (r377) :: r379 in
+  let r381 = R 518 :: r380 in
+  let r382 = R 278 :: r381 in
+  let r383 = [R 612] in
+  let r384 = [R 573] in
+  let r385 = S (N N_pattern) :: r384 in
+  let r386 = [R 610] in
+  let r387 = S (T T_RBRACKET) :: r386 in
+  let r388 = [R 233] in
+  let r389 = Sub (r45) :: r388 in
+  let r390 = [R 304] in
+  let r391 = R 453 :: r390 in
+  let r392 = R 447 :: r391 in
+  let r393 = Sub (r389) :: r392 in
+  let r394 = [R 609] in
+  let r395 = S (T T_RBRACE) :: r394 in
+  let r396 = [R 448] in
+  let r397 = [R 454] in
+  let r398 = S (T T_UNDERSCORE) :: r343 in
+  let r399 = [R 658] in
+  let r400 = Sub (r398) :: r399 in
+  let r401 = [R 491] in
+  let r402 = Sub (r400) :: r401 in
+  let r403 = R 278 :: r402 in
+  let r404 = [R 94] in
+  let r405 = [R 668] in
+  let r406 = S (T T_INT) :: r404 in
+  let r407 = [R 604] in
+  let r408 = Sub (r406) :: r407 in
+  let r409 = [R 665] in
+  let r410 = [R 670] in
+  let r411 = S (T T_RBRACKET) :: r410 in
+  let r412 = S (T T_LBRACKET) :: r411 in
+  let r413 = [R 671] in
+  let r414 = [R 482] in
+  let r415 = S (N N_pattern) :: r414 in
+  let r416 = R 278 :: r415 in
+  let r417 = [R 483] in
+  let r418 = [R 476] in
+  let r419 = [R 490] in
+  let r420 = [R 488] in
+  let r421 = [R 386] in
+  let r422 = S (T T_LIDENT) :: r421 in
+  let r423 = [R 489] in
+  let r424 = Sub (r400) :: r423 in
+  let r425 = S (T T_RPAREN) :: r424 in
+  let r426 = [R 484] in
+  let r427 = [R 673] in
+  let r428 = S (T T_RPAREN) :: r427 in
+  let r429 = [R 481] in
+  let r430 = [R 479] in
+  let r431 = [R 672] in
+  let r432 = [R 306] in
+  let r433 = [R 611] in
+  let r434 = [R 244] in
+  let r435 = [R 231] in
+  let r436 = S (T T_LIDENT) :: r435 in
+  let r437 = [R 243] in
+  let r438 = S (T T_RPAREN) :: r437 in
+  let r439 = [R 232] in
+  let r440 = [R 240] in
+  let r441 = [R 239] in
+  let r442 = S (T T_RPAREN) :: r441 in
+  let r443 = R 455 :: r442 in
+  let r444 = [R 456] in
+  let r445 = [R 263] in
+  let r446 = Sub (r63) :: r445 in
+  let r447 = [R 266] in
+  let r448 = Sub (r446) :: r447 in
+  let r449 = [R 172] in
+  let r450 = Sub (r1) :: r449 in
+  let r451 = S (T T_IN) :: r450 in
+  let r452 = [R 499] in
+  let r453 = S (T T_UNDERSCORE) :: r452 in
+  let r454 = [R 242] in
+  let r455 = [R 241] in
+  let r456 = S (T T_RPAREN) :: r455 in
+  let r457 = R 455 :: r456 in
+  let r458 = [R 261] in
+  let r459 = [R 728] in
+  let r460 = Sub (r1) :: r459 in
+  let r461 = S (T T_EQUAL) :: r460 in
+  let r462 = [R 195] in
+  let r463 = Sub (r461) :: r462 in
+  let r464 = [R 730] in
+  let r465 = Sub (r463) :: r464 in
+  let r466 = S (T T_RPAREN) :: r465 in
+  let r467 = Sub (r422) :: r466 in
+  let r468 = [R 245] in
+  let r469 = [R 131] in
+  let r470 = Sub (r1) :: r469 in
+  let r471 = S (T T_IN) :: r470 in
+  let r472 = S (N N_module_expr) :: r471 in
+  let r473 = R 278 :: r472 in
+  let r474 = R 186 :: r473 in
+  let r475 = [R 255] in
+  let r476 = R 284 :: r475 in
+  let r477 = Sub (r377) :: r476 in
+  let r478 = R 518 :: r477 in
+  let r479 = R 278 :: r478 in
+  let r480 = R 186 :: r479 in
+  let r481 = [R 132] in
+  let r482 = Sub (r1) :: r481 in
+  let r483 = S (T T_IN) :: r482 in
+  let r484 = S (N N_module_expr) :: r483 in
+  let r485 = R 278 :: r484 in
+  let r486 = [R 355] in
+  let r487 = S (N N_module_expr) :: r486 in
+  let r488 = S (T T_MINUSGREATER) :: r487 in
+  let r489 = S (N N_functor_args) :: r488 in
+  let r490 = [R 205] in
+  let r491 = [R 206] in
+  let r492 = S (T T_RPAREN) :: r491 in
+  let r493 = S (N N_module_type) :: r492 in
+  let r494 = [R 369] in
+  let r495 = S (T T_RPAREN) :: r494 in
+  let r496 = [R 367] in
+  let r497 = S (N N_module_type) :: r496 in
+  let r498 = S (T T_MINUSGREATER) :: r497 in
+  let r499 = S (N N_functor_args) :: r498 in
+  let r500 = [R 338] in
+  let r501 = Sub (r95) :: r500 in
+  let r502 = [R 377] in
+  let r503 = Sub (r501) :: r502 in
+  let r504 = [R 813] in
+  let r505 = S (N N_module_type) :: r504 in
+  let r506 = S (T T_EQUAL) :: r505 in
+  let r507 = Sub (r503) :: r506 in
+  let r508 = S (T T_TYPE) :: r507 in
+  let r509 = S (T T_MODULE) :: r508 in
+  let r510 = [R 549] in
+  let r511 = Sub (r509) :: r510 in
+  let r512 = [R 373] in
+  let r513 = [R 810] in
+  let r514 = Sub (r71) :: r513 in
+  let r515 = S (T T_COLONEQUAL) :: r514 in
+  let r516 = Sub (r389) :: r515 in
+  let r517 = [R 809] in
+  let r518 = R 534 :: r517 in
+  let r519 = [R 339] in
+  let r520 = Sub (r95) :: r519 in
+  let r521 = [R 814] in
+  let r522 = [R 372] in
+  let r523 = [R 811] in
+  let r524 = Sub (r208) :: r523 in
+  let r525 = [R 812] in
+  let r526 = [R 550] in
+  let r527 = [R 360] in
+  let r528 = [R 461] in
+  let r529 = S (T T_RPAREN) :: r528 in
+  let r530 = [R 650] in
+  let r531 = [R 567] in
+  let r532 = S (N N_expr) :: r531 in
+  let r533 = [R 653] in
+  let r534 = S (T T_RBRACKET) :: r533 in
+  let r535 = [R 638] in
+  let r536 = [R 570] in
+  let r537 = R 449 :: r536 in
+  let r538 = [R 450] in
+  let r539 = [R 576] in
+  let r540 = R 449 :: r539 in
+  let r541 = R 457 :: r540 in
+  let r542 = Sub (r389) :: r541 in
+  let r543 = [R 520] in
+  let r544 = Sub (r542) :: r543 in
+  let r545 = [R 647] in
+  let r546 = S (T T_RBRACE) :: r545 in
+  let r547 = [R 614] in
+  let r548 = [R 613] in
+  let r549 = S (T T_GREATERDOT) :: r548 in
+  let r550 = [R 143] in
+  let r551 = Sub (r42) :: r550 in
+  let r552 = R 278 :: r551 in
+  let r553 = [R 627] in
+  let r554 = S (T T_END) :: r553 in
+  let r555 = R 278 :: r554 in
+  let r556 = [R 139] in
+  let r557 = S (N N_expr) :: r556 in
+  let r558 = S (T T_THEN) :: r557 in
+  let r559 = Sub (r1) :: r558 in
+  let r560 = R 278 :: r559 in
+  let r561 = [R 133] in
+  let r562 = Sub (r35) :: r561 in
+  let r563 = R 278 :: r562 in
+  let r564 = [R 545] in
+  let r565 = [R 312] in
+  let r566 = Sub (r1) :: r565 in
+  let r567 = S (T T_MINUSGREATER) :: r566 in
+  let r568 = [R 246] in
+  let r569 = Sub (r400) :: r568 in
+  let r570 = [R 197] in
+  let r571 = Sub (r1) :: r570 in
+  let r572 = S (T T_MINUSGREATER) :: r571 in
+  let r573 = [R 134] in
+  let r574 = Sub (r572) :: r573 in
+  let r575 = Sub (r569) :: r574 in
+  let r576 = R 278 :: r575 in
+  let r577 = [R 135] in
+  let r578 = Sub (r572) :: r577 in
+  let r579 = S (T T_RPAREN) :: r578 in
+  let r580 = [R 127] in
+  let r581 = S (T T_DONE) :: r580 in
+  let r582 = Sub (r1) :: r581 in
+  let r583 = S (T T_DO) :: r582 in
+  let r584 = Sub (r1) :: r583 in
+  let r585 = S (T T_IN) :: r584 in
+  let r586 = S (N N_pattern) :: r585 in
+  let r587 = R 278 :: r586 in
+  let r588 = [R 118] in
+  let r589 = S (T T_DOWNTO) :: r588 in
+  let r590 = [R 141] in
+  let r591 = S (T T_DONE) :: r590 in
+  let r592 = Sub (r1) :: r591 in
+  let r593 = S (T T_DO) :: r592 in
+  let r594 = Sub (r1) :: r593 in
+  let r595 = Sub (r589) :: r594 in
+  let r596 = Sub (r1) :: r595 in
+  let r597 = S (T T_EQUAL) :: r596 in
+  let r598 = S (N N_pattern) :: r597 in
+  let r599 = R 278 :: r598 in
+  let r600 = [R 636] in
+  let r601 = [R 646] in
+  let r602 = S (T T_RPAREN) :: r601 in
+  let r603 = S (T T_LPAREN) :: r602 in
+  let r604 = S (T T_DOT) :: r603 in
+  let r605 = [R 656] in
+  let r606 = S (T T_RPAREN) :: r605 in
+  let r607 = S (N N_module_type) :: r606 in
+  let r608 = S (T T_COLON) :: r607 in
+  let r609 = S (N N_module_expr) :: r608 in
+  let r610 = R 278 :: r609 in
+  let r611 = [R 264] in
+  let r612 = Sub (r1) :: r611 in
+  let r613 = S (T T_EQUAL) :: r612 in
+  let r614 = [R 142] in
+  let r615 = Sub (r42) :: r614 in
+  let r616 = R 278 :: r615 in
+  let r617 = [R 643] in
+  let r618 = [R 620] in
+  let r619 = S (T T_RPAREN) :: r618 in
+  let r620 = Sub (r532) :: r619 in
+  let r621 = S (T T_LPAREN) :: r620 in
+  let r622 = [R 169] in
+  let r623 = [R 236] in
+  let r624 = [R 237] in
+  let r625 = [R 238] in
+  let r626 = [R 642] in
+  let r627 = [R 617] in
+  let r628 = S (T T_RPAREN) :: r627 in
+  let r629 = Sub (r1) :: r628 in
+  let r630 = S (T T_LPAREN) :: r629 in
+  let r631 = [R 561] in
+  let r632 = [R 119] in
+  let r633 = Sub (r1) :: r632 in
+  let r634 = [R 171] in
+  let r635 = Sub (r1) :: r634 in
+  let r636 = [R 159] in
+  let r637 = [R 153] in
+  let r638 = [R 170] in
+  let r639 = [R 582] in
+  let r640 = Sub (r1) :: r639 in
+  let r641 = [R 156] in
+  let r642 = [R 160] in
+  let r643 = [R 152] in
+  let r644 = [R 155] in
+  let r645 = [R 154] in
+  let r646 = [R 164] in
+  let r647 = [R 158] in
+  let r648 = [R 157] in
+  let r649 = [R 162] in
+  let r650 = [R 151] in
+  let r651 = [R 150] in
+  let r652 = [R 173] in
+  let r653 = [R 149] in
+  let r654 = [R 163] in
+  let r655 = [R 161] in
+  let r656 = [R 165] in
+  let r657 = [R 166] in
+  let r658 = [R 167] in
+  let r659 = [R 562] in
+  let r660 = [R 168] in
+  let r661 = [R 17] in
+  let r662 = R 284 :: r661 in
+  let r663 = Sub (r377) :: r662 in
+  let r664 = [R 254] in
+  let r665 = Sub (r1) :: r664 in
+  let r666 = S (T T_EQUAL) :: r665 in
+  let r667 = [R 253] in
+  let r668 = Sub (r1) :: r667 in
+  let r669 = [R 486] in
+  let r670 = [R 492] in
+  let r671 = [R 497] in
+  let r672 = [R 495] in
+  let r673 = [R 485] in
+  let r674 = [R 619] in
+  let r675 = S (T T_RBRACKET) :: r674 in
+  let r676 = Sub (r1) :: r675 in
+  let r677 = [R 618] in
+  let r678 = S (T T_RBRACE) :: r677 in
+  let r679 = Sub (r1) :: r678 in
+  let r680 = [R 621] in
+  let r681 = S (T T_RPAREN) :: r680 in
+  let r682 = Sub (r532) :: r681 in
+  let r683 = S (T T_LPAREN) :: r682 in
+  let r684 = [R 625] in
+  let r685 = S (T T_RBRACKET) :: r684 in
+  let r686 = Sub (r532) :: r685 in
+  let r687 = [R 623] in
+  let r688 = S (T T_RBRACE) :: r687 in
+  let r689 = Sub (r532) :: r688 in
+  let r690 = [R 235] in
+  let r691 = [R 179] in
+  let r692 = [R 624] in
+  let r693 = S (T T_RBRACKET) :: r692 in
+  let r694 = Sub (r532) :: r693 in
+  let r695 = [R 183] in
+  let r696 = [R 622] in
+  let r697 = S (T T_RBRACE) :: r696 in
+  let r698 = Sub (r532) :: r697 in
+  let r699 = [R 181] in
+  let r700 = [R 176] in
+  let r701 = [R 178] in
+  let r702 = [R 177] in
+  let r703 = [R 180] in
+  let r704 = [R 184] in
+  let r705 = [R 182] in
+  let r706 = [R 175] in
+  let r707 = [R 265] in
+  let r708 = Sub (r1) :: r707 in
+  let r709 = [R 267] in
+  let r710 = [R 640] in
+  let r711 = [R 652] in
+  let r712 = [R 651] in
+  let r713 = [R 655] in
+  let r714 = [R 654] in
+  let r715 = S (T T_LIDENT) :: r537 in
+  let r716 = [R 641] in
+  let r717 = S (T T_GREATERRBRACE) :: r716 in
+  let r718 = [R 648] in
+  let r719 = S (T T_RBRACE) :: r718 in
+  let r720 = [R 521] in
+  let r721 = Sub (r542) :: r720 in
+  let r722 = [R 769] in
+  let r723 = [R 767] in
+  let r724 = Sub (r73) :: r723 in
+  let r725 = [R 768] in
+  let r726 = [R 126] in
+  let r727 = S (T T_DONE) :: r726 in
+  let r728 = Sub (r1) :: r727 in
+  let r729 = S (T T_DO) :: r728 in
+  let r730 = Sub (r1) :: r729 in
+  let r731 = Sub (r589) :: r730 in
+  let r732 = [R 200] in
+  let r733 = Sub (r572) :: r732 in
+  let r734 = S (T T_RPAREN) :: r733 in
+  let r735 = [R 198] in
+  let r736 = Sub (r1) :: r735 in
+  let r737 = S (T T_MINUSGREATER) :: r736 in
+  let r738 = [R 199] in
+  let r739 = [R 546] in
+  let r740 = [R 138] in
+  let r741 = [R 626] in
+  let r742 = [R 637] in
+  let r743 = [R 649] in
+  let r744 = [R 349] in
+  let r745 = S (N N_module_expr) :: r744 in
+  let r746 = S (T T_EQUAL) :: r745 in
+  let r747 = [R 129] in
+  let r748 = Sub (r1) :: r747 in
+  let r749 = S (T T_IN) :: r748 in
+  let r750 = Sub (r746) :: r749 in
+  let r751 = Sub (r349) :: r750 in
+  let r752 = R 278 :: r751 in
+  let r753 = [R 350] in
+  let r754 = S (N N_module_expr) :: r753 in
+  let r755 = S (T T_EQUAL) :: r754 in
+  let r756 = [R 351] in
+  let r757 = [R 130] in
+  let r758 = Sub (r1) :: r757 in
+  let r759 = S (T T_IN) :: r758 in
+  let r760 = R 278 :: r759 in
+  let r761 = R 208 :: r760 in
+  let r762 = Sub (r125) :: r761 in
+  let r763 = R 278 :: r762 in
+  let r764 = [R 196] in
+  let r765 = Sub (r1) :: r764 in
+  let r766 = [R 729] in
+  let r767 = [R 252] in
+  let r768 = Sub (r1) :: r767 in
+  let r769 = S (T T_EQUAL) :: r768 in
+  let r770 = Sub (r73) :: r769 in
+  let r771 = S (T T_DOT) :: r770 in
+  let r772 = [R 251] in
+  let r773 = Sub (r1) :: r772 in
+  let r774 = S (T T_EQUAL) :: r773 in
+  let r775 = Sub (r73) :: r774 in
+  let r776 = [R 250] in
+  let r777 = Sub (r1) :: r776 in
+  let r778 = [R 466] in
+  let r779 = S (T T_RPAREN) :: r778 in
+  let r780 = [R 464] in
+  let r781 = S (T T_RPAREN) :: r780 in
+  let r782 = [R 465] in
+  let r783 = S (T T_RPAREN) :: r782 in
+  let r784 = [R 66] in
+  let r785 = S (T T_RPAREN) :: r784 in
+  let r786 = [R 796] in
+  let r787 = Sub (r1) :: r786 in
+  let r788 = S (T T_EQUAL) :: r787 in
+  let r789 = S (T T_LIDENT) :: r788 in
+  let r790 = R 378 :: r789 in
+  let r791 = R 278 :: r790 in
+  let r792 = [R 53] in
+  let r793 = R 284 :: r792 in
+  let r794 = [R 797] in
+  let r795 = Sub (r1) :: r794 in
+  let r796 = S (T T_EQUAL) :: r795 in
+  let r797 = S (T T_LIDENT) :: r796 in
+  let r798 = R 378 :: r797 in
+  let r799 = [R 799] in
+  let r800 = Sub (r1) :: r799 in
+  let r801 = [R 795] in
+  let r802 = Sub (r73) :: r801 in
+  let r803 = S (T T_COLON) :: r802 in
+  let r804 = [R 798] in
+  let r805 = Sub (r1) :: r804 in
+  let r806 = [R 322] in
+  let r807 = Sub (r461) :: r806 in
+  let r808 = S (T T_LIDENT) :: r807 in
+  let r809 = R 511 :: r808 in
+  let r810 = R 278 :: r809 in
+  let r811 = [R 54] in
+  let r812 = R 284 :: r811 in
+  let r813 = [R 323] in
+  let r814 = Sub (r461) :: r813 in
+  let r815 = S (T T_LIDENT) :: r814 in
+  let r816 = R 511 :: r815 in
+  let r817 = [R 505] in
+  let r818 = Sub (r73) :: r817 in
+  let r819 = [R 325] in
+  let r820 = Sub (r1) :: r819 in
+  let r821 = S (T T_EQUAL) :: r820 in
+  let r822 = [R 327] in
+  let r823 = Sub (r1) :: r822 in
+  let r824 = S (T T_EQUAL) :: r823 in
+  let r825 = Sub (r73) :: r824 in
+  let r826 = S (T T_DOT) :: r825 in
+  let r827 = [R 506] in
+  let r828 = Sub (r73) :: r827 in
+  let r829 = [R 321] in
+  let r830 = Sub (r818) :: r829 in
+  let r831 = S (T T_COLON) :: r830 in
+  let r832 = [R 324] in
+  let r833 = Sub (r1) :: r832 in
+  let r834 = S (T T_EQUAL) :: r833 in
+  let r835 = [R 326] in
+  let r836 = Sub (r1) :: r835 in
+  let r837 = S (T T_EQUAL) :: r836 in
+  let r838 = Sub (r73) :: r837 in
+  let r839 = S (T T_DOT) :: r838 in
+  let r840 = [R 224] in
+  let r841 = S (T T_RBRACKET) :: r840 in
+  let r842 = Sub (r15) :: r841 in
+  let r843 = [R 503] in
+  let r844 = [R 504] in
+  let r845 = [R 743] in
+  let r846 = R 284 :: r845 in
+  let r847 = Sub (r746) :: r846 in
+  let r848 = Sub (r349) :: r847 in
+  let r849 = R 278 :: r848 in
+  let r850 = [R 375] in
+  let r851 = R 284 :: r850 in
+  let r852 = R 451 :: r851 in
+  let r853 = Sub (r95) :: r852 in
+  let r854 = R 278 :: r853 in
+  let r855 = R 186 :: r854 in
+  let r856 = [R 452] in
+  let r857 = [R 744] in
+  let r858 = R 274 :: r857 in
+  let r859 = R 284 :: r858 in
+  let r860 = Sub (r746) :: r859 in
+  let r861 = [R 275] in
+  let r862 = R 274 :: r861 in
+  let r863 = R 284 :: r862 in
+  let r864 = Sub (r746) :: r863 in
+  let r865 = Sub (r349) :: r864 in
+  let r866 = [R 192] in
+  let r867 = S (T T_RBRACKET) :: r866 in
+  let r868 = Sub (r15) :: r867 in
+  let r869 = [R 749] in
+  let r870 = R 284 :: r869 in
+  let r871 = S (N N_module_expr) :: r870 in
+  let r872 = R 278 :: r871 in
+  let r873 = [R 388] in
+  let r874 = S (T T_STRING) :: r873 in
+  let r875 = [R 510] in
+  let r876 = R 284 :: r875 in
+  let r877 = Sub (r874) :: r876 in
+  let r878 = S (T T_EQUAL) :: r877 in
+  let r879 = Sub (r73) :: r878 in
+  let r880 = S (T T_COLON) :: r879 in
+  let r881 = Sub (r63) :: r880 in
+  let r882 = R 278 :: r881 in
+  let r883 = [R 727] in
+  let r884 = R 284 :: r883 in
+  let r885 = R 278 :: r884 in
+  let r886 = Sub (r313) :: r885 in
+  let r887 = S (T T_EQUAL) :: r886 in
+  let r888 = Sub (r125) :: r887 in
+  let r889 = R 278 :: r888 in
+  let r890 = [R 583] in
+  let r891 = R 284 :: r890 in
+  let r892 = R 278 :: r891 in
+  let r893 = R 208 :: r892 in
+  let r894 = Sub (r125) :: r893 in
+  let r895 = R 278 :: r894 in
+  let r896 = R 186 :: r895 in
+  let r897 = [R 501] in
+  let r898 = [R 287] in
+  let r899 = [R 406] in
+  let r900 = R 284 :: r899 in
+  let r901 = Sub (r208) :: r900 in
+  let r902 = R 278 :: r901 in
+  let r903 = [R 407] in
+  let r904 = R 284 :: r903 in
+  let r905 = Sub (r208) :: r904 in
+  let r906 = R 278 :: r905 in
+  let r907 = [R 352] in
+  let r908 = S (N N_module_type) :: r907 in
+  let r909 = S (T T_COLON) :: r908 in
+  let r910 = [R 594] in
+  let r911 = R 284 :: r910 in
+  let r912 = Sub (r909) :: r911 in
+  let r913 = Sub (r349) :: r912 in
+  let r914 = R 278 :: r913 in
+  let r915 = [R 376] in
+  let r916 = R 284 :: r915 in
+  let r917 = S (N N_module_type) :: r916 in
+  let r918 = S (T T_COLONEQUAL) :: r917 in
+  let r919 = Sub (r95) :: r918 in
+  let r920 = R 278 :: r919 in
+  let r921 = [R 365] in
+  let r922 = R 284 :: r921 in
+  let r923 = [R 597] in
+  let r924 = R 276 :: r923 in
+  let r925 = R 284 :: r924 in
+  let r926 = S (N N_module_type) :: r925 in
+  let r927 = S (T T_COLON) :: r926 in
+  let r928 = [R 277] in
+  let r929 = R 276 :: r928 in
+  let r930 = R 284 :: r929 in
+  let r931 = S (N N_module_type) :: r930 in
+  let r932 = S (T T_COLON) :: r931 in
+  let r933 = Sub (r349) :: r932 in
+  let r934 = S (T T_UIDENT) :: r26 in
+  let r935 = Sub (r934) :: r54 in
+  let r936 = [R 595] in
+  let r937 = R 284 :: r936 in
+  let r938 = [R 353] in
+  let r939 = [R 601] in
+  let r940 = R 284 :: r939 in
+  let r941 = S (N N_module_type) :: r940 in
+  let r942 = R 278 :: r941 in
+  let r943 = S (T T_QUOTED_STRING_EXPR) :: r41 in
+  let r944 = [R 78] in
+  let r945 = Sub (r943) :: r944 in
+  let r946 = [R 88] in
+  let r947 = Sub (r945) :: r946 in
+  let r948 = [R 602] in
+  let r949 = R 270 :: r948 in
+  let r950 = R 284 :: r949 in
+  let r951 = Sub (r947) :: r950 in
+  let r952 = S (T T_COLON) :: r951 in
+  let r953 = S (T T_LIDENT) :: r952 in
+  let r954 = R 193 :: r953 in
+  let r955 = R 801 :: r954 in
+  let r956 = R 278 :: r955 in
+  let r957 = [R 92] in
+  let r958 = R 272 :: r957 in
+  let r959 = R 284 :: r958 in
+  let r960 = Sub (r945) :: r959 in
+  let r961 = S (T T_EQUAL) :: r960 in
+  let r962 = S (T T_LIDENT) :: r961 in
+  let r963 = R 193 :: r962 in
+  let r964 = R 801 :: r963 in
+  let r965 = R 278 :: r964 in
+  let r966 = [R 194] in
+  let r967 = S (T T_RBRACKET) :: r966 in
+  let r968 = [R 79] in
+  let r969 = S (T T_END) :: r968 in
+  let r970 = R 293 :: r969 in
+  let r971 = R 69 :: r970 in
+  let r972 = [R 68] in
+  let r973 = S (T T_RPAREN) :: r972 in
+  let r974 = [R 71] in
+  let r975 = R 284 :: r974 in
+  let r976 = Sub (r73) :: r975 in
+  let r977 = S (T T_COLON) :: r976 in
+  let r978 = S (T T_LIDENT) :: r977 in
+  let r979 = R 380 :: r978 in
+  let r980 = [R 72] in
+  let r981 = R 284 :: r980 in
+  let r982 = Sub (r818) :: r981 in
+  let r983 = S (T T_COLON) :: r982 in
+  let r984 = S (T T_LIDENT) :: r983 in
+  let r985 = R 513 :: r984 in
+  let r986 = [R 70] in
+  let r987 = R 284 :: r986 in
+  let r988 = Sub (r945) :: r987 in
+  let r989 = [R 81] in
+  let r990 = Sub (r945) :: r989 in
+  let r991 = S (T T_IN) :: r990 in
+  let r992 = Sub (r935) :: r991 in
+  let r993 = R 278 :: r992 in
+  let r994 = [R 82] in
+  let r995 = Sub (r945) :: r994 in
+  let r996 = S (T T_IN) :: r995 in
+  let r997 = Sub (r935) :: r996 in
+  let r998 = [R 553] in
+  let r999 = Sub (r73) :: r998 in
+  let r1000 = [R 77] in
+  let r1001 = Sub (r199) :: r1000 in
+  let r1002 = S (T T_RBRACKET) :: r1001 in
+  let r1003 = Sub (r999) :: r1002 in
+  let r1004 = [R 554] in
+  let r1005 = [R 109] in
+  let r1006 = Sub (r73) :: r1005 in
+  let r1007 = S (T T_EQUAL) :: r1006 in
+  let r1008 = Sub (r73) :: r1007 in
+  let r1009 = [R 73] in
+  let r1010 = R 284 :: r1009 in
+  let r1011 = Sub (r1008) :: r1010 in
+  let r1012 = [R 74] in
+  let r1013 = [R 294] in
+  let r1014 = [R 273] in
+  let r1015 = R 272 :: r1014 in
+  let r1016 = R 284 :: r1015 in
+  let r1017 = Sub (r945) :: r1016 in
+  let r1018 = S (T T_EQUAL) :: r1017 in
+  let r1019 = S (T T_LIDENT) :: r1018 in
+  let r1020 = R 193 :: r1019 in
+  let r1021 = R 801 :: r1020 in
+  let r1022 = [R 90] in
+  let r1023 = Sub (r947) :: r1022 in
+  let r1024 = S (T T_MINUSGREATER) :: r1023 in
+  let r1025 = Sub (r67) :: r1024 in
+  let r1026 = [R 91] in
+  let r1027 = Sub (r947) :: r1026 in
+  let r1028 = [R 89] in
+  let r1029 = Sub (r947) :: r1028 in
+  let r1030 = S (T T_MINUSGREATER) :: r1029 in
+  let r1031 = [R 271] in
+  let r1032 = R 270 :: r1031 in
+  let r1033 = R 284 :: r1032 in
+  let r1034 = Sub (r947) :: r1033 in
+  let r1035 = S (T T_COLON) :: r1034 in
+  let r1036 = S (T T_LIDENT) :: r1035 in
+  let r1037 = R 193 :: r1036 in
+  let r1038 = R 801 :: r1037 in
+  let r1039 = [R 288] in
+  let r1040 = [R 585] in
+  let r1041 = [R 589] in
+  let r1042 = [R 281] in
+  let r1043 = R 280 :: r1042 in
+  let r1044 = R 284 :: r1043 in
+  let r1045 = R 534 :: r1044 in
+  let r1046 = R 770 :: r1045 in
+  let r1047 = S (T T_LIDENT) :: r1046 in
+  let r1048 = R 774 :: r1047 in
+  let r1049 = [R 590] in
+  let r1050 = [R 283] in
+  let r1051 = R 282 :: r1050 in
+  let r1052 = R 284 :: r1051 in
+  let r1053 = R 534 :: r1052 in
+  let r1054 = Sub (r164) :: r1053 in
+  let r1055 = S (T T_COLONEQUAL) :: r1054 in
+  let r1056 = S (T T_LIDENT) :: r1055 in
+  let r1057 = R 774 :: r1056 in
+  let r1058 = [R 50] in
+  let r1059 = Sub (r943) :: r1058 in
+  let r1060 = [R 59] in
+  let r1061 = Sub (r1059) :: r1060 in
+  let r1062 = S (T T_EQUAL) :: r1061 in
+  let r1063 = [R 747] in
+  let r1064 = R 268 :: r1063 in
+  let r1065 = R 284 :: r1064 in
+  let r1066 = Sub (r1062) :: r1065 in
+  let r1067 = S (T T_LIDENT) :: r1066 in
+  let r1068 = R 193 :: r1067 in
+  let r1069 = R 801 :: r1068 in
+  let r1070 = R 278 :: r1069 in
+  let r1071 = [R 87] in
+  let r1072 = S (T T_END) :: r1071 in
+  let r1073 = R 295 :: r1072 in
+  let r1074 = R 67 :: r1073 in
+  let r1075 = [R 56] in
+  let r1076 = R 284 :: r1075 in
+  let r1077 = Sub (r1) :: r1076 in
+  let r1078 = [R 51] in
+  let r1079 = R 284 :: r1078 in
+  let r1080 = R 445 :: r1079 in
+  let r1081 = Sub (r1059) :: r1080 in
+  let r1082 = [R 52] in
+  let r1083 = R 284 :: r1082 in
+  let r1084 = R 445 :: r1083 in
+  let r1085 = Sub (r1059) :: r1084 in
+  let r1086 = [R 83] in
+  let r1087 = S (T T_RPAREN) :: r1086 in
+  let r1088 = [R 46] in
+  let r1089 = Sub (r1059) :: r1088 in
+  let r1090 = S (T T_IN) :: r1089 in
+  let r1091 = Sub (r935) :: r1090 in
+  let r1092 = R 278 :: r1091 in
+  let r1093 = [R 258] in
+  let r1094 = R 284 :: r1093 in
+  let r1095 = Sub (r377) :: r1094 in
+  let r1096 = R 518 :: r1095 in
+  let r1097 = R 278 :: r1096 in
+  let r1098 = [R 47] in
+  let r1099 = Sub (r1059) :: r1098 in
+  let r1100 = S (T T_IN) :: r1099 in
+  let r1101 = Sub (r935) :: r1100 in
+  let r1102 = [R 85] in
+  let r1103 = Sub (r47) :: r1102 in
+  let r1104 = S (T T_RBRACKET) :: r1103 in
+  let r1105 = [R 62] in
+  let r1106 = Sub (r1059) :: r1105 in
+  let r1107 = S (T T_MINUSGREATER) :: r1106 in
+  let r1108 = Sub (r569) :: r1107 in
+  let r1109 = [R 44] in
+  let r1110 = Sub (r1108) :: r1109 in
+  let r1111 = [R 45] in
+  let r1112 = Sub (r1059) :: r1111 in
+  let r1113 = [R 257] in
+  let r1114 = R 284 :: r1113 in
+  let r1115 = Sub (r377) :: r1114 in
+  let r1116 = [R 86] in
+  let r1117 = S (T T_RPAREN) :: r1116 in
+  let r1118 = [R 446] in
+  let r1119 = [R 55] in
+  let r1120 = R 284 :: r1119 in
+  let r1121 = Sub (r1008) :: r1120 in
+  let r1122 = [R 57] in
+  let r1123 = [R 296] in
+  let r1124 = [R 60] in
+  let r1125 = Sub (r1059) :: r1124 in
+  let r1126 = S (T T_EQUAL) :: r1125 in
+  let r1127 = [R 61] in
+  let r1128 = [R 269] in
+  let r1129 = R 268 :: r1128 in
+  let r1130 = R 284 :: r1129 in
+  let r1131 = Sub (r1062) :: r1130 in
+  let r1132 = S (T T_LIDENT) :: r1131 in
+  let r1133 = R 193 :: r1132 in
+  let r1134 = R 801 :: r1133 in
+  let r1135 = [R 292] in
+  let r1136 = [R 735] in
+  let r1137 = [R 739] in
+  let r1138 = [R 732] in
+  let r1139 = R 289 :: r1138 in
+  let r1140 = [R 291] in
+  let r1141 = R 289 :: r1140 in
+  let r1142 = [R 214] in
+  let r1143 = R 284 :: r1142 in
+  let r1144 = R 534 :: r1143 in
+  let r1145 = [R 629] in
+  let r1146 = S (T T_RPAREN) :: r1145 in
+  let r1147 = S (N N_module_expr) :: r1146 in
+  let r1148 = R 278 :: r1147 in
+  let r1149 = [R 630] in
+  let r1150 = S (T T_RPAREN) :: r1149 in
+  let r1151 = [R 616] in
+  let r1152 = [R 122] in
+  let r1153 = [R 124] in
+  let r1154 = [R 123] in
+  let r1155 = [R 220] in
+  let r1156 = [R 223] in
+  let r1157 = [R 333] in
+  let r1158 = [R 336] in
+  let r1159 = S (T T_RPAREN) :: r1158 in
+  let r1160 = S (T T_COLONCOLON) :: r1159 in
+  let r1161 = S (T T_LPAREN) :: r1160 in
+  let r1162 = [R 467] in
+  let r1163 = [R 468] in
+  let r1164 = [R 469] in
+  let r1165 = [R 470] in
+  let r1166 = [R 471] in
+  let r1167 = [R 472] in
+  let r1168 = [R 473] in
+  let r1169 = [R 474] in
+  let r1170 = [R 475] in
+  let r1171 = [R 754] in
+  let r1172 = [R 763] in
+  let r1173 = [R 298] in
+  let r1174 = [R 761] in
+  let r1175 = S (T T_SEMISEMI) :: r1174 in
+  let r1176 = [R 762] in
+  let r1177 = [R 300] in
+  let r1178 = [R 303] in
+  let r1179 = [R 302] in
+  let r1180 = [R 301] in
+  let r1181 = R 299 :: r1180 in
+  let r1182 = [R 790] in
+  let r1183 = S (T T_EOF) :: r1182 in
+  let r1184 = R 299 :: r1183 in
+  let r1185 = [R 789] in
+  function
+  | 0 | 1750 | 1754 | 1772 | 1776 | 1780 | 1784 | 1788 | 1792 | 1796 | 1800 | 1806 | 1826 -> Nothing
+  | 1749 -> One ([R 0])
+  | 1753 -> One ([R 1])
+  | 1759 -> One ([R 2])
+  | 1773 -> One ([R 3])
+  | 1777 -> One ([R 4])
+  | 1783 -> One ([R 5])
+  | 1785 -> One ([R 6])
+  | 1789 -> One ([R 7])
+  | 1793 -> One ([R 8])
+  | 1799 -> One ([R 9])
+  | 1803 -> One ([R 10])
+  | 1816 -> One ([R 11])
+  | 1836 -> One ([R 12])
+  | 444 -> One ([R 13])
+  | 443 -> One ([R 14])
+  | 1767 -> One ([R 18])
+  | 1769 -> One ([R 19])
+  | 220 -> One ([R 24])
+  | 230 -> One ([R 25])
+  | 226 -> One ([R 39])
+  | 1580 -> One ([R 43])
+  | 1584 -> One ([R 48])
+  | 1581 -> One ([R 49])
+  | 1620 -> One ([R 58])
+  | 1587 -> One ([R 63])
+  | 1451 -> One ([R 75])
+  | 1431 -> One ([R 76])
+  | 1433 -> One ([R 80])
+  | 1582 -> One ([R 84])
+  | 513 -> One ([R 95])
+  | 73 -> One ([R 96])
+  | 512 -> One ([R 97])
+  | 72 -> One ([R 101])
+  | 187 | 330 -> One ([R 102])
+  | 410 -> One ([R 105])
+  | 329 -> One ([R 113])
+  | 351 -> One ([R 114])
+  | 260 -> One ([R 116])
+  | 1022 -> One ([R 117])
+  | 774 -> One ([R 128])
+  | 962 -> One ([R 145])
+  | 787 -> One ([R 146])
+  | 809 -> One ([R 147])
+  | 790 -> One ([R 148])
+  | 807 -> One ([R 185])
+  | 1 -> One (R 186 :: r7)
+  | 61 -> One (R 186 :: r24)
+  | 66 -> One (R 186 :: r29)
+  | 69 -> One (R 186 :: r40)
+  | 76 -> One (R 186 :: r50)
+  | 96 -> One (R 186 :: r79)
+  | 445 -> One (R 186 :: r328)
+  | 446 -> One (R 186 :: r332)
+  | 452 -> One (R 186 :: r340)
+  | 465 -> One (R 186 :: r353)
+  | 482 -> One (R 186 :: r369)
+  | 485 -> One (R 186 :: r374)
+  | 490 -> One (R 186 :: r382)
+  | 506 -> One (R 186 :: r403)
+  | 528 -> One (R 186 :: r416)
+  | 620 -> One (R 186 :: r485)
+  | 707 -> One (R 186 :: r552)
+  | 710 -> One (R 186 :: r555)
+  | 713 -> One (R 186 :: r560)
+  | 716 -> One (R 186 :: r563)
+  | 722 -> One (R 186 :: r576)
+  | 730 -> One (R 186 :: r587)
+  | 735 -> One (R 186 :: r599)
+  | 751 -> One (R 186 :: r610)
+  | 765 -> One (R 186 :: r616)
+  | 1099 -> One (R 186 :: r752)
+  | 1114 -> One (R 186 :: r763)
+  | 1263 -> One (R 186 :: r849)
+  | 1290 -> One (R 186 :: r872)
+  | 1295 -> One (R 186 :: r882)
+  | 1319 -> One (R 186 :: r902)
+  | 1320 -> One (R 186 :: r906)
+  | 1329 -> One (R 186 :: r914)
+  | 1366 -> One (R 186 :: r942)
+  | 1375 -> One (R 186 :: r956)
+  | 1376 -> One (R 186 :: r965)
+  | 1539 -> One (R 186 :: r1070)
+  | 1714 -> One (R 186 :: r1148)
+  | 632 -> One ([R 207])
+  | 146 -> One ([R 218])
+  | 125 -> One (R 221 :: r90)
+  | 129 -> One (R 221 :: r92)
+  | 442 -> One ([R 225])
+  | 324 -> One ([R 229])
+  | 325 -> One ([R 230])
+  | 961 -> One ([R 234])
+  | 880 -> One ([R 247])
+  | 1155 -> One ([R 249])
+  | 883 -> One ([R 256])
+  | 1585 -> One ([R 259])
+  | 603 -> One ([R 260])
+  | 1135 -> One ([R 262])
+  | 87 -> One (R 278 :: r55)
+  | 158 -> One (R 278 :: r109)
+  | 284 -> One (R 278 :: r239)
+  | 450 -> One (R 278 :: r335)
+  | 478 -> One (R 278 :: r364)
+  | 623 -> One (R 278 :: r489)
+  | 630 -> One (R 278 :: r499)
+  | 857 -> One (R 278 :: r663)
+  | 1186 -> One (R 278 :: r798)
+  | 1214 -> One (R 278 :: r816)
+  | 1278 -> One (R 278 :: r865)
+  | 1348 -> One (R 278 :: r933)
+  | 1387 -> One (R 278 :: r971)
+  | 1393 -> One (R 278 :: r979)
+  | 1404 -> One (R 278 :: r985)
+  | 1415 -> One (R 278 :: r988)
+  | 1419 -> One (R 278 :: r997)
+  | 1440 -> One (R 278 :: r1011)
+  | 1456 -> One (R 278 :: r1021)
+  | 1491 -> One (R 278 :: r1038)
+  | 1513 -> One (R 278 :: r1048)
+  | 1523 -> One (R 278 :: r1057)
+  | 1546 -> One (R 278 :: r1074)
+  | 1549 -> One (R 278 :: r1077)
+  | 1553 -> One (R 278 :: r1081)
+  | 1554 -> One (R 278 :: r1085)
+  | 1565 -> One (R 278 :: r1101)
+  | 1573 -> One (R 278 :: r1110)
+  | 1612 -> One (R 278 :: r1121)
+  | 1632 -> One (R 278 :: r1134)
+  | 1512 -> One (R 280 :: r1041)
+  | 1654 -> One (R 280 :: r1137)
+  | 1522 -> One (R 282 :: r1049)
+  | 397 -> One (R 284 :: r311)
+  | 1449 -> One (R 284 :: r1012)
+  | 1510 -> One (R 284 :: r1040)
+  | 1618 -> One (R 284 :: r1122)
+  | 1652 -> One (R 284 :: r1136)
+  | 1659 -> One (R 284 :: r1139)
+  | 1679 -> One (R 284 :: r1141)
+  | 1821 -> One (R 284 :: r1175)
+  | 1832 -> One (R 284 :: r1181)
+  | 1837 -> One (R 284 :: r1184)
+  | 1318 -> One (R 286 :: r898)
+  | 1502 -> One (R 286 :: r1039)
+  | 441 -> One (R 289 :: r324)
+  | 1642 -> One (R 289 :: r1135)
+  | 1452 -> One (R 293 :: r1013)
+  | 1621 -> One (R 295 :: r1123)
+  | 1819 -> One (R 297 :: r1173)
+  | 1827 -> One (R 299 :: r1177)
+  | 1828 -> One (R 299 :: r1178)
+  | 1829 -> One (R 299 :: r1179)
+  | 577 -> One ([R 305])
+  | 581 -> One ([R 307])
+  | 798 -> One ([R 309])
+  | 884 -> One ([R 310])
+  | 1060 -> One ([R 313])
+  | 287 -> One ([R 314])
+  | 290 -> One ([R 315])
+  | 289 -> One ([R 317])
+  | 288 -> One ([R 319])
+  | 286 -> One ([R 320])
+  | 1768 -> One ([R 332])
+  | 1758 -> One ([R 334])
+  | 1766 -> One ([R 335])
+  | 1765 -> One ([R 337])
+  | 742 -> One ([R 344])
+  | 1020 -> One ([R 345])
+  | 683 -> One ([R 356])
+  | 693 -> One ([R 357])
+  | 694 -> One ([R 358])
+  | 692 -> One ([R 359])
+  | 695 -> One ([R 361])
+  | 449 -> One ([R 362])
+  | 469 | 1339 -> One ([R 363])
+  | 654 -> One ([R 370])
+  | 636 -> One ([R 371])
+  | 661 -> One ([R 374])
+  | 314 | 1200 -> One ([R 379])
+  | 1397 -> One ([R 381])
+  | 1395 -> One ([R 382])
+  | 1398 -> One ([R 383])
+  | 1396 -> One ([R 384])
+  | 546 -> One ([R 387])
+  | 1303 -> One ([R 389])
+  | 366 -> One ([R 390])
+  | 356 -> One ([R 391])
+  | 379 -> One ([R 392])
+  | 357 -> One ([R 393])
+  | 378 -> One ([R 394])
+  | 373 -> One ([R 395])
+  | 92 | 100 -> One ([R 408])
+  | 108 | 760 -> One ([R 409])
+  | 136 -> One ([R 410])
+  | 124 -> One ([R 412])
+  | 128 -> One ([R 414])
+  | 132 -> One ([R 416])
+  | 115 -> One ([R 417])
+  | 135 | 984 -> One ([R 418])
+  | 114 -> One ([R 419])
+  | 113 -> One ([R 420])
+  | 112 -> One ([R 421])
+  | 111 -> One ([R 422])
+  | 110 -> One ([R 423])
+  | 103 | 464 | 750 -> One ([R 424])
+  | 102 | 749 -> One ([R 425])
+  | 101 -> One ([R 426])
+  | 107 | 551 | 759 -> One ([R 427])
+  | 106 | 758 -> One ([R 428])
+  | 90 -> One ([R 429])
+  | 104 -> One ([R 430])
+  | 117 -> One ([R 431])
+  | 109 -> One ([R 432])
+  | 116 -> One ([R 433])
+  | 105 -> One ([R 434])
+  | 134 -> One ([R 435])
+  | 137 -> One ([R 436])
+  | 133 -> One ([R 438])
+  | 247 -> One ([R 439])
+  | 246 -> One (R 440 :: r225)
+  | 198 -> One (R 441 :: r186)
+  | 199 -> One ([R 442])
+  | 578 -> One (R 443 :: r432)
+  | 579 -> One ([R 444])
+  | 1009 -> One ([R 458])
+  | 152 -> One ([R 459])
+  | 538 -> One ([R 477])
+  | 532 -> One ([R 478])
+  | 533 -> One ([R 480])
+  | 531 | 761 -> One ([R 487])
+  | 875 -> One ([R 493])
+  | 876 -> One ([R 494])
+  | 877 -> One ([R 496])
+  | 609 -> One ([R 498])
+  | 1538 -> One ([R 502])
+  | 402 | 1238 -> One ([R 512])
+  | 1408 -> One ([R 514])
+  | 1406 -> One ([R 515])
+  | 1409 -> One ([R 516])
+  | 1407 -> One ([R 517])
+  | 1594 -> One (R 518 :: r1115)
+  | 493 -> One ([R 519])
+  | 354 -> One ([R 522])
+  | 355 -> One ([R 523])
+  | 353 -> One ([R 524])
+  | 424 -> One ([R 526])
+  | 423 -> One ([R 527])
+  | 425 -> One ([R 528])
+  | 420 -> One ([R 529])
+  | 421 -> One ([R 530])
+  | 1693 -> One ([R 532])
+  | 1691 -> One ([R 533])
+  | 676 -> One ([R 536])
+  | 633 -> One ([R 537])
+  | 964 -> One ([R 538])
+  | 963 -> One ([R 539])
+  | 275 -> One ([R 541])
+  | 239 -> One ([R 565])
+  | 898 -> One ([R 568])
+  | 899 -> One ([R 569])
+  | 1083 -> One ([R 571])
+  | 1084 -> One ([R 572])
+  | 572 -> One ([R 574])
+  | 573 -> One ([R 575])
+  | 1012 -> One ([R 577])
+  | 1013 -> One ([R 578])
+  | 812 -> One ([R 580])
+  | 816 -> One ([R 581])
+  | 1533 -> One ([R 586])
+  | 1501 -> One ([R 587])
+  | 1504 -> One ([R 588])
+  | 1503 -> One ([R 593])
+  | 1508 -> One ([R 596])
+  | 1507 -> One ([R 598])
+  | 1506 -> One ([R 599])
+  | 1505 -> One ([R 600])
+  | 1534 -> One ([R 603])
+  | 462 -> One ([R 606])
+  | 459 -> One ([R 608])
+  | 741 -> One ([R 631])
+  | 794 -> One ([R 632])
+  | 793 | 808 -> One ([R 633])
+  | 744 | 789 -> One ([R 634])
+  | 906 | 958 -> One ([R 639])
+  | 792 -> One ([R 644])
+  | 514 -> One ([R 657])
+  | 518 -> One ([R 660])
+  | 519 -> One ([R 664])
+  | 550 -> One ([R 666])
+  | 523 -> One ([R 667])
+  | 574 -> One ([R 669])
+  | 541 -> One ([R 674])
+  | 28 -> One ([R 675])
+  | 8 -> One ([R 676])
+  | 52 -> One ([R 678])
+  | 51 -> One ([R 679])
+  | 50 -> One ([R 680])
+  | 49 -> One ([R 681])
+  | 48 -> One ([R 682])
+  | 47 -> One ([R 683])
+  | 46 -> One ([R 684])
+  | 45 -> One ([R 685])
+  | 44 -> One ([R 686])
+  | 43 -> One ([R 687])
+  | 42 -> One ([R 688])
+  | 41 -> One ([R 689])
+  | 40 -> One ([R 690])
+  | 39 -> One ([R 691])
+  | 38 -> One ([R 692])
+  | 37 -> One ([R 693])
+  | 36 -> One ([R 694])
+  | 35 -> One ([R 695])
+  | 34 -> One ([R 696])
+  | 33 -> One ([R 697])
+  | 32 -> One ([R 698])
+  | 31 -> One ([R 699])
+  | 30 -> One ([R 700])
+  | 29 -> One ([R 701])
+  | 27 -> One ([R 702])
+  | 26 -> One ([R 703])
+  | 25 -> One ([R 704])
+  | 24 -> One ([R 705])
+  | 23 -> One ([R 706])
+  | 22 -> One ([R 707])
+  | 21 -> One ([R 708])
+  | 20 -> One ([R 709])
+  | 19 -> One ([R 710])
+  | 18 -> One ([R 711])
+  | 17 -> One ([R 712])
+  | 16 -> One ([R 713])
+  | 15 -> One ([R 714])
+  | 14 -> One ([R 715])
+  | 13 -> One ([R 716])
+  | 12 -> One ([R 717])
+  | 11 -> One ([R 718])
+  | 10 -> One ([R 719])
+  | 9 -> One ([R 720])
+  | 7 -> One ([R 721])
+  | 6 -> One ([R 722])
+  | 5 -> One ([R 723])
+  | 4 -> One ([R 724])
+  | 3 -> One ([R 725])
+  | 1645 -> One ([R 726])
+  | 1665 -> One ([R 731])
+  | 1649 | 1664 -> One ([R 733])
+  | 1651 | 1666 -> One ([R 734])
+  | 1656 -> One ([R 736])
+  | 1646 -> One ([R 737])
+  | 1641 -> One ([R 738])
+  | 1644 -> One ([R 742])
+  | 1648 -> One ([R 745])
+  | 1647 -> One ([R 746])
+  | 1657 -> One ([R 748])
+  | 481 -> One ([R 750])
+  | 480 -> One ([R 751])
+  | 1810 -> One ([R 755])
+  | 1811 -> One ([R 756])
+  | 1813 -> One ([R 757])
+  | 1814 -> One ([R 758])
+  | 1812 -> One ([R 759])
+  | 1809 -> One ([R 760])
+  | 1815 -> One ([R 764])
+  | 223 -> One ([R 766])
+  | 639 -> One (R 774 :: r516)
+  | 430 -> One ([R 775])
+  | 164 -> One ([R 780])
+  | 167 -> One ([R 781])
+  | 171 -> One ([R 782])
+  | 165 -> One ([R 783])
+  | 172 -> One ([R 784])
+  | 168 -> One ([R 785])
+  | 173 -> One ([R 786])
+  | 170 -> One ([R 787])
+  | 163 -> One ([R 788])
+  | 515 -> One ([R 793])
+  | 791 -> One ([R 794])
+  | 1379 -> One ([R 802])
+  | 1198 -> One ([R 803])
+  | 1201 -> One ([R 804])
+  | 1199 -> One ([R 805])
+  | 1236 -> One ([R 806])
+  | 1239 -> One ([R 807])
+  | 1237 -> One ([R 808])
+  | 642 -> One ([R 815])
+  | 643 -> One ([R 816])
+  | 999 -> One (S (T T_WITH) :: r721)
+  | 473 -> One (S (T T_TYPE) :: r359)
+  | 611 -> One (S (T T_TYPE) :: r467)
+  | 338 -> One (S (T T_STAR) :: r273)
+  | 1817 -> One (S (T T_SEMISEMI) :: r1172)
+  | 1824 -> One (S (T T_SEMISEMI) :: r1176)
+  | 1755 -> One (S (T T_RPAREN) :: r58)
+  | 300 -> One (S (T T_RPAREN) :: r242)
+  | 307 -> One (S (T T_RPAREN) :: r245)
+  | 526 -> One (S (T T_RPAREN) :: r413)
+  | 565 -> One (S (T T_RPAREN) :: r431)
+  | 625 -> One (S (T T_RPAREN) :: r490)
+  | 685 -> One (S (T T_RPAREN) :: r527)
+  | 985 -> One (S (T T_RPAREN) :: r710)
+  | 1724 -> One (S (T T_RPAREN) :: r1151)
+  | 1756 -> One (S (T T_RPAREN) :: r1157)
+  | 201 -> One (S (T T_RBRACKET) :: r187)
+  | 311 | 332 -> One (S (T T_RBRACKET) :: r247)
+  | 991 -> One (S (T T_RBRACKET) :: r713)
+  | 993 -> One (S (T T_RBRACKET) :: r714)
+  | 253 -> One (S (T T_QUOTE) :: r228)
+  | 1417 -> One (S (T T_OPEN) :: r993)
+  | 1557 -> One (S (T T_OPEN) :: r1092)
+  | 153 -> One (S (T T_MODULE) :: r104)
+  | 344 -> One (S (T T_MINUSGREATER) :: r276)
+  | 1478 -> One (S (T T_MINUSGREATER) :: r1027)
+  | 118 -> One (S (T T_LPAREN) :: r87)
+  | 149 -> One (S (T T_LIDENT) :: r99)
+  | 315 -> One (S (T T_LIDENT) :: r263)
+  | 586 -> One (S (T T_LIDENT) :: r434)
+  | 594 -> One (S (T T_LIDENT) :: r440)
+  | 775 -> One (S (T T_LIDENT) :: r623)
+  | 777 -> One (S (T T_LIDENT) :: r624)
+  | 781 -> One (S (T T_LIDENT) :: r626)
+  | 1202 -> One (S (T T_LIDENT) :: r803)
+  | 1240 -> One (S (T T_LIDENT) :: r831)
+  | 1604 -> One (S (T T_LIDENT) :: r1118)
+  | 457 -> One (S (T T_INT) :: r344)
+  | 460 -> One (S (T T_INT) :: r345)
+  | 795 -> One (S (T T_IN) :: r633)
+  | 799 -> One (S (T T_IN) :: r635)
+  | 1577 -> One (S (T T_IN) :: r1112)
+  | 700 -> One (S (T T_GREATERRBRACE) :: r535)
+  | 1086 -> One (S (T T_GREATERRBRACE) :: r742)
+  | 193 -> One (S (T T_GREATER) :: r173)
+  | 293 -> One (S (T T_GREATER) :: r240)
+  | 666 -> One (S (T T_EQUAL) :: r524)
+  | 864 -> One (S (T T_EQUAL) :: r668)
+  | 975 -> One (S (T T_EQUAL) :: r708)
+  | 1128 -> One (S (T T_EQUAL) :: r765)
+  | 1152 -> One (S (T T_EQUAL) :: r777)
+  | 1192 -> One (S (T T_EQUAL) :: r800)
+  | 1210 -> One (S (T T_EQUAL) :: r805)
+  | 1747 -> One (S (T T_EOF) :: r1155)
+  | 1751 -> One (S (T T_EOF) :: r1156)
+  | 1770 -> One (S (T T_EOF) :: r1162)
+  | 1774 -> One (S (T T_EOF) :: r1163)
+  | 1778 -> One (S (T T_EOF) :: r1164)
+  | 1781 -> One (S (T T_EOF) :: r1165)
+  | 1786 -> One (S (T T_EOF) :: r1166)
+  | 1790 -> One (S (T T_EOF) :: r1167)
+  | 1794 -> One (S (T T_EOF) :: r1168)
+  | 1797 -> One (S (T T_EOF) :: r1169)
+  | 1801 -> One (S (T T_EOF) :: r1170)
+  | 1841 -> One (S (T T_EOF) :: r1185)
+  | 1073 -> One (S (T T_END) :: r741)
+  | 120 -> One (S (T T_DOTDOT) :: r88)
+  | 188 -> One (S (T T_DOTDOT) :: r166)
+  | 367 -> One (S (T T_DOTDOT) :: r280)
+  | 368 -> One (S (T T_DOTDOT) :: r281)
+  | 80 | 892 | 941 -> One (S (T T_DOT) :: r52)
+  | 277 -> One (S (T T_DOT) :: r237)
+  | 1804 -> One (S (T T_DOT) :: r318)
+  | 1147 -> One (S (T T_DOT) :: r775)
+  | 1225 -> One (S (T T_DOT) :: r828)
+  | 1760 -> One (S (T T_DOT) :: r1161)
+  | 189 | 331 -> One (S (T T_COLONCOLON) :: r168)
+  | 194 -> One (S (T T_COLON) :: r178)
+  | 627 -> One (S (T T_COLON) :: r493)
+  | 1472 -> One (S (T T_COLON) :: r1025)
+  | 495 -> One (S (T T_BARRBRACKET) :: r383)
+  | 583 -> One (S (T T_BARRBRACKET) :: r433)
+  | 698 -> One (S (T T_BARRBRACKET) :: r530)
+  | 987 -> One (S (T T_BARRBRACKET) :: r711)
+  | 989 -> One (S (T T_BARRBRACKET) :: r712)
+  | 1091 -> One (S (T T_BARRBRACKET) :: r743)
+  | 264 -> One (S (T T_BAR) :: r231)
+  | 455 -> One (S (N N_pattern) :: r342)
+  | 543 | 725 | 1041 -> One (S (N N_pattern) :: r347)
+  | 505 -> One (S (N N_pattern) :: r397)
+  | 534 -> One (S (N N_pattern) :: r417)
+  | 536 -> One (S (N N_pattern) :: r418)
+  | 554 -> One (S (N N_pattern) :: r426)
+  | 559 -> One (S (N N_pattern) :: r429)
+  | 867 -> One (S (N N_pattern) :: r669)
+  | 869 -> One (S (N N_pattern) :: r670)
+  | 871 -> One (S (N N_pattern) :: r671)
+  | 878 -> One (S (N N_pattern) :: r673)
+  | 1259 -> One (S (N N_pattern) :: r843)
+  | 472 -> One (S (N N_module_type) :: r355)
+  | 629 -> One (S (N N_module_type) :: r495)
+  | 662 -> One (S (N N_module_type) :: r521)
+  | 664 -> One (S (N N_module_type) :: r522)
+  | 689 -> One (S (N N_module_type) :: r529)
+  | 1105 -> One (S (N N_module_type) :: r755)
+  | 1167 -> One (S (N N_module_type) :: r779)
+  | 1170 -> One (S (N N_module_type) :: r781)
+  | 1173 -> One (S (N N_module_type) :: r783)
+  | 1268 -> One (S (N N_module_type) :: r856)
+  | 1719 -> One (S (N N_module_type) :: r1150)
+  | 477 -> One (S (N N_module_expr) :: r361)
+  | 602 -> One (S (N N_let_pattern) :: r457)
+  | 489 -> One (S (N N_expr) :: r375)
+  | 702 -> One (S (N N_expr) :: r538)
+  | 706 -> One (S (N N_expr) :: r549)
+  | 773 -> One (S (N N_expr) :: r622)
+  | 788 -> One (S (N N_expr) :: r631)
+  | 803 -> One (S (N N_expr) :: r636)
+  | 805 -> One (S (N N_expr) :: r637)
+  | 810 -> One (S (N N_expr) :: r638)
+  | 817 -> One (S (N N_expr) :: r641)
+  | 819 -> One (S (N N_expr) :: r642)
+  | 821 -> One (S (N N_expr) :: r643)
+  | 823 -> One (S (N N_expr) :: r644)
+  | 825 -> One (S (N N_expr) :: r645)
+  | 827 -> One (S (N N_expr) :: r646)
+  | 829 -> One (S (N N_expr) :: r647)
+  | 831 -> One (S (N N_expr) :: r648)
+  | 833 -> One (S (N N_expr) :: r649)
+  | 835 -> One (S (N N_expr) :: r650)
+  | 837 -> One (S (N N_expr) :: r651)
+  | 839 -> One (S (N N_expr) :: r652)
+  | 841 -> One (S (N N_expr) :: r653)
+  | 843 -> One (S (N N_expr) :: r654)
+  | 845 -> One (S (N N_expr) :: r655)
+  | 847 -> One (S (N N_expr) :: r656)
+  | 849 -> One (S (N N_expr) :: r657)
+  | 851 -> One (S (N N_expr) :: r658)
+  | 853 -> One (S (N N_expr) :: r659)
+  | 855 -> One (S (N N_expr) :: r660)
+  | 913 -> One (S (N N_expr) :: r691)
+  | 918 -> One (S (N N_expr) :: r695)
+  | 923 -> One (S (N N_expr) :: r699)
+  | 929 -> One (S (N N_expr) :: r700)
+  | 934 -> One (S (N N_expr) :: r701)
+  | 939 -> One (S (N N_expr) :: r702)
+  | 946 -> One (S (N N_expr) :: r703)
+  | 951 -> One (S (N N_expr) :: r704)
+  | 956 -> One (S (N N_expr) :: r705)
+  | 959 -> One (S (N N_expr) :: r706)
+  | 1070 -> One (S (N N_expr) :: r740)
+  | 597 -> One (Sub (r1) :: r444)
+  | 721 -> One (Sub (r1) :: r567)
+  | 1033 -> One (Sub (r1) :: r731)
+  | 1261 -> One (Sub (r1) :: r844)
+  | 1732 -> One (Sub (r1) :: r1153)
+  | 1734 -> One (Sub (r1) :: r1154)
+  | 2 -> One (Sub (r11) :: r12)
+  | 55 -> One (Sub (r11) :: r13)
+  | 59 -> One (Sub (r11) :: r18)
+  | 94 -> One (Sub (r11) :: r62)
+  | 383 -> One (Sub (r11) :: r291)
+  | 813 -> One (Sub (r11) :: r640)
+  | 1257 -> One (Sub (r11) :: r842)
+  | 1288 -> One (Sub (r11) :: r868)
+  | 1558 -> One (Sub (r11) :: r1097)
+  | 719 -> One (Sub (r33) :: r564)
+  | 1064 -> One (Sub (r33) :: r739)
+  | 1730 -> One (Sub (r35) :: r1152)
+  | 75 -> One (Sub (r42) :: r43)
+  | 705 -> One (Sub (r42) :: r547)
+  | 740 -> One (Sub (r42) :: r600)
+  | 769 -> One (Sub (r42) :: r617)
+  | 779 -> One (Sub (r42) :: r625)
+  | 907 -> One (Sub (r42) :: r690)
+  | 561 -> One (Sub (r63) :: r430)
+  | 873 -> One (Sub (r63) :: r672)
+  | 224 -> One (Sub (r65) :: r214)
+  | 236 -> One (Sub (r65) :: r219)
+  | 343 -> One (Sub (r65) :: r274)
+  | 1045 -> One (Sub (r65) :: r737)
+  | 231 -> One (Sub (r67) :: r218)
+  | 1480 -> One (Sub (r67) :: r1030)
+  | 222 -> One (Sub (r69) :: r213)
+  | 250 -> One (Sub (r71) :: r226)
+  | 646 -> One (Sub (r71) :: r518)
+  | 305 -> One (Sub (r73) :: r244)
+  | 309 -> One (Sub (r73) :: r246)
+  | 393 -> One (Sub (r73) :: r310)
+  | 502 -> One (Sub (r73) :: r396)
+  | 556 -> One (Sub (r73) :: r428)
+  | 589 -> One (Sub (r73) :: r439)
+  | 604 -> One (Sub (r73) :: r458)
+  | 762 -> One (Sub (r73) :: r613)
+  | 860 -> One (Sub (r73) :: r666)
+  | 1003 -> One (Sub (r73) :: r722)
+  | 1007 -> One (Sub (r73) :: r725)
+  | 1181 -> One (Sub (r73) :: r785)
+  | 1389 -> One (Sub (r73) :: r973)
+  | 1427 -> One (Sub (r73) :: r1004)
+  | 176 -> One (Sub (r95) :: r161)
+  | 278 -> One (Sub (r95) :: r238)
+  | 1807 -> One (Sub (r95) :: r1171)
+  | 1317 -> One (Sub (r106) :: r897)
+  | 510 -> One (Sub (r121) :: r405)
+  | 182 -> One (Sub (r156) :: r162)
+  | 169 -> One (Sub (r158) :: r160)
+  | 1381 -> One (Sub (r158) :: r967)
+  | 186 -> One (Sub (r164) :: r165)
+  | 380 -> One (Sub (r164) :: r288)
+  | 1696 -> One (Sub (r164) :: r1144)
+  | 243 -> One (Sub (r181) :: r220)
+  | 203 -> One (Sub (r183) :: r189)
+  | 217 -> One (Sub (r183) :: r212)
+  | 204 -> One (Sub (r195) :: r197)
+  | 205 -> One (Sub (r199) :: r200)
+  | 228 -> One (Sub (r199) :: r215)
+  | 302 -> One (Sub (r199) :: r243)
+  | 207 -> One (Sub (r208) :: r210)
+  | 670 -> One (Sub (r208) :: r525)
+  | 1340 -> One (Sub (r208) :: r922)
+  | 272 -> One (Sub (r233) :: r235)
+  | 313 -> One (Sub (r255) :: r257)
+  | 335 -> One (Sub (r255) :: r271)
+  | 361 -> One (Sub (r255) :: r279)
+  | 369 -> One (Sub (r255) :: r283)
+  | 374 -> One (Sub (r255) :: r285)
+  | 334 -> One (Sub (r268) :: r269)
+  | 406 -> One (Sub (r313) :: r315)
+  | 427 -> One (Sub (r313) :: r323)
+  | 1274 -> One (Sub (r349) :: r860)
+  | 1343 -> One (Sub (r349) :: r927)
+  | 497 -> One (Sub (r393) :: r395)
+  | 615 -> One (Sub (r400) :: r468)
+  | 520 -> One (Sub (r408) :: r409)
+  | 544 -> One (Sub (r422) :: r425)
+  | 726 -> One (Sub (r422) :: r579)
+  | 1042 -> One (Sub (r422) :: r734)
+  | 1141 -> One (Sub (r422) :: r771)
+  | 1219 -> One (Sub (r422) :: r826)
+  | 1247 -> One (Sub (r422) :: r839)
+  | 587 -> One (Sub (r436) :: r438)
+  | 595 -> One (Sub (r436) :: r443)
+  | 981 -> One (Sub (r446) :: r709)
+  | 598 -> One (Sub (r448) :: r451)
+  | 600 -> One (Sub (r453) :: r454)
+  | 1132 -> One (Sub (r463) :: r766)
+  | 674 -> One (Sub (r509) :: r526)
+  | 638 -> One (Sub (r511) :: r512)
+  | 703 -> One (Sub (r544) :: r546)
+  | 998 -> One (Sub (r544) :: r719)
+  | 1050 -> One (Sub (r572) :: r738)
+  | 995 -> One (Sub (r715) :: r717)
+  | 1112 -> One (Sub (r746) :: r756)
+  | 1185 -> One (Sub (r791) :: r793)
+  | 1213 -> One (Sub (r810) :: r812)
+  | 1218 -> One (Sub (r818) :: r821)
+  | 1246 -> One (Sub (r818) :: r834)
+  | 1364 -> One (Sub (r909) :: r938)
+  | 1357 -> One (Sub (r935) :: r937)
+  | 1600 -> One (Sub (r947) :: r1117)
+  | 1624 -> One (Sub (r947) :: r1126)
+  | 1569 -> One (Sub (r999) :: r1104)
+  | 1556 -> One (Sub (r1059) :: r1087)
+  | 1628 -> One (Sub (r1062) :: r1127)
+  | 802 -> One (r0)
+  | 1746 -> One (r2)
+  | 1745 -> One (r3)
+  | 1744 -> One (r4)
+  | 1743 -> One (r5)
+  | 1742 -> One (r6)
+  | 58 -> One (r7)
+  | 53 -> One (r8)
+  | 54 -> One (r10)
+  | 57 -> One (r12)
+  | 56 -> One (r13)
+  | 1658 -> One (r14)
+  | 1741 -> One (r16)
+  | 1740 -> One (r17)
+  | 60 -> One (r18)
+  | 1739 -> One (r19)
+  | 1738 -> One (r20)
+  | 1737 -> One (r21)
+  | 1736 -> One (r22)
+  | 63 -> One (r23)
+  | 62 -> One (r24)
+  | 64 -> One (r25)
+  | 65 -> One (r26)
+  | 1729 -> One (r27)
+  | 68 -> One (r28)
+  | 67 -> One (r29)
+  | 1061 -> One (r30)
+  | 1059 -> One (r31)
+  | 720 -> One (r32)
+  | 1066 -> One (r34)
+  | 1728 -> One (r36)
+  | 1727 -> One (r37)
+  | 1726 -> One (r38)
+  | 71 -> One (r39)
+  | 70 -> One (r40)
+  | 74 -> One (r41)
+  | 1713 -> One (r43)
+  | 79 -> One (r44)
+  | 85 -> One (r46)
+  | 86 -> One (r48)
+  | 78 -> One (r49)
+  | 77 -> One (r50)
+  | 83 -> One (r51)
+  | 81 -> One (r52)
+  | 82 -> One (r53)
+  | 84 -> One (r54)
+  | 88 -> One (r55)
+  | 1723 -> One (r56)
+  | 1722 -> One (r57)
+  | 91 -> One (r58)
+  | 93 | 488 | 704 | 1019 -> One (r59)
+  | 1712 -> One (r60)
+  | 1711 -> One (r61)
+  | 95 -> One (r62)
+  | 143 -> One (r64)
+  | 235 -> One (r66)
+  | 221 -> One (r68)
+  | 251 -> One (r70)
+  | 261 -> One (r72)
+  | 1710 -> One (r74)
+  | 1709 -> One (r75)
+  | 142 -> One (r76)
+  | 141 -> One (r77)
+  | 98 -> One (r78)
+  | 97 -> One (r79)
+  | 138 -> One (r80)
+  | 140 -> One (r82)
+  | 139 -> One (r83)
+  | 99 -> One (r84)
+  | 123 -> One (r85)
+  | 122 -> One (r86)
+  | 119 -> One (r87)
+  | 121 -> One (r88)
+  | 127 -> One (r89)
+  | 126 -> One (r90)
+  | 131 -> One (r91)
+  | 130 -> One (r92)
+  | 144 | 157 -> One (r93)
+  | 147 -> One (r94)
+  | 148 -> One (r96)
+  | 145 -> One (r97)
+  | 151 -> One (r98)
+  | 150 -> One (r99)
+  | 1708 -> One (r100)
+  | 1707 -> One (r101)
+  | 156 -> One (r102)
+  | 155 -> One (r103)
+  | 154 -> One (r104)
+  | 1537 -> One (r105)
+  | 1706 -> One (r107)
+  | 1705 -> One (r108)
+  | 159 -> One (r109)
+  | 435 -> One (r110)
+  | 434 -> One (r111)
+  | 433 -> One (r112)
+  | 192 -> One (r118)
+  | 225 -> One (r120)
+  | 327 -> One (r122)
+  | 350 -> One (r124)
+  | 360 -> One (r126)
+  | 359 -> One (r127)
+  | 358 | 426 -> One (r128)
+  | 1692 -> One (r130)
+  | 1704 -> One (r132)
+  | 1703 -> One (r133)
+  | 1702 -> One (r134)
+  | 1701 -> One (r135)
+  | 1700 -> One (r136)
+  | 399 -> One (r140)
+  | 392 -> One (r141)
+  | 391 -> One (r142)
+  | 1690 -> One (r146)
+  | 1689 -> One (r147)
+  | 1688 -> One (r148)
+  | 1687 -> One (r149)
+  | 1686 -> One (r150)
+  | 175 -> One (r152)
+  | 178 -> One (r154)
+  | 174 -> One (r155)
+  | 179 -> One (r157)
+  | 181 -> One (r159)
+  | 180 -> One (r160)
+  | 177 -> One (r161)
+  | 183 -> One (r162)
+  | 364 -> One (r163)
+  | 365 -> One (r165)
+  | 328 -> One (r166)
+  | 299 -> One (r167)
+  | 298 -> One (r168)
+  | 297 -> One (r169)
+  | 296 -> One (r170)
+  | 295 -> One (r171)
+  | 191 -> One (r172)
+  | 292 -> One (r173)
+  | 291 -> One (r174)
+  | 283 -> One (r176)
+  | 282 -> One (r177)
+  | 195 -> One (r178)
+  | 259 -> One (r180)
+  | 240 -> One (r182)
+  | 271 -> One (r184)
+  | 270 -> One (r185)
+  | 200 -> One (r186)
+  | 202 -> One (r187)
+  | 269 -> One (r188)
+  | 268 -> One (r189)
+  | 219 -> One (r190)
+  | 218 -> One (r191)
+  | 258 -> One (r193)
+  | 245 -> One (r194)
+  | 263 -> One (r196)
+  | 262 -> One (r197)
+  | 215 | 1483 -> One (r198)
+  | 216 -> One (r200)
+  | 211 -> One (r201)
+  | 210 -> One (r202)
+  | 214 -> One (r204)
+  | 212 -> One (r207)
+  | 209 -> One (r209)
+  | 208 -> One (r210)
+  | 242 -> One (r211)
+  | 241 -> One (r212)
+  | 238 -> One (r213)
+  | 227 -> One (r214)
+  | 229 -> One (r215)
+  | 234 -> One (r216)
+  | 233 -> One (r217)
+  | 232 -> One (r218)
+  | 237 -> One (r219)
+  | 244 -> One (r220)
+  | 257 -> One (r221)
+  | 256 -> One (r223)
+  | 249 -> One (r224)
+  | 248 -> One (r225)
+  | 252 -> One (r226)
+  | 255 -> One (r227)
+  | 254 -> One (r228)
+  | 267 -> One (r229)
+  | 266 -> One (r230)
+  | 265 -> One (r231)
+  | 276 -> One (r232)
+  | 274 -> One (r234)
+  | 273 -> One (r235)
+  | 281 -> One (r236)
+  | 280 -> One (r237)
+  | 279 -> One (r238)
+  | 285 -> One (r239)
+  | 294 -> One (r240)
+  | 304 -> One (r241)
+  | 301 -> One (r242)
+  | 303 -> One (r243)
+  | 306 -> One (r244)
+  | 308 -> One (r245)
+  | 310 -> One (r246)
+  | 312 -> One (r247)
+  | 326 -> One (r254)
+  | 323 -> One (r256)
+  | 322 -> One (r257)
+  | 321 -> One (r258)
+  | 320 -> One (r259)
+  | 319 -> One (r260)
+  | 318 -> One (r261)
+  | 317 -> One (r262)
+  | 316 -> One (r263)
+  | 349 -> One (r264)
+  | 348 -> One (r265)
+  | 333 | 405 -> One (r266)
+  | 342 -> One (r267)
+  | 341 -> One (r269)
+  | 337 -> One (r270)
+  | 336 -> One (r271)
+  | 340 -> One (r272)
+  | 339 -> One (r273)
+  | 347 -> One (r274)
+  | 346 -> One (r275)
+  | 345 -> One (r276)
+  | 352 | 404 -> One (r277)
+  | 363 -> One (r278)
+  | 362 -> One (r279)
+  | 377 -> One (r280)
+  | 372 -> One (r281)
+  | 371 -> One (r282)
+  | 370 -> One (r283)
+  | 376 -> One (r284)
+  | 375 -> One (r285)
+  | 1685 -> One (r286)
+  | 382 -> One (r287)
+  | 381 -> One (r288)
+  | 1684 -> One (r289)
+  | 1683 -> One (r290)
+  | 384 -> One (r291)
+  | 422 -> One (r292)
+  | 440 -> One (r294)
+  | 439 -> One (r295)
+  | 438 -> One (r296)
+  | 437 -> One (r297)
+  | 436 -> One (r298)
+  | 419 -> One (r302)
+  | 418 -> One (r303)
+  | 403 -> One (r304)
+  | 401 -> One (r305)
+  | 400 -> One (r306)
+  | 396 -> One (r308)
+  | 395 -> One (r309)
+  | 394 -> One (r310)
+  | 398 -> One (r311)
+  | 417 -> One (r312)
+  | 416 -> One (r314)
+  | 415 -> One (r315)
+  | 409 -> One (r316)
+  | 408 -> One (r317)
+  | 669 | 1805 -> One (r318)
+  | 414 -> One (r319)
+  | 413 -> One (r320)
+  | 412 -> One (r321)
+  | 429 -> One (r322)
+  | 428 -> One (r323)
+  | 1682 -> One (r324)
+  | 1678 -> One (r325)
+  | 1677 -> One (r326)
+  | 1676 -> One (r327)
+  | 1675 -> One (r328)
+  | 1674 -> One (r329)
+  | 1673 -> One (r330)
+  | 448 -> One (r331)
+  | 447 -> One (r332)
+  | 1672 -> One (r333)
+  | 1671 -> One (r334)
+  | 451 -> One (r335)
+  | 1670 -> One (r336)
+  | 1669 -> One (r337)
+  | 1184 -> One (r338)
+  | 454 -> One (r339)
+  | 453 -> One (r340)
+  | 1180 -> One (r341)
+  | 1179 -> One (r342)
+  | 456 -> One (r343)
+  | 458 -> One (r344)
+  | 461 -> One (r345)
+  | 553 -> One (r346)
+  | 552 -> One (r347)
+  | 468 -> One (r348)
+  | 471 -> One (r350)
+  | 470 -> One (r351)
+  | 467 -> One (r352)
+  | 466 -> One (r353)
+  | 1178 -> One (r354)
+  | 1177 -> One (r355)
+  | 1176 -> One (r356)
+  | 476 -> One (r357)
+  | 475 -> One (r358)
+  | 474 -> One (r359)
+  | 688 -> One (r360)
+  | 687 -> One (r361)
+  | 1166 -> One (r362)
+  | 1165 -> One (r363)
+  | 479 -> One (r364)
+  | 1164 -> One (r365)
+  | 1163 -> One (r366)
+  | 1162 -> One (r367)
+  | 484 -> One (r368)
+  | 483 -> One (r369)
+  | 1161 -> One (r370)
+  | 1160 -> One (r371)
+  | 1159 -> One (r372)
+  | 487 -> One (r373)
+  | 486 -> One (r374)
+  | 1158 -> One (r375)
+  | 585 -> One (r376)
+  | 1157 -> One (r378)
+  | 1156 -> One (r379)
+  | 494 -> One (r380)
+  | 492 -> One (r381)
+  | 491 -> One (r382)
+  | 582 -> One (r383)
+  | 571 -> One (r384)
+  | 570 -> One (r386)
+  | 569 -> One (r387)
+  | 498 -> One (r388)
+  | 576 -> One (r390)
+  | 504 -> One (r391)
+  | 501 -> One (r392)
+  | 500 -> One (r394)
+  | 499 -> One (r395)
+  | 503 -> One (r396)
+  | 575 -> One (r397)
+  | 516 | 859 -> One (r399)
+  | 517 -> One (r401)
+  | 508 -> One (r402)
+  | 507 -> One (r403)
+  | 509 -> One (r404)
+  | 511 -> One (r405)
+  | 522 -> One (r407)
+  | 521 -> One (r409)
+  | 568 -> One (r410)
+  | 567 -> One (r411)
+  | 525 -> One (r412)
+  | 527 -> One (r413)
+  | 564 -> One (r414)
+  | 530 -> One (r415)
+  | 529 -> One (r416)
+  | 535 -> One (r417)
+  | 537 -> One (r418)
+  | 540 -> One (r419)
+  | 563 -> One (r420)
+  | 545 -> One (r421)
+  | 549 -> One (r423)
+  | 548 -> One (r424)
+  | 547 -> One (r425)
+  | 555 -> One (r426)
+  | 558 -> One (r427)
+  | 557 -> One (r428)
+  | 560 -> One (r429)
+  | 562 -> One (r430)
+  | 566 -> One (r431)
+  | 580 -> One (r432)
+  | 584 -> One (r433)
+  | 593 -> One (r434)
+  | 588 -> One (r435)
+  | 592 -> One (r437)
+  | 591 -> One (r438)
+  | 590 -> One (r439)
+  | 1139 -> One (r440)
+  | 1138 -> One (r441)
+  | 1137 -> One (r442)
+  | 596 -> One (r443)
+  | 1136 -> One (r444)
+  | 599 -> One (r445)
+  | 983 -> One (r447)
+  | 980 -> One (r449)
+  | 979 -> One (r450)
+  | 978 -> One (r451)
+  | 601 -> One (r452)
+  | 610 -> One (r454)
+  | 608 -> One (r455)
+  | 607 -> One (r456)
+  | 606 -> One (r457)
+  | 605 -> One (r458)
+  | 1127 -> One (r459)
+  | 617 -> One (r460)
+  | 1131 -> One (r462)
+  | 1134 -> One (r464)
+  | 614 -> One (r465)
+  | 613 -> One (r466)
+  | 612 -> One (r467)
+  | 616 -> One (r468)
+  | 1098 -> One (r469)
+  | 1097 -> One (r470)
+  | 1096 -> One (r471)
+  | 1095 -> One (r472)
+  | 1094 -> One (r473)
+  | 619 -> One (r474)
+  | 1126 -> One (r475)
+  | 1125 -> One (r476)
+  | 1124 -> One (r477)
+  | 1123 -> One (r478)
+  | 1122 -> One (r479)
+  | 1643 -> One (r480)
+  | 1093 -> One (r481)
+  | 697 -> One (r482)
+  | 696 -> One (r483)
+  | 622 -> One (r484)
+  | 621 -> One (r485)
+  | 684 -> One (r486)
+  | 682 -> One (r487)
+  | 681 -> One (r488)
+  | 624 -> One (r489)
+  | 626 -> One (r490)
+  | 680 -> One (r491)
+  | 679 -> One (r492)
+  | 628 -> One (r493)
+  | 678 -> One (r494)
+  | 677 -> One (r495)
+  | 637 -> One (r496)
+  | 635 -> One (r497)
+  | 634 -> One (r498)
+  | 631 -> One (r499)
+  | 660 -> One (r500)
+  | 659 -> One (r502)
+  | 653 -> One (r504)
+  | 652 -> One (r505)
+  | 651 -> One (r506)
+  | 650 -> One (r507)
+  | 649 -> One (r508)
+  | 672 -> One (r510)
+  | 673 -> One (r512)
+  | 645 -> One (r513)
+  | 644 -> One (r514)
+  | 641 -> One (r515)
+  | 640 -> One (r516)
+  | 648 -> One (r517)
+  | 647 -> One (r518)
+  | 658 -> One (r519)
+  | 663 -> One (r521)
+  | 665 -> One (r522)
+  | 668 -> One (r523)
+  | 667 -> One (r524)
+  | 671 -> One (r525)
+  | 675 -> One (r526)
+  | 686 -> One (r527)
+  | 691 -> One (r528)
+  | 690 -> One (r529)
+  | 1090 -> One (r530)
+  | 897 -> One (r531)
+  | 1089 -> One (r533)
+  | 1088 -> One (r534)
+  | 1085 -> One (r535)
+  | 1082 -> One (r536)
+  | 701 -> One (r537)
+  | 1081 -> One (r538)
+  | 1011 -> One (r539)
+  | 1010 -> One (r540)
+  | 1002 -> One (r541)
+  | 1014 -> One (r543)
+  | 1080 -> One (r545)
+  | 1079 -> One (r546)
+  | 1078 -> One (r547)
+  | 1077 -> One (r548)
+  | 1076 -> One (r549)
+  | 1075 -> One (r550)
+  | 709 -> One (r551)
+  | 708 -> One (r552)
+  | 1072 -> One (r553)
+  | 712 -> One (r554)
+  | 711 -> One (r555)
+  | 1069 -> One (r556)
+  | 1068 -> One (r557)
+  | 1067 -> One (r558)
+  | 715 -> One (r559)
+  | 714 -> One (r560)
+  | 1063 -> One (r561)
+  | 718 -> One (r562)
+  | 717 -> One (r563)
+  | 1062 -> One (r564)
+  | 1058 -> One (r565)
+  | 1057 -> One (r566)
+  | 1056 -> One (r567)
+  | 1049 -> One (r568)
+  | 1040 -> One (r570)
+  | 729 -> One (r571)
+  | 1055 -> One (r573)
+  | 1054 -> One (r574)
+  | 724 -> One (r575)
+  | 723 -> One (r576)
+  | 1053 -> One (r577)
+  | 728 -> One (r578)
+  | 727 -> One (r579)
+  | 1032 -> One (r580)
+  | 1031 -> One (r581)
+  | 1030 -> One (r582)
+  | 1029 -> One (r583)
+  | 734 -> One (r584)
+  | 733 -> One (r585)
+  | 732 -> One (r586)
+  | 731 -> One (r587)
+  | 1023 -> One (r588)
+  | 1028 -> One (r590)
+  | 1027 -> One (r591)
+  | 1026 -> One (r592)
+  | 1025 -> One (r593)
+  | 1024 -> One (r594)
+  | 1021 -> One (r595)
+  | 739 -> One (r596)
+  | 738 -> One (r597)
+  | 737 -> One (r598)
+  | 736 -> One (r599)
+  | 743 -> One (r600)
+  | 748 -> One (r601)
+  | 747 -> One (r602)
+  | 746 | 1018 -> One (r603)
+  | 1017 -> One (r604)
+  | 757 -> One (r605)
+  | 756 -> One (r606)
+  | 755 -> One (r607)
+  | 754 -> One (r608)
+  | 753 -> One (r609)
+  | 752 -> One (r610)
+  | 974 -> One (r611)
+  | 764 -> One (r612)
+  | 763 -> One (r613)
+  | 768 -> One (r614)
+  | 767 -> One (r615)
+  | 766 -> One (r616)
+  | 770 -> One (r617)
+  | 912 | 967 -> One (r618)
+  | 911 | 966 -> One (r619)
+  | 772 | 910 -> One (r620)
+  | 771 | 909 -> One (r621)
+  | 965 -> One (r622)
+  | 776 -> One (r623)
+  | 778 -> One (r624)
+  | 780 -> One (r625)
+  | 782 -> One (r626)
+  | 786 | 928 -> One (r627)
+  | 785 | 927 -> One (r628)
+  | 784 | 926 -> One (r629)
+  | 783 | 925 -> One (r630)
+  | 885 -> One (r631)
+  | 797 -> One (r632)
+  | 796 -> One (r633)
+  | 801 -> One (r634)
+  | 800 -> One (r635)
+  | 804 -> One (r636)
+  | 806 -> One (r637)
+  | 811 -> One (r638)
+  | 815 -> One (r639)
+  | 814 -> One (r640)
+  | 818 -> One (r641)
+  | 820 -> One (r642)
+  | 822 -> One (r643)
+  | 824 -> One (r644)
+  | 826 -> One (r645)
+  | 828 -> One (r646)
+  | 830 -> One (r647)
+  | 832 -> One (r648)
+  | 834 -> One (r649)
+  | 836 -> One (r650)
+  | 838 -> One (r651)
+  | 840 -> One (r652)
+  | 842 -> One (r653)
+  | 844 -> One (r654)
+  | 846 -> One (r655)
+  | 848 -> One (r656)
+  | 850 -> One (r657)
+  | 852 -> One (r658)
+  | 854 -> One (r659)
+  | 856 -> One (r660)
+  | 882 -> One (r661)
+  | 881 -> One (r662)
+  | 858 -> One (r663)
+  | 863 -> One (r664)
+  | 862 -> One (r665)
+  | 861 -> One (r666)
+  | 866 -> One (r667)
+  | 865 -> One (r668)
+  | 868 -> One (r669)
+  | 870 -> One (r670)
+  | 872 -> One (r671)
+  | 874 -> One (r672)
+  | 879 -> One (r673)
+  | 888 | 933 -> One (r674)
+  | 887 | 932 -> One (r675)
+  | 886 | 931 -> One (r676)
+  | 891 | 938 -> One (r677)
+  | 890 | 937 -> One (r678)
+  | 889 | 936 -> One (r679)
+  | 896 | 945 -> One (r680)
+  | 895 | 944 -> One (r681)
+  | 894 | 943 -> One (r682)
+  | 893 | 942 -> One (r683)
+  | 902 | 950 -> One (r684)
+  | 901 | 949 -> One (r685)
+  | 900 | 948 -> One (r686)
+  | 905 | 955 -> One (r687)
+  | 904 | 954 -> One (r688)
+  | 903 | 953 -> One (r689)
+  | 908 -> One (r690)
+  | 914 -> One (r691)
+  | 917 | 970 -> One (r692)
+  | 916 | 969 -> One (r693)
+  | 915 | 968 -> One (r694)
+  | 919 -> One (r695)
+  | 922 | 973 -> One (r696)
+  | 921 | 972 -> One (r697)
+  | 920 | 971 -> One (r698)
+  | 924 -> One (r699)
+  | 930 -> One (r700)
+  | 935 -> One (r701)
+  | 940 -> One (r702)
+  | 947 -> One (r703)
+  | 952 -> One (r704)
+  | 957 -> One (r705)
+  | 960 -> One (r706)
+  | 977 -> One (r707)
+  | 976 -> One (r708)
+  | 982 -> One (r709)
+  | 986 -> One (r710)
+  | 988 -> One (r711)
+  | 990 -> One (r712)
+  | 992 -> One (r713)
+  | 994 -> One (r714)
+  | 997 -> One (r716)
+  | 996 -> One (r717)
+  | 1016 -> One (r718)
+  | 1015 -> One (r719)
+  | 1001 -> One (r720)
+  | 1000 -> One (r721)
+  | 1004 -> One (r722)
+  | 1006 -> One (r723)
+  | 1005 | 1140 -> One (r724)
+  | 1008 -> One (r725)
+  | 1039 -> One (r726)
+  | 1038 -> One (r727)
+  | 1037 -> One (r728)
+  | 1036 -> One (r729)
+  | 1035 -> One (r730)
+  | 1034 -> One (r731)
+  | 1052 -> One (r732)
+  | 1044 -> One (r733)
+  | 1043 -> One (r734)
+  | 1048 -> One (r735)
+  | 1047 -> One (r736)
+  | 1046 -> One (r737)
+  | 1051 -> One (r738)
+  | 1065 -> One (r739)
+  | 1071 -> One (r740)
+  | 1074 -> One (r741)
+  | 1087 -> One (r742)
+  | 1092 -> One (r743)
+  | 1104 -> One (r744)
+  | 1103 -> One (r745)
+  | 1111 -> One (r747)
+  | 1110 -> One (r748)
+  | 1109 -> One (r749)
+  | 1102 -> One (r750)
+  | 1101 -> One (r751)
+  | 1100 -> One (r752)
+  | 1108 -> One (r753)
+  | 1107 -> One (r754)
+  | 1106 -> One (r755)
+  | 1113 -> One (r756)
+  | 1121 -> One (r757)
+  | 1120 -> One (r758)
+  | 1119 -> One (r759)
+  | 1118 -> One (r760)
+  | 1117 -> One (r761)
+  | 1116 -> One (r762)
+  | 1115 -> One (r763)
+  | 1130 -> One (r764)
+  | 1129 -> One (r765)
+  | 1133 -> One (r766)
+  | 1146 -> One (r767)
+  | 1145 -> One (r768)
+  | 1144 -> One (r769)
+  | 1143 -> One (r770)
+  | 1142 -> One (r771)
+  | 1151 -> One (r772)
+  | 1150 -> One (r773)
+  | 1149 -> One (r774)
+  | 1148 -> One (r775)
+  | 1154 -> One (r776)
+  | 1153 -> One (r777)
+  | 1169 -> One (r778)
+  | 1168 -> One (r779)
+  | 1172 -> One (r780)
+  | 1171 -> One (r781)
+  | 1175 -> One (r782)
+  | 1174 -> One (r783)
+  | 1183 -> One (r784)
+  | 1182 -> One (r785)
+  | 1209 -> One (r786)
+  | 1208 -> One (r787)
+  | 1207 -> One (r788)
+  | 1206 -> One (r789)
+  | 1197 -> One (r790)
+  | 1196 -> One (r792)
+  | 1195 -> One (r793)
+  | 1191 -> One (r794)
+  | 1190 -> One (r795)
+  | 1189 -> One (r796)
+  | 1188 -> One (r797)
+  | 1187 -> One (r798)
+  | 1194 -> One (r799)
+  | 1193 -> One (r800)
+  | 1205 -> One (r801)
+  | 1204 -> One (r802)
+  | 1203 -> One (r803)
+  | 1212 -> One (r804)
+  | 1211 -> One (r805)
+  | 1256 -> One (r806)
+  | 1245 -> One (r807)
+  | 1244 -> One (r808)
+  | 1235 -> One (r809)
+  | 1234 -> One (r811)
+  | 1233 -> One (r812)
+  | 1232 -> One (r813)
+  | 1217 -> One (r814)
+  | 1216 -> One (r815)
+  | 1215 -> One (r816)
+  | 1231 -> One (r817)
+  | 1230 -> One (r819)
+  | 1229 -> One (r820)
+  | 1228 -> One (r821)
+  | 1224 -> One (r822)
+  | 1223 -> One (r823)
+  | 1222 -> One (r824)
+  | 1221 -> One (r825)
+  | 1220 -> One (r826)
+  | 1227 -> One (r827)
+  | 1226 -> One (r828)
+  | 1243 -> One (r829)
+  | 1242 -> One (r830)
+  | 1241 -> One (r831)
+  | 1255 -> One (r832)
+  | 1254 -> One (r833)
+  | 1253 -> One (r834)
+  | 1252 -> One (r835)
+  | 1251 -> One (r836)
+  | 1250 -> One (r837)
+  | 1249 -> One (r838)
+  | 1248 -> One (r839)
+  | 1668 -> One (r840)
+  | 1667 -> One (r841)
+  | 1258 -> One (r842)
+  | 1260 -> One (r843)
+  | 1262 -> One (r844)
+  | 1287 -> One (r845)
+  | 1286 -> One (r846)
+  | 1285 -> One (r847)
+  | 1273 -> One (r848)
+  | 1272 -> One (r849)
+  | 1271 -> One (r850)
+  | 1270 -> One (r851)
+  | 1267 -> One (r852)
+  | 1266 -> One (r853)
+  | 1265 -> One (r854)
+  | 1264 -> One (r855)
+  | 1269 -> One (r856)
+  | 1284 -> One (r857)
+  | 1277 -> One (r858)
+  | 1276 -> One (r859)
+  | 1275 -> One (r860)
+  | 1283 -> One (r861)
+  | 1282 -> One (r862)
+  | 1281 -> One (r863)
+  | 1280 -> One (r864)
+  | 1279 -> One (r865)
+  | 1663 -> One (r866)
+  | 1662 -> One (r867)
+  | 1289 -> One (r868)
+  | 1294 -> One (r869)
+  | 1293 -> One (r870)
+  | 1292 -> One (r871)
+  | 1291 -> One (r872)
+  | 1302 -> One (r873)
+  | 1305 -> One (r875)
+  | 1304 -> One (r876)
+  | 1301 -> One (r877)
+  | 1300 -> One (r878)
+  | 1299 -> One (r879)
+  | 1298 -> One (r880)
+  | 1297 -> One (r881)
+  | 1296 -> One (r882)
+  | 1313 -> One (r883)
+  | 1312 -> One (r884)
+  | 1311 -> One (r885)
+  | 1310 -> One (r886)
+  | 1316 -> One (r890)
+  | 1315 -> One (r891)
+  | 1314 -> One (r892)
+  | 1374 -> One (r893)
+  | 1373 -> One (r894)
+  | 1372 -> One (r895)
+  | 1371 -> One (r896)
+  | 1536 -> One (r897)
+  | 1535 -> One (r898)
+  | 1328 -> One (r899)
+  | 1327 -> One (r900)
+  | 1326 -> One (r901)
+  | 1325 -> One (r902)
+  | 1324 -> One (r903)
+  | 1323 -> One (r904)
+  | 1322 -> One (r905)
+  | 1321 -> One (r906)
+  | 1361 -> One (r907)
+  | 1360 -> One (r908)
+  | 1363 -> One (r910)
+  | 1362 -> One (r911)
+  | 1356 -> One (r912)
+  | 1338 -> One (r913)
+  | 1337 -> One (r914)
+  | 1336 -> One (r915)
+  | 1335 -> One (r916)
+  | 1334 -> One (r917)
+  | 1342 -> One (r921)
+  | 1341 -> One (r922)
+  | 1355 -> One (r923)
+  | 1347 -> One (r924)
+  | 1346 -> One (r925)
+  | 1345 -> One (r926)
+  | 1344 -> One (r927)
+  | 1354 -> One (r928)
+  | 1353 -> One (r929)
+  | 1352 -> One (r930)
+  | 1351 -> One (r931)
+  | 1350 -> One (r932)
+  | 1349 -> One (r933)
+  | 1359 -> One (r936)
+  | 1358 -> One (r937)
+  | 1365 -> One (r938)
+  | 1370 -> One (r939)
+  | 1369 -> One (r940)
+  | 1368 -> One (r941)
+  | 1367 -> One (r942)
+  | 1430 | 1484 -> One (r944)
+  | 1486 -> One (r946)
+  | 1500 -> One (r948)
+  | 1490 -> One (r949)
+  | 1489 -> One (r950)
+  | 1471 -> One (r951)
+  | 1470 -> One (r952)
+  | 1469 -> One (r953)
+  | 1468 -> One (r954)
+  | 1467 -> One (r955)
+  | 1466 -> One (r956)
+  | 1465 -> One (r957)
+  | 1455 -> One (r958)
+  | 1454 -> One (r959)
+  | 1386 -> One (r960)
+  | 1385 -> One (r961)
+  | 1384 -> One (r962)
+  | 1380 -> One (r963)
+  | 1378 -> One (r964)
+  | 1377 -> One (r965)
+  | 1383 -> One (r966)
+  | 1382 -> One (r967)
+  | 1448 -> One (r968)
+  | 1447 -> One (r969)
+  | 1392 -> One (r970)
+  | 1388 -> One (r971)
+  | 1391 -> One (r972)
+  | 1390 -> One (r973)
+  | 1403 -> One (r974)
+  | 1402 -> One (r975)
+  | 1401 -> One (r976)
+  | 1400 -> One (r977)
+  | 1399 -> One (r978)
+  | 1394 -> One (r979)
+  | 1414 -> One (r980)
+  | 1413 -> One (r981)
+  | 1412 -> One (r982)
+  | 1411 -> One (r983)
+  | 1410 -> One (r984)
+  | 1405 -> One (r985)
+  | 1439 -> One (r986)
+  | 1438 -> One (r987)
+  | 1416 -> One (r988)
+  | 1437 -> One (r989)
+  | 1436 -> One (r990)
+  | 1435 -> One (r991)
+  | 1434 -> One (r992)
+  | 1418 -> One (r993)
+  | 1432 -> One (r994)
+  | 1422 -> One (r995)
+  | 1421 -> One (r996)
+  | 1420 -> One (r997)
+  | 1429 | 1477 -> One (r998)
+  | 1426 -> One (r1000)
+  | 1425 -> One (r1001)
+  | 1424 -> One (r1002)
+  | 1423 | 1476 -> One (r1003)
+  | 1428 -> One (r1004)
+  | 1444 -> One (r1005)
+  | 1443 -> One (r1006)
+  | 1442 -> One (r1007)
+  | 1446 -> One (r1009)
+  | 1445 -> One (r1010)
+  | 1441 -> One (r1011)
+  | 1450 -> One (r1012)
+  | 1453 -> One (r1013)
+  | 1464 -> One (r1014)
+  | 1463 -> One (r1015)
+  | 1462 -> One (r1016)
+  | 1461 -> One (r1017)
+  | 1460 -> One (r1018)
+  | 1459 -> One (r1019)
+  | 1458 -> One (r1020)
+  | 1457 -> One (r1021)
+  | 1488 -> One (r1022)
+  | 1475 -> One (r1023)
+  | 1474 -> One (r1024)
+  | 1473 -> One (r1025)
+  | 1487 -> One (r1026)
+  | 1479 -> One (r1027)
+  | 1485 -> One (r1028)
+  | 1482 -> One (r1029)
+  | 1481 -> One (r1030)
+  | 1499 -> One (r1031)
+  | 1498 -> One (r1032)
+  | 1497 -> One (r1033)
+  | 1496 -> One (r1034)
+  | 1495 -> One (r1035)
+  | 1494 -> One (r1036)
+  | 1493 -> One (r1037)
+  | 1492 -> One (r1038)
+  | 1509 -> One (r1039)
+  | 1511 -> One (r1040)
+  | 1521 -> One (r1041)
+  | 1520 -> One (r1042)
+  | 1519 -> One (r1043)
+  | 1518 -> One (r1044)
+  | 1517 -> One (r1045)
+  | 1516 -> One (r1046)
+  | 1515 -> One (r1047)
+  | 1514 -> One (r1048)
+  | 1532 -> One (r1049)
+  | 1531 -> One (r1050)
+  | 1530 -> One (r1051)
+  | 1529 -> One (r1052)
+  | 1528 -> One (r1053)
+  | 1527 -> One (r1054)
+  | 1526 -> One (r1055)
+  | 1525 -> One (r1056)
+  | 1524 -> One (r1057)
+  | 1579 -> One (r1058)
+  | 1623 -> One (r1060)
+  | 1545 -> One (r1061)
+  | 1640 -> One (r1063)
+  | 1631 -> One (r1064)
+  | 1630 -> One (r1065)
+  | 1544 -> One (r1066)
+  | 1543 -> One (r1067)
+  | 1542 -> One (r1068)
+  | 1541 -> One (r1069)
+  | 1540 -> One (r1070)
+  | 1617 -> One (r1071)
+  | 1616 -> One (r1072)
+  | 1548 -> One (r1073)
+  | 1547 -> One (r1074)
+  | 1552 -> One (r1075)
+  | 1551 -> One (r1076)
+  | 1550 -> One (r1077)
+  | 1611 -> One (r1078)
+  | 1610 -> One (r1079)
+  | 1609 -> One (r1080)
+  | 1608 -> One (r1081)
+  | 1607 -> One (r1082)
+  | 1606 -> One (r1083)
+  | 1603 -> One (r1084)
+  | 1555 -> One (r1085)
+  | 1599 -> One (r1086)
+  | 1598 -> One (r1087)
+  | 1593 -> One (r1088)
+  | 1592 -> One (r1089)
+  | 1591 -> One (r1090)
+  | 1590 -> One (r1091)
+  | 1564 -> One (r1092)
+  | 1563 -> One (r1093)
+  | 1562 -> One (r1094)
+  | 1561 -> One (r1095)
+  | 1560 -> One (r1096)
+  | 1559 -> One (r1097)
+  | 1589 -> One (r1098)
+  | 1568 -> One (r1099)
+  | 1567 -> One (r1100)
+  | 1566 -> One (r1101)
+  | 1572 -> One (r1102)
+  | 1571 -> One (r1103)
+  | 1570 -> One (r1104)
+  | 1586 -> One (r1105)
+  | 1576 -> One (r1106)
+  | 1575 -> One (r1107)
+  | 1588 -> One (r1109)
+  | 1574 -> One (r1110)
+  | 1583 -> One (r1111)
+  | 1578 -> One (r1112)
+  | 1597 -> One (r1113)
+  | 1596 -> One (r1114)
+  | 1595 -> One (r1115)
+  | 1602 -> One (r1116)
+  | 1601 -> One (r1117)
+  | 1605 -> One (r1118)
+  | 1615 -> One (r1119)
+  | 1614 -> One (r1120)
+  | 1613 -> One (r1121)
+  | 1619 -> One (r1122)
+  | 1622 -> One (r1123)
+  | 1627 -> One (r1124)
+  | 1626 -> One (r1125)
+  | 1625 -> One (r1126)
+  | 1629 -> One (r1127)
+  | 1639 -> One (r1128)
+  | 1638 -> One (r1129)
+  | 1637 -> One (r1130)
+  | 1636 -> One (r1131)
+  | 1635 -> One (r1132)
+  | 1634 -> One (r1133)
+  | 1633 -> One (r1134)
+  | 1650 -> One (r1135)
+  | 1653 -> One (r1136)
+  | 1655 -> One (r1137)
+  | 1661 -> One (r1138)
+  | 1660 -> One (r1139)
+  | 1681 -> One (r1140)
+  | 1680 -> One (r1141)
+  | 1699 -> One (r1142)
+  | 1698 -> One (r1143)
+  | 1697 -> One (r1144)
+  | 1718 -> One (r1145)
+  | 1717 -> One (r1146)
+  | 1716 -> One (r1147)
+  | 1715 -> One (r1148)
+  | 1721 -> One (r1149)
+  | 1720 -> One (r1150)
+  | 1725 -> One (r1151)
+  | 1731 -> One (r1152)
+  | 1733 -> One (r1153)
+  | 1735 -> One (r1154)
+  | 1748 -> One (r1155)
+  | 1752 -> One (r1156)
+  | 1757 -> One (r1157)
+  | 1764 -> One (r1158)
+  | 1763 -> One (r1159)
+  | 1762 -> One (r1160)
+  | 1761 -> One (r1161)
+  | 1771 -> One (r1162)
+  | 1775 -> One (r1163)
+  | 1779 -> One (r1164)
+  | 1782 -> One (r1165)
+  | 1787 -> One (r1166)
+  | 1791 -> One (r1167)
+  | 1795 -> One (r1168)
+  | 1798 -> One (r1169)
+  | 1802 -> One (r1170)
+  | 1808 -> One (r1171)
+  | 1818 -> One (r1172)
+  | 1820 -> One (r1173)
+  | 1823 -> One (r1174)
+  | 1822 -> One (r1175)
+  | 1825 -> One (r1176)
+  | 1835 -> One (r1177)
+  | 1831 -> One (r1178)
+  | 1830 -> One (r1179)
+  | 1834 -> One (r1180)
+  | 1833 -> One (r1181)
+  | 1840 -> One (r1182)
+  | 1839 -> One (r1183)
+  | 1838 -> One (r1184)
+  | 1842 -> One (r1185)
+  | 524 -> Select (function
+    | -1 -> [R 105]
+    | _ -> S (T T_DOT) :: r412)
+  | 745 -> Select (function
+    | -1 -> [R 105]
+    | _ -> r604)
+  | 160 -> Select (function
+    | -1 -> r117
+    | _ -> R 186 :: r139)
+  | 385 -> Select (function
+    | -1 -> r117
+    | _ -> R 186 :: r301)
+  | 1306 -> Select (function
+    | -1 -> r896
+    | _ -> R 186 :: r889)
+  | 1330 -> Select (function
+    | -1 -> r855
+    | _ -> R 186 :: r920)
+  | 657 -> Select (function
+    | -1 -> r201
+    | _ -> [R 218])
+  | 542 -> Select (function
+    | -1 -> [R 666]
+    | _ -> S (N N_pattern) :: r420)
+  | 539 -> Select (function
+    | -1 -> [R 667]
+    | _ -> S (N N_pattern) :: r419)
+  | 166 -> Select (function
+    | -1 -> r145
+    | _ -> R 774 :: r151)
+  | 388 -> Select (function
+    | -1 -> r145
+    | _ -> R 774 :: r307)
+  | 407 -> Select (function
+    | -1 -> S (T T_RPAREN) :: r58
+    | _ -> S (T T_COLONCOLON) :: r317)
+  | 463 -> Select (function
+    | 494 | 598 | 760 | 858 | 981 | 1124 | 1561 | 1595 -> r84
+    | -1 -> S (T T_RPAREN) :: r58
+    | _ -> S (N N_pattern) :: r347)
+  | 89 -> Select (function
+    | -1 -> S (T T_RPAREN) :: r58
+    | _ -> Sub (r1) :: r57)
+  | 496 -> Select (function
+    | -1 -> S (T T_RBRACKET) :: r247
+    | _ -> Sub (r385) :: r387)
+  | 699 -> Select (function
+    | -1 -> S (T T_RBRACKET) :: r247
+    | _ -> Sub (r532) :: r534)
+  | 618 -> Select (function
+    | 60 | 95 | 384 | 451 | 1258 | 1289 -> r480
+    | _ -> S (T T_OPEN) :: r474)
+  | 411 -> Select (function
+    | -1 -> r318
+    | _ -> S (T T_LPAREN) :: r321)
+  | 206 -> Select (function
+    | -1 -> r203
+    | _ -> S (T T_DOT) :: r205)
+  | 655 -> Select (function
+    | -1 -> r203
+    | _ -> S (T T_DOT) :: r520)
+  | 190 -> Select (function
+    | -1 -> r118
+    | _ -> S (T T_COLON) :: r172)
+  | 196 -> Select (function
+    | 1140 -> r97
+    | _ -> Sub (r95) :: r179)
+  | 197 -> Select (function
+    | 1140 -> r96
+    | _ -> r179)
+  | 432 -> Select (function
+    | -1 -> r113
+    | _ -> r118)
+  | 1695 -> Select (function
+    | -1 -> r113
+    | _ -> r118)
+  | 1694 -> Select (function
+    | -1 -> r114
+    | _ -> r137)
+  | 431 -> Select (function
+    | -1 -> r114
+    | _ -> r299)
+  | 162 -> Select (function
+    | -1 -> r115
+    | _ -> r138)
+  | 387 -> Select (function
+    | -1 -> r115
+    | _ -> r300)
+  | 161 -> Select (function
+    | -1 -> r116
+    | _ -> r139)
+  | 386 -> Select (function
+    | -1 -> r116
+    | _ -> r301)
+  | 390 -> Select (function
+    | -1 -> r143
+    | _ -> r118)
+  | 185 -> Select (function
+    | -1 -> r143
+    | _ -> r118)
+  | 184 -> Select (function
+    | -1 -> r144
+    | _ -> r151)
+  | 389 -> Select (function
+    | -1 -> r144
+    | _ -> r307)
+  | 213 -> Select (function
+    | -1 -> r202
+    | _ -> r205)
+  | 656 -> Select (function
+    | -1 -> r202
+    | _ -> r520)
+  | 1333 -> Select (function
+    | -1 -> r852
+    | _ -> r918)
+  | 1332 -> Select (function
+    | -1 -> r853
+    | _ -> r919)
+  | 1331 -> Select (function
+    | -1 -> r854
+    | _ -> r920)
+  | 1309 -> Select (function
+    | -1 -> r893
+    | _ -> r887)
+  | 1308 -> Select (function
+    | -1 -> r894
+    | _ -> r888)
+  | 1307 -> Select (function
+    | -1 -> r895
+    | _ -> r889)
+  | _ -> raise Not_found
diff --git a/src/ocaml/preprocess/parser_recover.mli b/src/ocaml/preprocess/parser_recover.mli
new file mode 100644
index 0000000..8775aa1
--- /dev/null
+++ b/src/ocaml/preprocess/parser_recover.mli
@@ -0,0 +1,24 @@
+open Parser_raw
+
+module Default : sig
+  val default_loc : Location.t ref
+end
+
+val default_value : 'a MenhirInterpreter.symbol -> 'a
+
+type action =
+  | Abort
+  | R of int
+  | S : 'a MenhirInterpreter.symbol -> action
+  | Sub of action list
+
+type decision =
+  | Nothing
+  | One of action list
+  | Select of (int -> action list)
+
+val depth : int array
+
+val can_pop : 'a MenhirInterpreter.terminal -> bool
+
+val recover : int -> decision
diff --git a/src/ocaml/preprocess/printer/dune b/src/ocaml/preprocess/printer/dune
new file mode 100644
index 0000000..4103b5c
--- /dev/null
+++ b/src/ocaml/preprocess/printer/dune
@@ -0,0 +1,3 @@
+(executable
+ (name gen_printer)
+ (libraries unix menhirSdk))
diff --git a/src/ocaml/preprocess/printer/gen_printer.ml b/src/ocaml/preprocess/printer/gen_printer.ml
new file mode 100644
index 0000000..0f71dea
--- /dev/null
+++ b/src/ocaml/preprocess/printer/gen_printer.ml
@@ -0,0 +1,125 @@
+open MenhirSdk
+
+include Cmly_read.Read(struct let filename = Sys.argv.(1) end)
+
+let is_attribute names attr =
+  List.exists (fun l -> Attribute.has_label l attr) names
+
+let printf = Printf.printf
+let sprintf = Printf.sprintf
+
+let menhir = "MenhirInterpreter"
+
+(** Print header, if any *)
+
+let print_header () =
+  let name = Filename.chop_extension (Filename.basename Sys.argv.(1)) in
+  printf "open %s\n" (String.capitalize_ascii name);
+  List.iter
+    (fun attr ->
+       if is_attribute ["header"; "printer.header"] attr then
+         printf "%s\n" (Attribute.payload attr))
+    Grammar.attributes
+
+(** Printer from attributes *)
+
+let symbol_printer default attribs =
+  match List.find (is_attribute ["symbol"]) attribs with
+  | attr -> Attribute.payload attr
+  | exception Not_found ->
+    sprintf "%S" default
+
+let print_symbol () =
+  let case_t t =
+    match Terminal.kind t with
+    | `REGULAR | `ERROR | `EOF ->
+      printf "  | %s.X (%s.T %s.T_%s) -> %s\n"
+        menhir menhir menhir
+        (Terminal.name t)
+        (symbol_printer (Terminal.name t) (Terminal.attributes t))
+    | `PSEUDO -> ()
+  and case_n n =
+    match Nonterminal.kind n with
+    | `REGULAR ->
+      printf "  | %s.X (%s.N %s.N_%s) -> %s\n"
+        menhir menhir menhir
+        (Nonterminal.mangled_name n)
+        (symbol_printer (Nonterminal.mangled_name n) (Nonterminal.attributes n))
+    | `START -> ()
+  in
+  printf "let print_symbol = function\n";
+  Terminal.iter case_t;
+  Nonterminal.iter case_n
+
+let value_printer default attribs =
+  match List.find (is_attribute ["printer"]) attribs with
+  | attr -> sprintf "(%s)" (Attribute.payload attr)
+  | exception Not_found ->
+    sprintf "(fun _ -> %s)" (symbol_printer default attribs)
+
+let print_value () =
+  let case_t t =
+    match Terminal.kind t with
+    | `REGULAR | `ERROR | `EOF->
+      printf "  | %s.T %s.T_%s -> %s\n"
+        menhir menhir
+        (Terminal.name t)
+        (value_printer (Terminal.name t) (Terminal.attributes t))
+    | `PSEUDO -> ()
+  and case_n n =
+    match Nonterminal.kind n with
+    | `REGULAR ->
+      printf "  | %s.N %s.N_%s -> %s\n"
+        menhir menhir
+        (Nonterminal.mangled_name n)
+        (value_printer (Nonterminal.mangled_name n) (Nonterminal.attributes n))
+    | `START -> ()
+  in
+  printf "let print_value (type a) : a %s.symbol -> a -> string = function\n"
+    menhir;
+  Terminal.iter case_t;
+  Nonterminal.iter case_n
+
+let print_token () =
+  let case t =
+    match Terminal.kind t with
+    | `REGULAR | `EOF ->
+      printf "  | %s%s -> print_value (%s.T %s.T_%s) %s\n"
+        (Terminal.name t)
+        (match Terminal.typ t with | None -> "" | Some _typ -> " v")
+        menhir menhir
+        (Terminal.name t)
+        (match Terminal.typ t with | None -> "()" | Some _typ -> "v")
+    | `PSEUDO | `ERROR -> ()
+  in
+  printf "let print_token = function\n";
+  Terminal.iter case
+
+let print_token_of_terminal () =
+  let case t =
+    match Terminal.kind t with
+    | `REGULAR | `EOF ->
+      printf "  | %s.T_%s -> %s%s\n"
+        menhir (Terminal.name t)
+        (Terminal.name t) (if Terminal.typ t <> None then " v" else "")
+    | `ERROR ->
+      printf "  | %s.T_%s -> assert false\n"
+        menhir (Terminal.name t)
+    | `PSEUDO -> ()
+  in
+  printf
+    "let token_of_terminal (type a) (t : a %s.terminal) (v : a) : token =\n\
+    \  match t with\n"
+    menhir;
+  Terminal.iter case
+
+let () =
+  print_header ();
+  print_newline ();
+  print_symbol ();
+  print_newline ();
+  print_value ();
+  print_newline ();
+  print_token ();
+  print_newline ();
+  print_token_of_terminal ()
diff --git a/src/ocaml/preprocess/recover/compressedBitSet.ml b/src/ocaml/preprocess/recover/compressedBitSet.ml
new file mode 100644
index 0000000..9a4783d
--- /dev/null
+++ b/src/ocaml/preprocess/recover/compressedBitSet.ml
@@ -0,0 +1,238 @@
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU General Public License version 2, as described in the    *)
+(*  file LICENSE.                                                             *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* A compressed (or should we say sparse?) bit set is a list of pairs
+   of integers. The first component of every pair is an index, while
+   the second component is a bit field. The list is sorted by order
+   of increasing indices. *)
+
+type t =
+  | N
+  | C of int * int * t
+
+type element =
+    int
+
+let word_size =
+  Sys.word_size - 1
+
+let empty =
+  N
+
+let is_empty = function
+  | N ->
+      true
+  | C _ ->
+      false
+
+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)
+    | 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')
+  in
+  add s
+
+let singleton i =
+   add i N
+
+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
+    | 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')
+  in
+  remove s
+
+let rec fold f s accu =
+  match s with
+  | N ->
+      accu
+  | C (base, ss, qs) ->
+      loop f qs base ss accu
+
+and loop f qs i ss accu =
+  if ss = 0 then
+    fold f qs accu
+  else
+    (* One could in principle check whether [ss land 0x3] is zero and if
+       so move to [i + 2] and [ss lsr 2], and similarly for various sizes.
+       In practice, this does not seem to make a measurable difference. *)
+    loop f qs (i + 1) (ss lsr 1) (if ss land 1 = 1 then f i accu else accu)
+
+let iter f s =
+  fold (fun x () -> f x) s ()
+
+let is_singleton s =
+  match s with
+  | C (_, ss, N) ->
+      (* Test whether only one bit is set in [ss]. We do this by turning
+         off the rightmost bit, then comparing to zero. *)
+      ss land (ss - 1) = 0
+  | C (_, _, C _)
+  | N ->
+      false
+
+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 =
+  match s1, s2 with
+  | N, _ ->
+      true
+  | _, N ->
+      false
+  | C (addr1, ss1, qs1), C (addr2, ss2, qs2) ->
+      if addr1 < addr2 then
+        false
+      else if addr1 = addr2 then
+        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 =
+  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)
+      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 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
+      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)
+
+exception Found of int
+
+let choose s =
+  try
+    iter (fun x ->
+      raise (Found x)
+    ) s;
+    raise Not_found
+  with Found x ->
+    x
+
+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
+
+let equal s1 s2 =
+  compare s1 s2 = 0
+
+let rec disjoint s1 s2 =
+  match s1, s2 with
+  | N, _
+  | _, N ->
+      true
+  | 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
+
diff --git a/src/ocaml/preprocess/recover/compressedBitSet.mli b/src/ocaml/preprocess/recover/compressedBitSet.mli
new file mode 100644
index 0000000..bfbd47d
--- /dev/null
+++ b/src/ocaml/preprocess/recover/compressedBitSet.mli
@@ -0,0 +1,14 @@
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU General Public License version 2, as described in the    *)
+(*  file LICENSE.                                                             *)
+(*                                                                            *)
+(******************************************************************************)
+
+include GSet.S with type element = int
diff --git a/src/ocaml/preprocess/recover/dune b/src/ocaml/preprocess/recover/dune
new file mode 100644
index 0000000..2cfd745
--- /dev/null
+++ b/src/ocaml/preprocess/recover/dune
@@ -0,0 +1,3 @@
+(executable
+ (name gen_recover)
+ (libraries unix menhirSdk))
diff --git a/src/ocaml/preprocess/recover/emitter.ml b/src/ocaml/preprocess/recover/emitter.ml
new file mode 100644
index 0000000..2154fee
--- /dev/null
+++ b/src/ocaml/preprocess/recover/emitter.ml
@@ -0,0 +1,301 @@
+open MenhirSdk.Cmly_api
+open Utils
+
+let menhir = "MenhirInterpreter"
+
+(* Generation scheme doing checks and failing at runtime, or not ... *)
+let safe = false
+
+module Codeconsing (S : Synthesis.S) (R : Recovery.S with module G = S.G) : sig
+
+  (* Step 1: record all definitions *)
+  val record_item : R.item -> unit
+
+  type instr =
+    | Nil
+    | Cons of instr S.paction * instr
+    | Ref of int ref * instr
+
+  (* Step 2: get prelude maximizing & serialization function *)
+  val normalize : unit -> instr list * (R.item -> instr)
+
+end = struct
+
+  open S
+
+  type fixed = A of fixed paction list
+
+  let normalized_actions = Hashtbl.create 113
+
+  let rec normalize_actions = function
+    | [] -> []
+    | [Var v] -> normalize_actions (S.solution v)
+    | (x :: xs) as xxs ->
+        try !(Hashtbl.find normalized_actions xxs)
+        with Not_found ->
+          let x' = normalize_action x in
+          let xs' = normalize_actions xs in
+          let xxs' = x' :: xs' in
+          Hashtbl.add normalized_actions xxs (ref xxs');
+          xxs'
+
+  and normalize_action = function
+    | Abort | Reduce _ | Shift _ as a -> a
+    | Var v ->
+        match normalize_actions (S.solution v) with
+        | [x] -> x
+        | xs -> Var (A xs)
+
+  let item_to_actions (st, prod, pos) =
+    normalize_actions [Var (Tail (st, prod, pos))]
+
+  let roots : R.item list ref = ref []
+
+  let record_item root =
+    roots := root :: !roots
+
+  let share () =
+    let table = Hashtbl.create 113 in
+    let rec get = function
+      | [] -> []
+      | (x :: xs) ->
+          let xxs = (get_one x :: get xs) in
+          try
+            let r, v = Hashtbl.find table xxs in
+            incr r; v
+          with Not_found ->
+            Hashtbl.add table xxs (ref 1, xxs);
+            xxs
+    and get_one = function
+      | Var (A v) -> Var (A (get v))
+      | x -> x
+    in
+    Hashtbl.iter (fun _k v -> v := get !v) normalized_actions;
+    (* Return counter *)
+    (fun v -> try !(fst (Hashtbl.find table v)) with Not_found -> 0)
+
+  type instr =
+    | Nil
+    | Cons of instr paction * instr
+    | Ref of int ref * instr
+
+  let emitter () =
+    let counter = share () in
+    let table = Hashtbl.create 113 in
+    let frozen = ref false in
+    let values = ref [] in
+    let rec emit = function
+      | [] -> Nil
+      | (x :: xs) as xxs ->
+          try Hashtbl.find table xxs
+          with Not_found ->
+            let x = match x with
+              | Var (A ys) -> Var (emit ys)
+              | Abort | Reduce _ | Shift _ as a -> a
+            in
+            let value = Cons (x, emit xs) in
+            if counter xxs = 1 then value else (
+              assert (not !frozen);
+              let value = Ref (ref (-1), value) in
+              values := value :: !values;
+              Hashtbl.add table xxs value;
+              value
+            )
+    in
+    frozen, values, emit
+
+  let normalize () =
+    let roots = List.map item_to_actions !roots in
+    let frozen, values, emit = emitter () in
+    let pass_2 item = ignore (emit item) in
+    List.iter pass_2 roots;
+    frozen := true;
+    !values, (fun item -> emit (item_to_actions item))
+end
+
+module Make
+    (G : GRAMMAR)
+    (A : Recover_attrib.S with module G = G)
+    (S : Synthesis.S with module G = G)
+    (R : Recovery.S with module G = G) :
+sig
+  val emit : Format.formatter -> unit
+end = struct
+
+  open G
+  open Format
+
+  let emit_default_value ppf =
+    fprintf ppf "open %s\n\n"
+      (String.capitalize_ascii (Filename.basename Grammar.basename));
+    fprintf ppf "module Default = struct\n";
+    A.default_prelude ppf;
+
+    fprintf ppf "  let value (type a) : a %s.symbol -> a = function\n" menhir;
+    Terminal.iter (fun t ->
+        match A.default_terminal t with
+        | None -> ()
+        | Some str ->
+            fprintf ppf "    | %s.T %s.T_%s -> %s\n" menhir menhir (Terminal.name t) str
+      );
+    Nonterminal.iter (fun n ->
+        match A.default_nonterminal n with
+        | None -> ()
+        | Some str ->
+            fprintf ppf "    | %s.N %s.N_%s -> %s\n" menhir menhir (Nonterminal.mangled_name n) str
+      );
+    (*fprintf ppf "    | _ -> raise Not_found\n"; should be exhaustive*)
+    fprintf ppf "end\n\n";
+    fprintf ppf "let default_value = Default.value\n\n"
+
+  let emit_defs ppf =
+    fprintf ppf "open %s\n\n" menhir;
+    fprintf ppf "type action =\n\
+                \  | Abort\n\
+                \  | R of int\n\
+                \  | S : 'a symbol -> action\n\
+                \  | Sub of action list\n\n";
+    fprintf ppf "type decision =\n\
+                \  | Nothing\n\
+                \  | One of action list\n\
+                \  | Select of (int -> action list)\n\n"
+
+  module C = Codeconsing(S)(R)
+
+  let emit_depth ppf =
+    let open Format in
+    fprintf ppf "let depth =\n  [|";
+    Lr1.iter (fun st ->
+        let depth, _ = R.recover st in
+        fprintf ppf "%d;" depth
+      );
+    fprintf ppf "|]\n\n"
+
+  let _code, get_instr, iter_entries =
+    Lr1.iter (fun st ->
+        let _depth, cases = R.recover st in
+        List.iter (fun (_case, items) -> C.record_item (list_last items))
+          cases
+      );
+    let code, get_instr = C.normalize () in
+    let all_instrs =
+      Lr1.tabulate (fun st ->
+          let _depth, cases = R.recover st in
+          List.map (fun (_case, items) -> get_instr (list_last items))
+            cases
+        )
+    in
+    code, get_instr,
+    (fun f -> Lr1.iter (fun st -> List.iter f (all_instrs st)))
+
+  let emit_can_pop ppf =
+    Format.fprintf ppf "let can_pop (type a) : a terminal -> bool = function\n";
+    G.Terminal.iter (fun t ->
+        if G.Terminal.kind t = `REGULAR && G.Terminal.typ t = None then
+          Format.fprintf ppf "  | T_%s -> true\n" (G.Terminal.name t));
+    Format.fprintf ppf "  | _ -> false\n\n"
+
+  let emit_recoveries ppf =
+    let k = ref 0 in
+    let instrs = ref [] in
+    let rec alloc_entry = function
+      | C.Nil -> ()
+      | C.Cons (act, instr) -> alloc_entry_action act; alloc_entry instr
+      | C.Ref (r, instr) ->
+        if (!r = -1) then (
+          alloc_entry instr;
+          r := !k;
+          instrs := (!k, instr) :: !instrs;
+          incr k;
+          )
+    and alloc_entry_action = function
+      | S.Abort | S.Reduce _ | S.Shift _ -> ()
+      | S.Var instr -> alloc_entry instr
+    in
+    iter_entries alloc_entry;
+    let open Format in
+
+    let rec emit_action ppf = function
+      | S.Abort -> fprintf ppf "Abort"
+      | S.Reduce prod -> fprintf ppf "R %d" (Production.to_int prod)
+      | S.Shift (T t) -> fprintf ppf "S (T T_%s)" (Terminal.name t)
+      | S.Shift (N n) -> fprintf ppf "S (N N_%s)" (Nonterminal.mangled_name n)
+      | S.Var instr -> fprintf ppf "Sub (%a)" emit_instr instr
+    and emit_instr ppf = function
+      | C.Nil -> fprintf ppf "[]"
+      | C.Cons (act, C.Nil) ->
+        fprintf ppf "[%a]" emit_action act
+      | C.Cons (act, instr) ->
+        fprintf ppf "%a :: %a" emit_action act emit_instr instr
+      | C.Ref (r, _) -> fprintf ppf "r%d" !r
+    in
+
+    fprintf ppf "let recover =\n";
+
+    let emit_shared (k, instr) =
+      fprintf ppf "  let r%d = %a in\n" k emit_instr instr
+    in
+    List.iter emit_shared (List.rev !instrs);
+
+    let all_cases =
+      Lr1.fold (fun st acc ->
+          let _, cases = R.recover st in
+          let cases = List.map (fun (st', items) ->
+              (get_instr (list_last items)),
+              (match st' with None -> -1 | Some st' -> Lr1.to_int st')
+            ) cases
+          in
+          let cases = match group_assoc cases with
+            | [] -> `Nothing
+            | [(instr, _)] -> `One instr
+            | xs -> `Select xs
+          in
+          (cases, (Lr1.to_int st)) :: acc)
+        []
+    in
+    let all_cases = group_assoc all_cases in
+
+    fprintf ppf "  function\n";
+    List.iter (fun (cases, states) ->
+        fprintf ppf "  ";
+        List.iter (fprintf ppf "| %d ") states;
+        fprintf ppf "-> ";
+        match cases with
+        | `Nothing -> fprintf ppf "Nothing\n";
+        | `One instr -> fprintf ppf "One (%a)\n" emit_instr instr
+        | `Select xs ->
+          fprintf ppf "Select (function\n";
+          if safe then (
+            List.iter (fun (instr, cases) ->
+                fprintf ppf "    ";
+                List.iter (fprintf ppf "| %d ") cases;
+                fprintf ppf "-> %a\n" emit_instr instr;
+              ) xs;
+            fprintf ppf "    | _ -> raise Not_found)\n"
+          ) else (
+            match List.sort
+                    (fun (_,a) (_,b) -> compare (List.length b) (List.length a))
+                    xs
+            with
+            | (instr, _) :: xs ->
+              List.iter (fun (instr, cases) ->
+                  fprintf ppf "    ";
+                  List.iter (fprintf ppf "| %d ") cases;
+                  fprintf ppf "-> %a\n" emit_instr instr;
+                ) xs;
+              fprintf ppf "    | _ -> %a)\n" emit_instr instr
+            | [] -> assert false
+          )
+      ) all_cases;
+
+    fprintf ppf "  | _ -> raise Not_found\n"
+
+
+  let emit ppf =
+    emit_default_value ppf;
+    emit_defs ppf;
+    emit_depth ppf;
+    emit_can_pop ppf;
+    emit_recoveries ppf
+
+end
diff --git a/src/ocaml/preprocess/recover/emitter.mli b/src/ocaml/preprocess/recover/emitter.mli
new file mode 100644
index 0000000..962dd67
--- /dev/null
+++ b/src/ocaml/preprocess/recover/emitter.mli
@@ -0,0 +1,10 @@
+open MenhirSdk.Cmly_api
+
+module Make
+    (G : GRAMMAR)
+    (A : Recover_attrib.S with module G = G)
+    (S : Synthesis.S with module G = G)
+    (R : Recovery.S with module G = G) :
+sig
+  val emit : Format.formatter -> unit
+end
diff --git a/src/ocaml/preprocess/recover/fix.ml b/src/ocaml/preprocess/recover/fix.ml
new file mode 100644
index 0000000..36b275b
--- /dev/null
+++ b/src/ocaml/preprocess/recover/fix.ml
@@ -0,0 +1,529 @@
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU General Public License version 2, as described in the    *)
+(*  file LICENSE.                                                             *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* -------------------------------------------------------------------------- *)
+
+(* Maps. *)
+
+(* We require imperative maps, that is, maps that can be updated in place.
+   An implementation of persistent maps, such as the one offered by ocaml's
+   standard library, can easily be turned into an implementation of imperative
+   maps, so this is a weak requirement. *)
+
+module type IMPERATIVE_MAPS = sig
+  type key
+  type 'data t
+  val create: unit -> 'data t
+  val clear: 'data t -> unit
+  val add: key -> 'data -> 'data t -> unit
+  val find: key -> 'data t -> 'data
+  val iter: (key -> 'data -> unit) -> 'data t -> unit
+end
+
+(* -------------------------------------------------------------------------- *)
+
+(* Properties. *)
+
+(* Properties must form a partial order, equipped with a least element, and
+   must satisfy the ascending chain condition: every monotone sequence
+   eventually stabilizes. *)
+
+(* [is_maximal] determines whether a property [p] is maximal with respect to
+   the partial order. Only a conservative check is required: in any event, it
+   is permitted for [is_maximal p] to return [false]. If [is_maximal p]
+   returns [true], then [p] must have no upper bound other than itself. In
+   particular, if properties form a lattice, then [p] must be the top
+   element. This feature, not described in the paper, enables a couple of
+   minor optimizations. *)
+
+module type PROPERTY = sig
+  type property
+  val bottom: property
+  val equal: property -> property -> bool
+  val is_maximal: property -> bool
+end
+
+(* -------------------------------------------------------------------------- *)
+
+(* The dynamic dependency graph. *)
+
+(* An edge from [node1] to [node2] means that [node1] depends on [node2], or
+   (equivalently) that [node1] observes [node2]. Then, an update of the
+   current property at [node2] causes a signal to be sent to [node1]. A node
+   can observe itself. *)
+
+(* This module could be placed in a separate file, but is included here in
+   order to make [Fix] self-contained. *)
+
+module Graph : sig
+
+  (* This module provides a data structure for maintaining and modifying
+     a directed graph. Each node is allowed to carry a piece of client
+     data. There are functions for creating a new node, looking up a
+     node's data, looking up a node's predecessors, and setting or
+     clearing a node's successors (all at once). *)
+  type 'data node
+
+  (* [create data] creates a new node, with no incident edges, with
+     client information [data]. Time complexity: constant. *)
+  val create: 'data -> 'data node
+
+  (* [data node] returns the client information associated with
+     the node [node]. Time complexity: constant. *)
+  val data: 'data node -> 'data
+
+  (* [predecessors node] returns a list of [node]'s predecessors.
+     Amortized time complexity: linear in the length of the output
+     list. *)
+  val predecessors: 'data node -> 'data node list
+
+  (* [set_successors src dsts] creates an edge from the node [src] to
+     each of the nodes in the list [dsts]. Duplicate elements in the
+     list [dsts] are removed, so that no duplicate edges are created. It
+     is assumed that [src] initially has no successors. Time complexity:
+     linear in the length of the input list. *)
+  val set_successors: 'data node -> 'data node list -> unit
+
+  (* [clear_successors node] removes all of [node]'s outgoing edges.
+     Time complexity: linear in the number of edges that are removed. *)
+  val clear_successors: 'data node -> unit
+
+  (* That's it. *)
+end
+= struct
+
+  (* Using doubly-linked adjacency lists, one could implement [predecessors]
+     in worst-case linear time with respect to the length of the output list,
+     [set_successors] in worst-case linear time with respect to the length of
+     the input list, and [clear_successors] in worst-case linear time with
+     respect to the number of edges that are removed. We use a simpler
+     implementation, based on singly-linked adjacency lists, with deferred
+     removal of edges. It achieves the same complexity bounds, except
+     [predecessors] only offers an amortized complexity bound. This is good
+     enough for our purposes, and, in practice, is more efficient by a
+     constant factor. This simplification was suggested by Arthur
+     Charguéraud. *)
+
+  type 'data node = {
+
+    (* The client information associated with this node. *)
+
+    data: 'data;
+
+    (* This node's incoming and outgoing edges. *)
+
+    mutable outgoing: 'data edge list;
+    mutable incoming: 'data edge list;
+
+    (* A transient mark, always set to [false], except when checking
+       against duplicate elements in a successor list. *)
+
+    mutable marked: bool;
+
+  }
+
+  and 'data edge = {
+
+    (* This edge's nodes. Edges are symmetric: source and destination
+       are not distinguished. Thus, an edge appears both in the outgoing
+       edge list of its source node and in the incoming edge list of its
+       destination node. This allows edges to be easily marked as
+       destroyed. *)
+
+    node1: 'data node;
+    node2: 'data node;
+
+    (* Edges that are destroyed are marked as such, but are not
+       immediately removed from the adjacency lists. *)
+
+    mutable destroyed: bool;
+
+  }
+
+  let create (data : 'data) : 'data node = {
+    data = data;
+    outgoing = [];
+    incoming = [];
+    marked = false;
+  }
+
+  let data (node : 'data node) : 'data =
+    node.data
+
+  (* [follow src edge] returns the node that is connected to [src]
+     by [edge]. Time complexity: constant. *)
+
+  let follow src edge =
+    if edge.node1 == src then
+      edge.node2
+    else begin
+      assert (edge.node2 == src);
+      edge.node1
+    end
+
+  (* The [predecessors] function removes edges that have been marked
+     destroyed. The cost of removing these has already been paid for,
+     so the amortized time complexity of [predecessors] is linear in
+     the length of the output list. *)
+
+  let predecessors (node : 'data node) : 'data node list =
+    let predecessors = List.filter (fun edge -> not edge.destroyed) node.incoming in
+    node.incoming <- predecessors;
+    List.map (follow node) predecessors
+
+  (* [link src dst] creates a new edge from [src] to [dst], together
+     with its reverse edge. Time complexity: constant. *)
+
+  let link (src : 'data node) (dst : 'data node) : unit =
+    let edge = {
+      node1 = src;
+      node2 = dst;
+      destroyed = false;
+    } in
+    src.outgoing <- edge :: src.outgoing;
+    dst.incoming <- edge :: dst.incoming
+
+  let set_successors (src : 'data node) (dsts : 'data node list) : unit =
+    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
+    in
+    loop dsts
+
+  let clear_successors (node : 'data node) : unit =
+    List.iter (fun edge ->
+      assert (not edge.destroyed);
+      edge.destroyed <- true;
+    ) node.outgoing;
+    node.outgoing <- []
+
+end
+
+(* -------------------------------------------------------------------------- *)
+
+(* The code is parametric in an implementation of maps over variables and in
+   an implementation of properties. *)
+
+module Make
+  (M : IMPERATIVE_MAPS)
+  (P : PROPERTY)
+= struct
+
+type variable =
+    M.key
+
+type property =
+    P.property
+
+type valuation =
+    variable -> property
+
+type rhs =
+    valuation -> property
+
+type equations =
+    variable -> rhs
+
+(* -------------------------------------------------------------------------- *)
+
+(* Data. *)
+
+(* Each node in the dependency graph carries information about a fixed
+   variable [v]. *)
+
+type node =
+    data Graph.node
+
+and data = {
+
+  (* This is the result of the application of [rhs] to the variable [v]. It
+     must be stored in order to guarantee that this application is performed
+     at most once. *)
+  rhs: rhs;
+
+  (* This is the current property at [v]. It evolves monotonically with
+     time. *)
+  mutable property: property;
+
+  (* That's it! *)
+}
+
+(* [property node] returns the current property at [node]. *)
+
+let property node =
+  (Graph.data node).property
+
+(* -------------------------------------------------------------------------- *)
+
+(* Many definitions must be made within the body of the function [lfp].
+   For greater syntactic convenience, we place them in a local module. *)
+
+let lfp (eqs : equations) : valuation =
+  let module LFP = struct
+
+(* -------------------------------------------------------------------------- *)
+
+(* The workset. *)
+
+(* When the algorithm is inactive, the workset is empty. *)
+
+(* Our workset is based on a Queue, but it could just as well be based on a
+   Stack. A textual replacement is possible. It could also be based on a
+   priority queue, provided a sensible way of assigning priorities could
+   be found. *)
+
+module Workset : sig
+
+  (* [insert node] inserts [node] into the workset. [node] must have no
+     successors. *)
+  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
+     [insert]. *)
+  val repeat: (node -> unit) -> unit
+
+  (* That's it! *)
+end
+= struct
+
+  (* Initialize the workset. *)
+
+  let workset =
+    Queue.create()
+
+  let insert node =
+    Queue.push node workset
+
+  let repeat f =
+    while not (Queue.is_empty workset) do
+      f (Queue.pop workset)
+    done
+
+end
+
+(* -------------------------------------------------------------------------- *)
+
+(* Signals. *)
+
+(* A node in the workset has no successors. (It can have predecessors.)  In
+   other words, a predecessor (an observer) of some node is never in the
+   workset. Furthermore, a node never appears twice in the workset. *)
+
+(* When a variable broadcasts a signal, all of its predecessors (observers)
+   receive the signal. Any variable that receives the signal loses all of its
+   successors (that is, it ceases to observe anything) and is inserted into
+   the workset. This preserves the above invariant. *)
+
+let signal subject =
+  List.iter (fun observer ->
+    Graph.clear_successors observer;
+    Workset.insert observer
+  ) (Graph.predecessors subject)
+  (* At this point, [subject] has no predecessors. This plays no role in
+     the correctness proof, though. *)
+
+(* -------------------------------------------------------------------------- *)
+
+(* Tables. *)
+
+(* The permanent table maps variables that have reached a fixed point
+   to properties. It persists forever. *)
+
+let permanent : property M.t =
+  M.create()
+
+(* The transient table maps variables that have not yet reached a
+   fixed point to nodes. (A node contains not only a property, but
+   also a memoized right-hand side, and carries edges.) At the
+   beginning of a run, it is empty. It fills up during a run. At the
+   end of a run, it is copied into the permanent table and cleared. *)
+
+let transient : node M.t =
+  M.create()
+
+(* [freeze()] copies the transient table into the permanent table, and
+   empties the transient table. This allows all nodes to be reclaimed
+   by the garbage collector. *)
+
+let freeze () =
+  M.iter (fun v node ->
+    M.add v (property node) permanent
+  ) transient;
+  M.clear transient
+
+(* -------------------------------------------------------------------------- *)
+
+(* Workset processing. *)
+
+
+(* [solve node] re-evaluates the right-hand side at [node]. If this leads to
+   a change, then the current property is updated, and [node] emits a signal
+   towards its observers. *)
+
+(* When [solve node] is invoked, [node] has no subjects. Indeed, when [solve]
+   is invoked by [node_for], [node] is newly created; when [solve] is invoked by
+   [Workset.repeat], [node] has just been extracted out of the workset, and a
+   node in the workset has no subjects. *)
+
+(* [node] must not be in the workset. *)
+
+(* In short, when [solve node] is invoked, [node] is neither awake nor asleep.
+   When [solve node] finishes, [node] is either awake or asleep again. (Chances
+   are, it is asleep, unless it is its own observer; then, it is awakened by the
+   final call to [signal node].) *)
+
+let rec solve (node : node) : unit =
+
+  (* Retrieve the data record carried by this node. *)
+  let data = Graph.data node in
+
+  (* Prepare to compute an updated value at this node. This is done by
+     invoking the client's right-hand side function.  *)
+
+  (* The flag [alive] is used to prevent the client from invoking [request]
+     after this interaction phase is over. In theory, this dynamic check seems
+     required in order to argue that [request] behaves like a pure function.
+     In practice, this check is not very useful: only a bizarre client would
+     store a [request] function and invoke it after it has become stale. *)
+  let alive = ref true
+  and subjects = ref [] in
+
+  (* We supply the client with [request], a function that provides access to
+     the current valuation, and dynamically records dependencies. This yields
+     a set of dependencies that is correct by construction. *)
+  let request (v : variable) : property =
+    assert !alive;
+    try
+      M.find v permanent
+    with Not_found ->
+      let subject = node_for v in
+      let p = property subject in
+      if not (P.is_maximal p) then
+        subjects := subject :: !subjects;
+      p
+  in
+
+  (* Give control to the client. *)
+  let new_property = data.rhs request in
+
+  (* From now on, prevent any invocation of this instance of [request]
+     the client. *)
+  alive := false;
+
+  (* At this point, [node] has no subjects, as noted above. Thus, the
+     precondition of [set_successors] is met. We can install [data.subjects]
+     as the new set of subjects for this node. *)
+
+  (* If we have gathered no subjects in the list [data.subjects], then
+     this node must have stabilized. If [new_property] is maximal,
+     then this node must have stabilized. *)
+
+  (* If this node has stabilized, then it need not observe any more, so the
+     call to [set_successors] is skipped. In practice, this seems to be a
+     minor optimization. In the particular case where every node stabilizes at
+     the very first call to [rhs], this means that no edges are ever
+     built. This particular case is unlikely, as it means that we are just
+     doing memoization, not a true fixed point computation. *)
+
+  (* One could go further and note that, if this node has stabilized, then it
+     could immediately be taken out of the transient table and copied into the
+     permanent table. This would have the beneficial effect of allowing the
+     detection of further nodes that have stabilized. Furthermore, it would
+     enforce the property that no node in the transient table has a maximal
+     value, hence the call to [is_maximal] above would become useless. *)
+
+  if not (!subjects = [] || P.is_maximal new_property) then
+    Graph.set_successors node !subjects;
+
+  (* If the updated value differs from the previous value, record
+     the updated value and send a signal to all observers of [node]. *)
+  if not (P.equal data.property new_property) then begin
+    data.property <- new_property;
+    signal node
+  end
+  (* Note that equality of the two values does not imply that this node has
+     stabilized forever. *)
+
+(* -------------------------------------------------------------------------- *)
+
+(* [node_for v] returns the graph node associated with the variable [v]. It is
+   assumed that [v] does not appear in the permanent table. If [v] appears in
+   the transient table, the associated node is returned. Otherwise, [v] is a
+   newly discovered variable: a new node is created on the fly, and the
+   transient table is grown. The new node can either be inserted into the
+   workset (it is then awake) or handled immediately via a recursive call to
+   [solve] (it is then asleep, unless it observes itself). *)
+
+(* The recursive call to [solve node] can be replaced, if desired, by a call
+   to [Workset.insert node]. Using a recursive call to [solve] permits eager
+   top-down discovery of new nodes. This can save a constant factor, because
+   it allows new nodes to move directly from [bottom] to a good first
+   approximation, without sending any signals, since [node] has no observers
+   when [solve node] is invoked. In fact, if the dependency graph is acyclic,
+   the algorithm discovers nodes top-down, performs computation on the way
+   back up, and runs without ever inserting a node into the workset!
+   Unfortunately, this causes the stack to grow as deep as the longest path in
+   the dependency graph, which can blow up the stack. *)
+
+and node_for (v : variable) : node =
+  try
+    M.find v transient
+  with Not_found ->
+    let node = Graph.create { rhs = eqs v; property = P.bottom } in
+    (* Adding this node to the transient table prior to calling [solve]
+       recursively is mandatory, otherwise [solve] might loop, creating
+       an infinite number of nodes for the same variable. *)
+    M.add v node transient;
+    solve node; (* or: Workset.insert node *)
+    node
+
+(* -------------------------------------------------------------------------- *)
+
+(* Invocations of [get] trigger the fixed point computation. *)
+
+(* The flag [inactive] prevents reentrant calls by the client. *)
+
+let inactive =
+  ref true
+
+let get (v : variable) : property =
+  try
+    M.find v permanent
+  with Not_found ->
+    assert !inactive;
+    inactive := false;
+    let node = node_for v in
+    Workset.repeat solve;
+    freeze();
+    inactive := true;
+    property node
+
+(* -------------------------------------------------------------------------- *)
+
+(* Close the local module [LFP]. *)
+
+end
+in LFP.get
+
+end
diff --git a/src/ocaml/preprocess/recover/fix.mli b/src/ocaml/preprocess/recover/fix.mli
new file mode 100644
index 0000000..6e3fb38
--- /dev/null
+++ b/src/ocaml/preprocess/recover/fix.mli
@@ -0,0 +1,97 @@
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU General Public License version 2, as described in the    *)
+(*  file LICENSE.                                                             *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* This code is described in the paper ``Lazy Least Fixed Points in ML''. *)
+
+(* -------------------------------------------------------------------------- *)
+
+(* Maps. *)
+
+(* We require imperative maps, that is, maps that can be updated in place.
+   An implementation of persistent maps, such as the one offered by ocaml's
+   standard library, can easily be turned into an implementation of imperative
+   maps, so this is a weak requirement. *)
+
+module type IMPERATIVE_MAPS = sig
+  type key
+  type 'data t
+  val create: unit -> 'data t
+  val clear: 'data t -> unit
+  val add: key -> 'data -> 'data t -> unit
+  val find: key -> 'data t -> 'data
+  val iter: (key -> 'data -> unit) -> 'data t -> unit
+end
+
+(* -------------------------------------------------------------------------- *)
+
+(* Properties. *)
+
+(* Properties must form a partial order, equipped with a least element, and
+   must satisfy the ascending chain condition: every monotone sequence
+   eventually stabilizes. *)
+
+(* [is_maximal] determines whether a property [p] is maximal with respect to
+   the partial order. Only a conservative check is required: in any event, it
+   is permitted for [is_maximal p] to return [false]. If [is_maximal p]
+   returns [true], then [p] must have no upper bound other than itself. In
+   particular, if properties form a lattice, then [p] must be the top
+   element. This feature, not described in the paper, enables a couple of
+   minor optimizations. *)
+
+module type PROPERTY = sig
+  type property
+  val bottom: property
+  val equal: property -> property -> bool
+  val is_maximal: property -> bool
+end
+
+(* -------------------------------------------------------------------------- *)
+
+(* The code is parametric in an implementation of maps over variables and in
+   an implementation of properties. *)
+
+module Make
+  (M : IMPERATIVE_MAPS)
+  (P : PROPERTY)
+  : sig
+    type variable = M.key
+    type property = P.property
+
+    (* A valuation is a mapping of variables to properties. *)
+    type valuation = variable -> property
+
+    (* A right-hand side, when supplied with a valuation that gives
+       meaning to its free variables, evaluates to a property. More
+       precisely, a right-hand side is a monotone function of
+       valuations to properties. *)
+    type rhs = valuation -> property
+
+    (* A system of equations is a mapping of variables to right-hand
+       sides. *)
+    type equations = variable -> rhs
+
+    (* [lfp eqs] produces the least solution of the system of monotone
+       equations [eqs]. *)
+
+    (* It is guaranteed that, for each variable [v], the application [eqs v] is
+       performed at most once (whereas the right-hand side produced by this
+       application is, in general, evaluated multiple times). This guarantee can
+       be used to perform costly pre-computation, or memory allocation, when [eqs]
+       is applied to its first argument. *)
+
+    (* When [lfp] is applied to a system of equations [eqs], it performs no
+       actual computation. It produces a valuation, [get], which represents
+       the least solution of the system of equations. The actual fixed point
+       computation takes place, on demand, when [get] is applied. *)
+    val lfp: equations -> valuation
+  end
diff --git a/src/ocaml/preprocess/recover/gSet.ml b/src/ocaml/preprocess/recover/gSet.ml
new file mode 100644
index 0000000..8a2c0c7
--- /dev/null
+++ b/src/ocaml/preprocess/recover/gSet.ml
@@ -0,0 +1,115 @@
+(******************************************************************************)
+(*                                                                            *)
+(*                                   Menhir                                   *)
+(*                                                                            *)
+(*                       François Pottier, Inria Paris                        *)
+(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
+(*                                                                            *)
+(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
+(*  terms of the GNU General Public License version 2, as described in the    *)
+(*  file LICENSE.                                                             *)
+(*                                                                            *)
+(******************************************************************************)
+
+(* This is a stripped down version of [GSet] that describes both [Patricia]
+   and [CompressedBitSet]. The full version of [GSet] is in [AlphaLib]. *)
+
+module type S = sig
+
+  (* Elements are assumed to have a natural total order. *)
+
+  type element
+
+  (* Sets. *)
+
+  type t
+
+  (* The empty set. *)
+
+  val empty: t
+
+  (* [is_empty s] tells whether [s] is the empty set. *)
+
+  val is_empty: t -> bool
+
+  (* [singleton x] returns a singleton set containing [x] as its only
+     element. *)
+
+  val singleton: element -> t
+
+  (* [is_singleton s] tests whether [s] is a singleton set. *)
+
+  val is_singleton: t -> bool
+
+  (* [cardinal s] returns the cardinal of [s]. *)
+
+  val cardinal: t -> int
+
+  (* [choose s] returns an arbitrarily chosen element of [s], if [s]
+     is nonempty, and raises [Not_found] otherwise. *)
+
+  val choose: t -> element
+
+  (* [mem x s] returns [true] if and only if [x] appears in the set
+     [s]. *)
+
+  val mem: element -> t -> bool
+
+  (* [add x s] returns a set whose elements are all elements of [s],
+     plus [x]. *)
+
+  val add: element -> t -> t
+
+  (* [remove x s] returns a set whose elements are all elements of
+     [s], except [x]. *)
+
+  val remove: element -> t -> t
+
+  (* [union s1 s2] returns the union of the sets [s1] and [s2]. *)
+
+  val union: t -> t -> t
+
+  (* [inter s t] returns the set intersection of [s] and [t], that is,
+     $s\cap t$. *)
+
+  val inter: t -> t -> t
+
+  (* [disjoint s1 s2] returns [true] if and only if the sets [s1] and
+     [s2] are disjoint, i.e. iff their intersection is empty. *)
+
+  val disjoint: t -> t -> bool
+
+  (* [iter f s] invokes [f x], in turn, for each element [x] of the
+     set [s]. Elements are presented to [f] in increasing order. *)
+
+  val iter: (element -> unit) -> t -> unit
+
+  (* [fold f s seed] invokes [f x accu], in turn, for each element [x]
+     of the set [s]. Elements are presented to [f] in increasing
+     order. The initial value of [accu] is [seed]; then, at each new
+     call, its value is the value returned by the previous invocation
+     of [f]. The value returned by [fold] is the final value of
+     [accu]. In other words, if $s = \{ x_1, x_2, \ldots, x_n \}$,
+     where $x_1 < x_2 < \ldots < x_n$, then [fold f s seed] computes
+     $([f]\,x_n\,\ldots\,([f]\,x_2\,([f]\,x_1\,[seed]))\ldots)$. *)
+
+  val fold: (element -> 'b -> 'b) -> t -> 'b -> 'b
+
+  (* [elements s] is a list of all elements in the set [s]. *)
+
+  val elements: t -> element list
+
+  (* [compare] is an ordering over sets. *)
+
+  val compare: t -> t -> int
+
+  (* [equal] implements equality over sets. *)
+
+  val equal: t -> t -> bool
+
+  (* [subset] implements the subset predicate over sets. *)
+
+  val subset: (t -> t -> bool)
+
+end
+
diff --git a/src/ocaml/preprocess/recover/gen_recover.ml b/src/ocaml/preprocess/recover/gen_recover.ml
new file mode 100644
index 0000000..2d0f14f
--- /dev/null
+++ b/src/ocaml/preprocess/recover/gen_recover.ml
@@ -0,0 +1,65 @@
+open MenhirSdk
+
+let name = ref ""
+let verbose = ref false
+
+let usage () =
+  Printf.eprintf "Usage: %s [-v] file.cmly\n"
+    Sys.argv.(0);
+  exit 1
+
+let () =
+  for i = 1 to Array.length Sys.argv - 1 do
+    if Sys.argv.(i) = "-v" then
+      verbose := true
+    else if !name = "" then
+      name := Sys.argv.(i)
+    else
+      usage ()
+  done;
+  if !name = "" then
+    usage ()
+
+module G = Cmly_read.Read (struct let filename = !name end)
+module A = Recover_attrib.Make(G)
+
+let () =
+  let open Format in
+  let ppf = Format.err_formatter in
+  if !verbose then begin
+    let open G in
+    Lr1.iter (fun (st : lr1) ->
+        fprintf ppf "\n# LR(1) state #%d\n\n" (st :> int);
+        fprintf ppf "Items:\n";
+        Print.itemset ppf (Lr0.items (Lr1.lr0 st));
+        fprintf ppf "Transitions:\n";
+        List.iter (fun (sym,(st' : lr1)) ->
+            fprintf ppf " - on %a, goto #%d\n"
+              Print.symbol sym
+              (st' :> int)
+          ) (Lr1.transitions st);
+        fprintf ppf "Reductions:\n";
+        List.iter (fun (t,ps) ->
+            let p : production = List.hd ps in
+            fprintf ppf " - on %a, reduce %d:\n  %a\n"
+              Print.terminal t
+              (p :> int) Print.production p
+          ) (Lr1.reductions st);
+      );
+    Production.iter (fun (p : production) ->
+        fprintf ppf "\n# Production p%d\n%a"
+          (p :> int) Print.production p
+      );
+  end
+
+module S = Synthesis.Make(G)(A)
+
+let () = if !verbose then S.report Format.err_formatter
+
+module R = Recovery.Make(G)(S)
+
+let () = if !verbose then R.report Format.err_formatter
+
+module E = Emitter.Make(G)(A)(S)(R)
+
+let () = E.emit Format.std_formatter
diff --git a/src/ocaml/preprocess/recover/journal.md b/src/ocaml/preprocess/recover/journal.md
new file mode 100644
index 0000000..42be4c1
--- /dev/null
+++ b/src/ocaml/preprocess/recover/journal.md
@@ -0,0 +1,54 @@
+OLD: everything below is outdated
+
+Problematic cases when detecting cycle only on item at pos = 1 
+==============================================================
+
+Here, recovery should favor second reduction, first will obviously cycle:
+
+    mod_longident   ::= mod_longident . DOT UIDENT
+                        5.            4.    3.    
+    label_longident ::= mod_longident . DOT LIDENT
+                        5.            4.    3.    
+
+However there is only one transition (on DOT), so the decision really matters
+at next state:
+
+    mod_longident   ::= mod_longident DOT . UIDENT
+                        5.            4.  3.      
+    label_longident ::= mod_longident DOT . LIDENT
+                       5.            4.  3.      
+
+Option 1:
+---------
+
+Recovery doesn't send a single symbol but a full sentence.  So from the second
+state, we might wrongly choose the first reduction, but then we will be back to
+first state where we will reduce everything in a state.
+
+Simpler algorithm, less good recovery.
+
+Option 1':
+----------
+
+(doesn't always work, currently implemented)
+Analysis on the grammar reveals that second reduction always end quicker
+(first-item cost approximation in current gen_recover.ml).
+Thus it is ok to always favor the second.
+
+It might fail because it is sometime context dependent which of the two
+reductions is the good one. (One can come up with a grammar where sometime the
+first reduction ends as quick, defeating the heuristic).
+
+Option 2:
+---------
+
+Decide non locally. In second state, compute nth predecessors, and decide
+according to nth predecessors.
+
+Long term, 2 is needed. We should work on the full LR(1) automaton where not all transition exists, analysis needed for 2 is an intermediate step.
+
+Statically detecting this problem:
+----------------------------------
+
+Since we can enumerate transition, we can statically ensure by interpreting the
+automaton that all states can be reduced in a finite number of step.
diff --git a/src/ocaml/preprocess/recover/recover_attrib.ml b/src/ocaml/preprocess/recover/recover_attrib.ml
new file mode 100644
index 0000000..beb3709
--- /dev/null
+++ b/src/ocaml/preprocess/recover/recover_attrib.ml
@@ -0,0 +1,83 @@
+open MenhirSdk
+
+module type S = sig
+  module G : Cmly_api.GRAMMAR
+
+  val cost_of_prod    : G.production -> float
+  val penalty_of_item : G.production * int -> float
+  val cost_of_symbol  : G.symbol -> float
+
+  val default_prelude     : Format.formatter -> unit
+  val default_terminal    : G.terminal -> string option
+  val default_nonterminal : G.nonterminal -> string option
+end
+
+module Make (G : Cmly_api.GRAMMAR) : S with module G = G = struct
+  module G = G
+  open G
+
+  let cost_of_attributes prj attrs =
+    List.fold_left
+      (fun total attr ->
+         if Attribute.has_label "cost" attr then
+           total +. float_of_string (Attribute.payload attr)
+         else total)
+      0. (prj attrs)
+
+  let cost_of_symbol =
+    let measure ~has_default prj attrs =
+      if List.exists (Attribute.has_label "recovery") (prj attrs) || has_default
+      then cost_of_attributes prj attrs
+      else infinity
+    in
+    let ft = Terminal.tabulate
+        (fun t ->
+           if Terminal.typ t = None
+           then measure ~has_default:true Terminal.attributes t
+           else measure ~has_default:false Terminal.attributes t)
+    in
+    let fn =
+      Nonterminal.tabulate (measure ~has_default:false Nonterminal.attributes)
+    in
+    function
+    | T t -> ft t
+    | N n -> fn n
+
+  let cost_of_prod =
+    Production.tabulate (cost_of_attributes Production.attributes)
+
+  let penalty_of_item =
+    let f = Production.tabulate @@ fun p ->
+      Array.map (cost_of_attributes (fun (_,_,a) -> a))
+        (Production.rhs p)
+    in
+    fun (p,i) ->
+      let costs = f p in
+      if i < Array.length costs then costs.(i) else cost_of_prod p
+
+  let default_prelude ppf =
+    List.iter (fun a ->
+        if Attribute.has_label "header" a || Attribute.has_label "recovery.header" a then
+          Format.fprintf ppf "%s\n" (Attribute.payload a)
+      ) Grammar.attributes
+
+  let default_printer ?(fallback="raise Not_found") attrs =
+    match List.find (Attribute.has_label "recovery") attrs with
+    | exception Not_found -> fallback
+    | attr -> Attribute.payload attr
+
+  let default_terminal t =
+    match Terminal.kind t with
+    | `REGULAR | `ERROR | `EOF ->
+        let fallback = match Terminal.typ t with
+          | None -> Some "()"
+          | Some _ -> None
+        in
+        Some (default_printer ?fallback (Terminal.attributes t))
+    | `PSEUDO -> None
+
+  let default_nonterminal n =
+    match Nonterminal.kind n with
+    | `REGULAR -> Some (default_printer (Nonterminal.attributes n))
+    | `START -> None
+end
diff --git a/src/ocaml/preprocess/recover/recover_attrib.mli b/src/ocaml/preprocess/recover/recover_attrib.mli
new file mode 100644
index 0000000..102f9a6
--- /dev/null
+++ b/src/ocaml/preprocess/recover/recover_attrib.mli
@@ -0,0 +1,15 @@
+open MenhirSdk
+
+module type S = sig
+  module G : Cmly_api.GRAMMAR
+
+  val cost_of_prod    : G.production -> float
+  val penalty_of_item : G.production * int -> float
+  val cost_of_symbol  : G.symbol -> float
+
+  val default_prelude     : Format.formatter -> unit
+  val default_terminal    : G.terminal -> string option
+  val default_nonterminal : G.nonterminal -> string option
+end
+
+module Make (G : Cmly_api.GRAMMAR) : S with module G = G
diff --git a/src/ocaml/preprocess/recover/recovery.ml b/src/ocaml/preprocess/recover/recovery.ml
new file mode 100644
index 0000000..b8be36b
--- /dev/null
+++ b/src/ocaml/preprocess/recover/recovery.ml
@@ -0,0 +1,201 @@
+open MenhirSdk
+open Cmly_api
+open Utils
+
+module type S = sig
+  module G : GRAMMAR
+
+  type item = G.lr1 * G.production * int
+  type recovery = G.lr1 -> int * (G.lr1 option * item list) list
+
+  val recover : recovery
+  val report : Format.formatter -> unit
+end
+
+module Make (G : GRAMMAR)
+    (S : Synthesis.S with module G = G) : S with module G = G = struct
+  module G = G
+  open G
+
+  type item = lr1 * production * int
+
+  type recovery = lr1 -> int * (lr1 option * item list) list
+
+(*
+  let item_to_string (st, prod, p) =
+    Printf.sprintf "(#%d, p%d, %d)" (Lr1.to_int st) (Production.to_int prod) p
+*)
+
+  type trace = Trace of float * item list
+
+  module Trace = struct
+    type t = trace
+    let min = arg_min_float (fun (Trace (c,_)) -> c)
+
+    let cat (Trace (c1, tr1)) (Trace (c2, tr2)) =
+      Trace (c1 +. c2, tr1 @ tr2)
+
+(*
+    let to_string (Trace (c1, tr)) =
+      Printf.sprintf "Trace (%f, %s)"
+        c1 (list_fmt item_to_string tr)
+*)
+  end
+
+  module State = struct
+    type level = (nonterminal * Trace.t) list
+    type t = level list
+
+    let rec merge_level l1 l2 : level = match l1, l2 with
+      | [], l -> l
+      | l, [] -> l
+      | ((nt1, c1) :: xs1), (x2 :: xs2) ->
+          let (nt2, c2) = x2 in
+          match compare nt1 nt2 with
+          | 0 ->
+              let x = (nt1, Trace.min c1 c2) in
+              x :: merge_level xs1 xs2
+          | n when n > 0 -> x2 :: merge_level l1 xs2
+          | _ -> (nt1, c1) :: merge_level xs1 l2
+
+    let rec merge l1 l2 : t = match l1, l2 with
+      | [], l -> l
+      | l, [] -> l
+      | (x1 :: l1), (x2 :: l2) ->
+          let x' = merge_level x1 x2 in
+          x' :: merge l1 l2
+
+(*
+    let reduction_to_string (n, tr) =
+      Printf.sprintf "(%s, %s)" (Nonterminal.name n) (Trace.to_string tr)
+
+    let to_string (t : t) = list_fmt (list_fmt reduction_to_string) t
+*)
+  end
+
+  let synthesize =
+    let rec add_nt tr nt = function
+      | [] -> [(nt, tr)]
+      | x :: xs ->
+          let c = compare nt (fst x) in
+          if c = 0 then (nt, Trace.min tr (snd x)) :: xs
+          else if c < 0 then
+            (nt, tr) :: xs
+          else
+            x :: add_nt tr nt xs
+    in
+    let add_item cost item stack =
+      let (_, prod, pos) = item in
+      if cost = infinity then stack
+      else
+        let stack_hd = function
+          | [] -> []
+          | x :: _ -> x
+        and stack_tl = function
+          | [] -> []
+          | _ :: xs -> xs
+        in
+        let rec aux stack = function
+          | 0 -> add_nt (Trace (cost, [item])) (Production.lhs prod)
+                   (stack_hd stack) :: stack_tl stack
+          | n -> stack_hd stack :: aux (stack_tl stack) (n - 1)
+        in
+        aux stack pos
+    in
+    Lr1.tabulate (fun st ->
+        List.fold_left (fun acc (prod, pos) ->
+            if pos = 0 then (
+              (*if prod.p_kind = `START then ( *)
+              (* pos = 0 means we are on an initial state *)
+              (*report "skipping %s at depth %d\n" prod.p_lhs.n_name pos;*)
+              acc
+            ) else (
+              (*report "adding %s at depth %d\n" prod.p_lhs.n_name pos;*)
+              add_item
+                (S.cost_of (S.Tail (st, prod, pos)))
+                (st, prod, pos) acc
+            )
+          )
+          [] (Lr0.items (Lr1.lr0 st))
+      )
+
+  let step st ntss =
+    let seen = ref CompressedBitSet.empty in
+    let rec aux = function
+      | [] -> []
+      | ((nt, tr) :: x) :: xs
+        when not (CompressedBitSet.mem (Nonterminal.to_int nt) !seen) &&
+             not (Nonterminal.kind nt = `START) ->
+          seen := CompressedBitSet.add (Nonterminal.to_int nt) !seen;
+          let st' = List.assoc (N nt) (Lr1.transitions st) in
+          let xs' = synthesize st' in
+          let xs' = match xs' with
+            | [] -> []
+            | _ :: xs -> xs
+          in
+          let merge_trace (nt,tr') = (nt, Trace.cat tr' tr) in
+          let xs' = List.map (List.map merge_trace) xs' in
+          aux (State.merge xs' (x :: xs))
+      | (_ :: x) :: xs -> aux (x :: xs)
+      | [] :: xs -> xs
+    in
+    aux ntss
+
+  let init st = ((st, [st]), step st (synthesize st))
+
+  let expand ((st, sts), nts) =
+    List.map (fun st' -> ((st', st' :: sts), step st' nts)) (S.pred st)
+
+  let recover st =
+    (* How big is the known prefix of the stack *)
+    let pos =
+      let items = Lr0.items (Lr1.lr0 st) in
+      List.fold_left (fun pos (_, pos') -> max pos pos')
+        (snd (List.hd items)) (List.tl items)
+    in
+    (* Walk this prefix *)
+    let traces =
+      let acc = ref [init st] in
+      for _i = 1 to pos - 1 do
+        acc := List.concat (List.map expand !acc)
+      done;
+      !acc
+    in
+    (* Last step *)
+    let select_trace traces =
+      (* Pick a trace with minimal cost, somewhat arbitrary *)
+      match List.flatten traces with
+      | [] ->
+        (* FIXME: for release, empty list means recovery not possible
+           (not enough annotations) *)
+        assert false
+      | (_, trace) :: alternatives ->
+          List.fold_left
+            (fun tr1 (_,tr2) -> Trace.min tr1 tr2)
+            trace alternatives
+    in
+    let process_trace trace =
+      match expand trace with
+      | [] -> (* Initial state *)
+          assert (snd trace = []); []
+      | states ->
+          let select_expansion ((st, _sts), trace') =
+            if trace' = [] then
+              (* Reached stack bottom *)
+              (None, select_trace (snd trace))
+            else
+              (Some st, select_trace trace')
+          in
+          List.map select_expansion states
+    in
+    pos,
+    List.flatten @@ List.map (fun trace ->
+        List.map
+          (fun (st, Trace (_, reductions)) -> st, reductions)
+          (process_trace trace)
+      ) traces
+
+  let recover = Lr1.tabulate recover
+
+  let report _ppf = ()
+end
diff --git a/src/ocaml/preprocess/recover/recovery.mli b/src/ocaml/preprocess/recover/recovery.mli
new file mode 100644
index 0000000..412b6d0
--- /dev/null
+++ b/src/ocaml/preprocess/recover/recovery.mli
@@ -0,0 +1,12 @@
+open MenhirSdk.Cmly_api
+module type S = sig
+  module G : GRAMMAR
+
+  type item = G.lr1 * G.production * int
+  type recovery = G.lr1 -> int * (G.lr1 option * item list) list
+
+  val recover : recovery
+  val report : Format.formatter -> unit
+end
+
+module Make (G : GRAMMAR) (S : Synthesis.S with module G = G) : S with module G = G
diff --git a/src/ocaml/preprocess/recover/synthesis.ml b/src/ocaml/preprocess/recover/synthesis.ml
new file mode 100644
index 0000000..70f6f6d
--- /dev/null
+++ b/src/ocaml/preprocess/recover/synthesis.ml
@@ -0,0 +1,261 @@
+open MenhirSdk.Cmly_api
+open Utils
+
+module type S = sig
+  module G : GRAMMAR
+
+  type variable =
+    | Head of G.lr1 * G.nonterminal
+    | Tail of G.lr1 * G.production * int
+
+  val variable_to_string : variable -> string
+
+  type 'a paction =
+    | Abort
+    | Reduce of G.production
+    | Shift  of G.symbol
+    | Var    of 'a
+
+  val paction_to_string : ('a -> string) -> 'a paction -> string
+
+  type action = variable paction
+
+  val action_to_string : action -> string
+
+  val pred : G.lr1 -> G.lr1 list
+
+  val cost_of  : variable -> float
+  val cost_of_action  : action -> float
+  val cost_of_actions : action list -> float
+  val solution : variable -> action list
+  val report   : Format.formatter -> unit
+end
+
+module Make (G : GRAMMAR) (A : Recover_attrib.S with module G = G)
+  : S with module G = G =
+struct
+  module G = G
+  open G
+
+  let pred =
+    (* Compute lr1 predecessor relation *)
+    let tbl1 = Array.make Lr1.count [] in
+    let revert_transition s1 (sym,s2) =
+      assert (match Lr0.incoming (Lr1.lr0 s2) with
+          | None -> false
+          | Some sym' -> sym = sym');
+      tbl1.(Lr1.to_int s2) <- s1 :: tbl1.(Lr1.to_int s2)
+    in
+    Lr1.iter
+      (fun lr1 -> List.iter (revert_transition lr1) (Lr1.transitions lr1));
+    (fun lr1 -> tbl1.(Lr1.to_int lr1))
+
+  type variable =
+    | Head of lr1 * nonterminal
+    | Tail of lr1 * production * int
+
+  let variable_to_string = function
+    | Head (st, n) ->
+        Printf.sprintf "Head (#%d, %s)"
+          (Lr1.to_int st) (Nonterminal.name n)
+    | Tail (st, prod, pos) ->
+        Printf.sprintf "Tail (#%d, p%d, %d)"
+          (Lr1.to_int st) (Production.to_int prod) pos
+
+  type 'a paction =
+    | Abort
+    | Reduce of production
+    | Shift  of symbol
+    | Var    of 'a
+
+  let paction_to_string variable_to_string = function
+    | Abort -> "Abort"
+    | Reduce prod -> "Reduce p" ^ string_of_int (Production.to_int prod)
+    | Shift  sym -> "Shift " ^ (symbol_name sym)
+    | Var v -> "Var (" ^ variable_to_string v ^ ")"
+
+  type action = variable paction
+
+  let action_to_string = paction_to_string variable_to_string
+
+  let check_cost r =
+    assert (r >= 0.); r
+
+  let cost_of_prod p    = check_cost (1. +. A.cost_of_prod p)
+  let cost_of_symbol s  = check_cost (1. +. A.cost_of_symbol s)
+  let penalty_of_item i = check_cost (A.penalty_of_item i)
+
+  let app var v = v var
+
+  let var var = match var with
+    | Head _ -> app var
+    | Tail (_,prod,pos) ->
+        if pos < Array.length (Production.rhs prod) then
+          app var
+        else
+          let cost = cost_of_prod prod in
+          const cost
+
+(*
+  let can_pop prod pos =
+    pos > 1 &&
+    (match (Production.rhs prod).(pos - 1) with
+     | T t, _, _ -> Terminal.typ t = None
+     | _ -> false)
+*)
+
+  let cost_of = function
+    | Head (st, n) ->
+        let acc = List.fold_left
+            (fun acc (_sym, st') ->
+               List.fold_left (fun acc (prod, pos) ->
+                   if pos = 1 && Production.lhs prod = n then
+                     var (Tail (st, prod, 0)) :: acc
+                   else acc
+                 ) acc (Lr0.items (Lr1.lr0 st'))
+            ) [] (Lr1.transitions st)
+        in
+        let cost = List.fold_left
+            (fun acc (_, prods) ->
+               List.fold_left (fun acc prod ->
+                   if Production.rhs prod = [||] && Production.lhs prod = n then
+                     min_float (cost_of_prod prod) acc
+                   else acc
+                 ) acc prods
+            ) infinity (Lr1.reductions st)
+        in
+        if cost < infinity || acc <> [] then
+          (fun v -> List.fold_left (fun cost f -> min_float cost (f v)) cost acc)
+        else const infinity
+
+    | Tail (st, prod, pos) ->
+        let penalty = penalty_of_item (prod, pos) in
+        if penalty = infinity then
+          const infinity
+        else
+        if pos >= Array.length (Production.rhs prod) then
+          const (cost_of_prod prod)
+        else
+          let head =
+            let sym, _, _ = (Production.rhs prod).(pos) in
+            let cost = cost_of_symbol sym in
+            if cost < infinity then const cost
+            else match sym with
+              | T _ -> const infinity
+              | N n -> var (Head (st, n))
+          in
+          let tail =
+            let sym, _, _ = (Production.rhs prod).(pos) in
+            match List.assoc sym (Lr1.transitions st) with
+            | st' -> var (Tail (st', prod, pos + 1))
+            | exception Not_found ->
+                (*report "no transition: #%d (%d,%d)\n" st.lr1_index prod.p_index pos;*)
+                const infinity
+          in
+          (fun v -> head v +. tail v)
+
+  let cost_of =
+    let module Solver = Fix.Make (struct
+        type key = variable
+        type 'a t = (key, 'a) Hashtbl.t
+        let create () = Hashtbl.create 7
+        let find k tbl = Hashtbl.find tbl k
+        let add k v tbl = Hashtbl.add tbl k v
+        let iter f tbl = Hashtbl.iter f tbl
+        let clear = Hashtbl.clear
+      end) (struct
+        type property = float
+        let bottom = infinity
+        let equal : float -> float -> bool = (=)
+        let is_maximal f = f = 0.0
+      end)
+    in
+    Solver.lfp cost_of
+
+  let cost_of_action = function
+    | Abort    -> infinity
+    | Reduce p -> cost_of_prod p
+    | Shift s  -> cost_of_symbol s
+    | Var v    -> cost_of v
+
+  let select var1 var2 =
+    arg_min_float cost_of_action var1 var2
+
+  let cost_of_actions actions =
+    List.fold_left (fun cost act -> cost +. cost_of_action act) 0.0 actions
+
+  let solution = function
+    | Head (st, n) ->
+        let acc = Abort in
+        let acc = List.fold_left
+            (fun acc (_sym, st') ->
+               List.fold_left (fun acc (prod, pos) ->
+                   if pos = 1 && Production.lhs prod = n then
+                     select (Var (Tail (st, prod, 0))) acc
+                   else acc
+                 ) acc (Lr0.items (Lr1.lr0 st'))
+            ) acc (Lr1.transitions st)
+        in
+        let acc = List.fold_left
+            (fun acc (_, prods) ->
+               List.fold_left (fun acc prod ->
+                   if Production.rhs prod = [||] && Production.lhs prod = n then
+                     select (Reduce prod) acc
+                   else acc
+                 ) acc prods
+            ) acc (Lr1.reductions st)
+        in
+        [acc]
+
+    | Tail (_st, prod, pos) when pos = Array.length (Production.rhs prod) ->
+        [Reduce prod]
+
+    | Tail (st, prod, pos) ->
+        let penalty = penalty_of_item (prod, pos) in
+        if penalty = infinity then
+          [Abort]
+        else
+          let head =
+            let sym, _, _ = (Production.rhs prod).(pos) in
+            let cost = cost_of_symbol sym in
+            if cost < infinity then
+              Shift sym
+            else match sym with
+              | T _ -> Abort
+              | N n -> Var (Head (st, n))
+          in
+          let tail =
+            let sym, _, _ = (Production.rhs prod).(pos) in
+            match List.assoc sym (Lr1.transitions st) with
+            | st' -> Var (Tail (st', prod, pos + 1))
+            | exception Not_found ->
+                Abort
+          in
+          [head; tail]
+
+  let report ppf =
+    let open Format in
+    let solutions = Lr1.fold
+        (fun st acc ->
+          match List.fold_left (fun (item, cost) (prod, pos) ->
+              let cost' = cost_of (Tail (st, prod, pos)) in
+              let actions = solution (Tail (st, prod, pos)) in
+              assert (cost' = cost_of_actions actions);
+              if cost' < cost then (Some (prod, pos), cost') else (item, cost)
+            ) (None, infinity) (Lr0.items (Lr1.lr0 st))
+          with
+          | None, _ ->
+              fprintf ppf "no synthesis from %d\n" (Lr1.to_int st);
+              acc
+          | Some item, cost -> (item, (cost, st)) :: acc
+        ) []
+    in
+    List.iter (fun (item, states) ->
+        fprintf ppf "# Item (%d,%d)\n" (Production.to_int (fst item)) (snd item);
+        Print.item ppf item;
+        List.iter (fun (cost, states) ->
+            fprintf ppf "at cost %f from states %s\n\n"
+              cost (list_fmt (fun x -> string_of_int (Lr1.to_int x)) states)
+          ) (group_assoc states)
+      ) (group_assoc solutions)
+end
diff --git a/src/ocaml/preprocess/recover/synthesis.mli b/src/ocaml/preprocess/recover/synthesis.mli
new file mode 100644
index 0000000..5836150
--- /dev/null
+++ b/src/ocaml/preprocess/recover/synthesis.mli
@@ -0,0 +1,33 @@
+open MenhirSdk.Cmly_api
+
+module type S = sig
+  module G : GRAMMAR
+
+  type variable =
+    | Head of G.lr1 * G.nonterminal
+    | Tail of G.lr1 * G.production * int
+
+  val variable_to_string : variable -> string
+
+  type 'a paction =
+    | Abort
+    | Reduce of G.production
+    | Shift  of G.symbol
+    | Var    of 'a
+
+  val paction_to_string : ('a -> string) -> 'a paction -> string
+
+  type action = variable paction
+
+  val action_to_string : action -> string
+
+  val pred : G.lr1 -> G.lr1 list
+
+  val cost_of  : variable -> float
+  val cost_of_action  : action -> float
+  val cost_of_actions : action list -> float
+  val solution : variable -> action list
+  val report   : Format.formatter -> unit
+end
+
+module Make (G : GRAMMAR) (A : Recover_attrib.S with module G = G) : S with module G = G
diff --git a/src/ocaml/preprocess/recover/utils.ml b/src/ocaml/preprocess/recover/utils.ml
new file mode 100644
index 0000000..0492312
--- /dev/null
+++ b/src/ocaml/preprocess/recover/utils.ml
@@ -0,0 +1,59 @@
+let const c = fun _ -> c
+
+let group_assoc l =
+  let cons k v acc = (k, List.rev v) :: acc in
+  let rec aux k v vs acc = function
+    | [] -> List.rev (cons k (v :: vs) acc)
+    | (k', v') :: xs when compare k k' = 0 ->
+      if compare v v' = 0 then
+        aux k v vs acc xs
+      else
+        aux k v' (v :: vs) acc xs
+    | (k', v') :: xs ->
+      aux k' v' [] (cons k (v :: vs) acc) xs
+  in
+  match List.sort compare l with
+  | [] -> []
+  | (k, v) :: xs -> aux k v [] [] xs
+
+(* negation to put nan as the max *)
+let compare_float a b = - compare (-.a) (-.b)
+
+let min_float a b =
+  if compare_float a b > 0 then b else a
+
+let arg_min_float f a b =
+  if compare_float (f a) (f b) <= 0 then a else b
+
+exception Found of int
+let array_exists arr f =
+  try
+    for i = 0 to Array.length arr - 1 do
+      if f arr.(i) then raise (Found i);
+    done;
+    false
+  with Found _ -> true
+
+let array_findi arr f =
+  match
+    for i = 0 to Array.length arr - 1 do
+      if f arr.(i) then raise (Found i);
+    done
+  with () -> raise Not_found
+     | exception (Found i) -> i
+
+let array_find arr f =
+  arr.(array_findi arr f)
+
+let array_assoc arr x =
+  snd (array_find arr (fun (x',_) -> compare x x' = 0))
+
+let list_fmt f l =
+  "[" ^ String.concat "; " (List.map f l) ^ "]"
+
+let fst3 (x,_,_) = x
+
+let rec list_last = function
+  | [x] -> x
+  | _ :: xs -> list_last xs
+  | [] -> invalid_arg "list_last"
diff --git a/src/ocaml/typing/annot.mli b/src/ocaml/typing/annot.mli
new file mode 100644
index 0000000..3cae8f2
--- /dev/null
+++ b/src/ocaml/typing/annot.mli
@@ -0,0 +1,24 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Data types for annotations (Stypes.ml) *)
+
+type call = Tail | Stack | Inline;;
+
+type ident =
+  | Iref_internal of Location.t (* defining occurrence *)
+  | Iref_external
+  | Idef of Location.t          (* scope *)
+;;
diff --git a/src/ocaml/typing/btype.ml b/src/ocaml/typing/btype.ml
new file mode 100644
index 0000000..5c5830c
--- /dev/null
+++ b/src/ocaml/typing/btype.ml
@@ -0,0 +1,848 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Basic operations on core types *)
+
+open Asttypes
+open Types
+
+open Local_store
+
+(**** Sets, maps and hashtables of types ****)
+
+module TypeSet = Set.Make(TypeOps)
+module TypeMap = Map.Make (TypeOps)
+module TypeHash = Hashtbl.Make(TypeOps)
+
+(**** Forward declarations ****)
+
+let print_raw =
+  ref (fun _ -> assert false : Format.formatter -> type_expr -> unit)
+
+(**** Type level management ****)
+
+let generic_level = Ident.highest_scope
+
+(* Used to mark a type during a traversal. *)
+let lowest_level = Ident.lowest_scope
+let pivot_level = 2 * lowest_level - 1
+    (* pivot_level - lowest_level < lowest_level *)
+
+(**** Some type creators ****)
+
+let new_id = s_ref (-1)
+
+let newty2 level desc  =
+  incr new_id;
+  Private_type_expr.create desc ~level ~scope:lowest_level ~id:!new_id
+let newgenty desc      = newty2 generic_level desc
+let newgenvar ?name () = newgenty (Tvar name)
+(*
+let newmarkedvar level =
+  incr new_id; { desc = Tvar; level = pivot_level - level; id = !new_id }
+let newmarkedgenvar () =
+  incr new_id;
+  { desc = Tvar; level = pivot_level - generic_level; id = !new_id }
+*)
+
+(**** Check some types ****)
+
+let is_Tvar = function {desc=Tvar _} -> true | _ -> false
+let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false
+let is_Tconstr = function {desc=Tconstr _} -> true | _ -> false
+
+let dummy_method = "*dummy method*"
+
+(**** Definitions for backtracking ****)
+
+type change =
+    Ctype of type_expr * type_desc
+  | Ccompress of type_expr * type_desc * type_desc
+  | Clevel of type_expr * int
+  | Cscope of type_expr * int
+  | Cname of
+      (Path.t * type_expr list) option ref * (Path.t * type_expr list) option
+  | Crow of row_field option ref * row_field option
+  | Ckind of field_kind option ref * field_kind option
+  | Ccommu of commutable ref * commutable
+  | Cuniv of type_expr option ref * type_expr option
+  | Cfun of (unit -> unit)
+
+type changes =
+    Change of change * changes ref
+  | Unchanged
+  | Invalid
+
+open Local_store
+
+let trail = s_table ref Unchanged
+
+let log_change ch =
+  let r' = ref Unchanged in
+  !trail := Change (ch, r');
+  trail := r'
+
+(**** Representative of a type ****)
+
+let rec field_kind_repr =
+  function
+    Fvar {contents = Some kind} -> field_kind_repr kind
+  | kind                        -> kind
+
+let rec repr_link compress (t : type_expr) d : type_expr -> type_expr =
+ function
+   {desc = Tlink t' as d'} ->
+     repr_link true t d' t'
+ | {desc = Tfield (_, k, _, t') as d'} when field_kind_repr k = Fabsent ->
+     repr_link true t d' t'
+ | t' ->
+     if compress then begin
+       log_change (Ccompress (t, t.desc, d)); Private_type_expr.set_desc t d
+     end;
+     t'
+
+let repr (t : type_expr) =
+  match t.desc with
+   Tlink t' as d ->
+     repr_link false t d t'
+ | Tfield (_, k, _, t') as d when field_kind_repr k = Fabsent ->
+     repr_link false t d t'
+ | _ -> t
+
+let rec commu_repr = function
+    Clink r when !r <> Cunknown -> commu_repr !r
+  | c -> c
+
+let rec row_field_repr_aux tl = function
+    Reither(_, tl', _, {contents = Some fi}) ->
+      row_field_repr_aux (tl@tl') fi
+  | Reither(c, tl', m, r) ->
+      Reither(c, tl@tl', m, r)
+  | Rpresent (Some _) when tl <> [] ->
+      Rpresent (Some (List.hd tl))
+  | fi -> fi
+
+let row_field_repr fi = row_field_repr_aux [] fi
+
+let rec rev_concat l ll =
+  match ll with
+    [] -> l
+  | l'::ll -> rev_concat (l'@l) ll
+
+let rec row_repr_aux ll row =
+  match (repr row.row_more).desc with
+  | Tvariant row' ->
+      let f = row.row_fields in
+      row_repr_aux (if f = [] then ll else f::ll) row'
+  | _ ->
+      if ll = [] then row else
+      {row with row_fields = rev_concat row.row_fields ll}
+
+let row_repr row = row_repr_aux [] row
+
+let rec row_field tag row =
+  let rec find = function
+    | (tag',f) :: fields ->
+        if tag = tag' then row_field_repr f else find fields
+    | [] ->
+        match repr row.row_more with
+        | {desc=Tvariant row'} -> row_field tag row'
+        | _ -> Rabsent
+  in find row.row_fields
+
+let rec row_more row =
+  match repr row.row_more with
+  | {desc=Tvariant row'} -> row_more row'
+  | ty -> ty
+
+let merge_fixed_explanation fixed1 fixed2 =
+  match fixed1, fixed2 with
+  | Some Univar _ as x, _ | _, (Some Univar _ as x) -> x
+  | Some Fixed_private as x, _ | _, (Some Fixed_private as x) -> x
+  | Some Reified _ as x, _ | _, (Some Reified _ as x) -> x
+  | Some Rigid as x, _ | _, (Some Rigid as x) -> x
+  | None, None -> None
+
+
+let fixed_explanation row =
+  let row = row_repr row in
+  match row.row_fixed with
+  | Some _ as x -> x
+  | None ->
+      let more = repr row.row_more in
+      match more.desc with
+      | Tvar _ | Tnil -> None
+      | Tunivar _ -> Some (Univar more)
+      | Tconstr (p,_,_) -> Some (Reified p)
+      | _ -> assert false
+
+let is_fixed row = match row.row_fixed with
+  | None -> false
+  | Some _ -> true
+
+let row_fixed row = fixed_explanation row <> None
+
+
+let static_row row =
+  let row = row_repr row in
+  row.row_closed &&
+  List.for_all
+    (fun (_,f) -> match row_field_repr f with Reither _ -> false | _ -> true)
+    row.row_fields
+
+let hash_variant s =
+  let accu = ref 0 in
+  for i = 0 to String.length s - 1 do
+    accu := 223 * !accu + Char.code s.[i]
+  done;
+  (* reduce to 31 bits *)
+  accu := !accu land (1 lsl 31 - 1);
+  (* make it signed for 64 bits architectures *)
+  if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu
+
+let proxy ty =
+  let ty0 = repr ty in
+  match ty0.desc with
+  | Tvariant row when not (static_row row) ->
+      row_more row
+  | Tobject (ty, _) ->
+      let rec proxy_obj ty =
+        match ty.desc with
+          Tfield (_, _, _, ty) | Tlink ty -> proxy_obj ty
+        | Tvar _ | Tunivar _ | Tconstr _ -> ty
+        | Tnil -> ty0
+        | _ -> assert false
+      in proxy_obj ty
+  | _ -> ty0
+
+(**** Utilities for fixed row private types ****)
+
+let row_of_type t =
+  match (repr t).desc with
+    Tobject(t,_) ->
+      let rec get_row t =
+        let t = repr t in
+        match t.desc with
+          Tfield(_,_,_,t) -> get_row t
+        | _ -> t
+      in get_row t
+  | Tvariant row ->
+      row_more row
+  | _ ->
+      t
+
+let has_constr_row t =
+  not (is_Tconstr t) && is_Tconstr (row_of_type t)
+
+let is_row_name s =
+  let l = String.length s in
+  (* PR#10661: when l=4 and s is "#row", this is not a row name
+     but the valid #-type name of a class named "row". *)
+  l > 4 && String.sub s (l-4) 4 = "#row"
+
+let is_constr_row ~allow_ident t =
+  match t.desc with
+    Tconstr (Path.Pident id, _, _) when allow_ident ->
+      is_row_name (Ident.name id)
+  | Tconstr (Path.Pdot (_, s), _, _) -> is_row_name s
+  | _ -> false
+
+(* TODO: where should this really be *)
+(* Set row_name in Env, cf. GPR#1204/1329 *)
+let set_row_name decl path =
+  match decl.type_manifest with
+    None -> ()
+  | Some ty ->
+      let ty = repr ty in
+      match ty.desc with
+        Tvariant row when static_row row ->
+          let row = {(row_repr row) with
+                     row_name = Some (path, decl.type_params)} in
+          Private_type_expr.set_desc ty (Tvariant row)
+      | _ -> ()
+
+
+                  (**********************************)
+                  (*  Utilities for type traversal  *)
+                  (**********************************)
+
+let rec fold_row f init row =
+  let result =
+    List.fold_left
+      (fun init (_, fi) ->
+         match row_field_repr fi with
+         | Rpresent(Some ty) -> f init ty
+         | Reither(_, tl, _, _) -> List.fold_left f init tl
+         | _ -> init)
+      init
+      row.row_fields
+  in
+  match (repr row.row_more).desc with
+    Tvariant row -> fold_row f result row
+  | Tvar _ | Tunivar _ | Tsubst _ | Tconstr _ | Tnil ->
+    begin match
+      Option.map (fun (_,l) -> List.fold_left f result l) row.row_name
+    with
+    | None -> result
+    | Some result -> result
+    end
+  | _ -> assert false
+
+let iter_row f row =
+  fold_row (fun () v -> f v) () row
+
+let rec fold_type_expr f init ty =
+  match ty.desc with
+    Tvar _              -> init
+  | Tarrow (_, ty1, ty2, _) ->
+    let result = f init ty1 in
+    f result ty2
+  | Ttuple l            -> List.fold_left f init l
+  | Tconstr (_, l, _)   -> List.fold_left f init l
+  | Tobject(ty, {contents = Some (_, p)})
+    ->
+    let result = f init ty in
+    List.fold_left f result p
+  | Tobject (ty, _)     -> f init ty
+  | Tvariant row        ->
+    let result = fold_row f init row in
+    f result (row_more row)
+  | Tfield (_, _, ty1, ty2) ->
+    let result = f init ty1 in
+    f result ty2
+  | Tnil                -> init
+  | Tlink ty            -> fold_type_expr f init ty
+  | Tsubst _            -> assert false
+  | Tunivar _           -> init
+  | Tpoly (ty, tyl)     ->
+    let result = f init ty in
+    List.fold_left f result tyl
+  | Tpackage (_, fl)  ->
+    List.fold_left (fun result (_n, ty) -> f result ty) init fl
+
+let iter_type_expr f ty =
+  fold_type_expr (fun () v -> f v) () ty
+
+let rec iter_abbrev f = function
+    Mnil                   -> ()
+  | Mcons(_, _, ty, ty', rem) -> f ty; f ty'; iter_abbrev f rem
+  | Mlink rem              -> iter_abbrev f !rem
+
+type type_iterators =
+  { it_signature: type_iterators -> signature -> unit;
+    it_signature_item: type_iterators -> signature_item -> unit;
+    it_value_description: type_iterators -> value_description -> unit;
+    it_type_declaration: type_iterators -> type_declaration -> unit;
+    it_extension_constructor: type_iterators -> extension_constructor -> unit;
+    it_module_declaration: type_iterators -> module_declaration -> unit;
+    it_modtype_declaration: type_iterators -> modtype_declaration -> unit;
+    it_class_declaration: type_iterators -> class_declaration -> unit;
+    it_class_type_declaration: type_iterators -> class_type_declaration -> unit;
+    it_functor_param: type_iterators -> functor_parameter -> unit;
+    it_module_type: type_iterators -> module_type -> unit;
+    it_class_type: type_iterators -> class_type -> unit;
+    it_type_kind: type_iterators -> type_decl_kind -> unit;
+    it_do_type_expr: type_iterators -> type_expr -> unit;
+    it_type_expr: type_iterators -> type_expr -> unit;
+    it_path: Path.t -> unit; }
+
+let iter_type_expr_cstr_args f = function
+  | Cstr_tuple tl -> List.iter f tl
+  | Cstr_record lbls -> List.iter (fun d -> f d.ld_type) lbls
+
+let map_type_expr_cstr_args f = function
+  | Cstr_tuple tl -> Cstr_tuple (List.map f tl)
+  | Cstr_record lbls ->
+      Cstr_record (List.map (fun d -> {d with ld_type=f d.ld_type}) lbls)
+
+let iter_type_expr_kind f = function
+  | Type_abstract -> ()
+  | Type_variant (cstrs, _) ->
+      List.iter
+        (fun cd ->
+           iter_type_expr_cstr_args f cd.cd_args;
+           Option.iter f cd.cd_res
+        )
+        cstrs
+  | Type_record(lbls, _) ->
+      List.iter (fun d -> f d.ld_type) lbls
+  | Type_open ->
+      ()
+
+
+let type_iterators =
+  let it_signature it =
+    List.iter (it.it_signature_item it)
+  and it_signature_item it = function
+      Sig_value (_, vd, _)          -> it.it_value_description it vd
+    | Sig_type (_, td, _, _)        -> it.it_type_declaration it td
+    | Sig_typext (_, td, _, _)      -> it.it_extension_constructor it td
+    | Sig_module (_, _, md, _, _)   -> it.it_module_declaration it md
+    | Sig_modtype (_, mtd, _)       -> it.it_modtype_declaration it mtd
+    | Sig_class (_, cd, _, _)       -> it.it_class_declaration it cd
+    | Sig_class_type (_, ctd, _, _) -> it.it_class_type_declaration it ctd
+  and it_value_description it vd =
+    it.it_type_expr it vd.val_type
+  and it_type_declaration it td =
+    List.iter (it.it_type_expr it) td.type_params;
+    Option.iter (it.it_type_expr it) td.type_manifest;
+    it.it_type_kind it td.type_kind
+  and it_extension_constructor it td =
+    it.it_path td.ext_type_path;
+    List.iter (it.it_type_expr it) td.ext_type_params;
+    iter_type_expr_cstr_args (it.it_type_expr it) td.ext_args;
+    Option.iter (it.it_type_expr it) td.ext_ret_type
+  and it_module_declaration it md =
+    it.it_module_type it md.md_type
+  and it_modtype_declaration it mtd =
+    Option.iter (it.it_module_type it) mtd.mtd_type
+  and it_class_declaration it cd =
+    List.iter (it.it_type_expr it) cd.cty_params;
+    it.it_class_type it cd.cty_type;
+    Option.iter (it.it_type_expr it) cd.cty_new;
+    it.it_path cd.cty_path
+  and it_class_type_declaration it ctd =
+    List.iter (it.it_type_expr it) ctd.clty_params;
+    it.it_class_type it ctd.clty_type;
+    it.it_path ctd.clty_path
+  and it_functor_param it = function
+    | Unit -> ()
+    | Named (_, mt) -> it.it_module_type it mt
+  and it_module_type it = function
+      Mty_ident p
+    | Mty_alias p -> it.it_path p
+    | Mty_for_hole -> ()
+    | Mty_signature sg -> it.it_signature it sg
+    | Mty_functor (p, mt) ->
+        it.it_functor_param it p;
+        it.it_module_type it mt
+  and it_class_type it = function
+      Cty_constr (p, tyl, cty) ->
+        it.it_path p;
+        List.iter (it.it_type_expr it) tyl;
+        it.it_class_type it cty
+    | Cty_signature cs ->
+        it.it_type_expr it cs.csig_self;
+        Vars.iter (fun _ (_,_,ty) -> it.it_type_expr it ty) cs.csig_vars;
+        List.iter
+          (fun (p, tl) -> it.it_path p; List.iter (it.it_type_expr it) tl)
+          cs.csig_inher
+    | Cty_arrow  (_, ty, cty) ->
+        it.it_type_expr it ty;
+        it.it_class_type it cty
+  and it_type_kind it kind =
+    iter_type_expr_kind (it.it_type_expr it) kind
+  and it_do_type_expr it ty =
+    iter_type_expr (it.it_type_expr it) ty;
+    match ty.desc with
+      Tconstr (p, _, _)
+    | Tobject (_, {contents=Some (p, _)})
+    | Tpackage (p, _) ->
+        it.it_path p
+    | Tvariant row ->
+        Option.iter (fun (p,_) -> it.it_path p) (row_repr row).row_name
+    | _ -> ()
+  and it_path _p = ()
+  in
+  { it_path; it_type_expr = it_do_type_expr; it_do_type_expr;
+    it_type_kind; it_class_type; it_functor_param; it_module_type;
+    it_signature; it_class_type_declaration; it_class_declaration;
+    it_modtype_declaration; it_module_declaration; it_extension_constructor;
+    it_type_declaration; it_value_description; it_signature_item; }
+
+let copy_row f fixed row keep more =
+  let fields = List.map
+      (fun (l, fi) -> l,
+        match row_field_repr fi with
+        | Rpresent(Some ty) -> Rpresent(Some(f ty))
+        | Reither(c, tl, m, e) ->
+            let e = if keep then e else ref None in
+            let m = if is_fixed row then fixed else m in
+            let tl = List.map f tl in
+            Reither(c, tl, m, e)
+        | _ -> fi)
+      row.row_fields in
+  let name =
+    match row.row_name with
+    | None -> None
+    | Some (path, tl) -> Some (path, List.map f tl) in
+  let row_fixed = if fixed then row.row_fixed else None in
+  { row_fields = fields; row_more = more;
+    row_bound = (); row_fixed;
+    row_closed = row.row_closed; row_name = name; }
+
+let rec copy_kind = function
+    Fvar{contents = Some k} -> copy_kind k
+  | Fvar _   -> Fvar (ref None)
+  | Fpresent -> Fpresent
+  | Fabsent  -> assert false
+
+let copy_commu c =
+  if commu_repr c = Cok then Cok else Clink (ref Cunknown)
+
+let rec copy_type_desc ?(keep_names=false) f = function
+    Tvar _ as ty        -> if keep_names then ty else Tvar None
+  | Tarrow (p, ty1, ty2, c)-> Tarrow (p, f ty1, f ty2, copy_commu c)
+  | Ttuple l            -> Ttuple (List.map f l)
+  | Tconstr (p, l, _)   -> Tconstr (p, List.map f l, ref Mnil)
+  | Tobject(ty, {contents = Some (p, tl)})
+                        -> Tobject (f ty, ref (Some(p, List.map f tl)))
+  | Tobject (ty, _)     -> Tobject (f ty, ref None)
+  | Tvariant _          -> assert false (* too ambiguous *)
+  | Tfield (p, k, ty1, ty2) -> (* the kind is kept shared *)
+      Tfield (p, field_kind_repr k, f ty1, f ty2)
+  | Tnil                -> Tnil
+  | Tlink ty            -> copy_type_desc f ty.desc
+  | Tsubst _            -> assert false
+  | Tunivar _ as ty     -> ty (* always keep the name *)
+  | Tpoly (ty, tyl)     ->
+      let tyl = List.map f tyl in
+      Tpoly (f ty, tyl)
+  | Tpackage (p, fl)  -> Tpackage (p, List.map (fun (n, ty) -> (n, f ty)) fl)
+
+(* Utilities for copying *)
+
+module For_copy : sig
+  type copy_scope
+
+  val save_desc: copy_scope -> type_expr -> type_desc -> unit
+
+  val dup_kind: copy_scope -> field_kind option ref -> unit
+
+  val with_scope: (copy_scope -> 'a) -> 'a
+end = struct
+  type copy_scope = {
+    mutable saved_desc : (type_expr * type_desc) list;
+    (* Save association of generic nodes with their description. *)
+
+    mutable saved_kinds: field_kind option ref list;
+    (* duplicated kind variables *)
+
+    mutable new_kinds  : field_kind option ref list;
+    (* new kind variables *)
+  }
+
+  let save_desc copy_scope ty desc =
+    copy_scope.saved_desc <- (ty, desc) :: copy_scope.saved_desc
+
+  let dup_kind copy_scope r =
+    assert (Option.is_none !r);
+    if not (List.memq r copy_scope.new_kinds) then begin
+      copy_scope.saved_kinds <- r :: copy_scope.saved_kinds;
+      let r' = ref None in
+      copy_scope.new_kinds <- r' :: copy_scope.new_kinds;
+      r := Some (Fvar r')
+    end
+
+  (* Restore type descriptions. *)
+  let cleanup { saved_desc; saved_kinds; _ } =
+    List.iter (fun (ty, desc) -> Private_type_expr.set_desc ty desc) saved_desc;
+    List.iter (fun r -> r := None) saved_kinds
+
+  let with_scope f =
+    let scope = { saved_desc = []; saved_kinds = []; new_kinds = [] } in
+    let res = f scope in
+    cleanup scope;
+    res
+end
+
+
+                  (*******************************************)
+                  (*  Memorization of abbreviation expansion *)
+                  (*******************************************)
+
+(* Search whether the expansion has been memorized. *)
+
+let lte_public p1 p2 =  (* Private <= Public *)
+  match p1, p2 with
+  | Private, _ | _, Public -> true
+  | Public, Private -> false
+
+let rec find_expans priv p1 = function
+    Mnil -> None
+  | Mcons (priv', p2, _ty0, ty, _)
+    when lte_public priv priv' && Path.same p1 p2 -> Some ty
+  | Mcons (_, _, _, _, rem)   -> find_expans priv p1 rem
+  | Mlink {contents = rem} -> find_expans priv p1 rem
+
+(* debug: check for cycles in abbreviation. only works with -principal
+let rec check_expans visited ty =
+  let ty = repr ty in
+  assert (not (List.memq ty visited));
+  match ty.desc with
+    Tconstr (path, args, abbrev) ->
+      begin match find_expans path !abbrev with
+        Some ty' -> check_expans (ty :: visited) ty'
+      | None -> ()
+      end
+  | _ -> ()
+*)
+
+let memo = s_ref []
+        (* Contains the list of saved abbreviation expansions. *)
+
+let cleanup_abbrev () =
+        (* Remove all memorized abbreviation expansions. *)
+  List.iter (fun abbr -> abbr := Mnil) !memo;
+  memo := []
+
+let memorize_abbrev mem priv path v v' =
+        (* Memorize the expansion of an abbreviation. *)
+  mem := Mcons (priv, path, v, v', !mem);
+  (* check_expans [] v; *)
+  memo := mem :: !memo
+
+let rec forget_abbrev_rec mem path =
+  match mem with
+    Mnil ->
+      mem
+  | Mcons (_, path', _, _, rem) when Path.same path path' ->
+      rem
+  | Mcons (priv, path', v, v', rem) ->
+      Mcons (priv, path', v, v', forget_abbrev_rec rem path)
+  | Mlink mem' ->
+      mem' := forget_abbrev_rec !mem' path;
+      raise Exit
+
+let forget_abbrev mem path =
+  try mem := forget_abbrev_rec !mem path with Exit -> ()
+
+(* debug: check for invalid abbreviations
+let rec check_abbrev_rec = function
+    Mnil -> true
+  | Mcons (_, ty1, ty2, rem) ->
+      repr ty1 != repr ty2
+  | Mlink mem' ->
+      check_abbrev_rec !mem'
+
+let check_memorized_abbrevs () =
+  List.for_all (fun mem -> check_abbrev_rec !mem) !memo
+*)
+
+                  (**********************************)
+                  (*  Utilities for labels          *)
+                  (**********************************)
+
+let is_optional = function Optional _ -> true | _ -> false
+
+let label_name = function
+    Nolabel -> ""
+  | Labelled s
+  | Optional s -> s
+
+let prefixed_label_name = function
+    Nolabel -> ""
+  | Labelled s -> "~" ^ s
+  | Optional s -> "?" ^ s
+
+let rec extract_label_aux hd l = function
+  | [] -> None
+  | (l',t as p) :: ls ->
+      if label_name l' = l then
+        Some (l', t, hd <> [], List.rev_append hd ls)
+      else
+        extract_label_aux (p::hd) l ls
+
+let extract_label l ls = extract_label_aux [] l ls
+
+
+                  (**********************************)
+                  (*  Utilities for backtracking    *)
+                  (**********************************)
+
+let undo_change = function
+    Ctype  (ty, desc) -> Private_type_expr.set_desc ty desc
+  | Ccompress  (ty, desc, _) -> Private_type_expr.set_desc ty desc
+  | Clevel (ty, level) -> Private_type_expr.set_level ty level
+  | Cscope (ty, scope) -> Private_type_expr.set_scope ty scope
+  | Cname  (r, v) -> r := v
+  | Crow   (r, v) -> r := v
+  | Ckind  (r, v) -> r := v
+  | Ccommu (r, v) -> r := v
+  | Cuniv  (r, v) -> r := v
+  | Cfun f -> f ()
+
+type snapshot = changes ref * int
+let last_snapshot = s_ref 0
+let linked_variables = s_ref 0
+
+let log_type ty =
+  if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc))
+let link_type ty ty' =
+  log_type ty;
+  let desc = ty.desc in
+  (match desc with
+   | Tvar _ -> incr linked_variables
+   | _ -> ());
+  Private_type_expr.set_desc ty (Tlink ty');
+  (* Name is a user-supplied name for this unification variable (obtained
+   * through a type annotation for instance). *)
+  match desc, ty'.desc with
+    Tvar name, Tvar name' ->
+      begin match name, name' with
+      | Some _, None -> log_type ty'; Private_type_expr.set_desc ty' (Tvar name)
+      | None, Some _ -> ()
+      | Some _, Some _ ->
+          if ty.level < ty'.level then
+            (log_type ty'; Private_type_expr.set_desc ty' (Tvar name))
+      | None, None   -> ()
+      end
+  | _ -> ()
+  (* ; assert (check_memorized_abbrevs ()) *)
+  (*  ; check_expans [] ty' *)
+(* TODO: consider eliminating set_type_desc, replacing it with link types *)
+let set_type_desc ty td =
+  if td != ty.desc then begin
+    log_type ty;
+    Private_type_expr.set_desc ty td
+  end
+(* TODO: separate set_level into two specific functions: *)
+(*  set_lower_level and set_generic_level *)
+let set_level ty level =
+  if level <> ty.level then begin
+    if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level));
+    Private_type_expr.set_level ty level
+  end
+(* TODO: introduce a guard and rename it to set_higher_scope? *)
+let set_scope ty scope =
+  if scope <> ty.scope then begin
+    if ty.id <= !last_snapshot then log_change (Cscope (ty, ty.scope));
+    Private_type_expr.set_scope ty scope
+  end
+let set_univar rty ty =
+  log_change (Cuniv (rty, !rty)); rty := Some ty
+let set_name nm v =
+  log_change (Cname (nm, !nm)); nm := v
+let set_row_field e v =
+  log_change (Crow (e, !e)); e := Some v
+let set_kind rk k =
+  log_change (Ckind (rk, !rk)); rk := Some k
+let set_commu rc c =
+  log_change (Ccommu (rc, !rc)); rc := c
+
+let snapshot () =
+  let old = !last_snapshot in
+  last_snapshot := !new_id;
+  (!trail, old)
+
+let rec rev_log accu = function
+    Unchanged -> accu
+  | Invalid -> assert false
+  | Change (ch, next) ->
+      let d = !next in
+      next := Invalid;
+      rev_log (ch::accu) d
+
+let backtrack (changes, old) =
+  match !changes with
+    Unchanged -> last_snapshot := old
+  | Invalid -> failwith "Btype.backtrack"
+  | Change _ as change ->
+      cleanup_abbrev ();
+      let backlog = rev_log [] change in
+      List.iter undo_change backlog;
+      changes := Unchanged;
+      last_snapshot := old;
+      trail := changes
+
+let rec rev_compress_log log r =
+  match !r with
+    Unchanged | Invalid ->
+      log
+  | Change (Ccompress _, next) ->
+      rev_compress_log (r::log) next
+  | Change (_, next) ->
+      rev_compress_log log next
+
+let undo_compress (changes, _old) =
+  match !changes with
+    Unchanged
+  | Invalid -> ()
+  | Change _ ->
+      let log = rev_compress_log [] changes in
+      List.iter
+        (fun r -> match !r with
+          Change (Ccompress (ty, desc, d), next) when ty.desc == d ->
+            Private_type_expr.set_desc ty desc; r := !next
+        | _ -> ())
+        log
+
+let is_valid (changes, _old) =
+  match !changes with
+  | Invalid -> false
+  | _ -> true
+
+let on_backtrack f =
+  log_change (Cfun f)
+
+let linked_variables () =
+  !linked_variables
+
+(* Mark a type. *)
+
+let not_marked_node ty = ty.level >= lowest_level
+    (* type nodes with negative levels are "marked" *)
+
+let flip_mark_node ty = Private_type_expr.set_level ty (pivot_level - ty.level)
+let logged_mark_node ty = set_level ty (pivot_level - ty.level)
+
+let try_mark_node ty = not_marked_node ty && (flip_mark_node ty; true)
+let try_logged_mark_node ty = not_marked_node ty && (logged_mark_node ty; true)
+
+let rec mark_type ty =
+  let ty = repr ty in
+  if not_marked_node ty then begin
+    flip_mark_node ty;
+    iter_type_expr mark_type ty
+  end
+
+let mark_type_params ty =
+  iter_type_expr mark_type ty
+
+let type_iterators =
+  let it_type_expr it ty =
+    let ty = repr ty in
+    if try_mark_node ty then it.it_do_type_expr it ty
+  in
+  {type_iterators with it_type_expr}
+
+
+(* Remove marks from a type. *)
+let rec unmark_type ty =
+  let ty = repr ty in
+  if ty.level < lowest_level then begin
+    (* flip back the marked level *)
+    flip_mark_node ty;
+    iter_type_expr unmark_type ty
+  end
+
+let unmark_iterators =
+  let it_type_expr _it ty = unmark_type ty in
+  {type_iterators with it_type_expr}
+
+let unmark_type_decl decl =
+  unmark_iterators.it_type_declaration unmark_iterators decl
+
+let unmark_extension_constructor ext =
+  List.iter unmark_type ext.ext_type_params;
+  iter_type_expr_cstr_args unmark_type ext.ext_args;
+  Option.iter unmark_type ext.ext_ret_type
+
+let unmark_class_signature sign =
+  unmark_type sign.csig_self;
+  Vars.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_vars
+
+let unmark_class_type cty =
+  unmark_iterators.it_class_type unmark_iterators cty
diff --git a/src/ocaml/typing/btype.mli b/src/ocaml/typing/btype.mli
new file mode 100644
index 0000000..f7204c9
--- /dev/null
+++ b/src/ocaml/typing/btype.mli
@@ -0,0 +1,286 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Basic operations on core types *)
+
+open Asttypes
+open Types
+
+(**** Sets, maps and hashtables of types ****)
+
+module TypeSet  : Set.S with type elt = type_expr
+module TypeMap  : Map.S with type key = type_expr
+module TypeHash : Hashtbl.S with type key = type_expr
+
+(**** Levels ****)
+
+val generic_level: int
+
+val newty2: int -> type_desc -> type_expr
+        (* Create a type *)
+val newgenty: type_desc -> type_expr
+        (* Create a generic type *)
+val newgenvar: ?name:string -> unit -> type_expr
+        (* Return a fresh generic variable *)
+
+(* Use Tsubst instead
+val newmarkedvar: int -> type_expr
+        (* Return a fresh marked variable *)
+val newmarkedgenvar: unit -> type_expr
+        (* Return a fresh marked generic variable *)
+*)
+
+(**** Types ****)
+
+val is_Tvar: type_expr -> bool
+val is_Tunivar: type_expr -> bool
+val is_Tconstr: type_expr -> bool
+val dummy_method: label
+
+val repr: type_expr -> type_expr
+        (* Return the canonical representative of a type. *)
+
+val field_kind_repr: field_kind -> field_kind
+        (* Return the canonical representative of an object field
+           kind. *)
+
+val commu_repr: commutable -> commutable
+        (* Return the canonical representative of a commutation lock *)
+
+(**** polymorphic variants ****)
+
+val row_repr: row_desc -> row_desc
+        (* Return the canonical representative of a row description *)
+val row_field_repr: row_field -> row_field
+val row_field: label -> row_desc -> row_field
+        (* Return the canonical representative of a row field *)
+val row_more: row_desc -> type_expr
+        (* Return the extension variable of the row *)
+
+val is_fixed: row_desc -> bool
+(* Return whether the row is directly marked as fixed or not *)
+
+val row_fixed: row_desc -> bool
+(* Return whether the row should be treated as fixed or not.
+   In particular, [is_fixed row] implies [row_fixed row].
+*)
+
+val fixed_explanation: row_desc -> fixed_explanation option
+(* Return the potential explanation for the fixed row *)
+
+val merge_fixed_explanation:
+  fixed_explanation option -> fixed_explanation option
+  -> fixed_explanation option
+(* Merge two explanations for a fixed row *)
+
+val static_row: row_desc -> bool
+        (* Return whether the row is static or not *)
+val hash_variant: label -> int
+        (* Hash function for variant tags *)
+
+val proxy: type_expr -> type_expr
+        (* Return the proxy representative of the type: either itself
+           or a row variable *)
+
+(**** Utilities for private abbreviations with fixed rows ****)
+val row_of_type: type_expr -> type_expr
+val has_constr_row: type_expr -> bool
+val is_row_name: string -> bool
+val is_constr_row: allow_ident:bool -> type_expr -> bool
+
+(* Set the polymorphic variant row_name field *)
+val set_row_name : type_declaration -> Path.t -> unit
+
+(**** Utilities for type traversal ****)
+
+val iter_type_expr: (type_expr -> unit) -> type_expr -> unit
+        (* Iteration on types *)
+val fold_type_expr: ('a -> type_expr -> 'a) -> 'a -> type_expr -> 'a
+val iter_row: (type_expr -> unit) -> row_desc -> unit
+        (* Iteration on types in a row *)
+val fold_row: ('a -> type_expr -> 'a) -> 'a -> row_desc -> 'a
+val iter_abbrev: (type_expr -> unit) -> abbrev_memo -> unit
+        (* Iteration on types in an abbreviation list *)
+
+type type_iterators =
+  { it_signature: type_iterators -> signature -> unit;
+    it_signature_item: type_iterators -> signature_item -> unit;
+    it_value_description: type_iterators -> value_description -> unit;
+    it_type_declaration: type_iterators -> type_declaration -> unit;
+    it_extension_constructor: type_iterators -> extension_constructor -> unit;
+    it_module_declaration: type_iterators -> module_declaration -> unit;
+    it_modtype_declaration: type_iterators -> modtype_declaration -> unit;
+    it_class_declaration: type_iterators -> class_declaration -> unit;
+    it_class_type_declaration: type_iterators -> class_type_declaration -> unit;
+    it_functor_param: type_iterators -> functor_parameter -> unit;
+    it_module_type: type_iterators -> module_type -> unit;
+    it_class_type: type_iterators -> class_type -> unit;
+    it_type_kind: type_iterators -> type_decl_kind -> unit;
+    it_do_type_expr: type_iterators -> type_expr -> unit;
+    it_type_expr: type_iterators -> type_expr -> unit;
+    it_path: Path.t -> unit; }
+val type_iterators: type_iterators
+        (* Iteration on arbitrary type information.
+           [it_type_expr] calls [mark_node] to avoid loops. *)
+val unmark_iterators: type_iterators
+        (* Unmark any structure containing types. See [unmark_type] below. *)
+
+val copy_type_desc:
+    ?keep_names:bool -> (type_expr -> type_expr) -> type_desc -> type_desc
+        (* Copy on types *)
+val copy_row:
+    (type_expr -> type_expr) ->
+    bool -> row_desc -> bool -> type_expr -> row_desc
+val copy_kind: field_kind -> field_kind
+
+module For_copy : sig
+
+  type copy_scope
+        (* The private state that the primitives below are mutating, it should
+           remain scoped within a single [with_scope] call.
+
+           While it is possible to circumvent that discipline in various
+           ways, you should NOT do that. *)
+
+  val save_desc: copy_scope -> type_expr -> type_desc -> unit
+        (* Save a type description *)
+
+  val dup_kind: copy_scope -> field_kind option ref -> unit
+        (* Save a None field_kind, and make it point to a fresh Fvar *)
+
+  val with_scope: (copy_scope -> 'a) -> 'a
+        (* [with_scope f] calls [f] and restores saved type descriptions
+           before returning its result. *)
+end
+
+val lowest_level: int
+        (* Marked type: ty.level < lowest_level *)
+
+val not_marked_node: type_expr -> bool
+        (* Return true if a type node is not yet marked *)
+
+val logged_mark_node: type_expr -> unit
+        (* Mark a type node, logging the marking so it can be backtracked.
+           No [repr]'ing *)
+val try_logged_mark_node: type_expr -> bool
+        (* Mark a type node if it is not yet marked, logging the marking so it
+           can be backtracked.
+           Return false if it was already marked *)
+
+val flip_mark_node: type_expr -> unit
+        (* Mark a type node. No [repr]'ing.
+           The marking is not logged and will have to be manually undone using
+           one of the various [unmark]'ing functions below. *)
+val try_mark_node: type_expr -> bool
+        (* Mark a type node if it is not yet marked.
+           The marking is not logged and will have to be manually undone using
+           one of the various [unmark]'ing functions below.
+
+           Return false if it was already marked *)
+val mark_type: type_expr -> unit
+        (* Mark a type recursively *)
+val mark_type_params: type_expr -> unit
+        (* Mark the sons of a type node recursively *)
+
+val unmark_type: type_expr -> unit
+val unmark_type_decl: type_declaration -> unit
+val unmark_extension_constructor: extension_constructor -> unit
+val unmark_class_type: class_type -> unit
+val unmark_class_signature: class_signature -> unit
+        (* Remove marks from a type *)
+
+(**** Memorization of abbreviation expansion ****)
+
+val find_expans: private_flag -> Path.t -> abbrev_memo -> type_expr option
+        (* Look up a memorized abbreviation *)
+val cleanup_abbrev: unit -> unit
+        (* Flush the cache of abbreviation expansions.
+           When some types are saved (using [output_value]), this
+           function MUST be called just before. *)
+val memorize_abbrev:
+        abbrev_memo ref ->
+        private_flag -> Path.t -> type_expr -> type_expr -> unit
+        (* Add an expansion in the cache *)
+val forget_abbrev:
+        abbrev_memo ref -> Path.t -> unit
+        (* Remove an abbreviation from the cache *)
+
+(**** Utilities for labels ****)
+
+val is_optional : arg_label -> bool
+val label_name : arg_label -> label
+
+(* Returns the label name with first character '?' or '~' as appropriate. *)
+val prefixed_label_name : arg_label -> label
+
+val extract_label :
+    label -> (arg_label * 'a) list ->
+    (arg_label * 'a * bool * (arg_label * 'a) list) option
+(* actual label,
+   value,
+   whether (label, value) was at the head of the list,
+   list without the extracted (label, value) *)
+
+(**** Utilities for backtracking ****)
+
+type snapshot
+        (* A snapshot for backtracking *)
+val snapshot: unit -> snapshot
+        (* Make a snapshot for later backtracking. Costs nothing *)
+val backtrack: snapshot -> unit
+        (* Backtrack to a given snapshot. Only possible if you have
+           not already backtracked to a previous snapshot.
+           Calls [cleanup_abbrev] internally *)
+val undo_compress: snapshot -> unit
+        (* Backtrack only path compression. Only meaningful if you have
+           not already backtracked to a previous snapshot.
+           Does not call [cleanup_abbrev] *)
+
+(* Functions to use when modifying a type (only Ctype?) *)
+val link_type: type_expr -> type_expr -> unit
+        (* Set the desc field of [t1] to [Tlink t2], logging the old
+           value if there is an active snapshot *)
+val set_type_desc: type_expr -> type_desc -> unit
+        (* Set directly the desc field, without sharing *)
+val set_level: type_expr -> int -> unit
+val set_scope: type_expr -> int -> unit
+val set_name:
+    (Path.t * type_expr list) option ref ->
+    (Path.t * type_expr list) option -> unit
+val set_row_field: row_field option ref -> row_field -> unit
+val set_univar: type_expr option ref -> type_expr -> unit
+val set_kind: field_kind option ref -> field_kind -> unit
+val set_commu: commutable ref -> commutable -> unit
+        (* Set references, logging the old value *)
+
+(**** Forward declarations ****)
+val print_raw: (Format.formatter -> type_expr -> unit) ref
+
+val iter_type_expr_kind: (type_expr -> unit) -> (type_decl_kind -> unit)
+
+val iter_type_expr_cstr_args: (type_expr -> unit) ->
+  (constructor_arguments -> unit)
+val map_type_expr_cstr_args: (type_expr -> type_expr) ->
+  (constructor_arguments -> constructor_arguments)
+
+(** merlin: check if a snapshot has been invalidated *)
+val is_valid: snapshot -> bool
+
+(** merlin: also register changes to arbitrary references *)
+val on_backtrack: (unit -> unit) -> unit
+
+(** merlin: Number of unification variables that have been linked so far.
+   Used to estimate the "cost" of unification. *)
+val linked_variables: unit -> int
diff --git a/src/ocaml/typing/cmi_cache.ml b/src/ocaml/typing/cmi_cache.ml
new file mode 100644
index 0000000..220f652
--- /dev/null
+++ b/src/ocaml/typing/cmi_cache.ml
@@ -0,0 +1,34 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+
+include File_cache.Make (struct
+  type t = Cmi_format.cmi_infos
+  let read name = Cmi_format.read_cmi name
+  let cache_name = "Cmi_cache"
+end)
diff --git a/src/ocaml/typing/cmi_format.ml b/src/ocaml/typing/cmi_format.ml
new file mode 100644
index 0000000..2c5999d
--- /dev/null
+++ b/src/ocaml/typing/cmi_format.ml
@@ -0,0 +1,88 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Misc
+
+type pers_flags =
+  | Rectypes
+  | Alerts of alerts
+  | Opaque
+  | Unsafe_string
+
+(* these type abbreviations are not exported;
+   they are used to provide consistency across
+   input_value and output_value usage. *)
+type signature = Types.signature_item list
+type flags = pers_flags list
+type header = modname * signature
+
+type cmi_infos = {
+    cmi_name : modname;
+    cmi_sign : signature;
+    cmi_crcs : crcs;
+    cmi_flags : flags;
+}
+
+let input_cmi ic =
+  let (name, sign) = (input_value ic : header) in
+  let crcs = (input_value ic : crcs) in
+  let flags = (input_value ic : flags) in
+  {
+      cmi_name = name;
+      cmi_sign = sign;
+      cmi_crcs = crcs;
+      cmi_flags = flags;
+    }
+
+let read_cmi filename =
+  let open Magic_numbers.Cmi in
+  let ic = open_in_bin filename in
+  try
+    let buffer =
+      really_input_string ic (String.length Config.cmi_magic_number)
+    in
+    if buffer <> Config.cmi_magic_number then begin
+      close_in ic;
+      let pre_len = String.length Config.cmi_magic_number - 3 in
+      if String.sub buffer 0 pre_len
+          = String.sub Config.cmi_magic_number 0 pre_len then
+      begin
+        raise (Error (Wrong_version_interface (filename, buffer)))
+      end else begin
+        raise(Error(Not_an_interface filename))
+      end
+    end;
+    let cmi = input_cmi ic in
+    close_in ic;
+    cmi
+  with End_of_file | Failure _ ->
+      close_in ic;
+      raise(Error(Corrupted_interface(filename)))
+    | Error e ->
+      close_in ic;
+      raise (Error e)
+
+let output_cmi filename oc cmi =
+(* beware: the provided signature must have been substituted for saving *)
+  output_string oc Config.cmi_magic_number;
+  output_value oc ((cmi.cmi_name, cmi.cmi_sign) : header);
+  flush oc;
+  let crc = Digest.file filename in
+  let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in
+  output_value oc (crcs : crcs);
+  output_value oc (cmi.cmi_flags : flags);
+  crc
+
+(* Error report moved to src/ocaml/typing/magic_numbers.ml *)
diff --git a/src/ocaml/typing/cmi_format.mli b/src/ocaml/typing/cmi_format.mli
new file mode 100644
index 0000000..2ce923f
--- /dev/null
+++ b/src/ocaml/typing/cmi_format.mli
@@ -0,0 +1,40 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Misc
+
+type pers_flags =
+  | Rectypes
+  | Alerts of alerts
+  | Opaque
+  | Unsafe_string
+
+type cmi_infos = {
+    cmi_name : modname;
+    cmi_sign : Types.signature_item list;
+    cmi_crcs : crcs;
+    cmi_flags : pers_flags list;
+}
+
+(* write the magic + the cmi information *)
+val output_cmi : string -> out_channel -> cmi_infos -> Digest.t
+
+(* read the cmi information (the magic is supposed to have already been read) *)
+val input_cmi : in_channel -> cmi_infos
+
+(* read a cmi from a filename, checking the magic *)
+val read_cmi : string -> cmi_infos
+
+(* Error report moved to {!Magic_numbers.Cmi} *)
diff --git a/src/ocaml/typing/cmt_cache.ml b/src/ocaml/typing/cmt_cache.ml
new file mode 100644
index 0000000..5292e94
--- /dev/null
+++ b/src/ocaml/typing/cmt_cache.ml
@@ -0,0 +1,43 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+type cmt_item = {
+  cmt_infos : Cmt_format.cmt_infos ;
+  mutable location_trie : exn;
+}
+
+include File_cache.Make (struct
+  type t = cmt_item
+
+  let read file = {
+    cmt_infos = Cmt_format.read_cmt file ;
+    location_trie = Not_found;
+  }
+
+  let cache_name = "Cmt_cache"
+end)
diff --git a/src/ocaml/typing/cmt_format.ml b/src/ocaml/typing/cmt_format.ml
new file mode 100644
index 0000000..ca26ed5
--- /dev/null
+++ b/src/ocaml/typing/cmt_format.ml
@@ -0,0 +1,197 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Std
+open Cmi_format
+open Typedtree
+
+(* Note that in Typerex, there is an awful hack to save a cmt file
+   together with the interface file that was generated by ocaml (this
+   is because the installed version of ocaml might differ from the one
+   integrated in Typerex).
+*)
+
+
+
+let read_magic_number ic =
+  let len_magic_number = String.length Config.cmt_magic_number in
+  really_input_string ic len_magic_number
+
+type binary_annots =
+  | Packed of Types.signature * string list
+  | Implementation of structure
+  | Interface of signature
+  | Partial_implementation of binary_part array
+  | Partial_interface of binary_part array
+
+and binary_part =
+| Partial_structure of structure
+| Partial_structure_item of structure_item
+| Partial_expression of expression
+| Partial_pattern : 'k pattern_category * 'k general_pattern -> binary_part
+| Partial_class_expr of class_expr
+| Partial_signature of signature
+| Partial_signature_item of signature_item
+| Partial_module_type of module_type
+
+type cmt_infos = {
+  cmt_modname : string;
+  cmt_annots : binary_annots;
+  cmt_value_dependencies :
+    (Types.value_description * Types.value_description) list;
+  cmt_comments : (string * Location.t) list;
+  cmt_args : string array;
+  cmt_sourcefile : string option;
+  cmt_builddir : string;
+  cmt_loadpath : string list;
+  cmt_source_digest : Digest.t option;
+  cmt_initial_env : Env.t;
+  cmt_imports : (string * Digest.t option) list;
+  cmt_interface_digest : Digest.t option;
+  cmt_use_summaries : bool;
+}
+
+type error =
+    Not_a_typedtree of string
+
+let need_to_clear_env =
+  try ignore (Sys.getenv "OCAML_BINANNOT_WITHENV"); false
+  with Not_found -> true
+
+let keep_only_summary = Env.keep_only_summary
+
+open Tast_mapper
+
+let cenv =
+  {Tast_mapper.default with env = fun _sub env -> keep_only_summary env}
+
+let clear_part = function
+  | Partial_structure s -> Partial_structure (cenv.structure cenv s)
+  | Partial_structure_item s ->
+      Partial_structure_item (cenv.structure_item cenv s)
+  | Partial_expression e -> Partial_expression (cenv.expr cenv e)
+  | Partial_pattern (category, p) -> Partial_pattern (category, cenv.pat cenv p)
+  | Partial_class_expr ce -> Partial_class_expr (cenv.class_expr cenv ce)
+  | Partial_signature s -> Partial_signature (cenv.signature cenv s)
+  | Partial_signature_item s ->
+      Partial_signature_item (cenv.signature_item cenv s)
+  | Partial_module_type s -> Partial_module_type (cenv.module_type cenv s)
+
+let clear_env binary_annots =
+  if need_to_clear_env then
+    match binary_annots with
+    | Implementation s -> Implementation (cenv.structure cenv s)
+    | Interface s -> Interface (cenv.signature cenv s)
+    | Packed _ -> binary_annots
+    | Partial_implementation array ->
+        Partial_implementation (Array.map clear_part array)
+    | Partial_interface array ->
+        Partial_interface (Array.map clear_part array)
+
+  else binary_annots
+
+exception Error of error
+
+let input_cmt ic = (input_value ic : cmt_infos)
+
+let output_cmt oc cmt =
+  output_string oc Config.cmt_magic_number;
+  output_value oc (cmt : cmt_infos)
+
+let read filename =
+(*  Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *)
+  let ic = open_in_bin filename in
+  Misc.try_finally
+    ~always:(fun () -> close_in ic)
+    (fun () ->
+       let magic_number = read_magic_number ic in
+       let cmi, cmt =
+         if magic_number = Config.cmt_magic_number then
+           None, Some (input_cmt ic)
+         else if magic_number = Config.cmi_magic_number then
+           let cmi = Cmi_format.input_cmi ic in
+           let cmt = try
+               let magic_number = read_magic_number ic in
+               if magic_number = Config.cmt_magic_number then
+                 let cmt = input_cmt ic in
+                 Some cmt
+               else None
+             with _ -> None
+           in
+           Some cmi, cmt
+         else
+           raise Magic_numbers.Cmi.(Error(Not_an_interface filename))
+       in
+       cmi, cmt
+    )
+
+let read_cmt filename =
+  match read filename with
+      _, None -> raise (Error (Not_a_typedtree filename))
+    | _, Some cmt -> cmt
+
+let read_cmi filename =
+  match read filename with
+      None, _ ->
+        raise Magic_numbers.Cmi.(Error (Not_an_interface filename))
+    | Some cmi, _ -> cmi
+
+let saved_types = ref []
+let value_deps = ref []
+
+let clear () =
+  saved_types := [];
+  value_deps := []
+
+let add_saved_type b = saved_types := b :: !saved_types
+let get_saved_types () = !saved_types
+let set_saved_types l = saved_types := l
+
+(*let record_value_dependency vd1 vd2 =
+  if vd1.Types.val_loc <> vd2.Types.val_loc then
+    value_deps := (vd1, vd2) :: !value_deps*)
+
+let record_value_dependency _vd1 _vd2 = ()
+
+let save_cmt filename modname binary_annots sourcefile initial_env cmi =
+  if !Clflags.binary_annotations && not !Clflags.print_types then begin
+    Misc.output_to_file_via_temporary
+       ~mode:[Open_binary] filename
+       (fun temp_file_name oc ->
+         let this_crc =
+           match cmi with
+           | None -> None
+           | Some cmi -> Some (output_cmi temp_file_name oc cmi)
+         in
+         let source_digest = Option.map ~f:Digest.file sourcefile in
+         let cmt = {
+           cmt_modname = modname;
+           cmt_annots = clear_env binary_annots;
+           cmt_value_dependencies = !value_deps;
+           cmt_comments = [];
+           cmt_args = Sys.argv;
+           cmt_sourcefile = sourcefile;
+           cmt_builddir = Location.rewrite_absolute_path (Sys.getcwd ());
+           cmt_loadpath = Load_path.get_paths ();
+           cmt_source_digest = source_digest;
+           cmt_initial_env = if need_to_clear_env then
+               keep_only_summary initial_env else initial_env;
+           cmt_imports = List.sort ~cmp:compare (Env.imports ());
+           cmt_interface_digest = this_crc;
+           cmt_use_summaries = need_to_clear_env;
+         } in
+         output_cmt oc cmt)
+  end;
+  clear ()
diff --git a/src/ocaml/typing/cmt_format.mli b/src/ocaml/typing/cmt_format.mli
new file mode 100644
index 0000000..8a52c4b
--- /dev/null
+++ b/src/ocaml/typing/cmt_format.mli
@@ -0,0 +1,123 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** cmt and cmti files format. *)
+
+open Misc
+
+(** The layout of a cmt file is as follows:
+      <cmt> := \{<cmi>\} <cmt magic> \{cmt infos\} \{<source info>\}
+    where <cmi> is the cmi file format:
+      <cmi> := <cmi magic> <cmi info>.
+    More precisely, the optional <cmi> part must be present if and only if
+    the file is:
+    - a cmti, or
+    - a cmt, for a ml file which has no corresponding mli (hence no
+    corresponding cmti).
+
+    Thus, we provide a common reading function for cmi and cmt(i)
+    files which returns an option for each of the three parts: cmi
+    info, cmt info, source info. *)
+
+open Typedtree
+
+type binary_annots =
+  | Packed of Types.signature * string list
+  | Implementation of structure
+  | Interface of signature
+  | Partial_implementation of binary_part array
+  | Partial_interface of binary_part array
+
+and binary_part =
+  | Partial_structure of structure
+  | Partial_structure_item of structure_item
+  | Partial_expression of expression
+  | Partial_pattern : 'k pattern_category * 'k general_pattern -> binary_part
+  | Partial_class_expr of class_expr
+  | Partial_signature of signature
+  | Partial_signature_item of signature_item
+  | Partial_module_type of module_type
+
+type cmt_infos = {
+  cmt_modname : modname;
+  cmt_annots : binary_annots;
+  cmt_value_dependencies :
+    (Types.value_description * Types.value_description) list;
+  cmt_comments : (string * Location.t) list;
+  cmt_args : string array;
+  cmt_sourcefile : string option;
+  cmt_builddir : string;
+  cmt_loadpath : string list;
+  cmt_source_digest : string option;
+  cmt_initial_env : Env.t;
+  cmt_imports : crcs;
+  cmt_interface_digest : Digest.t option;
+  cmt_use_summaries : bool;
+}
+
+type error =
+    Not_a_typedtree of string
+
+exception Error of error
+
+(** [read filename] opens filename, and extract both the cmi_infos, if
+    it exists, and the cmt_infos, if it exists. Thus, it can be used
+    with .cmi, .cmt and .cmti files.
+
+    .cmti files always contain a cmi_infos at the beginning. .cmt files
+    only contain a cmi_infos at the beginning if there is no associated
+    .cmti file.
+*)
+val read : string -> Cmi_format.cmi_infos option * cmt_infos option
+
+val read_cmt : string -> cmt_infos
+val read_cmi : string -> Cmi_format.cmi_infos
+
+(** [save_cmt filename modname binary_annots sourcefile initial_env cmi]
+    writes a cmt(i) file.  *)
+val save_cmt :
+  string ->  (* filename.cmt to generate *)
+  string ->  (* module name *)
+  binary_annots ->
+  string option ->  (* source file *)
+  Env.t -> (* initial env *)
+  Cmi_format.cmi_infos option -> (* if a .cmi was generated *)
+  unit
+
+(* Miscellaneous functions *)
+
+val read_magic_number : in_channel -> string
+
+val clear: unit -> unit
+
+val add_saved_type : binary_part -> unit
+val get_saved_types : unit -> binary_part list
+val set_saved_types : binary_part list -> unit
+
+val record_value_dependency:
+  Types.value_description -> Types.value_description -> unit
+
+
+(*
+
+  val is_magic_number : string -> bool
+  val read : in_channel -> Env.cmi_infos option * t
+  val write_magic_number : out_channel -> unit
+  val write : out_channel -> t -> unit
+
+  val find : string list -> string -> string
+  val read_signature : 'a -> string -> Types.signature * 'b list * 'c list
+
+*)
diff --git a/src/ocaml/typing/ctype.ml b/src/ocaml/typing/ctype.ml
new file mode 100644
index 0000000..f8fcf77
--- /dev/null
+++ b/src/ocaml/typing/ctype.ml
@@ -0,0 +1,5027 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Operations on core types *)
+
+open Misc
+open Asttypes
+open Types
+open Btype
+open Errortrace
+
+open Local_store
+
+(*
+   Type manipulation after type inference
+   ======================================
+   If one wants to manipulate a type after type inference (for
+   instance, during code generation or in the debugger), one must
+   first make sure that the type levels are correct, using the
+   function [correct_levels]. Then, this type can be correctly
+   manipulated by [apply], [expand_head] and [moregeneral].
+*)
+
+(*
+   General notes
+   =============
+   - As much sharing as possible should be kept : it makes types
+     smaller and better abbreviated.
+     When necessary, some sharing can be lost. Types will still be
+     printed correctly (+++ TO DO...), and abbreviations defined by a
+     class do not depend on sharing thanks to constrained
+     abbreviations. (Of course, even if some sharing is lost, typing
+     will still be correct.)
+   - All nodes of a type have a level : that way, one know whether a
+     node need to be duplicated or not when instantiating a type.
+   - Levels of a type are decreasing (generic level being considered
+     as greatest).
+   - The level of a type constructor is superior to the binding
+     time of its path.
+   - Recursive types without limitation should be handled (even if
+     there is still an occur check). This avoid treating specially the
+     case for objects, for instance. Furthermore, the occur check
+     policy can then be easily changed.
+*)
+
+(**** Errors ****)
+exception Unify of unification Errortrace.t
+exception Equality of comparison Errortrace.t
+exception Moregen of comparison Errortrace.t
+exception Subtype of Errortrace.Subtype.t * unification Errortrace.t
+
+exception Escape of desc Errortrace.escape
+
+(* For local use: throw the appropriate exception.  Can be passed into local
+   functions as a parameter *)
+type _ trace_exn =
+| Unify    : unification trace_exn
+| Moregen  : comparison  trace_exn
+| Equality : comparison  trace_exn
+
+let raise_trace_for
+      (type variant)
+      (tr_exn : variant trace_exn)
+      (tr     : variant Errortrace.t) : 'a =
+  match tr_exn with
+  | Unify    -> raise (Unify    tr)
+  | Equality -> raise (Equality tr)
+  | Moregen  -> raise (Moregen  tr)
+
+(* Uses of this function are a bit suspicious, as we usually want to maintain
+   trace information; sometimes it makes sense, however, since we're maintaining
+   the trace at an outer exception handler. *)
+let raise_unexplained_for tr_exn =
+  raise_trace_for tr_exn []
+
+let raise_for tr_exn e =
+  raise_trace_for tr_exn [e]
+
+(* Thrown from [moregen_kind] *)
+exception Public_method_to_private_method
+
+let escape kind = {kind; context = None}
+let escape_exn kind = Escape (escape kind)
+let scope_escape_exn ty = escape_exn (Equation (short ty))
+let raise_escape_exn kind = raise (escape_exn kind)
+let raise_scope_escape_exn ty = raise (scope_escape_exn ty)
+
+exception Tags of label * label
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Tags (l, l') ->
+          Some
+            Location.
+              (errorf ~loc:(in_file !input_name)
+                 "In this program,@ variant constructors@ `%s and `%s@ \
+                  have the same hash value.@ Change one of them." l l'
+              )
+      | _ -> None
+    )
+
+exception Cannot_expand
+
+exception Cannot_apply
+
+exception Cannot_subst
+
+exception Cannot_unify_universal_variables
+
+exception Matches_failure of Env.t * unification Errortrace.t
+
+exception Incompatible
+
+(**** Type level management ****)
+
+let current_level = s_ref 0
+let nongen_level = s_ref 0
+let global_level = s_ref 1
+let saved_level = s_ref []
+
+type levels =
+    { current_level: int; nongen_level: int; global_level: int;
+      saved_level: (int * int) list; }
+let save_levels () =
+  { current_level = !current_level;
+    nongen_level = !nongen_level;
+    global_level = !global_level;
+    saved_level = !saved_level }
+let set_levels l =
+  current_level := l.current_level;
+  nongen_level := l.nongen_level;
+  global_level := l.global_level;
+  saved_level := l.saved_level
+
+let get_current_level () = !current_level
+let init_def level = current_level := level; nongen_level := level
+let begin_def () =
+  saved_level := (!current_level, !nongen_level) :: !saved_level;
+  incr current_level; nongen_level := !current_level
+let begin_class_def () =
+  saved_level := (!current_level, !nongen_level) :: !saved_level;
+  incr current_level
+let raise_nongen_level () =
+  saved_level := (!current_level, !nongen_level) :: !saved_level;
+  nongen_level := !current_level
+let end_def () =
+  let (cl, nl) = List.hd !saved_level in
+  saved_level := List.tl !saved_level;
+  current_level := cl; nongen_level := nl
+let create_scope () =
+  init_def (!current_level + 1);
+  !current_level
+
+let reset_global_level () =
+  global_level := !current_level + 1
+let increase_global_level () =
+  let gl = !global_level in
+  global_level := !current_level;
+  gl
+let restore_global_level gl =
+  global_level := gl
+
+(**** Whether a path points to an object type (with hidden row variable) ****)
+let is_object_type path =
+  let name =
+    match path with Path.Pident id -> Ident.name id
+    | Path.Pdot(_, s) -> s
+    | Path.Papply _ -> assert false
+  in name.[0] = '#'
+
+(**** Control tracing of GADT instances *)
+
+let trace_gadt_instances = ref false
+let check_trace_gadt_instances env =
+  not !trace_gadt_instances && Env.has_local_constraints env &&
+  (trace_gadt_instances := true; cleanup_abbrev (); true)
+
+let reset_trace_gadt_instances b =
+  if b then trace_gadt_instances := false
+
+let wrap_trace_gadt_instances env f x =
+  let b = check_trace_gadt_instances env in
+  let y = f x in
+  reset_trace_gadt_instances b;
+  y
+
+(**** Abbreviations without parameters ****)
+(* Shall reset after generalizing *)
+
+let simple_abbrevs = ref Mnil
+
+let proper_abbrevs path tl abbrev =
+  if tl <> [] || !trace_gadt_instances || !Clflags.principal ||
+     is_object_type path
+  then abbrev
+  else simple_abbrevs
+
+(**** Some type creators ****)
+
+(* Re-export generic type creators *)
+
+let newty2             = Btype.newty2
+let newty desc         = newty2 !current_level desc
+
+let newvar ?name ()         = newty2 !current_level (Tvar name)
+let newvar2 ?name level     = newty2 level (Tvar name)
+let new_global_var ?name () = newty2 !global_level (Tvar name)
+
+let newobj fields      = newty (Tobject (fields, ref None))
+
+let newconstr path tyl = newty (Tconstr (path, tyl, ref Mnil))
+
+let none = newty (Ttuple [])                (* Clearly ill-formed type *)
+
+(**** Representative of a type ****)
+
+(* Re-export repr *)
+let repr = repr
+
+(**** Type maps ****)
+
+module TypePairs =
+  Hashtbl.Make (struct
+    type t = type_expr * type_expr
+    let equal (t1, t1') (t2, t2') = (t1 == t2) && (t1' == t2')
+    let hash (t, t') = t.id + 93 * t'.id
+ end)
+
+
+(**** unification mode ****)
+
+type unification_mode =
+  | Expression (* unification in expression *)
+  | Pattern (* unification in pattern which may add local constraints *)
+
+type equations_generation =
+  | Forbidden
+  | Allowed of { equated_types : unit TypePairs.t }
+
+let umode = ref Expression
+let equations_generation = ref Forbidden
+let assume_injective = ref false
+let allow_recursive_equation = ref false
+
+let can_generate_equations () =
+  match !equations_generation with
+  | Forbidden -> false
+  | _ -> true
+
+let set_mode_pattern ~generate ~injective ~allow_recursive f =
+  Misc.protect_refs
+    [ Misc.R (umode, Pattern);
+      Misc.R (equations_generation, generate);
+      Misc.R (assume_injective, injective);
+      Misc.R (allow_recursive_equation, allow_recursive);
+    ] f
+
+(*** Checks for type definitions ***)
+
+let in_current_module = function
+  | Path.Pident _ -> true
+  | Path.Pdot _ | Path.Papply _ -> false
+
+let in_pervasives p =
+  in_current_module p &&
+  try ignore (Env.find_type p Env.initial_safe_string); true
+  with Not_found -> false
+
+let is_datatype decl=
+  match decl.type_kind with
+    Type_record _ | Type_variant _ | Type_open -> true
+  | Type_abstract -> false
+
+
+                  (**********************************************)
+                  (*  Miscellaneous operations on object types  *)
+                  (**********************************************)
+
+(* Note:
+   We need to maintain some invariants:
+   * cty_self must be a Tobject
+   * ...
+*)
+
+(**** Object field manipulation. ****)
+
+let object_fields ty =
+  match (repr ty).desc with
+    Tobject (fields, _) -> fields
+  | _                   -> assert false
+
+let flatten_fields ty =
+  let rec flatten l ty =
+    let ty = repr ty in
+    match ty.desc with
+      Tfield(s, k, ty1, ty2) ->
+        flatten ((s, k, ty1)::l) ty2
+    | _ ->
+        (l, ty)
+  in
+    let (l, r) = flatten [] ty in
+    (List.sort (fun (n, _, _) (n', _, _) -> compare n n') l, r)
+
+let build_fields level =
+  List.fold_right
+    (fun (s, k, ty1) ty2 -> newty2 level (Tfield(s, k, ty1, ty2)))
+
+let associate_fields fields1 fields2 =
+  let rec associate p s s' =
+    function
+      (l, []) ->
+        (List.rev p, (List.rev s) @ l, List.rev s')
+    | ([], l') ->
+        (List.rev p, List.rev s, (List.rev s') @ l')
+    | ((n, k, t)::r, (n', k', t')::r') when n = n' ->
+        associate ((n, k, t, k', t')::p) s s' (r, r')
+    | ((n, k, t)::r, ((n', _k', _t')::_ as l')) when n < n' ->
+        associate p ((n, k, t)::s) s' (r, l')
+    | (((_n, _k, _t)::_ as l), (n', k', t')::r') (* when n > n' *) ->
+        associate p s ((n', k', t')::s') (l, r')
+  in
+  associate [] [] [] (fields1, fields2)
+
+let rec has_dummy_method ty =
+  match repr ty with
+    {desc = Tfield (m, _, _, ty2)} ->
+      m = dummy_method || has_dummy_method ty2
+  | _ -> false
+
+let is_self_type = function
+  | Tobject (ty, _) -> has_dummy_method ty
+  | _ -> false
+
+(**** Check whether an object is open ****)
+
+(* +++ The abbreviation should eventually be expanded *)
+let rec object_row ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tobject (t, _)     -> object_row t
+  | Tfield(_, _, _, t) -> object_row t
+  | _ -> ty
+
+let opened_object ty =
+  match (object_row ty).desc with
+  | Tvar _  | Tunivar _ | Tconstr _ -> true
+  | _                               -> false
+
+let concrete_object ty =
+  match (object_row ty).desc with
+  | Tvar _             -> false
+  | _                  -> true
+
+(**** Close an object ****)
+
+let close_object ty =
+  let rec close ty =
+    let ty = repr ty in
+    match ty.desc with
+      Tvar _ ->
+        link_type ty (newty2 ty.level Tnil); true
+    | Tfield(lab, _, _, _) when lab = dummy_method ->
+        false
+    | Tfield(_, _, _, ty') -> close ty'
+    | _                    -> assert false
+  in
+  match (repr ty).desc with
+    Tobject (ty, _)   -> close ty
+  | _                 -> assert false
+
+(**** Row variable of an object type ****)
+
+let row_variable ty =
+  let rec find ty =
+    let ty = repr ty in
+    match ty.desc with
+      Tfield (_, _, _, ty) -> find ty
+    | Tvar _               -> ty
+    | _                    -> assert false
+  in
+  match (repr ty).desc with
+    Tobject (fi, _) -> find fi
+  | _               -> assert false
+
+(**** Object name manipulation ****)
+(* +++ Bientot obsolete *)
+
+let set_object_name id rv params ty =
+  match (repr ty).desc with
+    Tobject (_fi, nm) ->
+      set_name nm (Some (Path.Pident id, rv::params))
+  | _ ->
+      assert false
+
+let remove_object_name ty =
+  match (repr ty).desc with
+    Tobject (_, nm)   -> set_name nm None
+  | Tconstr (_, _, _) -> ()
+  | _                 -> fatal_error "Ctype.remove_object_name"
+
+(**** Hiding of private methods ****)
+
+let hide_private_methods ty =
+  match (repr ty).desc with
+    Tobject (fi, nm) ->
+      nm := None;
+      let (fl, _) = flatten_fields fi in
+      List.iter
+        (function (_, k, _) ->
+          match field_kind_repr k with
+            Fvar r -> set_kind r Fabsent
+          | _      -> ())
+        fl
+  | _ ->
+      assert false
+
+
+                              (*******************************)
+                              (*  Operations on class types  *)
+                              (*******************************)
+
+
+let rec signature_of_class_type =
+  function
+    Cty_constr (_, _, cty) -> signature_of_class_type cty
+  | Cty_signature sign     -> sign
+  | Cty_arrow (_, _, cty)   -> signature_of_class_type cty
+
+let self_type cty =
+  repr (signature_of_class_type cty).csig_self
+
+let rec class_type_arity =
+  function
+    Cty_constr (_, _, cty) ->  class_type_arity cty
+  | Cty_signature _        ->  0
+  | Cty_arrow (_, _, cty)    ->  1 + class_type_arity cty
+
+
+                  (*******************************************)
+                  (*  Miscellaneous operations on row types  *)
+                  (*******************************************)
+
+let sort_row_fields = List.sort (fun (p,_) (q,_) -> compare p q)
+
+let rec merge_rf r1 r2 pairs fi1 fi2 =
+  match fi1, fi2 with
+    (l1,f1 as p1)::fi1', (l2,f2 as p2)::fi2' ->
+      if l1 = l2 then merge_rf r1 r2 ((l1,f1,f2)::pairs) fi1' fi2' else
+      if l1 < l2 then merge_rf (p1::r1) r2 pairs fi1' fi2 else
+      merge_rf r1 (p2::r2) pairs fi1 fi2'
+  | [], _ -> (List.rev r1, List.rev_append r2 fi2, pairs)
+  | _, [] -> (List.rev_append r1 fi1, List.rev r2, pairs)
+
+let merge_row_fields fi1 fi2 =
+  match fi1, fi2 with
+    [], _ | _, [] -> (fi1, fi2, [])
+  | [p1], _ when not (List.mem_assoc (fst p1) fi2) -> (fi1, fi2, [])
+  | _, [p2] when not (List.mem_assoc (fst p2) fi1) -> (fi1, fi2, [])
+  | _ -> merge_rf [] [] [] (sort_row_fields fi1) (sort_row_fields fi2)
+
+let rec filter_row_fields erase = function
+    [] -> []
+  | (_l,f as p)::fi ->
+      let fi = filter_row_fields erase fi in
+      match row_field_repr f with
+        Rabsent -> fi
+      | Reither(_,_,false,e) when erase -> set_row_field e Rabsent; fi
+      | _ -> p :: fi
+
+                    (**************************************)
+                    (*  Check genericity of type schemes  *)
+                    (**************************************)
+
+
+exception Non_closed of type_expr * bool
+
+let free_variables = ref []
+let really_closed = ref None
+
+(* [free_vars_rec] collects the variables of the input type
+   expression into the [free_variables] reference. It is used for
+   several different things in the type-checker, with the following
+   bells and whistles:
+   - If [really_closed] is Some typing environment, types in the environment
+     are expanded to check whether the apparently-free variable would vanish
+     during expansion.
+   - We collect both type variables and row variables, paired with a boolean
+     that is [true] if we have a row variable.
+   - We do not count "virtual" free variables -- free variables stored in
+     the abbreviation of an object type that has been expanded (we store
+     the abbreviations for use when displaying the type).
+
+   The functions [free_vars] and [free_variables] below receive
+   a typing environment as an optional [?env] parameter and
+   set [really_closed] accordingly.
+   [free_vars] returns a [(variable * bool) list], while
+   [free_variables] drops the type/row information
+   and only returns a [variable list].
+ *)
+let rec free_vars_rec real ty =
+  let ty = repr ty in
+  if try_mark_node ty then
+    match ty.desc, !really_closed with
+      Tvar _, _ ->
+        free_variables := (ty, real) :: !free_variables
+    | Tconstr (path, tl, _), Some env ->
+        begin try
+          let (_, body, _) = Env.find_type_expansion path env in
+          if (repr body).level <> generic_level then
+            free_variables := (ty, real) :: !free_variables
+        with Not_found -> ()
+        end;
+        List.iter (free_vars_rec true) tl
+(* Do not count "virtual" free variables
+    | Tobject(ty, {contents = Some (_, p)}) ->
+        free_vars_rec false ty; List.iter (free_vars_rec true) p
+*)
+    | Tobject (ty, _), _ ->
+        free_vars_rec false ty
+    | Tfield (_, _, ty1, ty2), _ ->
+        free_vars_rec true ty1; free_vars_rec false ty2
+    | Tvariant row, _ ->
+        let row = row_repr row in
+        iter_row (free_vars_rec true) row;
+        if not (static_row row) then free_vars_rec false row.row_more
+    | _    ->
+        iter_type_expr (free_vars_rec true) ty
+
+let free_vars ?env ty =
+  free_variables := [];
+  really_closed := env;
+  free_vars_rec true ty;
+  let res = !free_variables in
+  free_variables := [];
+  really_closed := None;
+  res
+
+let free_variables ?env ty =
+  let tl = List.map fst (free_vars ?env ty) in
+  unmark_type ty;
+  tl
+
+let closed_type ty =
+  match free_vars ty with
+      []           -> ()
+  | (v, real) :: _ -> raise (Non_closed (v, real))
+
+let closed_parameterized_type params ty =
+  List.iter mark_type params;
+  let ok =
+    try closed_type ty; true with Non_closed _ -> false in
+  List.iter unmark_type params;
+  unmark_type ty;
+  ok
+
+let closed_type_decl decl =
+  try
+    List.iter mark_type decl.type_params;
+    begin match decl.type_kind with
+      Type_abstract ->
+        ()
+    | Type_variant (v, _rep) ->
+        List.iter
+          (fun {cd_args; cd_res; _} ->
+            match cd_res with
+            | Some _ -> ()
+            | None ->
+                match cd_args with
+                | Cstr_tuple l ->  List.iter closed_type l
+                | Cstr_record l -> List.iter (fun l -> closed_type l.ld_type) l
+          )
+          v
+    | Type_record(r, _rep) ->
+        List.iter (fun l -> closed_type l.ld_type) r
+    | Type_open -> ()
+    end;
+    begin match decl.type_manifest with
+      None    -> ()
+    | Some ty -> closed_type ty
+    end;
+    unmark_type_decl decl;
+    None
+  with Non_closed (ty, _) ->
+    unmark_type_decl decl;
+    Some ty
+
+let closed_extension_constructor ext =
+  try
+    List.iter mark_type ext.ext_type_params;
+    begin match ext.ext_ret_type with
+    | Some _ -> ()
+    | None -> iter_type_expr_cstr_args closed_type ext.ext_args
+    end;
+    unmark_extension_constructor ext;
+    None
+  with Non_closed (ty, _) ->
+    unmark_extension_constructor ext;
+    Some ty
+
+type closed_class_failure =
+    CC_Method of type_expr * bool * string * type_expr
+  | CC_Value of type_expr * bool * string * type_expr
+
+exception CCFailure of closed_class_failure
+
+let closed_class params sign =
+  let ty = object_fields (repr sign.csig_self) in
+  let (fields, rest) = flatten_fields ty in
+  List.iter mark_type params;
+  mark_type rest;
+  List.iter
+    (fun (lab, _, ty) -> if lab = dummy_method then mark_type ty)
+    fields;
+  try
+    ignore (try_mark_node (repr sign.csig_self));
+    List.iter
+      (fun (lab, kind, ty) ->
+        if field_kind_repr kind = Fpresent then
+        try closed_type ty with Non_closed (ty0, real) ->
+          raise (CCFailure (CC_Method (ty0, real, lab, ty))))
+      fields;
+    mark_type_params (repr sign.csig_self);
+    List.iter unmark_type params;
+    unmark_class_signature sign;
+    None
+  with CCFailure reason ->
+    mark_type_params (repr sign.csig_self);
+    List.iter unmark_type params;
+    unmark_class_signature sign;
+    Some reason
+
+
+                            (**********************)
+                            (*  Type duplication  *)
+                            (**********************)
+
+
+(* Duplicate a type, preserving only type variables *)
+let duplicate_type ty =
+  Subst.type_expr Subst.identity ty
+
+(* Same, for class types *)
+let duplicate_class_type ty =
+  Subst.class_type Subst.identity ty
+
+
+                         (*****************************)
+                         (*  Type level manipulation  *)
+                         (*****************************)
+
+(*
+   It would be a bit more efficient to remove abbreviation expansions
+   rather than generalizing them: these expansions will usually not be
+   used anymore. However, this is not possible in the general case, as
+   [expand_abbrev] (via [subst]) requires these expansions to be
+   preserved. Does it worth duplicating this code ?
+*)
+let rec generalize ty =
+  let ty = repr ty in
+  if (ty.level > !current_level) && (ty.level <> generic_level) then begin
+    set_level ty generic_level;
+    (* recur into abbrev for the speed *)
+    begin match ty.desc with
+      Tconstr (_, _, abbrev) ->
+        iter_abbrev generalize !abbrev
+    | _ -> ()
+    end;
+    iter_type_expr generalize ty
+  end
+
+let generalize ty =
+  simple_abbrevs := Mnil;
+  generalize ty
+
+(* Generalize the structure and lower the variables *)
+
+let rec generalize_structure ty =
+  let ty = repr ty in
+  if ty.level <> generic_level then begin
+    if is_Tvar ty && ty.level > !current_level then
+      set_level ty !current_level
+    else if
+      ty.level > !current_level &&
+      match ty.desc with
+        Tconstr (p, _, abbrev) ->
+          not (is_object_type p) && (abbrev := Mnil; true)
+      | _ -> true
+    then begin
+      set_level ty generic_level;
+      iter_type_expr generalize_structure ty
+    end
+  end
+
+let generalize_structure ty =
+  simple_abbrevs := Mnil;
+  generalize_structure ty
+
+(* Generalize the spine of a function, if the level >= !current_level *)
+
+let rec generalize_spine ty =
+  let ty = repr ty in
+  if ty.level < !current_level || ty.level = generic_level then () else
+  match ty.desc with
+    Tarrow (_, ty1, ty2, _) ->
+      set_level ty generic_level;
+      generalize_spine ty1;
+      generalize_spine ty2;
+  | Tpoly (ty', _) ->
+      set_level ty generic_level;
+      generalize_spine ty'
+  | Ttuple tyl ->
+      set_level ty generic_level;
+      List.iter generalize_spine tyl
+  | Tpackage (_, fl) ->
+      set_level ty generic_level;
+      List.iter (fun (_n, ty) -> generalize_spine ty) fl
+  | Tconstr (p, tyl, memo) when not (is_object_type p) ->
+      set_level ty generic_level;
+      memo := Mnil;
+      List.iter generalize_spine tyl
+  | _ -> ()
+
+let forward_try_expand_safe = (* Forward declaration *)
+  ref (fun _env _ty -> assert false)
+
+(*
+   Lower the levels of a type (assume [level] is not
+   [generic_level]).
+*)
+
+let rec normalize_package_path env p =
+  let t =
+    try (Env.find_modtype p env).mtd_type
+    with Not_found -> None
+  in
+  match t with
+  | Some (Mty_ident p) -> normalize_package_path env p
+  | Some (Mty_signature _ | Mty_functor _ | Mty_alias _ | Mty_for_hole)
+  | None ->
+      match p with
+        Path.Pdot (p1, s) ->
+          (* For module aliases *)
+          let p1' = Env.normalize_module_path None env p1 in
+          if Path.same p1 p1' then p else
+          normalize_package_path env (Path.Pdot (p1', s))
+      | _ -> p
+
+let rec check_scope_escape env level ty =
+  let ty = repr ty in
+  let orig_level = ty.level in
+  if try_logged_mark_node ty then begin
+    if level < ty.scope then
+      raise_scope_escape_exn ty;
+    begin match ty.desc with
+    | Tconstr (p, _, _) when level < Path.scope p ->
+        begin match !forward_try_expand_safe env ty with
+        | ty' ->
+            check_scope_escape env level ty'
+        | exception Cannot_expand ->
+            raise_escape_exn (Constructor p)
+        end
+    | Tpackage (p, fl) when level < Path.scope p ->
+        let p' = normalize_package_path env p in
+        if Path.same p p' then raise_escape_exn (Module_type p);
+        check_scope_escape env level
+          (Btype.newty2 orig_level (Tpackage (p', fl)))
+    | _ ->
+      iter_type_expr (check_scope_escape env level) ty
+    end;
+  end
+
+let check_scope_escape env level ty =
+  let snap = snapshot () in
+  try check_scope_escape env level ty; backtrack snap
+  with Escape e ->
+    backtrack snap;
+    raise (Escape { e with context = Some ty })
+
+let rec update_scope scope ty =
+  let ty = repr ty in
+  if ty.scope < scope then begin
+    if ty.level < scope then raise_scope_escape_exn ty;
+    set_scope ty scope;
+    (* Only recurse in principal mode as this is not necessary for soundness *)
+    if !Clflags.principal then iter_type_expr (update_scope scope) ty
+  end
+
+let update_scope_for tr_exn scope ty =
+  try
+    update_scope scope ty
+  with Escape e -> raise_for tr_exn (Escape e)
+
+(* Note: the level of a type constructor must be greater than its binding
+    time. That way, a type constructor cannot escape the scope of its
+    definition, as would be the case in
+      let x = ref []
+      module M = struct type t let _ = (x : t list ref) end
+    (without this constraint, the type system would actually be unsound.)
+*)
+
+let rec update_level env level expand ty =
+  let ty = repr ty in
+  if ty.level > level then begin
+    if level < ty.scope then raise_scope_escape_exn ty;
+    match ty.desc with
+      Tconstr(p, _tl, _abbrev) when level < Path.scope p ->
+        (* Try first to replace an abbreviation by its expansion. *)
+        begin try
+          link_type ty (!forward_try_expand_safe env ty);
+          update_level env level expand ty
+        with Cannot_expand ->
+          raise_escape_exn (Constructor p)
+        end
+    | Tconstr(p, (_ :: _ as tl), _) ->
+        let variance =
+          try (Env.find_type p env).type_variance
+          with Not_found -> List.map (fun _ -> Variance.unknown) tl in
+        let needs_expand =
+          expand ||
+          List.exists2
+            (fun var ty -> var = Variance.null && (repr ty).level > level)
+            variance tl
+        in
+        begin try
+          if not needs_expand then raise Cannot_expand;
+          link_type ty (!forward_try_expand_safe env ty);
+          update_level env level expand ty
+        with Cannot_expand ->
+          set_level ty level;
+          iter_type_expr (update_level env level expand) ty
+        end
+    | Tpackage (p, fl) when level < Path.scope p ->
+        let p' = normalize_package_path env p in
+        if Path.same p p' then raise_escape_exn (Module_type p);
+        set_type_desc ty (Tpackage (p', fl));
+        update_level env level expand ty
+    | Tobject(_, ({contents=Some(p, _tl)} as nm))
+      when level < Path.scope p ->
+        set_name nm None;
+        update_level env level expand ty
+    | Tvariant row ->
+        let row = row_repr row in
+        begin match row.row_name with
+        | Some (p, _tl) when level < Path.scope p ->
+            set_type_desc ty (Tvariant {row with row_name = None})
+        | _ -> ()
+        end;
+        set_level ty level;
+        iter_type_expr (update_level env level expand) ty
+    | Tfield(lab, _, ty1, _)
+      when lab = dummy_method && (repr ty1).level > level ->
+        raise_escape_exn Self
+    | _ ->
+        set_level ty level;
+        (* XXX what about abbreviations in Tconstr ? *)
+        iter_type_expr (update_level env level expand) ty
+  end
+
+(* First try without expanding, then expand everything,
+   to avoid combinatorial blow-up *)
+let update_level env level ty =
+  let ty = repr ty in
+  if ty.level > level then begin
+    let snap = snapshot () in
+    try
+      update_level env level false ty
+    with Escape _ ->
+      backtrack snap;
+      update_level env level true ty
+  end
+
+let update_level_for tr_exn env level ty =
+  try
+    update_level env level ty
+  with Escape e -> raise_for tr_exn (Escape e)
+
+(* Lower level of type variables inside contravariant branches *)
+
+let rec lower_contravariant env var_level visited contra ty =
+  let ty = repr ty in
+  let must_visit =
+    ty.level > var_level &&
+    match Hashtbl.find visited ty.id with
+    | done_contra -> contra && not done_contra
+    | exception Not_found -> true
+  in
+  if must_visit then begin
+    Hashtbl.add visited ty.id contra;
+    let lower_rec = lower_contravariant env var_level visited in
+    match ty.desc with
+      Tvar _ -> if contra then set_level ty var_level
+    | Tconstr (_, [], _) -> ()
+    | Tconstr (path, tyl, _abbrev) ->
+       let variance, maybe_expand =
+         try
+           let typ = Env.find_type path env in
+           typ.type_variance,
+           typ.type_kind = Type_abstract
+          with Not_found ->
+            (* See testsuite/tests/typing-missing-cmi-2 for an example *)
+            List.map (fun _ -> Variance.unknown) tyl,
+            false
+        in
+        if List.for_all ((=) Variance.null) variance then () else
+          let not_expanded () =
+            List.iter2
+              (fun v t ->
+                if v = Variance.null then () else
+                  if Variance.(mem May_weak v)
+                  then lower_rec true t
+                  else lower_rec contra t)
+              variance tyl in
+          if maybe_expand then (* we expand cautiously to avoid missing cmis *)
+            match !forward_try_expand_safe env ty with
+            | ty -> lower_rec contra ty
+            | exception Cannot_expand -> not_expanded ()
+          else not_expanded ()
+    | Tpackage (_, fl) ->
+        List.iter (fun (_n, ty) -> lower_rec true ty) fl
+    | Tarrow (_, t1, t2, _) ->
+        lower_rec true t1;
+        lower_rec contra t2
+    | _ ->
+        iter_type_expr (lower_rec contra) ty
+  end
+
+let lower_contravariant env ty =
+  simple_abbrevs := Mnil;
+  lower_contravariant env !nongen_level (Hashtbl.create 7) false ty
+
+(* Correct the levels of type [ty]. *)
+let correct_levels ty =
+  duplicate_type ty
+
+(* Only generalize the type ty0 in ty *)
+let limited_generalize ty0 ty =
+  let ty0 = repr ty0 in
+
+  let graph = Hashtbl.create 17 in
+  let idx = ref lowest_level in
+  let roots = ref [] in
+
+  let rec inverse pty ty =
+    let ty = repr ty in
+    if (ty.level > !current_level) || (ty.level = generic_level) then begin
+      decr idx;
+      Hashtbl.add graph !idx (ty, ref pty);
+      if (ty.level = generic_level) || (ty == ty0) then
+        roots := ty :: !roots;
+      set_level ty !idx;
+      iter_type_expr (inverse [ty]) ty
+    end else if ty.level < lowest_level then begin
+      let (_, parents) = Hashtbl.find graph ty.level in
+      parents := pty @ !parents
+    end
+
+  and generalize_parents ty =
+    let idx = ty.level in
+    if idx <> generic_level then begin
+      set_level ty generic_level;
+      List.iter generalize_parents !(snd (Hashtbl.find graph idx));
+      (* Special case for rows: must generalize the row variable *)
+      match ty.desc with
+        Tvariant row ->
+          let more = row_more row in
+          let lv = more.level in
+          if (lv < lowest_level || lv > !current_level)
+          && lv <> generic_level then set_level more generic_level
+      | _ -> ()
+    end
+  in
+
+  inverse [] ty;
+  if ty0.level < lowest_level then
+    iter_type_expr (inverse []) ty0;
+  List.iter generalize_parents !roots;
+  Hashtbl.iter
+    (fun _ (ty, _) ->
+       if ty.level <> generic_level then set_level ty !current_level)
+    graph
+
+
+(* Compute statically the free univars of all nodes in a type *)
+(* This avoids doing it repeatedly during instantiation *)
+
+type inv_type_expr =
+    { inv_type : type_expr;
+      mutable inv_parents : inv_type_expr list }
+
+let rec inv_type hash pty ty =
+  let ty = repr ty in
+  try
+    let inv = TypeHash.find hash ty in
+    inv.inv_parents <- pty @ inv.inv_parents
+  with Not_found ->
+    let inv = { inv_type = ty; inv_parents = pty } in
+    TypeHash.add hash ty inv;
+    iter_type_expr (inv_type hash [inv]) ty
+
+let compute_univars ty =
+  let inverted = TypeHash.create 17 in
+  inv_type inverted [] ty;
+  let node_univars = TypeHash.create 17 in
+  let rec add_univar univ inv =
+    match inv.inv_type.desc with
+      Tpoly (_ty, tl) when List.memq univ (List.map repr tl) -> ()
+    | _ ->
+        try
+          let univs = TypeHash.find node_univars inv.inv_type in
+          if not (TypeSet.mem univ !univs) then begin
+            univs := TypeSet.add univ !univs;
+            List.iter (add_univar univ) inv.inv_parents
+          end
+        with Not_found ->
+          TypeHash.add node_univars inv.inv_type (ref(TypeSet.singleton univ));
+          List.iter (add_univar univ) inv.inv_parents
+  in
+  TypeHash.iter (fun ty inv -> if is_Tunivar ty then add_univar ty inv)
+    inverted;
+  fun ty ->
+    try !(TypeHash.find node_univars ty) with Not_found -> TypeSet.empty
+
+
+let fully_generic ty =
+  let rec aux ty =
+    let ty = repr ty in
+    if not_marked_node ty then
+      if ty.level = generic_level then
+        (flip_mark_node ty; iter_type_expr aux ty)
+      else raise Exit
+  in
+  let res = try aux ty; true with Exit -> false in
+  unmark_type ty;
+  res
+
+
+                              (*******************)
+                              (*  Instantiation  *)
+                              (*******************)
+
+
+let rec find_repr p1 =
+  function
+    Mnil ->
+      None
+  | Mcons (Public, p2, ty, _, _) when Path.same p1 p2 ->
+      Some ty
+  | Mcons (_, _, _, _, rem) ->
+      find_repr p1 rem
+  | Mlink {contents = rem} ->
+      find_repr p1 rem
+
+(*
+   Generic nodes are duplicated, while non-generic nodes are left
+   as-is.
+   During instantiation, the description of a generic node is first
+   replaced by a link to a stub ([Tsubst (newvar ())]). Once the
+   copy is made, it replaces the stub.
+   After instantiation, the description of generic node, which was
+   stored by [save_desc], must be put back, using [cleanup_types].
+*)
+
+let abbreviations = ref (ref Mnil)
+  (* Abbreviation memorized. *)
+
+(* partial: we may not wish to copy the non generic types
+   before we call type_pat *)
+let rec copy ?partial ?keep_names scope ty =
+  let copy = copy ?partial ?keep_names scope in
+  let ty = repr ty in
+  match ty.desc with
+    Tsubst (ty, _) -> ty
+  | _ ->
+    if ty.level <> generic_level && partial = None then ty else
+    (* We only forget types that are non generic and do not contain
+       free univars *)
+    let forget =
+      if ty.level = generic_level then generic_level else
+      match partial with
+        None -> assert false
+      | Some (free_univars, keep) ->
+          if TypeSet.is_empty (free_univars ty) then
+            if keep then ty.level else !current_level
+          else generic_level
+    in
+    if forget <> generic_level then newty2 forget (Tvar None) else
+    let desc = ty.desc in
+    For_copy.save_desc scope ty desc;
+    let t = newvar() in          (* Stub *)
+    set_scope t ty.scope;
+    Private_type_expr.set_desc ty (Tsubst (t, None));
+    Private_type_expr.set_desc t
+      begin match desc with
+      | Tconstr (p, tl, _) ->
+          let abbrevs = proper_abbrevs p tl !abbreviations in
+          begin match find_repr p !abbrevs with
+            Some ty when repr ty != t ->
+              Tlink ty
+          | _ ->
+          (*
+             One must allocate a new reference, so that abbrevia-
+             tions belonging to different branches of a type are
+             independent.
+             Moreover, a reference containing a [Mcons] must be
+             shared, so that the memorized expansion of an abbrevi-
+             ation can be released by changing the content of just
+             one reference.
+          *)
+              Tconstr (p, List.map copy tl,
+                       ref (match !(!abbreviations) with
+                              Mcons _ -> Mlink !abbreviations
+                            | abbrev  -> abbrev))
+          end
+      | Tvariant row0 ->
+          let row = row_repr row0 in
+          let more = repr row.row_more in
+          (* We must substitute in a subtle way *)
+          (* Tsubst takes a tuple containing the row var and the variant *)
+          begin match more.desc with
+            Tsubst (_, Some ty2) ->
+              (* This variant type has been already copied *)
+              Private_type_expr.set_desc ty (Tsubst (ty2, None));
+              (* avoid Tlink in the new type *)
+              Tlink ty2
+          | _ ->
+              (* If the row variable is not generic, we must keep it *)
+              let keep = more.level <> generic_level && partial = None in
+              let more' =
+                match more.desc with
+                  Tsubst (ty, None) -> ty
+                  (* TODO: is this case possible?
+                     possibly an interaction with (copy more) below? *)
+                | Tconstr _ | Tnil ->
+                    For_copy.save_desc scope more more.desc;
+                    copy more
+                | Tvar _ | Tunivar _ ->
+                    For_copy.save_desc scope more more.desc;
+                    if keep then more else newty more.desc
+                |  _ -> assert false
+              in
+              let row =
+                match repr more' with (* PR#6163 *)
+                  {desc=Tconstr (x,_,_)} when not (is_fixed row) ->
+                    {row with row_fixed = Some (Reified x)}
+                | _ -> row
+              in
+              (* Open row if partial for pattern and contains Reither *)
+              let more', row =
+                match partial with
+                  Some (free_univars, false) ->
+                    let more' =
+                      if more.id <> more'.id then
+                        more' (* we've already made a copy *)
+                      else
+                        newvar ()
+                    in
+                    let not_reither (_, f) =
+                      match row_field_repr f with
+                        Reither _ -> false
+                      | _ -> true
+                    in
+                    if row.row_closed && not (is_fixed row)
+                    && TypeSet.is_empty (free_univars ty)
+                    && not (List.for_all not_reither row.row_fields) then
+                      (more',
+                       {row_fields = List.filter not_reither row.row_fields;
+                        row_more = more'; row_bound = ();
+                        row_closed = false; row_fixed = None; row_name = None})
+                    else (more', row)
+                | _ -> (more', row)
+              in
+              (* Register new type first for recursion *)
+              Private_type_expr.set_desc
+                more (Tsubst (more', Some t));
+              (* Return a new copy *)
+              Tvariant (copy_row copy true row keep more')
+          end
+      | Tfield (_p, k, _ty1, ty2) ->
+          begin match field_kind_repr k with
+            Fabsent  -> Tlink (copy ty2)
+          | Fpresent -> copy_type_desc copy desc
+          | Fvar r ->
+              For_copy.dup_kind scope r;
+              copy_type_desc copy desc
+          end
+      | Tobject (ty1, _) when partial <> None ->
+          Tobject (copy ty1, ref None)
+      | _ -> copy_type_desc ?keep_names copy desc
+      end;
+    t
+
+(**** Variants of instantiations ****)
+
+let instance ?partial sch =
+  let partial =
+    match partial with
+      None -> None
+    | Some keep -> Some (compute_univars sch, keep)
+  in
+  For_copy.with_scope (fun scope -> copy ?partial scope sch)
+
+let generic_instance sch =
+  let old = !current_level in
+  current_level := generic_level;
+  let ty = instance sch in
+  current_level := old;
+  ty
+
+let instance_list schl =
+  For_copy.with_scope (fun scope -> List.map (fun t -> copy scope t) schl)
+
+let reified_var_counter = ref Vars.empty
+let reset_reified_var_counter () =
+  reified_var_counter := Vars.empty
+
+(* names given to new type constructors.
+   Used for existential types and
+   local constraints *)
+let get_new_abstract_name s =
+  let index =
+    try Vars.find s !reified_var_counter + 1
+    with Not_found -> 0 in
+  reified_var_counter := Vars.add s index !reified_var_counter;
+  if index = 0 && s <> "" && s.[String.length s - 1] <> '$' then s else
+  Printf.sprintf "%s%d" s index
+
+let new_local_type ?(loc = Location.none) ?manifest_and_scope () =
+  let manifest, expansion_scope =
+    match manifest_and_scope with
+      None -> None, Btype.lowest_level
+    | Some (ty, scope) -> Some ty, scope
+  in
+  {
+    type_params = [];
+    type_arity = 0;
+    type_kind = Type_abstract;
+    type_private = Public;
+    type_manifest = manifest;
+    type_variance = [];
+    type_separability = [];
+    type_is_newtype = true;
+    type_expansion_scope = expansion_scope;
+    type_loc = loc;
+    type_attributes = [];
+    type_immediate = Unknown;
+    type_unboxed_default = false;
+    type_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+  }
+
+let existential_name cstr ty = match repr ty with
+  | {desc = Tvar (Some name)} -> "$" ^ cstr.cstr_name ^ "_'" ^ name
+  | _ -> "$" ^ cstr.cstr_name
+
+let instance_constructor ?in_pattern cstr =
+  For_copy.with_scope (fun scope ->
+    begin match in_pattern with
+    | None -> ()
+    | Some (env, fresh_constr_scope) ->
+        let process existential =
+          let decl = new_local_type () in
+          let name = existential_name cstr existential in
+          let (id, new_env) =
+            Env.enter_type (get_new_abstract_name name) decl !env
+              ~scope:fresh_constr_scope in
+          env := new_env;
+          let to_unify = newty (Tconstr (Path.Pident id,[],ref Mnil)) in
+          let tv = copy scope existential in
+          assert (is_Tvar tv);
+          link_type tv to_unify
+        in
+        List.iter process cstr.cstr_existentials
+    end;
+    let ty_res = copy scope cstr.cstr_res in
+    let ty_args = List.map (copy scope) cstr.cstr_args in
+    let ty_ex = List.map (copy scope) cstr.cstr_existentials in
+    (ty_args, ty_res, ty_ex)
+  )
+
+let instance_parameterized_type ?keep_names sch_args sch =
+  For_copy.with_scope (fun scope ->
+    let ty_args = List.map (fun t -> copy ?keep_names scope t) sch_args in
+    let ty = copy scope sch in
+    (ty_args, ty)
+  )
+
+let instance_parameterized_type_2 sch_args sch_lst sch =
+  For_copy.with_scope (fun scope ->
+    let ty_args = List.map (copy scope) sch_args in
+    let ty_lst = List.map (copy scope) sch_lst in
+    let ty = copy scope sch in
+    (ty_args, ty_lst, ty)
+  )
+
+let map_kind f = function
+  | Type_abstract -> Type_abstract
+  | Type_open -> Type_open
+  | Type_variant (cl, rep) ->
+      Type_variant (
+        List.map
+          (fun c ->
+             {c with
+              cd_args = map_type_expr_cstr_args f c.cd_args;
+              cd_res = Option.map f c.cd_res
+             })
+          cl, rep)
+  | Type_record (fl, rr) ->
+      Type_record (
+        List.map
+          (fun l ->
+             {l with ld_type = f l.ld_type}
+          ) fl, rr)
+
+
+let instance_declaration decl =
+  For_copy.with_scope (fun scope ->
+    {decl with type_params = List.map (copy scope) decl.type_params;
+     type_manifest = Option.map (copy scope) decl.type_manifest;
+     type_kind = map_kind (copy scope) decl.type_kind;
+    }
+  )
+
+let generic_instance_declaration decl =
+  let old = !current_level in
+  current_level := generic_level;
+  let decl = instance_declaration decl in
+  current_level := old;
+  decl
+
+let instance_class params cty =
+  let rec copy_class_type scope = function
+    | Cty_constr (path, tyl, cty) ->
+        let tyl' = List.map (copy scope) tyl in
+        let cty' = copy_class_type scope cty in
+        Cty_constr (path, tyl', cty')
+    | Cty_signature sign ->
+        Cty_signature
+          {csig_self = copy scope sign.csig_self;
+           csig_vars =
+             Vars.map (function (m, v, ty) -> (m, v, copy scope ty))
+               sign.csig_vars;
+           csig_concr = sign.csig_concr;
+           csig_inher =
+             List.map (fun (p,tl) -> (p, List.map (copy scope) tl))
+               sign.csig_inher}
+    | Cty_arrow (l, ty, cty) ->
+        Cty_arrow (l, copy scope ty, copy_class_type scope cty)
+  in
+  For_copy.with_scope (fun scope ->
+    let params' = List.map (copy scope) params in
+    let cty' = copy_class_type scope cty in
+    (params', cty')
+  )
+
+(**** Instantiation for types with free universal variables ****)
+
+let rec diff_list l1 l2 =
+  if l1 == l2 then [] else
+  match l1 with [] -> invalid_arg "Ctype.diff_list"
+  | a :: l1 -> a :: diff_list l1 l2
+
+let conflicts free bound =
+  let bound = List.map repr bound in
+  TypeSet.exists (fun t -> List.memq (repr t) bound) free
+
+let delayed_copy = ref []
+    (* copying to do later *)
+
+(* Copy without sharing until there are no free univars left *)
+(* all free univars must be included in [visited]            *)
+let rec copy_sep cleanup_scope fixed free bound visited ty =
+  let ty = repr ty in
+  let univars = free ty in
+  if TypeSet.is_empty univars then
+    if ty.level <> generic_level then ty else
+    let t = newvar () in
+    delayed_copy :=
+      lazy (Private_type_expr.set_desc t (Tlink (copy cleanup_scope ty)))
+      :: !delayed_copy;
+    t
+  else try
+    let t, bound_t = List.assq ty visited in
+    let dl = if is_Tunivar ty then [] else diff_list bound bound_t in
+    if dl <> [] && conflicts univars dl then raise Not_found;
+    t
+  with Not_found -> begin
+    let t = newvar() in          (* Stub *)
+    let visited =
+      match ty.desc with
+        Tarrow _ | Ttuple _ | Tvariant _ | Tconstr _ | Tobject _ | Tpackage _ ->
+          (ty,(t,bound)) :: visited
+      | Tvar _ | Tfield _ | Tnil | Tpoly _ | Tunivar _ ->
+          visited
+      | Tlink _ | Tsubst _ ->
+          assert false
+    in
+    let copy_rec = copy_sep cleanup_scope fixed free bound visited in
+    Private_type_expr.set_desc t
+      begin match ty.desc with
+      | Tvariant row0 ->
+          let row = row_repr row0 in
+          let more = repr row.row_more in
+          (* We shall really check the level on the row variable *)
+          let keep = is_Tvar more && more.level <> generic_level in
+          let more' = copy_rec more in
+          let fixed' = fixed && (is_Tvar more || is_Tunivar more) in
+          let row = copy_row copy_rec fixed' row keep more' in
+          Tvariant row
+      | Tpoly (t1, tl) ->
+          let tl = List.map repr tl in
+          let tl' = List.map (fun t -> newty t.desc) tl in
+          let bound = tl @ bound in
+          let visited =
+            List.map2 (fun ty t -> ty,(t,bound)) tl tl' @ visited in
+          Tpoly (copy_sep cleanup_scope fixed free bound visited t1, tl')
+      | _ -> copy_type_desc copy_rec ty.desc
+      end;
+    t
+  end
+
+let instance_poly' cleanup_scope ~keep_names fixed univars sch =
+  (* In order to compute univars below, [sch] schould not contain [Tsubst] *)
+  let univars = List.map repr univars in
+  let copy_var ty =
+    match ty.desc with
+      Tunivar name -> if keep_names then newty (Tvar name) else newvar ()
+    | _ -> assert false
+  in
+  let vars = List.map copy_var univars in
+  let pairs = List.map2 (fun u v -> u, (v, [])) univars vars in
+  delayed_copy := [];
+  let ty = copy_sep cleanup_scope fixed (compute_univars sch) [] pairs sch in
+  List.iter Lazy.force !delayed_copy;
+  delayed_copy := [];
+  vars, ty
+
+let instance_poly ?(keep_names=false) fixed univars sch =
+  For_copy.with_scope (fun cleanup_scope ->
+    instance_poly' cleanup_scope ~keep_names fixed univars sch
+  )
+
+let instance_label fixed lbl =
+  For_copy.with_scope (fun scope ->
+    let vars, ty_arg =
+      match repr lbl.lbl_arg with
+        {desc = Tpoly (ty, tl)} ->
+          instance_poly' scope ~keep_names:false fixed tl ty
+      | _ ->
+          [], copy scope lbl.lbl_arg
+    in
+    (* call [copy] after [instance_poly] to avoid introducing [Tsubst] *)
+    let ty_res = copy scope lbl.lbl_res in
+    (vars, ty_arg, ty_res)
+  )
+
+(**** Instantiation with parameter substitution ****)
+
+let unify' = (* Forward declaration *)
+  ref (fun _env _ty1 _ty2 -> assert false)
+
+
+let subst env level priv abbrev ty params args body =
+  if List.length params <> List.length args then raise Cannot_subst;
+  let old_level = !current_level in
+  current_level := level;
+  let body0 = newvar () in          (* Stub *)
+  let undo_abbrev =
+    match ty with
+    | None -> fun () -> () (* No abbreviation added *)
+    | Some ({desc = Tconstr (path, tl, _)} as ty) ->
+        let abbrev = proper_abbrevs path tl abbrev in
+        memorize_abbrev abbrev priv path ty body0;
+        fun () -> forget_abbrev abbrev path
+    | _ ->
+        assert false
+  in
+  abbreviations := abbrev;
+  let (params', body') = instance_parameterized_type params body in
+  abbreviations := ref Mnil;
+  try
+    !unify' env body0 body';
+    List.iter2 (!unify' env) params' args;
+    current_level := old_level;
+    body'
+  with Unify _ ->
+    current_level := old_level;
+    undo_abbrev ();
+    raise Cannot_subst
+
+(*
+   Only the shape of the type matters, not whether it is generic or
+   not. [generic_level] might be somewhat slower, but it ensures
+   invariants on types are enforced (decreasing levels), and we don't
+   care about efficiency here.
+*)
+let apply env params body args =
+  try
+    subst env generic_level Public (ref Mnil) None params args body
+  with
+    Cannot_subst -> raise Cannot_apply
+
+let () = Subst.ctype_apply_env_empty := apply Env.empty
+
+                              (****************************)
+                              (*  Abbreviation expansion  *)
+                              (****************************)
+
+(*
+   If the environment has changed, memorized expansions might not
+   be correct anymore, and so we flush the cache. This is safe but
+   quite pessimistic: it would be enough to flush the cache when a
+   type or module definition is overridden in the environment.
+*)
+let previous_env = ref Env.empty
+(*let string_of_kind = function Public -> "public" | Private -> "private"*)
+let check_abbrev_env env =
+  if env != !previous_env then begin
+    (* prerr_endline "cleanup expansion cache"; *)
+    cleanup_abbrev ();
+    previous_env := env
+  end
+
+
+(* Expand an abbreviation. The expansion is memorized. *)
+(*
+   Assume the level is greater than the path binding time of the
+   expanded abbreviation.
+*)
+(*
+   An abbreviation expansion will fail in either of these cases:
+   1. The type constructor does not correspond to a manifest type.
+   2. The type constructor is defined in an external file, and this
+      file is not in the path (missing -I options).
+   3. The type constructor is not in the "local" environment. This can
+      happens when a non-generic type variable has been instantiated
+      afterwards to the not yet defined type constructor. (Actually,
+      this cannot happen at the moment due to the strong constraints
+      between type levels and constructor binding time.)
+   4. The expansion requires the expansion of another abbreviation,
+      and this other expansion fails.
+*)
+let expand_abbrev_gen kind find_type_expansion env ty =
+  check_abbrev_env env;
+  match ty with
+    {desc = Tconstr (path, args, abbrev); level = level; scope} ->
+      let lookup_abbrev = proper_abbrevs path args abbrev in
+      begin match find_expans kind path !lookup_abbrev with
+        Some ty' ->
+          (* prerr_endline
+            ("found a "^string_of_kind kind^" expansion for "^Path.name path);*)
+          if level <> generic_level then
+            begin try
+              update_level env level ty'
+            with Escape _ ->
+              (* XXX This should not happen.
+                 However, levels are not correctly restored after a
+                 typing error *)
+              ()
+            end;
+          begin try
+            update_scope scope ty';
+          with Escape _ ->
+            (* XXX This should not happen.
+               However, levels are not correctly restored after a
+               typing error *)
+            ()
+          end;
+          let ty' = repr ty' in
+          (* assert (ty != ty'); *) (* PR#7324 *)
+          ty'
+      | None ->
+          match find_type_expansion path env with
+          | exception Not_found ->
+            (* another way to expand is to normalize the path itself *)
+            let path' = Env.normalize_type_path None env path in
+            if Path.same path path' then raise Cannot_expand
+            else newty2 level (Tconstr (path', args, abbrev))
+          | (params, body, lv) ->
+            (* prerr_endline
+              ("add a "^string_of_kind kind^" expansion for "^Path.name path);*)
+            let ty' =
+              try
+                subst env level kind abbrev (Some ty) params args body
+              with Cannot_subst -> raise_escape_exn Constraint
+            in
+            (* For gadts, remember type as non exportable *)
+            (* The ambiguous level registered for ty' should be the highest *)
+            (* if !trace_gadt_instances then begin *)
+            let scope = Int.max lv ty.scope in
+            update_scope scope ty;
+            update_scope scope ty';
+            ty'
+      end
+  | _ ->
+      assert false
+
+(* Expand respecting privacy *)
+let expand_abbrev env ty =
+  expand_abbrev_gen Public Env.find_type_expansion env ty
+
+(* Expand once the head of a type *)
+let expand_head_once env ty =
+  try
+    expand_abbrev env (repr ty)
+  with Cannot_expand | Escape _ -> assert false
+
+(* Check whether a type can be expanded *)
+let safe_abbrev env ty =
+  let snap = Btype.snapshot () in
+  try ignore (expand_abbrev env ty); true with
+    Cannot_expand ->
+      Btype.backtrack snap;
+      false
+  | Escape _ ->
+      Btype.backtrack snap;
+      cleanup_abbrev ();
+      false
+
+(* Expand the head of a type once.
+   Raise Cannot_expand if the type cannot be expanded.
+   May raise Escape, if a recursion was hidden in the type. *)
+let try_expand_once env ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tconstr _ -> repr (expand_abbrev env ty)
+  | _ -> raise Cannot_expand
+
+(* This one only raises Cannot_expand *)
+let try_expand_safe env ty =
+  let snap = Btype.snapshot () in
+  try try_expand_once env ty
+  with Escape _ ->
+    Btype.backtrack snap; cleanup_abbrev (); raise Cannot_expand
+
+(* Fully expand the head of a type. *)
+let rec try_expand_head try_once env ty =
+  let ty' = try_once env ty in
+  try try_expand_head try_once env ty'
+  with Cannot_expand -> ty'
+
+(* Unsafe full expansion, may raise [Unify [Escape _]]. *)
+let expand_head_unif env ty =
+  try
+    try_expand_head try_expand_once env ty
+  with
+  | Cannot_expand -> repr ty
+  | Escape e -> raise_for Unify (Escape e)
+
+(* Safe version of expand_head, never fails *)
+let expand_head env ty =
+  try try_expand_head try_expand_safe env ty with Cannot_expand -> repr ty
+
+let _ = forward_try_expand_safe := try_expand_safe
+
+
+(* Expand until we find a non-abstract type declaration,
+   use try_expand_safe to avoid raising "Unify _" when
+   called on recursive types
+ *)
+
+let rec extract_concrete_typedecl env ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tconstr (p, _, _) ->
+      let decl = Env.find_type p env in
+      if decl.type_kind <> Type_abstract then (p, p, decl) else
+      let ty =
+        try try_expand_safe env ty with Cannot_expand -> raise Not_found
+      in
+      let (_, p', decl) = extract_concrete_typedecl env ty in
+        (p, p', decl)
+  | _ -> raise Not_found
+
+(* Implementing function [expand_head_opt], the compiler's own version of
+   [expand_head] used for type-based optimisations.
+   [expand_head_opt] uses [Env.find_type_expansion_opt] to access the
+   manifest type information of private abstract data types which is
+   normally hidden to the type-checker out of the implementation module of
+   the private abbreviation. *)
+
+let expand_abbrev_opt env ty =
+  expand_abbrev_gen Private Env.find_type_expansion_opt env ty
+
+let safe_abbrev_opt env ty =
+  let snap = Btype.snapshot () in
+  try ignore (expand_abbrev_opt env ty); true
+  with Cannot_expand | Escape _ ->
+    Btype.backtrack snap;
+    false
+
+let try_expand_once_opt env ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tconstr _ -> repr (expand_abbrev_opt env ty)
+  | _ -> raise Cannot_expand
+
+let try_expand_safe_opt env ty =
+  let snap = Btype.snapshot () in
+  try try_expand_once_opt env ty
+  with Escape _ ->
+    Btype.backtrack snap; raise Cannot_expand
+
+let expand_head_opt env ty =
+  try try_expand_head try_expand_safe_opt env ty with Cannot_expand -> repr ty
+
+(* Recursively expand the head of a type.
+   Also expand #-types.
+
+   Error printing relies on [full_expand] returning exactly its input (i.e., a
+   physically equal type) when nothing changes. *)
+let full_expand ~may_forget_scope env ty =
+  let ty =
+    if may_forget_scope then
+      let ty = repr ty in
+      try expand_head_unif env ty with Unify _ ->
+        (* #10277: forget scopes when printing trace *)
+        begin_def ();
+        init_def ty.level;
+        let ty =
+          (* The same as [expand_head], except in the failing case we return the
+             *original* type, not [correct_levels ty].*)
+          try try_expand_head try_expand_safe env (correct_levels ty) with
+          | Cannot_expand -> repr ty
+        in
+        end_def ();
+        ty
+    else expand_head env ty
+  in
+  let ty = repr ty in
+  match ty.desc with
+    Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar (repr v) ->
+      newty2 ty.level (Tobject (fi, ref None))
+  | _ ->
+      ty
+
+(*
+   Check whether the abbreviation expands to a well-defined type.
+   During the typing of a class, abbreviations for correspondings
+   types expand to non-generic types.
+*)
+let generic_abbrev env path =
+  try
+    let (_, body, _) = Env.find_type_expansion path env in
+    (repr body).level = generic_level
+  with
+    Not_found ->
+      false
+
+let generic_private_abbrev env path =
+  try
+    match Env.find_type path env with
+      {type_kind = Type_abstract;
+       type_private = Private;
+       type_manifest = Some body} ->
+         (repr body).level = generic_level
+    | _ -> false
+  with Not_found -> false
+
+let is_contractive env p =
+  try
+    let decl = Env.find_type p env in
+    in_pervasives p && decl.type_manifest = None || is_datatype decl
+  with Not_found -> false
+
+
+                              (*****************)
+                              (*  Occur check  *)
+                              (*****************)
+
+
+exception Occur
+
+let rec occur_rec env allow_recursive visited ty0 = function
+  | {desc=Tlink ty} ->
+      occur_rec env allow_recursive visited ty0 ty
+  | ty ->
+  if ty == ty0  then raise Occur;
+  match ty.desc with
+    Tconstr(p, _tl, _abbrev) ->
+      if allow_recursive && is_contractive env p then () else
+      begin try
+        if TypeSet.mem ty visited then raise Occur;
+        let visited = TypeSet.add ty visited in
+        iter_type_expr (occur_rec env allow_recursive visited ty0) ty
+      with Occur -> try
+        let ty' = try_expand_head try_expand_once env ty in
+        (* This call used to be inlined, but there seems no reason for it.
+           Message was referring to change in rev. 1.58 of the CVS repo. *)
+        occur_rec env allow_recursive visited ty0 ty'
+      with Cannot_expand ->
+        raise Occur
+      end
+  | Tobject _ | Tvariant _ ->
+      ()
+  | _ ->
+      if allow_recursive ||  TypeSet.mem ty visited then () else begin
+        let visited = TypeSet.add ty visited in
+        iter_type_expr (occur_rec env allow_recursive visited ty0) ty
+      end
+
+let type_changed = ref false (* trace possible changes to the studied type *)
+
+let merge r b = if b then r := true
+
+let occur env ty0 ty =
+  let allow_recursive =
+    !Clflags.recursive_types || !umode = Pattern && !allow_recursive_equation in
+  let old = !type_changed in
+  try
+    while
+      type_changed := false;
+      occur_rec env allow_recursive TypeSet.empty ty0 ty;
+      !type_changed
+    do () (* prerr_endline "changed" *) done;
+    merge type_changed old
+  with exn ->
+    merge type_changed old;
+    raise exn
+
+let occur_for tr_exn env t1 t2 =
+  try
+    occur env t1 t2
+  with Occur -> raise_for tr_exn (Rec_occur(t1, t2))
+
+let occur_in env ty0 t =
+  try occur env ty0 t; false with Occur -> true
+
+(* Check that a local constraint is well-founded *)
+(* PR#6405: not needed since we allow recursion and work on normalized types *)
+(* PR#6992: we actually need it for contractiveness *)
+(* This is a simplified version of occur, only for the rectypes case *)
+
+let rec local_non_recursive_abbrev ~allow_rec strict visited env p ty =
+  (*Format.eprintf "@[Check %s =@ %a@]@." (Path.name p) !Btype.print_raw ty;*)
+  let ty = repr ty in
+  if not (List.memq ty visited) then begin
+    match ty.desc with
+      Tconstr(p', args, _abbrev) ->
+        if Path.same p p' then raise Occur;
+        if allow_rec && not strict && is_contractive env p' then () else
+        let visited = ty :: visited in
+        begin try
+          (* try expanding, since [p] could be hidden *)
+          local_non_recursive_abbrev ~allow_rec strict visited env p
+            (try_expand_head try_expand_safe_opt env ty)
+        with Cannot_expand ->
+          let params =
+            try (Env.find_type p' env).type_params
+            with Not_found -> args
+          in
+          List.iter2
+            (fun tv ty ->
+              let strict = strict || not (is_Tvar (repr tv)) in
+              local_non_recursive_abbrev ~allow_rec strict visited env p ty)
+            params args
+        end
+    | Tobject _ | Tvariant _ when not strict ->
+        ()
+    | _ ->
+        if strict || not allow_rec then (* PR#7374 *)
+          let visited = ty :: visited in
+          iter_type_expr
+            (local_non_recursive_abbrev ~allow_rec true visited env p) ty
+  end
+
+let local_non_recursive_abbrev env p ty =
+  let allow_rec =
+    !Clflags.recursive_types || !umode = Pattern && !allow_recursive_equation in
+  try (* PR#7397: need to check trace_gadt_instances *)
+    wrap_trace_gadt_instances env
+      (local_non_recursive_abbrev ~allow_rec false [] env p) ty;
+    true
+  with Occur -> false
+
+
+                   (*****************************)
+                   (*  Polymorphic Unification  *)
+                   (*****************************)
+
+(* Since we cannot duplicate universal variables, unification must
+   be done at meta-level, using bindings in univar_pairs *)
+(* TODO: use find_opt *)
+let rec unify_univar t1 t2 = function
+    (cl1, cl2) :: rem ->
+      let find_univ t cl =
+        try
+          let (_, r) = List.find (fun (t',_) -> t == repr t') cl in
+          Some r
+        with Not_found -> None
+      in
+      begin match find_univ t1 cl1, find_univ t2 cl2 with
+        Some {contents=Some t'2}, Some _ when t2 == repr t'2 ->
+          ()
+      | Some({contents=None} as r1), Some({contents=None} as r2) ->
+          set_univar r1 t2; set_univar r2 t1
+      | None, None ->
+          unify_univar t1 t2 rem
+      | _ ->
+          raise Cannot_unify_universal_variables
+      end
+  | [] -> raise Cannot_unify_universal_variables
+
+(* The same as [unify_univar], but raises the appropriate exception instead of
+   [Cannot_unify_universal_variables] *)
+let unify_univar_for tr_exn t1 t2 univar_pairs =
+  try unify_univar t1 t2 univar_pairs
+  with Cannot_unify_universal_variables -> raise_unexplained_for tr_exn
+
+(* Test the occurrence of free univars in a type *)
+(* That's way too expensive. Must do some kind of caching *)
+(* If [inj_only=true], only check injective positions *)
+let occur_univar ?(inj_only=false) env ty =
+  let visited = ref TypeMap.empty in
+  let rec occur_rec bound ty =
+    let ty = repr ty in
+    if not_marked_node ty then
+      if TypeSet.is_empty bound then
+        (flip_mark_node ty; occur_desc bound ty)
+      else try
+        let bound' = TypeMap.find ty !visited in
+        if not (TypeSet.subset bound' bound) then begin
+          visited := TypeMap.add ty (TypeSet.inter bound bound') !visited;
+          occur_desc bound ty
+        end
+      with Not_found ->
+        visited := TypeMap.add ty bound !visited;
+        occur_desc bound ty
+  and occur_desc bound ty =
+      match ty.desc with
+        Tunivar _ ->
+          if not (TypeSet.mem ty bound) then
+            raise_escape_exn (Univ ty)
+      | Tpoly (ty, tyl) ->
+          let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in
+          occur_rec bound  ty
+      | Tconstr (_, [], _) -> ()
+      | Tconstr (p, tl, _) ->
+          begin try
+            let td = Env.find_type p env in
+            List.iter2
+              (fun t v ->
+                (* The null variance only occurs in type abbreviations and
+                   corresponds to type variables that do not occur in the
+                   definition (expansion would erase them completely).
+                   The type-checker consistently ignores type expressions
+                   in this position. Physical expansion, as done in `occur`,
+                   would be costly here, since we need to check inside
+                   object and variant types too. *)
+                if Variance.(if inj_only then mem Inj v else not (eq v null))
+                then occur_rec bound t)
+              tl td.type_variance
+          with Not_found ->
+            if not inj_only then List.iter (occur_rec bound) tl
+          end
+      | _ -> iter_type_expr (occur_rec bound) ty
+  in
+  Misc.try_finally (fun () ->
+      occur_rec TypeSet.empty ty
+    )
+    ~always:(fun () -> unmark_type ty)
+
+let has_free_univars env ty =
+  try occur_univar ~inj_only:false env ty; false with Escape _ -> true
+let has_injective_univars env ty =
+  try occur_univar ~inj_only:true env ty; false with Escape _ -> true
+
+let occur_univar_for tr_exn env ty =
+  try
+    occur_univar env ty
+  with Escape e -> raise_for tr_exn (Escape e)
+
+(* Grouping univars by families according to their binders *)
+let add_univars =
+  List.fold_left (fun s (t,_) -> TypeSet.add (repr t) s)
+
+let get_univar_family univar_pairs univars =
+  if univars = [] then TypeSet.empty else
+  let insert s = function
+      cl1, (_::_ as cl2) ->
+        if List.exists (fun (t1,_) -> TypeSet.mem (repr t1) s) cl1 then
+          add_univars s cl2
+        else s
+    | _ -> s
+  in
+  let s = List.fold_right TypeSet.add univars TypeSet.empty in
+  List.fold_left insert s univar_pairs
+
+(* Whether a family of univars escapes from a type *)
+let univars_escape env univar_pairs vl ty =
+  let family = get_univar_family univar_pairs vl in
+  let visited = ref TypeSet.empty in
+  let rec occur t =
+    let t = repr t in
+    if TypeSet.mem t !visited then () else begin
+      visited := TypeSet.add t !visited;
+      match t.desc with
+        Tpoly (t, tl) ->
+          if List.exists (fun t -> TypeSet.mem (repr t) family) tl then ()
+          else occur t
+      | Tunivar _ -> if TypeSet.mem t family then raise_escape_exn (Univ t)
+      | Tconstr (_, [], _) -> ()
+      | Tconstr (p, tl, _) ->
+          begin try
+            let td = Env.find_type p env in
+            List.iter2
+              (* see occur_univar *)
+              (fun t v -> if not Variance.(eq v null) then occur t)
+              tl td.type_variance
+          with Not_found ->
+            List.iter occur tl
+          end
+      | _ ->
+          iter_type_expr occur t
+    end
+  in
+  occur ty
+
+(* Wrapper checking that no variable escapes and updating univar_pairs *)
+let enter_poly env univar_pairs t1 tl1 t2 tl2 f =
+  let old_univars = !univar_pairs in
+  let known_univars =
+    List.fold_left (fun s (cl,_) -> add_univars s cl)
+      TypeSet.empty old_univars
+  in
+  let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
+  if List.exists (fun t -> TypeSet.mem t known_univars) tl1 then
+     univars_escape env old_univars tl1 (newty(Tpoly(t2,tl2)));
+  if List.exists (fun t -> TypeSet.mem t known_univars) tl2 then
+    univars_escape env old_univars tl2 (newty(Tpoly(t1,tl1)));
+  let cl1 = List.map (fun t -> t, ref None) tl1
+  and cl2 = List.map (fun t -> t, ref None) tl2 in
+  univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars;
+  Misc.try_finally (fun () -> f t1 t2)
+    ~always:(fun () -> univar_pairs := old_univars)
+
+let enter_poly_for tr_exn env univar_pairs t1 tl1 t2 tl2 f =
+  try
+    enter_poly env univar_pairs t1 tl1 t2 tl2 f
+  with Escape e -> raise_for tr_exn (Escape e)
+
+let univar_pairs = ref []
+
+(**** Instantiate a generic type into a poly type ***)
+
+let polyfy env ty vars =
+  let subst_univar scope ty =
+    let ty = repr ty in
+    match ty.desc with
+    | Tvar name when ty.level = generic_level ->
+        For_copy.save_desc scope ty ty.desc;
+        let t = newty (Tunivar name) in
+        Private_type_expr.set_desc ty (Tsubst (t, None));
+        Some t
+    | _ -> None
+  in
+  (* need to expand twice? cf. Ctype.unify2 *)
+  let vars = List.map (expand_head env) vars in
+  let vars = List.map (expand_head env) vars in
+  For_copy.with_scope (fun scope ->
+    let vars' = List.filter_map (subst_univar scope) vars in
+    let ty = copy scope ty in
+    let ty = newty2 ty.level (Tpoly(repr ty, vars')) in
+    let complete = List.length vars = List.length vars' in
+    ty, complete
+  )
+
+(* assumption: [ty] is fully generalized. *)
+let reify_univars env ty =
+  let vars = free_variables ty in
+  let ty, _ = polyfy env ty vars in
+  ty
+
+                              (*****************)
+                              (*  Unification  *)
+                              (*****************)
+
+
+
+let rec has_cached_expansion p abbrev =
+  match abbrev with
+    Mnil                   -> false
+  | Mcons(_, p', _, _, rem)   -> Path.same p p' || has_cached_expansion p rem
+  | Mlink rem              -> has_cached_expansion p !rem
+
+(**** Transform error trace ****)
+(* +++ Move it to some other place ? *)
+
+let expand_any_trace map env trace =
+  let expand_desc x = match x.Errortrace.expanded with
+    | None ->
+      let expanded = full_expand ~may_forget_scope:true env x.t in
+      Errortrace.{ t = repr x.t; expanded = Some expanded }
+    | Some _ -> x in
+  map expand_desc trace
+
+let expand_trace env trace =
+  expand_any_trace Errortrace.map env trace
+
+let expand_subtype_trace env trace =
+  expand_any_trace Subtype.map env trace
+
+(**** Unification ****)
+
+(* Return whether [t0] occurs in [ty]. Objects are also traversed. *)
+let deep_occur t0 ty =
+  let rec occur_rec ty =
+    let ty = repr ty in
+    if ty.level >= t0.level && try_mark_node ty then begin
+      if ty == t0 then raise Occur;
+      iter_type_expr occur_rec ty
+    end
+  in
+  try
+    occur_rec ty; unmark_type ty; false
+  with Occur ->
+    unmark_type ty; true
+
+let gadt_equations_level = ref None
+
+let get_gadt_equations_level () =
+  match !gadt_equations_level with
+  | None -> assert false
+  | Some x -> x
+
+
+(* a local constraint can be added only if the rhs
+   of the constraint does not contain any Tvars.
+   They need to be removed using this function *)
+let reify env t =
+  let fresh_constr_scope = get_gadt_equations_level () in
+  let create_fresh_constr lev name =
+    let name = match name with Some s -> "$'"^s | _ -> "$" in
+    let decl = new_local_type () in
+    let (id, new_env) =
+      Env.enter_type (get_new_abstract_name name) decl !env
+        ~scope:fresh_constr_scope in
+    let path = Path.Pident id in
+    let t = newty2 lev (Tconstr (path,[],ref Mnil))  in
+    env := new_env;
+    path, t
+  in
+  let visited = ref TypeSet.empty in
+  let rec iterator ty =
+    let ty = repr ty in
+    if TypeSet.mem ty !visited then () else begin
+      visited := TypeSet.add ty !visited;
+      match ty.desc with
+        Tvar o ->
+          let path, t = create_fresh_constr ty.level o in
+          link_type ty t;
+          if ty.level < fresh_constr_scope then
+            raise_for Unify (Escape (escape (Constructor path)))
+      | Tvariant r ->
+          let r = row_repr r in
+          if not (static_row r) then begin
+            if is_fixed r then iterator (row_more r) else
+            let m = r.row_more in
+            match m.desc with
+              Tvar o ->
+                let path, t = create_fresh_constr m.level o in
+                let row =
+                  let row_fixed = Some (Reified path) in
+                  {r with row_fields=[]; row_fixed; row_more = t} in
+                link_type m (newty2 m.level (Tvariant row));
+                if m.level < fresh_constr_scope then
+                  raise_for Unify (Escape (escape (Constructor path)))
+            | _ -> assert false
+          end;
+          iter_row iterator r
+      | Tconstr (p, _, _) when is_object_type p ->
+          iter_type_expr iterator (full_expand ~may_forget_scope:false !env ty)
+      | _ ->
+          iter_type_expr iterator ty
+    end
+  in
+  iterator t
+
+let is_newtype env p =
+  try
+    let decl = Env.find_type p env in
+    decl.type_expansion_scope <> Btype.lowest_level &&
+    decl.type_kind = Type_abstract &&
+    decl.type_private = Public
+  with Not_found -> false
+
+let non_aliasable p decl =
+  (* in_pervasives p ||  (subsumed by in_current_module) *)
+  in_current_module p && not decl.type_is_newtype
+
+let is_instantiable env p =
+  try
+    let decl = Env.find_type p env in
+    decl.type_kind = Type_abstract &&
+    decl.type_private = Public &&
+    decl.type_arity = 0 &&
+    decl.type_manifest = None &&
+    not (non_aliasable p decl)
+  with Not_found -> false
+
+
+(* PR#7113: -safe-string should be a global property *)
+let compatible_paths p1 p2 =
+  let open Predef in
+  Path.same p1 p2 ||
+  Path.same p1 path_bytes && Path.same p2 path_string ||
+  Path.same p1 path_string && Path.same p2 path_bytes
+
+(* Check for datatypes carefully; see PR#6348 *)
+let rec expands_to_datatype env ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tconstr (p, _, _) ->
+      begin try
+        is_datatype (Env.find_type p env) ||
+        expands_to_datatype env (try_expand_safe env ty)
+      with Not_found | Cannot_expand -> false
+      end
+  | _ -> false
+
+(* [mcomp] tests if two types are "compatible" -- i.e., if they could ever
+   unify.  (This is distinct from [eqtype], which checks if two types *are*
+   exactly the same.)  This is used to decide whether GADT cases are
+   unreachable.  It is broadly part of unification. *)
+
+(* mcomp type_pairs subst env t1 t2 does not raise an
+   exception if it is possible that t1 and t2 are actually
+   equal, assuming the types in type_pairs are equal and
+   that the mapping subst holds.
+   Assumes that both t1 and t2 do not contain any tvars
+   and that both their objects and variants are closed
+ *)
+
+let rec mcomp type_pairs env t1 t2 =
+  if t1 == t2 then () else
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if t1 == t2 then () else
+  match (t1.desc, t2.desc) with
+  | (Tvar _, _)
+  | (_, Tvar _)  ->
+      ()
+  | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
+      ()
+  | _ ->
+      let t1' = expand_head_opt env t1 in
+      let t2' = expand_head_opt env t2 in
+      (* Expansion may have changed the representative of the types... *)
+      let t1' = repr t1' and t2' = repr t2' in
+      if t1' == t2' then () else
+      begin try TypePairs.find type_pairs (t1', t2')
+      with Not_found ->
+        TypePairs.add type_pairs (t1', t2') ();
+        match (t1'.desc, t2'.desc) with
+        | (Tvar _, _)
+        | (_, Tvar _)  ->
+            ()
+        | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _))
+          when l1 = l2 || not (is_optional l1 || is_optional l2) ->
+            mcomp type_pairs env t1 t2;
+            mcomp type_pairs env u1 u2;
+        | (Ttuple tl1, Ttuple tl2) ->
+            mcomp_list type_pairs env tl1 tl2
+        | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) ->
+            mcomp_type_decl type_pairs env p1 p2 tl1 tl2
+        | (Tconstr (_, [], _), _) when has_injective_univars env t2' ->
+            raise (Unify [])
+        | (_, Tconstr (_, [], _)) when has_injective_univars env t1' ->
+            raise (Unify [])
+        | (Tconstr (p, _, _), _) | (_, Tconstr (p, _, _)) ->
+            begin try
+              let decl = Env.find_type p env in
+              if non_aliasable p decl || is_datatype decl then
+                raise Incompatible
+            with Not_found -> ()
+            end
+        (*
+        | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) when n1 = n2 ->
+            mcomp_list type_pairs env tl1 tl2
+        *)
+        | (Tpackage _, Tpackage _) -> ()
+        | (Tvariant row1, Tvariant row2) ->
+            mcomp_row type_pairs env row1 row2
+        | (Tobject (fi1, _), Tobject (fi2, _)) ->
+            mcomp_fields type_pairs env fi1 fi2
+        | (Tfield _, Tfield _) ->       (* Actually unused *)
+            mcomp_fields type_pairs env t1' t2'
+        | (Tnil, Tnil) ->
+            ()
+        | (Tpoly (t1, []), Tpoly (t2, [])) ->
+            mcomp type_pairs env t1 t2
+        | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+            (try
+               enter_poly env univar_pairs
+                 t1 tl1 t2 tl2 (mcomp type_pairs env)
+             with Escape _ -> raise Incompatible)
+        | (Tunivar _, Tunivar _) ->
+            (try unify_univar t1' t2' !univar_pairs
+             with Cannot_unify_universal_variables -> raise Incompatible)
+        | (_, _) ->
+            raise Incompatible
+      end
+
+and mcomp_list type_pairs env tl1 tl2 =
+  if List.length tl1 <> List.length tl2 then
+    raise Incompatible;
+  List.iter2 (mcomp type_pairs env) tl1 tl2
+
+and mcomp_fields type_pairs env ty1 ty2 =
+  if not (concrete_object ty1 && concrete_object ty2) then assert false;
+  let (fields2, rest2) = flatten_fields ty2 in
+  let (fields1, rest1) = flatten_fields ty1 in
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  let has_present =
+    List.exists (fun (_, k, _) -> field_kind_repr k = Fpresent) in
+  mcomp type_pairs env rest1 rest2;
+  if has_present miss1  && (object_row ty2).desc = Tnil
+  || has_present miss2  && (object_row ty1).desc = Tnil then raise Incompatible;
+  List.iter
+    (function (_n, k1, t1, k2, t2) ->
+       mcomp_kind k1 k2;
+       mcomp type_pairs env t1 t2)
+    pairs
+
+and mcomp_kind k1 k2 =
+  let k1 = field_kind_repr k1 in
+  let k2 = field_kind_repr k2 in
+  match k1, k2 with
+    (Fpresent, Fabsent)
+  | (Fabsent, Fpresent) -> raise Incompatible
+  | _                   -> ()
+
+and mcomp_row type_pairs env row1 row2 =
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
+  let cannot_erase (_,f) =
+    match row_field_repr f with
+      Rpresent _ -> true
+    | Rabsent | Reither _ -> false
+  in
+  if row1.row_closed && List.exists cannot_erase r2
+  || row2.row_closed && List.exists cannot_erase r1 then raise Incompatible;
+  List.iter
+    (fun (_,f1,f2) ->
+      match row_field_repr f1, row_field_repr f2 with
+      | Rpresent None, (Rpresent (Some _) | Reither (_, _::_, _, _) | Rabsent)
+      | Rpresent (Some _), (Rpresent None | Reither (true, _, _, _) | Rabsent)
+      | (Reither (_, _::_, _, _) | Rabsent), Rpresent None
+      | (Reither (true, _, _, _) | Rabsent), Rpresent (Some _) ->
+          raise Incompatible
+      | Rpresent(Some t1), Rpresent(Some t2) ->
+          mcomp type_pairs env t1 t2
+      | Rpresent(Some t1), Reither(false, tl2, _, _) ->
+          List.iter (mcomp type_pairs env t1) tl2
+      | Reither(false, tl1, _, _), Rpresent(Some t2) ->
+          List.iter (mcomp type_pairs env t2) tl1
+      | _ -> ())
+    pairs
+
+and mcomp_type_decl type_pairs env p1 p2 tl1 tl2 =
+  try
+    let decl = Env.find_type p1 env in
+    let decl' = Env.find_type p2 env in
+    if compatible_paths p1 p2 then begin
+      let inj =
+        try List.map Variance.(mem Inj) (Env.find_type p1 env).type_variance
+        with Not_found -> List.map (fun _ -> false) tl1
+      in
+      List.iter2
+        (fun i (t1,t2) -> if i then mcomp type_pairs env t1 t2)
+        inj (List.combine tl1 tl2)
+    end else if non_aliasable p1 decl && non_aliasable p2 decl' then
+      raise Incompatible
+    else
+      match decl.type_kind, decl'.type_kind with
+      | Type_record (lst,r), Type_record (lst',r') when r = r' ->
+          mcomp_list type_pairs env tl1 tl2;
+          mcomp_record_description type_pairs env lst lst'
+      | Type_variant (v1,r), Type_variant (v2,r') when r = r' ->
+          mcomp_list type_pairs env tl1 tl2;
+          mcomp_variant_description type_pairs env v1 v2
+      | Type_open, Type_open ->
+          mcomp_list type_pairs env tl1 tl2
+      | Type_abstract, Type_abstract -> ()
+      | Type_abstract, _ when not (non_aliasable p1 decl)-> ()
+      | _, Type_abstract when not (non_aliasable p2 decl') -> ()
+      | _ -> raise Incompatible
+  with Not_found -> ()
+
+and mcomp_type_option type_pairs env t t' =
+  match t, t' with
+    None, None -> ()
+  | Some t, Some t' -> mcomp type_pairs env t t'
+  | _ -> raise Incompatible
+
+and mcomp_variant_description type_pairs env xs ys =
+  let rec iter = fun x y ->
+    match x, y with
+    | c1 :: xs, c2 :: ys   ->
+      mcomp_type_option type_pairs env c1.cd_res c2.cd_res;
+      begin match c1.cd_args, c2.cd_args with
+      | Cstr_tuple l1, Cstr_tuple l2 -> mcomp_list type_pairs env l1 l2
+      | Cstr_record l1, Cstr_record l2 ->
+          mcomp_record_description type_pairs env l1 l2
+      | _ -> raise Incompatible
+      end;
+     if Ident.name c1.cd_id = Ident.name c2.cd_id
+      then iter xs ys
+      else raise Incompatible
+    | [],[] -> ()
+    | _ -> raise Incompatible
+  in
+  iter xs ys
+
+and mcomp_record_description type_pairs env =
+  let rec iter x y =
+    match x, y with
+    | l1 :: xs, l2 :: ys ->
+        mcomp type_pairs env l1.ld_type l2.ld_type;
+        if Ident.name l1.ld_id = Ident.name l2.ld_id &&
+           l1.ld_mutable = l2.ld_mutable
+        then iter xs ys
+        else raise Incompatible
+    | [], [] -> ()
+    | _ -> raise Incompatible
+  in
+  iter
+
+let mcomp env t1 t2 =
+  mcomp (TypePairs.create 4) env t1 t2
+
+let mcomp_for tr_exn env t1 t2 =
+  try
+    mcomp env t1 t2
+  with Incompatible -> raise_unexplained_for tr_exn
+
+(* Real unification *)
+
+let find_lowest_level ty =
+  let lowest = ref generic_level in
+  let rec find ty =
+    let ty = repr ty in
+    if not_marked_node ty then begin
+      if ty.level < !lowest then lowest := ty.level;
+      flip_mark_node ty;
+      iter_type_expr find ty
+    end
+  in find ty; unmark_type ty; !lowest
+
+let find_expansion_scope env path =
+  (Env.find_type path env).type_expansion_scope
+
+let add_gadt_equation env source destination =
+  (* Format.eprintf "@[add_gadt_equation %s %a@]@."
+    (Path.name source) !Btype.print_raw destination; *)
+  if has_free_univars !env destination then
+    occur_univar ~inj_only:true !env destination
+  else if local_non_recursive_abbrev !env source destination then begin
+    let destination = duplicate_type destination in
+    let expansion_scope =
+      Int.max (Path.scope source) (get_gadt_equations_level ())
+    in
+    let decl =
+      new_local_type ~manifest_and_scope:(destination, expansion_scope) () in
+    env := Env.add_local_type source decl !env;
+    cleanup_abbrev ()
+  end
+
+let unify_eq_set = TypePairs.create 11
+
+let order_type_pair t1 t2 =
+  if t1.id <= t2.id then (t1, t2) else (t2, t1)
+
+let add_type_equality t1 t2 =
+  TypePairs.add unify_eq_set (order_type_pair t1 t2) ()
+
+let eq_package_path env p1 p2 =
+  Path.same p1 p2 ||
+  Path.same (normalize_package_path env p1) (normalize_package_path env p2)
+
+let nondep_type' = ref (fun _ _ _ -> assert false)
+let package_subtype = ref (fun _ _ _ _ _ -> assert false)
+
+exception Nondep_cannot_erase of Ident.t
+
+let rec concat_longident lid1 =
+  let open Longident in
+  function
+    Lident s -> Ldot (lid1, s)
+  | Ldot (lid2, s) -> Ldot (concat_longident lid1 lid2, s)
+  | Lapply (lid2, lid) -> Lapply (concat_longident lid1 lid2, lid)
+
+let nondep_instance env level id ty =
+  let ty = !nondep_type' env [id] ty in
+  if level = generic_level then duplicate_type ty else
+  let old = !current_level in
+  current_level := level;
+  let ty = instance ty in
+  current_level := old;
+  ty
+
+(* Find the type paths nl1 in the module type mty2, and add them to the
+   list (nl2, tl2). raise Not_found if impossible *)
+let complete_type_list ?(allow_absent=false) env fl1 lv2 mty2 fl2 =
+  (* This is morally WRONG: we're adding a (dummy) module without a scope in the
+     environment. However no operation which cares about levels/scopes is going
+     to happen while this module exists.
+     The only operations that happen are:
+     - Env.find_type_by_name
+     - nondep_instance
+     None of which check the scope.
+
+     It'd be nice if we avoided creating such temporary dummy modules and broken
+     environments though. *)
+  let id2 = Ident.create_local "Pkg" in
+  let env' = Env.add_module id2 Mp_present mty2 env in
+  let rec complete fl1 fl2 =
+    match fl1, fl2 with
+      [], _ -> fl2
+    | (n, _) :: nl, (n2, _ as nt2) :: ntl' when n >= n2 ->
+        nt2 :: complete (if n = n2 then nl else fl1) ntl'
+    | (n, _) :: nl, _ ->
+        let lid = concat_longident (Longident.Lident "Pkg") n in
+        match Env.find_type_by_name lid env' with
+        | (_, {type_arity = 0; type_kind = Type_abstract;
+               type_private = Public; type_manifest = Some t2}) ->
+            begin match nondep_instance env' lv2 id2 t2 with
+            | t -> (n, t) :: complete nl fl2
+            | exception Nondep_cannot_erase _ ->
+                if allow_absent then
+                  complete nl fl2
+                else
+                  raise Exit
+            end
+        | (_, {type_arity = 0; type_kind = Type_abstract;
+               type_private = Public; type_manifest = None})
+          when allow_absent ->
+            complete nl fl2
+        | _ -> raise Exit
+        | exception Not_found when allow_absent->
+            complete nl fl2
+  in
+  match complete fl1 fl2 with
+  | res -> res
+  | exception Exit -> raise Not_found
+
+(* raise Not_found rather than Unify if the module types are incompatible *)
+let unify_package env unify_list lv1 p1 fl1 lv2 p2 fl2 =
+  let ntl2 = complete_type_list env fl1 lv2 (Mty_ident p2) fl2
+  and ntl1 = complete_type_list env fl2 lv1 (Mty_ident p1) fl1 in
+  unify_list (List.map snd ntl1) (List.map snd ntl2);
+  if eq_package_path env p1 p2
+  || !package_subtype env p1 fl1 p2 fl2
+  && !package_subtype env p2 fl2 p1 fl1 then () else raise Not_found
+
+
+(* force unification in Reither when one side has a non-conjunctive type *)
+let rigid_variants = ref false
+
+let unify_eq t1 t2 =
+  t1 == t2 ||
+  match !umode with
+  | Expression -> false
+  | Pattern ->
+      try TypePairs.find unify_eq_set (order_type_pair t1 t2); true
+      with Not_found -> false
+
+let unify1_var env t1 t2 =
+  assert (is_Tvar t1);
+  occur_for Unify env t1 t2;
+  match occur_univar_for Unify env t2 with
+  | () ->
+      begin
+        try
+          update_level env t1.level t2;
+          update_scope t1.scope t2
+        with Escape e ->
+          raise_for Unify (Escape e)
+      end;
+      link_type t1 t2;
+      true
+  | exception Unify _ when !umode = Pattern ->
+      false
+
+(* Can only be called when generate_equations is true *)
+let record_equation t1 t2 =
+  match !equations_generation with
+  | Forbidden -> assert false
+  | Allowed { equated_types } -> TypePairs.add equated_types (t1, t2) ()
+
+(* Called from unify3 *)
+let unify3_var env t1' t2 t2' =
+  occur_for Unify !env t1' t2;
+  match occur_univar_for Unify !env t2 with
+  | () -> link_type t1' t2
+  | exception Unify _ when !umode = Pattern ->
+      reify env t1';
+      reify env t2';
+      if can_generate_equations () then begin
+        occur_univar ~inj_only:true !env t2';
+        record_equation t1' t2';
+      end
+
+(*
+   1. When unifying two non-abbreviated types, one type is made a link
+      to the other. When unifying an abbreviated type with a
+      non-abbreviated type, the non-abbreviated type is made a link to
+      the other one. When unifying to abbreviated types, these two
+      types are kept distincts, but they are made to (temporally)
+      expand to the same type.
+   2. Abbreviations with at least one parameter are systematically
+      expanded. The overhead does not seem too high, and that way
+      abbreviations where some parameters does not appear in the
+      expansion, such as ['a t = int], are correctly handled. In
+      particular, for this example, unifying ['a t] with ['b t] keeps
+      ['a] and ['b] distincts. (Is it really important ?)
+   3. Unifying an abbreviation ['a t = 'a] with ['a] should not yield
+      ['a t as 'a]. Indeed, the type variable would otherwise be lost.
+      This problem occurs for abbreviations expanding to a type
+      variable, but also to many other constrained abbreviations (for
+      instance, [(< x : 'a > -> unit) t = <x : 'a>]). The solution is
+      that, if an abbreviation is unified with some subpart of its
+      parameters, then the parameter actually does not get
+      abbreviated.  It would be possible to check whether some
+      information is indeed lost, but it probably does not worth it.
+*)
+
+let rec unify (env:Env.t ref) t1 t2 =
+  (* First step: special cases (optimizations) *)
+  if t1 == t2 then () else
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if unify_eq t1 t2 then () else
+  let reset_tracing = check_trace_gadt_instances !env in
+
+  try
+    type_changed := true;
+    begin match (t1.desc, t2.desc) with
+      (Tvar _, Tconstr _) when deep_occur t1 t2 ->
+        unify2 env t1 t2
+    | (Tconstr _, Tvar _) when deep_occur t2 t1 ->
+        unify2 env t1 t2
+    | (Tvar _, _) ->
+        if unify1_var !env t1 t2 then () else unify2 env t1 t2
+    | (_, Tvar _) ->
+        if unify1_var !env t2 t1 then () else unify2 env t1 t2
+    | (Tunivar _, Tunivar _) ->
+        unify_univar_for Unify t1 t2 !univar_pairs;
+        update_level_for Unify !env t1.level t2;
+        update_scope_for Unify t1.scope t2;
+        link_type t1 t2
+    | (Tconstr (p1, [], a1), Tconstr (p2, [], a2))
+          when Path.same p1 p2 (* && actual_mode !env = Old *)
+            (* This optimization assumes that t1 does not expand to t2
+               (and conversely), so we fall back to the general case
+               when any of the types has a cached expansion. *)
+            && not (has_cached_expansion p1 !a1
+                 || has_cached_expansion p2 !a2) ->
+        update_level_for Unify !env t1.level t2;
+        update_scope_for Unify t1.scope t2;
+        link_type t1 t2
+    | (Tconstr (p1, [], _), Tconstr (p2, [], _))
+      when Env.has_local_constraints !env
+      && is_newtype !env p1 && is_newtype !env p2 ->
+        (* Do not use local constraints more than necessary *)
+        begin try
+          if find_expansion_scope !env p1 > find_expansion_scope !env p2 then
+            unify env t1 (try_expand_safe !env t2)
+          else
+            unify env (try_expand_safe !env t1) t2
+        with Cannot_expand ->
+          unify2 env t1 t2
+        end
+    | _ ->
+        unify2 env t1 t2
+    end;
+    reset_trace_gadt_instances reset_tracing;
+  with Unify trace ->
+    reset_trace_gadt_instances reset_tracing;
+    raise( Unify (Errortrace.diff t1 t2 :: trace) )
+
+and unify2 env t1 t2 =
+  (* Second step: expansion of abbreviations *)
+  (* Expansion may change the representative of the types. *)
+  ignore (expand_head_unif !env t1);
+  ignore (expand_head_unif !env t2);
+  let t1' = expand_head_unif !env t1 in
+  let t2' = expand_head_unif !env t2 in
+  let lv = Int.min t1'.level t2'.level in
+  let scope = Int.max t1'.scope t2'.scope in
+  update_level_for Unify !env lv t2;
+  update_level_for Unify !env lv t1;
+  update_scope_for Unify scope t2;
+  update_scope_for Unify scope t1;
+  if unify_eq t1' t2' then () else
+
+  let t1 = repr t1 and t2 = repr t2 in
+  let t1, t2 =
+    if !Clflags.principal
+    && (find_lowest_level t1' < lv || find_lowest_level t2' < lv) then
+      (* Expand abbreviations hiding a lower level *)
+      (* Should also do it for parameterized types, after unification... *)
+      (match t1.desc with Tconstr (_, [], _) -> t1' | _ -> t1),
+      (match t2.desc with Tconstr (_, [], _) -> t2' | _ -> t2)
+    else (t1, t2)
+  in
+  if unify_eq t1 t1' || not (unify_eq t2 t2') then
+    unify3 env t1 t1' t2 t2'
+  else
+    try unify3 env t2 t2' t1 t1' with Unify trace ->
+      raise_trace_for Unify (swap_trace trace)
+
+and unify3 env t1 t1' t2 t2' =
+  (* Third step: truly unification *)
+  (* Assumes either [t1 == t1'] or [t2 != t2'] *)
+  let d1 = t1'.desc and d2 = t2'.desc in
+  let create_recursion = (t2 != t2') && (deep_occur t1' t2) in
+
+  begin match (d1, d2) with (* handle vars and univars specially *)
+    (Tunivar _, Tunivar _) ->
+      unify_univar_for Unify t1' t2' !univar_pairs;
+      link_type t1' t2'
+  | (Tvar _, _) ->
+      unify3_var env t1' t2 t2'
+  | (_, Tvar _) ->
+      unify3_var env t2' t1 t1'
+  | (Tfield _, Tfield _) -> (* special case for GADTs *)
+      unify_fields env t1' t2'
+  | _ ->
+    begin match !umode with
+    | Expression ->
+        occur_for Unify !env t1' t2';
+        if is_self_type d1 (* PR#7711: do not abbreviate self type *)
+        then link_type t1' t2'
+        else link_type t1' t2
+    | Pattern ->
+        add_type_equality t1' t2'
+    end;
+    try
+      begin match (d1, d2) with
+        (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2 ||
+        (!Clflags.classic || !umode = Pattern) &&
+        not (is_optional l1 || is_optional l2) ->
+          unify  env t1 t2; unify env  u1 u2;
+          begin match commu_repr c1, commu_repr c2 with
+            Clink r, c2 -> set_commu r c2
+          | c1, Clink r -> set_commu r c1
+          | _ -> ()
+          end
+      | (Ttuple tl1, Ttuple tl2) ->
+          unify_list env tl1 tl2
+      | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 ->
+          if !umode = Expression || !equations_generation = Forbidden then
+            unify_list env tl1 tl2
+          else if !assume_injective then
+            set_mode_pattern ~generate:!equations_generation ~injective:false
+              ~allow_recursive:!allow_recursive_equation
+              (fun () -> unify_list env tl1 tl2)
+          else if in_current_module p1 (* || in_pervasives p1 *)
+               || List.exists (expands_to_datatype !env) [t1'; t1; t2]
+          then
+            unify_list env tl1 tl2
+          else
+            let inj =
+              try List.map Variance.(mem Inj)
+                    (Env.find_type p1 !env).type_variance
+              with Not_found -> List.map (fun _ -> false) tl1
+            in
+            List.iter2
+              (fun i (t1, t2) ->
+                if i then unify env t1 t2 else
+                set_mode_pattern ~generate:Forbidden ~injective:false
+                  ~allow_recursive:!allow_recursive_equation
+                  begin fun () ->
+                    let snap = snapshot () in
+                    try unify env t1 t2 with Unify _ ->
+                      backtrack snap;
+                      reify env t1;
+                      reify env t2
+                  end)
+              inj (List.combine tl1 tl2)
+      | (Tconstr (path,[],_),
+         Tconstr (path',[],_))
+        when is_instantiable !env path && is_instantiable !env path'
+        && can_generate_equations () ->
+          let source, destination =
+            if Path.scope path > Path.scope path'
+            then  path , t2'
+            else  path', t1'
+          in
+          record_equation t1' t2';
+          add_gadt_equation env source destination
+      | (Tconstr (path,[],_), _)
+        when is_instantiable !env path && can_generate_equations () ->
+          reify env t2';
+          record_equation t1' t2';
+          add_gadt_equation env path t2'
+      | (_, Tconstr (path,[],_))
+        when is_instantiable !env path && can_generate_equations () ->
+          reify env t1';
+          record_equation t1' t2';
+          add_gadt_equation env path t1'
+      | (Tconstr (_,_,_), _) | (_, Tconstr (_,_,_)) when !umode = Pattern ->
+          reify env t1';
+          reify env t2';
+          if can_generate_equations () then (
+            mcomp_for Unify !env t1' t2';
+            record_equation t1' t2'
+          )
+      | (Tobject (fi1, nm1), Tobject (fi2, _)) ->
+          unify_fields env fi1 fi2;
+          (* Type [t2'] may have been instantiated by [unify_fields] *)
+          (* XXX One should do some kind of unification... *)
+          begin match (repr t2').desc with
+            Tobject (_, {contents = Some (_, va::_)}) when
+              (match (repr va).desc with
+                Tvar _|Tunivar _|Tnil -> true | _ -> false) -> ()
+          | Tobject (_, nm2) -> set_name nm2 !nm1
+          | _ -> ()
+          end
+      | (Tvariant row1, Tvariant row2) ->
+          if !umode = Expression then
+            unify_row env row1 row2
+          else begin
+            let snap = snapshot () in
+            try unify_row env row1 row2
+            with Unify _ ->
+              backtrack snap;
+              reify env t1';
+              reify env t2';
+              if can_generate_equations () then (
+                mcomp_for Unify !env t1' t2';
+                record_equation t1' t2'
+              )
+          end
+      | (Tfield(f,kind,_,rem), Tnil) | (Tnil, Tfield(f,kind,_,rem)) ->
+          begin match field_kind_repr kind with
+            Fvar r when f <> dummy_method ->
+              set_kind r Fabsent;
+              if d2 = Tnil then unify env rem t2'
+              else unify env (newty2 rem.level Tnil) rem
+          | _      ->
+              if f = dummy_method then
+                raise_for Unify (Obj Self_cannot_be_closed)
+              else if d1 = Tnil then
+                raise_for Unify (Obj (Missing_field(First, f)))
+              else
+                raise_for Unify (Obj (Missing_field(Second, f)))
+          end
+      | (Tnil, Tnil) ->
+          ()
+      | (Tpoly (t1, []), Tpoly (t2, [])) ->
+          unify env t1 t2
+      | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+          enter_poly_for Unify !env univar_pairs t1 tl1 t2 tl2 (unify env)
+      | (Tpackage (p1, fl1), Tpackage (p2, fl2)) ->
+          begin try
+            unify_package !env (unify_list env)
+              t1.level p1 fl1 t2.level p2 fl2
+          with Not_found ->
+            if !umode = Expression then raise_unexplained_for Unify;
+            List.iter (fun (_n, ty) -> reify env ty) (fl1 @ fl2);
+            (* if !generate_equations then List.iter2 (mcomp !env) tl1 tl2 *)
+          end
+      | (Tnil,  Tconstr _ ) ->
+          raise (Unify Errortrace.[Obj(Abstract_row Second)])
+      | (Tconstr _,  Tnil ) ->
+          raise (Unify Errortrace.[Obj(Abstract_row First)])
+      | (_, _) -> raise_unexplained_for Unify
+      end;
+      (* XXX Commentaires + changer "create_recursion"
+         ||| Comments + change "create_recursion" *)
+      if create_recursion then
+        match t2.desc with
+          Tconstr (p, tl, abbrev) ->
+            forget_abbrev abbrev p;
+            let t2'' = expand_head_unif !env t2 in
+            if not (closed_parameterized_type tl t2'') then
+              link_type (repr t2) (repr t2')
+        | _ ->
+            () (* t2 has already been expanded by update_level *)
+    with Unify trace ->
+      Private_type_expr.set_desc t1' d1;
+      raise_trace_for Unify trace
+  end
+
+and unify_list env tl1 tl2 =
+  if List.length tl1 <> List.length tl2 then
+    raise_unexplained_for Unify;
+  List.iter2 (unify env) tl1 tl2
+
+(* Build a fresh row variable for unification *)
+and make_rowvar level use1 rest1 use2 rest2  =
+  let set_name ty name =
+    match ty.desc with
+      Tvar None -> set_type_desc ty (Tvar name)
+    | _ -> ()
+  in
+  let name =
+    match rest1.desc, rest2.desc with
+      Tvar (Some _ as name1), Tvar (Some _ as name2) ->
+        if rest1.level <= rest2.level then name1 else name2
+    | Tvar (Some _ as name), _ ->
+        if use2 then set_name rest2 name; name
+    | _, Tvar (Some _ as name) ->
+        if use1 then set_name rest2 name; name
+    | _ -> None
+  in
+  if use1 then rest1 else
+  if use2 then rest2 else newvar2 ?name level
+
+and unify_fields env ty1 ty2 =          (* Optimization *)
+  let (fields1, rest1) = flatten_fields ty1
+  and (fields2, rest2) = flatten_fields ty2 in
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  let l1 = (repr ty1).level and l2 = (repr ty2).level in
+  let va = make_rowvar (Int.min l1 l2) (miss2=[]) rest1 (miss1=[]) rest2 in
+  let d1 = rest1.desc and d2 = rest2.desc in
+  try
+    unify env (build_fields l1 miss1 va) rest2;
+    unify env rest1 (build_fields l2 miss2 va);
+    List.iter
+      (fun (n, k1, t1, k2, t2) ->
+        unify_kind k1 k2;
+        try
+          if !trace_gadt_instances then begin
+            update_level_for Unify !env va.level t1;
+            update_scope_for Unify va.scope t1
+          end;
+          unify env t1 t2
+        with Unify trace ->
+          raise( Unify (Errortrace.incompatible_fields n t1 t2 :: trace) )
+      )
+      pairs
+  with exn ->
+    set_type_desc rest1 d1;
+    set_type_desc rest2 d2;
+    raise exn
+
+and unify_kind k1 k2 =
+  let k1 = field_kind_repr k1 in
+  let k2 = field_kind_repr k2 in
+  if k1 == k2 then () else
+  match k1, k2 with
+    (Fvar r, (Fvar _ | Fpresent)) -> set_kind r k2
+  | (Fpresent, Fvar r)            -> set_kind r k1
+  | (Fpresent, Fpresent)          -> ()
+  | _                             -> assert false
+
+and unify_row env row1 row2 =
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let rm1 = row_more row1 and rm2 = row_more row2 in
+  if unify_eq rm1 rm2 then () else
+  let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
+  if r1 <> [] && r2 <> [] then begin
+    let ht = Hashtbl.create (List.length r1) in
+    List.iter (fun (l,_) -> Hashtbl.add ht (hash_variant l) l) r1;
+    List.iter
+      (fun (l,_) ->
+        try raise (Tags(l, Hashtbl.find ht (hash_variant l)))
+        with Not_found -> ())
+      r2
+  end;
+  let fixed1 = fixed_explanation row1 and fixed2 = fixed_explanation row2 in
+  let more = match fixed1, fixed2 with
+    | Some _, Some _ -> if rm2.level < rm1.level then rm2 else rm1
+    | Some _, None -> rm1
+    | None, Some _ -> rm2
+    | None, None -> newty2 (Int.min rm1.level rm2.level) (Tvar None)
+  in
+  let fixed = merge_fixed_explanation fixed1 fixed2
+  and closed = row1.row_closed || row2.row_closed in
+  let keep switch =
+    List.for_all
+      (fun (_,f1,f2) ->
+        let f1, f2 = switch f1 f2 in
+        row_field_repr f1 = Rabsent || row_field_repr f2 <> Rabsent)
+      pairs
+  in
+  let empty fields =
+    List.for_all (fun (_,f) -> row_field_repr f = Rabsent) fields in
+  (* Check whether we are going to build an empty type *)
+  if closed && (empty r1 || row2.row_closed) && (empty r2 || row1.row_closed)
+  && List.for_all
+      (fun (_,f1,f2) ->
+        row_field_repr f1 = Rabsent || row_field_repr f2 = Rabsent)
+      pairs
+  then raise_for Unify (Variant No_intersection);
+  let name =
+    if row1.row_name <> None && (row1.row_closed || empty r2) &&
+      (not row2.row_closed || keep (fun f1 f2 -> f1, f2) && empty r1)
+    then row1.row_name
+    else if row2.row_name <> None && (row2.row_closed || empty r1) &&
+      (not row1.row_closed || keep (fun f1 f2 -> f2, f1) && empty r2)
+    then row2.row_name
+    else None
+  in
+  let row0 = {row_fields = []; row_more = more; row_bound = ();
+              row_closed = closed; row_fixed = fixed; row_name = name} in
+  let set_more row rest =
+    let rest =
+      if closed then
+        filter_row_fields row.row_closed rest
+      else rest in
+    begin match fixed_explanation row with
+      | None ->
+          if rest <> [] && row.row_closed then
+            let pos = if row == row1 then First else Second in
+            raise_for Unify (Variant (No_tags(pos,rest)))
+      | Some fixed ->
+          let pos = if row == row1 then First else Second in
+          if closed && not row.row_closed then
+            raise_for Unify (Variant (Fixed_row(pos,Cannot_be_closed,fixed)))
+          else if rest <> [] then
+            let case = Cannot_add_tags (List.map fst rest) in
+            raise_for Unify (Variant (Fixed_row(pos,case,fixed)))
+    end;
+    (* The following test is not principal... should rather use Tnil *)
+    let rm = row_more row in
+    (*if !trace_gadt_instances && rm.desc = Tnil then () else*)
+    if !trace_gadt_instances then
+      update_level_for Unify !env rm.level (newgenty (Tvariant row));
+    if row_fixed row then
+      if more == rm then () else
+      if is_Tvar rm then link_type rm more else unify env rm more
+    else
+      let ty = newgenty (Tvariant {row0 with row_fields = rest}) in
+      update_level_for Unify !env rm.level ty;
+      update_scope_for Unify rm.scope ty;
+      link_type rm ty
+  in
+  let md1 = rm1.desc and md2 = rm2.desc in
+  begin try
+    set_more row2 r1;
+    set_more row1 r2;
+    List.iter
+      (fun (l,f1,f2) ->
+        try unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2
+        with Unify trace ->
+          raise_trace_for Unify (Variant (Incompatible_types_for l) :: trace)
+      )
+      pairs;
+    if static_row row1 then begin
+      let rm = row_more row1 in
+      if is_Tvar rm then link_type rm (newty2 rm.level Tnil)
+    end
+  with exn ->
+    set_type_desc rm1 md1; set_type_desc rm2 md2; raise exn
+  end
+
+and unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 =
+  let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
+  let if_not_fixed (pos,fixed) f =
+    match fixed with
+    | None -> f ()
+    | Some fix ->
+        let tr = [Variant(Fixed_row(pos,Cannot_add_tags [l],fix))] in
+        raise_trace_for Unify tr in
+  let first = First, fixed1 and second = Second, fixed2 in
+  let either_fixed = match fixed1, fixed2 with
+    | None, None -> false
+    | _ -> true in
+  if f1 == f2 then () else
+  match f1, f2 with
+    Rpresent(Some t1), Rpresent(Some t2) -> unify env t1 t2
+  | Rpresent None, Rpresent None -> ()
+  | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) ->
+      if e1 == e2 then () else
+      if either_fixed && not (c1 || c2)
+      && List.length tl1 = List.length tl2 then begin
+        (* PR#7496 *)
+        let f = Reither (c1 || c2, [], m1 || m2, ref None) in
+        set_row_field e1 f; set_row_field e2 f;
+        List.iter2 (unify env) tl1 tl2
+      end
+      else let redo =
+        (m1 || m2 || either_fixed ||
+         !rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) &&
+        begin match tl1 @ tl2 with [] -> false
+        | t1 :: tl ->
+            if c1 || c2 then raise_unexplained_for Unify;
+            List.iter (unify env t1) tl;
+            !e1 <> None || !e2 <> None
+        end in
+      if redo then unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 else
+      let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
+      let rec remq tl = function [] -> []
+        | ty :: tl' ->
+            if List.memq ty tl then remq tl tl' else ty :: remq tl tl'
+      in
+      let tl1' = remq tl2 tl1 and tl2' = remq tl1 tl2 in
+      (* PR#6744 *)
+      let (tlu1,tl1') = List.partition (has_free_univars !env) tl1'
+      and (tlu2,tl2') = List.partition (has_free_univars !env) tl2' in
+      begin match tlu1, tlu2 with
+        [], [] -> ()
+      | (tu1::tlu1), _ :: _ ->
+          (* Attempt to merge all the types containing univars *)
+          List.iter (unify env tu1) (tlu1@tlu2)
+      | (tu::_, []) | ([], tu::_) ->
+          occur_univar_for Unify !env tu
+      end;
+      (* Is this handling of levels really principal? *)
+      List.iter (fun ty ->
+        let rm = repr rm2 in
+        update_level_for Unify !env rm.level ty;
+        update_scope_for Unify rm.scope ty;
+      ) tl1';
+      List.iter (fun ty ->
+        let rm = repr rm1 in
+        update_level_for Unify !env rm.level ty;
+        update_scope_for Unify rm.scope ty;
+      ) tl2';
+      let e = ref None in
+      let f1' = Reither(c1 || c2, tl2', m1 || m2, e)
+      and f2' = Reither(c1 || c2, tl1', m1 || m2, e) in
+      set_row_field e1 f1'; set_row_field e2 f2';
+  | Reither(_, _, false, e1), Rabsent ->
+      if_not_fixed first (fun () -> set_row_field e1 f2)
+  | Rabsent, Reither(_, _, false, e2) ->
+      if_not_fixed second (fun () -> set_row_field e2 f1)
+  | Rabsent, Rabsent -> ()
+  | Reither(false, tl, _, e1), Rpresent(Some t2) ->
+      if_not_fixed first (fun () ->
+          set_row_field e1 f2;
+          let rm = repr rm1 in
+          update_level_for Unify !env rm.level t2;
+          update_scope_for Unify rm.scope t2;
+          (try List.iter (fun t1 -> unify env t1 t2) tl
+           with exn -> e1 := None; raise exn)
+        )
+  | Rpresent(Some t1), Reither(false, tl, _, e2) ->
+      if_not_fixed second (fun () ->
+          set_row_field e2 f1;
+          let rm = repr rm2 in
+          update_level_for Unify !env rm.level t1;
+          update_scope_for Unify rm.scope t1;
+          (try List.iter (unify env t1) tl
+           with exn -> e2 := None; raise exn)
+        )
+  | Reither(true, [], _, e1), Rpresent None ->
+      if_not_fixed first (fun () -> set_row_field e1 f2)
+  | Rpresent None, Reither(true, [], _, e2) ->
+      if_not_fixed second (fun () -> set_row_field e2 f1)
+  | _ -> raise_unexplained_for Unify
+
+let unify env ty1 ty2 =
+  let snap = Btype.snapshot () in
+  try
+    unify env ty1 ty2
+  with
+    Unify trace ->
+      undo_compress snap;
+      raise (Unify (expand_trace !env trace))
+
+let unify_gadt ~equations_level:lev ~allow_recursive (env:Env.t ref) ty1 ty2 =
+  try
+    univar_pairs := [];
+    gadt_equations_level := Some lev;
+    let equated_types = TypePairs.create 0 in
+    set_mode_pattern
+      ~generate:(Allowed { equated_types })
+      ~injective:true
+      ~allow_recursive
+      (fun () -> unify env ty1 ty2);
+    gadt_equations_level := None;
+    TypePairs.clear unify_eq_set;
+    equated_types
+  with e ->
+    gadt_equations_level := None;
+    TypePairs.clear unify_eq_set;
+    raise e
+
+let unify_var env t1 t2 =
+  let t1 = repr t1 and t2 = repr t2 in
+  if t1 == t2 then () else
+  match t1.desc, t2.desc with
+    Tvar _, Tconstr _ when deep_occur t1 t2 ->
+      unify (ref env) t1 t2
+  | Tvar _, _ ->
+      let reset_tracing = check_trace_gadt_instances env in
+      begin try
+        occur_for Unify env t1 t2;
+        update_level_for Unify env t1.level t2;
+        update_scope_for Unify t1.scope t2;
+        link_type t1 t2;
+        reset_trace_gadt_instances reset_tracing;
+      with Unify trace ->
+        reset_trace_gadt_instances reset_tracing;
+        let expanded_trace =
+          expand_trace env @@ Errortrace.diff t1 t2 :: trace
+        in
+        raise_trace_for Unify expanded_trace
+      end
+  | _ ->
+      unify (ref env) t1 t2
+
+let _ = unify' := unify_var
+
+let unify_pairs env ty1 ty2 pairs =
+  univar_pairs := pairs;
+  unify env ty1 ty2
+
+let unify env ty1 ty2 =
+  unify_pairs (ref env) ty1 ty2 []
+
+
+
+(**** Special cases of unification ****)
+
+let expand_head_trace env t =
+  let reset_tracing = check_trace_gadt_instances env in
+  let t = expand_head_unif env t in
+  reset_trace_gadt_instances reset_tracing;
+  t
+
+(*
+   Unify [t] and [l:'a -> 'b]. Return ['a] and ['b].
+   In [-nolabels] mode, label mismatch is accepted when
+   (1) the requested label is ""
+   (2) the original label is not optional
+*)
+
+let filter_arrow env t l =
+  let t = expand_head_trace env t in
+  match t.desc with
+    Tvar _ ->
+      let lv = t.level in
+      let t1 = newvar2 lv and t2 = newvar2 lv in
+      let t' = newty2 lv (Tarrow (l, t1, t2, Cok)) in
+      link_type t t';
+      (t1, t2)
+  | Tarrow(l', t1, t2, _)
+    when l = l' || !Clflags.classic && l = Nolabel && not (is_optional l') ->
+      (t1, t2)
+  | _ ->
+      raise_unexplained_for Unify
+
+(* Used by [filter_method]. *)
+let rec filter_method_field env name priv ty =
+  let ty = expand_head_trace env ty in
+  match ty.desc with
+    Tvar _ ->
+      let level = ty.level in
+      let ty1 = newvar2 level and ty2 = newvar2 level in
+      let ty' = newty2 level (Tfield (name,
+                                      begin match priv with
+                                        Private -> Fvar (ref None)
+                                      | Public  -> Fpresent
+                                      end,
+                                      ty1, ty2))
+      in
+      link_type ty ty';
+      ty1
+  | Tfield(n, kind, ty1, ty2) ->
+      let kind = field_kind_repr kind in
+      if (n = name) && (kind <> Fabsent) then begin
+        if priv = Public then
+          unify_kind kind Fpresent;
+        ty1
+      end else
+        filter_method_field env name priv ty2
+  | _ ->
+      raise_unexplained_for Unify
+
+(* Unify [ty] and [< name : 'a; .. >]. Return ['a]. *)
+let filter_method env name priv ty =
+  let ty = expand_head_trace env ty in
+  match ty.desc with
+    Tvar _ ->
+      let ty1 = newvar () in
+      let ty' = newobj ty1 in
+      update_level_for Unify env ty.level ty';
+      update_scope_for Unify ty.scope ty';
+      link_type ty ty';
+      filter_method_field env name priv ty1
+  | Tobject(f, _) ->
+      filter_method_field env name priv f
+  | _ ->
+      raise_unexplained_for Unify
+
+let check_filter_method env name priv ty =
+  ignore(filter_method env name priv ty)
+
+let filter_self_method env lab priv meths ty =
+  let ty' = filter_method env lab priv ty in
+  try
+    Meths.find lab !meths
+  with Not_found ->
+    let pair = (Ident.create_local lab, ty') in
+    meths := Meths.add lab pair !meths;
+    pair
+
+
+                        (***********************************)
+                        (*  Matching between type schemes  *)
+                        (***********************************)
+
+(*
+   Update the level of [ty]. First check that the levels of generic
+   variables from the subject are not lowered.
+*)
+let moregen_occur env level ty =
+  let rec occur ty =
+    let ty = repr ty in
+    if ty.level <= level then () else
+    if is_Tvar ty && ty.level >= generic_level - 1 then raise Occur else
+    if try_mark_node ty then iter_type_expr occur ty
+  in
+  begin try
+    occur ty; unmark_type ty
+  with Occur ->
+    unmark_type ty; raise_unexplained_for Moregen
+  end;
+  (* also check for free univars *)
+  occur_univar_for Moregen env ty;
+  update_level_for Moregen env level ty
+
+let may_instantiate inst_nongen t1 =
+  if inst_nongen then t1.level <> generic_level - 1
+                 else t1.level =  generic_level
+
+let rec moregen inst_nongen type_pairs env t1 t2 =
+  if t1 == t2 then () else
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if t1 == t2 then () else
+  try
+    match (t1.desc, t2.desc) with
+    | (Tvar _, _) when may_instantiate inst_nongen t1 ->
+        moregen_occur env t1.level t2;
+        update_scope_for Moregen t1.scope t2;
+        occur_for Moregen env t1 t2;
+        link_type t1 t2
+    | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
+        ()
+    | _ ->
+        let t1' = expand_head env t1 in
+        let t2' = expand_head env t2 in
+        (* Expansion may have changed the representative of the types... *)
+        let t1' = repr t1' and t2' = repr t2' in
+        if t1' == t2' then () else
+        begin try
+          TypePairs.find type_pairs (t1', t2')
+        with Not_found ->
+          TypePairs.add type_pairs (t1', t2') ();
+          match (t1'.desc, t2'.desc) with
+            (Tvar _, _) when may_instantiate inst_nongen t1' ->
+              moregen_occur env t1'.level t2;
+              update_scope_for Moregen t1'.scope t2;
+              link_type t1' t2
+          | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2
+            || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
+              moregen inst_nongen type_pairs env t1 t2;
+              moregen inst_nongen type_pairs env u1 u2
+          | (Ttuple tl1, Ttuple tl2) ->
+              moregen_list inst_nongen type_pairs env tl1 tl2
+          | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
+                when Path.same p1 p2 ->
+              moregen_list inst_nongen type_pairs env tl1 tl2
+          | (Tpackage (p1, fl1), Tpackage (p2, fl2)) ->
+              begin try
+                unify_package env (moregen_list inst_nongen type_pairs env)
+                  t1'.level p1 fl1 t2'.level p2 fl2
+              with Not_found -> raise_unexplained_for Moregen
+              end
+          | (Tnil,  Tconstr _ ) -> raise_for Moregen (Obj (Abstract_row Second))
+          | (Tconstr _,  Tnil ) -> raise_for Moregen (Obj (Abstract_row First))
+          | (Tvariant row1, Tvariant row2) ->
+              moregen_row inst_nongen type_pairs env row1 row2
+          | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) ->
+              moregen_fields inst_nongen type_pairs env fi1 fi2
+          | (Tfield _, Tfield _) ->           (* Actually unused *)
+              moregen_fields inst_nongen type_pairs env t1' t2'
+          | (Tnil, Tnil) ->
+              ()
+          | (Tpoly (t1, []), Tpoly (t2, [])) ->
+              moregen inst_nongen type_pairs env t1 t2
+          | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+              enter_poly_for Moregen env univar_pairs t1 tl1 t2 tl2
+                (moregen inst_nongen type_pairs env)
+          | (Tunivar _, Tunivar _) ->
+              unify_univar_for Moregen t1' t2' !univar_pairs
+          | (_, _) ->
+              raise_unexplained_for Moregen
+        end
+  with Moregen trace -> raise ( Moregen ( Errortrace.diff t1 t2 :: trace ) );
+
+
+and moregen_list inst_nongen type_pairs env tl1 tl2 =
+  if List.length tl1 <> List.length tl2 then
+    raise_unexplained_for Moregen;
+  List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2
+
+and moregen_fields inst_nongen type_pairs env ty1 ty2 =
+  let (fields1, rest1) = flatten_fields ty1
+  and (fields2, rest2) = flatten_fields ty2 in
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  begin
+    match miss1 with
+    | (n, _, _) :: _ -> raise_for Moregen (Obj (Missing_field (Second, n)))
+    | [] -> ()
+  end;
+  moregen inst_nongen type_pairs env rest1
+    (build_fields (repr ty2).level miss2 rest2);
+
+  List.iter
+    (fun (n, k1, t1, k2, t2) ->
+       (* The below call should never throw [Public_method_to_private_method] *)
+       moregen_kind k1 k2;
+       try moregen inst_nongen type_pairs env t1 t2 with Moregen trace ->
+         raise( Moregen ( Errortrace.incompatible_fields n t1 t2 :: trace ) )
+    )
+    pairs
+
+and moregen_kind k1 k2 =
+  let k1 = field_kind_repr k1 in
+  let k2 = field_kind_repr k2 in
+  if k1 == k2 then () else
+  match k1, k2 with
+    (Fvar r, (Fvar _ | Fpresent))  -> set_kind r k2
+  | (Fpresent, Fpresent)           -> ()
+  | (Fpresent, Fvar _)             -> raise Public_method_to_private_method
+  | (Fabsent, _) | (_, Fabsent)    -> assert false
+
+and moregen_row inst_nongen type_pairs env row1 row2 =
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let rm1 = repr row1.row_more and rm2 = repr row2.row_more in
+  if rm1 == rm2 then () else
+  let may_inst =
+    is_Tvar rm1 && may_instantiate inst_nongen rm1 || rm1.desc = Tnil in
+  let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
+  let r1, r2 =
+    if row2.row_closed then
+      filter_row_fields may_inst r1, filter_row_fields false r2
+    else r1, r2
+  in
+  begin
+    if r1 <> [] then raise_for Moregen (Variant (No_tags (Second, r1)))
+  end;
+  if row1.row_closed then begin
+    match row2.row_closed, r2 with
+    | false, _ -> raise_for Moregen (Variant (Openness Second))
+    | _, _ :: _ -> raise_for Moregen (Variant (No_tags (First, r2)))
+    | _, [] -> ()
+  end;
+  begin match rm1.desc, rm2.desc with
+    Tunivar _, Tunivar _ ->
+      unify_univar_for Moregen rm1 rm2 !univar_pairs
+  | Tunivar _, _ | _, Tunivar _ ->
+      raise_unexplained_for Moregen
+  | _ when static_row row1 -> ()
+  | _ when may_inst ->
+      let ext =
+        newgenty (Tvariant {row2 with row_fields = r2; row_name = None})
+      in
+      moregen_occur env rm1.level ext;
+      update_scope_for Moregen rm1.scope ext;
+      link_type rm1 ext
+  | Tconstr _, Tconstr _ ->
+      moregen inst_nongen type_pairs env rm1 rm2
+  | _ -> raise_unexplained_for Moregen
+  end;
+  List.iter
+    (fun (l,f1,f2) ->
+       try
+         let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
+         if f1 == f2 then () else
+         match f1, f2 with
+         | Rpresent(Some t1), Rpresent(Some t2) ->
+             moregen inst_nongen type_pairs env t1 t2
+         | Rpresent None, Rpresent None -> ()
+         | Reither(false, tl1, _, e1), Rpresent(Some t2) when may_inst ->
+             set_row_field e1 f2;
+             List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1
+         | Reither(c1, tl1, _, e1), Reither(c2, tl2, m2, e2) ->
+             if e1 != e2 then begin
+               if c1 && not c2 then raise_unexplained_for Moregen;
+               set_row_field e1 (Reither (c2, [], m2, e2));
+               if List.length tl1 = List.length tl2 then
+                 List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2
+               else match tl2 with
+                 | t2 :: _ ->
+                     List.iter
+                       (fun t1 -> moregen inst_nongen type_pairs env t1 t2)
+                       tl1
+                 | [] -> if tl1 <> [] then raise_unexplained_for Moregen
+             end
+         | Reither(true, [], _, e1), Rpresent None when may_inst ->
+             set_row_field e1 f2
+         | Reither(_, _, _, e1), Rabsent when may_inst -> set_row_field e1 f2
+         | Rabsent, Rabsent -> ()
+         | Rpresent (Some _), Rpresent None -> raise_unexplained_for Moregen
+         | Rpresent None, Rpresent (Some _) -> raise_unexplained_for Moregen
+         | Rpresent _, Reither _ -> raise_unexplained_for Moregen
+         | _ -> raise_unexplained_for Moregen
+       with Moregen err ->
+         raise (Moregen (Variant (Incompatible_types_for l) :: err)))
+    pairs
+
+(* Must empty univar_pairs first *)
+let moregen inst_nongen type_pairs env patt subj =
+  univar_pairs := [];
+  moregen inst_nongen type_pairs env patt subj
+
+(*
+   Non-generic variable can be instantiated only if [inst_nongen] is
+   true. So, [inst_nongen] should be set to false if the subject might
+   contain non-generic variables (and we do not want them to be
+   instantiated).
+   Usually, the subject is given by the user, and the pattern
+   is unimportant.  So, no need to propagate abbreviations.
+*)
+let moregeneral env inst_nongen pat_sch subj_sch =
+  let old_level = !current_level in
+  current_level := generic_level - 1;
+  (*
+     Generic variables are first duplicated with [instance].  So,
+     their levels are lowered to [generic_level - 1].  The subject is
+     then copied with [duplicate_type].  That way, its levels won't be
+     changed.
+  *)
+  let subj = duplicate_type (instance subj_sch) in
+  current_level := generic_level;
+  (* Duplicate generic variables *)
+  let patt = instance pat_sch in
+
+  Misc.try_finally
+    (fun () -> moregen inst_nongen (TypePairs.create 13) env patt subj)
+    ~always:(fun () -> current_level := old_level)
+
+let is_moregeneral env inst_nongen pat_sch subj_sch =
+  match moregeneral env inst_nongen pat_sch subj_sch with
+  | () -> true
+  | exception Moregen _ -> false
+
+(* Alternative approach: "rigidify" a type scheme,
+   and check validity after unification *)
+(* Simpler, no? *)
+
+let rec rigidify_rec vars ty =
+  let ty = repr ty in
+  if try_mark_node ty then
+    begin match ty.desc with
+    | Tvar _ ->
+        if not (List.memq ty !vars) then vars := ty :: !vars
+    | Tvariant row ->
+        let row = row_repr row in
+        let more = repr row.row_more in
+        if is_Tvar more && not (row_fixed row) then begin
+          let more' = newty2 more.level more.desc in
+          let row' =
+            {row with row_fixed=Some Rigid; row_fields=[]; row_more=more'}
+          in link_type more (newty2 ty.level (Tvariant row'))
+        end;
+        iter_row (rigidify_rec vars) row;
+        (* only consider the row variable if the variant is not static *)
+        if not (static_row row) then rigidify_rec vars (row_more row)
+    | _ ->
+        iter_type_expr (rigidify_rec vars) ty
+    end
+
+let rigidify ty =
+  let vars = ref [] in
+  rigidify_rec vars ty;
+  unmark_type ty;
+  !vars
+
+let all_distinct_vars env vars =
+  let tyl = ref [] in
+  List.for_all
+    (fun ty ->
+      let ty = expand_head env ty in
+      if List.memq ty !tyl then false else
+      (tyl := ty :: !tyl; is_Tvar ty))
+    vars
+
+let matches env ty ty' =
+  let snap = snapshot () in
+  let vars = rigidify ty in
+  cleanup_abbrev ();
+  match unify env ty ty' with
+  | () ->
+      if not (all_distinct_vars env vars) then begin
+        backtrack snap;
+        raise (Matches_failure (env, [Errortrace.diff ty ty']))
+      end;
+      backtrack snap
+  | exception Unify trace ->
+      backtrack snap;
+      raise (Matches_failure (env, trace))
+
+let does_match env ty ty' =
+  match matches env ty ty' with
+  | () -> true
+  | exception Matches_failure (_, _) -> false
+
+                 (*********************************************)
+                 (*  Equivalence between parameterized types  *)
+                 (*********************************************)
+
+let expand_head_rigid env ty =
+  let old = !rigid_variants in
+  rigid_variants := true;
+  let ty' = expand_head env ty in
+  rigid_variants := old; ty'
+
+let normalize_subst subst =
+  if List.exists
+      (function {desc=Tlink _}, _ | _, {desc=Tlink _} -> true | _ -> false)
+      !subst
+  then subst := List.map (fun (t1,t2) -> repr t1, repr t2) !subst
+
+let rec eqtype rename type_pairs subst env t1 t2 =
+  if t1 == t2 then () else
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if t1 == t2 then () else
+
+  try
+    match (t1.desc, t2.desc) with
+    | (Tvar _, Tvar _) when rename ->
+        begin try
+          normalize_subst subst;
+          if List.assq t1 !subst != t2 then raise_unexplained_for Equality
+        with Not_found ->
+          if List.exists (fun (_, t) -> t == t2) !subst then
+            raise_unexplained_for Equality;
+          subst := (t1, t2) :: !subst
+        end
+    | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
+        ()
+    | _ ->
+        let t1' = expand_head_rigid env t1 in
+        let t2' = expand_head_rigid env t2 in
+        (* Expansion may have changed the representative of the types... *)
+        let t1' = repr t1' and t2' = repr t2' in
+        if t1' == t2' then () else
+        begin try
+          TypePairs.find type_pairs (t1', t2')
+        with Not_found ->
+          TypePairs.add type_pairs (t1', t2') ();
+          match (t1'.desc, t2'.desc) with
+          | (Tvar _, Tvar _) when rename ->
+              begin try
+                normalize_subst subst;
+                if List.assq t1' !subst != t2' then
+                  raise_unexplained_for Equality
+              with Not_found ->
+                if List.exists (fun (_, t) -> t == t2') !subst then
+                  raise_unexplained_for Equality;
+                subst := (t1', t2') :: !subst
+              end
+          | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2
+            || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
+              eqtype rename type_pairs subst env t1 t2;
+              eqtype rename type_pairs subst env u1 u2;
+          | (Ttuple tl1, Ttuple tl2) ->
+              eqtype_list rename type_pairs subst env tl1 tl2
+          | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
+                when Path.same p1 p2 ->
+              eqtype_list rename type_pairs subst env tl1 tl2
+          | (Tpackage (p1, fl1), Tpackage (p2, fl2)) ->
+              begin try
+                unify_package env (eqtype_list rename type_pairs subst env)
+                  t1'.level p1 fl1 t2'.level p2 fl2
+              with Not_found -> raise_unexplained_for Equality
+              end
+          | (Tnil,  Tconstr _ ) ->
+              raise_for Equality (Obj (Abstract_row Second))
+          | (Tconstr _,  Tnil ) ->
+              raise_for Equality (Obj (Abstract_row First))
+          | (Tvariant row1, Tvariant row2) ->
+              eqtype_row rename type_pairs subst env row1 row2
+          | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) ->
+              eqtype_fields rename type_pairs subst env fi1 fi2
+          | (Tfield _, Tfield _) ->       (* Actually unused *)
+              eqtype_fields rename type_pairs subst env t1' t2'
+          | (Tnil, Tnil) ->
+              ()
+          | (Tpoly (t1, []), Tpoly (t2, [])) ->
+              eqtype rename type_pairs subst env t1 t2
+          | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+              enter_poly_for Equality env univar_pairs t1 tl1 t2 tl2
+                (eqtype rename type_pairs subst env)
+          | (Tunivar _, Tunivar _) ->
+              unify_univar_for Equality t1' t2' !univar_pairs
+          | (_, _) ->
+              raise_unexplained_for Equality
+        end
+  with Equality trace ->  raise ( Equality (Errortrace.diff t1 t2 :: trace) )
+
+and eqtype_list rename type_pairs subst env tl1 tl2 =
+  if List.length tl1 <> List.length tl2 then
+    raise_unexplained_for Equality;
+  List.iter2 (eqtype rename type_pairs subst env) tl1 tl2
+
+and eqtype_fields rename type_pairs subst env ty1 ty2 =
+  let (fields1, rest1) = flatten_fields ty1 in
+  let (fields2, rest2) = flatten_fields ty2 in
+  (* First check if same row => already equal *)
+  let same_row =
+    rest1 == rest2 || TypePairs.mem type_pairs (rest1,rest2) ||
+    (rename && List.mem (rest1, rest2) !subst)
+  in
+  if same_row then () else
+  (* Try expansion, needed when called from Includecore.type_manifest *)
+  match expand_head_rigid env rest2 with
+    {desc=Tobject(ty2,_)} -> eqtype_fields rename type_pairs subst env ty1 ty2
+  | _ ->
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  eqtype rename type_pairs subst env rest1 rest2;
+  match miss1, miss2 with
+  | ((n, _, _)::_, _) -> raise_for Equality (Obj (Missing_field (Second, n)))
+  | (_, (n, _, _)::_) -> raise_for Equality (Obj (Missing_field (First, n)))
+  | [], [] ->
+      List.iter
+        (function (n, k1, t1, k2, t2) ->
+           eqtype_kind k1 k2;
+           try
+             eqtype rename type_pairs subst env t1 t2;
+           with Equality trace ->
+             raise (Equality (Errortrace.incompatible_fields n t1 t2 :: trace)))
+        pairs
+
+and eqtype_kind k1 k2 =
+  let k1 = field_kind_repr k1 in
+  let k2 = field_kind_repr k2 in
+  match k1, k2 with
+  | (Fvar _, Fvar _)
+  | (Fpresent, Fpresent) -> ()
+  | _                    -> raise_unexplained_for Equality
+
+and eqtype_row rename type_pairs subst env row1 row2 =
+  (* Try expansion, needed when called from Includecore.type_manifest *)
+  match expand_head_rigid env (row_more row2) with
+    {desc=Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2
+  | _ ->
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
+  if row1.row_closed <> row2.row_closed then begin
+    raise_for Equality
+      (Variant (Openness (if row2.row_closed then First else Second)))
+  end;
+  if not row1.row_closed then begin
+    match r1, r2 with
+    | _::_, _ -> raise_for Equality (Variant (No_tags (Second, r1)))
+    | _, _::_ -> raise_for Equality (Variant (No_tags (First,  r2)))
+    | _, _ -> ()
+  end;
+  begin
+    match filter_row_fields false r1 with
+    | [] -> ();
+    | _ :: _ as r1 -> raise_for Equality (Variant (No_tags (Second, r1)))
+  end;
+  begin
+    match filter_row_fields false r2 with
+    | [] -> ()
+    | _ :: _ as r2 -> raise_for Equality (Variant (No_tags (First, r2)))
+  end;
+  if not (static_row row1) then
+    eqtype rename type_pairs subst env row1.row_more row2.row_more;
+  List.iter
+    (fun (l,f1,f2) ->
+       try
+         match row_field_repr f1, row_field_repr f2 with
+         | Rpresent(Some t1), Rpresent(Some t2) ->
+             eqtype rename type_pairs subst env t1 t2
+         | Reither(c1, [], _, _), Reither(c2, [], _, _) when c1 = c2 -> ()
+         | Reither(c1, t1::tl1, _, _), Reither(c2, t2::tl2, _, _)
+           when c1 = c2 ->
+             eqtype rename type_pairs subst env t1 t2;
+             if List.length tl1 = List.length tl2 then
+               (* if same length allow different types (meaning?) *)
+               List.iter2 (eqtype rename type_pairs subst env) tl1 tl2
+             else begin
+               (* otherwise everything must be equal *)
+               List.iter (eqtype rename type_pairs subst env t1) tl2;
+               List.iter
+                 (fun t1 -> eqtype rename type_pairs subst env t1 t2) tl1
+             end
+         | Rpresent None, Rpresent None -> ()
+         | Rabsent, Rabsent -> ()
+         | Rpresent (Some _), Rpresent None -> raise_unexplained_for Equality
+         | Rpresent None, Rpresent (Some _) -> raise_unexplained_for Equality
+         | Rpresent _, Reither _ -> raise_unexplained_for Equality
+         | Reither _, Rpresent _ -> raise_unexplained_for Equality
+         | _ -> raise_unexplained_for Equality
+       with Equality err ->
+         raise (Equality (Variant (Incompatible_types_for l):: err)))
+    pairs
+
+(* Must empty univar_pairs first *)
+let eqtype_list rename type_pairs subst env tl1 tl2 =
+  univar_pairs := [];
+  let snap = Btype.snapshot () in
+  Misc.try_finally
+    ~always:(fun () -> backtrack snap)
+    (fun () -> eqtype_list rename type_pairs subst env tl1 tl2)
+
+let eqtype rename type_pairs subst env t1 t2 =
+  eqtype_list rename type_pairs subst env [t1] [t2]
+
+(* Two modes: with or without renaming of variables *)
+let equal env rename tyl1 tyl2 =
+  eqtype_list rename (TypePairs.create 11) (ref []) env tyl1 tyl2
+
+let is_equal env rename tyl1 tyl2 =
+  match equal env rename tyl1 tyl2 with
+  | () -> true
+  | exception Equality _ -> false
+
+let rec equal_private env params1 ty1 params2 ty2 =
+  match equal env true (params1 @ [ty1]) (params2 @ [ty2]) with
+  | () -> ()
+  | exception (Equality _ as err) ->
+      match try_expand_safe_opt env (expand_head env ty1) with
+      | ty1' -> equal_private env params1 ty1' params2 ty2
+      | exception Cannot_expand -> raise err
+
+                          (*************************)
+                          (*  Class type matching  *)
+                          (*************************)
+
+type class_match_failure_trace_type =
+  | CM_Equality
+  | CM_Moregen
+
+type class_match_failure =
+    CM_Virtual_class
+  | CM_Parameter_arity_mismatch of int * int
+  | CM_Type_parameter_mismatch of Env.t * comparison Errortrace.t (* Equality *)
+  | CM_Class_type_mismatch of Env.t * class_type * class_type
+  | CM_Parameter_mismatch of Env.t * comparison Errortrace.t (* Moregen *)
+  | CM_Val_type_mismatch of
+      class_match_failure_trace_type * string * Env.t * comparison Errortrace.t
+  | CM_Meth_type_mismatch of
+      class_match_failure_trace_type * string * Env.t * comparison Errortrace.t
+  | CM_Non_mutable_value of string
+  | CM_Non_concrete_value of string
+  | CM_Missing_value of string
+  | CM_Missing_method of string
+  | CM_Hide_public of string
+  | CM_Hide_virtual of string * string
+  | CM_Public_method of string
+  | CM_Private_method of string
+  | CM_Virtual_method of string
+
+exception Failure of class_match_failure list
+
+let rec moregen_clty trace type_pairs env cty1 cty2 =
+  try
+    match cty1, cty2 with
+      Cty_constr (_, _, cty1), _ ->
+        moregen_clty true type_pairs env cty1 cty2
+    | _, Cty_constr (_, _, cty2) ->
+        moregen_clty true type_pairs env cty1 cty2
+    | Cty_arrow (l1, ty1, cty1'), Cty_arrow (l2, ty2, cty2') when l1 = l2 ->
+        begin try moregen true type_pairs env ty1 ty2 with Moregen trace ->
+          raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)])
+        end;
+        moregen_clty false type_pairs env cty1' cty2'
+    | Cty_signature sign1, Cty_signature sign2 ->
+        let ty1 = object_fields (repr sign1.csig_self) in
+        let ty2 = object_fields (repr sign2.csig_self) in
+        let (fields1, _rest1) = flatten_fields ty1
+        and (fields2, _rest2) = flatten_fields ty2 in
+        let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in
+        List.iter
+          (fun (lab, _k1, t1, _k2, t2) ->
+            try moregen true type_pairs env t1 t2 with Moregen trace ->
+              raise (Failure [
+                CM_Meth_type_mismatch
+                  (CM_Moregen, lab, env, expand_trace env trace)]))
+          pairs;
+      Vars.iter
+        (fun lab (_mut, _v, ty) ->
+           let (_mut', _v', ty') = Vars.find lab sign1.csig_vars in
+           try moregen true type_pairs env ty' ty with Moregen trace ->
+             raise (Failure [
+               CM_Val_type_mismatch
+                 (CM_Moregen, lab, env, expand_trace env trace)]))
+        sign2.csig_vars
+  | _ ->
+      raise (Failure [])
+  with
+    Failure error when trace || error = [] ->
+      raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error))
+
+let match_class_types ?(trace=true) env pat_sch subj_sch =
+  let type_pairs = TypePairs.create 53 in
+  let old_level = !current_level in
+  current_level := generic_level - 1;
+  (*
+     Generic variables are first duplicated with [instance].  So,
+     their levels are lowered to [generic_level - 1].  The subject is
+     then copied with [duplicate_type].  That way, its levels won't be
+     changed.
+  *)
+  let (_, subj_inst) = instance_class [] subj_sch in
+  let subj = duplicate_class_type subj_inst in
+  current_level := generic_level;
+  (* Duplicate generic variables *)
+  let (_, patt) = instance_class [] pat_sch in
+  let res =
+    let sign1 = signature_of_class_type patt in
+    let sign2 = signature_of_class_type subj in
+    let t1 = repr sign1.csig_self in
+    let t2 = repr sign2.csig_self in
+    TypePairs.add type_pairs (t1, t2) ();
+    let (fields1, rest1) = flatten_fields (object_fields t1)
+    and (fields2, rest2) = flatten_fields (object_fields t2) in
+    let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+    let error =
+      List.fold_right
+        (fun (lab, k, _) err ->
+           let err =
+             let k = field_kind_repr k in
+             begin match k with
+               Fvar r -> set_kind r Fabsent; err
+             | _      -> CM_Hide_public lab::err
+             end
+           in
+           if lab = dummy_method || Concr.mem lab sign1.csig_concr then err
+           else CM_Hide_virtual ("method", lab) :: err)
+        miss1 []
+    in
+    let missing_method = List.map (fun (m, _, _) -> m) miss2 in
+    let error =
+      (List.map (fun m -> CM_Missing_method m) missing_method) @ error
+    in
+    (* Always succeeds *)
+    moregen true type_pairs env rest1 rest2;
+    let error =
+      List.fold_right
+        (fun (lab, k1, _t1, k2, _t2) err ->
+           match moregen_kind k1 k2 with
+           | () -> err
+           | exception Public_method_to_private_method ->
+               CM_Public_method lab :: err)
+        pairs error
+    in
+    let error =
+      Vars.fold
+        (fun lab (mut, vr, _ty) err ->
+          try
+            let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in
+            if mut = Mutable && mut' <> Mutable then
+              CM_Non_mutable_value lab::err
+            else if vr = Concrete && vr' <> Concrete then
+              CM_Non_concrete_value lab::err
+            else
+              err
+          with Not_found ->
+            CM_Missing_value lab::err)
+        sign2.csig_vars error
+    in
+    let error =
+      Vars.fold
+        (fun lab (_,vr,_) err ->
+          if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then
+            CM_Hide_virtual ("instance variable", lab) :: err
+          else err)
+        sign1.csig_vars error
+    in
+    let error =
+      List.fold_right
+        (fun e l ->
+           if List.mem e missing_method then l else CM_Virtual_method e::l)
+        (Concr.elements (Concr.diff sign2.csig_concr sign1.csig_concr))
+        error
+    in
+    match error with
+      [] ->
+        begin try
+          moregen_clty trace type_pairs env patt subj;
+          []
+        with
+          Failure r -> r
+        end
+    | error ->
+        CM_Class_type_mismatch (env, patt, subj)::error
+  in
+  current_level := old_level;
+  res
+
+let equal_clsig trace type_pairs subst env sign1 sign2 =
+  try
+    let ty1 = object_fields (repr sign1.csig_self) in
+    let ty2 = object_fields (repr sign2.csig_self) in
+    let (fields1, _rest1) = flatten_fields ty1
+    and (fields2, _rest2) = flatten_fields ty2 in
+    let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in
+    List.iter
+      (fun (lab, _k1, t1, _k2, t2) ->
+         begin try eqtype true type_pairs subst env t1 t2 with
+           Equality trace ->
+           raise (Failure [CM_Meth_type_mismatch
+                             (CM_Equality, lab, env, expand_trace env trace)])
+         end)
+      pairs;
+    Vars.iter
+      (fun lab (_, _, ty) ->
+         let (_, _, ty') = Vars.find lab sign1.csig_vars in
+         try eqtype true type_pairs subst env ty' ty with Equality trace ->
+           raise (Failure [CM_Val_type_mismatch
+                             (CM_Equality, lab, env, expand_trace env trace)]))
+      sign2.csig_vars
+  with
+    Failure error when trace ->
+      raise (Failure (CM_Class_type_mismatch
+                        (env, Cty_signature sign1, Cty_signature sign2)::error))
+
+let match_class_declarations env patt_params patt_type subj_params subj_type =
+  let type_pairs = TypePairs.create 53 in
+  let subst = ref [] in
+  let sign1 = signature_of_class_type patt_type in
+  let sign2 = signature_of_class_type subj_type in
+  let t1 = repr sign1.csig_self in
+  let t2 = repr sign2.csig_self in
+  TypePairs.add type_pairs (t1, t2) ();
+  let (fields1, rest1) = flatten_fields (object_fields t1)
+  and (fields2, rest2) = flatten_fields (object_fields t2) in
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  let error =
+    List.fold_right
+      (fun (lab, k, _) err ->
+        let err =
+          let k = field_kind_repr k in
+          begin match k with
+            Fvar _ -> err
+          | _      -> CM_Hide_public lab::err
+          end
+        in
+        if Concr.mem lab sign1.csig_concr then err
+        else CM_Hide_virtual ("method", lab) :: err)
+      miss1 []
+  in
+  let missing_method = List.map (fun (m, _, _) -> m) miss2 in
+  let error =
+    (List.map (fun m -> CM_Missing_method m) missing_method) @ error
+  in
+  (* Always succeeds *)
+  eqtype true type_pairs subst env rest1 rest2;
+  let error =
+    List.fold_right
+      (fun (lab, k1, _t1, k2, _t2) err ->
+        let k1 = field_kind_repr k1 in
+        let k2 = field_kind_repr k2 in
+        match k1, k2 with
+          (Fvar _, Fvar _)
+        | (Fpresent, Fpresent) -> err
+        | (Fvar _, Fpresent)   -> CM_Private_method lab::err
+        | (Fpresent, Fvar _)  -> CM_Public_method lab::err
+        | _                    -> assert false)
+      pairs error
+  in
+  let error =
+    Vars.fold
+      (fun lab (mut, vr, _ty) err ->
+         try
+           let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in
+           if mut = Mutable && mut' <> Mutable then
+             CM_Non_mutable_value lab::err
+           else if vr = Concrete && vr' <> Concrete then
+             CM_Non_concrete_value lab::err
+           else
+             err
+         with Not_found ->
+           CM_Missing_value lab::err)
+      sign2.csig_vars error
+  in
+  let error =
+    Vars.fold
+      (fun lab (_,vr,_) err ->
+        if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then
+          CM_Hide_virtual ("instance variable", lab) :: err
+        else err)
+      sign1.csig_vars error
+  in
+  let error =
+    List.fold_right
+      (fun e l ->
+        if List.mem e missing_method then l else CM_Virtual_method e::l)
+      (Concr.elements (Concr.diff sign2.csig_concr sign1.csig_concr))
+      error
+  in
+  match error with
+    [] ->
+      begin try
+        let lp = List.length patt_params in
+        let ls = List.length subj_params in
+        if lp  <> ls then
+          raise (Failure [CM_Parameter_arity_mismatch (lp, ls)]);
+        List.iter2 (fun p s ->
+          try eqtype true type_pairs subst env p s with Equality trace ->
+            raise (Failure [CM_Type_parameter_mismatch
+                               (env, expand_trace env trace)]))
+          patt_params subj_params;
+     (* old code: equal_clty false type_pairs subst env patt_type subj_type; *)
+        equal_clsig false type_pairs subst env sign1 sign2;
+        (* Use moregeneral for class parameters, need to recheck everything to
+           keeps relationships (PR#4824) *)
+        let clty_params =
+          List.fold_right (fun ty cty -> Cty_arrow (Labelled "*",ty,cty)) in
+        match_class_types ~trace:false env
+          (clty_params patt_params patt_type)
+          (clty_params subj_params subj_type)
+      with
+        Failure r -> r
+      end
+  | error ->
+      error
+
+
+                              (***************)
+                              (*  Subtyping  *)
+                              (***************)
+
+
+(**** Build a subtype of a given type. ****)
+
+(* build_subtype:
+   [visited] traces traversed object and variant types
+   [loops] is a mapping from variables to variables, to reproduce
+     positive loops in a class type
+   [posi] true if the current variance is positive
+   [level] number of expansions/enlargement allowed on this branch *)
+
+let warn = ref false  (* whether double coercion might do better *)
+let pred_expand n = if n mod 2 = 0 && n > 0 then pred n else n
+let pred_enlarge n = if n mod 2 = 1 then pred n else n
+
+type change = Unchanged | Equiv | Changed
+let max_change c1 c2 =
+  match c1, c2 with
+  | _, Changed | Changed, _ -> Changed
+  | Equiv, _ | _, Equiv -> Equiv
+  | _ -> Unchanged
+
+let collect l = List.fold_left (fun c1 (_, c2) -> max_change c1 c2) Unchanged l
+
+let rec filter_visited = function
+    [] -> []
+  | {desc=Tobject _|Tvariant _} :: _ as l -> l
+  | _ :: l -> filter_visited l
+
+let memq_warn t visited =
+  if List.memq t visited then (warn := true; true) else false
+
+let find_cltype_for_path env p =
+  let cl_abbr = Env.find_hash_type p env in
+  match cl_abbr.type_manifest with
+    Some ty ->
+      begin match (repr ty).desc with
+        Tobject(_,{contents=Some(p',_)}) when Path.same p p' -> cl_abbr, ty
+      | _ -> raise Not_found
+      end
+  | None -> assert false
+
+let has_constr_row' env t =
+  has_constr_row (expand_abbrev env t)
+
+let rec build_subtype env visited loops posi level t =
+  let t = repr t in
+  match t.desc with
+    Tvar _ ->
+      if posi then
+        try
+          let t' = List.assq t loops in
+          warn := true;
+          (t', Equiv)
+        with Not_found ->
+          (t, Unchanged)
+      else
+        (t, Unchanged)
+  | Tarrow(l, t1, t2, _) ->
+      if memq_warn t visited then (t, Unchanged) else
+      let visited = t :: visited in
+      let (t1', c1) = build_subtype env visited loops (not posi) level t1 in
+      let (t2', c2) = build_subtype env visited loops posi level t2 in
+      let c = max_change c1 c2 in
+      if c > Unchanged then (newty (Tarrow(l, t1', t2', Cok)), c)
+      else (t, Unchanged)
+  | Ttuple tlist ->
+      if memq_warn t visited then (t, Unchanged) else
+      let visited = t :: visited in
+      let tlist' =
+        List.map (build_subtype env visited loops posi level) tlist
+      in
+      let c = collect tlist' in
+      if c > Unchanged then (newty (Ttuple (List.map fst tlist')), c)
+      else (t, Unchanged)
+  | Tconstr(p, tl, abbrev)
+    when level > 0 && generic_abbrev env p && safe_abbrev env t
+    && not (has_constr_row' env t) ->
+      let t' = repr (expand_abbrev env t) in
+      let level' = pred_expand level in
+      begin try match t'.desc with
+        Tobject _ when posi && not (opened_object t') ->
+          let cl_abbr, body = find_cltype_for_path env p in
+          let ty =
+            try
+              subst env !current_level Public abbrev None
+                cl_abbr.type_params tl body
+            with Cannot_subst -> assert false in
+          let ty = repr ty in
+          let ty1, tl1 =
+            match ty.desc with
+              Tobject(ty1,{contents=Some(p',tl1)}) when Path.same p p' ->
+                ty1, tl1
+            | _ -> raise Not_found
+          in
+          (* Fix PR#4505: do not set ty to Tvar when it appears in tl1,
+             as this occurrence might break the occur check.
+             XXX not clear whether this correct anyway... *)
+          if List.exists (deep_occur ty) tl1 then raise Not_found;
+          set_type_desc ty (Tvar None);
+          let t'' = newvar () in
+          let loops = (ty, t'') :: loops in
+          (* May discard [visited] as level is going down *)
+          let (ty1', c) =
+            build_subtype env [t'] loops posi (pred_enlarge level') ty1 in
+          assert (is_Tvar t'');
+          let nm =
+            if c > Equiv || deep_occur ty ty1' then None else Some(p,tl1) in
+          set_type_desc t'' (Tobject (ty1', ref nm));
+          (try unify_var env ty t with Unify _ -> assert false);
+          (t'', Changed)
+      | _ -> raise Not_found
+      with Not_found ->
+        let (t'',c) = build_subtype env visited loops posi level' t' in
+        if c > Unchanged then (t'',c)
+        else (t, Unchanged)
+      end
+  | Tconstr(p, tl, _abbrev) ->
+      (* Must check recursion on constructors, since we do not always
+         expand them *)
+      if memq_warn t visited then (t, Unchanged) else
+      let visited = t :: visited in
+      begin try
+        let decl = Env.find_type p env in
+        if level = 0 && generic_abbrev env p && safe_abbrev env t
+        && not (has_constr_row' env t)
+        then warn := true;
+        let tl' =
+          List.map2
+            (fun v t ->
+              let (co,cn) = Variance.get_upper v in
+              if cn then
+                if co then (t, Unchanged)
+                else build_subtype env visited loops (not posi) level t
+              else
+                if co then build_subtype env visited loops posi level t
+                else (newvar(), Changed))
+            decl.type_variance tl
+        in
+        let c = collect tl' in
+        if c > Unchanged then (newconstr p (List.map fst tl'), c)
+        else (t, Unchanged)
+      with Not_found ->
+        (t, Unchanged)
+      end
+  | Tvariant row ->
+      let row = row_repr row in
+      if memq_warn t visited || not (static_row row) then (t, Unchanged) else
+      let level' = pred_enlarge level in
+      let visited =
+        t :: if level' < level then [] else filter_visited visited in
+      let fields = filter_row_fields false row.row_fields in
+      let fields =
+        List.map
+          (fun (l,f as orig) -> match row_field_repr f with
+            Rpresent None ->
+              if posi then
+                (l, Reither(true, [], false, ref None)), Unchanged
+              else
+                orig, Unchanged
+          | Rpresent(Some t) ->
+              let (t', c) = build_subtype env visited loops posi level' t in
+              let f =
+                if posi && level > 0
+                then Reither(false, [t'], false, ref None)
+                else Rpresent(Some t')
+              in (l, f), c
+          | _ -> assert false)
+          fields
+      in
+      let c = collect fields in
+      let row =
+        { row_fields = List.map fst fields; row_more = newvar();
+          row_bound = (); row_closed = posi; row_fixed = None;
+          row_name = if c > Unchanged then None else row.row_name }
+      in
+      (newty (Tvariant row), Changed)
+  | Tobject (t1, _) ->
+      if memq_warn t visited || opened_object t1 then (t, Unchanged) else
+      let level' = pred_enlarge level in
+      let visited =
+        t :: if level' < level then [] else filter_visited visited in
+      let (t1', c) = build_subtype env visited loops posi level' t1 in
+      if c > Unchanged then (newty (Tobject (t1', ref None)), c)
+      else (t, Unchanged)
+  | Tfield(s, _, t1, t2) (* Always present *) ->
+      let (t1', c1) = build_subtype env visited loops posi level t1 in
+      let (t2', c2) = build_subtype env visited loops posi level t2 in
+      let c = max_change c1 c2 in
+      if c > Unchanged then (newty (Tfield(s, Fpresent, t1', t2')), c)
+      else (t, Unchanged)
+  | Tnil ->
+      if posi then
+        let v = newvar () in
+        (v, Changed)
+      else begin
+        warn := true;
+        (t, Unchanged)
+      end
+  | Tsubst _ | Tlink _ ->
+      assert false
+  | Tpoly(t1, tl) ->
+      let (t1', c) = build_subtype env visited loops posi level t1 in
+      if c > Unchanged then (newty (Tpoly(t1', tl)), c)
+      else (t, Unchanged)
+  | Tunivar _ | Tpackage _ ->
+      (t, Unchanged)
+
+let enlarge_type env ty =
+  warn := false;
+  (* [level = 4] allows 2 expansions involving objects/variants *)
+  let (ty', _) = build_subtype env [] [] true 4 ty in
+  (ty', !warn)
+
+(**** Check whether a type is a subtype of another type. ****)
+
+(*
+    During the traversal, a trace of visited types is maintained. It
+    is printed in case of error.
+    Constraints (pairs of types that must be equals) are accumulated
+    rather than being enforced straight. Indeed, the result would
+    otherwise depend on the order in which these constraints are
+    enforced.
+    A function enforcing these constraints is returned. That way, type
+    variables can be bound to their actual values before this function
+    is called (see Typecore).
+    Only well-defined abbreviations are expanded (hence the tests
+    [generic_abbrev ...]).
+*)
+
+let subtypes = TypePairs.create 17
+
+let subtype_error env trace =
+  raise (Subtype (expand_subtype_trace env (List.rev trace), []))
+
+let rec subtype_rec env trace t1 t2 cstrs =
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if t1 == t2 then cstrs else
+
+  begin try
+    TypePairs.find subtypes (t1, t2);
+    cstrs
+  with Not_found ->
+    TypePairs.add subtypes (t1, t2) ();
+    match (t1.desc, t2.desc) with
+      (Tvar _, _) | (_, Tvar _) ->
+        (trace, t1, t2, !univar_pairs)::cstrs
+    | (Tarrow(l1, t1, u1, _), Tarrow(l2, t2, u2, _)) when l1 = l2
+      || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
+        let cstrs = subtype_rec env (Subtype.diff t2 t1::trace) t2 t1 cstrs in
+        subtype_rec env (Subtype.diff u1 u2::trace) u1 u2 cstrs
+    | (Ttuple tl1, Ttuple tl2) ->
+        subtype_list env trace tl1 tl2 cstrs
+    | (Tconstr(p1, [], _), Tconstr(p2, [], _)) when Path.same p1 p2 ->
+        cstrs
+    | (Tconstr(p1, _tl1, _abbrev1), _)
+      when generic_abbrev env p1 && safe_abbrev env t1 ->
+        subtype_rec env trace (expand_abbrev env t1) t2 cstrs
+    | (_, Tconstr(p2, _tl2, _abbrev2))
+      when generic_abbrev env p2 && safe_abbrev env t2 ->
+        subtype_rec env trace t1 (expand_abbrev env t2) cstrs
+    | (Tconstr(p1, tl1, _), Tconstr(p2, tl2, _)) when Path.same p1 p2 ->
+        begin try
+          let decl = Env.find_type p1 env in
+          List.fold_left2
+            (fun cstrs v (t1, t2) ->
+              let (co, cn) = Variance.get_upper v in
+              if co then
+                if cn then
+                  (trace, newty2 t1.level (Ttuple[t1]),
+                   newty2 t2.level (Ttuple[t2]), !univar_pairs) :: cstrs
+                else subtype_rec env (Subtype.diff t1 t2::trace) t1 t2 cstrs
+              else
+                if cn
+                then subtype_rec env (Subtype.diff t2 t1::trace) t2 t1 cstrs
+                else cstrs)
+            cstrs decl.type_variance (List.combine tl1 tl2)
+        with Not_found ->
+          (trace, t1, t2, !univar_pairs)::cstrs
+        end
+    | (Tconstr(p1, _, _), _)
+      when generic_private_abbrev env p1 && safe_abbrev_opt env t1 ->
+        subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs
+(*  | (_, Tconstr(p2, _, _)) when generic_private_abbrev false env p2 ->
+        subtype_rec env trace t1 (expand_abbrev_opt env t2) cstrs *)
+    | (Tobject (f1, _), Tobject (f2, _))
+      when is_Tvar (object_row f1) && is_Tvar (object_row f2) ->
+        (* Same row variable implies same object. *)
+        (trace, t1, t2, !univar_pairs)::cstrs
+    | (Tobject (f1, _), Tobject (f2, _)) ->
+        subtype_fields env trace f1 f2 cstrs
+    | (Tvariant row1, Tvariant row2) ->
+        begin try
+          subtype_row env trace row1 row2 cstrs
+        with Exit ->
+          (trace, t1, t2, !univar_pairs)::cstrs
+        end
+    | (Tpoly (u1, []), Tpoly (u2, [])) ->
+        subtype_rec env trace u1 u2 cstrs
+    | (Tpoly (u1, tl1), Tpoly (u2, [])) ->
+        let _, u1' = instance_poly false tl1 u1 in
+        subtype_rec env trace u1' u2 cstrs
+    | (Tpoly (u1, tl1), Tpoly (u2,tl2)) ->
+        begin try
+          enter_poly env univar_pairs u1 tl1 u2 tl2
+            (fun t1 t2 -> subtype_rec env trace t1 t2 cstrs)
+        with Escape _ ->
+          (trace, t1, t2, !univar_pairs)::cstrs
+        end
+    | (Tpackage (p1, fl1), Tpackage (p2, fl2)) ->
+        begin try
+          let ntl1 = complete_type_list env fl2 t1.level (Mty_ident p1) fl1
+          and ntl2 = complete_type_list env fl1 t2.level (Mty_ident p2) fl2
+              ~allow_absent:true in
+          let cstrs' =
+            List.map
+              (fun (n2,t2) -> (trace, List.assoc n2 ntl1, t2, !univar_pairs))
+              ntl2
+          in
+          if eq_package_path env p1 p2 then cstrs' @ cstrs
+          else begin
+            (* need to check module subtyping *)
+            let snap = Btype.snapshot () in
+            match List.iter (fun (_, t1, t2, _) -> unify env t1 t2) cstrs' with
+            | () when !package_subtype env p1 fl1 p2 fl2 ->
+              Btype.backtrack snap; cstrs' @ cstrs
+            | () | exception Unify _ ->
+              Btype.backtrack snap; raise Not_found
+          end
+        with Not_found ->
+          (trace, t1, t2, !univar_pairs)::cstrs
+        end
+    | (_, _) ->
+        (trace, t1, t2, !univar_pairs)::cstrs
+  end
+
+and subtype_list env trace tl1 tl2 cstrs =
+  if List.length tl1 <> List.length tl2 then
+    subtype_error env trace;
+  List.fold_left2
+    (fun cstrs t1 t2 -> subtype_rec env (Subtype.diff t1 t2::trace) t1 t2 cstrs)
+    cstrs tl1 tl2
+
+and subtype_fields env trace ty1 ty2 cstrs =
+  (* Assume that either rest1 or rest2 is not Tvar *)
+  let (fields1, rest1) = flatten_fields ty1 in
+  let (fields2, rest2) = flatten_fields ty2 in
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  let cstrs =
+    if rest2.desc = Tnil then cstrs else
+    if miss1 = [] then
+      subtype_rec env (Subtype.diff rest1 rest2::trace) rest1 rest2 cstrs
+    else
+      (trace, build_fields (repr ty1).level miss1 rest1, rest2,
+       !univar_pairs) :: cstrs
+  in
+  let cstrs =
+    if miss2 = [] then cstrs else
+    (trace, rest1, build_fields (repr ty2).level miss2 (newvar ()),
+     !univar_pairs) :: cstrs
+  in
+  List.fold_left
+    (fun cstrs (_, _k1, t1, _k2, t2) ->
+      (* These fields are always present *)
+      subtype_rec env (Subtype.diff t1 t2::trace) t1 t2 cstrs)
+    cstrs pairs
+
+and subtype_row env trace row1 row2 cstrs =
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let r1, r2, pairs =
+    merge_row_fields row1.row_fields row2.row_fields in
+  let r1 = if row2.row_closed then filter_row_fields false r1 else r1 in
+  let r2 = if row1.row_closed then filter_row_fields false r2 else r2 in
+  let more1 = repr row1.row_more
+  and more2 = repr row2.row_more in
+  match more1.desc, more2.desc with
+    Tconstr(p1,_,_), Tconstr(p2,_,_) when Path.same p1 p2 ->
+      subtype_rec env (Subtype.diff more1 more2::trace) more1 more2 cstrs
+  | (Tvar _|Tconstr _|Tnil), (Tvar _|Tconstr _|Tnil)
+    when row1.row_closed && r1 = [] ->
+      List.fold_left
+        (fun cstrs (_,f1,f2) ->
+          match row_field_repr f1, row_field_repr f2 with
+            (Rpresent None|Reither(true,_,_,_)), Rpresent None ->
+              cstrs
+          | Rpresent(Some t1), Rpresent(Some t2) ->
+              subtype_rec env (Subtype.diff t1 t2::trace) t1 t2 cstrs
+          | Reither(false, t1::_, _, _), Rpresent(Some t2) ->
+              subtype_rec env (Subtype.diff t1 t2::trace) t1 t2 cstrs
+          | Rabsent, _ -> cstrs
+          | _ -> raise Exit)
+        cstrs pairs
+  | Tunivar _, Tunivar _
+    when row1.row_closed = row2.row_closed && r1 = [] && r2 = [] ->
+      let cstrs =
+        subtype_rec env (Subtype.diff more1 more2::trace) more1 more2 cstrs in
+      List.fold_left
+        (fun cstrs (_,f1,f2) ->
+          match row_field_repr f1, row_field_repr f2 with
+            Rpresent None, Rpresent None
+          | Reither(true,[],_,_), Reither(true,[],_,_)
+          | Rabsent, Rabsent ->
+              cstrs
+          | Rpresent(Some t1), Rpresent(Some t2)
+          | Reither(false,[t1],_,_), Reither(false,[t2],_,_) ->
+              subtype_rec env (Subtype.diff t1 t2::trace) t1 t2 cstrs
+          | _ -> raise Exit)
+        cstrs pairs
+  | _ ->
+      raise Exit
+
+let subtype env ty1 ty2 =
+  TypePairs.clear subtypes;
+  univar_pairs := [];
+  (* Build constraint set. *)
+  let cstrs = subtype_rec env [Subtype.diff ty1 ty2] ty1 ty2 [] in
+  TypePairs.clear subtypes;
+  (* Enforce constraints. *)
+  function () ->
+    List.iter
+      (function (trace0, t1, t2, pairs) ->
+         try unify_pairs (ref env) t1 t2 pairs with Unify trace ->
+           raise (Subtype (expand_subtype_trace env (List.rev trace0),
+                           List.tl trace)))
+      (List.rev cstrs)
+
+                              (*******************)
+                              (*  Miscellaneous  *)
+                              (*******************)
+
+(* Utility for printing. The resulting type is not used in computation. *)
+let rec unalias_object ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tfield (s, k, t1, t2) ->
+      newty2 ty.level (Tfield (s, k, t1, unalias_object t2))
+  | Tvar _ | Tnil ->
+      newty2 ty.level ty.desc
+  | Tunivar _ ->
+      ty
+  | Tconstr _ ->
+      newvar2 ty.level
+  | _ ->
+      assert false
+
+let unalias ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tvar _ | Tunivar _ ->
+      ty
+  | Tvariant row ->
+      let row = row_repr row in
+      let more = row.row_more in
+      newty2 ty.level
+        (Tvariant {row with row_more = newty2 more.level more.desc})
+  | Tobject (ty, nm) ->
+      newty2 ty.level (Tobject (unalias_object ty, nm))
+  | _ ->
+      newty2 ty.level ty.desc
+
+(* Return the arity (as for curried functions) of the given type. *)
+let rec arity ty =
+  match (repr ty).desc with
+    Tarrow(_, _t1, t2, _) -> 1 + arity t2
+  | _ -> 0
+
+(* Check for non-generalizable type variables *)
+exception Non_closed0
+let visited = ref TypeSet.empty
+
+let rec closed_schema_rec env ty =
+  let ty = repr ty in
+  if TypeSet.mem ty !visited then () else begin
+    visited := TypeSet.add ty !visited;
+    match ty.desc with
+      Tvar _ when ty.level <> generic_level ->
+        raise Non_closed0
+    | Tconstr _ ->
+        let old = !visited in
+        begin try iter_type_expr (closed_schema_rec env) ty
+        with Non_closed0 -> try
+          visited := old;
+          closed_schema_rec env (try_expand_head try_expand_safe env ty)
+        with Cannot_expand ->
+          raise Non_closed0
+        end
+    | Tfield(_, kind, t1, t2) ->
+        if field_kind_repr kind = Fpresent then
+          closed_schema_rec env t1;
+        closed_schema_rec env t2
+    | Tvariant row ->
+        let row = row_repr row in
+        iter_row (closed_schema_rec env) row;
+        if not (static_row row) then closed_schema_rec env row.row_more
+    | _ ->
+        iter_type_expr (closed_schema_rec env) ty
+  end
+
+(* Return whether all variables of type [ty] are generic. *)
+let closed_schema env ty =
+  visited := TypeSet.empty;
+  try
+    closed_schema_rec env ty;
+    visited := TypeSet.empty;
+    true
+  with Non_closed0 ->
+    visited := TypeSet.empty;
+    false
+
+(* Normalize a type before printing, saving... *)
+(* Cannot use mark_type because deep_occur uses it too *)
+let rec normalize_type_rec visited ty =
+  let ty = repr ty in
+  if not (TypeSet.mem ty !visited) then begin
+    visited := TypeSet.add ty !visited;
+    let tm = row_of_type ty in
+    begin if not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm then
+      match tm.desc with (* PR#7348 *)
+        Tconstr (Path.Pdot(m,i), tl, _abbrev) ->
+          let i' = String.sub i 0 (String.length i - 4) in
+          set_type_desc ty (Tconstr(Path.Pdot(m,i'), tl, ref Mnil))
+      | _ -> assert false
+    else match ty.desc with
+    | Tvariant row ->
+      let row = row_repr row in
+      let fields = List.map
+          (fun (l,f0) ->
+            let f = row_field_repr f0 in l,
+            match f with Reither(b, ty::(_::_ as tyl), m, e) ->
+              let tyl' =
+                List.fold_left
+                  (fun tyl ty ->
+                    if List.exists
+                          (fun ty' ->
+                             match equal Env.empty false [ty] [ty'] with
+                             | () -> true
+                             | exception Equality _ -> false)
+                          tyl
+                     then tyl else ty::tyl)
+                  [ty] tyl
+              in
+              if f != f0 || List.length tyl' < List.length tyl then
+                Reither(b, List.rev tyl', m, e)
+              else f
+            | _ -> f)
+          row.row_fields in
+      let fields =
+        List.sort (fun (p,_) (q,_) -> compare p q)
+          (List.filter (fun (_,fi) -> fi <> Rabsent) fields) in
+      set_type_desc ty (Tvariant {row with row_fields = fields})
+    | Tobject (fi, nm) ->
+        begin match !nm with
+        | None -> ()
+        | Some (n, v :: l) ->
+            if deep_occur ty (newgenty (Ttuple l)) then
+              (* The abbreviation may be hiding something, so remove it *)
+              set_name nm None
+            else let v' = repr v in
+            begin match v'.desc with
+            | Tvar _ | Tunivar _ ->
+                if v' != v then set_name nm (Some (n, v' :: l))
+            | Tnil ->
+                set_type_desc ty (Tconstr (n, l, ref Mnil))
+            | _ -> set_name nm None
+            end
+        | _ ->
+            fatal_error "Ctype.normalize_type_rec"
+        end;
+        let fi = repr fi in
+        if fi.level < lowest_level then () else
+        let fields, row = flatten_fields fi in
+        let fi' = build_fields fi.level fields row in
+        set_type_desc fi fi'.desc
+    | _ -> ()
+    end;
+    iter_type_expr (normalize_type_rec visited) ty
+  end
+
+let normalize_type ty =
+  normalize_type_rec (ref TypeSet.empty) ty
+
+
+                              (*************************)
+                              (*  Remove dependencies  *)
+                              (*************************)
+
+
+(*
+   Variables are left unchanged. Other type nodes are duplicated, with
+   levels set to generic level.
+   We cannot use Tsubst here, because unification may be called by
+   expand_abbrev.
+*)
+
+let nondep_hash     = TypeHash.create 47
+let nondep_variants = TypeHash.create 17
+let clear_hash ()   =
+  TypeHash.clear nondep_hash; TypeHash.clear nondep_variants
+
+let rec nondep_type_rec ?(expand_private=false) env ids ty =
+  let try_expand env t =
+    if expand_private then try_expand_safe_opt env t
+    else try_expand_safe env t
+  in
+  match ty.desc with
+    Tvar _ | Tunivar _ -> ty
+  | Tlink ty -> nondep_type_rec env ids ty
+  | _ -> try TypeHash.find nondep_hash ty
+  with Not_found ->
+    let ty' = newgenvar () in        (* Stub *)
+    TypeHash.add nondep_hash ty ty';
+    set_type_desc ty'
+      begin match ty.desc with
+      | Tconstr(p, tl, _abbrev) ->
+          begin try
+            (* First, try keeping the same type constructor p *)
+            match Path.find_free_opt ids p with
+            | Some id ->
+               raise (Nondep_cannot_erase id)
+            | None ->
+               Tconstr(p, List.map (nondep_type_rec env ids) tl, ref Mnil)
+          with (Nondep_cannot_erase _) as exn ->
+            (* If that doesn't work, try expanding abbrevs *)
+            try Tlink (nondep_type_rec ~expand_private env ids
+                       (try_expand env (newty2 ty.level ty.desc)))
+              (*
+                 The [Tlink] is important. The expanded type may be a
+                 variable, or may not be completely copied yet
+                 (recursive type), so one cannot just take its
+                 description.
+               *)
+            with Cannot_expand -> raise exn
+          end
+      | Tpackage(p, fl) when Path.exists_free ids p ->
+          let p' = normalize_package_path env p in
+          begin match Path.find_free_opt ids p' with
+          | Some id -> raise (Nondep_cannot_erase id)
+          | None ->
+            let nondep_field_rec (n, ty) = (n, nondep_type_rec env ids ty) in
+            Tpackage (p', List.map nondep_field_rec fl)
+          end
+      | Tobject (t1, name) ->
+          Tobject (nondep_type_rec env ids t1,
+                 ref (match !name with
+                        None -> None
+                      | Some (p, tl) ->
+                          if Path.exists_free ids p then None
+                          else Some (p, List.map (nondep_type_rec env ids) tl)))
+      | Tvariant row ->
+          let row = row_repr row in
+          let more = repr row.row_more in
+          (* We must keep sharing according to the row variable *)
+          begin try
+            let ty2 = TypeHash.find nondep_variants more in
+            (* This variant type has been already copied *)
+            TypeHash.add nondep_hash ty ty2;
+            Tlink ty2
+          with Not_found ->
+            (* Register new type first for recursion *)
+            TypeHash.add nondep_variants more ty';
+            let static = static_row row in
+            let more' =
+              if static then newgenty Tnil else nondep_type_rec env ids more
+            in
+            (* Return a new copy *)
+            let row =
+              copy_row (nondep_type_rec env ids) true row true more' in
+            match row.row_name with
+              Some (p, _tl) when Path.exists_free ids p ->
+                Tvariant {row with row_name = None}
+            | _ -> Tvariant row
+          end
+      | _ -> copy_type_desc (nondep_type_rec env ids) ty.desc
+      end;
+    ty'
+
+let nondep_type env id ty =
+  try
+    let ty' = nondep_type_rec env id ty in
+    clear_hash ();
+    ty'
+  with Nondep_cannot_erase _ as exn ->
+    clear_hash ();
+    raise exn
+
+let () = nondep_type' := nondep_type
+
+(* Preserve sharing inside type declarations. *)
+let nondep_type_decl env mid is_covariant decl =
+  try
+    let params = List.map (nondep_type_rec env mid) decl.type_params in
+    let tk =
+      try map_kind (nondep_type_rec env mid) decl.type_kind
+      with Nondep_cannot_erase _ when is_covariant -> Type_abstract
+    and tm, priv =
+      match decl.type_manifest with
+      | None -> None, decl.type_private
+      | Some ty ->
+          try Some (nondep_type_rec env mid ty), decl.type_private
+          with Nondep_cannot_erase _ when is_covariant ->
+            clear_hash ();
+            try Some (nondep_type_rec ~expand_private:true env mid ty),
+                Private
+            with Nondep_cannot_erase _ ->
+              None, decl.type_private
+    in
+    clear_hash ();
+    let priv =
+      match tm with
+      | Some ty when Btype.has_constr_row ty -> Private
+      | _ -> priv
+    in
+    { type_params = params;
+      type_arity = decl.type_arity;
+      type_kind = tk;
+      type_manifest = tm;
+      type_private = priv;
+      type_variance = decl.type_variance;
+      type_separability = decl.type_separability;
+      type_is_newtype = false;
+      type_expansion_scope = Btype.lowest_level;
+      type_loc = decl.type_loc;
+      type_attributes = decl.type_attributes;
+      type_immediate = decl.type_immediate;
+      type_unboxed_default = decl.type_unboxed_default;
+      type_uid = decl.type_uid;
+    }
+  with Nondep_cannot_erase _ as exn ->
+    clear_hash ();
+    raise exn
+
+(* Preserve sharing inside extension constructors. *)
+let nondep_extension_constructor env ids ext =
+  try
+    let type_path, type_params =
+      match Path.find_free_opt ids ext.ext_type_path with
+      | Some id ->
+        begin
+          let ty =
+            newgenty (Tconstr(ext.ext_type_path, ext.ext_type_params, ref Mnil))
+          in
+          let ty' = nondep_type_rec env ids ty in
+            match (repr ty').desc with
+                Tconstr(p, tl, _) -> p, tl
+              | _ -> raise (Nondep_cannot_erase id)
+        end
+      | None ->
+        let type_params =
+          List.map (nondep_type_rec env ids) ext.ext_type_params
+        in
+          ext.ext_type_path, type_params
+    in
+    let args = map_type_expr_cstr_args (nondep_type_rec env ids) ext.ext_args in
+    let ret_type = Option.map (nondep_type_rec env ids) ext.ext_ret_type in
+      clear_hash ();
+      { ext_type_path = type_path;
+        ext_type_params = type_params;
+        ext_args = args;
+        ext_ret_type = ret_type;
+        ext_private = ext.ext_private;
+        ext_attributes = ext.ext_attributes;
+        ext_loc = ext.ext_loc;
+        ext_uid = ext.ext_uid;
+      }
+  with Nondep_cannot_erase _ as exn ->
+    clear_hash ();
+    raise exn
+
+
+(* Preserve sharing inside class types. *)
+let nondep_class_signature env id sign =
+  { csig_self = nondep_type_rec env id sign.csig_self;
+    csig_vars =
+      Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t))
+        sign.csig_vars;
+    csig_concr = sign.csig_concr;
+    csig_inher =
+      List.map (fun (p,tl) -> (p, List.map (nondep_type_rec env id) tl))
+        sign.csig_inher }
+
+let rec nondep_class_type env ids =
+  function
+    Cty_constr (p, _, cty) when Path.exists_free ids p ->
+      nondep_class_type env ids cty
+  | Cty_constr (p, tyl, cty) ->
+      Cty_constr (p, List.map (nondep_type_rec env ids) tyl,
+                   nondep_class_type env ids cty)
+  | Cty_signature sign ->
+      Cty_signature (nondep_class_signature env ids sign)
+  | Cty_arrow (l, ty, cty) ->
+      Cty_arrow (l, nondep_type_rec env ids ty, nondep_class_type env ids cty)
+
+let nondep_class_declaration env ids decl =
+  assert (not (Path.exists_free ids decl.cty_path));
+  let decl =
+    { cty_params = List.map (nondep_type_rec env ids) decl.cty_params;
+      cty_variance = decl.cty_variance;
+      cty_type = nondep_class_type env ids decl.cty_type;
+      cty_path = decl.cty_path;
+      cty_new =
+        begin match decl.cty_new with
+          None    -> None
+        | Some ty -> Some (nondep_type_rec env ids ty)
+        end;
+      cty_loc = decl.cty_loc;
+      cty_attributes = decl.cty_attributes;
+      cty_uid = decl.cty_uid;
+    }
+  in
+  clear_hash ();
+  decl
+
+let nondep_cltype_declaration env ids decl =
+  assert (not (Path.exists_free ids decl.clty_path));
+  let decl =
+    { clty_params = List.map (nondep_type_rec env ids) decl.clty_params;
+      clty_variance = decl.clty_variance;
+      clty_type = nondep_class_type env ids decl.clty_type;
+      clty_path = decl.clty_path;
+      clty_loc = decl.clty_loc;
+      clty_attributes = decl.clty_attributes;
+      clty_uid = decl.clty_uid;
+    }
+  in
+  clear_hash ();
+  decl
+
+(* collapse conjunctive types in class parameters *)
+let rec collapse_conj env visited ty =
+  let ty = repr ty in
+  if List.memq ty visited then () else
+  let visited = ty :: visited in
+  match ty.desc with
+    Tvariant row ->
+      let row = row_repr row in
+      List.iter
+        (fun (_l,fi) ->
+          match row_field_repr fi with
+            Reither (c, t1::(_::_ as tl), m, e) ->
+              List.iter (unify env t1) tl;
+              set_row_field e (Reither (c, [t1], m, ref None))
+          | _ ->
+              ())
+        row.row_fields;
+      iter_row (collapse_conj env visited) row
+  | _ ->
+      iter_type_expr (collapse_conj env visited) ty
+
+let collapse_conj_params env params =
+  List.iter (collapse_conj env []) params
+
+let same_constr env t1 t2 =
+  let t1 = expand_head env t1 in
+  let t2 = expand_head env t2 in
+  match t1.desc, t2.desc with
+  | Tconstr (p1, _, _), Tconstr (p2, _, _) -> Path.same p1 p2
+  | _ -> false
+
+let () =
+  Env.same_constr := same_constr
+
+let is_immediate = function
+  | Type_immediacy.Unknown -> false
+  | Type_immediacy.Always -> true
+  | Type_immediacy.Always_on_64bits ->
+      (* In bytecode, we don't know at compile time whether we are
+         targeting 32 or 64 bits. *)
+      !Clflags.native_code && Sys.word_size = 64
+
+let immediacy env typ =
+   match (repr typ).desc with
+  | Tconstr(p, _args, _abbrev) ->
+    begin try
+      let type_decl = Env.find_type p env in
+      type_decl.type_immediate
+    with Not_found -> Type_immediacy.Unknown
+    (* This can happen due to e.g. missing -I options,
+       causing some .cmi files to be unavailable.
+       Maybe we should emit a warning. *)
+    end
+  | Tvariant row ->
+      let row = Btype.row_repr row in
+      (* if all labels are devoid of arguments, not a pointer *)
+      if
+        not row.row_closed
+        || List.exists
+          (function
+            | _, (Rpresent (Some _) | Reither (false, _, _, _)) -> true
+            | _ -> false)
+          row.row_fields
+      then
+        Type_immediacy.Unknown
+      else
+        Type_immediacy.Always
+  | _ -> Type_immediacy.Unknown
+
+let maybe_pointer_type env typ = not (is_immediate (immediacy env typ))
diff --git a/src/ocaml/typing/ctype.mli b/src/ocaml/typing/ctype.mli
new file mode 100644
index 0000000..7185cdb
--- /dev/null
+++ b/src/ocaml/typing/ctype.mli
@@ -0,0 +1,354 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Operations on core types *)
+
+open Asttypes
+open Types
+
+module TypePairs : Hashtbl.S with type key = type_expr * type_expr
+
+exception Unify of Errortrace.unification Errortrace.t
+exception Equality of Errortrace.comparison Errortrace.t
+exception Moregen of Errortrace.comparison Errortrace.t
+exception Subtype of Errortrace.Subtype.t * Errortrace.unification Errortrace.t
+exception Escape of Errortrace.desc Errortrace.escape
+
+exception Tags of label * label
+exception Cannot_expand
+exception Cannot_apply
+exception Matches_failure of Env.t * Errortrace.unification Errortrace.t
+  (* Raised from [matches], hence the odd name *)
+exception Incompatible
+  (* Raised from [mcomp] *)
+
+val init_def: int -> unit
+        (* Set the initial variable level *)
+val begin_def: unit -> unit
+        (* Raise the variable level by one at the beginning of a definition. *)
+val end_def: unit -> unit
+        (* Lower the variable level by one at the end of a definition *)
+val begin_class_def: unit -> unit
+val raise_nongen_level: unit -> unit
+val reset_global_level: unit -> unit
+        (* Reset the global level before typing an expression *)
+val increase_global_level: unit -> int
+val restore_global_level: int -> unit
+        (* This pair of functions is only used in Typetexp *)
+type levels =
+    { current_level: int; nongen_level: int; global_level: int;
+      saved_level: (int * int) list; }
+val save_levels: unit -> levels
+val set_levels: levels -> unit
+
+val create_scope : unit -> int
+
+val newty: type_desc -> type_expr
+val newvar: ?name:string -> unit -> type_expr
+val newvar2: ?name:string -> int -> type_expr
+        (* Return a fresh variable *)
+val new_global_var: ?name:string -> unit -> type_expr
+        (* Return a fresh variable, bound at toplevel
+           (as type variables ['a] in type constraints). *)
+val newobj: type_expr -> type_expr
+val newconstr: Path.t -> type_expr list -> type_expr
+val none: type_expr
+        (* A dummy type expression *)
+
+val repr: type_expr -> type_expr
+        (* Return the canonical representative of a type. *)
+
+val object_fields: type_expr -> type_expr
+val flatten_fields:
+        type_expr -> (string * field_kind * type_expr) list * type_expr
+(** Transform a field type into a list of pairs label-type.
+    The fields are sorted.
+
+    Beware of the interaction with GADTs:
+
+    Due to the introduction of object indexes for GADTs, the row variable of
+    an object may now be an expansible type abbreviation.
+    A first consequence is that [flatten_fields] will not completely flatten
+    the object, since the type abbreviation will not be expanded
+    ([flatten_fields] does not receive the current environment).
+    Another consequence is that various functions may be called with the
+    expansion of this type abbreviation, which is a Tfield, e.g. during
+    printing.
+
+    Concrete problems have been fixed, but new bugs may appear in the
+    future. (Test cases were added to typing-gadts/test.ml)
+*)
+
+val associate_fields:
+        (string * field_kind * type_expr) list ->
+        (string * field_kind * type_expr) list ->
+        (string * field_kind * type_expr * field_kind * type_expr) list *
+        (string * field_kind * type_expr) list *
+        (string * field_kind * type_expr) list
+val opened_object: type_expr -> bool
+val close_object: type_expr -> bool
+val row_variable: type_expr -> type_expr
+        (* Return the row variable of an open object type *)
+val set_object_name:
+        Ident.t -> type_expr -> type_expr list -> type_expr -> unit
+val remove_object_name: type_expr -> unit
+val hide_private_methods: type_expr -> unit
+val find_cltype_for_path: Env.t -> Path.t -> type_declaration * type_expr
+
+val sort_row_fields: (label * row_field) list -> (label * row_field) list
+val merge_row_fields:
+        (label * row_field) list -> (label * row_field) list ->
+        (label * row_field) list * (label * row_field) list *
+        (label * row_field * row_field) list
+val filter_row_fields:
+        bool -> (label * row_field) list -> (label * row_field) list
+
+val generalize: type_expr -> unit
+        (* Generalize in-place the given type *)
+val lower_contravariant: Env.t -> type_expr -> unit
+        (* Lower level of type variables inside contravariant branches;
+           to be used before generalize for expansive expressions *)
+val generalize_structure: type_expr -> unit
+        (* Generalize the structure of a type, lowering variables
+           to !current_level *)
+val generalize_spine: type_expr -> unit
+        (* Special function to generalize a method during inference *)
+val correct_levels: type_expr -> type_expr
+        (* Returns a copy with decreasing levels *)
+val limited_generalize: type_expr -> type_expr -> unit
+        (* Only generalize some part of the type
+           Make the remaining of the type non-generalizable *)
+
+val fully_generic: type_expr -> bool
+
+val check_scope_escape : Env.t -> int -> type_expr -> unit
+        (* [check_scope_escape env lvl ty] ensures that [ty] could be raised
+           to the level [lvl] without any scope escape.
+           Raises [Escape] otherwise *)
+
+val instance: ?partial:bool -> type_expr -> type_expr
+        (* Take an instance of a type scheme *)
+        (* partial=None  -> normal
+           partial=false -> newvar() for non generic subterms
+           partial=true  -> newty2 ty.level Tvar for non generic subterms *)
+val generic_instance: type_expr -> type_expr
+        (* Same as instance, but new nodes at generic_level *)
+val instance_list: type_expr list -> type_expr list
+        (* Take an instance of a list of type schemes *)
+val new_local_type:
+        ?loc:Location.t ->
+        ?manifest_and_scope:(type_expr * int) -> unit -> type_declaration
+val existential_name: constructor_description -> type_expr -> string
+val instance_constructor:
+        ?in_pattern:Env.t ref * int ->
+        constructor_description -> type_expr list * type_expr * type_expr list
+        (* Same, for a constructor. Also returns existentials. *)
+val instance_parameterized_type:
+        ?keep_names:bool ->
+        type_expr list -> type_expr -> type_expr list * type_expr
+val instance_parameterized_type_2:
+        type_expr list -> type_expr list -> type_expr ->
+        type_expr list * type_expr list * type_expr
+val instance_declaration: type_declaration -> type_declaration
+val generic_instance_declaration: type_declaration -> type_declaration
+        (* Same as instance_declaration, but new nodes at generic_level *)
+val instance_class:
+        type_expr list -> class_type -> type_expr list * class_type
+val instance_poly:
+        ?keep_names:bool ->
+        bool -> type_expr list -> type_expr -> type_expr list * type_expr
+        (* Take an instance of a type scheme containing free univars *)
+val polyfy: Env.t -> type_expr -> type_expr list -> type_expr * bool
+val instance_label:
+        bool -> label_description -> type_expr list * type_expr * type_expr
+        (* Same, for a label *)
+val apply:
+        Env.t -> type_expr list -> type_expr -> type_expr list -> type_expr
+        (* [apply [p1...pN] t [a1...aN]] match the arguments [ai] to
+        the parameters [pi] and returns the corresponding instance of
+        [t]. Exception [Cannot_apply] is raised in case of failure. *)
+
+val try_expand_once_opt: Env.t -> type_expr -> type_expr
+val try_expand_safe_opt: Env.t -> type_expr -> type_expr
+
+val expand_head_once: Env.t -> type_expr -> type_expr
+val expand_head: Env.t -> type_expr -> type_expr
+val expand_head_opt: Env.t -> type_expr -> type_expr
+(** The compiler's own version of [expand_head] necessary for type-based
+    optimisations. *)
+
+val full_expand: may_forget_scope:bool -> Env.t -> type_expr -> type_expr
+val extract_concrete_typedecl:
+        Env.t -> type_expr -> Path.t * Path.t * type_declaration
+        (* Return the original path of the types, and the first concrete
+           type declaration found expanding it.
+           Raise [Not_found] if none appears or not a type constructor. *)
+
+val unify: Env.t -> type_expr -> type_expr -> unit
+        (* Unify the two types given. Raise [Unify] if not possible. *)
+val unify_gadt:
+        equations_level:int -> allow_recursive:bool ->
+        Env.t ref -> type_expr -> type_expr -> unit TypePairs.t
+        (* Unify the two types given and update the environment with the
+           local constraints. Raise [Unify] if not possible.
+           Returns the pairs of types that have been equated.  *)
+val unify_var: Env.t -> type_expr -> type_expr -> unit
+        (* Same as [unify], but allow free univars when first type
+           is a variable. *)
+val filter_arrow: Env.t -> type_expr -> arg_label -> type_expr * type_expr
+        (* A special case of unification (with l:'a -> 'b). *)
+val filter_method: Env.t -> string -> private_flag -> type_expr -> type_expr
+        (* A special case of unification (with {m : 'a; 'b}). *)
+val check_filter_method: Env.t -> string -> private_flag -> type_expr -> unit
+        (* A special case of unification (with {m : 'a; 'b}), returning unit. *)
+val occur_in: Env.t -> type_expr -> type_expr -> bool
+val deep_occur: type_expr -> type_expr -> bool
+val filter_self_method:
+        Env.t -> string -> private_flag -> (Ident.t * type_expr) Meths.t ref ->
+        type_expr -> Ident.t * type_expr
+val moregeneral: Env.t -> bool -> type_expr -> type_expr -> unit
+        (* Check if the first type scheme is more general than the second. *)
+val is_moregeneral: Env.t -> bool -> type_expr -> type_expr -> bool
+val rigidify: type_expr -> type_expr list
+        (* "Rigidify" a type and return its type variable *)
+val all_distinct_vars: Env.t -> type_expr list -> bool
+        (* Check those types are all distinct type variables *)
+val matches: Env.t -> type_expr -> type_expr -> unit
+        (* Same as [moregeneral false], implemented using the two above
+           functions and backtracking. Ignore levels *)
+val does_match: Env.t -> type_expr -> type_expr -> bool
+        (* Same as [matches], but returns a [bool] *)
+
+val reify_univars : Env.t -> Types.type_expr -> Types.type_expr
+        (* Replaces all the variables of a type by a univar. *)
+
+type class_match_failure_trace_type =
+  | CM_Equality
+  | CM_Moregen
+
+type class_match_failure =
+    CM_Virtual_class
+  | CM_Parameter_arity_mismatch of int * int
+  | CM_Type_parameter_mismatch of Env.t * Errortrace.comparison Errortrace.t
+  | CM_Class_type_mismatch of Env.t * class_type * class_type
+  | CM_Parameter_mismatch of Env.t * Errortrace.comparison Errortrace.t
+  | CM_Val_type_mismatch of
+      class_match_failure_trace_type *
+      string * Env.t * Errortrace.comparison Errortrace.t
+  | CM_Meth_type_mismatch of
+      class_match_failure_trace_type *
+      string * Env.t * Errortrace.comparison Errortrace.t
+  | CM_Non_mutable_value of string
+  | CM_Non_concrete_value of string
+  | CM_Missing_value of string
+  | CM_Missing_method of string
+  | CM_Hide_public of string
+  | CM_Hide_virtual of string * string
+  | CM_Public_method of string
+  | CM_Private_method of string
+  | CM_Virtual_method of string
+val match_class_types:
+    ?trace:bool -> Env.t -> class_type -> class_type -> class_match_failure list
+        (* Check if the first class type is more general than the second. *)
+val equal: Env.t -> bool -> type_expr list -> type_expr list -> unit
+        (* [equal env [x1...xn] tau [y1...yn] sigma]
+           checks whether the parameterized types
+           [/\x1.../\xn.tau] and [/\y1.../\yn.sigma] are equivalent. *)
+val is_equal : Env.t -> bool -> type_expr list -> type_expr list -> bool
+val equal_private :
+        Env.t -> type_expr list -> type_expr ->
+        type_expr list -> type_expr -> unit
+(* [equal_private env t1 params1 t2 params2] checks that [t1::params1]
+   equals [t2::params2] but it is allowed to expand [t1] if it is a
+   private abbreviations. *)
+
+val match_class_declarations:
+        Env.t -> type_expr list -> class_type -> type_expr list ->
+        class_type -> class_match_failure list
+        (* Check if the first class type is more general than the second. *)
+
+val enlarge_type: Env.t -> type_expr -> type_expr * bool
+        (* Make a type larger, flag is true if some pruning had to be done *)
+val subtype: Env.t -> type_expr -> type_expr -> unit -> unit
+        (* [subtype env t1 t2] checks that [t1] is a subtype of [t2].
+           It accumulates the constraints the type variables must
+           enforce and returns a function that enforces this
+           constraints. *)
+
+exception Nondep_cannot_erase of Ident.t
+
+val nondep_type: Env.t -> Ident.t list -> type_expr -> type_expr
+        (* Return a type equivalent to the given type but without
+           references to any of the given identifiers.
+           Raise [Nondep_cannot_erase id] if no such type exists because [id],
+           in particular, could not be erased. *)
+val nondep_type_decl:
+        Env.t -> Ident.t list -> bool -> type_declaration -> type_declaration
+        (* Same for type declarations. *)
+val nondep_extension_constructor:
+        Env.t -> Ident.t list -> extension_constructor ->
+        extension_constructor
+          (* Same for extension constructor *)
+val nondep_class_declaration:
+        Env.t -> Ident.t list -> class_declaration -> class_declaration
+        (* Same for class declarations. *)
+val nondep_cltype_declaration:
+  Env.t -> Ident.t list -> class_type_declaration -> class_type_declaration
+        (* Same for class type declarations. *)
+(*val correct_abbrev: Env.t -> Path.t -> type_expr list -> type_expr -> unit*)
+val is_contractive: Env.t -> Path.t -> bool
+val normalize_type: type_expr -> unit
+
+val closed_schema: Env.t -> type_expr -> bool
+        (* Check whether the given type scheme contains no non-generic
+           type variables *)
+
+val free_variables: ?env:Env.t -> type_expr -> type_expr list
+        (* If env present, then check for incomplete definitions too *)
+val closed_type_decl: type_declaration -> type_expr option
+val closed_extension_constructor: extension_constructor -> type_expr option
+type closed_class_failure =
+    CC_Method of type_expr * bool * string * type_expr
+  | CC_Value of type_expr * bool * string * type_expr
+val closed_class:
+        type_expr list -> class_signature -> closed_class_failure option
+        (* Check whether all type variables are bound *)
+
+val unalias: type_expr -> type_expr
+val signature_of_class_type: class_type -> class_signature
+val self_type: class_type -> type_expr
+val class_type_arity: class_type -> int
+val arity: type_expr -> int
+        (* Return the arity (as for curried functions) of the given type. *)
+
+val collapse_conj_params: Env.t -> type_expr list -> unit
+        (* Collapse conjunctive types in class parameters *)
+
+val get_current_level: unit -> int
+val wrap_trace_gadt_instances: Env.t -> ('a -> 'b) -> 'a -> 'b
+val reset_reified_var_counter: unit -> unit
+
+val immediacy : Env.t -> type_expr -> Type_immediacy.t
+
+val maybe_pointer_type : Env.t -> type_expr -> bool
+       (* True if type is possibly pointer, false if definitely not a pointer *)
+
+(* Stubs *)
+val package_subtype :
+    (Env.t -> Path.t -> (Longident.t * type_expr) list ->
+      Path.t -> (Longident.t * type_expr) list -> bool) ref
+
+(* Raises [Incompatible] *)
+val mcomp : Env.t -> type_expr -> type_expr -> unit
diff --git a/src/ocaml/typing/datarepr.ml b/src/ocaml/typing/datarepr.ml
new file mode 100644
index 0000000..8ec47a9
--- /dev/null
+++ b/src/ocaml/typing/datarepr.ml
@@ -0,0 +1,242 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Compute constructor and label descriptions from type declarations,
+   determining their representation. *)
+
+open Asttypes
+open Types
+open Btype
+
+(* Simplified version of Ctype.free_vars *)
+let free_vars ?(param=false) ty =
+  let ret = ref TypeSet.empty in
+  let rec loop ty =
+    let ty = repr ty in
+    if try_mark_node ty then
+      match ty.desc with
+      | Tvar _ ->
+          ret := TypeSet.add ty !ret
+      | Tvariant row ->
+          let row = row_repr row in
+          iter_row loop row;
+          if not (static_row row) then begin
+            match row.row_more.desc with
+            | Tvar _ when param -> ret := TypeSet.add ty !ret
+            | _ -> loop row.row_more
+          end
+      (* XXX: What about Tobject ? *)
+      | _ ->
+          iter_type_expr loop ty
+  in
+  loop ty;
+  unmark_type ty;
+  !ret
+
+let newgenconstr path tyl = newgenty (Tconstr (path, tyl, ref Mnil))
+
+let constructor_existentials cd_args cd_res =
+  let tyl =
+    match cd_args with
+    | Cstr_tuple l -> l
+    | Cstr_record l -> List.map (fun l -> l.ld_type) l
+  in
+  let existentials =
+    match cd_res with
+    | None -> []
+    | Some type_ret ->
+        let arg_vars_set = free_vars (newgenty (Ttuple tyl)) in
+        let res_vars = free_vars type_ret in
+        TypeSet.elements (TypeSet.diff arg_vars_set res_vars)
+  in
+  (tyl, existentials)
+
+let constructor_args ~current_unit priv cd_args cd_res path rep =
+  let tyl, existentials = constructor_existentials cd_args cd_res in
+  match cd_args with
+  | Cstr_tuple l -> existentials, l, None
+  | Cstr_record lbls ->
+      let arg_vars_set = free_vars ~param:true (newgenty (Ttuple tyl)) in
+      let type_params = TypeSet.elements arg_vars_set in
+      let arity = List.length type_params in
+      let tdecl =
+        {
+          type_params;
+          type_arity = arity;
+          type_kind = Type_record (lbls, rep);
+          type_private = priv;
+          type_manifest = None;
+          type_variance = Variance.unknown_signature ~injective:true ~arity;
+          type_separability = Types.Separability.default_signature ~arity;
+          type_is_newtype = false;
+          type_expansion_scope = Btype.lowest_level;
+          type_loc = Location.none;
+          type_attributes = [];
+          type_immediate = Unknown;
+          type_unboxed_default = false;
+          type_uid = Uid.mk ~current_unit;
+        }
+      in
+      existentials,
+      [ newgenconstr path type_params ],
+      Some tdecl
+
+let constructor_descrs ~current_unit ty_path decl cstrs rep =
+  let ty_res = newgenconstr ty_path decl.type_params in
+  let num_consts = ref 0 and num_nonconsts = ref 0  and num_normal = ref 0 in
+  List.iter
+    (fun {cd_args; cd_res; _} ->
+      if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts;
+      if cd_res = None then incr num_normal)
+    cstrs;
+  let rec describe_constructors idx_const idx_nonconst = function
+      [] -> []
+    | {cd_id; cd_args; cd_res; cd_loc; cd_attributes; cd_uid} :: rem ->
+        let ty_res =
+          match cd_res with
+          | Some ty_res' -> ty_res'
+          | None -> ty_res
+        in
+        let (tag, descr_rem) =
+          match cd_args, rep with
+          | _, Variant_unboxed ->
+            assert (rem = []);
+            (Cstr_unboxed, [])
+          | Cstr_tuple [], Variant_regular ->
+             (Cstr_constant idx_const,
+              describe_constructors (idx_const+1) idx_nonconst rem)
+          | _, Variant_regular  ->
+             (Cstr_block idx_nonconst,
+              describe_constructors idx_const (idx_nonconst+1) rem) in
+        let cstr_name = Ident.name cd_id in
+        let existentials, cstr_args, cstr_inlined =
+          let representation =
+            match rep with
+            | Variant_unboxed -> Record_unboxed true
+            | Variant_regular -> Record_inlined idx_nonconst
+          in
+          constructor_args ~current_unit decl.type_private cd_args cd_res
+            (Path.Pdot (ty_path, cstr_name)) representation
+        in
+        let cstr =
+          { cstr_name;
+            cstr_res = ty_res;
+            cstr_existentials = existentials;
+            cstr_args;
+            cstr_arity = List.length cstr_args;
+            cstr_tag = tag;
+            cstr_consts = !num_consts;
+            cstr_nonconsts = !num_nonconsts;
+            cstr_normal = !num_normal;
+            cstr_private = decl.type_private;
+            cstr_generalized = cd_res <> None;
+            cstr_loc = cd_loc;
+            cstr_attributes = cd_attributes;
+            cstr_inlined;
+            cstr_uid = cd_uid;
+          } in
+        (cd_id, cstr) :: descr_rem in
+  describe_constructors 0 0 cstrs
+
+let extension_descr ~current_unit path_ext ext =
+  let ty_res =
+    match ext.ext_ret_type with
+        Some type_ret -> type_ret
+      | None -> newgenconstr ext.ext_type_path ext.ext_type_params
+  in
+  let existentials, cstr_args, cstr_inlined =
+    constructor_args ~current_unit ext.ext_private ext.ext_args ext.ext_ret_type
+      path_ext (Record_extension path_ext)
+  in
+    { cstr_name = Path.last path_ext;
+      cstr_res = ty_res;
+      cstr_existentials = existentials;
+      cstr_args;
+      cstr_arity = List.length cstr_args;
+      cstr_tag = Cstr_extension(path_ext, cstr_args = []);
+      cstr_consts = -1;
+      cstr_nonconsts = -1;
+      cstr_private = ext.ext_private;
+      cstr_normal = -1;
+      cstr_generalized = ext.ext_ret_type <> None;
+      cstr_loc = ext.ext_loc;
+      cstr_attributes = ext.ext_attributes;
+      cstr_inlined;
+      cstr_uid = ext.ext_uid;
+    }
+
+let none = Private_type_expr.create (Ttuple [])
+    ~level:(-1) ~scope:Btype.generic_level ~id:(-1)
+                                        (* Clearly ill-formed type *)
+let dummy_label =
+  { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable;
+    lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular;
+    lbl_private = Public;
+    lbl_loc = Location.none;
+    lbl_attributes = [];
+    lbl_uid = Uid.internal_not_actually_unique;
+  }
+
+let label_descrs ty_res lbls repres priv =
+  let all_labels = Array.make (List.length lbls) dummy_label in
+  let rec describe_labels num = function
+      [] -> []
+    | l :: rest ->
+        let lbl =
+          { lbl_name = Ident.name l.ld_id;
+            lbl_res = ty_res;
+            lbl_arg = l.ld_type;
+            lbl_mut = l.ld_mutable;
+            lbl_pos = num;
+            lbl_all = all_labels;
+            lbl_repres = repres;
+            lbl_private = priv;
+            lbl_loc = l.ld_loc;
+            lbl_attributes = l.ld_attributes;
+            lbl_uid = l.ld_uid;
+          } in
+        all_labels.(num) <- lbl;
+        (l.ld_id, lbl) :: describe_labels (num+1) rest in
+  describe_labels 0 lbls
+
+exception Constr_not_found
+
+let rec find_constr tag num_const num_nonconst = function
+    [] ->
+      raise Constr_not_found
+  | {cd_args = Cstr_tuple []; _} as c  :: rem ->
+      if tag = Cstr_constant num_const
+      then c
+      else find_constr tag (num_const + 1) num_nonconst rem
+  | c :: rem ->
+      if tag = Cstr_block num_nonconst || tag = Cstr_unboxed
+      then c
+      else find_constr tag num_const (num_nonconst + 1) rem
+
+let find_constr_by_tag tag cstrlist =
+  find_constr tag 0 0 cstrlist
+
+let constructors_of_type ~current_unit ty_path decl =
+  match decl.type_kind with
+  | Type_variant (cstrs,rep) ->
+     constructor_descrs ~current_unit ty_path decl cstrs rep
+  | Type_record _ | Type_abstract | Type_open -> []
+
+let labels_of_type ty_path decl =
+  match decl.type_kind with
+  | Type_record(labels, rep) ->
+      label_descrs (newgenconstr ty_path decl.type_params)
+        labels rep decl.type_private
+  | Type_variant _ | Type_abstract | Type_open -> []
diff --git a/src/ocaml/typing/datarepr.mli b/src/ocaml/typing/datarepr.mli
new file mode 100644
index 0000000..38f05f7
--- /dev/null
+++ b/src/ocaml/typing/datarepr.mli
@@ -0,0 +1,45 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Compute constructor and label descriptions from type declarations,
+   determining their representation. *)
+
+open Types
+
+val extension_descr:
+  current_unit:string -> Path.t -> extension_constructor ->
+  constructor_description
+
+val labels_of_type:
+  Path.t -> type_declaration ->
+  (Ident.t * label_description) list
+val constructors_of_type:
+  current_unit:string -> Path.t -> type_declaration ->
+  (Ident.t * constructor_description) list
+
+
+exception Constr_not_found
+
+val find_constr_by_tag:
+  constructor_tag -> constructor_declaration list ->
+    constructor_declaration
+
+val constructor_existentials :
+    constructor_arguments -> type_expr option -> type_expr list * type_expr list
+(** Takes [cd_args] and [cd_res] from a [constructor_declaration] and
+    returns:
+    - the types of the constructor's arguments
+    - the existential variables introduced by the constructor
+ *)
diff --git a/src/ocaml/typing/dune b/src/ocaml/typing/dune
new file mode 100644
index 0000000..3445ed5
--- /dev/null
+++ b/src/ocaml/typing/dune
@@ -0,0 +1,9 @@
+(library
+  (name ocaml_typing)
+  (flags
+   -open Ocaml_utils
+   -open Ocaml_parsing
+   -open Merlin_utils
+   (:standard -w -9))
+  (modules_without_implementation annot outcometree)
+  (libraries merlin_utils ocaml_parsing ocaml_utils))
diff --git a/src/ocaml/typing/env.ml b/src/ocaml/typing/env.ml
new file mode 100644
index 0000000..7da56f8
--- /dev/null
+++ b/src/ocaml/typing/env.ml
@@ -0,0 +1,3885 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Environment handling *)
+
+open Cmi_format
+open Misc
+open Asttypes
+open Longident
+open Path
+open Types
+open Btype
+
+open Local_store
+
+module String = Misc.String
+
+let add_delayed_check_forward = ref (fun _ -> assert false)
+
+type 'a usage_tbl = ('a -> unit) Types.Uid.Tbl.t
+(** This table is used to track usage of value declarations.
+    A declaration is identified by its uid.
+    The callback attached to a declaration is called whenever the value (or
+    type, or ...) is used explicitly (lookup_value, ...) or implicitly
+    (inclusion test between signatures, cf Includemod.value_descriptions, ...).
+*)
+
+let value_declarations  : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16
+let type_declarations   : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16
+let module_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16
+
+type constructor_usage = Positive | Pattern | Exported_private | Exported
+type constructor_usages =
+  {
+    mutable cu_positive: bool;
+    mutable cu_pattern: bool;
+    mutable cu_exported_private: bool;
+  }
+let add_constructor_usage cu usage =
+  match usage with
+  | Positive -> cu.cu_positive <- true
+  | Pattern -> cu.cu_pattern <- true
+  | Exported_private -> cu.cu_exported_private <- true
+  | Exported ->
+    cu.cu_positive <- true;
+    cu.cu_pattern <- true;
+    cu.cu_exported_private <- true
+
+let constructor_usages () =
+  {cu_positive = false; cu_pattern = false; cu_exported_private = false}
+
+let constructor_usage_complaint ~rebind priv cu
+  : Warnings.constructor_usage_warning option =
+  match priv, rebind with
+  | Asttypes.Private, _ | _, true ->
+      if cu.cu_positive || cu.cu_pattern || cu.cu_exported_private then None
+      else Some Unused
+  | Asttypes.Public, false -> begin
+      match cu.cu_positive, cu.cu_pattern, cu.cu_exported_private with
+      | true, _, _ -> None
+      | false, false, false -> Some Unused
+      | false, true, _ -> Some Not_constructed
+      | false, false, true -> Some Only_exported_private
+    end
+
+let used_constructors : constructor_usage usage_tbl ref =
+  s_table Types.Uid.Tbl.create 16
+
+type label_usage =
+    Projection | Mutation | Construct | Exported_private | Exported
+type label_usages =
+    {
+     mutable lu_projection: bool;
+     mutable lu_mutation: bool;
+     mutable lu_construct: bool;
+    }
+let add_label_usage lu usage =
+  match usage with
+  | Projection -> lu.lu_projection <- true;
+  | Mutation -> lu.lu_mutation <- true
+  | Construct -> lu.lu_construct <- true
+  | Exported_private ->
+    lu.lu_projection <- true
+  | Exported ->
+    lu.lu_projection <- true;
+    lu.lu_mutation <- true;
+    lu.lu_construct <- true
+
+let label_usages () =
+  {lu_projection = false; lu_mutation = false; lu_construct = false}
+
+let label_usage_complaint priv mut lu
+  : Warnings.field_usage_warning option =
+  match priv, mut with
+  | Asttypes.Private, _ ->
+      if lu.lu_projection then None
+      else Some Unused
+  | Asttypes.Public, Asttypes.Immutable -> begin
+      match lu.lu_projection, lu.lu_construct with
+      | true, _ -> None
+      | false, false -> Some Unused
+      | false, true -> Some Not_read
+    end
+  | Asttypes.Public, Asttypes.Mutable -> begin
+      match lu.lu_projection, lu.lu_mutation, lu.lu_construct with
+      | true, true, _ -> None
+      | false, false, false -> Some Unused
+      | false, _, _ -> Some Not_read
+      | true, false, _ -> Some Not_mutated
+    end
+
+let used_labels : label_usage usage_tbl ref =
+  s_table Types.Uid.Tbl.create 16
+
+(** Map indexed by the name of module components. *)
+module NameMap = String.Map
+
+type value_unbound_reason =
+  | Val_unbound_instance_variable
+  | Val_unbound_self
+  | Val_unbound_ancestor
+  | Val_unbound_ghost_recursive of Location.t
+
+type module_unbound_reason =
+  | Mod_unbound_illegal_recursion
+
+type summary =
+    Env_empty
+  | Env_value of summary * Ident.t * value_description
+  | Env_type of summary * Ident.t * type_declaration
+  | Env_extension of summary * Ident.t * extension_constructor
+  | Env_module of summary * Ident.t * module_presence * module_declaration
+  | Env_modtype of summary * Ident.t * modtype_declaration
+  | Env_class of summary * Ident.t * class_declaration
+  | Env_cltype of summary * Ident.t * class_type_declaration
+  | Env_open of summary * Path.t
+  | Env_functor_arg of summary * Ident.t
+  | Env_constraints of summary * type_declaration Path.Map.t
+  | Env_copy_types of summary
+  | Env_persistent of summary * Ident.t
+  | Env_value_unbound of summary * string * value_unbound_reason
+  | Env_module_unbound of summary * string * module_unbound_reason
+
+let map_summary f = function
+    Env_empty -> Env_empty
+  | Env_value (s, id, d) -> Env_value (f s, id, d)
+  | Env_type (s, id, d) -> Env_type (f s, id, d)
+  | Env_extension (s, id, d) -> Env_extension (f s, id, d)
+  | Env_module (s, id, p, d) -> Env_module (f s, id, p, d)
+  | Env_modtype (s, id, d) -> Env_modtype (f s, id, d)
+  | Env_class (s, id, d) -> Env_class (f s, id, d)
+  | Env_cltype (s, id, d) -> Env_cltype (f s, id, d)
+  | Env_open (s, p) -> Env_open (f s, p)
+  | Env_functor_arg (s, id) -> Env_functor_arg (f s, id)
+  | Env_constraints (s, m) -> Env_constraints (f s, m)
+  | Env_copy_types s -> Env_copy_types (f s)
+  | Env_persistent (s, id) -> Env_persistent (f s, id)
+  | Env_value_unbound (s, u, r) -> Env_value_unbound (f s, u, r)
+  | Env_module_unbound (s, u, r) -> Env_module_unbound (f s, u, r)
+
+type address =
+  | Aident of Ident.t
+  | Adot of address * int
+
+module TycompTbl =
+  struct
+    (** This module is used to store components of types (i.e. labels
+        and constructors).  We keep a representation of each nested
+        "open" and the set of local bindings between each of them. *)
+
+    type 'a t = {
+      current: 'a Ident.tbl;
+      (** Local bindings since the last open. *)
+
+      opened: 'a opened option;
+      (** Symbolic representation of the last (innermost) open, if any. *)
+    }
+
+    and 'a opened = {
+      components: ('a list) NameMap.t;
+      (** Components from the opened module. We keep a list of
+          bindings for each name, as in comp_labels and
+          comp_constrs. *)
+
+      root: Path.t;
+      (** Only used to check removal of open *)
+
+      using: (string -> ('a * 'a) option -> unit) option;
+      (** A callback to be applied when a component is used from this
+          "open".  This is used to detect unused "opens".  The
+          arguments are used to detect shadowing. *)
+
+      next: 'a t;
+      (** The table before opening the module. *)
+    }
+
+    let empty = { current = Ident.empty; opened = None }
+
+    let add id x tbl =
+      {tbl with current = Ident.add id x tbl.current}
+
+    let add_open slot wrap root components next =
+      let using =
+        match slot with
+        | None -> None
+        | Some f -> Some (fun s x -> f s (wrap x))
+      in
+      {
+        current = Ident.empty;
+        opened = Some {using; components; root; next};
+      }
+
+    let remove_last_open rt tbl =
+      match tbl.opened with
+      | Some {root; next; _} when Path.same rt root ->
+          { next with current =
+            Ident.fold_all Ident.add tbl.current next.current }
+      | _ ->
+          assert false
+
+    let rec find_same id tbl =
+      try Ident.find_same id tbl.current
+      with Not_found as exn ->
+        begin match tbl.opened with
+        | Some {next; _} -> find_same id next
+        | None -> raise exn
+        end
+
+    let nothing = fun () -> ()
+
+    let mk_callback rest name desc using =
+      match using with
+      | None -> nothing
+      | Some f ->
+          (fun () ->
+             match rest with
+             | [] -> f name None
+             | (hidden, _) :: _ -> f name (Some (desc, hidden)))
+
+    let rec find_all ~mark name tbl =
+      List.map (fun (_id, desc) -> desc, nothing)
+        (Ident.find_all name tbl.current) @
+      match tbl.opened with
+      | None -> []
+      | Some {using; next; components; root = _} ->
+          let rest = find_all ~mark name next in
+          let using = if mark then using else None in
+          match NameMap.find name components with
+          | exception Not_found -> rest
+          | opened ->
+              List.map
+                (fun desc -> desc, mk_callback rest name desc using)
+                opened
+              @ rest
+
+    let rec fold_name f tbl acc =
+      let acc = Ident.fold_name (fun _id d -> f d) tbl.current acc in
+      match tbl.opened with
+      | Some {using = _; next; components; root = _} ->
+          acc
+          |> NameMap.fold
+            (fun _name -> List.fold_right f)
+            components
+          |> fold_name f next
+      | None ->
+          acc
+
+    let rec local_keys tbl acc =
+      let acc = Ident.fold_all (fun k _ accu -> k::accu) tbl.current acc in
+      match tbl.opened with
+      | Some o -> local_keys o.next acc
+      | None -> acc
+
+    let diff_keys is_local tbl1 tbl2 =
+      let keys2 = local_keys tbl2 [] in
+      List.filter
+        (fun id ->
+           is_local (find_same id tbl2) &&
+           try ignore (find_same id tbl1); false
+           with Not_found -> true)
+        keys2
+
+  end
+
+
+module IdTbl =
+  struct
+    (** This module is used to store all kinds of components except
+        (labels and constructors) in environments.  We keep a
+        representation of each nested "open" and the set of local
+        bindings between each of them. *)
+
+
+    type ('a, 'b) t = {
+      current: 'a Ident.tbl;
+      (** Local bindings since the last open *)
+
+      layer: ('a, 'b) layer;
+      (** Symbolic representation of the last (innermost) open, if any. *)
+    }
+
+    and ('a, 'b) layer =
+      | Open of {
+          root: Path.t;
+          (** The path of the opened module, to be prefixed in front of
+              its local names to produce a valid path in the current
+              environment. *)
+
+          components: 'b NameMap.t;
+          (** Components from the opened module. *)
+
+          using: (string -> ('a * 'a) option -> unit) option;
+          (** A callback to be applied when a component is used from this
+              "open".  This is used to detect unused "opens".  The
+              arguments are used to detect shadowing. *)
+
+          next: ('a, 'b) t;
+          (** The table before opening the module. *)
+        }
+
+      | Map of {
+          f: ('a -> 'a);
+          next: ('a, 'b) t;
+        }
+
+      | Nothing
+
+    let empty = { current = Ident.empty; layer = Nothing }
+
+    let add id x tbl =
+      {tbl with current = Ident.add id x tbl.current}
+
+    let remove id tbl =
+      {tbl with current = Ident.remove id tbl.current}
+
+    let add_open slot wrap root components next =
+      let using =
+        match slot with
+        | None -> None
+        | Some f -> Some (fun s x -> f s (wrap x))
+      in
+      {
+        current = Ident.empty;
+        layer = Open {using; root; components; next};
+      }
+
+    let remove_last_open rt tbl =
+      match tbl.layer with
+      | Open {root; next; _} when Path.same rt root ->
+          { next with current =
+            Ident.fold_all Ident.add tbl.current next.current }
+      | _ ->
+          assert false
+
+    let map f next =
+      {
+        current = Ident.empty;
+        layer = Map {f; next}
+      }
+
+    let rec find_same id tbl =
+      try Ident.find_same id tbl.current
+      with Not_found as exn ->
+        begin match tbl.layer with
+        | Open {next; _} -> find_same id next
+        | Map {f; next} -> f (find_same id next)
+        | Nothing -> raise exn
+        end
+
+    let rec find_name wrap ~mark name tbl =
+      try
+        let (id, desc) = Ident.find_name name tbl.current in
+        Pident id, desc
+      with Not_found as exn ->
+        begin match tbl.layer with
+        | Open {using; root; next; components} ->
+            begin try
+              let descr = wrap (NameMap.find name components) in
+              let res = Pdot (root, name), descr in
+              if mark then begin match using with
+              | None -> ()
+              | Some f -> begin
+                  match find_name wrap ~mark:false name next with
+                  | exception Not_found -> f name None
+                  | _, descr' -> f name (Some (descr', descr))
+                end
+              end;
+              res
+            with Not_found ->
+              find_name wrap ~mark name next
+            end
+        | Map {f; next} ->
+            let (p, desc) =  find_name wrap ~mark name next in
+            p, f desc
+        | Nothing ->
+            raise exn
+        end
+
+    let rec find_all wrap name tbl =
+      List.map
+        (fun (id, desc) -> Pident id, desc)
+        (Ident.find_all name tbl.current) @
+      match tbl.layer with
+      | Nothing -> []
+      | Open {root; using = _; next; components} ->
+          begin try
+            let desc = wrap (NameMap.find name components) in
+            (Pdot (root, name), desc) :: find_all wrap name next
+          with Not_found ->
+            find_all wrap name next
+          end
+      | Map {f; next} ->
+          List.map (fun (p, desc) -> (p, f desc))
+            (find_all wrap name next)
+
+    let rec fold_name wrap f tbl acc =
+      let acc =
+        Ident.fold_name
+          (fun id d -> f (Ident.name id) (Pident id, d))
+          tbl.current acc
+      in
+      match tbl.layer with
+      | Open {root; using = _; next; components} ->
+          acc
+          |> NameMap.fold
+            (fun name desc -> f name (Pdot (root, name), wrap desc))
+            components
+          |> fold_name wrap f next
+      | Nothing ->
+          acc
+      | Map {f=g; next} ->
+          acc
+          |> fold_name wrap
+               (fun name (path, desc) -> f name (path, g desc))
+               next
+
+    let rec local_keys tbl acc =
+      let acc = Ident.fold_all (fun k _ accu -> k::accu) tbl.current acc in
+      match tbl.layer with
+      | Open {next; _ } | Map {next; _} -> local_keys next acc
+      | Nothing -> acc
+
+
+    let rec iter wrap f tbl =
+      Ident.iter (fun id desc -> f id (Pident id, desc)) tbl.current;
+      match tbl.layer with
+      | Open {root; using = _; next; components} ->
+          NameMap.iter
+            (fun s x ->
+               let root_scope = Path.scope root in
+              f (Ident.create_scoped ~scope:root_scope s)
+                (Pdot (root, s), wrap x))
+            components;
+          iter wrap f next
+      | Map {f=g; next} ->
+          iter wrap (fun id (path, desc) -> f id (path, g desc)) next
+      | Nothing -> ()
+
+    let diff_keys tbl1 tbl2 =
+      let keys2 = local_keys tbl2 [] in
+      List.filter
+        (fun id ->
+           try ignore (find_same id tbl1); false
+           with Not_found -> true)
+        keys2
+
+
+  end
+
+type type_descr_kind =
+  (label_description, constructor_description) type_kind
+
+type type_descriptions = type_descr_kind
+
+let in_signature_flag = 0x01
+
+type t = {
+  values: (value_entry, value_data) IdTbl.t;
+  constrs: constructor_data TycompTbl.t;
+  labels: label_data TycompTbl.t;
+  types: (type_data, type_data) IdTbl.t;
+  modules: (module_entry, module_data) IdTbl.t;
+  modtypes: (modtype_data, modtype_data) IdTbl.t;
+  classes: (class_data, class_data) IdTbl.t;
+  cltypes: (cltype_data, cltype_data) IdTbl.t;
+  functor_args: unit Ident.tbl;
+  summary: summary;
+  local_constraints: type_declaration Path.Map.t;
+  flags: int;
+  short_paths: Short_paths.t option;
+  short_paths_additions: short_paths_addition list;
+}
+
+and module_declaration_lazy =
+  (Subst.t * Subst.scoping * module_declaration, module_declaration)
+    Lazy_backtrack.t
+
+and module_components =
+  {
+    alerts: alerts;
+    uid: Uid.t;
+    comps:
+      (components_maker,
+       (module_components_repr, module_components_failure) result)
+        Lazy_backtrack.t;
+  }
+
+and components_maker = {
+  cm_env: t;
+  cm_freshening_subst: Subst.t option;
+  cm_prefixing_subst: Subst.t;
+  cm_path: Path.t;
+  cm_addr: address_lazy;
+  cm_mty: Types.module_type;
+}
+
+and module_components_repr =
+    Structure_comps of structure_components
+  | Functor_comps of functor_components
+
+and module_components_failure =
+  | No_components_abstract
+  | No_components_alias of Path.t
+
+and structure_components = {
+  mutable comp_values: value_data NameMap.t;
+  mutable comp_constrs: constructor_data list NameMap.t;
+  mutable comp_labels: label_data list NameMap.t;
+  mutable comp_types: type_data NameMap.t;
+  mutable comp_modules: module_data NameMap.t;
+  mutable comp_modtypes: modtype_data NameMap.t;
+  mutable comp_classes: class_data NameMap.t;
+  mutable comp_cltypes: cltype_data NameMap.t;
+}
+
+and functor_components = {
+  fcomp_arg: functor_parameter;
+  (* Formal parameter and argument signature *)
+  fcomp_res: module_type;               (* Result signature *)
+  fcomp_cache: (Path.t, module_components) Hashtbl.t;  (* For memoization *)
+  fcomp_subst_cache: (Path.t, module_type) Hashtbl.t
+}
+
+and address_unforced =
+  | Projection of { parent : address_lazy; pos : int; }
+  | ModAlias of { env : t; path : Path.t; }
+
+and address_lazy = (address_unforced, address) Lazy_backtrack.t
+
+and value_data =
+  { vda_description : value_description;
+    vda_address : address_lazy }
+
+and value_entry =
+  | Val_bound of value_data
+  | Val_unbound of value_unbound_reason
+
+and constructor_data =
+  { cda_description : constructor_description;
+    cda_address : address_lazy option; }
+
+and label_data = label_description
+
+and type_data =
+  { tda_declaration : type_declaration;
+    tda_descriptions : type_descriptions; }
+
+and module_data =
+  { mda_declaration : module_declaration_lazy;
+    mda_components : module_components;
+    mda_address : address_lazy; }
+
+and module_entry =
+  | Mod_local of module_data
+  | Mod_persistent
+  | Mod_unbound of module_unbound_reason
+
+and modtype_data = modtype_declaration
+
+and class_data =
+  { clda_declaration : class_declaration;
+    clda_address : address_lazy }
+
+and cltype_data = class_type_declaration
+
+and short_paths_addition =
+  | Type of Ident.t * type_declaration
+  | Class_type of Ident.t * class_type_declaration
+  | Module_type of Ident.t * modtype_declaration
+  | Module of Ident.t * module_declaration * module_components
+  | Type_open of Path.t * type_data NameMap.t
+  | Class_type_open of Path.t * class_type_declaration NameMap.t
+  | Module_type_open of Path.t * modtype_declaration NameMap.t
+  | Module_open of Path.t * module_data NameMap.t
+
+let empty_structure =
+  Structure_comps {
+    comp_values = NameMap.empty;
+    comp_constrs = NameMap.empty;
+    comp_labels = NameMap.empty;
+    comp_types = NameMap.empty;
+    comp_modules = NameMap.empty; comp_modtypes = NameMap.empty;
+    comp_classes = NameMap.empty;
+    comp_cltypes = NameMap.empty }
+
+type unbound_value_hint =
+  | No_hint
+  | Missing_rec of Location.t
+
+type lookup_error =
+  | Unbound_value of Longident.t * unbound_value_hint
+  | Unbound_type of Longident.t
+  | Unbound_constructor of Longident.t
+  | Unbound_label of Longident.t
+  | Unbound_module of Longident.t
+  | Unbound_class of Longident.t
+  | Unbound_modtype of Longident.t
+  | Unbound_cltype of Longident.t
+  | Unbound_instance_variable of string
+  | Not_an_instance_variable of string
+  | Masked_instance_variable of Longident.t
+  | Masked_self_variable of Longident.t
+  | Masked_ancestor_variable of Longident.t
+  | Structure_used_as_functor of Longident.t
+  | Abstract_used_as_functor of Longident.t
+  | Functor_used_as_structure of Longident.t
+  | Abstract_used_as_structure of Longident.t
+  | Generative_used_as_applicative of Longident.t
+  | Illegal_reference_to_recursive_module
+  | Cannot_scrape_alias of Longident.t * Path.t
+
+type error =
+  | Missing_module of Location.t * Path.t * Path.t
+  | Illegal_value_name of Location.t * string
+  | Lookup_error of Location.t * t * lookup_error
+
+exception Error of error
+
+let error err = raise (Error err)
+
+let lookup_error loc env err =
+  error (Lookup_error(loc, env, err))
+
+let same_constr = ref (fun _ _ _ -> assert false)
+
+let check_well_formed_module = ref (fun _ -> assert false)
+
+(* Helper to decide whether to report an identifier shadowing
+   by some 'open'. For labels and constructors, we do not report
+   if the two elements are from the same re-exported declaration.
+
+   Later, one could also interpret some attributes on value and
+   type declarations to silence the shadowing warnings. *)
+
+let check_shadowing env = function
+  | `Constructor (Some (cda1, cda2))
+    when not (!same_constr env
+                cda1.cda_description.cstr_res
+                cda2.cda_description.cstr_res) ->
+      Some "constructor"
+  | `Label (Some (l1, l2))
+    when not (!same_constr env l1.lbl_res l2.lbl_res) ->
+      Some "label"
+  | `Value (Some _) -> Some "value"
+  | `Type (Some _) -> Some "type"
+  | `Module (Some _) | `Component (Some _) -> Some "module"
+  | `Module_type (Some _) -> Some "module type"
+  | `Class (Some _) -> Some "class"
+  | `Class_type (Some _) -> Some "class type"
+  | `Constructor _ | `Label _
+  | `Value None | `Type None | `Module None | `Module_type None
+  | `Class None | `Class_type None | `Component None ->
+      None
+
+let subst_modtype_maker (subst, scoping, md) =
+  {md with md_type = Subst.modtype scoping subst md.md_type}
+
+let empty = {
+  values = IdTbl.empty; constrs = TycompTbl.empty;
+  labels = TycompTbl.empty; types = IdTbl.empty;
+  modules = IdTbl.empty; modtypes = IdTbl.empty;
+  classes = IdTbl.empty; cltypes = IdTbl.empty;
+  summary = Env_empty; local_constraints = Path.Map.empty;
+  flags = 0;
+  functor_args = Ident.empty;
+  short_paths = None;
+  short_paths_additions = [];
+ }
+
+let in_signature b env =
+  let flags =
+    if b then env.flags lor in_signature_flag
+    else env.flags land (lnot in_signature_flag)
+  in
+  {env with flags}
+
+let is_in_signature env = env.flags land in_signature_flag <> 0
+
+let has_local_constraints env =
+  not (Path.Map.is_empty env.local_constraints)
+
+let is_ident = function
+    Pident _ -> true
+  | Pdot _ | Papply _ -> false
+
+let is_ext cda =
+  match cda.cda_description with
+  | {cstr_tag = Cstr_extension _} -> true
+  | _ -> false
+
+let is_local_ext cda =
+  match cda.cda_description with
+  | {cstr_tag = Cstr_extension(p, _)} -> is_ident p
+  | _ -> false
+
+let diff env1 env2 =
+  IdTbl.diff_keys env1.values env2.values @
+  TycompTbl.diff_keys is_local_ext env1.constrs env2.constrs @
+  IdTbl.diff_keys env1.modules env2.modules @
+  IdTbl.diff_keys env1.classes env2.classes
+
+(* Functions for use in "wrap" parameters in IdTbl *)
+let wrap_identity x = x
+let wrap_value vda = Val_bound vda
+let wrap_module mda = Mod_local mda
+
+(* Forward declarations *)
+
+let components_of_module_maker' =
+  ref ((fun _ -> assert false) :
+          components_maker ->
+            (module_components_repr, module_components_failure) result)
+
+let components_of_functor_appl' =
+  ref ((fun ~loc:_ ~f_path:_ ~f_comp:_ ~arg:_ _env -> assert false) :
+          loc:Location.t -> f_path:Path.t -> f_comp:functor_components ->
+            arg:Path.t -> t -> module_components)
+let check_functor_application =
+  (* to be filled by Includemod *)
+  ref ((fun ~errors:_ ~loc:_
+         ~lid_whole_app:_  ~f0_path:_ ~args:_
+         ~arg_path:_ ~arg_mty:_ ~param_mty:_
+         _env
+         -> assert false) :
+         errors:bool -> loc:Location.t ->
+       lid_whole_app:Longident.t ->
+       f0_path:Path.t -> args:(Path.t * Types.module_type) list ->
+       arg_path:Path.t -> arg_mty:module_type -> param_mty:module_type ->
+       t -> unit)
+let strengthen =
+  (* to be filled with Mtype.strengthen *)
+  ref ((fun ~aliasable:_ _env _mty _path -> assert false) :
+         aliasable:bool -> t -> module_type -> Path.t -> module_type)
+
+let shorten_module_path =
+  (* to be filled with Printtyp.shorten_module_path *)
+  ref ((fun _ _ -> assert false) :
+         t -> Path.t -> Path.t)
+
+let md md_type =
+  {md_type; md_attributes=[]; md_loc=Location.none
+  ;md_uid = Uid.internal_not_actually_unique}
+
+(* Print addresses *)
+
+let rec print_address ppf = function
+  | Aident id -> Format.fprintf ppf "%s" (Ident.name id)
+  | Adot(a, pos) -> Format.fprintf ppf "%a.[%i]" print_address a pos
+
+(* The name of the compilation unit currently compiled.
+   "" if outside a compilation unit. *)
+module Current_unit_name : sig
+  val get : unit -> modname
+  val set : modname -> unit
+  val is : modname -> bool
+  val is_ident : Ident.t -> bool
+  val is_path : Path.t -> bool
+end = struct
+  let current_unit =
+    ref ""
+  let get () =
+    !current_unit
+  let set name =
+    current_unit := name
+  let is name =
+    !current_unit = name
+  let is_ident id =
+    Ident.persistent id && is (Ident.name id)
+  let is_path = function
+  | Pident id -> is_ident id
+  | Pdot _ | Papply _ -> false
+end
+
+let set_unit_name = Current_unit_name.set
+let get_unit_name = Current_unit_name.get
+
+let find_same_module id tbl =
+  match IdTbl.find_same id tbl with
+  | x -> x
+  | exception Not_found
+    when Ident.persistent id && not (Current_unit_name.is_ident id) ->
+      Mod_persistent
+
+let find_name_module ~mark name tbl =
+  match IdTbl.find_name wrap_module ~mark name tbl with
+  | x -> x
+  | exception Not_found when not (Current_unit_name.is name) ->
+      let path = Pident(Ident.create_persistent name) in
+      path, Mod_persistent
+
+(* Short paths basis *)
+
+let short_paths_module_components_desc' = ref (fun _ -> assert false)
+
+let short_paths_components name pm =
+  let path = Pident (Ident.create_persistent name) in
+  lazy (!short_paths_module_components_desc' empty path pm.mda_components)
+
+let add_persistent_structure id env =
+  if not (Ident.persistent id) then invalid_arg "Env.add_persistent_structure";
+  if Current_unit_name.is_ident id then env
+  else begin
+    let material =
+      (* This addition only observably changes the environment if it shadows a
+         non-persistent module already in the environment.
+         (See PR#9345) *)
+      match
+        IdTbl.find_name wrap_module ~mark:false (Ident.name id) env.modules
+      with
+      | exception Not_found | _, Mod_persistent -> false
+      | _ -> true
+    in
+    let summary =
+      if material then Env_persistent (env.summary, id)
+      else env.summary
+    in
+    let modules =
+      (* With [-no-alias-deps], non-material additions should not
+         affect the environment at all. We should only observe the
+         existence of a cmi when accessing components of the module.
+         (See #9991). *)
+      if material || not !Clflags.transparent_modules then
+        IdTbl.add id Mod_persistent env.modules
+      else
+        env.modules
+    in
+    { env with modules; summary }
+  end
+
+let components_of_module ~alerts ~uid env fs ps path addr mty =
+  {
+    alerts;
+    uid;
+    comps = Lazy_backtrack.create {
+      cm_env = env;
+      cm_freshening_subst = fs;
+      cm_prefixing_subst = ps;
+      cm_path = path;
+      cm_addr = addr;
+      cm_mty = mty
+    }
+  }
+
+let sign_of_cmi ~freshen { Persistent_env.Persistent_signature.cmi; _ } =
+  let name = cmi.cmi_name in
+  let sign = cmi.cmi_sign in
+  let flags = cmi.cmi_flags in
+  let id_subst = Subst.(make_loc_ghost identity) in
+  let id = Ident.create_persistent name in
+  let path = Pident id in
+  let alerts =
+    List.fold_left (fun acc -> function Alerts s -> s | _ -> acc)
+      Misc.String.Map.empty
+      flags
+  in
+  let md =
+    { md_type =  Mty_signature sign;
+      md_loc = Location.none;
+      md_attributes = [];
+      md_uid = Uid.of_compilation_unit_id id;
+    }
+  in
+  let mda_address = Lazy_backtrack.create_forced (Aident id) in
+  let mda_declaration =
+    Lazy_backtrack.create (id_subst, Subst.Make_local, md)
+  in
+  let mda_components =
+    let freshening_subst =
+      if freshen then (Some id_subst) else None
+    in
+    components_of_module ~alerts ~uid:md.md_uid
+      empty freshening_subst id_subst
+      path mda_address (Mty_signature sign)
+  in
+  let result = {
+    mda_declaration;
+    mda_components;
+    mda_address;
+  } in
+  result
+
+
+let read_sign_of_cmi = sign_of_cmi ~freshen:true
+
+let save_sign_of_cmi = sign_of_cmi ~freshen:false
+
+let persistent_env : module_data Persistent_env.t ref =
+  s_table Persistent_env.empty ()
+
+let without_cmis f x =
+  Persistent_env.without_cmis !persistent_env f x
+
+let imports () = Persistent_env.imports !persistent_env
+
+let import_crcs ~source crcs =
+  Persistent_env.import_crcs !persistent_env ~source crcs
+
+let read_pers_mod modname filename =
+  Persistent_env.read !persistent_env
+    read_sign_of_cmi short_paths_components modname filename
+
+let find_pers_mod name =
+  Persistent_env.find !persistent_env
+    read_sign_of_cmi short_paths_components name
+
+let check_pers_mod ~loc name =
+  Persistent_env.check !persistent_env
+    read_sign_of_cmi short_paths_components ~loc name
+
+let crc_of_unit name =
+  Persistent_env.crc_of_unit !persistent_env
+    read_sign_of_cmi short_paths_components name
+
+let is_imported_opaque modname =
+  Persistent_env.is_imported_opaque !persistent_env modname
+
+let register_import_as_opaque modname =
+  Persistent_env.register_import_as_opaque !persistent_env modname
+
+let reset_declaration_caches () =
+  Types.Uid.Tbl.clear !value_declarations;
+  Types.Uid.Tbl.clear !type_declarations;
+  Types.Uid.Tbl.clear !module_declarations;
+  Types.Uid.Tbl.clear !used_constructors;
+  Types.Uid.Tbl.clear !used_labels;
+  ()
+
+let reset_cache () =
+  Current_unit_name.set "";
+  Persistent_env.clear !persistent_env;
+  reset_declaration_caches ();
+  ()
+
+let reset_cache_toplevel () =
+  Persistent_env.clear_missing !persistent_env;
+  reset_declaration_caches ();
+  ()
+
+(* get_components *)
+
+let get_components_res c =
+  match Persistent_env.can_load_cmis !persistent_env with
+  | Persistent_env.Can_load_cmis ->
+    Lazy_backtrack.force !components_of_module_maker' c.comps
+  | Persistent_env.Cannot_load_cmis log ->
+    Lazy_backtrack.force_logged log !components_of_module_maker' c.comps
+
+let get_components c =
+  match get_components_res c with
+  | Error _ -> empty_structure
+  | Ok c -> c
+
+(* Module type of functor application *)
+
+let modtype_of_functor_appl fcomp p1 p2 =
+  match fcomp.fcomp_res with
+  | Mty_alias _ as mty -> mty
+  | mty ->
+      try
+        Hashtbl.find fcomp.fcomp_subst_cache p2
+      with Not_found ->
+        let scope = Path.scope (Papply(p1, p2)) in
+        let mty =
+          let subst =
+            match fcomp.fcomp_arg with
+            | Unit
+            | Named (None, _) -> Subst.identity
+            | Named (Some param, _) -> Subst.add_module param p2 Subst.identity
+          in
+          Subst.modtype (Rescope scope) subst mty
+        in
+        Hashtbl.add fcomp.fcomp_subst_cache p2 mty;
+        mty
+
+let check_functor_appl
+    ~errors ~loc ~lid_whole_app ~f0_path ~args
+    ~f_comp
+    ~arg_path ~arg_mty ~param_mty
+    env =
+  if not (Hashtbl.mem f_comp.fcomp_cache arg_path) then
+    !check_functor_application
+      ~errors ~loc ~lid_whole_app ~f0_path ~args
+      ~arg_path ~arg_mty ~param_mty
+      env
+
+(* Lookup by identifier *)
+
+let find_ident_module id env =
+  match find_same_module id env.modules with
+  | Mod_local data -> data
+  | Mod_unbound _ -> raise Not_found
+  | Mod_persistent -> find_pers_mod (Ident.name id)
+
+let rec find_module_components path env =
+  match path with
+  | Pident id -> (find_ident_module id env).mda_components
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      (NameMap.find s sc.comp_modules).mda_components
+  | Papply(f_path, arg) ->
+      let f_comp = find_functor_components f_path env in
+      let loc = Location.(in_file !input_name) in
+      !components_of_functor_appl' ~loc ~f_path ~f_comp ~arg env
+
+and find_structure_components path env =
+  match get_components (find_module_components path env) with
+  | Structure_comps c -> c
+  | Functor_comps _ -> raise Not_found
+
+and find_functor_components path env =
+  match get_components (find_module_components path env) with
+  | Functor_comps f -> f
+  | Structure_comps _ -> raise Not_found
+
+let find_module ~alias path env =
+  match path with
+  | Pident id ->
+      let data = find_ident_module id env in
+      Lazy_backtrack.force subst_modtype_maker data.mda_declaration
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      let data = NameMap.find s sc.comp_modules in
+      Lazy_backtrack.force subst_modtype_maker data.mda_declaration
+  | Papply(p1, p2) ->
+      let fc = find_functor_components p1 env in
+      if alias then md (fc.fcomp_res)
+      else md (modtype_of_functor_appl fc p1 p2)
+
+let find_value_full path env =
+  match path with
+  | Pident id -> begin
+      match IdTbl.find_same id env.values with
+      | Val_bound data -> data
+      | Val_unbound _ -> raise Not_found
+    end
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      NameMap.find s sc.comp_values
+  | Papply _ -> raise Not_found
+
+let find_type_full path env =
+  match path with
+  | Pident id -> IdTbl.find_same id env.types
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      NameMap.find s sc.comp_types
+  | Papply _ -> raise Not_found
+
+let find_modtype path env =
+  match path with
+  | Pident id -> IdTbl.find_same id env.modtypes
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      NameMap.find s sc.comp_modtypes
+  | Papply _ -> raise Not_found
+
+let find_class_full path env =
+  match path with
+  | Pident id -> IdTbl.find_same id env.classes
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      NameMap.find s sc.comp_classes
+  | Papply _ -> raise Not_found
+
+let find_cltype path env =
+  match path with
+  | Pident id -> IdTbl.find_same id env.cltypes
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      NameMap.find s sc.comp_cltypes
+  | Papply _ -> raise Not_found
+
+let find_value path env =
+  (find_value_full path env).vda_description
+
+let find_class path env =
+  (find_class_full path env).clda_declaration
+
+let find_ident_constructor id env =
+  (TycompTbl.find_same id env.constrs).cda_description
+
+let find_ident_label id env =
+  TycompTbl.find_same id env.labels
+
+let type_of_cstr path = function
+  | {cstr_inlined = Some decl; _} ->
+      let labels =
+        List.map snd (Datarepr.labels_of_type path decl)
+      in
+      begin match decl.type_kind with
+      | Type_record (_, repr) ->
+        {
+          tda_declaration = decl;
+          tda_descriptions = Type_record (labels, repr);
+        }
+      | _ -> assert false
+      end
+  | _ -> assert false
+
+let find_type_data path env =
+  match Path.constructor_typath path with
+  | Regular p -> begin
+      match Path.Map.find p env.local_constraints with
+      | decl ->
+          { tda_declaration = decl; tda_descriptions = Type_abstract }
+      | exception Not_found -> find_type_full p env
+    end
+  | Cstr (ty_path, s) ->
+      (* This case corresponds to an inlined record *)
+      let tda =
+        try find_type_full ty_path env
+        with Not_found -> assert false
+      in
+      let cstr =
+        begin match tda.tda_descriptions with
+        | Type_variant (cstrs, _) -> begin
+            try
+              List.find (fun cstr -> cstr.cstr_name = s) cstrs
+            with Not_found -> assert false
+          end
+        | Type_record _ | Type_abstract | Type_open -> assert false
+        end
+      in
+      type_of_cstr path cstr
+  | LocalExt id ->
+      let cstr =
+        try (TycompTbl.find_same id env.constrs).cda_description
+        with Not_found -> assert false
+      in
+      type_of_cstr path cstr
+  | Ext (mod_path, s) ->
+      let comps =
+        try find_structure_components mod_path env
+        with Not_found -> assert false
+      in
+      let cstrs =
+        try NameMap.find s comps.comp_constrs
+        with Not_found -> assert false
+      in
+      let exts = List.filter is_ext cstrs in
+      match exts with
+      | [cda] -> type_of_cstr path cda.cda_description
+      | _ -> assert false
+
+let find_type p env =
+  (find_type_data p env).tda_declaration
+let find_type_descrs p env =
+  (find_type_data p env).tda_descriptions
+
+let rec find_module_address path env =
+  match path with
+  | Pident id -> get_address (find_ident_module id env).mda_address
+  | Pdot(p, s) ->
+      let c = find_structure_components p env in
+      get_address (NameMap.find s c.comp_modules).mda_address
+  | Papply _ -> raise Not_found
+
+and force_address = function
+  | Projection { parent; pos } -> Adot(get_address parent, pos)
+  | ModAlias { env; path } -> find_module_address path env
+
+and get_address a =
+  Lazy_backtrack.force force_address a
+
+let find_value_address path env =
+  get_address (find_value_full path env).vda_address
+
+let find_class_address path env =
+  get_address (find_class_full path env).clda_address
+
+let rec get_constrs_address = function
+  | [] -> raise Not_found
+  | cda :: rest ->
+    match cda.cda_address with
+    | None -> get_constrs_address rest
+    | Some a -> get_address a
+
+let find_constructor_address path env =
+  match path with
+  | Pident id -> begin
+      let cda = TycompTbl.find_same id env.constrs in
+      match cda.cda_address with
+      | None -> raise Not_found
+      | Some addr -> get_address addr
+    end
+  | Pdot(p, s) ->
+      let c = find_structure_components p env in
+      get_constrs_address (NameMap.find s c.comp_constrs)
+  | Papply _ ->
+      raise Not_found
+
+let find_hash_type path env =
+  match path with
+  | Pident id ->
+      let name = "#" ^ Ident.name id in
+      let _, tda =
+        IdTbl.find_name wrap_identity ~mark:false name env.types
+      in
+      tda.tda_declaration
+  | Pdot(p, s) ->
+      let c = find_structure_components p env in
+      let name = "#" ^ s in
+      let tda = NameMap.find name c.comp_types in
+      tda.tda_declaration
+  | Papply _ ->
+      raise Not_found
+
+let required_globals = s_ref []
+let reset_required_globals () = required_globals := []
+let get_required_globals () = !required_globals
+let add_required_global id =
+  if Ident.global id && not !Clflags.transparent_modules
+  && not (List.exists (Ident.same id) !required_globals)
+  then required_globals := id :: !required_globals
+
+let rec normalize_module_path lax env = function
+  | Pident id as path when lax && Ident.persistent id ->
+      path (* fast path (avoids lookup) *)
+  | Pdot (p, s) as path ->
+      let p' = normalize_module_path lax env p in
+      if p == p' then expand_module_path lax env path
+      else expand_module_path lax env (Pdot(p', s))
+  | Papply (p1, p2) as path ->
+      let p1' = normalize_module_path lax env p1 in
+      let p2' = normalize_module_path true env p2 in
+      if p1 == p1' && p2 == p2' then expand_module_path lax env path
+      else expand_module_path lax env (Papply(p1', p2'))
+  | Pident _ as path ->
+      expand_module_path lax env path
+
+and expand_module_path lax env path =
+  try match find_module ~alias:true path env with
+    {md_type=Mty_alias path1} ->
+      let path' = normalize_module_path lax env path1 in
+      if lax || !Clflags.transparent_modules then path' else
+      let id = Path.head path in
+      if Ident.global id && not (Ident.same id (Path.head path'))
+      then add_required_global id;
+      path'
+  | _ -> path
+  with Not_found when lax
+  || (match path with Pident id -> not (Ident.persistent id) | _ -> true) ->
+      path
+
+let normalize_module_path oloc env path =
+  try normalize_module_path (oloc = None) env path
+  with Not_found ->
+    match oloc with None -> assert false
+    | Some loc ->
+        error (Missing_module(loc, path,
+                              normalize_module_path true env path))
+
+let normalize_path_prefix oloc env path =
+  match path with
+    Pdot(p, s) ->
+      let p2 = normalize_module_path oloc env p in
+      if p == p2 then path else Pdot(p2, s)
+  | Pident _ ->
+      path
+  | Papply _ ->
+      assert false
+
+let normalize_type_path oloc env path =
+  (* Inlined version of Path.is_constructor_typath:
+     constructor type paths (i.e. path pointing to an inline
+     record argument of a constructpr) are built as a regular
+     type path followed by a capitalized constructor name. *)
+  match path with
+  | Pident _ ->
+      path
+  | Pdot(p, s) ->
+      let p2 =
+        if Path.is_uident s && not (Path.is_uident (Path.last p)) then
+          (* Cstr M.t.C *)
+          normalize_path_prefix oloc env p
+        else
+          (* Regular M.t, Ext M.C *)
+          normalize_module_path oloc env p
+      in
+      if p == p2 then path else Pdot (p2, s)
+  | Papply _ ->
+      assert false
+
+let rec normalize_modtype_path env path =
+  let path = normalize_path_prefix None env path in
+  expand_modtype_path env path
+
+and expand_modtype_path env path =
+  match (find_modtype path env).mtd_type with
+  | Some (Mty_ident path) -> normalize_modtype_path env path
+  | _ | exception Not_found -> path
+
+let find_module path env =
+  find_module ~alias:false path env
+
+(* Find the manifest type associated to a type when appropriate:
+   - the type should be public or should have a private row,
+   - the type should have an associated manifest type. *)
+let find_type_expansion path env =
+  let decl = find_type path env in
+  match decl.type_manifest with
+  | Some body when decl.type_private = Public
+              || decl.type_kind <> Type_abstract
+              || Btype.has_constr_row body ->
+      (decl.type_params, body, decl.type_expansion_scope)
+  (* The manifest type of Private abstract data types without
+     private row are still considered unknown to the type system.
+     Hence, this case is caught by the following clause that also handles
+     purely abstract data types without manifest type definition. *)
+  | _ -> raise Not_found
+
+(* Find the manifest type information associated to a type, i.e.
+   the necessary information for the compiler's type-based optimisations.
+   In particular, the manifest type associated to a private abstract type
+   is revealed for the sake of compiler's type-based optimisations. *)
+let find_type_expansion_opt path env =
+  let decl = find_type path env in
+  match decl.type_manifest with
+  (* The manifest type of Private abstract data types can still get
+     an approximation using their manifest type. *)
+  | Some body ->
+      (decl.type_params, body, decl.type_expansion_scope)
+  | _ -> raise Not_found
+
+let find_modtype_expansion path env =
+  match (find_modtype path env).mtd_type with
+  | None -> raise Not_found
+  | Some mty -> mty
+
+let rec is_functor_arg path env =
+  match path with
+    Pident id ->
+      begin try Ident.find_same id env.functor_args; true
+      with Not_found -> false
+      end
+  | Pdot (p, _s) -> is_functor_arg p env
+  | Papply _ -> true
+
+(* Copying types associated with values *)
+
+let make_copy_of_types env0 =
+  let memo = Hashtbl.create 16 in
+  let copy t =
+    try
+      Hashtbl.find memo t.id
+    with Not_found ->
+      let t2 = Subst.type_expr Subst.identity t in
+      Hashtbl.add memo t.id t2;
+      t2
+  in
+  let f = function
+    | Val_unbound _ as entry -> entry
+    | Val_bound vda ->
+        let desc = vda.vda_description in
+        let desc = { desc with val_type = copy desc.val_type } in
+        Val_bound { vda with vda_description = desc }
+  in
+  let values =
+    IdTbl.map f env0.values
+  in
+  (fun env ->
+     (*if env.values != env0.values then fatal_error "Env.make_copy_of_types";*)
+     {env with values; summary = Env_copy_types env.summary}
+  )
+
+(* Helper to handle optional substitutions. *)
+
+let may_subst subst_f sub x =
+  match sub with
+  | None -> x
+  | Some sub -> subst_f sub x
+
+(* Iter on an environment (ignoring the body of functors and
+   not yet evaluated structures) *)
+
+type iter_cont = unit -> unit
+let iter_env_cont = ref []
+
+let rec scrape_alias_for_visit env (sub : Subst.t option) mty =
+  match mty with
+  | Mty_alias path ->
+      begin match may_subst Subst.module_path sub path with
+      | Pident id
+        when Ident.persistent id
+          && not (Persistent_env.looked_up !persistent_env (Ident.name id)) ->
+          false
+      | path -> (* PR#6600: find_module may raise Not_found *)
+          try scrape_alias_for_visit env sub (find_module path env).md_type
+          with Not_found -> false
+      end
+  | _ -> true
+
+let iter_env wrap proj1 proj2 f env () =
+  IdTbl.iter wrap (fun id x -> f (Pident id) x) (proj1 env);
+  let rec iter_components path path' mcomps =
+    let cont () =
+      let visit =
+        match Lazy_backtrack.get_arg mcomps.comps with
+        | None -> true
+        | Some { cm_mty; cm_freshening_subst; _ } ->
+            scrape_alias_for_visit env cm_freshening_subst cm_mty
+      in
+      if not visit then () else
+      match get_components mcomps with
+        Structure_comps comps ->
+          NameMap.iter
+            (fun s d -> f (Pdot (path, s)) (Pdot (path', s), d))
+            (proj2 comps);
+          NameMap.iter
+            (fun s mda ->
+              iter_components
+                (Pdot (path, s)) (Pdot (path', s)) mda.mda_components)
+            comps.comp_modules
+      | Functor_comps _ -> ()
+    in iter_env_cont := (path, cont) :: !iter_env_cont
+  in
+  IdTbl.iter wrap_module
+    (fun id (path, entry) ->
+       match entry with
+       | Mod_unbound _ -> ()
+       | Mod_local data ->
+           iter_components (Pident id) path data.mda_components
+       | Mod_persistent ->
+           let modname = Ident.name id in
+           match Persistent_env.find_in_cache !persistent_env modname with
+           | None -> ()
+           | Some data ->
+               iter_components (Pident id) path data.mda_components)
+    env.modules
+
+let run_iter_cont l =
+  iter_env_cont := [];
+  List.iter (fun c -> c ()) l;
+  let cont = List.rev !iter_env_cont in
+  iter_env_cont := [];
+  cont
+
+let iter_types f =
+  iter_env wrap_identity (fun env -> env.types) (fun sc -> sc.comp_types)
+    (fun p1 (p2, tda) -> f p1 (p2, tda.tda_declaration))
+
+let same_types env1 env2 =
+  env1.types == env2.types && env1.modules == env2.modules
+
+let used_persistent () =
+  Persistent_env.fold !persistent_env
+    (fun s _m r -> Concr.add s r)
+    Concr.empty
+
+let find_all_comps wrap proj s (p, mda) =
+  match get_components mda.mda_components with
+    Functor_comps _ -> []
+  | Structure_comps comps ->
+      try
+        let c = NameMap.find s (proj comps) in
+        [Pdot(p,s), wrap c]
+      with Not_found -> []
+
+let rec find_shadowed_comps path env =
+  match path with
+  | Pident id ->
+      List.filter_map
+        (fun (p, data) ->
+           match data with
+           | Mod_local x -> Some (p, x)
+           | Mod_unbound _ | Mod_persistent -> None)
+        (IdTbl.find_all wrap_module (Ident.name id) env.modules)
+  | Pdot (p, s) ->
+      let l = find_shadowed_comps p env in
+      let l' =
+        List.map
+          (find_all_comps wrap_identity
+             (fun comps -> comps.comp_modules) s) l
+      in
+      List.flatten l'
+  | Papply _ -> []
+
+let find_shadowed wrap proj1 proj2 path env =
+  match path with
+    Pident id ->
+      IdTbl.find_all wrap (Ident.name id) (proj1 env)
+  | Pdot (p, s) ->
+      let l = find_shadowed_comps p env in
+      let l' = List.map (find_all_comps wrap proj2 s) l in
+      List.flatten l'
+  | Papply _ -> []
+
+let find_shadowed_types path env =
+  List.map fst
+    (find_shadowed wrap_identity
+       (fun env -> env.types) (fun comps -> comps.comp_types) path env)
+
+(* Expand manifest module type names at the top of the given module type *)
+
+let rec scrape_alias env sub ?path mty =
+  match mty, path with
+    Mty_ident _, _ ->
+      let p =
+        match may_subst (Subst.modtype Keep) sub mty with
+        | Mty_ident p -> p
+        | _ -> assert false (* only [Mty_ident]s in [sub] *)
+      in
+      begin try
+        scrape_alias env sub (find_modtype_expansion p env) ?path
+      with Not_found ->
+        mty
+      end
+  | Mty_alias path, _ ->
+      let path = may_subst Subst.module_path sub path in
+      begin try
+        scrape_alias env sub (find_module path env).md_type ~path
+      with Not_found ->
+        (*Location.prerr_warning Location.none
+          (Warnings.No_cmi_file (Path.name path));*)
+        mty
+      end
+  | mty, Some path ->
+      !strengthen ~aliasable:true env mty path
+  | _ -> mty
+
+(* Given a signature and a root path, prefix all idents in the signature
+   by the root path and build the corresponding substitution. *)
+
+let prefix_idents root freshening_sub prefixing_sub sg =
+  let refresh id add_fn = function
+    | None -> id, None
+    | Some sub ->
+      let id' = Ident.rename id in
+      id', Some (add_fn id (Pident id') sub)
+  in
+  let rec prefix_idents root items_and_paths freshening_sub prefixing_sub =
+    function
+    | [] -> (List.rev items_and_paths, freshening_sub, prefixing_sub)
+    | Sig_value(id, _, _) as item :: rem ->
+      let p = Pdot(root, Ident.name id) in
+      prefix_idents root
+        ((item, p) :: items_and_paths) freshening_sub prefixing_sub rem
+    | Sig_type(id, td, rs, vis) :: rem ->
+      let p = Pdot(root, Ident.name id) in
+      let id', freshening_sub = refresh id Subst.add_type freshening_sub in
+      prefix_idents root
+        ((Sig_type(id', td, rs, vis), p) :: items_and_paths)
+        freshening_sub
+        (Subst.add_type id' p prefixing_sub)
+        rem
+    | Sig_typext(id, ec, es, vis) :: rem ->
+      let p = Pdot(root, Ident.name id) in
+      let id', freshening_sub = refresh id Subst.add_type freshening_sub in
+      (* we extend the substitution in case of an inlined record *)
+      prefix_idents root
+        ((Sig_typext(id', ec, es, vis), p) :: items_and_paths)
+        freshening_sub
+        (Subst.add_type id' p prefixing_sub)
+        rem
+    | Sig_module(id, pres, md, rs, vis) :: rem ->
+      let p = Pdot(root, Ident.name id) in
+      let id', freshening_sub = refresh id Subst.add_module freshening_sub in
+      prefix_idents root
+        ((Sig_module(id', pres, md, rs, vis), p) :: items_and_paths)
+        freshening_sub
+        (Subst.add_module id' p prefixing_sub)
+        rem
+    | Sig_modtype(id, mtd, vis) :: rem ->
+      let p = Pdot(root, Ident.name id) in
+      let id', freshening_sub =
+        refresh id (fun i p s -> Subst.add_modtype i (Mty_ident p) s)
+          freshening_sub
+      in
+      prefix_idents root
+        ((Sig_modtype(id', mtd, vis), p) :: items_and_paths)
+        freshening_sub
+        (Subst.add_modtype id' (Mty_ident p) prefixing_sub)
+        rem
+    | Sig_class(id, cd, rs, vis) :: rem ->
+      (* pretend this is a type, cf. PR#6650 *)
+      let p = Pdot(root, Ident.name id) in
+      let id', freshening_sub = refresh id Subst.add_type freshening_sub in
+      prefix_idents root
+        ((Sig_class(id', cd, rs, vis), p) :: items_and_paths)
+        freshening_sub
+        (Subst.add_type id' p prefixing_sub)
+        rem
+    | Sig_class_type(id, ctd, rs, vis) :: rem ->
+      let p = Pdot(root, Ident.name id) in
+      let id', freshening_sub = refresh id Subst.add_type freshening_sub in
+      prefix_idents root
+        ((Sig_class_type(id', ctd, rs, vis), p) :: items_and_paths)
+        freshening_sub
+        (Subst.add_type id' p prefixing_sub)
+        rem
+  in
+  prefix_idents root [] freshening_sub prefixing_sub sg
+
+(* Short path additions *)
+
+let short_paths_type predef id decl old =
+  if not predef && !Clflags.real_paths then old
+  else Type(id, decl) :: old
+
+let short_paths_type_open path decls old =
+  if !Clflags.real_paths then old
+  else Type_open(path, decls) :: old
+
+let unbound_class = Path.Pident (Ident.create_local "*undef*")
+
+let is_dummy_class decl =
+  Path.same decl.clty_path unbound_class
+
+let short_paths_class_type id decl old =
+  if !Clflags.real_paths || is_dummy_class decl then old
+  else Class_type(id, decl) :: old
+
+let short_paths_class_type_open path decls old =
+  if !Clflags.real_paths then old
+  else Class_type_open(path, decls) :: old
+
+let short_paths_module_type id decl old =
+  if !Clflags.real_paths then old
+  else Module_type(id, decl) :: old
+
+let short_paths_module_type_open path decls old =
+  if !Clflags.real_paths then old
+  else Module_type_open(path, decls) :: old
+
+let short_paths_module id decl comps old =
+  if !Clflags.real_paths then old
+  else Module(id, decl, comps) :: old
+
+let short_paths_module_open path comps old =
+  if !Clflags.real_paths then old
+  else Module_open(path, comps) :: old
+
+(* Compute structure descriptions *)
+
+let add_to_tbl id decl tbl =
+  let decls = try NameMap.find id tbl with Not_found -> [] in
+  NameMap.add id (decl :: decls) tbl
+
+let value_declaration_address (_ : t) id decl =
+  match decl.val_kind with
+  | Val_prim _ -> Lazy_backtrack.create_failed Not_found
+  | _ -> Lazy_backtrack.create_forced (Aident id)
+
+let extension_declaration_address (_ : t) id (_ : extension_constructor) =
+  Lazy_backtrack.create_forced (Aident id)
+
+let class_declaration_address (_ : t) id (_ : class_declaration) =
+  Lazy_backtrack.create_forced (Aident id)
+
+let module_declaration_address env id presence md =
+  match presence with
+  | Mp_absent -> begin
+      match md.md_type with
+      | Mty_alias path -> Lazy_backtrack.create (ModAlias {env; path})
+      | _ -> assert false
+    end
+  | Mp_present ->
+      Lazy_backtrack.create_forced (Aident id)
+
+let is_identchar c =
+  (* This should be kept in sync with the [identchar_latin1] character class
+     in [lexer.mll] *)
+  match c with
+  | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214'
+  | '\216'..'\246' | '\248'..'\255' | '\'' | '0'..'9' ->
+    true
+  | _ ->
+    false
+
+let rec components_of_module_maker
+          {cm_env; cm_freshening_subst; cm_prefixing_subst;
+           cm_path; cm_addr; cm_mty} : _ result =
+  match scrape_alias cm_env cm_freshening_subst cm_mty with
+    Mty_signature sg ->
+      let c =
+        { comp_values = NameMap.empty;
+          comp_constrs = NameMap.empty;
+          comp_labels = NameMap.empty; comp_types = NameMap.empty;
+          comp_modules = NameMap.empty; comp_modtypes = NameMap.empty;
+          comp_classes = NameMap.empty; comp_cltypes = NameMap.empty }
+      in
+      let items_and_paths, freshening_sub, prefixing_sub =
+        prefix_idents cm_path cm_freshening_subst cm_prefixing_subst sg
+      in
+      let env = ref cm_env in
+      let pos = ref 0 in
+      let next_address () =
+        let addr : address_unforced =
+          Projection { parent = cm_addr; pos = !pos }
+        in
+        incr pos;
+        Lazy_backtrack.create addr
+      in
+      let sub = may_subst Subst.compose freshening_sub prefixing_sub in
+      List.iter (fun (item, path) ->
+        match item with
+          Sig_value(id, decl, _) ->
+            let decl' = Subst.value_description sub decl in
+            let addr =
+              match decl.val_kind with
+              | Val_prim _ -> Lazy_backtrack.create_failed Not_found
+              | _ -> next_address ()
+            in
+            let vda = { vda_description = decl'; vda_address = addr } in
+            c.comp_values <- NameMap.add (Ident.name id) vda c.comp_values;
+        | Sig_type(id, decl, _, _) ->
+            let fresh_decl =
+              may_subst Subst.type_declaration freshening_sub decl
+            in
+            let final_decl = Subst.type_declaration prefixing_sub fresh_decl in
+            Btype.set_row_name final_decl
+              (Subst.type_path prefixing_sub (Path.Pident id));
+            let descrs =
+              match decl.type_kind with
+              | Type_variant (_,repr) ->
+                  let cstrs = List.map snd
+                    (Datarepr.constructors_of_type path final_decl
+                        ~current_unit:(get_unit_name ()))
+                  in
+                  List.iter
+                    (fun descr ->
+                      let cda = {
+                        cda_description = descr;
+                        cda_address = None }
+                      in
+                      c.comp_constrs <-
+                        add_to_tbl descr.cstr_name cda c.comp_constrs
+                    ) cstrs;
+                 Type_variant (cstrs, repr)
+              | Type_record (_, repr) ->
+                  let lbls = List.map snd
+                    (Datarepr.labels_of_type path final_decl)
+                  in
+                  List.iter
+                    (fun descr ->
+                      c.comp_labels <-
+                        add_to_tbl descr.lbl_name descr c.comp_labels)
+                    lbls;
+                  Type_record (lbls, repr)
+              | Type_abstract -> Type_abstract
+              | Type_open -> Type_open
+            in
+            let tda =
+              { tda_declaration = final_decl;
+                tda_descriptions = descrs; }
+            in
+            c.comp_types <- NameMap.add (Ident.name id) tda c.comp_types;
+            env := store_type_infos id fresh_decl !env
+        | Sig_typext(id, ext, _, _) ->
+            let ext' = Subst.extension_constructor sub ext in
+            let descr =
+              Datarepr.extension_descr ~current_unit:(get_unit_name ()) path
+                ext'
+            in
+            let addr = next_address () in
+            let cda = { cda_description = descr; cda_address = Some addr } in
+            c.comp_constrs <- add_to_tbl (Ident.name id) cda c.comp_constrs
+        | Sig_module(id, pres, md, _, _) ->
+            let md' =
+              (* The prefixed items get the same scope as [cm_path], which is
+                 the prefix. *)
+              Lazy_backtrack.create
+                (sub, Subst.Rescope (Path.scope cm_path), md)
+            in
+            let addr =
+              match pres with
+              | Mp_absent -> begin
+                  match md.md_type with
+                  | Mty_alias p ->
+                      let path = may_subst Subst.module_path freshening_sub p in
+                      Lazy_backtrack.create (ModAlias {env = !env; path})
+                  | _ -> assert false
+                end
+              | Mp_present -> next_address ()
+            in
+            let alerts =
+              Builtin_attributes.alerts_of_attrs md.md_attributes
+            in
+            let comps =
+              components_of_module ~alerts ~uid:md.md_uid !env freshening_sub
+                prefixing_sub path addr md.md_type
+            in
+            let mda =
+              { mda_declaration = md';
+                mda_components = comps;
+                mda_address = addr }
+            in
+            c.comp_modules <-
+              NameMap.add (Ident.name id) mda c.comp_modules;
+            env :=
+              store_module ~freshening_sub ~check:None id addr pres md !env
+        | Sig_modtype(id, decl, _) ->
+            let fresh_decl =
+              (* the fresh_decl is only going in the local temporary env, and
+                 shouldn't be used for anything. So we make the items local. *)
+              may_subst (Subst.modtype_declaration Make_local) freshening_sub
+                decl
+            in
+            let final_decl =
+              (* The prefixed items get the same scope as [cm_path], which is
+                 the prefix. *)
+              Subst.modtype_declaration (Rescope (Path.scope cm_path))
+                prefixing_sub fresh_decl
+            in
+            c.comp_modtypes <-
+              NameMap.add (Ident.name id) final_decl c.comp_modtypes;
+            env := store_modtype id fresh_decl !env
+        | Sig_class(id, decl, _, _) ->
+            let decl' = Subst.class_declaration sub decl in
+            let addr = next_address () in
+            let clda = { clda_declaration = decl'; clda_address = addr } in
+            c.comp_classes <- NameMap.add (Ident.name id) clda c.comp_classes
+        | Sig_class_type(id, decl, _, _) ->
+            let decl' = Subst.cltype_declaration sub decl in
+            c.comp_cltypes <-
+              NameMap.add (Ident.name id) decl' c.comp_cltypes)
+        items_and_paths;
+        Ok (Structure_comps c)
+  | Mty_functor(arg, ty_res) ->
+      let sub =
+        may_subst Subst.compose cm_freshening_subst cm_prefixing_subst
+      in
+      let scoping = Subst.Rescope (Path.scope cm_path) in
+        Ok (Functor_comps {
+          (* fcomp_arg and fcomp_res must be prefixed eagerly, because
+             they are interpreted in the outer environment *)
+          fcomp_arg =
+            (match arg with
+            | Unit -> Unit
+            | Named (param, ty_arg) ->
+              Named (param, Subst.modtype scoping sub ty_arg));
+          fcomp_res = Subst.modtype scoping sub ty_res;
+          fcomp_cache = Hashtbl.create 17;
+          fcomp_subst_cache = Hashtbl.create 17 })
+  | Mty_ident _ -> Error No_components_abstract
+  | Mty_alias p -> Error (No_components_alias p)
+  | Mty_for_hole -> Error No_components_abstract
+
+(* Insertion of bindings by identifier + path *)
+
+and check_usage loc id uid warn tbl =
+  if not loc.Location.loc_ghost &&
+     Uid.for_actual_declaration uid &&
+     Warnings.is_active (warn "")
+  then begin
+    let name = Ident.name id in
+    if Types.Uid.Tbl.mem tbl uid then ()
+    else let used = ref false in
+    Types.Uid.Tbl.add tbl uid (fun () -> used := true);
+    if not (name = "" || name.[0] = '_' || name.[0] = '#')
+    then
+      !add_delayed_check_forward
+        (fun () -> if not !used then Location.prerr_warning loc (warn name))
+  end;
+
+and check_value_name name loc =
+  (* Note: we could also check here general validity of the
+     identifier, to protect against bad identifiers forged by -pp or
+     -ppx preprocessors. *)
+  if String.length name > 0 && not (is_identchar name.[0]) then
+    for i = 1 to String.length name - 1 do
+      if name.[i] = '#' then
+        error (Illegal_value_name(loc, name))
+    done
+
+and store_value ?check id addr decl env =
+  check_value_name (Ident.name id) decl.val_loc;
+  Option.iter
+    (fun f -> check_usage decl.val_loc id decl.val_uid f !value_declarations)
+    check;
+  let vda = { vda_description = decl; vda_address = addr } in
+  { env with
+    values = IdTbl.add id (Val_bound vda) env.values;
+    summary = Env_value(env.summary, id, decl) }
+
+and store_constructor ~check type_decl type_id cstr_id cstr env =
+  if check && not type_decl.type_loc.Location.loc_ghost
+     && Warnings.is_active (Warnings.Unused_constructor ("", Unused))
+  then begin
+    let ty_name = Ident.name type_id in
+    let name = cstr.cstr_name in
+    let loc = cstr.cstr_loc in
+    let k = cstr.cstr_uid in
+    let priv = type_decl.type_private in
+    if not (Types.Uid.Tbl.mem !used_constructors k) then begin
+      let used = constructor_usages () in
+      Types.Uid.Tbl.add !used_constructors k
+        (add_constructor_usage used);
+      if not (ty_name = "" || ty_name.[0] = '_')
+      then
+        !add_delayed_check_forward
+          (fun () ->
+            Option.iter
+              (fun complaint ->
+                 if not (is_in_signature env) then
+                   Location.prerr_warning loc
+                     (Warnings.Unused_constructor(name, complaint)))
+              (constructor_usage_complaint ~rebind:false priv used));
+    end;
+  end;
+  { env with
+    constrs =
+      TycompTbl.add cstr_id
+        { cda_description = cstr; cda_address = None } env.constrs;
+  }
+
+and store_label ~check type_decl type_id lbl_id lbl env =
+  if check && not type_decl.type_loc.Location.loc_ghost
+     && Warnings.is_active (Warnings.Unused_field ("", Unused))
+  then begin
+    let ty_name = Ident.name type_id in
+    let priv = type_decl.type_private in
+    let name = lbl.lbl_name in
+    let loc = lbl.lbl_loc in
+    let mut = lbl.lbl_mut in
+    let k = lbl.lbl_uid in
+    if not (Types.Uid.Tbl.mem !used_labels k) then
+      let used = label_usages () in
+      Types.Uid.Tbl.add !used_labels k
+        (add_label_usage used);
+      if not (ty_name = "" || ty_name.[0] = '_' || name.[0] = '_')
+      then !add_delayed_check_forward
+          (fun () ->
+            Option.iter
+              (fun complaint ->
+                 if not (is_in_signature env) then
+                   Location.prerr_warning
+                     loc (Warnings.Unused_field(name, complaint)))
+              (label_usage_complaint priv mut used))
+  end;
+  { env with
+    labels = TycompTbl.add lbl_id lbl env.labels;
+  }
+
+and store_type ~check ~predef id info env =
+  let loc = info.type_loc in
+  if check then
+    check_usage loc id info.type_uid
+      (fun s -> Warnings.Unused_type_declaration s)
+      !type_declarations;
+  let descrs, env =
+    let path = Pident id in
+    match info.type_kind with
+    | Type_variant (_,repr) ->
+        let constructors = Datarepr.constructors_of_type path info
+                            ~current_unit:(get_unit_name ())
+        in
+        Type_variant (List.map snd constructors, repr),
+        List.fold_left
+          (fun env (cstr_id, cstr) ->
+            store_constructor ~check info id cstr_id cstr env)
+          env constructors
+    | Type_record (_, repr) ->
+        let labels = Datarepr.labels_of_type path info in
+        Type_record (List.map snd labels, repr),
+        List.fold_left
+          (fun env (lbl_id, lbl) ->
+            store_label ~check info id lbl_id lbl env)
+          env labels
+    | Type_abstract -> Type_abstract, env
+    | Type_open -> Type_open, env
+  in
+  let tda = { tda_declaration = info; tda_descriptions = descrs } in
+  { env with
+    types = IdTbl.add id tda env.types;
+    summary = Env_type(env.summary, id, info);
+    short_paths_additions =
+      short_paths_type predef id info env.short_paths_additions; }
+
+and store_type_infos id info env =
+  (* Simplified version of store_type that doesn't compute and store
+     constructor and label infos, but simply record the arity and
+     manifest-ness of the type.  Used in components_of_module to
+     keep track of type abbreviations (e.g. type t = float) in the
+     computation of label representations. *)
+  let tda = { tda_declaration = info; tda_descriptions = Type_abstract } in
+  { env with
+    types = IdTbl.add id tda env.types;
+    summary = Env_type(env.summary, id, info);
+    short_paths_additions =
+      short_paths_type false id info env.short_paths_additions; }
+
+and store_extension ~check ~rebind id addr ext env =
+  let loc = ext.ext_loc in
+  let cstr =
+    Datarepr.extension_descr ~current_unit:(get_unit_name ()) (Pident id) ext
+  in
+  let cda = { cda_description = cstr; cda_address = Some addr } in
+  if check && not loc.Location.loc_ghost &&
+    Warnings.is_active (Warnings.Unused_extension ("", false, Unused))
+  then begin
+    let priv = ext.ext_private in
+    let is_exception = Path.same ext.ext_type_path Predef.path_exn in
+    let name = cstr.cstr_name in
+    let k = cstr.cstr_uid in
+    if not (Types.Uid.Tbl.mem !used_constructors k) then begin
+      let used = constructor_usages () in
+      Types.Uid.Tbl.add !used_constructors k
+        (add_constructor_usage used);
+      !add_delayed_check_forward
+         (fun () ->
+           Option.iter
+             (fun complaint ->
+                if not (is_in_signature env) then
+                  Location.prerr_warning loc
+                    (Warnings.Unused_extension
+                       (name, is_exception, complaint)))
+             (constructor_usage_complaint ~rebind priv used))
+    end;
+  end;
+  { env with
+    constrs = TycompTbl.add id cda env.constrs;
+    summary = Env_extension(env.summary, id, ext) }
+
+and store_module ~check ~freshening_sub id addr presence md env =
+  let loc = md.md_loc in
+  Option.iter
+    (fun f -> check_usage loc id md.md_uid f !module_declarations) check;
+  let alerts = Builtin_attributes.alerts_of_attrs md.md_attributes in
+  let module_decl_lazy =
+    match freshening_sub with
+    | None -> Lazy_backtrack.create_forced md
+    | Some s -> Lazy_backtrack.create (s, Subst.Rescope (Ident.scope id), md)
+  in
+  let comps =
+    components_of_module ~alerts ~uid:md.md_uid
+      env freshening_sub Subst.identity (Pident id) addr md.md_type
+  in
+  let mda =
+    { mda_declaration = module_decl_lazy;
+      mda_components = comps;
+      mda_address = addr }
+  in
+  { env with
+    modules = IdTbl.add id (Mod_local mda) env.modules;
+    summary = Env_module(env.summary, id, presence, md);
+    short_paths_additions =
+      short_paths_module id md comps env.short_paths_additions; }
+
+and store_modtype id info env =
+  { env with
+    modtypes = IdTbl.add id info env.modtypes;
+    summary = Env_modtype(env.summary, id, info);
+    short_paths_additions =
+      short_paths_module_type id info env.short_paths_additions; }
+
+and store_class id addr desc env =
+  let clda = { clda_declaration = desc; clda_address = addr } in
+  { env with
+    classes = IdTbl.add id clda env.classes;
+    summary = Env_class(env.summary, id, desc) }
+
+and store_cltype id desc env =
+  { env with
+    cltypes = IdTbl.add id desc env.cltypes;
+    summary = Env_cltype(env.summary, id, desc);
+    short_paths_additions =
+      short_paths_class_type id desc env.short_paths_additions; }
+
+let scrape_alias env mty = scrape_alias env None mty
+
+(* Compute the components of a functor application in a path. *)
+
+let components_of_functor_appl ~loc ~f_path ~f_comp ~arg env =
+  try
+    let c = Hashtbl.find f_comp.fcomp_cache arg in
+    c
+  with Not_found ->
+    let p = Papply(f_path, arg) in
+    let sub =
+      match f_comp.fcomp_arg with
+      | Unit
+      | Named (None, _) -> Subst.identity
+      | Named (Some param, _) -> Subst.add_module param arg Subst.identity
+    in
+    (* we have to apply eagerly instead of passing sub to [components_of_module]
+       because of the call to [check_well_formed_module]. *)
+    let mty = Subst.modtype (Rescope (Path.scope p)) sub f_comp.fcomp_res in
+    let addr = Lazy_backtrack.create_failed Not_found in
+    !check_well_formed_module env loc
+      ("the signature of " ^ Path.name p) mty;
+    let comps =
+      components_of_module ~alerts:Misc.String.Map.empty
+        ~uid:Uid.internal_not_actually_unique
+        (*???*)
+        env None Subst.identity p addr mty
+    in
+    Hashtbl.add f_comp.fcomp_cache arg comps;
+    comps
+
+(* Define forward functions *)
+
+let _ =
+  components_of_functor_appl' := components_of_functor_appl;
+  components_of_module_maker' := components_of_module_maker
+
+(* Insertion of bindings by identifier *)
+
+let add_functor_arg id env =
+  {env with
+   functor_args = Ident.add id () env.functor_args;
+   summary = Env_functor_arg (env.summary, id)}
+
+let add_value ?check id desc env =
+  let addr = value_declaration_address env id desc in
+  store_value ?check id addr desc env
+
+let add_type ~check id info env =
+  store_type ~check id info env
+
+and add_extension ~check ~rebind id ext env =
+  let addr = extension_declaration_address env id ext in
+  store_extension ~check ~rebind id addr ext env
+
+and add_module_declaration ?(arg=false) ~check id presence md env =
+  let check =
+    if not check then
+      None
+    else if arg && is_in_signature env then
+      Some (fun s -> Warnings.Unused_functor_parameter s)
+    else
+      Some (fun s -> Warnings.Unused_module s)
+  in
+  let addr = module_declaration_address env id presence md in
+  let env = store_module ~freshening_sub:None ~check id addr presence md env in
+  if arg then add_functor_arg id env else env
+
+and add_modtype id info env =
+  store_modtype id info env
+
+and add_class id ty env =
+  let addr = class_declaration_address env id ty in
+  store_class id addr ty env
+
+and add_cltype id ty env =
+  store_cltype id ty env
+
+let add_module ?arg id presence mty env =
+  add_module_declaration ~check:false ?arg id presence (md mty) env
+
+let add_local_type path info env =
+  { env with
+    local_constraints = Path.Map.add path info env.local_constraints }
+
+
+(* Insertion of bindings by name *)
+
+let enter_value ?check name desc env =
+  let id = Ident.create_local name in
+  let addr = value_declaration_address env id desc in
+  let env = store_value ?check id addr desc env in
+  (id, env)
+
+let enter_type ~scope name info env =
+  let id = Ident.create_scoped ~scope name in
+  let env = store_type ~check:true ~predef:false id info env in
+  (id, env)
+
+let enter_extension ~scope ~rebind name ext env =
+  let id = Ident.create_scoped ~scope name in
+  let addr = extension_declaration_address env id ext in
+  let env = store_extension ~check:true ~rebind id addr ext env in
+  (id, env)
+
+let enter_module_declaration ~scope ?arg s presence md env =
+  let id = Ident.create_scoped ~scope s in
+  (id, add_module_declaration ?arg ~check:true id presence md env)
+
+let enter_modtype ~scope name mtd env =
+  let id = Ident.create_scoped ~scope name in
+  let env = store_modtype id mtd env in
+  (id, env)
+
+let enter_class ~scope name desc env =
+  let id = Ident.create_scoped ~scope name in
+  let addr = class_declaration_address env id desc in
+  let env = store_class id addr desc env in
+  (id, env)
+
+let enter_cltype ~scope name desc env =
+  let id = Ident.create_scoped ~scope name in
+  let env = store_cltype id desc env in
+  (id, env)
+
+let enter_module ~scope ?arg s presence mty env =
+  enter_module_declaration ~scope ?arg s presence (md mty) env
+
+(* Insertion of all components of a signature *)
+
+let add_item comp env =
+  match comp with
+    Sig_value(id, decl, _)    -> add_value id decl env
+  | Sig_type(id, decl, _, _)  -> add_type ~check:false ~predef:false id decl env
+  | Sig_typext(id, ext, _, _) ->
+      add_extension ~check:false ~rebind:false id ext env
+  | Sig_module(id, presence, md, _, _) ->
+      add_module_declaration ~check:false id presence md env
+  | Sig_modtype(id, decl, _)  -> add_modtype id decl env
+  | Sig_class(id, decl, _, _) -> add_class id decl env
+  | Sig_class_type(id, decl, _, _) -> add_cltype id decl env
+
+let rec add_signature sg env =
+  match sg with
+    [] -> env
+  | comp :: rem -> add_signature rem (add_item comp env)
+
+let enter_signature ~scope sg env =
+  let sg = Subst.signature (Rescope scope) Subst.identity sg in
+  sg, add_signature sg env
+
+(* Add "unbound" bindings *)
+
+let enter_unbound_value name reason env =
+  let id = Ident.create_local name in
+  { env with
+    values = IdTbl.add id (Val_unbound reason) env.values;
+    summary = Env_value_unbound(env.summary, name, reason) }
+
+let enter_unbound_module name reason env =
+  let id = Ident.create_local name in
+  { env with
+    modules = IdTbl.add id (Mod_unbound reason) env.modules;
+    summary = Env_module_unbound(env.summary, name, reason) }
+
+(* Open a signature path *)
+
+let add_components slot root env0 comps =
+  let add_l w comps env0 =
+    TycompTbl.add_open slot w root comps env0
+  in
+  let add w comps env0 = IdTbl.add_open slot w root comps env0 in
+  let add_types w comps env0 additions =
+    let types = add w comps env0 in
+    let additions = short_paths_type_open root comps additions in
+    types, additions
+  in
+  let add_cltypes w comps env0 additions =
+    let cltypes = add w comps env0 in
+    let additions = short_paths_class_type_open root comps additions in
+    cltypes, additions
+  in
+  let add_modtypes w comps env0 additions =
+    let modtypes = add w comps env0 in
+    let additions = short_paths_module_type_open root comps additions in
+    modtypes, additions
+  in
+  let add_modules w comps env0 additions =
+    let modules = add w comps env0 in
+    let additions = short_paths_module_open root comps additions in
+    modules, additions
+  in
+  let constrs =
+    add_l (fun x -> `Constructor x) comps.comp_constrs env0.constrs
+  in
+  let labels =
+    add_l (fun x -> `Label x) comps.comp_labels env0.labels
+  in
+  let values =
+    add (fun x -> `Value x) comps.comp_values env0.values
+  in
+  let types, additions =
+    add_types (fun x -> `Type x)
+      comps.comp_types env0.types env0.short_paths_additions
+  in
+  let modtypes, additions =
+    add_modtypes (fun x -> `Module_type x)
+      comps.comp_modtypes env0.modtypes additions
+  in
+  let classes =
+    add (fun x -> `Class x) comps.comp_classes env0.classes
+  in
+  let cltypes, additions =
+    add_cltypes (fun x -> `Class_type x)
+      comps.comp_cltypes env0.cltypes additions
+  in
+  let modules, additions =
+    add_modules (fun x -> `Module x)
+      comps.comp_modules env0.modules additions
+  in
+  { env0 with
+    summary = Env_open(env0.summary, root);
+    constrs;
+    labels;
+    values;
+    types;
+    modtypes;
+    classes;
+    cltypes;
+    modules;
+    short_paths_additions = additions
+  }
+
+let open_signature slot root env0 : (_,_) result =
+  match get_components_res (find_module_components root env0) with
+  | Error _ -> Error `Not_found
+  | exception Not_found -> Error `Not_found
+  | Ok (Functor_comps _) -> Error `Functor
+  | Ok (Structure_comps comps) ->
+    Ok (add_components slot root env0 comps)
+
+let remove_last_open root env0 =
+  let rec filter_summary summary =
+    match summary with
+      Env_empty -> raise Exit
+    | Env_open (s, p) ->
+        if Path.same p root then s else raise Exit
+    | Env_value _
+    | Env_type _
+    | Env_extension _
+    | Env_module _
+    | Env_modtype _
+    | Env_class _
+    | Env_cltype _
+    | Env_functor_arg _
+    | Env_constraints _
+    | Env_persistent _
+    | Env_copy_types _
+    | Env_value_unbound _
+    | Env_module_unbound _ ->
+        map_summary filter_summary summary
+  in
+  match filter_summary env0.summary with
+  | summary ->
+      let rem_l tbl = TycompTbl.remove_last_open root tbl
+      and rem tbl = IdTbl.remove_last_open root tbl in
+      Some { env0 with
+             summary;
+             constrs = rem_l env0.constrs;
+             labels = rem_l env0.labels;
+             values = rem env0.values;
+             types = rem env0.types;
+             modtypes = rem env0.modtypes;
+             classes = rem env0.classes;
+             cltypes = rem env0.cltypes;
+             modules = rem env0.modules; }
+  | exception Exit ->
+      None
+
+(* Open a signature from a file *)
+
+let open_pers_signature name env =
+  match open_signature None (Pident(Ident.create_persistent name)) env with
+  | (Ok _ | Error `Not_found as res) -> res
+  | Error `Functor -> assert false
+        (* a compilation unit cannot refer to a functor *)
+
+let open_signature
+    ?(used_slot = ref false)
+    ?(loc = Location.none) ?(toplevel = false)
+    ovf root env =
+  let unused root =
+    match ovf with
+    | Asttypes.Fresh -> Warnings.Unused_open (Path.name root)
+    | Asttypes.Override -> Warnings.Unused_open_bang (Path.name root)
+  in
+  let warn_unused =
+    Warnings.is_active (unused root)
+  and warn_shadow_id =
+    Warnings.is_active (Warnings.Open_shadow_identifier ("", ""))
+  and warn_shadow_lc =
+    Warnings.is_active (Warnings.Open_shadow_label_constructor ("",""))
+  in
+  if not toplevel && not loc.Location.loc_ghost
+     && (warn_unused || warn_shadow_id || warn_shadow_lc)
+  then begin
+    let used = used_slot in
+    if warn_unused then
+      !add_delayed_check_forward
+        (fun () ->
+           if not !used then begin
+             used := true;
+             Location.prerr_warning loc (unused (!shorten_module_path env root))
+           end
+        );
+    let shadowed = ref [] in
+    let slot s b =
+      begin match check_shadowing env b with
+      | Some kind when
+          ovf = Asttypes.Fresh && not (List.mem (kind, s) !shadowed) ->
+          shadowed := (kind, s) :: !shadowed;
+          let w =
+            match kind with
+            | "label" | "constructor" ->
+                Warnings.Open_shadow_label_constructor (kind, s)
+            | _ -> Warnings.Open_shadow_identifier (kind, s)
+          in
+          Location.prerr_warning loc w
+      | _ -> ()
+      end;
+      used := true
+    in
+    open_signature (Some slot) root env
+  end
+  else open_signature None root env
+
+(* Read a signature from a file *)
+let read_signature modname filename =
+  let mda = read_pers_mod modname filename in
+  let md = Lazy_backtrack.force subst_modtype_maker mda.mda_declaration in
+  match md.md_type with
+  | Mty_signature sg -> sg
+  | Mty_ident _ | Mty_functor _ | Mty_alias _ | Mty_for_hole -> assert false
+
+let is_identchar_latin1 = function
+  | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214' | '\216'..'\246'
+  | '\248'..'\255' | '\'' | '0'..'9' -> true
+  | _ -> false
+
+let unit_name_of_filename fn =
+  match Filename.extension fn with
+  | ".cmi" -> begin
+      let unit =
+        String.capitalize_ascii (Filename.remove_extension fn)
+      in
+      if Std.String.for_all is_identchar_latin1 unit then
+        Some unit
+      else
+        None
+    end
+  | _ -> None
+
+let persistent_structures_of_dir dir =
+  Load_path.Dir.files dir
+  |> List.to_seq
+  |> Seq.filter_map unit_name_of_filename
+  |> String.Set.of_seq
+
+(* Save a signature to a file *)
+let save_signature_with_transform cmi_transform ~alerts sg modname filename =
+  Btype.cleanup_abbrev ();
+  Subst.reset_for_saving ();
+  let sg = Subst.signature Make_local (Subst.for_saving Subst.identity) sg in
+  let cmi =
+    Persistent_env.make_cmi !persistent_env modname sg alerts
+    |> cmi_transform in
+  let pm = save_sign_of_cmi
+      { Persistent_env.Persistent_signature.cmi; filename } in
+  Persistent_env.save_cmi !persistent_env
+    { Persistent_env.Persistent_signature.filename; cmi } pm;
+  cmi
+
+let save_signature ~alerts sg modname filename =
+  save_signature_with_transform (fun cmi -> cmi)
+    ~alerts sg modname filename
+
+let save_signature_with_imports ~alerts sg modname filename imports =
+  let with_imports cmi = { cmi with cmi_crcs = imports } in
+  save_signature_with_transform with_imports
+    ~alerts sg modname filename
+
+(* Make the initial environment *)
+let (initial_safe_string, initial_unsafe_string) =
+  Predef.build_initial_env
+    (add_type ~check:false ~predef:true)
+    (add_extension ~check:false ~rebind:false)
+    empty
+
+let add_type ~check id info env =
+  add_type ~check ~predef:false id info env
+
+(* Tracking usage *)
+
+let mark_module_used uid =
+  match Types.Uid.Tbl.find !module_declarations uid with
+  | mark -> mark ()
+  | exception Not_found -> ()
+
+let mark_modtype_used _uid = ()
+
+let mark_value_used uid =
+  match Types.Uid.Tbl.find !value_declarations uid with
+  | mark -> mark ()
+  | exception Not_found -> ()
+
+let mark_type_used uid =
+  match Types.Uid.Tbl.find !type_declarations uid with
+  | mark -> mark ()
+  | exception Not_found -> ()
+
+let mark_type_path_used env path =
+  match find_type path env with
+  | decl -> mark_type_used decl.type_uid
+  | exception Not_found -> ()
+
+let mark_constructor_used usage cd =
+  match Types.Uid.Tbl.find !used_constructors cd.cd_uid with
+  | mark -> mark usage
+  | exception Not_found -> ()
+
+let mark_extension_used usage ext =
+  match Types.Uid.Tbl.find !used_constructors ext.ext_uid with
+  | mark -> mark usage
+  | exception Not_found -> ()
+
+let mark_label_used usage ld =
+  match Types.Uid.Tbl.find !used_labels ld.ld_uid with
+  | mark -> mark usage
+  | exception Not_found -> ()
+
+let mark_constructor_description_used usage env cstr =
+  let ty_path =
+    match repr cstr.cstr_res with
+    | {desc=Tconstr(path, _, _)} -> path
+    | _ -> assert false
+  in
+  mark_type_path_used env ty_path;
+  match Types.Uid.Tbl.find !used_constructors cstr.cstr_uid with
+  | mark -> mark usage
+  | exception Not_found -> ()
+
+let mark_label_description_used usage env lbl =
+  let ty_path =
+    match repr lbl.lbl_res with
+    | {desc=Tconstr(path, _, _)} -> path
+    | _ -> assert false
+  in
+  mark_type_path_used env ty_path;
+  match Types.Uid.Tbl.find !used_labels lbl.lbl_uid with
+  | mark -> mark usage
+  | exception Not_found -> ()
+
+let mark_class_used uid =
+  match Types.Uid.Tbl.find !type_declarations uid with
+  | mark -> mark ()
+  | exception Not_found -> ()
+
+let mark_cltype_used uid =
+  match Types.Uid.Tbl.find !type_declarations uid with
+  | mark -> mark ()
+  | exception Not_found -> ()
+
+let set_value_used_callback vd callback =
+  Types.Uid.Tbl.add !value_declarations vd.val_uid callback
+
+let set_type_used_callback td callback =
+  if Uid.for_actual_declaration td.type_uid then
+    let old =
+      try Types.Uid.Tbl.find !type_declarations td.type_uid
+      with Not_found -> ignore
+    in
+    Types.Uid.Tbl.replace !type_declarations td.type_uid (fun () -> callback old)
+
+(* Lookup by name *)
+
+let may_lookup_error report_errors loc env err =
+  if report_errors then lookup_error loc env err
+  else raise Not_found
+
+let report_module_unbound ~errors ~loc env reason =
+  match reason with
+  | Mod_unbound_illegal_recursion ->
+      (* see #5965 *)
+    may_lookup_error errors loc env Illegal_reference_to_recursive_module
+
+let report_value_unbound ~errors ~loc env reason lid =
+  match reason with
+  | Val_unbound_instance_variable ->
+      may_lookup_error errors loc env (Masked_instance_variable lid)
+  | Val_unbound_self ->
+      may_lookup_error errors loc env (Masked_self_variable lid)
+  | Val_unbound_ancestor ->
+      may_lookup_error errors loc env (Masked_ancestor_variable lid)
+  | Val_unbound_ghost_recursive rloc ->
+      let show_hint =
+        (* Only display the "missing rec" hint for non-ghost code *)
+        not loc.Location.loc_ghost
+        && not rloc.Location.loc_ghost
+      in
+      let hint =
+        if show_hint then Missing_rec rloc else No_hint
+      in
+      may_lookup_error errors loc env (Unbound_value(lid, hint))
+
+let use_module ~use ~loc path mda =
+  if use then begin
+    let comps = mda.mda_components in
+    mark_module_used comps.uid;
+    Misc.String.Map.iter
+      (fun kind message ->
+         let message = if message = "" then "" else "\n" ^ message in
+         Location.alert ~kind loc
+           (Printf.sprintf "module %s%s" (Path.name path) message)
+      )
+      comps.alerts
+  end
+
+let use_value ~use ~loc path vda =
+  if use then begin
+    let desc = vda.vda_description in
+    mark_value_used desc.val_uid;
+    Builtin_attributes.check_alerts loc desc.val_attributes
+      (Path.name path)
+  end
+
+let use_type ~use ~loc path tda =
+  if use then begin
+    let decl = tda.tda_declaration in
+    mark_type_used decl.type_uid;
+    Builtin_attributes.check_alerts loc decl.type_attributes
+      (Path.name path)
+  end
+
+let use_modtype ~use ~loc path desc =
+  if use then begin
+    mark_modtype_used desc.mtd_uid;
+    Builtin_attributes.check_alerts loc desc.mtd_attributes
+      (Path.name path)
+  end
+
+let use_class ~use ~loc path clda =
+  if use then begin
+    let desc = clda.clda_declaration in
+    mark_class_used desc.cty_uid;
+    Builtin_attributes.check_alerts loc desc.cty_attributes
+      (Path.name path)
+  end
+
+let use_cltype ~use ~loc path desc =
+  if use then begin
+    mark_cltype_used desc.clty_uid;
+    Builtin_attributes.check_alerts loc desc.clty_attributes
+      (Path.name path)
+  end
+
+let use_label ~use ~loc usage env lbl =
+  if use then begin
+    mark_label_description_used usage env lbl;
+    Builtin_attributes.check_alerts loc lbl.lbl_attributes lbl.lbl_name
+  end
+
+let use_constructor_desc ~use ~loc usage env cstr =
+  if use then begin
+    mark_constructor_description_used usage env cstr;
+    Builtin_attributes.check_alerts loc cstr.cstr_attributes cstr.cstr_name
+  end
+
+let use_constructor ~use ~loc usage env cda =
+  use_constructor_desc ~use ~loc usage env cda.cda_description
+
+type _ load =
+  | Load : module_data load
+  | Don't_load : unit load
+
+let lookup_ident_module (type a) (load : a load) ~errors ~use ~loc s env =
+  let path, data =
+    match find_name_module ~mark:use s env.modules with
+    | res -> res
+    | exception Not_found ->
+        may_lookup_error errors loc env (Unbound_module (Lident s))
+  in
+  match data with
+  | Mod_local mda -> begin
+      use_module ~use ~loc path mda;
+      match load with
+      | Load -> path, (mda : a)
+      | Don't_load -> path, (() : a)
+    end
+  | Mod_unbound reason ->
+      report_module_unbound ~errors ~loc env reason
+  | Mod_persistent -> begin
+      match load with
+      | Don't_load ->
+          check_pers_mod ~loc s;
+          path, (() : a)
+      | Load -> begin
+          match find_pers_mod s with
+          | mda ->
+              use_module ~use ~loc path mda;
+              path, (mda : a)
+          | exception Not_found ->
+              may_lookup_error errors loc env (Unbound_module (Lident s))
+        end
+    end
+
+let lookup_ident_value ~errors ~use ~loc name env =
+  match IdTbl.find_name wrap_value ~mark:use name env.values with
+  | (path, Val_bound vda) ->
+      use_value ~use ~loc path vda;
+      path, vda.vda_description
+  | (_, Val_unbound reason) ->
+      report_value_unbound ~errors ~loc env reason (Lident name)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_value (Lident name, No_hint))
+
+let lookup_ident_type ~errors ~use ~loc s env =
+  match IdTbl.find_name wrap_identity ~mark:use s env.types with
+  | (path, data) as res ->
+      use_type ~use ~loc path data;
+      res
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_type (Lident s))
+
+let lookup_ident_modtype ~errors ~use ~loc s env =
+  match IdTbl.find_name wrap_identity ~mark:use s env.modtypes with
+  | (path, data) as res ->
+      use_modtype ~use ~loc path data;
+      res
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_modtype (Lident s))
+
+let lookup_ident_class ~errors ~use ~loc s env =
+  match IdTbl.find_name wrap_identity ~mark:use s env.classes with
+  | (path, clda) ->
+      use_class ~use ~loc path clda;
+      path, clda.clda_declaration
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_class (Lident s))
+
+let lookup_ident_cltype ~errors ~use ~loc s env =
+  match IdTbl.find_name wrap_identity ~mark:use s env.cltypes with
+  | (path, data) as res ->
+      use_cltype ~use ~loc path data;
+      res
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_cltype (Lident s))
+
+let lookup_all_ident_labels ~errors ~use ~loc usage s env =
+  match TycompTbl.find_all ~mark:use s env.labels with
+  | [] -> may_lookup_error errors loc env (Unbound_label (Lident s))
+  | lbls -> begin
+      List.map
+        (fun (lbl, use_fn) ->
+           let use_fn () =
+             use_label ~use ~loc usage env lbl;
+             use_fn ()
+           in
+           (lbl, use_fn))
+        lbls
+    end
+
+let lookup_all_ident_constructors ~errors ~use ~loc usage s env =
+  match TycompTbl.find_all ~mark:use s env.constrs with
+  | [] -> may_lookup_error errors loc env (Unbound_constructor (Lident s))
+  | cstrs ->
+      List.map
+        (fun (cda, use_fn) ->
+           let use_fn () =
+             use_constructor ~use ~loc usage env cda;
+             use_fn ()
+           in
+           (cda.cda_description, use_fn))
+        cstrs
+
+let rec lookup_module_components ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s ->
+      let path, data = lookup_ident_module Load ~errors ~use ~loc s env in
+      path, data.mda_components
+  | Ldot(l, s) ->
+      let path, data = lookup_dot_module ~errors ~use ~loc l s env in
+      path, data.mda_components
+  | Lapply _ as lid ->
+      let f_path, f_comp, arg = lookup_apply ~errors ~use ~loc lid env in
+      let comps =
+        !components_of_functor_appl' ~loc ~f_path ~f_comp ~arg env in
+      Papply (f_path, arg), comps
+
+and lookup_structure_components ~errors ~use ~loc lid env =
+  let path, comps = lookup_module_components ~errors ~use ~loc lid env in
+  match get_components_res comps with
+  | Ok (Structure_comps comps) -> path, comps
+  | Ok (Functor_comps _) ->
+      may_lookup_error errors loc env (Functor_used_as_structure lid)
+  | Error No_components_abstract ->
+      may_lookup_error errors loc env (Abstract_used_as_structure lid)
+  | Error (No_components_alias p) ->
+      may_lookup_error errors loc env (Cannot_scrape_alias(lid, p))
+
+and get_functor_components ~errors ~loc lid env comps =
+  match get_components_res comps with
+  | Ok (Functor_comps fcomps) -> begin
+      match fcomps.fcomp_arg with
+      | Unit -> (* PR#7611 *)
+          may_lookup_error errors loc env (Generative_used_as_applicative lid)
+      | Named (_, arg) -> fcomps, arg
+    end
+  | Ok (Structure_comps _) ->
+      may_lookup_error errors loc env (Structure_used_as_functor lid)
+  | Error No_components_abstract ->
+      may_lookup_error errors loc env (Abstract_used_as_functor lid)
+  | Error (No_components_alias p) ->
+      may_lookup_error errors loc env (Cannot_scrape_alias(lid, p))
+
+and lookup_all_args ~errors ~use ~loc lid0 env =
+  let rec loop_lid_arg args = function
+    | Lident _ | Ldot _ as f_lid ->
+        (f_lid, args)
+    | Lapply (f_lid, arg_lid) ->
+        let arg_path, arg_md = lookup_module ~errors ~use ~loc arg_lid env in
+        loop_lid_arg ((f_lid,arg_path,arg_md.md_type)::args) f_lid
+  in
+  loop_lid_arg [] lid0
+
+and lookup_apply ~errors ~use ~loc lid0 env =
+  let f0_lid, args0 = lookup_all_args ~errors ~use ~loc lid0 env in
+  let args_for_errors = List.map (fun (_,p,mty) -> (p,mty)) args0 in
+  let f0_path, f0_comp =
+    lookup_module_components ~errors ~use ~loc f0_lid env
+  in
+  let check_one_apply ~errors ~loc ~f_lid ~f_comp ~arg_path ~arg_mty env =
+    let f_comp, param_mty =
+      get_functor_components ~errors ~loc f_lid env f_comp
+    in
+    check_functor_appl
+      ~errors ~loc ~lid_whole_app:lid0
+      ~f0_path ~args:args_for_errors ~f_comp
+      ~arg_path ~arg_mty ~param_mty
+      env;
+    arg_path, f_comp
+  in
+  let rec check_apply ~path:f_path ~comp:f_comp = function
+    | [] -> invalid_arg "Env.lookup_apply: empty argument list"
+    | [ f_lid, arg_path, arg_mty ] ->
+        let arg_path, comps =
+          check_one_apply ~errors ~loc ~f_lid ~f_comp
+            ~arg_path ~arg_mty env
+        in
+        f_path, comps, arg_path
+    | (f_lid, arg_path, arg_mty) :: args ->
+        let arg_path, f_comp =
+          check_one_apply ~errors ~loc ~f_lid ~f_comp
+            ~arg_path ~arg_mty env
+        in
+        let comp =
+          !components_of_functor_appl' ~loc ~f_path ~f_comp ~arg:arg_path env
+        in
+        let path = Papply (f_path, arg_path) in
+        check_apply ~path ~comp args
+  in
+  check_apply ~path:f0_path ~comp:f0_comp args0
+
+and lookup_module ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s ->
+      let path, data = lookup_ident_module Load ~errors ~use ~loc s env in
+      let md = Lazy_backtrack.force subst_modtype_maker data.mda_declaration in
+      path, md
+  | Ldot(l, s) ->
+      let path, data = lookup_dot_module ~errors ~use ~loc l s env in
+      let md = Lazy_backtrack.force subst_modtype_maker data.mda_declaration in
+      path, md
+  | Lapply _ as lid ->
+      let path_f, comp_f, path_arg = lookup_apply ~errors ~use ~loc lid env in
+      let md = md (modtype_of_functor_appl comp_f path_f path_arg) in
+      Papply(path_f, path_arg), md
+
+and lookup_dot_module ~errors ~use ~loc l s env =
+  let p, comps = lookup_structure_components ~errors ~use ~loc l env in
+  match NameMap.find s comps.comp_modules with
+  | mda ->
+      let path = Pdot(p, s) in
+      use_module ~use ~loc path mda;
+      (path, mda)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_module (Ldot(l, s)))
+
+let lookup_dot_value ~errors ~use ~loc l s env =
+  let (path, comps) =
+    lookup_structure_components ~errors ~use ~loc l env
+  in
+  match NameMap.find s comps.comp_values with
+  | vda ->
+      let path = Pdot(path, s) in
+      use_value ~use ~loc path vda;
+      (path, vda.vda_description)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_value (Ldot(l, s), No_hint))
+
+let lookup_dot_type ~errors ~use ~loc l s env =
+  let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in
+  match NameMap.find s comps.comp_types with
+  | tda ->
+      let path = Pdot(p, s) in
+      use_type ~use ~loc path tda;
+      (path, tda)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_type (Ldot(l, s)))
+
+let lookup_dot_modtype ~errors ~use ~loc l s env =
+  let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in
+  match NameMap.find s comps.comp_modtypes with
+  | desc ->
+      let path = Pdot(p, s) in
+      use_modtype ~use ~loc path desc;
+      (path, desc)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_modtype (Ldot(l, s)))
+
+let lookup_dot_class ~errors ~use ~loc l s env =
+  let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in
+  match NameMap.find s comps.comp_classes with
+  | clda ->
+      let path = Pdot(p, s) in
+      use_class ~use ~loc path clda;
+      (path, clda.clda_declaration)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_class (Ldot(l, s)))
+
+let lookup_dot_cltype ~errors ~use ~loc l s env =
+  let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in
+  match NameMap.find s comps.comp_cltypes with
+  | desc ->
+      let path = Pdot(p, s) in
+      use_cltype ~use ~loc path desc;
+      (path, desc)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_cltype (Ldot(l, s)))
+
+let lookup_all_dot_labels ~errors ~use ~loc usage l s env =
+  let (_, comps) = lookup_structure_components ~errors ~use ~loc l env in
+  match NameMap.find s comps.comp_labels with
+  | [] | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_label (Ldot(l, s)))
+  | lbls ->
+      List.map
+        (fun lbl ->
+           let use_fun () = use_label ~use ~loc usage env lbl in
+           (lbl, use_fun))
+        lbls
+
+let lookup_all_dot_constructors ~errors ~use ~loc usage l s env =
+  match l with
+  | Longident.Lident "*predef*" ->
+      (* Hack to support compilation of default arguments *)
+      lookup_all_ident_constructors
+        ~errors ~use ~loc usage s initial_safe_string
+  | _ ->
+      let (_, comps) = lookup_structure_components ~errors ~use ~loc l env in
+      match NameMap.find s comps.comp_constrs with
+      | [] | exception Not_found ->
+          may_lookup_error errors loc env (Unbound_constructor (Ldot(l, s)))
+      | cstrs ->
+          List.map
+            (fun cda ->
+               let use_fun () = use_constructor ~use ~loc usage env cda in
+               (cda.cda_description, use_fun))
+            cstrs
+
+(* General forms of the lookup functions *)
+
+let lookup_module_path ~errors ~use ~loc ~load lid env : Path.t =
+  match lid with
+  | Lident s ->
+      if !Clflags.transparent_modules && not load then
+        fst (lookup_ident_module Don't_load ~errors ~use ~loc s env)
+      else
+        fst (lookup_ident_module Load ~errors ~use ~loc s env)
+  | Ldot(l, s) -> fst (lookup_dot_module ~errors ~use ~loc l s env)
+  | Lapply _ as lid ->
+      let path_f, _comp_f, path_arg = lookup_apply ~errors ~use ~loc lid env in
+      Papply(path_f, path_arg)
+
+let lookup_value ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s -> lookup_ident_value ~errors ~use ~loc s env
+  | Ldot(l, s) -> lookup_dot_value ~errors ~use ~loc l s env
+  | Lapply _ -> assert false
+
+let lookup_type_full ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s -> lookup_ident_type ~errors ~use ~loc s env
+  | Ldot(l, s) -> lookup_dot_type ~errors ~use ~loc l s env
+  | Lapply _ -> assert false
+
+let lookup_type ~errors ~use ~loc lid env =
+  let (path, tda) = lookup_type_full ~errors ~use ~loc lid env in
+  path, tda.tda_declaration
+
+let lookup_modtype ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s -> lookup_ident_modtype ~errors ~use ~loc s env
+  | Ldot(l, s) -> lookup_dot_modtype ~errors ~use ~loc l s env
+  | Lapply _ -> assert false
+
+let lookup_class ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s -> lookup_ident_class ~errors ~use ~loc s env
+  | Ldot(l, s) -> lookup_dot_class ~errors ~use ~loc l s env
+  | Lapply _ -> assert false
+
+let lookup_cltype ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s -> lookup_ident_cltype ~errors ~use ~loc s env
+  | Ldot(l, s) -> lookup_dot_cltype ~errors ~use ~loc l s env
+  | Lapply _ -> assert false
+
+let lookup_all_labels ~errors ~use ~loc usage lid env =
+  match lid with
+  | Lident s -> lookup_all_ident_labels ~errors ~use ~loc usage s env
+  | Ldot(l, s) -> lookup_all_dot_labels ~errors ~use ~loc usage l s env
+  | Lapply _ -> assert false
+
+let lookup_label ~errors ~use ~loc usage lid env =
+  match lookup_all_labels ~errors ~use ~loc usage lid env with
+  | [] -> assert false
+  | (desc, use) :: _ -> use (); desc
+
+let lookup_all_labels_from_type ~use ~loc usage ty_path env =
+  match find_type_descrs ty_path env with
+  | exception Not_found -> []
+  | Type_variant _ | Type_abstract | Type_open -> []
+  | Type_record (lbls, _) ->
+      List.map
+        (fun lbl ->
+           let use_fun () = use_label ~use ~loc usage env lbl in
+           (lbl, use_fun))
+        lbls
+
+let lookup_all_constructors ~errors ~use ~loc usage lid env =
+  match lid with
+  | Lident s -> lookup_all_ident_constructors ~errors ~use ~loc usage s env
+  | Ldot(l, s) -> lookup_all_dot_constructors ~errors ~use ~loc usage l s env
+  | Lapply _ -> assert false
+
+let lookup_constructor ~errors ~use ~loc usage lid env =
+  match lookup_all_constructors ~errors ~use ~loc usage lid env with
+  | [] -> assert false
+  | (desc, use) :: _ -> use (); desc
+
+let lookup_all_constructors_from_type ~use ~loc usage ty_path env =
+  match find_type_descrs ty_path env with
+  | exception Not_found -> []
+  | Type_record _ | Type_abstract | Type_open -> []
+  | Type_variant (cstrs, _) ->
+      List.map
+        (fun cstr ->
+           let use_fun () =
+             use_constructor_desc ~use ~loc usage env cstr
+           in
+           (cstr, use_fun))
+        cstrs
+
+(* Lookup functions that do not mark the item as used or
+   warn if it has alerts, and raise [Not_found] rather
+   than report errors *)
+
+let find_module_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_module ~errors:false ~use:false ~loc lid env
+
+let find_value_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_value ~errors:false ~use:false ~loc lid env
+
+let find_type_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_type ~errors:false ~use:false ~loc lid env
+
+let find_modtype_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_modtype ~errors:false ~use:false ~loc lid env
+
+let find_class_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_class ~errors:false ~use:false ~loc lid env
+
+let find_cltype_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_cltype ~errors:false ~use:false ~loc lid env
+
+let find_constructor_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_constructor ~errors:false ~use:false ~loc Positive lid env
+
+let find_label_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_label ~errors:false ~use:false ~loc Projection lid env
+
+(* Ordinary lookup functions *)
+
+let lookup_module_path ?(use=true) ~loc ~load lid env =
+  lookup_module_path ~errors:true ~use ~loc ~load lid env
+
+let lookup_module ?(use=true) ~loc lid env =
+  lookup_module ~errors:true ~use ~loc lid env
+
+let lookup_value ?(use=true) ~loc lid env =
+  check_value_name (Longident.last lid) loc;
+  lookup_value ~errors:true ~use ~loc lid env
+
+let lookup_type ?(use=true) ~loc lid env =
+  lookup_type ~errors:true ~use ~loc lid env
+
+let lookup_modtype ?(use=true) ~loc lid env =
+  lookup_modtype ~errors:true ~use ~loc lid env
+
+let lookup_class ?(use=true) ~loc lid env =
+  lookup_class ~errors:true ~use ~loc lid env
+
+let lookup_cltype ?(use=true) ~loc lid env =
+  lookup_cltype ~errors:true ~use ~loc lid env
+
+let lookup_all_constructors ?(use=true) ~loc usage lid env =
+  match lookup_all_constructors ~errors:true ~use ~loc usage lid env with
+  | exception Error(Lookup_error(loc', env', err)) ->
+      (Error(loc', env', err) : _ result)
+  | cstrs -> Ok cstrs
+
+let lookup_constructor ?(use=true) ~loc lid env =
+  lookup_constructor ~errors:true ~use ~loc lid env
+
+let lookup_all_constructors_from_type ?(use=true) ~loc usage ty_path env =
+  lookup_all_constructors_from_type ~use ~loc usage ty_path env
+
+let lookup_all_labels ?(use=true) ~loc usage lid env =
+  match lookup_all_labels ~errors:true ~use ~loc usage lid env with
+  | exception Error(Lookup_error(loc', env', err)) ->
+      (Error(loc', env', err) : _ result)
+  | lbls -> Ok lbls
+
+let lookup_label ?(use=true) ~loc lid env =
+  lookup_label ~errors:true ~use ~loc lid env
+
+let lookup_all_labels_from_type ?(use=true) ~loc usage ty_path env =
+  lookup_all_labels_from_type ~use ~loc usage ty_path env
+
+let lookup_instance_variable ?(use=true) ~loc name env =
+  match IdTbl.find_name wrap_value ~mark:use name env.values with
+  | (path, Val_bound vda) -> begin
+      let desc = vda.vda_description in
+      match desc.val_kind with
+      | Val_ivar(mut, cl_num) ->
+          use_value ~use ~loc path vda;
+          path, mut, cl_num, desc.val_type
+      | _ ->
+          lookup_error loc env (Not_an_instance_variable name)
+    end
+  | (_, Val_unbound Val_unbound_instance_variable) ->
+      lookup_error loc env (Masked_instance_variable (Lident name))
+  | (_, Val_unbound Val_unbound_self) ->
+      lookup_error loc env (Not_an_instance_variable name)
+  | (_, Val_unbound Val_unbound_ancestor) ->
+      lookup_error loc env (Not_an_instance_variable name)
+  | (_, Val_unbound Val_unbound_ghost_recursive _) ->
+      lookup_error loc env (Unbound_instance_variable name)
+  | exception Not_found ->
+      lookup_error loc env (Unbound_instance_variable name)
+
+(* Checking if a name is bound *)
+
+let bound_module name env =
+  match IdTbl.find_name wrap_module ~mark:false name env.modules with
+  | _ -> true
+  | exception Not_found ->
+      if Current_unit_name.is name then false
+      else begin
+        match find_pers_mod name with
+        | _ -> true
+        | exception Not_found -> false
+      end
+
+let bound wrap proj name env =
+  match IdTbl.find_name wrap ~mark:false name (proj env) with
+  | _ -> true
+  | exception Not_found -> false
+
+let bound_value name env =
+  bound wrap_value (fun env -> env.values) name env
+
+let bound_type name env =
+  bound wrap_identity (fun env -> env.types) name env
+
+let bound_modtype name env =
+  bound wrap_identity (fun env -> env.modtypes) name env
+
+let bound_class name env =
+  bound wrap_identity (fun env -> env.classes) name env
+
+let bound_cltype name env =
+  bound wrap_identity (fun env -> env.cltypes) name env
+
+(* Folding on environments *)
+
+let find_all wrap proj1 proj2 f lid env acc =
+  match lid with
+  | None ->
+      IdTbl.fold_name wrap
+        (fun name (p, data) acc -> f name p data acc)
+        (proj1 env) acc
+  | Some l ->
+      let p, desc =
+        lookup_module_components
+          ~errors:false ~use:false ~loc:Location.none l env
+      in
+      begin match get_components desc with
+      | Structure_comps c ->
+          NameMap.fold
+            (fun s data acc -> f s (Pdot (p, s)) (wrap data) acc)
+            (proj2 c) acc
+      | Functor_comps _ ->
+          acc
+      end
+
+let find_all_simple_list proj1 proj2 f lid env acc =
+  match lid with
+  | None ->
+      TycompTbl.fold_name
+        (fun data acc -> f data acc)
+        (proj1 env) acc
+  | Some l ->
+      let (_p, desc) =
+        lookup_module_components
+          ~errors:false ~use:false ~loc:Location.none l env
+      in
+      begin match get_components desc with
+      | Structure_comps c ->
+          NameMap.fold
+            (fun _s comps acc ->
+               match comps with
+               | [] -> acc
+               | data :: _ -> f data acc)
+            (proj2 c) acc
+      | Functor_comps _ ->
+          acc
+      end
+
+let fold_modules f lid env acc =
+  match lid with
+  | None ->
+      IdTbl.fold_name wrap_module
+        (fun name (p, entry) acc ->
+           match entry with
+           | Mod_unbound _ -> acc
+           | Mod_local mda ->
+               let md =
+                 Lazy_backtrack.force subst_modtype_maker mda.mda_declaration
+               in
+               f name p md acc
+           | Mod_persistent ->
+               match Persistent_env.find_in_cache !persistent_env name with
+               | None -> acc
+               | Some mda ->
+                   let md =
+                     Lazy_backtrack.force subst_modtype_maker
+                       mda.mda_declaration
+                   in
+                   f name p md acc)
+        env.modules
+        acc
+  | Some l ->
+      let p, desc =
+        lookup_module_components
+          ~errors:false ~use:false ~loc:Location.none l env
+      in
+      begin match get_components desc with
+      | Structure_comps c ->
+          NameMap.fold
+            (fun s mda acc ->
+               let md =
+                 Lazy_backtrack.force subst_modtype_maker mda.mda_declaration
+               in
+               f s (Pdot (p, s)) md acc)
+            c.comp_modules
+            acc
+      | Functor_comps _ ->
+          acc
+      end
+
+let fold_values f =
+  find_all wrap_value (fun env -> env.values) (fun sc -> sc.comp_values)
+    (fun k p ve acc ->
+       match ve with
+       | Val_unbound _ -> acc
+       | Val_bound vda -> f k p vda.vda_description acc)
+and fold_constructors f =
+  find_all_simple_list (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
+    (fun cda acc -> f cda.cda_description acc)
+and fold_labels f =
+  find_all_simple_list (fun env -> env.labels) (fun sc -> sc.comp_labels) f
+and fold_types f =
+  find_all wrap_identity
+    (fun env -> env.types) (fun sc -> sc.comp_types)
+    (fun k p tda acc -> f k p tda.tda_declaration acc)
+and fold_modtypes f =
+  find_all wrap_identity
+    (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) f
+and fold_classes f =
+  find_all wrap_identity (fun env -> env.classes) (fun sc -> sc.comp_classes)
+    (fun k p clda acc -> f k p clda.clda_declaration acc)
+and fold_cltypes f =
+  find_all wrap_identity
+    (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) f
+
+let filter_non_loaded_persistent f env =
+  let to_remove =
+    IdTbl.fold_name wrap_module
+      (fun name (_, entry) acc ->
+         match entry with
+         | Mod_local _ -> acc
+         | Mod_unbound _ -> acc
+         | Mod_persistent ->
+             match Persistent_env.find_in_cache !persistent_env name with
+             | Some _ -> acc
+             | None ->
+                 if f (Ident.create_persistent name) then
+                   acc
+                 else
+                   String.Set.add name acc)
+      env.modules
+      String.Set.empty
+  in
+  let remove_ids tbl ids =
+    String.Set.fold
+      (fun name tbl -> IdTbl.remove (Ident.create_persistent name) tbl)
+      ids
+      tbl
+  in
+  let rec filter_summary summary ids =
+    if String.Set.is_empty ids then
+      summary
+    else
+      match summary with
+        Env_persistent (s, id) when String.Set.mem (Ident.name id) ids ->
+          filter_summary s (String.Set.remove (Ident.name id) ids)
+      | Env_empty
+      | Env_value _
+      | Env_type _
+      | Env_extension _
+      | Env_module _
+      | Env_modtype _
+      | Env_class _
+      | Env_cltype _
+      | Env_open _
+      | Env_functor_arg _
+      | Env_constraints _
+      | Env_copy_types _
+      | Env_persistent _
+      | Env_value_unbound _
+      | Env_module_unbound _ ->
+          map_summary (fun s -> filter_summary s ids) summary
+  in
+  { env with
+    modules = remove_ids env.modules to_remove;
+    summary = filter_summary env.summary to_remove;
+  }
+
+(* Return the environment summary *)
+
+let summary env =
+  if Path.Map.is_empty env.local_constraints then env.summary
+  else Env_constraints (env.summary, env.local_constraints)
+
+let last_env = s_ref empty
+let last_reduced_env = s_ref empty
+
+let keep_only_summary env =
+  if !last_env == env then !last_reduced_env
+  else begin
+    let new_env =
+      {
+       empty with
+       summary = env.summary;
+       local_constraints = env.local_constraints;
+       flags = env.flags;
+      }
+    in
+    last_env := env;
+    last_reduced_env := new_env;
+    new_env
+  end
+
+
+let env_of_only_summary env_from_summary env =
+  let new_env = env_from_summary env.summary Subst.identity in
+  { new_env with
+    local_constraints = env.local_constraints;
+    flags = env.flags;
+  }
+
+(* Error report *)
+
+open Format
+
+(* Forward declarations *)
+
+let print_longident =
+  ref ((fun _ _ -> assert false) : formatter -> Longident.t -> unit)
+
+let print_path =
+  ref ((fun _ _ -> assert false) : formatter -> Path.t -> unit)
+
+let spellcheck ppf extract env lid =
+  let choices ~path name = Misc.spellcheck (extract path env) name in
+  match lid with
+    | Longident.Lapply _ -> ()
+    | Longident.Lident s ->
+       Misc.did_you_mean ppf (fun () -> choices ~path:None s)
+    | Longident.Ldot (r, s) ->
+       Misc.did_you_mean ppf (fun () -> choices ~path:(Some r) s)
+
+let spellcheck_name ppf extract env name =
+  Misc.did_you_mean ppf
+    (fun () -> Misc.spellcheck (extract env) name)
+
+let extract_values path env =
+  fold_values (fun name _ _ acc -> name :: acc) path env []
+let extract_types path env =
+  fold_types (fun name _ _ acc -> name :: acc) path env []
+let extract_modules path env =
+  fold_modules (fun name _ _ acc -> name :: acc) path env []
+let extract_constructors path env =
+  fold_constructors (fun desc acc -> desc.cstr_name :: acc) path env []
+let extract_labels path env =
+  fold_labels (fun desc acc -> desc.lbl_name :: acc) path env []
+let extract_classes path env =
+  fold_classes (fun name _ _ acc -> name :: acc) path env []
+let extract_modtypes path env =
+  fold_modtypes (fun name _ _ acc -> name :: acc) path env []
+let extract_cltypes path env =
+  fold_cltypes (fun name _ _ acc -> name :: acc) path env []
+let extract_instance_variables env =
+  fold_values
+    (fun name _ descr acc ->
+       match descr.val_kind with
+       | Val_ivar _ -> name :: acc
+       | _ -> acc) None env []
+
+let report_lookup_error _loc env ppf = function
+  | Unbound_value(lid, hint) -> begin
+      fprintf ppf "Unbound value %a" !print_longident lid;
+      spellcheck ppf extract_values env lid;
+      match hint with
+      | No_hint -> ()
+      | Missing_rec def_loc ->
+          let (_, line, _) =
+            Location.get_pos_info def_loc.Location.loc_start
+          in
+          fprintf ppf
+            "@.@[%s@ %s %i@]"
+            "Hint: If this is a recursive definition,"
+            "you should add the 'rec' keyword on line"
+            line
+    end
+  | Unbound_type lid ->
+      fprintf ppf "Unbound type constructor %a" !print_longident lid;
+      spellcheck ppf extract_types env lid;
+  | Unbound_module lid -> begin
+      fprintf ppf "Unbound module %a" !print_longident lid;
+      match find_modtype_by_name lid env with
+      | exception Not_found -> spellcheck ppf extract_modules env lid;
+      | _ ->
+         fprintf ppf
+           "@.@[%s %a, %s@]"
+           "Hint: There is a module type named"
+           !print_longident lid
+           "but module types are not modules"
+    end
+  | Unbound_constructor lid ->
+      fprintf ppf "Unbound constructor %a" !print_longident lid;
+      spellcheck ppf extract_constructors env lid;
+  | Unbound_label lid ->
+      fprintf ppf "Unbound record field %a" !print_longident lid;
+      spellcheck ppf extract_labels env lid;
+  | Unbound_class lid -> begin
+      fprintf ppf "Unbound class %a" !print_longident lid;
+      match find_cltype_by_name lid env with
+      | exception Not_found -> spellcheck ppf extract_classes env lid;
+      | _ ->
+         fprintf ppf
+           "@.@[%s %a, %s@]"
+           "Hint: There is a class type named"
+           !print_longident lid
+           "but classes are not class types"
+    end
+  | Unbound_modtype lid -> begin
+      fprintf ppf "Unbound module type %a" !print_longident lid;
+      match find_module_by_name lid env with
+      | exception Not_found -> spellcheck ppf extract_modtypes env lid;
+      | _ ->
+         fprintf ppf
+           "@.@[%s %a, %s@]"
+           "Hint: There is a module named"
+           !print_longident lid
+           "but modules are not module types"
+    end
+  | Unbound_cltype lid ->
+      fprintf ppf "Unbound class type %a" !print_longident lid;
+      spellcheck ppf extract_cltypes env lid;
+  | Unbound_instance_variable s ->
+      fprintf ppf "Unbound instance variable %s" s;
+      spellcheck_name ppf extract_instance_variables env s;
+  | Not_an_instance_variable s ->
+      fprintf ppf "The value %s is not an instance variable" s;
+      spellcheck_name ppf extract_instance_variables env s;
+  | Masked_instance_variable lid ->
+      fprintf ppf
+        "The instance variable %a@ \
+         cannot be accessed from the definition of another instance variable"
+        !print_longident lid
+  | Masked_self_variable lid ->
+      fprintf ppf
+        "The self variable %a@ \
+         cannot be accessed from the definition of an instance variable"
+        !print_longident lid
+  | Masked_ancestor_variable lid ->
+      fprintf ppf
+        "The ancestor variable %a@ \
+         cannot be accessed from the definition of an instance variable"
+        !print_longident lid
+  | Illegal_reference_to_recursive_module ->
+     fprintf ppf "Illegal recursive module reference"
+  | Structure_used_as_functor lid ->
+      fprintf ppf "@[The module %a is a structure, it cannot be applied@]"
+        !print_longident lid
+  | Abstract_used_as_functor lid ->
+      fprintf ppf "@[The module %a is abstract, it cannot be applied@]"
+        !print_longident lid
+  | Functor_used_as_structure lid ->
+      fprintf ppf "@[The module %a is a functor, \
+                   it cannot have any components@]" !print_longident lid
+  | Abstract_used_as_structure lid ->
+      fprintf ppf "@[The module %a is abstract, \
+                   it cannot have any components@]" !print_longident lid
+  | Generative_used_as_applicative lid ->
+      fprintf ppf "@[The functor %a is generative,@ it@ cannot@ be@ \
+                   applied@ in@ type@ expressions@]" !print_longident lid
+  | Cannot_scrape_alias(lid, p) ->
+      let cause =
+        if Current_unit_name.is_path p then "is the current compilation unit"
+        else "is missing"
+      in
+      fprintf ppf
+        "The module %a is an alias for module %a, which %s"
+        !print_longident lid !print_path p cause
+
+let report_error ppf = function
+  | Missing_module(_, path1, path2) ->
+      fprintf ppf "@[@[<hov>";
+      if Path.same path1 path2 then
+        fprintf ppf "Internal path@ %s@ is dangling." (Path.name path1)
+      else
+        fprintf ppf "Internal path@ %s@ expands to@ %s@ which is dangling."
+          (Path.name path1) (Path.name path2);
+      fprintf ppf "@]@ @[%s@ %s@ %s.@]@]"
+        "The compiled interface for module" (Ident.name (Path.head path2))
+        "was not found"
+  | Illegal_value_name(_loc, name) ->
+      fprintf ppf "'%s' is not a valid value identifier."
+        name
+  | Lookup_error(loc, t, err) -> report_lookup_error loc t ppf err
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err ->
+          let loc =
+            match err with
+            | Missing_module (loc, _, _)
+            | Illegal_value_name (loc, _)
+            | Lookup_error(loc, _, _) -> loc
+          in
+          let error_of_printer =
+            if loc = Location.none
+            then Location.error_of_printer_file
+            else Location.error_of_printer ~loc ?sub:None
+          in
+          Some (error_of_printer report_error err)
+      | _ ->
+          None
+    )
+
+(* helper for merlin *)
+
+let check_state_consistency () =
+  let missing modname =
+    match Load_path.find_uncap (modname ^ ".cmi") with
+    | _ -> false
+    | exception Not_found -> true
+  and found _modname filename ps_name _md =
+    match Cmi_cache.get_cached_entry filename with
+    | cmi_infos -> ps_name == cmi_infos.Cmi_format.cmi_name
+    | exception Not_found -> false
+  in
+  Persistent_env.forall ~found ~missing !persistent_env
+
+let with_cmis f =
+  Persistent_env.with_cmis !persistent_env f ()
+
+let add_merlin_extension_module id mty env = add_module id Mp_present mty env
+
+(* Update short paths *)
+
+let rec index l x =
+  match l with
+    [] -> raise Not_found
+  | a :: l -> if x == a then 0 else 1 + index l x
+
+let rec uniq = function
+    [] -> true
+  | a :: l -> not (List.memq a l) && uniq l
+
+let short_paths_type_desc decl =
+  let open Short_paths.Desc.Type in
+  match decl.type_manifest with
+  | None -> Fresh
+  | Some ty ->
+    let ty = repr ty in
+    if ty.level <> generic_level then Fresh
+    else begin
+      match decl.type_private, decl.type_kind with
+      | Private, Type_abstract -> Fresh
+      | _, _ -> begin
+        let params = List.map repr decl.type_params in
+        match ty with
+        | {desc = Tconstr (path, args, _)} ->
+            let args = List.map repr args in
+            if List.length params = List.length args
+               && List.for_all2 (==) params args
+            then Alias path
+            else if List.length params <= List.length args
+                    || not (uniq args) then Fresh
+            else begin
+              match List.map (index params) args with
+              | exception Not_found -> Fresh
+              | ns -> Subst(path, ns)
+            end
+        | ty -> begin
+            match index params ty with
+            | exception Not_found -> Fresh
+            | n -> Nth n
+          end
+      end
+    end
+
+let short_paths_class_type_desc clty =
+  let open Short_paths.Desc.Class_type in
+  match clty.clty_type with
+  | Cty_signature _ | Cty_arrow _ -> Fresh
+  | Cty_constr(path, args, _) ->
+      let params = List.map repr clty.clty_params in
+      let args = List.map repr args in
+      if List.length params = List.length args
+      && List.for_all2 (==) params args
+      then Alias path
+      else if List.length params <= List.length args
+             || not (uniq args) then Fresh
+      else begin
+        match List.map (index params) args with
+        | exception Not_found -> Fresh
+        | ns -> Subst(path, ns)
+      end
+
+let short_paths_module_type_desc mty =
+  let open Short_paths.Desc.Module_type in
+  match mty with
+  | None | Some Mty_for_hole -> Fresh
+  | Some (Mty_ident path) -> Alias path
+  | Some (Mty_signature _ | Mty_functor _) -> Fresh
+  | Some (Mty_alias _) -> assert false
+
+let deprecated_of_alerts alerts =
+  if
+    String.Map.exists (fun key _ ->
+      match key with
+      | "deprecated" | "ocaml.deprecated" -> true
+      | _ -> false
+    ) alerts
+  then
+    Short_paths.Desc.Deprecated
+  else
+    Short_paths.Desc.Not_deprecated
+
+let deprecated_of_attributes attrs =
+  deprecated_of_alerts (Builtin_attributes.alerts_of_attrs attrs)
+
+let rec short_paths_module_desc env mpath mty comp =
+  let open Short_paths.Desc.Module in
+  match mty with
+  | Mty_alias path -> Alias path
+  | Mty_ident path -> begin
+      match find_modtype_expansion path env with
+      | exception Not_found -> Fresh (Signature (lazy []))
+      | mty -> short_paths_module_desc env mpath mty comp
+    end
+  | Mty_signature _ ->
+      let components =
+        lazy (short_paths_module_components_desc env mpath comp)
+      in
+      Fresh (Signature components)
+  | Mty_functor _ ->
+      let apply path =
+        short_paths_functor_components_desc env mpath comp path
+      in
+      Fresh (Functor apply)
+  | Mty_for_hole -> Fresh (Signature (lazy []))
+
+and short_paths_module_components_desc env mpath comp =
+  match get_components comp with
+  | Functor_comps _ -> assert false
+  | Structure_comps c ->
+      let comps =
+        String.Map.fold (fun name { tda_declaration = decl; _ } acc ->
+          let desc = short_paths_type_desc decl in
+          let depr = deprecated_of_attributes decl.type_attributes in
+          let item = Short_paths.Desc.Module.Type(name, desc, depr) in
+          item :: acc
+        ) c.comp_types []
+      in
+      let comps =
+        String.Map.fold (fun name clty  acc ->
+          let desc = short_paths_class_type_desc clty in
+          let depr = deprecated_of_attributes clty.clty_attributes in
+          let item = Short_paths.Desc.Module.Class_type(name, desc, depr) in
+          item :: acc
+        ) c.comp_cltypes comps
+      in
+      let comps =
+        String.Map.fold (fun name mtd acc ->
+          let desc = short_paths_module_type_desc mtd.mtd_type in
+          let depr = deprecated_of_attributes mtd.mtd_attributes in
+          let item = Short_paths.Desc.Module.Module_type(name, desc, depr) in
+          item :: acc
+        ) c.comp_modtypes comps
+      in
+      let comps =
+        String.Map.fold (fun name { mda_declaration; mda_components; _ } acc ->
+          let mty = Lazy_backtrack.force subst_modtype_maker mda_declaration in
+          let mpath = Pdot(mpath, name) in
+          let desc =
+            short_paths_module_desc env mpath mty.md_type mda_components
+          in
+          let depr = deprecated_of_alerts mda_components.alerts in
+          let item = Short_paths.Desc.Module.Module(name, desc, depr) in
+          item :: acc
+        ) c.comp_modules comps
+      in
+      comps
+
+and short_paths_functor_components_desc env mpath comp path =
+  match get_components comp with
+  | Structure_comps _ -> assert false
+  | Functor_comps f ->
+      let mty =
+        try
+          Hashtbl.find f.fcomp_subst_cache path
+        with Not_found ->
+          let mty =
+            let subst =
+              match f.fcomp_arg with
+              | Unit 
+              | Named (None, _) -> Subst.identity
+              | Named (Some id, _) -> Subst.add_module id path Subst.identity
+            in
+            Subst.modtype (Rescope (Path.scope (Papply (mpath, path))))
+              subst f.fcomp_res
+          in
+          Hashtbl.add f.fcomp_subst_cache path mty;
+          mty
+      in
+      let loc = Location.(in_file !input_name) in
+      let comps = 
+        components_of_functor_appl ~loc ~f_comp:f env ~f_path:mpath ~arg:path
+      in
+      let mpath = Papply(mpath, path) in
+      short_paths_module_desc env mpath mty comps
+
+let short_paths_additions_desc env additions =
+  List.fold_left
+    (fun acc add ->
+       match add with
+       | Type(id, decl) ->
+           let desc = short_paths_type_desc decl in
+           let source = Short_paths.Desc.Local in
+           let depr = deprecated_of_attributes decl.type_attributes in
+           Short_paths.Desc.Type(id, desc, source, depr) :: acc
+       | Class_type(id, clty) ->
+           let desc = short_paths_class_type_desc clty in
+           let source = Short_paths.Desc.Local in
+           let depr = deprecated_of_attributes clty.clty_attributes in
+           Short_paths.Desc.Class_type(id, desc, source, depr) :: acc
+       | Module_type(id, mtd) ->
+           let desc = short_paths_module_type_desc mtd.mtd_type in
+           let source = Short_paths.Desc.Local in
+           let depr = deprecated_of_attributes mtd.mtd_attributes in
+           Short_paths.Desc.Module_type(id, desc, source, depr) :: acc
+       | Module(id, md, comps) ->
+           let desc =
+             short_paths_module_desc env (Pident id) md.md_type comps
+           in
+           let source = Short_paths.Desc.Local in
+           let depr = deprecated_of_alerts comps.alerts in
+           Short_paths.Desc.Module(id, desc, source, depr) :: acc
+       | Type_open(root, decls) ->
+           String.Map.fold
+             (fun name { tda_declaration = decl; _ } acc ->
+                let id = Ident.create_local name in
+                let path = Pdot(root, name) in
+                let desc = Short_paths.Desc.Type.Alias path in
+                let source = Short_paths.Desc.Open in
+                let depr = deprecated_of_attributes decl.type_attributes in
+                Short_paths.Desc.Type(id, desc, source, depr) :: acc)
+             decls acc
+       | Class_type_open(root, decls) ->
+           String.Map.fold
+             (fun name clty acc ->
+                let id = Ident.create_local name in
+                let path = Pdot(root, name) in
+                let desc = Short_paths.Desc.Class_type.Alias path in
+                let source = Short_paths.Desc.Open in
+                let depr = deprecated_of_attributes clty.clty_attributes in
+                Short_paths.Desc.Class_type(id, desc, source, depr) :: acc)
+             decls acc
+       | Module_type_open(root, decls) ->
+           String.Map.fold
+             (fun name mtd acc ->
+                let id = Ident.create_local name in
+                let path = Pdot(root, name) in
+                let desc = Short_paths.Desc.Module_type.Alias path in
+                let source = Short_paths.Desc.Open in
+                let depr = deprecated_of_attributes mtd.mtd_attributes in
+                Short_paths.Desc.Module_type(id, desc, source, depr) :: acc)
+             decls acc
+       | Module_open(root, decls) ->
+           String.Map.fold
+             (fun name { mda_components = comps; _ } acc ->
+                let id = Ident.create_local name in
+                let path = Pdot(root, name) in
+                let desc = Short_paths.Desc.Module.Alias path in
+                let source = Short_paths.Desc.Open in
+                let depr = deprecated_of_alerts comps.alerts in
+                Short_paths.Desc.Module(id, desc, source, depr) :: acc)
+             decls acc)
+    [] additions
+
+let () =
+  short_paths_module_components_desc' := short_paths_module_components_desc
+
+let update_short_paths env =
+  let env, short_paths =
+    match env.short_paths with
+    | None ->
+      let basis = Persistent_env.short_paths_basis !persistent_env in
+      let short_paths = Short_paths.initial basis in
+      let env = { env with short_paths = Some short_paths } in
+      env, short_paths
+    | Some short_paths -> env, short_paths
+  in
+  match env.short_paths_additions with
+  | [] -> env
+  | _ :: _ as additions ->
+    let short_paths =
+      Short_paths.add short_paths
+        (lazy (short_paths_additions_desc env additions))
+    in
+    { env with short_paths = Some short_paths;
+               short_paths_additions = []; }
+
+let short_paths env =
+  match env.short_paths with
+  | None ->
+    let basis = Persistent_env.short_paths_basis !persistent_env in
+    Short_paths.initial basis
+  | Some short_paths -> short_paths
diff --git a/src/ocaml/typing/env.mli b/src/ocaml/typing/env.mli
new file mode 100644
index 0000000..e5054d0
--- /dev/null
+++ b/src/ocaml/typing/env.mli
@@ -0,0 +1,507 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Environment handling *)
+
+open Types
+open Misc
+
+type value_unbound_reason =
+  | Val_unbound_instance_variable
+  | Val_unbound_self
+  | Val_unbound_ancestor
+  | Val_unbound_ghost_recursive of Location.t
+
+type module_unbound_reason =
+  | Mod_unbound_illegal_recursion
+
+type summary =
+    Env_empty
+  | Env_value of summary * Ident.t * value_description
+  | Env_type of summary * Ident.t * type_declaration
+  | Env_extension of summary * Ident.t * extension_constructor
+  | Env_module of summary * Ident.t * module_presence * module_declaration
+  | Env_modtype of summary * Ident.t * modtype_declaration
+  | Env_class of summary * Ident.t * class_declaration
+  | Env_cltype of summary * Ident.t * class_type_declaration
+  | Env_open of summary * Path.t
+  (** The string set argument of [Env_open] represents a list of module names
+      to skip, i.e. that won't be imported in the toplevel namespace. *)
+  | Env_functor_arg of summary * Ident.t
+  | Env_constraints of summary * type_declaration Path.Map.t
+  | Env_copy_types of summary
+  | Env_persistent of summary * Ident.t
+  | Env_value_unbound of summary * string * value_unbound_reason
+  | Env_module_unbound of summary * string * module_unbound_reason
+
+type address =
+  | Aident of Ident.t
+  | Adot of address * int
+
+type t
+
+val empty: t
+val initial_safe_string: t
+val initial_unsafe_string: t
+val diff: t -> t -> Ident.t list
+
+type type_descr_kind =
+  (label_description, constructor_description) type_kind
+
+  (* alias for compatibility *)
+type type_descriptions = type_descr_kind
+
+(* For short-paths *)
+type iter_cont
+val iter_types:
+    (Path.t -> Path.t * type_declaration -> unit) ->
+    t -> iter_cont
+val run_iter_cont: iter_cont list -> (Path.t * iter_cont) list
+val same_types: t -> t -> bool
+val used_persistent: unit -> Concr.t
+val find_shadowed_types: Path.t -> t -> Path.t list
+val without_cmis: ('a -> 'b) -> 'a -> 'b
+(* [without_cmis f arg] applies [f] to [arg], but does not
+   allow opening cmis during its execution *)
+
+(* Lookup by paths *)
+
+val find_value: Path.t -> t -> value_description
+val find_type: Path.t -> t -> type_declaration
+val find_type_descrs: Path.t -> t -> type_descriptions
+val find_module: Path.t -> t -> module_declaration
+val find_modtype: Path.t -> t -> modtype_declaration
+val find_class: Path.t -> t -> class_declaration
+val find_cltype: Path.t -> t -> class_type_declaration
+
+val find_ident_constructor: Ident.t -> t -> constructor_description
+val find_ident_label: Ident.t -> t -> label_description
+
+val find_type_expansion:
+    Path.t -> t -> type_expr list * type_expr * int
+val find_type_expansion_opt:
+    Path.t -> t -> type_expr list * type_expr * int
+(* Find the manifest type information associated to a type for the sake
+   of the compiler's type-based optimisations. *)
+val find_modtype_expansion: Path.t -> t -> module_type
+
+val find_hash_type: Path.t -> t -> type_declaration
+(* Find the "#t" type given the path for "t" *)
+
+val find_value_address: Path.t -> t -> address
+val find_module_address: Path.t -> t -> address
+val find_class_address: Path.t -> t -> address
+val find_constructor_address: Path.t -> t -> address
+
+val add_functor_arg: Ident.t -> t -> t
+val is_functor_arg: Path.t -> t -> bool
+
+val normalize_module_path: Location.t option -> t -> Path.t -> Path.t
+(* Normalize the path to a concrete module.
+   If the option is None, allow returning dangling paths.
+   Otherwise raise a Missing_module error, and may add forgotten
+   head as required global. *)
+
+val normalize_type_path: Location.t option -> t -> Path.t -> Path.t
+(* Normalize the prefix part of the type path *)
+
+val normalize_path_prefix: Location.t option -> t -> Path.t -> Path.t
+(* Normalize the prefix part of other kinds of paths
+   (value/modtype/etc) *)
+
+val normalize_modtype_path: t -> Path.t -> Path.t
+(* Normalize a module type path *)
+
+val reset_required_globals: unit -> unit
+val get_required_globals: unit -> Ident.t list
+val add_required_global: Ident.t -> unit
+
+val has_local_constraints: t -> bool
+
+(* Mark definitions as used *)
+val mark_value_used: Uid.t -> unit
+val mark_module_used: Uid.t -> unit
+val mark_type_used: Uid.t -> unit
+
+type constructor_usage = Positive | Pattern | Exported_private | Exported
+val mark_constructor_used:
+    constructor_usage -> constructor_declaration -> unit
+val mark_extension_used:
+    constructor_usage -> extension_constructor -> unit
+
+type label_usage =
+    Projection | Mutation | Construct | Exported_private | Exported
+val mark_label_used:
+    label_usage -> label_declaration -> unit
+
+(* Lookup by long identifiers *)
+
+(* Lookup errors *)
+
+type unbound_value_hint =
+  | No_hint
+  | Missing_rec of Location.t
+
+type lookup_error =
+  | Unbound_value of Longident.t * unbound_value_hint
+  | Unbound_type of Longident.t
+  | Unbound_constructor of Longident.t
+  | Unbound_label of Longident.t
+  | Unbound_module of Longident.t
+  | Unbound_class of Longident.t
+  | Unbound_modtype of Longident.t
+  | Unbound_cltype of Longident.t
+  | Unbound_instance_variable of string
+  | Not_an_instance_variable of string
+  | Masked_instance_variable of Longident.t
+  | Masked_self_variable of Longident.t
+  | Masked_ancestor_variable of Longident.t
+  | Structure_used_as_functor of Longident.t
+  | Abstract_used_as_functor of Longident.t
+  | Functor_used_as_structure of Longident.t
+  | Abstract_used_as_structure of Longident.t
+  | Generative_used_as_applicative of Longident.t
+  | Illegal_reference_to_recursive_module
+  | Cannot_scrape_alias of Longident.t * Path.t
+
+val lookup_error: Location.t -> t -> lookup_error -> 'a
+
+(* The [lookup_foo] functions will emit proper error messages (by
+   raising [Error]) if the identifier cannot be found, whereas the
+   [find_foo_by_name] functions will raise [Not_found] instead.
+
+   The [~use] parameters of the [lookup_foo] functions control
+   whether this lookup should be counted as a use for usage
+   warnings and alerts.
+
+   [Longident.t]s in the program source should be looked up using
+   [lookup_foo ~use:true] exactly one time -- otherwise warnings may be
+   emitted the wrong number of times. *)
+
+val lookup_value:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  Path.t * value_description
+val lookup_type:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  Path.t * type_declaration
+val lookup_module:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  Path.t * module_declaration
+val lookup_modtype:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  Path.t * modtype_declaration
+val lookup_class:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  Path.t * class_declaration
+val lookup_cltype:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  Path.t * class_type_declaration
+
+val lookup_module_path:
+  ?use:bool -> loc:Location.t -> load:bool -> Longident.t -> t -> Path.t
+
+val lookup_constructor:
+  ?use:bool -> loc:Location.t -> constructor_usage -> Longident.t -> t ->
+  constructor_description
+val lookup_all_constructors:
+  ?use:bool -> loc:Location.t -> constructor_usage -> Longident.t -> t ->
+  ((constructor_description * (unit -> unit)) list,
+   Location.t * t * lookup_error) result
+val lookup_all_constructors_from_type:
+  ?use:bool -> loc:Location.t -> constructor_usage -> Path.t -> t ->
+  (constructor_description * (unit -> unit)) list
+
+val lookup_label:
+  ?use:bool -> loc:Location.t -> label_usage -> Longident.t -> t ->
+  label_description
+val lookup_all_labels:
+  ?use:bool -> loc:Location.t -> label_usage -> Longident.t -> t ->
+  ((label_description * (unit -> unit)) list,
+   Location.t * t * lookup_error) result
+val lookup_all_labels_from_type:
+  ?use:bool -> loc:Location.t -> label_usage -> Path.t -> t ->
+  (label_description * (unit -> unit)) list
+
+val lookup_instance_variable:
+  ?use:bool -> loc:Location.t -> string -> t ->
+  Path.t * Asttypes.mutable_flag * string * type_expr
+
+val find_value_by_name:
+  Longident.t -> t -> Path.t * value_description
+val find_type_by_name:
+  Longident.t -> t -> Path.t * type_declaration
+val find_module_by_name:
+  Longident.t -> t -> Path.t * module_declaration
+val find_modtype_by_name:
+  Longident.t -> t -> Path.t * modtype_declaration
+val find_class_by_name:
+  Longident.t -> t -> Path.t * class_declaration
+val find_cltype_by_name:
+  Longident.t -> t -> Path.t * class_type_declaration
+
+val find_constructor_by_name:
+  Longident.t -> t -> constructor_description
+val find_label_by_name:
+  Longident.t -> t -> label_description
+
+(* Check if a name is bound *)
+
+val bound_value: string -> t -> bool
+val bound_module: string -> t -> bool
+val bound_type: string -> t -> bool
+val bound_modtype: string -> t -> bool
+val bound_class: string -> t -> bool
+val bound_cltype: string -> t -> bool
+
+val make_copy_of_types: t -> (t -> t)
+
+(* Insertion by identifier *)
+
+val add_value:
+    ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t
+val add_type: check:bool -> Ident.t -> type_declaration -> t -> t
+val add_extension:
+  check:bool -> rebind:bool -> Ident.t -> extension_constructor -> t -> t
+val add_module:
+  ?arg:bool -> Ident.t -> module_presence -> module_type -> t -> t
+val add_module_declaration: ?arg:bool -> check:bool -> Ident.t ->
+  module_presence -> module_declaration -> t -> t
+val add_modtype: Ident.t -> modtype_declaration -> t -> t
+val add_class: Ident.t -> class_declaration -> t -> t
+val add_cltype: Ident.t -> class_type_declaration -> t -> t
+val add_local_type: Path.t -> type_declaration -> t -> t
+
+(* Insertion of persistent signatures *)
+
+(* [add_persistent_structure id env] is an environment such that
+   module [id] points to the persistent structure contained in the
+   external compilation unit with the same name.
+
+   The compilation unit itself is looked up in the load path when the
+   contents of the module is accessed. *)
+val add_persistent_structure : Ident.t -> t -> t
+
+(* Returns the set of persistent structures found in the given
+   directory. *)
+val persistent_structures_of_dir : Load_path.Dir.t -> Misc.String.Set.t
+
+(* [filter_non_loaded_persistent f env] removes all the persistent
+   structures that are not yet loaded and for which [f] returns
+   [false]. *)
+val filter_non_loaded_persistent : (Ident.t -> bool) -> t -> t
+
+(* Insertion of all fields of a signature. *)
+
+val add_item: signature_item -> t -> t
+val add_signature: signature -> t -> t
+
+(* Insertion of all fields of a signature, relative to the given path.
+   Used to implement open. Returns None if the path refers to a functor,
+   not a structure. *)
+val open_signature:
+    ?used_slot:bool ref ->
+    ?loc:Location.t -> ?toplevel:bool ->
+    Asttypes.override_flag -> Path.t ->
+    t -> (t, [`Not_found | `Functor]) result
+
+val open_pers_signature: string -> t -> (t, [`Not_found]) result
+
+val remove_last_open: Path.t -> t -> t option
+
+(* Insertion by name *)
+
+val enter_value:
+    ?check:(string -> Warnings.t) ->
+    string -> value_description -> t -> Ident.t * t
+val enter_type: scope:int -> string -> type_declaration -> t -> Ident.t * t
+val enter_extension:
+  scope:int -> rebind:bool -> string ->
+  extension_constructor -> t -> Ident.t * t
+val enter_module:
+  scope:int -> ?arg:bool -> string -> module_presence ->
+  module_type -> t -> Ident.t * t
+val enter_module_declaration:
+  scope:int -> ?arg:bool -> string -> module_presence ->
+  module_declaration -> t -> Ident.t * t
+val enter_modtype:
+  scope:int -> string -> modtype_declaration -> t -> Ident.t * t
+val enter_class: scope:int -> string -> class_declaration -> t -> Ident.t * t
+val enter_cltype:
+  scope:int -> string -> class_type_declaration -> t -> Ident.t * t
+
+(* Same as [add_signature] but refreshes (new stamp) and rescopes bound idents
+   in the process. *)
+val enter_signature: scope:int -> signature -> t -> signature * t
+
+val enter_unbound_value : string -> value_unbound_reason -> t -> t
+
+val enter_unbound_module : string -> module_unbound_reason -> t -> t
+
+(* Initialize the cache of in-core module interfaces. *)
+val reset_cache: unit -> unit
+
+(* To be called before each toplevel phrase. *)
+val reset_cache_toplevel: unit -> unit
+
+(* Remember the name of the current compilation unit. *)
+val set_unit_name: string -> unit
+val get_unit_name: unit -> string
+
+(* Read, save a signature to/from a file *)
+val read_signature: modname -> filepath -> signature
+        (* Arguments: module name, file name. Results: signature. *)
+val save_signature:
+  alerts:alerts -> signature -> modname -> filepath
+  -> Cmi_format.cmi_infos
+        (* Arguments: signature, module name, file name. *)
+val save_signature_with_imports:
+  alerts:alerts -> signature -> modname -> filepath -> crcs
+  -> Cmi_format.cmi_infos
+        (* Arguments: signature, module name, file name,
+           imported units with their CRCs. *)
+
+(* Return the CRC of the interface of the given compilation unit *)
+val crc_of_unit: modname -> Digest.t
+
+(* Return the set of compilation units imported, with their CRC *)
+val imports: unit -> crcs
+
+(* may raise Persistent_env.Consistbl.Inconsistency *)
+val import_crcs: source:string -> crcs -> unit
+
+(* [is_imported_opaque md] returns true if [md] is an opaque imported module *)
+val is_imported_opaque: modname -> bool
+
+(* [register_import_as_opaque md] registers [md] as an opaque imported module *)
+val register_import_as_opaque: modname -> unit
+
+(* Summaries -- compact representation of an environment, to be
+   exported in debugging information. *)
+
+val summary: t -> summary
+
+(* Return an equivalent environment where all fields have been reset,
+   except the summary. The initial environment can be rebuilt from the
+   summary, using Envaux.env_of_only_summary. *)
+
+val keep_only_summary : t -> t
+val env_of_only_summary : (summary -> Subst.t -> t) -> t -> t
+
+(* Update the short paths table *)
+val update_short_paths : t -> t
+
+(* Return the short paths table *)
+val short_paths : t -> Short_paths.t
+
+(* Error report *)
+
+type error =
+  | Missing_module of Location.t * Path.t * Path.t
+  | Illegal_value_name of Location.t * string
+  | Lookup_error of Location.t * t * lookup_error
+
+exception Error of error
+
+open Format
+
+val report_error: formatter -> error -> unit
+
+val report_lookup_error: Location.t -> t -> formatter -> lookup_error -> unit
+
+val in_signature: bool -> t -> t
+
+val is_in_signature: t -> bool
+
+val set_value_used_callback:
+    value_description -> (unit -> unit) -> unit
+val set_type_used_callback:
+    type_declaration -> ((unit -> unit) -> unit) -> unit
+
+(* Forward declaration to break mutual recursion with Includemod. *)
+val check_functor_application:
+  (errors:bool -> loc:Location.t ->
+   lid_whole_app:Longident.t ->
+   f0_path:Path.t -> args:(Path.t * Types.module_type) list ->
+   arg_path:Path.t -> arg_mty:Types.module_type ->
+   param_mty:Types.module_type ->
+   t -> unit) ref
+(* Forward declaration to break mutual recursion with Typemod. *)
+val check_well_formed_module:
+    (t -> Location.t -> string -> module_type -> unit) ref
+(* Forward declaration to break mutual recursion with Typecore. *)
+val add_delayed_check_forward: ((unit -> unit) -> unit) ref
+(* Forward declaration to break mutual recursion with Mtype. *)
+val strengthen:
+    (aliasable:bool -> t -> module_type -> Path.t -> module_type) ref
+(* Forward declaration to break mutual recursion with Ctype. *)
+val same_constr: (t -> type_expr -> type_expr -> bool) ref
+(* Forward declaration to break mutual recursion with Printtyp. *)
+val print_longident: (Format.formatter -> Longident.t -> unit) ref
+(* Forward declaration to break mutual recursion with Printtyp. *)
+val print_path: (Format.formatter -> Path.t -> unit) ref
+
+
+(* Forward declaration to break mutual recursion with Printtyp *)
+val shorten_module_path : (t -> Path.t -> Path.t) ref
+
+(** Folds *)
+
+(** Folding over all identifiers (for analysis purpose) *)
+
+val fold_values:
+  (string -> Path.t -> value_description -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+val fold_types:
+  (string -> Path.t -> type_declaration -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+val fold_constructors:
+  (constructor_description -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+val fold_labels:
+  (label_description -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+
+(** Persistent structures are only traversed if they are already loaded. *)
+val fold_modules:
+  (string -> Path.t -> module_declaration -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+
+val fold_modtypes:
+  (string -> Path.t -> modtype_declaration -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+val fold_classes:
+  (string -> Path.t -> class_declaration -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+val fold_cltypes:
+  (string -> Path.t -> class_type_declaration -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+
+(** Utilities *)
+val scrape_alias: t -> module_type -> module_type
+val check_value_name: string -> Location.t -> unit
+
+val print_address : Format.formatter -> address -> unit
+
+val unbound_class : Path.t
+
+(** merlin: manage internal state *)
+
+val check_state_consistency: unit -> bool
+
+val with_cmis : (unit -> 'a) -> 'a
+
+(* helper for merlin *)
+
+val add_merlin_extension_module: Ident.t -> module_type -> t -> t
diff --git a/src/ocaml/typing/errortrace.ml b/src/ocaml/typing/errortrace.ml
new file mode 100644
index 0000000..bd331e8
--- /dev/null
+++ b/src/ocaml/typing/errortrace.ml
@@ -0,0 +1,172 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Florian Angeletti, projet Cambium, Inria Paris             *)
+(*              Antal Spector-Zabusky, Jane Street, New York              *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*   Copyright 2021 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Types
+open Format
+
+type position = First | Second
+
+let swap_position = function
+  | First -> Second
+  | Second -> First
+
+let print_pos ppf = function
+  | First -> fprintf ppf "first"
+  | Second -> fprintf ppf "second"
+
+type desc = { t: type_expr; expanded: type_expr option }
+type 'a diff = { got: 'a; expected: 'a}
+
+let short t = { t; expanded = None }
+let map_diff f r =
+  (* ordering is often meaningful when dealing with type_expr *)
+  let got = f r.got in
+  let expected = f r.expected in
+  { got; expected}
+
+let flatten_desc f x = match x.expanded with
+  | None -> f x.t x.t
+  | Some expanded -> f x.t expanded
+
+let swap_diff x = { got = x.expected; expected = x.got }
+
+type 'a escape_kind =
+  | Constructor of Path.t
+  | Univ of type_expr
+  (* The type_expr argument of [Univ] is always a [Tunivar _],
+     we keep a [type_expr] to track renaming in {!Printtyp} *)
+  | Self
+  | Module_type of Path.t
+  | Equation of 'a
+  | Constraint
+
+type 'a escape =
+  { kind : 'a escape_kind;
+    context : type_expr option }
+
+let explain trace f =
+  let rec explain = function
+    | [] -> None
+    | [h] -> f ~prev:None h
+    | h :: (prev :: _ as rem) ->
+      match f ~prev:(Some prev) h with
+      | Some _ as m -> m
+      | None -> explain rem in
+  explain (List.rev trace)
+
+(* Type indices *)
+type unification = private Unification
+type comparison  = private Comparison
+
+type fixed_row_case =
+  | Cannot_be_closed
+  | Cannot_add_tags of string list
+
+type 'variety variant =
+  (* Common *)
+  | Incompatible_types_for : string -> _ variant
+  | No_tags : position * (Asttypes.label * row_field) list -> _ variant
+  (* Unification *)
+  | No_intersection : unification variant
+  | Fixed_row :
+      position * fixed_row_case * fixed_explanation -> unification variant
+  (* Equality & Moregen *)
+  | Openness : position (* Always [Second] for Moregen *) -> comparison variant
+
+type 'variety obj =
+  (* Common *)
+  | Missing_field : position * string -> _ obj
+  | Abstract_row : position -> _ obj
+  (* Unification *)
+  | Self_cannot_be_closed : unification obj
+
+type ('a, 'variety) elt =
+  (* Common *)
+  | Diff : 'a diff -> ('a, _) elt
+  | Variant : 'variety variant -> ('a, 'variety) elt
+  | Obj : 'variety obj -> ('a, 'variety) elt
+  | Escape : 'a escape -> ('a, _) elt
+  | Incompatible_fields : { name:string; diff: type_expr diff } -> ('a, _) elt
+      (* Could move [Incompatible_fields] into [obj] *)
+  (* Unification & Moregen; included in Equality for simplicity *)
+  | Rec_occur : type_expr * type_expr -> ('a, _) elt
+
+type 'variety t =
+  (desc, 'variety) elt list
+
+let diff got expected = Diff (map_diff short { got; expected })
+
+let map_desc f { t; expanded } =
+  let t = f t in
+  let expanded = Std.Option.map ~f expanded in
+  { t; expanded }
+
+let map_elt (type variety) f : ('a, variety) elt -> ('b, variety) elt = function
+  | Diff x -> Diff (map_diff f x)
+  | Escape {kind = Equation x; context} ->
+      Escape { kind = Equation (f x); context }
+  | Escape {kind = (Univ _ | Self | Constructor _ | Module_type _ | Constraint);
+            _}
+  | Variant _ | Obj _ | Incompatible_fields _ | Rec_occur (_, _) as x -> x
+
+let map f t = List.map (map_elt f) t
+
+let map_types f = map (map_desc f)
+
+(* Convert desc to type_expr * type_expr *)
+let flatten f = map (flatten_desc f)
+
+let incompatible_fields name got expected =
+  Incompatible_fields { name; diff={got; expected} }
+
+
+let swap_elt (type variety) : ('a, variety) elt -> ('a, variety) elt = function
+  | Diff x -> Diff (swap_diff x)
+  | Incompatible_fields { name; diff } ->
+    Incompatible_fields { name; diff = swap_diff diff}
+  | Obj (Missing_field(pos,s)) -> Obj (Missing_field(swap_position pos,s))
+  | Obj (Abstract_row pos) -> Obj (Abstract_row (swap_position pos))
+  | Variant (Fixed_row(pos,k,f)) ->
+    Variant (Fixed_row(swap_position pos,k,f))
+  | Variant (No_tags(pos,f)) ->
+    Variant (No_tags(swap_position pos,f))
+  | x -> x
+
+let swap_trace e = List.map swap_elt e
+
+module Subtype = struct
+  type 'a elt =
+    | Diff of 'a diff
+
+  type t = desc elt list
+
+  let diff got expected = Diff (map_diff short {got;expected})
+
+  let map_elt f = function
+    | Diff x -> Diff (map_diff f x)
+
+  let map f t = List.map (map_elt f) t
+
+  let flatten f t = map (flatten_desc f) t
+
+  let map_desc f { t; expanded } =
+    let t = f t in
+    let expanded = Std.Option.map ~f expanded in
+    { t; expanded }  
+
+  let map_types f = map (map_desc f)
+end
diff --git a/src/ocaml/typing/errortrace.mli b/src/ocaml/typing/errortrace.mli
new file mode 100644
index 0000000..c515408
--- /dev/null
+++ b/src/ocaml/typing/errortrace.mli
@@ -0,0 +1,123 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Florian Angeletti, projet Cambium, Inria Paris             *)
+(*              Antal Spector-Zabusky, Jane Street, New York              *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*   Copyright 2021 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Types
+
+type position = First | Second
+
+val swap_position : position -> position
+val print_pos : Format.formatter -> position -> unit
+
+type desc = { t: type_expr; expanded: type_expr option }
+type 'a diff = { got: 'a; expected: 'a}
+
+(** [map_diff f {expected;got}] is [{expected=f expected; got=f got}] *)
+val map_diff: ('a -> 'b) -> 'a diff -> 'b diff
+
+(** Scope escape related errors *)
+type 'a escape_kind =
+  | Constructor of Path.t
+  | Univ of type_expr
+  (* The type_expr argument of [Univ] is always a [Tunivar _],
+     we keep a [type_expr] to track renaming in {!Printtyp} *)
+  | Self
+  | Module_type of Path.t
+  | Equation of 'a
+  | Constraint
+
+type 'a escape =
+  { kind : 'a escape_kind;
+    context : type_expr option }
+
+val short : type_expr -> desc
+
+val explain: 'a list ->
+  (prev:'a option -> 'a -> 'b option) ->
+  'b option
+
+(* Type indices *)
+type unification = private Unification
+type comparison  = private Comparison
+
+type fixed_row_case =
+  | Cannot_be_closed
+  | Cannot_add_tags of string list
+
+type 'variety variant =
+  (* Common *)
+  | Incompatible_types_for : string -> _ variant
+  | No_tags : position * (Asttypes.label * row_field) list -> _ variant
+  (* Unification *)
+  | No_intersection : unification variant
+  | Fixed_row :
+      position * fixed_row_case * fixed_explanation -> unification variant
+  (* Equality & Moregen *)
+  | Openness : position (* Always [Second] for Moregen *) -> comparison variant
+
+type 'variety obj =
+  (* Common *)
+  | Missing_field : position * string -> _ obj
+  | Abstract_row : position -> _ obj
+  (* Unification *)
+  | Self_cannot_be_closed : unification obj
+
+type ('a, 'variety) elt =
+  (* Common *)
+  | Diff : 'a diff -> ('a, _) elt
+  | Variant : 'variety variant -> ('a, 'variety) elt
+  | Obj : 'variety obj -> ('a, 'variety) elt
+  | Escape : 'a escape -> ('a, _) elt
+  | Incompatible_fields : { name:string; diff: type_expr diff } -> ('a, _) elt
+  (* Unification & Moregen; included in Equality for simplicity *)
+  | Rec_occur : type_expr * type_expr -> ('a, _) elt
+
+type 'variety t =
+  (desc, 'variety) elt list
+
+(** merlin specific *)
+val map_types : (type_expr -> type_expr) -> 'variety t -> 'variety t
+  
+
+val diff : type_expr -> type_expr -> (desc, _) elt
+
+(** [flatten f trace] flattens all elements of type {!desc} in
+    [trace] to either [f x.t expanded] if [x.expanded=Some expanded]
+    or [f x.t x.t] otherwise *)
+val flatten :
+  (type_expr -> type_expr -> 'a) -> 'variety t -> ('a, 'variety) elt list
+
+val map : ('a -> 'b) -> ('a, 'variety) elt list -> ('b, 'variety) elt list
+
+val incompatible_fields : string -> type_expr -> type_expr -> (desc, _) elt
+
+val swap_trace : 'variety t -> 'variety t
+
+module Subtype : sig
+  type 'a elt =
+    | Diff of 'a diff
+
+  type t = desc elt list
+
+  val diff: type_expr -> type_expr -> desc elt
+
+  val flatten : (type_expr -> type_expr -> 'a) -> t -> 'a elt list
+
+  val map : (desc -> desc) -> desc elt list -> desc elt list
+
+  (** merlin specific *)
+  val map_types : (type_expr -> type_expr) -> t -> t  
+end
diff --git a/src/ocaml/typing/ident.ml b/src/ocaml/typing/ident.ml
new file mode 100644
index 0000000..8873b28
--- /dev/null
+++ b/src/ocaml/typing/ident.ml
@@ -0,0 +1,364 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Local_store
+
+let lowest_scope  = 0
+let highest_scope = 100000000
+
+type t =
+  | Local of { name: string; stamp: int }
+  | Scoped of { name: string; stamp: int; scope: int }
+  | Global of string
+  | Predef of { name: string; stamp: int }
+      (* the stamp is here only for fast comparison, but the name of
+         predefined identifiers is always unique. *)
+
+(* A stamp of 0 denotes a persistent identifier *)
+
+let currentstamp = s_ref 0
+let predefstamp = s_ref 0
+
+let create_scoped ~scope s =
+  incr currentstamp;
+  Scoped { name = s; stamp = !currentstamp; scope }
+
+let create_local s =
+  incr currentstamp;
+  Local { name = s; stamp = !currentstamp }
+
+let create_predef s =
+  incr predefstamp;
+  Predef { name = s; stamp = !predefstamp }
+
+let create_persistent s =
+  Global s
+
+let name = function
+  | Local { name; _ }
+  | Scoped { name; _ }
+  | Global name
+  | Predef { name; _ } -> name
+
+let rename = function
+  | Local { name; stamp = _ }
+  | Scoped { name; stamp = _; scope = _ } ->
+      incr currentstamp;
+      Local { name; stamp = !currentstamp }
+  | id ->
+      Misc.fatal_errorf "Ident.rename %s" (name id)
+
+let unique_name = function
+  | Local { name; stamp }
+  | Scoped { name; stamp } -> name ^ "_" ^ Int.to_string stamp
+  | Global name ->
+      (* we're adding a fake stamp, because someone could have named his unit
+         [Foo_123] and since we're using unique_name to produce symbol names,
+         we might clash with an ident [Local { "Foo"; 123 }]. *)
+      name ^ "_0"
+  | Predef { name; _ } ->
+      (* we know that none of the predef names (currently) finishes in
+         "_<some number>", and that their name is unique. *)
+      name
+
+let unique_toplevel_name = function
+  | Local { name; stamp }
+  | Scoped { name; stamp } -> name ^ "/" ^ Int.to_string stamp
+  | Global name
+  | Predef { name; _ } -> name
+
+let persistent = function
+  | Global _ -> true
+  | _ -> false
+
+let equal i1 i2 =
+  match i1, i2 with
+  | Local { name = name1; _ }, Local { name = name2; _ }
+  | Scoped { name = name1; _ }, Scoped { name = name2; _ }
+  | Global name1, Global name2 ->
+      name1 = name2
+  | Predef { stamp = s1; _ }, Predef { stamp = s2 } ->
+      (* if they don't have the same stamp, they don't have the same name *)
+      s1 = s2
+  | _ ->
+      false
+
+let same i1 i2 =
+  match i1, i2 with
+  | Local { stamp = s1; _ }, Local { stamp = s2; _ }
+  | Scoped { stamp = s1; _ }, Scoped { stamp = s2; _ }
+  | Predef { stamp = s1; _ }, Predef { stamp = s2 } ->
+      s1 = s2
+  | Global name1, Global name2 ->
+      name1 = name2
+  | _ ->
+      false
+
+let stamp = function
+  | Local { stamp; _ }
+  | Scoped { stamp; _ } -> stamp
+  | _ -> 0
+
+let scope = function
+  | Scoped { scope; _ } -> scope
+  | Local _ -> highest_scope
+  | Global _ | Predef _ -> lowest_scope
+
+let reinit_level = ref (-1)
+
+let reinit () =
+  if !reinit_level < 0
+  then reinit_level := !currentstamp
+  else currentstamp := !reinit_level
+
+let global = function
+  | Local _
+  | Scoped _ -> false
+  | Global _
+  | Predef _ -> true
+
+let is_predef = function
+  | Predef _ -> true
+  | _ -> false
+
+let print ~with_scope ppf =
+  let open Format in
+  function
+  | Global name -> fprintf ppf "%s!" name
+  | Predef { name; stamp = n } ->
+      fprintf ppf "%s/%i!" name n
+  | Local { name; stamp = n } ->
+      fprintf ppf "%s/%i" name n
+  | Scoped { name; stamp = n; scope } ->
+      fprintf ppf "%s/%i%s" name n
+        (if with_scope then sprintf "[%i]" scope else "")
+
+let print_with_scope ppf id = print ~with_scope:true ppf id
+
+let print ppf id = print ~with_scope:false ppf id
+
+type 'a tbl =
+    Empty
+  | Node of 'a tbl * 'a data * 'a tbl * int
+
+and 'a data =
+  { ident: t;
+    data: 'a;
+    previous: 'a data option }
+
+let empty = Empty
+
+(* Inline expansion of height for better speed
+ * let height = function
+ *     Empty -> 0
+ *   | Node(_,_,_,h) -> h
+ *)
+
+let mknode l d r =
+  let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h
+  and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+  Node(l, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+let balance l d r =
+  let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h
+  and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+  if hl > hr + 1 then
+    match l with
+    | Node (ll, ld, lr, _)
+      when (match ll with Empty -> 0 | Node(_,_,_,h) -> h) >=
+           (match lr with Empty -> 0 | Node(_,_,_,h) -> h) ->
+        mknode ll ld (mknode lr d r)
+    | Node (ll, ld, Node(lrl, lrd, lrr, _), _) ->
+        mknode (mknode ll ld lrl) lrd (mknode lrr d r)
+    | _ -> assert false
+  else if hr > hl + 1 then
+    match r with
+    | Node (rl, rd, rr, _)
+      when (match rr with Empty -> 0 | Node(_,_,_,h) -> h) >=
+           (match rl with Empty -> 0 | Node(_,_,_,h) -> h) ->
+        mknode (mknode l d rl) rd rr
+    | Node (Node (rll, rld, rlr, _), rd, rr, _) ->
+        mknode (mknode l d rll) rld (mknode rlr rd rr)
+    | _ -> assert false
+  else
+    mknode l d r
+
+let rec add id data = function
+    Empty ->
+      Node(Empty, {ident = id; data = data; previous = None}, Empty, 1)
+  | Node(l, k, r, h) ->
+      let c = String.compare (name id) (name k.ident) in
+      if c = 0 then
+        Node(l, {ident = id; data = data; previous = Some k}, r, h)
+      else if c < 0 then
+        balance (add id data l) k r
+      else
+        balance l k (add id data r)
+
+let rec min_binding = function
+    Empty -> raise Not_found
+  | Node (Empty, d, _, _) -> d
+  | Node (l, _, _, _) -> min_binding l
+
+let rec remove_min_binding = function
+    Empty -> invalid_arg "Map.remove_min_elt"
+  | Node (Empty, _, r, _) -> r
+  | Node (l, d, r, _) -> balance (remove_min_binding l) d r
+
+let merge t1 t2 =
+  match (t1, t2) with
+    (Empty, t) -> t
+  | (t, Empty) -> t
+  | (_, _) ->
+      let d = min_binding t2 in
+      balance t1 d (remove_min_binding t2)
+
+let rec remove id = function
+    Empty ->
+      Empty
+  | (Node (l, k, r, h) as m) ->
+      let c = String.compare (name id) (name k.ident) in
+      if c = 0 then
+        match k.previous with
+        | None -> merge l r
+        | Some k -> Node (l, k, r, h)
+      else if c < 0 then
+        let ll = remove id l in if l == ll then m else balance ll k r
+      else
+        let rr = remove id r in if r == rr then m else balance l k rr
+
+let rec find_previous id = function
+    None ->
+      raise Not_found
+  | Some k ->
+      if same id k.ident then k.data else find_previous id k.previous
+
+let rec find_same id = function
+    Empty ->
+      raise Not_found
+  | Node(l, k, r, _) ->
+      let c = String.compare (name id) (name k.ident) in
+      if c = 0 then
+        if same id k.ident
+        then k.data
+        else find_previous id k.previous
+      else
+        find_same id (if c < 0 then l else r)
+
+let rec find_name n = function
+    Empty ->
+      raise Not_found
+  | Node(l, k, r, _) ->
+      let c = String.compare n (name k.ident) in
+      if c = 0 then
+        k.ident, k.data
+      else
+        find_name n (if c < 0 then l else r)
+
+let rec get_all = function
+  | None -> []
+  | Some k -> (k.ident, k.data) :: get_all k.previous
+
+let rec find_all n = function
+    Empty ->
+      []
+  | Node(l, k, r, _) ->
+      let c = String.compare n (name k.ident) in
+      if c = 0 then
+        (k.ident, k.data) :: get_all k.previous
+      else
+        find_all n (if c < 0 then l else r)
+
+let rec fold_aux f stack accu = function
+    Empty ->
+      begin match stack with
+        [] -> accu
+      | a :: l -> fold_aux f l accu a
+      end
+  | Node(l, k, r, _) ->
+      fold_aux f (l :: stack) (f k accu) r
+
+let fold_name f tbl accu = fold_aux (fun k -> f k.ident k.data) [] accu tbl
+
+let rec fold_data f d accu =
+  match d with
+    None -> accu
+  | Some k -> f k.ident k.data (fold_data f k.previous accu)
+
+let fold_all f tbl accu =
+  fold_aux (fun k -> fold_data f (Some k)) [] accu tbl
+
+(* let keys tbl = fold_name (fun k _ accu -> k::accu) tbl [] *)
+
+let rec iter f = function
+    Empty -> ()
+  | Node(l, k, r, _) ->
+      iter f l; f k.ident k.data; iter f r
+
+(* Idents for sharing keys *)
+
+(* They should be 'totally fresh' -> neg numbers *)
+let key_name = ""
+
+let make_key_generator () =
+  let c = ref 1 in
+  function
+  | Local _
+  | Scoped _ ->
+      let stamp = !c in
+      decr c ;
+      Local { name = key_name; stamp = stamp }
+  | global_id ->
+      Misc.fatal_errorf "Ident.make_key_generator () %s" (name global_id)
+
+let compare x y =
+  match x, y with
+  | Local x, Local y ->
+      let c = x.stamp - y.stamp in
+      if c <> 0 then c
+      else compare x.name y.name
+  | Local _, _ -> 1
+  | _, Local _ -> (-1)
+  | Scoped x, Scoped y ->
+      let c = x.stamp - y.stamp in
+      if c <> 0 then c
+      else compare x.name y.name
+  | Scoped _, _ -> 1
+  | _, Scoped _ -> (-1)
+  | Global x, Global y -> compare x y
+  | Global _, _ -> 1
+  | _, Global _ -> (-1)
+  | Predef { stamp = s1; _ }, Predef { stamp = s2; _ } -> compare s1 s2
+
+let output oc id = output_string oc (unique_name id)
+let hash i = (Char.code (name i).[0]) lxor (stamp i)
+
+let original_equal = equal
+include Identifiable.Make (struct
+  type nonrec t = t
+  let compare = compare
+  let output = output
+  let print = print
+  let hash = hash
+  let equal = same
+end)
+let equal = original_equal
+
+let rename_no_exn = function
+  | Local { name; stamp = _ }
+  | Scoped { name; stamp = _; scope = _ } ->
+      incr currentstamp;
+      Local { name; stamp = !currentstamp }
+  | id -> id
diff --git a/src/ocaml/typing/ident.mli b/src/ocaml/typing/ident.mli
new file mode 100644
index 0000000..947139a
--- /dev/null
+++ b/src/ocaml/typing/ident.mli
@@ -0,0 +1,86 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Identifiers (unique names) *)
+
+type t
+
+include Identifiable.S with type t := t
+(* Notes:
+   - [equal] compares identifiers by name
+   - [compare x y] is 0 if [same x y] is true.
+   - [compare] compares identifiers by binding location
+*)
+
+val print_with_scope : Format.formatter -> t -> unit
+        (** Same as {!print} except that it will also add a "[n]" suffix
+            if the scope of the argument is [n]. *)
+
+
+val create_scoped: scope:int -> string -> t
+val create_local: string -> t
+val create_persistent: string -> t
+val create_predef: string -> t
+
+val rename: t -> t
+        (** Creates an identifier with the same name as the input, a fresh
+            stamp, and no scope.
+            @raise [Fatal_error] if called on a persistent / predef ident. *)
+
+val name: t -> string
+val unique_name: t -> string
+val unique_toplevel_name: t -> string
+val persistent: t -> bool
+val same: t -> t -> bool
+        (** Compare identifiers by binding location.
+            Two identifiers are the same either if they are both
+            non-persistent and have been created by the same call to
+            [create_*], or if they are both persistent and have the same
+            name. *)
+
+val compare: t -> t -> int
+
+val global: t -> bool
+val is_predef: t -> bool
+
+val scope: t -> int
+val stamp: t -> int
+
+val lowest_scope : int
+val highest_scope: int
+
+val reinit: unit -> unit
+
+type 'a tbl
+        (* Association tables from identifiers to type 'a. *)
+
+val empty: 'a tbl
+val add: t -> 'a -> 'a tbl -> 'a tbl
+val find_same: t -> 'a tbl -> 'a
+val find_name: string -> 'a tbl -> t * 'a
+val find_all: string -> 'a tbl -> (t * 'a) list
+val fold_name: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b
+val fold_all: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b
+val iter: (t -> 'a -> unit) -> 'a tbl -> unit
+val remove: t -> 'a tbl -> 'a tbl
+
+(* Idents for sharing keys *)
+
+val make_key_generator : unit -> (t -> t)
+
+(* merlin *)
+
+val rename_no_exn: t -> t
+        (** Like [rename], but does not fail on persistent/predef idents. *)
diff --git a/src/ocaml/typing/includeclass.ml b/src/ocaml/typing/includeclass.ml
new file mode 100644
index 0000000..2f0c057
--- /dev/null
+++ b/src/ocaml/typing/includeclass.ml
@@ -0,0 +1,120 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Jerome Vouillon, projet Cristal, INRIA Rocquencourt          *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the class language *)
+
+open Types
+
+let class_types env cty1 cty2 =
+  Ctype.match_class_types env cty1 cty2
+
+let class_type_declarations ~loc env cty1 cty2 =
+  Builtin_attributes.check_alerts_inclusion
+    ~def:cty1.clty_loc
+    ~use:cty2.clty_loc
+    loc
+    cty1.clty_attributes cty2.clty_attributes
+    (Path.last cty1.clty_path);
+  Ctype.match_class_declarations env
+    cty1.clty_params cty1.clty_type
+    cty2.clty_params cty2.clty_type
+
+let class_declarations env cty1 cty2 =
+  match cty1.cty_new, cty2.cty_new with
+    None, Some _ ->
+      [Ctype.CM_Virtual_class]
+  | _ ->
+      Ctype.match_class_declarations env
+        cty1.cty_params cty1.cty_type
+        cty2.cty_params cty2.cty_type
+
+open Format
+open Ctype
+
+(*
+let rec hide_params = function
+    Tcty_arrow ("*", _, cty) -> hide_params cty
+  | cty -> cty
+*)
+
+let report_error_for = function
+  | CM_Equality -> Printtyp.report_equality_error
+  | CM_Moregen  -> Printtyp.report_moregen_error
+
+let include_err ppf =
+  function
+  | CM_Virtual_class ->
+      fprintf ppf "A class cannot be changed from virtual to concrete"
+  | CM_Parameter_arity_mismatch _ ->
+      fprintf ppf
+        "The classes do not have the same number of type parameters"
+  | CM_Type_parameter_mismatch (env, trace) ->
+      Printtyp.report_equality_error ppf env trace
+        (function ppf ->
+          fprintf ppf "A type parameter has type")
+        (function ppf ->
+          fprintf ppf "but is expected to have type")
+  | CM_Class_type_mismatch (env, cty1, cty2) ->
+      Printtyp.wrap_printing_env ~error:true env (fun () ->
+        fprintf ppf
+          "@[The class type@;<1 2>%a@ %s@;<1 2>%a@]"
+          Printtyp.class_type cty1
+          "is not matched by the class type"
+          Printtyp.class_type cty2)
+  | CM_Parameter_mismatch (env, trace) ->
+      Printtyp.report_moregen_error ppf env trace
+        (function ppf ->
+          fprintf ppf "A parameter has type")
+        (function ppf ->
+          fprintf ppf "but is expected to have type")
+  | CM_Val_type_mismatch (trace_type, lab, env, trace) ->
+      report_error_for trace_type ppf env trace
+        (function ppf ->
+          fprintf ppf "The instance variable %s@ has type" lab)
+        (function ppf ->
+          fprintf ppf "but is expected to have type")
+  | CM_Meth_type_mismatch (trace_type, lab, env, trace) ->
+      report_error_for trace_type  ppf env trace
+        (function ppf ->
+          fprintf ppf "The method %s@ has type" lab)
+        (function ppf ->
+          fprintf ppf "but is expected to have type")
+  | CM_Non_mutable_value lab ->
+      fprintf ppf
+       "@[The non-mutable instance variable %s cannot become mutable@]" lab
+  | CM_Non_concrete_value lab ->
+      fprintf ppf
+       "@[The virtual instance variable %s cannot become concrete@]" lab
+  | CM_Missing_value lab ->
+      fprintf ppf "@[The first class type has no instance variable %s@]" lab
+  | CM_Missing_method lab ->
+      fprintf ppf "@[The first class type has no method %s@]" lab
+  | CM_Hide_public lab ->
+     fprintf ppf "@[The public method %s cannot be hidden@]" lab
+  | CM_Hide_virtual (k, lab) ->
+      fprintf ppf "@[The virtual %s %s cannot be hidden@]" k lab
+  | CM_Public_method lab ->
+      fprintf ppf "@[The public method %s cannot become private@]" lab
+  | CM_Virtual_method lab ->
+      fprintf ppf "@[The virtual method %s cannot become concrete@]" lab
+  | CM_Private_method lab ->
+      fprintf ppf "@[The private method %s cannot become public@]" lab
+
+let report_error ppf = function
+  |  [] -> ()
+  | err :: errs ->
+      let print_errs ppf errs =
+         List.iter (fun err -> fprintf ppf "@ %a" include_err err) errs in
+      fprintf ppf "@[<v>%a%a@]" include_err err print_errs errs
diff --git a/src/ocaml/typing/includeclass.mli b/src/ocaml/typing/includeclass.mli
new file mode 100644
index 0000000..ebfa978
--- /dev/null
+++ b/src/ocaml/typing/includeclass.mli
@@ -0,0 +1,32 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Jerome Vouillon, projet Cristal, INRIA Rocquencourt          *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the class language *)
+
+open Types
+open Ctype
+open Format
+
+val class_types:
+        Env.t -> class_type -> class_type -> class_match_failure list
+val class_type_declarations:
+  loc:Location.t ->
+  Env.t -> class_type_declaration -> class_type_declaration ->
+  class_match_failure list
+val class_declarations:
+  Env.t -> class_declaration -> class_declaration ->
+  class_match_failure list
+
+val report_error: formatter -> class_match_failure list -> unit
diff --git a/src/ocaml/typing/includecore.ml b/src/ocaml/typing/includecore.ml
new file mode 100644
index 0000000..d712fae
--- /dev/null
+++ b/src/ocaml/typing/includecore.ml
@@ -0,0 +1,685 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the core language *)
+
+open Asttypes
+open Path
+open Types
+open Typedtree
+
+type position = Errortrace.position = First | Second
+
+(* Inclusion between value descriptions *)
+
+type primitive_mismatch =
+  | Name
+  | Arity
+  | No_alloc of position
+  | Native_name
+  | Result_repr
+  | Argument_repr of int
+
+let native_repr_args nra1 nra2 =
+  let rec loop i nra1 nra2 =
+    match nra1, nra2 with
+    | [], [] -> None
+    | [], _ :: _ -> assert false
+    | _ :: _, [] -> assert false
+    | nr1 :: nra1, nr2 :: nra2 ->
+      if not (Primitive.equal_native_repr nr1 nr2) then Some (Argument_repr i)
+      else loop (i+1) nra1 nra2
+  in
+  loop 1 nra1 nra2
+
+let primitive_descriptions pd1 pd2 =
+  let open Primitive in
+  if not (String.equal pd1.prim_name pd2.prim_name) then
+    Some Name
+  else if not (Int.equal pd1.prim_arity pd2.prim_arity) then
+    Some Arity
+  else if (not pd1.prim_alloc) && pd2.prim_alloc then
+    Some (No_alloc First)
+  else if pd1.prim_alloc && (not pd2.prim_alloc) then
+    Some (No_alloc Second)
+  else if not (String.equal pd1.prim_native_name pd2.prim_native_name) then
+    Some Native_name
+  else if not
+    (Primitive.equal_native_repr
+       pd1.prim_native_repr_res pd2.prim_native_repr_res) then
+    Some Result_repr
+  else
+    native_repr_args pd1.prim_native_repr_args pd2.prim_native_repr_args
+
+type value_mismatch =
+  | Primitive_mismatch of primitive_mismatch
+  | Not_a_primitive
+  | Type of Env.t * Errortrace.comparison Errortrace.t
+
+exception Dont_match of value_mismatch
+
+let value_descriptions ~loc env name
+    (vd1 : Types.value_description)
+    (vd2 : Types.value_description) =
+  Builtin_attributes.check_alerts_inclusion
+    ~def:vd1.val_loc
+    ~use:vd2.val_loc
+    loc
+    vd1.val_attributes vd2.val_attributes
+    name;
+  match Ctype.moregeneral env true vd1.val_type vd2.val_type with
+  | exception Ctype.Moregen trace -> raise (Dont_match (Type (env, trace)))
+  | () -> begin
+      match (vd1.val_kind, vd2.val_kind) with
+      | (Val_prim p1, Val_prim p2) -> begin
+          match primitive_descriptions p1 p2 with
+          | None -> Tcoerce_none
+          | Some err -> raise (Dont_match (Primitive_mismatch err))
+        end
+      | (Val_prim p, _) ->
+          let pc =
+            { pc_desc = p; pc_type = vd2.Types.val_type;
+              pc_env = env; pc_loc = vd1.Types.val_loc; }
+          in
+          Tcoerce_primitive pc
+      | (_, Val_prim _) -> raise (Dont_match Not_a_primitive)
+      | (_, _) -> Tcoerce_none
+    end
+
+(* Inclusion between "private" annotations *)
+
+let private_flags decl1 decl2 =
+  match decl1.type_private, decl2.type_private with
+  | Private, Public ->
+      decl2.type_kind = Type_abstract &&
+      (decl2.type_manifest = None || decl1.type_kind <> Type_abstract)
+  | _, _ -> true
+
+(* Inclusion between manifest types (particularly for private row types) *)
+
+let is_absrow env ty =
+  match ty.desc with
+  | Tconstr(Pident _, _, _) -> begin
+      match Ctype.expand_head env ty with
+      | {desc=Tobject _|Tvariant _} -> true
+      | _ -> false
+      end
+  | _ -> false
+
+(* Inclusion between type declarations *)
+
+let choose ord first second =
+  match ord with
+  | First -> first
+  | Second -> second
+
+let choose_other ord first second =
+  match ord with
+  | First -> choose Second first second
+  | Second -> choose First first second
+
+type label_mismatch =
+  | Type of Env.t * Errortrace.comparison Errortrace.t
+  | Mutability of position
+
+type record_mismatch =
+  | Label_mismatch of Types.label_declaration
+                      * Types.label_declaration
+                      * label_mismatch
+  | Label_names of int * Ident.t * Ident.t
+  | Label_missing of position * Ident.t
+  | Unboxed_float_representation of position
+
+type constructor_mismatch =
+  | Type of Env.t * Errortrace.comparison Errortrace.t
+  | Arity
+  | Inline_record of record_mismatch
+  | Kind of position
+  | Explicit_return_type of position
+
+type variant_mismatch =
+  | Constructor_mismatch of Types.constructor_declaration
+                            * Types.constructor_declaration
+                            * constructor_mismatch
+  | Constructor_names of int * Ident.t * Ident.t
+  | Constructor_missing of position * Ident.t
+
+type extension_constructor_mismatch =
+  | Constructor_privacy
+  | Constructor_mismatch of Ident.t
+                            * Types.extension_constructor
+                            * Types.extension_constructor
+                            * constructor_mismatch
+
+type private_variant_mismatch =
+  | Openness
+  | Missing of position * string
+  | Presence of string
+  | Incompatible_types_for of string
+  | Types of Env.t * Errortrace.comparison Errortrace.t
+
+type private_object_mismatch =
+  | Missing of string
+  | Types of Env.t * Errortrace.comparison Errortrace.t
+
+type type_mismatch =
+  | Arity
+  | Privacy
+  | Kind
+  | Constraint of Env.t * Errortrace.comparison Errortrace.t
+  | Manifest of Env.t * Errortrace.comparison Errortrace.t
+  | Private_variant of type_expr * type_expr * private_variant_mismatch
+  | Private_object of type_expr * type_expr * private_object_mismatch
+  | Variance
+  | Record_mismatch of record_mismatch
+  | Variant_mismatch of variant_mismatch
+  | Unboxed_representation of position
+  | Immediate of Type_immediacy.Violation.t
+
+let report_label_mismatch first second ppf err =
+  let pr fmt = Format.fprintf ppf fmt in
+  match (err : label_mismatch) with
+  | Type _ -> pr "The types are not equal."
+  | Mutability ord ->
+      pr "%s is mutable and %s is not."
+        (String.capitalize_ascii  (choose ord first second))
+        (choose_other ord first second)
+
+let report_record_mismatch first second decl ppf err =
+  let pr fmt = Format.fprintf ppf fmt in
+  match err with
+  | Label_mismatch (l1, l2, err) ->
+      pr
+        "@[<hv>Fields do not match:@;<1 2>%a@ is not compatible with:\
+         @;<1 2>%a@ %a@]"
+        Printtyp.label l1
+        Printtyp.label l2
+        (report_label_mismatch first second) err
+  | Label_names (n, name1, name2) ->
+      pr "@[<hv>Fields number %i have different names, %s and %s.@]"
+        n (Ident.name name1) (Ident.name name2)
+  | Label_missing (ord, s) ->
+      pr "@[<hv>The field %s is only present in %s %s.@]"
+        (Ident.name s) (choose ord first second) decl
+  | Unboxed_float_representation ord ->
+      pr "@[<hv>Their internal representations differ:@ %s %s %s.@]"
+        (choose ord first second) decl
+        "uses unboxed float representation"
+
+let report_constructor_mismatch first second decl ppf err =
+  let pr fmt  = Format.fprintf ppf fmt in
+  match (err : constructor_mismatch) with
+  | Type _ -> pr "The types are not equal."
+  | Arity -> pr "They have different arities."
+  | Inline_record err -> report_record_mismatch first second decl ppf err
+  | Kind ord ->
+      pr "%s uses inline records and %s doesn't."
+        (String.capitalize_ascii (choose ord first second))
+        (choose_other ord first second)
+  | Explicit_return_type ord ->
+      pr "%s has explicit return type and %s doesn't."
+        (String.capitalize_ascii (choose ord first second))
+        (choose_other ord first second)
+
+let report_variant_mismatch first second decl ppf err =
+  let pr fmt = Format.fprintf ppf fmt in
+  match (err : variant_mismatch) with
+  | Constructor_mismatch (c1, c2, err) ->
+      pr
+        "@[<hv>Constructors do not match:@;<1 2>%a@ is not compatible with:\
+         @;<1 2>%a@ %a@]"
+        Printtyp.constructor c1
+        Printtyp.constructor c2
+        (report_constructor_mismatch first second decl) err
+  | Constructor_names (n, name1, name2) ->
+      pr "Constructors number %i have different names, %s and %s."
+        n (Ident.name name1) (Ident.name name2)
+  | Constructor_missing (ord, s) ->
+      pr "The constructor %s is only present in %s %s."
+        (Ident.name s) (choose ord first second) decl
+
+let report_extension_constructor_mismatch first second decl ppf err =
+  let pr fmt = Format.fprintf ppf fmt in
+  match (err : extension_constructor_mismatch) with
+  | Constructor_privacy -> pr "A private type would be revealed."
+  | Constructor_mismatch (id, ext1, ext2, err) ->
+      pr "@[<hv>Constructors do not match:@;<1 2>%a@ is not compatible with:\
+          @;<1 2>%a@ %a@]"
+        (Printtyp.extension_only_constructor id) ext1
+        (Printtyp.extension_only_constructor id) ext2
+        (report_constructor_mismatch first second decl) err
+
+let report_type_mismatch0 first second decl ppf err =
+  let pr fmt = Format.fprintf ppf fmt in
+  match err with
+  | Arity -> pr "They have different arities."
+  | Privacy -> pr "A private type would be revealed."
+  | Kind -> pr "Their kinds differ."
+  | Constraint _ -> pr "Their constraints differ."
+  | Manifest _ -> ()
+  | Private_variant _ -> ()
+  | Private_object _ -> ()
+  | Variance -> pr "Their variances do not agree."
+  | Record_mismatch err -> report_record_mismatch first second decl ppf err
+  | Variant_mismatch err -> report_variant_mismatch first second decl ppf err
+  | Unboxed_representation ord ->
+      pr "Their internal representations differ:@ %s %s %s."
+         (choose ord first second) decl
+         "uses unboxed representation"
+  | Immediate violation ->
+      let first = StringLabels.capitalize_ascii first in
+      match violation with
+      | Type_immediacy.Violation.Not_always_immediate ->
+          pr "%s is not an immediate type." first
+      | Type_immediacy.Violation.Not_always_immediate_on_64bits ->
+          pr "%s is not a type that is always immediate on 64 bit platforms."
+            first
+
+let report_type_mismatch first second decl ppf err =
+  match err with
+  | Manifest _ -> ()
+  | Private_variant _ -> ()
+  | Private_object _ -> ()
+  | _ -> Format.fprintf ppf "@ %a" (report_type_mismatch0 first second decl) err
+
+let rec compare_constructor_arguments ~loc env params1 params2 arg1 arg2 =
+  match arg1, arg2 with
+  | Types.Cstr_tuple arg1, Types.Cstr_tuple arg2 ->
+      if List.length arg1 <> List.length arg2 then
+        Some (Arity : constructor_mismatch)
+      else begin
+        (* Ctype.equal must be called on all arguments at once, cf. PR#7378 *)
+        match Ctype.equal env true (params1 @ arg1) (params2 @ arg2) with
+        | exception Ctype.Equality trace -> Some (Type (env, trace))
+        | () -> None
+      end
+  | Types.Cstr_record l1, Types.Cstr_record l2 ->
+      Option.map
+        (fun rec_err -> Inline_record rec_err)
+        (compare_records env ~loc params1 params2 0 l1 l2)
+  | Types.Cstr_record _, _ -> Some (Kind First : constructor_mismatch)
+  | _, Types.Cstr_record _ -> Some (Kind Second : constructor_mismatch)
+
+and compare_constructors ~loc env params1 params2 res1 res2 args1 args2 =
+  match res1, res2 with
+  | Some r1, Some r2 -> begin
+      match Ctype.equal env true [r1] [r2] with
+      | exception Ctype.Equality trace -> Some (Type (env, trace))
+      | () -> compare_constructor_arguments ~loc env [r1] [r2] args1 args2
+    end
+  | Some _, None -> Some (Explicit_return_type First)
+  | None, Some _ -> Some (Explicit_return_type Second)
+  | None, None ->
+      compare_constructor_arguments ~loc env params1 params2 args1 args2
+
+and compare_variants ~loc env params1 params2 n
+    (cstrs1 : Types.constructor_declaration list)
+    (cstrs2 : Types.constructor_declaration list) =
+  match cstrs1, cstrs2 with
+  | [], []   -> None
+  | [], c::_ -> Some (Constructor_missing (Second, c.Types.cd_id))
+  | c::_, [] -> Some (Constructor_missing (First, c.Types.cd_id))
+  | cd1::rem1, cd2::rem2 ->
+      if Ident.name cd1.cd_id <> Ident.name cd2.cd_id then
+        Some (Constructor_names (n, cd1.cd_id, cd2.cd_id))
+      else begin
+        Builtin_attributes.check_alerts_inclusion
+          ~def:cd1.cd_loc
+          ~use:cd2.cd_loc
+          loc
+          cd1.cd_attributes cd2.cd_attributes
+          (Ident.name cd1.cd_id);
+        match compare_constructors ~loc env params1 params2
+                cd1.cd_res cd2.cd_res cd1.cd_args cd2.cd_args with
+        | Some r ->
+            Some ((Constructor_mismatch (cd1, cd2, r)) : variant_mismatch)
+        | None -> compare_variants ~loc env params1 params2 (n+1) rem1 rem2
+      end
+
+and compare_variants_with_representation ~loc env params1 params2 n
+      cstrs1 cstrs2 rep1 rep2
+  =
+  let err = compare_variants ~loc env params1 params2 n cstrs1 cstrs2 in
+  match err, rep1, rep2 with
+  | None, Variant_regular, Variant_regular
+  | None, Variant_unboxed, Variant_unboxed ->
+     None
+  | Some err, _, _ ->
+     Some (Variant_mismatch err)
+  | None, Variant_unboxed, Variant_regular ->
+     Some (Unboxed_representation First)
+  | None, Variant_regular, Variant_unboxed ->
+     Some (Unboxed_representation Second)
+
+and compare_labels env params1 params2
+      (ld1 : Types.label_declaration) (ld2 : Types.label_declaration) =
+  if ld1.ld_mutable <> ld2.ld_mutable then begin
+    let ord = if ld1.ld_mutable = Asttypes.Mutable then First else Second in
+    Some (Mutability  ord)
+  end else begin
+    let tl1 = params1 @ [ld1.ld_type] in
+    let tl2 = params2 @ [ld2.ld_type] in
+    match Ctype.equal env true tl1 tl2 with
+    | exception Ctype.Equality trace ->
+        Some (Type (env, trace) : label_mismatch)
+    | () -> None
+  end
+
+and compare_records ~loc env params1 params2 n
+    (labels1 : Types.label_declaration list)
+    (labels2 : Types.label_declaration list) =
+  match labels1, labels2 with
+  | [], []           -> None
+  | [], l::_ -> Some (Label_missing (Second, l.Types.ld_id))
+  | l::_, [] -> Some (Label_missing (First, l.Types.ld_id))
+  | ld1::rem1, ld2::rem2 ->
+      if Ident.name ld1.ld_id <> Ident.name ld2.ld_id
+      then Some (Label_names (n, ld1.ld_id, ld2.ld_id))
+      else begin
+        Builtin_attributes.check_deprecated_mutable_inclusion
+          ~def:ld1.ld_loc
+          ~use:ld2.ld_loc
+          loc
+          ld1.ld_attributes ld2.ld_attributes
+          (Ident.name ld1.ld_id);
+        match compare_labels env params1 params2 ld1 ld2 with
+        | Some r -> Some (Label_mismatch (ld1, ld2, r))
+        (* add arguments to the parameters, cf. PR#7378 *)
+        | None -> compare_records ~loc env
+                    (ld1.ld_type::params1) (ld2.ld_type::params2)
+                    (n+1)
+                    rem1 rem2
+      end
+
+let compare_records_with_representation ~loc env params1 params2 n
+      labels1 labels2 rep1 rep2
+  =
+  match compare_records ~loc env params1 params2 n labels1 labels2 with
+  | Some err -> Some (Record_mismatch err)
+  | None ->
+     match rep1, rep2 with
+     | Record_unboxed _, Record_unboxed _ -> None
+     | Record_unboxed _, _ -> Some (Unboxed_representation First)
+     | _, Record_unboxed _ -> Some (Unboxed_representation Second)
+
+     | Record_float, Record_float -> None
+     | Record_float, _ ->
+        Some (Record_mismatch (Unboxed_float_representation First))
+     | _, Record_float ->
+        Some (Record_mismatch (Unboxed_float_representation Second))
+
+     | Record_regular, Record_regular
+     | Record_inlined _, Record_inlined _
+     | Record_extension _, Record_extension _ -> None
+     | (Record_regular|Record_inlined _|Record_extension _),
+       (Record_regular|Record_inlined _|Record_extension _) ->
+        assert false
+
+let private_variant env row1 params1 row2 params2 =
+    let r1, r2, pairs =
+      Ctype.merge_row_fields row1.row_fields row2.row_fields
+    in
+    let err =
+      if row2.row_closed && not row1.row_closed then Some Openness
+      else begin
+        match row2.row_closed, Ctype.filter_row_fields false r1 with
+        | true, (s, _) :: _ ->
+            Some (Missing (Second, s) : private_variant_mismatch)
+        | _, _ -> None
+      end
+    in
+    if err <> None then err else
+    let err =
+      let missing =
+        List.find_opt
+          (fun (_,f) ->
+             match Btype.row_field_repr f with
+             | Rabsent | Reither _ -> false
+             | Rpresent _ -> true)
+          r2
+      in
+      match missing with
+      | None -> None
+      | Some (s, _) -> Some (Missing (First, s) : private_variant_mismatch)
+    in
+    if err <> None then err else
+    let rec loop tl1 tl2 pairs =
+      match pairs with
+      | [] -> begin
+          match Ctype.equal env true tl1 tl2 with
+          | exception Ctype.Equality trace ->
+              Some (Types (env, trace) : private_variant_mismatch)
+          | () -> None
+        end
+      | (s, f1, f2) :: pairs -> begin
+          match Btype.row_field_repr f1, Btype.row_field_repr f2 with
+          | Rpresent to1, Rpresent to2 -> begin
+              match to1, to2 with
+              | Some t1, Some t2 ->
+                  loop (t1 :: tl1) (t2 :: tl2) pairs
+              | None, None ->
+                  loop tl1 tl2 pairs
+              | Some _, None | None, Some _ ->
+                  Some (Incompatible_types_for s)
+            end
+          | Rpresent to1, Reither(const2, ts2, _, _) -> begin
+              match to1, const2, ts2 with
+              | Some t1, false, [t2] -> loop (t1 :: tl1) (t2 :: tl2) pairs
+              | None, true, [] -> loop tl1 tl2 pairs
+              | _, _, _ -> Some (Incompatible_types_for s)
+            end
+          | Rpresent _, Rabsent ->
+              Some (Missing (Second, s) : private_variant_mismatch)
+          | Reither(const1, ts1, _, _), Reither(const2, ts2, _, _) ->
+              if const1 = const2 && List.length ts1 = List.length ts2 then
+                loop (ts1 @ tl1) (ts2 @ tl2) pairs
+              else
+                Some (Incompatible_types_for s)
+          | Reither _, Rpresent _ ->
+              Some (Presence s)
+          | Reither _, Rabsent ->
+              Some (Missing (Second, s) : private_variant_mismatch)
+          | Rabsent, (Reither _ | Rabsent) ->
+              loop tl1 tl2 pairs
+          | Rabsent, Rpresent _ ->
+              Some (Missing (First, s) : private_variant_mismatch)
+        end
+    in
+    loop params1 params2 pairs
+
+let private_object env fields1 params1 fields2 params2 =
+  let pairs, _miss1, miss2 = Ctype.associate_fields fields1 fields2 in
+  let err =
+    match miss2 with
+    | [] -> None
+    | (f, _, _) :: _ -> Some (Missing f)
+  in
+  if err <> None then err else
+  let tl1, tl2 =
+    List.split (List.map (fun (_,_,t1,_,t2) -> t1, t2) pairs)
+  in
+  begin
+    match Ctype.equal env true (params1 @ tl1) (params2 @ tl2) with
+    | exception Ctype.Equality trace -> Some (Types (env, trace))
+    | () -> None
+  end
+
+let type_manifest env ty1 params1 ty2 params2 priv2 =
+  let ty1' = Ctype.expand_head env ty1 and ty2' = Ctype.expand_head env ty2 in
+  match ty1'.desc, ty2'.desc with
+  | Tvariant row1, Tvariant row2
+    when is_absrow env (Btype.row_more row2) -> begin
+      let row1 = Btype.row_repr row1 and row2 = Btype.row_repr row2 in
+      assert (Ctype.is_equal env true (ty1::params1) (row2.row_more::params2));
+      match private_variant env row1 params1 row2 params2 with
+      | None -> None
+      | Some err -> Some (Private_variant(ty1, ty2, err))
+    end
+  | Tobject (fi1, _), Tobject (fi2, _)
+    when is_absrow env (snd (Ctype.flatten_fields fi2)) -> begin
+      let (fields2,rest2) = Ctype.flatten_fields fi2 in
+      let (fields1,_) = Ctype.flatten_fields fi1 in
+      assert (Ctype.is_equal env true (ty1::params1) (rest2::params2));
+      match private_object env fields1 params1 fields2 params2 with
+      | None -> None
+      | Some err -> Some (Private_object(ty1, ty2, err))
+    end
+  | _ -> begin
+    match
+      match priv2 with
+      | Private -> Ctype.equal_private env params1 ty1 params2 ty2
+      | Public -> Ctype.equal env true (params1 @ [ty1]) (params2 @ [ty2])
+    with
+    | exception Ctype.Equality trace -> Some (Manifest (env, trace))
+    | () -> None
+  end
+
+let type_declarations ?(equality = false) ~loc env ~mark name
+      decl1 path decl2 =
+  Builtin_attributes.check_alerts_inclusion
+    ~def:decl1.type_loc
+    ~use:decl2.type_loc
+    loc
+    decl1.type_attributes decl2.type_attributes
+    name;
+  if decl1.type_arity <> decl2.type_arity then Some Arity else
+  if not (private_flags decl1 decl2) then Some Privacy else
+  let err = match (decl1.type_manifest, decl2.type_manifest) with
+      (_, None) ->
+        begin
+          match Ctype.equal env true decl1.type_params decl2.type_params with
+          | exception Ctype.Equality trace -> Some (Constraint(env, trace))
+          | () -> None
+        end
+    | (Some ty1, Some ty2) ->
+         type_manifest env ty1 decl1.type_params ty2 decl2.type_params
+           decl2.type_private
+    | (None, Some ty2) ->
+        let ty1 =
+          Btype.newgenty (Tconstr(path, decl2.type_params, ref Mnil))
+        in
+        match Ctype.equal env true decl1.type_params decl2.type_params with
+        | exception Ctype.Equality trace -> Some (Constraint(env, trace))
+        | () ->
+          match Ctype.equal env false [ty1] [ty2] with
+          | exception Ctype.Equality trace -> Some (Manifest(env, trace))
+          | () -> None
+  in
+  if err <> None then err else
+  let err = match (decl1.type_kind, decl2.type_kind) with
+      (_, Type_abstract) -> None
+    | (Type_variant (cstrs1, rep1), Type_variant (cstrs2, rep2)) ->
+        if mark then begin
+          let mark usage cstrs =
+            List.iter (Env.mark_constructor_used usage) cstrs
+          in
+          let usage : Env.constructor_usage =
+            if decl2.type_private = Public then Env.Exported
+            else Env.Exported_private
+          in
+          mark usage cstrs1;
+          if equality then mark Env.Exported cstrs2
+        end;
+        compare_variants_with_representation ~loc env
+          decl1.type_params decl2.type_params 1
+          cstrs1 cstrs2
+          rep1 rep2
+    | (Type_record(labels1,rep1), Type_record(labels2,rep2)) ->
+        if mark then begin
+          let mark usage lbls =
+            List.iter (Env.mark_label_used usage) lbls
+          in
+          let usage : Env.label_usage =
+            if decl2.type_private = Public then Env.Exported
+            else Env.Exported_private
+          in
+          mark usage labels1;
+          if equality then mark Env.Exported labels2
+        end;
+        compare_records_with_representation ~loc env
+          decl1.type_params decl2.type_params 1
+          labels1 labels2
+          rep1 rep2
+    | (Type_open, Type_open) -> None
+    | (_, _) -> Some Kind
+  in
+  if err <> None then err else
+  let abstr = decl2.type_kind = Type_abstract && decl2.type_manifest = None in
+  (* If attempt to assign a non-immediate type (e.g. string) to a type that
+   * must be immediate, then we error *)
+  let err =
+    if not abstr then
+      None
+    else
+      match
+        Type_immediacy.coerce decl1.type_immediate ~as_:decl2.type_immediate
+      with
+      | Ok () -> None
+      | Error violation -> Some (Immediate violation)
+  in
+  if err <> None then err else
+  let need_variance =
+    abstr || decl1.type_private = Private || decl1.type_kind = Type_open in
+  if not need_variance then None else
+  let abstr = abstr || decl2.type_private = Private in
+  let opn = decl2.type_kind = Type_open && decl2.type_manifest = None in
+  let constrained ty = not (Btype.(is_Tvar (repr ty))) in
+  if List.for_all2
+      (fun ty (v1,v2) ->
+        let open Variance in
+        let imp a b = not a || b in
+        let (co1,cn1) = get_upper v1 and (co2,cn2) = get_upper v2 in
+        (if abstr then (imp co1 co2 && imp cn1 cn2)
+         else if opn || constrained ty then (co1 = co2 && cn1 = cn2)
+         else true) &&
+        let (p1,n1,i1,j1) = get_lower v1 and (p2,n2,i2,j2) = get_lower v2 in
+        imp abstr (imp p2 p1 && imp n2 n1 && imp i2 i1 && imp j2 j1))
+      decl2.type_params (List.combine decl1.type_variance decl2.type_variance)
+  then None else Some Variance
+
+(* Inclusion between extension constructors *)
+
+let extension_constructors ~loc env ~mark id ext1 ext2 =
+  if mark then begin
+    let usage : Env.constructor_usage =
+      if ext2.ext_private = Public then Env.Exported
+      else Env.Exported_private
+    in
+    Env.mark_extension_used usage ext1
+  end;
+  let ty1 =
+    Btype.newgenty (Tconstr(ext1.ext_type_path, ext1.ext_type_params, ref Mnil))
+  in
+  let ty2 =
+    Btype.newgenty (Tconstr(ext2.ext_type_path, ext2.ext_type_params, ref Mnil))
+  in
+  let tl1 = ty1 :: ext1.ext_type_params in
+  let tl2 = ty2 :: ext2.ext_type_params in
+  match Ctype.equal env true tl1 tl2 with
+  | exception Ctype.Equality trace ->
+      Some (Constructor_mismatch (id, ext1, ext2, Type(env, trace)))
+  | () ->
+    let r =
+      compare_constructors ~loc env
+        ext1.ext_type_params ext2.ext_type_params
+        ext1.ext_ret_type ext2.ext_ret_type
+        ext1.ext_args ext2.ext_args
+    in
+    match r with
+    | Some r -> Some (Constructor_mismatch (id, ext1, ext2, r))
+    | None ->
+      match ext1.ext_private, ext2.ext_private with
+      | Private, Public -> Some Constructor_privacy
+      | _, _ -> None
diff --git a/src/ocaml/typing/includecore.mli b/src/ocaml/typing/includecore.mli
new file mode 100644
index 0000000..95bcbb2
--- /dev/null
+++ b/src/ocaml/typing/includecore.mli
@@ -0,0 +1,116 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the core language *)
+
+open Typedtree
+open Types
+
+type position = Errortrace.position = First | Second
+
+type primitive_mismatch =
+  | Name
+  | Arity
+  | No_alloc of position
+  | Native_name
+  | Result_repr
+  | Argument_repr of int
+
+type value_mismatch =
+  | Primitive_mismatch of primitive_mismatch
+  | Not_a_primitive
+  | Type of Env.t * Errortrace.comparison Errortrace.t
+
+exception Dont_match of value_mismatch
+
+type label_mismatch =
+  | Type of Env.t * Errortrace.comparison Errortrace.t
+  | Mutability of position
+
+type record_mismatch =
+  | Label_mismatch of label_declaration * label_declaration * label_mismatch
+  | Label_names of int * Ident.t * Ident.t
+  | Label_missing of position * Ident.t
+  | Unboxed_float_representation of position
+
+type constructor_mismatch =
+  | Type of Env.t * Errortrace.comparison Errortrace.t
+  | Arity
+  | Inline_record of record_mismatch
+  | Kind of position
+  | Explicit_return_type of position
+
+type variant_mismatch =
+  | Constructor_mismatch of constructor_declaration
+                            * constructor_declaration
+                            * constructor_mismatch
+  | Constructor_names of int * Ident.t * Ident.t
+  | Constructor_missing of position * Ident.t
+
+type extension_constructor_mismatch =
+  | Constructor_privacy
+  | Constructor_mismatch of Ident.t
+                            * extension_constructor
+                            * extension_constructor
+                            * constructor_mismatch
+
+type private_variant_mismatch =
+  | Openness
+  | Missing of position * string
+  | Presence of string
+  | Incompatible_types_for of string
+  | Types of Env.t * Errortrace.comparison Errortrace.t
+
+type private_object_mismatch =
+  | Missing of string
+  | Types of Env.t * Errortrace.comparison Errortrace.t
+
+type type_mismatch =
+  | Arity
+  | Privacy
+  | Kind
+  | Constraint of Env.t * Errortrace.comparison Errortrace.t
+  | Manifest of Env.t * Errortrace.comparison Errortrace.t
+  | Private_variant of type_expr * type_expr * private_variant_mismatch
+  | Private_object of type_expr * type_expr * private_object_mismatch
+  | Variance
+  | Record_mismatch of record_mismatch
+  | Variant_mismatch of variant_mismatch
+  | Unboxed_representation of position
+  | Immediate of Type_immediacy.Violation.t
+
+val value_descriptions:
+  loc:Location.t -> Env.t -> string ->
+  value_description -> value_description -> module_coercion
+
+val type_declarations:
+  ?equality:bool ->
+  loc:Location.t ->
+  Env.t -> mark:bool -> string ->
+  type_declaration -> Path.t -> type_declaration -> type_mismatch option
+
+val extension_constructors:
+  loc:Location.t -> Env.t -> mark:bool -> Ident.t ->
+  extension_constructor -> extension_constructor ->
+  extension_constructor_mismatch option
+(*
+val class_types:
+        Env.t -> class_type -> class_type -> bool
+*)
+
+val report_type_mismatch:
+    string -> string -> string -> Format.formatter -> type_mismatch -> unit
+val report_extension_constructor_mismatch: string -> string -> string ->
+  Format.formatter -> extension_constructor_mismatch -> unit
diff --git a/src/ocaml/typing/includemod.ml b/src/ocaml/typing/includemod.ml
new file mode 100644
index 0000000..ca448fa
--- /dev/null
+++ b/src/ocaml/typing/includemod.ml
@@ -0,0 +1,1027 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the module language *)
+
+open Misc
+open Typedtree
+open Types
+
+type symptom =
+    Missing_field of Ident.t * Location.t * string (* kind *)
+  | Value_descriptions of Ident.t * value_description * value_description
+                          * Includecore.value_mismatch
+  | Type_declarations of Ident.t * type_declaration
+        * type_declaration * Includecore.type_mismatch
+  | Extension_constructors of Ident.t * extension_constructor
+        * extension_constructor * Includecore.extension_constructor_mismatch
+  | Module_types of module_type * module_type
+  | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration
+  | Modtype_permutation of Types.module_type * Typedtree.module_coercion
+  | Interface_mismatch of string * string
+  | Class_type_declarations of
+      Ident.t * class_type_declaration * class_type_declaration *
+      Ctype.class_match_failure list
+  | Class_declarations of
+      Ident.t * class_declaration * class_declaration *
+      Ctype.class_match_failure list
+  | Unbound_module_path of Path.t
+  | Invalid_module_alias of Path.t
+
+type pos =
+  | Module of Ident.t
+  | Modtype of Ident.t
+  | Arg of functor_parameter
+  | Body of functor_parameter
+
+
+module Error = struct
+
+  type functor_arg_descr =
+    | Anonymous
+    | Named of Path.t
+    | Unit
+
+  type ('a,'b) diff = {got:'a; expected:'a; symptom:'b}
+  type 'a core_diff =('a,unit) diff
+  let diff x y s = {got=x;expected=y; symptom=s}
+  let sdiff x y = {got=x; expected=y; symptom=()}
+
+  type core_sigitem_symptom =
+    | Value_descriptions of value_description core_diff
+    | Type_declarations of (type_declaration, Includecore.type_mismatch) diff
+    | Extension_constructors of
+        (extension_constructor, Includecore.extension_constructor_mismatch) diff
+    | Class_type_declarations of
+        (class_type_declaration, Ctype.class_match_failure list) diff
+    | Class_declarations of
+        (class_declaration, Ctype.class_match_failure list) diff
+
+  type core_module_type_symptom =
+    | Not_an_alias
+    | Not_an_identifier
+    | Incompatible_aliases
+    | Abstract_module_type
+    | Unbound_module_path of Path.t
+
+  type module_type_symptom =
+    | Mt_core of core_module_type_symptom
+    | Signature of signature_symptom
+    | Functor of functor_symptom
+    | Invalid_module_alias of Path.t
+    | After_alias_expansion of module_type_diff
+
+
+  and module_type_diff = (module_type, module_type_symptom) diff
+
+  and functor_symptom =
+    | Params of functor_params_diff
+    | Result of module_type_diff
+
+  and ('arg,'path) functor_param_symptom =
+    | Incompatible_params of 'arg * functor_parameter
+    | Mismatch of module_type_diff
+
+  and arg_functor_param_symptom =
+    (functor_parameter, Ident.t) functor_param_symptom
+
+  and functor_params_diff = (functor_parameter list * module_type) core_diff
+
+  and signature_symptom = {
+    env: Env.t;
+    missings: signature_item list;
+    incompatibles: (Ident.t * sigitem_symptom) list;
+    oks: (int * module_coercion) list;
+  }
+  and sigitem_symptom =
+    | Core of core_sigitem_symptom
+    | Module_type_declaration of
+        (modtype_declaration, module_type_declaration_symptom) diff
+    | Module_type of module_type_diff
+
+  and module_type_declaration_symptom =
+    | Illegal_permutation of Typedtree.module_coercion
+    | Not_greater_than of module_type_diff
+    | Not_less_than of module_type_diff
+    | Incomparable of
+        {less_than:module_type_diff; greater_than: module_type_diff}
+
+
+  type all =
+    | In_Compilation_unit of (string, signature_symptom) diff
+    | In_Signature of signature_symptom
+    | In_Module_type of module_type_diff
+    | In_Module_type_substitution of
+        Ident.t * (Types.module_type,module_type_declaration_symptom) diff
+    | In_Type_declaration of Ident.t * core_sigitem_symptom
+    | In_Expansion of core_module_type_symptom
+
+end
+
+type mark =
+  | Mark_both
+  | Mark_positive
+  | Mark_negative
+  | Mark_neither
+
+let negate_mark = function
+  | Mark_both -> Mark_both
+  | Mark_positive -> Mark_negative
+  | Mark_negative -> Mark_positive
+  | Mark_neither -> Mark_neither
+
+let mark_positive = function
+  | Mark_both | Mark_positive -> true
+  | Mark_negative | Mark_neither -> false
+
+(* All functions "blah env x1 x2" check that x1 is included in x2,
+   i.e. that x1 is the type of an implementation that fulfills the
+   specification x2. If not, Error is raised with a backtrace of the error. *)
+
+(* Inclusion between value descriptions *)
+
+let value_descriptions ~loc env ~mark subst id vd1 vd2 =
+  Cmt_format.record_value_dependency vd1 vd2;
+  if mark_positive mark then
+    Env.mark_value_used vd1.val_uid;
+  let vd2 = Subst.value_description subst vd2 in
+  try
+    Ok (Includecore.value_descriptions ~loc env (Ident.name id) vd1 vd2)
+  with Includecore.Dont_match _err ->
+    Error Error.(Core (Value_descriptions (sdiff vd1 vd2)))
+
+(* Inclusion between type declarations *)
+
+let type_declarations ~loc env ~mark ?old_env:_ subst id decl1 decl2 =
+  let mark = mark_positive mark in
+  if mark then
+    Env.mark_type_used decl1.type_uid;
+  let decl2 = Subst.type_declaration subst decl2 in
+  match
+    Includecore.type_declarations ~loc env ~mark
+      (Ident.name id) decl1 (Path.Pident id) decl2
+  with
+  | None -> Ok Tcoerce_none
+  | Some err ->
+      Error Error.(Core(Type_declarations (diff decl1 decl2 err)))
+
+(* Inclusion between extension constructors *)
+
+let extension_constructors ~loc env ~mark  subst id ext1 ext2 =
+  let mark = mark_positive mark in
+  let ext2 = Subst.extension_constructor subst ext2 in
+  match Includecore.extension_constructors ~loc env ~mark id ext1 ext2 with
+  | None -> Ok Tcoerce_none
+  | Some err ->
+      Error Error.(Core(Extension_constructors(diff ext1 ext2 err)))
+
+(* Inclusion between class declarations *)
+
+let class_type_declarations ~loc ~old_env:_ env  subst decl1 decl2 =
+  let decl2 = Subst.cltype_declaration subst decl2 in
+  match Includeclass.class_type_declarations ~loc env decl1 decl2 with
+    []     -> Ok Tcoerce_none
+  | reason ->
+      Error Error.(Core(Class_type_declarations(diff decl1 decl2 reason)))
+
+let class_declarations ~old_env:_ env  subst decl1 decl2 =
+  let decl2 = Subst.class_declaration subst decl2 in
+  match Includeclass.class_declarations env decl1 decl2 with
+    []     -> Ok Tcoerce_none
+  | reason ->
+     Error Error.(Core(Class_declarations(diff decl1 decl2 reason)))
+
+(* Expand a module type identifier when possible *)
+
+let expand_modtype_path env path =
+   match Env.find_modtype_expansion path env with
+     | exception Not_found -> None
+     | x -> Some x
+
+let expand_module_alias env path =
+  match (Env.find_module path env).md_type with
+  | x -> Ok x
+  | exception Not_found -> Error (Error.Unbound_module_path path)
+
+(* Extract name, kind and ident from a signature item *)
+
+type field_kind =
+  | Field_value
+  | Field_type
+  | Field_exception
+  | Field_typext
+  | Field_module
+  | Field_modtype
+  | Field_class
+  | Field_classtype
+
+
+
+type field_desc = { name: string; kind: field_kind }
+
+let kind_of_field_desc fd = match fd.kind with
+  | Field_value -> "value"
+  | Field_type -> "type"
+  | Field_exception -> "exception"
+  | Field_typext -> "extension constructor"
+  | Field_module -> "module"
+  | Field_modtype -> "module type"
+  | Field_class -> "class"
+  | Field_classtype -> "class type"
+
+let field_desc kind id = { kind; name = Ident.name id }
+
+(** Map indexed by both field types and names.
+    This avoids name clashes between different sorts of fields
+    such as values and types. *)
+module FieldMap = Map.Make(struct
+    type t = field_desc
+    let compare = Stdlib.compare
+  end)
+
+let item_ident_name = function
+    Sig_value(id, d, _) -> (id, d.val_loc, field_desc Field_value id)
+  | Sig_type(id, d, _, _) -> (id, d.type_loc, field_desc Field_type  id )
+  | Sig_typext(id, d, _, _) ->
+      let kind =
+        if Path.same d.ext_type_path Predef.path_exn
+        then Field_exception
+        else Field_typext
+      in
+      (id, d.ext_loc, field_desc kind id)
+  | Sig_module(id, _, d, _, _) -> (id, d.md_loc, field_desc Field_module id)
+  | Sig_modtype(id, d, _) -> (id, d.mtd_loc, field_desc Field_modtype id)
+  | Sig_class(id, d, _, _) -> (id, d.cty_loc, field_desc Field_class id)
+  | Sig_class_type(id, d, _, _) ->
+      (id, d.clty_loc, field_desc Field_classtype id)
+
+let is_runtime_component = function
+  | Sig_value(_,{val_kind = Val_prim _}, _)
+  | Sig_type(_,_,_,_)
+  | Sig_module(_,Mp_absent,_,_,_)
+  | Sig_modtype(_,_,_)
+  | Sig_class_type(_,_,_,_) -> false
+  | Sig_value(_,_,_)
+  | Sig_typext(_,_,_,_)
+  | Sig_module(_,Mp_present,_,_,_)
+  | Sig_class(_,_,_,_) -> true
+
+(* Print a coercion *)
+
+let rec print_list pr ppf = function
+    [] -> ()
+  | [a] -> pr ppf a
+  | a :: l -> pr ppf a; Format.fprintf ppf ";@ "; print_list pr ppf l
+let print_list pr ppf l =
+  Format.fprintf ppf "[@[%a@]]" (print_list pr) l
+
+let rec print_coercion ppf c =
+  let pr fmt = Format.fprintf ppf fmt in
+  match c with
+    Tcoerce_none -> pr "id"
+  | Tcoerce_structure (fl, nl) ->
+      pr "@[<2>struct@ %a@ %a@]"
+        (print_list print_coercion2) fl
+        (print_list print_coercion3) nl
+  | Tcoerce_functor (inp, out) ->
+      pr "@[<2>functor@ (%a)@ (%a)@]"
+        print_coercion inp
+        print_coercion out
+  | Tcoerce_primitive {pc_desc; pc_env = _; pc_type}  ->
+      pr "prim %s@ (%a)" pc_desc.Primitive.prim_name
+        Printtyp.raw_type_expr pc_type
+  | Tcoerce_alias (_, p, c) ->
+      pr "@[<2>alias %a@ (%a)@]"
+        Printtyp.path p
+        print_coercion c
+and print_coercion2 ppf (n, c) =
+  Format.fprintf ppf "@[%d,@ %a@]" n print_coercion c
+and print_coercion3 ppf (i, n, c) =
+  Format.fprintf ppf "@[%s, %d,@ %a@]"
+    (Ident.unique_name i) n print_coercion c
+
+(* Simplify a structure coercion *)
+
+let equal_module_paths env p1 subst p2 =
+  Path.same p1 p2
+  || Path.same (Env.normalize_module_path None env p1)
+       (Env.normalize_module_path None env
+          (Subst.module_path subst p2))
+
+let equal_modtype_paths env p1 subst p2 =
+  Path.same p1 p2
+  || Path.same (Env.normalize_modtype_path env p1)
+       (Env.normalize_modtype_path env
+          (Subst.modtype_path subst p2))
+
+let simplify_structure_coercion cc id_pos_list =
+  let rec is_identity_coercion pos = function
+  | [] ->
+      true
+  | (n, c) :: rem ->
+      n = pos && c = Tcoerce_none && is_identity_coercion (pos + 1) rem in
+  if is_identity_coercion 0 cc
+  then Tcoerce_none
+  else Tcoerce_structure (cc, id_pos_list)
+
+let retrieve_functor_params env mty =
+  let rec retrieve_functor_params before env =
+    function
+    | Mty_ident p as res ->
+        begin match expand_modtype_path env p with
+        | Some mty -> retrieve_functor_params before env mty
+        | None -> List.rev before, res
+        end
+    | Mty_alias p as res ->
+        begin match expand_module_alias env p with
+        | Ok mty ->  retrieve_functor_params before env mty
+        | Error _ -> List.rev before, res
+        end
+    | Mty_functor (p, res) -> retrieve_functor_params (p :: before) env res
+    | Mty_signature _ as res -> List.rev before, res
+    | Mty_for_hole as res -> List.rev before, res
+  in
+  retrieve_functor_params [] env mty
+
+(* Inclusion between module types.
+   Return the restriction that transforms a value of the smaller type
+   into a value of the bigger type. *)
+
+let rec modtypes ~loc env ~mark subst mty1 mty2 =
+  match try_modtypes ~loc env ~mark subst mty1 mty2 with
+  | Ok _ as ok -> ok
+  | Error reason ->
+    let mty2 = Subst.modtype Make_local subst mty2 in
+    Error Error.(diff mty1 mty2 reason)
+
+and try_modtypes ~loc env ~mark subst mty1 mty2 =
+  match mty1, mty2 with
+  | (Mty_alias p1, Mty_alias p2) ->
+      if Env.is_functor_arg p2 env then
+        Error (Error.Invalid_module_alias p2)
+      else if not (equal_module_paths env p1 subst p2) then
+          Error Error.(Mt_core Incompatible_aliases)
+      else Ok Tcoerce_none
+  | (Mty_alias p1, _) -> begin
+      match
+        Env.normalize_module_path (Some Location.none) env p1
+      with
+      | exception Env.Error (Env.Missing_module (_, _, path)) ->
+          Error Error.(Mt_core(Unbound_module_path path))
+      | p1 ->
+          begin match expand_module_alias env  p1 with
+          | Error e -> Error (Error.Mt_core e)
+          | Ok mty1 ->
+              match strengthened_modtypes ~loc ~aliasable:true env ~mark
+                      subst mty1 p1 mty2
+              with
+              | Ok _ as x -> x
+              | Error reason -> Error (Error.After_alias_expansion reason)
+          end
+    end
+  | (Mty_ident p1, Mty_ident p2) ->
+      let p1 = Env.normalize_modtype_path env p1 in
+      let p2 = Env.normalize_modtype_path env (Subst.modtype_path subst p2) in
+      if Path.same p1 p2 then Ok Tcoerce_none
+      else
+        begin match expand_modtype_path env p1, expand_modtype_path env p2 with
+        | Some mty1, Some mty2 ->
+            try_modtypes ~loc env ~mark subst mty1 mty2
+        | None, _  | _, None -> Error (Error.Mt_core Abstract_module_type)
+        end
+  | (Mty_ident p1, _) ->
+      let p1 = Env.normalize_modtype_path env p1 in
+      begin match expand_modtype_path env p1 with
+      | Some p1 ->
+          try_modtypes ~loc env ~mark subst p1 mty2
+      | None -> Error (Error.Mt_core Abstract_module_type)
+      end
+  | (_, Mty_ident p2) ->
+      let p2 = Env.normalize_modtype_path env (Subst.modtype_path subst p2) in
+      begin match expand_modtype_path env p2 with
+      | Some p2 -> try_modtypes ~loc env ~mark subst mty1 p2
+      | None ->
+          begin match mty1 with
+          | Mty_functor _ ->
+              let params1 = retrieve_functor_params env mty1 in
+              let d = Error.sdiff params1 ([],mty2) in
+              Error Error.(Functor (Params d))
+          | _ -> Error Error.(Mt_core Not_an_identifier)
+          end
+      end
+  | (Mty_signature sig1, Mty_signature sig2) ->
+      begin match signatures ~loc env ~mark subst sig1 sig2 with
+      | Ok _ as ok -> ok
+      | Error e -> Error (Error.Signature e)
+      end
+  | Mty_functor (param1, res1), Mty_functor (param2, res2) ->
+      let cc_arg, env, subst =
+        functor_param ~loc env ~mark:(negate_mark mark) subst param1 param2
+      in
+      let cc_res = modtypes ~loc env ~mark subst res1 res2 in
+      begin match cc_arg, cc_res with
+      | Ok Tcoerce_none, Ok Tcoerce_none -> Ok Tcoerce_none
+      | Ok cc_arg, Ok cc_res -> Ok (Tcoerce_functor(cc_arg, cc_res))
+      | _, Error {Error.symptom = Error.Functor Error.Params res; _} ->
+          let got_params, got_res = res.got in
+          let expected_params, expected_res = res.expected in
+          let d = Error.sdiff
+              (param1::got_params, got_res)
+              (param2::expected_params, expected_res) in
+          Error Error.(Functor (Params d))
+      | Error _, _ ->
+          let params1, res1 = retrieve_functor_params env res1 in
+          let params2, res2 = retrieve_functor_params env res2 in
+          let d = Error.sdiff (param1::params1, res1) (param2::params2, res2) in
+          Error Error.(Functor (Params d))
+      | Ok _, Error res ->
+          Error Error.(Functor (Result res))
+      end
+  | Mty_functor _, _
+  | _, Mty_functor _ ->
+      let params1 = retrieve_functor_params env mty1 in
+      let params2 = retrieve_functor_params env mty2 in
+      let d = Error.sdiff params1 params2 in
+      Error Error.(Functor (Params d))
+  | Mty_for_hole, _ | _, Mty_for_hole ->
+      Ok Tcoerce_none
+  | _, Mty_alias _ ->
+      Error (Error.Mt_core Error.Not_an_alias)
+
+(* Functor parameters *)
+
+and functor_param ~loc env ~mark subst param1 param2 = match param1, param2 with
+  | Unit, Unit ->
+      Ok Tcoerce_none, env, subst
+  | Named (name1, arg1), Named (name2, arg2) ->
+      let arg2' = Subst.modtype Keep subst arg2 in
+      let cc_arg =
+        match modtypes ~loc env ~mark Subst.identity arg2' arg1 with
+        | Ok cc -> Ok cc
+        | Error err -> Error (Error.Mismatch err)
+      in
+      let env, subst =
+        match name1, name2 with
+        | Some id1, Some id2 ->
+            Env.add_module id1 Mp_present arg2' env,
+            Subst.add_module id2 (Path.Pident id1) subst
+        | None, Some id2 ->
+            Env.add_module id2 Mp_present arg2' env, subst
+        | Some id1, None ->
+            Env.add_module id1 Mp_present arg2' env, subst
+        | None, None ->
+            env, subst
+      in
+      cc_arg, env, subst
+  | _, _ ->
+      Error (Error.Incompatible_params (param1, param2)), env, subst
+
+and strengthened_modtypes ~loc ~aliasable env ~mark subst mty1 path1 mty2 =
+  match mty1, mty2 with
+  | Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 ->
+      Ok Tcoerce_none
+  | _, _ ->
+      let mty1 = Mtype.strengthen ~aliasable env mty1 path1 in
+      modtypes ~loc env ~mark subst mty1 mty2
+
+and strengthened_module_decl ~loc ~aliasable env ~mark subst md1 path1 md2 =
+  match md1.md_type, md2.md_type with
+  | Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 ->
+      Ok Tcoerce_none
+  | _, _ ->
+      let md1 = Mtype.strengthen_decl ~aliasable env md1 path1 in
+      modtypes ~loc env ~mark subst md1.md_type md2.md_type
+
+(* Inclusion between signatures *)
+
+and signatures ~loc env ~mark subst sig1 sig2 =
+  (* Environment used to check inclusion of components *)
+  let new_env =
+    Env.add_signature sig1 (Env.in_signature true env) in
+  (* Keep ids for module aliases *)
+  let (id_pos_list,_) =
+    List.fold_left
+      (fun (l,pos) -> function
+          Sig_module (id, Mp_present, _, _, _) ->
+            ((id,pos,Tcoerce_none)::l , pos+1)
+        | item -> (l, if is_runtime_component item then pos+1 else pos))
+      ([], 0) sig1 in
+  (* Build a table of the components of sig1, along with their positions.
+     The table is indexed by kind and name of component *)
+  let rec build_component_table pos tbl = function
+      [] -> pos, tbl
+    | (Sig_value (_, _, Hidden)
+      |Sig_type (_, _, _, Hidden)
+      |Sig_typext (_, _, _, Hidden)
+      |Sig_module (_, _, _, _, Hidden)
+      |Sig_modtype (_, _, Hidden)
+      |Sig_class (_, _, _, Hidden)
+      |Sig_class_type (_, _, _, Hidden)
+      ) as item :: rem ->
+        let pos = if is_runtime_component item then pos + 1 else pos in
+        build_component_table pos tbl rem (* do not pair private items. *)
+    | item :: rem ->
+        let (id, _loc, name) = item_ident_name item in
+        let pos, nextpos =
+          if is_runtime_component item then pos, pos + 1
+          else -1, pos
+        in
+        build_component_table nextpos
+                              (FieldMap.add name (id, item, pos) tbl) rem in
+  let len1, comps1 =
+    build_component_table 0 FieldMap.empty sig1 in
+  let len2 =
+    List.fold_left
+      (fun n i -> if is_runtime_component i then n + 1 else n)
+      0
+      sig2
+  in
+  (* Pair each component of sig2 with a component of sig1,
+     identifying the names along the way.
+     Return a coercion list indicating, for all run-time components
+     of sig2, the position of the matching run-time components of sig1
+     and the coercion to be applied to it. *)
+  let rec pair_components subst paired unpaired = function
+      [] ->
+        let oks, errors =
+          signature_components ~loc env ~mark new_env subst (List.rev paired) in
+        begin match unpaired, errors, oks with
+            | [], [], cc ->
+                if len1 = len2 then (* see PR#5098 *)
+                  Ok (simplify_structure_coercion cc id_pos_list)
+                else
+                  Ok (Tcoerce_structure (cc, id_pos_list))
+            | missings, incompatibles, cc ->
+                Error { env=new_env; Error.missings; incompatibles; oks=cc }
+        end
+    | item2 :: rem ->
+        let (id2, _loc, name2) = item_ident_name item2 in
+        let name2, report =
+          match item2, name2 with
+            Sig_type (_, {type_manifest=None}, _, _), {name=s; kind=Field_type}
+            when Btype.is_row_name s ->
+              (* Do not report in case of failure,
+                 as the main type will generate an error *)
+              { kind=Field_type; name=String.sub s 0 (String.length s - 4) },
+              false
+          | _ -> name2, true
+        in
+        begin try
+          let (id1, item1, pos1) = FieldMap.find name2 comps1 in
+          let new_subst =
+            match item2 with
+              Sig_type _ ->
+                Subst.add_type id2 (Path.Pident id1) subst
+            | Sig_module _ ->
+                Subst.add_module id2 (Path.Pident id1) subst
+            | Sig_modtype _ ->
+                Subst.add_modtype id2 (Mty_ident (Path.Pident id1)) subst
+            | Sig_value _ | Sig_typext _
+            | Sig_class _ | Sig_class_type _ ->
+                subst
+          in
+          pair_components new_subst
+            ((item1, item2, pos1) :: paired) unpaired rem
+        with Not_found ->
+          let unpaired =
+            if report then
+              item2 :: unpaired
+            else unpaired in
+          pair_components subst paired unpaired rem
+        end in
+  (* Do the pairing and checking, and return the final coercion *)
+  pair_components subst [] [] sig2
+
+(* Inclusion between signature components *)
+
+and signature_components ~loc old_env ~mark env subst paired =
+  match paired with
+  | [] -> [], []
+  | (sigi1, sigi2, pos) :: rem ->
+      let id, item, present_at_runtime =
+        match sigi1, sigi2 with
+        | Sig_value(id1, valdecl1, _) ,Sig_value(_id2, valdecl2, _) ->
+            let item =
+              value_descriptions ~loc env ~mark subst id1 valdecl1 valdecl2
+            in
+            let present_at_runtime = match valdecl2.val_kind with
+              | Val_prim _ -> false
+              | _ -> true
+            in
+            id1, item, present_at_runtime
+        | Sig_type(id1, tydec1, _, _), Sig_type(_id2, tydec2, _, _) ->
+            let item =
+              type_declarations ~loc ~old_env env ~mark subst id1 tydec1 tydec2
+            in
+            id1, item, false
+        | Sig_typext(id1, ext1, _, _), Sig_typext(_id2, ext2, _, _) ->
+            let item =
+              extension_constructors ~loc env ~mark  subst id1 ext1 ext2
+            in
+            id1, item, true
+        | Sig_module(id1, pres1, mty1, _, _), Sig_module(_, pres2, mty2, _, _)
+          -> begin
+              let item =
+                module_declarations ~loc env ~mark subst id1 mty1 mty2
+              in
+              let item =
+                Result.map_error (fun diff -> Error.Module_type diff) item
+              in
+              let present_at_runtime, item =
+                match pres1, pres2, mty1.md_type with
+                | Mp_present, Mp_present, _ -> true, item
+                | _, Mp_absent, _ -> false, item
+                | Mp_absent, Mp_present, Mty_alias p1 ->
+                    true, Result.map (fun i -> Tcoerce_alias (env, p1, i)) item
+                | Mp_absent, Mp_present, _ -> assert false
+              in
+              id1, item, present_at_runtime
+            end
+        | Sig_modtype(id1, info1, _), Sig_modtype(_id2, info2, _) ->
+            let item =
+              modtype_infos ~loc env ~mark  subst id1 info1 info2
+            in
+            id1, item, false
+        | Sig_class(id1, decl1, _, _), Sig_class(_id2, decl2, _, _) ->
+            let item =
+              class_declarations ~old_env env subst decl1 decl2
+            in
+            id1, item, true
+        | Sig_class_type(id1, info1, _, _), Sig_class_type(_id2, info2, _, _) ->
+            let item =
+              class_type_declarations ~loc ~old_env env subst info1 info2
+            in
+            id1, item, false
+        | _ ->
+            assert false
+      in
+      let oks, errors =
+        signature_components ~loc old_env ~mark env subst rem
+      in
+      match item with
+      | Ok x when present_at_runtime -> (pos,x) :: oks, errors
+      | Ok _ -> oks, errors
+      | Error y -> oks , (id,y) :: errors
+
+and module_declarations ~loc env ~mark  subst id1 md1 md2 =
+  Builtin_attributes.check_alerts_inclusion
+    ~def:md1.md_loc
+    ~use:md2.md_loc
+    loc
+    md1.md_attributes md2.md_attributes
+    (Ident.name id1);
+  let p1 = Path.Pident id1 in
+  if mark_positive mark then
+    Env.mark_module_used md1.md_uid;
+  strengthened_modtypes ~loc ~aliasable:true env ~mark subst
+    md1.md_type p1 md2.md_type
+
+(* Inclusion between module type specifications *)
+
+and modtype_infos ~loc env ~mark subst id info1 info2 =
+  Builtin_attributes.check_alerts_inclusion
+    ~def:info1.mtd_loc
+    ~use:info2.mtd_loc
+    loc
+    info1.mtd_attributes info2.mtd_attributes
+    (Ident.name id);
+  let info2 = Subst.modtype_declaration Keep subst info2 in
+  let r =
+    match (info1.mtd_type, info2.mtd_type) with
+      (None, None) -> Ok Tcoerce_none
+    | (Some _, None) -> Ok Tcoerce_none
+    | (Some mty1, Some mty2) ->
+        check_modtype_equiv ~loc env ~mark mty1 mty2
+    | (None, Some mty2) ->
+        check_modtype_equiv ~loc env ~mark (Mty_ident(Path.Pident id)) mty2 in
+  match r with
+  | Ok _ as ok -> ok
+  | Error e -> Error Error.(Module_type_declaration (diff info1 info2 e))
+
+and check_modtype_equiv ~loc env ~mark mty1 mty2 =
+  match
+    (modtypes ~loc env ~mark Subst.identity mty1 mty2,
+     modtypes ~loc env ~mark:(negate_mark mark) Subst.identity mty2 mty1)
+  with
+    (Ok Tcoerce_none, Ok Tcoerce_none) -> Ok Tcoerce_none
+  | (Ok c1, Ok _c2) ->
+      (* Format.eprintf "@[c1 = %a@ c2 = %a@]@."
+        print_coercion _c1 print_coercion _c2; *)
+      Error Error.(Illegal_permutation c1)
+  | Ok _, Error e -> Error Error.(Not_greater_than e)
+  | Error e, Ok _ -> Error Error.(Not_less_than e)
+  | Error less_than, Error greater_than ->
+      Error Error.(Incomparable {less_than; greater_than})
+
+
+(* Simplified inclusion check between module types (for Env) *)
+
+let can_alias env path =
+  let rec no_apply = function
+    | Path.Pident _ -> true
+    | Path.Pdot(p, _) -> no_apply p
+    | Path.Papply _ -> false
+  in
+  no_apply path && not (Env.is_functor_arg path env)
+
+
+
+type explanation = Env.t * Error.all
+exception Error of explanation
+
+exception Apply_error of {
+    loc : Location.t ;
+    env : Env.t ;
+    lid_app : Longident.t option ;
+    mty_f : module_type ;
+    args : (Error.functor_arg_descr * module_type) list ;
+  }
+
+let check_modtype_inclusion_raw ~loc env mty1 path1 mty2 =
+  let aliasable = can_alias env path1 in
+  strengthened_modtypes ~loc ~aliasable env ~mark:Mark_both
+    Subst.identity mty1 path1 mty2
+
+let check_modtype_inclusion ~loc env mty1 path1 mty2 =
+  match check_modtype_inclusion_raw ~loc env mty1 path1 mty2 with
+  | Ok _ -> None
+  | Error e -> Some (env, Error.In_Module_type e)
+
+let check_functor_application_in_path
+    ~errors ~loc ~lid_whole_app ~f0_path ~args
+    ~arg_path ~arg_mty ~param_mty env =
+  match check_modtype_inclusion_raw ~loc env arg_mty arg_path param_mty with
+  | Ok _ -> ()
+  | Error _errs ->
+      if errors then
+        let prepare_arg (arg_path, arg_mty) =
+          let aliasable = can_alias env arg_path in
+          let smd = Mtype.strengthen ~aliasable env arg_mty arg_path in
+          (Error.Named arg_path, smd)
+        in
+        let mty_f = (Env.find_module f0_path env).md_type in
+        let args = List.map prepare_arg args in
+        let lid_app = Some lid_whole_app in
+        raise (Apply_error {loc; env; lid_app; mty_f; args})
+      else
+        raise Not_found
+
+let () =
+  Env.check_functor_application := check_functor_application_in_path
+
+
+(* Check that an implementation of a compilation unit meets its
+   interface. *)
+
+let compunit env ~mark impl_name impl_sig intf_name intf_sig =
+  match
+    signatures ~loc:(Location.in_file impl_name) env ~mark Subst.identity
+      impl_sig intf_sig
+  with Result.Error reasons ->
+    let cdiff =
+      Error.In_Compilation_unit(Error.diff impl_name intf_name reasons) in
+    raise(Error(env, cdiff))
+  | Ok x -> x
+
+(* Functor diffing computation:
+   The diffing computation uses the internal typing function
+ *)
+
+module Functor_inclusion_diff = struct
+  open Diffing
+
+  let param_name = function
+      | Named(x,_) -> x
+      | Unit -> None
+
+  let weight = function
+    | Insert _ -> 10
+    | Delete _ -> 10
+    | Change _ -> 10
+    | Keep (param1, param2, _) -> begin
+        match param_name param1, param_name param2 with
+        | None, None
+          -> 0
+        | Some n1, Some n2
+          when String.equal (Ident.name n1) (Ident.name n2)
+          -> 0
+        | Some _, Some _ -> 1
+        | Some _,  None | None, Some _ -> 1
+      end
+
+  type state = {
+    res: module_type option;
+    env: Env.t;
+    subst: Subst.t;
+  }
+
+  let keep_expansible_param = function
+    | Mty_ident _ | Mty_alias _ as mty -> Some mty
+    | Mty_signature _ | Mty_functor _ | Mty_for_hole -> None
+
+  let lookup_expansion { env ; res ; _ } = match res with
+    | None -> None
+    | Some res ->
+        match retrieve_functor_params env res with
+        | [], _ -> None
+        | params, res ->
+            let more = Array.of_list params  in
+            Some (keep_expansible_param res, more)
+
+  let expand_params state  =
+    match lookup_expansion state with
+    | None -> state, [||]
+    | Some (res, expansion) -> { state with res }, expansion
+
+  let update d st = match d with
+    | Insert (Unit | Named (None,_))
+    | Delete (Unit | Named (None,_))
+    | Keep (Unit,_,_)
+    | Keep (_,Unit,_)
+    | Change (_,(Unit | Named (None,_)), _) ->
+        st, [||]
+    | Insert (Named (Some id, arg))
+    | Delete (Named (Some id, arg))
+    | Change (Unit, Named (Some id, arg), _) ->
+        let arg' = Subst.modtype Keep st.subst arg in
+        let env = Env.add_module id Mp_present arg' st.env in
+        expand_params { st with env }
+    | Keep (Named (name1, _), Named (name2, arg2), _)
+    | Change (Named (name1, _), Named (name2, arg2), _) -> begin
+        let arg' = Subst.modtype Keep st.subst arg2 in
+        match name1, name2 with
+        | Some id1, Some id2 ->
+            let env = Env.add_module id1 Mp_present arg' st.env in
+            let subst = Subst.add_module id2 (Path.Pident id1) st.subst in
+            expand_params { st with env; subst }
+        | None, Some id2 ->
+            let env = Env.add_module id2 Mp_present arg' st.env in
+            { st with env }, [||]
+        | Some id1, None ->
+            let env = Env.add_module id1 Mp_present arg' st.env in
+            expand_params { st with env }
+        | None, None ->
+            st, [||]
+      end
+
+  let diff env (l1,res1) (l2,_) =
+    let update = Diffing.With_left_extensions update in
+    let test st mty1 mty2 =
+      let loc = Location.none in
+      let res, _, _ =
+        functor_param ~loc st.env ~mark:Mark_neither st.subst mty1 mty2
+      in
+      res
+    in
+    let param1 = Array.of_list l1 in
+    let param2 = Array.of_list l2 in
+    let state =
+      { env; subst = Subst.identity; res = keep_expansible_param res1}
+    in
+    Diffing.variadic_diff ~weight ~test ~update state param1 param2
+
+end
+
+module Functor_app_diff = struct
+  module I = Functor_inclusion_diff
+  open Diffing
+
+  let weight = function
+    | Insert _ -> 10
+    | Delete _ -> 10
+    | Change _ -> 10
+    | Keep (param1, param2, _) ->
+        (* We assign a small penalty to named arguments with
+           non-matching names *)
+        begin
+          let desc1 : Error.functor_arg_descr = fst param1 in
+          match desc1, I.param_name param2 with
+          | (Unit | Anonymous) , None
+            -> 0
+          | Named (Path.Pident n1), Some n2
+            when String.equal (Ident.name n1) (Ident.name n2)
+            -> 0
+          | Named _, Some _ -> 1
+          | Named _,  None | (Unit | Anonymous), Some _ -> 1
+        end
+
+  let update (d: (_,Types.functor_parameter,_,_) change) (st:I.state) =
+    let open Error in
+    match d with
+    | Insert _
+    | Delete _
+    | Keep ((Unit,_),_,_)
+    | Keep (_,Unit,_)
+    | Change (_,(Unit | Named (None,_)), _ )
+    | Change ((Unit,_), Named (Some _, _), _) ->
+        st, [||]
+    | Keep ((Named arg,  _mty) , Named (param_name, _param), _)
+    | Change ((Named arg, _mty), Named (param_name, _param), _) ->
+        begin match param_name with
+        | Some param ->
+            let res =
+              Option.map (fun res ->
+                  let scope = Ctype.create_scope () in
+                  let subst = Subst.add_module param arg Subst.identity in
+                  Subst.modtype (Rescope scope) subst res
+                )
+                st.res
+            in
+            let subst = Subst.add_module param arg st.subst in
+            I.expand_params { st with subst; res }
+        | None ->
+            st, [||]
+        end
+    | Keep ((Anonymous, mty) , Named (param_name, _param), _)
+    | Change ((Anonymous, mty), Named (param_name, _param), _) -> begin
+        begin match param_name with
+        | Some param ->
+            let mty' = Subst.modtype Keep st.subst mty in
+            let env =
+              Env.add_module ~arg:true param Mp_present mty' st.env in
+            let res =
+              Option.map (Mtype.nondep_supertype env [param]) st.res in
+            I.expand_params { st with env; res}
+        | None ->
+            st, [||]
+        end
+      end
+
+  let diff env ~f ~args =
+    let params, res = retrieve_functor_params env f in
+    let update = Diffing.With_right_extensions update in
+    let test (state:I.state) (arg,arg_mty) param =
+      let loc = Location.none in
+      let res = match (arg:Error.functor_arg_descr), param with
+        | Unit, Unit -> Ok Tcoerce_none
+        | Unit, Named _ | (Anonymous | Named _), Unit ->
+            Result.Error (Error.Incompatible_params(arg,param))
+        | ( Anonymous | Named _ ) , Named (_, param) ->
+            match
+              modtypes ~loc state.env ~mark:Mark_neither state.subst
+                arg_mty param
+            with
+            | Error mty -> Result.Error (Error.Mismatch mty)
+            | Ok _ as x -> x
+      in
+      res
+    in
+    let args = Array.of_list args in
+    let params = Array.of_list params in
+    let state : I.state =
+      { env; subst = Subst.identity; res = I.keep_expansible_param res }
+    in
+    Diffing.variadic_diff ~weight ~test ~update state args params
+
+end
+
+(* Hide the context and substitution parameters to the outside world *)
+
+let modtypes ~loc env ~mark mty1 mty2 =
+  match modtypes ~loc env ~mark Subst.identity mty1 mty2 with
+  | Ok x -> x
+  | Error reason -> raise (Error (env, Error.(In_Module_type reason)))
+let signatures env ~mark sig1 sig2 =
+  match signatures ~loc:Location.none env ~mark Subst.identity sig1 sig2 with
+  | Ok x -> x
+  | Error reason -> raise (Error(env,Error.(In_Signature reason)))
+
+let type_declarations ~loc env ~mark id decl1 decl2 =
+  match type_declarations ~loc env ~mark Subst.identity id decl1 decl2 with
+  | Ok _ -> ()
+  | Error (Error.Core reason) ->
+      raise (Error(env,Error.(In_Type_declaration(id,reason))))
+  | Error _ -> assert false
+
+let strengthened_module_decl ~loc ~aliasable env ~mark md1 path1 md2 =
+  match strengthened_module_decl ~loc ~aliasable env ~mark Subst.identity
+    md1 path1 md2 with
+  | Ok x -> x
+  | Error mdiff ->
+      raise (Error(env,Error.(In_Module_type mdiff)))
+
+let expand_module_alias env path =
+  match expand_module_alias env path with
+  | Ok x -> x
+  | Result.Error _ ->
+      raise (Error(env,In_Expansion(Error.Unbound_module_path path)))
+
+let check_modtype_equiv ~loc env id mty1 mty2 =
+  match check_modtype_equiv ~loc env ~mark:Mark_both mty1 mty2 with
+  | Ok _ -> ()
+  | Error e ->
+      raise (Error(env,
+                   Error.(In_Module_type_substitution (id,diff mty1 mty2 e)))
+            )
diff --git a/src/ocaml/typing/includemod.mli b/src/ocaml/typing/includemod.mli
new file mode 100644
index 0000000..f4bd3a6
--- /dev/null
+++ b/src/ocaml/typing/includemod.mli
@@ -0,0 +1,237 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the module language *)
+
+open Typedtree
+open Types
+
+(** Type describing which arguments of an inclusion to consider as used
+    for the usage warnings. [Mark_both] is the default. *)
+type mark =
+  | Mark_both
+      (** Mark definitions used from both arguments *)
+  | Mark_positive
+      (** Mark definitions used from the positive (first) argument *)
+  | Mark_negative
+      (** Mark definitions used from the negative (second) argument *)
+  | Mark_neither
+      (** Do not mark definitions used from either argument *)
+
+module Error: sig
+
+  type ('elt,'explanation) diff = {
+    got:'elt;
+    expected:'elt;
+    symptom:'explanation
+  }
+  type 'elt core_diff =('elt,unit) diff
+
+  type functor_arg_descr =
+    | Anonymous
+    | Named of Path.t
+    | Unit
+
+  type core_sigitem_symptom =
+    | Value_descriptions of Types.value_description core_diff
+    | Type_declarations of
+        (Types.type_declaration, Includecore.type_mismatch) diff
+    | Extension_constructors of
+        (Types.extension_constructor,
+         Includecore.extension_constructor_mismatch) diff
+    | Class_type_declarations of
+        (Types.class_type_declaration, Ctype.class_match_failure list) diff
+    | Class_declarations of
+        (Types.class_declaration, Ctype.class_match_failure list) diff
+
+  type core_module_type_symptom =
+    | Not_an_alias
+    | Not_an_identifier
+    | Incompatible_aliases
+    | Abstract_module_type
+    | Unbound_module_path of Path.t
+
+  type module_type_symptom =
+    | Mt_core of core_module_type_symptom
+    | Signature of signature_symptom
+    | Functor of functor_symptom
+    | Invalid_module_alias of Path.t
+    | After_alias_expansion of module_type_diff
+
+
+  and module_type_diff = (Types.module_type, module_type_symptom) diff
+
+  and functor_symptom =
+    | Params of functor_params_diff
+    | Result of module_type_diff
+
+  and ('arg,'path) functor_param_symptom =
+    | Incompatible_params of 'arg * Types.functor_parameter
+    | Mismatch of module_type_diff
+
+  and arg_functor_param_symptom =
+    (Types.functor_parameter, Ident.t) functor_param_symptom
+
+  and functor_params_diff =
+    (Types.functor_parameter list * Types.module_type) core_diff
+
+  and signature_symptom = {
+    env: Env.t;
+    missings: Types.signature_item list;
+    incompatibles: (Ident.t * sigitem_symptom) list;
+    oks: (int * Typedtree.module_coercion) list;
+  }
+  and sigitem_symptom =
+    | Core of core_sigitem_symptom
+    | Module_type_declaration of
+        (Types.modtype_declaration, module_type_declaration_symptom) diff
+    | Module_type of module_type_diff
+
+  and module_type_declaration_symptom =
+    | Illegal_permutation of Typedtree.module_coercion
+    | Not_greater_than of module_type_diff
+    | Not_less_than of module_type_diff
+    | Incomparable of
+        {less_than:module_type_diff; greater_than: module_type_diff}
+
+
+  type all =
+    | In_Compilation_unit of (string, signature_symptom) diff
+    | In_Signature of signature_symptom
+    | In_Module_type of module_type_diff
+    | In_Module_type_substitution of
+        Ident.t * (Types.module_type,module_type_declaration_symptom) diff
+    | In_Type_declaration of Ident.t * core_sigitem_symptom
+    | In_Expansion of core_module_type_symptom
+end
+type explanation = Env.t * Error.all
+
+(* Extract name, kind and ident from a signature item *)
+type field_kind =
+  | Field_value
+  | Field_type
+  | Field_exception
+  | Field_typext
+  | Field_module
+  | Field_modtype
+  | Field_class
+  | Field_classtype
+
+type field_desc = { name: string; kind: field_kind }
+
+val kind_of_field_desc: field_desc -> string
+val field_desc: field_kind -> Ident.t -> field_desc
+
+(** Map indexed by both field types and names.
+    This avoids name clashes between different sorts of fields
+    such as values and types. *)
+module FieldMap: Map.S with type key = field_desc
+
+val item_ident_name: Types.signature_item -> Ident.t * Location.t * field_desc
+val is_runtime_component: Types.signature_item -> bool
+
+
+(* Typechecking *)
+
+val modtypes:
+  loc:Location.t -> Env.t -> mark:mark ->
+  module_type -> module_type -> module_coercion
+
+val strengthened_module_decl:
+  loc:Location.t -> aliasable:bool -> Env.t -> mark:mark ->
+  module_declaration -> Path.t -> module_declaration -> module_coercion
+
+val check_modtype_inclusion :
+  loc:Location.t -> Env.t -> Types.module_type -> Path.t -> Types.module_type ->
+  explanation option
+(** [check_modtype_inclusion ~loc env mty1 path1 mty2] checks that the
+    functor application F(M) is well typed, where mty2 is the type of
+    the argument of F and path1/mty1 is the path/unstrenghened type of M. *)
+
+val check_modtype_equiv:
+  loc:Location.t -> Env.t -> Ident.t -> module_type -> module_type -> unit
+
+val signatures: Env.t -> mark:mark ->
+  signature -> signature -> module_coercion
+
+val compunit:
+      Env.t -> mark:mark -> string -> signature ->
+      string -> signature -> module_coercion
+
+val type_declarations:
+  loc:Location.t -> Env.t -> mark:mark ->
+  Ident.t -> type_declaration -> type_declaration -> unit
+
+val print_coercion: Format.formatter -> module_coercion -> unit
+
+type symptom =
+    Missing_field of Ident.t * Location.t * string (* kind *)
+  | Value_descriptions of
+      Ident.t * value_description * value_description
+      * Includecore.value_mismatch
+  | Type_declarations of Ident.t * type_declaration
+        * type_declaration * Includecore.type_mismatch
+  | Extension_constructors of Ident.t * extension_constructor
+        * extension_constructor * Includecore.extension_constructor_mismatch
+  | Module_types of module_type * module_type
+  | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration
+  | Modtype_permutation of Types.module_type * Typedtree.module_coercion
+  | Interface_mismatch of string * string
+  | Class_type_declarations of
+      Ident.t * class_type_declaration * class_type_declaration *
+      Ctype.class_match_failure list
+  | Class_declarations of
+      Ident.t * class_declaration * class_declaration *
+      Ctype.class_match_failure list
+  | Unbound_module_path of Path.t
+  | Invalid_module_alias of Path.t
+
+type pos =
+  | Module of Ident.t
+  | Modtype of Ident.t
+  | Arg of functor_parameter
+  | Body of functor_parameter
+
+exception Error of explanation
+exception Apply_error of {
+    loc : Location.t ;
+    env : Env.t ;
+    lid_app : Longident.t option ;
+    mty_f : module_type ;
+    args : (Error.functor_arg_descr * Types.module_type)  list ;
+  }
+
+val expand_module_alias: Env.t -> Path.t -> Types.module_type
+
+module Functor_inclusion_diff: sig
+  val diff: Env.t ->
+           Types.functor_parameter list * Types.module_type ->
+           Types.functor_parameter list * Types.module_type ->
+           (Types.functor_parameter, Types.functor_parameter,
+            Typedtree.module_coercion,
+            (Types.functor_parameter, 'c) Error.functor_param_symptom)
+           Diffing.patch
+end
+
+module Functor_app_diff: sig
+  val diff:
+    Env.t ->
+    f:Types.module_type ->
+    args:(Error.functor_arg_descr * Types.module_type) list ->
+    (Error.functor_arg_descr * Types.module_type,
+     Types.functor_parameter, Typedtree.module_coercion,
+     (Error.functor_arg_descr, 'a) Error.functor_param_symptom)
+      Diffing.patch
+end
diff --git a/src/ocaml/typing/includemod_errorprinter.ml b/src/ocaml/typing/includemod_errorprinter.ml
new file mode 100644
index 0000000..223a817
--- /dev/null
+++ b/src/ocaml/typing/includemod_errorprinter.ml
@@ -0,0 +1,933 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Florian Angeletti, projet Cambium, Inria Paris             *)
+(*                                                                        *)
+(*   Copyright 2021 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+
+module Context = struct
+  type pos =
+    | Module of Ident.t
+    | Modtype of Ident.t
+    | Arg of Types.functor_parameter
+    | Body of Types.functor_parameter
+
+  let path_of_context = function
+      Module id :: rem ->
+        let rec subm path = function
+          | [] -> path
+          | Module id :: rem -> subm (Path.Pdot (path, Ident.name id)) rem
+          | _ -> assert false
+        in subm (Path.Pident id) rem
+    | _ -> assert false
+
+
+  let rec context ppf = function
+      Module id :: rem ->
+        Format.fprintf ppf "@[<2>module %a%a@]" Printtyp.ident id args rem
+    | Modtype id :: rem ->
+        Format.fprintf ppf "@[<2>module type %a =@ %a@]"
+          Printtyp.ident id context_mty rem
+    | Body x :: rem ->
+        Format.fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem
+    | Arg x :: rem ->
+        Format.fprintf ppf "functor (%s : %a) -> ..."
+          (argname x) context_mty rem
+    | [] ->
+        Format.fprintf ppf "<here>"
+  and context_mty ppf = function
+      (Module _ | Modtype _) :: _ as rem ->
+        Format.fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem
+    | cxt -> context ppf cxt
+  and args ppf = function
+      Body x :: rem ->
+        Format.fprintf ppf "(%s)%a" (argname x) args rem
+    | Arg x :: rem ->
+        Format.fprintf ppf "(%s :@ %a) : ..." (argname  x) context_mty rem
+    | cxt ->
+        Format.fprintf ppf " :@ %a" context_mty cxt
+  and argname = function
+    | Types.Unit -> ""
+    | Types.Named (None, _) -> "_"
+    | Types.Named (Some id, _) -> Ident.name id
+
+  let alt_pp ppf cxt =
+    if cxt = [] then () else
+    if List.for_all (function Module _ -> true | _ -> false) cxt then
+      Format.fprintf ppf "in module %a," Printtyp.path (path_of_context cxt)
+    else
+      Format.fprintf ppf "@[<hv 2>at position@ %a,@]" context cxt
+
+  let pp ppf cxt =
+    if cxt = [] then () else
+    if List.for_all (function Module _ -> true | _ -> false) cxt then
+      Format.fprintf ppf "In module %a:@ " Printtyp.path (path_of_context cxt)
+    else
+      Format.fprintf ppf "@[<hv 2>At position@ %a@]@ " context cxt
+end
+
+module Illegal_permutation = struct
+  (** Extraction of information in case of illegal permutation
+      in a module type *)
+
+  (** When examining coercions, we only have runtime component indices,
+      we use thus a limited version of {!pos}. *)
+  type coerce_pos =
+    | Item of int
+    | InArg
+    | InBody
+
+  let either f x g y = match f x with
+    | None -> g y
+    | Some _ as v -> v
+
+  (** We extract a lone transposition from a full tree of permutations. *)
+  let rec transposition_under path (coerc:Typedtree.module_coercion) =
+    match coerc with
+    | Tcoerce_structure(c,_) ->
+        either
+          (not_fixpoint path 0) c
+          (first_non_id path 0) c
+    | Tcoerce_functor(arg,res) ->
+        either
+          (transposition_under (InArg::path)) arg
+          (transposition_under (InBody::path)) res
+    | Tcoerce_none -> None
+    | Tcoerce_alias _ | Tcoerce_primitive _ ->
+        (* these coercions are not inversible, and raise an error earlier when
+           checking for module type equivalence *)
+        assert false
+  (* we search the first point which is not invariant at the current level *)
+  and not_fixpoint path pos = function
+    | [] -> None
+    | (n, _) :: q ->
+        if n = pos then
+          not_fixpoint path (pos+1) q
+        else
+          Some(List.rev path, pos, n)
+  (* we search the first item with a non-identity inner coercion *)
+  and first_non_id path pos = function
+    | [] -> None
+    | (_, Typedtree.Tcoerce_none) :: q -> first_non_id path (pos + 1) q
+    | (_,c) :: q ->
+        either
+          (transposition_under (Item pos :: path)) c
+          (first_non_id path (pos + 1)) q
+
+  let transposition c =
+    match transposition_under [] c with
+    | None -> raise Not_found
+    | Some x -> x
+
+  let rec runtime_item k = function
+    | [] -> raise Not_found
+    | item :: q ->
+        if not(Includemod.is_runtime_component item) then
+          runtime_item k q
+        else if k = 0 then
+          item
+        else
+          runtime_item (k-1) q
+
+  (* Find module type at position [path] and convert the [coerce_pos] path to
+     a [pos] path *)
+  let rec find env ctx path (mt:Types.module_type) = match mt, path with
+    | (Mty_ident p | Mty_alias p), _ ->
+        begin match (Env.find_modtype p env).mtd_type with
+        | None -> raise Not_found
+        | Some mt -> find env ctx path mt
+        end
+    | Mty_signature s , [] -> List.rev ctx, s
+    | Mty_signature s, Item k :: q ->
+        begin match runtime_item k s with
+        | Sig_module (id, _, md,_,_) ->
+            find env (Context.Module id :: ctx) q md.md_type
+        | _ -> raise Not_found
+        end
+    | Mty_functor(Named (_,mt) as arg,_), InArg :: q ->
+        find env (Context.Arg arg :: ctx) q mt
+    | Mty_functor(arg, mt), InBody :: q ->
+        find env (Context.Body arg :: ctx) q mt
+    | _ -> raise Not_found
+
+  let find env path mt = find env [] path mt
+  let item mt k = Includemod.item_ident_name (runtime_item k mt)
+
+  let pp_item ppf (id,_,kind) =
+    Format.fprintf ppf "%s %S"
+      (Includemod.kind_of_field_desc kind)
+      (Ident.name id)
+
+  let pp ctx_printer env ppf (mty,c) =
+    try
+      let p, k, l = transposition c in
+      let ctx, mt = find env p mty in
+      Format.fprintf ppf
+        "@[<hv 2>Illegal permutation of runtime components in a module type.@ \
+         @[For example,@ %a@]@ @[the %a@ and the %a are not in the same order@ \
+         in the expected and actual module types.@]@]"
+        ctx_printer ctx pp_item (item mt k) pp_item (item mt l)
+    with Not_found -> (* this should not happen *)
+      Format.fprintf ppf
+        "Illegal permutation of runtime components in a module type."
+
+end
+
+
+
+module Err = Includemod.Error
+
+let buffer = ref Bytes.empty
+let is_big obj =
+  let size = !Clflags.error_size in
+  size > 0 &&
+  begin
+    if Bytes.length !buffer < size then buffer := Bytes.create size;
+    try ignore (Marshal.to_buffer !buffer 0 size obj []); false
+    with _ -> true
+  end
+
+let show_loc msg ppf loc =
+  let pos = loc.Location.loc_start in
+  if List.mem pos.Lexing.pos_fname [""; "_none_"; "//toplevel//"] then ()
+  else Format.fprintf ppf "@\n@[<2>%a:@ %s@]" Location.print_loc loc msg
+
+let show_locs ppf (loc1, loc2) =
+  show_loc "Expected declaration" ppf loc2;
+  show_loc "Actual declaration" ppf loc1
+
+
+let dmodtype mty =
+  let tmty = Printtyp.tree_of_modtype mty in
+  Format.dprintf "%a" !Oprint.out_module_type tmty
+
+let space ppf () = Format.fprintf ppf "@ "
+
+(**
+   In order to display a list of functor arguments in a compact format,
+   we introduce a notion of shorthand for functor arguments.
+   The aim is to first present the lists of actual and expected types with
+   shorthands:
+
+     (X: $S1) (Y: $S2) (Z: An_existing_module_type) ...
+   does not match
+     (X: $T1) (Y: A_real_path) (Z: $T3) ...
+
+   and delay the full display of the module types corresponding to $S1, $S2,
+   $T1, and $T3 to the suberror message.
+
+*)
+module With_shorthand = struct
+
+  (** A item with a potential shorthand name *)
+  type 'a named = {
+    item: 'a;
+    name : string;
+  }
+
+  type 'a t =
+    | Original of 'a (** The shorthand has been discarded *)
+    | Synthetic of 'a named
+    (** The shorthand is potentially useful *)
+
+  type functor_param =
+    | Unit
+    | Named of (Ident.t option * Types.module_type t)
+
+  (** Shorthand generation *)
+  type kind =
+    | Got
+    | Expected
+    | Unneeded
+
+  type variant =
+    | App
+    | Inclusion
+
+  let elide_if_app ctx s = match ctx with
+    | App -> Unneeded
+    | Inclusion -> s
+
+  let make side pos =
+    match side with
+    | Got -> Format.sprintf "$S%d" pos
+    | Expected -> Format.sprintf "$T%d" pos
+    | Unneeded -> "..."
+
+  (** Add shorthands to a patch *)
+  let patch ctx p =
+    let add_shorthand side pos mty =
+      {name = (make side pos); item = mty }
+    in
+    let aux i d =
+      let pos = i + 1 in
+      let d = match d with
+        | Diffing.Insert mty ->
+            Diffing.Insert (add_shorthand Expected pos mty)
+        | Diffing.Delete mty ->
+            Diffing.Delete (add_shorthand (elide_if_app ctx Got) pos mty)
+        | Diffing.Change (g, e, p) ->
+            Diffing.Change
+              (add_shorthand Got pos g,
+               add_shorthand Expected pos e, p)
+        | Diffing.Keep (g, e, p) ->
+            Diffing.Keep (add_shorthand Got pos g,
+                          add_shorthand (elide_if_app ctx Expected) pos e, p)
+      in
+      pos, d
+    in
+    List.mapi aux p
+
+  (** Shorthand computation from named item *)
+  let modtype (r : _ named) = match r.item with
+    | Types.Mty_ident _
+    | Types.Mty_alias _
+    | Types.Mty_signature []
+    | Types.Mty_for_hole
+      -> Original r.item
+    | Types.Mty_signature _ | Types.Mty_functor _
+      -> Synthetic r
+
+  let functor_param (ua : _ named) = match ua.item with
+    | Types.Unit -> Unit
+    | Types.Named (from, mty) ->
+        Named (from, modtype { ua with item = mty })
+
+  (** Printing of arguments with shorthands *)
+  let pp ppx = function
+    | Original x -> ppx x
+    | Synthetic s -> Format.dprintf "%s" s.name
+
+  let pp_orig ppx = function
+    | Original x | Synthetic { item=x; _ } -> ppx x
+
+  let definition x = match functor_param x with
+    | Unit -> Format.dprintf "()"
+    | Named(_,short_mty) ->
+        match short_mty with
+        | Original mty -> dmodtype mty
+        | Synthetic {name; item = mty} ->
+            Format.dprintf
+              "%s@ =@ %t" name (dmodtype mty)
+
+  let param x = match functor_param x with
+    | Unit -> Format.dprintf "()"
+    | Named (_, short_mty) ->
+        pp dmodtype short_mty
+
+  let qualified_param x = match functor_param x with
+    | Unit -> Format.dprintf "()"
+    | Named (None, Original (Mty_signature []) ) ->
+        Format.dprintf "(sig end)"
+    | Named (None, short_mty) ->
+        pp dmodtype short_mty
+    | Named (Some p, short_mty) ->
+        Format.dprintf "(%s : %t)"
+          (Ident.name p) (pp dmodtype short_mty)
+
+  let definition_of_argument ua =
+    let arg, mty = ua.item in
+    match (arg: Err.functor_arg_descr) with
+    | Unit -> Format.dprintf "()"
+    | Named p ->
+        let mty = modtype { ua with item = mty } in
+        Format.dprintf
+          "%a@ :@ %t"
+          Printtyp.path p
+          (pp_orig dmodtype mty)
+    | Anonymous ->
+        let short_mty = modtype { ua with item = mty } in
+        begin match short_mty with
+        | Original mty -> dmodtype mty
+        | Synthetic {name; item=mty} ->
+            Format.dprintf "%s@ :@ %t" name (dmodtype mty)
+        end
+
+  let arg ua =
+    let arg, mty = ua.item in
+    match (arg: Err.functor_arg_descr) with
+    | Unit -> Format.dprintf "()"
+    | Named p -> fun ppf -> Printtyp.path ppf p
+    | Anonymous ->
+        let short_mty = modtype { ua with item=mty } in
+        pp dmodtype short_mty
+
+end
+
+
+module Functor_suberror = struct
+  open Err
+
+  let style = function
+    | Diffing.Keep _ -> Misc.Color.[ FG Green ]
+    | Diffing.Delete _ -> Misc.Color.[ FG Red; Bold]
+    | Diffing.Insert _ -> Misc.Color.[ FG Red; Bold]
+    | Diffing.Change _ -> Misc.Color.[ FG Magenta; Bold]
+
+  let prefix ppf (pos, p) =
+    let sty = style p in
+    Format.pp_open_stag ppf (Misc.Color.Style sty);
+    Format.fprintf ppf "%i." pos;
+    Format.pp_close_stag ppf ()
+
+  let param_id x = match x.With_shorthand.item with
+    | Types.Named (Some _ as x,_) -> x
+    | Types.(Unit | Named(None,_)) -> None
+
+  (** Print the list of params with style *)
+  let pretty_params sep proj printer patch =
+    let elt (x,param) =
+      let sty = style x in
+      Format.dprintf "%a%t%a"
+        Format.pp_open_stag (Misc.Color.Style sty)
+        (printer param)
+        Format.pp_close_stag ()
+    in
+    let params = List.filter_map proj @@ List.map snd patch in
+    Printtyp.functor_parameters ~sep elt params
+
+  let expected d =
+    let extract = function
+      | Diffing.Insert mty
+      | Diffing.Keep(_,mty,_)
+      | Diffing.Change (_,mty,_) as x ->
+          Some (param_id mty,(x, mty))
+      | Diffing.Delete _ -> None
+    in
+    pretty_params space extract With_shorthand.qualified_param d
+
+  let drop_inserted_suffix patch =
+    let rec drop = function
+      | Diffing.Insert _ :: q -> drop q
+      | rest -> List.rev rest in
+    drop (List.rev patch)
+
+  let prepare_patch ~drop ~ctx patch =
+    let drop_suffix x = if drop then drop_inserted_suffix x else x in
+    patch |> drop_suffix |> With_shorthand.patch ctx
+
+
+  module Inclusion = struct
+
+    let got d =
+      let extract = function
+      | Diffing.Delete mty
+      | Diffing.Keep (mty,_,_)
+      | Diffing.Change (mty,_,_) as x ->
+          Some (param_id mty,(x,mty))
+      | Diffing.Insert _ -> None
+      in
+      pretty_params space extract With_shorthand.qualified_param d
+
+    let insert mty =
+      Format.dprintf
+        "An argument appears to be missing with module type@;<1 2>@[%t@]"
+        (With_shorthand.definition mty)
+
+    let delete mty =
+      Format.dprintf
+        "An extra argument is provided of module type@;<1 2>@[%t@]"
+        (With_shorthand.definition mty)
+
+      let ok x y =
+        Format.dprintf
+          "Module types %t and %t match"
+          (With_shorthand.param x)
+          (With_shorthand.param y)
+
+      let diff g e more =
+        let g = With_shorthand.definition g in
+        let e = With_shorthand.definition e in
+        Format.dprintf
+          "Module types do not match:@ @[%t@]@;<1 -2>does not include@ \
+           @[%t@]%t"
+          g e (more ())
+
+      let incompatible = function
+        | Types.Unit ->
+            Format.dprintf
+              "The functor was expected to be applicative at this position"
+        | Types.Named _ ->
+            Format.dprintf
+              "The functor was expected to be generative at this position"
+
+      let patch env got expected =
+        Includemod.Functor_inclusion_diff.diff env got expected
+        |> prepare_patch ~drop:false ~ctx:Inclusion
+
+    end
+
+  module App = struct
+
+    let patch env ~f ~args =
+      Includemod.Functor_app_diff.diff env ~f ~args
+      |> prepare_patch ~drop:true ~ctx:App
+
+    let got d =
+      let extract = function
+        | Diffing.Delete mty
+        | Diffing.Keep (mty,_,_)
+        | Diffing.Change (mty,_,_) as x ->
+            Some (None,(x,mty))
+        | Diffing.Insert _ -> None
+      in
+      pretty_params space extract With_shorthand.arg d
+
+    let delete mty =
+      Format.dprintf
+        "The following extra argument is provided@;<1 2>@[%t@]"
+        (With_shorthand.definition_of_argument mty)
+
+    let insert = Inclusion.insert
+
+    let ok x y =
+      let pp_orig_name = match With_shorthand.functor_param y with
+        | With_shorthand.Named (_, Original mty) ->
+            Format.dprintf " %t" (dmodtype mty)
+        | _ -> ignore
+      in
+      Format.dprintf
+        "Module %t matches the expected module type%t"
+        (With_shorthand.arg x)
+        pp_orig_name
+
+    let diff g e more =
+      let g = With_shorthand.definition_of_argument g in
+      let e = With_shorthand.definition e in
+      Format.dprintf
+        "Modules do not match:@ @[%t@]@;<1 -2>\
+         is not included in@ @[%t@]%t"
+        g e (more ())
+
+    (** Specialized to avoid introducing shorthand names
+        for single change difference
+    *)
+    let single_diff g e more =
+      let _arg, mty = g.With_shorthand.item in
+      let e = match e.With_shorthand.item with
+        | Types.Unit -> Format.dprintf "()"
+        | Types.Named(_, mty) -> dmodtype mty
+      in
+      Format.dprintf
+        "Modules do not match:@ @[%t@]@;<1 -2>\
+         is not included in@ @[%t@]%t"
+        (dmodtype mty) e (more ())
+
+
+    let incompatible = function
+      | Unit ->
+          Format.dprintf
+            "The functor was expected to be applicative at this position"
+      | Named _ | Anonymous ->
+          Format.dprintf
+            "The functor was expected to be generative at this position"
+
+  end
+
+  let subcase sub ~expansion_token env (pos, diff) =
+    Location.msg "%a%a%a %a@[<hv 2>%t@]%a"
+      Format.pp_print_tab ()
+      Format.pp_open_tbox ()
+      prefix (pos, diff)
+      Format.pp_set_tab ()
+      (Printtyp.wrap_printing_env env ~error:true
+         (fun () -> sub ~expansion_token env diff)
+      )
+     Format.pp_close_tbox ()
+
+  let onlycase sub ~expansion_token env (_, diff) =
+    Location.msg "%a@[<hv 2>%t@]"
+      Format.pp_print_tab ()
+      (Printtyp.wrap_printing_env env ~error:true
+         (fun () -> sub ~expansion_token env diff)
+      )
+
+  let params sub ~expansion_token env l =
+    let rec aux subcases = function
+      | [] -> subcases
+      | (_, Diffing.Keep _) as a :: q ->
+          aux (subcase sub ~expansion_token env a :: subcases) q
+      | a :: q ->
+          List.fold_left (fun acc x ->
+            (subcase sub ~expansion_token:false env x) :: acc
+            )
+            (subcase sub ~expansion_token env a :: subcases)
+            q
+    in
+    match l with
+    | [a] -> [onlycase sub ~expansion_token env a]
+    | l -> aux [] l
+end
+
+
+(** Construct a linear presentation of the error tree *)
+
+open Err
+
+(* Context helper functions *)
+let with_context ?loc ctx printer diff =
+  Location.msg ?loc "%a%a" Context.pp (List.rev ctx)
+    printer diff
+
+let dwith_context ?loc ctx printer =
+  Location.msg ?loc "%a%t" Context.pp (List.rev ctx) printer
+
+let dwith_context_and_elision ?loc ctx printer diff =
+  if is_big (diff.got,diff.expected) then
+    Location.msg ?loc "..."
+  else
+    dwith_context ?loc ctx (printer diff)
+
+(* Merge sub msgs into one printer *)
+let coalesce msgs =
+  match List.rev msgs with
+  | [] -> ignore
+  | before ->
+      let ctx ppf =
+        Format.pp_print_list ~pp_sep:space
+          (fun ppf x -> x.Location.txt ppf)
+          ppf before in
+      ctx
+
+let subcase_list l ppf = match l with
+  | [] -> ()
+  | _ :: _ ->
+      Format.fprintf ppf "@;<1 -2>@[%a@]"
+        (Format.pp_print_list ~pp_sep:space
+           (fun ppf f -> f.Location.txt ppf)
+        )
+        (List.rev l)
+
+(* Printers for leaves *)
+let core id x =
+  match x with
+  | Err.Value_descriptions diff ->
+      let t1 = Printtyp.tree_of_value_description id diff.got in
+      let t2 = Printtyp.tree_of_value_description id diff.expected in
+      Format.dprintf
+        "@[<hv 2>Values do not match:@ %a@;<1 -2>is not included in@ %a@]%a%t"
+        !Oprint.out_sig_item t1
+        !Oprint.out_sig_item t2
+        show_locs (diff.got.val_loc, diff.expected.val_loc)
+        Printtyp.Conflicts.print_explanations
+  | Err.Type_declarations diff ->
+      Format.dprintf "@[<v>@[<hv>%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a%t@]"
+        "Type declarations do not match"
+        !Oprint.out_sig_item
+        (Printtyp.tree_of_type_declaration id diff.got Trec_first)
+        "is not included in"
+        !Oprint.out_sig_item
+        (Printtyp.tree_of_type_declaration id diff.expected Trec_first)
+        (Includecore.report_type_mismatch
+           "the first" "the second" "declaration") diff.symptom
+        show_locs (diff.got.type_loc, diff.expected.type_loc)
+        Printtyp.Conflicts.print_explanations
+  | Err.Extension_constructors diff ->
+      Format.dprintf "@[<v>@[<hv>%s:@;<1 2>%a@ %s@;<1 2>%a@]@ %a%a%t@]"
+        "Extension declarations do not match"
+        !Oprint.out_sig_item
+        (Printtyp.tree_of_extension_constructor id diff.got Text_first)
+        "is not included in"
+        !Oprint.out_sig_item
+        (Printtyp.tree_of_extension_constructor id diff.expected Text_first)
+        (Includecore.report_extension_constructor_mismatch
+           "the first" "the second" "declaration") diff.symptom
+        show_locs (diff.got.ext_loc, diff.expected.ext_loc)
+        Printtyp.Conflicts.print_explanations
+  | Err.Class_type_declarations diff ->
+      Format.dprintf
+        "@[<hv 2>Class type declarations do not match:@ \
+         %a@;<1 -2>does not match@ %a@]@ %a%t"
+        !Oprint.out_sig_item
+        (Printtyp.tree_of_cltype_declaration id diff.got Trec_first)
+        !Oprint.out_sig_item
+        (Printtyp.tree_of_cltype_declaration id diff.expected Trec_first)
+        Includeclass.report_error diff.symptom
+        Printtyp.Conflicts.print_explanations
+  | Err.Class_declarations {got;expected;symptom} ->
+      let t1 = Printtyp.tree_of_class_declaration id got Trec_first in
+      let t2 = Printtyp.tree_of_class_declaration id expected Trec_first in
+      Format.dprintf
+        "@[<hv 2>Class declarations do not match:@ \
+         %a@;<1 -2>does not match@ %a@]@ %a%t"
+        !Oprint.out_sig_item t1
+        !Oprint.out_sig_item t2
+        Includeclass.report_error symptom
+        Printtyp.Conflicts.print_explanations
+
+let missing_field ppf item =
+  let id, loc, kind =  Includemod.item_ident_name item in
+  Format.fprintf ppf "The %s `%a' is required but not provided%a"
+    (Includemod.kind_of_field_desc kind) Printtyp.ident id
+    (show_loc "Expected declaration") loc
+
+let module_types {Err.got=mty1; expected=mty2} =
+  Format.dprintf
+    "@[<hv 2>Modules do not match:@ \
+     %a@;<1 -2>is not included in@ %a@]"
+    !Oprint.out_module_type (Printtyp.tree_of_modtype mty1)
+    !Oprint.out_module_type (Printtyp.tree_of_modtype mty2)
+
+let eq_module_types {Err.got=mty1; expected=mty2} =
+  Format.dprintf
+    "@[<hv 2>Module types do not match:@ \
+     %a@;<1 -2>is not equal to@ %a@]"
+    !Oprint.out_module_type (Printtyp.tree_of_modtype mty1)
+    !Oprint.out_module_type (Printtyp.tree_of_modtype mty2)
+
+let module_type_declarations id {Err.got=d1 ; expected=d2} =
+  Format.dprintf
+    "@[<hv 2>Module type declarations do not match:@ \
+     %a@;<1 -2>does not match@ %a@]"
+    !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d1)
+    !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d2)
+
+let interface_mismatch ppf (diff: _ Err.diff) =
+  Format.fprintf ppf
+    "The implementation %s@ does not match the interface %s:@ "
+    diff.got diff.expected
+
+let core_module_type_symptom (x:Err.core_module_type_symptom)  =
+  match x with
+  | Not_an_alias | Not_an_identifier | Abstract_module_type
+  | Incompatible_aliases ->
+      if Printtyp.Conflicts.exists () then
+        Some Printtyp.Conflicts.print_explanations
+      else None
+  | Unbound_module_path path ->
+      Some(Format.dprintf "Unbound module %a" Printtyp.path path)
+
+(* Construct a linearized error message from the error tree *)
+
+let rec module_type ~expansion_token ~eqmode ~env ~before ~ctx diff =
+  match diff.symptom with
+  | Invalid_module_alias _ (* the difference is non-informative here *)
+  | After_alias_expansion _ (* we print only the expanded module types *) ->
+      module_type_symptom ~eqmode ~expansion_token ~env ~before ~ctx
+        diff.symptom
+  | Functor Params d -> (* We jump directly to the functor param error *)
+      functor_params ~expansion_token ~env ~before ~ctx d
+  | _ ->
+      let inner = if eqmode then eq_module_types else module_types in
+      let next = dwith_context_and_elision ctx inner diff in
+      let before = next :: before in
+      module_type_symptom ~eqmode ~expansion_token ~env ~before ~ctx
+        diff.symptom
+
+and module_type_symptom ~eqmode ~expansion_token ~env ~before ~ctx = function
+  | Mt_core core ->
+      begin match core_module_type_symptom core with
+      | None -> before
+      | Some msg -> Location.msg "%t" msg :: before
+      end
+  | Signature s -> signature ~expansion_token ~env ~before ~ctx s
+  | Functor f -> functor_symptom ~expansion_token ~env ~before ~ctx f
+  | After_alias_expansion diff ->
+      module_type ~eqmode ~expansion_token ~env ~before ~ctx diff
+  | Invalid_module_alias path ->
+      let printer =
+        Format.dprintf "Module %a cannot be aliased" Printtyp.path path
+      in
+      dwith_context ctx printer :: before
+
+and functor_params ~expansion_token ~env ~before ~ctx {got;expected;_} =
+  let d = Functor_suberror.Inclusion.patch env got expected in
+  let actual = Functor_suberror.Inclusion.got d in
+  let expected = Functor_suberror.expected d in
+  let main =
+    Format.dprintf
+      "@[<hv 2>Modules do not match:@ \
+       @[functor@ %t@ -> ...@]@;<1 -2>is not included in@ \
+       @[functor@ %t@ -> ...@]@]"
+      actual expected
+  in
+  let msgs = dwith_context ctx main :: before in
+  let functor_suberrors =
+    if expansion_token then
+      Functor_suberror.params functor_arg_diff ~expansion_token env d
+    else []
+  in
+  functor_suberrors @ msgs
+
+and functor_symptom ~expansion_token ~env ~before ~ctx = function
+  | Result res ->
+      module_type ~expansion_token ~eqmode:false ~env ~before ~ctx res
+  | Params d -> functor_params ~expansion_token ~env ~before ~ctx d
+
+and signature ~expansion_token ~env:_ ~before ~ctx sgs =
+  Printtyp.wrap_printing_env ~error:true sgs.env (fun () ->
+      match sgs.missings, sgs.incompatibles with
+      | a :: l , _ ->
+          if expansion_token then
+            with_context ctx missing_field a
+            :: List.map (Location.msg "%a" missing_field) l
+            @ before
+          else
+            before
+      | [], a :: _ -> sigitem ~expansion_token ~env:sgs.env ~before ~ctx a
+      | [], [] -> assert false
+    )
+and sigitem ~expansion_token ~env ~before ~ctx (name,s) = match s with
+  | Core c ->
+      dwith_context ctx (core name c):: before
+  | Module_type diff ->
+      module_type ~expansion_token ~eqmode:false ~env ~before
+        ~ctx:(Context.Module name :: ctx) diff
+  | Module_type_declaration diff ->
+      module_type_decl ~expansion_token ~env ~before ~ctx name diff
+and module_type_decl ~expansion_token ~env ~before ~ctx id diff =
+  let next =
+    dwith_context_and_elision ctx (module_type_declarations id) diff in
+  let before = next :: before in
+  match diff.symptom with
+  | Not_less_than mts ->
+      let before =
+        Location.msg "The first module type is not included in the second"
+        :: before
+      in
+      module_type ~expansion_token ~eqmode:true ~before ~env
+        ~ctx:(Context.Modtype id :: ctx) mts
+  | Not_greater_than mts ->
+      let before =
+        Location.msg "The second module type is not included in the first"
+        :: before in
+      module_type ~expansion_token ~eqmode:true ~before ~env
+        ~ctx:(Context.Modtype id :: ctx) mts
+  | Incomparable mts ->
+      module_type ~expansion_token ~eqmode:true ~env ~before
+        ~ctx:(Context.Modtype id :: ctx) mts.less_than
+  | Illegal_permutation c ->
+      begin match diff.got.Types.mtd_type with
+      | None -> assert false
+      | Some mty ->
+          with_context (Modtype id::ctx)
+            (Illegal_permutation.pp Context.alt_pp env) (mty,c)
+          :: before
+      end
+
+and functor_arg_diff ~expansion_token env = function
+  | Diffing.Insert mty -> Functor_suberror.Inclusion.insert mty
+  | Diffing.Delete mty -> Functor_suberror.Inclusion.delete mty
+  | Diffing.Keep (x, y, _) ->  Functor_suberror.Inclusion.ok x y
+  | Diffing.Change (_, _, Err.Incompatible_params (i,_)) ->
+      Functor_suberror.Inclusion.incompatible i
+  | Diffing.Change (g, e,  Err.Mismatch mty_diff) ->
+      let more () =
+        subcase_list @@
+        module_type_symptom ~eqmode:false ~expansion_token ~env ~before:[]
+          ~ctx:[] mty_diff.symptom
+      in
+      Functor_suberror.Inclusion.diff g e more
+
+let functor_app_diff ~expansion_token env = function
+  | Diffing.Insert mty ->  Functor_suberror.App.insert mty
+  | Diffing.Delete mty ->  Functor_suberror.App.delete mty
+  | Diffing.Keep (x, y, _) ->  Functor_suberror.App.ok x y
+  | Diffing.Change (_, _, Err.Incompatible_params (i,_)) ->
+      Functor_suberror.App.incompatible i
+  | Diffing.Change (g, e,  Err.Mismatch mty_diff) ->
+      let more () =
+        subcase_list @@
+        module_type_symptom ~eqmode:false ~expansion_token ~env ~before:[]
+          ~ctx:[] mty_diff.symptom
+      in
+      Functor_suberror.App.diff g e more
+
+let module_type_subst ~env id diff =
+  match diff.symptom with
+  | Not_less_than mts ->
+      module_type ~expansion_token:true ~eqmode:true ~before:[] ~env
+        ~ctx:[Modtype id] mts
+  | Not_greater_than mts ->
+      module_type ~expansion_token:true ~eqmode:true ~before:[] ~env
+        ~ctx:[Modtype id] mts
+  | Incomparable mts ->
+      module_type ~expansion_token:true ~eqmode:true ~env ~before:[]
+        ~ctx:[Modtype id] mts.less_than
+  | Illegal_permutation c ->
+      let mty = diff.got in
+      let main =
+        with_context [Modtype id]
+          (Illegal_permutation.pp Context.alt_pp env) (mty,c) in
+      [main]
+
+let all env = function
+  | In_Compilation_unit diff ->
+      let first = Location.msg "%a" interface_mismatch diff in
+      signature ~expansion_token:true ~env ~before:[first] ~ctx:[] diff.symptom
+  | In_Type_declaration (id,reason) ->
+      [Location.msg "%t" (core id reason)]
+  | In_Module_type diff ->
+      module_type ~expansion_token:true ~eqmode:false ~before:[] ~env ~ctx:[]
+        diff
+  | In_Module_type_substitution (id,diff) ->
+      module_type_subst ~env id diff
+  | In_Signature diff ->
+      signature ~expansion_token:true ~before:[] ~env ~ctx:[] diff
+  | In_Expansion cmts ->
+      match core_module_type_symptom cmts with
+      | None -> assert false
+      | Some main -> [Location.msg "%t" main]
+
+(* General error reporting *)
+
+let err_msgs (env, err) =
+  Printtyp.Conflicts.reset();
+  Printtyp.wrap_printing_env ~error:true env
+    (fun () -> coalesce @@ all env err)
+
+let report_error err =
+  let main = err_msgs err in
+  Location.errorf ~loc:Location.(in_file !input_name) "%t" main
+
+let report_apply_error ~loc env (lid_app, mty_f, args) =
+  let may_print_app ppf = match lid_app with
+    | None -> ()
+    | Some lid -> Format.fprintf ppf "%a " Printtyp.longident lid
+  in
+  let d = Functor_suberror.App.patch env ~f:mty_f ~args in
+  match d with
+  (* We specialize the one change and one argument case to remove the
+     presentation of the functor arguments *)
+  | [ _,  Diffing.Change (_, _, Err.Incompatible_params (i,_)) ] ->
+      Location.errorf ~loc "%t" (Functor_suberror.App.incompatible i)
+  | [ _, Diffing.Change (g, e,  Err.Mismatch mty_diff) ] ->
+      let more () =
+        subcase_list @@
+        module_type_symptom ~eqmode:false ~expansion_token:true ~env ~before:[]
+          ~ctx:[] mty_diff.symptom
+      in
+      Location.errorf ~loc "%t" (Functor_suberror.App.single_diff g e more)
+  | _ ->
+      let actual = Functor_suberror.App.got d in
+      let expected = Functor_suberror.expected d in
+      let sub =
+        List.rev @@
+        Functor_suberror.params functor_app_diff env ~expansion_token:true d
+      in
+      Location.errorf ~loc ~sub
+        "@[<hv>The functor application %tis ill-typed.@ \
+         These arguments:@;<1 2>\
+         @[%t@]@ do not match these parameters:@;<1 2>@[functor@ %t@ -> ...@]@]"
+        may_print_app
+        actual expected
+
+let register () =
+  Location.register_error_of_exn
+    (function
+      | Includemod.Error err -> Some (report_error err)
+      | Includemod.Apply_error {loc; env; lid_app; mty_f; args} ->
+          Some (Printtyp.wrap_printing_env env ~error:true (fun () ->
+              report_apply_error ~loc env (lid_app, mty_f, args))
+            )
+      | _ -> None
+    )
diff --git a/src/ocaml/typing/includemod_errorprinter.mli b/src/ocaml/typing/includemod_errorprinter.mli
new file mode 100644
index 0000000..12ea216
--- /dev/null
+++ b/src/ocaml/typing/includemod_errorprinter.mli
@@ -0,0 +1,17 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Florian Angeletti, projet Cambium, Inria Paris             *)
+(*                                                                        *)
+(*   Copyright 2021 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+val err_msgs: Includemod.explanation -> Format.formatter -> unit
+val register: unit -> unit
diff --git a/src/ocaml/typing/magic_numbers.ml b/src/ocaml/typing/magic_numbers.ml
new file mode 100644
index 0000000..4d13cd3
--- /dev/null
+++ b/src/ocaml/typing/magic_numbers.ml
@@ -0,0 +1,56 @@
+open Std
+
+module Cmi = struct
+  type error =
+    | Not_an_interface of string
+    | Wrong_version_interface of string * string
+    | Corrupted_interface of string
+
+  exception Error of error
+
+  let to_version_opt = function
+    | "Caml1999I017" -> Some "4.02"
+    | "Caml1999I020" -> Some "4.03"
+    | "Caml1999I021" -> Some "4.04 or 4.05"
+    | "Caml1999I022" -> Some "4.06"
+    | "Caml1999I023" -> Some "4.07.0"
+    | "Caml1999I024" -> Some "4.07.1"
+    | "Caml1999I025" -> Some "4.08"
+    | "Caml1999I026" -> Some "4.09"
+    | "Caml1999I027" -> Some "4.10"
+    | "Caml1999I028" -> Some "4.11"
+    | "Caml1999I029" -> Some "4.12"
+    | "Caml1999I030" -> Some "4.13"
+    | _ -> None
+
+  open Format
+
+  let report_error ppf = function
+    | Not_an_interface filename ->
+        fprintf ppf "%a@ is not a compiled interface"
+          Location.print_filename filename
+    | Wrong_version_interface (filename, compiler_magic) ->
+      begin match to_version_opt compiler_magic with
+      | None ->
+        fprintf ppf
+          "%a@ seems to be compiled with a version of OCaml that is not@.\
+           supported by Merlin."
+          Location.print_filename filename
+      | Some version ->
+        fprintf ppf
+          "%a@ seems to be compiled with OCaml %s.@.\
+           But this instance of Merlin handles OCaml %s."
+          Location.print_filename filename version
+          (Option.get @@ to_version_opt Config.cmi_magic_number)
+      end
+    | Corrupted_interface filename ->
+        fprintf ppf "Corrupted compiled interface@ %a"
+          Location.print_filename filename
+
+  let () =
+    Location.register_error_of_exn
+      (function
+        | Error err -> Some (Location.error_of_printer_file report_error err)
+        | _ -> None
+      )
+end
diff --git a/src/ocaml/typing/msupport.ml b/src/ocaml/typing/msupport.ml
new file mode 100644
index 0000000..394b77a
--- /dev/null
+++ b/src/ocaml/typing/msupport.ml
@@ -0,0 +1,180 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+
+let errors : (exn list ref * unit Btype.TypeHash.t) option ref = ref None
+
+let monitor_errors' = ref (ref false)
+let monitor_errors () =
+  if !(!monitor_errors') then
+    monitor_errors' := (ref false);
+  !monitor_errors'
+
+let raise_error ?(ignore_unify=false) exn =
+  !monitor_errors' := true;
+  match !errors with
+  | Some (l,_) ->
+    begin match exn with
+      | Ctype.Unify _ when ignore_unify -> ()
+      | Ctype.Unify _ | Failure _ ->
+        Logger.log ~section:"Typing_aux.raise_error"
+          ~title:(Printexc.exn_slot_name exn) "%a"
+          Logger.fmt (fun fmt ->
+              Printexc.record_backtrace true;
+              Format.pp_print_string  fmt (Printexc.get_backtrace ())
+            )
+      | exn -> l := exn :: !l
+    end
+  | None -> raise exn
+
+let () =
+  Msupport_parsing.msupport_raise_error := raise_error
+
+exception Resume
+
+let resume_raise exn =
+  raise_error exn;
+  raise Resume
+
+let catch_errors warnings caught f =
+  let warnings' = Warnings.backup () in
+  let errors' = !errors in
+  Warnings.restore warnings;
+  errors := (Some (caught,Btype.TypeHash.create 3));
+  Misc.try_finally f
+    ~always:(fun () ->
+       errors := errors';
+       Warnings.restore warnings')
+
+let uncatch_errors f =
+  let_ref errors None f
+
+let erroneous_type_register te =
+  match !errors with
+  | Some (_,h) -> Btype.TypeHash.replace h te ()
+  | None -> ()
+
+let erroneous_type_check te =
+  match !errors with
+  | Some (_,h) -> Btype.TypeHash.mem h te
+  | _ -> false
+
+let rec erroneous_expr_check e =
+  (erroneous_type_check e.Typedtree.exp_type) ||
+  match e.Typedtree.exp_desc with
+  | Typedtree.Texp_ident (p,_,_)
+    when Ident.name (Path.head p) = "_" -> true
+  | Typedtree.Texp_apply (e',_) -> erroneous_expr_check e'
+  | _ -> false
+
+exception Warning of Location.t * string
+
+let prerr_warning loc w =
+  match !errors with
+  | None -> () (*Location.print_warning loc Format.err_formatter w*)
+  | Some (l, _) ->
+    let ppf, to_string = Format.to_string () in
+    Location.print_warning loc ppf w;
+    match to_string () with
+      | "" -> ()
+      | s ->  l := Warning (loc,s) :: !l
+
+let prerr_alert loc w =
+  match !errors with
+  | None -> () (*Location.print_warning loc Format.err_formatter w*)
+  | Some (l, _) ->
+    let ppf, to_string = Format.to_string () in
+    Location.print_alert loc ppf w;
+    match to_string () with
+      | "" -> ()
+      | s ->  l := Warning (loc,s) :: !l
+
+let () = Location.register_error_of_exn (function
+    | Warning (loc, str) -> Some (Location.error ~loc ~source:Location.Warning str)
+    | _ -> None
+  )
+
+let () = Location.prerr_warning_ref := prerr_warning
+
+let () = Location.prerr_alert_ref := prerr_alert
+
+let flush_saved_types () =
+  match Cmt_format.get_saved_types () with
+  | [] -> []
+  | parts ->
+    Cmt_format.set_saved_types [];
+    let open Ast_helper in
+    let pexp = Exp.constant (Saved_parts.store parts) in
+    let pstr = Str.eval pexp in
+    [Attr.mk (Saved_parts.attribute) (Parsetree.PStr [pstr])]
+
+let rec get_saved_types_from_attributes = function
+  | [] -> []
+  | attr :: attrs ->
+    let (attr, str) = Ast_helper.Attr.as_tuple attr in
+    if attr = Saved_parts.attribute then
+      let open Parsetree in
+      begin match str with
+      | PStr({pstr_desc =
+                Pstr_eval ({pexp_desc = Pexp_constant key; _ } ,_)
+            ; _ } :: _) ->
+          Saved_parts.find key
+        | _ -> []
+      end
+    else
+      get_saved_types_from_attributes attrs
+
+let with_warning_attribute ?warning_attribute f =
+  match warning_attribute with
+  | None -> f ()
+  | Some attr -> Builtin_attributes.warning_scope attr f
+
+let with_saved_types ?warning_attribute ?save_part f =
+  let saved_types = Cmt_format.get_saved_types () in
+  Cmt_format.set_saved_types [];
+  try
+    let result = with_warning_attribute ?warning_attribute f in
+    begin match save_part with
+      | None -> ()
+      | Some f -> Cmt_format.set_saved_types (f result :: saved_types)
+    end;
+    result
+  with exn ->
+    let saved_types'= Cmt_format.get_saved_types () in
+    Cmt_format.set_saved_types (saved_types' @ saved_types);
+    reraise exn
+
+let incorrect_attribute =
+  Ast_helper.Attr.mk (Location.mknoloc "merlin.incorrect") (Parsetree.PStr [])
+
+let recovery_attributes attrs =
+  let attrs' = incorrect_attribute :: flush_saved_types () in
+  match attrs with
+  | [] -> attrs'
+  | attrs -> attrs' @ attrs
diff --git a/src/ocaml/typing/msupport.mli b/src/ocaml/typing/msupport.mli
new file mode 100644
index 0000000..43d0493
--- /dev/null
+++ b/src/ocaml/typing/msupport.mli
@@ -0,0 +1,76 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+(** Raise an error that can be caught: normal flow is resumed if a
+    [catch_errors] handler was installed. *)
+val raise_error: ?ignore_unify:bool -> exn -> unit
+
+(** Resume after error: like [raise_error], but if a handler was provided a
+    Resume exception is raised.  This allows to specify a special case when an
+    error is caught. *)
+exception Resume
+val resume_raise: exn -> 'a
+
+(** Installing (and removing) error handlers. *)
+
+(** Any [raise_error] invoked inside catch_errors will be added to the list. *)
+val catch_errors: Warnings.state -> exn list ref -> (unit -> 'a) -> 'a
+
+(** Temporary disable catching errors *)
+val uncatch_errors: (unit -> 'a) -> 'a
+
+(** Returns a reference initially set to false that will be set to true when a
+    type error is raised. *)
+val monitor_errors: unit -> bool ref
+
+(** Warnings can also be stored in the caught exception list, wrapped inside
+    this exception *)
+exception Warning of Location.t * string
+
+(* Keep track of type variables generated by error recovery. *)
+
+val erroneous_type_register: Types.type_expr -> unit
+val erroneous_type_check: Types.type_expr -> bool
+val erroneous_expr_check: Typedtree.expression -> bool
+
+(** Turn saved types from Cmt_format into attributes *)
+val flush_saved_types : unit -> Parsetree.attributes
+
+val incorrect_attribute: Parsetree.attribute
+
+(** Extend the given attributes with an incorrect attribute and the saved types
+    after turning them into attributes *)
+val recovery_attributes : Parsetree.attributes -> Parsetree.attributes
+
+(** Retrieve saved types that were turned into attributes *)
+val get_saved_types_from_attributes : Parsetree.attributes -> Cmt_format.binary_part list
+
+val with_saved_types :
+  ?warning_attribute:Parsetree.attributes ->
+  ?save_part:('a -> Cmt_format.binary_part) ->
+  (unit -> 'a) -> 'a
diff --git a/src/ocaml/typing/mtype.ml b/src/ocaml/typing/mtype.ml
new file mode 100644
index 0000000..e4e4f5c
--- /dev/null
+++ b/src/ocaml/typing/mtype.ml
@@ -0,0 +1,534 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Operations on module types *)
+
+open Asttypes
+open Path
+open Types
+
+
+let rec scrape env mty =
+  match mty with
+    Mty_ident p ->
+      begin try
+        scrape env (Env.find_modtype_expansion p env)
+      with Not_found ->
+        mty
+      end
+  | _ -> mty
+
+let freshen ~scope mty =
+  Subst.modtype (Rescope scope) Subst.identity mty
+
+let rec strengthen ~aliasable env mty p =
+  match scrape env mty with
+    Mty_signature sg ->
+      Mty_signature(strengthen_sig ~aliasable env sg p)
+  | Mty_functor(Named (Some param, arg), res)
+    when !Clflags.applicative_functors ->
+      Mty_functor(Named (Some param, arg),
+        strengthen ~aliasable:false env res (Papply(p, Pident param)))
+  | Mty_functor(Named (None, arg), res)
+    when !Clflags.applicative_functors ->
+      let param = Ident.create_scoped ~scope:(Path.scope p) "Arg" in
+      Mty_functor(Named (Some param, arg),
+        strengthen ~aliasable:false env res (Papply(p, Pident param)))
+  | mty ->
+      mty
+
+and strengthen_sig ~aliasable env sg p =
+  match sg with
+    [] -> []
+  | (Sig_value(_, _, _) as sigelt) :: rem ->
+      sigelt :: strengthen_sig ~aliasable env rem p
+  | Sig_type(id, {type_kind=Type_abstract}, _, _) :: rem
+    when Btype.is_row_name (Ident.name id) ->
+      strengthen_sig ~aliasable env rem p
+  | Sig_type(id, decl, rs, vis) :: rem ->
+      let newdecl =
+        match decl.type_manifest, decl.type_private, decl.type_kind with
+          Some _, Public, _ -> decl
+        | Some _, Private, (Type_record _ | Type_variant _) -> decl
+        | _ ->
+            let manif =
+              Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id),
+                                          decl.type_params, ref Mnil))) in
+            if decl.type_kind = Type_abstract then
+              { decl with type_private = Public; type_manifest = manif }
+            else
+              { decl with type_manifest = manif }
+      in
+      Sig_type(id, newdecl, rs, vis) :: strengthen_sig ~aliasable env rem p
+  | (Sig_typext _ as sigelt) :: rem ->
+      sigelt :: strengthen_sig ~aliasable env rem p
+  | Sig_module(id, pres, md, rs, vis) :: rem ->
+      let str =
+        strengthen_decl ~aliasable env md (Pdot(p, Ident.name id))
+      in
+      Sig_module(id, pres, str, rs, vis)
+      :: strengthen_sig ~aliasable
+        (Env.add_module_declaration ~check:false id pres md env) rem p
+      (* Need to add the module in case it defines manifest module types *)
+  | Sig_modtype(id, decl, vis) :: rem ->
+      let newdecl =
+        match decl.mtd_type with
+          None ->
+            {decl with mtd_type = Some(Mty_ident(Pdot(p,Ident.name id)))}
+        | Some _ ->
+            decl
+      in
+      Sig_modtype(id, newdecl, vis) ::
+      strengthen_sig ~aliasable (Env.add_modtype id decl env) rem p
+      (* Need to add the module type in case it is manifest *)
+  | (Sig_class _ as sigelt) :: rem ->
+      sigelt :: strengthen_sig ~aliasable env rem p
+  | (Sig_class_type _ as sigelt) :: rem ->
+      sigelt :: strengthen_sig ~aliasable env rem p
+
+and strengthen_decl ~aliasable env md p =
+  match md.md_type with
+  | Mty_alias _ -> md
+  | _ when aliasable -> {md with md_type = Mty_alias p}
+  | mty -> {md with md_type = strengthen ~aliasable env mty p}
+
+let () = Env.strengthen := strengthen
+
+let rec make_aliases_absent pres mty =
+  match mty with
+  | Mty_alias _ -> Mp_absent, mty
+  | Mty_signature sg ->
+      pres, Mty_signature(make_aliases_absent_sig sg)
+  | Mty_functor(arg, res) ->
+      let _, res = make_aliases_absent Mp_present res in
+      pres, Mty_functor(arg, res)
+  | mty ->
+      pres, mty
+
+and make_aliases_absent_sig sg =
+  match sg with
+    [] -> []
+  | Sig_module(id, pres, md, rs, priv) :: rem ->
+      let pres, md_type = make_aliases_absent pres md.md_type in
+      let md = { md with md_type } in
+      Sig_module(id, pres, md, rs, priv) :: make_aliases_absent_sig rem
+  | sigelt :: rem ->
+      sigelt :: make_aliases_absent_sig rem
+
+let scrape_for_type_of env pres mty =
+  let rec loop env path mty =
+    match mty, path with
+    | Mty_alias path, _ -> begin
+        try
+          let md = Env.find_module path env in
+          loop env (Some path) md.md_type
+        with Not_found -> mty
+      end
+    | mty, Some path ->
+        strengthen ~aliasable:false env mty path
+    | _ -> mty
+  in
+  make_aliases_absent pres (loop env None mty)
+
+(* In nondep_supertype, env is only used for the type it assigns to id.
+   Hence there is no need to keep env up-to-date by adding the bindings
+   traversed. *)
+
+type variance = Co | Contra | Strict
+
+let rec nondep_mty_with_presence env va ids pres mty =
+  match mty with
+    Mty_ident p ->
+      begin match Path.find_free_opt ids p with
+      | Some id ->
+          let expansion =
+            try Env.find_modtype_expansion p env
+            with Not_found ->
+              raise (Ctype.Nondep_cannot_erase id)
+          in
+          nondep_mty_with_presence env va ids pres expansion
+      | None -> pres, mty
+      end
+  | Mty_alias p ->
+      begin match Path.find_free_opt ids p with
+      | Some id ->
+          let expansion =
+            try Env.find_module p env
+            with Not_found ->
+              raise (Ctype.Nondep_cannot_erase id)
+          in
+          nondep_mty_with_presence env va ids Mp_present expansion.md_type
+      | None -> pres, mty
+      end
+  | Mty_signature sg ->
+      let mty = Mty_signature(nondep_sig env va ids sg) in
+      pres, mty
+  | Mty_functor(Unit, res) ->
+      pres, Mty_functor(Unit, nondep_mty env va ids res)
+  | Mty_functor(Named (param, arg), res) ->
+      let var_inv =
+        match va with Co -> Contra | Contra -> Co | Strict -> Strict in
+      let res_env =
+        match param with
+        | None -> env
+        | Some param -> Env.add_module ~arg:true param Mp_present arg env
+      in
+      let mty =
+        Mty_functor(Named (param, nondep_mty env var_inv ids arg),
+                    nondep_mty res_env va ids res)
+      in
+      pres, mty
+  | Mty_for_hole -> pres, Mty_for_hole
+
+and nondep_mty env va ids mty =
+  snd (nondep_mty_with_presence env va ids Mp_present mty)
+
+and nondep_sig_item env va ids = function
+  | Sig_value(id, d, vis) ->
+      Sig_value(id,
+                {d with val_type = Ctype.nondep_type env ids d.val_type},
+                vis)
+  | Sig_type(id, d, rs, vis) ->
+      Sig_type(id, Ctype.nondep_type_decl env ids (va = Co) d, rs, vis)
+  | Sig_typext(id, ext, es, vis) ->
+      Sig_typext(id, Ctype.nondep_extension_constructor env ids ext, es, vis)
+  | Sig_module(id, pres, md, rs, vis) ->
+      let pres, mty = nondep_mty_with_presence env va ids pres md.md_type in
+      Sig_module(id, pres, {md with md_type = mty}, rs, vis)
+  | Sig_modtype(id, d, vis) ->
+      begin try
+        Sig_modtype(id, nondep_modtype_decl env ids d, vis)
+      with Ctype.Nondep_cannot_erase _ as exn ->
+        match va with
+          Co -> Sig_modtype(id, {mtd_type=None; mtd_loc=Location.none;
+                                 mtd_attributes=[]; mtd_uid = d.mtd_uid}, vis)
+        | _  -> raise exn
+      end
+  | Sig_class(id, d, rs, vis) ->
+      Sig_class(id, Ctype.nondep_class_declaration env ids d, rs, vis)
+  | Sig_class_type(id, d, rs, vis) ->
+      Sig_class_type(id, Ctype.nondep_cltype_declaration env ids d, rs, vis)
+
+and nondep_sig env va ids sg =
+  let scope = Ctype.create_scope () in
+  let sg, env = Env.enter_signature ~scope sg env in
+  List.map (nondep_sig_item env va ids) sg
+
+and nondep_modtype_decl env ids mtd =
+  {mtd with mtd_type = Option.map (nondep_mty env Strict ids) mtd.mtd_type}
+
+let nondep_supertype env ids = nondep_mty env Co ids
+let nondep_sig_item env ids = nondep_sig_item env Co ids
+
+let enrich_typedecl env p id decl =
+  match decl.type_manifest with
+    Some _ -> decl
+  | None ->
+    match Env.find_type p env with
+    | exception Not_found -> decl
+        (* Type which was not present in the signature, so we don't have
+           anything to do. *)
+    | orig_decl ->
+        if decl.type_arity <> orig_decl.type_arity then
+          decl
+        else begin
+          let orig_ty =
+            Ctype.reify_univars env
+              (Btype.newgenty(Tconstr(p, orig_decl.type_params, ref Mnil)))
+          in
+          let new_ty =
+            Ctype.reify_univars env
+              (Btype.newgenty(Tconstr(Pident id, decl.type_params, ref Mnil)))
+          in
+          let env = Env.add_type ~check:false id decl env in
+          match Ctype.mcomp env orig_ty new_ty with
+          | exception Ctype.Incompatible -> decl
+              (* The current declaration is not compatible with the one we got
+                 from the signature. We should just fail now, but then, we could
+                 also have failed if the arities of the two decls were
+                 different, which we didn't. *)
+          | () ->
+              let orig_ty =
+                Btype.newgenty(Tconstr(p, decl.type_params, ref Mnil))
+              in
+              {decl with type_manifest = Some orig_ty}
+        end
+
+let rec enrich_modtype env p mty =
+  match mty with
+    Mty_signature sg ->
+      Mty_signature(List.map (enrich_item env p) sg)
+  | _ ->
+      mty
+
+and enrich_item env p = function
+    Sig_type(id, decl, rs, priv) ->
+      Sig_type(id,
+                enrich_typedecl env (Pdot(p, Ident.name id)) id decl, rs, priv)
+  | Sig_module(id, pres, md, rs, priv) ->
+      Sig_module(id, pres,
+                  {md with
+                   md_type = enrich_modtype env
+                       (Pdot(p, Ident.name id)) md.md_type},
+                 rs,
+                 priv)
+  | item -> item
+
+let rec type_paths env p mty =
+  match scrape env mty with
+    Mty_ident _ -> []
+  | Mty_alias _ -> []
+  | Mty_signature sg -> type_paths_sig env p sg
+  | Mty_functor _ -> []
+  | Mty_for_hole -> []
+
+and type_paths_sig env p sg =
+  match sg with
+    [] -> []
+  | Sig_type(id, _decl, _, _) :: rem ->
+      Pdot(p, Ident.name id) :: type_paths_sig env p rem
+  | Sig_module(id, pres, md, _, _) :: rem ->
+      type_paths env (Pdot(p, Ident.name id)) md.md_type @
+      type_paths_sig (Env.add_module_declaration ~check:false id pres md env)
+        p rem
+  | Sig_modtype(id, decl, _) :: rem ->
+      type_paths_sig (Env.add_modtype id decl env) p rem
+  | (Sig_value _ | Sig_typext _ | Sig_class _ | Sig_class_type _) :: rem ->
+      type_paths_sig env p rem
+
+
+let rec no_code_needed_mod env pres mty =
+  match pres with
+  | Mp_absent -> true
+  | Mp_present -> begin
+      match scrape env mty with
+        Mty_ident _ -> false
+      | Mty_signature sg -> no_code_needed_sig env sg
+      | Mty_functor _ -> false
+      | Mty_alias _ -> false
+      | Mty_for_hole -> true
+    end
+
+and no_code_needed_sig env sg =
+  match sg with
+    [] -> true
+  | Sig_value(_id, decl, _) :: rem ->
+      begin match decl.val_kind with
+      | Val_prim _ -> no_code_needed_sig env rem
+      | _ -> false
+      end
+  | Sig_module(id, pres, md, _, _) :: rem ->
+      no_code_needed_mod env pres md.md_type &&
+      no_code_needed_sig
+        (Env.add_module_declaration ~check:false id pres md env) rem
+  | (Sig_type _ | Sig_modtype _ | Sig_class_type _) :: rem ->
+      no_code_needed_sig env rem
+  | (Sig_typext _ | Sig_class _) :: _ ->
+      false
+
+let no_code_needed env mty = no_code_needed_mod env Mp_present mty
+
+(* Check whether a module type may return types *)
+
+let rec contains_type env = function
+    Mty_ident path ->
+      begin try match (Env.find_modtype path env).mtd_type with
+      | None -> raise Exit (* PR#6427 *)
+      | Some mty -> contains_type env mty
+      with Not_found -> raise Exit
+      end
+  | Mty_signature sg ->
+      contains_type_sig env sg
+  | Mty_functor (_, body) ->
+      contains_type env body
+  | Mty_alias _
+  | Mty_for_hole ->
+      ()
+
+and contains_type_sig env = List.iter (contains_type_item env)
+
+and contains_type_item env = function
+    Sig_type (_,({type_manifest = None} |
+                 {type_kind = Type_abstract; type_private = Private}),_, _)
+  | Sig_modtype _
+  | Sig_typext (_, {ext_args = Cstr_record _}, _, _) ->
+      (* We consider that extension constructors with an inlined
+         record create a type (the inlined record), even though
+         it would be technically safe to ignore that considering
+         the current constraints which guarantee that this type
+         is kept local to expressions.  *)
+      raise Exit
+  | Sig_module (_, _, {md_type = mty}, _, _) ->
+      contains_type env mty
+  | Sig_value _
+  | Sig_type _
+  | Sig_typext _
+  | Sig_class _
+  | Sig_class_type _ ->
+      ()
+
+let contains_type env mty =
+  try contains_type env mty; false with Exit -> true
+
+
+(* Remove module aliases from a signature *)
+
+let rec get_prefixes = function
+  | Pident _ -> Path.Set.empty
+  | Pdot (p, _)
+  | Papply (p, _) -> Path.Set.add p (get_prefixes p)
+
+let rec get_arg_paths = function
+  | Pident _ -> Path.Set.empty
+  | Pdot (p, _) -> get_arg_paths p
+  | Papply (p1, p2) ->
+      Path.Set.add p2
+        (Path.Set.union (get_prefixes p2)
+           (Path.Set.union (get_arg_paths p1) (get_arg_paths p2)))
+
+let rec rollback_path subst p =
+  try Pident (Path.Map.find p subst)
+  with Not_found ->
+    match p with
+      Pident _ | Papply _ -> p
+    | Pdot (p1, s) ->
+        let p1' = rollback_path subst p1 in
+        if Path.same p1 p1' then p else rollback_path subst (Pdot (p1', s))
+
+let rec collect_ids subst bindings p =
+    begin match rollback_path subst p with
+      Pident id ->
+        let ids =
+          try collect_ids subst bindings (Ident.find_same id bindings)
+          with Not_found -> Ident.Set.empty
+        in
+        Ident.Set.add id ids
+    | _ -> Ident.Set.empty
+    end
+
+let collect_arg_paths mty =
+  let open Btype in
+  let paths = ref Path.Set.empty
+  and subst = ref Path.Map.empty
+  and bindings = ref Ident.empty in
+  (* let rt = Ident.create "Root" in
+     and prefix = ref (Path.Pident rt) in *)
+  let it_path p = paths := Path.Set.union (get_arg_paths p) !paths
+  and it_signature_item it si =
+    type_iterators.it_signature_item it si;
+    match si with
+    | Sig_module (id, _, {md_type=Mty_alias p}, _, _) ->
+        bindings := Ident.add id p !bindings
+    | Sig_module (id, _, {md_type=Mty_signature sg}, _, _) ->
+        List.iter
+          (function Sig_module (id', _, _, _, _) ->
+              subst :=
+                Path.Map.add (Pdot (Pident id, Ident.name id')) id' !subst
+            | _ -> ())
+          sg
+    | _ -> ()
+  in
+  let it = {type_iterators with it_path; it_signature_item} in
+  it.it_module_type it mty;
+  it.it_module_type unmark_iterators mty;
+  Path.Set.fold (fun p -> Ident.Set.union (collect_ids !subst !bindings p))
+    !paths Ident.Set.empty
+
+type remove_alias_args =
+    { mutable modified: bool;
+      exclude: Ident.t -> Path.t -> bool;
+      scrape: Env.t -> module_type -> module_type }
+
+let rec remove_aliases_mty env args pres mty =
+  let args' = {args with modified = false} in
+  let res =
+    match args.scrape env mty with
+      Mty_signature sg ->
+        Mp_present, Mty_signature (remove_aliases_sig env args' sg)
+    | Mty_alias _ ->
+        let mty' = Env.scrape_alias env mty in
+        if mty' = mty then begin
+          pres, mty
+        end else begin
+          args'.modified <- true;
+          remove_aliases_mty env args' Mp_present mty'
+        end
+    | mty ->
+        Mp_present, mty
+  in
+  if args'.modified then begin
+    args.modified <- true;
+    res
+  end else begin
+    pres, mty
+  end
+
+and remove_aliases_sig env args sg =
+  match sg with
+    [] -> []
+  | Sig_module(id, pres, md, rs, priv) :: rem  ->
+      let pres, mty =
+        match md.md_type with
+          Mty_alias p when args.exclude id p ->
+            pres, md.md_type
+        | mty ->
+            remove_aliases_mty env args pres mty
+      in
+      Sig_module(id, pres, {md with md_type = mty} , rs, priv) ::
+      remove_aliases_sig (Env.add_module id pres mty env) args rem
+  | Sig_modtype(id, mtd, priv) :: rem ->
+      Sig_modtype(id, mtd, priv) ::
+      remove_aliases_sig (Env.add_modtype id mtd env) args rem
+  | it :: rem ->
+      it :: remove_aliases_sig env args rem
+
+let scrape_for_functor_arg env mty =
+  let exclude _id p =
+    try ignore (Env.find_module p env); true with Not_found -> false
+  in
+  let _, mty =
+    remove_aliases_mty env {modified=false; exclude; scrape} Mp_present mty
+  in
+  mty
+
+let scrape_for_type_of ~remove_aliases env mty =
+  if remove_aliases then begin
+    let excl = collect_arg_paths mty in
+    let exclude id _p = Ident.Set.mem id excl in
+    let scrape _ mty = mty in
+    let _, mty =
+      remove_aliases_mty env {modified=false; exclude; scrape} Mp_present mty
+    in
+    mty
+  end else begin
+    let _, mty = scrape_for_type_of env Mp_present mty in
+    mty
+  end
+
+(* Lower non-generalizable type variables *)
+
+let lower_nongen nglev mty =
+  let open Btype in
+  let it_type_expr it ty =
+    let ty = repr ty in
+    match ty with
+      {desc=Tvar _; level} ->
+        if level < generic_level && level > nglev then set_level ty nglev
+    | _ ->
+        type_iterators.it_type_expr it ty
+  in
+  let it = {type_iterators with it_type_expr} in
+  it.it_module_type it mty;
+  it.it_module_type unmark_iterators mty
diff --git a/src/ocaml/typing/mtype.mli b/src/ocaml/typing/mtype.mli
new file mode 100644
index 0000000..68d290b
--- /dev/null
+++ b/src/ocaml/typing/mtype.mli
@@ -0,0 +1,55 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Operations on module types *)
+
+open Types
+
+val scrape: Env.t -> module_type -> module_type
+        (* Expand toplevel module type abbreviations
+           till hitting a "hard" module type (signature, functor,
+           or abstract module type ident. *)
+val scrape_for_functor_arg: Env.t -> module_type -> module_type
+        (* Remove aliases in a functor argument type *)
+val scrape_for_type_of:
+  remove_aliases:bool -> Env.t -> module_type -> module_type
+        (* Process type for module type of *)
+val freshen: scope:int -> module_type -> module_type
+        (* Return an alpha-equivalent copy of the given module type
+           where bound identifiers are fresh. *)
+val strengthen: aliasable:bool -> Env.t -> module_type -> Path.t -> module_type
+        (* Strengthen abstract type components relative to the
+           given path. *)
+val strengthen_decl:
+  aliasable:bool -> Env.t -> module_declaration -> Path.t -> module_declaration
+val nondep_supertype: Env.t -> Ident.t list -> module_type -> module_type
+        (* Return the smallest supertype of the given type
+           in which none of the given idents appears.
+           @raise [Ctype.Nondep_cannot_erase] if no such type exists. *)
+val nondep_sig_item: Env.t -> Ident.t list -> signature_item -> signature_item
+        (* Returns the signature item with its type updated
+           to be the smallest supertype of its initial type
+           in which none of the given idents appears.
+           @raise [Ctype.Nondep_cannot_erase] if no such type exists. *)
+val no_code_needed: Env.t -> module_type -> bool
+val no_code_needed_sig: Env.t -> signature -> bool
+        (* Determine whether a module needs no implementation code,
+           i.e. consists only of type definitions. *)
+val enrich_modtype: Env.t -> Path.t -> module_type -> module_type
+val enrich_typedecl: Env.t -> Path.t -> Ident.t -> type_declaration ->
+  type_declaration
+val type_paths: Env.t -> Path.t -> module_type -> Path.t list
+val contains_type: Env.t -> module_type -> bool
+val lower_nongen: int -> module_type -> unit
diff --git a/src/ocaml/typing/natural.ml b/src/ocaml/typing/natural.ml
new file mode 100644
index 0000000..c79be05
--- /dev/null
+++ b/src/ocaml/typing/natural.ml
@@ -0,0 +1,270 @@
+
+module type Array = sig
+
+  type index
+
+  type 'a t
+
+  val empty : 'a t
+
+  val singleton : 'a -> 'a t
+
+  val extend : 'a t -> index -> (index -> 'a) -> 'a t
+
+  val retract : 'a t -> index -> 'a t
+
+  val contains : 'a t -> index -> bool
+
+  val last : 'a t -> index option
+
+  val set : 'a t -> index -> 'a -> unit
+
+  val get : 'a t -> index -> 'a
+
+end
+
+module type S_no_zero = sig
+
+  type t
+
+  val one : t
+
+  val maximum : t
+
+  val succ : t -> t
+
+  val pred : t -> t option
+
+  val compare : t -> t -> int
+
+  val equal : t -> t -> bool
+
+  val less_than : t -> t -> bool
+
+  val less_than_or_equal : t -> t -> bool
+
+  val max : t -> t -> t
+
+  val plus : t -> t -> t
+
+  val pp : Format.formatter -> t -> unit
+
+  module Map : Map.S with type key = t
+
+  module Set : Set.S with type elt = t
+
+  module Tbl : Hashtbl.S with type key = t
+
+  module Array : Array with type index = t
+
+end
+
+module type S = sig
+
+  include S_no_zero
+
+  val zero : t
+
+end
+
+module IntOps = struct
+
+  type t = int
+
+  let compare (x : t) (y : t) =
+    compare x y
+
+  let equal (x : t) (y : t) =
+    x = y
+
+  let less_than (x : t) (y : t) =
+    x < y
+
+  let less_than_or_equal (x : t) (y : t) =
+    x <= y
+
+  let max (x : t) (y : t) =
+    if x >= y then x
+    else y
+
+  let hash = Hashtbl.hash
+
+  let pp ppf x = Format.pp_print_int ppf x
+
+end
+
+module IntMap = Map.Make(IntOps)
+
+module IntSet = Set.Make(IntOps)
+
+module IntTbl = Hashtbl.Make(IntOps)
+
+module Array_zero_indexed = struct
+
+  type index = int
+
+  type 'a t = 'a array
+
+  let empty = [| |]
+
+  let singleton x = [| x |]
+
+  let extend t idx init =
+    let len = idx + 1 in
+    let old_len = Array.length t in
+    if old_len > idx then
+      failwith "Natural.Array.extend: array already contains index";
+    if old_len = 0 then begin
+      Array.init len init
+    end else begin
+      let extended = Array.make len (t.(0)) in
+      Array.blit t 0 extended 0 old_len;
+      for i = old_len to idx do
+        Array.unsafe_set extended i (init i)
+      done;
+      extended
+    end
+
+  let retract t idx =
+    let old_len = Array.length t in
+    if old_len <= idx then
+      failwith "Natural.Array.retract: array already doesn't contain index";
+    Array.sub t 0 idx
+
+  let contains t idx =
+    let len = Array.length t in
+    idx < len
+
+  let last t =
+    let len = Array.length t in
+    if len = 0 then None
+    else Some (len - 1)
+
+  let set t idx data =
+    t.(idx) <- data
+
+  let get t idx =
+    t.(idx)
+
+end
+
+module Array_one_indexed = struct
+
+  type index = int
+
+  type 'a t = 'a array
+
+  let empty = [| |]
+
+  let singleton x = [| x |]
+
+  let extend t idx init =
+    let old_len = Array.length t in
+    if old_len >= idx then
+      failwith "Natural.Array.extend: array already contains index";
+    if old_len = 0 then begin
+      let initial = init 1 in
+      let res = Array.make idx initial in
+      for i = 1 to (idx - 1) do
+        Array.unsafe_set res i (init (i + 1))
+      done;
+      res
+    end else begin
+      let extended = Array.make idx (t.(0)) in
+      Array.blit t 0 extended 0 old_len;
+      for i = old_len to (idx - 1) do
+        Array.unsafe_set extended i (init (i + 1))
+      done;
+      extended
+    end
+
+  let retract t idx =
+    let old_len = Array.length t in
+    if old_len < idx then
+      failwith "Natural.Array.retract: array already doesn't contain index";
+    Array.sub t 0 (idx - 1)
+
+  let contains t idx =
+    let len = Array.length t in
+    idx <= len
+
+  let last t =
+    let len = Array.length t in
+    if len = 0 then None
+    else Some len
+
+  let set t idx data =
+    t.(idx - 1) <- data
+
+  let get t idx =
+    t.(idx - 1)
+
+end
+
+module Nat = struct
+
+  include IntOps
+
+  let zero = 0
+
+  let one = 1
+
+  let maximum = max_int
+
+  let succ t =
+    if t = maximum then t
+    else t + 1
+
+  let pred t =
+    if t = 0 then None
+    else Some (t - 1)
+
+  let plus t1 t2 =
+    let res = t1 + t2 in
+    if res < 0 then maximum
+    else res
+
+  module Map = IntMap
+
+  module Set = IntSet
+
+  module Tbl = IntTbl
+
+  module Array = Array_zero_indexed
+
+end
+
+module Nat_no_zero = struct
+
+  include IntOps
+
+  let one = 1
+
+  let maximum = max_int
+
+  let succ t =
+    if t = maximum then t
+    else t + 1
+
+  let pred t =
+    if t = 1 then None
+    else Some (t - 1)
+
+  let plus t1 t2 =
+    let res = t1 + t2 in
+    if res < 0 then maximum
+    else res
+
+  module Map = IntMap
+
+  module Set = IntSet
+
+  module Tbl = IntTbl
+
+  module Array = Array_one_indexed
+
+end
+
+module Make () = Nat
+
+module Make_no_zero () = Nat_no_zero
diff --git a/src/ocaml/typing/natural.mli b/src/ocaml/typing/natural.mli
new file mode 100644
index 0000000..7ae1b08
--- /dev/null
+++ b/src/ocaml/typing/natural.mli
@@ -0,0 +1,83 @@
+(** Support for creating fresh types isomorphic to the natural numbers *)
+
+(** Module type for arrays indexed by a type [index] *)
+module type Array = sig
+
+  type index
+
+  type 'a t
+
+  val empty : 'a t
+
+  val singleton : 'a -> 'a t
+
+  val extend : 'a t -> index -> (index -> 'a) -> 'a t
+
+  val retract : 'a t -> index -> 'a t
+
+  val contains : 'a t -> index -> bool
+
+  val last : 'a t -> index option
+
+  val set : 'a t -> index -> 'a -> unit
+
+  val get : 'a t -> index -> 'a
+
+end
+
+(** Module type for types isomorphic to the natural numbers
+    without zero (up to [maximum]) *)
+module type S_no_zero = sig
+
+  type t
+
+  val one : t
+
+  val maximum : t
+
+  val succ : t -> t
+
+  val pred : t -> t option
+
+  val compare : t -> t -> int
+
+  val equal : t -> t -> bool
+
+  val less_than : t -> t -> bool
+
+  val less_than_or_equal : t -> t -> bool
+
+  val max : t -> t -> t
+
+  val plus : t -> t -> t
+
+  val pp : Format.formatter -> t -> unit
+
+  module Map : Map.S with type key = t
+
+  module Set : Set.S with type elt = t
+
+  module Tbl : Hashtbl.S with type key = t
+
+  module Array : Array with type index = t
+
+end
+
+
+(** Module type for types isomorphic to the natural numbers
+    (up to [maximum]) *)
+module type S = sig
+
+  include S_no_zero
+
+  val zero : t
+
+end
+
+(** Functor to create fresh types isomorphic to the natural numbers *)
+module Make () : S
+
+(** Functor to create fresh types isomorphic to the natural numbers
+    without zero *)
+module Make_no_zero () : S_no_zero
+
diff --git a/src/ocaml/typing/oprint.ml b/src/ocaml/typing/oprint.ml
new file mode 100644
index 0000000..3175a1c
--- /dev/null
+++ b/src/ocaml/typing/oprint.ml
@@ -0,0 +1,833 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Projet Cristal, INRIA Rocquencourt                   *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Format
+open Outcometree
+
+exception Ellipsis
+
+let cautious f ppf arg =
+  try f ppf arg with
+    Ellipsis -> fprintf ppf "..."
+
+let print_lident ppf = function
+  | "::" -> pp_print_string ppf "(::)"
+  | s -> pp_print_string ppf s
+
+let rec print_ident ppf =
+  function
+    Oide_ident s -> print_lident ppf s.printed_name
+  | Oide_dot (id, s) ->
+      print_ident ppf id; pp_print_char ppf '.'; print_lident ppf s
+  | Oide_apply (id1, id2) ->
+      fprintf ppf "%a(%a)" print_ident id1 print_ident id2
+
+let out_ident = ref print_ident
+
+(* Check a character matches the [identchar_latin1] class from the lexer *)
+let is_ident_char c =
+  match c with
+  | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214' | '\216'..'\246'
+  | '\248'..'\255' | '\'' | '0'..'9' -> true
+  | _ -> false
+
+let all_ident_chars s =
+  let rec loop s len i =
+    if i < len then begin
+      if is_ident_char s.[i] then loop s len (i+1)
+      else false
+    end else begin
+      true
+    end
+  in
+  let len = String.length s in
+  loop s len 0
+
+let parenthesized_ident name =
+  (List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"])
+  || not (all_ident_chars name)
+
+let value_ident ppf name =
+  if parenthesized_ident name then
+    fprintf ppf "( %s )" name
+  else
+    pp_print_string ppf name
+
+(* Values *)
+
+let valid_float_lexeme s =
+  let l = String.length s in
+  let rec loop i =
+    if i >= l then s ^ "." else
+    match s.[i] with
+    | '0' .. '9' | '-' -> loop (i+1)
+    | _ -> s
+  in loop 0
+
+let float_repres f =
+  match classify_float f with
+    FP_nan -> "nan"
+  | FP_infinite ->
+      if f < 0.0 then "neg_infinity" else "infinity"
+  | _ ->
+      let float_val =
+        let s1 = Printf.sprintf "%.12g" f in
+        if f = float_of_string s1 then s1 else
+        let s2 = Printf.sprintf "%.15g" f in
+        if f = float_of_string s2 then s2 else
+        Printf.sprintf "%.18g" f
+      in valid_float_lexeme float_val
+
+let parenthesize_if_neg ppf fmt v isneg =
+  if isneg then pp_print_char ppf '(';
+  fprintf ppf fmt v;
+  if isneg then pp_print_char ppf ')'
+
+let escape_string s =
+  (* Escape only C0 control characters (bytes <= 0x1F), DEL(0x7F), '\\'
+     and '"' *)
+   let n = ref 0 in
+  for i = 0 to String.length s - 1 do
+    n := !n +
+      (match String.unsafe_get s i with
+       | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2
+       | '\x00' .. '\x1F'
+       | '\x7F' -> 4
+       | _ -> 1)
+  done;
+  if !n = String.length s then s else begin
+    let s' = Bytes.create !n in
+    n := 0;
+    for i = 0 to String.length s - 1 do
+      begin match String.unsafe_get s i with
+      | ('\"' | '\\') as c ->
+          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n c
+      | '\n' ->
+          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'n'
+      | '\t' ->
+          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 't'
+      | '\r' ->
+          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'r'
+      | '\b' ->
+          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'b'
+      | '\x00' .. '\x1F' | '\x7F' as c ->
+          let a = Char.code c in
+          Bytes.unsafe_set s' !n '\\';
+          incr n;
+          Bytes.unsafe_set s' !n (Char.chr (48 + a / 100));
+          incr n;
+          Bytes.unsafe_set s' !n (Char.chr (48 + (a / 10) mod 10));
+          incr n;
+          Bytes.unsafe_set s' !n (Char.chr (48 + a mod 10));
+      | c -> Bytes.unsafe_set s' !n c
+      end;
+      incr n
+    done;
+    Bytes.to_string s'
+  end
+
+
+let print_out_string ppf s =
+  let not_escaped =
+    (* let the user dynamically choose if strings should be escaped: *)
+    match Sys.getenv_opt "OCAMLTOP_UTF_8" with
+    | None -> true
+    | Some x ->
+        match bool_of_string_opt x with
+        | None -> true
+        | Some f -> f in
+  if not_escaped then
+    fprintf ppf "\"%s\"" (escape_string s)
+  else
+    fprintf ppf "%S" s
+
+let print_out_value ppf tree =
+  let rec print_tree_1 ppf =
+    function
+    | Oval_constr (name, [param]) ->
+        fprintf ppf "@[<1>%a@ %a@]" print_ident name print_constr_param param
+    | Oval_constr (name, (_ :: _ as params)) ->
+        fprintf ppf "@[<1>%a@ (%a)@]" print_ident name
+          (print_tree_list print_tree_1 ",") params
+    | Oval_variant (name, Some param) ->
+        fprintf ppf "@[<2>`%s@ %a@]" name print_constr_param param
+    | tree -> print_simple_tree ppf tree
+  and print_constr_param ppf = function
+    | Oval_int i -> parenthesize_if_neg ppf "%i" i (i < 0)
+    | Oval_int32 i -> parenthesize_if_neg ppf "%lil" i (i < 0l)
+    | Oval_int64 i -> parenthesize_if_neg ppf "%LiL" i (i < 0L)
+    | Oval_nativeint i -> parenthesize_if_neg ppf "%nin" i (i < 0n)
+    | Oval_float f ->
+        parenthesize_if_neg ppf "%s" (float_repres f)
+                                     (f < 0.0 || 1. /. f = neg_infinity)
+    | Oval_string (_,_, Ostr_bytes) as tree ->
+      pp_print_char ppf '(';
+      print_simple_tree ppf tree;
+      pp_print_char ppf ')';
+    | tree -> print_simple_tree ppf tree
+  and print_simple_tree ppf =
+    function
+      Oval_int i -> fprintf ppf "%i" i
+    | Oval_int32 i -> fprintf ppf "%lil" i
+    | Oval_int64 i -> fprintf ppf "%LiL" i
+    | Oval_nativeint i -> fprintf ppf "%nin" i
+    | Oval_float f -> pp_print_string ppf (float_repres f)
+    | Oval_char c -> fprintf ppf "%C" c
+    | Oval_string (s, maxlen, kind) ->
+       begin try
+         let len = String.length s in
+         let s = if len > maxlen then String.sub s 0 maxlen else s in
+         begin match kind with
+         | Ostr_bytes -> fprintf ppf "Bytes.of_string %S" s
+         | Ostr_string -> print_out_string ppf s
+         end;
+         (if len > maxlen then
+            fprintf ppf
+              "... (* string length %d; truncated *)" len
+         )
+          with
+          Invalid_argument _ (* "String.create" *)-> fprintf ppf "<huge string>"
+        end
+    | Oval_list tl ->
+        fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ";") tl
+    | Oval_array tl ->
+        fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ";") tl
+    | Oval_constr (name, []) -> print_ident ppf name
+    | Oval_variant (name, None) -> fprintf ppf "`%s" name
+    | Oval_stuff s -> pp_print_string ppf s
+    | Oval_record fel ->
+        fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel
+    | Oval_ellipsis -> raise Ellipsis
+    | Oval_printer f -> f ppf
+    | Oval_tuple tree_list ->
+        fprintf ppf "@[<1>(%a)@]" (print_tree_list print_tree_1 ",") tree_list
+    | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree_1) tree
+  and print_fields first ppf =
+    function
+      [] -> ()
+    | (name, tree) :: fields ->
+        if not first then fprintf ppf ";@ ";
+        fprintf ppf "@[<1>%a@ =@ %a@]" print_ident name (cautious print_tree_1)
+          tree;
+        print_fields false ppf fields
+  and print_tree_list print_item sep ppf tree_list =
+    let rec print_list first ppf =
+      function
+        [] -> ()
+      | tree :: tree_list ->
+          if not first then fprintf ppf "%s@ " sep;
+          print_item ppf tree;
+          print_list false ppf tree_list
+    in
+    cautious (print_list true) ppf tree_list
+  in
+  cautious print_tree_1 ppf tree
+
+let out_value = ref print_out_value
+
+(* Types *)
+
+let rec print_list_init pr sep ppf =
+  function
+    [] -> ()
+  | a :: l -> sep ppf; pr ppf a; print_list_init pr sep ppf l
+
+let rec print_list pr sep ppf =
+  function
+    [] -> ()
+  | [a] -> pr ppf a
+  | a :: l -> pr ppf a; sep ppf; print_list pr sep ppf l
+
+let pr_present =
+  print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ")
+
+let pr_var = Pprintast.tyvar
+
+let pr_vars =
+  print_list pr_var (fun ppf -> fprintf ppf "@ ")
+
+let rec print_out_type ppf =
+  function
+  | Otyp_alias (ty, s) ->
+      fprintf ppf "@[%a@ as %a@]" print_out_type ty pr_var s
+  | Otyp_poly (sl, ty) ->
+      fprintf ppf "@[<hov 2>%a.@ %a@]"
+        pr_vars sl
+        print_out_type ty
+  | ty ->
+      print_out_type_1 ppf ty
+
+and print_out_type_1 ppf =
+  function
+    Otyp_arrow (lab, ty1, ty2) ->
+      pp_open_box ppf 0;
+      if lab <> "" then (pp_print_string ppf lab; pp_print_char ppf ':');
+      print_out_type_2 ppf ty1;
+      pp_print_string ppf " ->";
+      pp_print_space ppf ();
+      print_out_type_1 ppf ty2;
+      pp_close_box ppf ()
+  | ty -> print_out_type_2 ppf ty
+and print_out_type_2 ppf =
+  function
+    Otyp_tuple tyl ->
+      fprintf ppf "@[<0>%a@]" (print_typlist print_simple_out_type " *") tyl
+  | ty -> print_simple_out_type ppf ty
+and print_simple_out_type ppf =
+  function
+    Otyp_class (ng, id, tyl) ->
+      fprintf ppf "@[%a%s#%a@]" print_typargs tyl (if ng then "_" else "")
+        print_ident id
+  | Otyp_constr (id, tyl) ->
+      pp_open_box ppf 0;
+      print_typargs ppf tyl;
+      print_ident ppf id;
+      pp_close_box ppf ()
+  | Otyp_object (fields, rest) ->
+      fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields
+  | Otyp_stuff s -> pp_print_string ppf s
+  | Otyp_var (ng, s) -> pr_var ppf (if ng then "_" ^ s else s)
+  | Otyp_variant (non_gen, row_fields, closed, tags) ->
+      let print_present ppf =
+        function
+          None | Some [] -> ()
+        | Some l -> fprintf ppf "@;<1 -2>> @[<hov>%a@]" pr_present l
+      in
+      let print_fields ppf =
+        function
+          Ovar_fields fields ->
+            print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ")
+              ppf fields
+        | Ovar_typ typ ->
+           print_simple_out_type ppf typ
+      in
+      fprintf ppf "%s@[<hov>[%s@[<hv>@[<hv>%a@]%a@]@ ]@]"
+        (if non_gen then "_" else "")
+        (if closed then if tags = None then " " else "< "
+         else if tags = None then "> " else "? ")
+        print_fields row_fields
+        print_present tags
+  | Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty ->
+      pp_open_box ppf 1;
+      pp_print_char ppf '(';
+      print_out_type ppf ty;
+      pp_print_char ppf ')';
+      pp_close_box ppf ()
+  | Otyp_abstract | Otyp_open
+  | Otyp_sum _ | Otyp_manifest (_, _) -> ()
+  | Otyp_record lbls -> print_record_decl ppf lbls
+  | Otyp_module (p, fl) ->
+      fprintf ppf "@[<1>(module %a" print_ident p;
+      let first = ref true in
+      List.iter
+        (fun (s, t) ->
+          let sep = if !first then (first := false; "with") else "and" in
+          fprintf ppf " %s type %s = %a" sep s print_out_type t
+        )
+        fl;
+      fprintf ppf ")@]"
+  | Otyp_attribute (t, attr) ->
+      fprintf ppf "@[<1>(%a [@@%s])@]" print_out_type t attr.oattr_name
+and print_record_decl ppf lbls =
+  fprintf ppf "{%a@;<1 -2>}"
+    (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls
+and print_fields rest ppf =
+  function
+    [] ->
+      begin match rest with
+        Some non_gen -> fprintf ppf "%s.." (if non_gen then "_" else "")
+      | None -> ()
+      end
+  | [s, t] ->
+      fprintf ppf "%s : %a" s print_out_type t;
+      begin match rest with
+        Some _ -> fprintf ppf ";@ "
+      | None -> ()
+      end;
+      print_fields rest ppf []
+  | (s, t) :: l ->
+      fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l
+and print_row_field ppf (l, opt_amp, tyl) =
+  let pr_of ppf =
+    if opt_amp then fprintf ppf " of@ &@ "
+    else if tyl <> [] then fprintf ppf " of@ "
+    else fprintf ppf ""
+  in
+  fprintf ppf "@[<hv 2>`%s%t%a@]" l pr_of (print_typlist print_out_type " &")
+    tyl
+and print_typlist print_elem sep ppf =
+  function
+    [] -> ()
+  | [ty] -> print_elem ppf ty
+  | ty :: tyl ->
+      print_elem ppf ty;
+      pp_print_string ppf sep;
+      pp_print_space ppf ();
+      print_typlist print_elem sep ppf tyl
+and print_typargs ppf =
+  function
+    [] -> ()
+  | [ty1] -> print_simple_out_type ppf ty1; pp_print_space ppf ()
+  | tyl ->
+      pp_open_box ppf 1;
+      pp_print_char ppf '(';
+      print_typlist print_out_type "," ppf tyl;
+      pp_print_char ppf ')';
+      pp_close_box ppf ();
+      pp_print_space ppf ()
+and print_out_label ppf (name, mut, arg) =
+  fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name
+    print_out_type arg
+
+let out_label = ref print_out_label
+
+let out_type = ref print_out_type
+
+(* Class types *)
+
+let print_type_parameter ppf s =
+  if s = "_" then fprintf ppf "_" else pr_var ppf s
+
+let type_parameter ppf (ty, (var, inj)) =
+  let open Asttypes in
+  fprintf ppf "%s%s%a"
+    (match var with Covariant -> "+" | Contravariant -> "-" | NoVariance ->  "")
+    (match inj with Injective -> "!" | NoInjectivity -> "")
+    print_type_parameter ty
+
+let print_out_class_params ppf =
+  function
+    [] -> ()
+  | tyl ->
+      fprintf ppf "@[<1>[%a]@]@ "
+        (print_list type_parameter (fun ppf -> fprintf ppf ", "))
+        tyl
+
+let rec print_out_class_type ppf =
+  function
+    Octy_constr (id, tyl) ->
+      let pr_tyl ppf =
+        function
+          [] -> ()
+        | tyl ->
+            fprintf ppf "@[<1>[%a]@]@ " (print_typlist !out_type ",") tyl
+      in
+      fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id
+  | Octy_arrow (lab, ty, cty) ->
+      fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "")
+        print_out_type_2 ty print_out_class_type cty
+  | Octy_signature (self_ty, csil) ->
+      let pr_param ppf =
+        function
+          Some ty -> fprintf ppf "@ @[(%a)@]" !out_type ty
+        | None -> ()
+      in
+      fprintf ppf "@[<hv 2>@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty
+        (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ "))
+        csil
+and print_out_class_sig_item ppf =
+  function
+    Ocsg_constraint (ty1, ty2) ->
+      fprintf ppf "@[<2>constraint %a =@ %a@]" !out_type ty1
+        !out_type ty2
+  | Ocsg_method (name, priv, virt, ty) ->
+      fprintf ppf "@[<2>method %s%s%s :@ %a@]"
+        (if priv then "private " else "") (if virt then "virtual " else "")
+        name !out_type ty
+  | Ocsg_value (name, mut, vr, ty) ->
+      fprintf ppf "@[<2>val %s%s%s :@ %a@]"
+        (if mut then "mutable " else "")
+        (if vr then "virtual " else "")
+        name !out_type ty
+
+let out_class_type = ref print_out_class_type
+
+(* Signature *)
+
+let out_module_type = ref (fun _ -> failwith "Oprint.out_module_type")
+let out_sig_item = ref (fun _ -> failwith "Oprint.out_sig_item")
+let out_signature = ref (fun _ -> failwith "Oprint.out_signature")
+let out_type_extension = ref (fun _ -> failwith "Oprint.out_type_extension")
+let out_functor_parameters =
+  ref (fun _ -> failwith "Oprint.out_functor_parameters")
+
+(* For anonymous functor arguments, the logic to choose between
+   the long-form
+     functor (_ : S) -> ...
+   and the short-form
+     S -> ...
+   is as follows: if we are already printing long-form functor arguments,
+   we use the long form unless all remaining functor arguments can use
+   the short form. (Otherwise use the short form.)
+
+   For example,
+     functor (X : S1) (_ : S2) (Y : S3) (_ : S4) (_ : S5) -> sig end
+   will get printed as
+     functor (X : S1) (_ : S2) (Y : S3) -> S4 -> S5 -> sig end
+
+   but
+     functor (_ : S1) (_ : S2) (Y : S3) (_ : S4) (_ : S5) -> sig end
+   gets printed as
+     S1 -> S2 -> functor (Y : S3) -> S4 -> S5 -> sig end
+*)
+
+(* take a module type that may be a functor type,
+   and return the longest prefix list of arguments
+   that should be printed in long form. *)
+
+let rec collect_functor_args acc = function
+  | Omty_functor (param, mty_res) ->
+      collect_functor_args (param :: acc) mty_res
+  | non_functor -> (acc, non_functor)
+let collect_functor_args mty =
+  let l, rest = collect_functor_args [] mty in
+  List.rev l, rest
+
+let split_anon_functor_arguments params =
+  let rec uncollect_anonymous_suffix acc rest = match acc with
+    | Some (None, mty_arg) :: acc ->
+        uncollect_anonymous_suffix acc
+          (Some (None, mty_arg) :: rest)
+    | _ :: _ | [] ->
+        (acc, rest)
+  in
+  let (acc, rest) = uncollect_anonymous_suffix (List.rev params) [] in
+  (List.rev acc, rest)
+
+let rec print_out_module_type ppf mty =
+  print_out_functor ppf mty
+
+and print_out_functor_parameters ppf l =
+  let print_nonanon_arg ppf = function
+    | None ->
+        fprintf ppf "()"
+    | Some (param, mty) ->
+        fprintf ppf "(%s : %a)"
+          (Option.value param ~default:"_")
+          print_out_module_type mty
+  in
+  let rec print_args ppf = function
+    | [] -> ()
+    | Some (None, mty_arg) :: l ->
+        fprintf ppf "%a ->@ %a"
+          print_simple_out_module_type mty_arg
+          print_args l
+    | _ :: _ as non_anonymous_functor ->
+        let args, anons = split_anon_functor_arguments non_anonymous_functor in
+        fprintf ppf "@[<2>functor@ %a@]@ ->@ %a"
+          (pp_print_list ~pp_sep:pp_print_space print_nonanon_arg) args
+          print_args anons
+  in
+  print_args ppf l
+
+and print_out_functor ppf t =
+  let params, non_functor = collect_functor_args t in
+  fprintf ppf "@[<2>%a%a@]"
+    print_out_functor_parameters params
+    print_simple_out_module_type non_functor
+and print_simple_out_module_type ppf =
+  function
+    Omty_abstract -> ()
+  | Omty_ident id -> fprintf ppf "%a" print_ident id
+  | Omty_signature sg ->
+     begin match sg with
+       | [] -> fprintf ppf "sig end"
+       | sg ->
+          fprintf ppf "@[<hv 2>sig@ %a@;<1 -2>end@]" print_out_signature sg
+     end
+  | Omty_alias id -> fprintf ppf "(module %a)" print_ident id
+  | Omty_functor _ as non_simple ->
+     fprintf ppf "(%a)" print_out_module_type non_simple
+  | Omty_hole -> fprintf ppf "_"
+and print_out_signature ppf =
+  function
+    [] -> ()
+  | [item] -> !out_sig_item ppf item
+  | Osig_typext(ext, Oext_first) :: items ->
+      (* Gather together the extension constructors *)
+      let rec gather_extensions acc items =
+        match items with
+            Osig_typext(ext, Oext_next) :: items ->
+              gather_extensions
+                ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc)
+                items
+          | _ -> (List.rev acc, items)
+      in
+      let exts, items =
+        gather_extensions
+          [(ext.oext_name, ext.oext_args, ext.oext_ret_type)]
+          items
+      in
+      let te =
+        { otyext_name = ext.oext_type_name;
+          otyext_params = ext.oext_type_params;
+          otyext_constructors = exts;
+          otyext_private = ext.oext_private }
+      in
+        fprintf ppf "%a@ %a" !out_type_extension te print_out_signature items
+  | item :: items ->
+      fprintf ppf "%a@ %a" !out_sig_item item print_out_signature items
+and print_out_sig_item ppf =
+  function
+    Osig_class (vir_flag, name, params, clt, rs) ->
+      fprintf ppf "@[<2>%s%s@ %a%s@ :@ %a@]"
+        (if rs = Orec_next then "and" else "class")
+        (if vir_flag then " virtual" else "") print_out_class_params params
+        name !out_class_type clt
+  | Osig_class_type (vir_flag, name, params, clt, rs) ->
+      fprintf ppf "@[<2>%s%s@ %a%s@ =@ %a@]"
+        (if rs = Orec_next then "and" else "class type")
+        (if vir_flag then " virtual" else "") print_out_class_params params
+        name !out_class_type clt
+  | Osig_typext (ext, Oext_exception) ->
+      fprintf ppf "@[<2>exception %a@]"
+        print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type)
+  | Osig_typext (ext, _es) ->
+      print_out_extension_constructor ppf ext
+  | Osig_modtype (name, Omty_abstract) ->
+      fprintf ppf "@[<2>module type %s@]" name
+  | Osig_modtype (name, mty) ->
+      fprintf ppf "@[<2>module type %s =@ %a@]" name !out_module_type mty
+  | Osig_module (name, Omty_alias id, _) ->
+      fprintf ppf "@[<2>module %s =@ %a@]" name print_ident id
+  | Osig_module (name, mty, rs) ->
+      fprintf ppf "@[<2>%s %s :@ %a@]"
+        (match rs with Orec_not -> "module"
+                     | Orec_first -> "module rec"
+                     | Orec_next -> "and")
+        name !out_module_type mty
+  | Osig_type(td, rs) ->
+        print_out_type_decl
+          (match rs with
+           | Orec_not   -> "type nonrec"
+           | Orec_first -> "type"
+           | Orec_next  -> "and")
+          ppf td
+  | Osig_value vd ->
+      let kwd = if vd.oval_prims = [] then "val" else "external" in
+      let pr_prims ppf =
+        function
+          [] -> ()
+        | s :: sl ->
+            fprintf ppf "@ = \"%s\"" s;
+            List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl
+      in
+      fprintf ppf "@[<2>%s %a :@ %a%a%a@]" kwd value_ident vd.oval_name
+        !out_type vd.oval_type pr_prims vd.oval_prims
+        (fun ppf -> List.iter (fun a -> fprintf ppf "@ [@@@@%s]" a.oattr_name))
+        vd.oval_attributes
+  | Osig_ellipsis ->
+      fprintf ppf "..."
+
+and print_out_type_decl kwd ppf td =
+  let print_constraints ppf =
+    List.iter
+      (fun (ty1, ty2) ->
+         fprintf ppf "@ @[<2>constraint %a =@ %a@]" !out_type ty1
+           !out_type ty2)
+      td.otype_cstrs
+  in
+  let type_defined ppf =
+    match td.otype_params with
+      [] -> pp_print_string ppf td.otype_name
+    | [param] -> fprintf ppf "@[%a@ %s@]" type_parameter param td.otype_name
+    | _ ->
+        fprintf ppf "@[(@[%a)@]@ %s@]"
+          (print_list type_parameter (fun ppf -> fprintf ppf ",@ "))
+          td.otype_params
+          td.otype_name
+  in
+  let print_manifest ppf =
+    function
+      Otyp_manifest (ty, _) -> fprintf ppf " =@ %a" !out_type ty
+    | _ -> ()
+  in
+  let print_name_params ppf =
+    fprintf ppf "%s %t%a" kwd type_defined print_manifest td.otype_type
+  in
+  let ty =
+    match td.otype_type with
+      Otyp_manifest (_, ty) -> ty
+    | _ -> td.otype_type
+  in
+  let print_private ppf = function
+    Asttypes.Private -> fprintf ppf " private"
+  | Asttypes.Public -> ()
+  in
+  let print_immediate ppf =
+    match td.otype_immediate with
+    | Unknown -> ()
+    | Always -> fprintf ppf " [%@%@immediate]"
+    | Always_on_64bits -> fprintf ppf " [%@%@immediate64]"
+  in
+  let print_unboxed ppf =
+    if td.otype_unboxed then fprintf ppf " [%@%@unboxed]" else ()
+  in
+  let print_out_tkind ppf = function
+  | Otyp_abstract -> ()
+  | Otyp_record lbls ->
+      fprintf ppf " =%a %a"
+        print_private td.otype_private
+        print_record_decl lbls
+  | Otyp_sum constrs ->
+      let variants fmt constrs =
+        if constrs = [] then fprintf fmt "|" else
+        fprintf fmt "%a" (print_list print_out_constr
+          (fun ppf -> fprintf ppf "@ | ")) constrs in
+      fprintf ppf " =%a@;<1 2>%a"
+        print_private td.otype_private variants constrs
+  | Otyp_open ->
+      fprintf ppf " =%a .."
+        print_private td.otype_private
+  | ty ->
+      fprintf ppf " =%a@;<1 2>%a"
+        print_private td.otype_private
+        !out_type ty
+  in
+  fprintf ppf "@[<2>@[<hv 2>%t%a@]%t%t%t@]"
+    print_name_params
+    print_out_tkind ty
+    print_constraints
+    print_immediate
+    print_unboxed
+
+and print_out_constr ppf (name, tyl,ret_type_opt) =
+  let name =
+    match name with
+    | "::" -> "(::)"   (* #7200 *)
+    | s -> s
+  in
+  match ret_type_opt with
+  | None ->
+      begin match tyl with
+      | [] ->
+          pp_print_string ppf name
+      | _ ->
+          fprintf ppf "@[<2>%s of@ %a@]" name
+            (print_typlist print_simple_out_type " *") tyl
+      end
+  | Some ret_type ->
+      begin match tyl with
+      | [] ->
+          fprintf ppf "@[<2>%s :@ %a@]" name print_simple_out_type  ret_type
+      | _ ->
+          fprintf ppf "@[<2>%s :@ %a -> %a@]" name
+            (print_typlist print_simple_out_type " *")
+            tyl print_simple_out_type ret_type
+      end
+
+and print_out_extension_constructor ppf ext =
+  let print_extended_type ppf =
+      match ext.oext_type_params with
+        [] -> fprintf ppf "%s" ext.oext_type_name
+      | [ty_param] ->
+        fprintf ppf "@[%a@ %s@]"
+          print_type_parameter
+          ty_param
+          ext.oext_type_name
+      | _ ->
+        fprintf ppf "@[(@[%a)@]@ %s@]"
+          (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ "))
+          ext.oext_type_params
+          ext.oext_type_name
+  in
+  fprintf ppf "@[<hv 2>type %t +=%s@;<1 2>%a@]"
+    print_extended_type
+    (if ext.oext_private = Asttypes.Private then " private" else "")
+    print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type)
+
+and print_out_type_extension ppf te =
+  let print_extended_type ppf =
+    match te.otyext_params with
+      [] -> fprintf ppf "%s" te.otyext_name
+    | [param] ->
+      fprintf ppf "@[%a@ %s@]"
+        print_type_parameter param
+        te.otyext_name
+    | _ ->
+        fprintf ppf "@[(@[%a)@]@ %s@]"
+          (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ "))
+          te.otyext_params
+          te.otyext_name
+  in
+  fprintf ppf "@[<hv 2>type %t +=%s@;<1 2>%a@]"
+    print_extended_type
+    (if te.otyext_private = Asttypes.Private then " private" else "")
+    (print_list print_out_constr (fun ppf -> fprintf ppf "@ | "))
+    te.otyext_constructors
+
+let out_constr = ref print_out_constr
+let _ = out_module_type := print_out_module_type
+let _ = out_signature := print_out_signature
+let _ = out_sig_item := print_out_sig_item
+let _ = out_type_extension := print_out_type_extension
+let _ = out_functor_parameters := print_out_functor_parameters
+
+(* Phrases *)
+
+let print_out_exception ppf exn outv =
+  match exn with
+    Sys.Break -> fprintf ppf "Interrupted.@."
+  | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@."
+  | Stack_overflow ->
+      fprintf ppf "Stack overflow during evaluation (looping recursion?).@."
+  | _ -> match Printexc.use_printers exn with
+        | None -> fprintf ppf "@[Exception:@ %a.@]@." !out_value outv
+        | Some s -> fprintf ppf "@[Exception:@ %s@]@." s
+
+let rec print_items ppf =
+  function
+    [] -> ()
+  | (Osig_typext(ext, Oext_first), None) :: items ->
+      (* Gather together extension constructors *)
+      let rec gather_extensions acc items =
+        match items with
+            (Osig_typext(ext, Oext_next), None) :: items ->
+              gather_extensions
+                ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc)
+                items
+          | _ -> (List.rev acc, items)
+      in
+      let exts, items =
+        gather_extensions
+          [(ext.oext_name, ext.oext_args, ext.oext_ret_type)]
+          items
+      in
+      let te =
+        { otyext_name = ext.oext_type_name;
+          otyext_params = ext.oext_type_params;
+          otyext_constructors = exts;
+          otyext_private = ext.oext_private }
+      in
+        fprintf ppf "@[%a@]" !out_type_extension te;
+        if items <> [] then fprintf ppf "@ %a" print_items items
+  | (tree, valopt) :: items ->
+      begin match valopt with
+        Some v ->
+          fprintf ppf "@[<2>%a =@ %a@]" !out_sig_item tree
+            !out_value v
+      | None -> fprintf ppf "@[%a@]" !out_sig_item tree
+      end;
+      if items <> [] then fprintf ppf "@ %a" print_items items
+
+let print_out_phrase ppf =
+  function
+    Ophr_eval (outv, ty) ->
+      fprintf ppf "@[- : %a@ =@ %a@]@." !out_type ty !out_value outv
+  | Ophr_signature [] -> ()
+  | Ophr_signature items -> fprintf ppf "@[<v>%a@]@." print_items items
+  | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv
+
+let out_phrase = ref print_out_phrase
diff --git a/src/ocaml/typing/oprint.mli b/src/ocaml/typing/oprint.mli
new file mode 100644
index 0000000..bafd17c
--- /dev/null
+++ b/src/ocaml/typing/oprint.mli
@@ -0,0 +1,36 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Projet Cristal, INRIA Rocquencourt                   *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Format
+open Outcometree
+
+val out_ident : (formatter -> out_ident -> unit) ref
+val out_value : (formatter -> out_value -> unit) ref
+val out_label : (formatter -> string * bool * out_type -> unit) ref
+val out_type : (formatter -> out_type -> unit) ref
+val out_constr :
+  (formatter -> string * out_type list * out_type option -> unit) ref
+val out_class_type : (formatter -> out_class_type -> unit) ref
+val out_module_type : (formatter -> out_module_type -> unit) ref
+val out_sig_item : (formatter -> out_sig_item -> unit) ref
+val out_signature : (formatter -> out_sig_item list -> unit) ref
+val out_functor_parameters :
+  (formatter ->
+   (string option * Outcometree.out_module_type) option list -> unit)
+    ref
+val out_type_extension : (formatter -> out_type_extension -> unit) ref
+val out_phrase : (formatter -> out_phrase -> unit) ref
+
+val parenthesized_ident : string -> bool
diff --git a/src/ocaml/typing/outcometree.mli b/src/ocaml/typing/outcometree.mli
new file mode 100644
index 0000000..bab215a
--- /dev/null
+++ b/src/ocaml/typing/outcometree.mli
@@ -0,0 +1,151 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*      Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt          *)
+(*                                                                        *)
+(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Module [Outcometree]: results displayed by the toplevel *)
+
+(* These types represent messages that the toplevel displays as normal
+   results or errors. The real displaying is customisable using the hooks:
+      [Toploop.print_out_value]
+      [Toploop.print_out_type]
+      [Toploop.print_out_sig_item]
+      [Toploop.print_out_phrase] *)
+
+(** An [out_name] is a string representation of an identifier which can be
+    rewritten on the fly to avoid name collisions *)
+type out_name = { mutable printed_name: string }
+
+type out_ident =
+  | Oide_apply of out_ident * out_ident
+  | Oide_dot of out_ident * string
+  | Oide_ident of out_name
+
+type out_string =
+  | Ostr_string
+  | Ostr_bytes
+
+type out_attribute =
+  { oattr_name: string }
+
+type out_value =
+  | Oval_array of out_value list
+  | Oval_char of char
+  | Oval_constr of out_ident * out_value list
+  | Oval_ellipsis
+  | Oval_float of float
+  | Oval_int of int
+  | Oval_int32 of int32
+  | Oval_int64 of int64
+  | Oval_nativeint of nativeint
+  | Oval_list of out_value list
+  | Oval_printer of (Format.formatter -> unit)
+  | Oval_record of (out_ident * out_value) list
+  | Oval_string of string * int * out_string (* string, size-to-print, kind *)
+  | Oval_stuff of string
+  | Oval_tuple of out_value list
+  | Oval_variant of string * out_value option
+
+type out_type_param = string * (Asttypes.variance * Asttypes.injectivity)
+
+type out_type =
+  | Otyp_abstract
+  | Otyp_open
+  | Otyp_alias of out_type * string
+  | Otyp_arrow of string * out_type * out_type
+  | Otyp_class of bool * out_ident * out_type list
+  | Otyp_constr of out_ident * out_type list
+  | Otyp_manifest of out_type * out_type
+  | Otyp_object of (string * out_type) list * bool option
+  | Otyp_record of (string * bool * out_type) list
+  | Otyp_stuff of string
+  | Otyp_sum of (string * out_type list * out_type option) list
+  | Otyp_tuple of out_type list
+  | Otyp_var of bool * string
+  | Otyp_variant of
+      bool * out_variant * bool * (string list) option
+  | Otyp_poly of string list * out_type
+  | Otyp_module of out_ident * (string * out_type) list
+  | Otyp_attribute of out_type * out_attribute
+
+and out_variant =
+  | Ovar_fields of (string * bool * out_type list) list
+  | Ovar_typ of out_type
+
+type out_class_type =
+  | Octy_constr of out_ident * out_type list
+  | Octy_arrow of string * out_type * out_class_type
+  | Octy_signature of out_type option * out_class_sig_item list
+and out_class_sig_item =
+  | Ocsg_constraint of out_type * out_type
+  | Ocsg_method of string * bool * bool * out_type
+  | Ocsg_value of string * bool * bool * out_type
+
+type out_module_type =
+  | Omty_abstract
+  | Omty_functor of (string option * out_module_type) option * out_module_type
+  | Omty_ident of out_ident
+  | Omty_signature of out_sig_item list
+  | Omty_alias of out_ident
+  | Omty_hole
+and out_sig_item =
+  | Osig_class of
+      bool * string * out_type_param list * out_class_type *
+        out_rec_status
+  | Osig_class_type of
+      bool * string * out_type_param list * out_class_type *
+        out_rec_status
+  | Osig_typext of out_extension_constructor * out_ext_status
+  | Osig_modtype of string * out_module_type
+  | Osig_module of string * out_module_type * out_rec_status
+  | Osig_type of out_type_decl * out_rec_status
+  | Osig_value of out_val_decl
+  | Osig_ellipsis
+and out_type_decl =
+  { otype_name: string;
+    otype_params: out_type_param list;
+    otype_type: out_type;
+    otype_private: Asttypes.private_flag;
+    otype_immediate: Type_immediacy.t;
+    otype_unboxed: bool;
+    otype_cstrs: (out_type * out_type) list }
+and out_extension_constructor =
+  { oext_name: string;
+    oext_type_name: string;
+    oext_type_params: string list;
+    oext_args: out_type list;
+    oext_ret_type: out_type option;
+    oext_private: Asttypes.private_flag }
+and out_type_extension =
+  { otyext_name: string;
+    otyext_params: string list;
+    otyext_constructors: (string * out_type list * out_type option) list;
+    otyext_private: Asttypes.private_flag }
+and out_val_decl =
+  { oval_name: string;
+    oval_type: out_type;
+    oval_prims: string list;
+    oval_attributes: out_attribute list }
+and out_rec_status =
+  | Orec_not
+  | Orec_first
+  | Orec_next
+and out_ext_status =
+  | Oext_first
+  | Oext_next
+  | Oext_exception
+
+type out_phrase =
+  | Ophr_eval of out_value * out_type
+  | Ophr_signature of (out_sig_item * out_value option) list
+  | Ophr_exception of (exn * out_value)
diff --git a/src/ocaml/typing/parmatch.ml b/src/ocaml/typing/parmatch.ml
new file mode 100644
index 0000000..e647564
--- /dev/null
+++ b/src/ocaml/typing/parmatch.ml
@@ -0,0 +1,2523 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Detection of partial matches and unused match cases. *)
+
+open Misc
+open Asttypes
+open Types
+open Typedtree
+
+
+(*************************************)
+(* Utilities for building patterns   *)
+(*************************************)
+
+let make_pat desc ty tenv =
+  {pat_desc = desc; pat_loc = Location.none; pat_extra = [];
+   pat_type = ty ; pat_env = tenv;
+   pat_attributes = [];
+  }
+
+let omega = Patterns.omega
+let omegas = Patterns.omegas
+let omega_list = Patterns.omega_list
+
+let extra_pat =
+  make_pat
+    (Tpat_var (Ident.create_local "+", mknoloc "+"))
+    Ctype.none Env.empty
+
+
+(*******************)
+(* Coherence check *)
+(*******************)
+
+(* For some of the operations we do in this module, we would like (because it
+   simplifies matters) to assume that patterns appearing on a given column in a
+   pattern matrix are /coherent/ (think "of the same type").
+   Unfortunately that is not always true.
+
+   Consider the following (well-typed) example:
+   {[
+     type _ t = S : string t | U : unit t
+
+     let f (type a) (t1 : a t) (t2 : a t) (a : a) =
+       match t1, t2, a with
+       | U, _, () -> ()
+       | _, S, "" -> ()
+   ]}
+
+   Clearly the 3rd column contains incoherent patterns.
+
+   On the example above, most of the algorithms will explore the pattern matrix
+   as illustrated by the following tree:
+
+   {v
+                                                   S
+                                                -------> | "" |
+                             U     | S, "" | __/         | () |
+                         --------> | _, () |   \ not S
+        | U, _, () | __/                        -------> | () |
+        | _, S, "" |   \
+                        ---------> | S, "" | ----------> | "" |
+                          not U                    S
+   v}
+
+   where following an edge labelled by a pattern P means "assuming the value I
+   am matching on is filtered by [P] on the column I am currently looking at,
+   then the following submatrix is still reachable".
+
+   Notice that at any point of that tree, if the first column of a matrix is
+   incoherent, then the branch leading to it can only be taken if the scrutinee
+   is ill-typed.
+   In the example above the only case where we have a matrix with an incoherent
+   first column is when we consider [t1, t2, a] to be [U, S, ...]. However such
+   a value would be ill-typed, so we can never actually get there.
+
+   Checking the first column at each step of the recursion and making the
+   conscious decision of "aborting" the algorithm whenever the first column
+   becomes incoherent, allows us to retain the initial assumption in later
+   stages of the algorithms.
+
+   ---
+
+   N.B. two patterns can be considered coherent even though they might not be of
+   the same type.
+
+   That's in part because we only care about the "head" of patterns and leave
+   checking coherence of subpatterns for the next steps of the algorithm:
+   ('a', 'b') and (1, ()) will be deemed coherent because they are both a tuples
+   of arity 2 (we'll notice at a later stage the incoherence of 'a' and 1).
+
+   But also because it can be hard/costly to determine exactly whether two
+   patterns are of the same type or not (eg. in the example above with _ and S,
+   but see also the module [Coherence_illustration] in
+   testsuite/tests/basic-more/robustmatch.ml).
+
+   For the moment our weak, loosely-syntactic, coherence check seems to be
+   enough and we leave it to each user to consider (and document!) what happens
+   when an "incoherence" is not detected by this check.
+*)
+
+(* Given the first column of a simplified matrix, this function first looks for
+   a "discriminating" pattern on that column (i.e. a non-omega one) and then
+   check that every other head pattern in the column is coherent with that one.
+*)
+let all_coherent column =
+  let open Patterns.Head in
+  let coherent_heads hp1 hp2 =
+    match hp1.pat_desc, hp2.pat_desc with
+    | Construct c, Construct c' ->
+      c.cstr_consts = c'.cstr_consts
+      && c.cstr_nonconsts = c'.cstr_nonconsts
+    | Constant c1, Constant c2 -> begin
+        match c1, c2 with
+        | Const_char _, Const_char _
+        | Const_int _, Const_int _
+        | Const_int32 _, Const_int32 _
+        | Const_int64 _, Const_int64 _
+        | Const_nativeint _, Const_nativeint _
+        | Const_float _, Const_float _
+        | Const_string _, Const_string _ -> true
+        | ( Const_char _
+          | Const_int _
+          | Const_int32 _
+          | Const_int64 _
+          | Const_nativeint _
+          | Const_float _
+          | Const_string _), _ -> false
+      end
+    | Tuple l1, Tuple l2 -> l1 = l2
+    | Record (lbl1 :: _), Record (lbl2 :: _) ->
+      Array.length lbl1.lbl_all = Array.length lbl2.lbl_all
+    | Any, _
+    | _, Any
+    | Record [], Record []
+    | Variant _, Variant _
+    | Array _, Array _
+    | Lazy, Lazy -> true
+    | _, _ -> false
+  in
+  match
+    List.find
+      (function
+       | { pat_desc = Any } -> false
+       | _ -> true)
+      column
+  with
+  | exception Not_found ->
+    (* only omegas on the column: the column is coherent. *)
+    true
+  | discr_pat ->
+    List.for_all (coherent_heads discr_pat) column
+
+let first_column simplified_matrix =
+  List.map (fun ((head, _args), _rest) -> head) simplified_matrix
+
+(***********************)
+(* Compatibility check *)
+(***********************)
+
+(* Patterns p and q compatible means:
+   there exists value V that matches both, However....
+
+  The case of extension types is dubious, as constructor rebind permits
+  that different constructors are the same (and are thus compatible).
+
+  Compilation must take this into account, consider:
+
+  type t = ..
+  type t += A|B
+  type t += C=A
+
+  let f x y = match x,y with
+  | true,A  -> '1'
+  | _,C     -> '2'
+  | false,A -> '3'
+  | _,_     -> '_'
+
+  As C is bound to A the value of f false A is '2' (and not '3' as it would
+  be in the absence of rebinding).
+
+  Not considering rebinding, patterns "false,A" and "_,C" are incompatible
+  and the compiler can swap the second and third clause, resulting in the
+  (more efficiently compiled) matching
+
+  match x,y with
+  | true,A  -> '1'
+  | false,A -> '3'
+  | _,C     -> '2'
+  | _,_     -> '_'
+
+  This is not correct: when C is bound to A, "f false A" returns '2' (not '3')
+
+
+  However, diagnostics do not take constructor rebinding into account.
+  Notice, that due to module abstraction constructor rebinding is hidden.
+
+  module X : sig type t = .. type t += A|B end = struct
+    type t = ..
+    type t += A
+    type t += B=A
+  end
+
+  open X
+
+  let f x = match x with
+  | A -> '1'
+  | B -> '2'
+  | _ -> '_'
+
+  The second clause above will NOT (and cannot) be flagged as useless.
+
+  Finally, there are two compatibility functions:
+   compat p q      ---> 'syntactic compatibility, used for diagnostics.
+   may_compat p q --->   a safe approximation of possible compat,
+                         for compilation
+
+*)
+
+
+let is_absent tag row = Btype.row_field tag !row = Rabsent
+
+let is_absent_pat d =
+  match d.pat_desc with
+  | Patterns.Head.Variant { tag; cstr_row; _ } -> is_absent tag cstr_row
+  | _ -> false
+
+let const_compare x y =
+  match x,y with
+  | Const_float f1, Const_float f2 ->
+      Stdlib.compare (float_of_string f1) (float_of_string f2)
+  | Const_string (s1, _, _), Const_string (s2, _, _) ->
+      String.compare s1 s2
+  | (Const_int _
+    |Const_char _
+    |Const_string (_, _, _)
+    |Const_float _
+    |Const_int32 _
+    |Const_int64 _
+    |Const_nativeint _
+    ), _ -> Stdlib.compare x y
+
+let records_args l1 l2 =
+  (* Invariant: fields are already sorted by Typecore.type_label_a_list *)
+  let rec combine r1 r2 l1 l2 = match l1,l2 with
+  | [],[] -> List.rev r1, List.rev r2
+  | [],(_,_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2
+  | (_,_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 []
+  | (_,lbl1,p1)::rem1, ( _,lbl2,p2)::rem2 ->
+      if lbl1.lbl_pos < lbl2.lbl_pos then
+        combine (p1::r1) (omega::r2) rem1 l2
+      else if lbl1.lbl_pos > lbl2.lbl_pos then
+        combine (omega::r1) (p2::r2) l1 rem2
+      else (* same label on both sides *)
+        combine (p1::r1) (p2::r2) rem1 rem2 in
+  combine [] [] l1 l2
+
+
+
+module Compat
+    (Constr:sig
+      val equal :
+          Types.constructor_description ->
+            Types.constructor_description ->
+              bool
+    end) = struct
+
+  let rec compat p q = match p.pat_desc,q.pat_desc with
+(* Variables match any value *)
+  | ((Tpat_any|Tpat_var _),_)
+  | (_,(Tpat_any|Tpat_var _)) -> true
+(* Structural induction *)
+  | Tpat_alias (p,_,_),_      -> compat p q
+  | _,Tpat_alias (q,_,_)      -> compat p q
+  | Tpat_or (p1,p2,_),_ ->
+      (compat p1 q || compat p2 q)
+  | _,Tpat_or (q1,q2,_) ->
+      (compat p q1 || compat p q2)
+(* Constructors, with special case for extension *)
+  | Tpat_construct (_, c1, ps1, _), Tpat_construct (_, c2, ps2, _) ->
+      Constr.equal c1 c2 && compats ps1 ps2
+(* More standard stuff *)
+  | Tpat_variant(l1,op1, _), Tpat_variant(l2,op2,_) ->
+      l1=l2 && ocompat op1 op2
+  | Tpat_constant c1, Tpat_constant c2 ->
+      const_compare c1 c2 = 0
+  | Tpat_tuple ps, Tpat_tuple qs -> compats ps qs
+  | Tpat_lazy p, Tpat_lazy q -> compat p q
+  | Tpat_record (l1,_),Tpat_record (l2,_) ->
+      let ps,qs = records_args l1 l2 in
+      compats ps qs
+  | Tpat_array ps, Tpat_array qs ->
+      List.length ps = List.length qs &&
+      compats ps qs
+  | _,_  -> false
+
+  and ocompat op oq = match op,oq with
+  | None,None -> true
+  | Some p,Some q -> compat p q
+  | (None,Some _)|(Some _,None) -> false
+
+  and compats ps qs = match ps,qs with
+  | [], [] -> true
+  | p::ps, q::qs -> compat p q && compats ps qs
+  | _,_    -> false
+
+end
+
+module SyntacticCompat =
+  Compat
+    (struct
+      let equal c1 c2 =  Types.equal_tag c1.cstr_tag c2.cstr_tag
+    end)
+
+let compat =  SyntacticCompat.compat
+and compats = SyntacticCompat.compats
+
+(* Due to (potential) rebinding, two extension constructors
+   of the same arity type may equal *)
+
+exception Empty (* Empty pattern *)
+
+(****************************************)
+(* Utilities for retrieving type paths  *)
+(****************************************)
+
+(* May need a clean copy, cf. PR#4745 *)
+let clean_copy ty =
+  if ty.level = Btype.generic_level then ty
+  else Subst.type_expr Subst.identity ty
+
+let get_constructor_type_path ty tenv =
+  let ty = Ctype.repr (Ctype.expand_head tenv (clean_copy ty)) in
+  match ty.desc with
+  | Tconstr (path,_,_) -> path
+  | _ -> assert false
+
+(****************************)
+(* Utilities for matching   *)
+(****************************)
+
+(* Check top matching *)
+let simple_match d h =
+  let open Patterns.Head in
+  match d.pat_desc, h.pat_desc with
+  | Construct c1, Construct c2 ->
+      Types.equal_tag c1.cstr_tag c2.cstr_tag
+  | Variant { tag = t1; _ }, Variant { tag = t2 } ->
+      t1 = t2
+  | Constant c1, Constant c2 -> const_compare c1 c2 = 0
+  | Lazy, Lazy -> true
+  | Record _, Record _ -> true
+  | Tuple len1, Tuple len2
+  | Array len1, Array len2 -> len1 = len2
+  | _, Any -> true
+  | _, _ -> false
+
+
+
+(* extract record fields as a whole *)
+let record_arg ph =
+  let open Patterns.Head in
+  match ph.pat_desc with
+  | Any -> []
+  | Record args -> args
+  | _ -> fatal_error "Parmatch.as_record"
+
+
+let extract_fields lbls arg =
+  let get_field pos arg =
+    match List.find (fun (lbl,_) -> pos = lbl.lbl_pos) arg with
+    | _, p -> p
+    | exception Not_found -> omega
+  in
+  List.map (fun lbl -> get_field lbl.lbl_pos arg) lbls
+
+(* Build argument list when p2 >= p1, where p1 is a simple pattern *)
+let simple_match_args discr head args =
+  let open Patterns.Head in
+  match head.pat_desc with
+  | Constant _ -> []
+  | Construct _
+  | Variant _
+  | Tuple _
+  | Array _
+  | Lazy -> args
+  | Record lbls ->  extract_fields (record_arg discr) (List.combine lbls args)
+  | Any ->
+      begin match discr.pat_desc with
+      | Construct cstr -> Patterns.omegas cstr.cstr_arity
+      | Variant { has_arg = true }
+      | Lazy -> [Patterns.omega]
+      | Record lbls ->  omega_list lbls
+      | Array len
+      | Tuple len -> Patterns.omegas len
+      | Variant { has_arg = false }
+      | Any
+      | Constant _ -> []
+      end
+
+(* Consider a pattern matrix whose first column has been simplified to contain
+   only _ or a head constructor
+     | p1, r1...
+     | p2, r2...
+     | p3, r3...
+     | ...
+
+   We build a normalized /discriminating/ pattern from a pattern [q] by folding
+   over the first column of the matrix, "refining" [q] as we go:
+
+   - when we encounter a row starting with [Tuple] or [Lazy] then we
+   can stop and return that head, as we cannot refine any further. Indeed,
+   these constructors are alone in their signature, so they will subsume
+   whatever other head we might find, as well as the head we're threading
+   along.
+
+   - when we find a [Record] then it is a bit more involved: it is also alone
+   in its signature, however it might only be matching a subset of the
+   record fields. We use these fields to refine our accumulator and keep going
+   as another row might match on different fields.
+
+   - rows starting with a wildcard do not bring any information, so we ignore
+   them and keep going
+
+   - if we encounter anything else (i.e. any other constructor), then we just
+   stop and return our accumulator.
+*)
+let discr_pat q pss =
+  let open Patterns.Head in
+  let rec refine_pat acc = function
+    | [] -> acc
+    | ((head, _), _) :: rows ->
+      match head.pat_desc with
+      | Any -> refine_pat acc rows
+      | Tuple _ | Lazy -> head
+      | Record lbls ->
+        (* N.B. we could make this case "simpler" by refining the record case
+           using [all_record_args].
+           In which case we wouldn't need to fold over the first column for
+           records.
+           However it makes the witness we generate for the exhaustivity warning
+           less pretty. *)
+        let fields =
+          List.fold_right (fun lbl r ->
+            if List.exists (fun l -> l.lbl_pos = lbl.lbl_pos) r then
+              r
+            else
+              lbl :: r
+          ) lbls (record_arg acc)
+        in
+        let d = { head with pat_desc = Record fields } in
+        refine_pat d rows
+      | _ -> acc
+  in
+  let q, _ = deconstruct q in
+  match q.pat_desc with
+  (* short-circuiting: clearly if we have anything other than [Record] or
+     [Any] to start with, we're not going to be able refine at all. So
+     there's no point going over the matrix. *)
+  | Any | Record _ -> refine_pat q pss
+  | _ -> q
+
+(*
+   In case a matching value is found, set actual arguments
+   of the matching pattern.
+*)
+
+let rec read_args xs r = match xs,r with
+| [],_ -> [],r
+| _::xs, arg::rest ->
+   let args,rest = read_args xs rest in
+   arg::args,rest
+| _,_ ->
+    fatal_error "Parmatch.read_args"
+
+let do_set_args ~erase_mutable q r = match q with
+| {pat_desc = Tpat_tuple omegas} ->
+    let args,rest = read_args omegas r in
+    make_pat (Tpat_tuple args) q.pat_type q.pat_env::rest
+| {pat_desc = Tpat_record (omegas,closed)} ->
+    let args,rest = read_args omegas r in
+    make_pat
+      (Tpat_record
+         (List.map2 (fun (lid, lbl,_) arg ->
+           if
+             erase_mutable &&
+             (match lbl.lbl_mut with
+             | Mutable -> true | Immutable -> false)
+           then
+             lid, lbl, omega
+           else
+             lid, lbl, arg)
+            omegas args, closed))
+      q.pat_type q.pat_env::
+    rest
+| {pat_desc = Tpat_construct (lid, c, omegas, _)} ->
+    let args,rest = read_args omegas r in
+    make_pat
+      (Tpat_construct (lid, c, args, None))
+      q.pat_type q.pat_env::
+    rest
+| {pat_desc = Tpat_variant (l, omega, row)} ->
+    let arg, rest =
+      match omega, r with
+        Some _, a::r -> Some a, r
+      | None, r -> None, r
+      | _ -> assert false
+    in
+    make_pat
+      (Tpat_variant (l, arg, row)) q.pat_type q.pat_env::
+    rest
+| {pat_desc = Tpat_lazy _omega} ->
+    begin match r with
+      arg::rest ->
+        make_pat (Tpat_lazy arg) q.pat_type q.pat_env::rest
+    | _ -> fatal_error "Parmatch.do_set_args (lazy)"
+    end
+| {pat_desc = Tpat_array omegas} ->
+    let args,rest = read_args omegas r in
+    make_pat
+      (Tpat_array args) q.pat_type q.pat_env::
+    rest
+| {pat_desc=Tpat_constant _|Tpat_any} ->
+    q::r (* case any is used in matching.ml *)
+| _ -> fatal_error "Parmatch.set_args"
+
+let set_args q r = do_set_args ~erase_mutable:false q r
+and set_args_erase_mutable q r = do_set_args ~erase_mutable:true q r
+
+(* Given a matrix of non-empty rows
+   p1 :: r1...
+   p2 :: r2...
+   p3 :: r3...
+
+   Simplify the first column [p1 p2 p3] by splitting all or-patterns.
+   The result is a list of pairs
+     ((pattern head, arguments), rest of row)
+
+   For example,
+     x :: r1
+     (Some _) as y :: r2
+     (None as x) as y :: r3
+     (Some x | (None as x)) :: r4
+   becomes
+     ((   _ , [ ] ), r1)
+     (( Some, [_] ), r2)
+     (( None, [ ] ), r3)
+     (( Some, [x] ), r4)
+     (( None, [ ] ), r4)
+ *)
+let simplify_head_pat ~add_column p ps k =
+  let rec simplify_head_pat p ps k =
+    match Patterns.General.(view p |> strip_vars).pat_desc with
+    | `Or (p1,p2,_) -> simplify_head_pat p1 ps (simplify_head_pat p2 ps k)
+    | #Patterns.Simple.view as view ->
+       add_column (Patterns.Head.deconstruct { p with pat_desc = view }) ps k
+  in simplify_head_pat p ps k
+
+let rec simplify_first_col = function
+  | [] -> []
+  | [] :: _ -> assert false (* the rows are non-empty! *)
+  | (p::ps) :: rows ->
+      let add_column p ps k = (p, ps) :: k in
+      simplify_head_pat ~add_column p ps (simplify_first_col rows)
+
+
+(* Builds the specialized matrix of [pss] according to the discriminating
+   pattern head [d].
+   See section 3.1 of http://moscova.inria.fr/~maranget/papers/warn/warn.pdf
+
+   NOTES:
+   - we are polymorphic on the type of matrices we work on, in particular a row
+   might not simply be a [pattern list]. That's why we have the [extend_row]
+   parameter.
+*)
+let build_specialized_submatrix ~extend_row discr pss =
+  let rec filter_rec = function
+    | ((head, args), ps) :: pss ->
+        if simple_match discr head
+        then extend_row (simple_match_args discr head args) ps :: filter_rec pss
+        else filter_rec pss
+    | _ -> [] in
+  filter_rec pss
+
+(* The "default" and "specialized" matrices of a given matrix.
+   See section 3.1 of http://moscova.inria.fr/~maranget/papers/warn/warn.pdf .
+*)
+type 'matrix specialized_matrices = {
+  default : 'matrix;
+  constrs : (Patterns.Head.t * 'matrix) list;
+}
+
+(* Consider a pattern matrix whose first column has been simplified
+   to contain only _ or a head constructor
+     | p1, r1...
+     | p2, r2...
+     | p3, r3...
+     | ...
+
+   We split this matrix into a list of /specialized/ sub-matrices, one for
+   each head constructor appearing in the first column. For each row whose
+   first column starts with a head constructor, remove this head
+   column, prepend one column for each argument of the constructor,
+   and add the resulting row in the sub-matrix corresponding to this
+   head constructor.
+
+   Rows whose left column is omega (the Any pattern _) may match any
+   head constructor, so they are added to all sub-matrices.
+
+   In the case where all the rows in the matrix have an omega on their first
+   column, then there is only one /specialized/ sub-matrix, formed of all these
+   omega rows.
+   This matrix is also called the /default/ matrix.
+
+   See the documentation of [build_specialized_submatrix] for an explanation of
+   the [extend_row] parameter.
+*)
+let build_specialized_submatrices ~extend_row discr rows =
+  let extend_group discr p args r rs =
+    let r = extend_row (simple_match_args discr p args) r in
+    (discr, r :: rs)
+  in
+
+  (* insert a row of head [p] and rest [r] into the right group
+
+     Note: with this implementation, the order of the groups
+     is the order of their first row in the source order.
+     This is a nice property to get exhaustivity counter-examples
+     in source order.
+  *)
+  let rec insert_constr head args r = function
+    | [] ->
+      (* if no group matched this row, it has a head constructor that
+         was never seen before; add a new sub-matrix for this head *)
+      [extend_group head head args r []]
+    | (q0,rs) as bd::env ->
+      if simple_match q0 head
+      then extend_group q0 head args r rs :: env
+      else bd :: insert_constr head args r env
+  in
+
+  (* insert a row of head omega into all groups *)
+  let insert_omega r env =
+    List.map (fun (q0,rs) -> extend_group q0 Patterns.Head.omega [] r rs) env
+  in
+
+  let rec form_groups constr_groups omega_tails = function
+    | [] -> (constr_groups, omega_tails)
+    | ((head, args), tail) :: rest ->
+        match head.pat_desc with
+        | Patterns.Head.Any ->
+            (* note that calling insert_omega here would be wrong
+               as some groups may not have been formed yet, if the
+               first row with this head pattern comes after in the list *)
+            form_groups constr_groups (tail :: omega_tails) rest
+        | _ ->
+            form_groups
+              (insert_constr head args tail constr_groups) omega_tails rest
+  in
+
+  let constr_groups, omega_tails =
+    let initial_constr_group =
+      let open Patterns.Head in
+      match discr.pat_desc with
+      | Record _ | Tuple _ | Lazy ->
+        (* [discr] comes from [discr_pat], and in this case subsumes any of the
+           patterns we could find on the first column of [rows]. So it is better
+           to use it for our initial environment than any of the normalized
+           pattern we might obtain from the first column. *)
+        [discr,[]]
+      | _ -> []
+    in
+    form_groups initial_constr_group [] rows
+  in
+
+  (* groups are accumulated in reverse order;
+     we restore the order of rows in the source code *)
+  let default = List.rev omega_tails in
+  let constrs =
+    List.fold_right insert_omega omega_tails constr_groups
+    |> List.map (fun (discr, rs) -> (discr, List.rev rs))
+  in
+  { default; constrs; }
+
+(* Variant related functions *)
+
+let set_last a =
+  let rec loop = function
+    | [] -> assert false
+    | [_] -> [Patterns.General.erase a]
+    | x::l -> x :: loop l
+  in
+  function
+  | (_, []) -> (Patterns.Head.deconstruct a, [])
+  | (first, row) -> (first, loop row)
+
+(* mark constructor lines for failure when they are incomplete *)
+let mark_partial =
+  let zero = make_pat (`Constant (Const_int 0)) Ctype.none Env.empty in
+  List.map (fun ((hp, _), _ as ps) ->
+    match hp.pat_desc with
+    | Patterns.Head.Any -> ps
+    | _ -> set_last zero ps
+  )
+
+let close_variant env row =
+  let row = Btype.row_repr row in
+  let nm =
+    List.fold_left
+      (fun nm (_tag,f) ->
+        match Btype.row_field_repr f with
+        | Reither(_, _, false, e) ->
+            (* m=false means that this tag is not explicitly matched *)
+            Btype.set_row_field e Rabsent;
+            None
+        | Rabsent | Reither (_, _, true, _) | Rpresent _ -> nm)
+      row.row_name row.row_fields in
+  if not row.row_closed || nm != row.row_name then begin
+    (* this unification cannot fail *)
+    Ctype.unify env row.row_more
+      (Btype.newgenty
+         (Tvariant {row with row_fields = []; row_more = Btype.newgenvar();
+                    row_closed = true; row_name = nm}))
+  end
+
+(*
+  Check whether the first column of env makes up a complete signature or
+  not. We work on the discriminating pattern heads of each sub-matrix: they
+  are not omega/Any.
+*)
+let full_match closing env =  match env with
+| [] -> false
+| (discr, _) :: _ ->
+  let open Patterns.Head in
+  match discr.pat_desc with
+  | Any -> assert false
+  | Construct { cstr_tag = Cstr_extension _ ; _ } -> false
+  | Construct c -> List.length env = c.cstr_consts + c.cstr_nonconsts
+  | Variant { type_row; _ } ->
+      let fields =
+        List.map
+          (fun (d, _) ->
+            match d.pat_desc with
+            | Variant { tag } -> tag
+            | _ -> assert false)
+          env
+      in
+      let row = type_row () in
+      if closing && not (Btype.row_fixed row) then
+        (* closing=true, we are considering the variant as closed *)
+        List.for_all
+          (fun (tag,f) ->
+            match Btype.row_field_repr f with
+              Rabsent | Reither(_, _, false, _) -> true
+            | Reither (_, _, true, _)
+                (* m=true, do not discard matched tags, rather warn *)
+            | Rpresent _ -> List.mem tag fields)
+          row.row_fields
+      else
+        row.row_closed &&
+        List.for_all
+          (fun (tag,f) ->
+            Btype.row_field_repr f = Rabsent || List.mem tag fields)
+          row.row_fields
+  | Constant Const_char _ ->
+      List.length env = 256
+  | Constant _
+  | Array _ -> false
+  | Tuple _
+  | Record _
+  | Lazy -> true
+
+(* Written as a non-fragile matching, PR#7451 originated from a fragile matching
+   below. *)
+let should_extend ext env = match ext with
+| None -> false
+| Some ext -> begin match env with
+  | [] -> assert false
+  | (p,_)::_ ->
+      let open Patterns.Head in
+      begin match p.pat_desc with
+      | Construct {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)} ->
+          let path = get_constructor_type_path p.pat_type p.pat_env in
+          Path.same path ext
+      | Construct {cstr_tag=(Cstr_extension _)} -> false
+      | Constant _ | Tuple _ | Variant _ | Record _ | Array _ | Lazy -> false
+      | Any -> assert false
+      end
+end
+
+(* build a pattern from a constructor description *)
+let pat_of_constr ex_pat cstr =
+  {ex_pat with pat_desc =
+   Tpat_construct (mknoloc (Longident.Lident cstr.cstr_name),
+                   cstr, omegas cstr.cstr_arity, None)}
+
+let orify x y = make_pat (Tpat_or (x, y, None)) x.pat_type x.pat_env
+
+let rec orify_many = function
+| [] -> assert false
+| [x] -> x
+| x :: xs -> orify x (orify_many xs)
+
+(* build an or-pattern from a constructor list *)
+let pat_of_constrs ex_pat cstrs =
+  let ex_pat = Patterns.Head.to_omega_pattern ex_pat in
+  if cstrs = [] then raise Empty else
+  orify_many (List.map (pat_of_constr ex_pat) cstrs)
+
+let pats_of_type ?(always=false) env ty =
+  let ty' = Ctype.expand_head env ty in
+  match ty'.desc with
+  | Tconstr (path, _, _) ->
+      begin match Env.find_type_descrs path env with
+      | exception Not_found -> [omega]
+      | Type_variant (cstrs,_) when always || List.length cstrs <= 1 ||
+        (* Only explode when all constructors are GADTs *)
+        List.for_all (fun cd -> cd.cstr_generalized) cstrs ->
+          List.map (pat_of_constr (make_pat Tpat_any ty env)) cstrs
+      | Type_record (labels, _) ->
+          let fields =
+            List.map (fun ld ->
+              mknoloc (Longident.Lident ld.lbl_name), ld, omega)
+              labels
+          in
+          [make_pat (Tpat_record (fields, Closed)) ty env]
+      | Type_variant _ | Type_abstract | Type_open -> [omega]
+      end
+  | Ttuple tl ->
+      [make_pat (Tpat_tuple (omegas (List.length tl))) ty env]
+  | _ -> [omega]
+
+let rec get_variant_constructors env ty =
+  match (Ctype.repr ty).desc with
+  | Tconstr (path,_,_) -> begin
+      try match Env.find_type path env, Env.find_type_descrs path env with
+      | _, Type_variant (cstrs,_) -> cstrs
+      | {type_manifest = Some _}, _ ->
+          get_variant_constructors env
+            (Ctype.expand_head_once env (clean_copy ty))
+      | _ -> fatal_error "Parmatch.get_variant_constructors"
+      with Not_found ->
+        fatal_error "Parmatch.get_variant_constructors"
+    end
+  | _ -> fatal_error "Parmatch.get_variant_constructors"
+
+module ConstructorSet = Set.Make(struct
+  type t = constructor_description
+  let compare c1 c2 = String.compare c1.cstr_name c2.cstr_name
+end)
+
+(* Sends back a pattern that complements the given constructors used_constrs *)
+let complete_constrs constr used_constrs =
+  let c = constr.pat_desc in
+  let constrs = get_variant_constructors constr.pat_env c.cstr_res in
+  let used_constrs = ConstructorSet.of_list used_constrs in
+  let others =
+    List.filter
+      (fun cnstr -> not (ConstructorSet.mem cnstr used_constrs))
+      constrs in
+  (* Split constructors to put constant ones first *)
+  let const, nonconst =
+    List.partition (fun cnstr -> cnstr.cstr_arity = 0) others in
+  const @ nonconst
+
+let build_other_constrs env p =
+  let open Patterns.Head in
+  match p.pat_desc with
+  | Construct ({ cstr_tag = Cstr_extension _ }) -> extra_pat
+  | Construct
+      ({ cstr_tag = Cstr_constant _ | Cstr_block _ | Cstr_unboxed } as c) ->
+        let constr = { p with pat_desc = c } in
+        let get_constr q =
+          match q.pat_desc with
+          | Construct c -> c
+          | _ -> fatal_error "Parmatch.get_constr" in
+        let used_constrs =  List.map (fun (p,_) -> get_constr p) env in
+        pat_of_constrs p (complete_constrs constr used_constrs)
+  | _ -> extra_pat
+
+(* Auxiliary for build_other *)
+
+let build_other_constant proj make first next p env =
+  let all = List.map (fun (p, _) -> proj p.pat_desc) env in
+  let rec try_const i =
+    if List.mem i all
+    then try_const (next i)
+    else make_pat (make i) p.pat_type p.pat_env
+  in try_const first
+
+(*
+  Builds a pattern that is incompatible with all patterns in
+  the first column of env
+*)
+
+let some_private_tag = "<some private tag>"
+
+let build_other ext env =
+  match env with
+  | [] -> omega
+  | (d, _) :: _ ->
+      let open Patterns.Head in
+      match d.pat_desc with
+      | Construct { cstr_tag = Cstr_extension _ } ->
+          (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *)
+          make_pat
+            (Tpat_var (Ident.create_local "*extension*",
+                       {txt="*extension*"; loc = d.pat_loc}))
+            Ctype.none Env.empty
+      | Construct _ ->
+          begin match ext with
+          | Some ext ->
+              if Path.same ext (get_constructor_type_path d.pat_type d.pat_env)
+              then
+                extra_pat
+              else
+                build_other_constrs env d
+          | _ ->
+              build_other_constrs env d
+          end
+      | Variant { cstr_row; type_row } ->
+          let tags =
+            List.map
+              (fun (d, _) ->
+                match d.pat_desc with
+                | Variant { tag } -> tag
+                | _ -> assert false)
+              env
+            in
+            let make_other_pat tag const =
+              let arg = if const then None else Some Patterns.omega in
+              make_pat (Tpat_variant(tag, arg, cstr_row)) d.pat_type d.pat_env
+            in
+            let row = type_row () in
+            begin match
+              List.fold_left
+                (fun others (tag,f) ->
+                  if List.mem tag tags then others else
+                  match Btype.row_field_repr f with
+                    Rabsent (* | Reither _ *) -> others
+                  (* This one is called after erasing pattern info *)
+                  | Reither (c, _, _, _) -> make_other_pat tag c :: others
+                  | Rpresent arg -> make_other_pat tag (arg = None) :: others)
+                [] row.row_fields
+            with
+              [] ->
+                let tag =
+                  if Btype.row_fixed row then some_private_tag else
+                  let rec mktag tag =
+                    if List.mem tag tags then mktag (tag ^ "'") else tag in
+                  mktag "AnyOtherTag"
+                in make_other_pat tag true
+            | pat::other_pats ->
+                List.fold_left
+                  (fun p_res pat ->
+                    make_pat (Tpat_or (pat, p_res, None)) d.pat_type d.pat_env)
+                  pat other_pats
+            end
+      | Constant Const_char _ ->
+          let all_chars =
+            List.map
+              (fun (p,_) -> match p.pat_desc with
+              | Constant (Const_char c) -> c
+              | _ -> assert false)
+              env
+          in
+          let rec find_other i imax =
+            if i > imax then raise Not_found
+            else
+              let ci = Char.chr i in
+              if List.mem ci all_chars then
+                find_other (i+1) imax
+              else
+                make_pat (Tpat_constant (Const_char ci)) d.pat_type d.pat_env
+          in
+          let rec try_chars = function
+            | [] -> Patterns.omega
+            | (c1,c2) :: rest ->
+                try
+                  find_other (Char.code c1) (Char.code c2)
+                with
+                | Not_found -> try_chars rest
+          in
+          try_chars
+            [ 'a', 'z' ; 'A', 'Z' ; '0', '9' ;
+              ' ', '~' ; Char.chr 0 , Char.chr 255]
+      | Constant Const_int _ ->
+          build_other_constant
+            (function Constant(Const_int i) -> i | _ -> assert false)
+            (function i -> Tpat_constant(Const_int i))
+            0 succ d env
+      | Constant Const_int32 _ ->
+          build_other_constant
+            (function Constant(Const_int32 i) -> i | _ -> assert false)
+            (function i -> Tpat_constant(Const_int32 i))
+            0l Int32.succ d env
+      | Constant Const_int64 _ ->
+          build_other_constant
+            (function Constant(Const_int64 i) -> i | _ -> assert false)
+            (function i -> Tpat_constant(Const_int64 i))
+            0L Int64.succ d env
+      | Constant Const_nativeint _ ->
+          build_other_constant
+            (function Constant(Const_nativeint i) -> i | _ -> assert false)
+            (function i -> Tpat_constant(Const_nativeint i))
+            0n Nativeint.succ d env
+      | Constant Const_string _ ->
+          build_other_constant
+            (function Constant(Const_string (s, _, _)) -> String.length s
+                    | _ -> assert false)
+            (function i ->
+               Tpat_constant
+                 (Const_string(String.make i '*',Location.none,None)))
+            0 succ d env
+      | Constant Const_float _ ->
+          build_other_constant
+            (function Constant(Const_float f) -> float_of_string f
+                    | _ -> assert false)
+            (function f -> Tpat_constant(Const_float (string_of_float f)))
+            0.0 (fun f -> f +. 1.0) d env
+      | Array _ ->
+          let all_lengths =
+            List.map
+              (fun (p,_) -> match p.pat_desc with
+              | Array len -> len
+              | _ -> assert false)
+              env in
+          let rec try_arrays l =
+            if List.mem l all_lengths then try_arrays (l+1)
+            else
+              make_pat (Tpat_array (omegas l)) d.pat_type d.pat_env in
+          try_arrays 0
+      | _ -> Patterns.omega
+
+let rec has_instance p = match p.pat_desc with
+  | Tpat_variant (l,_,r) when is_absent l r -> false
+  | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true
+  | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) -> has_instance p
+  | Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2
+  | Tpat_construct (_,_,ps,_) | Tpat_tuple ps | Tpat_array ps ->
+      has_instances ps
+  | Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,x) -> x) lps)
+  | Tpat_lazy p
+    -> has_instance p
+
+and has_instances = function
+  | [] -> true
+  | q::rem -> has_instance q && has_instances rem
+
+(*
+  Core function :
+  Is the last row of pattern matrix pss + qs satisfiable ?
+  That is :
+    Does there exists at least one value vector, es such that :
+     1- for all ps in pss ps # es (ps and es are not compatible)
+     2- qs <= es                  (es matches qs)
+
+   ---
+
+   In two places in the following function, we check the coherence of the first
+   column of (pss + qs).
+   If it is incoherent, then we exit early saying that (pss + qs) is not
+   satisfiable (which is equivalent to saying "oh, we shouldn't have considered
+   that branch, no good result came come from here").
+
+   But what happens if we have a coherent but ill-typed column?
+   - we might end up returning [false], which is equivalent to noticing the
+   incompatibility: clearly this is fine.
+   - if we end up returning [true] then we're saying that [qs] is useful while
+   it is not. This is sad but not the end of the world, we're just allowing dead
+   code to survive.
+*)
+let rec satisfiable pss qs = match pss with
+| [] -> has_instances qs
+| _  ->
+    match qs with
+    | [] -> false
+    | q::qs ->
+       match Patterns.General.(view q |> strip_vars).pat_desc with
+       | `Or(q1,q2,_) ->
+          satisfiable pss (q1::qs) || satisfiable pss (q2::qs)
+       | `Any ->
+          let pss = simplify_first_col pss in
+          if not (all_coherent (first_column pss)) then
+            false
+          else begin
+            let { default; constrs } =
+              let q0 = discr_pat Patterns.Simple.omega pss in
+              build_specialized_submatrices ~extend_row:(@) q0 pss in
+            if not (full_match false constrs) then
+              satisfiable default qs
+            else
+              List.exists
+                (fun (p,pss) ->
+                   not (is_absent_pat p) &&
+                   satisfiable pss
+                     (simple_match_args p Patterns.Head.omega [] @ qs))
+                constrs
+          end
+       | `Variant (l,_,r) when is_absent l r -> false
+       | #Patterns.Simple.view as view ->
+          let q = { q with pat_desc = view } in
+          let pss = simplify_first_col pss in
+          let hq, qargs = Patterns.Head.deconstruct q in
+          if not (all_coherent (hq :: first_column pss)) then
+            false
+          else begin
+              let q0 = discr_pat q pss in
+              satisfiable (build_specialized_submatrix ~extend_row:(@) q0 pss)
+                (simple_match_args q0 hq qargs @ qs)
+            end
+
+(* While [satisfiable] only checks whether the last row of [pss + qs] is
+   satisfiable, this function returns the (possibly empty) list of vectors [es]
+   which verify:
+     1- for all ps in pss, ps # es (ps and es are not compatible)
+     2- qs <= es                   (es matches qs)
+
+   This is done to enable GADT handling
+
+   For considerations regarding the coherence check, see the comment on
+   [satisfiable] above.  *)
+let rec list_satisfying_vectors pss qs =
+  match pss with
+  | [] -> if has_instances qs then [qs] else []
+  | _  ->
+      match qs with
+      | [] -> []
+      | q :: qs ->
+         match Patterns.General.(view q |> strip_vars).pat_desc with
+         | `Or(q1,q2,_) ->
+            list_satisfying_vectors pss (q1::qs) @
+            list_satisfying_vectors pss (q2::qs)
+         | `Any ->
+            let pss = simplify_first_col pss in
+            if not (all_coherent (first_column pss)) then
+              []
+            else begin
+              let q0 = discr_pat Patterns.Simple.omega pss in
+              let wild default_matrix p =
+                List.map (fun qs -> p::qs)
+                  (list_satisfying_vectors default_matrix qs)
+              in
+              match build_specialized_submatrices ~extend_row:(@) q0 pss with
+              | { default; constrs = [] } ->
+                  (* first column of pss is made of variables only *)
+                  wild default omega
+              | { default; constrs = ((p,_)::_ as constrs) } ->
+                  let for_constrs () =
+                    List.flatten (
+                      List.map (fun (p,pss) ->
+                        if is_absent_pat p then
+                          []
+                        else
+                          let witnesses =
+                            list_satisfying_vectors pss
+                              (simple_match_args p Patterns.Head.omega [] @ qs)
+                          in
+                          let p = Patterns.Head.to_omega_pattern p in
+                          List.map (set_args p) witnesses
+                      ) constrs
+                    )
+                  in
+                  if full_match false constrs then for_constrs () else
+                  begin match p.pat_desc with
+                  | Construct _ ->
+                      (* activate this code
+                         for checking non-gadt constructors *)
+                      wild default (build_other_constrs constrs p)
+                      @ for_constrs ()
+                  | _ ->
+                      wild default Patterns.omega
+                  end
+          end
+      | `Variant (l, _, r) when is_absent l r -> []
+      | #Patterns.Simple.view as view ->
+          let q = { q with pat_desc = view } in
+          let hq, qargs = Patterns.Head.deconstruct q in
+          let pss = simplify_first_col pss in
+          if not (all_coherent (hq :: first_column pss)) then
+            []
+          else begin
+            let q0 = discr_pat q pss in
+            List.map (set_args (Patterns.Head.to_omega_pattern q0))
+              (list_satisfying_vectors
+                 (build_specialized_submatrix ~extend_row:(@) q0 pss)
+                 (simple_match_args q0 hq qargs @ qs))
+          end
+
+(******************************************)
+(* Look for a row that matches some value *)
+(******************************************)
+
+(*
+  Useful for seeing if the example of
+  non-matched value can indeed be matched
+  (by a guarded clause)
+*)
+
+let rec do_match pss qs = match qs with
+| [] ->
+    begin match pss  with
+    | []::_ -> true
+    | _ -> false
+    end
+| q::qs -> match Patterns.General.(view q |> strip_vars).pat_desc with
+  | `Or (q1,q2,_) ->
+      do_match pss (q1::qs) || do_match pss (q2::qs)
+  | `Any ->
+      let rec remove_first_column = function
+        | (_::ps)::rem -> ps::remove_first_column rem
+        | _ -> []
+      in
+      do_match (remove_first_column pss) qs
+  | #Patterns.Simple.view as view ->
+      let q = { q with pat_desc = view } in
+      let q0, qargs = Patterns.Head.deconstruct q in
+      let pss = simplify_first_col pss in
+      (* [pss] will (or won't) match [q0 :: qs] regardless of the coherence of
+         its first column. *)
+      do_match
+        (build_specialized_submatrix ~extend_row:(@) q0 pss)
+        (qargs @ qs)
+
+(*
+let print_pat pat =
+  let rec string_of_pat pat =
+    match pat.pat_desc with
+        Tpat_var _ -> "v"
+      | Tpat_any -> "_"
+      | Tpat_alias (p, x) -> Printf.sprintf "(%s) as ?"  (string_of_pat p)
+      | Tpat_constant n -> "0"
+      | Tpat_construct (_, lid, _) ->
+        Printf.sprintf "%s" (String.concat "." (Longident.flatten lid.txt))
+      | Tpat_lazy p ->
+        Printf.sprintf "(lazy %s)" (string_of_pat p)
+      | Tpat_or (p1,p2,_) ->
+        Printf.sprintf "(%s | %s)" (string_of_pat p1) (string_of_pat p2)
+      | Tpat_tuple list ->
+        Printf.sprintf "(%s)" (String.concat "," (List.map string_of_pat list))
+      | Tpat_variant (_, _, _) -> "variant"
+      | Tpat_record (_, _) -> "record"
+      | Tpat_array _ -> "array"
+  in
+  Printf.fprintf stderr "PAT[%s]\n%!" (string_of_pat pat)
+*)
+
+(*
+  Now another satisfiable function that additionally
+  supplies an example of a matching value.
+
+  This function should be called for exhaustiveness check only.
+*)
+let rec exhaust (ext:Path.t option) pss n = match pss with
+| []    ->  Seq.return (omegas n)
+| []::_ ->  Seq.empty
+| [(p :: ps)] -> exhaust_single_row ext p ps n
+| pss   -> specialize_and_exhaust ext pss n
+
+and exhaust_single_row ext p ps n =
+  (* Shortcut: in the single-row case p :: ps we know that all
+     counter-examples are either of the form
+       counter-example(p) :: omegas
+     or
+       p :: counter-examples(ps)
+
+     This is very interesting in the case where p contains
+     or-patterns, as the non-shortcut path below would do a separate
+     search for each constructor of the or-pattern, which can lead to
+     an exponential blowup on examples such as
+
+       | (A|B), (A|B), (A|B), (A|B) -> foo
+
+     Note that this shortcut also applies to examples such as
+
+       | A, A, A, A -> foo | (A|B), (A|B), (A|B), (A|B) -> bar
+
+     thanks to the [get_mins] preprocessing step which will drop the
+     first row (subsumed by the second). Code with this shape does
+     occur naturally when people want to avoid fragile pattern
+     matches: if A and B are the only two constructors, this is the
+     best way to make a non-fragile distinction between "all As" and
+     "at least one B".
+  *)
+  List.to_seq [Some p; None] |> Seq.flat_map
+    (function
+      | Some p ->
+          let sub_witnesses = exhaust ext [ps] (n - 1) in
+          Seq.map (fun row -> p :: row) sub_witnesses
+      | None ->
+          (* note: calling [exhaust] recursively of p would
+             result in an infinite loop in the case n=1 *)
+          let p_witnesses = specialize_and_exhaust ext [[p]] 1 in
+          Seq.map (fun p_row -> p_row @ omegas (n - 1)) p_witnesses
+    )
+
+and specialize_and_exhaust ext pss n =
+  let pss = simplify_first_col pss in
+  if not (all_coherent (first_column pss)) then
+    (* We're considering an ill-typed branch, we won't actually be able to
+       produce a well typed value taking that branch. *)
+    Seq.empty
+  else begin
+    (* Assuming the first column is ill-typed but considered coherent, we
+       might end up producing an ill-typed witness of non-exhaustivity
+       corresponding to the current branch.
+
+       If [exhaust] has been called by [do_check_partial], then the witnesses
+       produced get typechecked and the ill-typed ones are discarded.
+
+       If [exhaust] has been called by [do_check_fragile], then it is possible
+       we might fail to warn the user that the matching is fragile. See for
+       example testsuite/tests/warnings/w04_failure.ml. *)
+    let q0 = discr_pat Patterns.Simple.omega pss in
+    match build_specialized_submatrices ~extend_row:(@) q0 pss with
+    | { default; constrs = [] } ->
+        (* first column of pss is made of variables only *)
+        let sub_witnesses = exhaust ext default (n-1) in
+        let q0 = Patterns.Head.to_omega_pattern q0 in
+        Seq.map (fun row -> q0::row) sub_witnesses
+    | { default; constrs } ->
+        let try_non_omega (p,pss) =
+          if is_absent_pat p then
+            Seq.empty
+          else
+            let sub_witnesses =
+              exhaust
+                ext pss
+                (List.length (simple_match_args p Patterns.Head.omega [])
+                 + n - 1)
+            in
+            let p = Patterns.Head.to_omega_pattern p in
+            Seq.map (set_args p) sub_witnesses
+        in
+        let try_omega () =
+          if full_match false constrs && not (should_extend ext constrs) then
+            Seq.empty
+          else
+            let sub_witnesses = exhaust ext default (n-1) in
+            match build_other ext constrs with
+            | exception Empty ->
+                (* cannot occur, since constructors don't make
+                   a full signature *)
+                fatal_error "Parmatch.exhaust"
+            | p ->
+                Seq.map (fun tail -> p :: tail) sub_witnesses
+        in
+        (* Lazily compute witnesses for all constructor submatrices
+           (Some constr_mat) then the wildcard/default submatrix (None).
+           Note that the call to [try_omega ()] is delayed to after
+           all constructor matrices have been traversed. *)
+        List.map (fun constr_mat -> Some constr_mat) constrs @ [None]
+        |> List.to_seq
+        |> Seq.flat_map
+          (function
+            | Some constr_mat -> try_non_omega constr_mat
+            | None -> try_omega ())
+  end
+
+let exhaust ext pss n =
+  exhaust ext pss n
+  |> Seq.map (function
+     | [x] -> x
+     | _ -> assert false)
+
+(*
+   Another exhaustiveness check, enforcing variant typing.
+   Note that it does not check exact exhaustiveness, but whether a
+   matching could be made exhaustive by closing all variant types.
+   When this is true of all other columns, the current column is left
+   open (even if it means that the whole matching is not exhaustive as
+   a result).
+   When this is false for the matrix minus the current column, and the
+   current column is composed of variant tags, we close the variant
+   (even if it doesn't help in making the matching exhaustive).
+*)
+
+let rec pressure_variants tdefs = function
+  | []    -> false
+  | []::_ -> true
+  | pss   ->
+      let pss = simplify_first_col pss in
+      if not (all_coherent (first_column pss)) then
+        true
+      else begin
+        let q0 = discr_pat Patterns.Simple.omega pss in
+        match build_specialized_submatrices ~extend_row:(@) q0 pss with
+        | { default; constrs = [] } -> pressure_variants tdefs default
+        | { default; constrs } ->
+            let rec try_non_omega = function
+              | (_p,pss) :: rem ->
+                  let ok = pressure_variants tdefs pss in
+                  (* The order below matters : we want [pressure_variants] to be
+                    called on all the specialized submatrices because we might
+                    close some variant in any of them regardless of whether [ok]
+                    is true for [pss] or not *)
+                  try_non_omega rem && ok
+              | [] -> true
+            in
+            if full_match (tdefs=None) constrs then
+              try_non_omega constrs
+            else if tdefs = None then
+              pressure_variants None default
+            else
+              let full = full_match true constrs in
+              let ok =
+                if full then
+                  try_non_omega constrs
+                else begin
+                  let { constrs = partial_constrs; _ } =
+                    build_specialized_submatrices ~extend_row:(@) q0
+                      (mark_partial pss)
+                  in
+                  try_non_omega partial_constrs
+                end
+              in
+              begin match constrs, tdefs with
+              | [], _
+              | _, None -> ()
+              | (d, _) :: _, Some env ->
+                match d.pat_desc with
+                | Variant { type_row; _ } ->
+                  let row = type_row () in
+                  if Btype.row_fixed row
+                  || pressure_variants None default then ()
+                  else close_variant env row
+                | _ -> ()
+              end;
+              ok
+      end
+
+
+(* Yet another satisfiable function *)
+
+(*
+   This time every_satisfiable pss qs checks the
+   utility of every expansion of qs.
+   Expansion means expansion of or-patterns inside qs
+*)
+
+type answer =
+  | Used                                (* Useful pattern *)
+  | Unused                              (* Useless pattern *)
+  | Upartial of Typedtree.pattern list  (* Mixed, with list of useless ones *)
+
+
+
+(* this row type enable column processing inside the matrix
+    - left  ->  elements not to be processed,
+    - right ->  elements to be processed
+*)
+type usefulness_row =
+  {no_ors : pattern list ; ors : pattern list ; active : pattern list}
+
+(*
+let pretty_row {ors=ors ; no_ors=no_ors; active=active} =
+  pretty_line ors ; prerr_string " *" ;
+  pretty_line no_ors ; prerr_string " *" ;
+  pretty_line active
+
+let pretty_rows rs =
+  prerr_endline "begin matrix" ;
+  List.iter
+    (fun r ->
+      pretty_row r ;
+      prerr_endline "")
+    rs ;
+  prerr_endline "end matrix"
+*)
+
+(* Initial build *)
+let make_row ps = {ors=[] ; no_ors=[]; active=ps}
+
+let make_rows pss = List.map make_row pss
+
+
+(* Useful to detect and expand or pats inside as pats *)
+let is_var p = match Patterns.General.(view p |> strip_vars).pat_desc with
+| `Any -> true
+| _    -> false
+
+let is_var_column rs =
+  List.for_all
+    (fun r -> match r.active with
+    | p::_ -> is_var p
+    | []   -> assert false)
+    rs
+
+(* Standard or-args for left-to-right matching *)
+let rec or_args p = match p.pat_desc with
+| Tpat_or (p1,p2,_) -> p1,p2
+| Tpat_alias (p,_,_)  -> or_args p
+| _                 -> assert false
+
+(* Just remove current column *)
+let remove r = match r.active with
+| _::rem -> {r with active=rem}
+| []     -> assert false
+
+let remove_column rs = List.map remove rs
+
+(* Current column has been processed *)
+let push_no_or r = match r.active with
+| p::rem -> { r with no_ors = p::r.no_ors ; active=rem}
+| [] -> assert false
+
+let push_or r = match r.active with
+| p::rem -> { r with ors = p::r.ors ; active=rem}
+| [] -> assert false
+
+let push_or_column rs = List.map push_or rs
+and push_no_or_column rs = List.map push_no_or rs
+
+let rec simplify_first_usefulness_col = function
+  | [] -> []
+  | row :: rows ->
+    match row.active with
+    | [] -> assert false (* the rows are non-empty! *)
+    | p :: ps ->
+      let add_column p ps k =
+        (p, { row with active = ps }) :: k in
+      simplify_head_pat ~add_column p ps
+        (simplify_first_usefulness_col rows)
+
+(* Back to normal matrices *)
+let make_vector r = List.rev r.no_ors
+
+let make_matrix rs = List.map make_vector rs
+
+
+(* Standard union on answers *)
+let union_res r1 r2 = match r1, r2 with
+| (Unused,_)
+| (_, Unused) -> Unused
+| Used,_    -> r2
+| _, Used   -> r1
+| Upartial u1, Upartial u2 -> Upartial (u1@u2)
+
+(* propose or pats for expansion *)
+let extract_elements qs =
+  let rec do_rec seen = function
+    | [] -> []
+    | q::rem ->
+        {no_ors= List.rev_append seen rem @ qs.no_ors ;
+        ors=[] ;
+        active = [q]}::
+        do_rec (q::seen) rem in
+  do_rec [] qs.ors
+
+(* idem for matrices *)
+let transpose rs = match rs with
+| [] -> assert false
+| r::rem ->
+    let i = List.map (fun x -> [x]) r in
+    List.fold_left
+      (List.map2 (fun r x -> x::r))
+      i rem
+
+let extract_columns pss qs = match pss with
+| [] -> List.map (fun _ -> []) qs.ors
+| _  ->
+  let rows = List.map extract_elements pss in
+  transpose rows
+
+(* Core function
+   The idea is to first look for or patterns (recursive case), then
+   check or-patterns argument usefulness (terminal case)
+*)
+
+let rec every_satisfiables pss qs = match qs.active with
+| []     ->
+    (* qs is now partitionned,  check usefulness *)
+    begin match qs.ors with
+    | [] -> (* no or-patterns *)
+        if satisfiable (make_matrix pss) (make_vector qs) then
+          Used
+        else
+          Unused
+    | _  -> (* n or-patterns -> 2n expansions *)
+        List.fold_right2
+          (fun pss qs r -> match r with
+          | Unused -> Unused
+          | _ ->
+              match qs.active with
+              | [q] ->
+                  let q1,q2 = or_args q in
+                  let r_loc = every_both pss qs q1 q2 in
+                  union_res r r_loc
+              | _   -> assert false)
+          (extract_columns pss qs) (extract_elements qs)
+          Used
+    end
+| q::rem ->
+    begin match Patterns.General.(view q |> strip_vars).pat_desc with
+    | `Any ->
+        if is_var_column pss then
+          (* forget about ``all-variable''  columns now *)
+          every_satisfiables (remove_column pss) (remove qs)
+        else
+          (* otherwise this is direct food for satisfiable *)
+          every_satisfiables (push_no_or_column pss) (push_no_or qs)
+    | `Or (q1,q2,_) ->
+        if
+          q1.pat_loc.Location.loc_ghost &&
+          q2.pat_loc.Location.loc_ghost
+        then
+          (* syntactically generated or-pats should not be expanded *)
+          every_satisfiables (push_no_or_column pss) (push_no_or qs)
+        else
+          (* this is a real or-pattern *)
+          every_satisfiables (push_or_column pss) (push_or qs)
+    | `Variant (l,_,r) when is_absent l r -> (* Ah Jacques... *)
+        Unused
+    | #Patterns.Simple.view as view ->
+        let q = { q with pat_desc = view } in
+        (* standard case, filter matrix *)
+        let pss = simplify_first_usefulness_col pss in
+        let hq, args = Patterns.Head.deconstruct q in
+        (* The handling of incoherent matrices is kept in line with
+           [satisfiable] *)
+        if not (all_coherent (hq :: first_column pss)) then
+          Unused
+        else begin
+          let q0 = discr_pat q pss in
+          every_satisfiables
+            (build_specialized_submatrix q0 pss
+              ~extend_row:(fun ps r -> { r with active = ps @ r.active }))
+            {qs with active=simple_match_args q0 hq args @ rem}
+        end
+    end
+
+(*
+  This function ``every_both'' performs the usefulness check
+  of or-pat q1|q2.
+  The trick is to call every_satisfied twice with
+  current active columns restricted to q1 and q2,
+  That way,
+  - others orpats in qs.ors will not get expanded.
+  - all matching work performed on qs.no_ors is not performed again.
+  *)
+and every_both pss qs q1 q2 =
+  let qs1 = {qs with active=[q1]}
+  and qs2 =  {qs with active=[q2]} in
+  let r1 = every_satisfiables pss qs1
+  and r2 =  every_satisfiables (if compat q1 q2 then qs1::pss else pss) qs2 in
+  match r1 with
+  | Unused ->
+      begin match r2 with
+      | Unused -> Unused
+      | Used   -> Upartial [q1]
+      | Upartial u2 -> Upartial (q1::u2)
+      end
+  | Used ->
+      begin match r2 with
+      | Unused -> Upartial [q2]
+      | _      -> r2
+      end
+  | Upartial u1 ->
+      begin match r2 with
+      | Unused -> Upartial (u1@[q2])
+      | Used   -> r1
+      | Upartial u2 -> Upartial (u1 @ u2)
+      end
+
+
+
+
+(* le_pat p q  means, forall V,  V matches q implies V matches p *)
+let rec le_pat p q =
+  match (p.pat_desc, q.pat_desc) with
+  | (Tpat_var _|Tpat_any),_ -> true
+  | Tpat_alias(p,_,_), _ -> le_pat p q
+  | _, Tpat_alias(q,_,_) -> le_pat p q
+  | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0
+  | Tpat_construct(_,c1,ps,_), Tpat_construct(_,c2,qs,_) ->
+      Types.equal_tag c1.cstr_tag c2.cstr_tag && le_pats ps qs
+  | Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) ->
+      (l1 = l2 && le_pat p1 p2)
+  | Tpat_variant(l1,None,_r1), Tpat_variant(l2,None,_) ->
+      l1 = l2
+  | Tpat_variant(_,_,_), Tpat_variant(_,_,_) -> false
+  | Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs
+  | Tpat_lazy p, Tpat_lazy q -> le_pat p q
+  | Tpat_record (l1,_), Tpat_record (l2,_) ->
+      let ps,qs = records_args l1 l2 in
+      le_pats ps qs
+  | Tpat_array(ps), Tpat_array(qs) ->
+      List.length ps = List.length qs && le_pats ps qs
+(* In all other cases, enumeration is performed *)
+  | _,_  -> not (satisfiable [[p]] [q])
+
+and le_pats ps qs =
+  match ps,qs with
+    p::ps, q::qs -> le_pat p q && le_pats ps qs
+  | _, _         -> true
+
+let get_mins le ps =
+  let rec select_rec r = function
+      [] -> r
+    | p::ps ->
+        if List.exists (fun p0 -> le p0 p) ps
+        then select_rec r ps
+        else select_rec (p::r) ps in
+  select_rec [] (select_rec [] ps)
+
+(*
+  lub p q is a pattern that matches all values matched by p and q
+  may raise Empty, when p and q are not compatible
+*)
+
+let rec lub p q = match p.pat_desc,q.pat_desc with
+| Tpat_alias (p,_,_),_      -> lub p q
+| _,Tpat_alias (q,_,_)      -> lub p q
+| (Tpat_any|Tpat_var _),_ -> q
+| _,(Tpat_any|Tpat_var _) -> p
+| Tpat_or (p1,p2,_),_     -> orlub p1 p2 q
+| _,Tpat_or (q1,q2,_)     -> orlub q1 q2 p (* Thanks god, lub is commutative *)
+| Tpat_constant c1, Tpat_constant c2 when const_compare c1 c2 = 0 -> p
+| Tpat_tuple ps, Tpat_tuple qs ->
+    let rs = lubs ps qs in
+    make_pat (Tpat_tuple rs) p.pat_type p.pat_env
+| Tpat_lazy p, Tpat_lazy q ->
+    let r = lub p q in
+    make_pat (Tpat_lazy r) p.pat_type p.pat_env
+| Tpat_construct (lid,c1,ps1,_), Tpat_construct (_,c2,ps2,_)
+      when  Types.equal_tag c1.cstr_tag c2.cstr_tag  ->
+        let rs = lubs ps1 ps2 in
+        make_pat (Tpat_construct (lid, c1, rs, None))
+          p.pat_type p.pat_env
+| Tpat_variant(l1,Some p1,row), Tpat_variant(l2,Some p2,_)
+          when  l1=l2 ->
+            let r=lub p1 p2 in
+            make_pat (Tpat_variant (l1,Some r,row)) p.pat_type p.pat_env
+| Tpat_variant (l1,None,_row), Tpat_variant(l2,None,_)
+              when l1 = l2 -> p
+| Tpat_record (l1,closed),Tpat_record (l2,_) ->
+    let rs = record_lubs l1 l2 in
+    make_pat (Tpat_record (rs, closed)) p.pat_type p.pat_env
+| Tpat_array ps, Tpat_array qs
+      when List.length ps = List.length qs ->
+        let rs = lubs ps qs in
+        make_pat (Tpat_array rs) p.pat_type p.pat_env
+| _,_  ->
+    raise Empty
+
+and orlub p1 p2 q =
+  try
+    let r1 = lub p1 q in
+    try
+      {q with pat_desc=(Tpat_or (r1,lub p2 q,None))}
+  with
+  | Empty -> r1
+with
+| Empty -> lub p2 q
+
+and record_lubs l1 l2 =
+  let rec lub_rec l1 l2 = match l1,l2 with
+  | [],_ -> l2
+  | _,[] -> l1
+  | (lid1, lbl1,p1)::rem1, (lid2, lbl2,p2)::rem2 ->
+      if lbl1.lbl_pos < lbl2.lbl_pos then
+        (lid1, lbl1,p1)::lub_rec rem1 l2
+      else if lbl2.lbl_pos < lbl1.lbl_pos  then
+        (lid2, lbl2,p2)::lub_rec l1 rem2
+      else
+        (lid1, lbl1,lub p1 p2)::lub_rec rem1 rem2 in
+  lub_rec l1 l2
+
+and lubs ps qs = match ps,qs with
+| p::ps, q::qs -> lub p q :: lubs ps qs
+| _,_ -> []
+
+
+(******************************)
+(* Exported variant closing   *)
+(******************************)
+
+(* Apply pressure to variants *)
+
+let pressure_variants tdefs patl =
+  ignore (pressure_variants
+            (Some tdefs)
+            (List.map (fun p -> [p; omega]) patl))
+
+let pressure_variants_in_computation_pattern tdefs patl =
+  let add_row pss p_opt =
+    match p_opt with
+    | None -> pss
+    | Some p -> p :: pss
+  in
+  let val_pss, exn_pss =
+    List.fold_right (fun pat (vpss, epss)->
+      let (vp, ep) = split_pattern pat in
+      add_row vpss vp, add_row epss ep
+    ) patl ([], [])
+  in
+  pressure_variants tdefs val_pss;
+  pressure_variants tdefs exn_pss
+
+(*****************************)
+(* Utilities for diagnostics *)
+(*****************************)
+
+(*
+  Build up a working pattern matrix by forgetting
+  about guarded patterns
+*)
+
+let rec initial_matrix = function
+    [] -> []
+  | {c_guard=Some _} :: rem -> initial_matrix rem
+  | {c_guard=None; c_lhs=p} :: rem -> [p] :: initial_matrix rem
+
+(*
+   Build up a working pattern matrix by keeping
+   only the patterns which are guarded
+*)
+let rec initial_only_guarded = function
+  | [] -> []
+  | { c_guard = None; _} :: rem ->
+      initial_only_guarded rem
+  | { c_lhs = pat; _ } :: rem ->
+      [pat] :: initial_only_guarded rem
+
+
+(************************)
+(* Exhaustiveness check *)
+(************************)
+
+(* conversion from Typedtree.pattern to Parsetree.pattern list *)
+module Conv = struct
+  open Parsetree
+  let mkpat desc = Ast_helper.Pat.mk desc
+
+  let name_counter = ref 0
+  let fresh name =
+    let current = !name_counter in
+    name_counter := !name_counter + 1;
+    "#$" ^ name ^ Int.to_string current
+
+  let conv typed =
+    let constrs = Hashtbl.create 7 in
+    let labels = Hashtbl.create 7 in
+    let rec loop pat =
+      match pat.pat_desc with
+        Tpat_or (pa,pb,_) ->
+          mkpat (Ppat_or (loop pa, loop pb))
+      | Tpat_var (_, ({txt="*extension*"} as nm)) -> (* PR#7330 *)
+          mkpat (Ppat_var nm)
+      | Tpat_any
+      | Tpat_var _ ->
+          mkpat Ppat_any
+      | Tpat_constant c ->
+          mkpat (Ppat_constant (Untypeast.constant c))
+      | Tpat_alias (p,_,_) -> loop p
+      | Tpat_tuple lst ->
+          mkpat (Ppat_tuple (List.map loop lst))
+      | Tpat_construct (cstr_lid, cstr, lst, _) ->
+          let id = fresh cstr.cstr_name in
+          let lid = { cstr_lid with txt = Longident.Lident id } in
+          Hashtbl.add constrs id cstr;
+          let arg =
+            match List.map loop lst with
+            | []  -> None
+            | [p] -> Some ([], p)
+            | lst -> Some ([], mkpat (Ppat_tuple lst))
+          in
+          mkpat (Ppat_construct(lid, arg))
+      | Tpat_variant(label,p_opt,_row_desc) ->
+          let arg = Option.map loop p_opt in
+          mkpat (Ppat_variant(label, arg))
+      | Tpat_record (subpatterns, _closed_flag) ->
+          let fields =
+            List.map
+              (fun (_, lbl, p) ->
+                let id = fresh lbl.lbl_name in
+                Hashtbl.add labels id lbl;
+                (mknoloc (Longident.Lident id), loop p))
+              subpatterns
+          in
+          mkpat (Ppat_record (fields, Open))
+      | Tpat_array lst ->
+          mkpat (Ppat_array (List.map loop lst))
+      | Tpat_lazy p ->
+          mkpat (Ppat_lazy (loop p))
+    in
+    let ps = loop typed in
+    (ps, constrs, labels)
+end
+
+
+(* Whether the counter-example contains an extension pattern *)
+let contains_extension pat =
+  exists_pattern
+    (function
+     | {pat_desc=Tpat_var (_, {txt="*extension*"})} -> true
+     | _ -> false)
+    pat
+
+(* Build a pattern from its expected type *)
+type pat_explosion = PE_single | PE_gadt_cases
+type ppat_of_type =
+  | PT_empty
+  | PT_any
+  | PT_pattern of
+      pat_explosion *
+      Parsetree.pattern *
+      (string, constructor_description) Hashtbl.t *
+      (string, label_description) Hashtbl.t
+
+let ppat_of_type env ty =
+  match pats_of_type env ty with
+  | [] -> PT_empty
+  | [{pat_desc = Tpat_any}] -> PT_any
+  | [pat] ->
+      let (ppat, constrs, labels) = Conv.conv pat in
+      PT_pattern (PE_single, ppat, constrs, labels)
+  | pats ->
+      let (ppat, constrs, labels) = Conv.conv (orify_many pats) in
+      PT_pattern (PE_gadt_cases, ppat, constrs, labels)
+
+let typecheck ~pred p =
+  let (pattern,constrs,labels) = Conv.conv p in
+  pred constrs labels pattern
+
+let do_check_partial ~pred loc casel pss = match pss with
+| [] ->
+        (*
+          This can occur
+          - For empty matches generated by ocamlp4 (no warning)
+          - when all patterns have guards (then, casel <> [])
+          (specific warning)
+          Then match MUST be considered non-exhaustive,
+          otherwise compilation of PM is broken.
+          *)
+    begin match casel with
+    | [] -> ()
+    | _  ->
+      if Warnings.is_active Warnings.All_clauses_guarded then
+        Location.prerr_warning loc Warnings.All_clauses_guarded
+    end ;
+    Partial
+| ps::_  ->
+    let counter_examples =
+      exhaust None pss (List.length ps)
+      |> Seq.filter_map (typecheck ~pred) in
+    match counter_examples () with
+    | Seq.Nil -> Total
+    | Seq.Cons (v, _rest) ->
+      if Warnings.is_active (Warnings.Partial_match "") then begin
+        let errmsg =
+          try
+            let buf = Buffer.create 16 in
+            let fmt = Format.formatter_of_buffer buf in
+            Printpat.top_pretty fmt v;
+            if do_match (initial_only_guarded casel) [v] then
+              Buffer.add_string buf
+                "\n(However, some guarded clause may match this value.)";
+            if contains_extension v then
+              Buffer.add_string buf
+                "\nMatching over values of extensible variant types \
+                   (the *extension* above)\n\
+              must include a wild card pattern in order to be exhaustive."
+            ;
+            Buffer.contents buf
+          with _ ->
+            ""
+        in
+        Location.prerr_warning loc (Warnings.Partial_match errmsg)
+      end;
+      Partial
+
+(*****************)
+(* Fragile check *)
+(*****************)
+
+(* Collect all data types in a pattern *)
+
+let rec add_path path = function
+  | [] -> [path]
+  | x::rem as paths ->
+      if Path.same path x then paths
+      else x::add_path path rem
+
+let extendable_path path =
+  not
+    (Path.same path Predef.path_bool ||
+    Path.same path Predef.path_list ||
+    Path.same path Predef.path_unit ||
+    Path.same path Predef.path_option)
+
+let rec collect_paths_from_pat r p = match p.pat_desc with
+| Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)},
+                 ps, _) ->
+    let path = get_constructor_type_path p.pat_type p.pat_env in
+    List.fold_left
+      collect_paths_from_pat
+      (if extendable_path path then add_path path r else r)
+      ps
+| Tpat_any|Tpat_var _|Tpat_constant _| Tpat_variant (_,None,_) -> r
+| Tpat_tuple ps | Tpat_array ps
+| Tpat_construct (_, {cstr_tag=Cstr_extension _}, ps, _)->
+    List.fold_left collect_paths_from_pat r ps
+| Tpat_record (lps,_) ->
+    List.fold_left
+      (fun r (_, _, p) -> collect_paths_from_pat r p)
+      r lps
+| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_) -> collect_paths_from_pat r p
+| Tpat_or (p1,p2,_) ->
+    collect_paths_from_pat (collect_paths_from_pat r p1) p2
+| Tpat_lazy p
+    ->
+    collect_paths_from_pat r p
+
+
+(*
+  Actual fragile check
+   1. Collect data types in the patterns of the match.
+   2. One exhaustivity check per datatype, considering that
+      the type is extended.
+*)
+
+let do_check_fragile loc casel pss =
+  let exts =
+    List.fold_left
+      (fun r c -> collect_paths_from_pat r c.c_lhs)
+      [] casel in
+  match exts with
+  | [] -> ()
+  | _ -> match pss with
+    | [] -> ()
+    | ps::_ ->
+        List.iter
+          (fun ext ->
+            let witnesses = exhaust (Some ext) pss (List.length ps) in
+            match witnesses () with
+            | Seq.Nil ->
+                Location.prerr_warning
+                  loc
+                  (Warnings.Fragile_match (Path.name ext))
+            | Seq.Cons _ -> ())
+          exts
+
+(********************************)
+(* Exported unused clause check *)
+(********************************)
+
+let check_unused pred casel =
+  if Warnings.is_active Warnings.Redundant_case
+  || List.exists (fun c -> c.c_rhs.exp_desc = Texp_unreachable) casel then
+    let rec do_rec pref = function
+      | [] -> ()
+      | {c_lhs=q; c_guard; c_rhs} :: rem ->
+          let qs = [q] in
+            begin try
+              let pss =
+                (* prev was accumulated in reverse order;
+                   restore source order to get ordered counter-examples *)
+                List.rev pref
+                |> List.filter (compats qs)
+                |> get_mins le_pats in
+              (* First look for redundant or partially redundant patterns *)
+              let r = every_satisfiables (make_rows pss) (make_row qs) in
+              let refute = (c_rhs.exp_desc = Texp_unreachable) in
+              (* Do not warn for unused [pat -> .] *)
+              if r = Unused && refute then () else
+              let r =
+                (* Do not refine if either:
+                   - we already know the clause is unused
+                   - the clause under consideration is not a refutation clause
+                     and either:
+                     + there are no other lines
+                     + we do not care whether the types prevent this clause to
+                       be reached.
+                     If the clause under consideration *is* a refutation clause
+                     then we do need to check more carefully whether it can be
+                     refuted or not.  *)
+                let skip =
+                  r = Unused || (not refute && pref = []) ||
+                  not(refute || Warnings.is_active Warnings.Unreachable_case) in
+                if skip then r else
+                (* Then look for empty patterns *)
+                let sfs = list_satisfying_vectors pss qs in
+                if sfs = [] then Unused else
+                let sfs =
+                  List.map (function [u] -> u | _ -> assert false) sfs in
+                let u = orify_many sfs in
+                (*Format.eprintf "%a@." pretty_val u;*)
+                let (pattern,constrs,labels) = Conv.conv u in
+                let pattern = {pattern with Parsetree.ppat_loc = q.pat_loc} in
+                match pred refute constrs labels pattern with
+                  None when not refute ->
+                    Location.prerr_warning q.pat_loc Warnings.Unreachable_case;
+                    Used
+                | _ -> r
+              in
+              match r with
+              | Unused ->
+                  Location.prerr_warning
+                    q.pat_loc Warnings.Redundant_case
+              | Upartial ps ->
+                  List.iter
+                    (fun p ->
+                      Location.prerr_warning
+                        p.pat_loc Warnings.Redundant_subpat)
+                    ps
+              | Used -> ()
+            with Empty | Not_found -> assert false
+            end ;
+
+          if c_guard <> None then
+            do_rec pref rem
+          else
+            do_rec ([q]::pref) rem in
+
+    do_rec [] casel
+
+(*********************************)
+(* Exported irrefutability tests *)
+(*********************************)
+
+let irrefutable pat = le_pat pat omega
+
+let inactive ~partial pat =
+  match partial with
+  | Partial -> false
+  | Total -> begin
+      let rec loop pat =
+        match pat.pat_desc with
+        | Tpat_lazy _ | Tpat_array _ ->
+          false
+        | Tpat_any | Tpat_var _ | Tpat_variant (_, None, _) ->
+            true
+        | Tpat_constant c -> begin
+            match c with
+            | Const_string _ -> Config.safe_string
+            | Const_int _ | Const_char _ | Const_float _
+            | Const_int32 _ | Const_int64 _ | Const_nativeint _ -> true
+          end
+        | Tpat_tuple ps | Tpat_construct (_, _, ps, _) ->
+            List.for_all (fun p -> loop p) ps
+        | Tpat_alias (p,_,_) | Tpat_variant (_, Some p, _) ->
+            loop p
+        | Tpat_record (ldps,_) ->
+            List.for_all
+              (fun (_, lbl, p) -> lbl.lbl_mut = Immutable && loop p)
+              ldps
+        | Tpat_or (p,q,_) ->
+            loop p && loop q
+      in
+      loop pat
+  end
+
+
+
+
+
+
+
+(*********************************)
+(* Exported exhaustiveness check *)
+(*********************************)
+
+(*
+   Fragile check is performed when required and
+   on exhaustive matches only.
+*)
+
+let check_partial pred loc casel =
+  let pss = initial_matrix casel in
+  let pss = get_mins le_pats pss in
+  let total = do_check_partial ~pred loc casel pss in
+  if
+    total = Total && Warnings.is_active (Warnings.Fragile_match "")
+  then begin
+    do_check_fragile loc casel pss
+  end ;
+  total
+
+(*************************************)
+(* Ambiguous variable in or-patterns *)
+(*************************************)
+
+(* Specification: ambiguous variables in or-patterns.
+
+   The semantics of or-patterns in OCaml is specified with
+   a left-to-right bias: a value [v] matches the pattern [p | q] if it
+   matches [p] or [q], but if it matches both, the environment
+   captured by the match is the environment captured by [p], never the
+   one captured by [q].
+
+   While this property is generally well-understood, one specific case
+   where users expect a different semantics is when a pattern is
+   followed by a when-guard: [| p when g -> e]. Consider for example:
+
+     | ((Const x, _) | (_, Const x)) when is_neutral x -> branch
+
+   The semantics is clear: match the scrutinee against the pattern, if
+   it matches, test the guard, and if the guard passes, take the
+   branch.
+
+   However, consider the input [(Const a, Const b)], where [a] fails
+   the test [is_neutral f], while [b] passes the test [is_neutral
+   b]. With the left-to-right semantics, the clause above is *not*
+   taken by its input: matching [(Const a, Const b)] against the
+   or-pattern succeeds in the left branch, it returns the environment
+   [x -> a], and then the guard [is_neutral a] is tested and fails,
+   the branch is not taken. Most users, however, intuitively expect
+   that any pair that has one side passing the test will take the
+   branch. They assume it is equivalent to the following:
+
+     | (Const x, _) when is_neutral x -> branch
+     | (_, Const x) when is_neutral x -> branch
+
+   while it is not.
+
+   The code below is dedicated to finding these confusing cases: the
+   cases where a guard uses "ambiguous" variables, that are bound to
+   different parts of the scrutinees by different sides of
+   a or-pattern. In other words, it finds the cases where the
+   specified left-to-right semantics is not equivalent to
+   a non-deterministic semantics (any branch can be taken) relatively
+   to a specific guard.
+*)
+
+let pattern_vars p = Ident.Set.of_list (Typedtree.pat_bound_idents p)
+
+(* Row for ambiguous variable search,
+   row is the traditional pattern row,
+   varsets contain a list of head variable sets (varsets)
+
+   A given varset contains all the variables that appeared at the head
+   of a pattern in the row at some point during traversal: they would
+   all be bound to the same value at matching time. On the contrary,
+   two variables of different varsets appeared at different places in
+   the pattern and may be bound to distinct sub-parts of the matched
+   value.
+
+   All rows of a (sub)matrix have rows of the same length,
+   but also varsets of the same length.
+
+   Varsets are populated when simplifying the first column
+   -- the variables of the head pattern are collected in a new varset.
+   For example,
+     { row = x :: r1; varsets = s1 }
+     { row = (Some _) as y :: r2; varsets  = s2 }
+     { row = (None as x) as y :: r3; varsets = s3 }
+     { row = (Some x | (None as x)) :: r4 with varsets = s4 }
+   becomes
+     (_, { row = r1; varsets = {x} :: s1 })
+     (Some _, { row = r2; varsets = {y} :: s2 })
+     (None, { row = r3; varsets = {x, y} :: s3 })
+     (Some x, { row = r4; varsets = {} :: s4 })
+     (None, { row = r4; varsets = {x} :: s4 })
+*)
+type amb_row = { row : pattern list ; varsets : Ident.Set.t list; }
+
+let simplify_head_amb_pat head_bound_variables varsets ~add_column p ps k =
+  let rec simpl head_bound_variables varsets p ps k =
+    match (Patterns.General.view p).pat_desc with
+    | `Alias (p,x,_) ->
+      simpl (Ident.Set.add x head_bound_variables) varsets p ps k
+    | `Var (x, _) ->
+      simpl (Ident.Set.add x head_bound_variables) varsets Patterns.omega ps k
+    | `Or (p1,p2,_) ->
+      simpl head_bound_variables varsets p1 ps
+        (simpl head_bound_variables varsets p2 ps k)
+    | #Patterns.Simple.view as view ->
+      add_column (Patterns.Head.deconstruct { p with pat_desc = view })
+        { row = ps; varsets = head_bound_variables :: varsets; } k
+  in simpl head_bound_variables varsets p ps k
+
+(*
+   To accurately report ambiguous variables, one must consider
+   that previous clauses have already matched some values.
+   Consider for example:
+
+     | (Foo x, Foo y) -> ...
+     | ((Foo x, _) | (_, Foo x)) when bar x -> ...
+
+   The second line taken in isolation uses an unstable variable,
+   but the discriminating values, of the shape [(Foo v1, Foo v2)],
+   would all be filtered by the line above.
+
+   To track this information, the matrices we analyze contain both
+   *positive* rows, that describe the rows currently being analyzed
+   (of type Varsets.row, so that their varsets are tracked) and
+   *negative rows*, that describe the cases already matched against.
+
+   The values matched by a signed matrix are the values matched by
+   some of the positive rows but none of the negative rows. In
+   particular, a variable is stable if, for any value not matched by
+   any of the negative rows, the environment captured by any of the
+   matching positive rows is identical.
+*)
+type ('a, 'b) signed = Positive of 'a | Negative of 'b
+
+let rec simplify_first_amb_col = function
+  | [] -> []
+  | (Negative [] | Positive { row = []; _ }) :: _  -> assert false
+  | Negative (n :: ns) :: rem ->
+      let add_column n ns k = (n, Negative ns) :: k in
+      simplify_head_pat
+        ~add_column n ns (simplify_first_amb_col rem)
+  | Positive { row = p::ps; varsets; }::rem ->
+      let add_column p ps k = (p, Positive ps) :: k in
+      simplify_head_amb_pat
+        Ident.Set.empty varsets
+        ~add_column p ps (simplify_first_amb_col rem)
+
+(* Compute stable bindings *)
+
+type stable_vars =
+  | All
+  | Vars of Ident.Set.t
+
+let stable_inter sv1 sv2 = match sv1, sv2 with
+  | All, sv | sv, All -> sv
+  | Vars s1, Vars s2 -> Vars (Ident.Set.inter s1 s2)
+
+let reduce f = function
+| [] -> invalid_arg "reduce"
+| x::xs -> List.fold_left f x xs
+
+let rec matrix_stable_vars m = match m with
+  | [] -> All
+  | ((Positive {row = []; _} | Negative []) :: _) as empty_rows ->
+      let exception Negative_empty_row in
+      (* if at least one empty row is negative, the matrix matches no value *)
+      let get_varsets = function
+        | Negative n ->
+            (* All rows have the same number of columns;
+               if the first row is empty, they all are. *)
+            assert (n = []);
+            raise Negative_empty_row
+        | Positive p ->
+            assert (p.row = []);
+            p.varsets in
+      begin match List.map get_varsets empty_rows with
+      | exception Negative_empty_row -> All
+      | rows_varsets ->
+          let stables_in_varsets =
+            reduce (List.map2 Ident.Set.inter) rows_varsets in
+          (* The stable variables are those stable at any position *)
+          Vars
+            (List.fold_left Ident.Set.union Ident.Set.empty stables_in_varsets)
+      end
+  | m ->
+      let is_negative = function
+        | Negative _ -> true
+        | Positive _ -> false in
+      if List.for_all is_negative m then
+        (* optimization: quit early if there are no positive rows.
+           This may happen often when the initial matrix has many
+           negative cases and few positive cases (a small guarded
+           clause after a long list of clauses) *)
+        All
+      else begin
+        let m = simplify_first_amb_col m in
+        if not (all_coherent (first_column m)) then
+          All
+        else begin
+          (* If the column is ill-typed but deemed coherent, we might
+             spuriously warn about some variables being unstable.
+             As sad as that might be, the warning can be silenced by
+             splitting the or-pattern...  *)
+          let submatrices =
+            let extend_row columns = function
+              | Negative r -> Negative (columns @ r)
+              | Positive r -> Positive { r with row = columns @ r.row } in
+            let q0 = discr_pat Patterns.Simple.omega m in
+            let { default; constrs } =
+              build_specialized_submatrices ~extend_row q0 m in
+            let non_default = List.map snd constrs in
+            if full_match false constrs
+            then non_default
+            else default :: non_default in
+          (* A stable variable must be stable in each submatrix. *)
+          let submat_stable = List.map matrix_stable_vars submatrices in
+          List.fold_left stable_inter All submat_stable
+        end
+      end
+
+let pattern_stable_vars ns p =
+  matrix_stable_vars
+    (List.fold_left (fun m n -> Negative n :: m)
+       [Positive {varsets = []; row = [p]}] ns)
+
+(* All identifier paths that appear in an expression that occurs
+   as a clause right hand side or guard.
+
+  The function is rather complex due to the compilation of
+  unpack patterns by introducing code in rhs expressions
+  and **guards**.
+
+  For pattern (module M:S)  -> e the code is
+  let module M_mod = unpack M .. in e
+
+  Hence M is "free" in e iff M_mod is free in e.
+
+  Not doing so will yield excessive  warning in
+  (module (M:S) } ...) when true -> ....
+  as M is always present in
+  let module M_mod = unpack M .. in true
+*)
+
+let all_rhs_idents exp =
+  let ids = ref Ident.Set.empty in
+(* Very hackish, detect unpack pattern  compilation
+   and perform "indirect check for them" *)
+  let is_unpack exp =
+      List.exists
+        (fun attr -> attr.Parsetree.attr_name.txt = "#modulepat")
+        exp.exp_attributes in
+  let open Tast_iterator in
+  let expr_iter iter exp =
+    (match exp.exp_desc with
+      | Texp_ident (path, _lid, _descr) ->
+        List.iter (fun id -> ids := Ident.Set.add id !ids) (Path.heads path)
+      (* Use default iterator methods for rest of match.*)
+      | _ -> Tast_iterator.default_iterator.expr iter exp);
+
+    if is_unpack exp then begin match exp.exp_desc with
+    | Texp_letmodule
+        (id_mod,_,_,
+         {mod_desc=
+          Tmod_unpack ({exp_desc=Texp_ident (Path.Pident id_exp,_,_)},_)},
+         _) ->
+           assert (Ident.Set.mem id_exp !ids) ;
+           begin match id_mod with
+           | Some id_mod when not (Ident.Set.mem id_mod !ids) ->
+             ids := Ident.Set.remove id_exp !ids
+           | _ -> ()
+           end
+    | _ -> assert false
+    end
+  in
+  let iterator = {Tast_iterator.default_iterator with expr = expr_iter} in
+  iterator.expr iterator exp;
+  !ids
+
+let check_ambiguous_bindings =
+  let open Warnings in
+  let warn0 = Ambiguous_var_in_pattern_guard [] in
+  fun cases ->
+    if is_active warn0 then
+      let check_case ns case = match case with
+        | { c_lhs = p; c_guard=None ; _} -> [p]::ns
+        | { c_lhs=p; c_guard=Some g; _} ->
+            let all =
+              Ident.Set.inter (pattern_vars p) (all_rhs_idents g) in
+            if not (Ident.Set.is_empty all) then begin
+              match pattern_stable_vars ns p with
+              | All -> ()
+              | Vars stable ->
+                  let ambiguous = Ident.Set.diff all stable in
+                  if not (Ident.Set.is_empty ambiguous) then begin
+                    let pps =
+                      Ident.Set.elements ambiguous |> List.map Ident.name in
+                    let warn = Ambiguous_var_in_pattern_guard pps in
+                    Location.prerr_warning p.pat_loc warn
+                  end
+            end;
+            ns
+      in
+      ignore (List.fold_left check_case [] cases)
+
+let do_complete_partial ?pred pss =
+  (* c/p of [do_check_partial] without the parts concerning the generation of
+     the error message or the warning emiting. *)
+  match pss with
+  | [] -> []
+  | ps :: _  ->
+    let typecheck p =
+      match pred with
+      | Some pred ->
+          let (pattern,constrs,labels) = Conv.conv p in
+          Option.map (fun v -> v, Some (constrs, labels))
+            (pred constrs labels pattern)
+      | None -> Some (p, None)
+    in
+    exhaust None pss (List.length ps)
+    |> Seq.filter_map typecheck
+    |> List.of_seq
+
+let complete_partial ~pred pss =
+  let pss = get_mins le_pats pss in
+
+  do_complete_partial ~pred pss
+
+let return_unused casel =
+  let rec do_rec acc pref = function
+    | [] -> acc
+    | q :: rem ->
+      let qs = [q] in
+      let acc =
+        try
+          let pss = get_mins le_pats (List.filter (compats qs) pref) in
+          let r = every_satisfiables (make_rows pss) (make_row qs) in
+          match r with
+          | Unused -> `Unused q :: acc
+          | Upartial ps -> `Unused_subs (q, ps) :: acc
+          | Used -> acc
+        with Empty | Not_found -> assert false
+      in
+      (* FIXME: we need to know whether there is a guard here, because if there
+         is, we dont want to add [[q]] to [pref]. *)
+      do_rec acc ([q]::pref) rem
+  in
+  do_rec [] [] casel
diff --git a/src/ocaml/typing/parmatch.mli b/src/ocaml/typing/parmatch.mli
new file mode 100644
index 0000000..f0ff75f
--- /dev/null
+++ b/src/ocaml/typing/parmatch.mli
@@ -0,0 +1,149 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Detection of partial matches and unused match cases. *)
+
+open Asttypes
+open Typedtree
+open Types
+
+val const_compare : constant -> constant -> int
+(** [const_compare c1 c2] compares the actual values represented by [c1] and
+    [c2], while simply using [Stdlib.compare] would compare the
+    representations.
+
+    cf. MPR#5758 *)
+
+val le_pat : pattern -> pattern -> bool
+(** [le_pat p q]  means: forall V,  V matches q implies V matches p *)
+
+val le_pats : pattern list -> pattern list -> bool
+(** [le_pats (p1 .. pm) (q1 .. qn)] means: forall i <= m, [le_pat pi qi] *)
+
+(** Exported compatibility functor, abstracted over constructor equality *)
+module Compat :
+  functor
+    (_ : sig
+      val equal :
+          Types.constructor_description ->
+            Types.constructor_description ->
+              bool
+     end) -> sig
+       val compat : pattern -> pattern -> bool
+       val compats : pattern list -> pattern list -> bool
+     end
+
+exception Empty
+
+val lub : pattern -> pattern -> pattern
+(** [lub p q] is a pattern that matches all values matched by [p] and [q].
+    May raise [Empty], when [p] and [q] are not compatible. *)
+
+val lubs : pattern list -> pattern list -> pattern list
+(** [lubs [p1; ...; pn] [q1; ...; qk]], where [n < k], is
+    [[lub p1 q1; ...; lub pk qk]].  *)
+
+val get_mins : ('a -> 'a -> bool) -> 'a list -> 'a list
+
+(** Those two functions recombine one pattern and its arguments:
+    For instance:
+      (_,_)::p1::p2::rem -> (p1, p2)::rem
+    The second one will replace mutable arguments by '_'
+*)
+val set_args : pattern -> pattern list -> pattern list
+val set_args_erase_mutable : pattern -> pattern list -> pattern list
+
+val pat_of_constr : pattern -> constructor_description -> pattern
+val complete_constrs :
+    constructor_description pattern_data ->
+    constructor_description list ->
+    constructor_description list
+
+(** [ppat_of_type] builds an untyped pattern from its expected type,
+    for explosion of wildcard patterns in Typecore.type_pat.
+
+    There are four interesting cases:
+    - the type is empty ([PT_empty])
+    - no further explosion is necessary ([PT_any])
+    - a single pattern is generated, from a record or tuple type
+      or a single-variant type ([PE_single])
+    - an or-pattern is generated, in the case that all branches
+      are GADT constructors ([PE_gadt_cases]).
+ *)
+type pat_explosion = PE_single | PE_gadt_cases
+type ppat_of_type =
+  | PT_empty
+  | PT_any
+  | PT_pattern of
+      pat_explosion *
+      Parsetree.pattern *
+      (string, constructor_description) Hashtbl.t *
+      (string, label_description) Hashtbl.t
+
+val ppat_of_type: Env.t -> type_expr -> ppat_of_type
+
+val pressure_variants:
+  Env.t -> pattern list -> unit
+val pressure_variants_in_computation_pattern:
+  Env.t -> computation general_pattern list -> unit
+
+(** [check_partial pred loc caselist] and [check_unused refute pred caselist]
+    are called with a function [pred] which will be given counter-example
+    candidates: they may be partially ill-typed, and have to be type-checked
+    to extract a valid counter-example.
+    [pred] returns a valid counter-example or [None].
+    [refute] indicates that [check_unused] was called on a refutation clause.
+ *)
+val check_partial:
+    ((string, constructor_description) Hashtbl.t ->
+     (string, label_description) Hashtbl.t ->
+     Parsetree.pattern -> pattern option) ->
+    Location.t -> value case list -> partial
+val check_unused:
+    (bool ->
+     (string, constructor_description) Hashtbl.t ->
+     (string, label_description) Hashtbl.t ->
+     Parsetree.pattern -> pattern option) ->
+    value case list -> unit
+
+(* Irrefutability tests *)
+val irrefutable : pattern -> bool
+
+(** An inactive pattern is a pattern, matching against which can be duplicated,
+    erased or delayed without change in observable behavior of the program.
+    Patterns containing (lazy _) subpatterns or reads of mutable fields are
+    active. *)
+val inactive : partial:partial -> pattern -> bool
+
+(* Ambiguous bindings *)
+val check_ambiguous_bindings : value case list -> unit
+
+(* The tag used for open polymorphic variant types with an abstract row *)
+val some_private_tag : label
+
+(*******************)
+(* Merlin specific *)
+(*******************)
+
+val complete_partial :
+  pred:((label, constructor_description) Hashtbl.t ->
+        (label, label_description) Hashtbl.t ->
+        Parsetree.pattern -> pattern option) ->
+  pattern list list ->
+  (pattern * ((label, constructor_description) Hashtbl.t *
+  (label, label_description) Hashtbl.t) option) list
+
+val return_unused: pattern list ->
+  [ `Unused of pattern | `Unused_subs of pattern * pattern list ] list
diff --git a/src/ocaml/typing/path.ml b/src/ocaml/typing/path.ml
new file mode 100644
index 0000000..4190c27
--- /dev/null
+++ b/src/ocaml/typing/path.ml
@@ -0,0 +1,129 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t =
+    Pident of Ident.t
+  | Pdot of t * string
+  | Papply of t * t
+
+let rec same p1 p2 =
+  p1 == p2
+  || match (p1, p2) with
+    (Pident id1, Pident id2) -> Ident.same id1 id2
+  | (Pdot(p1, s1), Pdot(p2, s2)) -> s1 = s2 && same p1 p2
+  | (Papply(fun1, arg1), Papply(fun2, arg2)) ->
+       same fun1 fun2 && same arg1 arg2
+  | (_, _) -> false
+
+let rec compare p1 p2 =
+  if p1 == p2 then 0
+  else match (p1, p2) with
+    (Pident id1, Pident id2) -> Ident.compare id1 id2
+  | (Pdot(p1, s1), Pdot(p2, s2)) ->
+      let h = compare p1 p2 in
+      if h <> 0 then h else String.compare s1 s2
+  | (Papply(fun1, arg1), Papply(fun2, arg2)) ->
+      let h = compare fun1 fun2 in
+      if h <> 0 then h else compare arg1 arg2
+  | ((Pident _ | Pdot _), (Pdot _ | Papply _)) -> -1
+  | ((Pdot _ | Papply _), (Pident _ | Pdot _)) -> 1
+
+let rec find_free_opt ids = function
+    Pident id -> List.find_opt (Ident.same id) ids
+  | Pdot(p, _s) -> find_free_opt ids p
+  | Papply(p1, p2) ->
+      match find_free_opt ids p1 with
+      | None -> find_free_opt ids p2
+      | Some _ as res -> res
+
+let exists_free ids p =
+  match find_free_opt ids p with
+  | None -> false
+  | _ -> true
+
+let rec scope = function
+    Pident id -> Ident.scope id
+  | Pdot(p, _s) -> scope p
+  | Papply(p1, p2) -> Int.max (scope p1) (scope p2)
+
+let kfalse _ = false
+
+let rec name ?(paren=kfalse) = function
+    Pident id -> Ident.name id
+  | Pdot(p, s) ->
+      name ~paren p ^ if paren s then ".( " ^ s ^ " )" else "." ^ s
+  | Papply(p1, p2) -> name ~paren p1 ^ "(" ^ name ~paren p2 ^ ")"
+
+let rec print ppf = function
+  | Pident id -> Ident.print_with_scope ppf id
+  | Pdot(p, s) -> Format.fprintf ppf "%a.%s" print p s
+  | Papply(p1, p2) -> Format.fprintf ppf "%a(%a)" print p1 print p2
+
+let rec head = function
+    Pident id -> id
+  | Pdot(p, _s) -> head p
+  | Papply _ -> assert false
+
+let flatten =
+  let rec flatten acc = function
+    | Pident id -> `Ok (id, acc)
+    | Pdot (p, s) -> flatten (s :: acc) p
+    | Papply _ -> `Contains_apply
+  in
+  fun t -> flatten [] t
+
+let heads p =
+  let rec heads p acc = match p with
+    | Pident id -> id :: acc
+    | Pdot (p, _s) -> heads p acc
+    | Papply(p1, p2) ->
+        heads p1 (heads p2 acc)
+  in heads p []
+
+let rec last = function
+  | Pident id -> Ident.name id
+  | Pdot(_, s) -> s
+  | Papply(_, p) -> last p
+
+let is_uident s =
+  assert (s <> "");
+  match s.[0] with
+  | 'A'..'Z' -> true
+  | _ -> false
+
+type typath =
+  | Regular of t
+  | Ext of t * string
+  | LocalExt of Ident.t
+  | Cstr of t * string
+
+let constructor_typath = function
+  | Pident id when is_uident (Ident.name id) -> LocalExt id
+  | Pdot(ty_path, s) when is_uident s ->
+      if is_uident (last ty_path) then Ext (ty_path, s)
+      else Cstr (ty_path, s)
+  | p -> Regular p
+
+let is_constructor_typath p =
+  match constructor_typath p with
+  | Regular _ -> false
+  | _ -> true
+
+module T = struct
+  type nonrec t = t
+  let compare = compare
+end
+module Set = Set.Make(T)
+module Map = Map.Make(T)
diff --git a/src/ocaml/typing/path.mli b/src/ocaml/typing/path.mli
new file mode 100644
index 0000000..bddf9d6
--- /dev/null
+++ b/src/ocaml/typing/path.mli
@@ -0,0 +1,52 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Access paths *)
+
+type t =
+    Pident of Ident.t
+  | Pdot of t * string
+  | Papply of t * t
+
+val same: t -> t -> bool
+val compare: t -> t -> int
+val find_free_opt: Ident.t list -> t -> Ident.t option
+val exists_free: Ident.t list -> t -> bool
+val scope: t -> int
+val flatten : t -> [ `Contains_apply | `Ok of Ident.t * string list ]
+
+val name: ?paren:(string -> bool) -> t -> string
+    (* [paren] tells whether a path suffix needs parentheses *)
+val head: t -> Ident.t
+
+val print: Format.formatter -> t -> unit
+
+val heads: t -> Ident.t list
+
+val last: t -> string
+
+val is_uident: string -> bool
+
+type typath =
+  | Regular of t
+  | Ext of t * string
+  | LocalExt of Ident.t
+  | Cstr of t * string
+
+val constructor_typath: t -> typath
+val is_constructor_typath: t -> bool
+
+module Map : Map.S with type key = t
+module Set : Set.S with type elt = t
diff --git a/src/ocaml/typing/patterns.ml b/src/ocaml/typing/patterns.ml
new file mode 100644
index 0000000..8580329
--- /dev/null
+++ b/src/ocaml/typing/patterns.ml
@@ -0,0 +1,254 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Gabriel Scherer, projet Partout, INRIA Paris-Saclay           *)
+(*          Thomas Refis, Jane Street Europe                              *)
+(*                                                                        *)
+(*   Copyright 2019 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Types
+open Typedtree
+
+(* useful pattern auxiliary functions *)
+
+let omega = {
+  pat_desc = Tpat_any;
+  pat_loc = Location.none;
+  pat_extra = [];
+  pat_type = Ctype.none;
+  pat_env = Env.empty;
+  pat_attributes = [];
+}
+
+let rec omegas i =
+  if i <= 0 then [] else omega :: omegas (i-1)
+
+let omega_list l = List.map (fun _ -> omega) l
+
+module Non_empty_row = struct
+  type 'a t = 'a * Typedtree.pattern list
+
+  let of_initial = function
+    | [] -> assert false
+    | pat :: patl -> (pat, patl)
+
+  let map_first f (p, patl) = (f p, patl)
+end
+
+(* "views" on patterns are polymorphic variants
+   that allow to restrict the set of pattern constructors
+   statically allowed at a particular place *)
+
+module Simple = struct
+  type view = [
+    | `Any
+    | `Constant of constant
+    | `Tuple of pattern list
+    | `Construct of
+        Longident.t loc * constructor_description * pattern list
+    | `Variant of label * pattern option * row_desc ref
+    | `Record of
+        (Longident.t loc * label_description * pattern) list * closed_flag
+    | `Array of pattern list
+    | `Lazy of pattern
+  ]
+
+  type pattern = view pattern_data
+
+  let omega = { omega with pat_desc = `Any }
+end
+
+module Half_simple = struct
+  type view = [
+    | Simple.view
+    | `Or of pattern * pattern * row_desc option
+  ]
+
+  type pattern = view pattern_data
+end
+
+module General = struct
+  type view = [
+    | Half_simple.view
+    | `Var of Ident.t * string loc
+    | `Alias of pattern * Ident.t * string loc
+  ]
+  type pattern = view pattern_data
+
+  let view_desc = function
+    | Tpat_any ->
+       `Any
+    | Tpat_var (id, str) ->
+       `Var (id, str)
+    | Tpat_alias (p, id, str) ->
+       `Alias (p, id, str)
+    | Tpat_constant cst ->
+       `Constant cst
+    | Tpat_tuple ps ->
+       `Tuple ps
+    | Tpat_construct (cstr, cstr_descr, args, _) ->
+       `Construct (cstr, cstr_descr, args)
+    | Tpat_variant (cstr, arg, row_desc) ->
+       `Variant (cstr, arg, row_desc)
+    | Tpat_record (fields, closed) ->
+       `Record (fields, closed)
+    | Tpat_array ps -> `Array ps
+    | Tpat_or (p, q, row_desc) -> `Or (p, q, row_desc)
+    | Tpat_lazy p -> `Lazy p
+
+  let view p : pattern =
+    { p with pat_desc = view_desc p.pat_desc }
+
+  let erase_desc = function
+    | `Any -> Tpat_any
+    | `Var (id, str) -> Tpat_var (id, str)
+    | `Alias (p, id, str) -> Tpat_alias (p, id, str)
+    | `Constant cst -> Tpat_constant cst
+    | `Tuple ps -> Tpat_tuple ps
+    | `Construct (cstr, cst_descr, args) ->
+       Tpat_construct (cstr, cst_descr, args, None)
+    | `Variant (cstr, arg, row_desc) ->
+       Tpat_variant (cstr, arg, row_desc)
+    | `Record (fields, closed) ->
+       Tpat_record (fields, closed)
+    | `Array ps -> Tpat_array ps
+    | `Or (p, q, row_desc) -> Tpat_or (p, q, row_desc)
+    | `Lazy p -> Tpat_lazy p
+
+  let erase p : Typedtree.pattern =
+    { p with pat_desc = erase_desc p.pat_desc }
+
+  let rec strip_vars (p : pattern) : Half_simple.pattern =
+    match p.pat_desc with
+    | `Alias (p, _, _) -> strip_vars (view p)
+    | `Var _ -> { p with pat_desc = `Any }
+    | #Half_simple.view as view -> { p with pat_desc = view }
+end
+
+(* the head constructor of a simple pattern *)
+
+module Head : sig
+  type desc =
+    | Any
+    | Construct of constructor_description
+    | Constant of constant
+    | Tuple of int
+    | Record of label_description list
+    | Variant of
+        { tag: label; has_arg: bool;
+          cstr_row: row_desc ref;
+          type_row : unit -> row_desc; }
+    | Array of int
+    | Lazy
+
+  type t = desc pattern_data
+
+  val arity : t -> int
+
+  (** [deconstruct p] returns the head of [p] and the list of sub patterns. *)
+  val deconstruct : Simple.pattern -> t * pattern list
+
+  (** reconstructs a pattern, putting wildcards as sub-patterns. *)
+  val to_omega_pattern : t -> pattern
+
+  val omega : t
+end = struct
+  type desc =
+    | Any
+    | Construct of constructor_description
+    | Constant of constant
+    | Tuple of int
+    | Record of label_description list
+    | Variant of
+        { tag: label; has_arg: bool;
+          cstr_row: row_desc ref;
+          type_row : unit -> row_desc; }
+          (* the row of the type may evolve if [close_variant] is called,
+             hence the (unit -> ...) delay *)
+    | Array of int
+    | Lazy
+
+  type t = desc pattern_data
+
+  let deconstruct (q : Simple.pattern) =
+    let deconstruct_desc = function
+      | `Any -> Any, []
+      | `Constant c -> Constant c, []
+      | `Tuple args ->
+          Tuple (List.length args), args
+      | `Construct (_, c, args) ->
+          Construct c, args
+      | `Variant (tag, arg, cstr_row) ->
+          let has_arg, pats =
+            match arg with
+            | None -> false, []
+            | Some a -> true, [a]
+          in
+          let type_row () =
+            match Ctype.expand_head q.pat_env q.pat_type with
+              | {desc = Tvariant type_row} -> Btype.row_repr type_row
+              | _ -> assert false
+          in
+          Variant {tag; has_arg; cstr_row; type_row}, pats
+      | `Array args ->
+          Array (List.length args), args
+      | `Record (largs, _) ->
+          let lbls = List.map (fun (_,lbl,_) -> lbl) largs in
+          let pats = List.map (fun (_,_,pat) -> pat) largs in
+          Record lbls, pats
+      | `Lazy p ->
+          Lazy, [p]
+    in
+    let desc, pats = deconstruct_desc q.pat_desc in
+    { q with pat_desc = desc }, pats
+
+  let arity t =
+    match t.pat_desc with
+      | Any -> 0
+      | Constant _ -> 0
+      | Construct c -> c.cstr_arity
+      | Tuple n | Array n -> n
+      | Record l -> List.length l
+      | Variant { has_arg; _ } -> if has_arg then 1 else 0
+      | Lazy -> 1
+
+  let to_omega_pattern t =
+    let pat_desc =
+      let mkloc x = Location.mkloc x t.pat_loc in
+      match t.pat_desc with
+      | Any -> Tpat_any
+      | Lazy -> Tpat_lazy omega
+      | Constant c -> Tpat_constant c
+      | Tuple n -> Tpat_tuple (omegas n)
+      | Array n -> Tpat_array (omegas n)
+      | Construct c ->
+          let lid_loc = mkloc (Longident.Lident c.cstr_name) in
+          Tpat_construct (lid_loc, c, omegas c.cstr_arity, None)
+      | Variant { tag; has_arg; cstr_row } ->
+          let arg_opt = if has_arg then Some omega else None in
+          Tpat_variant (tag, arg_opt, cstr_row)
+      | Record lbls ->
+          let lst =
+            List.map (fun lbl ->
+              let lid_loc = mkloc (Longident.Lident lbl.lbl_name) in
+              (lid_loc, lbl, omega)
+            ) lbls
+          in
+          Tpat_record (lst, Closed)
+    in
+    { t with
+      pat_desc;
+      pat_extra = [];
+    }
+
+  let omega = { omega with pat_desc = Any }
+end
diff --git a/src/ocaml/typing/patterns.mli b/src/ocaml/typing/patterns.mli
new file mode 100644
index 0000000..66dd2d0
--- /dev/null
+++ b/src/ocaml/typing/patterns.mli
@@ -0,0 +1,109 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Gabriel Scherer, projet Partout, INRIA Paris-Saclay           *)
+(*          Thomas Refis, Jane Street Europe                              *)
+(*                                                                        *)
+(*   Copyright 2019 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Typedtree
+open Types
+
+val omega : pattern
+(** aka. "Tpat_any" or "_"  *)
+
+val omegas : int -> pattern list
+(** [List.init (fun _ -> omega)] *)
+
+val omega_list : 'a list -> pattern list
+(** [List.map (fun _ -> omega)] *)
+
+module Non_empty_row : sig
+  type 'a t = 'a * Typedtree.pattern list
+
+  val of_initial : Typedtree.pattern list -> Typedtree.pattern t
+  (** 'assert false' on empty rows *)
+
+  val map_first : ('a -> 'b) -> 'a t -> 'b t
+end
+
+module Simple : sig
+  type view = [
+    | `Any
+    | `Constant of constant
+    | `Tuple of pattern list
+    | `Construct of
+        Longident.t loc * constructor_description * pattern list
+    | `Variant of label * pattern option * row_desc ref
+    | `Record of
+        (Longident.t loc * label_description * pattern) list * closed_flag
+    | `Array of pattern list
+    | `Lazy of pattern
+  ]
+  type pattern = view pattern_data
+
+  val omega : [> view ] pattern_data
+end
+
+module Half_simple : sig
+  type view = [
+    | Simple.view
+    | `Or of pattern * pattern * row_desc option
+  ]
+  type pattern = view pattern_data
+end
+
+module General : sig
+  type view = [
+    | Half_simple.view
+    | `Var of Ident.t * string loc
+    | `Alias of pattern * Ident.t * string loc
+  ]
+  type pattern = view pattern_data
+
+  val view : Typedtree.pattern -> pattern
+  val erase : [< view ] pattern_data -> Typedtree.pattern
+
+  val strip_vars : pattern -> Half_simple.pattern
+end
+
+module Head : sig
+  type desc =
+    | Any
+    | Construct of constructor_description
+    | Constant of constant
+    | Tuple of int
+    | Record of label_description list
+    | Variant of
+        { tag: label; has_arg: bool;
+          cstr_row: row_desc ref;
+          type_row : unit -> row_desc; }
+          (* the row of the type may evolve if [close_variant] is called,
+             hence the (unit -> ...) delay *)
+    | Array of int
+    | Lazy
+
+  type t = desc pattern_data
+
+  val arity : t -> int
+
+  (** [deconstruct p] returns the head of [p] and the list of sub patterns.
+
+      @raise [Invalid_arg _] if [p] is an or- or an exception-pattern.  *)
+  val deconstruct : Simple.pattern -> t * pattern list
+
+  (** reconstructs a pattern, putting wildcards as sub-patterns. *)
+  val to_omega_pattern : t -> pattern
+
+  val omega : t
+
+end
diff --git a/src/ocaml/typing/persistent_env.ml b/src/ocaml/typing/persistent_env.ml
new file mode 100644
index 0000000..9b28a17
--- /dev/null
+++ b/src/ocaml/typing/persistent_env.ml
@@ -0,0 +1,424 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Xavier Leroy, projet Gallium, INRIA Rocquencourt                     *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*                                                                        *)
+(*   Copyright 2019 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Persistent structure descriptions *)
+
+open Misc
+open Cmi_format
+
+module Consistbl = Consistbl.Make (Misc.String)
+
+let add_delayed_check_forward = ref (fun _ -> assert false)
+
+type error =
+  | Illegal_renaming of modname * modname * filepath
+  | Inconsistent_import of modname * filepath * filepath
+  | Need_recursive_types of modname
+  | Depend_on_unsafe_string_unit of modname
+
+exception Error of error
+let error err = raise (Error err)
+
+module Persistent_signature = struct
+  type t =
+    { filename : string;
+      cmi : Cmi_format.cmi_infos }
+
+  let load = ref (fun ~unit_name ->
+      match Load_path.find_uncap (unit_name ^ ".cmi") with
+      | filename ->
+        let cmi = Cmi_cache.read filename in
+        Some { filename; cmi }
+      | exception Not_found -> None)
+end
+
+type can_load_cmis =
+  | Can_load_cmis
+  | Cannot_load_cmis of Lazy_backtrack.log
+
+type pers_struct = {
+  ps_name: string;
+  ps_crcs: (string * Digest.t option) list;
+  ps_filename: string;
+  ps_flags: pers_flags list;
+}
+
+module String = Misc.String
+
+(* If a .cmi file is missing (or invalid), we
+   store it as Missing in the cache. *)
+type 'a pers_struct_info =
+  | Missing
+  | Found of pers_struct * 'a
+
+type 'a t = {
+  persistent_structures : (string, 'a pers_struct_info) Hashtbl.t;
+  imported_units: String.Set.t ref;
+  imported_opaque_units: String.Set.t ref;
+  crc_units: Consistbl.t;
+  can_load_cmis: can_load_cmis ref;
+  short_paths_basis: Short_paths.Basis.t ref;
+}
+
+let empty () = {
+  persistent_structures = Hashtbl.create 17;
+  imported_units = ref String.Set.empty;
+  imported_opaque_units = ref String.Set.empty;
+  crc_units = Consistbl.create ();
+  can_load_cmis = ref Can_load_cmis;
+  short_paths_basis = ref (Short_paths.Basis.create ());
+}
+
+let clear penv =
+  let {
+    persistent_structures;
+    imported_units;
+    imported_opaque_units;
+    crc_units;
+    can_load_cmis;
+    short_paths_basis;
+  } = penv in
+  Hashtbl.clear persistent_structures;
+  imported_units := String.Set.empty;
+  imported_opaque_units := String.Set.empty;
+  Consistbl.clear crc_units;
+  can_load_cmis := Can_load_cmis;
+  short_paths_basis := Short_paths.Basis.create ();
+  ()
+
+let clear_missing {persistent_structures; _} =
+  let missing_entries =
+    Hashtbl.fold
+      (fun name r acc -> if r = Missing then name :: acc else acc)
+      persistent_structures []
+  in
+  List.iter (Hashtbl.remove persistent_structures) missing_entries
+
+let add_import {imported_units; _} s =
+  imported_units := String.Set.add s !imported_units
+
+let register_import_as_opaque {imported_opaque_units; _} s =
+  imported_opaque_units := String.Set.add s !imported_opaque_units
+
+let find_in_cache {persistent_structures; _} s =
+  match Hashtbl.find persistent_structures s with
+  | exception Not_found -> None
+  | Missing -> None
+  | Found (_ps, pm) -> Some pm
+
+let import_crcs penv ~source crcs =
+  let {crc_units; _} = penv in
+  let import_crc (name, crco) =
+    match crco with
+    | None -> ()
+    | Some crc ->
+        add_import penv name;
+        Consistbl.check crc_units name crc source
+  in List.iter import_crc crcs
+
+let check_consistency penv ps =
+  try import_crcs penv ~source:ps.ps_filename ps.ps_crcs
+  with Consistbl.Inconsistency {
+      unit_name = name;
+      inconsistent_source = source;
+      original_source = auth;
+    } ->
+    error (Inconsistent_import(name, auth, source))
+
+let can_load_cmis penv =
+  !(penv.can_load_cmis)
+let set_can_load_cmis penv setting =
+  penv.can_load_cmis := setting
+let short_paths_basis penv =
+  !(penv.short_paths_basis)
+
+let without_cmis penv f x =
+  let log = Lazy_backtrack.log () in
+  let res =
+    Misc.(protect_refs
+            [R (penv.can_load_cmis, Cannot_load_cmis log)]
+            (fun () -> f x))
+  in
+  Lazy_backtrack.backtrack log;
+  res
+
+let fold {persistent_structures; _} f x =
+  Hashtbl.fold (fun modname pso x -> match pso with
+      | Missing -> x
+      | Found (_, pm) -> f modname pm x)
+    persistent_structures x
+
+let register_pers_for_short_paths penv ps components =
+  let deps, alias_deps =
+    List.fold_left
+      (fun (deps, alias_deps) (name, digest) ->
+         Short_paths.Basis.add (short_paths_basis penv) name;
+         match digest with
+         | None -> deps, name :: alias_deps
+         | Some _ -> name :: deps, alias_deps)
+      ([], []) ps.ps_crcs
+  in
+  let desc =
+    Short_paths.Desc.Module.(Fresh (Signature components))
+  in
+  let is_deprecated =
+    List.exists
+      (function
+        | Alerts alerts ->
+          String.Map.mem "deprecated" alerts ||
+          String.Map.mem "ocaml.deprecated" alerts
+        | _ -> false)
+      ps.ps_flags
+  in
+  let deprecated =
+    if is_deprecated then Short_paths.Desc.Deprecated
+    else Short_paths.Desc.Not_deprecated
+  in
+  Short_paths.Basis.load (short_paths_basis penv) ps.ps_name
+    deps alias_deps desc deprecated
+(* Reading persistent structures from .cmi files *)
+
+let save_pers_struct penv crc ps pm =
+  let {persistent_structures; crc_units; _} = penv in
+  let modname = ps.ps_name in
+  Hashtbl.add persistent_structures modname (Found (ps, pm));
+  List.iter
+    (function
+        | Rectypes -> ()
+        | Alerts _ -> ()
+        | Unsafe_string -> ()
+        | Opaque -> register_import_as_opaque penv modname)
+    ps.ps_flags;
+  Consistbl.set crc_units modname crc ps.ps_filename;
+  add_import penv modname
+
+let acknowledge_pers_struct penv short_path_comps check modname pers_sig pm =
+  let { Persistent_signature.filename; cmi } = pers_sig in
+  let name = cmi.cmi_name in
+  let crcs = cmi.cmi_crcs in
+  let flags = cmi.cmi_flags in
+  let ps = { ps_name = name;
+             ps_crcs = crcs;
+             ps_filename = filename;
+             ps_flags = flags;
+           } in
+  if ps.ps_name <> modname then
+    error (Illegal_renaming(modname, ps.ps_name, filename));
+  List.iter
+    (function
+        | Rectypes ->
+            if not !Clflags.recursive_types then
+              error (Need_recursive_types(ps.ps_name))
+        | Unsafe_string ->
+            if Config.safe_string then
+              error (Depend_on_unsafe_string_unit(ps.ps_name));
+        | Alerts _ -> ()
+        | Opaque -> register_import_as_opaque penv modname)
+    ps.ps_flags;
+  if check then check_consistency penv ps;
+  let {persistent_structures; _} = penv in
+  Hashtbl.add persistent_structures modname (Found (ps, pm));
+  register_pers_for_short_paths penv ps (short_path_comps ps.ps_name pm);
+  ps
+
+let read_pers_struct penv val_of_pers_sig short_path_comps check modname filename =
+  add_import penv modname;
+  let cmi = Cmi_cache.read filename in
+  let pers_sig = { Persistent_signature.filename; cmi } in
+  let pm = val_of_pers_sig pers_sig in
+  let ps = acknowledge_pers_struct penv short_path_comps check modname pers_sig pm in
+  (ps, pm)
+
+let find_pers_struct penv val_of_pers_sig short_path_comps check name =
+  let {persistent_structures; _} = penv in
+  if name = "*predef*" then raise Not_found;
+  match Hashtbl.find persistent_structures name with
+  | Found (ps, pm) -> (ps, pm)
+  | Missing -> raise Not_found
+  | exception Not_found ->
+    match can_load_cmis penv with
+    | Cannot_load_cmis _ -> raise Not_found
+    | Can_load_cmis ->
+        let psig =
+          match !Persistent_signature.load ~unit_name:name with
+          | Some psig -> psig
+          | None ->
+            Hashtbl.add persistent_structures name Missing;
+            raise Not_found
+        in
+        add_import penv name;
+        let pm = val_of_pers_sig psig in
+        let ps = acknowledge_pers_struct penv short_path_comps check name psig pm in
+        (ps, pm)
+
+(* Emits a warning if there is no valid cmi for name *)
+let check_pers_struct penv f1 f2 ~loc name =
+  try
+    ignore (find_pers_struct penv f1 f2 false name)
+  with
+  | Not_found ->
+      let warn = Warnings.No_cmi_file(name, None) in
+        Location.prerr_warning loc warn
+  | Magic_numbers.Cmi.Error err ->
+      let msg = Format.asprintf "%a" Magic_numbers.Cmi.report_error err in
+      let warn = Warnings.No_cmi_file(name, Some msg) in
+        Location.prerr_warning loc warn
+  | Error err ->
+      let msg =
+        match err with
+        | Illegal_renaming(name, ps_name, filename) ->
+            Format.asprintf
+              " %a@ contains the compiled interface for @ \
+               %s when %s was expected"
+              Location.print_filename filename ps_name name
+        | Inconsistent_import _ -> assert false
+        | Need_recursive_types name ->
+            Format.sprintf
+              "%s uses recursive types"
+              name
+        | Depend_on_unsafe_string_unit name ->
+            Printf.sprintf "%s uses -unsafe-string"
+              name
+      in
+      let warn = Warnings.No_cmi_file(name, Some msg) in
+        Location.prerr_warning loc warn
+
+let read penv f1 f2 modname filename =
+  snd (read_pers_struct penv f1 f2 true modname filename)
+
+let find penv f1 f2 name =
+  snd (find_pers_struct penv f1 f2 true name)
+
+let check penv f1 f2 ~loc name =
+  let {persistent_structures; _} = penv in
+  if not (Hashtbl.mem persistent_structures name) then begin
+    (* PR#6843: record the weak dependency ([add_import]) regardless of
+       whether the check succeeds, to help make builds more
+       deterministic. *)
+    add_import penv name;
+    if (Warnings.is_active (Warnings.No_cmi_file("", None))) then
+      !add_delayed_check_forward
+        (fun () -> check_pers_struct penv f1 f2 ~loc name)
+  end
+
+let crc_of_unit penv f1 f2 name =
+  let (ps, _pm) = find_pers_struct penv f1 f2 true name in
+  let crco =
+    try
+      List.assoc name ps.ps_crcs
+    with Not_found ->
+      assert false
+  in
+    match crco with
+      None -> assert false
+    | Some crc -> crc
+
+let imports {imported_units; crc_units; _} =
+  Consistbl.extract (String.Set.elements !imported_units) crc_units
+
+let looked_up {persistent_structures; _} modname =
+  Hashtbl.mem persistent_structures modname
+
+let is_imported {imported_units; _} s =
+  String.Set.mem s !imported_units
+
+let is_imported_opaque {imported_opaque_units; _} s =
+  String.Set.mem s !imported_opaque_units
+
+let make_cmi penv modname sign alerts =
+  let flags =
+    List.concat [
+      if !Clflags.recursive_types then [Cmi_format.Rectypes] else [];
+      if !Clflags.opaque then [Cmi_format.Opaque] else [];
+      (if !Clflags.unsafe_string then [Cmi_format.Unsafe_string] else []);
+      [Alerts alerts];
+    ]
+  in
+  let crcs = imports penv in
+  {
+    cmi_name = modname;
+    cmi_sign = sign;
+    cmi_crcs = crcs;
+    cmi_flags = flags
+  }
+
+let save_cmi penv psig pm =
+  let { Persistent_signature.filename; cmi } = psig in
+  Misc.try_finally (fun () ->
+      let {
+        cmi_name = modname;
+        cmi_sign = _;
+        cmi_crcs = imports;
+        cmi_flags = flags;
+      } = cmi in
+      let crc =
+        output_to_file_via_temporary (* see MPR#7472, MPR#4991 *)
+          ~mode: [Open_binary] filename
+          (fun temp_filename oc -> output_cmi temp_filename oc cmi) in
+      (* Enter signature in persistent table so that imports()
+         will also return its crc *)
+      let ps =
+        { ps_name = modname;
+          ps_crcs = (cmi.cmi_name, Some crc) :: imports;
+          ps_filename = filename;
+          ps_flags = flags;
+        } in
+      save_pers_struct penv crc ps pm
+    )
+    ~exceptionally:(fun () -> remove_file filename)
+
+let report_error ppf =
+  let open Format in
+  function
+  | Illegal_renaming(modname, ps_name, filename) -> fprintf ppf
+      "Wrong file naming: %a@ contains the compiled interface for@ \
+       %s when %s was expected"
+      Location.print_filename filename ps_name modname
+  | Inconsistent_import(name, source1, source2) -> fprintf ppf
+      "@[<hov>The files %a@ and %a@ \
+              make inconsistent assumptions@ over interface %s@]"
+      Location.print_filename source1 Location.print_filename source2 name
+  | Need_recursive_types(import) ->
+      fprintf ppf
+        "@[<hov>Invalid import of %s, which uses recursive types.@ %s@]"
+        import "The compilation flag -rectypes is required"
+  | Depend_on_unsafe_string_unit(import) ->
+      fprintf ppf
+        "@[<hov>Invalid import of %s, compiled with -unsafe-string.@ %s@]"
+        import "This compiler has been configured in strict \
+                                  safe-string mode (-force-safe-string)"
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err ->
+          Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )
+
+(* helper for merlin *)
+
+let with_cmis penv f x =
+  Misc.(protect_refs
+          [R (penv.can_load_cmis, Can_load_cmis)]
+          (fun () -> f x))
+
+let forall ~found ~missing t =
+  Std.Hashtbl.forall t.persistent_structures (fun name -> function
+      | Missing -> missing name
+      | Found (pers_struct, a) ->
+        found name pers_struct.ps_filename pers_struct.ps_name a
+    )
diff --git a/src/ocaml/typing/persistent_env.mli b/src/ocaml/typing/persistent_env.mli
new file mode 100644
index 0000000..60506f4
--- /dev/null
+++ b/src/ocaml/typing/persistent_env.mli
@@ -0,0 +1,120 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Xavier Leroy, projet Gallium, INRIA Rocquencourt                     *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*                                                                        *)
+(*   Copyright 2019 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Misc
+
+module Consistbl : module type of struct
+  include Consistbl.Make (Misc.String)
+end
+
+type error =
+  | Illegal_renaming of modname * modname * filepath
+  | Inconsistent_import of modname * filepath * filepath
+  | Need_recursive_types of modname
+  | Depend_on_unsafe_string_unit of modname
+
+exception Error of error
+
+val report_error: Format.formatter -> error -> unit
+
+module Persistent_signature : sig
+  type t =
+    { filename : string; (** Name of the file containing the signature. *)
+      cmi : Cmi_format.cmi_infos }
+
+  (** Function used to load a persistent signature. The default is to look for
+      the .cmi file in the load path. This function can be overridden to load
+      it from memory, for instance to build a self-contained toplevel. *)
+  val load : (unit_name:string -> t option) ref
+end
+
+type can_load_cmis =
+  | Can_load_cmis
+  | Cannot_load_cmis of Lazy_backtrack.log
+
+type 'a t
+
+val empty : unit -> 'a t
+
+val short_paths_basis : 'a t -> Short_paths.Basis.t
+
+val clear : 'a t -> unit
+val clear_missing : 'a t -> unit
+
+val fold : 'a t -> (modname -> 'a -> 'b -> 'b) -> 'b -> 'b
+
+val read : 'a t -> (Persistent_signature.t -> 'a)
+  -> (string -> 'a -> Short_paths.Desc.Module.components Lazy.t)
+  -> modname -> filepath -> 'a
+val find : 'a t -> (Persistent_signature.t -> 'a)
+  -> (string -> 'a -> Short_paths.Desc.Module.components Lazy.t)
+  -> modname -> 'a
+
+val find_in_cache : 'a t -> modname -> 'a option
+
+val check : 'a t -> (Persistent_signature.t -> 'a)
+  -> (string -> 'a -> Short_paths.Desc.Module.components Lazy.t)
+  -> loc:Location.t -> modname -> unit
+
+(* [looked_up penv md] checks if one has already tried
+   to read the signature for [md] in the environment
+   [penv] (it may have failed) *)
+val looked_up : 'a t -> modname -> bool
+
+(* [is_imported penv md] checks if [md] has been successfully
+   imported in the environment [penv] *)
+val is_imported : 'a t -> modname -> bool
+
+(* [is_imported_opaque penv md] checks if [md] has been imported
+   in [penv] as an opaque module *)
+val is_imported_opaque : 'a t -> modname -> bool
+
+(* [register_import_as_opaque penv md] registers [md] in [penv] as an
+   opaque module *)
+val register_import_as_opaque : 'a t -> modname -> unit
+
+val make_cmi : 'a t -> modname -> Types.signature -> alerts
+  -> Cmi_format.cmi_infos
+
+val save_cmi : 'a t -> Persistent_signature.t -> 'a -> unit
+
+val can_load_cmis : 'a t -> can_load_cmis
+val set_can_load_cmis : 'a t -> can_load_cmis -> unit
+val without_cmis : 'a t -> ('b -> 'c) -> 'b -> 'c
+(* [without_cmis penv f arg] applies [f] to [arg], but does not
+    allow [penv] to openi cmis during its execution *)
+
+(* may raise Consistbl.Inconsistency *)
+val import_crcs : 'a t -> source:filepath -> crcs -> unit
+
+(* Return the set of compilation units imported, with their CRC *)
+val imports : 'a t -> crcs
+
+(* Return the CRC of the interface of the given compilation unit *)
+val crc_of_unit: 'a t -> (Persistent_signature.t -> 'a)
+  -> (string -> 'a -> Short_paths.Desc.Module.components Lazy.t)
+  -> modname -> Digest.t
+
+(* Forward declaration to break mutual recursion with Typecore. *)
+val add_delayed_check_forward: ((unit -> unit) -> unit) ref
+
+(* helper for merlin *)
+val with_cmis : 'a t -> ('b -> 'c) -> 'b -> 'c
+
+val forall :
+  found:(modname -> filepath -> string -> 'a -> bool) ->
+  missing:(modname -> bool) ->
+  'a t -> bool
diff --git a/src/ocaml/typing/predef.ml b/src/ocaml/typing/predef.ml
new file mode 100644
index 0000000..671df81
--- /dev/null
+++ b/src/ocaml/typing/predef.ml
@@ -0,0 +1,253 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Predefined type constructors (with special typing rules in typecore) *)
+
+open Path
+open Types
+open Btype
+
+let builtin_idents = ref []
+
+let wrap create s =
+  let id = create s in
+  builtin_idents := (s, id) :: !builtin_idents;
+  id
+
+let ident_create = wrap Ident.create_predef
+
+let ident_int = ident_create "int"
+and ident_char = ident_create "char"
+and ident_bytes = ident_create "bytes"
+and ident_float = ident_create "float"
+and ident_bool = ident_create "bool"
+and ident_unit = ident_create "unit"
+and ident_exn = ident_create "exn"
+and ident_array = ident_create "array"
+and ident_list = ident_create "list"
+and ident_option = ident_create "option"
+and ident_nativeint = ident_create "nativeint"
+and ident_int32 = ident_create "int32"
+and ident_int64 = ident_create "int64"
+and ident_lazy_t = ident_create "lazy_t"
+and ident_string = ident_create "string"
+and ident_extension_constructor = ident_create "extension_constructor"
+and ident_floatarray = ident_create "floatarray"
+
+let path_int = Pident ident_int
+and path_char = Pident ident_char
+and path_bytes = Pident ident_bytes
+and path_float = Pident ident_float
+and path_bool = Pident ident_bool
+and path_unit = Pident ident_unit
+and path_exn = Pident ident_exn
+and path_array = Pident ident_array
+and path_list = Pident ident_list
+and path_option = Pident ident_option
+and path_nativeint = Pident ident_nativeint
+and path_int32 = Pident ident_int32
+and path_int64 = Pident ident_int64
+and path_lazy_t = Pident ident_lazy_t
+and path_string = Pident ident_string
+and path_extension_constructor = Pident ident_extension_constructor
+and path_floatarray = Pident ident_floatarray
+
+let type_int = newgenty (Tconstr(path_int, [], ref Mnil))
+and type_char = newgenty (Tconstr(path_char, [], ref Mnil))
+and type_bytes = newgenty (Tconstr(path_bytes, [], ref Mnil))
+and type_float = newgenty (Tconstr(path_float, [], ref Mnil))
+and type_bool = newgenty (Tconstr(path_bool, [], ref Mnil))
+and type_unit = newgenty (Tconstr(path_unit, [], ref Mnil))
+and type_exn = newgenty (Tconstr(path_exn, [], ref Mnil))
+and type_array t = newgenty (Tconstr(path_array, [t], ref Mnil))
+and type_list t = newgenty (Tconstr(path_list, [t], ref Mnil))
+and type_option t = newgenty (Tconstr(path_option, [t], ref Mnil))
+and type_nativeint = newgenty (Tconstr(path_nativeint, [], ref Mnil))
+and type_int32 = newgenty (Tconstr(path_int32, [], ref Mnil))
+and type_int64 = newgenty (Tconstr(path_int64, [], ref Mnil))
+and type_lazy_t t = newgenty (Tconstr(path_lazy_t, [t], ref Mnil))
+and type_string = newgenty (Tconstr(path_string, [], ref Mnil))
+and type_extension_constructor =
+      newgenty (Tconstr(path_extension_constructor, [], ref Mnil))
+and type_floatarray = newgenty (Tconstr(path_floatarray, [], ref Mnil))
+
+let ident_match_failure = ident_create "Match_failure"
+and ident_out_of_memory = ident_create "Out_of_memory"
+and ident_invalid_argument = ident_create "Invalid_argument"
+and ident_failure = ident_create "Failure"
+and ident_not_found = ident_create "Not_found"
+and ident_sys_error = ident_create "Sys_error"
+and ident_end_of_file = ident_create "End_of_file"
+and ident_division_by_zero = ident_create "Division_by_zero"
+and ident_stack_overflow = ident_create "Stack_overflow"
+and ident_sys_blocked_io = ident_create "Sys_blocked_io"
+and ident_assert_failure = ident_create "Assert_failure"
+and ident_undefined_recursive_module =
+        ident_create "Undefined_recursive_module"
+
+let all_predef_exns = [
+  ident_match_failure;
+  ident_out_of_memory;
+  ident_invalid_argument;
+  ident_failure;
+  ident_not_found;
+  ident_sys_error;
+  ident_end_of_file;
+  ident_division_by_zero;
+  ident_stack_overflow;
+  ident_sys_blocked_io;
+  ident_assert_failure;
+  ident_undefined_recursive_module;
+]
+
+let path_match_failure = Pident ident_match_failure
+and path_assert_failure = Pident ident_assert_failure
+and path_undefined_recursive_module = Pident ident_undefined_recursive_module
+
+let cstr id args =
+  {
+    cd_id = id;
+    cd_args = Cstr_tuple args;
+    cd_res = None;
+    cd_loc = Location.none;
+    cd_attributes = [];
+    cd_uid = Uid.of_predef_id id;
+  }
+
+let ident_false = ident_create "false"
+and ident_true = ident_create "true"
+and ident_void = ident_create "()"
+and ident_nil = ident_create "[]"
+and ident_cons = ident_create "::"
+and ident_none = ident_create "None"
+and ident_some = ident_create "Some"
+
+let mk_add_type add_type type_ident
+      ?manifest ?(immediate=Type_immediacy.Unknown) ?(kind=Type_abstract) env =
+  let decl =
+    {type_params = [];
+     type_arity = 0;
+     type_kind = kind;
+     type_loc = Location.none;
+     type_private = Asttypes.Public;
+     type_manifest = manifest;
+     type_variance = [];
+     type_separability = [];
+     type_is_newtype = false;
+     type_expansion_scope = lowest_level;
+     type_attributes = [];
+     type_immediate = immediate;
+     type_unboxed_default = false;
+     type_uid = Uid.of_predef_id type_ident;
+    }
+  in
+  add_type type_ident decl env
+
+let common_initial_env add_type add_extension empty_env =
+  let add_type = mk_add_type add_type
+  and add_type1 type_ident
+      ~variance ~separability ?(kind=fun _ -> Type_abstract) env =
+    let param = newgenvar () in
+    let decl =
+      {type_params = [param];
+       type_arity = 1;
+       type_kind = kind param;
+       type_loc = Location.none;
+       type_private = Asttypes.Public;
+       type_manifest = None;
+       type_variance = [variance];
+       type_separability = [separability];
+       type_is_newtype = false;
+       type_expansion_scope = lowest_level;
+       type_attributes = [];
+       type_immediate = Unknown;
+       type_unboxed_default = false;
+       type_uid = Uid.of_predef_id type_ident;
+      }
+    in
+    add_type type_ident decl env
+  in
+  let add_extension id l =
+    add_extension id
+      { ext_type_path = path_exn;
+        ext_type_params = [];
+        ext_args = Cstr_tuple l;
+        ext_ret_type = None;
+        ext_private = Asttypes.Public;
+        ext_loc = Location.none;
+        ext_attributes = [Ast_helper.Attr.mk
+                            (Location.mknoloc "ocaml.warn_on_literal_pattern")
+                            (Parsetree.PStr [])];
+        ext_uid = Uid.of_predef_id id;
+      }
+  in
+  add_extension ident_match_failure
+                         [newgenty (Ttuple[type_string; type_int; type_int])] (
+  add_extension ident_out_of_memory [] (
+  add_extension ident_stack_overflow [] (
+  add_extension ident_invalid_argument [type_string] (
+  add_extension ident_failure [type_string] (
+  add_extension ident_not_found [] (
+  add_extension ident_sys_blocked_io [] (
+  add_extension ident_sys_error [type_string] (
+  add_extension ident_end_of_file [] (
+  add_extension ident_division_by_zero [] (
+  add_extension ident_assert_failure
+                         [newgenty (Ttuple[type_string; type_int; type_int])] (
+  add_extension ident_undefined_recursive_module
+                         [newgenty (Ttuple[type_string; type_int; type_int])] (
+  add_type ident_int64 (
+  add_type ident_int32 (
+  add_type ident_nativeint (
+  add_type1 ident_lazy_t ~variance:Variance.covariant
+    ~separability:Separability.Ind (
+  add_type1 ident_option ~variance:Variance.covariant
+    ~separability:Separability.Ind
+    ~kind:(fun tvar ->
+      Type_variant([cstr ident_none []; cstr ident_some [tvar]],
+                   Variant_regular)
+    ) (
+  add_type1 ident_list ~variance:Variance.covariant
+    ~separability:Separability.Ind
+    ~kind:(fun tvar ->
+      Type_variant([cstr ident_nil []; cstr ident_cons [tvar; type_list tvar]],
+                   Variant_regular)
+    ) (
+  add_type1 ident_array ~variance:Variance.full ~separability:Separability.Ind (
+  add_type ident_exn ~kind:Type_open (
+  add_type ident_unit ~immediate:Always
+    ~kind:(Type_variant([cstr ident_void []], Variant_regular)) (
+  add_type ident_bool ~immediate:Always
+    ~kind:(Type_variant([cstr ident_false []; cstr ident_true []],
+                        Variant_regular)) (
+  add_type ident_float (
+  add_type ident_string (
+  add_type ident_char ~immediate:Always (
+  add_type ident_int ~immediate:Always (
+  add_type ident_extension_constructor (
+  add_type ident_floatarray (
+    empty_env))))))))))))))))))))))))))))
+
+let build_initial_env add_type add_exception empty_env =
+  let common = common_initial_env add_type add_exception empty_env in
+  let add_type = mk_add_type add_type in
+  let safe_string = add_type ident_bytes common in
+  let unsafe_string = add_type ident_bytes ~manifest:type_string common in
+  (safe_string, unsafe_string)
+
+let builtin_values =
+  List.map (fun id -> (Ident.name id, id)) all_predef_exns
+
+let builtin_idents = List.rev !builtin_idents
diff --git a/src/ocaml/typing/predef.mli b/src/ocaml/typing/predef.mli
new file mode 100644
index 0000000..1edbb63
--- /dev/null
+++ b/src/ocaml/typing/predef.mli
@@ -0,0 +1,89 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Predefined type constructors (with special typing rules in typecore) *)
+
+open Types
+
+val ident_bytes: Ident.t
+
+val type_int: type_expr
+val type_char: type_expr
+val type_string: type_expr
+val type_bytes: type_expr
+val type_float: type_expr
+val type_bool: type_expr
+val type_unit: type_expr
+val type_exn: type_expr
+val type_array: type_expr -> type_expr
+val type_list: type_expr -> type_expr
+val type_option: type_expr -> type_expr
+val type_nativeint: type_expr
+val type_int32: type_expr
+val type_int64: type_expr
+val type_lazy_t: type_expr -> type_expr
+val type_extension_constructor:type_expr
+val type_floatarray:type_expr
+
+val path_int: Path.t
+val path_char: Path.t
+val path_string: Path.t
+val path_bytes: Path.t
+val path_float: Path.t
+val path_bool: Path.t
+val path_unit: Path.t
+val path_exn: Path.t
+val path_array: Path.t
+val path_list: Path.t
+val path_option: Path.t
+val path_nativeint: Path.t
+val path_int32: Path.t
+val path_int64: Path.t
+val path_lazy_t: Path.t
+val path_extension_constructor: Path.t
+val path_floatarray: Path.t
+
+val path_match_failure: Path.t
+val path_assert_failure : Path.t
+val path_undefined_recursive_module : Path.t
+
+val ident_false : Ident.t
+val ident_true : Ident.t
+val ident_void : Ident.t
+val ident_nil : Ident.t
+val ident_cons : Ident.t
+val ident_none : Ident.t
+val ident_some : Ident.t
+
+(* To build the initial environment. Since there is a nasty mutual
+   recursion between predef and env, we break it by parameterizing
+   over Env.t, Env.add_type and Env.add_extension. *)
+
+val build_initial_env:
+  (Ident.t -> type_declaration -> 'a -> 'a) ->
+  (Ident.t -> extension_constructor -> 'a -> 'a) ->
+  'a -> 'a * 'a
+
+(* To initialize linker tables *)
+
+val builtin_values: (string * Ident.t) list
+val builtin_idents: (string * Ident.t) list
+
+(** All predefined exceptions, exposed as [Ident.t] for flambda (for
+    building value approximations).
+    The [Ident.t] for division by zero is also exported explicitly
+    so flambda can generate code to raise it. *)
+val ident_division_by_zero: Ident.t
+val all_predef_exns : Ident.t list
diff --git a/src/ocaml/typing/primitive.ml b/src/ocaml/typing/primitive.ml
new file mode 100644
index 0000000..bf4fe83
--- /dev/null
+++ b/src/ocaml/typing/primitive.ml
@@ -0,0 +1,251 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Description of primitive functions *)
+
+open Misc
+open Parsetree
+
+type boxed_integer = Pnativeint | Pint32 | Pint64
+
+type native_repr =
+  | Same_as_ocaml_repr
+  | Unboxed_float
+  | Unboxed_integer of boxed_integer
+  | Untagged_int
+
+type description =
+  { prim_name: string;         (* Name of primitive  or C function *)
+    prim_arity: int;           (* Number of arguments *)
+    prim_alloc: bool;          (* Does it allocates or raise? *)
+    prim_native_name: string;  (* Name of C function for the nat. code gen. *)
+    prim_native_repr_args: native_repr list;
+    prim_native_repr_res: native_repr }
+
+type error =
+  | Old_style_float_with_native_repr_attribute
+  | Old_style_noalloc_with_noalloc_attribute
+  | No_native_primitive_with_repr_attribute
+
+exception Error of Location.t * error
+
+let is_ocaml_repr = function
+  | Same_as_ocaml_repr -> true
+  | Unboxed_float
+  | Unboxed_integer _
+  | Untagged_int -> false
+
+let is_unboxed = function
+  | Same_as_ocaml_repr
+  | Untagged_int -> false
+  | Unboxed_float
+  | Unboxed_integer _ -> true
+
+let is_untagged = function
+  | Untagged_int -> true
+  | Same_as_ocaml_repr
+  | Unboxed_float
+  | Unboxed_integer _ -> false
+
+let rec make_native_repr_args arity x =
+  if arity = 0 then
+    []
+  else
+    x :: make_native_repr_args (arity - 1) x
+
+let simple ~name ~arity ~alloc =
+  {prim_name = name;
+   prim_arity = arity;
+   prim_alloc = alloc;
+   prim_native_name = "";
+   prim_native_repr_args = make_native_repr_args arity Same_as_ocaml_repr;
+   prim_native_repr_res = Same_as_ocaml_repr}
+
+let make ~name ~alloc ~native_name ~native_repr_args ~native_repr_res =
+  {prim_name = name;
+   prim_arity = List.length native_repr_args;
+   prim_alloc = alloc;
+   prim_native_name = native_name;
+   prim_native_repr_args = native_repr_args;
+   prim_native_repr_res = native_repr_res}
+
+let parse_declaration valdecl ~native_repr_args ~native_repr_res =
+  let arity = List.length native_repr_args in
+  let name, native_name, old_style_noalloc, old_style_float =
+    match valdecl.pval_prim with
+    | name :: "noalloc" :: name2 :: "float" :: _ -> (name, name2, true, true)
+    | name :: "noalloc" :: name2 :: _ -> (name, name2, true, false)
+    | name :: name2 :: "float" :: _ -> (name, name2, false, true)
+    | name :: "noalloc" :: _ -> (name, "", true, false)
+    | name :: name2 :: _ -> (name, name2, false, false)
+    | name :: _ -> (name, "", false, false)
+    | [] ->
+        fatal_error "Primitive.parse_declaration"
+  in
+  let noalloc_attribute =
+    Attr_helper.has_no_payload_attribute ["noalloc"; "ocaml.noalloc"]
+      valdecl.pval_attributes
+  in
+  if old_style_float &&
+     not (List.for_all is_ocaml_repr native_repr_args &&
+          is_ocaml_repr native_repr_res) then
+    raise (Error (valdecl.pval_loc,
+                  Old_style_float_with_native_repr_attribute));
+  if old_style_noalloc && noalloc_attribute then
+    raise (Error (valdecl.pval_loc,
+                  Old_style_noalloc_with_noalloc_attribute));
+  (* The compiler used to assume "noalloc" with "float", we just make this
+     explicit now (GPR#167): *)
+  let old_style_noalloc = old_style_noalloc || old_style_float in
+  if old_style_float then
+    Location.deprecated valdecl.pval_loc
+      "[@@unboxed] + [@@noalloc] should be used\n\
+       instead of \"float\""
+  else if old_style_noalloc then
+    Location.deprecated valdecl.pval_loc
+      "[@@noalloc] should be used instead of \"noalloc\"";
+  if native_name = "" &&
+     not (List.for_all is_ocaml_repr native_repr_args &&
+          is_ocaml_repr native_repr_res) then
+    raise (Error (valdecl.pval_loc,
+                  No_native_primitive_with_repr_attribute));
+  let noalloc = old_style_noalloc || noalloc_attribute in
+  let native_repr_args, native_repr_res =
+    if old_style_float then
+      (make_native_repr_args arity Unboxed_float, Unboxed_float)
+    else
+      (native_repr_args, native_repr_res)
+  in
+  {prim_name = name;
+   prim_arity = arity;
+   prim_alloc = not noalloc;
+   prim_native_name = native_name;
+   prim_native_repr_args = native_repr_args;
+   prim_native_repr_res = native_repr_res}
+
+open Outcometree
+
+let rec add_native_repr_attributes ty attrs =
+  match ty, attrs with
+  | Otyp_arrow (label, a, b), attr_opt :: rest ->
+    let b = add_native_repr_attributes b rest in
+    let a =
+      match attr_opt with
+      | None -> a
+      | Some attr -> Otyp_attribute (a, attr)
+    in
+    Otyp_arrow (label, a, b)
+  | _, [Some attr] -> Otyp_attribute (ty, attr)
+  | _ ->
+    assert (List.for_all (fun x -> x = None) attrs);
+    ty
+
+let oattr_unboxed = { oattr_name = "unboxed" }
+let oattr_untagged = { oattr_name = "untagged" }
+let oattr_noalloc = { oattr_name = "noalloc" }
+
+let print p osig_val_decl =
+  let prims =
+    if p.prim_native_name <> "" then
+      [p.prim_name; p.prim_native_name]
+    else
+      [p.prim_name]
+  in
+  let for_all f =
+    List.for_all f p.prim_native_repr_args && f p.prim_native_repr_res
+  in
+  let all_unboxed = for_all is_unboxed in
+  let all_untagged = for_all is_untagged in
+  let attrs = if p.prim_alloc then [] else [oattr_noalloc] in
+  let attrs =
+    if all_unboxed then
+      oattr_unboxed :: attrs
+    else if all_untagged then
+      oattr_untagged :: attrs
+    else
+      attrs
+  in
+  let attr_of_native_repr = function
+    | Same_as_ocaml_repr -> None
+    | Unboxed_float
+    | Unboxed_integer _ -> if all_unboxed then None else Some oattr_unboxed
+    | Untagged_int -> if all_untagged then None else Some oattr_untagged
+  in
+  let type_attrs =
+    List.map attr_of_native_repr p.prim_native_repr_args @
+    [attr_of_native_repr p.prim_native_repr_res]
+  in
+  { osig_val_decl with
+    oval_prims = prims;
+    oval_type = add_native_repr_attributes osig_val_decl.oval_type type_attrs;
+    oval_attributes = attrs }
+
+let native_name p =
+  if p.prim_native_name <> ""
+  then p.prim_native_name
+  else p.prim_name
+
+let byte_name p =
+  p.prim_name
+
+let equal_boxed_integer bi1 bi2 =
+  match bi1, bi2 with
+  | Pnativeint, Pnativeint
+  | Pint32, Pint32
+  | Pint64, Pint64 ->
+    true
+  | (Pnativeint | Pint32 | Pint64), _ ->
+    false
+
+let equal_native_repr nr1 nr2 =
+  match nr1, nr2 with
+  | Same_as_ocaml_repr, Same_as_ocaml_repr -> true
+  | Same_as_ocaml_repr,
+    (Unboxed_float | Unboxed_integer _ | Untagged_int) -> false
+  | Unboxed_float, Unboxed_float -> true
+  | Unboxed_float,
+    (Same_as_ocaml_repr | Unboxed_integer _ | Untagged_int) -> false
+  | Unboxed_integer bi1, Unboxed_integer bi2 -> equal_boxed_integer bi1 bi2
+  | Unboxed_integer _,
+    (Same_as_ocaml_repr | Unboxed_float | Untagged_int) -> false
+  | Untagged_int, Untagged_int -> true
+  | Untagged_int,
+    (Same_as_ocaml_repr | Unboxed_float | Unboxed_integer _) -> false
+
+let native_name_is_external p =
+  let nat_name = native_name p in
+  nat_name <> "" && nat_name.[0] <> '%'
+
+let report_error ppf err =
+  match err with
+  | Old_style_float_with_native_repr_attribute ->
+    Format.fprintf ppf "Cannot use \"float\" in conjunction with \
+                        [%@unboxed]/[%@untagged]."
+  | Old_style_noalloc_with_noalloc_attribute ->
+    Format.fprintf ppf "Cannot use \"noalloc\" in conjunction with \
+                        [%@%@noalloc]."
+  | No_native_primitive_with_repr_attribute ->
+    Format.fprintf ppf
+      "[@The native code version of the primitive is mandatory@ \
+       when attributes [%@untagged] or [%@unboxed] are present.@]"
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, err) ->
+        Some (Location.error_of_printer ~loc report_error err)
+      | _ ->
+        None
+    )
diff --git a/src/ocaml/typing/primitive.mli b/src/ocaml/typing/primitive.mli
new file mode 100644
index 0000000..e8376ad
--- /dev/null
+++ b/src/ocaml/typing/primitive.mli
@@ -0,0 +1,79 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Description of primitive functions *)
+
+type boxed_integer = Pnativeint | Pint32 | Pint64
+
+(* Representation of arguments/result for the native code version
+   of a primitive *)
+type native_repr =
+  | Same_as_ocaml_repr
+  | Unboxed_float
+  | Unboxed_integer of boxed_integer
+  | Untagged_int
+
+type description = private
+  { prim_name: string;         (* Name of primitive  or C function *)
+    prim_arity: int;           (* Number of arguments *)
+    prim_alloc: bool;          (* Does it allocates or raise? *)
+    prim_native_name: string;  (* Name of C function for the nat. code gen. *)
+    prim_native_repr_args: native_repr list;
+    prim_native_repr_res: native_repr }
+
+(* Invariant [List.length d.prim_native_repr_args = d.prim_arity] *)
+
+val simple
+  :  name:string
+  -> arity:int
+  -> alloc:bool
+  -> description
+
+val make
+  :  name:string
+  -> alloc:bool
+  -> native_name:string
+  -> native_repr_args: native_repr list
+  -> native_repr_res: native_repr
+  -> description
+
+val parse_declaration
+  :  Parsetree.value_description
+  -> native_repr_args:native_repr list
+  -> native_repr_res:native_repr
+  -> description
+
+val print
+  :  description
+  -> Outcometree.out_val_decl
+  -> Outcometree.out_val_decl
+
+val native_name: description -> string
+val byte_name: description -> string
+
+val equal_boxed_integer : boxed_integer -> boxed_integer -> bool
+val equal_native_repr : native_repr -> native_repr -> bool
+
+(** [native_name_is_externa] returns [true] iff the [native_name] for the
+    given primitive identifies that the primitive is not implemented in the
+    compiler itself. *)
+val native_name_is_external : description -> bool
+
+type error =
+  | Old_style_float_with_native_repr_attribute
+  | Old_style_noalloc_with_noalloc_attribute
+  | No_native_primitive_with_repr_attribute
+
+exception Error of Location.t * error
diff --git a/src/ocaml/typing/printpat.ml b/src/ocaml/typing/printpat.ml
new file mode 100644
index 0000000..64094b6
--- /dev/null
+++ b/src/ocaml/typing/printpat.ml
@@ -0,0 +1,169 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Values as patterns pretty printer *)
+
+open Asttypes
+open Typedtree
+open Types
+open Format
+
+let is_cons = function
+| {cstr_name = "::"} -> true
+| _ -> false
+
+let pretty_const c = match c with
+| Const_int i -> Printf.sprintf "%d" i
+| Const_char c -> Printf.sprintf "%C" c
+| Const_string (s, _, _) -> Printf.sprintf "%S" s
+| Const_float f -> Printf.sprintf "%s" f
+| Const_int32 i -> Printf.sprintf "%ldl" i
+| Const_int64 i -> Printf.sprintf "%LdL" i
+| Const_nativeint i -> Printf.sprintf "%ndn" i
+
+let pretty_extra ppf (cstr, _loc, _attrs) pretty_rest rest =
+  match cstr with
+  | Tpat_unpack ->
+     fprintf ppf "@[(module %a)@]" pretty_rest rest
+  | Tpat_constraint _ ->
+     fprintf ppf "@[(%a : _)@]" pretty_rest rest
+  | Tpat_type _ ->
+     fprintf ppf "@[(# %a)@]" pretty_rest rest
+  | Tpat_open _ ->
+     fprintf ppf "@[(# %a)@]" pretty_rest rest
+
+let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v ->
+  match v.pat_extra with
+    | extra :: rem ->
+       pretty_extra ppf extra
+         pretty_val { v with pat_extra = rem }
+    | [] ->
+  match v.pat_desc with
+  | Tpat_any -> fprintf ppf "_"
+  | Tpat_var (x,_) -> fprintf ppf "%s" (Ident.name x)
+  | Tpat_constant c -> fprintf ppf "%s" (pretty_const c)
+  | Tpat_tuple vs ->
+      fprintf ppf "@[(%a)@]" (pretty_vals ",") vs
+  | Tpat_construct (_, cstr, [], _) ->
+      fprintf ppf "%s" cstr.cstr_name
+  | Tpat_construct (_, cstr, [w], None) ->
+      fprintf ppf "@[<2>%s@ %a@]" cstr.cstr_name pretty_arg w
+  | Tpat_construct (_, cstr, vs, vto) ->
+      let name = cstr.cstr_name in
+      begin match (name, vs, vto) with
+        ("::", [v1;v2], None) ->
+          fprintf ppf "@[%a::@,%a@]" pretty_car v1 pretty_cdr v2
+      | (_, _, None) ->
+          fprintf ppf "@[<2>%s@ @[(%a)@]@]" name (pretty_vals ",") vs
+      | (_, _, Some ([], _t)) ->
+          fprintf ppf "@[<2>%s@ @[(%a : _)@]@]" name (pretty_vals ",") vs
+      | (_, _, Some (vl, _t)) ->
+          let vars = List.map (fun x -> Ident.name x.txt) vl in
+          fprintf ppf "@[<2>%s@ (type %s)@ @[(%a : _)@]@]"
+            name (String.concat " " vars) (pretty_vals ",") vs
+      end
+  | Tpat_variant (l, None, _) ->
+      fprintf ppf "`%s" l
+  | Tpat_variant (l, Some w, _) ->
+      fprintf ppf "@[<2>`%s@ %a@]" l pretty_arg w
+  | Tpat_record (lvs,_) ->
+      let filtered_lvs = List.filter
+          (function
+            | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
+            | _ -> true) lvs in
+      begin match filtered_lvs with
+      | [] -> fprintf ppf "_"
+      | (_, lbl, _) :: q ->
+          let elision_mark ppf =
+            (* we assume that there is no label repetitions here *)
+             if Array.length lbl.lbl_all > 1 + List.length q then
+               fprintf ppf ";@ _@ "
+             else () in
+          fprintf ppf "@[{%a%t}@]"
+            pretty_lvals filtered_lvs elision_mark
+      end
+  | Tpat_array vs ->
+      fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
+  | Tpat_lazy v ->
+      fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v
+  | Tpat_alias (v, x,_) ->
+      fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x
+  | Tpat_value v ->
+      fprintf ppf "%a" pretty_val (v :> pattern)
+  | Tpat_exception v ->
+      fprintf ppf "@[<2>exception@ %a@]" pretty_arg v
+  | Tpat_or _ ->
+      fprintf ppf "@[(%a)@]" pretty_or v
+
+and pretty_car ppf v = match v.pat_desc with
+| Tpat_construct (_,cstr, [_ ; _], None)
+    when is_cons cstr ->
+      fprintf ppf "(%a)" pretty_val v
+| _ -> pretty_val ppf v
+
+and pretty_cdr ppf v = match v.pat_desc with
+| Tpat_construct (_,cstr, [v1 ; v2], None)
+    when is_cons cstr ->
+      fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2
+| _ -> pretty_val ppf v
+
+and pretty_arg ppf v = match v.pat_desc with
+| Tpat_construct (_,_,_::_,None)
+| Tpat_variant (_, Some _, _) -> fprintf ppf "(%a)" pretty_val v
+|  _ -> pretty_val ppf v
+
+and pretty_or : type k . _ -> k general_pattern -> _ = fun ppf v ->
+  match v.pat_desc with
+  | Tpat_or (v,w,_) ->
+      fprintf ppf "%a|@,%a" pretty_or v pretty_or w
+  | _ -> pretty_val ppf v
+
+and pretty_vals sep ppf = function
+  | [] -> ()
+  | [v] -> pretty_val ppf v
+  | v::vs ->
+      fprintf ppf "%a%s@ %a" pretty_val v sep (pretty_vals sep) vs
+
+and pretty_lvals ppf = function
+  | [] -> ()
+  | [_,lbl,v] ->
+      fprintf ppf "%s=%a" lbl.lbl_name pretty_val v
+  | (_, lbl,v)::rest ->
+      fprintf ppf "%s=%a;@ %a"
+        lbl.lbl_name pretty_val v pretty_lvals rest
+
+let top_pretty ppf v =
+  fprintf ppf "@[%a@]@?" pretty_val v
+
+let pretty_pat p =
+  top_pretty Format.str_formatter p ;
+  prerr_string (Format.flush_str_formatter ())
+
+type 'k matrix = 'k general_pattern list list
+
+let pretty_line fmt =
+  List.iter (fun p ->
+    Format.fprintf fmt " <";
+    top_pretty fmt p;
+    Format.fprintf fmt ">";
+  )
+
+let pretty_matrix fmt (pss : 'k matrix) =
+  Format.fprintf fmt "begin matrix\n" ;
+  List.iter (fun ps ->
+    pretty_line fmt ps ;
+    Format.fprintf fmt "\n"
+  ) pss;
+  Format.fprintf fmt "end matrix\n%!"
diff --git a/src/ocaml/typing/printpat.mli b/src/ocaml/typing/printpat.mli
new file mode 100644
index 0000000..1865a2a
--- /dev/null
+++ b/src/ocaml/typing/printpat.mli
@@ -0,0 +1,27 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+
+
+val pretty_const
+    : Asttypes.constant -> string
+val top_pretty
+    : Format.formatter -> 'k Typedtree.general_pattern -> unit
+val pretty_pat
+    : 'k Typedtree.general_pattern -> unit
+val pretty_line
+    : Format.formatter -> 'k Typedtree.general_pattern list -> unit
+val pretty_matrix
+    : Format.formatter -> 'k Typedtree.general_pattern list list -> unit
diff --git a/src/ocaml/typing/printtyp.ml b/src/ocaml/typing/printtyp.ml
new file mode 100644
index 0000000..74ccd5d
--- /dev/null
+++ b/src/ocaml/typing/printtyp.ml
@@ -0,0 +1,2263 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Printing functions *)
+
+module M = Misc.String.Map
+module S = Misc.String.Set
+
+open Misc
+open Ctype
+open Format
+open Longident
+open Path
+open Asttypes
+open Types
+open Btype
+open Outcometree
+
+(* Print a long identifier *)
+
+let rec longident ppf = function
+  | Lident s -> pp_print_string ppf s
+  | Ldot(p, s) -> fprintf ppf "%a.%s" longident p s
+  | Lapply(p1, p2) -> fprintf ppf "%a(%a)" longident p1 longident p2
+
+let () = Env.print_longident := longident
+
+(* Print an identifier avoiding name collisions *)
+
+module Out_name = struct
+  let create x = { printed_name = x }
+  let print x = x.printed_name
+  let set out_name x = out_name.printed_name <- x
+end
+
+(** Some identifiers may require hiding when printing *)
+type bound_ident = { hide:bool; ident:Ident.t }
+
+(* printing environment for path shortening and naming *)
+let printing_env = ref Env.empty
+
+(* When printing, it is important to only observe the
+   current printing environment, without reading any new
+   cmi present on the file system *)
+let in_printing_env f = Env.without_cmis f !printing_env
+
+let human_unique n id = Printf.sprintf "%s/%d" (Ident.name id) n
+
+type namespace =
+  | Type
+  | Module
+  | Module_type
+  | Class
+  | Class_type
+  | Other (** Other bypasses the unique name identifier mechanism *)
+
+module Namespace = struct
+
+  let id = function
+    | Type -> 0
+    | Module -> 1
+    | Module_type -> 2
+    | Class -> 3
+    | Class_type -> 4
+    | Other -> 5
+
+  let size = 1 + id Other
+
+  let show =
+    function
+    | Type -> "type"
+    | Module -> "module"
+    | Module_type -> "module type"
+    | Class -> "class"
+    | Class_type -> "class type"
+    | Other -> ""
+
+  let pp ppf x = Format.pp_print_string ppf (show x)
+
+  let lookup =
+    let to_lookup f lid = fst @@ in_printing_env (f (Lident lid)) in
+    function
+    | Type -> to_lookup Env.find_type_by_name
+    | Module -> to_lookup Env.find_module_by_name
+    | Module_type -> to_lookup Env.find_modtype_by_name
+    | Class -> to_lookup Env.find_class_by_name
+    | Class_type -> to_lookup Env.find_cltype_by_name
+    | Other -> fun _ -> raise Not_found
+
+  let location namespace id =
+    let path = Path.Pident id in
+    try Some (
+        match namespace with
+        | Type -> (in_printing_env @@ Env.find_type path).type_loc
+        | Module -> (in_printing_env @@ Env.find_module path).md_loc
+        | Module_type -> (in_printing_env @@ Env.find_modtype path).mtd_loc
+        | Class -> (in_printing_env @@ Env.find_class path).cty_loc
+        | Class_type -> (in_printing_env @@ Env.find_cltype path).clty_loc
+        | Other -> Location.none
+      ) with Not_found -> None
+
+  let best_class_namespace = function
+    | Papply _ | Pdot _ -> Module
+    | Pident c ->
+        match location Class c with
+        | Some _ -> Class
+        | None -> Class_type
+
+end
+
+(** {2 Conflicts printing}
+    Conflicts arise when multiple items are attributed the same name,
+    the following module stores the global conflict references and
+    provides the printing functions for explaining the source of
+    the conflicts.
+*)
+module Conflicts = struct
+  type explanation =
+    { kind: namespace; name:string; root_name:string; location:Location.t}
+  let explanations = ref M.empty
+  let collect_explanation namespace n id =
+    let name = human_unique n id in
+    let root_name = Ident.name id in
+    if not (M.mem name !explanations) then
+      match Namespace.location namespace id with
+      | None -> ()
+      | Some location ->
+          let explanation = { kind = namespace; location; name; root_name } in
+          explanations := M.add name explanation !explanations
+
+  let pp_explanation ppf r=
+    Format.fprintf ppf "@[<v 2>%a:@,Definition of %s %s@]"
+      Location.print_loc r.location (Namespace.show r.kind) r.name
+
+  let print_located_explanations ppf l =
+    Format.fprintf ppf "@[<v>%a@]" (Format.pp_print_list pp_explanation) l
+
+  let reset () = explanations := M.empty
+  let list_explanations () =
+    let c = !explanations in
+    reset ();
+    c |> M.bindings |> List.map snd |> List.sort Stdlib.compare
+
+
+  let print_toplevel_hint ppf l =
+    let conj ppf () = Format.fprintf ppf " and@ " in
+    let pp_namespace_plural ppf n = Format.fprintf ppf "%as" Namespace.pp n in
+    let root_names = List.map (fun r -> r.kind, r.root_name) l in
+    let unique_root_names = List.sort_uniq Stdlib.compare root_names in
+    let submsgs = Array.make Namespace.size [] in
+    let () = List.iter (fun (n,_ as x) ->
+        submsgs.(Namespace.id n) <- x :: submsgs.(Namespace.id n)
+      )  unique_root_names in
+    let pp_submsg ppf names =
+      match names with
+      | [] -> ()
+      | [namespace, a] ->
+          Format.fprintf ppf
+        "@ \
+         @[<2>Hint: The %a %s has been defined multiple times@ \
+         in@ this@ toplevel@ session.@ \
+         Some toplevel values still refer to@ old@ versions@ of@ this@ %a.\
+         @ Did you try to redefine them?@]"
+        Namespace.pp namespace a Namespace.pp namespace
+      | (namespace, _) :: _ :: _ ->
+      Format.fprintf ppf
+        "@ \
+         @[<2>Hint: The %a %a have been defined multiple times@ \
+         in@ this@ toplevel@ session.@ \
+         Some toplevel values still refer to@ old@ versions@ of@ those@ %a.\
+         @ Did you try to redefine them?@]"
+        pp_namespace_plural namespace
+        Format.(pp_print_list ~pp_sep:conj pp_print_string) (List.map snd names)
+        pp_namespace_plural namespace in
+    Array.iter (pp_submsg ppf) submsgs
+
+  let print_explanations ppf =
+    let ltop, l =
+      (* isolate toplevel locations, since they are too imprecise *)
+      let from_toplevel a =
+        a.location.Location.loc_start.Lexing.pos_fname = "//toplevel//" in
+      List.partition from_toplevel (list_explanations ())
+    in
+    begin match l with
+    | [] -> ()
+    | l -> Format.fprintf ppf "@,%a" print_located_explanations l
+    end;
+    (* if there are name collisions in a toplevel session,
+       display at least one generic hint by namespace *)
+    print_toplevel_hint ppf ltop
+
+  let exists () = M.cardinal !explanations >0
+end
+
+module Naming_context = struct
+
+let enabled = ref true
+let enable b = enabled := b
+
+(** Name mapping *)
+type mapping =
+  | Need_unique_name of int Ident.Map.t
+  (** The same name has already been attributed to multiple types.
+      The [map] argument contains the specific binding time attributed to each
+      types.
+  *)
+  | Uniquely_associated_to of Ident.t * out_name
+    (** For now, the name [Ident.name id] has been attributed to [id],
+        [out_name] is used to expand this name if a conflict arises
+        at a later point
+    *)
+  | Associated_to_pervasives of out_name
+  (** [Associated_to_pervasives out_name] is used when the item
+      [Stdlib.$name] has been associated to the name [$name].
+      Upon a conflict, this name will be expanded to ["Stdlib." ^ name ] *)
+
+let hid_start = 0
+
+let add_hid_id id map =
+  let new_id = 1 + Ident.Map.fold (fun _ -> Int.max) map hid_start in
+  new_id, Ident.Map.add id new_id  map
+
+let find_hid id map =
+  try Ident.Map.find id map, map with
+  Not_found -> add_hid_id id map
+
+let pervasives name = "Stdlib." ^ name
+
+let map = Array.make Namespace.size M.empty
+let get namespace = map.(Namespace.id namespace)
+let set namespace x = map.(Namespace.id namespace) <- x
+
+(* Names used in recursive definitions are not considered when determining
+   if a name is already attributed in the current environment.
+   This is a complementary version of hidden_rec_items used by short-path. *)
+let protected = ref S.empty
+
+(* When dealing with functor arguments, identity becomes fuzzy because the same
+   syntactic argument may be represented by different identifers during the
+   error processing, we are thus disabling disambiguation on the argument name
+*)
+let fuzzy = ref S.empty
+let with_arg id f =
+  protect_refs [ R(fuzzy, S.add (Ident.name id) !fuzzy) ] f
+let fuzzy_id namespace id = namespace = Module && S.mem (Ident.name id) !fuzzy
+
+let with_hidden ids f =
+  let update m id = S.add (Ident.name id.ident) m in
+  protect_refs [ R(protected, List.fold_left update !protected ids)] f
+
+let pervasives_name namespace name =
+  if not !enabled then Out_name.create name else
+  match M.find name (get namespace) with
+  | Associated_to_pervasives r -> r
+  | Need_unique_name _ -> Out_name.create (pervasives name)
+  | Uniquely_associated_to (id',r) ->
+      let hid, map = add_hid_id id' Ident.Map.empty in
+      Out_name.set r (human_unique hid id');
+      Conflicts.collect_explanation namespace hid id';
+      set namespace @@ M.add name (Need_unique_name map) (get namespace);
+      Out_name.create (pervasives name)
+  | exception Not_found ->
+      let r = Out_name.create name in
+      set namespace @@ M.add name (Associated_to_pervasives r) (get namespace);
+      r
+
+(** Lookup for preexisting named item within the current {!printing_env} *)
+let env_ident namespace name =
+  if S.mem name !protected then None else
+  match Namespace.lookup namespace name with
+  | Pident id -> Some id
+  | _ -> None
+  | exception Not_found -> None
+
+(** Associate a name to the identifier [id] within [namespace] *)
+let ident_name_simple namespace id =
+  if not !enabled || fuzzy_id namespace id then
+    Out_name.create (Ident.name id)
+  else
+  let name = Ident.name id in
+  match M.find name (get namespace) with
+  | Uniquely_associated_to (id',r) when Ident.same id id' ->
+      r
+  | Need_unique_name map ->
+      let hid, m = find_hid id map in
+      Conflicts.collect_explanation namespace hid id;
+      set namespace @@ M.add name (Need_unique_name m) (get namespace);
+      Out_name.create (human_unique hid id)
+  | Uniquely_associated_to (id',r) ->
+      let hid', m = find_hid id' Ident.Map.empty in
+      let hid, m = find_hid id m in
+      Out_name.set r (human_unique hid' id');
+      List.iter (fun (id,hid) -> Conflicts.collect_explanation namespace hid id)
+        [id, hid; id', hid' ];
+      set namespace @@ M.add name (Need_unique_name m) (get namespace);
+      Out_name.create (human_unique hid id)
+  | Associated_to_pervasives r ->
+      Out_name.set r ("Stdlib." ^ Out_name.print r);
+      let hid, m = find_hid id Ident.Map.empty in
+      set namespace @@ M.add name (Need_unique_name m) (get namespace);
+      Out_name.create (human_unique hid id)
+  | exception Not_found ->
+      let r = Out_name.create name in
+      set namespace
+      @@ M.add name (Uniquely_associated_to (id,r) ) (get namespace);
+      r
+
+(** Same as {!ident_name_simple} but lookup to existing named identifiers
+    in the current {!printing_env} *)
+let ident_name namespace id =
+  begin match env_ident namespace (Ident.name id) with
+  | Some id' -> ignore (ident_name_simple namespace id')
+  | None -> ()
+  end;
+  ident_name_simple namespace id
+
+let reset () =
+  Array.iteri ( fun i _ -> map.(i) <- M.empty ) map
+
+let with_ctx f =
+  let old = Array.copy map in
+  try_finally f
+    ~always:(fun () -> Array.blit old 0 map 0 (Array.length map))
+
+end
+let ident_name = Naming_context.ident_name
+let reset_naming_context = Naming_context.reset
+
+let ident ppf id = pp_print_string ppf
+    (Out_name.print (Naming_context.ident_name_simple Other id))
+
+(* Print a path *)
+
+let ident_stdlib = Ident.create_persistent "Stdlib"
+
+let non_shadowed_pervasive = function
+  | Pdot(Pident id, _) -> Ident.same id ident_stdlib
+  | _ -> false
+
+let find_double_underscore s =
+  let len = String.length s in
+  let rec loop i =
+    if i + 1 >= len then
+      None
+    else if s.[i] = '_' && s.[i + 1] = '_' then
+      Some i
+    else
+      loop (i + 1)
+  in
+  loop 0
+
+let rec module_path_is_an_alias_of env path ~alias_of =
+  match Env.find_module path env with
+  | { md_type = Mty_alias path'; _ } ->
+    Path.same path' alias_of ||
+    module_path_is_an_alias_of env path' ~alias_of
+  | _ -> false
+  | exception Not_found -> false
+
+(* Simple heuristic to print Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias
+   for Foo__bar. This pattern is used by the stdlib. *)
+let rec rewrite_double_underscore_paths env p =
+  match p with
+  | Pdot (p, s) ->
+    Pdot (rewrite_double_underscore_paths env p, s)
+  | Papply (a, b) ->
+    Papply (rewrite_double_underscore_paths env a,
+            rewrite_double_underscore_paths env b)
+  | Pident id ->
+    let name = Ident.name id in
+    match find_double_underscore name with
+    | None -> p
+    | Some i ->
+      let better_lid =
+        Ldot
+          (Lident (String.sub name 0 i),
+           String.capitalize_ascii
+             (String.sub name (i + 2) (String.length name - i - 2)))
+      in
+      match Env.find_module_by_name better_lid env with
+      | exception Not_found -> p
+      | p', _ ->
+          if module_path_is_an_alias_of env p' ~alias_of:p then
+            p'
+          else
+          p
+
+let rewrite_double_underscore_paths env p =
+  if env == Env.empty then
+    p
+  else
+    rewrite_double_underscore_paths env p
+
+let rec tree_of_path namespace = function
+  | Pident id ->
+      Oide_ident (ident_name namespace id)
+  | Pdot(_, s) as path when non_shadowed_pervasive path ->
+      Oide_ident (Naming_context.pervasives_name namespace s)
+  | Pdot(Pident t, s)
+    when namespace=Type && not (Path.is_uident (Ident.name t)) ->
+      (* [t.A]: inline record of the constructor [A] from type [t] *)
+      Oide_dot (Oide_ident (ident_name Type t), s)
+  | Pdot(p, s) ->
+      Oide_dot (tree_of_path Module p, s)
+  | Papply(p1, p2) ->
+      Oide_apply (tree_of_path Module p1, tree_of_path Module p2)
+
+let tree_of_path namespace p =
+  tree_of_path namespace (rewrite_double_underscore_paths !printing_env p)
+
+let path ppf p =
+  !Oprint.out_ident ppf (tree_of_path Other p)
+
+let string_of_path p =
+  Format.asprintf "%a" path p
+
+let strings_of_paths namespace p =
+  reset_naming_context ();
+  let trees = List.map (tree_of_path namespace) p in
+  List.map (Format.asprintf "%a" !Oprint.out_ident) trees
+
+let () = Env.print_path := path
+
+(* Print a recursive annotation *)
+
+let tree_of_rec = function
+  | Trec_not -> Orec_not
+  | Trec_first -> Orec_first
+  | Trec_next -> Orec_next
+
+(* Print a raw type expression, with sharing *)
+
+let raw_list pr ppf = function
+    [] -> fprintf ppf "[]"
+  | a :: l ->
+      fprintf ppf "@[<1>[%a%t]@]" pr a
+        (fun ppf -> List.iter (fun x -> fprintf ppf ";@,%a" pr x) l)
+
+let kind_vars = ref []
+let kind_count = ref 0
+
+let rec safe_kind_repr v = function
+    Fvar {contents=Some k}  ->
+      if List.memq k v then "Fvar loop" else
+      safe_kind_repr (k::v) k
+  | Fvar r ->
+      let vid =
+        try List.assq r !kind_vars
+        with Not_found ->
+          let c = incr kind_count; !kind_count in
+          kind_vars := (r,c) :: !kind_vars;
+          c
+      in
+      Printf.sprintf "Fvar {None}@%d" vid
+  | Fpresent -> "Fpresent"
+  | Fabsent -> "Fabsent"
+
+let rec safe_commu_repr v = function
+    Cok -> "Cok"
+  | Cunknown -> "Cunknown"
+  | Clink r ->
+      if List.memq r v then "Clink loop" else
+      safe_commu_repr (r::v) !r
+
+let rec safe_repr v = function
+    {desc = Tlink t} when not (List.memq t v) ->
+      safe_repr (t::v) t
+  | t -> t
+
+let rec list_of_memo = function
+    Mnil -> []
+  | Mcons (_priv, p, _t1, _t2, rem) -> p :: list_of_memo rem
+  | Mlink rem -> list_of_memo !rem
+
+let print_name ppf = function
+    None -> fprintf ppf "None"
+  | Some name -> fprintf ppf "\"%s\"" name
+
+let string_of_label = function
+    Nolabel -> ""
+  | Labelled s -> s
+  | Optional s -> "?"^s
+
+let visited = ref []
+let rec raw_type ppf ty =
+  let ty = safe_repr [] ty in
+  if List.memq ty !visited then fprintf ppf "{id=%d}" ty.id else begin
+    visited := ty :: !visited;
+    fprintf ppf "@[<1>{id=%d;level=%d;scope=%d;desc=@,%a}@]" ty.id ty.level
+      ty.scope raw_type_desc ty.desc
+  end
+and raw_type_list tl = raw_list raw_type tl
+and raw_type_desc ppf = function
+    Tvar name -> fprintf ppf "Tvar %a" print_name name
+  | Tarrow(l,t1,t2,c) ->
+      fprintf ppf "@[<hov1>Tarrow(\"%s\",@,%a,@,%a,@,%s)@]"
+        (string_of_label l) raw_type t1 raw_type t2
+        (safe_commu_repr [] c)
+  | Ttuple tl ->
+      fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl
+  | Tconstr (p, tl, abbrev) ->
+      fprintf ppf "@[<hov1>Tconstr(@,%a,@,%a,@,%a)@]" path p
+        raw_type_list tl
+        (raw_list path) (list_of_memo !abbrev)
+  | Tobject (t, nm) ->
+      fprintf ppf "@[<hov1>Tobject(@,%a,@,@[<1>ref%t@])@]" raw_type t
+        (fun ppf ->
+          match !nm with None -> fprintf ppf " None"
+          | Some(p,tl) ->
+              fprintf ppf "(Some(@,%a,@,%a))" path p raw_type_list tl)
+  | Tfield (f, k, t1, t2) ->
+      fprintf ppf "@[<hov1>Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f
+        (safe_kind_repr [] k)
+        raw_type t1 raw_type t2
+  | Tnil -> fprintf ppf "Tnil"
+  | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t
+  | Tsubst (t, None) -> fprintf ppf "@[<1>Tsubst@,(%a,None)@]" raw_type t
+  | Tsubst (t, Some t') ->
+      fprintf ppf "@[<1>Tsubst@,(%a,@ Some%a)@]" raw_type t raw_type t'
+  | Tunivar name -> fprintf ppf "Tunivar %a" print_name name
+  | Tpoly (t, tl) ->
+      fprintf ppf "@[<hov1>Tpoly(@,%a,@,%a)@]"
+        raw_type t
+        raw_type_list tl
+  | Tvariant row ->
+      fprintf ppf
+        "@[<hov1>{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%B;@ %s%a;@ @[<1>%s%t@]}@]"
+        "row_fields="
+        (raw_list (fun ppf (l, f) ->
+          fprintf ppf "@[%s,@ %a@]" l raw_field f))
+        row.row_fields
+        "row_more=" raw_type row.row_more
+        "row_closed=" row.row_closed
+        "row_fixed=" raw_row_fixed row.row_fixed
+        "row_name="
+        (fun ppf ->
+          match row.row_name with None -> fprintf ppf "None"
+          | Some(p,tl) ->
+              fprintf ppf "Some(@,%a,@,%a)" path p raw_type_list tl)
+  | Tpackage (p, fl) ->
+      fprintf ppf "@[<hov1>Tpackage(@,%a@,%a)@]" path p
+        raw_type_list (List.map snd fl)
+and raw_row_fixed ppf = function
+| None -> fprintf ppf "None"
+| Some Types.Fixed_private -> fprintf ppf "Some Fixed_private"
+| Some Types.Rigid -> fprintf ppf "Some Rigid"
+| Some Types.Univar t -> fprintf ppf "Some(Univar(%a))" raw_type t
+| Some Types.Reified p -> fprintf ppf "Some(Reified(%a))" path p
+
+and raw_field ppf = function
+    Rpresent None -> fprintf ppf "Rpresent None"
+  | Rpresent (Some t) -> fprintf ppf "@[<1>Rpresent(Some@,%a)@]" raw_type t
+  | Reither (c,tl,m,e) ->
+      fprintf ppf "@[<hov1>Reither(%B,@,%a,@,%B,@,@[<1>ref%t@])@]" c
+        raw_type_list tl m
+        (fun ppf ->
+          match !e with None -> fprintf ppf " None"
+          | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f)
+  | Rabsent -> fprintf ppf "Rabsent"
+
+let raw_type_expr ppf t =
+  visited := []; kind_vars := []; kind_count := 0;
+  raw_type ppf t;
+  visited := []; kind_vars := []
+
+let () = Btype.print_raw := raw_type_expr
+
+(* Normalize paths *)
+
+let same_type t t' = repr t == repr t'
+
+let set_printing_env env =
+  printing_env :=
+    if !Clflags.real_paths then Env.empty
+    else env
+
+let wrap_printing_env env f =
+  set_printing_env (Env.update_short_paths env);
+  reset_naming_context ();
+  try_finally f ~always:(fun () -> set_printing_env Env.empty)
+
+let wrap_printing_env ?error:_ env f =
+  Env.without_cmis (wrap_printing_env env) f
+
+type type_result = Short_paths.type_result =
+  | Nth of int
+  | Path of int list option * Path.t
+
+type type_resolution = Short_paths.type_resolution =
+  | Nth of int
+  | Subst of int list
+  | Id
+
+let apply_subst ns args =
+  List.map (List.nth args) ns
+
+let apply_subst_opt nso args =
+  match nso with
+  | None -> args
+  | Some ns -> apply_subst ns args
+
+let apply_nth n args =
+  List.nth args n
+
+let best_type_path p =
+  if !Clflags.real_paths || !printing_env == Env.empty
+  then Path(None, p)
+  else Short_paths.find_type (Env.short_paths !printing_env) p
+
+let best_type_path_resolution p =
+  if !Clflags.real_paths || !printing_env == Env.empty
+  then Id
+  else Short_paths.find_type_resolution (Env.short_paths !printing_env) p
+
+let best_type_path_simple p =
+  if !Clflags.real_paths || !printing_env == Env.empty
+  then p
+  else Short_paths.find_type_simple (Env.short_paths !printing_env) p
+
+let best_module_type_path p =
+  if !Clflags.real_paths || !printing_env == Env.empty
+  then p
+  else Short_paths.find_module_type (Env.short_paths !printing_env) p
+
+let best_module_path p =
+  if !Clflags.real_paths || !printing_env == Env.empty
+  then p
+  else Short_paths.find_module (Env.short_paths !printing_env) p
+
+let best_class_type_path p =
+  if !Clflags.real_paths || !printing_env == Env.empty
+  then None, p
+  else Short_paths.find_class_type (Env.short_paths !printing_env) p
+
+let best_class_type_path_simple p =
+  if !Clflags.real_paths || !printing_env == Env.empty
+  then p
+  else Short_paths.find_class_type_simple (Env.short_paths !printing_env) p
+
+(* Print a type expression *)
+
+let names = ref ([] : (type_expr * string) list)
+let name_counter = ref 0
+let named_vars = ref ([] : string list)
+
+let weak_counter = ref 1
+let weak_var_map = ref TypeMap.empty
+let named_weak_vars = ref String.Set.empty
+
+let reset_names () = names := []; name_counter := 0; named_vars := []
+let add_named_var ty =
+  match ty.desc with
+    Tvar (Some name) | Tunivar (Some name) ->
+      if List.mem name !named_vars then () else
+      named_vars := name :: !named_vars
+  | _ -> ()
+
+let name_is_already_used name =
+  List.mem name !named_vars
+  || List.exists (fun (_, name') -> name = name') !names
+  || String.Set.mem name !named_weak_vars
+
+let rec new_name () =
+  let name =
+    if !name_counter < 26
+    then String.make 1 (Char.chr(97 + !name_counter))
+    else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^
+           Int.to_string(!name_counter / 26) in
+  incr name_counter;
+  if name_is_already_used name then new_name () else name
+
+let rec new_weak_name ty () =
+  let name = "weak" ^ Int.to_string !weak_counter in
+  incr weak_counter;
+  if name_is_already_used name then new_weak_name ty ()
+  else begin
+      named_weak_vars := String.Set.add name !named_weak_vars;
+      weak_var_map := TypeMap.add ty name !weak_var_map;
+      name
+    end
+
+let name_of_type name_generator t =
+  (* We've already been through repr at this stage, so t is our representative
+     of the union-find class. *)
+  try List.assq t !names with Not_found ->
+    try TypeMap.find t !weak_var_map with Not_found ->
+    let name =
+      match t.desc with
+        Tvar (Some name) | Tunivar (Some name) ->
+          (* Some part of the type we've already printed has assigned another
+           * unification variable to that name. We want to keep the name, so try
+           * adding a number until we find a name that's not taken. *)
+          let current_name = ref name in
+          let i = ref 0 in
+          while List.exists (fun (_, name') -> !current_name = name') !names do
+            current_name := name ^ (Int.to_string !i);
+            i := !i + 1;
+          done;
+          !current_name
+      | _ ->
+          (* No name available, create a new one *)
+          name_generator ()
+    in
+    (* Exception for type declarations *)
+    if name <> "_" then names := (t, name) :: !names;
+    name
+
+let check_name_of_type t = ignore(name_of_type new_name t)
+
+let remove_names tyl =
+  let tyl = List.map repr tyl in
+  names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names
+
+let visited_objects = ref ([] : type_expr list)
+let aliased = ref ([] : type_expr list)
+let delayed = ref ([] : type_expr list)
+
+let add_delayed t =
+  if not (List.memq t !delayed) then delayed := t :: !delayed
+
+let is_aliased ty = List.memq (proxy ty) !aliased
+let add_alias ty =
+  let px = proxy ty in
+  if not (is_aliased px) then begin
+    aliased := px :: !aliased;
+    add_named_var px
+  end
+
+let aliasable ty =
+  match ty.desc with
+    Tvar _ | Tunivar _ | Tpoly _ -> false
+  | Tconstr (p, _, _) -> begin
+      match best_type_path_resolution p with
+      | Nth _ -> false
+      | Subst _ | Id -> true
+    end
+  | _ -> true
+
+let namable_row row =
+  row.row_name <> None &&
+  List.for_all
+    (fun (_, f) ->
+       match row_field_repr f with
+       | Reither(c, l, _, _) ->
+           row.row_closed && if c then l = [] else List.length l = 1
+       | _ -> true)
+    row.row_fields
+
+let rec mark_loops_rec visited ty =
+  let ty = repr ty in
+  let px = proxy ty in
+  if List.memq px visited && aliasable ty then add_alias px else
+    let visited = px :: visited in
+    match ty.desc with
+    | Tvar _ -> add_named_var ty
+    | Tarrow(_, ty1, ty2, _) ->
+        mark_loops_rec visited ty1; mark_loops_rec visited ty2
+    | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl
+    | Tconstr(p, tyl, _) -> begin
+        match best_type_path_resolution p with
+        | Nth n ->
+            mark_loops_rec visited (apply_nth n tyl)
+        | Subst ns ->
+          List.iter (mark_loops_rec visited) (apply_subst ns tyl)
+        | Id ->
+            List.iter (mark_loops_rec visited) tyl
+      end
+    | Tpackage (_, fl) ->
+        List.iter (fun (_n, ty) -> mark_loops_rec visited ty) fl
+    | Tvariant row ->
+        if List.memq px !visited_objects then add_alias px else
+         begin
+          let row = row_repr row in
+          if not (static_row row) then
+            visited_objects := px :: !visited_objects;
+          match row.row_name with
+          | Some(_p, tyl) when namable_row row ->
+              List.iter (mark_loops_rec visited) tyl
+          | _ ->
+              iter_row (mark_loops_rec visited) row
+         end
+    | Tobject (fi, nm) ->
+        if List.memq px !visited_objects then add_alias px else
+         begin
+          if opened_object ty then
+            visited_objects := px :: !visited_objects;
+          begin match !nm with
+          | None ->
+              let fields, _ = flatten_fields fi in
+              List.iter
+                (fun (_, kind, ty) ->
+                  if field_kind_repr kind = Fpresent then
+                    mark_loops_rec visited ty)
+                fields
+          | Some (_, l) ->
+              List.iter (mark_loops_rec visited) (List.tl l)
+          end
+        end
+    | Tfield(_, kind, ty1, ty2) when field_kind_repr kind = Fpresent ->
+        mark_loops_rec visited ty1; mark_loops_rec visited ty2
+    | Tfield(_, _, _, ty2) ->
+        mark_loops_rec visited ty2
+    | Tnil -> ()
+    | Tsubst _ -> ()  (* we do not print arguments *)
+    | Tlink _ -> fatal_error "Printtyp.mark_loops_rec (2)"
+    | Tpoly (ty, tyl) ->
+        List.iter (fun t -> add_alias t) tyl;
+        mark_loops_rec visited ty
+    | Tunivar _ -> add_named_var ty
+
+let mark_loops ty =
+  normalize_type ty;
+  mark_loops_rec [] ty;;
+
+let reset_loop_marks () =
+  visited_objects := []; aliased := []; delayed := []
+
+let reset_except_context () =
+  reset_names (); reset_loop_marks ()
+
+let reset () =
+  reset_naming_context (); Conflicts.reset ();
+  reset_except_context ()
+
+let reset_and_mark_loops ty =
+  reset_except_context (); mark_loops ty
+
+let reset_and_mark_loops_list tyl =
+  reset_except_context (); List.iter mark_loops tyl
+
+(* Disabled in classic mode when printing an unification error *)
+let print_labels = ref true
+
+let rec tree_of_typexp sch ty =
+  let ty = repr ty in
+  let px = proxy ty in
+  if List.mem_assq px !names && not (List.memq px !delayed) then
+   let mark = is_non_gen sch ty in
+   let name = name_of_type (if mark then new_weak_name ty else new_name) px in
+   Otyp_var (mark, name) else
+
+  let pr_typ () =
+    match ty.desc with
+    | Tvar _ ->
+        (*let lev =
+          if is_non_gen sch ty then "/" ^ Int.to_string ty.level else "" in*)
+        let non_gen = is_non_gen sch ty in
+        let name_gen = if non_gen then new_weak_name ty else new_name in
+        Otyp_var (non_gen, name_of_type name_gen ty)
+    | Tarrow(l, ty1, ty2, _) ->
+        let lab =
+          if !print_labels || is_optional l then string_of_label l else ""
+        in
+        let t1 =
+          if is_optional l then
+            match (repr ty1).desc with
+            | Tconstr(path, [ty], _)
+              when Path.same path Predef.path_option ->
+                tree_of_typexp sch ty
+            | _ -> Otyp_stuff "<hidden>"
+          else tree_of_typexp sch ty1 in
+        Otyp_arrow (lab, t1, tree_of_typexp sch ty2)
+    | Ttuple tyl ->
+        Otyp_tuple (tree_of_typlist sch tyl)
+    | Tconstr(p, tyl, _abbrev) -> begin
+        match best_type_path p with
+        | Nth n -> tree_of_typexp sch (apply_nth n tyl)
+        | Path(nso, p) ->
+            let tyl = apply_subst_opt nso tyl in
+            Otyp_constr (tree_of_path Type p, tree_of_typlist sch tyl)
+      end
+    | Tvariant row ->
+        let row = row_repr row in
+        let fields =
+          if row.row_closed then
+            List.filter (fun (_, f) -> row_field_repr f <> Rabsent)
+              row.row_fields
+          else row.row_fields in
+        let present =
+          List.filter
+            (fun (_, f) ->
+               match row_field_repr f with
+               | Rpresent _ -> true
+               | _ -> false)
+            fields in
+        let all_present = List.length present = List.length fields in
+        begin match row.row_name with
+        | Some(p, tyl) when namable_row row ->
+            let out_variant =
+              match best_type_path p with
+              | Nth n -> tree_of_typexp sch (apply_nth n tyl)
+              | Path(nso, p) ->
+                let id = tree_of_path Type p in
+                let args = tree_of_typlist sch (apply_subst_opt nso tyl) in
+                Otyp_constr (id, args)
+            in
+            if row.row_closed && all_present then
+              out_variant
+            else
+              let non_gen = is_non_gen sch px in
+              let tags =
+                if all_present then None else Some (List.map fst present) in
+              Otyp_variant (non_gen, Ovar_typ out_variant, row.row_closed, tags)
+        | _ ->
+            let non_gen =
+              not (row.row_closed && all_present) && is_non_gen sch px in
+            let fields = List.map (tree_of_row_field sch) fields in
+            let tags =
+              if all_present then None else Some (List.map fst present) in
+            Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags)
+        end
+    | Tobject (fi, nm) ->
+        tree_of_typobject sch fi !nm
+    | Tnil | Tfield _ ->
+        tree_of_typobject sch ty None
+    | Tsubst _ ->
+        (* This case should only happen when debugging the compiler *)
+        Otyp_stuff "<Tsubst>"
+    | Tlink _ ->
+        fatal_error "Printtyp.tree_of_typexp"
+    | Tpoly (ty, []) ->
+        tree_of_typexp sch ty
+    | Tpoly (ty, tyl) ->
+        (*let print_names () =
+          List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names;
+          prerr_string "; " in *)
+        let tyl = List.map repr tyl in
+        if tyl = [] then tree_of_typexp sch ty else begin
+          let old_delayed = !delayed in
+          (* Make the names delayed, so that the real type is
+             printed once when used as proxy *)
+          List.iter add_delayed tyl;
+          let tl = List.map (name_of_type new_name) tyl in
+          let tr = Otyp_poly (tl, tree_of_typexp sch ty) in
+          (* Forget names when we leave scope *)
+          remove_names tyl;
+          delayed := old_delayed; tr
+        end
+    | Tunivar _ ->
+        Otyp_var (false, name_of_type new_name ty)
+    | Tpackage (p, fl) ->
+        let p = best_module_type_path p in
+        let fl =
+          List.map
+            (fun (li, ty) -> (
+              String.concat "." (Longident.flatten li),
+              tree_of_typexp sch ty
+            )) fl in
+        Otyp_module (tree_of_path Module_type p, fl)
+  in
+  if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed;
+  if is_aliased px && aliasable ty then begin
+    check_name_of_type px;
+    Otyp_alias (pr_typ (), name_of_type new_name px) end
+  else pr_typ ()
+
+and tree_of_row_field sch (l, f) =
+  match row_field_repr f with
+  | Rpresent None | Reither(true, [], _, _) -> (l, false, [])
+  | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty])
+  | Reither(c, tyl, _, _) ->
+      if c (* contradiction: constant constructor with an argument *)
+      then (l, true, tree_of_typlist sch tyl)
+      else (l, false, tree_of_typlist sch tyl)
+  | Rabsent -> (l, false, [] (* actually, an error *))
+
+and tree_of_typlist sch tyl =
+  List.map (tree_of_typexp sch) tyl
+
+and tree_of_typobject sch fi nm =
+  begin match nm with
+  | None ->
+      let pr_fields fi =
+        let (fields, rest) = flatten_fields fi in
+        let present_fields =
+          List.fold_right
+            (fun (n, k, t) l ->
+               match field_kind_repr k with
+               | Fpresent -> (n, t) :: l
+               | _ -> l)
+            fields [] in
+        let sorted_fields =
+          List.sort
+            (fun (n, _) (n', _) -> String.compare n n') present_fields in
+        tree_of_typfields sch rest sorted_fields in
+      let (fields, rest) = pr_fields fi in
+      Otyp_object (fields, rest)
+  | Some (p, ty :: tyl) -> begin
+      let non_gen = is_non_gen sch (repr ty) in
+      let args = tree_of_typlist sch tyl in
+      let p = best_type_path_simple p in
+      Otyp_class (non_gen, tree_of_path Type p, args)
+    end
+  | _ ->
+      fatal_error "Printtyp.tree_of_typobject"
+  end
+
+and is_non_gen sch ty =
+    sch && is_Tvar ty && ty.level <> generic_level
+
+and tree_of_typfields sch rest = function
+  | [] ->
+      let rest =
+        match rest.desc with
+        | Tvar _ | Tunivar _ -> Some (is_non_gen sch rest)
+        | Tconstr _ -> Some false
+        | Tnil -> None
+        | _ -> fatal_error "typfields (1)"
+      in
+      ([], rest)
+  | (s, t) :: l ->
+      let field = (s, tree_of_typexp sch t) in
+      let (fields, rest) = tree_of_typfields sch rest l in
+      (field :: fields, rest)
+
+let typexp sch ppf ty =
+  !Oprint.out_type ppf (tree_of_typexp sch ty)
+
+let marked_type_expr ppf ty = typexp false ppf ty
+
+let type_expr ppf ty =
+  (* [type_expr] is used directly by error message printers,
+     we mark eventual loops ourself to avoid any misuse and stack overflow *)
+  reset_and_mark_loops ty;
+  marked_type_expr ppf ty
+
+and type_sch ppf ty = typexp true ppf ty
+
+and type_scheme ppf ty = reset_and_mark_loops ty; typexp true ppf ty
+
+let type_path ppf p =
+  let p = best_class_type_path_simple p in
+  let t = tree_of_path Type p in
+  !Oprint.out_ident ppf t
+
+(* Maxence *)
+let type_scheme_max ?(b_reset_names=true) ppf ty =
+  if b_reset_names then reset_names () ;
+  typexp true ppf ty
+(* End Maxence *)
+
+let tree_of_type_scheme ty = reset_and_mark_loops ty; tree_of_typexp true ty
+
+(* Print one type declaration *)
+
+let tree_of_constraints params =
+  List.fold_right
+    (fun ty list ->
+       let ty' = unalias ty in
+       if proxy ty != proxy ty' then
+         let tr = tree_of_typexp true ty in
+         (tr, tree_of_typexp true ty') :: list
+       else list)
+    params []
+
+let filter_params tyl =
+  let params =
+    List.fold_left
+      (fun tyl ty ->
+        let ty = repr ty in
+        if List.memq ty tyl then Btype.newgenty (Ttuple [ty]) :: tyl
+        else ty :: tyl)
+      (* Two parameters might be identical due to a constraint but we need to
+         print them differently in order to make the output syntactically valid.
+         We use [Ttuple [ty]] because it is printed as [ty]. *)
+      (* Replacing fold_left by fold_right does not work! *)
+      [] tyl
+  in List.rev params
+
+let mark_loops_constructor_arguments = function
+  | Cstr_tuple l -> List.iter mark_loops l
+  | Cstr_record l -> List.iter (fun l -> mark_loops l.ld_type) l
+
+let rec tree_of_type_decl id decl =
+
+  reset_except_context();
+
+  let params = filter_params decl.type_params in
+
+  begin match decl.type_manifest with
+  | Some ty ->
+      let vars = free_variables ty in
+      List.iter
+        (function {desc = Tvar (Some "_")} as ty ->
+            if List.memq ty vars then set_type_desc ty (Tvar None)
+          | _ -> ())
+        params
+  | None -> ()
+  end;
+
+  List.iter add_alias params;
+  List.iter mark_loops params;
+  List.iter check_name_of_type (List.map proxy params);
+  let ty_manifest =
+    match decl.type_manifest with
+    | None -> None
+    | Some ty ->
+        let ty =
+          (* Special hack to hide variant name *)
+          match repr ty with {desc=Tvariant row} ->
+            let row = row_repr row in
+            begin match row.row_name with
+              Some (Pident id', _) when Ident.same id id' ->
+                newgenty (Tvariant {row with row_name = None})
+            | _ -> ty
+            end
+          | _ -> ty
+        in
+        mark_loops ty;
+        Some ty
+  in
+  begin match decl.type_kind with
+  | Type_abstract -> ()
+  | Type_variant (cstrs, _rep) ->
+      List.iter
+        (fun c ->
+           mark_loops_constructor_arguments c.cd_args;
+           Option.iter mark_loops c.cd_res)
+        cstrs
+  | Type_record(l, _rep) ->
+      List.iter (fun l -> mark_loops l.ld_type) l
+  | Type_open -> ()
+  end;
+
+  let type_param =
+    function
+    | Otyp_var (_, id) -> id
+    | _ -> "?"
+  in
+  let type_defined decl =
+    let abstr =
+      match decl.type_kind with
+        Type_abstract ->
+          decl.type_manifest = None || decl.type_private = Private
+      | Type_record _ ->
+          decl.type_private = Private
+      | Type_variant (tll, _rep) ->
+          decl.type_private = Private ||
+          List.exists (fun cd -> cd.cd_res <> None) tll
+      | Type_open ->
+          decl.type_manifest = None
+    in
+    let vari =
+      List.map2
+        (fun ty v ->
+          let is_var = is_Tvar (repr ty) in
+          if abstr || not is_var then
+            let inj =
+              decl.type_kind = Type_abstract && Variance.mem Inj v &&
+              match decl.type_manifest with
+              | None -> true
+              | Some ty -> (* only abstract or private row types *)
+                  decl.type_private = Private &&
+                  Btype.is_constr_row ~allow_ident:true (Btype.row_of_type ty)
+            and (co, cn) = Variance.get_upper v in
+            (if not cn then Covariant else
+             if not co then Contravariant else NoVariance),
+            (if inj then Injective else NoInjectivity)
+          else (NoVariance, NoInjectivity))
+        decl.type_params decl.type_variance
+    in
+    (Ident.name id,
+     List.map2 (fun ty cocn -> type_param (tree_of_typexp false ty), cocn)
+       params vari)
+  in
+  let tree_of_manifest ty1 =
+    match ty_manifest with
+    | None -> ty1
+    | Some ty -> Otyp_manifest (tree_of_typexp false ty, ty1)
+  in
+  let (name, args) = type_defined decl in
+  let constraints = tree_of_constraints params in
+  let ty, priv, unboxed =
+    match decl.type_kind with
+    | Type_abstract ->
+        begin match ty_manifest with
+        | None -> (Otyp_abstract, Public, false)
+        | Some ty ->
+            tree_of_typexp false ty, decl.type_private, false
+        end
+    | Type_variant (cstrs, rep) ->
+        tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)),
+        decl.type_private,
+        (rep = Variant_unboxed)
+    | Type_record(lbls, rep) ->
+        tree_of_manifest (Otyp_record (List.map tree_of_label lbls)),
+        decl.type_private,
+        (match rep with Record_unboxed _ -> true | _ -> false)
+    | Type_open ->
+        tree_of_manifest Otyp_open,
+        decl.type_private,
+        false
+  in
+    { otype_name = name;
+      otype_params = args;
+      otype_type = ty;
+      otype_private = priv;
+      otype_immediate = Type_immediacy.of_attributes decl.type_attributes;
+      otype_unboxed = unboxed;
+      otype_cstrs = constraints }
+
+and tree_of_constructor_arguments = function
+  | Cstr_tuple l -> tree_of_typlist false l
+  | Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ]
+
+and tree_of_constructor cd =
+  let name = Ident.name cd.cd_id in
+  let arg () = tree_of_constructor_arguments cd.cd_args in
+  match cd.cd_res with
+  | None -> (name, arg (), None)
+  | Some res ->
+      let nm = !names in
+      names := [];
+      let ret = tree_of_typexp false res in
+      let args = arg () in
+      names := nm;
+      (name, args, Some ret)
+
+and tree_of_label l =
+  (Ident.name l.ld_id, l.ld_mutable = Mutable, tree_of_typexp false l.ld_type)
+
+let constructor ppf c =
+  reset_except_context ();
+  !Oprint.out_constr ppf (tree_of_constructor c)
+
+let label ppf l =
+  reset_except_context ();
+  !Oprint.out_label ppf (tree_of_label l)
+
+let tree_of_type_declaration id decl rs =
+  Osig_type (tree_of_type_decl id decl, tree_of_rec rs)
+
+let type_declaration id ppf decl =
+  !Oprint.out_sig_item ppf (tree_of_type_declaration id decl Trec_first)
+
+let constructor_arguments ppf a =
+  let tys = tree_of_constructor_arguments a in
+  !Oprint.out_type ppf (Otyp_tuple tys)
+
+(* Print an extension declaration *)
+
+let extension_constructor_args_and_ret_type_subtree ext_args ext_ret_type =
+  match ext_ret_type with
+  | None -> (tree_of_constructor_arguments ext_args, None)
+  | Some res ->
+    let nm = !names in
+    names := [];
+    let ret = tree_of_typexp false res in
+    let args = tree_of_constructor_arguments ext_args in
+    names := nm;
+    (args, Some ret)
+
+let tree_of_extension_constructor id ext es =
+  reset_except_context ();
+  let type_path = best_type_path_simple ext.ext_type_path in
+  let ty_name = Path.name type_path in
+  let ty_params = filter_params ext.ext_type_params in
+  List.iter add_alias ty_params;
+  List.iter mark_loops ty_params;
+  List.iter check_name_of_type (List.map proxy ty_params);
+  mark_loops_constructor_arguments ext.ext_args;
+  Option.iter mark_loops ext.ext_ret_type;
+  let type_param =
+    function
+    | Otyp_var (_, id) -> id
+    | _ -> "?"
+  in
+  let ty_params =
+    List.map (fun ty -> type_param (tree_of_typexp false ty)) ty_params
+  in
+  let name = Ident.name id in
+  let args, ret =
+    extension_constructor_args_and_ret_type_subtree
+      ext.ext_args
+      ext.ext_ret_type
+  in
+  let ext =
+    { oext_name = name;
+      oext_type_name = ty_name;
+      oext_type_params = ty_params;
+      oext_args = args;
+      oext_ret_type = ret;
+      oext_private = ext.ext_private }
+  in
+  let es =
+    match es with
+        Text_first -> Oext_first
+      | Text_next -> Oext_next
+      | Text_exception -> Oext_exception
+  in
+    Osig_typext (ext, es)
+
+let extension_constructor id ppf ext =
+  !Oprint.out_sig_item ppf (tree_of_extension_constructor id ext Text_first)
+
+let extension_only_constructor id ppf ext =
+  reset_except_context ();
+  let name = Ident.name id in
+  let args, ret =
+    extension_constructor_args_and_ret_type_subtree
+      ext.ext_args
+      ext.ext_ret_type
+  in
+  Format.fprintf ppf "@[<hv>%a@]"
+    !Oprint.out_constr (name, args, ret)
+
+(* Print a value declaration *)
+
+let tree_of_value_description id decl =
+  (* Format.eprintf "@[%a@]@." raw_type_expr decl.val_type; *)
+  let id = Ident.name id in
+  let ty = tree_of_type_scheme decl.val_type in
+  let vd =
+    { oval_name = id;
+      oval_type = ty;
+      oval_prims = [];
+      oval_attributes = [] }
+  in
+  let vd =
+    match decl.val_kind with
+    | Val_prim p -> Primitive.print p vd
+    | _ -> vd
+  in
+  Osig_value vd
+
+let value_description id ppf decl =
+  !Oprint.out_sig_item ppf (tree_of_value_description id decl)
+
+(* Print a class type *)
+
+let method_type (_, kind, ty) =
+  match field_kind_repr kind, repr ty with
+    Fpresent, {desc=Tpoly(ty, tyl)} -> (ty, tyl)
+  | _       , ty                    -> (ty, [])
+
+let tree_of_metho sch concrete csil (lab, kind, ty) =
+  if lab <> dummy_method then begin
+    let kind = field_kind_repr kind in
+    let priv = kind <> Fpresent in
+    let virt = not (Concr.mem lab concrete) in
+    let (ty, tyl) = method_type (lab, kind, ty) in
+    let tty = tree_of_typexp sch ty in
+    remove_names tyl;
+    Ocsg_method (lab, priv, virt, tty) :: csil
+  end
+  else csil
+
+let rec prepare_class_type params = function
+  | Cty_constr (_p, tyl, cty) ->
+      let sty = Ctype.self_type cty in
+      if List.memq (proxy sty) !visited_objects
+      || not (List.for_all is_Tvar params)
+      || List.exists (deep_occur sty) tyl
+      then prepare_class_type params cty
+      else List.iter mark_loops tyl
+  | Cty_signature sign ->
+      let sty = repr sign.csig_self in
+      (* Self may have a name *)
+      let px = proxy sty in
+      if List.memq px !visited_objects then add_alias sty
+      else visited_objects := px :: !visited_objects;
+      let (fields, _) =
+        Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
+      in
+      List.iter (fun met -> mark_loops (fst (method_type met))) fields;
+      Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.csig_vars
+  | Cty_arrow (_, ty, cty) ->
+      mark_loops ty;
+      prepare_class_type params cty
+
+let rec tree_of_class_type sch params =
+  function
+  | Cty_constr (p, tyl, cty) ->
+      let sty = Ctype.self_type cty in
+      if List.memq (proxy sty) !visited_objects
+      || not (List.for_all is_Tvar params)
+      then
+        tree_of_class_type sch params cty
+      else begin
+        let nso, p = best_class_type_path p in
+        let tyl = apply_subst_opt nso tyl in
+        let namespace = Namespace.best_class_namespace p in
+        Octy_constr (tree_of_path namespace p, tree_of_typlist true tyl)
+      end
+  | Cty_signature sign ->
+      let sty = repr sign.csig_self in
+      let self_ty =
+        if is_aliased sty then
+          Some (Otyp_var (false, name_of_type new_name (proxy sty)))
+        else None
+      in
+      let (fields, _) =
+        Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
+      in
+      let csil = [] in
+      let csil =
+        List.fold_left
+          (fun csil (ty1, ty2) -> Ocsg_constraint (ty1, ty2) :: csil)
+          csil (tree_of_constraints params)
+      in
+      let all_vars =
+        Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.csig_vars []
+      in
+      (* Consequence of PR#3607: order of Map.fold has changed! *)
+      let all_vars = List.rev all_vars in
+      let csil =
+        List.fold_left
+          (fun csil (l, m, v, t) ->
+            Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp sch t)
+            :: csil)
+          csil all_vars
+      in
+      let csil =
+        List.fold_left (tree_of_metho sch sign.csig_concr) csil fields
+      in
+      Octy_signature (self_ty, List.rev csil)
+  | Cty_arrow (l, ty, cty) ->
+      let lab =
+        if !print_labels || is_optional l then string_of_label l else ""
+      in
+      let tr =
+       if is_optional l then
+         match (repr ty).desc with
+         | Tconstr(path, [ty], _) when Path.same path Predef.path_option ->
+             tree_of_typexp sch ty
+         | _ -> Otyp_stuff "<hidden>"
+       else tree_of_typexp sch ty in
+      Octy_arrow (lab, tr, tree_of_class_type sch params cty)
+
+let class_type ppf cty =
+  reset ();
+  prepare_class_type [] cty;
+  !Oprint.out_class_type ppf (tree_of_class_type false [] cty)
+
+let tree_of_class_param param variance =
+  (match tree_of_typexp true param with
+    Otyp_var (_, s) -> s
+  | _ -> "?"),
+  if is_Tvar (repr param) then Asttypes.(NoVariance, NoInjectivity)
+                          else variance
+
+let class_variance =
+  let open Variance in let open Asttypes in
+  List.map (fun v ->
+    (if not (mem May_pos v) then Contravariant else
+     if not (mem May_neg v) then Covariant else NoVariance),
+    NoInjectivity)
+
+let tree_of_class_declaration id cl rs =
+  let params = filter_params cl.cty_params in
+
+  reset_except_context ();
+  List.iter add_alias params;
+  prepare_class_type params cl.cty_type;
+  let sty = Ctype.self_type cl.cty_type in
+  List.iter mark_loops params;
+
+  List.iter check_name_of_type (List.map proxy params);
+  if is_aliased sty then check_name_of_type (proxy sty);
+
+  let vir_flag = cl.cty_new = None in
+  Osig_class
+    (vir_flag, Ident.name id,
+     List.map2 tree_of_class_param params (class_variance cl.cty_variance),
+     tree_of_class_type true params cl.cty_type,
+     tree_of_rec rs)
+
+let class_declaration id ppf cl =
+  !Oprint.out_sig_item ppf (tree_of_class_declaration id cl Trec_first)
+
+let tree_of_cltype_declaration id cl rs =
+  let params = List.map repr cl.clty_params in
+
+  reset_except_context ();
+  List.iter add_alias params;
+  prepare_class_type params cl.clty_type;
+  let sty = Ctype.self_type cl.clty_type in
+  List.iter mark_loops params;
+
+  List.iter check_name_of_type (List.map proxy params);
+  if is_aliased sty then check_name_of_type (proxy sty);
+
+  let sign = Ctype.signature_of_class_type cl.clty_type in
+
+  let virt =
+    let (fields, _) =
+      Ctype.flatten_fields (Ctype.object_fields sign.csig_self) in
+    List.exists
+      (fun (lab, _, _) ->
+         not (lab = dummy_method || Concr.mem lab sign.csig_concr))
+      fields
+    || Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.csig_vars false
+  in
+
+  Osig_class_type
+    (virt, Ident.name id,
+     List.map2 tree_of_class_param params (class_variance cl.clty_variance),
+     tree_of_class_type true params cl.clty_type,
+     tree_of_rec rs)
+
+let cltype_declaration id ppf cl =
+  !Oprint.out_sig_item ppf (tree_of_cltype_declaration id cl Trec_first)
+
+(* Print a module type *)
+
+let wrap_env fenv ftree arg =
+  let env = !printing_env in
+  let env' = Env.update_short_paths (fenv env) in
+  set_printing_env env';
+  let tree = ftree arg in
+  set_printing_env env;
+  tree
+
+let dummy =
+  {
+    type_params = [];
+    type_arity = 0;
+    type_kind = Type_abstract;
+    type_private = Public;
+    type_manifest = None;
+    type_variance = [];
+    type_separability = [];
+    type_is_newtype = false;
+    type_expansion_scope = Btype.lowest_level;
+    type_loc = Location.none;
+    type_attributes = [];
+    type_immediate = Unknown;
+    type_unboxed_default = false;
+    type_uid = Uid.internal_not_actually_unique;
+  }
+
+(** we hide items being defined from short-path to avoid shortening
+    [type t = Path.To.t] into [type t = t].
+*)
+
+let ident_sigitem = function
+  | Types.Sig_type(ident,_,_,_) ->  {hide=true;ident}
+  | Types.Sig_class(ident,_,_,_)
+  | Types.Sig_class_type (ident,_,_,_)
+  | Types.Sig_module(ident,_, _,_,_)
+  | Types.Sig_value (ident,_,_)
+  | Types.Sig_modtype (ident,_,_)
+  | Types.Sig_typext (ident,_,_,_)   ->  {hide=false; ident }
+
+let hide ids env =
+  let hide_id id env =
+    (* Global idents cannot be renamed *)
+    if id.hide && not (Ident.global id.ident) then
+      Env.add_type ~check:false (Ident.rename_no_exn id.ident) dummy env
+    else env
+  in
+  List.fold_right hide_id ids env
+
+let with_hidden_items ids f =
+  let with_hidden_in_printing_env ids f =
+    wrap_env (hide ids) (Naming_context.with_hidden ids) f
+  in
+  if not !Clflags.real_paths then
+    with_hidden_in_printing_env ids f
+  else
+    Naming_context.with_hidden ids f
+
+let add_sigitem env x =
+  Env.add_signature (Signature_group.flatten x) env
+
+let rec tree_of_modtype ?(ellipsis=false) = function
+  | Mty_ident p ->
+      let p = best_module_type_path p in
+      Omty_ident (tree_of_path Module_type p)
+  | Mty_signature sg ->
+      Omty_signature (if ellipsis then [Osig_ellipsis]
+                      else tree_of_signature sg)
+  | Mty_functor(param, ty_res) ->
+      let param, env =
+        tree_of_functor_parameter param
+      in
+      let res = wrap_env env (tree_of_modtype ~ellipsis) ty_res in
+      Omty_functor (param, res)
+  | Mty_alias p ->
+      let p = best_module_path p in
+      Omty_alias (tree_of_path Module p)
+  | Mty_for_hole -> Omty_hole
+
+and tree_of_functor_parameter = function
+  | Unit ->
+      None, fun k -> k
+  | Named (param, ty_arg) ->
+      let name, env =
+        match param with
+        | None -> None, fun env -> env
+        | Some id ->
+            Some (Ident.name id),
+            Env.add_module ~arg:true id Mp_present ty_arg
+      in
+      Some (name, tree_of_modtype ~ellipsis:false ty_arg), env
+
+and tree_of_signature sg =
+  wrap_env (fun env -> env)(fun sg ->
+      let tree_groups = tree_of_signature_rec !printing_env sg in
+      List.concat_map (fun (_env,l) -> List.map snd l) tree_groups
+    ) sg
+
+and tree_of_signature_rec env' sg =
+  let structured = List.of_seq (Signature_group.seq sg) in
+  let collect_trees_of_rec_group group =
+    let env = !printing_env in
+    let env', group_trees =
+      Naming_context.with_ctx
+        (fun () -> trees_of_recursive_sigitem_group env group)
+    in
+    set_printing_env env';
+    (env, group_trees) in
+  set_printing_env env';
+  List.map collect_trees_of_rec_group structured
+
+and trees_of_recursive_sigitem_group env
+    (syntactic_group: Signature_group.rec_group) =
+  let display (x:Signature_group.sig_item) = x.src, tree_of_sigitem x.src in
+  let env = Env.add_signature syntactic_group.pre_ghosts env in
+  match syntactic_group.group with
+  | Not_rec x -> add_sigitem env x, [display x]
+  | Rec_group items ->
+      let ids = List.map (fun x -> ident_sigitem x.Signature_group.src) items in
+      List.fold_left add_sigitem env items,
+      with_hidden_items ids (fun () -> List.map display items)
+
+and tree_of_sigitem = function
+  | Sig_value(id, decl, _) ->
+      tree_of_value_description id decl
+  | Sig_type(id, decl, rs, _) ->
+      tree_of_type_declaration id decl rs
+  | Sig_typext(id, ext, es, _) ->
+      tree_of_extension_constructor id ext es
+  | Sig_module(id, _, md, rs, _) ->
+      let ellipsis =
+        List.exists (function
+          | Parsetree.{attr_name = {txt="..."}; attr_payload = PStr []} -> true
+          | _ -> false)
+          md.md_attributes in
+      tree_of_module id md.md_type rs ~ellipsis
+  | Sig_modtype(id, decl, _) ->
+      tree_of_modtype_declaration id decl
+  | Sig_class(id, decl, rs, _) ->
+      tree_of_class_declaration id decl rs
+  | Sig_class_type(id, decl, rs, _) ->
+      tree_of_cltype_declaration id decl rs
+
+and tree_of_modtype_declaration id decl =
+  let mty =
+    match decl.mtd_type with
+    | None -> Omty_abstract
+    | Some mty -> tree_of_modtype mty
+  in
+  Osig_modtype (Ident.name id, mty)
+
+and tree_of_module id ?ellipsis mty rs =
+  Osig_module (Ident.name id, tree_of_modtype ?ellipsis mty, tree_of_rec rs)
+
+let rec functor_parameters ~sep custom_printer = function
+  | [] -> ignore
+  | [id,param] ->
+      Format.dprintf "%t%t"
+        (custom_printer param)
+        (functor_param ~sep ~custom_printer id [])
+  | (id,param) :: q ->
+      Format.dprintf "%t%a%t"
+        (custom_printer param)
+        sep ()
+        (functor_param ~sep ~custom_printer id q)
+and functor_param ~sep ~custom_printer id q =
+  match id with
+  | None -> functor_parameters ~sep custom_printer q
+  | Some id ->
+      Naming_context.with_arg id
+        (fun () -> functor_parameters ~sep custom_printer q)
+
+
+
+let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty)
+let modtype_declaration id ppf decl =
+  !Oprint.out_sig_item ppf (tree_of_modtype_declaration id decl)
+
+(* For the toplevel: merge with tree_of_signature? *)
+
+(* Refresh weak variable map in the toplevel *)
+let refresh_weak () =
+  let refresh t name (m,s) =
+    if is_non_gen true (repr t) then
+      begin
+        TypeMap.add t name m,
+        String.Set.add name s
+      end
+    else m, s in
+  let m, s =
+    TypeMap.fold refresh !weak_var_map (TypeMap.empty ,String.Set.empty)  in
+  named_weak_vars := s;
+  weak_var_map := m
+
+let print_items showval env x =
+  refresh_weak();
+  reset_naming_context ();
+  Conflicts.reset ();
+  let extend_val env (sigitem,outcome) = outcome, showval env sigitem in
+  let post_process (env,l) = List.map (extend_val env) l in
+  List.concat_map post_process @@ tree_of_signature_rec env x
+
+(* Print a signature body (used by -i when compiling a .ml) *)
+
+let print_signature ppf tree =
+  fprintf ppf "@[<v>%a@]" !Oprint.out_signature tree
+
+let signature ppf sg =
+  fprintf ppf "%a" print_signature (tree_of_signature sg)
+
+(* Print a signature body (used by -i when compiling a .ml) *)
+let printed_signature sourcefile ppf sg =
+  (* we are tracking any collision event for warning 63 *)
+  Conflicts.reset ();
+  reset_naming_context ();
+  let t = tree_of_signature sg in
+  if Warnings.(is_active @@ Erroneous_printed_signature "")
+  && Conflicts.exists ()
+  then begin
+    let conflicts = Format.asprintf "%t" Conflicts.print_explanations in
+    Location.prerr_warning (Location.in_file sourcefile)
+      (Warnings.Erroneous_printed_signature conflicts);
+    Warnings.check_fatal ()
+  end;
+  fprintf ppf "%a" print_signature t
+
+(* Print an unification error *)
+
+let same_path t t' =
+  let t = repr t and t' = repr t' in
+  t == t' ||
+  match t.desc, t'.desc with
+  | Tconstr(p,tl,_), Tconstr(p',tl',_) -> begin
+      match best_type_path p, best_type_path p' with
+      | Nth n, Nth n' when n = n' -> true
+      | Path(nso, p), Path(nso', p') when Path.same p p' ->
+          let tl = apply_subst_opt nso tl in
+          let tl' = apply_subst_opt nso' tl' in
+          List.length tl = List.length tl' &&
+          List.for_all2 same_type tl tl'
+      | _ -> false
+      end
+  | _ ->
+      false
+
+type 'a diff = Same of 'a | Diff of 'a * 'a
+
+let trees_of_type_expansion (t,t') =
+  if same_path t t'
+  then begin add_delayed (proxy t); Same (tree_of_typexp false t) end
+  else
+    let t' = if proxy t == proxy t' then unalias t' else t' in
+    (* beware order matter due to side effect,
+       e.g. when printing object types *)
+    let first = tree_of_typexp false t in
+    let second = tree_of_typexp false t' in
+    if first = second then Same first
+    else Diff(first,second)
+
+let type_expansion ppf = function
+  | Same t -> !Oprint.out_type ppf t
+  | Diff(t,t') ->
+      fprintf ppf "@[<2>%a@ =@ %a@]"  !Oprint.out_type t  !Oprint.out_type t'
+
+let trees_of_trace = List.map (Errortrace.map_diff trees_of_type_expansion)
+
+let trees_of_type_path_expansion (tp,tp') =
+  if Path.same tp tp' then Same(tree_of_path Type tp) else
+    Diff(tree_of_path Type tp, tree_of_path Type tp')
+
+let type_path_expansion ppf = function
+  | Same p -> !Oprint.out_ident ppf p
+  | Diff(p,p') ->
+      fprintf ppf "@[<2>%a@ =@ %a@]"
+        !Oprint.out_ident p
+        !Oprint.out_ident p'
+
+let rec trace fst txt ppf = function
+  | {Errortrace.got; expected} :: rem ->
+      if not fst then fprintf ppf "@,";
+      fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@] %a"
+       type_expansion got txt type_expansion expected
+       (trace false txt) rem
+  | _ -> ()
+
+type printing_status =
+  | Discard
+  | Keep
+  | Optional_refinement
+  (** An [Optional_refinement] printing status is attributed to trace
+      elements that are focusing on a new subpart of a structural type.
+      Since the whole type should have been printed earlier in the trace,
+      we only print those elements if they are the last printed element
+      of a trace, and there is no explicit explanation for the
+      type error.
+  *)
+
+let diff_printing_status { Errortrace.got=t1, t1'; expected=t2, t2'} =
+  if  is_constr_row ~allow_ident:true t1'
+   || is_constr_row ~allow_ident:true t2'
+  then Discard
+  else if same_path t1 t1' && same_path t2 t2' then Optional_refinement
+  else Keep
+
+(* A configuration type that controls which trace we print.  This could be
+   exposed, but we instead expose three separate
+   [report_{unification,equality,moregen}_error] functions.  This also lets us
+   give the unification case an extra optional argument without adding it to the
+   equality and moregen cases. *)
+type 'variety trace_format =
+  | Unification : Errortrace.unification trace_format
+  | Equality    : Errortrace.comparison  trace_format
+  | Moregen     : Errortrace.comparison  trace_format
+
+let incompatibility_phrase (type variety) : variety trace_format -> string =
+  function
+  | Unification -> "is not compatible with type"
+  | Equality    -> "is not equal to type"
+  | Moregen     -> "is not compatible with type"
+
+let printing_status = function
+  | Errortrace.Diff d -> diff_printing_status d
+  | Errortrace.Escape {kind = Constraint} -> Keep
+  | _ -> Keep
+
+(** Flatten the trace and remove elements that are always discarded
+    during printing *)
+
+(* Takes [printing_status] to change behavior for [Subtype] *)
+let prepare_any_trace printing_status tr =
+  let clean_trace x l = match printing_status x with
+    | Keep -> x :: l
+    | Optional_refinement when l = [] -> [x]
+    | Optional_refinement | Discard -> l
+  in
+  match tr with
+  | [] -> []
+  | elt :: rem -> elt :: List.fold_right clean_trace rem []
+
+let prepare_trace f tr =
+  prepare_any_trace printing_status (Errortrace.flatten f tr)
+
+(** Keep elements that are not [Diff _ ] and take the decision
+    for the last element, require a prepared trace *)
+let rec filter_trace trace_format keep_last = function
+  | [] -> []
+  | [Errortrace.Diff d as elt]
+    when printing_status elt = Optional_refinement ->
+    if keep_last then [d] else []
+  | Errortrace.Diff d :: rem -> d :: filter_trace trace_format keep_last rem
+  | _ :: rem -> filter_trace trace_format keep_last rem
+
+let type_path_list =
+  Format.pp_print_list ~pp_sep:(fun ppf () -> Format.pp_print_break ppf 2 0)
+    type_path_expansion
+
+(* Hide variant name and var, to force printing the expanded type *)
+let hide_variant_name t =
+  match repr t with
+  | {desc = Tvariant row} as t when (row_repr row).row_name <> None ->
+      newty2 t.level
+        (Tvariant {(row_repr row) with row_name = None;
+                   row_more = newvar2 (row_more row).level})
+  | _ -> t
+
+let prepare_expansion (t, t') =
+  let t' = hide_variant_name t' in
+  mark_loops t;
+  if not (same_path t t') then mark_loops t';
+  (t, t')
+
+let may_prepare_expansion compact (t, t') =
+  match (repr t').desc with
+    Tvariant _ | Tobject _ when compact ->
+      mark_loops t; (t, t)
+  | _ -> prepare_expansion (t, t')
+
+let print_path p = Format.dprintf "%a" !Oprint.out_ident (tree_of_path Type p)
+
+let print_tag ppf = fprintf ppf "`%s"
+
+let print_tags =
+  let comma ppf () = Format.fprintf ppf ",@ " in
+  Format.pp_print_list ~pp_sep:comma print_tag
+
+let is_unit env ty =
+  match (Ctype.expand_head env ty).desc with
+  | Tconstr (p, _, _) -> Path.same p Predef.path_unit
+  | _ -> false
+
+let unifiable env ty1 ty2 =
+  let snap = Btype.snapshot () in
+  let res =
+    try Ctype.unify env ty1 ty2; true
+    with Unify _ -> false
+  in
+  Btype.backtrack snap;
+  res
+
+let explanation_diff env t3 t4 : (Format.formatter -> unit) option =
+  match t3.desc, t4.desc with
+  | Tarrow (_, ty1, ty2, _), _
+    when is_unit env ty1 && unifiable env ty2 t4 ->
+      Some (fun ppf ->
+        fprintf ppf
+          "@,@[Hint: Did you forget to provide `()' as argument?@]")
+  | _, Tarrow (_, ty1, ty2, _)
+    when is_unit env ty1 && unifiable env t3 ty2 ->
+      Some (fun ppf ->
+        fprintf ppf
+          "@,@[Hint: Did you forget to wrap the expression using \
+           `fun () ->'?@]")
+  | _ ->
+      None
+
+let explain_fixed_row_case ppf = function
+  | Errortrace.Cannot_be_closed ->
+      fprintf ppf "it cannot be closed"
+  | Errortrace.Cannot_add_tags tags ->
+      fprintf ppf "it may not allow the tag(s) %a" print_tags tags
+
+let explain_fixed_row pos expl = match expl with
+  | Fixed_private ->
+    dprintf "The %a variant type is private" Errortrace.print_pos pos
+  | Univar x ->
+    dprintf "The %a variant type is bound to the universal type variable %a"
+      Errortrace.print_pos pos type_expr x
+  | Reified p ->
+    dprintf "The %a variant type is bound to %t"
+      Errortrace.print_pos pos (print_path p)
+  | Rigid -> ignore
+
+let explain_variant (type variety) : variety Errortrace.variant -> _ = function
+  (* Common *)
+  | Errortrace.Incompatible_types_for s ->
+      Some(dprintf "@,Types for tag `%s are incompatible" s)
+  (* Unification *)
+  | Errortrace.No_intersection ->
+      Some(dprintf "@,These two variant types have no intersection")
+  | Errortrace.No_tags(pos,fields) -> Some(
+      dprintf
+        "@,@[The %a variant type does not allow tag(s)@ @[<hov>%a@]@]"
+        Errortrace.print_pos pos
+        print_tags (List.map fst fields)
+    )
+  | Errortrace.Fixed_row (pos,
+                          k,
+                          (Univar _ | Reified _ | Fixed_private as e)) ->
+      Some (
+        dprintf "@,@[%t,@ %a@]" (explain_fixed_row pos e)
+          explain_fixed_row_case k
+      )
+  | Errortrace.Fixed_row (_,_, Rigid) ->
+      (* this case never happens *)
+      None
+  (* Equality & Moregen *)
+  | Errortrace.Openness pos ->
+    Some(dprintf "@,The %a variant type is open and the %a is not"
+           Errortrace.print_pos pos
+           Errortrace.print_pos (Errortrace.swap_position pos))
+
+let explain_escape pre = function
+  | Errortrace.Univ u -> Some(
+      dprintf "%t@,The universal variable %a would escape its scope"
+        pre type_expr u)
+  | Errortrace.Constructor p -> Some(
+      dprintf
+        "%t@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
+        pre path p
+    )
+  | Errortrace.Module_type p -> Some(
+      dprintf
+        "%t@,@[The module type@;<1 2>%a@ would escape its scope@]"
+        pre path p
+    )
+  | Errortrace.Equation (_,t) -> Some(
+      dprintf "%t @,@[<hov>This instance of %a is ambiguous:@ %s@]"
+        pre type_expr t
+        "it would escape the scope of its equation"
+    )
+  | Errortrace.Self ->
+      Some (dprintf "%t@,Self type cannot escape its class" pre)
+  | Errortrace.Constraint ->
+      None
+
+let explain_object (type variety) : variety Errortrace.obj -> _ = function
+  | Errortrace.Missing_field (pos,f) -> Some(
+      dprintf "@,@[The %a object type has no method %s@]"
+        Errortrace.print_pos pos f
+    )
+  | Errortrace.Abstract_row pos -> Some(
+      dprintf
+        "@,@[The %a object type has an abstract row, it cannot be closed@]"
+        Errortrace.print_pos pos
+    )
+  | Errortrace.Self_cannot_be_closed ->
+      Some (dprintf "@,Self type cannot be unified with a closed object type")
+
+let explanation (type variety) intro prev env
+  : ('a, variety) Errortrace.elt -> _ = function
+  | Errortrace.Diff { Errortrace.got = _,s; expected = _,t } ->
+    explanation_diff env s t
+  | Errortrace.Escape {kind;context} ->
+    let pre =
+      match context, kind, prev with
+      | Some ctx, _, _ ->
+        dprintf "@[%t@;<1 2>%a@]" intro type_expr ctx
+      | None, Univ _, Some(Errortrace.Incompatible_fields {name; diff}) ->
+        dprintf "@,@[The method %s has type@ %a,@ \
+                 but the expected method type was@ %a@]"
+          name type_expr diff.got type_expr diff.expected
+      | _ -> ignore
+    in
+    explain_escape pre kind
+  | Errortrace.Incompatible_fields { name; _ } ->
+    Some(dprintf "@,Types for method %s are incompatible" name)
+  | Errortrace.Variant v ->
+    explain_variant v
+  | Errortrace.Obj o ->
+    explain_object o
+  | Errortrace.Rec_occur(x,y) ->
+    reset_and_mark_loops y;
+    begin match x.desc with
+    | Tvar _ | Tunivar _  ->
+        Some(dprintf "@,@[<hov>The type variable %a occurs inside@ %a@]"
+               type_expr x type_expr y)
+    | _ ->
+        (* We had a delayed unification of the type variable with
+           a non-variable after the occur check. *)
+        Some ignore
+        (* There is no need to search further for an explanation, but
+           we don't want to print a message of the form:
+             {[ The type int occurs inside int list -> 'a |}
+        *)
+    end
+
+let mismatch intro env trace =
+  Errortrace.explain trace (fun ~prev h -> explanation intro prev env h)
+
+let explain mis ppf =
+  match mis with
+  | None -> ()
+  | Some explain -> explain ppf
+
+let warn_on_missing_def env ppf t =
+  match t.desc with
+  | Tconstr (p,_,_) ->
+    begin
+      try
+        ignore(Env.find_type p env : Types.type_declaration)
+      with Not_found ->
+        fprintf ppf
+          "@,@[%a is abstract because no corresponding cmi file was found \
+           in path.@]" path p
+    end
+  | _ -> ()
+
+let prepare_expansion_head empty_tr = function
+  | Errortrace.Diff d ->
+      Some (Errortrace.map_diff (may_prepare_expansion empty_tr) d)
+  | _ -> None
+
+let head_error_printer txt_got txt_but = function
+  | None -> ignore
+  | Some d ->
+      let d = Errortrace.map_diff trees_of_type_expansion d in
+      dprintf "%t@;<1 2>%a@ %t@;<1 2>%a"
+        txt_got type_expansion d.Errortrace.got
+        txt_but type_expansion d.Errortrace.expected
+
+let warn_on_missing_defs env ppf = function
+  | None -> ()
+  | Some {Errortrace.got=te1,_; expected=te2,_ } ->
+      warn_on_missing_def env ppf te1;
+      warn_on_missing_def env ppf te2
+
+let error trace_format env tr txt1 ppf txt2 ty_expect_explanation =
+  reset ();
+  let tr = prepare_trace (fun t t' -> t, hide_variant_name t') tr in
+  let mis = mismatch txt1 env tr in
+  match tr with
+  | [] -> assert false
+  | elt :: tr ->
+    try
+      print_labels := not !Clflags.classic;
+      let tr = filter_trace trace_format (mis = None) tr in
+      let head = prepare_expansion_head (tr=[]) elt in
+      let tr = List.map (Errortrace.map_diff prepare_expansion) tr in
+      let head_error = head_error_printer txt1 txt2 head in
+      let tr = trees_of_trace tr in
+      fprintf ppf
+        "@[<v>\
+          @[%t%t@]%a%t\
+         @]"
+        head_error
+        ty_expect_explanation
+        (trace false (incompatibility_phrase trace_format)) tr
+        (explain mis);
+      if env <> Env.empty
+      then warn_on_missing_defs env ppf head;
+      Conflicts.print_explanations ppf;
+      print_labels := true
+    with exn ->
+      print_labels := true;
+      raise exn
+
+let report_error trace_format ppf env tr
+      ?(type_expected_explanation = fun _ -> ())
+      txt1 txt2 =
+  wrap_printing_env env (fun () -> error trace_format env tr txt1 ppf txt2
+                                     type_expected_explanation)
+    ~error:true
+
+let report_unification_error =
+  report_error Unification
+let report_equality_error =
+  report_error Equality ?type_expected_explanation:None
+let report_moregen_error =
+  report_error Moregen ?type_expected_explanation:None
+
+module Subtype = struct
+  (* There's a frustrating amount of code duplication between this module and
+     the outside code, particularly in [prepare_trace] and [filter_trace].
+     Unfortunately, [Subtype] is *just* similar enough to have code duplication,
+     while being *just* different enough (it's only [Diff]) for the abstraction
+     to be nonobvious.  Someday, perhaps... *)
+
+  let printing_status = function
+    | Errortrace.Subtype.Diff d -> diff_printing_status d
+
+  let prepare_unification_trace = prepare_trace
+
+  let prepare_trace f tr =
+    prepare_any_trace printing_status (Errortrace.Subtype.flatten f tr)
+
+  let trace filter_trace get_diff fst keep_last txt ppf tr =
+    print_labels := not !Clflags.classic;
+    try match tr with
+      | elt :: tr' ->
+        let diffed_elt = get_diff elt in
+        let tr =
+          trees_of_trace
+          @@ List.map (Errortrace.map_diff prepare_expansion)
+          @@ filter_trace keep_last tr' in
+        let tr =
+          match fst, diffed_elt with
+          | true, Some elt -> elt :: tr
+          | _, _ -> tr
+        in
+        trace fst txt ppf tr;
+        print_labels := true
+      | _ -> ()
+    with exn ->
+      print_labels := true;
+      raise exn
+
+  let filter_unification_trace = filter_trace Unification
+
+  let rec filter_subtype_trace keep_last = function
+    | [] -> []
+    | [Errortrace.Subtype.Diff d as elt]
+      when printing_status elt = Optional_refinement ->
+        if keep_last then [d] else []
+    | Errortrace.Subtype.Diff d :: rem ->
+        d :: filter_subtype_trace keep_last rem
+
+  let unification_get_diff = function
+    | Errortrace.Diff diff ->
+        Some (Errortrace.map_diff trees_of_type_expansion diff)
+    | _ -> None
+
+  let subtype_get_diff = function
+    | Errortrace.Subtype.Diff diff ->
+        Some (Errortrace.map_diff trees_of_type_expansion diff)
+
+  let report_error ppf env tr1 txt1 tr2 =
+    wrap_printing_env ~error:true env (fun () ->
+      reset ();
+      let tr1 =
+        prepare_trace (fun t t' -> prepare_expansion (t, t')) tr1
+      in
+      let tr2 =
+        prepare_unification_trace (fun t t' -> prepare_expansion (t, t')) tr2
+      in
+      let keep_first = match tr2 with
+        | [Obj _ | Variant _ | Escape _ ] | [] -> true
+        | _ -> false in
+      fprintf ppf "@[<v>%a"
+        (trace filter_subtype_trace subtype_get_diff true keep_first txt1) tr1;
+      if tr2 = [] then fprintf ppf "@]" else
+        let mis = mismatch (dprintf "Within this type") env tr2 in
+        fprintf ppf "%a%t%t@]"
+          (trace filter_unification_trace unification_get_diff false
+             (mis = None) "is not compatible with type") tr2
+          (explain mis)
+          Conflicts.print_explanations
+    )
+end
+
+let report_ambiguous_type_error ppf env tp0 tpl txt1 txt2 txt3 =
+  wrap_printing_env ~error:true env (fun () ->
+    reset ();
+    let tp0 = trees_of_type_path_expansion tp0 in
+      match tpl with
+      [] -> assert false
+    | [tp] ->
+        fprintf ppf
+          "@[%t@;<1 2>%a@ \
+             %t@;<1 2>%a\
+           @]"
+          txt1 type_path_expansion (trees_of_type_path_expansion tp)
+          txt3 type_path_expansion tp0
+    | _ ->
+        fprintf ppf
+          "@[%t@;<1 2>@[<hv>%a@]\
+             @ %t@;<1 2>%a\
+           @]"
+          txt2 type_path_list (List.map trees_of_type_path_expansion tpl)
+          txt3 type_path_expansion tp0)
+
+(* Adapt functions to exposed interface *)
+let tree_of_path = tree_of_path Other
+let tree_of_modtype = tree_of_modtype ~ellipsis:false
+let type_expansion ty ppf ty' =
+  type_expansion ppf (trees_of_type_expansion (ty,ty'))
+let tree_of_type_declaration ident td rs =
+  with_hidden_items [{hide=true; ident}]
+    (fun () -> tree_of_type_declaration ident td rs)
+
+let shorten_type_path env p =
+  wrap_printing_env env
+    (fun () -> best_type_path_simple p)
+
+let shorten_module_type_path env p =
+  wrap_printing_env env
+    (fun () -> best_module_type_path p)
+
+let shorten_module_path env p =
+  wrap_printing_env env
+    (fun () -> best_module_path p)
+
+let shorten_class_type_path env p =
+  wrap_printing_env env
+    (fun () -> best_class_type_path_simple p)
+
+let () =
+  Env.shorten_module_path := shorten_module_path
diff --git a/src/ocaml/typing/printtyp.mli b/src/ocaml/typing/printtyp.mli
new file mode 100644
index 0000000..cfaa9dc
--- /dev/null
+++ b/src/ocaml/typing/printtyp.mli
@@ -0,0 +1,224 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Printing functions *)
+
+open Format
+open Types
+open Outcometree
+
+val longident: formatter -> Longident.t -> unit
+val ident: formatter -> Ident.t -> unit
+val tree_of_path: Path.t -> out_ident
+val path: formatter -> Path.t -> unit
+val string_of_path: Path.t -> string
+
+val type_path: formatter -> Path.t -> unit
+(** Print a type path taking account of [-short-paths].
+    Calls should be within [wrap_printing_env]. *)
+
+module Out_name: sig
+  val create: string -> out_name
+  val print: out_name -> string
+end
+
+type namespace =
+  | Type
+  | Module
+  | Module_type
+  | Class
+  | Class_type
+  | Other (** Other bypasses the unique name for identifier mechanism *)
+
+val strings_of_paths: namespace -> Path.t list -> string list
+    (** Print a list of paths, using the same naming context to
+        avoid name collisions *)
+
+val raw_type_expr: formatter -> type_expr -> unit
+val string_of_label: Asttypes.arg_label -> string
+
+val wrap_printing_env: ?error:bool -> Env.t -> (unit -> 'a) -> 'a
+    (* Call the function using the environment for type path shortening *)
+    (* This affects all the printing functions below *)
+    (* Also, if [~error:true], then disable the loading of cmis *)
+val shorten_type_path: Env.t -> Path.t -> Path.t
+val shorten_module_type_path: Env.t -> Path.t -> Path.t
+val shorten_module_path: Env.t -> Path.t -> Path.t
+val shorten_class_type_path: Env.t -> Path.t -> Path.t
+
+module Naming_context: sig
+  val enable: bool -> unit
+  (** When contextual names are enabled, the mapping between identifiers
+      and names is ensured to be one-to-one. *)
+
+  val reset: unit -> unit
+  (** Reset the naming context *)
+end
+
+(** The [Conflicts] module keeps track of conflicts arising when attributing
+    names to identifiers and provides functions that can print explanations
+    for these conflict in error messages *)
+module Conflicts: sig
+  val exists: unit -> bool
+  (** [exists()] returns true if the current naming context renamed
+        an identifier to avoid a name collision *)
+
+  type explanation =
+    { kind: namespace;
+      name:string;
+      root_name:string;
+      location:Location.t
+    }
+
+  val list_explanations: unit -> explanation list
+(** [list_explanations()] return the list of conflict explanations
+    collected up to this point, and reset the list of collected
+    explanations *)
+
+  val print_located_explanations:
+    Format.formatter -> explanation list -> unit
+
+  val print_explanations: Format.formatter -> unit
+  (** Print all conflict explanations collected up to this point *)
+
+  val reset: unit -> unit
+end
+
+
+val reset: unit -> unit
+val mark_loops: type_expr -> unit
+val reset_and_mark_loops: type_expr -> unit
+val reset_and_mark_loops_list: type_expr list -> unit
+
+val type_expr: formatter -> type_expr -> unit
+val marked_type_expr: formatter -> type_expr -> unit
+(** The function [type_expr] is the safe version of the pair
+    [(typed_expr, marked_type_expr)]:
+    it takes care of marking loops in the type expression and resetting
+    type variable names before printing.
+      Contrarily, the function [marked_type_expr] should only be called on
+    type expressions whose loops have been marked or it may stackoverflow
+    (see #8860 for examples).
+ *)
+
+val constructor_arguments: formatter -> constructor_arguments -> unit
+val tree_of_type_scheme: type_expr -> out_type
+val type_sch : formatter -> type_expr -> unit
+val type_scheme: formatter -> type_expr -> unit
+(* Maxence *)
+val reset_names: unit -> unit
+val type_scheme_max: ?b_reset_names: bool ->
+        formatter -> type_expr -> unit
+(* End Maxence *)
+val tree_of_value_description: Ident.t -> value_description -> out_sig_item
+val value_description: Ident.t -> formatter -> value_description -> unit
+val label : formatter -> label_declaration -> unit
+val constructor : formatter -> constructor_declaration -> unit
+val tree_of_type_declaration:
+    Ident.t -> type_declaration -> rec_status -> out_sig_item
+val type_declaration: Ident.t -> formatter -> type_declaration -> unit
+val tree_of_extension_constructor:
+    Ident.t -> extension_constructor -> ext_status -> out_sig_item
+val extension_constructor:
+    Ident.t -> formatter -> extension_constructor -> unit
+(* Prints extension constructor with the type signature:
+     type ('a, 'b) bar += A of float
+*)
+
+val extension_only_constructor:
+    Ident.t -> formatter -> extension_constructor -> unit
+(* Prints only extension constructor without type signature:
+     A of float
+*)
+
+val tree_of_module:
+    Ident.t -> ?ellipsis:bool -> module_type -> rec_status -> out_sig_item
+val modtype: formatter -> module_type -> unit
+val signature: formatter -> signature -> unit
+val tree_of_modtype: module_type -> out_module_type
+val tree_of_modtype_declaration:
+    Ident.t -> modtype_declaration -> out_sig_item
+
+(** Print a list of functor parameters while adjusting the printing environment
+    for each functor argument.
+
+    Currently, we are disabling disambiguation for functor argument name to
+    avoid the need to track the moving association between identifiers and
+    syntactic names in situation like:
+
+    got: (X: sig module type T end) (Y:X.T) (X:sig module type T end) (Z:X.T)
+    expect: (_: sig end) (Y:X.T) (_:sig end) (Z:X.T)
+*)
+val functor_parameters:
+  sep:(Format.formatter -> unit -> unit) ->
+  ('b -> Format.formatter -> unit) ->
+  (Ident.t option * 'b) list -> Format.formatter -> unit
+
+val tree_of_signature: Types.signature -> out_sig_item list
+val tree_of_typexp: bool -> type_expr -> out_type
+val modtype_declaration: Ident.t -> formatter -> modtype_declaration -> unit
+val class_type: formatter -> class_type -> unit
+val tree_of_class_declaration:
+    Ident.t -> class_declaration -> rec_status -> out_sig_item
+val class_declaration: Ident.t -> formatter -> class_declaration -> unit
+val tree_of_cltype_declaration:
+    Ident.t -> class_type_declaration -> rec_status -> out_sig_item
+val cltype_declaration: Ident.t -> formatter -> class_type_declaration -> unit
+val type_expansion: type_expr -> Format.formatter -> type_expr -> unit
+val prepare_expansion: type_expr * type_expr -> type_expr * type_expr
+val report_ambiguous_type_error:
+    formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list ->
+    (formatter -> unit) -> (formatter -> unit) -> (formatter -> unit) -> unit
+
+val report_unification_error :
+  formatter -> Env.t ->
+  Errortrace.unification Errortrace.t ->
+  ?type_expected_explanation:(formatter -> unit) ->
+  (formatter -> unit) -> (formatter -> unit) ->
+  unit
+
+val report_equality_error :
+  formatter -> Env.t ->
+  Errortrace.comparison Errortrace.t ->
+  (formatter -> unit) -> (formatter -> unit) ->
+  unit
+
+val report_moregen_error :
+  formatter -> Env.t ->
+  Errortrace.comparison Errortrace.t ->
+  (formatter -> unit) -> (formatter -> unit) ->
+  unit
+
+module Subtype : sig
+  val report_error :
+    formatter ->
+    Env.t ->
+    Errortrace.Subtype.t ->
+    string ->
+    Errortrace.unification Errortrace.t ->
+    unit
+end
+
+(* for toploop *)
+val print_items: (Env.t -> signature_item -> 'a option) ->
+  Env.t -> signature_item list -> (out_sig_item * 'a option) list
+
+(* Simple heuristic to rewrite Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias
+   for Foo__bar. This pattern is used by the stdlib. *)
+val rewrite_double_underscore_paths: Env.t -> Path.t -> Path.t
+
+(** [printed_signature sourcefile ppf sg] print the signature [sg] of
+    [sourcefile] with potential warnings for name collisions *)
+val printed_signature: string -> formatter -> signature -> unit
diff --git a/src/ocaml/typing/printtyped.ml b/src/ocaml/typing/printtyped.ml
new file mode 100644
index 0000000..4e18386
--- /dev/null
+++ b/src/ocaml/typing/printtyped.ml
@@ -0,0 +1,967 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes;;
+open Format;;
+open Lexing;;
+open Location;;
+open Typedtree;;
+
+let fmt_position f l =
+  if l.pos_lnum = -1
+  then fprintf f "%s[%d]" l.pos_fname l.pos_cnum
+  else fprintf f "%s[%d,%d+%d]" l.pos_fname l.pos_lnum l.pos_bol
+               (l.pos_cnum - l.pos_bol)
+;;
+
+let fmt_location f loc =
+  if not !Clflags.locations then ()
+  else begin
+    fprintf f "(%a..%a)" fmt_position loc.loc_start fmt_position loc.loc_end;
+    if loc.loc_ghost then fprintf f " ghost";
+  end
+;;
+
+let rec fmt_longident_aux f x =
+  match x with
+  | Longident.Lident (s) -> fprintf f "%s" s;
+  | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s;
+  | Longident.Lapply (y, z) ->
+      fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z;
+;;
+
+let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x.txt;;
+
+let fmt_ident = Ident.print
+
+let fmt_modname f = function
+  | None -> fprintf f "_";
+  | Some id -> Ident.print f id
+
+let rec fmt_path_aux f x =
+  match x with
+  | Path.Pident (s) -> fprintf f "%a" fmt_ident s;
+  | Path.Pdot (y, s) -> fprintf f "%a.%s" fmt_path_aux y s;
+  | Path.Papply (y, z) ->
+      fprintf f "%a(%a)" fmt_path_aux y fmt_path_aux z;
+;;
+
+let fmt_path f x = fprintf f "\"%a\"" fmt_path_aux x;;
+
+let fmt_constant f x =
+  match x with
+  | Const_int (i) -> fprintf f "Const_int %d" i;
+  | Const_char (c) -> fprintf f "Const_char %02x" (Char.code c);
+  | Const_string (s, strloc, None) ->
+      fprintf f "Const_string(%S,%a,None)" s fmt_location strloc;
+  | Const_string (s, strloc, Some delim) ->
+      fprintf f "Const_string (%S,%a,Some %S)" s fmt_location strloc delim;
+  | Const_float (s) -> fprintf f "Const_float %s" s;
+  | Const_int32 (i) -> fprintf f "Const_int32 %ld" i;
+  | Const_int64 (i) -> fprintf f "Const_int64 %Ld" i;
+  | Const_nativeint (i) -> fprintf f "Const_nativeint %nd" i;
+;;
+
+let fmt_mutable_flag f x =
+  match x with
+  | Immutable -> fprintf f "Immutable";
+  | Mutable -> fprintf f "Mutable";
+;;
+
+let fmt_virtual_flag f x =
+  match x with
+  | Virtual -> fprintf f "Virtual";
+  | Concrete -> fprintf f "Concrete";
+;;
+
+let fmt_override_flag f x =
+  match x with
+  | Override -> fprintf f "Override";
+  | Fresh -> fprintf f "Fresh";
+;;
+
+let fmt_closed_flag f x =
+  match x with
+  | Closed -> fprintf f "Closed"
+  | Open -> fprintf f "Open"
+
+let fmt_rec_flag f x =
+  match x with
+  | Nonrecursive -> fprintf f "Nonrec";
+  | Recursive -> fprintf f "Rec";
+;;
+
+let fmt_direction_flag f x =
+  match x with
+  | Upto -> fprintf f "Up";
+  | Downto -> fprintf f "Down";
+;;
+
+let fmt_private_flag f x =
+  match x with
+  | Public -> fprintf f "Public";
+  | Private -> fprintf f "Private";
+;;
+
+let line i f s (*...*) =
+  fprintf f "%s" (String.make (2*i) ' ');
+  fprintf f s (*...*)
+;;
+
+let list i f ppf l =
+  match l with
+  | [] -> line i ppf "[]\n";
+  | _ :: _ ->
+     line i ppf "[\n";
+     List.iter (f (i+1) ppf) l;
+     line i ppf "]\n";
+;;
+
+let array i f ppf a =
+  if Array.length a = 0 then
+    line i ppf "[]\n"
+  else begin
+    line i ppf "[\n";
+    Array.iter (f (i+1) ppf) a;
+    line i ppf "]\n"
+  end
+;;
+
+let option i f ppf x =
+  match x with
+  | None -> line i ppf "None\n";
+  | Some x ->
+      line i ppf "Some\n";
+      f (i+1) ppf x;
+;;
+
+let longident i ppf li = line i ppf "%a\n" fmt_longident li;;
+let string i ppf s = line i ppf "\"%s\"\n" s;;
+let arg_label i ppf = function
+  | Nolabel -> line i ppf "Nolabel\n"
+  | Optional s -> line i ppf "Optional \"%s\"\n" s
+  | Labelled s -> line i ppf "Labelled \"%s\"\n" s
+;;
+
+let record_representation i ppf = let open Types in function
+  | Record_regular -> line i ppf "Record_regular\n"
+  | Record_float -> line i ppf "Record_float\n"
+  | Record_unboxed b -> line i ppf "Record_unboxed %b\n" b
+  | Record_inlined i -> line i ppf "Record_inlined %d\n" i
+  | Record_extension p -> line i ppf "Record_extension %a\n" fmt_path p
+
+let attribute i ppf k a =
+  line i ppf "%s \"%s\"\n" k a.Parsetree.attr_name.txt;
+  Printast.payload i ppf a.Parsetree.attr_payload
+
+let attributes i ppf l =
+  let i = i + 1 in
+  List.iter (fun a ->
+    line i ppf "attribute \"%s\"\n" a.Parsetree.attr_name.txt;
+    Printast.payload (i + 1) ppf a.Parsetree.attr_payload
+  ) l
+
+let rec core_type i ppf x =
+  line i ppf "core_type %a\n" fmt_location x.ctyp_loc;
+  attributes i ppf x.ctyp_attributes;
+  let i = i+1 in
+  match x.ctyp_desc with
+  | Ttyp_any -> line i ppf "Ttyp_any\n";
+  | Ttyp_var (s) -> line i ppf "Ttyp_var %s\n" s;
+  | Ttyp_arrow (l, ct1, ct2) ->
+      line i ppf "Ttyp_arrow\n";
+      arg_label i ppf l;
+      core_type i ppf ct1;
+      core_type i ppf ct2;
+  | Ttyp_tuple l ->
+      line i ppf "Ttyp_tuple\n";
+      list i core_type ppf l;
+  | Ttyp_constr (li, _, l) ->
+      line i ppf "Ttyp_constr %a\n" fmt_path li;
+      list i core_type ppf l;
+  | Ttyp_variant (l, closed, low) ->
+      line i ppf "Ttyp_variant closed=%a\n" fmt_closed_flag closed;
+      list i label_x_bool_x_core_type_list ppf l;
+      option i (fun i -> list i string) ppf low
+  | Ttyp_object (l, c) ->
+      line i ppf "Ttyp_object %a\n" fmt_closed_flag c;
+      let i = i + 1 in
+      List.iter (fun {of_desc; of_attributes; _} ->
+        match of_desc with
+        | OTtag (s, t) ->
+            line i ppf "method %s\n" s.txt;
+            attributes i ppf of_attributes;
+            core_type (i + 1) ppf t
+        | OTinherit ct ->
+            line i ppf "OTinherit\n";
+            core_type (i + 1) ppf ct
+        ) l
+  | Ttyp_class (li, _, l) ->
+      line i ppf "Ttyp_class %a\n" fmt_path li;
+      list i core_type ppf l;
+  | Ttyp_alias (ct, s) ->
+      line i ppf "Ttyp_alias \"%s\"\n" s;
+      core_type i ppf ct;
+  | Ttyp_poly (sl, ct) ->
+      line i ppf "Ttyp_poly%a\n"
+        (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x)) sl;
+      core_type i ppf ct;
+  | Ttyp_package { pack_path = s; pack_fields = l } ->
+      line i ppf "Ttyp_package %a\n" fmt_path s;
+      list i package_with ppf l;
+
+and package_with i ppf (s, t) =
+  line i ppf "with type %a\n" fmt_longident s;
+  core_type i ppf t
+
+and pattern : type k . _ -> _ -> k general_pattern -> unit = fun i ppf x ->
+  line i ppf "pattern %a\n" fmt_location x.pat_loc;
+  attributes i ppf x.pat_attributes;
+  let i = i+1 in
+  match x.pat_extra with
+    | extra :: rem ->
+        pattern_extra i ppf extra;
+        pattern i ppf { x with pat_extra = rem }
+    | [] ->
+  match x.pat_desc with
+  | Tpat_any -> line i ppf "Tpat_any\n";
+  | Tpat_var (s,_) -> line i ppf "Tpat_var \"%a\"\n" fmt_ident s;
+  | Tpat_alias (p, s,_) ->
+      line i ppf "Tpat_alias \"%a\"\n" fmt_ident s;
+      pattern i ppf p;
+  | Tpat_constant (c) -> line i ppf "Tpat_constant %a\n" fmt_constant c;
+  | Tpat_tuple (l) ->
+      line i ppf "Tpat_tuple\n";
+      list i pattern ppf l;
+  | Tpat_construct (li, _, po, vto) ->
+      line i ppf "Tpat_construct %a\n" fmt_longident li;
+      list i pattern ppf po;
+      option i
+        (fun i ppf (vl,ct) ->
+          let names = List.map (fun {txt} -> "\""^Ident.name txt^"\"") vl in
+          line i ppf "[%s]\n" (String.concat "; " names);
+          core_type i ppf ct)
+        ppf vto
+  | Tpat_variant (l, po, _) ->
+      line i ppf "Tpat_variant \"%s\"\n" l;
+      option i pattern ppf po;
+  | Tpat_record (l, _c) ->
+      line i ppf "Tpat_record\n";
+      list i longident_x_pattern ppf l;
+  | Tpat_array (l) ->
+      line i ppf "Tpat_array\n";
+      list i pattern ppf l;
+  | Tpat_lazy p ->
+      line i ppf "Tpat_lazy\n";
+      pattern i ppf p;
+  | Tpat_exception p ->
+      line i ppf "Tpat_exception\n";
+      pattern i ppf p;
+  | Tpat_value p ->
+      line i ppf "Tpat_value\n";
+      pattern i ppf (p :> pattern);
+  | Tpat_or (p1, p2, _) ->
+      line i ppf "Tpat_or\n";
+      pattern i ppf p1;
+      pattern i ppf p2;
+
+and pattern_extra i ppf (extra_pat, _, attrs) =
+  match extra_pat with
+  | Tpat_unpack ->
+     line i ppf "Tpat_extra_unpack\n";
+     attributes i ppf attrs;
+  | Tpat_constraint cty ->
+     line i ppf "Tpat_extra_constraint\n";
+     attributes i ppf attrs;
+     core_type i ppf cty;
+  | Tpat_type (id, _) ->
+     line i ppf "Tpat_extra_type %a\n" fmt_path id;
+     attributes i ppf attrs;
+  | Tpat_open (id,_,_) ->
+     line i ppf "Tpat_extra_open \"%a\"\n" fmt_path id;
+     attributes i ppf attrs;
+
+and expression_extra i ppf x attrs =
+  match x with
+  | Texp_constraint ct ->
+      line i ppf "Texp_constraint\n";
+      attributes i ppf attrs;
+      core_type i ppf ct;
+  | Texp_coerce (cto1, cto2) ->
+      line i ppf "Texp_coerce\n";
+      attributes i ppf attrs;
+      option i core_type ppf cto1;
+      core_type i ppf cto2;
+  | Texp_poly cto ->
+      line i ppf "Texp_poly\n";
+      attributes i ppf attrs;
+      option i core_type ppf cto;
+  | Texp_newtype s ->
+    line i ppf "Texp_newtype \"%s\"\n" s;
+  | Texp_newtype' (id, _) ->
+      line i ppf "Texp_newtype' \"%a\"\n" fmt_ident id;
+      attributes i ppf attrs;
+
+and expression i ppf x =
+  line i ppf "expression %a\n" fmt_location x.exp_loc;
+  attributes i ppf x.exp_attributes;
+  let i =
+    List.fold_left (fun i (extra,_,attrs) ->
+                      expression_extra i ppf extra attrs; i+1)
+      (i+1) x.exp_extra
+  in
+  match x.exp_desc with
+  | Texp_ident (li,_,_) -> line i ppf "Texp_ident %a\n" fmt_path li;
+  | Texp_instvar (_, li,_) -> line i ppf "Texp_instvar %a\n" fmt_path li;
+  | Texp_constant (c) -> line i ppf "Texp_constant %a\n" fmt_constant c;
+  | Texp_let (rf, l, e) ->
+      line i ppf "Texp_let %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l;
+      expression i ppf e;
+  | Texp_function { arg_label = p; param = _; cases; partial = _; } ->
+      line i ppf "Texp_function\n";
+      arg_label i ppf p;
+      list i case ppf cases;
+  | Texp_apply (e, l) ->
+      line i ppf "Texp_apply\n";
+      expression i ppf e;
+      list i label_x_expression ppf l;
+  | Texp_match (e, l, _partial) ->
+      line i ppf "Texp_match\n";
+      expression i ppf e;
+      list i case ppf l;
+  | Texp_try (e, l) ->
+      line i ppf "Texp_try\n";
+      expression i ppf e;
+      list i case ppf l;
+  | Texp_tuple (l) ->
+      line i ppf "Texp_tuple\n";
+      list i expression ppf l;
+  | Texp_construct (li, _, eo) ->
+      line i ppf "Texp_construct %a\n" fmt_longident li;
+      list i expression ppf eo;
+  | Texp_variant (l, eo) ->
+      line i ppf "Texp_variant \"%s\"\n" l;
+      option i expression ppf eo;
+  | Texp_record { fields; representation; extended_expression } ->
+      line i ppf "Texp_record\n";
+      let i = i+1 in
+      line i ppf "fields =\n";
+      array (i+1) record_field ppf fields;
+      line i ppf "representation =\n";
+      record_representation (i+1) ppf representation;
+      line i ppf "extended_expression =\n";
+      option (i+1) expression ppf extended_expression;
+  | Texp_field (e, li, _) ->
+      line i ppf "Texp_field\n";
+      expression i ppf e;
+      longident i ppf li;
+  | Texp_setfield (e1, li, _, e2) ->
+      line i ppf "Texp_setfield\n";
+      expression i ppf e1;
+      longident i ppf li;
+      expression i ppf e2;
+  | Texp_array (l) ->
+      line i ppf "Texp_array\n";
+      list i expression ppf l;
+  | Texp_ifthenelse (e1, e2, eo) ->
+      line i ppf "Texp_ifthenelse\n";
+      expression i ppf e1;
+      expression i ppf e2;
+      option i expression ppf eo;
+  | Texp_sequence (e1, e2) ->
+      line i ppf "Texp_sequence\n";
+      expression i ppf e1;
+      expression i ppf e2;
+  | Texp_while (e1, e2) ->
+      line i ppf "Texp_while\n";
+      expression i ppf e1;
+      expression i ppf e2;
+  | Texp_for (s, _, e1, e2, df, e3) ->
+      line i ppf "Texp_for \"%a\" %a\n" fmt_ident s fmt_direction_flag df;
+      expression i ppf e1;
+      expression i ppf e2;
+      expression i ppf e3;
+  | Texp_send (e, Tmeth_name s, eo) ->
+      line i ppf "Texp_send \"%s\"\n" s;
+      expression i ppf e;
+      option i expression ppf eo
+  | Texp_send (e, Tmeth_val s, eo) ->
+      line i ppf "Texp_send \"%a\"\n" fmt_ident s;
+      expression i ppf e;
+      option i expression ppf eo
+  | Texp_new (li, _, _) -> line i ppf "Texp_new %a\n" fmt_path li;
+  | Texp_setinstvar (_, s, _, e) ->
+      line i ppf "Texp_setinstvar \"%a\"\n" fmt_path s;
+      expression i ppf e;
+  | Texp_override (_, l) ->
+      line i ppf "Texp_override\n";
+      list i string_x_expression ppf l;
+  | Texp_letmodule (s, _, _, me, e) ->
+      line i ppf "Texp_letmodule \"%a\"\n" fmt_modname s;
+      module_expr i ppf me;
+      expression i ppf e;
+  | Texp_letexception (cd, e) ->
+      line i ppf "Texp_letexception\n";
+      extension_constructor i ppf cd;
+      expression i ppf e;
+  | Texp_assert (e) ->
+      line i ppf "Texp_assert";
+      expression i ppf e;
+  | Texp_lazy (e) ->
+      line i ppf "Texp_lazy";
+      expression i ppf e;
+  | Texp_object (s, _) ->
+      line i ppf "Texp_object";
+      class_structure i ppf s
+  | Texp_pack me ->
+      line i ppf "Texp_pack";
+      module_expr i ppf me
+  | Texp_letop {let_; ands; param = _; body; partial = _} ->
+      line i ppf "Texp_letop";
+      binding_op (i+1) ppf let_;
+      list (i+1) binding_op ppf ands;
+      case i ppf body
+  | Texp_unreachable ->
+      line i ppf "Texp_unreachable"
+  | Texp_extension_constructor (li, _) ->
+      line i ppf "Texp_extension_constructor %a" fmt_longident li
+  | Texp_open (o, e) ->
+      line i ppf "Texp_open %a\n"
+        fmt_override_flag o.open_override;
+      module_expr i ppf o.open_expr;
+      attributes i ppf o.open_attributes;
+      expression i ppf e;
+  | Texp_hole ->
+      line i ppf "Texp_hole"
+
+and value_description i ppf x =
+  line i ppf "value_description %a %a\n" fmt_ident x.val_id fmt_location
+       x.val_loc;
+  attributes i ppf x.val_attributes;
+  core_type (i+1) ppf x.val_desc;
+  list (i+1) string ppf x.val_prim;
+
+and binding_op i ppf x =
+  line i ppf "binding_op %a %a\n" fmt_path x.bop_op_path
+    fmt_location x.bop_loc;
+  expression i ppf x.bop_exp
+
+and type_parameter i ppf (x, _variance) = core_type i ppf x
+
+and type_declaration i ppf x =
+  line i ppf "type_declaration %a %a\n" fmt_ident x.typ_id fmt_location
+       x.typ_loc;
+  attributes i ppf x.typ_attributes;
+  let i = i+1 in
+  line i ppf "ptype_params =\n";
+  list (i+1) type_parameter ppf x.typ_params;
+  line i ppf "ptype_cstrs =\n";
+  list (i+1) core_type_x_core_type_x_location ppf x.typ_cstrs;
+  line i ppf "ptype_kind =\n";
+  type_kind (i+1) ppf x.typ_kind;
+  line i ppf "ptype_private = %a\n" fmt_private_flag x.typ_private;
+  line i ppf "ptype_manifest =\n";
+  option (i+1) core_type ppf x.typ_manifest;
+
+and type_kind i ppf x =
+  match x with
+  | Ttype_abstract ->
+      line i ppf "Ttype_abstract\n"
+  | Ttype_variant l ->
+      line i ppf "Ttype_variant\n";
+      list (i+1) constructor_decl ppf l;
+  | Ttype_record l ->
+      line i ppf "Ttype_record\n";
+      list (i+1) label_decl ppf l;
+  | Ttype_open ->
+      line i ppf "Ttype_open\n"
+
+and type_extension i ppf x =
+  line i ppf "type_extension\n";
+  attributes i ppf x.tyext_attributes;
+  let i = i+1 in
+  line i ppf "ptyext_path = %a\n" fmt_path x.tyext_path;
+  line i ppf "ptyext_params =\n";
+  list (i+1) type_parameter ppf x.tyext_params;
+  line i ppf "ptyext_constructors =\n";
+  list (i+1) extension_constructor ppf x.tyext_constructors;
+  line i ppf "ptyext_private = %a\n" fmt_private_flag x.tyext_private;
+
+and type_exception i ppf x =
+  line i ppf "type_exception\n";
+  attributes i ppf x.tyexn_attributes;
+  let i = i+1 in
+  line i ppf "ptyext_constructor =\n";
+  let i = i+1 in
+  extension_constructor i ppf x.tyexn_constructor
+
+and extension_constructor i ppf x =
+  line i ppf "extension_constructor %a\n" fmt_location x.ext_loc;
+  attributes i ppf x.ext_attributes;
+  let i = i + 1 in
+  line i ppf "pext_name = \"%a\"\n" fmt_ident x.ext_id;
+  line i ppf "pext_kind =\n";
+  extension_constructor_kind (i + 1) ppf x.ext_kind;
+
+and extension_constructor_kind i ppf x =
+  match x with
+      Text_decl(a, r) ->
+        line i ppf "Text_decl\n";
+        constructor_arguments (i+1) ppf a;
+        option (i+1) core_type ppf r;
+    | Text_rebind(p, _) ->
+        line i ppf "Text_rebind\n";
+        line (i+1) ppf "%a\n" fmt_path p;
+
+and class_type i ppf x =
+  line i ppf "class_type %a\n" fmt_location x.cltyp_loc;
+  attributes i ppf x.cltyp_attributes;
+  let i = i+1 in
+  match x.cltyp_desc with
+  | Tcty_constr (li, _, l) ->
+      line i ppf "Tcty_constr %a\n" fmt_path li;
+      list i core_type ppf l;
+  | Tcty_signature (cs) ->
+      line i ppf "Tcty_signature\n";
+      class_signature i ppf cs;
+  | Tcty_arrow (l, co, cl) ->
+      line i ppf "Tcty_arrow\n";
+      arg_label i ppf l;
+      core_type i ppf co;
+      class_type i ppf cl;
+  | Tcty_open (o, e) ->
+      line i ppf "Tcty_open %a %a\n"
+        fmt_override_flag o.open_override
+        fmt_path (fst o.open_expr);
+      class_type i ppf e
+
+and class_signature i ppf { csig_self = ct; csig_fields = l } =
+  line i ppf "class_signature\n";
+  core_type (i+1) ppf ct;
+  list (i+1) class_type_field ppf l;
+
+and class_type_field i ppf x =
+  line i ppf "class_type_field %a\n" fmt_location x.ctf_loc;
+  let i = i+1 in
+  attributes i ppf x.ctf_attributes;
+  match x.ctf_desc with
+  | Tctf_inherit (ct) ->
+      line i ppf "Tctf_inherit\n";
+      class_type i ppf ct;
+  | Tctf_val (s, mf, vf, ct) ->
+      line i ppf "Tctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf
+           fmt_virtual_flag vf;
+      core_type (i+1) ppf ct;
+  | Tctf_method (s, pf, vf, ct) ->
+      line i ppf "Tctf_method \"%s\" %a %a\n" s fmt_private_flag pf
+           fmt_virtual_flag vf;
+      core_type (i+1) ppf ct;
+  | Tctf_constraint (ct1, ct2) ->
+      line i ppf "Tctf_constraint\n";
+      core_type (i+1) ppf ct1;
+      core_type (i+1) ppf ct2;
+  | Tctf_attribute a ->
+      attribute i ppf "Tctf_attribute" a
+
+and class_description i ppf x =
+  line i ppf "class_description %a\n" fmt_location x.ci_loc;
+  attributes i ppf x.ci_attributes;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.ci_params;
+  line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt;
+  line i ppf "pci_expr =\n";
+  class_type (i+1) ppf x.ci_expr;
+
+and class_type_declaration i ppf x =
+  line i ppf "class_type_declaration %a\n" fmt_location x.ci_loc;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.ci_params;
+  line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt;
+  line i ppf "pci_expr =\n";
+  class_type (i+1) ppf x.ci_expr;
+
+and class_expr i ppf x =
+  line i ppf "class_expr %a\n" fmt_location x.cl_loc;
+  attributes i ppf x.cl_attributes;
+  let i = i+1 in
+  match x.cl_desc with
+  | Tcl_ident (li, _, l) ->
+      line i ppf "Tcl_ident %a\n" fmt_path li;
+      list i core_type ppf l;
+  | Tcl_structure (cs) ->
+      line i ppf "Tcl_structure\n";
+      class_structure i ppf cs;
+  | Tcl_fun (l, p, _, ce, _) ->
+      line i ppf "Tcl_fun\n";
+      arg_label i ppf l;
+      pattern i ppf p;
+      class_expr i ppf ce
+  | Tcl_apply (ce, l) ->
+      line i ppf "Tcl_apply\n";
+      class_expr i ppf ce;
+      list i label_x_expression ppf l;
+  | Tcl_let (rf, l1, l2, ce) ->
+      line i ppf "Tcl_let %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l1;
+      list i ident_x_expression_def ppf l2;
+      class_expr i ppf ce;
+  | Tcl_constraint (ce, Some ct, _, _, _) ->
+      line i ppf "Tcl_constraint\n";
+      class_expr i ppf ce;
+      class_type i ppf ct
+  | Tcl_constraint (ce, None, _, _, _) -> class_expr i ppf ce
+  | Tcl_open (o, e) ->
+      line i ppf "Tcl_open %a %a\n"
+        fmt_override_flag o.open_override
+        fmt_path (fst o.open_expr);
+      class_expr i ppf e
+
+and class_structure i ppf { cstr_self = p; cstr_fields = l } =
+  line i ppf "class_structure\n";
+  pattern (i+1) ppf p;
+  list (i+1) class_field ppf l;
+
+and class_field i ppf x =
+  line i ppf "class_field %a\n" fmt_location x.cf_loc;
+  let i = i + 1 in
+  attributes i ppf x.cf_attributes;
+  match x.cf_desc with
+  | Tcf_inherit (ovf, ce, so, _, _) ->
+      line i ppf "Tcf_inherit %a\n" fmt_override_flag ovf;
+      class_expr (i+1) ppf ce;
+      option (i+1) string ppf so;
+  | Tcf_val (s, mf, _, k, _) ->
+      line i ppf "Tcf_val \"%s\" %a\n" s.txt fmt_mutable_flag mf;
+      class_field_kind (i+1) ppf k
+  | Tcf_method (s, pf, k) ->
+      line i ppf "Tcf_method \"%s\" %a\n" s.txt fmt_private_flag pf;
+      class_field_kind (i+1) ppf k
+  | Tcf_constraint (ct1, ct2) ->
+      line i ppf "Tcf_constraint\n";
+      core_type (i+1) ppf ct1;
+      core_type (i+1) ppf ct2;
+  | Tcf_initializer (e) ->
+      line i ppf "Tcf_initializer\n";
+      expression (i+1) ppf e;
+  | Tcf_attribute a ->
+      attribute i ppf "Tcf_attribute" a
+
+and class_field_kind i ppf = function
+  | Tcfk_concrete (o, e) ->
+      line i ppf "Concrete %a\n" fmt_override_flag o;
+      expression i ppf e
+  | Tcfk_virtual t ->
+      line i ppf "Virtual\n";
+      core_type i ppf t
+
+and class_declaration i ppf x =
+  line i ppf "class_declaration %a\n" fmt_location x.ci_loc;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.ci_params;
+  line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt;
+  line i ppf "pci_expr =\n";
+  class_expr (i+1) ppf x.ci_expr;
+
+and module_type i ppf x =
+  line i ppf "module_type %a\n" fmt_location x.mty_loc;
+  attributes i ppf x.mty_attributes;
+  let i = i+1 in
+  match x.mty_desc with
+  | Tmty_ident (li,_) -> line i ppf "Tmty_ident %a\n" fmt_path li;
+  | Tmty_alias (li,_) -> line i ppf "Tmty_alias %a\n" fmt_path li;
+  | Tmty_signature (s) ->
+      line i ppf "Tmty_signature\n";
+      signature i ppf s;
+  | Tmty_functor (Unit, mt2) ->
+      line i ppf "Tmty_functor ()\n";
+      module_type i ppf mt2;
+  | Tmty_functor (Named (s, _, mt1), mt2) ->
+      line i ppf "Tmty_functor \"%a\"\n" fmt_modname s;
+      module_type i ppf mt1;
+      module_type i ppf mt2;
+  | Tmty_with (mt, l) ->
+      line i ppf "Tmty_with\n";
+      module_type i ppf mt;
+      list i longident_x_with_constraint ppf l;
+  | Tmty_typeof m ->
+      line i ppf "Tmty_typeof\n";
+      module_expr i ppf m;
+
+and signature i ppf x = list i signature_item ppf x.sig_items
+
+and signature_item i ppf x =
+  line i ppf "signature_item %a\n" fmt_location x.sig_loc;
+  let i = i+1 in
+  match x.sig_desc with
+  | Tsig_value vd ->
+      line i ppf "Tsig_value\n";
+      value_description i ppf vd;
+  | Tsig_type (rf, l) ->
+      line i ppf "Tsig_type %a\n" fmt_rec_flag rf;
+      list i type_declaration ppf l;
+  | Tsig_typesubst l ->
+      line i ppf "Tsig_typesubst\n";
+      list i type_declaration ppf l;
+  | Tsig_typext e ->
+      line i ppf "Tsig_typext\n";
+      type_extension i ppf e;
+  | Tsig_exception ext ->
+      line i ppf "Tsig_exception\n";
+      type_exception i ppf ext
+  | Tsig_module md ->
+      line i ppf "Tsig_module \"%a\"\n" fmt_modname md.md_id;
+      attributes i ppf md.md_attributes;
+      module_type i ppf md.md_type
+  | Tsig_modsubst ms ->
+      line i ppf "Tsig_modsubst \"%a\" = %a\n"
+        fmt_ident ms.ms_id fmt_path ms.ms_manifest;
+      attributes i ppf ms.ms_attributes;
+  | Tsig_recmodule decls ->
+      line i ppf "Tsig_recmodule\n";
+      list i module_declaration ppf decls;
+  | Tsig_modtype x ->
+      line i ppf "Tsig_modtype \"%a\"\n" fmt_ident x.mtd_id;
+      attributes i ppf x.mtd_attributes;
+      modtype_declaration i ppf x.mtd_type
+  | Tsig_modtypesubst x ->
+      line i ppf "Tsig_modtypesubst \"%a\"\n" fmt_ident x.mtd_id;
+      attributes i ppf x.mtd_attributes;
+      modtype_declaration i ppf x.mtd_type
+  | Tsig_open od ->
+      line i ppf "Tsig_open %a %a\n"
+        fmt_override_flag od.open_override
+        fmt_path (fst od.open_expr);
+      attributes i ppf od.open_attributes
+  | Tsig_include incl ->
+      line i ppf "Tsig_include\n";
+      attributes i ppf incl.incl_attributes;
+      module_type i ppf incl.incl_mod
+  | Tsig_class (l) ->
+      line i ppf "Tsig_class\n";
+      list i class_description ppf l;
+  | Tsig_class_type (l) ->
+      line i ppf "Tsig_class_type\n";
+      list i class_type_declaration ppf l;
+  | Tsig_attribute a ->
+      attribute i ppf "Tsig_attribute" a
+
+and module_declaration i ppf md =
+  line i ppf "%a" fmt_modname md.md_id;
+  attributes i ppf md.md_attributes;
+  module_type (i+1) ppf md.md_type;
+
+and module_binding i ppf x =
+  line i ppf "%a\n" fmt_modname x.mb_id;
+  attributes i ppf x.mb_attributes;
+  module_expr (i+1) ppf x.mb_expr
+
+and modtype_declaration i ppf = function
+  | None -> line i ppf "#abstract"
+  | Some mt -> module_type (i + 1) ppf mt
+
+and with_constraint i ppf x =
+  match x with
+  | Twith_type (td) ->
+      line i ppf "Twith_type\n";
+      type_declaration (i+1) ppf td;
+  | Twith_typesubst (td) ->
+      line i ppf "Twith_typesubst\n";
+      type_declaration (i+1) ppf td;
+  | Twith_module (li,_) -> line i ppf "Twith_module %a\n" fmt_path li;
+  | Twith_modsubst (li,_) -> line i ppf "Twith_modsubst %a\n" fmt_path li;
+  | Twith_modtype mty ->
+      line i ppf "Twith_modtype\n";
+      module_type (i+1) ppf mty
+  | Twith_modtypesubst mty ->
+      line i ppf "Twith_modtype\n";
+      module_type (i+1) ppf mty
+
+and module_expr i ppf x =
+  line i ppf "module_expr %a\n" fmt_location x.mod_loc;
+  attributes i ppf x.mod_attributes;
+  let i = i+1 in
+  match x.mod_desc with
+  | Tmod_ident (li,_) -> line i ppf "Tmod_ident %a\n" fmt_path li;
+  | Tmod_hole -> line i ppf "Tmod_hole\n";
+  | Tmod_structure (s) ->
+      line i ppf "Tmod_structure\n";
+      structure i ppf s;
+  | Tmod_functor (Unit, me) ->
+      line i ppf "Tmod_functor ()\n";
+      module_expr i ppf me;
+  | Tmod_functor (Named (s, _, mt), me) ->
+      line i ppf "Tmod_functor \"%a\"\n" fmt_modname s;
+      module_type i ppf mt;
+      module_expr i ppf me;
+  | Tmod_apply (me1, me2, _) ->
+      line i ppf "Tmod_apply\n";
+      module_expr i ppf me1;
+      module_expr i ppf me2;
+  | Tmod_constraint (me, _, Tmodtype_explicit mt, _) ->
+      line i ppf "Tmod_constraint\n";
+      module_expr i ppf me;
+      module_type i ppf mt;
+  | Tmod_constraint (me, _, Tmodtype_implicit, _) -> module_expr i ppf me
+  | Tmod_unpack (e, _) ->
+      line i ppf "Tmod_unpack\n";
+      expression i ppf e;
+
+and structure i ppf x = list i structure_item ppf x.str_items
+
+and structure_item i ppf x =
+  line i ppf "structure_item %a\n" fmt_location x.str_loc;
+  let i = i+1 in
+  match x.str_desc with
+  | Tstr_eval (e, attrs) ->
+      line i ppf "Tstr_eval\n";
+      attributes i ppf attrs;
+      expression i ppf e;
+  | Tstr_value (rf, l) ->
+      line i ppf "Tstr_value %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l;
+  | Tstr_primitive vd ->
+      line i ppf "Tstr_primitive\n";
+      value_description i ppf vd;
+  | Tstr_type (rf, l) ->
+      line i ppf "Tstr_type %a\n" fmt_rec_flag rf;
+      list i type_declaration ppf l;
+  | Tstr_typext te ->
+      line i ppf "Tstr_typext\n";
+      type_extension i ppf te
+  | Tstr_exception ext ->
+      line i ppf "Tstr_exception\n";
+      type_exception i ppf ext;
+  | Tstr_module x ->
+      line i ppf "Tstr_module\n";
+      module_binding i ppf x
+  | Tstr_recmodule bindings ->
+      line i ppf "Tstr_recmodule\n";
+      list i module_binding ppf bindings
+  | Tstr_modtype x ->
+      line i ppf "Tstr_modtype \"%a\"\n" fmt_ident x.mtd_id;
+      attributes i ppf x.mtd_attributes;
+      modtype_declaration i ppf x.mtd_type
+  | Tstr_open od ->
+      line i ppf "Tstr_open %a\n"
+        fmt_override_flag od.open_override;
+      module_expr i ppf od.open_expr;
+      attributes i ppf od.open_attributes
+  | Tstr_class (l) ->
+      line i ppf "Tstr_class\n";
+      list i class_declaration ppf (List.map (fun (cl, _) -> cl) l);
+  | Tstr_class_type (l) ->
+      line i ppf "Tstr_class_type\n";
+      list i class_type_declaration ppf (List.map (fun (_, _, cl) -> cl) l);
+  | Tstr_include incl ->
+      line i ppf "Tstr_include";
+      attributes i ppf incl.incl_attributes;
+      module_expr i ppf incl.incl_mod;
+  | Tstr_attribute a ->
+      attribute i ppf "Tstr_attribute" a
+
+and longident_x_with_constraint i ppf (li, _, wc) =
+  line i ppf "%a\n" fmt_path li;
+  with_constraint (i+1) ppf wc;
+
+and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
+  line i ppf "<constraint> %a\n" fmt_location l;
+  core_type (i+1) ppf ct1;
+  core_type (i+1) ppf ct2;
+
+and constructor_decl i ppf {cd_id; cd_name = _; cd_args; cd_res; cd_loc;
+                            cd_attributes} =
+  line i ppf "%a\n" fmt_location cd_loc;
+  line (i+1) ppf "%a\n" fmt_ident cd_id;
+  attributes i ppf cd_attributes;
+  constructor_arguments (i+1) ppf cd_args;
+  option (i+1) core_type ppf cd_res
+
+and constructor_arguments i ppf = function
+  | Cstr_tuple l -> list i core_type ppf l
+  | Cstr_record l -> list i label_decl ppf l
+
+and label_decl i ppf {ld_id; ld_name = _; ld_mutable; ld_type; ld_loc;
+                      ld_attributes} =
+  line i ppf "%a\n" fmt_location ld_loc;
+  attributes i ppf ld_attributes;
+  line (i+1) ppf "%a\n" fmt_mutable_flag ld_mutable;
+  line (i+1) ppf "%a" fmt_ident ld_id;
+  core_type (i+1) ppf ld_type
+
+and longident_x_pattern i ppf (li, _, p) =
+  line i ppf "%a\n" fmt_longident li;
+  pattern (i+1) ppf p;
+
+and case
+    : type k . _ -> _ -> k case -> unit
+  = fun i ppf {c_lhs; c_guard; c_rhs} ->
+  line i ppf "<case>\n";
+  pattern (i+1) ppf c_lhs;
+  begin match c_guard with
+  | None -> ()
+  | Some g -> line (i+1) ppf "<when>\n"; expression (i + 2) ppf g
+  end;
+  expression (i+1) ppf c_rhs;
+
+and value_binding i ppf x =
+  line i ppf "<def>\n";
+  attributes (i+1) ppf x.vb_attributes;
+  pattern (i+1) ppf x.vb_pat;
+  expression (i+1) ppf x.vb_expr
+
+and string_x_expression i ppf (s, _, e) =
+  line i ppf "<override> \"%a\"\n" fmt_path s;
+  expression (i+1) ppf e;
+
+and record_field i ppf = function
+  | _, Overridden (li, e) ->
+      line i ppf "%a\n" fmt_longident li;
+      expression (i+1) ppf e;
+  | _, Kept _ ->
+      line i ppf "<kept>"
+
+and label_x_expression i ppf (l, e) =
+  line i ppf "<arg>\n";
+  arg_label (i+1) ppf l;
+  (match e with None -> () | Some e -> expression (i+1) ppf e)
+
+and ident_x_expression_def i ppf (l, e) =
+  line i ppf "<def> \"%a\"\n" fmt_ident l;
+  expression (i+1) ppf e;
+
+and label_x_bool_x_core_type_list i ppf x =
+  match x.rf_desc with
+  | Ttag (l, b, ctl) ->
+      line i ppf "Ttag \"%s\" %s\n" l.txt (string_of_bool b);
+      attributes (i+1) ppf x.rf_attributes;
+      list (i+1) core_type ppf ctl
+  | Tinherit (ct) ->
+      line i ppf "Tinherit\n";
+      core_type (i+1) ppf ct
+;;
+
+let interface ppf x = list 0 signature_item ppf x.sig_items;;
+
+let implementation ppf x = list 0 structure_item ppf x.str_items;;
+
+let implementation_with_coercion ppf Typedtree.{structure; _} =
+  implementation ppf structure
diff --git a/src/ocaml/typing/printtyped.mli b/src/ocaml/typing/printtyped.mli
new file mode 100644
index 0000000..7002986
--- /dev/null
+++ b/src/ocaml/typing/printtyped.mli
@@ -0,0 +1,26 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*              Damien Doligez, projet Para, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Typedtree;;
+open Format;;
+
+val interface : formatter -> signature -> unit;;
+val implementation : formatter -> structure -> unit;;
+
+val implementation_with_coercion :
+  formatter -> Typedtree.implementation -> unit;;
+
+(* Added by merlin for debugging purposes *)
+val pattern : int -> formatter -> _ general_pattern -> unit
diff --git a/src/ocaml/typing/rec_check.ml b/src/ocaml/typing/rec_check.ml
new file mode 100644
index 0000000..83f9aa0
--- /dev/null
+++ b/src/ocaml/typing/rec_check.ml
@@ -0,0 +1,1268 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*               Jeremy Yallop, University of Cambridge                   *)
+(*               Gabriel Scherer, Project Parsifal, INRIA Saclay          *)
+(*               Alban Reynaud, ENS Lyon                                  *)
+(*                                                                        *)
+(*   Copyright 2017 Jeremy Yallop                                         *)
+(*   Copyright 2018 Alban Reynaud                                         *)
+(*   Copyright 2018 INRIA                                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Static checking of recursive declarations
+
+Some recursive definitions are meaningful
+{[
+  let rec factorial = function 0 -> 1 | n -> n * factorial (n - 1)
+  let rec infinite_list = 0 :: infinite_list
+]}
+but some other are meaningless
+{[
+  let rec x = x
+  let rec x = x+1
+|}
+
+Intuitively, a recursive definition makes sense when the body of the
+definition can be evaluated without fully knowing what the recursive
+name is yet.
+
+In the [factorial] example, the name [factorial] refers to a function,
+evaluating the function definition [function ...] can be done
+immediately and will not force a recursive call to [factorial] -- this
+will only happen later, when [factorial] is called with an argument.
+
+In the [infinite_list] example, we can evaluate [0 :: infinite_list]
+without knowing the full content of [infinite_list], but with just its
+address. This is a case of productive/guarded recursion.
+
+On the contrary, [let rec x = x] is unguarded recursion (the meaning
+is undetermined), and [let rec x = x+1] would need the value of [x]
+while evaluating its definition [x+1].
+
+This file implements a static check to decide which definitions are
+known to be meaningful, and which may be meaningless. In the general
+case, we handle a set of mutually-recursive definitions
+{[
+let rec x1 = e1
+and x2 = e2
+...
+and xn = en
+]}
+
+
+Our check (see function [is_valid_recursive_expression] is defined
+using two criteria:
+
+Usage of recursive variables: how does each of the [e1 .. en] use the
+ recursive variables [x1 .. xn]?
+
+Static or dynamic size: for which of the [ei] can we compute the
+  in-memory size of the value without evaluating [ei] (so that we can
+  pre-allocate it, and thus know its final address before evaluation).
+
+The "static or dynamic size" is decided by the classify_* functions below.
+
+The "variable usage" question is decided by a static analysis looking
+very much like a type system. The idea is to assign "access modes" to
+variables, where an "access mode" [m] is defined as either
+
+    m ::= Ignore (* the value is not used at all *)
+        | Delay (* the value is not needed at definition time *)
+        | Guard (* the value is stored under a data constructor *)
+        | Return (* the value result is directly returned *)
+        | Dereference (* full access and inspection of the value *)
+
+The access modes of an expression [e] are represented by a "context"
+[G], which is simply a mapping from variables (the variables used in
+[e]) to access modes.
+
+The core notion of the static check is a type-system-like judgment of
+the form [G |- e : m], which can be interpreted as meaning either of:
+
+- If we are allowed to use the variables of [e] at the modes in [G]
+  (but not more), then it is safe to use [e] at the mode [m].
+
+- If we want to use [e] at the mode [m], then its variables are
+  used at the modes in [G].
+
+In practice, for a given expression [e], our implementation takes the
+desired mode of use [m] as *input*, and returns a context [G] as
+*output*, which is (uniquely determined as) the most permissive choice
+of modes [G] for the variables of [e] such that [G |- e : m] holds.
+*)
+
+open Asttypes
+open Typedtree
+open Types
+
+exception Illegal_expr
+
+(** {1 Static or dynamic size} *)
+
+type sd = Static | Dynamic
+
+let is_ref : Types.value_description -> bool = function
+  | { Types.val_kind =
+        Types.Val_prim { Primitive.prim_name = "%makemutable";
+                          prim_arity = 1 } } ->
+        true
+  | _ -> false
+
+(* See the note on abstracted arguments in the documentation for
+    Typedtree.Texp_apply *)
+let is_abstracted_arg : arg_label * expression option -> bool = function
+  | (_, None) -> true
+  | (_, Some _) -> false
+
+let classify_expression : Typedtree.expression -> sd =
+  (* We need to keep track of the size of expressions
+      bound by local declarations, to be able to predict
+      the size of variables. Compare:
+
+        let rec r =
+          let y = fun () -> r ()
+          in y
+
+      and
+
+        let rec r =
+          let y = if Random.bool () then ignore else fun () -> r ()
+          in y
+
+    In both cases the final address of `r` must be known before `y` is compiled,
+    and this is only possible if `r` has a statically-known size.
+
+    The first definition can be allowed (`y` has a statically-known
+    size) but the second one is unsound (`y` has no statically-known size).
+  *)
+  let rec classify_expression env e = match e.exp_desc with
+    (* binding and variable cases *)
+    | Texp_let (rec_flag, vb, e) ->
+        let env = classify_value_bindings rec_flag env vb in
+        classify_expression env e
+    | Texp_ident (path, _, _) ->
+        classify_path env path
+
+    (* non-binding cases *)
+    | Texp_open (_, e)
+    | Texp_letmodule (_, _, _, _, e)
+    | Texp_sequence (_, e)
+    | Texp_letexception (_, e) ->
+        classify_expression env e
+
+    | Texp_construct (_, {cstr_tag = Cstr_unboxed}, [e]) ->
+        classify_expression env e
+    | Texp_construct _ ->
+        Static
+
+    | Texp_record { representation = Record_unboxed _;
+                    fields = [| _, Overridden (_,e) |] } ->
+        classify_expression env e
+    | Texp_record _ ->
+        Static
+
+    | Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, _)
+      when is_ref vd ->
+        Static
+    | Texp_apply (_,args)
+      when List.exists is_abstracted_arg args ->
+        Static
+    | Texp_apply _ ->
+        Dynamic
+
+    | Texp_for _
+    | Texp_constant _
+    | Texp_new _
+    | Texp_instvar _
+    | Texp_tuple _
+    | Texp_array _
+    | Texp_variant _
+    | Texp_setfield _
+    | Texp_while _
+    | Texp_setinstvar _
+    | Texp_pack _
+    | Texp_object _
+    | Texp_function _
+    | Texp_lazy _
+    | Texp_unreachable
+    | Texp_hole
+    | Texp_extension_constructor _ ->
+        Static
+
+    | Texp_match _
+    | Texp_ifthenelse _
+    | Texp_send _
+    | Texp_field _
+    | Texp_assert _
+    | Texp_try _
+    | Texp_override _
+    | Texp_letop _ ->
+        Dynamic
+  and classify_value_bindings rec_flag env bindings =
+    (* We use a non-recursive classification, classifying each
+        binding with respect to the old environment
+        (before all definitions), even if the bindings are recursive.
+
+        Note: computing a fixpoint in some way would be more
+        precise, as the following could be allowed:
+
+          let rec topdef =
+            let rec x = y and y = fun () -> topdef ()
+            in x
+    *)
+    ignore rec_flag;
+    let old_env = env in
+    let add_value_binding env vb =
+      match vb.vb_pat.pat_desc with
+      | Tpat_var (id, _loc) ->
+          let size = classify_expression old_env vb.vb_expr in
+          Ident.add id size env
+      | _ ->
+          (* Note: we don't try to compute any size for complex patterns *)
+          env
+    in
+    List.fold_left add_value_binding env bindings
+  and classify_path env = function
+    | Path.Pident x ->
+        begin
+          try Ident.find_same x env
+          with Not_found ->
+            (* an identifier will be missing from the map if either:
+                - it is a non-local identifier
+                  (bound outside the letrec-binding we are analyzing)
+                - or it is bound by a complex (let p = e in ...) local binding
+                - or it is bound within a module (let module M = ... in ...)
+                  that we are not traversing for size computation
+
+                For non-local identifiers it might be reasonable (although
+                not completely clear) to consider them Static (they have
+                already been evaluated), but for the others we must
+                under-approximate with Dynamic.
+
+                This could be fixed by a more complete implementation.
+            *)
+            Dynamic
+        end
+    | Path.Pdot _ | Path.Papply _ ->
+        (* local modules could have such paths to local definitions;
+            classify_expression could be extend to compute module
+            shapes more precisely *)
+        Dynamic
+  in classify_expression Ident.empty
+
+
+(** {1 Usage of recursive variables} *)
+
+module Mode = struct
+  (** For an expression in a program, its "usage mode" represents
+      static information about how the value produced by the expression
+      will be used by the context around it. *)
+  type t =
+    | Ignore
+    (** [Ignore] is for subexpressions that are not used at all during
+       the evaluation of the whole program. This is the mode of
+       a variable in an expression in which it does not occur. *)
+
+    | Delay
+    (** A [Delay] context can be fully evaluated without evaluating its argument
+        , which will only be needed at a later point of program execution. For
+        example, [fun x -> ?] or [lazy ?] are [Delay] contexts. *)
+
+    | Guard
+    (** A [Guard] context returns the value as a member of a data structure,
+        for example a variant constructor or record. The value can safely be
+        defined mutually-recursively with their context, for example in
+        [let rec li = 1 :: li].
+        When these subexpressions participate in a cyclic definition,
+        this definition is productive/guarded.
+
+        The [Guard] mode is also used when a value is not dereferenced,
+        it is returned by a sub-expression, but the result of this
+        sub-expression is discarded instead of being returned.
+        For example, the subterm [?] is in a [Guard] context
+        in [let _ = ? in e] and in [?; e].
+        When these subexpressions participate in a cyclic definition,
+        they cannot create a self-loop.
+    *)
+
+    | Return
+    (** A [Return] context returns its value without further inspection.
+        This value cannot be defined mutually-recursively with its context,
+        as there is a risk of self-loop: in [let rec x = y and y = x], the
+        two definitions use a single variable in [Return] context. *)
+
+    | Dereference
+    (** A [Dereference] context consumes, inspects and uses the value
+        in arbitrary ways. Such a value must be fully defined at the point
+        of usage, it cannot be defined mutually-recursively with its context. *)
+
+  let equal = ((=) : t -> t -> bool)
+
+  (* Lower-ranked modes demand/use less of the variable/expression they qualify
+     -- so they allow more recursive definitions.
+
+     Ignore < Delay < Guard < Return < Dereference
+  *)
+  let rank = function
+    | Ignore -> 0
+    | Delay -> 1
+    | Guard -> 2
+    | Return -> 3
+    | Dereference -> 4
+
+  (* Returns the more conservative (highest-ranking) mode of the two
+     arguments.
+
+     In judgments we write (m + m') for (join m m').
+  *)
+  let join m m' =
+    if rank m >= rank m' then m else m'
+
+  (* If x is used with the mode m in e[x], and e[x] is used with mode
+     m' in e'[e[x]], then x is used with mode m'[m] (our notation for
+     "compose m' m") in e'[e[x]].
+
+     Return is neutral for composition: m[Return] = m = Return[m].
+
+     Composition is associative and [Ignore] is a zero/annihilator for
+     it: (compose Ignore m) and (compose m Ignore) are both Ignore. *)
+  let compose m' m = match m', m with
+    | Ignore, _ | _, Ignore -> Ignore
+    | Dereference, _ -> Dereference
+    | Delay, _ -> Delay
+    | Guard, Return -> Guard
+    | Guard, ((Dereference | Guard | Delay) as m) -> m
+    | Return, Return -> Return
+    | Return, ((Dereference | Guard | Delay) as m) -> m
+end
+
+type mode = Mode.t = Ignore | Delay | Guard | Return | Dereference
+
+module Env :
+sig
+  type t
+
+  val single : Ident.t -> Mode.t -> t
+  (** Create an environment with a single identifier used with a given mode.
+  *)
+
+  val empty : t
+  (** An environment with no used identifiers. *)
+
+  val find : Ident.t -> t -> Mode.t
+  (** Find the mode of an identifier in an environment.  The default mode is
+      Ignore. *)
+
+  val unguarded : t -> Ident.t list -> Ident.t list
+  (** unguarded e l: the list of all identifiers in l that are dereferenced or
+      returned in the environment e. *)
+
+  val dependent : t -> Ident.t list -> Ident.t list
+  (** dependent e l: the list of all identifiers in l that are used in e
+      (not ignored). *)
+
+  val join : t -> t -> t
+  val join_list : t list -> t
+  (** Environments can be joined pointwise (variable per variable) *)
+
+  val compose : Mode.t -> t -> t
+  (** Environment composition m[G] extends mode composition m1[m2]
+      by composing each mode in G pointwise *)
+
+  val remove : Ident.t -> t -> t
+  (** Remove an identifier from an environment. *)
+
+  val take: Ident.t -> t -> Mode.t * t
+  (** Remove an identifier from an environment, and return its mode *)
+
+  val remove_list : Ident.t list -> t -> t
+  (** Remove all the identifiers of a list from an environment. *)
+
+  val equal : t -> t -> bool
+end = struct
+  module M = Map.Make(Ident)
+
+  (** A "t" maps each rec-bound variable to an access status *)
+  type t = Mode.t M.t
+
+  let equal = M.equal Mode.equal
+
+  let find (id: Ident.t) (tbl: t) =
+    try M.find id tbl with Not_found -> Ignore
+
+  let empty = M.empty
+
+  let join (x: t) (y: t) =
+    M.fold
+      (fun (id: Ident.t) (v: Mode.t) (tbl: t) ->
+         let v' = find id tbl in
+         M.add id (Mode.join v v') tbl)
+      x y
+
+  let join_list li = List.fold_left join empty li
+
+  let compose m env =
+    M.map (Mode.compose m) env
+
+  let single id mode = M.add id mode empty
+
+  let unguarded env li =
+    List.filter (fun id -> Mode.rank (find id env) > Mode.rank Guard) li
+
+  let dependent env li =
+    List.filter (fun id -> Mode.rank (find id env) > Mode.rank Ignore) li
+
+  let remove = M.remove
+
+  let take id env = (find id env, remove id env)
+
+  let remove_list l env =
+    List.fold_left (fun env id -> M.remove id env) env l
+end
+
+let remove_pat pat env =
+  Env.remove_list (pat_bound_idents pat) env
+
+let remove_patlist pats env =
+  List.fold_right remove_pat pats env
+
+(* Usage mode judgments.
+
+   There are two main groups of judgment functions:
+
+   - Judgments of the form "G |- ... : m"
+     compute the environment G of a subterm ... from its mode m, so
+     the corresponding function has type [... -> Mode.t -> Env.t].
+
+     We write [... -> term_judg] in this case.
+
+   - Judgments of the form "G |- ... : m -| G'"
+
+     correspond to binding constructs (for example "let x = e" in the
+     term "let x = e in body") that have both an exterior environment
+     G (the environment of the whole term "let x = e in body") and an
+     interior environment G' (the environment at the "in", after the
+     binding construct has introduced new names in scope).
+
+     For example, let-binding could be given the following rule:
+
+       G |- e : m + m'
+       -----------------------------------
+       G+G' |- (let x = e) : m -| x:m', G'
+
+     Checking the whole term composes this judgment
+     with the "G |- e : m" form for the let body:
+
+       G  |- (let x = e) : m -| G'
+       G' |- body : m
+       -------------------------------
+       G |- let x = e in body : m
+
+     To this judgment "G |- e : m -| G'" our implementation gives the
+     type [... -> Mode.t -> Env.t -> Env.t]: it takes the mode and
+     interior environment as inputs, and returns the exterior
+     environment.
+
+     We write [... -> bind_judg] in this case.
+*)
+type term_judg = Mode.t -> Env.t
+type bind_judg = Mode.t -> Env.t -> Env.t
+
+let option : 'a. ('a -> term_judg) -> 'a option -> term_judg =
+  fun f o m -> match o with
+    | None -> Env.empty
+    | Some v -> f v m
+let list : 'a. ('a -> term_judg) -> 'a list -> term_judg =
+  fun f li m ->
+    List.fold_left (fun env item -> Env.join env (f item m)) Env.empty li
+let array : 'a. ('a -> term_judg) -> 'a array -> term_judg =
+  fun f ar m ->
+    Array.fold_left (fun env item -> Env.join env (f item m)) Env.empty ar
+
+let single : Ident.t -> term_judg = Env.single
+let remove_id : Ident.t -> term_judg -> term_judg =
+  fun id f m -> Env.remove id (f m)
+let remove_ids : Ident.t list -> term_judg -> term_judg =
+  fun ids f m -> Env.remove_list ids (f m)
+
+let join : term_judg list -> term_judg =
+  fun li m -> Env.join_list (List.map (fun f -> f m) li)
+
+let empty = fun _ -> Env.empty
+
+(* A judgment [judg] takes a mode from the context as input, and
+   returns an environment. The judgment [judg << m], given a mode [m']
+   from the context, evaluates [judg] in the composed mode [m'[m]]. *)
+let (<<) : term_judg -> Mode.t -> term_judg =
+  fun f inner_mode -> fun outer_mode -> f (Mode.compose outer_mode inner_mode)
+
+(* A binding judgment [binder] expects a mode and an inner environment,
+   and returns an outer environment. [binder >> judg] computes
+   the inner environment as the environment returned by [judg]
+   in the ambient mode. *)
+let (>>) : bind_judg -> term_judg -> term_judg =
+  fun binder term mode -> binder mode (term mode)
+
+(* Expression judgment:
+     G |- e : m
+   where (m) is an input of the code and (G) is an output;
+   in the Prolog mode notation, this is (+G |- -e : -m).
+*)
+let rec expression : Typedtree.expression -> term_judg =
+  fun exp -> match exp.exp_desc with
+    | Texp_ident (pth, _, _) ->
+      path pth
+    | Texp_let (rec_flag, bindings, body) ->
+      (*
+         G  |- <bindings> : m -| G'
+         G' |- body : m
+         -------------------------------
+         G |- let <bindings> in body : m
+      *)
+      value_bindings rec_flag bindings >> expression body
+    | Texp_letmodule (x, _, _, mexp, e) ->
+      module_binding (x, mexp) >> expression e
+    | Texp_match (e, cases, _) ->
+      (*
+         (Gi; mi |- pi -> ei : m)^i
+         G |- e : sum(mi)^i
+         ----------------------------------------------
+         G + sum(Gi)^i |- match e with (pi -> ei)^i : m
+       *)
+      (fun mode ->
+        let pat_envs, pat_modes =
+          List.split (List.map (fun c -> case c mode) cases) in
+        let env_e = expression e (List.fold_left Mode.join Ignore pat_modes) in
+        Env.join_list (env_e :: pat_envs))
+    | Texp_for (_, _, low, high, _, body) ->
+      (*
+        G1 |- low: m[Dereference]
+        G2 |- high: m[Dereference]
+        G3 |- body: m[Guard]
+        ---
+        G1 + G2 + G3 |- for _ = low to high do body done: m
+      *)
+      join [
+        expression low << Dereference;
+        expression high << Dereference;
+        expression body << Guard;
+      ]
+    | Texp_constant _ ->
+      empty
+    | Texp_new (pth, _, _) ->
+      (*
+        G |- c: m[Dereference]
+        -----------------------
+        G |- new c: m
+      *)
+      path pth << Dereference
+    | Texp_instvar (self_path, pth, _inst_var) ->
+        join [path self_path << Dereference; path pth]
+    | Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, [_, Some arg])
+      when is_ref vd ->
+      (*
+        G |- e: m[Guard]
+        ------------------
+        G |- ref e: m
+      *)
+      expression arg << Guard
+    | Texp_apply (e, args)  ->
+        let arg (_, eo) = option expression eo in
+        let app_mode = if List.exists is_abstracted_arg args
+          then (* see the comment on Texp_apply in typedtree.mli;
+                  the non-abstracted arguments are bound to local
+                  variables, which corresponds to a Guard mode. *)
+            Guard
+          else Dereference
+        in
+        join [expression e; list arg args] << app_mode
+    | Texp_tuple exprs ->
+      list expression exprs << Guard
+    | Texp_array exprs ->
+      (*
+      let array_mode = match Typeopt.array_kind exp with
+        | Lambda.Pfloatarray ->
+            (* (flat) float arrays unbox their elements *)
+            Dereference
+        | Lambda.Pgenarray ->
+            (* This is counted as a use, because constructing a generic array
+               involves inspecting to decide whether to unbox (PR#6939). *)
+            Dereference
+        | Lambda.Paddrarray | Lambda.Pintarray ->
+            (* non-generic, non-float arrays act as constructors *)
+            Guard
+      in
+      *)
+      let array_mode =
+        (* FIXME MERLIN this is incorrect, but it won't report false positive, so it
+           will do for now. *)
+        Guard
+      in
+      list expression exprs << array_mode
+    | Texp_construct (_, desc, exprs) ->
+      let access_constructor =
+        match desc.cstr_tag with
+        | Cstr_extension (pth, _) ->
+          path pth << Dereference
+        | _ -> empty
+      in
+      let m' = match desc.cstr_tag with
+        | Cstr_unboxed ->
+          Return
+        | Cstr_constant _ | Cstr_block _ | Cstr_extension _ ->
+          Guard
+      in
+      join [
+        access_constructor;
+        list expression exprs << m'
+      ]
+    | Texp_variant (_, eo) ->
+      (*
+        G |- e: m[Guard]
+        ------------------   -----------
+        G |- `A e: m         [] |- `A: m
+      *)
+      option expression eo << Guard
+    | Texp_record { fields = es; extended_expression = eo;
+                    representation = rep } ->
+        let field_mode = match rep with
+          | Record_float -> Dereference
+          | Record_unboxed _ -> Return
+          | Record_regular | Record_inlined _
+          | Record_extension _ -> Guard
+        in
+        let field (_label, field_def) = match field_def with
+            Kept _ -> empty
+          | Overridden (_, e) -> expression e
+        in
+        join [
+          array field es << field_mode;
+          option expression eo << Dereference
+        ]
+    | Texp_ifthenelse (cond, ifso, ifnot) ->
+      (*
+        Gc |- c: m[Dereference]
+        G1 |- e1: m
+        G2 |- e2: m
+        ---
+        Gc + G1 + G2 |- if c then e1 else e2: m
+
+      Note: `if c then e1 else e2` is treated in the same way as
+      `match c with true -> e1 | false -> e2`
+      *)
+      join [
+        expression cond << Dereference;
+        expression ifso;
+        option expression ifnot;
+      ]
+    | Texp_setfield (e1, _, _, e2) ->
+      (*
+        G1 |- e1: m[Dereference]
+        G2 |- e2: m[Dereference]
+        ---
+        G1 + G2 |- e1.x <- e2: m
+
+        Note: e2 is dereferenced in the case of a field assignment to
+        a record of unboxed floats in that case, e2 evaluates to
+        a boxed float and it is unboxed on assignment.
+      *)
+      join [
+        expression e1 << Dereference;
+        expression e2 << Dereference;
+      ]
+    | Texp_sequence (e1, e2) ->
+      (*
+        G1 |- e1: m[Guard]
+        G2 |- e2: m
+        --------------------
+        G1 + G2 |- e1; e2: m
+
+        Note: `e1; e2` is treated in the same way as `let _ = e1 in e2`
+      *)
+      join [
+        expression e1 << Guard;
+        expression e2;
+      ]
+    | Texp_while (cond, body) ->
+      (*
+        G1 |- cond: m[Dereference]
+        G2 |- body: m[Guard]
+        ---------------------------------
+        G1 + G2 |- while cond do body done: m
+      *)
+      join [
+        expression cond << Dereference;
+        expression body << Guard;
+      ]
+    | Texp_send (e1, _, eo) ->
+      (*
+        G |- e: m[Dereference]
+        ---------------------- (plus weird 'eo' option)
+        G |- e#x: m
+      *)
+      join [
+        expression e1 << Dereference;
+        option expression eo << Dereference;
+      ]
+    | Texp_field (e, _, _) ->
+      (*
+        G |- e: m[Dereference]
+        -----------------------
+        G |- e.x: m
+      *)
+      expression e << Dereference
+    | Texp_setinstvar (pth,_,_,e) ->
+      (*
+        G |- e: m[Dereference]
+        ----------------------
+        G |- x <- e: m
+      *)
+      join [
+        path pth << Dereference;
+        expression e << Dereference;
+      ]
+    | Texp_letexception ({ext_id}, e) ->
+      (* G |- e: m
+         ----------------------------
+         G |- let exception A in e: m
+      *)
+      remove_id ext_id (expression e)
+    | Texp_assert e ->
+      (*
+        G |- e: m[Dereference]
+        -----------------------
+        G |- assert e: m
+
+        Note: `assert e` is treated just as if `assert` was a function.
+      *)
+      expression e << Dereference
+    | Texp_pack mexp ->
+      (*
+        G |- M: m
+        ----------------
+        G |- module M: m
+      *)
+      modexp mexp
+    | Texp_object (clsstrct, _) ->
+      class_structure clsstrct
+    | Texp_try (e, cases) ->
+      (*
+        G |- e: m      (Gi; _ |- pi -> ei : m)^i
+        --------------------------------------------
+        G + sum(Gi)^i |- try e with (pi -> ei)^i : m
+
+        Contrarily to match, the patterns p do not inspect
+        the value of e, so their mode does not influence the
+        mode of e.
+      *)
+      let case_env c m = fst (case c m) in
+      join [
+        expression e;
+        list case_env cases;
+      ]
+    | Texp_override (pth, fields) ->
+      (*
+         G |- pth : m   (Gi |- ei : m[Dereference])^i
+         ----------------------------------------------------
+         G + sum(Gi)^i |- {< (xi = ei)^i >} (at path pth) : m
+
+         Note: {< .. >} is desugared to a function application, but
+         the function implementation might still use its arguments in
+         a guarded way only -- intuitively it should behave as a constructor.
+         We could possibly refine the arguments' Dereference into Guard here.
+      *)
+      let field (_, _, arg) = expression arg in
+      join [
+        path pth << Dereference;
+        list field fields << Dereference;
+      ]
+    | Texp_function { cases } ->
+      (*
+         (Gi; _ |- pi -> ei : m[Delay])^i
+         --------------------------------------
+         sum(Gi)^i |- function (pi -> ei)^i : m
+
+         Contrarily to match, the value that is pattern-matched
+         is bound locally, so the pattern modes do not influence
+         the final environment.
+      *)
+      let case_env c m = fst (case c m) in
+      list case_env cases << Delay
+    | Texp_lazy e ->
+      (*
+        G |- e: m[Delay]
+        ----------------  (modulo some subtle compiler optimizations)
+        G |- lazy e: m
+      *)
+      let lazy_mode = match Typeopt.classify_lazy_argument e with
+        | `Constant_or_function
+        | `Identifier _
+        | `Float_that_cannot_be_shortcut ->
+          Return
+        | `Other ->
+          Delay
+      in
+      expression e << lazy_mode
+    | Texp_letop{let_; ands; body; _} ->
+        let case_env c m = fst (case c m) in
+        join [
+          list binding_op (let_ :: ands) << Dereference;
+          case_env body << Delay
+        ]
+    | Texp_unreachable ->
+      (*
+        ----------
+        [] |- .: m
+      *)
+      empty
+    | Texp_hole -> empty
+    | Texp_extension_constructor (_lid, pth) ->
+      path pth << Dereference
+    | Texp_open (od, e) ->
+      open_declaration od >> expression e
+
+and binding_op : Typedtree.binding_op -> term_judg =
+  fun bop ->
+    join [path bop.bop_op_path; expression bop.bop_exp]
+
+and class_structure : Typedtree.class_structure -> term_judg =
+  fun cs -> list class_field cs.cstr_fields
+
+and class_field : Typedtree.class_field -> term_judg =
+  fun cf -> match cf.cf_desc with
+    | Tcf_inherit (_, ce, _super, _inh_vars, _inh_meths) ->
+      class_expr ce << Dereference
+    | Tcf_val (_lab, _mut, _, cfk, _) ->
+      class_field_kind cfk
+    | Tcf_method (_, _, cfk) ->
+      class_field_kind cfk
+    | Tcf_constraint _ ->
+      empty
+    | Tcf_initializer e ->
+      expression e << Dereference
+    | Tcf_attribute _ ->
+      empty
+
+and class_field_kind : Typedtree.class_field_kind -> term_judg =
+  fun cfk -> match cfk with
+    | Tcfk_virtual _ ->
+      empty
+    | Tcfk_concrete (_, e) ->
+      expression e << Dereference
+
+and modexp : Typedtree.module_expr -> term_judg =
+  fun mexp -> match mexp.mod_desc with
+    | Tmod_ident (pth, _) ->
+      path pth
+    | Tmod_structure s ->
+      structure s
+    | Tmod_functor (_, e) ->
+      modexp e << Delay
+    | Tmod_apply (f, p, _) ->
+      join [
+        modexp f << Dereference;
+        modexp p << Dereference;
+      ]
+    | Tmod_constraint (mexp, _, _, coe) ->
+      let rec coercion coe k = match coe with
+        | Tcoerce_none ->
+          k Return
+        | Tcoerce_structure _
+        | Tcoerce_functor _ ->
+          (* These coercions perform a shallow copy of the input module,
+             by creating a new module with fields obtained by accessing
+             the same fields in the input module. *)
+           k Dereference
+        | Tcoerce_primitive _ ->
+          (* This corresponds to 'external' declarations,
+             and the coercion ignores its argument *)
+          k Ignore
+        | Tcoerce_alias (_, pth, coe) ->
+          (* Alias coercions ignore their arguments, but they evaluate
+             their alias module 'pth' under another coercion. *)
+          coercion coe (fun m -> path pth << m)
+      in
+      coercion coe (fun m -> modexp mexp << m)
+    | Tmod_unpack (e, _) ->
+      expression e
+    | Tmod_hole -> fun _ -> Env.empty
+
+
+(* G |- pth : m *)
+and path : Path.t -> term_judg =
+  (*
+    ------------
+    x: m |- x: m
+
+    G |- A: m[Dereference]
+    -----------------------
+    G |- A.x: m
+
+    G1 |- A: m[Dereference]
+    G2 |- B: m[Dereference]
+    ------------------------ (as for term application)
+    G1 + G2 |- A(B): m
+  *)
+  fun pth -> match pth with
+    | Path.Pident x ->
+        single x
+    | Path.Pdot (t, _) ->
+        path t << Dereference
+    | Path.Papply (f, p) ->
+        join [
+          path f << Dereference;
+          path p << Dereference;
+        ]
+
+(* G |- struct ... end : m *)
+and structure : Typedtree.structure -> term_judg =
+  (*
+    G1, {x: _, x in vars(G1)} |- item1: G2 + ... + Gn in m
+    G2, {x: _, x in vars(G2)} |- item2: G3 + ... + Gn in m
+    ...
+    Gn, {x: _, x in vars(Gn)} |- itemn: [] in m
+    ---
+    (G1 + ... + Gn) - V |- struct item1 ... itemn end: m
+  *)
+  fun s m ->
+    List.fold_right (fun it env -> structure_item it m env)
+      s.str_items Env.empty
+
+(* G |- <structure item> : m -| G'
+   where G is an output and m, G' are inputs *)
+and structure_item : Typedtree.structure_item -> bind_judg =
+  fun s m env -> match s.str_desc with
+    | Tstr_eval (e, _) ->
+      (*
+        Ge |- e: m[Guard]
+        G |- items: m -| G'
+        ---------------------------------
+        Ge + G |- (e;; items): m -| G'
+
+        The expression `e` is treated in the same way as let _ = e
+      *)
+      let judg_e = expression e << Guard in
+      Env.join (judg_e m) env
+    | Tstr_value (rec_flag, bindings) ->
+      value_bindings rec_flag bindings m env
+    | Tstr_module {mb_id; mb_expr} ->
+      module_binding (mb_id, mb_expr) m env
+    | Tstr_recmodule mbs ->
+      let bindings = List.map (fun {mb_id; mb_expr} -> (mb_id, mb_expr)) mbs in
+      recursive_module_bindings bindings m env
+    | Tstr_primitive _ ->
+      env
+    | Tstr_type _ ->
+      (*
+        -------------------
+        G |- type t: m -| G
+      *)
+      env
+    | Tstr_typext {tyext_constructors = exts; _} ->
+      let ext_ids = List.map (fun {ext_id = id; _} -> id) exts in
+      Env.join
+        (list extension_constructor exts m)
+        (Env.remove_list ext_ids env)
+    | Tstr_exception {tyexn_constructor = ext; _} ->
+      Env.join
+        (extension_constructor ext m)
+        (Env.remove ext.ext_id env)
+    | Tstr_modtype _
+    | Tstr_class_type _
+    | Tstr_attribute _ ->
+      env
+    | Tstr_open od ->
+      open_declaration od m env
+    | Tstr_class classes ->
+        let class_ids =
+          let class_id ({ci_id_class = id; _}, _) = id in
+          List.map class_id classes in
+        let class_declaration ({ci_expr; _}, _) m =
+          Env.remove_list class_ids (class_expr ci_expr m) in
+        Env.join
+          (list class_declaration classes m)
+          (Env.remove_list class_ids env)
+    | Tstr_include { incl_mod = mexp; incl_type = mty; _ } ->
+      let included_ids = List.map Types.signature_item_id mty in
+      Env.join (modexp mexp m) (Env.remove_list included_ids env)
+
+(* G |- module M = E : m -| G *)
+and module_binding : (Ident.t option * Typedtree.module_expr) -> bind_judg =
+  fun (id, mexp) m env ->
+      (*
+        GE |- E: m[mM + Guard]
+        -------------------------------------
+        GE + G |- module M = E : m -| M:mM, G
+      *)
+      let judg_E, env =
+        match id with
+        | None -> modexp mexp << Guard, env
+        | Some id ->
+          let mM, env = Env.take id env in
+          let judg_E = modexp mexp << (Mode.join mM Guard) in
+          judg_E, env
+      in
+      Env.join (judg_E m) env
+
+and open_declaration : Typedtree.open_declaration -> bind_judg =
+  fun { open_expr = mexp; open_bound_items = sg; _ } m env ->
+      let judg_E = modexp mexp in
+      let bound_ids = List.map Types.signature_item_id sg in
+      Env.join (judg_E m) (Env.remove_list bound_ids env)
+
+and recursive_module_bindings
+  : (Ident.t option * Typedtree.module_expr) list -> bind_judg =
+  fun m_bindings m env ->
+    let mids = List.filter_map fst m_bindings in
+    let binding (mid, mexp) m =
+      let judg_E =
+        match mid with
+        | None -> modexp mexp << Guard
+        | Some mid ->
+          let mM = Env.find mid env in
+          modexp mexp << (Mode.join mM Guard)
+      in
+      Env.remove_list mids (judg_E m)
+    in
+    Env.join (list binding m_bindings m) (Env.remove_list mids env)
+
+and class_expr : Typedtree.class_expr -> term_judg =
+  fun ce -> match ce.cl_desc with
+    | Tcl_ident (pth, _, _) ->
+        path pth << Dereference
+    | Tcl_structure cs ->
+        class_structure cs
+    | Tcl_fun (_, _, args, ce, _) ->
+        let ids = List.map fst args in
+        remove_ids ids (class_expr ce << Delay)
+    | Tcl_apply (ce, args) ->
+        let arg (_label, eo) = option expression eo in
+        join [
+          class_expr ce << Dereference;
+          list arg args << Dereference;
+        ]
+    | Tcl_let (rec_flag, bindings, _, ce) ->
+      value_bindings rec_flag bindings >> class_expr ce
+    | Tcl_constraint (ce, _, _, _, _) ->
+        class_expr ce
+    | Tcl_open (_, ce) ->
+        class_expr ce
+
+and extension_constructor : Typedtree.extension_constructor -> term_judg =
+  fun ec -> match ec.ext_kind with
+    | Text_decl _ ->
+      empty
+    | Text_rebind (pth, _lid) ->
+      path pth
+
+(* G |- let (rec?) (pi = ei)^i : m -| G' *)
+and value_bindings : rec_flag -> Typedtree.value_binding list -> bind_judg =
+  fun rec_flag bindings mode bound_env ->
+    let all_bound_pats = List.map (fun vb -> vb.vb_pat) bindings in
+    let outer_env = remove_patlist all_bound_pats bound_env in
+    let bindings_env =
+      match rec_flag with
+      | Nonrecursive ->
+        (*
+           (Gi, pi:_ |- ei : m[mbody_i])^i   (pi : mbody_i -| D)^i
+           ------------------------------------------------------------
+           Sum(Gi) + (D - (pi)^i) |- let (pi=ei)^i : m -| D
+        *)
+          let binding_env {vb_pat; vb_expr; _} m =
+            let m' = Mode.compose m (pattern vb_pat bound_env) in
+            remove_pat vb_pat (expression vb_expr m') in
+          list binding_env bindings mode
+      | Recursive ->
+        (*
+           (Gi, (xj : mdef_ij)^j |- ei : m[mbody_i])^i   (xi : mbody_i -| D)^i
+           G'i = Gi + mdef_ij[G'j]
+           -------------------------------------------------------------------
+           Sum(G'i) + (D - (pi)^i) |- let rec (xi=ei)^i : m -| D
+
+           The (mdef_ij)^i,j are a family of modes over two indices:
+           mdef_ij represents the mode of use, within e_i the definition of x_i,
+           of the mutually-recursive variable x_j.
+
+           The (G'i)^i are defined from the (Gi)^i as a family of equations,
+           whose smallest solution is computed as a least fixpoint.
+
+           The (Gi)^i are the "immediate" dependencies of each (ei)^i
+           on the outer context (excluding the mutually-defined
+           variables).
+           The (G'i)^i contain the "transitive" dependencies as well:
+           if ei depends on xj, then the dependencies of G'i of xi
+           must contain the dependencies of G'j, composed by
+           the mode mdef_ij of use of xj in ei.
+
+           For example, consider:
+
+             let rec z =
+               let rec x = ref y
+               and y = ref z
+               in f x
+
+           this definition should be rejected as the body [f x]
+           dereferences [x], which can be used to access the
+           yet-unitialized value [z]. This requires realizing that [x]
+           depends on [z] through [y], which requires the transitive
+           closure computation.
+
+           An earlier version of our check would take only the (Gi)^i
+           instead of the (G'i)^i, which is incorrect and would accept
+           the example above.
+        *)
+          (* [binding_env] takes a binding (x_i = e_i)
+             and computes (Gi, (mdef_ij)^j). *)
+          let binding_env {vb_pat = x_i; vb_expr = e_i; _} =
+            let mbody_i = pattern x_i bound_env in
+            (* Gi, (x_j:mdef_ij)^j  *)
+            let rhs_env_i = expression e_i (Mode.compose mode mbody_i) in
+            (* (mdef_ij)^j (for a fixed i) *)
+            let mutual_modes =
+              let mdef_ij {vb_pat = x_j; _} = pattern x_j rhs_env_i in
+              List.map mdef_ij bindings in
+            (* Gi *)
+            let env_i = remove_patlist all_bound_pats rhs_env_i in
+            (* (Gi, (mdef_ij)^j) *)
+            (env_i, mutual_modes) in
+          let env, mdef =
+            List.split (List.map binding_env bindings) in
+          let rec transitive_closure env =
+            let transitive_deps env_i mdef_i =
+              (* Gi, (mdef_ij)^j => Gi + Sum_j mdef_ij[Gj] *)
+              Env.join env_i
+                (Env.join_list (List.map2 Env.compose mdef_i env)) in
+            let env' = List.map2 transitive_deps env mdef in
+            if List.for_all2 Env.equal env env'
+            then env'
+            else transitive_closure env'
+          in
+          let env'_i = transitive_closure env in
+          Env.join_list env'_i
+    in Env.join bindings_env outer_env
+
+(* G; m' |- (p -> e) : m
+   with outputs G, m' and input m
+
+   m' is the mode under which the scrutinee of p
+   (the value matched against p) is placed.
+*)
+and case
+    : 'k . 'k Typedtree.case -> mode -> Env.t * mode
+  = fun { Typedtree.c_lhs; c_guard; c_rhs } ->
+    (*
+       Ge |- e : m    Gg |- g : m[Dereference]
+       G := Ge+Gg     p : mp -| G
+       ----------------------------------------
+       G - p; m[mp] |- (p (when g)? -> e) : m
+    *)
+    let judg = join [
+        option expression c_guard << Dereference;
+        expression c_rhs;
+      ] in
+    (fun m ->
+       let env = judg m in
+       (remove_pat c_lhs env), Mode.compose m (pattern c_lhs env))
+
+(* p : m -| G
+   with output m and input G
+
+   m is the mode under which the scrutinee of p is placed.
+*)
+and pattern : type k . k general_pattern -> Env.t -> mode = fun pat env ->
+  (*
+    mp := | Dereference if p is destructuring
+          | Guard       otherwise
+    me := sum{G(x), x in vars(p)}
+    --------------------------------------------
+    p : (mp + me) -| G
+  *)
+  let m_pat = if is_destructuring_pattern pat
+              then Dereference
+              else Guard
+  in
+  let m_env =
+    pat_bound_idents pat
+    |> List.map (fun id -> Env.find id env)
+    |> List.fold_left Mode.join Ignore
+  in
+  Mode.join m_pat m_env
+
+and is_destructuring_pattern : type k . k general_pattern -> bool =
+  fun pat -> match pat.pat_desc with
+    | Tpat_any -> false
+    | Tpat_var (_, _) -> false
+    | Tpat_alias (pat, _, _) -> is_destructuring_pattern pat
+    | Tpat_constant _ -> true
+    | Tpat_tuple _ -> true
+    | Tpat_construct _ -> true
+    | Tpat_variant _ -> true
+    | Tpat_record (_, _) -> true
+    | Tpat_array _ -> true
+    | Tpat_lazy _ -> true
+    | Tpat_value pat -> is_destructuring_pattern (pat :> pattern)
+    | Tpat_exception _ -> false
+    | Tpat_or (l,r,_) ->
+        is_destructuring_pattern l || is_destructuring_pattern r
+
+let is_valid_recursive_expression idlist expr =
+  let ty = expression expr Return in
+  match Env.unguarded ty idlist, Env.dependent ty idlist,
+        classify_expression expr with
+  | _ :: _, _, _ (* The expression inspects rec-bound variables *)
+  | [], _ :: _, Dynamic -> (* The expression depends on rec-bound variables
+                              and its size is unknown *)
+      false
+  | [], _, Static (* The expression has known size *)
+  | [], [], Dynamic -> (* The expression has unknown size,
+                          but does not depend on rec-bound variables *)
+      true
+
+(* A class declaration may contain let-bindings. If they are recursive,
+   their validity will already be checked by [is_valid_recursive_expression]
+   during type-checking. This function here prevents a different kind of
+   invalid recursion, which is the unsafe creations of objects of this class
+   in the let-binding. For example,
+   {|class a = let x = new a in object ... end|}
+   is forbidden, but
+   {|class a = let x () = new a in object ... end|}
+   is allowed.
+*)
+let is_valid_class_expr idlist ce =
+  let rec class_expr : mode -> Typedtree.class_expr -> Env.t =
+    fun mode ce -> match ce.cl_desc with
+      | Tcl_ident (_, _, _) ->
+        (*
+          ----------
+          [] |- a: m
+        *)
+        Env.empty
+      | Tcl_structure _ ->
+        (*
+          -----------------------
+          [] |- struct ... end: m
+        *)
+        Env.empty
+      | Tcl_fun (_, _, _, _, _) -> Env.empty
+        (*
+          ---------------------------
+          [] |- fun x1 ... xn -> C: m
+        *)
+      | Tcl_apply (_, _) -> Env.empty
+      | Tcl_let (rec_flag, bindings, _, ce) ->
+        value_bindings rec_flag bindings mode (class_expr mode ce)
+      | Tcl_constraint (ce, _, _, _, _) ->
+        class_expr mode ce
+      | Tcl_open (_, ce) ->
+        class_expr mode ce
+  in
+  match Env.unguarded (class_expr Return ce) idlist with
+  | [] -> true
+  | _ :: _ -> false
diff --git a/src/ocaml/typing/rec_check.mli b/src/ocaml/typing/rec_check.mli
new file mode 100644
index 0000000..aa5c1ca
--- /dev/null
+++ b/src/ocaml/typing/rec_check.mli
@@ -0,0 +1,19 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*               Jeremy Yallop, University of Cambridge                   *)
+(*                                                                        *)
+(*   Copyright 2017 Jeremy Yallop                                         *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+exception Illegal_expr
+
+val is_valid_recursive_expression : Ident.t list -> Typedtree.expression -> bool
+
+val is_valid_class_expr : Ident.t list -> Typedtree.class_expr -> bool
diff --git a/src/ocaml/typing/saved_parts.ml b/src/ocaml/typing/saved_parts.ml
new file mode 100644
index 0000000..47f980b
--- /dev/null
+++ b/src/ocaml/typing/saved_parts.ml
@@ -0,0 +1,27 @@
+let attribute = Location.mknoloc "merlin.saved-parts"
+
+module H = Ephemeron.K1.Make(struct
+    type t = string
+    let hash = Hashtbl.hash
+    let equal (a : t) (b : t) =  a = b
+  end)
+
+let table = H.create 7
+
+let gensym =
+  let counter = ref 0 in
+  fun () -> incr counter; !counter
+
+let store parts =
+  let id = string_of_int (gensym ()) in
+  let key = Parsetree.Pconst_integer (id, None) in
+  H.add table id parts;
+  key
+
+let find = function
+  | Parsetree.Pconst_integer (id, None) ->
+    begin
+      try H.find table id
+      with Not_found -> []
+    end
+  | _ -> assert false
diff --git a/src/ocaml/typing/saved_parts.mli b/src/ocaml/typing/saved_parts.mli
new file mode 100644
index 0000000..be1a206
--- /dev/null
+++ b/src/ocaml/typing/saved_parts.mli
@@ -0,0 +1,3 @@
+val attribute : string Location.loc
+val store : Cmt_format.binary_part list -> Parsetree.constant
+val find : Parsetree.constant -> Cmt_format.binary_part list
diff --git a/src/ocaml/typing/short_paths.ml b/src/ocaml/typing/short_paths.ml
new file mode 100644
index 0000000..efc423e
--- /dev/null
+++ b/src/ocaml/typing/short_paths.ml
@@ -0,0 +1,1932 @@
+
+open Short_paths_graph
+
+module Desc = Desc
+
+module Rev_deps : sig
+
+  type t
+
+  val create : unit -> t
+
+  val extend_up_to : t -> Dependency.t -> unit
+
+  val get : t -> Dependency.t -> Dependency.Set.t
+
+  val add : t -> source:Dependency.t -> target:Dependency.t -> unit
+
+  val add_alias : t -> source:Dependency.t -> target:Dependency.t -> unit
+
+  val before : t -> Origin.t -> Origin.t -> bool
+
+end = struct
+
+  module Stamp = Natural.Make()
+
+  type item =
+    { mutable set : Dependency.Set.t;
+      mutable edges : Dependency.t list;
+      mutable alias_edges : Dependency.t list;
+      mutable last : Stamp.t; }
+
+  type t =
+    { mutable stamp : Stamp.t;
+      mutable items : item Dependency.Array.t; }
+
+  let create () =
+    { stamp = Stamp.one;
+      items = Dependency.Array.empty; }
+
+  let extend_up_to t next =
+    match Dependency.pred next with
+    | None -> ()
+    | Some curr ->
+      if not (Dependency.Array.contains t.items curr) then begin
+        let items =
+          Dependency.Array.extend t.items curr
+            (fun _ -> { set = Dependency.Set.empty;
+                        edges = [];
+                        alias_edges = [];
+                        last = Stamp.zero; })
+        in
+        t.items <- items
+      end
+
+  let add t ~source ~target =
+    let item = Dependency.Array.get t.items source in
+    item.edges <- target :: item.edges;
+    t.stamp <- Stamp.succ t.stamp
+
+  let add_alias t ~source ~target =
+    let item = Dependency.Array.get t.items source in
+    item.alias_edges <- target :: item.alias_edges;
+    t.stamp <- Stamp.succ t.stamp
+
+  let update t dep item =
+    if Stamp.less_than item.last t.stamp then begin
+      let rec add_edges t item acc =
+        let rec loop t acc added = function
+          | [] ->
+              List.fold_left
+                (fun acc dep ->
+                   let item = Dependency.Array.get t.items dep in
+                   add_alias_edges t item acc)
+                acc added
+          | dep :: rest ->
+              if Dependency.Set.mem dep acc then loop t acc added rest
+              else begin
+                let acc = Dependency.Set.add dep acc in
+                let added = dep :: added in
+                loop t acc added rest
+              end
+        in
+        loop t acc [] item.edges
+      and add_alias_edges t item acc =
+        List.fold_left
+          (fun acc dep ->
+             if Dependency.Set.mem dep acc then acc
+             else begin
+               let acc = Dependency.Set.add dep acc in
+               let item = Dependency.Array.get t.items dep in
+               let acc = add_edges t item acc in
+               add_alias_edges t item acc
+             end)
+          acc item.alias_edges
+      in
+      let set = Dependency.Set.singleton dep in
+      let set = add_edges t item set in
+      let set = add_alias_edges t item set in
+      item.set <- set;
+      item.last <- t.stamp
+    end
+
+  let get t dep =
+    let item = Dependency.Array.get t.items dep in
+    update t dep item;
+    item.set
+
+  let before t origin1 origin2 =
+    let open Origin in
+    match origin1, origin2 with
+    | Environment age1, Environment age2 -> Age.less_than age1 age2
+    | Environment _, Dependency _ -> false
+    | Environment _, Dependencies _ -> false
+    | Dependency _, Environment _ -> true
+    | Dependency dep1, Dependency dep2 ->
+        let rev_dep = get t dep1 in
+        Dependency.Set.mem dep2 rev_dep
+    | Dependency dep1, Dependencies deps2 ->
+        let rev_dep = get t dep1 in
+        List.exists
+          (fun dep2 -> Dependency.Set.mem dep2 rev_dep)
+          deps2
+    | Dependencies _, Environment _ -> true
+    | Dependencies deps1, Dependency dep2 ->
+        List.for_all
+          (fun dep1 -> Dependency.Set.mem dep2 (get t dep1))
+          deps1
+    | Dependencies deps1, Dependencies deps2 ->
+        let rev_dep =
+          match deps1 with
+          | [] -> failwith "Rev_deps.before: invalid origin"
+          | dep1 :: deps1 ->
+              List.fold_left
+                (fun acc dep1 -> Dependency.Set.inter acc (get t dep1))
+                (get t dep1) deps1
+        in
+        List.exists
+          (fun dep2 -> Dependency.Set.mem dep2 rev_dep)
+          deps2
+
+end
+
+module Origin_range_tbl = struct
+
+  type 'a t =
+    { mutable envs : 'a list Age.Map.t;
+      mutable dep_keys : Dependency.Set.t;
+      deps : 'a list Dependency.Tbl.t; }
+
+  let create () =
+    { envs = Age.Map.empty;
+      dep_keys = Dependency.Set.empty;
+      deps = Dependency.Tbl.create 0; }
+
+  let add_dependency dep data t =
+    t.dep_keys <- Dependency.Set.add dep t.dep_keys;
+    let prev =
+      match Dependency.Tbl.find t.deps dep with
+      | exception Not_found -> []
+      | prev -> prev
+    in
+    Dependency.Tbl.replace t.deps dep (data :: prev)
+
+  let add_age age data t =
+    let prev =
+      match Age.Map.find age t.envs with
+      | exception Not_found -> []
+      | prev -> prev
+    in
+    t.envs <- Age.Map.add age (data :: prev) t.envs
+
+  let add rev_deps origin data t =
+    match origin with
+    | Origin.Dependency dep -> add_dependency dep data t
+    | Origin.Environment age -> add_age age data t
+    | Origin.Dependencies deps -> begin
+        let rev_dep_opt =
+          List.fold_left
+            (fun acc dep ->
+               let rev_dep = Rev_deps.get rev_deps dep in
+               match acc with
+               | None -> Some rev_dep
+               | Some acc -> Some (Dependency.Set.inter acc rev_dep))
+            None deps
+        in
+        let rev_dep =
+          match rev_dep_opt with
+          | None -> failwith "Origin_range_tbl.add: invalid origin"
+          | Some rev_dep -> rev_dep
+        in
+        match
+          List.find
+            (fun dep -> Dependency.Set.mem dep rev_dep)
+            deps
+        with
+        | dep -> add_dependency dep data t
+        | exception Not_found ->
+          match Dependency.Set.choose rev_dep with
+          | dep -> add_dependency dep data t
+          | exception Not_found -> add_age Age.zero data t
+      end
+
+  let pop_dependency rev_dep t =
+    let matching = Dependency.Set.inter rev_dep t.dep_keys in
+    t.dep_keys <- Dependency.Set.diff t.dep_keys matching;
+    let items =
+      Dependency.Set.fold
+        (fun dep acc ->
+           let data = Dependency.Tbl.find t.deps dep in
+           Dependency.Tbl.remove t.deps dep;
+           List.rev_append data acc)
+        matching
+        []
+    in
+    let items =
+      Age.Map.fold
+        (fun _ data acc -> List.rev_append data acc)
+        t.envs items
+    in
+    t.envs <- Age.Map.empty;
+    items
+
+  let pop_age age t =
+    let envs, first, matching = Age.Map.split age t.envs in
+    let items =
+      match first with
+      | None -> []
+      | Some first -> first
+    in
+    let items =
+      Age.Map.fold
+        (fun _ data acc -> List.rev_append data acc)
+        matching items
+    in
+    t.envs <- envs;
+    items
+
+  let pop rev_deps origin t =
+    match origin with
+    | Origin.Dependency dep ->
+        let rev_dep = Rev_deps.get rev_deps dep in
+        pop_dependency rev_dep t
+    | Origin.Dependencies deps ->
+        let rev_dep_opt =
+          List.fold_left
+            (fun acc dep ->
+               let rev_dep = Rev_deps.get rev_deps dep in
+               match acc with
+               | None -> Some rev_dep
+               | Some acc -> Some (Dependency.Set.inter acc rev_dep))
+            None deps
+        in
+        let rev_dep =
+          match rev_dep_opt with
+          | None -> failwith "Origin_range_tbl.pop: invalid origin"
+          | Some rev_dep -> rev_dep
+        in
+        pop_dependency rev_dep t
+    | Origin.Environment age ->
+        pop_age age t
+
+  let is_origin_empty rev_deps origin t =
+    match origin with
+    | Origin.Dependency dep ->
+        if not (Age.Map.is_empty t.envs) then false
+        else begin
+          let rev_dep = Rev_deps.get rev_deps dep in
+          let matching = Dependency.Set.inter rev_dep t.dep_keys in
+          Dependency.Set.is_empty matching
+        end
+    | Origin.Dependencies deps ->
+        if not (Age.Map.is_empty t.envs) then false
+        else begin
+          let rev_dep_opt =
+            List.fold_left
+              (fun acc dep ->
+                 let rev_dep = Rev_deps.get rev_deps dep in
+                 match acc with
+                 | None -> Some rev_dep
+                 | Some acc -> Some (Dependency.Set.inter acc rev_dep))
+              None deps
+          in
+          let rev_dep =
+            match rev_dep_opt with
+            | None ->
+                failwith "Origin_range_tbl.is_origin_empty: invalid origin"
+            | Some rev_dep -> rev_dep
+          in
+          let matching = Dependency.Set.inter rev_dep t.dep_keys in
+          Dependency.Set.is_empty matching
+        end
+    | Origin.Environment age ->
+        match Age.Map.max_binding t.envs with
+        | exception Not_found -> true
+        | (max, _) -> Age.less_than max age
+
+  let is_completely_empty t =
+    Age.Map.is_empty t.envs
+    && Dependency.Set.is_empty t.dep_keys
+
+end
+
+module Height = Natural.Make_no_zero()
+
+module Todo = struct
+
+  module Item = struct
+
+    type t =
+      | Base of Diff.Item.t
+      | Children of
+          { md : Module.t;
+            path : Path.t;
+            seen : Path_set.t; }
+      | Update of
+          { id : Ident.t;
+            origin : Origin.t; }
+      | Forward of
+          { id : Ident.t;
+            decl : Origin.t;
+            origin : Origin.t; }
+
+  end
+
+  type t =
+    { mutable table : Item.t Origin_range_tbl.t Height.Array.t }
+
+  let create graph rev_deps diff =
+    let tbl = Origin_range_tbl.create () in
+    List.iter
+      (fun item ->
+         let origin = Diff.Item.origin graph item in
+         match Diff.Item.previous graph item with
+         | None ->
+             Origin_range_tbl.add rev_deps origin (Item.Base item) tbl;
+         | Some decl ->
+             let id = Diff.Item.id graph item in
+             let item = Item.Forward { id; decl; origin } in
+             Origin_range_tbl.add rev_deps origin item tbl)
+      diff;
+    let table = Height.Array.singleton tbl in
+    { table }
+
+  let get_table t height =
+    if not (Height.Array.contains t.table height) then begin
+      t.table <- Height.Array.extend t.table height
+                   (fun _ -> Origin_range_tbl.create ());
+    end;
+    Height.Array.get t.table height
+
+  let get_table_opt t height =
+    if Height.Array.contains t.table height then
+      Some (Height.Array.get t.table height)
+    else None
+
+  let retract_empty t =
+    let rec loop height =
+      match Height.pred height with
+      | None ->
+          t.table <- Height.Array.empty
+      | Some prev ->
+          let tbl = Height.Array.get t.table prev in
+          if Origin_range_tbl.is_completely_empty tbl then loop prev
+          else begin
+            t.table <- Height.Array.retract t.table height
+          end
+    in
+    match Height.Array.last t.table with
+    | None -> ()
+    | Some last ->
+      let tbl = Height.Array.get t.table last in
+      if Origin_range_tbl.is_completely_empty tbl then loop last
+      else ()
+
+  let merge graph rev_deps t diff =
+    let tbl = get_table t Height.one in
+    List.iter
+      (fun item ->
+         match Diff.Item.previous graph item with
+         | None -> ()
+         | Some origin ->
+             let id = Diff.Item.id graph item in
+             let item = Item.Update { id; origin } in
+             Origin_range_tbl.add rev_deps origin item tbl)
+      diff
+
+  let mutate graph rev_deps t diff =
+    let tbl = get_table t Height.one in
+    List.iter
+      (fun item ->
+         match Diff.Item.previous graph item with
+         | None ->
+             let origin = Diff.Item.origin graph item in
+             Origin_range_tbl.add rev_deps origin (Item.Base item) tbl;
+         | Some origin ->
+             let id = Diff.Item.id graph item in
+             let item = Item.Update { id; origin } in
+             Origin_range_tbl.add rev_deps origin item tbl)
+      diff
+
+  let add_children graph rev_deps t height md path seen =
+    let height = Height.succ height in
+    let tbl = get_table t height in
+    let origin = Module.origin graph md in
+    Origin_range_tbl.add rev_deps origin (Item.Children{md; path; seen}) tbl
+
+  let add_next_update rev_deps t height origin id =
+    let height = Height.succ height in
+    let tbl = get_table t height in
+    let item = Item.Update { id; origin } in
+    Origin_range_tbl.add rev_deps origin item tbl
+
+  let add_next_forward rev_deps t height origin id decl =
+    let height = Height.succ height in
+    let tbl = get_table t height in
+    let item = Item.Forward { id; decl; origin } in
+    Origin_range_tbl.add rev_deps origin item tbl
+
+  let rec is_empty_from rev_deps t height origin =
+    match get_table_opt t height with
+    | None -> true
+    | Some tbl ->
+        Origin_range_tbl.is_origin_empty rev_deps origin tbl
+        && is_empty_from rev_deps t (Height.succ height) origin
+
+  let pop rev_deps t height origin =
+    match get_table_opt t height with
+    | None ->
+        retract_empty t;
+        None
+    | Some tbl ->
+      match Origin_range_tbl.pop rev_deps origin tbl with
+      | [] ->
+          let empty_from =
+            is_empty_from rev_deps t (Height.succ height) origin
+          in
+          if not empty_from then Some []
+          else begin
+            retract_empty t;
+            None
+          end
+      | _ :: _ as todo -> Some todo
+
+end
+
+module Forward_path_map : sig
+
+  type 'a t
+
+  val empty : 'a t
+
+  val add : 'a t -> Sort.t -> Path.t -> 'a -> 'a t
+
+  val find : 'a t -> Path.t -> 'a list
+
+  val rebase : 'a t -> 'a t -> 'a t
+
+  val iter_forwards : (Path.t -> 'a -> unit) -> 'a t -> Ident.t -> unit
+
+  val iter_updates : (Path.t -> 'a -> unit) -> 'a t -> Ident.t -> unit
+
+end = struct
+
+  type 'a t =
+    { new_paths : 'a list Path_map.t;
+      old_paths : 'a list Path_map.t;
+      updates : Path_set.t Ident_map.t;
+      forwards : Path_set.t Ident_map.t; }
+
+  let empty =
+    { new_paths = Path_map.empty;
+      old_paths = Path_map.empty;
+      forwards = Ident_map.empty;
+      updates = Ident_map.empty; }
+
+  let add t sort path data =
+    let new_paths = t.new_paths in
+    let prev =
+      match Path_map.find path new_paths with
+      | prev -> prev
+      | exception Not_found -> []
+    in
+    let new_paths = Path_map.add path (data :: prev) new_paths in
+    let updates = t.updates in
+    let updates =
+      match sort with
+      | Sort.Defined -> updates
+      | Sort.Declared ids ->
+          Ident_set.fold
+            (fun id acc ->
+               let prev =
+                 match Ident_map.find id updates with
+                 | prev -> prev
+                 | exception Not_found -> Path_set.empty
+               in
+               Ident_map.add id (Path_set.add path prev) acc)
+            ids updates
+    in
+    { t with new_paths; updates }
+
+  let find t path =
+    match Path_map.find path t.new_paths with
+    | exception Not_found -> Path_map.find path t.old_paths
+    | new_paths ->
+      match Path_map.find path t.old_paths with
+      | exception Not_found -> new_paths
+      | old_paths -> new_paths @ old_paths
+
+  let rebase t base =
+    let old_paths =
+      Path_map.union
+        (fun _ paths1 paths2 -> Some (paths1 @ paths2))
+        base.new_paths base.old_paths
+    in
+    let forwards =
+      Ident_map.union
+        (fun _ pset1 pset2 -> Some (Path_set.union pset1 pset2))
+        base.updates base.forwards
+    in
+    { t with old_paths; forwards }
+
+  let iter_updates f t id =
+    match Ident_map.find id t.updates with
+    | exception Not_found -> ()
+    | pset ->
+        Path_set.iter
+          (fun path ->
+             match Path_map.find path t.new_paths with
+             | exception Not_found -> ()
+             | paths -> List.iter (f path) paths)
+          pset
+
+  let iter_forwards f t id =
+    match Ident_map.find id t.forwards with
+    | exception Not_found -> ()
+    | pset ->
+        Path_set.iter
+          (fun path ->
+             match Path_map.find path t.old_paths with
+             | exception Not_found -> ()
+             | paths -> List.iter (f path) paths)
+          pset
+
+end
+
+module Origin_tbl = Hashtbl.Make(Origin)
+
+module History : sig
+
+  module Stamp : Natural.S
+
+  module Revision : sig
+
+    type t
+
+    val stamp : t -> Stamp.t
+
+    val diff : t -> Diff.t
+
+    val rev_deps : t -> Rev_deps.t
+
+    val next : t -> t option
+
+  end
+
+  type t
+
+  val init : Rev_deps.t ->  Diff.t -> t
+
+  val head : t -> Revision.t
+
+  val commit : t -> Rev_deps.t ->  Diff.t -> unit
+
+end = struct
+
+  module Stamp = Natural.Make()
+
+  module Revision = struct
+
+    type t =
+      { stamp : Stamp.t;
+        diff :  Diff.t;
+        rev_deps : Rev_deps.t;
+        mutable next : t option; }
+
+    let stamp t = t.stamp
+
+    let diff t = t.diff
+
+    let rev_deps t = t.rev_deps
+
+    let next t = t.next
+
+  end
+
+  type t =
+    { mutable head : Revision.t; }
+
+  let init rev_deps diff =
+    let stamp = Stamp.zero in
+    let next = None in
+    let head = { Revision.stamp; diff; rev_deps; next } in
+    { head }
+
+  let head t = t.head
+
+  let commit t rev_deps diff =
+    let head = t.head in
+    let stamp = Stamp.succ head.Revision.stamp in
+    let next = None in
+    let rev = { Revision.stamp; diff; rev_deps; next } in
+    head.Revision.next <- Some rev;
+    t.head <- rev
+
+end
+
+type type_resolution =
+  | Nth of int
+  | Subst of int list
+  | Id
+
+type type_result =
+  | Nth of int
+  | Path of int list option * Path.t
+
+type class_type_result = int list option * Path.t
+
+module Shortest = struct
+
+  module Section = struct
+
+    type t =
+      { mutable types : Path.t Forward_path_map.t;
+        mutable class_types : Path.t Forward_path_map.t;
+        mutable module_types : Path.t Forward_path_map.t;
+        mutable modules : (Path.t * Path_set.t) Forward_path_map.t; }
+
+    let create () =
+      let types = Forward_path_map.empty in
+      let class_types = Forward_path_map.empty in
+      let module_types = Forward_path_map.empty in
+      let modules = Forward_path_map.empty in
+      { types; class_types; module_types; modules }
+
+    let add_type graph t typ path =
+      let canonical = Type.path graph typ in
+      let sort = Type.sort graph typ in
+      t.types <- Forward_path_map.add t.types sort canonical path
+
+    let add_class_type graph t mty path =
+      let canonical = Class_type.path graph mty in
+      let sort = Class_type.sort graph mty in
+      t.class_types <- Forward_path_map.add t.class_types sort canonical path
+
+    let add_module_type graph t mty path =
+      let canonical = Module_type.path graph mty in
+      let sort = Module_type.sort graph mty in
+      t.module_types <- Forward_path_map.add t.module_types sort canonical path
+
+    let add_module graph t md path =
+      let canonical = Module.path graph md in
+      let sort = Module.sort graph md in
+      t.modules <- Forward_path_map.add t.modules sort canonical path
+
+    let rebase t parent =
+      t.types <- Forward_path_map.rebase t.types parent.types;
+      t.class_types <- Forward_path_map.rebase t.class_types parent.class_types;
+      t.module_types <- Forward_path_map.rebase t.module_types parent.module_types;
+      t.modules <- Forward_path_map.rebase t.modules parent.modules
+
+    let iter_updates ~type_ ~class_type ~module_type ~module_ t id =
+      Forward_path_map.iter_updates type_ t.types id;
+      Forward_path_map.iter_updates class_type t.class_types id;
+      Forward_path_map.iter_updates module_type t.module_types id;
+      Forward_path_map.iter_updates module_ t.modules id
+
+    let iter_forwards ~type_ ~class_type ~module_type ~module_ t id =
+      Forward_path_map.iter_forwards type_ t.types id;
+      Forward_path_map.iter_forwards class_type t.class_types id;
+      Forward_path_map.iter_forwards module_type t.module_types id;
+      Forward_path_map.iter_forwards module_ t.modules id
+
+    let find_type graph t typ =
+      let canonical = Type.path graph typ in
+      Forward_path_map.find t.types canonical
+
+    let find_class_type graph t mty =
+      let canonical = Class_type.path graph mty in
+      Forward_path_map.find t.class_types canonical
+
+    let find_module_type graph t mty =
+      let canonical = Module_type.path graph mty in
+      Forward_path_map.find t.module_types canonical
+
+    let find_module graph t md =
+      let canonical = Module.path graph md in
+      Forward_path_map.find t.modules canonical
+
+  end
+
+  module Sections = struct
+
+    type range =
+      | Until of Height.t
+      | All
+
+    type versioning =
+      | Unversioned
+      | Initialisation of History.Stamp.t
+      | Completion of History.Stamp.t
+
+    type t =
+      { mutable sections : Section.t Height.Array.t;
+        mutable initialised : range;
+        mutable completed : range;
+        mutable versioning : versioning; }
+
+    let create age origin =
+      let sections = Height.Array.empty in
+      let completed = Until Height.one in
+      let initialised, versioning =
+        if Age.equal age Age.zero then begin
+          All, Completion History.Stamp.zero
+        end else begin
+          match origin with
+          | Origin.Environment age' ->
+              let initialised =
+                if Age.less_than_or_equal age age' then All
+                else Until Height.one
+              in
+              initialised, Unversioned
+          | Origin.Dependency _ | Origin.Dependencies _ ->
+              Until Height.one, Initialisation History.Stamp.zero
+        end
+      in
+      { sections; initialised; completed; versioning; }
+
+    let update t stamp =
+      match t.versioning with
+      | Unversioned -> ()
+      | Initialisation initialised ->
+          if History.Stamp.less_than initialised stamp then begin
+            t.initialised <- Until Height.one;
+            t.versioning <- Initialisation stamp
+          end
+      | Completion completed ->
+          if History.Stamp.less_than completed stamp then begin
+            t.completed <- Until Height.one;
+            t.versioning <- Completion stamp
+          end
+
+    let expand t height =
+      let sections = t.sections in
+      if not (Height.Array.contains sections height) then begin
+        let sections =
+          Height.Array.extend sections height
+            (fun _ -> Section.create ())
+        in
+        t.sections <- sections;
+        sections
+      end else begin
+        sections
+      end
+
+    let is_initialised t height =
+      match t.initialised with
+      | All -> true
+      | Until until -> Height.less_than height until
+
+    let set_initialised t height =
+      match t.initialised with
+      | All ->
+          failwith "Section.set_initialised: already initialised"
+      | Until until ->
+          if not (Height.equal until height) then begin
+            if Height.less_than until height then
+              failwith "Section.set_initialised: initialised early"
+            else
+              failwith "Section.set_initialised: already initialised"
+          end;
+          t.initialised <- Until (Height.succ until)
+
+    let set_initialised_from t height =
+      match t.initialised with
+      | All ->
+          failwith "Section.set_initialised: already initialised"
+      | Until until ->
+          if not (Height.equal until height) then begin
+            if Height.less_than until height then
+              failwith "Section.set_initialised: initialised early"
+            else
+              failwith "Section.set_initialised: already initialised"
+          end;
+          t.initialised <- All
+
+    let is_completed t height =
+      match t.completed with
+      | All -> true
+      | Until until -> Height.less_than height until
+
+    let set_completed t height =
+      match t.completed with
+      | All ->
+          failwith "Section.set_completed: already completed"
+      | Until until ->
+          if not (Height.equal until height) then begin
+            if Height.less_than until height then
+              failwith "Section.set_completed: completed early"
+            else
+              failwith "Section.set_completed: already completed"
+          end;
+          t.completed <- Until (Height.succ until)
+
+    let set_completed_from t height =
+      match t.completed with
+      | All ->
+          failwith "Section.set_completed: already completed"
+      | Until until ->
+          if not (Height.equal until height) then begin
+            if Height.less_than until height then
+              failwith "Section.set_completed: completed early"
+            else
+              failwith "Section.set_completed: already completed"
+          end;
+          t.completed <- All
+
+    let is_finished t =
+      match t.initialised, t.completed with
+      | All, All -> true
+      | _, _ -> false
+
+    let get t height =
+      let sections = t.sections in
+      if Height.Array.contains sections height then
+        Some (Height.Array.get sections height)
+      else None
+
+    let check_initialised t height =
+      match t.initialised with
+      | All -> ()
+      | Until until ->
+          if not (Height.less_than height until) then
+            failwith "Sections: section not initialised"
+
+    let check_completed t height =
+      match t.completed with
+      | All -> ()
+      | Until until ->
+          if not (Height.less_than height until) then
+            failwith "Sections: section not completed"
+
+    let check_versions t parent =
+      match t.versioning, parent.versioning with
+      | Unversioned, _ | _, Unversioned -> ()
+      | (Completion stamp | Initialisation stamp),
+        (Completion parent_stamp | Initialisation parent_stamp) ->
+          if not (History.Stamp.equal stamp parent_stamp) then
+            failwith "Sections: version mismatch"
+
+    let initialise t height parent =
+      check_versions t parent;
+      check_completed parent height;
+      match get parent height with
+      | Some parent ->
+          let sections = expand t height in
+          let section = Height.Array.get sections height in
+          Section.rebase section parent;
+          set_initialised t height
+      | None ->
+          if is_finished parent then
+            set_initialised_from t height
+          else
+            set_initialised t height
+
+    let add_type graph t height typ path =
+      let sections = expand t height in
+      let section = Height.Array.get sections height in
+      Section.add_type graph section typ path
+
+    let add_class_type graph t height mty path =
+      let sections = expand t height in
+      let section = Height.Array.get sections height in
+      Section.add_class_type graph section mty path
+
+    let add_module_type graph t height mty path =
+      let sections = expand t height in
+      let section = Height.Array.get sections height in
+      Section.add_module_type graph section mty path
+
+    let add_module graph t height md path =
+      let sections = expand t height in
+      let section = Height.Array.get sections height in
+      Section.add_module graph section md path
+
+    (* returns [true] if there might be updated paths at a greater height. *)
+    let iter_updates ~type_ ~class_type ~module_type ~module_ t height id =
+      match get t height with
+      | Some section ->
+          Section.iter_updates ~type_ ~class_type
+            ~module_type ~module_ section id;
+          true
+      | None -> false
+
+    (* returns [true] if there might be forward paths at a greater height. *)
+    let iter_forwards ~type_ ~class_type ~module_type ~module_ t height id =
+      let all_initialised =
+        match t.initialised with
+        | All -> true
+        | Until until ->
+            if not (Height.less_than height until) then
+              failwith "Sections.iter_forwards: section not initialised";
+            false
+      in
+      match get t height with
+      | Some section ->
+          Section.iter_forwards ~type_ ~class_type
+            ~module_type ~module_ section id;
+          true
+      | None -> not all_initialised
+
+    type result =
+      | Not_found_here
+      | Not_found_here_or_later
+      | Found of Path.t
+
+    let rec get_visible_type graph = function
+      | [] -> None
+      | path :: rest ->
+          let visible = Graph.is_type_path_visible graph path in
+          if visible then Some path
+          else get_visible_type graph rest
+
+    let rec get_visible_class_type graph = function
+      | [] -> None
+      | path :: rest ->
+          let visible = Graph.is_class_type_path_visible graph path in
+          if visible then Some path
+          else get_visible_class_type graph rest
+
+    let rec get_visible_module_type graph = function
+      | [] -> None
+      | path :: rest ->
+          let visible = Graph.is_module_type_path_visible graph path in
+          if visible then Some path
+          else get_visible_module_type graph rest
+
+    let rec get_visible_module graph = function
+      | [] -> None
+      | (path, _) :: rest ->
+          let visible = Graph.is_module_path_visible graph path in
+          if visible then Some path
+          else get_visible_module graph rest
+
+    let find_type graph t height typ =
+      check_initialised t height;
+      check_completed t height;
+      match get t height with
+      | Some section -> begin
+          match Section.find_type graph section typ with
+          | exception Not_found -> Not_found_here
+          | paths -> begin
+              match get_visible_type graph paths with
+              | None -> Not_found_here
+              | Some path -> Found path
+            end
+        end
+      | None ->
+          if is_finished t then Not_found_here_or_later
+          else Not_found_here
+
+    let find_class_type graph t height mty =
+      check_initialised t height;
+      check_completed t height;
+      match get t height with
+      | Some section -> begin
+          match Section.find_class_type graph section mty with
+          | exception Not_found -> Not_found_here
+          | paths -> begin
+              match get_visible_class_type graph paths with
+              | None -> Not_found_here
+              | Some path -> Found path
+            end
+        end
+      | None ->
+          if is_finished t then Not_found_here_or_later
+          else Not_found_here
+
+    let find_module_type graph t height mty =
+      check_initialised t height;
+      check_completed t height;
+      match get t height with
+      | Some section -> begin
+          match Section.find_module_type graph section mty with
+          | exception Not_found -> Not_found_here
+          | paths -> begin
+              match get_visible_module_type graph paths with
+              | None -> Not_found_here
+              | Some path -> Found path
+            end
+        end
+      | None ->
+          if is_finished t then Not_found_here_or_later
+          else Not_found_here
+
+    let find_module graph t height md =
+      check_initialised t height;
+      check_completed t height;
+      match get t height with
+      | Some section -> begin
+          match Section.find_module graph section md with
+          | exception Not_found -> Not_found_here
+          | paths -> begin
+              match get_visible_module graph paths with
+              | None -> Not_found_here
+              | Some path -> Found path
+            end
+        end
+      | None ->
+          if is_finished t then Not_found_here_or_later
+          else Not_found_here
+
+  end
+
+  type basis
+
+  type env
+
+  type _ kind =
+    | Basis :
+        { history : History.t; }
+      -> basis kind
+    | Env :
+        { mutable revision : History.Revision.t;
+          parent : 'a t;
+          age : Age.t; }
+      -> env kind
+
+  and 'a t =
+    { kind : 'a kind;
+      mutable graph : Graph.t;
+      sections: Sections.t Origin_tbl.t;
+      todos: Todo.t; }
+
+  let age (type k) (t : k t) =
+    match t.kind with
+    | Basis _ -> Age.zero
+    | Env { age; _ } -> age
+
+  let revision (type k) (t : k t) =
+    match t.kind with
+    | Basis { history } -> History.head history
+    | Env { revision; _ } -> revision
+
+  let stamp t =
+    History.Revision.stamp (revision t)
+
+  let rev_deps t =
+    History.Revision.rev_deps (revision t)
+
+  let update (type kind) (t : kind t) =
+    match t.kind with
+    | Basis _ -> ()
+    | Env ({ revision } as e) ->
+        let rec loop graph revision =
+          let next = History.Revision.next revision in
+          match next with
+          | None -> revision, graph
+          | Some revision ->
+              let diff = History.Revision.diff revision in
+              let graph = Graph.merge graph diff in
+              let rev_deps = History.Revision.rev_deps revision in
+              Todo.merge graph rev_deps t.todos diff;
+              loop graph revision
+        in
+        let revision, graph = loop t.graph revision in
+        t.graph <- graph;
+        e.revision <- revision
+
+  let basis rev_deps components =
+    let graph, diff = Graph.add Graph.empty components in
+    let history = History.init rev_deps diff in
+    let kind = Basis { history } in
+    let sections = Origin_tbl.create 0 in
+    let todos = Todo.create graph rev_deps diff in
+    { kind; graph; sections; todos }
+
+  let local_or_open conc =
+    match conc with
+    | Desc.Local -> Component.Local
+    | Desc.Open -> Component.Open
+
+  let env parent desc =
+    update parent;
+    let age = Age.succ (age parent) in
+    let origin = Origin.Environment age in
+    let components =
+      List.map
+        (fun desc ->
+           match desc with
+           | Desc.Type(id, desc, conc, dpr) ->
+               Component.Type(origin, id, desc, local_or_open conc, dpr)
+           | Desc.Class_type(id, desc, conc, dpr) ->
+               Component.Class_type(origin, id, desc, local_or_open conc, dpr)
+           | Desc.Module_type(id, desc, conc, dpr) ->
+               Component.Module_type(origin, id, desc, local_or_open conc, dpr)
+           | Desc.Module(id, desc, conc, dpr) ->
+               Component.Module(origin, id, desc, local_or_open conc, dpr)
+           | Desc.Declare_type id ->
+               Component.Declare_type(origin, id)
+           | Desc.Declare_class_type id ->
+               Component.Declare_class_type(origin, id)
+           | Desc.Declare_module_type id ->
+               Component.Declare_module_type(origin, id)
+           | Desc.Declare_module id ->
+               Component.Declare_module(origin, id))
+        desc
+    in
+    let graph, diff = Graph.add parent.graph components in
+    let revision = revision parent in
+    let kind = Env { revision; parent; age } in
+    let sections = Origin_tbl.create 0 in
+    let rev_deps = History.Revision.rev_deps revision in
+    let todos = Todo.create graph rev_deps diff in
+    { kind; graph; sections; todos }
+
+  let mutate (t : basis t) rev_deps components =
+    let graph, diff = Graph.add t.graph components in
+    let Basis { history } = t.kind in
+    History.commit history rev_deps diff;
+    t.graph <- graph;
+    Todo.mutate graph rev_deps t.todos diff
+
+  let sections t origin =
+    match Origin_tbl.find t.sections origin with
+    | exception Not_found ->
+        let sections = Sections.create (age t) origin in
+        Origin_tbl.add t.sections origin sections;
+        sections
+    | sections -> sections
+
+  let update_seen t seen =
+    Path_set.fold
+      (fun path acc ->
+         match acc with
+         | None -> None
+         | Some acc ->
+             let md = Graph.find_module t.graph path in
+             let path = Module.path t.graph md in
+             if Path_set.mem path acc then None
+             else Some (Path_set.add path acc))
+      seen (Some Path_set.empty)
+
+  let process_type t height path typ =
+    let canonical_path = Type.path t.graph typ in
+    if not (Path.equal canonical_path path) then begin
+      let origin = Type.origin t.graph typ in
+      let sections = sections t origin in
+      Sections.add_type t.graph sections height typ path
+    end
+
+  let process_module_type t height path mty =
+    let canonical_path = Module_type.path t.graph mty in
+    if not (Path.equal canonical_path path) then begin
+      let origin = Module_type.origin t.graph mty in
+      let sections = sections t origin in
+      Sections.add_module_type t.graph sections height mty path
+    end
+
+  let process_class_type t height path mty =
+    let canonical_path = Class_type.path t.graph mty in
+    if not (Path.equal canonical_path path) then begin
+      let origin = Class_type.origin t.graph mty in
+      let sections = sections t origin in
+      Sections.add_class_type t.graph sections height mty path
+    end
+
+  let process_module t height path seen md =
+    let canonical_path = Module.path t.graph md in
+    if not (Path.equal canonical_path path) then begin
+      let origin = Module.origin t.graph md in
+      let sections = sections t origin in
+      Sections.add_module t.graph sections height md (path, seen);
+    end;
+    if not (Path_set.mem canonical_path seen) then begin
+      let seen = Path_set.add canonical_path seen in
+      Todo.add_children t.graph (rev_deps t) t.todos height md path seen
+    end
+
+  let process_children t height path seen md =
+    let types =
+      match Module.types t.graph md with
+      | Some types -> types
+      | None -> String_map.empty
+    in
+    let class_types =
+      match Module.class_types t.graph md with
+      | Some class_types -> class_types
+      | None -> String_map.empty
+    in
+    let module_types =
+      match Module.module_types t.graph md with
+      | Some module_types -> module_types
+      | None -> String_map.empty
+    in
+    let modules =
+      match Module.modules t.graph md with
+      | Some modules -> modules
+      | None -> String_map.empty
+    in
+    String_map.iter
+      (fun name typ ->
+         if not (Type.hidden typ) then begin
+           let path = Path.Pdot(path, name) in
+           process_type t height path typ
+         end)
+      types;
+    String_map.iter
+      (fun name clty ->
+         if not (Class_type.hidden clty) then begin
+           let path = Path.Pdot(path, name) in
+           process_class_type t height path clty
+         end)
+      class_types;
+    String_map.iter
+      (fun name mty ->
+         if not (Module_type.hidden mty) then begin
+           let path = Path.Pdot(path, name) in
+           process_module_type t height path mty
+         end)
+      module_types;
+    String_map.iter
+      (fun name md ->
+         if not (Module.hidden md) then begin
+           let path = Path.Pdot(path, name) in
+           process_module t height path seen md
+         end)
+      modules
+
+  let rec process : 'k . 'k t -> _ =
+    fun t origin height ->
+      let todo = Todo.pop (rev_deps t) t.todos height origin in
+      match todo with
+      | None -> true
+      | Some items ->
+          List.iter
+            (function
+              | Todo.Item.Base (Diff.Item.Type(id, typ, _)) ->
+                  if not (Type.hidden typ) then begin
+                    let path = Path.Pident id in
+                    process_type t height path typ
+                  end
+              | Todo.Item.Base (Diff.Item.Class_type(id, clty, _)) ->
+                  if not (Class_type.hidden clty) then begin
+                    let path = Path.Pident id in
+                    process_class_type t height path clty
+                  end
+              | Todo.Item.Base (Diff.Item.Module_type(id, mty, _)) ->
+                  if not (Module_type.hidden mty) then begin
+                    let path = Path.Pident id in
+                    process_module_type t height path mty
+                  end
+              | Todo.Item.Base (Diff.Item.Module(id, md, _)) ->
+                  if not (Module.hidden md) then begin
+                    let path = Path.Pident id in
+                    process_module t height path Path_set.empty md
+                  end
+              | Todo.Item.Children{md; path; seen} ->
+                  process_children t height path seen md
+              | Todo.Item.Update{ id; origin } ->
+                  process_update t origin height id
+              | Todo.Item.Forward{ id; decl; origin } ->
+                  process_forward t origin height id decl)
+            items;
+            false
+
+  and process_update : 'k . 'k t -> _ =
+    fun t origin height id ->
+      let sections = sections t origin in
+      let more =
+        Sections.iter_updates sections height id
+          ~type_:(fun canon path ->
+            let typ = Graph.find_type t.graph canon in
+            process_type t height path typ)
+          ~class_type:(fun canon path ->
+            let clty = Graph.find_class_type t.graph canon in
+            process_class_type t height path clty)
+          ~module_type:(fun canon path ->
+            let mty = Graph.find_module_type t.graph canon in
+            process_module_type t height path mty)
+          ~module_:(fun canon (path, seen) ->
+            let md = Graph.find_module t.graph canon in
+            match update_seen t seen with
+            | None -> ()
+            | Some seen ->
+              process_module t height path seen md);
+      in
+      if more then begin
+        Todo.add_next_update (rev_deps t) t.todos height origin id
+      end
+
+
+  and process_forward : 'k . 'k t -> _ =
+    fun t origin height id decl ->
+      let sections = init t decl height in
+      let more =
+        Sections.iter_forwards sections height id
+          ~type_:(fun canon path ->
+            let typ = Graph.find_type t.graph canon in
+            process_type t height path typ)
+          ~class_type:(fun canon path ->
+            let clty = Graph.find_class_type t.graph canon in
+            process_class_type t height path clty)
+          ~module_type:(fun canon path ->
+            let mty = Graph.find_module_type t.graph canon in
+            process_module_type t height path mty)
+          ~module_:(fun canon (path, seen) ->
+            let md = Graph.find_module t.graph canon in
+            match update_seen t seen with
+            | None -> ()
+            | Some seen ->
+              process_module t height path seen md);
+      in
+      if more then begin
+        Todo.add_next_forward (rev_deps t) t.todos height origin id decl
+      end
+
+  and initialise : type k. k t -> _ =
+    fun t sections origin height ->
+      if not (Sections.is_initialised sections height) then begin
+        begin match Height.pred height with
+        | None -> ()
+        | Some pred -> initialise t sections origin pred
+        end;
+        let parent =
+          match t.kind with
+          | Basis _ -> assert false
+          | Env { parent; _ } ->
+              update parent;
+              force parent origin height
+        in
+        Sections.initialise sections height parent
+      end
+
+  and init : 'k . 'k t -> _ =
+    fun t origin height ->
+      let sections = sections t origin in
+      Sections.update sections (stamp t);
+      initialise t sections origin height;
+      sections
+
+  and complete : 'k. 'k t -> _ =
+    fun t sections origin height ->
+      if not (Sections.is_completed sections height) then begin
+        begin match Height.pred height with
+        | None -> ()
+        | Some pred -> ignore (complete t sections origin pred)
+        end;
+        let finished = process t origin height in
+        if finished then Sections.set_completed_from sections height
+        else Sections.set_completed sections height
+      end
+
+  and force : 'k. 'k t -> _ =
+    fun t origin height ->
+      let sections = sections t origin in
+      Sections.update sections (stamp t);
+      initialise t sections origin height;
+      complete t sections origin height;
+      sections
+
+  module Search = struct
+
+    type 'a shortest = 'a t
+
+    type _ kind =
+      | Type : Type.t kind
+      | Class_type : Class_type.t kind
+      | Module_type : Module_type.t kind
+      | Module : Module.t kind
+
+    type name =
+      { name : string;
+        height : Height.t; }
+
+    type 'a t =
+      | Ident of
+          { kind : 'a kind;
+            node : 'a;
+            origin : Origin.t;
+            best : Path.t;
+            min: Height.t;
+            max: Height.t;
+            finished : bool; }
+      | Dot of
+          { kind : 'a kind;
+            node : 'a;
+            origin : Origin.t;
+            best : Path.t;
+            min: Height.t;
+            max: Height.t;
+            parent : Module.t t;
+            name : name;
+            searched : bool;
+            finished : bool; }
+      | Application of
+          { kind : 'a kind;
+            node : 'a;
+            origin : Origin.t;
+            best : Path.t;
+            min: Height.t;
+            max: Height.t;
+            func : Module.t t;
+            arg : Module.t t;
+            func_first : bool;
+            searched : bool;
+            finished : bool; }
+
+    let min_height = function
+      | Ident { min; _ } -> min
+      | Dot { min; _ } -> min
+      | Application { min; _ } -> min
+
+    let max_height = function
+      | Ident { max; _ } -> max
+      | Dot { max; _ } -> max
+      | Application { max; _ } -> max
+
+    let search_origin = function
+      | Ident { origin; _ } -> origin
+      | Dot { origin; _ } -> origin
+      | Application { origin; _ } -> origin
+
+    let finished = function
+      | Ident { finished; _ } -> finished
+      | Dot { finished; _ } -> finished
+      | Application { finished; _ } -> finished
+
+    let best = function
+      | Ident { best; _ } -> best
+      | Dot { best; _ } -> best
+      | Application { best; _ } -> best
+
+    let min_application fst snd =
+      Height.plus (min_height fst) (min_height snd)
+
+    let max_application fst snd =
+      Height.plus (max_height fst) (max_height snd)
+
+    let min_dot parent name =
+      let base = min_height parent in
+      Height.plus base name.height
+
+    let path_application fst snd =
+      Path.Papply(best fst, best snd)
+
+    let path_dot parent name =
+      Path.Pdot(best parent, name.name)
+
+    let is_visible_ident (type k) graph (kind : k kind) id =
+      match kind with
+      | Type -> Graph.is_type_ident_visible graph id
+      | Class_type -> Graph.is_class_type_ident_visible graph id
+      | Module_type -> Graph.is_module_type_ident_visible graph id
+      | Module -> Graph.is_module_ident_visible graph id
+
+    let create (type k) shortest (kind : k kind) canonical_path =
+      let rec loop : type k. k kind -> Path.t -> k t =
+        fun kind path ->
+          let graph = shortest.graph in
+          let (node : k), origin, hidden =
+            match kind with
+            | Type ->
+                let node = Graph.find_type graph path in
+                let origin = Type.origin graph node in
+                let hidden = Type.hidden node in
+                node, origin, hidden
+            | Class_type ->
+                let node = Graph.find_class_type graph path in
+                let origin = Class_type.origin graph node in
+                let hidden = Class_type.hidden node in
+                node, origin, hidden
+            | Module_type ->
+                let node = Graph.find_module_type graph path in
+                let origin = Module_type.origin graph node in
+                let hidden = Module_type.hidden node in
+                node, origin, hidden
+            | Module ->
+                let node = Graph.find_module graph path in
+                let origin = Module.origin graph node in
+                let hidden = Module.hidden node in
+                node, origin, hidden
+          in
+          let best = path in
+          match path with
+          | Path.Pident id ->
+              let max =
+                if is_visible_ident graph kind id && not hidden then
+                  Height.one
+                else
+                  Height.maximum
+              in
+              let min = Height.one in
+              let finished = false in
+              Ident { kind; node; origin; best; min; max; finished }
+          | Path.Pdot(parent, name) ->
+              let parent = loop Module parent in
+              let finished = false in
+              let name_height =
+                if not hidden then Height.one
+                else Height.maximum
+              in
+              let name = { name; height = name_height } in
+              let searched = false in
+              let max = Height.plus (max_height parent) name_height in
+              let min = Height.one in
+              Dot
+                { kind; node; origin; best; min; max;
+                  parent; name; searched; finished }
+          | Path.Papply(func, arg) ->
+              let func = loop Module func in
+              let arg = loop Module arg in
+              let func_first =
+                Rev_deps.before (rev_deps shortest)
+                  (search_origin arg) (search_origin func)
+              in
+              let finished = false in
+              (* There are no module aliases containing extended paths *)
+              let searched = true in
+              let max = max_application func arg in
+              let min = min_application func arg in
+              Application
+                { kind; node; origin; best; min; max;
+                  func; arg; func_first; searched; finished }
+      in
+      loop kind canonical_path
+
+    let find (type k) shortest origin height (kind : k kind) (node : k) =
+      let sections = force shortest origin height in
+      match kind with
+      | Type ->
+          Sections.find_type shortest.graph sections height node
+      | Class_type ->
+          Sections.find_class_type shortest.graph sections height node
+      | Module_type ->
+          Sections.find_module_type shortest.graph sections height node
+      | Module ->
+          Sections.find_module shortest.graph sections height node
+
+    let rec step : type k . _ shortest -> k t -> k t =
+      fun shortest search ->
+        if finished search then search
+        else begin
+          match search with
+          | Ident r -> begin
+              match find shortest r.origin r.min r.kind r.node with
+              | Sections.Not_found_here ->
+                  if Height.equal r.min r.max then
+                    Ident { r with finished = true }
+                  else
+                    Ident { r with min = Height.succ r.min }
+              | Sections.Not_found_here_or_later ->
+                  Ident { r with finished = true; min = r.max }
+              | Sections.Found path ->
+                  let best = path in
+                  let max = r.min in
+                  let finished = true in
+                  Ident { r with best; max; finished }
+            end
+          | Dot r ->
+              let parent = r.parent in
+              let parent =
+                let should_try_dot =
+                  Height.equal
+                    (min_dot parent r.name) r.min
+                in
+                if not should_try_dot then parent
+                else step shortest parent
+              in
+              let found =
+                finished parent
+                && Height.equal (min_dot parent r.name) r.min
+              in
+              if found then begin
+                let best = path_dot parent r.name in
+                let max = r.min in
+                let finished = true in
+                Dot
+                  { r with best; parent; max; finished }
+              end else begin
+                let best, max, searched, finished =
+                  if r.searched then r.best, r.max, r.searched, r.finished
+                  else begin
+                    match find shortest r.origin r.min r.kind r.node with
+                    | Sections.Not_found_here ->
+                        r.best, r.max, (Height.equal r.min r.max), r.finished
+                    | Sections.Not_found_here_or_later ->
+                        r.best, r.max, true, r.finished
+                    | Sections.Found path ->
+                        path, r.min, true, true
+                  end
+                in
+                let finished =
+                  finished ||
+                  (searched
+                   && Height.less_than_or_equal
+                        r.max (min_dot parent r.name))
+                in
+                let min = if finished then max else Height.succ r.min in
+                Dot { r with best; parent; min; max; searched; finished }
+              end
+         | Application r ->
+              let try_app searched =
+                let fst, snd =
+                  if r.func_first then r.func, r.arg
+                  else r.arg, r.func
+                in
+                let fst, snd =
+                  let should_try_app =
+                    Height.equal (min_application fst snd) r.min
+                  in
+                  if not should_try_app then fst, snd
+                  else begin
+                    let fst = step shortest fst in
+                    let should_try_app =
+                      Height.equal (min_application fst snd) r.min
+                    in
+                    if not should_try_app then fst, snd
+                    else fst, step shortest snd
+                  end
+                in
+                let func, arg =
+                  if r.func_first then fst, snd
+                  else snd, fst
+                in
+                let found =
+                  finished func && finished arg
+                  && Height.equal (min_application fst snd) r.min
+                in
+                if found then begin
+                  let best = path_application func arg in
+                  let max = r.min in
+                  let finished = true in
+                  Application
+                    { r with best; func; arg; max; searched; finished }
+                end else begin
+                  let finished =
+                    searched
+                    && Height.less_than_or_equal
+                         r.max (min_application fst snd)
+                  in
+                  let min = if finished then r.max else Height.succ r.min in
+                  Application
+                    { r with func; arg; min; searched; finished }
+                end
+              in
+              if r.searched then try_app true
+              else begin
+                match find shortest r.origin r.min r.kind r.node with
+                | Sections.Not_found_here ->
+                    try_app (Height.equal r.min r.max)
+                | Sections.Not_found_here_or_later ->
+                    try_app true
+                | Sections.Found path ->
+                    let best = path in
+                    let max = r.min in
+                    let searched = true in
+                    let finished = true in
+                    Application { r with best; max; searched; finished }
+              end
+        end
+
+    let rec perform shortest search =
+      if finished search then best search
+      else perform shortest (step shortest search)
+
+  end
+
+  let find_type t path =
+    update t;
+    let typ = Graph.find_type t.graph path in
+    match Type.resolve t.graph typ with
+    | Type.Nth n -> Nth n
+    | Type.Path(subst, typ) ->
+      let canonical_path = Type.path t.graph typ in
+      let search = Search.create t Search.Type canonical_path in
+      let path = Search.perform t search in
+      Path(subst, path)
+
+  let find_type_resolution t path : type_resolution =
+    update t;
+    let typ = Graph.find_type t.graph path in
+    match Type.resolve t.graph typ with
+    | Type.Nth n -> Nth n
+    | Type.Path(Some ns, _) -> Subst ns
+    | Type.Path(None, _) -> Id
+
+  let find_type_simple t path =
+    update t;
+    let typ = Graph.find_type t.graph path in
+    let canonical_path = Type.path t.graph typ in
+    let search = Search.create t Search.Type canonical_path in
+    Search.perform t search
+
+  let find_class_type t path =
+    update t;
+    let clty = Graph.find_class_type t.graph path in
+    let subst, clty = Class_type.resolve t.graph clty in
+    let canonical_path = Class_type.path t.graph clty in
+    let search = Search.create t Search.Class_type canonical_path in
+    let path = Search.perform t search in
+    (subst, path)
+
+  let find_class_type_simple t path =
+    update t;
+    let clty = Graph.find_class_type t.graph path in
+    let canonical_path = Class_type.path t.graph clty in
+    let search = Search.create t Search.Class_type canonical_path in
+    Search.perform t search
+
+  let find_module_type t path =
+    update t;
+    let mty = Graph.find_module_type t.graph path in
+    let canonical_path = Module_type.path t.graph mty in
+    let search = Search.create t Search.Module_type canonical_path in
+    Search.perform t search
+
+  let find_module t path =
+    update t;
+    let md = Graph.find_module t.graph path in
+    let canonical_path = Module.path t.graph md in
+    let search = Search.create t Search.Module canonical_path in
+    Search.perform t search
+
+end
+
+module String_set = Set.Make(String)
+
+module Basis = struct
+
+  type load =
+    { name : string;
+      depends : string list;
+      alias_depends : string list;
+      desc : Desc.Module.t;
+      deprecated : Desc.deprecated; }
+
+  type t =
+    { mutable next_dep : Dependency.t;
+      mutable pending_additions : String_set.t;
+      mutable pending_loads : load list;
+      mutable assignment : Dependency.t String_map.t;
+      rev_deps : Rev_deps.t;
+      mutable shortest : Shortest.basis Shortest.t option; }
+
+  let create () =
+    { next_dep = Dependency.zero;
+      pending_additions = String_set.empty;
+      pending_loads = [];
+      assignment = String_map.empty;
+      rev_deps = Rev_deps.create ();
+      shortest = None; }
+
+  let update_assignments t additions =
+    String_set.iter
+      (fun name ->
+         if not (String_map.mem name t.assignment) then begin
+           t.assignment <- String_map.add name t.next_dep t.assignment;
+           t.next_dep <- Dependency.succ t.next_dep
+         end)
+      additions
+
+  let update_rev_deps t loads =
+    Rev_deps.extend_up_to t.rev_deps t.next_dep;
+    List.iter
+      (fun { name; depends; alias_depends; _ } ->
+         let index = String_map.find name t.assignment in
+         List.iter
+           (fun dep_name ->
+              let dep_index = String_map.find dep_name t.assignment in
+              Rev_deps.add t.rev_deps ~source:dep_index ~target:index)
+           depends;
+         List.iter
+           (fun dep_name ->
+              let dep_index = String_map.find dep_name t.assignment in
+              Rev_deps.add_alias t.rev_deps ~source:dep_index ~target:index)
+           alias_depends)
+      loads
+
+  let update_shortest t additions loads =
+    let components =
+      List.map
+        (fun { name; desc; deprecated; _ } ->
+           let index = String_map.find name t.assignment in
+           let origin = Origin.Dependency index in
+           let id = Ident.global name in
+           Component.Module(origin, id, desc, Component.Global, deprecated))
+        loads
+    in
+    let components =
+      String_set.fold
+        (fun name acc ->
+           let index = String_map.find name t.assignment in
+           let origin = Origin.Dependency index in
+           let id = Ident.global name in
+           Component.Declare_module(origin, id) :: acc)
+        additions
+        components
+    in
+    match t.shortest with
+    | None ->
+        t.shortest <- Some (Shortest.basis t.rev_deps components)
+    | Some shortest ->
+        Shortest.mutate shortest t.rev_deps components
+
+  let update t =
+    let loads = t.pending_loads in
+    let additions = t.pending_additions in
+    match loads, String_set.is_empty additions with
+    | [], true -> ()
+    | _, _ ->
+      t.pending_loads <- [];
+      t.pending_additions <- String_set.empty;
+      let loads = List.rev loads in
+      update_assignments t additions;
+      update_rev_deps t loads;
+      update_shortest t additions loads
+
+  let shortest t =
+    update t;
+    match t.shortest with
+    | None ->
+        let shortest = Shortest.basis t.rev_deps [] in
+        t.shortest <- Some shortest;
+        shortest
+    | Some shortest -> shortest
+
+  let add t name =
+    t.pending_additions <- String_set.add name t.pending_additions
+
+  let load t name depends alias_depends desc deprecated =
+    let load = { name; depends; alias_depends; desc; deprecated } in
+    t.pending_loads <- load :: t.pending_loads
+
+end
+
+type state =
+  | Initial of Basis.t
+  | Unforced of
+      { parent : t;
+        desc : Desc.t list Lazy.t; }
+  | Forced of
+      { basis : Basis.t;
+        shortest : Shortest.env Shortest.t; }
+
+and t = state ref
+
+let rec force t =
+  match !t with
+  | Initial _ | Forced _ as state -> state
+  | Unforced { parent; desc } ->
+    let desc = Lazy.force desc in
+    let state =
+      match force parent with
+      | Unforced _ -> assert false
+      | Initial basis ->
+        let shortest = Shortest.env (Basis.shortest basis) desc in
+        Forced { basis; shortest }
+      | Forced { basis; shortest } ->
+        let shortest = Shortest.env shortest desc in
+        Forced { basis; shortest }
+    in
+    t := state;
+    state
+
+let initial basis = ref (Initial basis)
+
+let add parent desc =
+  ref (Unforced { parent; desc })
+
+type ext_shortest = Shortest : 'k Shortest.t -> ext_shortest
+
+let shortest t =
+  match force t with
+  | Unforced _ -> assert false
+  | Initial basis ->
+      Basis.update basis;
+      Shortest (Basis.shortest basis)
+  | Forced { basis; shortest } ->
+      Basis.update basis;
+      Shortest shortest
+
+let find_type t path =
+  let Shortest shortest = shortest t in
+  match Shortest.find_type shortest path with
+  | exception Not_found -> Path(None, path)
+  | result -> result
+
+let find_type_resolution t path : type_resolution =
+  let Shortest shortest = shortest t in
+  match Shortest.find_type_resolution shortest path with
+  | exception Not_found -> Id
+  | subst -> subst
+
+let find_type_simple t path =
+  let Shortest shortest = shortest t in
+  match Shortest.find_type_simple shortest path with
+  | exception Not_found -> path
+  | path -> path
+
+let find_class_type t path =
+  let Shortest shortest = shortest t in
+  match Shortest.find_class_type shortest path with
+  | exception Not_found -> (None, path)
+  | result -> result
+
+let find_class_type_simple t path =
+  let Shortest shortest = shortest t in
+  match Shortest.find_class_type_simple shortest path with
+  | exception Not_found -> path
+  | path -> path
+
+let find_module_type t path =
+  let Shortest shortest = shortest t in
+  match Shortest.find_module_type shortest path with
+  | exception Not_found -> path
+  | path -> path
+
+let find_module t path =
+  let Shortest shortest = shortest t in
+  match Shortest.find_module shortest path with
+  | exception Not_found -> path
+  | path -> path
diff --git a/src/ocaml/typing/short_paths.mli b/src/ocaml/typing/short_paths.mli
new file mode 100644
index 0000000..1cc7608
--- /dev/null
+++ b/src/ocaml/typing/short_paths.mli
@@ -0,0 +1,46 @@
+
+module Desc = Short_paths_graph.Desc
+
+module Basis : sig
+
+  type t
+
+  val create : unit -> t
+
+  val add : t -> string -> unit
+
+  val load : t -> string -> string list -> string list ->
+    Desc.Module.t -> Desc.deprecated -> unit
+
+end
+
+type t
+
+val initial : Basis.t -> t
+
+val add : t -> Desc.t list Lazy.t -> t
+
+type type_result =
+  | Nth of int
+  | Path of int list option * Path.t
+
+val find_type : t -> Path.t -> type_result
+
+type type_resolution =
+  | Nth of int
+  | Subst of int list
+  | Id
+
+val find_type_resolution : t -> Path.t -> type_resolution
+
+val find_type_simple : t -> Path.t -> Path.t
+
+type class_type_result = int list option * Path.t
+
+val find_class_type : t -> Path.t -> class_type_result
+
+val find_class_type_simple : t -> Path.t -> Path.t
+
+val find_module_type : t -> Path.t -> Path.t
+
+val find_module : t -> Path.t -> Path.t
diff --git a/src/ocaml/typing/short_paths_graph.ml b/src/ocaml/typing/short_paths_graph.ml
new file mode 100644
index 0000000..1b2fbde
--- /dev/null
+++ b/src/ocaml/typing/short_paths_graph.ml
@@ -0,0 +1,1535 @@
+
+module String_map = Misc.String.Map
+
+module Ident = struct
+
+  type t = Ident.t
+
+  let equal t1 t2 = Ident.equal t1 t2
+
+  let compare t1 t2 = Ident.compare t1 t2
+
+  let name = Ident.name
+
+  let global name =
+    Ident.create_persistent name
+
+end
+
+module Ident_map = Map.Make(Ident)
+module Ident_set = Set.Make(Ident)
+
+module Path = struct
+
+  type t = Path.t =
+    | Pident of Ident.t
+    | Pdot of t * string
+    | Papply of t * t
+
+  open Path
+
+  let rec equal t1 t2 =
+    match t1, t2 with
+    | Pident id1, Pident id2 -> Ident.equal id1 id2
+    | Pident _, Pdot _ -> false
+    | Pident _, Papply _ -> false
+    | Pdot _, Pident _ -> false
+    | Pdot(parent1, name1), Pdot(parent2, name2) ->
+        equal parent1 parent2
+        && String.equal name1 name2
+    | Pdot _, Papply _ -> false
+    | Papply _, Pident _ -> false
+    | Papply _, Pdot _ -> false
+    | Papply(func1, arg1), Papply(func2, arg2) ->
+        equal func1 func2
+        && equal arg1 arg2
+
+  let rec compare t1 t2 =
+    match t1, t2 with
+    | Pident id1, Pident id2 -> Ident.compare id1 id2
+    | Pident _, Pdot _ -> -1
+    | Pident _, Papply _ -> -1
+    | Pdot _, Pident _ -> 1
+    | Pdot(parent1, name1), Pdot(parent2, name2) ->
+        let c = compare parent1 parent2 in
+        if c <> 0 then c
+        else String.compare name1 name2
+    | Pdot _, Papply _ -> -1
+    | Papply _, Pident _ -> 1
+    | Papply _, Pdot _ -> 1
+    | Papply(func1, arg1), Papply(func2, arg2) ->
+        let c = compare func1 func2 in
+        if c <> 0 then c
+        else compare arg1 arg2
+
+end
+
+module Path_map = Map.Make(Path)
+module Path_set = Set.Make(Path)
+
+module Desc = struct
+
+  type deprecated =
+    | Deprecated
+    | Not_deprecated
+
+  module Type = struct
+
+    type t =
+      | Fresh
+      | Nth of int
+      | Subst of Path.t * int list
+      | Alias of Path.t
+
+  end
+
+  module Module_type = struct
+
+    type t =
+      | Fresh
+      | Alias of Path.t
+
+  end
+
+  module Class_type = struct
+
+    type t =
+      | Fresh
+      | Subst of Path.t * int list
+      | Alias of Path.t
+
+  end
+
+  module Module = struct
+
+    type component =
+      | Type of string * Type.t * deprecated
+      | Class_type of string * Class_type.t * deprecated
+      | Module_type of string * Module_type.t * deprecated
+      | Module of string * t * deprecated
+
+    and components = component list
+
+    and kind =
+      | Signature of components Lazy.t
+      | Functor of (Path.t -> t)
+
+    and t =
+      | Fresh of kind
+      | Alias of Path.t
+
+  end
+
+  type source =
+    | Local
+    | Open
+
+  type t =
+    | Type of Ident.t * Type.t * source * deprecated
+    | Class_type of Ident.t * Class_type.t * source * deprecated
+    | Module_type of Ident.t * Module_type.t * source * deprecated
+    | Module of Ident.t * Module.t * source * deprecated
+    | Declare_type of Ident.t
+    | Declare_class_type of Ident.t
+    | Declare_module_type of Ident.t
+    | Declare_module of Ident.t
+
+end
+
+module Sort = struct
+
+  type t =
+    | Defined
+    | Declared of Ident_set.t
+
+  let application t1 t2 =
+    match t1, t2 with
+    | Defined, Defined -> Defined
+    | Defined, Declared _ -> t2
+    | Declared _, Defined -> t1
+    | Declared ids1, Declared ids2 -> Declared (Ident_set.union ids1 ids2)
+
+end
+
+module Age = Natural.Make()
+
+module Dependency = Natural.Make()
+
+module Origin = struct
+
+  type t =
+    | Dependency of Dependency.t
+    | Dependencies of Dependency.t list
+    | Environment of Age.t
+
+  let rec deps_add dep deps =
+    match deps with
+    | [] -> [dep]
+    | dep' :: rest ->
+      if Dependency.equal dep dep' then
+        deps
+      else if Dependency.less_than dep dep' then
+        dep :: deps
+      else
+        dep' :: deps_add dep rest
+
+  let rec deps_union deps1 deps2 =
+    match deps1, deps2 with
+    | [], _ -> deps2
+    | _, [] -> deps1
+    | dep1 :: rest1, dep2 :: rest2 ->
+        if Dependency.equal dep1 dep2 then
+          dep1 :: deps_union rest1 rest2
+        else if Dependency.less_than dep1 dep2 then
+          dep1 :: deps_union rest1 deps2
+        else
+          dep2 :: deps_union deps1 rest2
+
+  let rec deps_equal deps1 deps2 =
+    match deps1, deps2 with
+    | [], [] -> true
+    | [], _ :: _ -> false
+    | _ :: _, [] -> false
+    | dep1 :: rest1, dep2 :: rest2 ->
+        Dependency.equal dep1 dep2
+        && deps_equal rest1 rest2
+
+  let application t1 t2 =
+    match t1, t2 with
+    | Dependency dep1, Dependency dep2 ->
+        if Dependency.equal dep1 dep2 then t1
+        else if Dependency.less_than dep1 dep2 then
+          Dependencies [dep1; dep2]
+        else
+          Dependencies [dep2; dep1]
+    | Dependency dep1, Dependencies deps2 ->
+        Dependencies (deps_add dep1 deps2)
+    | Dependency _, Environment _ -> t2
+    | Dependencies deps1, Dependency dep2 ->
+        Dependencies (deps_add dep2 deps1)
+    | Dependencies deps1, Dependencies deps2 ->
+        Dependencies (deps_union deps1 deps2)
+    | Dependencies _, Environment _ -> t2
+    | Environment _, Dependency _ -> t1
+    | Environment _, Dependencies _ -> t1
+    | Environment age1, Environment age2 ->
+        Environment (Age.max age1 age2)
+
+  let equal t1 t2 =
+    match t1, t2 with
+    | Dependency dep1, Dependency dep2 -> Dependency.equal dep1 dep2
+    | Dependency _, Dependencies _ -> false
+    | Dependency _, Environment _ -> false
+    | Dependencies _, Dependency _ -> false
+    | Dependencies deps1, Dependencies deps2 -> deps_equal deps1 deps2
+    | Dependencies _, Environment _ -> false
+    | Environment _, Dependency _ -> false
+    | Environment _, Dependencies _ -> false
+    | Environment env1, Environment env2 -> Age.equal env1 env2
+
+  let hash = Hashtbl.hash
+
+end
+
+let hidden_name name =
+  if name <> "" && name.[0] = '_' then true
+  else
+    try
+      for i = 1 to String.length name - 2 do
+        if name.[i] = '_' && name.[i + 1] = '_' then
+          raise Exit
+      done;
+      false
+    with Exit -> true
+
+let hidden_ident id =
+  if !Clflags.unsafe_string && Ident.equal id Predef.ident_bytes then true
+  else hidden_name (Ident.name id)
+
+let hidden_definition deprecated name =
+  match deprecated with
+  | Desc.Deprecated -> true
+  | Desc.Not_deprecated -> hidden_name name
+
+let hidden_base_definition deprecated id =
+  match deprecated with
+  | Desc.Deprecated -> true
+  | Desc.Not_deprecated -> hidden_ident id
+
+module rec Type : sig
+
+  type t
+
+  val base : Origin.t -> Ident.t -> Desc.Type.t option -> Desc.deprecated -> t
+
+  val child :
+    Module.normalized -> string -> Desc.Type.t option -> Desc.deprecated -> t
+
+  val declare : Origin.t -> Ident.t -> t
+
+  val declaration : t -> Origin.t option
+
+  val origin : Graph.t -> t -> Origin.t
+
+  val path : Graph.t -> t -> Path.t
+
+  val hidden : t -> bool
+
+  val sort : Graph.t -> t -> Sort.t
+
+  type resolved =
+    | Nth of int
+    | Path of int list option * t
+
+  val resolve : Graph.t -> t -> resolved
+
+end = struct
+
+  open Desc.Type
+
+  type definition =
+    | Alias of Path.t
+    | Defined
+    | Nth of int
+    | Subst of Path.t * int list
+    | Unknown
+
+  type t =
+    | Declaration of
+        { origin : Origin.t;
+          id : Ident.t;
+          hidden : bool; }
+    | Definition of
+        { origin : Origin.t;
+          path : Path.t;
+          hidden : bool;
+          sort : Sort.t;
+          definition : definition; }
+
+  let definition_of_desc (desc : Desc.Type.t option) =
+    match desc with
+    | None -> Unknown
+    | Some Fresh -> Defined
+    | Some (Nth n) -> Nth n
+    | Some (Subst(p, ns)) -> Subst(p, ns)
+    | Some (Alias alias) -> Alias alias
+
+  let base origin id desc deprecated =
+    let path = Path.Pident id in
+    let hidden = hidden_base_definition deprecated id in
+    let sort = Sort.Defined in
+    let definition = definition_of_desc desc in
+    Definition { origin; path; hidden; sort; definition }
+
+  let child md name desc deprecated =
+    let origin = Module.raw_origin md in
+    let sort = Module.raw_sort md in
+    let path = Path.Pdot(Module.raw_path md, name) in
+    let hidden = hidden_definition deprecated name in
+    let definition = definition_of_desc desc in
+    Definition { origin; path; hidden; sort; definition }
+
+  let declare origin id =
+    let hidden = hidden_ident id in
+    Declaration { origin; id; hidden }
+
+  let declaration t =
+    match t with
+    | Definition _ -> None
+    | Declaration { origin; _} -> Some origin
+
+  let hidden t =
+    match t with
+    | Definition { hidden; _ } -> hidden
+    | Declaration { hidden; _ } -> hidden
+
+  let raw_origin t =
+    match t with
+    | Declaration { origin; _ }
+    | Definition { origin; _ } -> origin
+
+  let raw_path t =
+    match t with
+    | Declaration { id; _ } -> Path.Pident id
+    | Definition { path; _ } -> path
+
+  let raw_sort t =
+    match t with
+    | Declaration { id; _ } -> Sort.Declared (Ident_set.singleton id)
+    | Definition { sort; _ } -> sort
+
+  let rec normalize_loop root t =
+    match t with
+    | Declaration _ -> t
+    | Definition { definition = Defined | Unknown | Nth _ | Subst _ } -> t
+    | Definition ({ definition = Alias alias } as r) -> begin
+        match Graph.find_type root alias with
+        | exception Not_found -> Definition { r with definition = Unknown }
+        | aliased -> normalize_loop root aliased
+      end
+
+  let normalize root t =
+    match t with
+    | Definition { sort = Sort.Defined } -> normalize_loop root t
+    | Definition { sort = Sort.Declared _ } | Declaration _ ->
+        match Graph.find_type root (raw_path t) with
+        | exception Not_found -> normalize_loop root t
+        | t -> normalize_loop root t
+
+  let origin root t =
+    raw_origin (normalize root t)
+
+  let path root t =
+    raw_path (normalize root t)
+
+  let sort root t =
+    raw_sort (normalize root t)
+
+  type resolved =
+    | Nth of int
+    | Path of int list option * t
+
+  let subst ns = function
+    | Nth n -> Nth (List.nth ns n)
+    | Path(None, p) -> Path(Some ns, p)
+    | Path(Some ms, p) -> Path(Some (List.map (List.nth ns) ms), p)
+
+  let rec resolve root t =
+    match normalize root t with
+    | Declaration _ -> Path(None, t)
+    | Definition { definition = Defined | Unknown } -> Path(None, t)
+    | Definition { definition = Nth n } -> Nth n
+    | Definition { definition = Subst(p, ns) } -> begin
+        match Graph.find_type root p with
+        | exception Not_found -> Path(None, t)
+        | aliased -> subst ns (resolve root aliased)
+      end
+    | Definition { definition = Alias _ } -> assert false
+
+end
+
+and Class_type : sig
+
+  type t
+
+  val base :
+    Origin.t -> Ident.t -> Desc.Class_type.t option -> Desc.deprecated -> t
+
+  val child :
+    Module.normalized -> string ->
+    Desc.Class_type.t option -> Desc.deprecated -> t
+
+  val declare : Origin.t -> Ident.t -> t
+
+  val declaration : t -> Origin.t option
+
+  val origin : Graph.t -> t -> Origin.t
+
+  val path : Graph.t -> t -> Path.t
+
+  val hidden : t -> bool
+
+  val sort : Graph.t -> t -> Sort.t
+
+  type resolved = int list option * t
+
+  val resolve : Graph.t -> t -> resolved
+
+end = struct
+
+  open Desc.Class_type
+
+  type definition =
+    | Alias of Path.t
+    | Defined
+    | Subst of Path.t * int list
+    | Unknown
+
+  type t =
+    | Declaration of
+        { origin : Origin.t;
+          id : Ident.t;
+          hidden : bool; }
+    | Definition of
+        { origin : Origin.t;
+          path : Path.t;
+          hidden : bool;
+          sort : Sort.t;
+          definition : definition; }
+
+  let definition_of_desc (desc : Desc.Class_type.t option) =
+    match desc with
+    | None -> Unknown
+    | Some Fresh -> Defined
+    | Some (Subst(p, ns)) -> Subst(p, ns)
+    | Some (Alias alias) -> Alias alias
+
+  let base origin id desc deprecated =
+    let path = Path.Pident id in
+    let hidden = hidden_base_definition deprecated id in
+    let sort = Sort.Defined in
+    let definition = definition_of_desc desc in
+    Definition { origin; path; hidden; sort; definition }
+
+  let child md name desc deprecated =
+    let origin = Module.raw_origin md in
+    let sort = Module.raw_sort md in
+    let path = Path.Pdot(Module.raw_path md, name) in
+    let hidden = hidden_definition deprecated name in
+    let definition = definition_of_desc desc in
+    Definition { origin; path; hidden; sort; definition }
+
+  let declare origin id =
+    let hidden = hidden_ident id in
+    Declaration { origin; id; hidden }
+
+  let declaration t =
+    match t with
+    | Definition _ -> None
+    | Declaration { origin; _} -> Some origin
+
+  let hidden t =
+    match t with
+    | Definition { hidden; _ } -> hidden
+    | Declaration { hidden; _ } -> hidden
+
+  let raw_origin t =
+    match t with
+    | Declaration { origin; _ }
+    | Definition { origin; _ } -> origin
+
+  let raw_path t =
+    match t with
+    | Declaration { id; _ } -> Path.Pident id
+    | Definition { path; _ } -> path
+
+  let raw_sort t =
+    match t with
+    | Declaration { id; _ } -> Sort.Declared (Ident_set.singleton id)
+    | Definition { sort; _ } -> sort
+
+  let rec normalize_loop root t =
+    match t with
+    | Declaration _ -> t
+    | Definition { definition = Defined | Unknown | Subst _ } -> t
+    | Definition ({ definition = Alias alias } as r) -> begin
+        match Graph.find_class_type root alias with
+        | exception Not_found -> Definition { r with definition = Unknown }
+        | aliased -> normalize_loop root aliased
+      end
+
+  let normalize root t =
+    match t with
+    | Definition { sort = Sort.Defined } -> normalize_loop root t
+    | Definition { sort = Sort.Declared _ } | Declaration _ ->
+        match Graph.find_class_type root (raw_path t) with
+        | exception Not_found -> normalize_loop root t
+        | t -> normalize_loop root t
+
+  let origin root t =
+    raw_origin (normalize root t)
+
+  let path root t =
+    raw_path (normalize root t)
+
+  let sort root t =
+    raw_sort (normalize root t)
+
+  type resolved = int list option * t
+
+  let subst ns = function
+    | (None, p) -> (Some ns, p)
+    | (Some ms, p) -> (Some (List.map (List.nth ns) ms), p)
+
+  let rec resolve root t =
+    match normalize root t with
+    | Declaration _ -> (None, t)
+    | Definition { definition = Defined | Unknown } -> (None, t)
+    | Definition { definition = Subst(p, ns) } -> begin
+        match Graph.find_class_type root p with
+        | exception Not_found -> (None, t)
+        | aliased -> subst ns (resolve root aliased)
+      end
+    | Definition { definition = Alias _ } -> assert false
+
+end
+
+and Module_type : sig
+
+  type t
+
+  val base :
+    Origin.t -> Ident.t -> Desc.Module_type.t option -> Desc.deprecated -> t
+
+  val child :
+    Module.normalized -> string ->
+    Desc.Module_type.t option -> Desc.deprecated -> t
+
+  val declare : Origin.t -> Ident.t -> t
+
+  val declaration : t -> Origin.t option
+
+  val origin : Graph.t -> t -> Origin.t
+
+  val path : Graph.t -> t -> Path.t
+
+  val hidden : t -> bool
+
+  val sort : Graph.t -> t -> Sort.t
+
+end = struct
+
+  open Desc.Module_type
+
+  type definition =
+    | Alias of Path.t
+    | Defined
+    | Unknown
+
+  type t =
+    | Declaration of
+        { origin : Origin.t;
+          id : Ident.t;
+          hidden : bool; }
+    | Definition of
+        { origin : Origin.t;
+          path : Path.t;
+          hidden : bool;
+          sort : Sort.t;
+          definition : definition; }
+
+  let base origin id desc deprecated =
+    let path = Path.Pident id in
+    let hidden = hidden_base_definition deprecated id in
+    let sort = Sort.Defined in
+    let definition =
+      match desc with
+      | None -> Unknown
+      | Some Fresh -> Defined
+      | Some (Alias alias) -> Alias alias
+    in
+    Definition { origin; path; hidden; sort; definition }
+
+  let child md name desc deprecated =
+    let origin = Module.raw_origin md in
+    let sort = Module.raw_sort md in
+    let path = Path.Pdot (Module.raw_path md, name) in
+    let hidden = hidden_definition deprecated name in
+    let definition =
+      match desc with
+      | None -> Unknown
+      | Some Fresh -> Defined
+      | Some (Alias alias) -> Alias alias
+    in
+    Definition { origin; path; hidden; sort; definition }
+
+  let declare origin id =
+    let hidden = hidden_ident id in
+    Declaration { origin; id; hidden }
+
+  let declaration t =
+    match t with
+    | Definition _ -> None
+    | Declaration { origin; _} -> Some origin
+
+  let hidden t =
+    match t with
+    | Definition { hidden; _ } -> hidden
+    | Declaration { hidden; _ } -> hidden
+
+  let raw_origin t =
+    match t with
+    | Declaration { origin; _ } | Definition { origin; _ } ->
+        origin
+
+  let raw_path t =
+    match t with
+    | Declaration { id; _ } -> Path.Pident id
+    | Definition { path; _ } -> path
+
+  let raw_sort t =
+    match t with
+    | Declaration { id; _ } -> Sort.Declared (Ident_set.singleton id)
+    | Definition { sort; _ } -> sort
+
+  let rec normalize_loop root t =
+    match t with
+    | Declaration _ -> t
+    | Definition { definition = Defined | Unknown } -> t
+    | Definition ({ definition = Alias alias } as r) -> begin
+        match Graph.find_module_type root alias with
+        | exception Not_found -> Definition { r with definition = Unknown }
+        | aliased -> normalize_loop root aliased
+      end
+
+  let normalize root t =
+    match t with
+    | Definition { sort = Sort.Defined } -> normalize_loop root t
+    | Definition { sort = Sort.Declared _ } | Declaration _ ->
+        match Graph.find_module_type root (raw_path t) with
+        | exception Not_found -> normalize_loop root t
+        | t -> normalize_loop root t
+
+  let origin root t =
+    raw_origin (normalize root t)
+
+  let path root t =
+    raw_path (normalize root t)
+
+  let sort root t =
+    raw_sort (normalize root t)
+
+end
+
+and Module : sig
+
+  type t
+
+  type normalized
+
+  val base :
+    Origin.t -> Ident.t -> Desc.Module.t option -> Desc.deprecated -> t
+
+  val child :
+    normalized -> string -> Desc.Module.t option -> Desc.deprecated -> t
+
+  val application : normalized -> t -> Desc.Module.t option -> t
+
+  val declare : Origin.t -> Ident.t -> t
+
+  val declaration : t -> Origin.t option
+
+  val origin : Graph.t -> t -> Origin.t
+
+  val path : Graph.t -> t -> Path.t
+
+  val hidden : t -> bool
+
+  val sort : Graph.t -> t -> Sort.t
+
+  val types : Graph.t -> t -> Type.t String_map.t option
+
+  val class_types : Graph.t -> t -> Class_type.t String_map.t option
+
+  val module_types : Graph.t -> t -> Module_type.t String_map.t option
+
+  val modules : Graph.t -> t -> Module.t String_map.t option
+
+  val find_type : Graph.t -> t -> string -> Type.t
+
+  val find_class_type : Graph.t -> t -> string -> Class_type.t
+
+  val find_module_type : Graph.t -> t -> string -> Module_type.t
+
+  val find_module : Graph.t -> t -> string -> Module.t
+
+  val find_application : Graph.t -> t -> Path.t -> Module.t
+
+  val normalize : Graph.t -> t -> normalized
+
+  val unnormalize : normalized -> t
+
+  val raw_origin : normalized -> Origin.t
+
+  val raw_path : normalized -> Path.t
+
+  val raw_sort : normalized -> Sort.t
+
+end = struct
+
+  open Desc.Module
+
+  type components =
+    | Unforced of Desc.Module.components Lazy.t
+    | Forced of
+        { types : Type.t String_map.t;
+          class_types : Class_type.t String_map.t;
+          module_types : Module_type.t String_map.t;
+          modules : t String_map.t; }
+
+  and definition =
+    | Alias of Path.t
+    | Signature of
+        { mutable components : components }
+    | Functor of
+        { apply : Path.t -> Desc.Module.t;
+          mutable applications : t Path_map.t; }
+    | Unknown
+
+  and t =
+    | Declaration of
+        { origin : Origin.t;
+          id : Ident.t;
+          hidden : bool; }
+    | Definition of
+        { origin : Origin.t;
+          path : Path.t;
+          hidden : bool;
+          sort : Sort.t;
+          definition : definition; }
+
+  let base origin id desc deprecated =
+    let path = Path.Pident id in
+    let hidden = hidden_base_definition deprecated id in
+    let sort = Sort.Defined in
+    let definition =
+      match desc with
+      | None -> Unknown
+      | Some (Fresh (Signature components)) ->
+          let components = Unforced components in
+          Signature { components }
+      | Some (Fresh (Functor apply)) ->
+          let applications = Path_map.empty in
+          Functor { apply; applications }
+      | Some (Alias alias) ->
+          Alias alias
+    in
+    Definition { origin; path; hidden; sort; definition }
+
+  let child md name desc deprecated =
+    let origin = Module.raw_origin md in
+    let sort = Module.raw_sort md in
+    let path = Path.Pdot(Module.raw_path md, name) in
+    let hidden = hidden_definition deprecated name in
+    let definition =
+      match desc with
+      | None -> Unknown
+      | Some (Fresh (Signature components)) ->
+          let components = Unforced components in
+          Signature { components }
+      | Some (Fresh (Functor apply)) ->
+          let applications = Path_map.empty in
+          Functor { apply; applications }
+      | Some (Alias alias) ->
+          Alias alias
+    in
+    Definition { origin; path; hidden; sort; definition }
+
+  let application func arg desc =
+    let func_origin = Module.raw_origin func in
+    let arg_origin = Module.raw_origin arg in
+    let origin = Origin.application func_origin arg_origin in
+    let func_sort = Module.raw_sort func in
+    let arg_sort = Module.raw_sort arg in
+    let sort = Sort.application func_sort arg_sort in
+    let func_path = Module.raw_path func in
+    let arg_path = Module.raw_path arg in
+    let path = Path.Papply(func_path, arg_path) in
+    let hidden = false in
+    let definition =
+      match desc with
+      | None -> Unknown
+      | Some (Fresh (Signature components)) ->
+          let components = Unforced components in
+          Signature { components }
+      | Some (Fresh (Functor apply)) ->
+          let applications = Path_map.empty in
+          Functor { apply; applications }
+      | Some (Alias alias) ->
+          Alias alias
+    in
+    Definition { origin; path; hidden; sort; definition }
+
+  let declare origin id =
+    let hidden = hidden_ident id in
+    Declaration { origin; id; hidden }
+
+  let declaration t =
+    match t with
+    | Definition _ -> None
+    | Declaration { origin; _} -> Some origin
+
+  let hidden t =
+    match t with
+    | Definition { hidden; _ } -> hidden
+    | Declaration { hidden; _ } -> hidden
+
+  let raw_origin t =
+    match t with
+    | Declaration { origin; _ } | Definition { origin; _ } ->
+        origin
+
+  let raw_path t =
+    match t with
+    | Declaration { id; _ } -> Path.Pident id
+    | Definition { path; _ } -> path
+
+  let raw_sort t =
+    match t with
+    | Declaration { id; _ } -> Sort.Declared (Ident_set.singleton id)
+    | Definition { sort; _ } -> sort
+
+  type normalized = t
+
+  let rec normalize_loop root t =
+    match t with
+    | Declaration _ -> t
+    | Definition { definition = Signature _ | Functor _ | Unknown } -> t
+    | Definition ({ definition = Alias alias } as r) -> begin
+        match Graph.find_module root alias with
+        | exception Not_found -> Definition { r with definition = Unknown }
+        | aliased -> normalize_loop root aliased
+      end
+
+  let normalize root t =
+    match t with
+    | Definition { sort = Sort.Defined } -> normalize_loop root t
+    | Definition { sort = Sort.Declared _ } | Declaration _ ->
+        match Graph.find_module root (raw_path t) with
+        | exception Not_found -> normalize_loop root t
+        | t -> normalize_loop root t
+
+  let unnormalize t = t
+
+  let origin root t =
+    raw_origin (normalize root t)
+
+  let path root t =
+    raw_path (normalize root t)
+
+  let sort root t =
+    raw_sort (normalize root t)
+
+  let definition t =
+    match Module.unnormalize t with
+    | Declaration _ -> Unknown
+    | Definition { definition; _ } -> definition
+
+  let force root t =
+    let t = Module.normalize root t in
+    match definition t with
+    | Alias _ -> assert false
+    | Unknown
+    | Functor _
+    | Signature { components = Forced _ } -> t
+    | Signature ({ components = Unforced components; _} as r) -> begin
+        let rec loop types class_types module_types modules = function
+          | [] -> Forced { types; class_types; module_types; modules }
+          | Type(name, desc, dpr) :: rest ->
+              let typ = Type.child t name (Some desc) dpr in
+              let types = String_map.add name typ types in
+              loop types class_types module_types modules rest
+          | Class_type(name, desc, dpr) :: rest ->
+              let clty = Class_type.child t name (Some desc) dpr in
+              let class_types = String_map.add name clty class_types in
+              loop types class_types module_types modules rest
+          | Module_type(name, desc, dpr) :: rest ->
+              let mty = Module_type.child t name (Some desc) dpr in
+              let module_types = String_map.add name mty module_types in
+              loop types class_types module_types modules rest
+          | Module(name, desc, dpr) :: rest ->
+              let md = Module.child t name (Some desc) dpr in
+              let modules = String_map.add name md modules in
+              loop types class_types module_types modules rest
+        in
+        let empty = String_map.empty in
+        let components = loop empty empty empty empty (Lazy.force components) in
+        r.components <- components;
+        t
+      end
+
+  let types root t =
+    let t = force root t in
+    match definition t with
+    | Alias _ | Signature { components = Unforced _ } ->
+        assert false
+    | Unknown | Functor _ ->
+        None
+    | Signature { components = Forced { types; _ }; _ } ->
+        Some types
+
+  let class_types root t =
+    let t = force root t in
+    match definition t with
+    | Alias _ | Signature { components = Unforced _ } ->
+        assert false
+    | Unknown | Functor _ ->
+        None
+    | Signature { components = Forced { class_types; _ } } ->
+        Some class_types
+
+  let module_types root t =
+    let t = force root t in
+    match definition t with
+    | Alias _ | Signature { components = Unforced _ } ->
+        assert false
+    | Unknown | Functor _ ->
+        None
+    | Signature { components = Forced { module_types; _ } } ->
+        Some module_types
+
+  let modules root t =
+    let t = force root t in
+    match definition t with
+    | Alias _ | Signature { components = Unforced _ } ->
+        assert false
+    | Unknown | Functor _ ->
+        None
+    | Signature { components = Forced { modules; _ } } ->
+        Some modules
+
+  let find_type root t name =
+    let t = force root t in
+    match definition t with
+    | Alias _
+    | Signature { components = Unforced _ } ->
+        assert false
+    | Unknown ->
+        Type.child t name None Not_deprecated
+    | Functor _ ->
+        raise Not_found
+    | Signature { components = Forced { types; _ }; _ } ->
+        String_map.find name types
+
+  let find_class_type root t name =
+    let t = force root t in
+    match definition t with
+    | Alias _
+    | Signature { components = Unforced _ } ->
+        assert false
+    | Unknown ->
+        Class_type.child t name None Not_deprecated
+    | Functor _ ->
+        raise Not_found
+    | Signature { components = Forced { class_types; _ }; _ } ->
+        String_map.find name class_types
+
+  let find_module_type root t name =
+    let t = force root t in
+    match definition t with
+    | Alias _
+    | Signature { components = Unforced _ } ->
+        assert false
+    | Unknown ->
+        Module_type.child t name None Not_deprecated
+    | Functor _ ->
+        raise Not_found
+    | Signature { components = Forced { module_types; _ }; _ } ->
+        String_map.find name module_types
+
+  let find_module root t name =
+    let t = force root t in
+    match definition t with
+    | Alias _
+    | Signature { components = Unforced _ } ->
+        assert false
+    | Unknown ->
+        Module.child t name None Not_deprecated
+    | Functor _ ->
+        raise Not_found
+    | Signature { components = Forced { modules; _ }; _ } ->
+        String_map.find name modules
+
+  let find_application root t path =
+    let t = Module.normalize root t in
+    match definition t with
+    | Alias _ -> assert false
+    | Signature _ -> raise Not_found
+    | Unknown ->
+        let arg = Graph.find_module root path in
+        Module.application t arg None
+    | Functor ({ apply; applications } as r)->
+        let arg = Graph.find_module root path in
+        let arg_path = Module.path root arg in
+        match Path_map.find arg_path applications with
+        | md -> md
+        | exception Not_found ->
+            let md = Module.application t arg (Some (apply arg_path)) in
+            r.applications <- Path_map.add arg_path md applications;
+            md
+
+end
+
+and Diff : sig
+
+  module Item : sig
+
+    type t =
+      | Type of Ident.t * Type.t * Origin.t option
+      | Class_type of Ident.t * Class_type.t * Origin.t option
+      | Module_type of Ident.t * Module_type.t * Origin.t option
+      | Module of Ident.t * Module.t * Origin.t option
+
+    val origin : Graph.t -> t -> Origin.t
+
+    val id : Graph.t -> t -> Ident.t
+
+    val previous : Graph.t -> t -> Origin.t option
+
+  end
+
+  type t = Item.t list
+
+end = struct
+
+  module Item = struct
+
+    type t =
+      | Type of Ident.t * Type.t * Origin.t option
+      | Class_type of Ident.t * Class_type.t * Origin.t option
+      | Module_type of Ident.t * Module_type.t * Origin.t option
+      | Module of Ident.t * Module.t * Origin.t option
+
+    let origin root = function
+      | Type(_, typ, _) -> Type.origin root typ
+      | Class_type(_, clty, _) -> Class_type.origin root clty
+      | Module_type(_, mty, _) -> Module_type.origin root mty
+      | Module(_, md, _) -> Module.origin root md
+
+    let id _root = function
+      | Type(id, _, _) -> id
+      | Class_type(id, _, _) -> id
+      | Module_type(id, _, _) -> id
+      | Module(id, _, _) -> id
+
+    let previous _root = function
+      | Type(_, _, prev) -> prev
+      | Class_type(_, _, prev) -> prev
+      | Module_type(_, _, prev) -> prev
+      | Module(_, _, prev) -> prev
+
+  end
+
+  type t = Item.t list
+
+end
+
+and Component : sig
+
+  type source =
+    | Global
+    | Local
+    | Open
+
+  type t =
+    | Type of
+        Origin.t * Ident.t * Desc.Type.t * source * Desc.deprecated
+    | Class_type of
+        Origin.t * Ident.t * Desc.Class_type.t * source * Desc.deprecated
+    | Module_type of
+        Origin.t * Ident.t * Desc.Module_type.t * source * Desc.deprecated
+    | Module of
+        Origin.t * Ident.t * Desc.Module.t * source * Desc.deprecated
+    | Declare_type of Origin.t * Ident.t
+    | Declare_class_type of Origin.t * Ident.t
+    | Declare_module_type of Origin.t * Ident.t
+    | Declare_module of Origin.t * Ident.t
+
+end = Component
+
+and Graph : sig
+
+  type t
+
+  val empty : t
+
+  val add : t -> Component.t list -> t * Diff.t
+
+  val merge : t -> Diff.t -> t
+
+  val find_type : t -> Path.t -> Type.t
+
+  val find_class_type : t -> Path.t -> Class_type.t
+
+  val find_module_type : t -> Path.t -> Module_type.t
+
+  val find_module : t -> Path.t -> Module.t
+
+  val is_type_path_visible : t -> Path.t -> bool
+
+  val is_class_type_path_visible : t -> Path.t -> bool
+
+  val is_module_type_path_visible : t -> Path.t -> bool
+
+  val is_module_path_visible : t -> Path.t -> bool
+
+  val is_type_ident_visible : t -> Ident.t -> bool
+
+  val is_class_type_ident_visible : t -> Ident.t -> bool
+
+  val is_module_type_ident_visible : t -> Ident.t -> bool
+
+  val is_module_ident_visible : t -> Ident.t -> bool
+
+end = struct
+
+  type defs =
+    | Global of Ident.t
+    | Local of Ident.t
+    | Unambiguous of Ident.t
+    | Ambiguous of Ident.t * Ident.t list
+
+  type t =
+    { types : Type.t Ident_map.t;
+      class_types : Class_type.t Ident_map.t;
+      module_types : Module_type.t Ident_map.t;
+      modules : Module.t Ident_map.t;
+      type_names : defs String_map.t;
+      class_type_names : defs String_map.t;
+      module_type_names : defs String_map.t;
+      module_names : defs String_map.t; }
+
+  let empty =
+    { types = Ident_map.empty;
+      class_types = Ident_map.empty;
+      module_types = Ident_map.empty;
+      modules = Ident_map.empty;
+      type_names = String_map.empty;
+      class_type_names = String_map.empty;
+      module_type_names = String_map.empty;
+      module_names = String_map.empty; }
+
+  let previous_type t id =
+    match Ident_map.find id t.types with
+    | exception Not_found -> None
+    | prev ->
+      match Type.declaration prev with
+      | None -> failwith "Graph.add: type already defined"
+      | Some _ as o -> o
+
+  let previous_class_type t id =
+    match Ident_map.find id t.class_types with
+    | exception Not_found -> None
+    | prev ->
+      match Class_type.declaration prev with
+      | None -> failwith "Graph.add: class type already defined"
+      | Some _ as o -> o
+
+  let previous_module_type t id =
+    match Ident_map.find id t.module_types with
+    | exception Not_found -> None
+    | prev ->
+      match Module_type.declaration prev with
+      | None -> failwith "Graph.add: module type already defined"
+      | Some _ as o -> o
+
+  let previous_module t id =
+    match Ident_map.find id t.modules with
+    | exception Not_found -> None
+    | prev ->
+      match Module.declaration prev with
+      | None -> failwith "Graph.add: module already defined"
+      | Some _ as o -> o
+
+  let add_name source id names =
+    let name = Ident.name id in
+    let defs =
+      match source with
+      | Component.Global -> Global id
+      | Component.Local -> Local id
+      | Component.Open -> begin
+        match String_map.find name names with
+        | exception Not_found -> Unambiguous id
+        | Global id' -> Unambiguous id'
+        | Local id' -> Ambiguous(id, [id'])
+        | Unambiguous id' -> Ambiguous(id, [id'])
+        | Ambiguous(id', ids) -> Ambiguous(id, id' :: ids)
+      end
+    in
+    String_map.add name defs names
+
+  let merge_name id names =
+    let name = Ident.name id in
+    match String_map.find name names with
+    | exception Not_found ->
+        String_map.add name (Global id) names
+    | _ -> names
+
+  let add t descs =
+    let rec loop acc diff declarations = function
+      | [] -> loop_declarations acc diff declarations
+      | Component.Type(origin, id, desc, source, dpr) :: rest ->
+          let prev = previous_type acc id in
+          let typ = Type.base origin id (Some desc) dpr in
+          let types = Ident_map.add id typ acc.types in
+          let type_names = add_name source id acc.type_names in
+          let item = Diff.Item.Type(id, typ, prev) in
+          let diff = item :: diff in
+          let acc = { acc with types; type_names } in
+          loop acc diff declarations rest
+      | Component.Class_type(origin,id, desc, source, dpr) :: rest ->
+          let prev = previous_class_type acc id in
+          let clty = Class_type.base origin id (Some desc) dpr in
+          let class_types = Ident_map.add id clty acc.class_types in
+          let class_type_names = add_name source id acc.class_type_names in
+          let item = Diff.Item.Class_type(id, clty, prev) in
+          let diff = item :: diff in
+          let acc = { acc with class_types; class_type_names } in
+          loop acc diff declarations rest
+      | Component.Module_type(origin,id, desc, source, dpr) :: rest ->
+          let prev = previous_module_type acc id in
+          let mty = Module_type.base origin id (Some desc) dpr in
+          let module_types = Ident_map.add id mty acc.module_types in
+          let module_type_names = add_name source id acc.module_type_names in
+          let item = Diff.Item.Module_type(id, mty, prev) in
+          let diff = item :: diff in
+          let acc = { acc with module_types; module_type_names } in
+          loop acc diff declarations rest
+      | Component.Module(origin,id, desc, source, dpr) :: rest ->
+          let prev = previous_module acc id in
+          let md = Module.base origin id (Some desc) dpr in
+          let modules = Ident_map.add id md acc.modules in
+          let module_names = add_name source id acc.module_names in
+          let item = Diff.Item.Module(id, md, prev) in
+          let diff = item :: diff in
+          let acc = { acc with modules; module_names } in
+          loop acc diff declarations rest
+      | Component.Declare_type(_, id) as decl :: rest ->
+          let declarations = decl :: declarations in
+          let type_names =
+            (* CR lwhite: This should probably not always be [Global] *)
+            add_name Component.Global id acc.type_names
+          in
+          let acc = { acc with type_names } in
+          loop acc diff declarations rest
+      | Component.Declare_class_type(_, id) as decl :: rest ->
+          let declarations = decl :: declarations in
+          let class_type_names =
+            (* CR lwhite: This should probably not always be [Global] *)
+            add_name Component.Global id acc.class_type_names
+          in
+          let acc = { acc with class_type_names } in
+          loop acc diff declarations rest
+      | Component.Declare_module_type(_, id) as decl :: rest ->
+          let declarations = decl :: declarations in
+          let module_type_names =
+            (* CR lwhite: This should probably not always be [Global] *)
+            add_name Component.Global id acc.module_type_names
+          in
+          let acc = { acc with module_type_names } in
+          loop acc diff declarations rest
+      | Component.Declare_module(_, id) as decl :: rest ->
+          let declarations = decl :: declarations in
+          let module_names =
+            (* CR lwhite: This should probably not always be [Global] *)
+            add_name Component.Global id acc.module_names
+          in
+          let acc = { acc with module_names } in
+          loop acc diff declarations rest
+    and loop_declarations acc diff = function
+      | [] -> acc, diff
+      | Component.Declare_type(origin, id) :: rest ->
+          if Ident_map.mem id acc.types then begin
+            loop_declarations acc diff rest
+          end else begin
+            let typ = Type.declare origin id in
+            let types = Ident_map.add id typ acc.types in
+            let acc = { acc with types } in
+            loop_declarations acc diff rest
+          end
+      | Component.Declare_class_type(origin, id) :: rest ->
+          if Ident_map.mem id acc.class_types then begin
+            loop_declarations acc diff rest
+          end else begin
+            let clty = Class_type.declare origin id in
+            let class_types = Ident_map.add id clty acc.class_types in
+            let acc = { acc with class_types } in
+            loop_declarations acc diff rest
+          end
+      | Component.Declare_module_type(origin, id) :: rest ->
+          if Ident_map.mem id acc.module_types then begin
+            loop_declarations acc diff rest
+          end else begin
+            let mty = Module_type.declare origin id in
+            let module_types = Ident_map.add id mty acc.module_types in
+            let acc = { acc with module_types } in
+            loop_declarations acc diff rest
+          end
+      | Component.Declare_module(origin, id) :: rest ->
+          if Ident_map.mem id acc.modules then begin
+            loop_declarations acc diff rest
+          end else begin
+            let md = Module.declare origin id in
+            let modules = Ident_map.add id md acc.modules in
+            let acc = { acc with modules } in
+            loop_declarations acc diff rest
+          end
+      | ( Component.Type _
+        | Component.Class_type _
+        | Component.Module_type _
+        | Component.Module _) :: _ -> assert false
+    in
+    loop t [] [] descs
+
+  let merge t diff =
+    let rec loop acc = function
+      | [] -> acc
+      | Diff.Item.Type(id, typ, _) :: rest ->
+          let types = Ident_map.add id typ acc.types in
+          let type_names = merge_name id acc.type_names in
+          let acc = { acc with types; type_names } in
+          loop acc rest
+      | Diff.Item.Class_type(id, clty, _) :: rest ->
+          let class_types = Ident_map.add id clty acc.class_types in
+          let class_type_names = merge_name id acc.class_type_names in
+          let acc = { acc with class_types; class_type_names } in
+          loop acc rest
+      | Diff.Item.Module_type(id, mty, _) :: rest ->
+          let module_types = Ident_map.add id mty acc.module_types in
+          let module_type_names = merge_name id acc.module_type_names in
+          let acc = { acc with module_types; module_type_names } in
+          loop acc rest
+      | Diff.Item.Module(id, md, _) :: rest ->
+          let modules = Ident_map.add id md acc.modules in
+          let module_names = merge_name id acc.module_names in
+          let acc = { acc with modules; module_names } in
+          loop acc rest
+    in
+    loop t diff
+
+  let rec find_module t path =
+    match path with
+    | Path.Pident id ->
+        Ident_map.find id t.modules
+    | Path.Pdot(p, name) ->
+        let md = find_module t p in
+        Module.find_module t md name
+    | Path.Papply(p, arg) ->
+        let md = find_module t p in
+        Module.find_application t md arg
+
+  let find_type t path =
+    match path with
+    | Path.Pident id ->
+        Ident_map.find id t.types
+    | Path.Pdot(p, name) ->
+        let md = find_module t p in
+        Module.find_type t md name
+    | Path.Papply _ ->
+        raise Not_found
+
+  let find_class_type t path =
+    match path with
+    | Path.Pident id ->
+        Ident_map.find id t.class_types
+    | Path.Pdot(p, name) ->
+        let md = find_module t p in
+        Module.find_class_type t md name
+    | Path.Papply _ ->
+        raise Not_found
+
+  let find_module_type t path =
+    match path with
+    | Path.Pident id ->
+        Ident_map.find id t.module_types
+    | Path.Pdot(p, name) ->
+        let md = find_module t p in
+        Module.find_module_type t md name
+    | Path.Papply _ ->
+        raise Not_found
+
+  let canonical_type_path t id =
+    match Ident_map.find id t.types with
+    | exception Not_found -> Path.Pident id
+    | md -> Type.path t md
+
+  let canonical_class_type_path t id =
+    match Ident_map.find id t.class_types with
+    | exception Not_found -> Path.Pident id
+    | md -> Class_type.path t md
+
+  let canonical_module_type_path t id =
+    match Ident_map.find id t.module_types with
+    | exception Not_found -> Path.Pident id
+    | md -> Module_type.path t md
+
+  let canonical_module_path t id =
+    match Ident_map.find id t.modules with
+    | exception Not_found -> Path.Pident id
+    | md -> Module.path t md
+
+  let is_module_ident_visible t id =
+    let name = Ident.name id in
+    match String_map.find name t.module_names with
+    | exception Not_found -> false
+    | Local id' -> Ident.equal id id'
+    | Global id' -> Ident.equal id id'
+    | Unambiguous id' -> Ident.equal id id'
+    | Ambiguous(id', ids) ->
+      if not (Ident.equal id id') then false
+      else begin
+        let paths = List.map (canonical_module_path t) ids in
+        let path = canonical_module_path t id in
+        List.for_all (Path.equal path) paths
+      end
+
+  let rec is_module_path_visible t = function
+    | Path.Pident id -> is_module_ident_visible t id
+    | Path.Pdot(path, _) ->
+        is_module_path_visible t path
+    | Path.Papply(path1, path2) ->
+        is_module_path_visible t path1
+        && is_module_path_visible t path2
+
+  let is_type_ident_visible t id =
+    let name = Ident.name id in
+    match String_map.find name t.type_names with
+    | exception Not_found -> false
+    | Local id' -> Ident.equal id id'
+    | Global id' -> Ident.equal id id'
+    | Unambiguous id' -> Ident.equal id id'
+    | Ambiguous(id', ids) ->
+      if not (Ident.equal id id') then false
+      else begin
+        let paths = List.map (canonical_type_path t) ids in
+        let path = canonical_type_path t id in
+        List.for_all (Path.equal path) paths
+      end
+
+  let is_type_path_visible t = function
+    | Path.Pident id -> is_type_ident_visible t id
+    | Path.Pdot(path, _) -> is_module_path_visible t path
+    | Path.Papply _ ->
+        failwith
+          "Short_paths_graph.Graph.is_type_path_visible: \
+           invalid type path"
+
+  let is_class_type_ident_visible t id =
+    let name = Ident.name id in
+    match String_map.find name t.class_type_names with
+    | exception Not_found -> false
+    | Local id' -> Ident.equal id id'
+    | Global id' -> Ident.equal id id'
+    | Unambiguous id' -> Ident.equal id id'
+    | Ambiguous(id', ids) ->
+      if not (Ident.equal id id') then false
+      else begin
+        let paths = List.map (canonical_class_type_path t) ids in
+        let path = canonical_class_type_path t id in
+        List.for_all (Path.equal path) paths
+      end
+
+  let is_class_type_path_visible t = function
+    | Path.Pident id -> is_class_type_ident_visible t id
+    | Path.Pdot(path, _) -> is_module_path_visible t path
+    | Path.Papply _ ->
+        failwith
+          "Short_paths_graph.Graph.is_class_type_path_visible: \
+           invalid class type path"
+
+  let is_module_type_ident_visible t id =
+    let name = Ident.name id in
+    match String_map.find name t.module_type_names with
+    | exception Not_found -> false
+    | Local id' -> Ident.equal id id'
+    | Global id' -> Ident.equal id id'
+    | Unambiguous id' -> Ident.equal id id'
+    | Ambiguous(id', ids) ->
+      if not (Ident.equal id id') then false
+      else begin
+        let paths = List.map (canonical_module_type_path t) ids in
+        let path = canonical_module_type_path t id in
+        List.for_all (Path.equal path) paths
+      end
+
+  let is_module_type_path_visible t = function
+    | Path.Pident id -> is_module_type_ident_visible t id
+    | Path.Pdot(path, _) -> is_module_path_visible t path
+    | Path.Papply _ ->
+        failwith
+          "Short_paths_graph.Graph.is_module_type_path_visible: \
+           invalid module type path"
+
+end
+
+type graph = Graph.t
diff --git a/src/ocaml/typing/short_paths_graph.mli b/src/ocaml/typing/short_paths_graph.mli
new file mode 100644
index 0000000..5f02176
--- /dev/null
+++ b/src/ocaml/typing/short_paths_graph.mli
@@ -0,0 +1,308 @@
+(** [Short_path_graph] is a representation of the environment (as a graph,
+    using [Graph.t]) that is more suitable to answer short path queries.
+
+    The only structures shared with the typechecker are [Ident.t] and [Path.t].
+    [Graph.t] is pure and doesn't hook into the [Env.t].
+    Context has to be rebuilt by outside code using [Graph.add].
+*)
+
+(* Generic definitions *)
+
+module String_map : Map.S with type key = string
+
+module Ident : sig
+
+  type t = Ident.t
+
+  val equal : t -> t -> bool
+
+  val compare : t -> t -> int
+
+  val name : t -> string
+
+  val global : string -> t
+
+end
+
+module Ident_map : Map.S with type key = Ident.t
+
+module Ident_set : Set.S with type elt = Ident.t
+
+module Path : sig
+
+  type t = Path.t =
+    | Pident of Ident.t
+    | Pdot of t * string
+    | Papply of t * t
+
+  val equal : t -> t -> bool
+
+  val compare : t -> t -> int
+
+end
+
+module Path_map : Map.S with type key = Path.t
+
+module Path_set : Set.S with type elt = Path.t
+
+(* Subset of the type algebra that is relevant to short path *)
+
+module Desc : sig
+
+  type deprecated =
+    | Deprecated
+    | Not_deprecated
+
+  module Type : sig
+
+    type t =
+      | Fresh
+      (** type t *)
+      | Nth of int
+      (** The n'th projection of type parameters.
+          E.g. for n < m, [type ('x_0,'x_1,...,'x_m-1) t = 'x_n]
+          is represented as [Nth n]. *)
+      | Subst of Path.t * int list
+      (** An alias to some other type after substitution of type parameters.
+          E.g. [type ('x_0, 'x_1', 'x_2, 'x_3) t = ('x_3, 'x_2) p]
+          is represented as [Subst (p, [3,2])]. *)
+      | Alias of Path.t
+      (** A direct alias to another type, preserving parameters.
+          E.g [type t = p], [type 'a t = 'a p], ...
+          are represented as [Alias p]. *)
+  end
+
+  module Class_type : sig
+
+    type t =
+      | Fresh
+      | Subst of Path.t * int list
+      | Alias of Path.t
+
+  end
+
+  module Module_type : sig
+
+    type t =
+      | Fresh
+      | Alias of Path.t
+
+  end
+
+  module Module : sig
+
+    type component =
+      | Type of string * Type.t * deprecated
+      | Class_type of string * Class_type.t * deprecated
+      | Module_type of string * Module_type.t * deprecated
+      | Module of string * t * deprecated
+
+    and components = component list
+
+    and kind =
+      | Signature of components Lazy.t
+      | Functor of (Path.t -> t)
+
+    and t =
+      | Fresh of kind
+      | Alias of Path.t
+
+  end
+
+  type source =
+    | Local
+    | Open
+
+  type t =
+    | Type of Ident.t * Type.t * source * deprecated
+    | Class_type of Ident.t * Class_type.t * source * deprecated
+    | Module_type of Ident.t * Module_type.t * source * deprecated
+    | Module of Ident.t * Module.t * source * deprecated
+    | Declare_type of Ident.t
+    | Declare_class_type of Ident.t
+    | Declare_module_type of Ident.t
+    | Declare_module of Ident.t
+
+end
+
+module Sort : sig
+
+  type t =
+    | Defined
+    | Declared of Ident_set.t
+
+end
+
+module Age : Natural.S
+
+module Dependency : Natural.S
+
+module Origin : sig
+
+  type t =
+    | Dependency of Dependency.t
+    | Dependencies of Dependency.t list
+    | Environment of Age.t
+
+  val equal : t -> t -> bool
+
+  val hash : t -> int
+
+end
+
+type graph
+
+module Type : sig
+
+  type t
+
+  val origin : graph -> t -> Origin.t
+
+  val path : graph -> t -> Path.t
+
+  val hidden : t -> bool
+
+  val sort : graph -> t -> Sort.t
+
+  type resolved =
+    | Nth of int
+    | Path of int list option * t
+
+  val resolve : graph -> t -> resolved
+
+end
+
+module Class_type : sig
+
+  type t
+
+  val origin : graph -> t -> Origin.t
+
+  val path : graph -> t -> Path.t
+
+  val hidden : t -> bool
+
+  val sort : graph -> t -> Sort.t
+
+  type resolved = int list option * t
+
+  val resolve : graph -> t -> resolved
+
+end
+
+module Module_type : sig
+
+  type t
+
+  val origin : graph -> t -> Origin.t
+
+  val path : graph -> t -> Path.t
+
+  val hidden : t -> bool
+
+  val sort : graph -> t -> Sort.t
+
+end
+
+module Module : sig
+
+  type t
+
+  val origin : graph -> t -> Origin.t
+
+  val path : graph -> t -> Path.t
+
+  val hidden : t -> bool
+
+  val sort : graph -> t -> Sort.t
+
+  val types : graph -> t -> Type.t String_map.t option
+
+  val class_types : graph -> t -> Class_type.t String_map.t option
+
+  val module_types : graph -> t -> Module_type.t String_map.t option
+
+  val modules : graph -> t -> t String_map.t option
+
+end
+
+module Diff : sig
+
+  module Item : sig
+
+    type t =
+      | Type of Ident.t * Type.t * Origin.t option
+      | Class_type of Ident.t * Class_type.t * Origin.t option
+      | Module_type of Ident.t * Module_type.t * Origin.t option
+      | Module of Ident.t * Module.t * Origin.t option
+
+    val origin : graph -> t -> Origin.t
+
+    val id : graph -> t -> Ident.t
+
+    val previous : graph -> t -> Origin.t option
+
+  end
+
+  type t = Item.t list
+
+end
+
+module Component : sig
+
+  type source =
+    | Global
+    | Local
+    | Open
+
+  type t =
+    | Type of
+        Origin.t * Ident.t * Desc.Type.t * source * Desc.deprecated
+    | Class_type of
+        Origin.t * Ident.t * Desc.Class_type.t * source * Desc.deprecated
+    | Module_type of
+        Origin.t * Ident.t * Desc.Module_type.t * source * Desc.deprecated
+    | Module of
+        Origin.t * Ident.t * Desc.Module.t * source * Desc.deprecated
+    | Declare_type of Origin.t * Ident.t
+    | Declare_class_type of Origin.t * Ident.t
+    | Declare_module_type of Origin.t * Ident.t
+    | Declare_module of Origin.t * Ident.t
+
+end
+
+module Graph : sig
+
+  type t = graph
+
+  val empty : t
+
+  val add : t -> Component.t list -> t * Diff.t
+
+  val merge : t -> Diff.t -> t
+
+  val find_type : t -> Path.t -> Type.t
+
+  val find_class_type : t -> Path.t -> Class_type.t
+
+  val find_module_type : t -> Path.t -> Module_type.t
+
+  val find_module : t -> Path.t -> Module.t
+
+  val is_type_path_visible : t -> Path.t -> bool
+
+  val is_class_type_path_visible : t -> Path.t -> bool
+
+  val is_module_type_path_visible : t -> Path.t -> bool
+
+  val is_module_path_visible : t -> Path.t -> bool
+
+  val is_type_ident_visible : t -> Ident.t -> bool
+
+  val is_class_type_ident_visible : t -> Ident.t -> bool
+
+  val is_module_type_ident_visible : t -> Ident.t -> bool
+
+  val is_module_ident_visible : t -> Ident.t -> bool
+
+end
diff --git a/src/ocaml/typing/signature_group.ml b/src/ocaml/typing/signature_group.ml
new file mode 100644
index 0000000..936c0fe
--- /dev/null
+++ b/src/ocaml/typing/signature_group.ml
@@ -0,0 +1,155 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*  Florian Angeletti, projet Cambium, Inria Paris                        *)
+(*                                                                        *)
+(*   Copyright 2021 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Fold on a signature by syntactic group of items *)
+
+(** Classes and class types generate ghosts signature items, we group them
+    together before printing *)
+type sig_item =
+  {
+    src: Types.signature_item;
+    post_ghosts: Types.signature_item list
+    (** ghost classes types are post-declared *);
+  }
+let flatten x = x.src :: x.post_ghosts
+
+type core_rec_group =
+  | Not_rec of sig_item
+  | Rec_group of sig_item list
+
+let rec_items = function
+  | Not_rec x -> [x]
+  | Rec_group x -> x
+
+(** Private row types are manifested as a sequence of definitions
+    preceding a recursive group, we collect them and separate them from the
+    syntatic recursive group. *)
+type rec_group =
+  { pre_ghosts: Types.signature_item list; group:core_rec_group }
+
+let next_group = function
+  | [] -> None
+  | src :: q ->
+      let ghosts, q =
+        match src with
+        | Types.Sig_class _ ->
+            (* a class declaration for [c] is followed by the ghost
+               declarations of class type [c], and types [c] and [#c] *)
+            begin match q with
+            | ct::t::ht::q -> [ct;t;ht], q
+            | _ -> assert false
+            end
+        | Types.Sig_class_type _  ->
+            (* a class type declaration for [ct] is followed by the ghost
+               declarations of types [ct] and [#ct] *)
+           begin match q with
+            | t::ht::q -> [t;ht], q
+            | _ -> assert false
+           end
+        | Types.(Sig_module _ | Sig_value _ | Sig_type _ | Sig_typext _
+                | Sig_modtype _) ->
+            [],q
+      in
+      Some({src; post_ghosts=ghosts}, q)
+
+let recursive_sigitem = function
+  | Types.Sig_type(ident, _, rs, _)
+  | Types.Sig_class(ident,_,rs,_)
+  | Types.Sig_class_type (ident,_,rs,_)
+  | Types.Sig_module(ident, _, _, rs, _) -> Some (ident,rs)
+  | Types.(Sig_value _ | Sig_modtype _ | Sig_typext _ )  -> None
+
+let next x =
+  let cons_group pre group q =
+    let group = Rec_group (List.rev group) in
+    Some({ pre_ghosts=List.rev pre; group },q)
+  in
+  let rec not_in_group pre l = match next_group l with
+    | None ->
+        assert (pre=[]);
+        None
+    | Some(elt, q)  ->
+        match recursive_sigitem elt.src with
+        | Some (id, _) when Btype.is_row_name (Ident.name id) ->
+            not_in_group (elt.src::pre) q
+        | None | Some (_, Types.Trec_not) ->
+            let sgroup = { pre_ghosts=List.rev pre; group=Not_rec elt } in
+            Some (sgroup,q)
+        | Some (id, Types.(Trec_first | Trec_next) )  ->
+            in_group ~pre ~ids:[id] ~group:[elt] q
+  and in_group ~pre ~ids ~group rem = match next_group rem with
+    | None -> cons_group pre group []
+    | Some (elt,next) ->
+        match recursive_sigitem elt.src with
+        | Some (id, Types.Trec_next) ->
+            in_group ~pre ~ids:(id::ids) ~group:(elt::group) next
+        | None | Some (_, Types.(Trec_not|Trec_first)) ->
+            cons_group pre group rem
+  in
+  not_in_group [] x
+
+let seq l = Seq.unfold next l
+let iter f l = Seq.iter f (seq l)
+let fold f acc l = Seq.fold_left f acc (seq l)
+
+let update_rec_next rs rem =
+  match rs with
+  | Types.Trec_next -> rem
+  | Types.(Trec_first | Trec_not) ->
+      match rem with
+      | Types.Sig_type (id, decl, Trec_next, priv) :: rem ->
+          Types.Sig_type (id, decl, rs, priv) :: rem
+      | Types.Sig_module (id, pres, mty, Trec_next, priv) :: rem ->
+          Types.Sig_module (id, pres, mty, rs, priv) :: rem
+      | _ -> rem
+
+type in_place_patch = {
+  ghosts: Types.signature;
+  replace_by: Types.signature_item option;
+}
+
+
+let replace_in_place f sg =
+  let rec next_group f before signature =
+    match next signature with
+    | None -> None
+    | Some(item,sg) ->
+        core_group f ~before ~ghosts:item.pre_ghosts ~before_group:[]
+          (rec_items item.group) ~sg
+  and core_group f ~before ~ghosts ~before_group current ~sg =
+    let commit ghosts = before_group @ List.rev_append ghosts before in
+    match current with
+    | [] -> next_group f (commit ghosts) sg
+    | a :: q ->
+        match f ~ghosts a.src with
+        | Some (info, {ghosts; replace_by}) ->
+            let after = List.concat_map flatten q @ sg in
+            let after = match recursive_sigitem a.src, replace_by with
+              | None, _ | _, Some _ -> after
+              | Some (_,rs), None -> update_rec_next rs after
+            in
+            let before = match replace_by with
+              | None -> commit ghosts
+              | Some x -> x :: commit ghosts
+            in
+            let sg = List.rev_append before after in
+            Some(info, sg)
+        | None ->
+            let before_group =
+              List.rev_append a.post_ghosts (a.src :: before_group)
+            in
+            core_group f ~before ~ghosts ~before_group q ~sg
+  in
+  next_group f [] sg
diff --git a/src/ocaml/typing/signature_group.mli b/src/ocaml/typing/signature_group.mli
new file mode 100644
index 0000000..c827543
--- /dev/null
+++ b/src/ocaml/typing/signature_group.mli
@@ -0,0 +1,85 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*  Florian Angeletti, projet Cambium, Inria Paris                        *)
+(*                                                                        *)
+(*   Copyright 2021 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Iterate on signature by syntactic group of items
+
+    Classes, class types and private row types adds ghost components to
+    the signature where they are defined.
+
+    When editing or printing a signature it is therefore important to
+    identify those ghost components.
+
+    This module provides type grouping together ghost components
+    with the corresponding core item (or recursive group) and
+    the corresponding iterators.
+*)
+
+(** Classes and class types generate ghosts signature items, we group them
+    together before printing *)
+type sig_item =
+  {
+    src: Types.signature_item (** the syntactic item *)
+;
+    post_ghosts: Types.signature_item list
+    (** ghost classes types are post-declared *);
+  }
+
+(** [flatten sig_item] is [x.src :: x.post_ghosts] *)
+val flatten: sig_item -> Types.signature
+
+(** A group of mutually recursive definition *)
+type core_rec_group =
+  | Not_rec of sig_item
+  | Rec_group of sig_item list
+
+(** [rec_items group] is the list of sig_items in the group *)
+val rec_items: core_rec_group -> sig_item list
+
+(** Private #row types are manifested as a sequence of definitions
+    preceding a recursive group, we collect them and separate them from the
+    syntatic recursive group. *)
+type rec_group =
+  { pre_ghosts: Types.signature_item list; group:core_rec_group }
+
+(** The sequence [seq signature] iterates over [signature] {!rec_group} by
+    {!rec_group}.
+    The second element of the tuple in the {!full_seq} case is the not-yet
+    traversed part of the signature.
+*)
+val next: Types.signature -> (rec_group * Types.signature) option
+val seq: Types.signature -> rec_group Seq.t
+
+val iter: (rec_group -> unit) -> Types.signature -> unit
+val fold: ('acc -> rec_group -> 'acc) -> 'acc -> Types.signature -> 'acc
+
+(** Describe how to amend one element of a signature *)
+type in_place_patch = {
+  ghosts: Types.signature; (** updated list of ghost items *)
+  replace_by: Types.signature_item option;
+  (** replacement for the selected item *)
+}
+
+(**
+  [!replace_in_place patch sg] replaces the first element of the signature
+   for which [patch ~rec_group ~ghosts component] returns [Some (value,patch)].
+   The [rec_group] argument is the remaining part of the mutually
+   recursive group of [component].
+   The [ghosts] list is the current prefix of ghost components associated to
+   [component]
+*)
+val replace_in_place:
+  ( ghosts:Types.signature -> Types.signature_item
+    -> ('a * in_place_patch) option )
+  -> Types.signature -> ('a * Types.signature) option
diff --git a/src/ocaml/typing/stypes.ml b/src/ocaml/typing/stypes.ml
new file mode 100644
index 0000000..dfbcc99
--- /dev/null
+++ b/src/ocaml/typing/stypes.ml
@@ -0,0 +1,210 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Damien Doligez, projet Moscova, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2003 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Recording and dumping (partial) type information *)
+
+(*
+  We record all types in a list as they are created.
+  This means we can dump type information even if type inference fails,
+  which is extremely important, since type information is most
+  interesting in case of errors.
+*)
+
+open Annot;;
+open Lexing;;
+open Location;;
+open Typedtree;;
+
+let output_int oc i = output_string oc (Int.to_string i)
+
+type annotation =
+  | Ti_pat : 'k pattern_category * 'k general_pattern -> annotation
+  | Ti_expr  of expression
+  | Ti_class of class_expr
+  | Ti_mod   of module_expr
+  | An_call of Location.t * Annot.call
+  | An_ident of Location.t * string * Annot.ident
+;;
+
+let get_location ti =
+  match ti with
+  | Ti_pat (_, p)   -> p.pat_loc
+  | Ti_expr e  -> e.exp_loc
+  | Ti_class c -> c.cl_loc
+  | Ti_mod m   -> m.mod_loc
+  | An_call (l, _k) -> l
+  | An_ident (l, _s, _k) -> l
+;;
+
+let annotations = ref ([] : annotation list);;
+let phrases = ref ([] : Location.t list);;
+
+let record ti =
+  if !Clflags.annotations && not (get_location ti).Location.loc_ghost then
+    annotations := ti :: !annotations
+;;
+
+let record_phrase loc =
+  if !Clflags.annotations then phrases := loc :: !phrases;
+;;
+
+(* comparison order:
+   the intervals are sorted by order of increasing upper bound
+   same upper bound -> sorted by decreasing lower bound
+*)
+let cmp_loc_inner_first loc1 loc2 =
+  match compare loc1.loc_end.pos_cnum loc2.loc_end.pos_cnum with
+  | 0 -> compare loc2.loc_start.pos_cnum loc1.loc_start.pos_cnum
+  | x -> x
+;;
+let cmp_ti_inner_first ti1 ti2 =
+  cmp_loc_inner_first (get_location ti1) (get_location ti2)
+;;
+
+let print_position pp pos =
+  if pos = dummy_pos then
+    output_string pp "--"
+  else begin
+    output_char pp '\"';
+    output_string pp (String.escaped pos.pos_fname);
+    output_string pp "\" ";
+    output_int pp pos.pos_lnum;
+    output_char pp ' ';
+    output_int pp pos.pos_bol;
+    output_char pp ' ';
+    output_int pp pos.pos_cnum;
+  end
+;;
+
+let print_location pp loc =
+  print_position pp loc.loc_start;
+  output_char pp ' ';
+  print_position pp loc.loc_end;
+;;
+
+let sort_filter_phrases () =
+  let ph = List.sort (fun x y -> cmp_loc_inner_first y x) !phrases in
+  let rec loop accu cur l =
+    match l with
+    | [] -> accu
+    | loc :: t ->
+       if cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum
+          && cur.loc_end.pos_cnum >= loc.loc_end.pos_cnum
+       then loop accu cur t
+       else loop (loc :: accu) loc t
+  in
+  phrases := loop [] Location.none ph;
+;;
+
+let rec printtyp_reset_maybe loc =
+  match !phrases with
+  | cur :: t when cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum ->
+     Printtyp.reset ();
+     phrases := t;
+     printtyp_reset_maybe loc;
+  | _ -> ()
+;;
+
+let call_kind_string k =
+  match k with
+  | Tail -> "tail"
+  | Stack -> "stack"
+  | Inline -> "inline"
+;;
+
+let print_ident_annot pp str k =
+  match k with
+  | Idef l ->
+      output_string pp "def ";
+      output_string pp str;
+      output_char pp ' ';
+      print_location pp l;
+      output_char pp '\n'
+  | Iref_internal l ->
+      output_string pp "int_ref ";
+      output_string pp str;
+      output_char pp ' ';
+      print_location pp l;
+      output_char pp '\n'
+  | Iref_external ->
+      output_string pp "ext_ref ";
+      output_string pp str;
+      output_char pp '\n'
+;;
+
+(* The format of the annotation file is documented in emacs/caml-types.el. *)
+
+let print_info pp prev_loc ti =
+  match ti with
+  | Ti_class _ | Ti_mod _ -> prev_loc
+  | Ti_pat  (_, {pat_loc = loc; pat_type = typ; pat_env = env})
+  | Ti_expr     {exp_loc = loc; exp_type = typ; exp_env = env} ->
+      if loc <> prev_loc then begin
+        print_location pp loc;
+        output_char pp '\n'
+      end;
+      output_string pp "type(\n";
+      printtyp_reset_maybe loc;
+      Printtyp.mark_loops typ;
+      Format.pp_print_string Format.str_formatter "  ";
+      Printtyp.wrap_printing_env ~error:false env
+                       (fun () -> Printtyp.type_sch Format.str_formatter typ);
+      Format.pp_print_newline Format.str_formatter ();
+      let s = Format.flush_str_formatter () in
+      output_string pp s;
+      output_string pp ")\n";
+      loc
+  | An_call (loc, k) ->
+      if loc <> prev_loc then begin
+        print_location pp loc;
+        output_char pp '\n'
+      end;
+      output_string pp "call(\n  ";
+      output_string pp (call_kind_string k);
+      output_string pp "\n)\n";
+      loc
+  | An_ident (loc, str, k) ->
+      if loc <> prev_loc then begin
+        print_location pp loc;
+        output_char pp '\n'
+      end;
+      output_string pp "ident(\n  ";
+      print_ident_annot pp str k;
+      output_string pp ")\n";
+      loc
+;;
+
+let get_info () =
+  let info = List.fast_sort cmp_ti_inner_first !annotations in
+  annotations := [];
+  info
+;;
+
+let dump filename =
+  if !Clflags.annotations then begin
+    let do_dump _temp_filename pp =
+      let info = get_info () in
+      sort_filter_phrases ();
+      ignore (List.fold_left (print_info pp) Location.none info) in
+    begin match filename with
+    | None -> do_dump "" stdout
+    | Some filename ->
+        Misc.output_to_file_via_temporary ~mode:[Open_text] filename do_dump
+    end;
+    phrases := [];
+  end else begin
+    annotations := [];
+  end;
+;;
diff --git a/src/ocaml/typing/stypes.mli b/src/ocaml/typing/stypes.mli
new file mode 100644
index 0000000..fda575f
--- /dev/null
+++ b/src/ocaml/typing/stypes.mli
@@ -0,0 +1,36 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Damien Doligez, projet Moscova, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2003 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Recording and dumping (partial) type information *)
+
+(* Clflags.save_types must be true *)
+
+open Typedtree;;
+
+type annotation =
+  | Ti_pat : 'k pattern_category * 'k general_pattern -> annotation
+  | Ti_expr  of expression
+  | Ti_class of class_expr
+  | Ti_mod   of module_expr
+  | An_call of Location.t * Annot.call
+  | An_ident of Location.t * string * Annot.ident
+;;
+
+val record : annotation -> unit;;
+val record_phrase : Location.t -> unit;;
+val dump : string option -> unit;;
+
+val get_location : annotation -> Location.t;;
+val get_info : unit -> annotation list;;
diff --git a/src/ocaml/typing/subst.ml b/src/ocaml/typing/subst.ml
new file mode 100644
index 0000000..2a5170e
--- /dev/null
+++ b/src/ocaml/typing/subst.ml
@@ -0,0 +1,586 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Substitutions *)
+
+open Misc
+open Path
+open Types
+open Btype
+
+open Local_store
+
+type type_replacement =
+  | Path of Path.t
+  | Type_function of { params : type_expr list; body : type_expr }
+
+type t =
+  { types: type_replacement Path.Map.t;
+    modules: Path.t Path.Map.t;
+    modtypes: module_type Path.Map.t;
+    for_saving: bool;
+    loc: Location.t option;
+    make_loc_ghost: bool;
+  }
+
+let identity =
+  { types = Path.Map.empty;
+    modules = Path.Map.empty;
+    modtypes = Path.Map.empty;
+    for_saving = false;
+    loc = None;
+    make_loc_ghost = false;
+  }
+
+let add_type_path id p s = { s with types = Path.Map.add id (Path p) s.types }
+let add_type id p s = add_type_path (Pident id) p s
+
+let add_type_function id ~params ~body s =
+  { s with types = Path.Map.add id (Type_function { params; body }) s.types }
+
+let add_module_path id p s = { s with modules = Path.Map.add id p s.modules }
+let add_module id p s = add_module_path (Pident id) p s
+
+let add_modtype_path p ty s = { s with modtypes = Path.Map.add p ty s.modtypes }
+let add_modtype id ty s = add_modtype_path (Pident id) ty s
+
+let for_saving s = { s with for_saving = true }
+let change_locs s loc = { s with loc = Some loc }
+let make_loc_ghost s = { s with make_loc_ghost = true }
+
+let loc s x =
+  match s.loc with
+  | Some l -> l
+  | None ->
+    if s.for_saving && not !Clflags.keep_locs then Location.none
+    else if s.make_loc_ghost then { x with loc_ghost = true }
+    else x
+
+let remove_loc =
+  let open Ast_mapper in
+  {default_mapper with location = (fun _this _loc -> Location.none)}
+
+let is_not_doc = function
+  | {Parsetree.attr_name = {Location.txt = "ocaml.doc"}; _} -> false
+  | {Parsetree.attr_name = {Location.txt = "ocaml.text"}; _} -> false
+  | {Parsetree.attr_name = {Location.txt = "doc"}; _} -> false
+  | {Parsetree.attr_name = {Location.txt = "text"}; _} -> false
+  | _ -> true
+
+let attrs s x =
+  let x =
+    if s.for_saving && not !Clflags.keep_docs then
+      List.filter is_not_doc x
+    else x
+  in
+    if s.for_saving && not !Clflags.keep_locs
+    then remove_loc.Ast_mapper.attributes remove_loc x
+    else x
+
+let rec module_path s path =
+  try Path.Map.find path s.modules
+  with Not_found ->
+    match path with
+    | Pident _ -> path
+    | Pdot(p, n) ->
+       Pdot(module_path s p, n)
+    | Papply(p1, p2) ->
+       Papply(module_path s p1, module_path s p2)
+
+let modtype_path s path =
+      match Path.Map.find path s.modtypes with
+      | Mty_ident p -> p
+      | Mty_alias _ | Mty_signature _ | Mty_functor _ | Mty_for_hole ->
+         fatal_error "Subst.modtype_path"
+      | exception Not_found ->
+         match path with
+         | Pdot(p, n) ->
+            Pdot(module_path s p, n)
+         | Papply _ ->
+            fatal_error "Subst.modtype_path"
+         | Pident _ -> path
+
+let type_path s path =
+  match Path.Map.find path s.types with
+  | Path p -> p
+  | Type_function _ -> assert false
+  | exception Not_found ->
+     match path with
+     | Pident _ -> path
+     | Pdot(p, n) ->
+        Pdot(module_path s p, n)
+     | Papply _ ->
+        fatal_error "Subst.type_path"
+
+let type_path s p =
+  match Path.constructor_typath p with
+  | Regular p -> type_path s p
+  | Cstr (ty_path, cstr) -> Pdot(type_path s ty_path, cstr)
+  | LocalExt _ -> type_path s p
+  | Ext (p, cstr) -> Pdot(module_path s p, cstr)
+
+let to_subst_by_type_function s p =
+  match Path.Map.find p s.types with
+  | Path _ -> false
+  | Type_function _ -> true
+  | exception Not_found -> false
+
+(* Special type ids for saved signatures *)
+
+let new_id = s_ref (-1)
+let reset_for_saving () = new_id := -1
+
+let newpersty desc =
+  decr new_id;
+  Private_type_expr.create
+    desc ~level:generic_level ~scope:Btype.lowest_level ~id:!new_id
+
+(* ensure that all occurrences of 'Tvar None' are physically shared *)
+let tvar_none = Tvar None
+let tunivar_none = Tunivar None
+let norm = function
+  | Tvar None -> tvar_none
+  | Tunivar None -> tunivar_none
+  | d -> d
+
+let ctype_apply_env_empty = ref (fun _ -> assert false)
+
+(* Similar to [Ctype.nondep_type_rec]. *)
+let rec typexp copy_scope s ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tvar _ | Tunivar _ as desc ->
+      if s.for_saving || ty.id < 0 then
+        let ty' =
+          if s.for_saving then newpersty (norm desc)
+          else newty2 ty.level desc
+        in
+        For_copy.save_desc copy_scope ty desc;
+        Private_type_expr.set_desc ty (Tsubst (ty', None));
+        (* TODO: move this line to btype.ml
+           there is a similar problem also in ctype.ml *)
+        ty'
+      else ty
+  | Tsubst (ty, _) ->
+      ty
+  | Tfield (m, k, _t1, _t2) when not s.for_saving && m = dummy_method
+      && field_kind_repr k <> Fabsent && (repr ty).level < generic_level ->
+      (* do not copy the type of self when it is not generalized *)
+      ty
+(* cannot do it, since it would omit substitution
+  | Tvariant row when not (static_row row) ->
+      ty
+*)
+  | _ ->
+    let desc = ty.desc in
+    For_copy.save_desc copy_scope ty desc;
+    let tm = row_of_type ty in
+    let has_fixed_row =
+      not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm in
+    (* Make a stub *)
+    let ty' = if s.for_saving then newpersty (Tvar None) else newgenvar () in
+    Private_type_expr.set_scope ty' ty.scope;
+    Private_type_expr.set_desc ty (Tsubst (ty', None));
+    Private_type_expr.set_desc ty'
+      begin if has_fixed_row then
+        match tm.desc with (* PR#7348 *)
+          Tconstr (Pdot(m,i), tl, _abbrev) ->
+            let i' = String.sub i 0 (String.length i - 4) in
+            Tconstr(type_path s (Pdot(m,i')), tl, ref Mnil)
+        | _ -> assert false
+      else match desc with
+      | Tconstr (p, args, _abbrev) ->
+         let args = List.map (typexp copy_scope s) args in
+         begin match Path.Map.find p s.types with
+         | exception Not_found -> Tconstr(type_path s p, args, ref Mnil)
+         | Path _ -> Tconstr(type_path s p, args, ref Mnil)
+         | Type_function { params; body } ->
+            Tlink (!ctype_apply_env_empty params body args)
+         end
+      | Tpackage(p, fl) ->
+          Tpackage(modtype_path s p,
+                    List.map (fun (n, ty) -> (n, typexp copy_scope s ty)) fl)
+      | Tobject (t1, name) ->
+          let t1' = typexp copy_scope s t1 in
+          let name' =
+            match !name with
+            | None -> None
+            | Some (p, tl) ->
+                if to_subst_by_type_function s p
+                then None
+                else Some (type_path s p, List.map (typexp copy_scope s) tl)
+          in
+          Tobject (t1', ref name')
+      | Tvariant row ->
+          let row = row_repr row in
+          let more = repr row.row_more in
+          (* We must substitute in a subtle way *)
+          (* Tsubst takes a tuple containing the row var and the variant *)
+          begin match more.desc with
+            Tsubst (_, Some ty2) ->
+              (* This variant type has been already copied *)
+              Private_type_expr.set_desc ty (Tsubst (ty2, None));
+              (* avoid Tlink in the new type *)
+              Tlink ty2
+          | _ ->
+              let dup =
+                s.for_saving || more.level = generic_level || static_row row ||
+                match more.desc with Tconstr _ -> true | _ -> false in
+              (* Various cases for the row variable *)
+              let more' =
+                match more.desc with
+                  Tsubst (ty, None) -> ty
+                | Tconstr _ | Tnil -> typexp copy_scope s more
+                | Tunivar _ | Tvar _ ->
+                    For_copy.save_desc copy_scope more more.desc;
+                    if s.for_saving then newpersty (norm more.desc) else
+                    if dup && is_Tvar more then newgenty more.desc else more
+                | _ -> assert false
+              in
+              (* Register new type first for recursion *)
+              Private_type_expr.set_desc more
+                (Tsubst (more', Some ty'));
+              (* TODO: check if more' can be eliminated *)
+              (* Return a new copy *)
+              let row =
+                copy_row (typexp copy_scope s) true row (not dup) more' in
+              match row.row_name with
+              | Some (p, tl) ->
+                 Tvariant {row with row_name =
+                                      if to_subst_by_type_function s p
+                                      then None
+                                      else Some (type_path s p, tl)}
+              | None ->
+                  Tvariant row
+          end
+      | Tfield(_label, kind, _t1, t2) when field_kind_repr kind = Fabsent ->
+          Tlink (typexp copy_scope s t2)
+      | _ -> copy_type_desc (typexp copy_scope s) desc
+      end;
+    ty'
+
+(*
+   Always make a copy of the type. If this is not done, type levels
+   might not be correct.
+*)
+let type_expr s ty =
+  For_copy.with_scope (fun copy_scope -> typexp copy_scope s ty)
+
+let label_declaration copy_scope s l =
+  {
+    ld_id = l.ld_id;
+    ld_mutable = l.ld_mutable;
+    ld_type = typexp copy_scope s l.ld_type;
+    ld_loc = loc s l.ld_loc;
+    ld_attributes = attrs s l.ld_attributes;
+    ld_uid = l.ld_uid;
+  }
+
+let constructor_arguments copy_scope s = function
+  | Cstr_tuple l ->
+      Cstr_tuple (List.map (typexp copy_scope s) l)
+  | Cstr_record l ->
+      Cstr_record (List.map (label_declaration copy_scope s) l)
+
+let constructor_declaration copy_scope s c =
+  {
+    cd_id = c.cd_id;
+    cd_args = constructor_arguments copy_scope s c.cd_args;
+    cd_res = Option.map (typexp copy_scope s) c.cd_res;
+    cd_loc = loc s c.cd_loc;
+    cd_attributes = attrs s c.cd_attributes;
+    cd_uid = c.cd_uid;
+  }
+
+let type_declaration' copy_scope s decl =
+  { type_params = List.map (typexp copy_scope s) decl.type_params;
+    type_arity = decl.type_arity;
+    type_kind =
+      begin match decl.type_kind with
+        Type_abstract -> Type_abstract
+      | Type_variant (cstrs, rep) ->
+          Type_variant (List.map (constructor_declaration copy_scope s) cstrs,
+                        rep)
+      | Type_record(lbls, rep) ->
+          Type_record (List.map (label_declaration copy_scope s) lbls, rep)
+      | Type_open -> Type_open
+      end;
+    type_manifest =
+      begin
+        match decl.type_manifest with
+          None -> None
+        | Some ty -> Some(typexp copy_scope s ty)
+      end;
+    type_private = decl.type_private;
+    type_variance = decl.type_variance;
+    type_separability = decl.type_separability;
+    type_is_newtype = false;
+    type_expansion_scope = Btype.lowest_level;
+    type_loc = loc s decl.type_loc;
+    type_attributes = attrs s decl.type_attributes;
+    type_immediate = decl.type_immediate;
+    type_unboxed_default = decl.type_unboxed_default;
+    type_uid = decl.type_uid;
+  }
+
+let type_declaration s decl =
+  For_copy.with_scope (fun copy_scope -> type_declaration' copy_scope s decl)
+
+let class_signature copy_scope s sign =
+  { csig_self = typexp copy_scope s sign.csig_self;
+    csig_vars =
+      Vars.map
+        (function (m, v, t) -> (m, v, typexp copy_scope s t)) sign.csig_vars;
+    csig_concr = sign.csig_concr;
+    csig_inher =
+      List.map
+        (fun (p, tl) -> (type_path s p, List.map (typexp copy_scope s) tl))
+        sign.csig_inher;
+  }
+
+let rec class_type copy_scope s = function
+  | Cty_constr (p, tyl, cty) ->
+      let p' = type_path s p in
+      let tyl' = List.map (typexp copy_scope s) tyl in
+      let cty' = class_type copy_scope s cty in
+      Cty_constr (p', tyl', cty')
+  | Cty_signature sign ->
+      Cty_signature (class_signature copy_scope s sign)
+  | Cty_arrow (l, ty, cty) ->
+      Cty_arrow (l, typexp copy_scope s ty, class_type copy_scope s cty)
+
+let class_declaration' copy_scope s decl =
+  { cty_params = List.map (typexp copy_scope s) decl.cty_params;
+    cty_variance = decl.cty_variance;
+    cty_type = class_type copy_scope s decl.cty_type;
+    cty_path = type_path s decl.cty_path;
+    cty_new =
+      begin match decl.cty_new with
+      | None    -> None
+      | Some ty -> Some (typexp copy_scope s ty)
+      end;
+    cty_loc = loc s decl.cty_loc;
+    cty_attributes = attrs s decl.cty_attributes;
+    cty_uid = decl.cty_uid;
+  }
+
+let class_declaration s decl =
+  For_copy.with_scope (fun copy_scope -> class_declaration' copy_scope s decl)
+
+let cltype_declaration' copy_scope s decl =
+  { clty_params = List.map (typexp copy_scope s) decl.clty_params;
+    clty_variance = decl.clty_variance;
+    clty_type = class_type copy_scope s decl.clty_type;
+    clty_path = type_path s decl.clty_path;
+    clty_loc = loc s decl.clty_loc;
+    clty_attributes = attrs s decl.clty_attributes;
+    clty_uid = decl.clty_uid;
+  }
+
+let cltype_declaration s decl =
+  For_copy.with_scope (fun copy_scope -> cltype_declaration' copy_scope s decl)
+
+let class_type s cty =
+  For_copy.with_scope (fun copy_scope -> class_type copy_scope s cty)
+
+let value_description' copy_scope s descr =
+  { val_type = typexp copy_scope s descr.val_type;
+    val_kind = descr.val_kind;
+    val_loc = loc s descr.val_loc;
+    val_attributes = attrs s descr.val_attributes;
+    val_uid = descr.val_uid;
+   }
+
+let value_description s descr =
+  For_copy.with_scope (fun copy_scope -> value_description' copy_scope s descr)
+
+let extension_constructor' copy_scope s ext =
+  { ext_type_path = type_path s ext.ext_type_path;
+    ext_type_params = List.map (typexp copy_scope s) ext.ext_type_params;
+    ext_args = constructor_arguments copy_scope s ext.ext_args;
+    ext_ret_type = Option.map (typexp copy_scope s) ext.ext_ret_type;
+    ext_private = ext.ext_private;
+    ext_attributes = attrs s ext.ext_attributes;
+    ext_loc = if s.for_saving then Location.none else ext.ext_loc;
+    ext_uid = ext.ext_uid;
+  }
+
+let extension_constructor s ext =
+  For_copy.with_scope
+    (fun copy_scope -> extension_constructor' copy_scope s ext)
+
+type scoping =
+  | Keep
+  | Make_local
+  | Rescope of int
+
+let rename_bound_idents scoping s sg =
+  let rename =
+    let open Ident in
+    match scoping with
+    | Keep -> (fun id -> create_scoped ~scope:(scope id) (name id))
+    | Make_local -> Ident.rename
+    | Rescope scope -> (fun id -> create_scoped ~scope (name id))
+  in
+  let rec rename_bound_idents s sg = function
+    | [] -> sg, s
+    | Sig_type(id, td, rs, vis) :: rest ->
+        let id' = rename id in
+        rename_bound_idents
+          (add_type id (Pident id') s)
+          (Sig_type(id', td, rs, vis) :: sg)
+          rest
+    | Sig_module(id, pres, md, rs, vis) :: rest ->
+        let id' = rename id in
+        rename_bound_idents
+          (add_module id (Pident id') s)
+          (Sig_module (id', pres, md, rs, vis) :: sg)
+          rest
+    | Sig_modtype(id, mtd, vis) :: rest ->
+        let id' = rename id in
+        rename_bound_idents
+          (add_modtype id (Mty_ident(Pident id')) s)
+          (Sig_modtype(id', mtd, vis) :: sg)
+          rest
+    | Sig_class(id, cd, rs, vis) :: rest ->
+        (* cheat and pretend they are types cf. PR#6650 *)
+        let id' = rename id in
+        rename_bound_idents
+          (add_type id (Pident id') s)
+          (Sig_class(id', cd, rs, vis) :: sg)
+          rest
+    | Sig_class_type(id, ctd, rs, vis) :: rest ->
+        (* cheat and pretend they are types cf. PR#6650 *)
+        let id' = rename id in
+        rename_bound_idents
+          (add_type id (Pident id') s)
+          (Sig_class_type(id', ctd, rs, vis) :: sg)
+          rest
+    | Sig_value(id, vd, vis) :: rest ->
+        (* scope doesn't matter for value identifiers. *)
+        let id' = Ident.rename id in
+        rename_bound_idents s (Sig_value(id', vd, vis) :: sg) rest
+    | Sig_typext(id, ec, es, vis) :: rest ->
+        let id' = rename id in
+        rename_bound_idents s (Sig_typext(id',ec,es,vis) :: sg) rest
+  in
+  rename_bound_idents s [] sg
+
+let rec modtype scoping s = function
+    Mty_ident p as mty ->
+      begin match Path.Map.find p s.modtypes with
+       | mty -> mty
+       | exception Not_found ->
+          begin match p with
+          | Pident _ -> mty
+          | Pdot(p, n) ->
+             Mty_ident(Pdot(module_path s p, n))
+          | Papply _ ->
+             fatal_error "Subst.modtype"
+          end
+      end
+  | Mty_signature sg ->
+      Mty_signature(signature scoping s sg)
+  | Mty_functor(Unit, res) ->
+      Mty_functor(Unit, modtype scoping s res)
+  | Mty_functor(Named (None, arg), res) ->
+      Mty_functor(Named (None, (modtype scoping s) arg), modtype scoping s res)
+  | Mty_functor(Named (Some id, arg), res) ->
+      let id' = Ident.rename id in
+      Mty_functor(Named (Some id', (modtype scoping s) arg),
+                  modtype scoping (add_module id (Pident id') s) res)
+  | Mty_alias p ->
+      Mty_alias (module_path s p)
+  | Mty_for_hole -> Mty_for_hole
+
+and signature scoping s sg =
+  (* Components of signature may be mutually recursive (e.g. type declarations
+     or class and type declarations), so first build global renaming
+     substitution... *)
+  let (sg', s') = rename_bound_idents scoping s sg in
+  (* ... then apply it to each signature component in turn *)
+  For_copy.with_scope (fun copy_scope ->
+    List.rev_map (signature_item' copy_scope scoping s') sg'
+  )
+
+
+and signature_item' copy_scope scoping s comp =
+  match comp with
+    Sig_value(id, d, vis) ->
+      Sig_value(id, value_description' copy_scope s d, vis)
+  | Sig_type(id, d, rs, vis) ->
+      Sig_type(id, type_declaration' copy_scope s d, rs, vis)
+  | Sig_typext(id, ext, es, vis) ->
+      Sig_typext(id, extension_constructor' copy_scope s ext, es, vis)
+  | Sig_module(id, pres, d, rs, vis) ->
+      Sig_module(id, pres, module_declaration scoping s d, rs, vis)
+  | Sig_modtype(id, d, vis) ->
+      Sig_modtype(id, modtype_declaration scoping s d, vis)
+  | Sig_class(id, d, rs, vis) ->
+      Sig_class(id, class_declaration' copy_scope s d, rs, vis)
+  | Sig_class_type(id, d, rs, vis) ->
+      Sig_class_type(id, cltype_declaration' copy_scope s d, rs, vis)
+
+and signature_item scoping s comp =
+  For_copy.with_scope
+    (fun copy_scope -> signature_item' copy_scope scoping s comp)
+
+and module_declaration scoping s decl =
+  {
+    md_type = modtype scoping s decl.md_type;
+    md_attributes = attrs s decl.md_attributes;
+    md_loc = loc s decl.md_loc;
+    md_uid = decl.md_uid;
+  }
+
+and modtype_declaration scoping s decl  =
+  {
+    mtd_type = Option.map (modtype scoping s) decl.mtd_type;
+    mtd_attributes = attrs s decl.mtd_attributes;
+    mtd_loc = loc s decl.mtd_loc;
+    mtd_uid = decl.mtd_uid;
+  }
+
+
+(* For every binding k |-> d of m1, add k |-> f d to m2
+   and return resulting merged map. *)
+
+let merge_path_maps f m1 m2 =
+  Path.Map.fold (fun k d accu -> Path.Map.add k (f d) accu) m1 m2
+
+let keep_latest_loc l1 l2 =
+  match l2 with
+  | None -> l1
+  | Some _ -> l2
+
+let type_replacement s = function
+  | Path p -> Path (type_path s p)
+  | Type_function { params; body } ->
+    For_copy.with_scope (fun copy_scope ->
+     let params = List.map (typexp copy_scope s) params in
+     let body = typexp copy_scope s body in
+     Type_function { params; body })
+
+(* Composition of substitutions:
+     apply (compose s1 s2) x = apply s2 (apply s1 x) *)
+
+let compose s1 s2 =
+  { types = merge_path_maps (type_replacement s2) s1.types s2.types;
+    modules = merge_path_maps (module_path s2) s1.modules s2.modules;
+    modtypes = merge_path_maps (modtype Keep s2) s1.modtypes s2.modtypes;
+    for_saving = s1.for_saving || s2.for_saving;
+    loc = keep_latest_loc s1.loc s2.loc;
+    make_loc_ghost = s1.make_loc_ghost || s2.make_loc_ghost;
+  }
diff --git a/src/ocaml/typing/subst.mli b/src/ocaml/typing/subst.mli
new file mode 100644
index 0000000..c73ab71
--- /dev/null
+++ b/src/ocaml/typing/subst.mli
@@ -0,0 +1,90 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Substitutions *)
+
+open Types
+
+type t
+
+(*
+   Substitutions are used to translate a type from one context to
+   another.  This requires substituting paths for identifiers, and
+   possibly also lowering the level of non-generic variables so that
+   they are inferior to the maximum level of the new context.
+
+   Substitutions can also be used to create a "clean" copy of a type.
+   Indeed, non-variable node of a type are duplicated, with their
+   levels set to generic level.  That way, the resulting type is
+   well-formed (decreasing levels), even if the original one was not.
+*)
+
+val identity: t
+
+val add_type: Ident.t -> Path.t -> t -> t
+val add_type_path: Path.t -> Path.t -> t -> t
+val add_type_function:
+  Path.t -> params:type_expr list -> body:type_expr -> t -> t
+val add_module: Ident.t -> Path.t -> t -> t
+val add_module_path: Path.t -> Path.t -> t -> t
+val add_modtype: Ident.t -> module_type -> t -> t
+val add_modtype_path: Path.t -> module_type -> t -> t
+
+val for_saving: t -> t
+val make_loc_ghost: t -> t
+val reset_for_saving: unit -> unit
+val change_locs: t -> Location.t -> t
+
+val module_path: t -> Path.t -> Path.t
+val type_path: t -> Path.t -> Path.t
+val modtype_path: t -> Path.t -> Path.t
+
+val type_expr: t -> type_expr -> type_expr
+val class_type: t -> class_type -> class_type
+val value_description: t -> value_description -> value_description
+val type_declaration: t -> type_declaration -> type_declaration
+val extension_constructor:
+        t -> extension_constructor -> extension_constructor
+val class_declaration: t -> class_declaration -> class_declaration
+val cltype_declaration: t -> class_type_declaration -> class_type_declaration
+
+(*
+   When applied to a signature item, a substitution not only modifies the types
+   present in its declaration, but also refreshes the identifier of the item.
+   Effectively this creates new declarations, and so one should decide what the
+   scope of this new declaration should be.
+
+   This is decided by the [scoping] argument passed to the following functions.
+*)
+
+type scoping =
+  | Keep
+  | Make_local
+  | Rescope of int
+
+val modtype: scoping -> t -> module_type -> module_type
+val signature: scoping -> t -> signature -> signature
+val signature_item: scoping -> t -> signature_item -> signature_item
+val modtype_declaration:
+  scoping -> t -> modtype_declaration -> modtype_declaration
+val module_declaration: scoping -> t -> module_declaration -> module_declaration
+
+(* Composition of substitutions:
+     apply (compose s1 s2) x = apply s2 (apply s1 x) *)
+val compose: t -> t -> t
+
+(* A forward reference to be filled in ctype.ml. *)
+val ctype_apply_env_empty:
+  (type_expr list -> type_expr -> type_expr list -> type_expr) ref
diff --git a/src/ocaml/typing/tast_iterator.ml b/src/ocaml/typing/tast_iterator.ml
new file mode 100644
index 0000000..9273de6
--- /dev/null
+++ b/src/ocaml/typing/tast_iterator.ml
@@ -0,0 +1,518 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                          Isaac "Izzy" Avram                            *)
+(*                                                                        *)
+(*   Copyright 2019 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Typedtree
+
+type iterator =
+  {
+    binding_op: iterator -> binding_op -> unit;
+    case: 'k . iterator -> 'k case -> unit;
+    class_declaration: iterator -> class_declaration -> unit;
+    class_description: iterator -> class_description -> unit;
+    class_expr: iterator -> class_expr -> unit;
+    class_field: iterator -> class_field -> unit;
+    class_signature: iterator -> class_signature -> unit;
+    class_structure: iterator -> class_structure -> unit;
+    class_type: iterator -> class_type -> unit;
+    class_type_declaration: iterator -> class_type_declaration -> unit;
+    class_type_field: iterator -> class_type_field -> unit;
+    env: iterator -> Env.t -> unit;
+    expr: iterator -> expression -> unit;
+    extension_constructor: iterator -> extension_constructor -> unit;
+    module_binding: iterator -> module_binding -> unit;
+    module_coercion: iterator -> module_coercion -> unit;
+    module_declaration: iterator -> module_declaration -> unit;
+    module_substitution: iterator -> module_substitution -> unit;
+    module_expr: iterator -> module_expr -> unit;
+    module_type: iterator -> module_type -> unit;
+    module_type_declaration: iterator -> module_type_declaration -> unit;
+    package_type: iterator -> package_type -> unit;
+    pat: 'k . iterator -> 'k general_pattern -> unit;
+    row_field: iterator -> row_field -> unit;
+    object_field: iterator -> object_field -> unit;
+    open_declaration: iterator -> open_declaration -> unit;
+    open_description: iterator -> open_description -> unit;
+    signature: iterator -> signature -> unit;
+    signature_item: iterator -> signature_item -> unit;
+    structure: iterator -> structure -> unit;
+    structure_item: iterator -> structure_item -> unit;
+    typ: iterator -> core_type -> unit;
+    type_declaration: iterator -> type_declaration -> unit;
+    type_declarations: iterator -> (rec_flag * type_declaration list) -> unit;
+    type_extension: iterator -> type_extension -> unit;
+    type_exception: iterator -> type_exception -> unit;
+    type_kind: iterator -> type_kind -> unit;
+    value_binding: iterator -> value_binding -> unit;
+    value_bindings: iterator -> (rec_flag * value_binding list) -> unit;
+    value_description: iterator -> value_description -> unit;
+    with_constraint: iterator -> with_constraint -> unit;
+  }
+
+let structure sub {str_items; str_final_env; _} =
+  List.iter (sub.structure_item sub) str_items;
+  sub.env sub str_final_env
+
+let class_infos sub f x =
+  List.iter (fun (ct, _) -> sub.typ sub ct) x.ci_params;
+  f x.ci_expr
+
+let module_type_declaration sub {mtd_type; _} =
+  Option.iter (sub.module_type sub) mtd_type
+
+let module_declaration sub {md_type; _} =
+  sub.module_type sub md_type
+let module_substitution _ _ = ()
+
+let include_infos f {incl_mod; _} = f incl_mod
+
+let class_type_declaration sub x =
+  class_infos sub (sub.class_type sub) x
+
+let class_declaration sub x =
+  class_infos sub (sub.class_expr sub) x
+
+let structure_item sub {str_desc; str_env; _} =
+  sub.env sub str_env;
+  match str_desc with
+  | Tstr_eval   (exp, _) -> sub.expr sub exp
+  | Tstr_value  (rec_flag, list) -> sub.value_bindings sub (rec_flag, list)
+  | Tstr_primitive v -> sub.value_description sub v
+  | Tstr_type (rec_flag, list) -> sub.type_declarations sub (rec_flag, list)
+  | Tstr_typext te -> sub.type_extension sub te
+  | Tstr_exception ext -> sub.type_exception sub ext
+  | Tstr_module mb -> sub.module_binding sub mb
+  | Tstr_recmodule list -> List.iter (sub.module_binding sub) list
+  | Tstr_modtype x -> sub.module_type_declaration sub x
+  | Tstr_class list ->
+      List.iter (fun (cls,_) -> sub.class_declaration sub cls) list
+  | Tstr_class_type list ->
+      List.iter (fun (_, _, cltd) -> sub.class_type_declaration sub cltd) list
+  | Tstr_include incl -> include_infos (sub.module_expr sub) incl
+  | Tstr_open od -> sub.open_declaration sub od
+  | Tstr_attribute _ -> ()
+
+let value_description sub x = sub.typ sub x.val_desc
+
+let label_decl sub {ld_type; _} = sub.typ sub ld_type
+
+let constructor_args sub = function
+  | Cstr_tuple l -> List.iter (sub.typ sub) l
+  | Cstr_record l -> List.iter (label_decl sub) l
+
+let constructor_decl sub {cd_args; cd_res; _} =
+  constructor_args sub cd_args;
+  Option.iter (sub.typ sub) cd_res
+
+let type_kind sub = function
+  | Ttype_abstract -> ()
+  | Ttype_variant list -> List.iter (constructor_decl sub) list
+  | Ttype_record list -> List.iter (label_decl sub) list
+  | Ttype_open -> ()
+
+let type_declaration sub {typ_cstrs; typ_kind; typ_manifest; typ_params; _} =
+  List.iter
+    (fun (c1, c2, _) ->
+      sub.typ sub c1;
+      sub.typ sub c2)
+    typ_cstrs;
+  sub.type_kind sub typ_kind;
+  Option.iter (sub.typ sub) typ_manifest;
+  List.iter (fun (c, _) -> sub.typ sub c) typ_params
+
+let type_declarations sub (_, list) = List.iter (sub.type_declaration sub) list
+
+let type_extension sub {tyext_constructors; tyext_params; _} =
+  List.iter (fun (c, _) -> sub.typ sub c) tyext_params;
+  List.iter (sub.extension_constructor sub) tyext_constructors
+
+let type_exception sub {tyexn_constructor; _} =
+  sub.extension_constructor sub tyexn_constructor
+
+let extension_constructor sub {ext_kind; _} =
+  match ext_kind with
+  | Text_decl (ctl, cto) ->
+      constructor_args sub ctl;
+      Option.iter (sub.typ sub) cto
+  | Text_rebind _ -> ()
+
+let pat_extra sub (e, _loc, _attrs) = match e with
+  | Tpat_type _ -> ()
+  | Tpat_unpack -> ()
+  | Tpat_open (_, _, env) -> sub.env sub env
+  | Tpat_constraint ct -> sub.typ sub ct
+
+let pat
+  : type k . iterator -> k general_pattern -> unit
+  = fun sub {pat_extra = extra; pat_desc; pat_env; _} ->
+  sub.env sub pat_env;
+  List.iter (pat_extra sub) extra;
+  match pat_desc with
+  | Tpat_any  -> ()
+  | Tpat_var _ -> ()
+  | Tpat_constant _ -> ()
+  | Tpat_tuple l -> List.iter (sub.pat sub) l
+  | Tpat_construct (_, _, l, vto) ->
+      List.iter (sub.pat sub) l;
+      Option.iter (fun (_ids, ct) -> sub.typ sub ct) vto
+  | Tpat_variant (_, po, _) -> Option.iter (sub.pat sub) po
+  | Tpat_record (l, _) -> List.iter (fun (_, _, i) -> sub.pat sub i) l
+  | Tpat_array l -> List.iter (sub.pat sub) l
+  | Tpat_alias (p, _, _) -> sub.pat sub p
+  | Tpat_lazy p -> sub.pat sub p
+  | Tpat_value p -> sub.pat sub (p :> pattern)
+  | Tpat_exception p -> sub.pat sub p
+  | Tpat_or (p1, p2, _) ->
+      sub.pat sub p1;
+      sub.pat sub p2
+
+let expr sub {exp_extra; exp_desc; exp_env; _} =
+  let extra = function
+    | Texp_constraint cty -> sub.typ sub cty
+    | Texp_coerce (cty1, cty2) ->
+        Option.iter (sub.typ sub) cty1;
+        sub.typ sub cty2
+    | Texp_newtype _ -> ()
+    | Texp_newtype' _ -> ()
+    | Texp_poly cto -> Option.iter (sub.typ sub) cto
+  in
+  List.iter (fun (e, _, _) -> extra e) exp_extra;
+  sub.env sub exp_env;
+  match exp_desc with
+  | Texp_ident _  -> ()
+  | Texp_constant _ -> ()
+  | Texp_let (rec_flag, list, exp) ->
+      sub.value_bindings sub (rec_flag, list);
+      sub.expr sub exp
+  | Texp_function {cases; _} ->
+     List.iter (sub.case sub) cases
+  | Texp_apply (exp, list) ->
+      sub.expr sub exp;
+      List.iter (fun (_, o) -> Option.iter (sub.expr sub) o) list
+  | Texp_match (exp, cases, _) ->
+      sub.expr sub exp;
+      List.iter (sub.case sub) cases
+  | Texp_try (exp, cases) ->
+      sub.expr sub exp;
+      List.iter (sub.case sub) cases
+  | Texp_tuple list -> List.iter (sub.expr sub) list
+  | Texp_construct (_, _, args) -> List.iter (sub.expr sub) args
+  | Texp_variant (_, expo) -> Option.iter (sub.expr sub) expo
+  | Texp_record { fields; extended_expression; _} ->
+      Array.iter (function
+        | _, Kept _ -> ()
+        | _, Overridden (_, exp) -> sub.expr sub exp)
+        fields;
+      Option.iter (sub.expr sub) extended_expression;
+  | Texp_field (exp, _, _) -> sub.expr sub exp
+  | Texp_setfield (exp1, _, _, exp2) ->
+      sub.expr sub exp1;
+      sub.expr sub exp2
+  | Texp_array list -> List.iter (sub.expr sub) list
+  | Texp_ifthenelse (exp1, exp2, expo) ->
+      sub.expr sub exp1;
+      sub.expr sub exp2;
+      Option.iter (sub.expr sub) expo
+  | Texp_sequence (exp1, exp2) ->
+      sub.expr sub exp1;
+      sub.expr sub exp2
+  | Texp_while (exp1, exp2) ->
+      sub.expr sub exp1;
+      sub.expr sub exp2
+  | Texp_for (_, _, exp1, exp2, _, exp3) ->
+      sub.expr sub exp1;
+      sub.expr sub exp2;
+      sub.expr sub exp3
+  | Texp_send (exp, _, expo) ->
+      sub.expr sub exp;
+      Option.iter (sub.expr sub) expo
+  | Texp_new _ -> ()
+  | Texp_instvar _ -> ()
+  | Texp_setinstvar (_, _, _, exp) ->sub.expr sub exp
+  | Texp_override (_, list) ->
+      List.iter (fun (_, _, e) -> sub.expr sub e) list
+  | Texp_letmodule (_, _, _, mexpr, exp) ->
+      sub.module_expr sub mexpr;
+      sub.expr sub exp
+  | Texp_letexception (cd, exp) ->
+      sub.extension_constructor sub cd;
+      sub.expr sub exp
+  | Texp_assert exp -> sub.expr sub exp
+  | Texp_lazy exp -> sub.expr sub exp
+  | Texp_object (cl, _) -> sub.class_structure sub cl
+  | Texp_pack mexpr -> sub.module_expr sub mexpr
+  | Texp_letop {let_ = l; ands; body; _} ->
+      sub.binding_op sub l;
+      List.iter (sub.binding_op sub) ands;
+      sub.case sub body
+  | Texp_unreachable -> ()
+  | Texp_extension_constructor _ -> ()
+  | Texp_open (od, e) ->
+      sub.open_declaration sub od;
+      sub.expr sub e
+  | Texp_hole -> ()
+
+
+let package_type sub {pack_fields; _} =
+  List.iter (fun (_, p) -> sub.typ sub p) pack_fields
+
+let binding_op sub {bop_exp; _} = sub.expr sub bop_exp
+
+let signature sub {sig_items; sig_final_env; _} =
+  sub.env sub sig_final_env;
+  List.iter (sub.signature_item sub) sig_items
+
+let signature_item sub {sig_desc; sig_env; _} =
+  sub.env sub sig_env;
+  match sig_desc with
+  | Tsig_value v -> sub.value_description sub v
+  | Tsig_type (rf, tdl)  -> sub.type_declarations sub (rf, tdl)
+  | Tsig_typesubst list -> sub.type_declarations sub (Nonrecursive, list)
+  | Tsig_typext te -> sub.type_extension sub te
+  | Tsig_exception ext -> sub.type_exception sub ext
+  | Tsig_module x -> sub.module_declaration sub x
+  | Tsig_modsubst x -> sub.module_substitution sub x
+  | Tsig_recmodule list -> List.iter (sub.module_declaration sub) list
+  | Tsig_modtype x -> sub.module_type_declaration sub x
+  | Tsig_modtypesubst x -> sub.module_type_declaration sub x
+  | Tsig_include incl -> include_infos (sub.module_type sub) incl
+  | Tsig_class list -> List.iter (sub.class_description sub) list
+  | Tsig_class_type list -> List.iter (sub.class_type_declaration sub) list
+  | Tsig_open od -> sub.open_description sub od
+  | Tsig_attribute _ -> ()
+
+let class_description sub x =
+  class_infos sub (sub.class_type sub) x
+
+let functor_parameter sub = function
+  | Unit -> ()
+  | Named (_, _, mtype) -> sub.module_type sub mtype
+
+let module_type sub {mty_desc; mty_env; _} =
+  sub.env sub mty_env;
+  match mty_desc with
+  | Tmty_ident _      -> ()
+  | Tmty_alias _      -> ()
+  | Tmty_signature sg -> sub.signature sub sg
+  | Tmty_functor (arg, mtype2) ->
+      functor_parameter sub arg;
+      sub.module_type sub mtype2
+  | Tmty_with (mtype, list) ->
+      sub.module_type sub mtype;
+      List.iter (fun (_, _, e) -> sub.with_constraint sub e) list
+  | Tmty_typeof mexpr -> sub.module_expr sub mexpr
+
+let with_constraint sub = function
+  | Twith_type      decl -> sub.type_declaration sub decl
+  | Twith_typesubst decl -> sub.type_declaration sub decl
+  | Twith_module    _    -> ()
+  | Twith_modsubst  _    -> ()
+  | Twith_modtype   _    -> ()
+  | Twith_modtypesubst _ -> ()
+
+
+let open_description sub {open_env; _} = sub.env sub open_env
+
+let open_declaration sub {open_expr; open_env; _} =
+  sub.module_expr sub open_expr;
+  sub.env sub open_env
+
+let module_coercion sub = function
+  | Tcoerce_none -> ()
+  | Tcoerce_functor (c1,c2) ->
+      sub.module_coercion sub c1;
+      sub.module_coercion sub c2
+  | Tcoerce_alias (env, _, c1) ->
+      sub.env sub env;
+      sub.module_coercion sub c1
+  | Tcoerce_structure (l1, l2) ->
+      List.iter (fun (_, c) -> sub.module_coercion sub c) l1;
+      List.iter (fun (_, _ ,c) -> sub.module_coercion sub c) l2
+  | Tcoerce_primitive {pc_env; _} -> sub.env sub pc_env
+
+let module_expr sub {mod_desc; mod_env; _} =
+  sub.env sub mod_env;
+  match mod_desc with
+  | Tmod_ident _ | Tmod_hole  -> ()
+  | Tmod_structure st -> sub.structure sub st
+  | Tmod_functor (arg, mexpr) ->
+      functor_parameter sub arg;
+      sub.module_expr sub mexpr
+  | Tmod_apply (mexp1, mexp2, c) ->
+      sub.module_expr sub mexp1;
+      sub.module_expr sub mexp2;
+      sub.module_coercion sub c
+  | Tmod_constraint (mexpr, _, Tmodtype_implicit, c) ->
+      sub.module_expr sub mexpr;
+      sub.module_coercion sub c
+  | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, c) ->
+      sub.module_expr sub mexpr;
+      sub.module_type sub mtype;
+      sub.module_coercion sub c
+  | Tmod_unpack (exp, _) -> sub.expr sub exp
+
+let module_binding sub {mb_expr; _} = sub.module_expr sub mb_expr
+
+let class_expr sub {cl_desc; cl_env; _} =
+  sub.env sub cl_env;
+  match cl_desc with
+  | Tcl_constraint (cl, clty, _, _, _) ->
+      sub.class_expr sub cl;
+      Option.iter (sub.class_type sub) clty
+  | Tcl_structure clstr -> sub.class_structure sub clstr
+  | Tcl_fun (_, pat, priv, cl, _) ->
+      sub.pat sub pat;
+      List.iter (fun (_, e) -> sub.expr sub e) priv;
+      sub.class_expr sub cl
+  | Tcl_apply (cl, args) ->
+      sub.class_expr sub cl;
+      List.iter (fun (_, e) -> Option.iter (sub.expr sub) e) args
+  | Tcl_let (rec_flag, value_bindings, ivars, cl) ->
+      sub.value_bindings sub (rec_flag, value_bindings);
+      List.iter (fun (_, e) -> sub.expr sub e) ivars;
+      sub.class_expr sub cl
+  | Tcl_ident (_, _, tyl) -> List.iter (sub.typ sub) tyl
+  | Tcl_open (od, e) ->
+      sub.open_description sub od;
+      sub.class_expr sub e
+
+let class_type sub {cltyp_desc; cltyp_env; _} =
+  sub.env sub cltyp_env;
+  match cltyp_desc with
+  | Tcty_signature csg -> sub.class_signature sub csg
+  | Tcty_constr (_, _, list) -> List.iter (sub.typ sub) list
+  | Tcty_arrow (_, ct, cl) ->
+      sub.typ sub ct;
+      sub.class_type sub cl
+  | Tcty_open (od, e) ->
+      sub.open_description sub od;
+      sub.class_type sub e
+
+let class_signature sub {csig_self; csig_fields; _} =
+  sub.typ sub csig_self;
+  List.iter (sub.class_type_field sub) csig_fields
+
+let class_type_field sub {ctf_desc; _} =
+  match ctf_desc with
+  | Tctf_inherit ct -> sub.class_type sub ct
+  | Tctf_val (_, _, _, ct) ->  sub.typ sub ct
+  | Tctf_method (_, _, _, ct) -> sub.typ sub ct
+  | Tctf_constraint  (ct1, ct2) ->
+      sub.typ sub ct1;
+      sub.typ sub ct2
+  | Tctf_attribute _ -> ()
+
+let typ sub {ctyp_desc; ctyp_env; _} =
+  sub.env sub ctyp_env;
+  match ctyp_desc with
+  | Ttyp_any   -> ()
+  | Ttyp_var _ -> ()
+  | Ttyp_arrow (_, ct1, ct2) ->
+      sub.typ sub ct1;
+      sub.typ sub ct2
+  | Ttyp_tuple list -> List.iter (sub.typ sub) list
+  | Ttyp_constr (_, _, list) ->  List.iter (sub.typ sub) list
+  | Ttyp_object (list, _) -> List.iter (sub.object_field sub) list
+  | Ttyp_class (_, _, list) -> List.iter (sub.typ sub) list
+  | Ttyp_alias (ct, _) -> sub.typ sub ct
+  | Ttyp_variant (list, _, _) -> List.iter (sub.row_field sub) list
+  | Ttyp_poly (_, ct) -> sub.typ sub ct
+  | Ttyp_package pack -> sub.package_type sub pack
+
+let class_structure sub {cstr_self; cstr_fields; _} =
+  sub.pat sub cstr_self;
+  List.iter (sub.class_field sub) cstr_fields
+
+let row_field sub {rf_desc; _} =
+  match rf_desc with
+  | Ttag (_, _, list) -> List.iter (sub.typ sub) list
+  | Tinherit ct -> sub.typ sub ct
+
+let object_field sub {of_desc; _} =
+  match of_desc with
+  | OTtag (_, ct) -> sub.typ sub ct
+  | OTinherit ct -> sub.typ sub ct
+
+let class_field_kind sub = function
+  | Tcfk_virtual ct -> sub.typ sub ct
+  | Tcfk_concrete (_, e) -> sub.expr sub e
+
+let class_field sub {cf_desc; _} = match cf_desc with
+  | Tcf_inherit (_, cl, _, _, _) -> sub.class_expr sub cl
+  | Tcf_constraint (cty1, cty2) ->
+      sub.typ sub cty1;
+      sub.typ sub cty2
+  | Tcf_val (_, _, _, k, _) -> class_field_kind sub k
+  | Tcf_method (_, _, k) -> class_field_kind sub k
+  | Tcf_initializer exp -> sub.expr sub exp
+  | Tcf_attribute _ -> ()
+
+let value_bindings sub (_, list) = List.iter (sub.value_binding sub) list
+
+let case sub {c_lhs; c_guard; c_rhs} =
+  sub.pat sub c_lhs;
+  Option.iter (sub.expr sub) c_guard;
+  sub.expr sub c_rhs
+
+let value_binding sub {vb_pat; vb_expr; _} =
+  sub.pat sub vb_pat;
+  sub.expr sub vb_expr
+
+let env _sub _ = ()
+
+let default_iterator =
+  {
+    binding_op;
+    case;
+    class_declaration;
+    class_description;
+    class_expr;
+    class_field;
+    class_signature;
+    class_structure;
+    class_type;
+    class_type_declaration;
+    class_type_field;
+    env;
+    expr;
+    extension_constructor;
+    module_binding;
+    module_coercion;
+    module_declaration;
+    module_substitution;
+    module_expr;
+    module_type;
+    module_type_declaration;
+    package_type;
+    pat;
+    row_field;
+    object_field;
+    open_declaration;
+    open_description;
+    signature;
+    signature_item;
+    structure;
+    structure_item;
+    typ;
+    type_declaration;
+    type_declarations;
+    type_extension;
+    type_exception;
+    type_kind;
+    value_binding;
+    value_bindings;
+    value_description;
+    with_constraint;
+  }
diff --git a/src/ocaml/typing/tast_iterator.mli b/src/ocaml/typing/tast_iterator.mli
new file mode 100644
index 0000000..e126128
--- /dev/null
+++ b/src/ocaml/typing/tast_iterator.mli
@@ -0,0 +1,68 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                           Isaac "Izzy" Avram                           *)
+(*                                                                        *)
+(*   Copyright 2019 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(**
+Allows the implementation of typed tree inspection using open recursion
+*)
+
+open Asttypes
+open Typedtree
+
+type iterator =
+  {
+    binding_op: iterator -> binding_op -> unit;
+    case: 'k . iterator -> 'k case -> unit;
+    class_declaration: iterator -> class_declaration -> unit;
+    class_description: iterator -> class_description -> unit;
+    class_expr: iterator -> class_expr -> unit;
+    class_field: iterator -> class_field -> unit;
+    class_signature: iterator -> class_signature -> unit;
+    class_structure: iterator -> class_structure -> unit;
+    class_type: iterator -> class_type -> unit;
+    class_type_declaration: iterator -> class_type_declaration -> unit;
+    class_type_field: iterator -> class_type_field -> unit;
+    env: iterator -> Env.t -> unit;
+    expr: iterator -> expression -> unit;
+    extension_constructor: iterator -> extension_constructor -> unit;
+    module_binding: iterator -> module_binding -> unit;
+    module_coercion: iterator -> module_coercion -> unit;
+    module_declaration: iterator -> module_declaration -> unit;
+    module_substitution: iterator -> module_substitution -> unit;
+    module_expr: iterator -> module_expr -> unit;
+    module_type: iterator -> module_type -> unit;
+    module_type_declaration: iterator -> module_type_declaration -> unit;
+    package_type: iterator -> package_type -> unit;
+    pat: 'k . iterator -> 'k general_pattern -> unit;
+    row_field: iterator -> row_field -> unit;
+    object_field: iterator -> object_field -> unit;
+    open_declaration: iterator -> open_declaration -> unit;
+    open_description: iterator -> open_description -> unit;
+    signature: iterator -> signature -> unit;
+    signature_item: iterator -> signature_item -> unit;
+    structure: iterator -> structure -> unit;
+    structure_item: iterator -> structure_item -> unit;
+    typ: iterator -> core_type -> unit;
+    type_declaration: iterator -> type_declaration -> unit;
+    type_declarations: iterator -> (rec_flag * type_declaration list) -> unit;
+    type_extension: iterator -> type_extension -> unit;
+    type_exception: iterator -> type_exception -> unit;
+    type_kind: iterator -> type_kind -> unit;
+    value_binding: iterator -> value_binding -> unit;
+    value_bindings: iterator -> (rec_flag * value_binding list) -> unit;
+    value_description: iterator -> value_description -> unit;
+    with_constraint: iterator -> with_constraint -> unit;
+  }
+
+val default_iterator: iterator
diff --git a/src/ocaml/typing/tast_mapper.ml b/src/ocaml/typing/tast_mapper.ml
new file mode 100644
index 0000000..aa6651a
--- /dev/null
+++ b/src/ocaml/typing/tast_mapper.ml
@@ -0,0 +1,753 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                        Alain Frisch, LexiFi                            *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Typedtree
+
+(* TODO: add 'methods' for location, attribute, extension,
+   include_declaration, include_description *)
+
+type mapper =
+  {
+    binding_op: mapper -> binding_op -> binding_op;
+    case: 'k . mapper -> 'k case -> 'k case;
+    class_declaration: mapper -> class_declaration -> class_declaration;
+    class_description: mapper -> class_description -> class_description;
+    class_expr: mapper -> class_expr -> class_expr;
+    class_field: mapper -> class_field -> class_field;
+    class_signature: mapper -> class_signature -> class_signature;
+    class_structure: mapper -> class_structure -> class_structure;
+    class_type: mapper -> class_type -> class_type;
+    class_type_declaration: mapper -> class_type_declaration ->
+      class_type_declaration;
+    class_type_field: mapper -> class_type_field -> class_type_field;
+    env: mapper -> Env.t -> Env.t;
+    expr: mapper -> expression -> expression;
+    extension_constructor: mapper -> extension_constructor ->
+      extension_constructor;
+    module_binding: mapper -> module_binding -> module_binding;
+    module_coercion: mapper -> module_coercion -> module_coercion;
+    module_declaration: mapper -> module_declaration -> module_declaration;
+    module_substitution: mapper -> module_substitution -> module_substitution;
+    module_expr: mapper -> module_expr -> module_expr;
+    module_type: mapper -> module_type -> module_type;
+    module_type_declaration:
+      mapper -> module_type_declaration -> module_type_declaration;
+    package_type: mapper -> package_type -> package_type;
+    pat: 'k . mapper -> 'k general_pattern -> 'k general_pattern;
+    row_field: mapper -> row_field -> row_field;
+    object_field: mapper -> object_field -> object_field;
+    open_declaration: mapper -> open_declaration -> open_declaration;
+    open_description: mapper -> open_description -> open_description;
+    signature: mapper -> signature -> signature;
+    signature_item: mapper -> signature_item -> signature_item;
+    structure: mapper -> structure -> structure;
+    structure_item: mapper -> structure_item -> structure_item;
+    typ: mapper -> core_type -> core_type;
+    type_declaration: mapper -> type_declaration -> type_declaration;
+    type_declarations: mapper -> (rec_flag * type_declaration list)
+      -> (rec_flag * type_declaration list);
+    type_extension: mapper -> type_extension -> type_extension;
+    type_exception: mapper -> type_exception -> type_exception;
+    type_kind: mapper -> type_kind -> type_kind;
+    value_binding: mapper -> value_binding -> value_binding;
+    value_bindings: mapper -> (rec_flag * value_binding list) ->
+      (rec_flag * value_binding list);
+    value_description: mapper -> value_description -> value_description;
+    with_constraint: mapper -> with_constraint -> with_constraint;
+  }
+
+let id x = x
+let tuple2 f1 f2 (x, y) = (f1 x, f2 y)
+let tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
+
+let structure sub {str_items; str_type; str_final_env} =
+  {
+    str_items = List.map (sub.structure_item sub) str_items;
+    str_final_env = sub.env sub str_final_env;
+    str_type;
+  }
+
+let class_infos sub f x =
+  {x with
+   ci_params = List.map (tuple2 (sub.typ sub) id) x.ci_params;
+   ci_expr = f x.ci_expr;
+  }
+
+let module_type_declaration sub x =
+  let mtd_type = Option.map (sub.module_type sub) x.mtd_type in
+  {x with mtd_type}
+
+let module_declaration sub x =
+  let md_type = sub.module_type sub x.md_type in
+  {x with md_type}
+
+let module_substitution _ x = x
+
+let include_infos f x = {x with incl_mod = f x.incl_mod}
+
+let class_type_declaration sub x =
+  class_infos sub (sub.class_type sub) x
+
+let class_declaration sub x =
+  class_infos sub (sub.class_expr sub) x
+
+let structure_item sub {str_desc; str_loc; str_env} =
+  let str_env = sub.env sub str_env in
+  let str_desc =
+    match str_desc with
+    | Tstr_eval (exp, attrs) -> Tstr_eval (sub.expr sub exp, attrs)
+    | Tstr_value (rec_flag, list) ->
+        let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in
+        Tstr_value (rec_flag, list)
+    | Tstr_primitive v -> Tstr_primitive (sub.value_description sub v)
+    | Tstr_type (rec_flag, list) ->
+        let (rec_flag, list) = sub.type_declarations sub (rec_flag, list) in
+        Tstr_type (rec_flag, list)
+    | Tstr_typext te -> Tstr_typext (sub.type_extension sub te)
+    | Tstr_exception ext -> Tstr_exception (sub.type_exception sub ext)
+    | Tstr_module mb -> Tstr_module (sub.module_binding sub mb)
+    | Tstr_recmodule list ->
+        Tstr_recmodule (List.map (sub.module_binding sub) list)
+    | Tstr_modtype x -> Tstr_modtype (sub.module_type_declaration sub x)
+    | Tstr_class list ->
+        Tstr_class
+          (List.map (tuple2 (sub.class_declaration sub) id) list)
+    | Tstr_class_type list ->
+        Tstr_class_type
+          (List.map (tuple3 id id (sub.class_type_declaration sub)) list)
+    | Tstr_include incl ->
+        Tstr_include (include_infos (sub.module_expr sub) incl)
+    | Tstr_open od -> Tstr_open (sub.open_declaration sub od)
+    | Tstr_attribute _ as d -> d
+  in
+  {str_desc; str_env; str_loc}
+
+let value_description sub x =
+  let val_desc = sub.typ sub x.val_desc in
+  {x with val_desc}
+
+let label_decl sub x =
+  let ld_type = sub.typ sub x.ld_type in
+  {x with ld_type}
+
+let constructor_args sub = function
+  | Cstr_tuple l -> Cstr_tuple (List.map (sub.typ sub) l)
+  | Cstr_record l -> Cstr_record (List.map (label_decl sub) l)
+
+let constructor_decl sub cd =
+  let cd_args = constructor_args sub cd.cd_args in
+  let cd_res = Option.map (sub.typ sub) cd.cd_res in
+  {cd with cd_args; cd_res}
+
+let type_kind sub = function
+  | Ttype_abstract -> Ttype_abstract
+  | Ttype_variant list -> Ttype_variant (List.map (constructor_decl sub) list)
+  | Ttype_record list -> Ttype_record (List.map (label_decl sub) list)
+  | Ttype_open -> Ttype_open
+
+let type_declaration sub x =
+  let typ_cstrs =
+    List.map
+      (tuple3 (sub.typ sub) (sub.typ sub) id)
+      x.typ_cstrs
+  in
+  let typ_kind = sub.type_kind sub x.typ_kind in
+  let typ_manifest = Option.map (sub.typ sub) x.typ_manifest in
+  let typ_params = List.map (tuple2 (sub.typ sub) id) x.typ_params in
+  {x with typ_cstrs; typ_kind; typ_manifest; typ_params}
+
+let type_declarations sub (rec_flag, list) =
+  (rec_flag, List.map (sub.type_declaration sub) list)
+
+let type_extension sub x =
+  let tyext_params = List.map (tuple2 (sub.typ sub) id) x.tyext_params in
+  let tyext_constructors =
+    List.map (sub.extension_constructor sub) x.tyext_constructors
+  in
+  {x with tyext_constructors; tyext_params}
+
+let type_exception sub x =
+  let tyexn_constructor =
+    sub.extension_constructor sub x.tyexn_constructor
+  in
+  {x with tyexn_constructor}
+
+let extension_constructor sub x =
+  let ext_kind =
+    match x.ext_kind with
+      Text_decl(ctl, cto) ->
+        Text_decl(constructor_args sub ctl, Option.map (sub.typ sub) cto)
+    | Text_rebind _ as d -> d
+  in
+  {x with ext_kind}
+
+let pat_extra sub = function
+  | Tpat_type _
+  | Tpat_unpack as d -> d
+  | Tpat_open (path,loc,env) ->  Tpat_open (path, loc, sub.env sub env)
+  | Tpat_constraint ct -> Tpat_constraint (sub.typ sub ct)
+
+let pat
+  : type k . mapper -> k general_pattern -> k general_pattern
+  = fun sub x ->
+  let pat_env = sub.env sub x.pat_env in
+  let pat_extra = List.map (tuple3 (pat_extra sub) id id) x.pat_extra in
+  let pat_desc : k pattern_desc =
+    match x.pat_desc with
+    | Tpat_any
+    | Tpat_var _
+    | Tpat_constant _ -> x.pat_desc
+    | Tpat_tuple l -> Tpat_tuple (List.map (sub.pat sub) l)
+    | Tpat_construct (loc, cd, l, vto) ->
+        let vto = Option.map (fun (vl,cty) -> vl, sub.typ sub cty) vto in
+        Tpat_construct (loc, cd, List.map (sub.pat sub) l, vto)
+    | Tpat_variant (l, po, rd) ->
+        Tpat_variant (l, Option.map (sub.pat sub) po, rd)
+    | Tpat_record (l, closed) ->
+        Tpat_record (List.map (tuple3 id id (sub.pat sub)) l, closed)
+    | Tpat_array l -> Tpat_array (List.map (sub.pat sub) l)
+    | Tpat_alias (p, id, s) -> Tpat_alias (sub.pat sub p, id, s)
+    | Tpat_lazy p -> Tpat_lazy (sub.pat sub p)
+    | Tpat_value p ->
+       (as_computation_pattern (sub.pat sub (p :> pattern))).pat_desc
+    | Tpat_exception p ->
+       Tpat_exception (sub.pat sub p)
+    | Tpat_or (p1, p2, rd) ->
+        Tpat_or (sub.pat sub p1, sub.pat sub p2, rd)
+  in
+  {x with pat_extra; pat_desc; pat_env}
+
+let expr sub x =
+  let extra = function
+    | Texp_constraint cty ->
+        Texp_constraint (sub.typ sub cty)
+    | Texp_coerce (cty1, cty2) ->
+        Texp_coerce (Option.map (sub.typ sub) cty1, sub.typ sub cty2)
+    | Texp_newtype _ as d -> d
+    | Texp_newtype' _ as d -> d
+    | Texp_poly cto -> Texp_poly (Option.map (sub.typ sub) cto)
+  in
+  let exp_extra = List.map (tuple3 extra id id) x.exp_extra in
+  let exp_env = sub.env sub x.exp_env in
+  let exp_desc =
+    match x.exp_desc with
+    | Texp_ident _
+    | Texp_constant _ as d -> d
+    | Texp_let (rec_flag, list, exp) ->
+        let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in
+        Texp_let (rec_flag, list, sub.expr sub exp)
+    | Texp_function { arg_label; param; cases; partial; } ->
+        let cases = List.map (sub.case sub) cases in
+        Texp_function { arg_label; param; cases; partial; }
+    | Texp_apply (exp, list) ->
+        Texp_apply (
+          sub.expr sub exp,
+          List.map (tuple2 id (Option.map (sub.expr sub))) list
+        )
+    | Texp_match (exp, cases, p) ->
+        Texp_match (
+          sub.expr sub exp,
+          List.map (sub.case sub) cases,
+          p
+        )
+    | Texp_try (exp, cases) ->
+        Texp_try (
+          sub.expr sub exp,
+          List.map (sub.case sub) cases
+        )
+    | Texp_tuple list ->
+        Texp_tuple (List.map (sub.expr sub) list)
+    | Texp_construct (lid, cd, args) ->
+        Texp_construct (lid, cd, List.map (sub.expr sub) args)
+    | Texp_variant (l, expo) ->
+        Texp_variant (l, Option.map (sub.expr sub) expo)
+    | Texp_record { fields; representation; extended_expression } ->
+        let fields = Array.map (function
+            | label, Kept t -> label, Kept t
+            | label, Overridden (lid, exp) ->
+                label, Overridden (lid, sub.expr sub exp))
+            fields
+        in
+        Texp_record {
+          fields; representation;
+          extended_expression = Option.map (sub.expr sub) extended_expression;
+        }
+    | Texp_field (exp, lid, ld) ->
+        Texp_field (sub.expr sub exp, lid, ld)
+    | Texp_setfield (exp1, lid, ld, exp2) ->
+        Texp_setfield (
+          sub.expr sub exp1,
+          lid,
+          ld,
+          sub.expr sub exp2
+        )
+    | Texp_array list ->
+        Texp_array (List.map (sub.expr sub) list)
+    | Texp_ifthenelse (exp1, exp2, expo) ->
+        Texp_ifthenelse (
+          sub.expr sub exp1,
+          sub.expr sub exp2,
+          Option.map (sub.expr sub) expo
+        )
+    | Texp_sequence (exp1, exp2) ->
+        Texp_sequence (
+          sub.expr sub exp1,
+          sub.expr sub exp2
+        )
+    | Texp_while (exp1, exp2) ->
+        Texp_while (
+          sub.expr sub exp1,
+          sub.expr sub exp2
+        )
+    | Texp_for (id, p, exp1, exp2, dir, exp3) ->
+        Texp_for (
+          id,
+          p,
+          sub.expr sub exp1,
+          sub.expr sub exp2,
+          dir,
+          sub.expr sub exp3
+        )
+    | Texp_send (exp, meth, expo) ->
+        Texp_send
+          (
+            sub.expr sub exp,
+            meth,
+            Option.map (sub.expr sub) expo
+          )
+    | Texp_new _
+    | Texp_instvar _ as d -> d
+    | Texp_setinstvar (path1, path2, id, exp) ->
+        Texp_setinstvar (
+          path1,
+          path2,
+          id,
+          sub.expr sub exp
+        )
+    | Texp_override (path, list) ->
+        Texp_override (
+          path,
+          List.map (tuple3 id id (sub.expr sub)) list
+        )
+    | Texp_letmodule (id, s, pres, mexpr, exp) ->
+        Texp_letmodule (
+          id,
+          s,
+          pres,
+          sub.module_expr sub mexpr,
+          sub.expr sub exp
+        )
+    | Texp_letexception (cd, exp) ->
+        Texp_letexception (
+          sub.extension_constructor sub cd,
+          sub.expr sub exp
+        )
+    | Texp_assert exp ->
+        Texp_assert (sub.expr sub exp)
+    | Texp_lazy exp ->
+        Texp_lazy (sub.expr sub exp)
+    | Texp_object (cl, sl) ->
+        Texp_object (sub.class_structure sub cl, sl)
+    | Texp_pack mexpr ->
+        Texp_pack (sub.module_expr sub mexpr)
+    | Texp_letop {let_; ands; param; body; partial} ->
+        Texp_letop{
+          let_ = sub.binding_op sub let_;
+          ands = List.map (sub.binding_op sub) ands;
+          param;
+          body = sub.case sub body;
+          partial;
+        }
+    | Texp_unreachable ->
+        Texp_unreachable
+    | Texp_extension_constructor _ as e ->
+        e
+    | Texp_open (od, e) ->
+        Texp_open (sub.open_declaration sub od, sub.expr sub e)
+    | Texp_hole ->
+        Texp_hole
+  in
+  {x with exp_extra; exp_desc; exp_env}
+
+
+let package_type sub x =
+  let pack_fields = List.map (tuple2 id (sub.typ sub)) x.pack_fields in
+  {x with pack_fields}
+
+let binding_op sub x =
+  { x with bop_exp = sub.expr sub x.bop_exp }
+
+let signature sub x =
+  let sig_final_env = sub.env sub x.sig_final_env in
+  let sig_items = List.map (sub.signature_item sub) x.sig_items in
+  {x with sig_items; sig_final_env}
+
+let signature_item sub x =
+  let sig_env = sub.env sub x.sig_env in
+  let sig_desc =
+    match x.sig_desc with
+    | Tsig_value v ->
+        Tsig_value (sub.value_description sub v)
+    | Tsig_type (rec_flag, list) ->
+        let (rec_flag, list) = sub.type_declarations sub (rec_flag, list) in
+        Tsig_type (rec_flag, list)
+    | Tsig_typesubst list ->
+        let (_, list) = sub.type_declarations sub (Nonrecursive, list) in
+        Tsig_typesubst list
+    | Tsig_typext te ->
+        Tsig_typext (sub.type_extension sub te)
+    | Tsig_exception ext ->
+        Tsig_exception (sub.type_exception sub ext)
+    | Tsig_module x ->
+        Tsig_module (sub.module_declaration sub x)
+    | Tsig_modsubst x ->
+        Tsig_modsubst (sub.module_substitution sub x)
+    | Tsig_recmodule list ->
+        Tsig_recmodule (List.map (sub.module_declaration sub) list)
+    | Tsig_modtype x ->
+        Tsig_modtype (sub.module_type_declaration sub x)
+   | Tsig_modtypesubst x ->
+        Tsig_modtypesubst (sub.module_type_declaration sub x)
+   | Tsig_include incl ->
+        Tsig_include (include_infos (sub.module_type sub) incl)
+    | Tsig_class list ->
+        Tsig_class (List.map (sub.class_description sub) list)
+    | Tsig_class_type list ->
+        Tsig_class_type
+          (List.map (sub.class_type_declaration sub) list)
+    | Tsig_open od -> Tsig_open (sub.open_description sub od)
+    | Tsig_attribute _ as d -> d
+  in
+  {x with sig_desc; sig_env}
+
+let class_description sub x =
+  class_infos sub (sub.class_type sub) x
+
+let functor_parameter sub = function
+  | Unit -> Unit
+  | Named (id, s, mtype) -> Named (id, s, sub.module_type sub mtype)
+
+let module_type sub x =
+  let mty_env = sub.env sub x.mty_env in
+  let mty_desc =
+    match x.mty_desc with
+    | Tmty_ident _
+    | Tmty_alias _ as d -> d
+    | Tmty_signature sg -> Tmty_signature (sub.signature sub sg)
+    | Tmty_functor (arg, mtype2) ->
+        Tmty_functor (functor_parameter sub arg, sub.module_type sub mtype2)
+    | Tmty_with (mtype, list) ->
+        Tmty_with (
+          sub.module_type sub mtype,
+          List.map (tuple3 id id (sub.with_constraint sub)) list
+        )
+    | Tmty_typeof mexpr ->
+        Tmty_typeof (sub.module_expr sub mexpr)
+  in
+  {x with mty_desc; mty_env}
+
+let with_constraint sub = function
+  | Twith_type decl -> Twith_type (sub.type_declaration sub decl)
+  | Twith_typesubst decl -> Twith_typesubst (sub.type_declaration sub decl)
+  | Twith_module _
+  | Twith_modsubst _
+  | Twith_modtype _
+  | Twith_modtypesubst _ as d -> d
+
+let open_description sub od =
+  {od with open_env = sub.env sub od.open_env}
+
+let open_declaration sub od =
+  {od with open_expr = sub.module_expr sub od.open_expr;
+           open_env = sub.env sub od.open_env}
+
+let module_coercion sub = function
+  | Tcoerce_none -> Tcoerce_none
+  | Tcoerce_functor (c1,c2) ->
+      Tcoerce_functor (sub.module_coercion sub c1, sub.module_coercion sub c2)
+  | Tcoerce_alias (env, p, c1) ->
+      Tcoerce_alias (sub.env sub env, p, sub.module_coercion sub c1)
+  | Tcoerce_structure (l1, l2) ->
+      let l1' = List.map (fun (i,c) -> i, sub.module_coercion sub c) l1 in
+      let l2' =
+        List.map (fun (id,i,c) -> id, i, sub.module_coercion sub c) l2
+      in
+      Tcoerce_structure (l1', l2')
+  | Tcoerce_primitive pc ->
+      Tcoerce_primitive {pc with pc_env = sub.env sub pc.pc_env}
+
+let module_expr sub x =
+  let mod_env = sub.env sub x.mod_env in
+  let mod_desc =
+    match x.mod_desc with
+    | Tmod_ident _ as d -> d
+    | Tmod_hole -> Tmod_hole
+    | Tmod_structure st -> Tmod_structure (sub.structure sub st)
+    | Tmod_functor (arg, mexpr) ->
+        Tmod_functor (functor_parameter sub arg, sub.module_expr sub mexpr)
+    | Tmod_apply (mexp1, mexp2, c) ->
+        Tmod_apply (
+          sub.module_expr sub mexp1,
+          sub.module_expr sub mexp2,
+          sub.module_coercion sub c
+        )
+    | Tmod_constraint (mexpr, mt, Tmodtype_implicit, c) ->
+        Tmod_constraint (sub.module_expr sub mexpr, mt, Tmodtype_implicit,
+                         sub.module_coercion sub c)
+    | Tmod_constraint (mexpr, mt, Tmodtype_explicit mtype, c) ->
+        Tmod_constraint (
+          sub.module_expr sub mexpr,
+          mt,
+          Tmodtype_explicit (sub.module_type sub mtype),
+          sub.module_coercion sub c
+        )
+    | Tmod_unpack (exp, mty) ->
+        Tmod_unpack
+          (
+            sub.expr sub exp,
+            mty
+          )
+  in
+  {x with mod_desc; mod_env}
+
+let module_binding sub x =
+  let mb_expr = sub.module_expr sub x.mb_expr in
+  {x with mb_expr}
+
+let class_expr sub x =
+  let cl_env = sub.env sub x.cl_env in
+  let cl_desc =
+    match x.cl_desc with
+    | Tcl_constraint (cl, clty, vals, meths, concrs) ->
+        Tcl_constraint (
+          sub.class_expr sub cl,
+          Option.map (sub.class_type sub) clty,
+          vals,
+          meths,
+          concrs
+        )
+    | Tcl_structure clstr ->
+        Tcl_structure (sub.class_structure sub clstr)
+    | Tcl_fun (label, pat, priv, cl, partial) ->
+        Tcl_fun (
+          label,
+          sub.pat sub pat,
+          List.map (tuple2 id (sub.expr sub)) priv,
+          sub.class_expr sub cl,
+          partial
+        )
+    | Tcl_apply (cl, args) ->
+        Tcl_apply (
+          sub.class_expr sub cl,
+          List.map (tuple2 id (Option.map (sub.expr sub))) args
+        )
+    | Tcl_let (rec_flag, value_bindings, ivars, cl) ->
+        let (rec_flag, value_bindings) =
+          sub.value_bindings sub (rec_flag, value_bindings)
+        in
+        Tcl_let (
+          rec_flag,
+          value_bindings,
+          List.map (tuple2 id (sub.expr sub)) ivars,
+          sub.class_expr sub cl
+        )
+    | Tcl_ident (path, lid, tyl) ->
+        Tcl_ident (path, lid, List.map (sub.typ sub) tyl)
+    | Tcl_open (od, e) ->
+        Tcl_open (sub.open_description sub od, sub.class_expr sub e)
+  in
+  {x with cl_desc; cl_env}
+
+let class_type sub x =
+  let cltyp_env = sub.env sub x.cltyp_env in
+  let cltyp_desc =
+    match x.cltyp_desc with
+    | Tcty_signature csg -> Tcty_signature (sub.class_signature sub csg)
+    | Tcty_constr (path, lid, list) ->
+        Tcty_constr (
+          path,
+          lid,
+          List.map (sub.typ sub) list
+        )
+    | Tcty_arrow (label, ct, cl) ->
+        Tcty_arrow
+          (label,
+           sub.typ sub ct,
+           sub.class_type sub cl
+          )
+    | Tcty_open (od, e) ->
+        Tcty_open (sub.open_description sub od, sub.class_type sub e)
+  in
+  {x with cltyp_desc; cltyp_env}
+
+let class_signature sub x =
+  let csig_self = sub.typ sub x.csig_self in
+  let csig_fields = List.map (sub.class_type_field sub) x.csig_fields in
+  {x with csig_self; csig_fields}
+
+let class_type_field sub x =
+  let ctf_desc =
+    match x.ctf_desc with
+    | Tctf_inherit ct ->
+        Tctf_inherit (sub.class_type sub ct)
+    | Tctf_val (s, mut, virt, ct) ->
+        Tctf_val (s, mut, virt, sub.typ sub ct)
+    | Tctf_method (s, priv, virt, ct) ->
+        Tctf_method (s, priv, virt, sub.typ sub ct)
+    | Tctf_constraint  (ct1, ct2) ->
+        Tctf_constraint (sub.typ sub ct1, sub.typ sub ct2)
+    | Tctf_attribute _ as d -> d
+  in
+  {x with ctf_desc}
+
+let typ sub x =
+  let ctyp_env = sub.env sub x.ctyp_env in
+  let ctyp_desc =
+    match x.ctyp_desc with
+    | Ttyp_any
+    | Ttyp_var _ as d -> d
+    | Ttyp_arrow (label, ct1, ct2) ->
+        Ttyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2)
+    | Ttyp_tuple list -> Ttyp_tuple (List.map (sub.typ sub) list)
+    | Ttyp_constr (path, lid, list) ->
+        Ttyp_constr (path, lid, List.map (sub.typ sub) list)
+    | Ttyp_object (list, closed) ->
+        Ttyp_object ((List.map (sub.object_field sub) list), closed)
+    | Ttyp_class (path, lid, list) ->
+        Ttyp_class
+          (path,
+           lid,
+           List.map (sub.typ sub) list
+          )
+    | Ttyp_alias (ct, s) ->
+        Ttyp_alias (sub.typ sub ct, s)
+    | Ttyp_variant (list, closed, labels) ->
+        Ttyp_variant (List.map (sub.row_field sub) list, closed, labels)
+    | Ttyp_poly (sl, ct) ->
+        Ttyp_poly (sl, sub.typ sub ct)
+    | Ttyp_package pack ->
+        Ttyp_package (sub.package_type sub pack)
+  in
+  {x with ctyp_desc; ctyp_env}
+
+let class_structure sub x =
+  let cstr_self = sub.pat sub x.cstr_self in
+  let cstr_fields = List.map (sub.class_field sub) x.cstr_fields in
+  {x with cstr_self; cstr_fields}
+
+let row_field sub x =
+  let rf_desc = match x.rf_desc with
+    | Ttag (label, b, list) ->
+        Ttag (label, b, List.map (sub.typ sub) list)
+    | Tinherit ct -> Tinherit (sub.typ sub ct)
+  in
+  { x with rf_desc; }
+
+let object_field sub x =
+  let of_desc = match x.of_desc with
+    | OTtag (label, ct) ->
+        OTtag (label, (sub.typ sub ct))
+    | OTinherit ct -> OTinherit (sub.typ sub ct)
+  in
+  { x with of_desc; }
+
+let class_field_kind sub = function
+  | Tcfk_virtual ct -> Tcfk_virtual (sub.typ sub ct)
+  | Tcfk_concrete (ovf, e) -> Tcfk_concrete (ovf, sub.expr sub e)
+
+let class_field sub x =
+  let cf_desc =
+    match x.cf_desc with
+    | Tcf_inherit (ovf, cl, super, vals, meths) ->
+        Tcf_inherit (ovf, sub.class_expr sub cl, super, vals, meths)
+    | Tcf_constraint (cty, cty') ->
+        Tcf_constraint (
+          sub.typ sub cty,
+          sub.typ sub cty'
+        )
+    | Tcf_val (s, mf, id, k, b) ->
+        Tcf_val (s, mf, id, class_field_kind sub k, b)
+    | Tcf_method (s, priv, k) ->
+        Tcf_method (s, priv, class_field_kind sub k)
+    | Tcf_initializer exp ->
+        Tcf_initializer (sub.expr sub exp)
+    | Tcf_attribute _ as d -> d
+  in
+  {x with cf_desc}
+
+let value_bindings sub (rec_flag, list) =
+  (rec_flag, List.map (sub.value_binding sub) list)
+
+let case
+  : type k . mapper -> k case -> k case
+  = fun sub {c_lhs; c_guard; c_rhs} ->
+  {
+    c_lhs = sub.pat sub c_lhs;
+    c_guard = Option.map (sub.expr sub) c_guard;
+    c_rhs = sub.expr sub c_rhs;
+  }
+
+let value_binding sub x =
+  let vb_pat = sub.pat sub x.vb_pat in
+  let vb_expr = sub.expr sub x.vb_expr in
+  {x with vb_pat; vb_expr}
+
+let env _sub x = x
+
+let default =
+  {
+    binding_op;
+    case;
+    class_declaration;
+    class_description;
+    class_expr;
+    class_field;
+    class_signature;
+    class_structure;
+    class_type;
+    class_type_declaration;
+    class_type_field;
+    env;
+    expr;
+    extension_constructor;
+    module_binding;
+    module_coercion;
+    module_declaration;
+    module_substitution;
+    module_expr;
+    module_type;
+    module_type_declaration;
+    package_type;
+    pat;
+    row_field;
+    object_field;
+    open_declaration;
+    open_description;
+    signature;
+    signature_item;
+    structure;
+    structure_item;
+    typ;
+    type_declaration;
+    type_declarations;
+    type_extension;
+    type_exception;
+    type_kind;
+    value_binding;
+    value_bindings;
+    value_description;
+    with_constraint;
+  }
diff --git a/src/ocaml/typing/tast_mapper.mli b/src/ocaml/typing/tast_mapper.mli
new file mode 100644
index 0000000..ea6543d
--- /dev/null
+++ b/src/ocaml/typing/tast_mapper.mli
@@ -0,0 +1,72 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                        Alain Frisch, LexiFi                            *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Typedtree
+
+(** {1 A generic Typedtree mapper} *)
+
+type mapper =
+  {
+    binding_op: mapper -> binding_op -> binding_op;
+    case: 'k . mapper -> 'k case -> 'k case;
+    class_declaration: mapper -> class_declaration -> class_declaration;
+    class_description: mapper -> class_description -> class_description;
+    class_expr: mapper -> class_expr -> class_expr;
+    class_field: mapper -> class_field -> class_field;
+    class_signature: mapper -> class_signature -> class_signature;
+    class_structure: mapper -> class_structure -> class_structure;
+    class_type: mapper -> class_type -> class_type;
+    class_type_declaration: mapper -> class_type_declaration ->
+      class_type_declaration;
+    class_type_field: mapper -> class_type_field -> class_type_field;
+    env: mapper -> Env.t -> Env.t;
+    expr: mapper -> expression -> expression;
+    extension_constructor: mapper -> extension_constructor ->
+      extension_constructor;
+    module_binding: mapper -> module_binding -> module_binding;
+    module_coercion: mapper -> module_coercion -> module_coercion;
+    module_declaration: mapper -> module_declaration -> module_declaration;
+    module_substitution: mapper -> module_substitution -> module_substitution;
+    module_expr: mapper -> module_expr -> module_expr;
+    module_type: mapper -> module_type -> module_type;
+    module_type_declaration:
+      mapper -> module_type_declaration -> module_type_declaration;
+    package_type: mapper -> package_type -> package_type;
+    pat: 'k . mapper -> 'k general_pattern -> 'k general_pattern;
+    row_field: mapper -> row_field -> row_field;
+    object_field: mapper -> object_field -> object_field;
+    open_declaration: mapper -> open_declaration -> open_declaration;
+    open_description: mapper -> open_description -> open_description;
+    signature: mapper -> signature -> signature;
+    signature_item: mapper -> signature_item -> signature_item;
+    structure: mapper -> structure -> structure;
+    structure_item: mapper -> structure_item -> structure_item;
+    typ: mapper -> core_type -> core_type;
+    type_declaration: mapper -> type_declaration -> type_declaration;
+    type_declarations: mapper -> (rec_flag * type_declaration list)
+      -> (rec_flag * type_declaration list);
+    type_extension: mapper -> type_extension -> type_extension;
+    type_exception: mapper -> type_exception -> type_exception;
+    type_kind: mapper -> type_kind -> type_kind;
+    value_binding: mapper -> value_binding -> value_binding;
+    value_bindings: mapper -> (rec_flag * value_binding list) ->
+      (rec_flag * value_binding list);
+    value_description: mapper -> value_description -> value_description;
+    with_constraint: mapper -> with_constraint -> with_constraint;
+  }
+
+
+val default: mapper
diff --git a/src/ocaml/typing/type_immediacy.ml b/src/ocaml/typing/type_immediacy.ml
new file mode 100644
index 0000000..557ed42
--- /dev/null
+++ b/src/ocaml/typing/type_immediacy.ml
@@ -0,0 +1,43 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2019 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t =
+  | Unknown
+  | Always
+  | Always_on_64bits
+
+module Violation = struct
+  type t =
+    | Not_always_immediate
+    | Not_always_immediate_on_64bits
+end
+
+let coerce t ~as_ =
+  match t, as_ with
+  | _, Unknown
+  | Always, Always
+  | (Always | Always_on_64bits), Always_on_64bits -> Ok ()
+  | (Unknown | Always_on_64bits), Always ->
+      Error Violation.Not_always_immediate
+  | Unknown, Always_on_64bits ->
+      Error Violation.Not_always_immediate_on_64bits
+
+let of_attributes attrs =
+  match
+    Builtin_attributes.immediate attrs,
+    Builtin_attributes.immediate64 attrs
+  with
+  | true, _ -> Always
+  | false, true -> Always_on_64bits
+  | false, false -> Unknown
diff --git a/src/ocaml/typing/type_immediacy.mli b/src/ocaml/typing/type_immediacy.mli
new file mode 100644
index 0000000..3fc2e3b
--- /dev/null
+++ b/src/ocaml/typing/type_immediacy.mli
@@ -0,0 +1,40 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2019 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Immediacy status of a type *)
+
+type t =
+  | Unknown
+  (** We don't know anything *)
+  | Always
+  (** We know for sure that values of this type are always immediate *)
+  | Always_on_64bits
+  (** We know for sure that values of this type are always immediate
+      on 64 bit platforms. For other platforms, we know nothing. *)
+
+module Violation : sig
+  type t =
+    | Not_always_immediate
+    | Not_always_immediate_on_64bits
+end
+
+(** [coerce t ~as_] returns [Ok ()] iff [t] can be seen as type
+    immediacy [as_]. For instance, [Always] can be seen as
+    [Always_on_64bits] but the opposite is not true. Return [Error _]
+    if the coercion is not possible. *)
+val coerce : t -> as_:t -> (unit, Violation.t) result
+
+(** Return the immediateness of a type as indicated by the user via
+    attributes *)
+val of_attributes : Parsetree.attributes -> t
diff --git a/src/ocaml/typing/typeclass.ml b/src/ocaml/typing/typeclass.ml
new file mode 100644
index 0000000..00d54bd
--- /dev/null
+++ b/src/ocaml/typing/typeclass.ml
@@ -0,0 +1,2063 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Parsetree
+open Asttypes
+open Path
+open Types
+open Typecore
+open Typetexp
+open Format
+
+type 'a class_info = {
+  cls_id : Ident.t;
+  cls_id_loc : string loc;
+  cls_decl : class_declaration;
+  cls_ty_id : Ident.t;
+  cls_ty_decl : class_type_declaration;
+  cls_obj_id : Ident.t;
+  cls_obj_abbr : type_declaration;
+  cls_typesharp_id : Ident.t;
+  cls_abbr : type_declaration;
+  cls_arity : int;
+  cls_pub_methods : string list;
+  cls_info : 'a;
+}
+
+type class_type_info = {
+  clsty_ty_id : Ident.t;
+  clsty_id_loc : string loc;
+  clsty_ty_decl : class_type_declaration;
+  clsty_obj_id : Ident.t;
+  clsty_obj_abbr : type_declaration;
+  clsty_typesharp_id : Ident.t;
+  clsty_abbr : type_declaration;
+  clsty_info : Typedtree.class_type_declaration;
+}
+
+type 'a full_class = {
+  id : Ident.t;
+  id_loc : tag loc;
+  clty: class_declaration;
+  ty_id: Ident.t;
+  cltydef: class_type_declaration;
+  obj_id: Ident.t;
+  obj_abbr: type_declaration;
+  cl_id: Ident.t;
+  cl_abbr: type_declaration;
+  arity: int;
+  pub_meths: string list;
+  coe: Warnings.loc list;
+  req: 'a Typedtree.class_infos;
+}
+
+type class_env = { val_env : Env.t; met_env : Env.t; par_env : Env.t }
+
+type error =
+  | Unconsistent_constraint of Errortrace.unification Errortrace.t
+  | Field_type_mismatch of string * string * Errortrace.unification Errortrace.t
+  | Structure_expected of class_type
+  | Cannot_apply of class_type
+  | Apply_wrong_label of arg_label
+  | Pattern_type_clash of type_expr
+  | Repeated_parameter
+  | Unbound_class_2 of Longident.t
+  | Unbound_class_type_2 of Longident.t
+  | Abbrev_type_clash of type_expr * type_expr * type_expr
+  | Constructor_type_mismatch of string * Errortrace.unification Errortrace.t
+  | Virtual_class of bool * bool * string list * string list
+  | Parameter_arity_mismatch of Longident.t * int * int
+  | Parameter_mismatch of Errortrace.unification Errortrace.t
+  | Bad_parameters of Ident.t * type_expr * type_expr
+  | Class_match_failure of Ctype.class_match_failure list
+  | Unbound_val of string
+  | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure
+  | Non_generalizable_class of Ident.t * Types.class_declaration
+  | Cannot_coerce_self of type_expr
+  | Non_collapsable_conjunction of
+      Ident.t * Types.class_declaration * Errortrace.unification Errortrace.t
+  | Final_self_clash of Errortrace.unification Errortrace.t
+  | Mutability_mismatch of string * mutable_flag
+  | No_overriding of string * string
+  | Duplicate of string * string
+  | Closing_self_type of type_expr
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+open Typedtree
+
+let type_open_descr :
+  (?used_slot:bool ref -> Env.t -> Parsetree.open_description
+   -> open_description * Env.t) ref =
+  ref (fun ?used_slot:_ _ -> assert false)
+
+let ctyp desc typ env loc =
+  { ctyp_desc = desc; ctyp_type = typ; ctyp_loc = loc; ctyp_env = env;
+    ctyp_attributes = [] }
+
+                       (**********************)
+                       (*  Useful constants  *)
+                       (**********************)
+
+
+(*
+   Self type have a dummy private method, thus preventing it to become
+   closed.
+*)
+let dummy_method = Btype.dummy_method
+
+(*
+   Path associated to the temporary class type of a class being typed
+   (its constructor is not available).
+*)
+let unbound_class =
+  Env.unbound_class
+
+
+                (************************************)
+                (*  Some operations on class types  *)
+                (************************************)
+
+
+(* Fully expand the head of a class type *)
+let rec scrape_class_type =
+  function
+    Cty_constr (_, _, cty) -> scrape_class_type cty
+  | cty                     -> cty
+
+(* Generalize a class type *)
+let rec generalize_class_type gen =
+  function
+    Cty_constr (_, params, cty) ->
+      List.iter gen params;
+      generalize_class_type gen cty
+  | Cty_signature {csig_self = sty; csig_vars = vars; csig_inher = inher} ->
+      gen sty;
+      Vars.iter (fun _ (_, _, ty) -> gen ty) vars;
+      List.iter (fun (_,tl) -> List.iter gen tl) inher
+  | Cty_arrow (_, ty, cty) ->
+      gen ty;
+      generalize_class_type gen cty
+
+let generalize_class_type vars =
+  let gen = if vars then Ctype.generalize else Ctype.generalize_structure in
+  generalize_class_type gen
+
+(* Return the virtual methods of a class type *)
+let virtual_methods sign =
+  let (fields, _) =
+    Ctype.flatten_fields (Ctype.object_fields sign.Types.csig_self)
+  in
+  List.fold_left
+    (fun virt (lab, _, _) ->
+       if lab = dummy_method then virt else
+       if Concr.mem lab sign.csig_concr then virt else
+       lab::virt)
+    [] fields
+
+(* Return the constructor type associated to a class type *)
+let rec constructor_type constr cty =
+  match cty with
+    Cty_constr (_, _, cty) ->
+      constructor_type constr cty
+  | Cty_signature _ ->
+      constr
+  | Cty_arrow (l, ty, cty) ->
+      Ctype.newty (Tarrow (l, ty, constructor_type constr cty, Cok))
+
+let rec class_body cty =
+  match cty with
+    Cty_constr _ ->
+      cty (* Only class bodies can be abbreviated *)
+  | Cty_signature _ ->
+      cty
+  | Cty_arrow (_, _, cty) ->
+      class_body cty
+
+let extract_constraints cty =
+  let sign = Ctype.signature_of_class_type cty in
+  (Vars.fold (fun lab _ vars -> lab :: vars) sign.csig_vars [],
+   begin let (fields, _) =
+     Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
+   in
+   List.fold_left
+     (fun meths (lab, _, _) ->
+        if lab = dummy_method then meths else lab::meths)
+     [] fields
+   end,
+   sign.csig_concr)
+
+let rec abbreviate_class_type path params cty =
+  match cty with
+    Cty_constr (_, _, _) | Cty_signature _ ->
+      Cty_constr (path, params, cty)
+  | Cty_arrow (l, ty, cty) ->
+      Cty_arrow (l, ty, abbreviate_class_type path params cty)
+
+(* Check that all type variables are generalizable *)
+(* Use Env.empty to prevent expansion of recursively defined object types;
+   cf. typing-poly/poly.ml *)
+let rec closed_class_type =
+  function
+    Cty_constr (_, params, _) ->
+      List.for_all (Ctype.closed_schema Env.empty) params
+  | Cty_signature sign ->
+      Ctype.closed_schema Env.empty sign.csig_self
+        &&
+      Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema Env.empty ty && cc)
+        sign.csig_vars
+        true
+  | Cty_arrow (_, ty, cty) ->
+      Ctype.closed_schema Env.empty ty
+        &&
+      closed_class_type cty
+
+let closed_class cty =
+  List.for_all (Ctype.closed_schema Env.empty) cty.cty_params
+    &&
+  closed_class_type cty.cty_type
+
+let rec limited_generalize rv =
+  function
+    Cty_constr (_path, params, cty) ->
+      List.iter (Ctype.limited_generalize rv) params;
+      limited_generalize rv cty
+  | Cty_signature sign ->
+      Ctype.limited_generalize rv sign.csig_self;
+      Vars.iter (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty)
+        sign.csig_vars;
+      List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl)
+        sign.csig_inher
+  | Cty_arrow (_, ty, cty) ->
+      Ctype.limited_generalize rv ty;
+      limited_generalize rv cty
+
+(* Record a class type *)
+let rc node =
+  Cmt_format.add_saved_type (Cmt_format.Partial_class_expr node);
+  node
+
+
+                (***********************************)
+                (*  Primitives for typing classes  *)
+                (***********************************)
+
+
+(* Enter a value in the method environment only *)
+let enter_met_env ?check loc lab kind unbound_kind ty class_env =
+  let {val_env; met_env; par_env} = class_env in
+  let val_env = Env.enter_unbound_value lab unbound_kind val_env in
+  let par_env = Env.enter_unbound_value lab unbound_kind par_env in
+  let (id, met_env) =
+    Env.enter_value ?check lab
+      {val_type = ty; val_kind = kind;
+       val_attributes = []; Types.val_loc = loc;
+       val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); } met_env
+  in
+  let class_env = {val_env; met_env; par_env} in
+  (id,class_env )
+
+(* Enter an instance variable in the environment *)
+let enter_val cl_num vars inh lab mut virt ty class_env loc =
+  let val_env = class_env.val_env in
+  let (id, virt) =
+    try
+      let (id, mut', virt', ty') = Vars.find lab !vars in
+      if mut' <> mut then
+        raise (Error(loc, val_env, Mutability_mismatch(lab, mut)));
+      Ctype.unify val_env (Ctype.instance ty) (Ctype.instance ty');
+      (if not inh then Some id else None),
+      (if virt' = Concrete then virt' else virt)
+    with
+      Ctype.Unify tr ->
+        raise (Error(loc, val_env,
+                     Field_type_mismatch("instance variable", lab, tr)))
+    | Not_found -> None, virt
+  in
+  let (id, _) as result =
+    match id with Some id -> (id, class_env)
+    | None ->
+        enter_met_env Location.none lab (Val_ivar (mut, cl_num))
+          Val_unbound_instance_variable ty class_env
+  in
+  vars := Vars.add lab (id, mut, virt, ty) !vars;
+  result
+
+let concr_vals vars =
+  Vars.fold
+    (fun id (_, vf, _) s -> if vf = Virtual then s else Concr.add id s)
+    vars Concr.empty
+
+let inheritance self_type env ovf concr_meths warn_vals loc parent =
+  match scrape_class_type parent with
+    Cty_signature cl_sig ->
+
+      (* Methods *)
+      begin try
+        Ctype.unify env self_type cl_sig.csig_self
+      with Ctype.Unify trace ->
+        match trace with
+        | Diff _ :: Incompatible_fields {name = n; _ } :: rem ->
+            raise(Error(loc, env, Field_type_mismatch ("method", n, rem)))
+        | _ -> assert false
+      end;
+
+      (* Overriding *)
+      let over_meths = Concr.inter cl_sig.csig_concr concr_meths in
+      let concr_vals = concr_vals cl_sig.csig_vars in
+      let over_vals = Concr.inter concr_vals warn_vals in
+      begin match ovf with
+        Some Fresh ->
+          let cname =
+            match parent with
+              Cty_constr (p, _, _) -> Path.name p
+            | _ -> "inherited"
+          in
+          if not (Concr.is_empty over_meths) then
+            Location.prerr_warning loc
+              (Warnings.Method_override (cname :: Concr.elements over_meths));
+          if not (Concr.is_empty over_vals) then
+            Location.prerr_warning loc
+              (Warnings.Instance_variable_override
+                 (cname :: Concr.elements over_vals));
+      | Some Override
+        when Concr.is_empty over_meths && Concr.is_empty over_vals ->
+        raise (Error(loc, env, No_overriding ("","")))
+      | _ -> ()
+      end;
+
+      let concr_meths = Concr.union cl_sig.csig_concr concr_meths
+      and warn_vals = Concr.union concr_vals warn_vals in
+
+      (cl_sig, concr_meths, warn_vals)
+
+  | _ ->
+      raise(Error(loc, env, Structure_expected parent))
+
+let virtual_method val_env meths self_type lab priv sty loc =
+  let (_, ty') =
+     Ctype.filter_self_method val_env lab priv meths self_type
+  in
+  let sty = Ast_helper.Typ.force_poly sty in
+  let cty = transl_simple_type val_env false sty in
+  let ty = cty.ctyp_type in
+  begin
+    try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
+        raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace)));
+  end;
+  cty
+
+let delayed_meth_specs = ref []
+
+let declare_method val_env meths self_type lab priv sty loc =
+  let (_, ty') =
+     Ctype.filter_self_method val_env lab priv meths self_type
+  in
+  let unif ty =
+    try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
+      raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace)))
+  in
+  let sty = Ast_helper.Typ.force_poly sty in
+  match sty.ptyp_desc, priv with
+    Ptyp_poly ([],sty'), Public ->
+(* TODO: we moved the [transl_simple_type_univars] outside of the lazy,
+so that we can get an immediate value. Is that correct ? Ask Jacques. *)
+      let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) val_env loc in
+      delayed_meth_specs :=
+      Warnings.mk_lazy (fun () ->
+            let cty = transl_simple_type_univars val_env sty' in
+            let ty = cty.ctyp_type in
+            unif ty;
+            returned_cty.ctyp_desc <- Ttyp_poly ([], cty);
+            returned_cty.ctyp_type <- ty;
+          ) ::
+      !delayed_meth_specs;
+      returned_cty
+  | _ ->
+      let cty = transl_simple_type val_env false sty in
+      let ty = cty.ctyp_type in
+      unif ty;
+      cty
+
+let type_constraint val_env sty sty' loc =
+  let cty  = transl_simple_type val_env false sty in
+  let ty = cty.ctyp_type in
+  let cty' = transl_simple_type val_env false sty' in
+  let ty' = cty'.ctyp_type in
+  begin
+    try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
+        raise(Error(loc, val_env, Unconsistent_constraint trace));
+  end;
+  (cty, cty')
+
+let make_method loc cl_num expr =
+  let open Ast_helper in
+  let mkid s = mkloc s loc in
+  Exp.fun_ ~loc:expr.pexp_loc Nolabel None
+    (Pat.alias ~loc (Pat.var ~loc (mkid "self-*")) (mkid ("self-" ^ cl_num)))
+    expr
+
+(*******************************)
+
+let add_val lab (mut, virt, ty) val_sig =
+  let virt =
+    try
+      let (_mut', virt', _ty') = Vars.find lab val_sig in
+      if virt' = Concrete then virt' else virt
+    with Not_found -> virt
+  in
+  Vars.add lab (mut, virt, ty) val_sig
+
+let rec class_type_field env self_type meths arg ctf =
+  Builtin_attributes.warning_scope ctf.pctf_attributes
+    (fun () -> class_type_field_aux env self_type meths arg ctf)
+
+and class_type_field_aux env self_type meths
+    (fields, val_sig, concr_meths, inher) ctf =
+
+  let loc = ctf.pctf_loc in
+  let mkctf desc =
+    { ctf_desc = desc; ctf_loc = loc; ctf_attributes = ctf.pctf_attributes }
+  in
+  match ctf.pctf_desc with
+    Pctf_inherit sparent ->
+      let parent = class_type env sparent in
+      let inher =
+        match parent.cltyp_type with
+          Cty_constr (p, tl, _) -> (p, tl) :: inher
+        | _ -> inher
+      in
+      let (cl_sig, concr_meths, _) =
+        inheritance self_type env None concr_meths Concr.empty sparent.pcty_loc
+          parent.cltyp_type
+      in
+      let val_sig =
+        Vars.fold add_val cl_sig.csig_vars val_sig in
+      (mkctf (Tctf_inherit parent) :: fields,
+       val_sig, concr_meths, inher)
+
+  | Pctf_val ({txt=lab}, mut, virt, sty) ->
+      let cty = transl_simple_type env false sty in
+      let ty = cty.ctyp_type in
+      (mkctf (Tctf_val (lab, mut, virt, cty)) :: fields,
+      add_val lab (mut, virt, ty) val_sig, concr_meths, inher)
+
+  | Pctf_method ({txt=lab}, priv, virt, sty)  ->
+      let cty =
+        declare_method env meths self_type lab priv sty  ctf.pctf_loc in
+      let concr_meths =
+        match virt with
+        | Concrete -> Concr.add lab concr_meths
+        | Virtual -> concr_meths
+      in
+      (mkctf (Tctf_method (lab, priv, virt, cty)) :: fields,
+        val_sig, concr_meths, inher)
+
+  | Pctf_constraint (sty, sty') ->
+      let (cty, cty') = type_constraint env sty sty'  ctf.pctf_loc in
+      (mkctf (Tctf_constraint (cty, cty')) :: fields,
+        val_sig, concr_meths, inher)
+
+  | Pctf_attribute x ->
+      Builtin_attributes.warning_attribute x;
+      (mkctf (Tctf_attribute x) :: fields,
+        val_sig, concr_meths, inher)
+
+  | Pctf_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and class_signature env {pcsig_self=sty; pcsig_fields=sign} =
+  let meths = ref Meths.empty in
+  let self_cty = transl_simple_type env false sty in
+  let self_cty = { self_cty with
+    ctyp_type = Ctype.expand_head env self_cty.ctyp_type } in
+  let self_type =  self_cty.ctyp_type in
+
+  (* Check that the binder is a correct type, and introduce a dummy
+     method preventing self type from being closed. *)
+  let dummy_obj = Ctype.newvar () in
+  Ctype.unify env (Ctype.filter_method env dummy_method Private dummy_obj)
+    (Ctype.newty (Ttuple []));
+  begin try
+    Ctype.unify env self_type dummy_obj
+  with Ctype.Unify _ ->
+    raise(Error(sty.ptyp_loc, env, Pattern_type_clash self_type))
+  end;
+
+  (* Class type fields *)
+  let (rev_fields, val_sig, concr_meths, inher) =
+    Builtin_attributes.warning_scope []
+      (fun () ->
+         List.fold_left (class_type_field env self_type meths)
+           ([], Vars.empty, Concr.empty, [])
+           sign
+      )
+  in
+  let cty =   {csig_self = self_type;
+   csig_vars = val_sig;
+   csig_concr = concr_meths;
+   csig_inher = inher}
+  in
+  { csig_self = self_cty;
+    csig_fields = List.rev rev_fields;
+    csig_type = cty;
+  }
+
+and class_type env scty =
+  Builtin_attributes.warning_scope scty.pcty_attributes
+    (fun () -> class_type_aux env scty)
+
+and class_type_aux env scty =
+  let cltyp desc typ =
+    {
+     cltyp_desc = desc;
+     cltyp_type = typ;
+     cltyp_loc = scty.pcty_loc;
+     cltyp_env = env;
+     cltyp_attributes = scty.pcty_attributes;
+    }
+  in
+  match scty.pcty_desc with
+    Pcty_constr (lid, styl) ->
+      let (path, decl) = Env.lookup_cltype ~loc:scty.pcty_loc lid.txt env in
+      if Path.same decl.clty_path unbound_class then
+        raise(Error(scty.pcty_loc, env, Unbound_class_type_2 lid.txt));
+      let (params, clty) =
+        Ctype.instance_class decl.clty_params decl.clty_type
+      in
+      if List.length params <> List.length styl then
+        raise(Error(scty.pcty_loc, env,
+                    Parameter_arity_mismatch (lid.txt, List.length params,
+                                                   List.length styl)));
+      let ctys = List.map2
+        (fun sty ty ->
+          let cty' = transl_simple_type env false sty in
+          let ty' = cty'.ctyp_type in
+          begin
+           try Ctype.unify env ty' ty with Ctype.Unify trace ->
+                  raise(Error(sty.ptyp_loc, env, Parameter_mismatch trace))
+            end;
+            cty'
+        )       styl params
+      in
+      let typ = Cty_constr (path, params, clty) in
+      cltyp (Tcty_constr ( path, lid , ctys)) typ
+
+  | Pcty_signature pcsig ->
+      let clsig = class_signature env pcsig in
+      let typ = Cty_signature clsig.csig_type in
+      cltyp (Tcty_signature clsig) typ
+
+  | Pcty_arrow (l, sty, scty) ->
+      let cty = transl_simple_type env false sty in
+      let ty = cty.ctyp_type in
+      let ty =
+        if Btype.is_optional l
+        then Ctype.newty (Tconstr(Predef.path_option,[ty], ref Mnil))
+        else ty in
+      let clty = class_type env scty in
+      let typ = Cty_arrow (l, ty, clty.cltyp_type) in
+      cltyp (Tcty_arrow (l, cty, clty)) typ
+
+  | Pcty_open (od, e) ->
+      let (od, newenv) = !type_open_descr env od in
+      let clty = class_type newenv e in
+      cltyp (Tcty_open (od, clty)) clty.cltyp_type
+
+  | Pcty_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+let class_type env scty =
+  delayed_meth_specs := [];
+  let cty = class_type env scty in
+  List.iter Lazy.force (List.rev !delayed_meth_specs);
+  delayed_meth_specs := [];
+  cty
+
+(*******************************)
+
+let rec class_field self_loc cl_num self_type meths vars arg cf =
+  Builtin_attributes.warning_scope cf.pcf_attributes
+    (fun () -> class_field_aux self_loc cl_num self_type meths vars arg cf)
+
+and class_field_aux self_loc cl_num self_type meths vars
+    (class_env, fields, concr_meths, warn_vals, inher,
+     local_meths, local_vals) cf =
+  let loc = cf.pcf_loc in
+  let mkcf desc =
+    { cf_desc = desc; cf_loc = loc; cf_attributes = cf.pcf_attributes }
+  in
+  let {val_env; met_env; par_env} = class_env in
+  match cf.pcf_desc with
+    Pcf_inherit (ovf, sparent, super) ->
+      let parent = class_expr cl_num val_env par_env sparent in
+      let inher =
+        match parent.cl_type with
+          Cty_constr (p, tl, _) -> (p, tl) :: inher
+        | _ -> inher
+      in
+      let (cl_sig, concr_meths, warn_vals) =
+        inheritance self_type val_env (Some ovf) concr_meths warn_vals
+          sparent.pcl_loc parent.cl_type
+      in
+      (* Variables *)
+      let (class_env, inh_vars) =
+        Vars.fold
+          (fun lab info (class_env, inh_vars) ->
+             let mut, vr, ty = info in
+             let (id, class_env) =
+                enter_val cl_num vars true lab mut vr ty class_env
+                 sparent.pcl_loc ;
+             in
+             (class_env, (lab, id) :: inh_vars))
+          cl_sig.csig_vars (class_env, [])
+      in
+      (* Inherited concrete methods *)
+      let inh_meths =
+        Concr.fold (fun lab rem -> (lab, Ident.create_local lab)::rem)
+          cl_sig.csig_concr []
+      in
+      (* Super *)
+      let (class_env,super) =
+        match super with
+          None ->
+            (class_env,None)
+        | Some {txt=name} ->
+            let (_id, class_env) =
+              enter_met_env ~check:(fun s -> Warnings.Unused_ancestor s)
+                sparent.pcl_loc name (Val_anc (inh_meths, cl_num))
+                Val_unbound_ancestor self_type class_env
+            in
+            (class_env,Some name)
+      in
+      (class_env,
+       lazy (mkcf (Tcf_inherit (ovf, parent, super, inh_vars, inh_meths)))
+       :: fields,
+       concr_meths, warn_vals, inher, local_meths, local_vals)
+
+  | Pcf_val (lab, mut, Cfk_virtual styp) ->
+      if !Clflags.principal then Ctype.begin_def ();
+      let cty = Typetexp.transl_simple_type val_env false styp in
+      let ty = cty.ctyp_type in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        Ctype.generalize_structure ty
+      end;
+      let (id, class_env') =
+        enter_val cl_num vars false lab.txt mut Virtual ty
+        class_env loc
+      in
+      (class_env',
+       lazy (mkcf (Tcf_val (lab, mut, id, Tcfk_virtual cty,
+                            met_env == class_env'.met_env)))
+             :: fields,
+             concr_meths, warn_vals, inher, local_meths, local_vals)
+
+  | Pcf_val (lab, mut, Cfk_concrete (ovf, sexp)) ->
+      if Concr.mem lab.txt local_vals then
+        raise(Error(loc, val_env, Duplicate ("instance variable", lab.txt)));
+      if Concr.mem lab.txt warn_vals then begin
+        if ovf = Fresh then
+          Location.prerr_warning lab.loc
+            (Warnings.Instance_variable_override[lab.txt])
+      end else begin
+        if ovf = Override then
+          raise(Error(loc, val_env,
+                      No_overriding ("instance variable", lab.txt)))
+      end;
+      if !Clflags.principal then Ctype.begin_def ();
+      let exp = type_exp val_env sexp in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        Ctype.generalize_structure exp.exp_type
+       end;
+      let (id, class_env') =
+        enter_val cl_num vars false lab.txt mut Concrete exp.exp_type
+        class_env loc
+      in
+      (class_env',
+       lazy (mkcf (Tcf_val (lab, mut, id,
+                    Tcfk_concrete (ovf, exp), met_env == class_env'.met_env)))
+       :: fields,
+       concr_meths, Concr.add lab.txt warn_vals, inher, local_meths,
+       Concr.add lab.txt local_vals)
+
+  | Pcf_method (lab, priv, Cfk_virtual sty) ->
+      let cty = virtual_method val_env meths self_type lab.txt priv sty loc in
+      (class_env,
+        lazy (mkcf(Tcf_method (lab, priv, Tcfk_virtual cty)))
+       ::fields,
+        concr_meths, warn_vals, inher, local_meths, local_vals)
+
+  | Pcf_method (lab, priv, Cfk_concrete (ovf, expr))  ->
+      let expr =
+        match expr.pexp_desc with
+        | Pexp_poly _ -> expr
+        | _ -> Ast_helper.Exp.poly ~loc:expr.pexp_loc expr None
+      in
+      if Concr.mem lab.txt local_meths then
+        raise(Error(loc, val_env, Duplicate ("method", lab.txt)));
+      if Concr.mem lab.txt concr_meths then begin
+        if ovf = Fresh then
+          Location.prerr_warning loc (Warnings.Method_override [lab.txt])
+      end else begin
+        if ovf = Override then
+          raise(Error(loc, val_env, No_overriding("method", lab.txt)))
+      end;
+      let (_, ty) =
+        Ctype.filter_self_method val_env lab.txt priv meths self_type
+      in
+      begin try match expr.pexp_desc with
+        Pexp_poly (sbody, sty) ->
+          begin match sty with None -> ()
+                | Some sty ->
+                    let sty = Ast_helper.Typ.force_poly sty in
+                    let cty' = Typetexp.transl_simple_type val_env false sty in
+                    let ty' = cty'.ctyp_type in
+              Ctype.unify val_env ty' ty
+          end;
+          begin match (Ctype.repr ty).desc with
+            Tvar _ ->
+              let ty' = Ctype.newvar () in
+              Ctype.unify val_env (Ctype.newty (Tpoly (ty', []))) ty;
+              Ctype.unify val_env (type_approx val_env sbody) ty'
+          | Tpoly (ty1, tl) ->
+              let _, ty1' = Ctype.instance_poly false tl ty1 in
+              let ty2 = type_approx val_env sbody in
+              Ctype.unify val_env ty2 ty1'
+          | _ -> assert false
+          end
+      | _ -> assert false
+      with Ctype.Unify trace ->
+        raise(Error(loc, val_env,
+                    Field_type_mismatch ("method", lab.txt, trace)))
+      end;
+      let meth_expr = make_method self_loc cl_num expr in
+      (* backup variables for Pexp_override *)
+      let vars_local = !vars in
+
+      let field =
+        Warnings.mk_lazy
+          (fun () ->
+             (* Read the generalized type *)
+             let (_, ty) = Meths.find lab.txt !meths in
+             let meth_type = mk_expected (
+               Btype.newgenty (Tarrow(Nolabel, self_type, ty, Cok))
+             ) in
+             Ctype.raise_nongen_level ();
+             vars := vars_local;
+             let texp = type_expect met_env meth_expr meth_type in
+             Ctype.end_def ();
+             mkcf (Tcf_method (lab, priv, Tcfk_concrete (ovf, texp)))
+          )
+      in
+      (class_env, field::fields,
+       Concr.add lab.txt concr_meths, warn_vals, inher,
+       Concr.add lab.txt local_meths, local_vals)
+
+  | Pcf_constraint (sty, sty') ->
+      let (cty, cty') = type_constraint val_env sty sty' loc in
+      (class_env,
+        lazy (mkcf (Tcf_constraint (cty, cty'))) :: fields,
+        concr_meths, warn_vals, inher, local_meths, local_vals)
+
+  | Pcf_initializer expr ->
+      let expr = make_method self_loc cl_num expr in
+      let vars_local = !vars in
+      let field =
+        lazy begin
+          Ctype.raise_nongen_level ();
+          let meth_type = mk_expected (
+            Ctype.newty
+              (Tarrow (Nolabel, self_type,
+                       Ctype.instance Predef.type_unit, Cok))
+          ) in
+          vars := vars_local;
+          let texp = type_expect met_env expr meth_type in
+          Ctype.end_def ();
+          mkcf (Tcf_initializer texp)
+        end in
+      (class_env, field::fields, concr_meths, warn_vals,
+       inher, local_meths, local_vals)
+  | Pcf_attribute x ->
+      Builtin_attributes.warning_attribute x;
+      (class_env,
+        lazy (mkcf (Tcf_attribute x)) :: fields,
+        concr_meths, warn_vals, inher, local_meths, local_vals)
+  | Pcf_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+(* N.B. the self type of a final object type doesn't contain a dummy method in
+   the beginning.
+   We only explicitly add a dummy method to class definitions (and class (type)
+   declarations)), which are later removed (made absent) by [final_decl].
+
+   If we ever find a dummy method in a final object self type, it means that
+   somehow we've unified the self type of the object with the self type of a not
+   yet finished class.
+   When this happens, we cannot close the object type and must error. *)
+and class_structure cl_num final val_env met_env loc
+  { pcstr_self = spat; pcstr_fields = str } =
+  (* Environment for substructures *)
+  let par_env = met_env in
+
+  (* Location of self. Used for locations of self arguments *)
+  let self_loc = {spat.ppat_loc with Location.loc_ghost = true} in
+
+  let self_type = Ctype.newobj (Ctype.newvar ()) in
+
+  (* Adding a dummy method to the self type prevents it from being closed /
+     escaping.
+     That isn't needed for objects though. *)
+  if not final then
+    Ctype.unify val_env
+      (Ctype.filter_method val_env dummy_method Private self_type)
+      (Ctype.newty (Ttuple []));
+
+  (* Private self is used for private method calls *)
+  let private_self = if final then Ctype.newvar () else self_type in
+
+  (* Self binder *)
+  let (pat, meths, vars, val_env, met_env, par_env) =
+    type_self_pattern cl_num private_self val_env met_env par_env spat
+  in
+  let public_self = pat.pat_type in
+
+  (* Check that the binder has a correct type *)
+  let ty =
+    if final then Ctype.newobj (Ctype.newvar()) else self_type in
+  begin try Ctype.unify val_env public_self ty with
+    Ctype.Unify _ ->
+      raise(Error(spat.ppat_loc, val_env, Pattern_type_clash public_self))
+  end;
+  let get_methods ty =
+    (fst (Ctype.flatten_fields
+            (Ctype.object_fields (Ctype.expand_head val_env ty)))) in
+  if final then begin
+    (* Copy known information to still empty self_type *)
+    List.iter
+      (fun (lab,kind,ty) ->
+        let k =
+          if Btype.field_kind_repr kind = Fpresent then Public else Private in
+        try Ctype.unify val_env ty
+            (Ctype.filter_method val_env lab k self_type)
+        with _ -> assert false)
+      (get_methods public_self)
+  end;
+
+  (* Typing of class fields *)
+  let class_env = {val_env; met_env; par_env} in
+  let (_, fields, concr_meths, _, inher, _local_meths, _local_vals) =
+    Builtin_attributes.warning_scope []
+      (fun () ->
+         List.fold_left (class_field self_loc cl_num self_type meths vars)
+           ( class_env,[], Concr.empty, Concr.empty, [],
+            Concr.empty, Concr.empty)
+           str
+      )
+  in
+  Ctype.unify val_env self_type (Ctype.newvar ()); (* useless ? *)
+  let sign =
+    {csig_self = public_self;
+     csig_vars = Vars.map (fun (_id, mut, vr, ty) -> (mut, vr, ty)) !vars;
+     csig_concr = concr_meths;
+      csig_inher = inher} in
+  let methods = get_methods self_type in
+  let priv_meths =
+    List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind <> Fpresent)
+      methods in
+  (* ensure that inherited methods are listed too *)
+  List.iter (fun (met, _kind, _ty) ->
+      if Meths.mem met !meths then () else
+      ignore (Ctype.filter_self_method val_env met Private meths self_type))
+    methods;
+  if final then begin
+    (* Unify private_self and a copy of self_type. self_type will not
+       be modified after this point *)
+    if not (Ctype.close_object self_type) then
+      raise(Error(loc, val_env, Closing_self_type self_type));
+    let mets = virtual_methods {sign with csig_self = self_type} in
+    let vals =
+      Vars.fold
+        (fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l)
+        sign.csig_vars [] in
+    if mets <> [] || vals <> [] then
+      raise(Error(loc, val_env, Virtual_class(true, final, mets, vals)));
+    let self_methods =
+      List.fold_right
+        (fun (lab,kind,ty) rem ->
+           Ctype.newty(Tfield(lab, Btype.copy_kind kind, ty, rem)))
+        methods (Ctype.newty Tnil) in
+    begin try
+      Ctype.unify val_env private_self
+        (Ctype.newty (Tobject(self_methods, ref None)));
+      Ctype.unify val_env public_self self_type
+    with Ctype.Unify trace -> raise(Error(loc, val_env, Final_self_clash trace))
+    end;
+  end;
+
+  (* Typing of method bodies *)
+  (* if !Clflags.principal then *) begin
+    let ms = !meths in
+    (* Generalize the spine of methods accessed through self *)
+    Meths.iter (fun _ (_,ty) -> Ctype.generalize_spine ty) ms;
+    meths :=
+      Meths.map (fun (id,ty) -> (id, Ctype.generic_instance ty)) ms;
+    (* But keep levels correct on the type of self *)
+    Meths.iter (fun _ (_,ty) -> Ctype.unify val_env ty (Ctype.newvar ())) ms
+  end;
+  let fields = List.map Lazy.force (List.rev fields) in
+  let meths = Meths.map (function (id, _ty) -> id) !meths in
+
+  (* Check for private methods made public *)
+  let pub_meths' =
+    List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind = Fpresent)
+      (get_methods public_self) in
+  let names = List.map (fun (x,_,_) -> x) in
+  let l1 = names priv_meths and l2 = names pub_meths' in
+  let added = List.filter (fun x -> List.mem x l1) l2 in
+  if added <> [] then
+    Location.prerr_warning loc (Warnings.Implicit_public_methods added);
+  let sign = if final then sign else
+      {sign with Types.csig_self = Ctype.expand_head val_env public_self} in
+  {
+    cstr_self = pat;
+    cstr_fields = fields;
+    cstr_type = sign;
+    cstr_meths = meths}, sign (* redondant, since already in cstr_type *)
+
+and class_expr cl_num val_env met_env scl =
+  Builtin_attributes.warning_scope scl.pcl_attributes
+    (fun () -> class_expr_aux cl_num val_env met_env scl)
+
+and class_expr_aux cl_num val_env met_env scl =
+  match scl.pcl_desc with
+    Pcl_constr (lid, styl) ->
+      let (path, decl) = Env.lookup_class ~loc:scl.pcl_loc lid.txt val_env in
+      if Path.same decl.cty_path unbound_class then
+        raise(Error(scl.pcl_loc, val_env, Unbound_class_2 lid.txt));
+      let tyl = List.map
+          (fun sty -> transl_simple_type val_env false sty)
+          styl
+      in
+      let (params, clty) =
+        Ctype.instance_class decl.cty_params decl.cty_type
+      in
+      let clty' = abbreviate_class_type path params clty in
+      if List.length params <> List.length tyl then
+        raise(Error(scl.pcl_loc, val_env,
+                    Parameter_arity_mismatch (lid.txt, List.length params,
+                                                   List.length tyl)));
+      List.iter2
+        (fun cty' ty ->
+          let ty' = cty'.ctyp_type in
+           try Ctype.unify val_env ty' ty with Ctype.Unify trace ->
+             raise(Error(cty'.ctyp_loc, val_env, Parameter_mismatch trace)))
+        tyl params;
+      let cl =
+        rc {cl_desc = Tcl_ident (path, lid, tyl);
+            cl_loc = scl.pcl_loc;
+            cl_type = clty';
+            cl_env = val_env;
+            cl_attributes = scl.pcl_attributes;
+           }
+      in
+      let (vals, meths, concrs) = extract_constraints clty in
+      rc {cl_desc = Tcl_constraint (cl, None, vals, meths, concrs);
+          cl_loc = scl.pcl_loc;
+          cl_type = clty';
+          cl_env = val_env;
+          cl_attributes = []; (* attributes are kept on the inner cl node *)
+         }
+  | Pcl_structure cl_str ->
+      let (desc, ty) =
+        class_structure cl_num false val_env met_env scl.pcl_loc cl_str in
+      rc {cl_desc = Tcl_structure desc;
+          cl_loc = scl.pcl_loc;
+          cl_type = Cty_signature ty;
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_fun (l, Some default, spat, sbody) ->
+      let loc = default.pexp_loc in
+      let open Ast_helper in
+      let scases = [
+        Exp.case
+          (Pat.construct ~loc
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
+             (Some ([], Pat.var ~loc (mknoloc "*sth*"))))
+          (Exp.ident ~loc (mknoloc (Longident.Lident "*sth*")));
+
+        Exp.case
+          (Pat.construct ~loc
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
+             None)
+          default;
+       ]
+      in
+      let smatch =
+        Exp.match_ ~loc (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*")))
+          scases
+      in
+      let sfun =
+        Cl.fun_ ~loc:scl.pcl_loc
+          l None
+          (Pat.var ~loc (mknoloc "*opt*"))
+          (Cl.let_ ~loc:scl.pcl_loc Nonrecursive [Vb.mk spat smatch] sbody)
+          (* Note: we don't put the '#default' attribute, as it
+             is not detected for class-level let bindings.  See #5975.*)
+      in
+      class_expr cl_num val_env met_env sfun
+  | Pcl_fun (l, None, spat, scl') ->
+      if !Clflags.principal then Ctype.begin_def ();
+      let (pat, pv, val_env', met_env) =
+        Typecore.type_class_arg_pattern cl_num val_env met_env l spat
+      in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        let gen {pat_type = ty} = Ctype.generalize_structure ty in
+        iter_pattern gen pat
+      end;
+      let pv =
+        List.map
+          begin fun (id, id', _ty) ->
+            let path = Pident id' in
+            (* do not mark the value as being used *)
+            let vd = Env.find_value path val_env' in
+            (id,
+             {exp_desc =
+              Texp_ident(path, mknoloc (Longident.Lident (Ident.name id)), vd);
+              exp_loc = Location.none; exp_extra = [];
+              exp_type = Ctype.instance vd.val_type;
+              exp_attributes = []; (* check *)
+              exp_env = val_env'})
+          end
+          pv
+      in
+      let rec not_nolabel_function = function
+        | Cty_arrow(Nolabel, _, _) -> false
+        | Cty_arrow(_, _, cty) -> not_nolabel_function cty
+        | _ -> true
+      in
+      let partial =
+        let dummy = type_exp val_env (Ast_helper.Exp.unreachable ()) in
+        Typecore.check_partial val_env pat.pat_type pat.pat_loc
+          [{c_lhs = pat; c_guard = None; c_rhs = dummy}]
+      in
+      Ctype.raise_nongen_level ();
+      let cl = class_expr cl_num val_env' met_env scl' in
+      Ctype.end_def ();
+      if Btype.is_optional l && not_nolabel_function cl.cl_type then
+        Location.prerr_warning pat.pat_loc
+          Warnings.Unerasable_optional_argument;
+      rc {cl_desc = Tcl_fun (l, pat, pv, cl, partial);
+          cl_loc = scl.pcl_loc;
+          cl_type = Cty_arrow
+            (l, Ctype.instance pat.pat_type, cl.cl_type);
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_apply (scl', sargs) ->
+      assert (sargs <> []);
+      if !Clflags.principal then Ctype.begin_def ();
+      let cl = class_expr cl_num val_env met_env scl' in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        generalize_class_type false cl.cl_type;
+      end;
+      let rec nonopt_labels ls ty_fun =
+        match ty_fun with
+        | Cty_arrow (l, _, ty_res) ->
+            if Btype.is_optional l then nonopt_labels ls ty_res
+            else nonopt_labels (l::ls) ty_res
+        | _    -> ls
+      in
+      let ignore_labels =
+        !Clflags.classic ||
+        let labels = nonopt_labels [] cl.cl_type in
+        List.length labels = List.length sargs &&
+        List.for_all (fun (l,_) -> l = Nolabel) sargs &&
+        List.exists (fun l -> l <> Nolabel) labels &&
+        begin
+          Location.prerr_warning
+            cl.cl_loc
+            (Warnings.Labels_omitted
+               (List.map Printtyp.string_of_label
+                         (List.filter ((<>) Nolabel) labels)));
+          true
+        end
+      in
+      let rec type_args args omitted ty_fun ty_fun0 sargs =
+        match ty_fun, ty_fun0 with
+        | Cty_arrow (l, ty, ty_fun), Cty_arrow (_, ty0, ty_fun0)
+          when sargs <> [] ->
+            let name = Btype.label_name l
+            and optional = Btype.is_optional l in
+            let use_arg sarg l' =
+              Some (
+                if not optional || Btype.is_optional l' then
+                  type_argument val_env sarg ty ty0
+                else
+                  let ty' = extract_option_type val_env ty
+                  and ty0' = extract_option_type val_env ty0 in
+                  let arg = type_argument val_env sarg ty' ty0' in
+                  option_some val_env arg
+              )
+            in
+            let eliminate_optional_arg () =
+              Some (option_none val_env ty0 Location.none)
+            in
+            let remaining_sargs, arg =
+              if ignore_labels then begin
+                match sargs with
+                | [] -> assert false
+                | (l', sarg) :: remaining_sargs ->
+                    if name = Btype.label_name l' ||
+                       (not optional && l' = Nolabel)
+                    then
+                      (remaining_sargs, use_arg sarg l')
+                    else if
+                      optional &&
+                      not (List.exists (fun (l, _) -> name = Btype.label_name l)
+                             remaining_sargs)
+                    then
+                      (sargs, eliminate_optional_arg ())
+                    else
+                      raise(Error(sarg.pexp_loc, val_env, Apply_wrong_label l'))
+              end else
+                match Btype.extract_label name sargs with
+                | Some (l', sarg, _, remaining_sargs) ->
+                    if not optional && Btype.is_optional l' then
+                      Location.prerr_warning sarg.pexp_loc
+                        (Warnings.Nonoptional_label
+                           (Printtyp.string_of_label l));
+                    remaining_sargs, use_arg sarg l'
+                | None ->
+                    sargs,
+                    if Btype.is_optional l && List.mem_assoc Nolabel sargs then
+                      eliminate_optional_arg ()
+                    else
+                      None
+            in
+            let omitted = if arg = None then (l,ty0) :: omitted else omitted in
+            type_args ((l,arg)::args) omitted ty_fun ty_fun0 remaining_sargs
+        | _ ->
+            match sargs with
+              (l, sarg0)::_ ->
+                if omitted <> [] then
+                  raise(Error(sarg0.pexp_loc, val_env, Apply_wrong_label l))
+                else
+                  raise(Error(cl.cl_loc, val_env, Cannot_apply cl.cl_type))
+            | [] ->
+                (List.rev args,
+                 List.fold_left
+                   (fun ty_fun (l,ty) -> Cty_arrow(l,ty,ty_fun))
+                   ty_fun0 omitted)
+      in
+      let (args, cty) =
+        let (_, ty_fun0) = Ctype.instance_class [] cl.cl_type in
+        type_args [] [] cl.cl_type ty_fun0 sargs
+      in
+      rc {cl_desc = Tcl_apply (cl, args);
+          cl_loc = scl.pcl_loc;
+          cl_type = cty;
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_let (rec_flag, sdefs, scl') ->
+      let (defs, val_env) =
+        Typecore.type_let In_class_def val_env rec_flag sdefs in
+      let (vals, met_env) =
+        List.fold_right
+          (fun (id, _id_loc, _typ) (vals, met_env) ->
+             let path = Pident id in
+             (* do not mark the value as used *)
+             let vd = Env.find_value path val_env in
+             Ctype.begin_def ();
+             let expr =
+               {exp_desc =
+                Texp_ident(path, mknoloc(Longident.Lident (Ident.name id)),vd);
+                exp_loc = Location.none; exp_extra = [];
+                exp_type = Ctype.instance vd.val_type;
+                exp_attributes = [];
+                exp_env = val_env;
+               }
+             in
+             Ctype.end_def ();
+             Ctype.generalize expr.exp_type;
+             let desc =
+               {val_type = expr.exp_type; val_kind = Val_ivar (Immutable,
+                                                               cl_num);
+                val_attributes = [];
+                Types.val_loc = vd.Types.val_loc;
+                val_uid = vd.val_uid;
+               }
+             in
+             let id' = Ident.create_local (Ident.name id) in
+             ((id', expr)
+              :: vals,
+              Env.add_value id' desc met_env))
+          (let_bound_idents_full defs)
+          ([], met_env)
+      in
+      let cl = class_expr cl_num val_env met_env scl' in
+      let () = if rec_flag = Recursive then
+        check_recursive_bindings val_env defs
+      in
+      rc {cl_desc = Tcl_let (rec_flag, defs, vals, cl);
+          cl_loc = scl.pcl_loc;
+          cl_type = cl.cl_type;
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_constraint (scl', scty) ->
+      Ctype.begin_class_def ();
+      let context = Typetexp.narrow () in
+      let cl = class_expr cl_num val_env met_env scl' in
+      Typetexp.widen context;
+      let context = Typetexp.narrow () in
+      let clty = class_type val_env scty in
+      Typetexp.widen context;
+      Ctype.end_def ();
+
+      limited_generalize (Ctype.row_variable (Ctype.self_type cl.cl_type))
+          cl.cl_type;
+      limited_generalize (Ctype.row_variable (Ctype.self_type clty.cltyp_type))
+        clty.cltyp_type;
+
+      begin match
+        Includeclass.class_types val_env cl.cl_type clty.cltyp_type
+      with
+        []    -> ()
+      | error -> raise(Error(cl.cl_loc, val_env, Class_match_failure error))
+      end;
+      let (vals, meths, concrs) = extract_constraints clty.cltyp_type in
+      rc {cl_desc = Tcl_constraint (cl, Some clty, vals, meths, concrs);
+          cl_loc = scl.pcl_loc;
+          cl_type = snd (Ctype.instance_class [] clty.cltyp_type);
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_open (pod, e) ->
+      let used_slot = ref false in
+      let (od, new_val_env) = !type_open_descr ~used_slot val_env pod in
+      let ( _, new_met_env) = !type_open_descr ~used_slot met_env pod in
+      let cl = class_expr cl_num new_val_env new_met_env e in
+      rc {cl_desc = Tcl_open (od, cl);
+          cl_loc = scl.pcl_loc;
+          cl_type = cl.cl_type;
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+(*******************************)
+
+(* Approximate the type of the constructor to allow recursive use *)
+(* of optional parameters                                         *)
+
+let var_option = Predef.type_option (Btype.newgenvar ())
+
+let rec approx_declaration cl =
+  match cl.pcl_desc with
+    Pcl_fun (l, _, _, cl) ->
+      let arg =
+        if Btype.is_optional l then Ctype.instance var_option
+        else Ctype.newvar () in
+      Ctype.newty (Tarrow (l, arg, approx_declaration cl, Cok))
+  | Pcl_let (_, _, cl) ->
+      approx_declaration cl
+  | Pcl_constraint (cl, _) ->
+      approx_declaration cl
+  | _ -> Ctype.newvar ()
+
+let rec approx_description ct =
+  match ct.pcty_desc with
+    Pcty_arrow (l, _, ct) ->
+      let arg =
+        if Btype.is_optional l then Ctype.instance var_option
+        else Ctype.newvar () in
+      Ctype.newty (Tarrow (l, arg, approx_description ct, Cok))
+  | _ -> Ctype.newvar ()
+
+(*******************************)
+
+let temp_abbrev loc env id arity uid =
+  let params = ref [] in
+  for _i = 1 to arity do
+    params := Ctype.newvar () :: !params
+  done;
+  let ty = Ctype.newobj (Ctype.newvar ()) in
+  let env =
+    Env.add_type ~check:true id
+      {type_params = !params;
+       type_arity = arity;
+       type_kind = Type_abstract;
+       type_private = Public;
+       type_manifest = Some ty;
+       type_variance = Variance.unknown_signature ~injective:false ~arity;
+       type_separability = Types.Separability.default_signature ~arity;
+       type_is_newtype = false;
+       type_expansion_scope = Btype.lowest_level;
+       type_loc = loc;
+       type_attributes = []; (* or keep attrs from the class decl? *)
+       type_immediate = Unknown;
+       type_unboxed_default = false;
+       type_uid = uid;
+      }
+      env
+  in
+  (!params, ty, env)
+
+let initial_env define_class approx
+    (res, env) (cl, id, ty_id, obj_id, cl_id, uid) =
+  (* Temporary abbreviations *)
+  let arity = List.length cl.pci_params in
+  let (obj_params, obj_ty, env) = temp_abbrev cl.pci_loc env obj_id arity uid in
+  let (cl_params, cl_ty, env) = temp_abbrev cl.pci_loc env cl_id arity uid in
+
+  (* Temporary type for the class constructor *)
+  let constr_type = approx cl.pci_expr in
+  if !Clflags.principal then Ctype.generalize_spine constr_type;
+  let dummy_cty =
+    Cty_signature
+      { csig_self = Ctype.newvar ();
+        csig_vars = Vars.empty;
+        csig_concr = Concr.empty;
+        csig_inher = [] }
+  in
+  let dummy_class =
+    {Types.cty_params = [];             (* Dummy value *)
+     cty_variance = [];
+     cty_type = dummy_cty;        (* Dummy value *)
+     cty_path = unbound_class;
+     cty_new =
+       begin match cl.pci_virt with
+       | Virtual  -> None
+       | Concrete -> Some constr_type
+       end;
+     cty_loc = Location.none;
+     cty_attributes = [];
+     cty_uid = uid;
+    }
+  in
+  let env =
+    Env.add_cltype ty_id
+      {clty_params = [];            (* Dummy value *)
+       clty_variance = [];
+       clty_type = dummy_cty;       (* Dummy value *)
+       clty_path = unbound_class;
+       clty_loc = Location.none;
+       clty_attributes = [];
+       clty_uid = uid;
+      }
+      (
+        if define_class then
+          Env.add_class id dummy_class env
+        else
+          env
+      )
+  in
+  ((cl, id, ty_id,
+    obj_id, obj_params, obj_ty,
+    cl_id, cl_params, cl_ty,
+    constr_type, dummy_class)::res,
+   env)
+
+let class_infos define_class kind
+    (cl, id, ty_id,
+     obj_id, obj_params, obj_ty,
+     cl_id, cl_params, cl_ty,
+     constr_type, dummy_class)
+    (res, env) =
+
+  reset_type_variables ();
+  Ctype.begin_class_def ();
+
+  (* Introduce class parameters *)
+  let ci_params =
+    let make_param (sty, v) =
+      try
+          (transl_type_param env sty, v)
+      with Already_bound ->
+        raise(Error(sty.ptyp_loc, env, Repeated_parameter))
+    in
+      List.map make_param cl.pci_params
+  in
+  let params = List.map (fun (cty, _) -> cty.ctyp_type) ci_params in
+
+  (* Allow self coercions (only for class declarations) *)
+  let coercion_locs = ref [] in
+
+  (* Type the class expression *)
+  let (expr, typ) =
+    try
+      Typecore.self_coercion :=
+        (Path.Pident obj_id, coercion_locs) :: !Typecore.self_coercion;
+      let res = kind env cl.pci_expr in
+      Typecore.self_coercion := List.tl !Typecore.self_coercion;
+      res
+    with exn ->
+      Typecore.self_coercion := []; raise exn
+  in
+
+  Ctype.end_def ();
+
+  let sty = Ctype.self_type typ in
+
+  (* First generalize the type of the dummy method (cf PR#6123) *)
+  let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in
+  List.iter (fun (met, _, ty) -> if met = dummy_method then Ctype.generalize ty)
+    fields;
+  (* Generalize the row variable *)
+  let rv = Ctype.row_variable sty in
+  List.iter (Ctype.limited_generalize rv) params;
+  limited_generalize rv typ;
+
+  (* Check the abbreviation for the object type *)
+  let (obj_params', obj_type) = Ctype.instance_class params typ in
+  let constr = Ctype.newconstr (Path.Pident obj_id) obj_params in
+  begin
+    let ty = Ctype.self_type obj_type in
+    Ctype.hide_private_methods ty;
+    if not (Ctype.close_object ty) then
+      raise(Error(cl.pci_loc, env, Closing_self_type ty));
+    begin try
+      List.iter2 (Ctype.unify env) obj_params obj_params'
+    with Ctype.Unify _ ->
+      raise(Error(cl.pci_loc, env,
+            Bad_parameters (obj_id, constr,
+                            Ctype.newconstr (Path.Pident obj_id)
+                                            obj_params')))
+    end;
+    begin try
+      Ctype.unify env ty constr
+    with Ctype.Unify _ ->
+      raise(Error(cl.pci_loc, env,
+        Abbrev_type_clash (constr, ty, Ctype.expand_head env constr)))
+    end
+  end;
+
+  (* Check the other temporary abbreviation (#-type) *)
+  begin
+    let (cl_params', cl_type) = Ctype.instance_class params typ in
+    let ty = Ctype.self_type cl_type in
+    Ctype.hide_private_methods ty;
+    Ctype.set_object_name obj_id (Ctype.row_variable ty) cl_params ty;
+    begin try
+      List.iter2 (Ctype.unify env) cl_params cl_params'
+    with Ctype.Unify _ ->
+      raise(Error(cl.pci_loc, env,
+            Bad_parameters (cl_id,
+                            Ctype.newconstr (Path.Pident cl_id)
+                                            cl_params,
+                            Ctype.newconstr (Path.Pident cl_id)
+                                            cl_params')))
+    end;
+    begin try
+      Ctype.unify env ty cl_ty
+    with Ctype.Unify _ ->
+      let constr = Ctype.newconstr (Path.Pident cl_id) params in
+      raise(Error(cl.pci_loc, env, Abbrev_type_clash (constr, ty, cl_ty)))
+    end
+  end;
+
+  (* Type of the class constructor *)
+  begin try
+    Ctype.unify env
+      (constructor_type constr obj_type)
+      (Ctype.instance constr_type)
+  with Ctype.Unify trace ->
+    raise(Error(cl.pci_loc, env,
+                Constructor_type_mismatch (cl.pci_name.txt, trace)))
+  end;
+
+  (* Class and class type temporary definitions *)
+  let cty_variance =
+    Variance.unknown_signature ~injective:false ~arity:(List.length params) in
+  let cltydef =
+    {clty_params = params; clty_type = class_body typ;
+     clty_variance = cty_variance;
+     clty_path = Path.Pident obj_id;
+     clty_loc = cl.pci_loc;
+     clty_attributes = cl.pci_attributes;
+     clty_uid = dummy_class.cty_uid;
+    }
+  and clty =
+    {cty_params = params; cty_type = typ;
+     cty_variance = cty_variance;
+     cty_path = Path.Pident obj_id;
+     cty_new =
+       begin match cl.pci_virt with
+       | Virtual  -> None
+       | Concrete -> Some constr_type
+       end;
+     cty_loc = cl.pci_loc;
+     cty_attributes = cl.pci_attributes;
+     cty_uid = dummy_class.cty_uid;
+    }
+  in
+  dummy_class.cty_type <- typ;
+  let env =
+    Env.add_cltype ty_id cltydef (
+    if define_class then Env.add_class id clty env else env)
+  in
+
+  if cl.pci_virt = Concrete then begin
+    let sign = Ctype.signature_of_class_type typ in
+    let mets = virtual_methods sign in
+    let vals =
+      Vars.fold
+        (fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l)
+        sign.csig_vars [] in
+    if mets <> []  || vals <> [] then
+      raise(Error(cl.pci_loc, env, Virtual_class(define_class, false, mets,
+                                                 vals)));
+  end;
+
+  (* Misc. *)
+  let arity = Ctype.class_type_arity typ in
+  let pub_meths =
+    let (fields, _) =
+      Ctype.flatten_fields (Ctype.object_fields (Ctype.expand_head env obj_ty))
+    in
+    List.map (function (lab, _, _) -> lab) fields
+  in
+
+  (* Final definitions *)
+  let (params', typ') = Ctype.instance_class params typ in
+  let cltydef =
+    {clty_params = params'; clty_type = class_body typ';
+     clty_variance = cty_variance;
+     clty_path = Path.Pident obj_id;
+     clty_loc = cl.pci_loc;
+     clty_attributes = cl.pci_attributes;
+     clty_uid = dummy_class.cty_uid;
+    }
+  and clty =
+    {cty_params = params'; cty_type = typ';
+     cty_variance = cty_variance;
+     cty_path = Path.Pident obj_id;
+     cty_new =
+       begin match cl.pci_virt with
+       | Virtual  -> None
+       | Concrete -> Some (Ctype.instance constr_type)
+       end;
+     cty_loc = cl.pci_loc;
+     cty_attributes = cl.pci_attributes;
+     cty_uid = dummy_class.cty_uid;
+    }
+  in
+  let obj_abbr =
+    let arity = List.length obj_params in
+    {
+     type_params = obj_params;
+     type_arity = arity;
+     type_kind = Type_abstract;
+     type_private = Public;
+     type_manifest = Some obj_ty;
+     type_variance = Variance.unknown_signature ~injective:false ~arity;
+     type_separability = Types.Separability.default_signature ~arity;
+     type_is_newtype = false;
+     type_expansion_scope = Btype.lowest_level;
+     type_loc = cl.pci_loc;
+     type_attributes = []; (* or keep attrs from cl? *)
+     type_immediate = Unknown;
+     type_unboxed_default = false;
+     type_uid = dummy_class.cty_uid;
+    }
+  in
+  let (cl_params, cl_ty) =
+    Ctype.instance_parameterized_type params (Ctype.self_type typ)
+  in
+  Ctype.hide_private_methods cl_ty;
+  Ctype.set_object_name obj_id (Ctype.row_variable cl_ty) cl_params cl_ty;
+  let cl_abbr =
+    let arity = List.length cl_params in
+    {
+     type_params = cl_params;
+     type_arity = arity;
+     type_kind = Type_abstract;
+     type_private = Public;
+     type_manifest = Some cl_ty;
+     type_variance = Variance.unknown_signature ~injective:false ~arity;
+     type_separability = Types.Separability.default_signature ~arity;
+     type_is_newtype = false;
+     type_expansion_scope = Btype.lowest_level;
+     type_loc = cl.pci_loc;
+     type_attributes = []; (* or keep attrs from cl? *)
+     type_immediate = Unknown;
+     type_unboxed_default = false;
+     type_uid = dummy_class.cty_uid;
+    }
+  in
+  ((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params,
+    arity, pub_meths, List.rev !coercion_locs, expr) :: res,
+   env)
+
+let final_decl env define_class
+    (cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params,
+     arity, pub_meths, coe, expr) =
+
+  begin try Ctype.collapse_conj_params env clty.cty_params
+  with Ctype.Unify trace ->
+    raise(Error(cl.pci_loc, env, Non_collapsable_conjunction (id, clty, trace)))
+  end;
+
+  (* make the dummy method disappear *)
+  begin
+    let self_type = Ctype.self_type clty.cty_type in
+    let methods, _ =
+      Ctype.flatten_fields
+        (Ctype.object_fields (Ctype.expand_head env self_type))
+    in
+    List.iter (fun (lab,kind,_) ->
+      if lab = dummy_method then
+        match Btype.field_kind_repr kind with
+          Fvar r -> Btype.set_kind r Fabsent
+        | _ -> ()
+    ) methods
+  end;
+
+  List.iter Ctype.generalize clty.cty_params;
+  generalize_class_type true clty.cty_type;
+  Option.iter  Ctype.generalize clty.cty_new;
+  List.iter Ctype.generalize obj_abbr.type_params;
+  Option.iter  Ctype.generalize obj_abbr.type_manifest;
+  List.iter Ctype.generalize cl_abbr.type_params;
+  Option.iter  Ctype.generalize cl_abbr.type_manifest;
+
+  if not (closed_class clty) then
+    raise(Error(cl.pci_loc, env, Non_generalizable_class (id, clty)));
+
+  begin match
+    Ctype.closed_class clty.cty_params
+      (Ctype.signature_of_class_type clty.cty_type)
+  with
+    None        -> ()
+  | Some reason ->
+      let printer =
+        if define_class
+        then function ppf -> Printtyp.class_declaration id ppf clty
+        else function ppf -> Printtyp.cltype_declaration id ppf cltydef
+      in
+      raise(Error(cl.pci_loc, env, Unbound_type_var(printer, reason)))
+  end;
+  { id; clty; ty_id; cltydef; obj_id; obj_abbr; cl_id; cl_abbr; arity;
+    pub_meths; coe;
+    id_loc = cl.pci_name;
+    req = { ci_loc = cl.pci_loc;
+            ci_virt = cl.pci_virt;
+            ci_params = ci_params;
+        (* TODO : check that we have the correct use of identifiers *)
+            ci_id_name = cl.pci_name;
+            ci_id_class = id;
+            ci_id_class_type = ty_id;
+            ci_id_object = obj_id;
+            ci_id_typehash = cl_id;
+            ci_expr = expr;
+            ci_decl = clty;
+            ci_type_decl = cltydef;
+            ci_attributes = cl.pci_attributes;
+        }
+  }
+(*   (cl.pci_variance, cl.pci_loc)) *)
+
+let class_infos define_class kind
+    (cl, id, ty_id,
+     obj_id, obj_params, obj_ty,
+     cl_id, cl_params, cl_ty,
+     constr_type, dummy_class)
+    (res, env) =
+  Builtin_attributes.warning_scope cl.pci_attributes
+    (fun () ->
+       class_infos define_class kind
+         (cl, id, ty_id,
+          obj_id, obj_params, obj_ty,
+          cl_id, cl_params, cl_ty,
+          constr_type, dummy_class)
+         (res, env)
+    )
+
+let extract_type_decls { clty; cltydef; obj_id; obj_abbr; cl_abbr; req} decls =
+  (obj_id, obj_abbr, cl_abbr, clty, cltydef, req) :: decls
+
+let merge_type_decls decl (obj_abbr, cl_abbr, clty, cltydef) =
+  {decl with obj_abbr; cl_abbr; clty; cltydef}
+
+let final_env define_class env { id; clty; ty_id; cltydef; obj_id; obj_abbr;
+    cl_id; cl_abbr } =
+  (* Add definitions after cleaning them *)
+  Env.add_type ~check:true obj_id
+    (Subst.type_declaration Subst.identity obj_abbr) (
+  Env.add_type ~check:true cl_id
+    (Subst.type_declaration Subst.identity cl_abbr) (
+  Env.add_cltype ty_id (Subst.cltype_declaration Subst.identity cltydef) (
+  if define_class then
+    Env.add_class id (Subst.class_declaration Subst.identity clty) env
+  else env)))
+
+(* Check that #c is coercible to c if there is a self-coercion *)
+let check_coercions env { id; id_loc; clty; ty_id; cltydef; obj_id; obj_abbr;
+    cl_id; cl_abbr; arity; pub_meths; coe; req } =
+  begin match coe with [] -> ()
+  | loc :: _ ->
+      let cl_ty, obj_ty =
+        match cl_abbr.type_manifest, obj_abbr.type_manifest with
+          Some cl_ab, Some obj_ab ->
+            let cl_params, cl_ty =
+              Ctype.instance_parameterized_type cl_abbr.type_params cl_ab
+            and obj_params, obj_ty =
+              Ctype.instance_parameterized_type obj_abbr.type_params obj_ab
+            in
+            List.iter2 (Ctype.unify env) cl_params obj_params;
+            cl_ty, obj_ty
+        | _ -> assert false
+      in
+      begin try Ctype.subtype env cl_ty obj_ty ()
+      with Ctype.Subtype (tr1, tr2) ->
+        raise(Typecore.Error(loc, env, Typecore.Not_subtype(tr1, tr2)))
+      end;
+      if not (Ctype.opened_object cl_ty) then
+        raise(Error(loc, env, Cannot_coerce_self obj_ty))
+  end;
+  {cls_id = id;
+   cls_id_loc = id_loc;
+   cls_decl = clty;
+   cls_ty_id = ty_id;
+   cls_ty_decl = cltydef;
+   cls_obj_id = obj_id;
+   cls_obj_abbr = obj_abbr;
+   cls_typesharp_id = cl_id;
+   cls_abbr = cl_abbr;
+   cls_arity = arity;
+   cls_pub_methods = pub_meths;
+   cls_info=req}
+
+(*******************************)
+
+let type_classes define_class approx kind env cls =
+  let scope = Ctype.create_scope () in
+  let cls =
+    List.map
+      (function cl ->
+         (cl,
+          Ident.create_scoped ~scope cl.pci_name.txt,
+          Ident.create_scoped ~scope cl.pci_name.txt,
+          Ident.create_scoped ~scope cl.pci_name.txt,
+          Ident.create_scoped ~scope ("#" ^ cl.pci_name.txt),
+          Uid.mk ~current_unit:(Env.get_unit_name ())
+         ))
+      cls
+  in
+  Ctype.begin_class_def ();
+  let (res, newenv) =
+    List.fold_left (initial_env define_class approx) ([], env) cls
+  in
+  let (res, newenv) =
+    List.fold_right (class_infos define_class kind) res ([], newenv)
+  in
+  Ctype.end_def ();
+  let res = List.rev_map (final_decl newenv define_class) res in
+  let decls = List.fold_right extract_type_decls res [] in
+  let decls =
+    try Typedecl_variance.update_class_decls newenv decls
+    with Typedecl_variance.Error(loc, err) ->
+      raise (Typedecl.Error(loc, Typedecl.Variance err))
+  in
+  let res = List.map2 merge_type_decls res decls in
+  let env = List.fold_left (final_env define_class) env res in
+  let res = List.map (check_coercions env) res in
+  (res, env)
+
+let class_num = ref 0
+let class_declaration env sexpr =
+  incr class_num;
+  let expr = class_expr (Int.to_string !class_num) env env sexpr in
+  (expr, expr.cl_type)
+
+let class_description env sexpr =
+  let expr = class_type env sexpr in
+  (expr, expr.cltyp_type)
+
+let class_declarations env cls =
+  let info, env =
+    type_classes true approx_declaration class_declaration env cls
+  in
+  let ids, exprs =
+    List.split
+      (List.map
+         (fun ci -> ci.cls_id, ci.cls_info.ci_expr)
+         info)
+  in
+  check_recursive_class_bindings env ids exprs;
+  info, env
+
+let class_descriptions env cls =
+  type_classes true approx_description class_description env cls
+
+let class_type_declarations env cls =
+  let (decls, env) =
+    type_classes false approx_description class_description env cls
+  in
+  (List.map
+     (fun decl ->
+        {clsty_ty_id = decl.cls_ty_id;
+         clsty_id_loc = decl.cls_id_loc;
+         clsty_ty_decl = decl.cls_ty_decl;
+         clsty_obj_id = decl.cls_obj_id;
+         clsty_obj_abbr = decl.cls_obj_abbr;
+         clsty_typesharp_id = decl.cls_typesharp_id;
+         clsty_abbr = decl.cls_abbr;
+         clsty_info = decl.cls_info})
+     decls,
+   env)
+
+let rec unify_parents env ty cl =
+  match cl.cl_desc with
+    Tcl_ident (p, _, _) ->
+      begin try
+        let decl = Env.find_class p env in
+        let _, body = Ctype.find_cltype_for_path env decl.cty_path in
+        Ctype.unify env ty (Ctype.instance body)
+      with
+        Not_found -> ()
+      | _exn -> assert false
+      end
+  | Tcl_structure st -> unify_parents_struct env ty st
+  | Tcl_open (_, cl)
+  | Tcl_fun (_, _, _, cl, _)
+  | Tcl_apply (cl, _)
+  | Tcl_let (_, _, _, cl)
+  | Tcl_constraint (cl, _, _, _, _) -> unify_parents env ty cl
+and unify_parents_struct env ty st =
+  List.iter
+    (function
+      | {cf_desc = Tcf_inherit (_, cl, _, _, _)} ->
+          unify_parents env ty cl
+      | _ -> ())
+    st.cstr_fields
+
+let type_object env loc s =
+  incr class_num;
+  let (desc, sign) =
+    class_structure (Int.to_string !class_num) true env env loc s in
+  let sty = Ctype.expand_head env sign.csig_self in
+  Ctype.hide_private_methods sty;
+  let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in
+  let meths = List.map (fun (s,_,_) -> s) fields in
+  unify_parents_struct env sign.csig_self desc;
+  (desc, sign, meths)
+
+let () =
+  Typecore.type_object := type_object
+
+(*******************************)
+
+(* Approximate the class declaration as class ['params] id = object end *)
+let approx_class sdecl =
+  let open Ast_helper in
+  let self' = Typ.any () in
+  let clty' = Cty.signature ~loc:sdecl.pci_expr.pcty_loc (Csig.mk self' []) in
+  { sdecl with pci_expr = clty' }
+
+let approx_class_declarations env sdecls =
+  fst (class_type_declarations env (List.map approx_class sdecls))
+
+(*******************************)
+
+(* Error report *)
+
+open Format
+
+let report_error env ppf = function
+  | Repeated_parameter ->
+      fprintf ppf "A type parameter occurs several times"
+  | Unconsistent_constraint trace ->
+      fprintf ppf "@[<v>The class constraints are not consistent.@ ";
+      Printtyp.report_unification_error ppf env trace
+        (fun ppf -> fprintf ppf "Type")
+        (fun ppf -> fprintf ppf "is not compatible with type");
+      fprintf ppf "@]"
+  | Field_type_mismatch (k, m, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "The %s %s@ has type" k m)
+        (function ppf ->
+           fprintf ppf "but is expected to have type")
+  | Structure_expected clty ->
+      fprintf ppf
+        "@[This class expression is not a class structure; it has type@ %a@]"
+        Printtyp.class_type clty
+  | Cannot_apply _ ->
+      fprintf ppf
+        "This class expression is not a class function, it cannot be applied"
+  | Apply_wrong_label l ->
+      let mark_label = function
+        | Nolabel -> "out label"
+        |  l -> sprintf " label %s" (Btype.prefixed_label_name l) in
+      fprintf ppf "This argument cannot be applied with%s" (mark_label l)
+  | Pattern_type_clash ty ->
+      (* XXX Trace *)
+      (* XXX Revoir message d'erreur | Improve error message *)
+      fprintf ppf "@[%s@ %a@]"
+        "This pattern cannot match self: it only matches values of type"
+        Printtyp.type_expr ty
+  | Unbound_class_2 cl ->
+      fprintf ppf "@[The class@ %a@ is not yet completely defined@]"
+      Printtyp.longident cl
+  | Unbound_class_type_2 cl ->
+      fprintf ppf "@[The class type@ %a@ is not yet completely defined@]"
+      Printtyp.longident cl
+  | Abbrev_type_clash (abbrev, actual, expected) ->
+      (* XXX Afficher une trace ? | Print a trace? *)
+      Printtyp.reset_and_mark_loops_list [abbrev; actual; expected];
+      fprintf ppf "@[The abbreviation@ %a@ expands to type@ %a@ \
+       but is used with type@ %a@]"
+        !Oprint.out_type (Printtyp.tree_of_typexp false abbrev)
+        !Oprint.out_type (Printtyp.tree_of_typexp false actual)
+        !Oprint.out_type (Printtyp.tree_of_typexp false expected)
+  | Constructor_type_mismatch (c, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "The expression \"new %s\" has type" c)
+        (function ppf ->
+           fprintf ppf "but is used with type")
+  | Virtual_class (cl, imm, mets, vals) ->
+      let print_mets ppf mets =
+        List.iter (function met -> fprintf ppf "@ %s" met) mets in
+      let missings =
+        match mets, vals with
+          [], _ -> "variables"
+        | _, [] -> "methods"
+        | _ -> "methods and variables"
+      in
+      let print_msg ppf =
+        if imm then fprintf ppf "This object has virtual %s" missings
+        else if cl then fprintf ppf "This class should be virtual"
+        else fprintf ppf "This class type should be virtual"
+      in
+      fprintf ppf
+        "@[%t.@ @[<2>The following %s are undefined :%a@]@]"
+        print_msg missings print_mets (mets @ vals)
+  | Parameter_arity_mismatch(lid, expected, provided) ->
+      fprintf ppf
+        "@[The class constructor %a@ expects %i type argument(s),@ \
+           but is here applied to %i type argument(s)@]"
+        Printtyp.longident lid expected provided
+  | Parameter_mismatch trace ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "The type parameter")
+        (function ppf ->
+           fprintf ppf "does not meet its constraint: it should be")
+  | Bad_parameters (id, params, cstrs) ->
+      Printtyp.reset_and_mark_loops_list [params; cstrs];
+      fprintf ppf
+        "@[The abbreviation %a@ is used with parameters@ %a@ \
+           which are incompatible with constraints@ %a@]"
+        Printtyp.ident id
+        !Oprint.out_type (Printtyp.tree_of_typexp false params)
+        !Oprint.out_type (Printtyp.tree_of_typexp false cstrs)
+  | Class_match_failure error ->
+      Includeclass.report_error ppf error
+  | Unbound_val lab ->
+      fprintf ppf "Unbound instance variable %s" lab
+  | Unbound_type_var (printer, reason) ->
+      let print_common ppf kind ty0 real lab ty =
+        let ty1 =
+          if real then ty0 else Btype.newgenty(Tobject(ty0, ref None)) in
+        List.iter Printtyp.mark_loops [ty; ty1];
+        fprintf ppf
+          "The %s %s@ has type@;<1 2>%a@ where@ %a@ is unbound"
+          kind lab
+          !Oprint.out_type (Printtyp.tree_of_typexp false ty)
+          !Oprint.out_type (Printtyp.tree_of_typexp false ty0)
+      in
+      let print_reason ppf = function
+      | Ctype.CC_Method (ty0, real, lab, ty) ->
+          print_common ppf "method" ty0 real lab ty
+      | Ctype.CC_Value (ty0, real, lab, ty) ->
+          print_common ppf "instance variable" ty0 real lab ty
+      in
+      Printtyp.reset ();
+      fprintf ppf
+        "@[<v>@[Some type variables are unbound in this type:@;<1 2>%t@]@ \
+              @[%a@]@]"
+       printer print_reason reason
+  | Non_generalizable_class (id, clty) ->
+      fprintf ppf
+        "@[The type of this class,@ %a,@ \
+           contains type variables that cannot be generalized@]"
+        (Printtyp.class_declaration id) clty
+  | Cannot_coerce_self ty ->
+      fprintf ppf
+        "@[The type of self cannot be coerced to@ \
+           the type of the current class:@ %a.@.\
+           Some occurrences are contravariant@]"
+        Printtyp.type_scheme ty
+  | Non_collapsable_conjunction (id, clty, trace) ->
+      fprintf ppf
+        "@[The type of this class,@ %a,@ \
+           contains non-collapsible conjunctive types in constraints.@ %t@]"
+        (Printtyp.class_declaration id) clty
+        (fun ppf -> Printtyp.report_unification_error ppf env trace
+            (fun ppf -> fprintf ppf "Type")
+            (fun ppf -> fprintf ppf "is not compatible with type")
+        )
+  | Final_self_clash trace ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "This object is expected to have type")
+        (function ppf ->
+           fprintf ppf "but actually has type")
+  | Mutability_mismatch (_lab, mut) ->
+      let mut1, mut2 =
+        if mut = Immutable then "mutable", "immutable"
+        else "immutable", "mutable" in
+      fprintf ppf
+        "@[The instance variable is %s;@ it cannot be redefined as %s@]"
+        mut1 mut2
+  | No_overriding (_, "") ->
+      fprintf ppf "@[This inheritance does not override any method@ %s@]"
+        "instance variable"
+  | No_overriding (kind, name) ->
+      fprintf ppf "@[The %s `%s'@ has no previous definition@]" kind name
+  | Duplicate (kind, name) ->
+      fprintf ppf "@[The %s `%s'@ has multiple definitions in this object@]"
+                    kind name
+  | Closing_self_type self ->
+    fprintf ppf
+      "@[Cannot close type of object literal:@ %a@,\
+       it has been unified with the self type of a class that is not yet@ \
+       completely defined.@]"
+      Printtyp.type_scheme self
+
+let report_error env ppf err =
+  Printtyp.wrap_printing_env ~error:true
+    env (fun () -> report_error env ppf err)
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, env, err) ->
+        Some (Location.error_of_printer ~loc (report_error env) err)
+      | Error_forward err ->
+        Some err
+      | _ ->
+        None
+    )
diff --git a/src/ocaml/typing/typeclass.mli b/src/ocaml/typing/typeclass.mli
new file mode 100644
index 0000000..ac8eb06
--- /dev/null
+++ b/src/ocaml/typing/typeclass.mli
@@ -0,0 +1,130 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Types
+open Format
+
+type 'a class_info = {
+  cls_id : Ident.t;
+  cls_id_loc : string loc;
+  cls_decl : class_declaration;
+  cls_ty_id : Ident.t;
+  cls_ty_decl : class_type_declaration;
+  cls_obj_id : Ident.t;
+  cls_obj_abbr : type_declaration;
+  cls_typesharp_id : Ident.t;
+  cls_abbr : type_declaration;
+  cls_arity : int;
+  cls_pub_methods : string list;
+  cls_info : 'a;
+}
+
+type class_type_info = {
+  clsty_ty_id : Ident.t;
+  clsty_id_loc : string loc;
+  clsty_ty_decl : class_type_declaration;
+  clsty_obj_id : Ident.t;
+  clsty_obj_abbr : type_declaration;
+  clsty_typesharp_id : Ident.t;
+  clsty_abbr : type_declaration;
+  clsty_info : Typedtree.class_type_declaration;
+}
+
+val class_declarations:
+  Env.t -> Parsetree.class_declaration list ->
+  Typedtree.class_declaration class_info list * Env.t
+
+(*
+and class_declaration =
+  (class_expr, Types.class_declaration) class_infos
+*)
+
+val class_descriptions:
+  Env.t -> Parsetree.class_description list ->
+  Typedtree.class_description class_info list * Env.t
+
+(*
+and class_description =
+  (class_type, unit) class_infos
+*)
+
+val class_type_declarations:
+  Env.t -> Parsetree.class_description list -> class_type_info list * Env.t
+
+(*
+and class_type_declaration =
+  (class_type, Types.class_type_declaration) class_infos
+*)
+
+val approx_class_declarations:
+  Env.t -> Parsetree.class_description list -> class_type_info list
+
+val virtual_methods: Types.class_signature -> label list
+
+(*
+val type_classes :
+           bool ->
+           ('a -> Types.type_expr) ->
+           (Env.t -> 'a -> 'b * Types.class_type) ->
+           Env.t ->
+           'a Parsetree.class_infos list ->
+  (  Ident.t * Types.class_declaration *
+     Ident.t * Types.class_type_declaration *
+     Ident.t * Types.type_declaration *
+     Ident.t * Types.type_declaration *
+     int * string list * 'b * 'b Typedtree.class_infos)
+           list * Env.t
+*)
+
+type error =
+  | Unconsistent_constraint of Errortrace.unification Errortrace.t
+  | Field_type_mismatch of string * string * Errortrace.unification Errortrace.t
+  | Structure_expected of class_type
+  | Cannot_apply of class_type
+  | Apply_wrong_label of arg_label
+  | Pattern_type_clash of type_expr
+  | Repeated_parameter
+  | Unbound_class_2 of Longident.t
+  | Unbound_class_type_2 of Longident.t
+  | Abbrev_type_clash of type_expr * type_expr * type_expr
+  | Constructor_type_mismatch of string * Errortrace.unification Errortrace.t
+  | Virtual_class of bool * bool * string list * string list
+  | Parameter_arity_mismatch of Longident.t * int * int
+  | Parameter_mismatch of Errortrace.unification Errortrace.t
+  | Bad_parameters of Ident.t * type_expr * type_expr
+  | Class_match_failure of Ctype.class_match_failure list
+  | Unbound_val of string
+  | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure
+  | Non_generalizable_class of Ident.t * Types.class_declaration
+  | Cannot_coerce_self of type_expr
+  | Non_collapsable_conjunction of
+      Ident.t * Types.class_declaration * Errortrace.unification Errortrace.t
+  | Final_self_clash of Errortrace.unification Errortrace.t
+  | Mutability_mismatch of string * mutable_flag
+  | No_overriding of string * string
+  | Duplicate of string * string
+  | Closing_self_type of type_expr
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+val report_error : Env.t -> formatter -> error -> unit
+
+(* Forward decl filled in by Typemod.type_open_descr *)
+val type_open_descr :
+  (?used_slot:bool ref ->
+   Env.t -> Parsetree.open_description -> Typedtree.open_description * Env.t)
+    ref
diff --git a/src/ocaml/typing/typecore.ml b/src/ocaml/typing/typecore.ml
new file mode 100644
index 0000000..e5dcc86
--- /dev/null
+++ b/src/ocaml/typing/typecore.ml
@@ -0,0 +1,6014 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Typechecking for the core language *)
+
+open Misc
+open Asttypes
+open Parsetree
+open Types
+open Typedtree
+open Btype
+open Ctype
+
+let raise_error = Msupport.raise_error
+
+type type_forcing_context =
+  | If_conditional
+  | If_no_else_branch
+  | While_loop_conditional
+  | While_loop_body
+  | For_loop_start_index
+  | For_loop_stop_index
+  | For_loop_body
+  | Assert_condition
+  | Sequence_left_hand_side
+  | When_guard
+
+type type_expected = {
+  ty: type_expr;
+  explanation: type_forcing_context option;
+}
+
+type to_unpack = {
+  tu_name: string Location.loc;
+  tu_loc: Location.t;
+  tu_uid: Uid.t
+}
+
+module Datatype_kind = struct
+  type t = Record | Variant
+
+  let type_name = function
+    | Record -> "record"
+    | Variant -> "variant"
+
+  let label_name = function
+    | Record -> "field"
+    | Variant -> "constructor"
+end
+
+type wrong_name = {
+  type_path: Path.t;
+  kind: Datatype_kind.t;
+  name: string loc;
+  valid_names: string list;
+}
+
+type existential_restriction =
+  | At_toplevel (** no existential types at the toplevel *)
+  | In_group (** nor with let ... and ... *)
+  | In_rec (** or recursive definition *)
+  | With_attributes (** or let[@any_attribute] = ... *)
+  | In_class_args (** or in class arguments *)
+  | In_class_def  (** or in [class c = let ... in ...] *)
+  | In_self_pattern (** or in self pattern *)
+
+type error =
+  | Constructor_arity_mismatch of Longident.t * int * int
+  | Label_mismatch of Longident.t * Errortrace.unification Errortrace.t
+  | Pattern_type_clash :
+      Errortrace.unification Errortrace.t * _ pattern_desc option -> error
+  | Or_pattern_type_clash of Ident.t * Errortrace.unification Errortrace.t
+  | Multiply_bound_variable of string
+  | Orpat_vars of Ident.t * Ident.t list
+  | Expr_type_clash of
+      Errortrace.unification Errortrace.t * type_forcing_context option
+      * expression_desc option
+  | Apply_non_function of type_expr
+  | Apply_wrong_label of arg_label * type_expr * bool
+  | Label_multiply_defined of string
+  | Label_missing of Ident.t list
+  | Label_not_mutable of Longident.t
+  | Wrong_name of string * type_expected * wrong_name
+  | Name_type_mismatch of
+      Datatype_kind.t * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list
+  | Invalid_format of string
+  | Undefined_method of type_expr * string * string list option
+  | Undefined_inherited_method of string * string list
+  | Virtual_class of Longident.t
+  | Private_type of type_expr
+  | Private_label of Longident.t * type_expr
+  | Private_constructor of constructor_description * type_expr
+  | Unbound_instance_variable of string * string list
+  | Instance_variable_not_mutable of string
+  | Not_subtype of Errortrace.Subtype.t * Errortrace.unification Errortrace.t
+  | Outside_class
+  | Value_multiply_overridden of string
+  | Coercion_failure of
+      type_expr * type_expr * Errortrace.unification Errortrace.t * bool
+  | Too_many_arguments of bool * type_expr * type_forcing_context option
+  | Abstract_wrong_label of arg_label * type_expr * type_forcing_context option
+  | Scoping_let_module of string * type_expr
+  | Not_a_variant_type of Longident.t
+  | Incoherent_label_order
+  | Less_general of string * Errortrace.unification Errortrace.t
+  | Modules_not_allowed
+  | Cannot_infer_signature
+  | Not_a_packed_module of type_expr
+  | Unexpected_existential of existential_restriction * string * string list
+  | Invalid_interval
+  | Invalid_for_loop_index
+  | No_value_clauses
+  | Exception_pattern_disallowed
+  | Mixed_value_and_exception_patterns_under_guard
+  | Inlined_record_escape
+  | Inlined_record_expected
+  | Unrefuted_pattern of pattern
+  | Invalid_extension_constructor_payload
+  | Not_an_extension_constructor
+  | Literal_overflow of string
+  | Unknown_literal of string * char
+  | Illegal_letrec_pat
+  | Illegal_letrec_expr
+  | Illegal_class_expr
+  | Letop_type_clash of string * Errortrace.unification Errortrace.t
+  | Andop_type_clash of string * Errortrace.unification Errortrace.t
+  | Bindings_type_clash of Errortrace.unification Errortrace.t
+  | Unbound_existential of Ident.t list * type_expr
+  | Missing_type_constraint
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+(* merlin: deep copy types in errors, to keep them meaningful after
+   backtracking *)
+let deep_copy () =
+  let table = TypeHash.create 7 in
+  let rec copy ty =
+    let ty = repr ty in
+    try TypeHash.find table ty
+    with Not_found ->
+      let ty' =
+        let {Types. level; id; desc; scope} = ty in
+        Types.Private_type_expr.create ~level ~id ~scope desc
+      in
+      TypeHash.add table ty ty';
+      let desc =
+        match ty.desc with
+        | Tvar _ | Tnil | Tunivar _ as desc -> desc
+        | Tvariant _ as desc -> (* fixme *) desc
+        | Tarrow (l,t1,t2,c) -> Tarrow (l, copy t1, copy t2, c)
+        | Ttuple tl -> Ttuple (List.map copy tl)
+        | Tconstr (p, tl, _) -> Tconstr (p, List.map copy tl, ref Mnil)
+        | Tobject (t1, r) ->
+          let r = match !r with
+            | None -> None
+            | Some (p,tl) -> Some (p, List.map copy tl)
+          in
+          Tobject (copy t1, ref r)
+        | Tfield (s,fk,t1,t2) -> Tfield (s, fk, copy t1, copy t2)
+        | Tpoly (t,tl) -> Tpoly (copy t, List.map copy tl)
+        | Tpackage (p,ltl) ->
+          Tpackage (p, List.map (fun (l, tl) -> l, copy tl) ltl)
+        | Tlink _ | Tsubst _ -> assert false
+      in
+      Types.Private_type_expr.set_desc ty' desc;
+      ty'
+  in
+  copy
+
+let trace_copy ?(copy=deep_copy ()) tr =
+  Errortrace.map_types copy tr
+
+let trace_subtype_copy ?(copy=deep_copy ()) tr =
+  Errortrace.Subtype.map_types copy tr
+
+let error (loc, env, err) =
+  let err = match err with
+    | Label_mismatch (li, trace) ->
+      Label_mismatch (li, trace_copy trace)
+    | Pattern_type_clash (trace, popt) ->
+      Pattern_type_clash (trace_copy trace, popt)
+    | Or_pattern_type_clash (i, trace) ->
+      Or_pattern_type_clash (i, trace_copy trace)
+    | Expr_type_clash (trace, ctx_opt, eopt) ->
+      Expr_type_clash (trace_copy trace, ctx_opt, eopt)
+    | Apply_non_function t ->
+      Apply_non_function (deep_copy () t)
+    | Apply_wrong_label (l, t, b) ->
+      Apply_wrong_label (l, deep_copy () t, b)
+    | Wrong_name (s1, t, wn) ->
+      Wrong_name (s1, { t with ty = deep_copy () t.ty }, wn)
+    | Undefined_method (t, s, l) ->
+      Undefined_method (deep_copy () t, s, l)
+    | Private_type t ->
+      Private_type (deep_copy () t)
+    | Private_label (li, t) ->
+      Private_label (li, deep_copy () t)
+    | Not_subtype (t1, t2) ->
+      let copy = deep_copy () in
+      Not_subtype (trace_subtype_copy ~copy t1, trace_copy ~copy t2)
+    | Coercion_failure (t1, t2, ts, b) ->
+      let copy = deep_copy () in
+      Coercion_failure (copy t1, copy t2, trace_copy ~copy ts, b)
+    | Too_many_arguments (b, t, ctx_opt) ->
+      Too_many_arguments (b, deep_copy () t, ctx_opt)
+    | Abstract_wrong_label (l, t, ctx_opt) ->
+      Abstract_wrong_label (l, deep_copy () t, ctx_opt)
+    | Scoping_let_module (s, t) ->
+      Scoping_let_module (s, deep_copy () t)
+    | Less_general (s, tr) ->
+      Less_general (s, trace_copy tr)
+    | Not_a_packed_module t ->
+      Not_a_packed_module (deep_copy () t)
+    | err -> err
+  in
+  Error (loc, env, err)
+
+(* Forward declaration, to be filled in by Typemod.type_module *)
+
+let type_module =
+  ref ((fun _env _md -> assert false) :
+       Env.t -> Parsetree.module_expr -> Typedtree.module_expr)
+
+(* Forward declaration, to be filled in by Typemod.type_open *)
+
+let type_open :
+  (?used_slot:bool ref -> override_flag -> Env.t -> Location.t ->
+   Longident.t loc -> Path.t * Env.t)
+    ref =
+  ref (fun ?used_slot:_ _ -> assert false)
+
+let type_open_decl :
+  (?used_slot:bool ref -> Env.t -> Parsetree.open_declaration
+   -> open_declaration * Types.signature * Env.t)
+    ref =
+  ref (fun ?used_slot:_ _ -> assert false)
+
+(* Forward declaration, to be filled in by Typemod.type_package *)
+
+let type_package =
+  ref (fun _ -> assert false)
+
+(* Forward declaration, to be filled in by Typeclass.class_structure *)
+let type_object =
+  ref (fun _env _s -> assert false :
+       Env.t -> Location.t -> Parsetree.class_structure ->
+         Typedtree.class_structure * Types.class_signature * string list)
+
+(*
+  Saving and outputting type information.
+  We keep these function names short, because they have to be
+  called each time we create a record of type [Typedtree.expression]
+  or [Typedtree.pattern] that will end up in the typed AST.
+*)
+let re node =
+  Cmt_format.add_saved_type (Cmt_format.Partial_expression node);
+  node
+;;
+let rp node =
+  Cmt_format.add_saved_type (Cmt_format.Partial_pattern (Value, node));
+  node
+;;
+let rcp node =
+  Cmt_format.add_saved_type (Cmt_format.Partial_pattern (Computation, node));
+  node
+;;
+
+
+(* Context for inline record arguments; see [type_ident] *)
+
+type recarg =
+  | Allowed
+  | Required
+  | Rejected
+
+
+let mk_expected ?explanation ty = { ty; explanation; }
+
+let case lhs rhs =
+  {c_lhs = lhs; c_guard = None; c_rhs = rhs}
+
+(* Typing of constants *)
+
+let type_constant = function
+    Const_int _ -> instance Predef.type_int
+  | Const_char _ -> instance Predef.type_char
+  | Const_string _ -> instance Predef.type_string
+  | Const_float _ -> instance Predef.type_float
+  | Const_int32 _ -> instance Predef.type_int32
+  | Const_int64 _ -> instance Predef.type_int64
+  | Const_nativeint _ -> instance Predef.type_nativeint
+
+let constant : Parsetree.constant -> (Asttypes.constant, error) result =
+  function
+  | Pconst_integer (i,None) ->
+     begin
+       try Ok (Const_int (Misc.Int_literal_converter.int i))
+       with Failure _ -> Error (Literal_overflow "int")
+     end
+  | Pconst_integer (i,Some 'l') ->
+     begin
+       try Ok (Const_int32 (Misc.Int_literal_converter.int32 i))
+       with Failure _ -> Error (Literal_overflow "int32")
+     end
+  | Pconst_integer (i,Some 'L') ->
+     begin
+       try Ok (Const_int64 (Misc.Int_literal_converter.int64 i))
+       with Failure _ -> Error (Literal_overflow "int64")
+     end
+  | Pconst_integer (i,Some 'n') ->
+     begin
+       try Ok (Const_nativeint (Misc.Int_literal_converter.nativeint i))
+       with Failure _ -> Error (Literal_overflow "nativeint")
+     end
+  | Pconst_integer (i,Some c) -> Error (Unknown_literal (i, c))
+  | Pconst_char c -> Ok (Const_char c)
+  | Pconst_string (s,loc,d) -> Ok (Const_string (s,loc,d))
+  | Pconst_float (f,None)-> Ok (Const_float f)
+  | Pconst_float (f,Some c) -> Error (Unknown_literal (f, c))
+
+let constant_or_raise env loc cst =
+  match constant cst with
+  | Ok c -> c
+  | Error err -> raise (error (loc, env, err))
+
+(* Specific version of type_option, using newty rather than newgenty *)
+
+let type_option ty =
+  newty (Tconstr(Predef.path_option,[ty], ref Mnil))
+
+let mkexp exp_desc exp_type exp_loc exp_env =
+  { exp_desc; exp_type; exp_loc; exp_env; exp_extra = []; exp_attributes = [] }
+
+let option_none env ty loc =
+  let lid = Longident.Lident "None" in
+  let cnone = Env.find_ident_constructor Predef.ident_none env in
+  mkexp (Texp_construct(mknoloc lid, cnone, [])) ty loc env
+
+let option_some env texp =
+  let lid = Longident.Lident "Some" in
+  let csome = Env.find_ident_constructor Predef.ident_some env in
+  mkexp ( Texp_construct(mknoloc lid , csome, [texp]) )
+    (type_option texp.exp_type) texp.exp_loc texp.exp_env
+
+let extract_option_type env ty =
+  match expand_head env ty with {desc = Tconstr(path, [ty], _)}
+    when Path.same path Predef.path_option -> ty
+  | _ -> assert false
+
+let extract_concrete_record env ty =
+  match extract_concrete_typedecl env ty with
+    (p0, p, {type_kind=Type_record (fields, _)}) -> (p0, p, fields)
+  | _ -> raise Not_found
+
+let extract_concrete_variant env ty =
+  match extract_concrete_typedecl env ty with
+    (p0, p, {type_kind=Type_variant (cstrs, _)}) -> (p0, p, cstrs)
+  | (p0, p, {type_kind=Type_open}) -> (p0, p, [])
+  | _ -> raise Not_found
+
+let extract_label_names env ty =
+  try
+    let (_, _,fields) = extract_concrete_record env ty in
+    List.map (fun l -> l.Types.ld_id) fields
+  with Not_found ->
+    assert false
+
+(* Typing of patterns *)
+
+(* unification inside type_exp and type_expect *)
+let unify_exp_types loc env ty expected_ty =
+  (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type
+    Printtyp.raw_type_expr expected_ty; *)
+  try
+    unify env ty expected_ty
+  with
+    Unify trace ->
+      raise(error(loc, env, Expr_type_clash(trace, None, None)))
+  | Tags(l1,l2) ->
+      raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2)))
+
+(* level at which to create the local type declarations *)
+let gadt_equations_level = ref None
+let get_gadt_equations_level () =
+  match !gadt_equations_level with
+    Some y -> y
+  | None -> assert false
+
+let nothing_equated = TypePairs.create 0
+
+(* unification inside type_pat*)
+let unify_pat_types_return_equated_pairs ?(refine = None) loc env ty ty' =
+  try
+    match refine with
+    | Some allow_recursive ->
+        unify_gadt ~equations_level:(get_gadt_equations_level ())
+          ~allow_recursive env ty ty'
+    | None ->
+        unify !env ty ty';
+        nothing_equated
+  with
+  | Unify trace ->
+      raise(error(loc, !env, Pattern_type_clash(trace, None)))
+  | Tags(l1,l2) ->
+      raise(Typetexp.Error(loc, !env, Typetexp.Variant_tags (l1, l2)))
+
+let unify_pat_types ?refine loc env ty ty' =
+  ignore (unify_pat_types_return_equated_pairs ?refine loc env ty ty')
+
+
+let unify_pat ?refine env pat expected_ty =
+  try unify_pat_types ?refine pat.pat_loc env pat.pat_type expected_ty
+  with Error (loc, env, Pattern_type_clash(trace, None)) ->
+    raise(Error(loc, env, Pattern_type_clash(trace, Some pat.pat_desc)))
+
+(* unification of a type with a Tconstr with freshly created arguments *)
+let unify_head_only ~refine loc env ty constr =
+  let path =
+    match (repr constr.cstr_res).desc with
+    | Tconstr(p, _, _) -> p
+    | _ -> assert false in
+  let decl = Env.find_type path !env in
+  let ty' = Ctype.newconstr path (Ctype.instance_list decl.type_params) in
+  unify_pat_types ~refine loc env ty' ty
+
+(* Creating new conjunctive types is not allowed when typing patterns *)
+(* make all Reither present in open variants *)
+let finalize_variant pat tag opat r =
+  let row =
+    match expand_head pat.pat_env pat.pat_type with
+      {desc = Tvariant row} -> r := row; row_repr row
+    | _ -> assert false
+  in
+  begin match row_field tag row with
+  | Rabsent -> () (* assert false *)
+  | Reither (true, [], _, e) when not row.row_closed ->
+      set_row_field e (Rpresent None)
+  | Reither (false, ty::tl, _, e) when not row.row_closed ->
+      set_row_field e (Rpresent (Some ty));
+      begin match opat with None -> assert false
+      | Some pat ->
+          let env = ref pat.pat_env in List.iter (unify_pat env pat) (ty::tl)
+      end
+  | Reither (c, _l, true, e) when not (row_fixed row) ->
+      set_row_field e (Reither (c, [], false, ref None))
+  | _ -> ()
+  end
+  (* Force check of well-formedness   WHY? *)
+  (* unify_pat pat.pat_env pat
+    (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false;
+                    row_bound=(); row_fixed=false; row_name=None})); *)
+
+let has_variants p =
+  exists_general_pattern
+    { f = fun (type k) (p : k general_pattern) -> match p.pat_desc with
+     | (Tpat_variant _) -> true
+     | _ -> false } p
+
+let finalize_variants p =
+  iter_general_pattern
+    { f = fun (type k) (p : k general_pattern) -> match p.pat_desc with
+     | Tpat_variant(tag, opat, r) ->
+        finalize_variant p tag opat r
+     | _ -> () } p
+
+(* pattern environment *)
+type pattern_variable =
+  {
+    pv_id: Ident.t;
+    pv_type: type_expr;
+    pv_loc: Location.t;
+    pv_as_var: bool;
+    pv_attributes: attributes;
+  }
+
+type module_variable =
+  string loc * Location.t
+
+let pattern_variables = ref ([] : pattern_variable list)
+let pattern_force = ref ([] : (unit -> unit) list)
+let allow_modules = ref false
+let module_variables = ref ([] : module_variable list)
+let reset_pattern allow =
+  pattern_variables := [];
+  pattern_force := [];
+  allow_modules := allow;
+  module_variables := [];
+;;
+
+let maybe_add_pattern_variables_ghost loc_let env pv =
+  List.fold_right
+    (fun {pv_id; _} env ->
+       let name = Ident.name pv_id in
+       if Env.bound_value name env then env
+       else begin
+         Env.enter_unbound_value name
+           (Val_unbound_ghost_recursive loc_let) env
+       end
+    ) pv env
+
+let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty
+    attrs =
+  if List.exists (fun {pv_id; _} -> Ident.name pv_id = name.txt)
+      !pattern_variables
+  then raise(error(loc, Env.empty, Multiply_bound_variable name.txt));
+  let id = Ident.create_local name.txt in
+  pattern_variables :=
+    {pv_id = id;
+     pv_type = ty;
+     pv_loc = loc;
+     pv_as_var = is_as_variable;
+     pv_attributes = attrs} :: !pattern_variables;
+  if is_module then begin
+    (* Note: unpack patterns enter a variable of the same name *)
+    if not !allow_modules then
+      raise (error (loc, Env.empty, Modules_not_allowed));
+    module_variables := (name, loc) :: !module_variables
+  end;
+  id
+
+let sort_pattern_variables vs =
+  List.sort
+    (fun {pv_id = x; _} {pv_id = y; _} ->
+      Stdlib.compare (Ident.name x) (Ident.name y))
+    vs
+
+let enter_orpat_variables loc env  p1_vs p2_vs =
+  (* unify_vars operate on sorted lists *)
+
+  let p1_vs = sort_pattern_variables p1_vs
+  and p2_vs = sort_pattern_variables p2_vs in
+
+  let rec unify_vars p1_vs p2_vs =
+    let vars vs = List.map (fun {pv_id; _} -> pv_id) vs in
+    match p1_vs, p2_vs with
+      | {pv_id = x1; pv_type = t1; _}::rem1, {pv_id = x2; pv_type = t2; _}::rem2
+        when Ident.equal x1 x2 ->
+          if x1==x2 then
+            unify_vars rem1 rem2
+          else begin
+            begin try
+              unify_var env (newvar ()) t1;
+              unify env t1 t2
+            with
+            | Unify trace ->
+                raise(error(loc, env, Or_pattern_type_clash(x1, trace)))
+            end;
+          (x2,x1)::unify_vars rem1 rem2
+          end
+      | [],[] -> []
+      | {pv_id; _}::_, [] | [],{pv_id; _}::_ ->
+          raise (error (loc, env, Orpat_vars (pv_id, [])))
+      | {pv_id = x; _}::_, {pv_id = y; _}::_ ->
+          let err =
+            if Ident.name x < Ident.name y
+            then Orpat_vars (x, vars p2_vs)
+            else Orpat_vars (y, vars p1_vs) in
+          raise (error (loc, env, err)) in
+  unify_vars p1_vs p2_vs
+
+let rec build_as_type env p =
+  let as_ty = build_as_type_aux env p in
+  (* Cf. #1655 *)
+  List.fold_left (fun as_ty (extra, _loc, _attrs) ->
+    match extra with
+    | Tpat_type _ | Tpat_open _ | Tpat_unpack -> as_ty
+    | Tpat_constraint cty ->
+      (* [generic_instance] can only be used if the variables of the original
+         type ([cty.ctyp_type] here) are not at [generic_level], which they are
+         here.
+         If we used [generic_instance] we would lose the sharing between
+         [instance ty] and [ty].  *)
+      begin_def ();
+      let ty = instance cty.ctyp_type in
+      end_def ();
+      generalize_structure ty;
+      (* This call to unify can't fail since the pattern is well typed. *)
+      unify !env (instance as_ty) (instance ty);
+      ty
+  ) as_ty p.pat_extra
+
+and build_as_type_aux env p =
+  match p.pat_desc with
+    Tpat_alias(p1,_, _) -> build_as_type env p1
+  | Tpat_tuple pl ->
+      let tyl = List.map (build_as_type env) pl in
+      newty (Ttuple tyl)
+  | Tpat_construct(_, cstr, pl, vto) ->
+      let keep =
+        cstr.cstr_private = Private || cstr.cstr_existentials <> [] ||
+        vto <> None (* be lazy and keep the type for node constraints *) in
+      if keep then p.pat_type else
+      let tyl = List.map (build_as_type env) pl in
+      let ty_args, ty_res, _ = instance_constructor cstr in
+      List.iter2 (fun (p,ty) -> unify_pat env {p with pat_type = ty})
+        (List.combine pl tyl) ty_args;
+      ty_res
+  | Tpat_variant(l, p', _) ->
+      let ty = Option.map (build_as_type env) p' in
+      newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar();
+                      row_bound=(); row_name=None;
+                      row_fixed=None; row_closed=false})
+  | Tpat_record (lpl,_) ->
+      let lbl = snd3 (List.hd lpl) in
+      if lbl.lbl_private = Private then p.pat_type else
+      let ty = newvar () in
+      let ppl = List.map (fun (_, l, p) -> l.lbl_pos, p) lpl in
+      let do_label lbl =
+        let _, ty_arg, ty_res = instance_label false lbl in
+        unify_pat env {p with pat_type = ty} ty_res;
+        let refinable =
+          lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl &&
+          match (repr lbl.lbl_arg).desc with Tpoly _ -> false | _ -> true in
+        if refinable then begin
+          let arg = List.assoc lbl.lbl_pos ppl in
+          unify_pat env {arg with pat_type = build_as_type env arg} ty_arg
+        end else begin
+          let _, ty_arg', ty_res' = instance_label false lbl in
+          unify !env ty_arg ty_arg';
+          unify_pat env p ty_res'
+        end in
+      Array.iter do_label lbl.lbl_all;
+      ty
+  | Tpat_or(p1, p2, row) ->
+      begin match row with
+        None ->
+          let ty1 = build_as_type env p1 and ty2 = build_as_type env p2 in
+          unify_pat env {p2 with pat_type = ty2} ty1;
+          ty1
+      | Some row ->
+          let row = row_repr row in
+          newty (Tvariant{row with row_closed=false; row_more=newvar()})
+      end
+  | Tpat_any | Tpat_var _ | Tpat_constant _
+  | Tpat_array _ | Tpat_lazy _ -> p.pat_type
+
+(* Constraint solving during typing of patterns *)
+
+let solve_Ppat_poly_constraint ~refine env loc sty expected_ty =
+  let cty, ty, force = Typetexp.transl_simple_type_delayed !env sty in
+  unify_pat_types ~refine loc env ty (instance expected_ty);
+  pattern_force := force :: !pattern_force;
+  match ty.desc with
+  | Tpoly (body, tyl) ->
+      begin_def ();
+      init_def generic_level;
+      let _, ty' = instance_poly ~keep_names:true false tyl body in
+      end_def ();
+      (cty, ty, ty')
+  | _ -> assert false
+
+let solve_Ppat_alias env pat =
+  begin_def ();
+  let ty_var = build_as_type env pat in
+  end_def ();
+  generalize ty_var;
+  ty_var
+
+let solve_Ppat_tuple (type a) ~refine loc env (args : a list) expected_ty =
+  let vars = List.map (fun _ -> newgenvar ()) args in
+  let ty = newgenty (Ttuple vars) in
+  let expected_ty = generic_instance expected_ty in
+  unify_pat_types ~refine loc env ty expected_ty;
+  vars
+
+let solve_constructor_annotation env name_list sty ty_args ty_ex =
+  let expansion_scope = get_gadt_equations_level () in
+  let ids =
+    List.map
+      (fun name ->
+        let decl = new_local_type ~loc:name.loc () in
+        let (id, new_env) =
+          Env.enter_type ~scope:expansion_scope name.txt decl !env in
+        env := new_env;
+        {name with txt = id})
+      name_list
+  in
+  begin_def ();
+  let cty, ty, force = Typetexp.transl_simple_type_delayed !env sty in
+  end_def ();
+  generalize_structure ty;
+  pattern_force := force :: !pattern_force;
+  let ty_args =
+    let ty1 = instance ty and ty2 = instance ty in
+    match ty_args with
+      [] -> assert false
+    | [ty_arg] ->
+        unify_pat_types cty.ctyp_loc env ty1 ty_arg;
+        [ty2]
+    | _ ->
+        unify_pat_types cty.ctyp_loc env ty1 (newty (Ttuple ty_args));
+        match repr (expand_head !env ty2) with
+          {desc = Ttuple tyl} -> tyl
+        | _ -> assert false
+  in
+  if ids <> [] then ignore begin
+    let ids = List.map (fun x -> x.txt) ids in
+    let rem =
+      List.fold_left
+        (fun rem tv ->
+          match repr tv with
+            {desc = Tconstr(Path.Pident id, [], _)}
+            when List.mem id rem ->
+              list_remove id rem
+          | _ ->
+              raise (Error (cty.ctyp_loc, !env,
+                            Unbound_existential (ids, ty))))
+        ids ty_ex
+    in
+    if rem <> [] then
+      raise (Error (cty.ctyp_loc, !env,
+                    Unbound_existential (ids, ty)))
+  end;
+  ty_args, Some (ids, cty)
+
+let solve_Ppat_construct ~refine env loc constr no_existentials
+        existential_styp expected_ty =
+  (* if constructor is gadt, we must verify that the expected type has the
+     correct head *)
+  if constr.cstr_generalized then
+    unify_head_only ~refine loc env (instance expected_ty) constr;
+  begin_def ();
+  let expected_ty = instance expected_ty in
+  (* PR#7214: do not use gadt unification for toplevel lets *)
+  let unify_res ty_res =
+    let refine =
+      match refine, no_existentials with
+      | None, None when constr.cstr_generalized -> Some false
+      | _ -> refine
+    in
+    unify_pat_types_return_equated_pairs ~refine loc env ty_res expected_ty
+  in
+  let expansion_scope = get_gadt_equations_level () in
+  let ty_args, ty_res, equated_types, existential_ctyp =
+    match existential_styp with
+      None ->
+        let ty_args, ty_res, _ =
+          instance_constructor ~in_pattern:(env, expansion_scope) constr in
+        ty_args, ty_res, unify_res ty_res, None
+    | Some (name_list, sty) ->
+        let in_pattern =
+          if name_list = [] then Some (env, expansion_scope) else None in
+        let ty_args, ty_res, ty_ex =
+          instance_constructor ?in_pattern constr in
+        let equated_types = unify_res ty_res in
+        let ty_args, existential_ctyp =
+          solve_constructor_annotation env name_list sty ty_args ty_ex in
+        ty_args, ty_res, equated_types, existential_ctyp
+  in
+  end_def ();
+  generalize_structure expected_ty;
+  generalize_structure ty_res;
+  List.iter generalize_structure ty_args;
+  if !Clflags.principal then begin
+    let exception Warn_only_once in
+    try
+      TypePairs.iter
+        (fun (t1, t2) () ->
+          generalize_structure t1;
+          generalize_structure t2;
+          if not (fully_generic t1 && fully_generic t2) then
+            let msg =
+              Format.asprintf
+                "typing this pattern requires considering@ %a@ and@ %a@ as \
+                equal.@,\
+                But the knowledge of these types"
+                    Printtyp.type_expr t1
+                    Printtyp.type_expr t2
+            in
+            Location.prerr_warning loc (Warnings.Not_principal msg);
+            raise Warn_only_once)
+        equated_types
+    with Warn_only_once -> ()
+  end;
+  (ty_args, existential_ctyp)
+
+let solve_Ppat_record_field ~refine loc env label label_lid record_ty =
+  begin_def ();
+  let (_, ty_arg, ty_res) = instance_label false label in
+  begin try
+    unify_pat_types ~refine loc env ty_res (instance record_ty)
+  with Error(_loc, _env, Pattern_type_clash(trace, _)) ->
+    raise(error(label_lid.loc, !env,
+                Label_mismatch(label_lid.txt, trace)))
+  end;
+  end_def ();
+  generalize_structure ty_res;
+  generalize_structure ty_arg;
+  ty_arg
+
+let solve_Ppat_array ~refine loc env expected_ty =
+  let ty_elt = newgenvar() in
+  let expected_ty = generic_instance expected_ty in
+  unify_pat_types ~refine
+    loc env (Predef.type_array ty_elt) expected_ty;
+  ty_elt
+
+let solve_Ppat_lazy  ~refine loc env expected_ty =
+  let nv = newgenvar () in
+  unify_pat_types ~refine loc env (Predef.type_lazy_t nv)
+    (generic_instance expected_ty);
+  nv
+
+let solve_Ppat_constraint ~refine loc env sty expected_ty =
+  begin_def();
+  let cty, ty, force = Typetexp.transl_simple_type_delayed !env sty in
+  end_def();
+  pattern_force := force :: !pattern_force;
+  generalize_structure ty;
+  let ty, expected_ty' = instance ty, ty in
+  unify_pat_types ~refine loc env ty (instance expected_ty);
+  (cty, ty, expected_ty')
+
+let solve_Ppat_variant ~refine loc env tag constant expected_ty =
+  let arg_type = if constant then [] else [newgenvar()] in
+  let row = { row_fields =
+              [tag, Reither(constant, arg_type, true, ref None)];
+              row_bound = ();
+              row_closed = false;
+              row_more = newgenvar ();
+              row_fixed = None;
+              row_name = None } in
+  let expected_ty = generic_instance expected_ty in
+  (* PR#7404: allow some_private_tag blindly, as it would not unify with
+     the abstract row variable *)
+  if tag <> Parmatch.some_private_tag then
+    unify_pat_types ~refine loc env (newgenty(Tvariant row)) expected_ty;
+  (arg_type, row, instance expected_ty)
+
+(* Building the or-pattern corresponding to a polymorphic variant type *)
+let build_or_pat env loc lid =
+  let path, decl = Env.lookup_type ~loc:lid.loc lid.txt env in
+  let tyl = List.map (fun _ -> newvar()) decl.type_params in
+  let row0 =
+    let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in
+    match ty.desc with
+      Tvariant row when static_row row -> row
+    | _ -> raise(error(lid.loc, env, Not_a_variant_type lid.txt))
+  in
+  let pats, fields =
+    List.fold_left
+      (fun (pats,fields) (l,f) ->
+        match row_field_repr f with
+          Rpresent None ->
+            (l,None) :: pats,
+            (l, Reither(true,[], true, ref None)) :: fields
+        | Rpresent (Some ty) ->
+            (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env;
+                      pat_type=ty; pat_extra=[]; pat_attributes=[]})
+            :: pats,
+            (l, Reither(false, [ty], true, ref None)) :: fields
+        | _ -> pats, fields)
+      ([],[]) (row_repr row0).row_fields in
+  let row =
+    { row_fields = List.rev fields; row_more = newvar(); row_bound = ();
+      row_closed = false; row_fixed = None; row_name = Some (path, tyl) }
+  in
+  let ty = newty (Tvariant row) in
+  let gloc = {loc with Location.loc_ghost=true} in
+  let row' = ref {row with row_more=newvar()} in
+  let pats =
+    List.map
+      (fun (l,p) ->
+        {pat_desc=Tpat_variant(l,p,row'); pat_loc=gloc;
+         pat_env=env; pat_type=ty; pat_extra=[]; pat_attributes=[]})
+      pats
+  in
+  match pats with
+    [] ->
+      (* empty polymorphic variants: not possible with the concrete language
+         but valid at the ast level *)
+      raise(error(lid.loc, env, Not_a_variant_type lid.txt))
+  | pat :: pats ->
+      let r =
+        List.fold_left
+          (fun pat pat0 ->
+            {pat_desc=Tpat_or(pat0,pat,Some row0); pat_extra=[];
+             pat_loc=gloc; pat_env=env; pat_type=ty; pat_attributes=[]})
+          pat pats in
+      (path, rp { r with pat_loc = loc })
+
+let split_cases env cases =
+  let add_case lst case = function
+    | None -> lst
+    | Some c_lhs -> { case with c_lhs } :: lst
+  in
+  List.fold_right (fun ({ c_lhs; c_guard } as case) (vals, exns) ->
+    match split_pattern c_lhs with
+    | Some _, Some _ when c_guard <> None ->
+      raise (error (c_lhs.pat_loc, env,
+                    Mixed_value_and_exception_patterns_under_guard))
+    | vp, ep -> add_case vals case vp, add_case exns case ep
+  ) cases ([], [])
+
+(* Type paths *)
+
+let rec expand_path env p =
+  let decl =
+    try Some (Env.find_type p env) with Not_found -> None
+  in
+  match decl with
+    Some {type_manifest = Some ty} ->
+      begin match repr ty with
+        {desc=Tconstr(p,_,_)} -> expand_path env p
+      | _ -> assert false
+      end
+  | _ ->
+      let p' = Env.normalize_type_path None env p in
+      if Path.same p p' then p else expand_path env p'
+
+let compare_type_path env tpath1 tpath2 =
+  Path.same (expand_path env tpath1) (expand_path env tpath2)
+
+(* Records *)
+exception Wrong_name_disambiguation of Env.t * wrong_name
+
+let get_constr_type_path ty =
+  match (repr ty).desc with
+  | Tconstr(p, _, _) -> p
+  | _ -> assert false
+
+module NameChoice(Name : sig
+  type t
+  type usage
+  val kind: Datatype_kind.t
+  val get_name: t -> string
+  val get_type: t -> type_expr
+  val lookup_all_from_type:
+    Location.t -> usage -> Path.t -> Env.t -> (t * (unit -> unit)) list
+
+  (** Some names (for example the fields of inline records) are not
+      in the typing environment -- they behave as structural labels
+      rather than nominal labels.*)
+  val in_env: t -> bool
+end) = struct
+  open Name
+
+  let get_type_path d = get_constr_type_path (get_type d)
+
+  let lookup_from_type env type_path usage lid =
+    let descrs = lookup_all_from_type lid.loc usage type_path env in
+    match lid.txt with
+    | Longident.Lident name -> begin
+        match
+          List.find (fun (nd, _) -> get_name nd = name) descrs
+        with
+        | descr, use ->
+            use ();
+            descr
+        | exception Not_found ->
+            let valid_names = List.map (fun (nd, _) -> get_name nd) descrs in
+            raise (Wrong_name_disambiguation (env, {
+                    type_path;
+                    name = { lid with txt = name };
+                    kind;
+                    valid_names;
+              }))
+      end
+    | _ -> raise Not_found
+
+  let rec unique eq acc = function
+      [] -> List.rev acc
+    | x :: rem ->
+        if List.exists (eq x) acc then unique eq acc rem
+        else unique eq (x :: acc) rem
+
+  let ambiguous_types env lbl others =
+    let tpath = get_type_path lbl in
+    let others =
+      List.map (fun (lbl, _) -> get_type_path lbl) others in
+    let tpaths = unique (compare_type_path env) [tpath] others in
+    match tpaths with
+      [_] -> []
+    | _ -> let open Printtyp in
+        wrap_printing_env ~error:true env (fun () ->
+            reset(); strings_of_paths Type tpaths)
+
+  let disambiguate_by_type env tpath lbls =
+    match lbls with
+    | (Error _ : _ result) -> raise Not_found
+    | Ok lbls ->
+        let check_type (lbl, _) =
+          let lbl_tpath = get_type_path lbl in
+          compare_type_path env tpath lbl_tpath
+        in
+        List.find check_type lbls
+
+  (* warn if there are several distinct candidates in scope *)
+  let warn_if_ambiguous warn lid env lbl rest =
+    Printtyp.Conflicts.reset ();
+    let paths = ambiguous_types env lbl rest in
+    let expansion =
+      Format.asprintf "%t" Printtyp.Conflicts.print_explanations in
+    if paths <> [] then
+      warn lid.loc
+        (Warnings.Ambiguous_name ([Longident.last lid.txt],
+                                  paths, false, expansion))
+
+  (* a non-principal type was used for disambiguation *)
+  let warn_non_principal warn lid =
+    let name = Datatype_kind.label_name kind in
+    warn lid.loc
+      (Warnings.Not_principal
+         ("this type-based " ^ name ^ " disambiguation"))
+
+  (* we selected a name out of the lexical scope *)
+  let warn_out_of_scope warn lid env tpath =
+    let path_s =
+      Printtyp.wrap_printing_env ~error:true env
+        (fun () -> Printtyp.string_of_path tpath) in
+    warn lid.loc
+      (Warnings.Name_out_of_scope (path_s, [Longident.last lid.txt], false))
+
+  (* warn if the selected name is not the last introduced in scope
+     -- in these cases the resolution is different from pre-disambiguation OCaml
+     (this warning is not enabled by default, it is specifically for people
+      wishing to write backward-compatible code).
+   *)
+  let warn_if_disambiguated_name warn lid lbl scope =
+    match scope with
+    | Ok ((lab1,_) :: _) when lab1 == lbl -> ()
+    | _ ->
+        warn lid.loc
+          (Warnings.Disambiguated_name (get_name lbl))
+
+  let force_error : ('a, _) result -> 'a = function
+    | Ok lbls -> lbls
+    | Error (loc', env', err) ->
+       Env.lookup_error loc' env' err
+
+  type candidate = t * (unit -> unit)
+  type nonempty_candidate_filter =
+    candidate list -> (candidate list, candidate list) result
+  (** This type is used for candidate filtering functions.
+      Filtering typically proceeds in several passes, filtering
+      candidates through increasingly precise conditions.
+
+      We assume that the input list is non-empty, and the output is one of
+      - [Ok result] for a non-empty list [result] of valid candidates
+      - [Error candidates] with there are no valid candidates,
+        and [candidates] is a non-empty subset of the input, typically
+        the result of the last non-empty filtering step.
+   *)
+
+  (** [disambiguate] selects a concrete description for [lid] using
+     some contextual information:
+     - An optional [expected_type].
+     - A list of candidates labels in the current lexical scope,
+       [candidates_in_scope], that is actually at the type
+       [(label_descr list, lookup_error) result] so that the
+       lookup error is only raised when necessary.
+     - A filtering criterion on candidates in scope [filter_candidates],
+       representing extra contextual information that can help
+       candidate selection (see [disambiguate_label_by_ids]).
+   *)
+  let disambiguate
+        ?(warn=Location.prerr_warning)
+        ?(filter : nonempty_candidate_filter = Result.ok)
+        usage lid env
+        expected_type
+        candidates_in_scope =
+    let lbl = match expected_type with
+    | None ->
+        (* no expected type => no disambiguation *)
+        begin match filter (force_error candidates_in_scope) with
+        | Ok [] | Error [] -> assert false
+        | Error((lbl, _use) :: _rest) -> lbl (* will fail later *)
+        | Ok((lbl, use) :: rest) ->
+            use ();
+            warn_if_ambiguous warn lid env lbl rest;
+            lbl
+        end
+    | Some(tpath0, tpath, principal) ->
+       (* If [expected_type] is available, the candidate selected
+          will correspond to the type-based resolution.
+          There are two reasons to still check the lexical scope:
+          - for warning purposes
+          - for extension types, the type environment does not contain
+            a list of constructors, so using only type-based selection
+            would fail.
+        *)
+        (* note that [disambiguate_by_type] does not
+           force [candidates_in_scope]: we just skip this case if there
+           are no candidates in scope *)
+        begin match disambiguate_by_type env tpath candidates_in_scope with
+        | lbl, use ->
+          use ();
+          if not principal then begin
+            (* Check if non-principal type is affecting result *)
+            match (candidates_in_scope : _ result) with
+            | Error _ -> warn_non_principal warn lid
+            | Ok lbls ->
+            match filter lbls with
+            | Error _ -> warn_non_principal warn lid
+            | Ok [] -> assert false
+            | Ok ((lbl', _use') :: rest) ->
+            let lbl_tpath = get_type_path lbl' in
+            (* no principality warning if the non-principal
+               type-based selection corresponds to the last
+               definition in scope *)
+            if not (compare_type_path env tpath lbl_tpath)
+            then warn_non_principal warn lid
+            else warn_if_ambiguous warn lid env lbl rest;
+          end;
+          lbl
+        | exception Not_found ->
+        (* look outside the lexical scope *)
+        match lookup_from_type env tpath usage lid with
+        | lbl ->
+          (* warn only on nominal labels;
+             structural labels cannot be qualified anyway *)
+          if in_env lbl then warn_out_of_scope warn lid env tpath;
+          if not principal then warn_non_principal warn lid;
+          lbl
+        | exception Not_found ->
+        match filter (force_error candidates_in_scope) with
+        | Ok lbls | Error lbls ->
+        let tp = (tpath0, expand_path env tpath) in
+        let tpl =
+          List.map
+            (fun (lbl, _) ->
+               let tp0 = get_type_path lbl in
+               let tp = expand_path env tp0 in
+               (tp0, tp))
+            lbls
+        in
+        raise (error (lid.loc, env,
+                      Name_type_mismatch (kind, lid.txt, tp, tpl)));
+        end
+    in
+    (* warn only on nominal labels *)
+    if in_env lbl then
+      warn_if_disambiguated_name warn lid lbl candidates_in_scope;
+    lbl
+end
+
+let wrap_disambiguate msg ty f x =
+  try f x with
+  | Wrong_name_disambiguation (env, wrong_name) ->
+    raise (error (wrong_name.name.loc, env, Wrong_name (msg, ty, wrong_name)))
+
+module Label = NameChoice (struct
+  type t = label_description
+  type usage = Env.label_usage
+  let kind = Datatype_kind.Record
+  let get_name lbl = lbl.lbl_name
+  let get_type lbl = lbl.lbl_res
+  let lookup_all_from_type loc usage path env =
+    Env.lookup_all_labels_from_type ~loc usage path env
+  let in_env lbl =
+    match lbl.lbl_repres with
+    | Record_regular | Record_float | Record_unboxed false -> true
+    | Record_unboxed true | Record_inlined _ | Record_extension _ -> false
+end)
+
+(* In record-construction expressions and patterns, we have many labels
+   at once; find a candidate type in the intersection of the candidates
+   of each label. In the [closed] expression case, this candidate must
+   contain exactly all the labels.
+
+   If our successive refinements result in an empty list,
+   return [Error] with the last non-empty list of candidates
+   for use in error messages.
+*)
+let disambiguate_label_by_ids closed ids labels  : (_, _) result =
+  let check_ids (lbl, _) =
+    let lbls = Hashtbl.create 8 in
+    Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl.lbl_all;
+    List.for_all (Hashtbl.mem lbls) ids
+  and check_closed (lbl, _) =
+    (not closed || List.length ids = Array.length lbl.lbl_all)
+  in
+  match List.filter check_ids labels with
+  | [] -> Error labels
+  | labels ->
+  match List.filter check_closed labels with
+  | [] -> Error labels
+  | labels ->
+  Ok labels
+
+(* Only issue warnings once per record constructor/pattern *)
+let disambiguate_lid_a_list loc closed env usage expected_type lid_a_list =
+  let ids = List.map (fun (lid, _) -> Longident.last lid.txt) lid_a_list in
+  let w_pr = ref false and w_amb = ref []
+  and w_scope = ref [] and w_scope_ty = ref "" in
+  let warn loc msg =
+    let open Warnings in
+    match msg with
+    | Not_principal _ -> w_pr := true
+    | Ambiguous_name([s], l, _, ex) -> w_amb := (s, l, ex) :: !w_amb
+    | Name_out_of_scope(ty, [s], _) ->
+        w_scope := s :: !w_scope; w_scope_ty := ty
+    | _ -> Location.prerr_warning loc msg
+  in
+  let process_label lid =
+    let scope = Env.lookup_all_labels ~loc:lid.loc usage lid.txt env in
+    let filter : Label.nonempty_candidate_filter =
+      disambiguate_label_by_ids closed ids in
+    Label.disambiguate ~warn ~filter usage lid env expected_type scope in
+  let lbl_a_list =
+    List.map (fun (lid,a) -> lid, process_label lid, a) lid_a_list in
+  if !w_pr then
+    Location.prerr_warning loc
+      (Warnings.Not_principal "this type-based record disambiguation")
+  else begin
+    match List.rev !w_amb with
+      (_,types,ex)::_ as amb ->
+        let paths =
+          List.map (fun (_,lbl,_) -> Label.get_type_path lbl) lbl_a_list in
+        let path = List.hd paths in
+        let fst3 (x,_,_) = x in
+        if List.for_all (compare_type_path env path) (List.tl paths) then
+          Location.prerr_warning loc
+            (Warnings.Ambiguous_name (List.map fst3 amb, types, true, ex))
+        else
+          List.iter
+            (fun (s,l,ex) -> Location.prerr_warning loc
+                (Warnings.Ambiguous_name ([s],l,false, ex)))
+            amb
+    | _ -> ()
+  end;
+  if !w_scope <> [] then
+    Location.prerr_warning loc
+      (Warnings.Name_out_of_scope (!w_scope_ty, List.rev !w_scope, true));
+  lbl_a_list
+
+let rec find_record_qual = function
+  | [] -> None
+  | ({ txt = Longident.Ldot (modname, _) }, _) :: _ -> Some modname
+  | _ :: rest -> find_record_qual rest
+
+let map_fold_cont f xs k =
+  List.fold_right (fun x k ys -> f x (fun y -> k (y :: ys)))
+    xs (fun ys -> k (List.rev ys)) []
+
+let type_label_a_list
+      ?labels loc closed env usage type_lbl_a expected_type lid_a_list k =
+  let lbl_a_list =
+    match lid_a_list, labels with
+      ({txt=Longident.Lident s}, _)::_, Some labels when Hashtbl.mem labels s ->
+        (* Special case for rebuilt syntax trees *)
+        List.map
+          (function lid, a -> match lid.txt with
+            Longident.Lident s -> lid, Hashtbl.find labels s, a
+          | _ -> assert false)
+          lid_a_list
+    | _ ->
+        let lid_a_list =
+          match find_record_qual lid_a_list with
+            None -> lid_a_list
+          | Some modname ->
+              List.map
+                (fun (lid, a as lid_a) ->
+                  match lid.txt with Longident.Lident s ->
+                    {lid with txt=Longident.Ldot (modname, s)}, a
+                  | _ -> lid_a)
+                lid_a_list
+        in
+        disambiguate_lid_a_list loc closed env usage expected_type lid_a_list
+  in
+  (* Invariant: records are sorted in the typed tree *)
+  let lbl_a_list =
+    List.sort
+      (fun (_,lbl1,_) (_,lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos)
+      lbl_a_list
+  in
+  map_fold_cont type_lbl_a lbl_a_list k
+;;
+
+(* Checks over the labels mentioned in a record pattern:
+   no duplicate definitions (error); properly closed (warning) *)
+
+let check_recordpat_labels loc lbl_pat_list closed =
+  match lbl_pat_list with
+  | [] -> ()                            (* should not happen *)
+  | (_, label1, _) :: _ ->
+      let all = label1.lbl_all in
+      let defined = Array.make (Array.length all) false in
+      let check_defined (_, label, _) =
+        if defined.(label.lbl_pos)
+        then raise(error(loc, Env.empty, Label_multiply_defined label.lbl_name))
+        else defined.(label.lbl_pos) <- true in
+      List.iter check_defined lbl_pat_list;
+      if closed = Closed
+      && Warnings.is_active (Warnings.Missing_record_field_pattern "")
+      then begin
+        let undefined = ref [] in
+        for i = 0 to Array.length all - 1 do
+          if not defined.(i) then undefined := all.(i).lbl_name :: !undefined
+        done;
+        if !undefined <> [] then begin
+          let u = String.concat ", " (List.rev !undefined) in
+          Location.prerr_warning loc (Warnings.Missing_record_field_pattern u)
+        end
+      end
+
+(* Constructors *)
+
+module Constructor = NameChoice (struct
+  type t = constructor_description
+  type usage = Env.constructor_usage
+  let kind = Datatype_kind.Variant
+  let get_name cstr = cstr.cstr_name
+  let get_type cstr = cstr.cstr_res
+  let lookup_all_from_type loc usage path env =
+    match Env.lookup_all_constructors_from_type ~loc usage path env with
+    | _ :: _ as x -> x
+    | [] ->
+        match (Env.find_type path env).type_kind with
+        | Type_open ->
+            (* Extension constructors cannot be found by looking at the type
+               declaration.
+               We scan the whole environment to get an accurate spellchecking
+               hint in the subsequent error message *)
+            let filter lbl =
+              compare_type_path env
+                path (get_constr_type_path @@ get_type lbl) in
+            let add_valid x acc = if filter x then (x,ignore)::acc else acc in
+            Env.fold_constructors add_valid None env []
+        | _ -> []
+  let in_env _ = true
+end)
+
+(* Typing of patterns *)
+
+(* "half typed" cases are produced in [type_cases] when we've just typechecked
+   the pattern but haven't type-checked the body yet.
+   At this point we might have added some type equalities to the environment,
+   but haven't yet added identifiers bound by the pattern. *)
+type 'case_pattern half_typed_case =
+  { typed_pat: 'case_pattern;
+    pat_type_for_unif: type_expr;
+    untyped_case: Parsetree.case;
+    branch_env: Env.t;
+    pat_vars: pattern_variable list;
+    unpacks: module_variable list;
+    contains_gadt: bool; }
+
+let rec has_literal_pattern p = match p.ppat_desc with
+  | Ppat_constant _
+  | Ppat_interval _ ->
+     true
+  | Ppat_any
+  | Ppat_variant (_, None)
+  | Ppat_construct (_, None)
+  | Ppat_type _
+  | Ppat_var _
+  | Ppat_unpack _
+  | Ppat_extension _ ->
+     false
+  | Ppat_exception p
+  | Ppat_variant (_, Some p)
+  | Ppat_construct (_, Some (_, p))
+  | Ppat_constraint (p, _)
+  | Ppat_alias (p, _)
+  | Ppat_lazy p
+  | Ppat_open (_, p) ->
+     has_literal_pattern p
+  | Ppat_tuple ps
+  | Ppat_array ps ->
+     List.exists has_literal_pattern ps
+  | Ppat_record (ps, _) ->
+     List.exists (fun (_,p) -> has_literal_pattern p) ps
+  | Ppat_or (p, q) ->
+     has_literal_pattern p || has_literal_pattern q
+
+let check_scope_escape loc env level ty =
+  try Ctype.check_scope_escape env level ty
+  with Escape trace ->
+    raise(error(loc, env, Pattern_type_clash([Escape trace], None)))
+
+type pattern_checking_mode =
+  | Normal
+  (** We are checking user code. *)
+  | Counter_example of counter_example_checking_info
+  (** In [Counter_example] mode, we are checking a counter-example
+      candidate produced by Parmatch. This is a syntactic pattern that
+      represents a set of values by using or-patterns (p_1 | ... | p_n)
+      to enumerate all alternatives in the counter-example
+      search. These or-patterns occur at every choice point, possibly
+      deep inside the pattern.
+
+      Parmatch does not use type information, so this pattern may
+      exhibit two issues:
+      - some parts of the pattern may be ill-typed due to GADTs, and
+      - some wildcard patterns may not match any values: their type is
+        empty.
+
+      The aim of [type_pat] in the [Counter_example] mode is to refine
+      this syntactic pattern into a well-typed pattern, and ensure
+      that it matches at least one concrete value.
+      - It filters ill-typed branches of or-patterns.
+        (see {!splitting_mode} below)
+      - It tries to check that wildcard patterns are non-empty.
+        (see {!explosion_fuel})
+  *)
+
+and counter_example_checking_info = {
+    explosion_fuel: int;
+    splitting_mode: splitting_mode;
+    constrs: (string, Types.constructor_description) Hashtbl.t;
+    labels: (string, Types.label_description) Hashtbl.t;
+  }
+(**
+    [explosion_fuel] controls the checking of wildcard patterns.  We
+    eliminate potentially-empty wildcard patterns by exploding them
+    into concrete sub-patterns, for example (K1 _ | K2 _) or
+    { l1: _; l2: _ }. [explosion_fuel] is the depth limit on wildcard
+    explosion. Such depth limit is required to avoid non-termination
+    and compilation-time blowups.
+
+    [splitting_mode] controls the handling of or-patterns.  In
+    [Counter_example] mode, we only need to select one branch that
+    leads to a well-typed pattern. Checking all branches is expensive,
+    we use different search strategies (see {!splitting_mode}) to
+    reduce the number of explored alternatives.
+
+    [constrs] and [labels] contain metadata produced by [Parmatch] to
+    type-check the given syntactic pattern. [Parmatch] produces
+    counter-examples by turning typed patterns into
+    [Parsetree.pattern]. In this process, constructor and label paths
+    are lost, and are replaced by generated strings. [constrs] and
+    [labels] map those synthetic names back to the typed descriptions
+    of the original names.
+ *)
+
+(** Due to GADT constraints, an or-pattern produced within
+    a counter-example may have ill-typed branches. Consider for example
+
+    {[
+      type _ tag = Int : int tag | Bool : bool tag
+    ]}
+
+    then [Parmatch] will propose the or-pattern [Int | Bool] whenever
+    a pattern of type [tag] is required to form a counter-example. For
+    example, a function expects a (int tag option) and only [None] is
+    handled by the user-written pattern. [Some (Int | Bool)] is not
+    well-typed in this context, only the sub-pattern [Some Int] is.
+    In this example, the expected type coming from the context
+    suffices to know which or-pattern branch must be chosen.
+
+    In the general case, choosing a branch can have non-local effects
+    on the typability of the term. For example, consider a tuple type
+    ['a tag * ...'a...], where the first component is a GADT.  All
+    constructor choices for this GADT lead to a well-typed branch in
+    isolation (['a] is unconstrained), but choosing one of them adds
+    a constraint on ['a] that may make the other tuple elements
+    ill-typed.
+
+    In general, after choosing each possible branch of the or-pattern,
+    [type_pat] has to check the rest of the pattern to tell if this
+    choice leads to a well-typed term. This may lead to an explosion
+    of typing/search work -- the rest of the term may in turn contain
+    alternatives.
+
+    We use careful strategies to try to limit counterexample-checking
+    time; [splitting_mode] represents those strategies.
+*)
+and splitting_mode =
+  | Backtrack_or
+  (** Always backtrack in or-patterns.
+
+      [Backtrack_or] selects a single alternative from an or-pattern
+      by using backtracking, trying to choose each branch in turn, and
+      to complete it into a valid sub-pattern. We call this
+      "splitting" the or-pattern.
+
+      We use this mode when looking for unused patterns or sub-patterns,
+      in particular to check a refutation clause (p -> .).
+    *)
+  | Refine_or of { inside_nonsplit_or: bool; }
+  (** Only backtrack when needed.
+
+      [Refine_or] tries another approach for refining or-pattern.
+
+      Instead of always splitting each or-pattern, It first attempts to
+      find branches that do not introduce new constraints (because they
+      do not contain GADT constructors). Those branches are such that,
+      if they fail, all other branches will fail.
+
+      If we find one such branch, we attempt to complete the subpattern
+      (checking what's outside the or-pattern), ignoring other
+      branches -- we never consider another branch choice again. If all
+      branches are constrained, it falls back to splitting the
+      or-pattern.
+
+      We use this mode when checking exhaustivity of pattern matching.
+  *)
+
+(** This exception is only used internally within [type_pat_aux], in
+    counter-example mode, to jump back to the parent or-pattern in the
+    [Refine_or] strategy.
+
+    Such a parent exists precisely when [inside_nonsplit_or = true];
+    it's an invariant that we always setup an exception handler for
+    [Need_backtrack] when we set this flag. *)
+exception Need_backtrack
+
+(** This exception is only used internally within [type_pat_aux], in
+    counter-example mode. We use it to discard counter-example candidates
+    that do not match any value. *)
+exception Empty_branch
+
+type abort_reason = Adds_constraints | Empty
+
+(** Remember current typing state for backtracking.
+   No variable information, as we only backtrack on
+   patterns without variables (cf. assert statements). *)
+type state =
+ { snapshot: Btype.snapshot;
+   levels: Ctype.levels;
+   env: Env.t; }
+let save_state env =
+  { snapshot = Btype.snapshot ();
+    levels = Ctype.save_levels ();
+    env = !env; }
+let set_state s env =
+  Btype.backtrack s.snapshot;
+  Ctype.set_levels s.levels;
+  env := s.env
+
+(** Find the first alternative in the tree of or-patterns for which
+   [f] does not raise an error. If all fail, the last error is
+   propagated *)
+let rec find_valid_alternative f pat =
+  match pat.ppat_desc with
+  | Ppat_or(p1,p2) ->
+      (try find_valid_alternative f p1 with
+       | Empty_branch | Error _ -> find_valid_alternative f p2
+      )
+  | _ -> f pat
+
+let no_explosion = function
+  | Normal -> Normal
+  | Counter_example info ->
+     Counter_example { info with explosion_fuel = 0 }
+
+let get_splitting_mode = function
+  | Normal -> None
+  | Counter_example {splitting_mode} -> Some splitting_mode
+
+let enter_nonsplit_or mode = match mode with
+  | Normal -> Normal
+  | Counter_example info ->
+     let splitting_mode = match info.splitting_mode with
+       | Backtrack_or ->
+          (* in Backtrack_or mode, or-patterns are always split *)
+          assert false
+       | Refine_or _ ->
+          Refine_or {inside_nonsplit_or = true}
+     in Counter_example { info with splitting_mode }
+
+(** The typedtree has two distinct syntactic categories for patterns,
+   "value" patterns, matching on values, and "computation" patterns
+   that match on the effect of a computation -- typically, exception
+   patterns (exception p).
+
+   On the other hand, the parsetree has an unstructured representation
+   where all categories of patterns are mixed together. The
+   decomposition according to the value/computation structure has to
+   happen during type-checking.
+
+   We don't want to duplicate the type-checking logic in two different
+   functions, depending on the kind of pattern to be produced. In
+   particular, there are both value and computation or-patterns, and
+   the type-checking logic for or-patterns is horribly complex; having
+   it in two different places would be twice as horirble.
+
+   The solution is to pass a GADT tag to [type_pat] to indicate whether
+   a value or computation pattern is expected. This way, there is a single
+   place where [Ppat_or] nodes are type-checked, the checking logic is shared,
+   and only at the end do we inspect the tag to decide to produce a value
+   or computation pattern.
+*)
+let pure
+  : type k . k pattern_category -> value general_pattern -> k general_pattern
+  = fun category pat ->
+  match category with
+  | Value -> pat
+  | Computation -> as_computation_pattern pat
+
+let only_impure
+  : type k . k pattern_category ->
+             computation general_pattern -> k general_pattern
+  = fun category pat ->
+  match category with
+  | Value ->
+     (* LATER: this exception could be renamed/generalized *)
+     raise (error (pat.pat_loc, pat.pat_env,
+                   Exception_pattern_disallowed))
+  | Computation -> pat
+
+let as_comp_pattern
+  : type k . k pattern_category ->
+             k general_pattern -> computation general_pattern
+  = fun category pat ->
+  match category with
+  | Value -> as_computation_pattern pat
+  | Computation -> pat
+
+(* type_pat propagates the expected type.
+   Unification may update the typing environment.
+
+   In counter-example mode, [Empty_branch] is raised when the counter-example
+   does not match any value.  *)
+let rec type_pat
+  : type k r . k pattern_category ->
+      no_existentials: existential_restriction option ->
+      mode: pattern_checking_mode -> env: Env.t ref -> Parsetree.pattern ->
+      type_expr -> (k general_pattern -> r) -> r
+  = fun category ~no_existentials ~mode
+        ~env sp expected_ty k ->
+  Msupport.with_saved_types
+    ~warning_attribute:sp.ppat_attributes ?save_part:None
+    (fun () ->
+       let saved = save_levels () in
+       try
+         type_pat_aux category ~no_existentials ~mode
+           ~env sp expected_ty k
+       with Error _ as exn when mode = Normal ->
+         (* We only want to catch error, not internal exceptions such as
+            [Need_backtrack], etc. *)
+         Msupport.erroneous_type_register expected_ty;
+         raise_error exn;
+         set_levels saved;
+         let loc = sp.ppat_loc in
+         let pat =
+           {
+             pat_desc = Tpat_any;
+             pat_loc = loc;
+             pat_extra = [];
+             pat_type = expected_ty;
+             pat_env = !env;
+             pat_attributes = Msupport.recovery_attributes sp.ppat_attributes;
+           }
+         in
+         k (match category with
+             | Value -> pat
+             | Computation -> as_computation_pattern pat)
+    )
+
+and type_pat_aux
+  : type k r . k pattern_category -> no_existentials:_ -> mode:_ ->
+         env:_ -> _ -> _ -> (k general_pattern -> r) -> r
+  = fun category ~no_existentials ~mode
+      ~env sp expected_ty k ->
+  let type_pat category ?(mode=mode) ?(env=env) =
+    type_pat category ~no_existentials ~mode ~env
+  in
+  let loc = sp.ppat_loc in
+  let refine =
+    match mode with Normal -> None | Counter_example _ -> Some true in
+  let solve_expected (x : pattern) : pattern =
+    unify_pat ~refine env x (instance expected_ty);
+    x
+  in
+  let rp x =
+    let crp (x : k general_pattern) : k general_pattern =
+      match category with
+      | Value -> rp x
+      | Computation -> rcp x in
+    if mode = Normal then crp x else x in
+  let rp k x = k (rp x)
+  and rvp k x = k (rp (pure category x))
+  and rcp k x = k (rp (only_impure category x)) in
+  let construction_not_used_in_counterexamples = (mode = Normal) in
+  let must_backtrack_on_gadt = match get_splitting_mode mode with
+    | None -> false
+    | Some Backtrack_or -> false
+    | Some (Refine_or {inside_nonsplit_or}) -> inside_nonsplit_or
+  in
+  match sp.ppat_desc with
+    Ppat_any ->
+      let k' d = rvp k {
+        pat_desc = d;
+        pat_loc = loc; pat_extra=[];
+        pat_type = instance expected_ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env }
+      in
+      begin match mode with
+      | Normal -> k' Tpat_any
+      | Counter_example {explosion_fuel; _} when explosion_fuel <= 0 ->
+          k' Tpat_any
+      | Counter_example ({explosion_fuel; _} as info) ->
+         let open Parmatch in
+         begin match ppat_of_type !env expected_ty with
+         | PT_empty -> raise Empty_branch
+         | PT_any -> k' Tpat_any
+         | PT_pattern (explosion, sp, constrs, labels) ->
+            let explosion_fuel =
+              match explosion with
+              | PE_single -> explosion_fuel - 1
+              | PE_gadt_cases ->
+                  if must_backtrack_on_gadt then raise Need_backtrack;
+                  explosion_fuel - 5
+            in
+            let mode =
+              Counter_example { info with explosion_fuel; constrs; labels }
+            in
+            type_pat category ~mode sp expected_ty k
+         end
+      end
+  | Ppat_var name ->
+      let ty = instance expected_ty in
+      let id = (* PR#7330 *)
+        if name.txt = "*extension*" then
+          Ident.create_local name.txt
+        else
+          enter_variable loc name ty sp.ppat_attributes
+      in
+      rvp k {
+        pat_desc = Tpat_var (id, name);
+        pat_loc = loc; pat_extra=[];
+        pat_type = ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env }
+  | Ppat_unpack name ->
+      assert construction_not_used_in_counterexamples;
+      let t = instance expected_ty in
+      begin match name.txt with
+      | None ->
+          rvp k {
+            pat_desc = Tpat_any;
+            pat_loc = sp.ppat_loc;
+            pat_extra=[Tpat_unpack, name.loc, sp.ppat_attributes];
+            pat_type = t;
+            pat_attributes = [];
+            pat_env = !env }
+      | Some s ->
+          let v = { name with txt = s } in
+          let id = enter_variable loc v t ~is_module:true sp.ppat_attributes in
+          rvp k {
+            pat_desc = Tpat_var (id, v);
+            pat_loc = sp.ppat_loc;
+            pat_extra=[Tpat_unpack, loc, sp.ppat_attributes];
+            pat_type = t;
+            pat_attributes = [];
+            pat_env = !env }
+      end
+  | Ppat_constraint(
+      {ppat_desc=Ppat_var name; ppat_loc=lloc; ppat_attributes = attrs},
+      ({ptyp_desc=Ptyp_poly _} as sty)) ->
+      (* explicitly polymorphic type *)
+      assert construction_not_used_in_counterexamples;
+      let cty, ty, ty' =
+        solve_Ppat_poly_constraint ~refine env lloc sty expected_ty in
+      let id = enter_variable lloc name ty' attrs in
+      rvp k { pat_desc = Tpat_var (id, name);
+              pat_loc = lloc;
+              pat_extra = [Tpat_constraint cty, loc, sp.ppat_attributes];
+              pat_type = ty;
+              pat_attributes = [];
+              pat_env = !env }
+  | Ppat_alias(sq, name) ->
+      assert construction_not_used_in_counterexamples;
+      type_pat Value sq expected_ty (fun q ->
+        let ty_var = solve_Ppat_alias env q in
+        let id =
+          enter_variable ~is_as_variable:true loc name ty_var sp.ppat_attributes
+        in
+        rvp k {
+          pat_desc = Tpat_alias(q, id, name);
+          pat_loc = loc; pat_extra=[];
+          pat_type = q.pat_type;
+          pat_attributes = sp.ppat_attributes;
+          pat_env = !env })
+  | Ppat_constant cst ->
+      let cst = constant_or_raise !env loc cst in
+      rvp k @@ solve_expected {
+        pat_desc = Tpat_constant cst;
+        pat_loc = loc; pat_extra=[];
+        pat_type = type_constant cst;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env }
+  | Ppat_interval (Pconst_char c1, Pconst_char c2) ->
+      let open Ast_helper.Pat in
+      let gloc = {loc with Location.loc_ghost=true} in
+      let rec loop c1 c2 =
+        if c1 = c2 then constant ~loc:gloc (Pconst_char c1)
+        else
+          or_ ~loc:gloc
+            (constant ~loc:gloc (Pconst_char c1))
+            (loop (Char.chr(Char.code c1 + 1)) c2)
+      in
+      let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in
+      let p = {p with ppat_loc=loc} in
+      type_pat category ~mode:(no_explosion mode) p expected_ty k
+        (* TODO: record 'extra' to remember about interval *)
+  | Ppat_interval _ ->
+      raise (error (loc, !env, Invalid_interval))
+  | Ppat_tuple spl ->
+      assert (List.length spl >= 2);
+      let expected_tys = solve_Ppat_tuple ~refine loc env spl expected_ty in
+      let spl_ann = List.combine spl expected_tys in
+      map_fold_cont (fun (p,t) -> type_pat Value p t) spl_ann (fun pl ->
+        rvp k {
+        pat_desc = Tpat_tuple pl;
+        pat_loc = loc; pat_extra=[];
+        pat_type = newty (Ttuple(List.map (fun p -> p.pat_type) pl));
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env })
+  | Ppat_construct(lid, sarg) ->
+      let expected_type =
+        try
+          let (p0, p, _) = extract_concrete_variant !env expected_ty in
+          let principal =
+            (repr expected_ty).level = generic_level || not !Clflags.principal
+          in
+            Some (p0, p, principal)
+        with Not_found -> None
+      in
+      let constr =
+        match lid.txt, mode with
+        | Longident.Lident s, Counter_example {constrs; _} ->
+           (* assert: cf. {!counter_example_checking_info} documentation *)
+            assert (Hashtbl.mem constrs s);
+            Hashtbl.find constrs s
+        | _ ->
+        let candidates =
+          Env.lookup_all_constructors Env.Pattern ~loc:lid.loc lid.txt !env in
+        wrap_disambiguate "This variant pattern is expected to have"
+          (mk_expected expected_ty)
+          (Constructor.disambiguate Env.Pattern lid !env expected_type)
+          candidates
+      in
+      if constr.cstr_generalized && must_backtrack_on_gadt then
+        raise Need_backtrack;
+      begin match no_existentials, constr.cstr_existentials with
+      | None, _ | _, [] -> ()
+      | Some r, (_ :: _ as exs)  ->
+          let exs = List.map (Ctype.existential_name constr) exs in
+          let name = constr.cstr_name in
+          raise (error (loc, !env, Unexpected_existential (r, name, exs)))
+      end;
+      let sarg', existential_styp =
+        match sarg with
+          None -> None, None
+        | Some (vl, {ppat_desc = Ppat_constraint (sp, sty)})
+          when vl <> [] || constr.cstr_arity > 1 ->
+            Some sp, Some (vl, sty)
+        | Some ([], sp) ->
+            Some sp, None
+        | Some (_, sp) ->
+            raise (error (sp.ppat_loc, !env, Missing_type_constraint))
+      in
+      let sargs =
+        match sarg' with
+          None -> []
+        | Some {ppat_desc = Ppat_tuple spl} when
+            constr.cstr_arity > 1 ||
+            Builtin_attributes.explicit_arity sp.ppat_attributes
+          -> spl
+        | Some({ppat_desc = Ppat_any} as sp) when
+            constr.cstr_arity = 0 && existential_styp = None
+          ->
+            Location.prerr_warning sp.ppat_loc
+              Warnings.Wildcard_arg_to_constant_constr;
+            []
+        | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity > 1 ->
+            replicate_list sp constr.cstr_arity
+        | Some sp -> [sp] in
+      if Builtin_attributes.warn_on_literal_pattern constr.cstr_attributes then
+        begin match List.filter has_literal_pattern sargs with
+        | sp :: _ ->
+           Location.prerr_warning sp.ppat_loc Warnings.Fragile_literal_pattern
+        | _ -> ()
+        end;
+      if List.length sargs <> constr.cstr_arity then
+        raise(error(loc, !env, Constructor_arity_mismatch(lid.txt,
+                                     constr.cstr_arity, List.length sargs)));
+
+      let (ty_args, existential_ctyp) =
+        solve_Ppat_construct ~refine env loc constr no_existentials
+          existential_styp expected_ty
+      in
+
+      let rec check_non_escaping p =
+        match p.ppat_desc with
+        | Ppat_or (p1, p2) ->
+            check_non_escaping p1;
+            check_non_escaping p2
+        | Ppat_alias (p, _) ->
+            check_non_escaping p
+        | Ppat_constraint _ ->
+            raise (error (p.ppat_loc, !env, Inlined_record_escape))
+        | _ ->
+            ()
+      in
+      if constr.cstr_inlined <> None then begin
+        List.iter check_non_escaping sargs;
+        Option.iter (fun (_, sarg) -> check_non_escaping sarg) sarg
+      end;
+
+      map_fold_cont
+        (fun (p,t) -> type_pat Value p t)
+        (List.combine sargs ty_args)
+        (fun args ->
+          rvp k {
+            pat_desc=Tpat_construct(lid, constr, args, existential_ctyp);
+            pat_loc = loc; pat_extra=[];
+            pat_type = instance expected_ty;
+            pat_attributes = sp.ppat_attributes;
+            pat_env = !env })
+  | Ppat_variant(tag, sarg) ->
+      if tag = Parmatch.some_private_tag then
+        assert (match mode with Normal -> false | Counter_example _ -> true);
+      let constant = (sarg = None) in
+      let arg_type, row, pat_type =
+        solve_Ppat_variant ~refine loc env tag constant expected_ty in
+      let k arg =
+        rvp k {
+        pat_desc = Tpat_variant(tag, arg, ref {row with row_more = newvar()});
+        pat_loc = loc; pat_extra = [];
+        pat_type = pat_type;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env }
+      in begin
+        (* PR#6235: propagate type information *)
+        match sarg, arg_type with
+          Some p, [ty] -> type_pat Value p ty (fun p -> k (Some p))
+        | _            -> k None
+      end
+  | Ppat_record(lid_sp_list, closed) ->
+      assert (lid_sp_list <> []);
+      let expected_type, record_ty =
+        try
+          let (p0, p,_) = extract_concrete_record !env expected_ty in
+          let ty = generic_instance expected_ty in
+          let principal =
+            (repr expected_ty).level = generic_level || not !Clflags.principal
+          in
+          Some (p0, p, principal), ty
+        with Not_found -> None, newvar ()
+      in
+      let type_label_pat (label_lid, label, sarg) k =
+        let ty_arg =
+          solve_Ppat_record_field ~refine loc env label label_lid record_ty in
+        type_pat Value sarg ty_arg (fun arg ->
+          k (label_lid, label, arg))
+      in
+      let make_record_pat lbl_pat_list =
+        check_recordpat_labels loc lbl_pat_list closed;
+        {
+          pat_desc = Tpat_record (lbl_pat_list, closed);
+          pat_loc = loc; pat_extra=[];
+          pat_type = instance record_ty;
+          pat_attributes = sp.ppat_attributes;
+          pat_env = !env;
+        }
+      in
+      let k' pat = rvp k @@ solve_expected pat in
+      begin match mode with
+      | Normal ->
+          k' (wrap_disambiguate "This record pattern is expected to have"
+               (mk_expected expected_ty)
+               (type_label_a_list loc false !env Env.Projection
+                  type_label_pat expected_type lid_sp_list)
+               make_record_pat)
+      | Counter_example {labels; _} ->
+          type_label_a_list ~labels loc false !env Env.Projection
+            type_label_pat expected_type lid_sp_list
+            (fun lbl_pat_list -> k' (make_record_pat lbl_pat_list))
+      end
+  | Ppat_array spl ->
+      let ty_elt = solve_Ppat_array ~refine loc env expected_ty in
+      map_fold_cont (fun p -> type_pat Value p ty_elt) spl (fun pl ->
+        rvp k {
+        pat_desc = Tpat_array pl;
+        pat_loc = loc; pat_extra=[];
+        pat_type = instance expected_ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env })
+  | Ppat_or(sp1, sp2) ->
+      begin match mode with
+      | Normal ->
+          let initial_pattern_variables = !pattern_variables in
+          let initial_module_variables = !module_variables in
+          let equation_level = !gadt_equations_level in
+          let outter_lev = get_current_level () in
+          (* introduce a new scope *)
+          begin_def ();
+          let lev = get_current_level () in
+          gadt_equations_level := Some lev;
+          let type_pat_rec env sp =
+            type_pat category sp expected_ty ~env (fun x -> x) in
+          let env1 = ref !env in
+          let p1 = type_pat_rec env1 sp1 in
+          let p1_variables = !pattern_variables in
+          let p1_module_variables = !module_variables in
+          pattern_variables := initial_pattern_variables;
+          module_variables := initial_module_variables;
+          let env2 = ref !env in
+          let p2 = type_pat_rec env2 sp2 in
+          end_def ();
+          gadt_equations_level := equation_level;
+          let p2_variables = !pattern_variables in
+          (* Make sure no variable with an ambiguous type gets added to the
+             environment. *)
+          List.iter (fun { pv_type; pv_loc; _ } ->
+            check_scope_escape pv_loc !env1 outter_lev pv_type
+          ) p1_variables;
+          List.iter (fun { pv_type; pv_loc; _ } ->
+            check_scope_escape pv_loc !env2 outter_lev pv_type
+          ) p2_variables;
+          let alpha_env =
+            enter_orpat_variables loc !env p1_variables p2_variables in
+          let p2 = alpha_pat alpha_env p2 in
+          pattern_variables := p1_variables;
+          module_variables := p1_module_variables;
+          rp k { pat_desc = Tpat_or (p1, p2, None);
+                 pat_loc = loc; pat_extra = [];
+                 pat_type = instance expected_ty;
+                 pat_attributes = sp.ppat_attributes;
+                 pat_env = !env }
+      | Counter_example {splitting_mode; _} ->
+          (* We are in counter-example mode, but try to avoid backtracking *)
+          let must_split =
+            match splitting_mode with
+            | Backtrack_or -> true
+            | Refine_or _ -> false in
+          let state = save_state env in
+          let split_or sp =
+            let typ pat = type_pat category pat expected_ty k in
+            find_valid_alternative (fun pat -> set_state state env; typ pat) sp
+          in
+          if must_split then split_or sp else
+          let type_pat_result env sp : (_, abort_reason) result =
+            let mode = enter_nonsplit_or mode in
+            match type_pat category ~mode sp expected_ty ~env (fun x -> x) with
+            | res -> Ok res
+            | exception Need_backtrack -> Error Adds_constraints
+            | exception Empty_branch -> Error Empty
+          in
+          let p1 = type_pat_result (ref !env) sp1 in
+          let p2 = type_pat_result (ref !env) sp2 in
+          match p1, p2 with
+          | Error Empty, Error Empty ->
+              raise Empty_branch
+          | Error Adds_constraints, Error _
+          | Error _, Error Adds_constraints ->
+              let inside_nonsplit_or =
+                match splitting_mode with
+                | Backtrack_or -> false
+                | Refine_or {inside_nonsplit_or} -> inside_nonsplit_or in
+              if inside_nonsplit_or
+              then raise Need_backtrack
+              else split_or sp
+          | Ok p, Error _
+          | Error _, Ok p ->
+              rp k p
+          | Ok p1, Ok p2 ->
+              rp k { pat_desc = Tpat_or (p1, p2, None);
+                     pat_loc = loc; pat_extra = [];
+                     pat_type = instance expected_ty;
+                     pat_attributes = sp.ppat_attributes;
+                     pat_env = !env }
+      end
+  | Ppat_lazy sp1 ->
+      let nv = solve_Ppat_lazy ~refine loc env expected_ty in
+      (* do not explode under lazy: PR#7421 *)
+      type_pat Value ~mode:(no_explosion mode) sp1 nv (fun p1 ->
+        rvp k {
+        pat_desc = Tpat_lazy p1;
+        pat_loc = loc; pat_extra=[];
+        pat_type = instance expected_ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env })
+  | Ppat_constraint(sp, sty) ->
+      assert construction_not_used_in_counterexamples;
+      (* Pretend separate = true *)
+      let cty, ty, expected_ty' =
+        solve_Ppat_constraint ~refine loc env sty expected_ty in
+      type_pat category sp expected_ty' (fun p ->
+        (*Format.printf "%a@.%a@."
+          Printtyp.raw_type_expr ty
+          Printtyp.raw_type_expr p.pat_type;*)
+        let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in
+        let p : k general_pattern =
+          match category, (p : k general_pattern) with
+          | Value, {pat_desc = Tpat_var (id,s); _} ->
+            {p with
+              pat_type = ty;
+              pat_desc =
+                Tpat_alias
+                  ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s);
+              pat_extra = [extra];
+            }
+          | _, p ->
+             { p with pat_type = ty; pat_extra = extra::p.pat_extra }
+        in k p)
+  | Ppat_type lid ->
+      assert construction_not_used_in_counterexamples;
+      let (path, p) = build_or_pat !env loc lid in
+      k @@ pure category @@ solve_expected
+        { p with pat_extra = (Tpat_type (path, lid), loc, sp.ppat_attributes)
+        :: p.pat_extra }
+  | Ppat_open (lid,p) ->
+      assert construction_not_used_in_counterexamples;
+      let path, new_env =
+        !type_open Asttypes.Fresh !env sp.ppat_loc lid in
+      env := new_env;
+      type_pat category ~env p expected_ty ( fun p ->
+        let new_env = !env in
+        begin match Env.remove_last_open path new_env with
+        | None -> assert false
+        | Some closed_env -> env := closed_env
+        end;
+        k { p with pat_extra = (Tpat_open (path,lid,new_env),
+                                loc, sp.ppat_attributes) :: p.pat_extra }
+      )
+  | Ppat_exception p ->
+      type_pat Value p Predef.type_exn (fun p_exn ->
+      rcp k {
+        pat_desc = Tpat_exception p_exn;
+        pat_loc = sp.ppat_loc;
+        pat_extra = [];
+        pat_type = expected_ty;
+        pat_env = !env;
+        pat_attributes = sp.ppat_attributes;
+      })
+  | Ppat_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+let type_pat category ?no_existentials ?(mode=Normal)
+    ?(lev=get_current_level()) env sp expected_ty =
+  Misc.protect_refs [Misc.R (gadt_equations_level, Some lev)] (fun () ->
+        type_pat category ~no_existentials ~mode
+          ~env sp expected_ty (fun x -> x)
+    )
+
+(* this function is passed to Partial.parmatch
+   to type check gadt nonexhaustiveness *)
+let partial_pred ~lev ~splitting_mode ?(explode=0)
+      env expected_ty constrs labels p =
+  let env = ref env in
+  let state = save_state env in
+  let mode =
+    Counter_example {
+        splitting_mode;
+        explosion_fuel = explode;
+        constrs; labels;
+      } in
+  try
+    reset_pattern true;
+    let typed_p = type_pat Value ~lev ~mode env p expected_ty in
+    set_state state env;
+    (* types are invalidated but we don't need them here *)
+    Some typed_p
+  with Error _ | Empty_branch ->
+    set_state state env;
+    None
+
+let check_partial ?(lev=get_current_level ()) env expected_ty loc cases =
+  let explode = match cases with [_] -> 5 | _ -> 0 in
+  let splitting_mode = Refine_or {inside_nonsplit_or = false} in
+  Parmatch.check_partial
+    (partial_pred ~lev ~splitting_mode ~explode env expected_ty) loc cases
+
+let check_unused ?(lev=get_current_level ()) env expected_ty cases =
+  Parmatch.check_unused
+    (fun refute constrs labels spat ->
+      match
+        partial_pred ~lev ~splitting_mode:Backtrack_or ~explode:5
+          env expected_ty constrs labels spat
+      with
+        Some pat when refute ->
+          raise (error (spat.ppat_loc, env, Unrefuted_pattern pat))
+      | r -> r)
+    cases
+
+let iter_pattern_variables_type f : pattern_variable list -> unit =
+  List.iter (fun {pv_type; _} -> f pv_type)
+
+let add_pattern_variables ?check ?check_as env pv =
+  List.fold_right
+    (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} env ->
+       let check = if pv_as_var then check_as else check in
+       Env.add_value ?check pv_id
+         {val_type = pv_type; val_kind = Val_reg; Types.val_loc = pv_loc;
+          val_attributes = pv_attributes;
+          val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+         } env
+    )
+    pv env
+
+let type_pattern category ~lev env spat expected_ty =
+  reset_pattern true;
+  let new_env = ref env in
+  let pat = type_pat category ~lev new_env spat expected_ty in
+  let pvs = get_ref pattern_variables in
+  let unpacks = get_ref module_variables in
+  (pat, !new_env, get_ref pattern_force, pvs, unpacks)
+
+let type_pattern_list
+    category no_existentials env spatl expected_tys allow
+  =
+  reset_pattern allow;
+  let new_env = ref env in
+  let type_pat (attrs, pat) ty =
+    Builtin_attributes.warning_scope ~ppwarning:false attrs
+      (fun () ->
+         type_pat category ~no_existentials new_env pat ty
+      )
+  in
+  let patl = List.map2 type_pat spatl expected_tys in
+  let pvs = get_ref pattern_variables in
+  let unpacks =
+    List.map (fun (name, loc) ->
+      {tu_name = name; tu_loc = loc;
+       tu_uid = Uid.mk ~current_unit:(Env.get_unit_name ())}
+    ) (get_ref module_variables)
+  in
+  let new_env = add_pattern_variables !new_env pvs in
+  (patl, new_env, get_ref pattern_force, pvs, unpacks)
+
+let type_class_arg_pattern cl_num val_env met_env l spat =
+  reset_pattern false;
+  let nv = newvar () in
+  let pat =
+    type_pat Value ~no_existentials:In_class_args (ref val_env) spat nv in
+  if has_variants pat then begin
+    Parmatch.pressure_variants val_env [pat];
+    finalize_variants pat;
+  end;
+  List.iter (fun f -> f()) (get_ref pattern_force);
+  if is_optional l then unify_pat (ref val_env) pat (type_option (newvar ()));
+  let (pv, val_env, met_env) =
+    List.fold_right
+      (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes}
+        (pv, val_env, met_env) ->
+         let check s =
+           if pv_as_var then Warnings.Unused_var s
+           else Warnings.Unused_var_strict s in
+         let id' = Ident.rename pv_id in
+         let val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in
+         let val_env =
+          Env.add_value pv_id
+            { val_type = pv_type
+            ; val_kind = Val_reg
+            ; val_attributes = pv_attributes
+            ; val_loc = pv_loc
+            ; val_uid
+            }
+            val_env
+         in
+         let met_env =
+          Env.add_value id' ~check
+            { val_type = pv_type
+            ; val_kind = Val_ivar (Immutable, cl_num)
+            ; val_attributes = pv_attributes
+            ; val_loc = pv_loc
+            ; val_uid
+            }
+            met_env
+         in
+         ((id', pv_id, pv_type)::pv, val_env, met_env))
+      !pattern_variables ([], val_env, met_env)
+  in
+  (pat, pv, val_env, met_env)
+
+let type_self_pattern cl_num privty val_env met_env par_env spat =
+  let open Ast_helper in
+  let spat =
+    Pat.mk (Ppat_alias (Pat.mk(Ppat_alias (spat, mknoloc "selfpat-*")),
+                        mknoloc ("selfpat-" ^ cl_num)))
+  in
+  reset_pattern false;
+  let nv = newvar() in
+  let pat =
+    type_pat Value ~no_existentials:In_self_pattern (ref val_env) spat nv in
+  List.iter (fun f -> f()) (get_ref pattern_force);
+  let meths = ref Meths.empty in
+  let vars = ref Vars.empty in
+  let pv = !pattern_variables in
+  pattern_variables := [];
+  let (val_env, met_env, par_env) =
+    List.fold_right
+      (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes}
+           (val_env, met_env, par_env) ->
+         let name = Ident.name pv_id in
+         (Env.enter_unbound_value name Val_unbound_self val_env,
+          Env.add_value pv_id
+            {val_type = pv_type;
+             val_kind = Val_self (meths, vars, cl_num, privty);
+             val_attributes = pv_attributes;
+             val_loc = pv_loc;
+             val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+            }
+            ~check:(fun s -> if pv_as_var then Warnings.Unused_var s
+                             else Warnings.Unused_var_strict s)
+            met_env,
+          Env.enter_unbound_value name Val_unbound_self par_env))
+      pv (val_env, met_env, par_env)
+  in
+  (pat, meths, vars, val_env, met_env, par_env)
+
+type delayed_check = ((unit -> unit) * Warnings.state)
+
+let delayed_checks = ref []
+let reset_delayed_checks () = delayed_checks := []
+let add_delayed_check f =
+  delayed_checks := (f, Warnings.backup ()) :: !delayed_checks
+
+let force_delayed_checks () =
+  (* checks may change type levels *)
+  let snap = Btype.snapshot () in
+  let w_old = Warnings.backup () in
+  List.iter
+    (fun (f, w) -> Warnings.restore w;
+      try f () with exn -> Msupport.raise_error exn)
+    (List.rev !delayed_checks);
+  Warnings.restore w_old;
+  reset_delayed_checks ();
+  Btype.backtrack snap
+
+let rec final_subexpression exp =
+  match exp.exp_desc with
+    Texp_let (_, _, e)
+  | Texp_sequence (_, e)
+  | Texp_try (e, _)
+  | Texp_ifthenelse (_, e, _)
+  | Texp_match (_, {c_rhs=e} :: _, _)
+  | Texp_letmodule (_, _, _, _, e)
+  | Texp_letexception (_, e)
+  | Texp_open (_, e)
+    -> final_subexpression e
+  | _ -> exp
+
+(* Generalization criterion for expressions *)
+
+let rec is_nonexpansive exp =
+  match exp.exp_desc with
+  | Texp_ident _
+  | Texp_constant _
+  | Texp_unreachable
+  | Texp_function _
+  | Texp_array []
+  | Texp_hole -> true
+  | Texp_let(_rec_flag, pat_exp_list, body) ->
+      List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list &&
+      is_nonexpansive body
+  | Texp_apply(e, (_,None)::el) ->
+      is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd el)
+  | Texp_match(e, cases, _) ->
+     (* Not sure this is necessary, if [e] is nonexpansive then we shouldn't
+         care if there are exception patterns. But the previous version enforced
+         that there be none, so... *)
+      let contains_exception_pat pat =
+        exists_general_pattern { f = fun (type k) (p : k general_pattern) ->
+          match p.pat_desc with
+          | Tpat_exception _ -> true
+          | _ -> false } pat
+      in
+      is_nonexpansive e &&
+      List.for_all
+        (fun {c_lhs; c_guard; c_rhs} ->
+           is_nonexpansive_opt c_guard && is_nonexpansive c_rhs
+           && not (contains_exception_pat c_lhs)
+        ) cases
+  | Texp_tuple el ->
+      List.for_all is_nonexpansive el
+  | Texp_construct( _, _, el) ->
+      List.for_all is_nonexpansive el
+  | Texp_variant(_, arg) -> is_nonexpansive_opt arg
+  | Texp_record { fields; extended_expression } ->
+      Array.for_all
+        (fun (lbl, definition) ->
+           match definition with
+           | Overridden (_, exp) ->
+               lbl.lbl_mut = Immutable && is_nonexpansive exp
+           | Kept _ -> true)
+        fields
+      && is_nonexpansive_opt extended_expression
+  | Texp_field(exp, _, _) -> is_nonexpansive exp
+  | Texp_ifthenelse(_cond, ifso, ifnot) ->
+      is_nonexpansive ifso && is_nonexpansive_opt ifnot
+  | Texp_sequence (_e1, e2) -> is_nonexpansive e2  (* PR#4354 *)
+  | Texp_new (_, _, cl_decl) -> Ctype.class_type_arity cl_decl.cty_type > 0
+  (* Note: nonexpansive only means no _observable_ side effects *)
+  | Texp_lazy e -> is_nonexpansive e
+  | Texp_object ({cstr_fields=fields; cstr_type = { csig_vars=vars}}, _) ->
+      let count = ref 0 in
+      List.for_all
+        (fun field -> match field.cf_desc with
+            Tcf_method _ -> true
+          | Tcf_val (_, _, _, Tcfk_concrete (_, e), _) ->
+              incr count; is_nonexpansive e
+          | Tcf_val (_, _, _, Tcfk_virtual _, _) ->
+              incr count; true
+          | Tcf_initializer e -> is_nonexpansive e
+          | Tcf_constraint _ -> true
+          | Tcf_inherit _ -> false
+          | Tcf_attribute _ -> true)
+        fields &&
+      Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable)
+        vars true &&
+      !count = 0
+  | Texp_letmodule (_, _, _, mexp, e)
+  | Texp_open ({ open_expr = mexp; _}, e) ->
+      is_nonexpansive_mod mexp && is_nonexpansive e
+  | Texp_pack mexp ->
+      is_nonexpansive_mod mexp
+  (* Computations which raise exceptions are nonexpansive, since (raise e) is
+     equivalent to (raise e; diverge), and a nonexpansive "diverge" can be
+     produced using lazy values or the relaxed value restriction.
+     See GPR#1142 *)
+  | Texp_assert exp ->
+      is_nonexpansive exp
+  | Texp_apply (
+      { exp_desc = Texp_ident (_, _, {val_kind =
+             Val_prim {Primitive.prim_name =
+                         ("%raise" | "%reraise" | "%raise_notrace")}}) },
+      [Nolabel, Some e]) ->
+     is_nonexpansive e
+  | Texp_array (_ :: _)
+  | Texp_apply _
+  | Texp_try _
+  | Texp_setfield _
+  | Texp_while _
+  | Texp_for _
+  | Texp_send _
+  | Texp_instvar _
+  | Texp_setinstvar _
+  | Texp_override _
+  | Texp_letexception _
+  | Texp_letop _
+  | Texp_extension_constructor _ ->
+    false
+
+and is_nonexpansive_mod mexp =
+  match mexp.mod_desc with
+  | Tmod_ident _
+  | Tmod_functor _
+  | Tmod_hole -> true
+  | Tmod_unpack (e, _) -> is_nonexpansive e
+  | Tmod_constraint (m, _, _, _) -> is_nonexpansive_mod m
+  | Tmod_structure str ->
+      List.for_all
+        (fun item -> match item.str_desc with
+          | Tstr_eval _ | Tstr_primitive _ | Tstr_type _
+          | Tstr_modtype _ | Tstr_class_type _  -> true
+          | Tstr_value (_, pat_exp_list) ->
+              List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list
+          | Tstr_module {mb_expr=m;_}
+          | Tstr_open {open_expr=m;_}
+          | Tstr_include {incl_mod=m;_} -> is_nonexpansive_mod m
+          | Tstr_recmodule id_mod_list ->
+              List.for_all (fun {mb_expr=m;_} -> is_nonexpansive_mod m)
+                id_mod_list
+          | Tstr_exception {tyexn_constructor = {ext_kind = Text_decl _}} ->
+              false (* true would be unsound *)
+          | Tstr_exception {tyexn_constructor = {ext_kind = Text_rebind _}} ->
+              true
+          | Tstr_typext te ->
+              List.for_all
+                (function {ext_kind = Text_decl _} -> false
+                        | {ext_kind = Text_rebind _} -> true)
+                te.tyext_constructors
+          | Tstr_class _ -> false (* could be more precise *)
+          | Tstr_attribute _ -> true
+        )
+        str.str_items
+  | Tmod_apply _ -> false
+
+and is_nonexpansive_opt = function
+  | None -> true
+  | Some e -> is_nonexpansive e
+
+let maybe_expansive e = not (is_nonexpansive e)
+
+let check_recursive_bindings env valbinds =
+  let ids = let_bound_idents valbinds in
+  List.iter
+    (fun {vb_expr} ->
+       if not (Rec_check.is_valid_recursive_expression ids vb_expr) then
+         raise(error(vb_expr.exp_loc, env, Illegal_letrec_expr))
+    )
+    valbinds
+
+let check_recursive_class_bindings env ids exprs =
+  List.iter
+    (fun expr ->
+       if not (Rec_check.is_valid_class_expr ids expr) then
+         raise(error(expr.cl_loc, env, Illegal_class_expr)))
+    exprs
+
+let is_prim ~name funct =
+  match funct.exp_desc with
+  | Texp_ident (_, _, {val_kind=Val_prim{Primitive.prim_name; _}}) ->
+      prim_name = name
+  | _ -> false
+(* Approximate the type of an expression, for better recursion *)
+
+let rec approx_type env sty =
+  match sty.ptyp_desc with
+    Ptyp_arrow (p, _, sty) ->
+      let ty1 = if is_optional p then type_option (newvar ()) else newvar () in
+      newty (Tarrow (p, ty1, approx_type env sty, Cok))
+  | Ptyp_tuple args ->
+      newty (Ttuple (List.map (approx_type env) args))
+  | Ptyp_constr (lid, ctl) ->
+      let path, decl = Env.lookup_type ~use:false ~loc:lid.loc lid.txt env in
+      if List.length ctl <> decl.type_arity then newvar ()
+      else begin
+        let tyl = List.map (approx_type env) ctl in
+        newconstr path tyl
+      end
+  | Ptyp_poly (_, sty) ->
+      approx_type env sty
+  | _ -> newvar ()
+
+let rec type_approx env sexp =
+  match sexp.pexp_desc with
+    Pexp_let (_, _, e) -> type_approx env e
+  | Pexp_fun (p, _, _, e) ->
+      let ty = if is_optional p then type_option (newvar ()) else newvar () in
+      newty (Tarrow(p, ty, type_approx env e, Cok))
+  | Pexp_function ({pc_rhs=e}::_) ->
+      newty (Tarrow(Nolabel, newvar (), type_approx env e, Cok))
+  | Pexp_match (_, {pc_rhs=e}::_) -> type_approx env e
+  | Pexp_try (e, _) -> type_approx env e
+  | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l))
+  | Pexp_ifthenelse (_,e,_) -> type_approx env e
+  | Pexp_sequence (_,e) -> type_approx env e
+  | Pexp_constraint (e, sty) ->
+      let ty = type_approx env e in
+      let ty1 = approx_type env sty in
+      begin try unify env ty ty1 with Unify trace ->
+        raise(error(sexp.pexp_loc, env, Expr_type_clash (trace, None, None)))
+      end;
+      ty1
+  | Pexp_coerce (e, sty1, sty2) ->
+      let approx_ty_opt = function
+        | None -> newvar ()
+        | Some sty -> approx_type env sty
+      in
+      let ty = type_approx env e
+      and ty1 = approx_ty_opt sty1
+      and ty2 = approx_type env sty2 in
+      begin try unify env ty ty1 with Unify trace ->
+        raise(error(sexp.pexp_loc, env, Expr_type_clash (trace, None, None)))
+      end;
+      ty2
+  | _ -> newvar ()
+
+(* List labels in a function type, and whether return type is a variable *)
+let rec list_labels_aux env visited ls ty_fun =
+  let ty = expand_head env ty_fun in
+  if List.memq ty visited then
+    List.rev ls, false
+  else match ty.desc with
+    Tarrow (l, _, ty_res, _) ->
+      list_labels_aux env (ty::visited) (l::ls) ty_res
+  | _ ->
+      List.rev ls, is_Tvar ty
+
+let list_labels env ty =
+  wrap_trace_gadt_instances env (list_labels_aux env [] []) ty
+
+(* Check that all univars are safe in a type. Both exp.exp_type and
+   ty_expected should already be generalized. *)
+let check_univars env kind exp ty_expected vars =
+  let pty = instance ty_expected in
+  begin_def ();
+  let exp_ty, vars =
+    match pty.desc with
+      Tpoly (body, tl) ->
+        (* Enforce scoping for type_let:
+           since body is not generic,  instance_poly only makes
+           copies of nodes that have a Tvar as descendant *)
+        let _, ty' = instance_poly true tl body in
+        let vars, exp_ty = instance_parameterized_type vars exp.exp_type in
+        unify_exp_types exp.exp_loc env exp_ty ty';
+        exp_ty, vars
+    | _ -> assert false
+  in
+  end_def ();
+  generalize exp_ty;
+  List.iter generalize vars;
+  let ty, complete = polyfy env exp_ty vars in
+  if not complete then
+    let ty_expected = instance ty_expected in
+    raise (error (exp.exp_loc, env,
+                  Less_general(kind, [Errortrace.diff ty ty_expected])))
+
+let generalize_and_check_univars env kind exp ty_expected vars =
+  generalize exp.exp_type;
+  generalize ty_expected;
+  List.iter generalize vars;
+  check_univars env kind exp ty_expected vars
+
+let check_partial_application statement exp =
+  let rec f delay =
+    let ty = (expand_head exp.exp_env exp.exp_type).desc in
+    let check_statement () =
+      match ty with
+      | Tconstr (p, _, _)  when Path.same p Predef.path_unit ->
+          ()
+      | _ ->
+          if statement then
+            let rec loop {exp_loc; exp_desc; exp_extra; _} =
+              match exp_desc with
+              | Texp_let (_, _, e)
+              | Texp_sequence (_, e)
+              | Texp_letexception (_, e)
+              | Texp_letmodule (_, _, _, _, e) ->
+                  loop e
+              | _ ->
+                  let loc =
+                    match List.find_opt (function
+                        | (Texp_constraint _, _, _) -> true
+                        | _ -> false) exp_extra
+                    with
+                    | Some (_, loc, _) -> loc
+                    | None -> exp_loc
+                  in
+                  Location.prerr_warning loc Warnings.Non_unit_statement
+            in
+            loop exp
+    in
+    match ty, exp.exp_desc with
+    | Tarrow _, _ ->
+        let rec check {exp_desc; exp_loc; exp_extra; _} =
+          if List.exists (function
+              | (Texp_constraint _, _, _) -> true
+              | _ -> false) exp_extra then check_statement ()
+          else begin
+            match exp_desc with
+            | Texp_ident _ | Texp_constant _ | Texp_tuple _
+            | Texp_construct _ | Texp_variant _ | Texp_record _
+            | Texp_field _ | Texp_setfield _ | Texp_array _
+            | Texp_while _ | Texp_for _ | Texp_instvar _
+            | Texp_setinstvar _ | Texp_override _ | Texp_assert _
+            | Texp_lazy _ | Texp_object _ | Texp_pack _ | Texp_unreachable
+            | Texp_extension_constructor _ | Texp_ifthenelse (_, _, None)
+            | Texp_function _ ->
+                check_statement ()
+            | Texp_match (_, cases, _) ->
+                List.iter (fun {c_rhs; _} -> check c_rhs) cases
+            | Texp_try (e, cases) ->
+                check e; List.iter (fun {c_rhs; _} -> check c_rhs) cases
+            | Texp_ifthenelse (_, e1, Some e2) ->
+                check e1; check e2
+            | Texp_let (_, _, e) | Texp_sequence (_, e) | Texp_open (_, e)
+            | Texp_letexception (_, e) | Texp_letmodule (_, _, _, _, e) ->
+                check e
+            | Texp_apply _ | Texp_send _ | Texp_new _ | Texp_letop _ ->
+                Location.prerr_warning exp_loc
+                  Warnings.Ignored_partial_application
+            | Texp_hole -> ()
+          end
+        in
+        check exp
+    | Tvar _, _ ->
+        if delay then add_delayed_check (fun () -> f false)
+    | _ ->
+        check_statement ()
+  in
+  f true
+
+(* Check that a type is generalizable at some level *)
+let generalizable level ty =
+  let rec check ty =
+    let ty = repr ty in
+    if not_marked_node ty then
+      if ty.level <= level then raise Exit else
+      (flip_mark_node ty; iter_type_expr check ty)
+  in
+  try check ty; unmark_type ty; true
+  with Exit -> unmark_type ty; false
+
+(* Hack to allow coercion of self. Will clean-up later. *)
+let self_coercion = ref ([] : (Path.t * Location.t list ref) list)
+
+(* Helpers for type_cases *)
+
+let contains_variant_either ty =
+  let rec loop ty =
+    let ty = repr ty in
+    if try_mark_node ty then
+      begin match ty.desc with
+        Tvariant row ->
+          let row = row_repr row in
+          if not (is_fixed row) then
+            List.iter
+              (fun (_,f) ->
+                match row_field_repr f with Reither _ -> raise Exit | _ -> ())
+              row.row_fields;
+          iter_row loop row
+      | _ ->
+          iter_type_expr loop ty
+      end
+  in
+  try loop ty; unmark_type ty; false
+  with Exit -> unmark_type ty; true
+
+let shallow_iter_ppat f p =
+  match p.ppat_desc with
+  | Ppat_any | Ppat_var _ | Ppat_constant _ | Ppat_interval _
+  | Ppat_construct (_, None)
+  | Ppat_extension _
+  | Ppat_type _ | Ppat_unpack _ -> ()
+  | Ppat_array pats -> List.iter f pats
+  | Ppat_or (p1,p2) -> f p1; f p2
+  | Ppat_variant (_, arg) -> Option.iter f arg
+  | Ppat_tuple lst ->  List.iter f lst
+  | Ppat_construct (_, Some (_, p))
+  | Ppat_exception p | Ppat_alias (p,_)
+  | Ppat_open (_,p)
+  | Ppat_constraint (p,_) | Ppat_lazy p -> f p
+  | Ppat_record (args, _flag) -> List.iter (fun (_,p) -> f p) args
+
+let exists_ppat f p =
+  let exception Found in
+  let rec loop p =
+    if f p then raise Found else ();
+    shallow_iter_ppat loop p in
+  match loop p with
+  | exception Found -> true
+  | () -> false
+
+let contains_polymorphic_variant p =
+  exists_ppat
+    (function
+     | {ppat_desc = (Ppat_variant _ | Ppat_type _)} -> true
+     | _ -> false)
+    p
+
+let contains_gadt p =
+  exists_general_pattern { f = fun (type k) (p : k general_pattern) ->
+     match p.pat_desc with
+     | Tpat_construct (_, cd, _, _) when cd.cstr_generalized -> true
+     | _ -> false } p
+
+(* There are various things that we need to do in presence of GADT constructors
+   that aren't required if there are none.
+   However, because of disambiguation, we can't know for sure whether the
+   patterns contain some GADT constructors. So we conservatively assume that
+   any constructor might be a GADT constructor. *)
+let may_contain_gadts p =
+  exists_ppat
+  (function
+   | {ppat_desc = Ppat_construct _} -> true
+   | _ -> false)
+  p
+
+let check_absent_variant env =
+  iter_general_pattern { f = fun (type k) (pat : k general_pattern) ->
+    match pat.pat_desc with
+    | Tpat_variant (s, arg, row) ->
+      let row = row_repr !row in
+      if List.exists (fun (s',fi) -> s = s' && row_field_repr fi <> Rabsent)
+          row.row_fields
+      || not (is_fixed row) && not (static_row row)  (* same as Ctype.poly *)
+      then () else
+      let ty_arg =
+        match arg with None -> [] | Some p -> [correct_levels p.pat_type] in
+      let row' = {row_fields = [s, Reither(arg=None,ty_arg,true,ref None)];
+                  row_more = newvar (); row_bound = ();
+                  row_closed = false; row_fixed = None; row_name = None} in
+      (* Should fail *)
+      unify_pat (ref env) {pat with pat_type = newty (Tvariant row')}
+                          (correct_levels pat.pat_type)
+    | _ -> () }
+
+(* Getting proper location of already typed expressions.
+
+   Used to avoid confusing locations on type error messages in presence of
+   type constraints.
+   For example:
+
+       (* Before patch *)
+       # let x : string = (5 : int);;
+                           ^
+       (* After patch *)
+       # let x : string = (5 : int);;
+                          ^^^^^^^^^
+*)
+let proper_exp_loc exp =
+  let rec aux = function
+    | [] -> exp.exp_loc
+    | ((Texp_constraint _ | Texp_coerce _), loc, _) :: _ -> loc
+    | _ :: rest -> aux rest
+  in
+  aux exp.exp_extra
+
+(* To find reasonable names for let-bound and lambda-bound idents *)
+
+let rec name_pattern default = function
+    [] -> Ident.create_local default
+  | p :: rem ->
+    match p.pat_desc with
+      Tpat_var (id, _) -> id
+    | Tpat_alias(_, id, _) -> id
+    | _ -> name_pattern default rem
+
+let name_cases default lst =
+  name_pattern default (List.map (fun c -> c.c_lhs) lst)
+
+(* Typing of expressions *)
+
+let unify_exp env exp expected_ty =
+  let loc = proper_exp_loc exp in
+  try
+    unify_exp_types loc env exp.exp_type expected_ty
+  with Error(loc, env, Expr_type_clash(trace, tfc, None)) ->
+    raise (Error(loc, env, Expr_type_clash(trace, tfc, Some exp.exp_desc)))
+
+(* If [is_inferred e] is true, [e] will be typechecked without using
+   the "expected type" provided by the context. *)
+
+let rec is_inferred sexp =
+  match sexp.pexp_desc with
+  | Pexp_ident _ | Pexp_apply _ | Pexp_field _ | Pexp_constraint _
+  | Pexp_coerce _ | Pexp_send _ | Pexp_new _ -> true
+  | Pexp_sequence (_, e) | Pexp_open (_, e) -> is_inferred e
+  | Pexp_ifthenelse (_, e1, Some e2) -> is_inferred e1 && is_inferred e2
+  | _ -> false
+
+(* check if the type of %apply or %revapply matches the type expected by
+   the specialized typing rule for those primitives.
+*)
+type apply_prim =
+  | Apply
+  | Revapply
+let check_apply_prim_type prim typ =
+  match (repr typ).desc with
+  | Tarrow (Nolabel,a,b,_) ->
+      begin match (repr b).desc with
+      | Tarrow(Nolabel,c,d,_) ->
+          let f, x, res =
+            match prim with
+            | Apply -> a, c, d
+            | Revapply -> c, a, d
+          in
+          let f, x, res = repr f, repr x, repr res in
+          begin match f.desc with
+          | Tarrow(Nolabel,fl,fr,_) ->
+              let fl, fr = repr fl, repr fr in
+              is_Tvar fl && is_Tvar fr && is_Tvar x && is_Tvar res
+              && fl == x && fr == res
+          | _ -> false
+          end
+      | _ -> false
+      end
+  | _ -> false
+
+(* Merge explanation to type clash error *)
+
+let with_explanation explanation f =
+  match explanation with
+  | None -> f ()
+  | Some explanation ->
+      try f ()
+      with Error (loc', env', Expr_type_clash(trace', None, exp'))
+        when not loc'.Location.loc_ghost ->
+        let err = Expr_type_clash(trace', Some explanation, exp') in
+        raise (Error (loc', env', err))
+
+let rec type_exp ?recarg env sexp =
+  (* We now delegate everything to type_expect *)
+  type_expect ?recarg env sexp (mk_expected (newvar ()))
+
+(* Typing of an expression with an expected type.
+   This provide better error messages, and allows controlled
+   propagation of return type information.
+   In the principal case, [type_expected'] may be at generic_level.
+ *)
+
+and type_expect ?in_function ?recarg env sexp ty_expected_explained =
+  Msupport.with_saved_types
+    ~warning_attribute:sexp.pexp_attributes ?save_part:None
+      (fun () ->
+        let saved = save_levels () in
+        try
+          type_expect_ ?in_function ?recarg env sexp ty_expected_explained
+        with exn ->
+          Msupport.erroneous_type_register ty_expected_explained.ty;
+          raise_error exn;
+          set_levels saved;
+          let loc = sexp.pexp_loc in
+          {
+            exp_desc = Texp_ident
+                         (Path.Pident (Ident.create_local "*type-error*"),
+                          Location.mkloc (Longident.Lident "*type-error*") loc,
+                          { Types.
+                            val_type = ty_expected_explained.ty;
+                            val_kind = Val_reg;
+                            val_loc = loc;
+                            val_attributes = [];
+                            val_uid = Uid.internal_not_actually_unique;
+                          });
+            exp_loc = loc;
+            exp_extra = [];
+            exp_type = ty_expected_explained.ty;
+            exp_env = env;
+            exp_attributes = Msupport.recovery_attributes sexp.pexp_attributes;
+          })
+
+and type_expect_
+    ?in_function ?(recarg=Rejected)
+    env sexp ty_expected_explained =
+  let { ty = ty_expected; explanation } = ty_expected_explained in
+  let loc = sexp.pexp_loc in
+  (* Record the expression type before unifying it with the expected type *)
+  let with_explanation = with_explanation explanation in
+  let rue exp =
+    with_explanation (fun () ->
+      unify_exp env (re exp) (instance ty_expected));
+    exp
+  in
+  match sexp.pexp_desc with
+  | Pexp_ident lid ->
+      let path, desc = type_ident env ~recarg lid in
+      let exp_desc =
+        match desc.val_kind with
+        | Val_ivar (_, cl_num) ->
+            let (self_path, _) =
+              Env.find_value_by_name
+                (Longident.Lident ("self-" ^ cl_num)) env
+            in
+            Texp_instvar(self_path, path,
+                         match lid.txt with
+                             Longident.Lident txt -> { txt; loc = lid.loc }
+                           | _ -> assert false)
+        | Val_self (_, _, cl_num, _) ->
+            let (path, _) =
+              Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env
+            in
+            Texp_ident(path, lid, desc)
+        | _ ->
+            Texp_ident(path, lid, desc)
+      in
+      rue {
+        exp_desc; exp_loc = loc; exp_extra = [];
+        exp_type = instance desc.val_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_constant(Pconst_string (str, _, _) as cst) -> (
+    let cst = constant_or_raise env loc cst in
+    (* Terrible hack for format strings *)
+    let ty_exp = expand_head env ty_expected in
+    let fmt6_path =
+      Path.(Pdot (Pident (Ident.create_persistent "CamlinternalFormatBasics"),
+                  "format6"))
+    in
+    let is_format = match ty_exp.desc with
+      | Tconstr(path, _, _) when Path.same path fmt6_path ->
+        if !Clflags.principal && ty_exp.level <> generic_level then
+          Location.prerr_warning loc
+            (Warnings.Not_principal "this coercion to format6");
+        true
+      | _ -> false
+    in
+    if is_format then
+      let format_parsetree =
+        { (type_format loc str env) with pexp_loc = sexp.pexp_loc }  in
+      type_expect ?in_function env format_parsetree ty_expected_explained
+    else
+      rue {
+        exp_desc = Texp_constant cst;
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance Predef.type_string;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  )
+  | Pexp_constant cst ->
+      let cst = constant_or_raise env loc cst in
+      rue {
+        exp_desc = Texp_constant cst;
+        exp_loc = loc; exp_extra = [];
+        exp_type = type_constant cst;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_let(Nonrecursive,
+             [{pvb_pat=spat; pvb_expr=sval; pvb_attributes=[]}], sbody)
+    when may_contain_gadts spat ->
+    (* TODO: allow non-empty attributes? *)
+      type_expect ?in_function env
+        {sexp with
+         pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody])}
+        ty_expected_explained
+  | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
+      let existential_context =
+        if rec_flag = Recursive then In_rec
+        else if List.compare_length_with spat_sexp_list 1 > 0 then In_group
+        else With_attributes in
+      let (pat_exp_list, new_env, unpacks) =
+        type_let existential_context env rec_flag spat_sexp_list true in
+      let body = type_unpacks new_env unpacks sbody ty_expected_explained in
+      let () =
+        if rec_flag = Recursive then
+          check_recursive_bindings env pat_exp_list
+      in
+      re {
+        exp_desc = Texp_let(rec_flag, pat_exp_list, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = body.exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_fun (l, Some default, spat, sbody) ->
+      assert(is_optional l); (* default allowed only with optional argument *)
+      let open Ast_helper in
+      let default_loc = default.pexp_loc in
+      let scases = [
+        Exp.case
+          (Pat.construct ~loc:default_loc
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
+             (Some ([], Pat.var ~loc:default_loc (mknoloc "*sth*"))))
+          (Exp.ident ~loc:default_loc (mknoloc (Longident.Lident "*sth*")));
+
+        Exp.case
+          (Pat.construct ~loc:default_loc
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
+             None)
+          default;
+       ]
+      in
+      let sloc =
+        { Location.loc_start = spat.ppat_loc.Location.loc_start;
+          loc_end = default_loc.Location.loc_end;
+          loc_ghost = true }
+      in
+      let smatch =
+        Exp.match_ ~loc:sloc
+          (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*")))
+          scases
+      in
+      let pat = Pat.var ~loc:sloc (mknoloc "*opt*") in
+      let body =
+        Exp.let_ ~loc Nonrecursive
+          ~attrs:[Attr.mk (mknoloc "#default") (PStr [])]
+          [Vb.mk spat smatch] sbody
+      in
+      type_function ?in_function loc sexp.pexp_attributes env
+                    ty_expected_explained l [Exp.case pat body]
+  | Pexp_fun (l, None, spat, sbody) ->
+      type_function ?in_function loc sexp.pexp_attributes env
+                    ty_expected_explained l [Ast_helper.Exp.case spat sbody]
+  | Pexp_function caselist ->
+      type_function ?in_function
+        loc sexp.pexp_attributes env ty_expected_explained Nolabel caselist
+  | Pexp_apply(sfunct, sargs) ->
+      assert (sargs <> []);
+      let rec lower_args seen ty_fun =
+        let ty = expand_head env ty_fun in
+        if List.memq ty seen then () else
+          match ty.desc with
+            Tarrow (_l, ty_arg, ty_fun, _com) ->
+              (try unify_var env (newvar()) ty_arg
+               with Unify _ -> assert false);
+              lower_args (ty::seen) ty_fun
+          | _ -> ()
+      in
+      let type_sfunct sfunct =
+        begin_def (); (* one more level for non-returning functions *)
+        if !Clflags.principal then begin_def ();
+        let funct = type_exp env sfunct in
+        if !Clflags.principal then begin
+          end_def ();
+          generalize_structure funct.exp_type
+        end;
+        let ty = instance funct.exp_type in
+        end_def ();
+        wrap_trace_gadt_instances env (lower_args []) ty;
+        funct
+      in
+      let funct, sargs =
+        let funct = type_sfunct sfunct in
+        match funct.exp_desc, sargs with
+        | Texp_ident (_, _,
+                      {val_kind = Val_prim {prim_name="%revapply"}; val_type}),
+          [Nolabel, sarg; Nolabel, actual_sfunct]
+          when is_inferred actual_sfunct
+            && check_apply_prim_type Revapply val_type ->
+            type_sfunct actual_sfunct, [Nolabel, sarg]
+        | Texp_ident (_, _,
+                      {val_kind = Val_prim {prim_name="%apply"}; val_type}),
+          [Nolabel, actual_sfunct; Nolabel, sarg]
+          when check_apply_prim_type Apply val_type ->
+            type_sfunct actual_sfunct, [Nolabel, sarg]
+        | _ ->
+            funct, sargs
+      in
+      begin_def ();
+      let (args, ty_res) = type_application env funct sargs in
+      end_def ();
+      unify_var env (newvar()) funct.exp_type;
+      let exp =
+        { exp_desc = Texp_apply(funct, args);
+          exp_loc = loc; exp_extra = [];
+          exp_type = ty_res;
+          exp_attributes = sexp.pexp_attributes;
+          exp_env = env } in
+      begin
+        try rue exp
+        with Error (_, _, Expr_type_clash _) as err ->
+          Misc.reraise_preserving_backtrace err (fun () ->
+            check_partial_application false exp)
+      end
+  | Pexp_match(sarg, caselist) ->
+      begin_def ();
+      let arg = type_exp env sarg in
+      end_def ();
+      if maybe_expansive arg then lower_contravariant env arg.exp_type;
+      generalize arg.exp_type;
+      let cases, partial =
+        type_cases Computation env
+          arg.exp_type ty_expected_explained true loc caselist in
+      re {
+        exp_desc = Texp_match(arg, cases, partial);
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance ty_expected;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_try(sbody, caselist) ->
+      let body = type_expect env sbody ty_expected_explained in
+      let cases, _ =
+        type_cases Value env
+          Predef.type_exn ty_expected_explained false loc caselist in
+      re {
+        exp_desc = Texp_try(body, cases);
+        exp_loc = loc; exp_extra = [];
+        exp_type = body.exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_tuple sexpl ->
+      assert (List.length sexpl >= 2);
+      let subtypes = List.map (fun _ -> newgenvar ()) sexpl in
+      let to_unify = newgenty (Ttuple subtypes) in
+      with_explanation (fun () ->
+        unify_exp_types loc env to_unify (generic_instance ty_expected));
+      let expl =
+        List.map2 (fun body ty -> type_expect env body (mk_expected ty))
+          sexpl subtypes
+      in
+      re {
+        exp_desc = Texp_tuple expl;
+        exp_loc = loc; exp_extra = [];
+        (* Keep sharing *)
+        exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl));
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_construct(lid, sarg) ->
+      type_construct env loc lid sarg ty_expected_explained sexp.pexp_attributes
+  | Pexp_variant(l, sarg) ->
+      (* Keep sharing *)
+      let ty_expected0 = instance ty_expected in
+      begin try match
+        sarg, expand_head env ty_expected, expand_head env ty_expected0 with
+      | Some sarg, {desc = Tvariant row}, {desc = Tvariant row0} ->
+          let row = row_repr row and row0 = row_repr row0 in
+          begin match row_field_repr (List.assoc l row.row_fields),
+          row_field_repr (List.assoc l row0.row_fields) with
+            Rpresent (Some ty), Rpresent (Some ty0) ->
+              let arg = type_argument env sarg ty ty0 in
+              re { exp_desc = Texp_variant(l, Some arg);
+                   exp_loc = loc; exp_extra = [];
+                   exp_type = ty_expected0;
+                   exp_attributes = sexp.pexp_attributes;
+                   exp_env = env }
+          | _ -> raise Not_found
+          end
+      | _ -> raise Not_found
+      with Not_found ->
+        let arg = Option.map (type_exp env) sarg in
+        let arg_type = Option.map (fun arg -> arg.exp_type) arg in
+        rue {
+          exp_desc = Texp_variant(l, arg);
+          exp_loc = loc; exp_extra = [];
+          exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type];
+                                    row_more = newvar ();
+                                    row_bound = ();
+                                    row_closed = false;
+                                    row_fixed = None;
+                                    row_name = None});
+          exp_attributes = sexp.pexp_attributes;
+          exp_env = env }
+      end
+  | Pexp_record(lid_sexp_list, opt_sexp) ->
+    let saved_levels = save_levels () in
+    begin try
+      assert (lid_sexp_list <> []);
+      let opt_exp =
+        match opt_sexp with
+          None -> None
+        | Some sexp ->
+            if !Clflags.principal then begin_def ();
+            let exp = type_exp ~recarg env sexp in
+            if !Clflags.principal then begin
+              end_def ();
+              generalize_structure exp.exp_type
+            end;
+            Some exp
+      in
+      let ty_record, expected_type =
+        let get_path ty =
+          try
+            let (p0, p,_) = extract_concrete_record env ty in
+            let principal =
+              (repr ty).level = generic_level || not !Clflags.principal
+            in
+            Some (p0, p, principal)
+          with Not_found -> None
+        in
+        let opath = get_path ty_expected in
+        match opath with
+          None | Some (_, _, false) ->
+            let ty = if opath = None then newvar () else ty_expected in
+            begin match opt_exp with
+              None -> ty, opath
+            | Some exp ->
+                match get_path exp.exp_type with
+                  None ->
+                    ty, opath
+                | Some (_, p', _) as opath ->
+                    let decl = Env.find_type p' env in
+                    begin_def ();
+                    let ty =
+                      newconstr p' (instance_list decl.type_params) in
+                    end_def ();
+                    generalize_structure ty;
+                    ty, opath
+            end
+        | _ -> ty_expected, opath
+      in
+      let closed = (opt_sexp = None) in
+      let lbl_exp_list =
+        wrap_disambiguate "This record expression is expected to have"
+          (mk_expected ty_record)
+          (type_label_a_list loc closed env Env.Construct
+             (fun e k -> k (type_label_exp true env loc ty_record e))
+             expected_type lid_sexp_list)
+          (fun x -> x)
+      in
+      with_explanation (fun () ->
+        unify_exp_types loc env (instance ty_record) (instance ty_expected));
+
+      (* type_label_a_list returns a list of labels sorted by lbl_pos *)
+      (* note: check_duplicates would better be implemented in
+         type_label_a_list directly *)
+      let rec check_duplicates = function
+        | (_, lbl1, _) :: (_, lbl2, _) :: _ when lbl1.lbl_pos = lbl2.lbl_pos ->
+          raise(error(loc, env, Label_multiply_defined lbl1.lbl_name))
+        | _ :: rem ->
+            check_duplicates rem
+        | [] -> ()
+      in
+      check_duplicates lbl_exp_list;
+      let opt_exp, label_definitions =
+        let (_lid, lbl, _lbl_exp) = List.hd lbl_exp_list in
+        let matching_label lbl =
+          List.find
+            (fun (_, lbl',_) -> lbl'.lbl_pos = lbl.lbl_pos)
+            lbl_exp_list
+        in
+        match opt_exp with
+          None ->
+            let label_definitions =
+              Array.map (fun lbl ->
+                  match matching_label lbl with
+                  | (lid, _lbl, lbl_exp) ->
+                      Overridden (lid, lbl_exp)
+                  | exception Not_found ->
+                      let present_indices =
+                        List.map (fun (_, lbl, _) -> lbl.lbl_pos) lbl_exp_list
+                      in
+                      let label_names = extract_label_names env ty_expected in
+                      let rec missing_labels n = function
+                          [] -> []
+                        | lbl :: rem ->
+                            if List.mem n present_indices
+                            then missing_labels (n + 1) rem
+                            else lbl :: missing_labels (n + 1) rem
+                      in
+                      let missing = missing_labels 0 label_names in
+                      raise(error(loc, env, Label_missing missing)))
+                lbl.lbl_all
+            in
+            None, label_definitions
+        | Some exp ->
+            let ty_exp = instance exp.exp_type in
+            let unify_kept lbl =
+              let _, ty_arg1, ty_res1 = instance_label false lbl in
+              unify_exp_types exp.exp_loc env ty_exp ty_res1;
+              match matching_label lbl with
+              | lid, _lbl, lbl_exp ->
+                  (* do not connect result types for overridden labels *)
+                  Overridden (lid, lbl_exp)
+              | exception Not_found -> begin
+                  let _, ty_arg2, ty_res2 = instance_label false lbl in
+                  unify_exp_types loc env ty_arg1 ty_arg2;
+                  with_explanation (fun () ->
+                    unify_exp_types loc env (instance ty_expected) ty_res2);
+                  Kept ty_arg1
+                end
+            in
+            let label_definitions = Array.map unify_kept lbl.lbl_all in
+            Some {exp with exp_type = ty_exp}, label_definitions
+      in
+      let num_fields =
+        match lbl_exp_list with [] -> assert false
+        | (_, lbl,_)::_ -> Array.length lbl.lbl_all in
+      if opt_sexp <> None && List.length lid_sexp_list = num_fields then
+        Location.prerr_warning loc Warnings.Useless_record_with;
+      let label_descriptions, representation =
+        let (_, { lbl_all; lbl_repres }, _) = List.hd lbl_exp_list in
+        lbl_all, lbl_repres
+      in
+      let fields =
+        Array.map2 (fun descr def -> descr, def)
+          label_descriptions label_definitions
+      in
+      re {
+        exp_desc = Texp_record {
+            fields; representation;
+            extended_expression = opt_exp
+          };
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance ty_expected;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+    with exn ->
+      raise_error exn;
+      set_levels saved_levels;
+      re {
+        exp_desc = Texp_record {
+            fields = [||]; representation = Record_regular;
+            extended_expression = None;
+          };
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance ty_expected;
+        exp_attributes = Msupport.recovery_attributes sexp.pexp_attributes;
+        exp_env = env }
+    end
+  | Pexp_field(srecord, lid) ->
+      let (record, label, _) =
+        type_label_access env srecord Env.Projection lid
+      in
+      let (_, ty_arg, ty_res) = instance_label false label in
+      unify_exp env record ty_res;
+      rue {
+        exp_desc = Texp_field(record, lid, label);
+        exp_loc = loc; exp_extra = [];
+        exp_type = ty_arg;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_setfield(srecord, lid, snewval) ->
+      let (record, label, expected_type) =
+        type_label_access env srecord Env.Mutation lid in
+      let ty_record =
+        if expected_type = None then newvar () else record.exp_type in
+      let (label_loc, label, newval) =
+        type_label_exp false env loc ty_record (lid, label, snewval) in
+      unify_exp env record ty_record;
+      if label.lbl_mut = Immutable then
+        raise(error(loc, env, Label_not_mutable lid.txt));
+      rue {
+        exp_desc = Texp_setfield(record, label_loc, label, newval);
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance Predef.type_unit;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_array(sargl) ->
+      let ty = newgenvar() in
+      let to_unify = Predef.type_array ty in
+      with_explanation (fun () ->
+        unify_exp_types loc env to_unify (generic_instance ty_expected));
+      let argl =
+        List.map (fun sarg -> type_expect env sarg (mk_expected ty)) sargl in
+      re {
+        exp_desc = Texp_array argl;
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance ty_expected;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_ifthenelse(scond, sifso, sifnot) ->
+      let cond = type_expect env scond
+          (mk_expected ~explanation:If_conditional Predef.type_bool) in
+      begin match sifnot with
+        None ->
+          let ifso = type_expect env sifso
+              (mk_expected ~explanation:If_no_else_branch Predef.type_unit) in
+          rue {
+            exp_desc = Texp_ifthenelse(cond, ifso, None);
+            exp_loc = loc; exp_extra = [];
+            exp_type = ifso.exp_type;
+            exp_attributes = sexp.pexp_attributes;
+            exp_env = env }
+      | Some sifnot ->
+          let ifso = type_expect env sifso ty_expected_explained in
+          let ifnot = type_expect env sifnot ty_expected_explained in
+          (* Keep sharing *)
+          unify_exp env ifnot ifso.exp_type;
+          re {
+            exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot);
+            exp_loc = loc; exp_extra = [];
+            exp_type = ifso.exp_type;
+            exp_attributes = sexp.pexp_attributes;
+            exp_env = env }
+      end
+  | Pexp_sequence(sexp1, sexp2) ->
+      let exp1 = type_statement ~explanation:Sequence_left_hand_side
+          env sexp1 in
+      let exp2 = type_expect env sexp2 ty_expected_explained in
+      re {
+        exp_desc = Texp_sequence(exp1, exp2);
+        exp_loc = loc; exp_extra = [];
+        exp_type = exp2.exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_while(scond, sbody) ->
+      let cond = type_expect env scond
+          (mk_expected ~explanation:While_loop_conditional Predef.type_bool) in
+      let body = type_statement ~explanation:While_loop_body env sbody in
+      rue {
+        exp_desc = Texp_while(cond, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance Predef.type_unit;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_for(param, slow, shigh, dir, sbody) ->
+      let low = type_expect env slow
+          (mk_expected ~explanation:For_loop_start_index Predef.type_int) in
+      let high = type_expect env shigh
+          (mk_expected ~explanation:For_loop_stop_index Predef.type_int) in
+      let id, new_env =
+        match param.ppat_desc with
+        | Ppat_any -> Ident.create_local "_for", env
+        | Ppat_var {txt} ->
+            Env.enter_value txt
+              {val_type = instance Predef.type_int;
+               val_attributes = [];
+               val_kind = Val_reg;
+               val_loc = loc;
+               val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+              } env
+              ~check:(fun s -> Warnings.Unused_for_index s)
+        | _ ->
+            raise (error (param.ppat_loc, env, Invalid_for_loop_index))
+      in
+      let body = type_statement ~explanation:For_loop_body new_env sbody in
+      rue {
+        exp_desc = Texp_for(id, param, low, high, dir, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance Predef.type_unit;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_constraint (sarg, sty) ->
+      (* Pretend separate = true, 1% slowdown for lablgtk *)
+      begin_def ();
+      let cty = Typetexp.transl_simple_type env false sty in
+      let ty = cty.ctyp_type in
+      end_def ();
+      generalize_structure ty;
+      let (arg, ty') = (type_argument env sarg ty (instance ty), instance ty) in
+      rue {
+        exp_desc = arg.exp_desc;
+        exp_loc = arg.exp_loc;
+        exp_type = ty';
+        exp_attributes = arg.exp_attributes;
+        exp_env = env;
+        exp_extra =
+          (Texp_constraint cty, loc, sexp.pexp_attributes) :: arg.exp_extra;
+      }
+  | Pexp_coerce(sarg, sty, sty') ->
+      (* Pretend separate = true, 1% slowdown for lablgtk *)
+      (* Also see PR#7199 for a problem with the following:
+         let separate = !Clflags.principal || Env.has_local_constraints env in*)
+      let (arg, ty',cty,cty') =
+        match sty with
+        | None ->
+            let (cty', ty', force) =
+              Typetexp.transl_simple_type_delayed env sty'
+            in
+            begin_def ();
+            let arg = type_exp env sarg in
+            end_def ();
+            let tv = newvar () in
+            let gen = generalizable tv.level arg.exp_type in
+            unify_var env tv arg.exp_type;
+            begin match arg.exp_desc, !self_coercion, (repr ty').desc with
+              Texp_ident(_, _, {val_kind=Val_self _}), (path,r) :: _,
+              Tconstr(path',_,_) when Path.same path path' ->
+                (* prerr_endline "self coercion"; *)
+                r := loc :: !r;
+                force ()
+            | _ when free_variables ~env arg.exp_type = []
+                  && free_variables ~env ty' = [] ->
+                if not gen && (* first try a single coercion *)
+                  let snap = snapshot () in
+                  let ty, _b = enlarge_type env ty' in
+                  try
+                    force (); Ctype.unify env arg.exp_type ty; true
+                  with Unify _ ->
+                    backtrack snap; false
+                then ()
+                else begin try
+                  let force' = subtype env arg.exp_type ty' in
+                  force (); force' ();
+                  if not gen && !Clflags.principal then
+                    Location.prerr_warning loc
+                      (Warnings.Not_principal "this ground coercion");
+                with Subtype (tr1, tr2) ->
+                  (* prerr_endline "coercion failed"; *)
+                  raise(error(loc, env, Not_subtype(tr1, tr2)))
+                end;
+            | _ ->
+                let ty, b = enlarge_type env ty' in
+                force ();
+                begin try Ctype.unify env arg.exp_type ty with Unify trace ->
+                  let expanded = full_expand ~may_forget_scope:true env ty' in
+                  raise(error(sarg.pexp_loc, env,
+                              Coercion_failure(ty', expanded, trace, b)))
+                end
+            end;
+            (arg, ty', None, cty')
+        | Some sty ->
+            begin_def ();
+            let (cty, ty, force) =
+              Typetexp.transl_simple_type_delayed env sty
+            and (cty', ty', force') =
+              Typetexp.transl_simple_type_delayed env sty'
+            in
+            begin try
+              let force'' = subtype env ty ty' in
+              force (); force' (); force'' ()
+            with Subtype (tr1, tr2) ->
+              raise(error(loc, env, Not_subtype(tr1, tr2)))
+            end;
+            end_def ();
+            generalize_structure ty;
+            generalize_structure ty';
+            (type_argument env sarg ty (instance ty),
+             instance ty', Some cty, cty')
+      in
+      rue {
+        exp_desc = arg.exp_desc;
+        exp_loc = arg.exp_loc;
+        exp_type = ty';
+        exp_attributes = arg.exp_attributes;
+        exp_env = env;
+        exp_extra = (Texp_coerce (cty, cty'), loc, sexp.pexp_attributes) ::
+                       arg.exp_extra;
+      }
+  | Pexp_send (e, {txt=met}) ->
+      if !Clflags.principal then begin_def ();
+      let obj = type_exp env e in
+      let obj_meths = ref None in
+      begin try
+        let (meth, exp, typ) =
+          match obj.exp_desc with
+            Texp_ident(_path, _, {val_kind = Val_self (meths, _, _, privty)}) ->
+              obj_meths := Some meths;
+              let (id, typ) =
+                filter_self_method env met Private meths privty
+              in
+              if is_Tvar (repr typ) then
+                Location.prerr_warning loc
+                  (Warnings.Undeclared_virtual_method met);
+              (Tmeth_val id, None, typ)
+          | Texp_ident(_path, lid, {val_kind = Val_anc (methods, cl_num)}) ->
+              let method_id =
+                begin try List.assoc met methods with Not_found ->
+                  let valid_methods = List.map fst methods in
+                  raise(error(e.pexp_loc, env,
+                              Undefined_inherited_method (met, valid_methods)))
+                end
+              in
+              begin match
+                Env.find_value_by_name
+                  (Longident.Lident ("selfpat-" ^ cl_num)) env,
+                Env.find_value_by_name
+                  (Longident.Lident ("self-" ^cl_num)) env
+              with
+              | (_, ({val_kind = Val_self (meths, _, _, privty)} as desc)),
+                (path, _) ->
+                  obj_meths := Some meths;
+                  let (_, typ) =
+                    filter_self_method env met Private meths privty
+                  in
+                  let method_type = newvar () in
+                  let (obj_ty, res_ty) = filter_arrow env method_type Nolabel in
+                  unify env obj_ty desc.val_type;
+                  unify env res_ty (instance typ);
+                  let method_desc =
+                    {val_type = method_type;
+                     val_kind = Val_reg;
+                     val_attributes = [];
+                     val_loc = Location.none;
+                     val_uid = Uid.internal_not_actually_unique;
+                    }
+                  in
+                  let exp_env = Env.add_value method_id method_desc env in
+                  let exp =
+                    Texp_apply({exp_desc =
+                                Texp_ident(Path.Pident method_id,
+                                           lid, method_desc);
+                                exp_loc = loc; exp_extra = [];
+                                exp_type = method_type;
+                                exp_attributes = []; (* check *)
+                                exp_env = exp_env},
+                          [ Nolabel,
+                            Some {exp_desc = Texp_ident(path, lid, desc);
+                                  exp_loc = obj.exp_loc; exp_extra = [];
+                                  exp_type = desc.val_type;
+                                  exp_attributes = []; (* check *)
+                                  exp_env = exp_env}
+                          ])
+                  in
+                  (Tmeth_name met, Some (re {exp_desc = exp;
+                                             exp_loc = loc; exp_extra = [];
+                                             exp_type = typ;
+                                             exp_attributes = []; (* check *)
+                                             exp_env = exp_env}), typ)
+              |  _ ->
+                  assert false
+              end
+          | _ ->
+              (Tmeth_name met, None,
+               filter_method env met Public obj.exp_type)
+        in
+        if !Clflags.principal then begin
+          end_def ();
+          generalize_structure typ;
+        end;
+        let typ =
+          match repr typ with
+            {desc = Tpoly (ty, [])} ->
+              instance ty
+          | {desc = Tpoly (ty, tl); level = l} ->
+              if !Clflags.principal && l <> generic_level then
+                Location.prerr_warning loc
+                  (Warnings.Not_principal "this use of a polymorphic method");
+              snd (instance_poly false tl ty)
+          | {desc = Tvar _} as ty ->
+              let ty' = newvar () in
+              unify env (instance ty) (newty(Tpoly(ty',[])));
+              (* if not !Clflags.nolabels then
+                 Location.prerr_warning loc (Warnings.Unknown_method met); *)
+              ty'
+          | _ ->
+              assert false
+        in
+        rue {
+          exp_desc = Texp_send(obj, meth, exp);
+          exp_loc = loc; exp_extra = [];
+          exp_type = typ;
+          exp_attributes = sexp.pexp_attributes;
+          exp_env = env }
+      with Unify _ ->
+        let valid_methods =
+          match !obj_meths with
+          | Some meths ->
+             Some (Meths.fold (fun meth _meth_ty li -> meth::li) !meths [])
+          | None ->
+             match (expand_head env obj.exp_type).desc with
+             | Tobject (fields, _) ->
+                let (fields, _) = Ctype.flatten_fields fields in
+                let collect_fields li (meth, meth_kind, _meth_ty) =
+                  if meth_kind = Fpresent then meth::li else li in
+                Some (List.fold_left collect_fields [] fields)
+             | _ -> None
+        in
+        Msupport.erroneous_type_register ty_expected;
+        raise_error
+          (error(e.pexp_loc, env,
+                 Undefined_method (obj.exp_type, met, valid_methods)));
+        rue {
+          exp_desc = Texp_send(obj, Tmeth_name met, None);
+          exp_loc = loc; exp_extra = [];
+          exp_type = ty_expected;
+          exp_attributes = Msupport.recovery_attributes sexp.pexp_attributes;
+          exp_env = env;
+        }
+      end
+  | Pexp_new cl ->
+      let (cl_path, cl_decl) = Env.lookup_class ~loc:cl.loc cl.txt env in
+      begin match cl_decl.cty_new with
+          None ->
+            raise(error(loc, env, Virtual_class cl.txt))
+        | Some ty ->
+            rue {
+              exp_desc = Texp_new (cl_path, cl, cl_decl);
+              exp_loc = loc; exp_extra = [];
+              exp_type = instance ty;
+              exp_attributes = sexp.pexp_attributes;
+              exp_env = env }
+        end
+  | Pexp_setinstvar (lab, snewval) -> begin
+      let (path, mut, cl_num, ty) =
+        Env.lookup_instance_variable ~loc lab.txt env
+      in
+      match mut with
+      | Mutable ->
+          let newval =
+            type_expect env snewval (mk_expected (instance ty))
+          in
+          let (path_self, _) =
+            Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env
+          in
+          rue {
+            exp_desc = Texp_setinstvar(path_self, path, lab, newval);
+            exp_loc = loc; exp_extra = [];
+            exp_type = instance Predef.type_unit;
+            exp_attributes = sexp.pexp_attributes;
+            exp_env = env }
+      | _ ->
+          raise(error(loc, env, Instance_variable_not_mutable lab.txt))
+    end
+  | Pexp_override lst ->
+      let _ =
+       List.fold_right
+        (fun (lab, _) l ->
+           if List.exists (fun l -> l.txt = lab.txt) l then
+             raise(error(loc, env,
+                         Value_multiply_overridden lab.txt));
+           lab::l)
+        lst
+        [] in
+      begin match
+        try
+          Env.find_value_by_name (Longident.Lident "selfpat-*") env,
+          Env.find_value_by_name (Longident.Lident "self-*") env
+        with Not_found ->
+          raise(error(loc, env, Outside_class))
+      with
+        (_, {val_type = self_ty; val_kind = Val_self (_, vars, _, _)}),
+        (path_self, _) ->
+          let type_override (lab, snewval) =
+            begin try
+              let (id, _, _, ty) = Vars.find lab.txt !vars in
+              (Path.Pident id, lab,
+               type_expect env snewval (mk_expected (instance ty)))
+            with
+              Not_found ->
+                let vars = Vars.fold (fun var _ li -> var::li) !vars [] in
+                raise(error(loc, env,
+                            Unbound_instance_variable (lab.txt, vars)))
+            end
+          in
+          let modifs = List.map type_override lst in
+          rue {
+            exp_desc = Texp_override(path_self, modifs);
+            exp_loc = loc; exp_extra = [];
+            exp_type = self_ty;
+            exp_attributes = sexp.pexp_attributes;
+            exp_env = env }
+      | _ ->
+          assert false
+      end
+  | Pexp_letmodule(name, smodl, sbody) ->
+      let ty = newvar() in
+      (* remember original level *)
+      begin_def ();
+      let context = Typetexp.narrow () in
+      let modl = !type_module env smodl in
+      Mtype.lower_nongen ty.level modl.mod_type;
+      let pres =
+        match modl.mod_type with
+        | Mty_alias _ -> Mp_absent
+        | _ -> Mp_present
+      in
+      let scope = create_scope () in
+      let md =
+        { md_type = modl.mod_type; md_attributes = []; md_loc = name.loc;
+          md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); }
+      in
+      let (id, new_env) =
+        match name.txt with
+        | None -> None, env
+        | Some name ->
+          let id, env = Env.enter_module_declaration ~scope name pres md env in
+          Some id, env
+      in
+      Typetexp.widen context;
+      (* ideally, we should catch Expr_type_clash errors
+         in type_expect triggered by escaping identifiers from the local module
+         and refine them into Scoping_let_module errors
+      *)
+      let body = type_expect new_env sbody ty_expected_explained in
+      (* go back to original level *)
+      end_def ();
+      Ctype.unify_var new_env ty body.exp_type;
+      re {
+        exp_desc = Texp_letmodule(id, name, pres, modl, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = ty;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_letexception(cd, sbody) ->
+      let (cd, newenv) = Typedecl.transl_exception env cd in
+      let body = type_expect newenv sbody ty_expected_explained in
+      re {
+        exp_desc = Texp_letexception(cd, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = body.exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+
+  | Pexp_assert (e) ->
+      let cond = type_expect env e
+          (mk_expected ~explanation:Assert_condition Predef.type_bool) in
+      let exp_type =
+        match cond.exp_desc with
+        | Texp_construct(_, {cstr_name="false"}, _) ->
+            instance ty_expected
+        | _ ->
+            instance Predef.type_unit
+      in
+      rue {
+        exp_desc = Texp_assert cond;
+        exp_loc = loc; exp_extra = [];
+        exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env;
+      }
+  | Pexp_lazy e ->
+      let ty = newgenvar () in
+      let to_unify = Predef.type_lazy_t ty in
+      with_explanation (fun () ->
+        unify_exp_types loc env to_unify (generic_instance ty_expected));
+      let arg = type_expect env e (mk_expected ty) in
+      re {
+        exp_desc = Texp_lazy arg;
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance ty_expected;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env;
+      }
+  | Pexp_object s ->
+      let desc, sign, meths = !type_object env loc s in
+      rue {
+        exp_desc = Texp_object (desc, (*sign,*) meths);
+        exp_loc = loc; exp_extra = [];
+        exp_type = sign.csig_self;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env;
+      }
+  | Pexp_poly(sbody, sty) ->
+      if !Clflags.principal then begin_def ();
+      let ty, cty =
+        match sty with None -> repr ty_expected, None
+        | Some sty ->
+            let sty = Ast_helper.Typ.force_poly sty in
+            let cty = Typetexp.transl_simple_type env false sty in
+            repr cty.ctyp_type, Some cty
+      in
+      if !Clflags.principal then begin
+        end_def ();
+        generalize_structure ty
+      end;
+      if sty <> None then
+        with_explanation (fun () ->
+          unify_exp_types loc env (instance ty) (instance ty_expected));
+      let exp =
+        match (expand_head env ty).desc with
+          Tpoly (ty', []) ->
+            let exp = type_expect env sbody (mk_expected ty') in
+            { exp with exp_type = instance ty }
+        | Tpoly (ty', tl) ->
+            (* One more level to generalize locally *)
+            begin_def ();
+            if !Clflags.principal then begin_def ();
+            let vars, ty'' = instance_poly true tl ty' in
+            if !Clflags.principal then begin
+              end_def ();
+              generalize_structure ty''
+            end;
+            let exp = type_expect env sbody (mk_expected ty'') in
+            end_def ();
+            generalize_and_check_univars env "method" exp ty_expected vars;
+            { exp with exp_type = instance ty }
+        | Tvar _ ->
+            let exp = type_exp env sbody in
+            let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in
+            unify_exp env exp ty;
+            exp
+        | _ -> assert false
+      in
+      re { exp with exp_extra =
+             (Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra }
+  | Pexp_newtype({txt=name} as label_loc, sbody) ->
+      let ty =
+        if Typetexp.valid_tyvar_name name then
+          newvar ~name ()
+        else
+          newvar ()
+      in
+      (* remember original level *)
+      begin_def ();
+      (* Create a fake abstract type declaration for name. *)
+      let decl = new_local_type ~loc () in
+      let scope = create_scope () in
+      let (id, new_env) = Env.enter_type ~scope name decl env in
+
+      let body = type_exp new_env sbody in
+      (* Replace every instance of this type constructor in the resulting
+         type. *)
+      let seen = Hashtbl.create 8 in
+      let rec replace t =
+        if Hashtbl.mem seen t.id then ()
+        else begin
+          Hashtbl.add seen t.id ();
+          match t.desc with
+          | Tconstr (Path.Pident id', _, _) when id == id' -> link_type t ty
+          | _ -> Btype.iter_type_expr replace t
+        end
+      in
+      let ety = Subst.type_expr Subst.identity body.exp_type in
+      replace ety;
+      (* back to original level *)
+      end_def ();
+      (* lower the levels of the result type *)
+      (* unify_var env ty ety; *)
+
+      (* non-expansive if the body is non-expansive, so we don't introduce
+         any new extra node in the typed AST. *)
+      rue { body with exp_loc = loc; exp_type = ety;
+            exp_extra =
+            (Texp_newtype' (id, label_loc), loc, sexp.pexp_attributes) :: body.exp_extra }
+  | Pexp_pack m ->
+      let (p, fl) =
+        match Ctype.expand_head env (instance ty_expected) with
+          {desc = Tpackage (p, fl)} ->
+            if !Clflags.principal &&
+              (Ctype.expand_head env ty_expected).level < Btype.generic_level
+            then
+              Location.prerr_warning loc
+                (Warnings.Not_principal "this module packing");
+            (p, fl)
+        | {desc = Tvar _} ->
+            raise (error (loc, env, Cannot_infer_signature))
+        | _ ->
+            raise (error (loc, env, Not_a_packed_module ty_expected))
+      in
+      let (modl, fl') = !type_package env m p fl in
+      rue {
+        exp_desc = Texp_pack modl;
+        exp_loc = loc; exp_extra = [];
+        exp_type = newty (Tpackage (p, fl'));
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_open (od, e) ->
+      let tv = newvar () in
+      let (od, _, newenv) = !type_open_decl env od in
+      let exp = type_expect newenv e ty_expected_explained in
+      (* Force the return type to be well-formed in the original
+         environment. *)
+      unify_var newenv tv exp.exp_type;
+      re {
+        exp_desc = Texp_open (od, exp);
+        exp_type = exp.exp_type;
+        exp_loc = loc;
+        exp_extra = [];
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env;
+      }
+  | Pexp_letop{ let_ = slet; ands = sands; body = sbody } ->
+      let rec loop spat_acc ty_acc sands =
+        match sands with
+        | [] -> spat_acc, ty_acc
+        | { pbop_pat = spat; _} :: rest ->
+            let ty = newvar () in
+            let loc = { slet.pbop_op.loc with Location.loc_ghost = true } in
+            let spat_acc = Ast_helper.Pat.tuple ~loc [spat_acc; spat] in
+            let ty_acc = newty (Ttuple [ty_acc; ty]) in
+            loop spat_acc ty_acc rest
+      in
+      if !Clflags.principal then begin_def ();
+      let let_loc = slet.pbop_op.loc in
+      let op_path, op_desc = type_binding_op_ident env slet.pbop_op in
+      let op_type = instance op_desc.val_type in
+      let spat_params, ty_params = loop slet.pbop_pat (newvar ()) sands in
+      let ty_func_result = newvar () in
+      let ty_func = newty (Tarrow(Nolabel, ty_params, ty_func_result, Cok)) in
+      let ty_result = newvar () in
+      let ty_andops = newvar () in
+      let ty_op =
+        newty (Tarrow(Nolabel, ty_andops,
+          newty (Tarrow(Nolabel, ty_func, ty_result, Cok)), Cok))
+      in
+      begin try
+        unify env op_type ty_op
+      with Unify trace ->
+        raise(error(let_loc, env, Letop_type_clash(slet.pbop_op.txt, trace)))
+      end;
+      if !Clflags.principal then begin
+        end_def ();
+        generalize_structure ty_andops;
+        generalize_structure ty_params;
+        generalize_structure ty_func_result;
+        generalize_structure ty_result
+      end;
+      let exp, ands = type_andops env slet.pbop_exp sands ty_andops in
+      let scase = Ast_helper.Exp.case spat_params sbody in
+      let cases, partial =
+        type_cases Value env
+          ty_params (mk_expected ty_func_result) true loc [scase]
+      in
+      let body =
+        match cases with
+        | [case] -> case
+        | _ -> assert false
+      in
+      let param = name_cases "param" cases in
+      let let_ =
+        { bop_op_name = slet.pbop_op;
+          bop_op_path = op_path;
+          bop_op_val = op_desc;
+          bop_op_type = op_type;
+          bop_exp = exp;
+          bop_loc = slet.pbop_loc; }
+      in
+      let desc =
+        Texp_letop{let_; ands; param; body; partial}
+      in
+      rue { exp_desc = desc;
+            exp_loc = sexp.pexp_loc;
+            exp_extra = [];
+            exp_type = instance ty_result;
+            exp_env = env;
+            exp_attributes = sexp.pexp_attributes; }
+
+  | Pexp_extension ({ txt = ("ocaml.extension_constructor"
+                             |"extension_constructor"); _ },
+                    payload) ->
+      begin match payload with
+      | PStr [ { pstr_desc =
+                   Pstr_eval ({ pexp_desc = Pexp_construct (lid, None); _ }, _)
+               } ] ->
+          let path =
+            let cd =
+              Env.lookup_constructor Env.Positive ~loc:lid.loc lid.txt env
+            in
+            match cd.cstr_tag with
+            | Cstr_extension (path, _) -> path
+            | _ -> raise (error (lid.loc, env, Not_an_extension_constructor))
+          in
+          rue {
+            exp_desc = Texp_extension_constructor (lid, path);
+            exp_loc = loc; exp_extra = [];
+            exp_type = instance Predef.type_extension_constructor;
+            exp_attributes = sexp.pexp_attributes;
+            exp_env = env }
+      | _ ->
+          raise (error (loc, env, Invalid_extension_constructor_payload))
+      end
+
+  | Pexp_extension ({ txt; _ } as s, payload) when txt = Ast_helper.hole_txt ->
+    let attr = Ast_helper.Attr.mk s payload in
+    re { exp_desc = Texp_hole;
+         exp_loc = loc; exp_extra = [];
+         exp_type = instance ty_expected;
+         exp_attributes = attr :: sexp.pexp_attributes;
+         exp_env = env }
+
+  | Pexp_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+  | Pexp_unreachable ->
+      re { exp_desc = Texp_unreachable;
+           exp_loc = loc; exp_extra = [];
+           exp_type = instance ty_expected;
+           exp_attributes = sexp.pexp_attributes;
+           exp_env = env }
+
+and type_ident env ?(recarg=Rejected) lid =
+  let (path, desc) = Env.lookup_value ~loc:lid.loc lid.txt env in
+  let is_recarg =
+    match (repr desc.val_type).desc with
+    | Tconstr(p, _, _) -> Path.is_constructor_typath p
+    | _ -> false
+  in
+  begin match is_recarg, recarg, (repr desc.val_type).desc with
+  | _, Allowed, _
+  | true, Required, _
+  | false, Rejected, _ -> ()
+  | true, Rejected, _
+  | false, Required, (Tvar _ | Tconstr _) ->
+      raise (error (lid.loc, env, Inlined_record_escape))
+  | false, Required, _  -> () (* will fail later *)
+  end;
+  path, desc
+
+and type_binding_op_ident env s =
+  let loc = s.loc in
+  let lid = Location.mkloc (Longident.Lident s.txt) loc in
+  let path, desc = type_ident env lid in
+  let path =
+    match desc.val_kind with
+    | Val_ivar _ ->
+        fatal_error "Illegal name for instance variable"
+    | Val_self (_, _, cl_num, _) ->
+        let path, _ =
+          Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env
+        in
+        path
+    | _ -> path
+  in
+  path, desc
+
+and type_function ?(in_function : (Location.t * type_expr) option)
+    loc attrs env ty_expected_explained arg_label caselist =
+  let { ty = ty_expected; explanation } = ty_expected_explained in
+  let (loc_fun, ty_fun) =
+    match in_function with Some p -> p
+    | None -> (loc, instance ty_expected)
+  in
+  let separate = !Clflags.principal || Env.has_local_constraints env in
+  if separate then begin_def ();
+  let (ty_arg, ty_res) =
+    try filter_arrow env (instance ty_expected) arg_label
+    with Unify _ ->
+      match expand_head env ty_expected with
+        {desc = Tarrow _} as ty ->
+          raise(error(loc, env,
+                      Abstract_wrong_label(arg_label, ty, explanation)))
+      | _ ->
+          raise(error(loc_fun, env,
+                      Too_many_arguments (in_function <> None,
+                                          ty_fun,
+                                          explanation)))
+  in
+  let ty_arg =
+    if is_optional arg_label then
+      let tv = newvar() in
+      begin
+        try unify env ty_arg (type_option tv)
+        with Unify _ -> assert false
+      end;
+      type_option tv
+    else ty_arg
+  in
+  if separate then begin
+    end_def ();
+    generalize_structure ty_arg;
+    generalize_structure ty_res
+  end;
+  let cases, partial =
+    type_cases Value ~in_function:(loc_fun,ty_fun) env
+      ty_arg (mk_expected ty_res) true loc caselist in
+  let not_nolabel_function ty =
+    let ls, tvar = list_labels env ty in
+    List.for_all ((<>) Nolabel) ls && not tvar
+  in
+  if is_optional arg_label && not_nolabel_function ty_res then
+    Location.prerr_warning (List.hd cases).c_lhs.pat_loc
+      Warnings.Unerasable_optional_argument;
+  let param = name_cases "param" cases in
+  re {
+    exp_desc = Texp_function { arg_label; param; cases; partial; };
+    exp_loc = loc; exp_extra = [];
+    exp_type = instance (newgenty (Tarrow(arg_label, ty_arg, ty_res, Cok)));
+    exp_attributes = attrs;
+    exp_env = env }
+
+
+and type_label_access env srecord usage lid =
+  if !Clflags.principal then begin_def ();
+  let record = type_exp ~recarg:Allowed env srecord in
+  if !Clflags.principal then begin
+    end_def ();
+    generalize_structure record.exp_type
+  end;
+  let ty_exp = record.exp_type in
+  let expected_type =
+    try
+      let (p0, p,_) = extract_concrete_record env ty_exp in
+      Some(p0, p, (repr ty_exp).level = generic_level || not !Clflags.principal)
+    with Not_found -> None
+  in
+  try
+    let labels = Env.lookup_all_labels ~loc:lid.loc usage lid.txt env in
+    let label =
+      wrap_disambiguate "This expression has" (mk_expected ty_exp)
+        (Label.disambiguate usage lid env expected_type) labels in
+    (record, label, expected_type)
+  with exn ->
+    raise_error exn;
+    let fake_label = {
+      lbl_name = "";
+      lbl_res = ty_exp;
+      lbl_arg = newvar ();
+      lbl_mut = Mutable;
+      lbl_pos = 0;
+      lbl_all = [||];
+      lbl_repres = Record_regular;
+      lbl_private = Public;
+      lbl_loc = lid.loc;
+      lbl_attributes = [];
+      lbl_uid = Uid.internal_not_actually_unique;
+    } in
+    (record, fake_label, expected_type)
+
+(* Typing format strings for printing or reading.
+   These formats are used by functions in modules Printf, Format, and Scanf.
+   (Handling of * modifiers contributed by Thorsten Ohl.) *)
+
+and type_format loc str env =
+  let loc = {loc with Location.loc_ghost = true} in
+  try
+    CamlinternalFormatBasics.(CamlinternalFormat.(
+      let mk_exp_loc pexp_desc = {
+        pexp_desc = pexp_desc;
+        pexp_loc = loc;
+        pexp_loc_stack = [];
+        pexp_attributes = [];
+      } and mk_lid_loc lid = {
+        txt = lid;
+        loc = loc;
+      } in
+      let mk_constr name args =
+        let lid = Longident.(Ldot(Lident "CamlinternalFormatBasics", name)) in
+        let arg = match args with
+          | []          -> None
+          | [ e ]       -> Some e
+          | _ :: _ :: _ -> Some (mk_exp_loc (Pexp_tuple args)) in
+        mk_exp_loc (Pexp_construct (mk_lid_loc lid, arg)) in
+      let mk_cst cst = mk_exp_loc (Pexp_constant cst) in
+      let mk_int n = mk_cst (Pconst_integer (Int.to_string n, None))
+      and mk_string str = mk_cst (Pconst_string (str, loc, None))
+      and mk_char chr = mk_cst (Pconst_char chr) in
+      let rec mk_formatting_lit fmting = match fmting with
+        | Close_box ->
+          mk_constr "Close_box" []
+        | Close_tag ->
+          mk_constr "Close_tag" []
+        | Break (org, ns, ni) ->
+          mk_constr "Break" [ mk_string org; mk_int ns; mk_int ni ]
+        | FFlush ->
+          mk_constr "FFlush" []
+        | Force_newline ->
+          mk_constr "Force_newline" []
+        | Flush_newline ->
+          mk_constr "Flush_newline" []
+        | Magic_size (org, sz) ->
+          mk_constr "Magic_size" [ mk_string org; mk_int sz ]
+        | Escaped_at ->
+          mk_constr "Escaped_at" []
+        | Escaped_percent ->
+          mk_constr "Escaped_percent" []
+        | Scan_indic c ->
+          mk_constr "Scan_indic" [ mk_char c ]
+      and mk_formatting_gen : type a b c d e f .
+          (a, b, c, d, e, f) formatting_gen -> Parsetree.expression =
+        fun fmting -> match fmting with
+        | Open_tag (Format (fmt', str')) ->
+          mk_constr "Open_tag" [ mk_format fmt' str' ]
+        | Open_box (Format (fmt', str')) ->
+          mk_constr "Open_box" [ mk_format fmt' str' ]
+      and mk_format : type a b c d e f .
+          (a, b, c, d, e, f) CamlinternalFormatBasics.fmt -> string ->
+          Parsetree.expression = fun fmt str ->
+        mk_constr "Format" [ mk_fmt fmt; mk_string str ]
+      and mk_side side = match side with
+        | Left  -> mk_constr "Left"  []
+        | Right -> mk_constr "Right" []
+        | Zeros -> mk_constr "Zeros" []
+      and mk_iconv iconv = match iconv with
+        | Int_d  -> mk_constr "Int_d"  [] | Int_pd -> mk_constr "Int_pd" []
+        | Int_sd -> mk_constr "Int_sd" [] | Int_i  -> mk_constr "Int_i"  []
+        | Int_pi -> mk_constr "Int_pi" [] | Int_si -> mk_constr "Int_si" []
+        | Int_x  -> mk_constr "Int_x"  [] | Int_Cx -> mk_constr "Int_Cx" []
+        | Int_X  -> mk_constr "Int_X"  [] | Int_CX -> mk_constr "Int_CX" []
+        | Int_o  -> mk_constr "Int_o"  [] | Int_Co -> mk_constr "Int_Co" []
+        | Int_u  -> mk_constr "Int_u"  [] | Int_Cd -> mk_constr "Int_Cd" []
+        | Int_Ci -> mk_constr "Int_Ci" [] | Int_Cu -> mk_constr "Int_Cu" []
+      and mk_fconv fconv =
+        let flag = match fst fconv with
+        | Float_flag_ -> mk_constr "Float_flag_" []
+        | Float_flag_p -> mk_constr "Float_flag_p" []
+        | Float_flag_s -> mk_constr "Float_flag_s" [] in
+        let kind = match snd fconv with
+        | Float_f  -> mk_constr "Float_f"  []
+        | Float_e  -> mk_constr "Float_e"  []
+        | Float_E  -> mk_constr "Float_E"  []
+        | Float_g  -> mk_constr "Float_g"  []
+        | Float_G  -> mk_constr "Float_G"  []
+        | Float_h  -> mk_constr "Float_h"  []
+        | Float_H  -> mk_constr "Float_H"  []
+        | Float_F  -> mk_constr "Float_F"  []
+        | Float_CF -> mk_constr "Float_CF" [] in
+        mk_exp_loc (Pexp_tuple [flag; kind])
+      and mk_counter cnt = match cnt with
+        | Line_counter  -> mk_constr "Line_counter"  []
+        | Char_counter  -> mk_constr "Char_counter"  []
+        | Token_counter -> mk_constr "Token_counter" []
+      and mk_int_opt n_opt = match n_opt with
+        | None ->
+          let lid_loc = mk_lid_loc (Longident.Lident "None") in
+          mk_exp_loc (Pexp_construct (lid_loc, None))
+        | Some n ->
+          let lid_loc = mk_lid_loc (Longident.Lident "Some") in
+          mk_exp_loc (Pexp_construct (lid_loc, Some (mk_int n)))
+      and mk_fmtty : type a b c d e f g h i j k l .
+          (a, b, c, d, e, f, g, h, i, j, k, l) fmtty_rel -> Parsetree.expression
+          =
+      fun fmtty -> match fmtty with
+        | Char_ty rest      -> mk_constr "Char_ty"      [ mk_fmtty rest ]
+        | String_ty rest    -> mk_constr "String_ty"    [ mk_fmtty rest ]
+        | Int_ty rest       -> mk_constr "Int_ty"       [ mk_fmtty rest ]
+        | Int32_ty rest     -> mk_constr "Int32_ty"     [ mk_fmtty rest ]
+        | Nativeint_ty rest -> mk_constr "Nativeint_ty" [ mk_fmtty rest ]
+        | Int64_ty rest     -> mk_constr "Int64_ty"     [ mk_fmtty rest ]
+        | Float_ty rest     -> mk_constr "Float_ty"     [ mk_fmtty rest ]
+        | Bool_ty rest      -> mk_constr "Bool_ty"      [ mk_fmtty rest ]
+        | Alpha_ty rest     -> mk_constr "Alpha_ty"     [ mk_fmtty rest ]
+        | Theta_ty rest     -> mk_constr "Theta_ty"     [ mk_fmtty rest ]
+        | Any_ty rest       -> mk_constr "Any_ty"       [ mk_fmtty rest ]
+        | Reader_ty rest    -> mk_constr "Reader_ty"    [ mk_fmtty rest ]
+        | Ignored_reader_ty rest ->
+          mk_constr "Ignored_reader_ty" [ mk_fmtty rest ]
+        | Format_arg_ty (sub_fmtty, rest) ->
+          mk_constr "Format_arg_ty" [ mk_fmtty sub_fmtty; mk_fmtty rest ]
+        | Format_subst_ty (sub_fmtty1, sub_fmtty2, rest) ->
+          mk_constr "Format_subst_ty"
+            [ mk_fmtty sub_fmtty1; mk_fmtty sub_fmtty2; mk_fmtty rest ]
+        | End_of_fmtty -> mk_constr "End_of_fmtty" []
+      and mk_ignored : type a b c d e f .
+          (a, b, c, d, e, f) ignored -> Parsetree.expression =
+      fun ign -> match ign with
+        | Ignored_char ->
+          mk_constr "Ignored_char" []
+        | Ignored_caml_char ->
+          mk_constr "Ignored_caml_char" []
+        | Ignored_string pad_opt ->
+          mk_constr "Ignored_string" [ mk_int_opt pad_opt ]
+        | Ignored_caml_string pad_opt ->
+          mk_constr "Ignored_caml_string" [ mk_int_opt pad_opt ]
+        | Ignored_int (iconv, pad_opt) ->
+          mk_constr "Ignored_int" [ mk_iconv iconv; mk_int_opt pad_opt ]
+        | Ignored_int32 (iconv, pad_opt) ->
+          mk_constr "Ignored_int32" [ mk_iconv iconv; mk_int_opt pad_opt ]
+        | Ignored_nativeint (iconv, pad_opt) ->
+          mk_constr "Ignored_nativeint" [ mk_iconv iconv; mk_int_opt pad_opt ]
+        | Ignored_int64 (iconv, pad_opt) ->
+          mk_constr "Ignored_int64" [ mk_iconv iconv; mk_int_opt pad_opt ]
+        | Ignored_float (pad_opt, prec_opt) ->
+          mk_constr "Ignored_float" [ mk_int_opt pad_opt; mk_int_opt prec_opt ]
+        | Ignored_bool pad_opt ->
+          mk_constr "Ignored_bool" [ mk_int_opt pad_opt ]
+        | Ignored_format_arg (pad_opt, fmtty) ->
+          mk_constr "Ignored_format_arg" [ mk_int_opt pad_opt; mk_fmtty fmtty ]
+        | Ignored_format_subst (pad_opt, fmtty) ->
+          mk_constr "Ignored_format_subst" [
+            mk_int_opt pad_opt; mk_fmtty fmtty ]
+        | Ignored_reader ->
+          mk_constr "Ignored_reader" []
+        | Ignored_scan_char_set (width_opt, char_set) ->
+          mk_constr "Ignored_scan_char_set" [
+            mk_int_opt width_opt; mk_string char_set ]
+        | Ignored_scan_get_counter counter ->
+          mk_constr "Ignored_scan_get_counter" [
+            mk_counter counter
+          ]
+        | Ignored_scan_next_char ->
+          mk_constr "Ignored_scan_next_char" []
+      and mk_padding : type x y . (x, y) padding -> Parsetree.expression =
+      fun pad -> match pad with
+        | No_padding         -> mk_constr "No_padding" []
+        | Lit_padding (s, w) -> mk_constr "Lit_padding" [ mk_side s; mk_int w ]
+        | Arg_padding s      -> mk_constr "Arg_padding" [ mk_side s ]
+      and mk_precision : type x y . (x, y) precision -> Parsetree.expression =
+      fun prec -> match prec with
+        | No_precision    -> mk_constr "No_precision" []
+        | Lit_precision w -> mk_constr "Lit_precision" [ mk_int w ]
+        | Arg_precision   -> mk_constr "Arg_precision" []
+      and mk_fmt : type a b c d e f .
+          (a, b, c, d, e, f) fmt -> Parsetree.expression =
+      fun fmt -> match fmt with
+        | Char rest ->
+          mk_constr "Char" [ mk_fmt rest ]
+        | Caml_char rest ->
+          mk_constr "Caml_char" [ mk_fmt rest ]
+        | String (pad, rest) ->
+          mk_constr "String" [ mk_padding pad; mk_fmt rest ]
+        | Caml_string (pad, rest) ->
+          mk_constr "Caml_string" [ mk_padding pad; mk_fmt rest ]
+        | Int (iconv, pad, prec, rest) ->
+          mk_constr "Int" [
+            mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
+        | Int32 (iconv, pad, prec, rest) ->
+          mk_constr "Int32" [
+            mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
+        | Nativeint (iconv, pad, prec, rest) ->
+          mk_constr "Nativeint" [
+            mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
+        | Int64 (iconv, pad, prec, rest) ->
+          mk_constr "Int64" [
+            mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
+        | Float (fconv, pad, prec, rest) ->
+          mk_constr "Float" [
+            mk_fconv fconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
+        | Bool (pad, rest) ->
+          mk_constr "Bool" [ mk_padding pad; mk_fmt rest ]
+        | Flush rest ->
+          mk_constr "Flush" [ mk_fmt rest ]
+        | String_literal (s, rest) ->
+          mk_constr "String_literal" [ mk_string s; mk_fmt rest ]
+        | Char_literal (c, rest) ->
+          mk_constr "Char_literal" [ mk_char c; mk_fmt rest ]
+        | Format_arg (pad_opt, fmtty, rest) ->
+          mk_constr "Format_arg" [
+            mk_int_opt pad_opt; mk_fmtty fmtty; mk_fmt rest ]
+        | Format_subst (pad_opt, fmtty, rest) ->
+          mk_constr "Format_subst" [
+            mk_int_opt pad_opt; mk_fmtty fmtty; mk_fmt rest ]
+        | Alpha rest ->
+          mk_constr "Alpha" [ mk_fmt rest ]
+        | Theta rest ->
+          mk_constr "Theta" [ mk_fmt rest ]
+        | Formatting_lit (fmting, rest) ->
+          mk_constr "Formatting_lit" [ mk_formatting_lit fmting; mk_fmt rest ]
+        | Formatting_gen (fmting, rest) ->
+          mk_constr "Formatting_gen" [ mk_formatting_gen fmting; mk_fmt rest ]
+        | Reader rest ->
+          mk_constr "Reader" [ mk_fmt rest ]
+        | Scan_char_set (width_opt, char_set, rest) ->
+          mk_constr "Scan_char_set" [
+            mk_int_opt width_opt; mk_string char_set; mk_fmt rest ]
+        | Scan_get_counter (cnt, rest) ->
+          mk_constr "Scan_get_counter" [ mk_counter cnt; mk_fmt rest ]
+        | Scan_next_char rest ->
+          mk_constr "Scan_next_char" [ mk_fmt rest ]
+        | Ignored_param (ign, rest) ->
+          mk_constr "Ignored_param" [ mk_ignored ign; mk_fmt rest ]
+        | End_of_format ->
+          mk_constr "End_of_format" []
+        | Custom _ ->
+          (* Custom formatters have no syntax so they will never appear
+             in formats parsed from strings. *)
+          assert false
+      in
+      let legacy_behavior = not !Clflags.strict_formats in
+      let Fmt_EBB fmt = fmt_ebb_of_string ~legacy_behavior str in
+      mk_constr "Format" [ mk_fmt fmt; mk_string str ]
+    ))
+  with Failure msg ->
+    raise (error (loc, env, Invalid_format msg))
+
+and type_label_exp create env loc ty_expected
+          (lid, label, sarg) =
+  (* Here also ty_expected may be at generic_level *)
+  begin_def ();
+  let separate = !Clflags.principal || Env.has_local_constraints env in
+  if separate then (begin_def (); begin_def ());
+  let (vars, ty_arg, ty_res) = instance_label true label in
+  if separate then begin
+    end_def ();
+    (* Generalize label information *)
+    generalize_structure ty_arg;
+    generalize_structure ty_res
+  end;
+  begin try
+    unify env (instance ty_res) (instance ty_expected)
+  with Unify trace ->
+    raise (error(lid.loc, env, Label_mismatch(lid.txt, trace)))
+  end;
+  (* Instantiate so that we can generalize internal nodes *)
+  let ty_arg = instance ty_arg in
+  if separate then begin
+    end_def ();
+    (* Generalize information merged from ty_expected *)
+    generalize_structure ty_arg
+  end;
+  if label.lbl_private = Private then
+    if create then
+      raise (error(loc, env, Private_type ty_expected))
+    else
+      raise (error(lid.loc, env, Private_label(lid.txt, ty_expected)));
+  let arg =
+    let snap = if vars = [] then None else Some (Btype.snapshot ()) in
+    let arg = type_argument env sarg ty_arg (instance ty_arg) in
+    end_def ();
+    try
+      if (vars = []) then arg
+      else begin
+        if maybe_expansive arg then
+          lower_contravariant env arg.exp_type;
+        generalize_and_check_univars env "field value" arg label.lbl_arg vars;
+        {arg with exp_type = instance arg.exp_type}
+      end
+    with exn when maybe_expansive arg -> try
+      (* Try to retype without propagating ty_arg, cf PR#4862 *)
+      Option.iter Btype.backtrack snap;
+      begin_def ();
+      let arg = type_exp env sarg in
+      end_def ();
+      lower_contravariant env arg.exp_type;
+      begin_def ();
+      let arg = {arg with exp_type = instance arg.exp_type} in
+      unify_exp env arg (instance ty_arg);
+      end_def ();
+      generalize_and_check_univars env "field value" arg label.lbl_arg vars;
+      {arg with exp_type = instance arg.exp_type}
+    with Error (_, _, Less_general _) as e -> raise e
+    | _ -> raise exn    (* In case of failure return the first error *)
+  in
+  (lid, label, arg)
+
+and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected =
+  (* ty_expected' may be generic *)
+  let no_labels ty =
+    let ls, tvar = list_labels env ty in
+    not tvar && List.for_all ((=) Nolabel) ls
+  in
+  let may_coerce =
+    if not (is_inferred sarg) then None else
+    let work () =
+      match expand_head env ty_expected' with
+        {desc = Tarrow(Nolabel,_,ty_res0,_); level} ->
+          Some (no_labels ty_res0, level)
+      | _ -> None
+    in
+    (* Need to be careful not to expand local constraints here *)
+    if Env.has_local_constraints env then
+      let snap = Btype.snapshot () in
+      try_finally ~always:(fun () -> Btype.backtrack snap) work
+    else work ()
+  in
+  match may_coerce with
+    Some (safe_expect, lv) ->
+      (* apply optional arguments when expected type is "" *)
+      (* we must be very careful about not breaking the semantics *)
+      if !Clflags.principal then begin_def ();
+      let texp = type_exp env sarg in
+      if !Clflags.principal then begin
+        end_def ();
+        generalize_structure texp.exp_type
+      end;
+      let rec make_args args ty_fun =
+        match (expand_head env ty_fun).desc with
+        | Tarrow (l,ty_arg,ty_fun,_) when is_optional l ->
+            let ty = option_none env (instance ty_arg) sarg.pexp_loc in
+            make_args ((l, Some ty) :: args) ty_fun
+        | Tarrow (l,_,ty_res',_) when l = Nolabel || !Clflags.classic ->
+            List.rev args, ty_fun, no_labels ty_res'
+        | Tvar _ ->  List.rev args, ty_fun, false
+        |  _ -> [], texp.exp_type, false
+      in
+      let args, ty_fun', simple_res = make_args [] texp.exp_type
+      and texp = {texp with exp_type = instance texp.exp_type} in
+      if not (simple_res || safe_expect) then begin
+        unify_exp env texp ty_expected;
+        texp
+      end else begin
+      let warn = !Clflags.principal &&
+        (lv <> generic_level || (repr ty_fun').level <> generic_level)
+      and ty_fun = instance ty_fun' in
+      let ty_arg, ty_res =
+        match expand_head env ty_expected' with
+          {desc = Tarrow(Nolabel,ty_arg,ty_res,_)} -> ty_arg, ty_res
+        | _ -> assert false
+      in
+      unify_exp env {texp with exp_type = ty_fun} ty_expected;
+      if args = [] then texp else
+      (* eta-expand to avoid side effects *)
+      let var_pair name ty =
+        let id = Ident.create_local name in
+        let desc =
+          { val_type = ty; val_kind = Val_reg;
+            val_attributes = [];
+            val_loc = Location.none;
+            val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+          }
+        in
+        let exp_env = Env.add_value id desc env in
+        {pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[];
+         pat_attributes = [];
+         pat_loc = Location.none; pat_env = env},
+        {exp_type = ty; exp_loc = Location.none; exp_env = exp_env;
+         exp_extra = []; exp_attributes = [];
+         exp_desc =
+         Texp_ident(Path.Pident id, mknoloc (Longident.Lident name), desc)}
+      in
+      let eta_pat, eta_var = var_pair "eta" ty_arg in
+      let func texp =
+        let e =
+          {texp with exp_type = ty_res; exp_desc =
+           Texp_apply
+             (texp,
+              args @ [Nolabel, Some eta_var])}
+        in
+        let cases = [case eta_pat e] in
+        let param = name_cases "param" cases in
+        { texp with exp_type = ty_fun; exp_desc =
+          Texp_function { arg_label = Nolabel; param; cases;
+            partial = Total; } }
+      in
+      Location.prerr_warning texp.exp_loc
+        (Warnings.Eliminated_optional_arguments
+           (List.map (fun (l, _) -> Printtyp.string_of_label l) args));
+      if warn then Location.prerr_warning texp.exp_loc
+          (Warnings.Non_principal_labels "eliminated optional argument");
+      (* let-expand to have side effects *)
+      let let_pat, let_var = var_pair "arg" texp.exp_type in
+      re { texp with exp_type = ty_fun; exp_desc =
+           Texp_let (Nonrecursive,
+                     [{vb_pat=let_pat; vb_expr=texp; vb_attributes=[];
+                       vb_loc=Location.none;
+                      }],
+                     func let_var) }
+      end
+  | None ->
+      let texp = type_expect ?recarg env sarg
+        (mk_expected ?explanation ty_expected') in
+      unify_exp env texp ty_expected;
+      texp
+
+and type_application env funct sargs =
+  (* funct.exp_type may be generic *)
+  let result_type omitted ty_fun =
+    List.fold_left
+      (fun ty_fun (l,ty,lv) -> newty2 lv (Tarrow(l,ty,ty_fun,Cok)))
+      ty_fun omitted
+  in
+  let has_label l ty_fun =
+    let ls, tvar = list_labels env ty_fun in
+    tvar || List.mem l ls
+  in
+  let eliminated_optional_arguments = ref [] in
+  let omitted_parameters = ref [] in
+  let type_unknown_arg (ty_fun, typed_args) (lbl, sarg) =
+    let (ty_arg, ty_res) =
+    try
+      let ty_fun = expand_head env ty_fun in
+      match ty_fun.desc with
+      | Tvar _ ->
+          let t1 = newvar () and t2 = newvar () in
+          if ty_fun.level >= t1.level &&
+             not (is_prim ~name:"%identity" funct) &&
+             not (Msupport.erroneous_expr_check funct)
+          then
+            Location.prerr_warning sarg.pexp_loc
+              Warnings.Ignored_extra_argument;
+          unify env ty_fun (newty (Tarrow(lbl,t1,t2,Clink(ref Cunknown))));
+          (t1, t2)
+      | Tarrow (l,t1,t2,_) when l = lbl
+        || !Clflags.classic && lbl = Nolabel && not (is_optional l) ->
+          (t1, t2)
+      | td ->
+          let ty_fun = match td with Tarrow _ -> newty td | _ -> ty_fun in
+          let ty_res =
+            result_type (!omitted_parameters @ !eliminated_optional_arguments)
+              ty_fun
+          in
+          match ty_res.desc with
+          | Tarrow _ ->
+              if !Clflags.classic || not (has_label lbl ty_fun) then
+                Msupport.resume_raise
+                  (error(sarg.pexp_loc, env,
+                         Apply_wrong_label(lbl, ty_res, false)))
+              else
+                Msupport.resume_raise
+                  (error(funct.exp_loc, env, Incoherent_label_order))
+          | _ ->
+              Msupport.resume_raise
+                (error(funct.exp_loc, env, Apply_non_function
+                            (expand_head env funct.exp_type)))
+    with Msupport.Resume ->
+      newvar(), ty_fun
+    in
+    let arg () =
+      let arg = type_expect env sarg (mk_expected ty_arg) in
+      if is_optional lbl then
+        unify_exp env arg (type_option(newvar()));
+      arg
+    in
+    (ty_res, (lbl, Some arg) :: typed_args)
+  in
+  let ignore_labels =
+    !Clflags.classic ||
+    begin
+      let ls, tvar = list_labels env funct.exp_type in
+      not tvar &&
+      let labels = List.filter (fun l -> not (is_optional l)) ls in
+      List.length labels = List.length sargs &&
+      List.for_all (fun (l,_) -> l = Nolabel) sargs &&
+      List.exists (fun l -> l <> Nolabel) labels &&
+      (Location.prerr_warning
+         funct.exp_loc
+         (Warnings.Labels_omitted
+            (List.map Printtyp.string_of_label
+                      (List.filter ((<>) Nolabel) labels)));
+       true)
+    end
+  in
+  let warned = ref false in
+  let rec type_args args ty_fun ty_fun0 sargs =
+    match expand_head env ty_fun, expand_head env ty_fun0 with
+    | {desc=Tarrow (l, ty, ty_fun, com); level=lv} as ty_fun',
+      {desc=Tarrow (_, ty0, ty_fun0, _)}
+      when sargs <> [] && commu_repr com = Cok ->
+        let may_warn loc w =
+          if not !warned && !Clflags.principal && lv <> generic_level
+          then begin
+            warned := true;
+            Location.prerr_warning loc w
+          end
+        in
+        let name = label_name l
+        and optional = is_optional l in
+        let use_arg sarg l' =
+          Some (
+            if not optional || is_optional l' then
+              (fun () -> type_argument env sarg ty ty0)
+            else begin
+              may_warn sarg.pexp_loc
+                (Warnings.Not_principal "using an optional argument here");
+              (fun () -> option_some env (type_argument env sarg
+                                            (extract_option_type env ty)
+                                            (extract_option_type env ty0)))
+            end
+          )
+        in
+        let eliminate_optional_arg () =
+          may_warn funct.exp_loc
+            (Warnings.Non_principal_labels "eliminated optional argument");
+          eliminated_optional_arguments :=
+            (l,ty,lv) :: !eliminated_optional_arguments;
+          Some (fun () -> option_none env (instance ty) Location.none)
+        in
+        let remaining_sargs, arg =
+          if ignore_labels then begin
+            (* No reordering is allowed, process arguments in order *)
+            match sargs with
+            | [] -> assert false
+            | (l', sarg) :: remaining_sargs ->
+                if name = label_name l' || (not optional && l' = Nolabel) then
+                  (remaining_sargs, use_arg sarg l')
+                else if
+                  optional &&
+                  not (List.exists (fun (l, _) -> name = label_name l)
+                         remaining_sargs) &&
+                  List.exists (function (Nolabel, _) -> true | _ -> false)
+                    sargs
+                then
+                  (sargs, eliminate_optional_arg ())
+                else
+                  raise(error(sarg.pexp_loc, env,
+                              Apply_wrong_label(l', ty_fun', optional)))
+          end else
+            (* Arguments can be commuted, try to fetch the argument
+               corresponding to the first parameter. *)
+            match extract_label name sargs with
+            | Some (l', sarg, commuted, remaining_sargs) ->
+                if commuted then begin
+                  may_warn sarg.pexp_loc
+                    (Warnings.Not_principal "commuting this argument")
+                end;
+                if not optional && is_optional l' then
+                  Location.prerr_warning sarg.pexp_loc
+                    (Warnings.Nonoptional_label (Printtyp.string_of_label l));
+                remaining_sargs, use_arg sarg l'
+            | None ->
+                sargs,
+                if optional && List.mem_assoc Nolabel sargs then
+                  eliminate_optional_arg ()
+                else begin
+                  (* No argument was given for this parameter, we abstract over
+                     it. *)
+                  may_warn funct.exp_loc
+                    (Warnings.Non_principal_labels "commuted an argument");
+                  omitted_parameters := (l,ty,lv) :: !omitted_parameters;
+                  None
+                end
+        in
+        type_args ((l,arg)::args) ty_fun ty_fun0 remaining_sargs
+    | _ ->
+        (* We're not looking at a *known* function type anymore, or there are no
+           arguments left. *)
+        let ty_fun, typed_args =
+          List.fold_left type_unknown_arg (ty_fun0, args) sargs
+        in
+        let args =
+          (* Force typing of arguments.
+             Careful: the order matters here. Using [List.rev_map] would be
+             incorrect. *)
+          List.map
+            (function
+              | l, None -> l, None
+              | l, Some f -> l, Some (f ()))
+            (List.rev typed_args)
+        in
+        let result_ty = instance (result_type !omitted_parameters ty_fun) in
+        args, result_ty
+  in
+  let is_ignore funct =
+    is_prim ~name:"%ignore" funct &&
+    (try ignore (filter_arrow env (instance funct.exp_type) Nolabel); true
+     with Unify _ -> false)
+  in
+  match sargs with
+  | (* Special case for ignore: avoid discarding warning *)
+    [Nolabel, sarg] when is_ignore funct ->
+      let ty_arg, ty_res = filter_arrow env (instance funct.exp_type) Nolabel in
+      let exp = type_expect env sarg (mk_expected ty_arg) in
+      check_partial_application false exp;
+      ([Nolabel, Some exp], ty_res)
+  | _ ->
+    let ty = funct.exp_type in
+    type_args [] ty (instance ty) sargs
+
+and type_construct env loc lid sarg ty_expected_explained attrs =
+  let { ty = ty_expected; explanation } = ty_expected_explained in
+  let expected_type =
+    try
+      let (p0, p,_) = extract_concrete_variant env ty_expected in
+      let principal =
+        (repr ty_expected).level = generic_level || not !Clflags.principal
+      in
+      Some(p0, p, principal)
+    with Not_found -> None
+  in
+  let constrs =
+    Env.lookup_all_constructors ~loc:lid.loc Env.Positive lid.txt env
+  in
+  let constr =
+    wrap_disambiguate "This variant expression is expected to have"
+      ty_expected_explained
+      (Constructor.disambiguate Env.Positive lid env expected_type) constrs
+  in
+  let sargs =
+    match sarg with
+      None -> []
+    | Some {pexp_desc = Pexp_tuple sel} when
+        constr.cstr_arity > 1 || Builtin_attributes.explicit_arity attrs
+      -> sel
+    | Some se -> [se] in
+  if List.length sargs <> constr.cstr_arity then
+    raise(error(loc, env, Constructor_arity_mismatch
+                            (lid.txt, constr.cstr_arity, List.length sargs)));
+  let separate = !Clflags.principal || Env.has_local_constraints env in
+  if separate then (begin_def (); begin_def ());
+  let (ty_args, ty_res, _) = instance_constructor constr in
+  let texp =
+    re {
+      exp_desc = Texp_construct(lid, constr, []);
+      exp_loc = loc; exp_extra = [];
+      exp_type = ty_res;
+      exp_attributes = attrs;
+      exp_env = env } in
+  if separate then begin
+    end_def ();
+    generalize_structure ty_res;
+    with_explanation explanation (fun () ->
+      unify_exp env {texp with exp_type = instance ty_res}
+        (instance ty_expected));
+    end_def ();
+    List.iter generalize_structure ty_args;
+    generalize_structure ty_res;
+  end;
+  let ty_args0, ty_res =
+    match instance_list (ty_res :: ty_args) with
+      t :: tl -> tl, t
+    | _ -> assert false
+  in
+  let texp = {texp with exp_type = ty_res} in
+  if not separate then unify_exp env texp (instance ty_expected);
+  let recarg =
+    match constr.cstr_inlined with
+    | None -> Rejected
+    | Some _ ->
+      begin match sargs with
+      | [{pexp_desc =
+            Pexp_ident _ |
+            Pexp_record (_, (Some {pexp_desc = Pexp_ident _}| None))}] ->
+        Required
+      | _ ->
+        raise (error(loc, env, Inlined_record_expected))
+      end
+  in
+  let args =
+    List.map2 (fun e (t,t0) -> type_argument ~recarg env e t t0) sargs
+      (List.combine ty_args ty_args0) in
+  if constr.cstr_private = Private then
+    begin match constr.cstr_tag with
+    | Cstr_extension _ ->
+        raise_error (error(loc, env, Private_constructor (constr, ty_res)))
+    | Cstr_constant _ | Cstr_block _ | Cstr_unboxed ->
+        raise_error (error(loc, env, Private_type ty_res));
+    end;
+  (* NOTE: shouldn't we call "re" on this final expression? -- AF *)
+  { texp with
+    exp_desc = Texp_construct(lid, constr, args) }
+
+(* Typing of statements (expressions whose values are discarded) *)
+
+and type_statement ?explanation env sexp =
+  let has_errors = Msupport.monitor_errors () in
+  begin_def();
+  let exp = type_exp env sexp in
+  end_def();
+  let ty = expand_head env exp.exp_type and tv = newvar() in
+  if is_Tvar ty && ty.level > tv.level && not !has_errors then
+    Location.prerr_warning
+      (final_subexpression exp).exp_loc
+      Warnings.Nonreturning_statement;
+  if !Clflags.strict_sequence then
+    let expected_ty = instance Predef.type_unit in
+    with_explanation explanation (fun () ->
+      unify_exp env exp expected_ty);
+    exp
+  else begin
+    if not !has_errors then check_partial_application true exp;
+    unify_var env tv ty;
+    exp
+  end
+
+and type_unpacks ?(in_function : (Location.t * type_expr) option)
+    env (unpacks : to_unpack list) sbody expected_ty =
+  let ty = newvar() in
+  (* remember original level *)
+  let extended_env, tunpacks =
+    List.fold_left (fun (env, tunpacks) unpack ->
+      begin_def ();
+      let context = Typetexp.narrow () in
+      let modl =
+        !type_module env
+          Ast_helper.(
+            Mod.unpack ~loc:unpack.tu_loc
+              (Exp.ident ~loc:unpack.tu_name.loc
+                 (mkloc (Longident.Lident unpack.tu_name.txt)
+                    unpack.tu_name.loc)))
+      in
+      Mtype.lower_nongen ty.level modl.mod_type;
+      let pres =
+        match modl.mod_type with
+        | Mty_alias _ -> Mp_absent
+        | _ -> Mp_present
+      in
+      let scope = create_scope () in
+      let md =
+        { md_type = modl.mod_type; md_attributes = [];
+          md_loc = unpack.tu_name.loc;
+          md_uid = unpack.tu_uid; }
+      in
+      let (id, env) =
+        Env.enter_module_declaration ~scope unpack.tu_name.txt pres md env
+      in
+      Typetexp.widen context;
+      env, (id, unpack.tu_name, pres, modl) :: tunpacks
+    ) (env, []) unpacks
+  in
+  (* ideally, we should catch Expr_type_clash errors
+     in type_expect triggered by escaping identifiers from the local module
+     and refine them into Scoping_let_module errors
+  *)
+  let body = type_expect ?in_function extended_env sbody expected_ty in
+  let exp_loc = { body.exp_loc with loc_ghost = true } in
+  let exp_attributes = [Ast_helper.Attr.mk (mknoloc "#modulepat") (PStr [])] in
+  List.fold_left (fun body (id, name, pres, modl) ->
+    (* go back to parent level *)
+    end_def ();
+    Ctype.unify_var extended_env ty body.exp_type;
+    re {
+      exp_desc = Texp_letmodule(Some id, { name with txt = Some name.txt },
+                                pres, modl, body);
+      exp_loc;
+      exp_attributes;
+      exp_extra = [];
+      exp_type = ty;
+      exp_env = env }
+  ) body tunpacks
+
+(* Typing of match cases *)
+and type_cases
+    : type k . k pattern_category ->
+           ?in_function:_ -> _ -> _ -> _ -> _ -> _ -> Parsetree.case list ->
+           k case list * partial
+    = fun category ?in_function env
+        ty_arg ty_res_explained partial_flag loc caselist ->
+  let has_errors = Msupport.monitor_errors () in
+  (* ty_arg is _fully_ generalized *)
+  let { ty = ty_res; explanation } = ty_res_explained in
+  let patterns = List.map (fun {pc_lhs=p} -> p) caselist in
+  let contains_polyvars = List.exists contains_polymorphic_variant patterns in
+  let erase_either = contains_polyvars && contains_variant_either ty_arg in
+  let may_contain_gadts = List.exists may_contain_gadts patterns in
+  let ty_arg =
+    if (may_contain_gadts || erase_either) && not !Clflags.principal
+    then correct_levels ty_arg else ty_arg
+  in
+  let rec is_var spat =
+    match spat.ppat_desc with
+      Ppat_any | Ppat_var _ -> true
+    | Ppat_alias (spat, _) -> is_var spat
+    | _ -> false in
+  let needs_exhaust_check =
+    match caselist with
+      [{pc_rhs = {pexp_desc = Pexp_unreachable}}] -> true
+    | [{pc_lhs}] when is_var pc_lhs -> false
+    | _ -> true
+  in
+  let outer_level = get_current_level () in
+  let lev =
+    if may_contain_gadts then begin_def ();
+    get_current_level ()
+  in
+  let take_partial_instance =
+    if erase_either
+    then Some false else None
+  in
+  begin_def (); (* propagation of the argument *)
+  let pattern_force = ref [] in
+(*  Format.printf "@[%i %i@ %a@]@." lev (get_current_level())
+    Printtyp.raw_type_expr ty_arg; *)
+  let half_typed_cases =
+    List.map
+      (fun ({pc_lhs; pc_guard = _; pc_rhs = _} as case) ->
+        if !Clflags.principal then begin_def (); (* propagation of pattern *)
+        begin_def ();
+        let ty_arg = instance ?partial:take_partial_instance ty_arg in
+        end_def ();
+        generalize_structure ty_arg;
+        let (pat, ext_env, force, pvs, unpacks) =
+          type_pattern category ~lev env pc_lhs ty_arg
+        in
+        pattern_force := force @ !pattern_force;
+        let pat =
+          if !Clflags.principal then begin
+            end_def ();
+            iter_pattern_variables_type generalize_structure pvs;
+            { pat with pat_type = instance pat.pat_type }
+          end else pat
+        in
+        (* Ensure that no ambivalent pattern type escapes its branch *)
+        check_scope_escape pat.pat_loc env outer_level ty_arg;
+        { typed_pat = pat;
+          pat_type_for_unif = ty_arg;
+          untyped_case = case;
+          branch_env = ext_env;
+          pat_vars = pvs;
+          unpacks;
+          contains_gadt = contains_gadt (as_comp_pattern category pat); }
+        )
+      caselist in
+  let patl = List.map (fun { typed_pat; _ } -> typed_pat) half_typed_cases in
+  let does_contain_gadt =
+    List.exists (fun { contains_gadt; _ } -> contains_gadt) half_typed_cases
+  in
+  let ty_res, do_copy_types =
+    if does_contain_gadt && not !Clflags.principal then
+      correct_levels ty_res, Env.make_copy_of_types env
+    else ty_res, (fun env -> env)
+  in
+  (* Unify all cases (delayed to keep it order-free) *)
+  let ty_arg' = newvar () in
+  let unify_pats ty =
+    List.iter (fun { typed_pat = pat; pat_type_for_unif = pat_ty; _ } ->
+      unify_pat_types pat.pat_loc (ref env) pat_ty ty
+    ) half_typed_cases
+  in
+  unify_pats ty_arg';
+  (* Check for polymorphic variants to close *)
+  if List.exists has_variants patl then begin
+      Parmatch.pressure_variants_in_computation_pattern env
+        (List.map (as_comp_pattern category) patl);
+      List.iter finalize_variants patl
+  end;
+  (* `Contaminating' unifications start here *)
+  List.iter (fun f -> f()) !pattern_force;
+  (* Post-processing and generalization *)
+  if take_partial_instance <> None then unify_pats (instance ty_arg);
+  List.iter (fun { pat_vars; _ } ->
+    iter_pattern_variables_type (fun t -> unify_var env (newvar()) t) pat_vars
+  ) half_typed_cases;
+  end_def ();
+  generalize ty_arg';
+  List.iter (fun { pat_vars; _ } ->
+    iter_pattern_variables_type generalize pat_vars
+  ) half_typed_cases;
+  (* type bodies *)
+  let in_function = if List.length caselist = 1 then in_function else None in
+  let cases =
+    List.map
+      (fun { typed_pat = pat; branch_env = ext_env; pat_vars = pvs; unpacks;
+             untyped_case = {pc_lhs = _; pc_guard; pc_rhs};
+             contains_gadt; _ }  ->
+        let ext_env =
+          if contains_gadt then
+            do_copy_types ext_env
+          else
+            ext_env
+        in
+        let ext_env =
+          add_pattern_variables ext_env pvs
+            ~check:(fun s -> Warnings.Unused_var_strict s)
+            ~check_as:(fun s -> Warnings.Unused_var s)
+        in
+        let unpacks =
+          List.map (fun (name, loc) ->
+            {tu_name = name; tu_loc = loc;
+             tu_uid = Uid.mk ~current_unit:(Env.get_unit_name ())}
+          ) unpacks
+        in
+        let ty_res' =
+          if !Clflags.principal then begin
+            begin_def ();
+            let ty = instance ~partial:true ty_res in
+            end_def ();
+            generalize_structure ty; ty
+          end
+          else if contains_gadt then
+            (* allow propagation from preceding branches *)
+            correct_levels ty_res
+          else ty_res in
+        let guard =
+          match pc_guard with
+          | None -> None
+          | Some scond ->
+              Some
+                (type_unpacks ext_env unpacks scond
+                   (mk_expected ~explanation:When_guard Predef.type_bool))
+        in
+        let exp =
+          type_unpacks ?in_function ext_env
+            unpacks pc_rhs (mk_expected ?explanation ty_res')
+        in
+        {
+         c_lhs = pat;
+         c_guard = guard;
+         c_rhs = {exp with exp_type = instance ty_res'}
+        }
+      )
+      half_typed_cases
+  in
+  if !Clflags.principal || does_contain_gadt then begin
+    let ty_res' = instance ty_res in
+    List.iter (fun c -> unify_exp env c.c_rhs ty_res') cases
+  end;
+  let do_init = may_contain_gadts || needs_exhaust_check in
+  let ty_arg_check =
+    if do_init then
+      (* Hack: use for_saving to copy variables too *)
+      Subst.type_expr (Subst.for_saving Subst.identity) ty_arg'
+    else ty_arg'
+  in
+  let val_cases, exn_cases =
+    match category with
+      | Value -> (cases : value case list), []
+      | Computation -> split_cases env cases in
+  if val_cases = [] && exn_cases <> [] then
+    raise (error (loc, env, No_value_clauses));
+  let partial =
+    if partial_flag then
+      check_partial ~lev env ty_arg_check loc val_cases
+    else
+      Partial
+  in
+  let unused_check delayed =
+    List.iter (fun { typed_pat; branch_env; _ } ->
+      check_absent_variant branch_env (as_comp_pattern category typed_pat)
+    ) half_typed_cases;
+    if delayed then (begin_def (); init_def lev);
+    check_unused ~lev env ty_arg_check val_cases ;
+    check_unused ~lev env Predef.type_exn exn_cases ;
+    if delayed then end_def ();
+    Parmatch.check_ambiguous_bindings val_cases ;
+    Parmatch.check_ambiguous_bindings exn_cases
+  in
+  if not !has_errors then (
+    if contains_polyvars then
+      add_delayed_check (fun () -> unused_check true)
+    else
+      (* Check for unused cases, do not delay because of gadts *)
+      unused_check false
+  );
+  if may_contain_gadts then begin
+    end_def ();
+    (* Ensure that existential types do not escape *)
+    unify_exp_types loc env (instance ty_res) (newvar ()) ;
+  end;
+  cases, partial
+
+(* Typing of let bindings *)
+
+and type_let
+    ?(check = fun s -> Warnings.Unused_var s)
+    ?(check_strict = fun s -> Warnings.Unused_var_strict s)
+    existential_context
+    env rec_flag spat_sexp_list allow =
+  let open Ast_helper in
+  begin_def();
+  if !Clflags.principal then begin_def ();
+
+  let is_fake_let =
+    match spat_sexp_list with
+    | [{pvb_expr={pexp_desc=Pexp_match(
+           {pexp_desc=Pexp_ident({ txt = Longident.Lident "*opt*"})},_)}}] ->
+        true (* the fake let-declaration introduced by fun ?(x = e) -> ... *)
+    | _ ->
+        false
+  in
+  let check = if is_fake_let then check_strict else check in
+
+  let spatl =
+    List.map
+      (fun {pvb_pat=spat; pvb_expr=sexp; pvb_attributes=attrs} ->
+        attrs,
+        match spat.ppat_desc, sexp.pexp_desc with
+          (Ppat_any | Ppat_constraint _), _ -> spat
+        | _, Pexp_coerce (_, _, sty)
+        | _, Pexp_constraint (_, sty) when !Clflags.principal ->
+            (* propagate type annotation to pattern,
+               to allow it to be generalized in -principal mode *)
+            Pat.constraint_
+              ~loc:{spat.ppat_loc with Location.loc_ghost=true}
+              spat
+              sty
+        | _ -> spat)
+      spat_sexp_list in
+  let nvs = List.map (fun _ -> newvar ()) spatl in
+  let (pat_list, new_env, force, pvs, unpacks) =
+    type_pattern_list Value existential_context env spatl nvs allow in
+  let attrs_list = List.map fst spatl in
+  let is_recursive = (rec_flag = Recursive) in
+  (* If recursive, first unify with an approximation of the expression *)
+  if is_recursive then
+    List.iter2
+      (fun pat binding ->
+        let pat =
+          match pat.pat_type.desc with
+          | Tpoly (ty, tl) ->
+              {pat with pat_type =
+               snd (instance_poly ~keep_names:true false tl ty)}
+          | _ -> pat
+        in unify_pat (ref env) pat (type_approx env binding.pvb_expr))
+      pat_list spat_sexp_list;
+  (* Polymorphic variant processing *)
+  List.iter
+    (fun pat ->
+      if has_variants pat then begin
+        Parmatch.pressure_variants env [pat];
+        finalize_variants pat
+      end)
+    pat_list;
+  (* Generalize the structure *)
+  let pat_list =
+    if !Clflags.principal then begin
+      end_def ();
+      iter_pattern_variables_type generalize_structure pvs;
+      List.map (fun pat ->
+        generalize_structure pat.pat_type;
+        {pat with pat_type = instance pat.pat_type}
+      ) pat_list
+    end else
+      pat_list
+  in
+  (* Only bind pattern variables after generalizing *)
+  List.iter (fun f -> f()) force;
+  let sexp_is_fun { pvb_expr = sexp; _ } =
+    match sexp.pexp_desc with
+    | Pexp_fun _ | Pexp_function _ -> true
+    | _ -> false
+  in
+  let exp_env =
+    if is_recursive then new_env
+    else if List.for_all sexp_is_fun spat_sexp_list
+    then begin
+      (* Add ghost bindings to help detecting missing "rec" keywords.
+
+         We only add those if the body of the definition is obviously a
+         function. The rationale is that, in other cases, the hint is probably
+         wrong (and the user is using "advanced features" anyway (lazy,
+         recursive values...)).
+
+         [pvb_loc] (below) is the location of the first let-binding (in case of
+         a let .. and ..), and is where the missing "rec" hint suggests to add a
+         "rec" keyword. *)
+      match spat_sexp_list with
+      | {pvb_loc; _} :: _ -> maybe_add_pattern_variables_ghost pvb_loc env pvs
+      | _ -> assert false
+    end
+    else env in
+
+  let current_slot = ref None in
+  let rec_needed = ref false in
+  let warn_about_unused_bindings =
+    List.exists
+      (fun attrs ->
+         Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () ->
+           Warnings.is_active (check "") || Warnings.is_active (check_strict "")
+           || (is_recursive && (Warnings.is_active Warnings.Unused_rec_flag))))
+      attrs_list
+  in
+  let pat_slot_list =
+    (* Algorithm to detect unused declarations in recursive bindings:
+       - During type checking of the definitions, we capture the 'value_used'
+         events on the bound identifiers and record them in a slot corresponding
+         to the current definition (!current_slot).
+         In effect, this creates a dependency graph between definitions.
+
+       - After type checking the definition (!current_slot = None),
+         when one of the bound identifier is effectively used, we trigger
+         again all the events recorded in the corresponding slot.
+         The effect is to traverse the transitive closure of the graph created
+         in the first step.
+
+       We also keep track of whether *all* variables in a given pattern
+       are unused. If this is the case, for local declarations, the issued
+       warning is 26, not 27.
+     *)
+    List.map2
+      (fun attrs pat ->
+         Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () ->
+           if not warn_about_unused_bindings then pat, None
+           else
+             let some_used = ref false in
+             (* has one of the identifier of this pattern been used? *)
+             let slot = ref [] in
+             List.iter
+               (fun id ->
+                  let vd = Env.find_value (Path.Pident id) new_env in
+                  (* note: Env.find_value does not trigger the value_used
+                           event *)
+                  let name = Ident.name id in
+                  let used = ref false in
+                  if not (name = "" || name.[0] = '_' || name.[0] = '#') then
+                    add_delayed_check
+                      (fun () ->
+                         if not !used then
+                           Location.prerr_warning vd.Types.val_loc
+                             ((if !some_used then check_strict else check) name)
+                      );
+                  Env.set_value_used_callback
+                    vd
+                    (fun () ->
+                       match !current_slot with
+                       | Some slot ->
+                         slot := vd.val_uid :: !slot; rec_needed := true
+                       | None ->
+                         List.iter Env.mark_value_used (get_ref slot);
+                         used := true;
+                         some_used := true
+                    )
+               )
+               (Typedtree.pat_bound_idents pat);
+             pat, Some slot
+         ))
+      attrs_list
+      pat_list
+  in
+  let exp_list =
+    List.map2
+      (fun {pvb_expr=sexp; pvb_attributes; _} (pat, slot) ->
+        if is_recursive then current_slot := slot;
+        match pat.pat_type.desc with
+        | Tpoly (ty, tl) ->
+            if !Clflags.principal then begin_def ();
+            let vars, ty' = instance_poly ~keep_names:true true tl ty in
+            if !Clflags.principal then begin
+              end_def ();
+              generalize_structure ty'
+            end;
+            let exp =
+              Builtin_attributes.warning_scope pvb_attributes (fun () ->
+                if rec_flag = Recursive then
+                  type_unpacks exp_env unpacks sexp (mk_expected ty')
+                else
+                  type_expect exp_env sexp (mk_expected ty')
+              )
+            in
+            exp, Some vars
+        | _ ->
+            let exp =
+              Builtin_attributes.warning_scope pvb_attributes (fun () ->
+                  if rec_flag = Recursive then
+                    type_unpacks exp_env unpacks sexp (mk_expected pat.pat_type)
+                  else
+                    type_expect exp_env sexp (mk_expected pat.pat_type))
+            in
+            exp, None)
+      spat_sexp_list pat_slot_list in
+  current_slot := None;
+  if is_recursive && not !rec_needed then begin
+    let {pvb_pat; pvb_attributes} = List.hd spat_sexp_list in
+    (* See PR#6677 *)
+    Builtin_attributes.warning_scope ~ppwarning:false pvb_attributes
+      (fun () ->
+         Location.prerr_warning pvb_pat.ppat_loc Warnings.Unused_rec_flag
+      )
+  end;
+  List.iter2
+    (fun pat (attrs, exp) ->
+       Builtin_attributes.warning_scope ~ppwarning:false attrs
+         (fun () ->
+            ignore(check_partial env pat.pat_type pat.pat_loc
+                     [case pat exp])
+         )
+    )
+    pat_list
+    (List.map2 (fun (attrs, _) (e, _) -> attrs, e) spatl exp_list);
+  let pvs = List.map (fun pv -> { pv with pv_type = instance pv.pv_type}) pvs in
+  end_def();
+  List.iter2
+    (fun pat (exp, _) ->
+       if maybe_expansive exp then
+         lower_contravariant env pat.pat_type)
+    pat_list exp_list;
+  iter_pattern_variables_type generalize pvs;
+  List.iter2
+    (fun pat (exp, vars) ->
+       match vars with
+       | None ->
+         (* We generalize expressions even if they are not bound to a variable
+            and do not have an expliclit polymorphic type annotation.  This is
+            not needed in general, however those types may be shown by the
+            interactive toplevel, for example:
+            {[
+              let _ = Array.get;;
+              - : 'a array -> int -> 'a = <fun>
+            ]}
+            so we do it anyway. *)
+         generalize exp.exp_type
+       | Some vars ->
+           if maybe_expansive exp then
+             lower_contravariant env exp.exp_type;
+           generalize_and_check_univars env "definition" exp pat.pat_type vars)
+    pat_list exp_list;
+  let l = List.combine pat_list exp_list in
+  let l =
+    List.map2
+      (fun (p, (e, _)) pvb ->
+        {vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes;
+         vb_loc=pvb.pvb_loc;
+        })
+      l spat_sexp_list
+  in
+  if is_recursive then
+    List.iter
+      (fun {vb_pat=pat} -> match pat.pat_desc with
+           Tpat_var _ -> ()
+         | Tpat_alias ({pat_desc=Tpat_any}, _, _) -> ()
+         | _ -> raise(error(pat.pat_loc, env, Illegal_letrec_pat)))
+      l;
+  List.iter (function
+      | {vb_pat = {pat_desc = Tpat_any; pat_extra; _}; vb_expr; _} ->
+          if not (List.exists (function (Tpat_constraint _, _, _) -> true
+                                      | _ -> false) pat_extra) then
+            check_partial_application false vb_expr
+      | _ -> ()) l;
+  (l, new_env, unpacks)
+
+and type_andops env sarg sands expected_ty =
+  let rec loop env let_sarg rev_sands expected_ty =
+    match rev_sands with
+    | [] -> type_expect env let_sarg (mk_expected expected_ty), []
+    | { pbop_op = sop; pbop_exp = sexp; pbop_loc = loc; _ } :: rest ->
+        if !Clflags.principal then begin_def ();
+        let op_path, op_desc = type_binding_op_ident env sop in
+        let op_type = instance op_desc.val_type in
+        let ty_arg = newvar () in
+        let ty_rest = newvar () in
+        let ty_result = newvar() in
+        let ty_rest_fun = newty (Tarrow(Nolabel, ty_arg, ty_result, Cok)) in
+        let ty_op = newty (Tarrow(Nolabel, ty_rest, ty_rest_fun, Cok)) in
+        begin try
+          unify env op_type ty_op
+        with Unify trace ->
+          raise(error(sop.loc, env, Andop_type_clash(sop.txt, trace)))
+        end;
+        if !Clflags.principal then begin
+          end_def ();
+          generalize_structure ty_rest;
+          generalize_structure ty_arg;
+          generalize_structure ty_result
+        end;
+        let let_arg, rest = loop env let_sarg rest ty_rest in
+        let exp = type_expect env sexp (mk_expected ty_arg) in
+        begin try
+          unify env (instance ty_result) (instance expected_ty)
+        with Unify trace ->
+          raise(error(loc, env, Bindings_type_clash(trace)))
+        end;
+        let andop =
+          { bop_op_name = sop;
+            bop_op_path = op_path;
+            bop_op_val = op_desc;
+            bop_op_type = op_type;
+            bop_exp = exp;
+            bop_loc = loc }
+        in
+        let_arg, andop :: rest
+  in
+  let let_arg, rev_ands = loop env sarg (List.rev sands) expected_ty in
+  let_arg, List.rev rev_ands
+
+(* Typing of toplevel bindings *)
+
+let type_binding env rec_flag spat_sexp_list =
+  Typetexp.reset_type_variables();
+  let (pat_exp_list, new_env, _unpacks) =
+    type_let
+      ~check:(fun s -> Warnings.Unused_value_declaration s)
+      ~check_strict:(fun s -> Warnings.Unused_value_declaration s)
+      At_toplevel
+      env rec_flag spat_sexp_list false
+  in
+  (pat_exp_list, new_env)
+
+let type_let existential_ctx env rec_flag spat_sexp_list =
+  let (pat_exp_list, new_env, _unpacks) =
+    type_let existential_ctx env rec_flag spat_sexp_list false in
+  (pat_exp_list, new_env)
+
+(* Typing of toplevel expressions *)
+
+let type_expression env sexp =
+  Typetexp.reset_type_variables();
+  begin_def();
+  let exp = type_exp env sexp in
+  end_def();
+  if maybe_expansive exp then lower_contravariant env exp.exp_type;
+  generalize exp.exp_type;
+  match sexp.pexp_desc with
+    Pexp_ident lid ->
+      let loc = sexp.pexp_loc in
+      (* Special case for keeping type variables when looking-up a variable *)
+      let (_path, desc) = Env.lookup_value ~use:false ~loc lid.txt env in
+      {exp with exp_type = desc.val_type}
+  | _ -> exp
+
+(* Error report *)
+
+let spellcheck ppf unbound_name valid_names =
+  Misc.did_you_mean ppf (fun () ->
+    Misc.spellcheck valid_names unbound_name
+  )
+
+let spellcheck_idents ppf unbound valid_idents =
+  spellcheck ppf (Ident.name unbound) (List.map Ident.name valid_idents)
+
+open Format
+
+let longident = Printtyp.longident
+
+(* Returns the first diff of the trace *)
+let type_clash_of_trace trace =
+  Errortrace.(explain trace (fun ~prev:_ -> function
+    | Diff diff -> Some diff
+    | _ -> None
+  ))
+
+(* Hint on type error on integer literals
+   To avoid confusion, it is disabled on float literals
+   and when the expected type is `int` *)
+let report_literal_type_constraint expected_type const =
+  let const_str = match const with
+    | Const_int n -> Some (Int.to_string n)
+    | Const_int32 n -> Some (Int32.to_string n)
+    | Const_int64 n -> Some (Int64.to_string n)
+    | Const_nativeint n -> Some (Nativeint.to_string n)
+    | _ -> None
+  in
+  let suffix =
+    if Path.same expected_type Predef.path_int32 then
+      Some 'l'
+    else if Path.same expected_type Predef.path_int64 then
+      Some 'L'
+    else if Path.same expected_type Predef.path_nativeint then
+      Some 'n'
+    else if Path.same expected_type Predef.path_float then
+      Some '.'
+    else None
+  in
+  match const_str, suffix with
+  | Some c, Some s -> [ Location.msg "@[Hint: Did you mean `%s%c'?@]" c s ]
+  | _, _ -> []
+
+let report_literal_type_constraint const = function
+  | Some Errortrace.{ expected = { t = { desc = Tconstr (typ, [], _) } } } ->
+      report_literal_type_constraint typ const
+  | Some _ | None -> []
+
+let report_expr_type_clash_hints exp diff =
+  match exp with
+  | Some (Texp_constant const) -> report_literal_type_constraint const diff
+  | _ -> []
+
+let report_pattern_type_clash_hints
+      (type k) (pat : k pattern_desc option) diff =
+  match pat with
+  | Some (Tpat_constant const) -> report_literal_type_constraint const diff
+  | _ -> []
+
+let report_type_expected_explanation expl ppf =
+  let because expl_str = fprintf ppf "@ because it is in %s" expl_str in
+  match expl with
+  | If_conditional ->
+      because "the condition of an if-statement"
+  | If_no_else_branch ->
+      because "the result of a conditional with no else branch"
+  | While_loop_conditional ->
+      because "the condition of a while-loop"
+  | While_loop_body ->
+      because "the body of a while-loop"
+  | For_loop_start_index ->
+      because "a for-loop start index"
+  | For_loop_stop_index ->
+      because "a for-loop stop index"
+  | For_loop_body ->
+      because "the body of a for-loop"
+  | Assert_condition ->
+      because "the condition of an assertion"
+  | Sequence_left_hand_side ->
+      because "the left-hand side of a sequence"
+  | When_guard ->
+      because "a when-guard"
+
+let report_type_expected_explanation_opt expl ppf =
+  match expl with
+  | None -> ()
+  | Some expl -> report_type_expected_explanation expl ppf
+
+let report_unification_error ~loc ?sub env trace
+    ?type_expected_explanation txt1 txt2 =
+  Location.error_of_printer ~loc ?sub (fun ppf () ->
+    Printtyp.report_unification_error ppf env trace
+      ?type_expected_explanation txt1 txt2
+  ) ()
+
+let report_error ~loc env = function
+  | Constructor_arity_mismatch(lid, expected, provided) ->
+      Location.errorf ~loc
+       "@[The constructor %a@ expects %i argument(s),@ \
+        but is applied here to %i argument(s)@]"
+       longident lid expected provided
+  | Label_mismatch(lid, trace) ->
+      report_unification_error ~loc env trace
+        (function ppf ->
+           fprintf ppf "The record field %a@ belongs to the type"
+                   longident lid)
+        (function ppf ->
+           fprintf ppf "but is mixed here with fields of type")
+  | Pattern_type_clash (trace, pat) ->
+      let diff = type_clash_of_trace trace in
+      let sub = report_pattern_type_clash_hints pat diff in
+      report_unification_error ~loc ~sub env trace
+        (function ppf ->
+          fprintf ppf "This pattern matches values of type")
+        (function ppf ->
+          fprintf ppf "but a pattern was expected which matches values of \
+                       type");
+  | Or_pattern_type_clash (id, trace) ->
+      report_unification_error ~loc env trace
+        (function ppf ->
+          fprintf ppf "The variable %s on the left-hand side of this \
+                       or-pattern has type" (Ident.name id))
+        (function ppf ->
+          fprintf ppf "but on the right-hand side it has type")
+  | Multiply_bound_variable name ->
+      Location.errorf ~loc
+        "Variable %s is bound several times in this matching"
+        name
+  | Orpat_vars (id, valid_idents) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        fprintf ppf
+          "Variable %s must occur on both sides of this | pattern"
+          (Ident.name id);
+        spellcheck_idents ppf id valid_idents
+      ) ()
+  | Expr_type_clash (trace, explanation, exp) ->
+      let diff = type_clash_of_trace trace in
+      let sub = report_expr_type_clash_hints exp diff in
+      report_unification_error ~loc ~sub env trace
+        ~type_expected_explanation:
+          (report_type_expected_explanation_opt explanation)
+        (function ppf ->
+           fprintf ppf "This expression has type")
+        (function ppf ->
+           fprintf ppf "but an expression was expected of type");
+  | Apply_non_function typ ->
+      begin match (repr typ).desc with
+        Tarrow _ ->
+          Location.errorf ~loc
+            "@[<v>@[<2>This function has type@ %a@]\
+             @ @[It is applied to too many arguments;@ %s@]@]"
+            Printtyp.type_expr typ "maybe you forgot a `;'.";
+      | _ ->
+          Location.errorf ~loc "@[<v>@[<2>This expression has type@ %a@]@ %s@]"
+            Printtyp.type_expr typ
+            "This is not a function; it cannot be applied."
+      end
+  | Apply_wrong_label (l, ty, extra_info) ->
+      let print_label ppf = function
+        | Nolabel -> fprintf ppf "without label"
+        | l -> fprintf ppf "with label %s" (prefixed_label_name l)
+      in
+      let extra_info =
+        if not extra_info then
+          []
+        else
+          [ Location.msg
+              "Since OCaml 4.11, optional arguments do not commute when \
+               -nolabels is given" ]
+      in
+      Location.errorf ~loc ~sub:extra_info
+        "@[<v>@[<2>The function applied to this argument has type@ %a@]@.\
+         This argument cannot be applied %a@]"
+        Printtyp.type_expr ty print_label l
+  | Label_multiply_defined s ->
+      Location.errorf ~loc "The record field label %s is defined several times"
+        s
+  | Label_missing labels ->
+      let print_labels ppf =
+        List.iter (fun lbl -> fprintf ppf "@ %s" (Ident.name lbl)) in
+      Location.errorf ~loc "@[<hov>Some record fields are undefined:%a@]"
+        print_labels labels
+  | Label_not_mutable lid ->
+      Location.errorf ~loc "The record field %a is not mutable" longident lid
+  | Wrong_name (eorp, ty_expected, { type_path; kind; name; valid_names; }) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        Printtyp.wrap_printing_env ~error:true env (fun () ->
+          let { ty; explanation } = ty_expected in
+          if Path.is_constructor_typath type_path then begin
+            fprintf ppf
+              "@[The field %s is not part of the record \
+               argument for the %a constructor@]"
+              name.txt
+              Printtyp.type_path type_path;
+          end else begin
+            fprintf ppf
+              "@[@[<2>%s type@ %a%t@]@ \
+               There is no %s %s within type %a@]"
+              eorp Printtyp.type_expr ty
+              (report_type_expected_explanation_opt explanation)
+              (Datatype_kind.label_name kind)
+              name.txt (*kind*) Printtyp.type_path type_path;
+          end;
+          spellcheck ppf name.txt valid_names
+      )) ()
+  | Name_type_mismatch (kind, lid, tp, tpl) ->
+      let type_name = Datatype_kind.type_name kind in
+      let name = Datatype_kind.label_name kind in
+      Location.error_of_printer ~loc (fun ppf () ->
+        Printtyp.report_ambiguous_type_error ppf env tp tpl
+          (function ppf ->
+             fprintf ppf "The %s %a@ belongs to the %s type"
+               name longident lid type_name)
+          (function ppf ->
+             fprintf ppf "The %s %a@ belongs to one of the following %s types:"
+               name longident lid type_name)
+          (function ppf ->
+             fprintf ppf "but a %s was expected belonging to the %s type"
+               name type_name)
+      ) ()
+  | Invalid_format msg ->
+      Location.errorf ~loc "%s" msg
+  | Undefined_method (ty, me, valid_methods) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        Printtyp.wrap_printing_env ~error:true env (fun () ->
+          fprintf ppf
+            "@[<v>@[This expression has type@;<1 2>%a@]@,\
+             It has no method %s@]" Printtyp.type_expr ty me;
+          begin match valid_methods with
+            | None -> ()
+            | Some valid_methods -> spellcheck ppf me valid_methods
+          end
+      )) ()
+  | Undefined_inherited_method (me, valid_methods) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        fprintf ppf "This expression has no method %s" me;
+        spellcheck ppf me valid_methods;
+      ) ()
+  | Virtual_class cl ->
+      Location.errorf ~loc "Cannot instantiate the virtual class %a"
+        longident cl
+  | Unbound_instance_variable (var, valid_vars) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        fprintf ppf "Unbound instance variable %s" var;
+        spellcheck ppf var valid_vars;
+      ) ()
+  | Instance_variable_not_mutable v ->
+      Location.errorf ~loc "The instance variable %s is not mutable" v
+  | Not_subtype(tr1, tr2) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        Printtyp.Subtype.report_error ppf env tr1 "is not a subtype of" tr2
+      ) ()
+  | Outside_class ->
+      Location.errorf ~loc
+        "This object duplication occurs outside a method definition"
+  | Value_multiply_overridden v ->
+      Location.errorf ~loc
+        "The instance variable %s is overridden several times"
+        v
+  | Coercion_failure (ty, ty', trace, b) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        Printtyp.report_unification_error ppf env trace
+          (function ppf ->
+             let ty, ty' = Printtyp.prepare_expansion (ty, ty') in
+             fprintf ppf "This expression cannot be coerced to type@;<1 2>%a;@ \
+                          it has type"
+             (Printtyp.type_expansion ty) ty')
+          (function ppf ->
+             fprintf ppf "but is here used with type");
+        if b then
+          fprintf ppf ".@.@[<hov>%s@ %s@ %s@]"
+            "This simple coercion was not fully general."
+            "Hint: Consider using a fully explicit coercion"
+            "of the form: `(foo : ty1 :> ty2)'."
+      ) ()
+  | Too_many_arguments (in_function, ty, explanation) ->
+      if in_function then begin
+        Location.errorf ~loc
+          "This function expects too many arguments,@ \
+           it should have type@ %a%t"
+          Printtyp.type_expr ty
+          (report_type_expected_explanation_opt explanation)
+      end else begin
+        Location.errorf ~loc
+          "This expression should not be a function,@ \
+           the expected type is@ %a%t"
+          Printtyp.type_expr ty
+          (report_type_expected_explanation_opt explanation)
+      end
+  | Abstract_wrong_label (l, ty, explanation) ->
+      let label_mark = function
+        | Nolabel -> "but its first argument is not labelled"
+        | l -> sprintf "but its first argument is labelled %s"
+                       (prefixed_label_name l) in
+      Location.errorf ~loc
+        "@[<v>@[<2>This function should have type@ %a%t@]@,%s@]"
+        Printtyp.type_expr ty
+        (report_type_expected_explanation_opt explanation)
+        (label_mark l)
+  | Scoping_let_module(id, ty) ->
+      Location.errorf ~loc
+        "This `let module' expression has type@ %a@ \
+         In this type, the locally bound module name %s escapes its scope"
+        Printtyp.type_expr ty id
+  | Private_type ty ->
+      Location.errorf ~loc "Cannot create values of the private type %a"
+        Printtyp.type_expr ty
+  | Private_label (lid, ty) ->
+      Location.errorf ~loc "Cannot assign field %a of the private type %a"
+        longident lid Printtyp.type_expr ty
+  | Private_constructor (constr, ty) ->
+      Location.errorf ~loc
+        "Cannot use private constructor %s to create values of type %a"
+        constr.cstr_name Printtyp.type_expr ty
+  | Not_a_variant_type lid ->
+      Location.errorf ~loc "The type %a@ is not a variant type" longident lid
+  | Incoherent_label_order ->
+      Location.errorf ~loc
+        "This function is applied to arguments@ \
+        in an order different from other calls.@ \
+        This is only allowed when the real type is known."
+  | Less_general (kind, trace) ->
+      report_unification_error ~loc env trace
+        (fun ppf -> fprintf ppf "This %s has type" kind)
+        (fun ppf -> fprintf ppf "which is less general than")
+  | Modules_not_allowed ->
+      Location.errorf ~loc "Modules are not allowed in this pattern."
+  | Cannot_infer_signature ->
+      Location.errorf ~loc
+        "The signature for this packaged module couldn't be inferred."
+  | Not_a_packed_module ty ->
+      Location.errorf ~loc
+        "This expression is packed module, but the expected type is@ %a"
+        Printtyp.type_expr ty
+  | Unexpected_existential (reason, name, types) ->
+      let reason_str =
+        match reason with
+        | In_class_args ->
+            "Existential types are not allowed in class arguments"
+        | In_class_def ->
+            "Existential types are not allowed in bindings inside \
+             class definition"
+        | In_self_pattern ->
+            "Existential types are not allowed in self patterns"
+        | At_toplevel ->
+            "Existential types are not allowed in toplevel bindings"
+        | In_group ->
+            "Existential types are not allowed in \"let ... and ...\" bindings"
+        | In_rec ->
+            "Existential types are not allowed in recursive bindings"
+        | With_attributes ->
+            "Existential types are not allowed in presence of attributes"
+      in
+      begin match List.find (fun ty -> ty <> "$" ^ name) types with
+      | example ->
+          Location.errorf ~loc
+            "%s,@ but this pattern introduces the existential type %s."
+            reason_str example
+      | exception Not_found ->
+          Location.errorf ~loc
+            "%s,@ but the constructor %s introduces existential types."
+            reason_str name
+      end
+  | Invalid_interval ->
+      Location.errorf ~loc
+        "@[Only character intervals are supported in patterns.@]"
+  | Invalid_for_loop_index ->
+      Location.errorf ~loc
+        "@[Invalid for-loop index: only variables and _ are allowed.@]"
+  | No_value_clauses ->
+      Location.errorf ~loc
+        "None of the patterns in this 'match' expression match values."
+  | Exception_pattern_disallowed ->
+      Location.errorf ~loc
+        "@[Exception patterns are not allowed in this position.@]"
+  | Mixed_value_and_exception_patterns_under_guard ->
+      Location.errorf ~loc
+        "@[Mixing value and exception patterns under when-guards is not \
+         supported.@]"
+  | Inlined_record_escape ->
+      Location.errorf ~loc
+        "@[This form is not allowed as the type of the inlined record could \
+         escape.@]"
+  | Inlined_record_expected ->
+      Location.errorf ~loc
+        "@[This constructor expects an inlined record argument.@]"
+  | Unrefuted_pattern pat ->
+      Location.errorf ~loc
+        "@[%s@ %s@ %a@]"
+        "This match case could not be refuted."
+        "Here is an example of a value that would reach it:"
+        Printpat.top_pretty pat
+  | Invalid_extension_constructor_payload ->
+      Location.errorf ~loc
+        "Invalid [%%extension_constructor] payload, a constructor is expected."
+  | Not_an_extension_constructor ->
+      Location.errorf ~loc
+        "This constructor is not an extension constructor."
+  | Literal_overflow ty ->
+      Location.errorf ~loc
+        "Integer literal exceeds the range of representable integers of type %s"
+        ty
+  | Unknown_literal (n, m) ->
+      Location.errorf ~loc "Unknown modifier '%c' for literal %s%c" m n m
+  | Illegal_letrec_pat ->
+      Location.errorf ~loc
+        "Only variables are allowed as left-hand side of `let rec'"
+  | Illegal_letrec_expr ->
+      Location.errorf ~loc
+        "This kind of expression is not allowed as right-hand side of `let rec'"
+  | Illegal_class_expr ->
+      Location.errorf ~loc
+        "This kind of recursive class expression is not allowed"
+  | Letop_type_clash(name, trace) ->
+      report_unification_error ~loc env trace
+        (function ppf ->
+          fprintf ppf "The operator %s has type" name)
+        (function ppf ->
+          fprintf ppf "but it was expected to have type")
+  | Andop_type_clash(name, trace) ->
+      report_unification_error ~loc env trace
+        (function ppf ->
+          fprintf ppf "The operator %s has type" name)
+        (function ppf ->
+          fprintf ppf "but it was expected to have type")
+  | Bindings_type_clash(trace) ->
+      report_unification_error ~loc env trace
+        (function ppf ->
+          fprintf ppf "These bindings have type")
+        (function ppf ->
+          fprintf ppf "but bindings were expected of type")
+  | Unbound_existential (ids, ty) ->
+      Location.errorf ~loc
+        "@[<2>%s:@ @[type %s.@ %a@]@]"
+        "This type does not bind all existentials in the constructor"
+        (String.concat " " (List.map Ident.name ids))
+        Printtyp.type_expr ty
+  | Missing_type_constraint ->
+      Location.errorf ~loc
+        "@[%s@ %s@]"
+        "Existential types introduced in a constructor pattern"
+        "must be bound by a type constraint on the argument."
+
+let report_error ~loc env err =
+  Printtyp.wrap_printing_env ~error:true env
+    (fun () -> report_error ~loc env err)
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, env, err) ->
+        Some (report_error ~loc env err)
+      | Error_forward err ->
+        Some err
+      | _ ->
+        None
+    )
+
+let () =
+  Persistent_env.add_delayed_check_forward := add_delayed_check;
+  Env.add_delayed_check_forward := add_delayed_check;
+  ()
+
+(* drop ?recarg argument from the external API *)
+let type_expect ?in_function env e ty = type_expect ?in_function env e ty
+let type_exp env e = type_exp env e
+let type_argument env e t1 t2 = type_argument env e t1 t2
+
+(* Merlin specific *)
+let partial_pred =
+  let splitting_mode = Refine_or {inside_nonsplit_or = false} in
+  partial_pred ~splitting_mode
diff --git a/src/ocaml/typing/typecore.mli b/src/ocaml/typing/typecore.mli
new file mode 100644
index 0000000..4918d20
--- /dev/null
+++ b/src/ocaml/typing/typecore.mli
@@ -0,0 +1,236 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Type inference for the core language *)
+
+open Asttypes
+open Types
+
+(* This variant is used to print improved error messages, and does not affect
+   the behavior of the typechecker itself.
+
+   It describes possible explanation for types enforced by a keyword of the
+   language; e.g. "if" requires the condition to be of type bool, and the
+   then-branch to be of type unit if there is no else branch; "for" requires
+   indices to be of type int, and the body to be of type unit.
+*)
+type type_forcing_context =
+  | If_conditional
+  | If_no_else_branch
+  | While_loop_conditional
+  | While_loop_body
+  | For_loop_start_index
+  | For_loop_stop_index
+  | For_loop_body
+  | Assert_condition
+  | Sequence_left_hand_side
+  | When_guard
+
+(* The combination of a type and a "type forcing context". The intent is that it
+   describes a type that is "expected" (required) by the context. If unifying
+   with such a type fails, then the "explanation" field explains why it was
+   required, in order to display a more enlightening error message.
+*)
+type type_expected = private {
+  ty: type_expr;
+  explanation: type_forcing_context option;
+}
+
+val mk_expected:
+  ?explanation:type_forcing_context ->
+  type_expr ->
+  type_expected
+
+val is_nonexpansive: Typedtree.expression -> bool
+
+module Datatype_kind : sig
+  type t = Record | Variant
+  val type_name : t -> string
+  val label_name : t -> string
+end
+
+type wrong_name = {
+  type_path: Path.t;
+  kind: Datatype_kind.t;
+  name: string loc;
+  valid_names: string list;
+}
+
+type existential_restriction =
+  | At_toplevel (** no existential types at the toplevel *)
+  | In_group (** nor with [let ... and ...] *)
+  | In_rec (** or recursive definition *)
+  | With_attributes (** or [let[@any_attribute] = ...] *)
+  | In_class_args (** or in class arguments [class c (...) = ...] *)
+  | In_class_def (** or in [class c = let ... in ...] *)
+  | In_self_pattern (** or in self pattern *)
+
+val type_binding:
+        Env.t -> rec_flag ->
+          Parsetree.value_binding list ->
+          Typedtree.value_binding list * Env.t
+val type_let:
+        existential_restriction -> Env.t -> rec_flag ->
+          Parsetree.value_binding list ->
+          Typedtree.value_binding list * Env.t
+val type_expression:
+        Env.t -> Parsetree.expression -> Typedtree.expression
+val type_class_arg_pattern:
+        string -> Env.t -> Env.t -> arg_label -> Parsetree.pattern ->
+        Typedtree.pattern *
+        (Ident.t * Ident.t * type_expr) list *
+        Env.t * Env.t
+val type_self_pattern:
+        string -> type_expr -> Env.t -> Env.t -> Env.t -> Parsetree.pattern ->
+        Typedtree.pattern *
+        (Ident.t * type_expr) Meths.t ref *
+        (Ident.t * Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr)
+            Vars.t ref *
+        Env.t * Env.t * Env.t
+val check_partial:
+        ?lev:int -> Env.t -> type_expr ->
+        Location.t -> Typedtree.value Typedtree.case list -> Typedtree.partial
+val type_expect:
+        ?in_function:(Location.t * type_expr) ->
+        Env.t -> Parsetree.expression -> type_expected -> Typedtree.expression
+val type_exp:
+        Env.t -> Parsetree.expression -> Typedtree.expression
+val type_approx:
+        Env.t -> Parsetree.expression -> type_expr
+val type_argument:
+        Env.t -> Parsetree.expression ->
+        type_expr -> type_expr -> Typedtree.expression
+
+val option_some: Env.t -> Typedtree.expression -> Typedtree.expression
+val option_none: Env.t -> type_expr -> Location.t -> Typedtree.expression
+val extract_option_type: Env.t -> type_expr -> type_expr
+val generalizable: int -> type_expr -> bool
+type delayed_check
+val delayed_checks: delayed_check list ref
+val reset_delayed_checks: unit -> unit
+val force_delayed_checks: unit -> unit
+
+val name_pattern : string -> Typedtree.pattern list -> Ident.t
+val name_cases : string -> Typedtree.value Typedtree.case list -> Ident.t
+
+val self_coercion : (Path.t * Location.t list ref) list ref
+
+type error =
+  | Constructor_arity_mismatch of Longident.t * int * int
+  | Label_mismatch of Longident.t * Errortrace.unification Errortrace.t
+  | Pattern_type_clash :
+      Errortrace.unification Errortrace.t * _ Typedtree.pattern_desc option
+      -> error
+  | Or_pattern_type_clash of Ident.t * Errortrace.unification Errortrace.t
+  | Multiply_bound_variable of string
+  | Orpat_vars of Ident.t * Ident.t list
+  | Expr_type_clash of
+      Errortrace.unification Errortrace.t * type_forcing_context option
+      * Typedtree.expression_desc option
+  | Apply_non_function of type_expr
+  | Apply_wrong_label of arg_label * type_expr * bool
+  | Label_multiply_defined of string
+  | Label_missing of Ident.t list
+  | Label_not_mutable of Longident.t
+  | Wrong_name of string * type_expected * wrong_name
+  | Name_type_mismatch of
+      Datatype_kind.t * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list
+  | Invalid_format of string
+  | Undefined_method of type_expr * string * string list option
+  | Undefined_inherited_method of string * string list
+  | Virtual_class of Longident.t
+  | Private_type of type_expr
+  | Private_label of Longident.t * type_expr
+  | Private_constructor of constructor_description * type_expr
+  | Unbound_instance_variable of string * string list
+  | Instance_variable_not_mutable of string
+  | Not_subtype of Errortrace.Subtype.t * Errortrace.unification Errortrace.t
+  | Outside_class
+  | Value_multiply_overridden of string
+  | Coercion_failure of
+      type_expr * type_expr * Errortrace.unification Errortrace.t * bool
+  | Too_many_arguments of bool * type_expr * type_forcing_context option
+  | Abstract_wrong_label of arg_label * type_expr * type_forcing_context option
+  | Scoping_let_module of string * type_expr
+  | Not_a_variant_type of Longident.t
+  | Incoherent_label_order
+  | Less_general of string * Errortrace.unification Errortrace.t
+  | Modules_not_allowed
+  | Cannot_infer_signature
+  | Not_a_packed_module of type_expr
+  | Unexpected_existential of existential_restriction * string * string list
+  | Invalid_interval
+  | Invalid_for_loop_index
+  | No_value_clauses
+  | Exception_pattern_disallowed
+  | Mixed_value_and_exception_patterns_under_guard
+  | Inlined_record_escape
+  | Inlined_record_expected
+  | Unrefuted_pattern of Typedtree.pattern
+  | Invalid_extension_constructor_payload
+  | Not_an_extension_constructor
+  | Literal_overflow of string
+  | Unknown_literal of string * char
+  | Illegal_letrec_pat
+  | Illegal_letrec_expr
+  | Illegal_class_expr
+  | Letop_type_clash of string * Errortrace.unification Errortrace.t
+  | Andop_type_clash of string * Errortrace.unification Errortrace.t
+  | Bindings_type_clash of Errortrace.unification Errortrace.t
+  | Unbound_existential of Ident.t list * type_expr
+  | Missing_type_constraint
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+val report_error: loc:Location.t -> Env.t -> error -> Location.error
+ (** @deprecated.  Use {!Location.error_of_exn}, {!Location.print_report}. *)
+
+(* Forward declaration, to be filled in by Typemod.type_module *)
+val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref
+(* Forward declaration, to be filled in by Typemod.type_open *)
+val type_open:
+  (?used_slot:bool ref -> override_flag -> Env.t -> Location.t ->
+   Longident.t loc -> Path.t * Env.t)
+    ref
+(* Forward declaration, to be filled in by Typemod.type_open_decl *)
+val type_open_decl:
+  (?used_slot:bool ref -> Env.t -> Parsetree.open_declaration ->
+   Typedtree.open_declaration * Types.signature * Env.t)
+    ref
+(* Forward declaration, to be filled in by Typeclass.class_structure *)
+val type_object:
+  (Env.t -> Location.t -> Parsetree.class_structure ->
+   Typedtree.class_structure * Types.class_signature * string list) ref
+val type_package:
+  (Env.t -> Parsetree.module_expr -> Path.t -> (Longident.t * type_expr) list ->
+  Typedtree.module_expr * (Longident.t * type_expr) list) ref
+
+val constant: Parsetree.constant -> (Asttypes.constant, error) result
+
+val check_recursive_bindings : Env.t -> Typedtree.value_binding list -> unit
+val check_recursive_class_bindings :
+  Env.t -> Ident.t list -> Typedtree.class_expr list -> unit
+
+(* Merlin specific *)
+val partial_pred :
+  lev:int ->
+  ?explode:int ->
+  Env.t ->
+  type_expr ->
+  (label, constructor_description) Hashtbl.t ->
+  (label, label_description) Hashtbl.t ->
+  Parsetree.pattern ->
+  Typedtree.value Typedtree.pattern_desc Typedtree.pattern_data option
diff --git a/src/ocaml/typing/typedecl.ml b/src/ocaml/typing/typedecl.ml
new file mode 100644
index 0000000..3f059dc
--- /dev/null
+++ b/src/ocaml/typing/typedecl.ml
@@ -0,0 +1,1906 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(**** Typing of type definitions ****)
+
+open Misc
+open Asttypes
+open Parsetree
+open Primitive
+open Types
+open Typetexp
+
+module String = Misc.String
+
+type native_repr_kind = Unboxed | Untagged
+
+type error =
+    Repeated_parameter
+  | Duplicate_constructor of string
+  | Too_many_constructors
+  | Duplicate_label of string
+  | Recursive_abbrev of string
+  | Cycle_in_def of string * type_expr
+  | Definition_mismatch of type_expr * Includecore.type_mismatch option
+  | Constraint_failed of Env.t * Errortrace.unification Errortrace.t
+  | Inconsistent_constraint of Env.t * Errortrace.unification Errortrace.t
+  | Type_clash of Env.t * Errortrace.unification Errortrace.t
+  | Non_regular of {
+      definition: Path.t;
+      used_as: type_expr;
+      defined_as: type_expr;
+      expansions: (type_expr * type_expr) list;
+    }
+  | Null_arity_external
+  | Missing_native_external
+  | Unbound_type_var of type_expr * type_declaration
+  | Cannot_extend_private_type of Path.t
+  | Not_extensible_type of Path.t
+  | Extension_mismatch of Path.t * Includecore.type_mismatch
+  | Rebind_wrong_type of
+      Longident.t * Env.t * Errortrace.unification Errortrace.t
+  | Rebind_mismatch of Longident.t * Path.t * Path.t
+  | Rebind_private of Longident.t
+  | Variance of Typedecl_variance.error
+  | Unavailable_type_constructor of Path.t
+  | Unbound_type_var_ext of type_expr * extension_constructor
+  | Val_in_structure
+  | Multiple_native_repr_attributes
+  | Cannot_unbox_or_untag_type of native_repr_kind
+  | Deep_unbox_or_untag_attribute of native_repr_kind
+  | Immediacy of Typedecl_immediacy.error
+  | Separability of Typedecl_separability.error
+  | Bad_unboxed_attribute of string
+  | Boxed_and_unboxed
+  | Nonrec_gadt
+  | Invalid_private_row_declaration of type_expr
+
+open Typedtree
+
+exception Error of Location.t * error
+
+let get_unboxed_from_attributes sdecl =
+  let unboxed = Builtin_attributes.has_unboxed sdecl.ptype_attributes in
+  let boxed = Builtin_attributes.has_boxed sdecl.ptype_attributes in
+  match boxed, unboxed with
+  | true, true -> raise (Error(sdecl.ptype_loc, Boxed_and_unboxed))
+  | true, false -> Some false
+  | false, true -> Some true
+  | false, false -> None
+
+(* Enter all declared types in the environment as abstract types *)
+
+let add_type ~check id decl env =
+  Builtin_attributes.warning_scope ~ppwarning:false decl.type_attributes
+    (fun () -> Env.add_type ~check id decl env)
+
+let enter_type rec_flag env sdecl (id, uid) =
+  let needed =
+    match rec_flag with
+    | Asttypes.Nonrecursive ->
+        begin match sdecl.ptype_kind with
+        | Ptype_variant scds ->
+            List.iter (fun cd ->
+              if cd.pcd_res <> None then raise (Error(cd.pcd_loc, Nonrec_gadt)))
+              scds
+        | _ -> ()
+        end;
+        Btype.is_row_name (Ident.name id)
+    | Asttypes.Recursive -> true
+  in
+  let arity = List.length sdecl.ptype_params in
+  if not needed then env else
+  let decl =
+    { type_params =
+        List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params;
+      type_arity = arity;
+      type_kind = Type_abstract;
+      type_private = sdecl.ptype_private;
+      type_manifest =
+        begin match sdecl.ptype_manifest with None -> None
+        | Some _ -> Some(Ctype.newvar ()) end;
+      type_variance = Variance.unknown_signature ~injective:false ~arity;
+      type_separability = Types.Separability.default_signature ~arity;
+      type_is_newtype = false;
+      type_expansion_scope = Btype.lowest_level;
+      type_loc = sdecl.ptype_loc;
+      type_attributes = sdecl.ptype_attributes;
+      type_immediate = Unknown;
+      type_unboxed_default = false;
+      type_uid = uid;
+    }
+  in
+  add_type ~check:true id decl env
+
+let update_type temp_env env id loc =
+  let path = Path.Pident id in
+  let decl = Env.find_type path temp_env in
+  match decl.type_manifest with None -> ()
+  | Some ty ->
+      let params = List.map (fun _ -> Ctype.newvar ()) decl.type_params in
+      try Ctype.unify env (Ctype.newconstr path params) ty
+      with Ctype.Unify trace ->
+        raise (Error(loc, Type_clash (env, trace)))
+
+let get_unboxed_type_representation env ty =
+  match Typedecl_unboxed.get_unboxed_type_representation env ty with
+  | Typedecl_unboxed.This x -> Some x
+  | _ -> None
+
+(* Determine if a type's values are represented by floats at run-time. *)
+let is_float env ty =
+  match get_unboxed_type_representation env ty with
+    Some {desc = Tconstr(p, _, _); _} -> Path.same p Predef.path_float
+  | _ -> false
+
+(* Determine if a type definition defines a fixed type. (PW) *)
+let is_fixed_type sd =
+  let rec has_row_var sty =
+    match sty.ptyp_desc with
+      Ptyp_alias (sty, _) -> has_row_var sty
+    | Ptyp_class _
+    | Ptyp_object (_, Open)
+    | Ptyp_variant (_, Open, _)
+    | Ptyp_variant (_, Closed, Some _) -> true
+    | _ -> false
+  in
+  match sd.ptype_manifest with
+    None -> false
+  | Some sty ->
+      sd.ptype_kind = Ptype_abstract &&
+      sd.ptype_private = Private &&
+      has_row_var sty
+
+(* Set the row variable to a fixed type in a private row type declaration.
+   (e.g. [ type t = private [< `A | `B ] ] or [type u = private < .. > ])
+   Require [is_fixed_type decl] as a precondition
+*)
+let set_private_row env loc p decl =
+  let tm =
+    match decl.type_manifest with
+      None -> assert false
+    | Some t -> Ctype.expand_head env t
+  in
+  let rv =
+    match tm.desc with
+      Tvariant row ->
+        let row = Btype.row_repr row in
+        Btype.set_type_desc tm
+          (Tvariant {row with row_fixed = Some Fixed_private});
+        if Btype.static_row row then
+          (* the syntax hinted at the existence of a row variable,
+             but there is in fact no row variable to make private, e.g.
+             [ type t = private [< `A > `A] ] *)
+          raise (Error(loc, Invalid_private_row_declaration tm))
+        else row.row_more
+    | Tobject (ty, _) ->
+        let r = snd (Ctype.flatten_fields ty) in
+        if not (Btype.is_Tvar r) then
+          (* a syntactically open object was closed by a constraint *)
+          raise (Error(loc, Invalid_private_row_declaration tm));
+        r
+    | _ -> assert false
+  in
+  Btype.set_type_desc rv (Tconstr (p, decl.type_params, ref Mnil))
+
+(* Translate one type declaration *)
+
+let make_params env params =
+  let make_param (sty, v) =
+    try
+      (transl_type_param env sty, v)
+    with Already_bound ->
+      raise(Error(sty.ptyp_loc, Repeated_parameter))
+  in
+    List.map make_param params
+
+let transl_labels env closed lbls =
+  assert (lbls <> []);
+  let all_labels = ref String.Set.empty in
+  List.iter
+    (fun {pld_name = {txt=name; loc}} ->
+       if String.Set.mem name !all_labels then
+         raise(Error(loc, Duplicate_label name));
+       all_labels := String.Set.add name !all_labels)
+    lbls;
+  let mk {pld_name=name;pld_mutable=mut;pld_type=arg;pld_loc=loc;
+          pld_attributes=attrs} =
+    Builtin_attributes.warning_scope attrs
+      (fun () ->
+         let arg = Ast_helper.Typ.force_poly arg in
+         let cty = transl_simple_type env closed arg in
+         {ld_id = Ident.create_local name.txt;
+          ld_name = name; ld_mutable = mut;
+          ld_type = cty; ld_loc = loc; ld_attributes = attrs}
+      )
+  in
+  let lbls = List.map mk lbls in
+  let lbls' =
+    List.map
+      (fun ld ->
+         let ty = ld.ld_type.ctyp_type in
+         let ty = match ty.desc with Tpoly(t,[]) -> t | _ -> ty in
+         {Types.ld_id = ld.ld_id;
+          ld_mutable = ld.ld_mutable;
+          ld_type = ty;
+          ld_loc = ld.ld_loc;
+          ld_attributes = ld.ld_attributes;
+          ld_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+         }
+      )
+      lbls in
+  lbls, lbls'
+
+let transl_constructor_arguments env closed = function
+  | Pcstr_tuple l ->
+      let l = List.map (transl_simple_type env closed) l in
+      Types.Cstr_tuple (List.map (fun t -> t.ctyp_type) l),
+      Cstr_tuple l
+  | Pcstr_record l ->
+      let lbls, lbls' = transl_labels env closed l in
+      Types.Cstr_record lbls',
+      Cstr_record lbls
+
+let make_constructor env type_path type_params sargs sret_type =
+  match sret_type with
+  | None ->
+      let args, targs =
+        transl_constructor_arguments env true sargs
+      in
+        targs, None, args, None
+  | Some sret_type ->
+      (* if it's a generalized constructor we must first narrow and
+         then widen so as to not introduce any new constraints *)
+      let z = narrow () in
+      reset_type_variables ();
+      let args, targs =
+        transl_constructor_arguments env false sargs
+      in
+      let tret_type = transl_simple_type env false sret_type in
+      let ret_type = tret_type.ctyp_type in
+      (* TODO add back type_path as a parameter ? *)
+      begin match (Ctype.repr ret_type).desc with
+        | Tconstr (p', _, _) when Path.same type_path p' -> ()
+        | _ ->
+          raise (Error (sret_type.ptyp_loc,
+                        Constraint_failed
+                          (env, [Errortrace.diff
+                                   ret_type
+                                   (Ctype.newconstr type_path type_params)])))
+      end;
+      widen z;
+      targs, Some tret_type, args, Some ret_type
+
+let transl_declaration env sdecl (id, uid) =
+  (* Bind type parameters *)
+  reset_type_variables();
+  Ctype.begin_def ();
+  let tparams = make_params env sdecl.ptype_params in
+  let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in
+  let cstrs = List.map
+    (fun (sty, sty', loc) ->
+      transl_simple_type env false sty,
+      transl_simple_type env false sty', loc)
+    sdecl.ptype_cstrs
+  in
+  let unboxed_attr = get_unboxed_from_attributes sdecl in
+  begin match unboxed_attr with
+  | (None | Some false) -> ()
+  | Some true ->
+    let bad msg = raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute msg)) in
+    match sdecl.ptype_kind with
+    | Ptype_abstract    -> bad "it is abstract"
+    | Ptype_open        -> bad "extensible variant types cannot be unboxed"
+    | Ptype_record fields -> begin match fields with
+        | [] -> bad "it has no fields"
+        | _::_::_ -> bad "it has more than one field"
+        | [{pld_mutable = Mutable}] -> bad "it is mutable"
+        | [{pld_mutable = Immutable}] -> ()
+      end
+    | Ptype_variant constructors -> begin match constructors with
+        | [] -> bad "it has no constructor"
+        | (_::_::_) -> bad "it has more than one constructor"
+        | [c] -> begin match c.pcd_args with
+            | Pcstr_tuple [] ->
+                bad "its constructor has no argument"
+            | Pcstr_tuple (_::_::_) ->
+                bad "its constructor has more than one argument"
+            | Pcstr_tuple [_]  ->
+                ()
+            | Pcstr_record [] ->
+                bad "its constructor has no fields"
+            | Pcstr_record (_::_::_) ->
+                bad "its constructor has more than one field"
+            | Pcstr_record [{pld_mutable = Mutable}] ->
+                bad "it is mutable"
+            | Pcstr_record [{pld_mutable = Immutable}] ->
+                ()
+          end
+      end
+  end;
+  let unbox, unboxed_default =
+    match sdecl.ptype_kind with
+    | Ptype_variant [{pcd_args = Pcstr_tuple [_]; _}]
+    | Ptype_variant [{pcd_args = Pcstr_record [{pld_mutable=Immutable; _}]; _}]
+    | Ptype_record [{pld_mutable=Immutable; _}] ->
+      Option.value unboxed_attr ~default:!Clflags.unboxed_types,
+      Option.is_none unboxed_attr
+    | _ -> false, false (* Not unboxable, mark as boxed *)
+  in
+  let (tkind, kind) =
+    match sdecl.ptype_kind with
+      | Ptype_abstract -> Ttype_abstract, Type_abstract
+      | Ptype_variant scstrs ->
+        if List.exists (fun cstr -> cstr.pcd_res <> None) scstrs then begin
+          match cstrs with
+            [] -> ()
+          | (_,_,loc)::_ ->
+              Location.prerr_warning loc Warnings.Constraint_on_gadt
+        end;
+        let all_constrs = ref String.Set.empty in
+        List.iter
+          (fun {pcd_name = {txt = name}} ->
+            if String.Set.mem name !all_constrs then
+              raise(Error(sdecl.ptype_loc, Duplicate_constructor name));
+            all_constrs := String.Set.add name !all_constrs)
+          scstrs;
+        if List.length
+            (List.filter (fun cd -> cd.pcd_args <> Pcstr_tuple []) scstrs)
+           > (Config.max_tag + 1) then
+          raise(Error(sdecl.ptype_loc, Too_many_constructors));
+        let make_cstr scstr =
+          let name = Ident.create_local scstr.pcd_name.txt in
+          let targs, tret_type, args, ret_type =
+            make_constructor env (Path.Pident id) params
+                             scstr.pcd_args scstr.pcd_res
+          in
+          let tcstr =
+            { cd_id = name;
+              cd_name = scstr.pcd_name;
+              cd_args = targs;
+              cd_res = tret_type;
+              cd_loc = scstr.pcd_loc;
+              cd_attributes = scstr.pcd_attributes }
+          in
+          let cstr =
+            { Types.cd_id = name;
+              cd_args = args;
+              cd_res = ret_type;
+              cd_loc = scstr.pcd_loc;
+              cd_attributes = scstr.pcd_attributes;
+              cd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) }
+          in
+            tcstr, cstr
+        in
+        let make_cstr scstr =
+          Builtin_attributes.warning_scope scstr.pcd_attributes
+            (fun () -> make_cstr scstr)
+        in
+        let rep = if unbox then Variant_unboxed else Variant_regular in
+        let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in
+          Ttype_variant tcstrs, Type_variant (cstrs, rep)
+      | Ptype_record lbls ->
+          let lbls, lbls' = transl_labels env true lbls in
+          let rep =
+            if unbox then Record_unboxed false
+            else if List.for_all (fun l -> is_float env l.Types.ld_type) lbls'
+            then Record_float
+            else Record_regular
+          in
+          Ttype_record lbls, Type_record(lbls', rep)
+      | Ptype_open -> Ttype_open, Type_open
+      in
+    let (tman, man) = match sdecl.ptype_manifest with
+        None -> None, None
+      | Some sty ->
+        let no_row = not (is_fixed_type sdecl) in
+        let cty = transl_simple_type env no_row sty in
+        Some cty, Some cty.ctyp_type
+    in
+    let arity = List.length params in
+    let decl =
+      { type_params = params;
+        type_arity = arity;
+        type_kind = kind;
+        type_private = sdecl.ptype_private;
+        type_manifest = man;
+        type_variance = Variance.unknown_signature ~injective:false ~arity;
+        type_separability = Types.Separability.default_signature ~arity;
+        type_is_newtype = false;
+        type_expansion_scope = Btype.lowest_level;
+        type_loc = sdecl.ptype_loc;
+        type_attributes = sdecl.ptype_attributes;
+        type_immediate = Unknown;
+        type_unboxed_default = unboxed_default;
+        type_uid = uid;
+      } in
+
+  (* Check constraints *)
+    List.iter
+      (fun (cty, cty', loc) ->
+        let ty = cty.ctyp_type in
+        let ty' = cty'.ctyp_type in
+        try Ctype.unify env ty ty' with Ctype.Unify tr ->
+          raise(Error(loc, Inconsistent_constraint (env, tr))))
+      cstrs;
+    Ctype.end_def ();
+  (* Add abstract row *)
+    if is_fixed_type sdecl then begin
+      let p, _ =
+        try Env.find_type_by_name
+              (Longident.Lident(Ident.name id ^ "#row")) env
+        with Not_found -> assert false
+      in
+      set_private_row env sdecl.ptype_loc p decl
+    end;
+    {
+      typ_id = id;
+      typ_name = sdecl.ptype_name;
+      typ_params = tparams;
+      typ_type = decl;
+      typ_cstrs = cstrs;
+      typ_loc = sdecl.ptype_loc;
+      typ_manifest = tman;
+      typ_kind = tkind;
+      typ_private = sdecl.ptype_private;
+      typ_attributes = sdecl.ptype_attributes;
+    }
+
+(* Generalize a type declaration *)
+
+let generalize_decl decl =
+  List.iter Ctype.generalize decl.type_params;
+  Btype.iter_type_expr_kind Ctype.generalize decl.type_kind;
+  begin match decl.type_manifest with
+  | None    -> ()
+  | Some ty -> Ctype.generalize ty
+  end
+
+(* Check that all constraints are enforced *)
+
+module TypeSet = Btype.TypeSet
+module TypeMap = Btype.TypeMap
+
+let rec check_constraints_rec env loc visited ty =
+  let ty = Ctype.repr ty in
+  if TypeSet.mem ty !visited then () else begin
+  visited := TypeSet.add ty !visited;
+  match ty.desc with
+  | Tconstr (path, args, _) ->
+      let decl =
+        try Env.find_type path env
+        with Not_found ->
+          raise (Error(loc, Unavailable_type_constructor path)) in
+      let ty' = Ctype.newconstr path (Ctype.instance_list decl.type_params) in
+      begin
+        try Ctype.matches env ty ty'
+        with Ctype.Matches_failure (env, trace) ->
+          raise (Error(loc, Constraint_failed (env, trace)))
+      end;
+      List.iter (check_constraints_rec env loc visited) args
+  | Tpoly (ty, tl) ->
+      let _, ty = Ctype.instance_poly false tl ty in
+      check_constraints_rec env loc visited ty
+  | _ ->
+      Btype.iter_type_expr (check_constraints_rec env loc visited) ty
+  end
+
+let check_constraints_labels env visited l pl =
+  let rec get_loc name = function
+      [] -> assert false
+    | pld :: tl ->
+        if name = pld.pld_name.txt then pld.pld_type.ptyp_loc
+        else get_loc name tl
+  in
+  List.iter
+    (fun {Types.ld_id=name; ld_type=ty} ->
+       check_constraints_rec env (get_loc (Ident.name name) pl) visited ty)
+    l
+
+let check_constraints env sdecl (_, decl) =
+  let visited = ref TypeSet.empty in
+  List.iter2
+    (fun (sty, _) ty -> check_constraints_rec env sty.ptyp_loc visited ty)
+    sdecl.ptype_params decl.type_params;
+  begin match decl.type_kind with
+  | Type_abstract -> ()
+  | Type_variant (l, _rep) ->
+      let find_pl = function
+          Ptype_variant pl -> pl
+        | Ptype_record _ | Ptype_abstract | Ptype_open -> assert false
+      in
+      let pl = find_pl sdecl.ptype_kind in
+      let pl_index =
+        let foldf acc x =
+          String.Map.add x.pcd_name.txt x acc
+        in
+        List.fold_left foldf String.Map.empty pl
+      in
+      List.iter
+        (fun {Types.cd_id=name; cd_args; cd_res} ->
+          let {pcd_args; pcd_res; _} =
+            try String.Map.find (Ident.name name) pl_index
+            with Not_found -> assert false in
+          begin match cd_args, pcd_args with
+          | Cstr_tuple tyl, Pcstr_tuple styl ->
+              List.iter2
+                (fun sty ty ->
+                   check_constraints_rec env sty.ptyp_loc visited ty)
+                styl tyl
+          | Cstr_record tyl, Pcstr_record styl ->
+              check_constraints_labels env visited tyl styl
+          | _ -> assert false
+          end;
+          match pcd_res, cd_res with
+          | Some sr, Some r ->
+              check_constraints_rec env sr.ptyp_loc visited r
+          | _ ->
+              () )
+        l
+  | Type_record (l, _) ->
+      let find_pl = function
+          Ptype_record pl -> pl
+        | Ptype_variant _ | Ptype_abstract | Ptype_open -> assert false
+      in
+      let pl = find_pl sdecl.ptype_kind in
+      check_constraints_labels env visited l pl
+  | Type_open -> ()
+  end;
+  begin match decl.type_manifest with
+  | None -> ()
+  | Some ty ->
+      let sty =
+        match sdecl.ptype_manifest with Some sty -> sty | _ -> assert false
+      in
+      check_constraints_rec env sty.ptyp_loc visited ty
+  end
+
+(*
+   If both a variant/record definition and a type equation are given,
+   need to check that the equation refers to a type of the same kind
+   with the same constructors and labels.
+*)
+let check_coherence env loc dpath decl =
+  match decl with
+    { type_kind = (Type_variant _ | Type_record _| Type_open);
+      type_manifest = Some ty } ->
+      begin match (Ctype.repr ty).desc with
+        Tconstr(path, args, _) ->
+          begin try
+            let decl' = Env.find_type path env in
+            let err =
+              if List.length args <> List.length decl.type_params
+              then Some Includecore.Arity
+              else begin
+                match Ctype.equal env false args decl.type_params with
+                | exception Ctype.Equality trace ->
+                    Some (Includecore.Constraint (env, trace))
+                | () ->
+                    Includecore.type_declarations ~loc ~equality:true env
+                      ~mark:true
+                      (Path.last path)
+                      decl'
+                      dpath
+                      (Subst.type_declaration
+                         (Subst.add_type_path dpath path Subst.identity) decl)
+              end
+            in
+            if err <> None then
+              raise(Error(loc, Definition_mismatch (ty, err)))
+          with Not_found ->
+            raise(Error(loc, Unavailable_type_constructor path))
+          end
+      | _ -> raise(Error(loc, Definition_mismatch (ty, None)))
+      end
+  | _ -> ()
+
+let check_abbrev env sdecl (id, decl) =
+  check_coherence env sdecl.ptype_loc (Path.Pident id) decl
+
+(* Check that recursion is well-founded *)
+
+let check_well_founded env loc path to_check ty =
+  let visited = ref TypeMap.empty in
+  let rec check ty0 parents ty =
+    let ty = Btype.repr ty in
+    if TypeSet.mem ty parents then begin
+      (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*)
+      if match ty0.desc with
+      | Tconstr (p, _, _) -> Path.same p path
+      | _ -> false
+      then raise (Error (loc, Recursive_abbrev (Path.name path)))
+      else raise (Error (loc, Cycle_in_def (Path.name path, ty0)))
+    end;
+    let (fini, parents) =
+      try
+        let prev = TypeMap.find ty !visited in
+        if TypeSet.subset parents prev then (true, parents) else
+        (false, TypeSet.union parents prev)
+      with Not_found ->
+        (false, parents)
+    in
+    if fini then () else
+    let rec_ok =
+      match ty.desc with
+        Tconstr(p,_,_) ->
+          !Clflags.recursive_types && Ctype.is_contractive env p
+      | Tobject _ | Tvariant _ -> true
+      | _ -> !Clflags.recursive_types
+    in
+    let visited' = TypeMap.add ty parents !visited in
+    let arg_exn =
+      try
+        visited := visited';
+        let parents =
+          if rec_ok then TypeSet.empty else TypeSet.add ty parents in
+        Btype.iter_type_expr (check ty0 parents) ty;
+        None
+      with e ->
+        visited := visited'; Some e
+    in
+    match ty.desc with
+    | Tconstr(p, _, _) when arg_exn <> None || to_check p ->
+        if to_check p then Option.iter raise arg_exn
+        else Btype.iter_type_expr (check ty0 TypeSet.empty) ty;
+        begin try
+          let ty' = Ctype.try_expand_once_opt env ty in
+          let ty0 = if TypeSet.is_empty parents then ty else ty0 in
+          check ty0 (TypeSet.add ty parents) ty'
+        with
+          Ctype.Cannot_expand -> Option.iter raise arg_exn
+        end
+    | _ -> Option.iter raise arg_exn
+  in
+  let snap = Btype.snapshot () in
+  try Ctype.wrap_trace_gadt_instances env (check ty TypeSet.empty) ty
+  with Ctype.Escape _ ->
+    (* Will be detected by check_recursion *)
+    Btype.backtrack snap
+
+let check_well_founded_manifest env loc path decl =
+  if decl.type_manifest = None then () else
+  let args = List.map (fun _ -> Ctype.newvar()) decl.type_params in
+  check_well_founded env loc path (Path.same path) (Ctype.newconstr path args)
+
+let check_well_founded_decl env loc path decl to_check =
+  let open Btype in
+  let it =
+    {type_iterators with
+     it_type_expr = (fun _ -> check_well_founded env loc path to_check)} in
+  it.it_type_declaration it (Ctype.generic_instance_declaration decl)
+
+(* Check for ill-defined abbrevs *)
+
+let check_recursion ~orig_env env loc path decl to_check =
+  (* to_check is true for potentially mutually recursive paths.
+     (path, decl) is the type declaration to be checked. *)
+
+  if decl.type_params = [] then () else
+
+  let visited = ref [] in
+
+  let rec check_regular cpath args prev_exp prev_expansions ty =
+    let ty = Ctype.repr ty in
+    if not (List.memq ty !visited) then begin
+      visited := ty :: !visited;
+      match ty.desc with
+      | Tconstr(path', args', _) ->
+          if Path.same path path' then begin
+            if not (Ctype.is_equal orig_env false args args') then
+              raise (Error(loc,
+                     Non_regular {
+                       definition=path;
+                       used_as=ty;
+                       defined_as=Ctype.newconstr path args;
+                       expansions=List.rev prev_expansions;
+                     }))
+          end
+          (* Attempt to expand a type abbreviation if:
+              1- [to_check path'] holds
+                 (otherwise the expansion cannot involve [path]);
+              2- we haven't expanded this type constructor before
+                 (otherwise we could loop if [path'] is itself
+                 a non-regular abbreviation). *)
+          else if to_check path' && not (List.mem path' prev_exp) then begin
+            try
+              (* Attempt expansion *)
+              let (params0, body0, _) = Env.find_type_expansion path' env in
+              let (params, body) =
+                Ctype.instance_parameterized_type params0 body0 in
+              begin
+                try List.iter2 (Ctype.unify orig_env) params args'
+                with Ctype.Unify trace ->
+                  raise (Error(loc, Constraint_failed (orig_env, trace)));
+              end;
+              check_regular path' args
+                (path' :: prev_exp) ((ty,body) :: prev_expansions)
+                body
+            with Not_found -> ()
+          end;
+          List.iter (check_regular cpath args prev_exp prev_expansions) args'
+      | Tpoly (ty, tl) ->
+          let (_, ty) = Ctype.instance_poly ~keep_names:true false tl ty in
+          check_regular cpath args prev_exp prev_expansions ty
+      | _ ->
+          Btype.iter_type_expr
+            (check_regular cpath args prev_exp prev_expansions) ty
+    end in
+
+  Option.iter
+    (fun body ->
+      let (args, body) =
+        Ctype.instance_parameterized_type
+          ~keep_names:true decl.type_params body in
+      List.iter (check_regular path args [] []) args;
+      check_regular path args [] [] body)
+    decl.type_manifest
+
+let check_abbrev_recursion ~orig_env env id_loc_list to_check tdecl =
+  let decl = tdecl.typ_type in
+  let id = tdecl.typ_id in
+  check_recursion ~orig_env env (List.assoc id id_loc_list) (Path.Pident id)
+    decl to_check
+
+let check_duplicates sdecl_list =
+  let labels = Hashtbl.create 7 and constrs = Hashtbl.create 7 in
+  List.iter
+    (fun sdecl -> match sdecl.ptype_kind with
+      Ptype_variant cl ->
+        List.iter
+          (fun pcd ->
+            try
+              let name' = Hashtbl.find constrs pcd.pcd_name.txt in
+              Location.prerr_warning pcd.pcd_loc
+                (Warnings.Duplicate_definitions
+                   ("constructor", pcd.pcd_name.txt, name',
+                    sdecl.ptype_name.txt))
+            with Not_found ->
+              Hashtbl.add constrs pcd.pcd_name.txt sdecl.ptype_name.txt)
+          cl
+    | Ptype_record fl ->
+        List.iter
+          (fun {pld_name=cname;pld_loc=loc} ->
+            try
+              let name' = Hashtbl.find labels cname.txt in
+              Location.prerr_warning loc
+                (Warnings.Duplicate_definitions
+                   ("label", cname.txt, name', sdecl.ptype_name.txt))
+            with Not_found -> Hashtbl.add labels cname.txt sdecl.ptype_name.txt)
+          fl
+    | Ptype_abstract -> ()
+    | Ptype_open -> ())
+    sdecl_list
+
+(* Force recursion to go through id for private types*)
+let name_recursion sdecl id decl =
+  match decl with
+  | { type_kind = Type_abstract;
+      type_manifest = Some ty;
+      type_private = Private; } when is_fixed_type sdecl ->
+    let ty = Ctype.repr ty in
+    let ty' = Btype.newty2 ty.level ty.desc in
+    if Ctype.deep_occur ty ty' then
+      let td = Tconstr(Path.Pident id, decl.type_params, ref Mnil) in
+      Btype.link_type ty (Btype.newty2 ty.level td);
+      {decl with type_manifest = Some ty'}
+    else decl
+  | _ -> decl
+
+let name_recursion_decls sdecls decls =
+  List.map2 (fun sdecl (id, decl) -> (id, name_recursion sdecl id decl))
+    sdecls decls
+
+(* Warn on definitions of type "type foo = ()" which redefine a different unit
+   type and are likely a mistake. *)
+let check_redefined_unit (td: Parsetree.type_declaration) =
+  let open Parsetree in
+  let is_unit_constructor cd = cd.pcd_name.txt = "()" in
+  match td with
+  | { ptype_name = { txt = name };
+      ptype_manifest = None;
+      ptype_kind = Ptype_variant [ cd ] }
+    when is_unit_constructor cd ->
+      Location.prerr_warning td.ptype_loc (Warnings.Redefining_unit name)
+  | _ ->
+      ()
+
+let add_types_to_env decls env =
+  List.fold_right
+    (fun (id, decl) env -> add_type ~check:true id decl env)
+    decls env
+
+(* Translate a set of type declarations, mutually recursive or not *)
+let transl_type_decl env rec_flag sdecl_list =
+  List.iter check_redefined_unit sdecl_list;
+  (* Add dummy types for fixed rows *)
+  let fixed_types = List.filter is_fixed_type sdecl_list in
+  let sdecl_list =
+    List.map
+      (fun sdecl ->
+         let ptype_name =
+           let loc = { sdecl.ptype_name.loc with Location.loc_ghost = true } in
+           mkloc (sdecl.ptype_name.txt ^"#row") loc
+         in
+         let ptype_kind = Ptype_abstract in
+         let ptype_manifest = None in
+         let ptype_loc = { sdecl.ptype_loc with Location.loc_ghost = true } in
+        {sdecl with
+           ptype_name; ptype_kind; ptype_manifest; ptype_loc })
+      fixed_types
+    @ sdecl_list
+  in
+
+  (* Create identifiers. *)
+  let scope = Ctype.create_scope () in
+  let ids_list =
+    List.map (fun sdecl ->
+      Ident.create_scoped ~scope sdecl.ptype_name.txt,
+      Uid.mk ~current_unit:(Env.get_unit_name ())
+    ) sdecl_list
+  in
+  Ctype.begin_def();
+  (* Enter types. *)
+  let temp_env =
+    List.fold_left2 (enter_type rec_flag) env sdecl_list ids_list in
+  (* Translate each declaration. *)
+  let current_slot = ref None in
+  let warn_unused = Warnings.is_active (Warnings.Unused_type_declaration "") in
+  let ids_slots (id, _uid as ids) =
+    match rec_flag with
+    | Asttypes.Recursive when warn_unused ->
+        (* See typecore.ml for a description of the algorithm used
+             to detect unused declarations in a set of recursive definitions. *)
+        let slot = ref [] in
+        let td = Env.find_type (Path.Pident id) temp_env in
+        Env.set_type_used_callback
+          td
+          (fun old_callback ->
+             match !current_slot with
+             | Some slot -> slot := td.type_uid :: !slot
+             | None ->
+                 List.iter Env.mark_type_used (get_ref slot);
+                 old_callback ()
+          );
+        ids, Some slot
+    | Asttypes.Recursive | Asttypes.Nonrecursive ->
+        ids, None
+  in
+  let transl_declaration name_sdecl (id, slot) =
+    current_slot := slot;
+    Builtin_attributes.warning_scope
+      name_sdecl.ptype_attributes
+      (fun () -> transl_declaration temp_env name_sdecl id)
+  in
+  let tdecls =
+    List.map2 transl_declaration sdecl_list (List.map ids_slots ids_list) in
+  let decls =
+    List.map (fun tdecl -> (tdecl.typ_id, tdecl.typ_type)) tdecls in
+  current_slot := None;
+  (* Check for duplicates *)
+  check_duplicates sdecl_list;
+  (* Build the final env. *)
+  let new_env = add_types_to_env decls env in
+  (* Update stubs *)
+  begin match rec_flag with
+    | Asttypes.Nonrecursive -> ()
+    | Asttypes.Recursive ->
+      List.iter2
+        (fun (id, _) sdecl -> update_type temp_env new_env id sdecl.ptype_loc)
+        ids_list sdecl_list
+  end;
+  (* Generalize type declarations. *)
+  Ctype.end_def();
+  List.iter (fun (_, decl) -> generalize_decl decl) decls;
+  (* Check for ill-formed abbrevs *)
+  let id_loc_list =
+    List.map2 (fun (id, _) sdecl -> (id, sdecl.ptype_loc))
+      ids_list sdecl_list
+  in
+  List.iter (fun (id, decl) ->
+    check_well_founded_manifest new_env (List.assoc id id_loc_list)
+      (Path.Pident id) decl)
+    decls;
+  let to_check =
+    function Path.Pident id -> List.mem_assoc id id_loc_list | _ -> false in
+  List.iter (fun (id, decl) ->
+    check_well_founded_decl new_env (List.assoc id id_loc_list) (Path.Pident id)
+      decl to_check)
+    decls;
+  List.iter
+    (check_abbrev_recursion ~orig_env:env new_env id_loc_list to_check) tdecls;
+  (* Check that all type variables are closed *)
+  List.iter2
+    (fun sdecl tdecl ->
+      let decl = tdecl.typ_type in
+       match Ctype.closed_type_decl decl with
+         Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl)))
+       | None   -> ())
+    sdecl_list tdecls;
+  (* Check that constraints are enforced *)
+  List.iter2 (check_constraints new_env) sdecl_list decls;
+  (* Add type properties to declarations *)
+  let decls =
+    try
+      decls
+      |> name_recursion_decls sdecl_list
+      |> Typedecl_variance.update_decls env sdecl_list
+      |> Typedecl_immediacy.update_decls env
+      |> Typedecl_separability.update_decls env
+    with
+    | Typedecl_variance.Error (loc, err) ->
+        raise (Error (loc, Variance err))
+    | Typedecl_immediacy.Error (loc, err) ->
+        raise (Error (loc, Immediacy err))
+    | Typedecl_separability.Error (loc, err) ->
+        raise (Error (loc, Separability err))
+  in
+  (* Compute the final environment with variance and immediacy *)
+  let final_env = add_types_to_env decls env in
+  (* Check re-exportation *)
+  List.iter2 (check_abbrev final_env) sdecl_list decls;
+  (* Keep original declaration *)
+  let final_decls =
+    List.map2
+      (fun tdecl (_id2, decl) ->
+        { tdecl with typ_type = decl }
+      ) tdecls decls
+  in
+  (* Done *)
+  (final_decls, final_env)
+
+(* Translating type extensions *)
+
+let transl_extension_constructor ~scope env type_path type_params
+                                 typext_params priv sext =
+  let id = Ident.create_scoped ~scope sext.pext_name.txt in
+  let args, ret_type, kind =
+    match sext.pext_kind with
+      Pext_decl(sargs, sret_type) ->
+        let targs, tret_type, args, ret_type =
+          make_constructor env type_path typext_params
+            sargs sret_type
+        in
+          args, ret_type, Text_decl(targs, tret_type)
+    | Pext_rebind lid ->
+        let usage : Env.constructor_usage =
+          if priv = Public then Env.Exported else Env.Exported_private
+        in
+        let cdescr = Env.lookup_constructor ~loc:lid.loc usage lid.txt env in
+        let (args, cstr_res, _ex) = Ctype.instance_constructor cdescr in
+        let res, ret_type =
+          if cdescr.cstr_generalized then
+            let params = Ctype.instance_list type_params in
+            let res = Ctype.newconstr type_path params in
+            let ret_type = Some (Ctype.newconstr type_path params) in
+              res, ret_type
+          else (Ctype.newconstr type_path typext_params), None
+        in
+        begin
+          try
+            Ctype.unify env cstr_res res
+          with Ctype.Unify trace ->
+            raise (Error(lid.loc,
+                     Rebind_wrong_type(lid.txt, env, trace)))
+        end;
+        (* Remove "_" names from parameters used in the constructor *)
+        if not cdescr.cstr_generalized then begin
+          let vars =
+            Ctype.free_variables (Btype.newgenty (Ttuple args))
+          in
+            List.iter
+              (function {desc = Tvar (Some "_")} as ty
+                  when List.memq ty vars ->
+                    Btype.set_type_desc ty (Tvar None)
+                | _ -> ())
+              typext_params
+        end;
+        (* Ensure that constructor's type matches the type being extended *)
+        let cstr_type_path, cstr_type_params =
+          match cdescr.cstr_res.desc with
+            Tconstr (p, _, _) ->
+              let decl = Env.find_type p env in
+                p, decl.type_params
+          | _ -> assert false
+        in
+        let cstr_types =
+          (Btype.newgenty
+             (Tconstr(cstr_type_path, cstr_type_params, ref Mnil)))
+          :: cstr_type_params
+        in
+        let ext_types =
+          (Btype.newgenty
+             (Tconstr(type_path, type_params, ref Mnil)))
+          :: type_params
+        in
+        if not (Ctype.is_equal env true cstr_types ext_types) then
+          raise (Error(lid.loc,
+                       Rebind_mismatch(lid.txt, cstr_type_path, type_path)));
+        (* Disallow rebinding private constructors to non-private *)
+        begin
+          match cdescr.cstr_private, priv with
+            Private, Public ->
+              raise (Error(lid.loc, Rebind_private lid.txt))
+          | _ -> ()
+        end;
+        let path =
+          match cdescr.cstr_tag with
+            Cstr_extension(path, _) -> path
+          | _ -> assert false
+        in
+        let args =
+          match cdescr.cstr_inlined with
+          | None ->
+              Types.Cstr_tuple args
+          | Some decl ->
+              let tl =
+                match args with
+                | [ {desc=Tconstr(_, tl, _)} ] -> tl
+                | _ -> assert false
+              in
+              let decl = Ctype.instance_declaration decl in
+              assert (List.length decl.type_params = List.length tl);
+              List.iter2 (Ctype.unify env) decl.type_params tl;
+              let lbls =
+                match decl.type_kind with
+                | Type_record (lbls, Record_extension _) -> lbls
+                | _ -> assert false
+              in
+              Types.Cstr_record lbls
+        in
+        args, ret_type, Text_rebind(path, lid)
+  in
+  let ext =
+    { ext_type_path = type_path;
+      ext_type_params = typext_params;
+      ext_args = args;
+      ext_ret_type = ret_type;
+      ext_private = priv;
+      Types.ext_loc = sext.pext_loc;
+      Types.ext_attributes = sext.pext_attributes;
+      ext_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+    }
+  in
+    { ext_id = id;
+      ext_name = sext.pext_name;
+      ext_type = ext;
+      ext_kind = kind;
+      Typedtree.ext_loc = sext.pext_loc;
+      Typedtree.ext_attributes = sext.pext_attributes; }
+
+let transl_extension_constructor ~scope env type_path type_params
+    typext_params priv sext =
+  Builtin_attributes.warning_scope sext.pext_attributes
+    (fun () -> transl_extension_constructor ~scope env type_path type_params
+        typext_params priv sext)
+
+let is_rebind ext =
+  match ext.ext_kind with
+  | Text_rebind _ -> true
+  | Text_decl _ -> false
+
+let transl_type_extension extend env loc styext =
+  (* Note: it would be incorrect to call [create_scope] *after*
+     [reset_type_variables] or after [begin_def] (see #10010). *)
+  let scope = Ctype.create_scope () in
+  reset_type_variables();
+  Ctype.begin_def();
+  let type_path, type_decl =
+    let lid = styext.ptyext_path in
+    Env.lookup_type ~loc:lid.loc lid.txt env
+  in
+  begin
+    match type_decl.type_kind with
+    | Type_open -> begin
+        match type_decl.type_private with
+        | Private when extend -> begin
+            match
+              List.find
+                (function {pext_kind = Pext_decl _} -> true
+                        | {pext_kind = Pext_rebind _} -> false)
+                styext.ptyext_constructors
+            with
+            | {pext_loc} ->
+                raise (Error(pext_loc, Cannot_extend_private_type type_path))
+            | exception Not_found -> ()
+          end
+        | _ -> ()
+      end
+    | _ ->
+        raise (Error(loc, Not_extensible_type type_path))
+  end;
+  let type_variance =
+    List.map (fun v ->
+                let (co, cn) = Variance.get_upper v in
+                  (not cn, not co, false))
+             type_decl.type_variance
+  in
+  let err =
+    if type_decl.type_arity <> List.length styext.ptyext_params then
+      Some Includecore.Arity
+    else
+      if List.for_all2
+           (fun (c1, n1, _) (c2, n2, _) -> (not c2 || c1) && (not n2 || n1))
+           type_variance
+           (Typedecl_variance.variance_of_params styext.ptyext_params)
+      then None else Some Includecore.Variance
+  in
+  begin match err with
+  | None -> ()
+  | Some err -> raise (Error(loc, Extension_mismatch (type_path, err)))
+  end;
+  let ttype_params = make_params env styext.ptyext_params in
+  let type_params = List.map (fun (cty, _) -> cty.ctyp_type) ttype_params in
+  List.iter2 (Ctype.unify_var env)
+    (Ctype.instance_list type_decl.type_params)
+    type_params;
+  let constructors =
+    List.map (transl_extension_constructor ~scope env type_path
+               type_decl.type_params type_params styext.ptyext_private)
+      styext.ptyext_constructors
+  in
+  Ctype.end_def();
+  (* Generalize types *)
+  List.iter Ctype.generalize type_params;
+  List.iter
+    (fun ext ->
+       Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args;
+       Option.iter Ctype.generalize ext.ext_type.ext_ret_type)
+    constructors;
+  (* Check that all type variables are closed *)
+  List.iter
+    (fun ext ->
+       match Ctype.closed_extension_constructor ext.ext_type with
+         Some ty ->
+           raise(Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type)))
+       | None -> ())
+    constructors;
+  (* Check variances are correct *)
+  List.iter
+    (fun ext->
+       (* Note that [loc] here is distinct from [type_decl.type_loc], which
+          makes the [loc] parameter to this function useful. [loc] is the
+          location of the extension, while [type_decl] points to the original
+          type declaration being extended. *)
+       try Typedecl_variance.check_variance_extension
+             env type_decl ext (type_variance, loc)
+       with Typedecl_variance.Error (loc, err) ->
+         raise (Error (loc, Variance err)))
+    constructors;
+  (* Add extension constructors to the environment *)
+  let newenv =
+    List.fold_left
+      (fun env ext ->
+         let rebind = is_rebind ext in
+         Env.add_extension ~check:true ~rebind ext.ext_id ext.ext_type env)
+      env constructors
+  in
+  let tyext =
+    { tyext_path = type_path;
+      tyext_txt = styext.ptyext_path;
+      tyext_params = ttype_params;
+      tyext_constructors = constructors;
+      tyext_private = styext.ptyext_private;
+      tyext_loc = styext.ptyext_loc;
+      tyext_attributes = styext.ptyext_attributes; }
+  in
+    (tyext, newenv)
+
+let transl_type_extension extend env loc styext =
+  Builtin_attributes.warning_scope styext.ptyext_attributes
+    (fun () -> transl_type_extension extend env loc styext)
+
+let transl_exception env sext =
+  let scope = Ctype.create_scope () in
+  reset_type_variables();
+  Ctype.begin_def();
+  let ext =
+    transl_extension_constructor ~scope env
+      Predef.path_exn [] [] Asttypes.Public sext
+  in
+  Ctype.end_def();
+  (* Generalize types *)
+  Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args;
+  Option.iter Ctype.generalize ext.ext_type.ext_ret_type;
+  (* Check that all type variables are closed *)
+  begin match Ctype.closed_extension_constructor ext.ext_type with
+    Some ty ->
+      raise (Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type)))
+  | None -> ()
+  end;
+  let rebind = is_rebind ext in
+  let newenv =
+    Env.add_extension ~check:true ~rebind ext.ext_id ext.ext_type env
+  in
+  ext, newenv
+
+let transl_type_exception env t =
+  Builtin_attributes.check_no_alert t.ptyexn_attributes;
+  let contructor, newenv =
+    Builtin_attributes.warning_scope t.ptyexn_attributes
+      (fun () ->
+         transl_exception env t.ptyexn_constructor
+      )
+  in
+  {tyexn_constructor = contructor;
+   tyexn_loc = t.ptyexn_loc;
+   tyexn_attributes = t.ptyexn_attributes}, newenv
+
+
+type native_repr_attribute =
+  | Native_repr_attr_absent
+  | Native_repr_attr_present of native_repr_kind
+
+let get_native_repr_attribute attrs ~global_repr =
+  match
+    Attr_helper.get_no_payload_attribute ["unboxed"; "ocaml.unboxed"]  attrs,
+    Attr_helper.get_no_payload_attribute ["untagged"; "ocaml.untagged"] attrs,
+    global_repr
+  with
+  | None, None, None -> Native_repr_attr_absent
+  | None, None, Some repr -> Native_repr_attr_present repr
+  | Some _, None, None -> Native_repr_attr_present Unboxed
+  | None, Some _, None -> Native_repr_attr_present Untagged
+  | Some { Location.loc }, _, _
+  | _, Some { Location.loc }, _ ->
+    raise (Error (loc, Multiple_native_repr_attributes))
+
+let native_repr_of_type env kind ty =
+  match kind, (Ctype.expand_head_opt env ty).desc with
+  | Untagged, Tconstr (path, _, _) when Path.same path Predef.path_int ->
+    Some Untagged_int
+  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_float ->
+    Some Unboxed_float
+  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int32 ->
+    Some (Unboxed_integer Pint32)
+  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int64 ->
+    Some (Unboxed_integer Pint64)
+  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_nativeint ->
+    Some (Unboxed_integer Pnativeint)
+  | _ ->
+    None
+
+(* Raises an error when [core_type] contains an [@unboxed] or [@untagged]
+   attribute in a strict sub-term. *)
+let error_if_has_deep_native_repr_attributes core_type =
+  let open Ast_iterator in
+  let this_iterator =
+    { default_iterator with typ = fun iterator core_type ->
+      begin
+        match
+          get_native_repr_attribute core_type.ptyp_attributes ~global_repr:None
+        with
+        | Native_repr_attr_present kind ->
+           raise (Error (core_type.ptyp_loc,
+                         Deep_unbox_or_untag_attribute kind))
+        | Native_repr_attr_absent -> ()
+      end;
+      default_iterator.typ iterator core_type }
+  in
+  default_iterator.typ this_iterator core_type
+
+let make_native_repr env core_type ty ~global_repr =
+  error_if_has_deep_native_repr_attributes core_type;
+  match get_native_repr_attribute core_type.ptyp_attributes ~global_repr with
+  | Native_repr_attr_absent ->
+    Same_as_ocaml_repr
+  | Native_repr_attr_present kind ->
+    begin match native_repr_of_type env kind ty with
+    | None ->
+      raise (Error (core_type.ptyp_loc, Cannot_unbox_or_untag_type kind))
+    | Some repr -> repr
+    end
+
+let rec parse_native_repr_attributes env core_type ty ~global_repr =
+  match core_type.ptyp_desc, (Ctype.repr ty).desc,
+    get_native_repr_attribute core_type.ptyp_attributes ~global_repr:None
+  with
+  | Ptyp_arrow _, Tarrow _, Native_repr_attr_present kind  ->
+    raise (Error (core_type.ptyp_loc, Cannot_unbox_or_untag_type kind))
+  | Ptyp_arrow (_, ct1, ct2), Tarrow (_, t1, t2, _), _ ->
+    let repr_arg = make_native_repr env ct1 t1 ~global_repr in
+    let repr_args, repr_res =
+      parse_native_repr_attributes env ct2 t2 ~global_repr
+    in
+    (repr_arg :: repr_args, repr_res)
+  | Ptyp_arrow _, _, _ | _, Tarrow _, _ -> assert false
+  | _ -> ([], make_native_repr env core_type ty ~global_repr)
+
+
+let check_unboxable env loc ty =
+  let check_type acc ty : Path.Set.t =
+    let ty = Ctype.repr (Ctype.expand_head_opt env ty) in
+    try match ty.desc with
+      | Tconstr (p, _, _) ->
+        let tydecl = Env.find_type p env in
+        if tydecl.type_unboxed_default then
+          Path.Set.add p acc
+        else acc
+      | _ -> acc
+    with Not_found -> acc
+  in
+  let all_unboxable_types = Btype.fold_type_expr check_type Path.Set.empty ty in
+  Path.Set.fold
+    (fun p () ->
+       let p = Printtyp.shorten_type_path env p in
+       Location.prerr_warning loc
+         (Warnings.Unboxable_type_in_prim_decl (Path.name p))
+    )
+    all_unboxable_types
+    ()
+
+(* Translate a value declaration *)
+let transl_value_decl env loc valdecl =
+  let cty = Typetexp.transl_type_scheme env valdecl.pval_type in
+  let ty = cty.ctyp_type in
+  let v =
+  match valdecl.pval_prim with
+    [] when Env.is_in_signature env ->
+      { val_type = ty; val_kind = Val_reg; Types.val_loc = loc;
+        val_attributes = valdecl.pval_attributes;
+        val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+      }
+  | [] ->
+      raise (Error(valdecl.pval_loc, Val_in_structure))
+  | _ ->
+      let global_repr =
+        match
+          get_native_repr_attribute valdecl.pval_attributes ~global_repr:None
+        with
+        | Native_repr_attr_present repr -> Some repr
+        | Native_repr_attr_absent -> None
+      in
+      let native_repr_args, native_repr_res =
+        parse_native_repr_attributes env valdecl.pval_type ty ~global_repr
+      in
+      let prim =
+        Primitive.parse_declaration valdecl
+          ~native_repr_args
+          ~native_repr_res
+      in
+      (*
+      if prim.prim_arity = 0 &&
+         (prim.prim_name = "" || prim.prim_name.[0] <> '%') then
+        raise(Error(valdecl.pval_type.ptyp_loc, Null_arity_external));
+      *)
+      if !Clflags.native_code
+      && prim.prim_arity > 5
+      && prim.prim_native_name = ""
+      then raise(Error(valdecl.pval_type.ptyp_loc, Missing_native_external));
+      check_unboxable env loc ty;
+      { val_type = ty; val_kind = Val_prim prim; Types.val_loc = loc;
+        val_attributes = valdecl.pval_attributes;
+        val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+      }
+  in
+  let (id, newenv) =
+    Env.enter_value valdecl.pval_name.txt v env
+      ~check:(fun s -> Warnings.Unused_value_declaration s)
+  in
+  let desc =
+    {
+     val_id = id;
+     val_name = valdecl.pval_name;
+     val_desc = cty; val_val = v;
+     val_prim = valdecl.pval_prim;
+     val_loc = valdecl.pval_loc;
+     val_attributes = valdecl.pval_attributes;
+    }
+  in
+  desc, newenv
+
+let transl_value_decl env loc valdecl =
+  Builtin_attributes.warning_scope valdecl.pval_attributes
+    (fun () -> transl_value_decl env loc valdecl)
+
+(* Translate a "with" constraint -- much simplified version of
+   transl_type_decl. For a constraint [Sig with t = sdecl],
+   there are two declarations of interest in two environments:
+   - [sig_decl] is the declaration of [t] in [Sig],
+     in the environment [sig_env] (containing the declarations
+     of [Sig] before [t])
+   - [sdecl] is the new syntactic declaration, to be type-checked
+     in the current, outer environment [with_env].
+
+   In particular, note that [sig_env] is an extension of
+   [outer_env].
+*)
+let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env
+    sdecl =
+  Env.mark_type_used sig_decl.type_uid;
+  reset_type_variables();
+  Ctype.begin_def();
+  (* In the first part of this function, we typecheck the syntactic
+     declaration [sdecl] in the outer environment [outer_env]. *)
+  let env = outer_env in
+  let loc = sdecl.ptype_loc in
+  let tparams = make_params env sdecl.ptype_params in
+  let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in
+  let arity = List.length params in
+  let constraints =
+    List.map (fun (ty, ty', loc) ->
+      let cty = transl_simple_type env false ty in
+      let cty' = transl_simple_type env false ty' in
+      (* Note: We delay the unification of those constraints
+         after the unification of parameters, so that clashing
+         constraints report an error on the constraint location
+         rather than the parameter location. *)
+      (cty, cty', loc)
+    ) sdecl.ptype_cstrs
+  in
+  let no_row = not (is_fixed_type sdecl) in
+  let (tman, man) =  match sdecl.ptype_manifest with
+      None -> None, None
+    | Some sty ->
+        let cty = transl_simple_type env no_row sty in
+        Some cty, Some cty.ctyp_type
+  in
+  (* In the second part, we check the consistency between the two
+     declarations and compute a "merged" declaration; we now need to
+     work in the larger signature environment [sig_env], because
+     [sig_decl.type_params] and [sig_decl.type_kind] are only valid
+     there. *)
+  let env = sig_env in
+  let sig_decl = Ctype.instance_declaration sig_decl in
+  let arity_ok = arity = sig_decl.type_arity in
+  if arity_ok then
+    List.iter2 (fun (cty, _) tparam ->
+      try Ctype.unify_var env cty.ctyp_type tparam
+      with Ctype.Unify tr ->
+        raise(Error(cty.ctyp_loc, Inconsistent_constraint (env, tr)))
+    ) tparams sig_decl.type_params;
+  List.iter (fun (cty, cty', loc) ->
+    (* Note: constraints must also be enforced in [sig_env] because
+       they may contain parameter variables from [tparams]
+       that have now be unified in [sig_env]. *)
+    try Ctype.unify env cty.ctyp_type cty'.ctyp_type
+    with Ctype.Unify tr ->
+      raise(Error(loc, Inconsistent_constraint (env, tr)))
+  ) constraints;
+  let priv =
+    if sdecl.ptype_private = Private then Private else
+    if arity_ok && sig_decl.type_kind <> Type_abstract
+    then sig_decl.type_private else sdecl.ptype_private
+  in
+  if arity_ok && sig_decl.type_kind <> Type_abstract
+  && sdecl.ptype_private = Private then
+    Location.deprecated loc "spurious use of private";
+  let type_kind, type_unboxed_default =
+    if arity_ok && man <> None then
+      sig_decl.type_kind, sig_decl.type_unboxed_default
+    else
+      Type_abstract, false
+  in
+  let new_sig_decl =
+    { type_params = params;
+      type_arity = arity;
+      type_kind;
+      type_private = priv;
+      type_manifest = man;
+      type_variance = [];
+      type_separability = Types.Separability.default_signature ~arity;
+      type_is_newtype = false;
+      type_expansion_scope = Btype.lowest_level;
+      type_loc = loc;
+      type_attributes = sdecl.ptype_attributes;
+      type_immediate = Unknown;
+      type_unboxed_default;
+      type_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+    }
+  in
+  Option.iter (fun p -> set_private_row env sdecl.ptype_loc p new_sig_decl)
+    fixed_row_path;
+  begin match Ctype.closed_type_decl new_sig_decl with None -> ()
+  | Some ty -> raise(Error(loc, Unbound_type_var(ty, new_sig_decl)))
+  end;
+  let new_sig_decl = name_recursion sdecl id new_sig_decl in
+  let new_type_variance =
+    let required = Typedecl_variance.variance_of_sdecl sdecl in
+    try
+      Typedecl_variance.compute_decl env ~check:true new_sig_decl required
+    with Typedecl_variance.Error (loc, err) ->
+      raise (Error (loc, Variance err)) in
+  let new_type_immediate =
+    (* Typedecl_immediacy.compute_decl never raises *)
+    Typedecl_immediacy.compute_decl env new_sig_decl in
+  let new_type_separability =
+    try Typedecl_separability.compute_decl env new_sig_decl
+    with Typedecl_separability.Error (loc, err) ->
+      raise (Error (loc, Separability err)) in
+  let new_sig_decl =
+    (* we intentionally write this without a fragile { decl with ... }
+       to ensure that people adding new fields to type declarations
+       consider whether they need to recompute it here; for an example
+       of bug caused by the previous approach, see #9607 *)
+    {
+      type_params = new_sig_decl.type_params;
+      type_arity = new_sig_decl.type_arity;
+      type_kind = new_sig_decl.type_kind;
+      type_private = new_sig_decl.type_private;
+      type_manifest = new_sig_decl.type_manifest;
+      type_unboxed_default = new_sig_decl.type_unboxed_default;
+      type_is_newtype = new_sig_decl.type_is_newtype;
+      type_expansion_scope = new_sig_decl.type_expansion_scope;
+      type_loc = new_sig_decl.type_loc;
+      type_attributes = new_sig_decl.type_attributes;
+      type_uid = new_sig_decl.type_uid;
+
+      type_variance = new_type_variance;
+      type_immediate = new_type_immediate;
+      type_separability = new_type_separability;
+    } in
+  Ctype.end_def();
+  generalize_decl new_sig_decl;
+  {
+    typ_id = id;
+    typ_name = sdecl.ptype_name;
+    typ_params = tparams;
+    typ_type = new_sig_decl;
+    typ_cstrs = constraints;
+    typ_loc = loc;
+    typ_manifest = tman;
+    typ_kind = Ttype_abstract;
+    typ_private = sdecl.ptype_private;
+    typ_attributes = sdecl.ptype_attributes;
+  }
+
+(* Approximate a type declaration: just make all types abstract *)
+
+let abstract_type_decl ~injective arity =
+  let rec make_params n =
+    if n <= 0 then [] else Ctype.newvar() :: make_params (n-1) in
+  Ctype.begin_def();
+  let decl =
+    { type_params = make_params arity;
+      type_arity = arity;
+      type_kind = Type_abstract;
+      type_private = Public;
+      type_manifest = None;
+      type_variance = Variance.unknown_signature ~injective ~arity;
+      type_separability = Types.Separability.default_signature ~arity;
+      type_is_newtype = false;
+      type_expansion_scope = Btype.lowest_level;
+      type_loc = Location.none;
+      type_attributes = [];
+      type_immediate = Unknown;
+      type_unboxed_default = false;
+      type_uid = Uid.internal_not_actually_unique;
+     } in
+  Ctype.end_def();
+  generalize_decl decl;
+  decl
+
+let approx_type_decl sdecl_list =
+  let scope = Ctype.create_scope () in
+  List.map
+    (fun sdecl ->
+      let injective = sdecl.ptype_kind <> Ptype_abstract in
+      (Ident.create_scoped ~scope sdecl.ptype_name.txt,
+       abstract_type_decl ~injective (List.length sdecl.ptype_params)))
+    sdecl_list
+
+(* Variant of check_abbrev_recursion to check the well-formedness
+   conditions on type abbreviations defined within recursive modules. *)
+
+let check_recmod_typedecl env loc recmod_ids path decl =
+  (* recmod_ids is the list of recursively-defined module idents.
+     (path, decl) is the type declaration to be checked. *)
+  let to_check path = Path.exists_free recmod_ids path in
+  check_well_founded_decl env loc path decl to_check;
+  check_recursion ~orig_env:env env loc path decl to_check;
+  (* additionally check coherece, as one might build an incoherent signature,
+     and use it to build an incoherent module, cf. #7851 *)
+  check_coherence env loc path decl
+
+
+(**** Error report ****)
+
+open Format
+
+let explain_unbound_gen ppf tv tl typ kwd pr =
+  try
+    let ti = List.find (fun ti -> Ctype.deep_occur tv (typ ti)) tl in
+    let ty0 = (* Hack to force aliasing when needed *)
+      Btype.newgenty (Tobject(tv, ref None)) in
+    Printtyp.reset_and_mark_loops_list [typ ti; ty0];
+    fprintf ppf
+      ".@ @[<hov2>In %s@ %a@;<1 -2>the variable %a is unbound@]"
+      kwd pr ti Printtyp.marked_type_expr tv
+  with Not_found -> ()
+
+let explain_unbound ppf tv tl typ kwd lab =
+  explain_unbound_gen ppf tv tl typ kwd
+    (fun ppf ti ->
+       fprintf ppf "%s%a" (lab ti) Printtyp.marked_type_expr (typ ti)
+    )
+
+let explain_unbound_single ppf tv ty =
+  let trivial ty =
+    explain_unbound ppf tv [ty] (fun t -> t) "type" (fun _ -> "") in
+  match (Ctype.repr ty).desc with
+    Tobject(fi,_) ->
+      let (tl, rv) = Ctype.flatten_fields fi in
+      if rv == tv then trivial ty else
+      explain_unbound ppf tv tl (fun (_,_,t) -> t)
+        "method" (fun (lab,_,_) -> lab ^ ": ")
+  | Tvariant row ->
+      let row = Btype.row_repr row in
+      if row.row_more == tv then trivial ty else
+      explain_unbound ppf tv row.row_fields
+        (fun (_l,f) -> match Btype.row_field_repr f with
+          Rpresent (Some t) -> t
+        | Reither (_,[t],_,_) -> t
+        | Reither (_,tl,_,_) -> Btype.newgenty (Ttuple tl)
+        | _ -> Btype.newgenty (Ttuple[]))
+        "case" (fun (lab,_) -> "`" ^ lab ^ " of ")
+  | _ -> trivial ty
+
+
+let tys_of_constr_args = function
+  | Types.Cstr_tuple tl -> tl
+  | Types.Cstr_record lbls -> List.map (fun l -> l.Types.ld_type) lbls
+
+let report_error ppf = function
+  | Repeated_parameter ->
+      fprintf ppf "A type parameter occurs several times"
+  | Duplicate_constructor s ->
+      fprintf ppf "Two constructors are named %s" s
+  | Too_many_constructors ->
+      fprintf ppf
+        "@[Too many non-constant constructors@ -- maximum is %i %s@]"
+        (Config.max_tag + 1) "non-constant constructors"
+  | Duplicate_label s ->
+      fprintf ppf "Two labels are named %s" s
+  | Recursive_abbrev s ->
+      fprintf ppf "The type abbreviation %s is cyclic" s
+  | Cycle_in_def (s, ty) ->
+      fprintf ppf "@[<v>The definition of %s contains a cycle:@ %a@]"
+        s Printtyp.type_expr ty
+  | Definition_mismatch (ty, None) ->
+      fprintf ppf "@[<v>@[<hov>%s@ %s@;<1 2>%a@]@]"
+        "This variant or record definition" "does not match that of type"
+        Printtyp.type_expr ty
+  | Definition_mismatch (ty, Some err) ->
+      fprintf ppf "@[<v>@[<hov>%s@ %s@;<1 2>%a@]%a@]"
+        "This variant or record definition" "does not match that of type"
+        Printtyp.type_expr ty
+        (Includecore.report_type_mismatch "the original" "this" "definition")
+        err
+  | Constraint_failed (env, trace) ->
+      fprintf ppf "@[<v>Constraints are not satisfied in this type.@ ";
+      Printtyp.report_unification_error ppf env trace
+        (fun ppf -> fprintf ppf "Type")
+        (fun ppf -> fprintf ppf "should be an instance of");
+      fprintf ppf "@]"
+  | Non_regular { definition; used_as; defined_as; expansions } ->
+      let pp_expansion ppf (ty,body) =
+        Format.fprintf ppf "%a = %a"
+          Printtyp.type_expr ty
+          Printtyp.type_expr body in
+      let comma ppf () = Format.fprintf ppf ",@;<1 2>" in
+      let pp_expansions ppf expansions =
+        Format.(pp_print_list ~pp_sep:comma pp_expansion) ppf expansions in
+      Printtyp.reset_and_mark_loops used_as;
+      Printtyp.mark_loops defined_as;
+      Printtyp.Naming_context.reset ();
+      begin match expansions with
+      | [] ->
+          fprintf ppf
+            "@[<hv>This recursive type is not regular.@ \
+             The type constructor %s is defined as@;<1 2>type %a@ \
+             but it is used as@;<1 2>%a.@ \
+             All uses need to match the definition for the recursive type \
+             to be regular.@]"
+            (Path.name definition)
+            !Oprint.out_type (Printtyp.tree_of_typexp false defined_as)
+            !Oprint.out_type (Printtyp.tree_of_typexp false used_as)
+      | _ :: _ ->
+          fprintf ppf
+            "@[<hv>This recursive type is not regular.@ \
+             The type constructor %s is defined as@;<1 2>type %a@ \
+             but it is used as@;<1 2>%a@ \
+             after the following expansion(s):@;<1 2>%a@ \
+             All uses need to match the definition for the recursive type \
+             to be regular.@]"
+            (Path.name definition)
+            !Oprint.out_type (Printtyp.tree_of_typexp false defined_as)
+            !Oprint.out_type (Printtyp.tree_of_typexp false used_as)
+            pp_expansions expansions
+      end
+  | Inconsistent_constraint (env, trace) ->
+      fprintf ppf "@[<v>The type constraints are not consistent.@ ";
+      Printtyp.report_unification_error ppf env trace
+        (fun ppf -> fprintf ppf "Type")
+        (fun ppf -> fprintf ppf "is not compatible with type");
+      fprintf ppf "@]"
+  | Type_clash (env, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "This type constructor expands to type")
+        (function ppf ->
+           fprintf ppf "but is used here with type")
+  | Null_arity_external ->
+      fprintf ppf "External identifiers must be functions"
+  | Missing_native_external ->
+      fprintf ppf "@[<hv>An external function with more than 5 arguments \
+                   requires a second stub function@ \
+                   for native-code compilation@]"
+  | Unbound_type_var (ty, decl) ->
+      fprintf ppf "@[A type variable is unbound in this type declaration";
+      let ty = Ctype.repr ty in
+      begin match decl.type_kind, decl.type_manifest with
+      | Type_variant (tl, _rep), _ ->
+          explain_unbound_gen ppf ty tl (fun c ->
+              let tl = tys_of_constr_args c.Types.cd_args in
+              Btype.newgenty (Ttuple tl)
+            )
+            "case" (fun ppf c ->
+                fprintf ppf
+                  "%a of %a" Printtyp.ident c.Types.cd_id
+                  Printtyp.constructor_arguments c.Types.cd_args)
+      | Type_record (tl, _), _ ->
+          explain_unbound ppf ty tl (fun l -> l.Types.ld_type)
+            "field" (fun l -> Ident.name l.Types.ld_id ^ ": ")
+      | Type_abstract, Some ty' ->
+          explain_unbound_single ppf ty ty'
+      | _ -> ()
+      end;
+      fprintf ppf "@]"
+  | Unbound_type_var_ext (ty, ext) ->
+      fprintf ppf "@[A type variable is unbound in this extension constructor";
+      let args = tys_of_constr_args ext.ext_args in
+      explain_unbound ppf ty args (fun c -> c) "type" (fun _ -> "");
+      fprintf ppf "@]"
+  | Cannot_extend_private_type path ->
+      fprintf ppf "@[%s@ %a@]"
+        "Cannot extend private type definition"
+        Printtyp.path path
+  | Not_extensible_type path ->
+      fprintf ppf "@[%s@ %a@ %s@]"
+        "Type definition"
+        Printtyp.path path
+        "is not extensible"
+  | Extension_mismatch (path, err) ->
+      fprintf ppf "@[<v>@[<hov>%s@ %s@;<1 2>%s@]%a@]"
+        "This extension" "does not match the definition of type"
+        (Path.name path)
+        (Includecore.report_type_mismatch
+           "the type" "this extension" "definition")
+        err
+  | Rebind_wrong_type (lid, env, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "The constructor %a@ has type"
+             Printtyp.longident lid)
+        (function ppf ->
+           fprintf ppf "but was expected to be of type")
+  | Rebind_mismatch (lid, p, p') ->
+      fprintf ppf
+        "@[%s@ %a@ %s@ %s@ %s@ %s@ %s@]"
+        "The constructor" Printtyp.longident lid
+        "extends type" (Path.name p)
+        "whose declaration does not match"
+        "the declaration of type" (Path.name p')
+  | Rebind_private lid ->
+      fprintf ppf "@[%s@ %a@ %s@]"
+        "The constructor"
+        Printtyp.longident lid
+        "is private"
+  | Variance (Typedecl_variance.Bad_variance (n, v1, v2)) ->
+      let variance (p,n,i) =
+        let inj = if i then "injective " else "" in
+        match p, n with
+          true,  true  -> inj ^ "invariant"
+        | true,  false -> inj ^ "covariant"
+        | false, true  -> inj ^ "contravariant"
+        | false, false -> if inj = "" then "unrestricted" else inj
+      in
+      let suffix n =
+        let teen = (n mod 100)/10 = 1 in
+        match n mod 10 with
+        | 1 when not teen -> "st"
+        | 2 when not teen -> "nd"
+        | 3 when not teen -> "rd"
+        | _ -> "th"
+      in
+      (match n with
+       | Variance_not_reflected ->
+           fprintf ppf "@[%s@ %s@ It"
+             "In this definition, a type variable has a variance that"
+             "is not reflected by its occurrence in type parameters."
+       | No_variable ->
+           fprintf ppf "@[%s@ %s@]"
+             "In this definition, a type variable cannot be deduced"
+             "from the type parameters."
+       | Variance_not_deducible ->
+           fprintf ppf "@[%s@ %s@ It"
+             "In this definition, a type variable has a variance that"
+             "cannot be deduced from the type parameters."
+       | Variance_not_satisfied n ->
+           fprintf ppf "@[%s@ %s@ The %d%s type parameter"
+             "In this definition, expected parameter"
+             "variances are not satisfied."
+             n (suffix n));
+      (match n with
+       | No_variable -> ()
+       | _ ->
+           fprintf ppf " was expected to be %s,@ but it is %s.@]"
+             (variance v2) (variance v1))
+  | Unavailable_type_constructor p ->
+      fprintf ppf "The definition of type %a@ is unavailable" Printtyp.path p
+  | Variance Typedecl_variance.Varying_anonymous ->
+      fprintf ppf "@[%s@ %s@ %s@]"
+        "In this GADT definition," "the variance of some parameter"
+        "cannot be checked"
+  | Val_in_structure ->
+      fprintf ppf "Value declarations are only allowed in signatures"
+  | Multiple_native_repr_attributes ->
+      fprintf ppf "Too many [@@unboxed]/[@@untagged] attributes"
+  | Cannot_unbox_or_untag_type Unboxed ->
+      fprintf ppf "@[Don't know how to unbox this type.@ \
+                   Only float, int32, int64 and nativeint can be unboxed.@]"
+  | Cannot_unbox_or_untag_type Untagged ->
+      fprintf ppf "@[Don't know how to untag this type.@ \
+                   Only int can be untagged.@]"
+  | Deep_unbox_or_untag_attribute kind ->
+      fprintf ppf
+        "@[The attribute '%s' should be attached to@ \
+         a direct argument or result of the primitive,@ \
+         it should not occur deeply into its type.@]"
+        (match kind with Unboxed -> "@unboxed" | Untagged -> "@untagged")
+  | Immediacy (Typedecl_immediacy.Bad_immediacy_attribute violation) ->
+      fprintf ppf "@[%a@]" Format.pp_print_text
+        (match violation with
+         | Type_immediacy.Violation.Not_always_immediate ->
+             "Types marked with the immediate attribute must be \
+              non-pointer types like int or bool."
+         | Type_immediacy.Violation.Not_always_immediate_on_64bits ->
+             "Types marked with the immediate64 attribute must be \
+              produced using the Stdlib.Sys.Immediate64.Make functor.")
+  | Bad_unboxed_attribute msg ->
+      fprintf ppf "@[This type cannot be unboxed because@ %s.@]" msg
+  | Separability (Typedecl_separability.Non_separable_evar evar) ->
+      let pp_evar ppf = function
+        | None ->
+            fprintf ppf "an unnamed existential variable"
+        | Some str ->
+            fprintf ppf "the existential variable %a"
+              Pprintast.tyvar str in
+      fprintf ppf "@[This type cannot be unboxed because@ \
+                   it might contain both float and non-float values,@ \
+                   depending on the instantiation of %a.@ \
+                   You should annotate it with [%@%@ocaml.boxed].@]"
+        pp_evar evar
+  | Boxed_and_unboxed ->
+      fprintf ppf "@[A type cannot be boxed and unboxed at the same time.@]"
+  | Nonrec_gadt ->
+      fprintf ppf
+        "@[GADT case syntax cannot be used in a 'nonrec' block.@]"
+  | Invalid_private_row_declaration ty ->
+      Format.fprintf ppf
+        "@[<hv>This private row type declaration is invalid.@ \
+         The type expression on the right-hand side reduces to@;<1 2>%a@ \
+         which does not have a free row type variable.@]@,\
+         @[<hv>@[Hint: If you intended to define a private type abbreviation,@ \
+         write explicitly@]@;<1 2>private %a@]"
+        Printtyp.type_expr ty Printtyp.type_expr ty
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, err) ->
+        Some (Location.error_of_printer ~loc report_error err)
+      | _ ->
+        None
+    )
diff --git a/src/ocaml/typing/typedecl.mli b/src/ocaml/typing/typedecl.mli
new file mode 100644
index 0000000..2ec3fef
--- /dev/null
+++ b/src/ocaml/typing/typedecl.mli
@@ -0,0 +1,109 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Typing of type definitions and primitive definitions *)
+
+open Types
+open Format
+
+val transl_type_decl:
+    Env.t -> Asttypes.rec_flag -> Parsetree.type_declaration list ->
+    Typedtree.type_declaration list * Env.t
+
+val transl_exception:
+    Env.t -> Parsetree.extension_constructor ->
+    Typedtree.extension_constructor * Env.t
+
+val transl_type_exception:
+    Env.t ->
+    Parsetree.type_exception -> Typedtree.type_exception * Env.t
+
+val transl_type_extension:
+    bool -> Env.t -> Location.t -> Parsetree.type_extension ->
+    Typedtree.type_extension * Env.t
+
+val transl_value_decl:
+    Env.t -> Location.t ->
+    Parsetree.value_description -> Typedtree.value_description * Env.t
+
+(* If the [fixed_row_path] optional argument is provided,
+   the [Parsetree.type_declaration] argument should satisfy [is_fixed_type] *)
+val transl_with_constraint:
+    Ident.t -> ?fixed_row_path:Path.t ->
+    sig_env:Env.t -> sig_decl:Types.type_declaration ->
+    outer_env:Env.t -> Parsetree.type_declaration ->
+    Typedtree.type_declaration
+
+val abstract_type_decl: injective:bool -> int -> type_declaration
+val approx_type_decl:
+    Parsetree.type_declaration list ->
+                                  (Ident.t * type_declaration) list
+val check_recmod_typedecl:
+    Env.t -> Location.t -> Ident.t list -> Path.t -> type_declaration -> unit
+val check_coherence:
+    Env.t -> Location.t -> Path.t -> type_declaration -> unit
+
+(* for fixed types *)
+val is_fixed_type : Parsetree.type_declaration -> bool
+
+(* for typeopt.ml *)
+val get_unboxed_type_representation: Env.t -> type_expr -> type_expr option
+
+type native_repr_kind = Unboxed | Untagged
+
+type error =
+    Repeated_parameter
+  | Duplicate_constructor of string
+  | Too_many_constructors
+  | Duplicate_label of string
+  | Recursive_abbrev of string
+  | Cycle_in_def of string * type_expr
+  | Definition_mismatch of type_expr * Includecore.type_mismatch option
+  | Constraint_failed of Env.t * Errortrace.unification Errortrace.t
+  | Inconsistent_constraint of Env.t * Errortrace.unification Errortrace.t
+  | Type_clash of Env.t * Errortrace.unification Errortrace.t
+  | Non_regular of {
+      definition: Path.t;
+      used_as: type_expr;
+      defined_as: type_expr;
+      expansions: (type_expr * type_expr) list;
+    }
+  | Null_arity_external
+  | Missing_native_external
+  | Unbound_type_var of type_expr * type_declaration
+  | Cannot_extend_private_type of Path.t
+  | Not_extensible_type of Path.t
+  | Extension_mismatch of Path.t * Includecore.type_mismatch
+  | Rebind_wrong_type of
+      Longident.t * Env.t * Errortrace.unification Errortrace.t
+  | Rebind_mismatch of Longident.t * Path.t * Path.t
+  | Rebind_private of Longident.t
+  | Variance of Typedecl_variance.error
+  | Unavailable_type_constructor of Path.t
+  | Unbound_type_var_ext of type_expr * extension_constructor
+  | Val_in_structure
+  | Multiple_native_repr_attributes
+  | Cannot_unbox_or_untag_type of native_repr_kind
+  | Deep_unbox_or_untag_attribute of native_repr_kind
+  | Immediacy of Typedecl_immediacy.error
+  | Separability of Typedecl_separability.error
+  | Bad_unboxed_attribute of string
+  | Boxed_and_unboxed
+  | Nonrec_gadt
+  | Invalid_private_row_declaration of type_expr
+
+exception Error of Location.t * error
+
+val report_error: formatter -> error -> unit
diff --git a/src/ocaml/typing/typedecl_immediacy.ml b/src/ocaml/typing/typedecl_immediacy.ml
new file mode 100644
index 0000000..bcc4d34
--- /dev/null
+++ b/src/ocaml/typing/typedecl_immediacy.ml
@@ -0,0 +1,71 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Types
+
+type error = Bad_immediacy_attribute of Type_immediacy.Violation.t
+exception Error of Location.t * error
+
+let compute_decl env tdecl =
+  match (tdecl.type_kind, tdecl.type_manifest) with
+  | (Type_variant ([{cd_args = Cstr_tuple [arg]
+                            | Cstr_record [{ld_type = arg; _}]; _}],
+                   Variant_unboxed)
+    | Type_record ([{ld_type = arg; _}], Record_unboxed _)), _ ->
+    begin match Typedecl_unboxed.get_unboxed_type_representation env arg with
+    | Typedecl_unboxed.Unavailable -> Type_immediacy.Unknown
+    | Typedecl_unboxed.This argrepr -> Ctype.immediacy env argrepr
+    | Typedecl_unboxed.Only_on_64_bits argrepr ->
+        match Ctype.immediacy env argrepr with
+        | Type_immediacy.Always -> Type_immediacy.Always_on_64bits
+        | Type_immediacy.Always_on_64bits | Type_immediacy.Unknown as x -> x
+    end
+  | (Type_variant (_ :: _ as cstrs, _), _) ->
+    if not (List.exists (fun c -> c.Types.cd_args <> Types.Cstr_tuple []) cstrs)
+    then
+      Type_immediacy.Always
+    else
+      Type_immediacy.Unknown
+  | (Type_abstract, Some(typ)) -> Ctype.immediacy env typ
+  | (Type_abstract, None) -> Type_immediacy.of_attributes tdecl.type_attributes
+  | _ -> Type_immediacy.Unknown
+
+let property : (Type_immediacy.t, unit) Typedecl_properties.property =
+  let open Typedecl_properties in
+  let eq = (=) in
+  let merge ~prop:_ ~new_prop = new_prop in
+  let default _decl = Type_immediacy.Unknown in
+  let compute env decl () = compute_decl env decl in
+  let update_decl decl immediacy = { decl with type_immediate = immediacy } in
+  let check _env _id decl () =
+    let written_by_user = Type_immediacy.of_attributes decl.type_attributes in
+    match Type_immediacy.coerce decl.type_immediate ~as_:written_by_user with
+    | Ok () -> ()
+    | Error violation ->
+        raise (Error (decl.type_loc,
+                      Bad_immediacy_attribute violation))
+  in
+  {
+    eq;
+    merge;
+    default;
+    compute;
+    update_decl;
+    check;
+  }
+
+let update_decls env decls =
+  Typedecl_properties.compute_property_noreq property env decls
diff --git a/src/ocaml/typing/typedecl_immediacy.mli b/src/ocaml/typing/typedecl_immediacy.mli
new file mode 100644
index 0000000..17fb985
--- /dev/null
+++ b/src/ocaml/typing/typedecl_immediacy.mli
@@ -0,0 +1,27 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type error = Bad_immediacy_attribute of Type_immediacy.Violation.t
+exception Error of Location.t * error
+
+val compute_decl : Env.t -> Types.type_declaration -> Type_immediacy.t
+
+val property : (Type_immediacy.t, unit) Typedecl_properties.property
+
+val update_decls :
+  Env.t ->
+  (Ident.t * Typedecl_properties.decl) list ->
+  (Ident.t * Typedecl_properties.decl) list
diff --git a/src/ocaml/typing/typedecl_properties.ml b/src/ocaml/typing/typedecl_properties.ml
new file mode 100644
index 0000000..28a1bb6
--- /dev/null
+++ b/src/ocaml/typing/typedecl_properties.ml
@@ -0,0 +1,73 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type decl = Types.type_declaration
+
+type ('prop, 'req) property = {
+  eq : 'prop -> 'prop -> bool;
+  merge : prop:'prop -> new_prop:'prop -> 'prop;
+
+  default : decl -> 'prop;
+  compute : Env.t -> decl -> 'req -> 'prop;
+  update_decl : decl -> 'prop -> decl;
+
+  check : Env.t -> Ident.t -> decl -> 'req -> unit;
+}
+
+let add_type ~check id decl env =
+  let open Types in
+  Builtin_attributes.warning_scope ~ppwarning:false decl.type_attributes
+    (fun () -> Env.add_type ~check id decl env)
+
+let add_types_to_env decls env =
+  List.fold_right
+    (fun (id, decl) env -> add_type ~check:true id decl env)
+    decls env
+
+let compute_property
+: ('prop, 'req) property -> Env.t ->
+  (Ident.t * decl) list -> 'req list -> (Ident.t * decl) list
+= fun property env decls required ->
+  (* [decls] and [required] must be lists of the same size,
+     with [required] containing the requirement for the corresponding
+     declaration in [decls]. *)
+  let props = List.map (fun (_id, decl) -> property.default decl) decls in
+  let rec compute_fixpoint props =
+    let new_decls =
+      List.map2 (fun (id, decl) prop ->
+          (id, property.update_decl decl prop))
+        decls props in
+    let new_env = add_types_to_env new_decls env in
+    let new_props =
+      List.map2
+        (fun (_id, decl) (prop, req) ->
+           let new_prop = property.compute new_env decl req in
+           property.merge ~prop ~new_prop)
+        new_decls (List.combine props required) in
+    if not (List.for_all2 property.eq props new_props)
+    then compute_fixpoint new_props
+    else begin
+      List.iter2
+        (fun (id, decl) req -> property.check new_env id decl req)
+        new_decls required;
+      new_decls
+    end
+  in
+  compute_fixpoint props
+
+let compute_property_noreq property env decls =
+  let req = List.map (fun _ -> ()) decls in
+  compute_property property env decls req
diff --git a/src/ocaml/typing/typedecl_properties.mli b/src/ocaml/typing/typedecl_properties.mli
new file mode 100644
index 0000000..153c3f7
--- /dev/null
+++ b/src/ocaml/typing/typedecl_properties.mli
@@ -0,0 +1,55 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type decl = Types.type_declaration
+
+(** An abstract interface for properties of type definitions, such as
+   variance and immediacy, that are computed by a fixpoint on
+   mutually-recursive type declarations. This interface contains all
+   the operations needed to initialize and run the fixpoint
+   computation, and then (optionally) check that the result is
+   consistent with the declaration or user expectations. *)
+
+type ('prop, 'req) property = {
+  eq : 'prop -> 'prop -> bool;
+  merge : prop:'prop -> new_prop:'prop -> 'prop;
+
+  default : decl -> 'prop;
+  compute : Env.t -> decl -> 'req -> 'prop;
+  update_decl : decl -> 'prop -> decl;
+
+  check : Env.t -> Ident.t -> decl -> 'req -> unit;
+}
+(** ['prop] represents the type of property values
+    ({!Types.Variance.t}, just 'bool' for immediacy, etc).
+
+    ['req] represents the property value required by the author of the
+    declaration, if they gave an expectation: [type +'a t = ...].
+
+    Some properties have no natural notion of user requirement, or
+    their requirement is global, or already stored in
+    [type_declaration]; they can just use [unit] as ['req] parameter. *)
+
+
+(** [compute_property prop env decls req] performs a fixpoint computation
+    to determine the final values of a property on a set of mutually-recursive
+    type declarations. The [req] argument must be a list of the same size as
+    [decls], providing the user requirement for each declaration. *)
+val compute_property : ('prop, 'req) property -> Env.t ->
+  (Ident.t * decl) list -> 'req list -> (Ident.t * decl) list
+
+val compute_property_noreq : ('prop, unit) property -> Env.t ->
+  (Ident.t * decl) list -> (Ident.t * decl) list
diff --git a/src/ocaml/typing/typedecl_separability.ml b/src/ocaml/typing/typedecl_separability.ml
new file mode 100644
index 0000000..0d4efd6
--- /dev/null
+++ b/src/ocaml/typing/typedecl_separability.ml
@@ -0,0 +1,674 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Types
+
+type type_definition = type_declaration
+(* We should use 'declaration' for interfaces, and 'definition' for
+   implementations. The name type_declaration in types.ml is improper
+   for our usage -- although for OCaml types the declaration and
+   definition languages are the same. *)
+
+(** assuming that a datatype has a single constructor/label with
+   a single argument, [argument_to_unbox] represents the
+   information we need to check the argument for separability. *)
+type argument_to_unbox = {
+  argument_type: type_expr;
+  result_type_parameter_instances: type_expr list;
+  (** result_type_parameter_instances represents the domain of the
+     constructor; usually it is just a list of the datatype parameter
+     ('a, 'b, ...), but when using GADTs or constraints it could
+     contain arbitrary type expressions.
+
+     For example, [type 'a t = 'b constraint 'a = 'b * int] has
+     [['b * int]] as [result_type_parameter_instances], and so does
+     [type _ t = T : 'b -> ('b * int) t]. *)
+}
+
+(** Summarize the right-hand-side of a type declaration,
+    for separability-checking purposes. See {!structure} below. *)
+type type_structure =
+  | Synonym of type_expr
+  | Abstract
+  | Open
+  | Algebraic
+  | Unboxed of argument_to_unbox
+
+let structure : type_definition -> type_structure = fun def ->
+  match def.type_kind with
+  | Type_open -> Open
+  | Type_abstract ->
+      begin match def.type_manifest with
+      | None -> Abstract
+      | Some type_expr -> Synonym type_expr
+      end
+
+  | ( Type_record ([{ld_type = ty; _}], Record_unboxed _)
+    | Type_variant ([{cd_args = Cstr_tuple [ty]; _}], Variant_unboxed)
+    | Type_variant ([{cd_args = Cstr_record [{ld_type = ty; _}]; _}],
+                    Variant_unboxed)) ->
+     let params =
+       match def.type_kind with
+       | Type_variant ([{cd_res = Some ret_type}], _) ->
+          begin match Ctype.repr ret_type with
+          | {desc=Tconstr (_, tyl, _)} ->
+             List.map Ctype.repr tyl
+          | _ -> assert false
+          end
+       | _ -> def.type_params
+     in
+     Unboxed { argument_type = ty; result_type_parameter_instances = params }
+
+  | Type_record _ | Type_variant _ -> Algebraic
+
+type error =
+  | Non_separable_evar of string option
+
+exception Error of Location.t * error
+
+(* see the .mli file for explanations on the modes *)
+module Sep = Types.Separability
+type mode = Sep.t = Ind | Sep | Deepsep
+
+let rank = Sep.rank
+let max_mode = Sep.max
+
+(** If the type context [e(_)] imposes the mode [m] on its hole [_],
+    and the type context [e'(_)] imposes the mode [m'] on its hole [_],
+    then the mode on [_] imposed by the context composition [e(e'(_))]
+    is [compose m m'].
+
+    This operation differs from [max_mode]: [max_mode Ind Sep] is [Sep],
+    but [compose Ind Sep] is [Ind]. *)
+let compose
+  : mode -> mode -> mode
+  = fun m1 m2 ->
+  match m1 with
+  | Deepsep -> Deepsep
+  | Sep -> m2
+  | Ind -> Ind
+
+type type_var = {
+  text: string option; (** the user name of the type variable, None for '_' *)
+  id: int; (** the identifier of the type node (type_expr.id) of the variable *)
+}
+
+module TVarMap = Map.Make(struct
+    type t = type_var
+    let compare v1 v2 = compare v1.id v2.id
+  end)
+type context = mode TVarMap.t
+let (++) = TVarMap.union (fun _ m1 m2 -> Some(max_mode m1 m2))
+let empty = TVarMap.empty
+
+
+(** [immediate_subtypes ty] returns the list of all the
+   immediate sub-type-expressions of [ty]. They represent the biggest
+   sub-components that may be extracted using a constraint. For
+   example, the immediate sub-type-expressions of [int * (bool * 'a)]
+   are [int] and [bool * 'a].
+
+   Smaller components are extracted recursively in [check_type]. *)
+let rec immediate_subtypes : type_expr -> type_expr list = fun ty ->
+  (* Note: Btype.fold_type_expr is not suitable here:
+     - it does not do the right thing on Tpoly, iterating on type
+       parameters as well as the subtype
+     - it performs a shallow traversal of object types,
+       while our implementation collects all method types *)
+  match (Ctype.repr ty).desc with
+  (* these are the important cases,
+     on which immediate_subtypes is called from [check_type] *)
+  | Tarrow(_,ty1,ty2,_) ->
+      [ty1; ty2]
+  | Ttuple(tys) -> tys
+  | Tpackage(_, fl) -> (snd (List.split fl))
+  | Tobject(row,class_ty) ->
+      let class_subtys =
+        match !class_ty with
+        | None        -> []
+        | Some(_,tys) -> tys
+      in
+      immediate_subtypes_object_row class_subtys row
+  | Tvariant(row) ->
+      immediate_subtypes_variant_row [] row
+
+  (* the cases below are not called from [check_type],
+     they are here for completeness *)
+  | Tnil | Tfield _ ->
+      (* these should only occur under Tobject and not at the toplevel,
+         but "better safe than sorry" *)
+      immediate_subtypes_object_row [] ty
+  | Tlink _ | Tsubst _ -> assert false (* impossible due to Ctype.repr *)
+  | Tvar _ | Tunivar _ -> []
+  | Tpoly (pty, _) -> [pty]
+  | Tconstr (_path, tys, _) -> tys
+
+and immediate_subtypes_object_row acc ty = match (Ctype.repr ty).desc with
+  | Tnil -> acc
+  | Tfield (_label, _kind, ty, rest) ->
+      let acc = ty :: acc in
+      immediate_subtypes_object_row acc rest
+  | _ -> ty :: acc
+
+and immediate_subtypes_variant_row acc desc =
+  let add_subtypes acc =
+    let add_subtype acc (_l, rf) =
+      immediate_subtypes_variant_row_field acc rf in
+    List.fold_left add_subtype acc desc.row_fields in
+  let add_row acc =
+    let row = Ctype.repr desc.row_more in
+    match row.desc with
+    | Tvariant more -> immediate_subtypes_variant_row acc more
+    | _ -> row :: acc
+  in
+  add_row (add_subtypes acc)
+
+and immediate_subtypes_variant_row_field acc = function
+  | Rpresent(None)
+  | Rabsent            -> acc
+  | Rpresent(Some(ty)) -> ty :: acc
+  | Reither(_,field_types,_,r) ->
+      let acc = List.rev_append field_types acc in
+      begin match !r with
+      | None -> acc
+      | Some rf -> immediate_subtypes_variant_row_field acc rf
+      end
+
+let free_variables ty =
+  Ctype.free_variables (Ctype.repr ty)
+  |> List.map (fun {desc; id; _} ->
+      match desc with
+      | Tvar text -> {text; id}
+      | _ ->
+          (* Ctype.free_variables only returns Tvar nodes *)
+          assert false)
+
+(** Coinductive hypotheses to handle equi-recursive types
+
+    OCaml allows infinite/cyclic types, such as
+      (int * 'a) as 'a
+    whose infinite unfolding is (int * (int * (int * (int * ...)))).
+
+    Remark: this specific type is only accepted if the -rectypes option
+    is passed, but such "equi-recursive types" are accepted by
+    default if the cycle goes through an object type or polymorphic
+    variant type:
+      [ `int | `other of 'a ] as 'a
+      < head : int; rest : 'a > as 'a
+
+    We have to take those infinite types in account in our
+    separability-checking program: a naive implementation would loop
+    infinitely when trying to prove that one of them is Deepsep.
+
+    After type-checking, the cycle-introducing form (... as 'a) does
+    not appear explicitly in the syntax of types: types are graphs/trees
+    with cycles in them, and we have to use the type_expr.id field,
+    an identifier for each node in the graph/tree, to detect cycles.
+
+    We avoid looping by remembering the set of separability queries
+    that we have already asked ourselves (in the current
+    search branch). For example, if we are asked to check
+
+      (int * 'a) : Deepsep
+
+    our algorithm will check both (int : Deepsep) and ('a : Deepsep),
+    but it will remember in these sub-checks that it is in the process
+    of checking (int * 'a) : Deepsep, adding it to a list of "active
+    goals", or "coinductive hypotheses".
+
+    Each new sub-query will start by checking whether the query
+    already appears as a coinductive hypothesis; in our example, this
+    can happen if 'a and (int * 'a) are in fact the same node in the
+    cyclic tree. In that case, we return immediately (instead of looping):
+    we reason that, assuming that 'a is indeed Deepsep, then it is
+    the case that (int * 'a) is also Deepsep.
+
+    This kind of cyclic reasoning can be dangerous: it would be wrong
+    to argue that an arbitrary 'a type is Deepsep by saying:
+    "assuming that 'a is Deepsep, then it is the case that 'a is
+    also Deepsep". In the first case, we made an assumption on 'a,
+    and used it on a type (int * 'a) which has 'a as a strict sub-component;
+    in the second, we use it on the same type 'a directly, which is invalid.
+
+    Now consider a type of the form (('a t) as 'a): while 'a is a sub-component
+    of ('a t), it may still be wrong to reason coinductively about it,
+    as ('a t) may be defined as (type 'a t = 'a).
+
+    When moving from (int * 'a) to a subcomponent (int) or ('a), we
+    say that the coinductive hypothesis on (int * 'a : m) is "safe":
+    it can be used immediately to prove the subcomponents, because we
+    made progress moving to a strict subcomponent (we are guarded
+    under a computational type constructor). On the other hand, when
+    moving from ('a t) to ('a), we say that the coinductive hypothesis
+    ('a t : m) is "unsafe" for the subgoal, as we don't know whether
+    we have made strict progress. In the general case, we keep track
+    of a set of safe and unsafe hypotheses made in the past, and we
+    use them to terminate checking if we encounter them again,
+    ensuring termination.
+
+    If we encounter a (ty : m) goal that is exactly a safe hypothesis,
+    we terminate with a success. In fact, we can use mode subtyping here:
+    if (ty : m') appears as a hypothesis with (m' >= m), then we would
+    succeed for (ty : m'), so (ty : m) should succeed as well.
+
+    On the other hand, if we encounter a (ty : m) goal that is an
+    *unsafe* hypothesis, we terminate the check with a failure. In this case,
+    we cannot work modulo mode subtyping: if (ty : m') appears with
+    (m' >= m), then the check (ty : m') would have failed, but it is still
+    possible that the weaker current query (ty : m) would succeed.
+
+    In usual coinductive-reasoning systems, unsafe hypotheses are turned
+    into safe hypotheses each time strict progress is made (for each
+    guarded sub-goal). Consider ((int * 'a) t as 'a : deepsep) for example:
+    the idea is that the ((int * 'a) t : deepsep) hypothesis would be
+    unsafe when checking ((int * 'a) : deepsep), but that the progress
+    step from (int * 'a : deepsep) to ('a : deepsep) would turn all
+    past unsafe hypotheses into safe hypotheses. There is a problem
+    with this, though, due to constraints: what if (_ t) is defined as
+
+      type 'b t = 'a constraint 'b = (int * 'a)
+
+    ?
+
+    In that case, then 'a is precisely the one-step unfolding
+    of the ((int * 'a) t) definition, and it would be an invalid,
+    cyclic reasoning to prove ('a : deepsep) from the now-safe
+    hypothesis ((int * 'a) t : deepsep).
+
+    Surprisingly-fortunately, we have exactly the information we need
+    to know whether (_ t) may or may not pull a constraint trick of
+    this nature: we can look at its mode signature, where constraints
+    are marked by a Deepsep mode. If we see Deepsep, we know that a
+    constraint exists, but we don't know what the constraint is:
+    we cannot tell at which point, when decomposing the parameter type,
+    a sub-component can be considered safe again. To model this,
+    we add a third category of co-inductive hypotheses: to "safe" and
+    "unsafe" we add the category of "poison" hypotheses, which remain
+    poisonous during the remaining of the type decomposition,
+    even in presence of safe, computational types constructors:
+
+    - when going under a computational constructor,
+      "unsafe" hypotheses become "safe"
+    - when going under a constraining type (more precisely, under
+      a type parameter that is marked Deepsep in the mode signature),
+      "unsafe" hypotheses become "poison"
+
+    The mode signature tells us even a bit more: if a parameter
+    is marked "Ind", we know that the type constructor cannot unfold
+    to this parameter (otherwise it would be Sep), so going under
+    this parameter can be considered a safe/guarded move: if
+    we have to check (foo t : m) with ((_ : Ind) t) in the signature,
+    we can recursively check (foo : Ind) with (foo t : m) marked
+    as "safe", rather than "unsafe".
+*)
+module TypeMap = Btype.TypeMap
+module ModeSet = Set.Make(Types.Separability)
+
+type coinductive_hyps = {
+  safe: ModeSet.t TypeMap.t;
+  unsafe: ModeSet.t TypeMap.t;
+  poison: ModeSet.t TypeMap.t;
+}
+
+module Hyps : sig
+  type t = coinductive_hyps
+  val empty : t
+  val add : type_expr -> mode -> t -> t
+  val guard : t -> t
+  val poison : t -> t
+  val safe : type_expr -> mode -> t -> bool
+  val unsafe : type_expr -> mode -> t -> bool
+end = struct
+  type t = coinductive_hyps
+
+  let empty = {
+    safe = TypeMap.empty;
+    unsafe = TypeMap.empty;
+    poison = TypeMap.empty;
+  }
+
+  let of_opt = function
+    | Some ms -> ms
+    | None -> ModeSet.empty
+
+  let merge map1 map2 =
+    TypeMap.merge (fun _k ms1 ms2 ->
+        Some (ModeSet.union (of_opt ms1) (of_opt ms2))
+      ) map1 map2
+
+  let guard {safe; unsafe; poison;} = {
+    safe = merge safe unsafe;
+    unsafe = TypeMap.empty;
+    poison;
+  }
+
+  let poison {safe; unsafe; poison;} = {
+    safe;
+    unsafe = TypeMap.empty;
+    poison = merge poison unsafe;
+  }
+
+  let add ty m hyps =
+    let m_map = TypeMap.singleton ty (ModeSet.singleton m) in
+    { hyps with unsafe = merge m_map hyps.unsafe; }
+
+  let find ty map = try TypeMap.find ty map with Not_found -> ModeSet.empty
+
+  let safe ty m hyps =
+    match ModeSet.max_elt_opt (find ty hyps.safe) with
+    | None -> false
+    | Some best_safe -> rank best_safe >= rank m
+
+  let unsafe ty m {safe = _; unsafe; poison} =
+    let in_map s = ModeSet.mem m (find ty s) in
+    List.exists in_map [unsafe; poison]
+end
+
+(** For a type expression [ty] (without constraints and existentials),
+    any mode checking [ty : m] is satisfied in the "worse case" context
+    that maps all free variables of [ty] to the most demanding mode,
+    Deepsep. *)
+let worst_case ty =
+  let add ctx tvar = TVarMap.add tvar Deepsep ctx in
+  List.fold_left add TVarMap.empty (free_variables ty)
+
+
+(** [check_type env sigma ty m] returns the most permissive context [gamma]
+    such that [ty] is separable at mode [m] in [gamma], under
+    the signature [sigma]. *)
+let check_type
+  : Env.t -> type_expr -> mode -> context
+  = fun env ty m ->
+  let rec check_type hyps ty m =
+    let ty = Ctype.repr ty in
+    if Hyps.safe ty m hyps then empty
+    else if Hyps.unsafe ty m hyps then worst_case ty
+    else
+    let hyps = Hyps.add ty m hyps in
+    match (ty.desc, m) with
+    (* Impossible case due to the call to [Ctype.repr]. *)
+    | (Tlink _            , _      ) -> assert false
+    (* Impossible case (according to comment in [typing/types.mli]. *)
+    | (Tsubst(_)          , _      ) -> assert false
+    (* "Indifferent" case, the empty context is sufficient. *)
+    | (_                  , Ind    ) -> empty
+    (* Variable case, add constraint. *)
+    | (Tvar(alpha)        , m      ) ->
+        TVarMap.singleton {text = alpha; id = ty.Types.id} m
+    (* "Separable" case for constructors with known memory representation. *)
+    | (Tarrow _           , Sep    )
+    | (Ttuple _           , Sep    )
+    | (Tvariant(_)        , Sep    )
+    | (Tobject(_,_)       , Sep    )
+    | ((Tnil | Tfield _)  , Sep    )
+    | (Tpackage(_,_)      , Sep    ) -> empty
+    (* "Deeply separable" case for these same constructors. *)
+    | (Tarrow _           , Deepsep)
+    | (Ttuple _           , Deepsep)
+    | (Tvariant(_)        , Deepsep)
+    | (Tobject(_,_)       , Deepsep)
+    | ((Tnil | Tfield _)  , Deepsep)
+    | (Tpackage(_,_)      , Deepsep) ->
+        let tys = immediate_subtypes ty in
+        let on_subtype context ty =
+          context ++ check_type (Hyps.guard hyps) ty Deepsep in
+        List.fold_left on_subtype empty tys
+    (* Polymorphic type, and corresponding polymorphic variable.
+
+       In theory, [Tpoly] (forall alpha. tau) would add a new variable
+       (alpha) in scope, check its body (tau) recursively, and then
+       remove the new variable from the resulting context. Because the
+       rule accepts any mode for this variable, the removal never
+       fails.
+
+       In practice the implementation is simplified by ignoring the
+       new variable, and always returning the [empty] context
+       (instead of (alpha : m) in the [Tunivar] case: the constraint
+       on the variable is removed/ignored at the variable occurrence
+       site, rather than at the variable-introduction site. *)
+    (* Note: that we are semantically incomplete in the Deepsep case
+       (following the syntactic typing rules): the semantics only
+       requires that *closed* sub-type-expressions be (deeply)
+       separable; sub-type-expressions containing the quantified
+       variable cannot be extracted by constraints (this would be
+       a scope violation), so they could be ignored if they occur
+       under a separating type constructor. *)
+    | (Tpoly(pty,_)       , m      ) ->
+        check_type hyps pty m
+    | (Tunivar(_)         , _      ) -> empty
+    (* Type constructor case. *)
+    | (Tconstr(path,tys,_), m      ) ->
+        let msig = (Env.find_type path env).type_separability in
+        let on_param context (ty, m_param) =
+          let hyps = match m_param with
+            | Ind -> Hyps.guard hyps
+            | Sep -> hyps
+            | Deepsep -> Hyps.poison hyps in
+          context ++ check_type hyps ty (compose m m_param) in
+        List.fold_left on_param empty (List.combine tys msig)
+  in
+  check_type Hyps.empty ty m
+
+let best_msig decl = List.map (fun _ -> Ind) decl.type_params
+let worst_msig decl = List.map (fun _ -> Deepsep) decl.type_params
+
+(** [msig_of_external_type decl] infers the mode signature of an
+    abstract/external type. We must assume the worst, namely that this
+    type may be defined as an unboxed algebraic datatype imposing deep
+    separability of its parameters.
+
+    One exception is when the type is marked "immediate", which
+    guarantees that its representation is only integers.  Immediate
+    types are always separable, so [Ind] suffices for their
+    parameters.
+
+    Note: this differs from {!Types.Separability.default_signature},
+    which does not have access to the declaration and its immediacy. *)
+let msig_of_external_type decl =
+  match decl.type_immediate with
+  | Always | Always_on_64bits -> best_msig decl
+  | Unknown -> worst_msig decl
+
+(** [msig_of_context ~decl_loc constructor context] returns the
+   separability signature of a single-constructor type whose
+   definition is valid in the mode context [context].
+
+   Note: A GADT constructor introduces existential type variables, and
+   may also introduce some equalities between its return type
+   parameters and type expressions containing universal and
+   existential variables. In other words, it introduces new type
+   variables in scope, and restricts existing variables by adding
+   equality constraints.
+
+   [msig_of_context] performs the reverse transformation: the context
+   [ctx] computed from the argument of the constructor mentions
+   existential variables, and the function returns a context over the
+   (universal) type parameters only. (Type constraints do not
+   introduce existential variables, but they do introduce equalities;
+   they are handled as GADTs equalities by this function.)
+
+   The transformation is separability-preserving in the following
+   sense: for any valid instance of the result mode signature
+   (replacing the universal type parameters with ground types
+   respecting the variable's separability mode), any possible
+   extension of this context instance with ground instances for the
+   existential variables of [parameter] that respects the equation
+   constraints will validate the separability requirements of the
+   modes in the input context [ctx].
+
+   Sometimes no such universal context exists, as an existential type
+   cannot be safely introduced, then this function raises an [Error]
+   exception with a [Non_separable_evar] payload.  *)
+let msig_of_context : decl_loc:Location.t -> parameters:type_expr list
+    -> context -> Sep.signature =
+  fun ~decl_loc ~parameters context ->
+    let handle_equation (acc, context) param_instance =
+      (* In the theory, GADT equations are of the form
+           ('a = <ty>)
+         for each type parameter 'a of the type constructor. For each
+         such equation, we should "strengthen" the current context in
+         the following way:
+         - if <ty> is another variable 'b,
+           the mode of 'a is set to the mode of 'b,
+           and 'b is set to Ind
+         - if <ty> is a type expression whose variables are all Ind,
+           set 'a to Ind and discard the equation
+         - otherwise (one of the variable of 'b is not Ind),
+           set 'a to Deepsep and set all variables of <ty> to Ind
+
+         In practice, type parameters are determined by their position
+         in a list, they do not necessarily have a corresponding type variable.
+         Instead of "setting 'a" in the context as in the description above,
+         we build a list of modes by repeated consing into
+         an accumulator variable [acc], setting existential variables
+         to Ind as we go. *)
+      let param_instance = Ctype.repr param_instance in
+      let get context var =
+        try TVarMap.find var context with Not_found -> Ind in
+      let set_ind context var =
+        TVarMap.add var Ind context in
+      let is_ind context var = match get context var with
+        | Ind -> true
+        | Sep | Deepsep -> false in
+      match param_instance.desc with
+      | Tvar text ->
+          let var = {text; id = param_instance.Types.id} in
+          (get context var) :: acc, (set_ind context var)
+      | _ ->
+          let instance_exis = free_variables param_instance in
+          if List.for_all (is_ind context) instance_exis then
+            Ind :: acc, context
+          else
+            Deepsep :: acc, List.fold_left set_ind context instance_exis
+    in
+    let mode_signature, context =
+      let (mode_signature_rev, ctx) =
+        List.fold_left handle_equation ([], context) parameters in
+      (* Note: our inference system is not principal, because the
+         inference result depends on the order in which those
+         equations are processed. (To our knowledge this is the only
+         source of non-principality.) If two parameters ('a, 'b) are
+         forced to be equal to each other, and also separable, then
+         either modes (Sep, Ind) and (Ind, Sep) are correct, allow
+         more declarations than (Sep, Sep), but (Ind, Ind) would be
+         unsound.
+
+         Such a non-principal example is the following:
+
+           type ('a, 'b) almost_eq =
+             | Almost_refl : 'c -> ('c, 'c) almost_eq
+
+         (This example looks strange: GADT equations are typically
+         either on only one parameter, or on two parameters that are
+         not used to classify constructor arguments. Indeed, we have
+         not found non-principal declarations in real-world code.)
+
+         In a non-principal system, it is important the our choice of
+         non-unique solution be at least predictable. We find it more
+         natural, when either ('a : Sep, 'b : Ind) and ('a : Ind,
+         'b : Sep) are correct because 'a = 'b, to choose to make the
+         first/leftmost parameter more constrained. We read this as
+         saying that 'a must be Sep, and 'b = 'a so 'b can be
+         Ind. (We define the second parameter as equal of the first,
+         already-seen parameter; instead of saying that the first
+         parameter is equal to the not-yet-seen second one.)
+
+         This is achieved by processing the equations from left to
+         right with List.fold_left, instead of using
+         List.fold_right. The code is slightly more awkward as it
+         needs a List.rev on the accumulated modes, but it gives
+         a more predictable/natural (non-principal) behavior.
+  *)
+      (List.rev mode_signature_rev, ctx) in
+    (* After all variables determined by the parameters have been set to Ind
+       by [handle_equation], all variables remaining in the context are
+       purely existential and should not require a stronger mode than Ind. *)
+    let check_existential evar mode =
+      if rank mode > rank Ind then
+        raise (Error (decl_loc, Non_separable_evar evar.text))
+    in
+    TVarMap.iter check_existential context;
+    mode_signature
+
+(** [check_def env def] returns the signature required
+    for the type definition [def] in the typing environment [env].
+
+    The exception [Error] is raised if we discover that
+    no such signature exists -- the definition will always be invalid.
+    This only happens when the definition is marked to be unboxed. *)
+
+let check_def
+  : Env.t -> type_definition -> Sep.signature
+  = fun env def ->
+  match structure def with
+  | Abstract ->
+      msig_of_external_type def
+  | Synonym type_expr ->
+      check_type env type_expr Sep
+      |> msig_of_context ~decl_loc:def.type_loc ~parameters:def.type_params
+  | Open | Algebraic ->
+      best_msig def
+  | Unboxed constructor ->
+      check_type env constructor.argument_type Sep
+      |> msig_of_context ~decl_loc:def.type_loc
+           ~parameters:constructor.result_type_parameter_instances
+
+let compute_decl env decl =
+  if Config.flat_float_array then check_def env decl
+  else
+    (* Hack: in -no-flat-float-array mode, instead of always returning
+       [best_msig], we first compute the separability signature --
+       falling back to [best_msig] if it fails.
+
+       This discipline is conservative: it never
+       rejects -no-flat-float-array programs. At the same time it
+       guarantees that, for any program that is also accepted
+       in -flat-float-array mode, the same separability will be
+       inferred in the two modes. In particular, the same .cmi files
+       and digests will be produced.
+
+       Before we introduced this hack, the production of different
+       .cmi files would break the build system of the compiler itself,
+       when trying to build a -no-flat-float-array system from
+       a bootstrap compiler itself using -flat-float-array. See #9291.
+       *)
+    try check_def env decl with
+    | Error _ ->
+       (* It could be nice to emit a warning here, so that users know
+          that their definition would be rejected in -flat-float-array mode *)
+       best_msig decl
+
+(** Separability as a generic property *)
+type prop = Types.Separability.signature
+
+let property : (prop, unit) Typedecl_properties.property =
+  let open Typedecl_properties in
+  let eq ts1 ts2 =
+    List.length ts1 = List.length ts2
+    && List.for_all2 Sep.eq ts1 ts2 in
+  let merge ~prop:_ ~new_prop =
+    (* the update function is monotonous: ~new_prop is always
+       more informative than ~prop, which can be ignored *)
+    new_prop in
+  let default decl = best_msig decl in
+  let compute env decl () = compute_decl env decl in
+  let update_decl decl type_separability = { decl with type_separability } in
+  let check _env _id _decl () = () in (* FIXME run final check? *)
+  { eq; merge; default; compute; update_decl; check; }
+
+(* Definition using the fixpoint infrastructure. *)
+let update_decls env decls =
+  Typedecl_properties.compute_property_noreq property env decls
diff --git a/src/ocaml/typing/typedecl_separability.mli b/src/ocaml/typing/typedecl_separability.mli
new file mode 100644
index 0000000..079e640
--- /dev/null
+++ b/src/ocaml/typing/typedecl_separability.mli
@@ -0,0 +1,132 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** The OCaml runtime assumes for type-directed optimizations that all types
+    are "separable". A type is "separable" if either all its inhabitants
+    (the values of this type) are floating-point numbers, or none of them are.
+
+    (Note: This assumption is required for the dynamic float array optimization;
+    it is only made if Config.flat_float_array is set,
+    otherwise the code in this module becomes trivial
+    -- see {!compute_decl}.)
+
+    This soundness requirement could be broken by type declarations mixing
+    existentials and the "[@@unboxed]" annotation. Consider the declaration
+
+    {[
+       type any = Any : 'a -> any [@@unboxed]
+    ]}
+
+   which corresponds to the existential type "exists a. a". If this type is
+   allowed to be unboxed, then it is inhabited by both [float] values
+   and non-[float] values. On the contrary, if unboxing is disallowed, the
+   inhabitants are all blocks with the [Any] constructors pointing to its
+   parameter: they may point to a float, but they are not floats.
+
+   The present module contains a static analysis ensuring that declarations
+   annotated with "[@@unboxed]" can be safely unboxed. The idea is to check
+   the "separability" (in the above sense) of the argument type that would
+   be unboxed, and reject the unboxed declaration if it would create a
+   non-separable type.
+
+   Checking mutually-recursive type declarations is a bit subtle.
+   Consider, for example, the following declarations.
+
+   {[
+      type foo = Foo : 'a t -> foo   [@@unboxed]
+      and 'a t = ...
+   ]}
+
+   Deciding whether the type [foo] should be accepted requires inspecting
+   the declaration of ['a t], which may itself refer to [foo] in turn.
+   In general, the analysis performs a fixpoint computation. It is somewhat
+   similar to what is done for inferring the variance of type parameters.
+
+   Our analysis is defined using inference rules for our judgment
+   [Def; Gamma |- t : m], in which a type expression [t] is checked
+   against a "mode" [m]. This "mode" describes the separability
+   requirement on the type expression (see below for
+   more details). The mode [Gamma] maps type variables to modes and
+   [Def] records the "mode signature" of the mutually-recursive type
+   declarations that are being checked.
+
+   The "mode signature" of a type with parameters [('a, 'b) t] is of the
+   form [('a : m1, 'b : m2) t], where [m1] and [m2] are modes. Its meaning
+   is the following: a concrete instance [(foo, bar) t] of the type is
+   separable if [foo] has mode [m1] and [bar] has mode [m2]. *)
+
+type error =
+  | Non_separable_evar of string option
+exception Error of Location.t * error
+(** Exception raised when a type declaration is not separable, or when its
+    separability cannot be established. *)
+
+type mode = Types.Separability.t = Ind | Sep | Deepsep
+(** The mode [Sep] ("separable") characterizes types that are indeed separable:
+    either they only contain floating-point values, or none of the values
+    at this type are floating-point values.
+    On a type parameter, it indicates that this parameter must be
+    separable for the whole type definition to be separable. For
+    example, the mode signature for the type declaration [type 'a
+    t = 'a] is [('a : Sep) t]. For the right-hand side to be
+    separable, the parameter ['a] must be separable.
+
+    The mode [Ind] ("indifferent") characterizes any type -- separable
+    or not.
+    On a type parameter, it indicates that this parameter needs not be
+    separable for the whole type definition to be separable. For
+    example, [type 'a t = 'a * bool] does not require its parameter
+    ['a] to be separable as ['a * bool] can never contain [float]
+    values. Its mode signature is thus [('a : Ind) t].
+
+    Finally, the mode [Deepsep] ("deeply separable") characterizes
+    types that are separable, and whose type sub-expressions are also
+    separable. This advanced feature is only used in the presence of
+    constraints.
+    For example, [type 'a t = 'b   constraint 'a = 'b * bool]
+    may not be separable even if ['a] is (its separately depends on 'b,
+    a fragment of 'a), so its mode signature is [('a : Deepsep) t].
+
+    The different modes are ordered as [Ind < Sep < Deepsep] (from the least
+    demanding to the most demanding). *)
+
+val compute_decl : Env.t -> Types.type_declaration -> mode list
+(** [compute_decl env def] returns the signature required
+    for the type definition [def] in the typing environment [env]
+    -- including signatures for the current recursive block.
+
+    The {!Error} exception is raised if no such signature exists
+    -- the definition will always be invalid. This only happens
+    when the definition is marked to be unboxed.
+
+    Variant (or record) declarations that are not marked with the
+    "[@@unboxed]" annotation, including those that contain several variants
+    (or labels), are always separable. In particular, their mode signatures
+    do not require anything of their type parameters, which are marked [Ind].
+
+    Finally, if {!Config.flat_float_array} is not set, then separability
+    is not required anymore; we just use [Ind] as the mode of each parameter
+    without any check.
+*)
+
+(** Property interface (see {!Typedecl_properties}). These functions
+    rely on {!compute_decl} and raise the {!Error} exception on error. *)
+type prop = Types.Separability.signature
+val property : (prop, unit) Typedecl_properties.property
+val update_decls :
+  Env.t ->
+  (Ident.t * Typedecl_properties.decl) list ->
+  (Ident.t * Typedecl_properties.decl) list
diff --git a/src/ocaml/typing/typedecl_unboxed.ml b/src/ocaml/typing/typedecl_unboxed.ml
new file mode 100644
index 0000000..6e23ab9
--- /dev/null
+++ b/src/ocaml/typing/typedecl_unboxed.ml
@@ -0,0 +1,53 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Types
+
+type t =
+  | Unavailable
+  | This of type_expr
+  | Only_on_64_bits of type_expr
+
+(* We use the Ctype.expand_head_opt version of expand_head to get access
+   to the manifest type of private abbreviations. *)
+let rec get_unboxed_type_representation env ty fuel =
+  if fuel < 0 then Unavailable else
+  let ty = Ctype.repr (Ctype.expand_head_opt env ty) in
+  match ty.desc with
+  | Tconstr (p, args, _) ->
+    begin match Env.find_type p env with
+    | exception Not_found -> This ty
+    | {type_immediate = Always; _} ->
+        This Predef.type_int
+    | {type_immediate = Always_on_64bits; _} ->
+        Only_on_64_bits Predef.type_int
+    | {type_params; type_kind =
+         Type_record ([{ld_type = ty2; _}], Record_unboxed _)
+       | Type_variant ([{cd_args = Cstr_tuple [ty2]; _}], Variant_unboxed)
+       | Type_variant ([{cd_args = Cstr_record [{ld_type = ty2; _}]; _}],
+                       Variant_unboxed)}
+      ->
+        let ty2 = match ty2.desc with Tpoly (t, _) -> t | _ -> ty2 in
+        get_unboxed_type_representation env
+          (Ctype.apply env type_params ty2 args) (fuel - 1)
+    | _ -> This ty
+    end
+  | _ -> This ty
+
+let get_unboxed_type_representation env ty =
+  (* Do not give too much fuel: PR#7424 *)
+  get_unboxed_type_representation env ty 100
+;;
diff --git a/src/ocaml/typing/typedecl_unboxed.mli b/src/ocaml/typing/typedecl_unboxed.mli
new file mode 100644
index 0000000..9afd38e
--- /dev/null
+++ b/src/ocaml/typing/typedecl_unboxed.mli
@@ -0,0 +1,25 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Types
+
+type t =
+  | Unavailable
+  | This of type_expr
+  | Only_on_64_bits of type_expr
+
+(* for typeopt.ml *)
+val get_unboxed_type_representation: Env.t -> type_expr -> t
diff --git a/src/ocaml/typing/typedecl_variance.ml b/src/ocaml/typing/typedecl_variance.ml
new file mode 100644
index 0000000..da5dce2
--- /dev/null
+++ b/src/ocaml/typing/typedecl_variance.ml
@@ -0,0 +1,422 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Types
+
+module TypeSet = Btype.TypeSet
+module TypeMap = Btype.TypeMap
+
+type surface_variance = bool * bool * bool
+
+type variance_error =
+| Variance_not_satisfied of int
+| No_variable
+| Variance_not_reflected
+| Variance_not_deducible
+
+type error =
+| Bad_variance of variance_error * surface_variance * surface_variance
+| Varying_anonymous
+
+
+exception Error of Location.t * error
+
+(* Compute variance *)
+
+let get_variance ty visited =
+  try TypeMap.find ty !visited with Not_found -> Variance.null
+
+let compute_variance env visited vari ty =
+  let rec compute_variance_rec vari ty =
+    (* Format.eprintf "%a: %x@." Printtyp.type_expr ty (Obj.magic vari); *)
+    let ty = Ctype.repr ty in
+    let vari' = get_variance ty visited in
+    if Variance.subset vari vari' then () else
+    let vari = Variance.union vari vari' in
+    visited := TypeMap.add ty vari !visited;
+    let compute_same = compute_variance_rec vari in
+    match ty.desc with
+      Tarrow (_, ty1, ty2, _) ->
+        let open Variance in
+        let v = conjugate vari in
+        let v1 =
+          if mem May_pos v || mem May_neg v
+          then set May_weak true v else v
+        in
+        compute_variance_rec v1 ty1;
+        compute_same ty2
+    | Ttuple tl ->
+        List.iter compute_same tl
+    | Tconstr (path, tl, _) ->
+        let open Variance in
+        if tl = [] then () else begin
+          try
+            let decl = Env.find_type path env in
+            let cvari f = mem f vari in
+            List.iter2
+              (fun ty v ->
+                let cv f = mem f v in
+                let strict =
+                  cvari Inv && cv Inj || (cvari Pos || cvari Neg) && cv Inv
+                in
+                if strict then compute_variance_rec full ty else
+                let p1 = inter v vari
+                and n1 = inter v (conjugate vari) in
+                let v1 =
+                  union (inter covariant (union p1 (conjugate p1)))
+                    (inter (conjugate covariant) (union n1 (conjugate n1)))
+                and weak =
+                  cvari May_weak && (cv May_pos || cv May_neg) ||
+                  (cvari May_pos || cvari May_neg) && cv May_weak
+                in
+                let v2 = set May_weak weak v1 in
+                compute_variance_rec v2 ty)
+              tl decl.type_variance
+          with Not_found ->
+            List.iter (compute_variance_rec unknown) tl
+        end
+    | Tobject (ty, _) ->
+        compute_same ty
+    | Tfield (_, _, ty1, ty2) ->
+        compute_same ty1;
+        compute_same ty2
+    | Tsubst _ ->
+        assert false
+    | Tvariant row ->
+        let row = Btype.row_repr row in
+        List.iter
+          (fun (_,f) ->
+            match Btype.row_field_repr f with
+              Rpresent (Some ty) ->
+                compute_same ty
+            | Reither (_, tyl, _, _) ->
+                let open Variance in
+                let upper =
+                  List.fold_left (fun s f -> set f true s)
+                    null [May_pos; May_neg; May_weak]
+                in
+                let v = inter vari upper in
+                (* cf PR#7269:
+                   if List.length tyl > 1 then upper else inter vari upper *)
+                List.iter (compute_variance_rec v) tyl
+            | _ -> ())
+          row.row_fields;
+        compute_same row.row_more
+    | Tpoly (ty, _) ->
+        compute_same ty
+    | Tvar _ | Tnil | Tlink _ | Tunivar _ -> ()
+    | Tpackage (_, fl) ->
+        let v =
+          Variance.(if mem Pos vari || mem Neg vari then full else unknown)
+        in
+        List.iter (fun (_, ty) -> compute_variance_rec v ty) fl
+  in
+  compute_variance_rec vari ty
+
+let make p n i =
+  let open Variance in
+  set May_pos p (set May_neg n (set May_weak n (set Inj i null)))
+
+let injective = Variance.(set Inj true null)
+
+let compute_variance_type env ~check (required, loc) decl tyl =
+  (* Requirements *)
+  let check_injectivity = decl.type_kind = Type_abstract in
+  let required =
+    List.map
+      (fun (c,n,i) ->
+        let i = if check_injectivity then i else false in
+        if c || n then (c,n,i) else (true,true,i))
+      required
+  in
+  (* Prepare *)
+  let params = List.map Btype.repr decl.type_params in
+  let tvl = ref TypeMap.empty in
+  (* Compute occurrences in the body *)
+  let open Variance in
+  List.iter
+    (fun (cn,ty) ->
+      compute_variance env tvl (if cn then full else covariant) ty)
+    tyl;
+  (* Infer injectivity of constrained parameters *)
+  if check_injectivity then
+    List.iter
+      (fun ty ->
+        if Btype.is_Tvar ty || mem Inj (get_variance ty tvl) then () else
+        let visited = ref TypeSet.empty in
+        let rec check ty =
+          let ty = Ctype.repr ty in
+          if TypeSet.mem ty !visited then () else begin
+            visited := TypeSet.add ty !visited;
+            if mem Inj (get_variance ty tvl) then () else
+            match ty.desc with
+            | Tvar _ -> raise Exit
+            | Tconstr _ ->
+                let old = !visited in
+                begin try
+                  Btype.iter_type_expr check ty
+                with Exit ->
+                  visited := old;
+                  let ty' = Ctype.expand_head_opt env ty in
+                  if ty == ty' then raise Exit else check ty'
+                end
+            | _ -> Btype.iter_type_expr check ty
+          end
+        in
+        try check ty; compute_variance env tvl injective ty
+        with Exit -> ())
+      params;
+  if check then begin
+    (* Check variance of parameters *)
+    let pos = ref 0 in
+    List.iter2
+      (fun ty (c, n, i) ->
+        incr pos;
+        let var = get_variance ty tvl in
+        let (co,cn) = get_upper var and ij = mem Inj var in
+        if Btype.is_Tvar ty && (co && not c || cn && not n) || not ij && i
+        then raise (Error(loc, Bad_variance
+                                (Variance_not_satisfied !pos,
+                                                        (co,cn,ij),
+                                                        (c,n,i)))))
+      params required;
+    (* Check propagation from constrained parameters *)
+    let args = Btype.newgenty (Ttuple params) in
+    let fvl = Ctype.free_variables args in
+    let fvl = List.filter (fun v -> not (List.memq v params)) fvl in
+    (* If there are no extra variables there is nothing to do *)
+    if fvl = [] then () else
+    let tvl2 = ref TypeMap.empty in
+    List.iter2
+      (fun ty (p,n,_) ->
+        if Btype.is_Tvar ty then () else
+        let v =
+          if p then if n then full else covariant else conjugate covariant in
+        compute_variance env tvl2 v ty)
+      params required;
+    let visited = ref TypeSet.empty in
+    let rec check ty =
+      let ty = Ctype.repr ty in
+      if TypeSet.mem ty !visited then () else
+      let visited' = TypeSet.add ty !visited in
+      visited := visited';
+      let v1 = get_variance ty tvl in
+      let snap = Btype.snapshot () in
+      let v2 =
+        TypeMap.fold
+          (fun t vt v ->
+             if Ctype.is_equal env false [ty] [t] then union vt v else v)
+          !tvl2 null in
+      Btype.backtrack snap;
+      let (c1,n1) = get_upper v1 and (c2,n2,_,i2) = get_lower v2 in
+      if c1 && not c2 || n1 && not n2 then
+        if List.memq ty fvl then
+          let code = if not i2 then No_variable
+                     else if c2 || n2 then Variance_not_reflected
+                     else Variance_not_deducible in
+          raise (Error (loc, Bad_variance (code, (c1,n1,false), (c2,n2,false))))
+        else
+          Btype.iter_type_expr check ty
+    in
+    List.iter (fun (_,ty) -> check ty) tyl;
+  end;
+  List.map2
+    (fun ty (p, n, i) ->
+      let v = get_variance ty tvl in
+      let tr = decl.type_private in
+      (* Use required variance where relevant *)
+      let concr = decl.type_kind <> Type_abstract (*|| tr = Type_new*) in
+      let (p, n) =
+        if tr = Private || not (Btype.is_Tvar ty) then (p, n) (* set *)
+        else (false, false) (* only check *)
+      and i = concr  || i && tr = Private in
+      let v = union v (make p n i) in
+      let v =
+        if not concr then v else
+        if mem Pos v && mem Neg v then full else
+        if Btype.is_Tvar ty then v else
+        union v
+          (if p then if n then full else covariant else conjugate covariant)
+      in
+      if decl.type_kind = Type_abstract && tr = Public then v else
+      set May_weak (mem May_neg v) v)
+    params required
+
+let add_false = List.map (fun ty -> false, ty)
+
+(* A parameter is constrained if it is either instantiated,
+   or it is a variable appearing in another parameter *)
+let constrained vars ty =
+  match ty.desc with
+  | Tvar _ -> List.exists (fun tl -> List.memq ty tl) vars
+  | _ -> true
+
+let for_constr = function
+  | Types.Cstr_tuple l -> add_false l
+  | Types.Cstr_record l ->
+      List.map
+        (fun {Types.ld_mutable; ld_type} -> (ld_mutable = Mutable, ld_type))
+        l
+
+let compute_variance_gadt env ~check (required, loc as rloc) decl
+    (tl, ret_type_opt) =
+  match ret_type_opt with
+  | None ->
+      compute_variance_type env ~check rloc {decl with type_private = Private}
+        (for_constr tl)
+  | Some ret_type ->
+      match Ctype.repr ret_type with
+      | {desc=Tconstr (_, tyl, _)} ->
+          (* let tyl = List.map (Ctype.expand_head env) tyl in *)
+          let tyl = List.map Ctype.repr tyl in
+          let fvl = List.map (Ctype.free_variables ?env:None) tyl in
+          let _ =
+            List.fold_left2
+              (fun (fv1,fv2) ty (c,n,_) ->
+                match fv2 with [] -> assert false
+                | fv :: fv2 ->
+                    (* fv1 @ fv2 = free_variables of other parameters *)
+                    if (c||n) && constrained (fv1 @ fv2) ty then
+                      raise (Error(loc, Varying_anonymous));
+                    (fv :: fv1, fv2))
+              ([], fvl) tyl required
+          in
+          compute_variance_type env ~check rloc
+            {decl with type_params = tyl; type_private = Private}
+            (for_constr tl)
+      | _ -> assert false
+
+let compute_variance_extension env ~check decl ext rloc =
+  compute_variance_gadt env ~check rloc
+    {decl with type_params = ext.ext_type_params}
+    (ext.ext_args, ext.ext_ret_type)
+
+let compute_variance_decl env ~check decl (required, _ as rloc) =
+  if (decl.type_kind = Type_abstract || decl.type_kind = Type_open)
+       && decl.type_manifest = None then
+    List.map
+      (fun (c, n, i) ->
+        make (not n) (not c) (decl.type_kind <> Type_abstract || i))
+      required
+  else
+  let mn =
+    match decl.type_manifest with
+      None -> []
+    | Some ty -> [false, ty]
+  in
+  match decl.type_kind with
+    Type_abstract | Type_open ->
+      compute_variance_type env ~check rloc decl mn
+  | Type_variant (tll,_rep) ->
+      if List.for_all (fun c -> c.Types.cd_res = None) tll then
+        compute_variance_type env ~check rloc decl
+          (mn @ List.flatten (List.map (fun c -> for_constr c.Types.cd_args)
+                                tll))
+      else begin
+        let mn =
+          List.map (fun (_,ty) -> (Types.Cstr_tuple [ty],None)) mn in
+        let tll =
+          mn @ List.map (fun c -> c.Types.cd_args, c.Types.cd_res) tll in
+        match List.map (compute_variance_gadt env ~check rloc decl) tll with
+        | vari :: rem ->
+            let varl = List.fold_left (List.map2 Variance.union) vari rem in
+            List.map
+              Variance.(fun v -> if mem Pos v && mem Neg v then full else v)
+              varl
+        | _ -> assert false
+      end
+  | Type_record (ftl, _) ->
+      compute_variance_type env ~check rloc decl
+        (mn @ List.map (fun {Types.ld_mutable; ld_type} ->
+             (ld_mutable = Mutable, ld_type)) ftl)
+
+let is_hash id =
+  let s = Ident.name id in
+  String.length s > 0 && s.[0] = '#'
+
+let check_variance_extension env decl ext rloc =
+  (* TODO: refactorize compute_variance_extension *)
+  ignore (compute_variance_extension env ~check:true decl
+    ext.Typedtree.ext_type rloc)
+
+let compute_decl env ~check decl req =
+  compute_variance_decl env ~check decl (req, decl.type_loc)
+
+let check_decl env decl req =
+  ignore (compute_variance_decl env ~check:true decl (req, decl.type_loc))
+
+type prop = Variance.t list
+type req = surface_variance list
+let property : (prop, req) Typedecl_properties.property =
+  let open Typedecl_properties in
+  let eq li1 li2 =
+    try List.for_all2 Variance.eq li1 li2 with _ -> false in
+  let merge ~prop ~new_prop =
+    List.map2 Variance.union prop new_prop in
+  let default decl =
+    List.map (fun _ -> Variance.null) decl.type_params in
+  let compute env decl req =
+    compute_decl env ~check:false decl req in
+  let update_decl decl variance =
+    { decl with type_variance = variance } in
+  let check env id decl req =
+    if is_hash id then () else check_decl env decl req in
+  {
+    eq;
+    merge;
+    default;
+    compute;
+    update_decl;
+    check;
+  }
+
+let transl_variance (v, i) =
+  let co, cn =
+    match v with
+    | Covariant -> (true, false)
+    | Contravariant -> (false, true)
+    | NoVariance -> (false, false)
+  in
+  (co, cn, match i with Injective -> true | NoInjectivity -> false)
+
+let variance_of_params ptype_params =
+  List.map transl_variance (List.map snd ptype_params)
+
+let variance_of_sdecl sdecl =
+  variance_of_params sdecl.Parsetree.ptype_params
+
+let update_decls env sdecls decls =
+  let required = List.map variance_of_sdecl sdecls in
+  Typedecl_properties.compute_property property env decls required
+
+let update_class_decls env cldecls =
+  let decls, required =
+    List.fold_right
+      (fun (obj_id, obj_abbr, _cl_abbr, _clty, _cltydef, ci) (decls, req) ->
+        (obj_id, obj_abbr) :: decls,
+        variance_of_params ci.Typedtree.ci_params :: req)
+      cldecls ([],[])
+  in
+  let decls =
+    Typedecl_properties.compute_property property env decls required in
+  List.map2
+    (fun (_,decl) (_, _, cl_abbr, clty, cltydef, _) ->
+      let variance = decl.type_variance in
+      (decl, {cl_abbr with type_variance = variance},
+       {clty with cty_variance = variance},
+       {cltydef with clty_variance = variance}))
+    decls cldecls
diff --git a/src/ocaml/typing/typedecl_variance.mli b/src/ocaml/typing/typedecl_variance.mli
new file mode 100644
index 0000000..941ab99
--- /dev/null
+++ b/src/ocaml/typing/typedecl_variance.mli
@@ -0,0 +1,63 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Types
+open Typedecl_properties
+
+type surface_variance = bool * bool * bool
+
+val variance_of_params :
+  (Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list ->
+  surface_variance list
+val variance_of_sdecl :
+  Parsetree.type_declaration -> surface_variance list
+
+type prop = Variance.t list
+type req = surface_variance list
+val property : (Variance.t list, req) property
+
+type variance_error =
+| Variance_not_satisfied of int
+| No_variable
+| Variance_not_reflected
+| Variance_not_deducible
+
+type error =
+| Bad_variance of variance_error * surface_variance * surface_variance
+| Varying_anonymous
+
+exception Error of Location.t * error
+
+val check_variance_extension :
+  Env.t -> type_declaration ->
+  Typedtree.extension_constructor -> req * Location.t -> unit
+
+val compute_decl :
+  Env.t -> check:bool -> type_declaration -> req -> prop
+
+val update_decls :
+  Env.t -> Parsetree.type_declaration list ->
+  (Ident.t * type_declaration) list ->
+  (Ident.t * type_declaration) list
+
+val update_class_decls :
+  Env.t ->
+  (Ident.t * Typedecl_properties.decl * Types.type_declaration *
+   Types.class_declaration * Types.class_type_declaration *
+   'a Typedtree.class_infos) list ->
+  (Typedecl_properties.decl * Types.type_declaration *
+   Types.class_declaration * Types.class_type_declaration) list
+(* FIXME: improve this horrible interface *)
diff --git a/src/ocaml/typing/typedtree.ml b/src/ocaml/typing/typedtree.ml
new file mode 100644
index 0000000..0c3d105
--- /dev/null
+++ b/src/ocaml/typing/typedtree.ml
@@ -0,0 +1,860 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Abstract syntax tree after typing *)
+
+open Asttypes
+open Types
+
+(* Value expressions for the core language *)
+
+type partial = Partial | Total
+
+type attribute = Parsetree.attribute
+type attributes = attribute list
+
+type value = Value_pattern
+type computation = Computation_pattern
+
+type _ pattern_category =
+| Value : value pattern_category
+| Computation : computation pattern_category
+
+type pattern = value general_pattern
+and 'k general_pattern = 'k pattern_desc pattern_data
+
+and 'a pattern_data =
+  { pat_desc: 'a;
+    pat_loc: Location.t;
+    pat_extra : (pat_extra * Location.t * attribute list) list;
+    pat_type: type_expr;
+    pat_env: Env.t;
+    pat_attributes: attribute list;
+   }
+
+and pat_extra =
+  | Tpat_constraint of core_type
+  | Tpat_type of Path.t * Longident.t loc
+  | Tpat_open of Path.t * Longident.t loc * Env.t
+  | Tpat_unpack
+
+and 'k pattern_desc =
+  (* value patterns *)
+  | Tpat_any : value pattern_desc
+  | Tpat_var : Ident.t * string loc -> value pattern_desc
+  | Tpat_alias :
+      value general_pattern * Ident.t * string loc -> value pattern_desc
+  | Tpat_constant : constant -> value pattern_desc
+  | Tpat_tuple : value general_pattern list -> value pattern_desc
+  | Tpat_construct :
+      Longident.t loc * constructor_description * value general_pattern list
+      * (Ident.t loc list * core_type) option ->
+      value pattern_desc
+  | Tpat_variant :
+      label * value general_pattern option * row_desc ref ->
+      value pattern_desc
+  | Tpat_record :
+      (Longident.t loc * label_description * value general_pattern) list *
+        closed_flag ->
+      value pattern_desc
+  | Tpat_array : value general_pattern list -> value pattern_desc
+  | Tpat_lazy : value general_pattern -> value pattern_desc
+  (* computation patterns *)
+  | Tpat_value : tpat_value_argument -> computation pattern_desc
+  | Tpat_exception : value general_pattern -> computation pattern_desc
+  (* generic constructions *)
+  | Tpat_or :
+      'k general_pattern * 'k general_pattern * row_desc option ->
+      'k pattern_desc
+
+and tpat_value_argument = value general_pattern
+
+and expression =
+  { exp_desc: expression_desc;
+    exp_loc: Location.t;
+    exp_extra: (exp_extra * Location.t * attribute list) list;
+    exp_type: type_expr;
+    exp_env: Env.t;
+    exp_attributes: attribute list;
+   }
+
+and exp_extra =
+  | Texp_constraint of core_type
+  | Texp_coerce of core_type option * core_type
+  | Texp_poly of core_type option
+  | Texp_newtype of string
+  | Texp_newtype' of Ident.t * label loc
+
+and expression_desc =
+    Texp_ident of Path.t * Longident.t loc * Types.value_description
+  | Texp_constant of constant
+  | Texp_let of rec_flag * value_binding list * expression
+  | Texp_function of { arg_label : arg_label; param : Ident.t;
+      cases : value case list; partial : partial; }
+  | Texp_apply of expression * (arg_label * expression option) list
+  | Texp_match of expression * computation case list * partial
+  | Texp_try of expression * value case list
+  | Texp_tuple of expression list
+  | Texp_construct of
+      Longident.t loc * constructor_description * expression list
+  | Texp_variant of label * expression option
+  | Texp_record of {
+      fields : ( Types.label_description * record_label_definition ) array;
+      representation : Types.record_representation;
+      extended_expression : expression option;
+    }
+  | Texp_field of expression * Longident.t loc * label_description
+  | Texp_setfield of
+      expression * Longident.t loc * label_description * expression
+  | Texp_array of expression list
+  | Texp_ifthenelse of expression * expression * expression option
+  | Texp_sequence of expression * expression
+  | Texp_while of expression * expression
+  | Texp_for of
+      Ident.t * Parsetree.pattern * expression * expression * direction_flag *
+        expression
+  | Texp_send of expression * meth * expression option
+  | Texp_new of Path.t * Longident.t loc * Types.class_declaration
+  | Texp_instvar of Path.t * Path.t * string loc
+  | Texp_setinstvar of Path.t * Path.t * string loc * expression
+  | Texp_override of Path.t * (Path.t * string loc * expression) list
+  | Texp_letmodule of
+      Ident.t option * string option loc * Types.module_presence * module_expr *
+        expression
+  | Texp_letexception of extension_constructor * expression
+  | Texp_assert of expression
+  | Texp_lazy of expression
+  | Texp_object of class_structure * string list
+  | Texp_pack of module_expr
+  | Texp_letop of {
+      let_ : binding_op;
+      ands : binding_op list;
+      param : Ident.t;
+      body : value case;
+      partial : partial;
+    }
+  | Texp_unreachable
+  | Texp_extension_constructor of Longident.t loc * Path.t
+  | Texp_open of open_declaration * expression
+  | Texp_hole
+
+and meth =
+    Tmeth_name of string
+  | Tmeth_val of Ident.t
+
+and 'k case =
+    {
+     c_lhs: 'k general_pattern;
+     c_guard: expression option;
+     c_rhs: expression;
+    }
+
+and record_label_definition =
+  | Kept of Types.type_expr
+  | Overridden of Longident.t loc * expression
+
+and binding_op =
+  {
+    bop_op_path : Path.t;
+    bop_op_name : string loc;
+    bop_op_val : Types.value_description;
+    bop_op_type : Types.type_expr;
+    bop_exp : expression;
+    bop_loc : Location.t;
+  }
+
+(* Value expressions for the class language *)
+
+and class_expr =
+    {
+     cl_desc: class_expr_desc;
+     cl_loc: Location.t;
+     cl_type: Types.class_type;
+     cl_env: Env.t;
+     cl_attributes: attribute list;
+    }
+
+and class_expr_desc =
+    Tcl_ident of Path.t * Longident.t loc * core_type list
+  | Tcl_structure of class_structure
+  | Tcl_fun of
+      arg_label * pattern * (Ident.t * expression) list
+      * class_expr * partial
+  | Tcl_apply of class_expr * (arg_label * expression option) list
+  | Tcl_let of rec_flag * value_binding list *
+                  (Ident.t * expression) list * class_expr
+  | Tcl_constraint of
+      class_expr * class_type option * string list * string list * Concr.t
+    (* Visible instance variables, methods and concrete methods *)
+  | Tcl_open of open_description * class_expr
+
+and class_structure =
+  {
+   cstr_self: pattern;
+   cstr_fields: class_field list;
+   cstr_type: Types.class_signature;
+   cstr_meths: Ident.t Meths.t;
+  }
+
+and class_field =
+   {
+    cf_desc: class_field_desc;
+    cf_loc: Location.t;
+    cf_attributes: attribute list;
+  }
+
+and class_field_kind =
+  | Tcfk_virtual of core_type
+  | Tcfk_concrete of override_flag * expression
+
+and class_field_desc =
+    Tcf_inherit of
+      override_flag * class_expr * string option * (string * Ident.t) list *
+        (string * Ident.t) list
+    (* Inherited instance variables and concrete methods *)
+  | Tcf_val of string loc * mutable_flag * Ident.t * class_field_kind * bool
+  | Tcf_method of string loc * private_flag * class_field_kind
+  | Tcf_constraint of core_type * core_type
+  | Tcf_initializer of expression
+  | Tcf_attribute of attribute
+
+(* Value expressions for the module language *)
+
+and module_expr =
+  { mod_desc: module_expr_desc;
+    mod_loc: Location.t;
+    mod_type: Types.module_type;
+    mod_env: Env.t;
+    mod_attributes: attribute list;
+   }
+
+and module_type_constraint =
+  Tmodtype_implicit
+| Tmodtype_explicit of module_type
+
+and functor_parameter =
+  | Unit
+  | Named of Ident.t option * string option loc * module_type
+
+and module_expr_desc =
+    Tmod_ident of Path.t * Longident.t loc
+  | Tmod_structure of structure
+  | Tmod_functor of functor_parameter * module_expr
+  | Tmod_apply of module_expr * module_expr * module_coercion
+  | Tmod_constraint of
+      module_expr * Types.module_type * module_type_constraint * module_coercion
+  | Tmod_unpack of expression * Types.module_type
+  | Tmod_hole
+
+and structure = {
+  str_items : structure_item list;
+  str_type : Types.signature;
+  str_final_env : Env.t;
+}
+
+and structure_item =
+  { str_desc : structure_item_desc;
+    str_loc : Location.t;
+    str_env : Env.t
+  }
+
+and structure_item_desc =
+    Tstr_eval of expression * attributes
+  | Tstr_value of rec_flag * value_binding list
+  | Tstr_primitive of value_description
+  | Tstr_type of rec_flag * type_declaration list
+  | Tstr_typext of type_extension
+  | Tstr_exception of type_exception
+  | Tstr_module of module_binding
+  | Tstr_recmodule of module_binding list
+  | Tstr_modtype of module_type_declaration
+  | Tstr_open of open_declaration
+  | Tstr_class of (class_declaration * string list) list
+  | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list
+  | Tstr_include of include_declaration
+  | Tstr_attribute of attribute
+
+and module_binding =
+    {
+     mb_id: Ident.t option;
+     mb_name: string option loc;
+     mb_presence: module_presence;
+     mb_expr: module_expr;
+     mb_attributes: attribute list;
+     mb_loc: Location.t;
+    }
+
+and value_binding =
+  {
+    vb_pat: pattern;
+    vb_expr: expression;
+    vb_attributes: attributes;
+    vb_loc: Location.t;
+  }
+
+and module_coercion =
+    Tcoerce_none
+  | Tcoerce_structure of (int * module_coercion) list *
+                         (Ident.t * int * module_coercion) list
+  | Tcoerce_functor of module_coercion * module_coercion
+  | Tcoerce_primitive of primitive_coercion
+  | Tcoerce_alias of Env.t * Path.t * module_coercion
+
+and module_type =
+  { mty_desc: module_type_desc;
+    mty_type : Types.module_type;
+    mty_env : Env.t;
+    mty_loc: Location.t;
+    mty_attributes: attribute list;
+   }
+
+and module_type_desc =
+    Tmty_ident of Path.t * Longident.t loc
+  | Tmty_signature of signature
+  | Tmty_functor of functor_parameter * module_type
+  | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list
+  | Tmty_typeof of module_expr
+  | Tmty_alias of Path.t * Longident.t loc
+
+(* Keep primitive type information for type-based lambda-code specialization *)
+and primitive_coercion =
+  {
+    pc_desc: Primitive.description;
+    pc_type: type_expr;
+    pc_env: Env.t;
+    pc_loc : Location.t;
+  }
+
+and signature = {
+  sig_items : signature_item list;
+  sig_type : Types.signature;
+  sig_final_env : Env.t;
+}
+
+and signature_item =
+  { sig_desc: signature_item_desc;
+    sig_env : Env.t; (* BINANNOT ADDED *)
+    sig_loc: Location.t }
+
+and signature_item_desc =
+    Tsig_value of value_description
+  | Tsig_type of rec_flag * type_declaration list
+  | Tsig_typesubst of type_declaration list
+  | Tsig_typext of type_extension
+  | Tsig_exception of type_exception
+  | Tsig_module of module_declaration
+  | Tsig_modsubst of module_substitution
+  | Tsig_recmodule of module_declaration list
+  | Tsig_modtype of module_type_declaration
+  | Tsig_modtypesubst of module_type_declaration
+  | Tsig_open of open_description
+  | Tsig_include of include_description
+  | Tsig_class of class_description list
+  | Tsig_class_type of class_type_declaration list
+  | Tsig_attribute of attribute
+
+and module_declaration =
+    {
+     md_id: Ident.t option;
+     md_name: string option loc;
+     md_presence: module_presence;
+     md_type: module_type;
+     md_attributes: attribute list;
+     md_loc: Location.t;
+    }
+
+and module_substitution =
+    {
+     ms_id: Ident.t;
+     ms_name: string loc;
+     ms_manifest: Path.t;
+     ms_txt: Longident.t loc;
+     ms_attributes: attributes;
+     ms_loc: Location.t;
+    }
+
+and module_type_declaration =
+    {
+     mtd_id: Ident.t;
+     mtd_name: string loc;
+     mtd_type: module_type option;
+     mtd_attributes: attribute list;
+     mtd_loc: Location.t;
+    }
+
+and 'a open_infos =
+    {
+     open_expr: 'a;
+     open_bound_items: Types.signature;
+     open_override: override_flag;
+     open_env: Env.t;
+     open_loc: Location.t;
+     open_attributes: attribute list;
+    }
+
+and open_description = (Path.t * Longident.t loc) open_infos
+
+and open_declaration = module_expr open_infos
+
+and 'a include_infos =
+    {
+     incl_mod: 'a;
+     incl_type: Types.signature;
+     incl_loc: Location.t;
+     incl_attributes: attribute list;
+    }
+
+and include_description = module_type include_infos
+
+and include_declaration = module_expr include_infos
+
+and with_constraint =
+    Twith_type of type_declaration
+  | Twith_module of Path.t * Longident.t loc
+  | Twith_modtype of module_type
+  | Twith_typesubst of type_declaration
+  | Twith_modsubst of Path.t * Longident.t loc
+  | Twith_modtypesubst of module_type
+
+
+and core_type =
+(* mutable because of [Typeclass.declare_method] *)
+  { mutable ctyp_desc : core_type_desc;
+    mutable ctyp_type : type_expr;
+    ctyp_env : Env.t; (* BINANNOT ADDED *)
+    ctyp_loc : Location.t;
+    ctyp_attributes: attribute list;
+   }
+
+and core_type_desc =
+    Ttyp_any
+  | Ttyp_var of string
+  | Ttyp_arrow of arg_label * core_type * core_type
+  | Ttyp_tuple of core_type list
+  | Ttyp_constr of Path.t * Longident.t loc * core_type list
+  | Ttyp_object of object_field list * closed_flag
+  | Ttyp_class of Path.t * Longident.t loc * core_type list
+  | Ttyp_alias of core_type * string
+  | Ttyp_variant of row_field list * closed_flag * label list option
+  | Ttyp_poly of string list * core_type
+  | Ttyp_package of package_type
+
+and package_type = {
+  pack_path : Path.t;
+  pack_fields : (Longident.t loc * core_type) list;
+  pack_type : Types.module_type;
+  pack_txt : Longident.t loc;
+}
+
+and row_field = {
+  rf_desc : row_field_desc;
+  rf_loc : Location.t;
+  rf_attributes : attributes;
+}
+
+and row_field_desc =
+    Ttag of string loc * bool * core_type list
+  | Tinherit of core_type
+
+and object_field = {
+  of_desc : object_field_desc;
+  of_loc : Location.t;
+  of_attributes : attributes;
+}
+
+and object_field_desc =
+  | OTtag of string loc * core_type
+  | OTinherit of core_type
+
+and value_description =
+  { val_id: Ident.t;
+    val_name: string loc;
+    val_desc: core_type;
+    val_val: Types.value_description;
+    val_prim: string list;
+    val_loc: Location.t;
+    val_attributes: attribute list;
+    }
+
+and type_declaration =
+  { typ_id: Ident.t;
+    typ_name: string loc;
+    typ_params: (core_type * (variance * injectivity)) list;
+    typ_type: Types.type_declaration;
+    typ_cstrs: (core_type * core_type * Location.t) list;
+    typ_kind: type_kind;
+    typ_private: private_flag;
+    typ_manifest: core_type option;
+    typ_loc: Location.t;
+    typ_attributes: attribute list;
+   }
+
+and type_kind =
+    Ttype_abstract
+  | Ttype_variant of constructor_declaration list
+  | Ttype_record of label_declaration list
+  | Ttype_open
+
+and label_declaration =
+    {
+     ld_id: Ident.t;
+     ld_name: string loc;
+     ld_mutable: mutable_flag;
+     ld_type: core_type;
+     ld_loc: Location.t;
+     ld_attributes: attribute list;
+    }
+
+and constructor_declaration =
+    {
+     cd_id: Ident.t;
+     cd_name: string loc;
+     cd_args: constructor_arguments;
+     cd_res: core_type option;
+     cd_loc: Location.t;
+     cd_attributes: attribute list;
+    }
+
+and constructor_arguments =
+  | Cstr_tuple of core_type list
+  | Cstr_record of label_declaration list
+
+and type_extension =
+  {
+    tyext_path: Path.t;
+    tyext_txt: Longident.t loc;
+    tyext_params: (core_type * (variance * injectivity)) list;
+    tyext_constructors: extension_constructor list;
+    tyext_private: private_flag;
+    tyext_loc: Location.t;
+    tyext_attributes: attribute list;
+  }
+
+and type_exception =
+  {
+    tyexn_constructor: extension_constructor;
+    tyexn_loc: Location.t;
+    tyexn_attributes: attribute list;
+  }
+
+and extension_constructor =
+  {
+    ext_id: Ident.t;
+    ext_name: string loc;
+    ext_type: Types.extension_constructor;
+    ext_kind: extension_constructor_kind;
+    ext_loc: Location.t;
+    ext_attributes: attribute list;
+  }
+
+and extension_constructor_kind =
+    Text_decl of constructor_arguments * core_type option
+  | Text_rebind of Path.t * Longident.t loc
+
+and class_type =
+    {
+     cltyp_desc: class_type_desc;
+     cltyp_type: Types.class_type;
+     cltyp_env: Env.t;
+     cltyp_loc: Location.t;
+     cltyp_attributes: attribute list;
+    }
+
+and class_type_desc =
+    Tcty_constr of Path.t * Longident.t loc * core_type list
+  | Tcty_signature of class_signature
+  | Tcty_arrow of arg_label * core_type * class_type
+  | Tcty_open of open_description * class_type
+
+and class_signature = {
+    csig_self: core_type;
+    csig_fields: class_type_field list;
+    csig_type: Types.class_signature;
+  }
+
+and class_type_field = {
+    ctf_desc: class_type_field_desc;
+    ctf_loc: Location.t;
+    ctf_attributes: attribute list;
+  }
+
+and class_type_field_desc =
+  | Tctf_inherit of class_type
+  | Tctf_val of (string * mutable_flag * virtual_flag * core_type)
+  | Tctf_method of (string * private_flag * virtual_flag * core_type)
+  | Tctf_constraint of (core_type * core_type)
+  | Tctf_attribute of attribute
+
+and class_declaration =
+  class_expr class_infos
+
+and class_description =
+  class_type class_infos
+
+and class_type_declaration =
+  class_type class_infos
+
+and 'a class_infos =
+  { ci_virt: virtual_flag;
+    ci_params: (core_type * (variance * injectivity)) list;
+    ci_id_name: string loc;
+    ci_id_class: Ident.t;
+    ci_id_class_type: Ident.t;
+    ci_id_object: Ident.t;
+    ci_id_typehash: Ident.t;
+    ci_expr: 'a;
+    ci_decl: Types.class_declaration;
+    ci_type_decl: Types.class_type_declaration;
+    ci_loc: Location.t;
+    ci_attributes: attribute list;
+   }
+
+type implementation = {
+  structure: structure;
+  coercion: module_coercion;
+  signature: Types.signature
+}
+
+
+(* Auxiliary functions over the a.s.t. *)
+
+let as_computation_pattern (p : pattern) : computation general_pattern =
+  {
+    pat_desc = Tpat_value p;
+    pat_loc = p.pat_loc;
+    pat_extra = [];
+    pat_type = p.pat_type;
+    pat_env = p.pat_env;
+    pat_attributes = [];
+  }
+
+let rec classify_pattern_desc : type k . k pattern_desc -> k pattern_category =
+  function
+  | Tpat_alias _ -> Value
+  | Tpat_tuple _ -> Value
+  | Tpat_construct _ -> Value
+  | Tpat_variant _ -> Value
+  | Tpat_record _ -> Value
+  | Tpat_array _ -> Value
+  | Tpat_lazy _ -> Value
+  | Tpat_any -> Value
+  | Tpat_var _ -> Value
+  | Tpat_constant _ -> Value
+
+  | Tpat_value _ -> Computation
+  | Tpat_exception _ -> Computation
+
+  | Tpat_or(p1, p2, _) ->
+     begin match classify_pattern p1, classify_pattern p2 with
+     | Value, Value -> Value
+     | Computation, Computation -> Computation
+     end
+
+and classify_pattern
+  : type k . k general_pattern -> k pattern_category
+  = fun pat ->
+  classify_pattern_desc pat.pat_desc
+
+type pattern_action =
+  { f : 'k . 'k general_pattern -> unit }
+let shallow_iter_pattern_desc
+  : type k . pattern_action -> k pattern_desc -> unit
+  = fun f -> function
+  | Tpat_alias(p, _, _) -> f.f p
+  | Tpat_tuple patl -> List.iter f.f patl
+  | Tpat_construct(_, _, patl, _) -> List.iter f.f patl
+  | Tpat_variant(_, pat, _) -> Option.iter f.f pat
+  | Tpat_record (lbl_pat_list, _) ->
+      List.iter (fun (_, _, pat) -> f.f pat) lbl_pat_list
+  | Tpat_array patl -> List.iter f.f patl
+  | Tpat_lazy p -> f.f p
+  | Tpat_any
+  | Tpat_var _
+  | Tpat_constant _ -> ()
+  | Tpat_value p -> f.f p
+  | Tpat_exception p -> f.f p
+  | Tpat_or(p1, p2, _) -> f.f p1; f.f p2
+
+type pattern_transformation =
+  { f : 'k . 'k general_pattern -> 'k general_pattern }
+let shallow_map_pattern_desc
+  : type k . pattern_transformation -> k pattern_desc -> k pattern_desc
+  = fun f d -> match d with
+  | Tpat_alias (p1, id, s) ->
+      Tpat_alias (f.f p1, id, s)
+  | Tpat_tuple pats ->
+      Tpat_tuple (List.map f.f pats)
+  | Tpat_record (lpats, closed) ->
+      Tpat_record (List.map (fun (lid, l,p) -> lid, l, f.f p) lpats, closed)
+  | Tpat_construct (lid, c, pats, ty) ->
+      Tpat_construct (lid, c, List.map f.f pats, ty)
+  | Tpat_array pats ->
+      Tpat_array (List.map f.f pats)
+  | Tpat_lazy p1 -> Tpat_lazy (f.f p1)
+  | Tpat_variant (x1, Some p1, x2) ->
+      Tpat_variant (x1, Some (f.f p1), x2)
+  | Tpat_var _
+  | Tpat_constant _
+  | Tpat_any
+  | Tpat_variant (_,None,_) -> d
+  | Tpat_value p -> Tpat_value (f.f p)
+  | Tpat_exception p -> Tpat_exception (f.f p)
+  | Tpat_or (p1,p2,path) ->
+      Tpat_or (f.f p1, f.f p2, path)
+
+let rec iter_general_pattern
+  : type k . pattern_action -> k general_pattern -> unit
+  = fun f p ->
+  f.f p;
+  shallow_iter_pattern_desc
+    { f = fun p -> iter_general_pattern f p }
+    p.pat_desc
+
+let iter_pattern (f : pattern -> unit) =
+  iter_general_pattern
+    { f = fun (type k) (p : k general_pattern) ->
+          match classify_pattern p with
+          | Value -> f p
+          | Computation -> () }
+
+type pattern_predicate = { f : 'k . 'k general_pattern -> bool }
+let exists_general_pattern (f : pattern_predicate) p =
+  let exception Found in
+  match
+    iter_general_pattern
+      { f = fun p -> if f.f p then raise Found else () }
+      p
+  with
+  | exception Found -> true
+  | () -> false
+
+let exists_pattern (f : pattern -> bool) =
+  exists_general_pattern
+    { f = fun (type k) (p : k general_pattern) ->
+          match classify_pattern p with
+          | Value -> f p
+          | Computation -> false }
+
+
+(* List the identifiers bound by a pattern or a let *)
+
+let rec iter_bound_idents
+  : type k . _ -> k general_pattern -> _
+  = fun f pat ->
+  match pat.pat_desc with
+  | Tpat_var (id,s) ->
+     f (id,s,pat.pat_type)
+  | Tpat_alias(p, id, s) ->
+      iter_bound_idents f p;
+      f (id,s,pat.pat_type)
+  | Tpat_or(p1, _, _) ->
+      (* Invariant : both arguments bind the same variables *)
+      iter_bound_idents f p1
+  | d ->
+     shallow_iter_pattern_desc
+       { f = fun p -> iter_bound_idents f p }
+       d
+
+let rev_pat_bound_idents_full pat =
+  let idents_full = ref [] in
+  let add id_full = idents_full := id_full :: !idents_full in
+  iter_bound_idents add pat;
+  !idents_full
+
+let rev_only_idents idents_full =
+  List.rev_map (fun (id,_,_) -> id) idents_full
+
+let pat_bound_idents_full pat =
+  List.rev (rev_pat_bound_idents_full pat)
+
+let pat_bound_idents pat =
+  rev_only_idents (rev_pat_bound_idents_full pat)
+
+let rev_let_bound_idents_full bindings =
+  let idents_full = ref [] in
+  let add id_full = idents_full := id_full :: !idents_full in
+  List.iter (fun vb -> iter_bound_idents add vb.vb_pat) bindings;
+  !idents_full
+
+let let_bound_idents_full bindings =
+  List.rev (rev_let_bound_idents_full bindings)
+let let_bound_idents pat =
+  rev_only_idents (rev_let_bound_idents_full pat)
+
+let alpha_var env id = List.assoc id env
+
+let rec alpha_pat
+  : type k . _ -> k general_pattern -> k general_pattern
+  = fun env p -> match p.pat_desc with
+  | Tpat_var (id, s) -> (* note the ``Not_found'' case *)
+      {p with pat_desc =
+       try Tpat_var (alpha_var env id, s) with
+       | Not_found -> Tpat_any}
+  | Tpat_alias (p1, id, s) ->
+      let new_p : k general_pattern =  alpha_pat env p1 in
+      begin try
+        {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s)}
+      with
+      | Not_found -> new_p
+      end
+  | d ->
+     let pat_desc =
+       shallow_map_pattern_desc { f = fun p -> alpha_pat env p } d in
+     {p with pat_desc}
+
+let mkloc = Location.mkloc
+let mknoloc = Location.mknoloc
+
+let split_pattern pat =
+  let combine_opts merge p1 p2 =
+    match p1, p2 with
+    | None, None -> None
+    | Some p, None
+    | None, Some p ->
+        Some p
+    | Some p1, Some p2 ->
+        Some (merge p1 p2)
+  in
+  let into pat p1 p2 =
+    (* The third parameter of [Tpat_or] is [Some _] only for "#typ"
+       patterns, which we do *not* expand. Hence we can put [None] here. *)
+    { pat with pat_desc = Tpat_or (p1, p2, None) } in
+  let rec split_pattern cpat =
+    match cpat.pat_desc with
+    | Tpat_value p ->
+        Some p, None
+    | Tpat_exception p ->
+        None, Some p
+    | Tpat_or (cp1, cp2, _) ->
+        let vals1, exns1 = split_pattern cp1 in
+        let vals2, exns2 = split_pattern cp2 in
+        combine_opts (into cpat) vals1 vals2,
+        (* We could change the pattern type for exception patterns to
+           [Predef.exn], but it doesn't really matter. *)
+        combine_opts (into cpat) exns1 exns2
+  in
+  split_pattern pat
+
+(* Merlin specific *)
+
+let unpack_functor_me me =
+  match me.mod_desc with
+  | Tmod_functor (fp, mty) -> fp, mty
+  | _ -> invalid_arg "Typedtree.unpack_functor_me (merlin)"
+
+let unpack_functor_mty mty =
+  match mty.mty_desc with
+  | Tmty_functor (fp, mty) -> fp, mty
+  | _ -> invalid_arg "Typedtree.unpack_functor_mty (merlin)"
diff --git a/src/ocaml/typing/typedtree.mli b/src/ocaml/typing/typedtree.mli
new file mode 100644
index 0000000..24271fa
--- /dev/null
+++ b/src/ocaml/typing/typedtree.mli
@@ -0,0 +1,835 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Abstract syntax tree after typing *)
+
+
+(** By comparison with {!Parsetree}:
+    - Every {!Longindent.t} is accompanied by a resolved {!Path.t}.
+
+*)
+
+open Asttypes
+
+(* Value expressions for the core language *)
+
+type partial = Partial | Total
+
+(** {1 Extension points} *)
+
+type attribute = Parsetree.attribute
+type attributes = attribute list
+
+(** {1 Core language} *)
+
+type value = Value_pattern
+type computation = Computation_pattern
+
+type _ pattern_category =
+| Value : value pattern_category
+| Computation : computation pattern_category
+
+type pattern = value general_pattern
+and 'k general_pattern = 'k pattern_desc pattern_data
+
+and 'a pattern_data =
+  { pat_desc: 'a;
+    pat_loc: Location.t;
+    pat_extra : (pat_extra * Location.t * attributes) list;
+    pat_type: Types.type_expr;
+    pat_env: Env.t;
+    pat_attributes: attributes;
+   }
+
+and pat_extra =
+  | Tpat_constraint of core_type
+        (** P : T          { pat_desc = P
+                           ; pat_extra = (Tpat_constraint T, _, _) :: ... }
+         *)
+  | Tpat_type of Path.t * Longident.t loc
+        (** #tconst        { pat_desc = disjunction
+                           ; pat_extra = (Tpat_type (P, "tconst"), _, _) :: ...}
+
+                           where [disjunction] is a [Tpat_or _] representing the
+                           branches of [tconst].
+         *)
+  | Tpat_open of Path.t * Longident.t loc * Env.t
+  | Tpat_unpack
+        (** (module P)     { pat_desc  = Tpat_var "P"
+                           ; pat_extra = (Tpat_unpack, _, _) :: ... }
+         *)
+
+and 'k pattern_desc =
+  (* value patterns *)
+  | Tpat_any : value pattern_desc
+        (** _ *)
+  | Tpat_var : Ident.t * string loc -> value pattern_desc
+        (** x *)
+  | Tpat_alias :
+      value general_pattern * Ident.t * string loc -> value pattern_desc
+        (** P as a *)
+  | Tpat_constant : constant -> value pattern_desc
+        (** 1, 'a', "true", 1.0, 1l, 1L, 1n *)
+  | Tpat_tuple : value general_pattern list -> value pattern_desc
+        (** (P1, ..., Pn)
+
+            Invariant: n >= 2
+         *)
+  | Tpat_construct :
+      Longident.t loc * Types.constructor_description *
+        value general_pattern list * (Ident.t loc list * core_type) option ->
+      value pattern_desc
+        (** C                             ([], None)
+            C P                           ([P], None)
+            C (P1, ..., Pn)               ([P1; ...; Pn], None)
+            C (P : t)                     ([P], Some ([], t))
+            C (P1, ..., Pn : t)           ([P1; ...; Pn], Some ([], t))
+            C (type a) (P : t)            ([P], Some ([a], t))
+            C (type a) (P1, ..., Pn : t)  ([P1; ...; Pn], Some ([a], t))
+          *)
+  | Tpat_variant :
+      label * value general_pattern option * Types.row_desc ref ->
+      value pattern_desc
+        (** `A             (None)
+            `A P           (Some P)
+
+            See {!Types.row_desc} for an explanation of the last parameter.
+         *)
+  | Tpat_record :
+      (Longident.t loc * Types.label_description * value general_pattern) list *
+        closed_flag ->
+      value pattern_desc
+        (** { l1=P1; ...; ln=Pn }     (flag = Closed)
+            { l1=P1; ...; ln=Pn; _}   (flag = Open)
+
+            Invariant: n > 0
+         *)
+  | Tpat_array : value general_pattern list -> value pattern_desc
+        (** [| P1; ...; Pn |] *)
+  | Tpat_lazy : value general_pattern -> value pattern_desc
+        (** lazy P *)
+  (* computation patterns *)
+  | Tpat_value : tpat_value_argument -> computation pattern_desc
+        (** P
+
+            Invariant: Tpat_value pattern should not carry
+            pat_attributes or pat_extra metadata coming from user
+            syntax, which must be on the inner pattern node -- to
+            facilitate searching for a certain value pattern
+            constructor with a specific attributed.
+
+            To enforce this restriction, we made the argument of
+            the Tpat_value constructor a private synonym of [pattern],
+            requiring you to use the [as_computation_pattern] function
+            below instead of using the [Tpat_value] constructor directly.
+         *)
+  | Tpat_exception : value general_pattern -> computation pattern_desc
+        (** exception P *)
+  (* generic constructions *)
+  | Tpat_or :
+      'k general_pattern * 'k general_pattern * Types.row_desc option ->
+      'k pattern_desc
+        (** P1 | P2
+
+            [row_desc] = [Some _] when translating [Ppat_type _],
+                         [None] otherwise.
+         *)
+
+and tpat_value_argument = private value general_pattern
+
+and expression =
+  { exp_desc: expression_desc;
+    exp_loc: Location.t;
+    exp_extra: (exp_extra * Location.t * attributes) list;
+    exp_type: Types.type_expr;
+    exp_env: Env.t;
+    exp_attributes: attributes;
+   }
+
+and exp_extra =
+  | Texp_constraint of core_type
+        (** E : T *)
+  | Texp_coerce of core_type option * core_type
+        (** E :> T           [Texp_coerce (None, T)]
+            E : T0 :> T      [Texp_coerce (Some T0, T)]
+         *)
+  | Texp_poly of core_type option
+        (** Used for method bodies. *)
+  | Texp_newtype of string
+        (** fun (type t) ->  *)
+  | Texp_newtype' of Ident.t * label loc
+  (** merlin-specific: keep enough information to correctly implement
+      occurrences for local-types.
+      Merlin typechecker uses [Texp_newtype'] constructor, while upstream
+      OCaml still uses [Texp_newtype]. Those can appear when unmarshaling cmt
+      files. By adding a new constructor, we can still safely uses these. *)
+
+and expression_desc =
+    Texp_ident of Path.t * Longident.t loc * Types.value_description
+        (** x
+            M.x
+         *)
+  | Texp_constant of constant
+        (** 1, 'a', "true", 1.0, 1l, 1L, 1n *)
+  | Texp_let of rec_flag * value_binding list * expression
+        (** let P1 = E1 and ... and Pn = EN in E       (flag = Nonrecursive)
+            let rec P1 = E1 and ... and Pn = EN in E   (flag = Recursive)
+         *)
+  | Texp_function of { arg_label : arg_label; param : Ident.t;
+      cases : value case list; partial : partial; }
+        (** [Pexp_fun] and [Pexp_function] both translate to [Texp_function].
+            See {!Parsetree} for more details.
+
+            [param] is the identifier that is to be used to name the
+            parameter of the function.
+
+            partial =
+              [Partial] if the pattern match is partial
+              [Total] otherwise.
+         *)
+  | Texp_apply of expression * (arg_label * expression option) list
+        (** E0 ~l1:E1 ... ~ln:En
+
+            The expression can be None if the expression is abstracted over
+            this argument. It currently appears when a label is applied.
+
+            For example:
+            let f x ~y = x + y in
+            f ~y:3
+
+            The resulting typedtree for the application is:
+            Texp_apply (Texp_ident "f/1037",
+                        [(Nolabel, None);
+                         (Labelled "y", Some (Texp_constant Const_int 3))
+                        ])
+         *)
+  | Texp_match of expression * computation case list * partial
+        (** match E0 with
+            | P1 -> E1
+            | P2 | exception P3 -> E2
+            | exception P4 -> E3
+
+            [Texp_match (E0, [(P1, E1); (P2 | exception P3, E2);
+                              (exception P4, E3)], _)]
+         *)
+  | Texp_try of expression * value case list
+        (** try E with P1 -> E1 | ... | PN -> EN *)
+  | Texp_tuple of expression list
+        (** (E1, ..., EN) *)
+  | Texp_construct of
+      Longident.t loc * Types.constructor_description * expression list
+        (** C                []
+            C E              [E]
+            C (E1, ..., En)  [E1;...;En]
+         *)
+  | Texp_variant of label * expression option
+  | Texp_record of {
+      fields : ( Types.label_description * record_label_definition ) array;
+      representation : Types.record_representation;
+      extended_expression : expression option;
+    }
+        (** { l1=P1; ...; ln=Pn }           (extended_expression = None)
+            { E0 with l1=P1; ...; ln=Pn }   (extended_expression = Some E0)
+
+            Invariant: n > 0
+
+            If the type is { l1: t1; l2: t2 }, the expression
+            { E0 with t2=P2 } is represented as
+            Texp_record
+              { fields = [| l1, Kept t1; l2 Override P2 |]; representation;
+                extended_expression = Some E0 }
+        *)
+  | Texp_field of expression * Longident.t loc * Types.label_description
+  | Texp_setfield of
+      expression * Longident.t loc * Types.label_description * expression
+  | Texp_array of expression list
+  | Texp_ifthenelse of expression * expression * expression option
+  | Texp_sequence of expression * expression
+  | Texp_while of expression * expression
+  | Texp_for of
+      Ident.t * Parsetree.pattern * expression * expression * direction_flag *
+        expression
+  | Texp_send of expression * meth * expression option
+  | Texp_new of Path.t * Longident.t loc * Types.class_declaration
+  | Texp_instvar of Path.t * Path.t * string loc
+  | Texp_setinstvar of Path.t * Path.t * string loc * expression
+  | Texp_override of Path.t * (Path.t * string loc * expression) list
+  | Texp_letmodule of
+      Ident.t option * string option loc * Types.module_presence * module_expr *
+        expression
+  | Texp_letexception of extension_constructor * expression
+  | Texp_assert of expression
+  | Texp_lazy of expression
+  | Texp_object of class_structure * string list
+  | Texp_pack of module_expr
+  | Texp_letop of {
+      let_ : binding_op;
+      ands : binding_op list;
+      param : Ident.t;
+      body : value case;
+      partial : partial;
+    }
+  | Texp_unreachable
+  | Texp_extension_constructor of Longident.t loc * Path.t
+  | Texp_open of open_declaration * expression
+        (** let open[!] M in e *)
+  | Texp_hole
+
+and meth =
+    Tmeth_name of string
+  | Tmeth_val of Ident.t
+
+and 'k case =
+    {
+     c_lhs: 'k general_pattern;
+     c_guard: expression option;
+     c_rhs: expression;
+    }
+
+and record_label_definition =
+  | Kept of Types.type_expr
+  | Overridden of Longident.t loc * expression
+
+and binding_op =
+  {
+    bop_op_path : Path.t;
+    bop_op_name : string loc;
+    bop_op_val : Types.value_description;
+    bop_op_type : Types.type_expr;
+    (* This is the type at which the operator was used.
+       It is always an instance of [bop_op_val.val_type] *)
+    bop_exp : expression;
+    bop_loc : Location.t;
+  }
+
+(* Value expressions for the class language *)
+
+and class_expr =
+    {
+     cl_desc: class_expr_desc;
+     cl_loc: Location.t;
+     cl_type: Types.class_type;
+     cl_env: Env.t;
+     cl_attributes: attributes;
+    }
+
+and class_expr_desc =
+    Tcl_ident of Path.t * Longident.t loc * core_type list
+  | Tcl_structure of class_structure
+  | Tcl_fun of
+      arg_label * pattern * (Ident.t * expression) list
+      * class_expr * partial
+  | Tcl_apply of class_expr * (arg_label * expression option) list
+  | Tcl_let of rec_flag * value_binding list *
+                  (Ident.t * expression) list * class_expr
+  | Tcl_constraint of
+      class_expr * class_type option * string list * string list * Types.Concr.t
+  (* Visible instance variables, methods and concrete methods *)
+  | Tcl_open of open_description * class_expr
+
+and class_structure =
+  {
+   cstr_self: pattern;
+   cstr_fields: class_field list;
+   cstr_type: Types.class_signature;
+   cstr_meths: Ident.t Types.Meths.t;
+  }
+
+and class_field =
+   {
+    cf_desc: class_field_desc;
+    cf_loc: Location.t;
+    cf_attributes: attributes;
+  }
+
+and class_field_kind =
+  | Tcfk_virtual of core_type
+  | Tcfk_concrete of override_flag * expression
+
+and class_field_desc =
+    Tcf_inherit of
+      override_flag * class_expr * string option * (string * Ident.t) list *
+        (string * Ident.t) list
+    (* Inherited instance variables and concrete methods *)
+  | Tcf_val of string loc * mutable_flag * Ident.t * class_field_kind * bool
+  | Tcf_method of string loc * private_flag * class_field_kind
+  | Tcf_constraint of core_type * core_type
+  | Tcf_initializer of expression
+  | Tcf_attribute of attribute
+
+(* Value expressions for the module language *)
+
+and module_expr =
+  { mod_desc: module_expr_desc;
+    mod_loc: Location.t;
+    mod_type: Types.module_type;
+    mod_env: Env.t;
+    mod_attributes: attributes;
+   }
+
+(** Annotations for [Tmod_constraint]. *)
+and module_type_constraint =
+  | Tmodtype_implicit
+  (** The module type constraint has been synthesized during typechecking. *)
+  | Tmodtype_explicit of module_type
+  (** The module type was in the source file. *)
+
+and functor_parameter =
+  | Unit
+  | Named of Ident.t option * string option loc * module_type
+
+and module_expr_desc =
+    Tmod_ident of Path.t * Longident.t loc
+  | Tmod_structure of structure
+  | Tmod_functor of functor_parameter * module_expr
+  | Tmod_apply of module_expr * module_expr * module_coercion
+  | Tmod_constraint of
+      module_expr * Types.module_type * module_type_constraint * module_coercion
+    (** ME          (constraint = Tmodtype_implicit)
+        (ME : MT)   (constraint = Tmodtype_explicit MT)
+     *)
+  | Tmod_unpack of expression * Types.module_type
+  | Tmod_hole
+
+and structure = {
+  str_items : structure_item list;
+  str_type : Types.signature;
+  str_final_env : Env.t;
+}
+
+and structure_item =
+  { str_desc : structure_item_desc;
+    str_loc : Location.t;
+    str_env : Env.t
+  }
+
+and structure_item_desc =
+    Tstr_eval of expression * attributes
+  | Tstr_value of rec_flag * value_binding list
+  | Tstr_primitive of value_description
+  | Tstr_type of rec_flag * type_declaration list
+  | Tstr_typext of type_extension
+  | Tstr_exception of type_exception
+  | Tstr_module of module_binding
+  | Tstr_recmodule of module_binding list
+  | Tstr_modtype of module_type_declaration
+  | Tstr_open of open_declaration
+  | Tstr_class of (class_declaration * string list) list
+  | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list
+  | Tstr_include of include_declaration
+  | Tstr_attribute of attribute
+
+and module_binding =
+    {
+     mb_id: Ident.t option;
+     mb_name: string option loc;
+     mb_presence: Types.module_presence;
+     mb_expr: module_expr;
+     mb_attributes: attributes;
+     mb_loc: Location.t;
+    }
+
+and value_binding =
+  {
+    vb_pat: pattern;
+    vb_expr: expression;
+    vb_attributes: attributes;
+    vb_loc: Location.t;
+  }
+
+and module_coercion =
+    Tcoerce_none
+  | Tcoerce_structure of (int * module_coercion) list *
+                         (Ident.t * int * module_coercion) list
+  | Tcoerce_functor of module_coercion * module_coercion
+  | Tcoerce_primitive of primitive_coercion
+  | Tcoerce_alias of Env.t * Path.t * module_coercion
+
+and module_type =
+  { mty_desc: module_type_desc;
+    mty_type : Types.module_type;
+    mty_env : Env.t;
+    mty_loc: Location.t;
+    mty_attributes: attributes;
+   }
+
+and module_type_desc =
+    Tmty_ident of Path.t * Longident.t loc
+  | Tmty_signature of signature
+  | Tmty_functor of functor_parameter * module_type
+  | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list
+  | Tmty_typeof of module_expr
+  | Tmty_alias of Path.t * Longident.t loc
+
+and primitive_coercion =
+  {
+    pc_desc: Primitive.description;
+    pc_type: Types.type_expr;
+    pc_env: Env.t;
+    pc_loc : Location.t;
+  }
+
+and signature = {
+  sig_items : signature_item list;
+  sig_type : Types.signature;
+  sig_final_env : Env.t;
+}
+
+and signature_item =
+  { sig_desc: signature_item_desc;
+    sig_env : Env.t; (* BINANNOT ADDED *)
+    sig_loc: Location.t }
+
+and signature_item_desc =
+    Tsig_value of value_description
+  | Tsig_type of rec_flag * type_declaration list
+  | Tsig_typesubst of type_declaration list
+  | Tsig_typext of type_extension
+  | Tsig_exception of type_exception
+  | Tsig_module of module_declaration
+  | Tsig_modsubst of module_substitution
+  | Tsig_recmodule of module_declaration list
+  | Tsig_modtype of module_type_declaration
+  | Tsig_modtypesubst of module_type_declaration
+  | Tsig_open of open_description
+  | Tsig_include of include_description
+  | Tsig_class of class_description list
+  | Tsig_class_type of class_type_declaration list
+  | Tsig_attribute of attribute
+
+and module_declaration =
+    {
+     md_id: Ident.t option;
+     md_name: string option loc;
+     md_presence: Types.module_presence;
+     md_type: module_type;
+     md_attributes: attributes;
+     md_loc: Location.t;
+    }
+
+and module_substitution =
+    {
+     ms_id: Ident.t;
+     ms_name: string loc;
+     ms_manifest: Path.t;
+     ms_txt: Longident.t loc;
+     ms_attributes: attributes;
+     ms_loc: Location.t;
+    }
+
+and module_type_declaration =
+    {
+     mtd_id: Ident.t;
+     mtd_name: string loc;
+     mtd_type: module_type option;
+     mtd_attributes: attributes;
+     mtd_loc: Location.t;
+    }
+
+and 'a open_infos =
+    {
+     open_expr: 'a;
+     open_bound_items: Types.signature;
+     open_override: override_flag;
+     open_env: Env.t;
+     open_loc: Location.t;
+     open_attributes: attribute list;
+    }
+
+and open_description = (Path.t * Longident.t loc) open_infos
+
+and open_declaration = module_expr open_infos
+
+
+and 'a include_infos =
+    {
+     incl_mod: 'a;
+     incl_type: Types.signature;
+     incl_loc: Location.t;
+     incl_attributes: attribute list;
+    }
+
+and include_description = module_type include_infos
+
+and include_declaration = module_expr include_infos
+
+and with_constraint =
+    Twith_type of type_declaration
+  | Twith_module of Path.t * Longident.t loc
+  | Twith_modtype of module_type
+  | Twith_typesubst of type_declaration
+  | Twith_modsubst of Path.t * Longident.t loc
+  | Twith_modtypesubst of module_type
+
+and core_type =
+  { mutable ctyp_desc : core_type_desc;
+      (** mutable because of [Typeclass.declare_method] *)
+    mutable ctyp_type : Types.type_expr;
+      (** mutable because of [Typeclass.declare_method] *)
+    ctyp_env : Env.t; (* BINANNOT ADDED *)
+    ctyp_loc : Location.t;
+    ctyp_attributes: attributes;
+   }
+
+and core_type_desc =
+    Ttyp_any
+  | Ttyp_var of string
+  | Ttyp_arrow of arg_label * core_type * core_type
+  | Ttyp_tuple of core_type list
+  | Ttyp_constr of Path.t * Longident.t loc * core_type list
+  | Ttyp_object of object_field list * closed_flag
+  | Ttyp_class of Path.t * Longident.t loc * core_type list
+  | Ttyp_alias of core_type * string
+  | Ttyp_variant of row_field list * closed_flag * label list option
+  | Ttyp_poly of string list * core_type
+  | Ttyp_package of package_type
+
+and package_type = {
+  pack_path : Path.t;
+  pack_fields : (Longident.t loc * core_type) list;
+  pack_type : Types.module_type;
+  pack_txt : Longident.t loc;
+}
+
+and row_field = {
+  rf_desc : row_field_desc;
+  rf_loc : Location.t;
+  rf_attributes : attributes;
+}
+
+and row_field_desc =
+    Ttag of string loc * bool * core_type list
+  | Tinherit of core_type
+
+and object_field = {
+  of_desc : object_field_desc;
+  of_loc : Location.t;
+  of_attributes : attributes;
+}
+
+and object_field_desc =
+  | OTtag of string loc * core_type
+  | OTinherit of core_type
+
+and value_description =
+  { val_id: Ident.t;
+    val_name: string loc;
+    val_desc: core_type;
+    val_val: Types.value_description;
+    val_prim: string list;
+    val_loc: Location.t;
+    val_attributes: attributes;
+    }
+
+and type_declaration =
+  {
+    typ_id: Ident.t;
+    typ_name: string loc;
+    typ_params: (core_type * (variance * injectivity)) list;
+    typ_type: Types.type_declaration;
+    typ_cstrs: (core_type * core_type * Location.t) list;
+    typ_kind: type_kind;
+    typ_private: private_flag;
+    typ_manifest: core_type option;
+    typ_loc: Location.t;
+    typ_attributes: attributes;
+   }
+
+and type_kind =
+    Ttype_abstract
+  | Ttype_variant of constructor_declaration list
+  | Ttype_record of label_declaration list
+  | Ttype_open
+
+and label_declaration =
+    {
+     ld_id: Ident.t;
+     ld_name: string loc;
+     ld_mutable: mutable_flag;
+     ld_type: core_type;
+     ld_loc: Location.t;
+     ld_attributes: attributes;
+    }
+
+and constructor_declaration =
+    {
+     cd_id: Ident.t;
+     cd_name: string loc;
+     cd_args: constructor_arguments;
+     cd_res: core_type option;
+     cd_loc: Location.t;
+     cd_attributes: attributes;
+    }
+
+and constructor_arguments =
+  | Cstr_tuple of core_type list
+  | Cstr_record of label_declaration list
+
+and type_extension =
+  {
+    tyext_path: Path.t;
+    tyext_txt: Longident.t loc;
+    tyext_params: (core_type * (variance * injectivity)) list;
+    tyext_constructors: extension_constructor list;
+    tyext_private: private_flag;
+    tyext_loc: Location.t;
+    tyext_attributes: attributes;
+  }
+
+and type_exception =
+  {
+    tyexn_constructor: extension_constructor;
+    tyexn_loc: Location.t;
+    tyexn_attributes: attribute list;
+  }
+
+and extension_constructor =
+  {
+    ext_id: Ident.t;
+    ext_name: string loc;
+    ext_type : Types.extension_constructor;
+    ext_kind : extension_constructor_kind;
+    ext_loc : Location.t;
+    ext_attributes: attributes;
+  }
+
+and extension_constructor_kind =
+    Text_decl of constructor_arguments * core_type option
+  | Text_rebind of Path.t * Longident.t loc
+
+and class_type =
+    {
+     cltyp_desc: class_type_desc;
+     cltyp_type: Types.class_type;
+     cltyp_env: Env.t;
+     cltyp_loc: Location.t;
+     cltyp_attributes: attributes;
+    }
+
+and class_type_desc =
+    Tcty_constr of Path.t * Longident.t loc * core_type list
+  | Tcty_signature of class_signature
+  | Tcty_arrow of arg_label * core_type * class_type
+  | Tcty_open of open_description * class_type
+
+and class_signature = {
+    csig_self : core_type;
+    csig_fields : class_type_field list;
+    csig_type : Types.class_signature;
+  }
+
+and class_type_field = {
+    ctf_desc: class_type_field_desc;
+    ctf_loc: Location.t;
+    ctf_attributes: attributes;
+  }
+
+and class_type_field_desc =
+  | Tctf_inherit of class_type
+  | Tctf_val of (string * mutable_flag * virtual_flag * core_type)
+  | Tctf_method of (string * private_flag * virtual_flag * core_type)
+  | Tctf_constraint of (core_type * core_type)
+  | Tctf_attribute of attribute
+
+and class_declaration =
+  class_expr class_infos
+
+and class_description =
+  class_type class_infos
+
+and class_type_declaration =
+  class_type class_infos
+
+and 'a class_infos =
+  { ci_virt: virtual_flag;
+    ci_params: (core_type * (variance * injectivity)) list;
+    ci_id_name : string loc;
+    ci_id_class: Ident.t;
+    ci_id_class_type : Ident.t;
+    ci_id_object : Ident.t;
+    ci_id_typehash : Ident.t;
+    ci_expr: 'a;
+    ci_decl: Types.class_declaration;
+    ci_type_decl : Types.class_type_declaration;
+    ci_loc: Location.t;
+    ci_attributes: attributes;
+   }
+
+type implementation = {
+  structure: structure;
+  coercion: module_coercion;
+  signature: Types.signature
+}
+(** A typechecked implementation including its module structure, its exported
+    signature, and a coercion of the module against that signature.
+
+    If an .mli file is present, the signature will come from that file and be
+    the exported signature of the module.
+
+    If there isn't one, the signature will be inferred from the module
+    structure.
+*)
+
+(* Auxiliary functions over the a.s.t. *)
+
+(** [as_computation_pattern p] is a computation pattern with description
+    [Tpat_value p], which enforces a correct placement of pat_attributes
+    and pat_extra metadata (on the inner value pattern, rather than on
+    the computation pattern). *)
+val as_computation_pattern: pattern -> computation general_pattern
+
+val classify_pattern_desc: 'k pattern_desc -> 'k pattern_category
+val classify_pattern: 'k general_pattern -> 'k pattern_category
+
+type pattern_action =
+  { f : 'k . 'k general_pattern -> unit }
+val shallow_iter_pattern_desc:
+    pattern_action -> 'k pattern_desc -> unit
+
+type pattern_transformation =
+  { f : 'k . 'k general_pattern -> 'k general_pattern }
+val shallow_map_pattern_desc:
+    pattern_transformation -> 'k pattern_desc -> 'k pattern_desc
+
+val iter_general_pattern: pattern_action -> 'k general_pattern -> unit
+val iter_pattern: (pattern -> unit) -> pattern -> unit
+
+type pattern_predicate = { f : 'k . 'k general_pattern -> bool }
+val exists_general_pattern: pattern_predicate -> 'k general_pattern -> bool
+val exists_pattern: (pattern -> bool) -> pattern -> bool
+
+val let_bound_idents: value_binding list -> Ident.t list
+val let_bound_idents_full:
+    value_binding list -> (Ident.t * string loc * Types.type_expr) list
+
+(** Alpha conversion of patterns *)
+val alpha_pat:
+  (Ident.t * Ident.t) list -> 'k general_pattern -> 'k general_pattern
+
+val mknoloc: 'a -> 'a Asttypes.loc
+val mkloc: 'a -> Location.t -> 'a Asttypes.loc
+
+val pat_bound_idents: 'k general_pattern -> Ident.t list
+val pat_bound_idents_full:
+  'k general_pattern -> (Ident.t * string loc * Types.type_expr) list
+
+(** Splits an or pattern into its value (left) and exception (right) parts. *)
+val split_pattern:
+  computation general_pattern -> pattern option * pattern option
+
+(* Merlin specific *)
+
+val unpack_functor_me : module_expr -> functor_parameter * module_expr
+val unpack_functor_mty : module_type -> functor_parameter * module_type
diff --git a/src/ocaml/typing/typemod.ml b/src/ocaml/typing/typemod.ml
new file mode 100644
index 0000000..b76867f
--- /dev/null
+++ b/src/ocaml/typing/typemod.ml
@@ -0,0 +1,3389 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Misc
+open Longident
+open Path
+open Asttypes
+open Parsetree
+open Types
+open Format
+
+let () = Includemod_errorprinter.register ()
+
+module String = Misc.String
+
+module Sig_component_kind = struct
+  type t =
+    | Value
+    | Type
+    | Module
+    | Module_type
+    | Extension_constructor
+    | Class
+    | Class_type
+
+  let to_string = function
+    | Value -> "value"
+    | Type -> "type"
+    | Module -> "module"
+    | Module_type -> "module type"
+    | Extension_constructor -> "extension constructor"
+    | Class -> "class"
+    | Class_type -> "class type"
+
+  (** Whether the name of a component of that kind can appear in a type. *)
+  let can_appear_in_types = function
+    | Value
+    | Extension_constructor ->
+        false
+    | Type
+    | Module
+    | Module_type
+    | Class
+    | Class_type ->
+        true
+end
+
+type hiding_error =
+  | Illegal_shadowing of {
+      shadowed_item_id: Ident.t;
+      shadowed_item_kind: Sig_component_kind.t;
+      shadowed_item_loc: Location.t;
+      shadower_id: Ident.t;
+      user_id: Ident.t;
+      user_kind: Sig_component_kind.t;
+      user_loc: Location.t;
+    }
+  | Appears_in_signature of {
+      opened_item_id: Ident.t;
+      opened_item_kind: Sig_component_kind.t;
+      user_id: Ident.t;
+      user_kind: Sig_component_kind.t;
+      user_loc: Location.t;
+    }
+
+type error =
+    Cannot_apply of module_type
+  | Not_included of Includemod.explanation
+  | Cannot_eliminate_dependency of module_type
+  | Signature_expected
+  | Structure_expected of module_type
+  | With_no_component of Longident.t
+  | With_mismatch of Longident.t * Includemod.explanation
+  | With_makes_applicative_functor_ill_typed of
+      Longident.t * Path.t * Includemod.explanation
+  | With_changes_module_alias of Longident.t * Ident.t * Path.t
+  | With_cannot_remove_constrained_type
+  | Repeated_name of Sig_component_kind.t * string
+  | Non_generalizable of type_expr
+  | Non_generalizable_class of Ident.t * class_declaration
+  | Non_generalizable_module of module_type
+  | Implementation_is_required of string
+  | Interface_not_compiled of string
+  | Not_allowed_in_functor_body
+  | Not_a_packed_module of type_expr
+  | Incomplete_packed_module of type_expr
+  | Scoping_pack of Longident.t * type_expr
+  | Recursive_module_require_explicit_type
+  | Apply_generative
+  | Cannot_scrape_alias of Path.t
+  | Cannot_scrape_package_type of Path.t
+  | Badly_formed_signature of string * Typedecl.error
+  | Cannot_hide_id of hiding_error
+  | Invalid_type_subst_rhs
+  | Unpackable_local_modtype_subst of Path.t
+  | With_cannot_remove_packed_modtype of Path.t * module_type
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+open Typedtree
+
+let rec path_concat head p =
+  match p with
+    Pident tail -> Pdot (Pident head, Ident.name tail)
+  | Pdot (pre, s) -> Pdot (path_concat head pre, s)
+  | Papply _ -> assert false
+
+(* Extract a signature from a module type *)
+
+let extract_sig env loc mty =
+  match Env.scrape_alias env mty with
+    Mty_signature sg -> sg
+  | Mty_for_hole -> []
+  | Mty_alias path ->
+      raise(Error(loc, env, Cannot_scrape_alias path))
+  | _ -> raise(Error(loc, env, Signature_expected))
+
+let extract_sig_open env loc mty =
+  match Env.scrape_alias env mty with
+    Mty_signature sg -> sg
+  | Mty_for_hole -> []
+  | Mty_alias path ->
+      raise(Error(loc, env, Cannot_scrape_alias path))
+  | mty -> raise(Error(loc, env, Structure_expected mty))
+
+(* Compute the environment after opening a module *)
+
+let type_open_ ?used_slot ?toplevel ovf env loc lid =
+  let path = Env.lookup_module_path ~load:true ~loc:lid.loc lid.txt env in
+  match Env.open_signature ~loc ?used_slot ?toplevel ovf path env with
+  | Ok env -> path, env
+  | Error _ ->
+      let md = Env.find_module path env in
+      ignore (extract_sig_open env lid.loc md.md_type);
+      assert false
+
+let initial_env ~loc ~safe_string ~initially_opened_module
+    ~open_implicit_modules =
+  let env =
+    if safe_string then
+      Env.initial_safe_string
+    else
+      Env.initial_unsafe_string
+  in
+  let open_module env m =
+    let open Asttypes in
+    let lid = {loc; txt = Longident.parse m } in
+    try
+      snd (type_open_ Override env lid.loc lid)
+    with
+    | (Typetexp.Error _ | Env.Error _ | Magic_numbers.Cmi.Error _ | Persistent_env.Error _) as exn ->
+      Msupport.raise_error exn;
+      env
+    | exn ->
+      Printf.ksprintf failwith
+        "Uncaught exception %s in initial_env.open_module: %s"
+        Obj.Extension_constructor.(name (of_val exn))
+        (Printexc.to_string exn)
+  in
+  let add_units env units =
+    String.Set.fold
+      (fun name env ->
+         Env.add_persistent_structure (Ident.create_persistent name) env)
+      units
+      env
+  in
+  let units =
+    List.map Env.persistent_structures_of_dir (Load_path.get ())
+  in
+  let env, units =
+    match initially_opened_module with
+    | None -> (env, units)
+    | Some m ->
+        (* Locate the directory that contains [m], adds the units it
+           contains to the environment and open [m] in the resulting
+           environment. *)
+        let rec loop before after =
+          match after with
+          | [] -> None
+          | units :: after ->
+              if String.Set.mem m units then
+                Some (units, List.rev_append before after)
+              else
+                loop (units :: before) after
+        in
+        let env, units =
+          match loop [] units with
+          | None ->
+              (env, units)
+          | Some (units_containing_m, other_units) ->
+              (add_units env units_containing_m, other_units)
+        in
+        (open_module env m, units)
+  in
+  let env = List.fold_left add_units env units in
+  List.fold_left open_module env open_implicit_modules
+
+let type_open_descr ?used_slot ?toplevel env sod =
+  let (path, newenv) =
+    Builtin_attributes.warning_scope sod.popen_attributes
+      (fun () ->
+         type_open_ ?used_slot ?toplevel sod.popen_override env sod.popen_loc
+           sod.popen_expr
+      )
+  in
+  let od =
+    {
+      open_expr = (path, sod.popen_expr);
+      open_bound_items = [];
+      open_override = sod.popen_override;
+      open_env = newenv;
+      open_attributes = sod.popen_attributes;
+      open_loc = sod.popen_loc;
+    }
+  in
+  (od, newenv)
+
+(* Forward declaration, to be filled in by type_module_type_of *)
+let type_module_type_of_fwd :
+    (Env.t -> Parsetree.module_expr ->
+      Typedtree.module_expr * Types.module_type) ref
+  = ref (fun _env _m -> assert false)
+
+(* Additional validity checks on type definitions arising from
+   recursive modules *)
+
+let check_recmod_typedecls env decls =
+  let recmod_ids = List.map fst decls in
+  List.iter
+    (fun (id, md) ->
+      List.iter
+        (fun path ->
+          Typedecl.check_recmod_typedecl env md.Types.md_loc recmod_ids
+                                         path (Env.find_type path env))
+        (Mtype.type_paths env (Pident id) md.Types.md_type))
+    decls
+
+(* Merge one "with" constraint in a signature *)
+
+let check_type_decl env sg loc id row_id newdecl decl =
+  let fresh_id = Ident.rename id in
+  let path = Pident fresh_id in
+  let sub = Subst.add_type id path Subst.identity in
+  let fresh_row_id, sub =
+    match row_id with
+    | None -> None, sub
+    | Some id ->
+      let fresh_row_id = Some (Ident.rename id) in
+      let sub = Subst.add_type id (Pident fresh_id) sub in
+      fresh_row_id, sub
+  in
+  let newdecl = Subst.type_declaration sub newdecl in
+  let decl = Subst.type_declaration sub decl in
+  let sg = List.map (Subst.signature_item Keep sub) sg in
+  let env = Env.add_type ~check:false fresh_id newdecl env in
+  let env =
+    match fresh_row_id with
+    | None -> env
+    | Some fresh_row_id -> Env.add_type ~check:false fresh_row_id newdecl env
+  in
+  let env = Env.add_signature sg env in
+  Includemod.type_declarations ~mark:Mark_both ~loc env fresh_id newdecl decl;
+  Typedecl.check_coherence env loc path newdecl
+
+let make_variance p n i =
+  let open Variance in
+  set May_pos p (set May_neg n (set May_weak n (set Inj i null)))
+
+let rec iter_path_apply p ~f =
+  match p with
+  | Pident _ -> ()
+  | Pdot (p, _) -> iter_path_apply p ~f
+  | Papply (p1, p2) ->
+     iter_path_apply p1 ~f;
+     iter_path_apply p2 ~f;
+     f p1 p2 (* after recursing, so we know both paths are well typed *)
+
+let path_is_strict_prefix =
+  let rec list_is_strict_prefix l ~prefix =
+    match l, prefix with
+    | [], [] -> false
+    | _ :: _, [] -> true
+    | [], _ :: _ -> false
+    | s1 :: t1, s2 :: t2 ->
+       String.equal s1 s2 && list_is_strict_prefix t1 ~prefix:t2
+  in
+  fun path ~prefix ->
+    match Path.flatten path, Path.flatten prefix with
+    | `Contains_apply, _ | _, `Contains_apply -> false
+    | `Ok (ident1, l1), `Ok (ident2, l2) ->
+       Ident.same ident1 ident2
+       && list_is_strict_prefix l1 ~prefix:l2
+
+let iterator_with_env env =
+  let env = ref (lazy env) in
+  let super = Btype.type_iterators in
+  env, { super with
+    Btype.it_signature = (fun self sg ->
+      (* add all items to the env before recursing down, to handle recursive
+         definitions *)
+      let env_before = !env in
+      env := lazy (Env.add_signature sg (Lazy.force env_before));
+      super.Btype.it_signature self sg;
+      env := env_before
+    );
+    Btype.it_module_type = (fun self -> function
+    | Mty_functor (param, mty_body) ->
+      let env_before = !env in
+      begin match param with
+      | Unit -> ()
+      | Named (param, mty_arg) ->
+        self.Btype.it_module_type self mty_arg;
+        match param with
+        | None -> ()
+        | Some id ->
+          env := lazy (Env.add_module ~arg:true id Mp_present
+                       mty_arg (Lazy.force env_before))
+      end;
+      self.Btype.it_module_type self mty_body;
+      env := env_before;
+    | mty ->
+      super.Btype.it_module_type self mty
+    )
+  }
+
+let retype_applicative_functor_type ~loc env funct arg =
+  let mty_functor = (Env.find_module funct env).md_type in
+  let mty_arg = (Env.find_module arg env).md_type in
+  let mty_param =
+    match Env.scrape_alias env mty_functor with
+    | Mty_functor (Named (_, mty_param), _) -> mty_param
+    | _ -> assert false (* could trigger due to MPR#7611 *)
+  in
+  Includemod.check_modtype_inclusion ~loc env mty_arg arg mty_param
+
+(* When doing a deep destructive substitution with type M.N.t := .., we change M
+   and M.N and so we have to check that uses of the modules other than just
+   extracting components from them still make sense. There are only two such
+   kinds of uses:
+   - applicative functor types: F(M).t might not be well typed anymore
+   - aliases: module A = M still makes sense but it doesn't mean the same thing
+     anymore, so it's forbidden until it's clear what we should do with it.
+   This function would be called with M.N.t and N.t to check for these uses. *)
+let check_usage_of_path_of_substituted_item paths ~loc ~lid env super =
+    { super with
+      Btype.it_signature_item = (fun self -> function
+      | Sig_module (id, _, { md_type = Mty_alias aliased_path; _ }, _, _)
+        when List.exists
+               (fun path -> path_is_strict_prefix path ~prefix:aliased_path)
+               paths
+        ->
+         let e = With_changes_module_alias (lid.txt, id, aliased_path) in
+         raise(Error(loc, Lazy.force !env, e))
+      | sig_item ->
+         super.Btype.it_signature_item self sig_item
+      );
+      Btype.it_path = (fun referenced_path ->
+        iter_path_apply referenced_path ~f:(fun funct arg ->
+          if List.exists
+               (fun path -> path_is_strict_prefix path ~prefix:arg)
+               paths
+          then
+            let env = Lazy.force !env in
+            match retype_applicative_functor_type ~loc env funct arg with
+            | None -> ()
+            | Some explanation ->
+                raise(Error(loc, env,
+                            With_makes_applicative_functor_ill_typed
+                            (lid.txt, referenced_path, explanation)))
+        )
+      );
+    }
+
+(* When doing a module type destructive substitution [with module type T = RHS]
+   where RHS is not a module type path, we need to check that the module type
+   T was not used as a path for a packed module
+*)
+let check_usage_of_module_types ~error ~paths ~loc env super =
+  let it_do_type_expr it ty = match ty.desc with
+    | Tpackage (p, _) ->
+       begin match List.find_opt (Path.same p) paths with
+       | Some p -> raise (Error(loc,Lazy.force !env,error p))
+       | _ -> super.Btype.it_do_type_expr it ty
+       end
+    | _ -> super.Btype.it_do_type_expr it ty in
+  { super with Btype.it_do_type_expr }
+
+let do_check_after_substitution env ~loc ~lid paths unpackable_modtype sg =
+  let env, iterator = iterator_with_env env in
+  let last, rest = match List.rev paths with
+    | [] -> assert false
+    | last :: rest -> last, rest
+  in
+  (* The last item is the one that's removed. We don't need to check how
+        it's used since it's replaced by a more specific type/module. *)
+  assert (match last with Pident _ -> true | _ -> false);
+  let iterator = match rest with
+    | [] -> iterator
+    | _ :: _ ->
+        check_usage_of_path_of_substituted_item rest ~loc ~lid env iterator
+  in
+  let iterator = match unpackable_modtype with
+    | None -> iterator
+    | Some mty ->
+       let error p = With_cannot_remove_packed_modtype(p,mty) in
+       check_usage_of_module_types ~error ~paths ~loc env iterator
+  in
+  iterator.Btype.it_signature iterator sg;
+  Btype.(unmark_iterators.it_signature unmark_iterators) sg
+
+let check_usage_after_substitution env ~loc ~lid paths unpackable_modtype sg =
+  match paths, unpackable_modtype with
+  | [_], None -> ()
+  | _ -> do_check_after_substitution env ~loc ~lid paths unpackable_modtype sg
+
+(* After substitution one also needs to re-check the well-foundedness
+   of type declarations in recursive modules *)
+let rec extract_next_modules = function
+  | Sig_module (id, _, mty, Trec_next, _) :: rem ->
+      let (id_mty_l, rem) = extract_next_modules rem in
+      ((id, mty) :: id_mty_l, rem)
+  | sg -> ([], sg)
+
+let check_well_formed_module env loc context mty =
+  (* Format.eprintf "@[check_well_formed_module@ %a@]@."
+     Printtyp.modtype mty; *)
+  let open Btype in
+  let iterator =
+    let rec check_signature env = function
+      | [] -> ()
+      | Sig_module (id, _, mty, Trec_first, _) :: rem ->
+          let (id_mty_l, rem) = extract_next_modules rem in
+          begin try
+            check_recmod_typedecls (Lazy.force env) ((id, mty) :: id_mty_l)
+          with Typedecl.Error (_, err) ->
+            raise (Error (loc, Lazy.force env,
+                          Badly_formed_signature(context, err)))
+          end;
+          check_signature env rem
+      | _ :: rem ->
+          check_signature env rem
+    in
+    let env, super = iterator_with_env env in
+    { super with
+      it_type_expr = (fun _self _ty -> ());
+      it_signature = (fun self sg ->
+        let env_before = !env in
+        let env = lazy (Env.add_signature sg (Lazy.force env_before)) in
+        check_signature env sg;
+        super.it_signature self sg);
+    }
+  in
+  iterator.it_module_type iterator mty
+
+let () = Env.check_well_formed_module := check_well_formed_module
+
+let type_decl_is_alias sdecl = (* assuming no explicit constraint *)
+  match sdecl.ptype_manifest with
+  | Some {ptyp_desc = Ptyp_constr (lid, stl)}
+       when List.length stl = List.length sdecl.ptype_params ->
+     begin
+       match
+         List.iter2 (fun x (y, _) ->
+             match x, y with
+               {ptyp_desc=Ptyp_var sx}, {ptyp_desc=Ptyp_var sy}
+                  when sx = sy -> ()
+             | _, _ -> raise Exit)
+           stl sdecl.ptype_params;
+       with
+       | exception Exit -> None
+       | () -> Some lid
+     end
+  | _ -> None
+;;
+
+let params_are_constrained =
+  let rec loop = function
+    | [] -> false
+    | hd :: tl ->
+       match (Btype.repr hd).desc with
+       | Tvar _ -> List.memq hd tl || loop tl
+       | _ -> true
+  in
+  loop
+;;
+
+type with_info =
+  | With_type of Parsetree.type_declaration
+  | With_typesubst of Parsetree.type_declaration
+  | With_module of {
+        lid:Longident.t loc;
+        path:Path.t;
+        md:Types.module_declaration;
+        remove_aliases:bool
+      }
+  | With_modsubst of Longident.t loc * Path.t * Types.module_declaration
+  | With_modtype of Typedtree.module_type
+  | With_modtypesubst of Typedtree.module_type
+
+let merge_constraint initial_env loc sg lid constr =
+  let destructive_substitution =
+    match constr with
+    | With_type _ | With_module _ | With_modtype _ -> false
+    | With_typesubst _ | With_modsubst _ | With_modtypesubst _  -> true
+  in
+  let real_ids = ref [] in
+  let unpackable_modtype = ref None in
+  let split_row_id s ghosts =
+    let srow = s ^ "#row" in
+    let rec split before = function
+        | Sig_type(id,_,_,_) :: rest when Ident.name id = srow ->
+            before, Some id, rest
+        | a :: rest -> split (a::before) rest
+        | [] -> before, None, []
+    in
+    split [] ghosts
+  in
+  let rec patch_item constr namelist outer_sig_env sg_for_env ~ghosts item =
+    let return ?(ghosts=ghosts) ~replace_by info =
+      Some (info, {Signature_group.ghosts; replace_by})
+    in
+    match item, namelist, constr with
+    | Sig_type(id, decl, rs, priv), [s],
+       With_type ({ptype_kind = Ptype_abstract} as sdecl)
+      when Ident.name id = s && Typedecl.is_fixed_type sdecl ->
+        let decl_row =
+          let arity = List.length sdecl.ptype_params in
+          {
+            type_params =
+              List.map (fun _ -> Btype.newgenvar()) sdecl.ptype_params;
+            type_arity = arity;
+            type_kind = Type_abstract;
+            type_private = Private;
+            type_manifest = None;
+            type_variance =
+              List.map
+                (fun (_, (v, i)) ->
+                   let (c, n) =
+                     match v with
+                     | Covariant -> true, false
+                     | Contravariant -> false, true
+                     | NoVariance -> false, false
+                   in
+                   make_variance (not n) (not c) (i = Injective)
+                )
+                sdecl.ptype_params;
+            type_separability =
+              Types.Separability.default_signature ~arity;
+            type_loc = sdecl.ptype_loc;
+            type_is_newtype = false;
+            type_expansion_scope = Btype.lowest_level;
+            type_attributes = [];
+            type_immediate = Unknown;
+            type_unboxed_default = false;
+            type_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+          }
+        and id_row = Ident.create_local (s^"#row") in
+        let initial_env =
+          Env.add_type ~check:false id_row decl_row initial_env
+        in
+        let sig_env = Env.add_signature sg_for_env outer_sig_env in
+        let tdecl =
+          Typedecl.transl_with_constraint id ~fixed_row_path:(Pident id_row)
+            ~sig_env ~sig_decl:decl ~outer_env:initial_env sdecl in
+        let newdecl = tdecl.typ_type in
+        let before_ghosts, row_id, after_ghosts = split_row_id s ghosts in
+        check_type_decl outer_sig_env sg_for_env sdecl.ptype_loc
+          id row_id newdecl decl;
+        let decl_row = {decl_row with type_params = newdecl.type_params} in
+        let rs' = if rs = Trec_first then Trec_not else rs in
+        let ghosts =
+          List.rev_append before_ghosts
+            (Sig_type(id_row, decl_row, rs', priv)::after_ghosts)
+        in
+        return ~ghosts
+          ~replace_by:(Some (Sig_type(id, newdecl, rs, priv)))
+          (Pident id, lid, Twith_type tdecl)
+    | Sig_type(id, sig_decl, rs, priv) , [s],
+       (With_type sdecl | With_typesubst sdecl as constr)
+      when Ident.name id = s ->
+        let sig_env = Env.add_signature sg_for_env outer_sig_env in
+        let tdecl =
+          Typedecl.transl_with_constraint id
+            ~sig_env ~sig_decl ~outer_env:initial_env sdecl in
+        let newdecl = tdecl.typ_type and loc = sdecl.ptype_loc in
+        let before_ghosts, row_id, after_ghosts = split_row_id s ghosts in
+        let ghosts = List.rev_append before_ghosts after_ghosts in
+        check_type_decl outer_sig_env sg_for_env loc
+          id row_id newdecl sig_decl;
+        begin match constr with
+          With_type _ ->
+            return ~ghosts
+              ~replace_by:(Some(Sig_type(id, newdecl, rs, priv)))
+              (Pident id, lid, Twith_type tdecl)
+        | (* With_typesubst *) _ ->
+            real_ids := [Pident id];
+            return ~ghosts ~replace_by:None
+              (Pident id, lid, Twith_typesubst tdecl)
+        end
+    | Sig_modtype(id, mtd, priv), [s],
+      (With_modtype mty | With_modtypesubst mty)
+      when Ident.name id = s ->
+        let sig_env = Env.add_signature sg_for_env outer_sig_env in
+        let () = match mtd.mtd_type with
+          | None -> ()
+          | Some previous_mty ->
+              Includemod.check_modtype_equiv ~loc sig_env
+                id previous_mty mty.mty_type
+        in
+        if not destructive_substitution then
+          let mtd': modtype_declaration =
+            {
+              mtd_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+              mtd_type = Some mty.mty_type;
+              mtd_attributes = [];
+              mtd_loc = loc;
+            }
+          in
+          return
+            ~replace_by:(Some(Sig_modtype(id, mtd', priv)))
+            (Pident id, lid, Twith_modtype mty)
+        else begin
+          let path = Pident id in
+          real_ids := [path];
+          begin match mty.mty_type with
+          | Mty_ident _ -> ()
+          | mty -> unpackable_modtype := Some mty
+          end;
+          return ~replace_by:None (Pident id, lid, Twith_modtypesubst mty)
+        end
+    | Sig_module(id, pres, md, rs, priv), [s],
+      With_module {lid=lid'; md=md'; path; remove_aliases}
+      when Ident.name id = s ->
+        let sig_env = Env.add_signature sg_for_env outer_sig_env in
+        let mty = md'.md_type in
+        let mty = Mtype.scrape_for_type_of ~remove_aliases sig_env mty in
+        let md'' = { md' with md_type = mty } in
+        let newmd = Mtype.strengthen_decl ~aliasable:false sig_env md'' path in
+        ignore(Includemod.modtypes  ~mark:Mark_both ~loc sig_env
+                 newmd.md_type md.md_type);
+        return
+          ~replace_by:(Some(Sig_module(id, pres, newmd, rs, priv)))
+          (Pident id, lid, Twith_module (path, lid'))
+    | Sig_module(id, _, md, _rs, _), [s], With_modsubst (lid',path,md')
+      when Ident.name id = s ->
+        let sig_env = Env.add_signature sg_for_env outer_sig_env in
+        let aliasable = not (Env.is_functor_arg path sig_env) in
+        ignore
+          (Includemod.strengthened_module_decl ~loc ~mark:Mark_both
+             ~aliasable sig_env md' path md);
+        real_ids := [Pident id];
+        return ~replace_by:None (Pident id, lid, Twith_modsubst (path, lid'))
+    | Sig_module(id, _, md, rs, priv) as item, s :: namelist, constr
+      when Ident.name id = s ->
+        let sig_env = Env.add_signature sg_for_env outer_sig_env in
+        let sg = extract_sig sig_env loc md.md_type in
+        let ((path, _, tcstr), newsg) = merge_signature sig_env sg namelist in
+        let path = path_concat id path in
+        real_ids := path :: !real_ids;
+        let item =
+          match md.md_type, constr with
+            Mty_alias _, (With_module _ | With_type _) ->
+              (* A module alias cannot be refined, so keep it
+                 and just check that the constraint is correct *)
+              item
+          | _ ->
+              let newmd = {md with md_type = Mty_signature newsg} in
+              Sig_module(id, Mp_present, newmd, rs, priv)
+        in
+        return ~replace_by:(Some item) (path, lid, tcstr)
+    | _ -> None
+  and merge_signature env sg namelist =
+    match
+      Signature_group.replace_in_place (patch_item constr namelist env sg) sg
+    with
+    | Some (x,sg) -> x, sg
+    | None -> raise(Error(loc, env, With_no_component lid.txt))
+  in
+  try
+    let names = Longident.flatten lid.txt in
+    let (tcstr, sg) = merge_signature initial_env sg names in
+    if destructive_substitution then
+      check_usage_after_substitution ~loc ~lid initial_env !real_ids
+        !unpackable_modtype sg;
+    let sg =
+    match tcstr with
+    | (_, _, Twith_typesubst tdecl) ->
+       let how_to_extend_subst =
+         let sdecl =
+           match constr with
+           | With_typesubst sdecl -> sdecl
+           | _ -> assert false
+         in
+         match type_decl_is_alias sdecl with
+         | Some lid ->
+            let replacement, _ =
+              try Env.find_type_by_name lid.txt initial_env
+              with Not_found -> assert false
+            in
+            fun s path -> Subst.add_type_path path replacement s
+         | None ->
+            let body = Option.get tdecl.typ_type.type_manifest in
+            let params = tdecl.typ_type.type_params in
+            if params_are_constrained params
+            then raise(Error(loc, initial_env,
+                             With_cannot_remove_constrained_type));
+            fun s path -> Subst.add_type_function path ~params ~body s
+       in
+       let sub = Subst.change_locs Subst.identity loc in
+       let sub = List.fold_left how_to_extend_subst sub !real_ids in
+       (* This signature will not be used directly, it will always be freshened
+          by the caller. So what we do with the scope doesn't really matter. But
+          making it local makes it unlikely that we will ever use the result of
+          this function unfreshened without issue. *)
+       Subst.signature Make_local sub sg
+    | (_, _, Twith_modsubst (real_path, _)) ->
+       let sub = Subst.change_locs Subst.identity loc in
+       let sub =
+         List.fold_left
+           (fun s path -> Subst.add_module_path path real_path s)
+           sub
+           !real_ids
+       in
+       (* See explanation in the [Twith_typesubst] case above. *)
+       Subst.signature Make_local sub sg
+    | (_, _, Twith_modtypesubst tmty) ->
+        let add s p = Subst.add_modtype_path p tmty.mty_type s in
+        let sub = Subst.change_locs Subst.identity loc in
+        let sub = List.fold_left add sub !real_ids in
+        Subst.signature Make_local sub sg
+    | _ ->
+       sg
+    in
+    check_well_formed_module initial_env loc "this instantiated signature"
+      (Mty_signature sg);
+    (tcstr, sg)
+  with Includemod.Error explanation ->
+    raise(Error(loc, initial_env, With_mismatch(lid.txt, explanation)))
+
+(* Add recursion flags on declarations arising from a mutually recursive
+   block. *)
+
+let map_rec fn decls rem =
+  match decls with
+  | [] -> rem
+  | d1 :: dl -> fn Trec_first d1 :: map_end (fn Trec_next) dl rem
+
+let map_rec_type ~rec_flag fn decls rem =
+  match decls with
+  | [] -> rem
+  | d1 :: dl ->
+      let first =
+        match rec_flag with
+        | Recursive -> Trec_first
+        | Nonrecursive -> Trec_not
+      in
+      fn first d1 :: map_end (fn Trec_next) dl rem
+
+let rec map_rec_type_with_row_types ~rec_flag fn decls rem =
+  match decls with
+  | [] -> rem
+  | d1 :: dl ->
+      if Btype.is_row_name (Ident.name d1.typ_id) then
+        fn Trec_not d1 :: map_rec_type_with_row_types ~rec_flag fn dl rem
+      else
+        map_rec_type ~rec_flag fn decls rem
+
+(* Add type extension flags to extension constructors *)
+let map_ext fn exts rem =
+  match exts with
+  | [] -> rem
+  | d1 :: dl -> fn Text_first d1 :: map_end (fn Text_next) dl rem
+
+(* Auxiliary for translating recursively-defined module types.
+   Return a module type that approximates the shape of the given module
+   type AST.  Retain only module, type, and module type
+   components of signatures.  For types, retain only their arity,
+   making them abstract otherwise. *)
+
+let rec approx_modtype env smty =
+  match smty.pmty_desc with
+    Pmty_ident lid ->
+      let (path, _info) =
+        Env.lookup_modtype ~use:false ~loc:smty.pmty_loc lid.txt env
+      in
+      Mty_ident path
+  | Pmty_alias lid ->
+      let path =
+        Env.lookup_module_path ~use:false ~load:false
+          ~loc:smty.pmty_loc lid.txt env
+      in
+      Mty_alias(path)
+  | Pmty_signature ssg ->
+      Mty_signature(approx_sig env ssg)
+  | Pmty_functor(param, sres) ->
+      let (param, newenv) =
+        match param with
+        | Unit -> Types.Unit, env
+        | Named (param, sarg) ->
+          let arg = approx_modtype env sarg in
+          match param.txt with
+          | None -> Types.Named (None, arg), env
+          | Some name ->
+            let rarg = Mtype.scrape_for_functor_arg env arg in
+            let scope = Ctype.create_scope () in
+            let (id, newenv) =
+              Env.enter_module ~scope ~arg:true name Mp_present rarg env
+            in
+            Types.Named (Some id, arg), newenv
+      in
+      let res = approx_modtype newenv sres in
+      Mty_functor(param, res)
+  | Pmty_with(sbody, constraints) ->
+      let body = approx_modtype env sbody in
+      List.iter
+        (fun sdecl ->
+          match sdecl with
+          | Pwith_type _
+          | Pwith_typesubst _
+          | Pwith_modtype _
+          | Pwith_modtypesubst _  -> ()
+          | Pwith_module (_, lid') ->
+              (* Lookup the module to make sure that it is not recursive.
+                 (GPR#1626) *)
+              ignore (Env.lookup_module ~use:false ~loc:lid'.loc lid'.txt env)
+          | Pwith_modsubst (_, lid') ->
+              ignore (Env.lookup_module ~use:false ~loc:lid'.loc lid'.txt env))
+        constraints;
+      body
+  | Pmty_typeof smod ->
+      let (_, mty) = !type_module_type_of_fwd env smod in
+      mty
+  | Pmty_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and approx_module_declaration env pmd =
+  {
+    Types.md_type = approx_modtype env pmd.pmd_type;
+    md_attributes = pmd.pmd_attributes;
+    md_loc = pmd.pmd_loc;
+    md_uid = Uid.internal_not_actually_unique;
+  }
+
+and approx_sig env ssg =
+  match ssg with
+    [] -> []
+  | item :: srem ->
+      match item.psig_desc with
+      | Psig_type (rec_flag, sdecls) ->
+          let decls = Typedecl.approx_type_decl sdecls in
+          let rem = approx_sig env srem in
+          map_rec_type ~rec_flag
+            (fun rs (id, info) -> Sig_type(id, info, rs, Exported)) decls rem
+      | Psig_typesubst _ -> approx_sig env srem
+      | Psig_module { pmd_name = { txt = None; _ }; _ } ->
+          approx_sig env srem
+      | Psig_module pmd ->
+          let scope = Ctype.create_scope () in
+          let md = approx_module_declaration env pmd in
+          let pres =
+            match md.Types.md_type with
+            | Mty_alias _ -> Mp_absent
+            | _ -> Mp_present
+          in
+          let id, newenv =
+            Env.enter_module_declaration ~scope (Option.get pmd.pmd_name.txt)
+              pres md env
+          in
+          Sig_module(id, pres, md, Trec_not, Exported) :: approx_sig newenv srem
+      | Psig_modsubst pms ->
+          let scope = Ctype.create_scope () in
+          let _, md =
+            Env.lookup_module ~use:false ~loc:pms.pms_manifest.loc
+               pms.pms_manifest.txt env
+          in
+          let pres =
+            match md.Types.md_type with
+            | Mty_alias _ -> Mp_absent
+            | _ -> Mp_present
+          in
+          let _, newenv =
+            Env.enter_module_declaration ~scope pms.pms_name.txt pres md env
+          in
+          approx_sig newenv srem
+      | Psig_recmodule sdecls ->
+          let scope = Ctype.create_scope () in
+          let decls =
+            List.filter_map
+              (fun pmd ->
+                 Option.map (fun name ->
+                   Ident.create_scoped ~scope name,
+                   approx_module_declaration env pmd
+                 ) pmd.pmd_name.txt
+              )
+              sdecls
+          in
+          let newenv =
+            List.fold_left
+              (fun env (id, md) -> Env.add_module_declaration ~check:false
+                  id Mp_present md env)
+              env decls
+          in
+          map_rec
+            (fun rs (id, md) -> Sig_module(id, Mp_present, md, rs, Exported))
+            decls
+            (approx_sig newenv srem)
+      | Psig_modtype d ->
+          let info = approx_modtype_info env d in
+          let scope = Ctype.create_scope () in
+          let (id, newenv) =
+            Env.enter_modtype ~scope d.pmtd_name.txt info env
+          in
+          Sig_modtype(id, info, Exported) :: approx_sig newenv srem
+      | Psig_modtypesubst d ->
+          let info = approx_modtype_info env d in
+          let scope = Ctype.create_scope () in
+          let (_id, newenv) =
+            Env.enter_modtype ~scope d.pmtd_name.txt info env
+          in
+          approx_sig newenv srem
+      | Psig_open sod ->
+          let _, env = type_open_descr env sod in
+          approx_sig env srem
+      | Psig_include sincl ->
+          let smty = sincl.pincl_mod in
+          let mty = approx_modtype env smty in
+          let scope = Ctype.create_scope () in
+          let sg, newenv = Env.enter_signature ~scope
+              (extract_sig env smty.pmty_loc mty) env in
+          sg @ approx_sig newenv srem
+      | Psig_class sdecls | Psig_class_type sdecls ->
+          let decls = Typeclass.approx_class_declarations env sdecls in
+          let rem = approx_sig env srem in
+          map_rec (fun rs decl ->
+            let open Typeclass in [
+              Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs,
+                             Exported);
+              Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs, Exported);
+              Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs, Exported);
+            ]
+          ) decls [rem]
+          |> List.flatten
+      | _ ->
+          approx_sig env srem
+
+and approx_modtype_info env sinfo =
+  {
+   mtd_type = Option.map (approx_modtype env) sinfo.pmtd_type;
+   mtd_attributes = sinfo.pmtd_attributes;
+   mtd_loc = sinfo.pmtd_loc;
+   mtd_uid = Uid.internal_not_actually_unique;
+  }
+
+let approx_modtype env smty =
+  Warnings.without_warnings
+    (fun () -> approx_modtype env smty)
+
+(* Auxiliaries for checking the validity of name shadowing in signatures and
+   structures.
+   If a shadowing is valid, we also record some information (its ident,
+   location where it first appears, etc) about the item that gets shadowed. *)
+module Signature_names : sig
+  type t
+
+ type shadowable =
+    {
+      self: Ident.t;
+      group: Ident.t list;
+      (** group includes the element itself and all elements
+                that should be removed at the same time
+      *)
+      loc:Location.t;
+    }
+
+  type info = [
+    | `Exported
+    | `From_open
+    | `Shadowable of shadowable
+    | `Substituted_away of Subst.t
+    | `Unpackable_modtype_substituted_away of Ident.t * Subst.t
+  ]
+
+  val create : unit -> t
+
+  val check_value     : ?info:info -> t -> Location.t -> Ident.t -> unit
+  val check_type      : ?info:info -> t -> Location.t -> Ident.t -> unit
+  val check_typext    : ?info:info -> t -> Location.t -> Ident.t -> unit
+  val check_module    : ?info:info -> t -> Location.t -> Ident.t -> unit
+  val check_modtype   : ?info:info -> t -> Location.t -> Ident.t -> unit
+  val check_class     : ?info:info -> t -> Location.t -> Ident.t -> unit
+  val check_class_type: ?info:info -> t -> Location.t -> Ident.t -> unit
+
+  val check_sig_item:
+    ?info:info -> t -> Location.t -> Signature_group.rec_group -> unit
+
+  val simplify: Env.t -> t -> Types.signature -> Types.signature
+end = struct
+
+  type shadowable =
+    {
+      self: Ident.t;
+      group: Ident.t list;
+      (** group includes the element itself and all elements
+                that should be removed at the same time
+      *)
+      loc:Location.t;
+    }
+
+  type bound_info = [
+    | `Exported
+    | `Shadowable of shadowable
+  ]
+
+  type info = [
+    | `From_open
+    | `Substituted_away of Subst.t
+    | `Unpackable_modtype_substituted_away of Ident.t * Subst.t
+    | bound_info
+  ]
+
+  type hide_reason =
+    | From_open
+    | Shadowed_by of Ident.t * Location.t
+
+  type to_be_removed = {
+    mutable subst: Subst.t;
+    mutable hide: (Sig_component_kind.t * Location.t * hide_reason) Ident.Map.t;
+    mutable unpackable_modtypes: Ident.Set.t;
+  }
+
+  type names_infos = (string, bound_info) Hashtbl.t
+
+  type names = {
+    values: names_infos;
+    types: names_infos;
+    modules: names_infos;
+    modtypes: names_infos;
+    typexts: names_infos;
+    classes: names_infos;
+    class_types: names_infos;
+  }
+
+  let new_names () = {
+    values = Hashtbl.create 16;
+    types = Hashtbl.create 16;
+    modules = Hashtbl.create 16;
+    modtypes = Hashtbl.create 16;
+    typexts = Hashtbl.create 16;
+    classes = Hashtbl.create 16;
+    class_types = Hashtbl.create 16;
+  }
+
+  type t = {
+    bound: names;
+    to_be_removed: to_be_removed;
+  }
+
+  let create () = {
+    bound = new_names ();
+    to_be_removed = {
+      subst = Subst.identity;
+      hide = Ident.Map.empty;
+      unpackable_modtypes = Ident.Set.empty;
+    };
+  }
+
+  let table_for component names =
+    let open Sig_component_kind in
+    match component with
+    | Value -> names.values
+    | Type -> names.types
+    | Module -> names.modules
+    | Module_type -> names.modtypes
+    | Extension_constructor -> names.typexts
+    | Class -> names.classes
+    | Class_type -> names.class_types
+
+  let check cl t loc id (info : info) =
+    let to_be_removed = t.to_be_removed in
+    match info with
+    | `Substituted_away s ->
+        to_be_removed.subst <- Subst.compose s to_be_removed.subst;
+    | `Unpackable_modtype_substituted_away (id,s) ->
+        to_be_removed.subst <- Subst.compose s to_be_removed.subst;
+        to_be_removed.unpackable_modtypes <-
+          Ident.Set.add id to_be_removed.unpackable_modtypes
+    | `From_open ->
+        to_be_removed.hide <-
+          Ident.Map.add id (cl, loc, From_open) to_be_removed.hide
+    | #bound_info as bound_info ->
+        let tbl = table_for cl t.bound in
+        let name = Ident.name id in
+        match Hashtbl.find_opt tbl name with
+        | None -> Hashtbl.add tbl name bound_info
+        | Some (`Shadowable s) ->
+            Hashtbl.replace tbl name bound_info;
+            let reason = Shadowed_by (id, loc) in
+            List.iter (fun shadowed_id ->
+            to_be_removed.hide <-
+              Ident.Map.add shadowed_id (cl, s.loc, reason)
+                to_be_removed.hide
+              ) s.group
+        | Some `Exported ->
+            raise(Error(loc, Env.empty, Repeated_name(cl, name)))
+
+  let check_value ?info t loc id =
+    let info =
+      match info with
+      | Some i -> i
+      | None -> `Shadowable {self=id; group=[id]; loc}
+    in
+    check Sig_component_kind.Value t loc id info
+  let check_type ?(info=`Exported) t loc id =
+    check Sig_component_kind.Type t loc id info
+  let check_module ?(info=`Exported) t loc id =
+    check Sig_component_kind.Module t loc id info
+  let check_modtype ?(info=`Exported) t loc id =
+    check Sig_component_kind.Module_type t loc id info
+  let check_typext ?(info=`Exported) t loc id =
+    check Sig_component_kind.Extension_constructor t loc id info
+  let check_class ?(info=`Exported) t loc id =
+    check Sig_component_kind.Class t loc id info
+  let check_class_type ?(info=`Exported) t loc id =
+    check Sig_component_kind.Class_type t loc id info
+
+  let classify =
+    let open Sig_component_kind in
+    function
+    | Sig_type(id, _, _, _) -> Type, id
+    | Sig_module(id, _, _, _, _) -> Module, id
+    | Sig_modtype(id, _, _) -> Module_type, id
+    | Sig_typext(id, _, _, _) -> Extension_constructor, id
+    | Sig_value (id, _, _) -> Value, id
+    | Sig_class (id, _, _, _) -> Class, id
+    | Sig_class_type (id, _, _, _) -> Class_type, id
+
+  let check_item ?info names loc kind id ids =
+    let info =
+      match info with
+      | None -> `Shadowable {self=id; group=ids; loc}
+      | Some i -> i
+    in
+    check kind names loc id info
+
+  let check_sig_item ?info names loc (item:Signature_group.rec_group) =
+    let check ?info names loc item =
+      let all = List.map classify (Signature_group.flatten item) in
+      let group = List.map snd all in
+      List.iter (fun (kind,id) -> check_item ?info names loc kind id group)
+        all
+    in
+    (* we can ignore x.pre_ghosts: they are eliminated by strengthening, and
+       thus never appear in includes *)
+     List.iter (check ?info names loc) (Signature_group.rec_items item.group)
+
+  (*
+    Before applying local module type substitutions where the
+    right-hand side is not a path, we need to check that those module types
+    where never used to pack modules. For instance
+    {[
+    module type T := sig end
+    val x: (module T)
+    ]}
+    should raise an error.
+  *)
+  let check_unpackable_modtypes ~loc ~env to_remove component =
+    if not (Ident.Set.is_empty to_remove.unpackable_modtypes) then begin
+      let iterator =
+        let error p = Unpackable_local_modtype_subst p in
+        let paths =
+          List.map (fun id -> Pident id)
+            (Ident.Set.elements to_remove.unpackable_modtypes)
+        in
+        check_usage_of_module_types ~loc ~error ~paths
+          (ref (lazy env)) Btype.type_iterators
+      in
+      iterator.Btype.it_signature_item iterator component;
+      Btype.(unmark_iterators.it_signature_item unmark_iterators) component
+    end
+
+  (* We usually require name uniqueness of signature components (e.g. types,
+     modules, etc), however in some situation reusing the name is allowed: if
+     the component is a value or an extension, or if the name is introduced by
+     an include.
+     When there are multiple specifications of a component with the same name,
+     we try to keep only the last (rightmost) one, removing all references to
+     the previous ones from the signature.
+     If some reference cannot be removed, then we error out with
+     [Cannot_hide_id].
+  *)
+
+  let simplify env t sg =
+    let to_remove = t.to_be_removed in
+    let ids_to_remove =
+      Ident.Map.fold (fun id (kind,  _, _) lst ->
+        if Sig_component_kind.can_appear_in_types kind then
+          id :: lst
+        else
+          lst
+      ) to_remove.hide []
+    in
+    let simplify_item (component: Types.signature_item) =
+      let user_kind, user_id, user_loc =
+        let open Sig_component_kind in
+        match component with
+        | Sig_value(id, v, _) -> Value, id, v.val_loc
+        | Sig_type (id, td, _, _) -> Type, id, td.type_loc
+        | Sig_typext (id, te, _, _) -> Extension_constructor, id, te.ext_loc
+        | Sig_module (id, _, md, _, _) -> Module, id, md.md_loc
+        | Sig_modtype (id, mtd, _) -> Module_type, id, mtd.mtd_loc
+        | Sig_class (id, c, _, _) -> Class, id, c.cty_loc
+        | Sig_class_type (id, ct, _, _) -> Class_type, id, ct.clty_loc
+      in
+      if Ident.Map.mem user_id to_remove.hide then
+        None
+      else begin
+        let component =
+          if to_remove.subst == Subst.identity then
+            component
+          else
+            begin
+              check_unpackable_modtypes ~loc:user_loc ~env to_remove component;
+              Subst.signature_item Keep to_remove.subst component
+            end
+        in
+        let component =
+          match ids_to_remove with
+          | [] -> component
+          | ids ->
+            try Mtype.nondep_sig_item env ids component with
+            | Ctype.Nondep_cannot_erase removed_item_id ->
+              let (removed_item_kind, removed_item_loc, reason) =
+                Ident.Map.find removed_item_id to_remove.hide
+              in
+              let err_loc, hiding_error =
+                match reason with
+                | From_open ->
+                  removed_item_loc,
+                  Appears_in_signature {
+                    opened_item_kind = removed_item_kind;
+                    opened_item_id = removed_item_id;
+                    user_id;
+                    user_kind;
+                    user_loc;
+                  }
+                | Shadowed_by (shadower_id, shadower_loc) ->
+                  shadower_loc,
+                  Illegal_shadowing {
+                    shadowed_item_kind = removed_item_kind;
+                    shadowed_item_id = removed_item_id;
+                    shadowed_item_loc = removed_item_loc;
+                    shadower_id;
+                    user_id;
+                    user_kind;
+                    user_loc;
+                  }
+              in
+              raise (Error(err_loc, env, Cannot_hide_id hiding_error))
+        in
+        Some component
+      end
+    in
+    List.filter_map simplify_item sg
+end
+
+let has_remove_aliases_attribute attr =
+  let remove_aliases =
+    Attr_helper.get_no_payload_attribute
+      ["remove_aliases"; "ocaml.remove_aliases"] attr
+  in
+  match remove_aliases with
+  | None -> false
+  | Some _ -> true
+
+(* Check and translate a module type expression *)
+
+let transl_modtype_longident loc env lid =
+  let (path, _info) = Env.lookup_modtype ~loc lid env in
+  path
+
+let transl_module_alias loc env lid =
+  Env.lookup_module_path ~load:false ~loc lid env
+
+let mkmty desc typ env loc attrs =
+  let mty = {
+    mty_desc = desc;
+    mty_type = typ;
+    mty_loc = loc;
+    mty_env = env;
+    mty_attributes = attrs;
+    } in
+  Cmt_format.add_saved_type (Cmt_format.Partial_module_type mty);
+  mty
+
+let mksig desc env loc =
+  let sg = { sig_desc = desc; sig_loc = loc; sig_env = env } in
+  Cmt_format.add_saved_type (Cmt_format.Partial_signature_item sg);
+  sg
+
+(* let signature sg = List.map (fun item -> item.sig_type) sg *)
+
+let rec transl_modtype env smty =
+  Builtin_attributes.warning_scope smty.pmty_attributes
+    (fun () -> transl_modtype_aux env smty)
+
+and transl_modtype_functor_arg env sarg =
+  let mty = transl_modtype env sarg in
+  {mty with mty_type = Mtype.scrape_for_functor_arg env mty.mty_type}
+
+and transl_modtype_aux env smty =
+  let loc = smty.pmty_loc in
+  match smty.pmty_desc with
+    Pmty_ident lid ->
+      let path = transl_modtype_longident loc env lid.txt in
+      mkmty (Tmty_ident (path, lid)) (Mty_ident path) env loc
+        smty.pmty_attributes
+  | Pmty_alias lid ->
+      let path = transl_module_alias loc env lid.txt in
+      mkmty (Tmty_alias (path, lid)) (Mty_alias path) env loc
+        smty.pmty_attributes
+  | Pmty_signature ssg ->
+      let sg = transl_signature env ssg in
+      mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc
+        smty.pmty_attributes
+  | Pmty_functor(sarg_opt, sres) ->
+      let t_arg, ty_arg, newenv =
+        match sarg_opt with
+        | Unit -> Unit, Types.Unit, env
+        | Named (param, sarg) ->
+          let arg = transl_modtype_functor_arg env sarg in
+          let (id, newenv) =
+            match param.txt with
+            | None -> None, env
+            | Some name ->
+              let scope = Ctype.create_scope () in
+              let id, newenv =
+                let arg_md =
+                  { md_type = arg.mty_type;
+                    md_attributes = [];
+                    md_loc = param.loc;
+                    md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+                  }
+                in
+                Env.enter_module_declaration ~scope ~arg:true name Mp_present
+                  arg_md env
+              in
+              Some id, newenv
+          in
+          Named (id, param, arg), Types.Named (id, arg.mty_type), newenv
+      in
+      let res = transl_modtype newenv sres in
+      mkmty (Tmty_functor (t_arg, res))
+        (Mty_functor(ty_arg, res.mty_type)) env loc
+        smty.pmty_attributes
+  | Pmty_with(sbody, constraints) ->
+      let body = transl_modtype env sbody in
+      let init_sg = extract_sig env sbody.pmty_loc body.mty_type in
+      let remove_aliases = has_remove_aliases_attribute smty.pmty_attributes in
+      let (rev_tcstrs, final_sg) =
+        List.fold_left (transl_with ~loc:smty.pmty_loc env remove_aliases)
+        ([],init_sg) constraints in
+      let scope = Ctype.create_scope () in
+      mkmty (Tmty_with ( body, List.rev rev_tcstrs))
+        (Mtype.freshen ~scope (Mty_signature final_sg)) env loc
+        smty.pmty_attributes
+  | Pmty_typeof smod ->
+      let env = Env.in_signature false env in
+      let tmty, mty = !type_module_type_of_fwd env smod in
+      mkmty (Tmty_typeof tmty) mty env loc smty.pmty_attributes
+  | Pmty_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and transl_with ~loc env remove_aliases (rev_tcstrs,sg) constr =
+  let lid, with_info = match constr with
+    | Pwith_type (l,decl) ->l , With_type decl
+    | Pwith_typesubst (l,decl) ->l , With_typesubst decl
+    | Pwith_module (l,l') ->
+        let path, md = Env.lookup_module ~loc l'.txt env in
+        l , With_module {lid=l';path;md; remove_aliases}
+    | Pwith_modsubst (l,l') ->
+        let path, md' = Env.lookup_module ~loc l'.txt env in
+        l , With_modsubst (l',path,md')
+    | Pwith_modtype (l,smty) ->
+        let mty = transl_modtype env smty in
+        l, With_modtype mty
+    | Pwith_modtypesubst (l,smty) ->
+        let mty = transl_modtype env smty in
+        l, With_modtypesubst mty
+  in
+  let (tcstr, sg) = merge_constraint env loc sg lid with_info in
+  (tcstr :: rev_tcstrs, sg)
+
+and transl_signature ?(keep_warnings = false) env sg =
+  let names = Signature_names.create () in
+  let rec transl_sig env sg =
+    match sg with
+      [] -> [], [], env
+    | item :: srem ->
+        let loc = item.psig_loc in
+        match item.psig_desc with
+        | Psig_value sdesc ->
+          begin match
+            let (tdesc, _) as res =
+              Typedecl.transl_value_decl env item.psig_loc sdesc
+            in
+            Signature_names.check_value names tdesc.val_loc tdesc.val_id;
+            res
+          with
+          | (tdesc, newenv) ->
+            let (trem,rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_value tdesc) env loc :: trem,
+            Sig_value(tdesc.val_id, tdesc.val_val, Exported) :: rem,
+              final_env
+          | exception exn ->
+            Msupport.raise_error exn;
+            transl_sig env srem
+          end
+        | Psig_type (rec_flag, sdecls) ->
+          begin match
+            let (decls, _) as res =
+              Typedecl.transl_type_decl env rec_flag sdecls
+            in
+            List.iter (fun td ->
+              Signature_names.check_type names td.typ_loc td.typ_id
+            ) decls;
+            res
+          with
+          | (decls, newenv) ->
+            let newenv = Env.update_short_paths newenv in
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            let sg =
+              map_rec_type_with_row_types ~rec_flag
+                (fun rs td -> Sig_type(td.typ_id, td.typ_type, rs, Exported))
+                decls rem
+            in
+            mksig (Tsig_type (rec_flag, decls)) env loc :: trem,
+            sg,
+            final_env
+          | exception exn ->
+            Msupport.raise_error exn;
+            transl_sig env srem
+          end
+        | Psig_typesubst sdecls ->
+          begin match
+            List.iter (fun td ->
+              if td.ptype_kind <> Ptype_abstract || td.ptype_manifest = None ||
+                 td.ptype_private = Private
+              then
+                (* This error should be a parsing error,
+                   once we have nice error messages there. *)
+                raise (Error (td.ptype_loc, env, Invalid_type_subst_rhs))
+            ) sdecls;
+            let (decls, _) as res =
+              Typedecl.transl_type_decl env Nonrecursive sdecls
+            in
+            List.iter (fun td ->
+              let params = td.typ_type.type_params in
+              if params_are_constrained params
+              then raise(Error(loc, env, With_cannot_remove_constrained_type));
+              let info =
+                  let subst =
+                    Subst.add_type_function (Pident td.typ_id)
+                      ~params
+                      ~body:(Option.get td.typ_type.type_manifest)
+                      Subst.identity
+                  in
+                  Some (`Substituted_away subst)
+              in
+              Signature_names.check_type ?info names td.typ_loc td.typ_id
+            ) decls;
+            res
+          with
+          | (decls, newenv) ->
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            let sg = rem
+            in
+            mksig (Tsig_typesubst decls) env loc :: trem,
+            sg,
+            final_env
+          | exception exn ->
+            Msupport.raise_error exn;
+            transl_sig env srem
+          end
+        | Psig_typext styext ->
+          begin match
+            let (tyext, _) as res =
+              Typedecl.transl_type_extension false env item.psig_loc styext
+            in
+            let constructors = tyext.tyext_constructors in
+            List.iter (fun ext ->
+              Signature_names.check_typext names ext.ext_loc ext.ext_id
+            ) constructors;
+            res, constructors
+          with
+          | (tyext, newenv), constructors ->
+            let (trem, rem, final_env) = transl_sig newenv srem in
+              mksig (Tsig_typext tyext) env loc :: trem,
+              map_ext (fun es ext ->
+                Sig_typext(ext.ext_id, ext.ext_type, es, Exported)
+              ) constructors rem,
+              final_env
+          | exception exn ->
+            Msupport.raise_error exn;
+            transl_sig env srem
+          end
+        | Psig_exception sext ->
+          begin match
+            let (ext, _) as res = Typedecl.transl_type_exception env sext in
+            let constructor = ext.tyexn_constructor in
+            Signature_names.check_typext names constructor.ext_loc
+              constructor.ext_id;
+            res, constructor
+          with
+          | (ext, newenv), constructor ->
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_exception ext) env loc :: trem,
+            Sig_typext(constructor.ext_id,
+                       constructor.ext_type,
+                       Text_exception,
+                       Exported) :: rem,
+            final_env
+          | exception exn ->
+            Msupport.raise_error exn;
+            transl_sig env srem
+          end
+        | Psig_module pmd ->
+          let scope = Ctype.create_scope () in
+          begin match
+            let tmty =
+              Builtin_attributes.warning_scope pmd.pmd_attributes
+                (fun () -> transl_modtype env pmd.pmd_type)
+            in
+            let pres =
+              match tmty.mty_type with
+              | Mty_alias _ -> Mp_absent
+              | _ -> Mp_present
+            in
+            match pmd.pmd_name.txt with
+            | None -> None, pres, env, None, tmty
+            | Some name ->
+              let md = {
+                md_type=tmty.mty_type;
+                md_attributes=pmd.pmd_attributes;
+                md_loc=pmd.pmd_loc;
+                md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+              }
+              in
+              let id, newenv =
+                Env.enter_module_declaration ~scope name pres md env
+              in
+              let newenv = Env.update_short_paths newenv in
+              Signature_names.check_module names pmd.pmd_name.loc id;
+              let sig_item = Sig_module(id, pres, md, Trec_not, Exported) in
+              Some id, pres, newenv, Some sig_item, tmty
+          with
+          | (id, pres, newenv, sig_item, tmty) ->
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_module {md_id=id; md_name=pmd.pmd_name;
+                                md_presence=pres; md_type=tmty;
+                                md_loc=pmd.pmd_loc;
+                                md_attributes=pmd.pmd_attributes})
+              env loc :: trem,
+            (match sig_item with None -> rem | Some i -> i :: rem),
+            final_env
+          | exception exn ->
+            Msupport.raise_error exn;
+            transl_sig env srem
+          end
+        | Psig_modsubst pms ->
+          let scope = Ctype.create_scope () in
+          begin match
+            let path, md =
+              Env.lookup_module ~loc:pms.pms_manifest.loc
+                pms.pms_manifest.txt env
+            in
+            let aliasable = not (Env.is_functor_arg path env) in
+            let md =
+              if not aliasable then
+                md
+              else
+                { md_type = Mty_alias path;
+                  md_attributes = pms.pms_attributes;
+                  md_loc = pms.pms_loc;
+                  md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+                }
+            in
+            let pres =
+              match md.md_type with
+              | Mty_alias _ -> Mp_absent
+              | _ -> Mp_present
+            in
+            let id, newenv =
+              Env.enter_module_declaration ~scope pms.pms_name.txt pres md env
+            in
+            let info =
+              `Substituted_away (Subst.add_module id path Subst.identity)
+            in
+            Signature_names.check_module ~info names pms.pms_name.loc id;
+            (newenv, Tsig_modsubst {ms_id=id; ms_name=pms.pms_name;
+                                    ms_manifest=path; ms_txt=pms.pms_manifest;
+                                    ms_loc=pms.pms_loc;
+                                    ms_attributes=pms.pms_attributes})
+          with
+          | newenv, sig_item ->
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            (mksig sig_item env loc :: trem, rem, final_env)
+          | exception exn ->
+            Msupport.raise_error exn;
+            transl_sig env srem
+          end
+        | Psig_recmodule sdecls ->
+          begin match
+            let (tdecls, newenv) =
+              transl_recmodule_modtypes env sdecls in
+            let decls =
+              List.filter_map (fun (md, uid) ->
+                match md.md_id with
+                | None -> None
+                | Some id -> Some (id, md, uid)
+              ) tdecls
+            in
+            List.iter (fun (id, md, _) ->
+              Signature_names.check_module names md.md_loc id
+            ) decls;
+            (tdecls, decls, newenv)
+          with
+          | (tdecls, decls, newenv) ->
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_recmodule (List.map fst tdecls)) env loc :: trem,
+            map_rec (fun rs (id, md, uid) ->
+                let d = {Types.md_type = md.md_type.mty_type;
+                         md_attributes = md.md_attributes;
+                         md_loc = md.md_loc;
+                         md_uid = uid;
+                        } in
+                Sig_module(id, Mp_present, d, rs, Exported))
+              decls rem,
+            final_env
+          | exception exn ->
+            Msupport.raise_error exn;
+            transl_sig env srem
+          end
+        | Psig_modtype pmtd ->
+          begin match transl_modtype_decl env pmtd with
+          | newenv, mtd, sg ->
+            Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id;
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_modtype mtd) env loc :: trem,
+            sg :: rem,
+            final_env
+          | exception exn ->
+            Msupport.raise_error exn;
+            transl_sig env srem
+          end
+        | Psig_modtypesubst pmtd ->
+          begin match transl_modtype_decl env pmtd with
+          | newenv, mtd, _sg ->
+            let info =
+              let mty = match mtd.mtd_type with
+                | Some tmty -> tmty.mty_type
+                | None ->
+                    (* parsetree invariant, see Ast_invariants *)
+                    assert false
+              in
+              let subst = Subst.add_modtype mtd.mtd_id mty Subst.identity in
+              match mty with
+              | Mty_ident _ -> `Substituted_away subst
+              | _ -> `Unpackable_modtype_substituted_away (mtd.mtd_id,subst)
+            in
+            Signature_names.check_modtype ~info names pmtd.pmtd_loc mtd.mtd_id;
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_modtypesubst mtd) env loc :: trem,
+            rem,
+            final_env
+          | exception exn ->
+            Msupport.raise_error exn;
+            transl_sig env srem
+          end
+        | Psig_open sod ->
+          begin match type_open_descr env sod with
+          | (od, newenv) ->
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_open od) env loc :: trem,
+            rem, final_env
+          | exception exn ->
+            Msupport.raise_error exn;
+            transl_sig env srem
+          end
+        | Psig_include sincl ->
+          begin match
+            let smty = sincl.pincl_mod in
+            let tmty =
+              Builtin_attributes.warning_scope sincl.pincl_attributes
+                (fun () -> transl_modtype env smty)
+            in
+            let mty = tmty.mty_type in
+            let scope = Ctype.create_scope () in
+            let sg, newenv = Env.enter_signature ~scope
+                       (extract_sig env smty.pmty_loc mty) env in
+            Signature_group.iter
+              (Signature_names.check_sig_item names item.psig_loc)
+              sg;
+            let incl =
+              { incl_mod = tmty;
+                incl_type = sg;
+                incl_attributes = sincl.pincl_attributes;
+                incl_loc = sincl.pincl_loc;
+              }
+            in
+            incl, sg, newenv
+          with
+          | incl, sg, newenv ->
+            let (trem, rem, final_env) = transl_sig newenv srem  in
+            mksig (Tsig_include incl) env loc :: trem,
+            sg @ rem,
+            final_env
+          | exception exn ->
+            Msupport.raise_error exn;
+            transl_sig env srem
+          end
+        | Psig_class cl ->
+          begin match
+            let (classes, _) as res = Typeclass.class_descriptions env cl in
+            List.iter (fun cls ->
+              let open Typeclass in
+              let loc = cls.cls_id_loc.Location.loc in
+              Signature_names.check_type names loc cls.cls_obj_id;
+              Signature_names.check_class names loc cls.cls_id;
+              Signature_names.check_class_type names loc cls.cls_ty_id;
+              Signature_names.check_type names loc cls.cls_typesharp_id;
+            ) classes;
+            res
+          with
+          | (classes, newenv) ->
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            let sg =
+              map_rec (fun rs cls ->
+                let open Typeclass in
+                [Sig_class(cls.cls_id, cls.cls_decl, rs, Exported);
+                 Sig_class_type(cls.cls_ty_id, cls.cls_ty_decl, rs, Exported);
+                 Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs, Exported);
+                 Sig_type(cls.cls_typesharp_id, cls.cls_abbr, rs, Exported)]
+              ) classes [rem]
+              |> List.flatten
+            in
+            let typedtree =
+              mksig (Tsig_class
+                       (List.map (fun decr ->
+                          decr.Typeclass.cls_info) classes)) env loc
+              :: trem
+            in
+            typedtree, sg, final_env
+          | exception exn ->
+            Msupport.raise_error exn;
+            transl_sig env srem
+          end
+        | Psig_class_type cl ->
+          begin match
+            let (classes, _) as res = Typeclass.class_type_declarations env cl in
+            List.iter (fun decl ->
+              let open Typeclass in
+              let loc = decl.clsty_id_loc.Location.loc in
+              Signature_names.check_class_type names loc decl.clsty_ty_id;
+              Signature_names.check_type names loc decl.clsty_obj_id;
+              Signature_names.check_type names loc decl.clsty_typesharp_id;
+            ) classes;
+            res
+          with
+          | (classes, newenv) ->
+            let (trem,rem, final_env) = transl_sig newenv srem in
+            let sg =
+              map_rec (fun rs decl ->
+                let open Typeclass in
+                [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs,
+                                Exported);
+                 Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs, Exported);
+                 Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs,
+                          Exported)
+                ]
+              ) classes [rem]
+              |> List.flatten
+            in
+            let typedtree =
+              mksig
+                (Tsig_class_type
+                   (List.map (fun decl -> decl.Typeclass.clsty_info) classes))
+                env loc
+              :: trem
+            in
+            typedtree, sg, final_env
+          | exception exn ->
+            Msupport.raise_error exn;
+            transl_sig env srem
+          end
+        | Psig_attribute x ->
+            Builtin_attributes.warning_attribute x;
+            let (trem,rem, final_env) = transl_sig env srem in
+            mksig (Tsig_attribute x) env loc :: trem, rem, final_env
+        | Psig_extension (ext, _attrs) ->
+            Msupport.raise_error
+              (Error_forward (Builtin_attributes.error_of_extension ext));
+            transl_sig env srem
+  in
+  Msupport.with_saved_types
+    ?warning_attribute:(if keep_warnings then None else Some [])
+    ~save_part:(fun sg -> Cmt_format.Partial_signature sg)
+    (fun () ->
+       let (trem, rem, final_env) = transl_sig (Env.in_signature true env) sg in
+       let rem = Signature_names.simplify final_env names rem in
+       { sig_items = trem; sig_type = rem; sig_final_env = final_env })
+
+and transl_modtype_decl env pmtd =
+  Builtin_attributes.warning_scope pmtd.pmtd_attributes
+    (fun () -> transl_modtype_decl_aux env pmtd)
+
+and transl_modtype_decl_aux env
+    {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} =
+  let tmty =
+    Option.map (transl_modtype (Env.in_signature true env)) pmtd_type
+  in
+  let decl =
+    {
+     Types.mtd_type=Option.map (fun t -> t.mty_type) tmty;
+     mtd_attributes=pmtd_attributes;
+     mtd_loc=pmtd_loc;
+     mtd_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+    }
+  in
+  let scope = Ctype.create_scope () in
+  let (id, newenv) = Env.enter_modtype ~scope pmtd_name.txt decl env in
+  let mtd =
+    {
+     mtd_id=id;
+     mtd_name=pmtd_name;
+     mtd_type=tmty;
+     mtd_attributes=pmtd_attributes;
+     mtd_loc=pmtd_loc;
+    }
+  in
+  newenv, mtd, Sig_modtype(id, decl, Exported)
+
+and transl_recmodule_modtypes env sdecls =
+  let make_env curr =
+    List.fold_left
+      (fun env (id, _, md, _) ->
+         Option.fold ~none:env
+           ~some:(fun id -> Env.add_module_declaration ~check:true ~arg:true
+                              id Mp_present md env) id)
+      env curr in
+  let transition env_c curr =
+    List.map2
+      (fun pmd (id, id_loc, md, _) ->
+        let tmty =
+          Builtin_attributes.warning_scope pmd.pmd_attributes
+            (fun () -> transl_modtype env_c pmd.pmd_type)
+        in
+        let md = { md with Types.md_type = tmty.mty_type } in
+        (id, id_loc, md, tmty))
+      sdecls curr in
+  let map_mtys curr =
+    List.filter_map
+      (fun (id, _, md, _) -> Option.map (fun id -> (id, md)) id)
+      curr
+  in
+  let scope = Ctype.create_scope () in
+  let ids =
+    List.map (fun x -> Option.map (Ident.create_scoped ~scope) x.pmd_name.txt)
+      sdecls
+  in
+  let approx_env =
+    List.fold_left
+      (fun env ->
+         Option.fold ~none:env ~some:(fun id -> (* cf #5965 *)
+           Env.enter_unbound_module (Ident.name id)
+             Mod_unbound_illegal_recursion env
+         ))
+      env ids
+  in
+  let init =
+    List.map2
+      (fun id pmd ->
+         let md =
+           { md_type = approx_modtype approx_env pmd.pmd_type;
+             md_loc = pmd.pmd_loc;
+             md_attributes = pmd.pmd_attributes;
+             md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) }
+         in
+        (id, pmd.pmd_name, md, ()))
+      ids sdecls
+  in
+  let env0 = make_env init in
+  let dcl1 =
+    Warnings.without_warnings
+      (fun () -> transition env0 init)
+  in
+  let env1 = make_env dcl1 in
+  check_recmod_typedecls env1 (map_mtys dcl1);
+  let dcl2 = transition env1 dcl1 in
+(*
+  List.iter
+    (fun (id, mty) ->
+      Format.printf "%a: %a@." Printtyp.ident id Printtyp.modtype mty)
+    dcl2;
+*)
+  let env2 = make_env dcl2 in
+  check_recmod_typedecls env2 (map_mtys dcl2);
+  let dcl2 =
+    List.map2 (fun pmd (id, id_loc, md, mty) ->
+      let tmd =
+        {md_id=id; md_name=id_loc; md_type=mty;
+         md_presence=Mp_present;
+         md_loc=pmd.pmd_loc;
+         md_attributes=pmd.pmd_attributes}
+      in
+      tmd, md.md_uid
+    ) sdecls dcl2
+  in
+  (dcl2, env2)
+
+(* Try to convert a module expression to a module path. *)
+
+exception Not_a_path
+
+let rec path_of_module mexp =
+  match mexp.mod_desc with
+  | Tmod_ident (p,_) -> p
+  | Tmod_apply(funct, arg, _coercion) when !Clflags.applicative_functors ->
+      Papply(path_of_module funct, path_of_module arg)
+  | Tmod_constraint (mexp, _, _, _) ->
+      path_of_module mexp
+  | _ -> raise Not_a_path
+
+let path_of_module mexp =
+ try Some (path_of_module mexp) with Not_a_path -> None
+
+(* Check that all core type schemes in a structure are closed *)
+
+let rec closed_modtype env = function
+    Mty_ident _ -> true
+  | Mty_alias _ -> true
+  | Mty_for_hole -> true
+  | Mty_signature sg ->
+      let env = Env.add_signature sg env in
+      List.for_all (closed_signature_item env) sg
+  | Mty_functor(arg_opt, body) ->
+      let env =
+        match arg_opt with
+        | Unit
+        | Named (None, _) -> env
+        | Named (Some id, param) ->
+            Env.add_module ~arg:true id Mp_present param env
+      in
+      closed_modtype env body
+
+and closed_signature_item env = function
+    Sig_value(_id, desc, _) -> Ctype.closed_schema env desc.val_type
+  | Sig_module(_id, _, md, _, _) -> closed_modtype env md.md_type
+  | _ -> true
+
+let check_nongen_scheme env sig_item =
+  match sig_item with
+    Sig_value(_id, vd, _) ->
+      if not (Ctype.closed_schema env vd.val_type) then
+        raise (Error (vd.val_loc, env, Non_generalizable vd.val_type))
+  | Sig_module (_id, _, md, _, _) ->
+      if not (closed_modtype env md.md_type) then
+        raise(Error(md.md_loc, env, Non_generalizable_module md.md_type))
+  | _ -> ()
+
+let check_nongen_schemes env sg =
+  List.iter (check_nongen_scheme env) sg
+
+(* Helpers for typing recursive modules *)
+
+let anchor_submodule name anchor =
+  match anchor, name with
+  | None, _
+  | _, None ->
+      None
+  | Some p, Some name ->
+      Some(Pdot(p, name))
+
+let anchor_recmodule = Option.map (fun id -> Pident id)
+
+let enrich_type_decls anchor decls oldenv newenv =
+  match anchor with
+    None -> newenv
+  | Some p ->
+      List.fold_left
+        (fun e info ->
+          let id = info.typ_id in
+          let info' =
+            Mtype.enrich_typedecl oldenv (Pdot(p, Ident.name id))
+              id info.typ_type
+          in
+            Env.add_type ~check:true id info' e)
+        oldenv decls
+
+let enrich_module_type anchor name mty env =
+  match anchor, name with
+  | None, _
+  | _, None ->
+      mty
+  | Some p, Some name ->
+      Mtype.enrich_modtype env (Pdot(p, name)) mty
+
+let check_recmodule_inclusion env bindings =
+  (* PR#4450, PR#4470: consider
+        module rec X : DECL = MOD  where MOD has inferred type ACTUAL
+     The "natural" typing condition
+        E, X: ACTUAL |- ACTUAL <: DECL
+     leads to circularities through manifest types.
+     Instead, we "unroll away" the potential circularities a finite number
+     of times.  The (weaker) condition we implement is:
+        E, X: DECL,
+           X1: ACTUAL,
+           X2: ACTUAL{X <- X1}/X1
+           ...
+           Xn: ACTUAL{X <- X(n-1)}/X(n-1)
+        |- ACTUAL{X <- Xn}/Xn <: DECL{X <- Xn}
+     so that manifest types rooted at X(n+1) are expanded in terms of X(n),
+     avoiding circularities.  The strengthenings ensure that
+     Xn.t = X(n-1).t = ... = X2.t = X1.t.
+     N can be chosen arbitrarily; larger values of N result in more
+     recursive definitions being accepted.  A good choice appears to be
+     the number of mutually recursive declarations. *)
+
+  let subst_and_strengthen env scope s id mty =
+    let mty = Subst.modtype (Rescope scope) s mty in
+    match id with
+    | None -> mty
+    | Some id ->
+        Mtype.strengthen ~aliasable:false env mty
+          (Subst.module_path s (Pident id))
+  in
+
+  let rec check_incl first_time n env s =
+    let scope = Ctype.create_scope () in
+    if n > 0 then begin
+      (* Generate fresh names Y_i for the rec. bound module idents X_i *)
+      let bindings1 =
+        List.map
+          (fun (id, _name, _mty_decl, _modl, mty_actual, _attrs, _loc, _uid) ->
+             let ids =
+               Option.map
+                 (fun id -> (id, Ident.create_scoped ~scope (Ident.name id))) id
+             in
+             (ids, mty_actual))
+          bindings in
+      (* Enter the Y_i in the environment with their actual types substituted
+         by the input substitution s *)
+      let env' =
+        List.fold_left
+          (fun env (ids, mty_actual) ->
+             match ids with
+             | None -> env
+             | Some (id, id') ->
+               let mty_actual' =
+                 if first_time
+                 then mty_actual
+                 else subst_and_strengthen env scope s (Some id) mty_actual
+               in
+               Env.add_module ~arg:false id' Mp_present mty_actual' env)
+          env bindings1 in
+      (* Build the output substitution Y_i <- X_i *)
+      let s' =
+        List.fold_left
+          (fun s (ids, _mty_actual) ->
+             match ids with
+             | None -> s
+             | Some (id, id') -> Subst.add_module id (Pident id') s)
+          Subst.identity bindings1 in
+      (* Recurse with env' and s' *)
+      check_incl false (n-1) env' s'
+    end else begin
+      (* Base case: check inclusion of s(mty_actual) in s(mty_decl)
+         and insert coercion if needed *)
+      let check_inclusion
+            (id, name, mty_decl, modl, mty_actual, attrs, loc, uid) =
+        let mty_decl' = Subst.modtype (Rescope scope) s mty_decl.mty_type
+        and mty_actual' = subst_and_strengthen env scope s id mty_actual in
+        let coercion =
+          try
+            Includemod.modtypes ~loc:modl.mod_loc ~mark:Mark_both env
+              mty_actual' mty_decl'
+          with Includemod.Error msg ->
+            Msupport.raise_error(Error(modl.mod_loc, env, Not_included msg));
+            Tcoerce_none
+        in
+        let modl' =
+            { mod_desc = Tmod_constraint(modl, mty_decl.mty_type,
+                Tmodtype_explicit mty_decl, coercion);
+              mod_type = mty_decl.mty_type;
+              mod_env = env;
+              mod_loc = modl.mod_loc;
+              mod_attributes = [];
+             } in
+        let mb =
+          {
+            mb_id = id;
+            mb_name = name;
+            mb_presence = Mp_present;
+            mb_expr = modl';
+            mb_attributes = attrs;
+            mb_loc = loc;
+          }
+        in
+        mb, uid
+      in
+      List.map check_inclusion bindings
+    end
+  in check_incl true (List.length bindings) env Subst.identity
+
+(* Helper for unpack *)
+
+let rec package_constraints_sig env loc sg constrs =
+  List.map
+    (function
+      | Sig_type (id, ({type_params=[]} as td), rs, priv)
+        when List.mem_assoc [Ident.name id] constrs ->
+          let ty = List.assoc [Ident.name id] constrs in
+          Sig_type (id, {td with type_manifest = Some ty}, rs, priv)
+      | Sig_module (id, pres, md, rs, priv) ->
+          let rec aux = function
+            | (m :: ((_ :: _) as l), t) :: rest when m = Ident.name id ->
+                (l, t) :: aux rest
+            | _ :: rest -> aux rest
+            | [] -> []
+          in
+          let md =
+            {md with
+             md_type = package_constraints env loc md.md_type (aux constrs)
+            }
+          in
+          Sig_module (id, pres, md, rs, priv)
+      | item -> item
+    )
+    sg
+
+and package_constraints env loc mty constrs =
+  if constrs = [] then mty
+  else begin
+    match Mtype.scrape env mty with
+    | Mty_signature sg ->
+        Mty_signature (package_constraints_sig env loc sg constrs)
+    | Mty_functor _ | Mty_alias _ -> assert false
+    | Mty_for_hole -> Mty_for_hole
+    | Mty_ident p -> raise(Error(loc, env, Cannot_scrape_package_type p))
+  end
+
+let modtype_of_package env loc p fl =
+  package_constraints env loc (Mty_ident p)
+    (List.map (fun (n, t) -> (Longident.flatten n, t)) fl)
+
+let package_subtype env p1 fl1 p2 fl2 =
+  let mkmty p fl =
+    let fl =
+      List.filter (fun (_n,t) -> Ctype.free_variables t = []) fl in
+    modtype_of_package env Location.none p fl
+  in
+  match mkmty p1 fl1, mkmty p2 fl2 with
+  | exception Error(_, _, Cannot_scrape_package_type _) -> false
+  | mty1, mty2 ->
+    let loc = Location.none in
+    match Includemod.modtypes ~loc ~mark:Mark_both env mty1 mty2 with
+    | Tcoerce_none -> true
+    | _ | exception Includemod.Error _ -> false
+
+let () = Ctype.package_subtype := package_subtype
+
+let wrap_constraint env mark arg mty explicit =
+  let mark = if mark then Includemod.Mark_both else Includemod.Mark_neither in
+  let coercion =
+    try
+      Includemod.modtypes ~loc:arg.mod_loc env ~mark arg.mod_type mty
+    with Includemod.Error msg ->
+      Msupport.raise_error(Error(arg.mod_loc, env, Not_included msg));
+      Tcoerce_none
+  in
+  { mod_desc = Tmod_constraint(arg, mty, explicit, coercion);
+    mod_type = mty;
+    mod_env = env;
+    mod_attributes = [];
+    mod_loc = arg.mod_loc }
+
+(* Type a module value expression *)
+
+
+(* Summary for F(X) *)
+type application_summary = {
+  loc: Location.t;
+  attributes: attributes;
+  f_loc: Location.t; (* loc for F *)
+  arg_is_syntactic_unit: bool;
+  arg: Typedtree.module_expr;
+  arg_path:Path.t option
+}
+
+let simplify_app_summary app_view =
+  let mty = app_view.arg.mod_type in
+  match app_view.arg_is_syntactic_unit , app_view.arg_path with
+  | true,   _ -> Includemod.Error.Unit, mty
+  | false, Some p -> Includemod.Error.Named p, mty
+  | false, None -> Includemod.Error.Anonymous, mty
+
+let rec type_module ?(alias=false) sttn funct_body anchor env smod =
+  (* Merlin: when we start typing a module we don't want to include potential
+    saved_items from its parent. We backup them before starting and restore them
+    when finished. *)
+  Msupport.with_saved_types @@ fun () ->
+  try
+    Builtin_attributes.warning_scope smod.pmod_attributes
+      (fun () -> type_module_aux ~alias sttn funct_body anchor env smod)
+  with exn ->
+    Msupport.raise_error exn;
+    { mod_desc = Tmod_structure {
+        str_items = [];
+        str_type = [];
+        str_final_env = env;
+      };
+      mod_type = Mty_signature [];
+      mod_env = env;
+      mod_attributes = Msupport.flush_saved_types () @ smod.pmod_attributes;
+      mod_loc = smod.pmod_loc }
+
+and type_module_aux ~alias sttn funct_body anchor env smod =
+  match smod.pmod_desc with
+    Pmod_ident lid ->
+      let path =
+        Env.lookup_module_path ~load:(not alias) ~loc:smod.pmod_loc lid.txt env
+      in
+      let md = { mod_desc = Tmod_ident (path, lid);
+                 mod_type = Mty_alias path;
+                 mod_env = env;
+                 mod_attributes = smod.pmod_attributes;
+                 mod_loc = smod.pmod_loc } in
+      let aliasable = not (Env.is_functor_arg path env) in
+      let md =
+        if alias && aliasable then
+          (Env.add_required_global (Path.head path); md)
+        else match (Env.find_module path env).md_type with
+        | Mty_alias p1 when not alias ->
+            let p1 = Env.normalize_module_path (Some smod.pmod_loc) env p1 in
+            let mty = Includemod.expand_module_alias env p1 in
+            { md with
+              mod_desc =
+                Tmod_constraint (md, mty, Tmodtype_implicit,
+                                 Tcoerce_alias (env, path, Tcoerce_none));
+              mod_type =
+                if sttn then Mtype.strengthen ~aliasable:true env mty p1
+                else mty }
+        | mty ->
+            let mty =
+              if sttn then Mtype.strengthen ~aliasable env mty path
+              else mty
+            in
+            { md with mod_type = mty }
+      in md
+  | Pmod_structure sstr ->
+      let (str, sg, names, _finalenv) =
+        type_structure funct_body anchor env sstr in
+      let md =
+        { mod_desc = Tmod_structure str;
+          mod_type = Mty_signature sg;
+          mod_env = env;
+          mod_attributes = smod.pmod_attributes;
+          mod_loc = smod.pmod_loc }
+      in
+      let sg' = Signature_names.simplify _finalenv names sg in
+      if List.length sg' = List.length sg then md else
+      wrap_constraint env false md (Mty_signature sg')
+        Tmodtype_implicit
+  | Pmod_functor(arg_opt, sbody) ->
+      let t_arg, ty_arg, newenv, funct_body =
+        match arg_opt with
+        | Unit -> Unit, Types.Unit, env, false
+        | Named (param, smty) ->
+          let mty = transl_modtype_functor_arg env smty in
+          let scope = Ctype.create_scope () in
+          let (id, newenv) =
+            match param.txt with
+            | None -> None, env
+            | Some name ->
+              let arg_md =
+                { md_type = mty.mty_type;
+                  md_attributes = [];
+                  md_loc = param.loc;
+                  md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+                }
+              in
+              let id, newenv =
+                Env.enter_module_declaration ~scope ~arg:true name Mp_present
+                  arg_md env
+              in
+              Some id, newenv
+          in
+          Named (id, param, mty), Types.Named (id, mty.mty_type), newenv, true
+      in
+      let body = type_module true funct_body None newenv sbody in
+      { mod_desc = Tmod_functor(t_arg, body);
+        mod_type = Mty_functor(ty_arg, body.mod_type);
+        mod_env = env;
+        mod_attributes = smod.pmod_attributes;
+        mod_loc = smod.pmod_loc }
+  | Pmod_apply _ ->
+      type_application smod.pmod_loc sttn funct_body env smod
+  | Pmod_constraint(sarg, smty) ->
+      let arg = type_module ~alias true funct_body anchor env sarg in
+      begin try
+        let mty = transl_modtype env smty in
+        let md =
+          wrap_constraint env true arg mty.mty_type (Tmodtype_explicit mty)
+        in
+        { md with
+          mod_loc = smod.pmod_loc;
+          mod_attributes = smod.pmod_attributes;
+        }
+      with exn ->
+       (* [merlin] For better Construct error messages we need to keep holes
+          in the recovered typedtree *)
+        match sarg.pmod_desc with
+        | Pmod_extension ({ txt; _ }, _) when txt = Ast_helper.hole_txt ->
+            Msupport.raise_error exn;
+            {
+              mod_desc = Tmod_hole;
+              mod_type = Mty_for_hole;
+              mod_loc = sarg.pmod_loc;
+              mod_env = env;
+              mod_attributes = sarg.pmod_attributes;
+            }
+        | _ -> raise exn
+      end
+  | Pmod_unpack sexp ->
+      if !Clflags.principal then Ctype.begin_def ();
+      let exp = Typecore.type_exp env sexp in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        Ctype.generalize_structure exp.exp_type
+      end;
+      let mty =
+        match Ctype.expand_head env exp.exp_type with
+          {desc = Tpackage (p, fl)} ->
+            if List.exists (fun (_n, t) -> Ctype.free_variables t <> []) fl then
+              raise (Error (smod.pmod_loc, env,
+                            Incomplete_packed_module exp.exp_type));
+            if !Clflags.principal &&
+              not (Typecore.generalizable (Btype.generic_level-1) exp.exp_type)
+            then
+              Location.prerr_warning smod.pmod_loc
+                (Warnings.Not_principal "this module unpacking");
+            modtype_of_package env smod.pmod_loc p fl
+        | {desc = Tvar _} ->
+            raise (Typecore.Error
+                     (smod.pmod_loc, env, Typecore.Cannot_infer_signature))
+        | _ ->
+            raise (Error(smod.pmod_loc, env, Not_a_packed_module exp.exp_type))
+      in
+      if funct_body && Mtype.contains_type env mty then
+        raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
+      { mod_desc = Tmod_unpack(exp, mty);
+        mod_type = mty;
+        mod_env = env;
+        mod_attributes = smod.pmod_attributes;
+        mod_loc = smod.pmod_loc }
+  | Pmod_extension ({ txt; _ }, _) when txt = Ast_helper.hole_txt ->
+      { mod_desc = Tmod_hole;
+        mod_type = Mty_for_hole;
+        mod_env = env;
+        mod_attributes = smod.pmod_attributes;
+        mod_loc = smod.pmod_loc }
+  | Pmod_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and type_application loc strengthen funct_body env smod =
+  let rec extract_application funct_body env sargs smod =
+    match smod.pmod_desc with
+    | Pmod_apply(f, sarg) ->
+        let arg = type_module true funct_body None env sarg in
+        let summary =
+          { loc=smod.pmod_loc;
+            attributes=smod.pmod_attributes;
+            f_loc = f.pmod_loc;
+            arg_is_syntactic_unit = sarg.pmod_desc = Pmod_structure [];
+            arg;
+            arg_path = path_of_module arg
+          }
+        in
+        extract_application funct_body env (summary::sargs) f
+    | _ -> smod, sargs
+  in
+  let sfunct, args = extract_application funct_body env [] smod in
+  let funct =
+    let strengthen =
+      strengthen && List.for_all (fun {arg_path;_} -> arg_path <> None) args
+    in
+    type_module strengthen funct_body None env sfunct
+  in
+  List.fold_left (type_one_application ~ctx:(loc, funct, args) funct_body env)
+    funct args
+
+and type_one_application ~ctx:(apply_loc,md_f,args) funct_body env funct
+    app_view =
+  match Env.scrape_alias env funct.mod_type with
+  | Mty_functor (Unit, mty_res) ->
+      if not app_view.arg_is_syntactic_unit then
+        raise (Error (app_view.f_loc, env, Apply_generative));
+      if funct_body && Mtype.contains_type env funct.mod_type then
+        raise (Error (apply_loc, env, Not_allowed_in_functor_body));
+      { mod_desc = Tmod_apply(funct, app_view.arg, Tcoerce_none);
+        mod_type = mty_res;
+        mod_env = env;
+        mod_attributes = app_view.attributes;
+        mod_loc = funct.mod_loc }
+  | Mty_functor (Named (param, mty_param), mty_res) as mty_functor ->
+      let coercion =
+        try
+          Includemod.modtypes
+            ~loc:app_view.arg.mod_loc ~mark:Mark_both env
+            app_view.arg.mod_type mty_param
+        with Includemod.Error msg ->
+          let _args = List.map simplify_app_summary args in
+          let _mty_f = md_f.mod_type in
+          let _lid_app = None in
+          Msupport.raise_error(
+            Error(app_view.arg.mod_loc, env, Not_included msg));
+          Tcoerce_none
+      in
+      let mty_appl =
+        match app_view.arg_path with
+        | Some path ->
+            let scope = Ctype.create_scope () in
+            let subst =
+              match param with
+              | None -> Subst.identity
+              | Some p -> Subst.add_module p path Subst.identity
+            in
+            Subst.modtype (Rescope scope) subst mty_res
+        | None ->
+            let nondep_mty =
+              match param with
+              | None -> mty_res
+              | Some param ->
+                  let parent_env = env in
+                  let env =
+                    Env.add_module ~arg:true param Mp_present
+                      app_view.arg.mod_type env
+                  in
+                  check_well_formed_module env app_view.loc
+                    "the signature of this functor application" mty_res;
+                  try Mtype.nondep_supertype env [param] mty_res
+                  with Ctype.Nondep_cannot_erase _ ->
+                    let error = Cannot_eliminate_dependency mty_functor in
+                    raise (Error(app_view.loc, parent_env, error))
+            in
+            (* TODO(merlin): we could perhaps log the "fatal error" cases...
+               not sure it's worth the effort. *)
+            (*
+            begin match
+              Includemod.modtypes
+                ~loc:app_view.loc ~mark:Mark_neither env mty_res nondep_mty
+            with
+            | Tcoerce_none -> ()
+            | _ ->
+                fatal_error
+                  "unexpected coercion from original module type to \
+                   nondep_supertype one"
+            | exception Includemod.Error _ ->
+                fatal_error
+                  "nondep_supertype not included in original module type"
+            end;
+            *)
+            nondep_mty
+      in
+      check_well_formed_module env apply_loc
+        "the signature of this functor application" mty_appl;
+      { mod_desc = Tmod_apply(funct, app_view.arg, coercion);
+        mod_type = mty_appl;
+        mod_env = env;
+        mod_attributes = app_view.attributes;
+        mod_loc = app_view.loc }
+  | Mty_alias path ->
+      raise(Error(app_view.f_loc, env, Cannot_scrape_alias path))
+  | _ ->
+      let args = List.map simplify_app_summary args in
+      let mty_f = md_f.mod_type in
+      let lid_app = None in
+      raise(Includemod.Apply_error {loc=apply_loc;env;lid_app;mty_f;args})
+
+and type_open_decl ?used_slot ?toplevel funct_body names env sod =
+  Builtin_attributes.warning_scope sod.popen_attributes
+    (fun () ->
+       type_open_decl_aux ?used_slot ?toplevel funct_body names env sod
+    )
+
+and type_open_decl_aux ?used_slot ?toplevel funct_body names env od =
+  let loc = od.popen_loc in
+  match od.popen_expr.pmod_desc with
+  | Pmod_ident lid ->
+    let path, newenv =
+      type_open_ ?used_slot ?toplevel od.popen_override env loc lid
+    in
+    let md = { mod_desc = Tmod_ident (path, lid);
+               mod_type = Mty_alias path;
+               mod_env = env;
+               mod_attributes = od.popen_expr.pmod_attributes;
+               mod_loc = od.popen_expr.pmod_loc }
+    in
+    let open_descr = {
+      open_expr = md;
+      open_bound_items = [];
+      open_override = od.popen_override;
+      open_env = newenv;
+      open_loc = loc;
+      open_attributes = od.popen_attributes
+    } in
+    open_descr, [], newenv
+  | _ ->
+    let md = type_module true funct_body None env od.popen_expr in
+    let scope = Ctype.create_scope () in
+    let sg, newenv =
+      Env.enter_signature ~scope (extract_sig_open env md.mod_loc md.mod_type)
+        env
+    in
+    let info, visibility =
+      match toplevel with
+      | Some false | None -> Some `From_open, Hidden
+      | Some true -> None, Exported
+    in
+    Signature_group.iter (Signature_names.check_sig_item ?info names loc) sg;
+    let sg =
+      List.map (function
+        | Sig_value(id, vd, _) -> Sig_value(id, vd, visibility)
+        | Sig_type(id, td, rs, _) -> Sig_type(id, td, rs, visibility)
+        | Sig_typext(id, ec, et, _) -> Sig_typext(id, ec, et, visibility)
+        | Sig_module(id, mp, md, rs, _) ->
+            Sig_module(id, mp, md, rs, visibility)
+        | Sig_modtype(id, mtd, _) -> Sig_modtype(id, mtd, visibility)
+        | Sig_class(id, cd, rs, _) -> Sig_class(id, cd, rs, visibility)
+        | Sig_class_type(id, ctd, rs, _) ->
+            Sig_class_type(id, ctd, rs, visibility)
+      ) sg
+    in
+    let open_descr = {
+      open_expr = md;
+      open_bound_items = sg;
+      open_override = od.popen_override;
+      open_env = newenv;
+      open_loc = loc;
+      open_attributes = od.popen_attributes
+    } in
+    open_descr, sg, newenv
+
+and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body anchor env sstr =
+  let names = Signature_names.create () in
+
+  let type_str_item env {pstr_loc = loc; pstr_desc = desc} =
+    match desc with
+    | Pstr_eval (sexpr, attrs) ->
+        let expr =
+          Builtin_attributes.warning_scope attrs
+            (fun () -> Typecore.type_expression env sexpr)
+        in
+        Tstr_eval (expr, attrs), [], env
+    | Pstr_value(rec_flag, sdefs) ->
+        let (defs, newenv) =
+          Typecore.type_binding env rec_flag sdefs in
+        let () = if rec_flag = Recursive then
+          Typecore.check_recursive_bindings env defs
+        in
+        (* Note: Env.find_value does not trigger the value_used event. Values
+           will be marked as being used during the signature inclusion test. *)
+        Tstr_value(rec_flag, defs),
+        List.map (fun (id, { Asttypes.loc; _ }, _typ)->
+          Signature_names.check_value names loc id;
+          Sig_value(id, Env.find_value (Pident id) newenv, Exported)
+        ) (let_bound_idents_full defs),
+        newenv
+    | Pstr_primitive sdesc ->
+        let (desc, newenv) = Typedecl.transl_value_decl env loc sdesc in
+        Signature_names.check_value names desc.val_loc desc.val_id;
+        Tstr_primitive desc,
+        [Sig_value(desc.val_id, desc.val_val, Exported)],
+        newenv
+    | Pstr_type (rec_flag, sdecls) ->
+        let (decls, newenv) = Typedecl.transl_type_decl env rec_flag sdecls in
+        let newenv = Env.update_short_paths newenv in
+        List.iter
+          Signature_names.(fun td -> check_type names td.typ_loc td.typ_id)
+          decls;
+        Tstr_type (rec_flag, decls),
+        map_rec_type_with_row_types ~rec_flag
+          (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs, Exported))
+          decls [],
+        enrich_type_decls anchor decls env newenv
+    | Pstr_typext styext ->
+        let (tyext, newenv) =
+          Typedecl.transl_type_extension true env loc styext
+        in
+        let constructors = tyext.tyext_constructors in
+        List.iter
+          Signature_names.(fun ext -> check_typext names ext.ext_loc ext.ext_id)
+          constructors;
+        (Tstr_typext tyext,
+         map_ext
+           (fun es ext -> Sig_typext(ext.ext_id, ext.ext_type, es, Exported))
+           constructors [],
+         newenv)
+    | Pstr_exception sext ->
+        let (ext, newenv) = Typedecl.transl_type_exception env sext in
+        let constructor = ext.tyexn_constructor in
+        Signature_names.check_typext names constructor.ext_loc
+          constructor.ext_id;
+        Tstr_exception ext,
+        [Sig_typext(constructor.ext_id,
+                    constructor.ext_type,
+                    Text_exception,
+                    Exported)],
+        newenv
+    | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs;
+                   pmb_loc;
+                  } ->
+        let outer_scope = Ctype.get_current_level () in
+        let scope = Ctype.create_scope () in
+        let modl =
+          Builtin_attributes.warning_scope attrs
+            (fun () ->
+               type_module ~alias:true true funct_body
+                 (anchor_submodule name.txt anchor) env smodl
+            )
+        in
+        let pres =
+          match modl.mod_type with
+          | Mty_alias _ -> Mp_absent
+          | _ -> Mp_present
+        in
+        let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in
+        let md =
+          { md_type = enrich_module_type anchor name.txt modl.mod_type env;
+            md_attributes = attrs;
+            md_loc = pmb_loc;
+            md_uid;
+          }
+        in
+        (*prerr_endline (Ident.unique_toplevel_name id);*)
+        Mtype.lower_nongen outer_scope md.md_type;
+        let id, newenv, sg =
+          match name.txt with
+          | None -> None, env, []
+          | Some name ->
+            let id, e = Env.enter_module_declaration ~scope name pres md env in
+            let e = Env.update_short_paths e in
+            Signature_names.check_module names pmb_loc id;
+            Some id, e,
+            [Sig_module(id, pres,
+                        {md_type = modl.mod_type;
+                         md_attributes = attrs;
+                         md_loc = pmb_loc;
+                         md_uid;
+                        }, Trec_not, Exported)]
+        in
+        Tstr_module {mb_id=id; mb_name=name; mb_expr=modl;
+                     mb_presence=pres; mb_attributes=attrs;  mb_loc=pmb_loc; },
+        sg,
+        newenv
+    | Pstr_recmodule sbind ->
+        let sbind =
+          List.map
+            (function
+              | {pmb_name = name;
+                 pmb_expr = {pmod_desc=Pmod_constraint(expr, typ)};
+                 pmb_attributes = attrs;
+                 pmb_loc = loc;
+                } ->
+                  name, typ, expr, attrs, loc
+              | mb ->
+                  raise (Error (mb.pmb_expr.pmod_loc, env,
+                                Recursive_module_require_explicit_type))
+            )
+            sbind
+        in
+        let (decls, newenv) =
+          transl_recmodule_modtypes env
+            (List.map (fun (name, smty, _smodl, attrs, loc) ->
+                 {pmd_name=name; pmd_type=smty;
+                  pmd_attributes=attrs; pmd_loc=loc}) sbind
+            ) in
+        List.iter
+          (fun (md, _) ->
+            Option.iter Signature_names.(check_module names md.md_loc) md.md_id)
+          decls;
+        let newenv = Env.update_short_paths newenv in
+        let bindings1 =
+          List.map2
+            (fun ({md_id=id; md_type=mty}, uid) (name, _, smodl, attrs, loc) ->
+               let modl =
+                 Builtin_attributes.warning_scope attrs
+                   (fun () ->
+                      type_module true funct_body (anchor_recmodule id)
+                        newenv smodl
+                   )
+               in
+               let mty' =
+                 enrich_module_type anchor name.txt modl.mod_type newenv
+               in
+               (id, name, mty, modl, mty', attrs, loc, uid))
+            decls sbind in
+        let newenv = (* allow aliasing recursive modules from outside *)
+          List.fold_left
+            (fun env (md, uid) ->
+               match md.md_id with
+               | None -> env
+               | Some id ->
+                   let mdecl =
+                     {
+                       md_type = md.md_type.mty_type;
+                       md_attributes = md.md_attributes;
+                       md_loc = md.md_loc;
+                       md_uid = uid;
+                     }
+                   in
+                   Env.add_module_declaration ~check:true
+                     id Mp_present mdecl env
+            )
+            env decls
+        in
+        let newenv = Env.update_short_paths newenv in
+        let bindings2 =
+          check_recmodule_inclusion newenv bindings1 in
+        let mbs =
+          List.filter_map (fun (mb, uid) ->
+            Option.map (fun id -> id, mb, uid)  mb.mb_id
+          ) bindings2
+        in
+        Tstr_recmodule (List.map fst bindings2),
+        map_rec (fun rs (id, mb, uid) ->
+            Sig_module(id, Mp_present, {
+                md_type=mb.mb_expr.mod_type;
+                md_attributes=mb.mb_attributes;
+                md_loc=mb.mb_loc;
+                md_uid = uid;
+              }, rs, Exported))
+           mbs [],
+        newenv
+    | Pstr_modtype pmtd ->
+        (* check that it is non-abstract *)
+        let newenv, mtd, sg = transl_modtype_decl env pmtd in
+        let newenv = Env.update_short_paths newenv in
+        Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id;
+        Tstr_modtype mtd, [sg], newenv
+    | Pstr_open sod ->
+        let (od, sg, newenv) =
+          type_open_decl ~toplevel funct_body names env sod
+        in
+        let newenv = Env.update_short_paths newenv in
+        Tstr_open od, sg, newenv
+    | Pstr_class cl ->
+        let (classes, new_env) = Typeclass.class_declarations env cl in
+        let new_env = Env.update_short_paths new_env in
+        List.iter (fun cls ->
+          let open Typeclass in
+          let loc = cls.cls_id_loc.Location.loc in
+          Signature_names.check_class names loc cls.cls_id;
+          Signature_names.check_class_type names loc cls.cls_ty_id;
+          Signature_names.check_type names loc cls.cls_obj_id;
+          Signature_names.check_type names loc cls.cls_typesharp_id;
+        ) classes;
+        Tstr_class
+          (List.map (fun cls ->
+               (cls.Typeclass.cls_info,
+                cls.Typeclass.cls_pub_methods)) classes),
+        List.flatten
+          (map_rec
+            (fun rs cls ->
+              let open Typeclass in
+              [Sig_class(cls.cls_id, cls.cls_decl, rs, Exported);
+               Sig_class_type(cls.cls_ty_id, cls.cls_ty_decl, rs, Exported);
+               Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs, Exported);
+               Sig_type(cls.cls_typesharp_id, cls.cls_abbr, rs, Exported)])
+             classes []),
+        new_env
+    | Pstr_class_type cl ->
+        let (classes, new_env) = Typeclass.class_type_declarations env cl in
+        let new_env = Env.update_short_paths new_env in
+        List.iter (fun decl ->
+          let open Typeclass in
+          let loc = decl.clsty_id_loc.Location.loc in
+          Signature_names.check_class_type names loc decl.clsty_ty_id;
+          Signature_names.check_type names loc decl.clsty_obj_id;
+          Signature_names.check_type names loc decl.clsty_typesharp_id;
+        ) classes;
+        Tstr_class_type
+          (List.map (fun cl ->
+               (cl.Typeclass.clsty_ty_id,
+                cl.Typeclass.clsty_id_loc,
+                cl.Typeclass.clsty_info)) classes),
+        List.flatten
+          (map_rec
+             (fun rs decl ->
+                let open Typeclass in
+                [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs,
+                                Exported);
+                 Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs, Exported);
+                 Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs,
+                          Exported)
+                ])
+             classes []),
+        new_env
+    | Pstr_include sincl ->
+        let smodl = sincl.pincl_mod in
+        let modl =
+          Builtin_attributes.warning_scope sincl.pincl_attributes
+            (fun () -> type_module true funct_body None env smodl)
+        in
+        let scope = Ctype.create_scope () in
+        (* Rename all identifiers bound by this signature to avoid clashes *)
+        let sg, new_env = Env.enter_signature ~scope
+            (extract_sig_open env smodl.pmod_loc modl.mod_type) env in
+        let new_env = Env.update_short_paths new_env in
+        Signature_group.iter (Signature_names.check_sig_item names loc) sg;
+        let incl =
+          { incl_mod = modl;
+            incl_type = sg;
+            incl_attributes = sincl.pincl_attributes;
+            incl_loc = sincl.pincl_loc;
+          }
+        in
+        Tstr_include incl, sg, new_env
+    | Pstr_extension (ext, _attrs) ->
+        raise (Error_forward (Builtin_attributes.error_of_extension ext))
+    | Pstr_attribute x ->
+        Builtin_attributes.warning_attribute x;
+        Tstr_attribute x, [], env
+  in
+  let rec type_struct env sstr =
+    match sstr with
+    | [] -> ([], [], env)
+    | pstr :: srem ->
+        let previous_saved_types = Cmt_format.get_saved_types () in
+        match type_str_item env pstr with
+        | desc, sg, new_env ->
+          let str = { str_desc = desc; str_loc = pstr.pstr_loc; str_env = env } in
+          Cmt_format.set_saved_types (Cmt_format.Partial_structure_item str
+                                      :: previous_saved_types);
+          let (str_rem, sig_rem, final_env) = type_struct new_env srem in
+          (str :: str_rem, sg @ sig_rem, final_env)
+        | exception exn ->
+          Msupport.raise_error exn;
+          type_struct env srem
+  in
+  Msupport.with_saved_types
+    ?warning_attribute:(if toplevel || keep_warnings then None else Some [])
+    ~save_part:(fun (str,_,_,_) -> Cmt_format.Partial_structure str)
+    (fun () ->
+      let (items, sg, final_env) = type_struct env sstr in
+      let str = { str_items = items; str_type = sg; str_final_env = final_env } in
+      str, sg, names, final_env)
+
+let type_toplevel_phrase env s =
+  Env.reset_required_globals ();
+  let (str, sg, _to_remove_from_sg, env) =
+    type_structure ~toplevel:true false None env s in
+  (str, sg, (* to_remove_from_sg, *) env)
+
+let type_module_alias = type_module ~alias:true true false None
+let type_module = type_module true false None
+
+let merlin_type_structure env str =
+  let (str, sg, _sg_names, env) =
+    type_structure ~keep_warnings:true false None env str
+  in
+  str, sg, env
+let type_structure = type_structure false None
+let merlin_transl_signature env sg = transl_signature ~keep_warnings:true env sg
+let transl_signature env sg = transl_signature env sg
+
+(* Normalize types in a signature *)
+
+let rec normalize_modtype = function
+    Mty_ident _
+  | Mty_alias _
+  | Mty_for_hole -> ()
+  | Mty_signature sg -> normalize_signature sg
+  | Mty_functor(_param, body) -> normalize_modtype body
+
+and normalize_signature sg = List.iter normalize_signature_item sg
+
+and normalize_signature_item = function
+    Sig_value(_id, desc, _) -> Ctype.normalize_type desc.val_type
+  | Sig_module(_id, _, md, _, _) -> normalize_modtype md.md_type
+  | _ -> ()
+
+(* Extract the module type of a module expression *)
+
+let type_module_type_of env smod =
+  let remove_aliases = has_remove_aliases_attribute smod.pmod_attributes in
+  let tmty =
+    match smod.pmod_desc with
+    | Pmod_ident lid -> (* turn off strengthening in this case *)
+        let path, md = Env.lookup_module ~loc:smod.pmod_loc lid.txt env in
+          { mod_desc = Tmod_ident (path, lid);
+            mod_type = md.md_type;
+            mod_env = env;
+            mod_attributes = smod.pmod_attributes;
+            mod_loc = smod.pmod_loc }
+    | _ -> type_module env smod
+  in
+  let mty = Mtype.scrape_for_type_of ~remove_aliases env tmty.mod_type in
+  (* PR#5036: must not contain non-generalized type variables *)
+  if not (closed_modtype env mty) then
+    raise(Error(smod.pmod_loc, env, Non_generalizable_module mty));
+  tmty, mty
+
+(* For Typecore *)
+
+(* Graft a longident onto a path *)
+let rec extend_path path =
+  fun lid ->
+    match lid with
+    | Lident name -> Pdot(path, name)
+    | Ldot(m, name) -> Pdot(extend_path path m, name)
+    | Lapply _ -> assert false
+
+(* Lookup a type's longident within a signature *)
+let lookup_type_in_sig sg =
+  let types, modules =
+    List.fold_left
+      (fun acc item ->
+         match item with
+         | Sig_type(id, _, _, _) ->
+             let types, modules = acc in
+             let types = String.Map.add (Ident.name id) id types in
+             types, modules
+         | Sig_module(id, _, _, _, _) ->
+             let types, modules = acc in
+             let modules = String.Map.add (Ident.name id) id modules in
+             types, modules
+         | _ -> acc)
+      (String.Map.empty, String.Map.empty) sg
+  in
+  let rec module_path = function
+    | Lident name -> Pident (String.Map.find name modules)
+    | Ldot(m, name) -> Pdot(module_path m, name)
+    | Lapply _ -> assert false
+  in
+  fun lid ->
+    match lid with
+    | Lident name -> Pident (String.Map.find name types)
+    | Ldot(m, name) -> Pdot(module_path m, name)
+    | Lapply _ -> assert false
+
+let type_package env m p fl =
+  (* Same as Pexp_letmodule *)
+  (* remember original level *)
+  Ctype.begin_def ();
+  let context = Typetexp.narrow () in
+  let modl = type_module env m in
+  let scope = Ctype.create_scope () in
+  Typetexp.widen context;
+  let fl', env =
+    match fl with
+    | [] -> [], env
+    | fl ->
+      let type_path, env =
+        match modl.mod_desc with
+        | Tmod_ident (mp,_)
+        | Tmod_constraint
+            ({mod_desc=Tmod_ident (mp,_)}, _, Tmodtype_implicit, _) ->
+          (* We special case these because interactions between
+             strengthening of module types and packages can cause
+             spurious escape errors. See examples from PR#6982 in the
+             testsuite. This can be removed when such issues are
+             fixed. *)
+          extend_path mp, env
+        | _ ->
+          let sg = extract_sig_open env modl.mod_loc modl.mod_type in
+          let sg, env = Env.enter_signature ~scope sg env in
+          lookup_type_in_sig sg, env
+      in
+      let fl' =
+        List.fold_right
+          (fun (lid, _t) fl ->
+             match type_path lid with
+             | exception Not_found -> fl
+             | path -> begin
+                 match Env.find_type path env with
+                 | exception Not_found -> fl
+                 | decl ->
+                     if decl.type_arity > 0 then begin
+                       fl
+                     end else begin
+                       let t = Btype.newgenty (Tconstr (path,[],ref Mnil)) in
+                       (lid, t) :: fl
+                     end
+               end)
+          fl []
+      in
+      fl', env
+  in
+  (* go back to original level *)
+  Ctype.end_def ();
+  let mty =
+    if fl = [] then (Mty_ident p)
+    else modtype_of_package env modl.mod_loc p fl'
+  in
+  List.iter
+    (fun (n, ty) ->
+      try Ctype.unify env ty (Ctype.newvar ())
+      with Ctype.Unify _ ->
+        raise (Error(modl.mod_loc, env, Scoping_pack (n,ty))))
+    fl';
+  let modl = wrap_constraint env true modl mty Tmodtype_implicit in
+  modl, fl'
+
+(* Fill in the forward declarations *)
+
+let type_open_decl ?used_slot env od =
+  type_open_decl ?used_slot ?toplevel:None false (Signature_names.create ()) env
+    od
+
+let type_open_descr ?used_slot env od =
+  type_open_descr ?used_slot ?toplevel:None env od
+
+let () =
+  Typecore.type_module := type_module_alias;
+  Typetexp.transl_modtype_longident := transl_modtype_longident;
+  Typetexp.transl_modtype := transl_modtype;
+  Typecore.type_open := type_open_ ?toplevel:None;
+  Typecore.type_open_decl := type_open_decl;
+  Typecore.type_package := type_package;
+  Typeclass.type_open_descr := type_open_descr;
+  type_module_type_of_fwd := type_module_type_of
+
+
+(* Typecheck an implementation file *)
+
+let type_implementation sourcefile outputprefix modulename initial_env ast =
+  Cmt_format.clear ();
+  Misc.try_finally (fun () ->
+      Typecore.reset_delayed_checks ();
+      Env.reset_required_globals ();
+      if !Clflags.print_types then (* #7656 *)
+        ignore @@ Warnings.parse_options false "-32-34-37-38-60";
+      let (str, sg, names, finalenv) =
+        type_structure initial_env ast in
+      let simple_sg = Signature_names.simplify finalenv names sg in
+      if !Clflags.print_types then begin
+        Typecore.force_delayed_checks ();
+        Printtyp.wrap_printing_env ~error:false initial_env
+          (fun () -> fprintf std_formatter "%a@."
+              (Printtyp.printed_signature sourcefile) simple_sg
+          );
+        { structure = str;
+          coercion = Tcoerce_none;
+          signature = simple_sg
+        } (* result is ignored by Compile.implementation *)
+      end else begin
+        let sourceintf =
+          Filename.remove_extension sourcefile ^ !Config.interface_suffix in
+        if Sys.file_exists sourceintf then begin
+          let intf_file =
+            try
+              Load_path.find_uncap (modulename ^ ".cmi")
+            with Not_found ->
+              raise(Error(Location.in_file sourcefile, Env.empty,
+                          Interface_not_compiled sourceintf)) in
+          let dclsig = Env.read_signature modulename intf_file in
+          let coercion =
+            Includemod.compunit initial_env ~mark:Mark_positive
+              sourcefile sg intf_file dclsig
+          in
+          Typecore.force_delayed_checks ();
+          (* It is important to run these checks after the inclusion test above,
+             so that value declarations which are not used internally but
+             exported are not reported as being unused. *)
+          let annots = Cmt_format.Implementation str in
+          Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename
+            annots (Some sourcefile) initial_env None;
+          { structure = str;
+            coercion;
+            signature = dclsig
+          }
+        end else begin
+          Location.prerr_warning (Location.in_file sourcefile)
+            Warnings.Missing_mli;
+          let coercion =
+            Includemod.compunit initial_env ~mark:Mark_positive
+              sourcefile sg "(inferred signature)" simple_sg
+          in
+          check_nongen_schemes finalenv simple_sg;
+          normalize_signature simple_sg;
+          Typecore.force_delayed_checks ();
+          (* See comment above. Here the target signature contains all
+             the value being exported. We can still capture unused
+             declarations like "let x = true;; let x = 1;;", because in this
+             case, the inferred signature contains only the last declaration. *)
+          if not !Clflags.dont_write_files then begin
+            let alerts = Builtin_attributes.alerts_of_str ast in
+            let cmi =
+              Env.save_signature ~alerts
+                simple_sg modulename (outputprefix ^ ".cmi")
+            in
+            let annots = Cmt_format.Implementation str in
+            Cmt_format.save_cmt  (outputprefix ^ ".cmt") modulename
+              annots (Some sourcefile) initial_env (Some cmi)
+          end;
+          { structure = str;
+            coercion;
+            signature = simple_sg
+          }
+        end
+      end
+    )
+    ~exceptionally:(fun () ->
+        let annots =
+          Cmt_format.Partial_implementation
+            (Array.of_list (Cmt_format.get_saved_types ()))
+        in
+        Cmt_format.save_cmt  (outputprefix ^ ".cmt") modulename
+          annots (Some sourcefile) initial_env None
+      )
+
+let save_signature modname tsg outputprefix source_file initial_env cmi =
+  Cmt_format.save_cmt  (outputprefix ^ ".cmti") modname
+    (Cmt_format.Interface tsg) (Some source_file) initial_env (Some cmi)
+
+let type_interface env ast =
+  transl_signature env ast
+
+(* "Packaging" of several compilation units into one unit
+   having them as sub-modules.  *)
+
+let package_signatures units =
+  let units_with_ids =
+    List.map
+      (fun (name, sg) ->
+        let oldid = Ident.create_persistent name in
+        let newid = Ident.create_local name in
+        (oldid, newid, sg))
+      units
+  in
+  let subst =
+    List.fold_left
+      (fun acc (oldid, newid, _) ->
+        Subst.add_module oldid (Pident newid) acc)
+      Subst.identity units_with_ids
+  in
+  List.map
+    (fun (_, newid, sg) ->
+      (* This signature won't be used for anything, it'll just be saved in a cmi
+         and cmt. *)
+      let sg = Subst.signature Make_local subst sg in
+      let md =
+        { md_type=Mty_signature sg;
+          md_attributes=[];
+          md_loc=Location.none;
+          md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+        }
+      in
+      Sig_module(newid, Mp_present, md, Trec_not, Exported))
+    units_with_ids
+
+let package_units initial_env objfiles cmifile modulename =
+  (* Read the signatures of the units *)
+  let units =
+    List.map
+      (fun f ->
+         let pref = chop_extensions f in
+         let modname = String.capitalize_ascii(Filename.basename pref) in
+         let sg = Env.read_signature modname (pref ^ ".cmi") in
+         if Filename.check_suffix f ".cmi" &&
+            not(Mtype.no_code_needed_sig Env.initial_safe_string sg)
+         then raise(Error(Location.none, Env.empty,
+                          Implementation_is_required f));
+         (modname, Env.read_signature modname (pref ^ ".cmi")))
+      objfiles in
+  (* Compute signature of packaged unit *)
+  Ident.reinit();
+  let sg = package_signatures units in
+  (* See if explicit interface is provided *)
+  let prefix = Filename.remove_extension cmifile in
+  let mlifile = prefix ^ !Config.interface_suffix in
+  if Sys.file_exists mlifile then begin
+    if not (Sys.file_exists cmifile) then begin
+      raise(Error(Location.in_file mlifile, Env.empty,
+                  Interface_not_compiled mlifile))
+    end;
+    let dclsig = Env.read_signature modulename cmifile in
+    Cmt_format.save_cmt  (prefix ^ ".cmt") modulename
+      (Cmt_format.Packed (sg, objfiles)) None initial_env  None ;
+    Includemod.compunit initial_env ~mark:Mark_both
+      "(obtained by packing)" sg mlifile dclsig
+  end else begin
+    (* Determine imports *)
+    let unit_names = List.map fst units in
+    let imports =
+      List.filter
+        (fun (name, _crc) -> not (List.mem name unit_names))
+        (Env.imports()) in
+    (* Write packaged signature *)
+    if not !Clflags.dont_write_files then begin
+      let cmi =
+        Env.save_signature_with_imports ~alerts:Misc.String.Map.empty
+          sg modulename
+          (prefix ^ ".cmi") imports
+      in
+      Cmt_format.save_cmt (prefix ^ ".cmt")  modulename
+        (Cmt_format.Packed (cmi.Cmi_format.cmi_sign, objfiles)) None initial_env
+        (Some cmi)
+    end;
+    Tcoerce_none
+  end
+
+
+(* Error report *)
+
+
+open Printtyp
+
+let report_error ~loc _env = function
+    Cannot_apply mty ->
+      Location.errorf ~loc
+        "@[This module is not a functor; it has type@ %a@]" modtype mty
+  | Not_included errs ->
+      let main = Includemod_errorprinter.err_msgs errs in
+      Location.errorf ~loc "@[<v>Signature mismatch:@ %t@]" main
+  | Cannot_eliminate_dependency mty ->
+      Location.errorf ~loc
+        "@[This functor has type@ %a@ \
+           The parameter cannot be eliminated in the result type.@ \
+           Please bind the argument to a module identifier.@]" modtype mty
+  | Signature_expected ->
+      Location.errorf ~loc "This module type is not a signature"
+  | Structure_expected mty ->
+      Location.errorf ~loc
+        "@[This module is not a structure; it has type@ %a" modtype mty
+  | With_no_component lid ->
+      Location.errorf ~loc
+        "@[The signature constrained by `with' has no component named %a@]"
+        longident lid
+  | With_mismatch(lid, explanation) ->
+      let main = Includemod_errorprinter.err_msgs explanation in
+      Location.errorf ~loc
+        "@[<v>\
+           @[In this `with' constraint, the new definition of %a@ \
+             does not match its original definition@ \
+             in the constrained signature:@]@ \
+           %t@]"
+        longident lid main
+  | With_makes_applicative_functor_ill_typed(lid, path, explanation) ->
+      let main = Includemod_errorprinter.err_msgs explanation in
+      Location.errorf ~loc
+        "@[<v>\
+           @[This `with' constraint on %a makes the applicative functor @ \
+             type %s ill-typed in the constrained signature:@]@ \
+           %t@]"
+        longident lid (Path.name path) main
+  | With_changes_module_alias(lid, id, path) ->
+      Location.errorf ~loc
+        "@[<v>\
+           @[This `with' constraint on %a changes %s, which is aliased @ \
+             in the constrained signature (as %s)@].@]"
+        longident lid (Path.name path) (Ident.name id)
+  | With_cannot_remove_constrained_type ->
+      Location.errorf ~loc
+        "@[<v>Destructive substitutions are not supported for constrained @ \
+              types (other than when replacing a type constructor with @ \
+              a type constructor with the same arguments).@]"
+  | With_cannot_remove_packed_modtype (p,mty) ->
+      Location.errorf ~loc
+        "This `with' constraint@ %s := %a@ makes a packed module ill-formed."
+        (Path.name p) Printtyp.modtype mty
+  | Repeated_name(kind, name) ->
+      Location.errorf ~loc
+        "@[Multiple definition of the %s name %s.@ \
+         Names must be unique in a given structure or signature.@]"
+        (Sig_component_kind.to_string kind) name
+  | Non_generalizable typ ->
+      Location.errorf ~loc
+        "@[The type of this expression,@ %a,@ \
+           contains type variables that cannot be generalized@]" type_scheme typ
+  | Non_generalizable_class (id, desc) ->
+      Location.errorf ~loc
+        "@[The type of this class,@ %a,@ \
+           contains type variables that cannot be generalized@]"
+        (class_declaration id) desc
+  | Non_generalizable_module mty ->
+      Location.errorf ~loc
+        "@[The type of this module,@ %a,@ \
+           contains type variables that cannot be generalized@]" modtype mty
+  | Implementation_is_required intf_name ->
+      Location.errorf ~loc
+        "@[The interface %a@ declares values, not just types.@ \
+           An implementation must be provided.@]"
+        Location.print_filename intf_name
+  | Interface_not_compiled intf_name ->
+      Location.errorf ~loc
+        "@[Could not find the .cmi file for interface@ %a.@]"
+        Location.print_filename intf_name
+  | Not_allowed_in_functor_body ->
+      Location.errorf ~loc
+        "@[This expression creates fresh types.@ %s@]"
+        "It is not allowed inside applicative functors."
+  | Not_a_packed_module ty ->
+      Location.errorf ~loc
+        "This expression is not a packed module. It has type@ %a"
+        type_expr ty
+  | Incomplete_packed_module ty ->
+      Location.errorf ~loc
+        "The type of this packed module contains variables:@ %a"
+        type_expr ty
+  | Scoping_pack (lid, ty) ->
+      Location.errorf ~loc
+        "The type %a in this module cannot be exported.@ \
+        Its type contains local dependencies:@ %a" longident lid type_expr ty
+  | Recursive_module_require_explicit_type ->
+      Location.errorf ~loc "Recursive modules require an explicit module type."
+  | Apply_generative ->
+      Location.errorf ~loc
+        "This is a generative functor. It can only be applied to ()"
+  | Cannot_scrape_alias p ->
+      Location.errorf ~loc
+        "This is an alias for module %a, which is missing"
+        path p
+  | Cannot_scrape_package_type p ->
+      Location.errorf ~loc
+        "The type of this packed module refers to %a, which is missing"
+        path p
+  | Badly_formed_signature (context, err) ->
+      Location.errorf ~loc "@[In %s:@ %a@]" context Typedecl.report_error err
+  | Cannot_hide_id Illegal_shadowing
+      { shadowed_item_kind; shadowed_item_id; shadowed_item_loc;
+        shadower_id; user_id; user_kind; user_loc } ->
+      let shadowed_item_kind= Sig_component_kind.to_string shadowed_item_kind in
+      Location.errorf ~loc
+        "@[<v>Illegal shadowing of included %s %a by %a@ \
+         %a:@;<1 2>%s %a came from this include@ \
+         %a:@;<1 2>The %s %s has no valid type if %a is shadowed@]"
+        shadowed_item_kind Ident.print shadowed_item_id Ident.print shadower_id
+        Location.print_loc shadowed_item_loc
+        (String.capitalize_ascii shadowed_item_kind)
+        Ident.print shadowed_item_id
+        Location.print_loc user_loc
+        (Sig_component_kind.to_string user_kind) (Ident.name user_id)
+        Ident.print shadowed_item_id
+  | Cannot_hide_id Appears_in_signature
+      { opened_item_kind; opened_item_id; user_id; user_kind; user_loc } ->
+      let opened_item_kind= Sig_component_kind.to_string opened_item_kind in
+      Location.errorf ~loc
+        "@[<v>The %s %a introduced by this open appears in the signature@ \
+         %a:@;<1 2>The %s %s has no valid type if %a is hidden@]"
+        opened_item_kind Ident.print opened_item_id
+        Location.print_loc user_loc
+        (Sig_component_kind.to_string user_kind) (Ident.name user_id)
+        Ident.print opened_item_id
+  | Invalid_type_subst_rhs ->
+      Location.errorf ~loc "Only type synonyms are allowed on the right of :="
+  | Unpackable_local_modtype_subst p ->
+      Location.errorf ~loc
+        "The module type@ %s@ is not a valid type for a packed module:@ \
+         it is defined as a local substitution for a non-path module type."
+        (Path.name p)
+
+let report_error env ~loc err =
+  Printtyp.wrap_printing_env ~error:true env
+    (fun () -> report_error env ~loc err)
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, env, err) ->
+        Some (report_error ~loc env err)
+      | Error_forward err ->
+        Some err
+      | _ ->
+        None
+    )
diff --git a/src/ocaml/typing/typemod.mli b/src/ocaml/typing/typemod.mli
new file mode 100644
index 0000000..c254fe4
--- /dev/null
+++ b/src/ocaml/typing/typemod.mli
@@ -0,0 +1,150 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Type-checking of the module language and typed ast hooks
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Types
+
+module Signature_names : sig
+  type t
+
+  val simplify: Env.t -> t -> signature -> signature
+end
+
+val type_module:
+        Env.t -> Parsetree.module_expr -> Typedtree.module_expr
+val type_structure:
+  Env.t -> Parsetree.structure ->
+  Typedtree.structure * Types.signature * Signature_names.t * Env.t
+val type_toplevel_phrase:
+  Env.t -> Parsetree.structure ->
+  Typedtree.structure * Types.signature * (* Signature_names.t * *) Env.t
+val type_implementation:
+  string -> string -> string -> Env.t ->
+  Parsetree.structure -> Typedtree.implementation
+val type_interface:
+        Env.t -> Parsetree.signature -> Typedtree.signature
+val transl_signature:
+        Env.t -> Parsetree.signature -> Typedtree.signature
+val check_nongen_schemes:
+        Env.t -> Types.signature -> unit
+        (*
+val type_open_:
+        ?used_slot:bool ref -> ?toplevel:bool ->
+        Asttypes.override_flag ->
+        Env.t -> Location.t -> Longident.t Asttypes.loc -> Path.t * Env.t
+        *)
+val modtype_of_package:
+        Env.t -> Location.t ->
+        Path.t -> (Longident.t * type_expr) list -> module_type
+
+val path_of_module : Typedtree.module_expr -> Path.t option
+
+val save_signature:
+  string -> Typedtree.signature -> string -> string ->
+  Env.t -> Cmi_format.cmi_infos -> unit
+
+val package_units:
+  Env.t -> string list -> string -> string -> Typedtree.module_coercion
+
+(* Should be in Envaux, but it breaks the build of the debugger *)
+val initial_env:
+  loc:Location.t -> safe_string:bool ->
+  initially_opened_module:string option ->
+  open_implicit_modules:string list -> Env.t
+
+module Sig_component_kind : sig
+  type t =
+    | Value
+    | Type
+    | Module
+    | Module_type
+    | Extension_constructor
+    | Class
+    | Class_type
+
+  val to_string : t -> string
+end
+
+type hiding_error =
+  | Illegal_shadowing of {
+      shadowed_item_id: Ident.t;
+      shadowed_item_kind: Sig_component_kind.t;
+      shadowed_item_loc: Location.t;
+      shadower_id: Ident.t;
+      user_id: Ident.t;
+      user_kind: Sig_component_kind.t;
+      user_loc: Location.t;
+    }
+  | Appears_in_signature of {
+      opened_item_id: Ident.t;
+      opened_item_kind: Sig_component_kind.t;
+      user_id: Ident.t;
+      user_kind: Sig_component_kind.t;
+      user_loc: Location.t;
+    }
+
+type error =
+    Cannot_apply of module_type
+  | Not_included of Includemod.explanation
+  | Cannot_eliminate_dependency of module_type
+  | Signature_expected
+  | Structure_expected of module_type
+  | With_no_component of Longident.t
+  | With_mismatch of Longident.t * Includemod.explanation
+  | With_makes_applicative_functor_ill_typed of
+      Longident.t * Path.t * Includemod.explanation
+  | With_changes_module_alias of Longident.t * Ident.t * Path.t
+  | With_cannot_remove_constrained_type
+  | Repeated_name of Sig_component_kind.t * string
+  | Non_generalizable of type_expr
+  | Non_generalizable_class of Ident.t * class_declaration
+  | Non_generalizable_module of module_type
+  | Implementation_is_required of string
+  | Interface_not_compiled of string
+  | Not_allowed_in_functor_body
+  | Not_a_packed_module of type_expr
+  | Incomplete_packed_module of type_expr
+  | Scoping_pack of Longident.t * type_expr
+  | Recursive_module_require_explicit_type
+  | Apply_generative
+  | Cannot_scrape_alias of Path.t
+  | Cannot_scrape_package_type of Path.t
+  | Badly_formed_signature of string * Typedecl.error
+  | Cannot_hide_id of hiding_error
+  | Invalid_type_subst_rhs
+  | Unpackable_local_modtype_subst of Path.t
+  | With_cannot_remove_packed_modtype of Path.t * module_type
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+val report_error: Env.t -> loc:Location.t -> error -> Location.error
+
+(* merlin *)
+
+val normalize_signature : Types.signature -> unit
+
+val merlin_type_structure:
+  Env.t -> Parsetree.structure ->
+  Typedtree.structure * Types.signature * (* Signature_names.t * *) Env.t
+
+val merlin_transl_signature:
+  Env.t -> Parsetree.signature -> Typedtree.signature
diff --git a/src/ocaml/typing/typeopt.ml b/src/ocaml/typing/typeopt.ml
new file mode 100644
index 0000000..281b574
--- /dev/null
+++ b/src/ocaml/typing/typeopt.ml
@@ -0,0 +1,141 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Auxiliaries for type-based optimizations, e.g. array kinds *)
+
+open Types
+open Asttypes
+open Typedtree
+
+let scrape_ty env ty =
+  let ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in
+  match ty.desc with
+  | Tconstr (p, _, _) ->
+      begin match Env.find_type p env with
+      | {type_kind = ( Type_variant (_, Variant_unboxed)
+                     | Type_record (_, Record_unboxed _) ); _} ->
+        begin match Typedecl.get_unboxed_type_representation env ty with
+        | None -> ty
+        | Some ty2 -> ty2
+        end
+      | _ -> ty
+      | exception Not_found -> ty
+      end
+  | _ -> ty
+
+let scrape env ty =
+  (scrape_ty env ty).desc
+
+let is_function_type env ty =
+  match scrape env ty with
+  | Tarrow (_, lhs, rhs, _) -> Some (lhs, rhs)
+  | _ -> None
+
+let is_base_type env ty base_ty_path =
+  match scrape env ty with
+  | Tconstr(p, _, _) -> Path.same p base_ty_path
+  | _ -> false
+
+(*
+let maybe_pointer_type env ty =
+  let ty = scrape_ty env ty in
+  if Ctype.maybe_pointer_type env ty then
+    Pointer
+  else
+    Immediate
+*)
+
+(* let maybe_pointer exp = maybe_pointer_type exp.exp_env exp.exp_type *)
+
+type classification =
+  | Int
+  | Float
+  | Lazy
+  | Addr  (* anything except a float or a lazy *)
+  | Any
+
+let classify env ty =
+  let ty = scrape_ty env ty in
+  if not (Ctype.maybe_pointer_type env ty) then Int
+  else match ty.desc with
+  | Tvar _ | Tunivar _ ->
+      Any
+  | Tconstr (p, _args, _abbrev) ->
+      if Path.same p Predef.path_float then Float
+      else if Path.same p Predef.path_lazy_t then Lazy
+      else if Path.same p Predef.path_string
+           || Path.same p Predef.path_bytes
+           || Path.same p Predef.path_array
+           || Path.same p Predef.path_nativeint
+           || Path.same p Predef.path_int32
+           || Path.same p Predef.path_int64 then Addr
+      else begin
+        try
+          match (Env.find_type p env).type_kind with
+          | Type_abstract ->
+              Any
+          | Type_record _ | Type_variant _ | Type_open ->
+              Addr
+        with Not_found ->
+          (* This can happen due to e.g. missing -I options,
+             causing some .cmi files to be unavailable.
+             Maybe we should emit a warning. *)
+          Any
+      end
+  | Tarrow _ | Ttuple _ | Tpackage _ | Tobject _ | Tnil | Tvariant _ ->
+      Addr
+  | Tlink _ | Tsubst _ | Tpoly _ | Tfield _ ->
+      assert false
+
+(*
+let function_return_value_kind env ty =
+  match is_function_type env ty with
+  | Some (_lhs, rhs) -> value_kind env rhs
+  | None -> Pgenval
+*)
+
+(** Whether a forward block is needed for a lazy thunk on a value, i.e.
+    if the value can be represented as a float/forward/lazy *)
+let lazy_val_requires_forward env ty =
+  match classify env ty with
+  | Any | Lazy -> true
+  | Float -> false (* TODO: Config.flat_float_array *)
+  | Addr | Int -> false
+
+(** The compilation of the expression [lazy e] depends on the form of e:
+    constants, floats and identifiers are optimized.  The optimization must be
+    taken into account when determining whether a recursive binding is safe. *)
+let classify_lazy_argument : Typedtree.expression ->
+                             [`Constant_or_function
+                             |`Float_that_cannot_be_shortcut
+                             |`Identifier of [`Forward_value|`Other]
+                             |`Other] =
+  fun e -> match e.exp_desc with
+    | Texp_constant
+        ( Const_int _ | Const_char _ | Const_string _
+        | Const_int32 _ | Const_int64 _ | Const_nativeint _ )
+    | Texp_function _
+    | Texp_construct (_, {cstr_arity = 0}, _) ->
+       `Constant_or_function
+    | Texp_constant(Const_float _) ->
+      (* TODO: handle flat float array, either at configure time or from the
+         .merlin. *)
+       `Constant_or_function
+    | Texp_ident _ when lazy_val_requires_forward e.exp_env e.exp_type ->
+       `Identifier `Forward_value
+    | Texp_ident _ ->
+       `Identifier `Other
+    | _ ->
+       `Other
diff --git a/src/ocaml/typing/typeopt.mli b/src/ocaml/typing/typeopt.mli
new file mode 100644
index 0000000..e3d4c79
--- /dev/null
+++ b/src/ocaml/typing/typeopt.mli
@@ -0,0 +1,26 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Auxiliaries for type-based optimizations, e.g. array kinds *)
+
+val is_function_type :
+      Env.t -> Types.type_expr -> (Types.type_expr * Types.type_expr) option
+val is_base_type : Env.t -> Types.type_expr -> Path.t -> bool
+
+val classify_lazy_argument : Typedtree.expression ->
+                             [ `Constant_or_function
+                             | `Float_that_cannot_be_shortcut
+                             | `Identifier of [`Forward_value | `Other]
+                             | `Other]
diff --git a/src/ocaml/typing/types.ml b/src/ocaml/typing/types.ml
new file mode 100644
index 0000000..bd51b32
--- /dev/null
+++ b/src/ocaml/typing/types.ml
@@ -0,0 +1,486 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Representation of types and declarations *)
+
+open Asttypes
+
+(* Type expressions for the core language *)
+
+type type_expr =
+  { mutable desc: type_desc;
+    mutable level: int;
+    mutable scope: int;
+    id: int }
+
+and type_desc =
+    Tvar of string option
+  | Tarrow of arg_label * type_expr * type_expr * commutable
+  | Ttuple of type_expr list
+  | Tconstr of Path.t * type_expr list * abbrev_memo ref
+  | Tobject of type_expr * (Path.t * type_expr list) option ref
+  | Tfield of string * field_kind * type_expr * type_expr
+  | Tnil
+  | Tlink of type_expr
+  | Tsubst of type_expr * type_expr option
+  | Tvariant of row_desc
+  | Tunivar of string option
+  | Tpoly of type_expr * type_expr list
+  | Tpackage of Path.t * (Longident.t * type_expr) list
+
+and row_desc =
+    { row_fields: (label * row_field) list;
+      row_more: type_expr;
+      row_bound: unit;
+      row_closed: bool;
+      row_fixed: fixed_explanation option;
+      row_name: (Path.t * type_expr list) option }
+and fixed_explanation =
+  | Univar of type_expr | Fixed_private | Reified of Path.t | Rigid
+and row_field =
+    Rpresent of type_expr option
+  | Reither of bool * type_expr list * bool * row_field option ref
+        (* 1st true denotes a constant constructor *)
+        (* 2nd true denotes a tag in a pattern matching, and
+           is erased later *)
+  | Rabsent
+
+and abbrev_memo =
+    Mnil
+  | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo
+  | Mlink of abbrev_memo ref
+
+and field_kind =
+    Fvar of field_kind option ref
+  | Fpresent
+  | Fabsent
+
+and commutable =
+    Cok
+  | Cunknown
+  | Clink of commutable ref
+
+module TypeOps = struct
+  type t = type_expr
+  let compare t1 t2 = t1.id - t2.id
+  let hash t = t.id
+  let equal t1 t2 = t1 == t2
+end
+
+module Private_type_expr = struct
+  let create desc ~level ~scope ~id = {desc; level; scope; id}
+  let set_desc ty d = ty.desc <- d
+  let set_level ty lv = ty.level <- lv
+  let set_scope ty sc = ty.scope <- sc
+end
+(* *)
+
+module Uid = struct
+  type t =
+    | Compilation_unit of string
+    | Item of { comp_unit: string; id: int }
+    | Internal
+    | Predef of string
+
+  include Identifiable.Make(struct
+    type nonrec t = t
+
+    let equal (x : t) y = x = y
+    let compare (x : t) y = compare x y
+    let hash (x : t) = Hashtbl.hash x
+
+    let print fmt = function
+      | Internal -> Format.pp_print_string fmt "<internal>"
+      | Predef name -> Format.fprintf fmt "<predef:%s>" name
+      | Compilation_unit s -> Format.pp_print_string fmt s
+      | Item { comp_unit; id } -> Format.fprintf fmt "%s.%d" comp_unit id
+
+    let output oc t =
+      let fmt = Format.formatter_of_out_channel oc in
+      print fmt t
+  end)
+
+  let id = ref (-1)
+
+  let reinit () = id := (-1)
+
+  let mk  ~current_unit =
+      incr id;
+      Item { comp_unit = current_unit; id = !id }
+
+  let of_compilation_unit_id id =
+    if not (Ident.persistent id) then
+      Misc.fatal_errorf "Types.Uid.of_compilation_unit_id %S" (Ident.name id);
+    Compilation_unit (Ident.name id)
+
+  let of_predef_id id =
+    if not (Ident.is_predef id) then
+      Misc.fatal_errorf "Types.Uid.of_predef_id %S" (Ident.name id);
+    Predef (Ident.name id)
+
+  let internal_not_actually_unique = Internal
+
+  let for_actual_declaration = function
+    | Item _ -> true
+    | _ -> false
+end
+
+(* Maps of methods and instance variables *)
+
+module Meths = Misc.String.Map
+module Vars = Meths
+
+(* Value descriptions *)
+
+type value_description =
+  { val_type: type_expr;                (* Type of the value *)
+    val_kind: value_kind;
+    val_loc: Location.t;
+    val_attributes: Parsetree.attributes;
+    val_uid: Uid.t;
+  }
+
+and value_kind =
+    Val_reg                             (* Regular value *)
+  | Val_prim of Primitive.description   (* Primitive *)
+  | Val_ivar of mutable_flag * string   (* Instance variable (mutable ?) *)
+  | Val_self of (Ident.t * type_expr) Meths.t ref *
+                (Ident.t * Asttypes.mutable_flag *
+                 Asttypes.virtual_flag * type_expr) Vars.t ref *
+                string * type_expr
+                                        (* Self *)
+  | Val_anc of (string * Ident.t) list * string
+                                        (* Ancestor *)
+
+(* Variance *)
+
+module Variance = struct
+  type t = int
+  type f = May_pos | May_neg | May_weak | Inj | Pos | Neg | Inv
+  let single = function
+    | May_pos -> 1
+    | May_neg -> 2
+    | May_weak -> 4
+    | Inj -> 8
+    | Pos -> 16
+    | Neg -> 32
+    | Inv -> 64
+  let union v1 v2 = v1 lor v2
+  let inter v1 v2 = v1 land v2
+  let subset v1 v2 = (v1 land v2 = v1)
+  let eq (v1 : t) v2 = (v1 = v2)
+  let set x b v =
+    if b then v lor single x else  v land (lnot (single x))
+  let mem x = subset (single x)
+  let null = 0
+  let unknown = 7
+  let full = 127
+  let covariant = single May_pos lor single Pos lor single Inj
+  let swap f1 f2 v =
+    let v' = set f1 (mem f2 v) v in set f2 (mem f1 v) v'
+  let conjugate v = swap May_pos May_neg (swap Pos Neg v)
+  let get_upper v = (mem May_pos v, mem May_neg v)
+  let get_lower v = (mem Pos v, mem Neg v, mem Inv v, mem Inj v)
+  let unknown_signature ~injective ~arity =
+    let v = if injective then set Inj true unknown else unknown in
+    Misc.replicate_list v arity
+end
+
+module Separability = struct
+  type t = Ind | Sep | Deepsep
+  type signature = t list
+  let eq (m1 : t) m2 = (m1 = m2)
+  let rank = function
+    | Ind -> 0
+    | Sep -> 1
+    | Deepsep -> 2
+  let compare m1 m2 = compare (rank m1) (rank m2)
+  let max m1 m2 = if rank m1 >= rank m2 then m1 else m2
+
+  let print ppf = function
+    | Ind -> Format.fprintf ppf "Ind"
+    | Sep -> Format.fprintf ppf "Sep"
+    | Deepsep -> Format.fprintf ppf "Deepsep"
+
+  let print_signature ppf modes =
+    let pp_sep ppf () = Format.fprintf ppf ",@," in
+    Format.fprintf ppf "@[(%a)@]"
+      (Format.pp_print_list ~pp_sep print) modes
+
+  let default_signature ~arity =
+    let default_mode = if Config.flat_float_array then Deepsep else Ind in
+    Misc.replicate_list default_mode arity
+end
+
+(* Type definitions *)
+
+type type_declaration =
+  { type_params: type_expr list;
+    type_arity: int;
+    type_kind: type_decl_kind;
+    type_private: private_flag;
+    type_manifest: type_expr option;
+    type_variance: Variance.t list;
+    type_separability: Separability.t list;
+    type_is_newtype: bool;
+    type_expansion_scope: int;
+    type_loc: Location.t;
+    type_attributes: Parsetree.attributes;
+    type_immediate: Type_immediacy.t;
+    type_unboxed_default: bool;
+    type_uid: Uid.t;
+ }
+
+and type_decl_kind = (label_declaration, constructor_declaration) type_kind
+
+and ('lbl, 'cstr) type_kind =
+    Type_abstract
+  | Type_record of 'lbl list * record_representation
+  | Type_variant of 'cstr list * variant_representation
+  | Type_open
+
+and record_representation =
+    Record_regular                      (* All fields are boxed / tagged *)
+  | Record_float                        (* All fields are floats *)
+  | Record_unboxed of bool    (* Unboxed single-field record, inlined or not *)
+  | Record_inlined of int               (* Inlined record *)
+  | Record_extension of Path.t          (* Inlined record under extension *)
+
+and variant_representation =
+    Variant_regular          (* Constant or boxed constructors *)
+  | Variant_unboxed          (* One unboxed single-field constructor *)
+
+and label_declaration =
+  {
+    ld_id: Ident.t;
+    ld_mutable: mutable_flag;
+    ld_type: type_expr;
+    ld_loc: Location.t;
+    ld_attributes: Parsetree.attributes;
+    ld_uid: Uid.t;
+  }
+
+and constructor_declaration =
+  {
+    cd_id: Ident.t;
+    cd_args: constructor_arguments;
+    cd_res: type_expr option;
+    cd_loc: Location.t;
+    cd_attributes: Parsetree.attributes;
+    cd_uid: Uid.t;
+  }
+
+and constructor_arguments =
+  | Cstr_tuple of type_expr list
+  | Cstr_record of label_declaration list
+
+type extension_constructor =
+  { ext_type_path: Path.t;
+    ext_type_params: type_expr list;
+    ext_args: constructor_arguments;
+    ext_ret_type: type_expr option;
+    ext_private: private_flag;
+    ext_loc: Location.t;
+    ext_attributes: Parsetree.attributes;
+    ext_uid: Uid.t;
+  }
+
+and type_transparence =
+    Type_public      (* unrestricted expansion *)
+  | Type_new         (* "new" type *)
+  | Type_private     (* private type *)
+
+(* Type expressions for the class language *)
+
+module Concr = Misc.String.Set
+
+type class_type =
+    Cty_constr of Path.t * type_expr list * class_type
+  | Cty_signature of class_signature
+  | Cty_arrow of arg_label * type_expr * class_type
+
+and class_signature =
+  { csig_self: type_expr;
+    csig_vars:
+      (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
+    csig_concr: Concr.t;
+    csig_inher: (Path.t * type_expr list) list }
+
+type class_declaration =
+  { cty_params: type_expr list;
+    mutable cty_type: class_type;
+    cty_path: Path.t;
+    cty_new: type_expr option;
+    cty_variance: Variance.t list;
+    cty_loc: Location.t;
+    cty_attributes: Parsetree.attributes;
+    cty_uid: Uid.t;
+ }
+
+type class_type_declaration =
+  { clty_params: type_expr list;
+    clty_type: class_type;
+    clty_path: Path.t;
+    clty_variance: Variance.t list;
+    clty_loc: Location.t;
+    clty_attributes: Parsetree.attributes;
+    clty_uid: Uid.t;
+  }
+
+(* Type expressions for the module language *)
+
+type visibility =
+  | Exported
+  | Hidden
+
+type module_type =
+    Mty_ident of Path.t
+  | Mty_signature of signature
+  | Mty_functor of functor_parameter * module_type
+  | Mty_alias of Path.t
+  | Mty_for_hole
+
+and functor_parameter =
+  | Unit
+  | Named of Ident.t option * module_type
+
+and module_presence =
+  | Mp_present
+  | Mp_absent
+
+and signature = signature_item list
+
+and signature_item =
+    Sig_value of Ident.t * value_description * visibility
+  | Sig_type of Ident.t * type_declaration * rec_status * visibility
+  | Sig_typext of Ident.t * extension_constructor * ext_status * visibility
+  | Sig_module of
+      Ident.t * module_presence * module_declaration * rec_status * visibility
+  | Sig_modtype of Ident.t * modtype_declaration * visibility
+  | Sig_class of Ident.t * class_declaration * rec_status * visibility
+  | Sig_class_type of Ident.t * class_type_declaration * rec_status * visibility
+
+and module_declaration =
+  {
+    md_type: module_type;
+    md_attributes: Parsetree.attributes;
+    md_loc: Location.t;
+    md_uid: Uid.t;
+  }
+
+and modtype_declaration =
+  {
+    mtd_type: module_type option;  (* Note: abstract *)
+    mtd_attributes: Parsetree.attributes;
+    mtd_loc: Location.t;
+    mtd_uid: Uid.t;
+  }
+
+and rec_status =
+    Trec_not                   (* first in a nonrecursive group *)
+  | Trec_first                 (* first in a recursive group *)
+  | Trec_next                  (* not first in a recursive/nonrecursive group *)
+
+and ext_status =
+    Text_first                     (* first constructor of an extension *)
+  | Text_next                      (* not first constructor of an extension *)
+  | Text_exception                 (* an exception *)
+
+
+(* Constructor and record label descriptions inserted held in typing
+   environments *)
+
+type constructor_description =
+  { cstr_name: string;                  (* Constructor name *)
+    cstr_res: type_expr;                (* Type of the result *)
+    cstr_existentials: type_expr list;  (* list of existentials *)
+    cstr_args: type_expr list;          (* Type of the arguments *)
+    cstr_arity: int;                    (* Number of arguments *)
+    cstr_tag: constructor_tag;          (* Tag for heap blocks *)
+    cstr_consts: int;                   (* Number of constant constructors *)
+    cstr_nonconsts: int;                (* Number of non-const constructors *)
+    cstr_normal: int;                   (* Number of non generalized constrs *)
+    cstr_generalized: bool;             (* Constrained return type? *)
+    cstr_private: private_flag;         (* Read-only constructor? *)
+    cstr_loc: Location.t;
+    cstr_attributes: Parsetree.attributes;
+    cstr_inlined: type_declaration option;
+    cstr_uid: Uid.t;
+   }
+
+and constructor_tag =
+    Cstr_constant of int                (* Constant constructor (an int) *)
+  | Cstr_block of int                   (* Regular constructor (a block) *)
+  | Cstr_unboxed                        (* Constructor of an unboxed type *)
+  | Cstr_extension of Path.t * bool     (* Extension constructor
+                                           true if a constant false if a block*)
+
+let equal_tag t1 t2 =
+  match (t1, t2) with
+  | Cstr_constant i1, Cstr_constant i2 -> i2 = i1
+  | Cstr_block i1, Cstr_block i2 -> i2 = i1
+  | Cstr_unboxed, Cstr_unboxed -> true
+  | Cstr_extension (path1, b1), Cstr_extension (path2, b2) ->
+      Path.same path1 path2 && b1 = b2
+  | (Cstr_constant _|Cstr_block _|Cstr_unboxed|Cstr_extension _), _ -> false
+
+let may_equal_constr c1 c2 =
+  c1.cstr_arity = c2.cstr_arity
+  && (match c1.cstr_tag,c2.cstr_tag with
+     | Cstr_extension _,Cstr_extension _ ->
+         (* extension constructors may be rebindings of each other *)
+         true
+     | tag1, tag2 ->
+         equal_tag tag1 tag2)
+
+type label_description =
+  { lbl_name: string;                   (* Short name *)
+    lbl_res: type_expr;                 (* Type of the result *)
+    lbl_arg: type_expr;                 (* Type of the argument *)
+    lbl_mut: mutable_flag;              (* Is this a mutable field? *)
+    lbl_pos: int;                       (* Position in block *)
+    lbl_all: label_description array;   (* All the labels in this type *)
+    lbl_repres: record_representation;  (* Representation for this record *)
+    lbl_private: private_flag;          (* Read-only field? *)
+    lbl_loc: Location.t;
+    lbl_attributes: Parsetree.attributes;
+    lbl_uid: Uid.t;
+   }
+
+let rec bound_value_identifiers = function
+    [] -> []
+  | Sig_value(id, {val_kind = Val_reg}, _) :: rem ->
+      id :: bound_value_identifiers rem
+  | Sig_typext(id, _, _, _) :: rem -> id :: bound_value_identifiers rem
+  | Sig_module(id, Mp_present, _, _, _) :: rem ->
+      id :: bound_value_identifiers rem
+  | Sig_class(id, _, _, _) :: rem -> id :: bound_value_identifiers rem
+  | _ :: rem -> bound_value_identifiers rem
+
+let signature_item_id = function
+  | Sig_value (id, _, _)
+  | Sig_type (id, _, _, _)
+  | Sig_typext (id, _, _, _)
+  | Sig_module (id, _, _, _, _)
+  | Sig_modtype (id, _, _)
+  | Sig_class (id, _, _, _)
+  | Sig_class_type (id, _, _, _)
+    -> id
+
+(* Merlin specific *)
+
+let unpack_functor = function
+  | Mty_functor (fp, mty) -> fp, mty
+  | _ -> invalid_arg "Types.unpack_functor (merlin)"
diff --git a/src/ocaml/typing/types.mli b/src/ocaml/typing/types.mli
new file mode 100644
index 0000000..da16787
--- /dev/null
+++ b/src/ocaml/typing/types.mli
@@ -0,0 +1,594 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** {0 Representation of types and declarations} *)
+
+(** [Types] defines the representation of types and declarations (that is, the
+    content of module signatures).
+
+    CMI files are made of marshalled types.
+*)
+
+(** Asttypes exposes basic definitions shared both by Parsetree and Types. *)
+open Asttypes
+
+(** Type expressions for the core language.
+
+    The [type_desc] variant defines all the possible type expressions one can
+    find in OCaml. [type_expr] wraps this with some annotations.
+
+    The [level] field tracks the level of polymorphism associated to a type,
+    guiding the generalization algorithm.
+    Put shortly, when referring to a type in a given environment, both the type
+    and the environment have a level. If the type has an higher level, then it
+    can be considered fully polymorphic (type variables will be printed as
+    ['a]), otherwise it'll be weakly polymorphic, or non generalized (type
+    variables printed as ['_a]).
+    See [http://okmij.org/ftp/ML/generalization.html] for more information.
+
+    Note about [type_declaration]: one should not make the confusion between
+    [type_expr] and [type_declaration].
+
+    [type_declaration] refers specifically to the [type] construct in OCaml
+    language, where you create and name a new type or type alias.
+
+    [type_expr] is used when you refer to existing types, e.g. when annotating
+    the expected type of a value.
+
+    Also, as the type system of OCaml is generative, a [type_declaration] can
+    have the side-effect of introducing a new type constructor, different from
+    all other known types.
+    Whereas [type_expr] is a pure construct which allows referring to existing
+    types.
+
+    Note on mutability: TBD.
+ *)
+type type_expr = private
+  { mutable desc: type_desc;
+    mutable level: int;
+    mutable scope: int;
+    id: int }
+
+and type_desc =
+  | Tvar of string option
+  (** [Tvar (Some "a")] ==> ['a] or ['_a]
+      [Tvar None]       ==> [_] *)
+
+  | Tarrow of arg_label * type_expr * type_expr * commutable
+  (** [Tarrow (Nolabel,      e1, e2, c)] ==> [e1    -> e2]
+      [Tarrow (Labelled "l", e1, e2, c)] ==> [l:e1  -> e2]
+      [Tarrow (Optional "l", e1, e2, c)] ==> [?l:e1 -> e2]
+
+      See [commutable] for the last argument. *)
+
+  | Ttuple of type_expr list
+  (** [Ttuple [t1;...;tn]] ==> [(t1 * ... * tn)] *)
+
+  | Tconstr of Path.t * type_expr list * abbrev_memo ref
+  (** [Tconstr (`A.B.t', [t1;...;tn], _)] ==> [(t1,...,tn) A.B.t]
+      The last parameter keep tracks of known expansions, see [abbrev_memo]. *)
+
+  | Tobject of type_expr * (Path.t * type_expr list) option ref
+  (** [Tobject (`f1:t1;...;fn: tn', `None')] ==> [< f1: t1; ...; fn: tn >]
+      f1, fn are represented as a linked list of types using Tfield and Tnil
+      constructors.
+
+      [Tobject (_, `Some (`A.ct', [t1;...;tn]')] ==> [(t1, ..., tn) A.ct].
+      where A.ct is the type of some class.
+
+      There are also special cases for so-called "class-types", cf. [Typeclass]
+      and [Ctype.set_object_name]:
+
+        [Tobject (Tfield(_,_,...(Tfield(_,_,rv)...),
+                         Some(`A.#ct`, [rv;t1;...;tn])]
+             ==> [(t1, ..., tn) #A.ct]
+        [Tobject (_, Some(`A.#ct`, [Tnil;t1;...;tn])] ==> [(t1, ..., tn) A.ct]
+
+      where [rv] is the hidden row variable.
+  *)
+
+  | Tfield of string * field_kind * type_expr * type_expr
+  (** [Tfield ("foo", Fpresent, t, ts)] ==> [<...; foo : t; ts>] *)
+
+  | Tnil
+  (** [Tnil] ==> [<...; >] *)
+
+  | Tlink of type_expr
+  (** Indirection used by unification engine. *)
+
+  | Tsubst of type_expr * type_expr option
+  (** [Tsubst] is used temporarily to store information in low-level
+      functions manipulating representation of types, such as
+      instantiation or copy.
+      The first argument contains a copy of the original node.
+      The second is available only when the first is the row variable of
+      a polymorphic variant.  It then contains a copy of the whole variant.
+      This constructor should not appear outside of these cases. *)
+
+  | Tvariant of row_desc
+  (** Representation of polymorphic variants, see [row_desc]. *)
+
+  | Tunivar of string option
+  (** Occurrence of a type variable introduced by a
+      forall quantifier / [Tpoly]. *)
+
+  | Tpoly of type_expr * type_expr list
+  (** [Tpoly (ty,tyl)] ==> ['a1... 'an. ty],
+      where 'a1 ... 'an are names given to types in tyl
+      and occurrences of those types in ty. *)
+
+  | Tpackage of Path.t * (Longident.t * type_expr) list
+  (** Type of a first-class module (a.k.a package). *)
+
+(** [  `X | `Y ]       (row_closed = true)
+    [< `X | `Y ]       (row_closed = true)
+    [> `X | `Y ]       (row_closed = false)
+    [< `X | `Y > `X ]  (row_closed = true)
+
+    type t = [> `X ] as 'a      (row_more = Tvar a)
+    type t = private [> `X ]    (row_more = Tconstr (t#row, [], ref Mnil))
+
+    And for:
+
+        let f = function `X -> `X -> | `Y -> `X
+
+    the type of "f" will be a [Tarrow] whose lhs will (basically) be:
+
+        Tvariant { row_fields = [("X", _)];
+                   row_more   =
+                     Tvariant { row_fields = [("Y", _)];
+                                row_more   =
+                                  Tvariant { row_fields = [];
+                                             row_more   = _;
+                                             _ };
+                                _ };
+                   _
+                 }
+
+*)
+and row_desc =
+    { row_fields: (label * row_field) list;
+      row_more: type_expr;
+      row_bound: unit; (* kept for compatibility *)
+      row_closed: bool;
+      row_fixed: fixed_explanation option;
+      row_name: (Path.t * type_expr list) option }
+and fixed_explanation =
+  | Univar of type_expr (** The row type was bound to an univar *)
+  | Fixed_private (** The row type is private *)
+  | Reified of Path.t (** The row was reified *)
+  | Rigid (** The row type was made rigid during constraint verification *)
+and row_field =
+    Rpresent of type_expr option
+  | Reither of bool * type_expr list * bool * row_field option ref
+        (* 1st true denotes a constant constructor *)
+        (* 2nd true denotes a tag in a pattern matching, and
+           is erased later *)
+  | Rabsent
+
+(** [abbrev_memo] allows one to keep track of different expansions of a type
+    alias. This is done for performance purposes.
+
+    For instance, when defining [type 'a pair = 'a * 'a], when one refers to an
+    ['a pair], it is just a shortcut for the ['a * 'a] type.
+    This expansion will be stored in the [abbrev_memo] of the corresponding
+    [Tconstr] node.
+
+    In practice, [abbrev_memo] behaves like list of expansions with a mutable
+    tail.
+
+    Note on marshalling: [abbrev_memo] must not appear in saved types.
+    [Btype], with [cleanup_abbrev] and [memo], takes care of tracking and
+    removing abbreviations.
+*)
+and abbrev_memo =
+  | Mnil (** No known abbreviation *)
+
+  | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo
+  (** Found one abbreviation.
+      A valid abbreviation should be at least as visible and reachable by the
+      same path.
+      The first expression is the abbreviation and the second the expansion. *)
+
+  | Mlink of abbrev_memo ref
+  (** Abbreviations can be found after this indirection *)
+
+and field_kind =
+    Fvar of field_kind option ref
+  | Fpresent
+  | Fabsent
+
+(** [commutable] is a flag appended to every arrow type.
+
+    When typing an application, if the type of the functional is
+    known, its type is instantiated with [Cok] arrows, otherwise as
+    [Clink (ref Cunknown)].
+
+    When the type is not known, the application will be used to infer
+    the actual type.  This is fragile in presence of labels where
+    there is no principal type.
+
+    Two incompatible applications relying on [Cunknown] arrows will
+    trigger an error.
+
+    let f g =
+      g ~a:() ~b:();
+      g ~b:() ~a:();
+
+    Error: This function is applied to arguments
+    in an order different from other calls.
+    This is only allowed when the real type is known.
+*)
+and commutable =
+    Cok
+  | Cunknown
+  | Clink of commutable ref
+
+module Private_type_expr : sig
+  val create : type_desc -> level: int -> scope: int -> id: int -> type_expr
+  val set_desc : type_expr -> type_desc -> unit
+  val set_level : type_expr -> int -> unit
+  val set_scope : type_expr -> int -> unit
+end
+
+module TypeOps : sig
+  type t = type_expr
+  val compare : t -> t -> int
+  val equal : t -> t -> bool
+  val hash : t -> int
+end
+
+(* *)
+
+module Uid : sig
+  type t
+
+  val reinit : unit -> unit
+
+  val mk : current_unit:string -> t
+  val of_compilation_unit_id : Ident.t -> t
+  val of_predef_id : Ident.t -> t
+  val internal_not_actually_unique : t
+
+  val for_actual_declaration : t -> bool
+
+  include Identifiable.S with type t := t
+end
+
+(* Maps of methods and instance variables *)
+
+module Meths : Map.S with type key = string
+module Vars  : Map.S with type key = string
+
+(* Value descriptions *)
+
+type value_description =
+  { val_type: type_expr;                (* Type of the value *)
+    val_kind: value_kind;
+    val_loc: Location.t;
+    val_attributes: Parsetree.attributes;
+    val_uid: Uid.t;
+  }
+
+and value_kind =
+    Val_reg                             (* Regular value *)
+  | Val_prim of Primitive.description   (* Primitive *)
+  | Val_ivar of mutable_flag * string   (* Instance variable (mutable ?) *)
+  | Val_self of (Ident.t * type_expr) Meths.t ref *
+                (Ident.t * mutable_flag * virtual_flag * type_expr) Vars.t ref *
+                string * type_expr
+                                        (* Self *)
+  | Val_anc of (string * Ident.t) list * string
+                                        (* Ancestor *)
+
+(* Variance *)
+
+module Variance : sig
+  type t
+  type f =
+      May_pos                (* allow positive occurrences *)
+    | May_neg                (* allow negative occurrences *)
+    | May_weak               (* allow occurrences under a negative position *)
+    | Inj                    (* type is injective in this parameter *)
+    | Pos                    (* there is a positive occurrence *)
+    | Neg                    (* there is a negative occurrence *)
+    | Inv                    (* both negative and positive occurrences *)
+  val null : t               (* no occurrence *)
+  val full : t               (* strictly invariant (all flags) *)
+  val covariant : t          (* strictly covariant (May_pos, Pos and Inj) *)
+  val unknown : t            (* allow everything, guarantee nothing *)
+  val union  : t -> t -> t
+  val inter  : t -> t -> t
+  val subset : t -> t -> bool
+  val eq : t -> t -> bool
+  val set : f -> bool -> t -> t
+  val mem : f -> t -> bool
+  val conjugate : t -> t                (* exchange positive and negative *)
+  val get_upper : t -> bool * bool                  (* may_pos, may_neg   *)
+  val get_lower : t -> bool * bool * bool * bool    (* pos, neg, inv, inj *)
+  val unknown_signature : injective:bool -> arity:int -> t list
+  (** The most pessimistic variance for a completely unknown type. *)
+end
+
+module Separability : sig
+  (** see {!Typedecl_separability} for an explanation of separability
+      and separability modes.*)
+
+  type t = Ind | Sep | Deepsep
+  val eq : t -> t -> bool
+  val print : Format.formatter -> t -> unit
+
+  val rank : t -> int
+  (** Modes are ordered from the least to the most demanding:
+      Ind < Sep < Deepsep.
+      'rank' maps them to integers in an order-respecting way:
+      m1 < m2  <=>  rank m1 < rank m2 *)
+
+  val compare : t -> t -> int
+  (** Compare two mode according to their mode ordering. *)
+
+  val max : t -> t -> t
+  (** [max_mode m1 m2] returns the most demanding mode. It is used to
+      express the conjunction of two parameter mode constraints. *)
+
+  type signature = t list
+  (** The 'separability signature' of a type assigns a mode for
+      each of its parameters. [('a, 'b) t] has mode [(m1, m2)] if
+      [(t1, t2) t] is separable whenever [t1, t2] have mode [m1, m2]. *)
+
+  val print_signature : Format.formatter -> signature -> unit
+
+  val default_signature : arity:int -> signature
+  (** The most pessimistic separability for a completely unknown type. *)
+end
+
+(* Type definitions *)
+
+type type_declaration =
+  { type_params: type_expr list;
+    type_arity: int;
+    type_kind: type_decl_kind;
+    type_private: private_flag;
+    type_manifest: type_expr option;
+    type_variance: Variance.t list;
+    (* covariant, contravariant, weakly contravariant, injective *)
+    type_separability: Separability.t list;
+    type_is_newtype: bool;
+    type_expansion_scope: int;
+    type_loc: Location.t;
+    type_attributes: Parsetree.attributes;
+    type_immediate: Type_immediacy.t;
+    type_unboxed_default: bool;
+    (* true if the unboxed-ness of this type was chosen by a compiler flag *)
+    type_uid: Uid.t;
+  }
+
+and type_decl_kind = (label_declaration, constructor_declaration) type_kind
+
+and ('lbl, 'cstr) type_kind =
+    Type_abstract
+  | Type_record of 'lbl list  * record_representation
+  | Type_variant of 'cstr list * variant_representation
+  | Type_open
+
+and record_representation =
+    Record_regular                      (* All fields are boxed / tagged *)
+  | Record_float                        (* All fields are floats *)
+  | Record_unboxed of bool    (* Unboxed single-field record, inlined or not *)
+  | Record_inlined of int               (* Inlined record *)
+  | Record_extension of Path.t          (* Inlined record under extension *)
+
+and variant_representation =
+    Variant_regular          (* Constant or boxed constructors *)
+  | Variant_unboxed          (* One unboxed single-field constructor *)
+
+and label_declaration =
+  {
+    ld_id: Ident.t;
+    ld_mutable: mutable_flag;
+    ld_type: type_expr;
+    ld_loc: Location.t;
+    ld_attributes: Parsetree.attributes;
+    ld_uid: Uid.t;
+  }
+
+and constructor_declaration =
+  {
+    cd_id: Ident.t;
+    cd_args: constructor_arguments;
+    cd_res: type_expr option;
+    cd_loc: Location.t;
+    cd_attributes: Parsetree.attributes;
+    cd_uid: Uid.t;
+  }
+
+and constructor_arguments =
+  | Cstr_tuple of type_expr list
+  | Cstr_record of label_declaration list
+
+type extension_constructor =
+  {
+    ext_type_path: Path.t;
+    ext_type_params: type_expr list;
+    ext_args: constructor_arguments;
+    ext_ret_type: type_expr option;
+    ext_private: private_flag;
+    ext_loc: Location.t;
+    ext_attributes: Parsetree.attributes;
+    ext_uid: Uid.t;
+  }
+
+and type_transparence =
+    Type_public      (* unrestricted expansion *)
+  | Type_new         (* "new" type *)
+  | Type_private     (* private type *)
+
+(* Type expressions for the class language *)
+
+module Concr : Set.S with type elt = string
+
+type class_type =
+    Cty_constr of Path.t * type_expr list * class_type
+  | Cty_signature of class_signature
+  | Cty_arrow of arg_label * type_expr * class_type
+
+and class_signature =
+  { csig_self: type_expr;
+    csig_vars:
+      (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
+    csig_concr: Concr.t;
+    csig_inher: (Path.t * type_expr list) list }
+
+type class_declaration =
+  { cty_params: type_expr list;
+    mutable cty_type: class_type;
+    cty_path: Path.t;
+    cty_new: type_expr option;
+    cty_variance: Variance.t list;
+    cty_loc: Location.t;
+    cty_attributes: Parsetree.attributes;
+    cty_uid: Uid.t;
+  }
+
+type class_type_declaration =
+  { clty_params: type_expr list;
+    clty_type: class_type;
+    clty_path: Path.t;
+    clty_variance: Variance.t list;
+    clty_loc: Location.t;
+    clty_attributes: Parsetree.attributes;
+    clty_uid: Uid.t;
+  }
+
+(* Type expressions for the module language *)
+
+type visibility =
+  | Exported
+  | Hidden
+
+type module_type =
+    Mty_ident of Path.t
+  | Mty_signature of signature
+  | Mty_functor of functor_parameter * module_type
+  | Mty_alias of Path.t
+  | Mty_for_hole
+
+and functor_parameter =
+  | Unit
+  | Named of Ident.t option * module_type
+
+and module_presence =
+  | Mp_present
+  | Mp_absent
+
+and signature = signature_item list
+
+and signature_item =
+    Sig_value of Ident.t * value_description * visibility
+  | Sig_type of Ident.t * type_declaration * rec_status * visibility
+  | Sig_typext of Ident.t * extension_constructor * ext_status * visibility
+  | Sig_module of
+      Ident.t * module_presence * module_declaration * rec_status * visibility
+  | Sig_modtype of Ident.t * modtype_declaration * visibility
+  | Sig_class of Ident.t * class_declaration * rec_status * visibility
+  | Sig_class_type of Ident.t * class_type_declaration * rec_status * visibility
+
+and module_declaration =
+  {
+    md_type: module_type;
+    md_attributes: Parsetree.attributes;
+    md_loc: Location.t;
+    md_uid: Uid.t;
+  }
+
+and modtype_declaration =
+  {
+    mtd_type: module_type option;  (* None: abstract *)
+    mtd_attributes: Parsetree.attributes;
+    mtd_loc: Location.t;
+    mtd_uid: Uid.t;
+  }
+
+and rec_status =
+    Trec_not                   (* first in a nonrecursive group *)
+  | Trec_first                 (* first in a recursive group *)
+  | Trec_next                  (* not first in a recursive/nonrecursive group *)
+
+and ext_status =
+    Text_first                     (* first constructor in an extension *)
+  | Text_next                      (* not first constructor in an extension *)
+  | Text_exception
+
+
+(* Constructor and record label descriptions inserted held in typing
+   environments *)
+
+type constructor_description =
+  { cstr_name: string;                  (* Constructor name *)
+    cstr_res: type_expr;                (* Type of the result *)
+    cstr_existentials: type_expr list;  (* list of existentials *)
+    cstr_args: type_expr list;          (* Type of the arguments *)
+    cstr_arity: int;                    (* Number of arguments *)
+    cstr_tag: constructor_tag;          (* Tag for heap blocks *)
+    cstr_consts: int;                   (* Number of constant constructors *)
+    cstr_nonconsts: int;                (* Number of non-const constructors *)
+    cstr_normal: int;                   (* Number of non generalized constrs *)
+    cstr_generalized: bool;             (* Constrained return type? *)
+    cstr_private: private_flag;         (* Read-only constructor? *)
+    cstr_loc: Location.t;
+    cstr_attributes: Parsetree.attributes;
+    cstr_inlined: type_declaration option;
+    cstr_uid: Uid.t;
+   }
+
+and constructor_tag =
+    Cstr_constant of int                (* Constant constructor (an int) *)
+  | Cstr_block of int                   (* Regular constructor (a block) *)
+  | Cstr_unboxed                        (* Constructor of an unboxed type *)
+  | Cstr_extension of Path.t * bool     (* Extension constructor
+                                           true if a constant false if a block*)
+
+(* Constructors are the same *)
+val equal_tag :  constructor_tag -> constructor_tag -> bool
+
+(* Constructors may be the same, given potential rebinding *)
+val may_equal_constr :
+    constructor_description ->  constructor_description -> bool
+
+type label_description =
+  { lbl_name: string;                   (* Short name *)
+    lbl_res: type_expr;                 (* Type of the result *)
+    lbl_arg: type_expr;                 (* Type of the argument *)
+    lbl_mut: mutable_flag;              (* Is this a mutable field? *)
+    lbl_pos: int;                       (* Position in block *)
+    lbl_all: label_description array;   (* All the labels in this type *)
+    lbl_repres: record_representation;  (* Representation for this record *)
+    lbl_private: private_flag;          (* Read-only field? *)
+    lbl_loc: Location.t;
+    lbl_attributes: Parsetree.attributes;
+    lbl_uid: Uid.t;
+  }
+
+(** Extracts the list of "value" identifiers bound by a signature.
+    "Value" identifiers are identifiers for signature components that
+    correspond to a run-time value: values, extensions, modules, classes.
+    Note: manifest primitives do not correspond to a run-time value! *)
+val bound_value_identifiers: signature -> Ident.t list
+
+val signature_item_id : signature_item -> Ident.t
+
+(* Merlin specific *)
+
+val unpack_functor : module_type -> functor_parameter * module_type
diff --git a/src/ocaml/typing/typetexp.ml b/src/ocaml/typing/typetexp.ml
new file mode 100644
index 0000000..eab6f1e
--- /dev/null
+++ b/src/ocaml/typing/typetexp.ml
@@ -0,0 +1,820 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* typetexp.ml,v 1.34.4.9 2002/01/07 08:39:16 garrigue Exp *)
+
+(* Typechecking of type expressions for the core language *)
+
+open Asttypes
+open Misc
+open Parsetree
+open Typedtree
+open Types
+open Ctype
+
+exception Already_bound
+
+type error =
+    Unbound_type_variable of string
+  | Undefined_type_constructor of Path.t
+  | Type_arity_mismatch of Longident.t * int * int
+  | Bound_type_variable of string
+  | Recursive_type
+  | Unbound_row_variable of Longident.t
+  | Type_mismatch of Errortrace.unification Errortrace.t
+  | Alias_type_mismatch of Errortrace.unification Errortrace.t
+  | Present_has_conjunction of string
+  | Present_has_no_type of string
+  | Constructor_mismatch of type_expr * type_expr
+  | Not_a_variant of type_expr
+  | Variant_tags of string * string
+  | Invalid_variable_name of string
+  | Cannot_quantify of string * type_expr
+  | Multiple_constraints_on_type of Longident.t
+  | Method_mismatch of string * type_expr * type_expr
+  | Opened_object of Path.t option
+  | Not_an_object of type_expr
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+(** Map indexed by type variable names. *)
+module TyVarMap = Misc.String.Map
+
+type variable_context = int * type_expr TyVarMap.t
+
+(* Support for first-class modules. *)
+
+let transl_modtype_longident = ref (fun _ -> assert false)
+let transl_modtype = ref (fun _ -> assert false)
+
+let create_package_mty fake loc env (p, l) =
+  let l =
+    List.sort
+      (fun (s1, _t1) (s2, _t2) ->
+         if s1.txt = s2.txt then
+           raise (Error (loc, env, Multiple_constraints_on_type s1.txt));
+         compare s1.txt s2.txt)
+      l
+  in
+  l,
+  List.fold_left
+    (fun mty (s, t) ->
+      let d = {ptype_name = mkloc (Longident.last s.txt) s.loc;
+               ptype_params = [];
+               ptype_cstrs = [];
+               ptype_kind = Ptype_abstract;
+               ptype_private = Asttypes.Public;
+               ptype_manifest = if fake then None else Some t;
+               ptype_attributes = [];
+               ptype_loc = loc} in
+      Ast_helper.Mty.mk ~loc
+        (Pmty_with (mty, [ Pwith_type ({ txt = s.txt; loc }, d) ]))
+    )
+    (Ast_helper.Mty.mk ~loc (Pmty_ident p))
+    l
+
+(* Translation of type expressions *)
+
+let type_variables = ref (TyVarMap.empty : type_expr TyVarMap.t)
+let univars        = ref ([] : (string * type_expr) list)
+let pre_univars    = ref ([] : type_expr list)
+let used_variables = ref (TyVarMap.empty : (type_expr * Location.t) TyVarMap.t)
+
+let reset_type_variables () =
+  reset_global_level ();
+  Ctype.reset_reified_var_counter ();
+  type_variables := TyVarMap.empty
+
+let narrow () =
+  (increase_global_level (), !type_variables)
+
+let widen (gl, tv) =
+  restore_global_level gl;
+  type_variables := tv
+
+let strict_ident c = (c = '_' || c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z')
+
+let validate_name = function
+    None -> None
+  | Some name as s ->
+      if name <> "" && strict_ident name.[0] then s else None
+
+let new_global_var ?name () =
+  new_global_var ?name:(validate_name name) ()
+let newvar ?name () =
+  newvar ?name:(validate_name name) ()
+
+let type_variable loc name =
+  try
+    TyVarMap.find name !type_variables
+  with Not_found ->
+    raise(Error(loc, Env.empty, Unbound_type_variable ("'" ^ name)))
+
+let valid_tyvar_name name =
+  name <> "" && name.[0] <> '_'
+
+let transl_type_param env styp =
+  let loc = styp.ptyp_loc in
+  match styp.ptyp_desc with
+    Ptyp_any ->
+      let ty = new_global_var ~name:"_" () in
+        { ctyp_desc = Ttyp_any; ctyp_type = ty; ctyp_env = env;
+          ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; }
+  | Ptyp_var name ->
+      let ty =
+        try
+          if not (valid_tyvar_name name) then
+            raise (Error (loc, Env.empty, Invalid_variable_name ("'" ^ name)));
+          ignore (TyVarMap.find name !type_variables);
+          raise Already_bound
+        with Not_found ->
+          let v = new_global_var ~name () in
+            type_variables := TyVarMap.add name v !type_variables;
+            v
+      in
+        { ctyp_desc = Ttyp_var name; ctyp_type = ty; ctyp_env = env;
+          ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; }
+  | _ -> assert false
+
+let transl_type_param env styp =
+  (* Currently useless, since type parameters cannot hold attributes
+     (but this could easily be lifted in the future). *)
+  Builtin_attributes.warning_scope styp.ptyp_attributes
+    (fun () -> transl_type_param env styp)
+
+
+let new_pre_univar ?name () =
+  let v = newvar ?name () in pre_univars := v :: !pre_univars; v
+
+type policy = Fixed | Extensible | Univars
+
+let rec transl_type env policy styp =
+  Msupport.with_saved_types
+    ~warning_attribute:styp.ptyp_attributes ?save_part:None
+    (fun () -> 
+       try
+         transl_type_aux env policy styp
+       with exn ->
+         Msupport.raise_error exn;
+           { ctyp_desc = Ttyp_any;
+             ctyp_type = new_global_var ();
+             ctyp_env = env;
+             ctyp_loc = styp.ptyp_loc;
+             ctyp_attributes = [];
+           }
+    )
+
+and transl_type_aux env policy styp =
+  let loc = styp.ptyp_loc in
+  let ctyp ctyp_desc ctyp_type =
+    { ctyp_desc; ctyp_type; ctyp_env = env;
+      ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes }
+  in
+  match styp.ptyp_desc with
+    Ptyp_any ->
+      let ty =
+        if policy = Univars then new_pre_univar () else
+          if policy = Fixed then
+            raise (Error (styp.ptyp_loc, env, Unbound_type_variable "_"))
+          else newvar ()
+      in
+      ctyp Ttyp_any ty
+  | Ptyp_var name ->
+    let ty =
+      if not (valid_tyvar_name name) then
+        raise (Error (styp.ptyp_loc, env, Invalid_variable_name ("'" ^ name)));
+      begin try
+        instance (List.assoc name !univars)
+      with Not_found -> try
+        instance (fst (TyVarMap.find name !used_variables))
+      with Not_found ->
+        let v =
+          if policy = Univars then new_pre_univar ~name () else newvar ~name ()
+        in
+        used_variables := TyVarMap.add name (v, styp.ptyp_loc) !used_variables;
+        v
+      end
+    in
+    ctyp (Ttyp_var name) ty
+  | Ptyp_arrow(l, st1, st2) ->
+    let cty1 = transl_type env policy st1 in
+    let cty2 = transl_type env policy st2 in
+    let ty1 = cty1.ctyp_type in
+    let ty1 =
+      if Btype.is_optional l
+      then newty (Tconstr(Predef.path_option,[ty1], ref Mnil))
+      else ty1 in
+    let ty = newty (Tarrow(l, ty1, cty2.ctyp_type, Cok)) in
+    ctyp (Ttyp_arrow (l, cty1, cty2)) ty
+  | Ptyp_tuple stl ->
+    assert (List.length stl >= 2);
+    let ctys = List.map (transl_type env policy) stl in
+    let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in
+    ctyp (Ttyp_tuple ctys) ty
+  | Ptyp_constr(lid, stl) ->
+      let (path, decl) = Env.lookup_type ~loc:lid.loc lid.txt env in
+      let stl =
+        match stl with
+        | [ {ptyp_desc=Ptyp_any} as t ] when decl.type_arity > 1 ->
+            List.map (fun _ -> t) decl.type_params
+        | _ -> stl
+      in
+      if List.length stl <> decl.type_arity then
+        raise(Error(styp.ptyp_loc, env,
+                    Type_arity_mismatch(lid.txt, decl.type_arity,
+                                        List.length stl)));
+      let args = List.map (transl_type env policy) stl in
+      let params = instance_list decl.type_params in
+      let unify_param =
+        match decl.type_manifest with
+          None -> unify_var
+        | Some ty ->
+            if (repr ty).level = Btype.generic_level then unify_var else unify
+      in
+      List.iter2
+        (fun (sty, cty) ty' ->
+           try unify_param env ty' cty.ctyp_type with Unify trace ->
+             let trace = Errortrace.swap_trace trace in
+             raise (Error(sty.ptyp_loc, env, Type_mismatch trace))
+        )
+        (List.combine stl args) params;
+      let constr =
+        newconstr path (List.map (fun ctyp -> ctyp.ctyp_type) args) in
+      ctyp (Ttyp_constr (path, lid, args)) constr
+  | Ptyp_object (fields, o) ->
+      let ty, fields = transl_fields env policy o fields in
+      ctyp (Ttyp_object (fields, o)) (newobj ty)
+  | Ptyp_class(lid, stl) ->
+      let (path, decl, _is_variant) =
+        try
+          let path, decl = Env.find_type_by_name lid.txt env in
+          let rec check decl =
+            match decl.type_manifest with
+              None -> raise Not_found
+            | Some ty ->
+                match (repr ty).desc with
+                  Tvariant row when Btype.static_row row -> ()
+                | Tconstr (path, _, _) ->
+                    check (Env.find_type path env)
+                | _ -> raise Not_found
+          in check decl;
+          Location.deprecated styp.ptyp_loc
+            "old syntax for polymorphic variant type";
+          ignore(Env.lookup_type ~loc:lid.loc lid.txt env);
+          (path, decl,true)
+        with Not_found -> try
+          let lid2 =
+            match lid.txt with
+              Longident.Lident s     -> Longident.Lident ("#" ^ s)
+            | Longident.Ldot(r, s)   -> Longident.Ldot (r, "#" ^ s)
+            | Longident.Lapply(_, _) -> fatal_error "Typetexp.transl_type"
+          in
+          let path, decl = Env.find_type_by_name lid2 env in
+          ignore(Env.lookup_cltype ~loc:lid.loc lid.txt env);
+          (path, decl, false)
+        with Not_found ->
+          ignore (Env.lookup_cltype ~loc:lid.loc lid.txt env); assert false
+      in
+      if List.length stl <> decl.type_arity then
+        raise(Error(styp.ptyp_loc, env,
+                    Type_arity_mismatch(lid.txt, decl.type_arity,
+                                        List.length stl)));
+      let args = List.map (transl_type env policy) stl in
+      let params = instance_list decl.type_params in
+      List.iter2
+        (fun (sty, cty) ty' ->
+           try unify_var env ty' cty.ctyp_type with Unify trace ->
+             let trace = Errortrace.swap_trace trace in
+             raise (Error(sty.ptyp_loc, env, Type_mismatch trace))
+        )
+        (List.combine stl args) params;
+        let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in
+      let ty =
+        try Ctype.expand_head env (newconstr path ty_args)
+        with Unify trace ->
+          raise (Error(styp.ptyp_loc, env, Type_mismatch trace))
+      in
+      let ty = match ty.desc with
+        Tvariant row ->
+          let row = Btype.row_repr row in
+          let fields =
+            List.map
+              (fun (l,f) -> l,
+                match Btype.row_field_repr f with
+                | Rpresent (Some ty) ->
+                    Reither(false, [ty], false, ref None)
+                | Rpresent None ->
+                    Reither (true, [], false, ref None)
+                | _ -> f)
+              row.row_fields
+          in
+          let row = { row_closed = true; row_fields = fields;
+                      row_bound = (); row_name = Some (path, ty_args);
+                      row_fixed = None; row_more = newvar () } in
+          let static = Btype.static_row row in
+          let row =
+            if static then { row with row_more = newty Tnil }
+            else if policy <> Univars then row
+            else { row with row_more = new_pre_univar () }
+          in
+          newty (Tvariant row)
+      | Tobject (fi, _) ->
+          let _, tv = flatten_fields fi in
+          if policy = Univars then pre_univars := tv :: !pre_univars;
+          ty
+      | _ ->
+          assert false
+      in
+      ctyp (Ttyp_class (path, lid, args)) ty
+  | Ptyp_alias(st, alias) ->
+      let cty =
+        try
+          let t =
+            try List.assoc alias !univars
+            with Not_found ->
+              instance (fst(TyVarMap.find alias !used_variables))
+          in
+          let ty = transl_type env policy st in
+          begin try unify_var env t ty.ctyp_type with Unify trace ->
+            let trace = Errortrace.swap_trace trace in
+            raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace))
+          end;
+          ty
+        with Not_found ->
+          if !Clflags.principal then begin_def ();
+          let t = newvar () in
+          used_variables :=
+            TyVarMap.add alias (t, styp.ptyp_loc) !used_variables;
+          let ty = transl_type env policy st in
+          begin try unify_var env t ty.ctyp_type with Unify trace ->
+            let trace = Errortrace.swap_trace trace in
+            raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace))
+          end;
+          if !Clflags.principal then begin
+            end_def ();
+            generalize_structure t;
+          end;
+          let t = instance t in
+          let px = Btype.proxy t in
+          begin match px.desc with
+          | Tvar None -> Btype.set_type_desc px (Tvar (Some alias))
+          | Tunivar None -> Btype.set_type_desc px (Tunivar (Some alias))
+          | _ -> ()
+          end;
+          { ty with ctyp_type = t }
+      in
+      ctyp (Ttyp_alias (cty, alias)) cty.ctyp_type
+  | Ptyp_variant(fields, closed, present) ->
+      let name = ref None in
+      let mkfield l f =
+        newty (Tvariant {row_fields=[l,f]; row_more=newvar();
+                         row_bound=(); row_closed=true;
+                         row_fixed=None; row_name=None}) in
+      let hfields = Hashtbl.create 17 in
+      let add_typed_field loc l f =
+        let h = Btype.hash_variant l in
+        try
+          let (l',f') = Hashtbl.find hfields h in
+          (* Check for tag conflicts *)
+          if l <> l' then raise(Error(styp.ptyp_loc, env, Variant_tags(l, l')));
+          let ty = mkfield l f and ty' = mkfield l f' in
+          if is_equal env false [ty] [ty'] then () else
+          try unify env ty ty'
+          with Unify _trace ->
+            raise(Error(loc, env, Constructor_mismatch (ty,ty')))
+        with Not_found ->
+          Hashtbl.add hfields h (l,f)
+      in
+      let add_field field =
+        let rf_loc = field.prf_loc in
+        let rf_attributes = field.prf_attributes in
+        let rf_desc = match field.prf_desc with
+        | Rtag (l, c, stl) ->
+            name := None;
+            let tl =
+              Builtin_attributes.warning_scope rf_attributes
+                (fun () -> List.map (transl_type env policy) stl)
+            in
+            let f = match present with
+              Some present when not (List.mem l.txt present) ->
+                let ty_tl = List.map (fun cty -> cty.ctyp_type) tl in
+                Reither(c, ty_tl, false, ref None)
+            | _ ->
+                if List.length stl > 1 || c && stl <> [] then
+                  raise(Error(styp.ptyp_loc, env,
+                              Present_has_conjunction l.txt));
+                match tl with [] -> Rpresent None
+                | st :: _ ->
+                      Rpresent (Some st.ctyp_type)
+            in
+            add_typed_field styp.ptyp_loc l.txt f;
+              Ttag (l,c,tl)
+        | Rinherit sty ->
+            let cty = transl_type env policy sty in
+            let ty = cty.ctyp_type in
+            let nm =
+              match repr cty.ctyp_type with
+                {desc=Tconstr(p, tl, _)} -> Some(p, tl)
+              | _                        -> None
+            in
+            name := if Hashtbl.length hfields <> 0 then None else nm;
+            let fl = match expand_head env cty.ctyp_type, nm with
+              {desc=Tvariant row}, _ when Btype.static_row row ->
+                let row = Btype.row_repr row in
+                row.row_fields
+            | {desc=Tvar _}, Some(p, _) ->
+                raise(Error(sty.ptyp_loc, env, Undefined_type_constructor p))
+            | _ ->
+                raise(Error(sty.ptyp_loc, env, Not_a_variant ty))
+            in
+            List.iter
+              (fun (l, f) ->
+                let f = match present with
+                  Some present when not (List.mem l present) ->
+                    begin match f with
+                      Rpresent(Some ty) ->
+                        Reither(false, [ty], false, ref None)
+                    | Rpresent None ->
+                        Reither(true, [], false, ref None)
+                    | _ ->
+                        assert false
+                    end
+                | _ -> f
+                in
+                add_typed_field sty.ptyp_loc l f)
+              fl;
+              Tinherit cty
+        in
+        { rf_desc; rf_loc; rf_attributes; }
+      in
+      let tfields = List.map add_field fields in
+      let fields = Hashtbl.fold (fun _ p l -> p :: l) hfields [] in
+      begin match present with None -> ()
+      | Some present ->
+          List.iter
+            (fun l -> if not (List.mem_assoc l fields) then
+              raise(Error(styp.ptyp_loc, env, Present_has_no_type l)))
+            present
+      end;
+      let row =
+        { row_fields = List.rev fields; row_more = newvar ();
+          row_bound = (); row_closed = (closed = Closed);
+          row_fixed = None; row_name = !name } in
+      let static = Btype.static_row row in
+      let row =
+        if static then { row with row_more = newty Tnil }
+        else if policy <> Univars then row
+        else { row with row_more = new_pre_univar () }
+      in
+      let ty = newty (Tvariant row) in
+      ctyp (Ttyp_variant (tfields, closed, present)) ty
+  | Ptyp_poly(vars, st) ->
+      let vars = List.map (fun v -> v.txt) vars in
+      begin_def();
+      let new_univars = List.map (fun name -> name, newvar ~name ()) vars in
+      let old_univars = !univars in
+      univars := new_univars @ !univars;
+      let cty = transl_type env policy st in
+      let ty = cty.ctyp_type in
+      univars := old_univars;
+      end_def();
+      generalize ty;
+      let ty_list =
+        List.fold_left
+          (fun tyl (name, ty1) ->
+            let v = Btype.proxy ty1 in
+            if deep_occur v ty then begin
+              match v.desc with
+                Tvar name when v.level = Btype.generic_level ->
+                  Btype.set_type_desc v (Tunivar name);
+                  v :: tyl
+              | _ ->
+                raise (Error (styp.ptyp_loc, env, Cannot_quantify (name, v)))
+            end else tyl)
+          [] new_univars
+      in
+      let ty' = Btype.newgenty (Tpoly(ty, List.rev ty_list)) in
+      unify_var env (newvar()) ty';
+      ctyp (Ttyp_poly (vars, cty)) ty'
+  | Ptyp_package (p, l) ->
+      let l, mty = create_package_mty true styp.ptyp_loc env (p, l) in
+      let z = narrow () in
+      let mty = !transl_modtype env mty in
+      widen z;
+      let ptys = List.map (fun (s, pty) ->
+                             s, transl_type env policy pty
+                          ) l in
+      let path = !transl_modtype_longident styp.ptyp_loc env p.txt in
+      let ty = newty (Tpackage (path,
+                       List.map (fun (s, cty) -> (s.txt, cty.ctyp_type)) ptys))
+      in
+      ctyp (Ttyp_package {
+            pack_path = path;
+            pack_type = mty.mty_type;
+            pack_fields = ptys;
+            pack_txt = p;
+           }) ty
+  | Ptyp_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and transl_poly_type env policy t =
+  transl_type env policy (Ast_helper.Typ.force_poly t)
+
+and transl_fields env policy o fields =
+  let hfields = Hashtbl.create 17 in
+  let add_typed_field loc l ty =
+    try
+      let ty' = Hashtbl.find hfields l in
+      if is_equal env false [ty] [ty'] then () else
+        try unify env ty ty'
+        with Unify _trace ->
+          raise(Error(loc, env, Method_mismatch (l, ty, ty')))
+    with Not_found ->
+      Hashtbl.add hfields l ty in
+  let add_field {pof_desc; pof_loc; pof_attributes;} =
+    let of_loc = pof_loc in
+    let of_attributes = pof_attributes in
+    let of_desc = match pof_desc with
+    | Otag (s, ty1) -> begin
+        let ty1 =
+          Builtin_attributes.warning_scope of_attributes
+            (fun () -> transl_poly_type env policy ty1)
+        in
+        let field = OTtag (s, ty1) in
+        add_typed_field ty1.ctyp_loc s.txt ty1.ctyp_type;
+        field
+      end
+    | Oinherit sty -> begin
+        let cty = transl_type env policy sty in
+        let nm =
+          match repr cty.ctyp_type with
+            {desc=Tconstr(p, _, _)} -> Some p
+          | _                        -> None in
+        let t = expand_head env cty.ctyp_type in
+        match t, nm with
+          {desc=Tobject ({desc=(Tfield _ | Tnil) as tf}, _)}, _ -> begin
+            if opened_object t then
+              raise (Error (sty.ptyp_loc, env, Opened_object nm));
+            let rec iter_add = function
+              | Tfield (s, _k, ty1, ty2) -> begin
+                  add_typed_field sty.ptyp_loc s ty1;
+                  iter_add ty2.desc
+                end
+              | Tnil -> ()
+              | _ -> assert false in
+            iter_add tf;
+            OTinherit cty
+            end
+        | {desc=Tvar _}, Some p ->
+            raise (Error (sty.ptyp_loc, env, Undefined_type_constructor p))
+        | _ -> raise (Error (sty.ptyp_loc, env, Not_an_object t))
+      end in
+    { of_desc; of_loc; of_attributes; }
+  in
+  let object_fields = List.map add_field fields in
+  let fields = Hashtbl.fold (fun s ty l -> (s, ty) :: l) hfields [] in
+  let ty_init =
+     match o, policy with
+     | Closed, _ -> newty Tnil
+     | Open, Univars -> new_pre_univar ()
+     | Open, _ -> newvar () in
+  let ty = List.fold_left (fun ty (s, ty') ->
+      newty (Tfield (s, Fpresent, ty', ty))) ty_init fields in
+  ty, object_fields
+
+
+(* Make the rows "fixed" in this type, to make universal check easier *)
+let rec make_fixed_univars ty =
+  let ty = repr ty in
+  if Btype.try_mark_node ty then
+    begin match ty.desc with
+    | Tvariant row ->
+        let row = Btype.row_repr row in
+        let more = Btype.row_more row in
+        if Btype.is_Tunivar more then
+          Btype.set_type_desc ty
+            (Tvariant
+               {row with row_fixed=Some(Univar more);
+                row_fields = List.map
+                 (fun (s,f as p) -> match Btype.row_field_repr f with
+                   Reither (c, tl, _m, r) -> s, Reither (c, tl, true, r)
+                 | _ -> p)
+                 row.row_fields});
+        Btype.iter_row make_fixed_univars row
+    | _ ->
+        Btype.iter_type_expr make_fixed_univars ty
+    end
+
+let make_fixed_univars ty =
+  make_fixed_univars ty;
+  Btype.unmark_type ty
+
+let create_package_mty = create_package_mty false
+
+let globalize_used_variables env fixed =
+  let r = ref [] in
+  TyVarMap.iter
+    (fun name (ty, loc) ->
+      let v = new_global_var () in
+      let snap = Btype.snapshot () in
+      if try unify env v ty; true with _ -> Btype.backtrack snap; false
+      then try
+        r := (loc, v,  TyVarMap.find name !type_variables) :: !r
+      with Not_found ->
+        if fixed && Btype.is_Tvar (repr ty) then
+          raise(Error(loc, env, Unbound_type_variable ("'"^name)));
+        let v2 = new_global_var () in
+        r := (loc, v, v2) :: !r;
+        type_variables := TyVarMap.add name v2 !type_variables)
+    !used_variables;
+  used_variables := TyVarMap.empty;
+  fun () ->
+    List.iter
+      (function (loc, t1, t2) ->
+        try unify env t1 t2 with Unify trace ->
+          raise (Error(loc, env, Type_mismatch trace)))
+      !r
+
+let transl_simple_type env fixed styp =
+  univars := []; used_variables := TyVarMap.empty;
+  let typ = transl_type env (if fixed then Fixed else Extensible) styp in
+  globalize_used_variables env fixed ();
+  make_fixed_univars typ.ctyp_type;
+  typ
+
+let transl_simple_type_univars env styp =
+  univars := []; used_variables := TyVarMap.empty; pre_univars := [];
+  begin_def ();
+  let typ = transl_type env Univars styp in
+  (* Only keep already global variables in used_variables *)
+  let new_variables = !used_variables in
+  used_variables := TyVarMap.empty;
+  TyVarMap.iter
+    (fun name p ->
+      if TyVarMap.mem name !type_variables then
+        used_variables := TyVarMap.add name p !used_variables)
+    new_variables;
+  globalize_used_variables env false ();
+  end_def ();
+  generalize typ.ctyp_type;
+  let univs =
+    List.fold_left
+      (fun acc v ->
+        let v = repr v in
+        match v.desc with
+          Tvar name when v.level = Btype.generic_level ->
+            Btype.set_type_desc v (Tunivar name); v :: acc
+        | _ -> acc)
+      [] !pre_univars
+  in
+  make_fixed_univars typ.ctyp_type;
+    { typ with ctyp_type =
+        instance (Btype.newgenty (Tpoly (typ.ctyp_type, univs))) }
+
+let transl_simple_type_delayed env styp =
+  univars := []; used_variables := TyVarMap.empty;
+  begin_def ();
+  let typ = transl_type env Extensible styp in
+  end_def ();
+  make_fixed_univars typ.ctyp_type;
+  (* This brings the used variables to the global level, but doesn't link them
+     to their other occurrences just yet. This will be done when [force] is
+     called. *)
+  let force = globalize_used_variables env false in
+  (* Generalizes everything except the variables that were just globalized. *)
+  generalize typ.ctyp_type;
+  (typ, instance typ.ctyp_type, force)
+
+let transl_type_scheme env styp =
+  reset_type_variables();
+  begin_def();
+  let typ = transl_simple_type env false styp in
+  end_def();
+  generalize typ.ctyp_type;
+  typ
+
+
+(* Error report *)
+
+open Format
+open Printtyp
+
+let report_error env ppf = function
+  | Unbound_type_variable name ->
+      let add_name name _ l = if name = "_" then l else ("'" ^ name) :: l in
+      let names = TyVarMap.fold add_name !type_variables [] in
+    fprintf ppf "The type variable %s is unbound in this type declaration.@ %a"
+      name
+      did_you_mean (fun () -> Misc.spellcheck names name )
+  | Undefined_type_constructor p ->
+    fprintf ppf "The type constructor@ %a@ is not yet completely defined"
+      path p
+  | Type_arity_mismatch(lid, expected, provided) ->
+    fprintf ppf
+      "@[The type constructor %a@ expects %i argument(s),@ \
+        but is here applied to %i argument(s)@]"
+      longident lid expected provided
+  | Bound_type_variable name ->
+    fprintf ppf "Already bound type parameter %a" Pprintast.tyvar name
+  | Recursive_type ->
+    fprintf ppf "This type is recursive"
+  | Unbound_row_variable lid ->
+      (* we don't use "spellcheck" here: this error is not raised
+         anywhere so it's unclear how it should be handled *)
+      fprintf ppf "Unbound row variable in #%a" longident lid
+  | Type_mismatch trace ->
+      Printtyp.report_unification_error ppf Env.empty trace
+        (function ppf ->
+           fprintf ppf "This type")
+        (function ppf ->
+           fprintf ppf "should be an instance of type")
+  | Alias_type_mismatch trace ->
+      Printtyp.report_unification_error ppf Env.empty trace
+        (function ppf ->
+           fprintf ppf "This alias is bound to type")
+        (function ppf ->
+           fprintf ppf "but is used as an instance of type")
+  | Present_has_conjunction l ->
+      fprintf ppf "The present constructor %s has a conjunctive type" l
+  | Present_has_no_type l ->
+      fprintf ppf
+        "@[<v>@[The constructor %s is missing from the upper bound@ \
+         (between '<'@ and '>')@ of this polymorphic variant@ \
+         but is present in@ its lower bound (after '>').@]@,\
+         @[Hint: Either add `%s in the upper bound,@ \
+         or remove it@ from the lower bound.@]@]"
+         l l
+  | Constructor_mismatch (ty, ty') ->
+      wrap_printing_env ~error:true env (fun ()  ->
+        Printtyp.reset_and_mark_loops_list [ty; ty'];
+        fprintf ppf "@[<hov>%s %a@ %s@ %a@]"
+          "This variant type contains a constructor"
+          !Oprint.out_type (tree_of_typexp false ty)
+          "which should be"
+           !Oprint.out_type (tree_of_typexp false ty'))
+  | Not_a_variant ty ->
+      fprintf ppf
+        "@[The type %a@ does not expand to a polymorphic variant type@]"
+        Printtyp.type_expr ty;
+      begin match ty.desc with
+        | Tvar (Some s) ->
+           (* PR#7012: help the user that wrote 'Foo instead of `Foo *)
+           Misc.did_you_mean ppf (fun () -> ["`" ^ s])
+        | _ -> ()
+      end
+  | Variant_tags (lab1, lab2) ->
+      fprintf ppf
+        "@[Variant tags `%s@ and `%s have the same hash value.@ %s@]"
+        lab1 lab2 "Change one of them."
+  | Invalid_variable_name name ->
+      fprintf ppf "The type variable name %s is not allowed in programs" name
+  | Cannot_quantify (name, v) ->
+      fprintf ppf
+        "@[<hov>The universal type variable %a cannot be generalized:@ "
+        Pprintast.tyvar name;
+      if Btype.is_Tvar v then
+        fprintf ppf "it escapes its scope"
+      else if Btype.is_Tunivar v then
+        fprintf ppf "it is already bound to another variable"
+      else
+        fprintf ppf "it is bound to@ %a" Printtyp.type_expr v;
+      fprintf ppf ".@]";
+  | Multiple_constraints_on_type s ->
+      fprintf ppf "Multiple constraints for type %a" longident s
+  | Method_mismatch (l, ty, ty') ->
+      wrap_printing_env ~error:true env (fun ()  ->
+        fprintf ppf "@[<hov>Method '%s' has type %a,@ which should be %a@]"
+          l Printtyp.type_expr ty Printtyp.type_expr ty')
+  | Opened_object nm ->
+      fprintf ppf
+        "Illegal open object type%a"
+        (fun ppf -> function
+             Some p -> fprintf ppf "@ %a" path p
+           | None -> fprintf ppf "") nm
+  | Not_an_object ty ->
+      fprintf ppf "@[The type %a@ is not an object type@]"
+        Printtyp.type_expr ty
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, env, err) ->
+        Some (Location.error_of_printer ~loc (report_error env) err)
+      | Error_forward err ->
+        Some err
+      | _ ->
+        None
+    )
diff --git a/src/ocaml/typing/typetexp.mli b/src/ocaml/typing/typetexp.mli
new file mode 100644
index 0000000..609305b
--- /dev/null
+++ b/src/ocaml/typing/typetexp.mli
@@ -0,0 +1,79 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Typechecking of type expressions for the core language *)
+
+open Types
+
+val valid_tyvar_name : string -> bool
+
+val transl_simple_type:
+        Env.t -> bool -> Parsetree.core_type -> Typedtree.core_type
+val transl_simple_type_univars:
+        Env.t -> Parsetree.core_type -> Typedtree.core_type
+val transl_simple_type_delayed
+  :  Env.t
+  -> Parsetree.core_type
+  -> Typedtree.core_type * type_expr * (unit -> unit)
+        (* Translate a type, but leave type variables unbound. Returns
+           the type, an instance of the corresponding type_expr, and a
+           function that binds the type variable. *)
+val transl_type_scheme:
+        Env.t -> Parsetree.core_type -> Typedtree.core_type
+val reset_type_variables: unit -> unit
+val type_variable: Location.t -> string -> type_expr
+val transl_type_param:
+  Env.t -> Parsetree.core_type -> Typedtree.core_type
+
+type variable_context
+val narrow: unit -> variable_context
+val widen: variable_context -> unit
+
+exception Already_bound
+
+type error =
+    Unbound_type_variable of string
+  | Undefined_type_constructor of Path.t
+  | Type_arity_mismatch of Longident.t * int * int
+  | Bound_type_variable of string
+  | Recursive_type
+  | Unbound_row_variable of Longident.t
+  | Type_mismatch of Errortrace.unification Errortrace.t
+  | Alias_type_mismatch of Errortrace.unification Errortrace.t
+  | Present_has_conjunction of string
+  | Present_has_no_type of string
+  | Constructor_mismatch of type_expr * type_expr
+  | Not_a_variant of type_expr
+  | Variant_tags of string * string
+  | Invalid_variable_name of string
+  | Cannot_quantify of string * type_expr
+  | Multiple_constraints_on_type of Longident.t
+  | Method_mismatch of string * type_expr * type_expr
+  | Opened_object of Path.t option
+  | Not_an_object of type_expr
+
+exception Error of Location.t * Env.t * error
+
+val report_error: Env.t -> Format.formatter -> error -> unit
+
+(* Support for first-class modules. *)
+val transl_modtype_longident:  (* from Typemod *)
+    (Location.t -> Env.t -> Longident.t -> Path.t) ref
+val transl_modtype: (* from Typemod *)
+    (Env.t -> Parsetree.module_type -> Typedtree.module_type) ref
+val create_package_mty:
+    Location.t -> Env.t -> Parsetree.package_type ->
+    (Longident.t Asttypes.loc * Parsetree.core_type) list *
+      Parsetree.module_type
diff --git a/src/ocaml/typing/untypeast.ml b/src/ocaml/typing/untypeast.ml
new file mode 100644
index 0000000..e5ffa94
--- /dev/null
+++ b/src/ocaml/typing/untypeast.ml
@@ -0,0 +1,922 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*    Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay)     *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Longident
+open Asttypes
+open Parsetree
+open Ast_helper
+
+module T = Typedtree
+
+type mapper = {
+  attribute: mapper -> T.attribute -> attribute;
+  attributes: mapper -> T.attribute list -> attribute list;
+  binding_op: mapper -> T.binding_op -> T.pattern -> binding_op;
+  case: 'k . mapper -> 'k T.case -> case;
+  class_declaration: mapper -> T.class_declaration -> class_declaration;
+  class_description: mapper -> T.class_description -> class_description;
+  class_expr: mapper -> T.class_expr -> class_expr;
+  class_field: mapper -> T.class_field -> class_field;
+  class_signature: mapper -> T.class_signature -> class_signature;
+  class_structure: mapper -> T.class_structure -> class_structure;
+  class_type: mapper -> T.class_type -> class_type;
+  class_type_declaration: mapper -> T.class_type_declaration
+                          -> class_type_declaration;
+  class_type_field: mapper -> T.class_type_field -> class_type_field;
+  constructor_declaration: mapper -> T.constructor_declaration
+                           -> constructor_declaration;
+  expr: mapper -> T.expression -> expression;
+  extension_constructor: mapper -> T.extension_constructor
+                         -> extension_constructor;
+  include_declaration: mapper -> T.include_declaration -> include_declaration;
+  include_description: mapper -> T.include_description -> include_description;
+  label_declaration: mapper -> T.label_declaration -> label_declaration;
+  location: mapper -> Location.t -> Location.t;
+  module_binding: mapper -> T.module_binding -> module_binding;
+  module_declaration: mapper -> T.module_declaration -> module_declaration;
+  module_substitution: mapper -> T.module_substitution -> module_substitution;
+  module_expr: mapper -> T.module_expr -> module_expr;
+  module_type: mapper -> T.module_type -> module_type;
+  module_type_declaration:
+    mapper -> T.module_type_declaration -> module_type_declaration;
+  package_type: mapper -> T.package_type -> package_type;
+  open_declaration: mapper -> T.open_declaration -> open_declaration;
+  open_description: mapper -> T.open_description -> open_description;
+  pat: 'k . mapper -> 'k T.general_pattern -> pattern;
+  row_field: mapper -> T.row_field -> row_field;
+  object_field: mapper -> T.object_field -> object_field;
+  signature: mapper -> T.signature -> signature;
+  signature_item: mapper -> T.signature_item -> signature_item;
+  structure: mapper -> T.structure -> structure;
+  structure_item: mapper -> T.structure_item -> structure_item;
+  typ: mapper -> T.core_type -> core_type;
+  type_declaration: mapper -> T.type_declaration -> type_declaration;
+  type_extension: mapper -> T.type_extension -> type_extension;
+  type_exception: mapper -> T.type_exception -> type_exception;
+  type_kind: mapper -> T.type_kind -> type_kind;
+  value_binding: mapper -> T.value_binding -> value_binding;
+  value_description: mapper -> T.value_description -> value_description;
+  with_constraint:
+    mapper -> (Path.t * Longident.t Location.loc * T.with_constraint)
+    -> with_constraint;
+}
+
+open T
+
+(*
+Some notes:
+
+   * For Pexp_function, we cannot go back to the exact original version
+   when there is a default argument, because the default argument is
+   translated in the typer. The code, if printed, will not be parsable because
+   new generated identifiers are not correct.
+
+   * For Pexp_apply, it is unclear whether arguments are reordered, especially
+    when there are optional arguments.
+
+*)
+
+
+(** Utility functions. *)
+
+let string_is_prefix sub str =
+  let sublen = String.length sub in
+  String.length str >= sublen && String.sub str 0 sublen = sub
+
+let rec lident_of_path = function
+  | Path.Pident id -> Longident.Lident (Ident.name id)
+  | Path.Pdot (p, s) -> Longident.Ldot (lident_of_path p, s)
+  | Path.Papply (p1, p2) ->
+      Longident.Lapply (lident_of_path p1, lident_of_path p2)
+
+let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}
+
+(** Try a name [$name$0], check if it's free, if not, increment and repeat. *)
+let fresh_name s env =
+  let rec aux i =
+    let name = s ^ Int.to_string i in
+    if Env.bound_value name env then aux (i+1)
+    else name
+  in
+  aux 0
+
+(** Extract the [n] patterns from the case of a letop *)
+let rec extract_letop_patterns n pat =
+  if n = 0 then pat, []
+  else begin
+    match pat.pat_desc with
+    | Tpat_tuple([first; rest]) ->
+        let next, others = extract_letop_patterns (n-1) rest in
+        first, next :: others
+    | _ ->
+      let rec anys n =
+        if n = 0 then []
+        else { pat with pat_desc = Tpat_any } :: anys (n-1)
+      in
+      { pat with pat_desc = Tpat_any }, anys (n-1)
+  end
+
+(** Mapping functions. *)
+
+let constant = function
+  | Const_char c -> Pconst_char c
+  | Const_string (s,loc,d) -> Pconst_string (s,loc,d)
+  | Const_int i -> Pconst_integer (Int.to_string i, None)
+  | Const_int32 i -> Pconst_integer (Int32.to_string i, Some 'l')
+  | Const_int64 i -> Pconst_integer (Int64.to_string i, Some 'L')
+  | Const_nativeint i -> Pconst_integer (Nativeint.to_string i, Some 'n')
+  | Const_float f -> Pconst_float (f,None)
+
+let attribute sub a = {
+    attr_name = map_loc sub a.attr_name;
+    attr_payload = a.attr_payload;
+    attr_loc = a.attr_loc
+  }
+
+let attributes sub l = List.map (sub.attribute sub) l
+
+let structure sub str =
+  List.map (sub.structure_item sub) str.str_items
+
+let open_description sub od =
+  let loc = sub.location sub od.open_loc in
+  let attrs = sub.attributes sub od.open_attributes in
+  Opn.mk ~loc ~attrs
+    ~override:od.open_override
+    (snd od.open_expr)
+
+let open_declaration sub od =
+  let loc = sub.location sub od.open_loc in
+  let attrs = sub.attributes sub od.open_attributes in
+  Opn.mk ~loc ~attrs
+    ~override:od.open_override
+    (sub.module_expr sub od.open_expr)
+
+let structure_item sub item =
+  let loc = sub.location sub item.str_loc in
+  let desc =
+    match item.str_desc with
+      Tstr_eval (exp, attrs) -> Pstr_eval (sub.expr sub exp, attrs)
+    | Tstr_value (rec_flag, list) ->
+        Pstr_value (rec_flag, List.map (sub.value_binding sub) list)
+    | Tstr_primitive vd ->
+        Pstr_primitive (sub.value_description sub vd)
+    | Tstr_type (rec_flag, list) ->
+        Pstr_type (rec_flag, List.map (sub.type_declaration sub) list)
+    | Tstr_typext tyext ->
+        Pstr_typext (sub.type_extension sub tyext)
+    | Tstr_exception ext ->
+        Pstr_exception (sub.type_exception sub ext)
+    | Tstr_module mb ->
+        Pstr_module (sub.module_binding sub mb)
+    | Tstr_recmodule list ->
+        Pstr_recmodule (List.map (sub.module_binding sub) list)
+    | Tstr_modtype mtd ->
+        Pstr_modtype (sub.module_type_declaration sub mtd)
+    | Tstr_open od ->
+        Pstr_open (sub.open_declaration sub od)
+    | Tstr_class list ->
+        Pstr_class
+          (List.map
+             (fun (ci, _) -> sub.class_declaration sub ci)
+             list)
+    | Tstr_class_type list ->
+        Pstr_class_type
+          (List.map
+             (fun (_id, _name, ct) -> sub.class_type_declaration sub ct)
+             list)
+    | Tstr_include incl ->
+        Pstr_include (sub.include_declaration sub incl)
+    | Tstr_attribute x ->
+        Pstr_attribute x
+  in
+  Str.mk ~loc desc
+
+let value_description sub v =
+  let loc = sub.location sub v.val_loc in
+  let attrs = sub.attributes sub v.val_attributes in
+  Val.mk ~loc ~attrs
+    ~prim:v.val_prim
+    (map_loc sub v.val_name)
+    (sub.typ sub v.val_desc)
+
+let module_binding sub mb =
+  let loc = sub.location sub mb.mb_loc in
+  let attrs = sub.attributes sub mb.mb_attributes in
+  Mb.mk ~loc ~attrs
+    (map_loc sub mb.mb_name)
+    (sub.module_expr sub mb.mb_expr)
+
+let type_parameter sub (ct, v) = (sub.typ sub ct, v)
+
+let type_declaration sub decl =
+  let loc = sub.location sub decl.typ_loc in
+  let attrs = sub.attributes sub decl.typ_attributes in
+  Type.mk ~loc ~attrs
+    ~params:(List.map (type_parameter sub) decl.typ_params)
+    ~cstrs:(
+      List.map
+        (fun (ct1, ct2, loc) ->
+           (sub.typ sub ct1, sub.typ sub ct2, sub.location sub loc))
+        decl.typ_cstrs)
+    ~kind:(sub.type_kind sub decl.typ_kind)
+    ~priv:decl.typ_private
+    ?manifest:(Option.map (sub.typ sub) decl.typ_manifest)
+    (map_loc sub decl.typ_name)
+
+let type_kind sub tk = match tk with
+  | Ttype_abstract -> Ptype_abstract
+  | Ttype_variant list ->
+      Ptype_variant (List.map (sub.constructor_declaration sub) list)
+  | Ttype_record list ->
+      Ptype_record (List.map (sub.label_declaration sub) list)
+  | Ttype_open -> Ptype_open
+
+let constructor_arguments sub = function
+   | Cstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l)
+   | Cstr_record l -> Pcstr_record (List.map (sub.label_declaration sub) l)
+
+let constructor_declaration sub cd =
+  let loc = sub.location sub cd.cd_loc in
+  let attrs = sub.attributes sub cd.cd_attributes in
+  Type.constructor ~loc ~attrs
+    ~args:(constructor_arguments sub cd.cd_args)
+    ?res:(Option.map (sub.typ sub) cd.cd_res)
+    (map_loc sub cd.cd_name)
+
+let label_declaration sub ld =
+  let loc = sub.location sub ld.ld_loc in
+  let attrs = sub.attributes sub ld.ld_attributes in
+  Type.field ~loc ~attrs
+    ~mut:ld.ld_mutable
+    (map_loc sub ld.ld_name)
+    (sub.typ sub ld.ld_type)
+
+let type_extension sub tyext =
+  let attrs = sub.attributes sub tyext.tyext_attributes in
+  Te.mk ~attrs
+    ~params:(List.map (type_parameter sub) tyext.tyext_params)
+    ~priv:tyext.tyext_private
+    (map_loc sub tyext.tyext_txt)
+    (List.map (sub.extension_constructor sub) tyext.tyext_constructors)
+
+let type_exception sub tyexn =
+  let attrs = sub.attributes sub tyexn.tyexn_attributes in
+  Te.mk_exception ~attrs
+    (sub.extension_constructor sub tyexn.tyexn_constructor)
+
+let extension_constructor sub ext =
+  let loc = sub.location sub ext.ext_loc in
+  let attrs = sub.attributes sub ext.ext_attributes in
+  Te.constructor ~loc ~attrs
+    (map_loc sub ext.ext_name)
+    (match ext.ext_kind with
+      | Text_decl (args, ret) ->
+          Pext_decl (constructor_arguments sub args,
+                     Option.map (sub.typ sub) ret)
+      | Text_rebind (_p, lid) -> Pext_rebind (map_loc sub lid)
+    )
+
+let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat ->
+  let loc = sub.location sub pat.pat_loc in
+  (* todo: fix attributes on extras *)
+  let attrs = sub.attributes sub pat.pat_attributes in
+  let desc =
+  match pat with
+      { pat_extra=[Tpat_unpack, loc, _attrs]; pat_desc = Tpat_any; _ } ->
+        Ppat_unpack { txt = None; loc  }
+    | { pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } ->
+        Ppat_unpack { name with txt = Some name.txt }
+    | { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } ->
+        Ppat_type (map_loc sub lid)
+    | { pat_extra= (Tpat_constraint ct, _, _attrs) :: rem; _ } ->
+        Ppat_constraint (sub.pat sub { pat with pat_extra=rem },
+                         sub.typ sub ct)
+    | _ ->
+    match pat.pat_desc with
+      Tpat_any -> Ppat_any
+    | Tpat_var (id, name) ->
+        begin
+          match (Ident.name id).[0] with
+            'A'..'Z' ->
+              Ppat_unpack { name with txt = Some name.txt}
+          | _ ->
+              Ppat_var name
+        end
+
+    (* We transform (_ as x) in x if _ and x have the same location.
+       The compiler transforms (x:t) into (_ as x : t).
+       This avoids transforming a warning 27 into a 26.
+     *)
+    | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name)
+         when pat_loc = pat.pat_loc ->
+       Ppat_var name
+
+    | Tpat_alias (pat, _id, name) ->
+        Ppat_alias (sub.pat sub pat, name)
+    | Tpat_constant cst -> Ppat_constant (constant cst)
+    | Tpat_tuple list ->
+        Ppat_tuple (List.map (sub.pat sub) list)
+    | Tpat_construct (lid, _, args, vto) ->
+        let tyo =
+          match vto with
+            None -> None
+          | Some (vl, ty) ->
+              let vl =
+                List.map (fun x -> {x with txt = Ident.name x.txt}) vl
+              in
+              Some (vl, sub.typ sub ty)
+        in
+        let arg =
+          match args with
+            []    -> None
+          | [arg] -> Some (sub.pat sub arg)
+          | args  -> Some (Pat.tuple ~loc (List.map (sub.pat sub) args))
+        in
+        Ppat_construct (map_loc sub lid,
+          match tyo, arg with
+          | Some (vl, ty), Some arg ->
+              Some (vl, Pat.mk ~loc (Ppat_constraint (arg, ty)))
+          | None, Some arg -> Some ([], arg)
+          | _, None -> None)
+    | Tpat_variant (label, pato, _) ->
+        Ppat_variant (label, Option.map (sub.pat sub) pato)
+    | Tpat_record (list, closed) ->
+        Ppat_record (List.map (fun (lid, _, pat) ->
+            map_loc sub lid, sub.pat sub pat) list, closed)
+    | Tpat_array list -> Ppat_array (List.map (sub.pat sub) list)
+    | Tpat_lazy p -> Ppat_lazy (sub.pat sub p)
+
+    | Tpat_exception p -> Ppat_exception (sub.pat sub p)
+    | Tpat_value p -> (sub.pat sub (p :> pattern)).ppat_desc
+    | Tpat_or (p1, p2, _) -> Ppat_or (sub.pat sub p1, sub.pat sub p2)
+  in
+  Pat.mk ~loc ~attrs desc
+
+let exp_extra sub (extra, loc, attrs) sexp =
+  let loc = sub.location sub loc in
+  let attrs = sub.attributes sub attrs in
+  let desc =
+    match extra with
+      Texp_coerce (cty1, cty2) ->
+        Pexp_coerce (sexp,
+                     Option.map (sub.typ sub) cty1,
+                     sub.typ sub cty2)
+    | Texp_constraint cty ->
+        Pexp_constraint (sexp, sub.typ sub cty)
+    | Texp_poly cto -> Pexp_poly (sexp, Option.map (sub.typ sub) cto)
+    | Texp_newtype s -> Pexp_newtype (mkloc s loc, sexp)
+    | Texp_newtype' (_id, label_loc) -> Pexp_newtype (label_loc, sexp)
+  in
+  Exp.mk ~loc ~attrs desc
+
+let case : type k . mapper -> k case -> _ = fun sub {c_lhs; c_guard; c_rhs} ->
+  {
+   pc_lhs = sub.pat sub c_lhs;
+   pc_guard = Option.map (sub.expr sub) c_guard;
+   pc_rhs = sub.expr sub c_rhs;
+  }
+
+let value_binding sub vb =
+  let loc = sub.location sub vb.vb_loc in
+  let attrs = sub.attributes sub vb.vb_attributes in
+  Vb.mk ~loc ~attrs
+    (sub.pat sub vb.vb_pat)
+    (sub.expr sub vb.vb_expr)
+
+let expression sub exp =
+  let loc = sub.location sub exp.exp_loc in
+  let attrs = sub.attributes sub exp.exp_attributes in
+  let desc =
+    match exp.exp_desc with
+      Texp_ident (_path, lid, _) -> Pexp_ident (map_loc sub lid)
+    | Texp_constant cst -> Pexp_constant (constant cst)
+    | Texp_let (rec_flag, list, exp) ->
+        Pexp_let (rec_flag,
+          List.map (sub.value_binding sub) list,
+          sub.expr sub exp)
+
+    (* Pexp_function can't have a label, so we split in 3 cases. *)
+    (* One case, no guard: It's a fun. *)
+    | Texp_function { arg_label; cases = [{c_lhs=p; c_guard=None; c_rhs=e}];
+          _ } ->
+        Pexp_fun (arg_label, None, sub.pat sub p, sub.expr sub e)
+    (* No label: it's a function. *)
+    | Texp_function { arg_label = Nolabel; cases; _; } ->
+        Pexp_function (List.map (sub.case sub) cases)
+    (* Mix of both, we generate `fun ~label:$name$ -> match $name$ with ...` *)
+    | Texp_function { arg_label = Labelled s | Optional s as label; cases;
+          _ } ->
+        let name = fresh_name s exp.exp_env in
+        Pexp_fun (label, None, Pat.var ~loc {loc;txt = name },
+          Exp.match_ ~loc (Exp.ident ~loc {loc;txt= Lident name})
+                          (List.map (sub.case sub) cases))
+    | Texp_apply (exp, list) ->
+        Pexp_apply (sub.expr sub exp,
+          List.fold_right (fun (label, expo) list ->
+              match expo with
+                None -> list
+              | Some exp -> (label, sub.expr sub exp) :: list
+          ) list [])
+    | Texp_match (exp, cases, _) ->
+      Pexp_match (sub.expr sub exp, List.map (sub.case sub) cases)
+    | Texp_try (exp, cases) ->
+        Pexp_try (sub.expr sub exp, List.map (sub.case sub) cases)
+    | Texp_tuple list ->
+        Pexp_tuple (List.map (sub.expr sub) list)
+    | Texp_construct (lid, _, args) ->
+        Pexp_construct (map_loc sub lid,
+          (match args with
+              [] -> None
+          | [ arg ] -> Some (sub.expr sub arg)
+          | args ->
+              Some
+                (Exp.tuple ~loc (List.map (sub.expr sub) args))
+          ))
+    | Texp_variant (label, expo) ->
+        Pexp_variant (label, Option.map (sub.expr sub) expo)
+    | Texp_record { fields; extended_expression; _ } ->
+        let list = Array.fold_left (fun l -> function
+            | _, Kept _ -> l
+            | _, Overridden (lid, exp) -> (lid, sub.expr sub exp) :: l)
+            [] fields
+        in
+        Pexp_record (list, Option.map (sub.expr sub) extended_expression)
+    | Texp_field (exp, lid, _label) ->
+        Pexp_field (sub.expr sub exp, map_loc sub lid)
+    | Texp_setfield (exp1, lid, _label, exp2) ->
+        Pexp_setfield (sub.expr sub exp1, map_loc sub lid,
+          sub.expr sub exp2)
+    | Texp_array list ->
+        Pexp_array (List.map (sub.expr sub) list)
+    | Texp_ifthenelse (exp1, exp2, expo) ->
+        Pexp_ifthenelse (sub.expr sub exp1,
+          sub.expr sub exp2,
+          Option.map (sub.expr sub) expo)
+    | Texp_sequence (exp1, exp2) ->
+        Pexp_sequence (sub.expr sub exp1, sub.expr sub exp2)
+    | Texp_while (exp1, exp2) ->
+        Pexp_while (sub.expr sub exp1, sub.expr sub exp2)
+    | Texp_for (_id, name, exp1, exp2, dir, exp3) ->
+        Pexp_for (name,
+          sub.expr sub exp1, sub.expr sub exp2,
+          dir, sub.expr sub exp3)
+    | Texp_send (exp, meth, _) ->
+        Pexp_send (sub.expr sub exp, match meth with
+            Tmeth_name name -> mkloc name loc
+          | Tmeth_val id -> mkloc (Ident.name id) loc)
+    | Texp_new (_path, lid, _) -> Pexp_new (map_loc sub lid)
+    | Texp_instvar (_, path, name) ->
+      Pexp_ident ({loc = sub.location sub name.loc ; txt = lident_of_path path})
+    | Texp_setinstvar (_, _path, lid, exp) ->
+        Pexp_setinstvar (map_loc sub lid, sub.expr sub exp)
+    | Texp_override (_, list) ->
+        Pexp_override (List.map (fun (_path, lid, exp) ->
+              (map_loc sub lid, sub.expr sub exp)
+          ) list)
+    | Texp_letmodule (_id, name, _pres, mexpr, exp) ->
+        Pexp_letmodule (name, sub.module_expr sub mexpr,
+          sub.expr sub exp)
+    | Texp_letexception (ext, exp) ->
+        Pexp_letexception (sub.extension_constructor sub ext,
+                           sub.expr sub exp)
+    | Texp_assert exp -> Pexp_assert (sub.expr sub exp)
+    | Texp_lazy exp -> Pexp_lazy (sub.expr sub exp)
+    | Texp_object (cl, _) ->
+        Pexp_object (sub.class_structure sub cl)
+    | Texp_pack (mexpr) ->
+        Pexp_pack (sub.module_expr sub mexpr)
+    | Texp_letop {let_; ands; body; _} ->
+        let pat, and_pats =
+          extract_letop_patterns (List.length ands) body.c_lhs
+        in
+        let let_ = sub.binding_op sub let_ pat in
+        let ands = List.map2 (sub.binding_op sub) ands and_pats in
+        let body = sub.expr sub body.c_rhs in
+        Pexp_letop {let_; ands; body }
+    | Texp_unreachable ->
+        Pexp_unreachable
+    | Texp_extension_constructor (lid, _) ->
+        Pexp_extension ({ txt = "ocaml.extension_constructor"; loc },
+                        PStr [ Str.eval ~loc
+                                 (Exp.construct ~loc (map_loc sub lid) None)
+                             ])
+    | Texp_open (od, exp) ->
+        Pexp_open (sub.open_declaration sub od, sub.expr sub exp)
+    | Texp_hole ->
+        let id = Location.mkloc hole_txt loc in
+        Pexp_extension (id, PStr [])
+  in
+  List.fold_right (exp_extra sub) exp.exp_extra
+    (Exp.mk ~loc ~attrs desc)
+
+let binding_op sub bop pat =
+  let pbop_op = bop.bop_op_name in
+  let pbop_pat = sub.pat sub pat in
+  let pbop_exp = sub.expr sub bop.bop_exp in
+  let pbop_loc = bop.bop_loc in
+  {pbop_op; pbop_pat; pbop_exp; pbop_loc}
+
+let package_type sub pack =
+  (map_loc sub pack.pack_txt,
+    List.map (fun (s, ct) ->
+        (s, sub.typ sub ct)) pack.pack_fields)
+
+let module_type_declaration sub mtd =
+  let loc = sub.location sub mtd.mtd_loc in
+  let attrs = sub.attributes sub mtd.mtd_attributes in
+  Mtd.mk ~loc ~attrs
+    ?typ:(Option.map (sub.module_type sub) mtd.mtd_type)
+    (map_loc sub mtd.mtd_name)
+
+let signature sub sg =
+  List.map (sub.signature_item sub) sg.sig_items
+
+let signature_item sub item =
+  let loc = sub.location sub item.sig_loc in
+  let desc =
+    match item.sig_desc with
+      Tsig_value v ->
+        Psig_value (sub.value_description sub v)
+    | Tsig_type (rec_flag, list) ->
+        Psig_type (rec_flag, List.map (sub.type_declaration sub) list)
+    | Tsig_typesubst list ->
+        Psig_typesubst (List.map (sub.type_declaration sub) list)
+    | Tsig_typext tyext ->
+        Psig_typext (sub.type_extension sub tyext)
+    | Tsig_exception ext ->
+        Psig_exception (sub.type_exception sub ext)
+    | Tsig_module md ->
+        Psig_module (sub.module_declaration sub md)
+    | Tsig_modsubst ms ->
+        Psig_modsubst (sub.module_substitution sub ms)
+    | Tsig_recmodule list ->
+        Psig_recmodule (List.map (sub.module_declaration sub) list)
+    | Tsig_modtype mtd ->
+        Psig_modtype (sub.module_type_declaration sub mtd)
+    | Tsig_modtypesubst mtd ->
+        Psig_modtypesubst (sub.module_type_declaration sub mtd)
+    | Tsig_open od ->
+        Psig_open (sub.open_description sub od)
+    | Tsig_include incl ->
+        Psig_include (sub.include_description sub incl)
+    | Tsig_class list ->
+        Psig_class (List.map (sub.class_description sub) list)
+    | Tsig_class_type list ->
+        Psig_class_type (List.map (sub.class_type_declaration sub) list)
+    | Tsig_attribute x ->
+        Psig_attribute x
+  in
+  Sig.mk ~loc desc
+
+let module_declaration sub md =
+  let loc = sub.location sub md.md_loc in
+  let attrs = sub.attributes sub md.md_attributes in
+  Md.mk ~loc ~attrs
+    (map_loc sub md.md_name)
+    (sub.module_type sub md.md_type)
+
+let module_substitution sub ms =
+  let loc = sub.location sub ms.ms_loc in
+  let attrs = sub.attributes sub ms.ms_attributes in
+  Ms.mk ~loc ~attrs
+    (map_loc sub ms.ms_name)
+    (map_loc sub ms.ms_txt)
+
+let include_infos f sub incl =
+  let loc = sub.location sub incl.incl_loc in
+  let attrs = sub.attributes sub incl.incl_attributes in
+  Incl.mk ~loc ~attrs
+    (f sub incl.incl_mod)
+
+let include_declaration sub = include_infos sub.module_expr sub
+let include_description sub = include_infos sub.module_type sub
+
+let class_infos f sub ci =
+  let loc = sub.location sub ci.ci_loc in
+  let attrs = sub.attributes sub ci.ci_attributes in
+  Ci.mk ~loc ~attrs
+    ~virt:ci.ci_virt
+    ~params:(List.map (type_parameter sub) ci.ci_params)
+    (map_loc sub ci.ci_id_name)
+    (f sub ci.ci_expr)
+
+let class_declaration sub = class_infos sub.class_expr sub
+let class_description sub = class_infos sub.class_type sub
+let class_type_declaration sub = class_infos sub.class_type sub
+
+let functor_parameter sub : functor_parameter -> Parsetree.functor_parameter =
+  function
+  | Unit -> Unit
+  | Named (_, name, mtype) -> Named (name, sub.module_type sub mtype)
+
+let module_type (sub : mapper) mty =
+  let loc = sub.location sub mty.mty_loc in
+  let attrs = sub.attributes sub mty.mty_attributes in
+  let desc = match mty.mty_desc with
+      Tmty_ident (_path, lid) -> Pmty_ident (map_loc sub lid)
+    | Tmty_alias (_path, lid) -> Pmty_alias (map_loc sub lid)
+    | Tmty_signature sg -> Pmty_signature (sub.signature sub sg)
+    | Tmty_functor (arg, mtype2) ->
+        Pmty_functor (functor_parameter sub arg, sub.module_type sub mtype2)
+    | Tmty_with (mtype, list) ->
+        Pmty_with (sub.module_type sub mtype,
+          List.map (sub.with_constraint sub) list)
+    | Tmty_typeof mexpr ->
+        Pmty_typeof (sub.module_expr sub mexpr)
+  in
+  Mty.mk ~loc ~attrs desc
+
+let with_constraint sub (_path, lid, cstr) =
+  match cstr with
+  | Twith_type decl ->
+      Pwith_type (map_loc sub lid, sub.type_declaration sub decl)
+  | Twith_module (_path, lid2) ->
+      Pwith_module (map_loc sub lid, map_loc sub lid2)
+  | Twith_modtype mty ->
+      let mty = sub.module_type sub mty in
+      Pwith_modtype (map_loc sub lid,mty)
+  | Twith_typesubst decl ->
+     Pwith_typesubst (map_loc sub lid, sub.type_declaration sub decl)
+  | Twith_modsubst (_path, lid2) ->
+      Pwith_modsubst (map_loc sub lid, map_loc sub lid2)
+  | Twith_modtypesubst mty ->
+      let mty = sub.module_type sub mty in
+      Pwith_modtypesubst (map_loc sub lid, mty)
+
+let module_expr (sub : mapper) mexpr =
+  let loc = sub.location sub mexpr.mod_loc in
+  let attrs = sub.attributes sub mexpr.mod_attributes in
+  match mexpr.mod_desc with
+      Tmod_constraint (m, _, Tmodtype_implicit, _ ) ->
+        sub.module_expr sub m
+    | _ ->
+        let desc = match mexpr.mod_desc with
+            Tmod_ident (_p, lid) -> Pmod_ident (map_loc sub lid)
+          | Tmod_structure st -> Pmod_structure (sub.structure sub st)
+          | Tmod_functor (arg, mexpr) ->
+              Pmod_functor
+                (functor_parameter sub arg, sub.module_expr sub mexpr)
+          | Tmod_apply (mexp1, mexp2, _) ->
+              Pmod_apply (sub.module_expr sub mexp1, sub.module_expr sub mexp2)
+          | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) ->
+              Pmod_constraint (sub.module_expr sub mexpr,
+                sub.module_type sub mtype)
+          | Tmod_constraint (_mexpr, _, Tmodtype_implicit, _) ->
+              assert false
+          | Tmod_unpack (exp, _pack) ->
+              Pmod_unpack (sub.expr sub exp)
+              (* TODO , sub.package_type sub pack) *)
+          | Tmod_hole ->
+              let id = Location.mkloc hole_txt loc in
+              Pmod_extension (id, PStr [])
+        in
+        Mod.mk ~loc ~attrs desc
+
+let class_expr sub cexpr =
+  let loc = sub.location sub cexpr.cl_loc in
+  let attrs = sub.attributes sub cexpr.cl_attributes in
+  let desc = match cexpr.cl_desc with
+    | Tcl_constraint ( { cl_desc = Tcl_ident (_path, lid, tyl); _ },
+                       None, _, _, _ ) ->
+        Pcl_constr (map_loc sub lid,
+          List.map (sub.typ sub) tyl)
+    | Tcl_structure clstr -> Pcl_structure (sub.class_structure sub clstr)
+
+    | Tcl_fun (label, pat, _pv, cl, _partial) ->
+        Pcl_fun (label, None, sub.pat sub pat, sub.class_expr sub cl)
+
+    | Tcl_apply (cl, args) ->
+        Pcl_apply (sub.class_expr sub cl,
+          List.fold_right (fun (label, expo) list ->
+              match expo with
+                None -> list
+              | Some exp -> (label, sub.expr sub exp) :: list
+          ) args [])
+
+    | Tcl_let (rec_flat, bindings, _ivars, cl) ->
+        Pcl_let (rec_flat,
+          List.map (sub.value_binding sub) bindings,
+          sub.class_expr sub cl)
+
+    | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) ->
+        Pcl_constraint (sub.class_expr sub cl,  sub.class_type sub clty)
+
+    | Tcl_open (od, e) ->
+        Pcl_open (sub.open_description sub od, sub.class_expr sub e)
+
+    | Tcl_ident _ -> assert false
+    | Tcl_constraint (_, None, _, _, _) -> assert false
+  in
+  Cl.mk ~loc ~attrs desc
+
+let class_type sub ct =
+  let loc = sub.location sub ct.cltyp_loc in
+  let attrs = sub.attributes sub ct.cltyp_attributes in
+  let desc = match ct.cltyp_desc with
+      Tcty_signature csg -> Pcty_signature (sub.class_signature sub csg)
+    | Tcty_constr (_path, lid, list) ->
+        Pcty_constr (map_loc sub lid, List.map (sub.typ sub) list)
+    | Tcty_arrow (label, ct, cl) ->
+        Pcty_arrow (label, sub.typ sub ct, sub.class_type sub cl)
+    | Tcty_open (od, e) ->
+        Pcty_open (sub.open_description sub od, sub.class_type sub e)
+  in
+  Cty.mk ~loc ~attrs desc
+
+let class_signature sub cs =
+  {
+    pcsig_self = sub.typ sub cs.csig_self;
+    pcsig_fields = List.map (sub.class_type_field sub) cs.csig_fields;
+  }
+
+let class_type_field sub ctf =
+  let loc = sub.location sub ctf.ctf_loc in
+  let attrs = sub.attributes sub ctf.ctf_attributes in
+  let desc = match ctf.ctf_desc with
+      Tctf_inherit ct -> Pctf_inherit (sub.class_type sub ct)
+    | Tctf_val (s, mut, virt, ct) ->
+        Pctf_val (mkloc s loc, mut, virt, sub.typ sub ct)
+    | Tctf_method  (s, priv, virt, ct) ->
+        Pctf_method  (mkloc s loc, priv, virt, sub.typ sub ct)
+    | Tctf_constraint  (ct1, ct2) ->
+        Pctf_constraint (sub.typ sub ct1, sub.typ sub ct2)
+    | Tctf_attribute x -> Pctf_attribute x
+  in
+  Ctf.mk ~loc ~attrs desc
+
+let core_type sub ct =
+  let loc = sub.location sub ct.ctyp_loc in
+  let attrs = sub.attributes sub ct.ctyp_attributes in
+  let desc = match ct.ctyp_desc with
+      Ttyp_any -> Ptyp_any
+    | Ttyp_var s -> Ptyp_var s
+    | Ttyp_arrow (label, ct1, ct2) ->
+        Ptyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2)
+    | Ttyp_tuple list -> Ptyp_tuple (List.map (sub.typ sub) list)
+    | Ttyp_constr (_path, lid, list) ->
+        Ptyp_constr (map_loc sub lid,
+          List.map (sub.typ sub) list)
+    | Ttyp_object (list, o) ->
+        Ptyp_object
+          (List.map (sub.object_field sub) list, o)
+    | Ttyp_class (_path, lid, list) ->
+        Ptyp_class (map_loc sub lid, List.map (sub.typ sub) list)
+    | Ttyp_alias (ct, s) ->
+        Ptyp_alias (sub.typ sub ct, s)
+    | Ttyp_variant (list, bool, labels) ->
+        Ptyp_variant (List.map (sub.row_field sub) list, bool, labels)
+    | Ttyp_poly (list, ct) ->
+        let list = List.map (fun v -> mkloc v loc) list in
+        Ptyp_poly (list, sub.typ sub ct)
+    | Ttyp_package pack -> Ptyp_package (sub.package_type sub pack)
+  in
+  Typ.mk ~loc ~attrs desc
+
+let class_structure sub cs =
+  let rec remove_self = function
+    | { pat_desc = Tpat_alias (p, id, _s) }
+      when string_is_prefix "selfpat-" (Ident.name id) ->
+        remove_self p
+    | p -> p
+  in
+  { pcstr_self = sub.pat sub (remove_self cs.cstr_self);
+    pcstr_fields = List.map (sub.class_field sub) cs.cstr_fields;
+  }
+
+let row_field sub {rf_loc; rf_desc; rf_attributes;} =
+  let loc = sub.location sub rf_loc in
+  let attrs = sub.attributes sub rf_attributes in
+  let desc = match rf_desc with
+    | Ttag (label, bool, list) ->
+        Rtag (label, bool, List.map (sub.typ sub) list)
+    | Tinherit ct -> Rinherit (sub.typ sub ct)
+  in
+  Rf.mk ~loc ~attrs desc
+
+let object_field sub {of_loc; of_desc; of_attributes;} =
+  let loc = sub.location sub of_loc in
+  let attrs = sub.attributes sub of_attributes in
+  let desc = match of_desc with
+    | OTtag (label, ct) ->
+        Otag (label, sub.typ sub ct)
+    | OTinherit ct -> Oinherit (sub.typ sub ct)
+  in
+  Of.mk ~loc ~attrs desc
+
+and is_self_pat = function
+  | { pat_desc = Tpat_alias(_pat, id, _) } ->
+      string_is_prefix "self-" (Ident.name id)
+  | _ -> false
+
+let class_field sub cf =
+  let loc = sub.location sub cf.cf_loc in
+  let attrs = sub.attributes sub cf.cf_attributes in
+  let desc = match cf.cf_desc with
+      Tcf_inherit (ovf, cl, super, _vals, _meths) ->
+        Pcf_inherit (ovf, sub.class_expr sub cl,
+                     Option.map (fun v -> mkloc v loc) super)
+    | Tcf_constraint (cty, cty') ->
+        Pcf_constraint (sub.typ sub cty, sub.typ sub cty')
+    | Tcf_val (lab, mut, _, Tcfk_virtual cty, _) ->
+        Pcf_val (lab, mut, Cfk_virtual (sub.typ sub cty))
+    | Tcf_val (lab, mut, _, Tcfk_concrete (o, exp), _) ->
+        Pcf_val (lab, mut, Cfk_concrete (o, sub.expr sub exp))
+    | Tcf_method (lab, priv, Tcfk_virtual cty) ->
+        Pcf_method (lab, priv, Cfk_virtual (sub.typ sub cty))
+    | Tcf_method (lab, priv, Tcfk_concrete (o, exp)) ->
+        let remove_fun_self = function
+          | { exp_desc =
+              Texp_function { arg_label = Nolabel; cases = [case]; _ } }
+            when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs
+          | e -> e
+        in
+        let exp = remove_fun_self exp in
+        Pcf_method (lab, priv, Cfk_concrete (o, sub.expr sub exp))
+    | Tcf_initializer exp ->
+        let remove_fun_self = function
+          | { exp_desc =
+              Texp_function { arg_label = Nolabel; cases = [case]; _ } }
+            when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs
+          | e -> e
+        in
+        let exp = remove_fun_self exp in
+        Pcf_initializer (sub.expr sub exp)
+    | Tcf_attribute x -> Pcf_attribute x
+  in
+  Cf.mk ~loc ~attrs desc
+
+let location _sub l = l
+
+let default_mapper =
+  {
+    attribute = attribute;
+    attributes = attributes;
+    binding_op = binding_op;
+    structure = structure;
+    structure_item = structure_item;
+    module_expr = module_expr;
+    signature = signature;
+    signature_item = signature_item;
+    module_type = module_type;
+    with_constraint = with_constraint;
+    class_declaration = class_declaration;
+    class_expr = class_expr;
+    class_field = class_field;
+    class_structure = class_structure;
+    class_type = class_type;
+    class_type_field = class_type_field;
+    class_signature = class_signature;
+    class_type_declaration = class_type_declaration;
+    class_description = class_description;
+    type_declaration = type_declaration;
+    type_kind = type_kind;
+    typ = core_type;
+    type_extension = type_extension;
+    type_exception = type_exception;
+    extension_constructor = extension_constructor;
+    value_description = value_description;
+    pat = pattern;
+    expr = expression;
+    module_declaration = module_declaration;
+    module_substitution = module_substitution;
+    module_type_declaration = module_type_declaration;
+    module_binding = module_binding;
+    package_type = package_type ;
+    open_declaration = open_declaration;
+    open_description = open_description;
+    include_description = include_description;
+    include_declaration = include_declaration;
+    value_binding = value_binding;
+    constructor_declaration = constructor_declaration;
+    label_declaration = label_declaration;
+    case = case;
+    location = location;
+    row_field = row_field ;
+    object_field = object_field ;
+  }
+
+let untype_structure ?(mapper : mapper = default_mapper) structure =
+  mapper.structure mapper structure
+
+let untype_signature ?(mapper : mapper = default_mapper) signature =
+  mapper.signature mapper signature
+
+(* Merlin *)
+let untype_pattern pat =
+  default_mapper.pat default_mapper pat
+
+let untype_expression exp =
+  default_mapper.expr default_mapper exp
diff --git a/src/ocaml/typing/untypeast.mli b/src/ocaml/typing/untypeast.mli
new file mode 100644
index 0000000..7f9e386
--- /dev/null
+++ b/src/ocaml/typing/untypeast.mli
@@ -0,0 +1,89 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*      Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay)   *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Parsetree
+
+val lident_of_path : Path.t -> Longident.t
+
+type mapper = {
+  attribute: mapper -> Typedtree.attribute -> attribute;
+  attributes: mapper -> Typedtree.attribute list -> attribute list;
+  binding_op:
+    mapper ->
+    Typedtree.binding_op -> Typedtree.pattern -> binding_op;
+  case: 'k . mapper -> 'k Typedtree.case -> case;
+  class_declaration: mapper -> Typedtree.class_declaration -> class_declaration;
+  class_description: mapper -> Typedtree.class_description -> class_description;
+  class_expr: mapper -> Typedtree.class_expr -> class_expr;
+  class_field: mapper -> Typedtree.class_field -> class_field;
+  class_signature: mapper -> Typedtree.class_signature -> class_signature;
+  class_structure: mapper -> Typedtree.class_structure -> class_structure;
+  class_type: mapper -> Typedtree.class_type -> class_type;
+  class_type_declaration: mapper -> Typedtree.class_type_declaration
+                          -> class_type_declaration;
+  class_type_field: mapper -> Typedtree.class_type_field -> class_type_field;
+  constructor_declaration: mapper -> Typedtree.constructor_declaration
+                           -> constructor_declaration;
+  expr: mapper -> Typedtree.expression -> expression;
+  extension_constructor: mapper -> Typedtree.extension_constructor
+                         -> extension_constructor;
+  include_declaration:
+    mapper -> Typedtree.include_declaration -> include_declaration;
+  include_description:
+    mapper -> Typedtree.include_description -> include_description;
+  label_declaration:
+    mapper -> Typedtree.label_declaration -> label_declaration;
+  location: mapper -> Location.t -> Location.t;
+  module_binding: mapper -> Typedtree.module_binding -> module_binding;
+  module_declaration:
+    mapper -> Typedtree.module_declaration -> module_declaration;
+  module_substitution:
+    mapper -> Typedtree.module_substitution -> module_substitution;
+  module_expr: mapper -> Typedtree.module_expr -> module_expr;
+  module_type: mapper -> Typedtree.module_type -> module_type;
+  module_type_declaration:
+    mapper -> Typedtree.module_type_declaration -> module_type_declaration;
+  package_type: mapper -> Typedtree.package_type -> package_type;
+  open_declaration: mapper -> Typedtree.open_declaration -> open_declaration;
+  open_description: mapper -> Typedtree.open_description -> open_description;
+  pat: 'k . mapper -> 'k Typedtree.general_pattern -> pattern;
+  row_field: mapper -> Typedtree.row_field -> row_field;
+  object_field: mapper -> Typedtree.object_field -> object_field;
+  signature: mapper -> Typedtree.signature -> signature;
+  signature_item: mapper -> Typedtree.signature_item -> signature_item;
+  structure: mapper -> Typedtree.structure -> structure;
+  structure_item: mapper -> Typedtree.structure_item -> structure_item;
+  typ: mapper -> Typedtree.core_type -> core_type;
+  type_declaration: mapper -> Typedtree.type_declaration -> type_declaration;
+  type_extension: mapper -> Typedtree.type_extension -> type_extension;
+  type_exception: mapper -> Typedtree.type_exception -> type_exception;
+  type_kind: mapper -> Typedtree.type_kind -> type_kind;
+  value_binding: mapper -> Typedtree.value_binding -> value_binding;
+  value_description: mapper -> Typedtree.value_description -> value_description;
+  with_constraint:
+    mapper -> (Path.t * Longident.t Location.loc * Typedtree.with_constraint)
+    -> with_constraint;
+}
+
+val default_mapper : mapper
+
+val untype_structure : ?mapper:mapper -> Typedtree.structure -> structure
+val untype_signature : ?mapper:mapper -> Typedtree.signature -> signature
+
+val constant : Asttypes.constant -> Parsetree.constant
+
+(* Merlin *)
+val untype_pattern : _ Typedtree.general_pattern -> Parsetree.pattern
+val untype_expression : Typedtree.expression -> Parsetree.expression
diff --git a/src/ocaml/utils/build_path_prefix_map.ml b/src/ocaml/utils/build_path_prefix_map.ml
new file mode 100644
index 0000000..c204d3a
--- /dev/null
+++ b/src/ocaml/utils/build_path_prefix_map.ml
@@ -0,0 +1,119 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*            Gabriel Scherer, projet Parsifal, INRIA Saclay              *)
+(*                                                                        *)
+(*   Copyright 2017 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type path = string
+type path_prefix = string
+type error_message = string
+
+let errorf fmt = Printf.kprintf (fun err -> Error err) fmt
+
+let encode_prefix str =
+  let buf = Buffer.create (String.length str) in
+  let push_char = function
+    | '%' -> Buffer.add_string buf "%#"
+    | '=' -> Buffer.add_string buf "%+"
+    | ':' -> Buffer.add_string buf "%."
+    | c -> Buffer.add_char buf c
+  in
+  String.iter push_char str;
+  Buffer.contents buf
+
+let decode_prefix str =
+  let buf = Buffer.create (String.length str) in
+  let rec loop i =
+    if i >= String.length str
+    then Ok (Buffer.contents buf)
+    else match str.[i] with
+      | ('=' | ':') as c ->
+        errorf "invalid character '%c' in key or value" c
+      | '%' ->
+        let push c = Buffer.add_char buf c; loop (i + 2) in
+        if i + 1 = String.length str then
+          errorf "invalid encoded string %S (trailing '%%')" str
+        else begin match str.[i + 1] with
+            | '#' -> push '%'
+            | '+' -> push '='
+            | '.' -> push ':'
+            | c -> errorf "invalid %%-escaped character '%c'" c
+        end
+      | c ->
+        Buffer.add_char buf c;
+        loop (i + 1)
+  in loop 0
+
+type pair = { target: path_prefix; source : path_prefix }
+
+let encode_pair { target; source } =
+  String.concat "=" [encode_prefix target; encode_prefix source]
+
+let decode_pair str =
+  match String.index str '=' with
+  | exception Not_found ->
+    errorf "invalid key/value pair %S, no '=' separator" str
+  | equal_pos ->
+    let encoded_target = String.sub str 0 equal_pos in
+    let encoded_source =
+      String.sub str (equal_pos + 1) (String.length str - equal_pos - 1) in
+    match decode_prefix encoded_target, decode_prefix encoded_source with
+    | Ok target, Ok source -> Ok { target; source }
+    | ((Error _ as err), _) | (_, (Error _ as err)) -> err
+
+type map = pair option list
+
+let encode_map map =
+  let encode_elem = function
+    | None -> ""
+    | Some pair -> encode_pair pair
+  in
+  List.map encode_elem map
+  |> String.concat ":"
+
+let decode_map str =
+  let exception Shortcut of error_message in
+  let decode_or_empty = function
+    | "" -> None
+    | pair ->
+      begin match decode_pair pair with
+        | Ok str -> Some str
+        | Error err -> raise (Shortcut err)
+      end
+  in
+  let pairs = String.split_on_char ':' str in
+  match List.map decode_or_empty pairs with
+  | exception (Shortcut err) -> Error err
+  | map -> Ok map
+
+let rewrite_opt prefix_map path =
+  let is_prefix = function
+    | None -> false
+    | Some { target = _; source } ->
+      String.length source <= String.length path
+      && String.equal source (String.sub path 0 (String.length source))
+  in
+  match
+    List.find is_prefix
+      (* read key/value pairs from right to left, as the spec demands *)
+      (List.rev prefix_map)
+  with
+  | exception Not_found -> None
+  | None -> None
+  | Some { source; target } ->
+      Some (target ^ (String.sub path (String.length source)
+                       (String.length path - String.length source)))
+
+let rewrite prefix_map path =
+  match rewrite_opt prefix_map path with
+  | None -> path
+  | Some path -> path
diff --git a/src/ocaml/utils/build_path_prefix_map.mli b/src/ocaml/utils/build_path_prefix_map.mli
new file mode 100644
index 0000000..dbcc8dc
--- /dev/null
+++ b/src/ocaml/utils/build_path_prefix_map.mli
@@ -0,0 +1,47 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*            Gabriel Scherer, projet Parsifal, INRIA Saclay              *)
+(*                                                                        *)
+(*   Copyright 2017 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Rewrite paths for reproducible builds
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+
+type path = string
+type path_prefix = string
+type error_message = string
+
+val encode_prefix : path_prefix -> string
+val decode_prefix : string -> (path_prefix, error_message) result
+
+type pair = { target: path_prefix; source : path_prefix }
+
+val encode_pair : pair -> string
+val decode_pair : string -> (pair, error_message) result
+
+type map = pair option list
+
+val encode_map : map -> string
+val decode_map : string -> (map, error_message) result
+
+val rewrite_opt : map -> path -> path option
+(** [rewrite_opt map path] tries to find a source in [map]
+    that is a prefix of the input [path]. If it succeeds,
+    it replaces this prefix with the corresponding target.
+    If it fails, it just returns [None]. *)
+
+val rewrite : map -> path -> path
diff --git a/src/ocaml/utils/clflags.ml b/src/ocaml/utils/clflags.ml
new file mode 100644
index 0000000..694ca9c
--- /dev/null
+++ b/src/ocaml/utils/clflags.ml
@@ -0,0 +1,40 @@
+(** {0 OCaml compiler compatible command-line parameters} *)
+
+let include_dirs        = ref []
+let fast                = ref false
+let classic             = ref false
+let principal           = ref false
+let real_paths          = ref true
+let recursive_types     = ref false
+let strict_sequence     = ref false
+let applicative_functors = ref true
+
+let unsafe_string =
+  ref (
+    match My_config.ocamlversion with
+    | `OCaml_4_02_0 | `OCaml_4_02_1 | `OCaml_4_02_2 | `OCaml_4_02_3
+    | `OCaml_4_03_0
+    | `OCaml_4_04_0
+    | `OCaml_4_05_0 -> true
+    | _ -> false (* -safe-string became the new default in 4.06 *)
+  )
+
+let nopervasives        = ref false
+let strict_formats      = ref false
+let open_modules        = ref []
+
+let annotations         = ref false
+let binary_annotations  = ref true
+let print_types         = ref false
+let native_code         = ref false
+let error_size          = ref 500
+let dont_write_files    = ref true
+let keep_locs           = ref true
+let keep_docs           = ref false
+let transparent_modules = ref true
+let for_package         = ref None
+let debug               = ref false
+let opaque              = ref false
+let unboxed_types       = ref false
+
+let locations = ref true
diff --git a/src/ocaml/utils/clflags.mli b/src/ocaml/utils/clflags.mli
new file mode 100644
index 0000000..e06b7a4
--- /dev/null
+++ b/src/ocaml/utils/clflags.mli
@@ -0,0 +1,38 @@
+(** {0 OCaml compiler compatible command-line parameters}
+
+    For compatibility with typechecker.
+    Argument parsing / build environment construction happens elsewhere.
+*)
+
+(** {1 Relevant settings}
+    Parameters from OCaml compiler which affect Merlin behavior. *)
+val include_dirs         : string list ref
+val fast                 : bool ref
+val classic              : bool ref
+val principal            : bool ref
+val real_paths           : bool ref
+val recursive_types      : bool ref
+val strict_sequence      : bool ref
+val applicative_functors : bool ref
+val unsafe_string        : bool ref
+val nopervasives         : bool ref
+val strict_formats       : bool ref
+val open_modules         : string list ref
+
+(** {1 Dummy values}
+    Ignored by merlin but kept for compatibility with upstream code. *)
+val annotations          : bool ref
+val binary_annotations   : bool ref
+val print_types          : bool ref
+val native_code          : bool ref
+val dont_write_files     : bool ref
+val error_size           : int ref (* max size of module related errors *)
+val keep_locs            : bool ref
+val keep_docs            : bool ref
+val transparent_modules  : bool ref
+val for_package          : string option ref
+val debug                : bool ref
+val opaque               : bool ref
+val unboxed_types        : bool ref
+
+val locations            : bool ref
diff --git a/src/ocaml/utils/config.ml b/src/ocaml/utils/config.ml
new file mode 100644
index 0000000..a5d2854
--- /dev/null
+++ b/src/ocaml/utils/config.ml
@@ -0,0 +1,58 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(***********************************************************************)
+(**                                                                   **)
+(**               WARNING WARNING WARNING                             **)
+(**                                                                   **)
+(** When you change this file, you must make the parallel change      **)
+(** in config.mlbuild                                                 **)
+(**                                                                   **)
+(***********************************************************************)
+
+
+(* The main OCaml version string has moved to ../VERSION *)
+let version = Sys.ocaml_version
+
+let flambda = false
+
+let exec_magic_number = "Caml1999X030"
+    (* exec_magic_number is duplicated in runtime/caml/exec.h *)
+and cmi_magic_number = "Caml1999I030"
+and cmo_magic_number = "Caml1999O030"
+and cma_magic_number = "Caml1999A030"
+and cmx_magic_number =
+  if flambda then
+    "Caml1999y030"
+  else
+    "Caml1999Y030"
+and cmxa_magic_number =
+  if flambda then
+    "Caml1999z030"
+  else
+    "Caml1999Z030"
+and ast_impl_magic_number = "Caml1999M030"
+and ast_intf_magic_number = "Caml1999N030"
+and cmxs_magic_number = "Caml1999D030"
+and cmt_magic_number = "Caml1999T030"
+
+let interface_suffix = ref ".mli"
+
+let max_tag = 245
+
+let safe_string = true
+let flat_float_array = false
+
+let merlin = true
diff --git a/src/ocaml/utils/config.mli b/src/ocaml/utils/config.mli
new file mode 100644
index 0000000..3cea743
--- /dev/null
+++ b/src/ocaml/utils/config.mli
@@ -0,0 +1,55 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* System configuration *)
+
+val version: string
+        (* The current version number of the system *)
+
+val interface_suffix: string ref
+        (* Suffix for interface file names *)
+
+val exec_magic_number: string
+        (* Magic number for bytecode executable files *)
+val cmi_magic_number: string
+        (* Magic number for compiled interface files *)
+val cmo_magic_number: string
+        (* Magic number for object bytecode files *)
+val cma_magic_number: string
+        (* Magic number for archive files *)
+val cmx_magic_number: string
+        (* Magic number for compilation unit descriptions *)
+val cmxa_magic_number: string
+        (* Magic number for libraries of compilation unit descriptions *)
+val ast_intf_magic_number: string
+        (* Magic number for file holding an interface syntax tree *)
+val ast_impl_magic_number: string
+        (* Magic number for file holding an implementation syntax tree *)
+val cmxs_magic_number: string
+        (* Magic number for dynamically-loadable plugins *)
+val cmt_magic_number: string
+        (* Magic number for compiled interface files *)
+
+val max_tag: int
+        (* Biggest tag that can be stored in the header of a regular block. *)
+
+val safe_string: bool
+val flat_float_array: bool
+
+(**/**)
+
+val merlin : bool
+
+(**/**)
diff --git a/src/ocaml/utils/consistbl.ml b/src/ocaml/utils/consistbl.ml
new file mode 100644
index 0000000..b329911
--- /dev/null
+++ b/src/ocaml/utils/consistbl.ml
@@ -0,0 +1,97 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Consistency tables: for checking consistency of module CRCs *)
+
+open Misc
+
+module Make (Module_name : sig
+  type t
+  module Set : Set.S with type elt = t
+  module Map : Map.S with type key = t
+  module Tbl : Hashtbl.S with type key = t
+  val compare : t -> t -> int
+end) = struct
+  type t = (Digest.t * filepath) Module_name.Tbl.t
+
+  let create () = Module_name.Tbl.create 13
+
+  let clear = Module_name.Tbl.clear
+
+  exception Inconsistency of {
+    unit_name : Module_name.t;
+    inconsistent_source : string;
+    original_source : string;
+  }
+
+  exception Not_available of Module_name.t
+
+  let check_ tbl name crc source =
+    let (old_crc, old_source) = Module_name.Tbl.find tbl name in
+    if crc <> old_crc then raise(Inconsistency {
+        unit_name = name;
+        inconsistent_source = source;
+        original_source = old_source;
+      })
+
+  let check tbl name crc source =
+    try check_ tbl name crc source
+    with Not_found ->
+      Module_name.Tbl.add tbl name (crc, source)
+
+  let check_noadd tbl name crc source =
+    try check_ tbl name crc source
+    with Not_found ->
+      raise (Not_available name)
+
+  let set tbl name crc source = Module_name.Tbl.add tbl name (crc, source)
+
+  let source tbl name = snd (Module_name.Tbl.find tbl name)
+
+  let extract l tbl =
+    let l = List.sort_uniq Module_name.compare l in
+    List.fold_left
+      (fun assc name ->
+         try
+           let (crc, _) = Module_name.Tbl.find tbl name in
+             (name, Some crc) :: assc
+         with Not_found ->
+           (name, None) :: assc)
+      [] l
+
+  let extract_map mod_names tbl =
+    Module_name.Set.fold
+      (fun name result ->
+         try
+           let (crc, _) = Module_name.Tbl.find tbl name in
+           Module_name.Map.add name (Some crc) result
+         with Not_found ->
+           Module_name.Map.add name None result)
+      mod_names
+      Module_name.Map.empty
+
+  let filter p tbl =
+    let to_remove = ref [] in
+    Module_name.Tbl.iter
+      (fun name _ ->
+        if not (p name) then to_remove := name :: !to_remove)
+      tbl;
+    List.iter
+      (fun name ->
+         while Module_name.Tbl.mem tbl name do
+           Module_name.Tbl.remove tbl name
+         done)
+      !to_remove
+end
diff --git a/src/ocaml/utils/consistbl.mli b/src/ocaml/utils/consistbl.mli
new file mode 100644
index 0000000..5067add
--- /dev/null
+++ b/src/ocaml/utils/consistbl.mli
@@ -0,0 +1,82 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Consistency tables: for checking consistency of module CRCs
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Misc
+
+module Make (Module_name : sig
+  type t
+  module Set : Set.S with type elt = t
+  module Map : Map.S with type key = t
+  module Tbl : Hashtbl.S with type key = t
+  val compare : t -> t -> int
+end) : sig
+  type t
+
+  val create: unit -> t
+
+  val clear: t -> unit
+
+  val check: t -> Module_name.t -> Digest.t -> filepath -> unit
+        (* [check tbl name crc source]
+             checks consistency of ([name], [crc]) with infos previously
+             stored in [tbl].  If no CRC was previously associated with
+             [name], record ([name], [crc]) in [tbl].
+             [source] is the name of the file from which the information
+             comes from.  This is used for error reporting. *)
+
+  val check_noadd: t -> Module_name.t -> Digest.t -> filepath -> unit
+        (* Same as [check], but raise [Not_available] if no CRC was previously
+             associated with [name]. *)
+
+  val set: t -> Module_name.t -> Digest.t -> filepath -> unit
+        (* [set tbl name crc source] forcefully associates [name] with
+           [crc] in [tbl], even if [name] already had a different CRC
+           associated with [name] in [tbl]. *)
+
+  val source: t -> Module_name.t -> filepath
+        (* [source tbl name] returns the file name associated with [name]
+           if the latter has an associated CRC in [tbl].
+           Raise [Not_found] otherwise. *)
+
+  val extract: Module_name.t list -> t -> (Module_name.t * Digest.t option) list
+        (* [extract tbl names] returns an associative list mapping each string
+           in [names] to the CRC associated with it in [tbl]. If no CRC is
+           associated with a name then it is mapped to [None]. *)
+
+  val extract_map : Module_name.Set.t -> t -> Digest.t option Module_name.Map.t
+        (* Like [extract] but with a more sophisticated type. *)
+
+  val filter: (Module_name.t -> bool) -> t -> unit
+        (* [filter pred tbl] removes from [tbl] table all (name, CRC) pairs
+           such that [pred name] is [false]. *)
+
+  exception Inconsistency of {
+    unit_name : Module_name.t;
+    inconsistent_source : string;
+    original_source : string;
+  }
+  (* Raised by [check] when a CRC mismatch is detected. *)
+
+  exception Not_available of Module_name.t
+        (* Raised by [check_noadd] when a name doesn't have an associated
+           CRC. *)
+end
diff --git a/src/ocaml/utils/diffing.ml b/src/ocaml/utils/diffing.ml
new file mode 100644
index 0000000..b12f101
--- /dev/null
+++ b/src/ocaml/utils/diffing.ml
@@ -0,0 +1,370 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Gabriel Radanne, projet Cambium, Inria Paris               *)
+(*                                                                        *)
+(*   Copyright 2020 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@warning "-16"]
+
+(* This module implements a modified version of Wagner-Fischer
+   See <https://en.wikipedia.org/wiki/Wagner%E2%80%93Fischer_algorithm>
+   for preliminary reading.
+
+   The main extensions is that:
+   - State is computed based on the optimal patch so far.
+   - The lists can be extended at each state computation.
+
+   We add the constraint that extensions can only be in one side
+   (either the left or right list). This is enforced by the external API.
+
+*)
+
+let (let*) = Option.bind
+let (let+) x f = Option.map f x
+let (let*!) x f = Option.iter f x
+
+type ('left, 'right, 'eq, 'diff) change =
+  | Delete of 'left
+  | Insert of 'right
+  | Keep of 'left * 'right * 'eq
+  | Change of 'left * 'right * 'diff
+
+type ('l, 'r, 'eq, 'diff) patch = ('l, 'r, 'eq, 'diff) change list
+
+let map f g = function
+  | Delete x -> Delete (f x)
+  | Insert x -> Insert (g x)
+  | Keep (x,y,k) -> Keep (f x, g y, k)
+  | Change (x,y,k) -> Change (f x, g y, k)
+
+type ('st,'left,'right) full_state = {
+  line: 'left array;
+  column: 'right array;
+  state: 'st
+}
+
+(* The matrix supporting our dynamic programming implementation.
+
+   Each cell contains:
+   - The diff and its weight
+   - The state computed so far
+   - The lists, potentially extended locally.
+
+   The matrix can also be reshaped.
+*)
+module Matrix : sig
+
+  type shape = { l : int ; c : int }
+
+  type ('state,'left,'right,'eq,'diff) t
+
+  val make : shape -> ('st,'l,'r,'e,'d) t
+  val reshape : shape -> ('st,'l,'r,'e,'d) t -> ('st,'l,'r,'e,'d) t
+
+  (** accessor functions *)
+  val diff : (_,'l,'r,'e,'d) t -> int -> int -> ('l,'r,'e,'d) change option
+  val state :
+    ('st,'l,'r,'e,'d) t -> int -> int -> ('st, 'l, 'r) full_state option
+  val weight : _ t -> int -> int -> int
+
+  val line : (_,'l,_,_,_) t -> int -> int -> 'l option
+  val column : (_,_,'r,_,_) t -> int -> int -> 'r option
+
+  val set :
+    ('st,'l,'r,'e,'d) t -> int -> int ->
+    diff:('l,'r,'e,'d) change option ->
+    weight:int ->
+    state:('st, 'l, 'r) full_state ->
+    unit
+
+  (** the shape when starting filling the matrix *)
+  val shape : _ t -> shape
+
+  (** [shape m i j] is the shape as seen from the state at position (i,j)
+      after some possible extensions
+  *)
+  val shape_at : _ t -> int -> int -> shape option
+
+  (** the maximal shape on the whole matrix *)
+  val real_shape : _ t -> shape
+
+  (** debugging printer *)
+  val[@warning "-32"] pp : Format.formatter -> _ t -> unit
+
+end = struct
+
+  type shape = { l : int ; c : int }
+
+  type ('state,'left,'right,'eq,'diff) t =
+    { states: ('state,'left,'right) full_state option array array;
+      weight: int array array;
+      diff: ('left,'right,'eq,'diff) change option array array;
+      columns: int;
+      lines: int;
+    }
+  let opt_get a n =
+    if n < Array.length a then Some (Array.unsafe_get a n) else None
+  let line m i j = let* st = m.states.(i).(j) in opt_get st.line i
+  let column m i j = let* st = m.states.(i).(j) in opt_get st.column j
+  let diff m i j = m.diff.(i).(j)
+  let weight m i j = m.weight.(i).(j)
+  let state m i j = m.states.(i).(j)
+  let shape m = { l = m.lines ; c = m.columns }
+
+  let set m i j ~diff ~weight ~state =
+    m.weight.(i).(j) <- weight;
+    m.states.(i).(j) <- Some state;
+    m.diff.(i).(j) <- diff;
+    ()
+
+  let shape_at tbl i j =
+    let+ st = tbl.states.(i).(j) in
+    let l = Array.length st.line in
+    let c = Array.length st.column in
+    { l ; c }
+
+  let real_shape tbl =
+    let lines = ref tbl.lines in
+    let columns = ref tbl.columns in
+    for i = 0 to tbl.lines do
+      for j = 0 to tbl.columns do
+        let*! {l; c} = shape_at tbl i j in
+        if l > !lines then lines := l;
+        if c > !columns then columns := c
+      done;
+    done;
+    { l = !lines ; c = !columns }
+
+  let make { l = lines ; c = columns } =
+    { states = Array.make_matrix (lines + 1) (columns + 1) None;
+      weight = Array.make_matrix (lines + 1) (columns + 1) max_int;
+      diff = Array.make_matrix (lines + 1) (columns + 1) None;
+      lines;
+      columns;
+    }
+
+  let reshape { l = lines ; c = columns } m =
+    let copy default a =
+      Array.init (1+lines) (fun i -> Array.init (1+columns) (fun j ->
+          if i <= m.lines && j <= m.columns then
+            a.(i).(j)
+          else default) ) in
+    { states = copy None m.states;
+      weight = copy max_int m.weight;
+      diff = copy None m.diff;
+      lines;
+      columns
+    }
+
+  let pp ppf m =
+    let { l ; c } = shape m in
+    Format.eprintf "Shape : %i, %i@." l c;
+    for i = 0 to l do
+      for j = 0 to c do
+        let d = diff m i j in
+        match d with
+        | None ->
+            Format.fprintf ppf "    "
+        | Some diff ->
+            let sdiff = match diff with
+              | Insert _ -> "\u{2190}"
+              | Delete _ -> "\u{2191}"
+              | Keep _ -> "\u{2196}"
+              | Change _ -> "\u{21F1}"
+            in
+            let w = weight m i j in
+            Format.fprintf ppf "%s%i " sdiff w
+      done;
+      Format.pp_print_newline ppf ()
+    done
+
+end
+
+(* Computation of new cells *)
+
+let select_best_proposition l =
+  let compare_proposition curr prop =
+    match curr, prop with
+    | None, o | o, None -> o
+    | Some (curr_m, curr_res), Some (m, res) ->
+        Some (if curr_m <= m then curr_m, curr_res else m,res)
+  in
+  List.fold_left compare_proposition None l
+
+(* Boundary cell update *)
+let compute_column0 ~weight ~update tbl i =
+  let*! st = Matrix.state tbl (i-1) 0 in
+  let*! line = Matrix.line tbl (i-1) 0 in
+  let diff = Delete line in
+  Matrix.set tbl i 0
+    ~weight:(weight diff + Matrix.weight tbl (i-1) 0)
+    ~state:(update diff st)
+    ~diff:(Some diff)
+
+let compute_line0 ~weight ~update tbl j =
+  let*! st = Matrix.state tbl 0 (j-1) in
+  let*! column = Matrix.column tbl 0 (j-1) in
+  let diff = Insert column in
+  Matrix.set tbl 0 j
+    ~weight:(weight diff + Matrix.weight tbl 0 (j-1))
+    ~state:(update diff st)
+    ~diff:(Some diff)
+
+let compute_inner_cell ~weight ~test ~update tbl i j =
+  let compute_proposition i j diff =
+    let* diff = diff in
+    let+ localstate = Matrix.state tbl i j in
+    weight diff + Matrix.weight tbl i j, (diff, localstate)
+  in
+  let del =
+    let diff = let+ x = Matrix.line tbl (i-1) j in Delete x in
+    compute_proposition (i-1) j diff
+  in
+  let insert =
+    let diff = let+ x = Matrix.column tbl i (j-1) in Insert x in
+    compute_proposition i (j-1) diff
+  in
+  let diag =
+    let diff =
+      let* state = Matrix.state tbl (i-1) (j-1) in
+      let* line = Matrix.line tbl (i-1) (j-1) in
+      let* column = Matrix.column tbl (i-1) (j-1) in
+      match test state.state line column with
+      | Ok ok -> Some (Keep (line, column, ok))
+      | Error err -> Some (Change (line, column, err))
+    in
+    compute_proposition (i-1) (j-1) diff
+  in
+  let*! newweight, (diff, localstate) =
+    select_best_proposition [diag;del;insert]
+  in
+  let state = update diff localstate in
+  Matrix.set tbl i j ~weight:newweight ~state ~diff:(Some diff)
+
+let compute_cell ~weight ~test ~update m i j =
+  match i, j with
+  | _ when Matrix.diff m i j <> None -> ()
+  | 0,0 -> ()
+  | 0,j -> compute_line0 ~update ~weight m j
+  | i,0 -> compute_column0 ~update ~weight m i;
+  | _ -> compute_inner_cell ~weight ~test ~update m i j
+
+(* Filling the matrix
+
+   We fill the whole matrix, as in vanilla Wagner-Fischer.
+   At this point, the lists in some states might have been extended.
+   If any list have been extended, we need to reshape the matrix
+   and repeat the process
+*)
+let compute_matrix ~weight ~test ~update state0 =
+  let m0 = Matrix.make { l = 0 ; c = 0 } in
+  Matrix.set m0 0 0 ~weight:0 ~state:state0 ~diff:None;
+  let rec loop m =
+    let shape = Matrix.shape m in
+    let new_shape = Matrix.real_shape m in
+    if new_shape.l > shape.l || new_shape.c > shape.c then
+      let m = Matrix.reshape new_shape m in
+      for i = 0 to new_shape.l do
+        for j = 0 to new_shape.c do
+          compute_cell ~update ~test ~weight m i j
+        done
+      done;
+      loop m
+    else
+      m
+  in
+  loop m0
+
+(* Building the patch.
+
+   We first select the best final cell. A potential final cell
+   is a cell where the local shape (i.e., the size of the strings) correspond
+   to its position in the matrix. In other words: it's at the end of both its
+   strings. We select the final cell with the smallest weight.
+
+   We then build the patch by walking backward from the final cell to the
+   origin.
+*)
+
+let select_final_state m0 =
+  let maybe_final i j =
+    match Matrix.shape_at m0 i j with
+    | Some shape_here -> shape_here.l = i && shape_here.c = j
+    | None -> false
+  in
+  let best_state (i0,j0,weigth0) (i,j) =
+    let weight = Matrix.weight m0 i j in
+    if weight < weigth0 then (i,j,weight) else (i0,j0,weigth0)
+  in
+  let res = ref (0,0,max_int) in
+  let shape = Matrix.shape m0 in
+  for i = 0 to shape.l do
+    for j = 0 to shape.c do
+      if maybe_final i j then
+        res := best_state !res (i,j)
+    done
+  done;
+  let i_final, j_final, _ = !res in
+  assert (i_final <> 0 || j_final <> 0);
+  (i_final, j_final)
+
+let construct_patch m0 =
+  let rec aux acc (i, j) =
+    if i = 0 && j = 0 then
+      acc
+    else
+      match Matrix.diff m0 i j with
+      | None -> assert false
+      | Some d ->
+          let next = match d with
+            | Keep _ | Change _ -> (i-1, j-1)
+            | Delete _ -> (i-1, j)
+            | Insert _ -> (i, j-1)
+          in
+          aux (d::acc) next
+  in
+  aux [] (select_final_state m0)
+
+let diff ~weight ~test ~update state line column =
+  let update d fs = { fs with state = update d fs.state } in
+  let fullstate = { line; column; state } in
+  compute_matrix ~weight ~test ~update fullstate
+  |> construct_patch
+
+type ('l, 'r, 'e, 'd, 'state) update =
+  | Without_extensions of (('l,'r,'e,'d) change -> 'state -> 'state)
+  | With_left_extensions of
+      (('l,'r,'e,'d) change -> 'state -> 'state * 'l array)
+  | With_right_extensions of
+      (('l,'r,'e,'d) change -> 'state -> 'state * 'r array)
+
+let variadic_diff ~weight ~test ~(update:_ update) state line column =
+  let may_append x = function
+    | [||] -> x
+    | y -> Array.append x y in
+  let update = match update with
+    | Without_extensions up ->
+        fun d fs ->
+          let state = up d fs.state in
+          { fs with state }
+    | With_left_extensions up ->
+        fun d fs ->
+          let state, a = up d fs.state in
+          { fs with state ; line = may_append fs.line a }
+    | With_right_extensions up ->
+        fun d fs ->
+          let state, a = up d fs.state in
+          { fs with state ; column = may_append fs.column a }
+  in
+  let fullstate = { line; column; state } in
+  compute_matrix ~weight ~test ~update fullstate
+  |> construct_patch
diff --git a/src/ocaml/utils/diffing.mli b/src/ocaml/utils/diffing.mli
new file mode 100644
index 0000000..51f4858
--- /dev/null
+++ b/src/ocaml/utils/diffing.mli
@@ -0,0 +1,112 @@
+
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Gabriel Radanne, projet Cambium, Inria Paris               *)
+(*                                                                        *)
+(*   Copyright 2020 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** {0 Parametric diffing}
+
+    This module implements diffing over lists of arbitrary content.
+    It is parameterized by
+    - The content of the two lists
+    - The equality witness when an element is kept
+    - The diffing witness when an element is changed
+
+    Diffing is extended to maintain state depending on the
+    computed changes while walking through the two lists.
+
+    The underlying algorithm is a modified Wagner-Fischer algorithm
+    (see <https://en.wikipedia.org/wiki/Wagner%E2%80%93Fischer_algorithm>).
+
+    We provide the following guarantee:
+    Given two lists [l] and [r], if different patches result in different
+    states, we say that the state diverges.
+    - We always return the optimal patch on prefixes of [l] and [r]
+      on which state does not diverge.
+    - Otherwise, we return a correct but non-optimal patch where subpatches
+      with no divergent states are optimal for the given initial state.
+
+    More precisely, the optimality of Wagner-Fischer depends on the property
+    that the edit-distance between a k-prefix of the left input and a l-prefix
+    of the right input d(k,l) satisfies
+
+    d(k,l) = min (
+     del_cost + d(k-1,l),
+     insert_cost + d(k,l-1),
+     change_cost + d(k-1,l-1)
+    )
+
+   Under this hypothesis, it is optimal to choose greedily the state of the
+   minimal patch transforming the left k-prefix into the right l-prefix as a
+   representative of the states of all possible patches transforming the left
+   k-prefix into the right l-prefix.
+
+   If this property is not satisfied, we can still choose greedily a
+   representative state. However, the computed patch is no more guaranteed to
+   be globally optimal.
+   Nevertheless, it is still a correct patch, which is even optimal among all
+   explored patches.
+
+*)
+
+(** The type of potential changes on a list. *)
+type ('left, 'right, 'eq, 'diff) change =
+  | Delete of 'left
+  | Insert of 'right
+  | Keep of 'left * 'right * 'eq
+  | Change of 'left * 'right * 'diff
+
+val map :
+  ('l1 -> 'l2) -> ('r1 -> 'r2) ->
+  ('l1, 'r1, 'eq, 'diff) change ->
+  ('l2, 'r2, 'eq, 'diff) change
+
+(** A patch is an ordered list of changes. *)
+type ('l, 'r, 'eq, 'diff) patch = ('l, 'r, 'eq, 'diff) change list
+
+(** [diff ~weight ~test ~update state l r] computes
+    the diff between [l] and [r], using the initial state [state].
+    - [test st xl xr] tests if the elements [xl] and [xr] are
+      compatible ([Ok]) or not ([Error]).
+    - [weight ch] returns the weight of the change [ch].
+      Used to find the smallest patch.
+    - [update ch st] returns the new state after applying a change.
+*)
+val diff :
+  weight:(('l, 'r, 'eq, 'diff) change -> int) ->
+  test:('state -> 'l -> 'r -> ('eq, 'diff) result) ->
+  update:(('l, 'r, 'eq, 'diff) change -> 'state -> 'state) ->
+  'state -> 'l array -> 'r array -> ('l, 'r, 'eq, 'diff) patch
+
+(** {1 Variadic diffing}
+
+    Variadic diffing allows to expand the lists being diffed during diffing.
+*)
+
+type ('l, 'r, 'e, 'd, 'state) update =
+  | Without_extensions of (('l,'r,'e,'d) change -> 'state -> 'state)
+  | With_left_extensions of
+      (('l,'r,'e,'d) change -> 'state -> 'state * 'l array)
+  | With_right_extensions of
+      (('l,'r,'e,'d) change -> 'state -> 'state * 'r array)
+
+(** [variadic_diff ~weight ~test ~update state l r] behaves as [diff]
+    with the following difference:
+    - [update] must now be an {!update} which indicates in which direction
+      the expansion takes place.
+*)
+val variadic_diff :
+  weight:(('l, 'r, 'eq, 'diff) change -> int) ->
+  test:('state -> 'l -> 'r -> ('eq, 'diff) result) ->
+  update:('l, 'r, 'eq, 'diff, 'state) update ->
+  'state -> 'l array -> 'r array -> ('l, 'r, 'eq, 'diff) patch
diff --git a/src/ocaml/utils/directory_content_cache.ml b/src/ocaml/utils/directory_content_cache.ml
new file mode 100644
index 0000000..7b5ee9e
--- /dev/null
+++ b/src/ocaml/utils/directory_content_cache.ml
@@ -0,0 +1,14 @@
+include File_cache.Make (struct
+    let cache_name = "Directory_content_cache"
+    type t = string array
+
+    (* For backward compatibility reason, simulate the behavior of
+       [Misc.find_in_path]: silently ignore directories that don't exist
+       + treat [""] as the current directory. *)
+    let read dir =
+      try
+        Sys.readdir (if dir = "" then Filename.current_dir_name else dir)
+      with Sys_error _ ->
+        [||]
+  end)
+
diff --git a/src/ocaml/utils/dune b/src/ocaml/utils/dune
new file mode 100644
index 0000000..4895e7e
--- /dev/null
+++ b/src/ocaml/utils/dune
@@ -0,0 +1,4 @@
+(library
+  (name ocaml_utils)
+  (libraries config merlin_utils)
+  (flags  :standard -open Merlin_utils))
diff --git a/src/ocaml/utils/identifiable.ml b/src/ocaml/utils/identifiable.ml
new file mode 100644
index 0000000..fc6cd44
--- /dev/null
+++ b/src/ocaml/utils/identifiable.ml
@@ -0,0 +1,223 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Stdlib_map = Map
+module Stdlib_set = Set
+
+module type Thing = sig
+  type t
+
+  include Hashtbl.HashedType with type t := t
+  include Map.OrderedType with type t := t
+
+  val output : out_channel -> t -> unit
+  val print : Format.formatter -> t -> unit
+end
+
+module Pair (A : Thing) (B : Thing) : Thing with type t = A.t * B.t = struct
+  type t = A.t * B.t
+
+  let compare (a1, b1) (a2, b2) =
+    let c = A.compare a1 a2 in
+    if c <> 0 then c
+    else B.compare b1 b2
+
+  let output oc (a, b) = Printf.fprintf oc " (%a, %a)" A.output a B.output b
+  let hash (a, b) = Hashtbl.hash (A.hash a, B.hash b)
+  let equal (a1, b1) (a2, b2) = A.equal a1 a2 && B.equal b1 b2
+  let print ppf (a, b) = Format.fprintf ppf " (%a, @ %a)" A.print a B.print b
+end
+
+module Make_map (T : Thing) = struct
+  include Map.Make (T)
+
+  let filter_map t ~f =
+    fold (fun id v map ->
+        match f id v with
+        | None -> map
+        | Some r -> add id r map) t empty
+
+  let of_list l =
+    List.fold_left (fun map (id, v) -> add id v map) empty l
+
+  let disjoint_union ?eq m1 m2 =
+    merge (fun id v1 v2 ->
+        match v1, v2 with
+        | Some v1, Some v2 ->
+          let ok = match eq with
+            | None -> false
+            | Some eq -> eq v1 v2
+          in
+          if not ok then
+            let err = Format.asprintf "Map.disjoint_union %a" T.print id in
+            Misc.fatal_error err
+          else Some v1
+        | x, None | None, x -> x)
+      m1 m2
+
+  let union_right m1 m2 =
+    merge (fun _ x y -> match x, y with
+        | None, None -> None
+        | None, Some v
+        | Some v, None
+        | Some _, Some v -> Some v)
+      m1 m2
+
+  let union_left m1 m2 = union_right m2 m1
+
+  let union_merge f m1 m2 =
+    let aux _ m1 m2 =
+      match m1, m2 with
+      | None, m | m, None -> m
+      | Some m1, Some m2 -> Some (f m1 m2)
+    in
+    merge aux m1 m2
+
+  let rename m v =
+    try find v m
+    with Not_found -> v
+
+  let map_keys f m =
+    of_list (List.map (fun (k, v) -> f k, v) (bindings m))
+
+  let print f ppf s =
+    let elts ppf s = iter (fun id v ->
+        Format.fprintf ppf "@ (@[%a@ %a@])" T.print id f v) s in
+    Format.fprintf ppf "@[<1>{@[%a@ @]}@]" elts s
+
+  module T_set = Set.Make (T)
+
+  let keys map = fold (fun k _ set -> T_set.add k set) map T_set.empty
+
+  let of_set f set = T_set.fold (fun e map -> add e (f e) map) set empty
+
+  let transpose_keys_and_data map = fold (fun k v m -> add v k m) map empty
+end
+
+module Make_set (T : Thing) = struct
+  include Set.Make (T)
+
+  let output oc s =
+    Printf.fprintf oc " ( ";
+    iter (fun v -> Printf.fprintf oc "%a " T.output v) s;
+    Printf.fprintf oc ")"
+
+  let print ppf s =
+    let elts ppf s = iter (fun e -> Format.fprintf ppf "@ %a" T.print e) s in
+    Format.fprintf ppf "@[<1>{@[%a@ @]}@]" elts s
+
+  let to_string s = Format.asprintf "%a" print s
+
+  let of_list l = match l with
+    | [] -> empty
+    | [t] -> singleton t
+    | t :: q -> List.fold_left (fun acc e -> add e acc) (singleton t) q
+
+  let map f s = of_list (List.map f (elements s))
+end
+
+module Make_tbl (T : Thing) = struct
+  include Hashtbl.Make (T)
+
+  module T_map = Make_map (T)
+
+  let to_list t =
+    fold (fun key datum elts -> (key, datum)::elts) t []
+
+  let of_list elts =
+    let t = create 42 in
+    List.iter (fun (key, datum) -> add t key datum) elts;
+    t
+
+  let to_map v = fold T_map.add v T_map.empty
+
+  let of_map m =
+    let t = create (T_map.cardinal m) in
+    T_map.iter (fun k v -> add t k v) m;
+    t
+
+  let memoize t f = fun key ->
+    try find t key with
+    | Not_found ->
+      let r = f key in
+      add t key r;
+      r
+
+  let map t f =
+    of_map (T_map.map f (to_map t))
+end
+
+module type S = sig
+  type t
+
+  module T : Thing with type t = t
+  include Thing with type t := T.t
+
+  module Set : sig
+    include Stdlib_set.S
+      with type elt = T.t
+      and type t = Make_set (T).t
+
+    val output : out_channel -> t -> unit
+    val print : Format.formatter -> t -> unit
+    val to_string : t -> string
+    val of_list : elt list -> t
+    val map : (elt -> elt) -> t -> t
+  end
+
+  module Map : sig
+    include Stdlib_map.S
+      with type key = T.t
+      and type 'a t = 'a Make_map (T).t
+
+    val filter_map : 'a t -> f:(key -> 'a -> 'b option) -> 'b t
+    val of_list : (key * 'a) list -> 'a t
+    val disjoint_union : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> 'a t
+    val union_right : 'a t -> 'a t -> 'a t
+    val union_left : 'a t -> 'a t -> 'a t
+    val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
+    val rename : key t -> key -> key
+    val map_keys : (key -> key) -> 'a t -> 'a t
+    val keys : 'a t -> Make_set (T).t
+    val of_set : (key -> 'a) -> Make_set (T).t -> 'a t
+    val transpose_keys_and_data : key t -> key t
+    val print :
+      (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
+  end
+
+  module Tbl : sig
+    include Hashtbl.S
+      with type key = T.t
+      and type 'a t = 'a Hashtbl.Make (T).t
+
+    val to_list : 'a t -> (T.t * 'a) list
+    val of_list : (T.t * 'a) list -> 'a t
+
+    val to_map : 'a t -> 'a Make_map (T).t
+    val of_map : 'a Make_map (T).t -> 'a t
+    val memoize : 'a t -> (key -> 'a) -> key -> 'a
+    val map : 'a t -> ('a -> 'b) -> 'b t
+  end
+end
+
+module Make (T : Thing) = struct
+  module T = T
+  include T
+
+  module Set = Make_set (T)
+  module Map = Make_map (T)
+  module Tbl = Make_tbl (T)
+end
diff --git a/src/ocaml/utils/identifiable.mli b/src/ocaml/utils/identifiable.mli
new file mode 100644
index 0000000..568ce46
--- /dev/null
+++ b/src/ocaml/utils/identifiable.mli
@@ -0,0 +1,94 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Uniform interface for common data structures over various things. *)
+
+module type Thing = sig
+  type t
+
+  include Hashtbl.HashedType with type t := t
+  include Map.OrderedType with type t := t
+
+  val output : out_channel -> t -> unit
+  val print : Format.formatter -> t -> unit
+end
+
+module Pair : functor (A : Thing) (B : Thing) -> Thing with type t = A.t * B.t
+
+module type S = sig
+  type t
+
+  module T : Thing with type t = t
+  include Thing with type t := T.t
+
+  module Set : sig
+    include Set.S
+      with type elt = T.t
+      and type t = Set.Make (T).t
+
+    val output : out_channel -> t -> unit
+    val print : Format.formatter -> t -> unit
+    val to_string : t -> string
+    val of_list : elt list -> t
+    val map : (elt -> elt) -> t -> t
+  end
+
+  module Map : sig
+    include Map.S
+      with type key = T.t
+      and type 'a t = 'a Map.Make (T).t
+
+    val filter_map : 'a t -> f:(key -> 'a -> 'b option) -> 'b t
+    val of_list : (key * 'a) list -> 'a t
+
+    (** [disjoint_union m1 m2] contains all bindings from [m1] and
+        [m2]. If some binding is present in both and the associated
+        value is not equal, a Fatal_error is raised *)
+    val disjoint_union : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> 'a t
+
+    (** [union_right m1 m2] contains all bindings from [m1] and [m2]. If
+        some binding is present in both, the one from [m2] is taken *)
+    val union_right : 'a t -> 'a t -> 'a t
+
+    (** [union_left m1 m2 = union_right m2 m1] *)
+    val union_left : 'a t -> 'a t -> 'a t
+
+    val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
+    val rename : key t -> key -> key
+    val map_keys : (key -> key) -> 'a t -> 'a t
+    val keys : 'a t -> Set.t
+    val of_set : (key -> 'a) -> Set.t -> 'a t
+    val transpose_keys_and_data : key t -> key t
+    val print :
+      (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
+  end
+
+  module Tbl : sig
+    include Hashtbl.S
+      with type key = T.t
+      and type 'a t = 'a Hashtbl.Make (T).t
+
+    val to_list : 'a t -> (T.t * 'a) list
+    val of_list : (T.t * 'a) list -> 'a t
+
+    val to_map : 'a t -> 'a Map.t
+    val of_map : 'a Map.t -> 'a t
+    val memoize : 'a t -> (key -> 'a) -> key -> 'a
+    val map : 'a t -> ('a -> 'b) -> 'b t
+  end
+end
+
+module Make (T : Thing) : S with type t := T.t
diff --git a/src/ocaml/utils/lazy_backtrack.ml b/src/ocaml/utils/lazy_backtrack.ml
new file mode 100644
index 0000000..a1fc997
--- /dev/null
+++ b/src/ocaml/utils/lazy_backtrack.ml
@@ -0,0 +1,92 @@
+type ('a,'b) t = ('a,'b) eval ref
+
+and ('a,'b) eval =
+  | Done of 'b
+  | Raise of exn
+  | Thunk of 'a
+
+type undo =
+  | Nil
+  | Cons : ('a, 'b) t * 'a * undo -> undo
+
+type log = undo ref
+
+let force f x =
+  match !x with
+  | Done x -> x
+  | Raise e -> raise e
+  | Thunk e ->
+      match f e with
+      | y ->
+        x := Done y;
+        y
+      | exception e ->
+        x := Raise e;
+        raise e
+
+let get_arg x =
+  match !x with Thunk a -> Some a | _ -> None
+
+let create x =
+  ref (Thunk x)
+
+let create_forced y =
+  ref (Done y)
+
+let create_failed e =
+  ref (Raise e)
+
+let log () =
+  ref Nil
+
+let force_logged log f x =
+  match !x with
+  | Done x -> x
+  | Raise e -> raise e
+  | Thunk e ->
+    match f e with
+    | (Error _ as err : _ result) ->
+        x := Done err;
+        log := Cons(x, e, !log);
+        err
+    | Ok _ as res ->
+        x := Done res;
+        res
+    | exception e ->
+        x := Raise e;
+        raise e
+
+let backtrack log =
+  let rec loop = function
+    | Nil -> ()
+    | Cons(x, e, rest) ->
+        x := Thunk e;
+        loop rest
+  in
+  loop !log
+
+(* For compatibility with 4.02 and 4.03 *)
+
+let is_val t = match !t with
+  | Done _ -> true
+  | Raise _ | Thunk _ -> false
+
+let view t = !t
+
+(* For compatibility with 4.08 and 4.09 *)
+
+let force_logged_408 log f x =
+  match !x with
+  | Done x -> x
+  | Raise e -> raise e | Thunk e ->
+    match f e with
+    | None ->
+        x := Done None;
+        log := Cons(x, e, !log);
+        None
+    | Some _ as y ->
+        x := Done y;
+        y
+    | exception e ->
+        x := Raise e;
+        raise e
diff --git a/src/ocaml/utils/lazy_backtrack.mli b/src/ocaml/utils/lazy_backtrack.mli
new file mode 100644
index 0000000..3523fe1
--- /dev/null
+++ b/src/ocaml/utils/lazy_backtrack.mli
@@ -0,0 +1,29 @@
+type ('a,'b) t
+
+type log
+
+val force : ('a -> 'b) -> ('a,'b) t -> 'b
+val create : 'a -> ('a,'b) t
+val get_arg : ('a,'b) t -> 'a option
+val create_forced : 'b -> ('a, 'b) t
+val create_failed : exn -> ('a, 'b) t
+
+(* [force_logged log f t] is equivalent to [force f t] but if [f] returns
+   [None] then [t] is recorded in [log]. [backtrack log] will then reset all
+   the recorded [t]s back to their original state. *)
+val log : unit -> log
+val force_logged :
+  log -> ('a -> ('b, 'c) result) -> ('a,('b, 'c) result) t -> ('b, 'c) result
+val backtrack : log -> unit
+
+(* For compatibility with 4.02 and 4.03 *)
+val is_val : ('a, 'b) t -> bool
+type ('a, 'b) eval =
+  | Done of 'b
+  | Raise of exn
+  | Thunk of 'a
+val view : ('a, 'b) t -> ('a, 'b) eval
+
+(* For compatibility with 4.08 and 4.09 *)
+val force_logged_408 :
+  log -> ('a -> 'b option) -> ('a,'b option) t -> 'b option
diff --git a/src/ocaml/utils/load_path.ml b/src/ocaml/utils/load_path.ml
new file mode 100644
index 0000000..045af69
--- /dev/null
+++ b/src/ocaml/utils/load_path.ml
@@ -0,0 +1,144 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2018 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Local_store
+
+module STbl = Misc.String.Tbl
+
+(* Mapping from basenames to full filenames *)
+type registry = string STbl.t
+
+let files : registry ref = s_table STbl.create 42
+let files_uncap : registry ref = s_table STbl.create 42
+
+module Dir = struct
+  type t = {
+    path : string;
+    files : string list;
+  }
+
+  let path t = t.path
+  let files t = t.files
+
+  let create path =
+    { path; files = Array.to_list (Directory_content_cache.read path) }
+
+  let check t = Directory_content_cache.check t.path
+
+end
+
+let dirs = s_ref []
+
+let reset () =
+  assert (not Config.merlin || Local_store.is_bound ());
+  STbl.clear !files;
+  STbl.clear !files_uncap;
+  dirs := []
+
+let get () = List.rev !dirs
+let get_paths () = List.rev_map Dir.path !dirs
+
+(* Optimized version of [add] below, for use in [init] and [remove_dir]: since
+   we are starting from an empty cache, we can avoid checking whether a unit
+   name already exists in the cache simply by adding entries in reverse
+   order. *)
+let prepend_add dir =
+  List.iter (fun base ->
+      let fn = Filename.concat dir.Dir.path base in
+      STbl.replace !files base fn;
+      STbl.replace !files_uncap (String.uncapitalize_ascii base) fn
+    ) dir.Dir.files
+
+let init l =
+  assert (not Config.merlin || Local_store.is_bound ());
+  let rec loop_changed acc = function
+    | [] -> Some acc
+    | new_path :: new_rest ->
+      loop_changed (Dir.create new_path :: acc) new_rest
+  in
+  let rec loop_unchanged acc new_paths old_dirs =
+    match new_paths, old_dirs with
+    | [], [] -> None
+    | new_path :: new_rest, [] ->
+      loop_changed (Dir.create new_path :: acc) new_rest
+    | [], _ :: _ -> Some acc
+    | new_path :: new_rest, old_dir :: old_rest ->
+      if String.equal new_path (Dir.path old_dir) then begin
+        if Dir.check old_dir then begin
+          loop_unchanged (old_dir :: acc) new_rest old_rest
+        end else begin
+          loop_changed (Dir.create new_path :: acc) new_rest
+        end
+      end else begin
+        loop_changed (Dir.create new_path :: acc) new_rest
+      end
+  in
+  match loop_unchanged [] l (List.rev !dirs) with
+  | None -> ()
+  | Some new_dirs ->
+    reset ();
+    dirs := new_dirs;
+    List.iter prepend_add new_dirs
+
+let remove_dir dir =
+  assert (not Config.merlin || Local_store.is_bound ());
+  let new_dirs = List.filter (fun d -> Dir.path d <> dir) !dirs in
+  if List.compare_lengths new_dirs !dirs <> 0 then begin
+    reset ();
+    List.iter prepend_add new_dirs;
+    dirs := new_dirs
+  end
+
+(* General purpose version of function to add a new entry to load path: We only
+   add a basename to the cache if it is not already present in the cache, in
+   order to enforce left-to-right precedence. *)
+let add dir =
+  assert (not Config.merlin || Local_store.is_bound ());
+  List.iter
+    (fun base ->
+       let fn = Filename.concat dir.Dir.path base in
+       if not (STbl.mem !files base) then
+         STbl.replace !files base fn;
+       let ubase = String.uncapitalize_ascii base in
+       if not (STbl.mem !files_uncap ubase) then
+         STbl.replace !files_uncap ubase fn)
+    dir.Dir.files;
+  dirs := dir :: !dirs
+
+let append_dir = add
+
+let add_dir dir = add (Dir.create dir)
+
+(* Add the directory at the start of load path - so basenames are
+   unconditionally added. *)
+let prepend_dir dir =
+  assert (not Config.merlin || Local_store.is_bound ());
+  prepend_add dir;
+  dirs := !dirs @ [dir]
+
+let is_basename fn = Filename.basename fn = fn
+
+let find fn =
+  assert (not Config.merlin || Local_store.is_bound ());
+  if is_basename fn && not !Sys.interactive then
+    STbl.find !files fn
+  else
+    Misc.find_in_path (get_paths ()) fn
+
+let find_uncap fn =
+  assert (not Config.merlin || Local_store.is_bound ());
+  if is_basename fn && not !Sys.interactive then
+    STbl.find !files_uncap (String.uncapitalize_ascii fn)
+  else
+    Misc.find_in_path_uncap (get_paths ()) fn
diff --git a/src/ocaml/utils/load_path.mli b/src/ocaml/utils/load_path.mli
new file mode 100644
index 0000000..1f9aba2
--- /dev/null
+++ b/src/ocaml/utils/load_path.mli
@@ -0,0 +1,75 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2018 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Management of include directories.
+
+    This module offers a high level interface to locating files in the
+    load path, which is constructed from [-I] command line flags and a few
+    other parameters.
+
+    It makes the assumption that the contents of include directories
+    doesn't change during the execution of the compiler.
+*)
+
+val add_dir : string -> unit
+(** Add a directory to the end of the load path (i.e. at lowest priority.) *)
+
+val remove_dir : string -> unit
+(** Remove a directory from the load path *)
+
+val reset : unit -> unit
+(** Remove all directories *)
+
+val init : string list -> unit
+(** [init l] is the same as [reset (); List.iter add_dir (List.rev l)] *)
+
+val get_paths : unit -> string list
+(** Return the list of directories passed to [add_dir] so far. *)
+
+val find : string -> string
+(** Locate a file in the load path. Raise [Not_found] if the file
+    cannot be found. This function is optimized for the case where the
+    filename is a basename, i.e. doesn't contain a directory
+    separator. *)
+
+val find_uncap : string -> string
+(** Same as [find], but search also for uncapitalized name, i.e.  if
+    name is Foo.ml, allow /path/Foo.ml and /path/foo.ml to match. *)
+
+module Dir : sig
+  type t
+  (** Represent one directory in the load path. *)
+
+  val create : string -> t
+
+  val path : t -> string
+
+  val files : t -> string list
+  (** All the files in that directory. This doesn't include files in
+      sub-directories of this directory. *)
+end
+
+val[@deprecated] add : Dir.t -> unit
+(** Old name for {!append_dir} *)
+
+val append_dir : Dir.t -> unit
+(** [append_dir d] adds [d] to the end of the load path (i.e. at lowest
+    priority. *)
+
+val prepend_dir : Dir.t -> unit
+(** [prepend_dir d] adds [d] to the start of the load path (i.e. at highest
+    priority. *)
+
+val get : unit -> Dir.t list
+(** Same as [get_paths ()], except that it returns a [Dir.t list]. *)
diff --git a/src/ocaml/utils/local_store.ml b/src/ocaml/utils/local_store.ml
new file mode 100644
index 0000000..b6d117e
--- /dev/null
+++ b/src/ocaml/utils/local_store.ml
@@ -0,0 +1,59 @@
+type ref_and_reset =
+  | Table : { ref: 'a ref; init: unit -> 'a } -> ref_and_reset
+  | Ref : { ref: 'a ref; mutable snapshot: 'a } -> ref_and_reset
+
+type bindings = {
+  mutable refs: ref_and_reset list;
+  mutable frozen : bool;
+  mutable is_bound: bool;
+}
+
+let global_bindings =
+  { refs = []; is_bound = false; frozen = false }
+
+let is_bound () = global_bindings.is_bound
+
+let reset () =
+  assert (is_bound ());
+  List.iter (function
+    | Table { ref; init } -> ref := init ()
+    | Ref { ref; snapshot } -> ref := snapshot
+  ) global_bindings.refs
+
+let s_table create size =
+  let init () = create size in
+  let ref = ref (init ()) in
+  assert (not global_bindings.frozen);
+  global_bindings.refs <- (Table { ref; init }) :: global_bindings.refs;
+  ref
+
+let s_ref k =
+  let ref = ref k in
+  assert (not global_bindings.frozen);
+  global_bindings.refs <-
+    (Ref { ref; snapshot = k }) :: global_bindings.refs;
+  ref
+
+type slot = Slot : { ref : 'a ref; mutable value : 'a } -> slot
+type store = slot list
+
+let fresh () =
+  let slots =
+    List.map (function
+      | Table { ref; init } -> Slot {ref; value = init ()}
+      | Ref r ->
+          if not global_bindings.frozen then r.snapshot <- !(r.ref);
+          Slot { ref = r.ref; value = r.snapshot }
+    ) global_bindings.refs
+  in
+  global_bindings.frozen <- true;
+  slots
+
+let with_store slots f =
+  assert (not global_bindings.is_bound);
+  global_bindings.is_bound <- true;
+  List.iter (fun (Slot {ref;value}) -> ref := value) slots;
+  Fun.protect f ~finally:(fun () ->
+    List.iter (fun (Slot s) -> s.value <- !(s.ref)) slots;
+    global_bindings.is_bound <- false;
+  )
diff --git a/src/ocaml/utils/local_store.mli b/src/ocaml/utils/local_store.mli
new file mode 100644
index 0000000..f39cd12
--- /dev/null
+++ b/src/ocaml/utils/local_store.mli
@@ -0,0 +1,66 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                        Frederic Bour, Tarides                          *)
+(*                         Thomas Refis, Tarides                          *)
+(*                                                                        *)
+(*   Copyright 2020 Tarides                                               *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** This module provides some facilities for creating references (and hash
+    tables) which can easily be snapshoted and restored to an arbitrary version.
+
+    It is used throughout the frontend (read: typechecker), to register all
+    (well, hopefully) the global state. Thus making it easy for tools like
+    Merlin to go back and forth typechecking different files. *)
+
+(** {1 Creators} *)
+
+val s_ref : 'a -> 'a ref
+(** Similar to {!ref}, except the allocated reference is registered into the
+    store. *)
+
+val s_table : ('a -> 'b) -> 'a -> 'b ref
+(** Used to register hash tables. Those also need to be placed into refs to be
+    easily swapped out, but one can't just "snapshot" the initial value to
+    create fresh instances, so instead an initializer is required.
+
+    Use it like this:
+    {[
+      let my_table = s_table Hashtbl.create 42
+    ]}
+*)
+
+(** {1 State management}
+
+    Note: all the following functions are currently unused inside the compiler
+    codebase. Merlin is their only user at the moment. *)
+
+type store
+
+val fresh : unit -> store
+(** Returns a fresh instance of the store.
+
+    The first time this function is called, it snapshots the value of all the
+    registered references, later calls to [fresh] will return instances
+    initialized to those values. *)
+
+val with_store : store -> (unit -> 'a) -> 'a
+(** [with_scope s f] resets all the registered references to the value they have
+    in [s] for the run of [f].
+    If [f] updates any of the registered refs, [s] is updated to remember those
+    changes. *)
+
+val reset : unit -> unit
+(** Resets all the references to the initial snapshot (i.e. to the same values
+    that new instances start with). *)
+
+val is_bound : unit -> bool
+(** Returns [true] when a scope is active (i.e. when called from the callback
+    passed to {!with_scope}), [false] otherwise. *)
diff --git a/src/ocaml/utils/tbl.ml b/src/ocaml/utils/tbl.ml
new file mode 100644
index 0000000..fa278b4
--- /dev/null
+++ b/src/ocaml/utils/tbl.ml
@@ -0,0 +1,123 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type ('k, 'v) t =
+    Empty
+  | Node of ('k, 'v) t * 'k * 'v * ('k, 'v) t * int
+
+let empty = Empty
+
+let height = function
+    Empty -> 0
+  | Node(_,_,_,_,h) -> h
+
+let create l x d r =
+  let hl = height l and hr = height r in
+  Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+let bal l x d r =
+  let hl = height l and hr = height r in
+  if hl > hr + 1 then
+    match l with
+    | Node (ll, lv, ld, lr, _) when height ll >= height lr ->
+        create ll lv ld (create lr x d r)
+    | Node (ll, lv, ld, Node (lrl, lrv, lrd, lrr, _), _) ->
+        create (create ll lv ld lrl) lrv lrd (create lrr x d r)
+    | _ -> assert false
+  else if hr > hl + 1 then
+    match r with
+    | Node (rl, rv, rd, rr, _) when height rr >= height rl ->
+        create (create l x d rl) rv rd rr
+    | Node (Node (rll, rlv, rld, rlr, _), rv, rd, rr, _) ->
+        create (create l x d rll) rlv rld (create rlr rv rd rr)
+    | _ -> assert false
+  else
+    create l x d r
+
+let rec add x data = function
+    Empty ->
+      Node(Empty, x, data, Empty, 1)
+  | Node(l, v, d, r, h) ->
+      let c = compare x v in
+      if c = 0 then
+        Node(l, x, data, r, h)
+      else if c < 0 then
+        bal (add x data l) v d r
+      else
+        bal l v d (add x data r)
+
+let rec find x = function
+    Empty ->
+      raise Not_found
+  | Node(l, v, d, r, _) ->
+      let c = compare x v in
+      if c = 0 then d
+      else find x (if c < 0 then l else r)
+
+let rec find_str (x : string) = function
+    Empty ->
+      raise Not_found
+  | Node(l, v, d, r, _) ->
+      let c = compare x v in
+      if c = 0 then d
+      else find_str x (if c < 0 then l else r)
+
+let rec mem x = function
+    Empty -> false
+  | Node(l, v, _d, r, _) ->
+      let c = compare x v in
+      c = 0 || mem x (if c < 0 then l else r)
+
+let rec merge t1 t2 =
+  match (t1, t2) with
+    (Empty, t) -> t
+  | (t, Empty) -> t
+  | (Node(l1, v1, d1, r1, _h1), Node(l2, v2, d2, r2, _h2)) ->
+      bal l1 v1 d1 (bal (merge r1 l2) v2 d2 r2)
+
+let rec remove x = function
+    Empty ->
+      Empty
+  | Node(l, v, d, r, _h) ->
+      let c = compare x v in
+      if c = 0 then
+        merge l r
+      else if c < 0 then
+        bal (remove x l) v d r
+      else
+        bal l v d (remove x r)
+
+let rec iter f = function
+    Empty -> ()
+  | Node(l, v, d, r, _) ->
+      iter f l; f v d; iter f r
+
+let rec map f = function
+    Empty -> Empty
+  | Node(l, v, d, r, h) -> Node(map f l, v, f v d, map f r, h)
+
+let rec fold f m accu =
+  match m with
+  | Empty -> accu
+  | Node(l, v, d, r, _) ->
+      fold f r (f v d (fold f l accu))
+
+open Format
+
+let print print_key print_data ppf tbl =
+  let print_tbl ppf tbl =
+    iter (fun k d -> fprintf ppf "@[<2>%a ->@ %a;@]@ " print_key k print_data d)
+      tbl in
+  fprintf ppf "@[<hv 2>[[%a]]@]" print_tbl tbl
diff --git a/src/ocaml/utils/tbl.mli b/src/ocaml/utils/tbl.mli
new file mode 100644
index 0000000..d23b959
--- /dev/null
+++ b/src/ocaml/utils/tbl.mli
@@ -0,0 +1,34 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Association tables from any ordered type to any type.
+   We use the generic ordering to compare keys. *)
+
+type ('k, 'v) t
+
+val empty: ('k, 'v) t
+val add: 'k -> 'v -> ('k, 'v) t -> ('k, 'v) t
+val find: 'k -> ('k, 'v) t -> 'v
+val find_str: string -> (string, 'v) t -> 'v
+val mem: 'k -> ('k, 'v) t -> bool
+val remove: 'k -> ('k,  'v) t -> ('k, 'v) t
+val iter: ('k -> 'v -> unit) -> ('k, 'v) t -> unit
+val map: ('k -> 'v1 -> 'v2) -> ('k, 'v1) t -> ('k, 'v2) t
+val fold: ('k -> 'v -> 'acc -> 'acc) -> ('k, 'v) t -> 'acc -> 'acc
+
+open Format
+
+val print: (formatter -> 'k -> unit) -> (formatter -> 'v -> unit) ->
+           formatter -> ('k, 'v) t -> unit
diff --git a/src/ocaml/utils/warnings.ml b/src/ocaml/utils/warnings.ml
new file mode 100644
index 0000000..63c20d5
--- /dev/null
+++ b/src/ocaml/utils/warnings.ml
@@ -0,0 +1,1077 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Pierre Weis && Damien Doligez, INRIA Rocquencourt          *)
+(*                                                                        *)
+(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* When you change this, you need to update:
+   - the list 'description' at the bottom of this file
+   - man/ocamlc.m
+*)
+
+type loc = {
+  loc_start: Lexing.position;
+  loc_end: Lexing.position;
+  loc_ghost: bool;
+}
+
+type field_usage_warning =
+  | Unused
+  | Not_read
+  | Not_mutated
+
+type constructor_usage_warning =
+  | Unused
+  | Not_constructed
+  | Only_exported_private
+
+type t =
+  | Comment_start                           (*  1 *)
+  | Comment_not_end                         (*  2 *)
+(*| Deprecated --> alert "deprecated" *)    (*  3 *)
+  | Fragile_match of string                 (*  4 *)
+  | Ignored_partial_application             (*  5 *)
+  | Labels_omitted of string list           (*  6 *)
+  | Method_override of string list          (*  7 *)
+  | Partial_match of string                 (*  8 *)
+  | Missing_record_field_pattern of string  (*  9 *)
+  | Non_unit_statement                      (* 10 *)
+  | Redundant_case                          (* 11 *)
+  | Redundant_subpat                        (* 12 *)
+  | Instance_variable_override of string list (* 13 *)
+  | Illegal_backslash                       (* 14 *)
+  | Implicit_public_methods of string list  (* 15 *)
+  | Unerasable_optional_argument            (* 16 *)
+  | Undeclared_virtual_method of string     (* 17 *)
+  | Not_principal of string                 (* 18 *)
+  | Non_principal_labels of string          (* 19 *)
+  | Ignored_extra_argument                  (* 20 *)
+  | Nonreturning_statement                  (* 21 *)
+  | Preprocessor of string                  (* 22 *)
+  | Useless_record_with                     (* 23 *)
+  | Bad_module_name of string               (* 24 *)
+  | All_clauses_guarded                     (* 8, used to be 25 *)
+  | Unused_var of string                    (* 26 *)
+  | Unused_var_strict of string             (* 27 *)
+  | Wildcard_arg_to_constant_constr         (* 28 *)
+  | Eol_in_string                           (* 29 *)
+  | Duplicate_definitions of string * string * string * string (*30 *)
+  | Module_linked_twice of string * string * string (* 31 *)
+  | Unused_value_declaration of string      (* 32 *)
+  | Unused_open of string                   (* 33 *)
+  | Unused_type_declaration of string       (* 34 *)
+  | Unused_for_index of string              (* 35 *)
+  | Unused_ancestor of string               (* 36 *)
+  | Unused_constructor of string * constructor_usage_warning (* 37 *)
+  | Unused_extension of string * bool * constructor_usage_warning (* 38 *)
+  | Unused_rec_flag                         (* 39 *)
+  | Name_out_of_scope of string * string list * bool (* 40 *)
+  | Ambiguous_name of string list * string list *  bool * string (* 41 *)
+  | Disambiguated_name of string            (* 42 *)
+  | Nonoptional_label of string             (* 43 *)
+  | Open_shadow_identifier of string * string (* 44 *)
+  | Open_shadow_label_constructor of string * string (* 45 *)
+  | Bad_env_variable of string * string     (* 46 *)
+  | Attribute_payload of string * string    (* 47 *)
+  | Eliminated_optional_arguments of string list (* 48 *)
+  | No_cmi_file of string * string option   (* 49 *)
+  | Unexpected_docstring of bool            (* 50 *)
+  | Wrong_tailcall_expectation of bool      (* 51 *)
+  | Fragile_literal_pattern                 (* 52 *)
+  | Misplaced_attribute of string           (* 53 *)
+  | Duplicated_attribute of string          (* 54 *)
+  | Inlining_impossible of string           (* 55 *)
+  | Unreachable_case                        (* 56 *)
+  | Ambiguous_var_in_pattern_guard of string list (* 57 *)
+  | No_cmx_file of string                   (* 58 *)
+  | Flambda_assignment_to_non_mutable_value (* 59 *)
+  | Unused_module of string                 (* 60 *)
+  | Unboxable_type_in_prim_decl of string   (* 61 *)
+  | Constraint_on_gadt                      (* 62 *)
+  | Erroneous_printed_signature of string   (* 63 *)
+  | Unsafe_array_syntax_without_parsing     (* 64 *)
+  | Redefining_unit of string               (* 65 *)
+  | Unused_open_bang of string              (* 66 *)
+  | Unused_functor_parameter of string      (* 67 *)
+  | Match_on_mutable_state_prevent_uncurry  (* 68 *)
+  | Unused_field of string * field_usage_warning (* 69 *)
+  | Missing_mli                             (* 70 *)
+;;
+
+(* If you remove a warning, leave a hole in the numbering.  NEVER change
+   the numbers of existing warnings.
+   If you add a new warning, add it at the end with a new number;
+   do NOT reuse one of the holes.
+*)
+
+type alert = {kind:string; message:string; def:loc; use:loc}
+
+let number = function
+  | Comment_start -> 1
+  | Comment_not_end -> 2
+  | Fragile_match _ -> 4
+  | Ignored_partial_application -> 5
+  | Labels_omitted _ -> 6
+  | Method_override _ -> 7
+  | Partial_match _ -> 8
+  | Missing_record_field_pattern _ -> 9
+  | Non_unit_statement -> 10
+  | Redundant_case -> 11
+  | Redundant_subpat -> 12
+  | Instance_variable_override _ -> 13
+  | Illegal_backslash -> 14
+  | Implicit_public_methods _ -> 15
+  | Unerasable_optional_argument -> 16
+  | Undeclared_virtual_method _ -> 17
+  | Not_principal _ -> 18
+  | Non_principal_labels _ -> 19
+  | Ignored_extra_argument -> 20
+  | Nonreturning_statement -> 21
+  | Preprocessor _ -> 22
+  | Useless_record_with -> 23
+  | Bad_module_name _ -> 24
+  | All_clauses_guarded -> 8 (* used to be 25 *)
+  | Unused_var _ -> 26
+  | Unused_var_strict _ -> 27
+  | Wildcard_arg_to_constant_constr -> 28
+  | Eol_in_string -> 29
+  | Duplicate_definitions _ -> 30
+  | Module_linked_twice _ -> 31
+  | Unused_value_declaration _ -> 32
+  | Unused_open _ -> 33
+  | Unused_type_declaration _ -> 34
+  | Unused_for_index _ -> 35
+  | Unused_ancestor _ -> 36
+  | Unused_constructor _ -> 37
+  | Unused_extension _ -> 38
+  | Unused_rec_flag -> 39
+  | Name_out_of_scope _ -> 40
+  | Ambiguous_name _ -> 41
+  | Disambiguated_name _ -> 42
+  | Nonoptional_label _ -> 43
+  | Open_shadow_identifier _ -> 44
+  | Open_shadow_label_constructor _ -> 45
+  | Bad_env_variable _ -> 46
+  | Attribute_payload _ -> 47
+  | Eliminated_optional_arguments _ -> 48
+  | No_cmi_file _ -> 49
+  | Unexpected_docstring _ -> 50
+  | Wrong_tailcall_expectation _ -> 51
+  | Fragile_literal_pattern -> 52
+  | Misplaced_attribute _ -> 53
+  | Duplicated_attribute _ -> 54
+  | Inlining_impossible _ -> 55
+  | Unreachable_case -> 56
+  | Ambiguous_var_in_pattern_guard _ -> 57
+  | No_cmx_file _ -> 58
+  | Flambda_assignment_to_non_mutable_value -> 59
+  | Unused_module _ -> 60
+  | Unboxable_type_in_prim_decl _ -> 61
+  | Constraint_on_gadt -> 62
+  | Erroneous_printed_signature _ -> 63
+  | Unsafe_array_syntax_without_parsing -> 64
+  | Redefining_unit _ -> 65
+  | Unused_open_bang _ -> 66
+  | Unused_functor_parameter _ -> 67
+  | Match_on_mutable_state_prevent_uncurry -> 68
+  | Unused_field _ -> 69
+  | Missing_mli -> 70
+;;
+
+let last_warning_number = 70
+;;
+
+(* Third component of each tuple is the list of names for each warning. The
+   first element of the list is the current name, any following ones are
+   deprecated. The current name should always be derived mechanically from the
+   constructor name. *)
+
+let descriptions =
+  [
+    1, "Suspicious-looking start-of-comment mark.",
+    ["comment-start"];
+    2, "Suspicious-looking end-of-comment mark.",
+    ["comment-not-end"];
+    3, "Deprecated synonym for the 'deprecated' alert.",
+    [];
+    4, "Fragile pattern matching: matching that will remain complete even\n\
+       \    if additional constructors are added to one of the variant types\n\
+       \    matched.",
+    ["fragile-match"];
+    5, "Partially applied function: expression whose result has function\n\
+       \    type and is ignored.",
+    ["ignored-partial-application"];
+    6, "Label omitted in function application.",
+    ["labels-omitted"];
+    7, "Method overridden.",
+    ["method-override"];
+    8, "Partial match: missing cases in pattern-matching.",
+    ["partial-match"];
+    9, "Missing fields in a record pattern.",
+    ["missing-record-field-pattern"];
+    10,
+    "Expression on the left-hand side of a sequence that doesn't have type\n\
+    \    \"unit\" (and that is not a function, see warning number 5).",
+    ["non-unit-statement"];
+    11, "Redundant case in a pattern matching (unused match case).",
+    ["redundant-case"];
+    12, "Redundant sub-pattern in a pattern-matching.",
+    ["redundant-subpat"];
+    13, "Instance variable overridden.",
+    ["instance-variable-override"];
+    14, "Illegal backslash escape in a string constant.",
+    ["illegal-backslash"];
+    15, "Private method made public implicitly.",
+    ["implicit-public-methods"];
+    16, "Unerasable optional argument.",
+    ["unerasable-optional-argument"];
+    17, "Undeclared virtual method.",
+    ["undeclared-virtual-method"];
+    18, "Non-principal type.",
+    ["not-principal"];
+    19, "Type without principality.",
+    ["non-principal-labels"];
+    20, "Unused function argument.",
+    ["ignored-extra-argument"];
+    21, "Non-returning statement.",
+    ["nonreturning-statement"];
+    22, "Preprocessor warning.",
+    ["preprocessor"];
+    23, "Useless record \"with\" clause.",
+    ["useless-record-with"];
+    24,
+    "Bad module name: the source file name is not a valid OCaml module name.",
+    ["bad-module-name"];
+    25, "Ignored: now part of warning 8.",
+    [];
+    26,
+    "Suspicious unused variable: unused variable that is bound\n\
+    \    with \"let\" or \"as\", and doesn't start with an underscore (\"_\")\n\
+    \    character.",
+    ["unused-var"];
+    27, "Innocuous unused variable: unused variable that is not bound with\n\
+        \    \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\
+        \    character.",
+    ["unused-var-strict"];
+    28, "Wildcard pattern given as argument to a constant constructor.",
+    ["wildcard-arg-to-constant-constr"];
+    29, "Unescaped end-of-line in a string constant (non-portable code).",
+    ["eol-in-string"];
+    30, "Two labels or constructors of the same name are defined in two\n\
+        \    mutually recursive types.",
+    ["duplicate-definitions"];
+    31, "A module is linked twice in the same executable.",
+    ["module-linked-twice"];
+    32, "Unused value declaration.",
+    ["unused-value-declaration"];
+    33, "Unused open statement.",
+    ["unused-open"];
+    34, "Unused type declaration.",
+    ["unused-type-declaration"];
+    35, "Unused for-loop index.",
+    ["unused-for-index"];
+    36, "Unused ancestor variable.",
+    ["unused-ancestor"];
+    37, "Unused constructor.",
+    ["unused-constructor"];
+    38, "Unused extension constructor.",
+    ["unused-extension"];
+    39, "Unused rec flag.",
+    ["unused-rec-flag"];
+    40, "Constructor or label name used out of scope.",
+    ["name-out-of-scope"];
+    41, "Ambiguous constructor or label name.",
+    ["ambiguous-name"];
+    42, "Disambiguated constructor or label name (compatibility warning).",
+    ["disambiguated-name"];
+    43, "Nonoptional label applied as optional.",
+    ["nonoptional-label"];
+    44, "Open statement shadows an already defined identifier.",
+    ["open-shadow-identifier"];
+    45, "Open statement shadows an already defined label or constructor.",
+    ["open-shadow-label-constructor"];
+    46, "Error in environment variable.",
+    ["bad-env-variable"];
+    47, "Illegal attribute payload.",
+    ["attribute-payload"];
+    48, "Implicit elimination of optional arguments.",
+    ["eliminated-optional-arguments"];
+    49, "Absent cmi file when looking up module alias.",
+    ["no-cmi-file"];
+    50, "Unexpected documentation comment.",
+    ["unexpected-docstring"];
+    51, "Function call annotated with an incorrect @tailcall attribute",
+    ["wrong-tailcall-expectation"];
+    52, "Fragile constant pattern.",
+    ["fragile-literal-pattern"];
+    53, "Attribute cannot appear in this context.",
+    ["misplaced-attribute"];
+    54, "Attribute used more than once on an expression.",
+    ["duplicated-attribute"];
+    55, "Inlining impossible.",
+    ["inlining-impossible"];
+    56, "Unreachable case in a pattern-matching (based on type information).",
+    ["unreachable-case"];
+    57, "Ambiguous or-pattern variables under guard.",
+    ["ambiguous-var-in-pattern-guard"];
+    58, "Missing cmx file.",
+    ["no-cmx-file"];
+    59, "Assignment to non-mutable value.",
+    ["flambda-assignment-to-non-mutable-value"];
+    60, "Unused module declaration.",
+    ["unused-module"];
+    61, "Unboxable type in primitive declaration.",
+    ["unboxable-type-in-prim-decl"];
+    62, "Type constraint on GADT type declaration.",
+    ["constraint-on-gadt"];
+    63, "Erroneous printed signature.",
+    ["erroneous-printed-signature"];
+    64, "-unsafe used with a preprocessor returning a syntax tree.",
+    ["unsafe-array-syntax-without-parsing"];
+    65, "Type declaration defining a new '()' constructor.",
+    ["redefining-unit"];
+    66, "Unused open! statement.",
+    ["unused-open-bang"];
+    67, "Unused functor parameter.",
+    ["unused-functor-parameter"];
+    68, "Pattern-matching depending on mutable state prevents the remaining \
+         arguments from being uncurried.",
+    ["match-on-mutable-state-prevent-uncurry"];
+    69, "Unused record field.",
+    ["unused-field"];
+    70, "Missing interface file.",
+    ["missing-mli"]
+  ]
+;;
+
+let name_to_number =
+  let h = Hashtbl.create last_warning_number in
+  List.iter (fun (num, _, names) ->
+      List.iter (fun name -> Hashtbl.add h name num) names
+    ) descriptions;
+  fun s -> Hashtbl.find_opt h s
+;;
+
+(* Must be the max number returned by the [number] function. *)
+
+let letter = function
+  | 'a' ->
+     let rec loop i = if i = 0 then [] else i :: loop (i - 1) in
+     loop last_warning_number
+  | 'b' -> []
+  | 'c' -> [1; 2]
+  | 'd' -> [3]
+  | 'e' -> [4]
+  | 'f' -> [5]
+  | 'g' -> []
+  | 'h' -> []
+  | 'i' -> []
+  | 'j' -> []
+  | 'k' -> [32; 33; 34; 35; 36; 37; 38; 39]
+  | 'l' -> [6]
+  | 'm' -> [7]
+  | 'n' -> []
+  | 'o' -> []
+  | 'p' -> [8]
+  | 'q' -> []
+  | 'r' -> [9]
+  | 's' -> [10]
+  | 't' -> []
+  | 'u' -> [11; 12]
+  | 'v' -> [13]
+  | 'w' -> []
+  | 'x' -> [14; 15; 16; 17; 18; 19; 20; 21; 22; 23; 24; 30]
+  | 'y' -> [26]
+  | 'z' -> [27]
+  | _ -> assert false
+;;
+
+type state =
+  {
+    active: bool array;
+    error: bool array;
+    alerts: (Std.String.Set.t * bool); (* false:set complement *)
+    alert_errors: (Std.String.Set.t * bool); (* false:set complement *)
+  }
+
+let current =
+  ref
+    {
+      active = Array.make (last_warning_number + 1) true;
+      error = Array.make (last_warning_number + 1) false;
+      alerts = (Std.String.Set.empty, false); (* all enabled *)
+      alert_errors = (Std.String.Set.empty, true); (* all soft *)
+    }
+
+let disabled = ref false
+
+let without_warnings f =
+  Misc.protect_refs [Misc.R(disabled, true)] f
+
+let backup () = !current
+
+let restore x = current := x
+
+(* Some warnings are not properly implemented in merlin, just disable *)
+let is_disabled x = Config.merlin && ((x >= 32 && x <= 39) || x = 60 || x = 69)
+
+let is_active x =
+  not !disabled &&
+  let x = number x in
+  not (is_disabled x) && (!current).active.(x)
+
+let is_error x =
+  not !disabled &&
+  let x = number x in
+  not (is_disabled x) && (!current).error.(x)
+
+let alert_is_active {kind; _} =
+  not !disabled &&
+  let (set, pos) = (!current).alerts in
+  Std.String.Set.mem kind set = pos
+
+let alert_is_error {kind; _} =
+  not !disabled &&
+  let (set, pos) = (!current).alert_errors in
+  Std.String.Set.mem kind set = pos
+
+let mk_lazy f =
+  let state = backup () in
+  lazy
+    (
+      let prev = backup () in
+      restore state;
+      try
+        let r = f () in
+        restore prev;
+        r
+      with exn ->
+        restore prev;
+        raise exn
+    )
+
+let set_alert ~error ~enable s =
+  let upd =
+    match s with
+    | "all" ->
+        (Std.String.Set.empty, not enable)
+    | s ->
+        let (set, pos) =
+          if error then (!current).alert_errors else (!current).alerts
+        in
+        let f =
+          if enable = pos
+          then Std.String.Set.add
+          else Std.String.Set.remove
+        in
+        (f s set, pos)
+  in
+  if error then
+    current := {(!current) with alert_errors=upd}
+  else
+    current := {(!current) with alerts=upd}
+
+let parse_alert_option s =
+  let n = String.length s in
+  let id_char = function
+    | 'a'..'z' | 'A'..'Z' | '_' | '\'' | '0'..'9' -> true
+    | _ -> false
+  in
+  let rec parse_id i =
+    if i < n && id_char s.[i] then parse_id (i + 1) else i
+  in
+  let rec scan i =
+    if i = n then ()
+    else if i + 1 = n then raise (Arg.Bad "Ill-formed list of alert settings")
+    else match s.[i], s.[i+1] with
+      | '+', '+' -> id (set_alert ~error:true ~enable:true) (i + 2)
+      | '+', _ -> id (set_alert ~error:false ~enable:true) (i + 1)
+      | '-', '-' -> id (set_alert ~error:true ~enable:false) (i + 2)
+      | '-', _ -> id (set_alert ~error:false ~enable:false) (i + 1)
+      | '@', _ ->
+          id (fun s ->
+              set_alert ~error:true ~enable:true s;
+              set_alert ~error:false ~enable:true s)
+            (i + 1)
+      | _ -> raise (Arg.Bad "Ill-formed list of alert settings")
+  and id f i =
+    let j = parse_id i in
+    if j = i then raise (Arg.Bad "Ill-formed list of alert settings");
+    let id = String.sub s i (j - i) in
+    f id;
+    scan j
+  in
+  scan 0
+
+type modifier =
+  | Set (** +a *)
+  | Clear (** -a *)
+  | Set_all (** @a *)
+
+type token =
+  | Letter of char * modifier option
+  | Num of int * int * modifier
+
+let letter_alert tokens =
+  let print_warning_char ppf c =
+    let lowercase = Char.lowercase_ascii c = c in
+    Format.fprintf ppf "%c%c"
+      (if lowercase then '-' else '+') c
+  in
+  let print_modifier ppf = function
+    | Set_all -> Format.fprintf ppf "@"
+    | Clear -> Format.fprintf ppf "-"
+    | Set -> Format.fprintf ppf "+"
+  in
+  let print_token ppf = function
+    | Num (a,b,m) -> if a = b then
+          Format.fprintf ppf "%a%d" print_modifier m a
+        else
+          Format.fprintf ppf "%a%d..%d" print_modifier m a b
+    | Letter(l,Some m) -> Format.fprintf ppf "%a%c" print_modifier m l
+    | Letter(l,None) -> print_warning_char ppf l
+  in
+  let consecutive_letters =
+    (* we are tracking sequences of 2 or more consecutive unsigned letters
+       in warning strings, for instance in '-w "not-principa"'. *)
+    let commit_chunk l = function
+      | [] | [ _ ] -> l
+      | _ :: _ :: _ as chunk -> List.rev chunk :: l
+    in
+    let group_consecutive_letters (l,current) = function
+    | Letter (x, None) -> (l, x::current)
+    | _ -> (commit_chunk l current, [])
+    in
+    let l, on_going =
+      List.fold_left group_consecutive_letters ([],[]) tokens
+    in
+    commit_chunk l on_going
+  in
+  match consecutive_letters with
+  | [] -> None
+  | example :: _  ->
+      let pos = { Lexing.dummy_pos with pos_fname = "_none_" } in
+      let nowhere = { loc_start=pos; loc_end=pos; loc_ghost=true } in
+      let spelling_hint ppf =
+        let max_seq_len =
+          List.fold_left (fun l x -> Int.max l (List.length x))
+            0 consecutive_letters
+        in
+        if max_seq_len >= 5 then
+          Format.fprintf ppf
+            "@ @[Hint: Did you make a spelling mistake \
+             when using a mnemonic name?@]"
+        else
+          ()
+      in
+      let message =
+        Format.asprintf
+          "@[<v>@[Setting a warning with a sequence of lowercase \
+           or uppercase letters,@ like '%a',@ is deprecated.@]@ \
+           @[Use the equivalent signed form:@ %t.@]@ \
+           @[Hint: Enabling or disabling a warning by its mnemonic name \
+           requires a + or - prefix.@]\
+           %t@?@]"
+          Format.(pp_print_list ~pp_sep:(fun _ -> ignore) pp_print_char) example
+          (fun ppf -> List.iter (print_token ppf) tokens)
+          spelling_hint
+      in
+      Some {
+        kind="ocaml_deprecated_cli";
+        use=nowhere; def=nowhere;
+        message
+      }
+
+
+let parse_warnings s =
+  let error () = raise (Arg.Bad "Ill-formed list of warnings") in
+  let rec get_num n i =
+    if i >= String.length s then i, n
+    else match s.[i] with
+    | '0'..'9' -> get_num (10 * n + Char.code s.[i] - Char.code '0') (i + 1)
+    | _ -> i, n
+  in
+  let get_range i =
+    let i, n1 = get_num 0 i in
+    if i + 2 < String.length s && s.[i] = '.' && s.[i + 1] = '.' then
+      let i, n2 = get_num 0 (i + 2) in
+      if n2 < n1 then error ();
+      i, n1, n2
+    else
+      i, n1, n1
+  in
+  let rec loop tokens i =
+    if i >= String.length s then List.rev tokens else
+    match s.[i] with
+    | 'A' .. 'Z' | 'a' .. 'z' ->
+        loop (Letter(s.[i],None)::tokens) (i+1)
+    | '+' -> loop_letter_num tokens Set (i+1)
+    | '-' -> loop_letter_num tokens Clear (i+1)
+    | '@' -> loop_letter_num tokens Set_all (i+1)
+    | _ -> error ()
+  and loop_letter_num tokens modifier i =
+    if i >= String.length s then error () else
+    match s.[i] with
+    | '0' .. '9' ->
+        let i, n1, n2 = get_range i in
+        loop (Num(n1,n2,modifier)::tokens) i
+    | 'A' .. 'Z' | 'a' .. 'z' ->
+       loop (Letter(s.[i],Some modifier)::tokens) (i+1)
+    | _ -> error ()
+  in
+  loop [] 0
+
+let parse_opt error active errflag s =
+  let flags = if errflag then error else active in
+  let action modifier i = match modifier with
+    | Set ->
+        if i = 3 then set_alert ~error:errflag ~enable:true "deprecated"
+        else flags.(i) <- true
+    | Clear ->
+        if i = 3 then set_alert ~error:errflag ~enable:false "deprecated"
+        else flags.(i) <- false
+    | Set_all ->
+        if i = 3 then begin
+          set_alert ~error:false ~enable:true "deprecated";
+          set_alert ~error:true ~enable:true "deprecated"
+        end
+        else begin
+          active.(i) <- true;
+          error.(i) <- true
+        end
+  in
+  let eval = function
+    | Letter(c, m) ->
+        let lc = Char.lowercase_ascii c in
+        let modifier = match m with
+          | None -> if c = lc then Clear else Set
+          | Some m -> m
+        in
+        List.iter (action modifier) (letter lc)
+    | Num(n1,n2,modifier) ->
+        for n = n1 to Int.min n2 last_warning_number do action modifier n done
+  in
+  let parse_and_eval s =
+    let tokens = parse_warnings s in
+    List.iter eval tokens;
+    letter_alert tokens
+  in
+   match name_to_number s with
+  | Some n -> action Set n; None
+  | None ->
+      if s = "" then parse_and_eval s
+      else begin
+        let rest = String.sub s 1 (String.length s - 1) in
+        match s.[0], name_to_number rest with
+        | '+', Some n -> action Set n; None
+        | '-', Some n -> action Clear n; None
+        | '@', Some n -> action Set_all n; None
+        | _ -> parse_and_eval s
+      end
+;;
+
+let parse_options errflag s =
+  let error = Array.copy (!current).error in
+  let active = Array.copy (!current).active in
+  let alerts = parse_opt error active errflag s in
+  current := {(!current) with error; active};
+  alerts
+
+(* If you change these, don't forget to change them in man/ocamlc.m *)
+let defaults_w = "+a-4-7-9-27-29-30-32..42-44-45-48-50-60-66..70";;
+let defaults_warn_error = "-a+31";;
+
+let () = ignore @@ parse_options false defaults_w;;
+let () = ignore @@ parse_options true defaults_warn_error;;
+
+let ref_manual_explanation () =
+  (* manual references are checked a posteriori by the manual
+     cross-reference consistency check in manual/tests*)
+  let[@manual.ref "s:comp-warnings"] chapter, section = 11, 5 in
+  Printf.sprintf "(See manual section %d.%d)" chapter section
+
+let message = function
+  | Comment_start ->
+      "this `(*' is the start of a comment.\n\
+       Hint: Did you forget spaces when writing the infix operator `( * )'?"
+  | Comment_not_end -> "this is not the end of a comment."
+  | Fragile_match "" ->
+      "this pattern-matching is fragile."
+  | Fragile_match s ->
+      "this pattern-matching is fragile.\n\
+       It will remain exhaustive when constructors are added to type " ^ s ^ "."
+  | Ignored_partial_application ->
+      "this function application is partial,\n\
+       maybe some arguments are missing."
+  | Labels_omitted [] -> assert false
+  | Labels_omitted [l] ->
+     "label " ^ l ^ " was omitted in the application of this function."
+  | Labels_omitted ls ->
+     "labels " ^ String.concat ", " ls ^
+       " were omitted in the application of this function."
+  | Method_override [lab] ->
+      "the method " ^ lab ^ " is overridden."
+  | Method_override (cname :: slist) ->
+      String.concat " "
+        ("the following methods are overridden by the class"
+         :: cname  :: ":\n " :: slist)
+  | Method_override [] -> assert false
+  | Partial_match "" -> "this pattern-matching is not exhaustive."
+  | Partial_match s ->
+      "this pattern-matching is not exhaustive.\n\
+       Here is an example of a case that is not matched:\n" ^ s
+  | Missing_record_field_pattern s ->
+      "the following labels are not bound in this record pattern:\n" ^ s ^
+      "\nEither bind these labels explicitly or add '; _' to the pattern."
+  | Non_unit_statement ->
+      "this expression should have type unit."
+  | Redundant_case -> "this match case is unused."
+  | Redundant_subpat -> "this sub-pattern is unused."
+  | Instance_variable_override [lab] ->
+      "the instance variable " ^ lab ^ " is overridden.\n" ^
+      "The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)"
+  | Instance_variable_override (cname :: slist) ->
+      String.concat " "
+        ("the following instance variables are overridden by the class"
+         :: cname  :: ":\n " :: slist) ^
+      "\nThe behaviour changed in ocaml 3.10 (previous behaviour was hiding.)"
+  | Instance_variable_override [] -> assert false
+  | Illegal_backslash -> "illegal backslash escape in string."
+  | Implicit_public_methods l ->
+      "the following private methods were made public implicitly:\n "
+      ^ String.concat " " l ^ "."
+  | Unerasable_optional_argument -> "this optional argument cannot be erased."
+  | Undeclared_virtual_method m -> "the virtual method "^m^" is not declared."
+  | Not_principal s -> s^" is not principal."
+  | Non_principal_labels s -> s^" without principality."
+  | Ignored_extra_argument -> "this argument will not be used by the function."
+  | Nonreturning_statement ->
+      "this statement never returns (or has an unsound type.)"
+  | Preprocessor s -> s
+  | Useless_record_with ->
+      "all the fields are explicitly listed in this record:\n\
+       the 'with' clause is useless."
+  | Bad_module_name (modname) ->
+      "bad source file name: \"" ^ modname ^ "\" is not a valid module name."
+  | All_clauses_guarded ->
+      "this pattern-matching is not exhaustive.\n\
+       All clauses in this pattern-matching are guarded."
+  | Unused_var v | Unused_var_strict v -> "unused variable " ^ v ^ "."
+  | Wildcard_arg_to_constant_constr ->
+     "wildcard pattern given as argument to a constant constructor"
+  | Eol_in_string ->
+     "unescaped end-of-line in a string constant (non-portable code)"
+  | Duplicate_definitions (kind, cname, tc1, tc2) ->
+      Printf.sprintf "the %s %s is defined in both types %s and %s."
+        kind cname tc1 tc2
+  | Module_linked_twice(modname, file1, file2) ->
+      Printf.sprintf
+        "files %s and %s both define a module named %s"
+        file1 file2 modname
+  | Unused_value_declaration v -> "unused value " ^ v ^ "."
+  | Unused_open s -> "unused open " ^ s ^ "."
+  | Unused_open_bang s -> "unused open! " ^ s ^ "."
+  | Unused_type_declaration s -> "unused type " ^ s ^ "."
+  | Unused_for_index s -> "unused for-loop index " ^ s ^ "."
+  | Unused_ancestor s -> "unused ancestor variable " ^ s ^ "."
+  | Unused_constructor (s, Unused) -> "unused constructor " ^ s ^ "."
+  | Unused_constructor (s, Not_constructed) ->
+      "constructor " ^ s ^
+      " is never used to build values.\n\
+        (However, this constructor appears in patterns.)"
+  | Unused_constructor (s, Only_exported_private) ->
+      "constructor " ^ s ^
+      " is never used to build values.\n\
+        Its type is exported as a private type."
+  | Unused_extension (s, is_exception, complaint) ->
+     let kind =
+       if is_exception then "exception" else "extension constructor" in
+     let name = kind ^ " " ^ s in
+     begin match complaint with
+       | Unused -> "unused " ^ name
+       | Not_constructed ->
+          name ^
+          " is never used to build values.\n\
+           (However, this constructor appears in patterns.)"
+       | Only_exported_private ->
+          name ^
+          " is never used to build values.\n\
+            It is exported or rebound as a private extension."
+     end
+  | Unused_rec_flag ->
+      "unused rec flag."
+  | Name_out_of_scope (ty, [nm], false) ->
+      nm ^ " was selected from type " ^ ty ^
+      ".\nIt is not visible in the current scope, and will not \n\
+       be selected if the type becomes unknown."
+  | Name_out_of_scope (_, _, false) -> assert false
+  | Name_out_of_scope (ty, slist, true) ->
+      "this record of type "^ ty ^" contains fields that are \n\
+       not visible in the current scope: "
+      ^ String.concat " " slist ^ ".\n\
+       They will not be selected if the type becomes unknown."
+  | Ambiguous_name ([s], tl, false, expansion) ->
+      s ^ " belongs to several types: " ^ String.concat " " tl ^
+      "\nThe first one was selected. Please disambiguate if this is wrong."
+      ^ expansion
+  | Ambiguous_name (_, _, false, _ ) -> assert false
+  | Ambiguous_name (_slist, tl, true, expansion) ->
+      "these field labels belong to several types: " ^
+      String.concat " " tl ^
+      "\nThe first one was selected. Please disambiguate if this is wrong."
+      ^ expansion
+  | Disambiguated_name s ->
+      "this use of " ^ s ^ " relies on type-directed disambiguation,\n\
+       it will not compile with OCaml 4.00 or earlier."
+  | Nonoptional_label s ->
+      "the label " ^ s ^ " is not optional."
+  | Open_shadow_identifier (kind, s) ->
+      Printf.sprintf
+        "this open statement shadows the %s identifier %s (which is later used)"
+        kind s
+  | Open_shadow_label_constructor (kind, s) ->
+      Printf.sprintf
+        "this open statement shadows the %s %s (which is later used)"
+        kind s
+  | Bad_env_variable (var, s) ->
+      Printf.sprintf "illegal environment variable %s : %s" var s
+  | Attribute_payload (a, s) ->
+      Printf.sprintf "illegal payload for attribute '%s'.\n%s" a s
+  | Eliminated_optional_arguments sl ->
+      Printf.sprintf "implicit elimination of optional argument%s %s"
+        (if List.length sl = 1 then "" else "s")
+        (String.concat ", " sl)
+  | No_cmi_file(name, None) ->
+      "no cmi file was found in path for module " ^ name
+  | No_cmi_file(name, Some msg) ->
+      Printf.sprintf
+        "no valid cmi file was found in path for module %s. %s"
+        name msg
+  | Unexpected_docstring unattached ->
+      if unattached then "unattached documentation comment (ignored)"
+      else "ambiguous documentation comment"
+  | Wrong_tailcall_expectation b ->
+      Printf.sprintf "expected %s"
+        (if b then "tailcall" else "non-tailcall")
+  | Fragile_literal_pattern ->
+      Printf.sprintf
+        "Code should not depend on the actual values of\n\
+         this constructor's arguments. They are only for information\n\
+         and may change in future versions. %t" ref_manual_explanation
+  | Unreachable_case ->
+      "this match case is unreachable.\n\
+       Consider replacing it with a refutation case '<pat> -> .'"
+  | Misplaced_attribute attr_name ->
+      Printf.sprintf "the %S attribute cannot appear in this context" attr_name
+  | Duplicated_attribute attr_name ->
+      Printf.sprintf "the %S attribute is used more than once on this \
+          expression"
+        attr_name
+  | Inlining_impossible reason ->
+      Printf.sprintf "Cannot inline: %s" reason
+  | Ambiguous_var_in_pattern_guard vars ->
+      let msg =
+        let vars = List.sort String.compare vars in
+        match vars with
+        | [] -> assert false
+        | [x] -> "variable " ^ x
+        | _::_ ->
+            "variables " ^ String.concat "," vars in
+      Printf.sprintf
+        "Ambiguous or-pattern variables under guard;\n\
+         %s may match different arguments. %t"
+        msg ref_manual_explanation
+  | No_cmx_file name ->
+      Printf.sprintf
+        "no cmx file was found in path for module %s, \
+         and its interface was not compiled with -opaque" name
+  | Flambda_assignment_to_non_mutable_value ->
+      "A potential assignment to a non-mutable value was detected \n\
+        in this source file.  Such assignments may generate incorrect code \n\
+        when using Flambda."
+  | Unused_module s -> "unused module " ^ s ^ "."
+  | Unboxable_type_in_prim_decl t ->
+      Printf.sprintf
+        "This primitive declaration uses type %s, whose representation\n\
+         may be either boxed or unboxed. Without an annotation to indicate\n\
+         which representation is intended, the boxed representation has been\n\
+         selected by default. This default choice may change in future\n\
+         versions of the compiler, breaking the primitive implementation.\n\
+         You should explicitly annotate the declaration of %s\n\
+         with [@@boxed] or [@@unboxed], so that its external interface\n\
+         remains stable in the future." t t
+  | Constraint_on_gadt ->
+      "Type constraints do not apply to GADT cases of variant types."
+  | Erroneous_printed_signature s ->
+      "The printed interface differs from the inferred interface.\n\
+       The inferred interface contained items which could not be printed\n\
+       properly due to name collisions between identifiers."
+     ^ s
+     ^ "\nBeware that this warning is purely informational and will not catch\n\
+        all instances of erroneous printed interface."
+  | Unsafe_array_syntax_without_parsing ->
+     "option -unsafe used with a preprocessor returning a syntax tree"
+  | Redefining_unit name ->
+      Printf.sprintf
+        "This type declaration is defining a new '()' constructor\n\
+         which shadows the existing one.\n\
+         Hint: Did you mean 'type %s = unit'?" name
+  | Unused_functor_parameter s -> "unused functor parameter " ^ s ^ "."
+  | Match_on_mutable_state_prevent_uncurry ->
+    "This pattern depends on mutable state.\n\
+     It prevents the remaining arguments from being uncurried, which will \
+     cause additional closure allocations."
+  | Unused_field (s, Unused) -> "unused record field " ^ s ^ "."
+  | Unused_field (s, Not_read) ->
+      "record field " ^ s ^
+      " is never read.\n\
+        (However, this field is used to build or mutate values.)"
+  | Unused_field (s, Not_mutated) ->
+      "mutable record field " ^ s ^
+      " is never mutated."
+  | Missing_mli ->
+    "Cannot find interface file."
+;;
+
+let nerrors = ref 0;;
+
+type reporting_information =
+  { id : string
+  ; message : string
+  ; is_error : bool
+  ; sub_locs : (loc * string) list;
+  }
+
+let id_name w =
+  let n = number w in
+  (* (* Merlin: let's keep our messages compact. *)
+  match List.find_opt (fun (m, _, _) -> m = n) descriptions with
+  | Some (_, _, s :: _) ->
+      Printf.sprintf "%d [%s]" n s
+  | _ ->
+      string_of_int n
+  *)
+  string_of_int n
+
+let report w =
+  match is_active w with
+  | false -> `Inactive
+  | true ->
+     if is_error w then incr nerrors;
+     `Active
+       { id = id_name w;
+         message = message w;
+         is_error = is_error w;
+         sub_locs = [];
+       }
+
+let report_alert (alert : alert) =
+  match alert_is_active alert with
+  | false -> `Inactive
+  | true ->
+      let is_error = alert_is_error alert in
+      if is_error then incr nerrors;
+      let message = Misc.normalise_eol alert.message in
+       (* Reduce \r\n to \n:
+           - Prevents any \r characters being printed on Unix when processing
+             Windows sources
+           - Prevents \r\r\n being generated on Windows, which affects the
+             testsuite
+       *)
+      let sub_locs =
+        if not alert.def.loc_ghost && not alert.use.loc_ghost then
+          [
+            alert.def, "Definition";
+            alert.use, "Expected signature";
+          ]
+        else
+          []
+      in
+      `Active
+        {
+          id = alert.kind;
+          message;
+          is_error;
+          sub_locs;
+        }
+
+exception Errors;;
+
+let reset_fatal () =
+  nerrors := 0
+
+let check_fatal () =
+  if !nerrors > 0 then begin
+    nerrors := 0;
+    raise Errors;
+  end;
+;;
+
+let help_warnings () =
+  List.iter
+    (fun (i, s, names) ->
+       let name =
+         match names with
+         | s :: _ -> " [" ^ s ^ "]"
+         | [] -> ""
+       in
+       Printf.printf "%3i%s %s\n" i name s)
+    descriptions;
+  print_endline "  A all warnings";
+  for i = Char.code 'b' to Char.code 'z' do
+    let c = Char.chr i in
+    match letter c with
+    | [] -> ()
+    | [n] ->
+        Printf.printf "  %c Alias for warning %i.\n" (Char.uppercase_ascii c) n
+    | l ->
+        Printf.printf "  %c warnings %s.\n"
+          (Char.uppercase_ascii c)
+          (String.concat ", " (List.map Int.to_string l))
+  done;
+  exit 0
+;;
+
+(* merlin *)
+
+let dump ?(verbose=false) () =
+  let open Std in
+  let actives arr =
+    let acc = ref [] in
+    for i = 1 to last_warning_number do
+      if arr.(i) then (
+        let x =
+          try
+            if verbose then
+              let _,desc,_ = List.find ~f:(fun (n, _, _) -> n = i) descriptions in
+              `String (string_of_int i ^ ": " ^ desc)
+            else
+              `Int i
+          with Not_found -> `Int i
+        in
+        acc := x :: !acc
+      )
+    done;
+    List.rev !acc
+  in
+  let alerts (set, enabled) =
+    `Assoc
+      [ "alerts", Json.list Json.string (String.Set.elements set);
+        "complement", Json.bool (not enabled) ]
+  in
+  `Assoc [
+    "actives", `List (actives !current.active);
+    "warn_error", `List (actives !current.error);
+    "alerts", alerts !current.alerts;
+    "alerts_error", alerts !current.alert_errors;
+  ]
+;;
diff --git a/src/ocaml/utils/warnings.mli b/src/ocaml/utils/warnings.mli
new file mode 100644
index 0000000..6855edf
--- /dev/null
+++ b/src/ocaml/utils/warnings.mli
@@ -0,0 +1,156 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Pierre Weis && Damien Doligez, INRIA Rocquencourt          *)
+(*                                                                        *)
+(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Warning definitions
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type loc = {
+  loc_start: Lexing.position;
+  loc_end: Lexing.position;
+  loc_ghost: bool;
+}
+
+type field_usage_warning =
+  | Unused
+  | Not_read
+  | Not_mutated
+
+type constructor_usage_warning =
+  | Unused
+  | Not_constructed
+  | Only_exported_private
+
+type t =
+  | Comment_start                           (*  1 *)
+  | Comment_not_end                         (*  2 *)
+(*| Deprecated --> alert "deprecated" *)    (*  3 *)
+  | Fragile_match of string                 (*  4 *)
+  | Ignored_partial_application             (*  5 *)
+  | Labels_omitted of string list           (*  6 *)
+  | Method_override of string list          (*  7 *)
+  | Partial_match of string                 (*  8 *)
+  | Missing_record_field_pattern of string  (*  9 *)
+  | Non_unit_statement                      (* 10 *)
+  | Redundant_case                          (* 11 *)
+  | Redundant_subpat                        (* 12 *)
+  | Instance_variable_override of string list (* 13 *)
+  | Illegal_backslash                       (* 14 *)
+  | Implicit_public_methods of string list  (* 15 *)
+  | Unerasable_optional_argument            (* 16 *)
+  | Undeclared_virtual_method of string     (* 17 *)
+  | Not_principal of string                 (* 18 *)
+  | Non_principal_labels of string          (* 19 *)
+  | Ignored_extra_argument                  (* 20 *)
+  | Nonreturning_statement                  (* 21 *)
+  | Preprocessor of string                  (* 22 *)
+  | Useless_record_with                     (* 23 *)
+  | Bad_module_name of string               (* 24 *)
+  | All_clauses_guarded                     (* 8, used to be 25 *)
+  | Unused_var of string                    (* 26 *)
+  | Unused_var_strict of string             (* 27 *)
+  | Wildcard_arg_to_constant_constr         (* 28 *)
+  | Eol_in_string                           (* 29 *)
+  | Duplicate_definitions of string * string * string * string (* 30 *)
+  | Module_linked_twice of string * string * string (* 31 *)
+  | Unused_value_declaration of string      (* 32 *)
+  | Unused_open of string                   (* 33 *)
+  | Unused_type_declaration of string       (* 34 *)
+  | Unused_for_index of string              (* 35 *)
+  | Unused_ancestor of string               (* 36 *)
+  | Unused_constructor of string * constructor_usage_warning (* 37 *)
+  | Unused_extension of string * bool * constructor_usage_warning (* 38 *)
+  | Unused_rec_flag                         (* 39 *)
+  | Name_out_of_scope of string * string list * bool   (* 40 *)
+  | Ambiguous_name of string list * string list * bool * string (* 41 *)
+  | Disambiguated_name of string            (* 42 *)
+  | Nonoptional_label of string             (* 43 *)
+  | Open_shadow_identifier of string * string (* 44 *)
+  | Open_shadow_label_constructor of string * string (* 45 *)
+  | Bad_env_variable of string * string     (* 46 *)
+  | Attribute_payload of string * string    (* 47 *)
+  | Eliminated_optional_arguments of string list (* 48 *)
+  | No_cmi_file of string * string option   (* 49 *)
+  | Unexpected_docstring of bool            (* 50 *)
+  | Wrong_tailcall_expectation of bool      (* 51 *)
+  | Fragile_literal_pattern                 (* 52 *)
+  | Misplaced_attribute of string           (* 53 *)
+  | Duplicated_attribute of string          (* 54 *)
+  | Inlining_impossible of string           (* 55 *)
+  | Unreachable_case                        (* 56 *)
+  | Ambiguous_var_in_pattern_guard of string list (* 57 *)
+  | No_cmx_file of string                   (* 58 *)
+  | Flambda_assignment_to_non_mutable_value (* 59 *)
+  | Unused_module of string                 (* 60 *)
+  | Unboxable_type_in_prim_decl of string   (* 61 *)
+  | Constraint_on_gadt                      (* 62 *)
+  | Erroneous_printed_signature of string   (* 63 *)
+  | Unsafe_array_syntax_without_parsing     (* 64 *)
+  | Redefining_unit of string               (* 65 *)
+  | Unused_open_bang of string              (* 66 *)
+  | Unused_functor_parameter of string      (* 67 *)
+  | Match_on_mutable_state_prevent_uncurry  (* 68 *)
+  | Unused_field of string * field_usage_warning (* 69 *)
+  | Missing_mli                             (* 70 *)
+;;
+
+type alert = {kind:string; message:string; def:loc; use:loc}
+
+val parse_options : bool -> string -> alert option;;
+
+val parse_alert_option: string -> unit
+  (** Disable/enable alerts based on the parameter to the -alert
+      command-line option.  Raises [Arg.Bad] if the string is not a
+      valid specification.
+  *)
+
+val without_warnings : (unit -> 'a) -> 'a
+  (** Run the thunk with all warnings and alerts disabled. *)
+
+val is_active : t -> bool;;
+val is_error : t -> bool;;
+
+val defaults_w : string;;
+val defaults_warn_error : string;;
+
+type reporting_information =
+  { id : string
+  ; message : string
+  ; is_error : bool
+  ; sub_locs : (loc * string) list;
+  }
+
+val report : t -> [ `Active of reporting_information | `Inactive ]
+val report_alert : alert -> [ `Active of reporting_information | `Inactive ]
+
+exception Errors;;
+
+val check_fatal : unit -> unit;;
+val reset_fatal: unit -> unit
+
+val help_warnings: unit -> unit
+
+type state
+val backup: unit -> state
+val restore: state -> unit
+val mk_lazy: (unit -> 'a) -> 'a Lazy.t
+    (** Like [Lazy.of_fun], but the function is applied with
+        the warning/alert settings at the time [mk_lazy] is called. *)
+
+(* merlin *)
+val dump : ?verbose:bool -> unit -> Std.json
diff --git a/src/platform/dune b/src/platform/dune
new file mode 100644
index 0000000..98ddb00
--- /dev/null
+++ b/src/platform/dune
@@ -0,0 +1,3 @@
+(library
+ (name os_ipc)
+ (foreign_stubs (language c) (names os_ipc_stub)))
diff --git a/src/platform/os_ipc.ml b/src/platform/os_ipc.ml
new file mode 100644
index 0000000..d5d7624
--- /dev/null
+++ b/src/platform/os_ipc.ml
@@ -0,0 +1,40 @@
+type server
+type context
+
+type client = {
+  context : context;
+  wd      : string;
+  environ : string;
+  argv    : string array;
+}
+
+(* {1 Server management}
+   Listen, accept client and close *)
+
+external server_setup : string -> string -> server option =
+  "ml_merlin_server_setup"
+
+external server_accept : server -> timeout:float -> client option =
+  "ml_merlin_server_accept"
+
+external server_close : server -> unit =
+  "ml_merlin_server_close"
+
+(* {1 Context management (stdin, stdout, stderr)}
+   Setup and close *)
+
+external context_setup : context -> unit =
+  "ml_merlin_context_setup"
+
+external context_close : context -> return_code:int -> unit =
+  "ml_merlin_context_close"
+
+(* {1 Environment management} *)
+
+external merlin_set_environ : string -> unit =
+  "ml_merlin_set_environ"
+(** completely replace the environment *)
+
+(* {1 Fixup for Windows process management} *)
+
+external merlin_dont_inherit_stdio : bool -> unit = "ml_merlin_dont_inherit_stdio"
diff --git a/src/platform/os_ipc_stub.c b/src/platform/os_ipc_stub.c
new file mode 100644
index 0000000..a95fe47
--- /dev/null
+++ b/src/platform/os_ipc_stub.c
@@ -0,0 +1,436 @@
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <errno.h>
+#ifdef _WIN32
+#include <windows.h>
+#include <io.h>
+#ifndef STDIN_FILENO
+#define STDIN_FILENO 0
+#endif
+#ifndef STDOUT_FILENO
+#define STDOUT_FILENO 1
+#endif
+#ifndef STDERR_FILENO
+#define STDERR_FILENO 2
+#endif
+#ifdef _MSC_VER
+typedef SSIZE_T ssize_t;
+#endif
+#else
+#include <unistd.h>
+#include <fcntl.h>
+
+#include <sys/socket.h>
+#include <sys/select.h>
+#endif
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/threads.h>
+
+#ifdef _MSC_VER
+extern __declspec(dllimport) char **environ;
+#else
+extern char **environ;
+#endif
+
+CAMLprim value
+ml_merlin_set_environ(value venviron)
+{
+  static char *buffer = NULL;
+
+  const char *ptr = String_val(venviron);
+  size_t length = caml_string_length(venviron);
+
+  buffer = realloc(buffer, length);
+  memcpy(buffer, ptr, length);
+
+  // clearenv() is not portable
+  if (environ)
+    *environ = NULL;
+
+  size_t i, j;
+
+  for (i = 0, j = 0; i < length; ++i)
+  {
+    if (buffer[i] == '\0')
+    {
+      putenv(&buffer[j]);
+      j = i + 1;
+    }
+  }
+
+  return Val_unit;
+}
+
+// Seen in the wild: environment of 40k
+#define BUFFER_SIZE 262144
+static unsigned char buffer[BUFFER_SIZE];
+
+#ifndef _WIN32
+#define NO_EINTR(var, command) \
+  do { (var) = command; } while ((var) == -1 && errno == EINTR)
+
+#define unbyte(x,n) (((unsigned char)x) << (n * 8))
+
+static ssize_t recv_buffer(int fd, int fds[3])
+{
+  char msg_control[CMSG_SPACE(3 * sizeof(int))];
+  struct iovec iov = { .iov_base = buffer, .iov_len = sizeof(buffer) };
+  struct msghdr msg = {
+    .msg_iov = &iov, .msg_iovlen = 1,
+    .msg_controllen = CMSG_SPACE(3 * sizeof(int)),
+  };
+  msg.msg_control = &msg_control;
+  memset(msg.msg_control, 0, msg.msg_controllen);
+
+  ssize_t recvd;
+  NO_EINTR(recvd, recvmsg(fd, &msg, 0));
+  if (recvd == -1)
+  {
+    perror("recvmsg");
+    return -1;
+  }
+
+  if (recvd < 4)
+  {
+    ssize_t recvd_;
+    do {
+      NO_EINTR(recvd_, recv(fd, buffer + recvd, sizeof(buffer) - recvd, 0));
+      if (recvd_ > 0)
+        recvd += recvd_;
+    } while (recvd_ > 0 && recvd < 4);
+  }
+
+  size_t target = -1;
+
+  if (recvd > 4)
+  {
+    target =
+      unbyte(buffer[0],0) | unbyte(buffer[1],1) |
+      unbyte(buffer[2],2) | unbyte(buffer[3],3);
+
+    if (recvd < target)
+    {
+      ssize_t recvd_;
+      do {
+        NO_EINTR(recvd_, recv(fd, buffer + recvd, sizeof(buffer) - recvd, 0));
+        if (recvd_ > 0)
+          recvd += recvd_;
+      } while (recvd_ > 0 && recvd < target);
+    }
+  }
+
+  struct cmsghdr *cm = CMSG_FIRSTHDR(&msg);
+
+  if (cm == NULL)
+  {
+    perror("recvmsg");
+    return -1;
+  }
+  int *fds0 = (int*)CMSG_DATA(cm);
+  int nfds = (cm->cmsg_len - CMSG_LEN(0)) / sizeof(int);
+
+  /* Check malformed packet */
+  if (nfds != 3 || recvd != target || buffer[recvd-1] != '\0')
+  {
+    int i;
+    for (i = 0; i < nfds; ++i)
+      close(fds0[i]);
+    return -1;
+  }
+
+  {
+    int i;
+    for (i = 0; i < 3; ++i)
+    {
+      fds[i] = fds0[i];
+      if (fcntl(fds[i], F_SETFD, FD_CLOEXEC) == -1)
+        perror("fcntl");
+    }
+  }
+
+  return recvd;
+}
+#endif
+
+value ml_merlin_server_setup(value path, value strfd)
+{
+  CAMLparam2(path, strfd);
+  CAMLlocal2(payload, ret);
+  char *endptr = NULL;
+  int fd;
+
+#ifdef _WIN32
+  fd = 0;
+  ret = strfd;
+#else
+  fd = strtol(String_val(strfd), &endptr, 0);
+  if (!endptr || *endptr != '\0')
+    fd = -1;
+  else
+    ret = Val_int(fd);
+#endif
+
+  if (fd != -1)
+  {
+    /* (path, fd) */
+    payload = caml_alloc(2, 0);
+    Store_field(payload, 0, path);
+    Store_field(payload, 1, ret);
+
+    /* Some payload */
+    ret = caml_alloc(1, 0);
+    Store_field(ret, 0, payload);
+  }
+  else
+  {
+    fprintf(stderr, "ml_merlin_server_setup(\"%s\",\"%s\"): invalid argument\n",
+        String_val(path), String_val(strfd));
+    unlink(String_val(path));
+    /* None */
+    ret = Val_unit;
+  }
+
+  CAMLreturn(ret);
+}
+
+value ml_merlin_server_accept(value server, value val_timeout)
+{
+  CAMLparam2(server, val_timeout);
+  CAMLlocal3(ret, client, context);
+  CAMLlocal3(wd, env, args);
+
+  ssize_t len = -1;
+
+#ifdef _WIN32
+  static BOOL bDoneReset = FALSE;
+  HANDLE hPipe = CreateNamedPipe(String_val(Field(server, 0)), PIPE_ACCESS_DUPLEX, PIPE_TYPE_MESSAGE | PIPE_READMODE_MESSAGE | PIPE_WAIT, PIPE_UNLIMITED_INSTANCES, 1024, 1024, NMPWAIT_USE_DEFAULT_WAIT, NULL);
+  ret = Val_unit; /* None */
+  if (hPipe != INVALID_HANDLE_VALUE)
+  {
+    if (!bDoneReset)
+    {
+      HANDLE hEvent = OpenEvent(EVENT_MODIFY_STATE, FALSE, String_val(Field(server, 1)));
+      SetEvent(hEvent);
+      CloseHandle(hEvent);
+      bDoneReset = TRUE;
+    }
+    if (ConnectNamedPipe(hPipe, NULL) || GetLastError() == ERROR_PIPE_CONNECTED)
+    {
+      intptr_t fds[3];
+      DWORD dwNumberOfBytesRead;
+      if (ReadFile(hPipe, fds, 3 * sizeof(HANDLE), &dwNumberOfBytesRead, NULL) && dwNumberOfBytesRead == 3 * sizeof(HANDLE))
+      {
+        context = caml_alloc(4, 0); /* hPipe, stdin, stdout, stderr) */
+        Store_field(context, 0, caml_copy_nativeint((intnat)hPipe));
+        Store_field(context, 1, Val_int(_open_osfhandle(fds[0], 0)));
+        Store_field(context, 2, Val_int(_open_osfhandle(fds[1], 0)));
+        Store_field(context, 3, Val_int(_open_osfhandle(fds[2], 0)));
+        if (ReadFile(hPipe, buffer, BUFFER_SIZE, &dwNumberOfBytesRead, NULL))
+        {
+          len = dwNumberOfBytesRead;
+        }
+        else
+        {
+          DisconnectNamedPipe(hPipe);
+          CloseHandle(hPipe);
+        }
+      }
+      else
+      {
+        DisconnectNamedPipe(hPipe);
+        CloseHandle(hPipe);
+      }
+    }
+    else
+    {
+      CloseHandle(hPipe);
+    }
+  }
+#else
+  // Compute timeout
+  double timeout = Double_val(val_timeout);
+  struct timeval tv;
+  tv.tv_sec = timeout;
+  tv.tv_usec = (timeout - tv.tv_sec) * 1000000;
+
+  // Select on server
+  int serverfd = Int_val(Field(server, 1));
+  int selectres;
+  fd_set readset;
+
+  caml_release_runtime_system();
+  do {
+    FD_ZERO(&readset);
+    FD_SET(serverfd, &readset);
+    selectres = select(serverfd + 1, &readset, NULL, NULL, &tv);
+  } while (selectres == -1 && errno == EINTR);
+  caml_acquire_runtime_system();
+
+  int fds[3], clientfd;
+
+  if (selectres > 0)
+  {
+    NO_EINTR(clientfd, accept(serverfd, NULL, NULL));
+    len = recv_buffer(clientfd, fds);
+  }
+
+  if (len == -1)
+    ret = Val_unit; /* None */
+  else {
+    context = caml_alloc(4, 0); /* (clientfd, stdin, stdout, stderr) */
+    Store_field(context, 0, Val_int(clientfd));
+    Store_field(context, 1, Val_int(fds[0]));
+    Store_field(context, 2, Val_int(fds[1]));
+    Store_field(context, 3, Val_int(fds[2]));
+  }
+#endif
+
+  if (len != -1)
+  {
+    ssize_t i, j;
+    int argc;
+    i = 4;
+
+    // Extract working directory
+    wd = caml_copy_string((const char *)&buffer[i]);
+    i += caml_string_length(wd) + 1;
+
+    // Extract environment
+    if (buffer[i] == '\0')
+    {
+      env = caml_alloc_string(0);
+      i += 1;
+    }
+    else
+    {
+      ssize_t env_start = i;
+      i += 1;
+      for (; i < len; ++i)
+      {
+        if (buffer[i-1] == '\0' && buffer[i] == '\0')
+        {
+          i += 1;
+          break;
+        }
+      }
+      env = caml_alloc_string(i - env_start);
+      memcpy((char *)String_val(env), &buffer[env_start], i - env_start);
+    }
+
+    // Extract remaining args
+    ssize_t args_start = i;
+    argc = 0;
+
+    for (i = args_start; i < len; ++i)
+    {
+      if (buffer[i] == '\0')
+        argc += 1;
+    }
+
+    args = caml_alloc(argc, 0);
+
+    argc = 0;
+    for (i = args_start, j = args_start; i < len; ++i)
+    {
+      if (buffer[i] == '\0')
+      {
+        Store_field(args, argc, caml_copy_string((const char *)&buffer[j]));
+        j = i + 1;
+        argc += 1;
+      }
+    }
+
+    client = caml_alloc(4, 0); /* (context, wd, environ, args) */
+    Store_field(client, 0, context);
+    Store_field(client, 1, wd);
+    Store_field(client, 2, env);
+    Store_field(client, 3, args);
+
+    ret = caml_alloc(1, 0); /* Some client */
+    Store_field(ret, 0, client);
+  }
+
+  CAMLreturn(ret);
+}
+
+
+value ml_merlin_server_close(value server)
+{
+  CAMLparam1(server);
+#ifndef _WIN32
+  unlink(String_val(Field(server, 0)));
+  close(Int_val(Field(server, 1)));
+#endif
+  CAMLreturn(Val_unit);
+}
+
+static void setup_fds(int fd0, int fd1, int fd2)
+{
+  static int copy0 = -1, copy1 = -1, copy2 = -1;
+
+  // Backup original
+  if (copy0 == -1) copy0 = dup(STDIN_FILENO);
+  if (copy1 == -1) copy1 = dup(STDOUT_FILENO);
+  if (copy2 == -1) copy2 = dup(STDERR_FILENO);
+
+  // Copy or restore new ones
+  if (fd0 != -1) dup2(fd0, STDIN_FILENO);
+  else { dup2(copy0, STDIN_FILENO); close(copy0); copy0 = -1; }
+
+  if (fd1 != -1) dup2(fd1, STDOUT_FILENO);
+  else { dup2(copy1, STDOUT_FILENO); close(copy1); copy1 = -1; }
+
+  if (fd2 != -1) dup2(fd2, STDERR_FILENO);
+  else { dup2(copy2, STDERR_FILENO); close(copy2); copy2 = -1; }
+}
+
+value ml_merlin_context_setup(value context)
+{
+  CAMLparam1(context);
+  setup_fds(
+      Int_val(Field(context, 1)),
+      Int_val(Field(context, 2)),
+      Int_val(Field(context, 3))
+      );
+  CAMLreturn(Val_unit);
+}
+
+value ml_merlin_context_close(value context, value return_code)
+{
+  CAMLparam1(context);
+  char code = (char)(Int_val(return_code));
+#ifdef _WIN32
+  HANDLE hPipe;
+  DWORD dwNumberOfBytesWritten;
+#else
+  ssize_t wrote_ = -1;
+#endif
+  setup_fds(-1, -1, -1);
+
+#ifdef _WIN32
+  hPipe = (HANDLE)Nativeint_val(Field(context, 0));
+  WriteFile(hPipe, &code, sizeof(char), &dwNumberOfBytesWritten, NULL);
+#else
+  NO_EINTR(wrote_, write(Int_val(Field(context, 0)), &code, sizeof(char)));
+#endif
+
+  // Close stdin, stdout, stderr
+  close(Int_val(Field(context, 1)));
+  close(Int_val(Field(context, 2)));
+  close(Int_val(Field(context, 3)));
+
+  // Close client connection
+#ifdef _WIN32
+  FlushFileBuffers(hPipe);
+  DisconnectNamedPipe(hPipe);
+  CloseHandle(hPipe);
+#else
+  close(Int_val(Field(context, 0)));
+#endif
+
+  CAMLreturn(Val_unit);
+}
diff --git a/src/platform/platform_misc.c b/src/platform/platform_misc.c
new file mode 100644
index 0000000..50e5c42
--- /dev/null
+++ b/src/platform/platform_misc.c
@@ -0,0 +1,180 @@
+#ifdef _WIN32
+#define CAML_NAME_SPACE
+#define CAML_INTERNALS
+#include <caml/misc.h>
+#include <caml/osdeps.h>
+#include <caml/unixsupport.h>
+#endif
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <stdlib.h>
+
+/* FS case */
+
+#ifdef __APPLE__
+
+#include <fcntl.h>
+#include <sys/param.h>
+#include <unistd.h>
+
+value ml_merlin_fs_exact_case(value path)
+{
+	CAMLparam1(path);
+	CAMLlocal1(realpath);
+	char realpath_c[MAXPATHLEN];
+
+	realpath = path;
+
+	int fd = open(String_val(path), O_EVTONLY | O_SYMLINK);
+	if (fd != -1)
+	{
+		if (fcntl(fd, F_GETPATH, realpath_c) != -1)
+		{
+			realpath = caml_copy_string(realpath_c);
+		}
+		close(fd);
+	}
+	CAMLreturn(realpath);
+}
+
+
+#else
+
+value ml_merlin_fs_exact_case(value path)
+{
+	return path;
+}
+
+#endif
+
+#ifdef _WIN32
+
+value ml_merlin_fs_exact_case_basename(value path)
+{
+  CAMLparam1(path);
+  CAMLlocal1(result);
+  HANDLE h;
+  wchar_t * wname;
+  WIN32_FIND_DATAW fileinfo;
+
+  wname = caml_stat_strdup_to_utf16(String_val(path));
+  h = FindFirstFileW(wname, &fileinfo);
+  caml_stat_free(wname);
+
+  if (h == INVALID_HANDLE_VALUE) {
+    result = Val_int(0);
+  } else {
+    FindClose(h);
+    result = caml_alloc (1, 0);
+    Store_field(result, 0, caml_copy_string_of_utf16(fileinfo.cFileName));
+  }
+
+  CAMLreturn(result);
+}
+
+#else
+
+value ml_merlin_fs_exact_case_basename(value path)
+{
+  return Val_int(0);
+}
+
+#endif
+
+#ifdef _WIN32
+
+/* File descriptor inheritance */
+
+#include <windows.h>
+#include <io.h>
+
+value ml_merlin_dont_inherit_stdio(value vstatus)
+{
+  int status = Int_val(vstatus) ? 0 : HANDLE_FLAG_INHERIT;
+  SetHandleInformation((HANDLE)_get_osfhandle(1), HANDLE_FLAG_INHERIT, status);
+  SetHandleInformation((HANDLE)_get_osfhandle(2), HANDLE_FLAG_INHERIT, status);
+  return Val_unit;
+}
+
+/* Run ppx-command without opening a sub console */
+
+static int windows_system(const char *cmd)
+{
+    PROCESS_INFORMATION p_info;
+    STARTUPINFOW s_info;
+    HANDLE hp, p_stderr;
+    DWORD handleInfo, flags, ret, err = ERROR_SUCCESS;
+
+    memset(&s_info, 0, sizeof(s_info));
+    memset(&p_info, 0, sizeof(p_info));
+    s_info.cb = sizeof(s_info);
+    s_info.dwFlags = STARTF_USESTDHANDLES;
+
+    s_info.hStdInput = INVALID_HANDLE_VALUE;
+
+    /* If needed, duplicate stderr to make sure it is inheritable */
+    p_stderr = GetStdHandle(STD_ERROR_HANDLE);
+    if (p_stderr == INVALID_HANDLE_VALUE) {
+        err = GetLastError(); goto ret;
+    }
+    if (! GetHandleInformation(p_stderr, &handleInfo)) {
+        err = GetLastError(); goto ret;
+    }
+    if (! (handleInfo & HANDLE_FLAG_INHERIT)) {
+        hp = GetCurrentProcess();
+        if (! DuplicateHandle(hp, p_stderr, hp, &(s_info.hStdError),
+                              0, TRUE, DUPLICATE_SAME_ACCESS)) {
+            err = GetLastError(); goto ret;
+        }
+    } else {
+        s_info.hStdError = p_stderr;
+    }
+
+    /* Redirect stdout to stderr */
+    s_info.hStdOutput = s_info.hStdError;
+
+    flags = CREATE_NO_WINDOW | CREATE_UNICODE_ENVIRONMENT;
+    WCHAR *utf16cmd = caml_stat_strdup_to_utf16(cmd);
+    if (! CreateProcessW(NULL, utf16cmd, NULL, NULL,
+                         TRUE, flags, NULL, NULL, &s_info, &p_info)) {
+        err = GetLastError();
+    }
+    caml_stat_free(utf16cmd);
+
+    /* Close the handle if we duplicated it above. */
+    if (! (handleInfo & HANDLE_FLAG_INHERIT))
+        CloseHandle(s_info.hStdError);
+
+    if (err == ERROR_SUCCESS) {
+        WaitForSingleObject(p_info.hProcess, INFINITE);
+        GetExitCodeProcess(p_info.hProcess, &ret);
+        CloseHandle(p_info.hProcess);
+        CloseHandle(p_info.hThread);
+        return ret;
+    }
+ ret:
+    win32_maperr(err);
+    uerror("windows_system", Nothing);
+}
+
+value ml_merlin_system_command(value command)
+{
+  return Val_int(windows_system(String_val(command)));
+}
+
+#else
+
+value ml_merlin_dont_inherit_stdio(value vstatus)
+{
+  (void)vstatus;
+  return Val_unit;
+}
+
+value ml_merlin_system_command(value command)
+{
+  return Val_int(system(String_val(command)));
+}
+
+#endif
diff --git a/src/utils/dune b/src/utils/dune
new file mode 100644
index 0000000..334591b
--- /dev/null
+++ b/src/utils/dune
@@ -0,0 +1,6 @@
+(rule (copy# ../platform/platform_misc.c platform_misc.c))
+
+(library
+ (name merlin_utils)
+ (libraries str yojson unix)
+ (foreign_stubs (language c) (names platform_misc)))
diff --git a/src/utils/file_cache.ml b/src/utils/file_cache.ml
new file mode 100644
index 0000000..1010867
--- /dev/null
+++ b/src/utils/file_cache.ml
@@ -0,0 +1,105 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+module Make(Input : sig
+  type t
+  val read : string -> t
+  val cache_name : string
+end) = struct
+  let {Logger. log} = Logger.for_section ("File_cache("^Input.cache_name^")")
+
+  let cache : (string, File_id.t * float ref * Input.t) Hashtbl.t
+            = Hashtbl.create 17
+
+  let get_cached_entry ~title fid filename =
+    let fid', latest_use, file = Hashtbl.find cache filename in
+    if (File_id.check fid fid') then
+      log ~title "reusing %S" filename
+    else (
+      log ~title "%S was updated on disk" filename;
+      raise Not_found;
+    );
+    latest_use := Unix.time ();
+    file
+
+  let read filename =
+    let fid = File_id.get filename in
+    let title = "read" in
+    try get_cached_entry ~title fid filename
+    with Not_found ->
+    try
+      log ~title "reading %S from disk" filename;
+      let file = Input.read filename in
+      Hashtbl.replace cache filename (fid, ref (Unix.time ()), file);
+      file
+    with exn ->
+      log ~title "failed to read %S (%t)"
+        filename (fun () -> Printexc.to_string exn);
+      Hashtbl.remove cache filename;
+      raise exn
+
+  let check filename =
+    let fid = File_id.get filename in
+    match Hashtbl.find cache filename with
+    | exception Not_found -> false
+    | (fid', latest_use, _) ->
+      if File_id.check fid fid' then begin
+        latest_use := Unix.time ();
+        true
+      end else begin
+        false
+      end
+
+  let get_cached_entry filename =
+    let fid = File_id.get filename in
+    let title = "get_cached_entry" in
+    get_cached_entry ~title fid filename
+
+  let flush ?older_than () =
+    let title = "flush" in
+    let limit = match older_than with
+      | None -> -.max_float
+      | Some dt -> Unix.time () -. dt
+    in
+    let add_invalid filename (fid, latest_use, _) invalids =
+      if !latest_use > limit &&
+         File_id.check (File_id.get filename) fid
+      then (
+        log ~title "keeping %S" filename;
+        invalids
+      ) else (
+        log ~title "removing %S" filename;
+        filename :: invalids
+      )
+    in
+    let invalid = Hashtbl.fold add_invalid cache [] in
+    List.iter (Hashtbl.remove cache) invalid
+
+  let clear () =
+    Hashtbl.clear cache
+end
diff --git a/src/utils/file_cache.mli b/src/utils/file_cache.mli
new file mode 100644
index 0000000..33fb2b8
--- /dev/null
+++ b/src/utils/file_cache.mli
@@ -0,0 +1,41 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+module Make (Input : sig
+  type t
+  val read : string -> t
+  val cache_name : string
+end) : sig
+  val read  : string -> Input.t
+  val flush : ?older_than:float -> unit -> unit
+  val clear : unit -> unit
+  val check : string -> bool
+
+  val get_cached_entry : string -> Input.t
+  (** @raises Not_found if the file is not in cache. *)
+end
diff --git a/src/utils/file_id.ml b/src/utils/file_id.ml
new file mode 100644
index 0000000..d3c80e6
--- /dev/null
+++ b/src/utils/file_id.ml
@@ -0,0 +1,39 @@
+type t = Unix.stats
+
+let null_stat =
+  { Unix.
+    st_dev = -1; st_ino = -1; st_kind = Unix.S_REG; st_nlink = -1;
+    st_perm = -1; st_uid = -1; st_gid = -1; st_rdev = -1; st_size = -1;
+    st_atime = nan; st_mtime = nan; st_ctime = nan }
+
+let get filename =
+  try Unix.stat filename
+  with _ -> null_stat
+
+let check a b =
+  a == b || (
+    (a != null_stat) && (b != null_stat) &&
+    let open Unix in
+    a.st_mtime = b.st_mtime &&
+    a.st_size = b.st_size &&
+    a.st_ino = b.st_ino &&
+    a.st_dev = b.st_dev
+  )
+
+let cache = ref None
+
+let with_cache k =
+  Std.let_ref cache (Some (Hashtbl.create 7)) k
+
+let get filename =
+  match !cache with
+  | None -> get filename
+  | Some table ->
+    match Hashtbl.find table filename with
+    | stats ->
+      Logger.log ~section:"stat_cache" ~title:"reuse cache" "%s" filename;
+      stats
+    | exception Not_found ->
+      let stats = get filename in
+      Hashtbl.add table filename stats;
+      stats
diff --git a/src/utils/file_id.mli b/src/utils/file_id.mli
new file mode 100644
index 0000000..b2f1888
--- /dev/null
+++ b/src/utils/file_id.mli
@@ -0,0 +1,16 @@
+type t
+(** An instance of [t] represents the identity of the contents of a file path.
+    Use this to quickly detect if a file has changed.
+    (Detection is done by checking some fields from stat syscall,
+    it can be tricked but should behave well in regular cases).
+    FIXME: precision of mtime is still the second?!
+*)
+
+val check: t -> t -> bool
+(** Returns true iff the heuristic determines that the file contents has not
+    changed. *)
+
+val get: string -> t
+(** [file_id filename] computes an id for the current contents of [filename] *)
+
+val with_cache : (unit -> 'a) -> 'a
diff --git a/src/utils/logger.ml b/src/utils/logger.ml
new file mode 100644
index 0000000..8b06a4c
--- /dev/null
+++ b/src/utils/logger.ml
@@ -0,0 +1,152 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+
+let time = ref 0.0
+
+let delta_time () =
+  Sys.time () -. !time
+
+let destination = ref None
+let selected_sections = ref None
+
+let is_section_enabled section =
+  match !selected_sections with
+  | None -> true
+  | Some sections -> Hashtbl.mem sections section
+
+let output_section oc section title =
+  Printf.fprintf oc "# %2.2f %s - %s\n" (delta_time ()) section title
+
+let log_flush () =
+  match !destination with
+  | None -> ()
+  | Some oc -> flush oc
+
+let log ~section ~title fmt =
+  match !destination with
+  | Some oc when is_section_enabled section ->
+    Printf.ksprintf (fun str ->
+        output_section oc section title;
+        if str <> "" then (
+          output_string oc str;
+          if str.[String.length str - 1] <> '\n' then
+            output_char oc '\n'
+        )
+      ) fmt
+  | None | Some _ ->
+    Printf.ifprintf () fmt
+
+let fmt_buffer = Buffer.create 128
+let fmt_handle = Format.formatter_of_buffer fmt_buffer
+
+let fmt () f =
+  Buffer.reset fmt_buffer;
+  begin match f fmt_handle with
+  | () -> ()
+  | exception exn ->
+    Format.fprintf fmt_handle "@\nException: %s" (Printexc.to_string exn);
+  end;
+  Format.pp_print_flush fmt_handle ();
+  let msg = Buffer.contents fmt_buffer in
+  Buffer.reset fmt_buffer;
+  msg
+
+let json () f =
+  match f () with
+  | json -> Json.pretty_to_string json
+  | exception exn ->
+    Printf.sprintf "Exception: %s" (Printexc.to_string exn)
+
+let exn () exn = Printexc.to_string exn
+
+type notification = {
+  section: string;
+  msg: string;
+}
+
+let notifications : notification list ref option ref = ref None
+
+let notify ~section =
+  let tell msg =
+    log ~section ~title:"notify" "%s" msg;
+    match !notifications with
+    | None -> ()
+    | Some r -> r := {section; msg} :: !r
+  in
+  Printf.ksprintf tell
+
+let with_notifications r f =
+  let_ref notifications (Some r) f
+
+let with_sections sections f =
+  let sections = match sections with
+    | [] -> None
+    | sections ->
+      let table = Hashtbl.create (List.length sections) in
+      List.iter sections ~f:(fun section -> Hashtbl.replace table section ());
+      Some table
+  in
+  let sections0 = !selected_sections in
+  selected_sections := sections;
+  match f () with
+  | result -> selected_sections := sections0; result
+  | exception exn -> selected_sections := sections0; reraise exn
+
+let with_log_file file ?(sections=[]) f =
+  match file with
+  | None -> with_sections sections f
+  | Some file ->
+    log_flush ();
+    let destination', release = match file with
+      | "" -> (None, ignore)
+      | "-" -> (Some stderr, ignore)
+      | filename ->
+        match open_out filename with
+        | exception exn ->
+          Printf.eprintf "cannot open %S for logging: %s"
+            filename (Printexc.to_string exn);
+          (None, ignore)
+        | oc ->
+          (Some oc, (fun () -> close_out_noerr oc))
+    in
+    let destination0 = !destination in
+    destination := destination';
+    let release () =
+      log_flush ();
+      destination := destination0;
+      release ()
+    in
+    match with_sections sections f with
+    | v -> release (); v
+    | exception exn -> release (); reraise exn
+
+type 'a printf = title:string -> ('a, unit, string, unit) format4 -> 'a
+type logger = { log : 'a. 'a printf }
+let for_section section = { log = (fun ~title fmt -> log ~section ~title fmt) }
diff --git a/src/utils/logger.mli b/src/utils/logger.mli
new file mode 100644
index 0000000..13bbc22
--- /dev/null
+++ b/src/utils/logger.mli
@@ -0,0 +1,58 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+(** Log module
+  *
+  * 1. Provide functions to log arbitrary messages, filtered according to a
+  * section and a verbosity level.
+  *
+  * 2. Allow to setup a destination for these log messages.
+  *
+  **)
+
+val log
+  : section:string -> title:string -> ('b, unit, string, unit) format4 -> 'b
+
+val fmt  : unit -> (Format.formatter -> unit) -> string
+val json : unit -> (unit -> Std.json) -> string
+val exn  : unit -> exn -> string
+
+val log_flush : unit -> unit
+
+type notification = {
+  section: string;
+  msg: string;
+}
+
+val notify : section:string -> ('b, unit, string, unit) format4 -> 'b
+val with_notifications : notification list ref -> (unit -> 'a) -> 'a
+val with_log_file : string option -> ?sections:string list -> (unit -> 'a) -> 'a
+
+type 'a printf = title:string -> ('a, unit, string, unit) format4 -> 'a
+type logger = { log : 'a. 'a printf }
+val for_section : string -> logger
diff --git a/src/utils/marg.ml b/src/utils/marg.ml
new file mode 100644
index 0000000..4b66418
--- /dev/null
+++ b/src/utils/marg.ml
@@ -0,0 +1,98 @@
+open Std
+
+(** {1 Flag parsing utils} *)
+
+type 'a t = string list -> 'a -> (string list * 'a)
+
+type 'a table = (string, 'a t) Hashtbl.t
+
+let unit f : 'a t = fun args acc -> (args, (f acc))
+
+let param ptype f : 'a t = fun args acc ->
+  match args with
+  | [] -> failwith ("expects a " ^ ptype ^ " argument")
+  | arg :: args -> args, f arg acc
+
+let unit_ignore : 'a t =
+  fun x -> unit (fun x -> x) x
+
+let param_ignore =
+  fun x -> param "string" (fun _ x -> x) x
+
+let bool f = param "bool"
+    (function
+      | "yes" | "y" | "Y" | "true" | "True" | "1" -> f true
+      | "no" | "n" | "N" | "false" | "False" | "0" -> f false
+      | str ->
+        failwithf "expecting boolean (%s), got %S."
+          "yes|y|Y|true|1 / no|n|N|false|0"
+          str
+    )
+
+type docstring = string
+
+type 'a spec = (string * docstring * 'a t)
+
+let rec assoc3 key = function
+  | [] -> raise Not_found
+  | (key', _, value) :: _ when key = key' -> value
+  | _ :: xs -> assoc3 key xs
+
+let rec mem_assoc3 key = function
+  | [] -> false
+  | (key', _, _) :: xs -> key = key' || mem_assoc3 key xs
+
+let parse_one ~warning global_spec local_spec args global local =
+  match args with
+  | [] -> None
+  | arg :: args ->
+    match Hashtbl.find global_spec arg with
+    | action -> begin match action args global with
+        | (args, global) ->
+          Some (args, global, local)
+        | exception (Failure msg) ->
+          warning ("flag " ^ arg ^ " " ^ msg);
+          Some (args, global, local)
+        | exception exn ->
+          warning ("flag " ^ arg ^ ": error, " ^ Printexc.to_string exn);
+          Some (args, global, local)
+      end
+    | exception Not_found ->
+      match assoc3 arg local_spec with
+      | action -> begin match action args local  with
+        | (args, local) ->
+          Some (args, global, local)
+        | exception (Failure msg) ->
+          warning ("flag " ^ arg ^ " " ^ msg);
+          Some (args, global, local)
+        | exception exn ->
+          warning ("flag " ^ arg ^ ": error, " ^ Printexc.to_string exn);
+          Some (args, global, local)
+      end
+      | exception Not_found -> None
+
+let parse_all ~warning global_spec local_spec =
+  let rec normal_parsing args global local =
+    match parse_one ~warning global_spec local_spec args global local with
+    | Some (args, global, local) -> normal_parsing args global local
+    | None -> match args with
+      | arg :: args -> begin
+        (* We split on the first '=' to check if the argument was
+           of the form name=value *)
+        try
+          let name, value = Misc.cut_at arg '=' in
+          normal_parsing (name::value::args) global local
+        with Not_found ->
+          warning ("unknown flag " ^ arg);
+          resume_parsing args global local
+        end
+      | [] -> (global, local)
+  and resume_parsing args global local =
+    let args = match args with
+      | arg :: args when not (Hashtbl.mem global_spec arg ||
+                              mem_assoc3 arg local_spec) -> args
+      | args -> args
+    in
+    normal_parsing args global local
+  in
+  normal_parsing
diff --git a/src/utils/marg.mli b/src/utils/marg.mli
new file mode 100644
index 0000000..ae3fb27
--- /dev/null
+++ b/src/utils/marg.mli
@@ -0,0 +1,56 @@
+(** {0 Argument parsing library which fold over arguments}
+
+    Specifications of arguments is split in two passes:
+    - [_ table] for parsing global arguments (compiler flags, merlin
+      configuration)
+    - a (string * _ t) for parsing command local arguments
+*)
+
+(** Action associated to a flag updating a state of type 'acc.
+    It takes a list of arguments and either succeeds returning untouched
+    arguments or fails raising an exception. *)
+type 'acc t = string list -> 'acc -> string list * 'acc
+
+(** A table mapping a flag to the corresponding action *)
+type 'acc table = (string, 'acc t) Hashtbl.t
+
+(** {1 Combinators for building actions} *)
+
+(** Action updating state and not consuming any argument *)
+val unit : ('acc -> 'acc) -> 'acc t
+
+(** Action consuming a single argument *)
+val param : string -> (string -> 'acc -> 'acc) -> 'acc t
+
+(** Action consuming a boolean argument *)
+val bool : (bool -> 'acc -> 'acc) -> 'acc t
+
+(** Action doing nothing *)
+val unit_ignore : 'acc t
+
+(** Action doing nothing and dropping one argument *)
+val param_ignore : 'acc t
+
+(** {1 Parsing of argument lists} *)
+
+type docstring = string
+
+type 'a spec = (string * docstring * 'a t)
+
+(** Consume at most one flag from the list, returning updated state or
+    [None] in case of failure.
+    Warning function is called with an error message in case of incorrect
+    use.  *)
+val parse_one :
+  warning:(string -> unit) ->
+  'global table -> 'local spec list ->
+  string list -> 'global -> 'local ->
+  (string list * 'global * 'local) option
+
+(** Consume all arguments from the input list, calling warning for incorrect
+    ones and resuming parsing after. *)
+val parse_all :
+  warning:(string -> unit) ->
+  'global table -> 'local spec list ->
+  string list -> 'global -> 'local ->
+  'global * 'local
diff --git a/src/utils/misc.ml b/src/utils/misc.ml
new file mode 100644
index 0000000..93690b1
--- /dev/null
+++ b/src/utils/misc.ml
@@ -0,0 +1,818 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+module CamlString = String
+
+open Std
+
+(* Errors *)
+
+exception Fatal_error of string * Printexc.raw_backtrace
+
+let () = Printexc.register_printer (function
+    | Fatal_error (msg, bt) ->
+      Some (Printf.sprintf "Fatal error: %s\n%s"
+              msg (Printexc.raw_backtrace_to_string bt))
+    | _ -> None
+  )
+
+let fatal_error msg =
+  raise (Fatal_error (msg, Printexc.get_callstack 50))
+
+let fatal_errorf fmt =
+  (*Format.kasprintf is not available in 4.02.3 *)
+  (*Format.kasprintf fatal_error fmt*)
+  ignore (Format.flush_str_formatter ());
+  Format.kfprintf
+    (fun _ppf -> fatal_error (Format.flush_str_formatter ()))
+    Format.str_formatter fmt
+
+(* Exceptions *)
+
+let try_finally ?(always=(fun () -> ())) ?(exceptionally=(fun () -> ())) work =
+  match work () with
+    | result ->
+      begin match always () with
+        | () -> result
+        | exception always_exn ->
+          (* raise_with_backtrace is not available before OCaml 4.05 *)
+          (*let always_bt = Printexc.get_raw_backtrace () in*)
+          exceptionally ();
+          (*Printexc.raise_with_backtrace always_exn always_bt*)
+          raise always_exn
+      end
+    | exception work_exn ->
+      (*let work_bt = Printexc.get_raw_backtrace () in*)
+      begin match always () with
+        | () ->
+          exceptionally ();
+          (*Printexc.raise_with_backtrace work_exn work_bt*)
+          raise work_exn
+        | exception always_exn ->
+          (*let always_bt = Printexc.get_raw_backtrace () in*)
+          exceptionally ();
+          (*Printexc.raise_with_backtrace always_exn always_bt*)
+          raise always_exn
+      end
+
+let reraise_preserving_backtrace e f =
+  let bt = Printexc.get_raw_backtrace () in
+  f ();
+  Printexc.raise_with_backtrace e bt
+
+type ref_and_value = R : 'a ref * 'a -> ref_and_value
+
+let protect_refs =
+  let set_refs l = List.iter ~f:(fun (R (r, v)) -> r := v) l in
+  fun refs f ->
+    let backup = List.map ~f:(fun (R (r, _)) -> R (r, !r)) refs in
+    set_refs refs;
+    match f () with
+    | x           -> set_refs backup; x
+    | exception e -> set_refs backup; raise e
+
+(* List functions *)
+
+let map_end f l1 l2 = List.map_end ~f l1 l2
+
+let rec map_left_right f = function
+    [] -> []
+  | hd::tl -> let res = f hd in res :: map_left_right f tl
+
+let for_all2 pred l1 l2 = List.for_all2 ~f:pred l1 l2
+
+let replicate_list = List.replicate
+
+let list_remove x = List.remove ~phys:false x
+
+let rec split_last = function
+    [] -> assert false
+  | [x] -> ([], x)
+  | hd :: tl ->
+      let (lst, last) = split_last tl in
+      (hd :: lst, last)
+
+(* Options *)
+
+let may f x = Option.iter ~f x
+let may_map f x = Option.map ~f x
+
+(* File functions *)
+
+let remove_file filename =
+  try  Sys.remove filename
+  with Sys_error _msg -> ()
+
+let rec split_path path acc =
+  match Filename.dirname path with
+  | dir when dir = path ->
+    let is_letter c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') in
+    let dir =
+      if not Sys.unix && String.length dir > 2 && is_letter dir.[0] && dir.[1] = ':'
+      then
+        (* We do two things here:
+            - We use an uppercase letter to match Dune's behavior
+            - We also add the separator ousrselves because [Filename.concat]
+            does not if its first argument is of the form ["C:"] *)
+        Printf.sprintf "%c:%s"
+          (Char.uppercase_ascii dir.[0])
+          Filename.dir_sep
+      else dir
+    in
+    dir :: acc
+  | dir -> split_path dir (Filename.basename path :: acc)
+
+(* Deal with case insensitive FS *)
+
+external fs_exact_case : string -> string = "ml_merlin_fs_exact_case"
+external fs_exact_case_basename: string -> string option = "ml_merlin_fs_exact_case_basename"
+
+(* A replacement for sys_file_exists that makes use of stat_cache *)
+module Exists_in_directory = File_cache.Make(struct
+    let cache_name = "Exists_in_directory"
+    type t = string -> bool
+    let read dir =
+      if Sys.file_exists dir &&
+         Sys.is_directory dir
+      then
+        let cache = Hashtbl.create 4 in
+        (fun filename ->
+           match Hashtbl.find cache filename with
+           | x -> x
+           | exception Not_found ->
+             let exists = Sys.file_exists (Filename.concat dir filename) in
+             Hashtbl.add cache filename exists;
+             exists)
+      else (fun _ -> false)
+  end)
+
+let exact_file_exists ~dirname ~basename =
+  Exists_in_directory.read dirname basename &&
+  let path = Filename.concat dirname basename in
+  match fs_exact_case_basename path with
+  | None ->
+    let path' = fs_exact_case path in
+    path == path' || (* only on macos *) basename = Filename.basename path'
+  | Some bn ->
+    (* only on windows *)
+    basename = bn
+
+let canonicalize_filename ?cwd path =
+  let parts =
+    match split_path path [] with
+    | dot :: rest when dot = Filename.current_dir_name ->
+      split_path (match cwd with None -> Sys.getcwd () | Some c -> c) rest
+    | parts -> parts
+  in
+  let goup path = function
+    | dir when dir = Filename.parent_dir_name ->
+      (match path with _ :: t -> t | [] -> [])
+    | dir when dir = Filename.current_dir_name ->
+      path
+    | dir -> dir :: path
+  in
+  let parts = List.rev (List.fold_left ~f:goup ~init:[] parts) in
+  let filename_concats = function
+    | [] -> ""
+    | root :: subs -> List.fold_left ~f:Filename.concat ~init:root subs
+  in
+  fs_exact_case (filename_concats parts)
+
+let rec expand_glob ~filter acc root = function
+  | [] -> root :: acc
+  | Glob.Wildwild :: _tl -> (* FIXME: why is tl not used? *)
+    let rec append acc root =
+      let items = try Sys.readdir root with Sys_error _ -> [||] in
+      let process acc dir =
+        let filename = Filename.concat root dir in
+        if filter filename
+        then append (filename :: acc) filename
+        else acc
+      in
+      Array.fold_left process (root :: acc) items
+    in
+    append acc root
+  | Glob.Exact component :: tl ->
+    let filename = Filename.concat root component in
+    expand_glob ~filter acc filename tl
+  | pattern :: tl ->
+    let items = try Sys.readdir root with Sys_error _ -> [||] in
+    let process acc dir =
+      if Glob.match_pattern pattern dir then
+        let root' = Filename.concat root dir in
+        if filter root' then
+          expand_glob ~filter acc root' tl
+        else acc
+      else acc
+    in
+    Array.fold_left process acc items
+
+let expand_glob ?(filter=fun _ -> true) path acc =
+  match split_path path [] with
+  | [] -> acc
+  | root :: subs ->
+    let patterns = List.map ~f:Glob.compile_pattern subs in
+    expand_glob ~filter acc root patterns
+
+let find_in_path path name =
+  canonicalize_filename
+  begin
+    if not (Filename.is_implicit name) then
+      if exact_file_exists
+          ~dirname:(Filename.dirname name)
+          ~basename:(Filename.basename name)
+      then name
+      else raise Not_found
+    else List.find_map path ~f:(fun dirname ->
+        if exact_file_exists ~dirname ~basename:name
+        then Some (Filename.concat dirname name)
+        else None
+      )
+  end
+
+let find_in_path_rel path name =
+  let rec simplify s =
+    let open Filename in
+    let base = basename s in
+    let dir = dirname s in
+    if dir = s then dir
+    else if base = current_dir_name then simplify dir
+    else concat (simplify dir) base
+  in
+  let rec try_dir = function
+    | [] -> raise Not_found
+    | dir::rem ->
+      let dir = simplify dir in
+      if Exists_in_directory.read dir name
+      then Filename.concat dir name
+      else try_dir rem
+  in try_dir path
+
+let find_in_path_uncap ?(fallback="") path name =
+  let has_fallback = fallback <> "" in
+  canonicalize_filename
+  begin
+    let uname = String.uncapitalize name in
+    let ufallback = String.uncapitalize fallback in
+    List.find_map path ~f:(fun dirname ->
+        if exact_file_exists ~dirname ~basename:uname
+        then Some (Filename.concat dirname uname)
+        else if exact_file_exists ~dirname ~basename:name
+        then Some (Filename.concat dirname name)
+        else 
+          let () = Logger.log 
+            ~section:"locate" 
+            ~title:"find_in_path_uncap"
+            "Failed to load %s/%s" dirname name
+          in
+          if has_fallback && exact_file_exists ~dirname ~basename:ufallback
+        then Some (Filename.concat dirname ufallback)
+        else if has_fallback && exact_file_exists ~dirname ~basename:fallback
+        then Some (Filename.concat dirname fallback)
+        else None
+      )
+  end
+
+(* Expand a -I option: if it starts with +, make it relative to the standard
+   library directory *)
+
+let expand_directory alt s =
+  if String.length s > 0 && s.[0] = '+'
+  then Filename.concat alt
+                       (String.sub s ~pos:1 ~len:(String.length s - 1))
+  else s
+
+(* Hashtable functions *)
+
+let create_hashtable size init =
+  let tbl = Hashtbl.create size in
+  List.iter ~f:(fun (key, data) -> Hashtbl.add tbl key data) init;
+  tbl
+
+(* File copy *)
+
+let copy_file ic oc =
+  let buff = Bytes.create 0x1000 in
+  let rec copy () =
+    let n = input ic buff 0 0x1000 in
+    if n = 0 then () else (output oc buff 0 n; copy())
+  in copy()
+
+let copy_file_chunk ic oc len =
+  let buff = Bytes.create 0x1000 in
+  let rec copy n =
+    if n <= 0 then () else begin
+      let r = input ic buff 0 (min n 0x1000) in
+      if r = 0 then raise End_of_file else (output oc buff 0 r; copy(n-r))
+    end
+  in copy len
+
+let string_of_file ic =
+  let b = Buffer.create 0x10000 in
+  let buff = Bytes.create 0x1000 in
+  let rec copy () =
+    let n = input ic buff 0 0x1000 in
+    if n = 0 then Buffer.contents b else
+      (Buffer.add_subbytes b buff 0 n; copy())
+  in copy()
+
+let output_to_file_via_temporary ?(mode = [Open_text]) filename fn =
+  let (temp_filename, oc) =
+    Filename.open_temp_file
+       ~mode (*~perms:0o666*) ~temp_dir:(Filename.dirname filename)
+       (Filename.basename filename) ".tmp" in
+    (* The 0o666 permissions will be modified by the umask.  It's just
+       like what [open_out] and [open_out_bin] do.
+       With temp_dir = dirname filename, we ensure that the returned
+       temp file is in the same directory as filename itself, making
+       it safe to rename temp_filename to filename later.
+       With prefix = basename filename, we are almost certain that
+       the first generated name will be unique.  A fixed prefix
+       would work too but might generate more collisions if many
+       files are being produced simultaneously in the same directory. *)
+  match fn temp_filename oc with
+  | res ->
+      close_out oc;
+      begin try
+        Sys.rename temp_filename filename; res
+      with exn ->
+        remove_file temp_filename; raise exn
+      end
+  | exception exn ->
+      close_out oc; remove_file temp_filename; raise exn
+
+(* Reading from a channel *)
+
+let input_bytes ic n =
+  let result = Bytes.create n in
+  really_input ic result 0 n;
+  result
+
+(* Integer operations *)
+
+let rec log2 n =
+  if n <= 1 then 0 else 1 + log2(n asr 1)
+
+let align n a =
+  if n >= 0 then (n + a - 1) land (-a) else n land (-a)
+
+let no_overflow_add a b = (a lxor b) lor (a lxor (lnot (a+b))) < 0
+
+let no_overflow_sub a b = (a lxor (lnot b)) lor (b lxor (a-b)) < 0
+
+(* Taken from Hacker's Delight, chapter "Overflow Detection" *)
+let no_overflow_mul a b =
+  not ((a = min_int && b < 0) || (b <> 0 && (a * b) / b <> a))
+
+let no_overflow_lsl a k =
+  0 <= k && k < Sys.word_size - 1 && min_int asr k <= a && a <= max_int asr k
+
+module Int_literal_converter = struct
+  (* To convert integer literals, allowing max_int + 1 (PR#4210) *)
+  let cvt_int_aux str neg of_string =
+    if String.length str = 0 || str.[0]= '-'
+    then of_string str
+    else neg (of_string ("-" ^ str))
+  let int s = cvt_int_aux s (~-) int_of_string
+  let int32 s = cvt_int_aux s Int32.neg Int32.of_string
+  let int64 s = cvt_int_aux s Int64.neg Int64.of_string
+  let nativeint s = cvt_int_aux s Nativeint.neg Nativeint.of_string
+end
+
+(* String operations *)
+
+let chop_extension_if_any fname =
+  try Filename.chop_extension fname with Invalid_argument _ -> fname
+
+let chop_extensions file =
+  let dirname = Filename.dirname file and basename = Filename.basename file in
+  try
+    let pos = String.index basename '.' in
+    let basename = String.sub basename ~pos:0 ~len:pos in
+    if Filename.is_implicit file && dirname = Filename.current_dir_name then
+      basename
+    else
+      Filename.concat dirname basename
+  with Not_found -> file
+
+let search_substring pat str start =
+  let rec search i j =
+    if j >= String.length pat then i
+    else if i + j >= String.length str then raise Not_found
+    else if str.[i + j] = pat.[j] then search i (j+1)
+    else search (i+1) 0
+  in search start 0
+
+let replace_substring ~before ~after str =
+  let rec search acc curr =
+    match search_substring before str curr with
+      | next ->
+         let prefix = String.sub str ~pos:curr ~len:(next - curr) in
+         search (prefix :: acc) (next + String.length before)
+      | exception Not_found ->
+        let suffix = String.sub str ~pos:curr ~len:(String.length str - curr) in
+        List.rev (suffix :: acc)
+  in String.concat ~sep:after (search [] 0)
+
+
+let rev_split_string cond s =
+  let rec split1 res i =
+    if i >= String.length s then res else begin
+      if cond s.[i] then
+        split1 res (i+1)
+      else
+        split2 res i (i+1)
+    end
+  and split2 res i j =
+    if j >= String.length s then String.sub s ~pos:i ~len:(j-i) :: res else begin
+      if cond s.[j] then
+        split1 (String.sub s ~pos:i ~len:(j-i) :: res) (j+1)
+      else
+        split2 res i (j+1)
+    end
+  in split1 [] 0
+
+let rev_split_words s =
+  let helper = function
+    | ' ' | '\t' | '\r' | '\n' -> true
+    | _ -> false
+  in
+  rev_split_string helper s
+
+let rev_string_split ~on s =
+  rev_split_string ((=) on) s
+
+let get_ref r =
+  let v = !r in
+  r := []; v
+
+let set_or_ignore f opt x =
+  match f x with
+  | None -> ()
+  | Some y -> opt := Some y
+
+let fst3 (x, _, _) = x
+let snd3 (_,x,_) = x
+let thd3 (_,_,x) = x
+
+let fst4 (x, _, _, _) = x
+let snd4 (_,x,_, _) = x
+let thd4 (_,_,x,_) = x
+let for4 (_,_,_,x) = x
+
+
+module LongString = struct
+  type t = bytes array
+
+  let create str_size =
+    let tbl_size = str_size / Sys.max_string_length + 1 in
+    let tbl = Array.make tbl_size Bytes.empty in
+    for i = 0 to tbl_size - 2 do
+      tbl.(i) <- Bytes.create Sys.max_string_length;
+    done;
+    tbl.(tbl_size - 1) <- Bytes.create (str_size mod Sys.max_string_length);
+    tbl
+
+  let length tbl =
+    let tbl_size = Array.length tbl in
+    Sys.max_string_length * (tbl_size - 1) + Bytes.length tbl.(tbl_size - 1)
+
+  let get tbl ind =
+    Bytes.get tbl.(ind / Sys.max_string_length) (ind mod Sys.max_string_length)
+
+  let set tbl ind c =
+    Bytes.set tbl.(ind / Sys.max_string_length) (ind mod Sys.max_string_length)
+              c
+
+  let blit src srcoff dst dstoff len =
+    for i = 0 to len - 1 do
+      set dst (dstoff + i) (get src (srcoff + i))
+    done
+
+  let output oc tbl pos len =
+    for i = pos to pos + len - 1 do
+      output_char oc (get tbl i)
+    done
+
+  let unsafe_blit_to_bytes src srcoff dst dstoff len =
+    for i = 0 to len - 1 do
+      Bytes.unsafe_set dst (dstoff + i) (get src (srcoff + i))
+    done
+
+  let input_bytes ic len =
+    let tbl = create len in
+    Array.iter (fun str -> really_input ic str 0 (Bytes.length str)) tbl;
+    tbl
+end
+
+let file_contents filename =
+  let ic = open_in filename in
+  try
+    let str = Bytes.create 1024 in
+    let buf = Buffer.create 1024 in
+    let rec loop () =
+      match input ic str 0 1024 with
+      | 0 -> ()
+      | n ->
+        Buffer.add_subbytes buf str 0 n;
+        loop ()
+    in
+    loop ();
+    close_in_noerr ic;
+    Buffer.contents buf
+  with exn ->
+    close_in_noerr ic;
+    raise exn
+
+let edit_distance a b cutoff =
+  let la, lb = String.length a, String.length b in
+  let cutoff =
+    (* using max_int for cutoff would cause overflows in (i + cutoff + 1);
+       we bring it back to the (max la lb) worstcase *)
+    min (max la lb) cutoff in
+  if abs (la - lb) > cutoff then None
+  else begin
+    (* initialize with 'cutoff + 1' so that not-yet-written-to cases have
+       the worst possible cost; this is useful when computing the cost of
+       a case just at the boundary of the cutoff diagonal. *)
+    let m = Array.make_matrix (la + 1) (lb + 1) (cutoff + 1) in
+    m.(0).(0) <- 0;
+    for i = 1 to la do
+      m.(i).(0) <- i;
+    done;
+    for j = 1 to lb do
+      m.(0).(j) <- j;
+    done;
+    for i = 1 to la do
+      for j = max 1 (i - cutoff - 1) to min lb (i + cutoff + 1) do
+        let cost = if a.[i-1] = b.[j-1] then 0 else 1 in
+        let best =
+          (* insert, delete or substitute *)
+          min (1 + min m.(i-1).(j) m.(i).(j-1)) (m.(i-1).(j-1) + cost)
+        in
+        let best =
+          (* swap two adjacent letters; we use "cost" again in case of
+             a swap between two identical letters; this is slightly
+             redundant as this is a double-substitution case, but it
+             was done this way in most online implementations and
+             imitation has its virtues *)
+          if not (i > 1 && j > 1 && a.[i-1] = b.[j-2] && a.[i-2] = b.[j-1])
+          then best
+          else min best (m.(i-2).(j-2) + cost)
+        in
+        m.(i).(j) <- best
+      done;
+    done;
+    let result = m.(la).(lb) in
+    if result > cutoff
+    then None
+    else Some result
+  end
+
+let spellcheck env name =
+  let cutoff =
+    match String.length name with
+      | 1 | 2 -> 0
+      | 3 | 4 -> 1
+      | 5 | 6 -> 2
+      | _ -> 3
+  in
+  let compare target acc head =
+    match edit_distance target head cutoff with
+    | None -> acc
+    | Some dist ->
+      let (best_choice, best_dist) = acc in
+      if dist < best_dist then ([head], dist)
+      else if dist = best_dist then (head :: best_choice, dist)
+      else acc
+  in
+  fst (List.fold_left ~f:(compare name) ~init:([], max_int) env)
+
+let did_you_mean ppf get_choices =
+  (* flush now to get the error report early, in the (unheard of) case
+     where the search in the get_choices function would take a bit of
+     time; in the worst case, the user has seen the error, she can
+     interrupt the process before the spell-checking terminates. *)
+  Format.fprintf ppf "@?";
+  match get_choices () with
+  | [] -> ()
+  | choices ->
+     let rest, last = split_last choices in
+     Format.fprintf ppf "@\nHint: Did you mean %s%s%s?@?"
+       (String.concat ~sep:", " rest)
+       (if rest = [] then "" else " or ")
+       last
+
+let cut_at s c =
+  let pos = String.index s c in
+  String.sub s ~pos:0 ~len:pos,
+  String.sub s ~pos:(pos+1) ~len:(String.length s - pos - 1)
+
+(* Color handling *)
+module Color = struct
+  (* use ANSI color codes, see https://en.wikipedia.org/wiki/ANSI_escape_code *)
+  type color =
+    | Black
+    | Red
+    | Green
+    | Yellow
+    | Blue
+    | Magenta
+    | Cyan
+    | White
+  ;;
+
+  type style =
+    | FG of color (* foreground *)
+    | BG of color (* background *)
+    | Bold
+    | Reset
+
+  let ansi_of_color = function
+    | Black -> "0"
+    | Red -> "1"
+    | Green -> "2"
+    | Yellow -> "3"
+    | Blue -> "4"
+    | Magenta -> "5"
+    | Cyan -> "6"
+    | White -> "7"
+
+  let code_of_style = function
+    | FG c -> "3" ^ ansi_of_color c
+    | BG c -> "4" ^ ansi_of_color c
+    | Bold -> "1"
+    | Reset -> "0"
+
+  let ansi_of_style_l l =
+    let s = match l with
+      | [] -> code_of_style Reset
+      | [s] -> code_of_style s
+      | _ -> String.concat ~sep:";" (List.map ~f:code_of_style l)
+    in
+    "\x1b[" ^ s ^ "m"
+
+
+  type Format.stag += Style of style list
+  type styles = {
+    error: style list;
+    warning: style list;
+    loc: style list;
+  }
+
+  let default_styles = {
+    warning = [Bold; FG Magenta];
+    error = [Bold; FG Red];
+    loc = [Bold];
+  }
+
+  let cur_styles = ref default_styles
+  let get_styles () = !cur_styles
+  let set_styles s = cur_styles := s
+
+  (* map a tag to a style, if the tag is known.
+     @raise Not_found otherwise *)
+  let style_of_tag s = match s with
+    | Format.String_tag "error" -> (!cur_styles).error
+    | Format.String_tag "warning" -> (!cur_styles).warning
+    | Format.String_tag "loc" -> (!cur_styles).loc
+    | Style s -> s
+    | _ -> raise Not_found
+
+  let color_enabled = ref true
+
+  (* either prints the tag of [s] or delegates to [or_else] *)
+  let mark_open_tag ~or_else s =
+    try
+      let style = style_of_tag s in
+      if !color_enabled then ansi_of_style_l style else ""
+    with Not_found -> or_else s
+
+  let mark_close_tag ~or_else s =
+    try
+      let _ = style_of_tag s in
+      if !color_enabled then ansi_of_style_l [Reset] else ""
+    with Not_found -> or_else s
+
+  (* add color handling to formatter [ppf] *)
+  let set_color_tag_handling ppf =
+    let open Format in
+    let functions = pp_get_formatter_stag_functions ppf () in
+    let functions' = {functions with
+      mark_open_stag=(mark_open_tag ~or_else:functions.mark_open_stag);
+      mark_close_stag=(mark_close_tag ~or_else:functions.mark_close_stag);
+    } in
+    pp_set_mark_tags ppf true; (* enable tags *)
+    pp_set_formatter_stag_functions ppf functions';
+    ()
+
+  external isatty : out_channel -> bool = "caml_sys_isatty"
+
+  (* reasonable heuristic on whether colors should be enabled *)
+  let should_enable_color () =
+    let term = try Sys.getenv "TERM" with Not_found -> "" in
+    term <> "dumb"
+    && term <> ""
+    && isatty stderr
+
+  type setting = Auto | Always | Never
+
+  let default_setting = Auto
+
+  let setup =
+    let first = ref true in (* initialize only once *)
+    let formatter_l =
+      [Format.std_formatter; Format.err_formatter; Format.str_formatter]
+    in
+    let enable_color = function
+      | Auto -> should_enable_color ()
+      | Always -> true
+      | Never -> false
+    in
+    fun o ->
+      if !first then (
+        first := false;
+        Format.set_mark_tags true;
+        List.iter ~f:set_color_tag_handling formatter_l;
+        color_enabled := (match o with
+          | Some s -> enable_color s
+          | None -> enable_color default_setting)
+      );
+      ()
+end
+
+let time_spent () =
+  let open Unix in
+  let t = times () in
+  ((t.tms_utime +. t.tms_stime +. t.tms_cutime +. t.tms_cstime) *. 1000.0)
+
+let normalise_eol s =
+  let b = Buffer.create 80 in
+    for i = 0 to String.length s - 1 do
+      if s.[i] <> '\r' then Buffer.add_char b s.[i]
+    done;
+    Buffer.contents b
+
+let unitname filename =
+  let unitname =
+    try String.sub filename ~pos:0 ~len:(String.index filename '.')
+    with Not_found -> filename
+  in
+  String.capitalize unitname
+
+(* [modules_in_path ~ext path] lists ocaml modules corresponding to
+                    * filenames with extension [ext] in given [path]es.
+                    * For instance, if there is file "a.ml","a.mli","b.ml" in ".":
+                    * - modules_in_path ~ext:".ml" ["."] returns ["A";"B"],
+                    * - modules_in_path ~ext:".mli" ["."] returns ["A"] *)
+let modules_in_path ~ext path =
+  let seen = Hashtbl.create 7 in
+  List.fold_left ~init:[] path
+    ~f:begin fun results dir ->
+      try
+        Array.fold_left
+          begin fun results file ->
+            if Filename.check_suffix file ext
+            then let name = Filename.chop_extension file in
+              (if Hashtbl.mem seen name
+               then results
+               else
+                 (Hashtbl.add seen name (); String.capitalize name :: results))
+            else results
+          end results (Sys.readdir dir)
+      with Sys_error _ -> results
+    end
+
+module String = struct
+  include CamlString
+  module Ord = struct
+    type t = string
+    let compare = String.compare
+  end
+  module Set = Set.Make (Ord)
+  module Map = Map.Make (Ord)
+  module Tbl = Hashtbl.Make (struct
+      type t = string
+      let equal (x : string) (y : string) : bool = (x = y)
+      let hash = Hashtbl.hash
+    end)
+end
+
+
+type filepath = string
+type modname = string
+type crcs = (modname * Digest.t option) list
+
+type alerts = string String.Map.t
diff --git a/src/utils/misc.mli b/src/utils/misc.mli
new file mode 100644
index 0000000..a2dc088
--- /dev/null
+++ b/src/utils/misc.mli
@@ -0,0 +1,357 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Miscellaneous useful types and functions *)
+
+val fatal_error: string -> 'a
+val fatal_errorf: ('a, Format.formatter, unit, 'b) format4 -> 'a
+exception Fatal_error of string * Printexc.raw_backtrace
+
+val try_finally :
+  ?always:(unit -> unit) ->
+  ?exceptionally:(unit -> unit) ->
+  (unit -> 'a) -> 'a
+(** [try_finally work ~always ~exceptionally] is designed to run code
+    in [work] that may fail with an exception, and has two kind of
+    cleanup routines: [always], that must be run after any execution
+    of the function (typically, freeing system resources), and
+    [exceptionally], that should be run only if [work] or [always]
+    failed with an exception (typically, undoing user-visible state
+    changes that would only make sense if the function completes
+    correctly). For example:
+
+    {[
+      let objfile = outputprefix ^ ".cmo" in
+      let oc = open_out_bin objfile in
+      Misc.try_finally
+        (fun () ->
+           bytecode
+           ++ Timings.(accumulate_time (Generate sourcefile))
+               (Emitcode.to_file oc modulename objfile);
+           Warnings.check_fatal ())
+        ~always:(fun () -> close_out oc)
+        ~exceptionally:(fun _exn -> remove_file objfile);
+    ]}
+
+    If [exceptionally] fail with an exception, it is propagated as
+    usual.
+
+    If [always] or [exceptionally] use exceptions internally for
+    control-flow but do not raise, then [try_finally] is careful to
+    preserve any exception backtrace coming from [work] or [always]
+    for easier debugging.
+*)
+
+val reraise_preserving_backtrace : exn -> (unit -> unit) -> 'a
+(** [reraise_preserving_backtrace e f] is (f (); raise e) except that the
+    current backtrace is preserved, even if [f] uses exceptions internally. *)
+
+
+val map_end: ('a -> 'b) -> 'a list -> 'b list -> 'b list
+        (* [map_end f l t] is [map f l @ t], just more efficient. *)
+val map_left_right: ('a -> 'b) -> 'a list -> 'b list
+        (* Like [List.map], with guaranteed left-to-right evaluation order *)
+val for_all2: ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+        (* Same as [List.for_all] but for a binary predicate.
+           In addition, this [for_all2] never fails: given two lists
+           with different lengths, it returns false. *)
+val replicate_list: 'a -> int -> 'a list
+        (* [replicate_list elem n] is the list with [n] elements
+           all identical to [elem]. *)
+val list_remove: 'a -> 'a list -> 'a list
+        (* [list_remove x l] returns a copy of [l] with the first
+           element equal to [x] removed. *)
+val split_last: 'a list -> 'a list * 'a
+        (* Return the last element and the other elements of the given list. *)
+val may: ('a -> unit) -> 'a option -> unit
+val may_map: ('a -> 'b) -> 'a option -> 'b option
+
+type ref_and_value = R : 'a ref * 'a -> ref_and_value
+
+val protect_refs : ref_and_value list -> (unit -> 'a) -> 'a
+(** [protect_refs l f] temporarily sets [r] to [v] for each [R (r, v)] in [l]
+    while executing [f]. The previous contents of the references is restored
+    even if [f] raises an exception. *)
+
+val exact_file_exists : dirname:string -> basename:string -> bool
+	(* Like [Sys.file_exists], but takes into account case-insensitive file
+	   systems: return true only if the basename (last component of the
+           path) has the correct case. *)
+val find_in_path: string list -> string -> string
+        (* Search a file in a list of directories. *)
+val find_in_path_rel: string list -> string -> string
+        (* Search a relative file in a list of directories. *)
+val find_in_path_uncap: ?fallback:string -> string list -> string -> string
+        (* Same, but search also for uncapitalized name, i.e.
+           if name is Foo.ml, allow /path/Foo.ml and /path/foo.ml
+           to match. *)
+val canonicalize_filename : ?cwd:string -> string -> string
+        (* Ensure that path is absolute (wrt to cwd), by following ".." and "." *)
+val expand_glob : ?filter:(string -> bool) -> string -> string list -> string list
+        (* [expand_glob ~filter pattern acc] adds all filenames matching
+           [pattern] and satistfying the [filter] predicate to [acc]*)
+val split_path : string -> string list -> string list
+        (* [split_path path tail] prepends all components of [path] to [tail],
+           including implicit "." if path is not absolute.
+           [split_path "a/b/c" []] = ["."; "a"; "b"; "c"]
+           [split_path "/a/b/c" []] = ["/"; "a"; "b"; "c"]
+        FIXME: explain windows behavior
+        *)
+
+val remove_file: string -> unit
+        (* Delete the given file if it exists. Never raise an error. *)
+val expand_directory: string -> string -> string
+        (* [expand_directory alt file] eventually expands a [+] at the
+           beginning of file into [alt] (an alternate root directory) *)
+
+val create_hashtable: int -> ('a * 'b) list -> ('a, 'b) Hashtbl.t
+        (* Create a hashtable of the given size and fills it with the
+           given bindings. *)
+
+val copy_file: in_channel -> out_channel -> unit
+        (* [copy_file ic oc] reads the contents of file [ic] and copies
+           them to [oc]. It stops when encountering EOF on [ic]. *)
+val copy_file_chunk: in_channel -> out_channel -> int -> unit
+        (* [copy_file_chunk ic oc n] reads [n] bytes from [ic] and copies
+           them to [oc]. It raises [End_of_file] when encountering
+           EOF on [ic]. *)
+val string_of_file: in_channel -> string
+        (* [string_of_file ic] reads the contents of file [ic] and copies
+           them to a string. It stops when encountering EOF on [ic]. *)
+val output_to_file_via_temporary:
+      ?mode:open_flag list -> string -> (string -> out_channel -> 'a) -> 'a
+        (* Produce output in temporary file, then rename it
+           (as atomically as possible) to the desired output file name.
+           [output_to_file_via_temporary filename fn] opens a temporary file
+           which is passed to [fn] (name + output channel).  When [fn] returns,
+           the channel is closed and the temporary file is renamed to
+           [filename]. *)
+
+val input_bytes : in_channel -> int -> bytes;;
+        (* [input_bytes ic n] reads [n] bytes from [ic] and returns them
+           in a new string.  It raises [End_of_file] if EOF is encountered
+           before all the bytes are read. *)
+
+val log2: int -> int
+        (* [log2 n] returns [s] such that [n = 1 lsl s]
+           if [n] is a power of 2*)
+val align: int -> int -> int
+        (* [align n a] rounds [n] upwards to a multiple of [a]
+           (a power of 2). *)
+val no_overflow_add: int -> int -> bool
+        (* [no_overflow_add n1 n2] returns [true] if the computation of
+           [n1 + n2] does not overflow. *)
+val no_overflow_sub: int -> int -> bool
+        (* [no_overflow_sub n1 n2] returns [true] if the computation of
+           [n1 - n2] does not overflow. *)
+val no_overflow_mul: int -> int -> bool
+        (* [no_overflow_mul n1 n2] returns [true] if the computation of
+           [n1 * n2] does not overflow. *)
+val no_overflow_lsl: int -> int -> bool
+        (* [no_overflow_lsl n k] returns [true] if the computation of
+           [n lsl k] does not overflow. *)
+
+module Int_literal_converter : sig
+  val int : string -> int
+  val int32 : string -> int32
+  val int64 : string -> int64
+  val nativeint : string -> nativeint
+end
+
+val chop_extension_if_any: string -> string
+        (* Like Filename.chop_extension but returns the initial file
+           name if it has no extension *)
+
+val chop_extensions: string -> string
+        (* Return the given file name without its extensions. The extensions
+           is the longest suffix starting with a period and not including
+           a directory separator, [.xyz.uvw] for instance.
+
+           Return the given name if it does not contain an extension. *)
+
+val search_substring: string -> string -> int -> int
+        (* [search_substring pat str start] returns the position of the first
+           occurrence of string [pat] in string [str].  Search starts
+           at offset [start] in [str].  Raise [Not_found] if [pat]
+           does not occur. *)
+
+val replace_substring: before:string -> after:string -> string -> string
+        (* [replace_substring ~before ~after str] replaces all
+           occurrences of [before] with [after] in [str] and returns
+           the resulting string. *)
+
+val rev_split_words: string -> string list
+        (* [rev_split_words s] splits [s] in blank-separated words, and returns
+           the list of words in reverse order. *)
+
+val rev_string_split: on:char -> string -> string list
+        (* [rev_string_split ~on s] splits [s] on [on], and return the list of
+           words in reverse order. *)
+
+val get_ref: 'a list ref -> 'a list
+        (* [get_ref lr] returns the content of the list reference [lr] and reset
+           its content to the empty list. *)
+
+val set_or_ignore : ('a -> 'b option) -> 'b option ref -> 'a -> unit
+        (* [set_or_ignore f opt x] sets [opt] to [f x] if it returns [Some _],
+           or leaves it unmodified if it returns [None]. *)
+
+val fst3: 'a * 'b * 'c -> 'a
+val snd3: 'a * 'b * 'c -> 'b
+val thd3: 'a * 'b * 'c -> 'c
+
+val fst4: 'a * 'b * 'c * 'd -> 'a
+val snd4: 'a * 'b * 'c * 'd -> 'b
+val thd4: 'a * 'b * 'c * 'd -> 'c
+val for4: 'a * 'b * 'c * 'd -> 'd
+
+(* [modules_in_path ~ext path] lists ocaml modules corresponding to
+ * filenames with extension [ext] in given [path]es.
+ * For instance, if there is file "a.ml","a.mli","b.ml" in ".":
+ * - modules_in_path ~ext:".ml" ["."] returns ["A";"B"],
+ * - modules_in_path ~ext:".mli" ["."] returns ["A"] *)
+val modules_in_path : ext:string -> string list -> string list
+
+val file_contents : string -> string
+
+module LongString :
+  sig
+    type t = bytes array
+    val create : int -> t
+    val length : t -> int
+    val get : t -> int -> char
+    val set : t -> int -> char -> unit
+    val blit : t -> int -> t -> int -> int -> unit
+    val output : out_channel -> t -> int -> int -> unit
+    val unsafe_blit_to_bytes : t -> int -> bytes -> int -> int -> unit
+    val input_bytes : in_channel -> int -> t
+  end
+
+val edit_distance : string -> string -> int -> int option
+(** [edit_distance a b cutoff] computes the edit distance between
+    strings [a] and [b]. To help efficiency, it uses a cutoff: if the
+    distance [d] is smaller than [cutoff], it returns [Some d], else
+    [None].
+
+    The distance algorithm currently used is Damerau-Levenshtein: it
+    computes the number of insertion, deletion, substitution of
+    letters, or swapping of adjacent letters to go from one word to the
+    other. The particular algorithm may change in the future.
+*)
+
+val spellcheck : string list -> string -> string list
+(** [spellcheck env name] takes a list of names [env] that exist in
+    the current environment and an erroneous [name], and returns a
+    list of suggestions taken from [env], that are close enough to
+    [name] that it may be a typo for one of them. *)
+
+val did_you_mean : Format.formatter -> (unit -> string list) -> unit
+(** [did_you_mean ppf get_choices] hints that the user may have meant
+    one of the option returned by calling [get_choices]. It does nothing
+    if the returned list is empty.
+
+    The [unit -> ...] thunking is meant to delay any potentially-slow
+    computation (typically computing edit-distance with many things
+    from the current environment) to when the hint message is to be
+    printed. You should print an understandable error message before
+    calling [did_you_mean], so that users get a clear notification of
+    the failure even if producing the hint is slow.
+*)
+
+val cut_at : string -> char -> string * string
+(** [String.cut_at s c] returns a pair containing the sub-string before
+   the first occurrence of [c] in [s], and the sub-string after the
+   first occurrence of [c] in [s].
+   [let (before, after) = String.cut_at s c in
+    before ^ String.make 1 c ^ after] is the identity if [s] contains [c].
+
+   Raise [Not_found] if the character does not appear in the string
+   @since 4.01
+*)
+
+val time_spent : unit -> float
+(** Returns a more precise measurement of resources usage than
+    Sys.times/Unix.times.
+    Both user and kernel cpu time is accounted.  *)
+
+module String : sig
+  include module type of String
+  module Map : Map.S with type key = t
+  module Set : Set.S with type elt = t
+  module Tbl : Hashtbl.S with type key = t
+end
+
+val normalise_eol : string -> string
+(** [normalise_eol s] returns a fresh copy of [s] with any '\r' characters
+   removed. Intended for pre-processing text which will subsequently be printed
+   on a channel which performs EOL transformations (i.e. Windows) *)
+
+val unitname: string -> string
+(** Return the name of the OCaml module matching a basename
+    (filename without directory).
+    Remove the extension and capitalize *)
+
+type filepath = string
+type modname = string
+type crcs = (modname * Digest.t option) list
+
+type alerts = string String.Map.t
+
+(* Color handling *)
+module Color : sig
+  type color =
+    | Black
+    | Red
+    | Green
+    | Yellow
+    | Blue
+    | Magenta
+    | Cyan
+    | White
+  ;;
+
+  type style =
+    | FG of color (* foreground *)
+    | BG of color (* background *)
+    | Bold
+    | Reset
+
+  type Format.stag += Style of style list
+
+  val ansi_of_style_l : style list -> string
+  (* ANSI escape sequence for the given style *)
+
+  type styles = {
+    error: style list;
+    warning: style list;
+    loc: style list;
+  }
+
+  val default_styles: styles
+  val get_styles: unit -> styles
+  val set_styles: styles -> unit
+
+  type setting = Auto | Always | Never
+
+  val default_setting : setting
+
+  val setup : setting option -> unit
+  (* [setup opt] will enable or disable color handling on standard formatters
+     according to the value of color setting [opt].
+     Only the first call to this function has an effect. *)
+
+  val set_color_tag_handling : Format.formatter -> unit
+  (* adds functions to support color tags to the given formatter. *)
+end
diff --git a/src/utils/ppxsetup.ml b/src/utils/ppxsetup.ml
new file mode 100644
index 0000000..885a324
--- /dev/null
+++ b/src/utils/ppxsetup.ml
@@ -0,0 +1,91 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+open Std
+
+type t = {
+  ppxs: string list;
+  ppxopts: string list list String.Map.t;
+}
+
+let empty = { ppxs = []; ppxopts = String.Map.empty }
+
+let add_ppx ppx t =
+  if List.mem ppx ~set:t.ppxs
+  then t
+  else {t with ppxs = ppx :: t.ppxs}
+
+let add_ppxopts ppx opts t =
+  match opts with
+  | [] -> t
+  | opts ->
+    let ppx = Filename.basename ppx in
+    let optss =
+      try String.Map.find ppx t.ppxopts
+      with Not_found -> []
+    in
+    if not (List.mem ~set:optss opts) then
+      let ppxopts = String.Map.add ~key:ppx ~data:(opts :: optss) t.ppxopts in
+      {t with ppxopts}
+    else t
+
+let union ta tb =
+  { ppxs = List.filter_dup (ta.ppxs @ tb.ppxs);
+    ppxopts = String.Map.merge ~f:(fun _ a b -> match a, b with
+        | v, None | None, v -> v
+        | Some a, Some b -> Some (List.filter_dup (a @ b)))
+        ta.ppxopts tb.ppxopts
+  }
+
+let command_line t =
+  List.fold_right ~f:(fun ppx ppxs ->
+      let basename = Filename.basename ppx in
+      let opts =
+        try String.Map.find basename t.ppxopts
+        with Not_found -> []
+      in
+      let opts = List.concat (List.rev opts) in
+      String.concat ~sep:" " (ppx :: opts) :: ppxs)
+    t.ppxs ~init:[]
+
+let dump t =
+  let string k = `String k in
+  let string_list l = `List (List.map ~f:string l) in
+  `Assoc [
+    "preprocessors",
+    string_list t.ppxs;
+    "options",
+    `Assoc (
+      String.Map.fold
+        ~f:(fun ~key ~data:opts acc ->
+          let opts = List.rev_map ~f:string_list opts in
+          (key, `List opts) :: acc)
+        ~init:[]
+        t.ppxopts
+    )
+  ]
diff --git a/src/utils/ppxsetup.mli b/src/utils/ppxsetup.mli
new file mode 100644
index 0000000..b1758c9
--- /dev/null
+++ b/src/utils/ppxsetup.mli
@@ -0,0 +1,39 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+type t
+
+val empty: t
+val add_ppx: string -> t -> t
+val add_ppxopts: string -> string list -> t -> t
+
+val union: t -> t -> t
+
+val command_line: t -> string list
+
+val dump : t -> Std.json
diff --git a/src/utils/sexp.ml b/src/utils/sexp.ml
new file mode 100644
index 0000000..17a8c91
--- /dev/null
+++ b/src/utils/sexp.ml
@@ -0,0 +1,313 @@
+type t =
+  | Cons   of t * t
+  | Sym    of string
+  | String of string
+  | Int    of int
+  | Float  of float
+
+let nil = Sym "nil"
+
+let escaped str =
+  let len = String.length str in
+  let extra_chars = ref 0 in
+  for i = 0 to len - 1 do
+    match str.[i] with
+    | '\\' | '"' -> incr extra_chars
+    | _ -> ()
+  done;
+  let buf = Buffer.create (len + !extra_chars + 2) in
+  Buffer.add_char buf '"';
+  if !extra_chars = 0 then (
+    Buffer.add_string buf str
+  ) else (
+    for i = 0 to len - 1 do
+      let c = str.[i] in
+      if c = '"' || c = '\\' then
+        Buffer.add_char buf '\\';
+      Buffer.add_char buf c
+    done;
+  );
+  Buffer.add_char buf '"';
+  Buffer.contents buf
+
+let unescaped str =
+  (* Unescaped doesn't support unicode escaping and multibyte hex and octal
+     escaping.
+     Unicode escaping: '\uNNNN' or '\U00NNNNNN'
+     Hex/octal escaping looks like '\xNN' or '\NNN'.
+     '\xNNNN' and '\NNNNNN' are ambiguous, but emacs will try to parse them
+     as multibyte
+  *)
+  match String.index str '\\' with
+  | exception Not_found -> str
+  | _ ->
+    let len = String.length str in
+    let buf = Buffer.create len in
+    let i = ref 0 in
+    while !i < len do
+      match str.[!i] with
+      | '\\' -> (
+          incr i;
+          begin match str.[!i] with
+            | 'n' -> Buffer.add_char buf '\n'
+            | 'r' -> Buffer.add_char buf '\r'
+            | 't' -> Buffer.add_char buf '\t'
+            | 'x' ->
+              let c0 = Char.code str.[!i+1] in
+              let c1 = Char.code str.[!i+2] in
+              Buffer.add_char buf (Char.chr ((c0 * 16) lor c1));
+              i := !i + 2;
+            | '0'..'9' ->
+              let c0 = Char.code str.[!i+1] in
+              let c1 = Char.code str.[!i+2] in
+              let c2 = Char.code str.[!i+3] in
+              Buffer.add_char buf (Char.chr ((c0 * 64) lor (c1 * 8) lor c2));
+              i := !i + 2;
+            | c -> Buffer.add_char buf c
+          end;
+          incr i
+        )
+      | c ->
+        Buffer.add_char buf c;
+        incr i
+    done;
+    Buffer.contents buf
+
+let rec of_list = function
+  | [] -> nil
+  | a :: tl -> Cons (a, of_list tl)
+
+let rec tell_sexp tell = function
+  | Cons (a,b) ->
+    tell "(";
+    tell_sexp tell a;
+    tell_cons tell b
+  | Sym s    -> tell s
+  | String s -> tell (escaped s)
+  | Int i    -> tell (string_of_int i)
+  | Float f  -> tell (string_of_float f)
+
+and tell_cons tell = function
+  | Sym "nil" -> tell ")"
+  | Cons (a,b) ->
+    tell " ";
+    tell_sexp tell a;
+    tell_cons tell b
+  | sexp ->
+    tell " . ";
+    tell_sexp tell sexp;
+    tell ")"
+
+let is_alpha c =
+  (c >= 'a' && c <= 'z')
+  || (c >= 'A' && c <= 'Z')
+
+let is_num c =
+  (c >= '0' && c <= '9')
+
+let is_alphanum c = is_alpha c || is_num c
+
+let read_sexp getch =
+  let buf = Buffer.create 10 in
+  let rec read_sexp getch = function
+    | ' ' | '\t' | '\n' ->
+      read_sexp getch (getch ())
+
+    | c when is_num c ->
+      read_num getch c
+
+    | '\'' | ':' | '_' as c -> read_sym getch (Some c)
+    | c when is_alpha c -> read_sym getch (Some c)
+
+    | '"' ->
+      read_string getch
+    | '\000' -> raise End_of_file
+    | '(' ->
+      let lhs, next = read_sexp getch (getch ()) in
+      read_cons getch (fun rhs -> Cons (lhs, rhs)) next
+    | _ -> failwith "Invalid parse"
+
+  and read_cons getch k next =
+    match (match next with Some c -> c | None -> getch ()) with
+    | ' ' | '\t' | '\n' -> read_cons getch k None
+    | ')' -> k nil, None
+    | '.' ->
+      let rhs, next = read_sexp getch (getch ()) in
+      let rec aux = function
+        | ')' -> k rhs
+        | ' ' | '\t' | '\n' -> aux (getch ())
+        | _ -> failwith "Invalid parse"
+      in
+      begin match next with
+        | Some c -> aux c
+        | None -> aux (getch ())
+      end, None
+    | c ->
+      let cell, next = read_sexp getch c in
+      read_cons getch (fun rhs -> k (Cons (cell, rhs))) next
+
+  and read_num getch c =
+    Buffer.clear buf;
+    Buffer.add_char buf c;
+    let is_float = ref false in
+    let rec aux () =
+      match getch () with
+      | c when c >= '0' && c <= '9' ->
+        Buffer.add_char buf c; aux ()
+      | '.' | 'e' | 'E' as c ->
+        is_float := true;
+        Buffer.add_char buf c; aux ()
+      | c ->
+        let s = Buffer.contents buf in
+        (if !is_float
+         then Float (float_of_string s)
+         else Int (int_of_string s)),
+        Some c
+    in
+    aux ()
+
+  and read_string getch =
+    Buffer.clear buf;
+    let rec aux () =
+      match getch () with
+      | '\000' -> failwith "Unterminated string"
+      | '\\' ->
+        Buffer.add_char buf '\\';
+        Buffer.add_char buf (getch ());
+        aux ()
+      | '"' ->
+        String (unescaped (Buffer.contents buf)), None
+      | c ->
+        Buffer.add_char buf c;
+        aux ()
+    in
+    aux ()
+
+  and read_sym getch next =
+    Buffer.clear buf;
+    let rec aux next =
+      match (match next with Some c -> c | None -> getch ()) with
+      | ('\'' | '-' | ':' | '_') as c ->
+        Buffer.add_char buf c;
+        aux None
+      | c when is_alphanum c ->
+        Buffer.add_char buf c;
+        aux None
+      | c -> Sym (Buffer.contents buf), Some c
+    in
+    aux next
+  in
+  read_sexp getch (getch ())
+
+let to_buf sexp buf =
+  tell_sexp (Buffer.add_string buf) sexp
+
+let to_string sexp =
+  let buf = Buffer.create 100 in
+  to_buf sexp buf;
+  Buffer.contents buf
+
+let getch_of_substring str pos len =
+  let len = pos + len in
+  if pos < 0 || len > String.length str then
+    invalid_arg "Sexp.getch_of_substring";
+  let pos = ref pos in
+  let getch () =
+    if !pos < len then
+      let r = str.[!pos] in
+      incr pos;
+      r
+    else '\000'
+  in
+  getch
+
+let getch_of_string str =
+  getch_of_substring str 0 (String.length str)
+
+let of_string str =
+  fst (read_sexp (getch_of_string str))
+
+let getch_of_subbytes str pos len =
+  let len = pos + len in
+  if pos < 0 || len > Bytes.length str then
+    invalid_arg "Sexp.getch_of_subbytes";
+  let pos = ref pos in
+  let getch () =
+    if !pos < len then
+      let r = Bytes.get str !pos in
+      incr pos;
+      r
+    else '\000'
+  in
+  getch
+
+let of_file_descr ?(on_read=ignore) fd =
+  let getch = ref (fun () -> '\000') in
+  let rest = ref None in
+  let buffer = Bytes.create 1024 in
+  let getch () =
+    match !rest with
+    | Some r ->
+      rest := None;
+      r
+    | None ->
+      match !getch () with
+      | '\000' ->
+        on_read fd;
+        let read = Unix.read fd buffer 0 1024 in
+        if read = 0 then '\000'
+        else
+          begin
+            getch := getch_of_subbytes buffer 0 read;
+            !getch ()
+          end
+      | c -> c
+  in
+  fun () ->
+    try
+      let sexp, rest' = read_sexp getch in
+      rest := rest';
+      Some sexp
+    with End_of_file -> None
+
+let of_channel ?on_read ic =
+  of_file_descr ?on_read (Unix.descr_of_in_channel ic)
+
+let rec of_json =
+  let assoc_item (a,b) = Cons (Sym a, of_json b) in
+  function
+  | `Null       -> Sym "null"
+  | `Int i      -> Int i
+  | `Float f    -> Float f
+  | `String s   -> String s
+  | `Bool true  -> Sym "true"
+  | `Bool false -> Sym "false"
+  | `Assoc lst  -> Cons (Cons (Sym "assoc", Sym "nil"), of_list (List.map assoc_item lst))
+  | `List lst   -> of_list (List.map of_json lst)
+
+let rec to_json =
+  let fail msg sexp =
+    failwith (msg ^ ", got: \n" ^ to_string sexp)
+  in
+  let rec assoc_item = function
+    | Cons (Cons (Sym a, b), c) -> (a, to_json b) :: assoc_item c
+    | Sym "nil" -> []
+    | sexp -> fail "expecting association (key . value)" sexp
+  in
+  let rec list_items = function
+    | Sym "nil" -> []
+    | Cons (hd, tl) -> to_json hd :: list_items tl
+    | sexp -> fail "expecting list" sexp
+  in
+  function
+  | Sym "null"  -> `Null
+  | Sym "true"  -> `Bool true
+  | Sym "false" -> `Bool false
+  | Int i    -> `Int i
+  | Float f  -> `Float f
+  | String s -> `String s
+  | Cons (Cons (Sym "assoc", Sym "nil"), assocs) ->
+    `Assoc (assoc_item assocs)
+  | Sym "nil" -> `List []
+  | Cons (hd, tl) -> `List (to_json hd :: list_items tl)
+  | Sym s -> `String s
diff --git a/src/utils/sexp.mli b/src/utils/sexp.mli
new file mode 100644
index 0000000..3801f3e
--- /dev/null
+++ b/src/utils/sexp.mli
@@ -0,0 +1,28 @@
+open Std
+
+type t =
+    Cons of t * t
+  | Sym of string
+  | String of string
+  | Int of int
+  | Float of float
+
+val nil : t
+val of_list : t list -> t
+
+val tell_sexp : (string -> unit) -> t -> unit
+val tell_cons : (string -> unit) -> t -> unit
+
+val to_buf : t -> Buffer.t -> unit
+
+val to_string : t -> string
+
+val of_string : string -> t
+
+val of_file_descr :
+  ?on_read:(Unix.file_descr -> unit) -> Unix.file_descr -> unit -> t option
+val of_channel :
+  ?on_read:(Unix.file_descr -> unit) -> in_channel -> unit -> t option
+
+val of_json : json -> t
+val to_json : t -> json
diff --git a/src/utils/std.ml b/src/utils/std.ml
new file mode 100644
index 0000000..670e1d1
--- /dev/null
+++ b/src/utils/std.ml
@@ -0,0 +1,805 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                             Thomas Refis  <refis.thomas(_)gmail.com>
+                             Simon Castellan  <simon.castellan(_)iuwt.fr>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+module Json = struct
+  include Yojson.Basic
+  let string x = `String x
+  let int x = `Int x
+  let bool x = `Bool x
+
+  let option f = function
+    | None -> `Null
+    | Some x -> f x
+
+  let list f x =
+    `List (List.map f x)
+
+  let print f () x =
+    pretty_to_string (f x)
+
+end
+
+type json =
+  [ `Assoc of (string * json) list
+  | `Bool of bool
+  | `Float of float
+  | `Int of int
+  | `List of json list
+  | `Null
+  | `String of string ]
+
+module Hashtbl = struct
+  include Hashtbl
+
+  let find_some tbl key =
+    try Some (find tbl key)
+    with Not_found -> None
+
+  let elements tbl = Hashtbl.fold (fun _key elt acc -> elt :: acc) tbl []
+
+  let forall table f =
+    match Hashtbl.iter (fun k v -> if not (f k v) then raise Exit) table with
+    | () -> true
+    | exception Exit -> false
+end
+
+module List = struct
+  include ListLabels
+
+  let init ~f n =
+    let rec aux i = if i = n then [] else f i :: aux (succ i) in
+    aux 0
+
+  let index ~f l =
+    let rec aux i = function
+      | [] -> raise Not_found
+      | x :: _ when f x -> i
+      | _ :: xs -> aux (succ i) xs
+    in
+    aux 0 l
+
+  let find_some ~f l =
+    try Some (find ~f l)
+    with Not_found -> None
+
+  let rec rev_scan_left acc ~f l ~init = match l with
+    | [] -> acc
+    | x :: xs ->
+      let init = f init x in
+      rev_scan_left (init :: acc) ~f xs ~init
+
+  let scan_left ~f l ~init =
+      List.rev (rev_scan_left [] ~f l ~init)
+
+  let rev_filter ~f lst =
+    let rec aux acc = function
+      | [] -> acc
+      | x :: xs -> aux (if f x then x :: acc else acc) xs
+    in
+    aux [] lst
+
+  let rec filter_map ~f = function
+    | [] -> []
+    | x :: xs ->
+      match f x with
+      | None -> filter_map ~f xs
+      | Some x -> x :: filter_map ~f xs
+
+  let rec find_map ~f = function
+    | [] -> raise Not_found
+    | x :: xs ->
+      match f x with
+      | None -> find_map ~f xs
+      | Some x' -> x'
+
+  let rec map_end ~f l1 l2 =
+    match l1 with
+    | [] -> l2
+    | hd::tl -> f hd :: map_end ~f tl l2
+
+  let concat_map ~f l = flatten (map ~f l)
+
+  let replicate elem n =
+    let rec aux acc elem n =
+      if n <= 0 then acc else aux (elem :: acc) elem (n-1)
+    in
+    aux [] elem n
+
+  let rec remove ?(phys=false) x =
+    let check = if phys then (==) else (=) in
+    function
+    | [] -> []
+    | hd :: tl when check x hd -> tl
+    | hd :: tl -> hd :: remove ~phys x tl
+
+  let rec remove_all x = function
+    | [] -> []
+    | hd :: tl when x = hd -> remove_all x tl
+    | hd :: tl -> hd :: remove_all x tl
+
+  let rec same ~f l1 l2 = match l1, l2 with
+    | [], [] -> true
+    | (hd1 :: tl1), (hd2 :: tl2) when f hd1 hd2 -> same ~f tl1 tl2
+    | _, _ -> false
+
+  (* [length_lessthan n l] returns
+   *   Some (List.length l) if List.length l <= n
+   *   None otherwise *)
+  let length_lessthan n l =
+    let rec aux i = function
+      | _ :: xs when i < n -> aux (succ i) xs
+      | [] -> Some i
+      | _ -> None
+    in
+    aux 0 l
+
+  let filter_dup' ~equiv lst =
+    let tbl = Hashtbl.create 17 in
+    let f a b =
+      let b' = equiv b in
+      if Hashtbl.mem tbl b'
+      then a
+      else (Hashtbl.add tbl b' (); b :: a)
+    in
+    rev (fold_left ~f ~init:[] lst)
+
+  let filter_dup lst = filter_dup' ~equiv:(fun x -> x) lst
+
+  let rec merge_cons ~f = function
+    | a :: ((b :: tl) as tl') ->
+      begin match f a b with
+        | Some a' -> merge_cons ~f (a' :: tl)
+        | None -> a :: merge_cons ~f tl'
+      end
+    | tl -> tl
+
+  let rec take_while ~f = function
+    | x :: xs when f x -> x :: take_while ~f xs
+    | _ -> []
+
+  let rec drop_while ~f = function
+    | x :: xs when f x -> drop_while ~f xs
+    | xs -> xs
+
+  let rec take_n acc n = function
+    | x :: xs when n > 0 -> take_n (x :: acc) (n - 1) xs
+    | _ -> List.rev acc
+  let take_n n l = take_n [] n l
+
+  let rec drop_n n = function
+    | _ :: xs when n > 0 -> drop_n (n - 1) xs
+    | xs -> xs
+
+  let rec split_n acc n = function
+    | x :: xs when n > 0 -> split_n (x :: acc) (n - 1) xs
+    | xs -> List.rev acc, xs
+  let split_n n l = split_n [] n l
+
+  let rec split3 xs ys zs = function
+    | (x,y,z) :: tl -> split3 (x :: xs) (y :: ys) (z :: zs) tl
+    | [] -> List.rev xs, List.rev ys, List.rev zs
+  let split3 l = split3 [] [] [] l
+
+  let rec unfold ~f a = match f a with
+    | None -> []
+    | Some a -> a :: unfold ~f a
+
+  let rec rev_unfold acc ~f a = match f a with
+    | None -> acc
+    | Some a -> rev_unfold (a :: acc) ~f a
+
+  let rec fold_n_map ~f ~init = function
+    | [] -> init, []
+    | x :: xs ->
+      let acc, x' = f init x in
+      let acc, xs' = fold_n_map ~f ~init:acc xs in
+      acc, (x' :: xs')
+
+  module Lazy = struct
+    type 'a t =
+      | Nil
+      | Cons of 'a * 'a t lazy_t
+
+    let rec map ~f = function
+      | Nil -> Nil
+      | Cons (hd,tl) ->
+         Cons (f hd, lazy (map ~f (Lazy.force tl)))
+
+    let rec to_strict = function
+      | Nil -> []
+      | Cons (hd, lazy tl) -> hd :: to_strict tl
+
+    let rec unfold f a = match f a with
+      | None -> Nil
+      | Some a -> Cons (a, lazy (unfold f a))
+
+    let rec filter_map ~f = function
+      | Nil -> Nil
+      | Cons (a, tl) -> match f a with
+        | None -> filter_map ~f (Lazy.force tl)
+        | Some a' -> Cons (a', lazy (filter_map ~f (Lazy.force tl)))
+  end
+
+  let rec last = function
+    | [] -> None
+    | [x] -> Some x
+    | _ :: l -> last l
+
+  let rec group_by pred group acc = function
+    | [] -> List.rev acc
+    | x :: xs ->
+      match group with
+      | (x' :: _) when pred x x' ->
+        group_by pred (x :: group) acc xs
+      | _ -> group_by pred [x] (group :: acc) xs
+
+  let group_by pred xs =
+    match group_by pred [] [] xs with
+    | [] :: xs | xs -> xs
+
+  (* Merge sorted lists *)
+  let rec merge ~cmp l1 l2 = match l1, l2 with
+    | l, [] | [], l -> l
+    | (x1 :: _), (x2 :: x2s) when cmp x1 x2 > 0 ->
+      x2 :: merge ~cmp l1 x2s
+    | x1 :: x1s, _ ->
+      x1 :: merge ~cmp x1s l2
+
+  let rec dedup_adjacent ~cmp = function
+    | x1 :: (x2 :: _ as xs) when cmp x1 x2 = 0 -> dedup_adjacent ~cmp xs
+    | x :: xs  -> x :: dedup_adjacent ~cmp xs
+    | [] -> []
+
+  (* [sort_uniq] does not need to maintain a set of seen entries because duplicates will
+     be adjacent. *)
+  let sort_uniq ~cmp l = dedup_adjacent ~cmp (sort ~cmp l)
+
+  let print f () l =
+    "[ " ^ String.concat "; " (List.map (f ()) l) ^ " ]"
+end
+
+module Option = struct
+  let bind opt ~f =
+    match opt with
+    | None -> None
+    | Some x -> f x
+
+  let map ~f = function
+    | None -> None
+    | Some x -> Some (f x)
+
+  let get = function
+    | None -> raise Not_found
+    | Some x -> x
+
+  let value ~default = function
+    | None -> default
+    | Some x -> x
+
+  let value_map ~f ~default = function
+    | None -> default
+    | Some x -> f x
+
+  let iter ~f = function
+    | None -> ()
+    | Some x -> f x
+
+  let cons o xs = match o with
+    | None -> xs
+    | Some x -> x :: xs
+
+  module Infix = struct
+    let return x  = Some x
+    let (>>=) x f = bind x ~f
+    let (>>|) x f = map  x ~f
+  end
+
+  include Infix
+
+  let to_list = function
+    | None -> []
+    | Some x -> [x]
+
+  let is_some = function
+    | None -> false
+    | _ -> true
+
+  let plus a b = match a with
+    | Some _ -> a
+    | None -> b
+
+  let print f () = function
+    | None -> "None"
+    | Some s -> "Some (" ^ f () s ^ ")"
+end
+
+module Result = struct
+  type ('a, 'e) t = ('a, 'e) result =
+  | Ok of 'a
+  | Error of 'e
+end
+
+module String = struct
+  include StringLabels
+
+  let for_all f t =
+    let len = String.length t in
+    let rec loop i =
+      i = len || (f t.[i] && loop (i + 1))
+    in
+    loop 0
+
+
+  let reverse s1 =
+    let len = length s1 in
+    let s2  = Bytes.make len 'a' in
+    for i = 0 to len - 1 do
+      Bytes.set s2 i s1.[len - i - 1]
+    done ;
+    Bytes.to_string s2
+
+  let common_prefix_len s1 s2 =
+    let rec aux i =
+      if i >= length s1 || i >= length s2 || s1.[i] <> s2.[i] then i else
+      aux (succ i)
+    in
+    aux 0
+
+  (* [is_prefixed ~by s] returns [true] iff [by] is a prefix of [s] *)
+  let is_prefixed ~by =
+    let l = String.length by in
+    fun s ->
+    let l' = String.length s in
+    (l' >= l) &&
+      (try for i = 0 to pred l do
+             if s.[i] <> by.[i] then
+               raise Not_found
+           done;
+           true
+       with Not_found -> false)
+
+  (* Drop characters from beginning of string *)
+  let drop n s = sub s ~pos:n ~len:(length s - n)
+
+  module Set = struct
+    include MoreLabels.Set.Make (struct type t = string let compare = compare end)
+    let of_list l = List.fold_left ~f:(fun s elt -> add elt s) l ~init:empty
+    let to_list s = fold ~f:(fun x xs -> x :: xs) s ~init:[]
+  end
+
+  module Map = struct
+    include MoreLabels.Map.Make (struct type t = string let compare = compare end)
+    let of_list l =
+      List.fold_left ~f:(fun m (k,v) -> add ~key:k ~data:v m) l ~init:empty
+    let to_list m = fold ~f:(fun ~key ~data xs -> (key,data) :: xs) m ~init:[]
+
+    let keys   m = fold ~f:(fun ~key ~data:_ xs -> key  :: xs) m ~init:[]
+    let values m = fold ~f:(fun ~key:_ ~data xs -> data :: xs) m ~init:[]
+
+    let add_multiple key data t =
+      let current =
+        try find key t
+        with Not_found -> []
+      in
+      let data = data :: current in
+      add ~key ~data t
+  end
+
+  let mem c s =
+    try ignore (String.index s c : int); true
+    with Not_found -> false
+
+  let first_double_underscore_end s =
+    let len = String.length s in
+    let rec aux i =
+      if i > len - 2 then raise Not_found else
+      if s.[i] = '_' && s.[i + 1] = '_' then i + 1
+      else aux (i + 1)
+    in
+    aux 0
+
+  let no_double_underscore s =
+    try ignore (first_double_underscore_end s); false
+    with Not_found -> true
+
+  let trim = function "" -> "" | str ->
+    let l = String.length str in
+    let is_space = function
+      | ' ' | '\n' | '\t' | '\r' -> true
+      | _ -> false
+    in
+    let r0 = ref 0 and rl = ref l in
+    while !r0 < l && is_space str.[!r0] do incr r0 done;
+    let r0 = !r0 in
+    while !rl > r0 && is_space str.[!rl - 1] do decr rl done;
+    let rl = !rl in
+    if r0 = 0 && rl = l then str else sub str ~pos:r0 ~len:(rl - r0)
+
+  let print () s = Printf.sprintf "%S" s
+
+  (* FIXME: Remove once we drop support for 4.02 and replace the calls by their
+     [_ascii] version. *)
+  [@@@ocaml.warning "-3"]
+
+  let capitalize = capitalize
+  let uncapitalize = uncapitalize
+
+  let lowercase = lowercase
+  let uppercase = uppercase
+
+  let split_on_char_ c s =
+    match String.index s c with
+    | exception Not_found -> [s]
+    | p ->
+      let rec loop i =
+        match String.index_from s i c with
+        | exception Not_found -> [String.sub s i (String.length s - i)]
+        | j ->
+          let s0 = String.sub s i (j - i) in
+          s0 :: loop (j + 1)
+      in
+      let s0 = String.sub s 0 p in
+      s0 :: loop (p + 1)
+
+  let chop_prefix ~prefix text =
+    let tlen = String.length text in
+    let plen = String.length prefix in
+    if tlen >= plen then
+      try
+        for i = 0 to plen - 1 do
+          if prefix.[i] <> text.[i] then raise Not_found
+        done;
+        Some (String.sub text plen (tlen - plen))
+      with Not_found -> None
+    else
+      None
+
+  let next_occurrence ~pattern text from =
+    let plen = String.length pattern in
+    let last = String.length text - plen in
+    let i = ref from and j = ref 0 in
+    while !i <= last && !j < plen do
+      if text.[!i + !j] <> pattern.[!j]
+      then (incr i; j := 0)
+      else incr j
+    done;
+    if !j < plen then
+      raise Not_found
+    else
+      !i
+
+  let replace_all ~pattern ~with_ text =
+    if pattern = "" then text else
+      match next_occurrence ~pattern text 0 with
+      | exception Not_found -> text
+      | j0 ->
+        let buffer = Buffer.create (String.length text) in
+        let rec aux i j =
+          Buffer.add_substring buffer text i (j - i);
+          Buffer.add_string buffer with_;
+          let i' = j + String.length pattern in
+          match next_occurrence ~pattern text i' with
+          | exception Not_found ->
+            Buffer.add_substring buffer text i' (String.length text - i')
+          | j' -> aux i' j'
+        in
+        aux 0 j0;
+        Buffer.contents buffer
+end
+
+let sprintf = Printf.sprintf
+
+module Format = struct
+  include Format
+
+  let default_width = ref 0
+
+  let to_string ?(width= !default_width) () =
+    let b = Buffer.create 32 in
+    let ppf = formatter_of_buffer b in
+    let contents () =
+      pp_print_flush ppf ();
+      Buffer.contents b
+    in
+    pp_set_margin ppf width;
+    ppf, contents
+end
+
+module Lexing = struct
+
+  type position = Lexing.position = {
+    pos_fname : string;
+    pos_lnum : int;
+    pos_bol : int;
+    pos_cnum : int;
+  }
+
+  include (Lexing : module type of struct include Lexing end
+           with type position := position)
+
+  let move buf p =
+    buf.lex_abs_pos <- (p.pos_cnum - buf.lex_curr_pos);
+    buf.lex_curr_p <- p
+
+  let from_strings ?empty ?position source refill =
+    let pos = ref 0 in
+    let len = ref (String.length source) in
+    let source = ref source in
+    let lex_fun buf size =
+      let count = min (!len - !pos) size in
+      let count =
+        if count <= 0 then
+          begin
+            source := refill ();
+            len := String.length !source;
+            pos := 0;
+            min !len size
+          end
+        else count
+      in
+      if count <= 0 then 0
+      else begin
+          String.blit ~src:!source ~src_pos:!pos ~dst:buf ~dst_pos:0 ~len:count;
+          pos := !pos + count;
+          (match empty with None -> () | Some r -> r := !pos >= !len);
+          count
+        end
+    in
+    let buf = from_function lex_fun in
+    Option.iter ~f:(move buf) position;
+    buf
+
+  (* Manipulating position *)
+  let make_pos ?(pos_fname="") (pos_lnum, pos_cnum) =
+    { pos_fname ; pos_lnum ; pos_cnum ; pos_bol = 0 }
+
+  let column pos = pos.pos_cnum - pos.pos_bol
+
+  let set_column pos col = {pos with pos_cnum = pos.pos_bol + col}
+
+  let split_pos pos = (pos.pos_lnum, column pos)
+
+  let compare_pos p1 p2 =
+    match compare p1.pos_lnum p2.pos_lnum with
+    | 0 -> compare (column p1) (column p2)
+    | n -> n
+
+  let print_position () p =
+    let l1, c1 = split_pos p in
+    sprintf "%d:%d" l1 c1
+
+  (* Current position in lexer, even if the buffer is in the middle of a refill
+     operation *)
+  let immediate_pos buf =
+    {buf.lex_curr_p with pos_cnum = buf.lex_abs_pos + buf.lex_curr_pos}
+
+  let json_of_position pos =
+    let line, col = split_pos pos in
+    `Assoc ["line", `Int line; "col", `Int col]
+
+  let min_pos p1 p2 =
+    if compare_pos p1 p2 <= 0 then p1 else p2
+
+  let max_pos p1 p2 =
+    if compare_pos p1 p2 >= 0 then p1 else p2
+end
+
+module Char = struct
+
+  (* FIXME: Remove once we drop support for 4.02 and replace the calls to
+     [uppercase] and [lowercase] by their [_ascii] version. *)
+  [@@@ocaml.warning "-3"]
+
+  include Char
+  let is_lowercase c = lowercase c = c
+  let is_uppercase c = uppercase c = c
+  let is_strictly_lowercase c = not (is_uppercase c)
+  let is_strictly_uppercase c = not (is_lowercase c)
+end
+
+module Glob : sig
+  type pattern =
+    | Wildwild
+    | Exact of string
+    | Regexp of Str.regexp
+  val compile_pattern : string -> pattern
+  val match_pattern : pattern -> string -> bool
+end = struct
+  type pattern =
+    | Wildwild
+    | Exact of string
+    | Regexp of Str.regexp
+
+  let compile_pattern = function
+    | "**" -> Wildwild
+    | pattern ->
+      let regexp = Buffer.create 15 in
+      let chunk = Buffer.create 15 in
+      let flush () =
+        if Buffer.length chunk > 0 then (
+          Buffer.add_string regexp (Str.quote (Buffer.contents chunk));
+          Buffer.clear chunk;
+        )
+      in
+      let l = String.length pattern in
+      let i = ref 0 in
+      while !i < l do
+        begin match pattern.[!i] with
+          | '\\' -> incr i; if !i  < l then Buffer.add_char chunk pattern.[!i]
+          | '*' -> flush (); Buffer.add_string regexp ".*";
+          | '?' -> flush (); Buffer.add_char regexp '.';
+          | x -> Buffer.add_char chunk x
+        end;
+        incr i
+      done;
+      if Buffer.length regexp = 0 then
+        Exact (Buffer.contents chunk)
+      else (
+        flush ();
+        Buffer.add_char regexp '$';
+        Regexp (Str.regexp (Buffer.contents regexp))
+      )
+
+  let match_pattern re str =
+    match re with
+    | Wildwild -> true
+    | Regexp re -> Str.string_match re str 0
+    | Exact s -> s = str
+end
+
+let fprintf = Format.fprintf
+
+let lazy_eq a b =
+  match Lazy.is_val a, Lazy.is_val b with
+  | true, true -> Lazy.force_val a == Lazy.force_val b
+  | false, false -> a == b
+  | _ -> false
+
+let let_ref r v f =
+  let v' = !r in
+  r := v;
+  match f () with
+  | result -> r := v'; result
+  | exception exn -> r := v'; raise exn
+
+let failwithf fmt = Printf.ksprintf failwith fmt
+
+module Shell = struct
+  let split_command str =
+    let comps = ref [] in
+    let dirty = ref false in
+    let buf   = Buffer.create 16 in
+    let flush () =
+      if !dirty then (
+        comps := Buffer.contents buf :: !comps;
+        dirty := false;
+        Buffer.clear buf;
+      )
+    in
+    let i = ref 0 and len = String.length str in
+    let unescape = function
+      | 'n' -> '\n'
+      | 'r' -> '\r'
+      | 't' -> '\t'
+      |  x  -> x
+    in
+    while !i < len do
+      let c = str.[!i] in
+      incr i;
+      match c with
+      | ' ' | '\t' | '\n' | '\r' -> flush ()
+      | '\\' ->
+        dirty := true;
+        if !i < len then (
+          Buffer.add_char buf (unescape str.[!i]);
+          incr i
+        )
+      | '\'' ->
+        dirty := true;
+        while !i < len && str.[!i] <> '\'' do
+          Buffer.add_char buf str.[!i];
+          incr i;
+        done;
+        incr i
+      | '"' ->
+        dirty := true;
+        while !i < len && str.[!i] <> '"' do
+          (match str.[!i] with
+           | '\\' ->
+             incr i;
+             if !i < len then
+               Buffer.add_char buf (unescape str.[!i]);
+           | x -> Buffer.add_char buf x
+          );
+          incr i;
+        done;
+        incr i
+      | x ->
+        dirty := true;
+        Buffer.add_char buf x
+    done;
+    flush ();
+    List.rev !comps
+end
+
+  (* [modules_in_path ~ext path] lists ocaml modules corresponding to
+   * filenames with extension [ext] in given [path]es.
+   * For instance, if there is file "a.ml","a.mli","b.ml" in ".":
+   * - modules_in_path ~ext:".ml" ["."] returns ["A";"B"],
+   * - modules_in_path ~ext:".mli" ["."] returns ["A"] *)
+let modules_in_path ~ext path =
+  let seen = Hashtbl.create 7 in
+  List.fold_left ~init:[] path
+  ~f:begin fun results dir ->
+    try
+      Array.fold_left
+      begin fun results file ->
+        if Filename.check_suffix file ext
+        then let name = Filename.chop_extension file in
+             (if Hashtbl.mem seen name
+              then results
+              else
+               (Hashtbl.add seen name (); String.capitalize name :: results))
+        else results
+      end results (Sys.readdir dir)
+    with Sys_error _ -> results
+  end
+
+let file_contents filename =
+  let ic = open_in filename in
+  try
+    let str = Bytes.create 1024 in
+    let buf = Buffer.create 1024 in
+    let rec loop () =
+      match input ic str 0 1024 with
+      | 0 -> ()
+      | n ->
+        Buffer.add_subbytes buf str 0 n;
+        loop ()
+    in
+    loop ();
+    close_in_noerr ic;
+    Buffer.contents buf
+  with exn ->
+    close_in_noerr ic;
+    raise exn
+
+external reraise : exn -> 'a = "%reraise"
+
+type 'a with_workdir = {
+  workdir : string;
+  workval : 'a;
+}
+(** Some value that must be interpreted with respect to a specific work
+    directory. (e.g. for resolving relative paths or executing sub-commands *)
+
+let dump_with_workdir f x : json =
+  `Assoc [
+    "workdir", `String x.workdir;
+    "workval", f x.workval;
+  ]
diff --git a/tests/dune b/tests/dune
new file mode 100644
index 0000000..89fd061
--- /dev/null
+++ b/tests/dune
@@ -0,0 +1,13 @@
+(env (_
+ (binaries merlin-wrapper)
+ (env-vars
+  (MERLIN merlin-wrapper)
+  (OCAMLC ocamlc))))
+
+(cram
+ (applies_to :whole_subtree)
+ (package merlin)
+ (deps
+  %{bin:merlin-wrapper}
+  (package merlin)
+  (package dot-merlin-reader)))
diff --git a/tests/merlin-wrapper b/tests/merlin-wrapper
new file mode 100755
index 0000000..3f40e5e
--- /dev/null
+++ b/tests/merlin-wrapper
@@ -0,0 +1,15 @@
+#!/usr/bin/env bash
+
+export PATH=$(dirname dot-merlin-reader):$PATH
+
+# If no dune-project of .merlin file are present in the test we write a default
+# `.merlin` file to force the use of dot-merlin-reader
+if [ ! -f dune-project ]; then
+  touch .merlin
+fi
+
+ocamlmerlin "$@" \
+    | jq 'del(.timing)' \
+    | sed -e 's:"[^"]*lib/ocaml:"lib/ocaml:g' \
+    | sed -e 's:\\n:\
+:g'
diff --git a/tests/test-dirs/.merlin b/tests/test-dirs/.merlin
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tests/test-dirs/.merlin
diff --git a/tests/test-dirs/alerts.t/lib.mli b/tests/test-dirs/alerts.t/lib.mli
new file mode 100644
index 0000000..900b6b6
--- /dev/null
+++ b/tests/test-dirs/alerts.t/lib.mli
@@ -0,0 +1,2 @@
+val sqrt : float -> float
+[@@ocaml.deprecated "I am deprecated"]
diff --git a/tests/test-dirs/alerts.t/main.ml b/tests/test-dirs/alerts.t/main.ml
new file mode 100644
index 0000000..cfc28eb
--- /dev/null
+++ b/tests/test-dirs/alerts.t/main.ml
@@ -0,0 +1,2 @@
+open Lib
+let x = sqrt 3.
diff --git a/tests/test-dirs/alerts.t/run.t b/tests/test-dirs/alerts.t/run.t
new file mode 100644
index 0000000..5b2787d
--- /dev/null
+++ b/tests/test-dirs/alerts.t/run.t
@@ -0,0 +1,62 @@
+  $ echo "S .\nB .\nFLG -nopervasives" > .merlin
+  $ $OCAMLC -nopervasives -c -bin-annot lib.mli
+  $ $MERLIN single errors -filename main.ml < main.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 8
+        },
+        "end": {
+          "line": 2,
+          "col": 12
+        },
+        "type": "warning",
+        "sub": [],
+        "valid": true,
+        "message": "Alert deprecated: Lib.sqrt
+  I am deprecated"
+      }
+    ],
+    "notifications": []
+  }
+
+  $ cat > .merlin <<EOF
+  > S .
+  > B .
+  > FLG -nopervasives -alert -deprecated
+  > EOF
+
+  $ $MERLIN single errors -filename main.ml < main.ml
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
+
+  $ cat > .merlin <<EOF
+  > S .
+  > B .
+  > FLG -nopervasives -alert=-deprecated
+  > EOF
+
+  $ $MERLIN single errors -filename main.ml < main.ml
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
+
+The compiler accept both
+  $ $OCAMLC -c main.ml
+  File "main.ml", line 2, characters 8-12:
+  2 | let x = sqrt 3.
+              ^^^^
+  Alert deprecated: Lib.sqrt
+  I am deprecated
+
+  $ $OCAMLC -alert -deprecated -c main.ml
+
+  $ $OCAMLC -alert=-deprecated -c main.ml
diff --git a/tests/test-dirs/completion/application_context.t/application_context.ml b/tests/test-dirs/completion/application_context.t/application_context.ml
new file mode 100644
index 0000000..9c5a195
--- /dev/null
+++ b/tests/test-dirs/completion/application_context.t/application_context.ml
@@ -0,0 +1,3 @@
+let foo ~i ~j = i + j
+let bar = 10
+let y = foo ~i:5
diff --git a/tests/test-dirs/completion/application_context.t/run.t b/tests/test-dirs/completion/application_context.t/run.t
new file mode 100644
index 0000000..b0f41cc
--- /dev/null
+++ b/tests/test-dirs/completion/application_context.t/run.t
@@ -0,0 +1,15 @@
+  $ $MERLIN single complete-prefix -position 3:17 \
+  > -filename application_context < application_context.ml \
+  > | tr '\n' ' ' | jq ".value.context"
+  [
+    "application",
+    {
+      "argument_type": "'_weak1",
+      "labels": [
+        {
+          "name": "~j",
+          "type": "int"
+        }
+      ]
+    }
+  ]
diff --git a/tests/test-dirs/completion/disambiguation.t/constr.ml b/tests/test-dirs/completion/disambiguation.t/constr.ml
new file mode 100644
index 0000000..f409db9
--- /dev/null
+++ b/tests/test-dirs/completion/disambiguation.t/constr.ml
@@ -0,0 +1,5 @@
+module T = struct
+  type t = Foobar
+end
+
+let _foobar = (Foo : T.t)
diff --git a/tests/test-dirs/completion/disambiguation.t/record.ml b/tests/test-dirs/completion/disambiguation.t/record.ml
new file mode 100644
index 0000000..5ec2221
--- /dev/null
+++ b/tests/test-dirs/completion/disambiguation.t/record.ml
@@ -0,0 +1,11 @@
+module T = struct
+  type t = { foobar : int; test_other : float; }
+end
+
+let _easy = { T.f }
+
+let _hard = ({ foo } : T.t)
+
+open T
+
+let _easier = { foobar = 5; tes }
diff --git a/tests/test-dirs/completion/disambiguation.t/run.t b/tests/test-dirs/completion/disambiguation.t/run.t
new file mode 100644
index 0000000..5dac24e
--- /dev/null
+++ b/tests/test-dirs/completion/disambiguation.t/run.t
@@ -0,0 +1,82 @@
+Completing out-of-scope constructor names when the type information is
+available:
+
+  $ $MERLIN single complete-prefix -position 5:18 -prefix Foo -doc n \
+  > -filename constr.ml < constr.ml
+  {
+    "class": "return",
+    "value": {
+      "entries": [
+        {
+          "name": "Foobar",
+          "kind": "Constructor",
+          "desc": "T.t",
+          "info": "",
+          "deprecated": false
+        }
+      ],
+      "context": null
+    },
+    "notifications": []
+  }
+
+Try completing field names inside record expressions (where either the scope or
+the type should be known):
+
+  $ $MERLIN single complete-prefix -position 5:17 -prefix T.f -doc n \
+  > -filename record.ml < record.ml
+  {
+    "class": "return",
+    "value": {
+      "entries": [
+        {
+          "name": "foobar",
+          "kind": "Label",
+          "desc": "T.t -> int",
+          "info": "",
+          "deprecated": false
+        }
+      ],
+      "context": null
+    },
+    "notifications": []
+  }
+
+
+  $ $MERLIN single complete-prefix -position 7:18 -prefix foo -doc n \
+  > -filename record.ml < record.ml
+  {
+    "class": "return",
+    "value": {
+      "entries": [
+        {
+          "name": "foobar",
+          "kind": "Label",
+          "desc": "T.t -> int",
+          "info": "",
+          "deprecated": false
+        }
+      ],
+      "context": null
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single complete-prefix -position 11:31 -prefix tes -doc n \
+  > -filename record.ml < record.ml
+  {
+    "class": "return",
+    "value": {
+      "entries": [
+        {
+          "name": "test_other",
+          "kind": "Label",
+          "desc": "T.t -> float",
+          "info": "",
+          "deprecated": false
+        }
+      ],
+      "context": null
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/completion/expansion.t/expansion1.ml b/tests/test-dirs/completion/expansion.t/expansion1.ml
new file mode 100644
index 0000000..65236d5
--- /dev/null
+++ b/tests/test-dirs/completion/expansion.t/expansion1.ml
@@ -0,0 +1 @@
+let x = L.m
diff --git a/tests/test-dirs/completion/expansion.t/expansion2.ml b/tests/test-dirs/completion/expansion.t/expansion2.ml
new file mode 100644
index 0000000..e072fa9
--- /dev/null
+++ b/tests/test-dirs/completion/expansion.t/expansion2.ml
@@ -0,0 +1 @@
+let x = Lsi.m
diff --git a/tests/test-dirs/completion/expansion.t/run.t b/tests/test-dirs/completion/expansion.t/run.t
new file mode 100644
index 0000000..ebb3f5f
--- /dev/null
+++ b/tests/test-dirs/completion/expansion.t/run.t
@@ -0,0 +1,248 @@
+  $ $MERLIN single expand-prefix -position 1:11 -prefix L.m \
+  > -filename expansion.ml < expansion1.ml | jq ".value.entries | sort_by(.name)"
+  [
+    {
+      "name": "Lazy.map",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "Lazy.map_val",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "List.map",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "List.map2",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "List.mapi",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "List.mem",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "List.mem_assoc",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "List.mem_assq",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "List.memq",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "List.merge",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "ListLabels.map",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "ListLabels.map2",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "ListLabels.mapi",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "ListLabels.mem",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "ListLabels.mem_assoc",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "ListLabels.mem_assq",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "ListLabels.memq",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "ListLabels.merge",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    }
+  ]
+
+  $ $MERLIN single expand-prefix -position 1:13 -prefix Lsi.m \
+  > -filename expansion.ml < expansion2.ml | jq ".value.entries | sort_by(.name)"
+  [
+    {
+      "name": "List.map",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "List.map2",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "List.mapi",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "List.mem",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "List.mem_assoc",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "List.mem_assq",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "List.memq",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "List.merge",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "ListLabels.map",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "ListLabels.map2",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "ListLabels.mapi",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "ListLabels.mem",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "ListLabels.mem_assoc",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "ListLabels.mem_assq",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "ListLabels.memq",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "ListLabels.merge",
+      "kind": "Value",
+      "desc": "",
+      "info": "",
+      "deprecated": false
+    }
+  ]
+
diff --git a/tests/test-dirs/completion/infix.t/infix.ml b/tests/test-dirs/completion/infix.t/infix.ml
new file mode 100644
index 0000000..3f0fdac
--- /dev/null
+++ b/tests/test-dirs/completion/infix.t/infix.ml
@@ -0,0 +1,9 @@
+module Z = struct
+  let (>>) = 0
+  let (|+) = 0
+  let (|-) = 0
+  let (>>=) = 0
+  let (>>|) = 0
+end
+
+let _ = Z.
diff --git a/tests/test-dirs/completion/infix.t/run.t b/tests/test-dirs/completion/infix.t/run.t
new file mode 100644
index 0000000..da3941a
--- /dev/null
+++ b/tests/test-dirs/completion/infix.t/run.t
@@ -0,0 +1,39 @@
+  $ $MERLIN single complete-prefix -position 11:10 -prefix "Z." \
+  > -filename infix.ml < infix.ml | jq ".value.entries | sort_by(.name)"
+  [
+    {
+      "name": "(>>)",
+      "kind": "Value",
+      "desc": "int",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "(>>=)",
+      "kind": "Value",
+      "desc": "int",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "(>>|)",
+      "kind": "Value",
+      "desc": "int",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "(|+)",
+      "kind": "Value",
+      "desc": "int",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "(|-)",
+      "kind": "Value",
+      "desc": "int",
+      "info": "",
+      "deprecated": false
+    }
+  ]
diff --git a/tests/test-dirs/completion/kind.t/run.t b/tests/test-dirs/completion/kind.t/run.t
new file mode 100644
index 0000000..d6aefec
--- /dev/null
+++ b/tests/test-dirs/completion/kind.t/run.t
@@ -0,0 +1,60 @@
+Default completion:
+
+  $ $MERLIN single complete-prefix -position 3:10 -filename test.ml \
+  > -prefix fu < test.ml| jq ".value.entries[].name"
+  "funnyny"
+
+Keywords only:
+
+  $ $MERLIN single complete-prefix -position 3:10 -filename test.ml \
+  > -kind k -prefix fu < test.ml| jq ".value.entries[].name"
+  "function"
+  "fun"
+  "functor"
+
+Keywords and values:
+
+  $ $MERLIN single complete-prefix -position 3:10 -filename test.ml \
+  > -kind keyword -kind value -prefix fu < test.ml| jq ".value.entries[].name"
+  "funnyny"
+  "function"
+  "fun"
+  "functor"
+
+Keywords only including extension:
+
+  $ echo "f" | $MERLIN single complete-prefix -position 1:2 -filename test.ml \
+  > -kind k -prefix f -extension lwt | jq ".value.entries[].name"
+  "finally"
+  "for_lwt"
+  "function"
+  "false"
+  "fun"
+  "for"
+  "functor"
+
+And let's also make sure we don't offer keywords when we completing under a
+certain path
+
+  $ $MERLIN single complete-prefix -position 5:14 -filename test.ml \
+  > -prefix List.f < test.ml| jq ".value.entries[].name"
+  "fast_sort"
+  "filter"
+  "filter_map"
+  "filteri"
+  "find"
+  "find_all"
+  "find_map"
+  "find_opt"
+  "flatten"
+  "fold_left"
+  "fold_left2"
+  "fold_left_map"
+  "fold_right"
+  "fold_right2"
+  "for_all"
+  "for_all2"
+
+  $ $MERLIN single complete-prefix -position 5:14 -filename test.ml \
+  > -kind k -prefix List.f < test.ml| jq ".value.entries"
+  []
diff --git a/tests/test-dirs/completion/kind.t/test.ml b/tests/test-dirs/completion/kind.t/test.ml
new file mode 100644
index 0000000..648b1c9
--- /dev/null
+++ b/tests/test-dirs/completion/kind.t/test.ml
@@ -0,0 +1,5 @@
+let funnyny = fun ny -> ny
+
+let _ = fu
+
+let _ = List.f
diff --git a/tests/test-dirs/completion/parenthesize.t/parenthesize.ml b/tests/test-dirs/completion/parenthesize.t/parenthesize.ml
new file mode 100644
index 0000000..4cba3bf
--- /dev/null
+++ b/tests/test-dirs/completion/parenthesize.t/parenthesize.ml
@@ -0,0 +1,11 @@
+module MyList = struct
+  [@@@ocaml.warning "-65"]
+  type 'a t =
+    | (::) of 'a * 'a t
+    | []
+  type u = ()
+  let (mod) = ()
+  let random = 1
+end
+
+let _ = MyList.
diff --git a/tests/test-dirs/completion/parenthesize.t/run.t b/tests/test-dirs/completion/parenthesize.t/run.t
new file mode 100644
index 0000000..ddb30c0
--- /dev/null
+++ b/tests/test-dirs/completion/parenthesize.t/run.t
@@ -0,0 +1,53 @@
+  $ $MERLIN single complete-prefix -position 11:15 -prefix MyList. \
+  > -filename parenthesize.ml < parenthesize.ml | jq ".value.entries | sort_by(.name)"
+  [
+    {
+      "name": "(())",
+      "kind": "Constructor",
+      "desc": "MyList.u",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "(::)",
+      "kind": "Constructor",
+      "desc": "'a * 'a MyList.t -> 'a MyList.t",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "([])",
+      "kind": "Constructor",
+      "desc": "'a MyList.t",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "(mod)",
+      "kind": "Value",
+      "desc": "MyList.u",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "random",
+      "kind": "Value",
+      "desc": "int",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "t",
+      "kind": "Type",
+      "desc": "type 'a t = (::) of 'a * 'a MyList.t | []",
+      "info": "",
+      "deprecated": false
+    },
+    {
+      "name": "u",
+      "kind": "Type",
+      "desc": "type u = ()",
+      "info": "",
+      "deprecated": false
+    }
+  ]
diff --git a/tests/test-dirs/config/check/check-config.t b/tests/test-dirs/config/check/check-config.t
new file mode 100644
index 0000000..12c6fe4
--- /dev/null
+++ b/tests/test-dirs/config/check/check-config.t
@@ -0,0 +1,17 @@
+Create a .merlin:
+
+  $ cat > .merlin <<EOF
+  > S ../../../../src/frontend
+  > EOF
+
+  $ echo | $MERLIN single check-configuration -filename test.ml
+  {
+    "class": "return",
+    "value": {
+      "dot_merlins": [
+        "$TESTCASE_ROOT/.merlin"
+      ],
+      "failures": []
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/config/check/dune b/tests/test-dirs/config/check/dune
new file mode 100755
index 0000000..eae5ad8
--- /dev/null
+++ b/tests/test-dirs/config/check/dune
@@ -0,0 +1,4 @@
+(cram
+ (applies_to check-config)
+ (enabled_if
+  (<> %{os_type} Win32)))
diff --git a/tests/test-dirs/config/dot-merlin-reader/dune b/tests/test-dirs/config/dot-merlin-reader/dune
new file mode 100755
index 0000000..ab289b6
--- /dev/null
+++ b/tests/test-dirs/config/dot-merlin-reader/dune
@@ -0,0 +1,4 @@
+(cram
+ (applies_to erroneous-config quoting)
+ (enabled_if
+  (<> %{os_type} Win32)))
diff --git a/tests/test-dirs/config/dot-merlin-reader/erroneous-config.t b/tests/test-dirs/config/dot-merlin-reader/erroneous-config.t
new file mode 100644
index 0000000..300ff5f
--- /dev/null
+++ b/tests/test-dirs/config/dot-merlin-reader/erroneous-config.t
@@ -0,0 +1,43 @@
+Create a broke .merlin:
+
+  $ cat > .merlin <<EOF
+  > FLG -principal
+  > PKG does-not-exist
+  > # some comment
+  > EOF
+
+And look at merlin's config:
+
+  $ echo | $MERLIN single dump-configuration -filename test.ml | \
+  > jq ".value.merlin | {flags_applied: .flags_applied, failures: .failures}"
+  {
+    "flags_applied": [
+      {
+        "workdir": "$TESTCASE_ROOT",
+        "workval": [
+          "-principal"
+        ]
+      }
+    ],
+    "failures": [
+      "Failed to load packages: does-not-exist"
+    ]
+  }
+
+Also, see that the failure is reported to the user:
+
+  $ echo | $MERLIN single errors -filename test.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "type": "config",
+        "sub": [],
+        "valid": true,
+        "message": "Failed to load packages: does-not-exist"
+      }
+    ],
+    "notifications": []
+  }
+
+  $ rm .merlin
diff --git a/tests/test-dirs/config/dot-merlin-reader/quoting.t b/tests/test-dirs/config/dot-merlin-reader/quoting.t
new file mode 100644
index 0000000..a936308
--- /dev/null
+++ b/tests/test-dirs/config/dot-merlin-reader/quoting.t
@@ -0,0 +1,72 @@
+  $ cat > .merlin <<EOF
+  > EXCLUDE_QUERY_DIR
+  > FLG -pp 'I/definitly/need/quoting.exe -nothing'
+  > FLG -ppx '/path/to/ppx.exe --as-ppx --cookie '\\''library-name="model"'\\'''
+  > FLG -w @3
+  > EOF
+
+  $ FILE=$(pwd)/test.ml; dot-merlin-reader <<EOF | sed 's#[0-9]*:#?:#g'
+  > (4:File${#FILE}:$FILE)
+  > EOF
+  ((?:EXCLUDE_QUERY_DIR)(?:FLG(?:-pp?:I/definitly/need/quoting.exe -nothing))(?:FLG(?:-ppx?:/path/to/ppx.exe --as-ppx --cookie 'library-name="model"'))(?:FLG(?:-w?:@3)))
+
+  $ echo | $MERLIN single dump-configuration -filename test.ml 2> /dev/null | jq '.value.merlin'
+  {
+    "build_path": [],
+    "source_path": [],
+    "cmi_path": [],
+    "cmt_path": [],
+    "flags_applied": [
+      {
+        "workdir": "$TESTCASE_ROOT",
+        "workval": [
+          "-pp",
+          "I/definitly/need/quoting.exe -nothing"
+        ]
+      },
+      {
+        "workdir": "$TESTCASE_ROOT",
+        "workval": [
+          "-ppx",
+          "/path/to/ppx.exe --as-ppx --cookie 'library-name=\"model\"'"
+        ]
+      },
+      {
+        "workdir": "$TESTCASE_ROOT",
+        "workval": [
+          "-w",
+          "@3"
+        ]
+      }
+    ],
+    "extensions": [],
+    "suffixes": [
+      {
+        "impl": ".ml",
+        "intf": ".mli"
+      },
+      {
+        "impl": ".re",
+        "intf": ".rei"
+      }
+    ],
+    "stdlib": null,
+    "reader": [],
+    "protocol": "json",
+    "log_file": null,
+    "log_sections": [],
+    "flags_to_apply": [],
+    "failures": [],
+    "assoc_suffixes": [
+      {
+        "extension": ".re",
+        "reader": "reason"
+      },
+      {
+        "extension": ".rei",
+        "reader": "reason"
+      }
+    ]
+  }
+
+  $ rm .merlin
diff --git a/tests/test-dirs/config/dune b/tests/test-dirs/config/dune
new file mode 100755
index 0000000..3afbf37
--- /dev/null
+++ b/tests/test-dirs/config/dune
@@ -0,0 +1,8 @@
+(cram
+ (applies_to path-expansion)
+ (enabled_if
+  (<> %{os_type} Win32)))
+
+(cram
+ (applies_to symlinks workdir)
+ (enabled_if false))
diff --git a/tests/test-dirs/config/flags/dune b/tests/test-dirs/config/flags/dune
new file mode 100755
index 0000000..30d4100
--- /dev/null
+++ b/tests/test-dirs/config/flags/dune
@@ -0,0 +1,4 @@
+(cram
+ (applies_to invalid)
+ (enabled_if
+  (<> %{os_type} Win32)))
diff --git a/tests/test-dirs/config/flags/invalid.t b/tests/test-dirs/config/flags/invalid.t
new file mode 100644
index 0000000..f7a7bd6
--- /dev/null
+++ b/tests/test-dirs/config/flags/invalid.t
@@ -0,0 +1,13 @@
+  $ echo | $MERLIN single check-configuration -filename invalid_flag.ml -lalala
+  {
+    "class": "return",
+    "value": {
+      "dot_merlins": [
+        "$TESTCASE_ROOT/.merlin"
+      ],
+      "failures": [
+        "unknown flag -lalala"
+      ]
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/config/flags/nolabels.t b/tests/test-dirs/config/flags/nolabels.t
new file mode 100644
index 0000000..aff3a9f
--- /dev/null
+++ b/tests/test-dirs/config/flags/nolabels.t
@@ -0,0 +1,34 @@
+classic and labels
+
+  $ $MERLIN single errors -filename labels_ok_1.ml <<EOF
+  > let f ~x = () in f ~x:(); f ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 26
+        },
+        "end": {
+          "line": 1,
+          "col": 27
+        },
+        "type": "warning",
+        "sub": [],
+        "valid": true,
+        "message": "Warning 6: label x was omitted in the application of this function."
+      }
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single errors -filename labels_ko_1.ml -nolabels <<EOF
+  > let f ~x = () in f ~x:(); f ()
+  > EOF
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/config/flags/unsafe.t b/tests/test-dirs/config/flags/unsafe.t
new file mode 100644
index 0000000..60579f5
--- /dev/null
+++ b/tests/test-dirs/config/flags/unsafe.t
@@ -0,0 +1,89 @@
+Testing array desugaring
+
+  $ $MERLIN single errors -filename array_good.ml <<EOF
+  > let x = [|0|].(0)
+  > EOF
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
+
+  $ $MERLIN single errors -filename array_bad.ml <<EOF
+  > module Array = struct end
+  > let x = [|0|].(0)
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 8
+        },
+        "end": {
+          "line": 2,
+          "col": 17
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Unbound value Array.get"
+      }
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single errors -filename array_fake_good.ml <<EOF
+  > module Array = struct let get _ _ = () end
+  > let x = [|0|].(0)
+  > EOF
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
+
+  $ $MERLIN single errors -filename unsafe_array_good.ml -unsafe <<EOF
+  > let x = [|0|].(0)
+  > EOF
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
+
+  $ $MERLIN single errors -filename unsafe_array_bad.ml -unsafe <<EOF
+  > module Array = struct end
+  > let x = [|0|].(0)
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 8
+        },
+        "end": {
+          "line": 2,
+          "col": 17
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Unbound value Array.unsafe_get"
+      }
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single errors -filename unsafe_array_fake_good.ml -unsafe <<EOF
+  > module Array = struct let unsafe_get _ _ = () end
+  > let x = [|0|].(0)
+  > EOF
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/config/path-expansion.t/run.t b/tests/test-dirs/config/path-expansion.t/run.t
new file mode 100644
index 0000000..f78c967
--- /dev/null
+++ b/tests/test-dirs/config/path-expansion.t/run.t
@@ -0,0 +1,35 @@
+A simple name is not expanded
+
+  $ echo | $MERLIN single dump-configuration -filename relative_path.ml -ppx test1 \
+  > 2> /dev/null | \
+  > jq '.value.ocaml.ppx'
+  [
+    {
+      "workdir": "$TESTCASE_ROOT",
+      "workval": "test1"
+    }
+  ]
+
+Neither is an absolute path
+
+  $ echo | $MERLIN single dump-configuration -filename relative_path.ml -ppx /test2 \
+  > 2> /dev/null | \
+  > jq '.value.ocaml.ppx'
+  [
+    {
+      "workdir": "$TESTCASE_ROOT",
+      "workval": "/test2"
+    }
+  ]
+
+But relative names are
+
+  $ echo | $MERLIN single dump-configuration -filename relative_path.ml -ppx ./test3 \
+  > 2> /dev/null | \
+  > jq '.value.ocaml.ppx'
+  [
+    {
+      "workdir": "$TESTCASE_ROOT",
+      "workval": "./test3"
+    }
+  ]
diff --git a/tests/test-dirs/config/symlinks.t/real/main.ml b/tests/test-dirs/config/symlinks.t/real/main.ml
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tests/test-dirs/config/symlinks.t/real/main.ml
diff --git a/tests/test-dirs/config/symlinks.t/run.t b/tests/test-dirs/config/symlinks.t/run.t
new file mode 100644
index 0000000..28546aa
--- /dev/null
+++ b/tests/test-dirs/config/symlinks.t/run.t
@@ -0,0 +1,62 @@
+  $ ROOT_DIR=$(pwd)
+
+  $ cat >real/dune-project <<EOF
+  > (lang dune 2.7)
+  > EOF
+
+We work in a directory which is a symlink to another
+  $ ln -s real link
+  $ cd link
+
+We need to set the MERLIN_LOG env variable for Merlin to log events prior
+to the reading of the configuration.
+  $ export MERLIN_LOG=-
+
+Merlin should first try a path relative to where `dune ocaml-merlin` was
+started and then an absolute path which may or may not include the symlink
+  $ ocamlmerlin single dump-configuration -filename main.ml < main.ml \
+  >  -log-section Mconfig -log-file - 2>&1 |
+  > grep "Querying dune" |
+  > sed s,/real,/real_or_link,g | sed s,/link,/real_or_link,g
+  Querying dune (inital cwd: $TESTCASE_ROOT/real_or_link) for file: main.ml.
+  Querying dune (inital cwd: $TESTCASE_ROOT/real_or_link) for file: $TESTCASE_ROOT/real_or_link/main.ml.
+
+However editors will use absolute path to the file which may (or may not ?)
+include the symlinks:
+  $ ocamlmerlin single dump-configuration -filename $ROOT_DIR/real/main.ml < main.ml \
+  >  -log-section Mconfig -log-file - 2>&1 |
+  > grep "Querying dune" |
+  > sed s,/real,/real_or_link,g | sed s,/link,/real_or_link,g
+  Querying dune (inital cwd: $TESTCASE_ROOT/real_or_link) for file: main.ml.
+  Querying dune (inital cwd: $TESTCASE_ROOT/real_or_link) for file: $TESTCASE_ROOT/real_or_link/main.ml.
+
+  $ ocamlmerlin single dump-configuration -filename $ROOT_DIR/link/main.ml < main.ml \
+  >  -log-section Mconfig -log-file - 2>&1 |
+  > grep "Querying dune" |
+  > sed s,/real,/real_or_link,g | sed s,/link,/real_or_link,g
+  Querying dune (inital cwd: $TESTCASE_ROOT/real_or_link) for file: main.ml.
+  Querying dune (inital cwd: $TESTCASE_ROOT/real_or_link) for file: $TESTCASE_ROOT/real_or_link/main.ml.
+
+And we perform the same testing when Merlin is started from the "real" dir
+  $ cd ../real
+
+  $ ocamlmerlin single dump-configuration -filename main.ml < main.ml \
+  >  -log-section Mconfig -log-file - 2>&1 |
+  > grep "Querying dune" |
+  > sed s,/real,/real_or_link,g | sed s,/link,/real_or_link,g
+  Querying dune (inital cwd: $TESTCASE_ROOT/real_or_link) for file: main.ml.
+  Querying dune (inital cwd: $TESTCASE_ROOT/real_or_link) for file: $TESTCASE_ROOT/real_or_link/main.ml.
+
+  $ ocamlmerlin single dump-configuration -filename $ROOT_DIR/real/main.ml < main.ml \
+  >  -log-section Mconfig -log-file - 2>&1 |
+  > grep "Querying dune" |
+  > sed s,/real,/real_or_link,g | sed s,/link,/real_or_link,g
+  Querying dune (inital cwd: $TESTCASE_ROOT/real_or_link) for file: main.ml.
+  Querying dune (inital cwd: $TESTCASE_ROOT/real_or_link) for file: $TESTCASE_ROOT/real_or_link/main.ml.
+
+  $ ocamlmerlin single dump-configuration -filename $ROOT_DIR/link/main.ml < main.ml \
+  >  -log-section Mconfig -log-file - 2>&1 |
+  > grep "Querying dune" |
+  > sed s,/real,/real_or_link,g | sed s,/link,/real_or_link,g
+  Querying dune (inital cwd: $TESTCASE_ROOT/real_or_link) for file: main.ml.
+  Querying dune (inital cwd: $TESTCASE_ROOT/real_or_link) for file: $TESTCASE_ROOT/real_or_link/main.ml.
diff --git a/tests/test-dirs/config/unknown_tag.t b/tests/test-dirs/config/unknown_tag.t
new file mode 100644
index 0000000..258d8bb
--- /dev/null
+++ b/tests/test-dirs/config/unknown_tag.t
@@ -0,0 +1,20 @@
+  $ cat >.merlin <<EOF
+  > B foobar_dir
+  > FOOBAR bar
+  > EOF
+
+  $ $MERLIN single errors -filename test.ml <<EOF
+  > let x = 2
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "type": "config",
+        "sub": [],
+        "valid": true,
+        "message": "Unknown tag in .merlin: FOOBAR"
+      }
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/config/workdir.t/run.t b/tests/test-dirs/config/workdir.t/run.t
new file mode 100644
index 0000000..662ebb8
--- /dev/null
+++ b/tests/test-dirs/config/workdir.t/run.t
@@ -0,0 +1,43 @@
+We need to set the MERLIN_LOG env variable for Merlin to log events prior
+to the reading of the configuration.
+  $ export MERLIN_LOG=-
+
+  $ cat >dune-project <<EOF
+  > (lang dune 2.7)
+  > EOF
+
+  $ cat >src/dune <<EOF
+  > (executable
+  >  (name main))
+  > EOF
+
+% We check that:
+%   workdir = $TESTCASE_ROOT/src
+%   startdir = $TESTCASE_ROOT
+%  (because the project is not built dune fails to find a configuration
+%  and Merlin retries with an absolute path)
+  $ ocamlmerlin single dump-configuration -log-section Mconfig_dot -filename src/main.ml < src/main.ml 2>&1 >/dev/null |
+  > sed -e 's,^# [0-9].[0-9][0-9],#,g'
+  # New_merlin - run
+  No working directory specified
+  # Mconfig_dot - get_config
+  Starting dune configuration provider from dir $TESTCASE_ROOT.
+  # Mconfig_dot - get_config
+  Querying dune (inital cwd: $TESTCASE_ROOT) for file: src/main.ml.
+  Workdir: $TESTCASE_ROOT/src
+  # Mconfig_dot - get_config
+  Querying dune (inital cwd: $TESTCASE_ROOT) for file: $TESTCASE_ROOT/src/main.ml.
+  Workdir: $TESTCASE_ROOT/src
+
+% Same for dot-merlin-reader except here the workdir and the starting dir should
+be the same ($TESTCASE_ROOT/src)
+  $ touch src/.merlin
+  $ ocamlmerlin single dump-configuration -log-section Mconfig_dot -filename src/main.ml < src/main.ml 2>&1 >/dev/null |
+  > sed -e 's,^# [0-9].[0-9][0-9],#,g'
+  # New_merlin - run
+  No working directory specified
+  # Mconfig_dot - get_config
+  Starting dot-merlin-reader configuration provider from dir $TESTCASE_ROOT/src.
+  # Mconfig_dot - get_config
+  Querying dot-merlin-reader (inital cwd: $TESTCASE_ROOT/src) for file: $TESTCASE_ROOT/src/main.ml.
+  Workdir: $TESTCASE_ROOT/src
diff --git a/tests/test-dirs/config/workdir.t/src/main.ml b/tests/test-dirs/config/workdir.t/src/main.ml
new file mode 100644
index 0000000..953a3f5
--- /dev/null
+++ b/tests/test-dirs/config/workdir.t/src/main.ml
@@ -0,0 +1 @@
+print_string "foobar"
diff --git a/tests/test-dirs/construct/c-depth.t b/tests/test-dirs/construct/c-depth.t
new file mode 100644
index 0000000..1eb0597
--- /dev/null
+++ b/tests/test-dirs/construct/c-depth.t
@@ -0,0 +1,99 @@
+  $ cat >d1.ml <<EOF
+  > let x : int option option = _
+  > EOF
+
+Test 1.1
+  $ $MERLIN single construct -depth 1 -position 1:28 -filename d1.ml <d1.ml |
+  >  jq ".value[1]"
+  [
+    "(Some _)",
+    "None"
+  ]
+
+Test 1.2
+  $ $MERLIN single construct -depth 2 -position 1:28 -filename d1.ml <d1.ml |
+  >  jq ".value[1]"
+  [
+    "(Some (Some _))",
+    "None",
+    "(Some None)"
+  ]
+
+Test 1.3
+  $ $MERLIN single construct -depth 3 -position 1:28 -filename d1.ml <d1.ml |
+  >  jq ".value[1]"
+  [
+    "(Some (Some 0))",
+    "None",
+    "(Some None)"
+  ]
+
+Test 1.4
+  $ $MERLIN single construct -depth 4 -position 1:28 -filename d1.ml <d1.ml |
+  >  jq ".value[1]"
+  [
+    "(Some (Some 0))",
+    "None",
+    "(Some None)"
+  ]
+
+  $ cat >d2.ml <<EOF
+  > type t = { a : int option option; b : float option }
+  > let x : t = _
+  > EOF
+
+Test 2.1
+  $ $MERLIN single construct -depth 1 -position 2:12 -filename d2.ml <d2.ml |
+  >  jq ".value[1]"
+  [
+    "{ a = _; b = _ }"
+  ]
+
+Test 2.2
+  $ $MERLIN single construct -depth 2 -position 2:12 -filename d2.ml <d2.ml |
+  >  jq ".value[1]"
+  [
+    "{ a = None; b = (Some _) }",
+    "{ a = (Some _); b = (Some _) }",
+    "{ a = (Some _); b = None }",
+    "{ a = None; b = None }"
+  ]
+
+Test 2.3
+  $ $MERLIN single construct -depth 3 -position 2:12 -filename d2.ml <d2.ml |
+  >  jq ".value[1]"
+  [
+    "{ a = (Some None); b = (Some 0.0) }",
+    "{ a = (Some (Some _)); b = (Some 0.0) }",
+    "{ a = None; b = (Some 0.0) }",
+    "{ a = None; b = None }",
+    "{ a = (Some (Some _)); b = None }",
+    "{ a = (Some None); b = None }"
+  ]
+
+Test 2.4
+  $ $MERLIN single construct -depth 4 -position 2:12 -filename d2.ml <d2.ml |
+  >  jq ".value[1]"
+  [
+    "{ a = (Some None); b = (Some 0.0) }",
+    "{ a = (Some (Some 0)); b = (Some 0.0) }",
+    "{ a = None; b = (Some 0.0) }",
+    "{ a = None; b = None }",
+    "{ a = (Some (Some 0)); b = None }",
+    "{ a = (Some None); b = None }"
+  ]
+
+  $ cat >d3.ml <<EOF
+  > type t = int option option * float option
+  > let x : t = _
+  > EOF
+
+Test 3.1
+  $ $MERLIN single construct -depth 2 -position 2:12 -filename d3.ml <d3.ml |
+  >  jq ".value[1]"
+  [
+    "(None, (Some _))",
+    "((Some _), (Some _))",
+    "((Some _), None)",
+    "(None, None)"
+  ]
diff --git a/tests/test-dirs/construct/c-errors.t b/tests/test-dirs/construct/c-errors.t
new file mode 100644
index 0000000..6d7069b
--- /dev/null
+++ b/tests/test-dirs/construct/c-errors.t
@@ -0,0 +1,59 @@
+  $ $MERLIN single construct -position 2:25 \
+  > -filename e1.ml <<EOF
+  > EOF
+  {
+    "class": "error",
+    "value": "Construct only works on holes.",
+    "notifications": []
+  }
+
+  $ $MERLIN single construct -position 1:15 \
+  > -filename e1.ml <<EOF
+  > let x : int =
+  > EOF
+  {
+    "class": "error",
+    "value": "Construct only works on holes.",
+    "notifications": []
+  }
+
+  $ $MERLIN single construct -position 1:5 \
+  > -filename e1.ml <<EOF
+  > let _ = 3
+  > EOF
+  {
+    "class": "error",
+    "value": "Construct only works on holes.",
+    "notifications": []
+  }
+
+  $ $MERLIN single construct -position 2:16 \
+  > -filename e1.ml <<EOF
+  > module M = N module type S = module type of M
+  > module M : S = _
+  > EOF
+  {
+    "class": "error",
+    "value": "Module not found: N",
+    "notifications": []
+  }
+
+  $ $MERLIN single construct -position 1:15 \
+  > -filename e1.ml <<EOF
+  > module M : S = _
+  > EOF
+  {
+    "class": "error",
+    "value": "Could not find a module type to construct from. Check that you used a correct constraint.",
+    "notifications": []
+  }
+
+  $ $MERLIN single construct -position 1:12 \
+  > -filename e1.ml <<EOF
+  > module M = _
+  > EOF
+  {
+    "class": "error",
+    "value": "Could not find a module type to construct from. Check that you used a correct constraint.",
+    "notifications": []
+  }
diff --git a/tests/test-dirs/construct/c-fun.t b/tests/test-dirs/construct/c-fun.t
new file mode 100644
index 0000000..a26dced
--- /dev/null
+++ b/tests/test-dirs/construct/c-fun.t
@@ -0,0 +1,91 @@
+Test 1
+  $ cat >fun1.ml <<EOF
+  > module Mymod = struct type the_type = int end
+  > type the_type = float
+  > let x : Mymod.the_type -> the_type -> unit =
+  >   _
+  > EOF
+
+  $ $MERLIN single construct -position 4:2 \
+  > -filename fun1.ml <fun1.ml | jq ".value"
+  [
+    {
+      "start": {
+        "line": 4,
+        "col": 2
+      },
+      "end": {
+        "line": 4,
+        "col": 3
+      }
+    },
+    [
+      "(fun the_type the_type_1 -> _)"
+    ]
+  ]
+
+Test 2
+  $ cat >fun2.ml <<EOF
+  > module Mymod = struct type int = string end
+  > type int = float
+  > let x : Mymod.int -> int -> unit =
+  >   _
+  > EOF
+
+  $ $MERLIN single construct -position 4:2 \
+  > -filename fun2.ml <fun2.ml | jq ".value"
+  [
+    {
+      "start": {
+        "line": 4,
+        "col": 2
+      },
+      "end": {
+        "line": 4,
+        "col": 3
+      }
+    },
+    [
+      "(fun int int_1 -> _)"
+    ]
+  ]
+
+Test 3
+  $ cat >fun3.ml <<EOF
+  > module Mymod : 
+  >  sig type t val x : t val f : int -> t end =
+  >  struct type t = int let x = 3 let f x = 2 * x end
+  > type t = float
+  > let g x = 2 *. x 
+  > let x : Mymod.t = 3
+  > let z : Mymod.t =
+  >   _
+  > let t : t =
+  >   _
+  > EOF
+
+Here nothing is expected as t is abstract
+  $ $MERLIN single construct -position 8:2 \
+  > -filename fun3.ml <fun3.ml | jq ".value[1]"
+  []
+
+  $ $MERLIN single construct -position 8:2 -with-values local \
+  > -filename fun3.ml <fun3.ml | jq ".value[1]"
+  [
+    "x",
+    "(Mymod.f _)",
+    "Mymod.x"
+  ]
+
+  $ $MERLIN single construct -position 10:2 \
+  > -filename fun3.ml <fun3.ml | jq ".value[1]"
+  [
+    "0.0"
+  ]
+
+  $ $MERLIN single construct -position 10:2 -with-values local \
+  > -filename fun3.ml <fun3.ml | jq ".value[1]"
+  [
+    "0.0",
+    "(g _)"
+  ]
diff --git a/tests/test-dirs/construct/c-modules.t/functor_app.ml b/tests/test-dirs/construct/c-modules.t/functor_app.ml
new file mode 100644
index 0000000..c0c473a
--- /dev/null
+++ b/tests/test-dirs/construct/c-modules.t/functor_app.ml
@@ -0,0 +1,7 @@
+module type X_int = sig val x : int end
+
+module Increment (M : X_int) = struct
+  let x = M.x + 1
+end
+
+module X = Increment(_);;
diff --git a/tests/test-dirs/construct/c-modules.t/module.ml b/tests/test-dirs/construct/c-modules.t/module.ml
new file mode 100644
index 0000000..d5a95e9
--- /dev/null
+++ b/tests/test-dirs/construct/c-modules.t/module.ml
@@ -0,0 +1,44 @@
+module type S = sig
+  type t = private b and b = A | B of t
+  type (-'a, +'b) t' = T of ('a -> 'b)
+  type t2 = A | B of string | C of t
+  type nonrec r = { lbl1 : t; lbl2 : float list}
+  type nonrec n = r and m = float
+  type t_ext = ..
+  type t_ext += Str of string | A
+  type v = [`A of t_ext]
+
+  val i : int
+  val f : t -> int
+
+  module Sub : sig
+    val y : int
+  end
+
+  class type room = object
+    val mutable gene : unit
+
+    method scientific : unit -> int
+  end
+  class croom : room
+  module type Another = sig val i : int end
+
+  module type Sig = sig
+    type t and b
+    val f : int -> float
+    module type STyp = sig end
+    module D : Another
+  end
+
+  module Submod : Sig
+
+  module SubFunc (M : Sig) : sig val g : unit end
+end
+
+module type Small = sig type t = int end
+
+module M : S = _
+
+let m : (module Small) = _
+
+let m = (module _ : Small)
diff --git a/tests/test-dirs/construct/c-modules.t/run.t b/tests/test-dirs/construct/c-modules.t/run.t
new file mode 100644
index 0000000..c72e028
--- /dev/null
+++ b/tests/test-dirs/construct/c-modules.t/run.t
@@ -0,0 +1,135 @@
+Simple module construction
+  $ $MERLIN single construct -position 40:16 \
+  > -filename module.ml <module.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 40,
+          "col": 15
+        },
+        "end": {
+          "line": 40,
+          "col": 16
+        }
+      },
+      [
+        "struct
+    type t = private b
+    and b =
+      | A 
+      | B of t 
+    type (-!'a, +!'b) t' =
+      | T of ('a -> 'b) 
+    type t2 =
+      | A 
+      | B of string 
+      | C of t 
+    type nonrec r = {
+      lbl1: t ;
+      lbl2: float list }
+    type nonrec n = r
+    and m = float
+    type t_ext = ..
+    type t_ext +=  
+      | Str of string 
+    type t_ext +=  
+      | A 
+    type v = [ `A of t_ext ]
+    let i = _
+    let f = _
+    module Sub = struct let y = _ end
+    [@@@ocaml.text
+      \"Construct does not handle class types yet. Please replace this comment by [room]'s definition.\"]
+    [@@@ocaml.text
+      \"Construct does not handle classes yet. Please replace this comment by [croom]'s definition.\"]
+    module type Another  = sig val i : int end
+    module type Sig  =
+      sig
+        type t
+        and b
+        val f : int -> float
+        module type STyp  = sig  end
+        module D : Another
+      end
+    module Submod =
+      struct
+        type t
+        and b
+        let f = _
+        module type STyp  = sig  end
+        module D = struct let i = _ end
+      end
+    module SubFunc(M:Sig) = struct let g = _ end
+  end"
+      ]
+    ],
+    "notifications": []
+  }
+
+First class modules
+
+  $ $MERLIN single construct -position 42:26 \
+  > -filename module.ml <module.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 42,
+          "col": 25
+        },
+        "end": {
+          "line": 42,
+          "col": 26
+        }
+      },
+      [
+        "((module struct type t = int end) : (module Small))"
+      ]
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single construct -position 44:17 \
+  > -filename module.ml <module.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 44,
+          "col": 16
+        },
+        "end": {
+          "line": 44,
+          "col": 17
+        }
+      },
+      [
+        "struct type t = int end"
+      ]
+    ],
+    "notifications": []
+  }
+
+
+Construction in functor application
+  $ $MERLIN single construct -position 7:22 \
+  > -filename functor_app.ml <functor_app.ml | jq '.value'
+  [
+    {
+      "start": {
+        "line": 7,
+        "col": 21
+      },
+      "end": {
+        "line": 7,
+        "col": 22
+      }
+    },
+    [
+      "struct let x = _ end"
+    ]
+  ]
diff --git a/tests/test-dirs/construct/c-objects.t b/tests/test-dirs/construct/c-objects.t
new file mode 100644
index 0000000..911dd67
--- /dev/null
+++ b/tests/test-dirs/construct/c-objects.t
@@ -0,0 +1,64 @@
+  $ cat >obj1.ml <<EOF
+  > let o : < a : string; get : int -> int option >
+  >   = _
+  > EOF
+
+  $ $MERLIN single construct -position 2:4 \
+  > -filename obj1.ml <obj1.ml | jq ".value"
+  [
+    {
+      "start": {
+        "line": 2,
+        "col": 4
+      },
+      "end": {
+        "line": 2,
+        "col": 5
+      }
+    },
+    [
+      "object method get = _ method a = _ end"
+    ]
+  ]
+
+  $ $MERLIN single construct -depth 2 -position 2:4 \
+  > -filename obj1.ml <obj1.ml | jq ".value[1]"
+  [
+    "object method get int = _ method a = \"\" end"
+  ]
+
+  $ $MERLIN single construct -depth 3 -position 2:4 \
+  > -filename obj1.ml <obj1.ml | jq ".value[1]"
+  [
+    "object method get int = Some _ method a = \"\" end",
+    "object method get int = None method a = \"\" end"
+  ]
+
+More cases
+  $ cat >obj2.ml <<EOF
+  > let a : < x : int >
+  >   = _
+  > let b : < x : int; .. >
+  >   = _
+  > type o = < x : int >
+  > let x : < y: char; o >
+  >   = _
+  > EOF
+
+  $ $MERLIN single construct -position 2:5 \
+  > -filename obj2.ml <obj2.ml | jq ".value[1]"
+  [
+    "object method x = _ end"
+  ]
+
+  $ $MERLIN single construct -position 4:5 \
+  > -filename obj2.ml <obj2.ml | jq ".value[1]"
+  [
+    "object method x = _ end"
+  ]
+
+  $ $MERLIN single construct -position 7:5 \
+  > -filename obj2.ml <obj2.ml | jq ".value[1]"
+  [
+    "object method y = _ method x = _ end"
+  ]
diff --git a/tests/test-dirs/construct/c-parenthesis.t b/tests/test-dirs/construct/c-parenthesis.t
new file mode 100644
index 0000000..8f3d2db
--- /dev/null
+++ b/tests/test-dirs/construct/c-parenthesis.t
@@ -0,0 +1,28 @@
+###############
+## SUM TYPES ##
+###############
+
+Test 1.1 :
+
+  $ cat >c1.ml <<EOF
+  > let x : int option option = Some (_)
+  > EOF
+
+  $ $MERLIN single construct -position 1:34 \
+  > -filename c1.ml <c1.ml | jq ".value"
+  [
+    {
+      "start": {
+        "line": 1,
+        "col": 33
+      },
+      "end": {
+        "line": 1,
+        "col": 36
+      }
+    },
+    [
+      "(Some _)",
+      "None"
+    ]
+  ]
diff --git a/tests/test-dirs/construct/c-prefix.t b/tests/test-dirs/construct/c-prefix.t
new file mode 100644
index 0000000..cf38ec9
--- /dev/null
+++ b/tests/test-dirs/construct/c-prefix.t
@@ -0,0 +1,101 @@
+###############
+## PREFIXING ##
+###############
+
+Test 1.1 :
+
+  $ cat >c1.ml <<EOF
+  > module Prefix = struct
+  >   type t = A of int | B
+  > end
+  > let x : Prefix.t = _
+  > EOF
+
+  $ $MERLIN single construct -position 4:20 -filename c1.ml <c1.ml |
+  >  jq ".value"
+  [
+    {
+      "start": {
+        "line": 4,
+        "col": 19
+      },
+      "end": {
+        "line": 4,
+        "col": 20
+      }
+    },
+    [
+      "Prefix.B",
+      "(Prefix.A _)"
+    ]
+  ]
+
+Test 1.2 :
+
+  $ cat >c12.ml <<EOF
+  > module Prefix = struct
+  >   type t = A of int | B
+  > end
+  > open Prefix
+  > let x : t = _
+  > EOF
+
+  $ $MERLIN single construct -position 5:13 -filename c12.ml <c12.ml |
+  >  jq ".value"
+  [
+    {
+      "start": {
+        "line": 5,
+        "col": 12
+      },
+      "end": {
+        "line": 5,
+        "col": 13
+      }
+    },
+    [
+      "B",
+      "(A _)"
+    ]
+  ]
+
+Test 1.3 :
+
+  $ cat >c13.ml <<EOF
+  > module Prefix = struct
+  >   type t = A of int | B
+  >   type r = { a : t }
+  > end
+  > let x : Prefix.t = _
+  > let x : Prefix.r = _
+  > open Prefix
+  > let x : t = _
+  > let x : r = _
+  > EOF
+
+  $ $MERLIN single construct -position 5:20 -filename c13.ml <c13.ml |
+  >  jq ".value[1]"
+  [
+    "Prefix.B",
+    "(Prefix.A _)"
+  ]
+
+  $ $MERLIN single construct -position 6:20 -filename c13.ml <c13.ml |
+  >  jq ".value[1]"
+  [
+    "{ Prefix.a = _ }"
+  ]
+
+  $ $MERLIN single construct -position 8:13 -filename c13.ml <c13.ml |
+  >  jq ".value[1]"
+  [
+    "B",
+    "(A _)"
+  ]
+
+  $ $MERLIN single construct -position 9:13 -filename c13.ml <c13.ml |
+  >  jq ".value[1]"
+  [
+    "{ a = _ }"
+  ]
+
diff --git a/tests/test-dirs/construct/c-simple.t b/tests/test-dirs/construct/c-simple.t
new file mode 100644
index 0000000..fa7a771
--- /dev/null
+++ b/tests/test-dirs/construct/c-simple.t
@@ -0,0 +1,561 @@
+###############
+## SUM TYPES ##
+###############
+
+Test 1.1 :
+
+  $ cat >c1.ml <<EOF
+  > let nice_candidate = Some 3
+  > let nice_candidate_with_arg x = Some x
+  > let nice_candidate_with_labeled_arg ~x = Some x
+  > let y = 4
+  > let x : int option = _
+  > EOF
+
+  $ $MERLIN single construct -position 5:22 \
+  > -filename c1.ml <c1.ml | jq ".value"
+  [
+    {
+      "start": {
+        "line": 5,
+        "col": 21
+      },
+      "end": {
+        "line": 5,
+        "col": 22
+      }
+    },
+    [
+      "(Some _)",
+      "None"
+    ]
+  ]
+
+With depth 2:
+
+  $ $MERLIN single construct -depth 2 -position 5:22 \
+  > -filename c1.ml <c1.ml | jq ".value"
+  [
+    {
+      "start": {
+        "line": 5,
+        "col": 21
+      },
+      "end": {
+        "line": 5,
+        "col": 22
+      }
+    },
+    [
+      "(Some 0)",
+      "None"
+    ]
+  ]
+
+With values:
+
+  $ $MERLIN single construct -with-values local -position 5:22 \
+  > -filename c1.ml <c1.ml | jq ".value"
+  [
+    {
+      "start": {
+        "line": 5,
+        "col": 21
+      },
+      "end": {
+        "line": 5,
+        "col": 22
+      }
+    },
+    [
+      "(Some _)",
+      "None",
+      "nice_candidate",
+      "(nice_candidate_with_arg _)",
+      "(nice_candidate_with_labeled_arg ~x:_)"
+    ]
+  ]
+
+With depth 2 and values:
+
+  $ $MERLIN single construct -depth 2 -with-values local \
+  > -position 5:22 -filename c1.ml <c1.ml | jq ".value"
+  [
+    {
+      "start": {
+        "line": 5,
+        "col": 21
+      },
+      "end": {
+        "line": 5,
+        "col": 22
+      }
+    },
+    [
+      "(Some 0)",
+      "None",
+      "(Some y)",
+      "nice_candidate",
+      "(nice_candidate_with_arg _)",
+      "(nice_candidate_with_labeled_arg ~x:_)"
+    ]
+  ]
+
+Test 1.2
+
+  $ cat >c2.ml <<EOF
+  > let x : int list = _
+  > EOF
+
+  $ $MERLIN single construct -position 1:20 \
+  > -filename c2.ml <c2.ml | jq ".value"
+  [
+    {
+      "start": {
+        "line": 1,
+        "col": 19
+      },
+      "end": {
+        "line": 1,
+        "col": 20
+      }
+    },
+    [
+      "(_ :: _)",
+      "[]"
+    ]
+  ]
+
+Test 1.3
+
+  $ cat >c3.ml <<EOF
+  > let x : 'a list = _
+  > EOF
+
+  $ $MERLIN single construct -position 1:19 \
+  > -filename c3.ml <c3.ml | jq ".value"
+  [
+    {
+      "start": {
+        "line": 1,
+        "col": 18
+      },
+      "end": {
+        "line": 1,
+        "col": 19
+      }
+    },
+    [
+      "(_ :: _)",
+      "[]"
+    ]
+  ]
+
+
+Test lazy
+
+  $ cat >lazy.ml <<EOF
+  > let x : int lazy = _
+  > EOF
+
+  $ $MERLIN single construct -position 1:20 \
+  > -filename lazy.ml <lazy.ml | jq ".value"
+  [
+    {
+      "start": {
+        "line": 1,
+        "col": 19
+      },
+      "end": {
+        "line": 1,
+        "col": 20
+      }
+    },
+    [
+      "(lazy _)"
+    ]
+  ]
+
+#############
+## RECORDS ##
+#############
+
+Test 2.1
+
+  $ cat >c2.ml <<EOF
+  > type r = { a : string; b : int option }
+  > let nice_candidate = {a = "a"; b = None }
+  > let x : r = _
+  > EOF
+
+  $ $MERLIN single construct -position 3:13 \
+  > -filename c2.ml <c2.ml | jq ".value"
+  [
+    {
+      "start": {
+        "line": 3,
+        "col": 12
+      },
+      "end": {
+        "line": 3,
+        "col": 13
+      }
+    },
+    [
+      "{ a = _; b = _ }"
+    ]
+  ]
+
+#################
+## ARROW TYPES ##
+#################
+
+Test 3.1
+
+  $ cat >c31.ml <<EOF
+  > let nice_candidate s = int_of_string s
+  > let x : string -> int = _
+  > EOF
+
+  $ $MERLIN single construct -position 2:25 \
+  > -filename c31.ml <c31.ml | jq ".value"
+  [
+    {
+      "start": {
+        "line": 2,
+        "col": 24
+      },
+      "end": {
+        "line": 2,
+        "col": 25
+      }
+    },
+    [
+      "(fun string -> _)"
+    ]
+  ]
+
+Test 3.2
+
+  $ cat >c32.ml <<EOF
+  > let type mytype = float
+  > let x : v:string -> float -> mytype -> mytype -> int = _
+  > EOF
+
+  $ $MERLIN single construct -position 2:55 \
+  > -filename c32.ml <c32.ml | jq ".value"
+  [
+    {
+      "start": {
+        "line": 2,
+        "col": 55
+      },
+      "end": {
+        "line": 2,
+        "col": 56
+      }
+    },
+    [
+      "(fun ~v float mytype mytype_1 -> _)"
+    ]
+  ]
+
+  $ $MERLIN single construct -depth 4 -position 2:55 \
+  > -filename c32.ml <c32.ml | jq ".value"
+  [
+    {
+      "start": {
+        "line": 2,
+        "col": 55
+      },
+      "end": {
+        "line": 2,
+        "col": 56
+      }
+    },
+    [
+      "(fun ~v float mytype mytype_1 -> 0)"
+    ]
+  ]
+
+############
+## TUPLES ##
+############
+
+Test 4.1
+
+  $ cat >c41.ml <<EOF
+  > type tup = int * float * (string option)
+  > let some_float = 4.2
+  > let x : tup = _
+  > EOF
+
+  $ $MERLIN single construct -position 3:14 \
+  >  -filename c41.ml <c41.ml | jq '.value[1]'
+  [
+    "(_, _, _)"
+  ]
+
+####################
+## POLY. VARIANTS ##
+####################
+
+TODO we need more tests here
+
+Test 5.1
+
+  $ cat >c51.ml <<EOF
+  > type v = [ \`A | \`B of string ]
+  > let some_v = \`B "totoro"
+  > let x : v = _
+  > EOF
+
+  $ $MERLIN single construct -position 3:13 \
+  >  -filename c51.ml <c51.ml | jq '.value[1]'
+  [
+    "(`B _)",
+    "`A"
+  ]
+
+  $ $MERLIN single construct -with-values local -position 3:13 \
+  >  -filename c51.ml <c51.ml | jq '.value[1]'
+  [
+    "(`B _)",
+    "`A",
+    "some_v"
+  ]
+
+###########
+## GADTs ##
+###########
+
+Test 6.1
+
+  $ cat >c61.ml <<EOF
+  > type _ term =
+  >  | Int : int -> int term
+  >  | Float : float -> float term
+  >  | Eq : 'a term * 'a term -> 'a term
+  > 
+  > let x : 'a term =
+  >   _
+  > let x : int term =
+  >   _
+  > EOF
+
+  $ $MERLIN single construct -position 7:3 \
+  > -filename c61.ml <c61.ml | jq '.value[1]'
+  [
+    "(Eq (_, _))",
+    "(Float _)",
+    "(Int _)"
+  ]
+
+Test 6.1b
+Eq (Int _, Float) is wrong and should not appear (fixed)
+  $ $MERLIN single construct -depth 2 -position 7:3 \
+  > -filename c61.ml <c61.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 7,
+          "col": 2
+        },
+        "end": {
+          "line": 7,
+          "col": 3
+        }
+      },
+      [
+        "(Eq ((Eq (_, _)), (Float _)))",
+        "(Float 0.0)",
+        "(Eq ((Float _), (Float _)))",
+        "(Int 0)",
+        "(Eq ((Float _), (Eq (_, _))))",
+        "(Eq ((Eq (_, _)), (Eq (_, _))))",
+        "(Eq ((Int _), (Eq (_, _))))",
+        "(Eq ((Eq (_, _)), (Int _)))",
+        "(Eq ((Int _), (Int _)))"
+      ]
+    ],
+    "notifications": []
+  }
+
+Test 6.1c
+  $ $MERLIN single construct -position 9:3 \
+  > -filename c61.ml <c61.ml | jq '.value[1]'
+  [
+    "(Eq (_, _))",
+    "(Int _)"
+  ]
+
+Test 6.2
+
+  $ cat >c62.ml <<EOF
+  > type _ term =
+  >  | Int : int -> int term
+  >  | Float : float -> float term
+  >  | Add : (int -> int -> int) term
+  >  | App : ('b -> 'a) term * 'b term -> 'a term
+  > let v1 = Int 42
+  > let v2 = Float 3.5
+  > let x : 'a term =
+  >   _
+  > let x : int term =
+  >   _
+  > EOF
+
+Test 6.2b
+Fixed: v2 should appear
+  $ $MERLIN single construct -with-values local -position 9:3 \
+  > -filename c62.ml <c62.ml | jq '.value[1]'
+  [
+    "(App (_, _))",
+    "Add",
+    "(Float _)",
+    "(Int _)",
+    "v1",
+    "v2"
+  ]
+
+Test 6.2c
+only v1 should appear
+  $ $MERLIN single construct -with-values local -position 11:3 \
+  > -filename c62.ml <c62.ml | jq '.value[1]'
+  [
+    "(App (_, _))",
+    "(Int _)",
+    "v1",
+    "x"
+  ]
+
+###################
+## MISCELLANEOUS ##
+###################
+
+Test M.1 : Type vars
+
+  $ cat >cM1.ml <<EOF
+  > type 'a t = A of 'a
+  > let x = A _
+  > EOF
+
+  $ $MERLIN single construct -position 2:11 \
+  >  -filename cM1.ml <cM1.ml | jq '.value[1]'
+  []
+
+Test M.2 : FIXME wrong position
+
+  $ cat >M2.ml <<EOF
+  > let x : type a . a list = _
+  > EOF
+
+  $ $MERLIN single construct -position 1:27 \
+  > -filename M2.ml <M2.ml | jq ".value"
+  [
+    {
+      "start": {
+        "line": 1,
+        "col": 4
+      },
+      "end": {
+        "line": 1,
+        "col": 27
+      }
+    },
+    [
+      "(_ :: _)",
+      "[]"
+    ]
+  ]
+
+Test M.3 : Predef types
+
+  $ cat >M3.ml <<EOF
+  > let x : int =         _
+  > let x : nativeint =   _
+  > let x : int32 =       _
+  > let x : int64 =       _
+  > let x : float =       _
+  > let x : char =        _
+  > let x : string =      _
+  > let x : bool =        _
+  > let x : unit =        _
+  > let x : exn =         _
+  > let x : 'a array =    _
+  > let x : 'a lazy_t =   _
+  > EOF
+
+  $ $MERLIN single construct -position 1:22 \
+  > -filename M3.ml <M3.ml | jq ".value[1]"
+  [
+    "0"
+  ]
+
+  $ $MERLIN single construct -position 2:22 \
+  > -filename M3.ml <M3.ml | jq ".value[1]"
+  [
+    "0n"
+  ]
+
+  $ $MERLIN single construct -position 3:22 \
+  > -filename M3.ml <M3.ml | jq ".value[1]"
+  [
+    "0l"
+  ]
+
+  $ $MERLIN single construct -position 4:22 \
+  > -filename M3.ml <M3.ml | jq ".value[1]"
+  [
+    "0L"
+  ]
+
+  $ $MERLIN single construct -position 5:22 \
+  > -filename M3.ml <M3.ml | jq ".value[1]"
+  [
+    "0.0"
+  ]
+
+  $ $MERLIN single construct -position 6:22 \
+  > -filename M3.ml <M3.ml | jq ".value[1]"
+  [
+    "'c'"
+  ]
+
+  $ $MERLIN single construct -position 7:22 \
+  > -filename M3.ml <M3.ml | jq ".value[1]"
+  [
+    "\"\""
+  ]
+
+  $ $MERLIN single construct -position 8:22 \
+  > -filename M3.ml <M3.ml | jq ".value[1]"
+  [
+    "true"
+  ]
+
+  $ $MERLIN single construct -position 9:22 \
+  > -filename M3.ml <M3.ml | jq ".value[1]"
+  [
+    "()"
+  ]
+
+  $ $MERLIN single construct -position 10:22 \
+  > -filename M3.ml <M3.ml | jq ".value[1]"
+  [
+    "exn"
+  ]
+
+  $ $MERLIN single construct -position 11:22 \
+  > -filename M3.ml <M3.ml | jq ".value[1]"
+  [
+    "[||]"
+  ]
+
+  $ $MERLIN single construct -position 12:22 \
+  > -filename M3.ml <M3.ml | jq ".value[1]"
+  [
+    "(lazy _)"
+  ]
diff --git a/tests/test-dirs/construct/dune b/tests/test-dirs/construct/dune
new file mode 100644
index 0000000..29a9d86
--- /dev/null
+++ b/tests/test-dirs/construct/dune
@@ -0,0 +1,3 @@
+(cram
+ (applies_to :whole_subtree)
+ (alias construct))
diff --git a/tests/test-dirs/construct/holes.t b/tests/test-dirs/construct/holes.t
new file mode 100644
index 0000000..3319a92
--- /dev/null
+++ b/tests/test-dirs/construct/holes.t
@@ -0,0 +1,63 @@
+  $ cat >h1.ml <<EOF
+  > EOF
+
+  $ $MERLIN single holes -filename h1.ml <h1.ml |
+  >  jq ".value"
+  []
+
+
+  $ cat >h2.ml <<EOF
+  > let x : int option = _
+  > let g x y = x * y
+  > let f x y = g _ _
+  > module M : sig val f : int -> unit end = _
+  > EOF
+
+  $ $MERLIN single holes -filename h2.ml <h2.ml |
+  >  jq ".value"
+  [
+    {
+      "start": {
+        "line": 1,
+        "col": 21
+      },
+      "end": {
+        "line": 1,
+        "col": 22
+      },
+      "type": "int option"
+    },
+    {
+      "start": {
+        "line": 3,
+        "col": 14
+      },
+      "end": {
+        "line": 3,
+        "col": 15
+      },
+      "type": "int"
+    },
+    {
+      "start": {
+        "line": 3,
+        "col": 16
+      },
+      "end": {
+        "line": 3,
+        "col": 17
+      },
+      "type": "int"
+    },
+    {
+      "start": {
+        "line": 4,
+        "col": 41
+      },
+      "end": {
+        "line": 4,
+        "col": 42
+      },
+      "type": "sig val f : int -> unit end"
+    }
+  ]
diff --git a/tests/test-dirs/deprecation.t/foo.mli b/tests/test-dirs/deprecation.t/foo.mli
new file mode 100644
index 0000000..9dce48b
--- /dev/null
+++ b/tests/test-dirs/deprecation.t/foo.mli
@@ -0,0 +1,5 @@
+
+val bar : unit -> int
+[@@ocaml.deprecated "deprecation message"]
+
+val baz : unit -> unit
diff --git a/tests/test-dirs/deprecation.t/run.t b/tests/test-dirs/deprecation.t/run.t
new file mode 100644
index 0000000..ffca8a4
--- /dev/null
+++ b/tests/test-dirs/deprecation.t/run.t
@@ -0,0 +1,26 @@
+  $ echo "S .\nB .\nFLG -nopervasives" > .merlin
+  $ $OCAMLC -nopervasives -c -bin-annot foo.mli
+  $ $MERLIN single complete-prefix -position 2:14 -prefix Foo.ba -kind val -filename x.ml < x.ml
+  {
+    "class": "return",
+    "value": {
+      "entries": [
+        {
+          "name": "bar",
+          "kind": "Value",
+          "desc": "unit -> int",
+          "info": "",
+          "deprecated": true
+        },
+        {
+          "name": "baz",
+          "kind": "Value",
+          "desc": "unit -> unit",
+          "info": "",
+          "deprecated": false
+        }
+      ],
+      "context": null
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/deprecation.t/x.ml b/tests/test-dirs/deprecation.t/x.ml
new file mode 100644
index 0000000..7a291c4
--- /dev/null
+++ b/tests/test-dirs/deprecation.t/x.ml
@@ -0,0 +1 @@
+let x = Foo.ba
diff --git a/tests/test-dirs/destruct/complete.t b/tests/test-dirs/destruct/complete.t
new file mode 100644
index 0000000..312fff4
--- /dev/null
+++ b/tests/test-dirs/destruct/complete.t
@@ -0,0 +1,361 @@
+###############
+## SUM TYPES ##
+###############
+
+Test 1.1 : FIXME (void type no Some)
+
+  $ cat >typ5.ml <<EOF
+  > type void = |
+  > let f (x : void option) =
+  >   match x with
+  >   | None -> ()
+  > EOF
+
+  $ $MERLIN single case-analysis -start 4:4 -end 4:4 -filename typ5.ml <typ5.ml | \
+  > sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.'
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 4,
+          "col": 14
+        },
+        "end": {
+          "line": 4,
+          "col": 14
+        }
+      },
+      "|Some _ -> _"
+    ],
+    "notifications": []
+  }
+
+Test 1.2 : FIXME ?
+
+  $ cat >typ12.ml <<EOF
+  > let _ =
+  >   match (None : int option option) with
+  >   | Some (Some 3) -> ()
+  > EOF
+
+  $ $MERLIN single case-analysis -start 3:4 -end 3:8 -filename typ12.ml < typ12.ml \
+  > sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.'
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 23
+        },
+        "end": {
+          "line": 3,
+          "col": 23
+        }
+      },
+      "|Some (Some 0) -> _|Some (None) -> _|None -> _"
+    ],
+    "notifications": []
+  }
+
+Test 1.3 : with type constructor
+
+  $ $MERLIN single case-analysis -start 3:5 -end 3:5 -filename funny.ml <<EOF
+  > type funny = int option -> unit
+  > let v : funny = function
+  >   | None -> ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 14
+        },
+        "end": {
+          "line": 3,
+          "col": 14
+        }
+      },
+      "
+  | Some _ -> _"
+    ],
+    "notifications": []
+  }
+
+#############
+## RECORDS ##
+#############
+
+Test 2.1
+
+  $ cat >typ.ml <<EOF
+  > type a = A | B of string
+  > type recd = { a : a }
+  > let f (x : recd) =
+  >   match x with
+  >   | { a = A } -> ()
+  > EOF
+
+  $ $MERLIN single case-analysis -start 5:4 -end 5:4 -filename typ.ml < typ.ml | \
+  > sed -e 's/ *| */|/g' | tr -d '\n' | jq '.'
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 5,
+          "col": 19
+        },
+        "end": {
+          "line": 5,
+          "col": 19
+        }
+      },
+      "|{ a = B _ } -> _"
+    ],
+    "notifications": []
+  }
+
+Test 2.2 : FIXME ?
+
+  $ cat >typ3.ml <<EOF
+  > type a = A | B of string
+  > type recd = { a : a }
+  > let f (x : recd) =
+  >   match x with
+  >   | { a = A } -> ()
+  >   | { a = B _ } -> ()
+  > EOF
+
+  $ $MERLIN single case-analysis -start 6:12 -end 6:12 -filename typ3.ml <typ3.ml | \
+  > sed -e 's/ *| */|/g' | tr -d '\n' | jq '.'
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 6,
+          "col": 4
+        },
+        "end": {
+          "line": 6,
+          "col": 15
+        }
+      },
+      "{ a = B \"\" }|{ a = B _ }"
+    ],
+    "notifications": []
+  }
+
+##########################
+## POLYMORPHIC VARIANTS ##
+##########################
+
+Test 3.1
+
+  $ cat >typ2.ml <<EOF
+  > type basic_color = [ \`Blue | \`Red | \`Yellow ]
+  > let f (x : basic_color) =
+  >   match x with
+  >   | \`Blue -> ()
+  > EOF
+
+  $ $MERLIN single case-analysis -start 4:5 -end 4:5 -filename typ2.ml <typ2.ml | \
+  > sed -e 's/ *| */|/g' | tr -d '\n' | jq '.'
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 4,
+          "col": 15
+        },
+        "end": {
+          "line": 4,
+          "col": 15
+        }
+      },
+      "|`Yellow|`Red -> _"
+    ],
+    "notifications": []
+  }
+
+Test 3.1
+
+  $ cat >typv3.ml <<EOF
+  > type basic_color = [ \`Blue | \`Red | \`Yellow ]
+  > type better_color = [ basic_color | \`Gold ]
+  > let f (x : better_color) =
+  >   match x with
+  >   | #basic_color -> ()
+  > EOF
+
+  $ $MERLIN single case-analysis -start 5:5 -end 5:5 -filename typv3.ml <typv3.ml | \
+  > sed -e 's/ *| */|/g' | tr -d '\n' | jq '.'
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 5,
+          "col": 22
+        },
+        "end": {
+          "line": 5,
+          "col": 22
+        }
+      },
+      "|`Gold -> _"
+    ],
+    "notifications": []
+  }
+
+##########
+## GADT ##
+##########
+
+Test 4.1
+
+  $ cat >typ3.ml <<EOF
+  > type _ term =
+  >  | Int : int -> int term
+  >  | Add : (int -> int -> int) term
+  >  | App : ('b -> 'a) term * 'b term -> 'a term
+  > let eval : type a. a term -> unit =
+  >   fun (x : a term) -> match x with
+  >   | Int _ -> ()
+  >   | Add -> ()
+  > EOF
+
+  $ $MERLIN single case-analysis -start 8:4 -end 8:4 -filename typ3.ml <typ3.ml | \
+  > sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.'
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 8,
+          "col": 13
+        },
+        "end": {
+          "line": 8,
+          "col": 13
+        }
+      },
+      "|App (_,_) -> _"
+    ],
+    "notifications": []
+  }
+
+Test 4.2
+
+  $ cat >typ4.ml <<EOF
+  > type _ term =
+  >  | Int : int -> int term
+  >  | Add : (int -> int -> int) term
+  >  | App : ('b -> 'a) term * 'b term -> 'a term
+  > let eval (type a) : a term -> unit =
+  >   function
+  >   | Int _ -> ()
+  >   | Add -> ()
+  > EOF
+
+  $ $MERLIN single case-analysis -start 8:4 -end 8:4 -filename typ4.ml <typ4.ml | \
+  > sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.'
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 8,
+          "col": 13
+        },
+        "end": {
+          "line": 8,
+          "col": 13
+        }
+      },
+      "|App (_,_) -> _"
+    ],
+    "notifications": []
+  }
+
+Test 4.3 : this match IS exhaustive
+
+  $ cat >typ4b.ml <<EOF
+  > type _ t =
+  >   | I : int t
+  >   | B : bool t
+  > let f : int t -> unit =
+  >   function
+  >   | I -> ()
+  > EOF
+
+  $ $MERLIN single case-analysis -start 6:4 -end 6:4 -filename typ4b.ml <typ4b.ml | \
+  > sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.'
+  {
+    "class": "error",
+    "value": "Nothing to do",
+    "notifications": []
+  }
+
+############
+## MODULE ##
+############
+
+Test 5.1 : Module path
+
+  $ $MERLIN single case-analysis -start 4:4 -end 4:4 -filename module_path.ml <<EOF
+  > module T = struct type t = A | B of int end
+  > let g x =
+  >   match x with
+  >   | T.A -> ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 4,
+          "col": 13
+        },
+        "end": {
+          "line": 4,
+          "col": 13
+        }
+      },
+      "
+  | T.B _ -> _"
+    ],
+    "notifications": []
+  }
+
+
+Test 5.1 : Module path (with function)
+
+  $ $MERLIN single case-analysis -start 3:4 -end 3:4 -filename module_path.ml <<EOF
+  > module T = struct type t = A | B of int end
+  > let g = function
+  >   | T.A -> ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 13
+        },
+        "end": {
+          "line": 3,
+          "col": 13
+        }
+      },
+      "
+  | T.B _ -> _"
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/destruct/create.t b/tests/test-dirs/destruct/create.t
new file mode 100644
index 0000000..f04df13
--- /dev/null
+++ b/tests/test-dirs/destruct/create.t
@@ -0,0 +1,250 @@
+###############
+## SUM TYPES ##
+###############
+
+Test 1.1 : FIXME: put each case on a different line (if it doesn't require updating
+pprintast).
+
+  $ $MERLIN single case-analysis -start 2:2 -end 2:3 -filename variant_exp.ml <<EOF
+  > let f (x : int option) =
+  >   x
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 2
+        },
+        "end": {
+          "line": 2,
+          "col": 3
+        }
+      },
+      "match x with | None -> _ | Some _ -> _"
+    ],
+    "notifications": []
+  }
+
+#############
+## RECORDS ##
+#############
+
+Test 2.1
+
+  $ $MERLIN single case-analysis -start 2:2 -end 2:3 -filename record_exp.ml <<EOF
+  > let f (x : int ref) =
+  >   x
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 2
+        },
+        "end": {
+          "line": 2,
+          "col": 3
+        }
+      },
+      "match x with | { contents } -> _"
+    ],
+    "notifications": []
+  }
+
+##########################
+## POLYMORPHIC VARIANTS ##
+##########################
+
+Test 3.1
+
+  $ cat >typv2.ml <<EOF
+  > type basic_color = [ \`Blue | \`Red | \`Yellow ]
+  > let f (x : basic_color) =
+  >   x
+  > EOF
+
+  $ $MERLIN single case-analysis -start 3:2 -end 3:2 -filename typv2.ml <typv2.ml | \
+  > sed -e 's/ *| */|/g' | tr -d '\n' | jq '.'
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 2
+        },
+        "end": {
+          "line": 3,
+          "col": 3
+        }
+      },
+      "match x with|`Blue -> _|`Yellow -> _|`Red -> _"
+    ],
+    "notifications": []
+  }
+
+Test 3.1
+
+  $ cat >typv3.ml <<EOF
+  > type basic_color = [ \`Blue | \`Red | \`Yellow ]
+  > type better_color = [ basic_color | \`Gold ]
+  > let f (x : better_color) =
+  >   x
+  > EOF
+
+  $ $MERLIN single case-analysis -start 4:2 -end 4:2 -filename typv3.ml <typv3.ml | \
+  > sed -e 's/ *| */|/g' | tr -d '\n' | jq '.'
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 4,
+          "col": 2
+        },
+        "end": {
+          "line": 4,
+          "col": 3
+        }
+      },
+      "match x with|`Blue -> _|`Yellow -> _|`Red -> _|`Gold -> _"
+    ],
+    "notifications": []
+  }
+
+##########
+## GADT ##
+##########
+
+Test 4.1
+
+  $ cat >typ4b.ml <<EOF
+  > type _ t =
+  >   | I : int -> int t
+  >   | B : bool t
+  > let f (x : int t) : unit =
+  >   x
+  > EOF
+
+  $ $MERLIN single case-analysis -start 5:2 -end 5:2 -filename typ4b.ml <typ4b.ml | \
+  > sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.'
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 5,
+          "col": 2
+        },
+        "end": {
+          "line": 5,
+          "col": 3
+        }
+      },
+      "(match x with|I _ -> _)"
+    ],
+    "notifications": []
+  }
+
+Test 4.2
+
+  $ cat >typ4.ml <<EOF
+  > type _ term =
+  >  | Int : int -> int term
+  >  | Add : (int -> int -> int) term
+  >  | App : ('b -> 'a) term * 'b term -> 'a term
+  > let eval : type a. a term -> a term = fun x ->
+  >   x
+  > EOF
+
+  $ $MERLIN single case-analysis -start 6:2 -end 6:2 -filename typ4.ml <typ4.ml | \
+  > sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.'
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 6,
+          "col": 2
+        },
+        "end": {
+          "line": 6,
+          "col": 3
+        }
+      },
+      "match x with|Int _ -> _|Add -> _|App (_,_) -> _"
+    ],
+    "notifications": []
+  }
+
+############
+## MODULE ##
+############
+
+Test 5.1
+
+  $ $MERLIN single case-analysis -start 3:2 -end 3:3 -filename unpack_module.ml <<EOF
+  > module type S = sig end
+  > let g (x : (module S)) =
+  >   x
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 2
+        },
+        "end": {
+          "line": 3,
+          "col": 3
+        }
+      },
+      "let module M = (val x) in _"
+    ],
+    "notifications": []
+  }
+
+Test 5.2 : Module path
+
+  $ $MERLIN single case-analysis -start 3:2 -end 3:3 -filename module_path.ml <<EOF
+  > module T = struct type t = A | B of int end
+  > let g (x : T.t) =
+  >   x
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 2
+        },
+        "end": {
+          "line": 3,
+          "col": 3
+        }
+      },
+      "match x with | T.A -> _ | T.B _ -> _"
+    ],
+    "notifications": []
+  }
+
+test 5.3 : Abstract type
+
+
+  $ $MERLIN single case-analysis -start 3:2 -end 3:3 -filename module_path.ml <<EOF
+  > module T : sig type t end = struct type t = A | B of int end
+  > let g (x : T.t) =
+  >   x
+  > EOF
+  {
+    "class": "error",
+    "value": "Destruct not allowed on non-destructible type: t",
+    "notifications": []
+  }
diff --git a/tests/test-dirs/destruct/dune b/tests/test-dirs/destruct/dune
new file mode 100644
index 0000000..62bcb43
--- /dev/null
+++ b/tests/test-dirs/destruct/dune
@@ -0,0 +1,3 @@
+(cram
+ (applies_to :whole_subtree)
+ (alias all-destruct-tests))
diff --git a/tests/test-dirs/destruct/errors.t b/tests/test-dirs/destruct/errors.t
new file mode 100644
index 0000000..1285db6
--- /dev/null
+++ b/tests/test-dirs/destruct/errors.t
@@ -0,0 +1,291 @@
+Test 1
+
+  $ echo "let () = ()" | $MERLIN single case-analysis -start 1:4 -end 1:4 -filename stacktrace.ml | grep -E -v "Raised|Called|Re-raised"
+  {
+    "class": "error",
+    "value": "Destruct not allowed on value_binding",
+    "notifications": []
+  }
+
+Test 2
+
+  $ $MERLIN single case-analysis -start 4:2 -end 4:1 -filename nonode.ml <<EOF
+  > let f (x : int option) =
+  >   match w with
+  >  | _ -> ()
+  > EOF
+  {
+    "class": "error",
+    "value": "Nothing to do",
+    "notifications": []
+  }
+
+Test 3
+
+  $ $MERLIN single case-analysis -start 3:4 -end 3:8 -filename complete.ml <<EOF
+  > let _ =
+  >   match (None : int option) with
+  >   | exception _ -> ()
+  >   | Some 3 -> ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 4,
+          "col": 16
+        },
+        "end": {
+          "line": 4,
+          "col": 16
+        }
+      },
+      " | Some 0 -> _
+  | None -> _"
+    ],
+    "notifications": []
+  }
+
+Test 4
+
+  $ $MERLIN single case-analysis -start 4:4 -end 4:8 -filename complete.ml <<EOF
+  > let _ =
+  >   match (None : int option) with
+  >   | exception _ -> ()
+  >   | Some _ -> ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 4,
+          "col": 16
+        },
+        "end": {
+          "line": 4,
+          "col": 16
+        }
+      },
+      "
+  | None -> _"
+    ],
+    "notifications": []
+  }
+
+Test 5
+
+  $ $MERLIN single case-analysis -start 4:5 -end 4:5 -filename no_comp_pat.ml <<EOF
+  > let _ =
+  >   match (None : unit option) with
+  >   | exception _ -> ()
+  >   | None -> ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 4,
+          "col": 14
+        },
+        "end": {
+          "line": 4,
+          "col": 14
+        }
+      },
+      "
+  | Some _ -> _"
+    ],
+    "notifications": []
+  }
+
+Test 6
+FIXME: `Some 0` certainly is a missing case but we can do better:
+
+  $ $MERLIN single case-analysis -start 4:4 -end 4:8 -filename complete.ml <<EOF
+  > let _ =
+  >   match (None : int option) with
+  >   | exception _ -> ()
+  >   | Some 3 -> ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 4,
+          "col": 16
+        },
+        "end": {
+          "line": 4,
+          "col": 16
+        }
+      },
+      " | Some 0 -> _
+  | None -> _"
+    ],
+    "notifications": []
+  }
+
+Test 7
+Same two tests but with the exception pattern at the end
+
+  $ $MERLIN single case-analysis -start 4:9 -end 4:11 -filename no_comp_pat.ml <<EOF
+  > let _ =
+  >   match (None : unit option) with
+  >   | None -> ()
+  >   | exception _ -> ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 4,
+          "col": 21
+        },
+        "end": {
+          "line": 4,
+          "col": 21
+        }
+      },
+      "
+  | Some _ -> _"
+    ],
+    "notifications": []
+  }
+
+Test 8
+FIXME: `Some 0` certainly is a missing case but we can do better
+
+  $ $MERLIN single case-analysis -start 3:4 -end 3:8 -filename complete.ml <<EOF
+  > let _ =
+  >   match (None : int option) with
+  >   | Some 3 -> ()
+  >   | exception _ -> ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 4,
+          "col": 21
+        },
+        "end": {
+          "line": 4,
+          "col": 21
+        }
+      },
+      " | Some 0 -> _
+  | None -> _"
+    ],
+    "notifications": []
+  }
+
+Test 9
+Tests with exception in or-pattern
+
+  $ $MERLIN single case-analysis -start 3:4 -end 3:4 -filename exp_or.ml <<EOF
+  > let _ =
+  >   match (None : unit option) with
+  >   | None | exception _ -> ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 28
+        },
+        "end": {
+          "line": 3,
+          "col": 28
+        }
+      },
+      "
+  | Some _ -> _"
+    ],
+    "notifications": []
+  }
+
+Test 10
+
+  $ $MERLIN single case-analysis -start 3:11 -end 3:11 -filename exp_or.ml <<EOF
+  > let _ =
+  >   match (None : unit option) with
+  >   | None | exception _ -> ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 28
+        },
+        "end": {
+          "line": 3,
+          "col": 28
+        }
+      },
+      "
+  | Some _ -> _"
+    ],
+    "notifications": []
+  }
+
+Test 11
+
+  $ $MERLIN single case-analysis -start 3:4 -end 3:4 -filename exp_or.ml <<EOF
+  > let _ =
+  >   match (None : unit option) with
+  >   | exception _ | None -> ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 28
+        },
+        "end": {
+          "line": 3,
+          "col": 28
+        }
+      },
+      "
+  | Some _ -> _"
+    ],
+    "notifications": []
+  }
+
+Test 12
+
+  $ $MERLIN single case-analysis -start 3:4 -end 3:4 -filename exp_or.ml <<EOF
+  > let _ =
+  >   match (None : unit option) with
+  >   | exception Not_found | None | exception _ -> ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 50
+        },
+        "end": {
+          "line": 3,
+          "col": 50
+        }
+      },
+      "
+  | Some _ -> _"
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/destruct/from_val.t b/tests/test-dirs/destruct/from_val.t
new file mode 100644
index 0000000..43a4916
--- /dev/null
+++ b/tests/test-dirs/destruct/from_val.t
@@ -0,0 +1,156 @@
+
+  $ $MERLIN single case-analysis -start 3:2 -end 3:3 -filename typ.ml <<EOF | sed -e 's/,_)/, _)/g'
+  > type my_list = Atom | Elt of string * my_list
+  > let f x : my_list =
+  >   x
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 2
+        },
+        "end": {
+          "line": 3,
+          "col": 3
+        }
+      },
+      "match (x : my_list) with | Atom -> _ | Elt (_, _) -> _"
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single case-analysis -start 3:2 -end 3:3 -filename typ.ml <<EOF
+  > type my_rec = { atom: string; elt: string * my_rec }
+  > let f x : my_rec =
+  >   x
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 2
+        },
+        "end": {
+          "line": 3,
+          "col": 3
+        }
+      },
+      "match (x : my_rec) with | { atom; elt } -> _"
+    ],
+    "notifications": []
+  }
+
+FIXME
+  $ $MERLIN single case-analysis -start 4:18 -end 4:21 -filename typ.ml <<EOF
+  > type my_rec = { atom: string; elt: string * my_rec }
+  > let f x : my_rec =
+  >   match (x : my_rec) with
+  >   | { atom; elt = _ } -> ()
+  > EOF
+  {
+    "class": "error",
+    "value": "Nothing to do",
+    "notifications": []
+  }
+
+  $ $MERLIN single case-analysis -start 3:2 -end 3:3 -filename typ.ml <<EOF
+  > type basic_color = [ \`Blue | \`Red | \`Yellow ]
+  > let f x : basic_color =
+  >   x
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 2
+        },
+        "end": {
+          "line": 3,
+          "col": 3
+        }
+      },
+      "match (x : basic_color) with | `Blue -> _ | `Yellow -> _ | `Red -> _"
+    ],
+    "notifications": []
+  }
+
+  $ cat >typ.ml <<EOF
+  > type my_list = Atom | Elt of string * my_list
+  > let f x : my_list =
+  >   match (x : my_list) with
+  >   | Atom -> ()
+  >   | Elt (_, _) -> ()
+  > EOF
+
+  $ $MERLIN single case-analysis -start 5:12 -end 5:13 -filename typ.ml <typ.ml | \
+  > sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.'
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 5,
+          "col": 4
+        },
+        "end": {
+          "line": 5,
+          "col": 14
+        }
+      },
+      "Elt (_,Atom)|Elt (_,Elt (_,_))"
+    ],
+    "notifications": []
+  }
+
+  $ cat >typ2.ml <<EOF
+  > type _ term =
+  >  | Int : int -> int term
+  >  | Add : (int -> int -> int) term
+  >  | App : ('b -> 'a) term * 'b term -> 'a term
+  > let eval : type a. a term -> a term =
+  >   fun x -> x
+  > EOF
+
+  $ $MERLIN single case-analysis -start 6:10 -end 6:10 -filename typ2.ml <typ2.ml | \
+  > sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.'
+  {
+    "class": "error",
+    "value": "Destruct not allowed on core_type",
+    "notifications": []
+  }
+
+  $ cat >typ3.ml <<EOF
+  > type _ term =
+  >  | Int : int -> int term
+  >  | Add : (int -> int -> int) term
+  >  | App : ('b -> 'a) term * 'b term -> 'a term
+  > let eval : type a. a term -> a term =
+  >   fun x : a term -> x
+  > EOF
+
+  $ $MERLIN single case-analysis -start 6:20 -end 6:20 -filename typ3.ml <typ3.ml | \
+  > sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.'
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 6,
+          "col": 20
+        },
+        "end": {
+          "line": 6,
+          "col": 21
+        }
+      },
+      "match (x : a term) with|Int _ -> _|Add -> _|App (_,_) -> _"
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/destruct/issue1300.t b/tests/test-dirs/destruct/issue1300.t
new file mode 100644
index 0000000..ab0d045
--- /dev/null
+++ b/tests/test-dirs/destruct/issue1300.t
@@ -0,0 +1,52 @@
+From issue 1300:
+https://github.com/ocaml/merlin/issues/1300
+  $ $MERLIN single case-analysis -start 6:5 -end 6:5 -filename i1300.ml <<EOF
+  > type t =
+  > | A of int
+  > | B of int
+  > 
+  > let f = function
+  > | A x (* <<< here *)
+  > | B -> 0
+  > EOF
+  {
+    "class": "error",
+    "value": "The node on which destruct was called is ill-typed",
+    "notifications": []
+  }
+
+  $ $MERLIN single case-analysis -start 6:5 -end 6:5 -filename i1300.ml <<EOF
+  > type t =
+  > | A of int
+  > | B of int
+  > 
+  > let f = function
+  > | A x (* <<< here *)
+  > | B x -> 0
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 6,
+          "col": 2
+        },
+        "end": {
+          "line": 7,
+          "col": 5
+        }
+      },
+      "A 0 |B x |A _"
+    ],
+    "notifications": []
+  }
+
+Fixed: Another stacktrace when "no nodes"
+  $ $MERLIN single case-analysis -start 7:25 -end 7:25 -filename i1300.ml <<EOF
+  > EOF
+  {
+    "class": "error",
+    "value": "Nothing to do",
+    "notifications": []
+  }
diff --git a/tests/test-dirs/destruct/issue596.t b/tests/test-dirs/destruct/issue596.t
new file mode 100644
index 0000000..f28c307
--- /dev/null
+++ b/tests/test-dirs/destruct/issue596.t
@@ -0,0 +1,8 @@
+  $ $MERLIN single case-analysis -start 1:5 -end 1:5 -filename bug.ml <<EOF | sed -e 's/,_)/, _)/g'
+  > let a = 1 in a + 1 ;;
+  > EOF
+  {
+    "class": "error",
+    "value": "Destruct not allowed on value_binding",
+    "notifications": []
+  }
diff --git a/tests/test-dirs/destruct/prefixing.t b/tests/test-dirs/destruct/prefixing.t
new file mode 100644
index 0000000..8faf688
--- /dev/null
+++ b/tests/test-dirs/destruct/prefixing.t
@@ -0,0 +1,108 @@
+#################
+### FROM EXPR ###
+#################
+Test 1.1
+  $ $MERLIN single case-analysis -start 3:2 -end 3:3 -filename typ.ml <<EOF | \
+  > tr -d '\n' | jq '.value[1]'
+  > module A = struct type my_list = Atom | Elt of string * my_list end
+  > let f x : A.my_list =
+  >   x
+  > EOF
+  "match (x : A.my_list) with | A.Atom -> _ | A.Elt (_, _) -> _"
+
+Test 1.2
+  $ $MERLIN single case-analysis -start 4:2 -end 4:3 -filename typ.ml <<EOF | \
+  > tr -d '\n' | jq '.value[1]'
+  > module A = struct type my_list = Atom | Elt of string * my_list end
+  > open A
+  > let f x : my_list =
+  >   x
+  > EOF
+  "match (x : my_list) with | Atom -> _ | Elt (_, _) -> _"
+
+Test 1.3
+  $ $MERLIN single case-analysis -start 6:2 -end 6:3 -filename typ.ml <<EOF | \
+  > tr -d '\n' | jq '.value[1]'
+  > module A = struct type t = A | B | C end
+  > module B = struct type t = A | B end
+  > open A
+  > open B
+  > let f x : A.t =
+  >   x
+  > EOF
+  "match (x : A.t) with | A -> _ | B -> _ | C -> _"
+
+Test 1.4
+  $ $MERLIN single case-analysis -start 5:2 -end 5:3 -filename typ.ml <<EOF | \
+  > tr -d '\n' | jq '.value[1]'
+  > module A = struct module B = struct type t = C end end
+  > open A
+  > module B = struct type t = D end
+  > let f x : A.B.t =
+  >   x
+  > EOF
+  "match (x : A.B.t) with | A.B.C -> _"
+
+################
+### COMPLETE ###
+################
+
+Test 2.1
+  $ cat >typ21.ml <<EOF
+  > module A = struct type t = B | C end
+  > let f (x : A.t) =
+  >   match x with
+  >   | A.B -> ()
+  > open A
+  > let f (x : t) =
+  >   match x with
+  >   | B -> ()
+  > EOF
+
+Test 2.2
+  $ $MERLIN single case-analysis -start 4:4 -end 4:4 -filename typ21.ml <typ21.ml | \
+  > tr -d '\n' | jq '.value[1]'
+  "| A.C -> _"
+
+Test 2.3
+  $ $MERLIN single case-analysis -start 8:4 -end 8:4 -filename typ21.ml <typ21.ml | \
+  > tr -d '\n' | jq '.value[1]'
+  "| C -> _"
+
+Test 2.4
+  $ $MERLIN single case-analysis -start 5:4 -end 5:4 -filename typ.ml <<EOF | \
+  > tr -d '\n' | jq '.value[1]'
+  > module A = struct module B = struct type t = C | F end end
+  > open A
+  > module B = struct type t = D end
+  > let f x = match (x : A.B.t) with
+  >   | A.B.C -> ()
+  > EOF
+  "| A.B.F -> _"
+
+################
+### REFINING ###
+################
+
+Test 3.1
+  $ $MERLIN single case-analysis -start 5:9 -end 5:10 -filename refine_pattern.ml <<EOF | \
+  > tr -d '\n' | jq '.value[1]'
+  > module A = struct type t = B | C end
+  > let _ =
+  >   match (None : A.t option) with
+  >   | None -> ()
+  >   | Some _ -> ()
+  > EOF
+  "Some (A.B) |Some (A.C)"
+
+Test 3.2
+  $ $MERLIN single case-analysis -start 6:9 -end 6:10 -filename refine_pattern.ml <<EOF | \
+  > tr -d '\n' | jq '.value[1]'
+  > module A = struct type t = B | C end
+  > open A
+  > let _ =
+  >   match (None : t option) with
+  >   | None -> ()
+  >   | Some _ -> ()
+  > EOF
+  "Some (B) |Some (C)"
diff --git a/tests/test-dirs/destruct/record.t b/tests/test-dirs/destruct/record.t
new file mode 100644
index 0000000..942e5d8
--- /dev/null
+++ b/tests/test-dirs/destruct/record.t
@@ -0,0 +1,101 @@
+Field projections should be handled the same way, regardless of whether we've
+selected:
+
+- the whole expression
+
+  $ $MERLIN single case-analysis -start 2:2 -end 2:11 -filename test.ml <<EOF
+  > let f (x : int ref) =
+  >   x.contents
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 2
+        },
+        "end": {
+          "line": 2,
+          "col": 12
+        }
+      },
+      "match x.contents with | 0 -> _ | _ -> _"
+    ],
+    "notifications": []
+  }
+
+- just the label
+
+  $ $MERLIN single case-analysis -start 2:4 -end 2:11 -filename test.ml <<EOF
+  > let f (x : int ref) =
+  >   x.contents
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 2
+        },
+        "end": {
+          "line": 2,
+          "col": 12
+        }
+      },
+      "match x.contents with | 0 -> _ | _ -> _"
+    ],
+    "notifications": []
+  }
+
+However, when calling on the field of a record literal, we should destruct the
+whole record expression (even though it's pointless):
+
+  $ $MERLIN single case-analysis -start 2:4 -end 2:11 -filename test.ml <<EOF
+  > let f () =
+  >   { contents = 3 }
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 2
+        },
+        "end": {
+          "line": 2,
+          "col": 18
+        }
+      },
+      "match { contents = 3 } with | { contents } -> _"
+    ],
+    "notifications": []
+  }
+
+
+Record fields in patterns should also be refinable:
+
+  $ $MERLIN single case-analysis -start 3:6 -end 3:13 -filename test.ml <<EOF
+  > let f (x : int ref) =
+  >   match x with
+  >   | { contents } -> ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 4
+        },
+        "end": {
+          "line": 3,
+          "col": 16
+        }
+      },
+      "{ contents = 0 } |{ contents = _ }"
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/destruct/refine.t b/tests/test-dirs/destruct/refine.t
new file mode 100644
index 0000000..9b08cb4
--- /dev/null
+++ b/tests/test-dirs/destruct/refine.t
@@ -0,0 +1,276 @@
+###############
+## SUM TYPES ##
+###############
+
+Test 1.1 : option refine
+
+  $ $MERLIN single case-analysis -start 4:9 -end 4:10 -filename refine_pattern.ml <<EOF
+  > let _ =
+  >   match (None : unit option) with
+  >   | None -> ()
+  >   | Some _ -> ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 4,
+          "col": 9
+        },
+        "end": {
+          "line": 4,
+          "col": 10
+        }
+      },
+      "()"
+    ],
+    "notifications": []
+  }
+
+Test 1.2 : option refine
+
+  $ cat >typ12.ml <<EOF
+  > type t = A | B of int
+  > let _ =
+  >   match (None : t option) with
+  >   | None -> ()
+  >   | Some _ -> ()
+  > EOF
+
+  $ $MERLIN single case-analysis -start 5:9 -end 5:10 -filename typ12.ml < typ12.ml \
+  > sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.'
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 5,
+          "col": 4
+        },
+        "end": {
+          "line": 5,
+          "col": 10
+        }
+      },
+      "Some (A)|Some (B _)"
+    ],
+    "notifications": []
+  }
+
+Test 1.3 : FIXME ? int option
+
+  $ cat >typ13.ml <<EOF
+  > let _ =
+  >   match (None : int option) with
+  >   | None -> ()
+  >   | Some _ -> ()
+  > EOF
+
+  $ $MERLIN single case-analysis -start 4:9 -end 4:10 -filename typ13.ml < typ13.ml \
+  > sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.'
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 4,
+          "col": 4
+        },
+        "end": {
+          "line": 4,
+          "col": 10
+        }
+      },
+      "Some 0|Some _"
+    ],
+    "notifications": []
+  }
+
+#############
+## RECORDS ##
+#############
+
+Test 2.1
+
+  $ cat >typ4.ml <<EOF
+  > type b = C | D of string
+  > type a = A | B of b
+  > type recd = { a : a }
+  > let f (x : recd) =
+  >   match x with
+  >   | { a = A } -> ()
+  >   | { a = B _ } -> ()
+  > EOF
+
+  $ $MERLIN single case-analysis -start 7:12 -end 7:12 -filename typ4.ml <typ4.ml | \
+  > sed -e 's/ *| */|/g' | tr -d '\n' | jq '.'
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 7,
+          "col": 4
+        },
+        "end": {
+          "line": 7,
+          "col": 15
+        }
+      },
+      "{ a = B (C) }|{ a = B (D _) }"
+    ],
+    "notifications": []
+  }
+
+Test 2.2
+
+  $ cat >typ4b.ml <<EOF
+  > type a = A | B
+  > type recd = { x : a; y : bool; z : a }
+  > let f (r : recd) =
+  >   match r with
+  >   | { x = _ ; y ; _ } -> ()
+  > EOF
+
+  $ $MERLIN single case-analysis -start 5:11 -end 5:11 -filename typ4b.ml <typ4b.ml | \
+  > sed -e 's/ *| */|/g' | tr -d '\n' | jq '.'
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 5,
+          "col": 4
+        },
+        "end": {
+          "line": 5,
+          "col": 21
+        }
+      },
+      "{ x = A; y;_}|{ x = B; y;_}"
+    ],
+    "notifications": []
+  }
+
+##########################
+## POLYMORPHIC VARIANTS ##
+##########################
+
+Test 3.1
+
+  $ cat >typ2.ml <<EOF
+  > type blues = [ \`Cyan | \`Methyl ]
+  > type basic_color = [ \`Blue of blues ]
+  > let f (x : basic_color) =
+  >   match x with
+  >   | \`Blue _ -> ()
+  > EOF
+
+  $ $MERLIN single case-analysis -start 5:11 -end 5:11 -filename typ2.ml <typ2.ml | \
+  > sed -e 's/ *| */|/g' | tr -d '\n' | jq '.'
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 5,
+          "col": 4
+        },
+        "end": {
+          "line": 5,
+          "col": 11
+        }
+      },
+      "`Blue `Methyl|`Blue `Cyan"
+    ],
+    "notifications": []
+  }
+
+##########
+## GADT ##
+##########
+
+Test 4.1 : Fixme: missing space and ()
+
+  $ cat >typ3.ml <<EOF
+  > type _ sub_t =
+  >   | A : int -> int sub_t
+  >   | B : int -> float sub_t
+  > type _ term =
+  >  | Int : int sub_t -> int term
+  > let eval : type a. a term -> a term =
+  >   fun x : a term -> match x with
+  >   | Int _ -> ()
+  > EOF
+
+  $ $MERLIN single case-analysis -start 8:8 -end 8:8 -filename typ3.ml <typ3.ml | \
+  > sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.'
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 8,
+          "col": 8
+        },
+        "end": {
+          "line": 8,
+          "col": 9
+        }
+      },
+      "A_"
+    ],
+    "notifications": []
+  }
+
+Test 4.2
+
+  $ cat >typ3b.ml <<EOF
+  > type _ sub_t =
+  >   | A : int -> int sub_t
+  >   | B : int -> int sub_t
+  > type _ term =
+  >  | Int : int sub_t -> int term
+  > let eval : type a. a term -> a term =
+  >   fun x : a term -> match x with
+  >   | Int _ -> ()
+  > EOF
+
+  $ $MERLIN single case-analysis -start 8:8 -end 8:8 -filename typ3b.ml <typ3b.ml | \
+  > sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.'
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 8,
+          "col": 4
+        },
+        "end": {
+          "line": 8,
+          "col": 9
+        }
+      },
+      "Int (A _)|Int (B _)"
+    ],
+    "notifications": []
+  }
+
+############
+## ERRORS ##
+############
+
+Test 5.1 : Nothing to do
+
+  $ $MERLIN single case-analysis -start 4:9 -end 4:11 -filename nothing_to_do.ml <<EOF
+  > let _ =
+  >   match (None : unit option) with
+  >   | None -> ()
+  >   | Some () -> ()
+  > EOF
+  {
+    "class": "error",
+    "value": "Nothing to do",
+    "notifications": []
+  }
diff --git a/tests/test-dirs/document/dune b/tests/test-dirs/document/dune
new file mode 100644
index 0000000..19ad803
--- /dev/null
+++ b/tests/test-dirs/document/dune
@@ -0,0 +1,3 @@
+(cram
+ (applies_to src-documentation module-doc)
+ (enabled_if (<> %{architecture} i386)))
diff --git a/tests/test-dirs/document/issue1513.t b/tests/test-dirs/document/issue1513.t
new file mode 100644
index 0000000..770783f
--- /dev/null
+++ b/tests/test-dirs/document/issue1513.t
@@ -0,0 +1,54 @@
+Merlin should show comments for a type's constructor from another module:
+  $ cat >naux.ml <<EOF
+  > type t =
+  >   | A
+  >   (**A Comment *)
+  >   | B
+  >   (**B Comment *)
+  >   | C
+  > EOF
+
+  $ cat >main.ml <<EOF
+  > let _ = Naux.A
+  > let _ = Naux.B
+  > let _ = Naux.C
+  > EOF
+
+  $ $OCAMLC -c -bin-annot naux.ml
+
+FIXME: the constructors are missing from the [uid_to_loc] tables
+  $ $MERLIN single document -position 1:13 \
+  > -filename main.ml <main.ml | jq '.value'
+  "No documentation available"
+
+  $ $MERLIN single document -position 2:13 \
+  > -filename main.ml <main.ml | tr '\n' ' ' | jq '.value'
+  "No documentation available"
+
+  $ $MERLIN single document -position 3:13 \
+  > -filename main.ml <main.ml | jq '.value'
+  "No documentation available"
+
+  $ rm naux.cmt
+
+Merlin should show comments for a type's constructor from the current module:
+  $ cat >main.ml <<EOF
+  > type t =
+  >   | A
+  >   (**A Comment *)
+  >   | B
+  >   (**B Comment *)
+  >   | C
+  > EOF
+
+  $ $MERLIN single document -position 2:4 \
+  > -filename main.ml <main.ml | jq '.value'
+  "A Comment"
+
+  $ $MERLIN single document -position 4:4 \
+  > -filename main.ml <main.ml | tr '\n' ' ' | jq '.value'
+  "B Comment"
+
+  $ $MERLIN single document -position 6:4 \
+  > -filename main.ml <main.ml | jq '.value'
+  "No documentation available"
diff --git a/tests/test-dirs/document/label-comments.t b/tests/test-dirs/document/label-comments.t
new file mode 100644
index 0000000..174caf1
--- /dev/null
+++ b/tests/test-dirs/document/label-comments.t
@@ -0,0 +1,66 @@
+Examples adapted from https://v2.ocaml.org/manual/doccomments.html#ss:label-comments.
+We do not currently show these comments:
+
+  $ cat >main.ml <<EOF
+  > type t1 =
+  >   lbl_a:unit (** lbl_a comment *) ->
+  >   lbl_b:unit (** lbl_b comment *) -> unit
+  > let _test (f: t1) =
+  >   let _ = f ~lbl_a:() ~lbl_b:() in
+  >   ()
+  > EOF
+
+FIXME: expected "lbl_b comment"
+
+  $ $MERLIN single document -position 5:15 \
+  > -filename main.ml <main.ml | jq '.value'
+  "Not a valid identifier"
+
+  $ cat >main.ml <<EOF
+  > type t = <
+  >   meth_a: unit; (** meth_a comment *)
+  >   meth_b: unit; (** meth_b comment *)
+  >   >
+  > let _test (o: t3) =
+  >   o#meth_b
+  > EOF
+
+FIXME: expected "meth_b comment"
+
+  $ $MERLIN single document -position 6:6 \
+  > -filename main.ml <main.ml | jq '.value'
+  "Not in environment 'meth_b'"
+
+  $ cat >main.ml <<"EOF"
+  > type t = [
+  >   | `Poly_a (** Poly_a comment *)
+  >   | `Poly_b (** Poly_b comment *)
+  > ]
+  > let _: t4 =
+  > `Poly_b
+  > EOF
+
+FIXME: expected "Poly_b comment"
+
+  $ $MERLIN single document -position 6:4 \
+  > -filename main.ml <main.ml | jq '.value'
+  "Not a valid identifier"
+
+FIXME: expected "fld_b comment"
+
+  $ cat >main.ml <<EOF
+  > type t2 = {
+  >   fld_a: unit; (** fld_a comment *)
+  >   fld_b: unit; (** fld_b comment *)
+  >   fld_c: unit;
+  > }
+  > let _ = {
+  >   fld_a = ();
+  >   fld_b = ();
+  >   fld_c = ()
+  > }
+  > EOF
+
+  $ $MERLIN single document -position 8:4 \
+  > -filename main.ml <main.ml | jq '.value'
+  "No documentation available"
diff --git a/tests/test-dirs/document/module-doc.t b/tests/test-dirs/document/module-doc.t
new file mode 100644
index 0000000..5a7e8e1
--- /dev/null
+++ b/tests/test-dirs/document/module-doc.t
@@ -0,0 +1,47 @@
+  $ cat >dune-project <<EOF
+  > (lang dune 2.0)
+  > EOF
+
+  $ cat >lib.mli <<EOF
+  > (****************)
+  > (* SOME LICENCE *)
+  > (****************)
+  > 
+  > (** Documentation of Lib *)
+  > 
+  > (** Documentation of Lib.a *)
+  > type a = int
+  > EOF
+
+  $ cat >lib.ml <<EOF
+  > type a = int
+  > EOF
+
+  $ cat >main.ml <<EOF
+  > type t = Lib.a
+  > EOF
+
+  $ cat >dune <<EOF
+  > (executable (name main))
+  > EOF
+
+  $ dune build ./main.exe
+
+FIXME: the licence should be ignored ?
+  $ $MERLIN single document -position 1:11 -filename main.ml <main.ml
+  {
+    "class": "return",
+    "value": "No documentation available",
+    "notifications": []
+  }
+
+Without the licence it works as expected:
+  $ sed -i -e '1,4d' lib.mli
+  $ dune build ./main.exe
+
+  $ $MERLIN single document -position 1:11 -filename main.ml <main.ml
+  {
+    "class": "return",
+    "value": "Documentation of Lib",
+    "notifications": []
+  }
diff --git a/tests/test-dirs/document/src-documentation.t/dune b/tests/test-dirs/document/src-documentation.t/dune
new file mode 100644
index 0000000..f7a3fe6
--- /dev/null
+++ b/tests/test-dirs/document/src-documentation.t/dune
@@ -0,0 +1,2 @@
+(executable
+ (name doc))
diff --git a/tests/test-dirs/document/src-documentation.t/dune-project b/tests/test-dirs/document/src-documentation.t/dune-project
new file mode 100644
index 0000000..de4fc20
--- /dev/null
+++ b/tests/test-dirs/document/src-documentation.t/dune-project
@@ -0,0 +1 @@
+(lang dune 1.0)
diff --git a/tests/test-dirs/document/src-documentation.t/run.t b/tests/test-dirs/document/src-documentation.t/run.t
new file mode 100644
index 0000000..4f4c432
--- /dev/null
+++ b/tests/test-dirs/document/src-documentation.t/run.t
@@ -0,0 +1,53 @@
+  $ cat >a.ml <<EOF
+  > (** a function *)
+  > let b () = ()
+  > 
+  > (** A function *)
+  > let a () = ()
+  > 
+  > (** a function *)
+  > let c () = ()
+  > EOF
+
+  $ cat >doc.ml <<EOF
+  > (** first function *)
+  > let f () = ()
+  > 
+  > (** second function *)
+  > let g () = ()
+  > 
+  > let () = g (f ())
+  > 
+  > let list_rev = List.rev
+  > 
+  > let () = A.a ()
+  > EOF
+
+documentation for the last defined value (in the same file) is shown
+  $ $MERLIN single document -position 7:10 -filename doc.ml < doc.ml |
+  > jq '.value'
+  "second function"
+
+documentation for the non-last defined value (in the same file) is show
+(we care about "non-last" value because of issue #1261)
+  $ $MERLIN single document -position 7:13 -filename doc.ml < doc.ml |
+  > jq '.value'
+  "first function"
+
+  $ $MERLIN single document -position 9:6 -filename doc.ml < doc.ml |
+  > jq '.value'
+  "No documentation available"
+
+  $ $MERLIN single document -position 9:22 -filename doc.ml < doc.ml |
+  > jq '.value'
+  " List reversal. "
+
+  $ dune build --root=. ./doc.exe 2> /dev/null
+  $ cat >.merlin <<EOF
+  > B _build/default/.doc.eobjs/byte
+  > S .
+  > EOF
+
+  $ $MERLIN single document -position 11:12 -filename doc.ml < doc.ml |
+  > jq '.value'
+  " A function "
diff --git a/tests/test-dirs/document/unattached-comment.t b/tests/test-dirs/document/unattached-comment.t
new file mode 100644
index 0000000..d55eb48
--- /dev/null
+++ b/tests/test-dirs/document/unattached-comment.t
@@ -0,0 +1,33 @@
+A test showing that we manage to get docstrings even when they are not kept as
+attributes on the AST.
+
+  $ cat >test.ml <<EOF
+  > let foo x y = (** incorrect doc for foo *)
+  >   x + y
+  >  
+  > let bar = foo
+  > EOF
+
+  $ $MERLIN single document -position 4:13 -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": "incorrect doc for foo",
+    "notifications": []
+  }
+
+And that it also works outside of the current buffer:
+
+  $ $OCAMLC -c -bin-annot -w +50 test.ml
+  File "test.ml", line 1, characters 14-42:
+  1 | let foo x y = (** incorrect doc for foo *)
+                    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+  Warning 50 [unexpected-docstring]: unattached documentation comment (ignored)
+
+  $ $MERLIN single document -position 1:18 -filename outside.ml << EOF
+  > let bar = Test.foo
+  > EOF
+  {
+    "class": "return",
+    "value": "incorrect doc for foo",
+    "notifications": []
+  }
diff --git a/tests/test-dirs/dune b/tests/test-dirs/dune
new file mode 100755
index 0000000..aa9ad1d
--- /dev/null
+++ b/tests/test-dirs/dune
@@ -0,0 +1,12 @@
+(cram
+ (applies_to no-escape type-expr environment_on_open locate-type
+   polarity-search)
+ (enabled_if
+  (<> %{os_type} Win32)))
+
+(cram
+ (applies_to typing-recovery)
+ (enabled_if 
+  (and 
+   (<> %{ocaml_version} 4.12.0+multicore)
+   (<> %{ocaml_version} 4.12.0+domains))))
diff --git a/tests/test-dirs/enclosing.t b/tests/test-dirs/enclosing.t
new file mode 100644
index 0000000..8853c00
--- /dev/null
+++ b/tests/test-dirs/enclosing.t
@@ -0,0 +1,115 @@
+  $ cat >main.ml <<EOF
+  > module M = struct
+  >  let g =
+  >    let f x = fun y -> Int.add x y in
+  >    f 4 5
+  > end
+  > EOF
+
+  $ $MERLIN single enclosing -position 3:32 -filename main.ml <main.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 32
+        },
+        "end": {
+          "line": 3,
+          "col": 33
+        }
+      },
+      {
+        "start": {
+          "line": 3,
+          "col": 22
+        },
+        "end": {
+          "line": 3,
+          "col": 33
+        }
+      },
+      {
+        "start": {
+          "line": 3,
+          "col": 17
+        },
+        "end": {
+          "line": 3,
+          "col": 33
+        }
+      },
+      {
+        "start": {
+          "line": 3,
+          "col": 13
+        },
+        "end": {
+          "line": 3,
+          "col": 33
+        }
+      },
+      {
+        "start": {
+          "line": 3,
+          "col": 9
+        },
+        "end": {
+          "line": 3,
+          "col": 33
+        }
+      },
+      {
+        "start": {
+          "line": 3,
+          "col": 3
+        },
+        "end": {
+          "line": 3,
+          "col": 33
+        }
+      },
+      {
+        "start": {
+          "line": 3,
+          "col": 3
+        },
+        "end": {
+          "line": 4,
+          "col": 8
+        }
+      },
+      {
+        "start": {
+          "line": 2,
+          "col": 1
+        },
+        "end": {
+          "line": 4,
+          "col": 8
+        }
+      },
+      {
+        "start": {
+          "line": 1,
+          "col": 11
+        },
+        "end": {
+          "line": 5,
+          "col": 3
+        }
+      },
+      {
+        "start": {
+          "line": 1,
+          "col": 0
+        },
+        "end": {
+          "line": 5,
+          "col": 3
+        }
+      }
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/environment_on_open.t/environment_on_open.ml b/tests/test-dirs/environment_on_open.t/environment_on_open.ml
new file mode 100644
index 0000000..21f057e
--- /dev/null
+++ b/tests/test-dirs/environment_on_open.t/environment_on_open.ml
@@ -0,0 +1,6 @@
+module M = struct
+  (* should jump above this comment,
+     but jumps below it pre 4.08 *)
+  module M = struct end
+end
+open M
diff --git a/tests/test-dirs/environment_on_open.t/run.t b/tests/test-dirs/environment_on_open.t/run.t
new file mode 100644
index 0000000..f8f1705
--- /dev/null
+++ b/tests/test-dirs/environment_on_open.t/run.t
@@ -0,0 +1,13 @@
+  $ $MERLIN single locate -look-for ml -position 6:6 \
+  > -filename ./environment_on_open.ml < ./environment_on_open.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/environment_on_open.ml",
+      "pos": {
+        "line": 1,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/errors/error-in-constrained-env.t/run.t b/tests/test-dirs/errors/error-in-constrained-env.t/run.t
new file mode 100644
index 0000000..caf1d6b
--- /dev/null
+++ b/tests/test-dirs/errors/error-in-constrained-env.t/run.t
@@ -0,0 +1,28 @@
+In the example, typing "None" will fail. 
+Because the environment has constraints, the failure will happen between a
+begin_def and an end_def.
+Thus the error recovery will happen at the wrong level.
+The fix is to save and restore levels when attempting a recoverable typing.
+
+  $ $MERLIN single errors -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 7,
+          "col": 9
+        },
+        "end": {
+          "line": 7,
+          "col": 13
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "This expression has type 'a option but an expression was expected of type
+    a -> string"
+      }
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/errors/error-in-constrained-env.t/test.ml b/tests/test-dirs/errors/error-in-constrained-env.t/test.ml
new file mode 100644
index 0000000..a00b518
--- /dev/null
+++ b/tests/test-dirs/errors/error-in-constrained-env.t/test.ml
@@ -0,0 +1,7 @@
+type _ gadt =
+  | I : int gadt
+  | S : string gadt
+
+let show : type a. a gadt -> a -> string = function
+  | I -> string_of_int
+  | S -> None
diff --git a/tests/test-dirs/errors/error-node-line-break.t b/tests/test-dirs/errors/error-node-line-break.t
new file mode 100644
index 0000000..c5eca4f
--- /dev/null
+++ b/tests/test-dirs/errors/error-node-line-break.t
@@ -0,0 +1,25 @@
+  $ cat >test.ml <<EOF
+  > [%%ocaml.error "test with several words"]
+  > EOF
+
+  $ $MERLIN single errors -filename test.ml <test.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 3
+        },
+        "end": {
+          "line": 1,
+          "col": 14
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "test with several words"
+      }
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/errors/issue1222.t b/tests/test-dirs/errors/issue1222.t
new file mode 100644
index 0000000..277ced5
--- /dev/null
+++ b/tests/test-dirs/errors/issue1222.t
@@ -0,0 +1,26 @@
+  $ $MERLIN single errors -filename issue1222.ml <<EOF
+  > let minimal : type a. 'a t
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 22
+        },
+        "end": {
+          "line": 1,
+          "col": 24
+        },
+        "type": "parser",
+        "sub": [],
+        "valid": true,
+        "message": "In this scoped type, variable 'a is reserved for the local type a."
+      }
+    ],
+    "notifications": []
+  }
+
+Merlin would fail to catch this new exception:
+"In this scoped type, variable 'a is reserved for the local type a.",
diff --git a/tests/test-dirs/errors/typing-after-parsing.t/run.t b/tests/test-dirs/errors/typing-after-parsing.t/run.t
new file mode 100644
index 0000000..521ab96
--- /dev/null
+++ b/tests/test-dirs/errors/typing-after-parsing.t/run.t
@@ -0,0 +1,88 @@
+First ask for all the errors:
+
+  $ $MERLIN single errors -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 9
+        },
+        "end": {
+          "line": 3,
+          "col": 10
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "This expression has type int but an expression was expected of type unit"
+      },
+      {
+        "start": {
+          "line": 7,
+          "col": 9
+        },
+        "end": {
+          "line": 7,
+          "col": 10
+        },
+        "type": "parser",
+        "sub": [],
+        "valid": true,
+        "message": "Syntax error, expecting expr"
+      }
+    ],
+    "notifications": []
+  }
+
+Notice that the second type error is not returned, as it happens after the first
+syntax error.
+
+Now let's just ask for typing errors:
+
+  $ $MERLIN single errors -lexing false -parsing false -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 9
+        },
+        "end": {
+          "line": 3,
+          "col": 10
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "This expression has type int but an expression was expected of type unit"
+      }
+    ],
+    "notifications": []
+  }
+
+And let's also try filtering out type errors:
+
+  $ $MERLIN single errors -typing false -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 7,
+          "col": 9
+        },
+        "end": {
+          "line": 7,
+          "col": 10
+        },
+        "type": "parser",
+        "sub": [],
+        "valid": true,
+        "message": "Syntax error, expecting expr"
+      }
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/errors/typing-after-parsing.t/test.ml b/tests/test-dirs/errors/typing-after-parsing.t/test.ml
new file mode 100644
index 0000000..f0c05db
--- /dev/null
+++ b/tests/test-dirs/errors/typing-after-parsing.t/test.ml
@@ -0,0 +1,11 @@
+(* First a typing error *)
+
+let () = 3
+
+(* Then a parsing error *)
+
+let () = | 3
+
+(* Then a typing error again *)
+
+let () = 3
diff --git a/tests/test-dirs/inconsistent-assumptions.t b/tests/test-dirs/inconsistent-assumptions.t
new file mode 100644
index 0000000..dd7546f
--- /dev/null
+++ b/tests/test-dirs/inconsistent-assumptions.t
@@ -0,0 +1,102 @@
+Let us take the following project, that defines a library "my_lib":
+
+  $ cat > import.ml <<EOF
+  > module AB = struct
+  >   type t = A | B
+  > end
+  > let x = 3
+  > EOF
+
+  $ cat > bar.ml <<EOF
+  > open Import
+  > let b = AB.B
+  > EOF
+
+  $ echo "val x : int" > foo.mli
+  $ cat > foo.ml <<EOF
+  > open Import
+  > type t = A
+  > let _a : AB.t * t = A, A
+  > let x, _ = x + 1, Bar.b
+  > EOF
+
+  $ cat > my_lib.ml <<EOF
+  > module Bar = Bar
+  > module Foo = Foo
+  > let the_import_b = Bar.b
+  > EOF
+
+And assume it is being built with dune:
+
+  $ mkdir _build
+  $ cp *.ml *.mli _build/
+  $ cd _build
+  $ cat > my_lib__.ml <<EOF
+  > module Bar = My_lib__Bar
+  > module Foo = My_lib__Foo
+  > module Import = My_lib__Import
+  > EOF
+  $ $OCAMLC -c -no-alias-deps -w @a-40-41-42-49-70 -short-paths my_lib__.ml
+  $ $OCAMLC -c -w @a-40-41-42-49-70 -short-paths -open My_lib__ -o my_lib__Import import.ml
+  $ $OCAMLC -c -w @a-40-41-42-49-70 -short-paths -open My_lib__ -o my_lib__Bar bar.ml
+  $ $OCAMLC -c -w @a-40-41-42-49-70 -short-paths -open My_lib__ -o my_lib__Foo foo.mli
+  $ $OCAMLC -c -w @a-40-41-42-49-70 -short-paths -open My_lib__ -o my_lib__Foo foo.ml
+  $ $OCAMLC -c -w @a-40-41-42-49-70 -short-paths -open My_lib__ my_lib.ml
+  $ cd ..
+  $ cat > .merlin <<EOF
+  > EXCLUDE_QUERY_DIR
+  > FLG -w @a-40-41-42-49-70 -short-paths -open My_lib__
+  > B _build
+  > S .
+  > EOF
+
+Make sure merlin is happy:
+
+  $ $MERLIN single errors -filename foo.ml < foo.ml
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
+
+Do an update that breaks the build:
+
+  $ echo "let x = if x > 2 then 'c' else 'd'" >> import.ml
+  $ cp *.ml *.mli _build/
+  $ cd _build
+  $ $OCAMLC -c -w @a-40-41-42-49-70 -short-paths -open My_lib__ -o my_lib__Import import.ml
+  $ $OCAMLC -c -w @a-40-41-42-49-70 -short-paths -open My_lib__ -o my_lib__Bar bar.ml
+  $ $OCAMLC -c -w @a-40-41-42-49-70 -short-paths -open My_lib__ -o my_lib__Foo foo.ml
+  File "foo.ml", line 4, characters 11-12:
+  4 | let x, _ = x + 1, Bar.b
+                 ^
+  Error: This expression has type char but an expression was expected of type
+           int
+  [2]
+  $ cd ..
+
+Go to the file, and ask merlin to move you to the error:
+
+  $ $MERLIN single errors -filename foo.ml < foo.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 4,
+          "col": 11
+        },
+        "end": {
+          "line": 4,
+          "col": 12
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "This expression has type char but an expression was expected of type int"
+      }
+    ],
+    "notifications": []
+  }
+
+`Foo` does not depend on `My_lib`, but merlin tries to load it regardless.
diff --git a/tests/test-dirs/issue1109.t/issue1109.ml b/tests/test-dirs/issue1109.t/issue1109.ml
new file mode 100644
index 0000000..e554de7
--- /dev/null
+++ b/tests/test-dirs/issue1109.t/issue1109.ml
@@ -0,0 +1,5 @@
+let rec unit y = y
+and f : Unknown_module.t -> _ =
+ fun y -> y
+
+let g y = unit y
diff --git a/tests/test-dirs/issue1109.t/run.t b/tests/test-dirs/issue1109.t/run.t
new file mode 100644
index 0000000..37e5a13
--- /dev/null
+++ b/tests/test-dirs/issue1109.t/run.t
@@ -0,0 +1,28 @@
+  $ $MERLIN single type-enclosing -position 5:11 -verbosity 0 \
+  > -filename ./issue1109.ml < ./issue1109.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 5,
+        "col": 10
+      },
+      "end": {
+        "line": 5,
+        "col": 14
+      },
+      "type": "'a -> 'a",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 5,
+        "col": 10
+      },
+      "end": {
+        "line": 5,
+        "col": 16
+      },
+      "type": "'a",
+      "tail": "no"
+    }
+  ]
diff --git a/tests/test-dirs/issue1322.t/.merlin b/tests/test-dirs/issue1322.t/.merlin
new file mode 100644
index 0000000..fa6b64a
--- /dev/null
+++ b/tests/test-dirs/issue1322.t/.merlin
@@ -0,0 +1 @@
+FLG -short-paths
diff --git a/tests/test-dirs/issue1322.t/foo.ml b/tests/test-dirs/issue1322.t/foo.ml
new file mode 100644
index 0000000..89c1525
--- /dev/null
+++ b/tests/test-dirs/issue1322.t/foo.ml
@@ -0,0 +1,7 @@
+module type Monad = sig
+  type 'a t
+end
+module type Monad_option =
+  Monad
+    with type 'a t = 'a option
+    constraint 'a = int
diff --git a/tests/test-dirs/issue1322.t/nasty.ml b/tests/test-dirs/issue1322.t/nasty.ml
new file mode 100644
index 0000000..9218416
--- /dev/null
+++ b/tests/test-dirs/issue1322.t/nasty.ml
@@ -0,0 +1,9 @@
+module type S = sig
+  type 'a t = 'a
+    constraint 'a = < m : r >
+  and r = (< m : r >) t
+end
+
+module type S = sig type 'a t = 'a constraint 'a = < m : r > and r = < m : r > t end
+
+module type T = S with type 'a t = 'b constraint 'a = < m : 'b >
diff --git a/tests/test-dirs/issue1322.t/run.t b/tests/test-dirs/issue1322.t/run.t
new file mode 100644
index 0000000..7e21a0f
--- /dev/null
+++ b/tests/test-dirs/issue1322.t/run.t
@@ -0,0 +1,32 @@
+  $ $MERLIN single errors -filename foo.ml < foo.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 5,
+          "col": 2
+        },
+        "end": {
+          "line": 7,
+          "col": 23
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "In this `with' constraint, the new definition of t
+  does not match its original definition in the constrained signature:
+  Type declarations do not match:
+    type 'a t = 'a t constraint 'a = int
+  is not included in
+    type 'a t
+  Their constraints differ.
+  File \"foo.ml\", line 2, characters 2-11: Expected declaration
+  File \"foo.ml\", line 6, characters 9-54: Actual declaration"
+      }
+    ],
+    "notifications": []
+  }
+
+FIXME (appears undeterministic)
+$ $MERLIN single errors -filename nasty.ml < nasty.ml
diff --git a/tests/test-dirs/issue1506.t b/tests/test-dirs/issue1506.t
new file mode 100644
index 0000000..87c577a
--- /dev/null
+++ b/tests/test-dirs/issue1506.t
@@ -0,0 +1,15 @@
+  $ cat >prefix.ml <<EOF
+  > let ( ?? ) x = 2 * x in
+  > print_int (?? 21)
+  > EOF
+
+  $ $OCAMLC -o p.exe prefix.ml
+  $ ./p.exe
+  42
+
+Fixed: Old holes where interfering with operators (??). And Merlin would report
+the folloswng error: "-      "message": "let-extension (with punning) expected."
+  $ $MERLIN single errors \
+  > -filename prefix.ml <prefix.ml |
+  > jq '.value'
+  []
diff --git a/tests/test-dirs/locate-type.t/a.ml b/tests/test-dirs/locate-type.t/a.ml
new file mode 100644
index 0000000..4136ae4
--- /dev/null
+++ b/tests/test-dirs/locate-type.t/a.ml
@@ -0,0 +1,11 @@
+module T = struct
+  type t = X of int
+end
+
+module Y = struct
+  let y = T.X 1
+end
+
+let z = Y.y
+
+let z2 = B.x
diff --git a/tests/test-dirs/locate-type.t/b.ml b/tests/test-dirs/locate-type.t/b.ml
new file mode 100644
index 0000000..fd9d36c
--- /dev/null
+++ b/tests/test-dirs/locate-type.t/b.ml
@@ -0,0 +1,2 @@
+type foo = string option
+let x : foo = None
diff --git a/tests/test-dirs/locate-type.t/run.t b/tests/test-dirs/locate-type.t/run.t
new file mode 100644
index 0000000..f25f2f4
--- /dev/null
+++ b/tests/test-dirs/locate-type.t/run.t
@@ -0,0 +1,40 @@
+  $ $OCAMLC b.ml -bin-annot -c
+
+  $ $MERLIN single locate-type -position 6:6 -filename ./a.ml < ./a.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/a.ml",
+      "pos": {
+        "line": 2,
+        "col": 2
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate-type -workdir . -position 9:11 -filename a.ml < ./a.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/a.ml",
+      "pos": {
+        "line": 2,
+        "col": 2
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate-type -position 11:12 -filename ./a.ml < ./a.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/b.ml",
+      "pos": {
+        "line": 1,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/locate/ambiguity/dune b/tests/test-dirs/locate/ambiguity/dune
new file mode 100755
index 0000000..17599c5
--- /dev/null
+++ b/tests/test-dirs/locate/ambiguity/dune
@@ -0,0 +1,4 @@
+(cram
+ (applies_to rebinding)
+ (enabled_if
+  (<> %{os_type} Win32)))
diff --git a/tests/test-dirs/locate/ambiguity/not-in-env.t b/tests/test-dirs/locate/ambiguity/not-in-env.t
new file mode 100644
index 0000000..867a4fc
--- /dev/null
+++ b/tests/test-dirs/locate/ambiguity/not-in-env.t
@@ -0,0 +1,25 @@
+FIXME!
+
+We would like this to say "Not in the environment b", because no label
+declaration named b exists.
+For this to work, we would need to know that the cursor is on a label name,
+which we can't right now when looking on the recovered typedtree. We only know
+we're in an expression.
+If we switch our context analysis to work on the grammar, this might get better.
+Until then ...
+
+  $ $MERLIN single locate -look-for ml -position 2:10 -filename test.ml <<EOF
+  > let b = 10
+  > let x = { b = 9 }
+  > EOF
+  {
+    "class": "return",
+    "value": {
+      "file": "test.ml",
+      "pos": {
+        "line": 1,
+        "col": 4
+      }
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/locate/ambiguity/rebinding.t/rebinding.ml b/tests/test-dirs/locate/ambiguity/rebinding.t/rebinding.ml
new file mode 100644
index 0000000..6d05fd6
--- /dev/null
+++ b/tests/test-dirs/locate/ambiguity/rebinding.t/rebinding.ml
@@ -0,0 +1,15 @@
+module X = struct
+  module Y = struct
+    module Z = struct
+      let foo () = ()
+    end
+  end
+end
+
+open X.Y
+
+let () = Z.foo ()
+
+module X = X.Y
+
+let () = Z.foo ()
diff --git a/tests/test-dirs/locate/ambiguity/rebinding.t/run.t b/tests/test-dirs/locate/ambiguity/rebinding.t/run.t
new file mode 100644
index 0000000..534f1f0
--- /dev/null
+++ b/tests/test-dirs/locate/ambiguity/rebinding.t/run.t
@@ -0,0 +1,30 @@
+Jumping to Z.foo before the rebinding of X:
+
+  $ $MERLIN single locate -look-for ml -position 11:13 -filename ./rebinding.ml < ./rebinding.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/rebinding.ml",
+      "pos": {
+        "line": 4,
+        "col": 10
+      }
+    },
+    "notifications": []
+  }
+
+Jumping to Z.foo after the rebinding of X:
+
+  $ $MERLIN single locate -look-for ml -position 15:13 -filename ./rebinding.ml < ./rebinding.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/rebinding.ml",
+      "pos": {
+        "line": 4,
+        "col": 10
+      }
+    },
+    "notifications": []
+  }
+
diff --git a/tests/test-dirs/locate/context-detection/cd-field.t/field.ml b/tests/test-dirs/locate/context-detection/cd-field.t/field.ml
new file mode 100644
index 0000000..1876a28
--- /dev/null
+++ b/tests/test-dirs/locate/context-detection/cd-field.t/field.ml
@@ -0,0 +1,15 @@
+type t = { foo : int }
+
+let f t = t.foo
+
+let foo () = 3
+
+let f t = t.foo
+
+module X = struct
+  type t = { bar : int; baz : bool }
+end
+
+let bar = 123
+let baz = true
+let y = { X.bar ; baz }
diff --git a/tests/test-dirs/locate/context-detection/cd-field.t/run.t b/tests/test-dirs/locate/context-detection/cd-field.t/run.t
new file mode 100644
index 0000000..20ae655
--- /dev/null
+++ b/tests/test-dirs/locate/context-detection/cd-field.t/run.t
@@ -0,0 +1,55 @@
+
+  $ $MERLIN single locate -look-for ml -position 3:14 -filename ./field.ml < ./field.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/field.ml",
+      "pos": {
+        "line": 1,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for ml -position 7:14 -filename ./field.ml < ./field.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/field.ml",
+      "pos": {
+        "line": 1,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
+Merlin is confused by punned fields prefixed by the module. { X.bar } goes to
+the field bar rather than the identifier.
+  $ $MERLIN single locate -look-for ml -position 15:14 -filename ./field.ml < ./field.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/field.ml",
+      "pos": {
+        "line": 10,
+        "col": 2
+      }
+    },
+    "notifications": []
+  }
+
+Normal punning works as expected:
+  $ $MERLIN single locate -look-for ml -position 15:19 -filename ./field.ml < ./field.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/field.ml",
+      "pos": {
+        "line": 14,
+        "col": 4
+      }
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/locate/context-detection/cd-from_a_pattern.t/from_a_pattern.ml b/tests/test-dirs/locate/context-detection/cd-from_a_pattern.t/from_a_pattern.ml
new file mode 100644
index 0000000..32f13d8
--- /dev/null
+++ b/tests/test-dirs/locate/context-detection/cd-from_a_pattern.t/from_a_pattern.ml
@@ -0,0 +1,8 @@
+module Blah = struct
+  type t =
+    | A
+    | B
+end
+
+let f = function
+  | Blah.Q -> ()
diff --git a/tests/test-dirs/locate/context-detection/cd-from_a_pattern.t/run.t b/tests/test-dirs/locate/context-detection/cd-from_a_pattern.t/run.t
new file mode 100644
index 0000000..882936c
--- /dev/null
+++ b/tests/test-dirs/locate/context-detection/cd-from_a_pattern.t/run.t
@@ -0,0 +1,38 @@
+Confirm there is a type error:
+
+  $ $MERLIN single errors -filename ./from_a_pattern.ml < ./from_a_pattern.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 8,
+          "col": 4
+        },
+        "end": {
+          "line": 8,
+          "col": 10
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Unbound constructor Blah.Q"
+      }
+    ],
+    "notifications": []
+  }
+
+We call locate from the broken pattern:
+
+  $ $MERLIN single locate -look-for ml -position 8:7 -filename ./from_a_pattern.ml < ./from_a_pattern.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/from_a_pattern.ml",
+      "pos": {
+        "line": 1,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/locate/context-detection/cd-label.t/label.ml b/tests/test-dirs/locate/context-detection/cd-label.t/label.ml
new file mode 100644
index 0000000..a1d9650
--- /dev/null
+++ b/tests/test-dirs/locate/context-detection/cd-label.t/label.ml
@@ -0,0 +1,9 @@
+type t = { foo : int }
+
+let foo = 5
+let x = { foo }
+
+(* introducing a syntax error, just to see. *)
+
+let foo = 5 in
+let x = { foo }
diff --git a/tests/test-dirs/locate/context-detection/cd-label.t/run.t b/tests/test-dirs/locate/context-detection/cd-label.t/run.t
new file mode 100644
index 0000000..feac97a
--- /dev/null
+++ b/tests/test-dirs/locate/context-detection/cd-label.t/run.t
@@ -0,0 +1,27 @@
+
+  $ $MERLIN single locate -look-for ml -position 4:11 -filename ./label.ml < ./label.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/label.ml",
+      "pos": {
+        "line": 3,
+        "col": 4
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for ml -position 9:11 -filename ./label.ml < ./label.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/label.ml",
+      "pos": {
+        "line": 8,
+        "col": 4
+      }
+    },
+    "notifications": []
+  }
+
diff --git a/tests/test-dirs/locate/context-detection/cd-mod_constr.t/mod_constr.ml b/tests/test-dirs/locate/context-detection/cd-mod_constr.t/mod_constr.ml
new file mode 100644
index 0000000..fb043ef
--- /dev/null
+++ b/tests/test-dirs/locate/context-detection/cd-mod_constr.t/mod_constr.ml
@@ -0,0 +1,2 @@
+type t = String
+let x = String.concat
diff --git a/tests/test-dirs/locate/context-detection/cd-mod_constr.t/run.t b/tests/test-dirs/locate/context-detection/cd-mod_constr.t/run.t
new file mode 100644
index 0000000..7ece891
--- /dev/null
+++ b/tests/test-dirs/locate/context-detection/cd-mod_constr.t/run.t
@@ -0,0 +1,13 @@
+
+  $ $MERLIN single locate -look-for ml -position 2:13 -filename ./mod_constr.ml < ./mod_constr.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "lib/ocaml/string.ml",
+      "pos": {
+        "line": 1,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/locate/context-detection/cd-test.t/run.t b/tests/test-dirs/locate/context-detection/cd-test.t/run.t
new file mode 100644
index 0000000..aaafdc1
--- /dev/null
+++ b/tests/test-dirs/locate/context-detection/cd-test.t/run.t
@@ -0,0 +1,184 @@
+Trying them all:
+
+  $ $MERLIN single locate -look-for ml -position 5:9 -filename ./test.ml < ./test.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/test.ml",
+      "pos": {
+        "line": 1,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for ml -position 7:17 -filename ./test.ml < ./test.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/test.ml",
+      "pos": {
+        "line": 3,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for ml -position 9:12 -filename ./test.ml < ./test.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/test.ml",
+      "pos": {
+        "line": 3,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
+FIXME this should say "Already at definition point" (we're defining the label):
+
+  $ $MERLIN single locate -look-for ml -position 13:12 -filename ./test.ml < ./test.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/test.ml",
+      "pos": {
+        "line": 5,
+        "col": 4
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for ml -position 13:16 -filename ./test.ml < ./test.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/test.ml",
+      "pos": {
+        "line": 1,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for ml -position 16:12 -filename ./test.ml < ./test.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/test.ml",
+      "pos": {
+        "line": 5,
+        "col": 4
+      }
+    },
+    "notifications": []
+  }
+
+FIXME we failed to parse/reconstruct the ident, that's interesting
+
+  $ $MERLIN single locate -look-for ml -position 16:16 -filename ./test.ml < ./test.ml
+  {
+    "class": "return",
+    "value": "Not a valid identifier",
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for ml -position 16:20 -filename ./test.ml < ./test.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/test.ml",
+      "pos": {
+        "line": 1,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for ml -position 17:5 -filename ./test.ml < ./test.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/test.ml",
+      "pos": {
+        "line": 1,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for ml -position 18:15 -filename ./test.ml < ./test.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/test.ml",
+      "pos": {
+        "line": 11,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
+FIXME this should jump to line 11:
+
+  $ $MERLIN single locate -look-for ml -position 20:15 -filename ./test.ml < ./test.ml
+  {
+    "class": "return",
+    "value": "Already at definition point",
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for ml -position 23:7 -filename ./test.ml < ./test.ml
+  {
+    "class": "return",
+    "value": "Already at definition point",
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for ml -position 23:13 -filename ./test.ml < ./test.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/test.ml",
+      "pos": {
+        "line": 13,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for ml -position 24:3 -filename ./test.ml < ./test.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/test.ml",
+      "pos": {
+        "line": 23,
+        "col": 6
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for ml -position 24:5 -filename ./test.ml < ./test.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/test.ml",
+      "pos": {
+        "line": 13,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/locate/context-detection/cd-test.t/test.ml b/tests/test-dirs/locate/context-detection/cd-test.t/test.ml
new file mode 100644
index 0000000..3f37866
--- /dev/null
+++ b/tests/test-dirs/locate/context-detection/cd-test.t/test.ml
@@ -0,0 +1,24 @@
+type a = A
+
+module type a = sig end
+
+let a = A
+
+module type A = a
+
+module A : A = struct end
+
+exception A
+
+type r = { a : a }
+
+let test =
+  match ({ a }.a : a) with
+  | A -> ()
+  | exception A -> ()
+
+exception B = A
+
+let test = (* don't stress the parser so much *)
+  let a = { a = A } in
+  a.a
diff --git a/tests/test-dirs/locate/context-detection/dune b/tests/test-dirs/locate/context-detection/dune
new file mode 100755
index 0000000..62b29ea
--- /dev/null
+++ b/tests/test-dirs/locate/context-detection/dune
@@ -0,0 +1,4 @@
+(cram
+ (applies_to cd-field cd-from_a_pattern cd-label cd-mod_constr cd-test)
+ (enabled_if
+  (<> %{os_type} Win32)))
diff --git a/tests/test-dirs/locate/dune b/tests/test-dirs/locate/dune
new file mode 100755
index 0000000..8a9839f
--- /dev/null
+++ b/tests/test-dirs/locate/dune
@@ -0,0 +1,12 @@
+(cram
+ (applies_to looping-substitution mutually-recursive partial-cmt includes
+   issue802 issue845 issue1199 sig-substs l-413-features module-aliases)
+ (enabled_if
+  (<> %{os_type} Win32)))
+
+(cram
+ (applies_to issue1424 module-aliases in-generated-file)
+ (enabled_if
+  (and
+   (<> %{architecture} i386)
+   (<> %{os_type} Win32))))
diff --git a/tests/test-dirs/locate/functors/dune b/tests/test-dirs/locate/functors/dune
new file mode 100755
index 0000000..d0c5c05
--- /dev/null
+++ b/tests/test-dirs/locate/functors/dune
@@ -0,0 +1,5 @@
+(cram
+ (applies_to f-all_local f-from_application f-generative f-included
+   f-missed_shadowing f-nested_applications)
+ (enabled_if
+  (<> %{os_type} Win32)))
diff --git a/tests/test-dirs/locate/functors/f-all_local.t/all_local.ml b/tests/test-dirs/locate/functors/f-all_local.t/all_local.ml
new file mode 100644
index 0000000..ed866b8
--- /dev/null
+++ b/tests/test-dirs/locate/functors/f-all_local.t/all_local.ml
@@ -0,0 +1,20 @@
+module type S = sig
+  type t
+end
+
+module M = struct
+  type t = T
+end
+
+module Make(Arg : S) : S = struct
+  include Arg
+
+  type x = t
+
+  let foo : x -> x =
+    fun x -> x
+end
+
+module Foo = Make(M)
+
+type t = Foo.t
diff --git a/tests/test-dirs/locate/functors/f-all_local.t/run.t b/tests/test-dirs/locate/functors/f-all_local.t/run.t
new file mode 100644
index 0000000..8f12de3
--- /dev/null
+++ b/tests/test-dirs/locate/functors/f-all_local.t/run.t
@@ -0,0 +1,44 @@
+Check that we can jump locally inside the functor:
+
+  $ $MERLIN single locate -look-for ml -position 14:12 -filename ./all_local.ml < ./all_local.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/all_local.ml",
+      "pos": {
+        "line": 12,
+        "col": 2
+      }
+    },
+    "notifications": []
+  }
+
+Check that we can jump from inside the functor to the (sig of the) parameter:
+
+  $ $MERLIN single locate -look-for ml -position 12:11 -filename ./all_local.ml < ./all_local.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/all_local.ml",
+      "pos": {
+        "line": 9,
+        "col": 12
+      }
+    },
+    "notifications": []
+  }
+
+Check the argument is substituted for the parameter
+
+  $ $MERLIN single locate -look-for ml -position 20:13 -filename ./all_local.ml < ./all_local.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/all_local.ml",
+      "pos": {
+        "line": 6,
+        "col": 2
+      }
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/locate/functors/f-from_application.t/from_application.ml b/tests/test-dirs/locate/functors/f-from_application.t/from_application.ml
new file mode 100644
index 0000000..711215e
--- /dev/null
+++ b/tests/test-dirs/locate/functors/f-from_application.t/from_application.ml
@@ -0,0 +1,19 @@
+module Make(X : sig type t end) = struct
+  type t = X.t list
+end
+
+module A = struct
+  type t = int
+end
+
+type a = A
+
+module M1 = Make(A)
+
+module M2 = Make(struct
+    type indir = a
+
+    let _noise = ()
+
+    type t = indir
+  end)
diff --git a/tests/test-dirs/locate/functors/f-from_application.t/run.t b/tests/test-dirs/locate/functors/f-from_application.t/run.t
new file mode 100644
index 0000000..37624db
--- /dev/null
+++ b/tests/test-dirs/locate/functors/f-from_application.t/run.t
@@ -0,0 +1,46 @@
+Jump on the argument passed to the functor:
+FIXME: we confuse the module for the constructor and jump to the wrong place
+
+  $ $MERLIN single locate -look-for ml -position 11:18 -filename ./from_application.ml < ./from_application.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/from_application.ml",
+      "pos": {
+        "line": 5,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
+Jump from inside the functor application to inside the functor application:
+
+  $ $MERLIN single locate -look-for ml -position 18:16 -filename ./from_application.ml < ./from_application.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/from_application.ml",
+      "pos": {
+        "line": 14,
+        "col": 4
+      }
+    },
+    "notifications": []
+  }
+
+Jump from inside the functor application to the outer scope:
+
+  $ $MERLIN single locate -look-for ml -position 14:18 -filename ./from_application.ml < ./from_application.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/from_application.ml",
+      "pos": {
+        "line": 9,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
diff --git a/tests/test-dirs/locate/functors/f-generative.t/generative.ml b/tests/test-dirs/locate/functors/f-generative.t/generative.ml
new file mode 100644
index 0000000..0af2f36
--- /dev/null
+++ b/tests/test-dirs/locate/functors/f-generative.t/generative.ml
@@ -0,0 +1,13 @@
+module type S = sig
+
+  val foo : int -> int
+
+end
+
+module Make (Foo : sig type t end) (Bar : sig end) () : S = struct
+  let foo x = x + 1
+end
+
+module M = Make(struct type t = int end)(struct end)()
+
+let x = M.foo
diff --git a/tests/test-dirs/locate/functors/f-generative.t/run.t b/tests/test-dirs/locate/functors/f-generative.t/run.t
new file mode 100644
index 0000000..ba6c75e
--- /dev/null
+++ b/tests/test-dirs/locate/functors/f-generative.t/run.t
@@ -0,0 +1,14 @@
+Check that we handle generative functors properly:
+
+  $ $MERLIN single locate -position 13:12 -filename generative.ml < generative.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/generative.ml",
+      "pos": {
+        "line": 8,
+        "col": 6
+      }
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/locate/functors/f-included.t/included.ml b/tests/test-dirs/locate/functors/f-included.t/included.ml
new file mode 100644
index 0000000..3930cd9
--- /dev/null
+++ b/tests/test-dirs/locate/functors/f-included.t/included.ml
@@ -0,0 +1,22 @@
+module type S = sig
+  type t
+end
+
+module Set(Elt : S) : sig
+  type elt = Elt.t
+  type set = private elt list
+
+  val empty : set
+end = struct
+  type elt = Elt.t
+  type set = elt list
+
+  let empty = []
+end
+
+module Str = struct
+  include String
+  include Set(String)
+end
+
+let e = Str.empty
diff --git a/tests/test-dirs/locate/functors/f-included.t/run.t b/tests/test-dirs/locate/functors/f-included.t/run.t
new file mode 100644
index 0000000..faea416
--- /dev/null
+++ b/tests/test-dirs/locate/functors/f-included.t/run.t
@@ -0,0 +1,14 @@
+
+  $ $MERLIN single locate -look-for ml -position 22:15 \
+  > -filename ./included.ml < ./included.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/included.ml",
+      "pos": {
+        "line": 14,
+        "col": 6
+      }
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/locate/functors/f-missed_shadowing.t/missed_shadowing.ml b/tests/test-dirs/locate/functors/f-missed_shadowing.t/missed_shadowing.ml
new file mode 100644
index 0000000..b42dadb
--- /dev/null
+++ b/tests/test-dirs/locate/functors/f-missed_shadowing.t/missed_shadowing.ml
@@ -0,0 +1,11 @@
+module W = struct end
+
+module M (W : sig end) : sig end = struct
+  include W
+end
+
+module type X = sig end
+
+module N (X : X) : sig end = struct
+  include X
+end
diff --git a/tests/test-dirs/locate/functors/f-missed_shadowing.t/run.t b/tests/test-dirs/locate/functors/f-missed_shadowing.t/run.t
new file mode 100644
index 0000000..99b2260
--- /dev/null
+++ b/tests/test-dirs/locate/functors/f-missed_shadowing.t/run.t
@@ -0,0 +1,29 @@
+Reproduce bug described (and fixed) in commit e558d203334fd06f7653a6388b46dba895fb3ce9
+
+  $ $MERLIN single locate -look-for ml -position 4:10 \
+  > -filename ./missed_shadowing.ml < ./missed_shadowing.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/missed_shadowing.ml",
+      "pos": {
+        "line": 3,
+        "col": 10
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for ml -position 9:15 \
+  > -filename ./missed_shadowing.ml < ./missed_shadowing.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/missed_shadowing.ml",
+      "pos": {
+        "line": 7,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/locate/functors/f-nested_applications.t/nested_applications.ml b/tests/test-dirs/locate/functors/f-nested_applications.t/nested_applications.ml
new file mode 100644
index 0000000..aa18af3
--- /dev/null
+++ b/tests/test-dirs/locate/functors/f-nested_applications.t/nested_applications.ml
@@ -0,0 +1,33 @@
+module type S = sig
+  type t
+end
+
+module Identity(X : S) : S = X
+
+module Apply(Id : S -> S) = Id
+
+module Simple = struct
+  type t
+end
+
+module M1 = Identity(Identity(Simple))
+
+module M2 = Apply(Identity)(Simple)
+
+type t1 = M1.t
+
+type t2 = M2.t
+
+module Alternative_apply(Id : S -> S)(X : S) = struct include Id(X) end
+
+module M3 = Alternative_apply(Identity)(Simple)
+
+type t3 = M3.t
+
+module M4 = Alternative_apply(functor(X : S) -> X)(Simple)
+
+type t4 = M4.t
+
+module M5 = Identity((functor(X : S) -> X)(Simple))
+
+type t5 = M5.t
diff --git a/tests/test-dirs/locate/functors/f-nested_applications.t/run.t b/tests/test-dirs/locate/functors/f-nested_applications.t/run.t
new file mode 100644
index 0000000..7effdf2
--- /dev/null
+++ b/tests/test-dirs/locate/functors/f-nested_applications.t/run.t
@@ -0,0 +1,71 @@
+
+  $ $MERLIN single locate -look-for ml -position 17:14 \
+  > -filename ./nested_applications.ml < ./nested_applications.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/nested_applications.ml",
+      "pos": {
+        "line": 5,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for ml -position 19:14 \
+  > -filename ./nested_applications.ml < ./nested_applications.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/nested_applications.ml",
+      "pos": {
+        "line": 10,
+        "col": 2
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for ml -position 25:14 \
+  > -filename ./nested_applications.ml < ./nested_applications.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/nested_applications.ml",
+      "pos": {
+        "line": 10,
+        "col": 2
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for ml -position 29:14 \
+  > -filename ./nested_applications.ml < ./nested_applications.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/nested_applications.ml",
+      "pos": {
+        "line": 21,
+        "col": 54
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for ml -position 33:14 \
+  > -filename ./nested_applications.ml < ./nested_applications.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/nested_applications.ml",
+      "pos": {
+        "line": 5,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
diff --git a/tests/test-dirs/locate/in-generated-file.t/dune-project b/tests/test-dirs/locate/in-generated-file.t/dune-project
new file mode 100644
index 0000000..929c696
--- /dev/null
+++ b/tests/test-dirs/locate/in-generated-file.t/dune-project
@@ -0,0 +1 @@
+(lang dune 2.0)
diff --git a/tests/test-dirs/locate/in-generated-file.t/main.ml b/tests/test-dirs/locate/in-generated-file.t/main.ml
new file mode 100644
index 0000000..d6aba71
--- /dev/null
+++ b/tests/test-dirs/locate/in-generated-file.t/main.ml
@@ -0,0 +1 @@
+let () = Printf.printf "Hello, World: %i\n" Client.x
diff --git a/tests/test-dirs/locate/in-generated-file.t/run.t b/tests/test-dirs/locate/in-generated-file.t/run.t
new file mode 100644
index 0000000..abcb1dd
--- /dev/null
+++ b/tests/test-dirs/locate/in-generated-file.t/run.t
@@ -0,0 +1,63 @@
+  $ cat >dune <<EOF
+  > (executable
+  >  (name main)
+  >  (modules main)
+  >  (libraries client))
+  > 
+  > (rule
+  >  (targets client.ml)
+  > ; (mode (promote (until-clean)))
+  >  (action (write-file %{targets} "let x = 42")))
+  > 
+  > (library
+  >  (name client)
+  >  (modules client)
+  >  (wrapped false))
+  > EOF
+
+  $ dune exec ./main.exe
+  Hello, World: 42
+
+  $ cat _build/default/client.ml
+  let x = 42
+
+Locate fails to find the source if it is not promoted:
+  $ $MERLIN single locate -look-for ml -position 1:52 -filename main.ml <main.ml
+  {
+    "class": "return",
+    "value": "'Client.x' seems to originate from 'Client' whose ML file could not be found",
+    "notifications": []
+  }
+
+A solution is to promote the generated file to the source tree:
+  $ cat >dune <<EOF
+  > (executable
+  >  (name main)
+  >  (modules main)
+  >  (libraries client))
+  > 
+  > (rule
+  >  (targets client.ml)
+  >  (mode (promote (until-clean)))
+  >  (action (write-file %{targets} "let x = 42")))
+  > 
+  > (library
+  >  (name client)
+  >  (modules client)
+  >  (wrapped false))
+  > EOF
+
+  $ dune build ./main.exe
+
+  $ $MERLIN single locate -look-for ml -position 1:52 -filename main.ml <main.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/client.ml",
+      "pos": {
+        "line": 1,
+        "col": 4
+      }
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/locate/includes.t/foo.ml b/tests/test-dirs/locate/includes.t/foo.ml
new file mode 100644
index 0000000..732f74e
--- /dev/null
+++ b/tests/test-dirs/locate/includes.t/foo.ml
@@ -0,0 +1 @@
+type 'a t = T of 'a
diff --git a/tests/test-dirs/locate/includes.t/run.t b/tests/test-dirs/locate/includes.t/run.t
new file mode 100644
index 0000000..6ffd20e
--- /dev/null
+++ b/tests/test-dirs/locate/includes.t/run.t
@@ -0,0 +1,37 @@
+We include another unit, compiled with -no-keep-locs, so there are no locations
+in the environment to fallback to:
+
+  $ $OCAMLC -c -bin-annot -no-keep-locs foo.ml
+
+Test when the include is a name, this should directly redirect us to the right
+thing.
+
+  $ $MERLIN single locate -look-for mli -position 4:17 -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/foo.ml",
+      "pos": {
+        "line": 1,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
+Test including a structure: there we will want to look up the ident again inside
+the structure, but the stamp will have changed:
+
+  $ $MERLIN single locate -look-for mli -position 10:17 -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/foo.ml",
+      "pos": {
+        "line": 1,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
diff --git a/tests/test-dirs/locate/includes.t/test.ml b/tests/test-dirs/locate/includes.t/test.ml
new file mode 100644
index 0000000..11e7cf5
--- /dev/null
+++ b/tests/test-dirs/locate/includes.t/test.ml
@@ -0,0 +1,11 @@
+module type S1 = sig
+  include module type of Foo
+
+  val foo : int t
+end
+
+module type S2 = sig
+  include module type of struct include Foo end
+
+  val foo : int t
+end
diff --git a/tests/test-dirs/locate/issue1199.t b/tests/test-dirs/locate/issue1199.t
new file mode 100644
index 0000000..86bc6b1
--- /dev/null
+++ b/tests/test-dirs/locate/issue1199.t
@@ -0,0 +1,37 @@
+When going to the definition of a module defined by a functor, merlin jumps
+straight to the functor.
+
+  $ cat > func.ml <<EOF
+  > module Make () = struct
+  >   let u = ()
+  > end
+  > 
+  > module T = Make ();;
+  > 
+  > let () = T.u
+  > EOF
+
+  $ $MERLIN single locate -look-for ml -position 7:11 -filename ./func.ml < ./func.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/func.ml",
+      "pos": {
+        "line": 2,
+        "col": 6
+      }
+    },
+    "notifications": []
+  }
+  $ $MERLIN single locate -look-for ml -position 7:9 -filename ./func.ml < ./func.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/func.ml",
+      "pos": {
+        "line": 5,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/locate/issue1398.t/issue1398.ml b/tests/test-dirs/locate/issue1398.t/issue1398.ml
new file mode 100644
index 0000000..480c5b1
--- /dev/null
+++ b/tests/test-dirs/locate/issue1398.t/issue1398.ml
@@ -0,0 +1,4 @@
+let (let++) x f = f x
+let (and++) a b = (a, b) ;;
+let ops = (let++), (and++) ;;
+let++ x = 3 and++ y = 4 in x + y
diff --git a/tests/test-dirs/locate/issue1398.t/run.t b/tests/test-dirs/locate/issue1398.t/run.t
new file mode 100644
index 0000000..9145509
--- /dev/null
+++ b/tests/test-dirs/locate/issue1398.t/run.t
@@ -0,0 +1,59 @@
+Test locating definition of let-based binding operator, from reified syntax:
+
+  $ $MERLIN single locate -position 3:11 ./issue1398.ml < ./issue1398.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "*buffer*",
+      "pos": {
+        "line": 1,
+        "col": 4
+      }
+    },
+    "notifications": []
+  }
+
+Test locating definition of and-based binding operator, from reified syntax:
+
+  $ $MERLIN single locate -position 3:20 ./issue1398.ml < ./issue1398.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "*buffer*",
+      "pos": {
+        "line": 2,
+        "col": 4
+      }
+    },
+    "notifications": []
+  }
+
+Test locating definition of let-based binding operator, from operator syntax:
+
+  $ $MERLIN single locate -position 4:0 ./issue1398.ml < ./issue1398.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "*buffer*",
+      "pos": {
+        "line": 1,
+        "col": 4
+      }
+    },
+    "notifications": []
+  }
+
+Test locating definition of and-based binding operator, from operator syntax:
+
+  $ $MERLIN single locate -position 4:12 ./issue1398.ml < ./issue1398.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "*buffer*",
+      "pos": {
+        "line": 2,
+        "col": 4
+      }
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/locate/issue1424.t b/tests/test-dirs/locate/issue1424.t
new file mode 100644
index 0000000..874a14a
--- /dev/null
+++ b/tests/test-dirs/locate/issue1424.t
@@ -0,0 +1,44 @@
+  $ cat >dune-project <<EOF
+  > (lang dune 2.8)
+  > EOF
+
+  $ cat >dune <<EOF
+  > (executable (name test))
+  > EOF
+
+  $ cat >test.ml <<EOF
+  > let _ = Test2.foo
+  > EOF
+
+  $ cat >test2.ml <<EOF
+  > let foo = 42
+  > EOF
+
+  $ cat >test2.mli <<EOF
+  > val foo : int
+  > EOF
+
+  $ dune build
+
+Jump to interface:
+  $ $MERLIN single locate -look-for mli -position 1:16 \
+  > -filename test.ml <test.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/test2.mli",
+    "pos": {
+      "line": 1,
+      "col": 0
+    }
+  }
+
+Jump to definition:
+FIXME: it should jump to the ml file
+  $ $MERLIN single locate -look-for ml -position 1:16 \
+  > -filename test.ml <test.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/test2.mli",
+    "pos": {
+      "line": 1,
+      "col": 0
+    }
+  }
diff --git a/tests/test-dirs/locate/issue802.t/a.ml b/tests/test-dirs/locate/issue802.t/a.ml
new file mode 100644
index 0000000..da15870
--- /dev/null
+++ b/tests/test-dirs/locate/issue802.t/a.ml
@@ -0,0 +1,7 @@
+open Error
+
+let f () = raise MyError
+
+let g () = Constructor
+
+let c : ext = C1
diff --git a/tests/test-dirs/locate/issue802.t/error.ml b/tests/test-dirs/locate/issue802.t/error.ml
new file mode 100644
index 0000000..63d72fb
--- /dev/null
+++ b/tests/test-dirs/locate/issue802.t/error.ml
@@ -0,0 +1,7 @@
+type t = Constructor
+
+exception MyError
+
+type ext = ..
+
+type ext += C1
diff --git a/tests/test-dirs/locate/issue802.t/mylib__.ml b/tests/test-dirs/locate/issue802.t/mylib__.ml
new file mode 100644
index 0000000..78f3979
--- /dev/null
+++ b/tests/test-dirs/locate/issue802.t/mylib__.ml
@@ -0,0 +1,2 @@
+module A = Mylib__A
+module Error = Mylib__Error
diff --git a/tests/test-dirs/locate/issue802.t/run.t b/tests/test-dirs/locate/issue802.t/run.t
new file mode 100644
index 0000000..73505e9
--- /dev/null
+++ b/tests/test-dirs/locate/issue802.t/run.t
@@ -0,0 +1,67 @@
+  $ echo "FLG -open Mylib__" > .merlin
+
+Compile the various units as dune would:
+
+  $ $OCAMLC -c -no-alias-deps -w -49 -bin-annot mylib__.ml
+  $ $OCAMLC -c -no-alias-deps -bin-annot -open Mylib__ -o Mylib__Error error.ml
+  $ $OCAMLC -c -no-alias-deps -bin-annot -open Mylib__ -o Mylib__A a.ml
+
+Test jumping from a normal constructor:
+
+  $ $MERLIN single locate -look-for ml -position 5:21 -filename ./a.ml < ./a.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/error.ml",
+      "pos": {
+        "line": 1,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
+From an exception:
+
+  $ $MERLIN single locate -look-for ml -position 3:21 -filename ./a.ml < ./a.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/error.ml",
+      "pos": {
+        "line": 3,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
+From an extension constructor:
+
+  $ $MERLIN single locate -look-for ml -position 7:16 -filename ./a.ml < ./a.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/error.ml",
+      "pos": {
+        "line": 7,
+        "col": 12
+      }
+    },
+    "notifications": []
+  }
+
+And from the extensible type name itself:
+
+  $ $MERLIN single locate -look-for ml -position 7:10 -filename ./a.ml < ./a.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/error.ml",
+      "pos": {
+        "line": 5,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/locate/issue845.t/local_map.ml b/tests/test-dirs/locate/issue845.t/local_map.ml
new file mode 100644
index 0000000..27926f9
--- /dev/null
+++ b/tests/test-dirs/locate/issue845.t/local_map.ml
@@ -0,0 +1,3 @@
+module Make(X : Map.OrderedType) = struct
+  include X
+end
diff --git a/tests/test-dirs/locate/issue845.t/local_map.mli b/tests/test-dirs/locate/issue845.t/local_map.mli
new file mode 100644
index 0000000..661a531
--- /dev/null
+++ b/tests/test-dirs/locate/issue845.t/local_map.mli
@@ -0,0 +1,3 @@
+module Make(X : Map.OrderedType) : sig
+  include Map.OrderedType with type t = X.t
+end
diff --git a/tests/test-dirs/locate/issue845.t/run.t b/tests/test-dirs/locate/issue845.t/run.t
new file mode 100644
index 0000000..3dafe6f
--- /dev/null
+++ b/tests/test-dirs/locate/issue845.t/run.t
@@ -0,0 +1,47 @@
+To properly test this, we need to have the functor in a different file than the
+one we jump from, otherwise we will get a location from the environment, which
+can be used as a fallback something fails later on.
+
+And we also do not want to use a functor from the stdlib, because locations,
+paths, etc. will change between versions of OCaml, so we define and compile a
+module containing a functor locally:
+
+  $ $OCAMLC -c -bin-annot local_map.mli
+  $ $OCAMLC -c -bin-annot local_map.ml
+
+Test jumping to impl:
+
+FIXME: this jumps to the .mli...
+
+  $ $MERLIN single locate -look-for ml -position 1:24 -filename test.ml <<EOF
+  > module SM = Local_map.Make(String)
+  > EOF
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/local_map.ml",
+      "pos": {
+        "line": 1,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
+Test jumping to intf:
+
+  $ $MERLIN single locate -look-for mli -position 1:24 -filename test.ml <<EOF
+  > module SM = Local_map.Make(String)
+  > EOF
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/local_map.mli",
+      "pos": {
+        "line": 1,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
diff --git a/tests/test-dirs/locate/issue949.t/issue949.ml b/tests/test-dirs/locate/issue949.t/issue949.ml
new file mode 100644
index 0000000..f10b2d6
--- /dev/null
+++ b/tests/test-dirs/locate/issue949.t/issue949.ml
@@ -0,0 +1,2 @@
+module A = struct let (+.) a b = a +. b end
+let f x = A.(x +. 1.)
diff --git a/tests/test-dirs/locate/issue949.t/run.t b/tests/test-dirs/locate/issue949.t/run.t
new file mode 100644
index 0000000..fa80cce
--- /dev/null
+++ b/tests/test-dirs/locate/issue949.t/run.t
@@ -0,0 +1,8 @@
+This test is for testing the behavior of identifiers with a . in them:
+
+  $ $MERLIN single locate -look-for ml -position 2:16 ./issue949.ml < ./issue949.ml
+  {
+    "class": "return",
+    "value": "Not in environment ''",
+    "notifications": []
+  }
diff --git a/tests/test-dirs/locate/l-413-features.t b/tests/test-dirs/locate/l-413-features.t
new file mode 100644
index 0000000..9568257
--- /dev/null
+++ b/tests/test-dirs/locate/l-413-features.t
@@ -0,0 +1,94 @@
+Named existentials in patterns
+
+  $ $MERLIN single locate -position 3:59 \
+  > -filename test.ml <<EOF
+  > type _ ty = Int : int ty
+  > type dyn = Dyn : 'a ty * 'a -> dyn
+  > let f = function Dyn (type a) (w, x : a ty * a) -> ignore (x : a)
+  > EOF
+  {
+    "class": "return",
+    "value": {
+      "file": "test.ml",
+      "pos": {
+        "line": 3,
+        "col": 34
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -position 3:63 \
+  > -filename test.ml <<EOF
+  > type _ ty = Int : int ty
+  > type dyn = Dyn : 'a ty * 'a -> dyn
+  > let f = function Dyn (type a) (w, x : a ty * a) -> ignore (x : a)
+  > EOF
+  {
+    "class": "return",
+    "value": {
+      "file": "test.ml",
+      "pos": {
+        "line": 3,
+        "col": 27
+      }
+    },
+    "notifications": []
+  }
+
+
+Module types substitutions
+  $ cat >mtsubst.ml <<EOF
+  > module type ENDO = sig
+  >   module type T
+  >   module F: T -> T
+  > end
+  > module Endo(X: sig module type T end): ENDO 
+  >   with module type T = X.T = struct
+  >   module type T = X.T
+  >   module F(X:T) = X
+  > end
+  > EOF
+
+  $ $MERLIN single locate -position 6:25 \
+  > -filename mtsubst.ml < mtsubst.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/mtsubst.ml",
+      "pos": {
+        "line": 5,
+        "col": 19
+      }
+    },
+    "notifications": []
+  }
+
+
+
+  $ cat >mtsubst.ml <<EOF
+  > module type ENDO = sig
+  >   module type T
+  >   module F: T -> T
+  > end
+  > module Endo(X: sig module type T end): ENDO 
+  >   with module type T := X.T = struct
+  >   module type T = X.T
+  >   module F(X:T) = X
+  > end
+  > EOF
+
+  $ $MERLIN single locate -position 6:26 \
+  > -filename mtsubst.ml < mtsubst.ml 
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/mtsubst.ml",
+      "pos": {
+        "line": 5,
+        "col": 19
+      }
+    },
+    "notifications": []
+  }
+ 
diff --git a/tests/test-dirs/locate/local-definitions/dune b/tests/test-dirs/locate/local-definitions/dune
new file mode 100755
index 0000000..00dcdb5
--- /dev/null
+++ b/tests/test-dirs/locate/local-definitions/dune
@@ -0,0 +1,4 @@
+(cram
+ (applies_to issue798 issue806)
+ (enabled_if
+  (<> %{os_type} Win32)))
diff --git a/tests/test-dirs/locate/local-definitions/issue798.t/issue798.ml b/tests/test-dirs/locate/local-definitions/issue798.t/issue798.ml
new file mode 100644
index 0000000..19d2825
--- /dev/null
+++ b/tests/test-dirs/locate/local-definitions/issue798.t/issue798.ml
@@ -0,0 +1,11 @@
+module List =
+  struct
+    include List
+    let foo l =
+      match l with
+      | hd :: tl ->
+         let _ = hd in
+         assert false
+      | [] ->
+         assert false
+  end
diff --git a/tests/test-dirs/locate/local-definitions/issue798.t/run.t b/tests/test-dirs/locate/local-definitions/issue798.t/run.t
new file mode 100644
index 0000000..26bae71
--- /dev/null
+++ b/tests/test-dirs/locate/local-definitions/issue798.t/run.t
@@ -0,0 +1,13 @@
+
+  $ $MERLIN single locate -look-for ml -position 7:17 -filename ./issue798.ml < ./issue798.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/issue798.ml",
+      "pos": {
+        "line": 6,
+        "col": 8
+      }
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/locate/local-definitions/issue806.t/issue806.ml b/tests/test-dirs/locate/local-definitions/issue806.t/issue806.ml
new file mode 100644
index 0000000..18a4135
--- /dev/null
+++ b/tests/test-dirs/locate/local-definitions/issue806.t/issue806.ml
@@ -0,0 +1,5 @@
+let foo () = ()
+
+let () =
+  let foo () = () in
+  foo ()
diff --git a/tests/test-dirs/locate/local-definitions/issue806.t/run.t b/tests/test-dirs/locate/local-definitions/issue806.t/run.t
new file mode 100644
index 0000000..3b0213f
--- /dev/null
+++ b/tests/test-dirs/locate/local-definitions/issue806.t/run.t
@@ -0,0 +1,13 @@
+
+  $ $MERLIN single locate -look-for ml -position 5:3 -filename ./issue806.ml < ./issue806.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/issue806.ml",
+      "pos": {
+        "line": 4,
+        "col": 6
+      }
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/locate/looping-substitution.t/bar.ml b/tests/test-dirs/locate/looping-substitution.t/bar.ml
new file mode 100644
index 0000000..093f572
--- /dev/null
+++ b/tests/test-dirs/locate/looping-substitution.t/bar.ml
@@ -0,0 +1,7 @@
+module Do_the_thing(Test : Foo.Test.S) = struct
+  let stuff () = ()
+
+  include Test
+end
+
+include Do_the_thing(Foo.Test)
diff --git a/tests/test-dirs/locate/looping-substitution.t/foo.ml b/tests/test-dirs/locate/looping-substitution.t/foo.ml
new file mode 100644
index 0000000..17dbf14
--- /dev/null
+++ b/tests/test-dirs/locate/looping-substitution.t/foo.ml
@@ -0,0 +1 @@
+module Test = Foo_test
diff --git a/tests/test-dirs/locate/looping-substitution.t/run.t b/tests/test-dirs/locate/looping-substitution.t/run.t
new file mode 100644
index 0000000..c3c9bde
--- /dev/null
+++ b/tests/test-dirs/locate/looping-substitution.t/run.t
@@ -0,0 +1,21 @@
+Setup the test environment:
+
+  $ $OCAMLC -c -bin-annot -o Foo_test test.ml
+  $ $OCAMLC -c -bin-annot foo.ml
+  $ $OCAMLC -c -bin-annot bar.ml
+
+Do the thing:
+
+  $ echo "let () = Bar.the_function ()" | \
+  > $MERLIN single locate -look-for ml -position 1:15 -filename ./example.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/test.ml",
+      "pos": {
+        "line": 5,
+        "col": 4
+      }
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/locate/looping-substitution.t/test.ml b/tests/test-dirs/locate/looping-substitution.t/test.ml
new file mode 100644
index 0000000..ab22bd4
--- /dev/null
+++ b/tests/test-dirs/locate/looping-substitution.t/test.ml
@@ -0,0 +1,5 @@
+module type S = sig
+  val the_function : unit -> unit
+end
+
+let the_function () = ()
diff --git a/tests/test-dirs/locate/module-aliases.t/anothermod.ml b/tests/test-dirs/locate/module-aliases.t/anothermod.ml
new file mode 100644
index 0000000..fb04f38
--- /dev/null
+++ b/tests/test-dirs/locate/module-aliases.t/anothermod.ml
@@ -0,0 +1,3 @@
+type a
+
+let f x = 2 * x
diff --git a/tests/test-dirs/locate/module-aliases.t/anothermod.mli b/tests/test-dirs/locate/module-aliases.t/anothermod.mli
new file mode 100644
index 0000000..9352548
--- /dev/null
+++ b/tests/test-dirs/locate/module-aliases.t/anothermod.mli
@@ -0,0 +1,3 @@
+type a
+
+val f : int -> int
diff --git a/tests/test-dirs/locate/module-aliases.t/dune b/tests/test-dirs/locate/module-aliases.t/dune
new file mode 100644
index 0000000..69dd4ad
--- /dev/null
+++ b/tests/test-dirs/locate/module-aliases.t/dune
@@ -0,0 +1,2 @@
+(executable
+ (name main))
diff --git a/tests/test-dirs/locate/module-aliases.t/dune-project b/tests/test-dirs/locate/module-aliases.t/dune-project
new file mode 100644
index 0000000..929c696
--- /dev/null
+++ b/tests/test-dirs/locate/module-aliases.t/dune-project
@@ -0,0 +1 @@
+(lang dune 2.0)
diff --git a/tests/test-dirs/locate/module-aliases.t/main.ml b/tests/test-dirs/locate/module-aliases.t/main.ml
new file mode 100644
index 0000000..013c622
--- /dev/null
+++ b/tests/test-dirs/locate/module-aliases.t/main.ml
@@ -0,0 +1,5 @@
+module Arith = Anothermod
+
+type u = Anothermod.a;;
+
+Arith.f 42
diff --git a/tests/test-dirs/locate/module-aliases.t/run.t b/tests/test-dirs/locate/module-aliases.t/run.t
new file mode 100644
index 0000000..286667e
--- /dev/null
+++ b/tests/test-dirs/locate/module-aliases.t/run.t
@@ -0,0 +1,154 @@
+**************************
+When building without Dune
+**************************
+
+  $ ocamlc -c -bin-annot anothermod.mli 
+  $ ocamlc -c -bin-annot anothermod.ml 
+
+
+  $ cat >.merlin << EOF
+  > EOF
+
+Jump from to another module `module A = Anothe|rmod`:
+  $ $MERLIN single locate -look-for ml -position 1:21 \
+  > -filename ./main.ml < ./main.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/anothermod.ml",
+    "pos": {
+      "line": 1,
+      "col": 0
+    }
+  }
+
+Jump from to another module signature `module A = Anothe|rmod`:
+  $ $MERLIN single locate -look-for mli -position 1:21 \
+  > -filename ./main.ml < ./main.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/anothermod.mli",
+    "pos": {
+      "line": 1,
+      "col": 0
+    }
+  }
+
+Jump to an element of an aliased module `A.|f`:
+  $ $MERLIN single locate -look-for ml -position 5:7 \
+  > -filename ./main.ml < ./main.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/anothermod.ml",
+    "pos": {
+      "line": 3,
+      "col": 4
+    }
+  }
+
+Jump to the declaration of an element of an alisaed module `A.|f`:
+  $ $MERLIN single locate -look-for mli -position 5:7 \
+  > -filename ./main.ml < ./main.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/anothermod.mli",
+    "pos": {
+      "line": 3,
+      "col": 0
+    }
+  }
+
+Jump to an aliased module `A|.f`:
+  $ $MERLIN single locate -look-for ml -position 5:2 \
+  > -filename ./main.ml < ./main.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/anothermod.ml",
+    "pos": {
+      "line": 1,
+      "col": 0
+    }
+  }
+
+Jump to the declaration of an aliased module `A|.f`:
+  $ $MERLIN single locate -look-for mli -position 5:2 \
+  > -filename ./main.ml < ./main.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/anothermod.mli",
+    "pos": {
+      "line": 1,
+      "col": 0
+    }
+  }
+
+***********************
+When building with Dune
+***********************
+
+With Dune we have an additional issue: the automatic wrapping
+  $ rm .merlin
+  $ rm *.cm*
+
+We need to build @check for all cmts to be created
+  $ dune build @check
+  $ dune build
+
+Jump from to another module `module A = Anothe|rmod`:
+  $ $MERLIN single locate -look-for ml -position 1:21 \
+  > -filename ./main.ml < ./main.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/anothermod.ml",
+    "pos": {
+      "line": 1,
+      "col": 0
+    }
+  }
+
+Jump from to another module signature `module A = Anothe|rmod`:
+  $ $MERLIN single locate -look-for mli -position 1:21 \
+  > -filename ./main.ml < ./main.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/anothermod.mli",
+    "pos": {
+      "line": 1,
+      "col": 0
+    }
+  }
+
+Jump to an element of an aliased module `A.|f`:
+  $ $MERLIN single locate -look-for ml -position 5:7 \
+  > -filename ./main.ml < ./main.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/anothermod.ml",
+    "pos": {
+      "line": 3,
+      "col": 4
+    }
+  }
+
+Jump to the declaration of an element of an alisaed module `A.|f`:
+  $ $MERLIN single locate -look-for mli -position 5:7 \
+  > -filename ./main.ml < ./main.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/anothermod.mli",
+    "pos": {
+      "line": 3,
+      "col": 0
+    }
+  }
+
+Jump to an aliased module `A|.f`:
+  $ $MERLIN single locate -look-for ml -position 5:2 \
+  > -filename ./main.ml < ./main.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/anothermod.ml",
+    "pos": {
+      "line": 1,
+      "col": 0
+    }
+  }
+
+Jump to the declaration of an aliased module `A|.f`:
+  $ $MERLIN single locate -look-for mli -position 5:2 \
+  > -filename ./main.ml < ./main.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/anothermod.mli",
+    "pos": {
+      "line": 1,
+      "col": 0
+    }
+  }
diff --git a/tests/test-dirs/locate/mutually-recursive.t/issue973.ml b/tests/test-dirs/locate/mutually-recursive.t/issue973.ml
new file mode 100644
index 0000000..a590feb
--- /dev/null
+++ b/tests/test-dirs/locate/mutually-recursive.t/issue973.ml
@@ -0,0 +1,8 @@
+let rec foo x =
+  1 + bar x
+
+and bar x =
+  if x = 0 then
+    x
+  else
+    foo (x - 1)
diff --git a/tests/test-dirs/locate/mutually-recursive.t/run.t b/tests/test-dirs/locate/mutually-recursive.t/run.t
new file mode 100644
index 0000000..25e2351
--- /dev/null
+++ b/tests/test-dirs/locate/mutually-recursive.t/run.t
@@ -0,0 +1,29 @@
+Searching foo from bar works:
+
+  $ $MERLIN single locate -look-for ml -position 8:6 -filename ./issue973.ml < ./issue973.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/issue973.ml",
+      "pos": {
+        "line": 1,
+        "col": 8
+      }
+    },
+    "notifications": []
+  }
+
+And so does bar from foo:
+
+  $ $MERLIN single locate -look-for ml -position 2:7 -filename ./issue973.ml < ./issue973.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/issue973.ml",
+      "pos": {
+        "line": 4,
+        "col": 4
+      }
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/locate/non-local/dune b/tests/test-dirs/locate/non-local/dune
new file mode 100755
index 0000000..c655d30
--- /dev/null
+++ b/tests/test-dirs/locate/non-local/dune
@@ -0,0 +1,4 @@
+(cram
+ (applies_to ignore-kept-locs preference)
+ (enabled_if
+  (<> %{os_type} Win32)))
diff --git a/tests/test-dirs/locate/non-local/ignore-kept-locs.t/a.ml b/tests/test-dirs/locate/non-local/ignore-kept-locs.t/a.ml
new file mode 100644
index 0000000..e1b898c
--- /dev/null
+++ b/tests/test-dirs/locate/non-local/ignore-kept-locs.t/a.ml
@@ -0,0 +1 @@
+let value = 3
diff --git a/tests/test-dirs/locate/non-local/ignore-kept-locs.t/b.ml b/tests/test-dirs/locate/non-local/ignore-kept-locs.t/b.ml
new file mode 100644
index 0000000..fbdfdcc
--- /dev/null
+++ b/tests/test-dirs/locate/non-local/ignore-kept-locs.t/b.ml
@@ -0,0 +1,5 @@
+let _ = A.value
+
+include A
+
+let _ = value
diff --git a/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t b/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t
new file mode 100644
index 0000000..897428d
--- /dev/null
+++ b/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t
@@ -0,0 +1,46 @@
+Setup the test context:
+
+  $ $OCAMLC -c -bin-annot -keep-locs a.ml
+
+Make sure that we do not use locations coming from the cmi:
+
+  $ $MERLIN single locate -look-for ml -log-section locate -log-file log \
+  > -position 1:12 -filename ./b.ml < ./b.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/a.ml",
+      "pos": {
+        "line": 1,
+        "col": 4
+      }
+    },
+    "notifications": []
+  }
+
+  $ grep -A1 Fallback log | grep -v Fallback
+  [1]
+
+  $ rm log
+
+  $ $MERLIN single locate -look-for ml -log-section locate -log-file log \
+  > -position 5:12 -filename ./b.ml < ./b.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/a.ml",
+      "pos": {
+        "line": 1,
+        "col": 4
+      }
+    },
+    "notifications": []
+  }
+
+The fallback here is ok, it points to the local buffer (to the include line
+actually), not to a.ml
+
+  $ grep -A1 Fallback log | grep -v Fallback
+  File "b.ml", line 3, characters 0-9
+
+  $ rm log
diff --git a/tests/test-dirs/locate/non-local/preference.t/a.ml b/tests/test-dirs/locate/non-local/preference.t/a.ml
new file mode 100644
index 0000000..e1b898c
--- /dev/null
+++ b/tests/test-dirs/locate/non-local/preference.t/a.ml
@@ -0,0 +1 @@
+let value = 3
diff --git a/tests/test-dirs/locate/non-local/preference.t/a.mli b/tests/test-dirs/locate/non-local/preference.t/a.mli
new file mode 100644
index 0000000..5230c37
--- /dev/null
+++ b/tests/test-dirs/locate/non-local/preference.t/a.mli
@@ -0,0 +1,3 @@
+(* a comment! *)
+
+val value : int
diff --git a/tests/test-dirs/locate/non-local/preference.t/b.ml b/tests/test-dirs/locate/non-local/preference.t/b.ml
new file mode 100644
index 0000000..a7b00f7
--- /dev/null
+++ b/tests/test-dirs/locate/non-local/preference.t/b.ml
@@ -0,0 +1,9 @@
+let _ = A.value
+
+module Indir = A
+
+let _ = Indir.value
+
+include A
+
+let _ = value
diff --git a/tests/test-dirs/locate/non-local/preference.t/b.mli b/tests/test-dirs/locate/non-local/preference.t/b.mli
new file mode 100644
index 0000000..2438c78
--- /dev/null
+++ b/tests/test-dirs/locate/non-local/preference.t/b.mli
@@ -0,0 +1 @@
+(* deliberately empty *)
diff --git a/tests/test-dirs/locate/non-local/preference.t/run.t b/tests/test-dirs/locate/non-local/preference.t/run.t
new file mode 100644
index 0000000..181bcda
--- /dev/null
+++ b/tests/test-dirs/locate/non-local/preference.t/run.t
@@ -0,0 +1,85 @@
+Setup the context:
+
+  $ $OCAMLC -c -bin-annot a.mli a.ml
+  $ $OCAMLC -c -bin-annot b.mli b.ml
+
+Test that Locate.locate and Locate.from_path do their job properly:
+
+  $ $MERLIN single locate -look-for ml -position 1:11 -filename ./b.ml < ./b.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/a.ml",
+      "pos": {
+        "line": 1,
+        "col": 4
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for ml -position 5:15 -filename ./b.ml < ./b.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/a.ml",
+      "pos": {
+        "line": 1,
+        "col": 4
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for ml -position 9:9 -filename ./b.ml < ./b.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/a.ml",
+      "pos": {
+        "line": 1,
+        "col": 4
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for mli -position 1:11 -filename ./b.ml < ./b.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/a.mli",
+      "pos": {
+        "line": 3,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for mli -position 5:15 -filename ./b.ml < ./b.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/a.mli",
+      "pos": {
+        "line": 3,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for mli -position 9:9 -filename ./b.ml < ./b.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/a.mli",
+      "pos": {
+        "line": 3,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
diff --git a/tests/test-dirs/locate/partial-cmt.t/.gitignore b/tests/test-dirs/locate/partial-cmt.t/.gitignore
new file mode 100644
index 0000000..1bdbd44
--- /dev/null
+++ b/tests/test-dirs/locate/partial-cmt.t/.gitignore
@@ -0,0 +1,2 @@
+a.ml
+a.mli
diff --git a/tests/test-dirs/locate/partial-cmt.t/run.t b/tests/test-dirs/locate/partial-cmt.t/run.t
new file mode 100644
index 0000000..272a0e7
--- /dev/null
+++ b/tests/test-dirs/locate/partial-cmt.t/run.t
@@ -0,0 +1,56 @@
+Create a well typed a.ml and a.mli and compile them
+(this will generate a .cmi and .cmt):
+
+  $ echo "type t = A | B" > a.ml
+  $ echo "type t = A | B" > a.mli
+  $ $OCAMLC -c a.mli
+  $ $OCAMLC -c -bin-annot a.ml
+  $ test -f a.cmi & test -f a.cmt & test ! -f a.cmti
+
+Jump:
+
+  $ $MERLIN single locate -look-for ml -position 1:11 -filename ./test.ml < ./test.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/a.ml",
+      "pos": {
+        "line": 1,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
+Remove the cmt:
+
+  $ rm a.cmt
+
+Introduce a type error in a.ml:
+
+  $ echo "let () = 3" >> a.ml
+  $ env OCAML_ERROR_STYLE=short $OCAMLC -c -bin-annot a.ml
+  File "a.ml", line 2, characters 9-10:
+  Error: This expression has type int but an expression was expected of type
+           unit
+  [2]
+  $ test -f a.cmi & test -f a.cmt & test ! -f a.cmti
+
+Try jumping again, note that if the file is the ".mli" one this means that we
+failed to find/read the cmt and we're fallbacking to the location we got from
+the environment (as we explicitly asked locate to jump to the .ml).
+That is: if the file is a.mli then the test is broken:
+
+  $ $MERLIN single locate -look-for ml -position 1:11 -filename ./test.ml < ./test.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/a.ml",
+      "pos": {
+        "line": 1,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
diff --git a/tests/test-dirs/locate/partial-cmt.t/test.ml b/tests/test-dirs/locate/partial-cmt.t/test.ml
new file mode 100644
index 0000000..924f61e
--- /dev/null
+++ b/tests/test-dirs/locate/partial-cmt.t/test.ml
@@ -0,0 +1 @@
+let _ = A.A
diff --git a/tests/test-dirs/locate/reconstruct-identifier/dune b/tests/test-dirs/locate/reconstruct-identifier/dune
new file mode 100755
index 0000000..d0da0b6
--- /dev/null
+++ b/tests/test-dirs/locate/reconstruct-identifier/dune
@@ -0,0 +1,4 @@
+(cram
+ (applies_to newlines off_by_one)
+ (enabled_if
+  (<> %{os_type} Win32)))
diff --git a/tests/test-dirs/locate/reconstruct-identifier/newlines.t/escaped_newline.ml b/tests/test-dirs/locate/reconstruct-identifier/newlines.t/escaped_newline.ml
new file mode 100644
index 0000000..49355f8
--- /dev/null
+++ b/tests/test-dirs/locate/reconstruct-identifier/newlines.t/escaped_newline.ml
@@ -0,0 +1,8 @@
+let string = "s"
+
+let foo =
+  let _ = {|  Look at this: '\
+Foo|} in
+  let () = ignore string in
+  "Onoes,  Foo_bar_lol baz"
+;;
diff --git a/tests/test-dirs/locate/reconstruct-identifier/newlines.t/newline_in_quotes.ml b/tests/test-dirs/locate/reconstruct-identifier/newlines.t/newline_in_quotes.ml
new file mode 100644
index 0000000..09a233b
--- /dev/null
+++ b/tests/test-dirs/locate/reconstruct-identifier/newlines.t/newline_in_quotes.ml
@@ -0,0 +1,9 @@
+let string = "s"
+
+let foo =
+  let _ = {|  Look at this: '
+'
+Foo|} in
+  let () = ignore string in
+  "Onoes,  Foo_bar_lol baz"
+;;
diff --git a/tests/test-dirs/locate/reconstruct-identifier/newlines.t/run.t b/tests/test-dirs/locate/reconstruct-identifier/newlines.t/run.t
new file mode 100644
index 0000000..3b35452
--- /dev/null
+++ b/tests/test-dirs/locate/reconstruct-identifier/newlines.t/run.t
@@ -0,0 +1,29 @@
+We need to be careful about newlines in Lexer_ident:
+
+  $ $MERLIN single locate -look-for ml -position 7:20 \
+  > -filename ./newline_in_quotes.ml < ./newline_in_quotes.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/newline_in_quotes.ml",
+      "pos": {
+        "line": 1,
+        "col": 4
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for ml -position 6:20 \
+  > -filename ./escaped_newline.ml < ./escaped_newline.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/escaped_newline.ml",
+      "pos": {
+        "line": 1,
+        "col": 4
+      }
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/locate/reconstruct-identifier/off_by_one.t/off_by_one.ml b/tests/test-dirs/locate/reconstruct-identifier/off_by_one.t/off_by_one.ml
new file mode 100644
index 0000000..c5cd526
--- /dev/null
+++ b/tests/test-dirs/locate/reconstruct-identifier/off_by_one.t/off_by_one.ml
@@ -0,0 +1,5 @@
+module Wx = struct type t end
+
+module type Q = sig
+  val f : x:Wx.t -> unit
+end
diff --git a/tests/test-dirs/locate/reconstruct-identifier/off_by_one.t/run.t b/tests/test-dirs/locate/reconstruct-identifier/off_by_one.t/run.t
new file mode 100644
index 0000000..c73c509
--- /dev/null
+++ b/tests/test-dirs/locate/reconstruct-identifier/off_by_one.t/run.t
@@ -0,0 +1,14 @@
+Regression test for #624
+
+  $ $MERLIN single locate -look-for ml -position 4:13 -filename ./off_by_one.ml < ./off_by_one.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/off_by_one.ml",
+      "pos": {
+        "line": 1,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/locate/sig-substs.t/basic.ml b/tests/test-dirs/locate/sig-substs.t/basic.ml
new file mode 100644
index 0000000..26582d6
--- /dev/null
+++ b/tests/test-dirs/locate/sig-substs.t/basic.ml
@@ -0,0 +1,11 @@
+module type S = sig
+  module type T = sig
+    type t
+  end
+
+  type lol
+
+  module M : T with type t = lol
+
+  val x : M.t
+end
diff --git a/tests/test-dirs/locate/sig-substs.t/run.t b/tests/test-dirs/locate/sig-substs.t/run.t
new file mode 100644
index 0000000..150ae6c
--- /dev/null
+++ b/tests/test-dirs/locate/sig-substs.t/run.t
@@ -0,0 +1,16 @@
+FIXME: such substitutions are not handled properly yet.
+On a similar note we currently have no way to decide between a sig and a struct
+when both are present in the buffer (the struct will always be preferred).
+
+  $ $MERLIN single locate -look-for ml -position 10:12 -filename ./basic.ml < ./basic.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/basic.ml",
+      "pos": {
+        "line": 3,
+        "col": 4
+      }
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/locate/with-holes.t/run.t b/tests/test-dirs/locate/with-holes.t/run.t
new file mode 100644
index 0000000..c638df7
--- /dev/null
+++ b/tests/test-dirs/locate/with-holes.t/run.t
@@ -0,0 +1,26 @@
+  $ cat >bar.ml <<EOF
+  > module M = struct
+  >  include _
+  >  let x = 3
+  > end
+  > let _ = M.x
+  > let _ = M.foo
+  > EOF
+
+  $ $MERLIN single locate -look-for ml -position 5:11 -filename bar.ml <bar.ml |
+  > jq '.value.pos'
+  {
+    "line": 3,
+    "col": 5
+  }
+
+  $ $MERLIN single locate -look-for ml -position 6:11 -filename bar.ml <bar.ml |
+  > jq '.value'
+  "Not in environment 'M.foo'"
+
+  $ $MERLIN single locate -look-for ml -position 2:10 -filename bar.ml <bar.ml
+  {
+    "class": "return",
+    "value": "Not a valid identifier",
+    "notifications": []
+  }
diff --git a/tests/test-dirs/misc/external-arity.t b/tests/test-dirs/misc/external-arity.t
new file mode 100644
index 0000000..b62ece3
--- /dev/null
+++ b/tests/test-dirs/misc/external-arity.t
@@ -0,0 +1,12 @@
+Bucklescript allow externals to have a non-arrow type. We relax this
+restriction in Merlin too as it ease some peoples life and is not really
+problematic for normal  OCaml users.
+
+  $ $MERLIN single errors -filename external_arity.ml -w +A <<EOF
+  > external foo : unit list = "foo"
+  > EOF
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/misc/load_path.t b/tests/test-dirs/misc/load_path.t
new file mode 100644
index 0000000..19bffb0
--- /dev/null
+++ b/tests/test-dirs/misc/load_path.t
@@ -0,0 +1,33 @@
+  $ echo "let x = List.map" >test.ml
+
+Shadow the list module from the stdlib:
+
+  $ echo "let map = 3" >list.ml
+  $ $OCAMLC -c list.ml
+
+Here is what the compiler sees:
+
+  $ $OCAMLC -c -i test.ml
+  val x : int
+
+Here is what merlin sees:
+
+  $ $MERLIN single type-enclosing -position 1:14 -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 8
+        },
+        "end": {
+          "line": 1,
+          "col": 16
+        },
+        "type": "int",
+        "tail": "no"
+      }
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/motion/jump.t b/tests/test-dirs/motion/jump.t
new file mode 100644
index 0000000..fc32437
--- /dev/null
+++ b/tests/test-dirs/motion/jump.t
@@ -0,0 +1,36 @@
+  $ $MERLIN single jump -target let -position 2:2 -filename test.ml <<EOF
+  > let x =
+  >   5
+  > EOF
+  {
+    "class": "return",
+    "value": {
+      "pos": {
+        "line": 1,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
+Same line should fail:
+
+  $ $MERLIN single jump -target let -position 1:8 -filename test.ml <<EOF
+  > let x = 5
+  > EOF
+  {
+    "class": "return",
+    "value": "No matching target",
+    "notifications": []
+  }
+
+  $ $MERLIN single jump -target module -position 2:2 -filename test.ml <<EOF
+  > let x =
+  >   5
+  > EOF
+  {
+    "class": "return",
+    "value": "No matching target",
+    "notifications": []
+  }
+
diff --git a/tests/test-dirs/motion/phrase.t b/tests/test-dirs/motion/phrase.t
new file mode 100644
index 0000000..ef7ef9e
--- /dev/null
+++ b/tests/test-dirs/motion/phrase.t
@@ -0,0 +1,31 @@
+  $ $MERLIN single phrase -target next -position 1:0 -filename test.ml <<EOF
+  > let x = 5
+  > let y = 2
+  > EOF
+  {
+    "class": "return",
+    "value": {
+      "pos": {
+        "line": 2,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
+FIXME: ??
+
+  $ $MERLIN single phrase -target prev -position 2:0 -filename test.ml <<EOF
+  > let x = 5
+  > let y = 2
+  > EOF
+  {
+    "class": "return",
+    "value": {
+      "pos": {
+        "line": 1,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/no-escape.t/foo.cmi b/tests/test-dirs/no-escape.t/foo.cmi
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tests/test-dirs/no-escape.t/foo.cmi
diff --git a/tests/test-dirs/no-escape.t/run.t b/tests/test-dirs/no-escape.t/run.t
new file mode 100644
index 0000000..84c6065
--- /dev/null
+++ b/tests/test-dirs/no-escape.t/run.t
@@ -0,0 +1,355 @@
+These tests ensure that all type errors are caught by the kernel, no exception
+should reach top-level
+
+  $ echo "type p = P : 'a -> 'a -> p" |
+  > $MERLIN single errors -filename ./incorrect_gadt.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 19
+        },
+        "end": {
+          "line": 1,
+          "col": 26
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "The type constructor p expects 0 argument(s),
+  but is here applied to 1 argument(s)"
+      },
+      {
+        "start": {
+          "line": 1,
+          "col": 22
+        },
+        "end": {
+          "line": 1,
+          "col": 24
+        },
+        "type": "parser",
+        "sub": [],
+        "valid": true,
+        "message": "Syntax error"
+      }
+    ],
+    "notifications": []
+  }
+
+  $ echo "let error : unknown_type_constructor = assert false" |
+  > $MERLIN single errors -filename  "unkown_constr.ml"
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 12
+        },
+        "end": {
+          "line": 1,
+          "col": 36
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Unbound type constructor unknown_type_constructor"
+      }
+    ],
+    "notifications": []
+  }
+
+  $ echo "val error : unknown_type_constructor" |
+  > $MERLIN single errors -filename  "unkown_constr.mli"
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 12
+        },
+        "end": {
+          "line": 1,
+          "col": 36
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Unbound type constructor unknown_type_constructor"
+      }
+    ],
+    "notifications": []
+  }
+
+  $ echo "type t = A | A" |
+  > $MERLIN single errors -filename  "two_constr.ml"
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 0
+        },
+        "end": {
+          "line": 1,
+          "col": 14
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Two constructors are named A"
+      }
+    ],
+    "notifications": []
+  }
+
+  $ echo "type t = A | A" |
+  > $MERLIN single errors -filename  "two_constr.mli"
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 0
+        },
+        "end": {
+          "line": 1,
+          "col": 14
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Two constructors are named A"
+      }
+    ],
+    "notifications": []
+  }
+
+  $ echo "let x = 4 val x : int" |
+  > $MERLIN single errors -filename  "ml_in_mli.mli"
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 0
+        },
+        "end": {
+          "line": 1,
+          "col": 3
+        },
+        "type": "parser",
+        "sub": [],
+        "valid": true,
+        "message": "Syntax error"
+      }
+    ],
+    "notifications": []
+  }
+
+vals are no allowed in ml files and detected during semantic analysis
+
+  $ echo "val x : int" |
+  > $MERLIN single errors -filename  "mli_in_ml.ml"
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 0
+        },
+        "end": {
+          "line": 1,
+          "col": 11
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Value declarations are only allowed in signatures"
+      }
+    ],
+    "notifications": []
+  }
+
+The code should raise a single error (for Bb typo), but shouldn't report the
+unused case after
+
+  $ $MERLIN single errors -filename "unused_case_after_error.ml" <<EOF
+  > type t = A | B | C
+  > let f = function
+  >   | A -> 1
+  >   | Bb -> 1
+  >   | C -> 1
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 4,
+          "col": 4
+        },
+        "end": {
+          "line": 4,
+          "col": 6
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "This variant pattern is expected to have type t
+  There is no constructor Bb within type t"
+      }
+    ],
+    "notifications": []
+  }
+
+Syntax errors also shouldn't escape:
+
+  $ echo "let f (_ : (module S with type 'a t = int)) = ()" |
+  > $MERLIN single errors -filename "invalid_package_type.ml"
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 11
+        },
+        "end": {
+          "line": 1,
+          "col": 42
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Unbound module type S"
+      },
+      {
+        "start": {
+          "line": 1,
+          "col": 26
+        },
+        "end": {
+          "line": 1,
+          "col": 41
+        },
+        "type": "parser",
+        "sub": [],
+        "valid": true,
+        "message": "invalid package type: parametrized types are not supported"
+      }
+    ],
+    "notifications": []
+  }
+
+Env initialization errors should also be caught, though it is currently
+difficult to report them if the buffer is empty, therefore there should be
+a different behavior between:
+
+  $ echo "" | $MERLIN single errors -open Absent_unit -filename "env_init.ml"
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
+
+And:
+
+  $ echo "let x = 3" | \
+  > $MERLIN single errors -open Absent_unit -filename "env_init.ml" |
+  > jq ".value |= (map(del(.start.line) | del(.end.line)))"
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "col": -1
+        },
+        "end": {
+          "col": -1
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Unbound module Absent_unit"
+      }
+    ],
+    "notifications": []
+  }
+
+And of course, it should never leak for other requests:
+
+  $ echo "" | $MERLIN single type-enclosing -position 1:0 -expression "3" \
+  > -open Absent_unit -filename "env_init.ml"
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": -1
+        },
+        "end": {
+          "line": 1,
+          "col": 0
+        },
+        "type": "int",
+        "tail": "no"
+      }
+    ],
+    "notifications": []
+  }
+
+When typing the Test module, Merlin will try to load the Foo dependency.
+However foo.cmi is not a valid cmi file, we must make sure Merlin handle this
+properly (this should also cover the "wrong magic number" case).
+
+  $ $MERLIN single errors -filename test_use.ml < test_use.ml |
+  > tr '\r\n' ' ' | jq ".value |= (map(del(.start.line) | del(.end.line)))"
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "col": -1
+        },
+        "end": {
+          "col": -1
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Corrupted compiled interface $TESTCASE_ROOT/foo.cmi"
+      }
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single errors -filename test_open.ml -open Foo < test_open.ml |
+  > tr '\r\n' ' ' | jq ".value |= (map(del(.start.line) | del(.end.line)))"
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "col": -1
+        },
+        "end": {
+          "col": -1
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Corrupted compiled interface $TESTCASE_ROOT/foo.cmi"
+      }
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/no-escape.t/test_open.ml b/tests/test-dirs/no-escape.t/test_open.ml
new file mode 100644
index 0000000..c54d98b
--- /dev/null
+++ b/tests/test-dirs/no-escape.t/test_open.ml
@@ -0,0 +1,9 @@
+(* TODO or FIXME: If file is empty, Merlin just drops the errors
+   (errors are attached to typed top-level definitions,
+    if there are no definitions, errors cannot be attached!)
+
+   So here is a dummy definition.
+*)
+
+
+let () = print_string "Hello world"
diff --git a/tests/test-dirs/no-escape.t/test_use.ml b/tests/test-dirs/no-escape.t/test_use.ml
new file mode 100644
index 0000000..605b85f
--- /dev/null
+++ b/tests/test-dirs/no-escape.t/test_use.ml
@@ -0,0 +1 @@
+open Foo
diff --git a/tests/test-dirs/occurrences/basic.t/basic.ml b/tests/test-dirs/occurrences/basic.t/basic.ml
new file mode 100644
index 0000000..ed36532
--- /dev/null
+++ b/tests/test-dirs/occurrences/basic.t/basic.ml
@@ -0,0 +1,19 @@
+let simple some =
+  some + some
+
+let withTypeAnnot (some : int) =
+  some + some
+
+type boxed_int = {value : int}
+
+let withRecordPattern {value;} =
+  value + value
+
+let withRecordLiteral num =
+  {value = num;}
+
+let withRecordLiteralPunned value =
+  {value;}
+
+let withAlias (value as num) =
+  num + num
diff --git a/tests/test-dirs/occurrences/basic.t/run.t b/tests/test-dirs/occurrences/basic.t/run.t
new file mode 100644
index 0000000..6c8ea9e
--- /dev/null
+++ b/tests/test-dirs/occurrences/basic.t/run.t
@@ -0,0 +1,219 @@
+Test getting occurrences of a function arg:
+
+  $ $MERLIN single occurrences -identifier-at 1:11 -filename ./basic.ml < ./basic.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 11
+        },
+        "end": {
+          "line": 1,
+          "col": 15
+        }
+      },
+      {
+        "start": {
+          "line": 2,
+          "col": 2
+        },
+        "end": {
+          "line": 2,
+          "col": 6
+        }
+      },
+      {
+        "start": {
+          "line": 2,
+          "col": 9
+        },
+        "end": {
+          "line": 2,
+          "col": 13
+        }
+      }
+    ],
+    "notifications": []
+  }
+
+Test getting occurrences of a function arg annotated with a type:
+
+  $ $MERLIN single occurrences -identifier-at 4:19 -filename ./basic.ml < ./basic.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 4,
+          "col": 19
+        },
+        "end": {
+          "line": 4,
+          "col": 23
+        }
+      },
+      {
+        "start": {
+          "line": 5,
+          "col": 2
+        },
+        "end": {
+          "line": 5,
+          "col": 6
+        }
+      },
+      {
+        "start": {
+          "line": 5,
+          "col": 9
+        },
+        "end": {
+          "line": 5,
+          "col": 13
+        }
+      }
+    ],
+    "notifications": []
+  }
+
+Test getting occurrences of a record pattern in a function arg:
+
+  $ $MERLIN single occurrences -identifier-at 9:24 -filename ./basic.ml < ./basic.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 9,
+          "col": 23
+        },
+        "end": {
+          "line": 9,
+          "col": 28
+        }
+      },
+      {
+        "start": {
+          "line": 10,
+          "col": 2
+        },
+        "end": {
+          "line": 10,
+          "col": 7
+        }
+      },
+      {
+        "start": {
+          "line": 10,
+          "col": 10
+        },
+        "end": {
+          "line": 10,
+          "col": 15
+        }
+      }
+    ],
+    "notifications": []
+  }
+
+Test getting occurrences of a function arg then used in record literal:
+
+  $ $MERLIN single occurrences -identifier-at 12:23 -filename ./basic.ml < ./basic.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 12,
+          "col": 22
+        },
+        "end": {
+          "line": 12,
+          "col": 25
+        }
+      },
+      {
+        "start": {
+          "line": 13,
+          "col": 11
+        },
+        "end": {
+          "line": 13,
+          "col": 14
+        }
+      }
+    ],
+    "notifications": []
+  }
+
+Test getting occurrences of a function arg then used in record literal punned:
+
+  $ $MERLIN single occurrences -identifier-at 15:29 -filename ./basic.ml < ./basic.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 15,
+          "col": 28
+        },
+        "end": {
+          "line": 15,
+          "col": 33
+        }
+      },
+      {
+        "start": {
+          "line": 16,
+          "col": 3
+        },
+        "end": {
+          "line": 16,
+          "col": 8
+        }
+      }
+    ],
+    "notifications": []
+  }
+
+Test getting occurrences of a function arg alias then used in record literal:
+
+  $ $MERLIN single occurrences -identifier-at 18:25 -filename ./basic.ml < ./basic.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 18,
+          "col": 24
+        },
+        "end": {
+          "line": 18,
+          "col": 27
+        }
+      },
+      {
+        "start": {
+          "line": 19,
+          "col": 2
+        },
+        "end": {
+          "line": 19,
+          "col": 5
+        }
+      },
+      {
+        "start": {
+          "line": 19,
+          "col": 8
+        },
+        "end": {
+          "line": 19,
+          "col": 11
+        }
+      }
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/occurrences/dune b/tests/test-dirs/occurrences/dune
new file mode 100644
index 0000000..0df46d5
--- /dev/null
+++ b/tests/test-dirs/occurrences/dune
@@ -0,0 +1,8 @@
+(cram
+ (applies_to issue1404)
+ (enabled_if
+  (<> %{os_type} Win32)))
+
+(cram
+ (applies_to occ-with-ppx)
+ (enabled_if false))
diff --git a/tests/test-dirs/occurrences/issue1398.t/issue1398.ml b/tests/test-dirs/occurrences/issue1398.t/issue1398.ml
new file mode 100644
index 0000000..480c5b1
--- /dev/null
+++ b/tests/test-dirs/occurrences/issue1398.t/issue1398.ml
@@ -0,0 +1,4 @@
+let (let++) x f = f x
+let (and++) a b = (a, b) ;;
+let ops = (let++), (and++) ;;
+let++ x = 3 and++ y = 4 in x + y
diff --git a/tests/test-dirs/occurrences/issue1398.t/run.t b/tests/test-dirs/occurrences/issue1398.t/run.t
new file mode 100644
index 0000000..069c4be
--- /dev/null
+++ b/tests/test-dirs/occurrences/issue1398.t/run.t
@@ -0,0 +1,99 @@
+Test finding occurrences of let-based binding operator, from reified syntax:
+
+  $ $MERLIN single occurrences -identifier-at 3:11 ./issue1398.ml < ./issue1398.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 4
+        },
+        "end": {
+          "line": 1,
+          "col": 11
+        }
+      },
+      {
+        "start": {
+          "line": 3,
+          "col": 10
+        },
+        "end": {
+          "line": 3,
+          "col": 17
+        }
+      },
+      {
+        "start": {
+          "line": 4,
+          "col": 0
+        },
+        "end": {
+          "line": 4,
+          "col": 5
+        }
+      }
+    ],
+    "notifications": []
+  }
+
+Test finding occurrences of and-based binding operator, from reified syntax:
+
+  $ $MERLIN single occurrences -identifier-at 3:20 ./issue1398.ml < ./issue1398.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 4
+        },
+        "end": {
+          "line": 2,
+          "col": 11
+        }
+      },
+      {
+        "start": {
+          "line": 3,
+          "col": 19
+        },
+        "end": {
+          "line": 3,
+          "col": 26
+        }
+      },
+      {
+        "start": {
+          "line": 4,
+          "col": 12
+        },
+        "end": {
+          "line": 4,
+          "col": 17
+        }
+      }
+    ],
+    "notifications": []
+  }
+
+FIXME -- this doesn't find anything right now
+Test finding occurrences of let-based binding operator, from operator syntax:
+
+  $ $MERLIN single occurrences -identifier-at 4:0 ./issue1398.ml < ./issue1398.ml
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
+
+FIXME -- this doesn't find anything right now
+Test finding occurrences of and-based binding operator, from operator syntax:
+
+  $ $MERLIN single occurrences -identifier-at 4:12 ./issue1398.ml < ./issue1398.ml
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/occurrences/issue1404.t b/tests/test-dirs/occurrences/issue1404.t
new file mode 100644
index 0000000..1009886
--- /dev/null
+++ b/tests/test-dirs/occurrences/issue1404.t
@@ -0,0 +1,89 @@
+FIXME there is a discrepancy on the detection of the expression under the cursor
+between locate and occurrences.
+
+occurrences identifier-at 2:0 returns the occurrences of [x]
+  $ $MERLIN single occurrences -identifier-at 2:0 -filename opt.ml <<EOF | \
+  > jq '.value'
+  > let x = 3 and y = 4 + 2 in
+  > x+y
+  > EOF
+  [
+    {
+      "start": {
+        "line": 1,
+        "col": 4
+      },
+      "end": {
+        "line": 1,
+        "col": 5
+      }
+    },
+    {
+      "start": {
+        "line": 2,
+        "col": 0
+      },
+      "end": {
+        "line": 2,
+        "col": 1
+      }
+    }
+  ]
+
+FIXME occurrences identifier-at 2:1 returns the occurrences of [x] (should be [+])
+  $ $MERLIN single occurrences -identifier-at 2:1 -filename opt.ml <<EOF | \
+  > jq '.value'
+  > let x = 3 and y = 4 + 2 in
+  > x+y
+  > EOF
+  [
+    {
+      "start": {
+        "line": 1,
+        "col": 4
+      },
+      "end": {
+        "line": 1,
+        "col": 5
+      }
+    },
+    {
+      "start": {
+        "line": 2,
+        "col": 0
+      },
+      "end": {
+        "line": 2,
+        "col": 1
+      }
+    }
+  ]
+
+locate position 2:0 returns the definition of [x]
+  $ $MERLIN single locate -position 2:0 -filename opt.ml <<EOF | \
+  > jq '.value'
+  > let x = 3 and y = 4 + 2 in
+  > x+y
+  > EOF
+  {
+    "file": "opt.ml",
+    "pos": {
+      "line": 1,
+      "col": 4
+    }
+  }
+
+
+locate position 2:1 returns the definition of [(+)]
+  $ $MERLIN single locate -position 2:1 -filename opt.ml <<EOF | \
+  > jq '.value'
+  > let x = 3 and y = 4 + 2 in
+  > x+y
+  > EOF
+  {
+    "file": "lib/ocaml/stdlib.mli",
+    "pos": {
+      "line": 347,
+      "col": 0
+    }
+  }
diff --git a/tests/test-dirs/occurrences/issue1410.t b/tests/test-dirs/occurrences/issue1410.t
new file mode 100644
index 0000000..2792226
--- /dev/null
+++ b/tests/test-dirs/occurrences/issue1410.t
@@ -0,0 +1,51 @@
+FIXME
+
+First result is incorrect when in the body of a function with an optional argument
+
+  $ $MERLIN single occurrences -identifier-at 3:3 -filename opt.ml <<EOF | \
+  > jq '.value'
+  > (* test case *)
+  > let f ?(x=1) () = 2 ;;
+  > None
+  > EOF
+  [
+    {
+      "start": {
+        "line": 0,
+        "col": -1
+      },
+      "end": {
+        "line": 0,
+        "col": -1
+      }
+    },
+    {
+      "start": {
+        "line": 3,
+        "col": 0
+      },
+      "end": {
+        "line": 3,
+        "col": 4
+      }
+    }
+  ]
+
+  $ $MERLIN single occurrences -identifier-at 3:3 -filename opt.ml <<EOF | \
+  > jq '.value'
+  > (* test case *)
+  > let f () = 2 ;;
+  > None
+  > EOF
+  [
+    {
+      "start": {
+        "line": 3,
+        "col": 0
+      },
+      "end": {
+        "line": 3,
+        "col": 4
+      }
+    }
+  ]
diff --git a/tests/test-dirs/occurrences/issue827.t/issue827.ml b/tests/test-dirs/occurrences/issue827.t/issue827.ml
new file mode 100644
index 0000000..bf44a6a
--- /dev/null
+++ b/tests/test-dirs/occurrences/issue827.t/issue827.ml
@@ -0,0 +1,5 @@
+module M = struct
+    type t = AC | BC
+end
+let _ = M.AC
+let _ = let open M in BC
diff --git a/tests/test-dirs/occurrences/issue827.t/run.t b/tests/test-dirs/occurrences/issue827.t/run.t
new file mode 100644
index 0000000..922bd79
--- /dev/null
+++ b/tests/test-dirs/occurrences/issue827.t/run.t
@@ -0,0 +1,116 @@
+Reproduction case:
+
+  $ $MERLIN single occurrences -identifier-at 2:14 -filename ./issue827.ml < ./issue827.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 13
+        },
+        "end": {
+          "line": 2,
+          "col": 15
+        }
+      },
+      {
+        "start": {
+          "line": 4,
+          "col": 8
+        },
+        "end": {
+          "line": 4,
+          "col": 12
+        }
+      }
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single occurrences -identifier-at 2:19 -filename ./issue827.ml < ./issue827.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 18
+        },
+        "end": {
+          "line": 2,
+          "col": 20
+        }
+      },
+      {
+        "start": {
+          "line": 5,
+          "col": 22
+        },
+        "end": {
+          "line": 5,
+          "col": 24
+        }
+      }
+    ],
+    "notifications": []
+  }
+
+Interestingly if you start from a use instead of the definition, it seems to
+work:
+
+  $ $MERLIN single occurrences -identifier-at 4:12 -filename ./issue827.ml < ./issue827.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 13
+        },
+        "end": {
+          "line": 2,
+          "col": 15
+        }
+      },
+      {
+        "start": {
+          "line": 4,
+          "col": 8
+        },
+        "end": {
+          "line": 4,
+          "col": 12
+        }
+      }
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single occurrences -identifier-at 5:23 -filename ./issue827.ml < ./issue827.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 18
+        },
+        "end": {
+          "line": 2,
+          "col": 20
+        }
+      },
+      {
+        "start": {
+          "line": 5,
+          "col": 22
+        },
+        "end": {
+          "line": 5,
+          "col": 24
+        }
+      }
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/occurrences/occ-types.t b/tests/test-dirs/occurrences/occ-types.t
new file mode 100644
index 0000000..aa9215d
--- /dev/null
+++ b/tests/test-dirs/occurrences/occ-types.t
@@ -0,0 +1,65 @@
+
+  $ $MERLIN single occurrences -identifier-at 1:6 -filename type.ml <<EOF | \
+  > jq '.value'
+  > type t
+  > type b = t
+  > EOF
+  [
+    {
+      "start": {
+        "line": 1,
+        "col": 5
+      },
+      "end": {
+        "line": 1,
+        "col": 6
+      }
+    },
+    {
+      "start": {
+        "line": 2,
+        "col": 9
+      },
+      "end": {
+        "line": 2,
+        "col": 10
+      }
+    }
+  ]
+
+  $ $MERLIN single occurrences -identifier-at 1:19 -filename type.ml <<EOF | \
+  > jq '.value'
+  > let f = fun (type t) (foo : t list) -> let (_ : t) = () in ()
+  > EOF
+  [
+    {
+      "start": {
+        "line": 1,
+        "col": 18
+      },
+      "end": {
+        "line": 1,
+        "col": 19
+      }
+    },
+    {
+      "start": {
+        "line": 1,
+        "col": 28
+      },
+      "end": {
+        "line": 1,
+        "col": 29
+      }
+    },
+    {
+      "start": {
+        "line": 1,
+        "col": 48
+      },
+      "end": {
+        "line": 1,
+        "col": 49
+      }
+    }
+  ]
diff --git a/tests/test-dirs/occurrences/occ-with-ppx.t b/tests/test-dirs/occurrences/occ-with-ppx.t
new file mode 100644
index 0000000..0cb5ab1
--- /dev/null
+++ b/tests/test-dirs/occurrences/occ-with-ppx.t
@@ -0,0 +1,76 @@
+  $ cat >dune-project <<EOF
+  > (lang dune 2.9)
+  > EOF
+
+  $ cat >dune <<EOF
+  > (executable
+  >  (name annot)
+  >  (libraries yojson ppx_deriving_yojson.runtime)
+  >  (preprocess (pps ppx_deriving_yojson)))
+  > EOF
+
+  $ cat >annot.ml <<EOF
+  > type foo = {
+  >   a: int;
+  >   b: string;
+  > }
+  > EOF
+
+  $ dune build @check
+
+  $ $MERLIN single occurrences -identifier-at 1:7 -filename annot.ml <annot.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 5
+        },
+        "end": {
+          "line": 1,
+          "col": 8
+        }
+      }
+    ],
+    "notifications": []
+  }
+
+  $ cat >annot.ml <<EOF
+  > type foo = {
+  >   a: int;
+  >   b: string;
+  > }
+  > [@@deriving yojson]
+  > EOF
+
+  $ dune build @check
+
+FIXME: we expect the same result at before, not the whole type declaration
+  $ $MERLIN single occurrences -identifier-at 1:7 -filename annot.ml <annot.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 0
+        },
+        "end": {
+          "line": 5,
+          "col": 19
+        }
+      },
+      {
+        "start": {
+          "line": 1,
+          "col": 0
+        },
+        "end": {
+          "line": 5,
+          "col": 19
+        }
+      }
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/occurrences/pattern.t b/tests/test-dirs/occurrences/pattern.t
new file mode 100644
index 0000000..4fc7f76
--- /dev/null
+++ b/tests/test-dirs/occurrences/pattern.t
@@ -0,0 +1,36 @@
+This test demonstrates the handling of location of patterns. For a pattern like
+(x), the occurrence location should reflect only the identifier.
+
+  $ cat >pat.ml <<EOF
+  > let f x =
+  >   match x with
+  >   | Some (yyy) -> yyy
+  >   | None -> assert false
+  > EOF
+  $ $MERLIN single occurrences -identifier-at 3:10 -filename ./pat.ml < ./pat.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 10
+        },
+        "end": {
+          "line": 3,
+          "col": 13
+        }
+      },
+      {
+        "start": {
+          "line": 3,
+          "col": 18
+        },
+        "end": {
+          "line": 3,
+          "col": 21
+        }
+      }
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/outline-recovery.t b/tests/test-dirs/outline-recovery.t
new file mode 100644
index 0000000..9aff32a
--- /dev/null
+++ b/tests/test-dirs/outline-recovery.t
@@ -0,0 +1,76 @@
+  $ cat >test.ml <<EOF
+  > module Make = struct
+  >   module A = struct end
+  >   module B = C.C1
+  >   module D = struct end
+  > end
+  > EOF
+
+  $ $MERLIN single outline -filename test.ml <test.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 0
+        },
+        "end": {
+          "line": 5,
+          "col": 3
+        },
+        "name": "Make",
+        "kind": "Module",
+        "type": null,
+        "children": [
+          {
+            "start": {
+              "line": 4,
+              "col": 2
+            },
+            "end": {
+              "line": 4,
+              "col": 23
+            },
+            "name": "D",
+            "kind": "Module",
+            "type": null,
+            "children": [],
+            "deprecated": false
+          },
+          {
+            "start": {
+              "line": 3,
+              "col": 2
+            },
+            "end": {
+              "line": 3,
+              "col": 17
+            },
+            "name": "B",
+            "kind": "Module",
+            "type": null,
+            "children": [],
+            "deprecated": false
+          },
+          {
+            "start": {
+              "line": 2,
+              "col": 2
+            },
+            "end": {
+              "line": 2,
+              "col": 23
+            },
+            "name": "A",
+            "kind": "Module",
+            "type": null,
+            "children": [],
+            "deprecated": false
+          }
+        ],
+        "deprecated": false
+      }
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/outline.t/foo.ml b/tests/test-dirs/outline.t/foo.ml
new file mode 100644
index 0000000..cd26241
--- /dev/null
+++ b/tests/test-dirs/outline.t/foo.ml
@@ -0,0 +1,28 @@
+module Bar = struct
+ type t = int
+ module type S1 = sig
+   type t
+
+   val foo : t -> int
+ end
+end
+
+class type class_type_a = object
+  method a : int -> int
+end
+
+class class_b = object
+  method b s = s ^ s
+end
+
+exception Ex of char
+
+type ('a, 'b) eithery =
+  | Lefty of 'a
+  | Righty of 'b
+
+type 'a point =
+  { x : 'a
+  ; y : 'a
+  ; z : 'a
+  }
diff --git a/tests/test-dirs/outline.t/path.ml b/tests/test-dirs/outline.t/path.ml
new file mode 100644
index 0000000..04c6402
--- /dev/null
+++ b/tests/test-dirs/outline.t/path.ml
@@ -0,0 +1,5 @@
+module A = struct 
+  type a = int 
+end 
+open A 
+let x = (5 : a)
diff --git a/tests/test-dirs/outline.t/run.t b/tests/test-dirs/outline.t/run.t
new file mode 100644
index 0000000..e74affc
--- /dev/null
+++ b/tests/test-dirs/outline.t/run.t
@@ -0,0 +1,244 @@
+  $ echo "S .\nB .\nFLG -nopervasives" > .merlin
+  $ $MERLIN single outline < foo.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 24,
+          "col": 0
+        },
+        "end": {
+          "line": 28,
+          "col": 3
+        },
+        "name": "point",
+        "kind": "Type",
+        "type": null,
+        "children": [
+          {
+            "start": {
+              "line": 27,
+              "col": 4
+            },
+            "end": {
+              "line": 27,
+              "col": 10
+            },
+            "name": "z",
+            "kind": "Label",
+            "type": null,
+            "children": [],
+            "deprecated": false
+          },
+          {
+            "start": {
+              "line": 26,
+              "col": 4
+            },
+            "end": {
+              "line": 27,
+              "col": 3
+            },
+            "name": "y",
+            "kind": "Label",
+            "type": null,
+            "children": [],
+            "deprecated": false
+          },
+          {
+            "start": {
+              "line": 25,
+              "col": 4
+            },
+            "end": {
+              "line": 26,
+              "col": 3
+            },
+            "name": "x",
+            "kind": "Label",
+            "type": null,
+            "children": [],
+            "deprecated": false
+          }
+        ],
+        "deprecated": false
+      },
+      {
+        "start": {
+          "line": 20,
+          "col": 0
+        },
+        "end": {
+          "line": 22,
+          "col": 16
+        },
+        "name": "eithery",
+        "kind": "Type",
+        "type": null,
+        "children": [
+          {
+            "start": {
+              "line": 22,
+              "col": 2
+            },
+            "end": {
+              "line": 22,
+              "col": 16
+            },
+            "name": "Righty",
+            "kind": "Constructor",
+            "type": null,
+            "children": [],
+            "deprecated": false
+          },
+          {
+            "start": {
+              "line": 21,
+              "col": 2
+            },
+            "end": {
+              "line": 21,
+              "col": 15
+            },
+            "name": "Lefty",
+            "kind": "Constructor",
+            "type": null,
+            "children": [],
+            "deprecated": false
+          }
+        ],
+        "deprecated": false
+      },
+      {
+        "start": {
+          "line": 18,
+          "col": 0
+        },
+        "end": {
+          "line": 18,
+          "col": 20
+        },
+        "name": "Ex",
+        "kind": "Exn",
+        "type": null,
+        "children": [],
+        "deprecated": false
+      },
+      {
+        "start": {
+          "line": 14,
+          "col": 0
+        },
+        "end": {
+          "line": 16,
+          "col": 3
+        },
+        "name": "class_b",
+        "kind": "Class",
+        "type": null,
+        "children": [
+          {
+            "start": {
+              "line": 15,
+              "col": 9
+            },
+            "end": {
+              "line": 15,
+              "col": 10
+            },
+            "name": "b",
+            "kind": "Method",
+            "type": null,
+            "children": [],
+            "deprecated": false
+          }
+        ],
+        "deprecated": false
+      },
+      {
+        "start": {
+          "line": 1,
+          "col": 0
+        },
+        "end": {
+          "line": 8,
+          "col": 3
+        },
+        "name": "Bar",
+        "kind": "Module",
+        "type": null,
+        "children": [
+          {
+            "start": {
+              "line": 3,
+              "col": 1
+            },
+            "end": {
+              "line": 7,
+              "col": 4
+            },
+            "name": "S1",
+            "kind": "Signature",
+            "type": null,
+            "children": [
+              {
+                "start": {
+                  "line": 6,
+                  "col": 3
+                },
+                "end": {
+                  "line": 6,
+                  "col": 21
+                },
+                "name": "foo",
+                "kind": "Value",
+                "type": "t -> int",
+                "children": [],
+                "deprecated": false
+              },
+              {
+                "start": {
+                  "line": 4,
+                  "col": 3
+                },
+                "end": {
+                  "line": 4,
+                  "col": 9
+                },
+                "name": "t",
+                "kind": "Type",
+                "type": null,
+                "children": [],
+                "deprecated": false
+              }
+            ],
+            "deprecated": false
+          },
+          {
+            "start": {
+              "line": 2,
+              "col": 1
+            },
+            "end": {
+              "line": 2,
+              "col": 13
+            },
+            "name": "t",
+            "kind": "Type",
+            "type": null,
+            "children": [],
+            "deprecated": false
+          }
+        ],
+        "deprecated": false
+      }
+    ],
+    "notifications": []
+  }
+  $ $MERLIN single outline < path.ml | jq '.value[].type'
+  "A.a"
+  null
+  $ $MERLIN single outline -short-paths < path.ml | jq '.value[].type'
+  "a"
+  null
diff --git a/tests/test-dirs/polarity-search.t b/tests/test-dirs/polarity-search.t
new file mode 100644
index 0000000..12c9c1c
--- /dev/null
+++ b/tests/test-dirs/polarity-search.t
@@ -0,0 +1,105 @@
+A few simple tests that show all the things we want to preserve or improve:
+
+# To improve
+
+- Presence of double underscores.
+
+  $ echo "" | $MERLIN single search-by-polarity -query "-float +int64" \
+  > -position 1:0 -filename test.ml | \
+  > jq '.value.entries[] | del(.info) | del(.kind) | del(.deprecated)'
+  {
+    "name": "Stdlib__Int64.bits_of_float",
+    "desc": "float -> int64"
+  }
+  {
+    "name": "Stdlib__Int64.of_float",
+    "desc": "float -> int64"
+  }
+
+- Duplicated elements
+
+  $ echo "" | $MERLIN single search-by-polarity -safe-string \
+  > -query "-int +string" -position 1:0 -filename test.ml | \
+  > tr '\n' ' ' | jq '.value.entries |= (map(del(.deprecated)) | .[:2])'
+  {
+    "class": "return",
+    "value": {
+      "entries": [
+        {
+          "name": "string_of_int",
+          "kind": "Value",
+          "desc": "int -> string",
+          "info": ""
+        },
+        {
+          "name": "string_of_int",
+          "kind": "Value",
+          "desc": "int -> string",
+          "info": ""
+        }
+      ],
+      "context": null
+    },
+    "notifications": []
+  }
+
+# To keep
+
+- Lower bound on function arity
+
+  $ echo "" | $MERLIN single search-by-polarity \
+  > -query "-float +fun +fun +float" -position 1:0 -filename test.ml | \
+  > tr '\n' ' ' | jq '.value.entries |= (map(del(.info) | del(.kind) | del (.deprecated)) | .[0:11])'
+  {
+    "class": "return",
+    "value": {
+      "entries": [
+        {
+          "name": "**",
+          "desc": "float -> float -> float"
+        },
+        {
+          "name": "**",
+          "desc": "float -> float -> float"
+        },
+        {
+          "name": "*.",
+          "desc": "float -> float -> float"
+        },
+        {
+          "name": "*.",
+          "desc": "float -> float -> float"
+        },
+        {
+          "name": "+.",
+          "desc": "float -> float -> float"
+        },
+        {
+          "name": "+.",
+          "desc": "float -> float -> float"
+        },
+        {
+          "name": "-.",
+          "desc": "float -> float -> float"
+        },
+        {
+          "name": "-.",
+          "desc": "float -> float -> float"
+        },
+        {
+          "name": "/.",
+          "desc": "float -> float -> float"
+        },
+        {
+          "name": "/.",
+          "desc": "float -> float -> float"
+        },
+        {
+          "name": "atan2",
+          "desc": "float -> float -> float"
+        }
+      ],
+      "context": null
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/pp/dot-pp-dot-ml-dune.t b/tests/test-dirs/pp/dot-pp-dot-ml-dune.t
new file mode 100644
index 0000000..952a180
--- /dev/null
+++ b/tests/test-dirs/pp/dot-pp-dot-ml-dune.t
@@ -0,0 +1,101 @@
+First, prepare our preprocessor:
+
+  $ cat >prep.ml <<EOF
+  > let output_to_stdout fn str =
+  >   output_string stdout Config.ast_impl_magic_number;
+  >   output_value  stdout (fn : string);
+  >   output_value  stdout (str : Parsetree.structure)
+  > 
+  > let () =
+  >   let to_file, in_file =
+  >     match Sys.argv.(1) with
+  >     | "-dump-to-file" -> true, Sys.argv.(2)
+  >     | filename -> false, filename
+  >   in
+  >   let str = Pparse.parse_implementation ~tool_name:"prep" in_file in
+  >   if to_file then
+  >     let out_file = Filename.chop_suffix in_file "ml" ^ "pp.ml" in
+  >     Pparse.write_ast Structure out_file str
+  >   else
+  >     output_to_stdout in_file str
+  > EOF
+
+  $ $OCAMLC -I +compiler-libs ocamlcommon.cma -o prep.exe prep.ml
+  $ rm prep.cm* prep.ml
+
+Then our test files:
+
+  $ mkdir liba libb
+
+  $ cat >dune-project <<EOF
+  > (lang dune 2.7)
+  > EOF
+
+  $ cat >liba/dune <<EOF
+  > (library (name liba))
+  > EOF
+
+  $ cat >libb/dune <<EOF
+  > (library
+  >  (name libb)
+  >  (preprocess (action (system "./prep.exe %{input-file}"))))
+  > EOF
+
+  $ cat >dune <<EOF
+  > (library (name test) (libraries liba libb))
+  > EOF
+
+  $ cat >liba/dep.ml <<EOF
+  > let x = "A"
+  > EOF
+
+  $ cat >libb/dep.ml <<EOF
+  > let x = "B"
+  > EOF
+
+  $ cat >liba/liba.ml <<EOF
+  > module Dep = Dep
+  > EOF
+
+  $ cat >libb/libb.ml <<EOF
+  > module Dep = Dep
+  > EOF
+
+  $ cat >test.ml <<EOF
+  > let _ = Liba.Dep.x
+  > let _ = Libb.Dep.x
+  > EOF
+
+Now build with dune:
+
+  $ BUILD_PATH_PREFIX_MAP= dune build 2>/dev/null
+
+And confirm that locate works on both deps:
+
+  $ $MERLIN single locate -look-for ml -position 1:15 \
+  > -filename test.ml < ./test.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/liba/dep.ml",
+      "pos": {
+        "line": 1,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for ml -position 2:15 \
+  > -filename test.ml < ./test.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/libb/dep.ml",
+      "pos": {
+        "line": 1,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/pp/dot-pp-dot-ml.t b/tests/test-dirs/pp/dot-pp-dot-ml.t
new file mode 100644
index 0000000..1c41b57
--- /dev/null
+++ b/tests/test-dirs/pp/dot-pp-dot-ml.t
@@ -0,0 +1,89 @@
+First, prepare our preprocessor:
+
+  $ cat >prep.ml <<EOF
+  > let output_to_stdout fn str =
+  >   output_string stdout Config.ast_impl_magic_number;
+  >   output_value  stdout (fn : string);
+  >   output_value  stdout (str : Parsetree.structure)
+  > 
+  > let () =
+  >   let to_file, in_file =
+  >     match Sys.argv.(1) with
+  >     | "-dump-to-file" -> true, Sys.argv.(2)
+  >     | filename -> false, filename
+  >   in
+  >   let str = Pparse.parse_implementation ~tool_name:"prep" in_file in
+  >   if to_file then
+  >     let out_file = Filename.chop_suffix in_file "ml" ^ "pp.ml" in
+  >     Pparse.write_ast Structure out_file str
+  >   else
+  >     output_to_stdout in_file str
+  > EOF
+
+  $ mkdir -p _build
+  $ cp prep.ml _build
+  $ (cd _build; $OCAMLC -I +compiler-libs ocamlcommon.cma -o prep.exe prep.ml)
+
+Then our test files:
+
+  $ mkdir liba libb
+
+  $ cat >liba/dep.ml <<EOF
+  > let x = "A"
+  > EOF
+
+  $ cat >libb/dep.ml <<EOF
+  > let x = "B"
+  > EOF
+
+  $ cat >test.ml <<EOF
+  > let _ = LibaDep.x
+  > let _ = LibbDep.x
+  > EOF
+
+----------------------------------------------------------
+
+Build the files in _build as dune would, preprocessing liba in the "usual" way
+and libb with dune cached way:
+
+  $ cp -r liba libb test.ml _build
+
+  $ cd _build/liba
+  $ $OCAMLC -c -pp ../prep.exe -bin-annot -o libaDep.cmo dep.ml
+  $ cd ..
+
+  $ cd libb
+  $ ../prep.exe -dump-to-file ./dep.ml
+  $ $OCAMLC -c -bin-annot -o libbDep.cmo dep.pp.ml
+  $ cd ..
+
+  $ $OCAMLC -I liba -I libb -c test.ml
+  $ cd ..
+
+And confirm that locate works on both deps:
+
+  $ $MERLIN single locate -look-for ml -position 1:11 \
+  > -build-path _build/liba -source-path liba \
+  > -build-path _build/libb -source-path libb \
+  > -filename test.ml < ./test.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/liba/dep.ml",
+      "pos": {
+        "line": 1,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }
+
+  $ $MERLIN single locate -look-for ml -position 2:11 \
+  > -build-path _build/liba -source-path liba \
+  > -build-path _build/libb -source-path libb \
+  > -filename test.ml < ./test.ml
+  {
+    "class": "return",
+    "value": "Several source files in your path have the same name, and merlin doesn't know which is the right one: $TESTCASE_ROOT/liba/dep.ml, $TESTCASE_ROOT/libb/dep.ml",
+    "notifications": []
+  }
diff --git a/tests/test-dirs/pp/dune b/tests/test-dirs/pp/dune
new file mode 100755
index 0000000..257435b
--- /dev/null
+++ b/tests/test-dirs/pp/dune
@@ -0,0 +1,4 @@
+(cram
+ (applies_to dot-pp-dot-ml-dune dot-pp-dot-ml simple-pp)
+ (enabled_if
+  (<> %{os_type} Win32)))
diff --git a/tests/test-dirs/pp/simple-pp.t b/tests/test-dirs/pp/simple-pp.t
new file mode 100644
index 0000000..edc96a2
--- /dev/null
+++ b/tests/test-dirs/pp/simple-pp.t
@@ -0,0 +1,62 @@
+  $ $MERLIN single errors -pp cat -filename test.ml <<EOF
+  > let x : int = "hello"
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 14
+        },
+        "end": {
+          "line": 1,
+          "col": 21
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "This expression has type string but an expression was expected of type int"
+      }
+    ],
+    "notifications": []
+  }
+  $ $MERLIN single errors -pp 'cpp -Wno-everything -E' -filename test.ml <<EOF
+  > #ifndef FOO
+  > let x : int = "hello"
+  > #else
+  > let x : int = 42
+  > #endif
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 14
+        },
+        "end": {
+          "line": 2,
+          "col": 21
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "This expression has type string but an expression was expected of type int"
+      }
+    ],
+    "notifications": []
+  }
+  $ $MERLIN single errors -pp 'cpp -Wno-everything -E' -filename test.ml <<EOF
+  > #ifdef FOO
+  > let x : int = "hello"
+  > #else
+  > let x : int = 42
+  > #endif
+  > EOF
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/recovery.t b/tests/test-dirs/recovery.t
new file mode 100644
index 0000000..df25068
--- /dev/null
+++ b/tests/test-dirs/recovery.t
@@ -0,0 +1,170 @@
+_ should be parsed as Pexp_hole or Pmod_hole, and shouldn't be treated as a type
+error.
+
+  $ echo "let () = _" | \
+  > $MERLIN single errors -filename hole_0.ml
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
+
+  $ echo "module M = _" | \
+  > $MERLIN single errors -filename hole_2.ml
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
+
+This incomplete expression should generate only a parser error.
+The hole is filled with merlin.hole.
+
+  $ echo "let _ =" | \
+  > $MERLIN single errors -filename hole_1.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 0
+        },
+        "end": {
+          "line": 2,
+          "col": 0
+        },
+        "type": "parser",
+        "sub": [],
+        "valid": true,
+        "message": "Syntax error, expecting expr"
+      }
+    ],
+    "notifications": []
+  }
+
+  $ echo "let _ =" | \
+  > $MERLIN single dump -what source -filename hole_1.ml | \
+  > tr -d '\n' | jq '.value'
+  "let _ = _"
+
+  $ echo "module M : sig val f : int -> unit end =" |
+  > $MERLIN single errors -filename "module_recovery.ml"
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 40
+        },
+        "end": {
+          "line": 1,
+          "col": 40
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Signature mismatch:
+  Modules do not match: sig end is not included in sig val f : int -> unit end
+  The value `f' is required but not provided
+  File \"module_recovery.ml\", line 1, characters 15-34: Expected declaration"
+      },
+      {
+        "start": {
+          "line": 2,
+          "col": 0
+        },
+        "end": {
+          "line": 2,
+          "col": 0
+        },
+        "type": "parser",
+        "sub": [],
+        "valid": true,
+        "message": "Syntax error, expecting module_expr"
+      }
+    ],
+    "notifications": []
+  }
+
+  $ echo "module M =" |
+  > $MERLIN single dump -what source -filename "module_recovery.ml"
+  {
+    "class": "return",
+    "value": "module M = struct  end
+  
+  ",
+    "notifications": []
+  }
+
+A bit trickier: the recovery is tempted to put a ->. (unreachable), but the
+penalty should prevent it.
+
+  $ echo "let f = function _ ->" | \
+  > $MERLIN single errors -filename  "hole_2.ml"
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 0
+        },
+        "end": {
+          "line": 2,
+          "col": 0
+        },
+        "type": "parser",
+        "sub": [],
+        "valid": true,
+        "message": "Syntax error, expecting expr"
+      }
+    ],
+    "notifications": []
+  }
+
+Issue #713: merlin would error when it cannot recover, but in some files there
+really is nothing to recover.
+
+Note: in 4.08 the suggestion changed from "exception" to "open" and the recovery
+generates "let open struct end in [%merlin.hole ]".
+
+FIXME: the syntax error message is off the mark.
+
+  $ echo "let" | \
+  > $MERLIN single errors -filename  "two_constr.ml" | \
+  > sed 's/expecting.*/<unstable suggestion>/'
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 0
+        },
+        "end": {
+          "line": 2,
+          "col": 0
+        },
+        "type": "parser",
+        "sub": [],
+        "valid": true,
+        "message": "Syntax error, <unstable suggestion>
+      }
+    ],
+    "notifications": []
+  }
+
+  $ echo "let test x = match x with | None -> exit 1 | Some pkg -> pkg end" | \
+  > $MERLIN single dump -what source -filename "lessminus.ml"
+  {
+    "class": "return",
+    "value": "let test x =
+    match x with
+    | None -> ((exit 1)[@merlin.loc ])
+    | Some pkg -> ((pkg)[@merlin.loc ])
+  
+  ",
+    "notifications": []
+  }
diff --git a/tests/test-dirs/refactor-open/functor-app.t/run.t b/tests/test-dirs/refactor-open/functor-app.t/run.t
new file mode 100644
index 0000000..5287c34
--- /dev/null
+++ b/tests/test-dirs/refactor-open/functor-app.t/run.t
@@ -0,0 +1,144 @@
+FIXME: functor applications in type paths are not handled
+
+Unqualifying inside application paths:
+
+  $ $MERLIN single refactor-open -action unqualify -position 26:10 \
+  > -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 28,
+          "col": 44
+        },
+        "end": {
+          "line": 28,
+          "col": 53
+        },
+        "content": "C"
+      },
+      {
+        "start": {
+          "line": 29,
+          "col": 12
+        },
+        "end": {
+          "line": 29,
+          "col": 24
+        },
+        "content": "Make"
+      },
+      {
+        "start": {
+          "line": 29,
+          "col": 26
+        },
+        "end": {
+          "line": 29,
+          "col": 35
+        },
+        "content": "C"
+      },
+      {
+        "start": {
+          "line": 31,
+          "col": 12
+        },
+        "end": {
+          "line": 31,
+          "col": 24
+        },
+        "content": "Make"
+      },
+      {
+        "start": {
+          "line": 36,
+          "col": 19
+        },
+        "end": {
+          "line": 36,
+          "col": 28
+        },
+        "content": "C"
+      },
+      {
+        "start": {
+          "line": 37,
+          "col": 13
+        },
+        "end": {
+          "line": 37,
+          "col": 25
+        },
+        "content": "Make"
+      }
+    ],
+    "notifications": []
+  }
+
+Qualifying inside application paths:
+
+  $ $MERLIN single refactor-open -action qualify -position 26:10 \
+  > -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 33,
+          "col": 13
+        },
+        "end": {
+          "line": 33,
+          "col": 17
+        },
+        "content": "Wrapper.Make"
+      },
+      {
+        "start": {
+          "line": 33,
+          "col": 19
+        },
+        "end": {
+          "line": 33,
+          "col": 20
+        },
+        "content": "Wrapper.C"
+      },
+      {
+        "start": {
+          "line": 34,
+          "col": 13
+        },
+        "end": {
+          "line": 34,
+          "col": 17
+        },
+        "content": "Wrapper.Make"
+      },
+      {
+        "start": {
+          "line": 36,
+          "col": 13
+        },
+        "end": {
+          "line": 36,
+          "col": 17
+        },
+        "content": "Wrapper.Make"
+      },
+      {
+        "start": {
+          "line": 37,
+          "col": 27
+        },
+        "end": {
+          "line": 37,
+          "col": 28
+        },
+        "content": "Wrapper.C"
+      }
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/refactor-open/functor-app.t/test.ml b/tests/test-dirs/refactor-open/functor-app.t/test.ml
new file mode 100644
index 0000000..6a7628c
--- /dev/null
+++ b/tests/test-dirs/refactor-open/functor-app.t/test.ml
@@ -0,0 +1,42 @@
+module Wrapper = struct
+  module type S = sig
+    type t
+    val x : t
+  end
+
+  module Make (X : S) = struct
+    include X
+
+    let () = ignore x
+  end
+
+  module C = struct
+    type t = char
+    let x  = 'a'
+  end
+end
+
+module I = struct
+  type t = int
+  let x  = 42
+end
+
+module Hammer = Wrapper
+
+open Wrapper
+
+module MC = Hammer (* just because *).Make (Wrapper.C)
+module MD = Wrapper.Make (Wrapper.C)
+
+module MI = Wrapper.Make (I)
+
+module MC2 = Make (C)
+module MI2 = Make (I)
+
+module MC3 = Make (Wrapper.C)
+module MC4 = Wrapper.Make (C)
+
+type t1 = Wrapper.Make(Wrapper.C).t
+type t2 = Make(Wrapper.C).t
+type t3 = Wrapper.Make(C).t
+type t4 = Make(C).t
diff --git a/tests/test-dirs/refactor-open/qualify.t b/tests/test-dirs/refactor-open/qualify.t
new file mode 100644
index 0000000..0c87c3a
--- /dev/null
+++ b/tests/test-dirs/refactor-open/qualify.t
@@ -0,0 +1,123 @@
+Can qualify module located in the same file
+  $ $MERLIN single refactor-open -action qualify -position 4:6 <<EOF
+  > module M = struct
+  >   let u = ()
+  > end
+  > open M
+  > let u = u
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 5,
+          "col": 8
+        },
+        "end": {
+          "line": 5,
+          "col": 9
+        },
+        "content": "M.u"
+      }
+    ],
+    "notifications": []
+  }
+
+Can qualify nested modules located in the same file
+
+  $ $MERLIN single refactor-open -action qualify -position 6:6 <<EOF
+  > module M = struct
+  >   module N = struct
+  >     let u = ()
+  >   end
+  > end
+  > open M.N
+  > let u = u
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 7,
+          "col": 8
+        },
+        "end": {
+          "line": 7,
+          "col": 9
+        },
+        "content": "M.N.u"
+      }
+    ],
+    "notifications": []
+  }
+
+Can qualify a module from an external library
+
+  $ $MERLIN single refactor-open -action qualify -position 1:6 <<EOF
+  > open Unix
+  > let times = times ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 12
+        },
+        "end": {
+          "line": 2,
+          "col": 17
+        },
+        "content": "Unix.times"
+      }
+    ],
+    "notifications": []
+  }
+
+Can qualify nested modules from the same file, including open statements, and 
+does not return duplicate edits
+
+  $ $MERLIN single refactor-open -action qualify -position 8:6 <<EOF
+  > module L = struct
+  >   module M = struct
+  >     module N = struct
+  >       let u = ()
+  >     end
+  >   end
+  > end
+  > open L 
+  > open M.N
+  > let () = u
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 9,
+          "col": 5
+        },
+        "end": {
+          "line": 9,
+          "col": 8
+        },
+        "content": "L.M.N"
+      },
+      {
+        "start": {
+          "line": 10,
+          "col": 9
+        },
+        "end": {
+          "line": 10,
+          "col": 10
+        },
+        "content": "L.M.N.u"
+      }
+    ],
+    "notifications": []
+  }
+
diff --git a/tests/test-dirs/refactor-open/qualify_short_paths.t b/tests/test-dirs/refactor-open/qualify_short_paths.t
new file mode 100644
index 0000000..c71c0c6
--- /dev/null
+++ b/tests/test-dirs/refactor-open/qualify_short_paths.t
@@ -0,0 +1,29 @@
+refactor open qualify should use short paths
+
+  $ $MERLIN single refactor-open -action qualify -position 7:6 <<EOF
+  > module Dune__exe = struct
+  >   module M = struct
+  >     let u = ()
+  >   end
+  > end
+  > open Dune__exe
+  > open M
+  > let u = u
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 8,
+          "col": 8
+        },
+        "end": {
+          "line": 8,
+          "col": 9
+        },
+        "content": "M.u"
+      }
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/refactor-open/record_field.t b/tests/test-dirs/refactor-open/record_field.t
new file mode 100644
index 0000000..5c9edab
--- /dev/null
+++ b/tests/test-dirs/refactor-open/record_field.t
@@ -0,0 +1,61 @@
+Refactor open for record fields
+
+  $ $MERLIN single refactor-open -action unqualify -position 4:7 <<EOF
+  > module M = struct
+  >   type r = {i: int}
+  > end
+  > open M
+  > let r = {M.i = 1}
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 5,
+          "col": 9
+        },
+        "end": {
+          "line": 5,
+          "col": 12
+        },
+        "content": "i"
+      }
+    ],
+    "notifications": []
+  }
+
+Refactor open for record disambiguation
+
+  $ $MERLIN single refactor-open -action qualify -position 1:6 <<EOF
+  > open Unix
+  > let f x = x.tms_stime, x.tms_utime
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 12
+        },
+        "end": {
+          "line": 2,
+          "col": 21
+        },
+        "content": "Unix.tms_stime"
+      },
+      {
+        "start": {
+          "line": 2,
+          "col": 25
+        },
+        "end": {
+          "line": 2,
+          "col": 34
+        },
+        "content": "Unix.tms_utime"
+      }
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/refactor-open/unqualify.t b/tests/test-dirs/refactor-open/unqualify.t
new file mode 100644
index 0000000..6d9084f
--- /dev/null
+++ b/tests/test-dirs/refactor-open/unqualify.t
@@ -0,0 +1,102 @@
+Can unqualify module located in the same file
+  $ $MERLIN single refactor-open -action unqualify -position 4:6 <<EOF
+  > module M = struct
+  >   let u = ()
+  > end
+  > open M
+  > let u = M.u
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 5,
+          "col": 8
+        },
+        "end": {
+          "line": 5,
+          "col": 11
+        },
+        "content": "u"
+      }
+    ],
+    "notifications": []
+  }
+
+Can unqualify nested modules located in the same file
+
+  $ $MERLIN single refactor-open -action unqualify -position 6:6 <<EOF
+  > module M = struct
+  >   module N = struct
+  >     let u = ()
+  >   end
+  > end
+  > open M.N
+  > let u = M.N.u
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 7,
+          "col": 8
+        },
+        "end": {
+          "line": 7,
+          "col": 13
+        },
+        "content": "u"
+      }
+    ],
+    "notifications": []
+  }
+
+Shouldn't return anything, as nothing to unqualify (for multiline identifiers)
+
+  $ $MERLIN single refactor-open -action unqualify -position 1:6 <<EOF
+  > open Unix
+  > let f x = x.
+  >             tms_stime
+  > EOF
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
+
+Shouldn't return anything, as nothing to unqualify (for multi-line identifiers)
+
+  $ $MERLIN single refactor-open -action unqualify -position 6:6 <<EOF
+  > module M = struct
+  >   module N = struct
+  >     let u = ()
+  >   end
+  > end
+  > open M
+  > let u = N.
+  > u
+  > EOF
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
+
+Unqualify should not qualify
+
+  $ $MERLIN single refactor-open -action unqualify -position 6:6 <<EOF
+  > module M = struct
+  >   module N = struct
+  >     type t = Foo | Bar
+  >   end
+  > end
+  > open M
+  > let v : N.t = Foo
+  > EOF
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/server-tests/dune b/tests/test-dirs/server-tests/dune
new file mode 100644
index 0000000..3b649e9
--- /dev/null
+++ b/tests/test-dirs/server-tests/dune
@@ -0,0 +1,5 @@
+
+(cram
+ (applies_to :whole_subtree)
+ (alias all-server-tests)
+ (locks merlin_server))
diff --git a/tests/test-dirs/server-tests/locate-state/reset-file-switching.t b/tests/test-dirs/server-tests/locate-state/reset-file-switching.t
new file mode 100644
index 0000000..6abc53d
--- /dev/null
+++ b/tests/test-dirs/server-tests/locate-state/reset-file-switching.t
@@ -0,0 +1,65 @@
+Reproduce [ocaml-lsp #344](https://github.com/ocaml/ocaml-lsp/issues/344): a symbol's
+documentation is some other random documentation from a library that was last pulled for
+completion. See the issue for details. The space is necessary for the position of
+documentation to be fetch-able.
+
+  $ cat >lib_doc.ml <<EOF
+  > 
+  > 
+  > 
+  > 
+  > 
+  > 
+  > 
+  > 
+  > 
+  > 
+  > 
+  > 
+  > 
+  > 
+  > 
+  > 
+  > 
+  > 
+  > 
+  > 
+  > 
+  > 
+  > let k = ()
+  > let m = List.map
+  > EOF
+
+we need merlin to keep state between requests, so using server
+
+  $ $MERLIN server stop-server
+
+see that there is no doc for k
+
+  $ $MERLIN server document -position 23:5 < lib_doc.ml | jq '.value'
+  "No documentation available"
+
+we trigger the bug
+
+  $ $MERLIN server document -position 24:15 -filename lib_doc < lib_doc.ml
+  {
+    "class": "return",
+    "value": " [map f [a1; ...; an]] applies function [f] to [a1, ..., an],
+     and builds the list [[f a1; ...; f an]]
+     with the results returned by [f]. Not tail-recursive.
+   ",
+    "notifications": []
+  }
+
+random documentation is fetched for the same `document` request as before
+
+  $ $MERLIN server document -position 23:5 < lib_doc.ml
+  {
+    "class": "return",
+    "value": "No documentation available",
+    "notifications": []
+  }
+
+stop server
+
+  $ $MERLIN server stop-server
diff --git a/tests/test-dirs/server-tests/typer-cache/current-level.t/run.t b/tests/test-dirs/server-tests/typer-cache/current-level.t/run.t
new file mode 100644
index 0000000..0300ce2
--- /dev/null
+++ b/tests/test-dirs/server-tests/typer-cache/current-level.t/run.t
@@ -0,0 +1,58 @@
+The server might already be running, we kill it to make sure we start from a
+clean slate:
+  $ $MERLIN server stop-server
+
+Then we can look at the current level and whether it's being reset between
+buffers, and different runs for the same buffer:
+
+  $ echo "let f x = x" | \
+  > $MERLIN server dump -what current-level -filename test.ml
+  {
+    "class": "return",
+    "value": 0,
+    "notifications": []
+  }
+
+  $ echo "let f x = x" | \
+  > $MERLIN server dump -what current-level -filename test.ml
+  {
+    "class": "return",
+    "value": 0,
+    "notifications": []
+  }
+
+  $ echo "type u= Uouo let f x = x type t = Toto" | \
+  > $MERLIN server dump -what current-level -filename test.ml
+  {
+    "class": "return",
+    "value": 2,
+    "notifications": []
+  }
+
+  $ echo "let f x = x" | \
+  > $MERLIN server dump -what current-level -filename test.ml
+  {
+    "class": "return",
+    "value": 2,
+    "notifications": []
+  }
+
+
+  $ echo "let f x = x" | \
+  > $MERLIN server dump -what current-level -filename other_test.ml
+  {
+    "class": "return",
+    "value": 0,
+    "notifications": []
+  }
+
+
+  $ echo "let f x = x" | \
+  > $MERLIN server dump -what current-level -filename test.ml
+  {
+    "class": "return",
+    "value": 2,
+    "notifications": []
+  }
+
+  $ $MERLIN server stop-server
diff --git a/tests/test-dirs/server-tests/typer-cache/dune b/tests/test-dirs/server-tests/typer-cache/dune
new file mode 100644
index 0000000..417670b
--- /dev/null
+++ b/tests/test-dirs/server-tests/typer-cache/dune
@@ -0,0 +1,6 @@
+(cram 
+ (applies_to stamps)
+ (enabled_if 
+  (and 
+   (<> %{ocaml_version} 4.12.0+multicore)
+   (<> %{ocaml_version} 4.12.0+domains))))
diff --git a/tests/test-dirs/server-tests/typer-cache/load_path.t/run.t b/tests/test-dirs/server-tests/typer-cache/load_path.t/run.t
new file mode 100644
index 0000000..249f4fd
--- /dev/null
+++ b/tests/test-dirs/server-tests/typer-cache/load_path.t/run.t
@@ -0,0 +1,172 @@
+Instances of the typechecker are cached based on configuration 
+(values of type `Mconfig.t`).
+
+Older versions of Merlin ignored some components resulting in possible
+mismatches between the internal configuration of the typechecker (loadpath,
+global modules visible from the environment) and Merlin configuration.
+
+For instance, `-package` and `-cmi-path` were ignored.
+
+The server might already be running, we kill it to make sure we start from a
+clean slate:
+  $ $MERLIN server stop-server
+
+We build a dep which we will be revealed to Merlin later:
+
+  $ $OCAMLC -c sub/dep.ml
+
+First try with dep hidden:
+
+  $ $MERLIN server errors -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 5
+        },
+        "end": {
+          "line": 1,
+          "col": 8
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Unbound module Dep"
+      }
+    ],
+    "notifications": []
+  }
+
+For reference, the answer in single mode:
+
+  $ $MERLIN single errors -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 5
+        },
+        "end": {
+          "line": 1,
+          "col": 8
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Unbound module Dep"
+      }
+    ],
+    "notifications": []
+  }
+
+
+We try again after revealing the dependency:
+
+  $ $MERLIN server errors -filename test.ml -cmi-path sub < test.ml
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
+
+
+Reference:
+
+  $ $MERLIN single errors -filename test.ml -cmi-path sub < test.ml
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
+
+
+Well behaving versions of Merlin (>= 3.3.4) of should return the same answer as
+reference.
+
+We should check in the other direction too. Starting from a visible dep and
+hiding it.  Older versions of the typechecker (before the 4.08 revamp of Env)
+would accumulate dependencies and forget to flush the cache when a dependency
+disappeared.
+ 
+  $ $MERLIN server stop-server
+
+
+Visible:
+
+  $ $MERLIN server errors -filename test.ml -cmi-path sub < test.ml
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
+
+
+Reference:
+
+  $ $MERLIN single errors -filename test.ml -cmi-path sub < test.ml
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
+
+
+Hidden:
+
+  $ $MERLIN server errors -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 5
+        },
+        "end": {
+          "line": 1,
+          "col": 8
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Unbound module Dep"
+      }
+    ],
+    "notifications": []
+  }
+
+
+Reference:
+
+  $ $MERLIN single errors -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 5
+        },
+        "end": {
+          "line": 1,
+          "col": 8
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Unbound module Dep"
+      }
+    ],
+    "notifications": []
+  }
+
+
+Now some cleanup.
+
+  $ rm sub/dep.cm*
+
+  $ $MERLIN server stop-server
diff --git a/tests/test-dirs/server-tests/typer-cache/load_path.t/sub/dep.ml b/tests/test-dirs/server-tests/typer-cache/load_path.t/sub/dep.ml
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tests/test-dirs/server-tests/typer-cache/load_path.t/sub/dep.ml
diff --git a/tests/test-dirs/server-tests/typer-cache/load_path.t/test.ml b/tests/test-dirs/server-tests/typer-cache/load_path.t/test.ml
new file mode 100644
index 0000000..2c75085
--- /dev/null
+++ b/tests/test-dirs/server-tests/typer-cache/load_path.t/test.ml
@@ -0,0 +1 @@
+open Dep
diff --git a/tests/test-dirs/server-tests/typer-cache/stamps.t/run.t b/tests/test-dirs/server-tests/typer-cache/stamps.t/run.t
new file mode 100644
index 0000000..f5158dc
--- /dev/null
+++ b/tests/test-dirs/server-tests/typer-cache/stamps.t/run.t
@@ -0,0 +1,38 @@
+The server might already be running, we kill it to make sure we start from a
+clean slate:
+  $ $MERLIN server stop-server
+
+Then we can look at identifier stamps and whether they are being reset between
+buffers, and different runs for the same buffer:
+
+  $ echo "let f x = x" | \
+  > $MERLIN server dump -what browse -filename test.ml | \
+  > sed 's:\\n:\n:g' | grep Tpat_var
+    Tpat_var \"f/81\"
+    Tpat_var \"x/83\"
+
+  $ echo "let f x = let () = () in x" | \
+  > $MERLIN server dump -what browse -filename test.ml | \
+  > sed 's:\\n:\n:g' | grep Tpat_var
+    Tpat_var \"f/84\"
+    Tpat_var \"x/86\"
+
+  $ echo "let f x = x" | \
+  > $MERLIN server dump -what browse -filename other_test.ml | \
+  > sed 's:\\n:\n:g' | grep Tpat_var
+    Tpat_var \"f/81\"
+    Tpat_var \"x/83\"
+
+  $ echo "let f x = let () = () in x" | \
+  > $MERLIN server dump -what browse -filename test.ml | \
+  > sed 's:\\n:\n:g' | grep Tpat_var
+    Tpat_var \"f/84\"
+    Tpat_var \"x/86\"
+
+  $ echo "let f x = x" | \
+  > $MERLIN server dump -what browse -filename test.ml | \
+  > sed 's:\\n:\n:g' | grep Tpat_var
+    Tpat_var \"f/87\"
+    Tpat_var \"x/89\"
+
+  $ $MERLIN server stop-server
diff --git a/tests/test-dirs/server-tests/typer-cache/sub.t/run.t b/tests/test-dirs/server-tests/typer-cache/sub.t/run.t
new file mode 100644
index 0000000..ad97f3b
--- /dev/null
+++ b/tests/test-dirs/server-tests/typer-cache/sub.t/run.t
@@ -0,0 +1,174 @@
+Instances of the typechecker are cached based on configuration
+(values of type `Mconfig.t`).
+
+Older versions of Merlin ignored some components resulting in possible
+mismatches between the internal configuration of the typechecker (loadpath,
+global modules visible from the environment) and Merlin configuration.
+
+For instance, `-package` and `-cmi-path` were ignored.
+
+The server might already be running, we kill it to make sure we start from a
+clean slate:
+  $ $MERLIN server stop-server
+
+We build a dep which we will be revealed to Merlin later:
+
+  $ mkdir sub
+  $ touch sub/dep.ml
+  $ $OCAMLC -c sub/dep.ml
+
+First try with dep hidden:
+
+  $ $MERLIN server errors -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 5
+        },
+        "end": {
+          "line": 1,
+          "col": 8
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Unbound module Dep"
+      }
+    ],
+    "notifications": []
+  }
+
+For reference, the answer in single mode:
+
+  $ $MERLIN single errors -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 5
+        },
+        "end": {
+          "line": 1,
+          "col": 8
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Unbound module Dep"
+      }
+    ],
+    "notifications": []
+  }
+
+
+We try again after revealing the dependency:
+
+  $ $MERLIN server errors -filename test.ml -cmi-path sub < test.ml
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
+
+
+Reference:
+
+  $ $MERLIN single errors -filename test.ml -cmi-path sub < test.ml
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
+
+
+Well behaving versions of Merlin (>= 3.3.4) of should return the same answer as
+reference.
+
+We should check in the other direction too. Starting from a visible dep and
+hiding it.  Older versions of the typechecker (before the 4.08 revamp of Env)
+would accumulate dependencies and forget to flush the cache when a dependency
+disappeared.
+
+  $ $MERLIN server stop-server
+
+
+Visible:
+
+  $ $MERLIN server errors -filename test.ml -cmi-path sub < test.ml
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
+
+
+Reference:
+
+  $ $MERLIN single errors -filename test.ml -cmi-path sub < test.ml
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
+
+
+Hidden:
+
+  $ $MERLIN server errors -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 5
+        },
+        "end": {
+          "line": 1,
+          "col": 8
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Unbound module Dep"
+      }
+    ],
+    "notifications": []
+  }
+
+
+Reference:
+
+  $ $MERLIN single errors -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 5
+        },
+        "end": {
+          "line": 1,
+          "col": 8
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Unbound module Dep"
+      }
+    ],
+    "notifications": []
+  }
+
+
+Now some cleanup.
+
+  $ rm sub/dep.cm*
+
+  $ $MERLIN server stop-server
diff --git a/tests/test-dirs/server-tests/typer-cache/sub.t/test.ml b/tests/test-dirs/server-tests/typer-cache/sub.t/test.ml
new file mode 100644
index 0000000..2c75085
--- /dev/null
+++ b/tests/test-dirs/server-tests/typer-cache/sub.t/test.ml
@@ -0,0 +1 @@
+open Dep
diff --git a/tests/test-dirs/server-tests/warnings/backtrack.t b/tests/test-dirs/server-tests/warnings/backtrack.t
new file mode 100644
index 0000000..99d27a2
--- /dev/null
+++ b/tests/test-dirs/server-tests/warnings/backtrack.t
@@ -0,0 +1,81 @@
+The server might already be running, we kill it to make sure we start from a
+clean slate:
+  $ $MERLIN server stop-server
+
+If warnings are not backtracked properly, when reusing the same type checking
+environment in different queries, some warnings will be reported only once.
+
+  $ $MERLIN server errors -filename backtrack.ml -w +A <<EOF
+  > let f x = ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 6
+        },
+        "end": {
+          "line": 1,
+          "col": 7
+        },
+        "type": "warning",
+        "sub": [],
+        "valid": true,
+        "message": "Warning 27: unused variable x."
+      }
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN server errors -filename backtrack.ml -w +A <<EOF
+  > 
+  > let f x = ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 6
+        },
+        "end": {
+          "line": 2,
+          "col": 7
+        },
+        "type": "warning",
+        "sub": [],
+        "valid": true,
+        "message": "Warning 27: unused variable x."
+      }
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN server errors -filename backtrack.ml -w +A <<EOF
+  > let f x = ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 6
+        },
+        "end": {
+          "line": 1,
+          "col": 7
+        },
+        "type": "warning",
+        "sub": [],
+        "valid": true,
+        "message": "Warning 27: unused variable x."
+      }
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN server stop-server
diff --git a/tests/test-dirs/short-paths.t/dep.mli b/tests/test-dirs/short-paths.t/dep.mli
new file mode 100644
index 0000000..95f0a74
--- /dev/null
+++ b/tests/test-dirs/short-paths.t/dep.mli
@@ -0,0 +1,4 @@
+
+module M : sig type t end
+
+type t = M.t
diff --git a/tests/test-dirs/short-paths.t/run.t b/tests/test-dirs/short-paths.t/run.t
new file mode 100644
index 0000000..9e3117b
--- /dev/null
+++ b/tests/test-dirs/short-paths.t/run.t
@@ -0,0 +1,355 @@
+  $ $OCAMLC -c dep.mli
+
+  $ $MERLIN single errors -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 21,
+          "col": 36
+        },
+        "end": {
+          "line": 21,
+          "col": 49
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Some type variables are unbound in this type: class b : 'a -> a
+  The method x has type 'a where 'a is unbound"
+      },
+      {
+        "start": {
+          "line": 23,
+          "col": 46
+        },
+        "end": {
+          "line": 23,
+          "col": 47
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "This class expression is not a class structure; it has type 'a -> a"
+      },
+      {
+        "start": {
+          "line": 27,
+          "col": 0
+        },
+        "end": {
+          "line": 30,
+          "col": 3
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Some type variables are unbound in this type:
+    class test : ?a:'a -> object method b : 'b end
+  The method b has type 'b where 'b is unbound"
+      },
+      {
+        "start": {
+          "line": 27,
+          "col": 12
+        },
+        "end": {
+          "line": 27,
+          "col": 13
+        },
+        "type": "warning",
+        "sub": [],
+        "valid": true,
+        "message": "Warning 16: this optional argument cannot be erased."
+      },
+      {
+        "start": {
+          "line": 29,
+          "col": 13
+        },
+        "end": {
+          "line": 29,
+          "col": 14
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Unbound value c"
+      },
+      {
+        "start": {
+          "line": 34,
+          "col": 0
+        },
+        "end": {
+          "line": 37,
+          "col": 3
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Some type variables are unbound in this type:
+    class test : 'a -> object method b : 'b end
+  The method b has type 'b where 'b is unbound"
+      },
+      {
+        "start": {
+          "line": 36,
+          "col": 13
+        },
+        "end": {
+          "line": 36,
+          "col": 14
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Unbound value c"
+      },
+      {
+        "start": {
+          "line": 39,
+          "col": 12
+        },
+        "end": {
+          "line": 39,
+          "col": 13
+        },
+        "type": "warning",
+        "sub": [],
+        "valid": true,
+        "message": "Warning 16: this optional argument cannot be erased."
+      },
+      {
+        "start": {
+          "line": 63,
+          "col": 25
+        },
+        "end": {
+          "line": 63,
+          "col": 26
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "This expression has type t = M.t but an expression was expected of type unit"
+      },
+      {
+        "start": {
+          "line": 82,
+          "col": 22
+        },
+        "end": {
+          "line": 86,
+          "col": 5
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Signature mismatch:
+  Modules do not match:
+    sig type t = int val foo : 'a -> string end
+  is not included in
+    S
+  Values do not match:
+    val foo : 'a -> string
+  is not included in
+    val foo : int -> t
+  File \"test.ml\", line 72, characters 2-20: Expected declaration
+  File \"test.ml\", line 85, characters 8-11: Actual declaration"
+      },
+      {
+        "start": {
+          "line": 90,
+          "col": 18
+        },
+        "end": {
+          "line": 90,
+          "col": 19
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "This expression has type int but an expression was expected of type Dep.M.t"
+      }
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single errors -filename test.ml -short-paths < test.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 21,
+          "col": 36
+        },
+        "end": {
+          "line": 21,
+          "col": 49
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Some type variables are unbound in this type: class b : 'a -> a
+  The method x has type 'a where 'a is unbound"
+      },
+      {
+        "start": {
+          "line": 23,
+          "col": 46
+        },
+        "end": {
+          "line": 23,
+          "col": 47
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "This class expression is not a class structure; it has type 'a -> a"
+      },
+      {
+        "start": {
+          "line": 27,
+          "col": 0
+        },
+        "end": {
+          "line": 30,
+          "col": 3
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Some type variables are unbound in this type:
+    class test : ?a:'a -> object method b : 'b end
+  The method b has type 'b where 'b is unbound"
+      },
+      {
+        "start": {
+          "line": 27,
+          "col": 12
+        },
+        "end": {
+          "line": 27,
+          "col": 13
+        },
+        "type": "warning",
+        "sub": [],
+        "valid": true,
+        "message": "Warning 16: this optional argument cannot be erased."
+      },
+      {
+        "start": {
+          "line": 29,
+          "col": 13
+        },
+        "end": {
+          "line": 29,
+          "col": 14
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Unbound value c"
+      },
+      {
+        "start": {
+          "line": 34,
+          "col": 0
+        },
+        "end": {
+          "line": 37,
+          "col": 3
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Some type variables are unbound in this type:
+    class test : 'a -> object method b : 'b end
+  The method b has type 'b where 'b is unbound"
+      },
+      {
+        "start": {
+          "line": 36,
+          "col": 13
+        },
+        "end": {
+          "line": 36,
+          "col": 14
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Unbound value c"
+      },
+      {
+        "start": {
+          "line": 39,
+          "col": 12
+        },
+        "end": {
+          "line": 39,
+          "col": 13
+        },
+        "type": "warning",
+        "sub": [],
+        "valid": true,
+        "message": "Warning 16: this optional argument cannot be erased."
+      },
+      {
+        "start": {
+          "line": 63,
+          "col": 25
+        },
+        "end": {
+          "line": 63,
+          "col": 26
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "This expression has type N.O.t but an expression was expected of type unit"
+      },
+      {
+        "start": {
+          "line": 82,
+          "col": 22
+        },
+        "end": {
+          "line": 86,
+          "col": 5
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Signature mismatch:
+  Modules do not match:
+    sig type t = int val foo : 'a -> string end
+  is not included in
+    S
+  Values do not match:
+    val foo : 'a -> string
+  is not included in
+    val foo : t -> t
+  File \"test.ml\", line 72, characters 2-20: Expected declaration
+  File \"test.ml\", line 85, characters 8-11: Actual declaration"
+      },
+      {
+        "start": {
+          "line": 90,
+          "col": 18
+        },
+        "end": {
+          "line": 90,
+          "col": 19
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "This expression has type int but an expression was expected of type Dep.t"
+      }
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/short-paths.t/test.ml b/tests/test-dirs/short-paths.t/test.ml
new file mode 100644
index 0000000..7aefab2
--- /dev/null
+++ b/tests/test-dirs/short-paths.t/test.ml
@@ -0,0 +1,90 @@
+(* *** #670 *** *)
+
+module type S = sig
+  class virtual x : object
+    method private virtual release : unit
+  end
+end
+
+module Make (C : S) = struct
+
+  class c =
+    object
+      method private release = ()
+    end
+
+  let x = 3
+end
+
+(* *** #843 *** *)
+
+class a x = object method x = x end and b x = a x
+
+class a x = object end and b = object inherit a end
+
+(* *** #907 *** *)
+
+class test ?a =
+object
+  method b = c
+end
+
+(* the following cases do not trigger error *)
+
+class test a =
+object
+  method b = c
+end
+
+class test ?a =
+object
+  method b = ()
+end
+
+(* *** Don't select deprecated paths *** *)
+
+include struct
+  [@@@warning "-3"]
+
+  module M = struct
+    type t = T
+    [@@deprecated "bad"]
+  end
+
+  type t = M.t
+  [@@deprecated "bad"]
+
+  module N = struct
+    module O = struct
+      type t = M.t
+    end
+  end
+
+  let f (x : t) : unit = x
+
+end
+
+(* *** #999 *** *)
+
+module type S = sig
+  type t
+
+  val foo : int -> t
+end
+
+module Functor (S: S) : sig
+  val bar : int -> S.t
+end = struct
+  let bar i =
+    S.foo i
+end
+
+module Bar = Functor (struct
+    type t = int
+
+    let foo _i = "haha"
+  end)
+
+(* #1082 *)
+
+let x : Dep.M.t = 5
diff --git a/tests/test-dirs/type-enclosing/constructors_and_paths.t/cons.ml b/tests/test-dirs/type-enclosing/constructors_and_paths.t/cons.ml
new file mode 100644
index 0000000..a092b5e
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/constructors_and_paths.t/cons.ml
@@ -0,0 +1,26 @@
+type t = U
+type t' = U
+
+let f : t  = U
+
+let g (x : t) =
+  match x with
+  | U -> ()
+
+module M = struct
+  type t = A
+  type u = A | B
+end
+
+let f () = (M.A : M.t)
+
+let _ = M.A
+
+module N = struct
+  type t = A of int
+  let x = 3
+end
+
+let _ = Some (N.A 3)
+
+let _ = N.x
diff --git a/tests/test-dirs/type-enclosing/constructors_and_paths.t/run.t b/tests/test-dirs/type-enclosing/constructors_and_paths.t/run.t
new file mode 100644
index 0000000..23f0408
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/constructors_and_paths.t/run.t
@@ -0,0 +1,248 @@
+Various parts of the cons.ml:
+
+- The expression:
+  $ $MERLIN single type-enclosing -position 4:14 -verbosity 0 \
+  > -filename ./cons.ml < ./cons.ml| jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 4,
+        "col": 13
+      },
+      "end": {
+        "line": 4,
+        "col": 14
+      },
+      "type": "t",
+      "tail": "no"
+    }
+  ]
+
+- The pattern:
+
+  $ $MERLIN single type-enclosing -position 8:5 -verbosity 0 \
+  > -filename ./cons.ml < ./cons.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 8,
+        "col": 4
+      },
+      "end": {
+        "line": 8,
+        "col": 5
+      },
+      "type": "t",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 7,
+        "col": 2
+      },
+      "end": {
+        "line": 8,
+        "col": 11
+      },
+      "type": "unit",
+      "tail": "no"
+    }
+  ]
+
+- Non-regression tests:
+
+  $ $MERLIN single type-enclosing -position 17:9 -verbosity 0 \
+  > -filename ./cons.ml < ./cons.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 17,
+        "col": 8
+      },
+      "end": {
+        "line": 17,
+        "col": 9
+      },
+      "type": "sig type t = A type u = A | B end",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 17,
+        "col": 8
+      },
+      "end": {
+        "line": 17,
+        "col": 11
+      },
+      "type": "M.u",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 15:13 -verbosity 0 \
+  > -filename ./cons.ml < ./cons.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 15,
+        "col": 12
+      },
+      "end": {
+        "line": 15,
+        "col": 13
+      },
+      "type": "sig type t = A type u = A | B end",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 15,
+        "col": 12
+      },
+      "end": {
+        "line": 15,
+        "col": 15
+      },
+      "type": "M.t",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 15:15 -verbosity 0 \
+  > -filename ./cons.ml < ./cons.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 15,
+        "col": 12
+      },
+      "end": {
+        "line": 15,
+        "col": 15
+      },
+      "type": "M.t",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 15,
+        "col": 6
+      },
+      "end": {
+        "line": 15,
+        "col": 22
+      },
+      "type": "unit -> M.t",
+      "tail": "no"
+    }
+  ]
+
+FIXME: the following two tests work only because of
+the fallbacks implemented in type_utils. Context is
+unable to answer correctly due to the enclosing node
+being "Texp_constant" and not "Texp_construct". in
+the expression reconstructed from  (M|.A 3).
+  $ $MERLIN single type-enclosing -position 24:15 -verbosity 0 \
+  > -filename ./cons.ml < ./cons.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 24,
+        "col": 14
+      },
+      "end": {
+        "line": 24,
+        "col": 15
+      },
+      "type": "sig type t = A of int val x : int end",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 24,
+        "col": 13
+      },
+      "end": {
+        "line": 24,
+        "col": 20
+      },
+      "type": "N.t",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 24:17 -verbosity 0 \
+  > -filename ./cons.ml < ./cons.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 24,
+        "col": 14
+      },
+      "end": {
+        "line": 24,
+        "col": 17
+      },
+      "type": "int -> N.t",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 24,
+        "col": 13
+      },
+      "end": {
+        "line": 24,
+        "col": 20
+      },
+      "type": "N.t",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 26:9 -verbosity 0 \
+  >  -filename ./cons.ml < ./cons.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 26,
+        "col": 8
+      },
+      "end": {
+        "line": 26,
+        "col": 9
+      },
+      "type": "sig type t = A of int val x : int end",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 26,
+        "col": 8
+      },
+      "end": {
+        "line": 26,
+        "col": 11
+      },
+      "type": "int",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 26:11 -verbosity 0 \
+  > -filename ./cons.ml < ./cons.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 26,
+        "col": 8
+      },
+      "end": {
+        "line": 26,
+        "col": 11
+      },
+      "type": "int",
+      "tail": "no"
+    }
+  ]
diff --git a/tests/test-dirs/type-enclosing/gadt_wrong.t b/tests/test-dirs/type-enclosing/gadt_wrong.t
new file mode 100644
index 0000000..ba73e21
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/gadt_wrong.t
@@ -0,0 +1,108 @@
+Initially from issue https://github.com/ocaml/merlin/issues/1125
+
+  $ cat > gadt.ml <<EOF
+  > 
+  > type _ term =
+  >   | Int : int -> int term
+  >   | Pair : 'a term * 'b term -> ('a * 'b) term
+  >   | Fst : ('a * 'b) term -> 'a term
+  >   | Snd : ('a * 'b) term -> 'b term
+  > 
+  > let rec eval : type a . a term -> a = function
+  >   | Int n -> n
+  >   | Pair (a, b) -> eval a, eval b
+  >   | Fst p -> fst (eval p)
+  >   | Snd p -> snd (eval p)
+  > EOF
+
+  $ $MERLIN single type-enclosing -position 3:5 -verbosity 0 \
+  > -filename ./gadt.ml < ./gadt.ml | tr '\r\n' ' ' | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 3,
+        "col": 4
+      },
+      "end": {
+        "line": 3,
+        "col": 7
+      },
+      "type": "(module Stdlib__Int)",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 2,
+        "col": 0
+      },
+      "end": {
+        "line": 6,
+        "col": 35
+      },
+      "type": "type _ term =     Int : int -> int term   | Pair : 'a term * 'b term -> ('a * 'b) term   | Fst : ('a * 'b) term -> 'a term   | Snd : ('a * 'b) term -> 'b term",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 9:5 -verbosity 0 \
+  > -filename ./gadt.ml < ./gadt.ml | tr '\r\n' ' ' | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 9,
+        "col": 4
+      },
+      "end": {
+        "line": 9,
+        "col": 7
+      },
+      "type": "int -> int term",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 9,
+        "col": 4
+      },
+      "end": {
+        "line": 9,
+        "col": 9
+      },
+      "type": "a term",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 8:21 -verbosity 0 \
+  > -filename ./gadt.ml < ./gadt.ml | tr '\r\n' ' ' | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 8,
+        "col": 8
+      },
+      "end": {
+        "line": 12,
+        "col": 25
+      },
+      "type": "'a term -> 'a",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 8:9 -verbosity 0 \
+  > -filename ./gadt.ml < ./gadt.ml | tr '\r\n' ' ' | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 8,
+        "col": 8
+      },
+      "end": {
+        "line": 8,
+        "col": 12
+      },
+      "type": "'a. 'a term -> 'a",
+      "tail": "no"
+    }
+  ]
diff --git a/tests/test-dirs/type-enclosing/github1003.t/issue1003.ml b/tests/test-dirs/type-enclosing/github1003.t/issue1003.ml
new file mode 100644
index 0000000..87ee17c
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/github1003.t/issue1003.ml
@@ -0,0 +1,5 @@
+module List = struct
+  let foo = 3
+end
+
+let _ = List.foo
diff --git a/tests/test-dirs/type-enclosing/github1003.t/run.t b/tests/test-dirs/type-enclosing/github1003.t/run.t
new file mode 100644
index 0000000..dd4730c
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/github1003.t/run.t
@@ -0,0 +1,45 @@
+  $ $MERLIN single type-enclosing -position 5:14 -verbosity 0 \
+  > -filename ./issue1003.ml < ./issue1003.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 5,
+        "col": 8
+      },
+      "end": {
+        "line": 5,
+        "col": 16
+      },
+      "type": "int",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 5:11 -verbosity 0 \
+  > -filename ./issue1003.ml < ./issue1003.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 5,
+        "col": 8
+      },
+      "end": {
+        "line": 5,
+        "col": 12
+      },
+      "type": "sig val foo : int end",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 5,
+        "col": 8
+      },
+      "end": {
+        "line": 5,
+        "col": 16
+      },
+      "type": "int",
+      "tail": "no"
+    }
+  ]
diff --git a/tests/test-dirs/type-enclosing/hole.t b/tests/test-dirs/type-enclosing/hole.t
new file mode 100644
index 0000000..db11232
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/hole.t
@@ -0,0 +1,194 @@
+Check that we can access the expected type of a hole:
+  $ $MERLIN single type-enclosing -position 2:2 -filename hole.ml <<EOF
+  > let f () : int =
+  >   _
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 2
+        },
+        "end": {
+          "line": 2,
+          "col": 3
+        },
+        "type": "int",
+        "tail": "no"
+      },
+      {
+        "start": {
+          "line": 1,
+          "col": 6
+        },
+        "end": {
+          "line": 2,
+          "col": 3
+        },
+        "type": "unit -> int",
+        "tail": "no"
+      }
+    ],
+    "notifications": []
+  }
+
+Check that we can access the expected type of a module hole:
+  $ $MERLIN single type-enclosing -position 2:2 -filename hole.ml <<EOF
+  > module M : sig val f : int -> unit end =
+  >   _
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 9
+        },
+        "end": {
+          "line": 2,
+          "col": 3
+        },
+        "type": "sig val f : int -> unit end",
+        "tail": "no"
+      },
+      {
+        "start": {
+          "line": 1,
+          "col": 0
+        },
+        "end": {
+          "line": 2,
+          "col": 3
+        },
+        "type": "sig val f : int -> unit end",
+        "tail": "no"
+      }
+    ],
+    "notifications": []
+  }
+
+What about other places where Module_expr are allowed ?
+  $ $MERLIN single type-enclosing -position 1:6 -filename hole.ml <<EOF
+  > open _
+  > EOF
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
+
+  $ $MERLIN single type-enclosing -position 1:6 -filename hole.ml <<EOF
+  > include _
+  > EOF
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
+
+  $ $MERLIN single type-enclosing -verbosity 2 -position 1:12 -filename hole.ml <<EOF
+  > module type Hole = module type of _
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 12
+        },
+        "end": {
+          "line": 1,
+          "col": 16
+        },
+        "type": "_",
+        "tail": "no"
+      },
+      {
+        "start": {
+          "line": 1,
+          "col": 0
+        },
+        "end": {
+          "line": 1,
+          "col": 35
+        },
+        "type": "_",
+        "tail": "no"
+      }
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single type-enclosing -position 2:16 -filename hole.ml <<EOF
+  > module type Hole = module type of _
+  > let m = (module _ : Hole)
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 16
+        },
+        "end": {
+          "line": 2,
+          "col": 17
+        },
+        "type": "Hole",
+        "tail": "no"
+      },
+      {
+        "start": {
+          "line": 2,
+          "col": 8
+        },
+        "end": {
+          "line": 2,
+          "col": 25
+        },
+        "type": "(module Hole)",
+        "tail": "no"
+      }
+    ],
+    "notifications": []
+  }
+
+Type when no type available ?
+  $ $MERLIN single type-enclosing -position 1:8 -filename hole.ml <<EOF
+  > module M = _
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 7
+        },
+        "end": {
+          "line": 1,
+          "col": 8
+        },
+        "type": "_",
+        "tail": "no"
+      },
+      {
+        "start": {
+          "line": 1,
+          "col": 0
+        },
+        "end": {
+          "line": 1,
+          "col": 12
+        },
+        "type": "_",
+        "tail": "no"
+      }
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/type-enclosing/issue1116.t/issue1116.ml b/tests/test-dirs/type-enclosing/issue1116.t/issue1116.ml
new file mode 100644
index 0000000..ce28823
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/issue1116.t/issue1116.ml
@@ -0,0 +1,2 @@
+let some_int = 5
+let x = "some_int"
diff --git a/tests/test-dirs/type-enclosing/issue1116.t/run.t b/tests/test-dirs/type-enclosing/issue1116.t/run.t
new file mode 100644
index 0000000..ce87380
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/issue1116.t/run.t
@@ -0,0 +1,33 @@
+  $ $MERLIN single type-enclosing -position 2:13 -verbosity 0 \
+  > -filename ./issue1116.ml < ./issue1116.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 2,
+        "col": 8
+      },
+      "end": {
+        "line": 2,
+        "col": 18
+      },
+      "type": "string",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 1:16 -verbosity 0 \
+  > -filename ./issue1116.ml < ./issue1116.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 1,
+        "col": 15
+      },
+      "end": {
+        "line": 1,
+        "col": 16
+      },
+      "type": "int",
+      "tail": "no"
+    }
+  ]
diff --git a/tests/test-dirs/type-enclosing/issue1226.t b/tests/test-dirs/type-enclosing/issue1226.t
new file mode 100644
index 0000000..d023551
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/issue1226.t
@@ -0,0 +1,39 @@
+Fixed.
+
+  $ $MERLIN single type-enclosing  -position 5:9 -filename test.ml <<EOF
+  > module Foo = struct
+  >   let bar = 42
+  > end
+  > type t = Foo of int
+  > let a = Foo 3
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 5,
+          "col": 8
+        },
+        "end": {
+          "line": 5,
+          "col": 11
+        },
+        "type": "int -> t",
+        "tail": "no"
+      },
+      {
+        "start": {
+          "line": 5,
+          "col": 8
+        },
+        "end": {
+          "line": 5,
+          "col": 13
+        },
+        "type": "t",
+        "tail": "no"
+      }
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/type-enclosing/issue1278.t b/tests/test-dirs/type-enclosing/issue1278.t
new file mode 100644
index 0000000..75fc3b8
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/issue1278.t
@@ -0,0 +1,59 @@
+  $ cat >test.ml <<EOF
+  > module C = struct end
+  > 
+  > module M = struct
+  >   type t = C
+  > end
+  > 
+  > let (_ : M.t) = C
+  > EOF
+
+  $ ocamlmerlin single type-enclosing -protocol jquery -verbosity 0 \
+  > -filename test.ml -position 7:17 -index 0 < test.ml | jq '.value[0]'
+  {
+    "start": {
+      "line": 7,
+      "col": 16
+    },
+    "end": {
+      "line": 7,
+      "col": 17
+    },
+    "type": "M.t",
+    "tail": "no"
+  }
+
+  $ ocamlmerlin single type-enclosing -protocol jquery -verbosity 0 \
+  > -filename test.ml -position 7:16 -index 0 < test.ml | jq '.value[0]'
+  {
+    "start": {
+      "line": 7,
+      "col": 16
+    },
+    "end": {
+      "line": 7,
+      "col": 17
+    },
+    "type": "M.t",
+    "tail": "no"
+  }
+
+  $ cat >>test.ml << EOF
+  > 
+  > let (_ : M.t) = C
+  > EOF
+
+  $ ocamlmerlin single type-enclosing -protocol jquery -verbosity 0 \
+  > -filename test.ml -position 9:17 -index 0 < test.ml | jq '.value[0]'
+  {
+    "start": {
+      "line": 9,
+      "col": 16
+    },
+    "end": {
+      "line": 9,
+      "col": 17
+    },
+    "type": "M.t",
+    "tail": "no"
+  }
diff --git a/tests/test-dirs/type-enclosing/issue1477.t b/tests/test-dirs/type-enclosing/issue1477.t
new file mode 100644
index 0000000..1b1e06f
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/issue1477.t
@@ -0,0 +1,34 @@
+  $ cat >test.ml <<EOF
+  > let g (x : int) = x
+  > let b = g 1
+  > EOF
+
+  $ $MERLIN single type-enclosing -position 2:8 \
+  > -filename test.ml < test.ml |
+  > jq '.value'
+  [
+    {
+      "start": {
+        "line": 2,
+        "col": 8
+      },
+      "end": {
+        "line": 2,
+        "col": 9
+      },
+      "type": "int -> int",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 2,
+        "col": 8
+      },
+      "end": {
+        "line": 2,
+        "col": 11
+      },
+      "type": "int",
+      "tail": "no"
+    }
+  ]
diff --git a/tests/test-dirs/type-enclosing/issue864.t/issue864.ml b/tests/test-dirs/type-enclosing/issue864.t/issue864.ml
new file mode 100644
index 0000000..e6b9f19
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/issue864.t/issue864.ml
@@ -0,0 +1,9 @@
+module X = struct
+  type t = { z : int }
+end
+
+let f1 _ (x : X.t) = x.z
+
+let f2 (z : string) (x : X.t) = x.X.z
+
+let f3 (z : string) (x : X.t) = x.z
diff --git a/tests/test-dirs/type-enclosing/issue864.t/run.t b/tests/test-dirs/type-enclosing/issue864.t/run.t
new file mode 100644
index 0000000..75b887d
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/issue864.t/run.t
@@ -0,0 +1,170 @@
+  $ $MERLIN single type-enclosing -position 5:24 -verbosity 0 \
+  > -filename ./issue864.ml < ./issue864.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 5,
+          "col": 23
+        },
+        "end": {
+          "line": 5,
+          "col": 24
+        },
+        "type": "int",
+        "tail": "no"
+      },
+      {
+        "start": {
+          "line": 5,
+          "col": 21
+        },
+        "end": {
+          "line": 5,
+          "col": 24
+        },
+        "type": "int",
+        "tail": "no"
+      },
+      {
+        "start": {
+          "line": 5,
+          "col": 9
+        },
+        "end": {
+          "line": 5,
+          "col": 24
+        },
+        "type": "X.t -> int",
+        "tail": "no"
+      },
+      {
+        "start": {
+          "line": 5,
+          "col": 7
+        },
+        "end": {
+          "line": 5,
+          "col": 24
+        },
+        "type": "'a -> X.t -> int",
+        "tail": "no"
+      }
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single type-enclosing -position 7:37 -verbosity 0 \
+  > -filename ./issue864.ml < ./issue864.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 7,
+          "col": 34
+        },
+        "end": {
+          "line": 7,
+          "col": 37
+        },
+        "type": "int",
+        "tail": "no"
+      },
+      {
+        "start": {
+          "line": 7,
+          "col": 32
+        },
+        "end": {
+          "line": 7,
+          "col": 37
+        },
+        "type": "int",
+        "tail": "no"
+      },
+      {
+        "start": {
+          "line": 7,
+          "col": 20
+        },
+        "end": {
+          "line": 7,
+          "col": 37
+        },
+        "type": "X.t -> int",
+        "tail": "no"
+      },
+      {
+        "start": {
+          "line": 7,
+          "col": 7
+        },
+        "end": {
+          "line": 7,
+          "col": 37
+        },
+        "type": "string -> X.t -> int",
+        "tail": "no"
+      }
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single type-enclosing -position 9:35 -verbosity 0 \
+  > -filename ./issue864.ml < ./issue864.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 9,
+          "col": 34
+        },
+        "end": {
+          "line": 9,
+          "col": 35
+        },
+        "type": "int",
+        "tail": "no"
+      },
+      {
+        "start": {
+          "line": 9,
+          "col": 32
+        },
+        "end": {
+          "line": 9,
+          "col": 35
+        },
+        "type": "int",
+        "tail": "no"
+      },
+      {
+        "start": {
+          "line": 9,
+          "col": 20
+        },
+        "end": {
+          "line": 9,
+          "col": 35
+        },
+        "type": "X.t -> int",
+        "tail": "no"
+      },
+      {
+        "start": {
+          "line": 9,
+          "col": 7
+        },
+        "end": {
+          "line": 9,
+          "col": 35
+        },
+        "type": "string -> X.t -> int",
+        "tail": "no"
+      }
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/type-enclosing/issueLSP444.t b/tests/test-dirs/type-enclosing/issueLSP444.t
new file mode 100644
index 0000000..440b17d
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/issueLSP444.t
@@ -0,0 +1,45 @@
+From ocaml-lsp#444 (https://github.com/ocaml/ocaml-lsp/issues/444)
+  $ cat >gadt.ml <<EOF
+  > type 'a t =
+  >   | A : [\`A] t
+  >   | B : [\`B] t
+  > 
+  > let f x =
+  >   match x with
+  >   | A -> ()
+  > EOF
+
+  $ $MERLIN single type-enclosing -position 6:9 -verbosity 0 \
+  > -filename ./gadt.ml < ./gadt.ml | tr '\r\n' ' ' | jq ".value[0]"
+  {
+    "start": {
+      "line": 6,
+      "col": 8
+    },
+    "end": {
+      "line": 6,
+      "col": 9
+    },
+    "type": "[ `A ] t",
+    "tail": "no"
+  }
+
+  $ $MERLIN single type-enclosing -position 7:5 -verbosity 0 \
+  > -filename ./gadt.ml < ./gadt.ml | tr '\r\n' ' ' | jq ".value[0]"
+  {
+    "start": {
+      "line": 7,
+      "col": 4
+    },
+    "end": {
+      "line": 7,
+      "col": 5
+    },
+    "type": "[ `A ] t",
+    "tail": "no"
+  }
+
+
+  $ $MERLIN single errors -verbosity 0 \
+  > -filename ./gadt.ml < ./gadt.ml | tr '\r\n' ' ' | jq ".value"
+  []
diff --git a/tests/test-dirs/type-enclosing/let.t/let.ml b/tests/test-dirs/type-enclosing/let.t/let.ml
new file mode 100644
index 0000000..8391207
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/let.t/let.ml
@@ -0,0 +1,4 @@
+
+let def = 6
+
+let def : float = float_of_int def
diff --git a/tests/test-dirs/type-enclosing/let.t/run.t b/tests/test-dirs/type-enclosing/let.t/run.t
new file mode 100644
index 0000000..ace16c6
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/let.t/run.t
@@ -0,0 +1,18 @@
+Get type of a shadowing let binding:
+
+  $ $MERLIN single type-enclosing -position 4:4 -verbosity 0 \
+  > -filename ./let.ml < ./let.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 4,
+        "col": 4
+      },
+      "end": {
+        "line": 4,
+        "col": 7
+      },
+      "type": "float",
+      "tail": "no"
+    }
+  ]
diff --git a/tests/test-dirs/type-enclosing/letop.t/letop.ml b/tests/test-dirs/type-enclosing/letop.t/letop.ml
new file mode 100644
index 0000000..a045cc9
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/letop.t/letop.ml
@@ -0,0 +1,5 @@
+let (let*) o f = Option.map
+
+let plus_two tbl key =
+  let* foo = Hashtbl.find_opt tbl key in
+  foo + 2
diff --git a/tests/test-dirs/type-enclosing/letop.t/run.t b/tests/test-dirs/type-enclosing/letop.t/run.t
new file mode 100644
index 0000000..ee3b699
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/letop.t/run.t
@@ -0,0 +1,184 @@
+Various parts of the letop:
+
+- The operator:
+
+  $ $MERLIN single type-enclosing -position 4:3 -verbosity 0 \
+  > -filename ./letop.ml < ./letop.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 4,
+        "col": 2
+      },
+      "end": {
+        "line": 5,
+        "col": 9
+      },
+      "type": "('a -> 'b) -> 'a option -> 'b option",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 3,
+        "col": 17
+      },
+      "end": {
+        "line": 5,
+        "col": 9
+      },
+      "type": "'a -> ('b -> 'c) -> 'b option -> 'c option",
+      "tail": "no"
+    }
+  ]
+
+- The pattern:
+
+  $ $MERLIN single type-enclosing -position 4:8 -verbosity 0 \
+  > -filename ./letop.ml < ./letop.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 4,
+        "col": 7
+      },
+      "end": {
+        "line": 4,
+        "col": 10
+      },
+      "type": "int",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 4,
+        "col": 2
+      },
+      "end": {
+        "line": 5,
+        "col": 9
+      },
+      "type": "('a -> 'b) -> 'a option -> 'b option",
+      "tail": "no"
+    }
+  ]
+
+- The rhs:
+
+  $ $MERLIN single type-enclosing -position 4:22 -verbosity 0 \
+  > -filename ./letop.ml < ./letop.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 4,
+        "col": 13
+      },
+      "end": {
+        "line": 4,
+        "col": 29
+      },
+      "type": "('a, 'b) Hashtbl.t -> 'a -> 'b option",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 4,
+        "col": 13
+      },
+      "end": {
+        "line": 4,
+        "col": 37
+      },
+      "type": "'a option",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 4:31 -verbosity 0 \
+  > -filename ./letop.ml < ./letop.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 4,
+        "col": 30
+      },
+      "end": {
+        "line": 4,
+        "col": 33
+      },
+      "type": "('a, 'b) Hashtbl.t",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 4,
+        "col": 13
+      },
+      "end": {
+        "line": 4,
+        "col": 37
+      },
+      "type": "'a option",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 4:35 -verbosity 0 \
+  > -filename ./letop.ml < ./letop.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 4,
+        "col": 34
+      },
+      "end": {
+        "line": 4,
+        "col": 37
+      },
+      "type": "'a",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 4,
+        "col": 13
+      },
+      "end": {
+        "line": 4,
+        "col": 37
+      },
+      "type": "'a option",
+      "tail": "no"
+    }
+  ]
+
+- After the in:
+
+  $ $MERLIN single type-enclosing -position 5:3 -verbosity 0 \
+  > -filename ./letop.ml < ./letop.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 5,
+        "col": 2
+      },
+      "end": {
+        "line": 5,
+        "col": 5
+      },
+      "type": "int",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 5,
+        "col": 2
+      },
+      "end": {
+        "line": 5,
+        "col": 9
+      },
+      "type": "int",
+      "tail": "no"
+    }
+  ]
+
diff --git a/tests/test-dirs/type-enclosing/merlin-hide.t b/tests/test-dirs/type-enclosing/merlin-hide.t
new file mode 100644
index 0000000..2f6e617
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/merlin-hide.t
@@ -0,0 +1,40 @@
+Make sure type-enclosing works properly even when the precise location is not
+accessible:
+
+  $ $MERLIN single type-enclosing -position 3:7 -filename hide.ml <<EOF
+  > module M = struct
+  >   include struct
+  >     let x = 3
+  >   end[@merlin.hide]
+  > end
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 11
+        },
+        "end": {
+          "line": 5,
+          "col": 3
+        },
+        "type": "sig val x : int end",
+        "tail": "no"
+      },
+      {
+        "start": {
+          "line": 1,
+          "col": 0
+        },
+        "end": {
+          "line": 5,
+          "col": 3
+        },
+        "type": "sig val x : int end",
+        "tail": "no"
+      }
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/type-enclosing/mod-alias.t/alias.ml b/tests/test-dirs/type-enclosing/mod-alias.t/alias.ml
new file mode 100644
index 0000000..6a83894
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/mod-alias.t/alias.ml
@@ -0,0 +1,3 @@
+module L = List
+
+let _ = L.hd [3]
diff --git a/tests/test-dirs/type-enclosing/mod-alias.t/run.t b/tests/test-dirs/type-enclosing/mod-alias.t/run.t
new file mode 100644
index 0000000..c6e9d54
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/mod-alias.t/run.t
@@ -0,0 +1,163 @@
+  $ $MERLIN single type-enclosing -position 3:9 -verbosity 0 \
+  > -filename ./alias.ml < ./alias.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 3,
+        "col": 8
+      },
+      "end": {
+        "line": 3,
+        "col": 9
+      },
+      "type": "(module List)",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 3,
+        "col": 8
+      },
+      "end": {
+        "line": 3,
+        "col": 12
+      },
+      "type": "int list -> int",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 3:11 -verbosity 0 \
+  > -filename ./alias.ml < ./alias.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 8
+        },
+        "end": {
+          "line": 3,
+          "col": 12
+        },
+        "type": "'a list -> 'a",
+        "tail": "no"
+      },
+      {
+        "start": {
+          "line": 3,
+          "col": 8
+        },
+        "end": {
+          "line": 3,
+          "col": 12
+        },
+        "type": "int list -> int",
+        "tail": "no"
+      },
+      {
+        "start": {
+          "line": 3,
+          "col": 8
+        },
+        "end": {
+          "line": 3,
+          "col": 16
+        },
+        "type": "int",
+        "tail": "no"
+      }
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single type-enclosing -position 3:14 -verbosity 0 \
+  > -filename ./alias.ml < ./alias.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 14
+        },
+        "end": {
+          "line": 3,
+          "col": 15
+        },
+        "type": "int",
+        "tail": "no"
+      },
+      {
+        "start": {
+          "line": 3,
+          "col": 13
+        },
+        "end": {
+          "line": 3,
+          "col": 16
+        },
+        "type": "int list",
+        "tail": "no"
+      },
+      {
+        "start": {
+          "line": 3,
+          "col": 8
+        },
+        "end": {
+          "line": 3,
+          "col": 16
+        },
+        "type": "int",
+        "tail": "no"
+      }
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single type-enclosing -position 3:15 -verbosity 0 \
+  > -filename ./alias.ml < ./alias.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 14
+        },
+        "end": {
+          "line": 3,
+          "col": 15
+        },
+        "type": "int",
+        "tail": "no"
+      },
+      {
+        "start": {
+          "line": 3,
+          "col": 13
+        },
+        "end": {
+          "line": 3,
+          "col": 16
+        },
+        "type": "int list",
+        "tail": "no"
+      },
+      {
+        "start": {
+          "line": 3,
+          "col": 8
+        },
+        "end": {
+          "line": 3,
+          "col": 16
+        },
+        "type": "int",
+        "tail": "no"
+      }
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/type-enclosing/mod-not-in-env.t/not-in-env.ml b/tests/test-dirs/type-enclosing/mod-not-in-env.t/not-in-env.ml
new file mode 100644
index 0000000..4f0c7a4
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/mod-not-in-env.t/not-in-env.ml
@@ -0,0 +1,7 @@
+module N = struct
+  let y = 4
+end
+
+let z = N.x
+
+let w = N.N
diff --git a/tests/test-dirs/type-enclosing/mod-not-in-env.t/run.t b/tests/test-dirs/type-enclosing/mod-not-in-env.t/run.t
new file mode 100644
index 0000000..fe950ca
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/mod-not-in-env.t/run.t
@@ -0,0 +1,62 @@
+  $ $MERLIN single type-enclosing -position 5:9 -verbosity 0 \
+  > -filename ./not-in-env.ml < ./not-in-env.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 5,
+        "col": 8
+      },
+      "end": {
+        "line": 5,
+        "col": 9
+      },
+      "type": "sig val y : int end",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 5,
+        "col": 8
+      },
+      "end": {
+        "line": 5,
+        "col": 11
+      },
+      "type": "'a",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 5:11 -verbosity 0 \
+  > -filename ./not-in-env.ml < ./not-in-env.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 5,
+        "col": 8
+      },
+      "end": {
+        "line": 5,
+        "col": 11
+      },
+      "type": "'a",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 7:11 -verbosity 0 \
+  > -filename ./not-in-env.ml < ./not-in-env.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 7,
+        "col": 8
+      },
+      "end": {
+        "line": 7,
+        "col": 11
+      },
+      "type": "'a",
+      "tail": "no"
+    }
+  ]
diff --git a/tests/test-dirs/type-enclosing/mod-type.t/module_type.mli b/tests/test-dirs/type-enclosing/mod-type.t/module_type.mli
new file mode 100644
index 0000000..a2e5bbd
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/mod-type.t/module_type.mli
@@ -0,0 +1,7 @@
+module type T = sig type a end
+
+module T : sig type b end
+
+include T
+
+include module type of T
diff --git a/tests/test-dirs/type-enclosing/mod-type.t/run.t b/tests/test-dirs/type-enclosing/mod-type.t/run.t
new file mode 100644
index 0000000..2506d0a
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/mod-type.t/run.t
@@ -0,0 +1,105 @@
+Get the type of a module type with the same name as a module:
+
+  $ $MERLIN single type-enclosing -position 5:9 -verbosity 0 \
+  > -filename ./module_type.mli < ./module_type.mli | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 5,
+        "col": 8
+      },
+      "end": {
+        "line": 5,
+        "col": 9
+      },
+      "type": "sig type a end",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 5,
+        "col": 8
+      },
+      "end": {
+        "line": 5,
+        "col": 9
+      },
+      "type": "T",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 5:9 -verbosity 2 \
+  > -filename ./module_type.mli < ./module_type.mli | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 5,
+        "col": 8
+      },
+      "end": {
+        "line": 5,
+        "col": 9
+      },
+      "type": "sig type a end",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 7:24 -verbosity 0 \
+  > -filename ./module_type.mli < ./module_type.mli | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 7,
+        "col": 23
+      },
+      "end": {
+        "line": 7,
+        "col": 24
+      },
+      "type": "sig type b end",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 7,
+        "col": 8
+      },
+      "end": {
+        "line": 7,
+        "col": 24
+      },
+      "type": "sig type b end",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 7:24 -verbosity 1 \
+  > -filename ./module_type.mli < ./module_type.mli | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 7,
+        "col": 23
+      },
+      "end": {
+        "line": 7,
+        "col": 24
+      },
+      "type": "sig type b end",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 7,
+        "col": 8
+      },
+      "end": {
+        "line": 7,
+        "col": 24
+      },
+      "type": "sig type b end",
+      "tail": "no"
+    }
+  ]
diff --git a/tests/test-dirs/type-enclosing/objects.t/run.t b/tests/test-dirs/type-enclosing/objects.t/run.t
new file mode 100644
index 0000000..a29e9d6
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/objects.t/run.t
@@ -0,0 +1,271 @@
+  $ $MERLIN single type-enclosing -position 1:5 -verbosity 1 \
+  > -filename ./test.ml < ./test.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 1,
+        "col": 4
+      },
+      "end": {
+        "line": 1,
+        "col": 5
+      },
+      "type": "< pop : int option; push : int -> unit >",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 2:14 -verbosity 1 \
+  > -filename ./test.ml < ./test.ml | tr '\r\n' ' ' | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 2,
+        "col": 2
+      },
+      "end": {
+        "line": 2,
+        "col": 24
+      },
+      "type": "int list  type 'a list = [] | (::) of 'a * 'a list",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 1,
+        "col": 8
+      },
+      "end": {
+        "line": 12,
+        "col": 3
+      },
+      "type": "< pop : int option; push : int -> unit >",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 11:10 -verbosity 1 \
+  > -filename ./test.ml < ./test.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 11,
+        "col": 2
+      },
+      "end": {
+        "line": 11,
+        "col": 31
+      },
+      "type": "int -> unit",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 1,
+        "col": 8
+      },
+      "end": {
+        "line": 12,
+        "col": 3
+      },
+      "type": "< pop : int option; push : int -> unit >",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 14:5 -verbosity 1 \
+  > -filename ./test.ml < ./test.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 14,
+        "col": 4
+      },
+      "end": {
+        "line": 14,
+        "col": 5
+      },
+      "type": "type unit = ()",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 14:9 -verbosity 1 \
+  > -filename ./test.ml < ./test.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 14,
+        "col": 8
+      },
+      "end": {
+        "line": 14,
+        "col": 9
+      },
+      "type": "< pop : int option; push : int -> unit >",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 14,
+        "col": 8
+      },
+      "end": {
+        "line": 14,
+        "col": 14
+      },
+      "type": "int -> unit",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 14:11 -verbosity 1 \
+  > -filename ./test.ml < ./test.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 14,
+        "col": 8
+      },
+      "end": {
+        "line": 14,
+        "col": 14
+      },
+      "type": "int -> unit",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 14,
+        "col": 8
+      },
+      "end": {
+        "line": 14,
+        "col": 16
+      },
+      "type": "type unit = ()",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 16:10 -verbosity 1 \
+  > -filename ./test.ml < ./test.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 16,
+        "col": 9
+      },
+      "end": {
+        "line": 16,
+        "col": 12
+      },
+      "type": "< pouet : string -> 'a; .. >",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 16,
+        "col": 9
+      },
+      "end": {
+        "line": 16,
+        "col": 28
+      },
+      "type": "< pouet : string -> 'a; .. > -> 'a",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 18:13 -verbosity 1 \
+  > -filename ./test.ml < ./test.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 18,
+        "col": 12
+      },
+      "end": {
+        "line": 18,
+        "col": 15
+      },
+      "type": "< pouet : string -> 'a >",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 18,
+        "col": 11
+      },
+      "end": {
+        "line": 18,
+        "col": 58
+      },
+      "type": "< pouet : string -> 'a > -> 'a",
+      "tail": "no"
+    }
+  ]
+
+FIXME: same as before
+  $ $MERLIN single type-enclosing -position 18:21 -verbosity 1 \
+  > -filename ./test.ml < ./test.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 18,
+        "col": 18
+      },
+      "end": {
+        "line": 18,
+        "col": 41
+      },
+      "type": "< pouet : string -> 'a >",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 18,
+        "col": 11
+      },
+      "end": {
+        "line": 18,
+        "col": 58
+      },
+      "type": "< pouet : string -> 'a > -> 'a",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 21:20 -verbosity 1 \
+  > -filename ./test.ml < ./test.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 21,
+        "col": 2
+      },
+      "end": {
+        "line": 21,
+        "col": 46
+      },
+      "type": "string -> char -> int",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 22:15 -verbosity 1 \
+  > -filename ./test.ml < ./test.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 22,
+        "col": 2
+      },
+      "end": {
+        "line": 22,
+        "col": 46
+      },
+      "type": "string -> char -> int",
+      "tail": "no"
+    }
+  ]
diff --git a/tests/test-dirs/type-enclosing/objects.t/test.ml b/tests/test-dirs/type-enclosing/objects.t/test.ml
new file mode 100644
index 0000000..b321491
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/objects.t/test.ml
@@ -0,0 +1,23 @@
+let s = object
+  val mutable v = [0; 2]
+
+  method pop =
+    match v with
+    | hd :: tl ->
+      v <- tl;
+      Some hd
+    | [] -> None
+
+  method push hd = v <- hd :: v
+end
+
+let r = s#push 3
+
+let poly obj = obj#pouet "a"
+
+let nopoly (obj : < pouet : string -> 'a>) = obj#pouet "a"
+
+class virtual foobar = object
+  method virtual virtu : string -> char -> int
+  val virtual virt_avl : string -> char -> int
+end
diff --git a/tests/test-dirs/type-enclosing/record.t/record.ml b/tests/test-dirs/type-enclosing/record.t/record.ml
new file mode 100644
index 0000000..c456780
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/record.t/record.ml
@@ -0,0 +1,12 @@
+type t = { mutable b: float }
+
+let b = 10
+let x = { b = 9. }
+
+let y = { c = 9. }
+
+let _ = x.b <- 3.
+
+type foo = Bar of {baz : unit}
+
+let z = Bar ({ baz = () })
diff --git a/tests/test-dirs/type-enclosing/record.t/run.t b/tests/test-dirs/type-enclosing/record.t/run.t
new file mode 100644
index 0000000..56cafdf
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/record.t/run.t
@@ -0,0 +1,249 @@
+  $ $MERLIN single type-enclosing -position 4:11 -verbosity 0 \
+  > -filename ./record.ml < ./record.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 4,
+        "col": 10
+      },
+      "end": {
+        "line": 4,
+        "col": 11
+      },
+      "type": "float",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 4,
+        "col": 8
+      },
+      "end": {
+        "line": 4,
+        "col": 18
+      },
+      "type": "t",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 6:11 -verbosity 0 \
+  > -filename ./record.ml < ./record.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 6,
+        "col": 8
+      },
+      "end": {
+        "line": 6,
+        "col": 18
+      },
+      "type": "'a",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 8:11 -verbosity 0 \
+  > -filename ./record.ml < ./record.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 8,
+        "col": 10
+      },
+      "end": {
+        "line": 8,
+        "col": 11
+      },
+      "type": "float",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 8,
+        "col": 8
+      },
+      "end": {
+        "line": 8,
+        "col": 17
+      },
+      "type": "unit",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 8:9 -verbosity 0 \
+  > -filename ./record.ml < ./record.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 8,
+        "col": 8
+      },
+      "end": {
+        "line": 8,
+        "col": 9
+      },
+      "type": "t",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 8,
+        "col": 8
+      },
+      "end": {
+        "line": 8,
+        "col": 17
+      },
+      "type": "unit",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 8:9 -verbosity 1 \
+  > -filename ./record.ml < ./record.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 8,
+        "col": 8
+      },
+      "end": {
+        "line": 8,
+        "col": 9
+      },
+      "type": "type t = { mutable b : float; }",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 8,
+        "col": 8
+      },
+      "end": {
+        "line": 8,
+        "col": 17
+      },
+      "type": "type unit = ()",
+      "tail": "no"
+    }
+  ]
+
+FIXME: The following results are not entirely satisfying (`foo.Bar -> foo` could be expanded to `{ baz : unit } -> foo`)
+  $ $MERLIN single type-enclosing -position 12:9 -verbosity 0 \
+  > -filename ./record.ml < ./record.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 12,
+        "col": 8
+      },
+      "end": {
+        "line": 12,
+        "col": 11
+      },
+      "type": "foo.Bar -> foo",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 12,
+        "col": 8
+      },
+      "end": {
+        "line": 12,
+        "col": 26
+      },
+      "type": "foo",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 12:9 -verbosity 1 \
+  > -filename ./record.ml < ./record.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 12,
+        "col": 8
+      },
+      "end": {
+        "line": 12,
+        "col": 11
+      },
+      "type": "foo.Bar -> foo",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 12,
+        "col": 8
+      },
+      "end": {
+        "line": 12,
+        "col": 26
+      },
+      "type": "type foo = Bar of { baz : unit; }",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 12:16 -verbosity 0 \
+  > -filename ./record.ml < ./record.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 12,
+        "col": 15
+      },
+      "end": {
+        "line": 12,
+        "col": 18
+      },
+      "type": "unit",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 12,
+        "col": 12
+      },
+      "end": {
+        "line": 12,
+        "col": 26
+      },
+      "type": "foo.Bar",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 12:16 -verbosity 1 \
+  > -filename ./record.ml < ./record.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 12,
+        "col": 15
+      },
+      "end": {
+        "line": 12,
+        "col": 18
+      },
+      "type": "unit",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 12,
+        "col": 12
+      },
+      "end": {
+        "line": 12,
+        "col": 26
+      },
+      "type": "type Bar = { baz : unit; }",
+      "tail": "no"
+    }
+  ]
diff --git a/tests/test-dirs/type-enclosing/te-413-features.t b/tests/test-dirs/type-enclosing/te-413-features.t
new file mode 100644
index 0000000..da5ab50
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/te-413-features.t
@@ -0,0 +1,243 @@
+Named existentials in patterns
+  $ $MERLIN single type-enclosing -position 3:59 -filename test.ml <<EOF | \
+  > tr '\n' ' ' |  jq '.value[0:2]' 
+  > type _ ty = Int : int ty
+  > type dyn = Dyn : 'a ty * 'a -> dyn
+  > let f = function Dyn (type a) (w, x : a ty * a) -> ignore (x : a)
+  > EOF
+  [
+    {
+      "start": {
+        "line": 3,
+        "col": 59
+      },
+      "end": {
+        "line": 3,
+        "col": 60
+      },
+      "type": "a",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 3,
+        "col": 51
+      },
+      "end": {
+        "line": 3,
+        "col": 65
+      },
+      "type": "unit",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 3:63 -filename test.ml <<EOF | \
+  > tr '\n' ' ' |  jq '.value[0:2]' 
+  > type _ ty = Int : int ty
+  > type dyn = Dyn : 'a ty * 'a -> dyn
+  > let f = function Dyn (type a) (w, x : a ty * a) -> ignore (x : a)
+  > EOF
+  [
+    {
+      "start": {
+        "line": 3,
+        "col": 63
+      },
+      "end": {
+        "line": 3,
+        "col": 64
+      },
+      "type": "type a",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 3,
+        "col": 63
+      },
+      "end": {
+        "line": 3,
+        "col": 64
+      },
+      "type": "a",
+      "tail": "no"
+    }
+  ]
+
+Module types substitutions
+  $ cat >mtsubst.ml <<EOF
+  > module type ENDO = sig
+  >   module type T
+  >   module F: T -> T
+  > end
+  > module Endo(X: sig module type T end): ENDO 
+  >   with module type T = X.T = struct
+  >   module type T = X.T
+  >   module F(X:T) = X
+  > end
+  > EOF
+
+  $ $MERLIN single type-enclosing -position 6:25 \
+  > -filename mtsubst.ml < mtsubst.ml |
+  > tr '\n' ' ' |  jq '.value[0:2]'
+  [
+    {
+      "start": {
+        "line": 6,
+        "col": 23
+      },
+      "end": {
+        "line": 6,
+        "col": 26
+      },
+      "type": "(* abstract module *)",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 6,
+        "col": 23
+      },
+      "end": {
+        "line": 6,
+        "col": 26
+      },
+      "type": "X.T",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single occurrences -identifier-at 6:19 \
+  > -filename mtsubst.ml < mtsubst.ml |
+  > tr '\n' ' ' |  jq '.value'
+  [
+    {
+      "start": {
+        "line": 2,
+        "col": 14
+      },
+      "end": {
+        "line": 2,
+        "col": 15
+      }
+    },
+    {
+      "start": {
+        "line": 3,
+        "col": 12
+      },
+      "end": {
+        "line": 3,
+        "col": 13
+      }
+    },
+    {
+      "start": {
+        "line": 3,
+        "col": 17
+      },
+      "end": {
+        "line": 3,
+        "col": 18
+      }
+    },
+    {
+      "start": {
+        "line": 6,
+        "col": 19
+      },
+      "end": {
+        "line": 6,
+        "col": 20
+      }
+    }
+  ]
+
+  $ cat >mtsubst.ml <<EOF
+  > module type ENDO = sig
+  >   module type T
+  >   module F: T -> T
+  > end
+  > module Endo(X: sig module type T end): ENDO 
+  >   with module type T := X.T = struct
+  >   module type T = X.T
+  >   module F(X:T) = X
+  > end
+  > EOF
+
+  $ $MERLIN single type-enclosing -position 6:26 \
+  > -filename mtsubst.ml < mtsubst.ml |
+  > tr '\n' ' ' |  jq '.value[0:2]'
+  [
+    {
+      "start": {
+        "line": 6,
+        "col": 24
+      },
+      "end": {
+        "line": 6,
+        "col": 27
+      },
+      "type": "(* abstract module *)",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 6,
+        "col": 24
+      },
+      "end": {
+        "line": 6,
+        "col": 27
+      },
+      "type": "X.T",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single occurrences -identifier-at 6:19 \
+  > -filename mtsubst.ml < mtsubst.ml |
+  > tr '\n' ' ' |  jq '.value'
+  [
+    {
+      "start": {
+        "line": 2,
+        "col": 14
+      },
+      "end": {
+        "line": 2,
+        "col": 15
+      }
+    },
+    {
+      "start": {
+        "line": 3,
+        "col": 12
+      },
+      "end": {
+        "line": 3,
+        "col": 13
+      }
+    },
+    {
+      "start": {
+        "line": 3,
+        "col": 17
+      },
+      "end": {
+        "line": 3,
+        "col": 18
+      }
+    },
+    {
+      "start": {
+        "line": 6,
+        "col": 19
+      },
+      "end": {
+        "line": 6,
+        "col": 20
+      }
+    }
+  ]
diff --git a/tests/test-dirs/type-enclosing/type-alias.t b/tests/test-dirs/type-enclosing/type-alias.t
new file mode 100644
index 0000000..e7e5bda
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/type-alias.t
@@ -0,0 +1,100 @@
+Test 1.1
+
+  $ $MERLIN single type-enclosing  -position 2:5 -filename type_alias.ml <<EOF
+  > type foo = int
+  > let x : foo = 1
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 4
+        },
+        "end": {
+          "line": 2,
+          "col": 5
+        },
+        "type": "foo",
+        "tail": "no"
+      }
+    ],
+    "notifications": []
+  }
+
+Test 1.2 with short paths
+
+  $ $MERLIN single type-enclosing -short-paths  -position 2:5 -filename type_alias.ml <<EOF
+  > type foo = int
+  > let x : foo = 1
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 4
+        },
+        "end": {
+          "line": 2,
+          "col": 5
+        },
+        "type": "foo",
+        "tail": "no"
+      }
+    ],
+    "notifications": []
+  }
+
+
+Test 2.1
+
+  $ $MERLIN single type-enclosing -position 2:5 -filename type_alias2.ml <<EOF
+  > type foo = int
+  > let x = 1
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 4
+        },
+        "end": {
+          "line": 2,
+          "col": 5
+        },
+        "type": "int",
+        "tail": "no"
+      }
+    ],
+    "notifications": []
+  }
+
+Test 2.2 with shortpaths
+
+  $ $MERLIN single type-enclosing -short-paths -position 2:5 -filename type_alias3.ml <<EOF
+  > type foo = int
+  > let x = 1
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 4
+        },
+        "end": {
+          "line": 2,
+          "col": 5
+        },
+        "type": "foo",
+        "tail": "no"
+      }
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/type-enclosing/types.t/run.t b/tests/test-dirs/type-enclosing/types.t/run.t
new file mode 100644
index 0000000..d86ca72
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/types.t/run.t
@@ -0,0 +1,162 @@
+  $ $MERLIN single type-enclosing -position 5:11 -verbosity 0 \
+  > -filename ./types.ml < ./types.ml | jq ".value"
+  [
+    {
+      "start": {
+        "line": 5,
+        "col": 10
+      },
+      "end": {
+        "line": 5,
+        "col": 11
+      },
+      "type": "type x = Foo",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 5,
+        "col": 10
+      },
+      "end": {
+        "line": 5,
+        "col": 11
+      },
+      "type": "x",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 5:11 -verbosity 1 \
+  > -filename ./types.ml < ./types.ml | jq ".value"
+  [
+    {
+      "start": {
+        "line": 5,
+        "col": 10
+      },
+      "end": {
+        "line": 5,
+        "col": 11
+      },
+      "type": "type x = Foo",
+      "tail": "no"
+    }
+  ]
+
+FIXED: small enclosing was incorrect?
+
+  $ $MERLIN single type-enclosing -position 7:9 -verbosity 0 \
+  > -filename ./types.ml < ./types.ml | jq ".value"
+  [
+    {
+      "start": {
+        "line": 7,
+        "col": 0
+      },
+      "end": {
+        "line": 7,
+        "col": 14
+      },
+      "type": "type 'a t = 'a",
+      "tail": "no"
+    }
+  ]
+
+FIXED: small enclosing was incorrect?
+
+  $ $MERLIN single type-enclosing -position 9:9 -verbosity 0 \
+  > -filename ./types.ml < ./types.ml | jq ".value"
+  [
+    {
+      "start": {
+        "line": 9,
+        "col": 0
+      },
+      "end": {
+        "line": 9,
+        "col": 16
+      },
+      "type": "type 'a s = 'a t",
+      "tail": "no"
+    }
+  ]
+
+FIXME: A type with a type param shouldn't equal itself - aliasing a list type
+
+  $ $MERLIN single type-enclosing -short-paths -position 11:9 -verbosity 0 \
+  > -filename ./types.ml < ./types.ml | jq ".value"
+  [
+    {
+      "start": {
+        "line": 11,
+        "col": 0
+      },
+      "end": {
+        "line": 11,
+        "col": 19
+      },
+      "type": "type 'a l = 'a l",
+      "tail": "no"
+    }
+  ]
+
+Same result regardless of verbosity:
+
+  $ $MERLIN single type-enclosing -short-paths -position 11:9 -verbosity 1 \
+  > -filename ./types.ml < ./types.ml | jq ".value"
+  [
+    {
+      "start": {
+        "line": 11,
+        "col": 0
+      },
+      "end": {
+        "line": 11,
+        "col": 19
+      },
+      "type": "type 'a l = 'a l",
+      "tail": "no"
+    }
+  ]
+
+OK without -short-paths
+
+  $ $MERLIN single type-enclosing -position 11:9 -verbosity 0 \
+  > -filename ./types.ml < ./types.ml | jq ".value"
+  [
+    {
+      "start": {
+        "line": 11,
+        "col": 0
+      },
+      "end": {
+        "line": 11,
+        "col": 19
+      },
+      "type": "type 'a l = 'a list",
+      "tail": "no"
+    }
+  ]
+
+
+FIXED: small enclosing at EOF was incorrect?
+
+  $ $MERLIN single type-enclosing -short-paths -position 17:9 -verbosity 0 \
+  > -filename ./types.ml < ./types.ml | jq ".value"
+  [
+    {
+      "start": {
+        "line": 17,
+        "col": 0
+      },
+      "end": {
+        "line": 17,
+        "col": 21
+      },
+      "type": "type 'a v = Foo of 'a",
+      "tail": "no"
+    }
+  ]
+
+
diff --git a/tests/test-dirs/type-enclosing/types.t/types.ml b/tests/test-dirs/type-enclosing/types.t/types.ml
new file mode 100644
index 0000000..b15a454
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/types.t/types.ml
@@ -0,0 +1,17 @@
+let x = 3
+
+type x = Foo
+
+let foo : x = Foo
+
+type 'a t = 'a
+
+type 'a s = 'a t
+
+type 'a l = 'a list
+
+module M = struct
+  type 'a t = 'a
+end
+
+type 'a v = Foo of 'a
\ No newline at end of file
diff --git a/tests/test-dirs/type-enclosing/underscore-ids.t b/tests/test-dirs/type-enclosing/underscore-ids.t
new file mode 100644
index 0000000..69189e6
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/underscore-ids.t
@@ -0,0 +1,321 @@
+These tests ensure the stability of identifier reconstruction
+in the presence of underscores.
+
+1.1
+  $ $MERLIN single type-enclosing -position 3:2 -filename under.ml <<EOF | \
+  > jq '.value'
+  > let _foo = 4.2
+  > let f () : int =
+  >   _foo
+  > EOF
+  [
+    {
+      "start": {
+        "line": 3,
+        "col": 2
+      },
+      "end": {
+        "line": 3,
+        "col": 6
+      },
+      "type": "float",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 3,
+        "col": 2
+      },
+      "end": {
+        "line": 3,
+        "col": 6
+      },
+      "type": "int",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 2,
+        "col": 6
+      },
+      "end": {
+        "line": 3,
+        "col": 6
+      },
+      "type": "unit -> int",
+      "tail": "no"
+    }
+  ]
+
+1.2
+  $ $MERLIN single type-enclosing -position 3:3 -filename under.ml <<EOF | \
+  >  jq '.value'
+  > let _foo = 4.2
+  > let f () : int =
+  >   _foo
+  > EOF
+  [
+    {
+      "start": {
+        "line": 3,
+        "col": 2
+      },
+      "end": {
+        "line": 3,
+        "col": 6
+      },
+      "type": "float",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 3,
+        "col": 2
+      },
+      "end": {
+        "line": 3,
+        "col": 6
+      },
+      "type": "int",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 2,
+        "col": 6
+      },
+      "end": {
+        "line": 3,
+        "col": 6
+      },
+      "type": "unit -> int",
+      "tail": "no"
+    }
+  ]
+
+We try several places in the identifier to check the result stability
+2.1
+  $ $MERLIN single type-enclosing -position 3:5 -filename under.ml <<EOF | \
+  >  jq '.value'
+  > let foo_bar = 4.2
+  > let f () : int =
+  >   foo_bar
+  > EOF
+  [
+    {
+      "start": {
+        "line": 3,
+        "col": 2
+      },
+      "end": {
+        "line": 3,
+        "col": 9
+      },
+      "type": "float",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 3,
+        "col": 2
+      },
+      "end": {
+        "line": 3,
+        "col": 9
+      },
+      "type": "int",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 2,
+        "col": 6
+      },
+      "end": {
+        "line": 3,
+        "col": 9
+      },
+      "type": "unit -> int",
+      "tail": "no"
+    }
+  ]
+
+2.2
+  $ $MERLIN single type-enclosing -position 3:6 -filename under.ml <<EOF | \
+  >  jq '.value'
+  > let foo_bar = 4.2
+  > let f () : int =
+  >   foo_bar
+  > EOF
+  [
+    {
+      "start": {
+        "line": 3,
+        "col": 2
+      },
+      "end": {
+        "line": 3,
+        "col": 9
+      },
+      "type": "float",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 3,
+        "col": 2
+      },
+      "end": {
+        "line": 3,
+        "col": 9
+      },
+      "type": "int",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 2,
+        "col": 6
+      },
+      "end": {
+        "line": 3,
+        "col": 9
+      },
+      "type": "unit -> int",
+      "tail": "no"
+    }
+  ]
+
+2.3
+  $ $MERLIN single type-enclosing -position 3:7 -filename under.ml <<EOF | \
+  >  jq '.value'
+  > let foo_bar = 4.2
+  > let f () : int =
+  >   foo_bar
+  > EOF
+  [
+    {
+      "start": {
+        "line": 3,
+        "col": 2
+      },
+      "end": {
+        "line": 3,
+        "col": 9
+      },
+      "type": "float",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 3,
+        "col": 2
+      },
+      "end": {
+        "line": 3,
+        "col": 9
+      },
+      "type": "int",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 2,
+        "col": 6
+      },
+      "end": {
+        "line": 3,
+        "col": 9
+      },
+      "type": "unit -> int",
+      "tail": "no"
+    }
+  ]
+
+2.4
+  $ $MERLIN single type-enclosing -position 3:8 -filename under.ml <<EOF
+  > let foo_bar = 4.2
+  > let f () : int =
+  >   foo_bar
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 2
+        },
+        "end": {
+          "line": 3,
+          "col": 9
+        },
+        "type": "float",
+        "tail": "no"
+      },
+      {
+        "start": {
+          "line": 3,
+          "col": 2
+        },
+        "end": {
+          "line": 3,
+          "col": 9
+        },
+        "type": "int",
+        "tail": "no"
+      },
+      {
+        "start": {
+          "line": 2,
+          "col": 6
+        },
+        "end": {
+          "line": 3,
+          "col": 9
+        },
+        "type": "unit -> int",
+        "tail": "no"
+      }
+    ],
+    "notifications": []
+  }
+
+3.1
+  $ $MERLIN single type-enclosing -position 5:10 -filename under.ml <<EOF
+  > let aa = 4.2
+  > let f (x) : int = function
+  >   | None -> 3
+  >   | Some 5 -> 4
+  >   | Some _aa -> 4
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 18
+        },
+        "end": {
+          "line": 5,
+          "col": 17
+        },
+        "type": "int",
+        "tail": "no"
+      },
+      {
+        "start": {
+          "line": 2,
+          "col": 6
+        },
+        "end": {
+          "line": 5,
+          "col": 17
+        },
+        "type": "'a -> int",
+        "tail": "no"
+      }
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/type-enclosing/variants.t/run.t b/tests/test-dirs/type-enclosing/variants.t/run.t
new file mode 100644
index 0000000..93df670
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/variants.t/run.t
@@ -0,0 +1,213 @@
+  $ $MERLIN single type-enclosing -position 2:15 -verbosity 0 \
+  > -filename ./variants.ml < ./variants.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 2,
+        "col": 14
+      },
+      "end": {
+        "line": 2,
+        "col": 18
+      },
+      "type": "type core = [ `A | `B ]",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 2,
+        "col": 14
+      },
+      "end": {
+        "line": 2,
+        "col": 18
+      },
+      "type": "core",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 2:13 -verbosity 0 \
+  > -filename ./variants.ml < ./variants.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 2,
+        "col": 12
+      },
+      "end": {
+        "line": 2,
+        "col": 25
+      },
+      "type": "[ `A | `B | `C ]",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 2,
+        "col": 0
+      },
+      "end": {
+        "line": 2,
+        "col": 25
+      },
+      "type": "type more = [ `A | `B | `C ]",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 4:5 -verbosity 0 \
+  > -filename ./variants.ml < ./variants.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 4,
+        "col": 4
+      },
+      "end": {
+        "line": 4,
+        "col": 5
+      },
+      "type": "more",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 4:5 -verbosity 1 \
+  > -filename ./variants.ml < ./variants.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 4,
+        "col": 4
+      },
+      "end": {
+        "line": 4,
+        "col": 5
+      },
+      "type": "[ `A | `B | `C ]",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 4:5 -verbosity 0 \
+  > -filename ./variants.ml < ./variants.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 4,
+        "col": 4
+      },
+      "end": {
+        "line": 4,
+        "col": 5
+      },
+      "type": "more",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 5:9 -verbosity 0 \
+  > -filename ./variants.ml < ./variants.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 5,
+        "col": 8
+      },
+      "end": {
+        "line": 5,
+        "col": 12
+      },
+      "type": "type core = [ `A | `B ]",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 5,
+        "col": 8
+      },
+      "end": {
+        "line": 5,
+        "col": 12
+      },
+      "type": "core",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 5:17 -verbosity 0 \
+  > -filename ./variants.ml < ./variants.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 5,
+        "col": 15
+      },
+      "end": {
+        "line": 5,
+        "col": 17
+      },
+      "type": "core",
+      "tail": "no"
+    }
+  ]
+
+FIXME: Not satisfying, expected core not more
+  $ $MERLIN single type-enclosing -position 9:3 -verbosity 0 \
+  > -filename ./variants.ml < ./variants.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 9,
+        "col": 2
+      },
+      "end": {
+        "line": 9,
+        "col": 7
+      },
+      "type": "more",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 7,
+        "col": 9
+      },
+      "end": {
+        "line": 9,
+        "col": 13
+      },
+      "type": "unit",
+      "tail": "no"
+    }
+  ]
+
+  $ $MERLIN single type-enclosing -position 9:3 -verbosity 1 \
+  > -filename ./variants.ml < ./variants.ml | jq ".value[0:2]"
+  [
+    {
+      "start": {
+        "line": 9,
+        "col": 2
+      },
+      "end": {
+        "line": 9,
+        "col": 7
+      },
+      "type": "[ `A | `B | `C ]",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 7,
+        "col": 9
+      },
+      "end": {
+        "line": 9,
+        "col": 13
+      },
+      "type": "type unit = ()",
+      "tail": "no"
+    }
+  ]
diff --git a/tests/test-dirs/type-enclosing/variants.t/variants.ml b/tests/test-dirs/type-enclosing/variants.t/variants.ml
new file mode 100644
index 0000000..a1003de
--- /dev/null
+++ b/tests/test-dirs/type-enclosing/variants.t/variants.ml
@@ -0,0 +1,9 @@
+type core = [ `A | `B ]
+type more = [ core | `C ]
+
+let x : more = `A
+let y : core = `B
+
+let () = match x with
+| `C -> ()
+| #core -> ()
diff --git a/tests/test-dirs/type-expr.t/run.t b/tests/test-dirs/type-expr.t/run.t
new file mode 100644
index 0000000..65f1fff
--- /dev/null
+++ b/tests/test-dirs/type-expr.t/run.t
@@ -0,0 +1,152 @@
+  $ $MERLIN single type-expression -expression "y" -position start -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": "Unbound value y",
+    "notifications": []
+  }
+  $ $MERLIN single type-expression -expression "y" -position end -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": "int",
+    "notifications": []
+  }
+
+  $ $MERLIN single type-expression -expression "t" -position start -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": "Unbound value t",
+    "notifications": []
+  }
+  $ $MERLIN single type-expression -expression "t" -position end -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": "Unbound value t",
+    "notifications": []
+  }
+
+  $ $MERLIN single type-expression -expression "x + y" -position start -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": "Unbound value x",
+    "notifications": []
+  }
+  $ $MERLIN single type-expression -expression "x + y" -position end -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": "int",
+    "notifications": []
+  }
+
+  $ $MERLIN single type-expression -expression "T" -position start -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": "Unbound constructor T",
+    "notifications": []
+  }
+  $ $MERLIN single type-expression -expression "T" -position end -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": "t",
+    "notifications": []
+  }
+
+  $ $MERLIN single type-expression -expression "M" -position start -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": "Unbound constructor M",
+    "notifications": []
+  }
+  $ $MERLIN single type-expression -expression "M" -position end -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": "(module List)",
+    "notifications": []
+  }
+
+  $ $MERLIN single type-expression -expression "MT" -position start -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": "Unbound constructor MT",
+    "notifications": []
+  }
+
+  $ $MERLIN single type-expression -expression "MT" -position end -filename test.ml < test.ml 
+  {
+    "class": "return",
+    "value": "sig
+    type 'a t = 'a list = [] | (::) of 'a * 'a list
+    val length : 'a list -> int
+    val compare_lengths : 'a list -> 'b list -> int
+    val compare_length_with : 'a list -> int -> int
+    val cons : 'a -> 'a list -> 'a list
+    val hd : 'a list -> 'a
+    val tl : 'a list -> 'a list
+    val nth : 'a list -> int -> 'a
+    val nth_opt : 'a list -> int -> 'a option
+    val rev : 'a list -> 'a list
+    val init : int -> (int -> 'a) -> 'a list
+    val append : 'a list -> 'a list -> 'a list
+    val rev_append : 'a list -> 'a list -> 'a list
+    val concat : 'a list list -> 'a list
+    val flatten : 'a list list -> 'a list
+    val equal : ('a -> 'a -> bool) -> 'a list -> 'a list -> bool
+    val compare : ('a -> 'a -> int) -> 'a list -> 'a list -> int
+    val iter : ('a -> unit) -> 'a list -> unit
+    val iteri : (int -> 'a -> unit) -> 'a list -> unit
+    val map : ('a -> 'b) -> 'a list -> 'b list
+    val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list
+    val rev_map : ('a -> 'b) -> 'a list -> 'b list
+    val filter_map : ('a -> 'b option) -> 'a list -> 'b list
+    val concat_map : ('a -> 'b list) -> 'a list -> 'b list
+    val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list
+    val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a
+    val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
+    val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit
+    val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
+    val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
+    val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a
+    val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c
+    val for_all : ('a -> bool) -> 'a list -> bool
+    val exists : ('a -> bool) -> 'a list -> bool
+    val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+    val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+    val mem : 'a -> 'a list -> bool
+    val memq : 'a -> 'a list -> bool
+    val find : ('a -> bool) -> 'a list -> 'a
+    val find_opt : ('a -> bool) -> 'a list -> 'a option
+    val find_map : ('a -> 'b option) -> 'a list -> 'b option
+    val filter : ('a -> bool) -> 'a list -> 'a list
+    val find_all : ('a -> bool) -> 'a list -> 'a list
+    val filteri : (int -> 'a -> bool) -> 'a list -> 'a list
+    val partition : ('a -> bool) -> 'a list -> 'a list * 'a list
+    val partition_map :
+      ('a -> ('b, 'c) Either.t) -> 'a list -> 'b list * 'c list
+    val assoc : 'a -> ('a * 'b) list -> 'b
+    val assoc_opt : 'a -> ('a * 'b) list -> 'b option
+    val assq : 'a -> ('a * 'b) list -> 'b
+    val assq_opt : 'a -> ('a * 'b) list -> 'b option
+    val mem_assoc : 'a -> ('a * 'b) list -> bool
+    val mem_assq : 'a -> ('a * 'b) list -> bool
+    val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list
+    val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list
+    val split : ('a * 'b) list -> 'a list * 'b list
+    val combine : 'a list -> 'b list -> ('a * 'b) list
+    val sort : ('a -> 'a -> int) -> 'a list -> 'a list
+    val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list
+    val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list
+    val sort_uniq : ('a -> 'a -> int) -> 'a list -> 'a list
+    val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
+    val to_seq : 'a list -> 'a Seq.t
+    val of_seq : 'a Seq.t -> 'a list
+  end",
+    "notifications": []
+  }
+
+  $ $MERLIN single type-expression -expression "f (" -position start \
+  > -filename test.ml < test.ml | \
+  > sed 's/\("value": \)".*\.Error.*",/\1<syntax error>,/'
+  {
+    "class": "return",
+    "value": <syntax error>,
+    "notifications": []
+  }
diff --git a/tests/test-dirs/type-expr.t/test.ml b/tests/test-dirs/type-expr.t/test.ml
new file mode 100644
index 0000000..f2456be
--- /dev/null
+++ b/tests/test-dirs/type-expr.t/test.ml
@@ -0,0 +1,6 @@
+let x = 5
+let y = 10
+type t = T
+module M = List
+module type MT = module type of List
+let z = ()
diff --git a/tests/test-dirs/typing-recovery.t b/tests/test-dirs/typing-recovery.t
new file mode 100644
index 0000000..910aa65
--- /dev/null
+++ b/tests/test-dirs/typing-recovery.t
@@ -0,0 +1,639 @@
+# Recovery in structures
+
+  $ cat >test.ml <<EOF
+  > type t = A | B
+  > let f (x : t) =
+  >   match x with
+  >   | A -> ()
+  >   | B -> 3
+  >   | C -> 'a'
+  > EOF
+
+  $ $MERLIN single errors -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 5,
+          "col": 9
+        },
+        "end": {
+          "line": 5,
+          "col": 10
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "This expression has type int but an expression was expected of type unit"
+      },
+      {
+        "start": {
+          "line": 6,
+          "col": 4
+        },
+        "end": {
+          "line": 6,
+          "col": 5
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "This variant pattern is expected to have type t
+  There is no constructor C within type t"
+      },
+      {
+        "start": {
+          "line": 6,
+          "col": 9
+        },
+        "end": {
+          "line": 6,
+          "col": 12
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "This expression has type char but an expression was expected of type unit"
+      }
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single dump -what typedtree -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": "[
+    structure_item (test.ml[1,0+0]..test.ml[1,0+14])
+      Tstr_type Rec
+      [
+        type_declaration t/81 (test.ml[1,0+0]..test.ml[1,0+14])
+          ptype_params =
+            []
+          ptype_cstrs =
+            []
+          ptype_kind =
+            Ttype_variant
+              [
+                (test.ml[1,0+9]..test.ml[1,0+10])
+                  A/82
+                  []
+                  None
+                (test.ml[1,0+11]..test.ml[1,0+14])
+                  B/83
+                  []
+                  None
+              ]
+          ptype_private = Public
+          ptype_manifest =
+            None
+      ]
+    structure_item (test.ml[2,15+0]..test.ml[6,69+12])
+      Tstr_value Nonrec
+      [
+        <def>
+          pattern (test.ml[2,15+4]..test.ml[2,15+5])
+            Tpat_var \"f/84\"
+          expression (test.ml[2,15+6]..test.ml[6,69+12]) ghost
+            Texp_function
+            Nolabel
+            [
+              <case>
+                pattern (test.ml[2,15+7]..test.ml[2,15+8])
+                  Tpat_extra_constraint
+                  core_type (test.ml[2,15+11]..test.ml[2,15+12])
+                    Ttyp_constr \"t/81\"
+                    []
+                  pattern (test.ml[2,15+7]..test.ml[2,15+8])
+                    Tpat_alias \"x/86\"
+                    pattern (test.ml[2,15+7]..test.ml[2,15+8])
+                      Tpat_any
+                expression (test.ml[3,31+2]..test.ml[6,69+12])
+                  Texp_match
+                  expression (test.ml[3,31+8]..test.ml[3,31+9])
+                    Texp_ident \"x/86\"
+                  [
+                    <case>
+                      pattern (test.ml[4,46+4]..test.ml[4,46+5])
+                        Tpat_value
+                        pattern (test.ml[4,46+4]..test.ml[4,46+5])
+                          Tpat_construct \"A\"
+                          []
+                          None
+                      expression (test.ml[4,46+9]..test.ml[4,46+11])
+                        attribute \"merlin.loc\"
+                          []
+                        Texp_construct \"()\"
+                        []
+                    <case>
+                      pattern (test.ml[5,58+4]..test.ml[5,58+5])
+                        Tpat_value
+                        pattern (test.ml[5,58+4]..test.ml[5,58+5])
+                          Tpat_construct \"B\"
+                          []
+                          None
+                      expression (test.ml[5,58+9]..test.ml[5,58+10])
+                        attribute \"merlin.incorrect\"
+                          []
+                        attribute \"merlin.saved-parts\"
+                          [
+                            structure_item (_none_[0,0+-1]..[0,0+-1]) ghost
+                              Pstr_eval
+                              expression (_none_[0,0+-1]..[0,0+-1]) ghost
+                                Pexp_constant PConst_int (1,None)
+                          ]
+                        attribute \"merlin.loc\"
+                          []
+                        Texp_ident \"*type-error*/87\"
+                    <case>
+                      pattern (test.ml[6,69+4]..test.ml[6,69+5])
+                        Tpat_value
+                        pattern (test.ml[6,69+4]..test.ml[6,69+5])
+                          attribute \"merlin.incorrect\"
+                            []
+                          Tpat_any
+                      expression (test.ml[6,69+9]..test.ml[6,69+12])
+                        attribute \"merlin.incorrect\"
+                          []
+                        attribute \"merlin.saved-parts\"
+                          [
+                            structure_item (_none_[0,0+-1]..[0,0+-1]) ghost
+                              Pstr_eval
+                              expression (_none_[0,0+-1]..[0,0+-1]) ghost
+                                Pexp_constant PConst_int (2,None)
+                          ]
+                        attribute \"merlin.loc\"
+                          []
+                        Texp_ident \"*type-error*/88\"
+                  ]
+            ]
+      ]
+  ]
+  
+  
+  ",
+    "notifications": []
+  }
+
+  $ cat >test2.ml <<EOF
+  > type t = A | B
+  > let f (C : t) : int = ()
+  > EOF
+
+  $ $MERLIN single errors -filename test2.ml < test2.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 7
+        },
+        "end": {
+          "line": 2,
+          "col": 8
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "This variant pattern is expected to have type t
+  There is no constructor C within type t"
+      },
+      {
+        "start": {
+          "line": 2,
+          "col": 22
+        },
+        "end": {
+          "line": 2,
+          "col": 24
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "This expression has type unit but an expression was expected of type int"
+      }
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single dump -what typedtree -filename test2.ml < test2.ml
+  {
+    "class": "return",
+    "value": "[
+    structure_item (test2.ml[1,0+0]..test2.ml[1,0+14])
+      Tstr_type Rec
+      [
+        type_declaration t/81 (test2.ml[1,0+0]..test2.ml[1,0+14])
+          ptype_params =
+            []
+          ptype_cstrs =
+            []
+          ptype_kind =
+            Ttype_variant
+              [
+                (test2.ml[1,0+9]..test2.ml[1,0+10])
+                  A/82
+                  []
+                  None
+                (test2.ml[1,0+11]..test2.ml[1,0+14])
+                  B/83
+                  []
+                  None
+              ]
+          ptype_private = Public
+          ptype_manifest =
+            None
+      ]
+    structure_item (test2.ml[2,15+0]..test2.ml[2,15+24])
+      Tstr_value Nonrec
+      [
+        <def>
+          pattern (test2.ml[2,15+4]..test2.ml[2,15+5])
+            Tpat_var \"f/84\"
+          expression (test2.ml[2,15+6]..test2.ml[2,15+24]) ghost
+            Texp_function
+            Nolabel
+            [
+              <case>
+                pattern (test2.ml[2,15+7]..test2.ml[2,15+8])
+                  attribute \"merlin.incorrect\"
+                    []
+                  Tpat_extra_constraint
+                  core_type (test2.ml[2,15+11]..test2.ml[2,15+12])
+                    Ttyp_constr \"t/81\"
+                    []
+                  pattern (test2.ml[2,15+7]..test2.ml[2,15+8])
+                    attribute \"merlin.incorrect\"
+                      []
+                    Tpat_any
+                expression (test2.ml[2,15+22]..test2.ml[2,15+24])
+                  attribute \"merlin.incorrect\"
+                    []
+                  attribute \"merlin.saved-parts\"
+                    [
+                      structure_item (_none_[0,0+-1]..[0,0+-1]) ghost
+                        Pstr_eval
+                        expression (_none_[0,0+-1]..[0,0+-1]) ghost
+                          Pexp_constant PConst_int (1,None)
+                    ]
+                  Texp_constraint
+                  core_type (test2.ml[2,15+16]..test2.ml[2,15+19])
+                    Ttyp_constr \"int/1!\"
+                    []
+                    Texp_ident \"*type-error*/86\"
+            ]
+      ]
+  ]
+  
+  
+  ",
+    "notifications": []
+  }
+
+# Recovery in signatures
+
+First a simple case:
+
+  $ cat >test.mli <<EOF
+  > val foo1 : int
+  > 
+  > val foo2 : int * toto
+  > 
+  > val foo3 : int * char
+  > EOF
+
+  $ $MERLIN single errors -filename test.mli < test.mli
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 17
+        },
+        "end": {
+          "line": 3,
+          "col": 21
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Unbound type constructor toto"
+      }
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single dump -what typedtree -filename test.mli < test.mli
+  {
+    "class": "return",
+    "value": "[
+    signature_item (test.mli[1,0+0]..test.mli[1,0+14])
+      Tsig_value
+      value_description foo1/81 (test.mli[1,0+0]..test.mli[1,0+14])
+        core_type (test.mli[1,0+11]..test.mli[1,0+14])
+          Ttyp_constr \"int/1!\"
+          []
+        []
+    signature_item (test.mli[3,16+0]..test.mli[3,16+21])
+      Tsig_value
+      value_description foo2/82 (test.mli[3,16+0]..test.mli[3,16+21])
+        core_type (test.mli[3,16+11]..test.mli[3,16+21])
+          Ttyp_tuple
+          [
+            core_type (test.mli[3,16+11]..test.mli[3,16+14])
+              Ttyp_constr \"int/1!\"
+              []
+            core_type (test.mli[3,16+17]..test.mli[3,16+21])
+              Ttyp_any
+          ]
+        []
+    signature_item (test.mli[5,39+0]..test.mli[5,39+21])
+      Tsig_value
+      value_description foo3/83 (test.mli[5,39+0]..test.mli[5,39+21])
+        core_type (test.mli[5,39+11]..test.mli[5,39+21])
+          Ttyp_tuple
+          [
+            core_type (test.mli[5,39+11]..test.mli[5,39+14])
+              Ttyp_constr \"int/1!\"
+              []
+            core_type (test.mli[5,39+17]..test.mli[5,39+21])
+              Ttyp_constr \"char/2!\"
+              []
+          ]
+        []
+  ]
+  
+  
+  ",
+    "notifications": []
+  }
+
+And now, with an error deep in a submodule:
+
+  $ cat >test2.mli <<EOF
+  > val foo1 : int
+  > 
+  > module M : sig
+  >   val foo21 : int
+  >   module N : sig
+  >     val foo211 : int
+  >     val foo212 : int * toto
+  >     val foo213 : int * char
+  >   end
+  > end
+  > 
+  > val foo3 : int * char
+  > EOF
+
+  $ $MERLIN single errors -filename test2.mli < test2.mli
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 7,
+          "col": 23
+        },
+        "end": {
+          "line": 7,
+          "col": 27
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Unbound type constructor toto"
+      }
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single dump -what typedtree -filename test2.mli < test2.mli
+  {
+    "class": "return",
+    "value": "[
+    signature_item (test2.mli[1,0+0]..test2.mli[1,0+14])
+      Tsig_value
+      value_description foo1/81 (test2.mli[1,0+0]..test2.mli[1,0+14])
+        core_type (test2.mli[1,0+11]..test2.mli[1,0+14])
+          Ttyp_constr \"int/1!\"
+          []
+        []
+    signature_item (test2.mli[3,16+0]..test2.mli[10,149+3])
+      Tsig_module \"M/87\"
+      module_type (test2.mli[3,16+11]..test2.mli[10,149+3])
+        Tmty_signature
+        [
+          signature_item (test2.mli[4,31+2]..test2.mli[4,31+17])
+            Tsig_value
+            value_description foo21/82 (test2.mli[4,31+2]..test2.mli[4,31+17])
+              core_type (test2.mli[4,31+14]..test2.mli[4,31+17])
+                Ttyp_constr \"int/1!\"
+                []
+              []
+          signature_item (test2.mli[5,49+2]..test2.mli[9,143+5])
+            Tsig_module \"N/86\"
+            module_type (test2.mli[5,49+13]..test2.mli[9,143+5])
+              Tmty_signature
+              [
+                signature_item (test2.mli[6,66+4]..test2.mli[6,66+20])
+                  Tsig_value
+                  value_description foo211/83 (test2.mli[6,66+4]..test2.mli[6,66+20])
+                    core_type (test2.mli[6,66+17]..test2.mli[6,66+20])
+                      Ttyp_constr \"int/1!\"
+                      []
+                    []
+                signature_item (test2.mli[7,87+4]..test2.mli[7,87+27])
+                  Tsig_value
+                  value_description foo212/84 (test2.mli[7,87+4]..test2.mli[7,87+27])
+                    core_type (test2.mli[7,87+17]..test2.mli[7,87+27])
+                      Ttyp_tuple
+                      [
+                        core_type (test2.mli[7,87+17]..test2.mli[7,87+20])
+                          Ttyp_constr \"int/1!\"
+                          []
+                        core_type (test2.mli[7,87+23]..test2.mli[7,87+27])
+                          Ttyp_any
+                      ]
+                    []
+                signature_item (test2.mli[8,115+4]..test2.mli[8,115+27])
+                  Tsig_value
+                  value_description foo213/85 (test2.mli[8,115+4]..test2.mli[8,115+27])
+                    core_type (test2.mli[8,115+17]..test2.mli[8,115+27])
+                      Ttyp_tuple
+                      [
+                        core_type (test2.mli[8,115+17]..test2.mli[8,115+20])
+                          Ttyp_constr \"int/1!\"
+                          []
+                        core_type (test2.mli[8,115+23]..test2.mli[8,115+27])
+                          Ttyp_constr \"char/2!\"
+                          []
+                      ]
+                    []
+              ]
+        ]
+    signature_item (test2.mli[12,154+0]..test2.mli[12,154+21])
+      Tsig_value
+      value_description foo3/88 (test2.mli[12,154+0]..test2.mli[12,154+21])
+        core_type (test2.mli[12,154+11]..test2.mli[12,154+21])
+          Ttyp_tuple
+          [
+            core_type (test2.mli[12,154+11]..test2.mli[12,154+14])
+              Ttyp_constr \"int/1!\"
+              []
+            core_type (test2.mli[12,154+17]..test2.mli[12,154+21])
+              Ttyp_constr \"char/2!\"
+              []
+          ]
+        []
+  ]
+  
+  
+  ",
+    "notifications": []
+  }
+
+# Recovery for core types
+
+Actually the most likely error for signatures is an error in a core type, let's
+make sure we also handle that correctly in structures:
+
+  $ cat >test_ct.ml <<EOF
+  > let foo1 : int = 3
+  > 
+  > let foo2 : int * toto = 3, 4
+  > 
+  > let foo3 : int * int = 3, 4
+  > EOF
+
+  $ $MERLIN single errors -filename test_ct.ml < test_ct.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 17
+        },
+        "end": {
+          "line": 3,
+          "col": 21
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Unbound type constructor toto"
+      }
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single dump -what typedtree -filename test_ct.ml < test_ct.ml
+  {
+    "class": "return",
+    "value": "[
+    structure_item (test_ct.ml[1,0+0]..test_ct.ml[1,0+18])
+      Tstr_value Nonrec
+      [
+        <def>
+          pattern (test_ct.ml[1,0+4]..test_ct.ml[1,0+8])
+            Tpat_extra_constraint
+            core_type (test_ct.ml[1,0+11]..test_ct.ml[1,0+14]) ghost
+              Ttyp_poly
+              core_type (test_ct.ml[1,0+11]..test_ct.ml[1,0+14])
+                Ttyp_constr \"int/1!\"
+                []
+            pattern (test_ct.ml[1,0+4]..test_ct.ml[1,0+8])
+              Tpat_var \"foo1/81\"
+          expression (test_ct.ml[1,0+17]..test_ct.ml[1,0+18])
+            Texp_constraint
+            core_type (test_ct.ml[1,0+11]..test_ct.ml[1,0+14])
+              Ttyp_constr \"int/1!\"
+              []
+              Texp_constant Const_int 3
+      ]
+    structure_item (test_ct.ml[3,20+0]..test_ct.ml[3,20+28])
+      Tstr_value Nonrec
+      [
+        <def>
+          pattern (test_ct.ml[3,20+4]..test_ct.ml[3,20+8])
+            Tpat_extra_constraint
+            core_type (test_ct.ml[3,20+11]..test_ct.ml[3,20+21]) ghost
+              Ttyp_poly
+              core_type (test_ct.ml[3,20+11]..test_ct.ml[3,20+21])
+                Ttyp_tuple
+                [
+                  core_type (test_ct.ml[3,20+11]..test_ct.ml[3,20+14])
+                    Ttyp_constr \"int/1!\"
+                    []
+                  core_type (test_ct.ml[3,20+17]..test_ct.ml[3,20+21])
+                    Ttyp_any
+                ]
+            pattern (test_ct.ml[3,20+4]..test_ct.ml[3,20+8])
+              Tpat_var \"foo2/82\"
+          expression (test_ct.ml[3,20+24]..test_ct.ml[3,20+28])
+            Texp_constraint
+            core_type (test_ct.ml[3,20+11]..test_ct.ml[3,20+21])
+              Ttyp_tuple
+              [
+                core_type (test_ct.ml[3,20+11]..test_ct.ml[3,20+14])
+                  Ttyp_constr \"int/1!\"
+                  []
+                core_type (test_ct.ml[3,20+17]..test_ct.ml[3,20+21])
+                  Ttyp_any
+              ]
+              Texp_tuple
+              [
+                expression (test_ct.ml[3,20+24]..test_ct.ml[3,20+25])
+                  Texp_constant Const_int 3
+                expression (test_ct.ml[3,20+27]..test_ct.ml[3,20+28])
+                  Texp_constant Const_int 4
+              ]
+      ]
+    structure_item (test_ct.ml[5,50+0]..test_ct.ml[5,50+27])
+      Tstr_value Nonrec
+      [
+        <def>
+          pattern (test_ct.ml[5,50+4]..test_ct.ml[5,50+8])
+            Tpat_extra_constraint
+            core_type (test_ct.ml[5,50+11]..test_ct.ml[5,50+20]) ghost
+              Ttyp_poly
+              core_type (test_ct.ml[5,50+11]..test_ct.ml[5,50+20])
+                Ttyp_tuple
+                [
+                  core_type (test_ct.ml[5,50+11]..test_ct.ml[5,50+14])
+                    Ttyp_constr \"int/1!\"
+                    []
+                  core_type (test_ct.ml[5,50+17]..test_ct.ml[5,50+20])
+                    Ttyp_constr \"int/1!\"
+                    []
+                ]
+            pattern (test_ct.ml[5,50+4]..test_ct.ml[5,50+8])
+              Tpat_var \"foo3/83\"
+          expression (test_ct.ml[5,50+23]..test_ct.ml[5,50+27])
+            Texp_constraint
+            core_type (test_ct.ml[5,50+11]..test_ct.ml[5,50+20])
+              Ttyp_tuple
+              [
+                core_type (test_ct.ml[5,50+11]..test_ct.ml[5,50+14])
+                  Ttyp_constr \"int/1!\"
+                  []
+                core_type (test_ct.ml[5,50+17]..test_ct.ml[5,50+20])
+                  Ttyp_constr \"int/1!\"
+                  []
+              ]
+              Texp_tuple
+              [
+                expression (test_ct.ml[5,50+23]..test_ct.ml[5,50+24])
+                  Texp_constant Const_int 3
+                expression (test_ct.ml[5,50+26]..test_ct.ml[5,50+27])
+                  Texp_constant Const_int 4
+              ]
+      ]
+  ]
+  
+  
+  ",
+    "notifications": []
+  }
diff --git a/tests/test-dirs/with-ppx.t/dune b/tests/test-dirs/with-ppx.t/dune
new file mode 100644
index 0000000..ec67e9d
--- /dev/null
+++ b/tests/test-dirs/with-ppx.t/dune
@@ -0,0 +1,4 @@
+(executable
+ (name main)
+ (preprocess
+  (pps my_ppx)))
diff --git a/tests/test-dirs/with-ppx.t/dune-project b/tests/test-dirs/with-ppx.t/dune-project
new file mode 100644
index 0000000..929c696
--- /dev/null
+++ b/tests/test-dirs/with-ppx.t/dune-project
@@ -0,0 +1 @@
+(lang dune 2.0)
diff --git a/tests/test-dirs/with-ppx.t/rewriter/dune b/tests/test-dirs/with-ppx.t/rewriter/dune
new file mode 100644
index 0000000..fcbdc1e
--- /dev/null
+++ b/tests/test-dirs/with-ppx.t/rewriter/dune
@@ -0,0 +1,4 @@
+(library
+ (name my_ppx)
+ (kind ppx_rewriter)
+ (libraries ppxlib))
diff --git a/tests/test-dirs/with-ppx.t/rewriter/my_ppx.ml b/tests/test-dirs/with-ppx.t/rewriter/my_ppx.ml
new file mode 100644
index 0000000..ded887b
--- /dev/null
+++ b/tests/test-dirs/with-ppx.t/rewriter/my_ppx.ml
@@ -0,0 +1,13 @@
+open Ppxlib
+
+let expand ~ctxt payload =
+  let loc = Expansion_context.Extension.extension_point_loc ctxt in
+  Ast_builder.Default.eint ~loc payload
+
+let my_extension =
+  Extension.V3.declare "get_int" Extension.Context.expression
+    Ast_pattern.(single_expr_payload (eint __))
+    expand
+
+let rule = Ppxlib.Context_free.Rule.extension my_extension
+let () = Driver.register_transformation ~rules:[ rule ] "get_int"
diff --git a/tests/test-dirs/with-ppx.t/run.t b/tests/test-dirs/with-ppx.t/run.t
new file mode 100644
index 0000000..f0db131
--- /dev/null
+++ b/tests/test-dirs/with-ppx.t/run.t
@@ -0,0 +1,32 @@
+The ppx works as expected without any typed-hole:
+  $ cat >main.ml <<EOF
+  > match Some 3 with
+  > | None -> ()
+  > | Some _ -> print_int [%get_int 42]
+  > EOF
+
+  $ dune exec ./main.exe 2>/dev/null
+  42
+
+  $ $MERLIN single errors \
+  > -filename main.ml < main.ml 
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
+
+and with type-holes (since #1503)
+  $ cat >main.ml <<EOF
+  > match Some 3 with
+  > | None -> _
+  > | Some _ -> print_int [%get_int 42]
+  > EOF
+
+  $ $MERLIN single errors \
+  > -filename main.ml < main.ml 
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
diff --git a/upstream/ocaml_411/base-rev.txt b/upstream/ocaml_411/base-rev.txt
new file mode 100644
index 0000000..15dc952
--- /dev/null
+++ b/upstream/ocaml_411/base-rev.txt
@@ -0,0 +1 @@
+936e16805a8c57e1293d90c78ae6786390d00cbf
diff --git a/upstream/ocaml_411/file_formats/cmi_format.ml b/upstream/ocaml_411/file_formats/cmi_format.ml
new file mode 100644
index 0000000..eadf676
--- /dev/null
+++ b/upstream/ocaml_411/file_formats/cmi_format.ml
@@ -0,0 +1,118 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Misc
+
+type pers_flags =
+  | Rectypes
+  | Alerts of alerts
+  | Opaque
+  | Unsafe_string
+
+type error =
+  | Not_an_interface of filepath
+  | Wrong_version_interface of filepath * string
+  | Corrupted_interface of filepath
+
+exception Error of error
+
+(* these type abbreviations are not exported;
+   they are used to provide consistency across
+   input_value and output_value usage. *)
+type signature = Types.signature_item list
+type flags = pers_flags list
+type header = modname * signature
+
+type cmi_infos = {
+    cmi_name : modname;
+    cmi_sign : signature;
+    cmi_crcs : crcs;
+    cmi_flags : flags;
+}
+
+let input_cmi ic =
+  let (name, sign) = (input_value ic : header) in
+  let crcs = (input_value ic : crcs) in
+  let flags = (input_value ic : flags) in
+  {
+      cmi_name = name;
+      cmi_sign = sign;
+      cmi_crcs = crcs;
+      cmi_flags = flags;
+    }
+
+let read_cmi filename =
+  let ic = open_in_bin filename in
+  try
+    let buffer =
+      really_input_string ic (String.length Config.cmi_magic_number)
+    in
+    if buffer <> Config.cmi_magic_number then begin
+      close_in ic;
+      let pre_len = String.length Config.cmi_magic_number - 3 in
+      if String.sub buffer 0 pre_len
+          = String.sub Config.cmi_magic_number 0 pre_len then
+      begin
+        let msg =
+          if buffer < Config.cmi_magic_number then "an older" else "a newer" in
+        raise (Error (Wrong_version_interface (filename, msg)))
+      end else begin
+        raise(Error(Not_an_interface filename))
+      end
+    end;
+    let cmi = input_cmi ic in
+    close_in ic;
+    cmi
+  with End_of_file | Failure _ ->
+      close_in ic;
+      raise(Error(Corrupted_interface(filename)))
+    | Error e ->
+      close_in ic;
+      raise (Error e)
+
+let output_cmi filename oc cmi =
+(* beware: the provided signature must have been substituted for saving *)
+  output_string oc Config.cmi_magic_number;
+  output_value oc ((cmi.cmi_name, cmi.cmi_sign) : header);
+  flush oc;
+  let crc = Digest.file filename in
+  let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in
+  output_value oc (crcs : crcs);
+  output_value oc (cmi.cmi_flags : flags);
+  crc
+
+(* Error report *)
+
+open Format
+
+let report_error ppf = function
+  | Not_an_interface filename ->
+      fprintf ppf "%a@ is not a compiled interface"
+        Location.print_filename filename
+  | Wrong_version_interface (filename, older_newer) ->
+      fprintf ppf
+        "%a@ is not a compiled interface for this version of OCaml.@.\
+         It seems to be for %s version of OCaml."
+        Location.print_filename filename older_newer
+  | Corrupted_interface filename ->
+      fprintf ppf "Corrupted compiled interface@ %a"
+        Location.print_filename filename
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )
diff --git a/upstream/ocaml_411/file_formats/cmi_format.mli b/upstream/ocaml_411/file_formats/cmi_format.mli
new file mode 100644
index 0000000..d4d665f
--- /dev/null
+++ b/upstream/ocaml_411/file_formats/cmi_format.mli
@@ -0,0 +1,51 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Misc
+
+type pers_flags =
+  | Rectypes
+  | Alerts of alerts
+  | Opaque
+  | Unsafe_string
+
+type cmi_infos = {
+    cmi_name : modname;
+    cmi_sign : Types.signature_item list;
+    cmi_crcs : crcs;
+    cmi_flags : pers_flags list;
+}
+
+(* write the magic + the cmi information *)
+val output_cmi : string -> out_channel -> cmi_infos -> Digest.t
+
+(* read the cmi information (the magic is supposed to have already been read) *)
+val input_cmi : in_channel -> cmi_infos
+
+(* read a cmi from a filename, checking the magic *)
+val read_cmi : string -> cmi_infos
+
+(* Error report *)
+
+type error =
+  | Not_an_interface of filepath
+  | Wrong_version_interface of filepath * string
+  | Corrupted_interface of filepath
+
+exception Error of error
+
+open Format
+
+val report_error: formatter -> error -> unit
diff --git a/upstream/ocaml_411/file_formats/cmt_format.ml b/upstream/ocaml_411/file_formats/cmt_format.ml
new file mode 100644
index 0000000..709509a
--- /dev/null
+++ b/upstream/ocaml_411/file_formats/cmt_format.ml
@@ -0,0 +1,194 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Cmi_format
+open Typedtree
+
+(* Note that in Typerex, there is an awful hack to save a cmt file
+   together with the interface file that was generated by ocaml (this
+   is because the installed version of ocaml might differ from the one
+   integrated in Typerex).
+*)
+
+
+
+let read_magic_number ic =
+  let len_magic_number = String.length Config.cmt_magic_number in
+  really_input_string ic len_magic_number
+
+type binary_annots =
+  | Packed of Types.signature * string list
+  | Implementation of structure
+  | Interface of signature
+  | Partial_implementation of binary_part array
+  | Partial_interface of binary_part array
+
+and binary_part =
+| Partial_structure of structure
+| Partial_structure_item of structure_item
+| Partial_expression of expression
+| Partial_pattern : 'k pattern_category * 'k general_pattern -> binary_part
+| Partial_class_expr of class_expr
+| Partial_signature of signature
+| Partial_signature_item of signature_item
+| Partial_module_type of module_type
+
+type cmt_infos = {
+  cmt_modname : string;
+  cmt_annots : binary_annots;
+  cmt_value_dependencies :
+    (Types.value_description * Types.value_description) list;
+  cmt_comments : (string * Location.t) list;
+  cmt_args : string array;
+  cmt_sourcefile : string option;
+  cmt_builddir : string;
+  cmt_loadpath : string list;
+  cmt_source_digest : Digest.t option;
+  cmt_initial_env : Env.t;
+  cmt_imports : (string * Digest.t option) list;
+  cmt_interface_digest : Digest.t option;
+  cmt_use_summaries : bool;
+}
+
+type error =
+    Not_a_typedtree of string
+
+let need_to_clear_env =
+  try ignore (Sys.getenv "OCAML_BINANNOT_WITHENV"); false
+  with Not_found -> true
+
+let keep_only_summary = Env.keep_only_summary
+
+open Tast_mapper
+
+let cenv =
+  {Tast_mapper.default with env = fun _sub env -> keep_only_summary env}
+
+let clear_part = function
+  | Partial_structure s -> Partial_structure (cenv.structure cenv s)
+  | Partial_structure_item s ->
+      Partial_structure_item (cenv.structure_item cenv s)
+  | Partial_expression e -> Partial_expression (cenv.expr cenv e)
+  | Partial_pattern (category, p) -> Partial_pattern (category, cenv.pat cenv p)
+  | Partial_class_expr ce -> Partial_class_expr (cenv.class_expr cenv ce)
+  | Partial_signature s -> Partial_signature (cenv.signature cenv s)
+  | Partial_signature_item s ->
+      Partial_signature_item (cenv.signature_item cenv s)
+  | Partial_module_type s -> Partial_module_type (cenv.module_type cenv s)
+
+let clear_env binary_annots =
+  if need_to_clear_env then
+    match binary_annots with
+    | Implementation s -> Implementation (cenv.structure cenv s)
+    | Interface s -> Interface (cenv.signature cenv s)
+    | Packed _ -> binary_annots
+    | Partial_implementation array ->
+        Partial_implementation (Array.map clear_part array)
+    | Partial_interface array ->
+        Partial_interface (Array.map clear_part array)
+
+  else binary_annots
+
+exception Error of error
+
+let input_cmt ic = (input_value ic : cmt_infos)
+
+let output_cmt oc cmt =
+  output_string oc Config.cmt_magic_number;
+  output_value oc (cmt : cmt_infos)
+
+let read filename =
+(*  Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *)
+  let ic = open_in_bin filename in
+  Misc.try_finally
+    ~always:(fun () -> close_in ic)
+    (fun () ->
+       let magic_number = read_magic_number ic in
+       let cmi, cmt =
+         if magic_number = Config.cmt_magic_number then
+           None, Some (input_cmt ic)
+         else if magic_number = Config.cmi_magic_number then
+           let cmi = Cmi_format.input_cmi ic in
+           let cmt = try
+               let magic_number = read_magic_number ic in
+               if magic_number = Config.cmt_magic_number then
+                 let cmt = input_cmt ic in
+                 Some cmt
+               else None
+             with _ -> None
+           in
+           Some cmi, cmt
+         else
+           raise(Cmi_format.Error(Cmi_format.Not_an_interface filename))
+       in
+       cmi, cmt
+    )
+
+let read_cmt filename =
+  match read filename with
+      _, None -> raise (Error (Not_a_typedtree filename))
+    | _, Some cmt -> cmt
+
+let read_cmi filename =
+  match read filename with
+      None, _ ->
+        raise (Cmi_format.Error (Cmi_format.Not_an_interface filename))
+    | Some cmi, _ -> cmi
+
+let saved_types = ref []
+let value_deps = ref []
+
+let clear () =
+  saved_types := [];
+  value_deps := []
+
+let add_saved_type b = saved_types := b :: !saved_types
+let get_saved_types () = !saved_types
+let set_saved_types l = saved_types := l
+
+let record_value_dependency vd1 vd2 =
+  if vd1.Types.val_loc <> vd2.Types.val_loc then
+    value_deps := (vd1, vd2) :: !value_deps
+
+let save_cmt filename modname binary_annots sourcefile initial_env cmi =
+  if !Clflags.binary_annotations && not !Clflags.print_types then begin
+    Misc.output_to_file_via_temporary
+       ~mode:[Open_binary] filename
+       (fun temp_file_name oc ->
+         let this_crc =
+           match cmi with
+           | None -> None
+           | Some cmi -> Some (output_cmi temp_file_name oc cmi)
+         in
+         let source_digest = Option.map Digest.file sourcefile in
+         let cmt = {
+           cmt_modname = modname;
+           cmt_annots = clear_env binary_annots;
+           cmt_value_dependencies = !value_deps;
+           cmt_comments = Lexer.comments ();
+           cmt_args = Sys.argv;
+           cmt_sourcefile = sourcefile;
+           cmt_builddir = Location.rewrite_absolute_path (Sys.getcwd ());
+           cmt_loadpath = Load_path.get_paths ();
+           cmt_source_digest = source_digest;
+           cmt_initial_env = if need_to_clear_env then
+               keep_only_summary initial_env else initial_env;
+           cmt_imports = List.sort compare (Env.imports ());
+           cmt_interface_digest = this_crc;
+           cmt_use_summaries = need_to_clear_env;
+         } in
+         output_cmt oc cmt)
+  end;
+  clear ()
diff --git a/upstream/ocaml_411/file_formats/cmt_format.mli b/upstream/ocaml_411/file_formats/cmt_format.mli
new file mode 100644
index 0000000..8a52c4b
--- /dev/null
+++ b/upstream/ocaml_411/file_formats/cmt_format.mli
@@ -0,0 +1,123 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** cmt and cmti files format. *)
+
+open Misc
+
+(** The layout of a cmt file is as follows:
+      <cmt> := \{<cmi>\} <cmt magic> \{cmt infos\} \{<source info>\}
+    where <cmi> is the cmi file format:
+      <cmi> := <cmi magic> <cmi info>.
+    More precisely, the optional <cmi> part must be present if and only if
+    the file is:
+    - a cmti, or
+    - a cmt, for a ml file which has no corresponding mli (hence no
+    corresponding cmti).
+
+    Thus, we provide a common reading function for cmi and cmt(i)
+    files which returns an option for each of the three parts: cmi
+    info, cmt info, source info. *)
+
+open Typedtree
+
+type binary_annots =
+  | Packed of Types.signature * string list
+  | Implementation of structure
+  | Interface of signature
+  | Partial_implementation of binary_part array
+  | Partial_interface of binary_part array
+
+and binary_part =
+  | Partial_structure of structure
+  | Partial_structure_item of structure_item
+  | Partial_expression of expression
+  | Partial_pattern : 'k pattern_category * 'k general_pattern -> binary_part
+  | Partial_class_expr of class_expr
+  | Partial_signature of signature
+  | Partial_signature_item of signature_item
+  | Partial_module_type of module_type
+
+type cmt_infos = {
+  cmt_modname : modname;
+  cmt_annots : binary_annots;
+  cmt_value_dependencies :
+    (Types.value_description * Types.value_description) list;
+  cmt_comments : (string * Location.t) list;
+  cmt_args : string array;
+  cmt_sourcefile : string option;
+  cmt_builddir : string;
+  cmt_loadpath : string list;
+  cmt_source_digest : string option;
+  cmt_initial_env : Env.t;
+  cmt_imports : crcs;
+  cmt_interface_digest : Digest.t option;
+  cmt_use_summaries : bool;
+}
+
+type error =
+    Not_a_typedtree of string
+
+exception Error of error
+
+(** [read filename] opens filename, and extract both the cmi_infos, if
+    it exists, and the cmt_infos, if it exists. Thus, it can be used
+    with .cmi, .cmt and .cmti files.
+
+    .cmti files always contain a cmi_infos at the beginning. .cmt files
+    only contain a cmi_infos at the beginning if there is no associated
+    .cmti file.
+*)
+val read : string -> Cmi_format.cmi_infos option * cmt_infos option
+
+val read_cmt : string -> cmt_infos
+val read_cmi : string -> Cmi_format.cmi_infos
+
+(** [save_cmt filename modname binary_annots sourcefile initial_env cmi]
+    writes a cmt(i) file.  *)
+val save_cmt :
+  string ->  (* filename.cmt to generate *)
+  string ->  (* module name *)
+  binary_annots ->
+  string option ->  (* source file *)
+  Env.t -> (* initial env *)
+  Cmi_format.cmi_infos option -> (* if a .cmi was generated *)
+  unit
+
+(* Miscellaneous functions *)
+
+val read_magic_number : in_channel -> string
+
+val clear: unit -> unit
+
+val add_saved_type : binary_part -> unit
+val get_saved_types : unit -> binary_part list
+val set_saved_types : binary_part list -> unit
+
+val record_value_dependency:
+  Types.value_description -> Types.value_description -> unit
+
+
+(*
+
+  val is_magic_number : string -> bool
+  val read : in_channel -> Env.cmi_infos option * t
+  val write_magic_number : out_channel -> unit
+  val write : out_channel -> t -> unit
+
+  val find : string list -> string -> string
+  val read_signature : 'a -> string -> Types.signature * 'b list * 'c list
+
+*)
diff --git a/upstream/ocaml_411/parsing/ast_helper.ml b/upstream/ocaml_411/parsing/ast_helper.ml
new file mode 100644
index 0000000..2d51dda
--- /dev/null
+++ b/upstream/ocaml_411/parsing/ast_helper.ml
@@ -0,0 +1,642 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Helpers to produce Parsetree fragments *)
+
+open Asttypes
+open Parsetree
+open Docstrings
+
+type 'a with_loc = 'a Location.loc
+type loc = Location.t
+
+type lid = Longident.t with_loc
+type str = string with_loc
+type str_opt = string option with_loc
+type attrs = attribute list
+
+let default_loc = ref Location.none
+
+let with_default_loc l f =
+  Misc.protect_refs [Misc.R (default_loc, l)] f
+
+module Const = struct
+  let integer ?suffix i = Pconst_integer (i, suffix)
+  let int ?suffix i = integer ?suffix (Int.to_string i)
+  let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i)
+  let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i)
+  let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i)
+  let float ?suffix f = Pconst_float (f, suffix)
+  let char c = Pconst_char c
+  let string ?quotation_delimiter ?(loc= !default_loc) s =
+    Pconst_string (s, loc, quotation_delimiter)
+end
+
+module Attr = struct
+  let mk ?(loc= !default_loc) name payload =
+    { attr_name = name;
+      attr_payload = payload;
+      attr_loc = loc }
+end
+
+module Typ = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {ptyp_desc = d;
+     ptyp_loc = loc;
+     ptyp_loc_stack = [];
+     ptyp_attributes = attrs}
+
+  let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]}
+
+  let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any
+  let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a)
+  let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c))
+  let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a)
+  let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b))
+  let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b))
+  let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b))
+  let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b))
+  let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c))
+  let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b))
+  let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b))
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a)
+
+  let force_poly t =
+    match t.ptyp_desc with
+    | Ptyp_poly _ -> t
+    | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *)
+
+  let varify_constructors var_names t =
+    let check_variable vl loc v =
+      if List.mem v vl then
+        raise Syntaxerr.(Error(Variable_in_scope(loc,v))) in
+    let var_names = List.map (fun v -> v.txt) var_names in
+    let rec loop t =
+      let desc =
+        match t.ptyp_desc with
+        | Ptyp_any -> Ptyp_any
+        | Ptyp_var x ->
+            check_variable var_names t.ptyp_loc x;
+            Ptyp_var x
+        | Ptyp_arrow (label,core_type,core_type') ->
+            Ptyp_arrow(label, loop core_type, loop core_type')
+        | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst)
+        | Ptyp_constr( { txt = Longident.Lident s }, [])
+          when List.mem s var_names ->
+            Ptyp_var s
+        | Ptyp_constr(longident, lst) ->
+            Ptyp_constr(longident, List.map loop lst)
+        | Ptyp_object (lst, o) ->
+            Ptyp_object (List.map loop_object_field lst, o)
+        | Ptyp_class (longident, lst) ->
+            Ptyp_class (longident, List.map loop lst)
+        | Ptyp_alias(core_type, string) ->
+            check_variable var_names t.ptyp_loc string;
+            Ptyp_alias(loop core_type, string)
+        | Ptyp_variant(row_field_list, flag, lbl_lst_option) ->
+            Ptyp_variant(List.map loop_row_field row_field_list,
+                         flag, lbl_lst_option)
+        | Ptyp_poly(string_lst, core_type) ->
+          List.iter (fun v ->
+            check_variable var_names t.ptyp_loc v.txt) string_lst;
+            Ptyp_poly(string_lst, loop core_type)
+        | Ptyp_package(longident,lst) ->
+            Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst)
+        | Ptyp_extension (s, arg) ->
+            Ptyp_extension (s, arg)
+      in
+      {t with ptyp_desc = desc}
+    and loop_row_field field =
+      let prf_desc = match field.prf_desc with
+        | Rtag(label,flag,lst) ->
+            Rtag(label,flag,List.map loop lst)
+        | Rinherit t ->
+            Rinherit (loop t)
+      in
+      { field with prf_desc; }
+    and loop_object_field field =
+      let pof_desc = match field.pof_desc with
+        | Otag(label, t) ->
+            Otag(label, loop t)
+        | Oinherit t ->
+            Oinherit (loop t)
+      in
+      { field with pof_desc; }
+    in
+    loop t
+
+end
+
+module Pat = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {ppat_desc = d;
+     ppat_loc = loc;
+     ppat_loc_stack = [];
+     ppat_attributes = attrs}
+  let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]}
+
+  let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any
+  let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a)
+  let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b))
+  let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a)
+  let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b))
+  let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a)
+  let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b))
+  let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b))
+  let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b))
+  let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a)
+  let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b))
+  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b))
+  let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a)
+  let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a)
+  let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a)
+  let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b))
+  let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a)
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a)
+end
+
+module Exp = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {pexp_desc = d;
+     pexp_loc = loc;
+     pexp_loc_stack = [];
+     pexp_attributes = attrs}
+  let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]}
+
+  let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a)
+  let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a)
+  let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c))
+  let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d))
+  let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a)
+  let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b))
+  let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b))
+  let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b))
+  let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a)
+  let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b))
+  let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b))
+  let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b))
+  let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b))
+  let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c))
+  let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a)
+  let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c))
+  let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b))
+  let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b))
+  let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e))
+  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b))
+  let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c))
+  let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b))
+  let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a)
+  let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b))
+  let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a)
+  let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c))
+  let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b))
+  let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a)
+  let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a)
+  let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b))
+  let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a)
+  let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b))
+  let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a)
+  let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_open (a, b))
+  let letop ?loc ?attrs let_ ands body =
+    mk ?loc ?attrs (Pexp_letop {let_; ands; body})
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a)
+  let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable
+
+  let case lhs ?guard rhs =
+    {
+     pc_lhs = lhs;
+     pc_guard = guard;
+     pc_rhs = rhs;
+    }
+
+  let binding_op op pat exp loc =
+    {
+      pbop_op = op;
+      pbop_pat = pat;
+      pbop_exp = exp;
+      pbop_loc = loc;
+    }
+end
+
+module Mty = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs}
+  let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]}
+
+  let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a)
+  let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a)
+  let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a)
+  let functor_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_functor (a, b))
+  let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b))
+  let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a)
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a)
+end
+
+module Mod = struct
+let mk ?(loc = !default_loc) ?(attrs = []) d =
+  {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs}
+  let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]}
+
+  let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x)
+  let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x)
+  let functor_ ?loc ?attrs arg body =
+    mk ?loc ?attrs (Pmod_functor (arg, body))
+  let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2))
+  let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty))
+  let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e)
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a)
+end
+
+module Sig = struct
+  let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc}
+
+  let value ?loc a = mk ?loc (Psig_value a)
+  let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a))
+  let type_subst ?loc a = mk ?loc (Psig_typesubst a)
+  let type_extension ?loc a = mk ?loc (Psig_typext a)
+  let exception_ ?loc a = mk ?loc (Psig_exception a)
+  let module_ ?loc a = mk ?loc (Psig_module a)
+  let mod_subst ?loc a = mk ?loc (Psig_modsubst a)
+  let rec_module ?loc a = mk ?loc (Psig_recmodule a)
+  let modtype ?loc a = mk ?loc (Psig_modtype a)
+  let open_ ?loc a = mk ?loc (Psig_open a)
+  let include_ ?loc a = mk ?loc (Psig_include a)
+  let class_ ?loc a = mk ?loc (Psig_class a)
+  let class_type ?loc a = mk ?loc (Psig_class_type a)
+  let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs))
+  let attribute ?loc a = mk ?loc (Psig_attribute a)
+  let text txt =
+    let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
+    List.map
+      (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
+      f_txt
+end
+
+module Str = struct
+  let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc}
+
+  let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs))
+  let value ?loc a b = mk ?loc (Pstr_value (a, b))
+  let primitive ?loc a = mk ?loc (Pstr_primitive a)
+  let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a))
+  let type_extension ?loc a = mk ?loc (Pstr_typext a)
+  let exception_ ?loc a = mk ?loc (Pstr_exception a)
+  let module_ ?loc a = mk ?loc (Pstr_module a)
+  let rec_module ?loc a = mk ?loc (Pstr_recmodule a)
+  let modtype ?loc a = mk ?loc (Pstr_modtype a)
+  let open_ ?loc a = mk ?loc (Pstr_open a)
+  let class_ ?loc a = mk ?loc (Pstr_class a)
+  let class_type ?loc a = mk ?loc (Pstr_class_type a)
+  let include_ ?loc a = mk ?loc (Pstr_include a)
+  let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs))
+  let attribute ?loc a = mk ?loc (Pstr_attribute a)
+  let text txt =
+    let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
+    List.map
+      (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
+      f_txt
+end
+
+module Cl = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {
+     pcl_desc = d;
+     pcl_loc = loc;
+     pcl_attributes = attrs;
+    }
+  let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]}
+
+  let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b))
+  let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a)
+  let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d))
+  let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b))
+  let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c))
+  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b))
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a)
+  let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_open (a, b))
+end
+
+module Cty = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {
+     pcty_desc = d;
+     pcty_loc = loc;
+     pcty_attributes = attrs;
+    }
+  let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]}
+
+  let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b))
+  let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a)
+  let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c))
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a)
+  let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcty_open (a, b))
+end
+
+module Ctf = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+           ?(docs = empty_docs) d =
+    {
+     pctf_desc = d;
+     pctf_loc = loc;
+     pctf_attributes = add_docs_attrs docs attrs;
+    }
+
+  let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a)
+  let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d))
+  let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d))
+  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b))
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a)
+  let attribute ?loc a = mk ?loc (Pctf_attribute a)
+  let text txt =
+   let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
+     List.map
+      (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
+      f_txt
+
+  let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]}
+
+end
+
+module Cf = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) d =
+    {
+     pcf_desc = d;
+     pcf_loc = loc;
+     pcf_attributes = add_docs_attrs docs attrs;
+    }
+
+  let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c))
+  let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c))
+  let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c))
+  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b))
+  let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a)
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a)
+  let attribute ?loc a = mk ?loc (Pcf_attribute a)
+  let text txt =
+    let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
+    List.map
+      (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
+      f_txt
+
+  let virtual_ ct = Cfk_virtual ct
+  let concrete o e = Cfk_concrete (o, e)
+
+  let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]}
+
+end
+
+module Val = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+        ?(prim = []) name typ =
+    {
+     pval_name = name;
+     pval_type = typ;
+     pval_attributes = add_docs_attrs docs attrs;
+     pval_loc = loc;
+     pval_prim = prim;
+    }
+end
+
+module Md = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = []) name typ =
+    {
+     pmd_name = name;
+     pmd_type = typ;
+     pmd_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pmd_loc = loc;
+    }
+end
+
+module Ms = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = []) name syn =
+    {
+     pms_name = name;
+     pms_manifest = syn;
+     pms_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pms_loc = loc;
+    }
+end
+
+module Mtd = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = []) ?typ name =
+    {
+     pmtd_name = name;
+     pmtd_type = typ;
+     pmtd_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pmtd_loc = loc;
+    }
+end
+
+module Mb = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = []) name expr =
+    {
+     pmb_name = name;
+     pmb_expr = expr;
+     pmb_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pmb_loc = loc;
+    }
+end
+
+module Opn = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+        ?(override = Fresh) expr =
+    {
+     popen_expr = expr;
+     popen_override = override;
+     popen_loc = loc;
+     popen_attributes = add_docs_attrs docs attrs;
+    }
+end
+
+module Incl = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr =
+    {
+     pincl_mod = mexpr;
+     pincl_loc = loc;
+     pincl_attributes = add_docs_attrs docs attrs;
+    }
+
+end
+
+module Vb = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+        ?(text = []) pat expr =
+    {
+     pvb_pat = pat;
+     pvb_expr = expr;
+     pvb_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pvb_loc = loc;
+    }
+end
+
+module Ci = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = [])
+        ?(virt = Concrete) ?(params = []) name expr =
+    {
+     pci_virt = virt;
+     pci_params = params;
+     pci_name = name;
+     pci_expr = expr;
+     pci_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pci_loc = loc;
+    }
+end
+
+module Type = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = [])
+      ?(params = [])
+      ?(cstrs = [])
+      ?(kind = Ptype_abstract)
+      ?(priv = Public)
+      ?manifest
+      name =
+    {
+     ptype_name = name;
+     ptype_params = params;
+     ptype_cstrs = cstrs;
+     ptype_kind = kind;
+     ptype_private = priv;
+     ptype_manifest = manifest;
+     ptype_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     ptype_loc = loc;
+    }
+
+  let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info)
+        ?(args = Pcstr_tuple []) ?res name =
+    {
+     pcd_name = name;
+     pcd_args = args;
+     pcd_res = res;
+     pcd_loc = loc;
+     pcd_attributes = add_info_attrs info attrs;
+    }
+
+  let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info)
+        ?(mut = Immutable) name typ =
+    {
+     pld_name = name;
+     pld_mutable = mut;
+     pld_type = typ;
+     pld_loc = loc;
+     pld_attributes = add_info_attrs info attrs;
+    }
+
+end
+
+(** Type extensions *)
+module Te = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+        ?(params = []) ?(priv = Public) path constructors =
+    {
+     ptyext_path = path;
+     ptyext_params = params;
+     ptyext_constructors = constructors;
+     ptyext_private = priv;
+     ptyext_loc = loc;
+     ptyext_attributes = add_docs_attrs docs attrs;
+    }
+
+  let mk_exception ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+      constructor =
+    {
+     ptyexn_constructor = constructor;
+     ptyexn_loc = loc;
+     ptyexn_attributes = add_docs_attrs docs attrs;
+    }
+
+  let constructor ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(info = empty_info) name kind =
+    {
+     pext_name = name;
+     pext_kind = kind;
+     pext_loc = loc;
+     pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
+    }
+
+  let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+             ?(info = empty_info) ?(args = Pcstr_tuple []) ?res name =
+    {
+     pext_name = name;
+     pext_kind = Pext_decl(args, res);
+     pext_loc = loc;
+     pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
+    }
+
+  let rebind ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(info = empty_info) name lid =
+    {
+     pext_name = name;
+     pext_kind = Pext_rebind lid;
+     pext_loc = loc;
+     pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
+    }
+
+end
+
+module Csig = struct
+  let mk self fields =
+    {
+     pcsig_self = self;
+     pcsig_fields = fields;
+    }
+end
+
+module Cstr = struct
+  let mk self fields =
+    {
+     pcstr_self = self;
+     pcstr_fields = fields;
+    }
+end
+
+(** Row fields *)
+module Rf = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) desc = {
+    prf_desc = desc;
+    prf_loc = loc;
+    prf_attributes = attrs;
+  }
+  let tag ?loc ?attrs label const tys =
+    mk ?loc ?attrs (Rtag (label, const, tys))
+  let inherit_?loc ty =
+    mk ?loc (Rinherit ty)
+end
+
+(** Object fields *)
+module Of = struct
+  let mk ?(loc = !default_loc) ?(attrs=[]) desc = {
+    pof_desc = desc;
+    pof_loc = loc;
+    pof_attributes = attrs;
+  }
+  let tag ?loc ?attrs label ty =
+    mk ?loc ?attrs (Otag (label, ty))
+  let inherit_ ?loc ty =
+    mk ?loc (Oinherit ty)
+end
diff --git a/upstream/ocaml_411/parsing/ast_helper.mli b/upstream/ocaml_411/parsing/ast_helper.mli
new file mode 100644
index 0000000..330f68e
--- /dev/null
+++ b/upstream/ocaml_411/parsing/ast_helper.mli
@@ -0,0 +1,490 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Helpers to produce Parsetree fragments
+
+  {b Warning} This module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Asttypes
+open Docstrings
+open Parsetree
+
+type 'a with_loc = 'a Location.loc
+type loc = Location.t
+
+type lid = Longident.t with_loc
+type str = string with_loc
+type str_opt = string option with_loc
+type attrs = attribute list
+
+(** {1 Default locations} *)
+
+val default_loc: loc ref
+    (** Default value for all optional location arguments. *)
+
+val with_default_loc: loc -> (unit -> 'a) -> 'a
+    (** Set the [default_loc] within the scope of the execution
+        of the provided function. *)
+
+(** {1 Constants} *)
+
+module Const : sig
+  val char : char -> constant
+  val string :
+    ?quotation_delimiter:string -> ?loc:Location.t -> string -> constant
+  val integer : ?suffix:char -> string -> constant
+  val int : ?suffix:char -> int -> constant
+  val int32 : ?suffix:char -> int32 -> constant
+  val int64 : ?suffix:char -> int64 -> constant
+  val nativeint : ?suffix:char -> nativeint -> constant
+  val float : ?suffix:char -> string -> constant
+end
+
+(** {1 Attributes} *)
+module Attr : sig
+  val mk: ?loc:loc -> str -> payload -> attribute
+end
+
+(** {1 Core language} *)
+
+(** Type expressions *)
+module Typ :
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type
+    val attr: core_type -> attribute -> core_type
+
+    val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type
+    val var: ?loc:loc -> ?attrs:attrs -> string -> core_type
+    val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type
+               -> core_type
+    val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type
+    val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
+    val object_: ?loc:loc -> ?attrs:attrs -> object_field list
+                   -> closed_flag -> core_type
+    val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
+    val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type
+    val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag
+                 -> label list option -> core_type
+    val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type
+    val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list
+                 -> core_type
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type
+
+    val force_poly: core_type -> core_type
+
+    val varify_constructors: str list -> core_type -> core_type
+    (** [varify_constructors newtypes te] is type expression [te], of which
+        any of nullary type constructor [tc] is replaced by type variable of
+        the same name, if [tc]'s name appears in [newtypes].
+        Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te]
+        appears in [newtypes].
+        @since 4.05
+     *)
+  end
+
+(** Patterns *)
+module Pat:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern
+    val attr:pattern -> attribute -> pattern
+
+    val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern
+    val var: ?loc:loc -> ?attrs:attrs -> str -> pattern
+    val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern
+    val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern
+    val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern
+    val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern
+    val construct: ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern
+    val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern
+    val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag
+                -> pattern
+    val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern
+    val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern
+    val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern
+    val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern
+    val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern
+    val unpack: ?loc:loc -> ?attrs:attrs -> str_opt -> pattern
+    val open_: ?loc:loc -> ?attrs:attrs  -> lid -> pattern -> pattern
+    val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern
+  end
+
+(** Expressions *)
+module Exp:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression
+    val attr: expression -> attribute -> expression
+
+    val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression
+    val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression
+    val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list
+              -> expression -> expression
+    val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option
+              -> pattern -> expression -> expression
+    val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression
+    val apply: ?loc:loc -> ?attrs:attrs -> expression
+               -> (arg_label * expression) list -> expression
+    val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list
+                -> expression
+    val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression
+    val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression
+    val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option
+                   -> expression
+    val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option
+                 -> expression
+    val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list
+                -> expression option -> expression
+    val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression
+    val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression
+                  -> expression
+    val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression
+    val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression
+                    -> expression option -> expression
+    val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression
+                  -> expression
+    val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression
+                -> expression
+    val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression
+              -> direction_flag -> expression -> expression
+    val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option
+                -> core_type -> expression
+    val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type
+                     -> expression
+    val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression
+    val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression
+    val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression
+    val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list
+                  -> expression
+    val letmodule: ?loc:loc -> ?attrs:attrs -> str_opt -> module_expr
+                   -> expression -> expression
+    val letexception:
+      ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression
+      -> expression
+    val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression
+    val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression
+    val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option
+              -> expression
+    val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression
+    val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression
+    val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression
+    val open_: ?loc:loc -> ?attrs:attrs -> open_declaration -> expression
+               -> expression
+    val letop: ?loc:loc -> ?attrs:attrs -> binding_op
+               -> binding_op list -> expression -> expression
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression
+    val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression
+
+    val case: pattern -> ?guard:expression -> expression -> case
+    val binding_op: str -> pattern -> expression -> loc -> binding_op
+  end
+
+(** Value declarations *)
+module Val:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
+      ?prim:string list -> str -> core_type -> value_description
+  end
+
+(** Type declarations *)
+module Type:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      ?params:(core_type * variance) list ->
+      ?cstrs:(core_type * core_type * loc) list ->
+      ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str ->
+      type_declaration
+
+    val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info ->
+      ?args:constructor_arguments -> ?res:core_type -> str ->
+      constructor_declaration
+    val field: ?loc:loc -> ?attrs:attrs -> ?info:info ->
+      ?mut:mutable_flag -> str -> core_type -> label_declaration
+  end
+
+(** Type extensions *)
+module Te:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
+      ?params:(core_type * variance) list -> ?priv:private_flag ->
+      lid -> extension_constructor list -> type_extension
+
+    val mk_exception: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
+      extension_constructor -> type_exception
+
+    val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
+      str -> extension_constructor_kind -> extension_constructor
+
+    val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
+      ?args:constructor_arguments -> ?res:core_type -> str ->
+      extension_constructor
+    val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
+      str -> lid -> extension_constructor
+  end
+
+(** {1 Module language} *)
+
+(** Module type expressions *)
+module Mty:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type
+    val attr: module_type -> attribute -> module_type
+
+    val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type
+    val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type
+    val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type
+    val functor_: ?loc:loc -> ?attrs:attrs ->
+      functor_parameter -> module_type -> module_type
+    val with_: ?loc:loc -> ?attrs:attrs -> module_type ->
+      with_constraint list -> module_type
+    val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type
+  end
+
+(** Module expressions *)
+module Mod:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr
+    val attr: module_expr -> attribute -> module_expr
+
+    val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr
+    val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr
+    val functor_: ?loc:loc -> ?attrs:attrs ->
+      functor_parameter -> module_expr -> module_expr
+    val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr ->
+      module_expr
+    val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type ->
+      module_expr
+    val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr
+  end
+
+(** Signature items *)
+module Sig:
+  sig
+    val mk: ?loc:loc -> signature_item_desc -> signature_item
+
+    val value: ?loc:loc -> value_description -> signature_item
+    val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item
+    val type_subst: ?loc:loc -> type_declaration list -> signature_item
+    val type_extension: ?loc:loc -> type_extension -> signature_item
+    val exception_: ?loc:loc -> type_exception -> signature_item
+    val module_: ?loc:loc -> module_declaration -> signature_item
+    val mod_subst: ?loc:loc -> module_substitution -> signature_item
+    val rec_module: ?loc:loc -> module_declaration list -> signature_item
+    val modtype: ?loc:loc -> module_type_declaration -> signature_item
+    val open_: ?loc:loc -> open_description -> signature_item
+    val include_: ?loc:loc -> include_description -> signature_item
+    val class_: ?loc:loc -> class_description list -> signature_item
+    val class_type: ?loc:loc -> class_type_declaration list -> signature_item
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item
+    val attribute: ?loc:loc -> attribute -> signature_item
+    val text: text -> signature_item list
+  end
+
+(** Structure items *)
+module Str:
+  sig
+    val mk: ?loc:loc -> structure_item_desc -> structure_item
+
+    val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item
+    val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item
+    val primitive: ?loc:loc -> value_description -> structure_item
+    val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item
+    val type_extension: ?loc:loc -> type_extension -> structure_item
+    val exception_: ?loc:loc -> type_exception -> structure_item
+    val module_: ?loc:loc -> module_binding -> structure_item
+    val rec_module: ?loc:loc -> module_binding list -> structure_item
+    val modtype: ?loc:loc -> module_type_declaration -> structure_item
+    val open_: ?loc:loc -> open_declaration -> structure_item
+    val class_: ?loc:loc -> class_declaration list -> structure_item
+    val class_type: ?loc:loc -> class_type_declaration list -> structure_item
+    val include_: ?loc:loc -> include_declaration -> structure_item
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item
+    val attribute: ?loc:loc -> attribute -> structure_item
+    val text: text -> structure_item list
+  end
+
+(** Module declarations *)
+module Md:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      str_opt -> module_type -> module_declaration
+  end
+
+(** Module substitutions *)
+module Ms:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      str -> lid -> module_substitution
+  end
+
+(** Module type declarations *)
+module Mtd:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      ?typ:module_type -> str -> module_type_declaration
+  end
+
+(** Module bindings *)
+module Mb:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      str_opt -> module_expr -> module_binding
+  end
+
+(** Opens *)
+module Opn:
+  sig
+    val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs ->
+      ?override:override_flag -> 'a -> 'a open_infos
+  end
+
+(** Includes *)
+module Incl:
+  sig
+    val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos
+  end
+
+(** Value bindings *)
+module Vb:
+  sig
+    val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      pattern -> expression -> value_binding
+  end
+
+
+(** {1 Class language} *)
+
+(** Class type expressions *)
+module Cty:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type
+    val attr: class_type -> attribute -> class_type
+
+    val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type
+    val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type
+    val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type ->
+      class_type -> class_type
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type
+    val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_type
+               -> class_type
+  end
+
+(** Class type fields *)
+module Ctf:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
+      class_type_field_desc -> class_type_field
+    val attr: class_type_field -> attribute -> class_type_field
+
+    val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field
+    val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag ->
+      virtual_flag -> core_type -> class_type_field
+    val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag ->
+      virtual_flag -> core_type -> class_type_field
+    val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type ->
+      class_type_field
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field
+    val attribute: ?loc:loc -> attribute -> class_type_field
+    val text: text -> class_type_field list
+  end
+
+(** Class expressions *)
+module Cl:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr
+    val attr: class_expr -> attribute -> class_expr
+
+    val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr
+    val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr
+    val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option ->
+      pattern -> class_expr -> class_expr
+    val apply: ?loc:loc -> ?attrs:attrs -> class_expr ->
+      (arg_label * expression) list -> class_expr
+    val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list ->
+      class_expr -> class_expr
+    val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type ->
+      class_expr
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr
+    val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_expr
+               -> class_expr
+  end
+
+(** Class fields *)
+module Cf:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc ->
+      class_field
+    val attr: class_field -> attribute -> class_field
+
+    val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr ->
+      str option -> class_field
+    val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag ->
+      class_field_kind -> class_field
+    val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag ->
+      class_field_kind -> class_field
+    val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type ->
+      class_field
+    val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field
+    val attribute: ?loc:loc -> attribute -> class_field
+    val text: text -> class_field list
+
+    val virtual_: core_type -> class_field_kind
+    val concrete: override_flag -> expression -> class_field_kind
+
+  end
+
+(** Classes *)
+module Ci:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      ?virt:virtual_flag -> ?params:(core_type * variance) list ->
+      str -> 'a -> 'a class_infos
+  end
+
+(** Class signatures *)
+module Csig:
+  sig
+    val mk: core_type -> class_type_field list -> class_signature
+  end
+
+(** Class structures *)
+module Cstr:
+  sig
+    val mk: pattern -> class_field list -> class_structure
+  end
+
+(** Row fields *)
+module Rf:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> row_field_desc -> row_field
+    val tag: ?loc:loc -> ?attrs:attrs ->
+      label with_loc -> bool -> core_type list -> row_field
+    val inherit_: ?loc:loc -> core_type -> row_field
+  end
+
+(** Object fields *)
+module Of:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs ->
+      object_field_desc -> object_field
+    val tag: ?loc:loc -> ?attrs:attrs ->
+      label with_loc -> core_type -> object_field
+    val inherit_: ?loc:loc -> core_type -> object_field
+  end
diff --git a/upstream/ocaml_411/parsing/ast_iterator.ml b/upstream/ocaml_411/parsing/ast_iterator.ml
new file mode 100644
index 0000000..5f016c0
--- /dev/null
+++ b/upstream/ocaml_411/parsing/ast_iterator.ml
@@ -0,0 +1,673 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Nicolas Ojeda Bar, LexiFi                         *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* A generic Parsetree mapping class *)
+
+(*
+[@@@ocaml.warning "+9"]
+  (* Ensure that record patterns don't miss any field. *)
+*)
+
+
+open Parsetree
+open Location
+
+type iterator = {
+  attribute: iterator -> attribute -> unit;
+  attributes: iterator -> attribute list -> unit;
+  binding_op: iterator -> binding_op -> unit;
+  case: iterator -> case -> unit;
+  cases: iterator -> case list -> unit;
+  class_declaration: iterator -> class_declaration -> unit;
+  class_description: iterator -> class_description -> unit;
+  class_expr: iterator -> class_expr -> unit;
+  class_field: iterator -> class_field -> unit;
+  class_signature: iterator -> class_signature -> unit;
+  class_structure: iterator -> class_structure -> unit;
+  class_type: iterator -> class_type -> unit;
+  class_type_declaration: iterator -> class_type_declaration -> unit;
+  class_type_field: iterator -> class_type_field -> unit;
+  constructor_declaration: iterator -> constructor_declaration -> unit;
+  expr: iterator -> expression -> unit;
+  extension: iterator -> extension -> unit;
+  extension_constructor: iterator -> extension_constructor -> unit;
+  include_declaration: iterator -> include_declaration -> unit;
+  include_description: iterator -> include_description -> unit;
+  label_declaration: iterator -> label_declaration -> unit;
+  location: iterator -> Location.t -> unit;
+  module_binding: iterator -> module_binding -> unit;
+  module_declaration: iterator -> module_declaration -> unit;
+  module_substitution: iterator -> module_substitution -> unit;
+  module_expr: iterator -> module_expr -> unit;
+  module_type: iterator -> module_type -> unit;
+  module_type_declaration: iterator -> module_type_declaration -> unit;
+  open_declaration: iterator -> open_declaration -> unit;
+  open_description: iterator -> open_description -> unit;
+  pat: iterator -> pattern -> unit;
+  payload: iterator -> payload -> unit;
+  signature: iterator -> signature -> unit;
+  signature_item: iterator -> signature_item -> unit;
+  structure: iterator -> structure -> unit;
+  structure_item: iterator -> structure_item -> unit;
+  typ: iterator -> core_type -> unit;
+  row_field: iterator -> row_field -> unit;
+  object_field: iterator -> object_field -> unit;
+  type_declaration: iterator -> type_declaration -> unit;
+  type_extension: iterator -> type_extension -> unit;
+  type_exception: iterator -> type_exception -> unit;
+  type_kind: iterator -> type_kind -> unit;
+  value_binding: iterator -> value_binding -> unit;
+  value_description: iterator -> value_description -> unit;
+  with_constraint: iterator -> with_constraint -> unit;
+}
+(** A [iterator] record implements one "method" per syntactic category,
+    using an open recursion style: each method takes as its first
+    argument the iterator to be applied to children in the syntax
+    tree. *)
+
+let iter_fst f (x, _) = f x
+let iter_snd f (_, y) = f y
+let iter_tuple f1 f2 (x, y) = f1 x; f2 y
+let iter_tuple3 f1 f2 f3 (x, y, z) = f1 x; f2 y; f3 z
+let iter_opt f = function None -> () | Some x -> f x
+
+let iter_loc sub {loc; txt = _} = sub.location sub loc
+
+module T = struct
+  (* Type expressions for the core language *)
+
+  let row_field sub {
+      prf_desc;
+      prf_loc;
+      prf_attributes;
+    } =
+    sub.location sub prf_loc;
+    sub.attributes sub prf_attributes;
+    match prf_desc with
+    | Rtag (_, _, tl) -> List.iter (sub.typ sub) tl
+    | Rinherit t -> sub.typ sub t
+
+  let object_field sub {
+      pof_desc;
+      pof_loc;
+      pof_attributes;
+    } =
+    sub.location sub pof_loc;
+    sub.attributes sub pof_attributes;
+    match pof_desc with
+    | Otag (_, t) -> sub.typ sub t
+    | Oinherit t -> sub.typ sub t
+
+  let iter sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Ptyp_any
+    | Ptyp_var _ -> ()
+    | Ptyp_arrow (_lab, t1, t2) ->
+        sub.typ sub t1; sub.typ sub t2
+    | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl
+    | Ptyp_constr (lid, tl) ->
+        iter_loc sub lid; List.iter (sub.typ sub) tl
+    | Ptyp_object (ol, _o) ->
+        List.iter (object_field sub) ol
+    | Ptyp_class (lid, tl) ->
+        iter_loc sub lid; List.iter (sub.typ sub) tl
+    | Ptyp_alias (t, _) -> sub.typ sub t
+    | Ptyp_variant (rl, _b, _ll) ->
+        List.iter (row_field sub) rl
+    | Ptyp_poly (_, t) -> sub.typ sub t
+    | Ptyp_package (lid, l) ->
+        iter_loc sub lid;
+        List.iter (iter_tuple (iter_loc sub) (sub.typ sub)) l
+    | Ptyp_extension x -> sub.extension sub x
+
+  let iter_type_declaration sub
+      {ptype_name; ptype_params; ptype_cstrs;
+       ptype_kind;
+       ptype_private = _;
+       ptype_manifest;
+       ptype_attributes;
+       ptype_loc} =
+    iter_loc sub ptype_name;
+    List.iter (iter_fst (sub.typ sub)) ptype_params;
+    List.iter
+      (iter_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub))
+      ptype_cstrs;
+    sub.type_kind sub ptype_kind;
+    iter_opt (sub.typ sub) ptype_manifest;
+    sub.location sub ptype_loc;
+    sub.attributes sub ptype_attributes
+
+  let iter_type_kind sub = function
+    | Ptype_abstract -> ()
+    | Ptype_variant l ->
+        List.iter (sub.constructor_declaration sub) l
+    | Ptype_record l -> List.iter (sub.label_declaration sub) l
+    | Ptype_open -> ()
+
+  let iter_constructor_arguments sub = function
+    | Pcstr_tuple l -> List.iter (sub.typ sub) l
+    | Pcstr_record l ->
+        List.iter (sub.label_declaration sub) l
+
+  let iter_type_extension sub
+      {ptyext_path; ptyext_params;
+       ptyext_constructors;
+       ptyext_private = _;
+       ptyext_loc;
+       ptyext_attributes} =
+    iter_loc sub ptyext_path;
+    List.iter (sub.extension_constructor sub) ptyext_constructors;
+    List.iter (iter_fst (sub.typ sub)) ptyext_params;
+    sub.location sub ptyext_loc;
+    sub.attributes sub ptyext_attributes
+
+  let iter_type_exception sub
+      {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} =
+    sub.extension_constructor sub ptyexn_constructor;
+    sub.location sub ptyexn_loc;
+    sub.attributes sub ptyexn_attributes
+
+  let iter_extension_constructor_kind sub = function
+      Pext_decl(ctl, cto) ->
+        iter_constructor_arguments sub ctl; iter_opt (sub.typ sub) cto
+    | Pext_rebind li ->
+        iter_loc sub li
+
+  let iter_extension_constructor sub
+      {pext_name;
+       pext_kind;
+       pext_loc;
+       pext_attributes} =
+    iter_loc sub pext_name;
+    iter_extension_constructor_kind sub pext_kind;
+    sub.location sub pext_loc;
+    sub.attributes sub pext_attributes
+
+end
+
+module CT = struct
+  (* Type expressions for the class language *)
+
+  let iter sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pcty_constr (lid, tys) ->
+        iter_loc sub lid; List.iter (sub.typ sub) tys
+    | Pcty_signature x -> sub.class_signature sub x
+    | Pcty_arrow (_lab, t, ct) ->
+        sub.typ sub t; sub.class_type sub ct
+    | Pcty_extension x -> sub.extension sub x
+    | Pcty_open (o, e) ->
+        sub.open_description sub o; sub.class_type sub e
+
+  let iter_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
+    =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pctf_inherit ct -> sub.class_type sub ct
+    | Pctf_val (_s, _m, _v, t) -> sub.typ sub t
+    | Pctf_method (_s, _p, _v, t) -> sub.typ sub t
+    | Pctf_constraint (t1, t2) ->
+        sub.typ sub t1; sub.typ sub t2
+    | Pctf_attribute x -> sub.attribute sub x
+    | Pctf_extension x -> sub.extension sub x
+
+  let iter_signature sub {pcsig_self; pcsig_fields} =
+    sub.typ sub pcsig_self;
+    List.iter (sub.class_type_field sub) pcsig_fields
+end
+
+let iter_functor_param sub = function
+  | Unit -> ()
+  | Named (name, mty) ->
+    iter_loc sub name;
+    sub.module_type sub mty
+
+module MT = struct
+  (* Type expressions for the module language *)
+
+  let iter sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pmty_ident s -> iter_loc sub s
+    | Pmty_alias s -> iter_loc sub s
+    | Pmty_signature sg -> sub.signature sub sg
+    | Pmty_functor (param, mt2) ->
+        iter_functor_param sub param;
+        sub.module_type sub mt2
+    | Pmty_with (mt, l) ->
+        sub.module_type sub mt;
+        List.iter (sub.with_constraint sub) l
+    | Pmty_typeof me -> sub.module_expr sub me
+    | Pmty_extension x -> sub.extension sub x
+
+  let iter_with_constraint sub = function
+    | Pwith_type (lid, d) ->
+        iter_loc sub lid; sub.type_declaration sub d
+    | Pwith_module (lid, lid2) ->
+        iter_loc sub lid; iter_loc sub lid2
+    | Pwith_typesubst (lid, d) ->
+        iter_loc sub lid; sub.type_declaration sub d
+    | Pwith_modsubst (s, lid) ->
+        iter_loc sub s; iter_loc sub lid
+
+  let iter_signature_item sub {psig_desc = desc; psig_loc = loc} =
+    sub.location sub loc;
+    match desc with
+    | Psig_value vd -> sub.value_description sub vd
+    | Psig_type (_, l)
+    | Psig_typesubst l ->
+      List.iter (sub.type_declaration sub) l
+    | Psig_typext te -> sub.type_extension sub te
+    | Psig_exception ed -> sub.type_exception sub ed
+    | Psig_module x -> sub.module_declaration sub x
+    | Psig_modsubst x -> sub.module_substitution sub x
+    | Psig_recmodule l ->
+        List.iter (sub.module_declaration sub) l
+    | Psig_modtype x -> sub.module_type_declaration sub x
+    | Psig_open x -> sub.open_description sub x
+    | Psig_include x -> sub.include_description sub x
+    | Psig_class l -> List.iter (sub.class_description sub) l
+    | Psig_class_type l ->
+        List.iter (sub.class_type_declaration sub) l
+    | Psig_extension (x, attrs) ->
+        sub.attributes sub attrs;
+        sub.extension sub x
+    | Psig_attribute x -> sub.attribute sub x
+end
+
+
+module M = struct
+  (* Value expressions for the module language *)
+
+  let iter sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pmod_ident x -> iter_loc sub x
+    | Pmod_structure str -> sub.structure sub str
+    | Pmod_functor (param, body) ->
+        iter_functor_param sub param;
+        sub.module_expr sub body
+    | Pmod_apply (m1, m2) ->
+        sub.module_expr sub m1; sub.module_expr sub m2
+    | Pmod_constraint (m, mty) ->
+        sub.module_expr sub m; sub.module_type sub mty
+    | Pmod_unpack e -> sub.expr sub e
+    | Pmod_extension x -> sub.extension sub x
+
+  let iter_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
+    sub.location sub loc;
+    match desc with
+    | Pstr_eval (x, attrs) ->
+        sub.attributes sub attrs; sub.expr sub x
+    | Pstr_value (_r, vbs) -> List.iter (sub.value_binding sub) vbs
+    | Pstr_primitive vd -> sub.value_description sub vd
+    | Pstr_type (_rf, l) -> List.iter (sub.type_declaration sub) l
+    | Pstr_typext te -> sub.type_extension sub te
+    | Pstr_exception ed -> sub.type_exception sub ed
+    | Pstr_module x -> sub.module_binding sub x
+    | Pstr_recmodule l -> List.iter (sub.module_binding sub) l
+    | Pstr_modtype x -> sub.module_type_declaration sub x
+    | Pstr_open x -> sub.open_declaration sub x
+    | Pstr_class l -> List.iter (sub.class_declaration sub) l
+    | Pstr_class_type l ->
+        List.iter (sub.class_type_declaration sub) l
+    | Pstr_include x -> sub.include_declaration sub x
+    | Pstr_extension (x, attrs) ->
+        sub.attributes sub attrs; sub.extension sub x
+    | Pstr_attribute x -> sub.attribute sub x
+end
+
+module E = struct
+  (* Value expressions for the core language *)
+
+  let iter sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pexp_ident x -> iter_loc sub x
+    | Pexp_constant _ -> ()
+    | Pexp_let (_r, vbs, e) ->
+        List.iter (sub.value_binding sub) vbs;
+        sub.expr sub e
+    | Pexp_fun (_lab, def, p, e) ->
+        iter_opt (sub.expr sub) def;
+        sub.pat sub p;
+        sub.expr sub e
+    | Pexp_function pel -> sub.cases sub pel
+    | Pexp_apply (e, l) ->
+        sub.expr sub e; List.iter (iter_snd (sub.expr sub)) l
+    | Pexp_match (e, pel) ->
+        sub.expr sub e; sub.cases sub pel
+    | Pexp_try (e, pel) -> sub.expr sub e; sub.cases sub pel
+    | Pexp_tuple el -> List.iter (sub.expr sub) el
+    | Pexp_construct (lid, arg) ->
+        iter_loc sub lid; iter_opt (sub.expr sub) arg
+    | Pexp_variant (_lab, eo) ->
+        iter_opt (sub.expr sub) eo
+    | Pexp_record (l, eo) ->
+        List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) l;
+        iter_opt (sub.expr sub) eo
+    | Pexp_field (e, lid) ->
+        sub.expr sub e; iter_loc sub lid
+    | Pexp_setfield (e1, lid, e2) ->
+        sub.expr sub e1; iter_loc sub lid;
+        sub.expr sub e2
+    | Pexp_array el -> List.iter (sub.expr sub) el
+    | Pexp_ifthenelse (e1, e2, e3) ->
+        sub.expr sub e1; sub.expr sub e2;
+        iter_opt (sub.expr sub) e3
+    | Pexp_sequence (e1, e2) ->
+        sub.expr sub e1; sub.expr sub e2
+    | Pexp_while (e1, e2) ->
+        sub.expr sub e1; sub.expr sub e2
+    | Pexp_for (p, e1, e2, _d, e3) ->
+        sub.pat sub p; sub.expr sub e1; sub.expr sub e2;
+        sub.expr sub e3
+    | Pexp_coerce (e, t1, t2) ->
+        sub.expr sub e; iter_opt (sub.typ sub) t1;
+        sub.typ sub t2
+    | Pexp_constraint (e, t) ->
+        sub.expr sub e; sub.typ sub t
+    | Pexp_send (e, _s) -> sub.expr sub e
+    | Pexp_new lid -> iter_loc sub lid
+    | Pexp_setinstvar (s, e) ->
+        iter_loc sub s; sub.expr sub e
+    | Pexp_override sel ->
+        List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) sel
+    | Pexp_letmodule (s, me, e) ->
+        iter_loc sub s; sub.module_expr sub me;
+        sub.expr sub e
+    | Pexp_letexception (cd, e) ->
+        sub.extension_constructor sub cd;
+        sub.expr sub e
+    | Pexp_assert e -> sub.expr sub e
+    | Pexp_lazy e -> sub.expr sub e
+    | Pexp_poly (e, t) ->
+        sub.expr sub e; iter_opt (sub.typ sub) t
+    | Pexp_object cls -> sub.class_structure sub cls
+    | Pexp_newtype (_s, e) -> sub.expr sub e
+    | Pexp_pack me -> sub.module_expr sub me
+    | Pexp_open (o, e) ->
+        sub.open_declaration sub o; sub.expr sub e
+    | Pexp_letop {let_; ands; body} ->
+        sub.binding_op sub let_;
+        List.iter (sub.binding_op sub) ands;
+        sub.expr sub body
+    | Pexp_extension x -> sub.extension sub x
+    | Pexp_unreachable -> ()
+
+  let iter_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} =
+    iter_loc sub pbop_op;
+    sub.pat sub pbop_pat;
+    sub.expr sub pbop_exp;
+    sub.location sub pbop_loc
+
+end
+
+module P = struct
+  (* Patterns *)
+
+  let iter sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Ppat_any -> ()
+    | Ppat_var s -> iter_loc sub s
+    | Ppat_alias (p, s) -> sub.pat sub p; iter_loc sub s
+    | Ppat_constant _ -> ()
+    | Ppat_interval _ -> ()
+    | Ppat_tuple pl -> List.iter (sub.pat sub) pl
+    | Ppat_construct (l, p) ->
+        iter_loc sub l; iter_opt (sub.pat sub) p
+    | Ppat_variant (_l, p) -> iter_opt (sub.pat sub) p
+    | Ppat_record (lpl, _cf) ->
+        List.iter (iter_tuple (iter_loc sub) (sub.pat sub)) lpl
+    | Ppat_array pl -> List.iter (sub.pat sub) pl
+    | Ppat_or (p1, p2) -> sub.pat sub p1; sub.pat sub p2
+    | Ppat_constraint (p, t) ->
+        sub.pat sub p; sub.typ sub t
+    | Ppat_type s -> iter_loc sub s
+    | Ppat_lazy p -> sub.pat sub p
+    | Ppat_unpack s -> iter_loc sub s
+    | Ppat_exception p -> sub.pat sub p
+    | Ppat_extension x -> sub.extension sub x
+    | Ppat_open (lid, p) ->
+        iter_loc sub lid; sub.pat sub p
+
+end
+
+module CE = struct
+  (* Value expressions for the class language *)
+
+  let iter sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pcl_constr (lid, tys) ->
+        iter_loc sub lid; List.iter (sub.typ sub) tys
+    | Pcl_structure s ->
+        sub.class_structure sub s
+    | Pcl_fun (_lab, e, p, ce) ->
+        iter_opt (sub.expr sub) e;
+        sub.pat sub p;
+        sub.class_expr sub ce
+    | Pcl_apply (ce, l) ->
+        sub.class_expr sub ce;
+        List.iter (iter_snd (sub.expr sub)) l
+    | Pcl_let (_r, vbs, ce) ->
+        List.iter (sub.value_binding sub) vbs;
+        sub.class_expr sub ce
+    | Pcl_constraint (ce, ct) ->
+        sub.class_expr sub ce; sub.class_type sub ct
+    | Pcl_extension x -> sub.extension sub x
+    | Pcl_open (o, e) ->
+        sub.open_description sub o; sub.class_expr sub e
+
+  let iter_kind sub = function
+    | Cfk_concrete (_o, e) -> sub.expr sub e
+    | Cfk_virtual t -> sub.typ sub t
+
+  let iter_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pcf_inherit (_o, ce, _s) -> sub.class_expr sub ce
+    | Pcf_val (s, _m, k) -> iter_loc sub s; iter_kind sub k
+    | Pcf_method (s, _p, k) ->
+        iter_loc sub s; iter_kind sub k
+    | Pcf_constraint (t1, t2) ->
+        sub.typ sub t1; sub.typ sub t2
+    | Pcf_initializer e -> sub.expr sub e
+    | Pcf_attribute x -> sub.attribute sub x
+    | Pcf_extension x -> sub.extension sub x
+
+  let iter_structure sub {pcstr_self; pcstr_fields} =
+    sub.pat sub pcstr_self;
+    List.iter (sub.class_field sub) pcstr_fields
+
+  let class_infos sub f {pci_virt = _; pci_params = pl; pci_name; pci_expr;
+                         pci_loc; pci_attributes} =
+    List.iter (iter_fst (sub.typ sub)) pl;
+    iter_loc sub pci_name;
+    f pci_expr;
+    sub.location sub pci_loc;
+    sub.attributes sub pci_attributes
+end
+
+(* Now, a generic AST mapper, to be extended to cover all kinds and
+   cases of the OCaml grammar.  The default behavior of the mapper is
+   the identity. *)
+
+let default_iterator =
+  {
+    structure = (fun this l -> List.iter (this.structure_item this) l);
+    structure_item = M.iter_structure_item;
+    module_expr = M.iter;
+    signature = (fun this l -> List.iter (this.signature_item this) l);
+    signature_item = MT.iter_signature_item;
+    module_type = MT.iter;
+    with_constraint = MT.iter_with_constraint;
+    class_declaration =
+      (fun this -> CE.class_infos this (this.class_expr this));
+    class_expr = CE.iter;
+    class_field = CE.iter_field;
+    class_structure = CE.iter_structure;
+    class_type = CT.iter;
+    class_type_field = CT.iter_field;
+    class_signature = CT.iter_signature;
+    class_type_declaration =
+      (fun this -> CE.class_infos this (this.class_type this));
+    class_description =
+      (fun this -> CE.class_infos this (this.class_type this));
+    type_declaration = T.iter_type_declaration;
+    type_kind = T.iter_type_kind;
+    typ = T.iter;
+    row_field = T.row_field;
+    object_field = T.object_field;
+    type_extension = T.iter_type_extension;
+    type_exception = T.iter_type_exception;
+    extension_constructor = T.iter_extension_constructor;
+    value_description =
+      (fun this {pval_name; pval_type; pval_prim = _; pval_loc;
+                 pval_attributes} ->
+        iter_loc this pval_name;
+        this.typ this pval_type;
+        this.location this pval_loc;
+        this.attributes this pval_attributes;
+      );
+
+    pat = P.iter;
+    expr = E.iter;
+    binding_op = E.iter_binding_op;
+
+    module_declaration =
+      (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} ->
+         iter_loc this pmd_name;
+         this.module_type this pmd_type;
+         this.location this pmd_loc;
+         this.attributes this pmd_attributes;
+      );
+
+    module_substitution =
+      (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} ->
+         iter_loc this pms_name;
+         iter_loc this pms_manifest;
+         this.location this pms_loc;
+         this.attributes this pms_attributes;
+      );
+
+    module_type_declaration =
+      (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} ->
+         iter_loc this pmtd_name;
+         iter_opt (this.module_type this) pmtd_type;
+         this.location this pmtd_loc;
+         this.attributes this pmtd_attributes;
+      );
+
+    module_binding =
+      (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} ->
+         iter_loc this pmb_name; this.module_expr this pmb_expr;
+         this.location this pmb_loc;
+         this.attributes this pmb_attributes;
+      );
+
+    open_declaration =
+      (fun this {popen_expr; popen_override = _; popen_attributes; popen_loc} ->
+         this.module_expr this popen_expr;
+         this.location this popen_loc;
+         this.attributes this popen_attributes
+      );
+
+    open_description =
+      (fun this {popen_expr; popen_override = _; popen_attributes; popen_loc} ->
+         iter_loc this popen_expr;
+         this.location this popen_loc;
+         this.attributes this popen_attributes
+      );
+
+
+    include_description =
+      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+         this.module_type this pincl_mod;
+         this.location this pincl_loc;
+         this.attributes this pincl_attributes
+      );
+
+    include_declaration =
+      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+         this.module_expr this pincl_mod;
+         this.location this pincl_loc;
+         this.attributes this pincl_attributes
+      );
+
+
+    value_binding =
+      (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} ->
+         this.pat this pvb_pat;
+         this.expr this pvb_expr;
+         this.location this pvb_loc;
+         this.attributes this pvb_attributes
+      );
+
+
+    constructor_declaration =
+      (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} ->
+         iter_loc this pcd_name;
+         T.iter_constructor_arguments this pcd_args;
+         iter_opt (this.typ this) pcd_res;
+         this.location this pcd_loc;
+         this.attributes this pcd_attributes
+      );
+
+    label_declaration =
+      (fun this {pld_name; pld_type; pld_loc; pld_mutable = _; pld_attributes}->
+         iter_loc this pld_name;
+         this.typ this pld_type;
+         this.location this pld_loc;
+         this.attributes this pld_attributes
+      );
+
+    cases = (fun this l -> List.iter (this.case this) l);
+    case =
+      (fun this {pc_lhs; pc_guard; pc_rhs} ->
+         this.pat this pc_lhs;
+         iter_opt (this.expr this) pc_guard;
+         this.expr this pc_rhs
+      );
+
+    location = (fun _this _l -> ());
+
+    extension = (fun this (s, e) -> iter_loc this s; this.payload this e);
+    attribute = (fun this a ->
+      iter_loc this a.attr_name;
+      this.payload this a.attr_payload;
+      this.location this a.attr_loc
+    );
+    attributes = (fun this l -> List.iter (this.attribute this) l);
+    payload =
+      (fun this -> function
+         | PStr x -> this.structure this x
+         | PSig x -> this.signature this x
+         | PTyp x -> this.typ this x
+         | PPat (x, g) -> this.pat this x; iter_opt (this.expr this) g
+      );
+  }
diff --git a/upstream/ocaml_411/parsing/ast_iterator.mli b/upstream/ocaml_411/parsing/ast_iterator.mli
new file mode 100644
index 0000000..26308d2
--- /dev/null
+++ b/upstream/ocaml_411/parsing/ast_iterator.mli
@@ -0,0 +1,83 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Nicolas Ojeda Bar, LexiFi                         *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** {!iterator} enables AST inspection using open recursion.  A
+    typical mapper would be based on {!default_iterator}, a trivial iterator,
+    and will fall back on it for handling the syntax it does not modify.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Parsetree
+
+(** {1 A generic Parsetree iterator} *)
+
+type iterator = {
+  attribute: iterator -> attribute -> unit;
+  attributes: iterator -> attribute list -> unit;
+  binding_op: iterator -> binding_op -> unit;
+  case: iterator -> case -> unit;
+  cases: iterator -> case list -> unit;
+  class_declaration: iterator -> class_declaration -> unit;
+  class_description: iterator -> class_description -> unit;
+  class_expr: iterator -> class_expr -> unit;
+  class_field: iterator -> class_field -> unit;
+  class_signature: iterator -> class_signature -> unit;
+  class_structure: iterator -> class_structure -> unit;
+  class_type: iterator -> class_type -> unit;
+  class_type_declaration: iterator -> class_type_declaration -> unit;
+  class_type_field: iterator -> class_type_field -> unit;
+  constructor_declaration: iterator -> constructor_declaration -> unit;
+  expr: iterator -> expression -> unit;
+  extension: iterator -> extension -> unit;
+  extension_constructor: iterator -> extension_constructor -> unit;
+  include_declaration: iterator -> include_declaration -> unit;
+  include_description: iterator -> include_description -> unit;
+  label_declaration: iterator -> label_declaration -> unit;
+  location: iterator -> Location.t -> unit;
+  module_binding: iterator -> module_binding -> unit;
+  module_declaration: iterator -> module_declaration -> unit;
+  module_substitution: iterator -> module_substitution -> unit;
+  module_expr: iterator -> module_expr -> unit;
+  module_type: iterator -> module_type -> unit;
+  module_type_declaration: iterator -> module_type_declaration -> unit;
+  open_declaration: iterator -> open_declaration -> unit;
+  open_description: iterator -> open_description -> unit;
+  pat: iterator -> pattern -> unit;
+  payload: iterator -> payload -> unit;
+  signature: iterator -> signature -> unit;
+  signature_item: iterator -> signature_item -> unit;
+  structure: iterator -> structure -> unit;
+  structure_item: iterator -> structure_item -> unit;
+  typ: iterator -> core_type -> unit;
+  row_field: iterator -> row_field -> unit;
+  object_field: iterator -> object_field -> unit;
+  type_declaration: iterator -> type_declaration -> unit;
+  type_extension: iterator -> type_extension -> unit;
+  type_exception: iterator -> type_exception -> unit;
+  type_kind: iterator -> type_kind -> unit;
+  value_binding: iterator -> value_binding -> unit;
+  value_description: iterator -> value_description -> unit;
+  with_constraint: iterator -> with_constraint -> unit;
+}
+(** A [iterator] record implements one "method" per syntactic category,
+    using an open recursion style: each method takes as its first
+    argument the iterator to be applied to children in the syntax
+    tree. *)
+
+val default_iterator: iterator
+(** A default iterator, which implements a "do not do anything" mapping. *)
diff --git a/upstream/ocaml_411/parsing/ast_mapper.ml b/upstream/ocaml_411/parsing/ast_mapper.ml
new file mode 100644
index 0000000..dadf5ea
--- /dev/null
+++ b/upstream/ocaml_411/parsing/ast_mapper.ml
@@ -0,0 +1,1068 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* A generic Parsetree mapping class *)
+
+(*
+[@@@ocaml.warning "+9"]
+  (* Ensure that record patterns don't miss any field. *)
+*)
+
+open Parsetree
+open Ast_helper
+open Location
+
+module String = Misc.Stdlib.String
+
+type mapper = {
+  attribute: mapper -> attribute -> attribute;
+  attributes: mapper -> attribute list -> attribute list;
+  binding_op: mapper -> binding_op -> binding_op;
+  case: mapper -> case -> case;
+  cases: mapper -> case list -> case list;
+  class_declaration: mapper -> class_declaration -> class_declaration;
+  class_description: mapper -> class_description -> class_description;
+  class_expr: mapper -> class_expr -> class_expr;
+  class_field: mapper -> class_field -> class_field;
+  class_signature: mapper -> class_signature -> class_signature;
+  class_structure: mapper -> class_structure -> class_structure;
+  class_type: mapper -> class_type -> class_type;
+  class_type_declaration: mapper -> class_type_declaration
+                          -> class_type_declaration;
+  class_type_field: mapper -> class_type_field -> class_type_field;
+  constant: mapper -> constant -> constant;
+  constructor_declaration: mapper -> constructor_declaration
+                           -> constructor_declaration;
+  expr: mapper -> expression -> expression;
+  extension: mapper -> extension -> extension;
+  extension_constructor: mapper -> extension_constructor
+                         -> extension_constructor;
+  include_declaration: mapper -> include_declaration -> include_declaration;
+  include_description: mapper -> include_description -> include_description;
+  label_declaration: mapper -> label_declaration -> label_declaration;
+  location: mapper -> Location.t -> Location.t;
+  module_binding: mapper -> module_binding -> module_binding;
+  module_declaration: mapper -> module_declaration -> module_declaration;
+  module_substitution: mapper -> module_substitution -> module_substitution;
+  module_expr: mapper -> module_expr -> module_expr;
+  module_type: mapper -> module_type -> module_type;
+  module_type_declaration: mapper -> module_type_declaration
+                           -> module_type_declaration;
+  open_declaration: mapper -> open_declaration -> open_declaration;
+  open_description: mapper -> open_description -> open_description;
+  pat: mapper -> pattern -> pattern;
+  payload: mapper -> payload -> payload;
+  signature: mapper -> signature -> signature;
+  signature_item: mapper -> signature_item -> signature_item;
+  structure: mapper -> structure -> structure;
+  structure_item: mapper -> structure_item -> structure_item;
+  typ: mapper -> core_type -> core_type;
+  type_declaration: mapper -> type_declaration -> type_declaration;
+  type_extension: mapper -> type_extension -> type_extension;
+  type_exception: mapper -> type_exception -> type_exception;
+  type_kind: mapper -> type_kind -> type_kind;
+  value_binding: mapper -> value_binding -> value_binding;
+  value_description: mapper -> value_description -> value_description;
+  with_constraint: mapper -> with_constraint -> with_constraint;
+}
+
+let map_fst f (x, y) = (f x, y)
+let map_snd f (x, y) = (x, f y)
+let map_tuple f1 f2 (x, y) = (f1 x, f2 y)
+let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
+let map_opt f = function None -> None | Some x -> Some (f x)
+
+let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}
+
+module C = struct
+  (* Constants *)
+
+  let map sub c = match c with
+    | Pconst_integer _
+    | Pconst_char _
+    | Pconst_float _
+      -> c
+    | Pconst_string (s, loc, quotation_delimiter) ->
+        let loc = sub.location sub loc in
+        Const.string ~loc ?quotation_delimiter s
+end
+
+module T = struct
+  (* Type expressions for the core language *)
+
+  let row_field sub {
+      prf_desc;
+      prf_loc;
+      prf_attributes;
+    } =
+    let loc = sub.location sub prf_loc in
+    let attrs = sub.attributes sub prf_attributes in
+    let desc = match prf_desc with
+      | Rtag (l, b, tl) -> Rtag (map_loc sub l, b, List.map (sub.typ sub) tl)
+      | Rinherit t -> Rinherit (sub.typ sub t)
+    in
+    Rf.mk ~loc ~attrs desc
+
+  let object_field sub {
+      pof_desc;
+      pof_loc;
+      pof_attributes;
+    } =
+    let loc = sub.location sub pof_loc in
+    let attrs = sub.attributes sub pof_attributes in
+    let desc = match pof_desc with
+      | Otag (l, t) -> Otag (map_loc sub l, sub.typ sub t)
+      | Oinherit t -> Oinherit (sub.typ sub t)
+    in
+    Of.mk ~loc ~attrs desc
+
+  let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
+    let open Typ in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Ptyp_any -> any ~loc ~attrs ()
+    | Ptyp_var s -> var ~loc ~attrs s
+    | Ptyp_arrow (lab, t1, t2) ->
+        arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2)
+    | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
+    | Ptyp_constr (lid, tl) ->
+        constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
+    | Ptyp_object (l, o) ->
+        object_ ~loc ~attrs (List.map (object_field sub) l) o
+    | Ptyp_class (lid, tl) ->
+        class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
+    | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s
+    | Ptyp_variant (rl, b, ll) ->
+        variant ~loc ~attrs (List.map (row_field sub) rl) b ll
+    | Ptyp_poly (sl, t) -> poly ~loc ~attrs
+                             (List.map (map_loc sub) sl) (sub.typ sub t)
+    | Ptyp_package (lid, l) ->
+        package ~loc ~attrs (map_loc sub lid)
+          (List.map (map_tuple (map_loc sub) (sub.typ sub)) l)
+    | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_type_declaration sub
+      {ptype_name; ptype_params; ptype_cstrs;
+       ptype_kind;
+       ptype_private;
+       ptype_manifest;
+       ptype_attributes;
+       ptype_loc} =
+    let loc = sub.location sub ptype_loc in
+    let attrs = sub.attributes sub ptype_attributes in
+    Type.mk ~loc ~attrs (map_loc sub ptype_name)
+      ~params:(List.map (map_fst (sub.typ sub)) ptype_params)
+      ~priv:ptype_private
+      ~cstrs:(List.map
+                (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub))
+                ptype_cstrs)
+      ~kind:(sub.type_kind sub ptype_kind)
+      ?manifest:(map_opt (sub.typ sub) ptype_manifest)
+
+  let map_type_kind sub = function
+    | Ptype_abstract -> Ptype_abstract
+    | Ptype_variant l ->
+        Ptype_variant (List.map (sub.constructor_declaration sub) l)
+    | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l)
+    | Ptype_open -> Ptype_open
+
+  let map_constructor_arguments sub = function
+    | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l)
+    | Pcstr_record l ->
+        Pcstr_record (List.map (sub.label_declaration sub) l)
+
+  let map_type_extension sub
+      {ptyext_path; ptyext_params;
+       ptyext_constructors;
+       ptyext_private;
+       ptyext_loc;
+       ptyext_attributes} =
+    let loc = sub.location sub ptyext_loc in
+    let attrs = sub.attributes sub ptyext_attributes in
+    Te.mk ~loc ~attrs
+      (map_loc sub ptyext_path)
+      (List.map (sub.extension_constructor sub) ptyext_constructors)
+      ~params:(List.map (map_fst (sub.typ sub)) ptyext_params)
+      ~priv:ptyext_private
+
+  let map_type_exception sub
+      {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} =
+    let loc = sub.location sub ptyexn_loc in
+    let attrs = sub.attributes sub ptyexn_attributes in
+    Te.mk_exception ~loc ~attrs
+      (sub.extension_constructor sub ptyexn_constructor)
+
+  let map_extension_constructor_kind sub = function
+      Pext_decl(ctl, cto) ->
+        Pext_decl(map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto)
+    | Pext_rebind li ->
+        Pext_rebind (map_loc sub li)
+
+  let map_extension_constructor sub
+      {pext_name;
+       pext_kind;
+       pext_loc;
+       pext_attributes} =
+    let loc = sub.location sub pext_loc in
+    let attrs = sub.attributes sub pext_attributes in
+    Te.constructor ~loc ~attrs
+      (map_loc sub pext_name)
+      (map_extension_constructor_kind sub pext_kind)
+
+end
+
+module CT = struct
+  (* Type expressions for the class language *)
+
+  let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} =
+    let open Cty in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pcty_constr (lid, tys) ->
+        constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
+    | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x)
+    | Pcty_arrow (lab, t, ct) ->
+        arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct)
+    | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x)
+    | Pcty_open (o, ct) ->
+        open_ ~loc ~attrs (sub.open_description sub o) (sub.class_type sub ct)
+
+  let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
+    =
+    let open Ctf in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct)
+    | Pctf_val (s, m, v, t) ->
+        val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t)
+    | Pctf_method (s, p, v, t) ->
+        method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t)
+    | Pctf_constraint (t1, t2) ->
+        constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
+    | Pctf_attribute x -> attribute ~loc (sub.attribute sub x)
+    | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_signature sub {pcsig_self; pcsig_fields} =
+    Csig.mk
+      (sub.typ sub pcsig_self)
+      (List.map (sub.class_type_field sub) pcsig_fields)
+end
+
+let map_functor_param sub = function
+  | Unit -> Unit
+  | Named (s, mt) -> Named (map_loc sub s, sub.module_type sub mt)
+
+module MT = struct
+  (* Type expressions for the module language *)
+
+  let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} =
+    let open Mty in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s)
+    | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s)
+    | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg)
+    | Pmty_functor (param, mt) ->
+        functor_ ~loc ~attrs
+          (map_functor_param sub param)
+          (sub.module_type sub mt)
+    | Pmty_with (mt, l) ->
+        with_ ~loc ~attrs (sub.module_type sub mt)
+          (List.map (sub.with_constraint sub) l)
+    | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me)
+    | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_with_constraint sub = function
+    | Pwith_type (lid, d) ->
+        Pwith_type (map_loc sub lid, sub.type_declaration sub d)
+    | Pwith_module (lid, lid2) ->
+        Pwith_module (map_loc sub lid, map_loc sub lid2)
+    | Pwith_typesubst (lid, d) ->
+        Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d)
+    | Pwith_modsubst (s, lid) ->
+        Pwith_modsubst (map_loc sub s, map_loc sub lid)
+
+  let map_signature_item sub {psig_desc = desc; psig_loc = loc} =
+    let open Sig in
+    let loc = sub.location sub loc in
+    match desc with
+    | Psig_value vd -> value ~loc (sub.value_description sub vd)
+    | Psig_type (rf, l) ->
+        type_ ~loc rf (List.map (sub.type_declaration sub) l)
+    | Psig_typesubst l ->
+        type_subst ~loc (List.map (sub.type_declaration sub) l)
+    | Psig_typext te -> type_extension ~loc (sub.type_extension sub te)
+    | Psig_exception ed -> exception_ ~loc (sub.type_exception sub ed)
+    | Psig_module x -> module_ ~loc (sub.module_declaration sub x)
+    | Psig_modsubst x -> mod_subst ~loc (sub.module_substitution sub x)
+    | Psig_recmodule l ->
+        rec_module ~loc (List.map (sub.module_declaration sub) l)
+    | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
+    | Psig_open x -> open_ ~loc (sub.open_description sub x)
+    | Psig_include x -> include_ ~loc (sub.include_description sub x)
+    | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l)
+    | Psig_class_type l ->
+        class_type ~loc (List.map (sub.class_type_declaration sub) l)
+    | Psig_extension (x, attrs) ->
+        let attrs = sub.attributes sub attrs in
+        extension ~loc ~attrs (sub.extension sub x)
+    | Psig_attribute x -> attribute ~loc (sub.attribute sub x)
+end
+
+
+module M = struct
+  (* Value expressions for the module language *)
+
+  let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} =
+    let open Mod in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x)
+    | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str)
+    | Pmod_functor (param, body) ->
+        functor_ ~loc ~attrs
+          (map_functor_param sub param)
+          (sub.module_expr sub body)
+    | Pmod_apply (m1, m2) ->
+        apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2)
+    | Pmod_constraint (m, mty) ->
+        constraint_ ~loc ~attrs (sub.module_expr sub m)
+                    (sub.module_type sub mty)
+    | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e)
+    | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
+    let open Str in
+    let loc = sub.location sub loc in
+    match desc with
+    | Pstr_eval (x, attrs) ->
+        let attrs = sub.attributes sub attrs in
+        eval ~loc ~attrs (sub.expr sub x)
+    | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs)
+    | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd)
+    | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l)
+    | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te)
+    | Pstr_exception ed -> exception_ ~loc (sub.type_exception sub ed)
+    | Pstr_module x -> module_ ~loc (sub.module_binding sub x)
+    | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l)
+    | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
+    | Pstr_open x -> open_ ~loc (sub.open_declaration sub x)
+    | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l)
+    | Pstr_class_type l ->
+        class_type ~loc (List.map (sub.class_type_declaration sub) l)
+    | Pstr_include x -> include_ ~loc (sub.include_declaration sub x)
+    | Pstr_extension (x, attrs) ->
+        let attrs = sub.attributes sub attrs in
+        extension ~loc ~attrs (sub.extension sub x)
+    | Pstr_attribute x -> attribute ~loc (sub.attribute sub x)
+end
+
+module E = struct
+  (* Value expressions for the core language *)
+
+  let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} =
+    let open Exp in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x)
+    | Pexp_constant x -> constant ~loc ~attrs (sub.constant sub x)
+    | Pexp_let (r, vbs, e) ->
+        let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
+          (sub.expr sub e)
+    | Pexp_fun (lab, def, p, e) ->
+        fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p)
+          (sub.expr sub e)
+    | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel)
+    | Pexp_apply (e, l) ->
+        apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l)
+    | Pexp_match (e, pel) ->
+        match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
+    | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
+    | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el)
+    | Pexp_construct (lid, arg) ->
+        construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg)
+    | Pexp_variant (lab, eo) ->
+        variant ~loc ~attrs lab (map_opt (sub.expr sub) eo)
+    | Pexp_record (l, eo) ->
+        record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l)
+          (map_opt (sub.expr sub) eo)
+    | Pexp_field (e, lid) ->
+        field ~loc ~attrs (sub.expr sub e) (map_loc sub lid)
+    | Pexp_setfield (e1, lid, e2) ->
+        setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid)
+          (sub.expr sub e2)
+    | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el)
+    | Pexp_ifthenelse (e1, e2, e3) ->
+        ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
+          (map_opt (sub.expr sub) e3)
+    | Pexp_sequence (e1, e2) ->
+        sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
+    | Pexp_while (e1, e2) ->
+        while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
+    | Pexp_for (p, e1, e2, d, e3) ->
+        for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d
+          (sub.expr sub e3)
+    | Pexp_coerce (e, t1, t2) ->
+        coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1)
+          (sub.typ sub t2)
+    | Pexp_constraint (e, t) ->
+        constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t)
+    | Pexp_send (e, s) ->
+        send ~loc ~attrs (sub.expr sub e) (map_loc sub s)
+    | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid)
+    | Pexp_setinstvar (s, e) ->
+        setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e)
+    | Pexp_override sel ->
+        override ~loc ~attrs
+          (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel)
+    | Pexp_letmodule (s, me, e) ->
+        letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me)
+          (sub.expr sub e)
+    | Pexp_letexception (cd, e) ->
+        letexception ~loc ~attrs
+          (sub.extension_constructor sub cd)
+          (sub.expr sub e)
+    | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e)
+    | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e)
+    | Pexp_poly (e, t) ->
+        poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t)
+    | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls)
+    | Pexp_newtype (s, e) ->
+        newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e)
+    | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me)
+    | Pexp_open (o, e) ->
+        open_ ~loc ~attrs (sub.open_declaration sub o) (sub.expr sub e)
+    | Pexp_letop {let_; ands; body} ->
+        letop ~loc ~attrs (sub.binding_op sub let_)
+          (List.map (sub.binding_op sub) ands) (sub.expr sub body)
+    | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x)
+    | Pexp_unreachable -> unreachable ~loc ~attrs ()
+
+  let map_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} =
+    let open Exp in
+    let op = map_loc sub pbop_op in
+    let pat = sub.pat sub pbop_pat in
+    let exp = sub.expr sub pbop_exp in
+    let loc = sub.location sub pbop_loc in
+    binding_op op pat exp loc
+
+end
+
+module P = struct
+  (* Patterns *)
+
+  let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} =
+    let open Pat in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Ppat_any -> any ~loc ~attrs ()
+    | Ppat_var s -> var ~loc ~attrs (map_loc sub s)
+    | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s)
+    | Ppat_constant c -> constant ~loc ~attrs (sub.constant sub c)
+    | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2
+    | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl)
+    | Ppat_construct (l, p) ->
+        construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p)
+    | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p)
+    | Ppat_record (lpl, cf) ->
+        record ~loc ~attrs
+               (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf
+    | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl)
+    | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2)
+    | Ppat_constraint (p, t) ->
+        constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t)
+    | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s)
+    | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p)
+    | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s)
+    | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p)
+    | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p)
+    | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x)
+end
+
+module CE = struct
+  (* Value expressions for the class language *)
+
+  let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} =
+    let open Cl in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pcl_constr (lid, tys) ->
+        constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
+    | Pcl_structure s ->
+        structure ~loc ~attrs (sub.class_structure sub s)
+    | Pcl_fun (lab, e, p, ce) ->
+        fun_ ~loc ~attrs lab
+          (map_opt (sub.expr sub) e)
+          (sub.pat sub p)
+          (sub.class_expr sub ce)
+    | Pcl_apply (ce, l) ->
+        apply ~loc ~attrs (sub.class_expr sub ce)
+          (List.map (map_snd (sub.expr sub)) l)
+    | Pcl_let (r, vbs, ce) ->
+        let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
+          (sub.class_expr sub ce)
+    | Pcl_constraint (ce, ct) ->
+        constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct)
+    | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x)
+    | Pcl_open (o, ce) ->
+        open_ ~loc ~attrs (sub.open_description sub o) (sub.class_expr sub ce)
+
+  let map_kind sub = function
+    | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e)
+    | Cfk_virtual t -> Cfk_virtual (sub.typ sub t)
+
+  let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} =
+    let open Cf in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pcf_inherit (o, ce, s) ->
+        inherit_ ~loc ~attrs o (sub.class_expr sub ce)
+          (map_opt (map_loc sub) s)
+    | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k)
+    | Pcf_method (s, p, k) ->
+        method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k)
+    | Pcf_constraint (t1, t2) ->
+        constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
+    | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e)
+    | Pcf_attribute x -> attribute ~loc (sub.attribute sub x)
+    | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_structure sub {pcstr_self; pcstr_fields} =
+    {
+      pcstr_self = sub.pat sub pcstr_self;
+      pcstr_fields = List.map (sub.class_field sub) pcstr_fields;
+    }
+
+  let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr;
+                         pci_loc; pci_attributes} =
+    let loc = sub.location sub pci_loc in
+    let attrs = sub.attributes sub pci_attributes in
+    Ci.mk ~loc ~attrs
+     ~virt:pci_virt
+     ~params:(List.map (map_fst (sub.typ sub)) pl)
+      (map_loc sub pci_name)
+      (f pci_expr)
+end
+
+(* Now, a generic AST mapper, to be extended to cover all kinds and
+   cases of the OCaml grammar.  The default behavior of the mapper is
+   the identity. *)
+
+let default_mapper =
+  {
+    constant = C.map;
+    structure = (fun this l -> List.map (this.structure_item this) l);
+    structure_item = M.map_structure_item;
+    module_expr = M.map;
+    signature = (fun this l -> List.map (this.signature_item this) l);
+    signature_item = MT.map_signature_item;
+    module_type = MT.map;
+    with_constraint = MT.map_with_constraint;
+    class_declaration =
+      (fun this -> CE.class_infos this (this.class_expr this));
+    class_expr = CE.map;
+    class_field = CE.map_field;
+    class_structure = CE.map_structure;
+    class_type = CT.map;
+    class_type_field = CT.map_field;
+    class_signature = CT.map_signature;
+    class_type_declaration =
+      (fun this -> CE.class_infos this (this.class_type this));
+    class_description =
+      (fun this -> CE.class_infos this (this.class_type this));
+    type_declaration = T.map_type_declaration;
+    type_kind = T.map_type_kind;
+    typ = T.map;
+    type_extension = T.map_type_extension;
+    type_exception = T.map_type_exception;
+    extension_constructor = T.map_extension_constructor;
+    value_description =
+      (fun this {pval_name; pval_type; pval_prim; pval_loc;
+                 pval_attributes} ->
+        Val.mk
+          (map_loc this pval_name)
+          (this.typ this pval_type)
+          ~attrs:(this.attributes this pval_attributes)
+          ~loc:(this.location this pval_loc)
+          ~prim:pval_prim
+      );
+
+    pat = P.map;
+    expr = E.map;
+    binding_op = E.map_binding_op;
+
+    module_declaration =
+      (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} ->
+         Md.mk
+           (map_loc this pmd_name)
+           (this.module_type this pmd_type)
+           ~attrs:(this.attributes this pmd_attributes)
+           ~loc:(this.location this pmd_loc)
+      );
+
+    module_substitution =
+      (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} ->
+         Ms.mk
+           (map_loc this pms_name)
+           (map_loc this pms_manifest)
+           ~attrs:(this.attributes this pms_attributes)
+           ~loc:(this.location this pms_loc)
+      );
+
+    module_type_declaration =
+      (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} ->
+         Mtd.mk
+           (map_loc this pmtd_name)
+           ?typ:(map_opt (this.module_type this) pmtd_type)
+           ~attrs:(this.attributes this pmtd_attributes)
+           ~loc:(this.location this pmtd_loc)
+      );
+
+    module_binding =
+      (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} ->
+         Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr)
+           ~attrs:(this.attributes this pmb_attributes)
+           ~loc:(this.location this pmb_loc)
+      );
+
+
+    open_declaration =
+      (fun this {popen_expr; popen_override; popen_attributes; popen_loc} ->
+         Opn.mk (this.module_expr this popen_expr)
+           ~override:popen_override
+           ~loc:(this.location this popen_loc)
+           ~attrs:(this.attributes this popen_attributes)
+      );
+
+    open_description =
+      (fun this {popen_expr; popen_override; popen_attributes; popen_loc} ->
+         Opn.mk (map_loc this popen_expr)
+           ~override:popen_override
+           ~loc:(this.location this popen_loc)
+           ~attrs:(this.attributes this popen_attributes)
+      );
+
+    include_description =
+      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+         Incl.mk (this.module_type this pincl_mod)
+           ~loc:(this.location this pincl_loc)
+           ~attrs:(this.attributes this pincl_attributes)
+      );
+
+    include_declaration =
+      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+         Incl.mk (this.module_expr this pincl_mod)
+           ~loc:(this.location this pincl_loc)
+           ~attrs:(this.attributes this pincl_attributes)
+      );
+
+
+    value_binding =
+      (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} ->
+         Vb.mk
+           (this.pat this pvb_pat)
+           (this.expr this pvb_expr)
+           ~loc:(this.location this pvb_loc)
+           ~attrs:(this.attributes this pvb_attributes)
+      );
+
+
+    constructor_declaration =
+      (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} ->
+        Type.constructor
+          (map_loc this pcd_name)
+          ~args:(T.map_constructor_arguments this pcd_args)
+          ?res:(map_opt (this.typ this) pcd_res)
+          ~loc:(this.location this pcd_loc)
+          ~attrs:(this.attributes this pcd_attributes)
+      );
+
+    label_declaration =
+      (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} ->
+         Type.field
+           (map_loc this pld_name)
+           (this.typ this pld_type)
+           ~mut:pld_mutable
+           ~loc:(this.location this pld_loc)
+           ~attrs:(this.attributes this pld_attributes)
+      );
+
+    cases = (fun this l -> List.map (this.case this) l);
+    case =
+      (fun this {pc_lhs; pc_guard; pc_rhs} ->
+         {
+           pc_lhs = this.pat this pc_lhs;
+           pc_guard = map_opt (this.expr this) pc_guard;
+           pc_rhs = this.expr this pc_rhs;
+         }
+      );
+
+
+
+    location = (fun _this l -> l);
+
+    extension = (fun this (s, e) -> (map_loc this s, this.payload this e));
+    attribute = (fun this a ->
+      {
+        attr_name = map_loc this a.attr_name;
+        attr_payload = this.payload this a.attr_payload;
+        attr_loc = this.location this a.attr_loc
+      }
+    );
+    attributes = (fun this l -> List.map (this.attribute this) l);
+    payload =
+      (fun this -> function
+         | PStr x -> PStr (this.structure this x)
+         | PSig x -> PSig (this.signature this x)
+         | PTyp x -> PTyp (this.typ this x)
+         | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g)
+      );
+  }
+
+let extension_of_error {kind; main; sub} =
+  if kind <> Location.Report_error then
+    raise (Invalid_argument "extension_of_error: expected kind Report_error");
+  let str_of_pp pp_msg = Format.asprintf "%t" pp_msg in
+  let extension_of_sub sub =
+    { loc = sub.loc; txt = "ocaml.error" },
+    PStr ([Str.eval (Exp.constant
+                       (Pconst_string (str_of_pp sub.txt, sub.loc, None)))])
+  in
+  { loc = main.loc; txt = "ocaml.error" },
+  PStr (Str.eval (Exp.constant
+                    (Pconst_string (str_of_pp main.txt, main.loc, None))) ::
+        List.map (fun msg -> Str.extension (extension_of_sub msg)) sub)
+
+let attribute_of_warning loc s =
+  Attr.mk
+    {loc; txt = "ocaml.ppwarning" }
+    (PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, loc, None)))]))
+
+let cookies = ref String.Map.empty
+
+let get_cookie k =
+  try Some (String.Map.find k !cookies)
+  with Not_found -> None
+
+let set_cookie k v =
+  cookies := String.Map.add k v !cookies
+
+let tool_name_ref = ref "_none_"
+
+let tool_name () = !tool_name_ref
+
+
+module PpxContext = struct
+  open Longident
+  open Asttypes
+  open Ast_helper
+
+  let lid name = { txt = Lident name; loc = Location.none }
+
+  let make_string s = Exp.constant (Const.string s)
+
+  let make_bool x =
+    if x
+    then Exp.construct (lid "true") None
+    else Exp.construct (lid "false") None
+
+  let rec make_list f lst =
+    match lst with
+    | x :: rest ->
+      Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest]))
+    | [] ->
+      Exp.construct (lid "[]") None
+
+  let make_pair f1 f2 (x1, x2) =
+    Exp.tuple [f1 x1; f2 x2]
+
+  let make_option f opt =
+    match opt with
+    | Some x -> Exp.construct (lid "Some") (Some (f x))
+    | None   -> Exp.construct (lid "None") None
+
+  let get_cookies () =
+    lid "cookies",
+    make_list (make_pair make_string (fun x -> x))
+      (String.Map.bindings !cookies)
+
+  let mk fields =
+    {
+      attr_name = { txt = "ocaml.ppx.context"; loc = Location.none };
+      attr_payload = Parsetree.PStr [Str.eval (Exp.record fields None)];
+      attr_loc = Location.none
+    }
+
+  let make ~tool_name () =
+    let fields =
+      [
+        lid "tool_name",    make_string tool_name;
+        lid "include_dirs", make_list make_string !Clflags.include_dirs;
+        lid "load_path",    make_list make_string (Load_path.get_paths ());
+        lid "open_modules", make_list make_string !Clflags.open_modules;
+        lid "for_package",  make_option make_string !Clflags.for_package;
+        lid "debug",        make_bool !Clflags.debug;
+        lid "use_threads",  make_bool !Clflags.use_threads;
+        lid "use_vmthreads", make_bool false;
+        lid "recursive_types", make_bool !Clflags.recursive_types;
+        lid "principal", make_bool !Clflags.principal;
+        lid "transparent_modules", make_bool !Clflags.transparent_modules;
+        lid "unboxed_types", make_bool !Clflags.unboxed_types;
+        lid "unsafe_string", make_bool !Clflags.unsafe_string;
+        get_cookies ()
+      ]
+    in
+    mk fields
+
+  let get_fields = function
+    | PStr [{pstr_desc = Pstr_eval
+                 ({ pexp_desc = Pexp_record (fields, None) }, [])}] ->
+        fields
+    | _ ->
+        raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax"
+
+  let restore fields =
+    let field name payload =
+      let rec get_string = function
+        | { pexp_desc = Pexp_constant (Pconst_string (str, _, None)) } -> str
+        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
+                             { %s }] string syntax" name
+      and get_bool pexp =
+        match pexp with
+        | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"},
+                                       None)} ->
+            true
+        | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"},
+                                       None)} ->
+            false
+        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
+                             { %s }] bool syntax" name
+      and get_list elem = function
+        | {pexp_desc =
+             Pexp_construct ({txt = Longident.Lident "::"},
+                             Some {pexp_desc = Pexp_tuple [exp; rest]}) } ->
+            elem exp :: get_list elem rest
+        | {pexp_desc =
+             Pexp_construct ({txt = Longident.Lident "[]"}, None)} ->
+            []
+        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
+                             { %s }] list syntax" name
+      and get_pair f1 f2 = function
+        | {pexp_desc = Pexp_tuple [e1; e2]} ->
+            (f1 e1, f2 e2)
+        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
+                             { %s }] pair syntax" name
+      and get_option elem = function
+        | { pexp_desc =
+              Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } ->
+            Some (elem exp)
+        | { pexp_desc =
+              Pexp_construct ({ txt = Longident.Lident "None" }, None) } ->
+            None
+        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
+                             { %s }] option syntax" name
+      in
+      match name with
+      | "tool_name" ->
+          tool_name_ref := get_string payload
+      | "include_dirs" ->
+          Clflags.include_dirs := get_list get_string payload
+      | "load_path" ->
+          Load_path.init (get_list get_string payload)
+      | "open_modules" ->
+          Clflags.open_modules := get_list get_string payload
+      | "for_package" ->
+          Clflags.for_package := get_option get_string payload
+      | "debug" ->
+          Clflags.debug := get_bool payload
+      | "use_threads" ->
+          Clflags.use_threads := get_bool payload
+      | "use_vmthreads" ->
+          if get_bool payload then
+            raise_errorf "Internal error: vmthreads not supported after 4.09.0"
+      | "recursive_types" ->
+          Clflags.recursive_types := get_bool payload
+      | "principal" ->
+          Clflags.principal := get_bool payload
+      | "transparent_modules" ->
+          Clflags.transparent_modules := get_bool payload
+      | "unboxed_types" ->
+          Clflags.unboxed_types := get_bool payload
+      | "unsafe_string" ->
+          Clflags.unsafe_string := get_bool payload
+      | "cookies" ->
+          let l = get_list (get_pair get_string (fun x -> x)) payload in
+          cookies :=
+            List.fold_left
+              (fun s (k, v) -> String.Map.add k v s) String.Map.empty
+              l
+      | _ ->
+          ()
+    in
+    List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields
+
+  let update_cookies fields =
+    let fields =
+      List.filter
+        (function ({txt=Lident "cookies"}, _) -> false | _ -> true)
+        fields
+    in
+    fields @ [get_cookies ()]
+end
+
+let ppx_context = PpxContext.make
+
+let extension_of_exn exn =
+  match error_of_exn exn with
+  | Some (`Ok error) -> extension_of_error error
+  | Some `Already_displayed ->
+      { loc = Location.none; txt = "ocaml.error" }, PStr []
+  | None -> raise exn
+
+
+let apply_lazy ~source ~target mapper =
+  let implem ast =
+    let fields, ast =
+      match ast with
+      | {pstr_desc = Pstr_attribute ({attr_name = {txt = "ocaml.ppx.context"};
+                                      attr_payload = x})} :: l ->
+          PpxContext.get_fields x, l
+      | _ -> [], ast
+    in
+    PpxContext.restore fields;
+    let ast =
+      try
+        let mapper = mapper () in
+        mapper.structure mapper ast
+      with exn ->
+        [{pstr_desc = Pstr_extension (extension_of_exn exn, []);
+          pstr_loc  = Location.none}]
+    in
+    let fields = PpxContext.update_cookies fields in
+    Str.attribute (PpxContext.mk fields) :: ast
+  in
+  let iface ast =
+    let fields, ast =
+      match ast with
+      | {psig_desc = Psig_attribute ({attr_name = {txt = "ocaml.ppx.context"};
+                                      attr_payload = x;
+                                      attr_loc = _})} :: l ->
+          PpxContext.get_fields x, l
+      | _ -> [], ast
+    in
+    PpxContext.restore fields;
+    let ast =
+      try
+        let mapper = mapper () in
+        mapper.signature mapper ast
+      with exn ->
+        [{psig_desc = Psig_extension (extension_of_exn exn, []);
+          psig_loc  = Location.none}]
+    in
+    let fields = PpxContext.update_cookies fields in
+    Sig.attribute (PpxContext.mk fields) :: ast
+  in
+
+  let ic = open_in_bin source in
+  let magic =
+    really_input_string ic (String.length Config.ast_impl_magic_number)
+  in
+
+  let rewrite transform =
+    Location.input_name := input_value ic;
+    let ast = input_value ic in
+    close_in ic;
+    let ast = transform ast in
+    let oc = open_out_bin target in
+    output_string oc magic;
+    output_value oc !Location.input_name;
+    output_value oc ast;
+    close_out oc
+  and fail () =
+    close_in ic;
+    failwith "Ast_mapper: OCaml version mismatch or malformed input";
+  in
+
+  if magic = Config.ast_impl_magic_number then
+    rewrite (implem : structure -> structure)
+  else if magic = Config.ast_intf_magic_number then
+    rewrite (iface : signature -> signature)
+  else fail ()
+
+let drop_ppx_context_str ~restore = function
+  | {pstr_desc = Pstr_attribute
+                   {attr_name = {Location.txt = "ocaml.ppx.context"};
+                    attr_payload = a;
+                    attr_loc = _}}
+    :: items ->
+      if restore then
+        PpxContext.restore (PpxContext.get_fields a);
+      items
+  | items -> items
+
+let drop_ppx_context_sig ~restore = function
+  | {psig_desc = Psig_attribute
+                   {attr_name = {Location.txt = "ocaml.ppx.context"};
+                    attr_payload = a;
+                    attr_loc = _}}
+    :: items ->
+      if restore then
+        PpxContext.restore (PpxContext.get_fields a);
+      items
+  | items -> items
+
+let add_ppx_context_str ~tool_name ast =
+  Ast_helper.Str.attribute (ppx_context ~tool_name ()) :: ast
+
+let add_ppx_context_sig ~tool_name ast =
+  Ast_helper.Sig.attribute (ppx_context ~tool_name ()) :: ast
+
+
+let apply ~source ~target mapper =
+  apply_lazy ~source ~target (fun () -> mapper)
+
+let run_main mapper =
+  try
+    let a = Sys.argv in
+    let n = Array.length a in
+    if n > 2 then
+      let mapper () =
+        try mapper (Array.to_list (Array.sub a 1 (n - 3)))
+        with exn ->
+          (* PR#6463 *)
+          let f _ _ = raise exn in
+          {default_mapper with structure = f; signature = f}
+      in
+      apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) mapper
+    else begin
+      Printf.eprintf "Usage: %s [extra_args] <infile> <outfile>\n%!"
+                     Sys.executable_name;
+      exit 2
+    end
+  with exn ->
+    prerr_endline (Printexc.to_string exn);
+    exit 2
+
+let register_function = ref (fun _name f -> run_main f)
+let register name f = !register_function name f
diff --git a/upstream/ocaml_411/parsing/ast_mapper.mli b/upstream/ocaml_411/parsing/ast_mapper.mli
new file mode 100644
index 0000000..69f6b01
--- /dev/null
+++ b/upstream/ocaml_411/parsing/ast_mapper.mli
@@ -0,0 +1,208 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** The interface of a -ppx rewriter
+
+  A -ppx rewriter is a program that accepts a serialized abstract syntax
+  tree and outputs another, possibly modified, abstract syntax tree.
+  This module encapsulates the interface between the compiler and
+  the -ppx rewriters, handling such details as the serialization format,
+  forwarding of command-line flags, and storing state.
+
+  {!mapper} enables AST rewriting using open recursion.
+  A typical mapper would be based on {!default_mapper}, a deep
+  identity mapper, and will fall back on it for handling the syntax it
+  does not modify. For example:
+
+  {[
+open Asttypes
+open Parsetree
+open Ast_mapper
+
+let test_mapper argv =
+  { default_mapper with
+    expr = fun mapper expr ->
+      match expr with
+      | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} ->
+        Ast_helper.Exp.constant (Const_int 42)
+      | other -> default_mapper.expr mapper other; }
+
+let () =
+  register "ppx_test" test_mapper]}
+
+  This -ppx rewriter, which replaces [[%test]] in expressions with
+  the constant [42], can be compiled using
+  [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml].
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+  *)
+
+open Parsetree
+
+(** {1 A generic Parsetree mapper} *)
+
+type mapper = {
+  attribute: mapper -> attribute -> attribute;
+  attributes: mapper -> attribute list -> attribute list;
+  binding_op: mapper -> binding_op -> binding_op;
+  case: mapper -> case -> case;
+  cases: mapper -> case list -> case list;
+  class_declaration: mapper -> class_declaration -> class_declaration;
+  class_description: mapper -> class_description -> class_description;
+  class_expr: mapper -> class_expr -> class_expr;
+  class_field: mapper -> class_field -> class_field;
+  class_signature: mapper -> class_signature -> class_signature;
+  class_structure: mapper -> class_structure -> class_structure;
+  class_type: mapper -> class_type -> class_type;
+  class_type_declaration: mapper -> class_type_declaration
+                          -> class_type_declaration;
+  class_type_field: mapper -> class_type_field -> class_type_field;
+  constant: mapper -> constant -> constant;
+  constructor_declaration: mapper -> constructor_declaration
+                           -> constructor_declaration;
+  expr: mapper -> expression -> expression;
+  extension: mapper -> extension -> extension;
+  extension_constructor: mapper -> extension_constructor
+                         -> extension_constructor;
+  include_declaration: mapper -> include_declaration -> include_declaration;
+  include_description: mapper -> include_description -> include_description;
+  label_declaration: mapper -> label_declaration -> label_declaration;
+  location: mapper -> Location.t -> Location.t;
+  module_binding: mapper -> module_binding -> module_binding;
+  module_declaration: mapper -> module_declaration -> module_declaration;
+  module_substitution: mapper -> module_substitution -> module_substitution;
+  module_expr: mapper -> module_expr -> module_expr;
+  module_type: mapper -> module_type -> module_type;
+  module_type_declaration: mapper -> module_type_declaration
+                           -> module_type_declaration;
+  open_declaration: mapper -> open_declaration -> open_declaration;
+  open_description: mapper -> open_description -> open_description;
+  pat: mapper -> pattern -> pattern;
+  payload: mapper -> payload -> payload;
+  signature: mapper -> signature -> signature;
+  signature_item: mapper -> signature_item -> signature_item;
+  structure: mapper -> structure -> structure;
+  structure_item: mapper -> structure_item -> structure_item;
+  typ: mapper -> core_type -> core_type;
+  type_declaration: mapper -> type_declaration -> type_declaration;
+  type_extension: mapper -> type_extension -> type_extension;
+  type_exception: mapper -> type_exception -> type_exception;
+  type_kind: mapper -> type_kind -> type_kind;
+  value_binding: mapper -> value_binding -> value_binding;
+  value_description: mapper -> value_description -> value_description;
+  with_constraint: mapper -> with_constraint -> with_constraint;
+}
+(** A mapper record implements one "method" per syntactic category,
+    using an open recursion style: each method takes as its first
+    argument the mapper to be applied to children in the syntax
+    tree. *)
+
+val default_mapper: mapper
+(** A default mapper, which implements a "deep identity" mapping. *)
+
+(** {1 Apply mappers to compilation units} *)
+
+val tool_name: unit -> string
+(** Can be used within a ppx preprocessor to know which tool is
+    calling it ["ocamlc"], ["ocamlopt"], ["ocamldoc"], ["ocamldep"],
+    ["ocaml"], ...  Some global variables that reflect command-line
+    options are automatically synchronized between the calling tool
+    and the ppx preprocessor: {!Clflags.include_dirs},
+    {!Load_path}, {!Clflags.open_modules}, {!Clflags.for_package},
+    {!Clflags.debug}. *)
+
+
+val apply: source:string -> target:string -> mapper -> unit
+(** Apply a mapper (parametrized by the unit name) to a dumped
+    parsetree found in the [source] file and put the result in the
+    [target] file. The [structure] or [signature] field of the mapper
+    is applied to the implementation or interface.  *)
+
+val run_main: (string list -> mapper) -> unit
+(** Entry point to call to implement a standalone -ppx rewriter from a
+    mapper, parametrized by the command line arguments.  The current
+    unit name can be obtained from {!Location.input_name}.  This
+    function implements proper error reporting for uncaught
+    exceptions. *)
+
+(** {1 Registration API} *)
+
+val register_function: (string -> (string list -> mapper) -> unit) ref
+
+val register: string -> (string list -> mapper) -> unit
+(** Apply the [register_function].  The default behavior is to run the
+    mapper immediately, taking arguments from the process command
+    line.  This is to support a scenario where a mapper is linked as a
+    stand-alone executable.
+
+    It is possible to overwrite the [register_function] to define
+    "-ppx drivers", which combine several mappers in a single process.
+    Typically, a driver starts by defining [register_function] to a
+    custom implementation, then lets ppx rewriters (linked statically
+    or dynamically) register themselves, and then run all or some of
+    them.  It is also possible to have -ppx drivers apply rewriters to
+    only specific parts of an AST.
+
+    The first argument to [register] is a symbolic name to be used by
+    the ppx driver.  *)
+
+
+(** {1 Convenience functions to write mappers} *)
+
+val map_opt: ('a -> 'b) -> 'a option -> 'b option
+
+val extension_of_error: Location.error -> extension
+(** Encode an error into an 'ocaml.error' extension node which can be
+    inserted in a generated Parsetree.  The compiler will be
+    responsible for reporting the error. *)
+
+val attribute_of_warning: Location.t -> string -> attribute
+(** Encode a warning message into an 'ocaml.ppwarning' attribute which can be
+    inserted in a generated Parsetree.  The compiler will be
+    responsible for reporting the warning. *)
+
+(** {1 Helper functions to call external mappers} *)
+
+val add_ppx_context_str:
+    tool_name:string -> Parsetree.structure -> Parsetree.structure
+(** Extract information from the current environment and encode it
+    into an attribute which is prepended to the list of structure
+    items in order to pass the information to an external
+    processor. *)
+
+val add_ppx_context_sig:
+    tool_name:string -> Parsetree.signature -> Parsetree.signature
+(** Same as [add_ppx_context_str], but for signatures. *)
+
+val drop_ppx_context_str:
+    restore:bool -> Parsetree.structure -> Parsetree.structure
+(** Drop the ocaml.ppx.context attribute from a structure.  If
+    [restore] is true, also restore the associated data in the current
+    process. *)
+
+val drop_ppx_context_sig:
+    restore:bool -> Parsetree.signature -> Parsetree.signature
+(** Same as [drop_ppx_context_str], but for signatures. *)
+
+(** {1 Cookies} *)
+
+(** Cookies are used to pass information from a ppx processor to
+    a further invocation of itself, when called from the OCaml
+    toplevel (or other tools that support cookies). *)
+
+val set_cookie: string -> Parsetree.expression -> unit
+val get_cookie: string -> Parsetree.expression option
diff --git a/upstream/ocaml_411/parsing/asttypes.mli b/upstream/ocaml_411/parsing/asttypes.mli
new file mode 100644
index 0000000..353d777
--- /dev/null
+++ b/upstream/ocaml_411/parsing/asttypes.mli
@@ -0,0 +1,63 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Auxiliary AST types used by parsetree and typedtree.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type constant =
+    Const_int of int
+  | Const_char of char
+  | Const_string of string * Location.t * string option
+  | Const_float of string
+  | Const_int32 of int32
+  | Const_int64 of int64
+  | Const_nativeint of nativeint
+
+type rec_flag = Nonrecursive | Recursive
+
+type direction_flag = Upto | Downto
+
+(* Order matters, used in polymorphic comparison *)
+type private_flag = Private | Public
+
+type mutable_flag = Immutable | Mutable
+
+type virtual_flag = Virtual | Concrete
+
+type override_flag = Override | Fresh
+
+type closed_flag = Closed | Open
+
+type label = string
+
+type arg_label =
+    Nolabel
+  | Labelled of string (*  label:T -> ... *)
+  | Optional of string (* ?label:T -> ... *)
+
+type 'a loc = 'a Location.loc = {
+  txt : 'a;
+  loc : Location.t;
+}
+
+
+type variance =
+  | Covariant
+  | Contravariant
+  | Invariant
diff --git a/upstream/ocaml_411/parsing/attr_helper.ml b/upstream/ocaml_411/parsing/attr_helper.ml
new file mode 100644
index 0000000..0a616cd
--- /dev/null
+++ b/upstream/ocaml_411/parsing/attr_helper.ml
@@ -0,0 +1,54 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                  Jeremie Dimino, Jane Street Europe                    *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Parsetree
+
+type error =
+  | Multiple_attributes of string
+  | No_payload_expected of string
+
+exception Error of Location.t * error
+
+let get_no_payload_attribute alt_names attrs =
+  match List.filter (fun a -> List.mem a.attr_name.txt alt_names) attrs with
+  | [] -> None
+  | [ {attr_name = name; attr_payload = PStr []; attr_loc = _} ] -> Some name
+  | [ {attr_name = name; _} ] ->
+    raise (Error (name.loc, No_payload_expected name.txt))
+  | _ :: {attr_name = name; _} :: _ ->
+    raise (Error (name.loc, Multiple_attributes name.txt))
+
+let has_no_payload_attribute alt_names attrs =
+  match get_no_payload_attribute alt_names attrs with
+  | None   -> false
+  | Some _ -> true
+
+open Format
+
+let report_error ppf = function
+  | Multiple_attributes name ->
+    fprintf ppf "Too many `%s' attributes" name
+  | No_payload_expected name ->
+    fprintf ppf "Attribute `%s' does not accept a payload" name
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, err) ->
+        Some (Location.error_of_printer ~loc report_error err)
+      | _ ->
+        None
+    )
diff --git a/upstream/ocaml_411/parsing/attr_helper.mli b/upstream/ocaml_411/parsing/attr_helper.mli
new file mode 100644
index 0000000..a3ddc0c
--- /dev/null
+++ b/upstream/ocaml_411/parsing/attr_helper.mli
@@ -0,0 +1,41 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                  Jeremie Dimino, Jane Street Europe                    *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Helpers for attributes
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Asttypes
+open Parsetree
+
+type error =
+  | Multiple_attributes of string
+  | No_payload_expected of string
+
+(** The [string list] argument of the following functions is a list of
+    alternative names for the attribute we are looking for. For instance:
+
+    {[
+      ["foo"; "ocaml.foo"]
+    ]} *)
+val get_no_payload_attribute : string list -> attributes -> string loc option
+val has_no_payload_attribute : string list -> attributes -> bool
+
+exception Error of Location.t * error
+
+val report_error: Format.formatter -> error -> unit
diff --git a/upstream/ocaml_411/parsing/builtin_attributes.ml b/upstream/ocaml_411/parsing/builtin_attributes.ml
new file mode 100644
index 0000000..af495e9
--- /dev/null
+++ b/upstream/ocaml_411/parsing/builtin_attributes.ml
@@ -0,0 +1,287 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Parsetree
+
+let string_of_cst = function
+  | Pconst_string(s, _, _) -> Some s
+  | _ -> None
+
+let string_of_payload = function
+  | PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant c},_)}] ->
+      string_of_cst c
+  | _ -> None
+
+let string_of_opt_payload p =
+  match string_of_payload p with
+  | Some s -> s
+  | None -> ""
+
+let error_of_extension ext =
+  let submessage_from main_loc main_txt = function
+    | {pstr_desc=Pstr_extension
+           (({txt = ("ocaml.error"|"error"); loc}, p), _)} ->
+        begin match p with
+        | PStr([{pstr_desc=Pstr_eval
+                     ({pexp_desc=Pexp_constant(Pconst_string(msg,_,_))}, _)}
+               ]) ->
+            { Location.loc; txt = fun ppf -> Format.pp_print_text ppf msg }
+        | _ ->
+            { Location.loc; txt = fun ppf ->
+                Format.fprintf ppf
+                  "Invalid syntax for sub-message of extension '%s'." main_txt }
+        end
+    | {pstr_desc=Pstr_extension (({txt; loc}, _), _)} ->
+        { Location.loc; txt = fun ppf ->
+            Format.fprintf ppf "Uninterpreted extension '%s'." txt }
+    | _ ->
+        { Location.loc = main_loc; txt = fun ppf ->
+            Format.fprintf ppf
+              "Invalid syntax for sub-message of extension '%s'." main_txt }
+  in
+  match ext with
+  | ({txt = ("ocaml.error"|"error") as txt; loc}, p) ->
+      begin match p with
+      | PStr [] -> raise Location.Already_displayed_error
+      | PStr({pstr_desc=Pstr_eval
+                  ({pexp_desc=Pexp_constant(Pconst_string(msg,_,_))}, _)}::
+             inner) ->
+          let sub = List.map (submessage_from loc txt) inner in
+          Location.error_of_printer ~loc ~sub Format.pp_print_text msg
+      | _ ->
+          Location.errorf ~loc "Invalid syntax for extension '%s'." txt
+      end
+  | ({txt; loc}, _) ->
+      Location.errorf ~loc "Uninterpreted extension '%s'." txt
+
+let kind_and_message = function
+  | PStr[
+      {pstr_desc=
+         Pstr_eval
+           ({pexp_desc=Pexp_apply
+                 ({pexp_desc=Pexp_ident{txt=Longident.Lident id}},
+                  [Nolabel,{pexp_desc=Pexp_constant (Pconst_string(s,_,_))}])
+            },_)}] ->
+      Some (id, s)
+  | PStr[
+      {pstr_desc=
+         Pstr_eval
+           ({pexp_desc=Pexp_ident{txt=Longident.Lident id}},_)}] ->
+      Some (id, "")
+  | _ -> None
+
+let cat s1 s2 =
+  if s2 = "" then s1 else s1 ^ "\n" ^ s2
+
+let alert_attr x =
+  match x.attr_name.txt with
+  | "ocaml.deprecated"|"deprecated" ->
+      Some (x, "deprecated", string_of_opt_payload x.attr_payload)
+  | "ocaml.alert"|"alert" ->
+      begin match kind_and_message x.attr_payload with
+      | Some (kind, message) -> Some (x, kind, message)
+      | None -> None (* note: bad payloads detected by warning_attribute *)
+      end
+  | _ -> None
+
+let alert_attrs l =
+  List.filter_map alert_attr l
+
+let alerts_of_attrs l =
+  List.fold_left
+    (fun acc (_, kind, message) ->
+       let upd = function
+         | None | Some "" -> Some message
+         | Some s -> Some (cat s message)
+       in
+       Misc.Stdlib.String.Map.update kind upd acc
+    )
+    Misc.Stdlib.String.Map.empty
+    (alert_attrs l)
+
+let check_alerts loc attrs s =
+  Misc.Stdlib.String.Map.iter
+    (fun kind message -> Location.alert loc ~kind (cat s message))
+    (alerts_of_attrs attrs)
+
+let check_alerts_inclusion ~def ~use loc attrs1 attrs2 s =
+  let m2 = alerts_of_attrs attrs2 in
+  Misc.Stdlib.String.Map.iter
+    (fun kind msg ->
+       if not (Misc.Stdlib.String.Map.mem kind m2) then
+         Location.alert ~def ~use ~kind loc (cat s msg)
+    )
+    (alerts_of_attrs attrs1)
+
+let rec deprecated_mutable_of_attrs = function
+  | [] -> None
+  | {attr_name =  {txt = "ocaml.deprecated_mutable"|"deprecated_mutable"; _};
+     attr_payload = p} :: _ ->
+     Some (string_of_opt_payload p)
+  | _ :: tl -> deprecated_mutable_of_attrs tl
+
+let check_deprecated_mutable loc attrs s =
+  match deprecated_mutable_of_attrs attrs with
+  | None -> ()
+  | Some txt ->
+      Location.deprecated loc (Printf.sprintf "mutating field %s" (cat s txt))
+
+let check_deprecated_mutable_inclusion ~def ~use loc attrs1 attrs2 s =
+  match deprecated_mutable_of_attrs attrs1,
+        deprecated_mutable_of_attrs attrs2
+  with
+  | None, _ | Some _, Some _ -> ()
+  | Some txt, None ->
+      Location.deprecated ~def ~use loc
+        (Printf.sprintf "mutating field %s" (cat s txt))
+
+let rec attrs_of_sig = function
+  | {psig_desc = Psig_attribute a} :: tl ->
+      a :: attrs_of_sig tl
+  | _ ->
+      []
+
+let alerts_of_sig sg = alerts_of_attrs (attrs_of_sig sg)
+
+let rec attrs_of_str = function
+  | {pstr_desc = Pstr_attribute a} :: tl ->
+      a :: attrs_of_str tl
+  | _ ->
+      []
+
+let alerts_of_str str = alerts_of_attrs (attrs_of_str str)
+
+let check_no_alert attrs =
+  List.iter
+    (fun (a, _, _) ->
+       Location.prerr_warning a.attr_loc
+         (Warnings.Misplaced_attribute a.attr_name.txt)
+    )
+    (alert_attrs attrs)
+
+let warn_payload loc txt msg =
+  Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg))
+
+let warning_attribute ?(ppwarning = true) =
+  let process loc txt errflag payload =
+    match string_of_payload payload with
+    | Some s ->
+        begin try Warnings.parse_options errflag s
+        with Arg.Bad msg -> warn_payload loc txt msg
+        end
+    | None ->
+        warn_payload loc txt "A single string literal is expected"
+  in
+  let process_alert loc txt = function
+    | PStr[{pstr_desc=
+              Pstr_eval(
+                {pexp_desc=Pexp_constant(Pconst_string(s,_,_))},
+                _)
+           }] ->
+        begin try Warnings.parse_alert_option s
+        with Arg.Bad msg -> warn_payload loc txt msg
+        end
+    | k ->
+        match kind_and_message k with
+        | Some ("all", _) ->
+            warn_payload loc txt "The alert name 'all' is reserved"
+        | Some _ -> ()
+        | None -> warn_payload loc txt "Invalid payload"
+  in
+  function
+  | {attr_name = {txt = ("ocaml.warning"|"warning") as txt; _};
+     attr_loc;
+     attr_payload;
+     } ->
+      process attr_loc txt false attr_payload
+  | {attr_name = {txt = ("ocaml.warnerror"|"warnerror") as txt; _};
+     attr_loc;
+     attr_payload
+    } ->
+      process attr_loc txt true attr_payload
+  | {attr_name = {txt="ocaml.ppwarning"|"ppwarning"; _};
+     attr_loc = _;
+     attr_payload =
+       PStr [
+         { pstr_desc=
+             Pstr_eval({pexp_desc=Pexp_constant (Pconst_string (s, _, _))},_);
+           pstr_loc }
+       ];
+    } when ppwarning ->
+     Location.prerr_warning pstr_loc (Warnings.Preprocessor s)
+  | {attr_name = {txt = ("ocaml.alert"|"alert") as txt; _};
+     attr_loc;
+     attr_payload;
+     } ->
+      process_alert attr_loc txt attr_payload
+  | _ ->
+     ()
+
+let warning_scope ?ppwarning attrs f =
+  let prev = Warnings.backup () in
+  try
+    List.iter (warning_attribute ?ppwarning) (List.rev attrs);
+    let ret = f () in
+    Warnings.restore prev;
+    ret
+  with exn ->
+    Warnings.restore prev;
+    raise exn
+
+
+let warn_on_literal_pattern =
+  List.exists
+    (fun a -> match a.attr_name.txt with
+       | "ocaml.warn_on_literal_pattern"|"warn_on_literal_pattern" -> true
+       | _ -> false
+    )
+
+let explicit_arity =
+  List.exists
+    (fun a -> match a.attr_name.txt with
+       | "ocaml.explicit_arity"|"explicit_arity" -> true
+       | _ -> false
+    )
+
+let immediate =
+  List.exists
+    (fun a -> match a.attr_name.txt with
+       | "ocaml.immediate"|"immediate" -> true
+       | _ -> false
+    )
+
+let immediate64 =
+  List.exists
+    (fun a -> match a.attr_name.txt with
+       | "ocaml.immediate64"|"immediate64" -> true
+       | _ -> false
+    )
+
+(* The "ocaml.boxed (default)" and "ocaml.unboxed (default)"
+   attributes cannot be input by the user, they are added by the
+   compiler when applying the default setting. This is done to record
+   in the .cmi the default used by the compiler when compiling the
+   source file because the default can change between compiler
+   invocations. *)
+
+let check l a = List.mem a.attr_name.txt l
+
+let has_unboxed attr =
+  List.exists (check ["ocaml.unboxed"; "unboxed"])
+    attr
+
+let has_boxed attr =
+  List.exists (check ["ocaml.boxed"; "boxed"]) attr
diff --git a/upstream/ocaml_411/parsing/builtin_attributes.mli b/upstream/ocaml_411/parsing/builtin_attributes.mli
new file mode 100644
index 0000000..6200fd7
--- /dev/null
+++ b/upstream/ocaml_411/parsing/builtin_attributes.mli
@@ -0,0 +1,84 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Support for some of the builtin attributes
+
+    - ocaml.deprecated
+    - ocaml.alert
+    - ocaml.error
+    - ocaml.ppwarning
+    - ocaml.warning
+    - ocaml.warnerror
+    - ocaml.explicit_arity (for camlp4/camlp5)
+    - ocaml.warn_on_literal_pattern
+    - ocaml.deprecated_mutable
+    - ocaml.immediate
+    - ocaml.immediate64
+    - ocaml.boxed / ocaml.unboxed
+
+    {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+val check_alerts: Location.t -> Parsetree.attributes -> string -> unit
+val check_alerts_inclusion:
+  def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes ->
+  Parsetree.attributes -> string -> unit
+val alerts_of_attrs: Parsetree.attributes -> Misc.alerts
+val alerts_of_sig: Parsetree.signature -> Misc.alerts
+val alerts_of_str: Parsetree.structure -> Misc.alerts
+
+val check_deprecated_mutable:
+    Location.t -> Parsetree.attributes -> string -> unit
+val check_deprecated_mutable_inclusion:
+  def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes ->
+  Parsetree.attributes -> string -> unit
+
+val check_no_alert: Parsetree.attributes -> unit
+
+val error_of_extension: Parsetree.extension -> Location.error
+
+val warning_attribute: ?ppwarning:bool -> Parsetree.attribute -> unit
+  (** Apply warning settings from the specified attribute.
+      "ocaml.warning"/"ocaml.warnerror" (and variants without the prefix)
+      are processed and other attributes are ignored.
+
+      Also implement ocaml.ppwarning (unless ~ppwarning:false is
+      passed).
+  *)
+
+val warning_scope:
+  ?ppwarning:bool ->
+  Parsetree.attributes -> (unit -> 'a) -> 'a
+  (** Execute a function in a new scope for warning settings.  This
+      means that the effect of any call to [warning_attribute] during
+      the execution of this function will be discarded after
+      execution.
+
+      The function also takes a list of attributes which are processed
+      with [warning_attribute] in the fresh scope before the function
+      is executed.
+  *)
+
+val warn_on_literal_pattern: Parsetree.attributes -> bool
+val explicit_arity: Parsetree.attributes -> bool
+
+
+val immediate: Parsetree.attributes -> bool
+val immediate64: Parsetree.attributes -> bool
+
+val has_unboxed: Parsetree.attributes -> bool
+val has_boxed: Parsetree.attributes -> bool
diff --git a/upstream/ocaml_411/parsing/docstrings.ml b/upstream/ocaml_411/parsing/docstrings.ml
new file mode 100644
index 0000000..987365a
--- /dev/null
+++ b/upstream/ocaml_411/parsing/docstrings.ml
@@ -0,0 +1,425 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                               Leo White                                *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Location
+
+(* Docstrings *)
+
+(* A docstring is "attached" if it has been inserted in the AST. This
+   is used for generating unexpected docstring warnings. *)
+type ds_attached =
+  | Unattached   (* Not yet attached anything.*)
+  | Info         (* Attached to a field or constructor. *)
+  | Docs         (* Attached to an item or as floating text. *)
+
+(* A docstring is "associated" with an item if there are no blank lines between
+   them. This is used for generating docstring ambiguity warnings. *)
+type ds_associated =
+  | Zero             (* Not associated with an item *)
+  | One              (* Associated with one item *)
+  | Many             (* Associated with multiple items (ambiguity) *)
+
+type docstring =
+  { ds_body: string;
+    ds_loc: Location.t;
+    mutable ds_attached: ds_attached;
+    mutable ds_associated: ds_associated; }
+
+(* List of docstrings *)
+
+let docstrings : docstring list ref = ref []
+
+(* Warn for unused and ambiguous docstrings *)
+
+let warn_bad_docstrings () =
+  if Warnings.is_active (Warnings.Bad_docstring true) then begin
+    List.iter
+      (fun ds ->
+         match ds.ds_attached with
+         | Info -> ()
+         | Unattached ->
+           prerr_warning ds.ds_loc (Warnings.Bad_docstring true)
+         | Docs ->
+             match ds.ds_associated with
+             | Zero | One -> ()
+             | Many ->
+               prerr_warning ds.ds_loc (Warnings.Bad_docstring false))
+      (List.rev !docstrings)
+end
+
+(* Docstring constructors and destructors *)
+
+let docstring body loc =
+  let ds =
+    { ds_body = body;
+      ds_loc = loc;
+      ds_attached = Unattached;
+      ds_associated = Zero; }
+  in
+  ds
+
+let register ds =
+  docstrings := ds :: !docstrings
+
+let docstring_body ds = ds.ds_body
+
+let docstring_loc ds = ds.ds_loc
+
+(* Docstrings attached to items *)
+
+type docs =
+  { docs_pre: docstring option;
+    docs_post: docstring option; }
+
+let empty_docs = { docs_pre = None; docs_post = None }
+
+let doc_loc = {txt = "ocaml.doc"; loc = Location.none}
+
+let docs_attr ds =
+  let open Parsetree in
+  let body = ds.ds_body in
+  let loc = ds.ds_loc in
+  let exp =
+    { pexp_desc = Pexp_constant (Pconst_string(body, loc, None));
+      pexp_loc = loc;
+      pexp_loc_stack = [];
+      pexp_attributes = []; }
+  in
+  let item =
+    { pstr_desc = Pstr_eval (exp, []); pstr_loc = loc }
+  in
+  { attr_name = doc_loc;
+    attr_payload = PStr [item];
+    attr_loc = loc }
+
+let add_docs_attrs docs attrs =
+  let attrs =
+    match docs.docs_pre with
+    | None | Some { ds_body=""; _ } -> attrs
+    | Some ds -> docs_attr ds :: attrs
+  in
+  let attrs =
+    match docs.docs_post with
+    | None | Some { ds_body=""; _ } -> attrs
+    | Some ds -> attrs @ [docs_attr ds]
+  in
+  attrs
+
+(* Docstrings attached to constructors or fields *)
+
+type info = docstring option
+
+let empty_info = None
+
+let info_attr = docs_attr
+
+let add_info_attrs info attrs =
+  match info with
+  | None | Some {ds_body=""; _} -> attrs
+  | Some ds -> attrs @ [info_attr ds]
+
+(* Docstrings not attached to a specific item *)
+
+type text = docstring list
+
+let empty_text = []
+let empty_text_lazy = lazy []
+
+let text_loc = {txt = "ocaml.text"; loc = Location.none}
+
+let text_attr ds =
+  let open Parsetree in
+  let body = ds.ds_body in
+  let loc = ds.ds_loc in
+  let exp =
+    { pexp_desc = Pexp_constant (Pconst_string(body, loc, None));
+      pexp_loc = loc;
+      pexp_loc_stack = [];
+      pexp_attributes = []; }
+  in
+  let item =
+    { pstr_desc = Pstr_eval (exp, []); pstr_loc = loc }
+  in
+  { attr_name = text_loc;
+    attr_payload = PStr [item];
+    attr_loc = loc }
+
+let add_text_attrs dsl attrs =
+  let fdsl = List.filter (function {ds_body=""} -> false| _ ->true) dsl in
+  (List.map text_attr fdsl) @ attrs
+
+(* Find the first non-info docstring in a list, attach it and return it *)
+let get_docstring ~info dsl =
+  let rec loop = function
+    | [] -> None
+    | {ds_attached = Info; _} :: rest -> loop rest
+    | ds :: _ ->
+        ds.ds_attached <- if info then Info else Docs;
+        Some ds
+  in
+  loop dsl
+
+(* Find all the non-info docstrings in a list, attach them and return them *)
+let get_docstrings dsl =
+  let rec loop acc = function
+    | [] -> List.rev acc
+    | {ds_attached = Info; _} :: rest -> loop acc rest
+    | ds :: rest ->
+        ds.ds_attached <- Docs;
+        loop (ds :: acc) rest
+  in
+    loop [] dsl
+
+(* "Associate" all the docstrings in a list *)
+let associate_docstrings dsl =
+  List.iter
+    (fun ds ->
+       match ds.ds_associated with
+       | Zero -> ds.ds_associated <- One
+       | (One | Many) -> ds.ds_associated <- Many)
+    dsl
+
+(* Map from positions to pre docstrings *)
+
+let pre_table : (Lexing.position, docstring list) Hashtbl.t =
+  Hashtbl.create 50
+
+let set_pre_docstrings pos dsl =
+  if dsl <> [] then Hashtbl.add pre_table pos dsl
+
+let get_pre_docs pos =
+  try
+    let dsl = Hashtbl.find pre_table pos in
+      associate_docstrings dsl;
+      get_docstring ~info:false dsl
+  with Not_found -> None
+
+let mark_pre_docs pos =
+  try
+    let dsl = Hashtbl.find pre_table pos in
+      associate_docstrings dsl
+  with Not_found -> ()
+
+(* Map from positions to post docstrings *)
+
+let post_table : (Lexing.position, docstring list) Hashtbl.t =
+  Hashtbl.create 50
+
+let set_post_docstrings pos dsl =
+  if dsl <> [] then Hashtbl.add post_table pos dsl
+
+let get_post_docs pos =
+  try
+    let dsl = Hashtbl.find post_table pos in
+      associate_docstrings dsl;
+      get_docstring ~info:false dsl
+  with Not_found -> None
+
+let mark_post_docs pos =
+  try
+    let dsl = Hashtbl.find post_table pos in
+      associate_docstrings dsl
+  with Not_found -> ()
+
+let get_info pos =
+  try
+    let dsl = Hashtbl.find post_table pos in
+      get_docstring ~info:true dsl
+  with Not_found -> None
+
+(* Map from positions to floating docstrings *)
+
+let floating_table : (Lexing.position, docstring list) Hashtbl.t =
+  Hashtbl.create 50
+
+let set_floating_docstrings pos dsl =
+  if dsl <> [] then Hashtbl.add floating_table pos dsl
+
+let get_text pos =
+  try
+    let dsl = Hashtbl.find floating_table pos in
+      get_docstrings dsl
+  with Not_found -> []
+
+let get_post_text pos =
+  try
+    let dsl = Hashtbl.find post_table pos in
+      get_docstrings dsl
+  with Not_found -> []
+
+(* Maps from positions to extra docstrings *)
+
+let pre_extra_table : (Lexing.position, docstring list) Hashtbl.t =
+  Hashtbl.create 50
+
+let set_pre_extra_docstrings pos dsl =
+  if dsl <> [] then Hashtbl.add pre_extra_table pos dsl
+
+let get_pre_extra_text pos =
+  try
+    let dsl = Hashtbl.find pre_extra_table pos in
+      get_docstrings dsl
+  with Not_found -> []
+
+let post_extra_table : (Lexing.position, docstring list) Hashtbl.t =
+  Hashtbl.create 50
+
+let set_post_extra_docstrings pos dsl =
+  if dsl <> [] then Hashtbl.add post_extra_table pos dsl
+
+let get_post_extra_text pos =
+  try
+    let dsl = Hashtbl.find post_extra_table pos in
+      get_docstrings dsl
+  with Not_found -> []
+
+(* Docstrings from parser actions *)
+module WithParsing = struct
+let symbol_docs () =
+  { docs_pre = get_pre_docs (Parsing.symbol_start_pos ());
+    docs_post = get_post_docs (Parsing.symbol_end_pos ()); }
+
+let symbol_docs_lazy () =
+  let p1 = Parsing.symbol_start_pos () in
+  let p2 = Parsing.symbol_end_pos () in
+    lazy { docs_pre = get_pre_docs p1;
+           docs_post = get_post_docs p2; }
+
+let rhs_docs pos1 pos2 =
+  { docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1);
+    docs_post = get_post_docs (Parsing.rhs_end_pos pos2); }
+
+let rhs_docs_lazy pos1 pos2 =
+  let p1 = Parsing.rhs_start_pos pos1 in
+  let p2 = Parsing.rhs_end_pos pos2 in
+    lazy { docs_pre = get_pre_docs p1;
+           docs_post = get_post_docs p2; }
+
+let mark_symbol_docs () =
+  mark_pre_docs (Parsing.symbol_start_pos ());
+  mark_post_docs (Parsing.symbol_end_pos ())
+
+let mark_rhs_docs pos1 pos2 =
+  mark_pre_docs (Parsing.rhs_start_pos pos1);
+  mark_post_docs (Parsing.rhs_end_pos pos2)
+
+let symbol_info () =
+  get_info (Parsing.symbol_end_pos ())
+
+let rhs_info pos =
+  get_info (Parsing.rhs_end_pos pos)
+
+let symbol_text () =
+  get_text (Parsing.symbol_start_pos ())
+
+let symbol_text_lazy () =
+  let pos = Parsing.symbol_start_pos () in
+    lazy (get_text pos)
+
+let rhs_text pos =
+  get_text (Parsing.rhs_start_pos pos)
+
+let rhs_post_text pos =
+  get_post_text (Parsing.rhs_end_pos pos)
+
+let rhs_text_lazy pos =
+  let pos = Parsing.rhs_start_pos pos in
+    lazy (get_text pos)
+
+let symbol_pre_extra_text () =
+  get_pre_extra_text (Parsing.symbol_start_pos ())
+
+let symbol_post_extra_text () =
+  get_post_extra_text (Parsing.symbol_end_pos ())
+
+let rhs_pre_extra_text pos =
+  get_pre_extra_text (Parsing.rhs_start_pos pos)
+
+let rhs_post_extra_text pos =
+  get_post_extra_text (Parsing.rhs_end_pos pos)
+end
+
+include WithParsing
+
+module WithMenhir = struct
+let symbol_docs (startpos, endpos) =
+  { docs_pre = get_pre_docs startpos;
+    docs_post = get_post_docs endpos; }
+
+let symbol_docs_lazy (p1, p2) =
+  lazy { docs_pre = get_pre_docs p1;
+         docs_post = get_post_docs p2; }
+
+let rhs_docs pos1 pos2 =
+  { docs_pre = get_pre_docs pos1;
+    docs_post = get_post_docs pos2; }
+
+let rhs_docs_lazy p1 p2 =
+    lazy { docs_pre = get_pre_docs p1;
+           docs_post = get_post_docs p2; }
+
+let mark_symbol_docs (startpos, endpos) =
+  mark_pre_docs startpos;
+  mark_post_docs endpos;
+  ()
+
+let mark_rhs_docs pos1 pos2 =
+  mark_pre_docs pos1;
+  mark_post_docs pos2;
+  ()
+
+let symbol_info endpos =
+  get_info endpos
+
+let rhs_info endpos =
+  get_info endpos
+
+let symbol_text startpos =
+  get_text startpos
+
+let symbol_text_lazy startpos =
+  lazy (get_text startpos)
+
+let rhs_text pos =
+  get_text pos
+
+let rhs_post_text pos =
+  get_post_text pos
+
+let rhs_text_lazy pos =
+  lazy (get_text pos)
+
+let symbol_pre_extra_text startpos =
+  get_pre_extra_text startpos
+
+let symbol_post_extra_text endpos =
+  get_post_extra_text endpos
+
+let rhs_pre_extra_text pos =
+  get_pre_extra_text pos
+
+let rhs_post_extra_text pos =
+  get_post_extra_text pos
+end
+
+(* (Re)Initialise all comment state *)
+
+let init () =
+  docstrings := [];
+  Hashtbl.reset pre_table;
+  Hashtbl.reset post_table;
+  Hashtbl.reset floating_table;
+  Hashtbl.reset pre_extra_table;
+  Hashtbl.reset post_extra_table
diff --git a/upstream/ocaml_411/parsing/docstrings.mli b/upstream/ocaml_411/parsing/docstrings.mli
new file mode 100644
index 0000000..bf2508f
--- /dev/null
+++ b/upstream/ocaml_411/parsing/docstrings.mli
@@ -0,0 +1,223 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                               Leo White                                *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Documentation comments
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+(** (Re)Initialise all docstring state *)
+val init : unit -> unit
+
+(** Emit warnings for unattached and ambiguous docstrings *)
+val warn_bad_docstrings : unit -> unit
+
+(** {2 Docstrings} *)
+
+(** Documentation comments *)
+type docstring
+
+(** Create a docstring *)
+val docstring : string -> Location.t -> docstring
+
+(** Register a docstring *)
+val register : docstring -> unit
+
+(** Get the text of a docstring *)
+val docstring_body : docstring -> string
+
+(** Get the location of a docstring *)
+val docstring_loc : docstring -> Location.t
+
+(** {2 Set functions}
+
+   These functions are used by the lexer to associate docstrings to
+   the locations of tokens. *)
+
+(** Docstrings immediately preceding a token *)
+val set_pre_docstrings : Lexing.position -> docstring list -> unit
+
+(** Docstrings immediately following a token *)
+val set_post_docstrings : Lexing.position -> docstring list -> unit
+
+(** Docstrings not immediately adjacent to a token *)
+val set_floating_docstrings : Lexing.position -> docstring list -> unit
+
+(** Docstrings immediately following the token which precedes this one *)
+val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit
+
+(** Docstrings immediately preceding the token which follows this one *)
+val set_post_extra_docstrings : Lexing.position -> docstring list -> unit
+
+(** {2 Items}
+
+    The {!docs} type represents documentation attached to an item. *)
+
+type docs =
+  { docs_pre: docstring option;
+    docs_post: docstring option; }
+
+val empty_docs : docs
+
+val docs_attr : docstring -> Parsetree.attribute
+
+(** Convert item documentation to attributes and add them to an
+    attribute list *)
+val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes
+
+(** Fetch the item documentation for the current symbol. This also
+    marks this documentation (for ambiguity warnings). *)
+val symbol_docs : unit -> docs
+val symbol_docs_lazy : unit -> docs Lazy.t
+
+(** Fetch the item documentation for the symbols between two
+    positions. This also marks this documentation (for ambiguity
+    warnings). *)
+val rhs_docs : int -> int -> docs
+val rhs_docs_lazy : int -> int -> docs Lazy.t
+
+(** Mark the item documentation for the current symbol (for ambiguity
+    warnings). *)
+val mark_symbol_docs : unit -> unit
+
+(** Mark as associated the item documentation for the symbols between
+    two positions (for ambiguity warnings) *)
+val mark_rhs_docs : int -> int -> unit
+
+(** {2 Fields and constructors}
+
+    The {!info} type represents documentation attached to a field or
+    constructor. *)
+
+type info = docstring option
+
+val empty_info : info
+
+val info_attr : docstring -> Parsetree.attribute
+
+(** Convert field info to attributes and add them to an
+    attribute list *)
+val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes
+
+(** Fetch the field info for the current symbol. *)
+val symbol_info : unit -> info
+
+(** Fetch the field info following the symbol at a given position. *)
+val rhs_info : int -> info
+
+(** {2 Unattached comments}
+
+    The {!text} type represents documentation which is not attached to
+    anything. *)
+
+type text = docstring list
+
+val empty_text : text
+val empty_text_lazy : text Lazy.t
+
+val text_attr : docstring -> Parsetree.attribute
+
+(** Convert text to attributes and add them to an attribute list *)
+val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes
+
+(** Fetch the text preceding the current symbol. *)
+val symbol_text : unit -> text
+val symbol_text_lazy : unit -> text Lazy.t
+
+(** Fetch the text preceding the symbol at the given position. *)
+val rhs_text : int -> text
+val rhs_text_lazy : int -> text Lazy.t
+
+(** {2 Extra text}
+
+    There may be additional text attached to the delimiters of a block
+    (e.g. [struct] and [end]). This is fetched by the following
+    functions, which are applied to the contents of the block rather
+    than the delimiters. *)
+
+(** Fetch additional text preceding the current symbol *)
+val symbol_pre_extra_text : unit -> text
+
+(** Fetch additional text following the current symbol *)
+val symbol_post_extra_text : unit -> text
+
+(** Fetch additional text preceding the symbol at the given position *)
+val rhs_pre_extra_text : int -> text
+
+(** Fetch additional text following the symbol at the given position *)
+val rhs_post_extra_text : int -> text
+
+(** Fetch text following the symbol at the given position *)
+val rhs_post_text : int -> text
+
+module WithMenhir: sig
+(** Fetch the item documentation for the current symbol. This also
+    marks this documentation (for ambiguity warnings). *)
+val symbol_docs : Lexing.position * Lexing.position -> docs
+val symbol_docs_lazy : Lexing.position * Lexing.position -> docs Lazy.t
+
+(** Fetch the item documentation for the symbols between two
+    positions. This also marks this documentation (for ambiguity
+    warnings). *)
+val rhs_docs : Lexing.position -> Lexing.position -> docs
+val rhs_docs_lazy : Lexing.position -> Lexing.position -> docs Lazy.t
+
+(** Mark the item documentation for the current symbol (for ambiguity
+    warnings). *)
+val mark_symbol_docs : Lexing.position * Lexing.position -> unit
+
+(** Mark as associated the item documentation for the symbols between
+    two positions (for ambiguity warnings) *)
+val mark_rhs_docs : Lexing.position -> Lexing.position -> unit
+
+(** Fetch the field info for the current symbol. *)
+val symbol_info : Lexing.position -> info
+
+(** Fetch the field info following the symbol at a given position. *)
+val rhs_info : Lexing.position -> info
+
+(** Fetch the text preceding the current symbol. *)
+val symbol_text : Lexing.position -> text
+val symbol_text_lazy : Lexing.position -> text Lazy.t
+
+(** Fetch the text preceding the symbol at the given position. *)
+val rhs_text : Lexing.position -> text
+val rhs_text_lazy : Lexing.position -> text Lazy.t
+
+(** {3 Extra text}
+
+    There may be additional text attached to the delimiters of a block
+    (e.g. [struct] and [end]). This is fetched by the following
+    functions, which are applied to the contents of the block rather
+    than the delimiters. *)
+
+(** Fetch additional text preceding the current symbol *)
+val symbol_pre_extra_text : Lexing.position -> text
+
+(** Fetch additional text following the current symbol *)
+val symbol_post_extra_text : Lexing.position -> text
+
+(** Fetch additional text preceding the symbol at the given position *)
+val rhs_pre_extra_text : Lexing.position -> text
+
+(** Fetch additional text following the symbol at the given position *)
+val rhs_post_extra_text : Lexing.position -> text
+
+(** Fetch text following the symbol at the given position *)
+val rhs_post_text : Lexing.position -> text
+
+end
diff --git a/upstream/ocaml_411/parsing/lexer.mli b/upstream/ocaml_411/parsing/lexer.mli
new file mode 100644
index 0000000..cde2ad5
--- /dev/null
+++ b/upstream/ocaml_411/parsing/lexer.mli
@@ -0,0 +1,64 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** The lexical analyzer
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+val init : unit -> unit
+val token: Lexing.lexbuf -> Parser.token
+val skip_hash_bang: Lexing.lexbuf -> unit
+
+type error =
+  | Illegal_character of char
+  | Illegal_escape of string * string option
+  | Reserved_sequence of string * string option
+  | Unterminated_comment of Location.t
+  | Unterminated_string
+  | Unterminated_string_in_comment of Location.t * Location.t
+  | Keyword_as_label of string
+  | Invalid_literal of string
+  | Invalid_directive of string * string option
+;;
+
+exception Error of error * Location.t
+
+val in_comment : unit -> bool;;
+val in_string : unit -> bool;;
+
+
+val print_warnings : bool ref
+val handle_docstrings: bool ref
+val comments : unit -> (string * Location.t) list
+val token_with_comments : Lexing.lexbuf -> Parser.token
+
+(*
+  [set_preprocessor init preprocessor] registers [init] as the function
+to call to initialize the preprocessor when the lexer is initialized,
+and [preprocessor] a function that is called when a new token is needed
+by the parser, as [preprocessor lexer lexbuf] where [lexer] is the
+lexing function.
+
+When a preprocessor is configured by calling [set_preprocessor], the lexer
+changes its behavior to accept backslash-newline as a token-separating blank.
+*)
+
+val set_preprocessor :
+  (unit -> unit) ->
+  ((Lexing.lexbuf -> Parser.token) -> Lexing.lexbuf -> Parser.token) ->
+  unit
diff --git a/upstream/ocaml_411/parsing/lexer.mll b/upstream/ocaml_411/parsing/lexer.mll
new file mode 100644
index 0000000..6d68b59
--- /dev/null
+++ b/upstream/ocaml_411/parsing/lexer.mll
@@ -0,0 +1,858 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* The lexer definition *)
+
+{
+open Lexing
+open Misc
+open Parser
+
+type error =
+  | Illegal_character of char
+  | Illegal_escape of string * string option
+  | Reserved_sequence of string * string option
+  | Unterminated_comment of Location.t
+  | Unterminated_string
+  | Unterminated_string_in_comment of Location.t * Location.t
+  | Keyword_as_label of string
+  | Invalid_literal of string
+  | Invalid_directive of string * string option
+;;
+
+exception Error of error * Location.t;;
+
+(* The table of keywords *)
+
+let keyword_table =
+  create_hashtable 149 [
+    "and", AND;
+    "as", AS;
+    "assert", ASSERT;
+    "begin", BEGIN;
+    "class", CLASS;
+    "constraint", CONSTRAINT;
+    "do", DO;
+    "done", DONE;
+    "downto", DOWNTO;
+    "else", ELSE;
+    "end", END;
+    "exception", EXCEPTION;
+    "external", EXTERNAL;
+    "false", FALSE;
+    "for", FOR;
+    "fun", FUN;
+    "function", FUNCTION;
+    "functor", FUNCTOR;
+    "if", IF;
+    "in", IN;
+    "include", INCLUDE;
+    "inherit", INHERIT;
+    "initializer", INITIALIZER;
+    "lazy", LAZY;
+    "let", LET;
+    "match", MATCH;
+    "method", METHOD;
+    "module", MODULE;
+    "mutable", MUTABLE;
+    "new", NEW;
+    "nonrec", NONREC;
+    "object", OBJECT;
+    "of", OF;
+    "open", OPEN;
+    "or", OR;
+(*  "parser", PARSER; *)
+    "private", PRIVATE;
+    "rec", REC;
+    "sig", SIG;
+    "struct", STRUCT;
+    "then", THEN;
+    "to", TO;
+    "true", TRUE;
+    "try", TRY;
+    "type", TYPE;
+    "val", VAL;
+    "virtual", VIRTUAL;
+    "when", WHEN;
+    "while", WHILE;
+    "with", WITH;
+
+    "lor", INFIXOP3("lor"); (* Should be INFIXOP2 *)
+    "lxor", INFIXOP3("lxor"); (* Should be INFIXOP2 *)
+    "mod", INFIXOP3("mod");
+    "land", INFIXOP3("land");
+    "lsl", INFIXOP4("lsl");
+    "lsr", INFIXOP4("lsr");
+    "asr", INFIXOP4("asr")
+]
+
+(* To buffer string literals *)
+
+let string_buffer = Buffer.create 256
+let reset_string_buffer () = Buffer.reset string_buffer
+let get_stored_string () = Buffer.contents string_buffer
+
+let store_string_char c = Buffer.add_char string_buffer c
+let store_string_utf_8_uchar u = Buffer.add_utf_8_uchar string_buffer u
+let store_string s = Buffer.add_string string_buffer s
+let store_lexeme lexbuf = store_string (Lexing.lexeme lexbuf)
+
+(* To store the position of the beginning of a string and comment *)
+let string_start_loc = ref Location.none;;
+let comment_start_loc = ref [];;
+let in_comment () = !comment_start_loc <> [];;
+let is_in_string = ref false
+let in_string () = !is_in_string
+let print_warnings = ref true
+
+(* Escaped chars are interpreted in strings unless they are in comments. *)
+let store_escaped_char lexbuf c =
+  if in_comment () then store_lexeme lexbuf else store_string_char c
+
+let store_escaped_uchar lexbuf u =
+  if in_comment () then store_lexeme lexbuf else store_string_utf_8_uchar u
+
+let compute_quoted_string_idloc {Location.loc_start = orig_loc } shift id =
+  let id_start_pos = orig_loc.Lexing.pos_cnum + shift in
+  let loc_start =
+    Lexing.{orig_loc with pos_cnum = id_start_pos }
+  in
+  let loc_end =
+    Lexing.{orig_loc with pos_cnum = id_start_pos + String.length id}
+  in
+  {Location. loc_start ; loc_end ; loc_ghost = false }
+
+let wrap_string_lexer f lexbuf =
+  let loc_start = lexbuf.lex_curr_p in
+  reset_string_buffer();
+  is_in_string := true;
+  let string_start = lexbuf.lex_start_p in
+  string_start_loc := Location.curr lexbuf;
+  let loc_end = f lexbuf in
+  is_in_string := false;
+  lexbuf.lex_start_p <- string_start;
+  let loc = Location.{loc_ghost= false; loc_start; loc_end} in
+  get_stored_string (), loc
+
+let wrap_comment_lexer comment lexbuf =
+  let start_loc = Location.curr lexbuf  in
+  comment_start_loc := [start_loc];
+  reset_string_buffer ();
+  let end_loc = comment lexbuf in
+  let s = get_stored_string () in
+  reset_string_buffer ();
+  s,
+  { start_loc with Location.loc_end = end_loc.Location.loc_end }
+
+let error lexbuf e = raise (Error(e, Location.curr lexbuf))
+let error_loc loc e = raise (Error(e, loc))
+
+(* to translate escape sequences *)
+
+let digit_value c =
+  match c with
+  | 'a' .. 'f' -> 10 + Char.code c - Char.code 'a'
+  | 'A' .. 'F' -> 10 + Char.code c - Char.code 'A'
+  | '0' .. '9' -> Char.code c - Char.code '0'
+  | _ -> assert false
+
+let num_value lexbuf ~base ~first ~last =
+  let c = ref 0 in
+  for i = first to last do
+    let v = digit_value (Lexing.lexeme_char lexbuf i) in
+    assert(v < base);
+    c := (base * !c) + v
+  done;
+  !c
+
+let char_for_backslash = function
+  | 'n' -> '\010'
+  | 'r' -> '\013'
+  | 'b' -> '\008'
+  | 't' -> '\009'
+  | c   -> c
+
+let illegal_escape lexbuf reason =
+  let error = Illegal_escape (Lexing.lexeme lexbuf, Some reason) in
+  raise (Error (error, Location.curr lexbuf))
+
+let char_for_decimal_code lexbuf i =
+  let c = num_value lexbuf ~base:10 ~first:i ~last:(i+2) in
+  if (c < 0 || c > 255) then
+    if in_comment ()
+    then 'x'
+    else
+      illegal_escape lexbuf
+        (Printf.sprintf
+          "%d is outside the range of legal characters (0-255)." c)
+  else Char.chr c
+
+let char_for_octal_code lexbuf i =
+  let c = num_value lexbuf ~base:8 ~first:i ~last:(i+2) in
+  if (c < 0 || c > 255) then
+    if in_comment ()
+    then 'x'
+    else
+      illegal_escape lexbuf
+        (Printf.sprintf
+          "o%o (=%d) is outside the range of legal characters (0-255)." c c)
+  else Char.chr c
+
+let char_for_hexadecimal_code lexbuf i =
+  Char.chr (num_value lexbuf ~base:16 ~first:i ~last:(i+1))
+
+let uchar_for_uchar_escape lexbuf =
+  let len = Lexing.lexeme_end lexbuf - Lexing.lexeme_start lexbuf in
+  let first = 3 (* skip opening \u{ *) in
+  let last = len - 2 (* skip closing } *) in
+  let digit_count = last - first + 1 in
+  match digit_count > 6 with
+  | true ->
+      illegal_escape lexbuf
+        "too many digits, expected 1 to 6 hexadecimal digits"
+  | false ->
+      let cp = num_value lexbuf ~base:16 ~first ~last in
+      if Uchar.is_valid cp then Uchar.unsafe_of_int cp else
+      illegal_escape lexbuf
+        (Printf.sprintf "%X is not a Unicode scalar value" cp)
+
+let is_keyword name = Hashtbl.mem keyword_table name
+
+let check_label_name lexbuf name =
+  if is_keyword name then error lexbuf (Keyword_as_label name)
+
+(* Update the current location with file name and line number. *)
+
+let update_loc lexbuf file line absolute chars =
+  let pos = lexbuf.lex_curr_p in
+  let new_file = match file with
+                 | None -> pos.pos_fname
+                 | Some s -> s
+  in
+  lexbuf.lex_curr_p <- { pos with
+    pos_fname = new_file;
+    pos_lnum = if absolute then line else pos.pos_lnum + line;
+    pos_bol = pos.pos_cnum - chars;
+  }
+;;
+
+let preprocessor = ref None
+
+let escaped_newlines = ref false
+
+(* Warn about Latin-1 characters used in idents *)
+
+let warn_latin1 lexbuf =
+  Location.deprecated
+    (Location.curr lexbuf)
+    "ISO-Latin1 characters in identifiers"
+
+let handle_docstrings = ref true
+let comment_list = ref []
+
+let add_comment com =
+  comment_list := com :: !comment_list
+
+let add_docstring_comment ds =
+  let com =
+    ("*" ^ Docstrings.docstring_body ds, Docstrings.docstring_loc ds)
+  in
+    add_comment com
+
+let comments () = List.rev !comment_list
+
+(* Error report *)
+
+open Format
+
+let prepare_error loc = function
+  | Illegal_character c ->
+      Location.errorf ~loc "Illegal character (%s)" (Char.escaped c)
+  | Illegal_escape (s, explanation) ->
+      Location.errorf ~loc
+        "Illegal backslash escape in string or character (%s)%t" s
+        (fun ppf -> match explanation with
+           | None -> ()
+           | Some expl -> fprintf ppf ": %s" expl)
+  | Reserved_sequence (s, explanation) ->
+      Location.errorf ~loc
+        "Reserved character sequence: %s%t" s
+        (fun ppf -> match explanation with
+           | None -> ()
+           | Some expl -> fprintf ppf " %s" expl)
+  | Unterminated_comment _ ->
+      Location.errorf ~loc "Comment not terminated"
+  | Unterminated_string ->
+      Location.errorf ~loc "String literal not terminated"
+  | Unterminated_string_in_comment (_, literal_loc) ->
+      Location.errorf ~loc
+        "This comment contains an unterminated string literal"
+        ~sub:[Location.msg ~loc:literal_loc "String literal begins here"]
+  | Keyword_as_label kwd ->
+      Location.errorf ~loc
+        "`%s' is a keyword, it cannot be used as label name" kwd
+  | Invalid_literal s ->
+      Location.errorf ~loc "Invalid literal %s" s
+  | Invalid_directive (dir, explanation) ->
+      Location.errorf ~loc "Invalid lexer directive %S%t" dir
+        (fun ppf -> match explanation with
+           | None -> ()
+           | Some expl -> fprintf ppf ": %s" expl)
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (err, loc) ->
+          Some (prepare_error loc err)
+      | _ ->
+          None
+    )
+
+}
+
+let newline = ('\013'* '\010')
+let blank = [' ' '\009' '\012']
+let lowercase = ['a'-'z' '_']
+let uppercase = ['A'-'Z']
+let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9']
+let lowercase_latin1 = ['a'-'z' '\223'-'\246' '\248'-'\255' '_']
+let uppercase_latin1 = ['A'-'Z' '\192'-'\214' '\216'-'\222']
+let identchar_latin1 =
+  ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
+let symbolchar =
+  ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
+let dotsymbolchar =
+  ['!' '$' '%' '&' '*' '+' '-' '/' ':' '=' '>' '?' '@' '^' '|']
+let kwdopchar =
+  ['$' '&' '*' '+' '-' '/' '<' '=' '>' '@' '^' '|']
+
+let ident = (lowercase | uppercase) identchar*
+let extattrident = ident ('.' ident)*
+
+let decimal_literal =
+  ['0'-'9'] ['0'-'9' '_']*
+let hex_digit =
+  ['0'-'9' 'A'-'F' 'a'-'f']
+let hex_literal =
+  '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']['0'-'9' 'A'-'F' 'a'-'f' '_']*
+let oct_literal =
+  '0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']*
+let bin_literal =
+  '0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']*
+let int_literal =
+  decimal_literal | hex_literal | oct_literal | bin_literal
+let float_literal =
+  ['0'-'9'] ['0'-'9' '_']*
+  ('.' ['0'-'9' '_']* )?
+  (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )?
+let hex_float_literal =
+  '0' ['x' 'X']
+  ['0'-'9' 'A'-'F' 'a'-'f'] ['0'-'9' 'A'-'F' 'a'-'f' '_']*
+  ('.' ['0'-'9' 'A'-'F' 'a'-'f' '_']* )?
+  (['p' 'P'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )?
+let literal_modifier = ['G'-'Z' 'g'-'z']
+
+rule token = parse
+  | ('\\' as bs) newline {
+      if not !escaped_newlines then error lexbuf (Illegal_character bs);
+      update_loc lexbuf None 1 false 0;
+      token lexbuf }
+  | newline
+      { update_loc lexbuf None 1 false 0;
+        EOL }
+  | blank +
+      { token lexbuf }
+  | "_"
+      { UNDERSCORE }
+  | "~"
+      { TILDE }
+  | ".~"
+      { error lexbuf
+          (Reserved_sequence (".~", Some "is reserved for use in MetaOCaml")) }
+  | "~" (lowercase identchar * as name) ':'
+      { check_label_name lexbuf name;
+        LABEL name }
+  | "~" (lowercase_latin1 identchar_latin1 * as name) ':'
+      { warn_latin1 lexbuf;
+        LABEL name }
+  | "?"
+      { QUESTION }
+  | "?" (lowercase identchar * as name) ':'
+      { check_label_name lexbuf name;
+        OPTLABEL name }
+  | "?" (lowercase_latin1 identchar_latin1 * as name) ':'
+      { warn_latin1 lexbuf;
+        OPTLABEL name }
+  | lowercase identchar * as name
+      { try Hashtbl.find keyword_table name
+        with Not_found -> LIDENT name }
+  | lowercase_latin1 identchar_latin1 * as name
+      { warn_latin1 lexbuf; LIDENT name }
+  | uppercase identchar * as name
+      { UIDENT name } (* No capitalized keywords *)
+  | uppercase_latin1 identchar_latin1 * as name
+      { warn_latin1 lexbuf; UIDENT name }
+  | int_literal as lit { INT (lit, None) }
+  | (int_literal as lit) (literal_modifier as modif)
+      { INT (lit, Some modif) }
+  | float_literal | hex_float_literal as lit
+      { FLOAT (lit, None) }
+  | (float_literal | hex_float_literal as lit) (literal_modifier as modif)
+      { FLOAT (lit, Some modif) }
+  | (float_literal | hex_float_literal | int_literal) identchar+ as invalid
+      { error lexbuf (Invalid_literal invalid) }
+  | "\""
+      { let s, loc = wrap_string_lexer string lexbuf in
+        STRING (s, loc, None) }
+  | "{" (lowercase* as delim) "|"
+      { let s, loc = wrap_string_lexer (quoted_string delim) lexbuf in
+        STRING (s, loc, Some delim) }
+  | "{%" (extattrident as id) "|"
+      { let orig_loc = Location.curr lexbuf in
+        let s, loc = wrap_string_lexer (quoted_string "") lexbuf in
+        let idloc = compute_quoted_string_idloc orig_loc 2 id in
+        QUOTED_STRING_EXPR (id, idloc, s, loc, Some "") }
+  | "{%" (extattrident as id) blank+ (lowercase* as delim) "|"
+      { let orig_loc = Location.curr lexbuf in
+        let s, loc = wrap_string_lexer (quoted_string delim) lexbuf in
+        let idloc = compute_quoted_string_idloc orig_loc 2 id in
+        QUOTED_STRING_EXPR (id, idloc, s, loc, Some delim) }
+  | "{%%" (extattrident as id) "|"
+      { let orig_loc = Location.curr lexbuf in
+        let s, loc = wrap_string_lexer (quoted_string "") lexbuf in
+        let idloc = compute_quoted_string_idloc orig_loc 3 id in
+        QUOTED_STRING_ITEM (id, idloc, s, loc, Some "") }
+  | "{%%" (extattrident as id) blank+ (lowercase* as delim) "|"
+      { let orig_loc = Location.curr lexbuf in
+        let s, loc = wrap_string_lexer (quoted_string delim) lexbuf in
+        let idloc = compute_quoted_string_idloc orig_loc 3 id in
+        QUOTED_STRING_ITEM (id, idloc, s, loc, Some delim) }
+  | "\'" newline "\'"
+      { update_loc lexbuf None 1 false 1;
+        (* newline is ('\013'* '\010') *)
+        CHAR '\n' }
+  | "\'" ([^ '\\' '\'' '\010' '\013'] as c) "\'"
+      { CHAR c }
+  | "\'\\" (['\\' '\'' '\"' 'n' 't' 'b' 'r' ' '] as c) "\'"
+      { CHAR (char_for_backslash c) }
+  | "\'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "\'"
+      { CHAR(char_for_decimal_code lexbuf 2) }
+  | "\'\\" 'o' ['0'-'7'] ['0'-'7'] ['0'-'7'] "\'"
+      { CHAR(char_for_octal_code lexbuf 3) }
+  | "\'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "\'"
+      { CHAR(char_for_hexadecimal_code lexbuf 3) }
+  | "\'" ("\\" _ as esc)
+      { error lexbuf (Illegal_escape (esc, None)) }
+  | "(*"
+      { let s, loc = wrap_comment_lexer comment lexbuf in
+        COMMENT (s, loc) }
+  | "(**"
+      { let s, loc = wrap_comment_lexer comment lexbuf in
+        if !handle_docstrings then
+          DOCSTRING (Docstrings.docstring s loc)
+        else
+          COMMENT ("*" ^ s, loc)
+      }
+  | "(**" (('*'+) as stars)
+      { let s, loc =
+          wrap_comment_lexer
+            (fun lexbuf ->
+               store_string ("*" ^ stars);
+               comment lexbuf)
+            lexbuf
+        in
+        COMMENT (s, loc) }
+  | "(*)"
+      { if !print_warnings then
+          Location.prerr_warning (Location.curr lexbuf) Warnings.Comment_start;
+        let s, loc = wrap_comment_lexer comment lexbuf in
+        COMMENT (s, loc) }
+  | "(*" (('*'*) as stars) "*)"
+      { if !handle_docstrings && stars="" then
+         (* (**) is an empty docstring *)
+          DOCSTRING(Docstrings.docstring "" (Location.curr lexbuf))
+        else
+          COMMENT (stars, Location.curr lexbuf) }
+  | "*)"
+      { let loc = Location.curr lexbuf in
+        Location.prerr_warning loc Warnings.Comment_not_end;
+        lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1;
+        let curpos = lexbuf.lex_curr_p in
+        lexbuf.lex_curr_p <- { curpos with pos_cnum = curpos.pos_cnum - 1 };
+        STAR
+      }
+  | "#"
+      { let at_beginning_of_line pos = (pos.pos_cnum = pos.pos_bol) in
+        if not (at_beginning_of_line lexbuf.lex_start_p)
+        then HASH
+        else try directive lexbuf with Failure _ -> HASH
+      }
+  | "&"  { AMPERSAND }
+  | "&&" { AMPERAMPER }
+  | "`"  { BACKQUOTE }
+  | "\'" { QUOTE }
+  | "("  { LPAREN }
+  | ")"  { RPAREN }
+  | "*"  { STAR }
+  | ","  { COMMA }
+  | "->" { MINUSGREATER }
+  | "."  { DOT }
+  | ".." { DOTDOT }
+  | "." (dotsymbolchar symbolchar* as op) { DOTOP op }
+  | ":"  { COLON }
+  | "::" { COLONCOLON }
+  | ":=" { COLONEQUAL }
+  | ":>" { COLONGREATER }
+  | ";"  { SEMI }
+  | ";;" { SEMISEMI }
+  | "<"  { LESS }
+  | "<-" { LESSMINUS }
+  | "="  { EQUAL }
+  | "["  { LBRACKET }
+  | "[|" { LBRACKETBAR }
+  | "[<" { LBRACKETLESS }
+  | "[>" { LBRACKETGREATER }
+  | "]"  { RBRACKET }
+  | "{"  { LBRACE }
+  | "{<" { LBRACELESS }
+  | "|"  { BAR }
+  | "||" { BARBAR }
+  | "|]" { BARRBRACKET }
+  | ">"  { GREATER }
+  | ">]" { GREATERRBRACKET }
+  | "}"  { RBRACE }
+  | ">}" { GREATERRBRACE }
+  | "[@" { LBRACKETAT }
+  | "[@@"  { LBRACKETATAT }
+  | "[@@@" { LBRACKETATATAT }
+  | "[%"   { LBRACKETPERCENT }
+  | "[%%"  { LBRACKETPERCENTPERCENT }
+  | "!"  { BANG }
+  | "!=" { INFIXOP0 "!=" }
+  | "+"  { PLUS }
+  | "+." { PLUSDOT }
+  | "+=" { PLUSEQ }
+  | "-"  { MINUS }
+  | "-." { MINUSDOT }
+
+  | "!" symbolchar + as op
+            { PREFIXOP op }
+  | ['~' '?'] symbolchar + as op
+            { PREFIXOP op }
+  | ['=' '<' '>' '|' '&' '$'] symbolchar * as op
+            { INFIXOP0 op }
+  | ['@' '^'] symbolchar * as op
+            { INFIXOP1 op }
+  | ['+' '-'] symbolchar * as op
+            { INFIXOP2 op }
+  | "**" symbolchar * as op
+            { INFIXOP4 op }
+  | '%'     { PERCENT }
+  | ['*' '/' '%'] symbolchar * as op
+            { INFIXOP3 op }
+  | '#' (symbolchar | '#') + as op
+            { HASHOP op }
+  | "let" kwdopchar dotsymbolchar * as op
+            { LETOP op }
+  | "and" kwdopchar dotsymbolchar * as op
+            { ANDOP op }
+  | eof { EOF }
+  | (_ as illegal_char)
+      { error lexbuf (Illegal_character illegal_char) }
+
+and directive = parse
+  | ([' ' '\t']* (['0'-'9']+ as num) [' ' '\t']*
+        ("\"" ([^ '\010' '\013' '\"' ] * as name) "\"") as directive)
+        [^ '\010' '\013'] *
+      {
+        match int_of_string num with
+        | exception _ ->
+            (* PR#7165 *)
+            let explanation = "line number out of range" in
+            error lexbuf (Invalid_directive ("#" ^ directive, Some explanation))
+        | line_num ->
+           (* Documentation says that the line number should be
+              positive, but we have never guarded against this and it
+              might have useful hackish uses. *)
+            update_loc lexbuf (Some name) (line_num - 1) true 0;
+            token lexbuf
+      }
+and comment = parse
+    "(*"
+      { comment_start_loc := (Location.curr lexbuf) :: !comment_start_loc;
+        store_lexeme lexbuf;
+        comment lexbuf
+      }
+  | "*)"
+      { match !comment_start_loc with
+        | [] -> assert false
+        | [_] -> comment_start_loc := []; Location.curr lexbuf
+        | _ :: l -> comment_start_loc := l;
+                  store_lexeme lexbuf;
+                  comment lexbuf
+       }
+  | "\""
+      {
+        string_start_loc := Location.curr lexbuf;
+        store_string_char '\"';
+        is_in_string := true;
+        let _loc = try string lexbuf
+        with Error (Unterminated_string, str_start) ->
+          match !comment_start_loc with
+          | [] -> assert false
+          | loc :: _ ->
+            let start = List.hd (List.rev !comment_start_loc) in
+            comment_start_loc := [];
+            error_loc loc (Unterminated_string_in_comment (start, str_start))
+        in
+        is_in_string := false;
+        store_string_char '\"';
+        comment lexbuf }
+  | "{" ('%' '%'? extattrident blank*)? (lowercase* as delim) "|"
+      {
+        string_start_loc := Location.curr lexbuf;
+        store_lexeme lexbuf;
+        is_in_string := true;
+        let _loc = try quoted_string delim lexbuf
+        with Error (Unterminated_string, str_start) ->
+          match !comment_start_loc with
+          | [] -> assert false
+          | loc :: _ ->
+            let start = List.hd (List.rev !comment_start_loc) in
+            comment_start_loc := [];
+            error_loc loc (Unterminated_string_in_comment (start, str_start))
+        in
+        is_in_string := false;
+        store_string_char '|';
+        store_string delim;
+        store_string_char '}';
+        comment lexbuf }
+  | "\'\'"
+      { store_lexeme lexbuf; comment lexbuf }
+  | "\'" newline "\'"
+      { update_loc lexbuf None 1 false 1;
+        store_lexeme lexbuf;
+        comment lexbuf
+      }
+  | "\'" [^ '\\' '\'' '\010' '\013' ] "\'"
+      { store_lexeme lexbuf; comment lexbuf }
+  | "\'\\" ['\\' '\"' '\'' 'n' 't' 'b' 'r' ' '] "\'"
+      { store_lexeme lexbuf; comment lexbuf }
+  | "\'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "\'"
+      { store_lexeme lexbuf; comment lexbuf }
+  | "\'\\" 'o' ['0'-'3'] ['0'-'7'] ['0'-'7'] "\'"
+      { store_lexeme lexbuf; comment lexbuf }
+  | "\'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "\'"
+      { store_lexeme lexbuf; comment lexbuf }
+  | eof
+      { match !comment_start_loc with
+        | [] -> assert false
+        | loc :: _ ->
+          let start = List.hd (List.rev !comment_start_loc) in
+          comment_start_loc := [];
+          error_loc loc (Unterminated_comment start)
+      }
+  | newline
+      { update_loc lexbuf None 1 false 0;
+        store_lexeme lexbuf;
+        comment lexbuf
+      }
+  | ident
+      { store_lexeme lexbuf; comment lexbuf }
+  | _
+      { store_lexeme lexbuf; comment lexbuf }
+
+and string = parse
+    '\"'
+      { lexbuf.lex_start_p }
+  | '\\' newline ([' ' '\t'] * as space)
+      { update_loc lexbuf None 1 false (String.length space);
+        if in_comment () then store_lexeme lexbuf;
+        string lexbuf
+      }
+  | '\\' (['\\' '\'' '\"' 'n' 't' 'b' 'r' ' '] as c)
+      { store_escaped_char lexbuf (char_for_backslash c);
+        string lexbuf }
+  | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9']
+      { store_escaped_char lexbuf (char_for_decimal_code lexbuf 1);
+         string lexbuf }
+  | '\\' 'o' ['0'-'7'] ['0'-'7'] ['0'-'7']
+      { store_escaped_char lexbuf (char_for_octal_code lexbuf 2);
+         string lexbuf }
+  | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F']
+      { store_escaped_char lexbuf (char_for_hexadecimal_code lexbuf 2);
+         string lexbuf }
+  | '\\' 'u' '{' hex_digit+ '}'
+        { store_escaped_uchar lexbuf (uchar_for_uchar_escape lexbuf);
+          string lexbuf }
+  | '\\' _
+      { if not (in_comment ()) then begin
+(*  Should be an error, but we are very lax.
+          error lexbuf (Illegal_escape (Lexing.lexeme lexbuf, None))
+*)
+          let loc = Location.curr lexbuf in
+          Location.prerr_warning loc Warnings.Illegal_backslash;
+        end;
+        store_lexeme lexbuf;
+        string lexbuf
+      }
+  | newline
+      { if not (in_comment ()) then
+          Location.prerr_warning (Location.curr lexbuf) Warnings.Eol_in_string;
+        update_loc lexbuf None 1 false 0;
+        store_lexeme lexbuf;
+        string lexbuf
+      }
+  | eof
+      { is_in_string := false;
+        error_loc !string_start_loc Unterminated_string }
+  | (_ as c)
+      { store_string_char c;
+        string lexbuf }
+
+and quoted_string delim = parse
+  | newline
+      { update_loc lexbuf None 1 false 0;
+        store_lexeme lexbuf;
+        quoted_string delim lexbuf
+      }
+  | eof
+      { is_in_string := false;
+        error_loc !string_start_loc Unterminated_string }
+  | "|" (lowercase* as edelim) "}"
+      {
+        if delim = edelim then lexbuf.lex_start_p
+        else (store_lexeme lexbuf; quoted_string delim lexbuf)
+      }
+  | (_ as c)
+      { store_string_char c;
+        quoted_string delim lexbuf }
+
+and skip_hash_bang = parse
+  | "#!" [^ '\n']* '\n' [^ '\n']* "\n!#\n"
+      { update_loc lexbuf None 3 false 0 }
+  | "#!" [^ '\n']* '\n'
+      { update_loc lexbuf None 1 false 0 }
+  | "" { () }
+
+{
+
+  let token_with_comments lexbuf =
+    match !preprocessor with
+    | None -> token lexbuf
+    | Some (_init, preprocess) -> preprocess token lexbuf
+
+  type newline_state =
+    | NoLine (* There have been no blank lines yet. *)
+    | NewLine
+        (* There have been no blank lines, and the previous
+           token was a newline. *)
+    | BlankLine (* There have been blank lines. *)
+
+  type doc_state =
+    | Initial  (* There have been no docstrings yet *)
+    | After of docstring list
+        (* There have been docstrings, none of which were
+           preceded by a blank line *)
+    | Before of docstring list * docstring list * docstring list
+        (* There have been docstrings, some of which were
+           preceded by a blank line *)
+
+  and docstring = Docstrings.docstring
+
+  let token lexbuf =
+    let post_pos = lexeme_end_p lexbuf in
+    let attach lines docs pre_pos =
+      let open Docstrings in
+        match docs, lines with
+        | Initial, _ -> ()
+        | After a, (NoLine | NewLine) ->
+            set_post_docstrings post_pos (List.rev a);
+            set_pre_docstrings pre_pos a;
+        | After a, BlankLine ->
+            set_post_docstrings post_pos (List.rev a);
+            set_pre_extra_docstrings pre_pos (List.rev a)
+        | Before(a, f, b), (NoLine | NewLine) ->
+            set_post_docstrings post_pos (List.rev a);
+            set_post_extra_docstrings post_pos
+              (List.rev_append f (List.rev b));
+            set_floating_docstrings pre_pos (List.rev f);
+            set_pre_extra_docstrings pre_pos (List.rev a);
+            set_pre_docstrings pre_pos b
+        | Before(a, f, b), BlankLine ->
+            set_post_docstrings post_pos (List.rev a);
+            set_post_extra_docstrings post_pos
+              (List.rev_append f (List.rev b));
+            set_floating_docstrings pre_pos
+              (List.rev_append f (List.rev b));
+            set_pre_extra_docstrings pre_pos (List.rev a)
+    in
+    let rec loop lines docs lexbuf =
+      match token_with_comments lexbuf with
+      | COMMENT (s, loc) ->
+          add_comment (s, loc);
+          let lines' =
+            match lines with
+            | NoLine -> NoLine
+            | NewLine -> NoLine
+            | BlankLine -> BlankLine
+          in
+          loop lines' docs lexbuf
+      | EOL ->
+          let lines' =
+            match lines with
+            | NoLine -> NewLine
+            | NewLine -> BlankLine
+            | BlankLine -> BlankLine
+          in
+          loop lines' docs lexbuf
+      | DOCSTRING doc ->
+          Docstrings.register doc;
+          add_docstring_comment doc;
+          let docs' =
+            if Docstrings.docstring_body doc = "/*" then
+              match docs with
+              | Initial -> Before([], [doc], [])
+              | After a -> Before (a, [doc], [])
+              | Before(a, f, b) -> Before(a, doc :: b @ f, [])
+            else
+              match docs, lines with
+              | Initial, (NoLine | NewLine) -> After [doc]
+              | Initial, BlankLine -> Before([], [], [doc])
+              | After a, (NoLine | NewLine) -> After (doc :: a)
+              | After a, BlankLine -> Before (a, [], [doc])
+              | Before(a, f, b), (NoLine | NewLine) -> Before(a, f, doc :: b)
+              | Before(a, f, b), BlankLine -> Before(a, b @ f, [doc])
+          in
+          loop NoLine docs' lexbuf
+      | tok ->
+          attach lines docs (lexeme_start_p lexbuf);
+          tok
+    in
+      loop NoLine Initial lexbuf
+
+  let init () =
+    is_in_string := false;
+    comment_start_loc := [];
+    comment_list := [];
+    match !preprocessor with
+    | None -> ()
+    | Some (init, _preprocess) -> init ()
+
+  let set_preprocessor init preprocess =
+    escaped_newlines := true;
+    preprocessor := Some (init, preprocess)
+
+}
diff --git a/upstream/ocaml_411/parsing/location.ml b/upstream/ocaml_411/parsing/location.ml
new file mode 100644
index 0000000..aa596c8
--- /dev/null
+++ b/upstream/ocaml_411/parsing/location.ml
@@ -0,0 +1,943 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Lexing
+
+type t = Warnings.loc =
+  { loc_start: position; loc_end: position; loc_ghost: bool };;
+
+let in_file name =
+  let loc = { dummy_pos with pos_fname = name } in
+  { loc_start = loc; loc_end = loc; loc_ghost = true }
+;;
+
+let none = in_file "_none_";;
+let is_none l = (l = none);;
+
+let curr lexbuf = {
+  loc_start = lexbuf.lex_start_p;
+  loc_end = lexbuf.lex_curr_p;
+  loc_ghost = false
+};;
+
+let init lexbuf fname =
+  lexbuf.lex_curr_p <- {
+    pos_fname = fname;
+    pos_lnum = 1;
+    pos_bol = 0;
+    pos_cnum = 0;
+  }
+;;
+
+let symbol_rloc () = {
+  loc_start = Parsing.symbol_start_pos ();
+  loc_end = Parsing.symbol_end_pos ();
+  loc_ghost = false;
+};;
+
+let symbol_gloc () = {
+  loc_start = Parsing.symbol_start_pos ();
+  loc_end = Parsing.symbol_end_pos ();
+  loc_ghost = true;
+};;
+
+let rhs_loc n = {
+  loc_start = Parsing.rhs_start_pos n;
+  loc_end = Parsing.rhs_end_pos n;
+  loc_ghost = false;
+};;
+
+let rhs_interval m n = {
+  loc_start = Parsing.rhs_start_pos m;
+  loc_end = Parsing.rhs_end_pos n;
+  loc_ghost = false;
+};;
+
+(* return file, line, char from the given position *)
+let get_pos_info pos =
+  (pos.pos_fname, pos.pos_lnum, pos.pos_cnum - pos.pos_bol)
+;;
+
+type 'a loc = {
+  txt : 'a;
+  loc : t;
+}
+
+let mkloc txt loc = { txt ; loc }
+let mknoloc txt = mkloc txt none
+
+(******************************************************************************)
+(* Input info *)
+
+let input_name = ref "_none_"
+let input_lexbuf = ref (None : lexbuf option)
+let input_phrase_buffer = ref (None : Buffer.t option)
+
+(******************************************************************************)
+(* Terminal info *)
+
+let status = ref Terminfo.Uninitialised
+
+let setup_terminal () =
+  if !status = Terminfo.Uninitialised then
+    status := Terminfo.setup stdout
+
+(* The number of lines already printed after input.
+
+   This is used by [highlight_terminfo] to identify the current position of the
+   input in the terminal. This would not be possible without this information,
+   since printing several warnings/errors adds text between the user input and
+   the bottom of the terminal.
+*)
+let num_loc_lines = ref 0
+
+(* This is used by the toplevel to reset [num_loc_lines] before each phrase *)
+let reset () =
+  num_loc_lines := 0
+
+(* This is used by the toplevel *)
+let echo_eof () =
+  print_newline ();
+  incr num_loc_lines
+
+(* Code printing errors and warnings must be wrapped using this function, in
+   order to update [num_loc_lines].
+
+   [print_updating_num_loc_lines ppf f arg] is equivalent to calling [f ppf
+   arg], and additionally updates [num_loc_lines]. *)
+let print_updating_num_loc_lines ppf f arg =
+  let open Format in
+  let out_functions = pp_get_formatter_out_functions ppf () in
+  let out_string str start len =
+    let rec count i c =
+      if i = start + len then c
+      else if String.get str i = '\n' then count (succ i) (succ c)
+      else count (succ i) c in
+    num_loc_lines := !num_loc_lines + count start 0 ;
+    out_functions.out_string str start len in
+  pp_set_formatter_out_functions ppf
+    { out_functions with out_string } ;
+  f ppf arg ;
+  pp_print_flush ppf ();
+  pp_set_formatter_out_functions ppf out_functions
+
+let setup_colors () =
+  Misc.Color.setup !Clflags.color
+
+(******************************************************************************)
+(* Printing locations, e.g. 'File "foo.ml", line 3, characters 10-12' *)
+
+let rewrite_absolute_path path =
+  match Misc.get_build_path_prefix_map () with
+  | None -> path
+  | Some map -> Build_path_prefix_map.rewrite map path
+
+let absolute_path s = (* This function could go into Filename *)
+  let open Filename in
+  let s =
+    if not (is_relative s) then s
+    else (rewrite_absolute_path (concat (Sys.getcwd ()) s))
+  in
+  (* Now simplify . and .. components *)
+  let rec aux s =
+    let base = basename s in
+    let dir = dirname s in
+    if dir = s then dir
+    else if base = current_dir_name then aux dir
+    else if base = parent_dir_name then dirname (aux dir)
+    else concat (aux dir) base
+  in
+  aux s
+
+let show_filename file =
+  if !Clflags.absname then absolute_path file else file
+
+let print_filename ppf file =
+  Format.pp_print_string ppf (show_filename file)
+
+(* Best-effort printing of the text describing a location, of the form
+   'File "foo.ml", line 3, characters 10-12'.
+
+   Some of the information (filename, line number or characters numbers) in the
+   location might be invalid; in which case we do not print it.
+ *)
+let print_loc ppf loc =
+  setup_colors ();
+  let file_valid = function
+    | "_none_" ->
+        (* This is a dummy placeholder, but we print it anyway to please editors
+           that parse locations in error messages (e.g. Emacs). *)
+        true
+    | "" | "//toplevel//" -> false
+    | _ -> true
+  in
+  let line_valid line = line > 0 in
+  let chars_valid ~startchar ~endchar = startchar <> -1 && endchar <> -1 in
+
+  let file =
+    (* According to the comment in location.mli, if [pos_fname] is "", we must
+       use [!input_name]. *)
+    if loc.loc_start.pos_fname = "" then !input_name
+    else loc.loc_start.pos_fname
+  in
+  let startline = loc.loc_start.pos_lnum in
+  let endline = loc.loc_end.pos_lnum in
+  let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in
+  let endchar = loc.loc_end.pos_cnum - loc.loc_end.pos_bol in
+
+  let first = ref true in
+  let capitalize s =
+    if !first then (first := false; String.capitalize_ascii s)
+    else s in
+  let comma () =
+    if !first then () else Format.fprintf ppf ", " in
+
+  Format.fprintf ppf "@{<loc>";
+
+  if file_valid file then
+    Format.fprintf ppf "%s \"%a\"" (capitalize "file") print_filename file;
+
+  (* Print "line 1" in the case of a dummy line number. This is to please the
+     existing setup of editors that parse locations in error messages (e.g.
+     Emacs). *)
+  comma ();
+  let startline = if line_valid startline then startline else 1 in
+  let endline = if line_valid endline then endline else startline in
+  begin if startline = endline then
+    Format.fprintf ppf "%s %i" (capitalize "line") startline
+  else
+    Format.fprintf ppf "%s %i-%i" (capitalize "lines") startline endline
+  end;
+
+  if chars_valid ~startchar ~endchar then (
+    comma ();
+    Format.fprintf ppf "%s %i-%i" (capitalize "characters") startchar endchar
+  );
+
+  Format.fprintf ppf "@}"
+
+(* Print a comma-separated list of locations *)
+let print_locs ppf locs =
+  Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ")
+    print_loc ppf locs
+
+(******************************************************************************)
+(* An interval set structure; additionally, it stores user-provided information
+   at interval boundaries.
+
+   The implementation provided here is naive and assumes the number of intervals
+   to be small, but the interface would allow for a more efficient
+   implementation if needed.
+
+   Note: the structure only stores maximal intervals (that therefore do not
+   overlap).
+*)
+
+module ISet : sig
+  type 'a bound = 'a * int
+  type 'a t
+  (* bounds are included *)
+  val of_intervals : ('a bound * 'a bound) list -> 'a t
+
+  val mem : 'a t -> pos:int -> bool
+  val find_bound_in : 'a t -> range:(int * int) -> 'a bound option
+
+  val is_start : 'a t -> pos:int -> 'a option
+  val is_end : 'a t -> pos:int -> 'a option
+
+  val extrema : 'a t -> ('a bound * 'a bound) option
+end
+=
+struct
+  type 'a bound = 'a * int
+
+  (* non overlapping intervals *)
+  type 'a t = ('a bound * 'a bound) list
+
+  let of_intervals intervals =
+    let pos =
+      List.map (fun ((a, x), (b, y)) ->
+        if x > y then [] else [((a, x), `S); ((b, y), `E)]
+      ) intervals
+      |> List.flatten
+      |> List.sort (fun ((_, x), k) ((_, y), k') ->
+        (* Make `S come before `E so that consecutive intervals get merged
+           together in the fold below *)
+        let kn = function `S -> 0 | `E -> 1 in
+        compare (x, kn k) (y, kn k'))
+    in
+    let nesting, acc =
+      List.fold_left (fun (nesting, acc) (a, kind) ->
+        match kind, nesting with
+        | `S, `Outside -> `Inside (a, 0), acc
+        | `S, `Inside (s, n) -> `Inside (s, n+1), acc
+        | `E, `Outside -> assert false
+        | `E, `Inside (s, 0) -> `Outside, ((s, a) :: acc)
+        | `E, `Inside (s, n) -> `Inside (s, n-1), acc
+      ) (`Outside, []) pos in
+    assert (nesting = `Outside);
+    List.rev acc
+
+  let mem iset ~pos =
+    List.exists (fun ((_, s), (_, e)) -> s <= pos && pos <= e) iset
+
+  let find_bound_in iset ~range:(start, end_)  =
+    Misc.Stdlib.List.find_map (fun ((a, x), (b, y)) ->
+      if start <= x && x <= end_ then Some (a, x)
+      else if start <= y && y <= end_ then Some (b, y)
+      else None
+    ) iset
+
+  let is_start iset ~pos =
+    Misc.Stdlib.List.find_map (fun ((a, x), _) ->
+      if pos = x then Some a else None
+    ) iset
+
+  let is_end iset ~pos =
+    Misc.Stdlib.List.find_map (fun (_, (b, y)) ->
+      if pos = y then Some b else None
+    ) iset
+
+  let extrema iset =
+    if iset = [] then None
+    else Some (fst (List.hd iset), snd (List.hd (List.rev iset)))
+end
+
+(******************************************************************************)
+(* Toplevel: highlighting and quoting locations *)
+
+(* Highlight the locations using standout mode.
+
+   If [locs] is empty, this function is a no-op.
+*)
+let highlight_terminfo lb ppf locs =
+  Format.pp_print_flush ppf ();  (* avoid mixing Format and normal output *)
+  (* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *)
+  let pos0 = -lb.lex_abs_pos in
+  (* Do nothing if the buffer does not contain the whole phrase. *)
+  if pos0 < 0 then raise Exit;
+  (* Count number of lines in phrase *)
+  let lines = ref !num_loc_lines in
+  for i = pos0 to lb.lex_buffer_len - 1 do
+    if Bytes.get lb.lex_buffer i = '\n' then incr lines
+  done;
+  (* If too many lines, give up *)
+  if !lines >= Terminfo.num_lines stdout - 2 then raise Exit;
+  (* Move cursor up that number of lines *)
+  flush stdout; Terminfo.backup stdout !lines;
+  (* Print the input, switching to standout for the location *)
+  let bol = ref false in
+  print_string "# ";
+  for pos = 0 to lb.lex_buffer_len - pos0 - 1 do
+    if !bol then (print_string "  "; bol := false);
+    if List.exists (fun loc -> pos = loc.loc_start.pos_cnum) locs then
+      Terminfo.standout stdout true;
+    if List.exists (fun loc -> pos = loc.loc_end.pos_cnum) locs then
+      Terminfo.standout stdout false;
+    let c = Bytes.get lb.lex_buffer (pos + pos0) in
+    print_char c;
+    bol := (c = '\n')
+  done;
+  (* Make sure standout mode is over *)
+  Terminfo.standout stdout false;
+  (* Position cursor back to original location *)
+  Terminfo.resume stdout !num_loc_lines;
+  flush stdout
+
+let highlight_terminfo lb ppf locs =
+  try highlight_terminfo lb ppf locs
+  with Exit -> ()
+
+(* Highlight the location by printing it again.
+
+   There are two different styles for highlighting errors in "dumb" mode,
+   depending if the error fits on a single line or spans across several lines.
+
+   For single-line errors,
+
+     foo the_error bar
+
+   gets displayed as follows, where X is the line number:
+
+     X | foo the_error bar
+             ^^^^^^^^^
+
+
+   For multi-line errors,
+
+     foo the_
+     error bar
+
+   gets displayed as:
+
+     X1 | ....the_
+     X2 | error....
+
+   An ellipsis hides the middle lines of the multi-line error if it has more
+   than [max_lines] lines.
+
+   If [locs] is empty then this function is a no-op.
+*)
+
+type input_line = {
+  text : string;
+  start_pos : int;
+}
+
+(* Takes a list of lines with possibly missing line numbers.
+
+   If the line numbers that are present are consistent with the number of lines
+   between them, then infer the intermediate line numbers.
+
+   This is not always the case, typically if lexer line directives are
+   involved... *)
+let infer_line_numbers
+    (lines: (int option * input_line) list):
+  (int option * input_line) list
+  =
+  let (_, offset, consistent) =
+    List.fold_left (fun (i, offset, consistent) (lnum, _) ->
+      match lnum, offset with
+      | None, _ -> (i+1, offset, consistent)
+      | Some n, None -> (i+1, Some (n - i), consistent)
+      | Some n, Some m -> (i+1, offset, consistent && n = m + i)
+    ) (0, None, true) lines
+  in
+  match offset, consistent with
+  | Some m, true ->
+      List.mapi (fun i (_, line) -> (Some (m + i), line)) lines
+  | _, _ ->
+      lines
+
+(* [get_lines] must return the lines to highlight, given starting and ending
+   positions.
+
+   See [lines_around_from_current_input] below for an instantiation of
+   [get_lines] that reads from the current input.
+*)
+let highlight_quote ppf
+    ~(get_lines: start_pos:position -> end_pos:position -> input_line list)
+    ?(max_lines = 10)
+    highlight_tag
+    locs
+  =
+  let iset = ISet.of_intervals @@ List.filter_map (fun loc ->
+    let s, e = loc.loc_start, loc.loc_end in
+    if s.pos_cnum = -1 || e.pos_cnum = -1 then None
+    else Some ((s, s.pos_cnum), (e, e.pos_cnum - 1))
+  ) locs in
+  match ISet.extrema iset with
+  | None -> ()
+  | Some ((leftmost, _), (rightmost, _)) ->
+      let lines =
+        get_lines ~start_pos:leftmost ~end_pos:rightmost
+        |> List.map (fun ({ text; start_pos } as line) ->
+          let end_pos = start_pos + String.length text - 1 in
+          let line_nb =
+            match ISet.find_bound_in iset ~range:(start_pos, end_pos) with
+            | None -> None
+            | Some (p, _) -> Some p.pos_lnum
+          in
+          (line_nb, line))
+        |> infer_line_numbers
+        |> List.map (fun (lnum, { text; start_pos }) ->
+          (text,
+           Option.fold ~some:Int.to_string ~none:"" lnum,
+           start_pos))
+      in
+    Format.fprintf ppf "@[<v>";
+    begin match lines with
+    | [] | [("", _, _)] -> ()
+    | [(line, line_nb, line_start_cnum)] ->
+        (* Single-line error *)
+        Format.fprintf ppf "%s | %s@," line_nb line;
+        Format.fprintf ppf "%*s   " (String.length line_nb) "";
+        for pos = line_start_cnum to rightmost.pos_cnum - 1 do
+          if ISet.is_start iset ~pos <> None then
+            Format.fprintf ppf "@{<%s>" highlight_tag;
+          if ISet.mem iset ~pos then Format.pp_print_char ppf '^'
+          else Format.pp_print_char ppf ' ';
+          if ISet.is_end iset ~pos <> None then
+            Format.fprintf ppf "@}"
+        done;
+        Format.fprintf ppf "@}@,"
+    | _ ->
+        (* Multi-line error *)
+        Misc.pp_two_columns ~sep:"|" ~max_lines ppf
+        @@ List.map (fun (line, line_nb, line_start_cnum) ->
+          let line = String.mapi (fun i car ->
+            if ISet.mem iset ~pos:(line_start_cnum + i) then car else '.'
+          ) line in
+          (line_nb, line)
+        ) lines
+    end;
+    Format.fprintf ppf "@]"
+
+
+
+let lines_around
+    ~(start_pos: position) ~(end_pos: position)
+    ~(seek: int -> unit)
+    ~(read_char: unit -> char option):
+  input_line list
+  =
+  seek start_pos.pos_bol;
+  let lines = ref [] in
+  let bol = ref start_pos.pos_bol in
+  let cur = ref start_pos.pos_bol in
+  let b = Buffer.create 80 in
+  let add_line () =
+    if !bol < !cur then begin
+      let text = Buffer.contents b in
+      Buffer.clear b;
+      lines := { text; start_pos = !bol } :: !lines;
+      bol := !cur
+    end
+  in
+  let rec loop () =
+    if !bol >= end_pos.pos_cnum then ()
+    else begin
+      match read_char () with
+      | None ->
+          (* end of input *)
+          add_line ()
+      | Some c ->
+          incr cur;
+          match c with
+          | '\r' -> loop ()
+          | '\n' -> add_line (); loop ()
+          | _ -> Buffer.add_char b c; loop ()
+    end
+  in
+  loop ();
+  List.rev !lines
+
+(* Try to get lines from a lexbuf *)
+let lines_around_from_lexbuf
+    ~(start_pos: position) ~(end_pos: position)
+    (lb: lexbuf):
+  input_line list
+  =
+  (* Converts a global position to one that is relative to the lexing buffer *)
+  let rel n = n - lb.lex_abs_pos in
+  if rel start_pos.pos_bol < 0 then begin
+    (* Do nothing if the buffer does not contain the input (because it has been
+       refilled while lexing it) *)
+    []
+  end else begin
+    let pos = ref 0 in (* relative position *)
+    let seek n = pos := rel n in
+    let read_char () =
+      if !pos >= lb.lex_buffer_len then (* end of buffer *) None
+      else
+        let c = Bytes.get lb.lex_buffer !pos in
+        incr pos; Some c
+    in
+    lines_around ~start_pos ~end_pos ~seek ~read_char
+  end
+
+(* Attempt to get lines from the phrase buffer *)
+let lines_around_from_phrasebuf
+    ~(start_pos: position) ~(end_pos: position)
+    (pb: Buffer.t):
+  input_line list
+  =
+  let pos = ref 0 in
+  let seek n = pos := n in
+  let read_char () =
+    if !pos >= Buffer.length pb then None
+    else begin
+      let c = Buffer.nth pb !pos in
+      incr pos; Some c
+    end
+  in
+  lines_around ~start_pos ~end_pos ~seek ~read_char
+
+(* Get lines from a file *)
+let lines_around_from_file
+    ~(start_pos: position) ~(end_pos: position)
+    (filename: string):
+  input_line list
+  =
+  try
+    let cin = open_in_bin filename in
+    let read_char () =
+      try Some (input_char cin) with End_of_file -> None
+    in
+    let lines =
+      lines_around ~start_pos ~end_pos ~seek:(seek_in cin) ~read_char
+    in
+    close_in cin;
+    lines
+  with Sys_error _ -> []
+
+(* A [get_lines] function for [highlight_quote] that reads from the current
+   input.
+
+   It first tries to read from [!input_lexbuf], then if that fails (because the
+   lexbuf no longer contains the input we want), it reads from [!input_name]
+   directly *)
+let lines_around_from_current_input ~start_pos ~end_pos =
+  (* Be a bit defensive, and do not try to open one of the possible
+     [!input_name] values that we know do not denote valid filenames. *)
+  let file_valid = function
+    | "//toplevel//" | "_none_" | "" -> false
+    | _ -> true
+  in
+  let from_file () =
+    if file_valid !input_name then
+      lines_around_from_file !input_name ~start_pos ~end_pos
+    else
+      []
+  in
+  match !input_lexbuf, !input_phrase_buffer, !input_name with
+  | _, Some pb, "//toplevel//" ->
+      begin match lines_around_from_phrasebuf pb ~start_pos ~end_pos with
+      | [] -> (* Could not read the input from the phrase buffer. This is likely
+                 a sign that we were given a buggy location. *)
+          []
+      | lines ->
+          lines
+      end
+  | Some lb, _, _ ->
+      begin match lines_around_from_lexbuf lb ~start_pos ~end_pos with
+      | [] -> (* The input is likely not in the lexbuf anymore *)
+          from_file ()
+      | lines ->
+          lines
+      end
+  | None, _, _ ->
+      from_file ()
+
+(******************************************************************************)
+(* Reporting errors and warnings *)
+
+type msg = (Format.formatter -> unit) loc
+
+let msg ?(loc = none) fmt =
+  Format.kdprintf (fun txt -> { loc; txt }) fmt
+
+type report_kind =
+  | Report_error
+  | Report_warning of string
+  | Report_warning_as_error of string
+  | Report_alert of string
+  | Report_alert_as_error of string
+
+type report = {
+  kind : report_kind;
+  main : msg;
+  sub : msg list;
+}
+
+type report_printer = {
+  (* The entry point *)
+  pp : report_printer ->
+    Format.formatter -> report -> unit;
+
+  pp_report_kind : report_printer -> report ->
+    Format.formatter -> report_kind -> unit;
+  pp_main_loc : report_printer -> report ->
+    Format.formatter -> t -> unit;
+  pp_main_txt : report_printer -> report ->
+    Format.formatter -> (Format.formatter -> unit) -> unit;
+  pp_submsgs : report_printer -> report ->
+    Format.formatter -> msg list -> unit;
+  pp_submsg : report_printer -> report ->
+    Format.formatter -> msg -> unit;
+  pp_submsg_loc : report_printer -> report ->
+    Format.formatter -> t -> unit;
+  pp_submsg_txt : report_printer -> report ->
+    Format.formatter -> (Format.formatter -> unit) -> unit;
+}
+
+let is_dummy_loc loc =
+  (* Fixme: this should be just [loc.loc_ghost] and the function should be
+     inlined below. However, currently, the compiler emits in some places ghost
+     locations with valid ranges that should still be printed. These locations
+     should be made non-ghost -- in the meantime we just check if the ranges are
+     valid. *)
+  loc.loc_start.pos_cnum = -1 || loc.loc_end.pos_cnum = -1
+
+(* It only makes sense to highlight (i.e. quote or underline the corresponding
+   source code) locations that originate from the current input.
+
+   As of now, this should only happen in the following cases:
+
+   - if dummy locs or ghost locs leak out of the compiler or a buggy ppx;
+
+   - more generally, if some code uses the compiler-libs API and feeds it
+   locations that do not match the current values of [!Location.input_name],
+   [!Location.input_lexbuf];
+
+   - when calling the compiler on a .ml file that contains lexer line directives
+   indicating an other file. This should happen relatively rarely in practice --
+   in particular this is not what happens when using -pp or -ppx or a ppx
+   driver.
+*)
+let is_quotable_loc loc =
+  not (is_dummy_loc loc)
+  && loc.loc_start.pos_fname = !input_name
+  && loc.loc_end.pos_fname = !input_name
+
+let error_style () =
+  match !Clflags.error_style with
+  | Some setting -> setting
+  | None -> Misc.Error_style.default_setting
+
+let batch_mode_printer : report_printer =
+  let pp_loc _self report ppf loc =
+    let tag = match report.kind with
+      | Report_warning_as_error _
+      | Report_alert_as_error _
+      | Report_error -> "error"
+      | Report_warning _
+      | Report_alert _ -> "warning"
+    in
+    let highlight ppf loc =
+      match error_style () with
+      | Misc.Error_style.Contextual ->
+          if is_quotable_loc loc then
+            highlight_quote ppf
+              ~get_lines:lines_around_from_current_input
+              tag [loc]
+      | Misc.Error_style.Short ->
+          ()
+    in
+    Format.fprintf ppf "@[<v>%a:@ %a@]" print_loc loc highlight loc
+  in
+  let pp_txt ppf txt = Format.fprintf ppf "@[%t@]" txt in
+  let pp self ppf report =
+    setup_colors ();
+    (* Make sure we keep [num_loc_lines] updated. *)
+    print_updating_num_loc_lines ppf (fun ppf () ->
+      Format.fprintf ppf "@[<v>%a%a: %a%a@]@."
+      (self.pp_main_loc self report) report.main.loc
+      (self.pp_report_kind self report) report.kind
+      (self.pp_main_txt self report) report.main.txt
+      (self.pp_submsgs self report) report.sub
+    ) ()
+  in
+  let pp_report_kind _self _ ppf = function
+    | Report_error -> Format.fprintf ppf "@{<error>Error@}"
+    | Report_warning w -> Format.fprintf ppf "@{<warning>Warning@} %s" w
+    | Report_warning_as_error w ->
+        Format.fprintf ppf "@{<error>Error@} (warning %s)" w
+    | Report_alert w -> Format.fprintf ppf "@{<warning>Alert@} %s" w
+    | Report_alert_as_error w ->
+        Format.fprintf ppf "@{<error>Error@} (alert %s)" w
+  in
+  let pp_main_loc self report ppf loc =
+    pp_loc self report ppf loc
+  in
+  let pp_main_txt _self _ ppf txt =
+    pp_txt ppf txt
+  in
+  let pp_submsgs self report ppf msgs =
+    List.iter (fun msg ->
+      Format.fprintf ppf "@,%a" (self.pp_submsg self report) msg
+    ) msgs
+  in
+  let pp_submsg self report ppf { loc; txt } =
+    Format.fprintf ppf "@[%a  %a@]"
+      (self.pp_submsg_loc self report) loc
+      (self.pp_submsg_txt self report) txt
+  in
+  let pp_submsg_loc self report ppf loc =
+    if not loc.loc_ghost then
+      pp_loc self report ppf loc
+  in
+  let pp_submsg_txt _self _ ppf loc =
+    pp_txt ppf loc
+  in
+  { pp; pp_report_kind; pp_main_loc; pp_main_txt;
+    pp_submsgs; pp_submsg; pp_submsg_loc; pp_submsg_txt }
+
+let terminfo_toplevel_printer (lb: lexbuf): report_printer =
+  let pp self ppf err =
+    setup_colors ();
+    (* Highlight all toplevel locations of the report, instead of displaying
+       the main location. Do it now instead of in [pp_main_loc], to avoid
+       messing with Format boxes. *)
+    let sub_locs = List.map (fun { loc; _ } -> loc) err.sub in
+    let all_locs = err.main.loc :: sub_locs in
+    let locs_highlighted = List.filter is_quotable_loc all_locs in
+    highlight_terminfo lb ppf locs_highlighted;
+    batch_mode_printer.pp self ppf err
+  in
+  let pp_main_loc _ _ _ _ = () in
+  let pp_submsg_loc _ _ ppf loc =
+    if not loc.loc_ghost then
+      Format.fprintf ppf "%a:@ " print_loc loc in
+  { batch_mode_printer with pp; pp_main_loc; pp_submsg_loc }
+
+let best_toplevel_printer () =
+  setup_terminal ();
+  match !status, !input_lexbuf with
+  | Terminfo.Good_term, Some lb ->
+      terminfo_toplevel_printer lb
+  | _, _ ->
+      batch_mode_printer
+
+(* Creates a printer for the current input *)
+let default_report_printer () : report_printer =
+  if !input_name = "//toplevel//" then
+    best_toplevel_printer ()
+  else
+    batch_mode_printer
+
+let report_printer = ref default_report_printer
+
+let print_report ppf report =
+  let printer = !report_printer () in
+  printer.pp printer ppf report
+
+(******************************************************************************)
+(* Reporting errors *)
+
+type error = report
+
+let report_error ppf err =
+  print_report ppf err
+
+let mkerror loc sub txt =
+  { kind = Report_error; main = { loc; txt }; sub }
+
+let errorf ?(loc = none) ?(sub = []) =
+  Format.kdprintf (mkerror loc sub)
+
+let error ?(loc = none) ?(sub = []) msg_str =
+  mkerror loc sub (fun ppf -> Format.pp_print_string ppf msg_str)
+
+let error_of_printer ?(loc = none) ?(sub = []) pp x =
+  mkerror loc sub (fun ppf -> pp ppf x)
+
+let error_of_printer_file print x =
+  error_of_printer ~loc:(in_file !input_name) print x
+
+(******************************************************************************)
+(* Reporting warnings: generating a report from a warning number using the
+   information in [Warnings] + convenience functions. *)
+
+let default_warning_alert_reporter report mk (loc: t) w : report option =
+  match report w with
+  | `Inactive -> None
+  | `Active { Warnings.id; message; is_error; sub_locs } ->
+      let msg_of_str str = fun ppf -> Format.pp_print_string ppf str in
+      let kind = mk is_error id in
+      let main = { loc; txt = msg_of_str message } in
+      let sub = List.map (fun (loc, sub_message) ->
+        { loc; txt = msg_of_str sub_message }
+      ) sub_locs in
+      Some { kind; main; sub }
+
+
+let default_warning_reporter =
+  default_warning_alert_reporter
+    Warnings.report
+    (fun is_error id ->
+       if is_error then Report_warning_as_error id
+       else Report_warning id
+    )
+
+let warning_reporter = ref default_warning_reporter
+let report_warning loc w = !warning_reporter loc w
+
+let formatter_for_warnings = ref Format.err_formatter
+
+let print_warning loc ppf w =
+  match report_warning loc w with
+  | None -> ()
+  | Some report -> print_report ppf report
+
+let prerr_warning loc w = print_warning loc !formatter_for_warnings w
+
+let default_alert_reporter =
+  default_warning_alert_reporter
+    Warnings.report_alert
+    (fun is_error id ->
+       if is_error then Report_alert_as_error id
+       else Report_alert id
+    )
+
+let alert_reporter = ref default_alert_reporter
+let report_alert loc w = !alert_reporter loc w
+
+let print_alert loc ppf w =
+  match report_alert loc w with
+  | None -> ()
+  | Some report -> print_report ppf report
+
+let prerr_alert loc w = print_alert loc !formatter_for_warnings w
+
+let alert ?(def = none) ?(use = none) ~kind loc message =
+  prerr_alert loc {Warnings.kind; message; def; use}
+
+let deprecated ?def ?use loc message =
+  alert ?def ?use ~kind:"deprecated" loc message
+
+(******************************************************************************)
+(* Reporting errors on exceptions *)
+
+let error_of_exn : (exn -> error option) list ref = ref []
+
+let register_error_of_exn f = error_of_exn := f :: !error_of_exn
+
+exception Already_displayed_error = Warnings.Errors
+
+let error_of_exn exn =
+  match exn with
+  | Already_displayed_error -> Some `Already_displayed
+  | _ ->
+     let rec loop = function
+       | [] -> None
+       | f :: rest ->
+          match f exn with
+          | Some error -> Some (`Ok error)
+          | None -> loop rest
+     in
+     loop !error_of_exn
+
+let () =
+  register_error_of_exn
+    (function
+      | Sys_error msg ->
+          Some (errorf ~loc:(in_file !input_name) "I/O error: %s" msg)
+      | _ -> None
+    )
+
+external reraise : exn -> 'a = "%reraise"
+
+let report_exception ppf exn =
+  let rec loop n exn =
+    match error_of_exn exn with
+    | None -> reraise exn
+    | Some `Already_displayed -> ()
+    | Some (`Ok err) -> report_error ppf err
+    | exception exn when n > 0 -> loop (n-1) exn
+  in
+  loop 5 exn
+
+exception Error of error
+
+let () =
+  register_error_of_exn
+    (function
+      | Error e -> Some e
+      | _ -> None
+    )
+
+let raise_errorf ?(loc = none) ?(sub = []) =
+  Format.kdprintf (fun txt -> raise (Error (mkerror loc sub txt)))
diff --git a/upstream/ocaml_411/parsing/location.mli b/upstream/ocaml_411/parsing/location.mli
new file mode 100644
index 0000000..ecf39b2
--- /dev/null
+++ b/upstream/ocaml_411/parsing/location.mli
@@ -0,0 +1,287 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** {1 Source code locations (ranges of positions), used in parsetree}
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Format
+
+type t = Warnings.loc = {
+  loc_start: Lexing.position;
+  loc_end: Lexing.position;
+  loc_ghost: bool;
+}
+
+(** Note on the use of Lexing.position in this module.
+   If [pos_fname = ""], then use [!input_name] instead.
+   If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and
+     re-parse the file to get the line and character numbers.
+   Else all fields are correct.
+*)
+
+val none : t
+(** An arbitrary value of type [t]; describes an empty ghost range. *)
+
+val is_none : t -> bool
+(** True for [Location.none], false any other location *)
+
+val in_file : string -> t
+(** Return an empty ghost range located in a given file. *)
+
+val init : Lexing.lexbuf -> string -> unit
+(** Set the file name and line number of the [lexbuf] to be the start
+    of the named file. *)
+
+val curr : Lexing.lexbuf -> t
+(** Get the location of the current token from the [lexbuf]. *)
+
+val symbol_rloc: unit -> t
+val symbol_gloc: unit -> t
+
+(** [rhs_loc n] returns the location of the symbol at position [n], starting
+  at 1, in the current parser rule. *)
+val rhs_loc: int -> t
+
+val rhs_interval: int -> int -> t
+
+val get_pos_info: Lexing.position -> string * int * int
+(** file, line, char *)
+
+type 'a loc = {
+  txt : 'a;
+  loc : t;
+}
+
+val mknoloc : 'a -> 'a loc
+val mkloc : 'a -> t -> 'a loc
+
+
+(** {1 Input info} *)
+
+val input_name: string ref
+val input_lexbuf: Lexing.lexbuf option ref
+
+(* This is used for reporting errors coming from the toplevel.
+
+   When running a toplevel session (i.e. when [!input_name] is "//toplevel//"),
+   [!input_phrase_buffer] should be [Some buf] where [buf] contains the last
+   toplevel phrase. *)
+val input_phrase_buffer: Buffer.t option ref
+
+
+(** {1 Toplevel-specific functions} *)
+
+val echo_eof: unit -> unit
+val reset: unit -> unit
+
+
+(** {1 Printing locations} *)
+
+val rewrite_absolute_path: string -> string
+    (** rewrite absolute path to honor the BUILD_PATH_PREFIX_MAP
+        variable (https://reproducible-builds.org/specs/build-path-prefix-map/)
+        if it is set. *)
+
+val absolute_path: string -> string
+
+val show_filename: string -> string
+    (** In -absname mode, return the absolute path for this filename.
+        Otherwise, returns the filename unchanged. *)
+
+val print_filename: formatter -> string -> unit
+
+val print_loc: formatter -> t -> unit
+val print_locs: formatter -> t list -> unit
+
+
+(** {1 Toplevel-specific location highlighting} *)
+
+val highlight_terminfo:
+  Lexing.lexbuf -> formatter -> t list -> unit
+
+
+(** {1 Reporting errors and warnings} *)
+
+(** {2 The type of reports and report printers} *)
+
+type msg = (Format.formatter -> unit) loc
+
+val msg: ?loc:t -> ('a, Format.formatter, unit, msg) format4 -> 'a
+
+type report_kind =
+  | Report_error
+  | Report_warning of string
+  | Report_warning_as_error of string
+  | Report_alert of string
+  | Report_alert_as_error of string
+
+type report = {
+  kind : report_kind;
+  main : msg;
+  sub : msg list;
+}
+
+type report_printer = {
+  (* The entry point *)
+  pp : report_printer ->
+    Format.formatter -> report -> unit;
+
+  pp_report_kind : report_printer -> report ->
+    Format.formatter -> report_kind -> unit;
+  pp_main_loc : report_printer -> report ->
+    Format.formatter -> t -> unit;
+  pp_main_txt : report_printer -> report ->
+    Format.formatter -> (Format.formatter -> unit) -> unit;
+  pp_submsgs : report_printer -> report ->
+    Format.formatter -> msg list -> unit;
+  pp_submsg : report_printer -> report ->
+    Format.formatter -> msg -> unit;
+  pp_submsg_loc : report_printer -> report ->
+    Format.formatter -> t -> unit;
+  pp_submsg_txt : report_printer -> report ->
+    Format.formatter -> (Format.formatter -> unit) -> unit;
+}
+(** A printer for [report]s, defined using open-recursion.
+    The goal is to make it easy to define new printers by re-using code from
+    existing ones.
+*)
+
+(** {2 Report printers used in the compiler} *)
+
+val batch_mode_printer: report_printer
+
+val terminfo_toplevel_printer: Lexing.lexbuf -> report_printer
+
+val best_toplevel_printer: unit -> report_printer
+(** Detects the terminal capabilities and selects an adequate printer *)
+
+(** {2 Printing a [report]} *)
+
+val print_report: formatter -> report -> unit
+(** Display an error or warning report. *)
+
+val report_printer: (unit -> report_printer) ref
+(** Hook for redefining the printer of reports.
+
+    The hook is a [unit -> report_printer] and not simply a [report_printer]:
+    this is useful so that it can detect the type of the output (a file, a
+    terminal, ...) and select a printer accordingly. *)
+
+val default_report_printer: unit -> report_printer
+(** Original report printer for use in hooks. *)
+
+
+(** {1 Reporting warnings} *)
+
+(** {2 Converting a [Warnings.t] into a [report]} *)
+
+val report_warning: t -> Warnings.t -> report option
+(** [report_warning loc w] produces a report for the given warning [w], or
+   [None] if the warning is not to be printed. *)
+
+val warning_reporter: (t -> Warnings.t -> report option) ref
+(** Hook for intercepting warnings. *)
+
+val default_warning_reporter: t -> Warnings.t -> report option
+(** Original warning reporter for use in hooks. *)
+
+(** {2 Printing warnings} *)
+
+val formatter_for_warnings : formatter ref
+
+val print_warning: t -> formatter -> Warnings.t -> unit
+(** Prints a warning. This is simply the composition of [report_warning] and
+   [print_report]. *)
+
+val prerr_warning: t -> Warnings.t -> unit
+(** Same as [print_warning], but uses [!formatter_for_warnings] as output
+   formatter. *)
+
+(** {1 Reporting alerts} *)
+
+(** {2 Converting an [Alert.t] into a [report]} *)
+
+val report_alert: t -> Warnings.alert -> report option
+(** [report_alert loc w] produces a report for the given alert [w], or
+   [None] if the alert is not to be printed. *)
+
+val alert_reporter: (t -> Warnings.alert -> report option) ref
+(** Hook for intercepting alerts. *)
+
+val default_alert_reporter: t -> Warnings.alert -> report option
+(** Original alert reporter for use in hooks. *)
+
+(** {2 Printing alerts} *)
+
+val print_alert: t -> formatter -> Warnings.alert -> unit
+(** Prints an alert. This is simply the composition of [report_alert] and
+   [print_report]. *)
+
+val prerr_alert: t -> Warnings.alert -> unit
+(** Same as [print_alert], but uses [!formatter_for_warnings] as output
+   formatter. *)
+
+val deprecated: ?def:t -> ?use:t -> t -> string -> unit
+(** Prints a deprecation alert. *)
+
+val alert: ?def:t -> ?use:t -> kind:string -> t -> string -> unit
+(** Prints an arbitrary alert. *)
+
+
+(** {1 Reporting errors} *)
+
+type error = report
+(** An [error] is a [report] which [report_kind] must be [Report_error]. *)
+
+val error: ?loc:t -> ?sub:msg list -> string -> error
+
+val errorf: ?loc:t -> ?sub:msg list ->
+  ('a, Format.formatter, unit, error) format4 -> 'a
+
+val error_of_printer: ?loc:t -> ?sub:msg list ->
+  (formatter -> 'a -> unit) -> 'a -> error
+
+val error_of_printer_file: (formatter -> 'a -> unit) -> 'a -> error
+
+
+(** {1 Automatically reporting errors for raised exceptions} *)
+
+val register_error_of_exn: (exn -> error option) -> unit
+(** Each compiler module which defines a custom type of exception
+    which can surface as a user-visible error should register
+    a "printer" for this exception using [register_error_of_exn].
+    The result of the printer is an [error] value containing
+    a location, a message, and optionally sub-messages (each of them
+    being located as well). *)
+
+val error_of_exn: exn -> [ `Ok of error | `Already_displayed ] option
+
+exception Error of error
+(** Raising [Error e] signals an error [e]; the exception will be caught and the
+   error will be printed. *)
+
+exception Already_displayed_error
+(** Raising [Already_displayed_error] signals an error which has already been
+   printed. The exception will be caught, but nothing will be printed *)
+
+val raise_errorf: ?loc:t -> ?sub:msg list ->
+  ('a, Format.formatter, unit, 'b) format4 -> 'a
+
+val report_exception: formatter -> exn -> unit
+(** Reraise the exception if it is unknown. *)
diff --git a/upstream/ocaml_411/parsing/longident.ml b/upstream/ocaml_411/parsing/longident.ml
new file mode 100644
index 0000000..eaafb02
--- /dev/null
+++ b/upstream/ocaml_411/parsing/longident.ml
@@ -0,0 +1,50 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t =
+    Lident of string
+  | Ldot of t * string
+  | Lapply of t * t
+
+let rec flat accu = function
+    Lident s -> s :: accu
+  | Ldot(lid, s) -> flat (s :: accu) lid
+  | Lapply(_, _) -> Misc.fatal_error "Longident.flat"
+
+let flatten lid = flat [] lid
+
+let last = function
+    Lident s -> s
+  | Ldot(_, s) -> s
+  | Lapply(_, _) -> Misc.fatal_error "Longident.last"
+
+
+let rec split_at_dots s pos =
+  try
+    let dot = String.index_from s pos '.' in
+    String.sub s pos (dot - pos) :: split_at_dots s (dot + 1)
+  with Not_found ->
+    [String.sub s pos (String.length s - pos)]
+
+let unflatten l =
+  match l with
+  | [] -> None
+  | hd :: tl -> Some (List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl)
+
+let parse s =
+  match unflatten (split_at_dots s 0) with
+  | None -> Lident ""  (* should not happen, but don't put assert false
+                          so as not to crash the toplevel (see Genprintval) *)
+  | Some v -> v
diff --git a/upstream/ocaml_411/parsing/longident.mli b/upstream/ocaml_411/parsing/longident.mli
new file mode 100644
index 0000000..0708630
--- /dev/null
+++ b/upstream/ocaml_411/parsing/longident.mli
@@ -0,0 +1,60 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Long identifiers, used in parsetree.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type t =
+    Lident of string
+  | Ldot of t * string
+  | Lapply of t * t
+
+val flatten: t -> string list
+val unflatten: string list -> t option
+(** For a non-empty list [l], [unflatten l] is [Some lid] where [lid] is
+    the long identifier created by concatenating the elements of [l]
+    with [Ldot].
+    [unflatten []] is [None].
+*)
+
+val last: t -> string
+val parse: string -> t
+[@@deprecated "this function may misparse its input,\n\
+use \"Parse.longident\" or \"Longident.unflatten\""]
+(**
+
+   This function is broken on identifiers that are not just "Word.Word.word";
+   for example, it returns incorrect results on infix operators
+   and extended module paths.
+
+   If you want to generate long identifiers that are a list of
+   dot-separated identifiers, the function {!unflatten} is safer and faster.
+   {!unflatten} is available since OCaml 4.06.0.
+
+   If you want to parse any identifier correctly, use the long-identifiers
+   functions from the {!Parse} module, in particular {!Parse.longident}.
+   They are available since OCaml 4.11, and also provide proper
+   input-location support.
+
+*)
+
+
+
+(** To print a longident, see {!Pprintast.longident}, using
+    {!Format.asprintf} to convert to a string. *)
diff --git a/upstream/ocaml_411/parsing/parse.ml b/upstream/ocaml_411/parsing/parse.ml
new file mode 100644
index 0000000..b0cee44
--- /dev/null
+++ b/upstream/ocaml_411/parsing/parse.ml
@@ -0,0 +1,173 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Entry points in the parser *)
+
+(* Skip tokens to the end of the phrase *)
+
+let last_token = ref Parser.EOF
+
+let token lexbuf =
+  let token = Lexer.token lexbuf in
+  last_token := token;
+  token
+
+let rec skip_phrase lexbuf =
+  match token lexbuf with
+  | Parser.SEMISEMI | Parser.EOF -> ()
+  | _ -> skip_phrase lexbuf
+  | exception (Lexer.Error (Lexer.Unterminated_comment _, _)
+              | Lexer.Error (Lexer.Unterminated_string, _)
+              | Lexer.Error (Lexer.Reserved_sequence _, _)
+              | Lexer.Error (Lexer.Unterminated_string_in_comment _, _)
+              | Lexer.Error (Lexer.Illegal_character _, _)) ->
+      skip_phrase lexbuf
+
+let maybe_skip_phrase lexbuf =
+  match !last_token with
+  | Parser.SEMISEMI | Parser.EOF -> ()
+  | _ -> skip_phrase lexbuf
+
+let wrap parsing_fun lexbuf =
+  try
+    Docstrings.init ();
+    Lexer.init ();
+    let ast = parsing_fun lexbuf in
+    Parsing.clear_parser();
+    Docstrings.warn_bad_docstrings ();
+    last_token := Parser.EOF;
+    ast
+  with
+  | Lexer.Error(Lexer.Illegal_character _, _) as err
+    when !Location.input_name = "//toplevel//"->
+      skip_phrase lexbuf;
+      raise err
+  | Syntaxerr.Error _ as err
+    when !Location.input_name = "//toplevel//" ->
+      maybe_skip_phrase lexbuf;
+      raise err
+  | Parsing.Parse_error | Syntaxerr.Escape_error ->
+      let loc = Location.curr lexbuf in
+      if !Location.input_name = "//toplevel//"
+      then maybe_skip_phrase lexbuf;
+      raise(Syntaxerr.Error(Syntaxerr.Other loc))
+
+let rec loop lexbuf in_error checkpoint =
+  let module I = Parser.MenhirInterpreter in
+  match checkpoint with
+  | I.InputNeeded _env ->
+      let triple =
+        if in_error then
+          (* The parser detected an error.
+             At this point we don't want to consume input anymore. In the
+             top-level, it would translate into waiting for the user to type
+             something, just to raise an error at some earlier position, rather
+             than just raising the error immediately.
+
+             This worked before with yacc because, AFAICT (@let-def):
+             - yacc eagerly reduces "default reduction" (when the next action
+               is to reduce the same production no matter what token is read,
+               yacc reduces it immediately rather than waiting for that token
+               to be read)
+             - error productions in OCaml grammar are always in a position that
+               allows default reduction ("error" symbol is the last producer,
+               and the lookahead token will not be used to disambiguate between
+               two possible error rules)
+             This solution is fragile because it relies on an optimization
+             (default reduction), that changes the semantics of the parser the
+             way it is implemented in Yacc (an optimization that changes
+             semantics? hmmmm).
+
+             Rather than relying on implementation details of the parser, when
+             an error is detected in this loop we stop looking at the input and
+             fill the parser with EOF tokens.
+             The skip_phrase logic will resynchronize the input stream by
+             looking for the next ';;'.  *)
+          (Parser.EOF, lexbuf.Lexing.lex_curr_p, lexbuf.Lexing.lex_curr_p)
+        else
+          let token = token lexbuf in
+          (token, lexbuf.Lexing.lex_start_p, lexbuf.Lexing.lex_curr_p)
+      in
+      let checkpoint = I.offer checkpoint triple in
+      loop lexbuf in_error checkpoint
+  | I.Shifting _ | I.AboutToReduce _ ->
+      loop lexbuf in_error (I.resume checkpoint)
+  | I.Accepted v -> v
+  | I.Rejected -> raise Parser.Error
+  | I.HandlingError _ ->
+      loop lexbuf true (I.resume checkpoint)
+
+let wrap_menhir entry lexbuf =
+  let initial = entry lexbuf.Lexing.lex_curr_p in
+  wrap (fun lexbuf -> loop lexbuf false initial) lexbuf
+
+let implementation = wrap_menhir Parser.Incremental.implementation
+and interface = wrap_menhir Parser.Incremental.interface
+and toplevel_phrase = wrap_menhir Parser.Incremental.toplevel_phrase
+and use_file = wrap_menhir Parser.Incremental.use_file
+and core_type = wrap_menhir Parser.Incremental.parse_core_type
+and expression = wrap_menhir Parser.Incremental.parse_expression
+and pattern = wrap_menhir Parser.Incremental.parse_pattern
+
+let longident = wrap_menhir Parser.Incremental.parse_any_longident
+let val_ident = wrap_menhir Parser.Incremental.parse_val_longident
+let constr_ident= wrap_menhir Parser.Incremental.parse_constr_longident
+let extended_module_path =
+  wrap_menhir Parser.Incremental.parse_mod_ext_longident
+let simple_module_path = wrap_menhir Parser.Incremental.parse_mod_longident
+let type_ident = wrap_menhir Parser.Incremental.parse_mty_longident
+
+(* Error reporting for Syntaxerr *)
+(* The code has been moved here so that one can reuse Pprintast.tyvar *)
+
+let prepare_error err =
+  let open Syntaxerr in
+  match err with
+  | Unclosed(opening_loc, opening, closing_loc, closing) ->
+      Location.errorf
+        ~loc:closing_loc
+        ~sub:[
+          Location.msg ~loc:opening_loc
+            "This '%s' might be unmatched" opening
+        ]
+        "Syntax error: '%s' expected" closing
+
+  | Expecting (loc, nonterm) ->
+      Location.errorf ~loc "Syntax error: %s expected." nonterm
+  | Not_expecting (loc, nonterm) ->
+      Location.errorf ~loc "Syntax error: %s not expected." nonterm
+  | Applicative_path loc ->
+      Location.errorf ~loc
+        "Syntax error: applicative paths of the form F(X).t \
+         are not supported when the option -no-app-func is set."
+  | Variable_in_scope (loc, var) ->
+      Location.errorf ~loc
+        "In this scoped type, variable %a \
+         is reserved for the local type %s."
+        Pprintast.tyvar var var
+  | Other loc ->
+      Location.errorf ~loc "Syntax error"
+  | Ill_formed_ast (loc, s) ->
+      Location.errorf ~loc
+        "broken invariant in parsetree: %s" s
+  | Invalid_package_type (loc, s) ->
+      Location.errorf ~loc "invalid package type: %s" s
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Syntaxerr.Error err -> Some (prepare_error err)
+      | _ -> None
+    )
diff --git a/upstream/ocaml_411/parsing/parse.mli b/upstream/ocaml_411/parsing/parse.mli
new file mode 100644
index 0000000..699e6ba
--- /dev/null
+++ b/upstream/ocaml_411/parsing/parse.mli
@@ -0,0 +1,108 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Entry points in the parser
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+val implementation : Lexing.lexbuf -> Parsetree.structure
+val interface : Lexing.lexbuf -> Parsetree.signature
+val toplevel_phrase : Lexing.lexbuf -> Parsetree.toplevel_phrase
+val use_file : Lexing.lexbuf -> Parsetree.toplevel_phrase list
+val core_type : Lexing.lexbuf -> Parsetree.core_type
+val expression : Lexing.lexbuf -> Parsetree.expression
+val pattern : Lexing.lexbuf -> Parsetree.pattern
+
+(** The functions below can be used to parse Longident safely. *)
+
+val longident: Lexing.lexbuf -> Longident.t
+(**
+   The function [longident] is guaranted to parse all subclasses
+   of {!Longident.t} used in OCaml: values, constructors, simple or extended
+   module paths, and types or module types.
+
+   However, this function accepts inputs which are not accepted by the
+   compiler, because they combine functor applications and infix operators.
+   In valid OCaml syntax, only value-level identifiers may end with infix
+   operators [Foo.( + )].
+   Moreover, in value-level identifiers the module path [Foo] must be simple
+   ([M.N] rather than [F(X)]): functor applications may only appear in
+   type-level identifiers.
+   As a consequence, a path such as [F(X).( + )] is not a valid OCaml
+   identifier; but it is accepted by this function.
+*)
+
+(** The next functions are specialized to a subclass of {!Longident.t} *)
+
+val val_ident: Lexing.lexbuf -> Longident.t
+(**
+   This function parses a syntactically valid path for a value. For instance,
+   [x], [M.x], and [(+.)] are valid. Contrarily, [M.A], [F(X).x], and [true]
+   are rejected.
+
+   Longident for OCaml's value cannot contain functor application.
+   The last component of the {!Longident.t} is not capitalized,
+   but can be an operator [A.Path.To.(.%.%.(;..)<-)]
+*)
+
+val constr_ident: Lexing.lexbuf -> Longident.t
+(**
+   This function parses a syntactically valid path for a variant constructor.
+   For instance, [A], [M.A] and [M.(::)] are valid, but both [M.a]
+   and [F(X).A] are rejected.
+
+   Longident for OCaml's variant constructors cannot contain functor
+   application.
+   The last component of the {!Longident.t} is capitalized,
+   or it may be one the special constructors: [true],[false],[()],[[]],[(::)].
+   Among those special constructors, only [(::)] can be prefixed by a module
+   path ([A.B.C.(::)]).
+*)
+
+
+val simple_module_path: Lexing.lexbuf -> Longident.t
+(**
+   This function parses a syntactically valid path for a module.
+   For instance, [A], and [M.A] are valid, but both [M.a]
+   and [F(X).A] are rejected.
+
+   Longident for OCaml's module cannot contain functor application.
+   The last component of the {!Longident.t} is capitalized.
+*)
+
+
+val extended_module_path: Lexing.lexbuf -> Longident.t
+(**
+   This function parse syntactically valid path for an extended module.
+   For instance, [A.B] and [F(A).B] are valid. Contrarily,
+   [(.%())] or [[]] are both rejected.
+
+   The last component of the {!Longident.t} is capitalized.
+
+*)
+
+val type_ident: Lexing.lexbuf -> Longident.t
+(**
+   This function parse syntactically valid path for a type or a module type.
+   For instance, [A], [t], [M.t] and [F(X).t] are valid. Contrarily,
+   [(.%())] or [[]] are both rejected.
+
+   In path for type and module types, only operators and special constructors
+   are rejected.
+
+*)
diff --git a/upstream/ocaml_411/parsing/parser.mly b/upstream/ocaml_411/parsing/parser.mly
new file mode 100644
index 0000000..12e1818
--- /dev/null
+++ b/upstream/ocaml_411/parsing/parser.mly
@@ -0,0 +1,3761 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 1996 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* The parser definition */
+
+%{
+
+open Asttypes
+open Longident
+open Parsetree
+open Ast_helper
+open Docstrings
+open Docstrings.WithMenhir
+
+let mkloc = Location.mkloc
+let mknoloc = Location.mknoloc
+
+let make_loc (startpos, endpos) = {
+  Location.loc_start = startpos;
+  Location.loc_end = endpos;
+  Location.loc_ghost = false;
+}
+
+let ghost_loc (startpos, endpos) = {
+  Location.loc_start = startpos;
+  Location.loc_end = endpos;
+  Location.loc_ghost = true;
+}
+
+let mktyp ~loc d = Typ.mk ~loc:(make_loc loc) d
+let mkpat ~loc d = Pat.mk ~loc:(make_loc loc) d
+let mkexp ~loc d = Exp.mk ~loc:(make_loc loc) d
+let mkmty ~loc ?attrs d = Mty.mk ~loc:(make_loc loc) ?attrs d
+let mksig ~loc d = Sig.mk ~loc:(make_loc loc) d
+let mkmod ~loc ?attrs d = Mod.mk ~loc:(make_loc loc) ?attrs d
+let mkstr ~loc d = Str.mk ~loc:(make_loc loc) d
+let mkclass ~loc ?attrs d = Cl.mk ~loc:(make_loc loc) ?attrs d
+let mkcty ~loc ?attrs d = Cty.mk ~loc:(make_loc loc) ?attrs d
+
+let pstr_typext (te, ext) =
+  (Pstr_typext te, ext)
+let pstr_primitive (vd, ext) =
+  (Pstr_primitive vd, ext)
+let pstr_type ((nr, ext), tys) =
+  (Pstr_type (nr, tys), ext)
+let pstr_exception (te, ext) =
+  (Pstr_exception te, ext)
+let pstr_include (body, ext) =
+  (Pstr_include body, ext)
+let pstr_recmodule (ext, bindings) =
+  (Pstr_recmodule bindings, ext)
+
+let psig_typext (te, ext) =
+  (Psig_typext te, ext)
+let psig_value (vd, ext) =
+  (Psig_value vd, ext)
+let psig_type ((nr, ext), tys) =
+  (Psig_type (nr, tys), ext)
+let psig_typesubst ((nr, ext), tys) =
+  assert (nr = Recursive); (* see [no_nonrec_flag] *)
+  (Psig_typesubst tys, ext)
+let psig_exception (te, ext) =
+  (Psig_exception te, ext)
+let psig_include (body, ext) =
+  (Psig_include body, ext)
+
+let mkctf ~loc ?attrs ?docs d =
+  Ctf.mk ~loc:(make_loc loc) ?attrs ?docs d
+let mkcf ~loc ?attrs ?docs d =
+  Cf.mk ~loc:(make_loc loc) ?attrs ?docs d
+
+let mkrhs rhs loc = mkloc rhs (make_loc loc)
+let ghrhs rhs loc = mkloc rhs (ghost_loc loc)
+
+let push_loc x acc =
+  if x.Location.loc_ghost
+  then acc
+  else x :: acc
+
+let reloc_pat ~loc x =
+  { x with ppat_loc = make_loc loc;
+           ppat_loc_stack = push_loc x.ppat_loc x.ppat_loc_stack };;
+let reloc_exp ~loc x =
+  { x with pexp_loc = make_loc loc;
+           pexp_loc_stack = push_loc x.pexp_loc x.pexp_loc_stack };;
+let reloc_typ ~loc x =
+  { x with ptyp_loc = make_loc loc;
+           ptyp_loc_stack = push_loc x.ptyp_loc x.ptyp_loc_stack };;
+
+let mkexpvar ~loc (name : string) =
+  mkexp ~loc (Pexp_ident(mkrhs (Lident name) loc))
+
+let mkoperator =
+  mkexpvar
+
+let mkpatvar ~loc name =
+  mkpat ~loc (Ppat_var (mkrhs name loc))
+
+(*
+  Ghost expressions and patterns:
+  expressions and patterns that do not appear explicitly in the
+  source file they have the loc_ghost flag set to true.
+  Then the profiler will not try to instrument them and the
+  -annot option will not try to display their type.
+
+  Every grammar rule that generates an element with a location must
+  make at most one non-ghost element, the topmost one.
+
+  How to tell whether your location must be ghost:
+  A location corresponds to a range of characters in the source file.
+  If the location contains a piece of code that is syntactically
+  valid (according to the documentation), and corresponds to the
+  AST node, then the location must be real; in all other cases,
+  it must be ghost.
+*)
+let ghexp ~loc d = Exp.mk ~loc:(ghost_loc loc) d
+let ghpat ~loc d = Pat.mk ~loc:(ghost_loc loc) d
+let ghtyp ~loc d = Typ.mk ~loc:(ghost_loc loc) d
+let ghloc ~loc d = { txt = d; loc = ghost_loc loc }
+let ghstr ~loc d = Str.mk ~loc:(ghost_loc loc) d
+let ghsig ~loc d = Sig.mk ~loc:(ghost_loc loc) d
+
+let mkinfix arg1 op arg2 =
+  Pexp_apply(op, [Nolabel, arg1; Nolabel, arg2])
+
+let neg_string f =
+  if String.length f > 0 && f.[0] = '-'
+  then String.sub f 1 (String.length f - 1)
+  else "-" ^ f
+
+let mkuminus ~oploc name arg =
+  match name, arg.pexp_desc with
+  | "-", Pexp_constant(Pconst_integer (n,m)) ->
+      Pexp_constant(Pconst_integer(neg_string n,m))
+  | ("-" | "-."), Pexp_constant(Pconst_float (f, m)) ->
+      Pexp_constant(Pconst_float(neg_string f, m))
+  | _ ->
+      Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg])
+
+let mkuplus ~oploc name arg =
+  let desc = arg.pexp_desc in
+  match name, desc with
+  | "+", Pexp_constant(Pconst_integer _)
+  | ("+" | "+."), Pexp_constant(Pconst_float _) -> desc
+  | _ ->
+      Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg])
+
+(* TODO define an abstraction boundary between locations-as-pairs
+   and locations-as-Location.t; it should be clear when we move from
+   one world to the other *)
+
+let mkexp_cons_desc consloc args =
+  Pexp_construct(mkrhs (Lident "::") consloc, Some args)
+let mkexp_cons ~loc consloc args =
+  mkexp ~loc (mkexp_cons_desc consloc args)
+
+let mkpat_cons_desc consloc args =
+  Ppat_construct(mkrhs (Lident "::") consloc, Some args)
+let mkpat_cons ~loc consloc args =
+  mkpat ~loc (mkpat_cons_desc consloc args)
+
+let ghexp_cons_desc consloc args =
+  Pexp_construct(ghrhs (Lident "::") consloc, Some args)
+let ghpat_cons_desc consloc args =
+  Ppat_construct(ghrhs (Lident "::") consloc, Some args)
+
+let rec mktailexp nilloc = let open Location in function
+    [] ->
+      let nil = ghloc ~loc:nilloc (Lident "[]") in
+      Pexp_construct (nil, None), nilloc
+  | e1 :: el ->
+      let exp_el, el_loc = mktailexp nilloc el in
+      let loc = (e1.pexp_loc.loc_start, snd el_loc) in
+      let arg = ghexp ~loc (Pexp_tuple [e1; ghexp ~loc:el_loc exp_el]) in
+      ghexp_cons_desc loc arg, loc
+
+let rec mktailpat nilloc = let open Location in function
+    [] ->
+      let nil = ghloc ~loc:nilloc (Lident "[]") in
+      Ppat_construct (nil, None), nilloc
+  | p1 :: pl ->
+      let pat_pl, el_loc = mktailpat nilloc pl in
+      let loc = (p1.ppat_loc.loc_start, snd el_loc) in
+      let arg = ghpat ~loc (Ppat_tuple [p1; ghpat ~loc:el_loc pat_pl]) in
+      ghpat_cons_desc loc arg, loc
+
+let mkstrexp e attrs =
+  { pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc }
+
+let mkexp_constraint ~loc e (t1, t2) =
+  match t1, t2 with
+  | Some t, None -> ghexp ~loc (Pexp_constraint(e, t))
+  | _, Some t -> ghexp ~loc (Pexp_coerce(e, t1, t))
+  | None, None -> assert false
+
+let mkexp_opt_constraint ~loc e = function
+  | None -> e
+  | Some constraint_ -> mkexp_constraint ~loc e constraint_
+
+let mkpat_opt_constraint ~loc p = function
+  | None -> p
+  | Some typ -> mkpat ~loc (Ppat_constraint(p, typ))
+
+let syntax_error () =
+  raise Syntaxerr.Escape_error
+
+let unclosed opening_name opening_loc closing_name closing_loc =
+  raise(Syntaxerr.Error(Syntaxerr.Unclosed(make_loc opening_loc, opening_name,
+                                           make_loc closing_loc, closing_name)))
+
+let expecting loc nonterm =
+    raise Syntaxerr.(Error(Expecting(make_loc loc, nonterm)))
+
+let not_expecting loc nonterm =
+    raise Syntaxerr.(Error(Not_expecting(make_loc loc, nonterm)))
+
+let dotop ~left ~right ~assign ~ext ~multi =
+  let assign = if assign then "<-" else "" in
+  let mid = if multi then ";.." else "" in
+  String.concat "" ["."; ext; left; mid; right; assign]
+let paren = "(",")"
+let brace = "{", "}"
+let bracket = "[", "]"
+let lident x =  Lident x
+let ldot x y = Ldot(x,y)
+let dotop_fun ~loc dotop =
+  (* We could use ghexp here, but sticking to mkexp for parser.mly
+     compatibility. TODO improve parser.mly *)
+  mkexp ~loc (Pexp_ident (ghloc ~loc dotop))
+
+let array_function ~loc str name =
+  ghloc ~loc (Ldot(Lident str,
+                   (if !Clflags.unsafe then "unsafe_" ^ name else name)))
+
+let array_get_fun ~loc =
+  ghexp ~loc (Pexp_ident(array_function ~loc "Array" "get"))
+let string_get_fun ~loc =
+  ghexp ~loc (Pexp_ident(array_function ~loc "String" "get"))
+
+let array_set_fun ~loc =
+  ghexp ~loc (Pexp_ident(array_function ~loc "Array" "set"))
+let string_set_fun ~loc =
+  ghexp ~loc (Pexp_ident(array_function ~loc "String" "set"))
+
+let multi_indices ~loc = function
+  | [a] -> false, a
+  | l -> true, mkexp ~loc (Pexp_array l)
+
+let index_get ~loc get_fun array index =
+  let args = [Nolabel, array; Nolabel, index] in
+   mkexp ~loc (Pexp_apply(get_fun, args))
+
+let index_set ~loc set_fun array index value =
+  let args = [Nolabel, array; Nolabel, index; Nolabel, value] in
+   mkexp ~loc (Pexp_apply(set_fun, args))
+
+let array_get ~loc = index_get ~loc (array_get_fun ~loc)
+let string_get ~loc = index_get ~loc (string_get_fun ~loc)
+let dotop_get ~loc path (left,right) ext array index =
+  let multi, index = multi_indices ~loc index in
+  index_get ~loc
+    (dotop_fun ~loc (path @@ dotop ~left ~right ~ext ~multi ~assign:false))
+    array index
+
+let array_set ~loc = index_set ~loc (array_set_fun ~loc)
+let string_set ~loc = index_set ~loc (string_set_fun ~loc)
+let dotop_set ~loc path (left,right) ext array index value=
+  let multi, index = multi_indices ~loc index in
+  index_set ~loc
+    (dotop_fun ~loc (path @@ dotop ~left ~right ~ext ~multi ~assign:true))
+    array index value
+
+
+let bigarray_function ~loc str name =
+  ghloc ~loc (Ldot(Ldot(Lident "Bigarray", str), name))
+
+let bigarray_untuplify = function
+    { pexp_desc = Pexp_tuple explist; pexp_loc = _ } -> explist
+  | exp -> [exp]
+
+let bigarray_get ~loc arr arg =
+  let mkexp, ghexp = mkexp ~loc, ghexp ~loc in
+  let bigarray_function = bigarray_function ~loc in
+  let get = if !Clflags.unsafe then "unsafe_get" else "get" in
+  match bigarray_untuplify arg with
+    [c1] ->
+      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" get)),
+                       [Nolabel, arr; Nolabel, c1]))
+  | [c1;c2] ->
+      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" get)),
+                       [Nolabel, arr; Nolabel, c1; Nolabel, c2]))
+  | [c1;c2;c3] ->
+      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" get)),
+                       [Nolabel, arr; Nolabel, c1; Nolabel, c2; Nolabel, c3]))
+  | coords ->
+      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "get")),
+                       [Nolabel, arr; Nolabel, ghexp(Pexp_array coords)]))
+
+let bigarray_set ~loc arr arg newval =
+  let mkexp, ghexp = mkexp ~loc, ghexp ~loc in
+  let bigarray_function = bigarray_function ~loc in
+  let set = if !Clflags.unsafe then "unsafe_set" else "set" in
+  match bigarray_untuplify arg with
+    [c1] ->
+      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" set)),
+                       [Nolabel, arr; Nolabel, c1; Nolabel, newval]))
+  | [c1;c2] ->
+      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" set)),
+                       [Nolabel, arr; Nolabel, c1;
+                        Nolabel, c2; Nolabel, newval]))
+  | [c1;c2;c3] ->
+      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" set)),
+                       [Nolabel, arr; Nolabel, c1;
+                        Nolabel, c2; Nolabel, c3; Nolabel, newval]))
+  | coords ->
+      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "set")),
+                       [Nolabel, arr;
+                        Nolabel, ghexp(Pexp_array coords);
+                        Nolabel, newval]))
+
+let lapply ~loc p1 p2 =
+  if !Clflags.applicative_functors
+  then Lapply(p1, p2)
+  else raise (Syntaxerr.Error(
+                  Syntaxerr.Applicative_path (make_loc loc)))
+
+let exp_of_longident ~loc lid =
+  mkexp ~loc (Pexp_ident {lid with txt = Lident(Longident.last lid.txt)})
+
+(* [loc_map] could be [Location.map]. *)
+let loc_map (f : 'a -> 'b) (x : 'a Location.loc) : 'b Location.loc =
+  { x with txt = f x.txt }
+
+let loc_last (id : Longident.t Location.loc) : string Location.loc =
+  loc_map Longident.last id
+
+let loc_lident (id : string Location.loc) : Longident.t Location.loc =
+  loc_map (fun x -> Lident x) id
+
+let exp_of_label ~loc lbl =
+  mkexp ~loc (Pexp_ident (loc_lident lbl))
+
+let pat_of_label ~loc lbl =
+  mkpat ~loc (Ppat_var (loc_last lbl))
+
+let mk_newtypes ~loc newtypes exp =
+  let mkexp = mkexp ~loc in
+  List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp)))
+    newtypes exp
+
+let wrap_type_annotation ~loc newtypes core_type body =
+  let mkexp, ghtyp = mkexp ~loc, ghtyp ~loc in
+  let mk_newtypes = mk_newtypes ~loc in
+  let exp = mkexp(Pexp_constraint(body,core_type)) in
+  let exp = mk_newtypes newtypes exp in
+  (exp, ghtyp(Ptyp_poly(newtypes, Typ.varify_constructors newtypes core_type)))
+
+let wrap_exp_attrs ~loc body (ext, attrs) =
+  let ghexp = ghexp ~loc in
+  (* todo: keep exact location for the entire attribute *)
+  let body = {body with pexp_attributes = attrs @ body.pexp_attributes} in
+  match ext with
+  | None -> body
+  | Some id -> ghexp(Pexp_extension (id, PStr [mkstrexp body []]))
+
+let mkexp_attrs ~loc d attrs =
+  wrap_exp_attrs ~loc (mkexp ~loc d) attrs
+
+let wrap_typ_attrs ~loc typ (ext, attrs) =
+  (* todo: keep exact location for the entire attribute *)
+  let typ = {typ with ptyp_attributes = attrs @ typ.ptyp_attributes} in
+  match ext with
+  | None -> typ
+  | Some id -> ghtyp ~loc (Ptyp_extension (id, PTyp typ))
+
+let wrap_pat_attrs ~loc pat (ext, attrs) =
+  (* todo: keep exact location for the entire attribute *)
+  let pat = {pat with ppat_attributes = attrs @ pat.ppat_attributes} in
+  match ext with
+  | None -> pat
+  | Some id -> ghpat ~loc (Ppat_extension (id, PPat (pat, None)))
+
+let mkpat_attrs ~loc d attrs =
+  wrap_pat_attrs ~loc (mkpat ~loc d) attrs
+
+let wrap_class_attrs ~loc:_ body attrs =
+  {body with pcl_attributes = attrs @ body.pcl_attributes}
+let wrap_mod_attrs ~loc:_ attrs body =
+  {body with pmod_attributes = attrs @ body.pmod_attributes}
+let wrap_mty_attrs ~loc:_ attrs body =
+  {body with pmty_attributes = attrs @ body.pmty_attributes}
+
+let wrap_str_ext ~loc body ext =
+  match ext with
+  | None -> body
+  | Some id -> ghstr ~loc (Pstr_extension ((id, PStr [body]), []))
+
+let wrap_mkstr_ext ~loc (item, ext) =
+  wrap_str_ext ~loc (mkstr ~loc item) ext
+
+let wrap_sig_ext ~loc body ext =
+  match ext with
+  | None -> body
+  | Some id -> ghsig ~loc (Psig_extension ((id, PSig [body]), []))
+
+let wrap_mksig_ext ~loc (item, ext) =
+  wrap_sig_ext ~loc (mksig ~loc item) ext
+
+let mk_quotedext ~loc (id, idloc, str, strloc, delim) =
+  let exp_id = mkloc id idloc in
+  let e = ghexp ~loc (Pexp_constant (Pconst_string (str, strloc, delim))) in
+  (exp_id, PStr [mkstrexp e []])
+
+let text_str pos = Str.text (rhs_text pos)
+let text_sig pos = Sig.text (rhs_text pos)
+let text_cstr pos = Cf.text (rhs_text pos)
+let text_csig pos = Ctf.text (rhs_text pos)
+let text_def pos = [Ptop_def (Str.text (rhs_text pos))]
+
+let extra_text startpos endpos text items =
+  match items with
+  | [] ->
+      let post = rhs_post_text endpos in
+      let post_extras = rhs_post_extra_text endpos in
+      text post @ text post_extras
+  | _ :: _ ->
+      let pre_extras = rhs_pre_extra_text startpos in
+      let post_extras = rhs_post_extra_text endpos in
+        text pre_extras @ items @ text post_extras
+
+let extra_str p1 p2 items = extra_text p1 p2 Str.text items
+let extra_sig p1 p2 items = extra_text p1 p2 Sig.text items
+let extra_cstr p1 p2 items = extra_text p1 p2 Cf.text items
+let extra_csig p1 p2 items = extra_text p1 p2 Ctf.text  items
+let extra_def p1 p2 items =
+  extra_text p1 p2 (fun txt -> [Ptop_def (Str.text txt)]) items
+
+let extra_rhs_core_type ct ~pos =
+  let docs = rhs_info pos in
+  { ct with ptyp_attributes = add_info_attrs docs ct.ptyp_attributes }
+
+type let_binding =
+  { lb_pattern: pattern;
+    lb_expression: expression;
+    lb_attributes: attributes;
+    lb_docs: docs Lazy.t;
+    lb_text: text Lazy.t;
+    lb_loc: Location.t; }
+
+type let_bindings =
+  { lbs_bindings: let_binding list;
+    lbs_rec: rec_flag;
+    lbs_extension: string Asttypes.loc option;
+    lbs_loc: Location.t }
+
+let mklb first ~loc (p, e) attrs =
+  {
+    lb_pattern = p;
+    lb_expression = e;
+    lb_attributes = attrs;
+    lb_docs = symbol_docs_lazy loc;
+    lb_text = (if first then empty_text_lazy
+               else symbol_text_lazy (fst loc));
+    lb_loc = make_loc loc;
+  }
+
+let mklbs ~loc ext rf lb =
+  {
+    lbs_bindings = [lb];
+    lbs_rec = rf;
+    lbs_extension = ext ;
+    lbs_loc = make_loc loc;
+  }
+
+let addlb lbs lb =
+  { lbs with lbs_bindings = lb :: lbs.lbs_bindings }
+
+let val_of_let_bindings ~loc lbs =
+  let bindings =
+    List.map
+      (fun lb ->
+         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
+           ~docs:(Lazy.force lb.lb_docs)
+           ~text:(Lazy.force lb.lb_text)
+           lb.lb_pattern lb.lb_expression)
+      lbs.lbs_bindings
+  in
+  let str = mkstr ~loc (Pstr_value(lbs.lbs_rec, List.rev bindings)) in
+  match lbs.lbs_extension with
+  | None -> str
+  | Some id -> ghstr ~loc (Pstr_extension((id, PStr [str]), []))
+
+let expr_of_let_bindings ~loc lbs body =
+  let bindings =
+    List.map
+      (fun lb ->
+         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
+           lb.lb_pattern lb.lb_expression)
+      lbs.lbs_bindings
+  in
+    mkexp_attrs ~loc (Pexp_let(lbs.lbs_rec, List.rev bindings, body))
+      (lbs.lbs_extension, [])
+
+let class_of_let_bindings ~loc lbs body =
+  let bindings =
+    List.map
+      (fun lb ->
+         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
+           lb.lb_pattern lb.lb_expression)
+      lbs.lbs_bindings
+  in
+    (* Our use of let_bindings(no_ext) guarantees the following: *)
+    assert (lbs.lbs_extension = None);
+    mkclass ~loc (Pcl_let (lbs.lbs_rec, List.rev bindings, body))
+
+(* Alternatively, we could keep the generic module type in the Parsetree
+   and extract the package type during type-checking. In that case,
+   the assertions below should be turned into explicit checks. *)
+let package_type_of_module_type pmty =
+  let err loc s =
+    raise (Syntaxerr.Error (Syntaxerr.Invalid_package_type (loc, s)))
+  in
+  let map_cstr = function
+    | Pwith_type (lid, ptyp) ->
+        let loc = ptyp.ptype_loc in
+        if ptyp.ptype_params <> [] then
+          err loc "parametrized types are not supported";
+        if ptyp.ptype_cstrs <> [] then
+          err loc "constrained types are not supported";
+        if ptyp.ptype_private <> Public then
+          err loc "private types are not supported";
+
+        (* restrictions below are checked by the 'with_constraint' rule *)
+        assert (ptyp.ptype_kind = Ptype_abstract);
+        assert (ptyp.ptype_attributes = []);
+        let ty =
+          match ptyp.ptype_manifest with
+          | Some ty -> ty
+          | None -> assert false
+        in
+        (lid, ty)
+    | _ ->
+        err pmty.pmty_loc "only 'with type t =' constraints are supported"
+  in
+  match pmty with
+  | {pmty_desc = Pmty_ident lid} -> (lid, [])
+  | {pmty_desc = Pmty_with({pmty_desc = Pmty_ident lid}, cstrs)} ->
+      (lid, List.map map_cstr cstrs)
+  | _ ->
+      err pmty.pmty_loc
+        "only module type identifier and 'with type' constraints are supported"
+
+let mk_directive_arg ~loc k =
+  { pdira_desc = k;
+    pdira_loc = make_loc loc;
+  }
+
+let mk_directive ~loc name arg =
+  Ptop_dir {
+      pdir_name = name;
+      pdir_arg = arg;
+      pdir_loc = make_loc loc;
+    }
+
+%}
+
+/* Tokens */
+
+%token AMPERAMPER
+%token AMPERSAND
+%token AND
+%token AS
+%token ASSERT
+%token BACKQUOTE
+%token BANG
+%token BAR
+%token BARBAR
+%token BARRBRACKET
+%token BEGIN
+%token <char> CHAR
+%token CLASS
+%token COLON
+%token COLONCOLON
+%token COLONEQUAL
+%token COLONGREATER
+%token COMMA
+%token CONSTRAINT
+%token DO
+%token DONE
+%token DOT
+%token DOTDOT
+%token DOWNTO
+%token ELSE
+%token END
+%token EOF
+%token EQUAL
+%token EXCEPTION
+%token EXTERNAL
+%token FALSE
+%token <string * char option> FLOAT
+%token FOR
+%token FUN
+%token FUNCTION
+%token FUNCTOR
+%token GREATER
+%token GREATERRBRACE
+%token GREATERRBRACKET
+%token IF
+%token IN
+%token INCLUDE
+%token <string> INFIXOP0
+%token <string> INFIXOP1
+%token <string> INFIXOP2
+%token <string> INFIXOP3
+%token <string> INFIXOP4
+%token <string> DOTOP
+%token <string> LETOP
+%token <string> ANDOP
+%token INHERIT
+%token INITIALIZER
+%token <string * char option> INT
+%token <string> LABEL
+%token LAZY
+%token LBRACE
+%token LBRACELESS
+%token LBRACKET
+%token LBRACKETBAR
+%token LBRACKETLESS
+%token LBRACKETGREATER
+%token LBRACKETPERCENT
+%token LBRACKETPERCENTPERCENT
+%token LESS
+%token LESSMINUS
+%token LET
+%token <string> LIDENT
+%token LPAREN
+%token LBRACKETAT
+%token LBRACKETATAT
+%token LBRACKETATATAT
+%token MATCH
+%token METHOD
+%token MINUS
+%token MINUSDOT
+%token MINUSGREATER
+%token MODULE
+%token MUTABLE
+%token NEW
+%token NONREC
+%token OBJECT
+%token OF
+%token OPEN
+%token <string> OPTLABEL
+%token OR
+/* %token PARSER */
+%token PERCENT
+%token PLUS
+%token PLUSDOT
+%token PLUSEQ
+%token <string> PREFIXOP
+%token PRIVATE
+%token QUESTION
+%token QUOTE
+%token RBRACE
+%token RBRACKET
+%token REC
+%token RPAREN
+%token SEMI
+%token SEMISEMI
+%token HASH
+%token <string> HASHOP
+%token SIG
+%token STAR
+%token <string * Location.t * string option> STRING
+%token
+  <string * Location.t * string * Location.t * string option> QUOTED_STRING_EXPR
+%token
+  <string * Location.t * string * Location.t * string option> QUOTED_STRING_ITEM
+%token STRUCT
+%token THEN
+%token TILDE
+%token TO
+%token TRUE
+%token TRY
+%token TYPE
+%token <string> UIDENT
+%token UNDERSCORE
+%token VAL
+%token VIRTUAL
+%token WHEN
+%token WHILE
+%token WITH
+%token <string * Location.t> COMMENT
+%token <Docstrings.docstring> DOCSTRING
+
+%token EOL
+
+/* Precedences and associativities.
+
+Tokens and rules have precedences.  A reduce/reduce conflict is resolved
+in favor of the first rule (in source file order).  A shift/reduce conflict
+is resolved by comparing the precedence and associativity of the token to
+be shifted with those of the rule to be reduced.
+
+By default, a rule has the precedence of its rightmost terminal (if any).
+
+When there is a shift/reduce conflict between a rule and a token that
+have the same precedence, it is resolved using the associativity:
+if the token is left-associative, the parser will reduce; if
+right-associative, the parser will shift; if non-associative,
+the parser will declare a syntax error.
+
+We will only use associativities with operators of the kind  x * x -> x
+for example, in the rules of the form    expr: expr BINOP expr
+in all other cases, we define two precedences if needed to resolve
+conflicts.
+
+The precedences must be listed from low to high.
+*/
+
+%nonassoc IN
+%nonassoc below_SEMI
+%nonassoc SEMI                          /* below EQUAL ({lbl=...; lbl=...}) */
+%nonassoc LET                           /* above SEMI ( ...; let ... in ...) */
+%nonassoc below_WITH
+%nonassoc FUNCTION WITH                 /* below BAR  (match ... with ...) */
+%nonassoc AND             /* above WITH (module rec A: SIG with ... and ...) */
+%nonassoc THEN                          /* below ELSE (if ... then ...) */
+%nonassoc ELSE                          /* (if ... then ... else ...) */
+%nonassoc LESSMINUS                     /* below COLONEQUAL (lbl <- x := e) */
+%right    COLONEQUAL                    /* expr (e := e := e) */
+%nonassoc AS
+%left     BAR                           /* pattern (p|p|p) */
+%nonassoc below_COMMA
+%left     COMMA                         /* expr/expr_comma_list (e,e,e) */
+%right    MINUSGREATER                  /* function_type (t -> t -> t) */
+%right    OR BARBAR                     /* expr (e || e || e) */
+%right    AMPERSAND AMPERAMPER          /* expr (e && e && e) */
+%nonassoc below_EQUAL
+%left     INFIXOP0 EQUAL LESS GREATER   /* expr (e OP e OP e) */
+%right    INFIXOP1                      /* expr (e OP e OP e) */
+%nonassoc below_LBRACKETAT
+%nonassoc LBRACKETAT
+%right    COLONCOLON                    /* expr (e :: e :: e) */
+%left     INFIXOP2 PLUS PLUSDOT MINUS MINUSDOT PLUSEQ /* expr (e OP e OP e) */
+%left     PERCENT INFIXOP3 STAR                 /* expr (e OP e OP e) */
+%right    INFIXOP4                      /* expr (e OP e OP e) */
+%nonassoc prec_unary_minus prec_unary_plus /* unary - */
+%nonassoc prec_constant_constructor     /* cf. simple_expr (C versus C x) */
+%nonassoc prec_constr_appl              /* above AS BAR COLONCOLON COMMA */
+%nonassoc below_HASH
+%nonassoc HASH                         /* simple_expr/toplevel_directive */
+%left     HASHOP
+%nonassoc below_DOT
+%nonassoc DOT DOTOP
+/* Finally, the first tokens of simple_expr are above everything else. */
+%nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT INT
+          LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN
+          NEW PREFIXOP STRING TRUE UIDENT
+          LBRACKETPERCENT QUOTED_STRING_EXPR
+
+
+/* Entry points */
+
+%start implementation                   /* for implementation files */
+%type <Parsetree.structure> implementation
+%start interface                        /* for interface files */
+%type <Parsetree.signature> interface
+%start toplevel_phrase                  /* for interactive use */
+%type <Parsetree.toplevel_phrase> toplevel_phrase
+%start use_file                         /* for the #use directive */
+%type <Parsetree.toplevel_phrase list> use_file
+%start parse_core_type
+%type <Parsetree.core_type> parse_core_type
+%start parse_expression
+%type <Parsetree.expression> parse_expression
+%start parse_pattern
+%type <Parsetree.pattern> parse_pattern
+%start parse_constr_longident
+%type <Longident.t> parse_constr_longident
+%start parse_val_longident
+%type <Longident.t> parse_val_longident
+%start parse_mty_longident
+%type <Longident.t> parse_mty_longident
+%start parse_mod_ext_longident
+%type <Longident.t> parse_mod_ext_longident
+%start parse_mod_longident
+%type <Longident.t> parse_mod_longident
+%start parse_any_longident
+%type <Longident.t> parse_any_longident
+%%
+
+/* macros */
+%inline extra_str(symb): symb { extra_str $startpos $endpos $1 };
+%inline extra_sig(symb): symb { extra_sig $startpos $endpos $1 };
+%inline extra_cstr(symb): symb { extra_cstr $startpos $endpos $1 };
+%inline extra_csig(symb): symb { extra_csig $startpos $endpos $1 };
+%inline extra_def(symb): symb { extra_def $startpos $endpos $1 };
+%inline extra_text(symb): symb { extra_text $startpos $endpos $1 };
+%inline extra_rhs(symb): symb { extra_rhs_core_type $1 ~pos:$endpos($1) };
+%inline mkrhs(symb): symb
+    { mkrhs $1 $sloc }
+;
+
+%inline text_str(symb): symb
+  { text_str $startpos @ [$1] }
+%inline text_str_SEMISEMI: SEMISEMI
+  { text_str $startpos }
+%inline text_sig(symb): symb
+  { text_sig $startpos @ [$1] }
+%inline text_sig_SEMISEMI: SEMISEMI
+  { text_sig $startpos }
+%inline text_def(symb): symb
+  { text_def $startpos @ [$1] }
+%inline top_def(symb): symb
+  { Ptop_def [$1] }
+%inline text_cstr(symb): symb
+  { text_cstr $startpos @ [$1] }
+%inline text_csig(symb): symb
+  { text_csig $startpos @ [$1] }
+
+(* Using this %inline definition means that we do not control precisely
+   when [mark_rhs_docs] is called, but I don't think this matters. *)
+%inline mark_rhs_docs(symb): symb
+  { mark_rhs_docs $startpos $endpos;
+    $1 }
+
+%inline op(symb): symb
+   { mkoperator ~loc:$sloc $1 }
+
+%inline mkloc(symb): symb
+    { mkloc $1 (make_loc $sloc) }
+
+%inline mkexp(symb): symb
+    { mkexp ~loc:$sloc $1 }
+%inline mkpat(symb): symb
+    { mkpat ~loc:$sloc $1 }
+%inline mktyp(symb): symb
+    { mktyp ~loc:$sloc $1 }
+%inline mkstr(symb): symb
+    { mkstr ~loc:$sloc $1 }
+%inline mksig(symb): symb
+    { mksig ~loc:$sloc $1 }
+%inline mkmod(symb): symb
+    { mkmod ~loc:$sloc $1 }
+%inline mkmty(symb): symb
+    { mkmty ~loc:$sloc $1 }
+%inline mkcty(symb): symb
+    { mkcty ~loc:$sloc $1 }
+%inline mkctf(symb): symb
+    { mkctf ~loc:$sloc $1 }
+%inline mkcf(symb): symb
+    { mkcf ~loc:$sloc $1 }
+%inline mkclass(symb): symb
+    { mkclass ~loc:$sloc $1 }
+
+%inline wrap_mkstr_ext(symb): symb
+    { wrap_mkstr_ext ~loc:$sloc $1 }
+%inline wrap_mksig_ext(symb): symb
+    { wrap_mksig_ext ~loc:$sloc $1 }
+
+%inline mk_directive_arg(symb): symb
+    { mk_directive_arg ~loc:$sloc $1 }
+
+/* Generic definitions */
+
+(* [iloption(X)] recognizes either nothing or [X]. Assuming [X] produces
+   an OCaml list, it produces an OCaml list, too. *)
+
+%inline iloption(X):
+  /* nothing */
+    { [] }
+| x = X
+    { x }
+
+(* [llist(X)] recognizes a possibly empty list of [X]s. It is left-recursive. *)
+
+reversed_llist(X):
+  /* empty */
+    { [] }
+| xs = reversed_llist(X) x = X
+    { x :: xs }
+
+%inline llist(X):
+  xs = rev(reversed_llist(X))
+    { xs }
+
+(* [reversed_nonempty_llist(X)] recognizes a nonempty list of [X]s, and produces
+   an OCaml list in reverse order -- that is, the last element in the input text
+   appears first in this list. Its definition is left-recursive. *)
+
+reversed_nonempty_llist(X):
+  x = X
+    { [ x ] }
+| xs = reversed_nonempty_llist(X) x = X
+    { x :: xs }
+
+(* [nonempty_llist(X)] recognizes a nonempty list of [X]s, and produces an OCaml
+   list in direct order -- that is, the first element in the input text appears
+   first in this list. *)
+
+%inline nonempty_llist(X):
+  xs = rev(reversed_nonempty_llist(X))
+    { xs }
+
+(* [reversed_separated_nonempty_llist(separator, X)] recognizes a nonempty list
+   of [X]s, separated with [separator]s, and produces an OCaml list in reverse
+   order -- that is, the last element in the input text appears first in this
+   list. Its definition is left-recursive. *)
+
+(* [inline_reversed_separated_nonempty_llist(separator, X)] is semantically
+   equivalent to [reversed_separated_nonempty_llist(separator, X)], but is
+   marked %inline, which means that the case of a list of length one and
+   the case of a list of length more than one will be distinguished at the
+   use site, and will give rise there to two productions. This can be used
+   to avoid certain conflicts. *)
+
+%inline inline_reversed_separated_nonempty_llist(separator, X):
+  x = X
+    { [ x ] }
+| xs = reversed_separated_nonempty_llist(separator, X)
+  separator
+  x = X
+    { x :: xs }
+
+reversed_separated_nonempty_llist(separator, X):
+  xs = inline_reversed_separated_nonempty_llist(separator, X)
+    { xs }
+
+(* [separated_nonempty_llist(separator, X)] recognizes a nonempty list of [X]s,
+   separated with [separator]s, and produces an OCaml list in direct order --
+   that is, the first element in the input text appears first in this list. *)
+
+%inline separated_nonempty_llist(separator, X):
+  xs = rev(reversed_separated_nonempty_llist(separator, X))
+    { xs }
+
+%inline inline_separated_nonempty_llist(separator, X):
+  xs = rev(inline_reversed_separated_nonempty_llist(separator, X))
+    { xs }
+
+(* [reversed_separated_nontrivial_llist(separator, X)] recognizes a list of at
+   least two [X]s, separated with [separator]s, and produces an OCaml list in
+   reverse order -- that is, the last element in the input text appears first
+   in this list. Its definition is left-recursive. *)
+
+reversed_separated_nontrivial_llist(separator, X):
+  xs = reversed_separated_nontrivial_llist(separator, X)
+  separator
+  x = X
+    { x :: xs }
+| x1 = X
+  separator
+  x2 = X
+    { [ x2; x1 ] }
+
+(* [separated_nontrivial_llist(separator, X)] recognizes a list of at least
+   two [X]s, separated with [separator]s, and produces an OCaml list in direct
+   order -- that is, the first element in the input text appears first in this
+   list. *)
+
+%inline separated_nontrivial_llist(separator, X):
+  xs = rev(reversed_separated_nontrivial_llist(separator, X))
+    { xs }
+
+(* [separated_or_terminated_nonempty_list(delimiter, X)] recognizes a nonempty
+   list of [X]s, separated with [delimiter]s, and optionally terminated with a
+   final [delimiter]. Its definition is right-recursive. *)
+
+separated_or_terminated_nonempty_list(delimiter, X):
+  x = X ioption(delimiter)
+    { [x] }
+| x = X
+  delimiter
+  xs = separated_or_terminated_nonempty_list(delimiter, X)
+    { x :: xs }
+
+(* [reversed_preceded_or_separated_nonempty_llist(delimiter, X)] recognizes a
+   nonempty list of [X]s, separated with [delimiter]s, and optionally preceded
+   with a leading [delimiter]. It produces an OCaml list in reverse order. Its
+   definition is left-recursive. *)
+
+reversed_preceded_or_separated_nonempty_llist(delimiter, X):
+  ioption(delimiter) x = X
+    { [x] }
+| xs = reversed_preceded_or_separated_nonempty_llist(delimiter, X)
+  delimiter
+  x = X
+    { x :: xs }
+
+(* [preceded_or_separated_nonempty_llist(delimiter, X)] recognizes a nonempty
+   list of [X]s, separated with [delimiter]s, and optionally preceded with a
+   leading [delimiter]. It produces an OCaml list in direct order. *)
+
+%inline preceded_or_separated_nonempty_llist(delimiter, X):
+  xs = rev(reversed_preceded_or_separated_nonempty_llist(delimiter, X))
+    { xs }
+
+(* [bar_llist(X)] recognizes a nonempty list of [X]'s, separated with BARs,
+   with an optional leading BAR. We assume that [X] is itself parameterized
+   with an opening symbol, which can be [epsilon] or [BAR]. *)
+
+(* This construction may seem needlessly complicated: one might think that
+   using [preceded_or_separated_nonempty_llist(BAR, X)], where [X] is *not*
+   itself parameterized, would be sufficient. Indeed, this simpler approach
+   would recognize the same language. However, the two approaches differ in
+   the footprint of [X]. We want the start location of [X] to include [BAR]
+   when present. In the future, we might consider switching to the simpler
+   definition, at the cost of producing slightly different locations. TODO *)
+
+reversed_bar_llist(X):
+    (* An [X] without a leading BAR. *)
+    x = X(epsilon)
+      { [x] }
+  | (* An [X] with a leading BAR. *)
+    x = X(BAR)
+      { [x] }
+  | (* An initial list, followed with a BAR and an [X]. *)
+    xs = reversed_bar_llist(X)
+    x = X(BAR)
+      { x :: xs }
+
+%inline bar_llist(X):
+  xs = reversed_bar_llist(X)
+    { List.rev xs }
+
+(* [xlist(A, B)] recognizes [AB*]. We assume that the semantic value for [A]
+   is a pair [x, b], while the semantic value for [B*] is a list [bs].
+   We return the pair [x, b :: bs]. *)
+
+%inline xlist(A, B):
+  a = A bs = B*
+    { let (x, b) = a in x, b :: bs }
+
+(* [listx(delimiter, X, Y)] recognizes a nonempty list of [X]s, optionally
+   followed with a [Y], separated-or-terminated with [delimiter]s. The
+   semantic value is a pair of a list of [X]s and an optional [Y]. *)
+
+listx(delimiter, X, Y):
+| x = X ioption(delimiter)
+    { [x], None }
+| x = X delimiter y = Y delimiter?
+    { [x], Some y }
+| x = X
+  delimiter
+  tail = listx(delimiter, X, Y)
+    { let xs, y = tail in
+      x :: xs, y }
+
+(* -------------------------------------------------------------------------- *)
+
+(* Entry points. *)
+
+(* An .ml file. *)
+implementation:
+  structure EOF
+    { $1 }
+;
+
+(* An .mli file. *)
+interface:
+  signature EOF
+    { $1 }
+;
+
+(* A toplevel phrase. *)
+toplevel_phrase:
+  (* An expression with attributes, ended by a double semicolon. *)
+  extra_str(text_str(str_exp))
+  SEMISEMI
+    { Ptop_def $1 }
+| (* A list of structure items, ended by a double semicolon. *)
+  extra_str(flatten(text_str(structure_item)*))
+  SEMISEMI
+    { Ptop_def $1 }
+| (* A directive, ended by a double semicolon. *)
+  toplevel_directive
+  SEMISEMI
+    { $1 }
+| (* End of input. *)
+  EOF
+    { raise End_of_file }
+;
+
+(* An .ml file that is read by #use. *)
+use_file:
+  (* An optional standalone expression,
+     followed with a series of elements,
+     followed with EOF. *)
+  extra_def(append(
+    optional_use_file_standalone_expression,
+    flatten(use_file_element*)
+  ))
+  EOF
+    { $1 }
+;
+
+(* An optional standalone expression is just an expression with attributes
+   (str_exp), with extra wrapping. *)
+%inline optional_use_file_standalone_expression:
+  iloption(text_def(top_def(str_exp)))
+    { $1 }
+;
+
+(* An element in a #used file is one of the following:
+   - a double semicolon followed with an optional standalone expression;
+   - a structure item;
+   - a toplevel directive.
+ *)
+%inline use_file_element:
+  preceded(SEMISEMI, optional_use_file_standalone_expression)
+| text_def(top_def(structure_item))
+| text_def(mark_rhs_docs(toplevel_directive))
+      { $1 }
+;
+
+parse_core_type:
+  core_type EOF
+    { $1 }
+;
+
+parse_expression:
+  seq_expr EOF
+    { $1 }
+;
+
+parse_pattern:
+  pattern EOF
+    { $1 }
+;
+
+parse_mty_longident:
+  mty_longident EOF
+    { $1 }
+;
+
+parse_val_longident:
+  val_longident EOF
+    { $1 }
+;
+
+parse_constr_longident:
+  constr_longident EOF
+    { $1 }
+;
+
+parse_mod_ext_longident:
+  mod_ext_longident EOF
+    { $1 }
+;
+
+parse_mod_longident:
+  mod_longident EOF
+    { $1 }
+;
+
+parse_any_longident:
+  any_longident EOF
+    { $1 }
+;
+(* -------------------------------------------------------------------------- *)
+
+(* Functor arguments appear in module expressions and module types. *)
+
+%inline functor_args:
+  reversed_nonempty_llist(functor_arg)
+    { $1 }
+    (* Produce a reversed list on purpose;
+       later processed using [fold_left]. *)
+;
+
+functor_arg:
+    (* An anonymous and untyped argument. *)
+    LPAREN RPAREN
+      { Unit }
+  | (* An argument accompanied with an explicit type. *)
+    LPAREN x = mkrhs(module_name) COLON mty = module_type RPAREN
+      { Named (x, mty) }
+;
+
+module_name:
+    (* A named argument. *)
+    x = UIDENT
+      { Some x }
+  | (* An anonymous argument. *)
+    UNDERSCORE
+      { None }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+(* Module expressions. *)
+
+(* The syntax of module expressions is not properly stratified. The cases of
+   functors, functor applications, and attributes interact and cause conflicts,
+   which are resolved by precedence declarations. This is concise but fragile.
+   Perhaps in the future an explicit stratification could be used. *)
+
+module_expr:
+  | STRUCT attrs = attributes s = structure END
+      { mkmod ~loc:$sloc ~attrs (Pmod_structure s) }
+  | STRUCT attributes structure error
+      { unclosed "struct" $loc($1) "end" $loc($4) }
+  | FUNCTOR attrs = attributes args = functor_args MINUSGREATER me = module_expr
+      { wrap_mod_attrs ~loc:$sloc attrs (
+          List.fold_left (fun acc arg ->
+            mkmod ~loc:$sloc (Pmod_functor (arg, acc))
+          ) me args
+        ) }
+  | me = paren_module_expr
+      { me }
+  | me = module_expr attr = attribute
+      { Mod.attr me attr }
+  | mkmod(
+      (* A module identifier. *)
+      x = mkrhs(mod_longident)
+        { Pmod_ident x }
+    | (* In a functor application, the actual argument must be parenthesized. *)
+      me1 = module_expr me2 = paren_module_expr
+        { Pmod_apply(me1, me2) }
+    | (* Application to unit is sugar for application to an empty structure. *)
+      me1 = module_expr LPAREN RPAREN
+        { (* TODO review mkmod location *)
+          Pmod_apply(me1, mkmod ~loc:$sloc (Pmod_structure [])) }
+    | (* An extension. *)
+      ex = extension
+        { Pmod_extension ex }
+    )
+    { $1 }
+;
+
+(* A parenthesized module expression is a module expression that begins
+   and ends with parentheses. *)
+
+paren_module_expr:
+    (* A module expression annotated with a module type. *)
+    LPAREN me = module_expr COLON mty = module_type RPAREN
+      { mkmod ~loc:$sloc (Pmod_constraint(me, mty)) }
+  | LPAREN module_expr COLON module_type error
+      { unclosed "(" $loc($1) ")" $loc($5) }
+  | (* A module expression within parentheses. *)
+    LPAREN me = module_expr RPAREN
+      { me (* TODO consider reloc *) }
+  | LPAREN module_expr error
+      { unclosed "(" $loc($1) ")" $loc($3) }
+  | (* A core language expression that produces a first-class module.
+       This expression can be annotated in various ways. *)
+    LPAREN VAL attrs = attributes e = expr_colon_package_type RPAREN
+      { mkmod ~loc:$sloc ~attrs (Pmod_unpack e) }
+  | LPAREN VAL attributes expr COLON error
+      { unclosed "(" $loc($1) ")" $loc($6) }
+  | LPAREN VAL attributes expr COLONGREATER error
+      { unclosed "(" $loc($1) ")" $loc($6) }
+  | LPAREN VAL attributes expr error
+      { unclosed "(" $loc($1) ")" $loc($5) }
+;
+
+(* The various ways of annotating a core language expression that
+   produces a first-class module that we wish to unpack. *)
+%inline expr_colon_package_type:
+    e = expr
+      { e }
+  | e = expr COLON ty = package_type
+      { ghexp ~loc:$loc (Pexp_constraint (e, ty)) }
+  | e = expr COLON ty1 = package_type COLONGREATER ty2 = package_type
+      { ghexp ~loc:$loc (Pexp_coerce (e, Some ty1, ty2)) }
+  | e = expr COLONGREATER ty2 = package_type
+      { ghexp ~loc:$loc (Pexp_coerce (e, None, ty2)) }
+;
+
+(* A structure, which appears between STRUCT and END (among other places),
+   begins with an optional standalone expression, and continues with a list
+   of structure elements. *)
+structure:
+  extra_str(append(
+    optional_structure_standalone_expression,
+    flatten(structure_element*)
+  ))
+  { $1 }
+;
+
+(* An optional standalone expression is just an expression with attributes
+   (str_exp), with extra wrapping. *)
+%inline optional_structure_standalone_expression:
+  items = iloption(mark_rhs_docs(text_str(str_exp)))
+    { items }
+;
+
+(* An expression with attributes, wrapped as a structure item. *)
+%inline str_exp:
+  e = seq_expr
+  attrs = post_item_attributes
+    { mkstrexp e attrs }
+;
+
+(* A structure element is one of the following:
+   - a double semicolon followed with an optional standalone expression;
+   - a structure item. *)
+%inline structure_element:
+    append(text_str_SEMISEMI, optional_structure_standalone_expression)
+  | text_str(structure_item)
+      { $1 }
+;
+
+(* A structure item. *)
+structure_item:
+    let_bindings(ext)
+      { val_of_let_bindings ~loc:$sloc $1 }
+  | mkstr(
+      item_extension post_item_attributes
+        { let docs = symbol_docs $sloc in
+          Pstr_extension ($1, add_docs_attrs docs $2) }
+    | floating_attribute
+        { Pstr_attribute $1 }
+    )
+  | wrap_mkstr_ext(
+      primitive_declaration
+        { pstr_primitive $1 }
+    | value_description
+        { pstr_primitive $1 }
+    | type_declarations
+        { pstr_type $1 }
+    | str_type_extension
+        { pstr_typext $1 }
+    | str_exception_declaration
+        { pstr_exception $1 }
+    | module_binding
+        { $1 }
+    | rec_module_bindings
+        { pstr_recmodule $1 }
+    | module_type_declaration
+        { let (body, ext) = $1 in (Pstr_modtype body, ext) }
+    | open_declaration
+        { let (body, ext) = $1 in (Pstr_open body, ext) }
+    | class_declarations
+        { let (ext, l) = $1 in (Pstr_class l, ext) }
+    | class_type_declarations
+        { let (ext, l) = $1 in (Pstr_class_type l, ext) }
+    | include_statement(module_expr)
+        { pstr_include $1 }
+    )
+    { $1 }
+;
+
+(* A single module binding. *)
+%inline module_binding:
+  MODULE
+  ext = ext attrs1 = attributes
+  name = mkrhs(module_name)
+  body = module_binding_body
+  attrs2 = post_item_attributes
+    { let docs = symbol_docs $sloc in
+      let loc = make_loc $sloc in
+      let attrs = attrs1 @ attrs2 in
+      let body = Mb.mk name body ~attrs ~loc ~docs in
+      Pstr_module body, ext }
+;
+
+(* The body (right-hand side) of a module binding. *)
+module_binding_body:
+    EQUAL me = module_expr
+      { me }
+  | mkmod(
+      COLON mty = module_type EQUAL me = module_expr
+        { Pmod_constraint(me, mty) }
+    | arg = functor_arg body = module_binding_body
+        { Pmod_functor(arg, body) }
+  ) { $1 }
+;
+
+(* A group of recursive module bindings. *)
+%inline rec_module_bindings:
+  xlist(rec_module_binding, and_module_binding)
+    { $1 }
+;
+
+(* The first binding in a group of recursive module bindings. *)
+%inline rec_module_binding:
+  MODULE
+  ext = ext
+  attrs1 = attributes
+  REC
+  name = mkrhs(module_name)
+  body = module_binding_body
+  attrs2 = post_item_attributes
+  {
+    let loc = make_loc $sloc in
+    let attrs = attrs1 @ attrs2 in
+    let docs = symbol_docs $sloc in
+    ext,
+    Mb.mk name body ~attrs ~loc ~docs
+  }
+;
+
+(* The following bindings in a group of recursive module bindings. *)
+%inline and_module_binding:
+  AND
+  attrs1 = attributes
+  name = mkrhs(module_name)
+  body = module_binding_body
+  attrs2 = post_item_attributes
+  {
+    let loc = make_loc $sloc in
+    let attrs = attrs1 @ attrs2 in
+    let docs = symbol_docs $sloc in
+    let text = symbol_text $symbolstartpos in
+    Mb.mk name body ~attrs ~loc ~text ~docs
+  }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+(* Shared material between structures and signatures. *)
+
+(* An [include] statement can appear in a structure or in a signature,
+   which is why this definition is parameterized. *)
+%inline include_statement(thing):
+  INCLUDE
+  ext = ext
+  attrs1 = attributes
+  thing = thing
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Incl.mk thing ~attrs ~loc ~docs, ext
+  }
+;
+
+(* A module type declaration. *)
+module_type_declaration:
+  MODULE TYPE
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(ident)
+  typ = preceded(EQUAL, module_type)?
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Mtd.mk id ?typ ~attrs ~loc ~docs, ext
+  }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+(* Opens. *)
+
+open_declaration:
+  OPEN
+  override = override_flag
+  ext = ext
+  attrs1 = attributes
+  me = module_expr
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Opn.mk me ~override ~attrs ~loc ~docs, ext
+  }
+;
+
+open_description:
+  OPEN
+  override = override_flag
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(mod_ext_longident)
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Opn.mk id ~override ~attrs ~loc ~docs, ext
+  }
+;
+
+%inline open_dot_declaration: mkrhs(mod_longident)
+  { let loc = make_loc $loc($1) in
+    let me = Mod.ident ~loc $1 in
+    Opn.mk ~loc me }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+/* Module types */
+
+module_type:
+  | SIG attrs = attributes s = signature END
+      { mkmty ~loc:$sloc ~attrs (Pmty_signature s) }
+  | SIG attributes signature error
+      { unclosed "sig" $loc($1) "end" $loc($4) }
+  | FUNCTOR attrs = attributes args = functor_args
+    MINUSGREATER mty = module_type
+      %prec below_WITH
+      { wrap_mty_attrs ~loc:$sloc attrs (
+          List.fold_left (fun acc arg ->
+            mkmty ~loc:$sloc (Pmty_functor (arg, acc))
+          ) mty args
+        ) }
+  | MODULE TYPE OF attributes module_expr %prec below_LBRACKETAT
+      { mkmty ~loc:$sloc ~attrs:$4 (Pmty_typeof $5) }
+  | LPAREN module_type RPAREN
+      { $2 }
+  | LPAREN module_type error
+      { unclosed "(" $loc($1) ")" $loc($3) }
+  | module_type attribute
+      { Mty.attr $1 $2 }
+  | mkmty(
+      mkrhs(mty_longident)
+        { Pmty_ident $1 }
+    | module_type MINUSGREATER module_type
+        %prec below_WITH
+        { Pmty_functor(Named (mknoloc None, $1), $3) }
+    | module_type WITH separated_nonempty_llist(AND, with_constraint)
+        { Pmty_with($1, $3) }
+/*  | LPAREN MODULE mkrhs(mod_longident) RPAREN
+        { Pmty_alias $3 } */
+    | extension
+        { Pmty_extension $1 }
+    )
+    { $1 }
+;
+(* A signature, which appears between SIG and END (among other places),
+   is a list of signature elements. *)
+signature:
+  extra_sig(flatten(signature_element*))
+    { $1 }
+;
+
+(* A signature element is one of the following:
+   - a double semicolon;
+   - a signature item. *)
+%inline signature_element:
+    text_sig_SEMISEMI
+  | text_sig(signature_item)
+      { $1 }
+;
+
+(* A signature item. *)
+signature_item:
+  | item_extension post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mksig ~loc:$sloc (Psig_extension ($1, (add_docs_attrs docs $2))) }
+  | mksig(
+      floating_attribute
+        { Psig_attribute $1 }
+    )
+    { $1 }
+  | wrap_mksig_ext(
+      value_description
+        { psig_value $1 }
+    | primitive_declaration
+        { psig_value $1 }
+    | type_declarations
+        { psig_type $1 }
+    | type_subst_declarations
+        { psig_typesubst $1 }
+    | sig_type_extension
+        { psig_typext $1 }
+    | sig_exception_declaration
+        { psig_exception $1 }
+    | module_declaration
+        { let (body, ext) = $1 in (Psig_module body, ext) }
+    | module_alias
+        { let (body, ext) = $1 in (Psig_module body, ext) }
+    | module_subst
+        { let (body, ext) = $1 in (Psig_modsubst body, ext) }
+    | rec_module_declarations
+        { let (ext, l) = $1 in (Psig_recmodule l, ext) }
+    | module_type_declaration
+        { let (body, ext) = $1 in (Psig_modtype body, ext) }
+    | open_description
+        { let (body, ext) = $1 in (Psig_open body, ext) }
+    | include_statement(module_type)
+        { psig_include $1 }
+    | class_descriptions
+        { let (ext, l) = $1 in (Psig_class l, ext) }
+    | class_type_declarations
+        { let (ext, l) = $1 in (Psig_class_type l, ext) }
+    )
+    { $1 }
+
+(* A module declaration. *)
+%inline module_declaration:
+  MODULE
+  ext = ext attrs1 = attributes
+  name = mkrhs(module_name)
+  body = module_declaration_body
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Md.mk name body ~attrs ~loc ~docs, ext
+  }
+;
+
+(* The body (right-hand side) of a module declaration. *)
+module_declaration_body:
+    COLON mty = module_type
+      { mty }
+  | mkmty(
+      arg = functor_arg body = module_declaration_body
+        { Pmty_functor(arg, body) }
+    )
+    { $1 }
+;
+
+(* A module alias declaration (in a signature). *)
+%inline module_alias:
+  MODULE
+  ext = ext attrs1 = attributes
+  name = mkrhs(module_name)
+  EQUAL
+  body = module_expr_alias
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Md.mk name body ~attrs ~loc ~docs, ext
+  }
+;
+%inline module_expr_alias:
+  id = mkrhs(mod_longident)
+    { Mty.alias ~loc:(make_loc $sloc) id }
+;
+(* A module substitution (in a signature). *)
+module_subst:
+  MODULE
+  ext = ext attrs1 = attributes
+  uid = mkrhs(UIDENT)
+  COLONEQUAL
+  body = mkrhs(mod_ext_longident)
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Ms.mk uid body ~attrs ~loc ~docs, ext
+  }
+| MODULE ext attributes mkrhs(UIDENT) COLONEQUAL error
+    { expecting $loc($6) "module path" }
+;
+
+(* A group of recursive module declarations. *)
+%inline rec_module_declarations:
+  xlist(rec_module_declaration, and_module_declaration)
+    { $1 }
+;
+%inline rec_module_declaration:
+  MODULE
+  ext = ext
+  attrs1 = attributes
+  REC
+  name = mkrhs(module_name)
+  COLON
+  mty = module_type
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    ext, Md.mk name mty ~attrs ~loc ~docs
+  }
+;
+%inline and_module_declaration:
+  AND
+  attrs1 = attributes
+  name = mkrhs(module_name)
+  COLON
+  mty = module_type
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let docs = symbol_docs $sloc in
+    let loc = make_loc $sloc in
+    let text = symbol_text $symbolstartpos in
+    Md.mk name mty ~attrs ~loc ~text ~docs
+  }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+(* Class declarations. *)
+
+%inline class_declarations:
+  xlist(class_declaration, and_class_declaration)
+    { $1 }
+;
+%inline class_declaration:
+  CLASS
+  ext = ext
+  attrs1 = attributes
+  virt = virtual_flag
+  params = formal_class_parameters
+  id = mkrhs(LIDENT)
+  body = class_fun_binding
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    ext,
+    Ci.mk id body ~virt ~params ~attrs ~loc ~docs
+  }
+;
+%inline and_class_declaration:
+  AND
+  attrs1 = attributes
+  virt = virtual_flag
+  params = formal_class_parameters
+  id = mkrhs(LIDENT)
+  body = class_fun_binding
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    let text = symbol_text $symbolstartpos in
+    Ci.mk id body ~virt ~params ~attrs ~loc ~text ~docs
+  }
+;
+
+class_fun_binding:
+    EQUAL class_expr
+      { $2 }
+  | mkclass(
+      COLON class_type EQUAL class_expr
+        { Pcl_constraint($4, $2) }
+    | labeled_simple_pattern class_fun_binding
+      { let (l,o,p) = $1 in Pcl_fun(l, o, p, $2) }
+    ) { $1 }
+;
+
+formal_class_parameters:
+  params = class_parameters(type_parameter)
+    { params }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+(* Class expressions. *)
+
+class_expr:
+    class_simple_expr
+      { $1 }
+  | FUN attributes class_fun_def
+      { wrap_class_attrs ~loc:$sloc $3 $2 }
+  | let_bindings(no_ext) IN class_expr
+      { class_of_let_bindings ~loc:$sloc $1 $3 }
+  | LET OPEN override_flag attributes mkrhs(mod_longident) IN class_expr
+      { let loc = ($startpos($2), $endpos($4)) in
+        let od = Opn.mk ~override:$3 ~loc:(make_loc loc) $5 in
+        mkclass ~loc:$sloc ~attrs:$4 (Pcl_open(od, $7)) }
+  | class_expr attribute
+      { Cl.attr $1 $2 }
+  | mkclass(
+      class_simple_expr nonempty_llist(labeled_simple_expr)
+        { Pcl_apply($1, $2) }
+    | extension
+        { Pcl_extension $1 }
+    ) { $1 }
+;
+class_simple_expr:
+  | LPAREN class_expr RPAREN
+      { $2 }
+  | LPAREN class_expr error
+      { unclosed "(" $loc($1) ")" $loc($3) }
+  | mkclass(
+      tys = actual_class_parameters cid = mkrhs(class_longident)
+        { Pcl_constr(cid, tys) }
+    | OBJECT attributes class_structure error
+        { unclosed "object" $loc($1) "end" $loc($4) }
+    | LPAREN class_expr COLON class_type RPAREN
+        { Pcl_constraint($2, $4) }
+    | LPAREN class_expr COLON class_type error
+        { unclosed "(" $loc($1) ")" $loc($5) }
+    ) { $1 }
+  | OBJECT attributes class_structure END
+    { mkclass ~loc:$sloc ~attrs:$2 (Pcl_structure $3) }
+;
+
+class_fun_def:
+  mkclass(
+    labeled_simple_pattern MINUSGREATER e = class_expr
+  | labeled_simple_pattern e = class_fun_def
+      { let (l,o,p) = $1 in Pcl_fun(l, o, p, e) }
+  ) { $1 }
+;
+%inline class_structure:
+  |  class_self_pattern extra_cstr(class_fields)
+       { Cstr.mk $1 $2 }
+;
+class_self_pattern:
+    LPAREN pattern RPAREN
+      { reloc_pat ~loc:$sloc $2 }
+  | mkpat(LPAREN pattern COLON core_type RPAREN
+      { Ppat_constraint($2, $4) })
+      { $1 }
+  | /* empty */
+      { ghpat ~loc:$sloc Ppat_any }
+;
+%inline class_fields:
+  flatten(text_cstr(class_field)*)
+    { $1 }
+;
+class_field:
+  | INHERIT override_flag attributes class_expr
+    self = preceded(AS, mkrhs(LIDENT))?
+    post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkcf ~loc:$sloc (Pcf_inherit ($2, $4, self)) ~attrs:($3@$6) ~docs }
+  | VAL value post_item_attributes
+      { let v, attrs = $2 in
+        let docs = symbol_docs $sloc in
+        mkcf ~loc:$sloc (Pcf_val v) ~attrs:(attrs@$3) ~docs }
+  | METHOD method_ post_item_attributes
+      { let meth, attrs = $2 in
+        let docs = symbol_docs $sloc in
+        mkcf ~loc:$sloc (Pcf_method meth) ~attrs:(attrs@$3) ~docs }
+  | CONSTRAINT attributes constrain_field post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkcf ~loc:$sloc (Pcf_constraint $3) ~attrs:($2@$4) ~docs }
+  | INITIALIZER attributes seq_expr post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkcf ~loc:$sloc (Pcf_initializer $3) ~attrs:($2@$4) ~docs }
+  | item_extension post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkcf ~loc:$sloc (Pcf_extension $1) ~attrs:$2 ~docs }
+  | mkcf(floating_attribute
+      { Pcf_attribute $1 })
+      { $1 }
+;
+value:
+    no_override_flag
+    attrs = attributes
+    mutable_ = virtual_with_mutable_flag
+    label = mkrhs(label) COLON ty = core_type
+      { (label, mutable_, Cfk_virtual ty), attrs }
+  | override_flag attributes mutable_flag mkrhs(label) EQUAL seq_expr
+      { ($4, $3, Cfk_concrete ($1, $6)), $2 }
+  | override_flag attributes mutable_flag mkrhs(label) type_constraint
+    EQUAL seq_expr
+      { let e = mkexp_constraint ~loc:$sloc $7 $5 in
+        ($4, $3, Cfk_concrete ($1, e)), $2
+      }
+;
+method_:
+    no_override_flag
+    attrs = attributes
+    private_ = virtual_with_private_flag
+    label = mkrhs(label) COLON ty = poly_type
+      { (label, private_, Cfk_virtual ty), attrs }
+  | override_flag attributes private_flag mkrhs(label) strict_binding
+      { let e = $5 in
+        let loc = Location.(e.pexp_loc.loc_start, e.pexp_loc.loc_end) in
+        ($4, $3,
+        Cfk_concrete ($1, ghexp ~loc (Pexp_poly (e, None)))), $2 }
+  | override_flag attributes private_flag mkrhs(label)
+    COLON poly_type EQUAL seq_expr
+      { let poly_exp =
+          let loc = ($startpos($6), $endpos($8)) in
+          ghexp ~loc (Pexp_poly($8, Some $6)) in
+        ($4, $3, Cfk_concrete ($1, poly_exp)), $2 }
+  | override_flag attributes private_flag mkrhs(label) COLON TYPE lident_list
+    DOT core_type EQUAL seq_expr
+      { let poly_exp_loc = ($startpos($7), $endpos($11)) in
+        let poly_exp =
+          let exp, poly =
+            (* it seems odd to use the global ~loc here while poly_exp_loc
+               is tighter, but this is what ocamlyacc does;
+               TODO improve parser.mly *)
+            wrap_type_annotation ~loc:$sloc $7 $9 $11 in
+          ghexp ~loc:poly_exp_loc (Pexp_poly(exp, Some poly)) in
+        ($4, $3,
+        Cfk_concrete ($1, poly_exp)), $2 }
+;
+
+/* Class types */
+
+class_type:
+    class_signature
+      { $1 }
+  | mkcty(
+      label = arg_label
+      domain = tuple_type
+      MINUSGREATER
+      codomain = class_type
+        { Pcty_arrow(label, domain, codomain) }
+    ) { $1 }
+ ;
+class_signature:
+    mkcty(
+      tys = actual_class_parameters cid = mkrhs(clty_longident)
+        { Pcty_constr (cid, tys) }
+    | extension
+        { Pcty_extension $1 }
+    ) { $1 }
+  | OBJECT attributes class_sig_body END
+      { mkcty ~loc:$sloc ~attrs:$2 (Pcty_signature $3) }
+  | OBJECT attributes class_sig_body error
+      { unclosed "object" $loc($1) "end" $loc($4) }
+  | class_signature attribute
+      { Cty.attr $1 $2 }
+  | LET OPEN override_flag attributes mkrhs(mod_longident) IN class_signature
+      { let loc = ($startpos($2), $endpos($4)) in
+        let od = Opn.mk ~override:$3 ~loc:(make_loc loc) $5 in
+        mkcty ~loc:$sloc ~attrs:$4 (Pcty_open(od, $7)) }
+;
+%inline class_parameters(parameter):
+  | /* empty */
+      { [] }
+  | LBRACKET params = separated_nonempty_llist(COMMA, parameter) RBRACKET
+      { params }
+;
+%inline actual_class_parameters:
+  tys = class_parameters(core_type)
+    { tys }
+;
+%inline class_sig_body:
+    class_self_type extra_csig(class_sig_fields)
+      { Csig.mk $1 $2 }
+;
+class_self_type:
+    LPAREN core_type RPAREN
+      { $2 }
+  | mktyp((* empty *) { Ptyp_any })
+      { $1 }
+;
+%inline class_sig_fields:
+  flatten(text_csig(class_sig_field)*)
+    { $1 }
+;
+class_sig_field:
+    INHERIT attributes class_signature post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkctf ~loc:$sloc (Pctf_inherit $3) ~attrs:($2@$4) ~docs }
+  | VAL attributes value_type post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkctf ~loc:$sloc (Pctf_val $3) ~attrs:($2@$4) ~docs }
+  | METHOD attributes private_virtual_flags mkrhs(label) COLON poly_type
+    post_item_attributes
+      { let (p, v) = $3 in
+        let docs = symbol_docs $sloc in
+        mkctf ~loc:$sloc (Pctf_method ($4, p, v, $6)) ~attrs:($2@$7) ~docs }
+  | CONSTRAINT attributes constrain_field post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkctf ~loc:$sloc (Pctf_constraint $3) ~attrs:($2@$4) ~docs }
+  | item_extension post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkctf ~loc:$sloc (Pctf_extension $1) ~attrs:$2 ~docs }
+  | mkctf(floating_attribute
+      { Pctf_attribute $1 })
+      { $1 }
+;
+%inline value_type:
+  flags = mutable_virtual_flags
+  label = mkrhs(label)
+  COLON
+  ty = core_type
+  {
+    let mut, virt = flags in
+    label, mut, virt, ty
+  }
+;
+%inline constrain:
+    core_type EQUAL core_type
+    { $1, $3, make_loc $sloc }
+;
+constrain_field:
+  core_type EQUAL core_type
+    { $1, $3 }
+;
+(* A group of class descriptions. *)
+%inline class_descriptions:
+  xlist(class_description, and_class_description)
+    { $1 }
+;
+%inline class_description:
+  CLASS
+  ext = ext
+  attrs1 = attributes
+  virt = virtual_flag
+  params = formal_class_parameters
+  id = mkrhs(LIDENT)
+  COLON
+  cty = class_type
+  attrs2 = post_item_attributes
+    {
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let docs = symbol_docs $sloc in
+      ext,
+      Ci.mk id cty ~virt ~params ~attrs ~loc ~docs
+    }
+;
+%inline and_class_description:
+  AND
+  attrs1 = attributes
+  virt = virtual_flag
+  params = formal_class_parameters
+  id = mkrhs(LIDENT)
+  COLON
+  cty = class_type
+  attrs2 = post_item_attributes
+    {
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let docs = symbol_docs $sloc in
+      let text = symbol_text $symbolstartpos in
+      Ci.mk id cty ~virt ~params ~attrs ~loc ~text ~docs
+    }
+;
+class_type_declarations:
+  xlist(class_type_declaration, and_class_type_declaration)
+    { $1 }
+;
+%inline class_type_declaration:
+  CLASS TYPE
+  ext = ext
+  attrs1 = attributes
+  virt = virtual_flag
+  params = formal_class_parameters
+  id = mkrhs(LIDENT)
+  EQUAL
+  csig = class_signature
+  attrs2 = post_item_attributes
+    {
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let docs = symbol_docs $sloc in
+      ext,
+      Ci.mk id csig ~virt ~params ~attrs ~loc ~docs
+    }
+;
+%inline and_class_type_declaration:
+  AND
+  attrs1 = attributes
+  virt = virtual_flag
+  params = formal_class_parameters
+  id = mkrhs(LIDENT)
+  EQUAL
+  csig = class_signature
+  attrs2 = post_item_attributes
+    {
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let docs = symbol_docs $sloc in
+      let text = symbol_text $symbolstartpos in
+      Ci.mk id csig ~virt ~params ~attrs ~loc ~text ~docs
+    }
+;
+
+/* Core expressions */
+
+seq_expr:
+  | expr        %prec below_SEMI  { $1 }
+  | expr SEMI                     { $1 }
+  | mkexp(expr SEMI seq_expr
+    { Pexp_sequence($1, $3) })
+    { $1 }
+  | expr SEMI PERCENT attr_id seq_expr
+    { let seq = mkexp ~loc:$sloc (Pexp_sequence ($1, $5)) in
+      let payload = PStr [mkstrexp seq []] in
+      mkexp ~loc:$sloc (Pexp_extension ($4, payload)) }
+;
+labeled_simple_pattern:
+    QUESTION LPAREN label_let_pattern opt_default RPAREN
+      { (Optional (fst $3), $4, snd $3) }
+  | QUESTION label_var
+      { (Optional (fst $2), None, snd $2) }
+  | OPTLABEL LPAREN let_pattern opt_default RPAREN
+      { (Optional $1, $4, $3) }
+  | OPTLABEL pattern_var
+      { (Optional $1, None, $2) }
+  | TILDE LPAREN label_let_pattern RPAREN
+      { (Labelled (fst $3), None, snd $3) }
+  | TILDE label_var
+      { (Labelled (fst $2), None, snd $2) }
+  | LABEL simple_pattern
+      { (Labelled $1, None, $2) }
+  | simple_pattern
+      { (Nolabel, None, $1) }
+;
+
+pattern_var:
+  mkpat(
+      mkrhs(LIDENT)     { Ppat_var $1 }
+    | UNDERSCORE        { Ppat_any }
+  ) { $1 }
+;
+
+%inline opt_default:
+  preceded(EQUAL, seq_expr)?
+    { $1 }
+;
+label_let_pattern:
+    x = label_var
+      { x }
+  | x = label_var COLON cty = core_type
+      { let lab, pat = x in
+        lab,
+        mkpat ~loc:$sloc (Ppat_constraint (pat, cty)) }
+;
+%inline label_var:
+    mkrhs(LIDENT)
+      { ($1.Location.txt, mkpat ~loc:$sloc (Ppat_var $1)) }
+;
+let_pattern:
+    pattern
+      { $1 }
+  | mkpat(pattern COLON core_type
+      { Ppat_constraint($1, $3) })
+      { $1 }
+;
+
+expr:
+    simple_expr %prec below_HASH
+      { $1 }
+  | expr_attrs
+      { let desc, attrs = $1 in
+        mkexp_attrs ~loc:$sloc desc attrs }
+  | mkexp(expr_)
+      { $1 }
+  | let_bindings(ext) IN seq_expr
+      { expr_of_let_bindings ~loc:$sloc $1 $3 }
+  | pbop_op = mkrhs(LETOP) bindings = letop_bindings IN body = seq_expr
+      { let (pbop_pat, pbop_exp, rev_ands) = bindings in
+        let ands = List.rev rev_ands in
+        let pbop_loc = make_loc $sloc in
+        let let_ = {pbop_op; pbop_pat; pbop_exp; pbop_loc} in
+        mkexp ~loc:$sloc (Pexp_letop{ let_; ands; body}) }
+  | expr COLONCOLON expr
+      { mkexp_cons ~loc:$sloc $loc($2) (ghexp ~loc:$sloc (Pexp_tuple[$1;$3])) }
+  | mkrhs(label) LESSMINUS expr
+      { mkexp ~loc:$sloc (Pexp_setinstvar($1, $3)) }
+  | simple_expr DOT mkrhs(label_longident) LESSMINUS expr
+      { mkexp ~loc:$sloc (Pexp_setfield($1, $3, $5)) }
+  | simple_expr DOT LPAREN seq_expr RPAREN LESSMINUS expr
+      { array_set ~loc:$sloc $1 $4 $7 }
+  | simple_expr DOT LBRACKET seq_expr RBRACKET LESSMINUS expr
+      { string_set ~loc:$sloc $1 $4 $7 }
+  | simple_expr DOT LBRACE expr RBRACE LESSMINUS expr
+      { bigarray_set ~loc:$sloc $1 $4 $7 }
+  | simple_expr DOTOP LBRACKET expr_semi_list RBRACKET LESSMINUS expr
+      { dotop_set ~loc:$sloc lident bracket $2 $1 $4 $7 }
+  | simple_expr DOTOP LPAREN expr_semi_list RPAREN LESSMINUS expr
+      { dotop_set ~loc:$sloc lident paren $2 $1 $4 $7 }
+  | simple_expr DOTOP LBRACE expr_semi_list RBRACE LESSMINUS expr
+      { dotop_set ~loc:$sloc lident brace $2 $1 $4 $7 }
+  | simple_expr DOT mod_longident DOTOP LBRACKET expr_semi_list RBRACKET
+      LESSMINUS expr
+      { dotop_set ~loc:$sloc (ldot $3) bracket $4 $1 $6 $9 }
+  | simple_expr DOT mod_longident DOTOP LPAREN expr_semi_list RPAREN
+      LESSMINUS expr
+      { dotop_set ~loc:$sloc (ldot $3) paren $4 $1 $6 $9  }
+  | simple_expr DOT mod_longident DOTOP LBRACE expr_semi_list RBRACE
+      LESSMINUS expr
+      { dotop_set ~loc:$sloc (ldot $3) brace $4 $1 $6 $9 }
+  | expr attribute
+      { Exp.attr $1 $2 }
+  | UNDERSCORE
+     { not_expecting $loc($1) "wildcard \"_\"" }
+;
+%inline expr_attrs:
+  | LET MODULE ext_attributes mkrhs(module_name) module_binding_body IN seq_expr
+      { Pexp_letmodule($4, $5, $7), $3 }
+  | LET EXCEPTION ext_attributes let_exception_declaration IN seq_expr
+      { Pexp_letexception($4, $6), $3 }
+  | LET OPEN override_flag ext_attributes module_expr IN seq_expr
+      { let open_loc = make_loc ($startpos($2), $endpos($5)) in
+        let od = Opn.mk $5 ~override:$3 ~loc:open_loc in
+        Pexp_open(od, $7), $4 }
+  | FUNCTION ext_attributes match_cases
+      { Pexp_function $3, $2 }
+  | FUN ext_attributes labeled_simple_pattern fun_def
+      { let (l,o,p) = $3 in
+        Pexp_fun(l, o, p, $4), $2 }
+  | FUN ext_attributes LPAREN TYPE lident_list RPAREN fun_def
+      { (mk_newtypes ~loc:$sloc $5 $7).pexp_desc, $2 }
+  | MATCH ext_attributes seq_expr WITH match_cases
+      { Pexp_match($3, $5), $2 }
+  | TRY ext_attributes seq_expr WITH match_cases
+      { Pexp_try($3, $5), $2 }
+  | TRY ext_attributes seq_expr WITH error
+      { syntax_error() }
+  | IF ext_attributes seq_expr THEN expr ELSE expr
+      { Pexp_ifthenelse($3, $5, Some $7), $2 }
+  | IF ext_attributes seq_expr THEN expr
+      { Pexp_ifthenelse($3, $5, None), $2 }
+  | WHILE ext_attributes seq_expr DO seq_expr DONE
+      { Pexp_while($3, $5), $2 }
+  | FOR ext_attributes pattern EQUAL seq_expr direction_flag seq_expr DO
+    seq_expr DONE
+      { Pexp_for($3, $5, $7, $6, $9), $2 }
+  | ASSERT ext_attributes simple_expr %prec below_HASH
+      { Pexp_assert $3, $2 }
+  | LAZY ext_attributes simple_expr %prec below_HASH
+      { Pexp_lazy $3, $2 }
+  | OBJECT ext_attributes class_structure END
+      { Pexp_object $3, $2 }
+  | OBJECT ext_attributes class_structure error
+      { unclosed "object" $loc($1) "end" $loc($4) }
+;
+%inline expr_:
+  | simple_expr nonempty_llist(labeled_simple_expr)
+      { Pexp_apply($1, $2) }
+  | expr_comma_list %prec below_COMMA
+      { Pexp_tuple($1) }
+  | mkrhs(constr_longident) simple_expr %prec below_HASH
+      { Pexp_construct($1, Some $2) }
+  | name_tag simple_expr %prec below_HASH
+      { Pexp_variant($1, Some $2) }
+  | e1 = expr op = op(infix_operator) e2 = expr
+      { mkinfix e1 op e2 }
+  | subtractive expr %prec prec_unary_minus
+      { mkuminus ~oploc:$loc($1) $1 $2 }
+  | additive expr %prec prec_unary_plus
+      { mkuplus ~oploc:$loc($1) $1 $2 }
+;
+
+simple_expr:
+  | LPAREN seq_expr RPAREN
+      { reloc_exp ~loc:$sloc $2 }
+  | LPAREN seq_expr error
+      { unclosed "(" $loc($1) ")" $loc($3) }
+  | LPAREN seq_expr type_constraint RPAREN
+      { mkexp_constraint ~loc:$sloc $2 $3 }
+  | simple_expr DOT LPAREN seq_expr RPAREN
+      { array_get ~loc:$sloc $1 $4 }
+  | simple_expr DOT LPAREN seq_expr error
+      { unclosed "(" $loc($3) ")" $loc($5) }
+  | simple_expr DOT LBRACKET seq_expr RBRACKET
+      { string_get ~loc:$sloc $1 $4 }
+  | simple_expr DOT LBRACKET seq_expr error
+      { unclosed "[" $loc($3) "]" $loc($5) }
+  | simple_expr DOTOP LBRACKET expr_semi_list RBRACKET
+      { dotop_get ~loc:$sloc lident bracket $2 $1 $4 }
+  | simple_expr DOTOP LBRACKET expr_semi_list error
+      { unclosed "[" $loc($3) "]" $loc($5) }
+  | simple_expr DOTOP LPAREN expr_semi_list RPAREN
+      { dotop_get ~loc:$sloc lident paren $2 $1 $4  }
+  | simple_expr DOTOP LPAREN expr_semi_list error
+      { unclosed "(" $loc($3) ")" $loc($5) }
+  | simple_expr DOTOP LBRACE expr_semi_list RBRACE
+      { dotop_get ~loc:$sloc lident brace $2 $1 $4 }
+  | simple_expr DOTOP LBRACE expr error
+      { unclosed "{" $loc($3) "}" $loc($5) }
+  | simple_expr DOT mod_longident DOTOP LBRACKET expr_semi_list RBRACKET
+      { dotop_get ~loc:$sloc (ldot $3) bracket $4 $1 $6  }
+  | simple_expr DOT
+    mod_longident DOTOP LBRACKET expr_semi_list error
+      { unclosed "[" $loc($5) "]" $loc($7) }
+  | simple_expr DOT mod_longident DOTOP LPAREN expr_semi_list RPAREN
+      { dotop_get ~loc:$sloc (ldot $3) paren $4 $1 $6 }
+  | simple_expr DOT
+    mod_longident DOTOP LPAREN expr_semi_list error
+      { unclosed "(" $loc($5) ")" $loc($7) }
+  | simple_expr DOT mod_longident DOTOP LBRACE expr_semi_list RBRACE
+      { dotop_get ~loc:$sloc (ldot $3) brace $4 $1 $6  }
+  | simple_expr DOT
+    mod_longident DOTOP LBRACE expr_semi_list error
+      { unclosed "{" $loc($5) "}" $loc($7) }
+  | simple_expr DOT LBRACE expr RBRACE
+      { bigarray_get ~loc:$sloc $1 $4 }
+  | simple_expr DOT LBRACE expr error
+      { unclosed "{" $loc($3) "}" $loc($5) }
+  | simple_expr_attrs
+    { let desc, attrs = $1 in
+      mkexp_attrs ~loc:$sloc desc attrs }
+  | mkexp(simple_expr_)
+      { $1 }
+;
+%inline simple_expr_attrs:
+  | BEGIN ext = ext attrs = attributes e = seq_expr END
+      { e.pexp_desc, (ext, attrs @ e.pexp_attributes) }
+  | BEGIN ext_attributes END
+      { Pexp_construct (mkloc (Lident "()") (make_loc $sloc), None), $2 }
+  | BEGIN ext_attributes seq_expr error
+      { unclosed "begin" $loc($1) "end" $loc($4) }
+  | NEW ext_attributes mkrhs(class_longident)
+      { Pexp_new($3), $2 }
+  | LPAREN MODULE ext_attributes module_expr RPAREN
+      { Pexp_pack $4, $3 }
+  | LPAREN MODULE ext_attributes module_expr COLON package_type RPAREN
+      { Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $4), $6), $3 }
+  | LPAREN MODULE ext_attributes module_expr COLON error
+      { unclosed "(" $loc($1) ")" $loc($6) }
+;
+%inline simple_expr_:
+  | mkrhs(val_longident)
+      { Pexp_ident ($1) }
+  | constant
+      { Pexp_constant $1 }
+  | mkrhs(constr_longident) %prec prec_constant_constructor
+      { Pexp_construct($1, None) }
+  | name_tag %prec prec_constant_constructor
+      { Pexp_variant($1, None) }
+  | op(PREFIXOP) simple_expr
+      { Pexp_apply($1, [Nolabel,$2]) }
+  | op(BANG {"!"}) simple_expr
+      { Pexp_apply($1, [Nolabel,$2]) }
+  | LBRACELESS object_expr_content GREATERRBRACE
+      { Pexp_override $2 }
+  | LBRACELESS object_expr_content error
+      { unclosed "{<" $loc($1) ">}" $loc($3) }
+  | LBRACELESS GREATERRBRACE
+      { Pexp_override [] }
+  | simple_expr DOT mkrhs(label_longident)
+      { Pexp_field($1, $3) }
+  | od=open_dot_declaration DOT LPAREN seq_expr RPAREN
+      { Pexp_open(od, $4) }
+  | od=open_dot_declaration DOT LBRACELESS object_expr_content GREATERRBRACE
+      { (* TODO: review the location of Pexp_override *)
+        Pexp_open(od, mkexp ~loc:$sloc (Pexp_override $4)) }
+  | mod_longident DOT LBRACELESS object_expr_content error
+      { unclosed "{<" $loc($3) ">}" $loc($5) }
+  | simple_expr HASH mkrhs(label)
+      { Pexp_send($1, $3) }
+  | simple_expr op(HASHOP) simple_expr
+      { mkinfix $1 $2 $3 }
+  | extension
+      { Pexp_extension $1 }
+  | od=open_dot_declaration DOT mkrhs(LPAREN RPAREN {Lident "()"})
+      { (* TODO: review the location of Pexp_construct *)
+        Pexp_open(od, mkexp ~loc:$sloc (Pexp_construct($3, None))) }
+  | mod_longident DOT LPAREN seq_expr error
+      { unclosed "(" $loc($3) ")" $loc($5) }
+  | LBRACE record_expr_content RBRACE
+      { let (exten, fields) = $2 in
+        Pexp_record(fields, exten) }
+  | LBRACE record_expr_content error
+      { unclosed "{" $loc($1) "}" $loc($3) }
+  | od=open_dot_declaration DOT LBRACE record_expr_content RBRACE
+      { let (exten, fields) = $4 in
+        (* TODO: review the location of Pexp_construct *)
+        Pexp_open(od, mkexp ~loc:$sloc (Pexp_record(fields, exten))) }
+  | mod_longident DOT LBRACE record_expr_content error
+      { unclosed "{" $loc($3) "}" $loc($5) }
+  | LBRACKETBAR expr_semi_list BARRBRACKET
+      { Pexp_array($2) }
+  | LBRACKETBAR expr_semi_list error
+      { unclosed "[|" $loc($1) "|]" $loc($3) }
+  | LBRACKETBAR BARRBRACKET
+      { Pexp_array [] }
+  | od=open_dot_declaration DOT LBRACKETBAR expr_semi_list BARRBRACKET
+      { (* TODO: review the location of Pexp_array *)
+        Pexp_open(od, mkexp ~loc:$sloc (Pexp_array($4))) }
+  | od=open_dot_declaration DOT LBRACKETBAR BARRBRACKET
+      { (* TODO: review the location of Pexp_array *)
+        Pexp_open(od, mkexp ~loc:$sloc (Pexp_array [])) }
+  | mod_longident DOT
+    LBRACKETBAR expr_semi_list error
+      { unclosed "[|" $loc($3) "|]" $loc($5) }
+  | LBRACKET expr_semi_list RBRACKET
+      { fst (mktailexp $loc($3) $2) }
+  | LBRACKET expr_semi_list error
+      { unclosed "[" $loc($1) "]" $loc($3) }
+  | od=open_dot_declaration DOT LBRACKET expr_semi_list RBRACKET
+      { let list_exp =
+          (* TODO: review the location of list_exp *)
+          let tail_exp, _tail_loc = mktailexp $loc($5) $4 in
+          mkexp ~loc:$sloc tail_exp in
+        Pexp_open(od, list_exp) }
+  | od=open_dot_declaration DOT mkrhs(LBRACKET RBRACKET {Lident "[]"})
+      { (* TODO: review the location of Pexp_construct *)
+        Pexp_open(od, mkexp ~loc:$sloc (Pexp_construct($3, None))) }
+  | mod_longident DOT
+    LBRACKET expr_semi_list error
+      { unclosed "[" $loc($3) "]" $loc($5) }
+  | od=open_dot_declaration DOT LPAREN MODULE ext_attributes module_expr COLON
+    package_type RPAREN
+      { (* TODO: review the location of Pexp_constraint *)
+        let modexp =
+          mkexp_attrs ~loc:$sloc
+            (Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $6), $8)) $5 in
+        Pexp_open(od, modexp) }
+  | mod_longident DOT
+    LPAREN MODULE ext_attributes module_expr COLON error
+      { unclosed "(" $loc($3) ")" $loc($8) }
+;
+labeled_simple_expr:
+    simple_expr %prec below_HASH
+      { (Nolabel, $1) }
+  | LABEL simple_expr %prec below_HASH
+      { (Labelled $1, $2) }
+  | TILDE label = LIDENT
+      { let loc = $loc(label) in
+        (Labelled label, mkexpvar ~loc label) }
+  | QUESTION label = LIDENT
+      { let loc = $loc(label) in
+        (Optional label, mkexpvar ~loc label) }
+  | OPTLABEL simple_expr %prec below_HASH
+      { (Optional $1, $2) }
+;
+%inline lident_list:
+  xs = mkrhs(LIDENT)+
+    { xs }
+;
+%inline let_ident:
+    val_ident { mkpatvar ~loc:$sloc $1 }
+;
+let_binding_body:
+    let_ident strict_binding
+      { ($1, $2) }
+  | let_ident type_constraint EQUAL seq_expr
+      { let v = $1 in (* PR#7344 *)
+        let t =
+          match $2 with
+            Some t, None -> t
+          | _, Some t -> t
+          | _ -> assert false
+        in
+        let loc = Location.(t.ptyp_loc.loc_start, t.ptyp_loc.loc_end) in
+        let typ = ghtyp ~loc (Ptyp_poly([],t)) in
+        let patloc = ($startpos($1), $endpos($2)) in
+        (ghpat ~loc:patloc (Ppat_constraint(v, typ)),
+         mkexp_constraint ~loc:$sloc $4 $2) }
+  | let_ident COLON typevar_list DOT core_type EQUAL seq_expr
+      (* TODO: could replace [typevar_list DOT core_type]
+               with [mktyp(poly(core_type))]
+               and simplify the semantic action? *)
+      { let typloc = ($startpos($3), $endpos($5)) in
+        let patloc = ($startpos($1), $endpos($5)) in
+        (ghpat ~loc:patloc
+           (Ppat_constraint($1, ghtyp ~loc:typloc (Ptyp_poly($3,$5)))),
+         $7) }
+  | let_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr
+      { let exp, poly =
+          wrap_type_annotation ~loc:$sloc $4 $6 $8 in
+        let loc = ($startpos($1), $endpos($6)) in
+        (ghpat ~loc (Ppat_constraint($1, poly)), exp) }
+  | pattern_no_exn EQUAL seq_expr
+      { ($1, $3) }
+  | simple_pattern_not_ident COLON core_type EQUAL seq_expr
+      { let loc = ($startpos($1), $endpos($3)) in
+        (ghpat ~loc (Ppat_constraint($1, $3)), $5) }
+;
+(* The formal parameter EXT can be instantiated with ext or no_ext
+   so as to indicate whether an extension is allowed or disallowed. *)
+let_bindings(EXT):
+    let_binding(EXT)                            { $1 }
+  | let_bindings(EXT) and_let_binding           { addlb $1 $2 }
+;
+%inline let_binding(EXT):
+  LET
+  ext = EXT
+  attrs1 = attributes
+  rec_flag = rec_flag
+  body = let_binding_body
+  attrs2 = post_item_attributes
+    {
+      let attrs = attrs1 @ attrs2 in
+      mklbs ~loc:$sloc ext rec_flag (mklb ~loc:$sloc true body attrs)
+    }
+;
+and_let_binding:
+  AND
+  attrs1 = attributes
+  body = let_binding_body
+  attrs2 = post_item_attributes
+    {
+      let attrs = attrs1 @ attrs2 in
+      mklb ~loc:$sloc false body attrs
+    }
+;
+letop_binding_body:
+    pat = let_ident exp = strict_binding
+      { (pat, exp) }
+  | pat = simple_pattern COLON typ = core_type EQUAL exp = seq_expr
+      { let loc = ($startpos(pat), $endpos(typ)) in
+        (ghpat ~loc (Ppat_constraint(pat, typ)), exp) }
+  | pat = pattern_no_exn EQUAL exp = seq_expr
+      { (pat, exp) }
+;
+letop_bindings:
+    body = letop_binding_body
+      { let let_pat, let_exp = body in
+        let_pat, let_exp, [] }
+  | bindings = letop_bindings pbop_op = mkrhs(ANDOP) body = let_binding_body
+      { let let_pat, let_exp, rev_ands = bindings in
+        let pbop_pat, pbop_exp = body in
+        let pbop_loc = make_loc $sloc in
+        let and_ = {pbop_op; pbop_pat; pbop_exp; pbop_loc} in
+        let_pat, let_exp, and_ :: rev_ands }
+;
+fun_binding:
+    strict_binding
+      { $1 }
+  | type_constraint EQUAL seq_expr
+      { mkexp_constraint ~loc:$sloc $3 $1 }
+;
+strict_binding:
+    EQUAL seq_expr
+      { $2 }
+  | labeled_simple_pattern fun_binding
+      { let (l, o, p) = $1 in ghexp ~loc:$sloc (Pexp_fun(l, o, p, $2)) }
+  | LPAREN TYPE lident_list RPAREN fun_binding
+      { mk_newtypes ~loc:$sloc $3 $5 }
+;
+%inline match_cases:
+  xs = preceded_or_separated_nonempty_llist(BAR, match_case)
+    { xs }
+;
+match_case:
+    pattern MINUSGREATER seq_expr
+      { Exp.case $1 $3 }
+  | pattern WHEN seq_expr MINUSGREATER seq_expr
+      { Exp.case $1 ~guard:$3 $5 }
+  | pattern MINUSGREATER DOT
+      { Exp.case $1 (Exp.unreachable ~loc:(make_loc $loc($3)) ()) }
+;
+fun_def:
+    MINUSGREATER seq_expr
+      { $2 }
+  | mkexp(COLON atomic_type MINUSGREATER seq_expr
+      { Pexp_constraint ($4, $2) })
+      { $1 }
+/* Cf #5939: we used to accept (fun p when e0 -> e) */
+  | labeled_simple_pattern fun_def
+      {
+       let (l,o,p) = $1 in
+       ghexp ~loc:$sloc (Pexp_fun(l, o, p, $2))
+      }
+  | LPAREN TYPE lident_list RPAREN fun_def
+      { mk_newtypes ~loc:$sloc $3 $5 }
+;
+%inline expr_comma_list:
+  es = separated_nontrivial_llist(COMMA, expr)
+    { es }
+;
+record_expr_content:
+  eo = ioption(terminated(simple_expr, WITH))
+  fields = separated_or_terminated_nonempty_list(SEMI, record_expr_field)
+    { eo, fields }
+;
+%inline record_expr_field:
+  | label = mkrhs(label_longident)
+    c = type_constraint?
+    eo = preceded(EQUAL, expr)?
+      { let e =
+          match eo with
+          | None ->
+              (* No pattern; this is a pun. Desugar it. *)
+              exp_of_longident ~loc:$sloc label
+          | Some e ->
+              e
+        in
+        label, mkexp_opt_constraint ~loc:$sloc e c }
+;
+%inline object_expr_content:
+  xs = separated_or_terminated_nonempty_list(SEMI, object_expr_field)
+    { xs }
+;
+%inline object_expr_field:
+    label = mkrhs(label)
+    oe = preceded(EQUAL, expr)?
+      { let e =
+          match oe with
+          | None ->
+              (* No expression; this is a pun. Desugar it. *)
+              exp_of_label ~loc:$sloc label
+          | Some e ->
+              e
+        in
+        label, e }
+;
+%inline expr_semi_list:
+  es = separated_or_terminated_nonempty_list(SEMI, expr)
+    { es }
+;
+type_constraint:
+    COLON core_type                             { (Some $2, None) }
+  | COLON core_type COLONGREATER core_type      { (Some $2, Some $4) }
+  | COLONGREATER core_type                      { (None, Some $2) }
+  | COLON error                                 { syntax_error() }
+  | COLONGREATER error                          { syntax_error() }
+;
+
+/* Patterns */
+
+(* Whereas [pattern] is an arbitrary pattern, [pattern_no_exn] is a pattern
+   that does not begin with the [EXCEPTION] keyword. Thus, [pattern_no_exn]
+   is the intersection of the context-free language [pattern] with the
+   regular language [^EXCEPTION .*].
+
+   Ideally, we would like to use [pattern] everywhere and check in a later
+   phase that EXCEPTION patterns are used only where they are allowed (there
+   is code in typing/typecore.ml to this end). Unfortunately, in the
+   definition of [let_binding_body], we cannot allow [pattern]. That would
+   create a shift/reduce conflict: upon seeing LET EXCEPTION ..., the parser
+   wouldn't know whether this is the beginning of a LET EXCEPTION construct or
+   the beginning of a LET construct whose pattern happens to begin with
+   EXCEPTION. The conflict is avoided there by using [pattern_no_exn] in the
+   definition of [let_binding_body].
+
+   In order to avoid duplication between the definitions of [pattern] and
+   [pattern_no_exn], we create a parameterized definition [pattern_(self)]
+   and instantiate it twice. *)
+
+pattern:
+    pattern_(pattern)
+      { $1 }
+  | EXCEPTION ext_attributes pattern %prec prec_constr_appl
+      { mkpat_attrs ~loc:$sloc (Ppat_exception $3) $2}
+;
+
+pattern_no_exn:
+    pattern_(pattern_no_exn)
+      { $1 }
+;
+
+%inline pattern_(self):
+  | self COLONCOLON pattern
+      { mkpat_cons ~loc:$sloc $loc($2) (ghpat ~loc:$sloc (Ppat_tuple[$1;$3])) }
+  | self attribute
+      { Pat.attr $1 $2 }
+  | pattern_gen
+      { $1 }
+  | mkpat(
+      self AS mkrhs(val_ident)
+        { Ppat_alias($1, $3) }
+    | self AS error
+        { expecting $loc($3) "identifier" }
+    | pattern_comma_list(self) %prec below_COMMA
+        { Ppat_tuple(List.rev $1) }
+    | self COLONCOLON error
+        { expecting $loc($3) "pattern" }
+    | self BAR pattern
+        { Ppat_or($1, $3) }
+    | self BAR error
+        { expecting $loc($3) "pattern" }
+  ) { $1 }
+;
+
+pattern_gen:
+    simple_pattern
+      { $1 }
+  | mkpat(
+      mkrhs(constr_longident) pattern %prec prec_constr_appl
+        { Ppat_construct($1, Some $2) }
+    | name_tag pattern %prec prec_constr_appl
+        { Ppat_variant($1, Some $2) }
+    ) { $1 }
+  | LAZY ext_attributes simple_pattern
+      { mkpat_attrs ~loc:$sloc (Ppat_lazy $3) $2}
+;
+simple_pattern:
+    mkpat(mkrhs(val_ident) %prec below_EQUAL
+      { Ppat_var ($1) })
+      { $1 }
+  | simple_pattern_not_ident { $1 }
+;
+
+simple_pattern_not_ident:
+  | LPAREN pattern RPAREN
+      { reloc_pat ~loc:$sloc $2 }
+  | simple_delimited_pattern
+      { $1 }
+  | LPAREN MODULE ext_attributes mkrhs(module_name) RPAREN
+      { mkpat_attrs ~loc:$sloc (Ppat_unpack $4) $3 }
+  | LPAREN MODULE ext_attributes mkrhs(module_name) COLON package_type RPAREN
+      { mkpat_attrs ~loc:$sloc
+          (Ppat_constraint(mkpat ~loc:$sloc (Ppat_unpack $4), $6))
+          $3 }
+  | mkpat(simple_pattern_not_ident_)
+      { $1 }
+;
+%inline simple_pattern_not_ident_:
+  | UNDERSCORE
+      { Ppat_any }
+  | signed_constant
+      { Ppat_constant $1 }
+  | signed_constant DOTDOT signed_constant
+      { Ppat_interval ($1, $3) }
+  | mkrhs(constr_longident)
+      { Ppat_construct($1, None) }
+  | name_tag
+      { Ppat_variant($1, None) }
+  | HASH mkrhs(type_longident)
+      { Ppat_type ($2) }
+  | mkrhs(mod_longident) DOT simple_delimited_pattern
+      { Ppat_open($1, $3) }
+  | mkrhs(mod_longident) DOT mkrhs(LBRACKET RBRACKET {Lident "[]"})
+    { Ppat_open($1, mkpat ~loc:$sloc (Ppat_construct($3, None))) }
+  | mkrhs(mod_longident) DOT mkrhs(LPAREN RPAREN {Lident "()"})
+    { Ppat_open($1, mkpat ~loc:$sloc (Ppat_construct($3, None))) }
+  | mkrhs(mod_longident) DOT LPAREN pattern RPAREN
+      { Ppat_open ($1, $4) }
+  | mod_longident DOT LPAREN pattern error
+      { unclosed "(" $loc($3) ")" $loc($5)  }
+  | mod_longident DOT LPAREN error
+      { expecting $loc($4) "pattern" }
+  | LPAREN pattern error
+      { unclosed "(" $loc($1) ")" $loc($3) }
+  | LPAREN pattern COLON core_type RPAREN
+      { Ppat_constraint($2, $4) }
+  | LPAREN pattern COLON core_type error
+      { unclosed "(" $loc($1) ")" $loc($5) }
+  | LPAREN pattern COLON error
+      { expecting $loc($4) "type" }
+  | LPAREN MODULE ext_attributes module_name COLON package_type
+    error
+      { unclosed "(" $loc($1) ")" $loc($7) }
+  | extension
+      { Ppat_extension $1 }
+;
+
+simple_delimited_pattern:
+  mkpat(
+      LBRACE record_pat_content RBRACE
+      { let (fields, closed) = $2 in
+        Ppat_record(fields, closed) }
+    | LBRACE record_pat_content error
+      { unclosed "{" $loc($1) "}" $loc($3) }
+    | LBRACKET pattern_semi_list RBRACKET
+      { fst (mktailpat $loc($3) $2) }
+    | LBRACKET pattern_semi_list error
+      { unclosed "[" $loc($1) "]" $loc($3) }
+    | LBRACKETBAR pattern_semi_list BARRBRACKET
+      { Ppat_array $2 }
+    | LBRACKETBAR BARRBRACKET
+      { Ppat_array [] }
+    | LBRACKETBAR pattern_semi_list error
+      { unclosed "[|" $loc($1) "|]" $loc($3) }
+  ) { $1 }
+
+pattern_comma_list(self):
+    pattern_comma_list(self) COMMA pattern      { $3 :: $1 }
+  | self COMMA pattern                          { [$3; $1] }
+  | self COMMA error                            { expecting $loc($3) "pattern" }
+;
+%inline pattern_semi_list:
+  ps = separated_or_terminated_nonempty_list(SEMI, pattern)
+    { ps }
+;
+(* A label-pattern list is a nonempty list of label-pattern pairs, optionally
+   followed with an UNDERSCORE, separated-or-terminated with semicolons. *)
+%inline record_pat_content:
+  listx(SEMI, record_pat_field, UNDERSCORE)
+    { let fields, closed = $1 in
+      let closed = match closed with Some () -> Open | None -> Closed in
+      fields, closed }
+;
+%inline record_pat_field:
+  label = mkrhs(label_longident)
+  octy = preceded(COLON, core_type)?
+  opat = preceded(EQUAL, pattern)?
+    { let pat =
+        match opat with
+        | None ->
+            (* No pattern; this is a pun. Desugar it. *)
+            pat_of_label ~loc:$sloc label
+        | Some pat ->
+            pat
+      in
+      label, mkpat_opt_constraint ~loc:$sloc pat octy
+    }
+;
+
+/* Value descriptions */
+
+value_description:
+  VAL
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(val_ident)
+  COLON
+  ty = core_type
+  attrs2 = post_item_attributes
+    { let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let docs = symbol_docs $sloc in
+      Val.mk id ty ~attrs ~loc ~docs,
+      ext }
+;
+
+/* Primitive declarations */
+
+primitive_declaration:
+  EXTERNAL
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(val_ident)
+  COLON
+  ty = core_type
+  EQUAL
+  prim = raw_string+
+  attrs2 = post_item_attributes
+    { let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let docs = symbol_docs $sloc in
+      Val.mk id ty ~prim ~attrs ~loc ~docs,
+      ext }
+;
+
+(* Type declarations and type substitutions. *)
+
+(* Type declarations [type t = u] and type substitutions [type t := u] are very
+   similar, so we view them as instances of [generic_type_declarations]. In the
+   case of a type declaration, the use of [nonrec_flag] means that [NONREC] may
+   be absent or present, whereas in the case of a type substitution, the use of
+   [no_nonrec_flag] means that [NONREC] must be absent. The use of [type_kind]
+   versus [type_subst_kind] means that in the first case, we expect an [EQUAL]
+   sign, whereas in the second case, we expect [COLONEQUAL]. *)
+
+%inline type_declarations:
+  generic_type_declarations(nonrec_flag, type_kind)
+    { $1 }
+;
+
+%inline type_subst_declarations:
+  generic_type_declarations(no_nonrec_flag, type_subst_kind)
+    { $1 }
+;
+
+(* A set of type declarations or substitutions begins with a
+   [generic_type_declaration] and continues with a possibly empty list of
+   [generic_and_type_declaration]s. *)
+
+%inline generic_type_declarations(flag, kind):
+  xlist(
+    generic_type_declaration(flag, kind),
+    generic_and_type_declaration(kind)
+  )
+  { $1 }
+;
+
+(* [generic_type_declaration] and [generic_and_type_declaration] look similar,
+   but are in reality different enough that it is difficult to share anything
+   between them. *)
+
+generic_type_declaration(flag, kind):
+  TYPE
+  ext = ext
+  attrs1 = attributes
+  flag = flag
+  params = type_parameters
+  id = mkrhs(LIDENT)
+  kind_priv_manifest = kind
+  cstrs = constraints
+  attrs2 = post_item_attributes
+    {
+      let (kind, priv, manifest) = kind_priv_manifest in
+      let docs = symbol_docs $sloc in
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      (flag, ext),
+      Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs
+    }
+;
+%inline generic_and_type_declaration(kind):
+  AND
+  attrs1 = attributes
+  params = type_parameters
+  id = mkrhs(LIDENT)
+  kind_priv_manifest = kind
+  cstrs = constraints
+  attrs2 = post_item_attributes
+    {
+      let (kind, priv, manifest) = kind_priv_manifest in
+      let docs = symbol_docs $sloc in
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let text = symbol_text $symbolstartpos in
+      Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ~text
+    }
+;
+%inline constraints:
+  llist(preceded(CONSTRAINT, constrain))
+    { $1 }
+;
+(* Lots of %inline expansion are required for [nonempty_type_kind] to be
+   LR(1). At the cost of some manual expansion, it would be possible to give a
+   definition that leads to a smaller grammar (after expansion) and therefore
+   a smaller automaton. *)
+nonempty_type_kind:
+  | priv = inline_private_flag
+    ty = core_type
+      { (Ptype_abstract, priv, Some ty) }
+  | oty = type_synonym
+    priv = inline_private_flag
+    cs = constructor_declarations
+      { (Ptype_variant cs, priv, oty) }
+  | oty = type_synonym
+    priv = inline_private_flag
+    DOTDOT
+      { (Ptype_open, priv, oty) }
+  | oty = type_synonym
+    priv = inline_private_flag
+    LBRACE ls = label_declarations RBRACE
+      { (Ptype_record ls, priv, oty) }
+;
+%inline type_synonym:
+  ioption(terminated(core_type, EQUAL))
+    { $1 }
+;
+type_kind:
+    /*empty*/
+      { (Ptype_abstract, Public, None) }
+  | EQUAL nonempty_type_kind
+      { $2 }
+;
+%inline type_subst_kind:
+    COLONEQUAL nonempty_type_kind
+      { $2 }
+;
+type_parameters:
+    /* empty */
+      { [] }
+  | p = type_parameter
+      { [p] }
+  | LPAREN ps = separated_nonempty_llist(COMMA, type_parameter) RPAREN
+      { ps }
+;
+type_parameter:
+    type_variance type_variable        { $2, $1 }
+;
+type_variable:
+  mktyp(
+    QUOTE tyvar = ident
+      { Ptyp_var tyvar }
+  | UNDERSCORE
+      { Ptyp_any }
+  ) { $1 }
+;
+
+type_variance:
+    /* empty */                                 { Invariant }
+  | PLUS                                        { Covariant }
+  | MINUS                                       { Contravariant }
+;
+
+(* A sequence of constructor declarations is either a single BAR, which
+   means that the list is empty, or a nonempty BAR-separated list of
+   declarations, with an optional leading BAR. *)
+constructor_declarations:
+  | BAR
+      { [] }
+  | cs = bar_llist(constructor_declaration)
+      { cs }
+;
+(* A constructor declaration begins with an opening symbol, which can
+   be either epsilon or BAR. Note that this opening symbol is included
+   in the footprint $sloc. *)
+(* Because [constructor_declaration] and [extension_constructor_declaration]
+   are identical except for their semantic actions, we introduce the symbol
+   [generic_constructor_declaration], whose semantic action is neutral -- it
+   merely returns a tuple. *)
+generic_constructor_declaration(opening):
+  opening
+  cid = mkrhs(constr_ident)
+  args_res = generalized_constructor_arguments
+  attrs = attributes
+    {
+      let args, res = args_res in
+      let info = symbol_info $endpos in
+      let loc = make_loc $sloc in
+      cid, args, res, attrs, loc, info
+    }
+;
+%inline constructor_declaration(opening):
+  d = generic_constructor_declaration(opening)
+    {
+      let cid, args, res, attrs, loc, info = d in
+      Type.constructor cid ~args ?res ~attrs ~loc ~info
+    }
+;
+str_exception_declaration:
+  sig_exception_declaration
+    { $1 }
+| EXCEPTION
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(constr_ident)
+  EQUAL
+  lid = mkrhs(constr_longident)
+  attrs2 = attributes
+  attrs = post_item_attributes
+  { let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Te.mk_exception ~attrs
+      (Te.rebind id lid ~attrs:(attrs1 @ attrs2) ~loc ~docs)
+    , ext }
+;
+sig_exception_declaration:
+  EXCEPTION
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(constr_ident)
+  args_res = generalized_constructor_arguments
+  attrs2 = attributes
+  attrs = post_item_attributes
+    { let args, res = args_res in
+      let loc = make_loc $sloc in
+      let docs = symbol_docs $sloc in
+      Te.mk_exception ~attrs
+        (Te.decl id ~args ?res ~attrs:(attrs1 @ attrs2) ~loc ~docs)
+      , ext }
+;
+%inline let_exception_declaration:
+    mkrhs(constr_ident) generalized_constructor_arguments attributes
+      { let args, res = $2 in
+        Te.decl $1 ~args ?res ~attrs:$3 ~loc:(make_loc $sloc) }
+;
+generalized_constructor_arguments:
+    /*empty*/                     { (Pcstr_tuple [],None) }
+  | OF constructor_arguments      { ($2,None) }
+  | COLON constructor_arguments MINUSGREATER atomic_type %prec below_HASH
+                                  { ($2,Some $4) }
+  | COLON atomic_type %prec below_HASH
+                                  { (Pcstr_tuple [],Some $2) }
+;
+
+constructor_arguments:
+  | tys = inline_separated_nonempty_llist(STAR, atomic_type)
+    %prec below_HASH
+      { Pcstr_tuple tys }
+  | LBRACE label_declarations RBRACE
+      { Pcstr_record $2 }
+;
+label_declarations:
+    label_declaration                           { [$1] }
+  | label_declaration_semi                      { [$1] }
+  | label_declaration_semi label_declarations   { $1 :: $2 }
+;
+label_declaration:
+    mutable_flag mkrhs(label) COLON poly_type_no_attr attributes
+      { let info = symbol_info $endpos in
+        Type.field $2 $4 ~mut:$1 ~attrs:$5 ~loc:(make_loc $sloc) ~info }
+;
+label_declaration_semi:
+    mutable_flag mkrhs(label) COLON poly_type_no_attr attributes SEMI attributes
+      { let info =
+          match rhs_info $endpos($5) with
+          | Some _ as info_before_semi -> info_before_semi
+          | None -> symbol_info $endpos
+       in
+       Type.field $2 $4 ~mut:$1 ~attrs:($5 @ $7) ~loc:(make_loc $sloc) ~info }
+;
+
+/* Type Extensions */
+
+%inline str_type_extension:
+  type_extension(extension_constructor)
+    { $1 }
+;
+%inline sig_type_extension:
+  type_extension(extension_constructor_declaration)
+    { $1 }
+;
+%inline type_extension(declaration):
+  TYPE
+  ext = ext
+  attrs1 = attributes
+  no_nonrec_flag
+  params = type_parameters
+  tid = mkrhs(type_longident)
+  PLUSEQ
+  priv = private_flag
+  cs = bar_llist(declaration)
+  attrs2 = post_item_attributes
+    { let docs = symbol_docs $sloc in
+      let attrs = attrs1 @ attrs2 in
+      Te.mk tid cs ~params ~priv ~attrs ~docs,
+      ext }
+;
+%inline extension_constructor(opening):
+    extension_constructor_declaration(opening)
+      { $1 }
+  | extension_constructor_rebind(opening)
+      { $1 }
+;
+%inline extension_constructor_declaration(opening):
+  d = generic_constructor_declaration(opening)
+    {
+      let cid, args, res, attrs, loc, info = d in
+      Te.decl cid ~args ?res ~attrs ~loc ~info
+    }
+;
+extension_constructor_rebind(opening):
+  opening
+  cid = mkrhs(constr_ident)
+  EQUAL
+  lid = mkrhs(constr_longident)
+  attrs = attributes
+      { let info = symbol_info $endpos in
+        Te.rebind cid lid ~attrs ~loc:(make_loc $sloc) ~info }
+;
+
+/* "with" constraints (additional type equations over signature components) */
+
+with_constraint:
+    TYPE type_parameters mkrhs(label_longident) with_type_binder
+    core_type_no_attr constraints
+      { let lident = loc_last $3 in
+        Pwith_type
+          ($3,
+           (Type.mk lident
+              ~params:$2
+              ~cstrs:$6
+              ~manifest:$5
+              ~priv:$4
+              ~loc:(make_loc $sloc))) }
+    /* used label_longident instead of type_longident to disallow
+       functor applications in type path */
+  | TYPE type_parameters mkrhs(label_longident)
+    COLONEQUAL core_type_no_attr
+      { let lident = loc_last $3 in
+        Pwith_typesubst
+         ($3,
+           (Type.mk lident
+              ~params:$2
+              ~manifest:$5
+              ~loc:(make_loc $sloc))) }
+  | MODULE mkrhs(mod_longident) EQUAL mkrhs(mod_ext_longident)
+      { Pwith_module ($2, $4) }
+  | MODULE mkrhs(mod_longident) COLONEQUAL mkrhs(mod_ext_longident)
+      { Pwith_modsubst ($2, $4) }
+;
+with_type_binder:
+    EQUAL          { Public }
+  | EQUAL PRIVATE  { Private }
+;
+
+/* Polymorphic types */
+
+%inline typevar:
+  QUOTE mkrhs(ident)
+    { $2 }
+;
+%inline typevar_list:
+  nonempty_llist(typevar)
+    { $1 }
+;
+%inline poly(X):
+  typevar_list DOT X
+    { Ptyp_poly($1, $3) }
+;
+possibly_poly(X):
+  X
+    { $1 }
+| mktyp(poly(X))
+    { $1 }
+;
+%inline poly_type:
+  possibly_poly(core_type)
+    { $1 }
+;
+%inline poly_type_no_attr:
+  possibly_poly(core_type_no_attr)
+    { $1 }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+(* Core language types. *)
+
+(* A core type (core_type) is a core type without attributes (core_type_no_attr)
+   followed with a list of attributes. *)
+core_type:
+    core_type_no_attr
+      { $1 }
+  | core_type attribute
+      { Typ.attr $1 $2 }
+;
+
+(* A core type without attributes is currently defined as an alias type, but
+   this could change in the future if new forms of types are introduced. From
+   the outside, one should use core_type_no_attr. *)
+%inline core_type_no_attr:
+  alias_type
+    { $1 }
+;
+
+(* Alias types include:
+   - function types (see below);
+   - proper alias types:                  'a -> int as 'a
+ *)
+alias_type:
+    function_type
+      { $1 }
+  | mktyp(
+      ty = alias_type AS QUOTE tyvar = ident
+        { Ptyp_alias(ty, tyvar) }
+    )
+    { $1 }
+;
+
+(* Function types include:
+   - tuple types (see below);
+   - proper function types:               int -> int
+                                          foo: int -> int
+                                          ?foo: int -> int
+ *)
+function_type:
+  | ty = tuple_type
+    %prec MINUSGREATER
+      { ty }
+  | mktyp(
+      label = arg_label
+      domain = extra_rhs(tuple_type)
+      MINUSGREATER
+      codomain = function_type
+        { Ptyp_arrow(label, domain, codomain) }
+    )
+    { $1 }
+;
+%inline arg_label:
+  | label = optlabel
+      { Optional label }
+  | label = LIDENT COLON
+      { Labelled label }
+  | /* empty */
+      { Nolabel }
+;
+(* Tuple types include:
+   - atomic types (see below);
+   - proper tuple types:                  int * int * int list
+   A proper tuple type is a star-separated list of at least two atomic types.
+ *)
+tuple_type:
+  | ty = atomic_type
+    %prec below_HASH
+      { ty }
+  | mktyp(
+      tys = separated_nontrivial_llist(STAR, atomic_type)
+        { Ptyp_tuple tys }
+    )
+    { $1 }
+;
+
+(* Atomic types are the most basic level in the syntax of types.
+   Atomic types include:
+   - types between parentheses:           (int -> int)
+   - first-class module types:            (module S)
+   - type variables:                      'a
+   - applications of type constructors:   int, int list, int option list
+   - variant types:                       [`A]
+ *)
+atomic_type:
+  | LPAREN core_type RPAREN
+      { $2 }
+  | LPAREN MODULE ext_attributes package_type RPAREN
+      { wrap_typ_attrs ~loc:$sloc (reloc_typ ~loc:$sloc $4) $3 }
+  | mktyp( /* begin mktyp group */
+      QUOTE ident
+        { Ptyp_var $2 }
+    | UNDERSCORE
+        { Ptyp_any }
+    | tys = actual_type_parameters
+      tid = mkrhs(type_longident)
+        { Ptyp_constr(tid, tys) }
+    | LESS meth_list GREATER
+        { let (f, c) = $2 in Ptyp_object (f, c) }
+    | LESS GREATER
+        { Ptyp_object ([], Closed) }
+    | tys = actual_type_parameters
+      HASH
+      cid = mkrhs(clty_longident)
+        { Ptyp_class(cid, tys) }
+    | LBRACKET tag_field RBRACKET
+        (* not row_field; see CONFLICTS *)
+        { Ptyp_variant([$2], Closed, None) }
+    | LBRACKET BAR row_field_list RBRACKET
+        { Ptyp_variant($3, Closed, None) }
+    | LBRACKET row_field BAR row_field_list RBRACKET
+        { Ptyp_variant($2 :: $4, Closed, None) }
+    | LBRACKETGREATER BAR? row_field_list RBRACKET
+        { Ptyp_variant($3, Open, None) }
+    | LBRACKETGREATER RBRACKET
+        { Ptyp_variant([], Open, None) }
+    | LBRACKETLESS BAR? row_field_list RBRACKET
+        { Ptyp_variant($3, Closed, Some []) }
+    | LBRACKETLESS BAR? row_field_list GREATER name_tag_list RBRACKET
+        { Ptyp_variant($3, Closed, Some $5) }
+    | extension
+        { Ptyp_extension $1 }
+  )
+  { $1 } /* end mktyp group */
+;
+
+(* This is the syntax of the actual type parameters in an application of
+   a type constructor, such as int, int list, or (int, bool) Hashtbl.t.
+   We allow one of the following:
+   - zero parameters;
+   - one parameter:
+     an atomic type;
+     among other things, this can be an arbitrary type between parentheses;
+   - two or more parameters:
+     arbitrary types, between parentheses, separated with commas.
+ *)
+%inline actual_type_parameters:
+  | /* empty */
+      { [] }
+  | ty = atomic_type
+      { [ty] }
+  | LPAREN tys = separated_nontrivial_llist(COMMA, core_type) RPAREN
+      { tys }
+;
+
+%inline package_type:
+    mktyp(module_type
+      { Ptyp_package (package_type_of_module_type $1) })
+      { $1 }
+;
+%inline row_field_list:
+  separated_nonempty_llist(BAR, row_field)
+    { $1 }
+;
+row_field:
+    tag_field
+      { $1 }
+  | core_type
+      { Rf.inherit_ ~loc:(make_loc $sloc) $1 }
+;
+tag_field:
+    mkrhs(name_tag) OF opt_ampersand amper_type_list attributes
+      { let info = symbol_info $endpos in
+        let attrs = add_info_attrs info $5 in
+        Rf.tag ~loc:(make_loc $sloc) ~attrs $1 $3 $4 }
+  | mkrhs(name_tag) attributes
+      { let info = symbol_info $endpos in
+        let attrs = add_info_attrs info $2 in
+        Rf.tag ~loc:(make_loc $sloc) ~attrs $1 true [] }
+;
+opt_ampersand:
+    AMPERSAND                                   { true }
+  | /* empty */                                 { false }
+;
+%inline amper_type_list:
+  separated_nonempty_llist(AMPERSAND, core_type_no_attr)
+    { $1 }
+;
+%inline name_tag_list:
+  nonempty_llist(name_tag)
+    { $1 }
+;
+(* A method list (in an object type). *)
+meth_list:
+    head = field_semi         tail = meth_list
+  | head = inherit_field SEMI tail = meth_list
+      { let (f, c) = tail in (head :: f, c) }
+  | head = field_semi
+  | head = inherit_field SEMI
+      { [head], Closed }
+  | head = field
+  | head = inherit_field
+      { [head], Closed }
+  | DOTDOT
+      { [], Open }
+;
+%inline field:
+  mkrhs(label) COLON poly_type_no_attr attributes
+    { let info = symbol_info $endpos in
+      let attrs = add_info_attrs info $4 in
+      Of.tag ~loc:(make_loc $sloc) ~attrs $1 $3 }
+;
+
+%inline field_semi:
+  mkrhs(label) COLON poly_type_no_attr attributes SEMI attributes
+    { let info =
+        match rhs_info $endpos($4) with
+        | Some _ as info_before_semi -> info_before_semi
+        | None -> symbol_info $endpos
+      in
+      let attrs = add_info_attrs info ($4 @ $6) in
+      Of.tag ~loc:(make_loc $sloc) ~attrs $1 $3 }
+;
+
+%inline inherit_field:
+  ty = atomic_type
+    { Of.inherit_ ~loc:(make_loc $sloc) ty }
+;
+
+%inline label:
+    LIDENT                                      { $1 }
+;
+
+/* Constants */
+
+constant:
+  | INT          { let (n, m) = $1 in Pconst_integer (n, m) }
+  | CHAR         { Pconst_char $1 }
+  | STRING       { let (s, strloc, d) = $1 in Pconst_string (s, strloc, d) }
+  | FLOAT        { let (f, m) = $1 in Pconst_float (f, m) }
+;
+signed_constant:
+    constant     { $1 }
+  | MINUS INT    { let (n, m) = $2 in Pconst_integer("-" ^ n, m) }
+  | MINUS FLOAT  { let (f, m) = $2 in Pconst_float("-" ^ f, m) }
+  | PLUS INT     { let (n, m) = $2 in Pconst_integer (n, m) }
+  | PLUS FLOAT   { let (f, m) = $2 in Pconst_float(f, m) }
+;
+
+/* Identifiers and long identifiers */
+
+ident:
+    UIDENT                    { $1 }
+  | LIDENT                    { $1 }
+;
+val_extra_ident:
+  | LPAREN operator RPAREN    { $2 }
+  | LPAREN operator error     { unclosed "(" $loc($1) ")" $loc($3) }
+  | LPAREN error              { expecting $loc($2) "operator" }
+  | LPAREN MODULE error       { expecting $loc($3) "module-expr" }
+;
+val_ident:
+    LIDENT                    { $1 }
+  | val_extra_ident           { $1 }
+;
+operator:
+    PREFIXOP                                    { $1 }
+  | LETOP                                       { $1 }
+  | ANDOP                                       { $1 }
+  | DOTOP LPAREN index_mod RPAREN               { "."^ $1 ^"(" ^ $3 ^ ")" }
+  | DOTOP LPAREN index_mod RPAREN LESSMINUS     { "."^ $1 ^ "(" ^ $3 ^ ")<-" }
+  | DOTOP LBRACKET index_mod RBRACKET           { "."^ $1 ^"[" ^ $3 ^ "]" }
+  | DOTOP LBRACKET index_mod RBRACKET LESSMINUS { "."^ $1 ^ "[" ^ $3 ^ "]<-" }
+  | DOTOP LBRACE index_mod RBRACE               { "."^ $1 ^"{" ^ $3 ^ "}" }
+  | DOTOP LBRACE index_mod RBRACE LESSMINUS     { "."^ $1 ^ "{" ^ $3 ^ "}<-" }
+  | HASHOP                                      { $1 }
+  | BANG                                        { "!" }
+  | infix_operator                              { $1 }
+;
+%inline infix_operator:
+  | op = INFIXOP0 { op }
+  | op = INFIXOP1 { op }
+  | op = INFIXOP2 { op }
+  | op = INFIXOP3 { op }
+  | op = INFIXOP4 { op }
+  | PLUS           {"+"}
+  | PLUSDOT       {"+."}
+  | PLUSEQ        {"+="}
+  | MINUS          {"-"}
+  | MINUSDOT      {"-."}
+  | STAR           {"*"}
+  | PERCENT        {"%"}
+  | EQUAL          {"="}
+  | LESS           {"<"}
+  | GREATER        {">"}
+  | OR            {"or"}
+  | BARBAR        {"||"}
+  | AMPERSAND      {"&"}
+  | AMPERAMPER    {"&&"}
+  | COLONEQUAL    {":="}
+;
+index_mod:
+| { "" }
+| SEMI DOTDOT { ";.." }
+;
+
+%inline constr_extra_ident:
+  | LPAREN COLONCOLON RPAREN                    { "::" }
+;
+constr_extra_nonprefix_ident:
+  | LBRACKET RBRACKET                           { "[]" }
+  | LPAREN RPAREN                               { "()" }
+  | FALSE                                       { "false" }
+  | TRUE                                        { "true" }
+;
+constr_ident:
+    UIDENT                                      { $1 }
+  | constr_extra_ident                          { $1 }
+  | constr_extra_nonprefix_ident                { $1 }
+;
+constr_longident:
+    mod_longident       %prec below_DOT  { $1 } /* A.B.x vs (A).B.x */
+  | mod_longident DOT constr_extra_ident { Ldot($1,$3) }
+  | constr_extra_ident                   { Lident $1 }
+  | constr_extra_nonprefix_ident         { Lident $1 }
+;
+mk_longident(prefix,final):
+   | final            { Lident $1 }
+   | prefix DOT final { Ldot($1,$3) }
+;
+val_longident:
+    mk_longident(mod_longident, val_ident) { $1 }
+;
+label_longident:
+    mk_longident(mod_longident, LIDENT) { $1 }
+;
+type_longident:
+    mk_longident(mod_ext_longident, LIDENT)  { $1 }
+;
+mod_longident:
+    mk_longident(mod_longident, UIDENT)  { $1 }
+;
+mod_ext_longident:
+    mk_longident(mod_ext_longident, UIDENT) { $1 }
+  | mod_ext_longident LPAREN mod_ext_longident RPAREN
+      { lapply ~loc:$sloc $1 $3 }
+  | mod_ext_longident LPAREN error
+      { expecting $loc($3) "module path" }
+;
+mty_longident:
+    mk_longident(mod_ext_longident,ident) { $1 }
+;
+clty_longident:
+    mk_longident(mod_ext_longident,LIDENT) { $1 }
+;
+class_longident:
+   mk_longident(mod_longident,LIDENT) { $1 }
+;
+
+/* For compiler-libs: parse all valid longidents and a little more:
+   final identifiers which are value specific are accepted even when
+   the path prefix is only valid for types: (e.g. F(X).(::)) */
+any_longident:
+  | mk_longident (mod_ext_longident,
+     ident | constr_extra_ident | val_extra_ident { $1 }
+    ) { $1 }
+  | constr_extra_nonprefix_ident { Lident $1 }
+;
+
+/* Toplevel directives */
+
+toplevel_directive:
+  HASH dir = mkrhs(ident)
+  arg = ioption(mk_directive_arg(toplevel_directive_argument))
+    { mk_directive ~loc:$sloc dir arg }
+;
+
+%inline toplevel_directive_argument:
+  | STRING        { let (s, _, _) = $1 in Pdir_string s }
+  | INT           { let (n, m) = $1 in Pdir_int (n ,m) }
+  | val_longident { Pdir_ident $1 }
+  | mod_longident { Pdir_ident $1 }
+  | FALSE         { Pdir_bool false }
+  | TRUE          { Pdir_bool true }
+;
+
+/* Miscellaneous */
+
+(* The symbol epsilon can be used instead of an /* empty */ comment. *)
+%inline epsilon:
+  /* empty */
+    { () }
+;
+
+%inline raw_string:
+  s = STRING
+    { let body, _, _ = s in body }
+;
+
+name_tag:
+    BACKQUOTE ident                             { $2 }
+;
+rec_flag:
+    /* empty */                                 { Nonrecursive }
+  | REC                                         { Recursive }
+;
+%inline nonrec_flag:
+    /* empty */                                 { Recursive }
+  | NONREC                                      { Nonrecursive }
+;
+%inline no_nonrec_flag:
+    /* empty */ { Recursive }
+  | NONREC      { not_expecting $loc "nonrec flag" }
+;
+direction_flag:
+    TO                                          { Upto }
+  | DOWNTO                                      { Downto }
+;
+private_flag:
+  inline_private_flag
+    { $1 }
+;
+%inline inline_private_flag:
+    /* empty */                                 { Public }
+  | PRIVATE                                     { Private }
+;
+mutable_flag:
+    /* empty */                                 { Immutable }
+  | MUTABLE                                     { Mutable }
+;
+virtual_flag:
+    /* empty */                                 { Concrete }
+  | VIRTUAL                                     { Virtual }
+;
+mutable_virtual_flags:
+    /* empty */
+      { Immutable, Concrete }
+  | MUTABLE
+      { Mutable, Concrete }
+  | VIRTUAL
+      { Immutable, Virtual }
+  | MUTABLE VIRTUAL
+  | VIRTUAL MUTABLE
+      { Mutable, Virtual }
+;
+private_virtual_flags:
+    /* empty */  { Public, Concrete }
+  | PRIVATE { Private, Concrete }
+  | VIRTUAL { Public, Virtual }
+  | PRIVATE VIRTUAL { Private, Virtual }
+  | VIRTUAL PRIVATE { Private, Virtual }
+;
+(* This nonterminal symbol indicates the definite presence of a VIRTUAL
+   keyword and the possible presence of a MUTABLE keyword. *)
+virtual_with_mutable_flag:
+  | VIRTUAL { Immutable }
+  | MUTABLE VIRTUAL { Mutable }
+  | VIRTUAL MUTABLE { Mutable }
+;
+(* This nonterminal symbol indicates the definite presence of a VIRTUAL
+   keyword and the possible presence of a PRIVATE keyword. *)
+virtual_with_private_flag:
+  | VIRTUAL { Public }
+  | PRIVATE VIRTUAL { Private }
+  | VIRTUAL PRIVATE { Private }
+;
+%inline no_override_flag:
+    /* empty */                                 { Fresh }
+;
+%inline override_flag:
+    /* empty */                                 { Fresh }
+  | BANG                                        { Override }
+;
+subtractive:
+  | MINUS                                       { "-" }
+  | MINUSDOT                                    { "-." }
+;
+additive:
+  | PLUS                                        { "+" }
+  | PLUSDOT                                     { "+." }
+;
+optlabel:
+   | OPTLABEL                                   { $1 }
+   | QUESTION LIDENT COLON                      { $2 }
+;
+
+/* Attributes and extensions */
+
+single_attr_id:
+    LIDENT { $1 }
+  | UIDENT { $1 }
+  | AND { "and" }
+  | AS { "as" }
+  | ASSERT { "assert" }
+  | BEGIN { "begin" }
+  | CLASS { "class" }
+  | CONSTRAINT { "constraint" }
+  | DO { "do" }
+  | DONE { "done" }
+  | DOWNTO { "downto" }
+  | ELSE { "else" }
+  | END { "end" }
+  | EXCEPTION { "exception" }
+  | EXTERNAL { "external" }
+  | FALSE { "false" }
+  | FOR { "for" }
+  | FUN { "fun" }
+  | FUNCTION { "function" }
+  | FUNCTOR { "functor" }
+  | IF { "if" }
+  | IN { "in" }
+  | INCLUDE { "include" }
+  | INHERIT { "inherit" }
+  | INITIALIZER { "initializer" }
+  | LAZY { "lazy" }
+  | LET { "let" }
+  | MATCH { "match" }
+  | METHOD { "method" }
+  | MODULE { "module" }
+  | MUTABLE { "mutable" }
+  | NEW { "new" }
+  | NONREC { "nonrec" }
+  | OBJECT { "object" }
+  | OF { "of" }
+  | OPEN { "open" }
+  | OR { "or" }
+  | PRIVATE { "private" }
+  | REC { "rec" }
+  | SIG { "sig" }
+  | STRUCT { "struct" }
+  | THEN { "then" }
+  | TO { "to" }
+  | TRUE { "true" }
+  | TRY { "try" }
+  | TYPE { "type" }
+  | VAL { "val" }
+  | VIRTUAL { "virtual" }
+  | WHEN { "when" }
+  | WHILE { "while" }
+  | WITH { "with" }
+/* mod/land/lor/lxor/lsl/lsr/asr are not supported for now */
+;
+
+attr_id:
+  mkloc(
+      single_attr_id { $1 }
+    | single_attr_id DOT attr_id { $1 ^ "." ^ $3.txt }
+  ) { $1 }
+;
+attribute:
+  LBRACKETAT attr_id payload RBRACKET
+    { Attr.mk ~loc:(make_loc $sloc) $2 $3 }
+;
+post_item_attribute:
+  LBRACKETATAT attr_id payload RBRACKET
+    { Attr.mk ~loc:(make_loc $sloc) $2 $3 }
+;
+floating_attribute:
+  LBRACKETATATAT attr_id payload RBRACKET
+    { mark_symbol_docs $sloc;
+      Attr.mk ~loc:(make_loc $sloc) $2 $3 }
+;
+%inline post_item_attributes:
+  post_item_attribute*
+    { $1 }
+;
+%inline attributes:
+  attribute*
+    { $1 }
+;
+ext:
+  | /* empty */     { None }
+  | PERCENT attr_id { Some $2 }
+;
+%inline no_ext:
+  | /* empty */     { None }
+  | PERCENT attr_id { not_expecting $loc "extension" }
+;
+%inline ext_attributes:
+  ext attributes    { $1, $2 }
+;
+extension:
+  | LBRACKETPERCENT attr_id payload RBRACKET { ($2, $3) }
+  | QUOTED_STRING_EXPR
+    { mk_quotedext ~loc:$sloc $1 }
+;
+item_extension:
+  | LBRACKETPERCENTPERCENT attr_id payload RBRACKET { ($2, $3) }
+  | QUOTED_STRING_ITEM
+    { mk_quotedext ~loc:$sloc $1 }
+;
+payload:
+    structure { PStr $1 }
+  | COLON signature { PSig $2 }
+  | COLON core_type { PTyp $2 }
+  | QUESTION pattern { PPat ($2, None) }
+  | QUESTION pattern WHEN seq_expr { PPat ($2, Some $4) }
+;
+%%
diff --git a/upstream/ocaml_411/parsing/parsetree.mli b/upstream/ocaml_411/parsing/parsetree.mli
new file mode 100644
index 0000000..0712f87
--- /dev/null
+++ b/upstream/ocaml_411/parsing/parsetree.mli
@@ -0,0 +1,970 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Abstract syntax tree produced by parsing
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Asttypes
+
+type constant =
+    Pconst_integer of string * char option
+  (* 3 3l 3L 3n
+
+     Suffixes [g-z][G-Z] are accepted by the parser.
+     Suffixes except 'l', 'L' and 'n' are rejected by the typechecker
+  *)
+  | Pconst_char of char
+  (* 'c' *)
+  | Pconst_string of string * Location.t * string option
+  (* "constant"
+     {delim|other constant|delim}
+
+     The location span the content of the string, without the delimiters.
+  *)
+  | Pconst_float of string * char option
+  (* 3.4 2e5 1.4e-4
+
+     Suffixes [g-z][G-Z] are accepted by the parser.
+     Suffixes are rejected by the typechecker.
+  *)
+
+type location_stack = Location.t list
+
+(** {1 Extension points} *)
+
+type attribute = {
+    attr_name : string loc;
+    attr_payload : payload;
+    attr_loc : Location.t;
+  }
+       (* [@id ARG]
+          [@@id ARG]
+
+          Metadata containers passed around within the AST.
+          The compiler ignores unknown attributes.
+       *)
+
+and extension = string loc * payload
+      (* [%id ARG]
+         [%%id ARG]
+
+         Sub-language placeholder -- rejected by the typechecker.
+      *)
+
+and attributes = attribute list
+
+and payload =
+  | PStr of structure
+  | PSig of signature (* : SIG *)
+  | PTyp of core_type  (* : T *)
+  | PPat of pattern * expression option  (* ? P  or  ? P when E *)
+
+(** {1 Core language} *)
+
+(* Type expressions *)
+
+and core_type =
+    {
+     ptyp_desc: core_type_desc;
+     ptyp_loc: Location.t;
+     ptyp_loc_stack: location_stack;
+     ptyp_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and core_type_desc =
+  | Ptyp_any
+        (*  _ *)
+  | Ptyp_var of string
+        (* 'a *)
+  | Ptyp_arrow of arg_label * core_type * core_type
+        (* T1 -> T2       Simple
+           ~l:T1 -> T2    Labelled
+           ?l:T1 -> T2    Optional
+         *)
+  | Ptyp_tuple of core_type list
+        (* T1 * ... * Tn
+
+           Invariant: n >= 2
+        *)
+  | Ptyp_constr of Longident.t loc * core_type list
+        (* tconstr
+           T tconstr
+           (T1, ..., Tn) tconstr
+         *)
+  | Ptyp_object of object_field list * closed_flag
+        (* < l1:T1; ...; ln:Tn >     (flag = Closed)
+           < l1:T1; ...; ln:Tn; .. > (flag = Open)
+         *)
+  | Ptyp_class of Longident.t loc * core_type list
+        (* #tconstr
+           T #tconstr
+           (T1, ..., Tn) #tconstr
+         *)
+  | Ptyp_alias of core_type * string
+        (* T as 'a *)
+  | Ptyp_variant of row_field list * closed_flag * label list option
+        (* [ `A|`B ]         (flag = Closed; labels = None)
+           [> `A|`B ]        (flag = Open;   labels = None)
+           [< `A|`B ]        (flag = Closed; labels = Some [])
+           [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"])
+         *)
+  | Ptyp_poly of string loc list * core_type
+        (* 'a1 ... 'an. T
+
+           Can only appear in the following context:
+
+           - As the core_type of a Ppat_constraint node corresponding
+             to a constraint on a let-binding: let x : 'a1 ... 'an. T
+             = e ...
+
+           - Under Cfk_virtual for methods (not values).
+
+           - As the core_type of a Pctf_method node.
+
+           - As the core_type of a Pexp_poly node.
+
+           - As the pld_type field of a label_declaration.
+
+           - As a core_type of a Ptyp_object node.
+         *)
+
+  | Ptyp_package of package_type
+        (* (module S) *)
+  | Ptyp_extension of extension
+        (* [%id] *)
+
+and package_type = Longident.t loc * (Longident.t loc * core_type) list
+      (*
+        (module S)
+        (module S with type t1 = T1 and ... and tn = Tn)
+       *)
+
+and row_field = {
+  prf_desc : row_field_desc;
+  prf_loc : Location.t;
+  prf_attributes : attributes;
+}
+
+and row_field_desc =
+  | Rtag of label loc * bool * core_type list
+        (* [`A]                   ( true,  [] )
+           [`A of T]              ( false, [T] )
+           [`A of T1 & .. & Tn]   ( false, [T1;...Tn] )
+           [`A of & T1 & .. & Tn] ( true,  [T1;...Tn] )
+
+          - The 'bool' field is true if the tag contains a
+            constant (empty) constructor.
+          - '&' occurs when several types are used for the same constructor
+            (see 4.2 in the manual)
+        *)
+  | Rinherit of core_type
+        (* [ T ] *)
+
+and object_field = {
+  pof_desc : object_field_desc;
+  pof_loc : Location.t;
+  pof_attributes : attributes;
+}
+
+and object_field_desc =
+  | Otag of label loc * core_type
+  | Oinherit of core_type
+
+(* Patterns *)
+
+and pattern =
+    {
+     ppat_desc: pattern_desc;
+     ppat_loc: Location.t;
+     ppat_loc_stack: location_stack;
+     ppat_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and pattern_desc =
+  | Ppat_any
+        (* _ *)
+  | Ppat_var of string loc
+        (* x *)
+  | Ppat_alias of pattern * string loc
+        (* P as 'a *)
+  | Ppat_constant of constant
+        (* 1, 'a', "true", 1.0, 1l, 1L, 1n *)
+  | Ppat_interval of constant * constant
+        (* 'a'..'z'
+
+           Other forms of interval are recognized by the parser
+           but rejected by the type-checker. *)
+  | Ppat_tuple of pattern list
+        (* (P1, ..., Pn)
+
+           Invariant: n >= 2
+        *)
+  | Ppat_construct of Longident.t loc * pattern option
+        (* C                None
+           C P              Some P
+           C (P1, ..., Pn)  Some (Ppat_tuple [P1; ...; Pn])
+         *)
+  | Ppat_variant of label * pattern option
+        (* `A             (None)
+           `A P           (Some P)
+         *)
+  | Ppat_record of (Longident.t loc * pattern) list * closed_flag
+        (* { l1=P1; ...; ln=Pn }     (flag = Closed)
+           { l1=P1; ...; ln=Pn; _}   (flag = Open)
+
+           Invariant: n > 0
+         *)
+  | Ppat_array of pattern list
+        (* [| P1; ...; Pn |] *)
+  | Ppat_or of pattern * pattern
+        (* P1 | P2 *)
+  | Ppat_constraint of pattern * core_type
+        (* (P : T) *)
+  | Ppat_type of Longident.t loc
+        (* #tconst *)
+  | Ppat_lazy of pattern
+        (* lazy P *)
+  | Ppat_unpack of string option loc
+        (* (module P)        Some "P"
+           (module _)        None
+
+           Note: (module P : S) is represented as
+           Ppat_constraint(Ppat_unpack, Ptyp_package)
+         *)
+  | Ppat_exception of pattern
+        (* exception P *)
+  | Ppat_extension of extension
+        (* [%id] *)
+  | Ppat_open of Longident.t loc * pattern
+        (* M.(P) *)
+
+(* Value expressions *)
+
+and expression =
+    {
+     pexp_desc: expression_desc;
+     pexp_loc: Location.t;
+     pexp_loc_stack: location_stack;
+     pexp_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and expression_desc =
+  | Pexp_ident of Longident.t loc
+        (* x
+           M.x
+         *)
+  | Pexp_constant of constant
+        (* 1, 'a', "true", 1.0, 1l, 1L, 1n *)
+  | Pexp_let of rec_flag * value_binding list * expression
+        (* let P1 = E1 and ... and Pn = EN in E       (flag = Nonrecursive)
+           let rec P1 = E1 and ... and Pn = EN in E   (flag = Recursive)
+         *)
+  | Pexp_function of case list
+        (* function P1 -> E1 | ... | Pn -> En *)
+  | Pexp_fun of arg_label * expression option * pattern * expression
+        (* fun P -> E1                          (Simple, None)
+           fun ~l:P -> E1                       (Labelled l, None)
+           fun ?l:P -> E1                       (Optional l, None)
+           fun ?l:(P = E0) -> E1                (Optional l, Some E0)
+
+           Notes:
+           - If E0 is provided, only Optional is allowed.
+           - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun.
+           - "let f P = E" is represented using Pexp_fun.
+         *)
+  | Pexp_apply of expression * (arg_label * expression) list
+        (* E0 ~l1:E1 ... ~ln:En
+           li can be empty (non labeled argument) or start with '?'
+           (optional argument).
+
+           Invariant: n > 0
+         *)
+  | Pexp_match of expression * case list
+        (* match E0 with P1 -> E1 | ... | Pn -> En *)
+  | Pexp_try of expression * case list
+        (* try E0 with P1 -> E1 | ... | Pn -> En *)
+  | Pexp_tuple of expression list
+        (* (E1, ..., En)
+
+           Invariant: n >= 2
+        *)
+  | Pexp_construct of Longident.t loc * expression option
+        (* C                None
+           C E              Some E
+           C (E1, ..., En)  Some (Pexp_tuple[E1;...;En])
+        *)
+  | Pexp_variant of label * expression option
+        (* `A             (None)
+           `A E           (Some E)
+         *)
+  | Pexp_record of (Longident.t loc * expression) list * expression option
+        (* { l1=P1; ...; ln=Pn }     (None)
+           { E0 with l1=P1; ...; ln=Pn }   (Some E0)
+
+           Invariant: n > 0
+         *)
+  | Pexp_field of expression * Longident.t loc
+        (* E.l *)
+  | Pexp_setfield of expression * Longident.t loc * expression
+        (* E1.l <- E2 *)
+  | Pexp_array of expression list
+        (* [| E1; ...; En |] *)
+  | Pexp_ifthenelse of expression * expression * expression option
+        (* if E1 then E2 else E3 *)
+  | Pexp_sequence of expression * expression
+        (* E1; E2 *)
+  | Pexp_while of expression * expression
+        (* while E1 do E2 done *)
+  | Pexp_for of
+      pattern *  expression * expression * direction_flag * expression
+        (* for i = E1 to E2 do E3 done      (flag = Upto)
+           for i = E1 downto E2 do E3 done  (flag = Downto)
+         *)
+  | Pexp_constraint of expression * core_type
+        (* (E : T) *)
+  | Pexp_coerce of expression * core_type option * core_type
+        (* (E :> T)        (None, T)
+           (E : T0 :> T)   (Some T0, T)
+         *)
+  | Pexp_send of expression * label loc
+        (*  E # m *)
+  | Pexp_new of Longident.t loc
+        (* new M.c *)
+  | Pexp_setinstvar of label loc * expression
+        (* x <- 2 *)
+  | Pexp_override of (label loc * expression) list
+        (* {< x1 = E1; ...; Xn = En >} *)
+  | Pexp_letmodule of string option loc * module_expr * expression
+        (* let module M = ME in E *)
+  | Pexp_letexception of extension_constructor * expression
+        (* let exception C in E *)
+  | Pexp_assert of expression
+        (* assert E
+           Note: "assert false" is treated in a special way by the
+           type-checker. *)
+  | Pexp_lazy of expression
+        (* lazy E *)
+  | Pexp_poly of expression * core_type option
+        (* Used for method bodies.
+
+           Can only be used as the expression under Cfk_concrete
+           for methods (not values). *)
+  | Pexp_object of class_structure
+        (* object ... end *)
+  | Pexp_newtype of string loc * expression
+        (* fun (type t) -> E *)
+  | Pexp_pack of module_expr
+        (* (module ME)
+
+           (module ME : S) is represented as
+           Pexp_constraint(Pexp_pack, Ptyp_package S) *)
+  | Pexp_open of open_declaration * expression
+        (* M.(E)
+           let open M in E
+           let! open M in E *)
+  | Pexp_letop of letop
+        (* let* P = E in E
+           let* P = E and* P = E in E *)
+  | Pexp_extension of extension
+        (* [%id] *)
+  | Pexp_unreachable
+        (* . *)
+
+and case =   (* (P -> E) or (P when E0 -> E) *)
+    {
+     pc_lhs: pattern;
+     pc_guard: expression option;
+     pc_rhs: expression;
+   }
+
+and letop =
+  {
+    let_ : binding_op;
+    ands : binding_op list;
+    body : expression;
+  }
+
+and binding_op =
+  {
+    pbop_op : string loc;
+    pbop_pat : pattern;
+    pbop_exp : expression;
+    pbop_loc : Location.t;
+  }
+
+(* Value descriptions *)
+
+and value_description =
+    {
+     pval_name: string loc;
+     pval_type: core_type;
+     pval_prim: string list;
+     pval_attributes: attributes;  (* ... [@@id1] [@@id2] *)
+     pval_loc: Location.t;
+    }
+
+(*
+  val x: T                            (prim = [])
+  external x: T = "s1" ... "sn"       (prim = ["s1";..."sn"])
+*)
+
+(* Type declarations *)
+
+and type_declaration =
+    {
+     ptype_name: string loc;
+     ptype_params: (core_type * variance) list;
+           (* ('a1,...'an) t; None represents  _*)
+     ptype_cstrs: (core_type * core_type * Location.t) list;
+           (* ... constraint T1=T1'  ... constraint Tn=Tn' *)
+     ptype_kind: type_kind;
+     ptype_private: private_flag;   (* = private ... *)
+     ptype_manifest: core_type option;  (* = T *)
+     ptype_attributes: attributes;   (* ... [@@id1] [@@id2] *)
+     ptype_loc: Location.t;
+    }
+
+(*
+  type t                     (abstract, no manifest)
+  type t = T0                (abstract, manifest=T0)
+  type t = C of T | ...      (variant,  no manifest)
+  type t = T0 = C of T | ... (variant,  manifest=T0)
+  type t = {l: T; ...}       (record,   no manifest)
+  type t = T0 = {l : T; ...} (record,   manifest=T0)
+  type t = ..                (open,     no manifest)
+*)
+
+and type_kind =
+  | Ptype_abstract
+  | Ptype_variant of constructor_declaration list
+  | Ptype_record of label_declaration list
+        (* Invariant: non-empty list *)
+  | Ptype_open
+
+and label_declaration =
+    {
+     pld_name: string loc;
+     pld_mutable: mutable_flag;
+     pld_type: core_type;
+     pld_loc: Location.t;
+     pld_attributes: attributes; (* l : T [@id1] [@id2] *)
+    }
+
+(*  { ...; l: T; ... }            (mutable=Immutable)
+    { ...; mutable l: T; ... }    (mutable=Mutable)
+
+    Note: T can be a Ptyp_poly.
+*)
+
+and constructor_declaration =
+    {
+     pcd_name: string loc;
+     pcd_args: constructor_arguments;
+     pcd_res: core_type option;
+     pcd_loc: Location.t;
+     pcd_attributes: attributes; (* C of ... [@id1] [@id2] *)
+    }
+
+and constructor_arguments =
+  | Pcstr_tuple of core_type list
+  | Pcstr_record of label_declaration list
+
+(*
+  | C of T1 * ... * Tn     (res = None,    args = Pcstr_tuple [])
+  | C: T0                  (res = Some T0, args = [])
+  | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple)
+  | C of {...}             (res = None,    args = Pcstr_record)
+  | C: {...} -> T0         (res = Some T0, args = Pcstr_record)
+  | C of {...} as t        (res = None,    args = Pcstr_record)
+*)
+
+and type_extension =
+    {
+     ptyext_path: Longident.t loc;
+     ptyext_params: (core_type * variance) list;
+     ptyext_constructors: extension_constructor list;
+     ptyext_private: private_flag;
+     ptyext_loc: Location.t;
+     ptyext_attributes: attributes;   (* ... [@@id1] [@@id2] *)
+    }
+(*
+  type t += ...
+*)
+
+and extension_constructor =
+    {
+     pext_name: string loc;
+     pext_kind : extension_constructor_kind;
+     pext_loc : Location.t;
+     pext_attributes: attributes; (* C of ... [@id1] [@id2] *)
+   }
+
+(* exception E *)
+and type_exception =
+  {
+    ptyexn_constructor: extension_constructor;
+    ptyexn_loc: Location.t;
+    ptyexn_attributes: attributes; (* ... [@@id1] [@@id2] *)
+  }
+
+and extension_constructor_kind =
+    Pext_decl of constructor_arguments * core_type option
+      (*
+         | C of T1 * ... * Tn     ([T1; ...; Tn], None)
+         | C: T0                  ([], Some T0)
+         | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0)
+       *)
+  | Pext_rebind of Longident.t loc
+      (*
+         | C = D
+       *)
+
+(** {1 Class language} *)
+
+(* Type expressions for the class language *)
+
+and class_type =
+    {
+     pcty_desc: class_type_desc;
+     pcty_loc: Location.t;
+     pcty_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and class_type_desc =
+  | Pcty_constr of Longident.t loc * core_type list
+        (* c
+           ['a1, ..., 'an] c *)
+  | Pcty_signature of class_signature
+        (* object ... end *)
+  | Pcty_arrow of arg_label * core_type * class_type
+        (* T -> CT       Simple
+           ~l:T -> CT    Labelled l
+           ?l:T -> CT    Optional l
+         *)
+  | Pcty_extension of extension
+        (* [%id] *)
+  | Pcty_open of open_description * class_type
+        (* let open M in CT *)
+
+and class_signature =
+    {
+     pcsig_self: core_type;
+     pcsig_fields: class_type_field list;
+    }
+(* object('selfpat) ... end
+   object ... end             (self = Ptyp_any)
+ *)
+
+and class_type_field =
+    {
+     pctf_desc: class_type_field_desc;
+     pctf_loc: Location.t;
+     pctf_attributes: attributes; (* ... [@@id1] [@@id2] *)
+    }
+
+and class_type_field_desc =
+  | Pctf_inherit of class_type
+        (* inherit CT *)
+  | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type)
+        (* val x: T *)
+  | Pctf_method  of (label loc * private_flag * virtual_flag * core_type)
+        (* method x: T
+
+           Note: T can be a Ptyp_poly.
+         *)
+  | Pctf_constraint  of (core_type * core_type)
+        (* constraint T1 = T2 *)
+  | Pctf_attribute of attribute
+        (* [@@@id] *)
+  | Pctf_extension of extension
+        (* [%%id] *)
+
+and 'a class_infos =
+    {
+     pci_virt: virtual_flag;
+     pci_params: (core_type * variance) list;
+     pci_name: string loc;
+     pci_expr: 'a;
+     pci_loc: Location.t;
+     pci_attributes: attributes;  (* ... [@@id1] [@@id2] *)
+    }
+(* class c = ...
+   class ['a1,...,'an] c = ...
+   class virtual c = ...
+
+   Also used for "class type" declaration.
+*)
+
+and class_description = class_type class_infos
+
+and class_type_declaration = class_type class_infos
+
+(* Value expressions for the class language *)
+
+and class_expr =
+    {
+     pcl_desc: class_expr_desc;
+     pcl_loc: Location.t;
+     pcl_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and class_expr_desc =
+  | Pcl_constr of Longident.t loc * core_type list
+        (* c
+           ['a1, ..., 'an] c *)
+  | Pcl_structure of class_structure
+        (* object ... end *)
+  | Pcl_fun of arg_label * expression option * pattern * class_expr
+        (* fun P -> CE                          (Simple, None)
+           fun ~l:P -> CE                       (Labelled l, None)
+           fun ?l:P -> CE                       (Optional l, None)
+           fun ?l:(P = E0) -> CE                (Optional l, Some E0)
+         *)
+  | Pcl_apply of class_expr * (arg_label * expression) list
+        (* CE ~l1:E1 ... ~ln:En
+           li can be empty (non labeled argument) or start with '?'
+           (optional argument).
+
+           Invariant: n > 0
+         *)
+  | Pcl_let of rec_flag * value_binding list * class_expr
+        (* let P1 = E1 and ... and Pn = EN in CE      (flag = Nonrecursive)
+           let rec P1 = E1 and ... and Pn = EN in CE  (flag = Recursive)
+         *)
+  | Pcl_constraint of class_expr * class_type
+        (* (CE : CT) *)
+  | Pcl_extension of extension
+  (* [%id] *)
+  | Pcl_open of open_description * class_expr
+  (* let open M in CE *)
+
+
+and class_structure =
+    {
+     pcstr_self: pattern;
+     pcstr_fields: class_field list;
+    }
+(* object(selfpat) ... end
+   object ... end           (self = Ppat_any)
+ *)
+
+and class_field =
+    {
+     pcf_desc: class_field_desc;
+     pcf_loc: Location.t;
+     pcf_attributes: attributes; (* ... [@@id1] [@@id2] *)
+    }
+
+and class_field_desc =
+  | Pcf_inherit of override_flag * class_expr * string loc option
+        (* inherit CE
+           inherit CE as x
+           inherit! CE
+           inherit! CE as x
+         *)
+  | Pcf_val of (label loc * mutable_flag * class_field_kind)
+        (* val x = E
+           val virtual x: T
+         *)
+  | Pcf_method of (label loc * private_flag * class_field_kind)
+        (* method x = E            (E can be a Pexp_poly)
+           method virtual x: T     (T can be a Ptyp_poly)
+         *)
+  | Pcf_constraint of (core_type * core_type)
+        (* constraint T1 = T2 *)
+  | Pcf_initializer of expression
+        (* initializer E *)
+  | Pcf_attribute of attribute
+        (* [@@@id] *)
+  | Pcf_extension of extension
+        (* [%%id] *)
+
+and class_field_kind =
+  | Cfk_virtual of core_type
+  | Cfk_concrete of override_flag * expression
+
+and class_declaration = class_expr class_infos
+
+(** {1 Module language} *)
+
+(* Type expressions for the module language *)
+
+and module_type =
+    {
+     pmty_desc: module_type_desc;
+     pmty_loc: Location.t;
+     pmty_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and module_type_desc =
+  | Pmty_ident of Longident.t loc
+        (* S *)
+  | Pmty_signature of signature
+        (* sig ... end *)
+  | Pmty_functor of functor_parameter * module_type
+        (* functor(X : MT1) -> MT2 *)
+  | Pmty_with of module_type * with_constraint list
+        (* MT with ... *)
+  | Pmty_typeof of module_expr
+        (* module type of ME *)
+  | Pmty_extension of extension
+        (* [%id] *)
+  | Pmty_alias of Longident.t loc
+        (* (module M) *)
+
+and functor_parameter =
+  | Unit
+        (* () *)
+  | Named of string option loc * module_type
+        (* (X : MT)          Some X, MT
+           (_ : MT)          None, MT *)
+
+and signature = signature_item list
+
+and signature_item =
+    {
+     psig_desc: signature_item_desc;
+     psig_loc: Location.t;
+    }
+
+and signature_item_desc =
+  | Psig_value of value_description
+        (*
+          val x: T
+          external x: T = "s1" ... "sn"
+         *)
+  | Psig_type of rec_flag * type_declaration list
+        (* type t1 = ... and ... and tn  = ... *)
+  | Psig_typesubst of type_declaration list
+        (* type t1 := ... and ... and tn := ...  *)
+  | Psig_typext of type_extension
+        (* type t1 += ... *)
+  | Psig_exception of type_exception
+        (* exception C of T *)
+  | Psig_module of module_declaration
+        (* module X = M
+           module X : MT *)
+  | Psig_modsubst of module_substitution
+        (* module X := M *)
+  | Psig_recmodule of module_declaration list
+        (* module rec X1 : MT1 and ... and Xn : MTn *)
+  | Psig_modtype of module_type_declaration
+        (* module type S = MT
+           module type S *)
+  | Psig_open of open_description
+        (* open X *)
+  | Psig_include of include_description
+        (* include MT *)
+  | Psig_class of class_description list
+        (* class c1 : ... and ... and cn : ... *)
+  | Psig_class_type of class_type_declaration list
+        (* class type ct1 = ... and ... and ctn = ... *)
+  | Psig_attribute of attribute
+        (* [@@@id] *)
+  | Psig_extension of extension * attributes
+        (* [%%id] *)
+
+and module_declaration =
+    {
+     pmd_name: string option loc;
+     pmd_type: module_type;
+     pmd_attributes: attributes; (* ... [@@id1] [@@id2] *)
+     pmd_loc: Location.t;
+    }
+(* S : MT *)
+
+and module_substitution =
+    {
+     pms_name: string loc;
+     pms_manifest: Longident.t loc;
+     pms_attributes: attributes; (* ... [@@id1] [@@id2] *)
+     pms_loc: Location.t;
+    }
+
+and module_type_declaration =
+    {
+     pmtd_name: string loc;
+     pmtd_type: module_type option;
+     pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *)
+     pmtd_loc: Location.t;
+    }
+(* S = MT
+   S       (abstract module type declaration, pmtd_type = None)
+*)
+
+and 'a open_infos =
+    {
+     popen_expr: 'a;
+     popen_override: override_flag;
+     popen_loc: Location.t;
+     popen_attributes: attributes;
+    }
+(* open! X - popen_override = Override (silences the 'used identifier
+                              shadowing' warning)
+   open  X - popen_override = Fresh
+ *)
+
+and open_description = Longident.t loc open_infos
+(* open M.N
+   open M(N).O *)
+
+and open_declaration = module_expr open_infos
+(* open M.N
+   open M(N).O
+   open struct ... end *)
+
+and 'a include_infos =
+    {
+     pincl_mod: 'a;
+     pincl_loc: Location.t;
+     pincl_attributes: attributes;
+    }
+
+and include_description = module_type include_infos
+(* include MT *)
+
+and include_declaration = module_expr include_infos
+(* include ME *)
+
+and with_constraint =
+  | Pwith_type of Longident.t loc * type_declaration
+        (* with type X.t = ...
+
+           Note: the last component of the longident must match
+           the name of the type_declaration. *)
+  | Pwith_module of Longident.t loc * Longident.t loc
+        (* with module X.Y = Z *)
+  | Pwith_typesubst of Longident.t loc * type_declaration
+        (* with type X.t := ..., same format as [Pwith_type] *)
+  | Pwith_modsubst of Longident.t loc * Longident.t loc
+        (* with module X.Y := Z *)
+
+(* Value expressions for the module language *)
+
+and module_expr =
+    {
+     pmod_desc: module_expr_desc;
+     pmod_loc: Location.t;
+     pmod_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and module_expr_desc =
+  | Pmod_ident of Longident.t loc
+        (* X *)
+  | Pmod_structure of structure
+        (* struct ... end *)
+  | Pmod_functor of functor_parameter * module_expr
+        (* functor(X : MT1) -> ME *)
+  | Pmod_apply of module_expr * module_expr
+        (* ME1(ME2) *)
+  | Pmod_constraint of module_expr * module_type
+        (* (ME : MT) *)
+  | Pmod_unpack of expression
+        (* (val E) *)
+  | Pmod_extension of extension
+        (* [%id] *)
+
+and structure = structure_item list
+
+and structure_item =
+    {
+     pstr_desc: structure_item_desc;
+     pstr_loc: Location.t;
+    }
+
+and structure_item_desc =
+  | Pstr_eval of expression * attributes
+        (* E *)
+  | Pstr_value of rec_flag * value_binding list
+        (* let P1 = E1 and ... and Pn = EN       (flag = Nonrecursive)
+           let rec P1 = E1 and ... and Pn = EN   (flag = Recursive)
+         *)
+  | Pstr_primitive of value_description
+        (*  val x: T
+            external x: T = "s1" ... "sn" *)
+  | Pstr_type of rec_flag * type_declaration list
+        (* type t1 = ... and ... and tn = ... *)
+  | Pstr_typext of type_extension
+        (* type t1 += ... *)
+  | Pstr_exception of type_exception
+        (* exception C of T
+           exception C = M.X *)
+  | Pstr_module of module_binding
+        (* module X = ME *)
+  | Pstr_recmodule of module_binding list
+        (* module rec X1 = ME1 and ... and Xn = MEn *)
+  | Pstr_modtype of module_type_declaration
+        (* module type S = MT *)
+  | Pstr_open of open_declaration
+        (* open X *)
+  | Pstr_class of class_declaration list
+        (* class c1 = ... and ... and cn = ... *)
+  | Pstr_class_type of class_type_declaration list
+        (* class type ct1 = ... and ... and ctn = ... *)
+  | Pstr_include of include_declaration
+        (* include ME *)
+  | Pstr_attribute of attribute
+        (* [@@@id] *)
+  | Pstr_extension of extension * attributes
+        (* [%%id] *)
+
+and value_binding =
+  {
+    pvb_pat: pattern;
+    pvb_expr: expression;
+    pvb_attributes: attributes;
+    pvb_loc: Location.t;
+  }
+
+and module_binding =
+    {
+     pmb_name: string option loc;
+     pmb_expr: module_expr;
+     pmb_attributes: attributes;
+     pmb_loc: Location.t;
+    }
+(* X = ME *)
+
+(** {1 Toplevel} *)
+
+(* Toplevel phrases *)
+
+type toplevel_phrase =
+  | Ptop_def of structure
+  | Ptop_dir of toplevel_directive
+     (* #use, #load ... *)
+
+and toplevel_directive =
+  {
+    pdir_name : string loc;
+    pdir_arg : directive_argument option;
+    pdir_loc : Location.t;
+  }
+
+and directive_argument =
+  {
+    pdira_desc : directive_argument_desc;
+    pdira_loc : Location.t;
+  }
+
+and directive_argument_desc =
+  | Pdir_string of string
+  | Pdir_int of string * char option
+  | Pdir_ident of Longident.t
+  | Pdir_bool of bool
diff --git a/upstream/ocaml_411/parsing/pprintast.ml b/upstream/ocaml_411/parsing/pprintast.ml
new file mode 100644
index 0000000..d731bdf
--- /dev/null
+++ b/upstream/ocaml_411/parsing/pprintast.ml
@@ -0,0 +1,1647 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Thomas Gazagnaire, OCamlPro                       *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*               Hongbo Zhang, University of Pennsylvania                 *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Original Code from Ber-metaocaml, modified for 3.12.0 and fixed *)
+(* Printing code expressions *)
+(* Authors:  Ed Pizzi, Fabrice Le Fessant *)
+(* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *)
+(* TODO more fine-grained precedence pretty-printing *)
+
+open Asttypes
+open Format
+open Location
+open Longident
+open Parsetree
+open Ast_helper
+
+let prefix_symbols  = [ '!'; '?'; '~' ] ;;
+let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/';
+                      '$'; '%'; '#' ]
+
+(* type fixity = Infix| Prefix  *)
+let special_infix_strings =
+  ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ]
+
+let letop s =
+  String.length s > 3
+  && s.[0] = 'l'
+  && s.[1] = 'e'
+  && s.[2] = 't'
+  && List.mem s.[3] infix_symbols
+
+let andop s =
+  String.length s > 3
+  && s.[0] = 'a'
+  && s.[1] = 'n'
+  && s.[2] = 'd'
+  && List.mem s.[3] infix_symbols
+
+(* determines if the string is an infix string.
+   checks backwards, first allowing a renaming postfix ("_102") which
+   may have resulted from Pexp -> Texp -> Pexp translation, then checking
+   if all the characters in the beginning of the string are valid infix
+   characters. *)
+let fixity_of_string  = function
+  | "" -> `Normal
+  | s when List.mem s special_infix_strings -> `Infix s
+  | s when List.mem s.[0] infix_symbols -> `Infix s
+  | s when List.mem s.[0] prefix_symbols -> `Prefix s
+  | s when s.[0] = '.' -> `Mixfix s
+  | s when letop s -> `Letop s
+  | s when andop s -> `Andop s
+  | _ -> `Normal
+
+let view_fixity_of_exp = function
+  | {pexp_desc = Pexp_ident {txt=Lident l;_}; pexp_attributes = []} ->
+      fixity_of_string l
+  | _ -> `Normal
+
+let is_infix  = function `Infix _ -> true | _  -> false
+let is_mixfix = function `Mixfix _ -> true | _ -> false
+let is_kwdop = function `Letop _ | `Andop _ -> true | _ -> false
+
+let first_is c str =
+  str <> "" && str.[0] = c
+let last_is c str =
+  str <> "" && str.[String.length str - 1] = c
+
+let first_is_in cs str =
+  str <> "" && List.mem str.[0] cs
+
+(* which identifiers are in fact operators needing parentheses *)
+let needs_parens txt =
+  let fix = fixity_of_string txt in
+  is_infix fix
+  || is_mixfix fix
+  || is_kwdop fix
+  || first_is_in prefix_symbols txt
+
+(* some infixes need spaces around parens to avoid clashes with comment
+   syntax *)
+let needs_spaces txt =
+  first_is '*' txt || last_is '*' txt
+
+(* add parentheses to binders when they are in fact infix or prefix operators *)
+let protect_ident ppf txt =
+  let format : (_, _, _) format =
+    if not (needs_parens txt) then "%s"
+    else if needs_spaces txt then "(@;%s@;)"
+    else "(%s)"
+  in fprintf ppf format txt
+
+let protect_longident ppf print_longident longprefix txt =
+  let format : (_, _, _) format =
+    if not (needs_parens txt) then "%a.%s"
+    else if needs_spaces txt then  "%a.(@;%s@;)"
+    else "%a.(%s)" in
+  fprintf ppf format print_longident longprefix txt
+
+type space_formatter = (unit, Format.formatter, unit) format
+
+let override = function
+  | Override -> "!"
+  | Fresh -> ""
+
+(* variance encoding: need to sync up with the [parser.mly] *)
+let type_variance = function
+  | Invariant -> ""
+  | Covariant -> "+"
+  | Contravariant -> "-"
+
+type construct =
+  [ `cons of expression list
+  | `list of expression list
+  | `nil
+  | `normal
+  | `simple of Longident.t
+  | `tuple ]
+
+let view_expr x =
+  match x.pexp_desc with
+  | Pexp_construct ( {txt= Lident "()"; _},_) -> `tuple
+  | Pexp_construct ( {txt= Lident "[]";_},_) -> `nil
+  | Pexp_construct ( {txt= Lident"::";_},Some _) ->
+      let rec loop exp acc = match exp with
+          | {pexp_desc=Pexp_construct ({txt=Lident "[]";_},_);
+             pexp_attributes = []} ->
+              (List.rev acc,true)
+          | {pexp_desc=
+             Pexp_construct ({txt=Lident "::";_},
+                             Some ({pexp_desc= Pexp_tuple([e1;e2]);
+                                    pexp_attributes = []}));
+             pexp_attributes = []}
+            ->
+              loop e2 (e1::acc)
+          | e -> (List.rev (e::acc),false) in
+      let (ls,b) = loop x []  in
+      if b then
+        `list ls
+      else `cons ls
+  | Pexp_construct (x,None) -> `simple (x.txt)
+  | _ -> `normal
+
+let is_simple_construct :construct -> bool = function
+  | `nil | `tuple | `list _ | `simple _  -> true
+  | `cons _ | `normal -> false
+
+let pp = fprintf
+
+type ctxt = {
+  pipe : bool;
+  semi : bool;
+  ifthenelse : bool;
+}
+
+let reset_ctxt = { pipe=false; semi=false; ifthenelse=false }
+let under_pipe ctxt = { ctxt with pipe=true }
+let under_semi ctxt = { ctxt with semi=true }
+let under_ifthenelse ctxt = { ctxt with ifthenelse=true }
+(*
+let reset_semi ctxt = { ctxt with semi=false }
+let reset_ifthenelse ctxt = { ctxt with ifthenelse=false }
+let reset_pipe ctxt = { ctxt with pipe=false }
+*)
+
+let list : 'a . ?sep:space_formatter -> ?first:space_formatter ->
+  ?last:space_formatter -> (Format.formatter -> 'a -> unit) ->
+  Format.formatter -> 'a list -> unit
+  = fun ?sep ?first ?last fu f xs ->
+    let first = match first with Some x -> x |None -> ("": _ format6)
+    and last = match last with Some x -> x |None -> ("": _ format6)
+    and sep = match sep with Some x -> x |None -> ("@ ": _ format6) in
+    let aux f = function
+      | [] -> ()
+      | [x] -> fu f x
+      | xs ->
+          let rec loop  f = function
+            | [x] -> fu f x
+            | x::xs ->  fu f x; pp f sep; loop f xs;
+            | _ -> assert false in begin
+            pp f first; loop f xs; pp f last;
+          end in
+    aux f xs
+
+let option : 'a. ?first:space_formatter -> ?last:space_formatter ->
+  (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit
+  = fun  ?first  ?last fu f a ->
+    let first = match first with Some x -> x | None -> ("": _ format6)
+    and last = match last with Some x -> x | None -> ("": _ format6) in
+    match a with
+    | None -> ()
+    | Some x -> pp f first; fu f x; pp f last
+
+let paren: 'a . ?first:space_formatter -> ?last:space_formatter ->
+  bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit
+  = fun  ?(first=("": _ format6)) ?(last=("": _ format6)) b fu f x ->
+    if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")")
+    else fu f x
+
+let rec longident f = function
+  | Lident s -> protect_ident f s
+  | Ldot(y,s) -> protect_longident f longident y s
+  | Lapply (y,s) ->
+      pp f "%a(%a)" longident y longident s
+
+let longident_loc f x = pp f "%a" longident x.txt
+
+let constant f = function
+  | Pconst_char i ->
+      pp f "%C"  i
+  | Pconst_string (i, _, None) ->
+      pp f "%S" i
+  | Pconst_string (i, _, Some delim) ->
+      pp f "{%s|%s|%s}" delim i delim
+  | Pconst_integer (i, None) ->
+      paren (first_is '-' i) (fun f -> pp f "%s") f i
+  | Pconst_integer (i, Some m) ->
+      paren (first_is '-' i) (fun f (i, m) -> pp f "%s%c" i m) f (i,m)
+  | Pconst_float (i, None) ->
+      paren (first_is '-' i) (fun f -> pp f "%s") f i
+  | Pconst_float (i, Some m) ->
+      paren (first_is '-' i) (fun f (i,m) -> pp f "%s%c" i m) f (i,m)
+
+(* trailing space*)
+let mutable_flag f = function
+  | Immutable -> ()
+  | Mutable -> pp f "mutable@;"
+let virtual_flag f  = function
+  | Concrete -> ()
+  | Virtual -> pp f "virtual@;"
+
+(* trailing space added *)
+let rec_flag f rf =
+  match rf with
+  | Nonrecursive -> ()
+  | Recursive -> pp f "rec "
+let nonrec_flag f rf =
+  match rf with
+  | Nonrecursive -> pp f "nonrec "
+  | Recursive -> ()
+let direction_flag f = function
+  | Upto -> pp f "to@ "
+  | Downto -> pp f "downto@ "
+let private_flag f = function
+  | Public -> ()
+  | Private -> pp f "private@ "
+
+let iter_loc f ctxt {txt; loc = _} = f ctxt txt
+
+let constant_string f s = pp f "%S" s
+
+let tyvar ppf s =
+  if String.length s >= 2 && s.[1] = '\'' then
+    (* without the space, this would be parsed as
+       a character literal *)
+    Format.fprintf ppf "' %s" s
+  else
+    Format.fprintf ppf "'%s" s
+
+let tyvar_loc f str = tyvar f str.txt
+let string_quot f x = pp f "`%s" x
+
+(* c ['a,'b] *)
+let rec class_params_def ctxt f =  function
+  | [] -> ()
+  | l ->
+      pp f "[%a] " (* space *)
+        (list (type_param ctxt) ~sep:",") l
+
+and type_with_label ctxt f (label, c) =
+  match label with
+  | Nolabel    -> core_type1 ctxt f c (* otherwise parenthesize *)
+  | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c
+  | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c
+
+and core_type ctxt f x =
+  if x.ptyp_attributes <> [] then begin
+    pp f "((%a)%a)" (core_type ctxt) {x with ptyp_attributes=[]}
+      (attributes ctxt) x.ptyp_attributes
+  end
+  else match x.ptyp_desc with
+    | Ptyp_arrow (l, ct1, ct2) ->
+        pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
+          (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2
+    | Ptyp_alias (ct, s) ->
+        pp f "@[<2>%a@;as@;%a@]" (core_type1 ctxt) ct tyvar s
+    | Ptyp_poly ([], ct) ->
+        core_type ctxt f ct
+    | Ptyp_poly (sl, ct) ->
+        pp f "@[<2>%a%a@]"
+          (fun f l ->
+             pp f "%a"
+               (fun f l -> match l with
+                  | [] -> ()
+                  | _ ->
+                      pp f "%a@;.@;"
+                        (list tyvar_loc ~sep:"@;")  l)
+               l)
+          sl (core_type ctxt) ct
+    | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x
+
+and core_type1 ctxt f x =
+  if x.ptyp_attributes <> [] then core_type ctxt f x
+  else match x.ptyp_desc with
+    | Ptyp_any -> pp f "_";
+    | Ptyp_var s -> tyvar f  s;
+    | Ptyp_tuple l ->  pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l
+    | Ptyp_constr (li, l) ->
+        pp f (* "%a%a@;" *) "%a%a"
+          (fun f l -> match l with
+             |[] -> ()
+             |[x]-> pp f "%a@;" (core_type1 ctxt)  x
+             | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l)
+          l longident_loc li
+    | Ptyp_variant (l, closed, low) ->
+        let type_variant_helper f x =
+          match x.prf_desc with
+          | Rtag (l, _, ctl) ->
+              pp f "@[<2>%a%a@;%a@]" (iter_loc string_quot) l
+                (fun f l -> match l with
+                   |[] -> ()
+                   | _ -> pp f "@;of@;%a"
+                            (list (core_type ctxt) ~sep:"&")  ctl) ctl
+                (attributes ctxt) x.prf_attributes
+          | Rinherit ct -> core_type ctxt f ct in
+        pp f "@[<2>[%a%a]@]"
+          (fun f l ->
+             match l, closed with
+             | [], Closed -> ()
+             | [], Open -> pp f ">" (* Cf #7200: print [>] correctly *)
+             | _ ->
+                 pp f "%s@;%a"
+                   (match (closed,low) with
+                    | (Closed,None) -> ""
+                    | (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*)
+                    | (Open,_) -> ">")
+                   (list type_variant_helper ~sep:"@;<1 -2>| ") l) l
+          (fun f low -> match low with
+             |Some [] |None -> ()
+             |Some xs ->
+                 pp f ">@ %a"
+                   (list string_quot) xs) low
+    | Ptyp_object (l, o) ->
+        let core_field_type f x = match x.pof_desc with
+          | Otag (l, ct) ->
+            (* Cf #7200 *)
+            pp f "@[<hov2>%s: %a@ %a@ @]" l.txt
+              (core_type ctxt) ct (attributes ctxt) x.pof_attributes
+          | Oinherit ct ->
+            pp f "@[<hov2>%a@ @]" (core_type ctxt) ct
+        in
+        let field_var f = function
+          | Asttypes.Closed -> ()
+          | Asttypes.Open ->
+              match l with
+              | [] -> pp f ".."
+              | _ -> pp f " ;.."
+        in
+        pp f "@[<hov2><@ %a%a@ > @]"
+          (list core_field_type ~sep:";") l
+          field_var o (* Cf #7200 *)
+    | Ptyp_class (li, l) ->   (*FIXME*)
+        pp f "@[<hov2>%a#%a@]"
+          (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") l
+          longident_loc li
+    | Ptyp_package (lid, cstrs) ->
+        let aux f (s, ct) =
+          pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct  in
+        (match cstrs with
+         |[] -> pp f "@[<hov2>(module@ %a)@]" longident_loc lid
+         |_ ->
+             pp f "@[<hov2>(module@ %a@ with@ %a)@]" longident_loc lid
+               (list aux  ~sep:"@ and@ ")  cstrs)
+    | Ptyp_extension e -> extension ctxt f e
+    | _ -> paren true (core_type ctxt) f x
+
+(********************pattern********************)
+(* be cautious when use [pattern], [pattern1] is preferred *)
+and pattern ctxt f x =
+  let rec list_of_pattern acc = function (* only consider ((A|B)|C)*)
+    | {ppat_desc= Ppat_or (p1,p2); ppat_attributes = []} ->
+        list_of_pattern  (p2::acc) p1
+    | x -> x::acc
+  in
+  if x.ppat_attributes <> [] then begin
+    pp f "((%a)%a)" (pattern ctxt) {x with ppat_attributes=[]}
+      (attributes ctxt) x.ppat_attributes
+  end
+  else match x.ppat_desc with
+    | Ppat_alias (p, s) ->
+        pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt (* RA*)
+    | Ppat_or _ -> (* *)
+        pp f "@[<hov0>%a@]" (list ~sep:"@,|" (pattern ctxt))
+          (list_of_pattern [] x)
+    | _ -> pattern1 ctxt f x
+
+and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit =
+  let rec pattern_list_helper f = function
+    | {ppat_desc =
+         Ppat_construct
+           ({ txt = Lident("::") ;_},
+            Some ({ppat_desc = Ppat_tuple([pat1; pat2]);_}));
+       ppat_attributes = []}
+
+      ->
+        pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*)
+    | p -> pattern1 ctxt f p
+  in
+  if x.ppat_attributes <> [] then pattern ctxt f x
+  else match x.ppat_desc with
+    | Ppat_variant (l, Some p) ->
+        pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) p
+    | Ppat_construct (({txt=Lident("()"|"[]");_}), _) -> simple_pattern ctxt f x
+    | Ppat_construct (({txt;_} as li), po) ->
+        (* FIXME The third field always false *)
+        if txt = Lident "::" then
+          pp f "%a" pattern_list_helper x
+        else
+          (match po with
+           | Some x -> pp f "%a@;%a"  longident_loc li (simple_pattern ctxt) x
+           | None -> pp f "%a" longident_loc li)
+    | _ -> simple_pattern ctxt f x
+
+and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit =
+  if x.ppat_attributes <> [] then pattern ctxt f x
+  else match x.ppat_desc with
+    | Ppat_construct (({txt=Lident ("()"|"[]" as x);_}), _) -> pp f  "%s" x
+    | Ppat_any -> pp f "_";
+    | Ppat_var ({txt = txt;_}) -> protect_ident f txt
+    | Ppat_array l ->
+        pp f "@[<2>[|%a|]@]"  (list (pattern1 ctxt) ~sep:";") l
+    | Ppat_unpack { txt = None } ->
+        pp f "(module@ _)@ "
+    | Ppat_unpack { txt = Some s } ->
+        pp f "(module@ %s)@ " s
+    | Ppat_type li ->
+        pp f "#%a" longident_loc li
+    | Ppat_record (l, closed) ->
+        let longident_x_pattern f (li, p) =
+          match (li,p) with
+          | ({txt=Lident s;_ },
+             {ppat_desc=Ppat_var {txt;_};
+              ppat_attributes=[]; _})
+            when s = txt ->
+              pp f "@[<2>%a@]"  longident_loc li
+          | _ ->
+              pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p
+        in
+        begin match closed with
+        | Closed ->
+            pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l
+        | _ ->
+            pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l
+        end
+    | Ppat_tuple l ->
+        pp f "@[<1>(%a)@]" (list  ~sep:",@;" (pattern1 ctxt))  l (* level1*)
+    | Ppat_constant (c) -> pp f "%a" constant c
+    | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2
+    | Ppat_variant (l,None) ->  pp f "`%s" l
+    | Ppat_constraint (p, ct) ->
+        pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct
+    | Ppat_lazy p ->
+        pp f "@[<2>(lazy@;%a)@]" (simple_pattern ctxt) p
+    | Ppat_exception p ->
+        pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p
+    | Ppat_extension e -> extension ctxt f e
+    | Ppat_open (lid, p) ->
+        let with_paren =
+        match p.ppat_desc with
+        | Ppat_array _ | Ppat_record _
+        | Ppat_construct (({txt=Lident ("()"|"[]");_}), _) -> false
+        | _ -> true in
+        pp f "@[<2>%a.%a @]" longident_loc lid
+          (paren with_paren @@ pattern1 ctxt) p
+    | _ -> paren true (pattern ctxt) f x
+
+and label_exp ctxt f (l,opt,p) =
+  match l with
+  | Nolabel ->
+      (* single case pattern parens needed here *)
+      pp f "%a@ " (simple_pattern ctxt) p
+  | Optional rest ->
+      begin match p with
+      | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []}
+        when txt = rest ->
+          (match opt with
+           | Some o -> pp f "?(%s=@;%a)@;" rest  (expression ctxt) o
+           | None -> pp f "?%s@ " rest)
+      | _ ->
+          (match opt with
+           | Some o ->
+               pp f "?%s:(%a=@;%a)@;"
+                 rest (pattern1 ctxt) p (expression ctxt) o
+           | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p)
+      end
+  | Labelled l -> match p with
+    | {ppat_desc  = Ppat_var {txt;_}; ppat_attributes = []}
+      when txt = l ->
+        pp f "~%s@;" l
+    | _ ->  pp f "~%s:%a@;" l (simple_pattern ctxt) p
+
+and sugar_expr ctxt f e =
+  if e.pexp_attributes <> [] then false
+  else match e.pexp_desc with
+  | Pexp_apply ({ pexp_desc = Pexp_ident {txt = id; _};
+                  pexp_attributes=[]; _}, args)
+    when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin
+      let print_indexop a path_prefix assign left sep right print_index indices
+          rem_args =
+        let print_path ppf = function
+          | None -> ()
+          | Some m -> pp ppf ".%a" longident m in
+        match assign, rem_args with
+            | false, [] ->
+              pp f "@[%a%a%s%a%s@]"
+                (simple_expr ctxt) a print_path path_prefix
+                left (list ~sep print_index) indices right; true
+            | true, [v] ->
+              pp f "@[%a%a%s%a%s@ <-@;<1 2>%a@]"
+                (simple_expr ctxt) a print_path path_prefix
+                left (list ~sep print_index) indices right
+                (simple_expr ctxt) v; true
+            | _ -> false in
+      match id, List.map snd args with
+      | Lident "!", [e] ->
+        pp f "@[<hov>!%a@]" (simple_expr ctxt) e; true
+      | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin
+          let assign = func = "set" in
+          let print = print_indexop a None assign in
+          match path, other_args with
+          | Lident "Array", i :: rest ->
+            print ".(" "" ")" (expression ctxt) [i] rest
+          | Lident "String", i :: rest ->
+            print ".[" "" "]" (expression ctxt) [i] rest
+          | Ldot (Lident "Bigarray", "Array1"), i1 :: rest ->
+            print ".{" "," "}" (simple_expr ctxt) [i1] rest
+          | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest ->
+            print ".{" "," "}" (simple_expr ctxt) [i1; i2] rest
+          | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest ->
+            print ".{" "," "}" (simple_expr ctxt) [i1; i2; i3] rest
+          | Ldot (Lident "Bigarray", "Genarray"),
+            {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest ->
+              print ".{" "," "}" (simple_expr ctxt) indexes rest
+          | _ -> false
+        end
+      | (Lident s | Ldot(_,s)) , a :: i :: rest
+        when first_is '.' s ->
+          (* extract operator:
+             assignment operators end with [right_bracket ^ "<-"],
+             access operators end with [right_bracket] directly
+          *)
+          let multi_indices = String.contains s ';' in
+          let i =
+              match i.pexp_desc with
+                | Pexp_array l when multi_indices -> l
+                | _ -> [ i ] in
+          let assign = last_is '-' s in
+          let kind =
+            (* extract the right end bracket *)
+            let n = String.length s in
+            if assign then s.[n - 3] else s.[n - 1] in
+          let left, right = match kind with
+            | ')' -> '(', ")"
+            | ']' -> '[', "]"
+            | '}' -> '{', "}"
+            | _ -> assert false in
+          let path_prefix = match id with
+            | Ldot(m,_) -> Some m
+            | _ -> None in
+          let left = String.sub s 0 (1+String.index s left) in
+          print_indexop a path_prefix assign left ";" right
+            (if multi_indices then expression ctxt else simple_expr ctxt)
+            i rest
+      | _ -> false
+    end
+  | _ -> false
+
+and expression ctxt f x =
+  if x.pexp_attributes <> [] then
+    pp f "((%a)@,%a)" (expression ctxt) {x with pexp_attributes=[]}
+      (attributes ctxt) x.pexp_attributes
+  else match x.pexp_desc with
+    | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _
+    | Pexp_newtype _
+      when ctxt.pipe || ctxt.semi ->
+        paren true (expression reset_ctxt) f x
+    | Pexp_ifthenelse _ | Pexp_sequence _ when ctxt.ifthenelse ->
+        paren true (expression reset_ctxt) f x
+    | Pexp_let _ | Pexp_letmodule _ | Pexp_open _
+      | Pexp_letexception _ | Pexp_letop _
+        when ctxt.semi ->
+        paren true (expression reset_ctxt) f x
+    | Pexp_fun (l, e0, p, e) ->
+        pp f "@[<2>fun@;%a->@;%a@]"
+          (label_exp ctxt) (l, e0, p)
+          (expression ctxt) e
+    | Pexp_newtype (lid, e) ->
+        pp f "@[<2>fun@;(type@;%s)@;->@;%a@]" lid.txt
+          (expression ctxt) e
+    | Pexp_function l ->
+        pp f "@[<hv>function%a@]" (case_list ctxt) l
+    | Pexp_match (e, l) ->
+        pp f "@[<hv0>@[<hv0>@[<2>match %a@]@ with@]%a@]"
+          (expression reset_ctxt) e (case_list ctxt) l
+
+    | Pexp_try (e, l) ->
+        pp f "@[<0>@[<hv2>try@ %a@]@ @[<0>with%a@]@]"
+             (* "try@;@[<2>%a@]@\nwith@\n%a"*)
+          (expression reset_ctxt) e  (case_list ctxt) l
+    | Pexp_let (rf, l, e) ->
+        (* pp f "@[<2>let %a%a in@;<1 -2>%a@]"
+           (*no indentation here, a new line*) *)
+        (*   rec_flag rf *)
+        pp f "@[<2>%a in@;<1 -2>%a@]"
+          (bindings reset_ctxt) (rf,l)
+          (expression ctxt) e
+    | Pexp_apply (e, l) ->
+        begin if not (sugar_expr ctxt f x) then
+            match view_fixity_of_exp e with
+            | `Infix s ->
+                begin match l with
+                | [ (Nolabel, _) as arg1; (Nolabel, _) as arg2 ] ->
+                    (* FIXME associativity label_x_expression_param *)
+                    pp f "@[<2>%a@;%s@;%a@]"
+                      (label_x_expression_param reset_ctxt) arg1 s
+                      (label_x_expression_param ctxt) arg2
+                | _ ->
+                    pp f "@[<2>%a %a@]"
+                      (simple_expr ctxt) e
+                      (list (label_x_expression_param ctxt)) l
+                end
+            | `Prefix s ->
+                let s =
+                  if List.mem s ["~+";"~-";"~+.";"~-."] &&
+                   (match l with
+                    (* See #7200: avoid turning (~- 1) into (- 1) which is
+                       parsed as an int literal *)
+                    |[(_,{pexp_desc=Pexp_constant _})] -> false
+                    | _ -> true)
+                  then String.sub s 1 (String.length s -1)
+                  else s in
+                begin match l with
+                | [(Nolabel, x)] ->
+                  pp f "@[<2>%s@;%a@]" s (simple_expr ctxt) x
+                | _   ->
+                  pp f "@[<2>%a %a@]" (simple_expr ctxt) e
+                    (list (label_x_expression_param ctxt)) l
+                end
+            | _ ->
+                pp f "@[<hov2>%a@]" begin fun f (e,l) ->
+                  pp f "%a@ %a" (expression2 ctxt) e
+                    (list (label_x_expression_param reset_ctxt))  l
+                    (* reset here only because [function,match,try,sequence]
+                       are lower priority *)
+                end (e,l)
+        end
+
+    | Pexp_construct (li, Some eo)
+      when not (is_simple_construct (view_expr x))-> (* Not efficient FIXME*)
+        (match view_expr x with
+         | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;"
+         | `normal ->
+             pp f "@[<2>%a@;%a@]" longident_loc li
+               (simple_expr ctxt) eo
+         | _ -> assert false)
+    | Pexp_setfield (e1, li, e2) ->
+        pp f "@[<2>%a.%a@ <-@ %a@]"
+          (simple_expr ctxt) e1 longident_loc li (simple_expr ctxt) e2
+    | Pexp_ifthenelse (e1, e2, eo) ->
+        (* @;@[<2>else@ %a@]@] *)
+        let fmt:(_,_,_)format ="@[<hv0>@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" in
+        let expression_under_ifthenelse = expression (under_ifthenelse ctxt) in
+        pp f fmt expression_under_ifthenelse e1 expression_under_ifthenelse e2
+          (fun f eo -> match eo with
+             | Some x ->
+                 pp f "@;@[<2>else@;%a@]" (expression (under_semi ctxt)) x
+             | None -> () (* pp f "()" *)) eo
+    | Pexp_sequence _ ->
+        let rec sequence_helper acc = function
+          | {pexp_desc=Pexp_sequence(e1,e2); pexp_attributes = []} ->
+              sequence_helper (e1::acc) e2
+          | v -> List.rev (v::acc) in
+        let lst = sequence_helper [] x in
+        pp f "@[<hv>%a@]"
+          (list (expression (under_semi ctxt)) ~sep:";@;") lst
+    | Pexp_new (li) ->
+        pp f "@[<hov2>new@ %a@]" longident_loc li;
+    | Pexp_setinstvar (s, e) ->
+        pp f "@[<hov2>%s@ <-@ %a@]" s.txt (expression ctxt) e
+    | Pexp_override l -> (* FIXME *)
+        let string_x_expression f (s, e) =
+          pp f "@[<hov2>%s@ =@ %a@]" s.txt (expression ctxt) e in
+        pp f "@[<hov2>{<%a>}@]"
+          (list string_x_expression  ~sep:";"  )  l;
+    | Pexp_letmodule (s, me, e) ->
+        pp f "@[<hov2>let@ module@ %s@ =@ %a@ in@ %a@]"
+          (Option.value s.txt ~default:"_")
+          (module_expr reset_ctxt) me (expression ctxt) e
+    | Pexp_letexception (cd, e) ->
+        pp f "@[<hov2>let@ exception@ %a@ in@ %a@]"
+          (extension_constructor ctxt) cd
+          (expression ctxt) e
+    | Pexp_assert e ->
+        pp f "@[<hov2>assert@ %a@]" (simple_expr ctxt) e
+    | Pexp_lazy (e) ->
+        pp f "@[<hov2>lazy@ %a@]" (simple_expr ctxt) e
+    (* Pexp_poly: impossible but we should print it anyway, rather than
+       assert false *)
+    | Pexp_poly (e, None) ->
+        pp f "@[<hov2>!poly!@ %a@]" (simple_expr ctxt) e
+    | Pexp_poly (e, Some ct) ->
+        pp f "@[<hov2>(!poly!@ %a@ : %a)@]"
+          (simple_expr ctxt) e (core_type ctxt) ct
+    | Pexp_open (o, e) ->
+        pp f "@[<2>let open%s %a in@;%a@]"
+          (override o.popen_override) (module_expr ctxt) o.popen_expr
+          (expression ctxt) e
+    | Pexp_variant (l,Some eo) ->
+        pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo
+    | Pexp_letop {let_; ands; body} ->
+        pp f "@[<2>@[<v>%a@,%a@] in@;<1 -2>%a@]"
+          (binding_op ctxt) let_
+          (list ~sep:"@," (binding_op ctxt)) ands
+          (expression ctxt) body
+    | Pexp_extension e -> extension ctxt f e
+    | Pexp_unreachable -> pp f "."
+    | _ -> expression1 ctxt f x
+
+and expression1 ctxt f x =
+  if x.pexp_attributes <> [] then expression ctxt f x
+  else match x.pexp_desc with
+    | Pexp_object cs -> pp f "%a" (class_structure ctxt) cs
+    | _ -> expression2 ctxt f x
+(* used in [Pexp_apply] *)
+
+and expression2 ctxt f x =
+  if x.pexp_attributes <> [] then expression ctxt f x
+  else match x.pexp_desc with
+    | Pexp_field (e, li) ->
+        pp f "@[<hov2>%a.%a@]" (simple_expr ctxt) e longident_loc li
+    | Pexp_send (e, s) -> pp f "@[<hov2>%a#%s@]" (simple_expr ctxt) e s.txt
+
+    | _ -> simple_expr ctxt f x
+
+and simple_expr ctxt f x =
+  if x.pexp_attributes <> [] then expression ctxt f x
+  else match x.pexp_desc with
+    | Pexp_construct _  when is_simple_construct (view_expr x) ->
+        (match view_expr x with
+         | `nil -> pp f "[]"
+         | `tuple -> pp f "()"
+         | `list xs ->
+             pp f "@[<hv0>[%a]@]"
+               (list (expression (under_semi ctxt)) ~sep:";@;") xs
+         | `simple x -> longident f x
+         | _ -> assert false)
+    | Pexp_ident li ->
+        longident_loc f li
+    (* (match view_fixity_of_exp x with *)
+    (* |`Normal -> longident_loc f li *)
+    (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *)
+    | Pexp_constant c -> constant f c;
+    | Pexp_pack me ->
+        pp f "(module@;%a)" (module_expr ctxt) me
+    | Pexp_tuple l ->
+        pp f "@[<hov2>(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l
+    | Pexp_constraint (e, ct) ->
+        pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct
+    | Pexp_coerce (e, cto1, ct) ->
+        pp f "(%a%a :> %a)" (expression ctxt) e
+          (option (core_type ctxt) ~first:" : " ~last:" ") cto1 (* no sep hint*)
+          (core_type ctxt) ct
+    | Pexp_variant (l, None) -> pp f "`%s" l
+    | Pexp_record (l, eo) ->
+        let longident_x_expression f ( li, e) =
+          match e with
+          |  {pexp_desc=Pexp_ident {txt;_};
+              pexp_attributes=[]; _} when li.txt = txt ->
+              pp f "@[<hov2>%a@]" longident_loc li
+          | _ ->
+              pp f "@[<hov2>%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e
+        in
+        pp f "@[<hv0>@[<hv2>{@;%a%a@]@;}@]"(* "@[<hov2>{%a%a}@]" *)
+          (option ~last:" with@;" (simple_expr ctxt)) eo
+          (list longident_x_expression ~sep:";@;") l
+    | Pexp_array (l) ->
+        pp f "@[<0>@[<2>[|%a|]@]@]"
+          (list (simple_expr (under_semi ctxt)) ~sep:";") l
+    | Pexp_while (e1, e2) ->
+        let fmt : (_,_,_) format = "@[<2>while@;%a@;do@;%a@;done@]" in
+        pp f fmt (expression ctxt) e1 (expression ctxt) e2
+    | Pexp_for (s, e1, e2, df, e3) ->
+        let fmt:(_,_,_)format =
+          "@[<hv0>@[<hv2>@[<2>for %a =@;%a@;%a%a@;do@]@;%a@]@;done@]" in
+        let expression = expression ctxt in
+        pp f fmt (pattern ctxt) s expression e1 direction_flag
+          df expression e2 expression e3
+    | _ ->  paren true (expression ctxt) f x
+
+and attributes ctxt f l =
+  List.iter (attribute ctxt f) l
+
+and item_attributes ctxt f l =
+  List.iter (item_attribute ctxt f) l
+
+and attribute ctxt f a =
+  pp f "@[<2>[@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload
+
+and item_attribute ctxt f a =
+  pp f "@[<2>[@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload
+
+and floating_attribute ctxt f a =
+  pp f "@[<2>[@@@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload
+
+and value_description ctxt f x =
+  (* note: value_description has an attribute field,
+           but they're already printed by the callers this method *)
+  pp f "@[<hov2>%a%a@]" (core_type ctxt) x.pval_type
+    (fun f x ->
+       if x.pval_prim <> []
+       then pp f "@ =@ %a" (list constant_string) x.pval_prim
+    ) x
+
+and extension ctxt f (s, e) =
+  pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e
+
+and item_extension ctxt f (s, e) =
+  pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e
+
+and exception_declaration ctxt f x =
+  pp f "@[<hov2>exception@ %a@]%a"
+    (extension_constructor ctxt) x.ptyexn_constructor
+    (item_attributes ctxt) x.ptyexn_attributes
+
+and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} =
+  let class_type_field f x =
+    match x.pctf_desc with
+    | Pctf_inherit (ct) ->
+        pp f "@[<2>inherit@ %a@]%a" (class_type ctxt) ct
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_val (s, mf, vf, ct) ->
+        pp f "@[<2>val @ %a%a%s@ :@ %a@]%a"
+          mutable_flag mf virtual_flag vf s.txt (core_type ctxt) ct
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_method (s, pf, vf, ct) ->
+        pp f "@[<2>method %a %a%s :@;%a@]%a"
+          private_flag pf virtual_flag vf s.txt (core_type ctxt) ct
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_constraint (ct1, ct2) ->
+        pp f "@[<2>constraint@ %a@ =@ %a@]%a"
+          (core_type ctxt) ct1 (core_type ctxt) ct2
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_attribute a -> floating_attribute ctxt f a
+    | Pctf_extension e ->
+        item_extension ctxt f e;
+        item_attributes ctxt f x.pctf_attributes
+  in
+  pp f "@[<hv0>@[<hv2>object@[<1>%a@]@ %a@]@ end@]"
+    (fun f -> function
+         {ptyp_desc=Ptyp_any; ptyp_attributes=[]; _} -> ()
+       | ct -> pp f " (%a)" (core_type ctxt) ct) ct
+    (list class_type_field ~sep:"@;") l
+
+(* call [class_signature] called by [class_signature] *)
+and class_type ctxt f x =
+  match x.pcty_desc with
+  | Pcty_signature cs ->
+      class_signature ctxt f cs;
+      attributes ctxt f x.pcty_attributes
+  | Pcty_constr (li, l) ->
+      pp f "%a%a%a"
+        (fun f l -> match l with
+           | [] -> ()
+           | _  -> pp f "[%a]@ " (list (core_type ctxt) ~sep:"," ) l) l
+        longident_loc li
+        (attributes ctxt) x.pcty_attributes
+  | Pcty_arrow (l, co, cl) ->
+      pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
+        (type_with_label ctxt) (l,co)
+        (class_type ctxt) cl
+  | Pcty_extension e ->
+      extension ctxt f e;
+      attributes ctxt f x.pcty_attributes
+  | Pcty_open (o, e) ->
+      pp f "@[<2>let open%s %a in@;%a@]"
+        (override o.popen_override) longident_loc o.popen_expr
+        (class_type ctxt) e
+
+(* [class type a = object end] *)
+and class_type_declaration_list ctxt f l =
+  let class_type_declaration kwd f x =
+    let { pci_params=ls; pci_name={ txt; _ }; _ } = x in
+    pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd
+      virtual_flag x.pci_virt
+      (class_params_def ctxt) ls txt
+      (class_type ctxt) x.pci_expr
+      (item_attributes ctxt) x.pci_attributes
+  in
+  match l with
+  | [] -> ()
+  | [x] -> class_type_declaration "class type" f x
+  | x :: xs ->
+      pp f "@[<v>%a@,%a@]"
+        (class_type_declaration "class type") x
+        (list ~sep:"@," (class_type_declaration "and")) xs
+
+and class_field ctxt f x =
+  match x.pcf_desc with
+  | Pcf_inherit (ovf, ce, so) ->
+      pp f "@[<2>inherit@ %s@ %a%a@]%a" (override ovf)
+        (class_expr ctxt) ce
+        (fun f so -> match so with
+           | None -> ();
+           | Some (s) -> pp f "@ as %s" s.txt ) so
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_val (s, mf, Cfk_concrete (ovf, e)) ->
+      pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf)
+        mutable_flag mf s.txt
+        (expression ctxt) e
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_method (s, pf, Cfk_virtual ct) ->
+      pp f "@[<2>method virtual %a %s :@;%a@]%a"
+        private_flag pf s.txt
+        (core_type ctxt) ct
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_val (s, mf, Cfk_virtual ct) ->
+      pp f "@[<2>val virtual %a%s :@ %a@]%a"
+        mutable_flag mf s.txt
+        (core_type ctxt) ct
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_method (s, pf, Cfk_concrete (ovf, e)) ->
+      let bind e =
+        binding ctxt f
+          {pvb_pat=
+             {ppat_desc=Ppat_var s;
+              ppat_loc=Location.none;
+              ppat_loc_stack=[];
+              ppat_attributes=[]};
+           pvb_expr=e;
+           pvb_attributes=[];
+           pvb_loc=Location.none;
+          }
+      in
+      pp f "@[<2>method%s %a%a@]%a"
+        (override ovf)
+        private_flag pf
+        (fun f -> function
+           | {pexp_desc=Pexp_poly (e, Some ct); pexp_attributes=[]; _} ->
+               pp f "%s :@;%a=@;%a"
+                 s.txt (core_type ctxt) ct (expression ctxt) e
+           | {pexp_desc=Pexp_poly (e, None); pexp_attributes=[]; _} ->
+               bind e
+           | _ -> bind e) e
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_constraint (ct1, ct2) ->
+      pp f "@[<2>constraint %a =@;%a@]%a"
+        (core_type ctxt) ct1
+        (core_type ctxt) ct2
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_initializer (e) ->
+      pp f "@[<2>initializer@ %a@]%a"
+        (expression ctxt) e
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_attribute a -> floating_attribute ctxt f a
+  | Pcf_extension e ->
+      item_extension ctxt f e;
+      item_attributes ctxt f x.pcf_attributes
+
+and class_structure ctxt f { pcstr_self = p; pcstr_fields =  l } =
+  pp f "@[<hv0>@[<hv2>object%a@;%a@]@;end@]"
+    (fun f p -> match p.ppat_desc with
+       | Ppat_any -> ()
+       | Ppat_constraint _ -> pp f " %a" (pattern ctxt) p
+       | _ -> pp f " (%a)" (pattern ctxt) p) p
+    (list (class_field ctxt)) l
+
+and class_expr ctxt f x =
+  if x.pcl_attributes <> [] then begin
+    pp f "((%a)%a)" (class_expr ctxt) {x with pcl_attributes=[]}
+      (attributes ctxt) x.pcl_attributes
+  end else
+    match x.pcl_desc with
+    | Pcl_structure (cs) -> class_structure ctxt f cs
+    | Pcl_fun (l, eo, p, e) ->
+        pp f "fun@ %a@ ->@ %a"
+          (label_exp ctxt) (l,eo,p)
+          (class_expr ctxt) e
+    | Pcl_let (rf, l, ce) ->
+        pp f "%a@ in@ %a"
+          (bindings ctxt) (rf,l)
+          (class_expr ctxt) ce
+    | Pcl_apply (ce, l) ->
+        pp f "((%a)@ %a)" (* Cf: #7200 *)
+          (class_expr ctxt) ce
+          (list (label_x_expression_param ctxt)) l
+    | Pcl_constr (li, l) ->
+        pp f "%a%a"
+          (fun f l-> if l <>[] then
+              pp f "[%a]@ "
+                (list (core_type ctxt) ~sep:",") l) l
+          longident_loc li
+    | Pcl_constraint (ce, ct) ->
+        pp f "(%a@ :@ %a)"
+          (class_expr ctxt) ce
+          (class_type ctxt) ct
+    | Pcl_extension e -> extension ctxt f e
+    | Pcl_open (o, e) ->
+        pp f "@[<2>let open%s %a in@;%a@]"
+          (override o.popen_override) longident_loc o.popen_expr
+          (class_expr ctxt) e
+
+and module_type ctxt f x =
+  if x.pmty_attributes <> [] then begin
+    pp f "((%a)%a)" (module_type ctxt) {x with pmty_attributes=[]}
+      (attributes ctxt) x.pmty_attributes
+  end else
+    match x.pmty_desc with
+    | Pmty_functor (Unit, mt2) ->
+        pp f "@[<hov2>functor () ->@ %a@]" (module_type ctxt) mt2
+    | Pmty_functor (Named (s, mt1), mt2) ->
+        begin match s.txt with
+        | None ->
+            pp f "@[<hov2>%a@ ->@ %a@]"
+              (module_type1 ctxt) mt1 (module_type ctxt) mt2
+        | Some name ->
+            pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" name
+              (module_type ctxt) mt1 (module_type ctxt) mt2
+        end
+    | Pmty_with (mt, []) -> module_type ctxt f mt
+    | Pmty_with (mt, l) ->
+        let with_constraint f = function
+          | Pwith_type (li, ({ptype_params= ls ;_} as td)) ->
+              let ls = List.map fst ls in
+              pp f "type@ %a %a =@ %a"
+                (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")")
+                ls longident_loc li (type_declaration ctxt) td
+          | Pwith_module (li, li2) ->
+              pp f "module %a =@ %a" longident_loc li longident_loc li2;
+          | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) ->
+              let ls = List.map fst ls in
+              pp f "type@ %a %a :=@ %a"
+                (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")")
+                ls longident_loc li
+                (type_declaration ctxt) td
+          | Pwith_modsubst (li, li2) ->
+             pp f "module %a :=@ %a" longident_loc li longident_loc li2 in
+        pp f "@[<hov2>%a@ with@ %a@]"
+          (module_type1 ctxt) mt (list with_constraint ~sep:"@ and@ ") l
+    | _ -> module_type1 ctxt f x
+
+and module_type1 ctxt f x =
+  if x.pmty_attributes <> [] then module_type ctxt f x
+  else match x.pmty_desc with
+    | Pmty_ident li ->
+        pp f "%a" longident_loc li;
+    | Pmty_alias li ->
+        pp f "(module %a)" longident_loc li;
+    | Pmty_signature (s) ->
+        pp f "@[<hv0>@[<hv2>sig@ %a@]@ end@]" (* "@[<hov>sig@ %a@ end@]" *)
+          (list (signature_item ctxt)) s (* FIXME wrong indentation*)
+    | Pmty_typeof me ->
+        pp f "@[<hov2>module@ type@ of@ %a@]" (module_expr ctxt) me
+    | Pmty_extension e -> extension ctxt f e
+    | _ -> paren true (module_type ctxt) f x
+
+and signature ctxt f x =  list ~sep:"@\n" (signature_item ctxt) f x
+
+and signature_item ctxt f x : unit =
+  match x.psig_desc with
+  | Psig_type (rf, l) ->
+      type_def_list ctxt f (rf, true, l)
+  | Psig_typesubst l ->
+      type_def_list ctxt f (Nonrecursive, false, l)
+  | Psig_value vd ->
+      let intro = if vd.pval_prim = [] then "val" else "external" in
+      pp f "@[<2>%s@ %a@ :@ %a@]%a" intro
+        protect_ident vd.pval_name.txt
+        (value_description ctxt) vd
+        (item_attributes ctxt) vd.pval_attributes
+  | Psig_typext te ->
+      type_extension ctxt f te
+  | Psig_exception ed ->
+      exception_declaration ctxt f ed
+  | Psig_class l ->
+      let class_description kwd f ({pci_params=ls;pci_name={txt;_};_} as x) =
+        pp f "@[<2>%s %a%a%s@;:@;%a@]%a" kwd
+          virtual_flag x.pci_virt
+          (class_params_def ctxt) ls txt
+          (class_type ctxt) x.pci_expr
+          (item_attributes ctxt) x.pci_attributes
+      in begin
+        match l with
+        | [] -> ()
+        | [x] -> class_description "class" f x
+        | x :: xs ->
+            pp f "@[<v>%a@,%a@]"
+              (class_description "class") x
+              (list ~sep:"@," (class_description "and")) xs
+      end
+  | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias;
+                            pmty_attributes=[]; _};_} as pmd) ->
+      pp f "@[<hov>module@ %s@ =@ %a@]%a"
+        (Option.value pmd.pmd_name.txt ~default:"_")
+        longident_loc alias
+        (item_attributes ctxt) pmd.pmd_attributes
+  | Psig_module pmd ->
+      pp f "@[<hov>module@ %s@ :@ %a@]%a"
+        (Option.value pmd.pmd_name.txt ~default:"_")
+        (module_type ctxt) pmd.pmd_type
+        (item_attributes ctxt) pmd.pmd_attributes
+  | Psig_modsubst pms ->
+      pp f "@[<hov>module@ %s@ :=@ %a@]%a" pms.pms_name.txt
+        longident_loc pms.pms_manifest
+        (item_attributes ctxt) pms.pms_attributes
+  | Psig_open od ->
+      pp f "@[<hov2>open%s@ %a@]%a"
+        (override od.popen_override)
+        longident_loc od.popen_expr
+        (item_attributes ctxt) od.popen_attributes
+  | Psig_include incl ->
+      pp f "@[<hov2>include@ %a@]%a"
+        (module_type ctxt) incl.pincl_mod
+        (item_attributes ctxt) incl.pincl_attributes
+  | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
+      pp f "@[<hov2>module@ type@ %s%a@]%a"
+        s.txt
+        (fun f md -> match md with
+           | None -> ()
+           | Some mt ->
+               pp_print_space f () ;
+               pp f "@ =@ %a" (module_type ctxt) mt
+        ) md
+        (item_attributes ctxt) attrs
+  | Psig_class_type (l) -> class_type_declaration_list ctxt f l
+  | Psig_recmodule decls ->
+      let rec  string_x_module_type_list f ?(first=true) l =
+        match l with
+        | [] -> () ;
+        | pmd :: tl ->
+            if not first then
+              pp f "@ @[<hov2>and@ %s:@ %a@]%a"
+                (Option.value pmd.pmd_name.txt ~default:"_")
+                (module_type1 ctxt) pmd.pmd_type
+                (item_attributes ctxt) pmd.pmd_attributes
+            else
+              pp f "@[<hov2>module@ rec@ %s:@ %a@]%a"
+                (Option.value pmd.pmd_name.txt ~default:"_")
+                (module_type1 ctxt) pmd.pmd_type
+                (item_attributes ctxt) pmd.pmd_attributes;
+            string_x_module_type_list f ~first:false tl
+      in
+      string_x_module_type_list f decls
+  | Psig_attribute a -> floating_attribute ctxt f a
+  | Psig_extension(e, a) ->
+      item_extension ctxt f e;
+      item_attributes ctxt f a
+
+and module_expr ctxt f x =
+  if x.pmod_attributes <> [] then
+    pp f "((%a)%a)" (module_expr ctxt) {x with pmod_attributes=[]}
+      (attributes ctxt) x.pmod_attributes
+  else match x.pmod_desc with
+    | Pmod_structure (s) ->
+        pp f "@[<hv2>struct@;@[<0>%a@]@;<1 -2>end@]"
+          (list (structure_item ctxt) ~sep:"@\n") s;
+    | Pmod_constraint (me, mt) ->
+        pp f "@[<hov2>(%a@ :@ %a)@]"
+          (module_expr ctxt) me
+          (module_type ctxt) mt
+    | Pmod_ident (li) ->
+        pp f "%a" longident_loc li;
+    | Pmod_functor (Unit, me) ->
+        pp f "functor ()@;->@;%a" (module_expr ctxt) me
+    | Pmod_functor (Named (s, mt), me) ->
+        pp f "functor@ (%s@ :@ %a)@;->@;%a"
+          (Option.value s.txt ~default:"_")
+          (module_type ctxt) mt (module_expr ctxt) me
+    | Pmod_apply (me1, me2) ->
+        pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2
+        (* Cf: #7200 *)
+    | Pmod_unpack e ->
+        pp f "(val@ %a)" (expression ctxt) e
+    | Pmod_extension e -> extension ctxt f e
+
+and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x
+
+and payload ctxt f = function
+  | PStr [{pstr_desc = Pstr_eval (e, attrs)}] ->
+      pp f "@[<2>%a@]%a"
+        (expression ctxt) e
+        (item_attributes ctxt) attrs
+  | PStr x -> structure ctxt f x
+  | PTyp x -> pp f ":"; core_type ctxt f x
+  | PSig x -> pp f ":"; signature ctxt f x
+  | PPat (x, None) -> pp f "?"; pattern ctxt f x
+  | PPat (x, Some e) ->
+      pp f "?"; pattern ctxt f x;
+      pp f " when "; expression ctxt f e
+
+(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *)
+and binding ctxt f {pvb_pat=p; pvb_expr=x; _} =
+  (* .pvb_attributes have already been printed by the caller, #bindings *)
+  let rec pp_print_pexp_function f x =
+    if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x
+    else match x.pexp_desc with
+      | Pexp_fun (label, eo, p, e) ->
+          if label=Nolabel then
+            pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e
+          else
+            pp f "%a@ %a"
+              (label_exp ctxt) (label,eo,p) pp_print_pexp_function e
+      | Pexp_newtype (str,e) ->
+          pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e
+      | _ -> pp f "=@;%a" (expression ctxt) x
+  in
+  let tyvars_str tyvars = List.map (fun v -> v.txt) tyvars in
+  let is_desugared_gadt p e =
+    let gadt_pattern =
+      match p with
+      | {ppat_desc=Ppat_constraint({ppat_desc=Ppat_var _} as pat,
+                                   {ptyp_desc=Ptyp_poly (args_tyvars, rt)});
+         ppat_attributes=[]}->
+          Some (pat, args_tyvars, rt)
+      | _ -> None in
+    let rec gadt_exp tyvars e =
+      match e with
+      | {pexp_desc=Pexp_newtype (tyvar, e); pexp_attributes=[]} ->
+          gadt_exp (tyvar :: tyvars) e
+      | {pexp_desc=Pexp_constraint (e, ct); pexp_attributes=[]} ->
+          Some (List.rev tyvars, e, ct)
+      | _ -> None in
+    let gadt_exp = gadt_exp [] e in
+    match gadt_pattern, gadt_exp with
+    | Some (p, pt_tyvars, pt_ct), Some (e_tyvars, e, e_ct)
+      when tyvars_str pt_tyvars = tyvars_str e_tyvars ->
+      let ety = Typ.varify_constructors e_tyvars e_ct in
+      if ety = pt_ct then
+      Some (p, pt_tyvars, e_ct, e) else None
+    | _ -> None in
+  if x.pexp_attributes <> []
+  then pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x else
+  match is_desugared_gadt p x with
+  | Some (p, [], ct, e) ->
+      pp f "%a@;: %a@;=@;%a"
+        (simple_pattern ctxt) p (core_type ctxt) ct (expression ctxt) e
+  | Some (p, tyvars, ct, e) -> begin
+    pp f "%a@;: type@;%a.@;%a@;=@;%a"
+    (simple_pattern ctxt) p (list pp_print_string ~sep:"@;")
+    (tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e
+    end
+  | None -> begin
+      match p with
+      | {ppat_desc=Ppat_constraint(p ,ty);
+         ppat_attributes=[]} -> (* special case for the first*)
+          begin match ty with
+          | {ptyp_desc=Ptyp_poly _; ptyp_attributes=[]} ->
+              pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p
+                (core_type ctxt) ty (expression ctxt) x
+          | _ ->
+              pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p
+                (core_type ctxt) ty (expression ctxt) x
+          end
+      | {ppat_desc=Ppat_var _; ppat_attributes=[]} ->
+          pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x
+      | _ ->
+          pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x
+    end
+
+(* [in] is not printed *)
+and bindings ctxt f (rf,l) =
+  let binding kwd rf f x =
+    pp f "@[<2>%s %a%a@]%a" kwd rec_flag rf
+      (binding ctxt) x (item_attributes ctxt) x.pvb_attributes
+  in
+  match l with
+  | [] -> ()
+  | [x] -> binding "let" rf f x
+  | x::xs ->
+      pp f "@[<v>%a@,%a@]"
+        (binding "let" rf) x
+        (list ~sep:"@," (binding "and" Nonrecursive)) xs
+
+and binding_op ctxt f x =
+  pp f "@[<2>%s %a@;=@;%a@]"
+    x.pbop_op.txt (pattern ctxt) x.pbop_pat (expression ctxt) x.pbop_exp
+
+and structure_item ctxt f x =
+  match x.pstr_desc with
+  | Pstr_eval (e, attrs) ->
+      pp f "@[<hov2>;;%a@]%a"
+        (expression ctxt) e
+        (item_attributes ctxt) attrs
+  | Pstr_type (_, []) -> assert false
+  | Pstr_type (rf, l)  -> type_def_list ctxt f (rf, true, l)
+  | Pstr_value (rf, l) ->
+      (* pp f "@[<hov2>let %a%a@]"  rec_flag rf bindings l *)
+      pp f "@[<2>%a@]" (bindings ctxt) (rf,l)
+  | Pstr_typext te -> type_extension ctxt f te
+  | Pstr_exception ed -> exception_declaration ctxt f ed
+  | Pstr_module x ->
+      let rec module_helper = function
+        | {pmod_desc=Pmod_functor(arg_opt,me'); pmod_attributes = []} ->
+            begin match arg_opt with
+            | Unit -> pp f "()"
+            | Named (s, mt) ->
+              pp f "(%s:%a)" (Option.value s.txt ~default:"_")
+                (module_type ctxt) mt
+            end;
+            module_helper me'
+        | me -> me
+      in
+      pp f "@[<hov2>module %s%a@]%a"
+        (Option.value x.pmb_name.txt ~default:"_")
+        (fun f me ->
+           let me = module_helper me in
+           match me with
+           | {pmod_desc=
+                Pmod_constraint
+                  (me',
+                   ({pmty_desc=(Pmty_ident (_)
+                               | Pmty_signature (_));_} as mt));
+              pmod_attributes = []} ->
+               pp f " :@;%a@;=@;%a@;"
+                 (module_type ctxt) mt (module_expr ctxt) me'
+           | _ -> pp f " =@ %a" (module_expr ctxt) me
+        ) x.pmb_expr
+        (item_attributes ctxt) x.pmb_attributes
+  | Pstr_open od ->
+      pp f "@[<2>open%s@;%a@]%a"
+        (override od.popen_override)
+        (module_expr ctxt) od.popen_expr
+        (item_attributes ctxt) od.popen_attributes
+  | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
+      pp f "@[<hov2>module@ type@ %s%a@]%a"
+        s.txt
+        (fun f md -> match md with
+           | None -> ()
+           | Some mt ->
+               pp_print_space f () ;
+               pp f "@ =@ %a" (module_type ctxt) mt
+        ) md
+        (item_attributes ctxt) attrs
+  | Pstr_class l ->
+      let extract_class_args cl =
+        let rec loop acc = function
+          | {pcl_desc=Pcl_fun (l, eo, p, cl'); pcl_attributes = []} ->
+              loop ((l,eo,p) :: acc) cl'
+          | cl -> List.rev acc, cl
+        in
+        let args, cl = loop [] cl in
+        let constr, cl =
+          match cl with
+          | {pcl_desc=Pcl_constraint (cl', ct); pcl_attributes = []} ->
+              Some ct, cl'
+          | _ -> None, cl
+        in
+        args, constr, cl
+      in
+      let class_constraint f ct = pp f ": @[%a@] " (class_type ctxt) ct in
+      let class_declaration kwd f
+          ({pci_params=ls; pci_name={txt;_}; _} as x) =
+        let args, constr, cl = extract_class_args x.pci_expr in
+        pp f "@[<2>%s %a%a%s %a%a=@;%a@]%a" kwd
+          virtual_flag x.pci_virt
+          (class_params_def ctxt) ls txt
+          (list (label_exp ctxt)) args
+          (option class_constraint) constr
+          (class_expr ctxt) cl
+          (item_attributes ctxt) x.pci_attributes
+      in begin
+        match l with
+        | [] -> ()
+        | [x] -> class_declaration "class" f x
+        | x :: xs ->
+            pp f "@[<v>%a@,%a@]"
+              (class_declaration "class") x
+              (list ~sep:"@," (class_declaration "and")) xs
+      end
+  | Pstr_class_type l -> class_type_declaration_list ctxt f l
+  | Pstr_primitive vd ->
+      pp f "@[<hov2>external@ %a@ :@ %a@]%a"
+        protect_ident vd.pval_name.txt
+        (value_description ctxt) vd
+        (item_attributes ctxt) vd.pval_attributes
+  | Pstr_include incl ->
+      pp f "@[<hov2>include@ %a@]%a"
+        (module_expr ctxt) incl.pincl_mod
+        (item_attributes ctxt) incl.pincl_attributes
+  | Pstr_recmodule decls -> (* 3.07 *)
+      let aux f = function
+        | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) ->
+            pp f "@[<hov2>@ and@ %s:%a@ =@ %a@]%a"
+              (Option.value pmb.pmb_name.txt ~default:"_")
+              (module_type ctxt) typ
+              (module_expr ctxt) expr
+              (item_attributes ctxt) pmb.pmb_attributes
+        | pmb ->
+            pp f "@[<hov2>@ and@ %s@ =@ %a@]%a"
+              (Option.value pmb.pmb_name.txt ~default:"_")
+              (module_expr ctxt) pmb.pmb_expr
+              (item_attributes ctxt) pmb.pmb_attributes
+      in
+      begin match decls with
+      | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 ->
+          pp f "@[<hv>@[<hov2>module@ rec@ %s:%a@ =@ %a@]%a@ %a@]"
+            (Option.value pmb.pmb_name.txt ~default:"_")
+            (module_type ctxt) typ
+            (module_expr ctxt) expr
+            (item_attributes ctxt) pmb.pmb_attributes
+            (fun f l2 -> List.iter (aux f) l2) l2
+      | pmb :: l2 ->
+          pp f "@[<hv>@[<hov2>module@ rec@ %s@ =@ %a@]%a@ %a@]"
+            (Option.value pmb.pmb_name.txt ~default:"_")
+            (module_expr ctxt) pmb.pmb_expr
+            (item_attributes ctxt) pmb.pmb_attributes
+            (fun f l2 -> List.iter (aux f) l2) l2
+      | _ -> assert false
+      end
+  | Pstr_attribute a -> floating_attribute ctxt f a
+  | Pstr_extension(e, a) ->
+      item_extension ctxt f e;
+      item_attributes ctxt f a
+
+and type_param ctxt f (ct, a) =
+  pp f "%s%a" (type_variance a) (core_type ctxt) ct
+
+and type_params ctxt f = function
+  | [] -> ()
+  | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l
+
+and type_def_list ctxt f (rf, exported, l) =
+  let type_decl kwd rf f x =
+    let eq =
+      if (x.ptype_kind = Ptype_abstract)
+         && (x.ptype_manifest = None) then ""
+      else if exported then " ="
+      else " :="
+    in
+    pp f "@[<2>%s %a%a%s%s%a@]%a" kwd
+      nonrec_flag rf
+      (type_params ctxt) x.ptype_params
+      x.ptype_name.txt eq
+      (type_declaration ctxt) x
+      (item_attributes ctxt) x.ptype_attributes
+  in
+  match l with
+  | [] -> assert false
+  | [x] -> type_decl "type" rf f x
+  | x :: xs -> pp f "@[<v>%a@,%a@]"
+                 (type_decl "type" rf) x
+                 (list ~sep:"@," (type_decl "and" Recursive)) xs
+
+and record_declaration ctxt f lbls =
+  let type_record_field f pld =
+    pp f "@[<2>%a%s:@;%a@;%a@]"
+      mutable_flag pld.pld_mutable
+      pld.pld_name.txt
+      (core_type ctxt) pld.pld_type
+      (attributes ctxt) pld.pld_attributes
+  in
+  pp f "{@\n%a}"
+    (list type_record_field ~sep:";@\n" )  lbls
+
+and type_declaration ctxt f x =
+  (* type_declaration has an attribute field,
+     but it's been printed by the caller of this method *)
+  let priv f =
+    match x.ptype_private with
+    | Public -> ()
+    | Private -> pp f "@;private"
+  in
+  let manifest f =
+    match x.ptype_manifest with
+    | None -> ()
+    | Some y ->
+        if x.ptype_kind = Ptype_abstract then
+          pp f "%t@;%a" priv (core_type ctxt) y
+        else
+          pp f "@;%a" (core_type ctxt) y
+  in
+  let constructor_declaration f pcd =
+    pp f "|@;";
+    constructor_declaration ctxt f
+      (pcd.pcd_name.txt, pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes)
+  in
+  let repr f =
+    let intro f =
+      if x.ptype_manifest = None then ()
+      else pp f "@;="
+    in
+    match x.ptype_kind with
+    | Ptype_variant xs ->
+      let variants fmt xs =
+        if xs = [] then pp fmt " |" else
+          pp fmt "@\n%a" (list ~sep:"@\n" constructor_declaration) xs
+      in pp f "%t%t%a" intro priv variants xs
+    | Ptype_abstract -> ()
+    | Ptype_record l ->
+        pp f "%t%t@;%a" intro priv (record_declaration ctxt) l
+    | Ptype_open -> pp f "%t%t@;.." intro priv
+  in
+  let constraints f =
+    List.iter
+      (fun (ct1,ct2,_) ->
+         pp f "@[<hov2>@ constraint@ %a@ =@ %a@]"
+           (core_type ctxt) ct1 (core_type ctxt) ct2)
+      x.ptype_cstrs
+  in
+  pp f "%t%t%t" manifest repr constraints
+
+and type_extension ctxt f x =
+  let extension_constructor f x =
+    pp f "@\n|@;%a" (extension_constructor ctxt) x
+  in
+  pp f "@[<2>type %a%a += %a@ %a@]%a"
+    (fun f -> function
+       | [] -> ()
+       | l ->
+           pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l)
+    x.ptyext_params
+    longident_loc x.ptyext_path
+    private_flag x.ptyext_private (* Cf: #7200 *)
+    (list ~sep:"" extension_constructor)
+    x.ptyext_constructors
+    (item_attributes ctxt) x.ptyext_attributes
+
+and constructor_declaration ctxt f (name, args, res, attrs) =
+  let name =
+    match name with
+    | "::" -> "(::)"
+    | s -> s in
+  match res with
+  | None ->
+      pp f "%s%a@;%a" name
+        (fun f -> function
+           | Pcstr_tuple [] -> ()
+           | Pcstr_tuple l ->
+             pp f "@;of@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l
+           | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l
+        ) args
+        (attributes ctxt) attrs
+  | Some r ->
+      pp f "%s:@;%a@;%a" name
+        (fun f -> function
+           | Pcstr_tuple [] -> core_type1 ctxt f r
+           | Pcstr_tuple l -> pp f "%a@;->@;%a"
+                                (list (core_type1 ctxt) ~sep:"@;*@;") l
+                                (core_type1 ctxt) r
+           | Pcstr_record l ->
+               pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r
+        )
+        args
+        (attributes ctxt) attrs
+
+and extension_constructor ctxt f x =
+  (* Cf: #7200 *)
+  match x.pext_kind with
+  | Pext_decl(l, r) ->
+      constructor_declaration ctxt f (x.pext_name.txt, l, r, x.pext_attributes)
+  | Pext_rebind li ->
+      pp f "%s%a@;=@;%a" x.pext_name.txt
+        (attributes ctxt) x.pext_attributes
+        longident_loc li
+
+and case_list ctxt f l : unit =
+  let aux f {pc_lhs; pc_guard; pc_rhs} =
+    pp f "@;| @[<2>%a%a@;->@;%a@]"
+      (pattern ctxt) pc_lhs (option (expression ctxt) ~first:"@;when@;")
+      pc_guard (expression (under_pipe ctxt)) pc_rhs
+  in
+  list aux f l ~sep:""
+
+and label_x_expression_param ctxt f (l,e) =
+  let simple_name = match e with
+    | {pexp_desc=Pexp_ident {txt=Lident l;_};
+       pexp_attributes=[]} -> Some l
+    | _ -> None
+  in match l with
+  | Nolabel  -> expression2 ctxt f e (* level 2*)
+  | Optional str ->
+      if Some str = simple_name then
+        pp f "?%s" str
+      else
+        pp f "?%s:%a" str (simple_expr ctxt) e
+  | Labelled lbl ->
+      if Some lbl = simple_name then
+        pp f "~%s" lbl
+      else
+        pp f "~%s:%a" lbl (simple_expr ctxt) e
+
+and directive_argument f x =
+  match x.pdira_desc with
+  | Pdir_string (s) -> pp f "@ %S" s
+  | Pdir_int (n, None) -> pp f "@ %s" n
+  | Pdir_int (n, Some m) -> pp f "@ %s%c" n m
+  | Pdir_ident (li) -> pp f "@ %a" longident li
+  | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b)
+
+let toplevel_phrase f x =
+  match x with
+  | Ptop_def (s) ->pp f "@[<hov0>%a@]"  (list (structure_item reset_ctxt)) s
+   (* pp_open_hvbox f 0; *)
+   (* pp_print_list structure_item f s ; *)
+   (* pp_close_box f (); *)
+  | Ptop_dir {pdir_name; pdir_arg = None; _} ->
+   pp f "@[<hov2>#%s@]" pdir_name.txt
+  | Ptop_dir {pdir_name; pdir_arg = Some pdir_arg; _} ->
+   pp f "@[<hov2>#%s@ %a@]" pdir_name.txt directive_argument pdir_arg
+
+let expression f x =
+  pp f "@[%a@]" (expression reset_ctxt) x
+
+let string_of_expression x =
+  ignore (flush_str_formatter ()) ;
+  let f = str_formatter in
+  expression f x;
+  flush_str_formatter ()
+
+let string_of_structure x =
+  ignore (flush_str_formatter ());
+  let f = str_formatter in
+  structure reset_ctxt f x;
+  flush_str_formatter ()
+
+let top_phrase f x =
+  pp_print_newline f ();
+  toplevel_phrase f x;
+  pp f ";;";
+  pp_print_newline f ()
+
+let core_type = core_type reset_ctxt
+let pattern = pattern reset_ctxt
+let signature = signature reset_ctxt
+let structure = structure reset_ctxt
diff --git a/upstream/ocaml_411/parsing/pprintast.mli b/upstream/ocaml_411/parsing/pprintast.mli
new file mode 100644
index 0000000..454e60e
--- /dev/null
+++ b/upstream/ocaml_411/parsing/pprintast.mli
@@ -0,0 +1,44 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Hongbo Zhang (University of Pennsylvania)                  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+
+(** Pretty-printers for {!Parsetree}
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type space_formatter = (unit, Format.formatter, unit) format
+
+val longident : Format.formatter -> Longident.t -> unit
+val expression : Format.formatter -> Parsetree.expression -> unit
+val string_of_expression : Parsetree.expression -> string
+
+val pattern: Format.formatter -> Parsetree.pattern -> unit
+
+val core_type: Format.formatter -> Parsetree.core_type -> unit
+
+val signature: Format.formatter -> Parsetree.signature -> unit
+val structure: Format.formatter -> Parsetree.structure -> unit
+val string_of_structure: Parsetree.structure -> string
+
+val toplevel_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit
+val top_phrase: Format.formatter -> Parsetree.toplevel_phrase -> unit
+
+
+val tyvar: Format.formatter -> string -> unit
+  (** Print a type variable name, taking care of the special treatment
+      required for the single quote character in second position. *)
diff --git a/upstream/ocaml_411/parsing/printast.ml b/upstream/ocaml_411/parsing/printast.ml
new file mode 100644
index 0000000..4e3ef2b
--- /dev/null
+++ b/upstream/ocaml_411/parsing/printast.ml
@@ -0,0 +1,965 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*              Damien Doligez, projet Para, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes;;
+open Format;;
+open Lexing;;
+open Location;;
+open Parsetree;;
+
+let fmt_position with_name f l =
+  let fname = if with_name then l.pos_fname else "" in
+  if l.pos_lnum = -1
+  then fprintf f "%s[%d]" fname l.pos_cnum
+  else fprintf f "%s[%d,%d+%d]" fname l.pos_lnum l.pos_bol
+               (l.pos_cnum - l.pos_bol)
+;;
+
+let fmt_location f loc =
+  if not !Clflags.locations then ()
+  else begin
+    let p_2nd_name = loc.loc_start.pos_fname <> loc.loc_end.pos_fname in
+    fprintf f "(%a..%a)" (fmt_position true) loc.loc_start
+                         (fmt_position p_2nd_name) loc.loc_end;
+    if loc.loc_ghost then fprintf f " ghost";
+  end
+;;
+
+let rec fmt_longident_aux f x =
+  match x with
+  | Longident.Lident (s) -> fprintf f "%s" s;
+  | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s;
+  | Longident.Lapply (y, z) ->
+      fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z;
+;;
+
+let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x;;
+
+let fmt_longident_loc f (x : Longident.t loc) =
+  fprintf f "\"%a\" %a" fmt_longident_aux x.txt fmt_location x.loc;
+;;
+
+let fmt_string_loc f (x : string loc) =
+  fprintf f "\"%s\" %a" x.txt fmt_location x.loc;
+;;
+
+let fmt_str_opt_loc f (x : string option loc) =
+  fprintf f "\"%s\" %a" (Option.value x.txt ~default:"_") fmt_location x.loc;
+;;
+
+let fmt_char_option f = function
+  | None -> fprintf f "None"
+  | Some c -> fprintf f "Some %c" c
+
+let fmt_constant f x =
+  match x with
+  | Pconst_integer (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m;
+  | Pconst_char (c) -> fprintf f "PConst_char %02x" (Char.code c);
+  | Pconst_string (s, strloc, None) ->
+      fprintf f "PConst_string(%S,%a,None)" s fmt_location strloc ;
+  | Pconst_string (s, strloc, Some delim) ->
+      fprintf f "PConst_string (%S,%a,Some %S)" s fmt_location strloc delim;
+  | Pconst_float (s,m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m;
+;;
+
+let fmt_mutable_flag f x =
+  match x with
+  | Immutable -> fprintf f "Immutable";
+  | Mutable -> fprintf f "Mutable";
+;;
+
+let fmt_virtual_flag f x =
+  match x with
+  | Virtual -> fprintf f "Virtual";
+  | Concrete -> fprintf f "Concrete";
+;;
+
+let fmt_override_flag f x =
+  match x with
+  | Override -> fprintf f "Override";
+  | Fresh -> fprintf f "Fresh";
+;;
+
+let fmt_closed_flag f x =
+  match x with
+  | Closed -> fprintf f "Closed"
+  | Open -> fprintf f "Open"
+
+let fmt_rec_flag f x =
+  match x with
+  | Nonrecursive -> fprintf f "Nonrec";
+  | Recursive -> fprintf f "Rec";
+;;
+
+let fmt_direction_flag f x =
+  match x with
+  | Upto -> fprintf f "Up";
+  | Downto -> fprintf f "Down";
+;;
+
+let fmt_private_flag f x =
+  match x with
+  | Public -> fprintf f "Public";
+  | Private -> fprintf f "Private";
+;;
+
+let line i f s (*...*) =
+  fprintf f "%s" (String.make ((2*i) mod 72) ' ');
+  fprintf f s (*...*)
+;;
+
+let list i f ppf l =
+  match l with
+  | [] -> line i ppf "[]\n";
+  | _ :: _ ->
+     line i ppf "[\n";
+     List.iter (f (i+1) ppf) l;
+     line i ppf "]\n";
+;;
+
+let option i f ppf x =
+  match x with
+  | None -> line i ppf "None\n";
+  | Some x ->
+      line i ppf "Some\n";
+      f (i+1) ppf x;
+;;
+
+let longident_loc i ppf li = line i ppf "%a\n" fmt_longident_loc li;;
+let string i ppf s = line i ppf "\"%s\"\n" s;;
+let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s;;
+let str_opt_loc i ppf s = line i ppf "%a\n" fmt_str_opt_loc s;;
+let arg_label i ppf = function
+  | Nolabel -> line i ppf "Nolabel\n"
+  | Optional s -> line i ppf "Optional \"%s\"\n" s
+  | Labelled s -> line i ppf "Labelled \"%s\"\n" s
+;;
+
+let rec core_type i ppf x =
+  line i ppf "core_type %a\n" fmt_location x.ptyp_loc;
+  attributes i ppf x.ptyp_attributes;
+  let i = i+1 in
+  match x.ptyp_desc with
+  | Ptyp_any -> line i ppf "Ptyp_any\n";
+  | Ptyp_var (s) -> line i ppf "Ptyp_var %s\n" s;
+  | Ptyp_arrow (l, ct1, ct2) ->
+      line i ppf "Ptyp_arrow\n";
+      arg_label i ppf l;
+      core_type i ppf ct1;
+      core_type i ppf ct2;
+  | Ptyp_tuple l ->
+      line i ppf "Ptyp_tuple\n";
+      list i core_type ppf l;
+  | Ptyp_constr (li, l) ->
+      line i ppf "Ptyp_constr %a\n" fmt_longident_loc li;
+      list i core_type ppf l;
+  | Ptyp_variant (l, closed, low) ->
+      line i ppf "Ptyp_variant closed=%a\n" fmt_closed_flag closed;
+      list i label_x_bool_x_core_type_list ppf l;
+      option i (fun i -> list i string) ppf low
+  | Ptyp_object (l, c) ->
+      line i ppf "Ptyp_object %a\n" fmt_closed_flag c;
+      let i = i + 1 in
+      List.iter (fun field ->
+        match field.pof_desc with
+          | Otag (l, t) ->
+            line i ppf "method %s\n" l.txt;
+            attributes i ppf field.pof_attributes;
+            core_type (i + 1) ppf t
+          | Oinherit ct ->
+              line i ppf "Oinherit\n";
+              core_type (i + 1) ppf ct
+      ) l
+  | Ptyp_class (li, l) ->
+      line i ppf "Ptyp_class %a\n" fmt_longident_loc li;
+      list i core_type ppf l
+  | Ptyp_alias (ct, s) ->
+      line i ppf "Ptyp_alias \"%s\"\n" s;
+      core_type i ppf ct;
+  | Ptyp_poly (sl, ct) ->
+      line i ppf "Ptyp_poly%a\n"
+        (fun ppf ->
+           List.iter (fun x -> fprintf ppf " %a" Pprintast.tyvar x.txt)
+        )
+        sl;
+      core_type i ppf ct;
+  | Ptyp_package (s, l) ->
+      line i ppf "Ptyp_package %a\n" fmt_longident_loc s;
+      list i package_with ppf l;
+  | Ptyp_extension (s, arg) ->
+      line i ppf "Ptyp_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and package_with i ppf (s, t) =
+  line i ppf "with type %a\n" fmt_longident_loc s;
+  core_type i ppf t
+
+and pattern i ppf x =
+  line i ppf "pattern %a\n" fmt_location x.ppat_loc;
+  attributes i ppf x.ppat_attributes;
+  let i = i+1 in
+  match x.ppat_desc with
+  | Ppat_any -> line i ppf "Ppat_any\n";
+  | Ppat_var (s) -> line i ppf "Ppat_var %a\n" fmt_string_loc s;
+  | Ppat_alias (p, s) ->
+      line i ppf "Ppat_alias %a\n" fmt_string_loc s;
+      pattern i ppf p;
+  | Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c;
+  | Ppat_interval (c1, c2) ->
+      line i ppf "Ppat_interval %a..%a\n" fmt_constant c1 fmt_constant c2;
+  | Ppat_tuple (l) ->
+      line i ppf "Ppat_tuple\n";
+      list i pattern ppf l;
+  | Ppat_construct (li, po) ->
+      line i ppf "Ppat_construct %a\n" fmt_longident_loc li;
+      option i pattern ppf po;
+  | Ppat_variant (l, po) ->
+      line i ppf "Ppat_variant \"%s\"\n" l;
+      option i pattern ppf po;
+  | Ppat_record (l, c) ->
+      line i ppf "Ppat_record %a\n" fmt_closed_flag c;
+      list i longident_x_pattern ppf l;
+  | Ppat_array (l) ->
+      line i ppf "Ppat_array\n";
+      list i pattern ppf l;
+  | Ppat_or (p1, p2) ->
+      line i ppf "Ppat_or\n";
+      pattern i ppf p1;
+      pattern i ppf p2;
+  | Ppat_lazy p ->
+      line i ppf "Ppat_lazy\n";
+      pattern i ppf p;
+  | Ppat_constraint (p, ct) ->
+      line i ppf "Ppat_constraint\n";
+      pattern i ppf p;
+      core_type i ppf ct;
+  | Ppat_type (li) ->
+      line i ppf "Ppat_type\n";
+      longident_loc i ppf li
+  | Ppat_unpack s ->
+      line i ppf "Ppat_unpack %a\n" fmt_str_opt_loc s;
+  | Ppat_exception p ->
+      line i ppf "Ppat_exception\n";
+      pattern i ppf p
+  | Ppat_open (m,p) ->
+      line i ppf "Ppat_open \"%a\"\n" fmt_longident_loc m;
+      pattern i ppf p
+  | Ppat_extension (s, arg) ->
+      line i ppf "Ppat_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and expression i ppf x =
+  line i ppf "expression %a\n" fmt_location x.pexp_loc;
+  attributes i ppf x.pexp_attributes;
+  let i = i+1 in
+  match x.pexp_desc with
+  | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li;
+  | Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c;
+  | Pexp_let (rf, l, e) ->
+      line i ppf "Pexp_let %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l;
+      expression i ppf e;
+  | Pexp_function l ->
+      line i ppf "Pexp_function\n";
+      list i case ppf l;
+  | Pexp_fun (l, eo, p, e) ->
+      line i ppf "Pexp_fun\n";
+      arg_label i ppf l;
+      option i expression ppf eo;
+      pattern i ppf p;
+      expression i ppf e;
+  | Pexp_apply (e, l) ->
+      line i ppf "Pexp_apply\n";
+      expression i ppf e;
+      list i label_x_expression ppf l;
+  | Pexp_match (e, l) ->
+      line i ppf "Pexp_match\n";
+      expression i ppf e;
+      list i case ppf l;
+  | Pexp_try (e, l) ->
+      line i ppf "Pexp_try\n";
+      expression i ppf e;
+      list i case ppf l;
+  | Pexp_tuple (l) ->
+      line i ppf "Pexp_tuple\n";
+      list i expression ppf l;
+  | Pexp_construct (li, eo) ->
+      line i ppf "Pexp_construct %a\n" fmt_longident_loc li;
+      option i expression ppf eo;
+  | Pexp_variant (l, eo) ->
+      line i ppf "Pexp_variant \"%s\"\n" l;
+      option i expression ppf eo;
+  | Pexp_record (l, eo) ->
+      line i ppf "Pexp_record\n";
+      list i longident_x_expression ppf l;
+      option i expression ppf eo;
+  | Pexp_field (e, li) ->
+      line i ppf "Pexp_field\n";
+      expression i ppf e;
+      longident_loc i ppf li;
+  | Pexp_setfield (e1, li, e2) ->
+      line i ppf "Pexp_setfield\n";
+      expression i ppf e1;
+      longident_loc i ppf li;
+      expression i ppf e2;
+  | Pexp_array (l) ->
+      line i ppf "Pexp_array\n";
+      list i expression ppf l;
+  | Pexp_ifthenelse (e1, e2, eo) ->
+      line i ppf "Pexp_ifthenelse\n";
+      expression i ppf e1;
+      expression i ppf e2;
+      option i expression ppf eo;
+  | Pexp_sequence (e1, e2) ->
+      line i ppf "Pexp_sequence\n";
+      expression i ppf e1;
+      expression i ppf e2;
+  | Pexp_while (e1, e2) ->
+      line i ppf "Pexp_while\n";
+      expression i ppf e1;
+      expression i ppf e2;
+  | Pexp_for (p, e1, e2, df, e3) ->
+      line i ppf "Pexp_for %a\n" fmt_direction_flag df;
+      pattern i ppf p;
+      expression i ppf e1;
+      expression i ppf e2;
+      expression i ppf e3;
+  | Pexp_constraint (e, ct) ->
+      line i ppf "Pexp_constraint\n";
+      expression i ppf e;
+      core_type i ppf ct;
+  | Pexp_coerce (e, cto1, cto2) ->
+      line i ppf "Pexp_coerce\n";
+      expression i ppf e;
+      option i core_type ppf cto1;
+      core_type i ppf cto2;
+  | Pexp_send (e, s) ->
+      line i ppf "Pexp_send \"%s\"\n" s.txt;
+      expression i ppf e;
+  | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident_loc li;
+  | Pexp_setinstvar (s, e) ->
+      line i ppf "Pexp_setinstvar %a\n" fmt_string_loc s;
+      expression i ppf e;
+  | Pexp_override (l) ->
+      line i ppf "Pexp_override\n";
+      list i string_x_expression ppf l;
+  | Pexp_letmodule (s, me, e) ->
+      line i ppf "Pexp_letmodule %a\n" fmt_str_opt_loc s;
+      module_expr i ppf me;
+      expression i ppf e;
+  | Pexp_letexception (cd, e) ->
+      line i ppf "Pexp_letexception\n";
+      extension_constructor i ppf cd;
+      expression i ppf e;
+  | Pexp_assert (e) ->
+      line i ppf "Pexp_assert\n";
+      expression i ppf e;
+  | Pexp_lazy (e) ->
+      line i ppf "Pexp_lazy\n";
+      expression i ppf e;
+  | Pexp_poly (e, cto) ->
+      line i ppf "Pexp_poly\n";
+      expression i ppf e;
+      option i core_type ppf cto;
+  | Pexp_object s ->
+      line i ppf "Pexp_object\n";
+      class_structure i ppf s
+  | Pexp_newtype (s, e) ->
+      line i ppf "Pexp_newtype \"%s\"\n" s.txt;
+      expression i ppf e
+  | Pexp_pack me ->
+      line i ppf "Pexp_pack\n";
+      module_expr i ppf me
+  | Pexp_open (o, e) ->
+      line i ppf "Pexp_open %a\n" fmt_override_flag o.popen_override;
+      module_expr i ppf o.popen_expr;
+      expression i ppf e
+  | Pexp_letop {let_; ands; body} ->
+      line i ppf "Pexp_letop\n";
+      binding_op i ppf let_;
+      list i binding_op ppf ands;
+      expression i ppf body
+  | Pexp_extension (s, arg) ->
+      line i ppf "Pexp_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+  | Pexp_unreachable ->
+      line i ppf "Pexp_unreachable"
+
+and value_description i ppf x =
+  line i ppf "value_description %a %a\n" fmt_string_loc
+       x.pval_name fmt_location x.pval_loc;
+  attributes i ppf x.pval_attributes;
+  core_type (i+1) ppf x.pval_type;
+  list (i+1) string ppf x.pval_prim
+
+and type_parameter i ppf (x, _variance) = core_type i ppf x
+
+and type_declaration i ppf x =
+  line i ppf "type_declaration %a %a\n" fmt_string_loc x.ptype_name
+       fmt_location x.ptype_loc;
+  attributes i ppf x.ptype_attributes;
+  let i = i+1 in
+  line i ppf "ptype_params =\n";
+  list (i+1) type_parameter ppf x.ptype_params;
+  line i ppf "ptype_cstrs =\n";
+  list (i+1) core_type_x_core_type_x_location ppf x.ptype_cstrs;
+  line i ppf "ptype_kind =\n";
+  type_kind (i+1) ppf x.ptype_kind;
+  line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private;
+  line i ppf "ptype_manifest =\n";
+  option (i+1) core_type ppf x.ptype_manifest
+
+and attribute i ppf k a =
+  line i ppf "%s \"%s\"\n" k a.attr_name.txt;
+  payload i ppf a.attr_payload;
+
+and attributes i ppf l =
+  let i = i + 1 in
+  List.iter (fun a ->
+    line i ppf "attribute \"%s\"\n" a.attr_name.txt;
+    payload (i + 1) ppf a.attr_payload;
+  ) l;
+
+and payload i ppf = function
+  | PStr x -> structure i ppf x
+  | PSig x -> signature i ppf x
+  | PTyp x -> core_type i ppf x
+  | PPat (x, None) -> pattern i ppf x
+  | PPat (x, Some g) ->
+    pattern i ppf x;
+    line i ppf "<when>\n";
+    expression (i + 1) ppf g
+
+
+and type_kind i ppf x =
+  match x with
+  | Ptype_abstract ->
+      line i ppf "Ptype_abstract\n"
+  | Ptype_variant l ->
+      line i ppf "Ptype_variant\n";
+      list (i+1) constructor_decl ppf l;
+  | Ptype_record l ->
+      line i ppf "Ptype_record\n";
+      list (i+1) label_decl ppf l;
+  | Ptype_open ->
+      line i ppf "Ptype_open\n";
+
+and type_extension i ppf x =
+  line i ppf "type_extension\n";
+  attributes i ppf x.ptyext_attributes;
+  let i = i+1 in
+  line i ppf "ptyext_path = %a\n" fmt_longident_loc x.ptyext_path;
+  line i ppf "ptyext_params =\n";
+  list (i+1) type_parameter ppf x.ptyext_params;
+  line i ppf "ptyext_constructors =\n";
+  list (i+1) extension_constructor ppf x.ptyext_constructors;
+  line i ppf "ptyext_private = %a\n" fmt_private_flag x.ptyext_private;
+
+and type_exception i ppf x =
+  line i ppf "type_exception\n";
+  attributes i ppf x.ptyexn_attributes;
+  let i = i+1 in
+  line i ppf "ptyext_constructor =\n";
+  let i = i+1 in
+  extension_constructor i ppf x.ptyexn_constructor
+
+and extension_constructor i ppf x =
+  line i ppf "extension_constructor %a\n" fmt_location x.pext_loc;
+  attributes i ppf x.pext_attributes;
+  let i = i + 1 in
+  line i ppf "pext_name = \"%s\"\n" x.pext_name.txt;
+  line i ppf "pext_kind =\n";
+  extension_constructor_kind (i + 1) ppf x.pext_kind;
+
+and extension_constructor_kind i ppf x =
+  match x with
+      Pext_decl(a, r) ->
+        line i ppf "Pext_decl\n";
+        constructor_arguments (i+1) ppf a;
+        option (i+1) core_type ppf r;
+    | Pext_rebind li ->
+        line i ppf "Pext_rebind\n";
+        line (i+1) ppf "%a\n" fmt_longident_loc li;
+
+and class_type i ppf x =
+  line i ppf "class_type %a\n" fmt_location x.pcty_loc;
+  attributes i ppf x.pcty_attributes;
+  let i = i+1 in
+  match x.pcty_desc with
+  | Pcty_constr (li, l) ->
+      line i ppf "Pcty_constr %a\n" fmt_longident_loc li;
+      list i core_type ppf l;
+  | Pcty_signature (cs) ->
+      line i ppf "Pcty_signature\n";
+      class_signature i ppf cs;
+  | Pcty_arrow (l, co, cl) ->
+      line i ppf "Pcty_arrow\n";
+      arg_label i ppf l;
+      core_type i ppf co;
+      class_type i ppf cl;
+  | Pcty_extension (s, arg) ->
+      line i ppf "Pcty_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+  | Pcty_open (o, e) ->
+      line i ppf "Pcty_open %a %a\n" fmt_override_flag o.popen_override
+        fmt_longident_loc o.popen_expr;
+      class_type i ppf e
+
+and class_signature i ppf cs =
+  line i ppf "class_signature\n";
+  core_type (i+1) ppf cs.pcsig_self;
+  list (i+1) class_type_field ppf cs.pcsig_fields;
+
+and class_type_field i ppf x =
+  line i ppf "class_type_field %a\n" fmt_location x.pctf_loc;
+  let i = i+1 in
+  attributes i ppf x.pctf_attributes;
+  match x.pctf_desc with
+  | Pctf_inherit (ct) ->
+      line i ppf "Pctf_inherit\n";
+      class_type i ppf ct;
+  | Pctf_val (s, mf, vf, ct) ->
+      line i ppf "Pctf_val \"%s\" %a %a\n" s.txt fmt_mutable_flag mf
+           fmt_virtual_flag vf;
+      core_type (i+1) ppf ct;
+  | Pctf_method (s, pf, vf, ct) ->
+      line i ppf "Pctf_method \"%s\" %a %a\n" s.txt fmt_private_flag pf
+           fmt_virtual_flag vf;
+      core_type (i+1) ppf ct;
+  | Pctf_constraint (ct1, ct2) ->
+      line i ppf "Pctf_constraint\n";
+      core_type (i+1) ppf ct1;
+      core_type (i+1) ppf ct2;
+  | Pctf_attribute a ->
+      attribute i ppf "Pctf_attribute" a
+  | Pctf_extension (s, arg) ->
+      line i ppf "Pctf_extension \"%s\"\n" s.txt;
+     payload i ppf arg
+
+and class_description i ppf x =
+  line i ppf "class_description %a\n" fmt_location x.pci_loc;
+  attributes i ppf x.pci_attributes;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.pci_params;
+  line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
+  line i ppf "pci_expr =\n";
+  class_type (i+1) ppf x.pci_expr;
+
+and class_type_declaration i ppf x =
+  line i ppf "class_type_declaration %a\n" fmt_location x.pci_loc;
+  attributes i ppf x.pci_attributes;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.pci_params;
+  line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
+  line i ppf "pci_expr =\n";
+  class_type (i+1) ppf x.pci_expr;
+
+and class_expr i ppf x =
+  line i ppf "class_expr %a\n" fmt_location x.pcl_loc;
+  attributes i ppf x.pcl_attributes;
+  let i = i+1 in
+  match x.pcl_desc with
+  | Pcl_constr (li, l) ->
+      line i ppf "Pcl_constr %a\n" fmt_longident_loc li;
+      list i core_type ppf l;
+  | Pcl_structure (cs) ->
+      line i ppf "Pcl_structure\n";
+      class_structure i ppf cs;
+  | Pcl_fun (l, eo, p, e) ->
+      line i ppf "Pcl_fun\n";
+      arg_label i ppf l;
+      option i expression ppf eo;
+      pattern i ppf p;
+      class_expr i ppf e;
+  | Pcl_apply (ce, l) ->
+      line i ppf "Pcl_apply\n";
+      class_expr i ppf ce;
+      list i label_x_expression ppf l;
+  | Pcl_let (rf, l, ce) ->
+      line i ppf "Pcl_let %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l;
+      class_expr i ppf ce;
+  | Pcl_constraint (ce, ct) ->
+      line i ppf "Pcl_constraint\n";
+      class_expr i ppf ce;
+      class_type i ppf ct;
+  | Pcl_extension (s, arg) ->
+      line i ppf "Pcl_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+  | Pcl_open (o, e) ->
+      line i ppf "Pcl_open %a %a\n" fmt_override_flag o.popen_override
+        fmt_longident_loc o.popen_expr;
+      class_expr i ppf e
+
+and class_structure i ppf { pcstr_self = p; pcstr_fields = l } =
+  line i ppf "class_structure\n";
+  pattern (i+1) ppf p;
+  list (i+1) class_field ppf l;
+
+and class_field i ppf x =
+  line i ppf "class_field %a\n" fmt_location x.pcf_loc;
+  let i = i + 1 in
+  attributes i ppf x.pcf_attributes;
+  match x.pcf_desc with
+  | Pcf_inherit (ovf, ce, so) ->
+      line i ppf "Pcf_inherit %a\n" fmt_override_flag ovf;
+      class_expr (i+1) ppf ce;
+      option (i+1) string_loc ppf so;
+  | Pcf_val (s, mf, k) ->
+      line i ppf "Pcf_val %a\n" fmt_mutable_flag mf;
+      line (i+1) ppf "%a\n" fmt_string_loc s;
+      class_field_kind (i+1) ppf k
+  | Pcf_method (s, pf, k) ->
+      line i ppf "Pcf_method %a\n" fmt_private_flag pf;
+      line (i+1) ppf "%a\n" fmt_string_loc s;
+      class_field_kind (i+1) ppf k
+  | Pcf_constraint (ct1, ct2) ->
+      line i ppf "Pcf_constraint\n";
+      core_type (i+1) ppf ct1;
+      core_type (i+1) ppf ct2;
+  | Pcf_initializer (e) ->
+      line i ppf "Pcf_initializer\n";
+      expression (i+1) ppf e;
+  | Pcf_attribute a ->
+      attribute i ppf "Pcf_attribute" a
+  | Pcf_extension (s, arg) ->
+      line i ppf "Pcf_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and class_field_kind i ppf = function
+  | Cfk_concrete (o, e) ->
+      line i ppf "Concrete %a\n" fmt_override_flag o;
+      expression i ppf e
+  | Cfk_virtual t ->
+      line i ppf "Virtual\n";
+      core_type i ppf t
+
+and class_declaration i ppf x =
+  line i ppf "class_declaration %a\n" fmt_location x.pci_loc;
+  attributes i ppf x.pci_attributes;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.pci_params;
+  line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
+  line i ppf "pci_expr =\n";
+  class_expr (i+1) ppf x.pci_expr;
+
+and module_type i ppf x =
+  line i ppf "module_type %a\n" fmt_location x.pmty_loc;
+  attributes i ppf x.pmty_attributes;
+  let i = i+1 in
+  match x.pmty_desc with
+  | Pmty_ident li -> line i ppf "Pmty_ident %a\n" fmt_longident_loc li;
+  | Pmty_alias li -> line i ppf "Pmty_alias %a\n" fmt_longident_loc li;
+  | Pmty_signature (s) ->
+      line i ppf "Pmty_signature\n";
+      signature i ppf s;
+  | Pmty_functor (Unit, mt2) ->
+      line i ppf "Pmty_functor ()\n";
+      module_type i ppf mt2;
+  | Pmty_functor (Named (s, mt1), mt2) ->
+      line i ppf "Pmty_functor %a\n" fmt_str_opt_loc s;
+      module_type i ppf mt1;
+      module_type i ppf mt2;
+  | Pmty_with (mt, l) ->
+      line i ppf "Pmty_with\n";
+      module_type i ppf mt;
+      list i with_constraint ppf l;
+  | Pmty_typeof m ->
+      line i ppf "Pmty_typeof\n";
+      module_expr i ppf m;
+  | Pmty_extension (s, arg) ->
+      line i ppf "Pmod_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and signature i ppf x = list i signature_item ppf x
+
+and signature_item i ppf x =
+  line i ppf "signature_item %a\n" fmt_location x.psig_loc;
+  let i = i+1 in
+  match x.psig_desc with
+  | Psig_value vd ->
+      line i ppf "Psig_value\n";
+      value_description i ppf vd;
+  | Psig_type (rf, l) ->
+      line i ppf "Psig_type %a\n" fmt_rec_flag rf;
+      list i type_declaration ppf l;
+  | Psig_typesubst l ->
+      line i ppf "Psig_typesubst\n";
+      list i type_declaration ppf l;
+  | Psig_typext te ->
+      line i ppf "Psig_typext\n";
+      type_extension i ppf te
+  | Psig_exception te ->
+      line i ppf "Psig_exception\n";
+      type_exception i ppf te
+  | Psig_module pmd ->
+      line i ppf "Psig_module %a\n" fmt_str_opt_loc pmd.pmd_name;
+      attributes i ppf pmd.pmd_attributes;
+      module_type i ppf pmd.pmd_type
+  | Psig_modsubst pms ->
+      line i ppf "Psig_modsubst %a = %a\n"
+        fmt_string_loc pms.pms_name
+        fmt_longident_loc pms.pms_manifest;
+      attributes i ppf pms.pms_attributes;
+  | Psig_recmodule decls ->
+      line i ppf "Psig_recmodule\n";
+      list i module_declaration ppf decls;
+  | Psig_modtype x ->
+      line i ppf "Psig_modtype %a\n" fmt_string_loc x.pmtd_name;
+      attributes i ppf x.pmtd_attributes;
+      modtype_declaration i ppf x.pmtd_type
+  | Psig_open od ->
+      line i ppf "Psig_open %a %a\n" fmt_override_flag od.popen_override
+        fmt_longident_loc od.popen_expr;
+      attributes i ppf od.popen_attributes
+  | Psig_include incl ->
+      line i ppf "Psig_include\n";
+      module_type i ppf incl.pincl_mod;
+      attributes i ppf incl.pincl_attributes
+  | Psig_class (l) ->
+      line i ppf "Psig_class\n";
+      list i class_description ppf l;
+  | Psig_class_type (l) ->
+      line i ppf "Psig_class_type\n";
+      list i class_type_declaration ppf l;
+  | Psig_extension ((s, arg), attrs) ->
+      line i ppf "Psig_extension \"%s\"\n" s.txt;
+      attributes i ppf attrs;
+      payload i ppf arg
+  | Psig_attribute a ->
+      attribute i ppf "Psig_attribute" a
+
+and modtype_declaration i ppf = function
+  | None -> line i ppf "#abstract"
+  | Some mt -> module_type (i+1) ppf mt
+
+and with_constraint i ppf x =
+  match x with
+  | Pwith_type (lid, td) ->
+      line i ppf "Pwith_type %a\n" fmt_longident_loc lid;
+      type_declaration (i+1) ppf td;
+  | Pwith_typesubst (lid, td) ->
+      line i ppf "Pwith_typesubst %a\n" fmt_longident_loc lid;
+      type_declaration (i+1) ppf td;
+  | Pwith_module (lid1, lid2) ->
+      line i ppf "Pwith_module %a = %a\n"
+        fmt_longident_loc lid1
+        fmt_longident_loc lid2;
+  | Pwith_modsubst (lid1, lid2) ->
+      line i ppf "Pwith_modsubst %a = %a\n"
+        fmt_longident_loc lid1
+        fmt_longident_loc lid2;
+
+and module_expr i ppf x =
+  line i ppf "module_expr %a\n" fmt_location x.pmod_loc;
+  attributes i ppf x.pmod_attributes;
+  let i = i+1 in
+  match x.pmod_desc with
+  | Pmod_ident (li) -> line i ppf "Pmod_ident %a\n" fmt_longident_loc li;
+  | Pmod_structure (s) ->
+      line i ppf "Pmod_structure\n";
+      structure i ppf s;
+  | Pmod_functor (Unit, me) ->
+      line i ppf "Pmod_functor ()\n";
+      module_expr i ppf me;
+  | Pmod_functor (Named (s, mt), me) ->
+      line i ppf "Pmod_functor %a\n" fmt_str_opt_loc s;
+      module_type i ppf mt;
+      module_expr i ppf me;
+  | Pmod_apply (me1, me2) ->
+      line i ppf "Pmod_apply\n";
+      module_expr i ppf me1;
+      module_expr i ppf me2;
+  | Pmod_constraint (me, mt) ->
+      line i ppf "Pmod_constraint\n";
+      module_expr i ppf me;
+      module_type i ppf mt;
+  | Pmod_unpack (e) ->
+      line i ppf "Pmod_unpack\n";
+      expression i ppf e;
+  | Pmod_extension (s, arg) ->
+      line i ppf "Pmod_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and structure i ppf x = list i structure_item ppf x
+
+and structure_item i ppf x =
+  line i ppf "structure_item %a\n" fmt_location x.pstr_loc;
+  let i = i+1 in
+  match x.pstr_desc with
+  | Pstr_eval (e, attrs) ->
+      line i ppf "Pstr_eval\n";
+      attributes i ppf attrs;
+      expression i ppf e;
+  | Pstr_value (rf, l) ->
+      line i ppf "Pstr_value %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l;
+  | Pstr_primitive vd ->
+      line i ppf "Pstr_primitive\n";
+      value_description i ppf vd;
+  | Pstr_type (rf, l) ->
+      line i ppf "Pstr_type %a\n" fmt_rec_flag rf;
+      list i type_declaration ppf l;
+  | Pstr_typext te ->
+      line i ppf "Pstr_typext\n";
+      type_extension i ppf te
+  | Pstr_exception te ->
+      line i ppf "Pstr_exception\n";
+      type_exception i ppf te
+  | Pstr_module x ->
+      line i ppf "Pstr_module\n";
+      module_binding i ppf x
+  | Pstr_recmodule bindings ->
+      line i ppf "Pstr_recmodule\n";
+      list i module_binding ppf bindings;
+  | Pstr_modtype x ->
+      line i ppf "Pstr_modtype %a\n" fmt_string_loc x.pmtd_name;
+      attributes i ppf x.pmtd_attributes;
+      modtype_declaration i ppf x.pmtd_type
+  | Pstr_open od ->
+      line i ppf "Pstr_open %a\n" fmt_override_flag od.popen_override;
+      module_expr i ppf od.popen_expr;
+      attributes i ppf od.popen_attributes
+  | Pstr_class (l) ->
+      line i ppf "Pstr_class\n";
+      list i class_declaration ppf l;
+  | Pstr_class_type (l) ->
+      line i ppf "Pstr_class_type\n";
+      list i class_type_declaration ppf l;
+  | Pstr_include incl ->
+      line i ppf "Pstr_include";
+      attributes i ppf incl.pincl_attributes;
+      module_expr i ppf incl.pincl_mod
+  | Pstr_extension ((s, arg), attrs) ->
+      line i ppf "Pstr_extension \"%s\"\n" s.txt;
+      attributes i ppf attrs;
+      payload i ppf arg
+  | Pstr_attribute a ->
+      attribute i ppf "Pstr_attribute" a
+
+and module_declaration i ppf pmd =
+  str_opt_loc i ppf pmd.pmd_name;
+  attributes i ppf pmd.pmd_attributes;
+  module_type (i+1) ppf pmd.pmd_type;
+
+and module_binding i ppf x =
+  str_opt_loc i ppf x.pmb_name;
+  attributes i ppf x.pmb_attributes;
+  module_expr (i+1) ppf x.pmb_expr
+
+and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
+  line i ppf "<constraint> %a\n" fmt_location l;
+  core_type (i+1) ppf ct1;
+  core_type (i+1) ppf ct2;
+
+and constructor_decl i ppf
+                     {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} =
+  line i ppf "%a\n" fmt_location pcd_loc;
+  line (i+1) ppf "%a\n" fmt_string_loc pcd_name;
+  attributes i ppf pcd_attributes;
+  constructor_arguments (i+1) ppf pcd_args;
+  option (i+1) core_type ppf pcd_res
+
+and constructor_arguments i ppf = function
+  | Pcstr_tuple l -> list i core_type ppf l
+  | Pcstr_record l -> list i label_decl ppf l
+
+and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes}=
+  line i ppf "%a\n" fmt_location pld_loc;
+  attributes i ppf pld_attributes;
+  line (i+1) ppf "%a\n" fmt_mutable_flag pld_mutable;
+  line (i+1) ppf "%a" fmt_string_loc pld_name;
+  core_type (i+1) ppf pld_type
+
+and longident_x_pattern i ppf (li, p) =
+  line i ppf "%a\n" fmt_longident_loc li;
+  pattern (i+1) ppf p;
+
+and case i ppf {pc_lhs; pc_guard; pc_rhs} =
+  line i ppf "<case>\n";
+  pattern (i+1) ppf pc_lhs;
+  begin match pc_guard with
+  | None -> ()
+  | Some g -> line (i+1) ppf "<when>\n"; expression (i + 2) ppf g
+  end;
+  expression (i+1) ppf pc_rhs;
+
+and value_binding i ppf x =
+  line i ppf "<def>\n";
+  attributes (i+1) ppf x.pvb_attributes;
+  pattern (i+1) ppf x.pvb_pat;
+  expression (i+1) ppf x.pvb_expr
+
+and binding_op i ppf x =
+  line i ppf "<binding_op> %a %a"
+    fmt_string_loc x.pbop_op fmt_location x.pbop_loc;
+  pattern (i+1) ppf x.pbop_pat;
+  expression (i+1) ppf x.pbop_exp;
+
+and string_x_expression i ppf (s, e) =
+  line i ppf "<override> %a\n" fmt_string_loc s;
+  expression (i+1) ppf e;
+
+and longident_x_expression i ppf (li, e) =
+  line i ppf "%a\n" fmt_longident_loc li;
+  expression (i+1) ppf e;
+
+and label_x_expression i ppf (l,e) =
+  line i ppf "<arg>\n";
+  arg_label i ppf l;
+  expression (i+1) ppf e;
+
+and label_x_bool_x_core_type_list i ppf x =
+  match x.prf_desc with
+    Rtag (l, b, ctl) ->
+      line i ppf "Rtag \"%s\" %s\n" l.txt (string_of_bool b);
+      attributes (i+1) ppf x.prf_attributes;
+      list (i+1) core_type ppf ctl
+  | Rinherit (ct) ->
+      line i ppf "Rinherit\n";
+      core_type (i+1) ppf ct
+;;
+
+let rec toplevel_phrase i ppf x =
+  match x with
+  | Ptop_def (s) ->
+      line i ppf "Ptop_def\n";
+      structure (i+1) ppf s;
+  | Ptop_dir {pdir_name; pdir_arg; _} ->
+      line i ppf "Ptop_dir \"%s\"\n" pdir_name.txt;
+      match pdir_arg with
+      | None -> ()
+      | Some da -> directive_argument i ppf da;
+
+and directive_argument i ppf x =
+  match x.pdira_desc with
+  | Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s;
+  | Pdir_int (n, None) -> line i ppf "Pdir_int %s\n" n;
+  | Pdir_int (n, Some m) -> line i ppf "Pdir_int %s%c\n" n m;
+  | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident li;
+  | Pdir_bool (b) -> line i ppf "Pdir_bool %s\n" (string_of_bool b);
+;;
+
+let interface ppf x = list 0 signature_item ppf x;;
+
+let implementation ppf x = list 0 structure_item ppf x;;
+
+let top_phrase ppf x = toplevel_phrase 0 ppf x;;
diff --git a/upstream/ocaml_411/parsing/printast.mli b/upstream/ocaml_411/parsing/printast.mli
new file mode 100644
index 0000000..8215654
--- /dev/null
+++ b/upstream/ocaml_411/parsing/printast.mli
@@ -0,0 +1,32 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*              Damien Doligez, projet Para, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Raw printer for {!Parsetree}
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Parsetree;;
+open Format;;
+
+val interface : formatter -> signature_item list -> unit;;
+val implementation : formatter -> structure_item list -> unit;;
+val top_phrase : formatter -> toplevel_phrase -> unit;;
+
+val expression: int -> formatter -> expression -> unit
+val structure: int -> formatter -> structure -> unit
+val payload: int -> formatter -> payload -> unit
diff --git a/upstream/ocaml_411/parsing/syntaxerr.ml b/upstream/ocaml_411/parsing/syntaxerr.ml
new file mode 100644
index 0000000..49372b9
--- /dev/null
+++ b/upstream/ocaml_411/parsing/syntaxerr.ml
@@ -0,0 +1,43 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Auxiliary type for reporting syntax errors *)
+
+type error =
+    Unclosed of Location.t * string * Location.t * string
+  | Expecting of Location.t * string
+  | Not_expecting of Location.t * string
+  | Applicative_path of Location.t
+  | Variable_in_scope of Location.t * string
+  | Other of Location.t
+  | Ill_formed_ast of Location.t * string
+  | Invalid_package_type of Location.t * string
+
+exception Error of error
+exception Escape_error
+
+let location_of_error = function
+  | Unclosed(l,_,_,_)
+  | Applicative_path l
+  | Variable_in_scope(l,_)
+  | Other l
+  | Not_expecting (l, _)
+  | Ill_formed_ast (l, _)
+  | Invalid_package_type (l, _)
+  | Expecting (l, _) -> l
+
+
+let ill_formed_ast loc s =
+  raise (Error (Ill_formed_ast (loc, s)))
diff --git a/upstream/ocaml_411/parsing/syntaxerr.mli b/upstream/ocaml_411/parsing/syntaxerr.mli
new file mode 100644
index 0000000..26ba712
--- /dev/null
+++ b/upstream/ocaml_411/parsing/syntaxerr.mli
@@ -0,0 +1,37 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Auxiliary type for reporting syntax errors
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type error =
+    Unclosed of Location.t * string * Location.t * string
+  | Expecting of Location.t * string
+  | Not_expecting of Location.t * string
+  | Applicative_path of Location.t
+  | Variable_in_scope of Location.t * string
+  | Other of Location.t
+  | Ill_formed_ast of Location.t * string
+  | Invalid_package_type of Location.t * string
+
+exception Error of error
+exception Escape_error
+
+val location_of_error: error -> Location.t
+val ill_formed_ast: Location.t -> string -> 'a
diff --git a/upstream/ocaml_411/typing/annot.mli b/upstream/ocaml_411/typing/annot.mli
new file mode 100644
index 0000000..3cae8f2
--- /dev/null
+++ b/upstream/ocaml_411/typing/annot.mli
@@ -0,0 +1,24 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Data types for annotations (Stypes.ml) *)
+
+type call = Tail | Stack | Inline;;
+
+type ident =
+  | Iref_internal of Location.t (* defining occurrence *)
+  | Iref_external
+  | Idef of Location.t          (* scope *)
+;;
diff --git a/upstream/ocaml_411/typing/btype.ml b/upstream/ocaml_411/typing/btype.ml
new file mode 100644
index 0000000..bec3149
--- /dev/null
+++ b/upstream/ocaml_411/typing/btype.ml
@@ -0,0 +1,820 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Basic operations on core types *)
+
+open Asttypes
+open Types
+
+(**** Sets, maps and hashtables of types ****)
+
+module TypeSet = Set.Make(TypeOps)
+module TypeMap = Map.Make (TypeOps)
+module TypeHash = Hashtbl.Make(TypeOps)
+
+(**** Forward declarations ****)
+
+let print_raw =
+  ref (fun _ -> assert false : Format.formatter -> type_expr -> unit)
+
+(**** Type level management ****)
+
+let generic_level = Ident.highest_scope
+
+(* Used to mark a type during a traversal. *)
+let lowest_level = Ident.lowest_scope
+let pivot_level = 2 * lowest_level - 1
+    (* pivot_level - lowest_level < lowest_level *)
+
+(**** Some type creators ****)
+
+let new_id = ref (-1)
+
+let newty2 level desc  =
+  incr new_id; { desc; level; scope = lowest_level; id = !new_id }
+let newgenty desc      = newty2 generic_level desc
+let newgenvar ?name () = newgenty (Tvar name)
+(*
+let newmarkedvar level =
+  incr new_id; { desc = Tvar; level = pivot_level - level; id = !new_id }
+let newmarkedgenvar () =
+  incr new_id;
+  { desc = Tvar; level = pivot_level - generic_level; id = !new_id }
+*)
+
+(**** Check some types ****)
+
+let is_Tvar = function {desc=Tvar _} -> true | _ -> false
+let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false
+let is_Tconstr = function {desc=Tconstr _} -> true | _ -> false
+
+let dummy_method = "*dummy method*"
+
+(**** Definitions for backtracking ****)
+
+type change =
+    Ctype of type_expr * type_desc
+  | Ccompress of type_expr * type_desc * type_desc
+  | Clevel of type_expr * int
+  | Cscope of type_expr * int
+  | Cname of
+      (Path.t * type_expr list) option ref * (Path.t * type_expr list) option
+  | Crow of row_field option ref * row_field option
+  | Ckind of field_kind option ref * field_kind option
+  | Ccommu of commutable ref * commutable
+  | Cuniv of type_expr option ref * type_expr option
+  | Ctypeset of TypeSet.t ref * TypeSet.t
+
+type changes =
+    Change of change * changes ref
+  | Unchanged
+  | Invalid
+
+let trail = Weak.create 1
+
+let log_change ch =
+  match Weak.get trail 0 with None -> ()
+  | Some r ->
+      let r' = ref Unchanged in
+      r := Change (ch, r');
+      Weak.set trail 0 (Some r')
+
+(**** Representative of a type ****)
+
+let rec field_kind_repr =
+  function
+    Fvar {contents = Some kind} -> field_kind_repr kind
+  | kind                        -> kind
+
+let rec repr_link compress t d =
+ function
+   {desc = Tlink t' as d'} ->
+     repr_link true t d' t'
+ | {desc = Tfield (_, k, _, t') as d'} when field_kind_repr k = Fabsent ->
+     repr_link true t d' t'
+ | t' ->
+     if compress then begin
+       log_change (Ccompress (t, t.desc, d)); t.desc <- d
+     end;
+     t'
+
+let repr t =
+  match t.desc with
+   Tlink t' as d ->
+     repr_link false t d t'
+ | Tfield (_, k, _, t') as d when field_kind_repr k = Fabsent ->
+     repr_link false t d t'
+ | _ -> t
+
+let rec commu_repr = function
+    Clink r when !r <> Cunknown -> commu_repr !r
+  | c -> c
+
+let rec row_field_repr_aux tl = function
+    Reither(_, tl', _, {contents = Some fi}) ->
+      row_field_repr_aux (tl@tl') fi
+  | Reither(c, tl', m, r) ->
+      Reither(c, tl@tl', m, r)
+  | Rpresent (Some _) when tl <> [] ->
+      Rpresent (Some (List.hd tl))
+  | fi -> fi
+
+let row_field_repr fi = row_field_repr_aux [] fi
+
+let rec rev_concat l ll =
+  match ll with
+    [] -> l
+  | l'::ll -> rev_concat (l'@l) ll
+
+let rec row_repr_aux ll row =
+  match (repr row.row_more).desc with
+  | Tvariant row' ->
+      let f = row.row_fields in
+      row_repr_aux (if f = [] then ll else f::ll) row'
+  | _ ->
+      if ll = [] then row else
+      {row with row_fields = rev_concat row.row_fields ll}
+
+let row_repr row = row_repr_aux [] row
+
+let rec row_field tag row =
+  let rec find = function
+    | (tag',f) :: fields ->
+        if tag = tag' then row_field_repr f else find fields
+    | [] ->
+        match repr row.row_more with
+        | {desc=Tvariant row'} -> row_field tag row'
+        | _ -> Rabsent
+  in find row.row_fields
+
+let rec row_more row =
+  match repr row.row_more with
+  | {desc=Tvariant row'} -> row_more row'
+  | ty -> ty
+
+let merge_fixed_explanation fixed1 fixed2 =
+  match fixed1, fixed2 with
+  | Some Univar _ as x, _ | _, (Some Univar _ as x) -> x
+  | Some Fixed_private as x, _ | _, (Some Fixed_private as x) -> x
+  | Some Reified _ as x, _ | _, (Some Reified _ as x) -> x
+  | Some Rigid as x, _ | _, (Some Rigid as x) -> x
+  | None, None -> None
+
+
+let fixed_explanation row =
+  let row = row_repr row in
+  match row.row_fixed with
+  | Some _ as x -> x
+  | None ->
+      let more = repr row.row_more in
+      match more.desc with
+      | Tvar _ | Tnil -> None
+      | Tunivar _ -> Some (Univar more)
+      | Tconstr (p,_,_) -> Some (Reified p)
+      | _ -> assert false
+
+let is_fixed row = match row.row_fixed with
+  | None -> false
+  | Some _ -> true
+
+let row_fixed row = fixed_explanation row <> None
+
+
+let static_row row =
+  let row = row_repr row in
+  row.row_closed &&
+  List.for_all
+    (fun (_,f) -> match row_field_repr f with Reither _ -> false | _ -> true)
+    row.row_fields
+
+let hash_variant s =
+  let accu = ref 0 in
+  for i = 0 to String.length s - 1 do
+    accu := 223 * !accu + Char.code s.[i]
+  done;
+  (* reduce to 31 bits *)
+  accu := !accu land (1 lsl 31 - 1);
+  (* make it signed for 64 bits architectures *)
+  if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu
+
+let proxy ty =
+  let ty0 = repr ty in
+  match ty0.desc with
+  | Tvariant row when not (static_row row) ->
+      row_more row
+  | Tobject (ty, _) ->
+      let rec proxy_obj ty =
+        match ty.desc with
+          Tfield (_, _, _, ty) | Tlink ty -> proxy_obj ty
+        | Tvar _ | Tunivar _ | Tconstr _ -> ty
+        | Tnil -> ty0
+        | _ -> assert false
+      in proxy_obj ty
+  | _ -> ty0
+
+(**** Utilities for fixed row private types ****)
+
+let row_of_type t =
+  match (repr t).desc with
+    Tobject(t,_) ->
+      let rec get_row t =
+        let t = repr t in
+        match t.desc with
+          Tfield(_,_,_,t) -> get_row t
+        | _ -> t
+      in get_row t
+  | Tvariant row ->
+      row_more row
+  | _ ->
+      t
+
+let has_constr_row t =
+  not (is_Tconstr t) && is_Tconstr (row_of_type t)
+
+let is_row_name s =
+  let l = String.length s in
+  if l < 4 then false else String.sub s (l-4) 4 = "#row"
+
+let is_constr_row ~allow_ident t =
+  match t.desc with
+    Tconstr (Path.Pident id, _, _) when allow_ident ->
+      is_row_name (Ident.name id)
+  | Tconstr (Path.Pdot (_, s), _, _) -> is_row_name s
+  | _ -> false
+
+
+                  (**********************************)
+                  (*  Utilities for type traversal  *)
+                  (**********************************)
+
+let rec fold_row f init row =
+  let result =
+    List.fold_left
+      (fun init (_, fi) ->
+         match row_field_repr fi with
+         | Rpresent(Some ty) -> f init ty
+         | Reither(_, tl, _, _) -> List.fold_left f init tl
+         | _ -> init)
+      init
+      row.row_fields
+  in
+  match (repr row.row_more).desc with
+    Tvariant row -> fold_row f result row
+  | Tvar _ | Tunivar _ | Tsubst _ | Tconstr _ | Tnil ->
+    begin match
+      Option.map (fun (_,l) -> List.fold_left f result l) row.row_name
+    with
+    | None -> result
+    | Some result -> result
+    end
+  | _ -> assert false
+
+let iter_row f row =
+  fold_row (fun () v -> f v) () row
+
+let fold_type_expr f init ty =
+  match ty.desc with
+    Tvar _              -> init
+  | Tarrow (_, ty1, ty2, _) ->
+    let result = f init ty1 in
+    f result ty2
+  | Ttuple l            -> List.fold_left f init l
+  | Tconstr (_, l, _)   -> List.fold_left f init l
+  | Tobject(ty, {contents = Some (_, p)})
+    ->
+    let result = f init ty in
+    List.fold_left f result p
+  | Tobject (ty, _)     -> f init ty
+  | Tvariant row        ->
+    let result = fold_row f init row in
+    f result (row_more row)
+  | Tfield (_, _, ty1, ty2) ->
+    let result = f init ty1 in
+    f result ty2
+  | Tnil                -> init
+  | Tlink ty            -> f init ty
+  | Tsubst ty           -> f init ty
+  | Tunivar _           -> init
+  | Tpoly (ty, tyl)     ->
+    let result = f init ty in
+    List.fold_left f result tyl
+  | Tpackage (_, _, l)  -> List.fold_left f init l
+
+let iter_type_expr f ty =
+  fold_type_expr (fun () v -> f v) () ty
+
+let rec iter_abbrev f = function
+    Mnil                   -> ()
+  | Mcons(_, _, ty, ty', rem) -> f ty; f ty'; iter_abbrev f rem
+  | Mlink rem              -> iter_abbrev f !rem
+
+type type_iterators =
+  { it_signature: type_iterators -> signature -> unit;
+    it_signature_item: type_iterators -> signature_item -> unit;
+    it_value_description: type_iterators -> value_description -> unit;
+    it_type_declaration: type_iterators -> type_declaration -> unit;
+    it_extension_constructor: type_iterators -> extension_constructor -> unit;
+    it_module_declaration: type_iterators -> module_declaration -> unit;
+    it_modtype_declaration: type_iterators -> modtype_declaration -> unit;
+    it_class_declaration: type_iterators -> class_declaration -> unit;
+    it_class_type_declaration: type_iterators -> class_type_declaration -> unit;
+    it_functor_param: type_iterators -> functor_parameter -> unit;
+    it_module_type: type_iterators -> module_type -> unit;
+    it_class_type: type_iterators -> class_type -> unit;
+    it_type_kind: type_iterators -> type_kind -> unit;
+    it_do_type_expr: type_iterators -> type_expr -> unit;
+    it_type_expr: type_iterators -> type_expr -> unit;
+    it_path: Path.t -> unit; }
+
+let iter_type_expr_cstr_args f = function
+  | Cstr_tuple tl -> List.iter f tl
+  | Cstr_record lbls -> List.iter (fun d -> f d.ld_type) lbls
+
+let map_type_expr_cstr_args f = function
+  | Cstr_tuple tl -> Cstr_tuple (List.map f tl)
+  | Cstr_record lbls ->
+      Cstr_record (List.map (fun d -> {d with ld_type=f d.ld_type}) lbls)
+
+let iter_type_expr_kind f = function
+  | Type_abstract -> ()
+  | Type_variant cstrs ->
+      List.iter
+        (fun cd ->
+           iter_type_expr_cstr_args f cd.cd_args;
+           Option.iter f cd.cd_res
+        )
+        cstrs
+  | Type_record(lbls, _) ->
+      List.iter (fun d -> f d.ld_type) lbls
+  | Type_open ->
+      ()
+
+
+let type_iterators =
+  let it_signature it =
+    List.iter (it.it_signature_item it)
+  and it_signature_item it = function
+      Sig_value (_, vd, _)          -> it.it_value_description it vd
+    | Sig_type (_, td, _, _)        -> it.it_type_declaration it td
+    | Sig_typext (_, td, _, _)      -> it.it_extension_constructor it td
+    | Sig_module (_, _, md, _, _)   -> it.it_module_declaration it md
+    | Sig_modtype (_, mtd, _)       -> it.it_modtype_declaration it mtd
+    | Sig_class (_, cd, _, _)       -> it.it_class_declaration it cd
+    | Sig_class_type (_, ctd, _, _) -> it.it_class_type_declaration it ctd
+  and it_value_description it vd =
+    it.it_type_expr it vd.val_type
+  and it_type_declaration it td =
+    List.iter (it.it_type_expr it) td.type_params;
+    Option.iter (it.it_type_expr it) td.type_manifest;
+    it.it_type_kind it td.type_kind
+  and it_extension_constructor it td =
+    it.it_path td.ext_type_path;
+    List.iter (it.it_type_expr it) td.ext_type_params;
+    iter_type_expr_cstr_args (it.it_type_expr it) td.ext_args;
+    Option.iter (it.it_type_expr it) td.ext_ret_type
+  and it_module_declaration it md =
+    it.it_module_type it md.md_type
+  and it_modtype_declaration it mtd =
+    Option.iter (it.it_module_type it) mtd.mtd_type
+  and it_class_declaration it cd =
+    List.iter (it.it_type_expr it) cd.cty_params;
+    it.it_class_type it cd.cty_type;
+    Option.iter (it.it_type_expr it) cd.cty_new;
+    it.it_path cd.cty_path
+  and it_class_type_declaration it ctd =
+    List.iter (it.it_type_expr it) ctd.clty_params;
+    it.it_class_type it ctd.clty_type;
+    it.it_path ctd.clty_path
+  and it_functor_param it = function
+    | Unit -> ()
+    | Named (_, mt) -> it.it_module_type it mt
+  and it_module_type it = function
+      Mty_ident p
+    | Mty_alias p -> it.it_path p
+    | Mty_signature sg -> it.it_signature it sg
+    | Mty_functor (p, mt) ->
+        it.it_functor_param it p;
+        it.it_module_type it mt
+  and it_class_type it = function
+      Cty_constr (p, tyl, cty) ->
+        it.it_path p;
+        List.iter (it.it_type_expr it) tyl;
+        it.it_class_type it cty
+    | Cty_signature cs ->
+        it.it_type_expr it cs.csig_self;
+        Vars.iter (fun _ (_,_,ty) -> it.it_type_expr it ty) cs.csig_vars;
+        List.iter
+          (fun (p, tl) -> it.it_path p; List.iter (it.it_type_expr it) tl)
+          cs.csig_inher
+    | Cty_arrow  (_, ty, cty) ->
+        it.it_type_expr it ty;
+        it.it_class_type it cty
+  and it_type_kind it kind =
+    iter_type_expr_kind (it.it_type_expr it) kind
+  and it_do_type_expr it ty =
+    iter_type_expr (it.it_type_expr it) ty;
+    match ty.desc with
+      Tconstr (p, _, _)
+    | Tobject (_, {contents=Some (p, _)})
+    | Tpackage (p, _, _) ->
+        it.it_path p
+    | Tvariant row ->
+        Option.iter (fun (p,_) -> it.it_path p) (row_repr row).row_name
+    | _ -> ()
+  and it_path _p = ()
+  in
+  { it_path; it_type_expr = it_do_type_expr; it_do_type_expr;
+    it_type_kind; it_class_type; it_functor_param; it_module_type;
+    it_signature; it_class_type_declaration; it_class_declaration;
+    it_modtype_declaration; it_module_declaration; it_extension_constructor;
+    it_type_declaration; it_value_description; it_signature_item; }
+
+let copy_row f fixed row keep more =
+  let fields = List.map
+      (fun (l, fi) -> l,
+        match row_field_repr fi with
+        | Rpresent(Some ty) -> Rpresent(Some(f ty))
+        | Reither(c, tl, m, e) ->
+            let e = if keep then e else ref None in
+            let m = if is_fixed row then fixed else m in
+            let tl = List.map f tl in
+            Reither(c, tl, m, e)
+        | _ -> fi)
+      row.row_fields in
+  let name =
+    match row.row_name with
+    | None -> None
+    | Some (path, tl) -> Some (path, List.map f tl) in
+  let row_fixed = if fixed then row.row_fixed else None in
+  { row_fields = fields; row_more = more;
+    row_bound = (); row_fixed;
+    row_closed = row.row_closed; row_name = name; }
+
+let rec copy_kind = function
+    Fvar{contents = Some k} -> copy_kind k
+  | Fvar _   -> Fvar (ref None)
+  | Fpresent -> Fpresent
+  | Fabsent  -> assert false
+
+let copy_commu c =
+  if commu_repr c = Cok then Cok else Clink (ref Cunknown)
+
+(* Since univars may be used as row variables, we need to do some
+   encoding during substitution *)
+let rec norm_univar ty =
+  match ty.desc with
+    Tunivar _ | Tsubst _ -> ty
+  | Tlink ty           -> norm_univar ty
+  | Ttuple (ty :: _)   -> norm_univar ty
+  | _                  -> assert false
+
+let rec copy_type_desc ?(keep_names=false) f = function
+    Tvar _ as ty        -> if keep_names then ty else Tvar None
+  | Tarrow (p, ty1, ty2, c)-> Tarrow (p, f ty1, f ty2, copy_commu c)
+  | Ttuple l            -> Ttuple (List.map f l)
+  | Tconstr (p, l, _)   -> Tconstr (p, List.map f l, ref Mnil)
+  | Tobject(ty, {contents = Some (p, tl)})
+                        -> Tobject (f ty, ref (Some(p, List.map f tl)))
+  | Tobject (ty, _)     -> Tobject (f ty, ref None)
+  | Tvariant _          -> assert false (* too ambiguous *)
+  | Tfield (p, k, ty1, ty2) -> (* the kind is kept shared *)
+      Tfield (p, field_kind_repr k, f ty1, f ty2)
+  | Tnil                -> Tnil
+  | Tlink ty            -> copy_type_desc f ty.desc
+  | Tsubst _            -> assert false
+  | Tunivar _ as ty     -> ty (* always keep the name *)
+  | Tpoly (ty, tyl)     ->
+      let tyl = List.map (fun x -> norm_univar (f x)) tyl in
+      Tpoly (f ty, tyl)
+  | Tpackage (p, n, l)  -> Tpackage (p, n, List.map f l)
+
+(* Utilities for copying *)
+
+module For_copy : sig
+  type copy_scope
+
+  val save_desc: copy_scope -> type_expr -> type_desc -> unit
+
+  val dup_kind: copy_scope -> field_kind option ref -> unit
+
+  val with_scope: (copy_scope -> 'a) -> 'a
+end = struct
+  type copy_scope = {
+    mutable saved_desc : (type_expr * type_desc) list;
+    (* Save association of generic nodes with their description. *)
+
+    mutable saved_kinds: field_kind option ref list;
+    (* duplicated kind variables *)
+
+    mutable new_kinds  : field_kind option ref list;
+    (* new kind variables *)
+  }
+
+  let save_desc copy_scope ty desc =
+    copy_scope.saved_desc <- (ty, desc) :: copy_scope.saved_desc
+
+  let dup_kind copy_scope r =
+    assert (Option.is_none !r);
+    if not (List.memq r copy_scope.new_kinds) then begin
+      copy_scope.saved_kinds <- r :: copy_scope.saved_kinds;
+      let r' = ref None in
+      copy_scope.new_kinds <- r' :: copy_scope.new_kinds;
+      r := Some (Fvar r')
+    end
+
+  (* Restore type descriptions. *)
+  let cleanup { saved_desc; saved_kinds; _ } =
+    List.iter (fun (ty, desc) -> ty.desc <- desc) saved_desc;
+    List.iter (fun r -> r := None) saved_kinds
+
+  let with_scope f =
+    let scope = { saved_desc = []; saved_kinds = []; new_kinds = [] } in
+    let res = f scope in
+    cleanup scope;
+    res
+end
+
+(* Mark a type. *)
+let rec mark_type ty =
+  let ty = repr ty in
+  if ty.level >= lowest_level then begin
+    ty.level <- pivot_level - ty.level;
+    iter_type_expr mark_type ty
+  end
+
+let mark_type_node ty =
+  let ty = repr ty in
+  if ty.level >= lowest_level then begin
+    ty.level <- pivot_level - ty.level;
+  end
+
+let mark_type_params ty =
+  iter_type_expr mark_type ty
+
+let type_iterators =
+  let it_type_expr it ty =
+    let ty = repr ty in
+    if ty.level >= lowest_level then begin
+      mark_type_node ty;
+      it.it_do_type_expr it ty;
+    end
+  in
+  {type_iterators with it_type_expr}
+
+
+(* Remove marks from a type. *)
+let rec unmark_type ty =
+  let ty = repr ty in
+  if ty.level < lowest_level then begin
+    ty.level <- pivot_level - ty.level;
+    iter_type_expr unmark_type ty
+  end
+
+let unmark_iterators =
+  let it_type_expr _it ty = unmark_type ty in
+  {type_iterators with it_type_expr}
+
+let unmark_type_decl decl =
+  unmark_iterators.it_type_declaration unmark_iterators decl
+
+let unmark_extension_constructor ext =
+  List.iter unmark_type ext.ext_type_params;
+  iter_type_expr_cstr_args unmark_type ext.ext_args;
+  Option.iter unmark_type ext.ext_ret_type
+
+let unmark_class_signature sign =
+  unmark_type sign.csig_self;
+  Vars.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_vars
+
+let unmark_class_type cty =
+  unmark_iterators.it_class_type unmark_iterators cty
+
+
+                  (*******************************************)
+                  (*  Memorization of abbreviation expansion *)
+                  (*******************************************)
+
+(* Search whether the expansion has been memorized. *)
+
+let lte_public p1 p2 =  (* Private <= Public *)
+  match p1, p2 with
+  | Private, _ | _, Public -> true
+  | Public, Private -> false
+
+let rec find_expans priv p1 = function
+    Mnil -> None
+  | Mcons (priv', p2, _ty0, ty, _)
+    when lte_public priv priv' && Path.same p1 p2 -> Some ty
+  | Mcons (_, _, _, _, rem)   -> find_expans priv p1 rem
+  | Mlink {contents = rem} -> find_expans priv p1 rem
+
+(* debug: check for cycles in abbreviation. only works with -principal
+let rec check_expans visited ty =
+  let ty = repr ty in
+  assert (not (List.memq ty visited));
+  match ty.desc with
+    Tconstr (path, args, abbrev) ->
+      begin match find_expans path !abbrev with
+        Some ty' -> check_expans (ty :: visited) ty'
+      | None -> ()
+      end
+  | _ -> ()
+*)
+
+let memo = ref []
+        (* Contains the list of saved abbreviation expansions. *)
+
+let cleanup_abbrev () =
+        (* Remove all memorized abbreviation expansions. *)
+  List.iter (fun abbr -> abbr := Mnil) !memo;
+  memo := []
+
+let memorize_abbrev mem priv path v v' =
+        (* Memorize the expansion of an abbreviation. *)
+  mem := Mcons (priv, path, v, v', !mem);
+  (* check_expans [] v; *)
+  memo := mem :: !memo
+
+let rec forget_abbrev_rec mem path =
+  match mem with
+    Mnil ->
+      mem
+  | Mcons (_, path', _, _, rem) when Path.same path path' ->
+      rem
+  | Mcons (priv, path', v, v', rem) ->
+      Mcons (priv, path', v, v', forget_abbrev_rec rem path)
+  | Mlink mem' ->
+      mem' := forget_abbrev_rec !mem' path;
+      raise Exit
+
+let forget_abbrev mem path =
+  try mem := forget_abbrev_rec !mem path with Exit -> ()
+
+(* debug: check for invalid abbreviations
+let rec check_abbrev_rec = function
+    Mnil -> true
+  | Mcons (_, ty1, ty2, rem) ->
+      repr ty1 != repr ty2
+  | Mlink mem' ->
+      check_abbrev_rec !mem'
+
+let check_memorized_abbrevs () =
+  List.for_all (fun mem -> check_abbrev_rec !mem) !memo
+*)
+
+                  (**********************************)
+                  (*  Utilities for labels          *)
+                  (**********************************)
+
+let is_optional = function Optional _ -> true | _ -> false
+
+let label_name = function
+    Nolabel -> ""
+  | Labelled s
+  | Optional s -> s
+
+let prefixed_label_name = function
+    Nolabel -> ""
+  | Labelled s -> "~" ^ s
+  | Optional s -> "?" ^ s
+
+let rec extract_label_aux hd l = function
+  | [] -> None
+  | (l',t as p) :: ls ->
+      if label_name l' = l then
+        Some (l', t, hd <> [], List.rev_append hd ls)
+      else
+        extract_label_aux (p::hd) l ls
+
+let extract_label l ls = extract_label_aux [] l ls
+
+
+                  (**********************************)
+                  (*  Utilities for backtracking    *)
+                  (**********************************)
+
+let undo_change = function
+    Ctype  (ty, desc) -> ty.desc <- desc
+  | Ccompress  (ty, desc, _) -> ty.desc <- desc
+  | Clevel (ty, level) -> ty.level <- level
+  | Cscope (ty, scope) -> ty.scope <- scope
+  | Cname  (r, v) -> r := v
+  | Crow   (r, v) -> r := v
+  | Ckind  (r, v) -> r := v
+  | Ccommu (r, v) -> r := v
+  | Cuniv  (r, v) -> r := v
+  | Ctypeset (r, v) -> r := v
+
+type snapshot = changes ref * int
+let last_snapshot = ref 0
+
+let log_type ty =
+  if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc))
+let link_type ty ty' =
+  log_type ty;
+  let desc = ty.desc in
+  ty.desc <- Tlink ty';
+  (* Name is a user-supplied name for this unification variable (obtained
+   * through a type annotation for instance). *)
+  match desc, ty'.desc with
+    Tvar name, Tvar name' ->
+      begin match name, name' with
+      | Some _, None ->  log_type ty'; ty'.desc <- Tvar name
+      | None, Some _ ->  ()
+      | Some _, Some _ ->
+          if ty.level < ty'.level then (log_type ty'; ty'.desc <- Tvar name)
+      | None, None   ->  ()
+      end
+  | _ -> ()
+  (* ; assert (check_memorized_abbrevs ()) *)
+  (*  ; check_expans [] ty' *)
+let set_type_desc ty td =
+  if td != ty.desc then begin
+    log_type ty;
+    ty.desc <- td
+  end
+let set_level ty level =
+  if level <> ty.level then begin
+    if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level));
+    ty.level <- level
+  end
+let set_scope ty scope =
+  if scope <> ty.scope then begin
+    if ty.id <= !last_snapshot then log_change (Cscope (ty, ty.scope));
+    ty.scope <- scope
+  end
+let set_univar rty ty =
+  log_change (Cuniv (rty, !rty)); rty := Some ty
+let set_name nm v =
+  log_change (Cname (nm, !nm)); nm := v
+let set_row_field e v =
+  log_change (Crow (e, !e)); e := Some v
+let set_kind rk k =
+  log_change (Ckind (rk, !rk)); rk := Some k
+let set_commu rc c =
+  log_change (Ccommu (rc, !rc)); rc := c
+let set_typeset rs s =
+  log_change (Ctypeset (rs, !rs)); rs := s
+
+let snapshot () =
+  let old = !last_snapshot in
+  last_snapshot := !new_id;
+  match Weak.get trail 0 with Some r -> (r, old)
+  | None ->
+      let r = ref Unchanged in
+      Weak.set trail 0 (Some r);
+      (r, old)
+
+let rec rev_log accu = function
+    Unchanged -> accu
+  | Invalid -> assert false
+  | Change (ch, next) ->
+      let d = !next in
+      next := Invalid;
+      rev_log (ch::accu) d
+
+let backtrack (changes, old) =
+  match !changes with
+    Unchanged -> last_snapshot := old
+  | Invalid -> failwith "Btype.backtrack"
+  | Change _ as change ->
+      cleanup_abbrev ();
+      let backlog = rev_log [] change in
+      List.iter undo_change backlog;
+      changes := Unchanged;
+      last_snapshot := old;
+      Weak.set trail 0 (Some changes)
+
+let rec rev_compress_log log r =
+  match !r with
+    Unchanged | Invalid ->
+      log
+  | Change (Ccompress _, next) ->
+      rev_compress_log (r::log) next
+  | Change (_, next) ->
+      rev_compress_log log next
+
+let undo_compress (changes, _old) =
+  match !changes with
+    Unchanged
+  | Invalid -> ()
+  | Change _ ->
+      let log = rev_compress_log [] changes in
+      List.iter
+        (fun r -> match !r with
+          Change (Ccompress (ty, desc, d), next) when ty.desc == d ->
+            ty.desc <- desc; r := !next
+        | _ -> ())
+        log
diff --git a/upstream/ocaml_411/typing/btype.mli b/upstream/ocaml_411/typing/btype.mli
new file mode 100644
index 0000000..7c215ed
--- /dev/null
+++ b/upstream/ocaml_411/typing/btype.mli
@@ -0,0 +1,255 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Basic operations on core types *)
+
+open Asttypes
+open Types
+
+(**** Sets, maps and hashtables of types ****)
+
+module TypeSet  : Set.S with type elt = type_expr
+module TypeMap  : Map.S with type key = type_expr
+module TypeHash : Hashtbl.S with type key = type_expr
+
+(**** Levels ****)
+
+val generic_level: int
+
+val newty2: int -> type_desc -> type_expr
+        (* Create a type *)
+val newgenty: type_desc -> type_expr
+        (* Create a generic type *)
+val newgenvar: ?name:string -> unit -> type_expr
+        (* Return a fresh generic variable *)
+
+(* Use Tsubst instead
+val newmarkedvar: int -> type_expr
+        (* Return a fresh marked variable *)
+val newmarkedgenvar: unit -> type_expr
+        (* Return a fresh marked generic variable *)
+*)
+
+(**** Types ****)
+
+val is_Tvar: type_expr -> bool
+val is_Tunivar: type_expr -> bool
+val is_Tconstr: type_expr -> bool
+val dummy_method: label
+
+val repr: type_expr -> type_expr
+        (* Return the canonical representative of a type. *)
+
+val field_kind_repr: field_kind -> field_kind
+        (* Return the canonical representative of an object field
+           kind. *)
+
+val commu_repr: commutable -> commutable
+        (* Return the canonical representative of a commutation lock *)
+
+(**** polymorphic variants ****)
+
+val row_repr: row_desc -> row_desc
+        (* Return the canonical representative of a row description *)
+val row_field_repr: row_field -> row_field
+val row_field: label -> row_desc -> row_field
+        (* Return the canonical representative of a row field *)
+val row_more: row_desc -> type_expr
+        (* Return the extension variable of the row *)
+
+val is_fixed: row_desc -> bool
+(* Return whether the row is directly marked as fixed or not *)
+
+val row_fixed: row_desc -> bool
+(* Return whether the row should be treated as fixed or not.
+   In particular, [is_fixed row] implies [row_fixed row].
+*)
+
+val fixed_explanation: row_desc -> fixed_explanation option
+(* Return the potential explanation for the fixed row *)
+
+val merge_fixed_explanation:
+  fixed_explanation option -> fixed_explanation option
+  -> fixed_explanation option
+(* Merge two explanations for a fixed row *)
+
+val static_row: row_desc -> bool
+        (* Return whether the row is static or not *)
+val hash_variant: label -> int
+        (* Hash function for variant tags *)
+
+val proxy: type_expr -> type_expr
+        (* Return the proxy representative of the type: either itself
+           or a row variable *)
+
+(**** Utilities for private abbreviations with fixed rows ****)
+val row_of_type: type_expr -> type_expr
+val has_constr_row: type_expr -> bool
+val is_row_name: string -> bool
+val is_constr_row: allow_ident:bool -> type_expr -> bool
+
+(**** Utilities for type traversal ****)
+
+val iter_type_expr: (type_expr -> unit) -> type_expr -> unit
+        (* Iteration on types *)
+val fold_type_expr: ('a -> type_expr -> 'a) -> 'a -> type_expr -> 'a
+val iter_row: (type_expr -> unit) -> row_desc -> unit
+        (* Iteration on types in a row *)
+val fold_row: ('a -> type_expr -> 'a) -> 'a -> row_desc -> 'a
+val iter_abbrev: (type_expr -> unit) -> abbrev_memo -> unit
+        (* Iteration on types in an abbreviation list *)
+
+type type_iterators =
+  { it_signature: type_iterators -> signature -> unit;
+    it_signature_item: type_iterators -> signature_item -> unit;
+    it_value_description: type_iterators -> value_description -> unit;
+    it_type_declaration: type_iterators -> type_declaration -> unit;
+    it_extension_constructor: type_iterators -> extension_constructor -> unit;
+    it_module_declaration: type_iterators -> module_declaration -> unit;
+    it_modtype_declaration: type_iterators -> modtype_declaration -> unit;
+    it_class_declaration: type_iterators -> class_declaration -> unit;
+    it_class_type_declaration: type_iterators -> class_type_declaration -> unit;
+    it_functor_param: type_iterators -> functor_parameter -> unit;
+    it_module_type: type_iterators -> module_type -> unit;
+    it_class_type: type_iterators -> class_type -> unit;
+    it_type_kind: type_iterators -> type_kind -> unit;
+    it_do_type_expr: type_iterators -> type_expr -> unit;
+    it_type_expr: type_iterators -> type_expr -> unit;
+    it_path: Path.t -> unit; }
+val type_iterators: type_iterators
+        (* Iteration on arbitrary type information.
+           [it_type_expr] calls [mark_type_node] to avoid loops. *)
+val unmark_iterators: type_iterators
+        (* Unmark any structure containing types. See [unmark_type] below. *)
+
+val copy_type_desc:
+    ?keep_names:bool -> (type_expr -> type_expr) -> type_desc -> type_desc
+        (* Copy on types *)
+val copy_row:
+    (type_expr -> type_expr) ->
+    bool -> row_desc -> bool -> type_expr -> row_desc
+val copy_kind: field_kind -> field_kind
+
+module For_copy : sig
+
+  type copy_scope
+        (* The private state that the primitives below are mutating, it should
+           remain scoped within a single [with_scope] call.
+
+           While it is possible to circumvent that discipline in various
+           ways, you should NOT do that. *)
+
+  val save_desc: copy_scope -> type_expr -> type_desc -> unit
+        (* Save a type description *)
+
+  val dup_kind: copy_scope -> field_kind option ref -> unit
+        (* Save a None field_kind, and make it point to a fresh Fvar *)
+
+  val with_scope: (copy_scope -> 'a) -> 'a
+        (* [with_scope f] calls [f] and restores saved type descriptions
+           before returning its result. *)
+end
+
+val lowest_level: int
+        (* Marked type: ty.level < lowest_level *)
+val pivot_level: int
+        (* Type marking: ty.level <- pivot_level - ty.level *)
+val mark_type: type_expr -> unit
+        (* Mark a type *)
+val mark_type_node: type_expr -> unit
+        (* Mark a type node (but not its sons) *)
+val mark_type_params: type_expr -> unit
+        (* Mark the sons of a type node *)
+val unmark_type: type_expr -> unit
+val unmark_type_decl: type_declaration -> unit
+val unmark_extension_constructor: extension_constructor -> unit
+val unmark_class_type: class_type -> unit
+val unmark_class_signature: class_signature -> unit
+        (* Remove marks from a type *)
+
+(**** Memorization of abbreviation expansion ****)
+
+val find_expans: private_flag -> Path.t -> abbrev_memo -> type_expr option
+        (* Look up a memorized abbreviation *)
+val cleanup_abbrev: unit -> unit
+        (* Flush the cache of abbreviation expansions.
+           When some types are saved (using [output_value]), this
+           function MUST be called just before. *)
+val memorize_abbrev:
+        abbrev_memo ref ->
+        private_flag -> Path.t -> type_expr -> type_expr -> unit
+        (* Add an expansion in the cache *)
+val forget_abbrev:
+        abbrev_memo ref -> Path.t -> unit
+        (* Remove an abbreviation from the cache *)
+
+(**** Utilities for labels ****)
+
+val is_optional : arg_label -> bool
+val label_name : arg_label -> label
+
+(* Returns the label name with first character '?' or '~' as appropriate. *)
+val prefixed_label_name : arg_label -> label
+
+val extract_label :
+    label -> (arg_label * 'a) list ->
+    (arg_label * 'a * bool * (arg_label * 'a) list) option
+(* actual label,
+   value,
+   whether (label, value) was at the head of the list,
+   list without the extracted (label, value) *)
+
+(**** Utilities for backtracking ****)
+
+type snapshot
+        (* A snapshot for backtracking *)
+val snapshot: unit -> snapshot
+        (* Make a snapshot for later backtracking. Costs nothing *)
+val backtrack: snapshot -> unit
+        (* Backtrack to a given snapshot. Only possible if you have
+           not already backtracked to a previous snapshot.
+           Calls [cleanup_abbrev] internally *)
+val undo_compress: snapshot -> unit
+        (* Backtrack only path compression. Only meaningful if you have
+           not already backtracked to a previous snapshot.
+           Does not call [cleanup_abbrev] *)
+
+(* Functions to use when modifying a type (only Ctype?) *)
+val link_type: type_expr -> type_expr -> unit
+        (* Set the desc field of [t1] to [Tlink t2], logging the old
+           value if there is an active snapshot *)
+val set_type_desc: type_expr -> type_desc -> unit
+        (* Set directly the desc field, without sharing *)
+val set_level: type_expr -> int -> unit
+val set_scope: type_expr -> int -> unit
+val set_name:
+    (Path.t * type_expr list) option ref ->
+    (Path.t * type_expr list) option -> unit
+val set_row_field: row_field option ref -> row_field -> unit
+val set_univar: type_expr option ref -> type_expr -> unit
+val set_kind: field_kind option ref -> field_kind -> unit
+val set_commu: commutable ref -> commutable -> unit
+val set_typeset: TypeSet.t ref -> TypeSet.t -> unit
+        (* Set references, logging the old value *)
+
+(**** Forward declarations ****)
+val print_raw: (Format.formatter -> type_expr -> unit) ref
+
+val iter_type_expr_kind: (type_expr -> unit) -> (type_kind -> unit)
+
+val iter_type_expr_cstr_args: (type_expr -> unit) ->
+  (constructor_arguments -> unit)
+val map_type_expr_cstr_args: (type_expr -> type_expr) ->
+  (constructor_arguments -> constructor_arguments)
diff --git a/upstream/ocaml_411/typing/ctype.ml b/upstream/ocaml_411/typing/ctype.ml
new file mode 100644
index 0000000..1033097
--- /dev/null
+++ b/upstream/ocaml_411/typing/ctype.ml
@@ -0,0 +1,4847 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Operations on core types *)
+
+open Misc
+open Asttypes
+open Types
+open Btype
+
+(*
+   Type manipulation after type inference
+   ======================================
+   If one wants to manipulate a type after type inference (for
+   instance, during code generation or in the debugger), one must
+   first make sure that the type levels are correct, using the
+   function [correct_levels]. Then, this type can be correctly
+   manipulated by [apply], [expand_head] and [moregeneral].
+*)
+
+(*
+   General notes
+   =============
+   - As much sharing as possible should be kept : it makes types
+     smaller and better abbreviated.
+     When necessary, some sharing can be lost. Types will still be
+     printed correctly (+++ TO DO...), and abbreviations defined by a
+     class do not depend on sharing thanks to constrained
+     abbreviations. (Of course, even if some sharing is lost, typing
+     will still be correct.)
+   - All nodes of a type have a level : that way, one know whether a
+     node need to be duplicated or not when instantiating a type.
+   - Levels of a type are decreasing (generic level being considered
+     as greatest).
+   - The level of a type constructor is superior to the binding
+     time of its path.
+   - Recursive types without limitation should be handled (even if
+     there is still an occur check). This avoid treating specially the
+     case for objects, for instance. Furthermore, the occur check
+     policy can then be easily changed.
+*)
+
+(**** Errors ****)
+
+module Unification_trace = struct
+
+  type position = First | Second
+  let swap_position = function
+    | First -> Second
+    | Second -> First
+
+  type desc = { t: type_expr; expanded: type_expr option }
+  type 'a diff = { got: 'a; expected: 'a}
+
+  type 'a escape =
+    | Constructor of Path.t
+    | Univ of type_expr
+    (* The type_expr argument of [Univ] is always a [Tunivar _],
+       we keep a [type_expr] to track renaming in {!Printtyp} *)
+    | Self
+    | Module_type of Path.t
+    | Equation of 'a
+
+  type fixed_row_case =
+    | Cannot_be_closed
+    | Cannot_add_tags of string list
+
+  type variant =
+    | No_intersection
+    | No_tags of position * (Asttypes.label * row_field) list
+    | Incompatible_types_for of string
+    | Fixed_row of position * fixed_row_case * fixed_explanation
+
+
+  type obj =
+    | Missing_field of position * string
+    | Abstract_row of position
+    | Self_cannot_be_closed
+
+  type 'a elt =
+    | Diff of 'a diff
+    | Variant of variant
+    | Obj of obj
+    | Escape of {context:type_expr option; kind: 'a escape}
+    | Incompatible_fields of {name:string; diff:type_expr diff }
+    | Rec_occur of type_expr * type_expr
+
+  type t = desc elt list
+  let short t = { t; expanded = None }
+  let map_diff f r =
+    (* ordering is often meaningful when dealing with type_expr *)
+    let got = f r.got in
+    let expected = f r.expected in
+    { got; expected}
+  let diff got expected = Diff (map_diff short {got;expected})
+
+  let map_elt f = function
+    | Diff x -> Diff (map_diff f x)
+    | Escape {kind=Equation x; context} -> Escape {kind=Equation(f x); context}
+    | Rec_occur (_,_)
+    | Escape {kind=(Univ _ | Self|Constructor _ | Module_type _ ); _}
+    | Variant _ | Obj _
+    | Incompatible_fields _ as x -> x
+  let map f = List.map (map_elt f)
+
+
+  (* Convert desc to type_expr * type_expr *)
+  let flatten_desc f x = match x.expanded with
+    | None -> f x.t x.t
+    | Some expanded -> f x.t expanded
+  let flatten f = map (flatten_desc f)
+
+  (* Permute the expected and actual values *)
+  let swap_diff x = { got = x.expected; expected = x.got }
+  let swap_elt = function
+    | Diff x -> Diff (swap_diff x)
+    | Incompatible_fields {name;diff} ->
+        Incompatible_fields { name; diff = swap_diff diff}
+    | Obj (Missing_field(pos,s)) -> Obj(Missing_field(swap_position pos,s))
+    | Obj (Abstract_row pos) -> Obj(Abstract_row (swap_position pos))
+    | Variant (Fixed_row(pos,k,f)) -> Variant (Fixed_row(swap_position pos,k,f))
+    | Variant (No_tags(pos,f)) -> Variant (No_tags(swap_position pos,f))
+    | x -> x
+  let swap x = List.map swap_elt x
+
+  exception Unify of t
+
+  let escape kind =  Escape { kind; context = None}
+  let scope_escape x = Unify[escape (Equation (short x))]
+  let rec_occur x y = Unify[Rec_occur(x, y)]
+  let incompatible_fields name got expected =
+    Incompatible_fields {name; diff={got; expected} }
+
+  let explain trace f =
+    let rec explain = function
+      | [] -> None
+      | [h] -> f ~prev:None h
+      | h :: (prev :: _ as rem) ->
+        match f ~prev:(Some prev) h with
+        | Some _ as m -> m
+        | None -> explain rem in
+    explain (List.rev trace)
+
+end
+module Trace = Unification_trace
+
+exception Unify = Trace.Unify
+
+exception Tags of label * label
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Tags (l, l') ->
+          Some
+            Location.
+              (errorf ~loc:(in_file !input_name)
+                 "In this program,@ variant constructors@ `%s and `%s@ \
+                  have the same hash value.@ Change one of them." l l'
+              )
+      | _ -> None
+    )
+
+exception Subtype of Unification_trace.t * Unification_trace.t
+
+exception Cannot_expand
+
+exception Cannot_apply
+
+(**** Type level management ****)
+
+let current_level = ref 0
+let nongen_level = ref 0
+let global_level = ref 1
+let saved_level = ref []
+
+type levels =
+    { current_level: int; nongen_level: int; global_level: int;
+      saved_level: (int * int) list; }
+let save_levels () =
+  { current_level = !current_level;
+    nongen_level = !nongen_level;
+    global_level = !global_level;
+    saved_level = !saved_level }
+let set_levels l =
+  current_level := l.current_level;
+  nongen_level := l.nongen_level;
+  global_level := l.global_level;
+  saved_level := l.saved_level
+
+let get_current_level () = !current_level
+let init_def level = current_level := level; nongen_level := level
+let begin_def () =
+  saved_level := (!current_level, !nongen_level) :: !saved_level;
+  incr current_level; nongen_level := !current_level
+let begin_class_def () =
+  saved_level := (!current_level, !nongen_level) :: !saved_level;
+  incr current_level
+let raise_nongen_level () =
+  saved_level := (!current_level, !nongen_level) :: !saved_level;
+  nongen_level := !current_level
+let end_def () =
+  let (cl, nl) = List.hd !saved_level in
+  saved_level := List.tl !saved_level;
+  current_level := cl; nongen_level := nl
+let create_scope () =
+  init_def (!current_level + 1);
+  !current_level
+
+let reset_global_level () =
+  global_level := !current_level + 1
+let increase_global_level () =
+  let gl = !global_level in
+  global_level := !current_level;
+  gl
+let restore_global_level gl =
+  global_level := gl
+
+(**** Whether a path points to an object type (with hidden row variable) ****)
+let is_object_type path =
+  let name =
+    match path with Path.Pident id -> Ident.name id
+    | Path.Pdot(_, s) -> s
+    | Path.Papply _ -> assert false
+  in name.[0] = '#'
+
+(**** Control tracing of GADT instances *)
+
+let trace_gadt_instances = ref false
+let check_trace_gadt_instances env =
+  not !trace_gadt_instances && Env.has_local_constraints env &&
+  (trace_gadt_instances := true; cleanup_abbrev (); true)
+
+let reset_trace_gadt_instances b =
+  if b then trace_gadt_instances := false
+
+let wrap_trace_gadt_instances env f x =
+  let b = check_trace_gadt_instances env in
+  let y = f x in
+  reset_trace_gadt_instances b;
+  y
+
+(**** Abbreviations without parameters ****)
+(* Shall reset after generalizing *)
+
+let simple_abbrevs = ref Mnil
+
+let proper_abbrevs path tl abbrev =
+  if tl <> [] || !trace_gadt_instances || !Clflags.principal ||
+     is_object_type path
+  then abbrev
+  else simple_abbrevs
+
+(**** Some type creators ****)
+
+(* Re-export generic type creators *)
+
+let newty2             = Btype.newty2
+let newty desc         = newty2 !current_level desc
+
+let newvar ?name ()         = newty2 !current_level (Tvar name)
+let newvar2 ?name level     = newty2 level (Tvar name)
+let new_global_var ?name () = newty2 !global_level (Tvar name)
+
+let newobj fields      = newty (Tobject (fields, ref None))
+
+let newconstr path tyl = newty (Tconstr (path, tyl, ref Mnil))
+
+let none = newty (Ttuple [])                (* Clearly ill-formed type *)
+
+(**** Representative of a type ****)
+
+(* Re-export repr *)
+let repr = repr
+
+(**** Type maps ****)
+
+module TypePairs =
+  Hashtbl.Make (struct
+    type t = type_expr * type_expr
+    let equal (t1, t1') (t2, t2') = (t1 == t2) && (t1' == t2')
+    let hash (t, t') = t.id + 93 * t'.id
+ end)
+
+
+(**** unification mode ****)
+
+type unification_mode =
+  | Expression (* unification in expression *)
+  | Pattern (* unification in pattern which may add local constraints *)
+
+let umode = ref Expression
+let generate_equations = ref false
+let assume_injective = ref false
+
+let set_mode_pattern ~generate ~injective f =
+  Misc.protect_refs
+    [Misc.R (umode, Pattern);
+     Misc.R (generate_equations, generate);
+     Misc.R (assume_injective, injective)] f
+
+(*** Checks for type definitions ***)
+
+let in_current_module = function
+  | Path.Pident _ -> true
+  | Path.Pdot _ | Path.Papply _ -> false
+
+let in_pervasives p =
+  in_current_module p &&
+  try ignore (Env.find_type p Env.initial_safe_string); true
+  with Not_found -> false
+
+let is_datatype decl=
+  match decl.type_kind with
+    Type_record _ | Type_variant _ | Type_open -> true
+  | Type_abstract -> false
+
+
+                  (**********************************************)
+                  (*  Miscellaneous operations on object types  *)
+                  (**********************************************)
+
+(* Note:
+   We need to maintain some invariants:
+   * cty_self must be a Tobject
+   * ...
+*)
+
+(**** Object field manipulation. ****)
+
+let object_fields ty =
+  match (repr ty).desc with
+    Tobject (fields, _) -> fields
+  | _                   -> assert false
+
+let flatten_fields ty =
+  let rec flatten l ty =
+    let ty = repr ty in
+    match ty.desc with
+      Tfield(s, k, ty1, ty2) ->
+        flatten ((s, k, ty1)::l) ty2
+    | _ ->
+        (l, ty)
+  in
+    let (l, r) = flatten [] ty in
+    (List.sort (fun (n, _, _) (n', _, _) -> compare n n') l, r)
+
+let build_fields level =
+  List.fold_right
+    (fun (s, k, ty1) ty2 -> newty2 level (Tfield(s, k, ty1, ty2)))
+
+let associate_fields fields1 fields2 =
+  let rec associate p s s' =
+    function
+      (l, []) ->
+        (List.rev p, (List.rev s) @ l, List.rev s')
+    | ([], l') ->
+        (List.rev p, List.rev s, (List.rev s') @ l')
+    | ((n, k, t)::r, (n', k', t')::r') when n = n' ->
+        associate ((n, k, t, k', t')::p) s s' (r, r')
+    | ((n, k, t)::r, ((n', _k', _t')::_ as l')) when n < n' ->
+        associate p ((n, k, t)::s) s' (r, l')
+    | (((_n, _k, _t)::_ as l), (n', k', t')::r') (* when n > n' *) ->
+        associate p s ((n', k', t')::s') (l, r')
+  in
+  associate [] [] [] (fields1, fields2)
+
+let rec has_dummy_method ty =
+  match repr ty with
+    {desc = Tfield (m, _, _, ty2)} ->
+      m = dummy_method || has_dummy_method ty2
+  | _ -> false
+
+let is_self_type = function
+  | Tobject (ty, _) -> has_dummy_method ty
+  | _ -> false
+
+(**** Check whether an object is open ****)
+
+(* +++ The abbreviation should eventually be expanded *)
+let rec object_row ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tobject (t, _)     -> object_row t
+  | Tfield(_, _, _, t) -> object_row t
+  | _ -> ty
+
+let opened_object ty =
+  match (object_row ty).desc with
+  | Tvar _  | Tunivar _ | Tconstr _ -> true
+  | _                               -> false
+
+let concrete_object ty =
+  match (object_row ty).desc with
+  | Tvar _             -> false
+  | _                  -> true
+
+(**** Close an object ****)
+
+let close_object ty =
+  let rec close ty =
+    let ty = repr ty in
+    match ty.desc with
+      Tvar _ ->
+        link_type ty (newty2 ty.level Tnil); true
+    | Tfield(lab, _, _, _) when lab = dummy_method ->
+        false
+    | Tfield(_, _, _, ty') -> close ty'
+    | _                    -> assert false
+  in
+  match (repr ty).desc with
+    Tobject (ty, _)   -> close ty
+  | _                 -> assert false
+
+(**** Row variable of an object type ****)
+
+let row_variable ty =
+  let rec find ty =
+    let ty = repr ty in
+    match ty.desc with
+      Tfield (_, _, _, ty) -> find ty
+    | Tvar _               -> ty
+    | _                    -> assert false
+  in
+  match (repr ty).desc with
+    Tobject (fi, _) -> find fi
+  | _               -> assert false
+
+(**** Object name manipulation ****)
+(* +++ Bientot obsolete *)
+
+let set_object_name id rv params ty =
+  match (repr ty).desc with
+    Tobject (_fi, nm) ->
+      set_name nm (Some (Path.Pident id, rv::params))
+  | _ ->
+      assert false
+
+let remove_object_name ty =
+  match (repr ty).desc with
+    Tobject (_, nm)   -> set_name nm None
+  | Tconstr (_, _, _) -> ()
+  | _                 -> fatal_error "Ctype.remove_object_name"
+
+(**** Hiding of private methods ****)
+
+let hide_private_methods ty =
+  match (repr ty).desc with
+    Tobject (fi, nm) ->
+      nm := None;
+      let (fl, _) = flatten_fields fi in
+      List.iter
+        (function (_, k, _) ->
+          match field_kind_repr k with
+            Fvar r -> set_kind r Fabsent
+          | _      -> ())
+        fl
+  | _ ->
+      assert false
+
+
+                              (*******************************)
+                              (*  Operations on class types  *)
+                              (*******************************)
+
+
+let rec signature_of_class_type =
+  function
+    Cty_constr (_, _, cty) -> signature_of_class_type cty
+  | Cty_signature sign     -> sign
+  | Cty_arrow (_, _, cty)   -> signature_of_class_type cty
+
+let self_type cty =
+  repr (signature_of_class_type cty).csig_self
+
+let rec class_type_arity =
+  function
+    Cty_constr (_, _, cty) ->  class_type_arity cty
+  | Cty_signature _        ->  0
+  | Cty_arrow (_, _, cty)    ->  1 + class_type_arity cty
+
+
+                  (*******************************************)
+                  (*  Miscellaneous operations on row types  *)
+                  (*******************************************)
+
+let sort_row_fields = List.sort (fun (p,_) (q,_) -> compare p q)
+
+let rec merge_rf r1 r2 pairs fi1 fi2 =
+  match fi1, fi2 with
+    (l1,f1 as p1)::fi1', (l2,f2 as p2)::fi2' ->
+      if l1 = l2 then merge_rf r1 r2 ((l1,f1,f2)::pairs) fi1' fi2' else
+      if l1 < l2 then merge_rf (p1::r1) r2 pairs fi1' fi2 else
+      merge_rf r1 (p2::r2) pairs fi1 fi2'
+  | [], _ -> (List.rev r1, List.rev_append r2 fi2, pairs)
+  | _, [] -> (List.rev_append r1 fi1, List.rev r2, pairs)
+
+let merge_row_fields fi1 fi2 =
+  match fi1, fi2 with
+    [], _ | _, [] -> (fi1, fi2, [])
+  | [p1], _ when not (List.mem_assoc (fst p1) fi2) -> (fi1, fi2, [])
+  | _, [p2] when not (List.mem_assoc (fst p2) fi1) -> (fi1, fi2, [])
+  | _ -> merge_rf [] [] [] (sort_row_fields fi1) (sort_row_fields fi2)
+
+let rec filter_row_fields erase = function
+    [] -> []
+  | (_l,f as p)::fi ->
+      let fi = filter_row_fields erase fi in
+      match row_field_repr f with
+        Rabsent -> fi
+      | Reither(_,_,false,e) when erase -> set_row_field e Rabsent; fi
+      | _ -> p :: fi
+
+                    (**************************************)
+                    (*  Check genericity of type schemes  *)
+                    (**************************************)
+
+
+exception Non_closed of type_expr * bool
+
+let free_variables = ref []
+let really_closed = ref None
+
+(* [free_vars_rec] collects the variables of the input type
+   expression into the [free_variables] reference. It is used for
+   several different things in the type-checker, with the following
+   bells and whistles:
+   - If [really_closed] is Some typing environment, types in the environment
+     are expanded to check whether the apparently-free variable would vanish
+     during expansion.
+   - We collect both type variables and row variables, paired with a boolean
+     that is [true] if we have a row variable.
+   - We do not count "virtual" free variables -- free variables stored in
+     the abbreviation of an object type that has been expanded (we store
+     the abbreviations for use when displaying the type).
+
+   The functions [free_vars] and [free_variables] below receive
+   a typing environment as an optional [?env] parameter and
+   set [really_closed] accordingly.
+   [free_vars] returns a [(variable * bool) list], while
+   [free_variables] drops the type/row information
+   and only returns a [variable list].
+ *)
+let rec free_vars_rec real ty =
+  let ty = repr ty in
+  if ty.level >= lowest_level then begin
+    ty.level <- pivot_level - ty.level;
+    begin match ty.desc, !really_closed with
+      Tvar _, _ ->
+        free_variables := (ty, real) :: !free_variables
+    | Tconstr (path, tl, _), Some env ->
+        begin try
+          let (_, body, _) = Env.find_type_expansion path env in
+          if (repr body).level <> generic_level then
+            free_variables := (ty, real) :: !free_variables
+        with Not_found -> ()
+        end;
+        List.iter (free_vars_rec true) tl
+(* Do not count "virtual" free variables
+    | Tobject(ty, {contents = Some (_, p)}) ->
+        free_vars_rec false ty; List.iter (free_vars_rec true) p
+*)
+    | Tobject (ty, _), _ ->
+        free_vars_rec false ty
+    | Tfield (_, _, ty1, ty2), _ ->
+        free_vars_rec true ty1; free_vars_rec false ty2
+    | Tvariant row, _ ->
+        let row = row_repr row in
+        iter_row (free_vars_rec true) row;
+        if not (static_row row) then free_vars_rec false row.row_more
+    | _    ->
+        iter_type_expr (free_vars_rec true) ty
+    end;
+  end
+
+let free_vars ?env ty =
+  free_variables := [];
+  really_closed := env;
+  free_vars_rec true ty;
+  let res = !free_variables in
+  free_variables := [];
+  really_closed := None;
+  res
+
+let free_variables ?env ty =
+  let tl = List.map fst (free_vars ?env ty) in
+  unmark_type ty;
+  tl
+
+let closed_type ty =
+  match free_vars ty with
+      []           -> ()
+  | (v, real) :: _ -> raise (Non_closed (v, real))
+
+let closed_parameterized_type params ty =
+  List.iter mark_type params;
+  let ok =
+    try closed_type ty; true with Non_closed _ -> false in
+  List.iter unmark_type params;
+  unmark_type ty;
+  ok
+
+let closed_type_decl decl =
+  try
+    List.iter mark_type decl.type_params;
+    begin match decl.type_kind with
+      Type_abstract ->
+        ()
+    | Type_variant v ->
+        List.iter
+          (fun {cd_args; cd_res; _} ->
+            match cd_res with
+            | Some _ -> ()
+            | None ->
+                match cd_args with
+                | Cstr_tuple l ->  List.iter closed_type l
+                | Cstr_record l -> List.iter (fun l -> closed_type l.ld_type) l
+          )
+          v
+    | Type_record(r, _rep) ->
+        List.iter (fun l -> closed_type l.ld_type) r
+    | Type_open -> ()
+    end;
+    begin match decl.type_manifest with
+      None    -> ()
+    | Some ty -> closed_type ty
+    end;
+    unmark_type_decl decl;
+    None
+  with Non_closed (ty, _) ->
+    unmark_type_decl decl;
+    Some ty
+
+let closed_extension_constructor ext =
+  try
+    List.iter mark_type ext.ext_type_params;
+    begin match ext.ext_ret_type with
+    | Some _ -> ()
+    | None -> iter_type_expr_cstr_args closed_type ext.ext_args
+    end;
+    unmark_extension_constructor ext;
+    None
+  with Non_closed (ty, _) ->
+    unmark_extension_constructor ext;
+    Some ty
+
+type closed_class_failure =
+    CC_Method of type_expr * bool * string * type_expr
+  | CC_Value of type_expr * bool * string * type_expr
+
+exception CCFailure of closed_class_failure
+
+let closed_class params sign =
+  let ty = object_fields (repr sign.csig_self) in
+  let (fields, rest) = flatten_fields ty in
+  List.iter mark_type params;
+  mark_type rest;
+  List.iter
+    (fun (lab, _, ty) -> if lab = dummy_method then mark_type ty)
+    fields;
+  try
+    mark_type_node (repr sign.csig_self);
+    List.iter
+      (fun (lab, kind, ty) ->
+        if field_kind_repr kind = Fpresent then
+        try closed_type ty with Non_closed (ty0, real) ->
+          raise (CCFailure (CC_Method (ty0, real, lab, ty))))
+      fields;
+    mark_type_params (repr sign.csig_self);
+    List.iter unmark_type params;
+    unmark_class_signature sign;
+    None
+  with CCFailure reason ->
+    mark_type_params (repr sign.csig_self);
+    List.iter unmark_type params;
+    unmark_class_signature sign;
+    Some reason
+
+
+                            (**********************)
+                            (*  Type duplication  *)
+                            (**********************)
+
+
+(* Duplicate a type, preserving only type variables *)
+let duplicate_type ty =
+  Subst.type_expr Subst.identity ty
+
+(* Same, for class types *)
+let duplicate_class_type ty =
+  Subst.class_type Subst.identity ty
+
+
+                         (*****************************)
+                         (*  Type level manipulation  *)
+                         (*****************************)
+
+(*
+   It would be a bit more efficient to remove abbreviation expansions
+   rather than generalizing them: these expansions will usually not be
+   used anymore. However, this is not possible in the general case, as
+   [expand_abbrev] (via [subst]) requires these expansions to be
+   preserved. Does it worth duplicating this code ?
+*)
+let rec generalize ty =
+  let ty = repr ty in
+  if (ty.level > !current_level) && (ty.level <> generic_level) then begin
+    set_level ty generic_level;
+    begin match ty.desc with
+      Tconstr (_, _, abbrev) ->
+        iter_abbrev generalize !abbrev
+    | _ -> ()
+    end;
+    iter_type_expr generalize ty
+  end
+
+let generalize ty =
+  simple_abbrevs := Mnil;
+  generalize ty
+
+(* Generalize the structure and lower the variables *)
+
+let rec generalize_structure var_level ty =
+  let ty = repr ty in
+  if ty.level <> generic_level then begin
+    if is_Tvar ty && ty.level > var_level then
+      set_level ty var_level
+    else if
+      ty.level > !current_level &&
+      match ty.desc with
+        Tconstr (p, _, abbrev) ->
+          not (is_object_type p) && (abbrev := Mnil; true)
+      | _ -> true
+    then begin
+      set_level ty generic_level;
+      iter_type_expr (generalize_structure var_level) ty
+    end
+  end
+
+let generalize_structure ty =
+  simple_abbrevs := Mnil;
+  generalize_structure !current_level ty
+
+(* Generalize the spine of a function, if the level >= !current_level *)
+
+let rec generalize_spine ty =
+  let ty = repr ty in
+  if ty.level < !current_level || ty.level = generic_level then () else
+  match ty.desc with
+    Tarrow (_, ty1, ty2, _) ->
+      set_level ty generic_level;
+      generalize_spine ty1;
+      generalize_spine ty2;
+  | Tpoly (ty', _) ->
+      set_level ty generic_level;
+      generalize_spine ty'
+  | Ttuple tyl
+  | Tpackage (_, _, tyl) ->
+      set_level ty generic_level;
+      List.iter generalize_spine tyl
+  | Tconstr (p, tyl, memo) when not (is_object_type p) ->
+      set_level ty generic_level;
+      memo := Mnil;
+      List.iter generalize_spine tyl
+  | _ -> ()
+
+let forward_try_expand_once = (* Forward declaration *)
+  ref (fun _env _ty -> raise Cannot_expand)
+
+(*
+   Lower the levels of a type (assume [level] is not
+   [generic_level]).
+*)
+
+let rec normalize_package_path env p =
+  let t =
+    try (Env.find_modtype p env).mtd_type
+    with Not_found -> None
+  in
+  match t with
+  | Some (Mty_ident p) -> normalize_package_path env p
+  | Some (Mty_signature _ | Mty_functor _ | Mty_alias _) | None ->
+      match p with
+        Path.Pdot (p1, s) ->
+          (* For module aliases *)
+          let p1' = Env.normalize_module_path None env p1 in
+          if Path.same p1 p1' then p else
+          normalize_package_path env (Path.Pdot (p1', s))
+      | _ -> p
+
+let check_scope_escape env level ty =
+  let rec loop ty =
+    let ty = repr ty in
+    if ty.level >= lowest_level then begin
+      ty.level <- pivot_level - ty.level;
+      if level < ty.scope then
+        raise(Trace.scope_escape ty);
+      begin match ty.desc with
+      | Tconstr (p, _, _) when level < Path.scope p ->
+          begin match !forward_try_expand_once env ty with
+          | ty' -> aux ty'
+          | exception Cannot_expand ->
+              raise Trace.(Unify [escape (Constructor p)])
+          end
+      | Tpackage (p, nl, tl) when level < Path.scope p ->
+          let p' = normalize_package_path env p in
+          if Path.same p p' then raise Trace.(Unify [escape (Module_type p)]);
+          aux { ty with desc = Tpackage (p', nl, tl) }
+      | _ ->
+        iter_type_expr loop ty
+      end;
+    end
+  and aux ty =
+    loop ty;
+    unmark_type ty
+  in
+  try aux ty;
+  with Unify [Trace.Escape x] ->
+    raise Trace.(Unify[Escape { x with context = Some ty }])
+
+let update_scope scope ty =
+  let ty = repr ty in
+  let scope = max scope ty.scope in
+  if ty.level < scope then raise (Trace.scope_escape ty);
+  set_scope ty scope
+
+(* Note: the level of a type constructor must be greater than its binding
+    time. That way, a type constructor cannot escape the scope of its
+    definition, as would be the case in
+      let x = ref []
+      module M = struct type t let _ = (x : t list ref) end
+    (without this constraint, the type system would actually be unsound.)
+*)
+
+let rec update_level env level expand ty =
+  let ty = repr ty in
+  if ty.level > level then begin
+    if level < ty.scope then raise (Trace.scope_escape ty);
+    match ty.desc with
+      Tconstr(p, _tl, _abbrev) when level < Path.scope p ->
+        (* Try first to replace an abbreviation by its expansion. *)
+        begin try
+          link_type ty (!forward_try_expand_once env ty);
+          update_level env level expand ty
+        with Cannot_expand ->
+          raise Trace.(Unify [escape(Constructor p)])
+        end
+    | Tconstr(p, (_ :: _ as tl), _) ->
+        let variance =
+          try (Env.find_type p env).type_variance
+          with Not_found -> List.map (fun _ -> Variance.may_inv) tl in
+        let needs_expand =
+          expand ||
+          List.exists2
+            (fun var ty -> var = Variance.null && (repr ty).level > level)
+            variance tl
+        in
+        begin try
+          if not needs_expand then raise Cannot_expand;
+          link_type ty (!forward_try_expand_once env ty);
+          update_level env level expand ty
+        with Cannot_expand ->
+          set_level ty level;
+          iter_type_expr (update_level env level expand) ty
+        end
+    | Tpackage (p, nl, tl) when level < Path.scope p ->
+        let p' = normalize_package_path env p in
+        if Path.same p p' then raise Trace.(Unify [escape (Module_type p)]);
+        set_type_desc ty (Tpackage (p', nl, tl));
+        update_level env level expand ty
+    | Tobject(_, ({contents=Some(p, _tl)} as nm))
+      when level < Path.scope p ->
+        set_name nm None;
+        update_level env level expand ty
+    | Tvariant row ->
+        let row = row_repr row in
+        begin match row.row_name with
+        | Some (p, _tl) when level < Path.scope p ->
+            set_type_desc ty (Tvariant {row with row_name = None})
+        | _ -> ()
+        end;
+        set_level ty level;
+        iter_type_expr (update_level env level expand) ty
+    | Tfield(lab, _, ty1, _)
+      when lab = dummy_method && (repr ty1).level > level ->
+        raise Trace.(Unify [escape Self])
+    | _ ->
+        set_level ty level;
+        (* XXX what about abbreviations in Tconstr ? *)
+        iter_type_expr (update_level env level expand) ty
+  end
+
+(* First try without expanding, then expand everything,
+   to avoid combinatorial blow-up *)
+let update_level env level ty =
+  let ty = repr ty in
+  if ty.level > level then begin
+    let snap = snapshot () in
+    try
+      update_level env level false ty
+    with Unify _ ->
+      backtrack snap;
+      update_level env level true ty
+  end
+
+(* Lower level of type variables inside contravariant branches *)
+
+let rec lower_contravariant env var_level visited contra ty =
+  let ty = repr ty in
+  let must_visit =
+    ty.level > var_level &&
+    match Hashtbl.find visited ty.id with
+    | done_contra -> contra && not done_contra
+    | exception Not_found -> true
+  in
+  if must_visit then begin
+    Hashtbl.add visited ty.id contra;
+    let lower_rec = lower_contravariant env var_level visited in
+    match ty.desc with
+      Tvar _ -> if contra then set_level ty var_level
+    | Tconstr (_, [], _) -> ()
+    | Tconstr (path, tyl, _abbrev) ->
+       let variance, maybe_expand =
+         try
+           let typ = Env.find_type path env in
+           typ.type_variance,
+           typ.type_kind = Type_abstract
+          with Not_found ->
+            (* See testsuite/tests/typing-missing-cmi-2 for an example *)
+            List.map (fun _ -> Variance.may_inv) tyl,
+            false
+        in
+        if List.for_all ((=) Variance.null) variance then () else
+          let not_expanded () =
+            List.iter2
+              (fun v t ->
+                if v = Variance.null then () else
+                  if Variance.(mem May_weak v)
+                  then lower_rec true t
+                  else lower_rec contra t)
+              variance tyl in
+          if maybe_expand then (* we expand cautiously to avoid missing cmis *)
+            match !forward_try_expand_once env ty with
+            | ty -> lower_rec contra ty
+            | exception Cannot_expand -> not_expanded ()
+          else not_expanded ()
+    | Tpackage (_, _, tyl) ->
+        List.iter (lower_rec true) tyl
+    | Tarrow (_, t1, t2, _) ->
+        lower_rec true t1;
+        lower_rec contra t2
+    | _ ->
+        iter_type_expr (lower_rec contra) ty
+  end
+
+let lower_contravariant env ty =
+  simple_abbrevs := Mnil;
+  lower_contravariant env !nongen_level (Hashtbl.create 7) false ty
+
+(* Correct the levels of type [ty]. *)
+let correct_levels ty =
+  duplicate_type ty
+
+(* Only generalize the type ty0 in ty *)
+let limited_generalize ty0 ty =
+  let ty0 = repr ty0 in
+
+  let graph = Hashtbl.create 17 in
+  let idx = ref lowest_level in
+  let roots = ref [] in
+
+  let rec inverse pty ty =
+    let ty = repr ty in
+    if (ty.level > !current_level) || (ty.level = generic_level) then begin
+      decr idx;
+      Hashtbl.add graph !idx (ty, ref pty);
+      if (ty.level = generic_level) || (ty == ty0) then
+        roots := ty :: !roots;
+      set_level ty !idx;
+      iter_type_expr (inverse [ty]) ty
+    end else if ty.level < lowest_level then begin
+      let (_, parents) = Hashtbl.find graph ty.level in
+      parents := pty @ !parents
+    end
+
+  and generalize_parents ty =
+    let idx = ty.level in
+    if idx <> generic_level then begin
+      set_level ty generic_level;
+      List.iter generalize_parents !(snd (Hashtbl.find graph idx));
+      (* Special case for rows: must generalize the row variable *)
+      match ty.desc with
+        Tvariant row ->
+          let more = row_more row in
+          let lv = more.level in
+          if (lv < lowest_level || lv > !current_level)
+          && lv <> generic_level then set_level more generic_level
+      | _ -> ()
+    end
+  in
+
+  inverse [] ty;
+  if ty0.level < lowest_level then
+    iter_type_expr (inverse []) ty0;
+  List.iter generalize_parents !roots;
+  Hashtbl.iter
+    (fun _ (ty, _) ->
+       if ty.level <> generic_level then set_level ty !current_level)
+    graph
+
+
+(* Compute statically the free univars of all nodes in a type *)
+(* This avoids doing it repeatedly during instantiation *)
+
+type inv_type_expr =
+    { inv_type : type_expr;
+      mutable inv_parents : inv_type_expr list }
+
+let rec inv_type hash pty ty =
+  let ty = repr ty in
+  try
+    let inv = TypeHash.find hash ty in
+    inv.inv_parents <- pty @ inv.inv_parents
+  with Not_found ->
+    let inv = { inv_type = ty; inv_parents = pty } in
+    TypeHash.add hash ty inv;
+    iter_type_expr (inv_type hash [inv]) ty
+
+let compute_univars ty =
+  let inverted = TypeHash.create 17 in
+  inv_type inverted [] ty;
+  let node_univars = TypeHash.create 17 in
+  let rec add_univar univ inv =
+    match inv.inv_type.desc with
+      Tpoly (_ty, tl) when List.memq univ (List.map repr tl) -> ()
+    | _ ->
+        try
+          let univs = TypeHash.find node_univars inv.inv_type in
+          if not (TypeSet.mem univ !univs) then begin
+            univs := TypeSet.add univ !univs;
+            List.iter (add_univar univ) inv.inv_parents
+          end
+        with Not_found ->
+          TypeHash.add node_univars inv.inv_type (ref(TypeSet.singleton univ));
+          List.iter (add_univar univ) inv.inv_parents
+  in
+  TypeHash.iter (fun ty inv -> if is_Tunivar ty then add_univar ty inv)
+    inverted;
+  fun ty ->
+    try !(TypeHash.find node_univars ty) with Not_found -> TypeSet.empty
+
+
+                              (*******************)
+                              (*  Instantiation  *)
+                              (*******************)
+
+
+let rec find_repr p1 =
+  function
+    Mnil ->
+      None
+  | Mcons (Public, p2, ty, _, _) when Path.same p1 p2 ->
+      Some ty
+  | Mcons (_, _, _, _, rem) ->
+      find_repr p1 rem
+  | Mlink {contents = rem} ->
+      find_repr p1 rem
+
+(*
+   Generic nodes are duplicated, while non-generic nodes are left
+   as-is.
+   During instantiation, the description of a generic node is first
+   replaced by a link to a stub ([Tsubst (newvar ())]). Once the
+   copy is made, it replaces the stub.
+   After instantiation, the description of generic node, which was
+   stored by [save_desc], must be put back, using [cleanup_types].
+*)
+
+let abbreviations = ref (ref Mnil)
+  (* Abbreviation memorized. *)
+
+(* partial: we may not wish to copy the non generic types
+   before we call type_pat *)
+let rec copy ?partial ?keep_names scope ty =
+  let copy = copy ?partial ?keep_names scope in
+  let ty = repr ty in
+  match ty.desc with
+    Tsubst ty -> ty
+  | _ ->
+    if ty.level <> generic_level && partial = None then ty else
+    (* We only forget types that are non generic and do not contain
+       free univars *)
+    let forget =
+      if ty.level = generic_level then generic_level else
+      match partial with
+        None -> assert false
+      | Some (free_univars, keep) ->
+          if TypeSet.is_empty (free_univars ty) then
+            if keep then ty.level else !current_level
+          else generic_level
+    in
+    if forget <> generic_level then newty2 forget (Tvar None) else
+    let desc = ty.desc in
+    For_copy.save_desc scope ty desc;
+    let t = newvar() in          (* Stub *)
+    set_scope t ty.scope;
+    ty.desc <- Tsubst t;
+    t.desc <-
+      begin match desc with
+      | Tconstr (p, tl, _) ->
+          let abbrevs = proper_abbrevs p tl !abbreviations in
+          begin match find_repr p !abbrevs with
+            Some ty when repr ty != t ->
+              Tlink ty
+          | _ ->
+          (*
+             One must allocate a new reference, so that abbrevia-
+             tions belonging to different branches of a type are
+             independent.
+             Moreover, a reference containing a [Mcons] must be
+             shared, so that the memorized expansion of an abbrevi-
+             ation can be released by changing the content of just
+             one reference.
+          *)
+              Tconstr (p, List.map copy tl,
+                       ref (match !(!abbreviations) with
+                              Mcons _ -> Mlink !abbreviations
+                            | abbrev  -> abbrev))
+          end
+      | Tvariant row0 ->
+          let row = row_repr row0 in
+          let more = repr row.row_more in
+          (* We must substitute in a subtle way *)
+          (* Tsubst takes a tuple containing the row var and the variant *)
+          begin match more.desc with
+            Tsubst {desc = Ttuple [_;ty2]} ->
+              (* This variant type has been already copied *)
+              ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *)
+              Tlink ty2
+          | _ ->
+              (* If the row variable is not generic, we must keep it *)
+              let keep = more.level <> generic_level && partial = None in
+              let more' =
+                match more.desc with
+                  Tsubst ty -> ty
+                | Tconstr _ | Tnil ->
+                    For_copy.save_desc scope more more.desc;
+                    copy more
+                | Tvar _ | Tunivar _ ->
+                    For_copy.save_desc scope more more.desc;
+                    if keep then more else newty more.desc
+                |  _ -> assert false
+              in
+              let row =
+                match repr more' with (* PR#6163 *)
+                  {desc=Tconstr (x,_,_)} when not (is_fixed row) ->
+                    {row with row_fixed = Some (Reified x)}
+                | _ -> row
+              in
+              (* Open row if partial for pattern and contains Reither *)
+              let more', row =
+                match partial with
+                  Some (free_univars, false) ->
+                    let more' =
+                      if more.id != more'.id then more' else
+                      let lv = if keep then more.level else !current_level in
+                      newty2 lv (Tvar None)
+                    in
+                    let not_reither (_, f) =
+                      match row_field_repr f with
+                        Reither _ -> false
+                      | _ -> true
+                    in
+                    if row.row_closed && not (is_fixed row)
+                    && TypeSet.is_empty (free_univars ty)
+                    && not (List.for_all not_reither row.row_fields) then
+                      (more',
+                       {row_fields = List.filter not_reither row.row_fields;
+                        row_more = more'; row_bound = ();
+                        row_closed = false; row_fixed = None; row_name = None})
+                    else (more', row)
+                | _ -> (more', row)
+              in
+              (* Register new type first for recursion *)
+              more.desc <- Tsubst(newgenty(Ttuple[more';t]));
+              (* Return a new copy *)
+              Tvariant (copy_row copy true row keep more')
+          end
+      | Tfield (_p, k, _ty1, ty2) ->
+          begin match field_kind_repr k with
+            Fabsent  -> Tlink (copy ty2)
+          | Fpresent -> copy_type_desc copy desc
+          | Fvar r ->
+              For_copy.dup_kind scope r;
+              copy_type_desc copy desc
+          end
+      | Tobject (ty1, _) when partial <> None ->
+          Tobject (copy ty1, ref None)
+      | _ -> copy_type_desc ?keep_names copy desc
+      end;
+    t
+
+(**** Variants of instantiations ****)
+
+let instance ?partial sch =
+  let partial =
+    match partial with
+      None -> None
+    | Some keep -> Some (compute_univars sch, keep)
+  in
+  For_copy.with_scope (fun scope -> copy ?partial scope sch)
+
+let generic_instance sch =
+  let old = !current_level in
+  current_level := generic_level;
+  let ty = instance sch in
+  current_level := old;
+  ty
+
+let instance_list schl =
+  For_copy.with_scope (fun scope -> List.map (fun t -> copy scope t) schl)
+
+let reified_var_counter = ref Vars.empty
+let reset_reified_var_counter () =
+  reified_var_counter := Vars.empty
+
+(* names given to new type constructors.
+   Used for existential types and
+   local constraints *)
+let get_new_abstract_name s =
+  let index =
+    try Vars.find s !reified_var_counter + 1
+    with Not_found -> 0 in
+  reified_var_counter := Vars.add s index !reified_var_counter;
+  if index = 0 && s <> "" && s.[String.length s - 1] <> '$' then s else
+  Printf.sprintf "%s%d" s index
+
+let new_declaration expansion_scope manifest =
+  {
+    type_params = [];
+    type_arity = 0;
+    type_kind = Type_abstract;
+    type_private = Public;
+    type_manifest = manifest;
+    type_variance = [];
+    type_separability = [];
+    type_is_newtype = true;
+    type_expansion_scope = expansion_scope;
+    type_loc = Location.none;
+    type_attributes = [];
+    type_immediate = Unknown;
+    type_unboxed = unboxed_false_default_false;
+    type_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+  }
+
+let existential_name cstr ty = match repr ty with
+  | {desc = Tvar (Some name)} -> "$" ^ cstr.cstr_name ^ "_'" ^ name
+  | _ -> "$" ^ cstr.cstr_name
+
+let instance_constructor ?in_pattern cstr =
+  For_copy.with_scope (fun scope ->
+    begin match in_pattern with
+    | None -> ()
+    | Some (env, expansion_scope) ->
+        let process existential =
+          let decl = new_declaration expansion_scope None in
+          let name = existential_name cstr existential in
+          let path =
+            Path.Pident
+              (Ident.create_scoped ~scope:expansion_scope
+                 (get_new_abstract_name name))
+          in
+          let new_env = Env.add_local_type path decl !env in
+          env := new_env;
+          let to_unify = newty (Tconstr (path,[],ref Mnil)) in
+          let tv = copy scope existential in
+          assert (is_Tvar tv);
+          link_type tv to_unify
+        in
+        List.iter process cstr.cstr_existentials
+    end;
+    let ty_res = copy scope cstr.cstr_res in
+    let ty_args = List.map (copy scope) cstr.cstr_args in
+    (ty_args, ty_res)
+  )
+
+let instance_parameterized_type ?keep_names sch_args sch =
+  For_copy.with_scope (fun scope ->
+    let ty_args = List.map (fun t -> copy ?keep_names scope t) sch_args in
+    let ty = copy scope sch in
+    (ty_args, ty)
+  )
+
+let instance_parameterized_type_2 sch_args sch_lst sch =
+  For_copy.with_scope (fun scope ->
+    let ty_args = List.map (copy scope) sch_args in
+    let ty_lst = List.map (copy scope) sch_lst in
+    let ty = copy scope sch in
+    (ty_args, ty_lst, ty)
+  )
+
+let map_kind f = function
+  | Type_abstract -> Type_abstract
+  | Type_open -> Type_open
+  | Type_variant cl ->
+      Type_variant (
+        List.map
+          (fun c ->
+             {c with
+              cd_args = map_type_expr_cstr_args f c.cd_args;
+              cd_res = Option.map f c.cd_res
+             })
+          cl)
+  | Type_record (fl, rr) ->
+      Type_record (
+        List.map
+          (fun l ->
+             {l with ld_type = f l.ld_type}
+          ) fl, rr)
+
+
+let instance_declaration decl =
+  For_copy.with_scope (fun scope ->
+    {decl with type_params = List.map (copy scope) decl.type_params;
+     type_manifest = Option.map (copy scope) decl.type_manifest;
+     type_kind = map_kind (copy scope) decl.type_kind;
+    }
+  )
+
+let generic_instance_declaration decl =
+  let old = !current_level in
+  current_level := generic_level;
+  let decl = instance_declaration decl in
+  current_level := old;
+  decl
+
+let instance_class params cty =
+  let rec copy_class_type scope = function
+    | Cty_constr (path, tyl, cty) ->
+        let tyl' = List.map (copy scope) tyl in
+        let cty' = copy_class_type scope cty in
+        Cty_constr (path, tyl', cty')
+    | Cty_signature sign ->
+        Cty_signature
+          {csig_self = copy scope sign.csig_self;
+           csig_vars =
+             Vars.map (function (m, v, ty) -> (m, v, copy scope ty))
+               sign.csig_vars;
+           csig_concr = sign.csig_concr;
+           csig_inher =
+             List.map (fun (p,tl) -> (p, List.map (copy scope) tl))
+               sign.csig_inher}
+    | Cty_arrow (l, ty, cty) ->
+        Cty_arrow (l, copy scope ty, copy_class_type scope cty)
+  in
+  For_copy.with_scope (fun scope ->
+    let params' = List.map (copy scope) params in
+    let cty' = copy_class_type scope cty in
+    (params', cty')
+  )
+
+(**** Instantiation for types with free universal variables ****)
+
+let rec diff_list l1 l2 =
+  if l1 == l2 then [] else
+  match l1 with [] -> invalid_arg "Ctype.diff_list"
+  | a :: l1 -> a :: diff_list l1 l2
+
+let conflicts free bound =
+  let bound = List.map repr bound in
+  TypeSet.exists (fun t -> List.memq (repr t) bound) free
+
+let delayed_copy = ref []
+    (* copying to do later *)
+
+(* Copy without sharing until there are no free univars left *)
+(* all free univars must be included in [visited]            *)
+let rec copy_sep cleanup_scope fixed free bound visited ty =
+  let ty = repr ty in
+  let univars = free ty in
+  if TypeSet.is_empty univars then
+    if ty.level <> generic_level then ty else
+    let t = newvar () in
+    delayed_copy :=
+      lazy (t.desc <- Tlink (copy cleanup_scope ty))
+      :: !delayed_copy;
+    t
+  else try
+    let t, bound_t = List.assq ty visited in
+    let dl = if is_Tunivar ty then [] else diff_list bound bound_t in
+    if dl <> [] && conflicts univars dl then raise Not_found;
+    t
+  with Not_found -> begin
+    let t = newvar() in          (* Stub *)
+    let visited =
+      match ty.desc with
+        Tarrow _ | Ttuple _ | Tvariant _ | Tconstr _ | Tobject _ | Tpackage _ ->
+          (ty,(t,bound)) :: visited
+      | Tvar _ | Tfield _ | Tnil | Tpoly _ | Tunivar _ | Tlink _ | Tsubst _ ->
+          visited
+    in
+    let copy_rec = copy_sep cleanup_scope fixed free bound visited in
+    t.desc <-
+      begin match ty.desc with
+      | Tvariant row0 ->
+          let row = row_repr row0 in
+          let more = repr row.row_more in
+          (* We shall really check the level on the row variable *)
+          let keep = is_Tvar more && more.level <> generic_level in
+          let more' = copy_rec more in
+          let fixed' = fixed && (is_Tvar more || is_Tunivar more) in
+          let row = copy_row copy_rec fixed' row keep more' in
+          Tvariant row
+      | Tpoly (t1, tl) ->
+          let tl = List.map repr tl in
+          let tl' = List.map (fun t -> newty t.desc) tl in
+          let bound = tl @ bound in
+          let visited =
+            List.map2 (fun ty t -> ty,(t,bound)) tl tl' @ visited in
+          Tpoly (copy_sep cleanup_scope fixed free bound visited t1, tl')
+      | _ -> copy_type_desc copy_rec ty.desc
+      end;
+    t
+  end
+
+let instance_poly' cleanup_scope ~keep_names fixed univars sch =
+  let univars = List.map repr univars in
+  let copy_var ty =
+    match ty.desc with
+      Tunivar name -> if keep_names then newty (Tvar name) else newvar ()
+    | _ -> assert false
+  in
+  let vars = List.map copy_var univars in
+  let pairs = List.map2 (fun u v -> u, (v, [])) univars vars in
+  delayed_copy := [];
+  let ty = copy_sep cleanup_scope fixed (compute_univars sch) [] pairs sch in
+  List.iter Lazy.force !delayed_copy;
+  delayed_copy := [];
+  vars, ty
+
+let instance_poly ?(keep_names=false) fixed univars sch =
+  For_copy.with_scope (fun cleanup_scope ->
+    instance_poly' cleanup_scope ~keep_names fixed univars sch
+  )
+
+let instance_label fixed lbl =
+  For_copy.with_scope (fun scope ->
+    let ty_res = copy scope lbl.lbl_res in
+    let vars, ty_arg =
+      match repr lbl.lbl_arg with
+        {desc = Tpoly (ty, tl)} ->
+          instance_poly' scope ~keep_names:false fixed tl ty
+      | _ ->
+          [], copy scope lbl.lbl_arg
+    in
+    (vars, ty_arg, ty_res)
+  )
+
+(**** Instantiation with parameter substitution ****)
+
+let unify' = (* Forward declaration *)
+  ref (fun _env _ty1 _ty2 -> raise (Unify []))
+
+let subst env level priv abbrev ty params args body =
+  if List.length params <> List.length args then raise (Unify []);
+  let old_level = !current_level in
+  current_level := level;
+  try
+    let body0 = newvar () in          (* Stub *)
+    begin match ty with
+      None      -> ()
+    | Some ({desc = Tconstr (path, tl, _)} as ty) ->
+        let abbrev = proper_abbrevs path tl abbrev in
+        memorize_abbrev abbrev priv path ty body0
+    | _ ->
+        assert false
+    end;
+    abbreviations := abbrev;
+    let (params', body') = instance_parameterized_type params body in
+    abbreviations := ref Mnil;
+    !unify' env body0 body';
+    List.iter2 (!unify' env) params' args;
+    current_level := old_level;
+    body'
+  with Unify _ as exn ->
+    current_level := old_level;
+    raise exn
+
+(*
+   Only the shape of the type matters, not whether it is generic or
+   not. [generic_level] might be somewhat slower, but it ensures
+   invariants on types are enforced (decreasing levels), and we don't
+   care about efficiency here.
+*)
+let apply env params body args =
+  try
+    subst env generic_level Public (ref Mnil) None params args body
+  with
+    Unify _ -> raise Cannot_apply
+
+let () = Subst.ctype_apply_env_empty := apply Env.empty
+
+                              (****************************)
+                              (*  Abbreviation expansion  *)
+                              (****************************)
+
+(*
+   If the environment has changed, memorized expansions might not
+   be correct anymore, and so we flush the cache. This is safe but
+   quite pessimistic: it would be enough to flush the cache when a
+   type or module definition is overridden in the environment.
+*)
+let previous_env = ref Env.empty
+(*let string_of_kind = function Public -> "public" | Private -> "private"*)
+let check_abbrev_env env =
+  if env != !previous_env then begin
+    (* prerr_endline "cleanup expansion cache"; *)
+    cleanup_abbrev ();
+    previous_env := env
+  end
+
+
+(* Expand an abbreviation. The expansion is memorized. *)
+(*
+   Assume the level is greater than the path binding time of the
+   expanded abbreviation.
+*)
+(*
+   An abbreviation expansion will fail in either of these cases:
+   1. The type constructor does not correspond to a manifest type.
+   2. The type constructor is defined in an external file, and this
+      file is not in the path (missing -I options).
+   3. The type constructor is not in the "local" environment. This can
+      happens when a non-generic type variable has been instantiated
+      afterwards to the not yet defined type constructor. (Actually,
+      this cannot happen at the moment due to the strong constraints
+      between type levels and constructor binding time.)
+   4. The expansion requires the expansion of another abbreviation,
+      and this other expansion fails.
+*)
+let expand_abbrev_gen kind find_type_expansion env ty =
+  check_abbrev_env env;
+  match ty with
+    {desc = Tconstr (path, args, abbrev); level = level; scope} ->
+      let lookup_abbrev = proper_abbrevs path args abbrev in
+      begin match find_expans kind path !lookup_abbrev with
+        Some ty' ->
+          (* prerr_endline
+            ("found a "^string_of_kind kind^" expansion for "^Path.name path);*)
+          if level <> generic_level then
+            begin try
+              update_level env level ty'
+            with Unify _ ->
+              (* XXX This should not happen.
+                 However, levels are not correctly restored after a
+                 typing error *)
+              ()
+            end;
+          begin try
+            update_scope scope ty';
+          with Unify _ ->
+            (* XXX This should not happen.
+               However, levels are not correctly restored after a
+               typing error *)
+            ()
+          end;
+          let ty' = repr ty' in
+          (* assert (ty != ty'); *) (* PR#7324 *)
+          ty'
+      | None ->
+          match find_type_expansion path env with
+          | exception Not_found ->
+            (* another way to expand is to normalize the path itself *)
+            let path' = Env.normalize_type_path None env path in
+            if Path.same path path' then raise Cannot_expand
+            else newty2 level (Tconstr (path', args, abbrev))
+          | (params, body, lv) ->
+            (* prerr_endline
+              ("add a "^string_of_kind kind^" expansion for "^Path.name path);*)
+            let ty' = subst env level kind abbrev (Some ty) params args body in
+            (* For gadts, remember type as non exportable *)
+            (* The ambiguous level registered for ty' should be the highest *)
+            if !trace_gadt_instances then begin
+              let scope = max lv ty.scope in
+              if level < scope then raise (Trace.scope_escape ty);
+              set_scope ty scope;
+              set_scope ty' scope
+            end;
+            ty'
+      end
+  | _ ->
+      assert false
+
+(* Expand respecting privacy *)
+let expand_abbrev env ty =
+  expand_abbrev_gen Public Env.find_type_expansion env ty
+
+(* Expand once the head of a type *)
+let expand_head_once env ty =
+  try expand_abbrev env (repr ty) with Cannot_expand -> assert false
+
+(* Check whether a type can be expanded *)
+let safe_abbrev env ty =
+  let snap = Btype.snapshot () in
+  try ignore (expand_abbrev env ty); true
+  with Cannot_expand | Unify _ ->
+    Btype.backtrack snap;
+    false
+
+(* Expand the head of a type once.
+   Raise Cannot_expand if the type cannot be expanded.
+   May raise Unify, if a recursion was hidden in the type. *)
+let try_expand_once env ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tconstr _ -> repr (expand_abbrev env ty)
+  | _ -> raise Cannot_expand
+
+(* This one only raises Cannot_expand *)
+let try_expand_safe env ty =
+  let snap = Btype.snapshot () in
+  try try_expand_once env ty
+  with Unify _ ->
+    Btype.backtrack snap; raise Cannot_expand
+
+(* Fully expand the head of a type. *)
+let rec try_expand_head try_once env ty =
+  let ty' = try_once env ty in
+  try try_expand_head try_once env ty'
+  with Cannot_expand -> ty'
+
+(* Unsafe full expansion, may raise Unify. *)
+let expand_head_unif env ty =
+  try try_expand_head try_expand_once env ty with Cannot_expand -> repr ty
+
+(* Safe version of expand_head, never fails *)
+let expand_head env ty =
+  try try_expand_head try_expand_safe env ty with Cannot_expand -> repr ty
+
+let _ = forward_try_expand_once := try_expand_safe
+
+
+(* Expand until we find a non-abstract type declaration,
+   use try_expand_safe to avoid raising "Unify _" when
+   called on recursive types
+ *)
+
+let rec extract_concrete_typedecl env ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tconstr (p, _, _) ->
+      let decl = Env.find_type p env in
+      if decl.type_kind <> Type_abstract then (p, p, decl) else
+      let ty =
+        try try_expand_safe env ty with Cannot_expand -> raise Not_found
+      in
+      let (_, p', decl) = extract_concrete_typedecl env ty in
+        (p, p', decl)
+  | _ -> raise Not_found
+
+(* Implementing function [expand_head_opt], the compiler's own version of
+   [expand_head] used for type-based optimisations.
+   [expand_head_opt] uses [Env.find_type_expansion_opt] to access the
+   manifest type information of private abstract data types which is
+   normally hidden to the type-checker out of the implementation module of
+   the private abbreviation. *)
+
+let expand_abbrev_opt =
+  expand_abbrev_gen Private Env.find_type_expansion_opt
+
+let try_expand_once_opt env ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tconstr _ -> repr (expand_abbrev_opt env ty)
+  | _ -> raise Cannot_expand
+
+let rec try_expand_head_opt env ty =
+  let ty' = try_expand_once_opt env ty in
+  begin try
+    try_expand_head_opt env ty'
+  with Cannot_expand ->
+    ty'
+  end
+
+let expand_head_opt env ty =
+  let snap = Btype.snapshot () in
+  try try_expand_head_opt env ty
+  with Cannot_expand | Unify _ -> (* expand_head shall never fail *)
+    Btype.backtrack snap;
+    repr ty
+
+(* Make sure that the type parameters of the type constructor [ty]
+   respect the type constraints *)
+let enforce_constraints env ty =
+  match ty with
+    {desc = Tconstr (path, args, _abbrev); level = level} ->
+      begin try
+        let decl = Env.find_type path env in
+        ignore
+          (subst env level Public (ref Mnil) None decl.type_params args
+             (newvar2 level))
+      with Not_found -> ()
+      end
+  | _ ->
+      assert false
+
+(* Recursively expand the head of a type.
+   Also expand #-types. *)
+let full_expand env ty =
+  let ty = repr (expand_head env ty) in
+  match ty.desc with
+    Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar (repr v) ->
+      newty2 ty.level (Tobject (fi, ref None))
+  | _ ->
+      ty
+
+(*
+   Check whether the abbreviation expands to a well-defined type.
+   During the typing of a class, abbreviations for correspondings
+   types expand to non-generic types.
+*)
+let generic_abbrev env path =
+  try
+    let (_, body, _) = Env.find_type_expansion path env in
+    (repr body).level = generic_level
+  with
+    Not_found ->
+      false
+
+let generic_private_abbrev env path =
+  try
+    match Env.find_type path env with
+      {type_kind = Type_abstract;
+       type_private = Private;
+       type_manifest = Some body} ->
+         (repr body).level = generic_level
+    | _ -> false
+  with Not_found -> false
+
+let is_contractive env p =
+  try
+    let decl = Env.find_type p env in
+    in_pervasives p && decl.type_manifest = None || is_datatype decl
+  with Not_found -> false
+
+
+                              (*****************)
+                              (*  Occur check  *)
+                              (*****************)
+
+
+exception Occur
+
+let rec occur_rec env allow_recursive visited ty0 = function
+  | {desc=Tlink ty} ->
+      occur_rec env allow_recursive visited ty0 ty
+  | ty ->
+  if ty == ty0  then raise Occur;
+  match ty.desc with
+    Tconstr(p, _tl, _abbrev) ->
+      if allow_recursive && is_contractive env p then () else
+      begin try
+        if TypeSet.mem ty visited then raise Occur;
+        let visited = TypeSet.add ty visited in
+        iter_type_expr (occur_rec env allow_recursive visited ty0) ty
+      with Occur -> try
+        let ty' = try_expand_head try_expand_once env ty in
+        (* This call used to be inlined, but there seems no reason for it.
+           Message was referring to change in rev. 1.58 of the CVS repo. *)
+        occur_rec env allow_recursive visited ty0 ty'
+      with Cannot_expand ->
+        raise Occur
+      end
+  | Tobject _ | Tvariant _ ->
+      ()
+  | _ ->
+      if allow_recursive ||  TypeSet.mem ty visited then () else begin
+        let visited = TypeSet.add ty visited in
+        iter_type_expr (occur_rec env allow_recursive visited ty0) ty
+      end
+
+let type_changed = ref false (* trace possible changes to the studied type *)
+
+let merge r b = if b then r := true
+
+let occur env ty0 ty =
+  let allow_recursive = !Clflags.recursive_types || !umode = Pattern  in
+  let old = !type_changed in
+  try
+    while
+      type_changed := false;
+      occur_rec env allow_recursive TypeSet.empty ty0 ty;
+      !type_changed
+    do () (* prerr_endline "changed" *) done;
+    merge type_changed old
+  with exn ->
+    merge type_changed old;
+    match exn with
+    | Occur -> raise (Trace.rec_occur ty0 ty)
+    | _ -> raise exn
+
+let occur_in env ty0 t =
+  try occur env ty0 t; false with Unify _ -> true
+
+(* Check that a local constraint is well-founded *)
+(* PR#6405: not needed since we allow recursion and work on normalized types *)
+(* PR#6992: we actually need it for contractiveness *)
+(* This is a simplified version of occur, only for the rectypes case *)
+
+let rec local_non_recursive_abbrev strict visited env p ty =
+  (*Format.eprintf "@[Check %s =@ %a@]@." (Path.name p) !Btype.print_raw ty;*)
+  let ty = repr ty in
+  if not (List.memq ty visited) then begin
+    match ty.desc with
+      Tconstr(p', args, _abbrev) ->
+        if Path.same p p' then raise Occur;
+        if not strict && is_contractive env p' then () else
+        let visited = ty :: visited in
+        begin try
+          (* try expanding, since [p] could be hidden *)
+          local_non_recursive_abbrev strict visited env p
+            (try_expand_head try_expand_once_opt env ty)
+        with Cannot_expand ->
+          let params =
+            try (Env.find_type p' env).type_params
+            with Not_found -> args
+          in
+          List.iter2
+            (fun tv ty ->
+              let strict = strict || not (is_Tvar (repr tv)) in
+              local_non_recursive_abbrev strict visited env p ty)
+            params args
+        end
+    | _ ->
+        if strict then (* PR#7374 *)
+          let visited = ty :: visited in
+          iter_type_expr (local_non_recursive_abbrev true visited env p) ty
+  end
+
+let local_non_recursive_abbrev env p ty =
+  try (* PR#7397: need to check trace_gadt_instances *)
+    wrap_trace_gadt_instances env
+      (local_non_recursive_abbrev false [] env p) ty;
+    true
+  with Occur -> false
+
+
+                   (*****************************)
+                   (*  Polymorphic Unification  *)
+                   (*****************************)
+
+(* Since we cannot duplicate universal variables, unification must
+   be done at meta-level, using bindings in univar_pairs *)
+let rec unify_univar t1 t2 = function
+    (cl1, cl2) :: rem ->
+      let find_univ t cl =
+        try
+          let (_, r) = List.find (fun (t',_) -> t == repr t') cl in
+          Some r
+        with Not_found -> None
+      in
+      begin match find_univ t1 cl1, find_univ t2 cl2 with
+        Some {contents=Some t'2}, Some _ when t2 == repr t'2 ->
+          ()
+      | Some({contents=None} as r1), Some({contents=None} as r2) ->
+          set_univar r1 t2; set_univar r2 t1
+      | None, None ->
+          unify_univar t1 t2 rem
+      | _ ->
+          raise (Unify [])
+      end
+  | [] -> raise (Unify [])
+
+(* Test the occurrence of free univars in a type *)
+(* that's way too expensive. Must do some kind of caching *)
+let occur_univar env ty =
+  let visited = ref TypeMap.empty in
+  let rec occur_rec bound ty =
+    let ty = repr ty in
+    if ty.level >= lowest_level &&
+      if TypeSet.is_empty bound then
+        (ty.level <- pivot_level - ty.level; true)
+      else try
+        let bound' = TypeMap.find ty !visited in
+        if TypeSet.exists (fun x -> not (TypeSet.mem x bound)) bound' then
+          (visited := TypeMap.add ty (TypeSet.inter bound bound') !visited;
+           true)
+        else false
+      with Not_found ->
+        visited := TypeMap.add ty bound !visited;
+        true
+    then
+      match ty.desc with
+        Tunivar _ ->
+          if not (TypeSet.mem ty bound) then
+            raise Trace.(Unify [escape (Univ ty)])
+      | Tpoly (ty, tyl) ->
+          let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in
+          occur_rec bound  ty
+      | Tconstr (_, [], _) -> ()
+      | Tconstr (p, tl, _) ->
+          begin try
+            let td = Env.find_type p env in
+            List.iter2
+              (fun t v ->
+                (* The null variance only occurs in type abbreviations and
+                   corresponds to type variables that do not occur in the
+                   definition (expansion would erase them completely).
+                   The type-checker consistently ignores type expressions
+                   in this position. Physical expansion, as done in `occur`,
+                   would be costly here, since we need to check inside
+                   object and variant types too. *)
+                if not Variance.(eq v null) then occur_rec bound t)
+              tl td.type_variance
+          with Not_found ->
+            List.iter (occur_rec bound) tl
+          end
+      | _ -> iter_type_expr (occur_rec bound) ty
+  in
+  Misc.try_finally (fun () ->
+      occur_rec TypeSet.empty ty
+    )
+    ~always:(fun () -> unmark_type ty)
+
+(* Grouping univars by families according to their binders *)
+let add_univars =
+  List.fold_left (fun s (t,_) -> TypeSet.add (repr t) s)
+
+let get_univar_family univar_pairs univars =
+  if univars = [] then TypeSet.empty else
+  let insert s = function
+      cl1, (_::_ as cl2) ->
+        if List.exists (fun (t1,_) -> TypeSet.mem (repr t1) s) cl1 then
+          add_univars s cl2
+        else s
+    | _ -> s
+  in
+  let s = List.fold_right TypeSet.add univars TypeSet.empty in
+  List.fold_left insert s univar_pairs
+
+(* Whether a family of univars escapes from a type *)
+let univars_escape env univar_pairs vl ty =
+  let family = get_univar_family univar_pairs vl in
+  let visited = ref TypeSet.empty in
+  let rec occur t =
+    let t = repr t in
+    if TypeSet.mem t !visited then () else begin
+      visited := TypeSet.add t !visited;
+      match t.desc with
+        Tpoly (t, tl) ->
+          if List.exists (fun t -> TypeSet.mem (repr t) family) tl then ()
+          else occur t
+      | Tunivar _ ->
+          if TypeSet.mem t family then raise Trace.(Unify [escape(Univ t)])
+      | Tconstr (_, [], _) -> ()
+      | Tconstr (p, tl, _) ->
+          begin try
+            let td = Env.find_type p env in
+            List.iter2
+              (* see occur_univar *)
+              (fun t v -> if not Variance.(eq v null) then occur t)
+              tl td.type_variance
+          with Not_found ->
+            List.iter occur tl
+          end
+      | _ ->
+          iter_type_expr occur t
+    end
+  in
+  occur ty
+
+(* Wrapper checking that no variable escapes and updating univar_pairs *)
+let enter_poly env univar_pairs t1 tl1 t2 tl2 f =
+  let old_univars = !univar_pairs in
+  let known_univars =
+    List.fold_left (fun s (cl,_) -> add_univars s cl)
+      TypeSet.empty old_univars
+  in
+  let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
+  if List.exists (fun t -> TypeSet.mem t known_univars) tl1 then
+     univars_escape env old_univars tl1 (newty(Tpoly(t2,tl2)));
+  if List.exists (fun t -> TypeSet.mem t known_univars) tl2 then
+    univars_escape env old_univars tl2 (newty(Tpoly(t1,tl1)));
+  let cl1 = List.map (fun t -> t, ref None) tl1
+  and cl2 = List.map (fun t -> t, ref None) tl2 in
+  univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars;
+  Misc.try_finally (fun () -> f t1 t2)
+    ~always:(fun () -> univar_pairs := old_univars)
+
+let univar_pairs = ref []
+
+(**** Instantiate a generic type into a poly type ***)
+
+let polyfy env ty vars =
+  let subst_univar scope ty =
+    let ty = repr ty in
+    match ty.desc with
+    | Tvar name when ty.level = generic_level ->
+        For_copy.save_desc scope ty ty.desc;
+        let t = newty (Tunivar name) in
+        ty.desc <- Tsubst t;
+        Some t
+    | _ -> None
+  in
+  (* need to expand twice? cf. Ctype.unify2 *)
+  let vars = List.map (expand_head env) vars in
+  let vars = List.map (expand_head env) vars in
+  For_copy.with_scope (fun scope ->
+    let vars' = List.filter_map (subst_univar scope) vars in
+    let ty = copy scope ty in
+    let ty = newty2 ty.level (Tpoly(repr ty, vars')) in
+    let complete = List.length vars = List.length vars' in
+    ty, complete
+  )
+
+(* assumption: [ty] is fully generalized. *)
+let reify_univars env ty =
+  let vars = free_variables ty in
+  let ty, _ = polyfy env ty vars in
+  ty
+
+                              (*****************)
+                              (*  Unification  *)
+                              (*****************)
+
+
+
+let rec has_cached_expansion p abbrev =
+  match abbrev with
+    Mnil                   -> false
+  | Mcons(_, p', _, _, rem)   -> Path.same p p' || has_cached_expansion p rem
+  | Mlink rem              -> has_cached_expansion p !rem
+
+(**** Transform error trace ****)
+(* +++ Move it to some other place ? *)
+
+let expand_trace env trace =
+  let expand_desc x = match x.Trace.expanded with
+    | None -> Trace.{ t = repr x.t; expanded= Some(full_expand env x.t) }
+    | Some _ -> x in
+  Unification_trace.map expand_desc trace
+
+(**** Unification ****)
+
+(* Return whether [t0] occurs in [ty]. Objects are also traversed. *)
+let deep_occur t0 ty =
+  let rec occur_rec ty =
+    let ty = repr ty in
+    if ty.level >= lowest_level then begin
+      if ty == t0 then raise Occur;
+      ty.level <- pivot_level - ty.level;
+      iter_type_expr occur_rec ty
+    end
+  in
+  try
+    occur_rec ty; unmark_type ty; false
+  with Occur ->
+    unmark_type ty; true
+
+(*
+   1. When unifying two non-abbreviated types, one type is made a link
+      to the other. When unifying an abbreviated type with a
+      non-abbreviated type, the non-abbreviated type is made a link to
+      the other one. When unifying to abbreviated types, these two
+      types are kept distincts, but they are made to (temporally)
+      expand to the same type.
+   2. Abbreviations with at least one parameter are systematically
+      expanded. The overhead does not seem too high, and that way
+      abbreviations where some parameters does not appear in the
+      expansion, such as ['a t = int], are correctly handled. In
+      particular, for this example, unifying ['a t] with ['b t] keeps
+      ['a] and ['b] distincts. (Is it really important ?)
+   3. Unifying an abbreviation ['a t = 'a] with ['a] should not yield
+      ['a t as 'a]. Indeed, the type variable would otherwise be lost.
+      This problem occurs for abbreviations expanding to a type
+      variable, but also to many other constrained abbreviations (for
+      instance, [(< x : 'a > -> unit) t = <x : 'a>]). The solution is
+      that, if an abbreviation is unified with some subpart of its
+      parameters, then the parameter actually does not get
+      abbreviated.  It would be possible to check whether some
+      information is indeed lost, but it probably does not worth it.
+*)
+
+let gadt_equations_level = ref None
+
+let get_gadt_equations_level () =
+  match !gadt_equations_level with
+  | None -> assert false
+  | Some x -> x
+
+
+(* a local constraint can be added only if the rhs
+   of the constraint does not contain any Tvars.
+   They need to be removed using this function *)
+let reify env t =
+  let fresh_constr_scope = get_gadt_equations_level () in
+  let create_fresh_constr lev name =
+    let name = match name with Some s -> "$'"^s | _ -> "$" in
+    let path =
+      Path.Pident
+        (Ident.create_scoped ~scope:fresh_constr_scope
+           (get_new_abstract_name name))
+    in
+    let decl = new_declaration fresh_constr_scope None in
+    let new_env = Env.add_local_type path decl !env in
+    let t = newty2 lev (Tconstr (path,[],ref Mnil))  in
+    env := new_env;
+    path, t
+  in
+  let visited = ref TypeSet.empty in
+  let rec iterator ty =
+    let ty = repr ty in
+    if TypeSet.mem ty !visited then () else begin
+      visited := TypeSet.add ty !visited;
+      match ty.desc with
+        Tvar o ->
+          let path, t = create_fresh_constr ty.level o in
+          link_type ty t;
+          if ty.level < fresh_constr_scope then
+            raise Trace.(Unify [escape (Constructor path)])
+      | Tvariant r ->
+          let r = row_repr r in
+          if not (static_row r) then begin
+            if is_fixed r then iterator (row_more r) else
+            let m = r.row_more in
+            match m.desc with
+              Tvar o ->
+                let path, t = create_fresh_constr m.level o in
+                let row =
+                  let row_fixed = Some (Reified path) in
+                  {r with row_fields=[]; row_fixed; row_more = t} in
+                link_type m (newty2 m.level (Tvariant row));
+                if m.level < fresh_constr_scope then
+                  raise Trace.(Unify [escape (Constructor path)])
+            | _ -> assert false
+          end;
+          iter_row iterator r
+      | Tconstr (p, _, _) when is_object_type p ->
+          iter_type_expr iterator (full_expand !env ty)
+      | _ ->
+          iter_type_expr iterator ty
+    end
+  in
+  iterator t
+
+let is_newtype env p =
+  try
+    let decl = Env.find_type p env in
+    decl.type_expansion_scope <> Btype.lowest_level &&
+    decl.type_kind = Type_abstract &&
+    decl.type_private = Public
+  with Not_found -> false
+
+let non_aliasable p decl =
+  (* in_pervasives p ||  (subsumed by in_current_module) *)
+  in_current_module p && not decl.type_is_newtype
+
+let is_instantiable env p =
+  try
+    let decl = Env.find_type p env in
+    decl.type_kind = Type_abstract &&
+    decl.type_private = Public &&
+    decl.type_arity = 0 &&
+    decl.type_manifest = None &&
+    not (non_aliasable p decl)
+  with Not_found -> false
+
+
+(* PR#7113: -safe-string should be a global property *)
+let compatible_paths p1 p2 =
+  let open Predef in
+  Path.same p1 p2 ||
+  Path.same p1 path_bytes && Path.same p2 path_string ||
+  Path.same p1 path_string && Path.same p2 path_bytes
+
+(* Check for datatypes carefully; see PR#6348 *)
+let rec expands_to_datatype env ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tconstr (p, _, _) ->
+      begin try
+        is_datatype (Env.find_type p env) ||
+        expands_to_datatype env (try_expand_once env ty)
+      with Not_found | Cannot_expand -> false
+      end
+  | _ -> false
+
+(* mcomp type_pairs subst env t1 t2 does not raise an
+   exception if it is possible that t1 and t2 are actually
+   equal, assuming the types in type_pairs are equal and
+   that the mapping subst holds.
+   Assumes that both t1 and t2 do not contain any tvars
+   and that both their objects and variants are closed
+ *)
+
+let rec mcomp type_pairs env t1 t2 =
+  if t1 == t2 then () else
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if t1 == t2 then () else
+  match (t1.desc, t2.desc) with
+  | (Tvar _, _)
+  | (_, Tvar _)  ->
+      ()
+  | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
+      ()
+  | _ ->
+      let t1' = expand_head_opt env t1 in
+      let t2' = expand_head_opt env t2 in
+      (* Expansion may have changed the representative of the types... *)
+      let t1' = repr t1' and t2' = repr t2' in
+      if t1' == t2' then () else
+      begin try TypePairs.find type_pairs (t1', t2')
+      with Not_found ->
+        TypePairs.add type_pairs (t1', t2') ();
+        match (t1'.desc, t2'.desc) with
+        | (Tvar _, _)
+        | (_, Tvar _)  ->
+            ()
+        | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _))
+          when l1 = l2 || not (is_optional l1 || is_optional l2) ->
+            mcomp type_pairs env t1 t2;
+            mcomp type_pairs env u1 u2;
+        | (Ttuple tl1, Ttuple tl2) ->
+            mcomp_list type_pairs env tl1 tl2
+        | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) ->
+            mcomp_type_decl type_pairs env p1 p2 tl1 tl2
+        | (Tconstr (p, _, _), _) | (_, Tconstr (p, _, _)) ->
+            begin try
+              let decl = Env.find_type p env in
+              if non_aliasable p decl || is_datatype decl then raise (Unify [])
+            with Not_found -> ()
+            end
+        (*
+        | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) when n1 = n2 ->
+            mcomp_list type_pairs env tl1 tl2
+        *)
+        | (Tpackage _, Tpackage _) -> ()
+        | (Tvariant row1, Tvariant row2) ->
+            mcomp_row type_pairs env row1 row2
+        | (Tobject (fi1, _), Tobject (fi2, _)) ->
+            mcomp_fields type_pairs env fi1 fi2
+        | (Tfield _, Tfield _) ->       (* Actually unused *)
+            mcomp_fields type_pairs env t1' t2'
+        | (Tnil, Tnil) ->
+            ()
+        | (Tpoly (t1, []), Tpoly (t2, [])) ->
+            mcomp type_pairs env t1 t2
+        | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+            enter_poly env univar_pairs t1 tl1 t2 tl2
+              (mcomp type_pairs env)
+        | (Tunivar _, Tunivar _) ->
+            unify_univar t1' t2' !univar_pairs
+        | (_, _) ->
+            raise (Unify [])
+      end
+
+and mcomp_list type_pairs env tl1 tl2 =
+  if List.length tl1 <> List.length tl2 then
+    raise (Unify []);
+  List.iter2 (mcomp type_pairs env) tl1 tl2
+
+and mcomp_fields type_pairs env ty1 ty2 =
+  if not (concrete_object ty1 && concrete_object ty2) then assert false;
+  let (fields2, rest2) = flatten_fields ty2 in
+  let (fields1, rest1) = flatten_fields ty1 in
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  let has_present =
+    List.exists (fun (_, k, _) -> field_kind_repr k = Fpresent) in
+  mcomp type_pairs env rest1 rest2;
+  if has_present miss1  && (object_row ty2).desc = Tnil
+  || has_present miss2  && (object_row ty1).desc = Tnil then raise (Unify []);
+  List.iter
+    (function (_n, k1, t1, k2, t2) ->
+       mcomp_kind k1 k2;
+       mcomp type_pairs env t1 t2)
+    pairs
+
+and mcomp_kind k1 k2 =
+  let k1 = field_kind_repr k1 in
+  let k2 = field_kind_repr k2 in
+  match k1, k2 with
+    (Fpresent, Fabsent)
+  | (Fabsent, Fpresent) -> raise (Unify [])
+  | _                   -> ()
+
+and mcomp_row type_pairs env row1 row2 =
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
+  let cannot_erase (_,f) =
+    match row_field_repr f with
+      Rpresent _ -> true
+    | Rabsent | Reither _ -> false
+  in
+  if row1.row_closed && List.exists cannot_erase r2
+  || row2.row_closed && List.exists cannot_erase r1 then raise (Unify []);
+  List.iter
+    (fun (_,f1,f2) ->
+      match row_field_repr f1, row_field_repr f2 with
+      | Rpresent None, (Rpresent (Some _) | Reither (_, _::_, _, _) | Rabsent)
+      | Rpresent (Some _), (Rpresent None | Reither (true, _, _, _) | Rabsent)
+      | (Reither (_, _::_, _, _) | Rabsent), Rpresent None
+      | (Reither (true, _, _, _) | Rabsent), Rpresent (Some _) ->
+          raise (Unify [])
+      | Rpresent(Some t1), Rpresent(Some t2) ->
+          mcomp type_pairs env t1 t2
+      | Rpresent(Some t1), Reither(false, tl2, _, _) ->
+          List.iter (mcomp type_pairs env t1) tl2
+      | Reither(false, tl1, _, _), Rpresent(Some t2) ->
+          List.iter (mcomp type_pairs env t2) tl1
+      | _ -> ())
+    pairs
+
+and mcomp_type_decl type_pairs env p1 p2 tl1 tl2 =
+  try
+    let decl = Env.find_type p1 env in
+    let decl' = Env.find_type p2 env in
+    if compatible_paths p1 p2 then begin
+      let inj =
+        try List.map Variance.(mem Inj) (Env.find_type p1 env).type_variance
+        with Not_found -> List.map (fun _ -> false) tl1
+      in
+      List.iter2
+        (fun i (t1,t2) -> if i then mcomp type_pairs env t1 t2)
+        inj (List.combine tl1 tl2)
+    end else if non_aliasable p1 decl && non_aliasable p2 decl' then
+      raise (Unify [])
+    else
+      match decl.type_kind, decl'.type_kind with
+      | Type_record (lst,r), Type_record (lst',r') when r = r' ->
+          mcomp_list type_pairs env tl1 tl2;
+          mcomp_record_description type_pairs env lst lst'
+      | Type_variant v1, Type_variant v2 ->
+          mcomp_list type_pairs env tl1 tl2;
+          mcomp_variant_description type_pairs env v1 v2
+      | Type_open, Type_open ->
+          mcomp_list type_pairs env tl1 tl2
+      | Type_abstract, Type_abstract -> ()
+      | Type_abstract, _ when not (non_aliasable p1 decl)-> ()
+      | _, Type_abstract when not (non_aliasable p2 decl') -> ()
+      | _ -> raise (Unify [])
+  with Not_found -> ()
+
+and mcomp_type_option type_pairs env t t' =
+  match t, t' with
+    None, None -> ()
+  | Some t, Some t' -> mcomp type_pairs env t t'
+  | _ -> raise (Unify [])
+
+and mcomp_variant_description type_pairs env xs ys =
+  let rec iter = fun x y ->
+    match x, y with
+    | c1 :: xs, c2 :: ys   ->
+      mcomp_type_option type_pairs env c1.cd_res c2.cd_res;
+      begin match c1.cd_args, c2.cd_args with
+      | Cstr_tuple l1, Cstr_tuple l2 -> mcomp_list type_pairs env l1 l2
+      | Cstr_record l1, Cstr_record l2 ->
+          mcomp_record_description type_pairs env l1 l2
+      | _ -> raise (Unify [])
+      end;
+     if Ident.name c1.cd_id = Ident.name c2.cd_id
+      then iter xs ys
+      else raise (Unify [])
+    | [],[] -> ()
+    | _ -> raise (Unify [])
+  in
+  iter xs ys
+
+and mcomp_record_description type_pairs env =
+  let rec iter x y =
+    match x, y with
+    | l1 :: xs, l2 :: ys ->
+        mcomp type_pairs env l1.ld_type l2.ld_type;
+        if Ident.name l1.ld_id = Ident.name l2.ld_id &&
+           l1.ld_mutable = l2.ld_mutable
+        then iter xs ys
+        else raise (Unify [])
+    | [], [] -> ()
+    | _ -> raise (Unify [])
+  in
+  iter
+
+let mcomp env t1 t2 =
+  mcomp (TypePairs.create 4) env t1 t2
+
+(* Real unification *)
+
+let find_lowest_level ty =
+  let lowest = ref generic_level in
+  let rec find ty =
+    let ty = repr ty in
+    if ty.level >= lowest_level then begin
+      if ty.level < !lowest then lowest := ty.level;
+      ty.level <- pivot_level - ty.level;
+      iter_type_expr find ty
+    end
+  in find ty; unmark_type ty; !lowest
+
+let find_expansion_scope env path =
+  (Env.find_type path env).type_expansion_scope
+
+let add_gadt_equation env source destination =
+  (* Format.eprintf "@[add_gadt_equation %s %a@]@."
+    (Path.name source) !Btype.print_raw destination; *)
+  if local_non_recursive_abbrev !env source destination then begin
+    let destination = duplicate_type destination in
+    let expansion_scope =
+      max (Path.scope source) (get_gadt_equations_level ())
+    in
+    let decl = new_declaration expansion_scope (Some destination) in
+    env := Env.add_local_type source decl !env;
+    cleanup_abbrev ()
+  end
+
+let unify_eq_set = TypePairs.create 11
+
+let order_type_pair t1 t2 =
+  if t1.id <= t2.id then (t1, t2) else (t2, t1)
+
+let add_type_equality t1 t2 =
+  TypePairs.add unify_eq_set (order_type_pair t1 t2) ()
+
+let eq_package_path env p1 p2 =
+  Path.same p1 p2 ||
+  Path.same (normalize_package_path env p1) (normalize_package_path env p2)
+
+let nondep_type' = ref (fun _ _ _ -> assert false)
+let package_subtype = ref (fun _ _ _ _ _ _ _ -> assert false)
+
+let rec concat_longident lid1 =
+  let open Longident in
+  function
+    Lident s -> Ldot (lid1, s)
+  | Ldot (lid2, s) -> Ldot (concat_longident lid1 lid2, s)
+  | Lapply (lid2, lid) -> Lapply (concat_longident lid1 lid2, lid)
+
+let nondep_instance env level id ty =
+  let ty = !nondep_type' env [id] ty in
+  if level = generic_level then duplicate_type ty else
+  let old = !current_level in
+  current_level := level;
+  let ty = instance ty in
+  current_level := old;
+  ty
+
+(* Find the type paths nl1 in the module type mty2, and add them to the
+   list (nl2, tl2). raise Not_found if impossible *)
+let complete_type_list ?(allow_absent=false) env nl1 lv2 mty2 nl2 tl2 =
+  (* This is morally WRONG: we're adding a (dummy) module without a scope in the
+     environment. However no operation which cares about levels/scopes is going
+     to happen while this module exists.
+     The only operations that happen are:
+     - Env.find_type_by_name
+     - nondep_instance
+     None of which check the scope.
+
+     It'd be nice if we avoided creating such temporary dummy modules and broken
+     environments though. *)
+  let id2 = Ident.create_local "Pkg" in
+  let env' = Env.add_module id2 Mp_present mty2 env in
+  let rec complete nl1 ntl2 =
+    match nl1, ntl2 with
+      [], _ -> ntl2
+    | n :: nl, (n2, _ as nt2) :: ntl' when n >= n2 ->
+        nt2 :: complete (if n = n2 then nl else nl1) ntl'
+    | n :: nl, _ ->
+        let lid = concat_longident (Longident.Lident "Pkg") n in
+        match Env.find_type_by_name lid env' with
+        | (_, {type_arity = 0; type_kind = Type_abstract;
+               type_private = Public; type_manifest = Some t2}) ->
+            (n, nondep_instance env' lv2 id2 t2) :: complete nl ntl2
+        | (_, {type_arity = 0; type_kind = Type_abstract;
+               type_private = Public; type_manifest = None})
+          when allow_absent ->
+            complete nl ntl2
+        | _ -> raise Exit
+        | exception Not_found when allow_absent->
+            complete nl ntl2
+  in
+  match complete nl1 (List.combine nl2 tl2) with
+  | res -> res
+  | exception Exit -> raise Not_found
+
+(* raise Not_found rather than Unify if the module types are incompatible *)
+let unify_package env unify_list lv1 p1 n1 tl1 lv2 p2 n2 tl2 =
+  let ntl2 = complete_type_list env n1 lv2 (Mty_ident p2) n2 tl2
+  and ntl1 = complete_type_list env n2 lv1 (Mty_ident p1) n1 tl1 in
+  unify_list (List.map snd ntl1) (List.map snd ntl2);
+  if eq_package_path env p1 p2
+  || !package_subtype env p1 n1 tl1 p2 n2 tl2
+  && !package_subtype env p2 n2 tl2 p1 n1 tl1 then () else raise Not_found
+
+
+(* force unification in Reither when one side has a non-conjunctive type *)
+let rigid_variants = ref false
+
+let unify_eq t1 t2 =
+  t1 == t2 ||
+  match !umode with
+  | Expression -> false
+  | Pattern ->
+      try TypePairs.find unify_eq_set (order_type_pair t1 t2); true
+      with Not_found -> false
+
+let unify1_var env t1 t2 =
+  assert (is_Tvar t1);
+  occur env t1 t2;
+  occur_univar env t2;
+  let d1 = t1.desc in
+  link_type t1 t2;
+  try
+    update_level env t1.level t2;
+    update_scope t1.scope t2
+  with Unify _ as e ->
+    t1.desc <- d1;
+    raise e
+
+let rec unify (env:Env.t ref) t1 t2 =
+  (* First step: special cases (optimizations) *)
+  if t1 == t2 then () else
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if unify_eq t1 t2 then () else
+  let reset_tracing = check_trace_gadt_instances !env in
+
+  try
+    type_changed := true;
+    begin match (t1.desc, t2.desc) with
+      (Tvar _, Tconstr _) when deep_occur t1 t2 ->
+        unify2 env t1 t2
+    | (Tconstr _, Tvar _) when deep_occur t2 t1 ->
+        unify2 env t1 t2
+    | (Tvar _, _) ->
+        unify1_var !env t1 t2
+    | (_, Tvar _) ->
+        unify1_var !env t2 t1
+    | (Tunivar _, Tunivar _) ->
+        unify_univar t1 t2 !univar_pairs;
+        update_level !env t1.level t2;
+        update_scope t1.scope t2;
+        link_type t1 t2
+    | (Tconstr (p1, [], a1), Tconstr (p2, [], a2))
+          when Path.same p1 p2 (* && actual_mode !env = Old *)
+            (* This optimization assumes that t1 does not expand to t2
+               (and conversely), so we fall back to the general case
+               when any of the types has a cached expansion. *)
+            && not (has_cached_expansion p1 !a1
+                 || has_cached_expansion p2 !a2) ->
+        update_level !env t1.level t2;
+        update_scope t1.scope t2;
+        link_type t1 t2
+    | (Tconstr (p1, [], _), Tconstr (p2, [], _))
+      when Env.has_local_constraints !env
+      && is_newtype !env p1 && is_newtype !env p2 ->
+        (* Do not use local constraints more than necessary *)
+        begin try
+          if find_expansion_scope !env p1 > find_expansion_scope !env p2 then
+            unify env t1 (try_expand_once !env t2)
+          else
+            unify env (try_expand_once !env t1) t2
+        with Cannot_expand ->
+          unify2 env t1 t2
+        end
+    | _ ->
+        unify2 env t1 t2
+    end;
+    reset_trace_gadt_instances reset_tracing;
+  with Unify trace ->
+    reset_trace_gadt_instances reset_tracing;
+    raise( Unify (Trace.diff t1 t2 :: trace) )
+
+and unify2 env t1 t2 =
+  (* Second step: expansion of abbreviations *)
+  (* Expansion may change the representative of the types. *)
+  ignore (expand_head_unif !env t1);
+  ignore (expand_head_unif !env t2);
+  let t1' = expand_head_unif !env t1 in
+  let t2' = expand_head_unif !env t2 in
+  let lv = min t1'.level t2'.level in
+  let scope = max t1'.scope t2'.scope in
+  update_level !env lv t2;
+  update_level !env lv t1;
+  update_scope scope t2;
+  update_scope scope t1;
+  if unify_eq t1' t2' then () else
+
+  let t1 = repr t1 and t2 = repr t2 in
+  let t1, t2 =
+    if !Clflags.principal
+    && (find_lowest_level t1' < lv || find_lowest_level t2' < lv) then
+      (* Expand abbreviations hiding a lower level *)
+      (* Should also do it for parameterized types, after unification... *)
+      (match t1.desc with Tconstr (_, [], _) -> t1' | _ -> t1),
+      (match t2.desc with Tconstr (_, [], _) -> t2' | _ -> t2)
+    else (t1, t2)
+  in
+  if unify_eq t1 t1' || not (unify_eq t2 t2') then
+    unify3 env t1 t1' t2 t2'
+  else
+    try unify3 env t2 t2' t1 t1' with Unify trace ->
+      raise (Unify (Trace.swap trace))
+
+and unify3 env t1 t1' t2 t2' =
+  (* Third step: truly unification *)
+  (* Assumes either [t1 == t1'] or [t2 != t2'] *)
+  let d1 = t1'.desc and d2 = t2'.desc in
+  let create_recursion = (t2 != t2') && (deep_occur t1' t2) in
+
+  begin match (d1, d2) with (* handle vars and univars specially *)
+    (Tunivar _, Tunivar _) ->
+      unify_univar t1' t2' !univar_pairs;
+      link_type t1' t2'
+  | (Tvar _, _) ->
+      occur !env t1' t2;
+      occur_univar !env t2;
+      link_type t1' t2;
+  | (_, Tvar _) ->
+      occur !env t2' t1;
+      occur_univar !env t1;
+      link_type t2' t1;
+  | (Tfield _, Tfield _) -> (* special case for GADTs *)
+      unify_fields env t1' t2'
+  | _ ->
+    begin match !umode with
+    | Expression ->
+        occur !env t1' t2';
+        if is_self_type d1 (* PR#7711: do not abbreviate self type *)
+        then link_type t1' t2'
+        else link_type t1' t2
+    | Pattern ->
+        add_type_equality t1' t2'
+    end;
+    try
+      begin match (d1, d2) with
+        (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2 ||
+        (!Clflags.classic || !umode = Pattern) &&
+        not (is_optional l1 || is_optional l2) ->
+          unify  env t1 t2; unify env  u1 u2;
+          begin match commu_repr c1, commu_repr c2 with
+            Clink r, c2 -> set_commu r c2
+          | c1, Clink r -> set_commu r c1
+          | _ -> ()
+          end
+      | (Ttuple tl1, Ttuple tl2) ->
+          unify_list env tl1 tl2
+      | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 ->
+          if !umode = Expression || not !generate_equations then
+            unify_list env tl1 tl2
+          else if !assume_injective then
+            set_mode_pattern ~generate:true ~injective:false
+                             (fun () -> unify_list env tl1 tl2)
+          else if in_current_module p1 (* || in_pervasives p1 *)
+                  || List.exists (expands_to_datatype !env) [t1'; t1; t2] then
+            unify_list env tl1 tl2
+          else
+            let inj =
+              try List.map Variance.(mem Inj)
+                    (Env.find_type p1 !env).type_variance
+              with Not_found -> List.map (fun _ -> false) tl1
+            in
+            List.iter2
+              (fun i (t1, t2) ->
+                if i then unify env t1 t2 else
+                set_mode_pattern ~generate:false ~injective:false
+                  begin fun () ->
+                    let snap = snapshot () in
+                    try unify env t1 t2 with Unify _ ->
+                      backtrack snap;
+                      reify env t1; reify env t2
+                  end)
+              inj (List.combine tl1 tl2)
+      | (Tconstr (path,[],_),
+         Tconstr (path',[],_))
+        when is_instantiable !env path && is_instantiable !env path'
+        && !generate_equations ->
+          let source, destination =
+            if Path.scope path > Path.scope path'
+            then  path , t2'
+            else  path', t1'
+          in
+          add_gadt_equation env source destination
+      | (Tconstr (path,[],_), _)
+        when is_instantiable !env path && !generate_equations ->
+          reify env t2';
+          add_gadt_equation env path t2'
+      | (_, Tconstr (path,[],_))
+        when is_instantiable !env path && !generate_equations ->
+          reify env t1';
+          add_gadt_equation env path t1'
+      | (Tconstr (_,_,_), _) | (_, Tconstr (_,_,_)) when !umode = Pattern ->
+          reify env t1';
+          reify env t2';
+          if !generate_equations then mcomp !env t1' t2'
+      | (Tobject (fi1, nm1), Tobject (fi2, _)) ->
+          unify_fields env fi1 fi2;
+          (* Type [t2'] may have been instantiated by [unify_fields] *)
+          (* XXX One should do some kind of unification... *)
+          begin match (repr t2').desc with
+            Tobject (_, {contents = Some (_, va::_)}) when
+              (match (repr va).desc with
+                Tvar _|Tunivar _|Tnil -> true | _ -> false) -> ()
+          | Tobject (_, nm2) -> set_name nm2 !nm1
+          | _ -> ()
+          end
+      | (Tvariant row1, Tvariant row2) ->
+          if !umode = Expression then
+            unify_row env row1 row2
+          else begin
+            let snap = snapshot () in
+            try unify_row env row1 row2
+            with Unify _ ->
+              backtrack snap;
+              reify env t1';
+              reify env t2';
+              if !generate_equations then mcomp !env t1' t2'
+          end
+      | (Tfield(f,kind,_,rem), Tnil) | (Tnil, Tfield(f,kind,_,rem)) ->
+          begin match field_kind_repr kind with
+            Fvar r when f <> dummy_method ->
+              set_kind r Fabsent;
+              if d2 = Tnil then unify env rem t2'
+              else unify env (newty2 rem.level Tnil) rem
+          | _      ->
+              if f = dummy_method then
+                raise (Unify Trace.[Obj Self_cannot_be_closed])
+              else if d1 = Tnil then
+                raise (Unify Trace.[Obj(Missing_field (First, f))])
+              else
+                raise (Unify Trace.[Obj(Missing_field (Second, f))])
+          end
+      | (Tnil, Tnil) ->
+          ()
+      | (Tpoly (t1, []), Tpoly (t2, [])) ->
+          unify env t1 t2
+      | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+          enter_poly !env univar_pairs t1 tl1 t2 tl2 (unify env)
+      | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) ->
+          begin try
+            unify_package !env (unify_list env)
+              t1.level p1 n1 tl1 t2.level p2 n2 tl2
+          with Not_found ->
+            if !umode = Expression then raise (Unify []);
+            List.iter (reify env) (tl1 @ tl2);
+            (* if !generate_equations then List.iter2 (mcomp !env) tl1 tl2 *)
+          end
+      | (Tnil,  Tconstr _ ) -> raise (Unify Trace.[Obj(Abstract_row Second)])
+      | (Tconstr _,  Tnil ) -> raise (Unify Trace.[Obj(Abstract_row First)])
+      | (_, _) -> raise (Unify [])
+      end;
+      (* XXX Commentaires + changer "create_recursion"
+         ||| Comments + change "create_recursion" *)
+      if create_recursion then
+        match t2.desc with
+          Tconstr (p, tl, abbrev) ->
+            forget_abbrev abbrev p;
+            let t2'' = expand_head_unif !env t2 in
+            if not (closed_parameterized_type tl t2'') then
+              link_type (repr t2) (repr t2')
+        | _ ->
+            () (* t2 has already been expanded by update_level *)
+    with Unify trace ->
+      t1'.desc <- d1;
+      raise (Unify trace)
+  end
+
+and unify_list env tl1 tl2 =
+  if List.length tl1 <> List.length tl2 then
+    raise (Unify []);
+  List.iter2 (unify env) tl1 tl2
+
+(* Build a fresh row variable for unification *)
+and make_rowvar level use1 rest1 use2 rest2  =
+  let set_name ty name =
+    match ty.desc with
+      Tvar None -> set_type_desc ty (Tvar name)
+    | _ -> ()
+  in
+  let name =
+    match rest1.desc, rest2.desc with
+      Tvar (Some _ as name1), Tvar (Some _ as name2) ->
+        if rest1.level <= rest2.level then name1 else name2
+    | Tvar (Some _ as name), _ ->
+        if use2 then set_name rest2 name; name
+    | _, Tvar (Some _ as name) ->
+        if use1 then set_name rest2 name; name
+    | _ -> None
+  in
+  if use1 then rest1 else
+  if use2 then rest2 else newvar2 ?name level
+
+and unify_fields env ty1 ty2 =          (* Optimization *)
+  let (fields1, rest1) = flatten_fields ty1
+  and (fields2, rest2) = flatten_fields ty2 in
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  let l1 = (repr ty1).level and l2 = (repr ty2).level in
+  let va = make_rowvar (min l1 l2) (miss2=[]) rest1 (miss1=[]) rest2 in
+  let d1 = rest1.desc and d2 = rest2.desc in
+  try
+    unify env (build_fields l1 miss1 va) rest2;
+    unify env rest1 (build_fields l2 miss2 va);
+    List.iter
+      (fun (n, k1, t1, k2, t2) ->
+        unify_kind k1 k2;
+        try
+          if !trace_gadt_instances then begin
+            update_level !env va.level t1;
+            update_scope va.scope t1
+          end;
+          unify env t1 t2
+        with Unify trace ->
+          raise( Unify (Trace.incompatible_fields n t1 t2 :: trace) )
+      )
+      pairs
+  with exn ->
+    set_type_desc rest1 d1;
+    set_type_desc rest2 d2;
+    raise exn
+
+and unify_kind k1 k2 =
+  let k1 = field_kind_repr k1 in
+  let k2 = field_kind_repr k2 in
+  if k1 == k2 then () else
+  match k1, k2 with
+    (Fvar r, (Fvar _ | Fpresent)) -> set_kind r k2
+  | (Fpresent, Fvar r)            -> set_kind r k1
+  | (Fpresent, Fpresent)          -> ()
+  | _                             -> assert false
+
+and unify_row env row1 row2 =
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let rm1 = row_more row1 and rm2 = row_more row2 in
+  if unify_eq rm1 rm2 then () else
+  let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
+  if r1 <> [] && r2 <> [] then begin
+    let ht = Hashtbl.create (List.length r1) in
+    List.iter (fun (l,_) -> Hashtbl.add ht (hash_variant l) l) r1;
+    List.iter
+      (fun (l,_) ->
+        try raise (Tags(l, Hashtbl.find ht (hash_variant l)))
+        with Not_found -> ())
+      r2
+  end;
+  let fixed1 = fixed_explanation row1 and fixed2 = fixed_explanation row2 in
+  let more = match fixed1, fixed2 with
+    | Some _, Some _ -> if rm2.level < rm1.level then rm2 else rm1
+    | Some _, None -> rm1
+    | None, Some _ -> rm2
+    | None, None -> newty2 (min rm1.level rm2.level) (Tvar None)
+  in
+  let fixed = merge_fixed_explanation fixed1 fixed2
+  and closed = row1.row_closed || row2.row_closed in
+  let keep switch =
+    List.for_all
+      (fun (_,f1,f2) ->
+        let f1, f2 = switch f1 f2 in
+        row_field_repr f1 = Rabsent || row_field_repr f2 <> Rabsent)
+      pairs
+  in
+  let empty fields =
+    List.for_all (fun (_,f) -> row_field_repr f = Rabsent) fields in
+  (* Check whether we are going to build an empty type *)
+  if closed && (empty r1 || row2.row_closed) && (empty r2 || row1.row_closed)
+  && List.for_all
+      (fun (_,f1,f2) ->
+        row_field_repr f1 = Rabsent || row_field_repr f2 = Rabsent)
+      pairs
+  then raise Trace.( Unify [Variant No_intersection] );
+  let name =
+    if row1.row_name <> None && (row1.row_closed || empty r2) &&
+      (not row2.row_closed || keep (fun f1 f2 -> f1, f2) && empty r1)
+    then row1.row_name
+    else if row2.row_name <> None && (row2.row_closed || empty r1) &&
+      (not row1.row_closed || keep (fun f1 f2 -> f2, f1) && empty r2)
+    then row2.row_name
+    else None
+  in
+  let row0 = {row_fields = []; row_more = more; row_bound = ();
+              row_closed = closed; row_fixed = fixed; row_name = name} in
+  let set_more row rest =
+    let rest =
+      if closed then
+        filter_row_fields row.row_closed rest
+      else rest in
+    begin match fixed_explanation row with
+      | None ->
+          if rest <> [] && row.row_closed then
+            let pos = if row == row1 then Trace.First else Trace.Second in
+            raise Trace.(Unify [Variant (No_tags(pos,rest))])
+      | Some fixed ->
+          let pos = if row == row1 then Trace.First else Trace.Second in
+          if closed && not row.row_closed then
+            raise Trace.(Unify [Variant(Fixed_row(pos,Cannot_be_closed,fixed))])
+          else if rest <> [] then
+            let case = Trace.Cannot_add_tags (List.map fst rest) in
+            raise Trace.(Unify [Variant(Fixed_row(pos,case,fixed))])
+    end;
+    (* The following test is not principal... should rather use Tnil *)
+    let rm = row_more row in
+    (*if !trace_gadt_instances && rm.desc = Tnil then () else*)
+    if !trace_gadt_instances then
+      update_level !env rm.level (newgenty (Tvariant row));
+    if row_fixed row then
+      if more == rm then () else
+      if is_Tvar rm then link_type rm more else unify env rm more
+    else
+      let ty = newgenty (Tvariant {row0 with row_fields = rest}) in
+      update_level !env rm.level ty;
+      update_scope rm.scope ty;
+      link_type rm ty
+  in
+  let md1 = rm1.desc and md2 = rm2.desc in
+  begin try
+    set_more row2 r1;
+    set_more row1 r2;
+    List.iter
+      (fun (l,f1,f2) ->
+        try unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2
+        with Unify trace ->
+          raise Trace.( Unify( Variant (Incompatible_types_for l) :: trace ))
+      )
+      pairs;
+    if static_row row1 then begin
+      let rm = row_more row1 in
+      if is_Tvar rm then link_type rm (newty2 rm.level Tnil)
+    end
+  with exn ->
+    set_type_desc rm1 md1; set_type_desc rm2 md2; raise exn
+  end
+
+and unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 =
+  let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
+  let if_not_fixed (pos,fixed) f =
+    match fixed with
+    | None -> f ()
+    | Some fix ->
+        let tr = Trace.[ Variant (Fixed_row (pos,Cannot_add_tags [l],fix)) ] in
+        raise (Unify tr) in
+  let first = Trace.First, fixed1 and second = Trace.Second, fixed2 in
+  let either_fixed = match fixed1, fixed2 with
+    | None, None -> false
+    | _ -> true in
+  if f1 == f2 then () else
+  match f1, f2 with
+    Rpresent(Some t1), Rpresent(Some t2) -> unify env t1 t2
+  | Rpresent None, Rpresent None -> ()
+  | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) ->
+      if e1 == e2 then () else
+      if either_fixed && not (c1 || c2)
+      && List.length tl1 = List.length tl2 then begin
+        (* PR#7496 *)
+        let f = Reither (c1 || c2, [], m1 || m2, ref None) in
+        set_row_field e1 f; set_row_field e2 f;
+        List.iter2 (unify env) tl1 tl2
+      end
+      else let redo =
+        (m1 || m2 || either_fixed ||
+         !rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) &&
+        begin match tl1 @ tl2 with [] -> false
+        | t1 :: tl ->
+            if c1 || c2 then raise (Unify []);
+            List.iter (unify env t1) tl;
+            !e1 <> None || !e2 <> None
+        end in
+      if redo then unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 else
+      let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
+      let rec remq tl = function [] -> []
+        | ty :: tl' ->
+            if List.memq ty tl then remq tl tl' else ty :: remq tl tl'
+      in
+      let tl1' = remq tl2 tl1 and tl2' = remq tl1 tl2 in
+      (* PR#6744 *)
+      let split_univars =
+        List.partition
+          (fun ty -> try occur_univar !env ty; true with Unify _ -> false) in
+      let (tl1',tlu1) = split_univars tl1'
+      and (tl2',tlu2) = split_univars tl2' in
+      begin match tlu1, tlu2 with
+        [], [] -> ()
+      | (tu1::tlu1), _ :: _ ->
+          (* Attempt to merge all the types containing univars *)
+          List.iter (unify env tu1) (tlu1@tlu2)
+      | (tu::_, []) | ([], tu::_) -> occur_univar !env tu
+      end;
+      (* Is this handling of levels really principal? *)
+      List.iter (fun ty ->
+        let rm = repr rm2 in
+        update_level !env rm.level ty;
+        update_scope rm.scope ty;
+      ) tl1';
+      List.iter (fun ty ->
+        let rm = repr rm1 in
+        update_level !env rm.level ty;
+        update_scope rm.scope ty;
+      ) tl2';
+      let e = ref None in
+      let f1' = Reither(c1 || c2, tl2', m1 || m2, e)
+      and f2' = Reither(c1 || c2, tl1', m1 || m2, e) in
+      set_row_field e1 f1'; set_row_field e2 f2';
+  | Reither(_, _, false, e1), Rabsent ->
+      if_not_fixed first (fun () -> set_row_field e1 f2)
+  | Rabsent, Reither(_, _, false, e2) ->
+      if_not_fixed second (fun () -> set_row_field e2 f1)
+  | Rabsent, Rabsent -> ()
+  | Reither(false, tl, _, e1), Rpresent(Some t2) ->
+      if_not_fixed first (fun () ->
+          set_row_field e1 f2;
+          let rm = repr rm1 in
+          update_level !env rm.level t2;
+          update_scope rm.scope t2;
+          (try List.iter (fun t1 -> unify env t1 t2) tl
+           with exn -> e1 := None; raise exn)
+        )
+  | Rpresent(Some t1), Reither(false, tl, _, e2) ->
+      if_not_fixed second (fun () ->
+          set_row_field e2 f1;
+          let rm = repr rm2 in
+          update_level !env rm.level t1;
+          update_scope rm.scope t1;
+          (try List.iter (unify env t1) tl
+           with exn -> e2 := None; raise exn)
+        )
+  | Reither(true, [], _, e1), Rpresent None ->
+      if_not_fixed first (fun () -> set_row_field e1 f2)
+  | Rpresent None, Reither(true, [], _, e2) ->
+      if_not_fixed second (fun () -> set_row_field e2 f1)
+  | _ -> raise (Unify [])
+
+
+let unify env ty1 ty2 =
+  let snap = Btype.snapshot () in
+  try
+    unify env ty1 ty2
+  with
+    Unify trace ->
+      undo_compress snap;
+      raise (Unify (expand_trace !env trace))
+
+let unify_gadt ~equations_level:lev (env:Env.t ref) ty1 ty2 =
+  try
+    univar_pairs := [];
+    gadt_equations_level := Some lev;
+    set_mode_pattern ~generate:true ~injective:true
+                     (fun () -> unify env ty1 ty2);
+    gadt_equations_level := None;
+    TypePairs.clear unify_eq_set;
+  with e ->
+    gadt_equations_level := None;
+    TypePairs.clear unify_eq_set;
+    raise e
+
+let unify_var env t1 t2 =
+  let t1 = repr t1 and t2 = repr t2 in
+  if t1 == t2 then () else
+  match t1.desc, t2.desc with
+    Tvar _, Tconstr _ when deep_occur t1 t2 ->
+      unify (ref env) t1 t2
+  | Tvar _, _ ->
+      let reset_tracing = check_trace_gadt_instances env in
+      begin try
+        occur env t1 t2;
+        update_level env t1.level t2;
+        update_scope t1.scope t2;
+        link_type t1 t2;
+        reset_trace_gadt_instances reset_tracing;
+      with Unify trace ->
+        reset_trace_gadt_instances reset_tracing;
+        let expanded_trace = expand_trace env @@ Trace.diff t1 t2 :: trace in
+        raise (Unify expanded_trace)
+      end
+  | _ ->
+      unify (ref env) t1 t2
+
+let _ = unify' := unify_var
+
+let unify_pairs env ty1 ty2 pairs =
+  univar_pairs := pairs;
+  unify env ty1 ty2
+
+let unify env ty1 ty2 =
+  unify_pairs (ref env) ty1 ty2 []
+
+
+
+(**** Special cases of unification ****)
+
+let expand_head_trace env t =
+  let reset_tracing = check_trace_gadt_instances env in
+  let t = expand_head_unif env t in
+  reset_trace_gadt_instances reset_tracing;
+  t
+
+(*
+   Unify [t] and [l:'a -> 'b]. Return ['a] and ['b].
+   In label mode, label mismatch is accepted when
+   (1) the requested label is ""
+   (2) the original label is not optional
+*)
+
+let filter_arrow env t l =
+  let t = expand_head_trace env t in
+  match t.desc with
+    Tvar _ ->
+      let lv = t.level in
+      let t1 = newvar2 lv and t2 = newvar2 lv in
+      let t' = newty2 lv (Tarrow (l, t1, t2, Cok)) in
+      link_type t t';
+      (t1, t2)
+  | Tarrow(l', t1, t2, _)
+    when l = l' || !Clflags.classic && l = Nolabel && not (is_optional l') ->
+      (t1, t2)
+  | _ ->
+      raise (Unify [])
+
+(* Used by [filter_method]. *)
+let rec filter_method_field env name priv ty =
+  let ty = expand_head_trace env ty in
+  match ty.desc with
+    Tvar _ ->
+      let level = ty.level in
+      let ty1 = newvar2 level and ty2 = newvar2 level in
+      let ty' = newty2 level (Tfield (name,
+                                      begin match priv with
+                                        Private -> Fvar (ref None)
+                                      | Public  -> Fpresent
+                                      end,
+                                      ty1, ty2))
+      in
+      link_type ty ty';
+      ty1
+  | Tfield(n, kind, ty1, ty2) ->
+      let kind = field_kind_repr kind in
+      if (n = name) && (kind <> Fabsent) then begin
+        if priv = Public then
+          unify_kind kind Fpresent;
+        ty1
+      end else
+        filter_method_field env name priv ty2
+  | _ ->
+      raise (Unify [])
+
+(* Unify [ty] and [< name : 'a; .. >]. Return ['a]. *)
+let filter_method env name priv ty =
+  let ty = expand_head_trace env ty in
+  match ty.desc with
+    Tvar _ ->
+      let ty1 = newvar () in
+      let ty' = newobj ty1 in
+      update_level env ty.level ty';
+      update_scope ty.scope ty';
+      link_type ty ty';
+      filter_method_field env name priv ty1
+  | Tobject(f, _) ->
+      filter_method_field env name priv f
+  | _ ->
+      raise (Unify [])
+
+let check_filter_method env name priv ty =
+  ignore(filter_method env name priv ty)
+
+let filter_self_method env lab priv meths ty =
+  let ty' = filter_method env lab priv ty in
+  try
+    Meths.find lab !meths
+  with Not_found ->
+    let pair = (Ident.create_local lab, ty') in
+    meths := Meths.add lab pair !meths;
+    pair
+
+
+                        (***********************************)
+                        (*  Matching between type schemes  *)
+                        (***********************************)
+
+(*
+   Update the level of [ty]. First check that the levels of generic
+   variables from the subject are not lowered.
+*)
+let moregen_occur env level ty =
+  let rec occur ty =
+    let ty = repr ty in
+    if ty.level > level then begin
+      if is_Tvar ty && ty.level >= generic_level - 1 then raise Occur;
+      ty.level <- pivot_level - ty.level;
+      iter_type_expr occur ty
+    end
+  in
+  begin try
+    occur ty; unmark_type ty
+  with Occur ->
+    unmark_type ty; raise (Unify [])
+  end;
+  (* also check for free univars *)
+  occur_univar env ty;
+  update_level env level ty
+
+let may_instantiate inst_nongen t1 =
+  if inst_nongen then t1.level <> generic_level - 1
+                 else t1.level =  generic_level
+
+let rec moregen inst_nongen type_pairs env t1 t2 =
+  if t1 == t2 then () else
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if t1 == t2 then () else
+
+  try
+    match (t1.desc, t2.desc) with
+      (Tvar _, _) when may_instantiate inst_nongen t1 ->
+        moregen_occur env t1.level t2;
+        update_scope t1.scope t2;
+        occur env t1 t2;
+        link_type t1 t2
+    | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
+        ()
+    | _ ->
+        let t1' = expand_head env t1 in
+        let t2' = expand_head env t2 in
+        (* Expansion may have changed the representative of the types... *)
+        let t1' = repr t1' and t2' = repr t2' in
+        if t1' == t2' then () else
+        begin try
+          TypePairs.find type_pairs (t1', t2')
+        with Not_found ->
+          TypePairs.add type_pairs (t1', t2') ();
+          match (t1'.desc, t2'.desc) with
+            (Tvar _, _) when may_instantiate inst_nongen t1' ->
+              moregen_occur env t1'.level t2;
+              update_scope t1'.scope t2;
+              link_type t1' t2
+          | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2
+            || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
+              moregen inst_nongen type_pairs env t1 t2;
+              moregen inst_nongen type_pairs env u1 u2
+          | (Ttuple tl1, Ttuple tl2) ->
+              moregen_list inst_nongen type_pairs env tl1 tl2
+          | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
+                when Path.same p1 p2 ->
+              moregen_list inst_nongen type_pairs env tl1 tl2
+          | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) ->
+              begin try
+                unify_package env (moregen_list inst_nongen type_pairs env)
+                  t1'.level p1 n1 tl1 t2'.level p2 n2 tl2
+              with Not_found -> raise (Unify [])
+              end
+          | (Tvariant row1, Tvariant row2) ->
+              moregen_row inst_nongen type_pairs env row1 row2
+          | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) ->
+              moregen_fields inst_nongen type_pairs env fi1 fi2
+          | (Tfield _, Tfield _) ->           (* Actually unused *)
+              moregen_fields inst_nongen type_pairs env t1' t2'
+          | (Tnil, Tnil) ->
+              ()
+          | (Tpoly (t1, []), Tpoly (t2, [])) ->
+              moregen inst_nongen type_pairs env t1 t2
+          | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+              enter_poly env univar_pairs t1 tl1 t2 tl2
+                (moregen inst_nongen type_pairs env)
+          | (Tunivar _, Tunivar _) ->
+              unify_univar t1' t2' !univar_pairs
+          | (_, _) ->
+              raise (Unify [])
+        end
+  with Unify trace ->  raise( Unify ( Trace.diff t1 t2 :: trace ) )
+
+and moregen_list inst_nongen type_pairs env tl1 tl2 =
+  if List.length tl1 <> List.length tl2 then
+    raise (Unify []);
+  List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2
+
+and moregen_fields inst_nongen type_pairs env ty1 ty2 =
+  let (fields1, rest1) = flatten_fields ty1
+  and (fields2, rest2) = flatten_fields ty2 in
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  if miss1 <> [] then raise (Unify []);
+  moregen inst_nongen type_pairs env rest1
+    (build_fields (repr ty2).level miss2 rest2);
+  List.iter
+    (fun (n, k1, t1, k2, t2) ->
+       moregen_kind k1 k2;
+       try moregen inst_nongen type_pairs env t1 t2 with Unify trace ->
+         let e = Trace.diff
+             (newty (Tfield(n, k1, t1, rest2)))
+             (newty (Tfield(n, k2, t2, rest2))) in
+         raise( Unify ( e :: trace ) )
+    )
+    pairs
+
+and moregen_kind k1 k2 =
+  let k1 = field_kind_repr k1 in
+  let k2 = field_kind_repr k2 in
+  if k1 == k2 then () else
+  match k1, k2 with
+    (Fvar r, (Fvar _ | Fpresent))  -> set_kind r k2
+  | (Fpresent, Fpresent)           -> ()
+  | _                              -> raise (Unify [])
+
+and moregen_row inst_nongen type_pairs env row1 row2 =
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let rm1 = repr row1.row_more and rm2 = repr row2.row_more in
+  if rm1 == rm2 then () else
+  let may_inst =
+    is_Tvar rm1 && may_instantiate inst_nongen rm1 || rm1.desc = Tnil in
+  let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
+  let r1, r2 =
+    if row2.row_closed then
+      filter_row_fields may_inst r1, filter_row_fields false r2
+    else r1, r2
+  in
+  if r1 <> [] || row1.row_closed && (not row2.row_closed || r2 <> [])
+  then raise (Unify []);
+  begin match rm1.desc, rm2.desc with
+    Tunivar _, Tunivar _ ->
+      unify_univar rm1 rm2 !univar_pairs
+  | Tunivar _, _ | _, Tunivar _ ->
+      raise (Unify [])
+  | _ when static_row row1 -> ()
+  | _ when may_inst ->
+      let ext =
+        newgenty (Tvariant {row2 with row_fields = r2; row_name = None})
+      in
+      moregen_occur env rm1.level ext;
+      update_scope rm1.scope ext;
+      link_type rm1 ext
+  | Tconstr _, Tconstr _ ->
+      moregen inst_nongen type_pairs env rm1 rm2
+  | _ -> raise (Unify [])
+  end;
+  List.iter
+    (fun (_l,f1,f2) ->
+      let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
+      if f1 == f2 then () else
+      match f1, f2 with
+        Rpresent(Some t1), Rpresent(Some t2) ->
+          moregen inst_nongen type_pairs env t1 t2
+      | Rpresent None, Rpresent None -> ()
+      | Reither(false, tl1, _, e1), Rpresent(Some t2) when may_inst ->
+          set_row_field e1 f2;
+          List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1
+      | Reither(c1, tl1, _, e1), Reither(c2, tl2, m2, e2) ->
+          if e1 != e2 then begin
+            if c1 && not c2 then raise(Unify []);
+            set_row_field e1 (Reither (c2, [], m2, e2));
+            if List.length tl1 = List.length tl2 then
+              List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2
+            else match tl2 with
+              t2 :: _ ->
+                List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2)
+                  tl1
+            | [] ->
+                if tl1 <> [] then raise (Unify [])
+          end
+      | Reither(true, [], _, e1), Rpresent None when may_inst ->
+          set_row_field e1 f2
+      | Reither(_, _, _, e1), Rabsent when may_inst ->
+          set_row_field e1 f2
+      | Rabsent, Rabsent -> ()
+      | _ -> raise (Unify []))
+    pairs
+
+(* Must empty univar_pairs first *)
+let moregen inst_nongen type_pairs env patt subj =
+  univar_pairs := [];
+  moregen inst_nongen type_pairs env patt subj
+
+(*
+   Non-generic variable can be instantiated only if [inst_nongen] is
+   true. So, [inst_nongen] should be set to false if the subject might
+   contain non-generic variables (and we do not want them to be
+   instantiated).
+   Usually, the subject is given by the user, and the pattern
+   is unimportant.  So, no need to propagate abbreviations.
+*)
+let moregeneral env inst_nongen pat_sch subj_sch =
+  let old_level = !current_level in
+  current_level := generic_level - 1;
+  (*
+     Generic variables are first duplicated with [instance].  So,
+     their levels are lowered to [generic_level - 1].  The subject is
+     then copied with [duplicate_type].  That way, its levels won't be
+     changed.
+  *)
+  let subj = duplicate_type (instance subj_sch) in
+  current_level := generic_level;
+  (* Duplicate generic variables *)
+  let patt = instance pat_sch in
+  let res =
+    try moregen inst_nongen (TypePairs.create 13) env patt subj; true with
+      Unify _ -> false
+  in
+  current_level := old_level;
+  res
+
+
+(* Alternative approach: "rigidify" a type scheme,
+   and check validity after unification *)
+(* Simpler, no? *)
+
+let rec rigidify_rec vars ty =
+  let ty = repr ty in
+  if ty.level >= lowest_level then begin
+    ty.level <- pivot_level - ty.level;
+    match ty.desc with
+    | Tvar _ ->
+        if not (List.memq ty !vars) then vars := ty :: !vars
+    | Tvariant row ->
+        let row = row_repr row in
+        let more = repr row.row_more in
+        if is_Tvar more && not (row_fixed row) then begin
+          let more' = newty2 more.level more.desc in
+          let row' =
+            {row with row_fixed=Some Rigid; row_fields=[]; row_more=more'}
+          in link_type more (newty2 ty.level (Tvariant row'))
+        end;
+        iter_row (rigidify_rec vars) row;
+        (* only consider the row variable if the variant is not static *)
+        if not (static_row row) then rigidify_rec vars (row_more row)
+    | _ ->
+        iter_type_expr (rigidify_rec vars) ty
+  end
+
+let rigidify ty =
+  let vars = ref [] in
+  rigidify_rec vars ty;
+  unmark_type ty;
+  !vars
+
+let all_distinct_vars env vars =
+  let tyl = ref [] in
+  List.for_all
+    (fun ty ->
+      let ty = expand_head env ty in
+      if List.memq ty !tyl then false else
+      (tyl := ty :: !tyl; is_Tvar ty))
+    vars
+
+let matches env ty ty' =
+  let snap = snapshot () in
+  let vars = rigidify ty in
+  cleanup_abbrev ();
+  let ok =
+    try unify env ty ty'; all_distinct_vars env vars
+    with Unify _ -> false
+  in
+  backtrack snap;
+  ok
+
+
+                 (*********************************************)
+                 (*  Equivalence between parameterized types  *)
+                 (*********************************************)
+
+let expand_head_rigid env ty =
+  let old = !rigid_variants in
+  rigid_variants := true;
+  let ty' = expand_head env ty in
+  rigid_variants := old; ty'
+
+let normalize_subst subst =
+  if List.exists
+      (function {desc=Tlink _}, _ | _, {desc=Tlink _} -> true | _ -> false)
+      !subst
+  then subst := List.map (fun (t1,t2) -> repr t1, repr t2) !subst
+
+let rec eqtype rename type_pairs subst env t1 t2 =
+  if t1 == t2 then () else
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if t1 == t2 then () else
+
+  try
+    match (t1.desc, t2.desc) with
+      (Tvar _, Tvar _) when rename ->
+        begin try
+          normalize_subst subst;
+          if List.assq t1 !subst != t2 then raise (Unify [])
+        with Not_found ->
+          if List.exists (fun (_, t) -> t == t2) !subst then raise (Unify []);
+          subst := (t1, t2) :: !subst
+        end
+    | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
+        ()
+    | _ ->
+        let t1' = expand_head_rigid env t1 in
+        let t2' = expand_head_rigid env t2 in
+        (* Expansion may have changed the representative of the types... *)
+        let t1' = repr t1' and t2' = repr t2' in
+        if t1' == t2' then () else
+        begin try
+          TypePairs.find type_pairs (t1', t2')
+        with Not_found ->
+          TypePairs.add type_pairs (t1', t2') ();
+          match (t1'.desc, t2'.desc) with
+            (Tvar _, Tvar _) when rename ->
+              begin try
+                normalize_subst subst;
+                if List.assq t1' !subst != t2' then raise (Unify [])
+              with Not_found ->
+                if List.exists (fun (_, t) -> t == t2') !subst
+                then raise (Unify []);
+                subst := (t1', t2') :: !subst
+              end
+          | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2
+            || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
+              eqtype rename type_pairs subst env t1 t2;
+              eqtype rename type_pairs subst env u1 u2;
+          | (Ttuple tl1, Ttuple tl2) ->
+              eqtype_list rename type_pairs subst env tl1 tl2
+          | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
+                when Path.same p1 p2 ->
+              eqtype_list rename type_pairs subst env tl1 tl2
+          | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) ->
+              begin try
+                unify_package env (eqtype_list rename type_pairs subst env)
+                  t1'.level p1 n1 tl1 t2'.level p2 n2 tl2
+              with Not_found -> raise (Unify [])
+              end
+          | (Tvariant row1, Tvariant row2) ->
+              eqtype_row rename type_pairs subst env row1 row2
+          | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) ->
+              eqtype_fields rename type_pairs subst env fi1 fi2
+          | (Tfield _, Tfield _) ->       (* Actually unused *)
+              eqtype_fields rename type_pairs subst env t1' t2'
+          | (Tnil, Tnil) ->
+              ()
+          | (Tpoly (t1, []), Tpoly (t2, [])) ->
+              eqtype rename type_pairs subst env t1 t2
+          | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+              enter_poly env univar_pairs t1 tl1 t2 tl2
+                (eqtype rename type_pairs subst env)
+          | (Tunivar _, Tunivar _) ->
+              unify_univar t1' t2' !univar_pairs
+          | (_, _) ->
+              raise (Unify [])
+        end
+  with Unify trace ->  raise ( Unify (Trace.diff t1 t2 :: trace) )
+
+and eqtype_list rename type_pairs subst env tl1 tl2 =
+  if List.length tl1 <> List.length tl2 then
+    raise (Unify []);
+  List.iter2 (eqtype rename type_pairs subst env) tl1 tl2
+
+and eqtype_fields rename type_pairs subst env ty1 ty2 =
+  let (fields1, rest1) = flatten_fields ty1 in
+  let (fields2, rest2) = flatten_fields ty2 in
+  (* First check if same row => already equal *)
+  let same_row =
+    rest1 == rest2 || TypePairs.mem type_pairs (rest1,rest2) ||
+    (rename && List.mem (rest1, rest2) !subst)
+  in
+  if same_row then () else
+  (* Try expansion, needed when called from Includecore.type_manifest *)
+  match expand_head_rigid env rest2 with
+    {desc=Tobject(ty2,_)} -> eqtype_fields rename type_pairs subst env ty1 ty2
+  | _ ->
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  eqtype rename type_pairs subst env rest1 rest2;
+  if (miss1 <> []) || (miss2 <> []) then raise (Unify []);
+  List.iter
+    (function (n, k1, t1, k2, t2) ->
+       eqtype_kind k1 k2;
+       try eqtype rename type_pairs subst env t1 t2 with Unify trace ->
+         let e = Trace.diff
+             (newty (Tfield(n, k1, t1, rest2)))
+             (newty (Tfield(n, k2, t2, rest2))) in
+         raise ( Unify ( e :: trace ) )
+    )
+    pairs
+
+and eqtype_kind k1 k2 =
+  let k1 = field_kind_repr k1 in
+  let k2 = field_kind_repr k2 in
+  match k1, k2 with
+    (Fvar _, Fvar _)
+  | (Fpresent, Fpresent) -> ()
+  | _                    -> raise (Unify [])
+
+and eqtype_row rename type_pairs subst env row1 row2 =
+  (* Try expansion, needed when called from Includecore.type_manifest *)
+  match expand_head_rigid env (row_more row2) with
+    {desc=Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2
+  | _ ->
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
+  if row1.row_closed <> row2.row_closed
+  || not row1.row_closed && (r1 <> [] || r2 <> [])
+  || filter_row_fields false (r1 @ r2) <> []
+  then raise (Unify []);
+  if not (static_row row1) then
+    eqtype rename type_pairs subst env row1.row_more row2.row_more;
+  List.iter
+    (fun (_,f1,f2) ->
+      match row_field_repr f1, row_field_repr f2 with
+        Rpresent(Some t1), Rpresent(Some t2) ->
+          eqtype rename type_pairs subst env t1 t2
+      | Reither(c1, [], _, _), Reither(c2, [], _, _) when c1 = c2 ->
+          ()
+      | Reither(c1, t1::tl1, _, _), Reither(c2, t2::tl2, _, _) when c1 = c2 ->
+          eqtype rename type_pairs subst env t1 t2;
+          if List.length tl1 = List.length tl2 then
+            (* if same length allow different types (meaning?) *)
+            List.iter2 (eqtype rename type_pairs subst env) tl1 tl2
+          else begin
+            (* otherwise everything must be equal *)
+            List.iter (eqtype rename type_pairs subst env t1) tl2;
+            List.iter (fun t1 -> eqtype rename type_pairs subst env t1 t2) tl1
+          end
+      | Rpresent None, Rpresent None -> ()
+      | Rabsent, Rabsent -> ()
+      | _ -> raise (Unify []))
+    pairs
+
+(* Must empty univar_pairs first *)
+let eqtype_list rename type_pairs subst env tl1 tl2 =
+  univar_pairs := [];
+  let snap = Btype.snapshot () in
+  Misc.try_finally
+    ~always:(fun () -> backtrack snap)
+    (fun () -> eqtype_list rename type_pairs subst env tl1 tl2)
+
+let eqtype rename type_pairs subst env t1 t2 =
+  eqtype_list rename type_pairs subst env [t1] [t2]
+
+(* Two modes: with or without renaming of variables *)
+let equal env rename tyl1 tyl2 =
+  try
+    eqtype_list rename (TypePairs.create 11) (ref []) env tyl1 tyl2; true
+  with
+    Unify _ -> false
+
+
+                          (*************************)
+                          (*  Class type matching  *)
+                          (*************************)
+
+
+type class_match_failure =
+    CM_Virtual_class
+  | CM_Parameter_arity_mismatch of int * int
+  | CM_Type_parameter_mismatch of Env.t * Unification_trace.t
+  | CM_Class_type_mismatch of Env.t * class_type * class_type
+  | CM_Parameter_mismatch of Env.t * Unification_trace.t
+  | CM_Val_type_mismatch of string * Env.t * Unification_trace.t
+  | CM_Meth_type_mismatch of string * Env.t * Unification_trace.t
+  | CM_Non_mutable_value of string
+  | CM_Non_concrete_value of string
+  | CM_Missing_value of string
+  | CM_Missing_method of string
+  | CM_Hide_public of string
+  | CM_Hide_virtual of string * string
+  | CM_Public_method of string
+  | CM_Private_method of string
+  | CM_Virtual_method of string
+
+exception Failure of class_match_failure list
+
+let rec moregen_clty trace type_pairs env cty1 cty2 =
+  try
+    match cty1, cty2 with
+      Cty_constr (_, _, cty1), _ ->
+        moregen_clty true type_pairs env cty1 cty2
+    | _, Cty_constr (_, _, cty2) ->
+        moregen_clty true type_pairs env cty1 cty2
+    | Cty_arrow (l1, ty1, cty1'), Cty_arrow (l2, ty2, cty2') when l1 = l2 ->
+        begin try moregen true type_pairs env ty1 ty2 with Unify trace ->
+          raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)])
+        end;
+        moregen_clty false type_pairs env cty1' cty2'
+    | Cty_signature sign1, Cty_signature sign2 ->
+        let ty1 = object_fields (repr sign1.csig_self) in
+        let ty2 = object_fields (repr sign2.csig_self) in
+        let (fields1, _rest1) = flatten_fields ty1
+        and (fields2, _rest2) = flatten_fields ty2 in
+        let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in
+        List.iter
+          (fun (lab, _k1, t1, _k2, t2) ->
+            begin try moregen true type_pairs env t1 t2 with Unify trace ->
+              raise (Failure [CM_Meth_type_mismatch
+                                 (lab, env, expand_trace env trace)])
+           end)
+        pairs;
+      Vars.iter
+        (fun lab (_mut, _v, ty) ->
+           let (_mut', _v', ty') = Vars.find lab sign1.csig_vars in
+           try moregen true type_pairs env ty' ty with Unify trace ->
+             raise (Failure [CM_Val_type_mismatch
+                                (lab, env, expand_trace env trace)]))
+        sign2.csig_vars
+  | _ ->
+      raise (Failure [])
+  with
+    Failure error when trace || error = [] ->
+      raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error))
+
+let match_class_types ?(trace=true) env pat_sch subj_sch =
+  let type_pairs = TypePairs.create 53 in
+  let old_level = !current_level in
+  current_level := generic_level - 1;
+  (*
+     Generic variables are first duplicated with [instance].  So,
+     their levels are lowered to [generic_level - 1].  The subject is
+     then copied with [duplicate_type].  That way, its levels won't be
+     changed.
+  *)
+  let (_, subj_inst) = instance_class [] subj_sch in
+  let subj = duplicate_class_type subj_inst in
+  current_level := generic_level;
+  (* Duplicate generic variables *)
+  let (_, patt) = instance_class [] pat_sch in
+  let res =
+    let sign1 = signature_of_class_type patt in
+    let sign2 = signature_of_class_type subj in
+    let t1 = repr sign1.csig_self in
+    let t2 = repr sign2.csig_self in
+    TypePairs.add type_pairs (t1, t2) ();
+    let (fields1, rest1) = flatten_fields (object_fields t1)
+    and (fields2, rest2) = flatten_fields (object_fields t2) in
+    let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+    let error =
+      List.fold_right
+        (fun (lab, k, _) err ->
+           let err =
+             let k = field_kind_repr k in
+             begin match k with
+               Fvar r -> set_kind r Fabsent; err
+             | _      -> CM_Hide_public lab::err
+             end
+           in
+           if lab = dummy_method || Concr.mem lab sign1.csig_concr then err
+           else CM_Hide_virtual ("method", lab) :: err)
+        miss1 []
+    in
+    let missing_method = List.map (fun (m, _, _) -> m) miss2 in
+    let error =
+      (List.map (fun m -> CM_Missing_method m) missing_method) @ error
+    in
+    (* Always succeeds *)
+    moregen true type_pairs env rest1 rest2;
+    let error =
+      List.fold_right
+        (fun (lab, k1, _t1, k2, _t2) err ->
+           try moregen_kind k1 k2; err with
+             Unify _ -> CM_Public_method lab::err)
+        pairs error
+    in
+    let error =
+      Vars.fold
+        (fun lab (mut, vr, _ty) err ->
+          try
+            let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in
+            if mut = Mutable && mut' <> Mutable then
+              CM_Non_mutable_value lab::err
+            else if vr = Concrete && vr' <> Concrete then
+              CM_Non_concrete_value lab::err
+            else
+              err
+          with Not_found ->
+            CM_Missing_value lab::err)
+        sign2.csig_vars error
+    in
+    let error =
+      Vars.fold
+        (fun lab (_,vr,_) err ->
+          if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then
+            CM_Hide_virtual ("instance variable", lab) :: err
+          else err)
+        sign1.csig_vars error
+    in
+    let error =
+      List.fold_right
+        (fun e l ->
+           if List.mem e missing_method then l else CM_Virtual_method e::l)
+        (Concr.elements (Concr.diff sign2.csig_concr sign1.csig_concr))
+        error
+    in
+    match error with
+      [] ->
+        begin try
+          moregen_clty trace type_pairs env patt subj;
+          []
+        with
+          Failure r -> r
+        end
+    | error ->
+        CM_Class_type_mismatch (env, patt, subj)::error
+  in
+  current_level := old_level;
+  res
+
+let rec equal_clty trace type_pairs subst env cty1 cty2 =
+  try
+    match cty1, cty2 with
+      Cty_constr (_, _, cty1), Cty_constr (_, _, cty2) ->
+        equal_clty true type_pairs subst env cty1 cty2
+    | Cty_constr (_, _, cty1), _ ->
+        equal_clty true type_pairs subst env cty1 cty2
+    | _, Cty_constr (_, _, cty2) ->
+        equal_clty true type_pairs subst env cty1 cty2
+    | Cty_arrow (l1, ty1, cty1'), Cty_arrow (l2, ty2, cty2') when l1 = l2 ->
+        begin try eqtype true type_pairs subst env ty1 ty2 with Unify trace ->
+          raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)])
+        end;
+        equal_clty false type_pairs subst env cty1' cty2'
+    | Cty_signature sign1, Cty_signature sign2 ->
+        let ty1 = object_fields (repr sign1.csig_self) in
+        let ty2 = object_fields (repr sign2.csig_self) in
+        let (fields1, _rest1) = flatten_fields ty1
+        and (fields2, _rest2) = flatten_fields ty2 in
+        let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in
+        List.iter
+          (fun (lab, _k1, t1, _k2, t2) ->
+             begin try eqtype true type_pairs subst env t1 t2 with
+               Unify trace ->
+                 raise (Failure [CM_Meth_type_mismatch
+                                    (lab, env, expand_trace env trace)])
+             end)
+          pairs;
+        Vars.iter
+          (fun lab (_, _, ty) ->
+             let (_, _, ty') = Vars.find lab sign1.csig_vars in
+             try eqtype true type_pairs subst env ty' ty with Unify trace ->
+               raise (Failure [CM_Val_type_mismatch
+                                  (lab, env, expand_trace env trace)]))
+          sign2.csig_vars
+    | _ ->
+        raise
+          (Failure (if trace then []
+                    else [CM_Class_type_mismatch (env, cty1, cty2)]))
+  with
+    Failure error when trace ->
+      raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error))
+
+let match_class_declarations env patt_params patt_type subj_params subj_type =
+  let type_pairs = TypePairs.create 53 in
+  let subst = ref [] in
+  let sign1 = signature_of_class_type patt_type in
+  let sign2 = signature_of_class_type subj_type in
+  let t1 = repr sign1.csig_self in
+  let t2 = repr sign2.csig_self in
+  TypePairs.add type_pairs (t1, t2) ();
+  let (fields1, rest1) = flatten_fields (object_fields t1)
+  and (fields2, rest2) = flatten_fields (object_fields t2) in
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  let error =
+    List.fold_right
+      (fun (lab, k, _) err ->
+        let err =
+          let k = field_kind_repr k in
+          begin match k with
+            Fvar _ -> err
+          | _      -> CM_Hide_public lab::err
+          end
+        in
+        if Concr.mem lab sign1.csig_concr then err
+        else CM_Hide_virtual ("method", lab) :: err)
+      miss1 []
+  in
+  let missing_method = List.map (fun (m, _, _) -> m) miss2 in
+  let error =
+    (List.map (fun m -> CM_Missing_method m) missing_method) @ error
+  in
+  (* Always succeeds *)
+  eqtype true type_pairs subst env rest1 rest2;
+  let error =
+    List.fold_right
+      (fun (lab, k1, _t1, k2, _t2) err ->
+        let k1 = field_kind_repr k1 in
+        let k2 = field_kind_repr k2 in
+        match k1, k2 with
+          (Fvar _, Fvar _)
+        | (Fpresent, Fpresent) -> err
+        | (Fvar _, Fpresent)   -> CM_Private_method lab::err
+        | (Fpresent, Fvar _)  -> CM_Public_method lab::err
+        | _                    -> assert false)
+      pairs error
+  in
+  let error =
+    Vars.fold
+      (fun lab (mut, vr, _ty) err ->
+         try
+           let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in
+           if mut = Mutable && mut' <> Mutable then
+             CM_Non_mutable_value lab::err
+           else if vr = Concrete && vr' <> Concrete then
+             CM_Non_concrete_value lab::err
+           else
+             err
+         with Not_found ->
+           CM_Missing_value lab::err)
+      sign2.csig_vars error
+  in
+  let error =
+    Vars.fold
+      (fun lab (_,vr,_) err ->
+        if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then
+          CM_Hide_virtual ("instance variable", lab) :: err
+        else err)
+      sign1.csig_vars error
+  in
+  let error =
+    List.fold_right
+      (fun e l ->
+        if List.mem e missing_method then l else CM_Virtual_method e::l)
+      (Concr.elements (Concr.diff sign2.csig_concr sign1.csig_concr))
+      error
+  in
+  match error with
+    [] ->
+      begin try
+        let lp = List.length patt_params in
+        let ls = List.length subj_params in
+        if lp  <> ls then
+          raise (Failure [CM_Parameter_arity_mismatch (lp, ls)]);
+        List.iter2 (fun p s ->
+          try eqtype true type_pairs subst env p s with Unify trace ->
+            raise (Failure [CM_Type_parameter_mismatch
+                               (env, expand_trace env trace)]))
+          patt_params subj_params;
+     (* old code: equal_clty false type_pairs subst env patt_type subj_type; *)
+        equal_clty false type_pairs subst env
+          (Cty_signature sign1) (Cty_signature sign2);
+        (* Use moregeneral for class parameters, need to recheck everything to
+           keeps relationships (PR#4824) *)
+        let clty_params =
+          List.fold_right (fun ty cty -> Cty_arrow (Labelled "*",ty,cty)) in
+        match_class_types ~trace:false env
+          (clty_params patt_params patt_type)
+          (clty_params subj_params subj_type)
+      with
+        Failure r -> r
+      end
+  | error ->
+      error
+
+
+                              (***************)
+                              (*  Subtyping  *)
+                              (***************)
+
+
+(**** Build a subtype of a given type. ****)
+
+(* build_subtype:
+   [visited] traces traversed object and variant types
+   [loops] is a mapping from variables to variables, to reproduce
+     positive loops in a class type
+   [posi] true if the current variance is positive
+   [level] number of expansions/enlargement allowed on this branch *)
+
+let warn = ref false  (* whether double coercion might do better *)
+let pred_expand n = if n mod 2 = 0 && n > 0 then pred n else n
+let pred_enlarge n = if n mod 2 = 1 then pred n else n
+
+type change = Unchanged | Equiv | Changed
+let collect l = List.fold_left (fun c1 (_, c2) -> max c1 c2) Unchanged l
+
+let rec filter_visited = function
+    [] -> []
+  | {desc=Tobject _|Tvariant _} :: _ as l -> l
+  | _ :: l -> filter_visited l
+
+let memq_warn t visited =
+  if List.memq t visited then (warn := true; true) else false
+
+let find_cltype_for_path env p =
+  let cl_abbr = Env.find_hash_type p env in
+  match cl_abbr.type_manifest with
+    Some ty ->
+      begin match (repr ty).desc with
+        Tobject(_,{contents=Some(p',_)}) when Path.same p p' -> cl_abbr, ty
+      | _ -> raise Not_found
+      end
+  | None -> assert false
+
+let has_constr_row' env t =
+  has_constr_row (expand_abbrev env t)
+
+let rec build_subtype env visited loops posi level t =
+  let t = repr t in
+  match t.desc with
+    Tvar _ ->
+      if posi then
+        try
+          let t' = List.assq t loops in
+          warn := true;
+          (t', Equiv)
+        with Not_found ->
+          (t, Unchanged)
+      else
+        (t, Unchanged)
+  | Tarrow(l, t1, t2, com) ->
+      assert (com = Cok);
+      if memq_warn t visited then (t, Unchanged) else
+      let visited = t :: visited in
+      let (t1', c1) = build_subtype env visited loops (not posi) level t1 in
+      let (t2', c2) = build_subtype env visited loops posi level t2 in
+      let c = max c1 c2 in
+      if c > Unchanged then (newty (Tarrow(l, t1', t2', Cok)), c)
+      else (t, Unchanged)
+  | Ttuple tlist ->
+      if memq_warn t visited then (t, Unchanged) else
+      let visited = t :: visited in
+      let tlist' =
+        List.map (build_subtype env visited loops posi level) tlist
+      in
+      let c = collect tlist' in
+      if c > Unchanged then (newty (Ttuple (List.map fst tlist')), c)
+      else (t, Unchanged)
+  | Tconstr(p, tl, abbrev)
+    when level > 0 && generic_abbrev env p && safe_abbrev env t
+    && not (has_constr_row' env t) ->
+      let t' = repr (expand_abbrev env t) in
+      let level' = pred_expand level in
+      begin try match t'.desc with
+        Tobject _ when posi && not (opened_object t') ->
+          let cl_abbr, body = find_cltype_for_path env p in
+          let ty =
+            subst env !current_level Public abbrev None
+              cl_abbr.type_params tl body in
+          let ty = repr ty in
+          let ty1, tl1 =
+            match ty.desc with
+              Tobject(ty1,{contents=Some(p',tl1)}) when Path.same p p' ->
+                ty1, tl1
+            | _ -> raise Not_found
+          in
+          (* Fix PR#4505: do not set ty to Tvar when it appears in tl1,
+             as this occurrence might break the occur check.
+             XXX not clear whether this correct anyway... *)
+          if List.exists (deep_occur ty) tl1 then raise Not_found;
+          ty.desc <- Tvar None;
+          let t'' = newvar () in
+          let loops = (ty, t'') :: loops in
+          (* May discard [visited] as level is going down *)
+          let (ty1', c) =
+            build_subtype env [t'] loops posi (pred_enlarge level') ty1 in
+          assert (is_Tvar t'');
+          let nm =
+            if c > Equiv || deep_occur ty ty1' then None else Some(p,tl1) in
+          t''.desc <- Tobject (ty1', ref nm);
+          (try unify_var env ty t with Unify _ -> assert false);
+          (t'', Changed)
+      | _ -> raise Not_found
+      with Not_found ->
+        let (t'',c) = build_subtype env visited loops posi level' t' in
+        if c > Unchanged then (t'',c)
+        else (t, Unchanged)
+      end
+  | Tconstr(p, tl, _abbrev) ->
+      (* Must check recursion on constructors, since we do not always
+         expand them *)
+      if memq_warn t visited then (t, Unchanged) else
+      let visited = t :: visited in
+      begin try
+        let decl = Env.find_type p env in
+        if level = 0 && generic_abbrev env p && safe_abbrev env t
+        && not (has_constr_row' env t)
+        then warn := true;
+        let tl' =
+          List.map2
+            (fun v t ->
+              let (co,cn) = Variance.get_upper v in
+              if cn then
+                if co then (t, Unchanged)
+                else build_subtype env visited loops (not posi) level t
+              else
+                if co then build_subtype env visited loops posi level t
+                else (newvar(), Changed))
+            decl.type_variance tl
+        in
+        let c = collect tl' in
+        if c > Unchanged then (newconstr p (List.map fst tl'), c)
+        else (t, Unchanged)
+      with Not_found ->
+        (t, Unchanged)
+      end
+  | Tvariant row ->
+      let row = row_repr row in
+      if memq_warn t visited || not (static_row row) then (t, Unchanged) else
+      let level' = pred_enlarge level in
+      let visited =
+        t :: if level' < level then [] else filter_visited visited in
+      let fields = filter_row_fields false row.row_fields in
+      let fields =
+        List.map
+          (fun (l,f as orig) -> match row_field_repr f with
+            Rpresent None ->
+              if posi then
+                (l, Reither(true, [], false, ref None)), Unchanged
+              else
+                orig, Unchanged
+          | Rpresent(Some t) ->
+              let (t', c) = build_subtype env visited loops posi level' t in
+              let f =
+                if posi && level > 0
+                then Reither(false, [t'], false, ref None)
+                else Rpresent(Some t')
+              in (l, f), c
+          | _ -> assert false)
+          fields
+      in
+      let c = collect fields in
+      let row =
+        { row_fields = List.map fst fields; row_more = newvar();
+          row_bound = (); row_closed = posi; row_fixed = None;
+          row_name = if c > Unchanged then None else row.row_name }
+      in
+      (newty (Tvariant row), Changed)
+  | Tobject (t1, _) ->
+      if memq_warn t visited || opened_object t1 then (t, Unchanged) else
+      let level' = pred_enlarge level in
+      let visited =
+        t :: if level' < level then [] else filter_visited visited in
+      let (t1', c) = build_subtype env visited loops posi level' t1 in
+      if c > Unchanged then (newty (Tobject (t1', ref None)), c)
+      else (t, Unchanged)
+  | Tfield(s, _, t1, t2) (* Always present *) ->
+      let (t1', c1) = build_subtype env visited loops posi level t1 in
+      let (t2', c2) = build_subtype env visited loops posi level t2 in
+      let c = max c1 c2 in
+      if c > Unchanged then (newty (Tfield(s, Fpresent, t1', t2')), c)
+      else (t, Unchanged)
+  | Tnil ->
+      if posi then
+        let v = newvar () in
+        (v, Changed)
+      else begin
+        warn := true;
+        (t, Unchanged)
+      end
+  | Tsubst _ | Tlink _ ->
+      assert false
+  | Tpoly(t1, tl) ->
+      let (t1', c) = build_subtype env visited loops posi level t1 in
+      if c > Unchanged then (newty (Tpoly(t1', tl)), c)
+      else (t, Unchanged)
+  | Tunivar _ | Tpackage _ ->
+      (t, Unchanged)
+
+let enlarge_type env ty =
+  warn := false;
+  (* [level = 4] allows 2 expansions involving objects/variants *)
+  let (ty', _) = build_subtype env [] [] true 4 ty in
+  (ty', !warn)
+
+(**** Check whether a type is a subtype of another type. ****)
+
+(*
+    During the traversal, a trace of visited types is maintained. It
+    is printed in case of error.
+    Constraints (pairs of types that must be equals) are accumulated
+    rather than being enforced straight. Indeed, the result would
+    otherwise depend on the order in which these constraints are
+    enforced.
+    A function enforcing these constraints is returned. That way, type
+    variables can be bound to their actual values before this function
+    is called (see Typecore).
+    Only well-defined abbreviations are expanded (hence the tests
+    [generic_abbrev ...]).
+*)
+
+let subtypes = TypePairs.create 17
+
+let subtype_error env trace =
+  raise (Subtype (expand_trace env (List.rev trace), []))
+
+let rec subtype_rec env trace t1 t2 cstrs =
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if t1 == t2 then cstrs else
+
+  begin try
+    TypePairs.find subtypes (t1, t2);
+    cstrs
+  with Not_found ->
+    TypePairs.add subtypes (t1, t2) ();
+    match (t1.desc, t2.desc) with
+      (Tvar _, _) | (_, Tvar _) ->
+        (trace, t1, t2, !univar_pairs)::cstrs
+    | (Tarrow(l1, t1, u1, _), Tarrow(l2, t2, u2, _)) when l1 = l2
+      || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
+        let cstrs = subtype_rec env (Trace.diff t2 t1::trace) t2 t1 cstrs in
+        subtype_rec env (Trace.diff u1 u2::trace) u1 u2 cstrs
+    | (Ttuple tl1, Ttuple tl2) ->
+        subtype_list env trace tl1 tl2 cstrs
+    | (Tconstr(p1, [], _), Tconstr(p2, [], _)) when Path.same p1 p2 ->
+        cstrs
+    | (Tconstr(p1, _tl1, _abbrev1), _)
+      when generic_abbrev env p1 && safe_abbrev env t1 ->
+        subtype_rec env trace (expand_abbrev env t1) t2 cstrs
+    | (_, Tconstr(p2, _tl2, _abbrev2))
+      when generic_abbrev env p2 && safe_abbrev env t2 ->
+        subtype_rec env trace t1 (expand_abbrev env t2) cstrs
+    | (Tconstr(p1, tl1, _), Tconstr(p2, tl2, _)) when Path.same p1 p2 ->
+        begin try
+          let decl = Env.find_type p1 env in
+          List.fold_left2
+            (fun cstrs v (t1, t2) ->
+              let (co, cn) = Variance.get_upper v in
+              if co then
+                if cn then
+                  (trace, newty2 t1.level (Ttuple[t1]),
+                   newty2 t2.level (Ttuple[t2]), !univar_pairs) :: cstrs
+                else subtype_rec env (Trace.diff t1 t2::trace) t1 t2 cstrs
+              else
+                if cn then subtype_rec env (Trace.diff t2 t1::trace) t2 t1 cstrs
+                else cstrs)
+            cstrs decl.type_variance (List.combine tl1 tl2)
+        with Not_found ->
+          (trace, t1, t2, !univar_pairs)::cstrs
+        end
+    | (Tconstr(p1, _, _), _) when generic_private_abbrev env p1 ->
+        subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs
+(*  | (_, Tconstr(p2, _, _)) when generic_private_abbrev false env p2 ->
+        subtype_rec env trace t1 (expand_abbrev_opt env t2) cstrs *)
+    | (Tobject (f1, _), Tobject (f2, _))
+      when is_Tvar (object_row f1) && is_Tvar (object_row f2) ->
+        (* Same row variable implies same object. *)
+        (trace, t1, t2, !univar_pairs)::cstrs
+    | (Tobject (f1, _), Tobject (f2, _)) ->
+        subtype_fields env trace f1 f2 cstrs
+    | (Tvariant row1, Tvariant row2) ->
+        begin try
+          subtype_row env trace row1 row2 cstrs
+        with Exit ->
+          (trace, t1, t2, !univar_pairs)::cstrs
+        end
+    | (Tpoly (u1, []), Tpoly (u2, [])) ->
+        subtype_rec env trace u1 u2 cstrs
+    | (Tpoly (u1, tl1), Tpoly (u2, [])) ->
+        let _, u1' = instance_poly false tl1 u1 in
+        subtype_rec env trace u1' u2 cstrs
+    | (Tpoly (u1, tl1), Tpoly (u2,tl2)) ->
+        begin try
+          enter_poly env univar_pairs u1 tl1 u2 tl2
+            (fun t1 t2 -> subtype_rec env trace t1 t2 cstrs)
+        with Unify _ ->
+          (trace, t1, t2, !univar_pairs)::cstrs
+        end
+    | (Tpackage (p1, nl1, tl1), Tpackage (p2, nl2, tl2)) ->
+        begin try
+          let ntl1 = complete_type_list env nl2 t1.level (Mty_ident p1) nl1 tl1
+          and ntl2 = complete_type_list env nl1 t2.level (Mty_ident p2) nl2 tl2
+              ~allow_absent:true in
+          let cstrs' =
+            List.map
+              (fun (n2,t2) -> (trace, List.assoc n2 ntl1, t2, !univar_pairs))
+              ntl2
+          in
+          if eq_package_path env p1 p2 then cstrs' @ cstrs
+          else begin
+            (* need to check module subtyping *)
+            let snap = Btype.snapshot () in
+            try
+              List.iter (fun (_, t1, t2, _) -> unify env t1 t2) cstrs';
+              if !package_subtype env p1 nl1 tl1 p2 nl2 tl2
+              then (Btype.backtrack snap; cstrs' @ cstrs)
+              else raise (Unify [])
+            with Unify _ ->
+              Btype.backtrack snap; raise Not_found
+          end
+        with Not_found ->
+          (trace, t1, t2, !univar_pairs)::cstrs
+        end
+    | (_, _) ->
+        (trace, t1, t2, !univar_pairs)::cstrs
+  end
+
+and subtype_list env trace tl1 tl2 cstrs =
+  if List.length tl1 <> List.length tl2 then
+    subtype_error env trace;
+  List.fold_left2
+    (fun cstrs t1 t2 -> subtype_rec env (Trace.diff t1 t2::trace) t1 t2 cstrs)
+    cstrs tl1 tl2
+
+and subtype_fields env trace ty1 ty2 cstrs =
+  (* Assume that either rest1 or rest2 is not Tvar *)
+  let (fields1, rest1) = flatten_fields ty1 in
+  let (fields2, rest2) = flatten_fields ty2 in
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  let cstrs =
+    if rest2.desc = Tnil then cstrs else
+    if miss1 = [] then
+      subtype_rec env (Trace.diff rest1 rest2::trace) rest1 rest2 cstrs
+    else
+      (trace, build_fields (repr ty1).level miss1 rest1, rest2,
+       !univar_pairs) :: cstrs
+  in
+  let cstrs =
+    if miss2 = [] then cstrs else
+    (trace, rest1, build_fields (repr ty2).level miss2 (newvar ()),
+     !univar_pairs) :: cstrs
+  in
+  List.fold_left
+    (fun cstrs (_, _k1, t1, _k2, t2) ->
+      (* These fields are always present *)
+      subtype_rec env (Trace.diff t1 t2::trace) t1 t2 cstrs)
+    cstrs pairs
+
+and subtype_row env trace row1 row2 cstrs =
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let r1, r2, pairs =
+    merge_row_fields row1.row_fields row2.row_fields in
+  let r1 = if row2.row_closed then filter_row_fields false r1 else r1 in
+  let r2 = if row1.row_closed then filter_row_fields false r2 else r2 in
+  let more1 = repr row1.row_more
+  and more2 = repr row2.row_more in
+  match more1.desc, more2.desc with
+    Tconstr(p1,_,_), Tconstr(p2,_,_) when Path.same p1 p2 ->
+      subtype_rec env (Trace.diff more1 more2::trace) more1 more2 cstrs
+  | (Tvar _|Tconstr _|Tnil), (Tvar _|Tconstr _|Tnil)
+    when row1.row_closed && r1 = [] ->
+      List.fold_left
+        (fun cstrs (_,f1,f2) ->
+          match row_field_repr f1, row_field_repr f2 with
+            (Rpresent None|Reither(true,_,_,_)), Rpresent None ->
+              cstrs
+          | Rpresent(Some t1), Rpresent(Some t2) ->
+              subtype_rec env (Trace.diff t1 t2::trace) t1 t2 cstrs
+          | Reither(false, t1::_, _, _), Rpresent(Some t2) ->
+              subtype_rec env (Trace.diff t1 t2::trace) t1 t2 cstrs
+          | Rabsent, _ -> cstrs
+          | _ -> raise Exit)
+        cstrs pairs
+  | Tunivar _, Tunivar _
+    when row1.row_closed = row2.row_closed && r1 = [] && r2 = [] ->
+      let cstrs =
+        subtype_rec env (Trace.diff more1 more2::trace) more1 more2 cstrs in
+      List.fold_left
+        (fun cstrs (_,f1,f2) ->
+          match row_field_repr f1, row_field_repr f2 with
+            Rpresent None, Rpresent None
+          | Reither(true,[],_,_), Reither(true,[],_,_)
+          | Rabsent, Rabsent ->
+              cstrs
+          | Rpresent(Some t1), Rpresent(Some t2)
+          | Reither(false,[t1],_,_), Reither(false,[t2],_,_) ->
+              subtype_rec env (Trace.diff t1 t2::trace) t1 t2 cstrs
+          | _ -> raise Exit)
+        cstrs pairs
+  | _ ->
+      raise Exit
+
+let subtype env ty1 ty2 =
+  TypePairs.clear subtypes;
+  univar_pairs := [];
+  (* Build constraint set. *)
+  let cstrs = subtype_rec env [Trace.diff ty1 ty2] ty1 ty2 [] in
+  TypePairs.clear subtypes;
+  (* Enforce constraints. *)
+  function () ->
+    List.iter
+      (function (trace0, t1, t2, pairs) ->
+         try unify_pairs (ref env) t1 t2 pairs with Unify trace ->
+           raise (Subtype (expand_trace env (List.rev trace0),
+                           List.tl trace)))
+      (List.rev cstrs)
+
+                              (*******************)
+                              (*  Miscellaneous  *)
+                              (*******************)
+
+(* Utility for printing. The resulting type is not used in computation. *)
+let rec unalias_object ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tfield (s, k, t1, t2) ->
+      newty2 ty.level (Tfield (s, k, t1, unalias_object t2))
+  | Tvar _ | Tnil ->
+      newty2 ty.level ty.desc
+  | Tunivar _ ->
+      ty
+  | Tconstr _ ->
+      newvar2 ty.level
+  | _ ->
+      assert false
+
+let unalias ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tvar _ | Tunivar _ ->
+      ty
+  | Tvariant row ->
+      let row = row_repr row in
+      let more = row.row_more in
+      newty2 ty.level
+        (Tvariant {row with row_more = newty2 more.level more.desc})
+  | Tobject (ty, nm) ->
+      newty2 ty.level (Tobject (unalias_object ty, nm))
+  | _ ->
+      newty2 ty.level ty.desc
+
+(* Return the arity (as for curried functions) of the given type. *)
+let rec arity ty =
+  match (repr ty).desc with
+    Tarrow(_, _t1, t2, _) -> 1 + arity t2
+  | _ -> 0
+
+(* Check whether an abbreviation expands to itself. *)
+let cyclic_abbrev env id ty =
+  let rec check_cycle seen ty =
+    let ty = repr ty in
+    match ty.desc with
+      Tconstr (p, _tl, _abbrev) ->
+        p = Path.Pident id || List.memq ty seen ||
+        begin try
+          check_cycle (ty :: seen) (expand_abbrev_opt env ty)
+        with
+          Cannot_expand -> false
+        | Unify _ -> true
+        end
+    | _ ->
+        false
+  in check_cycle [] ty
+
+(* Check for non-generalizable type variables *)
+exception Non_closed0
+let visited = ref TypeSet.empty
+
+let rec closed_schema_rec env ty =
+  let ty = repr ty in
+  if TypeSet.mem ty !visited then () else begin
+    visited := TypeSet.add ty !visited;
+    match ty.desc with
+      Tvar _ when ty.level <> generic_level ->
+        raise Non_closed0
+    | Tconstr _ ->
+        let old = !visited in
+        begin try iter_type_expr (closed_schema_rec env) ty
+        with Non_closed0 -> try
+          visited := old;
+          closed_schema_rec env (try_expand_head try_expand_safe env ty)
+        with Cannot_expand ->
+          raise Non_closed0
+        end
+    | Tfield(_, kind, t1, t2) ->
+        if field_kind_repr kind = Fpresent then
+          closed_schema_rec env t1;
+        closed_schema_rec env t2
+    | Tvariant row ->
+        let row = row_repr row in
+        iter_row (closed_schema_rec env) row;
+        if not (static_row row) then closed_schema_rec env row.row_more
+    | _ ->
+        iter_type_expr (closed_schema_rec env) ty
+  end
+
+(* Return whether all variables of type [ty] are generic. *)
+let closed_schema env ty =
+  visited := TypeSet.empty;
+  try
+    closed_schema_rec env ty;
+    visited := TypeSet.empty;
+    true
+  with Non_closed0 ->
+    visited := TypeSet.empty;
+    false
+
+(* Normalize a type before printing, saving... *)
+(* Cannot use mark_type because deep_occur uses it too *)
+let rec normalize_type_rec env visited ty =
+  let ty = repr ty in
+  if not (TypeSet.mem ty !visited) then begin
+    visited := TypeSet.add ty !visited;
+    let tm = row_of_type ty in
+    begin if not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm then
+      match tm.desc with (* PR#7348 *)
+        Tconstr (Path.Pdot(m,i), tl, _abbrev) ->
+          let i' = String.sub i 0 (String.length i - 4) in
+          set_type_desc ty (Tconstr(Path.Pdot(m,i'), tl, ref Mnil))
+      | _ -> assert false
+    else match ty.desc with
+    | Tvariant row ->
+      let row = row_repr row in
+      let fields = List.map
+          (fun (l,f0) ->
+            let f = row_field_repr f0 in l,
+            match f with Reither(b, ty::(_::_ as tyl), m, e) ->
+              let tyl' =
+                List.fold_left
+                  (fun tyl ty ->
+                    if List.exists (fun ty' -> equal env false [ty] [ty']) tyl
+                    then tyl else ty::tyl)
+                  [ty] tyl
+              in
+              if f != f0 || List.length tyl' < List.length tyl then
+                Reither(b, List.rev tyl', m, e)
+              else f
+            | _ -> f)
+          row.row_fields in
+      let fields =
+        List.sort (fun (p,_) (q,_) -> compare p q)
+          (List.filter (fun (_,fi) -> fi <> Rabsent) fields) in
+      set_type_desc ty (Tvariant {row with row_fields = fields})
+    | Tobject (fi, nm) ->
+        begin match !nm with
+        | None -> ()
+        | Some (n, v :: l) ->
+            if deep_occur ty (newgenty (Ttuple l)) then
+              (* The abbreviation may be hiding something, so remove it *)
+              set_name nm None
+            else let v' = repr v in
+            begin match v'.desc with
+            | Tvar _ | Tunivar _ ->
+                if v' != v then set_name nm (Some (n, v' :: l))
+            | Tnil ->
+                set_type_desc ty (Tconstr (n, l, ref Mnil))
+            | _ -> set_name nm None
+            end
+        | _ ->
+            fatal_error "Ctype.normalize_type_rec"
+        end;
+        let fi = repr fi in
+        if fi.level < lowest_level then () else
+        let fields, row = flatten_fields fi in
+        let fi' = build_fields fi.level fields row in
+        set_type_desc fi fi'.desc
+    | _ -> ()
+    end;
+    iter_type_expr (normalize_type_rec env visited) ty
+  end
+
+let normalize_type env ty =
+  normalize_type_rec env (ref TypeSet.empty) ty
+
+
+                              (*************************)
+                              (*  Remove dependencies  *)
+                              (*************************)
+
+
+(*
+   Variables are left unchanged. Other type nodes are duplicated, with
+   levels set to generic level.
+   We cannot use Tsubst here, because unification may be called by
+   expand_abbrev.
+*)
+
+let nondep_hash     = TypeHash.create 47
+let nondep_variants = TypeHash.create 17
+let clear_hash ()   =
+  TypeHash.clear nondep_hash; TypeHash.clear nondep_variants
+
+exception Nondep_cannot_erase of Ident.t
+
+let rec nondep_type_rec ?(expand_private=false) env ids ty =
+  let expand_abbrev env t =
+    if expand_private then expand_abbrev_opt env t else expand_abbrev env t
+  in
+  match ty.desc with
+    Tvar _ | Tunivar _ -> ty
+  | Tlink ty -> nondep_type_rec env ids ty
+  | _ -> try TypeHash.find nondep_hash ty
+  with Not_found ->
+    let ty' = newgenvar () in        (* Stub *)
+    TypeHash.add nondep_hash ty ty';
+    ty'.desc <-
+      begin match ty.desc with
+      | Tconstr(p, tl, _abbrev) ->
+          begin match Path.find_free_opt ids p with
+          | Some id ->
+              begin try
+                Tlink (nondep_type_rec ~expand_private env ids
+                         (expand_abbrev env (newty2 ty.level ty.desc)))
+                (*
+                   The [Tlink] is important. The expanded type may be a
+                   variable, or may not be completely copied yet
+                   (recursive type), so one cannot just take its
+                   description.
+                 *)
+              with Cannot_expand | Unify _ ->
+                raise (Nondep_cannot_erase id)
+              end
+          | None ->
+              Tconstr(p, List.map (nondep_type_rec env ids) tl, ref Mnil)
+          end
+      | Tpackage(p, nl, tl) when Path.exists_free ids p ->
+          let p' = normalize_package_path env p in
+          begin match Path.find_free_opt ids p' with
+          | Some id -> raise (Nondep_cannot_erase id)
+          | None -> Tpackage (p', nl, List.map (nondep_type_rec env ids) tl)
+          end
+      | Tobject (t1, name) ->
+          Tobject (nondep_type_rec env ids t1,
+                 ref (match !name with
+                        None -> None
+                      | Some (p, tl) ->
+                          if Path.exists_free ids p then None
+                          else Some (p, List.map (nondep_type_rec env ids) tl)))
+      | Tvariant row ->
+          let row = row_repr row in
+          let more = repr row.row_more in
+          (* We must keep sharing according to the row variable *)
+          begin try
+            let ty2 = TypeHash.find nondep_variants more in
+            (* This variant type has been already copied *)
+            TypeHash.add nondep_hash ty ty2;
+            Tlink ty2
+          with Not_found ->
+            (* Register new type first for recursion *)
+            TypeHash.add nondep_variants more ty';
+            let static = static_row row in
+            let more' = if static then newgenty Tnil else more in
+            (* Return a new copy *)
+            let row =
+              copy_row (nondep_type_rec env ids) true row true more' in
+            match row.row_name with
+              Some (p, _tl) when Path.exists_free ids p ->
+                Tvariant {row with row_name = None}
+            | _ -> Tvariant row
+          end
+      | _ -> copy_type_desc (nondep_type_rec env ids) ty.desc
+      end;
+    ty'
+
+let nondep_type env id ty =
+  try
+    let ty' = nondep_type_rec env id ty in
+    clear_hash ();
+    ty'
+  with Nondep_cannot_erase _ as exn ->
+    clear_hash ();
+    raise exn
+
+let () = nondep_type' := nondep_type
+
+(* Preserve sharing inside type declarations. *)
+let nondep_type_decl env mid is_covariant decl =
+  try
+    let params = List.map (nondep_type_rec env mid) decl.type_params in
+    let tk =
+      try map_kind (nondep_type_rec env mid) decl.type_kind
+      with Nondep_cannot_erase _ when is_covariant -> Type_abstract
+    and tm, priv =
+      match decl.type_manifest with
+      | None -> None, decl.type_private
+      | Some ty ->
+          try Some (nondep_type_rec env mid ty), decl.type_private
+          with Nondep_cannot_erase _ when is_covariant ->
+            clear_hash ();
+            try Some (nondep_type_rec ~expand_private:true env mid ty),
+                Private
+            with Nondep_cannot_erase _ ->
+              None, decl.type_private
+    in
+    clear_hash ();
+    let priv =
+      match tm with
+      | Some ty when Btype.has_constr_row ty -> Private
+      | _ -> priv
+    in
+    { type_params = params;
+      type_arity = decl.type_arity;
+      type_kind = tk;
+      type_manifest = tm;
+      type_private = priv;
+      type_variance = decl.type_variance;
+      type_separability = decl.type_separability;
+      type_is_newtype = false;
+      type_expansion_scope = Btype.lowest_level;
+      type_loc = decl.type_loc;
+      type_attributes = decl.type_attributes;
+      type_immediate = decl.type_immediate;
+      type_unboxed = decl.type_unboxed;
+      type_uid = decl.type_uid;
+    }
+  with Nondep_cannot_erase _ as exn ->
+    clear_hash ();
+    raise exn
+
+(* Preserve sharing inside extension constructors. *)
+let nondep_extension_constructor env ids ext =
+  try
+    let type_path, type_params =
+      match Path.find_free_opt ids ext.ext_type_path with
+      | Some id ->
+        begin
+          let ty =
+            newgenty (Tconstr(ext.ext_type_path, ext.ext_type_params, ref Mnil))
+          in
+          let ty' = nondep_type_rec env ids ty in
+            match (repr ty').desc with
+                Tconstr(p, tl, _) -> p, tl
+              | _ -> raise (Nondep_cannot_erase id)
+        end
+      | None ->
+        let type_params =
+          List.map (nondep_type_rec env ids) ext.ext_type_params
+        in
+          ext.ext_type_path, type_params
+    in
+    let args = map_type_expr_cstr_args (nondep_type_rec env ids) ext.ext_args in
+    let ret_type = Option.map (nondep_type_rec env ids) ext.ext_ret_type in
+      clear_hash ();
+      { ext_type_path = type_path;
+        ext_type_params = type_params;
+        ext_args = args;
+        ext_ret_type = ret_type;
+        ext_private = ext.ext_private;
+        ext_attributes = ext.ext_attributes;
+        ext_loc = ext.ext_loc;
+        ext_uid = ext.ext_uid;
+      }
+  with Nondep_cannot_erase _ as exn ->
+    clear_hash ();
+    raise exn
+
+
+(* Preserve sharing inside class types. *)
+let nondep_class_signature env id sign =
+  { csig_self = nondep_type_rec env id sign.csig_self;
+    csig_vars =
+      Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t))
+        sign.csig_vars;
+    csig_concr = sign.csig_concr;
+    csig_inher =
+      List.map (fun (p,tl) -> (p, List.map (nondep_type_rec env id) tl))
+        sign.csig_inher }
+
+let rec nondep_class_type env ids =
+  function
+    Cty_constr (p, _, cty) when Path.exists_free ids p ->
+      nondep_class_type env ids cty
+  | Cty_constr (p, tyl, cty) ->
+      Cty_constr (p, List.map (nondep_type_rec env ids) tyl,
+                   nondep_class_type env ids cty)
+  | Cty_signature sign ->
+      Cty_signature (nondep_class_signature env ids sign)
+  | Cty_arrow (l, ty, cty) ->
+      Cty_arrow (l, nondep_type_rec env ids ty, nondep_class_type env ids cty)
+
+let nondep_class_declaration env ids decl =
+  assert (not (Path.exists_free ids decl.cty_path));
+  let decl =
+    { cty_params = List.map (nondep_type_rec env ids) decl.cty_params;
+      cty_variance = decl.cty_variance;
+      cty_type = nondep_class_type env ids decl.cty_type;
+      cty_path = decl.cty_path;
+      cty_new =
+        begin match decl.cty_new with
+          None    -> None
+        | Some ty -> Some (nondep_type_rec env ids ty)
+        end;
+      cty_loc = decl.cty_loc;
+      cty_attributes = decl.cty_attributes;
+      cty_uid = decl.cty_uid;
+    }
+  in
+  clear_hash ();
+  decl
+
+let nondep_cltype_declaration env ids decl =
+  assert (not (Path.exists_free ids decl.clty_path));
+  let decl =
+    { clty_params = List.map (nondep_type_rec env ids) decl.clty_params;
+      clty_variance = decl.clty_variance;
+      clty_type = nondep_class_type env ids decl.clty_type;
+      clty_path = decl.clty_path;
+      clty_loc = decl.clty_loc;
+      clty_attributes = decl.clty_attributes;
+      clty_uid = decl.clty_uid;
+    }
+  in
+  clear_hash ();
+  decl
+
+(* collapse conjunctive types in class parameters *)
+let rec collapse_conj env visited ty =
+  let ty = repr ty in
+  if List.memq ty visited then () else
+  let visited = ty :: visited in
+  match ty.desc with
+    Tvariant row ->
+      let row = row_repr row in
+      List.iter
+        (fun (_l,fi) ->
+          match row_field_repr fi with
+            Reither (c, t1::(_::_ as tl), m, e) ->
+              List.iter (unify env t1) tl;
+              set_row_field e (Reither (c, [t1], m, ref None))
+          | _ ->
+              ())
+        row.row_fields;
+      iter_row (collapse_conj env visited) row
+  | _ ->
+      iter_type_expr (collapse_conj env visited) ty
+
+let collapse_conj_params env params =
+  List.iter (collapse_conj env []) params
+
+let same_constr env t1 t2 =
+  let t1 = expand_head env t1 in
+  let t2 = expand_head env t2 in
+  match t1.desc, t2.desc with
+  | Tconstr (p1, _, _), Tconstr (p2, _, _) -> Path.same p1 p2
+  | _ -> false
+
+let () =
+  Env.same_constr := same_constr
+
+let is_immediate = function
+  | Type_immediacy.Unknown -> false
+  | Type_immediacy.Always -> true
+  | Type_immediacy.Always_on_64bits ->
+      (* In bytecode, we don't know at compile time whether we are
+         targeting 32 or 64 bits. *)
+      !Clflags.native_code && Sys.word_size = 64
+
+let immediacy env typ =
+   match (repr typ).desc with
+  | Tconstr(p, _args, _abbrev) ->
+    begin try
+      let type_decl = Env.find_type p env in
+      type_decl.type_immediate
+    with Not_found -> Type_immediacy.Unknown
+    (* This can happen due to e.g. missing -I options,
+       causing some .cmi files to be unavailable.
+       Maybe we should emit a warning. *)
+    end
+  | Tvariant row ->
+      let row = Btype.row_repr row in
+      (* if all labels are devoid of arguments, not a pointer *)
+      if
+        not row.row_closed
+        || List.exists
+          (function
+            | _, (Rpresent (Some _) | Reither (false, _, _, _)) -> true
+            | _ -> false)
+          row.row_fields
+      then
+        Type_immediacy.Unknown
+      else
+        Type_immediacy.Always
+  | _ -> Type_immediacy.Unknown
+
+let maybe_pointer_type env typ = not (is_immediate (immediacy env typ))
diff --git a/upstream/ocaml_411/typing/ctype.mli b/upstream/ocaml_411/typing/ctype.mli
new file mode 100644
index 0000000..05fb78c
--- /dev/null
+++ b/upstream/ocaml_411/typing/ctype.mli
@@ -0,0 +1,371 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Operations on core types *)
+
+open Asttypes
+open Types
+
+module Unification_trace: sig
+  (** Unification traces are used to explain unification errors
+      when printing error messages *)
+
+  type position = First | Second
+  type desc = { t: type_expr; expanded: type_expr option }
+  type 'a diff = { got: 'a; expected: 'a}
+
+   (** Scope escape related errors *)
+    type 'a escape =
+    | Constructor of Path.t
+    | Univ of type_expr
+    (** The type_expr argument of [Univ] is always a [Tunivar _],
+        we keep a [type_expr] to track renaming in {!Printtyp} *)
+    | Self
+    | Module_type of Path.t
+    | Equation of 'a
+
+   (** Errors for polymorphic variants *)
+
+  type fixed_row_case =
+    | Cannot_be_closed
+    | Cannot_add_tags of string list
+
+  type variant =
+    | No_intersection
+    | No_tags of position * (Asttypes.label * row_field) list
+    | Incompatible_types_for of string
+    | Fixed_row of position * fixed_row_case * fixed_explanation
+    (** Fixed row types,  e.g. ['a. [> `X] as 'a] *)
+
+  type obj =
+    | Missing_field of position * string
+    | Abstract_row of position
+    | Self_cannot_be_closed
+
+  type 'a elt =
+    | Diff of 'a diff
+    | Variant of variant
+    | Obj of obj
+    | Escape of {context: type_expr option; kind:'a escape}
+    | Incompatible_fields of {name:string; diff: type_expr diff }
+    | Rec_occur of type_expr * type_expr
+
+  type t = desc elt list
+
+  val diff: type_expr -> type_expr -> desc elt
+
+  (** [map_diff f {expected;got}] is [{expected=f expected; got=f got}] *)
+  val map_diff: ('a -> 'b) -> 'a diff -> 'b diff
+
+  (** [flatten f trace] flattens all elements of type {!desc} in
+      [trace] to either [f x.t expanded] if [x.expanded=Some expanded]
+      or [f x.t x.t] otherwise *)
+  val flatten: (type_expr -> type_expr -> 'a) -> t -> 'a elt list
+
+  (** Switch [expected] and [got] *)
+  val swap: t -> t
+
+  (** [explain trace f] calls [f] on trace elements starting from the end
+      until [f ~prev elt] is [Some _], returns that
+      or [None] if the end of the trace is reached. *)
+  val explain:
+          'a elt list ->
+          (prev:'a elt option -> 'a elt -> 'b option) ->
+          'b option
+
+end
+
+exception Unify of Unification_trace.t
+exception Tags of label * label
+exception Subtype of Unification_trace.t * Unification_trace.t
+exception Cannot_expand
+exception Cannot_apply
+
+val init_def: int -> unit
+        (* Set the initial variable level *)
+val begin_def: unit -> unit
+        (* Raise the variable level by one at the beginning of a definition. *)
+val end_def: unit -> unit
+        (* Lower the variable level by one at the end of a definition *)
+val begin_class_def: unit -> unit
+val raise_nongen_level: unit -> unit
+val reset_global_level: unit -> unit
+        (* Reset the global level before typing an expression *)
+val increase_global_level: unit -> int
+val restore_global_level: int -> unit
+        (* This pair of functions is only used in Typetexp *)
+type levels =
+    { current_level: int; nongen_level: int; global_level: int;
+      saved_level: (int * int) list; }
+val save_levels: unit -> levels
+val set_levels: levels -> unit
+
+val create_scope : unit -> int
+
+val newty: type_desc -> type_expr
+val newvar: ?name:string -> unit -> type_expr
+val newvar2: ?name:string -> int -> type_expr
+        (* Return a fresh variable *)
+val new_global_var: ?name:string -> unit -> type_expr
+        (* Return a fresh variable, bound at toplevel
+           (as type variables ['a] in type constraints). *)
+val newobj: type_expr -> type_expr
+val newconstr: Path.t -> type_expr list -> type_expr
+val none: type_expr
+        (* A dummy type expression *)
+
+val repr: type_expr -> type_expr
+        (* Return the canonical representative of a type. *)
+
+val object_fields: type_expr -> type_expr
+val flatten_fields:
+        type_expr -> (string * field_kind * type_expr) list * type_expr
+        (* Transform a field type into a list of pairs label-type *)
+        (* The fields are sorted *)
+val associate_fields:
+        (string * field_kind * type_expr) list ->
+        (string * field_kind * type_expr) list ->
+        (string * field_kind * type_expr * field_kind * type_expr) list *
+        (string * field_kind * type_expr) list *
+        (string * field_kind * type_expr) list
+val opened_object: type_expr -> bool
+val close_object: type_expr -> bool
+val row_variable: type_expr -> type_expr
+        (* Return the row variable of an open object type *)
+val set_object_name:
+        Ident.t -> type_expr -> type_expr list -> type_expr -> unit
+val remove_object_name: type_expr -> unit
+val hide_private_methods: type_expr -> unit
+val find_cltype_for_path: Env.t -> Path.t -> type_declaration * type_expr
+
+val sort_row_fields: (label * row_field) list -> (label * row_field) list
+val merge_row_fields:
+        (label * row_field) list -> (label * row_field) list ->
+        (label * row_field) list * (label * row_field) list *
+        (label * row_field * row_field) list
+val filter_row_fields:
+        bool -> (label * row_field) list -> (label * row_field) list
+
+val generalize: type_expr -> unit
+        (* Generalize in-place the given type *)
+val lower_contravariant: Env.t -> type_expr -> unit
+        (* Lower level of type variables inside contravariant branches;
+           to be used before generalize for expansive expressions *)
+val generalize_structure: type_expr -> unit
+        (* Same, but variables are only lowered to !current_level *)
+val generalize_spine: type_expr -> unit
+        (* Special function to generalize a method during inference *)
+val correct_levels: type_expr -> type_expr
+        (* Returns a copy with decreasing levels *)
+val limited_generalize: type_expr -> type_expr -> unit
+        (* Only generalize some part of the type
+           Make the remaining of the type non-generalizable *)
+
+val check_scope_escape : Env.t -> int -> type_expr -> unit
+        (* [check_scope_escape env lvl ty] ensures that [ty] could be raised
+           to the level [lvl] without any scope escape.
+           Raises [Unify] otherwise *)
+
+val instance: ?partial:bool -> type_expr -> type_expr
+        (* Take an instance of a type scheme *)
+        (* partial=None  -> normal
+           partial=false -> newvar() for non generic subterms
+           partial=true  -> newty2 ty.level Tvar for non generic subterms *)
+val generic_instance: type_expr -> type_expr
+        (* Same as instance, but new nodes at generic_level *)
+val instance_list: type_expr list -> type_expr list
+        (* Take an instance of a list of type schemes *)
+val existential_name: constructor_description -> type_expr -> string
+val instance_constructor:
+        ?in_pattern:Env.t ref * int ->
+        constructor_description -> type_expr list * type_expr
+        (* Same, for a constructor *)
+val instance_parameterized_type:
+        ?keep_names:bool ->
+        type_expr list -> type_expr -> type_expr list * type_expr
+val instance_parameterized_type_2:
+        type_expr list -> type_expr list -> type_expr ->
+        type_expr list * type_expr list * type_expr
+val instance_declaration: type_declaration -> type_declaration
+val generic_instance_declaration: type_declaration -> type_declaration
+        (* Same as instance_declaration, but new nodes at generic_level *)
+val instance_class:
+        type_expr list -> class_type -> type_expr list * class_type
+val instance_poly:
+        ?keep_names:bool ->
+        bool -> type_expr list -> type_expr -> type_expr list * type_expr
+        (* Take an instance of a type scheme containing free univars *)
+val polyfy: Env.t -> type_expr -> type_expr list -> type_expr * bool
+val instance_label:
+        bool -> label_description -> type_expr list * type_expr * type_expr
+        (* Same, for a label *)
+val apply:
+        Env.t -> type_expr list -> type_expr -> type_expr list -> type_expr
+        (* [apply [p1...pN] t [a1...aN]] match the arguments [ai] to
+        the parameters [pi] and returns the corresponding instance of
+        [t]. Exception [Cannot_apply] is raised in case of failure. *)
+
+val expand_head_once: Env.t -> type_expr -> type_expr
+val expand_head: Env.t -> type_expr -> type_expr
+val try_expand_once_opt: Env.t -> type_expr -> type_expr
+val expand_head_opt: Env.t -> type_expr -> type_expr
+(** The compiler's own version of [expand_head] necessary for type-based
+    optimisations. *)
+
+val full_expand: Env.t -> type_expr -> type_expr
+val extract_concrete_typedecl:
+        Env.t -> type_expr -> Path.t * Path.t * type_declaration
+        (* Return the original path of the types, and the first concrete
+           type declaration found expanding it.
+           Raise [Not_found] if none appears or not a type constructor. *)
+
+val enforce_constraints: Env.t -> type_expr -> unit
+
+val unify: Env.t -> type_expr -> type_expr -> unit
+        (* Unify the two types given. Raise [Unify] if not possible. *)
+val unify_gadt:
+        equations_level:int -> Env.t ref -> type_expr -> type_expr -> unit
+        (* Unify the two types given and update the environment with the
+           local constraints. Raise [Unify] if not possible. *)
+val unify_var: Env.t -> type_expr -> type_expr -> unit
+        (* Same as [unify], but allow free univars when first type
+           is a variable. *)
+val filter_arrow: Env.t -> type_expr -> arg_label -> type_expr * type_expr
+        (* A special case of unification (with l:'a -> 'b). *)
+val filter_method: Env.t -> string -> private_flag -> type_expr -> type_expr
+        (* A special case of unification (with {m : 'a; 'b}). *)
+val check_filter_method: Env.t -> string -> private_flag -> type_expr -> unit
+        (* A special case of unification (with {m : 'a; 'b}), returning unit. *)
+val occur_in: Env.t -> type_expr -> type_expr -> bool
+val deep_occur: type_expr -> type_expr -> bool
+val filter_self_method:
+        Env.t -> string -> private_flag -> (Ident.t * type_expr) Meths.t ref ->
+        type_expr -> Ident.t * type_expr
+val moregeneral: Env.t -> bool -> type_expr -> type_expr -> bool
+        (* Check if the first type scheme is more general than the second. *)
+
+val rigidify: type_expr -> type_expr list
+        (* "Rigidify" a type and return its type variable *)
+val all_distinct_vars: Env.t -> type_expr list -> bool
+        (* Check those types are all distinct type variables *)
+val matches: Env.t -> type_expr -> type_expr -> bool
+        (* Same as [moregeneral false], implemented using the two above
+           functions and backtracking. Ignore levels *)
+
+val reify_univars : Env.t -> Types.type_expr -> Types.type_expr
+        (* Replaces all the variables of a type by a univar. *)
+
+type class_match_failure =
+    CM_Virtual_class
+  | CM_Parameter_arity_mismatch of int * int
+  | CM_Type_parameter_mismatch of Env.t * Unification_trace.t
+  | CM_Class_type_mismatch of Env.t * class_type * class_type
+  | CM_Parameter_mismatch of Env.t * Unification_trace.t
+  | CM_Val_type_mismatch of string * Env.t * Unification_trace.t
+  | CM_Meth_type_mismatch of string * Env.t * Unification_trace.t
+  | CM_Non_mutable_value of string
+  | CM_Non_concrete_value of string
+  | CM_Missing_value of string
+  | CM_Missing_method of string
+  | CM_Hide_public of string
+  | CM_Hide_virtual of string * string
+  | CM_Public_method of string
+  | CM_Private_method of string
+  | CM_Virtual_method of string
+val match_class_types:
+    ?trace:bool -> Env.t -> class_type -> class_type -> class_match_failure list
+        (* Check if the first class type is more general than the second. *)
+val equal: Env.t -> bool -> type_expr list -> type_expr list -> bool
+        (* [equal env [x1...xn] tau [y1...yn] sigma]
+           checks whether the parameterized types
+           [/\x1.../\xn.tau] and [/\y1.../\yn.sigma] are equivalent. *)
+val match_class_declarations:
+        Env.t -> type_expr list -> class_type -> type_expr list ->
+        class_type -> class_match_failure list
+        (* Check if the first class type is more general than the second. *)
+
+val enlarge_type: Env.t -> type_expr -> type_expr * bool
+        (* Make a type larger, flag is true if some pruning had to be done *)
+val subtype: Env.t -> type_expr -> type_expr -> unit -> unit
+        (* [subtype env t1 t2] checks that [t1] is a subtype of [t2].
+           It accumulates the constraints the type variables must
+           enforce and returns a function that enforces this
+           constraints. *)
+
+exception Nondep_cannot_erase of Ident.t
+
+val nondep_type: Env.t -> Ident.t list -> type_expr -> type_expr
+        (* Return a type equivalent to the given type but without
+           references to any of the given identifiers.
+           Raise [Nondep_cannot_erase id] if no such type exists because [id],
+           in particular, could not be erased. *)
+val nondep_type_decl:
+        Env.t -> Ident.t list -> bool -> type_declaration -> type_declaration
+        (* Same for type declarations. *)
+val nondep_extension_constructor:
+        Env.t -> Ident.t list -> extension_constructor ->
+        extension_constructor
+          (* Same for extension constructor *)
+val nondep_class_declaration:
+        Env.t -> Ident.t list -> class_declaration -> class_declaration
+        (* Same for class declarations. *)
+val nondep_cltype_declaration:
+  Env.t -> Ident.t list -> class_type_declaration -> class_type_declaration
+        (* Same for class type declarations. *)
+(*val correct_abbrev: Env.t -> Path.t -> type_expr list -> type_expr -> unit*)
+val cyclic_abbrev: Env.t -> Ident.t -> type_expr -> bool
+val is_contractive: Env.t -> Path.t -> bool
+val normalize_type: Env.t -> type_expr -> unit
+
+val closed_schema: Env.t -> type_expr -> bool
+        (* Check whether the given type scheme contains no non-generic
+           type variables *)
+
+val free_variables: ?env:Env.t -> type_expr -> type_expr list
+        (* If env present, then check for incomplete definitions too *)
+val closed_type_decl: type_declaration -> type_expr option
+val closed_extension_constructor: extension_constructor -> type_expr option
+type closed_class_failure =
+    CC_Method of type_expr * bool * string * type_expr
+  | CC_Value of type_expr * bool * string * type_expr
+val closed_class:
+        type_expr list -> class_signature -> closed_class_failure option
+        (* Check whether all type variables are bound *)
+
+val unalias: type_expr -> type_expr
+val signature_of_class_type: class_type -> class_signature
+val self_type: class_type -> type_expr
+val class_type_arity: class_type -> int
+val arity: type_expr -> int
+        (* Return the arity (as for curried functions) of the given type. *)
+
+val collapse_conj_params: Env.t -> type_expr list -> unit
+        (* Collapse conjunctive types in class parameters *)
+
+val get_current_level: unit -> int
+val wrap_trace_gadt_instances: Env.t -> ('a -> 'b) -> 'a -> 'b
+val reset_reified_var_counter: unit -> unit
+
+val immediacy : Env.t -> type_expr -> Type_immediacy.t
+
+val maybe_pointer_type : Env.t -> type_expr -> bool
+       (* True if type is possibly pointer, false if definitely not a pointer *)
+
+(* Stubs *)
+val package_subtype :
+    (Env.t -> Path.t -> Longident.t list -> type_expr list ->
+      Path.t -> Longident.t list -> type_expr list -> bool) ref
+
+val mcomp : Env.t -> type_expr -> type_expr -> unit
diff --git a/upstream/ocaml_411/typing/datarepr.ml b/upstream/ocaml_411/typing/datarepr.ml
new file mode 100644
index 0000000..818d60a
--- /dev/null
+++ b/upstream/ocaml_411/typing/datarepr.ml
@@ -0,0 +1,258 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Compute constructor and label descriptions from type declarations,
+   determining their representation. *)
+
+open Asttypes
+open Types
+open Btype
+
+(* Simplified version of Ctype.free_vars *)
+let free_vars ?(param=false) ty =
+  let ret = ref TypeSet.empty in
+  let rec loop ty =
+    let ty = repr ty in
+    if ty.level >= lowest_level then begin
+      ty.level <- pivot_level - ty.level;
+      match ty.desc with
+      | Tvar _ ->
+          ret := TypeSet.add ty !ret
+      | Tvariant row ->
+          let row = row_repr row in
+          iter_row loop row;
+          if not (static_row row) then begin
+            match row.row_more.desc with
+            | Tvar _ when param -> ret := TypeSet.add ty !ret
+            | _ -> loop row.row_more
+          end
+      (* XXX: What about Tobject ? *)
+      | _ ->
+          iter_type_expr loop ty
+    end
+  in
+  loop ty;
+  unmark_type ty;
+  !ret
+
+let newgenconstr path tyl = newgenty (Tconstr (path, tyl, ref Mnil))
+
+let constructor_existentials cd_args cd_res =
+  let tyl =
+    match cd_args with
+    | Cstr_tuple l -> l
+    | Cstr_record l -> List.map (fun l -> l.ld_type) l
+  in
+  let existentials =
+    match cd_res with
+    | None -> []
+    | Some type_ret ->
+        let arg_vars_set = free_vars (newgenty (Ttuple tyl)) in
+        let res_vars = free_vars type_ret in
+        TypeSet.elements (TypeSet.diff arg_vars_set res_vars)
+  in
+  (tyl, existentials)
+
+let constructor_args ~current_unit priv cd_args cd_res path rep =
+  let tyl, existentials = constructor_existentials cd_args cd_res in
+  match cd_args with
+  | Cstr_tuple l -> existentials, l, None
+  | Cstr_record lbls ->
+      let arg_vars_set = free_vars ~param:true (newgenty (Ttuple tyl)) in
+      let type_params = TypeSet.elements arg_vars_set in
+      let type_unboxed =
+        match rep with
+        | Record_unboxed _ -> unboxed_true_default_false
+        | _ -> unboxed_false_default_false
+      in
+      let arity = List.length type_params in
+      let tdecl =
+        {
+          type_params;
+          type_arity = arity;
+          type_kind = Type_record (lbls, rep);
+          type_private = priv;
+          type_manifest = None;
+          type_variance = List.map (fun _ -> Variance.full) type_params;
+          type_separability = Types.Separability.default_signature ~arity;
+          type_is_newtype = false;
+          type_expansion_scope = Btype.lowest_level;
+          type_loc = Location.none;
+          type_attributes = [];
+          type_immediate = Unknown;
+          type_unboxed;
+          type_uid = Uid.mk ~current_unit;
+        }
+      in
+      existentials,
+      [ newgenconstr path type_params ],
+      Some tdecl
+
+let constructor_descrs ~current_unit ty_path decl cstrs =
+  let ty_res = newgenconstr ty_path decl.type_params in
+  let num_consts = ref 0 and num_nonconsts = ref 0  and num_normal = ref 0 in
+  List.iter
+    (fun {cd_args; cd_res; _} ->
+      if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts;
+      if cd_res = None then incr num_normal)
+    cstrs;
+  let rec describe_constructors idx_const idx_nonconst = function
+      [] -> []
+    | {cd_id; cd_args; cd_res; cd_loc; cd_attributes; cd_uid} :: rem ->
+        let ty_res =
+          match cd_res with
+          | Some ty_res' -> ty_res'
+          | None -> ty_res
+        in
+        let (tag, descr_rem) =
+          match cd_args with
+          | _ when decl.type_unboxed.unboxed ->
+            assert (rem = []);
+            (Cstr_unboxed, [])
+          | Cstr_tuple [] -> (Cstr_constant idx_const,
+                   describe_constructors (idx_const+1) idx_nonconst rem)
+          | _  -> (Cstr_block idx_nonconst,
+                   describe_constructors idx_const (idx_nonconst+1) rem) in
+        let cstr_name = Ident.name cd_id in
+        let existentials, cstr_args, cstr_inlined =
+          let representation =
+            if decl.type_unboxed.unboxed
+            then Record_unboxed true
+            else Record_inlined idx_nonconst
+          in
+          constructor_args ~current_unit decl.type_private cd_args cd_res
+            (Path.Pdot (ty_path, cstr_name)) representation
+        in
+        let cstr =
+          { cstr_name;
+            cstr_res = ty_res;
+            cstr_existentials = existentials;
+            cstr_args;
+            cstr_arity = List.length cstr_args;
+            cstr_tag = tag;
+            cstr_consts = !num_consts;
+            cstr_nonconsts = !num_nonconsts;
+            cstr_normal = !num_normal;
+            cstr_private = decl.type_private;
+            cstr_generalized = cd_res <> None;
+            cstr_loc = cd_loc;
+            cstr_attributes = cd_attributes;
+            cstr_inlined;
+            cstr_uid = cd_uid;
+          } in
+        (cd_id, cstr) :: descr_rem in
+  describe_constructors 0 0 cstrs
+
+let extension_descr ~current_unit path_ext ext =
+  let ty_res =
+    match ext.ext_ret_type with
+        Some type_ret -> type_ret
+      | None -> newgenconstr ext.ext_type_path ext.ext_type_params
+  in
+  let existentials, cstr_args, cstr_inlined =
+    constructor_args ~current_unit ext.ext_private ext.ext_args ext.ext_ret_type
+      path_ext (Record_extension path_ext)
+  in
+    { cstr_name = Path.last path_ext;
+      cstr_res = ty_res;
+      cstr_existentials = existentials;
+      cstr_args;
+      cstr_arity = List.length cstr_args;
+      cstr_tag = Cstr_extension(path_ext, cstr_args = []);
+      cstr_consts = -1;
+      cstr_nonconsts = -1;
+      cstr_private = ext.ext_private;
+      cstr_normal = -1;
+      cstr_generalized = ext.ext_ret_type <> None;
+      cstr_loc = ext.ext_loc;
+      cstr_attributes = ext.ext_attributes;
+      cstr_inlined;
+      cstr_uid = ext.ext_uid;
+    }
+
+let none = {desc = Ttuple []; level = -1; scope = Btype.generic_level; id = -1}
+                                        (* Clearly ill-formed type *)
+let dummy_label =
+  { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable;
+    lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular;
+    lbl_private = Public;
+    lbl_loc = Location.none;
+    lbl_attributes = [];
+    lbl_uid = Uid.internal_not_actually_unique;
+  }
+
+let label_descrs ty_res lbls repres priv =
+  let all_labels = Array.make (List.length lbls) dummy_label in
+  let rec describe_labels num = function
+      [] -> []
+    | l :: rest ->
+        let lbl =
+          { lbl_name = Ident.name l.ld_id;
+            lbl_res = ty_res;
+            lbl_arg = l.ld_type;
+            lbl_mut = l.ld_mutable;
+            lbl_pos = num;
+            lbl_all = all_labels;
+            lbl_repres = repres;
+            lbl_private = priv;
+            lbl_loc = l.ld_loc;
+            lbl_attributes = l.ld_attributes;
+            lbl_uid = l.ld_uid;
+          } in
+        all_labels.(num) <- lbl;
+        (l.ld_id, lbl) :: describe_labels (num+1) rest in
+  describe_labels 0 lbls
+
+exception Constr_not_found
+
+let rec find_constr tag num_const num_nonconst = function
+    [] ->
+      raise Constr_not_found
+  | {cd_args = Cstr_tuple []; _} as c  :: rem ->
+      if tag = Cstr_constant num_const
+      then c
+      else find_constr tag (num_const + 1) num_nonconst rem
+  | c :: rem ->
+      if tag = Cstr_block num_nonconst || tag = Cstr_unboxed
+      then c
+      else find_constr tag num_const (num_nonconst + 1) rem
+
+let find_constr_by_tag tag cstrlist =
+  find_constr tag 0 0 cstrlist
+
+let constructors_of_type ~current_unit ty_path decl =
+  match decl.type_kind with
+  | Type_variant cstrs -> constructor_descrs ~current_unit ty_path decl cstrs
+  | Type_record _ | Type_abstract | Type_open -> []
+
+let labels_of_type ty_path decl =
+  match decl.type_kind with
+  | Type_record(labels, rep) ->
+      label_descrs (newgenconstr ty_path decl.type_params)
+        labels rep decl.type_private
+  | Type_variant _ | Type_abstract | Type_open -> []
+
+(* Set row_name in Env, cf. GPR#1204/1329 *)
+let set_row_name decl path =
+  match decl.type_manifest with
+    None -> ()
+  | Some ty ->
+      let ty = repr ty in
+      match ty.desc with
+        Tvariant row when static_row row ->
+          let row = {(row_repr row) with
+                     row_name = Some (path, decl.type_params)} in
+          ty.desc <- Tvariant row
+      | _ -> ()
diff --git a/upstream/ocaml_411/typing/datarepr.mli b/upstream/ocaml_411/typing/datarepr.mli
new file mode 100644
index 0000000..e3962e3
--- /dev/null
+++ b/upstream/ocaml_411/typing/datarepr.mli
@@ -0,0 +1,49 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Compute constructor and label descriptions from type declarations,
+   determining their representation. *)
+
+open Types
+
+val extension_descr:
+  current_unit:string -> Path.t -> extension_constructor ->
+  constructor_description
+
+val labels_of_type:
+  Path.t -> type_declaration ->
+  (Ident.t * label_description) list
+val constructors_of_type:
+  current_unit:string -> Path.t -> type_declaration ->
+  (Ident.t * constructor_description) list
+
+
+exception Constr_not_found
+
+val find_constr_by_tag:
+  constructor_tag -> constructor_declaration list ->
+    constructor_declaration
+
+val constructor_existentials :
+    constructor_arguments -> type_expr option -> type_expr list * type_expr list
+(** Takes [cd_args] and [cd_res] from a [constructor_declaration] and
+    returns:
+    - the types of the constructor's arguments
+    - the existential variables introduced by the constructor
+ *)
+
+
+(* Set the polymorphic variant row_name field *)
+val set_row_name : type_declaration -> Path.t -> unit
diff --git a/upstream/ocaml_411/typing/env.ml b/upstream/ocaml_411/typing/env.ml
new file mode 100644
index 0000000..9abbd08
--- /dev/null
+++ b/upstream/ocaml_411/typing/env.ml
@@ -0,0 +1,3174 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Environment handling *)
+
+open Cmi_format
+open Misc
+open Asttypes
+open Longident
+open Path
+open Types
+open Btype
+
+module String = Misc.Stdlib.String
+
+let add_delayed_check_forward = ref (fun _ -> assert false)
+
+type 'a usage_tbl = ('a -> unit) Types.Uid.Tbl.t
+(** This table is used to track usage of value declarations.
+    A declaration is identified by its uid.
+    The callback attached to a declaration is called whenever the value (or
+    type, or ...) is used explicitly (lookup_value, ...) or implicitly
+    (inclusion test between signatures, cf Includemod.value_descriptions, ...).
+*)
+
+let value_declarations  : unit usage_tbl = Types.Uid.Tbl.create 16
+let type_declarations   : unit usage_tbl = Types.Uid.Tbl.create 16
+let module_declarations : unit usage_tbl = Types.Uid.Tbl.create 16
+
+type constructor_usage = Positive | Pattern | Privatize
+type constructor_usages =
+    {
+     mutable cu_positive: bool;
+     mutable cu_pattern: bool;
+     mutable cu_privatize: bool;
+    }
+let add_constructor_usage ~rebind priv cu usage =
+  let private_or_rebind =
+    match priv with
+    | Asttypes.Private -> true
+    | Asttypes.Public -> rebind
+  in
+  if private_or_rebind then begin
+    cu.cu_positive <- true
+  end else begin
+    match usage with
+    | Positive -> cu.cu_positive <- true
+    | Pattern -> cu.cu_pattern <- true
+    | Privatize -> cu.cu_privatize <- true
+  end
+
+let constructor_usages () =
+  {cu_positive = false; cu_pattern = false; cu_privatize = false}
+
+let used_constructors : constructor_usage usage_tbl = Types.Uid.Tbl.create 16
+
+(** Map indexed by the name of module components. *)
+module NameMap = String.Map
+
+type value_unbound_reason =
+  | Val_unbound_instance_variable
+  | Val_unbound_self
+  | Val_unbound_ancestor
+  | Val_unbound_ghost_recursive of Location.t
+
+type module_unbound_reason =
+  | Mod_unbound_illegal_recursion
+
+type summary =
+    Env_empty
+  | Env_value of summary * Ident.t * value_description
+  | Env_type of summary * Ident.t * type_declaration
+  | Env_extension of summary * Ident.t * extension_constructor
+  | Env_module of summary * Ident.t * module_presence * module_declaration
+  | Env_modtype of summary * Ident.t * modtype_declaration
+  | Env_class of summary * Ident.t * class_declaration
+  | Env_cltype of summary * Ident.t * class_type_declaration
+  | Env_open of summary * Path.t
+  | Env_functor_arg of summary * Ident.t
+  | Env_constraints of summary * type_declaration Path.Map.t
+  | Env_copy_types of summary
+  | Env_persistent of summary * Ident.t
+  | Env_value_unbound of summary * string * value_unbound_reason
+  | Env_module_unbound of summary * string * module_unbound_reason
+
+type address =
+  | Aident of Ident.t
+  | Adot of address * int
+
+module TycompTbl =
+  struct
+    (** This module is used to store components of types (i.e. labels
+        and constructors).  We keep a representation of each nested
+        "open" and the set of local bindings between each of them. *)
+
+    type 'a t = {
+      current: 'a Ident.tbl;
+      (** Local bindings since the last open. *)
+
+      opened: 'a opened option;
+      (** Symbolic representation of the last (innermost) open, if any. *)
+    }
+
+    and 'a opened = {
+      components: ('a list) NameMap.t;
+      (** Components from the opened module. We keep a list of
+          bindings for each name, as in comp_labels and
+          comp_constrs. *)
+
+      using: (string -> ('a * 'a) option -> unit) option;
+      (** A callback to be applied when a component is used from this
+          "open".  This is used to detect unused "opens".  The
+          arguments are used to detect shadowing. *)
+
+      next: 'a t;
+      (** The table before opening the module. *)
+    }
+
+    let empty = { current = Ident.empty; opened = None }
+
+    let add id x tbl =
+      {tbl with current = Ident.add id x tbl.current}
+
+    let add_open slot wrap components next =
+      let using =
+        match slot with
+        | None -> None
+        | Some f -> Some (fun s x -> f s (wrap x))
+      in
+      {
+        current = Ident.empty;
+        opened = Some {using; components; next};
+      }
+
+    let rec find_same id tbl =
+      try Ident.find_same id tbl.current
+      with Not_found as exn ->
+        begin match tbl.opened with
+        | Some {next; _} -> find_same id next
+        | None -> raise exn
+        end
+
+    let nothing = fun () -> ()
+
+    let mk_callback rest name desc using =
+      match using with
+      | None -> nothing
+      | Some f ->
+          (fun () ->
+             match rest with
+             | [] -> f name None
+             | (hidden, _) :: _ -> f name (Some (desc, hidden)))
+
+    let rec find_all ~mark name tbl =
+      List.map (fun (_id, desc) -> desc, nothing)
+        (Ident.find_all name tbl.current) @
+      match tbl.opened with
+      | None -> []
+      | Some {using; next; components} ->
+          let rest = find_all ~mark name next in
+          let using = if mark then using else None in
+          match NameMap.find name components with
+          | exception Not_found -> rest
+          | opened ->
+              List.map
+                (fun desc -> desc, mk_callback rest name desc using)
+                opened
+              @ rest
+
+    let rec fold_name f tbl acc =
+      let acc = Ident.fold_name (fun _id d -> f d) tbl.current acc in
+      match tbl.opened with
+      | Some {using = _; next; components} ->
+          acc
+          |> NameMap.fold
+            (fun _name -> List.fold_right f)
+            components
+          |> fold_name f next
+      | None ->
+          acc
+
+    let rec local_keys tbl acc =
+      let acc = Ident.fold_all (fun k _ accu -> k::accu) tbl.current acc in
+      match tbl.opened with
+      | Some o -> local_keys o.next acc
+      | None -> acc
+
+    let diff_keys is_local tbl1 tbl2 =
+      let keys2 = local_keys tbl2 [] in
+      List.filter
+        (fun id ->
+           is_local (find_same id tbl2) &&
+           try ignore (find_same id tbl1); false
+           with Not_found -> true)
+        keys2
+
+  end
+
+
+module IdTbl =
+  struct
+    (** This module is used to store all kinds of components except
+        (labels and constructors) in environments.  We keep a
+        representation of each nested "open" and the set of local
+        bindings between each of them. *)
+
+
+    type ('a, 'b) t = {
+      current: 'a Ident.tbl;
+      (** Local bindings since the last open *)
+
+      layer: ('a, 'b) layer;
+      (** Symbolic representation of the last (innermost) open, if any. *)
+    }
+
+    and ('a, 'b) layer =
+      | Open of {
+          root: Path.t;
+          (** The path of the opened module, to be prefixed in front of
+              its local names to produce a valid path in the current
+              environment. *)
+
+          components: 'b NameMap.t;
+          (** Components from the opened module. *)
+
+          using: (string -> ('a * 'a) option -> unit) option;
+          (** A callback to be applied when a component is used from this
+              "open".  This is used to detect unused "opens".  The
+              arguments are used to detect shadowing. *)
+
+          next: ('a, 'b) t;
+          (** The table before opening the module. *)
+        }
+
+      | Map of {
+          f: ('a -> 'a);
+          next: ('a, 'b) t;
+        }
+
+      | Nothing
+
+    let empty = { current = Ident.empty; layer = Nothing }
+
+    let add id x tbl =
+      {tbl with current = Ident.add id x tbl.current}
+
+    let remove id tbl =
+      {tbl with current = Ident.remove id tbl.current}
+
+    let add_open slot wrap root components next =
+      let using =
+        match slot with
+        | None -> None
+        | Some f -> Some (fun s x -> f s (wrap x))
+      in
+      {
+        current = Ident.empty;
+        layer = Open {using; root; components; next};
+      }
+
+    let map f next =
+      {
+        current = Ident.empty;
+        layer = Map {f; next}
+      }
+
+    let rec find_same id tbl =
+      try Ident.find_same id tbl.current
+      with Not_found as exn ->
+        begin match tbl.layer with
+        | Open {next; _} -> find_same id next
+        | Map {f; next} -> f (find_same id next)
+        | Nothing -> raise exn
+        end
+
+    let rec find_name wrap ~mark name tbl =
+      try
+        let (id, desc) = Ident.find_name name tbl.current in
+        Pident id, desc
+      with Not_found as exn ->
+        begin match tbl.layer with
+        | Open {using; root; next; components} ->
+            begin try
+              let descr = wrap (NameMap.find name components) in
+              let res = Pdot (root, name), descr in
+              if mark then begin match using with
+              | None -> ()
+              | Some f -> begin
+                  match find_name wrap ~mark:false name next with
+                  | exception Not_found -> f name None
+                  | _, descr' -> f name (Some (descr', descr))
+                end
+              end;
+              res
+            with Not_found ->
+              find_name wrap ~mark name next
+            end
+        | Map {f; next} ->
+            let (p, desc) =  find_name wrap ~mark name next in
+            p, f desc
+        | Nothing ->
+            raise exn
+        end
+
+    let rec find_all wrap name tbl =
+      List.map
+        (fun (id, desc) -> Pident id, desc)
+        (Ident.find_all name tbl.current) @
+      match tbl.layer with
+      | Nothing -> []
+      | Open {root; using = _; next; components} ->
+          begin try
+            let desc = wrap (NameMap.find name components) in
+            (Pdot (root, name), desc) :: find_all wrap name next
+          with Not_found ->
+            find_all wrap name next
+          end
+      | Map {f; next} ->
+          List.map (fun (p, desc) -> (p, f desc))
+            (find_all wrap name next)
+
+    let rec fold_name wrap f tbl acc =
+      let acc =
+        Ident.fold_name
+          (fun id d -> f (Ident.name id) (Pident id, d))
+          tbl.current acc
+      in
+      match tbl.layer with
+      | Open {root; using = _; next; components} ->
+          acc
+          |> NameMap.fold
+            (fun name desc -> f name (Pdot (root, name), wrap desc))
+            components
+          |> fold_name wrap f next
+      | Nothing ->
+          acc
+      | Map {f=g; next} ->
+          acc
+          |> fold_name wrap
+               (fun name (path, desc) -> f name (path, g desc))
+               next
+
+    let rec local_keys tbl acc =
+      let acc = Ident.fold_all (fun k _ accu -> k::accu) tbl.current acc in
+      match tbl.layer with
+      | Open {next; _ } | Map {next; _} -> local_keys next acc
+      | Nothing -> acc
+
+
+    let rec iter wrap f tbl =
+      Ident.iter (fun id desc -> f id (Pident id, desc)) tbl.current;
+      match tbl.layer with
+      | Open {root; using = _; next; components} ->
+          NameMap.iter
+            (fun s x ->
+               let root_scope = Path.scope root in
+              f (Ident.create_scoped ~scope:root_scope s)
+                (Pdot (root, s), wrap x))
+            components;
+          iter wrap f next
+      | Map {f=g; next} ->
+          iter wrap (fun id (path, desc) -> f id (path, g desc)) next
+      | Nothing -> ()
+
+    let diff_keys tbl1 tbl2 =
+      let keys2 = local_keys tbl2 [] in
+      List.filter
+        (fun id ->
+           try ignore (find_same id tbl1); false
+           with Not_found -> true)
+        keys2
+
+
+  end
+
+type type_descriptions =
+    constructor_description list * label_description list
+
+let in_signature_flag = 0x01
+
+type t = {
+  values: (value_entry, value_data) IdTbl.t;
+  constrs: constructor_data TycompTbl.t;
+  labels: label_data TycompTbl.t;
+  types: (type_data, type_data) IdTbl.t;
+  modules: (module_entry, module_data) IdTbl.t;
+  modtypes: (modtype_data, modtype_data) IdTbl.t;
+  classes: (class_data, class_data) IdTbl.t;
+  cltypes: (cltype_data, cltype_data) IdTbl.t;
+  functor_args: unit Ident.tbl;
+  summary: summary;
+  local_constraints: type_declaration Path.Map.t;
+  flags: int;
+}
+
+and module_declaration_lazy =
+  (Subst.t * Subst.scoping * module_declaration, module_declaration) EnvLazy.t
+
+and module_components =
+  {
+    alerts: alerts;
+    uid: Uid.t;
+    comps:
+      (components_maker,
+       (module_components_repr, module_components_failure) result)
+        EnvLazy.t;
+  }
+
+and components_maker = {
+  cm_env: t;
+  cm_freshening_subst: Subst.t option;
+  cm_prefixing_subst: Subst.t;
+  cm_path: Path.t;
+  cm_addr: address_lazy;
+  cm_mty: Types.module_type;
+}
+
+and module_components_repr =
+    Structure_comps of structure_components
+  | Functor_comps of functor_components
+
+and module_components_failure =
+  | No_components_abstract
+  | No_components_alias of Path.t
+
+and structure_components = {
+  mutable comp_values: value_data NameMap.t;
+  mutable comp_constrs: constructor_data list NameMap.t;
+  mutable comp_labels: label_data list NameMap.t;
+  mutable comp_types: type_data NameMap.t;
+  mutable comp_modules: module_data NameMap.t;
+  mutable comp_modtypes: modtype_data NameMap.t;
+  mutable comp_classes: class_data NameMap.t;
+  mutable comp_cltypes: cltype_data NameMap.t;
+}
+
+and functor_components = {
+  fcomp_arg: functor_parameter;
+  (* Formal parameter and argument signature *)
+  fcomp_res: module_type;               (* Result signature *)
+  fcomp_cache: (Path.t, module_components) Hashtbl.t;  (* For memoization *)
+  fcomp_subst_cache: (Path.t, module_type) Hashtbl.t
+}
+
+and address_unforced =
+  | Projection of { parent : address_lazy; pos : int; }
+  | ModAlias of { env : t; path : Path.t; }
+
+and address_lazy = (address_unforced, address) EnvLazy.t
+
+and value_data =
+  { vda_description : value_description;
+    vda_address : address_lazy }
+
+and value_entry =
+  | Val_bound of value_data
+  | Val_unbound of value_unbound_reason
+
+and constructor_data =
+  { cda_description : constructor_description;
+    cda_address : address_lazy option; }
+
+and label_data = label_description
+
+and type_data =
+  { tda_declaration : type_declaration;
+    tda_descriptions : type_descriptions; }
+
+and module_data =
+  { mda_declaration : module_declaration_lazy;
+    mda_components : module_components;
+    mda_address : address_lazy; }
+
+and module_entry =
+  | Mod_local of module_data
+  | Mod_persistent
+  | Mod_unbound of module_unbound_reason
+
+and modtype_data = modtype_declaration
+
+and class_data =
+  { clda_declaration : class_declaration;
+    clda_address : address_lazy }
+
+and cltype_data = class_type_declaration
+
+let empty_structure =
+  Structure_comps {
+    comp_values = NameMap.empty;
+    comp_constrs = NameMap.empty;
+    comp_labels = NameMap.empty;
+    comp_types = NameMap.empty;
+    comp_modules = NameMap.empty; comp_modtypes = NameMap.empty;
+    comp_classes = NameMap.empty;
+    comp_cltypes = NameMap.empty }
+
+type unbound_value_hint =
+  | No_hint
+  | Missing_rec of Location.t
+
+type lookup_error =
+  | Unbound_value of Longident.t * unbound_value_hint
+  | Unbound_type of Longident.t
+  | Unbound_constructor of Longident.t
+  | Unbound_label of Longident.t
+  | Unbound_module of Longident.t
+  | Unbound_class of Longident.t
+  | Unbound_modtype of Longident.t
+  | Unbound_cltype of Longident.t
+  | Unbound_instance_variable of string
+  | Not_an_instance_variable of string
+  | Masked_instance_variable of Longident.t
+  | Masked_self_variable of Longident.t
+  | Masked_ancestor_variable of Longident.t
+  | Structure_used_as_functor of Longident.t
+  | Abstract_used_as_functor of Longident.t
+  | Functor_used_as_structure of Longident.t
+  | Abstract_used_as_structure of Longident.t
+  | Generative_used_as_applicative of Longident.t
+  | Illegal_reference_to_recursive_module
+  | Cannot_scrape_alias of Longident.t * Path.t
+
+type error =
+  | Missing_module of Location.t * Path.t * Path.t
+  | Illegal_value_name of Location.t * string
+  | Lookup_error of Location.t * t * lookup_error
+
+exception Error of error
+
+let error err = raise (Error err)
+
+let lookup_error loc env err =
+  error (Lookup_error(loc, env, err))
+
+let copy_local ~from env =
+  { env with
+    local_constraints = from.local_constraints;
+    flags = from.flags }
+
+let same_constr = ref (fun _ _ _ -> assert false)
+
+let check_well_formed_module = ref (fun _ -> assert false)
+
+(* Helper to decide whether to report an identifier shadowing
+   by some 'open'. For labels and constructors, we do not report
+   if the two elements are from the same re-exported declaration.
+
+   Later, one could also interpret some attributes on value and
+   type declarations to silence the shadowing warnings. *)
+
+let check_shadowing env = function
+  | `Constructor (Some (cda1, cda2))
+    when not (!same_constr env
+                cda1.cda_description.cstr_res
+                cda2.cda_description.cstr_res) ->
+      Some "constructor"
+  | `Label (Some (l1, l2))
+    when not (!same_constr env l1.lbl_res l2.lbl_res) ->
+      Some "label"
+  | `Value (Some _) -> Some "value"
+  | `Type (Some _) -> Some "type"
+  | `Module (Some _) | `Component (Some _) -> Some "module"
+  | `Module_type (Some _) -> Some "module type"
+  | `Class (Some _) -> Some "class"
+  | `Class_type (Some _) -> Some "class type"
+  | `Constructor _ | `Label _
+  | `Value None | `Type None | `Module None | `Module_type None
+  | `Class None | `Class_type None | `Component None ->
+      None
+
+let subst_modtype_maker (subst, scoping, md) =
+  {md with md_type = Subst.modtype scoping subst md.md_type}
+
+let empty = {
+  values = IdTbl.empty; constrs = TycompTbl.empty;
+  labels = TycompTbl.empty; types = IdTbl.empty;
+  modules = IdTbl.empty; modtypes = IdTbl.empty;
+  classes = IdTbl.empty; cltypes = IdTbl.empty;
+  summary = Env_empty; local_constraints = Path.Map.empty;
+  flags = 0;
+  functor_args = Ident.empty;
+ }
+
+let in_signature b env =
+  let flags =
+    if b then env.flags lor in_signature_flag
+    else env.flags land (lnot in_signature_flag)
+  in
+  {env with flags}
+
+let is_in_signature env = env.flags land in_signature_flag <> 0
+
+let has_local_constraints env =
+  not (Path.Map.is_empty env.local_constraints)
+
+let is_ident = function
+    Pident _ -> true
+  | Pdot _ | Papply _ -> false
+
+let is_ext cda =
+  match cda.cda_description with
+  | {cstr_tag = Cstr_extension _} -> true
+  | _ -> false
+
+let is_local_ext cda =
+  match cda.cda_description with
+  | {cstr_tag = Cstr_extension(p, _)} -> is_ident p
+  | _ -> false
+
+let diff env1 env2 =
+  IdTbl.diff_keys env1.values env2.values @
+  TycompTbl.diff_keys is_local_ext env1.constrs env2.constrs @
+  IdTbl.diff_keys env1.modules env2.modules @
+  IdTbl.diff_keys env1.classes env2.classes
+
+(* Functions for use in "wrap" parameters in IdTbl *)
+let wrap_identity x = x
+let wrap_value vda = Val_bound vda
+let wrap_module mda = Mod_local mda
+
+(* Forward declarations *)
+
+let components_of_module_maker' =
+  ref ((fun _ -> assert false) :
+          components_maker ->
+            (module_components_repr, module_components_failure) result)
+
+let components_of_functor_appl' =
+  ref ((fun ~loc:_ _f _env _p1 _p2 -> assert false) :
+          loc:Location.t -> functor_components -> t ->
+            Path.t -> Path.t -> module_components)
+let check_functor_application =
+  (* to be filled by Includemod *)
+  ref ((fun ~errors:_ ~loc:_ _env _mty1 _path1 _mty2 _path2 -> assert false) :
+          errors:bool -> loc:Location.t -> t -> module_type ->
+            Path.t -> module_type -> Path.t -> unit)
+let strengthen =
+  (* to be filled with Mtype.strengthen *)
+  ref ((fun ~aliasable:_ _env _mty _path -> assert false) :
+         aliasable:bool -> t -> module_type -> Path.t -> module_type)
+
+let md md_type =
+  {md_type; md_attributes=[]; md_loc=Location.none
+  ;md_uid = Uid.internal_not_actually_unique}
+
+(* Print addresses *)
+
+let rec print_address ppf = function
+  | Aident id -> Format.fprintf ppf "%s" (Ident.name id)
+  | Adot(a, pos) -> Format.fprintf ppf "%a.[%i]" print_address a pos
+
+(* The name of the compilation unit currently compiled.
+   "" if outside a compilation unit. *)
+module Current_unit_name : sig
+  val get : unit -> modname
+  val set : modname -> unit
+  val is : modname -> bool
+  val is_name_of : Ident.t -> bool
+end = struct
+  let current_unit =
+    ref ""
+  let get () =
+    !current_unit
+  let set name =
+    current_unit := name
+  let is name =
+    !current_unit = name
+  let is_name_of id =
+    is (Ident.name id)
+end
+
+let set_unit_name = Current_unit_name.set
+let get_unit_name = Current_unit_name.get
+
+let find_same_module id tbl =
+  match IdTbl.find_same id tbl with
+  | x -> x
+  | exception Not_found
+    when Ident.persistent id && not (Current_unit_name.is_name_of id) ->
+      Mod_persistent
+
+let find_name_module ~mark name tbl =
+  match IdTbl.find_name wrap_module ~mark name tbl with
+  | x -> x
+  | exception Not_found when not (Current_unit_name.is name) ->
+      let path = Pident(Ident.create_persistent name) in
+      path, Mod_persistent
+
+let add_persistent_structure id env =
+  if not (Ident.persistent id) then invalid_arg "Env.add_persistent_structure";
+  if not (Current_unit_name.is_name_of id) then
+    let summary =
+      match
+        IdTbl.find_name wrap_module ~mark:false (Ident.name id) env.modules
+      with
+      | exception Not_found | _, Mod_persistent -> env.summary
+      | _ -> Env_persistent (env.summary, id)
+    in
+    { env with
+      modules = IdTbl.add id Mod_persistent env.modules;
+      summary
+    }
+  else
+    env
+
+let components_of_module ~alerts ~uid env fs ps path addr mty =
+  {
+    alerts;
+    uid;
+    comps = EnvLazy.create {
+      cm_env = env;
+      cm_freshening_subst = fs;
+      cm_prefixing_subst = ps;
+      cm_path = path;
+      cm_addr = addr;
+      cm_mty = mty
+    }
+  }
+
+let sign_of_cmi ~freshen { Persistent_env.Persistent_signature.cmi; _ } =
+  let name = cmi.cmi_name in
+  let sign = cmi.cmi_sign in
+  let flags = cmi.cmi_flags in
+  let id = Ident.create_persistent name in
+  let path = Pident id in
+  let alerts =
+    List.fold_left (fun acc -> function Alerts s -> s | _ -> acc)
+      Misc.Stdlib.String.Map.empty
+      flags
+  in
+  let md =
+    { md_type =  Mty_signature sign;
+      md_loc = Location.none;
+      md_attributes = [];
+      md_uid = Uid.of_compilation_unit_id id;
+    }
+  in
+  let mda_address = EnvLazy.create_forced (Aident id) in
+  let mda_declaration =
+    EnvLazy.create (Subst.identity, Subst.Make_local, md)
+  in
+  let mda_components =
+    let freshening_subst =
+      if freshen then (Some Subst.identity) else None
+    in
+    components_of_module ~alerts ~uid:md.md_uid
+      empty freshening_subst Subst.identity
+      path mda_address (Mty_signature sign)
+  in
+  {
+    mda_declaration;
+    mda_components;
+    mda_address;
+  }
+
+let read_sign_of_cmi = sign_of_cmi ~freshen:true
+
+let save_sign_of_cmi = sign_of_cmi ~freshen:false
+
+let persistent_env : module_data Persistent_env.t =
+  Persistent_env.empty ()
+
+let without_cmis f x =
+  Persistent_env.without_cmis persistent_env f x
+
+let imports () = Persistent_env.imports persistent_env
+
+let import_crcs ~source crcs =
+  Persistent_env.import_crcs persistent_env ~source crcs
+
+let read_pers_mod modname filename =
+  Persistent_env.read persistent_env read_sign_of_cmi modname filename
+
+let find_pers_mod name =
+  Persistent_env.find persistent_env read_sign_of_cmi name
+
+let check_pers_mod ~loc name =
+  Persistent_env.check persistent_env read_sign_of_cmi ~loc name
+
+let crc_of_unit name =
+  Persistent_env.crc_of_unit persistent_env read_sign_of_cmi name
+
+let is_imported_opaque modname =
+  Persistent_env.is_imported_opaque persistent_env modname
+
+let register_import_as_opaque modname =
+  Persistent_env.register_import_as_opaque persistent_env modname
+
+let reset_declaration_caches () =
+  Types.Uid.Tbl.clear value_declarations;
+  Types.Uid.Tbl.clear type_declarations;
+  Types.Uid.Tbl.clear module_declarations;
+  Types.Uid.Tbl.clear used_constructors;
+  ()
+
+let reset_cache () =
+  Current_unit_name.set "";
+  Persistent_env.clear persistent_env;
+  reset_declaration_caches ();
+  ()
+
+let reset_cache_toplevel () =
+  Persistent_env.clear_missing persistent_env;
+  reset_declaration_caches ();
+  ()
+
+(* get_components *)
+
+let get_components_res c =
+  match Persistent_env.can_load_cmis persistent_env with
+  | Persistent_env.Can_load_cmis ->
+    EnvLazy.force !components_of_module_maker' c.comps
+  | Persistent_env.Cannot_load_cmis log ->
+    EnvLazy.force_logged log !components_of_module_maker' c.comps
+
+let get_components c =
+  match get_components_res c with
+  | Error _ -> empty_structure
+  | Ok c -> c
+
+(* Module type of functor application *)
+
+let modtype_of_functor_appl fcomp p1 p2 =
+  match fcomp.fcomp_res with
+  | Mty_alias _ as mty -> mty
+  | mty ->
+      try
+        Hashtbl.find fcomp.fcomp_subst_cache p2
+      with Not_found ->
+        let scope = Path.scope (Papply(p1, p2)) in
+        let mty =
+          let subst =
+            match fcomp.fcomp_arg with
+            | Unit
+            | Named (None, _) -> Subst.identity
+            | Named (Some param, _) -> Subst.add_module param p2 Subst.identity
+          in
+          Subst.modtype (Rescope scope) subst mty
+        in
+        Hashtbl.add fcomp.fcomp_subst_cache p2 mty;
+        mty
+
+let check_functor_appl ~errors ~loc env p1 f arg p2 md =
+  if not (Hashtbl.mem f.fcomp_cache p2) then
+    !check_functor_application ~errors ~loc env md.md_type p2 arg p1
+
+(* Lookup by identifier *)
+
+let find_ident_module id env =
+  match find_same_module id env.modules with
+  | Mod_local data -> data
+  | Mod_unbound _ -> raise Not_found
+  | Mod_persistent -> find_pers_mod (Ident.name id)
+
+let rec find_module_components path env =
+  match path with
+  | Pident id -> (find_ident_module id env).mda_components
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      (NameMap.find s sc.comp_modules).mda_components
+  | Papply(p1, p2) ->
+      let fc = find_functor_components p1 env in
+      let loc = Location.(in_file !input_name) in
+      !components_of_functor_appl' ~loc fc env p1 p2
+
+and find_structure_components path env =
+  match get_components (find_module_components path env) with
+  | Structure_comps c -> c
+  | Functor_comps _ -> raise Not_found
+
+and find_functor_components path env =
+  match get_components (find_module_components path env) with
+  | Functor_comps f -> f
+  | Structure_comps _ -> raise Not_found
+
+let find_module ~alias path env =
+  match path with
+  | Pident id ->
+      let data = find_ident_module id env in
+      EnvLazy.force subst_modtype_maker data.mda_declaration
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      let data = NameMap.find s sc.comp_modules in
+      EnvLazy.force subst_modtype_maker data.mda_declaration
+  | Papply(p1, p2) ->
+      let fc = find_functor_components p1 env in
+      if alias then md (fc.fcomp_res)
+      else md (modtype_of_functor_appl fc p1 p2)
+
+let find_value_full path env =
+  match path with
+  | Pident id -> begin
+      match IdTbl.find_same id env.values with
+      | Val_bound data -> data
+      | Val_unbound _ -> raise Not_found
+    end
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      NameMap.find s sc.comp_values
+  | Papply _ -> raise Not_found
+
+let find_type_full path env =
+  match path with
+  | Pident id -> IdTbl.find_same id env.types
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      NameMap.find s sc.comp_types
+  | Papply _ -> raise Not_found
+
+let find_modtype path env =
+  match path with
+  | Pident id -> IdTbl.find_same id env.modtypes
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      NameMap.find s sc.comp_modtypes
+  | Papply _ -> raise Not_found
+
+let find_class_full path env =
+  match path with
+  | Pident id -> IdTbl.find_same id env.classes
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      NameMap.find s sc.comp_classes
+  | Papply _ -> raise Not_found
+
+let find_cltype path env =
+  match path with
+  | Pident id -> IdTbl.find_same id env.cltypes
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      NameMap.find s sc.comp_cltypes
+  | Papply _ -> raise Not_found
+
+let find_value path env =
+  (find_value_full path env).vda_description
+
+let find_class path env =
+  (find_class_full path env).clda_declaration
+
+let find_ident_constructor id env =
+  (TycompTbl.find_same id env.constrs).cda_description
+
+let find_ident_label id env =
+  TycompTbl.find_same id env.labels
+
+let type_of_cstr path = function
+  | {cstr_inlined = Some decl; _} ->
+      let labels =
+        List.map snd (Datarepr.labels_of_type path decl)
+      in
+      { tda_declaration = decl; tda_descriptions = ([], labels) }
+  | _ ->
+      assert false
+
+let find_type_full path env =
+  match Path.constructor_typath path with
+  | Regular p -> begin
+      match Path.Map.find p env.local_constraints with
+      | decl ->
+          { tda_declaration = decl; tda_descriptions = [], [] }
+      | exception Not_found -> find_type_full p env
+    end
+  | Cstr (ty_path, s) ->
+      let tda =
+        try find_type_full ty_path env
+        with Not_found -> assert false
+      in
+      let (cstrs, _) = tda.tda_descriptions in
+      let cstr =
+        try List.find (fun cstr -> cstr.cstr_name = s) cstrs
+        with Not_found -> assert false
+      in
+      type_of_cstr path cstr
+  | LocalExt id ->
+      let cstr =
+        try (TycompTbl.find_same id env.constrs).cda_description
+        with Not_found -> assert false
+      in
+      type_of_cstr path cstr
+  | Ext (mod_path, s) ->
+      let comps =
+        try find_structure_components mod_path env
+        with Not_found -> assert false
+      in
+      let cstrs =
+        try NameMap.find s comps.comp_constrs
+        with Not_found -> assert false
+      in
+      let exts = List.filter is_ext cstrs in
+      match exts with
+      | [cda] -> type_of_cstr path cda.cda_description
+      | _ -> assert false
+
+let find_type p env =
+  (find_type_full p env).tda_declaration
+let find_type_descrs p env =
+  (find_type_full p env).tda_descriptions
+
+let rec find_module_address path env =
+  match path with
+  | Pident id -> get_address (find_ident_module id env).mda_address
+  | Pdot(p, s) ->
+      let c = find_structure_components p env in
+      get_address (NameMap.find s c.comp_modules).mda_address
+  | Papply _ -> raise Not_found
+
+and force_address = function
+  | Projection { parent; pos } -> Adot(get_address parent, pos)
+  | ModAlias { env; path } -> find_module_address path env
+
+and get_address a =
+  EnvLazy.force force_address a
+
+let find_value_address path env =
+  get_address (find_value_full path env).vda_address
+
+let find_class_address path env =
+  get_address (find_class_full path env).clda_address
+
+let rec get_constrs_address = function
+  | [] -> raise Not_found
+  | cda :: rest ->
+    match cda.cda_address with
+    | None -> get_constrs_address rest
+    | Some a -> get_address a
+
+let find_constructor_address path env =
+  match path with
+  | Pident id -> begin
+      let cda = TycompTbl.find_same id env.constrs in
+      match cda.cda_address with
+      | None -> raise Not_found
+      | Some addr -> get_address addr
+    end
+  | Pdot(p, s) ->
+      let c = find_structure_components p env in
+      get_constrs_address (NameMap.find s c.comp_constrs)
+  | Papply _ ->
+      raise Not_found
+
+let find_hash_type path env =
+  match path with
+  | Pident id ->
+      let name = "#" ^ Ident.name id in
+      let _, tda =
+        IdTbl.find_name wrap_identity ~mark:false name env.types
+      in
+      tda.tda_declaration
+  | Pdot(p, s) ->
+      let c = find_structure_components p env in
+      let name = "#" ^ s in
+      let tda = NameMap.find name c.comp_types in
+      tda.tda_declaration
+  | Papply _ ->
+      raise Not_found
+
+let required_globals = ref []
+let reset_required_globals () = required_globals := []
+let get_required_globals () = !required_globals
+let add_required_global id =
+  if Ident.global id && not !Clflags.transparent_modules
+  && not (List.exists (Ident.same id) !required_globals)
+  then required_globals := id :: !required_globals
+
+let rec normalize_module_path lax env = function
+  | Pident id as path when lax && Ident.persistent id ->
+      path (* fast path (avoids lookup) *)
+  | Pdot (p, s) as path ->
+      let p' = normalize_module_path lax env p in
+      if p == p' then expand_module_path lax env path
+      else expand_module_path lax env (Pdot(p', s))
+  | Papply (p1, p2) as path ->
+      let p1' = normalize_module_path lax env p1 in
+      let p2' = normalize_module_path true env p2 in
+      if p1 == p1' && p2 == p2' then expand_module_path lax env path
+      else expand_module_path lax env (Papply(p1', p2'))
+  | Pident _ as path ->
+      expand_module_path lax env path
+
+and expand_module_path lax env path =
+  try match find_module ~alias:true path env with
+    {md_type=Mty_alias path1} ->
+      let path' = normalize_module_path lax env path1 in
+      if lax || !Clflags.transparent_modules then path' else
+      let id = Path.head path in
+      if Ident.global id && not (Ident.same id (Path.head path'))
+      then add_required_global id;
+      path'
+  | _ -> path
+  with Not_found when lax
+  || (match path with Pident id -> not (Ident.persistent id) | _ -> true) ->
+      path
+
+let normalize_module_path oloc env path =
+  try normalize_module_path (oloc = None) env path
+  with Not_found ->
+    match oloc with None -> assert false
+    | Some loc ->
+        error (Missing_module(loc, path,
+                              normalize_module_path true env path))
+
+let normalize_path_prefix oloc env path =
+  match path with
+    Pdot(p, s) ->
+      let p2 = normalize_module_path oloc env p in
+      if p == p2 then path else Pdot(p2, s)
+  | Pident _ ->
+      path
+  | Papply _ ->
+      assert false
+
+let normalize_type_path oloc env path =
+  (* Inlined version of Path.is_constructor_typath:
+     constructor type paths (i.e. path pointing to an inline
+     record argument of a constructpr) are built as a regular
+     type path followed by a capitalized constructor name. *)
+  match path with
+  | Pident _ ->
+      path
+  | Pdot(p, s) ->
+      let p2 =
+        if Path.is_uident s && not (Path.is_uident (Path.last p)) then
+          (* Cstr M.t.C *)
+          normalize_path_prefix oloc env p
+        else
+          (* Regular M.t, Ext M.C *)
+          normalize_module_path oloc env p
+      in
+      if p == p2 then path else Pdot (p2, s)
+  | Papply _ ->
+      assert false
+
+let rec normalize_modtype_path env path =
+  let path = normalize_path_prefix None env path in
+  expand_modtype_path env path
+
+and expand_modtype_path env path =
+  match (find_modtype path env).mtd_type with
+  | Some (Mty_ident path) -> normalize_modtype_path env path
+  | _ | exception Not_found -> path
+
+let find_module path env =
+  find_module ~alias:false path env
+
+(* Find the manifest type associated to a type when appropriate:
+   - the type should be public or should have a private row,
+   - the type should have an associated manifest type. *)
+let find_type_expansion path env =
+  let decl = find_type path env in
+  match decl.type_manifest with
+  | Some body when decl.type_private = Public
+              || decl.type_kind <> Type_abstract
+              || Btype.has_constr_row body ->
+      (decl.type_params, body, decl.type_expansion_scope)
+  (* The manifest type of Private abstract data types without
+     private row are still considered unknown to the type system.
+     Hence, this case is caught by the following clause that also handles
+     purely abstract data types without manifest type definition. *)
+  | _ -> raise Not_found
+
+(* Find the manifest type information associated to a type, i.e.
+   the necessary information for the compiler's type-based optimisations.
+   In particular, the manifest type associated to a private abstract type
+   is revealed for the sake of compiler's type-based optimisations. *)
+let find_type_expansion_opt path env =
+  let decl = find_type path env in
+  match decl.type_manifest with
+  (* The manifest type of Private abstract data types can still get
+     an approximation using their manifest type. *)
+  | Some body ->
+      (decl.type_params, body, decl.type_expansion_scope)
+  | _ -> raise Not_found
+
+let find_modtype_expansion path env =
+  match (find_modtype path env).mtd_type with
+  | None -> raise Not_found
+  | Some mty -> mty
+
+let rec is_functor_arg path env =
+  match path with
+    Pident id ->
+      begin try Ident.find_same id env.functor_args; true
+      with Not_found -> false
+      end
+  | Pdot (p, _s) -> is_functor_arg p env
+  | Papply _ -> true
+
+(* Copying types associated with values *)
+
+let make_copy_of_types env0 =
+  let memo = Hashtbl.create 16 in
+  let copy t =
+    try
+      Hashtbl.find memo t.id
+    with Not_found ->
+      let t2 = Subst.type_expr Subst.identity t in
+      Hashtbl.add memo t.id t2;
+      t2
+  in
+  let f = function
+    | Val_unbound _ as entry -> entry
+    | Val_bound vda ->
+        let desc = vda.vda_description in
+        let desc = { desc with val_type = copy desc.val_type } in
+        Val_bound { vda with vda_description = desc }
+  in
+  let values =
+    IdTbl.map f env0.values
+  in
+  (fun env ->
+     if env.values != env0.values then fatal_error "Env.make_copy_of_types";
+     {env with values; summary = Env_copy_types env.summary}
+  )
+
+(* Helper to handle optional substitutions. *)
+
+let may_subst subst_f sub x =
+  match sub with
+  | None -> x
+  | Some sub -> subst_f sub x
+
+(* Iter on an environment (ignoring the body of functors and
+   not yet evaluated structures) *)
+
+type iter_cont = unit -> unit
+let iter_env_cont = ref []
+
+let rec scrape_alias_for_visit env (sub : Subst.t option) mty =
+  match mty with
+  | Mty_alias path ->
+      begin match may_subst Subst.module_path sub path with
+      | Pident id
+        when Ident.persistent id
+          && not (Persistent_env.looked_up persistent_env (Ident.name id)) ->
+          false
+      | path -> (* PR#6600: find_module may raise Not_found *)
+          try scrape_alias_for_visit env sub (find_module path env).md_type
+          with Not_found -> false
+      end
+  | _ -> true
+
+let iter_env wrap proj1 proj2 f env () =
+  IdTbl.iter wrap (fun id x -> f (Pident id) x) (proj1 env);
+  let rec iter_components path path' mcomps =
+    let cont () =
+      let visit =
+        match EnvLazy.get_arg mcomps.comps with
+        | None -> true
+        | Some { cm_mty; cm_freshening_subst; _ } ->
+            scrape_alias_for_visit env cm_freshening_subst cm_mty
+      in
+      if not visit then () else
+      match get_components mcomps with
+        Structure_comps comps ->
+          NameMap.iter
+            (fun s d -> f (Pdot (path, s)) (Pdot (path', s), d))
+            (proj2 comps);
+          NameMap.iter
+            (fun s mda ->
+              iter_components
+                (Pdot (path, s)) (Pdot (path', s)) mda.mda_components)
+            comps.comp_modules
+      | Functor_comps _ -> ()
+    in iter_env_cont := (path, cont) :: !iter_env_cont
+  in
+  IdTbl.iter wrap_module
+    (fun id (path, entry) ->
+       match entry with
+       | Mod_unbound _ -> ()
+       | Mod_local data ->
+           iter_components (Pident id) path data.mda_components
+       | Mod_persistent ->
+           let modname = Ident.name id in
+           match Persistent_env.find_in_cache persistent_env modname with
+           | None -> ()
+           | Some data ->
+               iter_components (Pident id) path data.mda_components)
+    env.modules
+
+let run_iter_cont l =
+  iter_env_cont := [];
+  List.iter (fun c -> c ()) l;
+  let cont = List.rev !iter_env_cont in
+  iter_env_cont := [];
+  cont
+
+let iter_types f =
+  iter_env wrap_identity (fun env -> env.types) (fun sc -> sc.comp_types)
+    (fun p1 (p2, tda) -> f p1 (p2, tda.tda_declaration))
+
+let same_types env1 env2 =
+  env1.types == env2.types && env1.modules == env2.modules
+
+let used_persistent () =
+  Persistent_env.fold persistent_env
+    (fun s _m r -> Concr.add s r)
+    Concr.empty
+
+let find_all_comps wrap proj s (p, mda) =
+  match get_components mda.mda_components with
+    Functor_comps _ -> []
+  | Structure_comps comps ->
+      try
+        let c = NameMap.find s (proj comps) in
+        [Pdot(p,s), wrap c]
+      with Not_found -> []
+
+let rec find_shadowed_comps path env =
+  match path with
+  | Pident id ->
+      List.filter_map
+        (fun (p, data) ->
+           match data with
+           | Mod_local x -> Some (p, x)
+           | Mod_unbound _ | Mod_persistent -> None)
+        (IdTbl.find_all wrap_module (Ident.name id) env.modules)
+  | Pdot (p, s) ->
+      let l = find_shadowed_comps p env in
+      let l' =
+        List.map
+          (find_all_comps wrap_identity
+             (fun comps -> comps.comp_modules) s) l
+      in
+      List.flatten l'
+  | Papply _ -> []
+
+let find_shadowed wrap proj1 proj2 path env =
+  match path with
+    Pident id ->
+      IdTbl.find_all wrap (Ident.name id) (proj1 env)
+  | Pdot (p, s) ->
+      let l = find_shadowed_comps p env in
+      let l' = List.map (find_all_comps wrap proj2 s) l in
+      List.flatten l'
+  | Papply _ -> []
+
+let find_shadowed_types path env =
+  List.map fst
+    (find_shadowed wrap_identity
+       (fun env -> env.types) (fun comps -> comps.comp_types) path env)
+
+(* Expand manifest module type names at the top of the given module type *)
+
+let rec scrape_alias env sub ?path mty =
+  match mty, path with
+    Mty_ident _, _ ->
+      let p =
+        match may_subst (Subst.modtype Keep) sub mty with
+        | Mty_ident p -> p
+        | _ -> assert false (* only [Mty_ident]s in [sub] *)
+      in
+      begin try
+        scrape_alias env sub (find_modtype_expansion p env) ?path
+      with Not_found ->
+        mty
+      end
+  | Mty_alias path, _ ->
+      let path = may_subst Subst.module_path sub path in
+      begin try
+        scrape_alias env sub (find_module path env).md_type ~path
+      with Not_found ->
+        (*Location.prerr_warning Location.none
+          (Warnings.No_cmi_file (Path.name path));*)
+        mty
+      end
+  | mty, Some path ->
+      !strengthen ~aliasable:true env mty path
+  | _ -> mty
+
+(* Given a signature and a root path, prefix all idents in the signature
+   by the root path and build the corresponding substitution. *)
+
+let prefix_idents root freshening_sub prefixing_sub sg =
+  let refresh id add_fn = function
+    | None -> id, None
+    | Some sub ->
+      let id' = Ident.rename id in
+      id', Some (add_fn id (Pident id') sub)
+  in
+  let rec prefix_idents root items_and_paths freshening_sub prefixing_sub =
+    function
+    | [] -> (List.rev items_and_paths, freshening_sub, prefixing_sub)
+    | Sig_value(id, _, _) as item :: rem ->
+      let p = Pdot(root, Ident.name id) in
+      prefix_idents root
+        ((item, p) :: items_and_paths) freshening_sub prefixing_sub rem
+    | Sig_type(id, td, rs, vis) :: rem ->
+      let p = Pdot(root, Ident.name id) in
+      let id', freshening_sub = refresh id Subst.add_type freshening_sub in
+      prefix_idents root
+        ((Sig_type(id', td, rs, vis), p) :: items_and_paths)
+        freshening_sub
+        (Subst.add_type id' p prefixing_sub)
+        rem
+    | Sig_typext(id, ec, es, vis) :: rem ->
+      let p = Pdot(root, Ident.name id) in
+      let id', freshening_sub = refresh id Subst.add_type freshening_sub in
+      (* we extend the substitution in case of an inlined record *)
+      prefix_idents root
+        ((Sig_typext(id', ec, es, vis), p) :: items_and_paths)
+        freshening_sub
+        (Subst.add_type id' p prefixing_sub)
+        rem
+    | Sig_module(id, pres, md, rs, vis) :: rem ->
+      let p = Pdot(root, Ident.name id) in
+      let id', freshening_sub = refresh id Subst.add_module freshening_sub in
+      prefix_idents root
+        ((Sig_module(id', pres, md, rs, vis), p) :: items_and_paths)
+        freshening_sub
+        (Subst.add_module id' p prefixing_sub)
+        rem
+    | Sig_modtype(id, mtd, vis) :: rem ->
+      let p = Pdot(root, Ident.name id) in
+      let id', freshening_sub =
+        refresh id (fun i p s -> Subst.add_modtype i (Mty_ident p) s)
+          freshening_sub
+      in
+      prefix_idents root
+        ((Sig_modtype(id', mtd, vis), p) :: items_and_paths)
+        freshening_sub
+        (Subst.add_modtype id' (Mty_ident p) prefixing_sub)
+        rem
+    | Sig_class(id, cd, rs, vis) :: rem ->
+      (* pretend this is a type, cf. PR#6650 *)
+      let p = Pdot(root, Ident.name id) in
+      let id', freshening_sub = refresh id Subst.add_type freshening_sub in
+      prefix_idents root
+        ((Sig_class(id', cd, rs, vis), p) :: items_and_paths)
+        freshening_sub
+        (Subst.add_type id' p prefixing_sub)
+        rem
+    | Sig_class_type(id, ctd, rs, vis) :: rem ->
+      let p = Pdot(root, Ident.name id) in
+      let id', freshening_sub = refresh id Subst.add_type freshening_sub in
+      prefix_idents root
+        ((Sig_class_type(id', ctd, rs, vis), p) :: items_and_paths)
+        freshening_sub
+        (Subst.add_type id' p prefixing_sub)
+        rem
+  in
+  prefix_idents root [] freshening_sub prefixing_sub sg
+
+(* Compute structure descriptions *)
+
+let add_to_tbl id decl tbl =
+  let decls = try NameMap.find id tbl with Not_found -> [] in
+  NameMap.add id (decl :: decls) tbl
+
+let value_declaration_address (_ : t) id decl =
+  match decl.val_kind with
+  | Val_prim _ -> EnvLazy.create_failed Not_found
+  | _ -> EnvLazy.create_forced (Aident id)
+
+let extension_declaration_address (_ : t) id (_ : extension_constructor) =
+  EnvLazy.create_forced (Aident id)
+
+let class_declaration_address (_ : t) id (_ : class_declaration) =
+  EnvLazy.create_forced (Aident id)
+
+let module_declaration_address env id presence md =
+  match presence with
+  | Mp_absent -> begin
+      match md.md_type with
+      | Mty_alias path -> EnvLazy.create (ModAlias {env; path})
+      | _ -> assert false
+    end
+  | Mp_present ->
+      EnvLazy.create_forced (Aident id)
+
+let rec components_of_module_maker
+          {cm_env; cm_freshening_subst; cm_prefixing_subst;
+           cm_path; cm_addr; cm_mty} : _ result =
+  match scrape_alias cm_env cm_freshening_subst cm_mty with
+    Mty_signature sg ->
+      let c =
+        { comp_values = NameMap.empty;
+          comp_constrs = NameMap.empty;
+          comp_labels = NameMap.empty; comp_types = NameMap.empty;
+          comp_modules = NameMap.empty; comp_modtypes = NameMap.empty;
+          comp_classes = NameMap.empty; comp_cltypes = NameMap.empty }
+      in
+      let items_and_paths, freshening_sub, prefixing_sub =
+        prefix_idents cm_path cm_freshening_subst cm_prefixing_subst sg
+      in
+      let env = ref cm_env in
+      let pos = ref 0 in
+      let next_address () =
+        let addr : address_unforced =
+          Projection { parent = cm_addr; pos = !pos }
+        in
+        incr pos;
+        EnvLazy.create addr
+      in
+      let sub = may_subst Subst.compose freshening_sub prefixing_sub in
+      List.iter (fun (item, path) ->
+        match item with
+          Sig_value(id, decl, _) ->
+            let decl' = Subst.value_description sub decl in
+            let addr =
+              match decl.val_kind with
+              | Val_prim _ -> EnvLazy.create_failed Not_found
+              | _ -> next_address ()
+            in
+            let vda = { vda_description = decl'; vda_address = addr } in
+            c.comp_values <- NameMap.add (Ident.name id) vda c.comp_values;
+        | Sig_type(id, decl, _, _) ->
+            let fresh_decl =
+              may_subst Subst.type_declaration freshening_sub decl
+            in
+            let final_decl = Subst.type_declaration prefixing_sub fresh_decl in
+            Datarepr.set_row_name final_decl
+              (Subst.type_path prefixing_sub (Path.Pident id));
+            let constructors =
+              List.map snd
+                (Datarepr.constructors_of_type ~current_unit:(get_unit_name ())
+                   path final_decl)
+            in
+            let labels =
+              List.map snd (Datarepr.labels_of_type path final_decl) in
+            let tda =
+              { tda_declaration = final_decl;
+                tda_descriptions = (constructors, labels); }
+            in
+            c.comp_types <- NameMap.add (Ident.name id) tda c.comp_types;
+            List.iter
+              (fun descr ->
+                 let cda = { cda_description = descr; cda_address = None } in
+                 c.comp_constrs <-
+                   add_to_tbl descr.cstr_name cda c.comp_constrs)
+              constructors;
+            List.iter
+              (fun descr ->
+                c.comp_labels <-
+                  add_to_tbl descr.lbl_name descr c.comp_labels)
+              labels;
+            env := store_type_infos id fresh_decl !env
+        | Sig_typext(id, ext, _, _) ->
+            let ext' = Subst.extension_constructor sub ext in
+            let descr =
+              Datarepr.extension_descr ~current_unit:(get_unit_name ()) path
+                ext'
+            in
+            let addr = next_address () in
+            let cda = { cda_description = descr; cda_address = Some addr } in
+            c.comp_constrs <- add_to_tbl (Ident.name id) cda c.comp_constrs
+        | Sig_module(id, pres, md, _, _) ->
+            let md' =
+              (* The prefixed items get the same scope as [cm_path], which is
+                 the prefix. *)
+              EnvLazy.create (sub, Subst.Rescope (Path.scope cm_path), md)
+            in
+            let addr =
+              match pres with
+              | Mp_absent -> begin
+                  match md.md_type with
+                  | Mty_alias p ->
+                      let path = may_subst Subst.module_path freshening_sub p in
+                      EnvLazy.create (ModAlias {env = !env; path})
+                  | _ -> assert false
+                end
+              | Mp_present -> next_address ()
+            in
+            let alerts =
+              Builtin_attributes.alerts_of_attrs md.md_attributes
+            in
+            let comps =
+              components_of_module ~alerts ~uid:md.md_uid !env freshening_sub
+                prefixing_sub path addr md.md_type
+            in
+            let mda =
+              { mda_declaration = md';
+                mda_components = comps;
+                mda_address = addr }
+            in
+            c.comp_modules <-
+              NameMap.add (Ident.name id) mda c.comp_modules;
+            env :=
+              store_module ~freshening_sub ~check:None id addr pres md !env
+        | Sig_modtype(id, decl, _) ->
+            let fresh_decl =
+              (* the fresh_decl is only going in the local temporary env, and
+                 shouldn't be used for anything. So we make the items local. *)
+              may_subst (Subst.modtype_declaration Make_local) freshening_sub
+                decl
+            in
+            let final_decl =
+              (* The prefixed items get the same scope as [cm_path], which is
+                 the prefix. *)
+              Subst.modtype_declaration (Rescope (Path.scope cm_path))
+                prefixing_sub fresh_decl
+            in
+            c.comp_modtypes <-
+              NameMap.add (Ident.name id) final_decl c.comp_modtypes;
+            env := store_modtype id fresh_decl !env
+        | Sig_class(id, decl, _, _) ->
+            let decl' = Subst.class_declaration sub decl in
+            let addr = next_address () in
+            let clda = { clda_declaration = decl'; clda_address = addr } in
+            c.comp_classes <- NameMap.add (Ident.name id) clda c.comp_classes
+        | Sig_class_type(id, decl, _, _) ->
+            let decl' = Subst.cltype_declaration sub decl in
+            c.comp_cltypes <-
+              NameMap.add (Ident.name id) decl' c.comp_cltypes)
+        items_and_paths;
+        Ok (Structure_comps c)
+  | Mty_functor(arg, ty_res) ->
+      let sub =
+        may_subst Subst.compose cm_freshening_subst cm_prefixing_subst
+      in
+      let scoping = Subst.Rescope (Path.scope cm_path) in
+        Ok (Functor_comps {
+          (* fcomp_arg and fcomp_res must be prefixed eagerly, because
+             they are interpreted in the outer environment *)
+          fcomp_arg =
+            (match arg with
+            | Unit -> Unit
+            | Named (param, ty_arg) ->
+              Named (param, Subst.modtype scoping sub ty_arg));
+          fcomp_res = Subst.modtype scoping sub ty_res;
+          fcomp_cache = Hashtbl.create 17;
+          fcomp_subst_cache = Hashtbl.create 17 })
+  | Mty_ident _ -> Error No_components_abstract
+  | Mty_alias p -> Error (No_components_alias p)
+
+(* Insertion of bindings by identifier + path *)
+
+and check_usage loc id uid warn tbl =
+  if not loc.Location.loc_ghost &&
+     Uid.for_actual_declaration uid &&
+     Warnings.is_active (warn "")
+  then begin
+    let name = Ident.name id in
+    if Types.Uid.Tbl.mem tbl uid then ()
+    else let used = ref false in
+    Types.Uid.Tbl.add tbl uid (fun () -> used := true);
+    if not (name = "" || name.[0] = '_' || name.[0] = '#')
+    then
+      !add_delayed_check_forward
+        (fun () -> if not !used then Location.prerr_warning loc (warn name))
+  end;
+
+and check_value_name name loc =
+  (* Note: we could also check here general validity of the
+     identifier, to protect against bad identifiers forged by -pp or
+     -ppx preprocessors. *)
+  if String.length name > 0 && (name.[0] = '#') then
+    for i = 1 to String.length name - 1 do
+      if name.[i] = '#' then
+        error (Illegal_value_name(loc, name))
+    done
+
+and store_value ?check id addr decl env =
+  check_value_name (Ident.name id) decl.val_loc;
+  Option.iter
+    (fun f -> check_usage decl.val_loc id decl.val_uid f value_declarations)
+    check;
+  let vda = { vda_description = decl; vda_address = addr } in
+  { env with
+    values = IdTbl.add id (Val_bound vda) env.values;
+    summary = Env_value(env.summary, id, decl) }
+
+and store_type ~check id info env =
+  let loc = info.type_loc in
+  if check then
+    check_usage loc id info.type_uid
+      (fun s -> Warnings.Unused_type_declaration s)
+      type_declarations;
+  let path = Pident id in
+  let constructors =
+    Datarepr.constructors_of_type path info
+      ~current_unit:(get_unit_name ())
+  in
+  let labels = Datarepr.labels_of_type path info in
+  let descrs = (List.map snd constructors, List.map snd labels) in
+  let tda = { tda_declaration = info; tda_descriptions = descrs } in
+  if check && not loc.Location.loc_ghost &&
+    Warnings.is_active (Warnings.Unused_constructor ("", false, false))
+  then begin
+    let ty_name = Ident.name id in
+    let priv = info.type_private in
+    List.iter
+      begin fun (_, cstr) ->
+        let name = cstr.cstr_name in
+        let loc = cstr.cstr_loc in
+        let k = cstr.cstr_uid in
+        if not (Types.Uid.Tbl.mem used_constructors k) then
+          let used = constructor_usages () in
+          Types.Uid.Tbl.add used_constructors k
+            (add_constructor_usage ~rebind:false priv used);
+          if not (ty_name = "" || ty_name.[0] = '_')
+          then !add_delayed_check_forward
+              (fun () ->
+                if not (is_in_signature env) && not used.cu_positive then
+                  Location.prerr_warning loc
+                    (Warnings.Unused_constructor
+                       (name, used.cu_pattern, used.cu_privatize)))
+      end
+      constructors
+  end;
+  { env with
+    constrs =
+      List.fold_right
+        (fun (id, descr) constrs ->
+           let cda = { cda_description = descr; cda_address = None } in
+           TycompTbl.add id cda constrs)
+        constructors env.constrs;
+    labels =
+      List.fold_right
+        (fun (id, descr) labels -> TycompTbl.add id descr labels)
+        labels env.labels;
+    types = IdTbl.add id tda env.types;
+    summary = Env_type(env.summary, id, info) }
+
+and store_type_infos id info env =
+  (* Simplified version of store_type that doesn't compute and store
+     constructor and label infos, but simply record the arity and
+     manifest-ness of the type.  Used in components_of_module to
+     keep track of type abbreviations (e.g. type t = float) in the
+     computation of label representations. *)
+  let tda = { tda_declaration = info; tda_descriptions = [], [] } in
+  { env with
+    types = IdTbl.add id tda env.types;
+    summary = Env_type(env.summary, id, info) }
+
+and store_extension ~check ~rebind id addr ext env =
+  let loc = ext.ext_loc in
+  let cstr =
+    Datarepr.extension_descr ~current_unit:(get_unit_name ()) (Pident id) ext
+  in
+  let cda = { cda_description = cstr; cda_address = Some addr } in
+  if check && not loc.Location.loc_ghost &&
+    Warnings.is_active (Warnings.Unused_extension ("", false, false, false))
+  then begin
+    let priv = ext.ext_private in
+    let is_exception = Path.same ext.ext_type_path Predef.path_exn in
+    let name = cstr.cstr_name in
+    let k = cstr.cstr_uid in
+    if not (Types.Uid.Tbl.mem used_constructors k) then begin
+      let used = constructor_usages () in
+      Types.Uid.Tbl.add used_constructors k
+        (add_constructor_usage ~rebind priv used);
+      !add_delayed_check_forward
+        (fun () ->
+          if not (is_in_signature env) && not used.cu_positive then
+            Location.prerr_warning loc
+              (Warnings.Unused_extension
+                 (name, is_exception, used.cu_pattern, used.cu_privatize)
+              )
+        )
+    end;
+  end;
+  { env with
+    constrs = TycompTbl.add id cda env.constrs;
+    summary = Env_extension(env.summary, id, ext) }
+
+and store_module ~check ~freshening_sub id addr presence md env =
+  let loc = md.md_loc in
+  Option.iter
+    (fun f -> check_usage loc id md.md_uid f module_declarations) check;
+  let alerts = Builtin_attributes.alerts_of_attrs md.md_attributes in
+  let module_decl_lazy =
+    match freshening_sub with
+    | None -> EnvLazy.create_forced md
+    | Some s -> EnvLazy.create (s, Subst.Rescope (Ident.scope id), md)
+  in
+  let comps =
+    components_of_module ~alerts ~uid:md.md_uid
+      env freshening_sub Subst.identity (Pident id) addr md.md_type
+  in
+  let mda =
+    { mda_declaration = module_decl_lazy;
+      mda_components = comps;
+      mda_address = addr }
+  in
+  { env with
+    modules = IdTbl.add id (Mod_local mda) env.modules;
+    summary = Env_module(env.summary, id, presence, md) }
+
+and store_modtype id info env =
+  { env with
+    modtypes = IdTbl.add id info env.modtypes;
+    summary = Env_modtype(env.summary, id, info) }
+
+and store_class id addr desc env =
+  let clda = { clda_declaration = desc; clda_address = addr } in
+  { env with
+    classes = IdTbl.add id clda env.classes;
+    summary = Env_class(env.summary, id, desc) }
+
+and store_cltype id desc env =
+  { env with
+    cltypes = IdTbl.add id desc env.cltypes;
+    summary = Env_cltype(env.summary, id, desc) }
+
+let scrape_alias env mty = scrape_alias env None mty
+
+(* Compute the components of a functor application in a path. *)
+
+let components_of_functor_appl ~loc f env p1 p2 =
+  try
+    Hashtbl.find f.fcomp_cache p2
+  with Not_found ->
+    let p = Papply(p1, p2) in
+    let sub =
+      match f.fcomp_arg with
+      | Unit
+      | Named (None, _) -> Subst.identity
+      | Named (Some param, _) -> Subst.add_module param p2 Subst.identity
+    in
+    (* we have to apply eagerly instead of passing sub to [components_of_module]
+       because of the call to [check_well_formed_module]. *)
+    let mty = Subst.modtype (Rescope (Path.scope p)) sub f.fcomp_res in
+    let addr = EnvLazy.create_failed Not_found in
+    !check_well_formed_module env loc
+      ("the signature of " ^ Path.name p) mty;
+    let comps =
+      components_of_module ~alerts:Misc.Stdlib.String.Map.empty
+        ~uid:Uid.internal_not_actually_unique
+        (*???*)
+        env None Subst.identity p addr mty
+    in
+    Hashtbl.add f.fcomp_cache p2 comps;
+    comps
+
+(* Define forward functions *)
+
+let _ =
+  components_of_functor_appl' := components_of_functor_appl;
+  components_of_module_maker' := components_of_module_maker
+
+(* Insertion of bindings by identifier *)
+
+let add_functor_arg id env =
+  {env with
+   functor_args = Ident.add id () env.functor_args;
+   summary = Env_functor_arg (env.summary, id)}
+
+let add_value ?check id desc env =
+  let addr = value_declaration_address env id desc in
+  store_value ?check id addr desc env
+
+let add_type ~check id info env =
+  store_type ~check id info env
+
+and add_extension ~check ~rebind id ext env =
+  let addr = extension_declaration_address env id ext in
+  store_extension ~check ~rebind id addr ext env
+
+and add_module_declaration ?(arg=false) ~check id presence md env =
+  let check =
+    if not check then
+      None
+    else if arg && is_in_signature env then
+      Some (fun s -> Warnings.Unused_functor_parameter s)
+    else
+      Some (fun s -> Warnings.Unused_module s)
+  in
+  let addr = module_declaration_address env id presence md in
+  let env = store_module ~freshening_sub:None ~check id addr presence md env in
+  if arg then add_functor_arg id env else env
+
+and add_modtype id info env =
+  store_modtype id info env
+
+and add_class id ty env =
+  let addr = class_declaration_address env id ty in
+  store_class id addr ty env
+
+and add_cltype id ty env =
+  store_cltype id ty env
+
+let add_module ?arg id presence mty env =
+  add_module_declaration ~check:false ?arg id presence (md mty) env
+
+let add_local_type path info env =
+  { env with
+    local_constraints = Path.Map.add path info env.local_constraints }
+
+
+(* Insertion of bindings by name *)
+
+let enter_value ?check name desc env =
+  let id = Ident.create_local name in
+  let addr = value_declaration_address env id desc in
+  let env = store_value ?check id addr desc env in
+  (id, env)
+
+let enter_type ~scope name info env =
+  let id = Ident.create_scoped ~scope name in
+  let env = store_type ~check:true id info env in
+  (id, env)
+
+let enter_extension ~scope ~rebind name ext env =
+  let id = Ident.create_scoped ~scope name in
+  let addr = extension_declaration_address env id ext in
+  let env = store_extension ~check:true ~rebind id addr ext env in
+  (id, env)
+
+let enter_module_declaration ~scope ?arg s presence md env =
+  let id = Ident.create_scoped ~scope s in
+  (id, add_module_declaration ?arg ~check:true id presence md env)
+
+let enter_modtype ~scope name mtd env =
+  let id = Ident.create_scoped ~scope name in
+  let env = store_modtype id mtd env in
+  (id, env)
+
+let enter_class ~scope name desc env =
+  let id = Ident.create_scoped ~scope name in
+  let addr = class_declaration_address env id desc in
+  let env = store_class id addr desc env in
+  (id, env)
+
+let enter_cltype ~scope name desc env =
+  let id = Ident.create_scoped ~scope name in
+  let env = store_cltype id desc env in
+  (id, env)
+
+let enter_module ~scope ?arg s presence mty env =
+  enter_module_declaration ~scope ?arg s presence (md mty) env
+
+(* Insertion of all components of a signature *)
+
+let add_item comp env =
+  match comp with
+    Sig_value(id, decl, _)    -> add_value id decl env
+  | Sig_type(id, decl, _, _)  -> add_type ~check:false id decl env
+  | Sig_typext(id, ext, _, _) ->
+      add_extension ~check:false ~rebind:false id ext env
+  | Sig_module(id, presence, md, _, _) ->
+      add_module_declaration ~check:false id presence md env
+  | Sig_modtype(id, decl, _)  -> add_modtype id decl env
+  | Sig_class(id, decl, _, _) -> add_class id decl env
+  | Sig_class_type(id, decl, _, _) -> add_cltype id decl env
+
+let rec add_signature sg env =
+  match sg with
+    [] -> env
+  | comp :: rem -> add_signature rem (add_item comp env)
+
+let enter_signature ~scope sg env =
+  let sg = Subst.signature (Rescope scope) Subst.identity sg in
+  sg, add_signature sg env
+
+(* Add "unbound" bindings *)
+
+let enter_unbound_value name reason env =
+  let id = Ident.create_local name in
+  { env with
+    values = IdTbl.add id (Val_unbound reason) env.values;
+    summary = Env_value_unbound(env.summary, name, reason) }
+
+let enter_unbound_module name reason env =
+  let id = Ident.create_local name in
+  { env with
+    modules = IdTbl.add id (Mod_unbound reason) env.modules;
+    summary = Env_module_unbound(env.summary, name, reason) }
+
+(* Open a signature path *)
+
+let add_components slot root env0 comps =
+  let add_l w comps env0 =
+    TycompTbl.add_open slot w comps env0
+  in
+  let add w comps env0 = IdTbl.add_open slot w root comps env0 in
+  let constrs =
+    add_l (fun x -> `Constructor x) comps.comp_constrs env0.constrs
+  in
+  let labels =
+    add_l (fun x -> `Label x) comps.comp_labels env0.labels
+  in
+  let values =
+    add (fun x -> `Value x) comps.comp_values env0.values
+  in
+  let types =
+    add (fun x -> `Type x) comps.comp_types env0.types
+  in
+  let modtypes =
+    add (fun x -> `Module_type x) comps.comp_modtypes env0.modtypes
+  in
+  let classes =
+    add (fun x -> `Class x) comps.comp_classes env0.classes
+  in
+  let cltypes =
+    add (fun x -> `Class_type x) comps.comp_cltypes env0.cltypes
+  in
+  let modules =
+    add (fun x -> `Module x) comps.comp_modules env0.modules
+  in
+  { env0 with
+    summary = Env_open(env0.summary, root);
+    constrs;
+    labels;
+    values;
+    types;
+    modtypes;
+    classes;
+    cltypes;
+    modules;
+  }
+
+let open_signature slot root env0 : (_,_) result =
+  match get_components_res (find_module_components root env0) with
+  | Error _ -> Error `Not_found
+  | exception Not_found -> Error `Not_found
+  | Ok (Functor_comps _) -> Error `Functor
+  | Ok (Structure_comps comps) ->
+    Ok (add_components slot root env0 comps)
+
+
+(* Open a signature from a file *)
+
+let open_pers_signature name env =
+  match open_signature None (Pident(Ident.create_persistent name)) env with
+  | (Ok _ | Error `Not_found as res) -> res
+  | Error `Functor -> assert false
+        (* a compilation unit cannot refer to a functor *)
+
+let open_signature
+    ?(used_slot = ref false)
+    ?(loc = Location.none) ?(toplevel = false)
+    ovf root env =
+  let unused =
+    match ovf with
+    | Asttypes.Fresh -> Warnings.Unused_open (Path.name root)
+    | Asttypes.Override -> Warnings.Unused_open_bang (Path.name root)
+  in
+  let warn_unused =
+    Warnings.is_active unused
+  and warn_shadow_id =
+    Warnings.is_active (Warnings.Open_shadow_identifier ("", ""))
+  and warn_shadow_lc =
+    Warnings.is_active (Warnings.Open_shadow_label_constructor ("",""))
+  in
+  if not toplevel && not loc.Location.loc_ghost
+     && (warn_unused || warn_shadow_id || warn_shadow_lc)
+  then begin
+    let used = used_slot in
+    if warn_unused then
+      !add_delayed_check_forward
+        (fun () ->
+           if not !used then begin
+             used := true;
+             Location.prerr_warning loc unused
+           end
+        );
+    let shadowed = ref [] in
+    let slot s b =
+      begin match check_shadowing env b with
+      | Some kind when
+          ovf = Asttypes.Fresh && not (List.mem (kind, s) !shadowed) ->
+          shadowed := (kind, s) :: !shadowed;
+          let w =
+            match kind with
+            | "label" | "constructor" ->
+                Warnings.Open_shadow_label_constructor (kind, s)
+            | _ -> Warnings.Open_shadow_identifier (kind, s)
+          in
+          Location.prerr_warning loc w
+      | _ -> ()
+      end;
+      used := true
+    in
+    open_signature (Some slot) root env
+  end
+  else open_signature None root env
+
+(* Read a signature from a file *)
+let read_signature modname filename =
+  let mda = read_pers_mod modname filename in
+  let md = EnvLazy.force subst_modtype_maker mda.mda_declaration in
+  match md.md_type with
+  | Mty_signature sg -> sg
+  | Mty_ident _ | Mty_functor _ | Mty_alias _ -> assert false
+
+let is_identchar_latin1 = function
+  | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214' | '\216'..'\246'
+  | '\248'..'\255' | '\'' | '0'..'9' -> true
+  | _ -> false
+
+let unit_name_of_filename fn =
+  match Filename.extension fn with
+  | ".cmi" -> begin
+      let unit =
+        String.capitalize_ascii (Filename.remove_extension fn)
+      in
+      if String.for_all is_identchar_latin1 unit then
+        Some unit
+      else
+        None
+    end
+  | _ -> None
+
+let persistent_structures_of_dir dir =
+  Load_path.Dir.files dir
+  |> List.to_seq
+  |> Seq.filter_map unit_name_of_filename
+  |> String.Set.of_seq
+
+(* Save a signature to a file *)
+let save_signature_with_transform cmi_transform ~alerts sg modname filename =
+  Btype.cleanup_abbrev ();
+  Subst.reset_for_saving ();
+  let sg = Subst.signature Make_local (Subst.for_saving Subst.identity) sg in
+  let cmi =
+    Persistent_env.make_cmi persistent_env modname sg alerts
+    |> cmi_transform in
+  let pm = save_sign_of_cmi
+      { Persistent_env.Persistent_signature.cmi; filename } in
+  Persistent_env.save_cmi persistent_env
+    { Persistent_env.Persistent_signature.filename; cmi } pm;
+  cmi
+
+let save_signature ~alerts sg modname filename =
+  save_signature_with_transform (fun cmi -> cmi)
+    ~alerts sg modname filename
+
+let save_signature_with_imports ~alerts sg modname filename imports =
+  let with_imports cmi = { cmi with cmi_crcs = imports } in
+  save_signature_with_transform with_imports
+    ~alerts sg modname filename
+
+(* Make the initial environment *)
+let (initial_safe_string, initial_unsafe_string) =
+  Predef.build_initial_env
+    (add_type ~check:false)
+    (add_extension ~check:false ~rebind:false)
+    empty
+
+(* Tracking usage *)
+
+let mark_module_used uid =
+  match Types.Uid.Tbl.find module_declarations uid with
+  | mark -> mark ()
+  | exception Not_found -> ()
+
+let mark_modtype_used _uid = ()
+
+let mark_value_used uid =
+  match Types.Uid.Tbl.find value_declarations uid with
+  | mark -> mark ()
+  | exception Not_found -> ()
+
+let mark_type_used uid =
+  match Types.Uid.Tbl.find type_declarations uid with
+  | mark -> mark ()
+  | exception Not_found -> ()
+
+let mark_type_path_used env path =
+  match find_type path env with
+  | decl -> mark_type_used decl.type_uid
+  | exception Not_found -> ()
+
+let mark_constructor_used usage cd =
+  match Types.Uid.Tbl.find used_constructors cd.cd_uid with
+  | mark -> mark usage
+  | exception Not_found -> ()
+
+let mark_extension_used usage ext =
+  match Types.Uid.Tbl.find used_constructors ext.ext_uid with
+  | mark -> mark usage
+  | exception Not_found -> ()
+
+let mark_constructor_description_used usage env cstr =
+  let ty_path =
+    match repr cstr.cstr_res with
+    | {desc=Tconstr(path, _, _)} -> path
+    | _ -> assert false
+  in
+  mark_type_path_used env ty_path;
+  match Types.Uid.Tbl.find used_constructors cstr.cstr_uid with
+  | mark -> mark usage
+  | exception Not_found -> ()
+
+let mark_label_description_used () env lbl =
+  let ty_path =
+    match repr lbl.lbl_res with
+    | {desc=Tconstr(path, _, _)} -> path
+    | _ -> assert false
+  in
+  mark_type_path_used env ty_path
+
+let mark_class_used uid =
+  match Types.Uid.Tbl.find type_declarations uid with
+  | mark -> mark ()
+  | exception Not_found -> ()
+
+let mark_cltype_used uid =
+  match Types.Uid.Tbl.find type_declarations uid with
+  | mark -> mark ()
+  | exception Not_found -> ()
+
+let set_value_used_callback vd callback =
+  Types.Uid.Tbl.add value_declarations vd.val_uid callback
+
+let set_type_used_callback td callback =
+  if Uid.for_actual_declaration td.type_uid then
+    let old =
+      try Types.Uid.Tbl.find type_declarations td.type_uid
+      with Not_found -> ignore
+    in
+    Types.Uid.Tbl.replace type_declarations td.type_uid (fun () -> callback old)
+
+(* Lookup by name *)
+
+let may_lookup_error report_errors loc env err =
+  if report_errors then lookup_error loc env err
+  else raise Not_found
+
+let report_module_unbound ~errors ~loc env reason =
+  match reason with
+  | Mod_unbound_illegal_recursion ->
+      (* see #5965 *)
+    may_lookup_error errors loc env Illegal_reference_to_recursive_module
+
+let report_value_unbound ~errors ~loc env reason lid =
+  match reason with
+  | Val_unbound_instance_variable ->
+      may_lookup_error errors loc env (Masked_instance_variable lid)
+  | Val_unbound_self ->
+      may_lookup_error errors loc env (Masked_self_variable lid)
+  | Val_unbound_ancestor ->
+      may_lookup_error errors loc env (Masked_ancestor_variable lid)
+  | Val_unbound_ghost_recursive rloc ->
+      let show_hint =
+        (* Only display the "missing rec" hint for non-ghost code *)
+        not loc.Location.loc_ghost
+        && not rloc.Location.loc_ghost
+      in
+      let hint =
+        if show_hint then Missing_rec rloc else No_hint
+      in
+      may_lookup_error errors loc env (Unbound_value(lid, hint))
+
+let use_module ~use ~loc path mda =
+  if use then begin
+    let comps = mda.mda_components in
+    mark_module_used comps.uid;
+    Misc.Stdlib.String.Map.iter
+      (fun kind message ->
+         let message = if message = "" then "" else "\n" ^ message in
+         Location.alert ~kind loc
+           (Printf.sprintf "module %s%s" (Path.name path) message)
+      )
+      comps.alerts
+  end
+
+let use_value ~use ~loc path vda =
+  if use then begin
+    let desc = vda.vda_description in
+    mark_value_used desc.val_uid;
+    Builtin_attributes.check_alerts loc desc.val_attributes
+      (Path.name path)
+  end
+
+let use_type ~use ~loc path tda =
+  if use then begin
+    let decl = tda.tda_declaration in
+    mark_type_used decl.type_uid;
+    Builtin_attributes.check_alerts loc decl.type_attributes
+      (Path.name path)
+  end
+
+let use_modtype ~use ~loc path desc =
+  if use then begin
+    mark_modtype_used desc.mtd_uid;
+    Builtin_attributes.check_alerts loc desc.mtd_attributes
+      (Path.name path)
+  end
+
+let use_class ~use ~loc path clda =
+  if use then begin
+    let desc = clda.clda_declaration in
+    mark_class_used desc.cty_uid;
+    Builtin_attributes.check_alerts loc desc.cty_attributes
+      (Path.name path)
+  end
+
+let use_cltype ~use ~loc path desc =
+  if use then begin
+    mark_cltype_used desc.clty_uid;
+    Builtin_attributes.check_alerts loc desc.clty_attributes
+      (Path.name path)
+  end
+
+let use_label ~use ~loc env lbl =
+  if use then begin
+    mark_label_description_used () env lbl;
+    Builtin_attributes.check_alerts loc lbl.lbl_attributes lbl.lbl_name
+  end
+
+let use_constructor_desc ~use ~loc usage env cstr =
+  if use then begin
+    mark_constructor_description_used usage env cstr;
+    Builtin_attributes.check_alerts loc cstr.cstr_attributes cstr.cstr_name
+  end
+
+let use_constructor ~use ~loc usage env cda =
+  use_constructor_desc ~use ~loc usage env cda.cda_description
+
+type _ load =
+  | Load : module_data load
+  | Don't_load : unit load
+
+let lookup_ident_module (type a) (load : a load) ~errors ~use ~loc s env =
+  let path, data =
+    match find_name_module ~mark:use s env.modules with
+    | res -> res
+    | exception Not_found ->
+        may_lookup_error errors loc env (Unbound_module (Lident s))
+  in
+  match data with
+  | Mod_local mda -> begin
+      use_module ~use ~loc path mda;
+      match load with
+      | Load -> path, (mda : a)
+      | Don't_load -> path, (() : a)
+    end
+  | Mod_unbound reason ->
+      report_module_unbound ~errors ~loc env reason
+  | Mod_persistent -> begin
+      match load with
+      | Don't_load ->
+          check_pers_mod ~loc s;
+          path, (() : a)
+      | Load -> begin
+          match find_pers_mod s with
+          | mda ->
+              use_module ~use ~loc path mda;
+              path, (mda : a)
+          | exception Not_found ->
+              may_lookup_error errors loc env (Unbound_module (Lident s))
+        end
+    end
+
+let lookup_ident_value ~errors ~use ~loc name env =
+  match IdTbl.find_name wrap_value ~mark:use name env.values with
+  | (path, Val_bound vda) ->
+      use_value ~use ~loc path vda;
+      path, vda.vda_description
+  | (_, Val_unbound reason) ->
+      report_value_unbound ~errors ~loc env reason (Lident name)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_value (Lident name, No_hint))
+
+let lookup_ident_type ~errors ~use ~loc s env =
+  match IdTbl.find_name wrap_identity ~mark:use s env.types with
+  | (path, data) as res ->
+      use_type ~use ~loc path data;
+      res
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_type (Lident s))
+
+let lookup_ident_modtype ~errors ~use ~loc s env =
+  match IdTbl.find_name wrap_identity ~mark:use s env.modtypes with
+  | (path, data) as res ->
+      use_modtype ~use ~loc path data;
+      res
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_modtype (Lident s))
+
+let lookup_ident_class ~errors ~use ~loc s env =
+  match IdTbl.find_name wrap_identity ~mark:use s env.classes with
+  | (path, clda) ->
+      use_class ~use ~loc path clda;
+      path, clda.clda_declaration
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_class (Lident s))
+
+let lookup_ident_cltype ~errors ~use ~loc s env =
+  match IdTbl.find_name wrap_identity ~mark:use s env.cltypes with
+  | (path, data) as res ->
+      use_cltype ~use ~loc path data;
+      res
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_cltype (Lident s))
+
+let lookup_all_ident_labels ~errors ~use ~loc s env =
+  match TycompTbl.find_all ~mark:use s env.labels with
+  | [] -> may_lookup_error errors loc env (Unbound_label (Lident s))
+  | lbls -> begin
+      List.map
+        (fun (lbl, use_fn) ->
+           let use_fn () =
+             use_label ~use ~loc env lbl;
+             use_fn ()
+           in
+           (lbl, use_fn))
+        lbls
+    end
+
+let lookup_all_ident_constructors ~errors ~use ~loc usage s env =
+  match TycompTbl.find_all ~mark:use s env.constrs with
+  | [] -> may_lookup_error errors loc env (Unbound_constructor (Lident s))
+  | cstrs ->
+      List.map
+        (fun (cda, use_fn) ->
+           let use_fn () =
+             use_constructor ~use ~loc usage env cda;
+             use_fn ()
+           in
+           (cda.cda_description, use_fn))
+        cstrs
+
+let rec lookup_module_components ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s ->
+      let path, data = lookup_ident_module Load ~errors ~use ~loc s env in
+      path, data.mda_components
+  | Ldot(l, s) ->
+      let path, data = lookup_dot_module ~errors ~use ~loc l s env in
+      path, data.mda_components
+  | Lapply(l1, l2) ->
+      let p1, f, arg = lookup_functor_components ~errors ~use ~loc l1 env in
+      let p2, md = lookup_module ~errors ~use ~loc l2 env in
+      check_functor_appl ~errors ~loc env p1 f arg p2 md;
+      let comps = !components_of_functor_appl' ~loc f env p1 p2 in
+      (Papply(p1, p2), comps)
+
+and lookup_structure_components ~errors ~use ~loc lid env =
+  let path, comps = lookup_module_components ~errors ~use ~loc lid env in
+  match get_components_res comps with
+  | Ok (Structure_comps comps) -> path, comps
+  | Ok (Functor_comps _) ->
+      may_lookup_error errors loc env (Functor_used_as_structure lid)
+  | Error No_components_abstract ->
+      may_lookup_error errors loc env (Abstract_used_as_structure lid)
+  | Error (No_components_alias p) ->
+      may_lookup_error errors loc env (Cannot_scrape_alias(lid, p))
+
+and lookup_functor_components ~errors ~use ~loc lid env =
+  let path, comps = lookup_module_components ~errors ~use ~loc lid env in
+  match get_components_res comps with
+  | Ok (Functor_comps fcomps) -> begin
+      match fcomps.fcomp_arg with
+      | Unit -> (* PR#7611 *)
+          may_lookup_error errors loc env (Generative_used_as_applicative lid)
+      | Named (_, arg) -> path, fcomps, arg
+    end
+  | Ok (Structure_comps _) ->
+      may_lookup_error errors loc env (Structure_used_as_functor lid)
+  | Error No_components_abstract ->
+      may_lookup_error errors loc env (Abstract_used_as_functor lid)
+  | Error (No_components_alias p) ->
+      may_lookup_error errors loc env (Cannot_scrape_alias(lid, p))
+
+and lookup_module ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s ->
+      let path, data = lookup_ident_module Load ~errors ~use ~loc s env in
+      let md = EnvLazy.force subst_modtype_maker data.mda_declaration in
+      path, md
+  | Ldot(l, s) ->
+      let path, data = lookup_dot_module ~errors ~use ~loc l s env in
+      let md = EnvLazy.force subst_modtype_maker data.mda_declaration in
+      path, md
+  | Lapply(l1, l2) ->
+      let p1, fc, arg = lookup_functor_components ~errors ~use ~loc l1 env in
+      let p2, md2 = lookup_module ~errors ~use ~loc l2 env in
+      check_functor_appl ~errors ~loc env p1 fc arg p2 md2;
+      let md = md (modtype_of_functor_appl fc p1 p2) in
+      Papply(p1, p2), md
+
+and lookup_dot_module ~errors ~use ~loc l s env =
+  let p, comps = lookup_structure_components ~errors ~use ~loc l env in
+  match NameMap.find s comps.comp_modules with
+  | mda ->
+      let path = Pdot(p, s) in
+      use_module ~use ~loc path mda;
+      (path, mda)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_module (Ldot(l, s)))
+
+let lookup_dot_value ~errors ~use ~loc l s env =
+  let (path, comps) =
+    lookup_structure_components ~errors ~use ~loc l env
+  in
+  match NameMap.find s comps.comp_values with
+  | vda ->
+      let path = Pdot(path, s) in
+      use_value ~use ~loc path vda;
+      (path, vda.vda_description)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_value (Ldot(l, s), No_hint))
+
+let lookup_dot_type ~errors ~use ~loc l s env =
+  let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in
+  match NameMap.find s comps.comp_types with
+  | tda ->
+      let path = Pdot(p, s) in
+      use_type ~use ~loc path tda;
+      (path, tda)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_type (Ldot(l, s)))
+
+let lookup_dot_modtype ~errors ~use ~loc l s env =
+  let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in
+  match NameMap.find s comps.comp_modtypes with
+  | desc ->
+      let path = Pdot(p, s) in
+      use_modtype ~use ~loc path desc;
+      (path, desc)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_modtype (Ldot(l, s)))
+
+let lookup_dot_class ~errors ~use ~loc l s env =
+  let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in
+  match NameMap.find s comps.comp_classes with
+  | clda ->
+      let path = Pdot(p, s) in
+      use_class ~use ~loc path clda;
+      (path, clda.clda_declaration)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_class (Ldot(l, s)))
+
+let lookup_dot_cltype ~errors ~use ~loc l s env =
+  let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in
+  match NameMap.find s comps.comp_cltypes with
+  | desc ->
+      let path = Pdot(p, s) in
+      use_cltype ~use ~loc path desc;
+      (path, desc)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_cltype (Ldot(l, s)))
+
+let lookup_all_dot_labels ~errors ~use ~loc l s env =
+  let (_, comps) = lookup_structure_components ~errors ~use ~loc l env in
+  match NameMap.find s comps.comp_labels with
+  | [] | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_label (Ldot(l, s)))
+  | lbls ->
+      List.map
+        (fun lbl ->
+           let use_fun () = use_label ~use ~loc env lbl in
+           (lbl, use_fun))
+        lbls
+
+let lookup_all_dot_constructors ~errors ~use ~loc usage l s env =
+  match l with
+  | Longident.Lident "*predef*" ->
+      (* Hack to support compilation of default arguments *)
+      lookup_all_ident_constructors
+        ~errors ~use ~loc usage s initial_safe_string
+  | _ ->
+      let (_, comps) = lookup_structure_components ~errors ~use ~loc l env in
+      match NameMap.find s comps.comp_constrs with
+      | [] | exception Not_found ->
+          may_lookup_error errors loc env (Unbound_constructor (Ldot(l, s)))
+      | cstrs ->
+          List.map
+            (fun cda ->
+               let use_fun () = use_constructor ~use ~loc usage env cda in
+               (cda.cda_description, use_fun))
+            cstrs
+
+(* General forms of the lookup functions *)
+
+let lookup_module_path ~errors ~use ~loc ~load lid env : Path.t =
+  match lid with
+  | Lident s ->
+      if !Clflags.transparent_modules && not load then
+        fst (lookup_ident_module Don't_load ~errors ~use ~loc s env)
+      else
+        fst (lookup_ident_module Load ~errors ~use ~loc s env)
+  | Ldot(l, s) -> fst (lookup_dot_module ~errors ~use ~loc l s env)
+  | Lapply(l1, l2) ->
+      let (p1, f, arg) = lookup_functor_components ~errors ~use ~loc l1 env in
+      let p2, md2 = lookup_module ~errors ~use ~loc l2 env in
+      check_functor_appl ~errors ~loc env p1 f arg p2 md2;
+      Papply(p1, p2)
+
+let lookup_value ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s -> lookup_ident_value ~errors ~use ~loc s env
+  | Ldot(l, s) -> lookup_dot_value ~errors ~use ~loc l s env
+  | Lapply _ -> assert false
+
+let lookup_type_full ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s -> lookup_ident_type ~errors ~use ~loc s env
+  | Ldot(l, s) -> lookup_dot_type ~errors ~use ~loc l s env
+  | Lapply _ -> assert false
+
+let lookup_type ~errors ~use ~loc lid env =
+  let (path, tda) = lookup_type_full ~errors ~use ~loc lid env in
+  path, tda.tda_declaration
+
+let lookup_modtype ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s -> lookup_ident_modtype ~errors ~use ~loc s env
+  | Ldot(l, s) -> lookup_dot_modtype ~errors ~use ~loc l s env
+  | Lapply _ -> assert false
+
+let lookup_class ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s -> lookup_ident_class ~errors ~use ~loc s env
+  | Ldot(l, s) -> lookup_dot_class ~errors ~use ~loc l s env
+  | Lapply _ -> assert false
+
+let lookup_cltype ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s -> lookup_ident_cltype ~errors ~use ~loc s env
+  | Ldot(l, s) -> lookup_dot_cltype ~errors ~use ~loc l s env
+  | Lapply _ -> assert false
+
+let lookup_all_labels ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s -> lookup_all_ident_labels ~errors ~use ~loc s env
+  | Ldot(l, s) -> lookup_all_dot_labels ~errors ~use ~loc l s env
+  | Lapply _ -> assert false
+
+let lookup_label ~errors ~use ~loc lid env =
+  match lookup_all_labels ~errors ~use ~loc lid env with
+  | [] -> assert false
+  | (desc, use) :: _ -> use (); desc
+
+let lookup_all_labels_from_type ~use ~loc ty_path env =
+  match find_type_descrs ty_path env with
+  | exception Not_found -> []
+  | (_, lbls) ->
+      List.map
+        (fun lbl ->
+           let use_fun () = use_label ~use ~loc env lbl in
+           (lbl, use_fun))
+        lbls
+
+let lookup_all_constructors ~errors ~use ~loc usage lid env =
+  match lid with
+  | Lident s -> lookup_all_ident_constructors ~errors ~use ~loc usage s env
+  | Ldot(l, s) -> lookup_all_dot_constructors ~errors ~use ~loc usage l s env
+  | Lapply _ -> assert false
+
+let lookup_constructor ~errors ~use ~loc usage lid env =
+  match lookup_all_constructors ~errors ~use ~loc usage lid env with
+  | [] -> assert false
+  | (desc, use) :: _ -> use (); desc
+
+let lookup_all_constructors_from_type ~use ~loc usage ty_path env =
+  match find_type_descrs ty_path env with
+  | exception Not_found -> []
+  | (cstrs, _) ->
+      List.map
+        (fun cstr ->
+           let use_fun () =
+             use_constructor_desc ~use ~loc usage env cstr
+           in
+           (cstr, use_fun))
+        cstrs
+
+(* Lookup functions that do not mark the item as used or
+   warn if it has alerts, and raise [Not_found] rather
+   than report errors *)
+
+let find_module_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_module ~errors:false ~use:false ~loc lid env
+
+let find_value_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_value ~errors:false ~use:false ~loc lid env
+
+let find_type_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_type ~errors:false ~use:false ~loc lid env
+
+let find_modtype_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_modtype ~errors:false ~use:false ~loc lid env
+
+let find_class_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_class ~errors:false ~use:false ~loc lid env
+
+let find_cltype_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_cltype ~errors:false ~use:false ~loc lid env
+
+let find_constructor_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_constructor ~errors:false ~use:false ~loc Positive lid env
+
+let find_label_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_label ~errors:false ~use:false ~loc lid env
+
+(* Ordinary lookup functions *)
+
+let lookup_module_path ?(use=true) ~loc ~load lid env =
+  lookup_module_path ~errors:true ~use ~loc ~load lid env
+
+let lookup_module ?(use=true) ~loc lid env =
+  lookup_module ~errors:true ~use ~loc lid env
+
+let lookup_value ?(use=true) ~loc lid env =
+  check_value_name (Longident.last lid) loc;
+  lookup_value ~errors:true ~use ~loc lid env
+
+let lookup_type ?(use=true) ~loc lid env =
+  lookup_type ~errors:true ~use ~loc lid env
+
+let lookup_modtype ?(use=true) ~loc lid env =
+  lookup_modtype ~errors:true ~use ~loc lid env
+
+let lookup_class ?(use=true) ~loc lid env =
+  lookup_class ~errors:true ~use ~loc lid env
+
+let lookup_cltype ?(use=true) ~loc lid env =
+  lookup_cltype ~errors:true ~use ~loc lid env
+
+let lookup_all_constructors ?(use=true) ~loc usage lid env =
+  match lookup_all_constructors ~errors:true ~use ~loc usage lid env with
+  | exception Error(Lookup_error(loc', env', err)) ->
+      (Error(loc', env', err) : _ result)
+  | cstrs -> Ok cstrs
+
+let lookup_constructor ?(use=true) ~loc lid env =
+  lookup_constructor ~errors:true ~use ~loc lid env
+
+let lookup_all_constructors_from_type ?(use=true) ~loc usage ty_path env =
+  lookup_all_constructors_from_type ~use ~loc usage ty_path env
+
+let lookup_all_labels ?(use=true) ~loc lid env =
+  match lookup_all_labels ~errors:true ~use ~loc lid env with
+  | exception Error(Lookup_error(loc', env', err)) ->
+      (Error(loc', env', err) : _ result)
+  | lbls -> Ok lbls
+
+let lookup_label ?(use=true) ~loc lid env =
+  lookup_label ~errors:true ~use ~loc lid env
+
+let lookup_all_labels_from_type ?(use=true) ~loc ty_path env =
+  lookup_all_labels_from_type ~use ~loc ty_path env
+
+let lookup_instance_variable ?(use=true) ~loc name env =
+  match IdTbl.find_name wrap_value ~mark:use name env.values with
+  | (path, Val_bound vda) -> begin
+      let desc = vda.vda_description in
+      match desc.val_kind with
+      | Val_ivar(mut, cl_num) ->
+          use_value ~use ~loc path vda;
+          path, mut, cl_num, desc.val_type
+      | _ ->
+          lookup_error loc env (Not_an_instance_variable name)
+    end
+  | (_, Val_unbound Val_unbound_instance_variable) ->
+      lookup_error loc env (Masked_instance_variable (Lident name))
+  | (_, Val_unbound Val_unbound_self) ->
+      lookup_error loc env (Not_an_instance_variable name)
+  | (_, Val_unbound Val_unbound_ancestor) ->
+      lookup_error loc env (Not_an_instance_variable name)
+  | (_, Val_unbound Val_unbound_ghost_recursive _) ->
+      lookup_error loc env (Unbound_instance_variable name)
+  | exception Not_found ->
+      lookup_error loc env (Unbound_instance_variable name)
+
+(* Checking if a name is bound *)
+
+let bound_module name env =
+  match IdTbl.find_name wrap_module ~mark:false name env.modules with
+  | _ -> true
+  | exception Not_found ->
+      if Current_unit_name.is name then false
+      else begin
+        match find_pers_mod name with
+        | _ -> true
+        | exception Not_found -> false
+      end
+
+let bound wrap proj name env =
+  match IdTbl.find_name wrap ~mark:false name (proj env) with
+  | _ -> true
+  | exception Not_found -> false
+
+let bound_value name env =
+  bound wrap_value (fun env -> env.values) name env
+
+let bound_type name env =
+  bound wrap_identity (fun env -> env.types) name env
+
+let bound_modtype name env =
+  bound wrap_identity (fun env -> env.modtypes) name env
+
+let bound_class name env =
+  bound wrap_identity (fun env -> env.classes) name env
+
+let bound_cltype name env =
+  bound wrap_identity (fun env -> env.cltypes) name env
+
+(* Folding on environments *)
+
+let find_all wrap proj1 proj2 f lid env acc =
+  match lid with
+  | None ->
+      IdTbl.fold_name wrap
+        (fun name (p, data) acc -> f name p data acc)
+        (proj1 env) acc
+  | Some l ->
+      let p, desc =
+        lookup_module_components
+          ~errors:false ~use:false ~loc:Location.none l env
+      in
+      begin match get_components desc with
+      | Structure_comps c ->
+          NameMap.fold
+            (fun s data acc -> f s (Pdot (p, s)) (wrap data) acc)
+            (proj2 c) acc
+      | Functor_comps _ ->
+          acc
+      end
+
+let find_all_simple_list proj1 proj2 f lid env acc =
+  match lid with
+  | None ->
+      TycompTbl.fold_name
+        (fun data acc -> f data acc)
+        (proj1 env) acc
+  | Some l ->
+      let (_p, desc) =
+        lookup_module_components
+          ~errors:false ~use:false ~loc:Location.none l env
+      in
+      begin match get_components desc with
+      | Structure_comps c ->
+          NameMap.fold
+            (fun _s comps acc ->
+               match comps with
+               | [] -> acc
+               | data :: _ -> f data acc)
+            (proj2 c) acc
+      | Functor_comps _ ->
+          acc
+      end
+
+let fold_modules f lid env acc =
+  match lid with
+  | None ->
+      IdTbl.fold_name wrap_module
+        (fun name (p, entry) acc ->
+           match entry with
+           | Mod_unbound _ -> acc
+           | Mod_local mda ->
+               let md =
+                 EnvLazy.force subst_modtype_maker mda.mda_declaration
+               in
+               f name p md acc
+           | Mod_persistent ->
+               match Persistent_env.find_in_cache persistent_env name with
+               | None -> acc
+               | Some mda ->
+                   let md =
+                     EnvLazy.force subst_modtype_maker mda.mda_declaration
+                   in
+                   f name p md acc)
+        env.modules
+        acc
+  | Some l ->
+      let p, desc =
+        lookup_module_components
+          ~errors:false ~use:false ~loc:Location.none l env
+      in
+      begin match get_components desc with
+      | Structure_comps c ->
+          NameMap.fold
+            (fun s mda acc ->
+               let md =
+                 EnvLazy.force subst_modtype_maker mda.mda_declaration
+               in
+               f s (Pdot (p, s)) md acc)
+            c.comp_modules
+            acc
+      | Functor_comps _ ->
+          acc
+      end
+
+let fold_values f =
+  find_all wrap_value (fun env -> env.values) (fun sc -> sc.comp_values)
+    (fun k p ve acc ->
+       match ve with
+       | Val_unbound _ -> acc
+       | Val_bound vda -> f k p vda.vda_description acc)
+and fold_constructors f =
+  find_all_simple_list (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
+    (fun cda acc -> f cda.cda_description acc)
+and fold_labels f =
+  find_all_simple_list (fun env -> env.labels) (fun sc -> sc.comp_labels) f
+and fold_types f =
+  find_all wrap_identity
+    (fun env -> env.types) (fun sc -> sc.comp_types)
+    (fun k p tda acc -> f k p tda.tda_declaration acc)
+and fold_modtypes f =
+  find_all wrap_identity
+    (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) f
+and fold_classes f =
+  find_all wrap_identity (fun env -> env.classes) (fun sc -> sc.comp_classes)
+    (fun k p clda acc -> f k p clda.clda_declaration acc)
+and fold_cltypes f =
+  find_all wrap_identity
+    (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) f
+
+let filter_non_loaded_persistent f env =
+  let to_remove =
+    IdTbl.fold_name wrap_module
+      (fun name (_, entry) acc ->
+         match entry with
+         | Mod_local _ -> acc
+         | Mod_unbound _ -> acc
+         | Mod_persistent ->
+             match Persistent_env.find_in_cache persistent_env name with
+             | Some _ -> acc
+             | None ->
+                 if f (Ident.create_persistent name) then
+                   acc
+                 else
+                   String.Set.add name acc)
+      env.modules
+      String.Set.empty
+  in
+  let remove_ids tbl ids =
+    String.Set.fold
+      (fun name tbl -> IdTbl.remove (Ident.create_persistent name) tbl)
+      ids
+      tbl
+  in
+  let rec filter_summary summary ids =
+    if String.Set.is_empty ids then
+      summary
+    else
+      match summary with
+      | Env_empty -> summary
+      | Env_value (s, id, vd) ->
+          Env_value (filter_summary s ids, id, vd)
+      | Env_type (s, id, td) ->
+          Env_type (filter_summary s ids, id, td)
+      | Env_extension (s, id, ec) ->
+          Env_extension (filter_summary s ids, id, ec)
+      | Env_module (s, id, mp, md) ->
+          Env_module (filter_summary s ids, id, mp, md)
+      | Env_modtype (s, id, md) ->
+          Env_modtype (filter_summary s ids, id, md)
+      | Env_class (s, id, cd) ->
+          Env_class (filter_summary s ids, id, cd)
+      | Env_cltype (s, id, ctd) ->
+          Env_cltype (filter_summary s ids, id, ctd)
+      | Env_open (s, p) ->
+          Env_open (filter_summary s ids, p)
+      | Env_functor_arg (s, id) ->
+          Env_functor_arg (filter_summary s ids, id)
+      | Env_constraints (s, cstrs) ->
+          Env_constraints (filter_summary s ids, cstrs)
+      | Env_copy_types s ->
+          Env_copy_types (filter_summary s ids)
+      | Env_persistent (s, id) ->
+          if String.Set.mem (Ident.name id) ids then
+            filter_summary s (String.Set.remove (Ident.name id) ids)
+          else
+            Env_persistent (filter_summary s ids, id)
+      | Env_value_unbound (s, n, r) ->
+          Env_value_unbound (filter_summary s ids, n, r)
+      | Env_module_unbound (s, n, r) ->
+          Env_module_unbound (filter_summary s ids, n, r)
+  in
+  { env with
+    modules = remove_ids env.modules to_remove;
+    summary = filter_summary env.summary to_remove;
+  }
+
+(* Return the environment summary *)
+
+let summary env =
+  if Path.Map.is_empty env.local_constraints then env.summary
+  else Env_constraints (env.summary, env.local_constraints)
+
+let last_env = ref empty
+let last_reduced_env = ref empty
+
+let keep_only_summary env =
+  if !last_env == env then !last_reduced_env
+  else begin
+    let new_env =
+      {
+       empty with
+       summary = env.summary;
+       local_constraints = env.local_constraints;
+       flags = env.flags;
+      }
+    in
+    last_env := env;
+    last_reduced_env := new_env;
+    new_env
+  end
+
+
+let env_of_only_summary env_from_summary env =
+  let new_env = env_from_summary env.summary Subst.identity in
+  { new_env with
+    local_constraints = env.local_constraints;
+    flags = env.flags;
+  }
+
+(* Error report *)
+
+open Format
+
+(* Forward declarations *)
+
+let print_longident =
+  ref ((fun _ _ -> assert false) : formatter -> Longident.t -> unit)
+
+let print_path =
+  ref ((fun _ _ -> assert false) : formatter -> Path.t -> unit)
+
+let spellcheck ppf extract env lid =
+  let choices ~path name = Misc.spellcheck (extract path env) name in
+  match lid with
+    | Longident.Lapply _ -> ()
+    | Longident.Lident s ->
+       Misc.did_you_mean ppf (fun () -> choices ~path:None s)
+    | Longident.Ldot (r, s) ->
+       Misc.did_you_mean ppf (fun () -> choices ~path:(Some r) s)
+
+let spellcheck_name ppf extract env name =
+  Misc.did_you_mean ppf
+    (fun () -> Misc.spellcheck (extract env) name)
+
+let extract_values path env =
+  fold_values (fun name _ _ acc -> name :: acc) path env []
+let extract_types path env =
+  fold_types (fun name _ _ acc -> name :: acc) path env []
+let extract_modules path env =
+  fold_modules (fun name _ _ acc -> name :: acc) path env []
+let extract_constructors path env =
+  fold_constructors (fun desc acc -> desc.cstr_name :: acc) path env []
+let extract_labels path env =
+  fold_labels (fun desc acc -> desc.lbl_name :: acc) path env []
+let extract_classes path env =
+  fold_classes (fun name _ _ acc -> name :: acc) path env []
+let extract_modtypes path env =
+  fold_modtypes (fun name _ _ acc -> name :: acc) path env []
+let extract_cltypes path env =
+  fold_cltypes (fun name _ _ acc -> name :: acc) path env []
+let extract_instance_variables env =
+  fold_values
+    (fun name _ descr acc ->
+       match descr.val_kind with
+       | Val_ivar _ -> name :: acc
+       | _ -> acc) None env []
+
+let report_lookup_error _loc env ppf = function
+  | Unbound_value(lid, hint) -> begin
+      fprintf ppf "Unbound value %a" !print_longident lid;
+      spellcheck ppf extract_values env lid;
+      match hint with
+      | No_hint -> ()
+      | Missing_rec def_loc ->
+          let (_, line, _) =
+            Location.get_pos_info def_loc.Location.loc_start
+          in
+          fprintf ppf
+            "@.@[%s@ %s %i@]"
+            "Hint: If this is a recursive definition,"
+            "you should add the 'rec' keyword on line"
+            line
+    end
+  | Unbound_type lid ->
+      fprintf ppf "Unbound type constructor %a" !print_longident lid;
+      spellcheck ppf extract_types env lid;
+  | Unbound_module lid ->
+      fprintf ppf "Unbound module %a" !print_longident lid;
+      spellcheck ppf extract_modules env lid;
+  | Unbound_constructor lid ->
+      fprintf ppf "Unbound constructor %a" !print_longident lid;
+      spellcheck ppf extract_constructors env lid;
+  | Unbound_label lid ->
+      fprintf ppf "Unbound record field %a" !print_longident lid;
+      spellcheck ppf extract_labels env lid;
+  | Unbound_class lid ->
+      fprintf ppf "Unbound class %a" !print_longident lid;
+      spellcheck ppf extract_classes env lid;
+  | Unbound_modtype lid ->
+      fprintf ppf "Unbound module type %a" !print_longident lid;
+      spellcheck ppf extract_modtypes env lid;
+  | Unbound_cltype lid ->
+      fprintf ppf "Unbound class type %a" !print_longident lid;
+      spellcheck ppf extract_cltypes env lid;
+  | Unbound_instance_variable s ->
+      fprintf ppf "Unbound instance variable %s" s;
+      spellcheck_name ppf extract_instance_variables env s;
+  | Not_an_instance_variable s ->
+      fprintf ppf "The value %s is not an instance variable" s;
+      spellcheck_name ppf extract_instance_variables env s;
+  | Masked_instance_variable lid ->
+      fprintf ppf
+        "The instance variable %a@ \
+         cannot be accessed from the definition of another instance variable"
+        !print_longident lid
+  | Masked_self_variable lid ->
+      fprintf ppf
+        "The self variable %a@ \
+         cannot be accessed from the definition of an instance variable"
+        !print_longident lid
+  | Masked_ancestor_variable lid ->
+      fprintf ppf
+        "The ancestor variable %a@ \
+         cannot be accessed from the definition of an instance variable"
+        !print_longident lid
+  | Illegal_reference_to_recursive_module ->
+     fprintf ppf "Illegal recursive module reference"
+  | Structure_used_as_functor lid ->
+      fprintf ppf "@[The module %a is a structure, it cannot be applied@]"
+        !print_longident lid
+  | Abstract_used_as_functor lid ->
+      fprintf ppf "@[The module %a is abstract, it cannot be applied@]"
+        !print_longident lid
+  | Functor_used_as_structure lid ->
+      fprintf ppf "@[The module %a is a functor, \
+                   it cannot have any components@]" !print_longident lid
+  | Abstract_used_as_structure lid ->
+      fprintf ppf "@[The module %a is abstract, \
+                   it cannot have any components@]" !print_longident lid
+  | Generative_used_as_applicative lid ->
+      fprintf ppf "@[The functor %a is generative,@ it@ cannot@ be@ \
+                   applied@ in@ type@ expressions@]" !print_longident lid
+  | Cannot_scrape_alias(lid, p) ->
+      fprintf ppf
+        "The module %a is an alias for module %a, which is missing"
+        !print_longident lid !print_path p
+
+let report_error ppf = function
+  | Missing_module(_, path1, path2) ->
+      fprintf ppf "@[@[<hov>";
+      if Path.same path1 path2 then
+        fprintf ppf "Internal path@ %s@ is dangling." (Path.name path1)
+      else
+        fprintf ppf "Internal path@ %s@ expands to@ %s@ which is dangling."
+          (Path.name path1) (Path.name path2);
+      fprintf ppf "@]@ @[%s@ %s@ %s.@]@]"
+        "The compiled interface for module" (Ident.name (Path.head path2))
+        "was not found"
+  | Illegal_value_name(_loc, name) ->
+      fprintf ppf "'%s' is not a valid value identifier."
+        name
+  | Lookup_error(loc, t, err) -> report_lookup_error loc t ppf err
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err ->
+          let loc =
+            match err with
+            | Missing_module (loc, _, _)
+            | Illegal_value_name (loc, _)
+            | Lookup_error(loc, _, _) -> loc
+          in
+          let error_of_printer =
+            if loc = Location.none
+            then Location.error_of_printer_file
+            else Location.error_of_printer ~loc ?sub:None
+          in
+          Some (error_of_printer report_error err)
+      | _ ->
+          None
+    )
diff --git a/upstream/ocaml_411/typing/env.mli b/upstream/ocaml_411/typing/env.mli
new file mode 100644
index 0000000..e43a5ef
--- /dev/null
+++ b/upstream/ocaml_411/typing/env.mli
@@ -0,0 +1,447 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Environment handling *)
+
+open Types
+open Misc
+
+type value_unbound_reason =
+  | Val_unbound_instance_variable
+  | Val_unbound_self
+  | Val_unbound_ancestor
+  | Val_unbound_ghost_recursive of Location.t
+
+type module_unbound_reason =
+  | Mod_unbound_illegal_recursion
+
+type summary =
+    Env_empty
+  | Env_value of summary * Ident.t * value_description
+  | Env_type of summary * Ident.t * type_declaration
+  | Env_extension of summary * Ident.t * extension_constructor
+  | Env_module of summary * Ident.t * module_presence * module_declaration
+  | Env_modtype of summary * Ident.t * modtype_declaration
+  | Env_class of summary * Ident.t * class_declaration
+  | Env_cltype of summary * Ident.t * class_type_declaration
+  | Env_open of summary * Path.t
+  (** The string set argument of [Env_open] represents a list of module names
+      to skip, i.e. that won't be imported in the toplevel namespace. *)
+  | Env_functor_arg of summary * Ident.t
+  | Env_constraints of summary * type_declaration Path.Map.t
+  | Env_copy_types of summary
+  | Env_persistent of summary * Ident.t
+  | Env_value_unbound of summary * string * value_unbound_reason
+  | Env_module_unbound of summary * string * module_unbound_reason
+
+type address =
+  | Aident of Ident.t
+  | Adot of address * int
+
+type t
+
+val empty: t
+val initial_safe_string: t
+val initial_unsafe_string: t
+val diff: t -> t -> Ident.t list
+val copy_local: from:t -> t -> t
+
+type type_descriptions =
+    constructor_description list * label_description list
+
+(* For short-paths *)
+type iter_cont
+val iter_types:
+    (Path.t -> Path.t * type_declaration -> unit) ->
+    t -> iter_cont
+val run_iter_cont: iter_cont list -> (Path.t * iter_cont) list
+val same_types: t -> t -> bool
+val used_persistent: unit -> Concr.t
+val find_shadowed_types: Path.t -> t -> Path.t list
+val without_cmis: ('a -> 'b) -> 'a -> 'b
+(* [without_cmis f arg] applies [f] to [arg], but does not
+   allow opening cmis during its execution *)
+
+(* Lookup by paths *)
+
+val find_value: Path.t -> t -> value_description
+val find_type: Path.t -> t -> type_declaration
+val find_type_descrs: Path.t -> t -> type_descriptions
+val find_module: Path.t -> t -> module_declaration
+val find_modtype: Path.t -> t -> modtype_declaration
+val find_class: Path.t -> t -> class_declaration
+val find_cltype: Path.t -> t -> class_type_declaration
+
+val find_ident_constructor: Ident.t -> t -> constructor_description
+val find_ident_label: Ident.t -> t -> label_description
+
+val find_type_expansion:
+    Path.t -> t -> type_expr list * type_expr * int
+val find_type_expansion_opt:
+    Path.t -> t -> type_expr list * type_expr * int
+(* Find the manifest type information associated to a type for the sake
+   of the compiler's type-based optimisations. *)
+val find_modtype_expansion: Path.t -> t -> module_type
+
+val find_hash_type: Path.t -> t -> type_declaration
+(* Find the "#t" type given the path for "t" *)
+
+val find_value_address: Path.t -> t -> address
+val find_module_address: Path.t -> t -> address
+val find_class_address: Path.t -> t -> address
+val find_constructor_address: Path.t -> t -> address
+
+val add_functor_arg: Ident.t -> t -> t
+val is_functor_arg: Path.t -> t -> bool
+
+val normalize_module_path: Location.t option -> t -> Path.t -> Path.t
+(* Normalize the path to a concrete module.
+   If the option is None, allow returning dangling paths.
+   Otherwise raise a Missing_module error, and may add forgotten
+   head as required global. *)
+
+val normalize_type_path: Location.t option -> t -> Path.t -> Path.t
+(* Normalize the prefix part of the type path *)
+
+val normalize_path_prefix: Location.t option -> t -> Path.t -> Path.t
+(* Normalize the prefix part of other kinds of paths
+   (value/modtype/etc) *)
+
+val normalize_modtype_path: t -> Path.t -> Path.t
+(* Normalize a module type path *)
+
+val reset_required_globals: unit -> unit
+val get_required_globals: unit -> Ident.t list
+val add_required_global: Ident.t -> unit
+
+val has_local_constraints: t -> bool
+
+(* Mark definitions as used *)
+val mark_value_used: Uid.t -> unit
+val mark_module_used: Uid.t -> unit
+val mark_type_used: Uid.t -> unit
+
+type constructor_usage = Positive | Pattern | Privatize
+val mark_constructor_used:
+    constructor_usage -> constructor_declaration -> unit
+val mark_extension_used:
+    constructor_usage -> extension_constructor -> unit
+
+(* Lookup by long identifiers *)
+
+(* Lookup errors *)
+
+type unbound_value_hint =
+  | No_hint
+  | Missing_rec of Location.t
+
+type lookup_error =
+  | Unbound_value of Longident.t * unbound_value_hint
+  | Unbound_type of Longident.t
+  | Unbound_constructor of Longident.t
+  | Unbound_label of Longident.t
+  | Unbound_module of Longident.t
+  | Unbound_class of Longident.t
+  | Unbound_modtype of Longident.t
+  | Unbound_cltype of Longident.t
+  | Unbound_instance_variable of string
+  | Not_an_instance_variable of string
+  | Masked_instance_variable of Longident.t
+  | Masked_self_variable of Longident.t
+  | Masked_ancestor_variable of Longident.t
+  | Structure_used_as_functor of Longident.t
+  | Abstract_used_as_functor of Longident.t
+  | Functor_used_as_structure of Longident.t
+  | Abstract_used_as_structure of Longident.t
+  | Generative_used_as_applicative of Longident.t
+  | Illegal_reference_to_recursive_module
+  | Cannot_scrape_alias of Longident.t * Path.t
+
+val lookup_error: Location.t -> t -> lookup_error -> 'a
+
+(* The [lookup_foo] functions will emit proper error messages (by
+   raising [Error]) if the identifier cannot be found, whereas the
+   [find_foo_by_name] functions will raise [Not_found] instead.
+
+   The [~use] parameters of the [lookup_foo] functions control
+   whether this lookup should be counted as a use for usage
+   warnings and alerts.
+
+   [Longident.t]s in the program source should be looked up using
+   [lookup_foo ~use:true] exactly one time -- otherwise warnings may be
+   emitted the wrong number of times. *)
+
+val lookup_value:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  Path.t * value_description
+val lookup_type:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  Path.t * type_declaration
+val lookup_module:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  Path.t * module_declaration
+val lookup_modtype:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  Path.t * modtype_declaration
+val lookup_class:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  Path.t * class_declaration
+val lookup_cltype:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  Path.t * class_type_declaration
+
+val lookup_module_path:
+  ?use:bool -> loc:Location.t -> load:bool -> Longident.t -> t -> Path.t
+
+val lookup_constructor:
+  ?use:bool -> loc:Location.t -> constructor_usage -> Longident.t -> t ->
+  constructor_description
+val lookup_all_constructors:
+  ?use:bool -> loc:Location.t -> constructor_usage -> Longident.t -> t ->
+  ((constructor_description * (unit -> unit)) list,
+   Location.t * t * lookup_error) result
+val lookup_all_constructors_from_type:
+  ?use:bool -> loc:Location.t -> constructor_usage -> Path.t -> t ->
+  (constructor_description * (unit -> unit)) list
+
+val lookup_label:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  label_description
+val lookup_all_labels:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  ((label_description * (unit -> unit)) list,
+   Location.t * t * lookup_error) result
+val lookup_all_labels_from_type:
+  ?use:bool -> loc:Location.t -> Path.t -> t ->
+  (label_description * (unit -> unit)) list
+
+val lookup_instance_variable:
+  ?use:bool -> loc:Location.t -> string -> t ->
+  Path.t * Asttypes.mutable_flag * string * type_expr
+
+val find_value_by_name:
+  Longident.t -> t -> Path.t * value_description
+val find_type_by_name:
+  Longident.t -> t -> Path.t * type_declaration
+val find_module_by_name:
+  Longident.t -> t -> Path.t * module_declaration
+val find_modtype_by_name:
+  Longident.t -> t -> Path.t * modtype_declaration
+val find_class_by_name:
+  Longident.t -> t -> Path.t * class_declaration
+val find_cltype_by_name:
+  Longident.t -> t -> Path.t * class_type_declaration
+
+val find_constructor_by_name:
+  Longident.t -> t -> constructor_description
+val find_label_by_name:
+  Longident.t -> t -> label_description
+
+(* Check if a name is bound *)
+
+val bound_value: string -> t -> bool
+val bound_module: string -> t -> bool
+val bound_type: string -> t -> bool
+val bound_modtype: string -> t -> bool
+val bound_class: string -> t -> bool
+val bound_cltype: string -> t -> bool
+
+val make_copy_of_types: t -> (t -> t)
+
+(* Insertion by identifier *)
+
+val add_value:
+    ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t
+val add_type: check:bool -> Ident.t -> type_declaration -> t -> t
+val add_extension:
+  check:bool -> rebind:bool -> Ident.t -> extension_constructor -> t -> t
+val add_module:
+  ?arg:bool -> Ident.t -> module_presence -> module_type -> t -> t
+val add_module_declaration: ?arg:bool -> check:bool -> Ident.t ->
+  module_presence -> module_declaration -> t -> t
+val add_modtype: Ident.t -> modtype_declaration -> t -> t
+val add_class: Ident.t -> class_declaration -> t -> t
+val add_cltype: Ident.t -> class_type_declaration -> t -> t
+val add_local_type: Path.t -> type_declaration -> t -> t
+
+(* Insertion of persistent signatures *)
+
+(* [add_persistent_structure id env] is an environment such that
+   module [id] points to the persistent structure contained in the
+   external compilation unit with the same name.
+
+   The compilation unit itself is looked up in the load path when the
+   contents of the module is accessed. *)
+val add_persistent_structure : Ident.t -> t -> t
+
+(* Returns the set of persistent structures found in the given
+   directory. *)
+val persistent_structures_of_dir : Load_path.Dir.t -> Misc.Stdlib.String.Set.t
+
+(* [filter_non_loaded_persistent f env] removes all the persistent
+   structures that are not yet loaded and for which [f] returns
+   [false]. *)
+val filter_non_loaded_persistent : (Ident.t -> bool) -> t -> t
+
+(* Insertion of all fields of a signature. *)
+
+val add_item: signature_item -> t -> t
+val add_signature: signature -> t -> t
+
+(* Insertion of all fields of a signature, relative to the given path.
+   Used to implement open. Returns None if the path refers to a functor,
+   not a structure. *)
+val open_signature:
+    ?used_slot:bool ref ->
+    ?loc:Location.t -> ?toplevel:bool ->
+    Asttypes.override_flag -> Path.t ->
+    t -> (t, [`Not_found | `Functor]) result
+
+val open_pers_signature: string -> t -> (t, [`Not_found]) result
+
+(* Insertion by name *)
+
+val enter_value:
+    ?check:(string -> Warnings.t) ->
+    string -> value_description -> t -> Ident.t * t
+val enter_type: scope:int -> string -> type_declaration -> t -> Ident.t * t
+val enter_extension:
+  scope:int -> rebind:bool -> string ->
+  extension_constructor -> t -> Ident.t * t
+val enter_module:
+  scope:int -> ?arg:bool -> string -> module_presence ->
+  module_type -> t -> Ident.t * t
+val enter_module_declaration:
+  scope:int -> ?arg:bool -> string -> module_presence ->
+  module_declaration -> t -> Ident.t * t
+val enter_modtype:
+  scope:int -> string -> modtype_declaration -> t -> Ident.t * t
+val enter_class: scope:int -> string -> class_declaration -> t -> Ident.t * t
+val enter_cltype:
+  scope:int -> string -> class_type_declaration -> t -> Ident.t * t
+
+(* Same as [add_signature] but refreshes (new stamp) and rescopes bound idents
+   in the process. *)
+val enter_signature: scope:int -> signature -> t -> signature * t
+
+val enter_unbound_value : string -> value_unbound_reason -> t -> t
+
+val enter_unbound_module : string -> module_unbound_reason -> t -> t
+
+(* Initialize the cache of in-core module interfaces. *)
+val reset_cache: unit -> unit
+
+(* To be called before each toplevel phrase. *)
+val reset_cache_toplevel: unit -> unit
+
+(* Remember the name of the current compilation unit. *)
+val set_unit_name: string -> unit
+val get_unit_name: unit -> string
+
+(* Read, save a signature to/from a file *)
+val read_signature: modname -> filepath -> signature
+        (* Arguments: module name, file name. Results: signature. *)
+val save_signature:
+  alerts:alerts -> signature -> modname -> filepath
+  -> Cmi_format.cmi_infos
+        (* Arguments: signature, module name, file name. *)
+val save_signature_with_imports:
+  alerts:alerts -> signature -> modname -> filepath -> crcs
+  -> Cmi_format.cmi_infos
+        (* Arguments: signature, module name, file name,
+           imported units with their CRCs. *)
+
+(* Return the CRC of the interface of the given compilation unit *)
+val crc_of_unit: modname -> Digest.t
+
+(* Return the set of compilation units imported, with their CRC *)
+val imports: unit -> crcs
+
+(* may raise Persistent_env.Consistbl.Inconsistency *)
+val import_crcs: source:string -> crcs -> unit
+
+(* [is_imported_opaque md] returns true if [md] is an opaque imported module *)
+val is_imported_opaque: modname -> bool
+
+(* [register_import_as_opaque md] registers [md] as an opaque imported module *)
+val register_import_as_opaque: modname -> unit
+
+(* Summaries -- compact representation of an environment, to be
+   exported in debugging information. *)
+
+val summary: t -> summary
+
+(* Return an equivalent environment where all fields have been reset,
+   except the summary. The initial environment can be rebuilt from the
+   summary, using Envaux.env_of_only_summary. *)
+
+val keep_only_summary : t -> t
+val env_of_only_summary : (summary -> Subst.t -> t) -> t -> t
+
+(* Error report *)
+
+type error =
+  | Missing_module of Location.t * Path.t * Path.t
+  | Illegal_value_name of Location.t * string
+  | Lookup_error of Location.t * t * lookup_error
+
+exception Error of error
+
+open Format
+
+val report_error: formatter -> error -> unit
+
+val report_lookup_error: Location.t -> t -> formatter -> lookup_error -> unit
+
+val in_signature: bool -> t -> t
+
+val is_in_signature: t -> bool
+
+val set_value_used_callback:
+    value_description -> (unit -> unit) -> unit
+val set_type_used_callback:
+    type_declaration -> ((unit -> unit) -> unit) -> unit
+
+(* Forward declaration to break mutual recursion with Includemod. *)
+val check_functor_application:
+      (errors:bool -> loc:Location.t -> t -> module_type ->
+         Path.t -> module_type -> Path.t -> unit) ref
+(* Forward declaration to break mutual recursion with Typemod. *)
+val check_well_formed_module:
+    (t -> Location.t -> string -> module_type -> unit) ref
+(* Forward declaration to break mutual recursion with Typecore. *)
+val add_delayed_check_forward: ((unit -> unit) -> unit) ref
+(* Forward declaration to break mutual recursion with Mtype. *)
+val strengthen:
+    (aliasable:bool -> t -> module_type -> Path.t -> module_type) ref
+(* Forward declaration to break mutual recursion with Ctype. *)
+val same_constr: (t -> type_expr -> type_expr -> bool) ref
+(* Forward declaration to break mutual recursion with Printtyp. *)
+val print_longident: (Format.formatter -> Longident.t -> unit) ref
+(* Forward declaration to break mutual recursion with Printtyp. *)
+val print_path: (Format.formatter -> Path.t -> unit) ref
+
+
+(** Folds *)
+
+val fold_constructors:
+  (constructor_description -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+
+(** Utilities *)
+val scrape_alias: t -> module_type -> module_type
+val check_value_name: string -> Location.t -> unit
+
+val print_address : Format.formatter -> address -> unit
diff --git a/upstream/ocaml_411/typing/ident.ml b/upstream/ocaml_411/typing/ident.ml
new file mode 100644
index 0000000..6296398
--- /dev/null
+++ b/upstream/ocaml_411/typing/ident.ml
@@ -0,0 +1,358 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+let lowest_scope  = 0
+let highest_scope = 100000000
+
+type t =
+  | Local of { name: string; stamp: int }
+  | Scoped of { name: string; stamp: int; scope: int }
+  | Global of string
+  | Predef of { name: string; stamp: int }
+      (* the stamp is here only for fast comparison, but the name of
+         predefined identifiers is always unique. *)
+
+(* A stamp of 0 denotes a persistent identifier *)
+
+let currentstamp = ref 0
+let predefstamp = ref 0
+
+let create_scoped ~scope s =
+  incr currentstamp;
+  Scoped { name = s; stamp = !currentstamp; scope }
+
+let create_local s =
+  incr currentstamp;
+  Local { name = s; stamp = !currentstamp }
+
+let create_predef s =
+  incr predefstamp;
+  Predef { name = s; stamp = !predefstamp }
+
+let create_persistent s =
+  Global s
+
+let name = function
+  | Local { name; _ }
+  | Scoped { name; _ }
+  | Global name
+  | Predef { name; _ } -> name
+
+let rename = function
+  | Local { name; stamp = _ }
+  | Scoped { name; stamp = _; scope = _ } ->
+      incr currentstamp;
+      Local { name; stamp = !currentstamp }
+  | id ->
+      Misc.fatal_errorf "Ident.rename %s" (name id)
+
+let unique_name = function
+  | Local { name; stamp }
+  | Scoped { name; stamp } -> name ^ "_" ^ Int.to_string stamp
+  | Global name ->
+      (* we're adding a fake stamp, because someone could have named his unit
+         [Foo_123] and since we're using unique_name to produce symbol names,
+         we might clash with an ident [Local { "Foo"; 123 }]. *)
+      name ^ "_0"
+  | Predef { name; _ } ->
+      (* we know that none of the predef names (currently) finishes in
+         "_<some number>", and that their name is unique. *)
+      name
+
+let unique_toplevel_name = function
+  | Local { name; stamp }
+  | Scoped { name; stamp } -> name ^ "/" ^ Int.to_string stamp
+  | Global name
+  | Predef { name; _ } -> name
+
+let persistent = function
+  | Global _ -> true
+  | _ -> false
+
+let equal i1 i2 =
+  match i1, i2 with
+  | Local { name = name1; _ }, Local { name = name2; _ }
+  | Scoped { name = name1; _ }, Scoped { name = name2; _ }
+  | Global name1, Global name2 ->
+      name1 = name2
+  | Predef { stamp = s1; _ }, Predef { stamp = s2 } ->
+      (* if they don't have the same stamp, they don't have the same name *)
+      s1 = s2
+  | _ ->
+      false
+
+let same i1 i2 =
+  match i1, i2 with
+  | Local { stamp = s1; _ }, Local { stamp = s2; _ }
+  | Scoped { stamp = s1; _ }, Scoped { stamp = s2; _ }
+  | Predef { stamp = s1; _ }, Predef { stamp = s2 } ->
+      s1 = s2
+  | Global name1, Global name2 ->
+      name1 = name2
+  | _ ->
+      false
+
+let stamp = function
+  | Local { stamp; _ }
+  | Scoped { stamp; _ } -> stamp
+  | _ -> 0
+
+let scope = function
+  | Scoped { scope; _ } -> scope
+  | Local _ -> highest_scope
+  | Global _ | Predef _ -> lowest_scope
+
+let reinit_level = ref (-1)
+
+let reinit () =
+  if !reinit_level < 0
+  then reinit_level := !currentstamp
+  else currentstamp := !reinit_level
+
+let global = function
+  | Local _
+  | Scoped _ -> false
+  | Global _
+  | Predef _ -> true
+
+let is_predef = function
+  | Predef _ -> true
+  | _ -> false
+
+let print ~with_scope ppf =
+  let open Format in
+  function
+  | Global name -> fprintf ppf "%s!" name
+  | Predef { name; stamp = n } ->
+      fprintf ppf "%s%s!" name
+        (if !Clflags.unique_ids then sprintf "/%i" n else "")
+  | Local { name; stamp = n } ->
+      fprintf ppf "%s%s" name
+        (if !Clflags.unique_ids then sprintf "/%i" n else "")
+  | Scoped { name; stamp = n; scope } ->
+      fprintf ppf "%s%s%s" name
+        (if !Clflags.unique_ids then sprintf "/%i" n else "")
+        (if with_scope then sprintf "[%i]" scope else "")
+
+let print_with_scope ppf id = print ~with_scope:true ppf id
+
+let print ppf id = print ~with_scope:false ppf id
+
+type 'a tbl =
+    Empty
+  | Node of 'a tbl * 'a data * 'a tbl * int
+
+and 'a data =
+  { ident: t;
+    data: 'a;
+    previous: 'a data option }
+
+let empty = Empty
+
+(* Inline expansion of height for better speed
+ * let height = function
+ *     Empty -> 0
+ *   | Node(_,_,_,h) -> h
+ *)
+
+let mknode l d r =
+  let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h
+  and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+  Node(l, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+let balance l d r =
+  let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h
+  and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+  if hl > hr + 1 then
+    match l with
+    | Node (ll, ld, lr, _)
+      when (match ll with Empty -> 0 | Node(_,_,_,h) -> h) >=
+           (match lr with Empty -> 0 | Node(_,_,_,h) -> h) ->
+        mknode ll ld (mknode lr d r)
+    | Node (ll, ld, Node(lrl, lrd, lrr, _), _) ->
+        mknode (mknode ll ld lrl) lrd (mknode lrr d r)
+    | _ -> assert false
+  else if hr > hl + 1 then
+    match r with
+    | Node (rl, rd, rr, _)
+      when (match rr with Empty -> 0 | Node(_,_,_,h) -> h) >=
+           (match rl with Empty -> 0 | Node(_,_,_,h) -> h) ->
+        mknode (mknode l d rl) rd rr
+    | Node (Node (rll, rld, rlr, _), rd, rr, _) ->
+        mknode (mknode l d rll) rld (mknode rlr rd rr)
+    | _ -> assert false
+  else
+    mknode l d r
+
+let rec add id data = function
+    Empty ->
+      Node(Empty, {ident = id; data = data; previous = None}, Empty, 1)
+  | Node(l, k, r, h) ->
+      let c = String.compare (name id) (name k.ident) in
+      if c = 0 then
+        Node(l, {ident = id; data = data; previous = Some k}, r, h)
+      else if c < 0 then
+        balance (add id data l) k r
+      else
+        balance l k (add id data r)
+
+let rec min_binding = function
+    Empty -> raise Not_found
+  | Node (Empty, d, _, _) -> d
+  | Node (l, _, _, _) -> min_binding l
+
+let rec remove_min_binding = function
+    Empty -> invalid_arg "Map.remove_min_elt"
+  | Node (Empty, _, r, _) -> r
+  | Node (l, d, r, _) -> balance (remove_min_binding l) d r
+
+let merge t1 t2 =
+  match (t1, t2) with
+    (Empty, t) -> t
+  | (t, Empty) -> t
+  | (_, _) ->
+      let d = min_binding t2 in
+      balance t1 d (remove_min_binding t2)
+
+let rec remove id = function
+    Empty ->
+      Empty
+  | (Node (l, k, r, h) as m) ->
+      let c = String.compare (name id) (name k.ident) in
+      if c = 0 then
+        match k.previous with
+        | None -> merge l r
+        | Some k -> Node (l, k, r, h)
+      else if c < 0 then
+        let ll = remove id l in if l == ll then m else balance ll k r
+      else
+        let rr = remove id r in if r == rr then m else balance l k rr
+
+let rec find_previous id = function
+    None ->
+      raise Not_found
+  | Some k ->
+      if same id k.ident then k.data else find_previous id k.previous
+
+let rec find_same id = function
+    Empty ->
+      raise Not_found
+  | Node(l, k, r, _) ->
+      let c = String.compare (name id) (name k.ident) in
+      if c = 0 then
+        if same id k.ident
+        then k.data
+        else find_previous id k.previous
+      else
+        find_same id (if c < 0 then l else r)
+
+let rec find_name n = function
+    Empty ->
+      raise Not_found
+  | Node(l, k, r, _) ->
+      let c = String.compare n (name k.ident) in
+      if c = 0 then
+        k.ident, k.data
+      else
+        find_name n (if c < 0 then l else r)
+
+let rec get_all = function
+  | None -> []
+  | Some k -> (k.ident, k.data) :: get_all k.previous
+
+let rec find_all n = function
+    Empty ->
+      []
+  | Node(l, k, r, _) ->
+      let c = String.compare n (name k.ident) in
+      if c = 0 then
+        (k.ident, k.data) :: get_all k.previous
+      else
+        find_all n (if c < 0 then l else r)
+
+let rec fold_aux f stack accu = function
+    Empty ->
+      begin match stack with
+        [] -> accu
+      | a :: l -> fold_aux f l accu a
+      end
+  | Node(l, k, r, _) ->
+      fold_aux f (l :: stack) (f k accu) r
+
+let fold_name f tbl accu = fold_aux (fun k -> f k.ident k.data) [] accu tbl
+
+let rec fold_data f d accu =
+  match d with
+    None -> accu
+  | Some k -> f k.ident k.data (fold_data f k.previous accu)
+
+let fold_all f tbl accu =
+  fold_aux (fun k -> fold_data f (Some k)) [] accu tbl
+
+(* let keys tbl = fold_name (fun k _ accu -> k::accu) tbl [] *)
+
+let rec iter f = function
+    Empty -> ()
+  | Node(l, k, r, _) ->
+      iter f l; f k.ident k.data; iter f r
+
+(* Idents for sharing keys *)
+
+(* They should be 'totally fresh' -> neg numbers *)
+let key_name = ""
+
+let make_key_generator () =
+  let c = ref 1 in
+  function
+  | Local _
+  | Scoped _ ->
+      let stamp = !c in
+      decr c ;
+      Local { name = key_name; stamp = stamp }
+  | global_id ->
+      Misc.fatal_errorf "Ident.make_key_generator () %s" (name global_id)
+
+let compare x y =
+  match x, y with
+  | Local x, Local y ->
+      let c = x.stamp - y.stamp in
+      if c <> 0 then c
+      else compare x.name y.name
+  | Local _, _ -> 1
+  | _, Local _ -> (-1)
+  | Scoped x, Scoped y ->
+      let c = x.stamp - y.stamp in
+      if c <> 0 then c
+      else compare x.name y.name
+  | Scoped _, _ -> 1
+  | _, Scoped _ -> (-1)
+  | Global x, Global y -> compare x y
+  | Global _, _ -> 1
+  | _, Global _ -> (-1)
+  | Predef { stamp = s1; _ }, Predef { stamp = s2; _ } -> compare s1 s2
+
+let output oc id = output_string oc (unique_name id)
+let hash i = (Char.code (name i).[0]) lxor (stamp i)
+
+let original_equal = equal
+include Identifiable.Make (struct
+  type nonrec t = t
+  let compare = compare
+  let output = output
+  let print = print
+  let hash = hash
+  let equal = same
+end)
+let equal = original_equal
diff --git a/upstream/ocaml_411/typing/ident.mli b/upstream/ocaml_411/typing/ident.mli
new file mode 100644
index 0000000..65ddb9f
--- /dev/null
+++ b/upstream/ocaml_411/typing/ident.mli
@@ -0,0 +1,80 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Identifiers (unique names) *)
+
+type t
+
+include Identifiable.S with type t := t
+(* Notes:
+   - [equal] compares identifiers by name
+   - [compare x y] is 0 if [same x y] is true.
+   - [compare] compares identifiers by binding location
+*)
+
+val print_with_scope : Format.formatter -> t -> unit
+        (** Same as {!print} except that it will also add a "[n]" suffix
+            if the scope of the argument is [n]. *)
+
+
+val create_scoped: scope:int -> string -> t
+val create_local: string -> t
+val create_persistent: string -> t
+val create_predef: string -> t
+
+val rename: t -> t
+        (** Creates an identifier with the same name as the input, a fresh
+            stamp, and no scope.
+            @raises [Fatal_error] if called on a persistent / predef ident. *)
+
+val name: t -> string
+val unique_name: t -> string
+val unique_toplevel_name: t -> string
+val persistent: t -> bool
+val same: t -> t -> bool
+        (** Compare identifiers by binding location.
+            Two identifiers are the same either if they are both
+            non-persistent and have been created by the same call to
+            [create_*], or if they are both persistent and have the same
+            name. *)
+
+val compare: t -> t -> int
+
+val global: t -> bool
+val is_predef: t -> bool
+
+val scope: t -> int
+
+val lowest_scope : int
+val highest_scope: int
+
+val reinit: unit -> unit
+
+type 'a tbl
+        (* Association tables from identifiers to type 'a. *)
+
+val empty: 'a tbl
+val add: t -> 'a -> 'a tbl -> 'a tbl
+val find_same: t -> 'a tbl -> 'a
+val find_name: string -> 'a tbl -> t * 'a
+val find_all: string -> 'a tbl -> (t * 'a) list
+val fold_name: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b
+val fold_all: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b
+val iter: (t -> 'a -> unit) -> 'a tbl -> unit
+val remove: t -> 'a tbl -> 'a tbl
+
+(* Idents for sharing keys *)
+
+val make_key_generator : unit -> (t -> t)
diff --git a/upstream/ocaml_411/typing/includeclass.ml b/upstream/ocaml_411/typing/includeclass.ml
new file mode 100644
index 0000000..483088d
--- /dev/null
+++ b/upstream/ocaml_411/typing/includeclass.ml
@@ -0,0 +1,116 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Jerome Vouillon, projet Cristal, INRIA Rocquencourt          *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the class language *)
+
+open Types
+
+let class_types env cty1 cty2 =
+  Ctype.match_class_types env cty1 cty2
+
+let class_type_declarations ~loc env cty1 cty2 =
+  Builtin_attributes.check_alerts_inclusion
+    ~def:cty1.clty_loc
+    ~use:cty2.clty_loc
+    loc
+    cty1.clty_attributes cty2.clty_attributes
+    (Path.last cty1.clty_path);
+  Ctype.match_class_declarations env
+    cty1.clty_params cty1.clty_type
+    cty2.clty_params cty2.clty_type
+
+let class_declarations env cty1 cty2 =
+  match cty1.cty_new, cty2.cty_new with
+    None, Some _ ->
+      [Ctype.CM_Virtual_class]
+  | _ ->
+      Ctype.match_class_declarations env
+        cty1.cty_params cty1.cty_type
+        cty2.cty_params cty2.cty_type
+
+open Format
+open Ctype
+
+(*
+let rec hide_params = function
+    Tcty_arrow ("*", _, cty) -> hide_params cty
+  | cty -> cty
+*)
+
+let include_err ppf =
+  function
+  | CM_Virtual_class ->
+      fprintf ppf "A class cannot be changed from virtual to concrete"
+  | CM_Parameter_arity_mismatch _ ->
+      fprintf ppf
+        "The classes do not have the same number of type parameters"
+  | CM_Type_parameter_mismatch (env, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+          fprintf ppf "A type parameter has type")
+        (function ppf ->
+          fprintf ppf "but is expected to have type")
+  | CM_Class_type_mismatch (env, cty1, cty2) ->
+      Printtyp.wrap_printing_env ~error:true env (fun () ->
+        fprintf ppf
+          "@[The class type@;<1 2>%a@ %s@;<1 2>%a@]"
+          Printtyp.class_type cty1
+          "is not matched by the class type"
+          Printtyp.class_type cty2)
+  | CM_Parameter_mismatch (env, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+          fprintf ppf "A parameter has type")
+        (function ppf ->
+          fprintf ppf "but is expected to have type")
+  | CM_Val_type_mismatch (lab, env, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+          fprintf ppf "The instance variable %s@ has type" lab)
+        (function ppf ->
+          fprintf ppf "but is expected to have type")
+  | CM_Meth_type_mismatch (lab, env, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+          fprintf ppf "The method %s@ has type" lab)
+        (function ppf ->
+          fprintf ppf "but is expected to have type")
+  | CM_Non_mutable_value lab ->
+      fprintf ppf
+       "@[The non-mutable instance variable %s cannot become mutable@]" lab
+  | CM_Non_concrete_value lab ->
+      fprintf ppf
+       "@[The virtual instance variable %s cannot become concrete@]" lab
+  | CM_Missing_value lab ->
+      fprintf ppf "@[The first class type has no instance variable %s@]" lab
+  | CM_Missing_method lab ->
+      fprintf ppf "@[The first class type has no method %s@]" lab
+  | CM_Hide_public lab ->
+     fprintf ppf "@[The public method %s cannot be hidden@]" lab
+  | CM_Hide_virtual (k, lab) ->
+      fprintf ppf "@[The virtual %s %s cannot be hidden@]" k lab
+  | CM_Public_method lab ->
+      fprintf ppf "@[The public method %s cannot become private@]" lab
+  | CM_Virtual_method lab ->
+      fprintf ppf "@[The virtual method %s cannot become concrete@]" lab
+  | CM_Private_method lab ->
+      fprintf ppf "@[The private method %s cannot become public@]" lab
+
+let report_error ppf = function
+  |  [] -> ()
+  | err :: errs ->
+      let print_errs ppf errs =
+         List.iter (fun err -> fprintf ppf "@ %a" include_err err) errs in
+      fprintf ppf "@[<v>%a%a@]" include_err err print_errs errs
diff --git a/upstream/ocaml_411/typing/includeclass.mli b/upstream/ocaml_411/typing/includeclass.mli
new file mode 100644
index 0000000..ebfa978
--- /dev/null
+++ b/upstream/ocaml_411/typing/includeclass.mli
@@ -0,0 +1,32 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Jerome Vouillon, projet Cristal, INRIA Rocquencourt          *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the class language *)
+
+open Types
+open Ctype
+open Format
+
+val class_types:
+        Env.t -> class_type -> class_type -> class_match_failure list
+val class_type_declarations:
+  loc:Location.t ->
+  Env.t -> class_type_declaration -> class_type_declaration ->
+  class_match_failure list
+val class_declarations:
+  Env.t -> class_declaration -> class_declaration ->
+  class_match_failure list
+
+val report_error: formatter -> class_match_failure list -> unit
diff --git a/upstream/ocaml_411/typing/includecore.ml b/upstream/ocaml_411/typing/includecore.ml
new file mode 100644
index 0000000..5325d97
--- /dev/null
+++ b/upstream/ocaml_411/typing/includecore.ml
@@ -0,0 +1,508 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the core language *)
+
+open Asttypes
+open Path
+open Types
+open Typedtree
+
+(* Inclusion between value descriptions *)
+
+exception Dont_match
+
+let value_descriptions ~loc env name
+    (vd1 : Types.value_description)
+    (vd2 : Types.value_description) =
+  Builtin_attributes.check_alerts_inclusion
+    ~def:vd1.val_loc
+    ~use:vd2.val_loc
+    loc
+    vd1.val_attributes vd2.val_attributes
+    name;
+  if Ctype.moregeneral env true vd1.val_type vd2.val_type then begin
+    match (vd1.val_kind, vd2.val_kind) with
+        (Val_prim p1, Val_prim p2) ->
+          if p1 = p2 then Tcoerce_none else raise Dont_match
+      | (Val_prim p, _) ->
+          let pc = {pc_desc = p; pc_type = vd2.Types.val_type;
+                  pc_env = env; pc_loc = vd1.Types.val_loc; } in
+          Tcoerce_primitive pc
+      | (_, Val_prim _) -> raise Dont_match
+      | (_, _) -> Tcoerce_none
+  end else
+    raise Dont_match
+
+(* Inclusion between "private" annotations *)
+
+let private_flags decl1 decl2 =
+  match decl1.type_private, decl2.type_private with
+  | Private, Public ->
+      decl2.type_kind = Type_abstract &&
+      (decl2.type_manifest = None || decl1.type_kind <> Type_abstract)
+  | _, _ -> true
+
+(* Inclusion between manifest types (particularly for private row types) *)
+
+let is_absrow env ty =
+  match ty.desc with
+    Tconstr(Pident _, _, _) ->
+      begin match Ctype.expand_head env ty with
+        {desc=Tobject _|Tvariant _} -> true
+      | _ -> false
+      end
+  | _ -> false
+
+let type_manifest env ty1 params1 ty2 params2 priv2 =
+  let ty1' = Ctype.expand_head env ty1 and ty2' = Ctype.expand_head env ty2 in
+  match ty1'.desc, ty2'.desc with
+    Tvariant row1, Tvariant row2 when is_absrow env (Btype.row_more row2) ->
+      let row1 = Btype.row_repr row1 and row2 = Btype.row_repr row2 in
+      Ctype.equal env true (ty1::params1) (row2.row_more::params2) &&
+      begin match row1.row_more with
+        {desc=Tvar _|Tconstr _|Tnil} -> true
+      | _ -> false
+      end &&
+      let r1, r2, pairs =
+        Ctype.merge_row_fields row1.row_fields row2.row_fields in
+      (not row2.row_closed ||
+       row1.row_closed && Ctype.filter_row_fields false r1 = []) &&
+      List.for_all
+        (fun (_,f) -> match Btype.row_field_repr f with
+          Rabsent | Reither _ -> true | Rpresent _ -> false)
+        r2 &&
+      let to_equal = ref (List.combine params1 params2) in
+      List.for_all
+        (fun (_, f1, f2) ->
+          match Btype.row_field_repr f1, Btype.row_field_repr f2 with
+            Rpresent(Some t1),
+            (Rpresent(Some t2) | Reither(false, [t2], _, _)) ->
+              to_equal := (t1,t2) :: !to_equal; true
+          | Rpresent None, (Rpresent None | Reither(true, [], _, _)) -> true
+          | Reither(c1,tl1,_,_), Reither(c2,tl2,_,_)
+            when List.length tl1 = List.length tl2 && c1 = c2 ->
+              to_equal := List.combine tl1 tl2 @ !to_equal; true
+          | Rabsent, (Reither _ | Rabsent) -> true
+          | _ -> false)
+        pairs &&
+      let tl1, tl2 = List.split !to_equal in
+      Ctype.equal env true tl1 tl2
+  | Tobject (fi1, _), Tobject (fi2, _)
+    when is_absrow env (snd(Ctype.flatten_fields fi2)) ->
+      let (fields2,rest2) = Ctype.flatten_fields fi2 in
+      Ctype.equal env true (ty1::params1) (rest2::params2) &&
+      let (fields1,rest1) = Ctype.flatten_fields fi1 in
+      (match rest1 with {desc=Tnil|Tvar _|Tconstr _} -> true | _ -> false) &&
+      let pairs, _miss1, miss2 = Ctype.associate_fields fields1 fields2 in
+      miss2 = [] &&
+      let tl1, tl2 =
+        List.split (List.map (fun (_,_,t1,_,t2) -> t1, t2) pairs) in
+      Ctype.equal env true (params1 @ tl1) (params2 @ tl2)
+  | _ ->
+      let rec check_super ty1 =
+        Ctype.equal env true (ty1 :: params1) (ty2 :: params2) ||
+        priv2 = Private &&
+        try check_super
+              (Ctype.try_expand_once_opt env (Ctype.expand_head env ty1))
+        with Ctype.Cannot_expand -> false
+      in check_super ty1
+
+(* Inclusion between type declarations *)
+
+type position = Ctype.Unification_trace.position = First | Second
+
+let choose ord first second =
+  match ord with
+  | First -> first
+  | Second -> second
+
+let choose_other ord first second =
+  match ord with
+  | First -> choose Second first second
+  | Second -> choose First first second
+
+type label_mismatch =
+  | Type
+  | Mutability of position
+
+type record_mismatch =
+  | Label_mismatch of Types.label_declaration
+                      * Types.label_declaration
+                      * label_mismatch
+  | Label_names of int * Ident.t * Ident.t
+  | Label_missing of position * Ident.t
+  | Unboxed_float_representation of position
+
+type constructor_mismatch =
+  | Type
+  | Arity
+  | Inline_record of record_mismatch
+  | Kind of position
+  | Explicit_return_type of position
+
+type variant_mismatch =
+  | Constructor_mismatch of Types.constructor_declaration
+                            * Types.constructor_declaration
+                            * constructor_mismatch
+  | Constructor_names of int * Ident.t * Ident.t
+  | Constructor_missing of position * Ident.t
+
+type extension_constructor_mismatch =
+  | Constructor_privacy
+  | Constructor_mismatch of Ident.t
+                            * Types.extension_constructor
+                            * Types.extension_constructor
+                            * constructor_mismatch
+
+type type_mismatch =
+  | Arity
+  | Privacy
+  | Kind
+  | Constraint
+  | Manifest
+  | Variance
+  | Record_mismatch of record_mismatch
+  | Variant_mismatch of variant_mismatch
+  | Unboxed_representation of position
+  | Immediate of Type_immediacy.Violation.t
+
+let report_label_mismatch first second ppf err =
+  let pr fmt = Format.fprintf ppf fmt in
+  match (err : label_mismatch) with
+  | Type -> pr "The types are not equal."
+  | Mutability ord ->
+      pr "%s is mutable and %s is not."
+        (String.capitalize_ascii  (choose ord first second))
+        (choose_other ord first second)
+
+let report_record_mismatch first second decl ppf err =
+  let pr fmt = Format.fprintf ppf fmt in
+  match err with
+  | Label_mismatch (l1, l2, err) ->
+      pr
+        "@[<hv>Fields do not match:@;<1 2>%a@ is not compatible with:\
+         @;<1 2>%a@ %a"
+        Printtyp.label l1
+        Printtyp.label l2
+        (report_label_mismatch first second) err
+  | Label_names (n, name1, name2) ->
+      pr "@[<hv>Fields number %i have different names, %s and %s.@]"
+        n (Ident.name name1) (Ident.name name2)
+  | Label_missing (ord, s) ->
+      pr "@[<hv>The field %s is only present in %s %s.@]"
+        (Ident.name s) (choose ord first second) decl
+  | Unboxed_float_representation ord ->
+      pr "@[<hv>Their internal representations differ:@ %s %s %s.@]"
+        (choose ord first second) decl
+        "uses unboxed float representation"
+
+let report_constructor_mismatch first second decl ppf err =
+  let pr fmt  = Format.fprintf ppf fmt in
+  match (err : constructor_mismatch) with
+  | Type -> pr "The types are not equal."
+  | Arity -> pr "They have different arities."
+  | Inline_record err -> report_record_mismatch first second decl ppf err
+  | Kind ord ->
+      pr "%s uses inline records and %s doesn't."
+        (String.capitalize_ascii (choose ord first second))
+        (choose_other ord first second)
+  | Explicit_return_type ord ->
+      pr "%s has explicit return type and %s doesn't."
+        (String.capitalize_ascii (choose ord first second))
+        (choose_other ord first second)
+
+let report_variant_mismatch first second decl ppf err =
+  let pr fmt = Format.fprintf ppf fmt in
+  match (err : variant_mismatch) with
+  | Constructor_mismatch (c1, c2, err) ->
+      pr
+        "@[<hv>Constructors do not match:@;<1 2>%a@ is not compatible with:\
+         @;<1 2>%a@ %a"
+        Printtyp.constructor c1
+        Printtyp.constructor c2
+        (report_constructor_mismatch first second decl) err
+  | Constructor_names (n, name1, name2) ->
+      pr "Constructors number %i have different names, %s and %s."
+        n (Ident.name name1) (Ident.name name2)
+  | Constructor_missing (ord, s) ->
+      pr "The constructor %s is only present in %s %s."
+        (Ident.name s) (choose ord first second) decl
+
+let report_extension_constructor_mismatch first second decl ppf err =
+  let pr fmt = Format.fprintf ppf fmt in
+  match (err : extension_constructor_mismatch) with
+  | Constructor_privacy -> pr "A private type would be revealed."
+  | Constructor_mismatch (id, ext1, ext2, err) ->
+      pr "@[<hv>Constructors do not match:@;<1 2>%a@ is not compatible with:\
+          @;<1 2>%a@ %a@]"
+        (Printtyp.extension_only_constructor id) ext1
+        (Printtyp.extension_only_constructor id) ext2
+        (report_constructor_mismatch first second decl) err
+
+let report_type_mismatch0 first second decl ppf err =
+  let pr fmt = Format.fprintf ppf fmt in
+  match err with
+  | Arity -> pr "They have different arities."
+  | Privacy -> pr "A private type would be revealed."
+  | Kind -> pr "Their kinds differ."
+  | Constraint -> pr "Their constraints differ."
+  | Manifest -> ()
+  | Variance -> pr "Their variances do not agree."
+  | Record_mismatch err -> report_record_mismatch first second decl ppf err
+  | Variant_mismatch err -> report_variant_mismatch first second decl ppf err
+  | Unboxed_representation ord ->
+      pr "Their internal representations differ:@ %s %s %s."
+         (choose ord first second) decl
+         "uses unboxed representation"
+  | Immediate violation ->
+      let first = StringLabels.capitalize_ascii first in
+      match violation with
+      | Type_immediacy.Violation.Not_always_immediate ->
+          pr "%s is not an immediate type." first
+      | Type_immediacy.Violation.Not_always_immediate_on_64bits ->
+          pr "%s is not a type that is always immediate on 64 bit platforms."
+            first
+
+let report_type_mismatch first second decl ppf err =
+  if err = Manifest then () else
+  Format.fprintf ppf "@ %a" (report_type_mismatch0 first second decl) err
+
+let rec compare_constructor_arguments ~loc env params1 params2 arg1 arg2 =
+  match arg1, arg2 with
+  | Types.Cstr_tuple arg1, Types.Cstr_tuple arg2 ->
+      if List.length arg1 <> List.length arg2 then
+        Some (Arity : constructor_mismatch)
+      else if
+        (* Ctype.equal must be called on all arguments at once, cf. PR#7378 *)
+        Ctype.equal env true (params1 @ arg1) (params2 @ arg2)
+      then None else Some Type
+  | Types.Cstr_record l1, Types.Cstr_record l2 ->
+      Option.map
+        (fun rec_err -> Inline_record rec_err)
+        (compare_records env ~loc params1 params2 0 l1 l2)
+  | Types.Cstr_record _, _ -> Some (Kind First : constructor_mismatch)
+  | _, Types.Cstr_record _ -> Some (Kind Second : constructor_mismatch)
+
+and compare_constructors ~loc env params1 params2 res1 res2 args1 args2 =
+  match res1, res2 with
+  | Some r1, Some r2 ->
+      if Ctype.equal env true [r1] [r2] then
+        compare_constructor_arguments ~loc env [r1] [r2] args1 args2
+      else Some Type
+  | Some _, None -> Some (Explicit_return_type First)
+  | None, Some _ -> Some (Explicit_return_type Second)
+  | None, None ->
+      compare_constructor_arguments ~loc env params1 params2 args1 args2
+
+and compare_variants ~loc env params1 params2 n
+    (cstrs1 : Types.constructor_declaration list)
+    (cstrs2 : Types.constructor_declaration list) =
+  match cstrs1, cstrs2 with
+  | [], []   -> None
+  | [], c::_ -> Some (Constructor_missing (Second, c.Types.cd_id))
+  | c::_, [] -> Some (Constructor_missing (First, c.Types.cd_id))
+  | cd1::rem1, cd2::rem2 ->
+      if Ident.name cd1.cd_id <> Ident.name cd2.cd_id then
+        Some (Constructor_names (n, cd1.cd_id, cd2.cd_id))
+      else begin
+        Builtin_attributes.check_alerts_inclusion
+          ~def:cd1.cd_loc
+          ~use:cd2.cd_loc
+          loc
+          cd1.cd_attributes cd2.cd_attributes
+          (Ident.name cd1.cd_id);
+        match compare_constructors ~loc env params1 params2
+                cd1.cd_res cd2.cd_res cd1.cd_args cd2.cd_args with
+        | Some r ->
+            Some ((Constructor_mismatch (cd1, cd2, r)) : variant_mismatch)
+        | None -> compare_variants ~loc env params1 params2 (n+1) rem1 rem2
+      end
+
+and compare_labels env params1 params2
+      (ld1 : Types.label_declaration)
+      (ld2 : Types.label_declaration) =
+      if ld1.ld_mutable <> ld2.ld_mutable
+      then
+        let ord = if ld1.ld_mutable = Asttypes.Mutable then First else Second in
+        Some (Mutability  ord)
+      else
+        if Ctype.equal env true (ld1.ld_type::params1) (ld2.ld_type::params2)
+        then None
+        else Some (Type : label_mismatch)
+
+and compare_records ~loc env params1 params2 n
+    (labels1 : Types.label_declaration list)
+    (labels2 : Types.label_declaration list) =
+  match labels1, labels2 with
+  | [], []           -> None
+  | [], l::_ -> Some (Label_missing (Second, l.Types.ld_id))
+  | l::_, [] -> Some (Label_missing (First, l.Types.ld_id))
+  | ld1::rem1, ld2::rem2 ->
+      if Ident.name ld1.ld_id <> Ident.name ld2.ld_id
+      then Some (Label_names (n, ld1.ld_id, ld2.ld_id))
+      else begin
+        Builtin_attributes.check_deprecated_mutable_inclusion
+          ~def:ld1.ld_loc
+          ~use:ld2.ld_loc
+          loc
+          ld1.ld_attributes ld2.ld_attributes
+          (Ident.name ld1.ld_id);
+        match compare_labels env params1 params2 ld1 ld2 with
+        | Some r -> Some (Label_mismatch (ld1, ld2, r))
+        (* add arguments to the parameters, cf. PR#7378 *)
+        | None -> compare_records ~loc env
+                    (ld1.ld_type::params1) (ld2.ld_type::params2)
+                    (n+1)
+                    rem1 rem2
+      end
+
+let compare_records_with_representation ~loc env params1 params2 n
+      labels1 labels2 rep1 rep2
+  =
+  match compare_records ~loc env params1 params2 n labels1 labels2 with
+  | None when rep1 <> rep2 ->
+      let pos = if rep2 = Record_float then Second else First in
+      Some (Unboxed_float_representation pos)
+  | err -> err
+
+let type_declarations ?(equality = false) ~loc env ~mark name
+      decl1 path decl2 =
+  Builtin_attributes.check_alerts_inclusion
+    ~def:decl1.type_loc
+    ~use:decl2.type_loc
+    loc
+    decl1.type_attributes decl2.type_attributes
+    name;
+  if decl1.type_arity <> decl2.type_arity then Some Arity else
+  if not (private_flags decl1 decl2) then Some Privacy else
+  let err = match (decl1.type_manifest, decl2.type_manifest) with
+      (_, None) ->
+        if Ctype.equal env true decl1.type_params decl2.type_params
+        then None else Some Constraint
+    | (Some ty1, Some ty2) ->
+        if type_manifest env ty1 decl1.type_params ty2 decl2.type_params
+            decl2.type_private
+        then None else Some Manifest
+    | (None, Some ty2) ->
+        let ty1 =
+          Btype.newgenty (Tconstr(path, decl2.type_params, ref Mnil))
+        in
+        if Ctype.equal env true decl1.type_params decl2.type_params then
+          if Ctype.equal env false [ty1] [ty2] then None
+          else Some Manifest
+        else Some Constraint
+  in
+  if err <> None then err else
+  let err =
+    match (decl2.type_kind, decl1.type_unboxed.unboxed,
+           decl2.type_unboxed.unboxed) with
+    | Type_abstract, _, _ -> None
+    | _, true, false -> Some (Unboxed_representation First)
+    | _, false, true -> Some (Unboxed_representation Second)
+    | _ -> None
+  in
+  if err <> None then err else
+  let err = match (decl1.type_kind, decl2.type_kind) with
+      (_, Type_abstract) -> None
+    | (Type_variant cstrs1, Type_variant cstrs2) ->
+        if mark then begin
+          let mark usage cstrs =
+            List.iter (Env.mark_constructor_used usage) cstrs
+          in
+          let usage =
+            if decl2.type_private = Public then Env.Positive
+            else Env.Privatize
+          in
+          mark usage cstrs1;
+          if equality then mark Env.Positive cstrs2
+        end;
+        Option.map
+          (fun var_err -> Variant_mismatch var_err)
+          (compare_variants ~loc env decl1.type_params decl2.type_params 1
+             cstrs1 cstrs2)
+    | (Type_record(labels1,rep1), Type_record(labels2,rep2)) ->
+        Option.map (fun rec_err -> Record_mismatch rec_err)
+          (compare_records_with_representation ~loc env
+             decl1.type_params decl2.type_params 1
+             labels1 labels2
+             rep1 rep2)
+    | (Type_open, Type_open) -> None
+    | (_, _) -> Some Kind
+  in
+  if err <> None then err else
+  let abstr = decl2.type_kind = Type_abstract && decl2.type_manifest = None in
+  (* If attempt to assign a non-immediate type (e.g. string) to a type that
+   * must be immediate, then we error *)
+  let err =
+    if not abstr then
+      None
+    else
+      match
+        Type_immediacy.coerce decl1.type_immediate ~as_:decl2.type_immediate
+      with
+      | Ok () -> None
+      | Error violation -> Some (Immediate violation)
+  in
+  if err <> None then err else
+  let need_variance =
+    abstr || decl1.type_private = Private || decl1.type_kind = Type_open in
+  if not need_variance then None else
+  let abstr = abstr || decl2.type_private = Private in
+  let opn = decl2.type_kind = Type_open && decl2.type_manifest = None in
+  let constrained ty = not (Btype.(is_Tvar (repr ty))) in
+  if List.for_all2
+      (fun ty (v1,v2) ->
+        let open Variance in
+        let imp a b = not a || b in
+        let (co1,cn1) = get_upper v1 and (co2,cn2) = get_upper v2 in
+        (if abstr then (imp co1 co2 && imp cn1 cn2)
+         else if opn || constrained ty then (co1 = co2 && cn1 = cn2)
+         else true) &&
+        let (p1,n1,i1,j1) = get_lower v1 and (p2,n2,i2,j2) = get_lower v2 in
+        imp abstr (imp p2 p1 && imp n2 n1 && imp i2 i1 && imp j2 j1))
+      decl2.type_params (List.combine decl1.type_variance decl2.type_variance)
+  then None else Some Variance
+
+(* Inclusion between extension constructors *)
+
+let extension_constructors ~loc env ~mark id ext1 ext2 =
+  if mark then begin
+    let usage =
+      if ext2.ext_private = Public then Env.Positive
+      else Env.Privatize
+    in
+    Env.mark_extension_used usage ext1
+  end;
+  let ty1 =
+    Btype.newgenty (Tconstr(ext1.ext_type_path, ext1.ext_type_params, ref Mnil))
+  in
+  let ty2 =
+    Btype.newgenty (Tconstr(ext2.ext_type_path, ext2.ext_type_params, ref Mnil))
+  in
+  if not (Ctype.equal env true (ty1 :: ext1.ext_type_params)
+                               (ty2 :: ext2.ext_type_params))
+  then Some (Constructor_mismatch (id, ext1, ext2, Type))
+  else
+    let r =
+      compare_constructors ~loc env ext1.ext_type_params ext2.ext_type_params
+        ext1.ext_ret_type ext2.ext_ret_type
+        ext1.ext_args ext2.ext_args
+    in
+    match r with
+    | Some r -> Some (Constructor_mismatch (id, ext1, ext2, r))
+    | None -> match ext1.ext_private, ext2.ext_private with
+        Private, Public -> Some Constructor_privacy
+      | _, _ -> None
diff --git a/upstream/ocaml_411/typing/includecore.mli b/upstream/ocaml_411/typing/includecore.mli
new file mode 100644
index 0000000..560d0ac
--- /dev/null
+++ b/upstream/ocaml_411/typing/includecore.mli
@@ -0,0 +1,90 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the core language *)
+
+open Typedtree
+open Types
+
+exception Dont_match
+
+type position = Ctype.Unification_trace.position = First | Second
+
+type label_mismatch =
+  | Type
+  | Mutability of position
+
+type record_mismatch =
+  | Label_mismatch of label_declaration * label_declaration * label_mismatch
+  | Label_names of int * Ident.t * Ident.t
+  | Label_missing of position * Ident.t
+  | Unboxed_float_representation of position
+
+type constructor_mismatch =
+  | Type
+  | Arity
+  | Inline_record of record_mismatch
+  | Kind of position
+  | Explicit_return_type of position
+
+type variant_mismatch =
+  | Constructor_mismatch of constructor_declaration
+                            * constructor_declaration
+                            * constructor_mismatch
+  | Constructor_names of int * Ident.t * Ident.t
+  | Constructor_missing of position * Ident.t
+
+type extension_constructor_mismatch =
+  | Constructor_privacy
+  | Constructor_mismatch of Ident.t
+                            * extension_constructor
+                            * extension_constructor
+                            * constructor_mismatch
+
+type type_mismatch =
+  | Arity
+  | Privacy
+  | Kind
+  | Constraint
+  | Manifest
+  | Variance
+  | Record_mismatch of record_mismatch
+  | Variant_mismatch of variant_mismatch
+  | Unboxed_representation of position
+  | Immediate of Type_immediacy.Violation.t
+
+val value_descriptions:
+  loc:Location.t -> Env.t -> string ->
+  value_description -> value_description -> module_coercion
+
+val type_declarations:
+  ?equality:bool ->
+  loc:Location.t ->
+  Env.t -> mark:bool -> string ->
+  type_declaration -> Path.t -> type_declaration -> type_mismatch option
+
+val extension_constructors:
+  loc:Location.t -> Env.t -> mark:bool -> Ident.t ->
+  extension_constructor -> extension_constructor ->
+  extension_constructor_mismatch option
+(*
+val class_types:
+        Env.t -> class_type -> class_type -> bool
+*)
+
+val report_type_mismatch:
+    string -> string -> string -> Format.formatter -> type_mismatch -> unit
+val report_extension_constructor_mismatch: string -> string -> string ->
+  Format.formatter -> extension_constructor_mismatch -> unit
diff --git a/upstream/ocaml_411/typing/includemod.ml b/upstream/ocaml_411/typing/includemod.ml
new file mode 100644
index 0000000..e2e63ec
--- /dev/null
+++ b/upstream/ocaml_411/typing/includemod.ml
@@ -0,0 +1,896 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the module language *)
+
+open Misc
+open Typedtree
+open Types
+
+type symptom =
+    Missing_field of Ident.t * Location.t * string (* kind *)
+  | Value_descriptions of Ident.t * value_description * value_description
+  | Type_declarations of Ident.t * type_declaration
+        * type_declaration * Includecore.type_mismatch
+  | Extension_constructors of Ident.t * extension_constructor
+        * extension_constructor * Includecore.extension_constructor_mismatch
+  | Module_types of module_type * module_type
+  | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration
+  | Modtype_permutation of Types.module_type * Typedtree.module_coercion
+  | Interface_mismatch of string * string
+  | Class_type_declarations of
+      Ident.t * class_type_declaration * class_type_declaration *
+      Ctype.class_match_failure list
+  | Class_declarations of
+      Ident.t * class_declaration * class_declaration *
+      Ctype.class_match_failure list
+  | Unbound_modtype_path of Path.t
+  | Unbound_module_path of Path.t
+  | Invalid_module_alias of Path.t
+
+type pos =
+  | Module of Ident.t
+  | Modtype of Ident.t
+  | Arg of functor_parameter
+  | Body of functor_parameter
+type error = pos list * Env.t * symptom
+
+exception Error of error list
+exception Apply_error of Location.t * Path.t * Path.t * error list
+
+type mark =
+  | Mark_both
+  | Mark_positive
+  | Mark_negative
+  | Mark_neither
+
+let negate_mark = function
+  | Mark_both -> Mark_both
+  | Mark_positive -> Mark_negative
+  | Mark_negative -> Mark_positive
+  | Mark_neither -> Mark_neither
+
+let mark_positive = function
+  | Mark_both | Mark_positive -> true
+  | Mark_negative | Mark_neither -> false
+
+(* All functions "blah env x1 x2" check that x1 is included in x2,
+   i.e. that x1 is the type of an implementation that fulfills the
+   specification x2. If not, Error is raised with a backtrace of the error. *)
+
+(* Inclusion between value descriptions *)
+
+let value_descriptions ~loc env ~mark cxt subst id vd1 vd2 =
+  Cmt_format.record_value_dependency vd1 vd2;
+  if mark_positive mark then
+    Env.mark_value_used vd1.val_uid;
+  let vd2 = Subst.value_description subst vd2 in
+  try
+    Includecore.value_descriptions ~loc env (Ident.name id) vd1 vd2
+  with Includecore.Dont_match ->
+    raise(Error[cxt, env, Value_descriptions(id, vd1, vd2)])
+
+(* Inclusion between type declarations *)
+
+let type_declarations ~loc env ~mark ?old_env:_ cxt subst id decl1 decl2 =
+  let mark = mark_positive mark in
+  if mark then
+    Env.mark_type_used decl1.type_uid;
+  let decl2 = Subst.type_declaration subst decl2 in
+  match
+    Includecore.type_declarations ~loc env ~mark
+      (Ident.name id) decl1 (Path.Pident id) decl2
+  with
+  | None -> ()
+  | Some err ->
+      raise(Error[cxt, env, Type_declarations(id, decl1, decl2, err)])
+
+(* Inclusion between extension constructors *)
+
+let extension_constructors ~loc env ~mark cxt subst id ext1 ext2 =
+  let mark = mark_positive mark in
+  let ext2 = Subst.extension_constructor subst ext2 in
+  match Includecore.extension_constructors ~loc env ~mark id ext1 ext2 with
+  | None -> ()
+  | Some err ->
+      raise(Error[cxt, env, Extension_constructors(id, ext1, ext2, err)])
+
+(* Inclusion between class declarations *)
+
+let class_type_declarations ~loc ~old_env:_ env cxt subst id decl1 decl2 =
+  let decl2 = Subst.cltype_declaration subst decl2 in
+  match Includeclass.class_type_declarations ~loc env decl1 decl2 with
+    []     -> ()
+  | reason ->
+      raise(Error[cxt, env,
+                  Class_type_declarations(id, decl1, decl2, reason)])
+
+let class_declarations ~old_env:_ env cxt subst id decl1 decl2 =
+  let decl2 = Subst.class_declaration subst decl2 in
+  match Includeclass.class_declarations env decl1 decl2 with
+    []     -> ()
+  | reason ->
+      raise(Error[cxt, env, Class_declarations(id, decl1, decl2, reason)])
+
+(* Expand a module type identifier when possible *)
+
+exception Dont_match
+
+let try_expand_modtype_path env path =
+  try
+    Env.find_modtype_expansion path env
+  with Not_found -> raise Dont_match
+
+let expand_module_alias env cxt path =
+  try (Env.find_module path env).md_type
+  with Not_found ->
+    raise(Error[cxt, env, Unbound_module_path path])
+
+(* Extract name, kind and ident from a signature item *)
+
+type field_desc =
+    Field_value of string
+  | Field_type of string
+  | Field_exception of string
+  | Field_typext of string
+  | Field_module of string
+  | Field_modtype of string
+  | Field_class of string
+  | Field_classtype of string
+
+let kind_of_field_desc = function
+  | Field_value _ -> "value"
+  | Field_type _ -> "type"
+  | Field_exception _ -> "exception"
+  | Field_typext _ -> "extension constructor"
+  | Field_module _ -> "module"
+  | Field_modtype _ -> "module type"
+  | Field_class _ -> "class"
+  | Field_classtype _ -> "class type"
+
+(** Map indexed by both field types and names.
+    This avoids name clashes between different sorts of fields
+    such as values and types. *)
+module FieldMap = Map.Make(struct
+    type t = field_desc
+    let compare = Stdlib.compare
+  end)
+
+let item_ident_name = function
+    Sig_value(id, d, _) -> (id, d.val_loc, Field_value(Ident.name id))
+  | Sig_type(id, d, _, _) -> (id, d.type_loc, Field_type(Ident.name id))
+  | Sig_typext(id, d, _, _) ->
+     let kind =
+       if Path.same d.ext_type_path Predef.path_exn
+       then Field_exception(Ident.name id)
+       else Field_typext(Ident.name id)
+     in
+     (id, d.ext_loc, kind)
+  | Sig_module(id, _, d, _, _) -> (id, d.md_loc, Field_module(Ident.name id))
+  | Sig_modtype(id, d, _) -> (id, d.mtd_loc, Field_modtype(Ident.name id))
+  | Sig_class(id, d, _, _) -> (id, d.cty_loc, Field_class(Ident.name id))
+  | Sig_class_type(id, d, _, _) ->
+      (id, d.clty_loc, Field_classtype(Ident.name id))
+
+let is_runtime_component = function
+  | Sig_value(_,{val_kind = Val_prim _}, _)
+  | Sig_type(_,_,_,_)
+  | Sig_module(_,Mp_absent,_,_,_)
+  | Sig_modtype(_,_,_)
+  | Sig_class_type(_,_,_,_) -> false
+  | Sig_value(_,_,_)
+  | Sig_typext(_,_,_,_)
+  | Sig_module(_,Mp_present,_,_,_)
+  | Sig_class(_,_,_,_) -> true
+
+(* Print a coercion *)
+
+let rec print_list pr ppf = function
+    [] -> ()
+  | [a] -> pr ppf a
+  | a :: l -> pr ppf a; Format.fprintf ppf ";@ "; print_list pr ppf l
+let print_list pr ppf l =
+  Format.fprintf ppf "[@[%a@]]" (print_list pr) l
+
+let rec print_coercion ppf c =
+  let pr fmt = Format.fprintf ppf fmt in
+  match c with
+    Tcoerce_none -> pr "id"
+  | Tcoerce_structure (fl, nl) ->
+      pr "@[<2>struct@ %a@ %a@]"
+        (print_list print_coercion2) fl
+        (print_list print_coercion3) nl
+  | Tcoerce_functor (inp, out) ->
+      pr "@[<2>functor@ (%a)@ (%a)@]"
+        print_coercion inp
+        print_coercion out
+  | Tcoerce_primitive {pc_desc; pc_env = _; pc_type}  ->
+      pr "prim %s@ (%a)" pc_desc.Primitive.prim_name
+        Printtyp.raw_type_expr pc_type
+  | Tcoerce_alias (_, p, c) ->
+      pr "@[<2>alias %a@ (%a)@]"
+        Printtyp.path p
+        print_coercion c
+and print_coercion2 ppf (n, c) =
+  Format.fprintf ppf "@[%d,@ %a@]" n print_coercion c
+and print_coercion3 ppf (i, n, c) =
+  Format.fprintf ppf "@[%s, %d,@ %a@]"
+    (Ident.unique_name i) n print_coercion c
+
+(* Simplify a structure coercion *)
+
+let equal_module_paths env p1 subst p2 =
+  Path.same p1 p2
+  || Path.same (Env.normalize_module_path None env p1)
+       (Env.normalize_module_path None env
+          (Subst.module_path subst p2))
+
+let equal_modtype_paths env p1 subst p2 =
+  Path.same p1 p2
+  || Path.same (Env.normalize_modtype_path env p1)
+       (Env.normalize_modtype_path env
+          (Subst.modtype_path subst p2))
+
+let simplify_structure_coercion cc id_pos_list =
+  let rec is_identity_coercion pos = function
+  | [] ->
+      true
+  | (n, c) :: rem ->
+      n = pos && c = Tcoerce_none && is_identity_coercion (pos + 1) rem in
+  if is_identity_coercion 0 cc
+  then Tcoerce_none
+  else Tcoerce_structure (cc, id_pos_list)
+
+(* Inclusion between module types.
+   Return the restriction that transforms a value of the smaller type
+   into a value of the bigger type. *)
+
+let rec modtypes ~loc env ~mark cxt subst mty1 mty2 =
+  try
+    try_modtypes ~loc env ~mark cxt subst mty1 mty2
+  with
+    Dont_match ->
+      raise(Error[cxt, env,
+                  Module_types(mty1, Subst.modtype Make_local subst mty2)])
+  | Error reasons as err ->
+      match mty1, mty2 with
+        Mty_alias _, _
+      | _, Mty_alias _ -> raise err
+      | _ ->
+          raise(Error((cxt, env,
+                       Module_types(mty1, Subst.modtype Make_local subst mty2))
+                      :: reasons))
+
+and try_modtypes ~loc env ~mark cxt subst mty1 mty2 =
+  match mty1, mty2 with
+  | (Mty_alias p1, Mty_alias p2) ->
+      if Env.is_functor_arg p2 env then
+        raise (Error[cxt, env, Invalid_module_alias p2]);
+      if not (equal_module_paths env p1 subst p2) then
+        raise Dont_match;
+      Tcoerce_none
+  | (Mty_alias p1, _) ->
+      let p1 = try
+        Env.normalize_module_path (Some Location.none) env p1
+      with Env.Error (Env.Missing_module (_, _, path)) ->
+        raise (Error[cxt, env, Unbound_module_path path])
+      in
+      let mty1 = expand_module_alias env cxt p1 in
+      strengthened_modtypes ~loc ~aliasable:true env ~mark cxt
+        subst mty1 p1 mty2
+  | (Mty_ident p1, Mty_ident p2) ->
+      let p1 = Env.normalize_modtype_path env p1 in
+      let p2 = Env.normalize_modtype_path env (Subst.modtype_path subst p2) in
+      if Path.same p1 p2 then Tcoerce_none
+      else
+        try_modtypes ~loc env ~mark cxt subst
+          (try_expand_modtype_path env p1)
+          (try_expand_modtype_path env p2)
+  | (Mty_ident p1, _) ->
+      let p1 = Env.normalize_modtype_path env p1 in
+      try_modtypes ~loc env ~mark cxt subst
+        (try_expand_modtype_path env p1) mty2
+  | (_, Mty_ident p2) ->
+      let p2 = Env.normalize_modtype_path env (Subst.modtype_path subst p2) in
+      try_modtypes ~loc env ~mark cxt subst mty1
+        (try_expand_modtype_path env p2)
+  | (Mty_signature sig1, Mty_signature sig2) ->
+      signatures ~loc env ~mark cxt subst sig1 sig2
+  | (Mty_functor(Unit, res1), Mty_functor(Unit, res2)) ->
+    begin
+      match modtypes ~loc env ~mark (Body Unit::cxt) subst res1 res2 with
+      | Tcoerce_none -> Tcoerce_none
+      | cc -> Tcoerce_functor (Tcoerce_none, cc)
+    end
+  | (Mty_functor(Named (param1, arg1) as arg, res1),
+     Mty_functor(Named (param2, arg2), res2)) ->
+      let arg2' = Subst.modtype Keep subst arg2 in
+      let cc_arg =
+        modtypes ~loc env ~mark:(negate_mark mark)
+          (Arg arg::cxt) Subst.identity arg2' arg1
+      in
+      let env, subst =
+        match param1, param2 with
+        | Some p1, Some p2 ->
+            Env.add_module p1 Mp_present arg2' env,
+            Subst.add_module p2 (Path.Pident p1) subst
+        | None, Some p2 ->
+            Env.add_module p2 Mp_present arg2' env, subst
+        | Some p1, None ->
+            Env.add_module p1 Mp_present arg2' env, subst
+        | None, None ->
+            env, subst
+      in
+      let cc_res = modtypes ~loc env ~mark (Body arg::cxt) subst res1 res2 in
+      begin match (cc_arg, cc_res) with
+          (Tcoerce_none, Tcoerce_none) -> Tcoerce_none
+        | _ -> Tcoerce_functor(cc_arg, cc_res)
+      end
+  | (_, _) ->
+      raise Dont_match
+
+and strengthened_modtypes ~loc ~aliasable env ~mark cxt subst mty1 path1 mty2 =
+  match mty1, mty2 with
+  | Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 ->
+      Tcoerce_none
+  | _, _ ->
+      let mty1 = Mtype.strengthen ~aliasable env mty1 path1 in
+      modtypes ~loc env ~mark cxt subst mty1 mty2
+
+and strengthened_module_decl ~loc ~aliasable env ~mark cxt subst md1 path1 md2 =
+  match md1.md_type, md2.md_type with
+  | Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 ->
+      Tcoerce_none
+  | _, _ ->
+      let md1 = Mtype.strengthen_decl ~aliasable env md1 path1 in
+      modtypes ~loc env ~mark cxt subst md1.md_type md2.md_type
+
+(* Inclusion between signatures *)
+
+and signatures ~loc env ~mark cxt subst sig1 sig2 =
+  (* Environment used to check inclusion of components *)
+  let new_env =
+    Env.add_signature sig1 (Env.in_signature true env) in
+  (* Keep ids for module aliases *)
+  let (id_pos_list,_) =
+    List.fold_left
+      (fun (l,pos) -> function
+          Sig_module (id, Mp_present, _, _, _) ->
+            ((id,pos,Tcoerce_none)::l , pos+1)
+        | item -> (l, if is_runtime_component item then pos+1 else pos))
+      ([], 0) sig1 in
+  (* Build a table of the components of sig1, along with their positions.
+     The table is indexed by kind and name of component *)
+  let rec build_component_table pos tbl = function
+      [] -> pos, tbl
+    | (Sig_value (_, _, Hidden)
+      |Sig_type (_, _, _, Hidden)
+      |Sig_typext (_, _, _, Hidden)
+      |Sig_module (_, _, _, _, Hidden)
+      |Sig_modtype (_, _, Hidden)
+      |Sig_class (_, _, _, Hidden)
+      |Sig_class_type (_, _, _, Hidden)
+      ) as item :: rem ->
+        let pos = if is_runtime_component item then pos + 1 else pos in
+        build_component_table pos tbl rem (* do not pair private items. *)
+    | item :: rem ->
+        let (id, _loc, name) = item_ident_name item in
+        let pos, nextpos =
+          if is_runtime_component item then pos, pos + 1
+          else -1, pos
+        in
+        build_component_table nextpos
+                              (FieldMap.add name (id, item, pos) tbl) rem in
+  let len1, comps1 =
+    build_component_table 0 FieldMap.empty sig1 in
+  let len2 =
+    List.fold_left
+      (fun n i -> if is_runtime_component i then n + 1 else n)
+      0
+      sig2
+  in
+  (* Pair each component of sig2 with a component of sig1,
+     identifying the names along the way.
+     Return a coercion list indicating, for all run-time components
+     of sig2, the position of the matching run-time components of sig1
+     and the coercion to be applied to it. *)
+  let rec pair_components subst paired unpaired = function
+      [] ->
+        begin match unpaired with
+            [] ->
+              let cc =
+                signature_components ~loc env ~mark new_env cxt subst
+                  (List.rev paired)
+              in
+              if len1 = len2 then (* see PR#5098 *)
+                simplify_structure_coercion cc id_pos_list
+              else
+                Tcoerce_structure (cc, id_pos_list)
+          | _  -> raise(Error unpaired)
+        end
+    | item2 :: rem ->
+        let (id2, loc, name2) = item_ident_name item2 in
+        let name2, report =
+          match item2, name2 with
+            Sig_type (_, {type_manifest=None}, _, _), Field_type s
+            when Btype.is_row_name s ->
+              (* Do not report in case of failure,
+                 as the main type will generate an error *)
+              Field_type (String.sub s 0 (String.length s - 4)), false
+          | _ -> name2, true
+        in
+        begin try
+          let (id1, item1, pos1) = FieldMap.find name2 comps1 in
+          let new_subst =
+            match item2 with
+              Sig_type _ ->
+                Subst.add_type id2 (Path.Pident id1) subst
+            | Sig_module _ ->
+                Subst.add_module id2 (Path.Pident id1) subst
+            | Sig_modtype _ ->
+                Subst.add_modtype id2 (Mty_ident (Path.Pident id1)) subst
+            | Sig_value _ | Sig_typext _
+            | Sig_class _ | Sig_class_type _ ->
+                subst
+          in
+          pair_components new_subst
+            ((item1, item2, pos1) :: paired) unpaired rem
+        with Not_found ->
+          let unpaired =
+            if report then
+              (cxt, env, Missing_field (id2, loc, kind_of_field_desc name2)) ::
+              unpaired
+            else unpaired in
+          pair_components subst paired unpaired rem
+        end in
+  (* Do the pairing and checking, and return the final coercion *)
+  pair_components subst [] [] sig2
+
+(* Inclusion between signature components *)
+
+and signature_components ~loc old_env ~mark env cxt subst paired =
+  let comps_rec rem =
+    signature_components ~loc old_env ~mark env cxt subst rem
+  in
+  match paired with
+    [] -> []
+  | (Sig_value(id1, valdecl1, _), Sig_value(_id2, valdecl2, _), pos) :: rem ->
+      let cc =
+        value_descriptions ~loc env ~mark cxt subst id1 valdecl1 valdecl2
+      in
+      begin match valdecl2.val_kind with
+        Val_prim _ -> comps_rec rem
+      | _ -> (pos, cc) :: comps_rec rem
+      end
+  | (Sig_type(id1, tydecl1, _, _), Sig_type(_id2, tydecl2, _, _), _pos) :: rem
+    ->
+      type_declarations ~loc ~old_env env ~mark cxt subst id1 tydecl1 tydecl2;
+      comps_rec rem
+  | (Sig_typext(id1, ext1, _, _), Sig_typext(_id2, ext2, _, _), pos)
+    :: rem ->
+      extension_constructors ~loc env ~mark cxt subst id1 ext1 ext2;
+      (pos, Tcoerce_none) :: comps_rec rem
+  | (Sig_module(id1, pres1, mty1, _, _),
+     Sig_module(_id2, pres2, mty2, _, _), pos) :: rem -> begin
+      let cc = module_declarations ~loc env ~mark cxt subst id1 mty1 mty2 in
+      let rem = comps_rec rem in
+      match pres1, pres2, mty1.md_type with
+      | Mp_present, Mp_present, _ -> (pos, cc) :: rem
+      | _, Mp_absent, _ -> rem
+      | Mp_absent, Mp_present, Mty_alias p1 ->
+          (pos, Tcoerce_alias (env, p1, cc)) :: rem
+      | Mp_absent, Mp_present, _ -> assert false
+    end
+  | (Sig_modtype(id1, info1, _), Sig_modtype(_id2, info2, _), _pos) :: rem ->
+      modtype_infos ~loc env ~mark cxt subst id1 info1 info2;
+      comps_rec rem
+  | (Sig_class(id1, decl1, _, _), Sig_class(_id2, decl2, _, _), pos) :: rem ->
+      class_declarations ~old_env env cxt subst id1 decl1 decl2;
+      (pos, Tcoerce_none) :: comps_rec rem
+  | (Sig_class_type(id1, info1, _, _),
+     Sig_class_type(_id2, info2, _, _), _pos) :: rem ->
+      class_type_declarations ~loc ~old_env env cxt subst id1 info1 info2;
+      comps_rec rem
+  | _ ->
+      assert false
+
+and module_declarations ~loc env ~mark cxt subst id1 md1 md2 =
+  Builtin_attributes.check_alerts_inclusion
+    ~def:md1.md_loc
+    ~use:md2.md_loc
+    loc
+    md1.md_attributes md2.md_attributes
+    (Ident.name id1);
+  let p1 = Path.Pident id1 in
+  if mark_positive mark then
+    Env.mark_module_used md1.md_uid;
+  strengthened_modtypes ~loc ~aliasable:true env ~mark (Module id1::cxt) subst
+    md1.md_type p1 md2.md_type
+
+(* Inclusion between module type specifications *)
+
+and modtype_infos ~loc env ~mark cxt subst id info1 info2 =
+  Builtin_attributes.check_alerts_inclusion
+    ~def:info1.mtd_loc
+    ~use:info2.mtd_loc
+    loc
+    info1.mtd_attributes info2.mtd_attributes
+    (Ident.name id);
+  let info2 = Subst.modtype_declaration Keep subst info2 in
+  let cxt' = Modtype id :: cxt in
+  try
+    match (info1.mtd_type, info2.mtd_type) with
+      (None, None) -> ()
+    | (Some _, None) -> ()
+    | (Some mty1, Some mty2) ->
+        check_modtype_equiv ~loc env ~mark cxt' mty1 mty2
+    | (None, Some mty2) ->
+        check_modtype_equiv ~loc env ~mark cxt' (Mty_ident(Path.Pident id)) mty2
+  with Error reasons ->
+    raise(Error((cxt, env, Modtype_infos(id, info1, info2)) :: reasons))
+
+and check_modtype_equiv ~loc env ~mark cxt mty1 mty2 =
+  match
+    (modtypes ~loc env ~mark cxt Subst.identity mty1 mty2,
+     modtypes ~loc env ~mark:(negate_mark mark) cxt Subst.identity mty2 mty1)
+  with
+    (Tcoerce_none, Tcoerce_none) -> ()
+  | (c1, _c2) ->
+      (* Format.eprintf "@[c1 = %a@ c2 = %a@]@."
+        print_coercion _c1 print_coercion _c2; *)
+      raise(Error [cxt, env, Modtype_permutation (mty1, c1)])
+
+(* Simplified inclusion check between module types (for Env) *)
+
+let can_alias env path =
+  let rec no_apply = function
+    | Path.Pident _ -> true
+    | Path.Pdot(p, _) -> no_apply p
+    | Path.Papply _ -> false
+  in
+  no_apply path && not (Env.is_functor_arg path env)
+
+let check_modtype_inclusion ~loc env mty1 path1 mty2 =
+  let aliasable = can_alias env path1 in
+  ignore
+    (strengthened_modtypes ~loc ~aliasable env ~mark:Mark_both []
+       Subst.identity mty1 path1 mty2)
+
+let () =
+  Env.check_functor_application :=
+    (fun ~errors ~loc env mty1 path1 mty2 path2 ->
+       try
+         check_modtype_inclusion ~loc env mty1 path1 mty2
+       with Error errs ->
+         if errors then
+           raise (Apply_error(loc, path1, path2, errs))
+         else
+           raise Not_found)
+
+(* Check that an implementation of a compilation unit meets its
+   interface. *)
+
+let compunit env ~mark impl_name impl_sig intf_name intf_sig =
+  try
+    signatures ~loc:(Location.in_file impl_name) env ~mark []
+      Subst.identity impl_sig intf_sig
+  with Error reasons ->
+    raise(Error(([], Env.empty,Interface_mismatch(impl_name, intf_name))
+                :: reasons))
+
+(* Hide the context and substitution parameters to the outside world *)
+
+let modtypes ~loc env ~mark mty1 mty2 =
+  modtypes ~loc env ~mark [] Subst.identity mty1 mty2
+let signatures env ~mark sig1 sig2 =
+  signatures ~loc:Location.none env ~mark [] Subst.identity sig1 sig2
+let type_declarations ~loc env ~mark id decl1 decl2 =
+  type_declarations ~loc env ~mark [] Subst.identity id decl1 decl2
+let strengthened_module_decl ~loc ~aliasable env ~mark
+      md1 path1 md2 =
+  strengthened_module_decl ~loc ~aliasable env ~mark [] Subst.identity
+    md1 path1 md2
+
+(*
+let modtypes env m1 m2 =
+  let c = modtypes env m1 m2 in
+  Format.eprintf "@[<2>modtypes@ %a@ %a =@ %a@]@."
+    Printtyp.modtype m1 Printtyp.modtype m2
+    print_coercion c;
+  c
+*)
+
+(* Error report *)
+
+module Illegal_permutation = struct
+  (** Extraction of information in case of illegal permutation
+      in a module type *)
+
+  (** When examining coercions, we only have runtime component indices,
+      we use thus a limited version of {!pos}. *)
+  type coerce_pos =
+    | Item of int
+    | InArg
+    | InBody
+
+  let either f x g y = match f x with
+    | None -> g y
+    | Some _ as v -> v
+
+  (** We extract a lone transposition from a full tree of permutations. *)
+  let rec transposition_under path = function
+    | Tcoerce_structure(c,_) ->
+        either
+          (not_fixpoint path 0) c
+          (first_non_id path 0) c
+    | Tcoerce_functor(arg,res) ->
+        either
+          (transposition_under (InArg::path)) arg
+          (transposition_under (InBody::path)) res
+    | Tcoerce_none -> None
+    | Tcoerce_alias _ | Tcoerce_primitive _ ->
+        (* these coercions are not inversible, and raise an error earlier when
+           checking for module type equivalence *)
+        assert false
+  (* we search the first point which is not invariant at the current level *)
+  and not_fixpoint path pos = function
+    | [] -> None
+    | (n, _) :: q ->
+        if n = pos then
+          not_fixpoint path (pos+1) q
+        else
+          Some(List.rev path, pos, n)
+  (* we search the first item with a non-identity inner coercion *)
+  and first_non_id path pos = function
+    | [] -> None
+    | (_,Tcoerce_none) :: q -> first_non_id path (pos + 1) q
+    | (_,c) :: q ->
+        either
+          (transposition_under (Item pos :: path)) c
+          (first_non_id path (pos + 1)) q
+
+  let transposition c =
+    match transposition_under [] c with
+    | None -> raise Not_found
+    | Some x -> x
+
+  let rec runtime_item k = function
+    | [] -> raise Not_found
+    | item :: q ->
+        if not(is_runtime_component item) then
+          runtime_item k q
+        else if k = 0 then
+          item
+        else
+          runtime_item (k-1) q
+
+  (* Find module type at position [path] and convert the [coerce_pos] path to
+     a [pos] path *)
+  let rec find env ctx path mt = match mt, path with
+    | (Mty_ident p | Mty_alias p), _ ->
+        begin match (Env.find_modtype p env).mtd_type with
+        | None -> raise Not_found
+        | Some mt -> find env ctx path mt
+        end
+    | Mty_signature s , [] -> List.rev ctx, s
+    | Mty_signature s, Item k :: q ->
+        begin match runtime_item k s with
+        | Sig_module (id, _, md,_,_) -> find env (Module id :: ctx) q md.md_type
+        | _ -> raise Not_found
+        end
+    | Mty_functor(Named (_,mt) as arg,_), InArg :: q ->
+        find env (Arg arg :: ctx) q mt
+    | Mty_functor(arg, mt), InBody :: q ->
+        find env (Body arg :: ctx) q mt
+    | _ -> raise Not_found
+
+  let find env path mt = find env [] path mt
+  let item mt k = item_ident_name (runtime_item k mt)
+
+  let pp_item ppf (id,_,kind) =
+    Format.fprintf ppf "%s %S" (kind_of_field_desc kind) (Ident.name id)
+
+  let pp ctx_printer env ppf (mty,c) =
+    try
+      let p, k, l = transposition c in
+      let ctx, mt = find env p mty in
+      Format.fprintf ppf
+        "@[<hv 2>Illegal permutation of runtime components in a module type.@ \
+         @[For example,@ %a@[the %a@ and the %a are not in the same order@ \
+         in the expected and actual module types.@]@]"
+        ctx_printer ctx pp_item (item mt k) pp_item (item mt l)
+    with Not_found -> (* this should not happen *)
+      Format.fprintf ppf
+        "Illegal permutation of runtime components in a module type."
+
+end
+
+open Format
+
+let show_loc msg ppf loc =
+  let pos = loc.Location.loc_start in
+  if List.mem pos.Lexing.pos_fname [""; "_none_"; "//toplevel//"] then ()
+  else fprintf ppf "@\n@[<2>%a:@ %s@]" Location.print_loc loc msg
+
+let show_locs ppf (loc1, loc2) =
+  show_loc "Expected declaration" ppf loc2;
+  show_loc "Actual declaration" ppf loc1
+
+let path_of_context = function
+    Module id :: rem ->
+      let rec subm path = function
+        | [] -> path
+        | Module id :: rem -> subm (Path.Pdot (path, Ident.name id)) rem
+        | _ -> assert false
+      in subm (Path.Pident id) rem
+  | _ -> assert false
+
+
+let rec context ppf = function
+    Module id :: rem ->
+      fprintf ppf "@[<2>module %a%a@]" Printtyp.ident id args rem
+  | Modtype id :: rem ->
+      fprintf ppf "@[<2>module type %a =@ %a@]"
+        Printtyp.ident id context_mty rem
+  | Body x :: rem ->
+      fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem
+  | Arg x :: rem ->
+      fprintf ppf "functor (%s : %a) -> ..." (argname x) context_mty rem
+  | [] ->
+      fprintf ppf "<here>"
+and context_mty ppf = function
+    (Module _ | Modtype _) :: _ as rem ->
+      fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem
+  | cxt -> context ppf cxt
+and args ppf = function
+    Body x :: rem ->
+      fprintf ppf "(%s)%a" (argname x) args rem
+  | Arg x :: rem ->
+      fprintf ppf "(%s :@ %a) : ..." (argname  x) context_mty rem
+  | cxt ->
+      fprintf ppf " :@ %a" context_mty cxt
+and argname = function
+  | Unit -> ""
+  | Named (None, _) -> "_"
+  | Named (Some id, _) -> Ident.name id
+
+let alt_context ppf cxt =
+  if cxt = [] then () else
+  if List.for_all (function Module _ -> true | _ -> false) cxt then
+    fprintf ppf "in module %a,@ " Printtyp.path (path_of_context cxt)
+  else
+    fprintf ppf "@[<hv 2>at position@ %a,@]@ " context cxt
+
+let context ppf cxt =
+  if cxt = [] then () else
+  if List.for_all (function Module _ -> true | _ -> false) cxt then
+    fprintf ppf "In module %a:@ " Printtyp.path (path_of_context cxt)
+  else
+    fprintf ppf "@[<hv 2>At position@ %a@]@ " context cxt
+
+let include_err env ppf = function
+  | Missing_field (id, loc, kind) ->
+      fprintf ppf "The %s `%a' is required but not provided"
+        kind Printtyp.ident id;
+      show_loc "Expected declaration" ppf loc
+  | Value_descriptions(id, d1, d2) ->
+      fprintf ppf
+        "@[<hv 2>Values do not match:@ %a@;<1 -2>is not included in@ %a@]"
+        !Oprint.out_sig_item (Printtyp.tree_of_value_description id d1)
+        !Oprint.out_sig_item (Printtyp.tree_of_value_description id d2);
+      show_locs ppf (d1.val_loc, d2.val_loc)
+  | Type_declarations(id, d1, d2, err) ->
+      fprintf ppf "@[<v>@[<hv>%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]"
+        "Type declarations do not match"
+        !Oprint.out_sig_item
+        (Printtyp.tree_of_type_declaration id d1 Trec_first)
+        "is not included in"
+        !Oprint.out_sig_item
+        (Printtyp.tree_of_type_declaration id d2 Trec_first)
+        (Includecore.report_type_mismatch
+           "the first" "the second" "declaration") err
+        show_locs (d1.type_loc, d2.type_loc)
+  | Extension_constructors(id, x1, x2, err) ->
+      fprintf ppf "@[<v>@[<hv>%s:@;<1 2>%a@ %s@;<1 2>%a@]@ %a%a@]"
+        "Extension declarations do not match"
+        !Oprint.out_sig_item
+        (Printtyp.tree_of_extension_constructor id x1 Text_first)
+        "is not included in"
+        !Oprint.out_sig_item
+        (Printtyp.tree_of_extension_constructor id x2 Text_first)
+        (Includecore.report_extension_constructor_mismatch
+           "the first" "the second" "declaration") err
+        show_locs (x1.ext_loc, x2.ext_loc)
+  | Module_types(mty1, mty2)->
+      fprintf ppf
+       "@[<hv 2>Modules do not match:@ \
+        %a@;<1 -2>is not included in@ %a@]"
+      !Oprint.out_module_type (Printtyp.tree_of_modtype mty1)
+      !Oprint.out_module_type (Printtyp.tree_of_modtype mty2)
+  | Modtype_infos(id, d1, d2) ->
+      fprintf ppf
+       "@[<hv 2>Module type declarations do not match:@ \
+        %a@;<1 -2>does not match@ %a@]"
+      !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d1)
+      !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d2)
+  | Modtype_permutation (mty,c) ->
+      Illegal_permutation.pp alt_context env ppf (mty,c)
+  | Interface_mismatch(impl_name, intf_name) ->
+      fprintf ppf "@[The implementation %s@ does not match the interface %s:"
+       impl_name intf_name
+  | Class_type_declarations(id, d1, d2, reason) ->
+      fprintf ppf
+       "@[<hv 2>Class type declarations do not match:@ \
+        %a@;<1 -2>does not match@ %a@]@ %a"
+       !Oprint.out_sig_item
+       (Printtyp.tree_of_cltype_declaration id d1 Trec_first)
+       !Oprint.out_sig_item
+       (Printtyp.tree_of_cltype_declaration id d2 Trec_first)
+      Includeclass.report_error reason
+  | Class_declarations(id, d1, d2, reason) ->
+      fprintf ppf
+       "@[<hv 2>Class declarations do not match:@ \
+        %a@;<1 -2>does not match@ %a@]@ %a"
+      !Oprint.out_sig_item (Printtyp.tree_of_class_declaration id d1 Trec_first)
+      !Oprint.out_sig_item (Printtyp.tree_of_class_declaration id d2 Trec_first)
+      Includeclass.report_error reason
+  | Unbound_modtype_path path ->
+      fprintf ppf "Unbound module type %a" Printtyp.path path
+  | Unbound_module_path path ->
+      fprintf ppf "Unbound module %a" Printtyp.path path
+  | Invalid_module_alias path ->
+      fprintf ppf "Module %a cannot be aliased" Printtyp.path path
+
+let include_err ppf (cxt, env, err) =
+  Printtyp.wrap_printing_env ~error:true env (fun () ->
+    fprintf ppf "@[<v>%a%a@]" context (List.rev cxt) (include_err env) err)
+
+let buffer = ref Bytes.empty
+let is_big obj =
+  let size = !Clflags.error_size in
+  size > 0 &&
+  begin
+    if Bytes.length !buffer < size then buffer := Bytes.create size;
+    try ignore (Marshal.to_buffer !buffer 0 size obj []); false
+    with _ -> true
+  end
+
+let report_error ppf errs =
+  if errs = [] then () else
+  let (errs , err) = split_last errs in
+  let pe = ref true in
+  let include_err' ppf (_,_,obj as err) =
+    if not (is_big obj) then fprintf ppf "%a@ " include_err err
+    else if !pe then (fprintf ppf "...@ "; pe := false)
+  in
+  let print_errs ppf = List.iter (include_err' ppf) in
+  Printtyp.Conflicts.reset();
+  fprintf ppf "@[<v>%a%a%t@]" print_errs errs include_err err
+    Printtyp.Conflicts.print_explanations
+
+let report_apply_error p1 p2 ppf errs =
+  fprintf ppf "@[The type of %a does not match %a's parameter@ %a@]"
+    Printtyp.path p1 Printtyp.path p2 report_error errs
+
+(* We could do a better job to split the individual error items
+   as sub-messages of the main interface mismatch on the whole unit. *)
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | Apply_error(loc, p1, p2, err) ->
+          Some (Location.error_of_printer ~loc (report_apply_error p1 p2) err)
+      | _ -> None
+    )
diff --git a/upstream/ocaml_411/typing/includemod.mli b/upstream/ocaml_411/typing/includemod.mli
new file mode 100644
index 0000000..855b786
--- /dev/null
+++ b/upstream/ocaml_411/typing/includemod.mli
@@ -0,0 +1,93 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the module language *)
+
+open Typedtree
+open Types
+open Format
+
+(** Type describing which arguments of an inclusion to consider as used
+    for the usage warnings. [Mark_both] is the default. *)
+type mark =
+  | Mark_both
+      (** Mark definitions used from both arguments *)
+  | Mark_positive
+      (** Mark definitions used from the positive (first) argument *)
+  | Mark_negative
+      (** Mark definitions used from the negative (second) argument *)
+  | Mark_neither
+      (** Do not mark definitions used from either argument *)
+
+val modtypes:
+  loc:Location.t -> Env.t -> mark:mark ->
+  module_type -> module_type -> module_coercion
+
+val strengthened_module_decl:
+  loc:Location.t -> aliasable:bool -> Env.t -> mark:mark ->
+  module_declaration -> Path.t -> module_declaration -> module_coercion
+
+val check_modtype_inclusion :
+  loc:Location.t -> Env.t -> Types.module_type -> Path.t -> Types.module_type ->
+  unit
+(** [check_modtype_inclusion ~loc env mty1 path1 mty2] checks that the
+    functor application F(M) is well typed, where mty2 is the type of
+    the argument of F and path1/mty1 is the path/unstrenghened type of M. *)
+
+val signatures: Env.t -> mark:mark ->
+  signature -> signature -> module_coercion
+
+val compunit:
+      Env.t -> mark:mark -> string -> signature ->
+      string -> signature -> module_coercion
+
+val type_declarations:
+  loc:Location.t -> Env.t -> mark:mark ->
+  Ident.t -> type_declaration -> type_declaration -> unit
+
+val print_coercion: formatter -> module_coercion -> unit
+
+type symptom =
+    Missing_field of Ident.t * Location.t * string (* kind *)
+  | Value_descriptions of Ident.t * value_description * value_description
+  | Type_declarations of Ident.t * type_declaration
+        * type_declaration * Includecore.type_mismatch
+  | Extension_constructors of Ident.t * extension_constructor
+        * extension_constructor * Includecore.extension_constructor_mismatch
+  | Module_types of module_type * module_type
+  | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration
+  | Modtype_permutation of Types.module_type * Typedtree.module_coercion
+  | Interface_mismatch of string * string
+  | Class_type_declarations of
+      Ident.t * class_type_declaration * class_type_declaration *
+      Ctype.class_match_failure list
+  | Class_declarations of
+      Ident.t * class_declaration * class_declaration *
+      Ctype.class_match_failure list
+  | Unbound_modtype_path of Path.t
+  | Unbound_module_path of Path.t
+  | Invalid_module_alias of Path.t
+
+type pos =
+  | Module of Ident.t
+  | Modtype of Ident.t
+  | Arg of functor_parameter
+  | Body of functor_parameter
+type error = pos list * Env.t * symptom
+
+exception Error of error list
+
+val report_error: formatter -> error list -> unit
+val expand_module_alias: Env.t -> pos list -> Path.t -> Types.module_type
diff --git a/upstream/ocaml_411/typing/mtype.ml b/upstream/ocaml_411/typing/mtype.ml
new file mode 100644
index 0000000..edb4e1b
--- /dev/null
+++ b/upstream/ocaml_411/typing/mtype.ml
@@ -0,0 +1,527 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Operations on module types *)
+
+open Asttypes
+open Path
+open Types
+
+
+let rec scrape env mty =
+  match mty with
+    Mty_ident p ->
+      begin try
+        scrape env (Env.find_modtype_expansion p env)
+      with Not_found ->
+        mty
+      end
+  | _ -> mty
+
+let freshen ~scope mty =
+  Subst.modtype (Rescope scope) Subst.identity mty
+
+let rec strengthen ~aliasable env mty p =
+  match scrape env mty with
+    Mty_signature sg ->
+      Mty_signature(strengthen_sig ~aliasable env sg p)
+  | Mty_functor(Named (Some param, arg), res)
+    when !Clflags.applicative_functors ->
+      Mty_functor(Named (Some param, arg),
+        strengthen ~aliasable:false env res (Papply(p, Pident param)))
+  | Mty_functor(Named (None, arg), res)
+    when !Clflags.applicative_functors ->
+      let param = Ident.create_scoped ~scope:(Path.scope p) "Arg" in
+      Mty_functor(Named (Some param, arg),
+        strengthen ~aliasable:false env res (Papply(p, Pident param)))
+  | mty ->
+      mty
+
+and strengthen_sig ~aliasable env sg p =
+  match sg with
+    [] -> []
+  | (Sig_value(_, _, _) as sigelt) :: rem ->
+      sigelt :: strengthen_sig ~aliasable env rem p
+  | Sig_type(id, {type_kind=Type_abstract}, _, _) ::
+    (Sig_type(id', {type_private=Private}, _, _) :: _ as rem)
+    when Ident.name id = Ident.name id' ^ "#row" ->
+      strengthen_sig ~aliasable env rem p
+  | Sig_type(id, decl, rs, vis) :: rem ->
+      let newdecl =
+        match decl.type_manifest, decl.type_private, decl.type_kind with
+          Some _, Public, _ -> decl
+        | Some _, Private, (Type_record _ | Type_variant _) -> decl
+        | _ ->
+            let manif =
+              Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id),
+                                          decl.type_params, ref Mnil))) in
+            if decl.type_kind = Type_abstract then
+              { decl with type_private = Public; type_manifest = manif }
+            else
+              { decl with type_manifest = manif }
+      in
+      Sig_type(id, newdecl, rs, vis) :: strengthen_sig ~aliasable env rem p
+  | (Sig_typext _ as sigelt) :: rem ->
+      sigelt :: strengthen_sig ~aliasable env rem p
+  | Sig_module(id, pres, md, rs, vis) :: rem ->
+      let str =
+        strengthen_decl ~aliasable env md (Pdot(p, Ident.name id))
+      in
+      Sig_module(id, pres, str, rs, vis)
+      :: strengthen_sig ~aliasable
+        (Env.add_module_declaration ~check:false id pres md env) rem p
+      (* Need to add the module in case it defines manifest module types *)
+  | Sig_modtype(id, decl, vis) :: rem ->
+      let newdecl =
+        match decl.mtd_type with
+          None ->
+            {decl with mtd_type = Some(Mty_ident(Pdot(p,Ident.name id)))}
+        | Some _ ->
+            decl
+      in
+      Sig_modtype(id, newdecl, vis) ::
+      strengthen_sig ~aliasable (Env.add_modtype id decl env) rem p
+      (* Need to add the module type in case it is manifest *)
+  | (Sig_class _ as sigelt) :: rem ->
+      sigelt :: strengthen_sig ~aliasable env rem p
+  | (Sig_class_type _ as sigelt) :: rem ->
+      sigelt :: strengthen_sig ~aliasable env rem p
+
+and strengthen_decl ~aliasable env md p =
+  match md.md_type with
+  | Mty_alias _ -> md
+  | _ when aliasable -> {md with md_type = Mty_alias p}
+  | mty -> {md with md_type = strengthen ~aliasable env mty p}
+
+let () = Env.strengthen := strengthen
+
+let rec make_aliases_absent pres mty =
+  match mty with
+  | Mty_alias _ -> Mp_absent, mty
+  | Mty_signature sg ->
+      pres, Mty_signature(make_aliases_absent_sig sg)
+  | Mty_functor(arg, res) ->
+      let _, res = make_aliases_absent Mp_present res in
+      pres, Mty_functor(arg, res)
+  | mty ->
+      pres, mty
+
+and make_aliases_absent_sig sg =
+  match sg with
+    [] -> []
+  | Sig_module(id, pres, md, rs, priv) :: rem ->
+      let pres, md_type = make_aliases_absent pres md.md_type in
+      let md = { md with md_type } in
+      Sig_module(id, pres, md, rs, priv) :: make_aliases_absent_sig rem
+  | sigelt :: rem ->
+      sigelt :: make_aliases_absent_sig rem
+
+let scrape_for_type_of env pres mty =
+  let rec loop env path mty =
+    match mty, path with
+    | Mty_alias path, _ -> begin
+        try
+          let md = Env.find_module path env in
+          loop env (Some path) md.md_type
+        with Not_found -> mty
+      end
+    | mty, Some path ->
+        strengthen ~aliasable:false env mty path
+    | _ -> mty
+  in
+  make_aliases_absent pres (loop env None mty)
+
+(* In nondep_supertype, env is only used for the type it assigns to id.
+   Hence there is no need to keep env up-to-date by adding the bindings
+   traversed. *)
+
+type variance = Co | Contra | Strict
+
+let rec nondep_mty_with_presence env va ids pres mty =
+  match mty with
+    Mty_ident p ->
+      begin match Path.find_free_opt ids p with
+      | Some id ->
+          let expansion =
+            try Env.find_modtype_expansion p env
+            with Not_found ->
+              raise (Ctype.Nondep_cannot_erase id)
+          in
+          nondep_mty_with_presence env va ids pres expansion
+      | None -> pres, mty
+      end
+  | Mty_alias p ->
+      begin match Path.find_free_opt ids p with
+      | Some id ->
+          let expansion =
+            try Env.find_module p env
+            with Not_found ->
+              raise (Ctype.Nondep_cannot_erase id)
+          in
+          nondep_mty_with_presence env va ids Mp_present expansion.md_type
+      | None -> pres, mty
+      end
+  | Mty_signature sg ->
+      let mty = Mty_signature(nondep_sig env va ids sg) in
+      pres, mty
+  | Mty_functor(Unit, res) ->
+      pres, Mty_functor(Unit, nondep_mty env va ids res)
+  | Mty_functor(Named (param, arg), res) ->
+      let var_inv =
+        match va with Co -> Contra | Contra -> Co | Strict -> Strict in
+      let res_env =
+        match param with
+        | None -> env
+        | Some param -> Env.add_module ~arg:true param Mp_present arg env
+      in
+      let mty =
+        Mty_functor(Named (param, nondep_mty env var_inv ids arg),
+                    nondep_mty res_env va ids res)
+      in
+      pres, mty
+
+and nondep_mty env va ids mty =
+  snd (nondep_mty_with_presence env va ids Mp_present mty)
+
+and nondep_sig_item env va ids = function
+  | Sig_value(id, d, vis) ->
+      Sig_value(id,
+                {d with val_type = Ctype.nondep_type env ids d.val_type},
+                vis)
+  | Sig_type(id, d, rs, vis) ->
+      Sig_type(id, Ctype.nondep_type_decl env ids (va = Co) d, rs, vis)
+  | Sig_typext(id, ext, es, vis) ->
+      Sig_typext(id, Ctype.nondep_extension_constructor env ids ext, es, vis)
+  | Sig_module(id, pres, md, rs, vis) ->
+      let pres, mty = nondep_mty_with_presence env va ids pres md.md_type in
+      Sig_module(id, pres, {md with md_type = mty}, rs, vis)
+  | Sig_modtype(id, d, vis) ->
+      begin try
+        Sig_modtype(id, nondep_modtype_decl env ids d, vis)
+      with Ctype.Nondep_cannot_erase _ as exn ->
+        match va with
+          Co -> Sig_modtype(id, {mtd_type=None; mtd_loc=Location.none;
+                                 mtd_attributes=[]; mtd_uid = d.mtd_uid}, vis)
+        | _  -> raise exn
+      end
+  | Sig_class(id, d, rs, vis) ->
+      Sig_class(id, Ctype.nondep_class_declaration env ids d, rs, vis)
+  | Sig_class_type(id, d, rs, vis) ->
+      Sig_class_type(id, Ctype.nondep_cltype_declaration env ids d, rs, vis)
+
+and nondep_sig env va ids sg =
+  List.map (nondep_sig_item env va ids) sg
+
+and nondep_modtype_decl env ids mtd =
+  {mtd with mtd_type = Option.map (nondep_mty env Strict ids) mtd.mtd_type}
+
+let nondep_supertype env ids = nondep_mty env Co ids
+let nondep_sig_item env ids = nondep_sig_item env Co ids
+
+let enrich_typedecl env p id decl =
+  match decl.type_manifest with
+    Some _ -> decl
+  | None ->
+      try
+        let orig_decl = Env.find_type p env in
+        if decl.type_arity <> orig_decl.type_arity then
+          decl
+        else
+          let orig_ty =
+            Ctype.reify_univars env
+              (Btype.newgenty(Tconstr(p, orig_decl.type_params, ref Mnil)))
+          in
+          let new_ty =
+            Ctype.reify_univars env
+              (Btype.newgenty(Tconstr(Pident id, decl.type_params, ref Mnil)))
+          in
+          let env = Env.add_type ~check:false id decl env in
+          Ctype.mcomp env orig_ty new_ty;
+          let orig_ty =
+            Btype.newgenty(Tconstr(p, decl.type_params, ref Mnil))
+          in
+          {decl with type_manifest = Some orig_ty}
+      with Not_found | Ctype.Unify _ ->
+        (* - Not_found: type which was not present in the signature, so we don't
+           have anything to do.
+           - Unify: the current declaration is not compatible with the one we
+           got from the signature. We should just fail now, but then, we could
+           also have failed if the arities of the two decls were different,
+           which we didn't. *)
+        decl
+
+let rec enrich_modtype env p mty =
+  match mty with
+    Mty_signature sg ->
+      Mty_signature(List.map (enrich_item env p) sg)
+  | _ ->
+      mty
+
+and enrich_item env p = function
+    Sig_type(id, decl, rs, priv) ->
+      Sig_type(id,
+                enrich_typedecl env (Pdot(p, Ident.name id)) id decl, rs, priv)
+  | Sig_module(id, pres, md, rs, priv) ->
+      Sig_module(id, pres,
+                  {md with
+                   md_type = enrich_modtype env
+                       (Pdot(p, Ident.name id)) md.md_type},
+                 rs,
+                 priv)
+  | item -> item
+
+let rec type_paths env p mty =
+  match scrape env mty with
+    Mty_ident _ -> []
+  | Mty_alias _ -> []
+  | Mty_signature sg -> type_paths_sig env p sg
+  | Mty_functor _ -> []
+
+and type_paths_sig env p sg =
+  match sg with
+    [] -> []
+  | Sig_type(id, _decl, _, _) :: rem ->
+      Pdot(p, Ident.name id) :: type_paths_sig env p rem
+  | Sig_module(id, pres, md, _, _) :: rem ->
+      type_paths env (Pdot(p, Ident.name id)) md.md_type @
+      type_paths_sig (Env.add_module_declaration ~check:false id pres md env)
+        p rem
+  | Sig_modtype(id, decl, _) :: rem ->
+      type_paths_sig (Env.add_modtype id decl env) p rem
+  | (Sig_value _ | Sig_typext _ | Sig_class _ | Sig_class_type _) :: rem ->
+      type_paths_sig env p rem
+
+
+let rec no_code_needed_mod env pres mty =
+  match pres with
+  | Mp_absent -> true
+  | Mp_present -> begin
+      match scrape env mty with
+        Mty_ident _ -> false
+      | Mty_signature sg -> no_code_needed_sig env sg
+      | Mty_functor _ -> false
+      | Mty_alias _ -> false
+    end
+
+and no_code_needed_sig env sg =
+  match sg with
+    [] -> true
+  | Sig_value(_id, decl, _) :: rem ->
+      begin match decl.val_kind with
+      | Val_prim _ -> no_code_needed_sig env rem
+      | _ -> false
+      end
+  | Sig_module(id, pres, md, _, _) :: rem ->
+      no_code_needed_mod env pres md.md_type &&
+      no_code_needed_sig
+        (Env.add_module_declaration ~check:false id pres md env) rem
+  | (Sig_type _ | Sig_modtype _ | Sig_class_type _) :: rem ->
+      no_code_needed_sig env rem
+  | (Sig_typext _ | Sig_class _) :: _ ->
+      false
+
+let no_code_needed env mty = no_code_needed_mod env Mp_present mty
+
+(* Check whether a module type may return types *)
+
+let rec contains_type env = function
+    Mty_ident path ->
+      begin try match (Env.find_modtype path env).mtd_type with
+      | None -> raise Exit (* PR#6427 *)
+      | Some mty -> contains_type env mty
+      with Not_found -> raise Exit
+      end
+  | Mty_signature sg ->
+      contains_type_sig env sg
+  | Mty_functor (_, body) ->
+      contains_type env body
+  | Mty_alias _ ->
+      ()
+
+and contains_type_sig env = List.iter (contains_type_item env)
+
+and contains_type_item env = function
+    Sig_type (_,({type_manifest = None} |
+                 {type_kind = Type_abstract; type_private = Private}),_, _)
+  | Sig_modtype _
+  | Sig_typext (_, {ext_args = Cstr_record _}, _, _) ->
+      (* We consider that extension constructors with an inlined
+         record create a type (the inlined record), even though
+         it would be technically safe to ignore that considering
+         the current constraints which guarantee that this type
+         is kept local to expressions.  *)
+      raise Exit
+  | Sig_module (_, _, {md_type = mty}, _, _) ->
+      contains_type env mty
+  | Sig_value _
+  | Sig_type _
+  | Sig_typext _
+  | Sig_class _
+  | Sig_class_type _ ->
+      ()
+
+let contains_type env mty =
+  try contains_type env mty; false with Exit -> true
+
+
+(* Remove module aliases from a signature *)
+
+let rec get_prefixes = function
+  | Pident _ -> Path.Set.empty
+  | Pdot (p, _)
+  | Papply (p, _) -> Path.Set.add p (get_prefixes p)
+
+let rec get_arg_paths = function
+  | Pident _ -> Path.Set.empty
+  | Pdot (p, _) -> get_arg_paths p
+  | Papply (p1, p2) ->
+      Path.Set.add p2
+        (Path.Set.union (get_prefixes p2)
+           (Path.Set.union (get_arg_paths p1) (get_arg_paths p2)))
+
+let rec rollback_path subst p =
+  try Pident (Path.Map.find p subst)
+  with Not_found ->
+    match p with
+      Pident _ | Papply _ -> p
+    | Pdot (p1, s) ->
+        let p1' = rollback_path subst p1 in
+        if Path.same p1 p1' then p else rollback_path subst (Pdot (p1', s))
+
+let rec collect_ids subst bindings p =
+    begin match rollback_path subst p with
+      Pident id ->
+        let ids =
+          try collect_ids subst bindings (Ident.find_same id bindings)
+          with Not_found -> Ident.Set.empty
+        in
+        Ident.Set.add id ids
+    | _ -> Ident.Set.empty
+    end
+
+let collect_arg_paths mty =
+  let open Btype in
+  let paths = ref Path.Set.empty
+  and subst = ref Path.Map.empty
+  and bindings = ref Ident.empty in
+  (* let rt = Ident.create "Root" in
+     and prefix = ref (Path.Pident rt) in *)
+  let it_path p = paths := Path.Set.union (get_arg_paths p) !paths
+  and it_signature_item it si =
+    type_iterators.it_signature_item it si;
+    match si with
+    | Sig_module (id, _, {md_type=Mty_alias p}, _, _) ->
+        bindings := Ident.add id p !bindings
+    | Sig_module (id, _, {md_type=Mty_signature sg}, _, _) ->
+        List.iter
+          (function Sig_module (id', _, _, _, _) ->
+              subst :=
+                Path.Map.add (Pdot (Pident id, Ident.name id')) id' !subst
+            | _ -> ())
+          sg
+    | _ -> ()
+  in
+  let it = {type_iterators with it_path; it_signature_item} in
+  it.it_module_type it mty;
+  it.it_module_type unmark_iterators mty;
+  Path.Set.fold (fun p -> Ident.Set.union (collect_ids !subst !bindings p))
+    !paths Ident.Set.empty
+
+type remove_alias_args =
+    { mutable modified: bool;
+      exclude: Ident.t -> Path.t -> bool;
+      scrape: Env.t -> module_type -> module_type }
+
+let rec remove_aliases_mty env args pres mty =
+  let args' = {args with modified = false} in
+  let res =
+    match args.scrape env mty with
+      Mty_signature sg ->
+        Mp_present, Mty_signature (remove_aliases_sig env args' sg)
+    | Mty_alias _ ->
+        let mty' = Env.scrape_alias env mty in
+        if mty' = mty then begin
+          pres, mty
+        end else begin
+          args'.modified <- true;
+          remove_aliases_mty env args' Mp_present mty'
+        end
+    | mty ->
+        Mp_present, mty
+  in
+  if args'.modified then begin
+    args.modified <- true;
+    res
+  end else begin
+    pres, mty
+  end
+
+and remove_aliases_sig env args sg =
+  match sg with
+    [] -> []
+  | Sig_module(id, pres, md, rs, priv) :: rem  ->
+      let pres, mty =
+        match md.md_type with
+          Mty_alias p when args.exclude id p ->
+            pres, md.md_type
+        | mty ->
+            remove_aliases_mty env args pres mty
+      in
+      Sig_module(id, pres, {md with md_type = mty} , rs, priv) ::
+      remove_aliases_sig (Env.add_module id pres mty env) args rem
+  | Sig_modtype(id, mtd, priv) :: rem ->
+      Sig_modtype(id, mtd, priv) ::
+      remove_aliases_sig (Env.add_modtype id mtd env) args rem
+  | it :: rem ->
+      it :: remove_aliases_sig env args rem
+
+let scrape_for_functor_arg env mty =
+  let exclude _id p =
+    try ignore (Env.find_module p env); true with Not_found -> false
+  in
+  let _, mty =
+    remove_aliases_mty env {modified=false; exclude; scrape} Mp_present mty
+  in
+  mty
+
+let scrape_for_type_of ~remove_aliases env mty =
+  if remove_aliases then begin
+    let excl = collect_arg_paths mty in
+    let exclude id _p = Ident.Set.mem id excl in
+    let scrape _ mty = mty in
+    let _, mty =
+      remove_aliases_mty env {modified=false; exclude; scrape} Mp_present mty
+    in
+    mty
+  end else begin
+    let _, mty = scrape_for_type_of env Mp_present mty in
+    mty
+  end
+
+(* Lower non-generalizable type variables *)
+
+let lower_nongen nglev mty =
+  let open Btype in
+  let it_type_expr it ty =
+    let ty = repr ty in
+    match ty with
+      {desc=Tvar _; level} ->
+        if level < generic_level && level > nglev then set_level ty nglev
+    | _ ->
+        type_iterators.it_type_expr it ty
+  in
+  let it = {type_iterators with it_type_expr} in
+  it.it_module_type it mty;
+  it.it_module_type unmark_iterators mty
diff --git a/upstream/ocaml_411/typing/mtype.mli b/upstream/ocaml_411/typing/mtype.mli
new file mode 100644
index 0000000..68d290b
--- /dev/null
+++ b/upstream/ocaml_411/typing/mtype.mli
@@ -0,0 +1,55 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Operations on module types *)
+
+open Types
+
+val scrape: Env.t -> module_type -> module_type
+        (* Expand toplevel module type abbreviations
+           till hitting a "hard" module type (signature, functor,
+           or abstract module type ident. *)
+val scrape_for_functor_arg: Env.t -> module_type -> module_type
+        (* Remove aliases in a functor argument type *)
+val scrape_for_type_of:
+  remove_aliases:bool -> Env.t -> module_type -> module_type
+        (* Process type for module type of *)
+val freshen: scope:int -> module_type -> module_type
+        (* Return an alpha-equivalent copy of the given module type
+           where bound identifiers are fresh. *)
+val strengthen: aliasable:bool -> Env.t -> module_type -> Path.t -> module_type
+        (* Strengthen abstract type components relative to the
+           given path. *)
+val strengthen_decl:
+  aliasable:bool -> Env.t -> module_declaration -> Path.t -> module_declaration
+val nondep_supertype: Env.t -> Ident.t list -> module_type -> module_type
+        (* Return the smallest supertype of the given type
+           in which none of the given idents appears.
+           @raise [Ctype.Nondep_cannot_erase] if no such type exists. *)
+val nondep_sig_item: Env.t -> Ident.t list -> signature_item -> signature_item
+        (* Returns the signature item with its type updated
+           to be the smallest supertype of its initial type
+           in which none of the given idents appears.
+           @raise [Ctype.Nondep_cannot_erase] if no such type exists. *)
+val no_code_needed: Env.t -> module_type -> bool
+val no_code_needed_sig: Env.t -> signature -> bool
+        (* Determine whether a module needs no implementation code,
+           i.e. consists only of type definitions. *)
+val enrich_modtype: Env.t -> Path.t -> module_type -> module_type
+val enrich_typedecl: Env.t -> Path.t -> Ident.t -> type_declaration ->
+  type_declaration
+val type_paths: Env.t -> Path.t -> module_type -> Path.t list
+val contains_type: Env.t -> module_type -> bool
+val lower_nongen: int -> module_type -> unit
diff --git a/upstream/ocaml_411/typing/oprint.ml b/upstream/ocaml_411/typing/oprint.ml
new file mode 100644
index 0000000..bf6f5f9
--- /dev/null
+++ b/upstream/ocaml_411/typing/oprint.ml
@@ -0,0 +1,820 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Projet Cristal, INRIA Rocquencourt                   *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Format
+open Outcometree
+
+exception Ellipsis
+
+let cautious f ppf arg =
+  try f ppf arg with
+    Ellipsis -> fprintf ppf "..."
+
+let print_lident ppf = function
+  | "::" -> pp_print_string ppf "(::)"
+  | s -> pp_print_string ppf s
+
+let rec print_ident ppf =
+  function
+    Oide_ident s -> print_lident ppf s.printed_name
+  | Oide_dot (id, s) ->
+      print_ident ppf id; pp_print_char ppf '.'; print_lident ppf s
+  | Oide_apply (id1, id2) ->
+      fprintf ppf "%a(%a)" print_ident id1 print_ident id2
+
+let out_ident = ref print_ident
+
+(* Check a character matches the [identchar_latin1] class from the lexer *)
+let is_ident_char c =
+  match c with
+  | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214' | '\216'..'\246'
+  | '\248'..'\255' | '\'' | '0'..'9' -> true
+  | _ -> false
+
+let all_ident_chars s =
+  let rec loop s len i =
+    if i < len then begin
+      if is_ident_char s.[i] then loop s len (i+1)
+      else false
+    end else begin
+      true
+    end
+  in
+  let len = String.length s in
+  loop s len 0
+
+let parenthesized_ident name =
+  (List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"])
+  || not (all_ident_chars name)
+
+let value_ident ppf name =
+  if parenthesized_ident name then
+    fprintf ppf "( %s )" name
+  else
+    pp_print_string ppf name
+
+(* Values *)
+
+let valid_float_lexeme s =
+  let l = String.length s in
+  let rec loop i =
+    if i >= l then s ^ "." else
+    match s.[i] with
+    | '0' .. '9' | '-' -> loop (i+1)
+    | _ -> s
+  in loop 0
+
+let float_repres f =
+  match classify_float f with
+    FP_nan -> "nan"
+  | FP_infinite ->
+      if f < 0.0 then "neg_infinity" else "infinity"
+  | _ ->
+      let float_val =
+        let s1 = Printf.sprintf "%.12g" f in
+        if f = float_of_string s1 then s1 else
+        let s2 = Printf.sprintf "%.15g" f in
+        if f = float_of_string s2 then s2 else
+        Printf.sprintf "%.18g" f
+      in valid_float_lexeme float_val
+
+let parenthesize_if_neg ppf fmt v isneg =
+  if isneg then pp_print_char ppf '(';
+  fprintf ppf fmt v;
+  if isneg then pp_print_char ppf ')'
+
+let escape_string s =
+  (* Escape only C0 control characters (bytes <= 0x1F), DEL(0x7F), '\\'
+     and '"' *)
+   let n = ref 0 in
+  for i = 0 to String.length s - 1 do
+    n := !n +
+      (match String.unsafe_get s i with
+       | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2
+       | '\x00' .. '\x1F'
+       | '\x7F' -> 4
+       | _ -> 1)
+  done;
+  if !n = String.length s then s else begin
+    let s' = Bytes.create !n in
+    n := 0;
+    for i = 0 to String.length s - 1 do
+      begin match String.unsafe_get s i with
+      | ('\"' | '\\') as c ->
+          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n c
+      | '\n' ->
+          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'n'
+      | '\t' ->
+          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 't'
+      | '\r' ->
+          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'r'
+      | '\b' ->
+          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'b'
+      | '\x00' .. '\x1F' | '\x7F' as c ->
+          let a = Char.code c in
+          Bytes.unsafe_set s' !n '\\';
+          incr n;
+          Bytes.unsafe_set s' !n (Char.chr (48 + a / 100));
+          incr n;
+          Bytes.unsafe_set s' !n (Char.chr (48 + (a / 10) mod 10));
+          incr n;
+          Bytes.unsafe_set s' !n (Char.chr (48 + a mod 10));
+      | c -> Bytes.unsafe_set s' !n c
+      end;
+      incr n
+    done;
+    Bytes.to_string s'
+  end
+
+
+let print_out_string ppf s =
+  let not_escaped =
+    (* let the user dynamically choose if strings should be escaped: *)
+    match Sys.getenv_opt "OCAMLTOP_UTF_8" with
+    | None -> true
+    | Some x ->
+        match bool_of_string_opt x with
+        | None -> true
+        | Some f -> f in
+  if not_escaped then
+    fprintf ppf "\"%s\"" (escape_string s)
+  else
+    fprintf ppf "%S" s
+
+let print_out_value ppf tree =
+  let rec print_tree_1 ppf =
+    function
+    | Oval_constr (name, [param]) ->
+        fprintf ppf "@[<1>%a@ %a@]" print_ident name print_constr_param param
+    | Oval_constr (name, (_ :: _ as params)) ->
+        fprintf ppf "@[<1>%a@ (%a)@]" print_ident name
+          (print_tree_list print_tree_1 ",") params
+    | Oval_variant (name, Some param) ->
+        fprintf ppf "@[<2>`%s@ %a@]" name print_constr_param param
+    | tree -> print_simple_tree ppf tree
+  and print_constr_param ppf = function
+    | Oval_int i -> parenthesize_if_neg ppf "%i" i (i < 0)
+    | Oval_int32 i -> parenthesize_if_neg ppf "%lil" i (i < 0l)
+    | Oval_int64 i -> parenthesize_if_neg ppf "%LiL" i (i < 0L)
+    | Oval_nativeint i -> parenthesize_if_neg ppf "%nin" i (i < 0n)
+    | Oval_float f ->
+        parenthesize_if_neg ppf "%s" (float_repres f)
+                                     (f < 0.0 || 1. /. f = neg_infinity)
+    | Oval_string (_,_, Ostr_bytes) as tree ->
+      pp_print_char ppf '(';
+      print_simple_tree ppf tree;
+      pp_print_char ppf ')';
+    | tree -> print_simple_tree ppf tree
+  and print_simple_tree ppf =
+    function
+      Oval_int i -> fprintf ppf "%i" i
+    | Oval_int32 i -> fprintf ppf "%lil" i
+    | Oval_int64 i -> fprintf ppf "%LiL" i
+    | Oval_nativeint i -> fprintf ppf "%nin" i
+    | Oval_float f -> pp_print_string ppf (float_repres f)
+    | Oval_char c -> fprintf ppf "%C" c
+    | Oval_string (s, maxlen, kind) ->
+       begin try
+         let len = String.length s in
+         let s = if len > maxlen then String.sub s 0 maxlen else s in
+         begin match kind with
+         | Ostr_bytes -> fprintf ppf "Bytes.of_string %S" s
+         | Ostr_string -> print_out_string ppf s
+         end;
+         (if len > maxlen then
+            fprintf ppf
+              "... (* string length %d; truncated *)" len
+         )
+          with
+          Invalid_argument _ (* "String.create" *)-> fprintf ppf "<huge string>"
+        end
+    | Oval_list tl ->
+        fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ";") tl
+    | Oval_array tl ->
+        fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ";") tl
+    | Oval_constr (name, []) -> print_ident ppf name
+    | Oval_variant (name, None) -> fprintf ppf "`%s" name
+    | Oval_stuff s -> pp_print_string ppf s
+    | Oval_record fel ->
+        fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel
+    | Oval_ellipsis -> raise Ellipsis
+    | Oval_printer f -> f ppf
+    | Oval_tuple tree_list ->
+        fprintf ppf "@[<1>(%a)@]" (print_tree_list print_tree_1 ",") tree_list
+    | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree_1) tree
+  and print_fields first ppf =
+    function
+      [] -> ()
+    | (name, tree) :: fields ->
+        if not first then fprintf ppf ";@ ";
+        fprintf ppf "@[<1>%a@ =@ %a@]" print_ident name (cautious print_tree_1)
+          tree;
+        print_fields false ppf fields
+  and print_tree_list print_item sep ppf tree_list =
+    let rec print_list first ppf =
+      function
+        [] -> ()
+      | tree :: tree_list ->
+          if not first then fprintf ppf "%s@ " sep;
+          print_item ppf tree;
+          print_list false ppf tree_list
+    in
+    cautious (print_list true) ppf tree_list
+  in
+  cautious print_tree_1 ppf tree
+
+let out_value = ref print_out_value
+
+(* Types *)
+
+let rec print_list_init pr sep ppf =
+  function
+    [] -> ()
+  | a :: l -> sep ppf; pr ppf a; print_list_init pr sep ppf l
+
+let rec print_list pr sep ppf =
+  function
+    [] -> ()
+  | [a] -> pr ppf a
+  | a :: l -> pr ppf a; sep ppf; print_list pr sep ppf l
+
+let pr_present =
+  print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ")
+
+let pr_var = Pprintast.tyvar
+
+let pr_vars =
+  print_list pr_var (fun ppf -> fprintf ppf "@ ")
+
+let rec print_out_type ppf =
+  function
+  | Otyp_alias (ty, s) ->
+      fprintf ppf "@[%a@ as %a@]" print_out_type ty pr_var s
+  | Otyp_poly (sl, ty) ->
+      fprintf ppf "@[<hov 2>%a.@ %a@]"
+        pr_vars sl
+        print_out_type ty
+  | ty ->
+      print_out_type_1 ppf ty
+
+and print_out_type_1 ppf =
+  function
+    Otyp_arrow (lab, ty1, ty2) ->
+      pp_open_box ppf 0;
+      if lab <> "" then (pp_print_string ppf lab; pp_print_char ppf ':');
+      print_out_type_2 ppf ty1;
+      pp_print_string ppf " ->";
+      pp_print_space ppf ();
+      print_out_type_1 ppf ty2;
+      pp_close_box ppf ()
+  | ty -> print_out_type_2 ppf ty
+and print_out_type_2 ppf =
+  function
+    Otyp_tuple tyl ->
+      fprintf ppf "@[<0>%a@]" (print_typlist print_simple_out_type " *") tyl
+  | ty -> print_simple_out_type ppf ty
+and print_simple_out_type ppf =
+  function
+    Otyp_class (ng, id, tyl) ->
+      fprintf ppf "@[%a%s#%a@]" print_typargs tyl (if ng then "_" else "")
+        print_ident id
+  | Otyp_constr (id, tyl) ->
+      pp_open_box ppf 0;
+      print_typargs ppf tyl;
+      print_ident ppf id;
+      pp_close_box ppf ()
+  | Otyp_object (fields, rest) ->
+      fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields
+  | Otyp_stuff s -> pp_print_string ppf s
+  | Otyp_var (ng, s) -> pr_var ppf (if ng then "_" ^ s else s)
+  | Otyp_variant (non_gen, row_fields, closed, tags) ->
+      let print_present ppf =
+        function
+          None | Some [] -> ()
+        | Some l -> fprintf ppf "@;<1 -2>> @[<hov>%a@]" pr_present l
+      in
+      let print_fields ppf =
+        function
+          Ovar_fields fields ->
+            print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ")
+              ppf fields
+        | Ovar_typ typ ->
+           print_simple_out_type ppf typ
+      in
+      fprintf ppf "%s@[<hov>[%s@[<hv>@[<hv>%a@]%a@]@ ]@]"
+        (if non_gen then "_" else "")
+        (if closed then if tags = None then " " else "< "
+         else if tags = None then "> " else "? ")
+        print_fields row_fields
+        print_present tags
+  | Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty ->
+      pp_open_box ppf 1;
+      pp_print_char ppf '(';
+      print_out_type ppf ty;
+      pp_print_char ppf ')';
+      pp_close_box ppf ()
+  | Otyp_abstract | Otyp_open
+  | Otyp_sum _ | Otyp_manifest (_, _) -> ()
+  | Otyp_record lbls -> print_record_decl ppf lbls
+  | Otyp_module (p, n, tyl) ->
+      fprintf ppf "@[<1>(module %a" print_ident p;
+      let first = ref true in
+      List.iter2
+        (fun s t ->
+          let sep = if !first then (first := false; "with") else "and" in
+          fprintf ppf " %s type %s = %a" sep s print_out_type t
+        )
+        n tyl;
+      fprintf ppf ")@]"
+  | Otyp_attribute (t, attr) ->
+      fprintf ppf "@[<1>(%a [@@%s])@]" print_out_type t attr.oattr_name
+and print_record_decl ppf lbls =
+  fprintf ppf "{%a@;<1 -2>}"
+    (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls
+and print_fields rest ppf =
+  function
+    [] ->
+      begin match rest with
+        Some non_gen -> fprintf ppf "%s.." (if non_gen then "_" else "")
+      | None -> ()
+      end
+  | [s, t] ->
+      fprintf ppf "%s : %a" s print_out_type t;
+      begin match rest with
+        Some _ -> fprintf ppf ";@ "
+      | None -> ()
+      end;
+      print_fields rest ppf []
+  | (s, t) :: l ->
+      fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l
+and print_row_field ppf (l, opt_amp, tyl) =
+  let pr_of ppf =
+    if opt_amp then fprintf ppf " of@ &@ "
+    else if tyl <> [] then fprintf ppf " of@ "
+    else fprintf ppf ""
+  in
+  fprintf ppf "@[<hv 2>`%s%t%a@]" l pr_of (print_typlist print_out_type " &")
+    tyl
+and print_typlist print_elem sep ppf =
+  function
+    [] -> ()
+  | [ty] -> print_elem ppf ty
+  | ty :: tyl ->
+      print_elem ppf ty;
+      pp_print_string ppf sep;
+      pp_print_space ppf ();
+      print_typlist print_elem sep ppf tyl
+and print_typargs ppf =
+  function
+    [] -> ()
+  | [ty1] -> print_simple_out_type ppf ty1; pp_print_space ppf ()
+  | tyl ->
+      pp_open_box ppf 1;
+      pp_print_char ppf '(';
+      print_typlist print_out_type "," ppf tyl;
+      pp_print_char ppf ')';
+      pp_close_box ppf ();
+      pp_print_space ppf ()
+and print_out_label ppf (name, mut, arg) =
+  fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name
+    print_out_type arg
+
+let out_label = ref print_out_label
+
+let out_type = ref print_out_type
+
+(* Class types *)
+
+let print_type_parameter ppf s =
+  if s = "_" then fprintf ppf "_" else pr_var ppf s
+
+let type_parameter ppf (ty, (co, cn)) =
+  fprintf ppf "%s%a"
+    (if not cn then "+" else if not co then "-" else "")
+    print_type_parameter ty
+
+let print_out_class_params ppf =
+  function
+    [] -> ()
+  | tyl ->
+      fprintf ppf "@[<1>[%a]@]@ "
+        (print_list type_parameter (fun ppf -> fprintf ppf ", "))
+        tyl
+
+let rec print_out_class_type ppf =
+  function
+    Octy_constr (id, tyl) ->
+      let pr_tyl ppf =
+        function
+          [] -> ()
+        | tyl ->
+            fprintf ppf "@[<1>[%a]@]@ " (print_typlist !out_type ",") tyl
+      in
+      fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id
+  | Octy_arrow (lab, ty, cty) ->
+      fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "")
+        print_out_type_2 ty print_out_class_type cty
+  | Octy_signature (self_ty, csil) ->
+      let pr_param ppf =
+        function
+          Some ty -> fprintf ppf "@ @[(%a)@]" !out_type ty
+        | None -> ()
+      in
+      fprintf ppf "@[<hv 2>@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty
+        (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ "))
+        csil
+and print_out_class_sig_item ppf =
+  function
+    Ocsg_constraint (ty1, ty2) ->
+      fprintf ppf "@[<2>constraint %a =@ %a@]" !out_type ty1
+        !out_type ty2
+  | Ocsg_method (name, priv, virt, ty) ->
+      fprintf ppf "@[<2>method %s%s%s :@ %a@]"
+        (if priv then "private " else "") (if virt then "virtual " else "")
+        name !out_type ty
+  | Ocsg_value (name, mut, vr, ty) ->
+      fprintf ppf "@[<2>val %s%s%s :@ %a@]"
+        (if mut then "mutable " else "")
+        (if vr then "virtual " else "")
+        name !out_type ty
+
+let out_class_type = ref print_out_class_type
+
+(* Signature *)
+
+let out_module_type = ref (fun _ -> failwith "Oprint.out_module_type")
+let out_sig_item = ref (fun _ -> failwith "Oprint.out_sig_item")
+let out_signature = ref (fun _ -> failwith "Oprint.out_signature")
+let out_type_extension = ref (fun _ -> failwith "Oprint.out_type_extension")
+
+(* For anonymous functor arguments, the logic to choose between
+   the long-form
+     functor (_ : S) -> ...
+   and the short-form
+     S -> ...
+   is as follows: if we are already printing long-form functor arguments,
+   we use the long form unless all remaining functor arguments can use
+   the short form. (Otherwise use the short form.)
+
+   For example,
+     functor (X : S1) (_ : S2) (Y : S3) (_ : S4) (_ : S5) -> sig end
+   will get printed as
+     functor (X : S1) (_ : S2) (Y : S3) -> S4 -> S5 -> sig end
+
+   but
+     functor (_ : S1) (_ : S2) (Y : S3) (_ : S4) (_ : S5) -> sig end
+   gets printed as
+     S1 -> S2 -> functor (Y : S3) -> S4 -> S5 -> sig end
+*)
+
+(* take a module type that may be a functor type,
+   and return the longest prefix list of arguments
+   that should be printed in long form. *)
+let collect_functor_arguments mty =
+  let rec collect_args acc = function
+    | Omty_functor (param, mty_res) ->
+       collect_args (param :: acc) mty_res
+    | non_functor -> (acc, non_functor)
+  in
+  let rec uncollect_anonymous_suffix acc rest = match acc with
+      | Some (None, mty_arg) :: acc ->
+          uncollect_anonymous_suffix acc
+            (Omty_functor (Some (None, mty_arg), rest))
+      | _ :: _ | [] ->
+         (acc, rest)
+  in
+  let (acc, non_functor) = collect_args [] mty in
+  let (acc, rest) = uncollect_anonymous_suffix acc non_functor in
+  (List.rev acc, rest)
+
+let rec print_out_module_type ppf mty =
+  print_out_functor ppf mty
+and print_out_functor ppf = function
+  | Omty_functor _ as t ->
+     let rec print_functor ppf = function
+       | Omty_functor (Some (None, mty_arg), mty_res) ->
+          fprintf ppf "%a ->@ %a"
+            print_simple_out_module_type mty_arg
+            print_functor mty_res
+       | Omty_functor _ as non_anonymous_functor ->
+          let (args, rest) = collect_functor_arguments non_anonymous_functor in
+          let print_arg ppf = function
+            | None ->
+               fprintf ppf "()"
+            | Some (param, mty) ->
+               fprintf ppf "(%s : %a)"
+                 (Option.value param ~default:"_")
+                 print_out_module_type mty
+          in
+          fprintf ppf "@[<2>functor@ %a@]@ ->@ %a"
+            (pp_print_list ~pp_sep:pp_print_space print_arg) args
+            print_functor rest
+       | non_functor ->
+          print_simple_out_module_type ppf non_functor
+     in
+     fprintf ppf "@[<2>%a@]" print_functor t
+  | t -> print_simple_out_module_type ppf t
+and print_simple_out_module_type ppf =
+  function
+    Omty_abstract -> ()
+  | Omty_ident id -> fprintf ppf "%a" print_ident id
+  | Omty_signature sg ->
+     begin match sg with
+       | [] -> fprintf ppf "sig end"
+       | sg ->
+          fprintf ppf "@[<hv 2>sig@ %a@;<1 -2>end@]" print_out_signature sg
+     end
+  | Omty_alias id -> fprintf ppf "(module %a)" print_ident id
+  | Omty_functor _ as non_simple ->
+     fprintf ppf "(%a)" print_out_module_type non_simple
+and print_out_signature ppf =
+  function
+    [] -> ()
+  | [item] -> !out_sig_item ppf item
+  | Osig_typext(ext, Oext_first) :: items ->
+      (* Gather together the extension constructors *)
+      let rec gather_extensions acc items =
+        match items with
+            Osig_typext(ext, Oext_next) :: items ->
+              gather_extensions
+                ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc)
+                items
+          | _ -> (List.rev acc, items)
+      in
+      let exts, items =
+        gather_extensions
+          [(ext.oext_name, ext.oext_args, ext.oext_ret_type)]
+          items
+      in
+      let te =
+        { otyext_name = ext.oext_type_name;
+          otyext_params = ext.oext_type_params;
+          otyext_constructors = exts;
+          otyext_private = ext.oext_private }
+      in
+        fprintf ppf "%a@ %a" !out_type_extension te print_out_signature items
+  | item :: items ->
+      fprintf ppf "%a@ %a" !out_sig_item item print_out_signature items
+and print_out_sig_item ppf =
+  function
+    Osig_class (vir_flag, name, params, clt, rs) ->
+      fprintf ppf "@[<2>%s%s@ %a%s@ :@ %a@]"
+        (if rs = Orec_next then "and" else "class")
+        (if vir_flag then " virtual" else "") print_out_class_params params
+        name !out_class_type clt
+  | Osig_class_type (vir_flag, name, params, clt, rs) ->
+      fprintf ppf "@[<2>%s%s@ %a%s@ =@ %a@]"
+        (if rs = Orec_next then "and" else "class type")
+        (if vir_flag then " virtual" else "") print_out_class_params params
+        name !out_class_type clt
+  | Osig_typext (ext, Oext_exception) ->
+      fprintf ppf "@[<2>exception %a@]"
+        print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type)
+  | Osig_typext (ext, _es) ->
+      print_out_extension_constructor ppf ext
+  | Osig_modtype (name, Omty_abstract) ->
+      fprintf ppf "@[<2>module type %s@]" name
+  | Osig_modtype (name, mty) ->
+      fprintf ppf "@[<2>module type %s =@ %a@]" name !out_module_type mty
+  | Osig_module (name, Omty_alias id, _) ->
+      fprintf ppf "@[<2>module %s =@ %a@]" name print_ident id
+  | Osig_module (name, mty, rs) ->
+      fprintf ppf "@[<2>%s %s :@ %a@]"
+        (match rs with Orec_not -> "module"
+                     | Orec_first -> "module rec"
+                     | Orec_next -> "and")
+        name !out_module_type mty
+  | Osig_type(td, rs) ->
+        print_out_type_decl
+          (match rs with
+           | Orec_not   -> "type nonrec"
+           | Orec_first -> "type"
+           | Orec_next  -> "and")
+          ppf td
+  | Osig_value vd ->
+      let kwd = if vd.oval_prims = [] then "val" else "external" in
+      let pr_prims ppf =
+        function
+          [] -> ()
+        | s :: sl ->
+            fprintf ppf "@ = \"%s\"" s;
+            List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl
+      in
+      fprintf ppf "@[<2>%s %a :@ %a%a%a@]" kwd value_ident vd.oval_name
+        !out_type vd.oval_type pr_prims vd.oval_prims
+        (fun ppf -> List.iter (fun a -> fprintf ppf "@ [@@@@%s]" a.oattr_name))
+        vd.oval_attributes
+  | Osig_ellipsis ->
+      fprintf ppf "..."
+
+and print_out_type_decl kwd ppf td =
+  let print_constraints ppf =
+    List.iter
+      (fun (ty1, ty2) ->
+         fprintf ppf "@ @[<2>constraint %a =@ %a@]" !out_type ty1
+           !out_type ty2)
+      td.otype_cstrs
+  in
+  let type_defined ppf =
+    match td.otype_params with
+      [] -> pp_print_string ppf td.otype_name
+    | [param] -> fprintf ppf "@[%a@ %s@]" type_parameter param td.otype_name
+    | _ ->
+        fprintf ppf "@[(@[%a)@]@ %s@]"
+          (print_list type_parameter (fun ppf -> fprintf ppf ",@ "))
+          td.otype_params
+          td.otype_name
+  in
+  let print_manifest ppf =
+    function
+      Otyp_manifest (ty, _) -> fprintf ppf " =@ %a" !out_type ty
+    | _ -> ()
+  in
+  let print_name_params ppf =
+    fprintf ppf "%s %t%a" kwd type_defined print_manifest td.otype_type
+  in
+  let ty =
+    match td.otype_type with
+      Otyp_manifest (_, ty) -> ty
+    | _ -> td.otype_type
+  in
+  let print_private ppf = function
+    Asttypes.Private -> fprintf ppf " private"
+  | Asttypes.Public -> ()
+  in
+  let print_immediate ppf =
+    match td.otype_immediate with
+    | Unknown -> ()
+    | Always -> fprintf ppf " [%@%@immediate]"
+    | Always_on_64bits -> fprintf ppf " [%@%@immediate64]"
+  in
+  let print_unboxed ppf =
+    if td.otype_unboxed then fprintf ppf " [%@%@unboxed]" else ()
+  in
+  let print_out_tkind ppf = function
+  | Otyp_abstract -> ()
+  | Otyp_record lbls ->
+      fprintf ppf " =%a %a"
+        print_private td.otype_private
+        print_record_decl lbls
+  | Otyp_sum constrs ->
+      let variants fmt constrs =
+        if constrs = [] then fprintf fmt "|" else
+        fprintf fmt "%a" (print_list print_out_constr
+          (fun ppf -> fprintf ppf "@ | ")) constrs in
+      fprintf ppf " =%a@;<1 2>%a"
+        print_private td.otype_private variants constrs
+  | Otyp_open ->
+      fprintf ppf " =%a .."
+        print_private td.otype_private
+  | ty ->
+      fprintf ppf " =%a@;<1 2>%a"
+        print_private td.otype_private
+        !out_type ty
+  in
+  fprintf ppf "@[<2>@[<hv 2>%t%a@]%t%t%t@]"
+    print_name_params
+    print_out_tkind ty
+    print_constraints
+    print_immediate
+    print_unboxed
+
+and print_out_constr ppf (name, tyl,ret_type_opt) =
+  let name =
+    match name with
+    | "::" -> "(::)"   (* #7200 *)
+    | s -> s
+  in
+  match ret_type_opt with
+  | None ->
+      begin match tyl with
+      | [] ->
+          pp_print_string ppf name
+      | _ ->
+          fprintf ppf "@[<2>%s of@ %a@]" name
+            (print_typlist print_simple_out_type " *") tyl
+      end
+  | Some ret_type ->
+      begin match tyl with
+      | [] ->
+          fprintf ppf "@[<2>%s :@ %a@]" name print_simple_out_type  ret_type
+      | _ ->
+          fprintf ppf "@[<2>%s :@ %a -> %a@]" name
+            (print_typlist print_simple_out_type " *")
+            tyl print_simple_out_type ret_type
+      end
+
+and print_out_extension_constructor ppf ext =
+  let print_extended_type ppf =
+      match ext.oext_type_params with
+        [] -> fprintf ppf "%s" ext.oext_type_name
+      | [ty_param] ->
+        fprintf ppf "@[%a@ %s@]"
+          print_type_parameter
+          ty_param
+          ext.oext_type_name
+      | _ ->
+        fprintf ppf "@[(@[%a)@]@ %s@]"
+          (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ "))
+          ext.oext_type_params
+          ext.oext_type_name
+  in
+  fprintf ppf "@[<hv 2>type %t +=%s@;<1 2>%a@]"
+    print_extended_type
+    (if ext.oext_private = Asttypes.Private then " private" else "")
+    print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type)
+
+and print_out_type_extension ppf te =
+  let print_extended_type ppf =
+    match te.otyext_params with
+      [] -> fprintf ppf "%s" te.otyext_name
+    | [param] ->
+      fprintf ppf "@[%a@ %s@]"
+        print_type_parameter param
+        te.otyext_name
+    | _ ->
+        fprintf ppf "@[(@[%a)@]@ %s@]"
+          (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ "))
+          te.otyext_params
+          te.otyext_name
+  in
+  fprintf ppf "@[<hv 2>type %t +=%s@;<1 2>%a@]"
+    print_extended_type
+    (if te.otyext_private = Asttypes.Private then " private" else "")
+    (print_list print_out_constr (fun ppf -> fprintf ppf "@ | "))
+    te.otyext_constructors
+
+let out_constr = ref print_out_constr
+let _ = out_module_type := print_out_module_type
+let _ = out_signature := print_out_signature
+let _ = out_sig_item := print_out_sig_item
+let _ = out_type_extension := print_out_type_extension
+
+(* Phrases *)
+
+let print_out_exception ppf exn outv =
+  match exn with
+    Sys.Break -> fprintf ppf "Interrupted.@."
+  | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@."
+  | Stack_overflow ->
+      fprintf ppf "Stack overflow during evaluation (looping recursion?).@."
+  | _ -> match Printexc.use_printers exn with
+        | None -> fprintf ppf "@[Exception:@ %a.@]@." !out_value outv
+        | Some s -> fprintf ppf "@[Exception:@ %s@]@." s
+
+let rec print_items ppf =
+  function
+    [] -> ()
+  | (Osig_typext(ext, Oext_first), None) :: items ->
+      (* Gather together extension constructors *)
+      let rec gather_extensions acc items =
+        match items with
+            (Osig_typext(ext, Oext_next), None) :: items ->
+              gather_extensions
+                ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc)
+                items
+          | _ -> (List.rev acc, items)
+      in
+      let exts, items =
+        gather_extensions
+          [(ext.oext_name, ext.oext_args, ext.oext_ret_type)]
+          items
+      in
+      let te =
+        { otyext_name = ext.oext_type_name;
+          otyext_params = ext.oext_type_params;
+          otyext_constructors = exts;
+          otyext_private = ext.oext_private }
+      in
+        fprintf ppf "@[%a@]" !out_type_extension te;
+        if items <> [] then fprintf ppf "@ %a" print_items items
+  | (tree, valopt) :: items ->
+      begin match valopt with
+        Some v ->
+          fprintf ppf "@[<2>%a =@ %a@]" !out_sig_item tree
+            !out_value v
+      | None -> fprintf ppf "@[%a@]" !out_sig_item tree
+      end;
+      if items <> [] then fprintf ppf "@ %a" print_items items
+
+let print_out_phrase ppf =
+  function
+    Ophr_eval (outv, ty) ->
+      fprintf ppf "@[- : %a@ =@ %a@]@." !out_type ty !out_value outv
+  | Ophr_signature [] -> ()
+  | Ophr_signature items -> fprintf ppf "@[<v>%a@]@." print_items items
+  | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv
+
+let out_phrase = ref print_out_phrase
diff --git a/upstream/ocaml_411/typing/oprint.mli b/upstream/ocaml_411/typing/oprint.mli
new file mode 100644
index 0000000..2eaaa26
--- /dev/null
+++ b/upstream/ocaml_411/typing/oprint.mli
@@ -0,0 +1,32 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Projet Cristal, INRIA Rocquencourt                   *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Format
+open Outcometree
+
+val out_ident : (formatter -> out_ident -> unit) ref
+val out_value : (formatter -> out_value -> unit) ref
+val out_label : (formatter -> string * bool * out_type -> unit) ref
+val out_type : (formatter -> out_type -> unit) ref
+val out_constr :
+  (formatter -> string * out_type list * out_type option -> unit) ref
+val out_class_type : (formatter -> out_class_type -> unit) ref
+val out_module_type : (formatter -> out_module_type -> unit) ref
+val out_sig_item : (formatter -> out_sig_item -> unit) ref
+val out_signature : (formatter -> out_sig_item list -> unit) ref
+val out_type_extension : (formatter -> out_type_extension -> unit) ref
+val out_phrase : (formatter -> out_phrase -> unit) ref
+
+val parenthesized_ident : string -> bool
diff --git a/upstream/ocaml_411/typing/outcometree.mli b/upstream/ocaml_411/typing/outcometree.mli
new file mode 100644
index 0000000..bb53d23
--- /dev/null
+++ b/upstream/ocaml_411/typing/outcometree.mli
@@ -0,0 +1,148 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*      Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt          *)
+(*                                                                        *)
+(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Module [Outcometree]: results displayed by the toplevel *)
+
+(* These types represent messages that the toplevel displays as normal
+   results or errors. The real displaying is customisable using the hooks:
+      [Toploop.print_out_value]
+      [Toploop.print_out_type]
+      [Toploop.print_out_sig_item]
+      [Toploop.print_out_phrase] *)
+
+(** An [out_name] is a string representation of an identifier which can be
+    rewritten on the fly to avoid name collisions *)
+type out_name = { mutable printed_name: string }
+
+type out_ident =
+  | Oide_apply of out_ident * out_ident
+  | Oide_dot of out_ident * string
+  | Oide_ident of out_name
+
+type out_string =
+  | Ostr_string
+  | Ostr_bytes
+
+type out_attribute =
+  { oattr_name: string }
+
+type out_value =
+  | Oval_array of out_value list
+  | Oval_char of char
+  | Oval_constr of out_ident * out_value list
+  | Oval_ellipsis
+  | Oval_float of float
+  | Oval_int of int
+  | Oval_int32 of int32
+  | Oval_int64 of int64
+  | Oval_nativeint of nativeint
+  | Oval_list of out_value list
+  | Oval_printer of (Format.formatter -> unit)
+  | Oval_record of (out_ident * out_value) list
+  | Oval_string of string * int * out_string (* string, size-to-print, kind *)
+  | Oval_stuff of string
+  | Oval_tuple of out_value list
+  | Oval_variant of string * out_value option
+
+type out_type =
+  | Otyp_abstract
+  | Otyp_open
+  | Otyp_alias of out_type * string
+  | Otyp_arrow of string * out_type * out_type
+  | Otyp_class of bool * out_ident * out_type list
+  | Otyp_constr of out_ident * out_type list
+  | Otyp_manifest of out_type * out_type
+  | Otyp_object of (string * out_type) list * bool option
+  | Otyp_record of (string * bool * out_type) list
+  | Otyp_stuff of string
+  | Otyp_sum of (string * out_type list * out_type option) list
+  | Otyp_tuple of out_type list
+  | Otyp_var of bool * string
+  | Otyp_variant of
+      bool * out_variant * bool * (string list) option
+  | Otyp_poly of string list * out_type
+  | Otyp_module of out_ident * string list * out_type list
+  | Otyp_attribute of out_type * out_attribute
+
+and out_variant =
+  | Ovar_fields of (string * bool * out_type list) list
+  | Ovar_typ of out_type
+
+type out_class_type =
+  | Octy_constr of out_ident * out_type list
+  | Octy_arrow of string * out_type * out_class_type
+  | Octy_signature of out_type option * out_class_sig_item list
+and out_class_sig_item =
+  | Ocsg_constraint of out_type * out_type
+  | Ocsg_method of string * bool * bool * out_type
+  | Ocsg_value of string * bool * bool * out_type
+
+type out_module_type =
+  | Omty_abstract
+  | Omty_functor of (string option * out_module_type) option * out_module_type
+  | Omty_ident of out_ident
+  | Omty_signature of out_sig_item list
+  | Omty_alias of out_ident
+and out_sig_item =
+  | Osig_class of
+      bool * string * (string * (bool * bool)) list * out_class_type *
+        out_rec_status
+  | Osig_class_type of
+      bool * string * (string * (bool * bool)) list * out_class_type *
+        out_rec_status
+  | Osig_typext of out_extension_constructor * out_ext_status
+  | Osig_modtype of string * out_module_type
+  | Osig_module of string * out_module_type * out_rec_status
+  | Osig_type of out_type_decl * out_rec_status
+  | Osig_value of out_val_decl
+  | Osig_ellipsis
+and out_type_decl =
+  { otype_name: string;
+    otype_params: (string * (bool * bool)) list;
+    otype_type: out_type;
+    otype_private: Asttypes.private_flag;
+    otype_immediate: Type_immediacy.t;
+    otype_unboxed: bool;
+    otype_cstrs: (out_type * out_type) list }
+and out_extension_constructor =
+  { oext_name: string;
+    oext_type_name: string;
+    oext_type_params: string list;
+    oext_args: out_type list;
+    oext_ret_type: out_type option;
+    oext_private: Asttypes.private_flag }
+and out_type_extension =
+  { otyext_name: string;
+    otyext_params: string list;
+    otyext_constructors: (string * out_type list * out_type option) list;
+    otyext_private: Asttypes.private_flag }
+and out_val_decl =
+  { oval_name: string;
+    oval_type: out_type;
+    oval_prims: string list;
+    oval_attributes: out_attribute list }
+and out_rec_status =
+  | Orec_not
+  | Orec_first
+  | Orec_next
+and out_ext_status =
+  | Oext_first
+  | Oext_next
+  | Oext_exception
+
+type out_phrase =
+  | Ophr_eval of out_value * out_type
+  | Ophr_signature of (out_sig_item * out_value option) list
+  | Ophr_exception of (exn * out_value)
diff --git a/upstream/ocaml_411/typing/parmatch.ml b/upstream/ocaml_411/typing/parmatch.ml
new file mode 100644
index 0000000..1209ef8
--- /dev/null
+++ b/upstream/ocaml_411/typing/parmatch.ml
@@ -0,0 +1,2650 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Detection of partial matches and unused match cases. *)
+
+open Misc
+open Asttypes
+open Types
+open Typedtree
+
+(*************************************)
+(* Utilities for building patterns   *)
+(*************************************)
+
+let make_pat desc ty tenv =
+  {pat_desc = desc; pat_loc = Location.none; pat_extra = [];
+   pat_type = ty ; pat_env = tenv;
+   pat_attributes = [];
+  }
+
+let omega = make_pat Tpat_any Ctype.none Env.empty
+
+let extra_pat =
+  make_pat
+    (Tpat_var (Ident.create_local "+", mknoloc "+"))
+    Ctype.none Env.empty
+
+let rec omegas i =
+  if i <= 0 then [] else omega :: omegas (i-1)
+
+let omega_list l = List.map (fun _ -> omega) l
+
+module Pattern_head : sig
+  type desc =
+    | Any
+    | Construct of constructor_description
+    | Constant of constant
+    | Tuple of int
+    | Record of label_description list
+    | Variant of
+        { tag: label; has_arg: bool;
+          cstr_row: row_desc ref;
+          type_row : unit -> row_desc; }
+          (* the row of the type may evolve if [close_variant] is called,
+             hence the (unit -> ...) delay *)
+    | Array of int
+    | Lazy
+
+  type t
+
+  val desc : t -> desc
+  val env : t -> Env.t
+  val loc : t -> Location.t
+  val typ : t -> Types.type_expr
+
+  (** [deconstruct p] returns the head of [p] and the list of sub patterns.
+
+      @raises [Invalid_arg _] if [p] is an or- or an exception-pattern.  *)
+  val deconstruct : pattern -> t * pattern list
+
+  (** reconstructs a pattern, putting wildcards as sub-patterns. *)
+  val to_omega_pattern : t -> pattern
+
+  val make
+    :  loc:Location.t
+    -> typ:Types.type_expr
+    -> env:Env.t
+    -> desc
+    -> t
+
+  val omega : t
+
+end = struct
+  type desc =
+    | Any
+    | Construct of constructor_description
+    | Constant of constant
+    | Tuple of int
+    | Record of label_description list
+    | Variant of
+        { tag: label;
+          has_arg: bool;
+          cstr_row: row_desc ref;
+          type_row: unit -> row_desc; }
+    | Array of int
+    | Lazy
+
+  type t = {
+    desc: desc;
+    typ : Types.type_expr;
+    loc : Location.t;
+    env : Env.t;
+    attributes : attributes;
+  }
+
+  let desc { desc } = desc
+  let env { env } = env
+  let loc { loc } = loc
+  let typ { typ } = typ
+
+  let deconstruct q =
+    let rec deconstruct_desc = function
+      | Tpat_any
+      | Tpat_var _ -> Any, []
+      | Tpat_constant c -> Constant c, []
+      | Tpat_alias (p,_,_) -> deconstruct_desc p.pat_desc
+      | Tpat_tuple args ->
+          Tuple (List.length args), args
+      | Tpat_construct (_, c, args) ->
+          Construct c, args
+      | Tpat_variant (tag, arg, cstr_row) ->
+          let has_arg, pats =
+            match arg with
+            | None -> false, []
+            | Some a -> true, [a]
+          in
+          let type_row () =
+            match Ctype.expand_head q.pat_env q.pat_type with
+              | {desc = Tvariant type_row} -> Btype.row_repr type_row
+              | _ -> assert false
+          in
+          Variant {tag; has_arg; cstr_row; type_row}, pats
+      | Tpat_array args ->
+          Array (List.length args), args
+      | Tpat_record (largs, _) ->
+          let lbls = List.map (fun (_,lbl,_) -> lbl) largs in
+          let pats = List.map (fun (_,_,pat) -> pat) largs in
+          Record lbls, pats
+      | Tpat_lazy p ->
+          Lazy, [p]
+      | Tpat_or _ -> invalid_arg "Parmatch.Pattern_head.deconstruct: (P | Q)"
+    in
+    let desc, pats = deconstruct_desc q.pat_desc in
+    { desc; typ = q.pat_type; loc = q.pat_loc;
+      env = q.pat_env; attributes = q.pat_attributes }, pats
+
+  let to_omega_pattern t =
+    let pat_desc =
+      match t.desc with
+      | Any -> Tpat_any
+      | Lazy -> Tpat_lazy omega
+      | Constant c -> Tpat_constant c
+      | Tuple n -> Tpat_tuple (omegas n)
+      | Array n -> Tpat_array (omegas n)
+      | Construct c ->
+          let lid_loc = Location.mkloc (Longident.Lident c.cstr_name) t.loc in
+          Tpat_construct (lid_loc, c, omegas c.cstr_arity)
+      | Variant { tag; has_arg; cstr_row } ->
+          let arg_opt = if has_arg then Some omega else None in
+          Tpat_variant (tag, arg_opt, cstr_row)
+      | Record lbls ->
+          let lst =
+            List.map (fun lbl ->
+              let lid_loc =
+                Location.mkloc (Longident.Lident lbl.lbl_name) t.loc
+              in
+              (lid_loc, lbl, omega)
+            ) lbls
+          in
+          Tpat_record (lst, Closed)
+    in
+    { pat_desc; pat_type = t.typ; pat_loc = t.loc; pat_extra = [];
+      pat_env = t.env; pat_attributes = t.attributes }
+
+  let make ~loc ~typ ~env desc =
+    { desc; loc; typ; env; attributes = [] }
+
+  let omega =
+    { desc = Any
+    ; loc = Location.none
+    ; typ = Ctype.none
+    ; env = Env.empty
+    ; attributes = []
+    }
+end
+
+(*
+  Normalize a pattern ->
+   all arguments are omega (simple pattern) and no more variables
+*)
+
+let normalize_pat p = Pattern_head.(to_omega_pattern @@ fst @@ deconstruct p)
+
+(*******************)
+(* Coherence check *)
+(*******************)
+
+(* For some of the operations we do in this module, we would like (because it
+   simplifies matters) to assume that patterns appearing on a given column in a
+   pattern matrix are /coherent/ (think "of the same type").
+   Unfortunately that is not always true.
+
+   Consider the following (well-typed) example:
+   {[
+     type _ t = S : string t | U : unit t
+
+     let f (type a) (t1 : a t) (t2 : a t) (a : a) =
+       match t1, t2, a with
+       | U, _, () -> ()
+       | _, S, "" -> ()
+   ]}
+
+   Clearly the 3rd column contains incoherent patterns.
+
+   On the example above, most of the algorithms will explore the pattern matrix
+   as illustrated by the following tree:
+
+   {v
+                                                   S
+                                                -------> | "" |
+                             U     | S, "" | __/         | () |
+                         --------> | _, () |   \ not S
+        | U, _, () | __/                        -------> | () |
+        | _, S, "" |   \
+                        ---------> | S, "" | ----------> | "" |
+                          not U                    S
+   v}
+
+   where following an edge labelled by a pattern P means "assuming the value I
+   am matching on is filtered by [P] on the column I am currently looking at,
+   then the following submatrix is still reachable".
+
+   Notice that at any point of that tree, if the first column of a matrix is
+   incoherent, then the branch leading to it can only be taken if the scrutinee
+   is ill-typed.
+   In the example above the only case where we have a matrix with an incoherent
+   first column is when we consider [t1, t2, a] to be [U, S, ...]. However such
+   a value would be ill-typed, so we can never actually get there.
+
+   Checking the first column at each step of the recursion and making the
+   conscious decision of "aborting" the algorithm whenever the first column
+   becomes incoherent, allows us to retain the initial assumption in later
+   stages of the algorithms.
+
+   ---
+
+   N.B. two patterns can be considered coherent even though they might not be of
+   the same type.
+
+   That's in part because we only care about the "head" of patterns and leave
+   checking coherence of subpatterns for the next steps of the algorithm:
+   ('a', 'b') and (1, ()) will be deemed coherent because they are both a tuples
+   of arity 2 (we'll notice at a later stage the incoherence of 'a' and 1).
+
+   But also because it can be hard/costly to determine exactly whether two
+   patterns are of the same type or not (eg. in the example above with _ and S,
+   but see also the module [Coherence_illustration] in
+   testsuite/tests/basic-more/robustmatch.ml).
+
+   For the moment our weak, loosely-syntactic, coherence check seems to be
+   enough and we leave it to each user to consider (and document!) what happens
+   when an "incoherence" is not detected by this check.
+*)
+
+(* Given the first column of a simplified matrix, this function first looks for
+   a "discriminating" pattern on that column (i.e. a non-omega one) and then
+   check that every other head pattern in the column is coherent with that one.
+*)
+let all_coherent column =
+  let coherent_heads hp1 hp2 =
+    match Pattern_head.desc hp1, Pattern_head.desc hp2 with
+    | Construct c, Construct c' ->
+      c.cstr_consts = c'.cstr_consts
+      && c.cstr_nonconsts = c'.cstr_nonconsts
+    | Constant c1, Constant c2 -> begin
+        match c1, c2 with
+        | Const_char _, Const_char _
+        | Const_int _, Const_int _
+        | Const_int32 _, Const_int32 _
+        | Const_int64 _, Const_int64 _
+        | Const_nativeint _, Const_nativeint _
+        | Const_float _, Const_float _
+        | Const_string _, Const_string _ -> true
+        | ( Const_char _
+          | Const_int _
+          | Const_int32 _
+          | Const_int64 _
+          | Const_nativeint _
+          | Const_float _
+          | Const_string _), _ -> false
+      end
+    | Tuple l1, Tuple l2 -> l1 = l2
+    | Record (lbl1 :: _), Record (lbl2 :: _) ->
+      Array.length lbl1.lbl_all = Array.length lbl2.lbl_all
+    | Any, _
+    | _, Any
+    | Record [], Record []
+    | Variant _, Variant _
+    | Array _, Array _
+    | Lazy, Lazy -> true
+    | _, _ -> false
+  in
+  match
+    List.find (fun head_pat ->
+      match Pattern_head.desc head_pat with
+      | Any -> false
+      | _ -> true
+    ) column
+  with
+  | exception Not_found ->
+    (* only omegas on the column: the column is coherent. *)
+    true
+  | discr_pat ->
+    List.for_all (coherent_heads discr_pat) column
+
+let first_column simplified_matrix =
+  List.map (fun ((head, _args), _rest) -> head) simplified_matrix
+
+(***********************)
+(* Compatibility check *)
+(***********************)
+
+(* Patterns p and q compatible means:
+   there exists value V that matches both, However....
+
+  The case of extension types is dubious, as constructor rebind permits
+  that different constructors are the same (and are thus compatible).
+
+  Compilation must take this into account, consider:
+
+  type t = ..
+  type t += A|B
+  type t += C=A
+
+  let f x y = match x,y with
+  | true,A  -> '1'
+  | _,C     -> '2'
+  | false,A -> '3'
+  | _,_     -> '_'
+
+  As C is bound to A the value of f false A is '2' (and not '3' as it would
+  be in the absence of rebinding).
+
+  Not considering rebinding, patterns "false,A" and "_,C" are incompatible
+  and the compiler can swap the second and third clause, resulting in the
+  (more efficiently compiled) matching
+
+  match x,y with
+  | true,A  -> '1'
+  | false,A -> '3'
+  | _,C     -> '2'
+  | _,_     -> '_'
+
+  This is not correct: when C is bound to A, "f false A" returns '2' (not '3')
+
+
+  However, diagnostics do not take constructor rebinding into account.
+  Notice, that due to module abstraction constructor rebinding is hidden.
+
+  module X : sig type t = .. type t += A|B end = struct
+    type t = ..
+    type t += A
+    type t += B=A
+  end
+
+  open X
+
+  let f x = match x with
+  | A -> '1'
+  | B -> '2'
+  | _ -> '_'
+
+  The second clause above will NOT (and cannot) be flagged as useless.
+
+  Finally, there are two compatibility functions:
+   compat p q      ---> 'syntactic compatibility, used for diagnostics.
+   may_compat p q --->   a safe approximation of possible compat,
+                         for compilation
+
+*)
+
+
+let is_absent tag row = Btype.row_field tag !row = Rabsent
+
+let is_absent_pat d =
+  match Pattern_head.desc d with
+  | Variant { tag; cstr_row; _ } -> is_absent tag cstr_row
+  | _ -> false
+
+let const_compare x y =
+  match x,y with
+  | Const_float f1, Const_float f2 ->
+      Stdlib.compare (float_of_string f1) (float_of_string f2)
+  | Const_string (s1, _, _), Const_string (s2, _, _) ->
+      String.compare s1 s2
+  | (Const_int _
+    |Const_char _
+    |Const_string (_, _, _)
+    |Const_float _
+    |Const_int32 _
+    |Const_int64 _
+    |Const_nativeint _
+    ), _ -> Stdlib.compare x y
+
+let records_args l1 l2 =
+  (* Invariant: fields are already sorted by Typecore.type_label_a_list *)
+  let rec combine r1 r2 l1 l2 = match l1,l2 with
+  | [],[] -> List.rev r1, List.rev r2
+  | [],(_,_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2
+  | (_,_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 []
+  | (_,lbl1,p1)::rem1, ( _,lbl2,p2)::rem2 ->
+      if lbl1.lbl_pos < lbl2.lbl_pos then
+        combine (p1::r1) (omega::r2) rem1 l2
+      else if lbl1.lbl_pos > lbl2.lbl_pos then
+        combine (omega::r1) (p2::r2) l1 rem2
+      else (* same label on both sides *)
+        combine (p1::r1) (p2::r2) rem1 rem2 in
+  combine [] [] l1 l2
+
+
+
+module Compat
+    (Constr:sig
+      val equal :
+          Types.constructor_description ->
+            Types.constructor_description ->
+              bool
+    end) = struct
+
+  let rec compat p q = match p.pat_desc,q.pat_desc with
+(* Variables match any value *)
+  | ((Tpat_any|Tpat_var _),_)
+  | (_,(Tpat_any|Tpat_var _)) -> true
+(* Structural induction *)
+  | Tpat_alias (p,_,_),_      -> compat p q
+  | _,Tpat_alias (q,_,_)      -> compat p q
+  | Tpat_or (p1,p2,_),_ ->
+      (compat p1 q || compat p2 q)
+  | _,Tpat_or (q1,q2,_) ->
+      (compat p q1 || compat p q2)
+(* Constructors, with special case for extension *)
+  | Tpat_construct (_, c1,ps1), Tpat_construct (_, c2,ps2) ->
+      Constr.equal c1 c2 && compats ps1 ps2
+(* More standard stuff *)
+  | Tpat_variant(l1,op1, _), Tpat_variant(l2,op2,_) ->
+      l1=l2 && ocompat op1 op2
+  | Tpat_constant c1, Tpat_constant c2 ->
+      const_compare c1 c2 = 0
+  | Tpat_tuple ps, Tpat_tuple qs -> compats ps qs
+  | Tpat_lazy p, Tpat_lazy q -> compat p q
+  | Tpat_record (l1,_),Tpat_record (l2,_) ->
+      let ps,qs = records_args l1 l2 in
+      compats ps qs
+  | Tpat_array ps, Tpat_array qs ->
+      List.length ps = List.length qs &&
+      compats ps qs
+  | _,_  -> false
+
+  and ocompat op oq = match op,oq with
+  | None,None -> true
+  | Some p,Some q -> compat p q
+  | (None,Some _)|(Some _,None) -> false
+
+  and compats ps qs = match ps,qs with
+  | [], [] -> true
+  | p::ps, q::qs -> compat p q && compats ps qs
+  | _,_    -> false
+
+end
+
+module SyntacticCompat =
+  Compat
+    (struct
+      let equal c1 c2 =  Types.equal_tag c1.cstr_tag c2.cstr_tag
+    end)
+
+let compat =  SyntacticCompat.compat
+and compats = SyntacticCompat.compats
+
+(* Due to (potential) rebinding, two extension constructors
+   of the same arity type may equal *)
+
+exception Empty (* Empty pattern *)
+
+(****************************************)
+(* Utilities for retrieving type paths  *)
+(****************************************)
+
+(* May need a clean copy, cf. PR#4745 *)
+let clean_copy ty =
+  if ty.level = Btype.generic_level then ty
+  else Subst.type_expr Subst.identity ty
+
+let get_constructor_type_path ty tenv =
+  let ty = Ctype.repr (Ctype.expand_head tenv (clean_copy ty)) in
+  match ty.desc with
+  | Tconstr (path,_,_) -> path
+  | _ -> assert false
+
+(****************************)
+(* Utilities for matching   *)
+(****************************)
+
+(* Check top matching *)
+let simple_match d h =
+  match Pattern_head.desc d, Pattern_head.desc h with
+  | Construct c1, Construct c2 ->
+      Types.equal_tag c1.cstr_tag c2.cstr_tag
+  | Variant { tag = t1; _ }, Variant { tag = t2 } ->
+      t1 = t2
+  | Constant c1, Constant c2 -> const_compare c1 c2 = 0
+  | Lazy, Lazy -> true
+  | Record _, Record _ -> true
+  | Tuple len1, Tuple len2
+  | Array len1, Array len2 -> len1 = len2
+  | _, Any -> true
+  | _, _ -> false
+
+
+
+(* extract record fields as a whole *)
+let record_arg ph = match Pattern_head.desc ph with
+| Any -> []
+| Record args -> args
+| _ -> fatal_error "Parmatch.as_record"
+
+
+let extract_fields lbls arg =
+  let get_field pos arg =
+    match List.find (fun (lbl,_) -> pos = lbl.lbl_pos) arg with
+    | _, p -> p
+    | exception Not_found -> omega
+  in
+  List.map (fun lbl -> get_field lbl.lbl_pos arg) lbls
+
+(* Build argument list when p2 >= p1, where p1 is a simple pattern *)
+let simple_match_args discr head args = match Pattern_head.desc head with
+| Constant _ -> []
+| Construct _
+| Variant _
+| Tuple _
+| Array _
+| Lazy -> args
+| Record lbls ->  extract_fields (record_arg discr) (List.combine lbls args)
+| Any ->
+    begin match Pattern_head.desc discr with
+    | Construct cstr -> omegas cstr.cstr_arity
+    | Variant { has_arg = true }
+    | Lazy -> [omega]
+    | Record lbls ->  omega_list lbls
+    | Array len
+    | Tuple len -> omegas len
+    | Variant { has_arg = false }
+    | Any
+    | Constant _ -> []
+    end
+
+(* Consider a pattern matrix whose first column has been simplified to contain
+   only _ or a head constructor
+     | p1, r1...
+     | p2, r2...
+     | p3, r3...
+     | ...
+
+   We build a normalized /discriminating/ pattern from a pattern [q] by folding
+   over the first column of the matrix, "refining" [q] as we go:
+
+   - when we encounter a row starting with [Tuple] or [Lazy] then we
+   can stop and return that head, as we cannot refine any further. Indeed,
+   these constructors are alone in their signature, so they will subsume
+   whatever other head we might find, as well as the head we're threading
+   along.
+
+   - when we find a [Record] then it is a bit more involved: it is also alone
+   in its signature, however it might only be matching a subset of the
+   record fields. We use these fields to refine our accumulator and keep going
+   as another row might match on different fields.
+
+   - rows starting with a wildcard do not bring any information, so we ignore
+   them and keep going
+
+   - if we encounter anything else (i.e. any other constructor), then we just
+   stop and return our accumulator.
+*)
+let discr_pat q pss =
+  let rec refine_pat acc = function
+    | [] -> acc
+    | ((head, _), _) :: rows ->
+      match Pattern_head.desc head with
+      | Any -> refine_pat acc rows
+      | Tuple _ | Lazy -> head
+      | Record lbls ->
+        (* N.B. we could make this case "simpler" by refining the record case
+           using [all_record_args].
+           In which case we wouldn't need to fold over the first column for
+           records.
+           However it makes the witness we generate for the exhaustivity warning
+           less pretty. *)
+        let fields =
+          List.fold_right (fun lbl r ->
+            if List.exists (fun l -> l.lbl_pos = lbl.lbl_pos) r then
+              r
+            else
+              lbl :: r
+          ) lbls (record_arg acc)
+        in
+        let d =
+          let open Pattern_head in
+          make ~loc:(loc head) ~typ:(typ head) ~env:(env head) (Record fields)
+        in
+        refine_pat d rows
+      | _ -> acc
+  in
+  let q, _ = Pattern_head.deconstruct q in
+  match Pattern_head.desc q with
+  (* short-circuiting: clearly if we have anything other than [Record] or
+     [Any] to start with, we're not going to be able refine at all. So
+     there's no point going over the matrix. *)
+  | Any | Record _ -> refine_pat q pss
+  | _ -> q
+
+(*
+   In case a matching value is found, set actual arguments
+   of the matching pattern.
+*)
+
+let rec read_args xs r = match xs,r with
+| [],_ -> [],r
+| _::xs, arg::rest ->
+   let args,rest = read_args xs rest in
+   arg::args,rest
+| _,_ ->
+    fatal_error "Parmatch.read_args"
+
+let do_set_args ~erase_mutable q r = match q with
+| {pat_desc = Tpat_tuple omegas} ->
+    let args,rest = read_args omegas r in
+    make_pat (Tpat_tuple args) q.pat_type q.pat_env::rest
+| {pat_desc = Tpat_record (omegas,closed)} ->
+    let args,rest = read_args omegas r in
+    make_pat
+      (Tpat_record
+         (List.map2 (fun (lid, lbl,_) arg ->
+           if
+             erase_mutable &&
+             (match lbl.lbl_mut with
+             | Mutable -> true | Immutable -> false)
+           then
+             lid, lbl, omega
+           else
+             lid, lbl, arg)
+            omegas args, closed))
+      q.pat_type q.pat_env::
+    rest
+| {pat_desc = Tpat_construct (lid, c,omegas)} ->
+    let args,rest = read_args omegas r in
+    make_pat
+      (Tpat_construct (lid, c,args))
+      q.pat_type q.pat_env::
+    rest
+| {pat_desc = Tpat_variant (l, omega, row)} ->
+    let arg, rest =
+      match omega, r with
+        Some _, a::r -> Some a, r
+      | None, r -> None, r
+      | _ -> assert false
+    in
+    make_pat
+      (Tpat_variant (l, arg, row)) q.pat_type q.pat_env::
+    rest
+| {pat_desc = Tpat_lazy _omega} ->
+    begin match r with
+      arg::rest ->
+        make_pat (Tpat_lazy arg) q.pat_type q.pat_env::rest
+    | _ -> fatal_error "Parmatch.do_set_args (lazy)"
+    end
+| {pat_desc = Tpat_array omegas} ->
+    let args,rest = read_args omegas r in
+    make_pat
+      (Tpat_array args) q.pat_type q.pat_env::
+    rest
+| {pat_desc=Tpat_constant _|Tpat_any} ->
+    q::r (* case any is used in matching.ml *)
+| _ -> fatal_error "Parmatch.set_args"
+
+let set_args q r = do_set_args ~erase_mutable:false q r
+and set_args_erase_mutable q r = do_set_args ~erase_mutable:true q r
+
+(* Given a matrix of non-empty rows
+   p1 :: r1...
+   p2 :: r2...
+   p3 :: r3...
+
+   Simplify the first column [p1 p2 p3] by splitting all or-patterns.
+   The result is a list of pairs
+     ((pattern head, arguments), rest of row)
+
+   For example,
+     x :: r1
+     (Some _) as y :: r2
+     (None as x) as y :: r3
+     (Some x | (None as x)) :: r4
+   becomes
+     ((   _ , [ ] ), r1)
+     (( Some, [_] ), r2)
+     (( None, [ ] ), r3)
+     (( Some, [x] ), r4)
+     (( None, [ ] ), r4)
+ *)
+let simplify_head_pat ~add_column p ps k =
+  let rec simplify_head_pat p ps k =
+    match p.pat_desc with
+    | Tpat_alias (p,_,_) ->
+        (* We have to handle aliases here, because there can be or-patterns
+           underneath, that [Pattern_head.deconstruct] won't handle. *)
+        simplify_head_pat p ps k
+    | Tpat_or (p1,p2,_) -> simplify_head_pat p1 ps (simplify_head_pat p2 ps k)
+    | _ -> add_column (Pattern_head.deconstruct p) ps k
+  in simplify_head_pat p ps k
+
+let rec simplify_first_col = function
+  | [] -> []
+  | [] :: _ -> assert false (* the rows are non-empty! *)
+  | (p::ps) :: rows ->
+      let add_column p ps k = (p, ps) :: k in
+      simplify_head_pat ~add_column p ps (simplify_first_col rows)
+
+
+(* Builds the specialized matrix of [pss] according to the discriminating
+   pattern head [d].
+   See section 3.1 of http://moscova.inria.fr/~maranget/papers/warn/warn.pdf
+
+   NOTES:
+   - we are polymorphic on the type of matrices we work on, in particular a row
+   might not simply be a [pattern list]. That's why we have the [extend_row]
+   parameter.
+*)
+let build_specialized_submatrix ~extend_row discr pss =
+  let rec filter_rec = function
+    | ((head, args), ps) :: pss ->
+        if simple_match discr head
+        then extend_row (simple_match_args discr head args) ps :: filter_rec pss
+        else filter_rec pss
+    | _ -> [] in
+  filter_rec pss
+
+(* The "default" and "specialized" matrices of a given matrix.
+   See section 3.1 of http://moscova.inria.fr/~maranget/papers/warn/warn.pdf .
+*)
+type 'matrix specialized_matrices = {
+  default : 'matrix;
+  constrs : (Pattern_head.t * 'matrix) list;
+}
+
+(* Consider a pattern matrix whose first column has been simplified
+   to contain only _ or a head constructor
+     | p1, r1...
+     | p2, r2...
+     | p3, r3...
+     | ...
+
+   We split this matrix into a list of /specialized/ sub-matrices, one for
+   each head constructor appearing in the first column. For each row whose
+   first column starts with a head constructor, remove this head
+   column, prepend one column for each argument of the constructor,
+   and add the resulting row in the sub-matrix corresponding to this
+   head constructor.
+
+   Rows whose left column is omega (the Any pattern _) may match any
+   head constructor, so they are added to all sub-matrices.
+
+   In the case where all the rows in the matrix have an omega on their first
+   column, then there is only one /specialized/ sub-matrix, formed of all these
+   omega rows.
+   This matrix is also called the /default/ matrix.
+
+   See the documentation of [build_specialized_submatrix] for an explanation of
+   the [extend_row] parameter.
+*)
+let build_specialized_submatrices ~extend_row discr rows =
+  let extend_group discr p args r rs =
+    let r = extend_row (simple_match_args discr p args) r in
+    (discr, r :: rs)
+  in
+
+  (* insert a row of head [p] and rest [r] into the right group *)
+  let rec insert_constr head args r = function
+    | [] ->
+      (* if no group matched this row, it has a head constructor that
+         was never seen before; add a new sub-matrix for this head *)
+      [extend_group head head args r []]
+    | (q0,rs) as bd::env ->
+      if simple_match q0 head
+      then extend_group q0 head args r rs :: env
+      else bd :: insert_constr head args r env
+  in
+
+  (* insert a row of head omega into all groups *)
+  let insert_omega r env =
+    List.map (fun (q0,rs) -> extend_group q0 Pattern_head.omega [] r rs) env
+  in
+
+  let rec form_groups constr_groups omega_tails = function
+    | [] -> (constr_groups, omega_tails)
+    | ((head, args), tail) :: rest ->
+        match Pattern_head.desc head with
+        | Any ->
+            (* note that calling insert_omega here would be wrong
+               as some groups may not have been formed yet, if the
+               first row with this head pattern comes after in the list *)
+            form_groups constr_groups (tail :: omega_tails) rest
+        | _ ->
+            form_groups
+              (insert_constr head args tail constr_groups) omega_tails rest
+  in
+
+  let constr_groups, omega_tails =
+    let initial_constr_group =
+      match Pattern_head.desc discr with
+      | Record _ | Tuple _ | Lazy ->
+        (* [discr] comes from [discr_pat], and in this case subsumes any of the
+           patterns we could find on the first column of [rows]. So it is better
+           to use it for our initial environment than any of the normalized
+           pattern we might obtain from the first column. *)
+        [discr,[]]
+      | _ -> []
+    in
+    form_groups initial_constr_group [] rows
+  in
+  {
+    default = omega_tails;
+    constrs =
+      (* insert omega rows in all groups *)
+      List.fold_right insert_omega omega_tails constr_groups;
+  }
+
+(* Variant related functions *)
+
+let set_last a =
+  let rec loop = function
+    | [] -> assert false
+    | [_] -> [a]
+    | x::l -> x :: loop l
+  in
+  function
+  | (_, []) -> (Pattern_head.deconstruct a, [])
+  | (first, row) -> (first, loop row)
+
+(* mark constructor lines for failure when they are incomplete *)
+let mark_partial =
+  let zero = make_pat (Tpat_constant (Const_int 0)) Ctype.none Env.empty in
+  List.map (fun ((hp, _), _ as ps) ->
+    match Pattern_head.desc hp with
+    | Any -> ps
+    | _ -> set_last zero ps
+  )
+
+let close_variant env row =
+  let row = Btype.row_repr row in
+  let nm =
+    List.fold_left
+      (fun nm (_tag,f) ->
+        match Btype.row_field_repr f with
+        | Reither(_, _, false, e) ->
+            (* m=false means that this tag is not explicitly matched *)
+            Btype.set_row_field e Rabsent;
+            None
+        | Rabsent | Reither (_, _, true, _) | Rpresent _ -> nm)
+      row.row_name row.row_fields in
+  if not row.row_closed || nm != row.row_name then begin
+    (* this unification cannot fail *)
+    Ctype.unify env row.row_more
+      (Btype.newgenty
+         (Tvariant {row with row_fields = []; row_more = Btype.newgenvar();
+                    row_closed = true; row_name = nm}))
+  end
+
+(*
+  Check whether the first column of env makes up a complete signature or
+  not. We work on the discriminating pattern heads of each sub-matrix: they
+  are not omega/Any.
+*)
+let full_match closing env =  match env with
+| [] -> false
+| (discr, _) :: _ ->
+  match Pattern_head.desc discr with
+  | Any -> assert false
+  | Construct { cstr_tag = Cstr_extension _ ; _ } -> false
+  | Construct c -> List.length env = c.cstr_consts + c.cstr_nonconsts
+  | Variant { type_row; _ } ->
+      let fields =
+        List.map
+          (fun (d, _) ->
+            match Pattern_head.desc d with
+            | Variant { tag } -> tag
+            | _ -> assert false)
+          env
+      in
+      let row = type_row () in
+      if closing && not (Btype.row_fixed row) then
+        (* closing=true, we are considering the variant as closed *)
+        List.for_all
+          (fun (tag,f) ->
+            match Btype.row_field_repr f with
+              Rabsent | Reither(_, _, false, _) -> true
+            | Reither (_, _, true, _)
+                (* m=true, do not discard matched tags, rather warn *)
+            | Rpresent _ -> List.mem tag fields)
+          row.row_fields
+      else
+        row.row_closed &&
+        List.for_all
+          (fun (tag,f) ->
+            Btype.row_field_repr f = Rabsent || List.mem tag fields)
+          row.row_fields
+  | Constant Const_char _ ->
+      List.length env = 256
+  | Constant _
+  | Array _ -> false
+  | Tuple _
+  | Record _
+  | Lazy -> true
+
+(* Written as a non-fragile matching, PR#7451 originated from a fragile matching
+   below. *)
+let should_extend ext env = match ext with
+| None -> false
+| Some ext -> begin match env with
+  | [] -> assert false
+  | (p,_)::_ ->
+      begin match Pattern_head.desc p with
+      | Construct {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)} ->
+          let path =
+            get_constructor_type_path (Pattern_head.typ p) (Pattern_head.env p)
+          in
+          Path.same path ext
+      | Construct {cstr_tag=(Cstr_extension _)} -> false
+      | Constant _ | Tuple _ | Variant _ | Record _ | Array _ | Lazy -> false
+      | Any -> assert false
+      end
+end
+
+module ConstructorTagHashtbl = Hashtbl.Make(
+  struct
+    type t = Types.constructor_tag
+    let hash = Hashtbl.hash
+    let equal = Types.equal_tag
+  end
+)
+
+(* complement constructor tags *)
+let complete_tags nconsts nconstrs tags =
+  let seen_const = Array.make nconsts false
+  and seen_constr = Array.make nconstrs false in
+  List.iter
+    (function
+      | Cstr_constant i -> seen_const.(i) <- true
+      | Cstr_block i -> seen_constr.(i) <- true
+      | _  -> assert false)
+    tags ;
+  let r = ConstructorTagHashtbl.create (nconsts+nconstrs) in
+  for i = 0 to nconsts-1 do
+    if not seen_const.(i) then
+      ConstructorTagHashtbl.add r (Cstr_constant i) ()
+  done ;
+  for i = 0 to nconstrs-1 do
+    if not seen_constr.(i) then
+      ConstructorTagHashtbl.add r (Cstr_block i) ()
+  done ;
+  r
+
+(* build a pattern from a constructor description *)
+let pat_of_constr ex_pat cstr =
+  {ex_pat with pat_desc =
+   Tpat_construct (mknoloc (Longident.Lident cstr.cstr_name),
+                   cstr, omegas cstr.cstr_arity)}
+
+let orify x y = make_pat (Tpat_or (x, y, None)) x.pat_type x.pat_env
+
+let rec orify_many = function
+| [] -> assert false
+| [x] -> x
+| x :: xs -> orify x (orify_many xs)
+
+(* build an or-pattern from a constructor list *)
+let pat_of_constrs ex_pat cstrs =
+  let ex_pat = Pattern_head.to_omega_pattern ex_pat in
+  if cstrs = [] then raise Empty else
+  orify_many (List.map (pat_of_constr ex_pat) cstrs)
+
+let pats_of_type ?(always=false) env ty =
+  let ty' = Ctype.expand_head env ty in
+  match ty'.desc with
+  | Tconstr (path, _, _) ->
+      begin try match (Env.find_type path env).type_kind with
+      | Type_variant cl when always || List.length cl <= 1 ||
+        (* Only explode when all constructors are GADTs *)
+        List.for_all (fun cd -> cd.Types.cd_res <> None) cl ->
+          let cstrs = fst (Env.find_type_descrs path env) in
+          List.map (pat_of_constr (make_pat Tpat_any ty env)) cstrs
+      | Type_record _ ->
+          let labels = snd (Env.find_type_descrs path env) in
+          let fields =
+            List.map (fun ld ->
+              mknoloc (Longident.Lident ld.lbl_name), ld, omega)
+              labels
+          in
+          [make_pat (Tpat_record (fields, Closed)) ty env]
+      | _ -> [omega]
+      with Not_found -> [omega]
+      end
+  | Ttuple tl ->
+      [make_pat (Tpat_tuple (omegas (List.length tl))) ty env]
+  | _ -> [omega]
+
+let rec get_variant_constructors env ty =
+  match (Ctype.repr ty).desc with
+  | Tconstr (path,_,_) -> begin
+      try match Env.find_type path env with
+      | {type_kind=Type_variant _} ->
+          fst (Env.find_type_descrs path env)
+      | {type_manifest = Some _} ->
+          get_variant_constructors env
+            (Ctype.expand_head_once env (clean_copy ty))
+      | _ -> fatal_error "Parmatch.get_variant_constructors"
+      with Not_found ->
+        fatal_error "Parmatch.get_variant_constructors"
+    end
+  | _ -> fatal_error "Parmatch.get_variant_constructors"
+
+(* Sends back a pattern that complements constructor tags all_tag *)
+let complete_constrs p all_tags =
+  let c = match Pattern_head.desc p with Construct c -> c | _ -> assert false in
+  let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in
+  let constrs = get_variant_constructors (Pattern_head.env p) c.cstr_res in
+  let others =
+    List.filter
+      (fun cnstr -> ConstructorTagHashtbl.mem not_tags cnstr.cstr_tag)
+      constrs in
+  let const, nonconst =
+    List.partition (fun cnstr -> cnstr.cstr_arity = 0) others in
+  const @ nonconst
+
+let build_other_constrs env p =
+  match Pattern_head.desc p with
+  | Construct { cstr_tag = Cstr_constant _ | Cstr_block _ } ->
+      let get_tag q =
+        match Pattern_head.desc q with
+        | Construct c -> c.cstr_tag
+        | _ -> fatal_error "Parmatch.get_tag" in
+      let all_tags =  List.map (fun (p,_) -> get_tag p) env in
+      pat_of_constrs p (complete_constrs p all_tags)
+  | _ -> extra_pat
+
+let complete_constrs p all_tags =
+  (* This wrapper is here for [Matching], which (indirectly) calls this function
+     from [combine_constructor], and nowhere else.
+     So we know patterns have been fully simplified. *)
+  complete_constrs (fst @@ Pattern_head.deconstruct p) all_tags
+
+(* Auxiliary for build_other *)
+
+let build_other_constant proj make first next p env =
+  let all = List.map (fun (p, _) -> proj (Pattern_head.desc p)) env in
+  let rec try_const i =
+    if List.mem i all
+    then try_const (next i)
+    else make_pat (make i) (Pattern_head.typ p) (Pattern_head.env p)
+  in try_const first
+
+(*
+  Builds a pattern that is incompatible with all patterns in
+  the first column of env
+*)
+
+let some_private_tag = "<some private tag>"
+
+let build_other ext env =
+  match env with
+  | [] -> omega
+  | (d, _) :: _ ->
+      match Pattern_head.desc d with
+      | Construct { cstr_tag = Cstr_extension _ } ->
+          (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *)
+          make_pat
+            (Tpat_var (Ident.create_local "*extension*",
+                       {txt="*extension*"; loc = Pattern_head.loc d}))
+            Ctype.none Env.empty
+      | Construct _ ->
+          begin match ext with
+          | Some ext ->
+              if Path.same ext
+                   (get_constructor_type_path
+                      (Pattern_head.typ d) (Pattern_head.env d))
+              then
+                extra_pat
+              else
+                build_other_constrs env d
+          | _ ->
+              build_other_constrs env d
+          end
+      | Variant { cstr_row; type_row } ->
+          let tags =
+            List.map
+              (fun (d, _) ->
+                match Pattern_head.desc d with
+                | Variant { tag } -> tag
+                | _ -> assert false)
+              env
+            in
+            let make_other_pat tag const =
+              let arg = if const then None else Some omega in
+              make_pat (Tpat_variant(tag, arg, cstr_row))
+                (Pattern_head.typ d) (Pattern_head.env d)
+            in
+            let row = type_row () in
+            begin match
+              List.fold_left
+                (fun others (tag,f) ->
+                  if List.mem tag tags then others else
+                  match Btype.row_field_repr f with
+                    Rabsent (* | Reither _ *) -> others
+                  (* This one is called after erasing pattern info *)
+                  | Reither (c, _, _, _) -> make_other_pat tag c :: others
+                  | Rpresent arg -> make_other_pat tag (arg = None) :: others)
+                [] row.row_fields
+            with
+              [] ->
+                let tag =
+                  if Btype.row_fixed row then some_private_tag else
+                  let rec mktag tag =
+                    if List.mem tag tags then mktag (tag ^ "'") else tag in
+                  mktag "AnyOtherTag"
+                in make_other_pat tag true
+            | pat::other_pats ->
+                List.fold_left
+                  (fun p_res pat ->
+                    make_pat (Tpat_or (pat, p_res, None))
+                      (Pattern_head.typ d) (Pattern_head.env d))
+                  pat other_pats
+            end
+      | Constant Const_char _ ->
+          let all_chars =
+            List.map
+              (fun (p,_) -> match Pattern_head.desc p with
+              | Constant (Const_char c) -> c
+              | _ -> assert false)
+              env
+          in
+          let rec find_other i imax =
+            if i > imax then raise Not_found
+            else
+              let ci = Char.chr i in
+              if List.mem ci all_chars then
+                find_other (i+1) imax
+              else
+                make_pat (Tpat_constant (Const_char ci))
+                  (Pattern_head.typ d) (Pattern_head.env d)
+          in
+          let rec try_chars = function
+            | [] -> omega
+            | (c1,c2) :: rest ->
+                try
+                  find_other (Char.code c1) (Char.code c2)
+                with
+                | Not_found -> try_chars rest
+          in
+          try_chars
+            [ 'a', 'z' ; 'A', 'Z' ; '0', '9' ;
+              ' ', '~' ; Char.chr 0 , Char.chr 255]
+      | Constant Const_int _ ->
+          build_other_constant
+            (function Constant(Const_int i) -> i | _ -> assert false)
+            (function i -> Tpat_constant(Const_int i))
+            0 succ d env
+      | Constant Const_int32 _ ->
+          build_other_constant
+            (function Constant(Const_int32 i) -> i | _ -> assert false)
+            (function i -> Tpat_constant(Const_int32 i))
+            0l Int32.succ d env
+      | Constant Const_int64 _ ->
+          build_other_constant
+            (function Constant(Const_int64 i) -> i | _ -> assert false)
+            (function i -> Tpat_constant(Const_int64 i))
+            0L Int64.succ d env
+      | Constant Const_nativeint _ ->
+          build_other_constant
+            (function Constant(Const_nativeint i) -> i | _ -> assert false)
+            (function i -> Tpat_constant(Const_nativeint i))
+            0n Nativeint.succ d env
+      | Constant Const_string _ ->
+          build_other_constant
+            (function Constant(Const_string (s, _, _)) -> String.length s
+                    | _ -> assert false)
+            (function i ->
+               Tpat_constant
+                 (Const_string(String.make i '*',Location.none,None)))
+            0 succ d env
+      | Constant Const_float _ ->
+          build_other_constant
+            (function Constant(Const_float f) -> float_of_string f
+                    | _ -> assert false)
+            (function f -> Tpat_constant(Const_float (string_of_float f)))
+            0.0 (fun f -> f +. 1.0) d env
+      | Array _ ->
+          let all_lengths =
+            List.map
+              (fun (p,_) -> match Pattern_head.desc p with
+              | Array len -> len
+              | _ -> assert false)
+              env in
+          let rec try_arrays l =
+            if List.mem l all_lengths then try_arrays (l+1)
+            else
+              make_pat
+                (Tpat_array (omegas l))
+                (Pattern_head.typ d) (Pattern_head.env d) in
+          try_arrays 0
+      | _ -> omega
+
+let rec has_instance p = match p.pat_desc with
+  | Tpat_variant (l,_,r) when is_absent l r -> false
+  | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true
+  | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) -> has_instance p
+  | Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2
+  | Tpat_construct (_,_,ps) | Tpat_tuple ps | Tpat_array ps ->
+      has_instances ps
+  | Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,x) -> x) lps)
+  | Tpat_lazy p
+    -> has_instance p
+
+and has_instances = function
+  | [] -> true
+  | q::rem -> has_instance q && has_instances rem
+
+(*
+  Core function :
+  Is the last row of pattern matrix pss + qs satisfiable ?
+  That is :
+    Does there exists at least one value vector, es such that :
+     1- for all ps in pss ps # es (ps and es are not compatible)
+     2- qs <= es                  (es matches qs)
+
+   ---
+
+   In two places in the following function, we check the coherence of the first
+   column of (pss + qs).
+   If it is incoherent, then we exit early saying that (pss + qs) is not
+   satisfiable (which is equivalent to saying "oh, we shouldn't have considered
+   that branch, no good result came come from here").
+
+   But what happens if we have a coherent but ill-typed column?
+   - we might end up returning [false], which is equivalent to noticing the
+   incompatibility: clearly this is fine.
+   - if we end up returning [true] then we're saying that [qs] is useful while
+   it is not. This is sad but not the end of the world, we're just allowing dead
+   code to survive.
+*)
+let rec satisfiable pss qs = match pss with
+| [] -> has_instances qs
+| _  ->
+    match qs with
+    | [] -> false
+    | {pat_desc = Tpat_or(q1,q2,_)}::qs ->
+        satisfiable pss (q1::qs) || satisfiable pss (q2::qs)
+    | {pat_desc = Tpat_alias(q,_,_)}::qs ->
+          satisfiable pss (q::qs)
+    | {pat_desc = (Tpat_any | Tpat_var(_))}::qs ->
+        let pss = simplify_first_col pss in
+        if not (all_coherent (first_column pss)) then
+          false
+        else begin
+          let { default; constrs } =
+            let q0 = discr_pat omega pss in
+            build_specialized_submatrices ~extend_row:(@) q0 pss in
+          if not (full_match false constrs) then
+            satisfiable default qs
+          else
+            List.exists
+              (fun (p,pss) ->
+                 not (is_absent_pat p) &&
+                 satisfiable pss
+                   (simple_match_args p Pattern_head.omega [] @ qs))
+              constrs
+        end
+    | {pat_desc=Tpat_variant (l,_,r)}::_ when is_absent l r -> false
+    | q::qs ->
+        let pss = simplify_first_col pss in
+        let hq, qargs = Pattern_head.deconstruct q in
+        if not (all_coherent (hq :: first_column pss)) then
+          false
+        else begin
+          let q0 = discr_pat q pss in
+          satisfiable (build_specialized_submatrix ~extend_row:(@) q0 pss)
+            (simple_match_args q0 hq qargs @ qs)
+        end
+
+(* While [satisfiable] only checks whether the last row of [pss + qs] is
+   satisfiable, this function returns the (possibly empty) list of vectors [es]
+   which verify:
+     1- for all ps in pss, ps # es (ps and es are not compatible)
+     2- qs <= es                   (es matches qs)
+
+   This is done to enable GADT handling
+
+   For considerations regarding the coherence check, see the comment on
+   [satisfiable] above.  *)
+let rec list_satisfying_vectors pss qs =
+  match pss with
+  | [] -> if has_instances qs then [qs] else []
+  | _  ->
+      match qs with
+      | [] -> []
+      | {pat_desc = Tpat_or(q1,q2,_)}::qs ->
+          list_satisfying_vectors pss (q1::qs) @
+          list_satisfying_vectors pss (q2::qs)
+      | {pat_desc = Tpat_alias(q,_,_)}::qs ->
+          list_satisfying_vectors pss (q::qs)
+      | {pat_desc = (Tpat_any | Tpat_var(_))}::qs ->
+          let pss = simplify_first_col pss in
+          if not (all_coherent (first_column pss)) then
+            []
+          else begin
+            let q0 = discr_pat omega pss in
+            let wild default_matrix p =
+              List.map (fun qs -> p::qs)
+                (list_satisfying_vectors default_matrix qs)
+            in
+            match build_specialized_submatrices ~extend_row:(@) q0 pss with
+            | { default; constrs = [] } ->
+                (* first column of pss is made of variables only *)
+                wild default omega
+            | { default; constrs = ((p,_)::_ as constrs) } ->
+                let for_constrs () =
+                  List.flatten (
+                    List.map (fun (p,pss) ->
+                      if is_absent_pat p then
+                        []
+                      else
+                        let witnesses =
+                          list_satisfying_vectors pss
+                            (simple_match_args p Pattern_head.omega [] @ qs)
+                        in
+                        let p = Pattern_head.to_omega_pattern p in
+                        List.map (set_args p) witnesses
+                    ) constrs
+                  )
+                in
+                if full_match false constrs then for_constrs () else
+                begin match Pattern_head.desc p with
+                | Construct _ ->
+                    (* activate this code for checking non-gadt constructors *)
+                    wild default (build_other_constrs constrs p)
+                    @ for_constrs ()
+                | _ ->
+                    wild default omega
+                end
+          end
+      | {pat_desc=Tpat_variant (l,_,r)}::_ when is_absent l r -> []
+      | q::qs ->
+          let hq, qargs = Pattern_head.deconstruct q in
+          let pss = simplify_first_col pss in
+          if not (all_coherent (hq :: first_column pss)) then
+            []
+          else begin
+            let q0 = discr_pat q pss in
+            List.map (set_args (Pattern_head.to_omega_pattern q0))
+              (list_satisfying_vectors
+                 (build_specialized_submatrix ~extend_row:(@) q0 pss)
+                 (simple_match_args q0 hq qargs @ qs))
+          end
+
+(******************************************)
+(* Look for a row that matches some value *)
+(******************************************)
+
+(*
+  Useful for seeing if the example of
+  non-matched value can indeed be matched
+  (by a guarded clause)
+*)
+
+let rec do_match pss qs = match qs with
+| [] ->
+    begin match pss  with
+    | []::_ -> true
+    | _ -> false
+    end
+| q::qs -> match q with
+  | {pat_desc = Tpat_or (q1,q2,_)} ->
+      do_match pss (q1::qs) || do_match pss (q2::qs)
+  | {pat_desc = Tpat_any} ->
+      let rec remove_first_column = function
+        | (_::ps)::rem -> ps::remove_first_column rem
+        | _ -> []
+      in
+      do_match (remove_first_column pss) qs
+  | _ ->
+      (* [q] is generated by us, it doesn't come from the source. So we know
+         it's not of the form [P as name].
+         Therefore there is no risk of [deconstruct] raising. *)
+      let q0, qargs = Pattern_head.deconstruct q in
+      let pss = simplify_first_col pss in
+      (* [pss] will (or won't) match [q0 :: qs] regardless of the coherence of
+         its first column. *)
+      do_match
+        (build_specialized_submatrix ~extend_row:(@) q0 pss)
+        (qargs @ qs)
+
+
+type 'a exhaust_result =
+  | No_matching_value
+  | Witnesses of 'a list
+
+let rappend r1 r2 =
+  match r1, r2 with
+  | No_matching_value, _ -> r2
+  | _, No_matching_value -> r1
+  | Witnesses l1, Witnesses l2 -> Witnesses (l1 @ l2)
+
+let rec try_many  f = function
+  | [] -> No_matching_value
+  | (p,pss)::rest ->
+      rappend (f (p, pss)) (try_many f rest)
+
+(*
+let print_pat pat =
+  let rec string_of_pat pat =
+    match pat.pat_desc with
+        Tpat_var _ -> "v"
+      | Tpat_any -> "_"
+      | Tpat_alias (p, x) -> Printf.sprintf "(%s) as ?"  (string_of_pat p)
+      | Tpat_constant n -> "0"
+      | Tpat_construct (_, lid, _) ->
+        Printf.sprintf "%s" (String.concat "." (Longident.flatten lid.txt))
+      | Tpat_lazy p ->
+        Printf.sprintf "(lazy %s)" (string_of_pat p)
+      | Tpat_or (p1,p2,_) ->
+        Printf.sprintf "(%s | %s)" (string_of_pat p1) (string_of_pat p2)
+      | Tpat_tuple list ->
+        Printf.sprintf "(%s)" (String.concat "," (List.map string_of_pat list))
+      | Tpat_variant (_, _, _) -> "variant"
+      | Tpat_record (_, _) -> "record"
+      | Tpat_array _ -> "array"
+  in
+  Printf.fprintf stderr "PAT[%s]\n%!" (string_of_pat pat)
+*)
+
+(*
+  Now another satisfiable function that additionally
+  supplies an example of a matching value.
+
+  This function should be called for exhaustiveness check only.
+*)
+let rec exhaust (ext:Path.t option) pss n = match pss with
+| []    ->  Witnesses [omegas n]
+| []::_ ->  No_matching_value
+| pss   ->
+    let pss = simplify_first_col pss in
+    if not (all_coherent (first_column pss)) then
+      (* We're considering an ill-typed branch, we won't actually be able to
+         produce a well typed value taking that branch. *)
+      No_matching_value
+    else begin
+      (* Assuming the first column is ill-typed but considered coherent, we
+         might end up producing an ill-typed witness of non-exhaustivity
+         corresponding to the current branch.
+
+         If [exhaust] has been called by [do_check_partial], then the witnesses
+         produced get typechecked and the ill-typed ones are discarded.
+
+         If [exhaust] has been called by [do_check_fragile], then it is possible
+         we might fail to warn the user that the matching is fragile. See for
+         example testsuite/tests/warnings/w04_failure.ml. *)
+      let q0 = discr_pat omega pss in
+      match build_specialized_submatrices ~extend_row:(@) q0 pss with
+      | { default; constrs = [] } ->
+          (* first column of pss is made of variables only *)
+          begin match exhaust ext default (n-1) with
+          | Witnesses r ->
+              let q0 = Pattern_head.to_omega_pattern q0 in
+              Witnesses (List.map (fun row -> q0::row) r)
+          | r -> r
+        end
+      | { default; constrs } ->
+          let try_non_omega (p,pss) =
+            if is_absent_pat p then
+              No_matching_value
+            else
+              match
+                exhaust
+                  ext pss
+                  (List.length (simple_match_args p Pattern_head.omega [])
+                   + n - 1)
+              with
+              | Witnesses r ->
+                  let p = Pattern_head.to_omega_pattern p in
+                  Witnesses (List.map (set_args p) r)
+              | r       -> r in
+          let before = try_many try_non_omega constrs in
+          if
+            full_match false constrs && not (should_extend ext constrs)
+          then
+            before
+          else
+            let r =  exhaust ext default (n-1) in
+            match r with
+            | No_matching_value -> before
+            | Witnesses r ->
+                try
+                  let p = build_other ext constrs in
+                  let dug = List.map (fun tail -> p :: tail) r in
+                  match before with
+                  | No_matching_value -> Witnesses dug
+                  | Witnesses x -> Witnesses (x @ dug)
+                with
+        (* cannot occur, since constructors don't make a full signature *)
+                | Empty -> fatal_error "Parmatch.exhaust"
+  end
+
+let exhaust ext pss n =
+  let ret = exhaust ext pss n in
+  match ret with
+    No_matching_value -> No_matching_value
+  | Witnesses lst ->
+      let singletons =
+        List.map
+          (function
+              [x] -> x
+            | _ -> assert false)
+          lst
+      in
+      Witnesses [orify_many singletons]
+
+(*
+   Another exhaustiveness check, enforcing variant typing.
+   Note that it does not check exact exhaustiveness, but whether a
+   matching could be made exhaustive by closing all variant types.
+   When this is true of all other columns, the current column is left
+   open (even if it means that the whole matching is not exhaustive as
+   a result).
+   When this is false for the matrix minus the current column, and the
+   current column is composed of variant tags, we close the variant
+   (even if it doesn't help in making the matching exhaustive).
+*)
+
+let rec pressure_variants tdefs = function
+  | []    -> false
+  | []::_ -> true
+  | pss   ->
+      let pss = simplify_first_col pss in
+      if not (all_coherent (first_column pss)) then
+        true
+      else begin
+        let q0 = discr_pat omega pss in
+        match build_specialized_submatrices ~extend_row:(@) q0 pss with
+        | { default; constrs = [] } -> pressure_variants tdefs default
+        | { default; constrs } ->
+            let rec try_non_omega = function
+              | (_p,pss) :: rem ->
+                  let ok = pressure_variants tdefs pss in
+                  (* The order below matters : we want [pressure_variants] to be
+                    called on all the specialized submatrices because we might
+                    close some variant in any of them regardless of whether [ok]
+                    is true for [pss] or not *)
+                  try_non_omega rem && ok
+              | [] -> true
+            in
+            if full_match (tdefs=None) constrs then
+              try_non_omega constrs
+            else if tdefs = None then
+              pressure_variants None default
+            else
+              let full = full_match true constrs in
+              let ok =
+                if full then
+                  try_non_omega constrs
+                else begin
+                  let { constrs = partial_constrs; _ } =
+                    build_specialized_submatrices ~extend_row:(@) q0
+                      (mark_partial pss)
+                  in
+                  try_non_omega partial_constrs
+                end
+              in
+              begin match constrs, tdefs with
+              | [], _
+              | _, None -> ()
+              | (d, _) :: _, Some env ->
+                match Pattern_head.desc d with
+                | Variant { type_row; _ } ->
+                  let row = type_row () in
+                  if Btype.row_fixed row
+                  || pressure_variants None default then ()
+                  else close_variant env row
+                | _ -> ()
+              end;
+              ok
+      end
+
+
+(* Yet another satisfiable function *)
+
+(*
+   This time every_satisfiable pss qs checks the
+   utility of every expansion of qs.
+   Expansion means expansion of or-patterns inside qs
+*)
+
+type answer =
+  | Used                                (* Useful pattern *)
+  | Unused                              (* Useless pattern *)
+  | Upartial of Typedtree.pattern list  (* Mixed, with list of useless ones *)
+
+
+
+(* this row type enable column processing inside the matrix
+    - left  ->  elements not to be processed,
+    - right ->  elements to be processed
+*)
+type usefulness_row =
+  {no_ors : pattern list ; ors : pattern list ; active : pattern list}
+
+(*
+let pretty_row {ors=ors ; no_ors=no_ors; active=active} =
+  pretty_line ors ; prerr_string " *" ;
+  pretty_line no_ors ; prerr_string " *" ;
+  pretty_line active
+
+let pretty_rows rs =
+  prerr_endline "begin matrix" ;
+  List.iter
+    (fun r ->
+      pretty_row r ;
+      prerr_endline "")
+    rs ;
+  prerr_endline "end matrix"
+*)
+
+(* Initial build *)
+let make_row ps = {ors=[] ; no_ors=[]; active=ps}
+
+let make_rows pss = List.map make_row pss
+
+
+(* Useful to detect and expand  or pats inside as pats *)
+let rec unalias p = match p.pat_desc with
+| Tpat_alias (p,_,_) -> unalias p
+| _ -> p
+
+
+let is_var p = match (unalias p).pat_desc with
+| Tpat_any|Tpat_var _ -> true
+| _                   -> false
+
+let is_var_column rs =
+  List.for_all
+    (fun r -> match r.active with
+    | p::_ -> is_var p
+    | []   -> assert false)
+    rs
+
+(* Standard or-args for left-to-right matching *)
+let rec or_args p = match p.pat_desc with
+| Tpat_or (p1,p2,_) -> p1,p2
+| Tpat_alias (p,_,_)  -> or_args p
+| _                 -> assert false
+
+(* Just remove current column *)
+let remove r = match r.active with
+| _::rem -> {r with active=rem}
+| []     -> assert false
+
+let remove_column rs = List.map remove rs
+
+(* Current column has been processed *)
+let push_no_or r = match r.active with
+| p::rem -> { r with no_ors = p::r.no_ors ; active=rem}
+| [] -> assert false
+
+let push_or r = match r.active with
+| p::rem -> { r with ors = p::r.ors ; active=rem}
+| [] -> assert false
+
+let push_or_column rs = List.map push_or rs
+and push_no_or_column rs = List.map push_no_or rs
+
+let rec simplify_first_usefulness_col = function
+  | [] -> []
+  | row :: rows ->
+    match row.active with
+    | [] -> assert false (* the rows are non-empty! *)
+    | p :: ps ->
+      let add_column p ps k =
+        (p, { row with active = ps }) :: k in
+      simplify_head_pat ~add_column p ps
+        (simplify_first_usefulness_col rows)
+
+(* Back to normal matrices *)
+let make_vector r = List.rev r.no_ors
+
+let make_matrix rs = List.map make_vector rs
+
+
+(* Standard union on answers *)
+let union_res r1 r2 = match r1, r2 with
+| (Unused,_)
+| (_, Unused) -> Unused
+| Used,_    -> r2
+| _, Used   -> r1
+| Upartial u1, Upartial u2 -> Upartial (u1@u2)
+
+(* propose or pats for expansion *)
+let extract_elements qs =
+  let rec do_rec seen = function
+    | [] -> []
+    | q::rem ->
+        {no_ors= List.rev_append seen rem @ qs.no_ors ;
+        ors=[] ;
+        active = [q]}::
+        do_rec (q::seen) rem in
+  do_rec [] qs.ors
+
+(* idem for matrices *)
+let transpose rs = match rs with
+| [] -> assert false
+| r::rem ->
+    let i = List.map (fun x -> [x]) r in
+    List.fold_left
+      (List.map2 (fun r x -> x::r))
+      i rem
+
+let extract_columns pss qs = match pss with
+| [] -> List.map (fun _ -> []) qs.ors
+| _  ->
+  let rows = List.map extract_elements pss in
+  transpose rows
+
+(* Core function
+   The idea is to first look for or patterns (recursive case), then
+   check or-patterns argument usefulness (terminal case)
+*)
+
+let rec every_satisfiables pss qs = match qs.active with
+| []     ->
+    (* qs is now partitionned,  check usefulness *)
+    begin match qs.ors with
+    | [] -> (* no or-patterns *)
+        if satisfiable (make_matrix pss) (make_vector qs) then
+          Used
+        else
+          Unused
+    | _  -> (* n or-patterns -> 2n expansions *)
+        List.fold_right2
+          (fun pss qs r -> match r with
+          | Unused -> Unused
+          | _ ->
+              match qs.active with
+              | [q] ->
+                  let q1,q2 = or_args q in
+                  let r_loc = every_both pss qs q1 q2 in
+                  union_res r r_loc
+              | _   -> assert false)
+          (extract_columns pss qs) (extract_elements qs)
+          Used
+    end
+| q::rem ->
+    let uq = unalias q in
+    begin match uq.pat_desc with
+    | Tpat_any | Tpat_var _ ->
+        if is_var_column pss then
+(* forget about ``all-variable''  columns now *)
+          every_satisfiables (remove_column pss) (remove qs)
+        else
+(* otherwise this is direct food for satisfiable *)
+          every_satisfiables (push_no_or_column pss) (push_no_or qs)
+    | Tpat_or (q1,q2,_) ->
+        if
+          q1.pat_loc.Location.loc_ghost &&
+          q2.pat_loc.Location.loc_ghost
+        then
+(* syntactically generated or-pats should not be expanded *)
+          every_satisfiables (push_no_or_column pss) (push_no_or qs)
+        else
+(* this is a real or-pattern *)
+          every_satisfiables (push_or_column pss) (push_or qs)
+    | Tpat_variant (l,_,r) when is_absent l r -> (* Ah Jacques... *)
+        Unused
+    | _ ->
+(* standard case, filter matrix *)
+        let pss = simplify_first_usefulness_col pss in
+        let huq, args = Pattern_head.deconstruct uq in
+        (* The handling of incoherent matrices is kept in line with
+           [satisfiable] *)
+        if not (all_coherent (huq :: first_column pss)) then
+          Unused
+        else begin
+          let q0 = discr_pat q pss in
+          every_satisfiables
+            (build_specialized_submatrix q0 pss
+              ~extend_row:(fun ps r -> { r with active = ps @ r.active }))
+            {qs with active=simple_match_args q0 huq args @ rem}
+        end
+    end
+
+(*
+  This function ``every_both'' performs the usefulness check
+  of or-pat q1|q2.
+  The trick is to call every_satisfied twice with
+  current active columns restricted to q1 and q2,
+  That way,
+  - others orpats in qs.ors will not get expanded.
+  - all matching work performed on qs.no_ors is not performed again.
+  *)
+and every_both pss qs q1 q2 =
+  let qs1 = {qs with active=[q1]}
+  and qs2 =  {qs with active=[q2]} in
+  let r1 = every_satisfiables pss qs1
+  and r2 =  every_satisfiables (if compat q1 q2 then qs1::pss else pss) qs2 in
+  match r1 with
+  | Unused ->
+      begin match r2 with
+      | Unused -> Unused
+      | Used   -> Upartial [q1]
+      | Upartial u2 -> Upartial (q1::u2)
+      end
+  | Used ->
+      begin match r2 with
+      | Unused -> Upartial [q2]
+      | _      -> r2
+      end
+  | Upartial u1 ->
+      begin match r2 with
+      | Unused -> Upartial (u1@[q2])
+      | Used   -> r1
+      | Upartial u2 -> Upartial (u1 @ u2)
+      end
+
+
+
+
+(* le_pat p q  means, forall V,  V matches q implies V matches p *)
+let rec le_pat p q =
+  match (p.pat_desc, q.pat_desc) with
+  | (Tpat_var _|Tpat_any),_ -> true
+  | Tpat_alias(p,_,_), _ -> le_pat p q
+  | _, Tpat_alias(q,_,_) -> le_pat p q
+  | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0
+  | Tpat_construct(_,c1,ps), Tpat_construct(_,c2,qs) ->
+      Types.equal_tag c1.cstr_tag c2.cstr_tag && le_pats ps qs
+  | Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) ->
+      (l1 = l2 && le_pat p1 p2)
+  | Tpat_variant(l1,None,_r1), Tpat_variant(l2,None,_) ->
+      l1 = l2
+  | Tpat_variant(_,_,_), Tpat_variant(_,_,_) -> false
+  | Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs
+  | Tpat_lazy p, Tpat_lazy q -> le_pat p q
+  | Tpat_record (l1,_), Tpat_record (l2,_) ->
+      let ps,qs = records_args l1 l2 in
+      le_pats ps qs
+  | Tpat_array(ps), Tpat_array(qs) ->
+      List.length ps = List.length qs && le_pats ps qs
+(* In all other cases, enumeration is performed *)
+  | _,_  -> not (satisfiable [[p]] [q])
+
+and le_pats ps qs =
+  match ps,qs with
+    p::ps, q::qs -> le_pat p q && le_pats ps qs
+  | _, _         -> true
+
+let get_mins le ps =
+  let rec select_rec r = function
+      [] -> r
+    | p::ps ->
+        if List.exists (fun p0 -> le p0 p) ps
+        then select_rec r ps
+        else select_rec (p::r) ps in
+  select_rec [] (select_rec [] ps)
+
+(*
+  lub p q is a pattern that matches all values matched by p and q
+  may raise Empty, when p and q are not compatible
+*)
+
+let rec lub p q = match p.pat_desc,q.pat_desc with
+| Tpat_alias (p,_,_),_      -> lub p q
+| _,Tpat_alias (q,_,_)      -> lub p q
+| (Tpat_any|Tpat_var _),_ -> q
+| _,(Tpat_any|Tpat_var _) -> p
+| Tpat_or (p1,p2,_),_     -> orlub p1 p2 q
+| _,Tpat_or (q1,q2,_)     -> orlub q1 q2 p (* Thanks god, lub is commutative *)
+| Tpat_constant c1, Tpat_constant c2 when const_compare c1 c2 = 0 -> p
+| Tpat_tuple ps, Tpat_tuple qs ->
+    let rs = lubs ps qs in
+    make_pat (Tpat_tuple rs) p.pat_type p.pat_env
+| Tpat_lazy p, Tpat_lazy q ->
+    let r = lub p q in
+    make_pat (Tpat_lazy r) p.pat_type p.pat_env
+| Tpat_construct (lid, c1,ps1), Tpat_construct (_,c2,ps2)
+      when  Types.equal_tag c1.cstr_tag c2.cstr_tag  ->
+        let rs = lubs ps1 ps2 in
+        make_pat (Tpat_construct (lid, c1,rs))
+          p.pat_type p.pat_env
+| Tpat_variant(l1,Some p1,row), Tpat_variant(l2,Some p2,_)
+          when  l1=l2 ->
+            let r=lub p1 p2 in
+            make_pat (Tpat_variant (l1,Some r,row)) p.pat_type p.pat_env
+| Tpat_variant (l1,None,_row), Tpat_variant(l2,None,_)
+              when l1 = l2 -> p
+| Tpat_record (l1,closed),Tpat_record (l2,_) ->
+    let rs = record_lubs l1 l2 in
+    make_pat (Tpat_record (rs, closed)) p.pat_type p.pat_env
+| Tpat_array ps, Tpat_array qs
+      when List.length ps = List.length qs ->
+        let rs = lubs ps qs in
+        make_pat (Tpat_array rs) p.pat_type p.pat_env
+| _,_  ->
+    raise Empty
+
+and orlub p1 p2 q =
+  try
+    let r1 = lub p1 q in
+    try
+      {q with pat_desc=(Tpat_or (r1,lub p2 q,None))}
+  with
+  | Empty -> r1
+with
+| Empty -> lub p2 q
+
+and record_lubs l1 l2 =
+  let rec lub_rec l1 l2 = match l1,l2 with
+  | [],_ -> l2
+  | _,[] -> l1
+  | (lid1, lbl1,p1)::rem1, (lid2, lbl2,p2)::rem2 ->
+      if lbl1.lbl_pos < lbl2.lbl_pos then
+        (lid1, lbl1,p1)::lub_rec rem1 l2
+      else if lbl2.lbl_pos < lbl1.lbl_pos  then
+        (lid2, lbl2,p2)::lub_rec l1 rem2
+      else
+        (lid1, lbl1,lub p1 p2)::lub_rec rem1 rem2 in
+  lub_rec l1 l2
+
+and lubs ps qs = match ps,qs with
+| p::ps, q::qs -> lub p q :: lubs ps qs
+| _,_ -> []
+
+
+(******************************)
+(* Exported variant closing   *)
+(******************************)
+
+(* Apply pressure to variants *)
+
+let pressure_variants tdefs patl =
+  ignore (pressure_variants
+            (Some tdefs)
+            (List.map (fun p -> [p; omega]) patl))
+
+let pressure_variants_in_computation_pattern tdefs patl =
+  let add_row pss p_opt =
+    match p_opt with
+    | None -> pss
+    | Some p -> p :: pss
+  in
+  let val_pss, exn_pss =
+    List.fold_right (fun pat (vpss, epss)->
+      let (vp, ep) = split_pattern pat in
+      add_row vpss vp, add_row epss ep
+    ) patl ([], [])
+  in
+  pressure_variants tdefs val_pss;
+  pressure_variants tdefs exn_pss
+
+(*****************************)
+(* Utilities for diagnostics *)
+(*****************************)
+
+(*
+  Build up a working pattern matrix by forgetting
+  about guarded patterns
+*)
+
+let rec initial_matrix = function
+    [] -> []
+  | {c_guard=Some _} :: rem -> initial_matrix rem
+  | {c_guard=None; c_lhs=p} :: rem -> [p] :: initial_matrix rem
+
+(*
+   Build up a working pattern matrix by keeping
+   only the patterns which are guarded
+*)
+let rec initial_only_guarded = function
+  | [] -> []
+  | { c_guard = None; _} :: rem ->
+      initial_only_guarded rem
+  | { c_lhs = pat; _ } :: rem ->
+      [pat] :: initial_only_guarded rem
+
+
+(************************)
+(* Exhaustiveness check *)
+(************************)
+
+(* conversion from Typedtree.pattern to Parsetree.pattern list *)
+module Conv = struct
+  open Parsetree
+  let mkpat desc = Ast_helper.Pat.mk desc
+
+  let name_counter = ref 0
+  let fresh name =
+    let current = !name_counter in
+    name_counter := !name_counter + 1;
+    "#$" ^ name ^ Int.to_string current
+
+  let conv typed =
+    let constrs = Hashtbl.create 7 in
+    let labels = Hashtbl.create 7 in
+    let rec loop pat =
+      match pat.pat_desc with
+        Tpat_or (pa,pb,_) ->
+          mkpat (Ppat_or (loop pa, loop pb))
+      | Tpat_var (_, ({txt="*extension*"} as nm)) -> (* PR#7330 *)
+          mkpat (Ppat_var nm)
+      | Tpat_any
+      | Tpat_var _ ->
+          mkpat Ppat_any
+      | Tpat_constant c ->
+          mkpat (Ppat_constant (Untypeast.constant c))
+      | Tpat_alias (p,_,_) -> loop p
+      | Tpat_tuple lst ->
+          mkpat (Ppat_tuple (List.map loop lst))
+      | Tpat_construct (cstr_lid, cstr, lst) ->
+          let id = fresh cstr.cstr_name in
+          let lid = { cstr_lid with txt = Longident.Lident id } in
+          Hashtbl.add constrs id cstr;
+          let arg =
+            match List.map loop lst with
+            | []  -> None
+            | [p] -> Some p
+            | lst -> Some (mkpat (Ppat_tuple lst))
+          in
+          mkpat (Ppat_construct(lid, arg))
+      | Tpat_variant(label,p_opt,_row_desc) ->
+          let arg = Option.map loop p_opt in
+          mkpat (Ppat_variant(label, arg))
+      | Tpat_record (subpatterns, _closed_flag) ->
+          let fields =
+            List.map
+              (fun (_, lbl, p) ->
+                let id = fresh lbl.lbl_name in
+                Hashtbl.add labels id lbl;
+                (mknoloc (Longident.Lident id), loop p))
+              subpatterns
+          in
+          mkpat (Ppat_record (fields, Open))
+      | Tpat_array lst ->
+          mkpat (Ppat_array (List.map loop lst))
+      | Tpat_lazy p ->
+          mkpat (Ppat_lazy (loop p))
+    in
+    let ps = loop typed in
+    (ps, constrs, labels)
+end
+
+
+(* Whether the counter-example contains an extension pattern *)
+let contains_extension pat =
+  exists_pattern
+    (function
+     | {pat_desc=Tpat_var (_, {txt="*extension*"})} -> true
+     | _ -> false)
+    pat
+
+(* Build a pattern from its expected type *)
+type pat_explosion = PE_single | PE_gadt_cases
+type ppat_of_type =
+  | PT_empty
+  | PT_any
+  | PT_pattern of
+      pat_explosion *
+      Parsetree.pattern *
+      (string, constructor_description) Hashtbl.t *
+      (string, label_description) Hashtbl.t
+
+let ppat_of_type env ty =
+  match pats_of_type env ty with
+  | [] -> PT_empty
+  | [{pat_desc = Tpat_any}] -> PT_any
+  | [pat] ->
+      let (ppat, constrs, labels) = Conv.conv pat in
+      PT_pattern (PE_single, ppat, constrs, labels)
+  | pats ->
+      let (ppat, constrs, labels) = Conv.conv (orify_many pats) in
+      PT_pattern (PE_gadt_cases, ppat, constrs, labels)
+
+let do_check_partial ~pred loc casel pss = match pss with
+| [] ->
+        (*
+          This can occur
+          - For empty matches generated by ocamlp4 (no warning)
+          - when all patterns have guards (then, casel <> [])
+          (specific warning)
+          Then match MUST be considered non-exhaustive,
+          otherwise compilation of PM is broken.
+          *)
+    begin match casel with
+    | [] -> ()
+    | _  ->
+      if Warnings.is_active Warnings.All_clauses_guarded then
+        Location.prerr_warning loc Warnings.All_clauses_guarded
+    end ;
+    Partial
+| ps::_  ->
+    begin match exhaust None pss (List.length ps) with
+    | No_matching_value -> Total
+    | Witnesses [u] ->
+        let v =
+          let (pattern,constrs,labels) = Conv.conv u in
+          let u' = pred constrs labels pattern in
+          (* pretty_pat u;
+          begin match u' with
+            None -> prerr_endline ": impossible"
+          | Some _ -> prerr_endline ": possible"
+          end; *)
+          u'
+        in
+        begin match v with
+          None -> Total
+        | Some v ->
+            if Warnings.is_active (Warnings.Partial_match "") then begin
+              let errmsg =
+                try
+                  let buf = Buffer.create 16 in
+                  let fmt = Format.formatter_of_buffer buf in
+                  Printpat.top_pretty fmt v;
+                  if do_match (initial_only_guarded casel) [v] then
+                    Buffer.add_string buf
+                      "\n(However, some guarded clause may match this value.)";
+                  if contains_extension v then
+                    Buffer.add_string buf
+                      "\nMatching over values of extensible variant types \
+                         (the *extension* above)\n\
+                    must include a wild card pattern in order to be exhaustive."
+                  ;
+                  Buffer.contents buf
+                with _ ->
+                  ""
+              in
+                Location.prerr_warning loc (Warnings.Partial_match errmsg)
+            end;
+            Partial
+        end
+    | _ ->
+        fatal_error "Parmatch.check_partial"
+    end
+
+(*****************)
+(* Fragile check *)
+(*****************)
+
+(* Collect all data types in a pattern *)
+
+let rec add_path path = function
+  | [] -> [path]
+  | x::rem as paths ->
+      if Path.same path x then paths
+      else x::add_path path rem
+
+let extendable_path path =
+  not
+    (Path.same path Predef.path_bool ||
+    Path.same path Predef.path_list ||
+    Path.same path Predef.path_unit ||
+    Path.same path Predef.path_option)
+
+let rec collect_paths_from_pat r p = match p.pat_desc with
+| Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)},ps)
+  ->
+    let path = get_constructor_type_path p.pat_type p.pat_env in
+    List.fold_left
+      collect_paths_from_pat
+      (if extendable_path path then add_path path r else r)
+      ps
+| Tpat_any|Tpat_var _|Tpat_constant _| Tpat_variant (_,None,_) -> r
+| Tpat_tuple ps | Tpat_array ps
+| Tpat_construct (_, {cstr_tag=Cstr_extension _}, ps)->
+    List.fold_left collect_paths_from_pat r ps
+| Tpat_record (lps,_) ->
+    List.fold_left
+      (fun r (_, _, p) -> collect_paths_from_pat r p)
+      r lps
+| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_) -> collect_paths_from_pat r p
+| Tpat_or (p1,p2,_) ->
+    collect_paths_from_pat (collect_paths_from_pat r p1) p2
+| Tpat_lazy p
+    ->
+    collect_paths_from_pat r p
+
+
+(*
+  Actual fragile check
+   1. Collect data types in the patterns of the match.
+   2. One exhaustivity check per datatype, considering that
+      the type is extended.
+*)
+
+let do_check_fragile loc casel pss =
+  let exts =
+    List.fold_left
+      (fun r c -> collect_paths_from_pat r c.c_lhs)
+      [] casel in
+  match exts with
+  | [] -> ()
+  | _ -> match pss with
+    | [] -> ()
+    | ps::_ ->
+        List.iter
+          (fun ext ->
+            match exhaust (Some ext) pss (List.length ps) with
+            | No_matching_value ->
+                Location.prerr_warning
+                  loc
+                  (Warnings.Fragile_match (Path.name ext))
+            | Witnesses _ -> ())
+          exts
+
+(********************************)
+(* Exported unused clause check *)
+(********************************)
+
+let check_unused pred casel =
+  if Warnings.is_active Warnings.Unused_match
+  || List.exists (fun c -> c.c_rhs.exp_desc = Texp_unreachable) casel then
+    let rec do_rec pref = function
+      | [] -> ()
+      | {c_lhs=q; c_guard; c_rhs} :: rem ->
+          let qs = [q] in
+            begin try
+              let pss =
+                  get_mins le_pats (List.filter (compats qs) pref) in
+              (* First look for redundant or partially redundant patterns *)
+              let r = every_satisfiables (make_rows pss) (make_row qs) in
+              let refute = (c_rhs.exp_desc = Texp_unreachable) in
+              (* Do not warn for unused [pat -> .] *)
+              if r = Unused && refute then () else
+              let r =
+                (* Do not refine if either:
+                   - we already know the clause is unused
+                   - the clause under consideration is not a refutation clause
+                     and either:
+                     + there are no other lines
+                     + we do not care whether the types prevent this clause to
+                       be reached.
+                     If the clause under consideration *is* a refutation clause
+                     then we do need to check more carefully whether it can be
+                     refuted or not.  *)
+                let skip =
+                  r = Unused || (not refute && pref = []) ||
+                  not(refute || Warnings.is_active Warnings.Unreachable_case) in
+                if skip then r else
+                (* Then look for empty patterns *)
+                let sfs = list_satisfying_vectors pss qs in
+                if sfs = [] then Unused else
+                let sfs =
+                  List.map (function [u] -> u | _ -> assert false) sfs in
+                let u = orify_many sfs in
+                (*Format.eprintf "%a@." pretty_val u;*)
+                let (pattern,constrs,labels) = Conv.conv u in
+                let pattern = {pattern with Parsetree.ppat_loc = q.pat_loc} in
+                match pred refute constrs labels pattern with
+                  None when not refute ->
+                    Location.prerr_warning q.pat_loc Warnings.Unreachable_case;
+                    Used
+                | _ -> r
+              in
+              match r with
+              | Unused ->
+                  Location.prerr_warning
+                    q.pat_loc Warnings.Unused_match
+              | Upartial ps ->
+                  List.iter
+                    (fun p ->
+                      Location.prerr_warning
+                        p.pat_loc Warnings.Unused_pat)
+                    ps
+              | Used -> ()
+            with Empty | Not_found -> assert false
+            end ;
+
+          if c_guard <> None then
+            do_rec pref rem
+          else
+            do_rec ([q]::pref) rem in
+
+    do_rec [] casel
+
+(*********************************)
+(* Exported irrefutability tests *)
+(*********************************)
+
+let irrefutable pat = le_pat pat omega
+
+let inactive ~partial pat =
+  match partial with
+  | Partial -> false
+  | Total -> begin
+      let rec loop pat =
+        match pat.pat_desc with
+        | Tpat_lazy _ | Tpat_array _ ->
+          false
+        | Tpat_any | Tpat_var _ | Tpat_variant (_, None, _) ->
+            true
+        | Tpat_constant c -> begin
+            match c with
+            | Const_string _ -> Config.safe_string
+            | Const_int _ | Const_char _ | Const_float _
+            | Const_int32 _ | Const_int64 _ | Const_nativeint _ -> true
+          end
+        | Tpat_tuple ps | Tpat_construct (_, _, ps) ->
+            List.for_all (fun p -> loop p) ps
+        | Tpat_alias (p,_,_) | Tpat_variant (_, Some p, _) ->
+            loop p
+        | Tpat_record (ldps,_) ->
+            List.for_all
+              (fun (_, lbl, p) -> lbl.lbl_mut = Immutable && loop p)
+              ldps
+        | Tpat_or (p,q,_) ->
+            loop p && loop q
+      in
+      loop pat
+  end
+
+
+
+
+
+
+
+(*********************************)
+(* Exported exhaustiveness check *)
+(*********************************)
+
+(*
+   Fragile check is performed when required and
+   on exhaustive matches only.
+*)
+
+let check_partial pred loc casel =
+  let pss = initial_matrix casel in
+  let pss = get_mins le_pats pss in
+  let total = do_check_partial ~pred loc casel pss in
+  if
+    total = Total && Warnings.is_active (Warnings.Fragile_match "")
+  then begin
+    do_check_fragile loc casel pss
+  end ;
+  total
+
+(*************************************)
+(* Ambiguous variable in or-patterns *)
+(*************************************)
+
+(* Specification: ambiguous variables in or-patterns.
+
+   The semantics of or-patterns in OCaml is specified with
+   a left-to-right bias: a value [v] matches the pattern [p | q] if it
+   matches [p] or [q], but if it matches both, the environment
+   captured by the match is the environment captured by [p], never the
+   one captured by [q].
+
+   While this property is generally well-understood, one specific case
+   where users expect a different semantics is when a pattern is
+   followed by a when-guard: [| p when g -> e]. Consider for example:
+
+     | ((Const x, _) | (_, Const x)) when is_neutral x -> branch
+
+   The semantics is clear: match the scrutinee against the pattern, if
+   it matches, test the guard, and if the guard passes, take the
+   branch.
+
+   However, consider the input [(Const a, Const b)], where [a] fails
+   the test [is_neutral f], while [b] passes the test [is_neutral
+   b]. With the left-to-right semantics, the clause above is *not*
+   taken by its input: matching [(Const a, Const b)] against the
+   or-pattern succeeds in the left branch, it returns the environment
+   [x -> a], and then the guard [is_neutral a] is tested and fails,
+   the branch is not taken. Most users, however, intuitively expect
+   that any pair that has one side passing the test will take the
+   branch. They assume it is equivalent to the following:
+
+     | (Const x, _) when is_neutral x -> branch
+     | (_, Const x) when is_neutral x -> branch
+
+   while it is not.
+
+   The code below is dedicated to finding these confusing cases: the
+   cases where a guard uses "ambiguous" variables, that are bound to
+   different parts of the scrutinees by different sides of
+   a or-pattern. In other words, it finds the cases where the
+   specified left-to-right semantics is not equivalent to
+   a non-deterministic semantics (any branch can be taken) relatively
+   to a specific guard.
+*)
+
+let pattern_vars p = Ident.Set.of_list (Typedtree.pat_bound_idents p)
+
+(* Row for ambiguous variable search,
+   row is the traditional pattern row,
+   varsets contain a list of head variable sets (varsets)
+
+   A given varset contains all the variables that appeared at the head
+   of a pattern in the row at some point during traversal: they would
+   all be bound to the same value at matching time. On the contrary,
+   two variables of different varsets appeared at different places in
+   the pattern and may be bound to distinct sub-parts of the matched
+   value.
+
+   All rows of a (sub)matrix have rows of the same length,
+   but also varsets of the same length.
+
+   Varsets are populated when simplifying the first column
+   -- the variables of the head pattern are collected in a new varset.
+   For example,
+     { row = x :: r1; varsets = s1 }
+     { row = (Some _) as y :: r2; varsets  = s2 }
+     { row = (None as x) as y :: r3; varsets = s3 }
+     { row = (Some x | (None as x)) :: r4 with varsets = s4 }
+   becomes
+     (_, { row = r1; varsets = {x} :: s1 })
+     (Some _, { row = r2; varsets = {y} :: s2 })
+     (None, { row = r3; varsets = {x, y} :: s3 })
+     (Some x, { row = r4; varsets = {} :: s4 })
+     (None, { row = r4; varsets = {x} :: s4 })
+*)
+type amb_row = { row : pattern list ; varsets : Ident.Set.t list; }
+
+let simplify_head_amb_pat head_bound_variables varsets ~add_column p ps k =
+  let rec simpl head_bound_variables varsets p ps k =
+    match p.pat_desc with
+    | Tpat_alias (p,x,_) ->
+      simpl (Ident.Set.add x head_bound_variables) varsets p ps k
+    | Tpat_var (x,_) ->
+      let rest_of_the_row =
+        { row = ps; varsets = Ident.Set.add x head_bound_variables :: varsets; }
+      in
+      add_column (Pattern_head.deconstruct omega) rest_of_the_row k
+    | Tpat_or (p1,p2,_) ->
+      simpl head_bound_variables varsets p1 ps
+        (simpl head_bound_variables varsets p2 ps k)
+    | _ ->
+      add_column (Pattern_head.deconstruct p)
+        { row = ps; varsets = head_bound_variables :: varsets; } k
+  in simpl head_bound_variables varsets p ps k
+
+(*
+   To accurately report ambiguous variables, one must consider
+   that previous clauses have already matched some values.
+   Consider for example:
+
+     | (Foo x, Foo y) -> ...
+     | ((Foo x, _) | (_, Foo x)) when bar x -> ...
+
+   The second line taken in isolation uses an unstable variable,
+   but the discriminating values, of the shape [(Foo v1, Foo v2)],
+   would all be filtered by the line above.
+
+   To track this information, the matrices we analyze contain both
+   *positive* rows, that describe the rows currently being analyzed
+   (of type Varsets.row, so that their varsets are tracked) and
+   *negative rows*, that describe the cases already matched against.
+
+   The values matched by a signed matrix are the values matched by
+   some of the positive rows but none of the negative rows. In
+   particular, a variable is stable if, for any value not matched by
+   any of the negative rows, the environment captured by any of the
+   matching positive rows is identical.
+*)
+type ('a, 'b) signed = Positive of 'a | Negative of 'b
+
+let rec simplify_first_amb_col = function
+  | [] -> []
+  | (Negative [] | Positive { row = []; _ }) :: _  -> assert false
+  | Negative (n :: ns) :: rem ->
+      let add_column n ns k = (n, Negative ns) :: k in
+      simplify_head_pat
+        ~add_column n ns (simplify_first_amb_col rem)
+  | Positive { row = p::ps; varsets; }::rem ->
+      let add_column p ps k = (p, Positive ps) :: k in
+      simplify_head_amb_pat
+        Ident.Set.empty varsets
+        ~add_column p ps (simplify_first_amb_col rem)
+
+(* Compute stable bindings *)
+
+type stable_vars =
+  | All
+  | Vars of Ident.Set.t
+
+let stable_inter sv1 sv2 = match sv1, sv2 with
+  | All, sv | sv, All -> sv
+  | Vars s1, Vars s2 -> Vars (Ident.Set.inter s1 s2)
+
+let reduce f = function
+| [] -> invalid_arg "reduce"
+| x::xs -> List.fold_left f x xs
+
+let rec matrix_stable_vars m = match m with
+  | [] -> All
+  | ((Positive {row = []; _} | Negative []) :: _) as empty_rows ->
+      let exception Negative_empty_row in
+      (* if at least one empty row is negative, the matrix matches no value *)
+      let get_varsets = function
+        | Negative n ->
+            (* All rows have the same number of columns;
+               if the first row is empty, they all are. *)
+            assert (n = []);
+            raise Negative_empty_row
+        | Positive p ->
+            assert (p.row = []);
+            p.varsets in
+      begin match List.map get_varsets empty_rows with
+      | exception Negative_empty_row -> All
+      | rows_varsets ->
+          let stables_in_varsets =
+            reduce (List.map2 Ident.Set.inter) rows_varsets in
+          (* The stable variables are those stable at any position *)
+          Vars
+            (List.fold_left Ident.Set.union Ident.Set.empty stables_in_varsets)
+      end
+  | m ->
+      let is_negative = function
+        | Negative _ -> true
+        | Positive _ -> false in
+      if List.for_all is_negative m then
+        (* optimization: quit early if there are no positive rows.
+           This may happen often when the initial matrix has many
+           negative cases and few positive cases (a small guarded
+           clause after a long list of clauses) *)
+        All
+      else begin
+        let m = simplify_first_amb_col m in
+        if not (all_coherent (first_column m)) then
+          All
+        else begin
+          (* If the column is ill-typed but deemed coherent, we might
+             spuriously warn about some variables being unstable.
+             As sad as that might be, the warning can be silenced by
+             splitting the or-pattern...  *)
+          let submatrices =
+            let extend_row columns = function
+              | Negative r -> Negative (columns @ r)
+              | Positive r -> Positive { r with row = columns @ r.row } in
+            let q0 = discr_pat omega m in
+            let { default; constrs } =
+              build_specialized_submatrices ~extend_row q0 m in
+            let non_default = List.map snd constrs in
+            if full_match false constrs
+            then non_default
+            else default :: non_default in
+          (* A stable variable must be stable in each submatrix. *)
+          let submat_stable = List.map matrix_stable_vars submatrices in
+          List.fold_left stable_inter All submat_stable
+        end
+      end
+
+let pattern_stable_vars ns p =
+  matrix_stable_vars
+    (List.fold_left (fun m n -> Negative n :: m)
+       [Positive {varsets = []; row = [p]}] ns)
+
+(* All identifier paths that appear in an expression that occurs
+   as a clause right hand side or guard.
+
+  The function is rather complex due to the compilation of
+  unpack patterns by introducing code in rhs expressions
+  and **guards**.
+
+  For pattern (module M:S)  -> e the code is
+  let module M_mod = unpack M .. in e
+
+  Hence M is "free" in e iff M_mod is free in e.
+
+  Not doing so will yield excessive  warning in
+  (module (M:S) } ...) when true -> ....
+  as M is always present in
+  let module M_mod = unpack M .. in true
+*)
+
+let all_rhs_idents exp =
+  let ids = ref Ident.Set.empty in
+(* Very hackish, detect unpack pattern  compilation
+   and perform "indirect check for them" *)
+  let is_unpack exp =
+      List.exists
+        (fun attr -> attr.Parsetree.attr_name.txt = "#modulepat")
+        exp.exp_attributes in
+  let open Tast_iterator in
+  let expr_iter iter exp =
+    (match exp.exp_desc with
+      | Texp_ident (path, _lid, _descr) ->
+        List.iter (fun id -> ids := Ident.Set.add id !ids) (Path.heads path)
+      (* Use default iterator methods for rest of match.*)
+      | _ -> Tast_iterator.default_iterator.expr iter exp);
+
+    if is_unpack exp then begin match exp.exp_desc with
+    | Texp_letmodule
+        (id_mod,_,_,
+         {mod_desc=
+          Tmod_unpack ({exp_desc=Texp_ident (Path.Pident id_exp,_,_)},_)},
+         _) ->
+           assert (Ident.Set.mem id_exp !ids) ;
+           begin match id_mod with
+           | Some id_mod when not (Ident.Set.mem id_mod !ids) ->
+             ids := Ident.Set.remove id_exp !ids
+           | _ -> ()
+           end
+    | _ -> assert false
+    end
+  in
+  let iterator = {Tast_iterator.default_iterator with expr = expr_iter} in
+  iterator.expr iterator exp;
+  !ids
+
+let check_ambiguous_bindings =
+  let open Warnings in
+  let warn0 = Ambiguous_pattern [] in
+  fun cases ->
+    if is_active warn0 then
+      let check_case ns case = match case with
+        | { c_lhs = p; c_guard=None ; _} -> [p]::ns
+        | { c_lhs=p; c_guard=Some g; _} ->
+            let all =
+              Ident.Set.inter (pattern_vars p) (all_rhs_idents g) in
+            if not (Ident.Set.is_empty all) then begin
+              match pattern_stable_vars ns p with
+              | All -> ()
+              | Vars stable ->
+                  let ambiguous = Ident.Set.diff all stable in
+                  if not (Ident.Set.is_empty ambiguous) then begin
+                    let pps =
+                      Ident.Set.elements ambiguous |> List.map Ident.name in
+                    let warn = Ambiguous_pattern pps in
+                    Location.prerr_warning p.pat_loc warn
+                  end
+            end;
+            ns
+      in
+      ignore (List.fold_left check_case [] cases)
diff --git a/upstream/ocaml_411/typing/parmatch.mli b/upstream/ocaml_411/typing/parmatch.mli
new file mode 100644
index 0000000..e6952be
--- /dev/null
+++ b/upstream/ocaml_411/typing/parmatch.mli
@@ -0,0 +1,187 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Detection of partial matches and unused match cases. *)
+
+open Asttypes
+open Typedtree
+open Types
+
+val omega : pattern
+(** aka. "Tpat_any" or "_"  *)
+
+val omegas : int -> pattern list
+(** [List.init (fun _ -> omega)] *)
+
+val omega_list : 'a list -> pattern list
+(** [List.map (fun _ -> omega)] *)
+
+module Pattern_head : sig
+  type desc =
+    | Any
+    | Construct of constructor_description
+    | Constant of constant
+    | Tuple of int
+    | Record of label_description list
+    | Variant of
+        { tag: label; has_arg: bool;
+          cstr_row: row_desc ref;
+          type_row : unit -> row_desc; }
+          (* the row of the type may evolve if [close_variant] is called,
+             hence the (unit -> ...) delay *)
+    | Array of int
+    | Lazy
+
+  type t
+
+  val desc : t -> desc
+  val env : t -> Env.t
+  val loc : t -> Location.t
+  val typ : t -> Types.type_expr
+
+  (** [deconstruct p] returns the head of [p] and the list of sub patterns.
+
+      @raises [Invalid_arg _] if [p] is an or- or an exception-pattern.  *)
+  val deconstruct : pattern -> t * pattern list
+
+  (** reconstructs a pattern, putting wildcards as sub-patterns. *)
+  val to_omega_pattern : t -> pattern
+
+  val make
+    :  loc:Location.t
+    -> typ:Types.type_expr
+    -> env:Env.t
+    -> desc
+    -> t
+
+  val omega : t
+
+end
+
+val normalize_pat : pattern -> pattern
+(** Keep only the "head" of a pattern: all arguments are replaced by [omega], so
+    are variables. *)
+
+val const_compare : constant -> constant -> int
+(** [const_compare c1 c2] compares the actual values represented by [c1] and
+    [c2], while simply using [Stdlib.compare] would compare the
+    representations.
+
+    cf. MPR#5758 *)
+
+val le_pat : pattern -> pattern -> bool
+(** [le_pat p q]  means: forall V,  V matches q implies V matches p *)
+
+val le_pats : pattern list -> pattern list -> bool
+(** [le_pats (p1 .. pm) (q1 .. qn)] means: forall i <= m, [le_pat pi qi] *)
+
+(** Exported compatibility functor, abstracted over constructor equality *)
+module Compat :
+  functor
+    (_ : sig
+      val equal :
+          Types.constructor_description ->
+            Types.constructor_description ->
+              bool
+     end) -> sig
+       val compat : pattern -> pattern -> bool
+       val compats : pattern list -> pattern list -> bool
+     end
+
+exception Empty
+
+val lub : pattern -> pattern -> pattern
+(** [lub p q] is a pattern that matches all values matched by [p] and [q].
+    May raise [Empty], when [p] and [q] are not compatible. *)
+
+val lubs : pattern list -> pattern list -> pattern list
+(** [lubs [p1; ...; pn] [q1; ...; qk]], where [n < k], is
+    [[lub p1 q1; ...; lub pk qk]].  *)
+
+val get_mins : ('a -> 'a -> bool) -> 'a list -> 'a list
+
+(** Those two functions recombine one pattern and its arguments:
+    For instance:
+      (_,_)::p1::p2::rem -> (p1, p2)::rem
+    The second one will replace mutable arguments by '_'
+*)
+val set_args : pattern -> pattern list -> pattern list
+val set_args_erase_mutable : pattern -> pattern list -> pattern list
+
+val pat_of_constr : pattern -> constructor_description -> pattern
+val complete_constrs :
+    pattern -> constructor_tag list -> constructor_description  list
+
+(** [ppat_of_type] builds an untyped pattern from its expected type,
+    for explosion of wildcard patterns in Typecore.type_pat.
+
+    There are four interesting cases:
+    - the type is empty ([PT_empty])
+    - no further explosion is necessary ([PT_any])
+    - a single pattern is generated, from a record or tuple type
+      or a single-variant type ([PE_single])
+    - an or-pattern is generated, in the case that all branches
+      are GADT constructors ([PE_gadt_cases]).
+ *)
+type pat_explosion = PE_single | PE_gadt_cases
+type ppat_of_type =
+  | PT_empty
+  | PT_any
+  | PT_pattern of
+      pat_explosion *
+      Parsetree.pattern *
+      (string, constructor_description) Hashtbl.t *
+      (string, label_description) Hashtbl.t
+
+val ppat_of_type: Env.t -> type_expr -> ppat_of_type
+
+val pressure_variants:
+  Env.t -> pattern list -> unit
+val pressure_variants_in_computation_pattern:
+  Env.t -> computation general_pattern list -> unit
+
+(** [check_partial pred loc caselist] and [check_unused refute pred caselist]
+    are called with a function [pred] which will be given counter-example
+    candidates: they may be partially ill-typed, and have to be type-checked
+    to extract a valid counter-example.
+    [pred] returns a valid counter-example or [None].
+    [refute] indicates that [check_unused] was called on a refutation clause.
+ *)
+val check_partial:
+    ((string, constructor_description) Hashtbl.t ->
+     (string, label_description) Hashtbl.t ->
+     Parsetree.pattern -> pattern option) ->
+    Location.t -> value case list -> partial
+val check_unused:
+    (bool ->
+     (string, constructor_description) Hashtbl.t ->
+     (string, label_description) Hashtbl.t ->
+     Parsetree.pattern -> pattern option) ->
+    value case list -> unit
+
+(* Irrefutability tests *)
+val irrefutable : pattern -> bool
+
+(** An inactive pattern is a pattern, matching against which can be duplicated,
+    erased or delayed without change in observable behavior of the program.
+    Patterns containing (lazy _) subpatterns or reads of mutable fields are
+    active. *)
+val inactive : partial:partial -> pattern -> bool
+
+(* Ambiguous bindings *)
+val check_ambiguous_bindings : value case list -> unit
+
+(* The tag used for open polymorphic variant types with an abstract row *)
+val some_private_tag : label
diff --git a/upstream/ocaml_411/typing/path.ml b/upstream/ocaml_411/typing/path.ml
new file mode 100644
index 0000000..e5a8d7e
--- /dev/null
+++ b/upstream/ocaml_411/typing/path.ml
@@ -0,0 +1,129 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t =
+    Pident of Ident.t
+  | Pdot of t * string
+  | Papply of t * t
+
+let rec same p1 p2 =
+  p1 == p2
+  || match (p1, p2) with
+    (Pident id1, Pident id2) -> Ident.same id1 id2
+  | (Pdot(p1, s1), Pdot(p2, s2)) -> s1 = s2 && same p1 p2
+  | (Papply(fun1, arg1), Papply(fun2, arg2)) ->
+       same fun1 fun2 && same arg1 arg2
+  | (_, _) -> false
+
+let rec compare p1 p2 =
+  if p1 == p2 then 0
+  else match (p1, p2) with
+    (Pident id1, Pident id2) -> Ident.compare id1 id2
+  | (Pdot(p1, s1), Pdot(p2, s2)) ->
+      let h = compare p1 p2 in
+      if h <> 0 then h else String.compare s1 s2
+  | (Papply(fun1, arg1), Papply(fun2, arg2)) ->
+      let h = compare fun1 fun2 in
+      if h <> 0 then h else compare arg1 arg2
+  | ((Pident _ | Pdot _), (Pdot _ | Papply _)) -> -1
+  | ((Pdot _ | Papply _), (Pident _ | Pdot _)) -> 1
+
+let rec find_free_opt ids = function
+    Pident id -> List.find_opt (Ident.same id) ids
+  | Pdot(p, _s) -> find_free_opt ids p
+  | Papply(p1, p2) ->
+      match find_free_opt ids p1 with
+      | None -> find_free_opt ids p2
+      | Some _ as res -> res
+
+let exists_free ids p =
+  match find_free_opt ids p with
+  | None -> false
+  | _ -> true
+
+let rec scope = function
+    Pident id -> Ident.scope id
+  | Pdot(p, _s) -> scope p
+  | Papply(p1, p2) -> max (scope p1) (scope p2)
+
+let kfalse _ = false
+
+let rec name ?(paren=kfalse) = function
+    Pident id -> Ident.name id
+  | Pdot(p, s) ->
+      name ~paren p ^ if paren s then ".( " ^ s ^ " )" else "." ^ s
+  | Papply(p1, p2) -> name ~paren p1 ^ "(" ^ name ~paren p2 ^ ")"
+
+let rec print ppf = function
+  | Pident id -> Ident.print_with_scope ppf id
+  | Pdot(p, s) -> Format.fprintf ppf "%a.%s" print p s
+  | Papply(p1, p2) -> Format.fprintf ppf "%a(%a)" print p1 print p2
+
+let rec head = function
+    Pident id -> id
+  | Pdot(p, _s) -> head p
+  | Papply _ -> assert false
+
+let flatten =
+  let rec flatten acc = function
+    | Pident id -> `Ok (id, acc)
+    | Pdot (p, s) -> flatten (s :: acc) p
+    | Papply _ -> `Contains_apply
+  in
+  fun t -> flatten [] t
+
+let heads p =
+  let rec heads p acc = match p with
+    | Pident id -> id :: acc
+    | Pdot (p, _s) -> heads p acc
+    | Papply(p1, p2) ->
+        heads p1 (heads p2 acc)
+  in heads p []
+
+let rec last = function
+  | Pident id -> Ident.name id
+  | Pdot(_, s) -> s
+  | Papply(_, p) -> last p
+
+let is_uident s =
+  assert (s <> "");
+  match s.[0] with
+  | 'A'..'Z' -> true
+  | _ -> false
+
+type typath =
+  | Regular of t
+  | Ext of t * string
+  | LocalExt of Ident.t
+  | Cstr of t * string
+
+let constructor_typath = function
+  | Pident id when is_uident (Ident.name id) -> LocalExt id
+  | Pdot(ty_path, s) when is_uident s ->
+      if is_uident (last ty_path) then Ext (ty_path, s)
+      else Cstr (ty_path, s)
+  | p -> Regular p
+
+let is_constructor_typath p =
+  match constructor_typath p with
+  | Regular _ -> false
+  | _ -> true
+
+module T = struct
+  type nonrec t = t
+  let compare = compare
+end
+module Set = Set.Make(T)
+module Map = Map.Make(T)
diff --git a/upstream/ocaml_411/typing/path.mli b/upstream/ocaml_411/typing/path.mli
new file mode 100644
index 0000000..bddf9d6
--- /dev/null
+++ b/upstream/ocaml_411/typing/path.mli
@@ -0,0 +1,52 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Access paths *)
+
+type t =
+    Pident of Ident.t
+  | Pdot of t * string
+  | Papply of t * t
+
+val same: t -> t -> bool
+val compare: t -> t -> int
+val find_free_opt: Ident.t list -> t -> Ident.t option
+val exists_free: Ident.t list -> t -> bool
+val scope: t -> int
+val flatten : t -> [ `Contains_apply | `Ok of Ident.t * string list ]
+
+val name: ?paren:(string -> bool) -> t -> string
+    (* [paren] tells whether a path suffix needs parentheses *)
+val head: t -> Ident.t
+
+val print: Format.formatter -> t -> unit
+
+val heads: t -> Ident.t list
+
+val last: t -> string
+
+val is_uident: string -> bool
+
+type typath =
+  | Regular of t
+  | Ext of t * string
+  | LocalExt of Ident.t
+  | Cstr of t * string
+
+val constructor_typath: t -> typath
+val is_constructor_typath: t -> bool
+
+module Map : Map.S with type key = t
+module Set : Set.S with type elt = t
diff --git a/upstream/ocaml_411/typing/persistent_env.ml b/upstream/ocaml_411/typing/persistent_env.ml
new file mode 100644
index 0000000..1931f5f
--- /dev/null
+++ b/upstream/ocaml_411/typing/persistent_env.ml
@@ -0,0 +1,373 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Xavier Leroy, projet Gallium, INRIA Rocquencourt                     *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*                                                                        *)
+(*   Copyright 2019 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Persistent structure descriptions *)
+
+open Misc
+open Cmi_format
+
+module Consistbl = Consistbl.Make (Misc.Stdlib.String)
+
+let add_delayed_check_forward = ref (fun _ -> assert false)
+
+type error =
+  | Illegal_renaming of modname * modname * filepath
+  | Inconsistent_import of modname * filepath * filepath
+  | Need_recursive_types of modname
+  | Depend_on_unsafe_string_unit of modname
+
+exception Error of error
+let error err = raise (Error err)
+
+module Persistent_signature = struct
+  type t =
+    { filename : string;
+      cmi : Cmi_format.cmi_infos }
+
+  let load = ref (fun ~unit_name ->
+      match Load_path.find_uncap (unit_name ^ ".cmi") with
+      | filename -> Some { filename; cmi = read_cmi filename }
+      | exception Not_found -> None)
+end
+
+type can_load_cmis =
+  | Can_load_cmis
+  | Cannot_load_cmis of EnvLazy.log
+
+type pers_struct = {
+  ps_name: string;
+  ps_crcs: (string * Digest.t option) list;
+  ps_filename: string;
+  ps_flags: pers_flags list;
+}
+
+module String = Misc.Stdlib.String
+
+(* If a .cmi file is missing (or invalid), we
+   store it as Missing in the cache. *)
+type 'a pers_struct_info =
+  | Missing
+  | Found of pers_struct * 'a
+
+type 'a t = {
+  persistent_structures : (string, 'a pers_struct_info) Hashtbl.t;
+  imported_units: String.Set.t ref;
+  imported_opaque_units: String.Set.t ref;
+  crc_units: Consistbl.t;
+  can_load_cmis: can_load_cmis ref;
+}
+
+let empty () = {
+  persistent_structures = Hashtbl.create 17;
+  imported_units = ref String.Set.empty;
+  imported_opaque_units = ref String.Set.empty;
+  crc_units = Consistbl.create ();
+  can_load_cmis = ref Can_load_cmis;
+}
+
+let clear penv =
+  let {
+    persistent_structures;
+    imported_units;
+    imported_opaque_units;
+    crc_units;
+    can_load_cmis;
+  } = penv in
+  Hashtbl.clear persistent_structures;
+  imported_units := String.Set.empty;
+  imported_opaque_units := String.Set.empty;
+  Consistbl.clear crc_units;
+  can_load_cmis := Can_load_cmis;
+  ()
+
+let clear_missing {persistent_structures; _} =
+  let missing_entries =
+    Hashtbl.fold
+      (fun name r acc -> if r = Missing then name :: acc else acc)
+      persistent_structures []
+  in
+  List.iter (Hashtbl.remove persistent_structures) missing_entries
+
+let add_import {imported_units; _} s =
+  imported_units := String.Set.add s !imported_units
+
+let register_import_as_opaque {imported_opaque_units; _} s =
+  imported_opaque_units := String.Set.add s !imported_opaque_units
+
+let find_in_cache {persistent_structures; _} s =
+  match Hashtbl.find persistent_structures s with
+  | exception Not_found -> None
+  | Missing -> None
+  | Found (_ps, pm) -> Some pm
+
+let import_crcs penv ~source crcs =
+  let {crc_units; _} = penv in
+  let import_crc (name, crco) =
+    match crco with
+    | None -> ()
+    | Some crc ->
+        add_import penv name;
+        Consistbl.check crc_units name crc source
+  in List.iter import_crc crcs
+
+let check_consistency penv ps =
+  try import_crcs penv ~source:ps.ps_filename ps.ps_crcs
+  with Consistbl.Inconsistency {
+      unit_name = name;
+      inconsistent_source = source;
+      original_source = auth;
+    } ->
+    error (Inconsistent_import(name, auth, source))
+
+let can_load_cmis penv =
+  !(penv.can_load_cmis)
+let set_can_load_cmis penv setting =
+  penv.can_load_cmis := setting
+
+let without_cmis penv f x =
+  let log = EnvLazy.log () in
+  let res =
+    Misc.(protect_refs
+            [R (penv.can_load_cmis, Cannot_load_cmis log)]
+            (fun () -> f x))
+  in
+  EnvLazy.backtrack log;
+  res
+
+let fold {persistent_structures; _} f x =
+  Hashtbl.fold (fun modname pso x -> match pso with
+      | Missing -> x
+      | Found (_, pm) -> f modname pm x)
+    persistent_structures x
+
+(* Reading persistent structures from .cmi files *)
+
+let save_pers_struct penv crc ps pm =
+  let {persistent_structures; crc_units; _} = penv in
+  let modname = ps.ps_name in
+  Hashtbl.add persistent_structures modname (Found (ps, pm));
+  List.iter
+    (function
+        | Rectypes -> ()
+        | Alerts _ -> ()
+        | Unsafe_string -> ()
+        | Opaque -> register_import_as_opaque penv modname)
+    ps.ps_flags;
+  Consistbl.set crc_units modname crc ps.ps_filename;
+  add_import penv modname
+
+let acknowledge_pers_struct penv check modname pers_sig pm =
+  let { Persistent_signature.filename; cmi } = pers_sig in
+  let name = cmi.cmi_name in
+  let crcs = cmi.cmi_crcs in
+  let flags = cmi.cmi_flags in
+  let ps = { ps_name = name;
+             ps_crcs = crcs;
+             ps_filename = filename;
+             ps_flags = flags;
+           } in
+  if ps.ps_name <> modname then
+    error (Illegal_renaming(modname, ps.ps_name, filename));
+  List.iter
+    (function
+        | Rectypes ->
+            if not !Clflags.recursive_types then
+              error (Need_recursive_types(ps.ps_name))
+        | Unsafe_string ->
+            if Config.safe_string then
+              error (Depend_on_unsafe_string_unit(ps.ps_name));
+        | Alerts _ -> ()
+        | Opaque -> register_import_as_opaque penv modname)
+    ps.ps_flags;
+  if check then check_consistency penv ps;
+  let {persistent_structures; _} = penv in
+  Hashtbl.add persistent_structures modname (Found (ps, pm));
+  ps
+
+let read_pers_struct penv val_of_pers_sig check modname filename =
+  add_import penv modname;
+  let cmi = read_cmi filename in
+  let pers_sig = { Persistent_signature.filename; cmi } in
+  let pm = val_of_pers_sig pers_sig in
+  let ps = acknowledge_pers_struct penv check modname pers_sig pm in
+  (ps, pm)
+
+let find_pers_struct penv val_of_pers_sig check name =
+  let {persistent_structures; _} = penv in
+  if name = "*predef*" then raise Not_found;
+  match Hashtbl.find persistent_structures name with
+  | Found (ps, pm) -> (ps, pm)
+  | Missing -> raise Not_found
+  | exception Not_found ->
+    match can_load_cmis penv with
+    | Cannot_load_cmis _ -> raise Not_found
+    | Can_load_cmis ->
+        let psig =
+          match !Persistent_signature.load ~unit_name:name with
+          | Some psig -> psig
+          | None ->
+            Hashtbl.add persistent_structures name Missing;
+            raise Not_found
+        in
+        add_import penv name;
+        let pm = val_of_pers_sig psig in
+        let ps = acknowledge_pers_struct penv check name psig pm in
+        (ps, pm)
+
+(* Emits a warning if there is no valid cmi for name *)
+let check_pers_struct penv f ~loc name =
+  try
+    ignore (find_pers_struct penv f false name)
+  with
+  | Not_found ->
+      let warn = Warnings.No_cmi_file(name, None) in
+        Location.prerr_warning loc warn
+  | Cmi_format.Error err ->
+      let msg = Format.asprintf "%a" Cmi_format.report_error err in
+      let warn = Warnings.No_cmi_file(name, Some msg) in
+        Location.prerr_warning loc warn
+  | Error err ->
+      let msg =
+        match err with
+        | Illegal_renaming(name, ps_name, filename) ->
+            Format.asprintf
+              " %a@ contains the compiled interface for @ \
+               %s when %s was expected"
+              Location.print_filename filename ps_name name
+        | Inconsistent_import _ -> assert false
+        | Need_recursive_types name ->
+            Format.sprintf
+              "%s uses recursive types"
+              name
+        | Depend_on_unsafe_string_unit name ->
+            Printf.sprintf "%s uses -unsafe-string"
+              name
+      in
+      let warn = Warnings.No_cmi_file(name, Some msg) in
+        Location.prerr_warning loc warn
+
+let read penv f modname filename =
+  snd (read_pers_struct penv f true modname filename)
+
+let find penv f name =
+  snd (find_pers_struct penv f true name)
+
+let check penv f ~loc name =
+  let {persistent_structures; _} = penv in
+  if not (Hashtbl.mem persistent_structures name) then begin
+    (* PR#6843: record the weak dependency ([add_import]) regardless of
+       whether the check succeeds, to help make builds more
+       deterministic. *)
+    add_import penv name;
+    if (Warnings.is_active (Warnings.No_cmi_file("", None))) then
+      !add_delayed_check_forward
+        (fun () -> check_pers_struct penv f ~loc name)
+  end
+
+let crc_of_unit penv f name =
+  let (ps, _pm) = find_pers_struct penv f true name in
+  let crco =
+    try
+      List.assoc name ps.ps_crcs
+    with Not_found ->
+      assert false
+  in
+    match crco with
+      None -> assert false
+    | Some crc -> crc
+
+let imports {imported_units; crc_units; _} =
+  Consistbl.extract (String.Set.elements !imported_units) crc_units
+
+let looked_up {persistent_structures; _} modname =
+  Hashtbl.mem persistent_structures modname
+
+let is_imported {imported_units; _} s =
+  String.Set.mem s !imported_units
+
+let is_imported_opaque {imported_opaque_units; _} s =
+  String.Set.mem s !imported_opaque_units
+
+let make_cmi penv modname sign alerts =
+  let flags =
+    List.concat [
+      if !Clflags.recursive_types then [Cmi_format.Rectypes] else [];
+      if !Clflags.opaque then [Cmi_format.Opaque] else [];
+      (if !Clflags.unsafe_string then [Cmi_format.Unsafe_string] else []);
+      [Alerts alerts];
+    ]
+  in
+  let crcs = imports penv in
+  {
+    cmi_name = modname;
+    cmi_sign = sign;
+    cmi_crcs = crcs;
+    cmi_flags = flags
+  }
+
+let save_cmi penv psig pm =
+  let { Persistent_signature.filename; cmi } = psig in
+  Misc.try_finally (fun () ->
+      let {
+        cmi_name = modname;
+        cmi_sign = _;
+        cmi_crcs = imports;
+        cmi_flags = flags;
+      } = cmi in
+      let crc =
+        output_to_file_via_temporary (* see MPR#7472, MPR#4991 *)
+          ~mode: [Open_binary] filename
+          (fun temp_filename oc -> output_cmi temp_filename oc cmi) in
+      (* Enter signature in persistent table so that imports()
+         will also return its crc *)
+      let ps =
+        { ps_name = modname;
+          ps_crcs = (cmi.cmi_name, Some crc) :: imports;
+          ps_filename = filename;
+          ps_flags = flags;
+        } in
+      save_pers_struct penv crc ps pm
+    )
+    ~exceptionally:(fun () -> remove_file filename)
+
+let report_error ppf =
+  let open Format in
+  function
+  | Illegal_renaming(modname, ps_name, filename) -> fprintf ppf
+      "Wrong file naming: %a@ contains the compiled interface for@ \
+       %s when %s was expected"
+      Location.print_filename filename ps_name modname
+  | Inconsistent_import(name, source1, source2) -> fprintf ppf
+      "@[<hov>The files %a@ and %a@ \
+              make inconsistent assumptions@ over interface %s@]"
+      Location.print_filename source1 Location.print_filename source2 name
+  | Need_recursive_types(import) ->
+      fprintf ppf
+        "@[<hov>Invalid import of %s, which uses recursive types.@ %s@]"
+        import "The compilation flag -rectypes is required"
+  | Depend_on_unsafe_string_unit(import) ->
+      fprintf ppf
+        "@[<hov>Invalid import of %s, compiled with -unsafe-string.@ %s@]"
+        import "This compiler has been configured in strict \
+                                  safe-string mode (-force-safe-string)"
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err ->
+          Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )
diff --git a/upstream/ocaml_411/typing/persistent_env.mli b/upstream/ocaml_411/typing/persistent_env.mli
new file mode 100644
index 0000000..ac3109c
--- /dev/null
+++ b/upstream/ocaml_411/typing/persistent_env.mli
@@ -0,0 +1,105 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Xavier Leroy, projet Gallium, INRIA Rocquencourt                     *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*                                                                        *)
+(*   Copyright 2019 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Misc
+
+module Consistbl : module type of struct
+  include Consistbl.Make (Misc.Stdlib.String)
+end
+
+type error =
+  | Illegal_renaming of modname * modname * filepath
+  | Inconsistent_import of modname * filepath * filepath
+  | Need_recursive_types of modname
+  | Depend_on_unsafe_string_unit of modname
+
+exception Error of error
+
+val report_error: Format.formatter -> error -> unit
+
+module Persistent_signature : sig
+  type t =
+    { filename : string; (** Name of the file containing the signature. *)
+      cmi : Cmi_format.cmi_infos }
+
+  (** Function used to load a persistent signature. The default is to look for
+      the .cmi file in the load path. This function can be overridden to load
+      it from memory, for instance to build a self-contained toplevel. *)
+  val load : (unit_name:string -> t option) ref
+end
+
+type can_load_cmis =
+  | Can_load_cmis
+  | Cannot_load_cmis of Misc.EnvLazy.log
+
+type 'a t
+
+val empty : unit -> 'a t
+
+val clear : 'a t -> unit
+val clear_missing : 'a t -> unit
+
+val fold : 'a t -> (modname -> 'a -> 'b -> 'b) -> 'b -> 'b
+
+val read : 'a t -> (Persistent_signature.t -> 'a)
+  -> modname -> filepath -> 'a
+val find : 'a t -> (Persistent_signature.t -> 'a)
+  -> modname -> 'a
+
+val find_in_cache : 'a t -> modname -> 'a option
+
+val check : 'a t -> (Persistent_signature.t -> 'a)
+  -> loc:Location.t -> modname -> unit
+
+(* [looked_up penv md] checks if one has already tried
+   to read the signature for [md] in the environment
+   [penv] (it may have failed) *)
+val looked_up : 'a t -> modname -> bool
+
+(* [is_imported penv md] checks if [md] has been successfully
+   imported in the environment [penv] *)
+val is_imported : 'a t -> modname -> bool
+
+(* [is_imported_opaque penv md] checks if [md] has been imported
+   in [penv] as an opaque module *)
+val is_imported_opaque : 'a t -> modname -> bool
+
+(* [register_import_as_opaque penv md] registers [md] in [penv] as an
+   opaque module *)
+val register_import_as_opaque : 'a t -> modname -> unit
+
+val make_cmi : 'a t -> modname -> Types.signature -> alerts
+  -> Cmi_format.cmi_infos
+
+val save_cmi : 'a t -> Persistent_signature.t -> 'a -> unit
+
+val can_load_cmis : 'a t -> can_load_cmis
+val set_can_load_cmis : 'a t -> can_load_cmis -> unit
+val without_cmis : 'a t -> ('b -> 'c) -> 'b -> 'c
+(* [without_cmis penv f arg] applies [f] to [arg], but does not
+    allow [penv] to openi cmis during its execution *)
+
+(* may raise Consistbl.Inconsistency *)
+val import_crcs : 'a t -> source:filepath -> crcs -> unit
+
+(* Return the set of compilation units imported, with their CRC *)
+val imports : 'a t -> crcs
+
+(* Return the CRC of the interface of the given compilation unit *)
+val crc_of_unit: 'a t -> (Persistent_signature.t -> 'a) -> modname -> Digest.t
+
+(* Forward declaration to break mutual recursion with Typecore. *)
+val add_delayed_check_forward: ((unit -> unit) -> unit) ref
diff --git a/upstream/ocaml_411/typing/predef.ml b/upstream/ocaml_411/typing/predef.ml
new file mode 100644
index 0000000..786d1dc
--- /dev/null
+++ b/upstream/ocaml_411/typing/predef.ml
@@ -0,0 +1,250 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Predefined type constructors (with special typing rules in typecore) *)
+
+open Path
+open Types
+open Btype
+
+let builtin_idents = ref []
+
+let wrap create s =
+  let id = create s in
+  builtin_idents := (s, id) :: !builtin_idents;
+  id
+
+let ident_create = wrap Ident.create_predef
+
+let ident_int = ident_create "int"
+and ident_char = ident_create "char"
+and ident_bytes = ident_create "bytes"
+and ident_float = ident_create "float"
+and ident_bool = ident_create "bool"
+and ident_unit = ident_create "unit"
+and ident_exn = ident_create "exn"
+and ident_array = ident_create "array"
+and ident_list = ident_create "list"
+and ident_option = ident_create "option"
+and ident_nativeint = ident_create "nativeint"
+and ident_int32 = ident_create "int32"
+and ident_int64 = ident_create "int64"
+and ident_lazy_t = ident_create "lazy_t"
+and ident_string = ident_create "string"
+and ident_extension_constructor = ident_create "extension_constructor"
+and ident_floatarray = ident_create "floatarray"
+
+let path_int = Pident ident_int
+and path_char = Pident ident_char
+and path_bytes = Pident ident_bytes
+and path_float = Pident ident_float
+and path_bool = Pident ident_bool
+and path_unit = Pident ident_unit
+and path_exn = Pident ident_exn
+and path_array = Pident ident_array
+and path_list = Pident ident_list
+and path_option = Pident ident_option
+and path_nativeint = Pident ident_nativeint
+and path_int32 = Pident ident_int32
+and path_int64 = Pident ident_int64
+and path_lazy_t = Pident ident_lazy_t
+and path_string = Pident ident_string
+and path_extension_constructor = Pident ident_extension_constructor
+and path_floatarray = Pident ident_floatarray
+
+let type_int = newgenty (Tconstr(path_int, [], ref Mnil))
+and type_char = newgenty (Tconstr(path_char, [], ref Mnil))
+and type_bytes = newgenty (Tconstr(path_bytes, [], ref Mnil))
+and type_float = newgenty (Tconstr(path_float, [], ref Mnil))
+and type_bool = newgenty (Tconstr(path_bool, [], ref Mnil))
+and type_unit = newgenty (Tconstr(path_unit, [], ref Mnil))
+and type_exn = newgenty (Tconstr(path_exn, [], ref Mnil))
+and type_array t = newgenty (Tconstr(path_array, [t], ref Mnil))
+and type_list t = newgenty (Tconstr(path_list, [t], ref Mnil))
+and type_option t = newgenty (Tconstr(path_option, [t], ref Mnil))
+and type_nativeint = newgenty (Tconstr(path_nativeint, [], ref Mnil))
+and type_int32 = newgenty (Tconstr(path_int32, [], ref Mnil))
+and type_int64 = newgenty (Tconstr(path_int64, [], ref Mnil))
+and type_lazy_t t = newgenty (Tconstr(path_lazy_t, [t], ref Mnil))
+and type_string = newgenty (Tconstr(path_string, [], ref Mnil))
+and type_extension_constructor =
+      newgenty (Tconstr(path_extension_constructor, [], ref Mnil))
+and type_floatarray = newgenty (Tconstr(path_floatarray, [], ref Mnil))
+
+let ident_match_failure = ident_create "Match_failure"
+and ident_out_of_memory = ident_create "Out_of_memory"
+and ident_invalid_argument = ident_create "Invalid_argument"
+and ident_failure = ident_create "Failure"
+and ident_not_found = ident_create "Not_found"
+and ident_sys_error = ident_create "Sys_error"
+and ident_end_of_file = ident_create "End_of_file"
+and ident_division_by_zero = ident_create "Division_by_zero"
+and ident_stack_overflow = ident_create "Stack_overflow"
+and ident_sys_blocked_io = ident_create "Sys_blocked_io"
+and ident_assert_failure = ident_create "Assert_failure"
+and ident_undefined_recursive_module =
+        ident_create "Undefined_recursive_module"
+
+let all_predef_exns = [
+  ident_match_failure;
+  ident_out_of_memory;
+  ident_invalid_argument;
+  ident_failure;
+  ident_not_found;
+  ident_sys_error;
+  ident_end_of_file;
+  ident_division_by_zero;
+  ident_stack_overflow;
+  ident_sys_blocked_io;
+  ident_assert_failure;
+  ident_undefined_recursive_module;
+]
+
+let path_match_failure = Pident ident_match_failure
+and path_assert_failure = Pident ident_assert_failure
+and path_undefined_recursive_module = Pident ident_undefined_recursive_module
+
+let cstr id args =
+  {
+    cd_id = id;
+    cd_args = Cstr_tuple args;
+    cd_res = None;
+    cd_loc = Location.none;
+    cd_attributes = [];
+    cd_uid = Uid.of_predef_id id;
+  }
+
+let ident_false = ident_create "false"
+and ident_true = ident_create "true"
+and ident_void = ident_create "()"
+and ident_nil = ident_create "[]"
+and ident_cons = ident_create "::"
+and ident_none = ident_create "None"
+and ident_some = ident_create "Some"
+
+let mk_add_type add_type type_ident
+      ?manifest ?(immediate=Type_immediacy.Unknown) ?(kind=Type_abstract) env =
+  let decl =
+    {type_params = [];
+     type_arity = 0;
+     type_kind = kind;
+     type_loc = Location.none;
+     type_private = Asttypes.Public;
+     type_manifest = manifest;
+     type_variance = [];
+     type_separability = [];
+     type_is_newtype = false;
+     type_expansion_scope = lowest_level;
+     type_attributes = [];
+     type_immediate = immediate;
+     type_unboxed = unboxed_false_default_false;
+     type_uid = Uid.of_predef_id type_ident;
+    }
+  in
+  add_type type_ident decl env
+
+let common_initial_env add_type add_extension empty_env =
+  let add_type = mk_add_type add_type
+  and add_type1 type_ident
+      ~variance ~separability ?(kind=fun _ -> Type_abstract) env =
+    let param = newgenvar () in
+    let decl =
+      {type_params = [param];
+       type_arity = 1;
+       type_kind = kind param;
+       type_loc = Location.none;
+       type_private = Asttypes.Public;
+       type_manifest = None;
+       type_variance = [variance];
+       type_separability = [separability];
+       type_is_newtype = false;
+       type_expansion_scope = lowest_level;
+       type_attributes = [];
+       type_immediate = Unknown;
+       type_unboxed = unboxed_false_default_false;
+       type_uid = Uid.of_predef_id type_ident;
+      }
+    in
+    add_type type_ident decl env
+  in
+  let add_extension id l =
+    add_extension id
+      { ext_type_path = path_exn;
+        ext_type_params = [];
+        ext_args = Cstr_tuple l;
+        ext_ret_type = None;
+        ext_private = Asttypes.Public;
+        ext_loc = Location.none;
+        ext_attributes = [Ast_helper.Attr.mk
+                            (Location.mknoloc "ocaml.warn_on_literal_pattern")
+                            (Parsetree.PStr [])];
+        ext_uid = Uid.of_predef_id id;
+      }
+  in
+  add_extension ident_match_failure
+                         [newgenty (Ttuple[type_string; type_int; type_int])] (
+  add_extension ident_out_of_memory [] (
+  add_extension ident_stack_overflow [] (
+  add_extension ident_invalid_argument [type_string] (
+  add_extension ident_failure [type_string] (
+  add_extension ident_not_found [] (
+  add_extension ident_sys_blocked_io [] (
+  add_extension ident_sys_error [type_string] (
+  add_extension ident_end_of_file [] (
+  add_extension ident_division_by_zero [] (
+  add_extension ident_assert_failure
+                         [newgenty (Ttuple[type_string; type_int; type_int])] (
+  add_extension ident_undefined_recursive_module
+                         [newgenty (Ttuple[type_string; type_int; type_int])] (
+  add_type ident_int64 (
+  add_type ident_int32 (
+  add_type ident_nativeint (
+  add_type1 ident_lazy_t ~variance:Variance.covariant
+    ~separability:Separability.Ind (
+  add_type1 ident_option ~variance:Variance.covariant
+    ~separability:Separability.Ind
+    ~kind:(fun tvar ->
+      Type_variant([cstr ident_none []; cstr ident_some [tvar]])
+    ) (
+  add_type1 ident_list ~variance:Variance.covariant
+    ~separability:Separability.Ind
+    ~kind:(fun tvar ->
+      Type_variant([cstr ident_nil []; cstr ident_cons [tvar; type_list tvar]])
+    ) (
+  add_type1 ident_array ~variance:Variance.full ~separability:Separability.Ind (
+  add_type ident_exn ~kind:Type_open (
+  add_type ident_unit ~immediate:Always
+    ~kind:(Type_variant([cstr ident_void []])) (
+  add_type ident_bool ~immediate:Always
+    ~kind:(Type_variant([cstr ident_false []; cstr ident_true []])) (
+  add_type ident_float (
+  add_type ident_string (
+  add_type ident_char ~immediate:Always (
+  add_type ident_int ~immediate:Always (
+  add_type ident_extension_constructor (
+  add_type ident_floatarray (
+    empty_env))))))))))))))))))))))))))))
+
+let build_initial_env add_type add_exception empty_env =
+  let common = common_initial_env add_type add_exception empty_env in
+  let add_type = mk_add_type add_type in
+  let safe_string = add_type ident_bytes common in
+  let unsafe_string = add_type ident_bytes ~manifest:type_string common in
+  (safe_string, unsafe_string)
+
+let builtin_values =
+  List.map (fun id -> (Ident.name id, id)) all_predef_exns
+
+let builtin_idents = List.rev !builtin_idents
diff --git a/upstream/ocaml_411/typing/predef.mli b/upstream/ocaml_411/typing/predef.mli
new file mode 100644
index 0000000..962a276
--- /dev/null
+++ b/upstream/ocaml_411/typing/predef.mli
@@ -0,0 +1,87 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Predefined type constructors (with special typing rules in typecore) *)
+
+open Types
+
+val type_int: type_expr
+val type_char: type_expr
+val type_string: type_expr
+val type_bytes: type_expr
+val type_float: type_expr
+val type_bool: type_expr
+val type_unit: type_expr
+val type_exn: type_expr
+val type_array: type_expr -> type_expr
+val type_list: type_expr -> type_expr
+val type_option: type_expr -> type_expr
+val type_nativeint: type_expr
+val type_int32: type_expr
+val type_int64: type_expr
+val type_lazy_t: type_expr -> type_expr
+val type_extension_constructor:type_expr
+val type_floatarray:type_expr
+
+val path_int: Path.t
+val path_char: Path.t
+val path_string: Path.t
+val path_bytes: Path.t
+val path_float: Path.t
+val path_bool: Path.t
+val path_unit: Path.t
+val path_exn: Path.t
+val path_array: Path.t
+val path_list: Path.t
+val path_option: Path.t
+val path_nativeint: Path.t
+val path_int32: Path.t
+val path_int64: Path.t
+val path_lazy_t: Path.t
+val path_extension_constructor: Path.t
+val path_floatarray: Path.t
+
+val path_match_failure: Path.t
+val path_assert_failure : Path.t
+val path_undefined_recursive_module : Path.t
+
+val ident_false : Ident.t
+val ident_true : Ident.t
+val ident_void : Ident.t
+val ident_nil : Ident.t
+val ident_cons : Ident.t
+val ident_none : Ident.t
+val ident_some : Ident.t
+
+(* To build the initial environment. Since there is a nasty mutual
+   recursion between predef and env, we break it by parameterizing
+   over Env.t, Env.add_type and Env.add_extension. *)
+
+val build_initial_env:
+  (Ident.t -> type_declaration -> 'a -> 'a) ->
+  (Ident.t -> extension_constructor -> 'a -> 'a) ->
+  'a -> 'a * 'a
+
+(* To initialize linker tables *)
+
+val builtin_values: (string * Ident.t) list
+val builtin_idents: (string * Ident.t) list
+
+(** All predefined exceptions, exposed as [Ident.t] for flambda (for
+    building value approximations).
+    The [Ident.t] for division by zero is also exported explicitly
+    so flambda can generate code to raise it. *)
+val ident_division_by_zero: Ident.t
+val all_predef_exns : Ident.t list
diff --git a/upstream/ocaml_411/typing/primitive.ml b/upstream/ocaml_411/typing/primitive.ml
new file mode 100644
index 0000000..0c3372b
--- /dev/null
+++ b/upstream/ocaml_411/typing/primitive.ml
@@ -0,0 +1,227 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Description of primitive functions *)
+
+open Misc
+open Parsetree
+
+type boxed_integer = Pnativeint | Pint32 | Pint64
+
+type native_repr =
+  | Same_as_ocaml_repr
+  | Unboxed_float
+  | Unboxed_integer of boxed_integer
+  | Untagged_int
+
+type description =
+  { prim_name: string;         (* Name of primitive  or C function *)
+    prim_arity: int;           (* Number of arguments *)
+    prim_alloc: bool;          (* Does it allocates or raise? *)
+    prim_native_name: string;  (* Name of C function for the nat. code gen. *)
+    prim_native_repr_args: native_repr list;
+    prim_native_repr_res: native_repr }
+
+type error =
+  | Old_style_float_with_native_repr_attribute
+  | Old_style_noalloc_with_noalloc_attribute
+  | No_native_primitive_with_repr_attribute
+
+exception Error of Location.t * error
+
+let is_ocaml_repr = function
+  | Same_as_ocaml_repr -> true
+  | Unboxed_float
+  | Unboxed_integer _
+  | Untagged_int -> false
+
+let is_unboxed = function
+  | Same_as_ocaml_repr
+  | Untagged_int -> false
+  | Unboxed_float
+  | Unboxed_integer _ -> true
+
+let is_untagged = function
+  | Untagged_int -> true
+  | Same_as_ocaml_repr
+  | Unboxed_float
+  | Unboxed_integer _ -> false
+
+let rec make_native_repr_args arity x =
+  if arity = 0 then
+    []
+  else
+    x :: make_native_repr_args (arity - 1) x
+
+let simple ~name ~arity ~alloc =
+  {prim_name = name;
+   prim_arity = arity;
+   prim_alloc = alloc;
+   prim_native_name = "";
+   prim_native_repr_args = make_native_repr_args arity Same_as_ocaml_repr;
+   prim_native_repr_res = Same_as_ocaml_repr}
+
+let make ~name ~alloc ~native_name ~native_repr_args ~native_repr_res =
+  {prim_name = name;
+   prim_arity = List.length native_repr_args;
+   prim_alloc = alloc;
+   prim_native_name = native_name;
+   prim_native_repr_args = native_repr_args;
+   prim_native_repr_res = native_repr_res}
+
+let parse_declaration valdecl ~native_repr_args ~native_repr_res =
+  let arity = List.length native_repr_args in
+  let name, native_name, old_style_noalloc, old_style_float =
+    match valdecl.pval_prim with
+    | name :: "noalloc" :: name2 :: "float" :: _ -> (name, name2, true, true)
+    | name :: "noalloc" :: name2 :: _ -> (name, name2, true, false)
+    | name :: name2 :: "float" :: _ -> (name, name2, false, true)
+    | name :: "noalloc" :: _ -> (name, "", true, false)
+    | name :: name2 :: _ -> (name, name2, false, false)
+    | name :: _ -> (name, "", false, false)
+    | [] ->
+        fatal_error "Primitive.parse_declaration"
+  in
+  let noalloc_attribute =
+    Attr_helper.has_no_payload_attribute ["noalloc"; "ocaml.noalloc"]
+      valdecl.pval_attributes
+  in
+  if old_style_float &&
+     not (List.for_all is_ocaml_repr native_repr_args &&
+          is_ocaml_repr native_repr_res) then
+    raise (Error (valdecl.pval_loc,
+                  Old_style_float_with_native_repr_attribute));
+  if old_style_noalloc && noalloc_attribute then
+    raise (Error (valdecl.pval_loc,
+                  Old_style_noalloc_with_noalloc_attribute));
+  (* The compiler used to assume "noalloc" with "float", we just make this
+     explicit now (GPR#167): *)
+  let old_style_noalloc = old_style_noalloc || old_style_float in
+  if old_style_float then
+    Location.deprecated valdecl.pval_loc
+      "[@@unboxed] + [@@noalloc] should be used\n\
+       instead of \"float\""
+  else if old_style_noalloc then
+    Location.deprecated valdecl.pval_loc
+      "[@@noalloc] should be used instead of \"noalloc\"";
+  if native_name = "" &&
+     not (List.for_all is_ocaml_repr native_repr_args &&
+          is_ocaml_repr native_repr_res) then
+    raise (Error (valdecl.pval_loc,
+                  No_native_primitive_with_repr_attribute));
+  let noalloc = old_style_noalloc || noalloc_attribute in
+  let native_repr_args, native_repr_res =
+    if old_style_float then
+      (make_native_repr_args arity Unboxed_float, Unboxed_float)
+    else
+      (native_repr_args, native_repr_res)
+  in
+  {prim_name = name;
+   prim_arity = arity;
+   prim_alloc = not noalloc;
+   prim_native_name = native_name;
+   prim_native_repr_args = native_repr_args;
+   prim_native_repr_res = native_repr_res}
+
+open Outcometree
+
+let rec add_native_repr_attributes ty attrs =
+  match ty, attrs with
+  | Otyp_arrow (label, a, b), attr_opt :: rest ->
+    let b = add_native_repr_attributes b rest in
+    let a =
+      match attr_opt with
+      | None -> a
+      | Some attr -> Otyp_attribute (a, attr)
+    in
+    Otyp_arrow (label, a, b)
+  | _, [Some attr] -> Otyp_attribute (ty, attr)
+  | _ ->
+    assert (List.for_all (fun x -> x = None) attrs);
+    ty
+
+let oattr_unboxed = { oattr_name = "unboxed" }
+let oattr_untagged = { oattr_name = "untagged" }
+let oattr_noalloc = { oattr_name = "noalloc" }
+
+let print p osig_val_decl =
+  let prims =
+    if p.prim_native_name <> "" then
+      [p.prim_name; p.prim_native_name]
+    else
+      [p.prim_name]
+  in
+  let for_all f =
+    List.for_all f p.prim_native_repr_args && f p.prim_native_repr_res
+  in
+  let all_unboxed = for_all is_unboxed in
+  let all_untagged = for_all is_untagged in
+  let attrs = if p.prim_alloc then [] else [oattr_noalloc] in
+  let attrs =
+    if all_unboxed then
+      oattr_unboxed :: attrs
+    else if all_untagged then
+      oattr_untagged :: attrs
+    else
+      attrs
+  in
+  let attr_of_native_repr = function
+    | Same_as_ocaml_repr -> None
+    | Unboxed_float
+    | Unboxed_integer _ -> if all_unboxed then None else Some oattr_unboxed
+    | Untagged_int -> if all_untagged then None else Some oattr_untagged
+  in
+  let type_attrs =
+    List.map attr_of_native_repr p.prim_native_repr_args @
+    [attr_of_native_repr p.prim_native_repr_res]
+  in
+  { osig_val_decl with
+    oval_prims = prims;
+    oval_type = add_native_repr_attributes osig_val_decl.oval_type type_attrs;
+    oval_attributes = attrs }
+
+let native_name p =
+  if p.prim_native_name <> ""
+  then p.prim_native_name
+  else p.prim_name
+
+let byte_name p =
+  p.prim_name
+
+let native_name_is_external p =
+  let nat_name = native_name p in
+  nat_name <> "" && nat_name.[0] <> '%'
+
+let report_error ppf err =
+  match err with
+  | Old_style_float_with_native_repr_attribute ->
+    Format.fprintf ppf "Cannot use \"float\" in conjunction with \
+                        [%@unboxed]/[%@untagged]."
+  | Old_style_noalloc_with_noalloc_attribute ->
+    Format.fprintf ppf "Cannot use \"noalloc\" in conjunction with \
+                        [%@%@noalloc]."
+  | No_native_primitive_with_repr_attribute ->
+    Format.fprintf ppf
+      "[@The native code version of the primitive is mandatory@ \
+       when attributes [%@untagged] or [%@unboxed] are present.@]"
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, err) ->
+        Some (Location.error_of_printer ~loc report_error err)
+      | _ ->
+        None
+    )
diff --git a/upstream/ocaml_411/typing/primitive.mli b/upstream/ocaml_411/typing/primitive.mli
new file mode 100644
index 0000000..ddd3977
--- /dev/null
+++ b/upstream/ocaml_411/typing/primitive.mli
@@ -0,0 +1,76 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Description of primitive functions *)
+
+type boxed_integer = Pnativeint | Pint32 | Pint64
+
+(* Representation of arguments/result for the native code version
+   of a primitive *)
+type native_repr =
+  | Same_as_ocaml_repr
+  | Unboxed_float
+  | Unboxed_integer of boxed_integer
+  | Untagged_int
+
+type description = private
+  { prim_name: string;         (* Name of primitive  or C function *)
+    prim_arity: int;           (* Number of arguments *)
+    prim_alloc: bool;          (* Does it allocates or raise? *)
+    prim_native_name: string;  (* Name of C function for the nat. code gen. *)
+    prim_native_repr_args: native_repr list;
+    prim_native_repr_res: native_repr }
+
+(* Invariant [List.length d.prim_native_repr_args = d.prim_arity] *)
+
+val simple
+  :  name:string
+  -> arity:int
+  -> alloc:bool
+  -> description
+
+val make
+  :  name:string
+  -> alloc:bool
+  -> native_name:string
+  -> native_repr_args: native_repr list
+  -> native_repr_res: native_repr
+  -> description
+
+val parse_declaration
+  :  Parsetree.value_description
+  -> native_repr_args:native_repr list
+  -> native_repr_res:native_repr
+  -> description
+
+val print
+  :  description
+  -> Outcometree.out_val_decl
+  -> Outcometree.out_val_decl
+
+val native_name: description -> string
+val byte_name: description -> string
+
+(** [native_name_is_externa] returns [true] iff the [native_name] for the
+    given primitive identifies that the primitive is not implemented in the
+    compiler itself. *)
+val native_name_is_external : description -> bool
+
+type error =
+  | Old_style_float_with_native_repr_attribute
+  | Old_style_noalloc_with_noalloc_attribute
+  | No_native_primitive_with_repr_attribute
+
+exception Error of Location.t * error
diff --git a/upstream/ocaml_411/typing/printpat.ml b/upstream/ocaml_411/typing/printpat.ml
new file mode 100644
index 0000000..43a1864
--- /dev/null
+++ b/upstream/ocaml_411/typing/printpat.ml
@@ -0,0 +1,163 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Values as patterns pretty printer *)
+
+open Asttypes
+open Typedtree
+open Types
+open Format
+
+let is_cons = function
+| {cstr_name = "::"} -> true
+| _ -> false
+
+let pretty_const c = match c with
+| Const_int i -> Printf.sprintf "%d" i
+| Const_char c -> Printf.sprintf "%C" c
+| Const_string (s, _, _) -> Printf.sprintf "%S" s
+| Const_float f -> Printf.sprintf "%s" f
+| Const_int32 i -> Printf.sprintf "%ldl" i
+| Const_int64 i -> Printf.sprintf "%LdL" i
+| Const_nativeint i -> Printf.sprintf "%ndn" i
+
+let pretty_extra ppf (cstr, _loc, _attrs) pretty_rest rest =
+  match cstr with
+  | Tpat_unpack ->
+     fprintf ppf "@[(module %a)@]" pretty_rest rest
+  | Tpat_constraint _ ->
+     fprintf ppf "@[(%a : _)@]" pretty_rest rest
+  | Tpat_type _ ->
+     fprintf ppf "@[(# %a)@]" pretty_rest rest
+  | Tpat_open _ ->
+     fprintf ppf "@[(# %a)@]" pretty_rest rest
+
+let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v ->
+  match v.pat_extra with
+    | extra :: rem ->
+       pretty_extra ppf extra
+         pretty_val { v with pat_extra = rem }
+    | [] ->
+  match v.pat_desc with
+  | Tpat_any -> fprintf ppf "_"
+  | Tpat_var (x,_) -> fprintf ppf "%s" (Ident.name x)
+  | Tpat_constant c -> fprintf ppf "%s" (pretty_const c)
+  | Tpat_tuple vs ->
+      fprintf ppf "@[(%a)@]" (pretty_vals ",") vs
+  | Tpat_construct (_, cstr, []) ->
+      fprintf ppf "%s" cstr.cstr_name
+  | Tpat_construct (_, cstr, [w]) ->
+      fprintf ppf "@[<2>%s@ %a@]" cstr.cstr_name pretty_arg w
+  | Tpat_construct (_, cstr, vs) ->
+      let name = cstr.cstr_name in
+      begin match (name, vs) with
+        ("::", [v1;v2]) ->
+          fprintf ppf "@[%a::@,%a@]" pretty_car v1 pretty_cdr v2
+      |  _ ->
+          fprintf ppf "@[<2>%s@ @[(%a)@]@]" name (pretty_vals ",") vs
+      end
+  | Tpat_variant (l, None, _) ->
+      fprintf ppf "`%s" l
+  | Tpat_variant (l, Some w, _) ->
+      fprintf ppf "@[<2>`%s@ %a@]" l pretty_arg w
+  | Tpat_record (lvs,_) ->
+      let filtered_lvs = List.filter
+          (function
+            | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
+            | _ -> true) lvs in
+      begin match filtered_lvs with
+      | [] -> fprintf ppf "_"
+      | (_, lbl, _) :: q ->
+          let elision_mark ppf =
+            (* we assume that there is no label repetitions here *)
+             if Array.length lbl.lbl_all > 1 + List.length q then
+               fprintf ppf ";@ _@ "
+             else () in
+          fprintf ppf "@[{%a%t}@]"
+            pretty_lvals filtered_lvs elision_mark
+      end
+  | Tpat_array vs ->
+      fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
+  | Tpat_lazy v ->
+      fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v
+  | Tpat_alias (v, x,_) ->
+      fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x
+  | Tpat_value v ->
+      fprintf ppf "%a" pretty_val (v :> pattern)
+  | Tpat_exception v ->
+      fprintf ppf "@[<2>exception@ %a@]" pretty_arg v
+  | Tpat_or _ ->
+      fprintf ppf "@[(%a)@]" pretty_or v
+
+and pretty_car ppf v = match v.pat_desc with
+| Tpat_construct (_,cstr, [_ ; _])
+    when is_cons cstr ->
+      fprintf ppf "(%a)" pretty_val v
+| _ -> pretty_val ppf v
+
+and pretty_cdr ppf v = match v.pat_desc with
+| Tpat_construct (_,cstr, [v1 ; v2])
+    when is_cons cstr ->
+      fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2
+| _ -> pretty_val ppf v
+
+and pretty_arg ppf v = match v.pat_desc with
+| Tpat_construct (_,_,_::_)
+| Tpat_variant (_, Some _, _) -> fprintf ppf "(%a)" pretty_val v
+|  _ -> pretty_val ppf v
+
+and pretty_or : type k . _ -> k general_pattern -> _ = fun ppf v ->
+  match v.pat_desc with
+  | Tpat_or (v,w,_) ->
+      fprintf ppf "%a|@,%a" pretty_or v pretty_or w
+  | _ -> pretty_val ppf v
+
+and pretty_vals sep ppf = function
+  | [] -> ()
+  | [v] -> pretty_val ppf v
+  | v::vs ->
+      fprintf ppf "%a%s@ %a" pretty_val v sep (pretty_vals sep) vs
+
+and pretty_lvals ppf = function
+  | [] -> ()
+  | [_,lbl,v] ->
+      fprintf ppf "%s=%a" lbl.lbl_name pretty_val v
+  | (_, lbl,v)::rest ->
+      fprintf ppf "%s=%a;@ %a"
+        lbl.lbl_name pretty_val v pretty_lvals rest
+
+let top_pretty ppf v =
+  fprintf ppf "@[%a@]@?" pretty_val v
+
+let pretty_pat p =
+  top_pretty Format.str_formatter p ;
+  prerr_string (Format.flush_str_formatter ())
+
+type 'k matrix = 'k general_pattern list list
+
+let pretty_line fmt =
+  List.iter (fun p ->
+    Format.fprintf fmt " <";
+    top_pretty fmt p;
+    Format.fprintf fmt ">";
+  )
+
+let pretty_matrix fmt (pss : 'k matrix) =
+  Format.fprintf fmt "begin matrix\n" ;
+  List.iter (fun ps ->
+    pretty_line fmt ps ;
+    Format.fprintf fmt "\n"
+  ) pss;
+  Format.fprintf fmt "end matrix\n%!"
diff --git a/upstream/ocaml_411/typing/printpat.mli b/upstream/ocaml_411/typing/printpat.mli
new file mode 100644
index 0000000..1865a2a
--- /dev/null
+++ b/upstream/ocaml_411/typing/printpat.mli
@@ -0,0 +1,27 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+
+
+val pretty_const
+    : Asttypes.constant -> string
+val top_pretty
+    : Format.formatter -> 'k Typedtree.general_pattern -> unit
+val pretty_pat
+    : 'k Typedtree.general_pattern -> unit
+val pretty_line
+    : Format.formatter -> 'k Typedtree.general_pattern list -> unit
+val pretty_matrix
+    : Format.formatter -> 'k Typedtree.general_pattern list list -> unit
diff --git a/upstream/ocaml_411/typing/printtyp.ml b/upstream/ocaml_411/typing/printtyp.ml
new file mode 100644
index 0000000..5cdd914
--- /dev/null
+++ b/upstream/ocaml_411/typing/printtyp.ml
@@ -0,0 +1,2194 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Printing functions *)
+
+open Misc
+open Ctype
+open Format
+open Longident
+open Path
+open Asttypes
+open Types
+open Btype
+open Outcometree
+
+module String = Misc.Stdlib.String
+
+(* Print a long identifier *)
+
+let rec longident ppf = function
+  | Lident s -> pp_print_string ppf s
+  | Ldot(p, s) -> fprintf ppf "%a.%s" longident p s
+  | Lapply(p1, p2) -> fprintf ppf "%a(%a)" longident p1 longident p2
+
+let () = Env.print_longident := longident
+
+(* Print an identifier avoiding name collisions *)
+
+module Out_name = struct
+  let create x = { printed_name = x }
+  let print x = x.printed_name
+  let set out_name x = out_name.printed_name <- x
+end
+
+(* printing environment for path shortening and naming *)
+let printing_env = ref Env.empty
+
+(* When printing, it is important to only observe the
+   current printing environment, without reading any new
+   cmi present on the file system *)
+let in_printing_env f = Env.without_cmis f !printing_env
+
+let human_unique n id = Printf.sprintf "%s/%d" (Ident.name id) n
+
+type namespace =
+  | Type
+  | Module
+  | Module_type
+  | Class
+  | Class_type
+  | Other (** Other bypasses the unique name identifier mechanism *)
+
+module Namespace = struct
+
+  let id = function
+    | Type -> 0
+    | Module -> 1
+    | Module_type -> 2
+    | Class -> 3
+    | Class_type -> 4
+    | Other -> 5
+
+  let size = 1 + id Other
+
+  let show =
+    function
+    | Type -> "type"
+    | Module -> "module"
+    | Module_type -> "module type"
+    | Class -> "class"
+    | Class_type -> "class type"
+    | Other -> ""
+
+  let pp ppf x = Format.pp_print_string ppf (show x)
+
+  (** The two functions below should never access the filesystem,
+      and thus use {!in_printing_env} rather than directly
+      accessing the printing environment *)
+  let lookup =
+    let to_lookup f lid = fst @@ in_printing_env (f (Lident lid)) in
+    function
+    | Type -> to_lookup Env.find_type_by_name
+    | Module -> to_lookup Env.find_module_by_name
+    | Module_type -> to_lookup Env.find_modtype_by_name
+    | Class -> to_lookup Env.find_class_by_name
+    | Class_type -> to_lookup Env.find_cltype_by_name
+    | Other -> fun _ -> raise Not_found
+
+  let location namespace id =
+    let path = Path.Pident id in
+    try Some (
+        match namespace with
+        | Type -> (in_printing_env @@ Env.find_type path).type_loc
+        | Module -> (in_printing_env @@ Env.find_module path).md_loc
+        | Module_type -> (in_printing_env @@ Env.find_modtype path).mtd_loc
+        | Class -> (in_printing_env @@ Env.find_class path).cty_loc
+        | Class_type -> (in_printing_env @@ Env.find_cltype path).clty_loc
+        | Other -> Location.none
+      ) with Not_found -> None
+
+  let best_class_namespace = function
+    | Papply _ | Pdot _ -> Module
+    | Pident c ->
+        match location Class c with
+        | Some _ -> Class
+        | None -> Class_type
+
+end
+
+(** {2 Conflicts printing}
+    Conflicts arise when multiple items are attributed the same name,
+    the following module stores the global conflict references and
+    provides the printing functions for explaining the source of
+    the conflicts.
+*)
+module Conflicts = struct
+  module M = String.Map
+  type explanation =
+    { kind: namespace; name:string; root_name:string; location:Location.t}
+  let explanations = ref M.empty
+  let collect_explanation namespace n id =
+    let name = human_unique n id in
+    let root_name = Ident.name id in
+    if not (M.mem name !explanations) then
+      match Namespace.location namespace id with
+      | None -> ()
+      | Some location ->
+          let explanation = { kind = namespace; location; name; root_name } in
+          explanations := M.add name explanation !explanations
+
+  let pp_explanation ppf r=
+    Format.fprintf ppf "@[<v 2>%a:@,Definition of %s %s@]"
+      Location.print_loc r.location (Namespace.show r.kind) r.name
+
+  let print_located_explanations ppf l =
+    Format.fprintf ppf "@[<v>%a@]" (Format.pp_print_list pp_explanation) l
+
+  let reset () = explanations := M.empty
+  let list_explanations () =
+    let c = !explanations in
+    reset ();
+    c |> M.bindings |> List.map snd |> List.sort Stdlib.compare
+
+
+  let print_toplevel_hint ppf l =
+    let conj ppf () = Format.fprintf ppf " and@ " in
+    let pp_namespace_plural ppf n = Format.fprintf ppf "%as" Namespace.pp n in
+    let root_names = List.map (fun r -> r.kind, r.root_name) l in
+    let unique_root_names = List.sort_uniq Stdlib.compare root_names in
+    let submsgs = Array.make Namespace.size [] in
+    let () = List.iter (fun (n,_ as x) ->
+        submsgs.(Namespace.id n) <- x :: submsgs.(Namespace.id n)
+      )  unique_root_names in
+    let pp_submsg ppf names =
+      match names with
+      | [] -> ()
+      | [namespace, a] ->
+          Format.fprintf ppf
+        "@ \
+         @[<2>Hint: The %a %s has been defined multiple times@ \
+         in@ this@ toplevel@ session.@ \
+         Some toplevel values still refer to@ old@ versions@ of@ this@ %a.\
+         @ Did you try to redefine them?@]"
+        Namespace.pp namespace a Namespace.pp namespace
+      | (namespace, _) :: _ :: _ ->
+      Format.fprintf ppf
+        "@ \
+         @[<2>Hint: The %a %a have been defined multiple times@ \
+         in@ this@ toplevel@ session.@ \
+         Some toplevel values still refer to@ old@ versions@ of@ those@ %a.\
+         @ Did you try to redefine them?@]"
+        pp_namespace_plural namespace
+        Format.(pp_print_list ~pp_sep:conj pp_print_string) (List.map snd names)
+        pp_namespace_plural namespace in
+    Array.iter (pp_submsg ppf) submsgs
+
+  let print_explanations ppf =
+    let ltop, l =
+      (* isolate toplevel locations, since they are too imprecise *)
+      let from_toplevel a =
+        a.location.Location.loc_start.Lexing.pos_fname = "//toplevel//" in
+      List.partition from_toplevel (list_explanations ())
+    in
+    begin match l with
+    | [] -> ()
+    | l -> Format.fprintf ppf "@ %a" print_located_explanations l
+    end;
+    (* if there are name collisions in a toplevel session,
+       display at least one generic hint by namespace *)
+    print_toplevel_hint ppf ltop
+
+  let exists () = M.cardinal !explanations >0
+end
+
+
+module Naming_context = struct
+
+module M = String.Map
+module S = String.Set
+
+let enabled = ref true
+let enable b = enabled := b
+
+(** Name mapping *)
+type mapping =
+  | Need_unique_name of int Ident.Map.t
+  (** The same name has already been attributed to multiple types.
+      The [map] argument contains the specific binding time attributed to each
+      types.
+  *)
+  | Uniquely_associated_to of Ident.t * out_name
+    (** For now, the name [Ident.name id] has been attributed to [id],
+        [out_name] is used to expand this name if a conflict arises
+        at a later point
+    *)
+  | Associated_to_pervasives of out_name
+  (** [Associated_to_pervasives out_name] is used when the item
+      [Stdlib.$name] has been associated to the name [$name].
+      Upon a conflict, this name will be expanded to ["Stdlib." ^ name ] *)
+
+let hid_start = 0
+
+let add_hid_id id map =
+  let new_id = 1 + Ident.Map.fold (fun _ -> max) map hid_start in
+  new_id, Ident.Map.add id new_id  map
+
+let find_hid id map =
+  try Ident.Map.find id map, map with
+  Not_found -> add_hid_id id map
+
+let pervasives name = "Stdlib." ^ name
+
+let map = Array.make Namespace.size M.empty
+let get namespace = map.(Namespace.id namespace)
+let set namespace x = map.(Namespace.id namespace) <- x
+
+(* Names used in recursive definitions are not considered when determining
+   if a name is already attributed in the current environment.
+   This is a weaker version of hidden_rec_items used by short-path. *)
+let protected = ref S.empty
+let add_protected id = protected := S.add (Ident.name id) !protected
+let reset_protected () = protected := S.empty
+let with_hidden id f =
+  protect_refs [ R(protected,S.add (Ident.name id) !protected)] f
+
+let pervasives_name namespace name =
+  if not !enabled then Out_name.create name else
+  match M.find name (get namespace) with
+  | Associated_to_pervasives r -> r
+  | Need_unique_name _ -> Out_name.create (pervasives name)
+  | Uniquely_associated_to (id',r) ->
+      let hid, map = add_hid_id id' Ident.Map.empty in
+      Out_name.set r (human_unique hid id');
+      Conflicts.collect_explanation namespace hid id';
+      set namespace @@ M.add name (Need_unique_name map) (get namespace);
+      Out_name.create (pervasives name)
+  | exception Not_found ->
+      let r = Out_name.create name in
+      set namespace @@ M.add name (Associated_to_pervasives r) (get namespace);
+      r
+
+(** Lookup for preexisting named item within the current {!printing_env} *)
+let env_ident namespace name =
+  if S.mem name !protected then None else
+  match Namespace.lookup namespace name with
+  | Pident id -> Some id
+  | _ -> None
+  | exception Not_found -> None
+
+(** Associate a name to the identifier [id] within [namespace] *)
+let ident_name_simple namespace id =
+  if not !enabled then Out_name.create (Ident.name id) else
+  let name = Ident.name id in
+  match M.find name (get namespace) with
+  | Uniquely_associated_to (id',r) when Ident.same id id' ->
+      r
+  | Need_unique_name map ->
+      let hid, m = find_hid id map in
+      Conflicts.collect_explanation namespace hid id;
+      set namespace @@ M.add name (Need_unique_name m) (get namespace);
+      Out_name.create (human_unique hid id)
+  | Uniquely_associated_to (id',r) ->
+      let hid', m = find_hid id' Ident.Map.empty in
+      let hid, m = find_hid id m in
+      Out_name.set r (human_unique hid' id');
+      List.iter (fun (id,hid) -> Conflicts.collect_explanation namespace hid id)
+        [id, hid; id', hid' ];
+      set namespace @@ M.add name (Need_unique_name m) (get namespace);
+      Out_name.create (human_unique hid id)
+  | Associated_to_pervasives r ->
+      Out_name.set r ("Stdlib." ^ Out_name.print r);
+      let hid, m = find_hid id Ident.Map.empty in
+      set namespace @@ M.add name (Need_unique_name m) (get namespace);
+      Out_name.create (human_unique hid id)
+  | exception Not_found ->
+      let r = Out_name.create name in
+      set namespace
+      @@ M.add name (Uniquely_associated_to (id,r) ) (get namespace);
+      r
+
+(** Same as {!ident_name_simple} but lookup to existing named identifiers
+    in the current {!printing_env} *)
+let ident_name namespace id =
+  begin match env_ident namespace (Ident.name id) with
+  | Some id' -> ignore (ident_name_simple namespace id')
+  | None -> ()
+  end;
+  ident_name_simple namespace id
+
+let reset () =
+  Array.iteri ( fun i _ -> map.(i) <- M.empty ) map
+
+end
+let ident_name = Naming_context.ident_name
+let reset_naming_context = Naming_context.reset
+
+let ident ppf id = pp_print_string ppf
+    (Out_name.print (Naming_context.ident_name_simple Other id))
+
+(* Print a path *)
+
+let ident_stdlib = Ident.create_persistent "Stdlib"
+
+let non_shadowed_pervasive = function
+  | Pdot(Pident id, s) as path ->
+      Ident.same id ident_stdlib &&
+      (match in_printing_env (Env.find_type_by_name (Lident s)) with
+       | (path', _) -> Path.same path path'
+       | exception Not_found -> true)
+  | _ -> false
+
+let find_double_underscore s =
+  let len = String.length s in
+  let rec loop i =
+    if i + 1 >= len then
+      None
+    else if s.[i] = '_' && s.[i + 1] = '_' then
+      Some i
+    else
+      loop (i + 1)
+  in
+  loop 0
+
+let rec module_path_is_an_alias_of env path ~alias_of =
+  match Env.find_module path env with
+  | { md_type = Mty_alias path'; _ } ->
+    Path.same path' alias_of ||
+    module_path_is_an_alias_of env path' ~alias_of
+  | _ -> false
+  | exception Not_found -> false
+
+(* Simple heuristic to print Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias
+   for Foo__bar. This pattern is used by the stdlib. *)
+let rec rewrite_double_underscore_paths env p =
+  match p with
+  | Pdot (p, s) ->
+    Pdot (rewrite_double_underscore_paths env p, s)
+  | Papply (a, b) ->
+    Papply (rewrite_double_underscore_paths env a,
+            rewrite_double_underscore_paths env b)
+  | Pident id ->
+    let name = Ident.name id in
+    match find_double_underscore name with
+    | None -> p
+    | Some i ->
+      let better_lid =
+        Ldot
+          (Lident (String.sub name 0 i),
+           String.capitalize_ascii
+             (String.sub name (i + 2) (String.length name - i - 2)))
+      in
+      match Env.find_module_by_name better_lid env with
+      | exception Not_found -> p
+      | p', _ ->
+          if module_path_is_an_alias_of env p' ~alias_of:p then
+            p'
+          else
+          p
+
+let rewrite_double_underscore_paths env p =
+  if env == Env.empty then
+    p
+  else
+    rewrite_double_underscore_paths env p
+
+let rec tree_of_path namespace = function
+  | Pident id ->
+      Oide_ident (ident_name namespace id)
+  | Pdot(_, s) as path when non_shadowed_pervasive path ->
+      Oide_ident (Naming_context.pervasives_name namespace s)
+  | Pdot(Pident t, s)
+    when namespace=Type && not (Path.is_uident (Ident.name t)) ->
+      (* [t.A]: inline record of the constructor [A] from type [t] *)
+      Oide_dot (Oide_ident (ident_name Type t), s)
+  | Pdot(p, s) ->
+      Oide_dot (tree_of_path Module p, s)
+  | Papply(p1, p2) ->
+      Oide_apply (tree_of_path Module p1, tree_of_path Module p2)
+
+let tree_of_path namespace p =
+  tree_of_path namespace (rewrite_double_underscore_paths !printing_env p)
+
+let path ppf p =
+  !Oprint.out_ident ppf (tree_of_path Other p)
+
+let string_of_path p =
+  Format.asprintf "%a" path p
+
+let strings_of_paths namespace p =
+  reset_naming_context ();
+  let trees = List.map (tree_of_path namespace) p in
+  List.map (Format.asprintf "%a" !Oprint.out_ident) trees
+
+let () = Env.print_path := path
+
+(* Print a recursive annotation *)
+
+let tree_of_rec = function
+  | Trec_not -> Orec_not
+  | Trec_first -> Orec_first
+  | Trec_next -> Orec_next
+
+(* Print a raw type expression, with sharing *)
+
+let raw_list pr ppf = function
+    [] -> fprintf ppf "[]"
+  | a :: l ->
+      fprintf ppf "@[<1>[%a%t]@]" pr a
+        (fun ppf -> List.iter (fun x -> fprintf ppf ";@,%a" pr x) l)
+
+let kind_vars = ref []
+let kind_count = ref 0
+
+let rec safe_kind_repr v = function
+    Fvar {contents=Some k}  ->
+      if List.memq k v then "Fvar loop" else
+      safe_kind_repr (k::v) k
+  | Fvar r ->
+      let vid =
+        try List.assq r !kind_vars
+        with Not_found ->
+          let c = incr kind_count; !kind_count in
+          kind_vars := (r,c) :: !kind_vars;
+          c
+      in
+      Printf.sprintf "Fvar {None}@%d" vid
+  | Fpresent -> "Fpresent"
+  | Fabsent -> "Fabsent"
+
+let rec safe_commu_repr v = function
+    Cok -> "Cok"
+  | Cunknown -> "Cunknown"
+  | Clink r ->
+      if List.memq r v then "Clink loop" else
+      safe_commu_repr (r::v) !r
+
+let rec safe_repr v = function
+    {desc = Tlink t} when not (List.memq t v) ->
+      safe_repr (t::v) t
+  | t -> t
+
+let rec list_of_memo = function
+    Mnil -> []
+  | Mcons (_priv, p, _t1, _t2, rem) -> p :: list_of_memo rem
+  | Mlink rem -> list_of_memo !rem
+
+let print_name ppf = function
+    None -> fprintf ppf "None"
+  | Some name -> fprintf ppf "\"%s\"" name
+
+let string_of_label = function
+    Nolabel -> ""
+  | Labelled s -> s
+  | Optional s -> "?"^s
+
+let visited = ref []
+let rec raw_type ppf ty =
+  let ty = safe_repr [] ty in
+  if List.memq ty !visited then fprintf ppf "{id=%d}" ty.id else begin
+    visited := ty :: !visited;
+    fprintf ppf "@[<1>{id=%d;level=%d;desc=@,%a}@]" ty.id ty.level
+      raw_type_desc ty.desc
+  end
+and raw_type_list tl = raw_list raw_type tl
+and raw_type_desc ppf = function
+    Tvar name -> fprintf ppf "Tvar %a" print_name name
+  | Tarrow(l,t1,t2,c) ->
+      fprintf ppf "@[<hov1>Tarrow(\"%s\",@,%a,@,%a,@,%s)@]"
+        (string_of_label l) raw_type t1 raw_type t2
+        (safe_commu_repr [] c)
+  | Ttuple tl ->
+      fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl
+  | Tconstr (p, tl, abbrev) ->
+      fprintf ppf "@[<hov1>Tconstr(@,%a,@,%a,@,%a)@]" path p
+        raw_type_list tl
+        (raw_list path) (list_of_memo !abbrev)
+  | Tobject (t, nm) ->
+      fprintf ppf "@[<hov1>Tobject(@,%a,@,@[<1>ref%t@])@]" raw_type t
+        (fun ppf ->
+          match !nm with None -> fprintf ppf " None"
+          | Some(p,tl) ->
+              fprintf ppf "(Some(@,%a,@,%a))" path p raw_type_list tl)
+  | Tfield (f, k, t1, t2) ->
+      fprintf ppf "@[<hov1>Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f
+        (safe_kind_repr [] k)
+        raw_type t1 raw_type t2
+  | Tnil -> fprintf ppf "Tnil"
+  | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t
+  | Tsubst t -> fprintf ppf "@[<1>Tsubst@,%a@]" raw_type t
+  | Tunivar name -> fprintf ppf "Tunivar %a" print_name name
+  | Tpoly (t, tl) ->
+      fprintf ppf "@[<hov1>Tpoly(@,%a,@,%a)@]"
+        raw_type t
+        raw_type_list tl
+  | Tvariant row ->
+      fprintf ppf
+        "@[<hov1>{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%B;@ %s%a;@ @[<1>%s%t@]}@]"
+        "row_fields="
+        (raw_list (fun ppf (l, f) ->
+          fprintf ppf "@[%s,@ %a@]" l raw_field f))
+        row.row_fields
+        "row_more=" raw_type row.row_more
+        "row_closed=" row.row_closed
+        "row_fixed=" raw_row_fixed row.row_fixed
+        "row_name="
+        (fun ppf ->
+          match row.row_name with None -> fprintf ppf "None"
+          | Some(p,tl) ->
+              fprintf ppf "Some(@,%a,@,%a)" path p raw_type_list tl)
+  | Tpackage (p, _, tl) ->
+      fprintf ppf "@[<hov1>Tpackage(@,%a@,%a)@]" path p
+        raw_type_list tl
+and raw_row_fixed ppf = function
+| None -> fprintf ppf "None"
+| Some Types.Fixed_private -> fprintf ppf "Some Fixed_private"
+| Some Types.Rigid -> fprintf ppf "Some Rigid"
+| Some Types.Univar t -> fprintf ppf "Some(Univar(%a))" raw_type t
+| Some Types.Reified p -> fprintf ppf "Some(Reified(%a))" path p
+
+and raw_field ppf = function
+    Rpresent None -> fprintf ppf "Rpresent None"
+  | Rpresent (Some t) -> fprintf ppf "@[<1>Rpresent(Some@,%a)@]" raw_type t
+  | Reither (c,tl,m,e) ->
+      fprintf ppf "@[<hov1>Reither(%B,@,%a,@,%B,@,@[<1>ref%t@])@]" c
+        raw_type_list tl m
+        (fun ppf ->
+          match !e with None -> fprintf ppf " None"
+          | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f)
+  | Rabsent -> fprintf ppf "Rabsent"
+
+let raw_type_expr ppf t =
+  visited := []; kind_vars := []; kind_count := 0;
+  raw_type ppf t;
+  visited := []; kind_vars := []
+
+let () = Btype.print_raw := raw_type_expr
+
+(* Normalize paths *)
+
+type param_subst = Id | Nth of int | Map of int list
+
+let is_nth = function
+    Nth _ -> true
+  | _ -> false
+
+let compose l1 = function
+  | Id -> Map l1
+  | Map l2 -> Map (List.map (List.nth l1) l2)
+  | Nth n  -> Nth (List.nth l1 n)
+
+let apply_subst s1 tyl =
+  if tyl = [] then []
+  (* cf. PR#7543: Typemod.type_package doesn't respect type constructor arity *)
+  else
+    match s1 with
+      Nth n1 -> [List.nth tyl n1]
+    | Map l1 -> List.map (List.nth tyl) l1
+    | Id -> tyl
+
+type best_path = Paths of Path.t list | Best of Path.t
+
+let printing_depth = ref 0
+let printing_cont = ref ([] : Env.iter_cont list)
+let printing_old = ref Env.empty
+let printing_pers = ref Concr.empty
+let printing_map = ref Path.Map.empty
+
+let same_type t t' = repr t == repr t'
+
+let rec index l x =
+  match l with
+    [] -> raise Not_found
+  | a :: l -> if x == a then 0 else 1 + index l x
+
+let rec uniq = function
+    [] -> true
+  | a :: l -> not (List.memq a l) && uniq l
+
+let rec normalize_type_path ?(cache=false) env p =
+  try
+    let (params, ty, _) = Env.find_type_expansion p env in
+    let params = List.map repr params in
+    match repr ty with
+      {desc = Tconstr (p1, tyl, _)} ->
+        let tyl = List.map repr tyl in
+        if List.length params = List.length tyl
+        && List.for_all2 (==) params tyl
+        then normalize_type_path ~cache env p1
+        else if cache || List.length params <= List.length tyl
+             || not (uniq tyl) then (p, Id)
+        else
+          let l1 = List.map (index params) tyl in
+          let (p2, s2) = normalize_type_path ~cache env p1 in
+          (p2, compose l1 s2)
+    | ty ->
+        (p, Nth (index params ty))
+  with
+    Not_found ->
+      (Env.normalize_type_path None env p, Id)
+
+let penalty s =
+  if s <> "" && s.[0] = '_' then
+    10
+  else
+    match find_double_underscore s with
+    | None -> 1
+    | Some _ -> 10
+
+let rec path_size = function
+    Pident id ->
+      penalty (Ident.name id), -Ident.scope id
+  | Pdot (p, _) ->
+      let (l, b) = path_size p in (1+l, b)
+  | Papply (p1, p2) ->
+      let (l, b) = path_size p1 in
+      (l + fst (path_size p2), b)
+
+let same_printing_env env =
+  let used_pers = Env.used_persistent () in
+  Env.same_types !printing_old env && Concr.equal !printing_pers used_pers
+
+let set_printing_env env =
+  printing_env := env;
+  if !Clflags.real_paths ||
+     !printing_env == Env.empty ||
+     same_printing_env env then
+    ()
+  else begin
+    (* printf "Reset printing_map@."; *)
+    printing_old := env;
+    printing_pers := Env.used_persistent ();
+    printing_map := Path.Map.empty;
+    printing_depth := 0;
+    (* printf "Recompute printing_map.@."; *)
+    let cont =
+      Env.iter_types
+        (fun p (p', _decl) ->
+          let (p1, s1) = normalize_type_path env p' ~cache:true in
+          (* Format.eprintf "%a -> %a = %a@." path p path p' path p1 *)
+          if s1 = Id then
+          try
+            let r = Path.Map.find p1 !printing_map in
+            match !r with
+              Paths l -> r := Paths (p :: l)
+            | Best p' -> r := Paths [p; p'] (* assert false *)
+          with Not_found ->
+            printing_map := Path.Map.add p1 (ref (Paths [p])) !printing_map)
+        env in
+    printing_cont := [cont];
+  end
+
+let wrap_printing_env env f =
+  set_printing_env env; reset_naming_context ();
+  try_finally f ~always:(fun () -> set_printing_env Env.empty)
+
+let wrap_printing_env ~error env f =
+  if error then Env.without_cmis (wrap_printing_env env) f
+  else wrap_printing_env env f
+
+let rec lid_of_path = function
+    Path.Pident id ->
+      Longident.Lident (Ident.name id)
+  | Path.Pdot (p1, s) ->
+      Longident.Ldot (lid_of_path p1, s)
+  | Path.Papply (p1, p2) ->
+      Longident.Lapply (lid_of_path p1, lid_of_path p2)
+
+let is_unambiguous path env =
+  let l = Env.find_shadowed_types path env in
+  List.exists (Path.same path) l || (* concrete paths are ok *)
+  match l with
+    [] -> true
+  | p :: rem ->
+      (* allow also coherent paths:  *)
+      let normalize p = fst (normalize_type_path ~cache:true env p) in
+      let p' = normalize p in
+      List.for_all (fun p -> Path.same (normalize p) p') rem ||
+      (* also allow repeatedly defining and opening (for toplevel) *)
+      let id = lid_of_path p in
+      List.for_all (fun p -> lid_of_path p = id) rem &&
+      Path.same p (fst (Env.find_type_by_name id env))
+
+let rec get_best_path r =
+  match !r with
+    Best p' -> p'
+  | Paths [] -> raise Not_found
+  | Paths l ->
+      r := Paths [];
+      List.iter
+        (fun p ->
+          (* Format.eprintf "evaluating %a@." path p; *)
+          match !r with
+            Best p' when path_size p >= path_size p' -> ()
+          | _ -> if is_unambiguous p !printing_env then r := Best p)
+              (* else Format.eprintf "%a ignored as ambiguous@." path p *)
+        l;
+      get_best_path r
+
+let best_type_path p =
+  if !printing_env == Env.empty
+  then (p, Id)
+  else if !Clflags.real_paths
+  then (p, Id)
+  else
+    let (p', s) = normalize_type_path !printing_env p in
+    let get_path () = get_best_path (Path.Map.find  p' !printing_map) in
+    while !printing_cont <> [] &&
+      try fst (path_size (get_path ())) > !printing_depth with Not_found -> true
+    do
+      printing_cont := List.map snd (Env.run_iter_cont !printing_cont);
+      incr printing_depth;
+    done;
+    let p'' = try get_path () with Not_found -> p' in
+    (* Format.eprintf "%a = %a -> %a@." path p path p' path p''; *)
+    (p'', s)
+
+(* Print a type expression *)
+
+let names = ref ([] : (type_expr * string) list)
+let name_counter = ref 0
+let named_vars = ref ([] : string list)
+
+let weak_counter = ref 1
+let weak_var_map = ref TypeMap.empty
+let named_weak_vars = ref String.Set.empty
+
+let reset_names () = names := []; name_counter := 0; named_vars := []
+let add_named_var ty =
+  match ty.desc with
+    Tvar (Some name) | Tunivar (Some name) ->
+      if List.mem name !named_vars then () else
+      named_vars := name :: !named_vars
+  | _ -> ()
+
+let name_is_already_used name =
+  List.mem name !named_vars
+  || List.exists (fun (_, name') -> name = name') !names
+  || String.Set.mem name !named_weak_vars
+
+let rec new_name () =
+  let name =
+    if !name_counter < 26
+    then String.make 1 (Char.chr(97 + !name_counter))
+    else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^
+           Int.to_string(!name_counter / 26) in
+  incr name_counter;
+  if name_is_already_used name then new_name () else name
+
+let rec new_weak_name ty () =
+  let name = "weak" ^ Int.to_string !weak_counter in
+  incr weak_counter;
+  if name_is_already_used name then new_weak_name ty ()
+  else begin
+      named_weak_vars := String.Set.add name !named_weak_vars;
+      weak_var_map := TypeMap.add ty name !weak_var_map;
+      name
+    end
+
+let name_of_type name_generator t =
+  (* We've already been through repr at this stage, so t is our representative
+     of the union-find class. *)
+  try List.assq t !names with Not_found ->
+    try TypeMap.find t !weak_var_map with Not_found ->
+    let name =
+      match t.desc with
+        Tvar (Some name) | Tunivar (Some name) ->
+          (* Some part of the type we've already printed has assigned another
+           * unification variable to that name. We want to keep the name, so try
+           * adding a number until we find a name that's not taken. *)
+          let current_name = ref name in
+          let i = ref 0 in
+          while List.exists (fun (_, name') -> !current_name = name') !names do
+            current_name := name ^ (Int.to_string !i);
+            i := !i + 1;
+          done;
+          !current_name
+      | _ ->
+          (* No name available, create a new one *)
+          name_generator ()
+    in
+    (* Exception for type declarations *)
+    if name <> "_" then names := (t, name) :: !names;
+    name
+
+let check_name_of_type t = ignore(name_of_type new_name t)
+
+let remove_names tyl =
+  let tyl = List.map repr tyl in
+  names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names
+
+let visited_objects = ref ([] : type_expr list)
+let aliased = ref ([] : type_expr list)
+let delayed = ref ([] : type_expr list)
+
+let add_delayed t =
+  if not (List.memq t !delayed) then delayed := t :: !delayed
+
+let is_aliased ty = List.memq (proxy ty) !aliased
+let add_alias ty =
+  let px = proxy ty in
+  if not (is_aliased px) then begin
+    aliased := px :: !aliased;
+    add_named_var px
+  end
+
+let aliasable ty =
+  match ty.desc with
+    Tvar _ | Tunivar _ | Tpoly _ -> false
+  | Tconstr (p, _, _) ->
+      not (is_nth (snd (best_type_path p)))
+  | _ -> true
+
+let namable_row row =
+  row.row_name <> None &&
+  List.for_all
+    (fun (_, f) ->
+       match row_field_repr f with
+       | Reither(c, l, _, _) ->
+           row.row_closed && if c then l = [] else List.length l = 1
+       | _ -> true)
+    row.row_fields
+
+let rec mark_loops_rec visited ty =
+  let ty = repr ty in
+  let px = proxy ty in
+  if List.memq px visited && aliasable ty then add_alias px else
+    let visited = px :: visited in
+    match ty.desc with
+    | Tvar _ -> add_named_var ty
+    | Tarrow(_, ty1, ty2, _) ->
+        mark_loops_rec visited ty1; mark_loops_rec visited ty2
+    | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl
+    | Tconstr(p, tyl, _) ->
+        let (_p', s) = best_type_path p in
+        List.iter (mark_loops_rec visited) (apply_subst s tyl)
+    | Tpackage (_, _, tyl) ->
+        List.iter (mark_loops_rec visited) tyl
+    | Tvariant row ->
+        if List.memq px !visited_objects then add_alias px else
+         begin
+          let row = row_repr row in
+          if not (static_row row) then
+            visited_objects := px :: !visited_objects;
+          match row.row_name with
+          | Some(_p, tyl) when namable_row row ->
+              List.iter (mark_loops_rec visited) tyl
+          | _ ->
+              iter_row (mark_loops_rec visited) row
+         end
+    | Tobject (fi, nm) ->
+        if List.memq px !visited_objects then add_alias px else
+         begin
+          if opened_object ty then
+            visited_objects := px :: !visited_objects;
+          begin match !nm with
+          | None ->
+              let fields, _ = flatten_fields fi in
+              List.iter
+                (fun (_, kind, ty) ->
+                  if field_kind_repr kind = Fpresent then
+                    mark_loops_rec visited ty)
+                fields
+          | Some (_, l) ->
+              List.iter (mark_loops_rec visited) (List.tl l)
+          end
+        end
+    | Tfield(_, kind, ty1, ty2) when field_kind_repr kind = Fpresent ->
+        mark_loops_rec visited ty1; mark_loops_rec visited ty2
+    | Tfield(_, _, _, ty2) ->
+        mark_loops_rec visited ty2
+    | Tnil -> ()
+    | Tsubst ty -> mark_loops_rec visited ty
+    | Tlink _ -> fatal_error "Printtyp.mark_loops_rec (2)"
+    | Tpoly (ty, tyl) ->
+        List.iter (fun t -> add_alias t) tyl;
+        mark_loops_rec visited ty
+    | Tunivar _ -> add_named_var ty
+
+let mark_loops ty =
+  normalize_type Env.empty ty;
+  mark_loops_rec [] ty;;
+
+let reset_loop_marks () =
+  visited_objects := []; aliased := []; delayed := []
+
+let reset_except_context () =
+  reset_names (); reset_loop_marks ()
+
+let reset () =
+  reset_naming_context (); Conflicts.reset ();
+  reset_except_context ()
+
+let reset_and_mark_loops ty =
+  reset_except_context (); mark_loops ty
+
+let reset_and_mark_loops_list tyl =
+  reset_except_context (); List.iter mark_loops tyl
+
+(* Disabled in classic mode when printing an unification error *)
+let print_labels = ref true
+
+let rec tree_of_typexp sch ty =
+  let ty = repr ty in
+  let px = proxy ty in
+  if List.mem_assq px !names && not (List.memq px !delayed) then
+   let mark = is_non_gen sch ty in
+   let name = name_of_type (if mark then new_weak_name ty else new_name) px in
+   Otyp_var (mark, name) else
+
+  let pr_typ () =
+    match ty.desc with
+    | Tvar _ ->
+        (*let lev =
+          if is_non_gen sch ty then "/" ^ Int.to_string ty.level else "" in*)
+        let non_gen = is_non_gen sch ty in
+        let name_gen = if non_gen then new_weak_name ty else new_name in
+        Otyp_var (non_gen, name_of_type name_gen ty)
+    | Tarrow(l, ty1, ty2, _) ->
+        let lab =
+          if !print_labels || is_optional l then string_of_label l else ""
+        in
+        let t1 =
+          if is_optional l then
+            match (repr ty1).desc with
+            | Tconstr(path, [ty], _)
+              when Path.same path Predef.path_option ->
+                tree_of_typexp sch ty
+            | _ -> Otyp_stuff "<hidden>"
+          else tree_of_typexp sch ty1 in
+        Otyp_arrow (lab, t1, tree_of_typexp sch ty2)
+    | Ttuple tyl ->
+        Otyp_tuple (tree_of_typlist sch tyl)
+    | Tconstr(p, tyl, _abbrev) ->
+        let p', s = best_type_path p in
+        let tyl' = apply_subst s tyl in
+        if is_nth s && not (tyl'=[]) then tree_of_typexp sch (List.hd tyl') else
+        Otyp_constr (tree_of_path Type p', tree_of_typlist sch tyl')
+    | Tvariant row ->
+        let row = row_repr row in
+        let fields =
+          if row.row_closed then
+            List.filter (fun (_, f) -> row_field_repr f <> Rabsent)
+              row.row_fields
+          else row.row_fields in
+        let present =
+          List.filter
+            (fun (_, f) ->
+               match row_field_repr f with
+               | Rpresent _ -> true
+               | _ -> false)
+            fields in
+        let all_present = List.length present = List.length fields in
+        begin match row.row_name with
+        | Some(p, tyl) when namable_row row ->
+            let (p', s) = best_type_path p in
+            let id = tree_of_path Type p' in
+            let args = tree_of_typlist sch (apply_subst s tyl) in
+            let out_variant =
+              if is_nth s then List.hd args else Otyp_constr (id, args) in
+            if row.row_closed && all_present then
+              out_variant
+            else
+              let non_gen = is_non_gen sch px in
+              let tags =
+                if all_present then None else Some (List.map fst present) in
+              Otyp_variant (non_gen, Ovar_typ out_variant, row.row_closed, tags)
+        | _ ->
+            let non_gen =
+              not (row.row_closed && all_present) && is_non_gen sch px in
+            let fields = List.map (tree_of_row_field sch) fields in
+            let tags =
+              if all_present then None else Some (List.map fst present) in
+            Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags)
+        end
+    | Tobject (fi, nm) ->
+        tree_of_typobject sch fi !nm
+    | Tnil | Tfield _ ->
+        tree_of_typobject sch ty None
+    | Tsubst ty ->
+        tree_of_typexp sch ty
+    | Tlink _ ->
+        fatal_error "Printtyp.tree_of_typexp"
+    | Tpoly (ty, []) ->
+        tree_of_typexp sch ty
+    | Tpoly (ty, tyl) ->
+        (*let print_names () =
+          List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names;
+          prerr_string "; " in *)
+        let tyl = List.map repr tyl in
+        if tyl = [] then tree_of_typexp sch ty else begin
+          let old_delayed = !delayed in
+          (* Make the names delayed, so that the real type is
+             printed once when used as proxy *)
+          List.iter add_delayed tyl;
+          let tl = List.map (name_of_type new_name) tyl in
+          let tr = Otyp_poly (tl, tree_of_typexp sch ty) in
+          (* Forget names when we leave scope *)
+          remove_names tyl;
+          delayed := old_delayed; tr
+        end
+    | Tunivar _ ->
+        Otyp_var (false, name_of_type new_name ty)
+    | Tpackage (p, n, tyl) ->
+        let n =
+          List.map (fun li -> String.concat "." (Longident.flatten li)) n in
+        Otyp_module (tree_of_path Module_type p, n, tree_of_typlist sch tyl)
+  in
+  if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed;
+  if is_aliased px && aliasable ty then begin
+    check_name_of_type px;
+    Otyp_alias (pr_typ (), name_of_type new_name px) end
+  else pr_typ ()
+
+and tree_of_row_field sch (l, f) =
+  match row_field_repr f with
+  | Rpresent None | Reither(true, [], _, _) -> (l, false, [])
+  | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty])
+  | Reither(c, tyl, _, _) ->
+      if c (* contradiction: constant constructor with an argument *)
+      then (l, true, tree_of_typlist sch tyl)
+      else (l, false, tree_of_typlist sch tyl)
+  | Rabsent -> (l, false, [] (* actually, an error *))
+
+and tree_of_typlist sch tyl =
+  List.map (tree_of_typexp sch) tyl
+
+and tree_of_typobject sch fi nm =
+  begin match nm with
+  | None ->
+      let pr_fields fi =
+        let (fields, rest) = flatten_fields fi in
+        let present_fields =
+          List.fold_right
+            (fun (n, k, t) l ->
+               match field_kind_repr k with
+               | Fpresent -> (n, t) :: l
+               | _ -> l)
+            fields [] in
+        let sorted_fields =
+          List.sort
+            (fun (n, _) (n', _) -> String.compare n n') present_fields in
+        tree_of_typfields sch rest sorted_fields in
+      let (fields, rest) = pr_fields fi in
+      Otyp_object (fields, rest)
+  | Some (p, ty :: tyl) ->
+      let non_gen = is_non_gen sch (repr ty) in
+      let args = tree_of_typlist sch tyl in
+      let (p', s) = best_type_path p in
+      assert (s = Id);
+      Otyp_class (non_gen, tree_of_path Type p', args)
+  | _ ->
+      fatal_error "Printtyp.tree_of_typobject"
+  end
+
+and is_non_gen sch ty =
+    sch && is_Tvar ty && ty.level <> generic_level
+
+and tree_of_typfields sch rest = function
+  | [] ->
+      let rest =
+        match rest.desc with
+        | Tvar _ | Tunivar _ -> Some (is_non_gen sch rest)
+        | Tconstr _ -> Some false
+        | Tnil -> None
+        | _ -> fatal_error "typfields (1)"
+      in
+      ([], rest)
+  | (s, t) :: l ->
+      let field = (s, tree_of_typexp sch t) in
+      let (fields, rest) = tree_of_typfields sch rest l in
+      (field :: fields, rest)
+
+let typexp sch ppf ty =
+  !Oprint.out_type ppf (tree_of_typexp sch ty)
+
+let marked_type_expr ppf ty = typexp false ppf ty
+
+let type_expr ppf ty =
+  (* [type_expr] is used directly by error message printers,
+     we mark eventual loops ourself to avoid any misuse and stack overflow *)
+  reset_and_mark_loops ty;
+  marked_type_expr ppf ty
+
+and type_sch ppf ty = typexp true ppf ty
+
+and type_scheme ppf ty = reset_and_mark_loops ty; typexp true ppf ty
+
+let type_path ppf p =
+  let (p', s) = best_type_path p in
+  let p = if (s = Id) then p' else p in
+  let t = tree_of_path Type p in
+  !Oprint.out_ident ppf t
+
+(* Maxence *)
+let type_scheme_max ?(b_reset_names=true) ppf ty =
+  if b_reset_names then reset_names () ;
+  typexp true ppf ty
+(* End Maxence *)
+
+let tree_of_type_scheme ty = reset_and_mark_loops ty; tree_of_typexp true ty
+
+(* Print one type declaration *)
+
+let tree_of_constraints params =
+  List.fold_right
+    (fun ty list ->
+       let ty' = unalias ty in
+       if proxy ty != proxy ty' then
+         let tr = tree_of_typexp true ty in
+         (tr, tree_of_typexp true ty') :: list
+       else list)
+    params []
+
+let filter_params tyl =
+  let params =
+    List.fold_left
+      (fun tyl ty ->
+        let ty = repr ty in
+        if List.memq ty tyl then Btype.newgenty (Tsubst ty) :: tyl
+        else ty :: tyl)
+      [] tyl
+  in List.rev params
+
+let mark_loops_constructor_arguments = function
+  | Cstr_tuple l -> List.iter mark_loops l
+  | Cstr_record l -> List.iter (fun l -> mark_loops l.ld_type) l
+
+let rec tree_of_type_decl id decl =
+
+  reset_except_context();
+
+  let params = filter_params decl.type_params in
+
+  begin match decl.type_manifest with
+  | Some ty ->
+      let vars = free_variables ty in
+      List.iter
+        (function {desc = Tvar (Some "_")} as ty ->
+            if List.memq ty vars then ty.desc <- Tvar None
+          | _ -> ())
+        params
+  | None -> ()
+  end;
+
+  List.iter add_alias params;
+  List.iter mark_loops params;
+  List.iter check_name_of_type (List.map proxy params);
+  let ty_manifest =
+    match decl.type_manifest with
+    | None -> None
+    | Some ty ->
+        let ty =
+          (* Special hack to hide variant name *)
+          match repr ty with {desc=Tvariant row} ->
+            let row = row_repr row in
+            begin match row.row_name with
+              Some (Pident id', _) when Ident.same id id' ->
+                newgenty (Tvariant {row with row_name = None})
+            | _ -> ty
+            end
+          | _ -> ty
+        in
+        mark_loops ty;
+        Some ty
+  in
+  begin match decl.type_kind with
+  | Type_abstract -> ()
+  | Type_variant cstrs ->
+      List.iter
+        (fun c ->
+           mark_loops_constructor_arguments c.cd_args;
+           Option.iter mark_loops c.cd_res)
+        cstrs
+  | Type_record(l, _rep) ->
+      List.iter (fun l -> mark_loops l.ld_type) l
+  | Type_open -> ()
+  end;
+
+  let type_param =
+    function
+    | Otyp_var (_, id) -> id
+    | _ -> "?"
+  in
+  let type_defined decl =
+    let abstr =
+      match decl.type_kind with
+        Type_abstract ->
+          decl.type_manifest = None || decl.type_private = Private
+      | Type_record _ ->
+          decl.type_private = Private
+      | Type_variant tll ->
+          decl.type_private = Private ||
+          List.exists (fun cd -> cd.cd_res <> None) tll
+      | Type_open ->
+          decl.type_manifest = None
+    in
+    let vari =
+      List.map2
+        (fun ty v ->
+          if abstr || not (is_Tvar (repr ty)) then Variance.get_upper v
+          else (true,true))
+        decl.type_params decl.type_variance
+    in
+    (Ident.name id,
+     List.map2 (fun ty cocn -> type_param (tree_of_typexp false ty), cocn)
+       params vari)
+  in
+  let tree_of_manifest ty1 =
+    match ty_manifest with
+    | None -> ty1
+    | Some ty -> Otyp_manifest (tree_of_typexp false ty, ty1)
+  in
+  let (name, args) = type_defined decl in
+  let constraints = tree_of_constraints params in
+  let ty, priv =
+    match decl.type_kind with
+    | Type_abstract ->
+        begin match ty_manifest with
+        | None -> (Otyp_abstract, Public)
+        | Some ty ->
+            tree_of_typexp false ty, decl.type_private
+        end
+    | Type_variant cstrs ->
+        tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)),
+        decl.type_private
+    | Type_record(lbls, _rep) ->
+        tree_of_manifest (Otyp_record (List.map tree_of_label lbls)),
+        decl.type_private
+    | Type_open ->
+        tree_of_manifest Otyp_open,
+        decl.type_private
+  in
+    { otype_name = name;
+      otype_params = args;
+      otype_type = ty;
+      otype_private = priv;
+      otype_immediate = Type_immediacy.of_attributes decl.type_attributes;
+      otype_unboxed = decl.type_unboxed.unboxed;
+      otype_cstrs = constraints }
+
+and tree_of_constructor_arguments = function
+  | Cstr_tuple l -> tree_of_typlist false l
+  | Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ]
+
+and tree_of_constructor cd =
+  let name = Ident.name cd.cd_id in
+  let arg () = tree_of_constructor_arguments cd.cd_args in
+  match cd.cd_res with
+  | None -> (name, arg (), None)
+  | Some res ->
+      let nm = !names in
+      names := [];
+      let ret = tree_of_typexp false res in
+      let args = arg () in
+      names := nm;
+      (name, args, Some ret)
+
+and tree_of_label l =
+  (Ident.name l.ld_id, l.ld_mutable = Mutable, tree_of_typexp false l.ld_type)
+
+let constructor ppf c =
+  reset_except_context ();
+  !Oprint.out_constr ppf (tree_of_constructor c)
+
+let label ppf l =
+  reset_except_context ();
+  !Oprint.out_label ppf (tree_of_label l)
+
+let tree_of_type_declaration id decl rs =
+  Osig_type (tree_of_type_decl id decl, tree_of_rec rs)
+
+let type_declaration id ppf decl =
+  !Oprint.out_sig_item ppf (tree_of_type_declaration id decl Trec_first)
+
+let constructor_arguments ppf a =
+  let tys = tree_of_constructor_arguments a in
+  !Oprint.out_type ppf (Otyp_tuple tys)
+
+(* Print an extension declaration *)
+
+let extension_constructor_args_and_ret_type_subtree ext_args ext_ret_type =
+  match ext_ret_type with
+  | None -> (tree_of_constructor_arguments ext_args, None)
+  | Some res ->
+    let nm = !names in
+    names := [];
+    let ret = tree_of_typexp false res in
+    let args = tree_of_constructor_arguments ext_args in
+    names := nm;
+    (args, Some ret)
+
+let tree_of_extension_constructor id ext es =
+  reset_except_context ();
+  let ty_name = Path.name ext.ext_type_path in
+  let ty_params = filter_params ext.ext_type_params in
+  List.iter add_alias ty_params;
+  List.iter mark_loops ty_params;
+  List.iter check_name_of_type (List.map proxy ty_params);
+  mark_loops_constructor_arguments ext.ext_args;
+  Option.iter mark_loops ext.ext_ret_type;
+  let type_param =
+    function
+    | Otyp_var (_, id) -> id
+    | _ -> "?"
+  in
+  let ty_params =
+    List.map (fun ty -> type_param (tree_of_typexp false ty)) ty_params
+  in
+  let name = Ident.name id in
+  let args, ret =
+    extension_constructor_args_and_ret_type_subtree
+      ext.ext_args
+      ext.ext_ret_type
+  in
+  let ext =
+    { oext_name = name;
+      oext_type_name = ty_name;
+      oext_type_params = ty_params;
+      oext_args = args;
+      oext_ret_type = ret;
+      oext_private = ext.ext_private }
+  in
+  let es =
+    match es with
+        Text_first -> Oext_first
+      | Text_next -> Oext_next
+      | Text_exception -> Oext_exception
+  in
+    Osig_typext (ext, es)
+
+let extension_constructor id ppf ext =
+  !Oprint.out_sig_item ppf (tree_of_extension_constructor id ext Text_first)
+
+let extension_only_constructor id ppf ext =
+  reset_except_context ();
+  let name = Ident.name id in
+  let args, ret =
+    extension_constructor_args_and_ret_type_subtree
+      ext.ext_args
+      ext.ext_ret_type
+  in
+  Format.fprintf ppf "@[<hv>%a@]"
+    !Oprint.out_constr (name, args, ret)
+
+(* Print a value declaration *)
+
+let tree_of_value_description id decl =
+  (* Format.eprintf "@[%a@]@." raw_type_expr decl.val_type; *)
+  let id = Ident.name id in
+  let ty = tree_of_type_scheme decl.val_type in
+  let vd =
+    { oval_name = id;
+      oval_type = ty;
+      oval_prims = [];
+      oval_attributes = [] }
+  in
+  let vd =
+    match decl.val_kind with
+    | Val_prim p -> Primitive.print p vd
+    | _ -> vd
+  in
+  Osig_value vd
+
+let value_description id ppf decl =
+  !Oprint.out_sig_item ppf (tree_of_value_description id decl)
+
+(* Print a class type *)
+
+let method_type (_, kind, ty) =
+  match field_kind_repr kind, repr ty with
+    Fpresent, {desc=Tpoly(ty, tyl)} -> (ty, tyl)
+  | _       , ty                    -> (ty, [])
+
+let tree_of_metho sch concrete csil (lab, kind, ty) =
+  if lab <> dummy_method then begin
+    let kind = field_kind_repr kind in
+    let priv = kind <> Fpresent in
+    let virt = not (Concr.mem lab concrete) in
+    let (ty, tyl) = method_type (lab, kind, ty) in
+    let tty = tree_of_typexp sch ty in
+    remove_names tyl;
+    Ocsg_method (lab, priv, virt, tty) :: csil
+  end
+  else csil
+
+let rec prepare_class_type params = function
+  | Cty_constr (_p, tyl, cty) ->
+      let sty = Ctype.self_type cty in
+      if List.memq (proxy sty) !visited_objects
+      || not (List.for_all is_Tvar params)
+      || List.exists (deep_occur sty) tyl
+      then prepare_class_type params cty
+      else List.iter mark_loops tyl
+  | Cty_signature sign ->
+      let sty = repr sign.csig_self in
+      (* Self may have a name *)
+      let px = proxy sty in
+      if List.memq px !visited_objects then add_alias sty
+      else visited_objects := px :: !visited_objects;
+      let (fields, _) =
+        Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
+      in
+      List.iter (fun met -> mark_loops (fst (method_type met))) fields;
+      Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.csig_vars
+  | Cty_arrow (_, ty, cty) ->
+      mark_loops ty;
+      prepare_class_type params cty
+
+let rec tree_of_class_type sch params =
+  function
+  | Cty_constr (p', tyl, cty) ->
+      let sty = Ctype.self_type cty in
+      if List.memq (proxy sty) !visited_objects
+      || not (List.for_all is_Tvar params)
+      then
+        tree_of_class_type sch params cty
+      else
+        let namespace = Namespace.best_class_namespace p' in
+        Octy_constr (tree_of_path namespace p', tree_of_typlist true tyl)
+  | Cty_signature sign ->
+      let sty = repr sign.csig_self in
+      let self_ty =
+        if is_aliased sty then
+          Some (Otyp_var (false, name_of_type new_name (proxy sty)))
+        else None
+      in
+      let (fields, _) =
+        Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
+      in
+      let csil = [] in
+      let csil =
+        List.fold_left
+          (fun csil (ty1, ty2) -> Ocsg_constraint (ty1, ty2) :: csil)
+          csil (tree_of_constraints params)
+      in
+      let all_vars =
+        Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.csig_vars []
+      in
+      (* Consequence of PR#3607: order of Map.fold has changed! *)
+      let all_vars = List.rev all_vars in
+      let csil =
+        List.fold_left
+          (fun csil (l, m, v, t) ->
+            Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp sch t)
+            :: csil)
+          csil all_vars
+      in
+      let csil =
+        List.fold_left (tree_of_metho sch sign.csig_concr) csil fields
+      in
+      Octy_signature (self_ty, List.rev csil)
+  | Cty_arrow (l, ty, cty) ->
+      let lab =
+        if !print_labels || is_optional l then string_of_label l else ""
+      in
+      let tr =
+       if is_optional l then
+         match (repr ty).desc with
+         | Tconstr(path, [ty], _) when Path.same path Predef.path_option ->
+             tree_of_typexp sch ty
+         | _ -> Otyp_stuff "<hidden>"
+       else tree_of_typexp sch ty in
+      Octy_arrow (lab, tr, tree_of_class_type sch params cty)
+
+let class_type ppf cty =
+  reset ();
+  prepare_class_type [] cty;
+  !Oprint.out_class_type ppf (tree_of_class_type false [] cty)
+
+let tree_of_class_param param variance =
+  (match tree_of_typexp true param with
+    Otyp_var (_, s) -> s
+  | _ -> "?"),
+  if is_Tvar (repr param) then (true, true) else variance
+
+let class_variance =
+  List.map Variance.(fun v -> mem May_pos v, mem May_neg v)
+
+let tree_of_class_declaration id cl rs =
+  let params = filter_params cl.cty_params in
+
+  reset_except_context ();
+  List.iter add_alias params;
+  prepare_class_type params cl.cty_type;
+  let sty = Ctype.self_type cl.cty_type in
+  List.iter mark_loops params;
+
+  List.iter check_name_of_type (List.map proxy params);
+  if is_aliased sty then check_name_of_type (proxy sty);
+
+  let vir_flag = cl.cty_new = None in
+  Osig_class
+    (vir_flag, Ident.name id,
+     List.map2 tree_of_class_param params (class_variance cl.cty_variance),
+     tree_of_class_type true params cl.cty_type,
+     tree_of_rec rs)
+
+let class_declaration id ppf cl =
+  !Oprint.out_sig_item ppf (tree_of_class_declaration id cl Trec_first)
+
+let tree_of_cltype_declaration id cl rs =
+  let params = List.map repr cl.clty_params in
+
+  reset_except_context ();
+  List.iter add_alias params;
+  prepare_class_type params cl.clty_type;
+  let sty = Ctype.self_type cl.clty_type in
+  List.iter mark_loops params;
+
+  List.iter check_name_of_type (List.map proxy params);
+  if is_aliased sty then check_name_of_type (proxy sty);
+
+  let sign = Ctype.signature_of_class_type cl.clty_type in
+
+  let virt =
+    let (fields, _) =
+      Ctype.flatten_fields (Ctype.object_fields sign.csig_self) in
+    List.exists
+      (fun (lab, _, _) ->
+         not (lab = dummy_method || Concr.mem lab sign.csig_concr))
+      fields
+    || Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.csig_vars false
+  in
+
+  Osig_class_type
+    (virt, Ident.name id,
+     List.map2 tree_of_class_param params (class_variance cl.clty_variance),
+     tree_of_class_type true params cl.clty_type,
+     tree_of_rec rs)
+
+let cltype_declaration id ppf cl =
+  !Oprint.out_sig_item ppf (tree_of_cltype_declaration id cl Trec_first)
+
+(* Print a module type *)
+
+let wrap_env fenv ftree arg =
+  let env = !printing_env in
+  set_printing_env (fenv env);
+  let tree = ftree arg in
+  set_printing_env env;
+  tree
+
+let filter_rem_sig item rem =
+  match item, rem with
+  | Sig_class _, ctydecl :: tydecl1 :: tydecl2 :: rem ->
+      ([ctydecl; tydecl1; tydecl2], rem)
+  | Sig_class_type _, tydecl1 :: tydecl2 :: rem ->
+      ([tydecl1; tydecl2], rem)
+  | _ ->
+      ([], rem)
+
+let dummy =
+  {
+    type_params = [];
+    type_arity = 0;
+    type_kind = Type_abstract;
+    type_private = Public;
+    type_manifest = None;
+    type_variance = [];
+    type_separability = [];
+    type_is_newtype = false;
+    type_expansion_scope = Btype.lowest_level;
+    type_loc = Location.none;
+    type_attributes = [];
+    type_immediate = Unknown;
+    type_unboxed = unboxed_false_default_false;
+    type_uid = Uid.internal_not_actually_unique;
+  }
+
+let hide ids env = List.fold_right
+    (fun id -> Env.add_type ~check:false (Ident.rename id) dummy)
+    ids env
+
+let hide_rec_items = function
+  | Sig_type(id, _decl, rs, _) ::rem
+    when rs = Trec_first && not !Clflags.real_paths ->
+      let rec get_ids = function
+          Sig_type (id, _, Trec_next, _) :: rem ->
+            id :: get_ids rem
+        | _ -> []
+      in
+      let ids = id :: get_ids rem in
+      set_printing_env
+        (hide ids !printing_env)
+  | _ -> ()
+
+let recursive_sigitem = function
+  | Sig_class(id,_,rs,_) -> Some(id,rs,3)
+  | Sig_class_type (id,_,rs,_) -> Some(id,rs,2)
+  | Sig_type(id, _, rs, _)
+  | Sig_module(id, _, _, rs, _) -> Some (id,rs,0)
+  | _ -> None
+
+let skip k l = snd (Misc.Stdlib.List.split_at k l)
+
+let protect_rec_items items =
+  let rec get_ids recs = function
+    | [] -> []
+    | item :: rem -> match recursive_sigitem item with
+      | Some (id, r, k ) when r = recs -> id :: get_ids Trec_next (skip k rem)
+      | _ -> [] in
+  List.iter Naming_context.add_protected (get_ids Trec_first items)
+
+let stop_type_group env =
+  Naming_context.reset_protected ();
+  set_printing_env env
+
+let still_in_type_group env' in_type_group item =
+  match in_type_group, recursive_sigitem item with
+  | true, Some (_,Trec_next,_) -> true
+  | _, Some (_, (Trec_not | Trec_first),_) ->
+      stop_type_group env' ; true
+  | _ -> stop_type_group env'; false
+
+let rec tree_of_modtype ?(ellipsis=false) = function
+  | Mty_ident p ->
+      Omty_ident (tree_of_path Module_type p)
+  | Mty_signature sg ->
+      Omty_signature (if ellipsis then [Osig_ellipsis]
+                      else tree_of_signature sg)
+  | Mty_functor(param, ty_res) ->
+      let param, res =
+        match param with
+        | Unit -> None, tree_of_modtype ~ellipsis ty_res
+        | Named (param, ty_arg) ->
+          let name, env =
+            match param with
+            | None -> None, fun env -> env
+            | Some id ->
+                Some (Ident.name id),
+                Env.add_module ~arg:true id Mp_present ty_arg
+          in
+          Some (name, tree_of_modtype ~ellipsis:false ty_arg),
+          wrap_env env (tree_of_modtype ~ellipsis) ty_res
+      in
+      Omty_functor (param, res)
+  | Mty_alias p ->
+      Omty_alias (tree_of_path Module p)
+
+and tree_of_signature sg =
+  wrap_env (fun env -> env) (tree_of_signature_rec !printing_env false) sg
+
+and tree_of_signature_rec env' in_type_group = function
+    [] -> stop_type_group env'; []
+  | item :: rem as items ->
+      let in_type_group = still_in_type_group env' in_type_group item in
+      let (sg, rem) = filter_rem_sig item rem in
+      hide_rec_items items;
+      protect_rec_items items;
+      reset_naming_context ();
+      let trees = trees_of_sigitem item in
+      let env' = Env.add_signature (item :: sg) env' in
+      trees @ tree_of_signature_rec env' in_type_group rem
+
+and trees_of_sigitem = function
+  | Sig_value(id, decl, _) ->
+      [tree_of_value_description id decl]
+  | Sig_type(id, _, _, _) when is_row_name (Ident.name id) ->
+      []
+  | Sig_type(id, decl, rs, _) ->
+      [tree_of_type_declaration id decl rs]
+  | Sig_typext(id, ext, es, _) ->
+      [tree_of_extension_constructor id ext es]
+  | Sig_module(id, _, md, rs, _) ->
+      let ellipsis =
+        List.exists (function
+          | Parsetree.{attr_name = {txt="..."}; attr_payload = PStr []} -> true
+          | _ -> false)
+          md.md_attributes in
+      [tree_of_module id md.md_type rs ~ellipsis]
+  | Sig_modtype(id, decl, _) ->
+      [tree_of_modtype_declaration id decl]
+  | Sig_class(id, decl, rs, _) ->
+      [tree_of_class_declaration id decl rs]
+  | Sig_class_type(id, decl, rs, _) ->
+      [tree_of_cltype_declaration id decl rs]
+
+and tree_of_modtype_declaration id decl =
+  let mty =
+    match decl.mtd_type with
+    | None -> Omty_abstract
+    | Some mty -> tree_of_modtype mty
+  in
+  Osig_modtype (Ident.name id, mty)
+
+and tree_of_module id ?ellipsis mty rs =
+  Osig_module (Ident.name id, tree_of_modtype ?ellipsis mty, tree_of_rec rs)
+
+let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty)
+let modtype_declaration id ppf decl =
+  !Oprint.out_sig_item ppf (tree_of_modtype_declaration id decl)
+
+(* For the toplevel: merge with tree_of_signature? *)
+
+(* Refresh weak variable map in the toplevel *)
+let refresh_weak () =
+  let refresh t name (m,s) =
+    if is_non_gen true (repr t) then
+      begin
+        TypeMap.add t name m,
+        String.Set.add name s
+      end
+    else m, s in
+  let m, s =
+    TypeMap.fold refresh !weak_var_map (TypeMap.empty ,String.Set.empty)  in
+  named_weak_vars := s;
+  weak_var_map := m
+
+let print_items showval env x =
+  refresh_weak();
+  reset_naming_context ();
+  Conflicts.reset ();
+  let rec print showval in_type_group env = function
+  | [] -> stop_type_group env; []
+  | item :: rem as items ->
+      let in_type_group = still_in_type_group env in_type_group item in
+      let (sg, rem) = filter_rem_sig item rem in
+      hide_rec_items items;
+      protect_rec_items items;
+      reset_naming_context ();
+      let trees = trees_of_sigitem item in
+      List.map (fun d -> (d, showval env item)) trees @
+      print showval in_type_group (Env.add_signature (item :: sg) env) rem in
+  print showval false env x
+
+(* Print a signature body (used by -i when compiling a .ml) *)
+
+let print_signature ppf tree =
+  fprintf ppf "@[<v>%a@]" !Oprint.out_signature tree
+
+let signature ppf sg =
+  fprintf ppf "%a" print_signature (tree_of_signature sg)
+
+(* Print a signature body (used by -i when compiling a .ml) *)
+let printed_signature sourcefile ppf sg =
+  (* we are tracking any collision event for warning 63 *)
+  Conflicts.reset ();
+  reset_naming_context ();
+  let t = tree_of_signature sg in
+  if Warnings.(is_active @@ Erroneous_printed_signature "")
+  && Conflicts.exists ()
+  then begin
+    let conflicts = Format.asprintf "%t" Conflicts.print_explanations in
+    Location.prerr_warning (Location.in_file sourcefile)
+      (Warnings.Erroneous_printed_signature conflicts);
+    Warnings.check_fatal ()
+  end;
+  fprintf ppf "%a" print_signature t
+
+(* Print an unification error *)
+
+let same_path t t' =
+  let t = repr t and t' = repr t' in
+  t == t' ||
+  match t.desc, t'.desc with
+    Tconstr(p,tl,_), Tconstr(p',tl',_) ->
+      let (p1, s1) = best_type_path p and (p2, s2)  = best_type_path p' in
+      begin match s1, s2 with
+        Nth n1, Nth n2 when n1 = n2 -> true
+      | (Id | Map _), (Id | Map _) when Path.same p1 p2 ->
+          let tl = apply_subst s1 tl and tl' = apply_subst s2 tl' in
+          List.length tl = List.length tl' &&
+          List.for_all2 same_type tl tl'
+      | _ -> false
+      end
+  | _ ->
+      false
+
+type 'a diff = Same of 'a | Diff of 'a * 'a
+
+let trees_of_type_expansion (t,t') =
+  if same_path t t'
+  then begin add_delayed (proxy t); Same (tree_of_typexp false t) end
+  else
+    let t' = if proxy t == proxy t' then unalias t' else t' in
+    (* beware order matter due to side effect,
+       e.g. when printing object types *)
+    let first = tree_of_typexp false t in
+    let second = tree_of_typexp false t' in
+    if first = second then Same first
+    else Diff(first,second)
+
+let type_expansion ppf = function
+  | Same t -> !Oprint.out_type ppf t
+  | Diff(t,t') ->
+      fprintf ppf "@[<2>%a@ =@ %a@]"  !Oprint.out_type t  !Oprint.out_type t'
+
+module Trace = Ctype.Unification_trace
+
+let trees_of_trace = List.map (Trace.map_diff trees_of_type_expansion)
+
+let trees_of_type_path_expansion (tp,tp') =
+  if Path.same tp tp' then Same(tree_of_path Type tp) else
+    Diff(tree_of_path Type tp, tree_of_path Type tp')
+
+let type_path_expansion ppf = function
+  | Same p -> !Oprint.out_ident ppf p
+  | Diff(p,p') ->
+      fprintf ppf "@[<2>%a@ =@ %a@]"
+        !Oprint.out_ident p
+        !Oprint.out_ident p'
+
+let rec trace fst txt ppf = function
+  | {Trace.got; expected} :: rem ->
+      if not fst then fprintf ppf "@,";
+      fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@] %a"
+       type_expansion got txt type_expansion expected
+       (trace false txt) rem
+  | _ -> ()
+
+
+type printing_status =
+  | Discard
+  | Keep
+  | Optional_refinement
+  (** An [Optional_refinement] printing status is attributed to trace
+      elements that are focusing on a new subpart of a structural type.
+      Since the whole type should have been printed earlier in the trace,
+      we only print those elements if they are the last printed element
+      of a trace, and there is no explicit explanation for the
+      type error.
+  *)
+
+let printing_status  = function
+  | Trace.(Diff { got=t1, t1'; expected=t2, t2'}) ->
+      if  is_constr_row ~allow_ident:true t1'
+       || is_constr_row ~allow_ident:true t2'
+      then Discard
+      else if same_path t1 t1' && same_path t2 t2' then Optional_refinement
+      else Keep
+  | _ -> Keep
+
+(** Flatten the trace and remove elements that are always discarded
+    during printing *)
+let prepare_trace f tr =
+  let clean_trace x l = match printing_status x with
+    | Keep -> x :: l
+    | Optional_refinement when l = [] -> [x]
+    | Optional_refinement | Discard -> l
+  in
+  match Trace.flatten f tr with
+  | [] -> []
+  | elt :: rem -> (* the first element is always kept *)
+      elt :: List.fold_right clean_trace rem []
+
+(** Keep elements that are not [Diff _ ] and take the decision
+    for the last element, require a prepared trace *)
+let rec filter_trace keep_last = function
+  | [] -> []
+  | [Trace.Diff d as elt] when printing_status elt = Optional_refinement ->
+      if keep_last then [d] else []
+  | Trace.Diff d :: rem -> d :: filter_trace keep_last rem
+  | _ :: rem -> filter_trace keep_last rem
+
+let type_path_list =
+  Format.pp_print_list ~pp_sep:(fun ppf () -> Format.pp_print_break ppf 2 0)
+    type_path_expansion
+
+(* Hide variant name and var, to force printing the expanded type *)
+let hide_variant_name t =
+  match repr t with
+  | {desc = Tvariant row} as t when (row_repr row).row_name <> None ->
+      newty2 t.level
+        (Tvariant {(row_repr row) with row_name = None;
+                   row_more = newvar2 (row_more row).level})
+  | _ -> t
+
+let prepare_expansion (t, t') =
+  let t' = hide_variant_name t' in
+  mark_loops t;
+  if not (same_path t t') then mark_loops t';
+  (t, t')
+
+let may_prepare_expansion compact (t, t') =
+  match (repr t').desc with
+    Tvariant _ | Tobject _ when compact ->
+      mark_loops t; (t, t)
+  | _ -> prepare_expansion (t, t')
+
+let print_tag ppf = fprintf ppf "`%s"
+
+let print_tags =
+  let comma ppf () = Format.fprintf ppf ",@ " in
+  Format.pp_print_list ~pp_sep:comma print_tag
+
+let is_unit env ty =
+  match (Ctype.expand_head env ty).desc with
+  | Tconstr (p, _, _) -> Path.same p Predef.path_unit
+  | _ -> false
+
+let unifiable env ty1 ty2 =
+  let snap = Btype.snapshot () in
+  let res =
+    try Ctype.unify env ty1 ty2; true
+    with Unify _ -> false
+  in
+  Btype.backtrack snap;
+  res
+
+let explanation_diff env t3 t4 : (Format.formatter -> unit) option =
+  match t3.desc, t4.desc with
+  | Tarrow (_, ty1, ty2, _), _
+    when is_unit env ty1 && unifiable env ty2 t4 ->
+      Some (fun ppf ->
+        fprintf ppf
+          "@,@[Hint: Did you forget to provide `()' as argument?@]")
+  | _, Tarrow (_, ty1, ty2, _)
+    when is_unit env ty1 && unifiable env t3 ty2 ->
+      Some (fun ppf ->
+        fprintf ppf
+          "@,@[Hint: Did you forget to wrap the expression using \
+           `fun () ->'?@]")
+  | _ ->
+      None
+
+let print_pos ppf = function
+  | Trace.First -> fprintf ppf "first"
+  | Trace.Second -> fprintf ppf "second"
+
+let explain_fixed_row_case ppf = function
+  | Trace.Cannot_be_closed -> Format.fprintf ppf "it cannot be closed"
+  | Trace.Cannot_add_tags tags ->
+      Format.fprintf ppf "it may not allow the tag(s) %a"
+        print_tags tags
+
+let explain_fixed_row pos expl = match expl with
+  | Types.Fixed_private ->
+      dprintf "The %a variant type is private" print_pos pos
+  | Types.Univar x ->
+      dprintf "The %a variant type is bound to the universal type variable %a"
+        print_pos pos type_expr x
+  | Types.Reified p ->
+      let p = tree_of_path Type p in
+      dprintf "The %a variant type is bound to %a" print_pos pos
+        !Oprint.out_ident p
+  | Types.Rigid -> ignore
+
+let explain_variant = function
+  | Trace.No_intersection ->
+      Some(dprintf "@,These two variant types have no intersection")
+  | Trace.No_tags(pos,fields) -> Some(
+      dprintf
+        "@,@[The %a variant type does not allow tag(s)@ @[<hov>%a@]@]"
+        print_pos pos
+        print_tags (List.map fst fields)
+    )
+  | Trace.Incompatible_types_for s ->
+      Some(dprintf "@,Types for tag `%s are incompatible" s)
+  | Trace.Fixed_row (pos, k, (Univar _ | Reified _ | Fixed_private as e)) ->
+      Some (
+        dprintf "@,@[%t,@ %a@]" (explain_fixed_row pos e)
+          explain_fixed_row_case k
+      )
+  | Trace.Fixed_row (_,_, Rigid) ->
+      (* this case never happens *)
+      None
+
+
+let explain_escape intro prev ctx e =
+  let pre = match ctx with
+    | Some ctx ->  dprintf "@[%t@;<1 2>%a@]" intro type_expr ctx
+    | None -> match e, prev with
+      | Trace.Univ _, Some(Trace.Incompatible_fields {name; diff}) ->
+          dprintf "@,@[The method %s has type@ %a,@ \
+                   but the expected method type was@ %a@]" name
+            type_expr diff.Trace.got type_expr diff.Trace.expected
+      | _ -> ignore in
+  match e with
+  | Trace.Univ u ->  Some(
+      dprintf "%t@,The universal variable %a would escape its scope"
+        pre type_expr u)
+  | Trace.Constructor p -> Some(
+      dprintf
+        "%t@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
+        pre path p
+    )
+  | Trace.Module_type p -> Some(
+      dprintf
+        "%t@,@[The module type@;<1 2>%a@ would escape its scope@]"
+        pre path p
+    )
+  | Trace.Equation (_,t) -> Some(
+      dprintf "%t @,@[<hov>This instance of %a is ambiguous:@ %s@]"
+        pre type_expr t
+        "it would escape the scope of its equation"
+    )
+  | Trace.Self ->
+      Some (dprintf "%t@,Self type cannot escape its class" pre)
+
+
+let explain_object = function
+  | Trace.Self_cannot_be_closed ->
+      Some (dprintf "@,Self type cannot be unified with a closed object type")
+  | Trace.Missing_field (pos,f) ->
+      Some(dprintf "@,@[The %a object type has no method %s@]" print_pos pos f)
+  | Trace.Abstract_row pos -> Some(
+      dprintf
+        "@,@[The %a object type has an abstract row, it cannot be closed@]"
+        print_pos pos
+    )
+
+
+let explanation intro prev env = function
+  | Trace.Diff { Trace.got = _, s; expected = _,t } -> explanation_diff env s t
+  | Trace.Escape {kind;context} -> explain_escape intro prev context kind
+  | Trace.Incompatible_fields { name; _ } ->
+        Some(dprintf "@,Types for method %s are incompatible" name)
+  | Trace.Variant v -> explain_variant v
+  | Trace.Obj o -> explain_object o
+  | Trace.Rec_occur(x,y) ->
+      reset_and_mark_loops y;
+      Some(dprintf "@,@[<hov>The type variable %a occurs inside@ %a@]"
+            marked_type_expr x marked_type_expr y)
+
+let mismatch intro env trace =
+  Trace.explain trace (fun ~prev h -> explanation intro prev env h)
+
+let explain mis ppf =
+  match mis with
+  | None -> ()
+  | Some explain -> explain ppf
+
+let warn_on_missing_def env ppf t =
+  match t.desc with
+  | Tconstr (p,_,_) ->
+    begin
+      try
+        ignore(Env.find_type p env : Types.type_declaration)
+      with Not_found ->
+        fprintf ppf
+          "@,@[%a is abstract because no corresponding cmi file was found \
+           in path.@]" path p
+    end
+  | _ -> ()
+
+
+let prepare_expansion_head empty_tr = function
+  | Trace.Diff d ->
+      Some(Trace.map_diff (may_prepare_expansion empty_tr) d)
+  | _ -> None
+
+let head_error_printer txt_got txt_but = function
+  | None -> ignore
+  | Some d ->
+      let d = Trace.map_diff trees_of_type_expansion d in
+      dprintf "%t@;<1 2>%a@ %t@;<1 2>%a"
+        txt_got type_expansion d.Trace.got
+        txt_but type_expansion d.Trace.expected
+
+let warn_on_missing_defs env ppf = function
+  | None -> ()
+  | Some {Trace.got=te1,_; expected=te2,_ } ->
+      warn_on_missing_def env ppf te1;
+      warn_on_missing_def env ppf te2
+
+let unification_error env tr txt1 ppf txt2 ty_expect_explanation =
+  reset ();
+  let tr = prepare_trace (fun t t' -> t, hide_variant_name t') tr in
+  let mis = mismatch txt1 env tr in
+  match tr with
+  | [] -> assert false
+  | elt :: tr ->
+    try
+      print_labels := not !Clflags.classic;
+      let tr = filter_trace (mis = None) tr in
+      let head = prepare_expansion_head (tr=[]) elt in
+      let tr = List.map (Trace.map_diff prepare_expansion) tr in
+      let head_error = head_error_printer txt1 txt2 head in
+      let tr = trees_of_trace tr in
+      fprintf ppf
+        "@[<v>\
+          @[%t%t@]%a%t\
+         @]"
+        head_error
+        ty_expect_explanation
+        (trace false "is not compatible with type") tr
+        (explain mis);
+      if env <> Env.empty
+      then warn_on_missing_defs env ppf head;
+      Conflicts.print_explanations ppf;
+      print_labels := true
+    with exn ->
+      print_labels := true;
+      raise exn
+
+let report_unification_error ppf env tr
+    ?(type_expected_explanation = fun _ -> ())
+    txt1 txt2 =
+  wrap_printing_env env (fun () -> unification_error env tr txt1 ppf txt2
+                            type_expected_explanation)
+    ~error:true
+;;
+
+(** [trace] requires the trace to be prepared *)
+let trace fst keep_last txt ppf tr =
+  print_labels := not !Clflags.classic;
+  try match tr with
+    | elt :: tr' ->
+        let elt = match elt with
+          | Trace.Diff diff -> [Trace.map_diff trees_of_type_expansion diff]
+          | _ -> [] in
+        let tr =
+          trees_of_trace
+          @@ List.map (Trace.map_diff prepare_expansion)
+          @@ filter_trace keep_last tr' in
+      if fst then trace fst txt ppf (elt @ tr)
+      else trace fst txt ppf tr;
+      print_labels := true
+  | _ -> ()
+  with exn ->
+    print_labels := true;
+    raise exn
+
+let report_subtyping_error ppf env tr1 txt1 tr2 =
+  wrap_printing_env ~error:true env (fun () ->
+    reset ();
+    let tr1 = prepare_trace (fun t t' -> prepare_expansion (t, t')) tr1 in
+    let tr2 = prepare_trace (fun t t' -> prepare_expansion (t, t')) tr2 in
+    let keep_first = match tr2 with
+      | Trace.[Obj _ | Variant _ | Escape _ ] | [] -> true
+      | _ -> false in
+    fprintf ppf "@[<v>%a" (trace true keep_first txt1) tr1;
+    if tr2 = [] then fprintf ppf "@]" else
+    let mis = mismatch (dprintf "Within this type") env tr2 in
+    fprintf ppf "%a%t%t@]"
+      (trace false (mis = None) "is not compatible with type") tr2
+      (explain mis)
+      Conflicts.print_explanations
+  )
+
+
+let report_ambiguous_type_error ppf env tp0 tpl txt1 txt2 txt3 =
+  wrap_printing_env ~error:true env (fun () ->
+    reset ();
+    let tp0 = trees_of_type_path_expansion tp0 in
+      match tpl with
+      [] -> assert false
+    | [tp] ->
+        fprintf ppf
+          "@[%t@;<1 2>%a@ \
+             %t@;<1 2>%a\
+           @]"
+          txt1 type_path_expansion (trees_of_type_path_expansion tp)
+          txt3 type_path_expansion tp0
+    | _ ->
+        fprintf ppf
+          "@[%t@;<1 2>@[<hv>%a@]\
+             @ %t@;<1 2>%a\
+           @]"
+          txt2 type_path_list (List.map trees_of_type_path_expansion tpl)
+          txt3 type_path_expansion tp0)
+
+(* Adapt functions to exposed interface *)
+let tree_of_path = tree_of_path Other
+let tree_of_modtype = tree_of_modtype ~ellipsis:false
+let type_expansion ty ppf ty' =
+  type_expansion ppf (trees_of_type_expansion (ty,ty'))
+let tree_of_type_declaration id td rs =
+  Naming_context.with_hidden id ( (* for disambiguation *)
+    wrap_env (hide [id]) (* for short-path *)
+      (fun () -> tree_of_type_declaration id td rs)
+  )
diff --git a/upstream/ocaml_411/typing/printtyp.mli b/upstream/ocaml_411/typing/printtyp.mli
new file mode 100644
index 0000000..fba02c6
--- /dev/null
+++ b/upstream/ocaml_411/typing/printtyp.mli
@@ -0,0 +1,186 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Printing functions *)
+
+open Format
+open Types
+open Outcometree
+
+val longident: formatter -> Longident.t -> unit
+val ident: formatter -> Ident.t -> unit
+val tree_of_path: Path.t -> out_ident
+val path: formatter -> Path.t -> unit
+val string_of_path: Path.t -> string
+
+val type_path: formatter -> Path.t -> unit
+(** Print a type path taking account of [-short-paths].
+    Calls should be within [wrap_printing_env]. *)
+
+module Out_name: sig
+  val create: string -> out_name
+  val print: out_name -> string
+end
+
+type namespace =
+  | Type
+  | Module
+  | Module_type
+  | Class
+  | Class_type
+  | Other (** Other bypasses the unique name for identifier mechanism *)
+
+val strings_of_paths: namespace -> Path.t list -> string list
+    (** Print a list of paths, using the same naming context to
+        avoid name collisions *)
+
+val raw_type_expr: formatter -> type_expr -> unit
+val string_of_label: Asttypes.arg_label -> string
+
+val wrap_printing_env: error:bool -> Env.t -> (unit -> 'a) -> 'a
+    (* Call the function using the environment for type path shortening *)
+    (* This affects all the printing functions below *)
+    (* Also, if [~error:true], then disable the loading of cmis *)
+
+module Naming_context: sig
+  val enable: bool -> unit
+  (** When contextual names are enabled, the mapping between identifiers
+      and names is ensured to be one-to-one. *)
+
+  val reset: unit -> unit
+  (** Reset the naming context *)
+end
+
+(** The [Conflicts] module keeps track of conflicts arising when attributing
+    names to identifiers and provides functions that can print explanations
+    for these conflict in error messages *)
+module Conflicts: sig
+  val exists: unit -> bool
+  (** [exists()] returns true if the current naming context renamed
+        an identifier to avoid a name collision *)
+
+  type explanation =
+    { kind: namespace;
+      name:string;
+      root_name:string;
+      location:Location.t
+    }
+
+  val list_explanations: unit -> explanation list
+(** [list_explanations()] return the list of conflict explanations
+    collected up to this point, and reset the list of collected
+    explanations *)
+
+  val print_located_explanations:
+    Format.formatter -> explanation list -> unit
+
+  val print_explanations: Format.formatter -> unit
+  (** Print all conflict explanations collected up to this point *)
+
+  val reset: unit -> unit
+end
+
+val reset: unit -> unit
+val mark_loops: type_expr -> unit
+val reset_and_mark_loops: type_expr -> unit
+val reset_and_mark_loops_list: type_expr list -> unit
+
+val type_expr: formatter -> type_expr -> unit
+val marked_type_expr: formatter -> type_expr -> unit
+(** The function [type_expr] is the safe version of the pair
+    [(typed_expr, marked_type_expr)]:
+    it takes care of marking loops in the type expression and resetting
+    type variable names before printing.
+      Contrarily, the function [marked_type_expr] should only be called on
+    type expressions whose loops have been marked or it may stackoverflow
+    (see #8860 for examples).
+ *)
+
+val constructor_arguments: formatter -> constructor_arguments -> unit
+val tree_of_type_scheme: type_expr -> out_type
+val type_sch : formatter -> type_expr -> unit
+val type_scheme: formatter -> type_expr -> unit
+(* Maxence *)
+val reset_names: unit -> unit
+val type_scheme_max: ?b_reset_names: bool ->
+        formatter -> type_expr -> unit
+(* End Maxence *)
+val tree_of_value_description: Ident.t -> value_description -> out_sig_item
+val value_description: Ident.t -> formatter -> value_description -> unit
+val label : formatter -> label_declaration -> unit
+val constructor : formatter -> constructor_declaration -> unit
+val tree_of_type_declaration:
+    Ident.t -> type_declaration -> rec_status -> out_sig_item
+val type_declaration: Ident.t -> formatter -> type_declaration -> unit
+val tree_of_extension_constructor:
+    Ident.t -> extension_constructor -> ext_status -> out_sig_item
+val extension_constructor:
+    Ident.t -> formatter -> extension_constructor -> unit
+(* Prints extension constructor with the type signature:
+     type ('a, 'b) bar += A of float
+*)
+
+val extension_only_constructor:
+    Ident.t -> formatter -> extension_constructor -> unit
+(* Prints only extension constructor without type signature:
+     A of float
+*)
+
+val tree_of_module:
+    Ident.t -> ?ellipsis:bool -> module_type -> rec_status -> out_sig_item
+val modtype: formatter -> module_type -> unit
+val signature: formatter -> signature -> unit
+val tree_of_modtype: module_type -> out_module_type
+val tree_of_modtype_declaration:
+    Ident.t -> modtype_declaration -> out_sig_item
+val tree_of_signature: Types.signature -> out_sig_item list
+val tree_of_typexp: bool -> type_expr -> out_type
+val modtype_declaration: Ident.t -> formatter -> modtype_declaration -> unit
+val class_type: formatter -> class_type -> unit
+val tree_of_class_declaration:
+    Ident.t -> class_declaration -> rec_status -> out_sig_item
+val class_declaration: Ident.t -> formatter -> class_declaration -> unit
+val tree_of_cltype_declaration:
+    Ident.t -> class_type_declaration -> rec_status -> out_sig_item
+val cltype_declaration: Ident.t -> formatter -> class_type_declaration -> unit
+val type_expansion: type_expr -> Format.formatter -> type_expr -> unit
+val prepare_expansion: type_expr * type_expr -> type_expr * type_expr
+val trace:
+  bool -> bool-> string -> formatter
+  -> (type_expr * type_expr) Ctype.Unification_trace.elt list -> unit
+val report_unification_error:
+    formatter -> Env.t ->
+    Ctype.Unification_trace.t ->
+    ?type_expected_explanation:(formatter -> unit) ->
+    (formatter -> unit) -> (formatter -> unit) ->
+    unit
+val report_subtyping_error:
+    formatter -> Env.t -> Ctype.Unification_trace.t -> string
+    -> Ctype.Unification_trace.t -> unit
+val report_ambiguous_type_error:
+    formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list ->
+    (formatter -> unit) -> (formatter -> unit) -> (formatter -> unit) -> unit
+
+(* for toploop *)
+val print_items: (Env.t -> signature_item -> 'a option) ->
+  Env.t -> signature_item list -> (out_sig_item * 'a option) list
+
+(* Simple heuristic to rewrite Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias
+   for Foo__bar. This pattern is used by the stdlib. *)
+val rewrite_double_underscore_paths: Env.t -> Path.t -> Path.t
+
+(** [printed_signature sourcefile ppf sg] print the signature [sg] of
+    [sourcefile] with potential warnings for name collisions *)
+val printed_signature: string -> formatter -> signature -> unit
diff --git a/upstream/ocaml_411/typing/printtyped.ml b/upstream/ocaml_411/typing/printtyped.ml
new file mode 100644
index 0000000..15aa097
--- /dev/null
+++ b/upstream/ocaml_411/typing/printtyped.ml
@@ -0,0 +1,945 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes;;
+open Format;;
+open Lexing;;
+open Location;;
+open Typedtree;;
+
+let fmt_position f l =
+  if l.pos_lnum = -1
+  then fprintf f "%s[%d]" l.pos_fname l.pos_cnum
+  else fprintf f "%s[%d,%d+%d]" l.pos_fname l.pos_lnum l.pos_bol
+               (l.pos_cnum - l.pos_bol)
+;;
+
+let fmt_location f loc =
+  if not !Clflags.locations then ()
+  else begin
+    fprintf f "(%a..%a)" fmt_position loc.loc_start fmt_position loc.loc_end;
+    if loc.loc_ghost then fprintf f " ghost";
+  end
+;;
+
+let rec fmt_longident_aux f x =
+  match x with
+  | Longident.Lident (s) -> fprintf f "%s" s;
+  | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s;
+  | Longident.Lapply (y, z) ->
+      fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z;
+;;
+
+let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x.txt;;
+
+let fmt_ident = Ident.print
+
+let fmt_modname f = function
+  | None -> fprintf f "_";
+  | Some id -> Ident.print f id
+
+let rec fmt_path_aux f x =
+  match x with
+  | Path.Pident (s) -> fprintf f "%a" fmt_ident s;
+  | Path.Pdot (y, s) -> fprintf f "%a.%s" fmt_path_aux y s;
+  | Path.Papply (y, z) ->
+      fprintf f "%a(%a)" fmt_path_aux y fmt_path_aux z;
+;;
+
+let fmt_path f x = fprintf f "\"%a\"" fmt_path_aux x;;
+
+let fmt_constant f x =
+  match x with
+  | Const_int (i) -> fprintf f "Const_int %d" i;
+  | Const_char (c) -> fprintf f "Const_char %02x" (Char.code c);
+  | Const_string (s, strloc, None) ->
+      fprintf f "Const_string(%S,%a,None)" s fmt_location strloc;
+  | Const_string (s, strloc, Some delim) ->
+      fprintf f "Const_string (%S,%a,Some %S)" s fmt_location strloc delim;
+  | Const_float (s) -> fprintf f "Const_float %s" s;
+  | Const_int32 (i) -> fprintf f "Const_int32 %ld" i;
+  | Const_int64 (i) -> fprintf f "Const_int64 %Ld" i;
+  | Const_nativeint (i) -> fprintf f "Const_nativeint %nd" i;
+;;
+
+let fmt_mutable_flag f x =
+  match x with
+  | Immutable -> fprintf f "Immutable";
+  | Mutable -> fprintf f "Mutable";
+;;
+
+let fmt_virtual_flag f x =
+  match x with
+  | Virtual -> fprintf f "Virtual";
+  | Concrete -> fprintf f "Concrete";
+;;
+
+let fmt_override_flag f x =
+  match x with
+  | Override -> fprintf f "Override";
+  | Fresh -> fprintf f "Fresh";
+;;
+
+let fmt_closed_flag f x =
+  match x with
+  | Closed -> fprintf f "Closed"
+  | Open -> fprintf f "Open"
+
+let fmt_rec_flag f x =
+  match x with
+  | Nonrecursive -> fprintf f "Nonrec";
+  | Recursive -> fprintf f "Rec";
+;;
+
+let fmt_direction_flag f x =
+  match x with
+  | Upto -> fprintf f "Up";
+  | Downto -> fprintf f "Down";
+;;
+
+let fmt_private_flag f x =
+  match x with
+  | Public -> fprintf f "Public";
+  | Private -> fprintf f "Private";
+;;
+
+let line i f s (*...*) =
+  fprintf f "%s" (String.make (2*i) ' ');
+  fprintf f s (*...*)
+;;
+
+let list i f ppf l =
+  match l with
+  | [] -> line i ppf "[]\n";
+  | _ :: _ ->
+     line i ppf "[\n";
+     List.iter (f (i+1) ppf) l;
+     line i ppf "]\n";
+;;
+
+let array i f ppf a =
+  if Array.length a = 0 then
+    line i ppf "[]\n"
+  else begin
+    line i ppf "[\n";
+    Array.iter (f (i+1) ppf) a;
+    line i ppf "]\n"
+  end
+;;
+
+let option i f ppf x =
+  match x with
+  | None -> line i ppf "None\n";
+  | Some x ->
+      line i ppf "Some\n";
+      f (i+1) ppf x;
+;;
+
+let longident i ppf li = line i ppf "%a\n" fmt_longident li;;
+let string i ppf s = line i ppf "\"%s\"\n" s;;
+let arg_label i ppf = function
+  | Nolabel -> line i ppf "Nolabel\n"
+  | Optional s -> line i ppf "Optional \"%s\"\n" s
+  | Labelled s -> line i ppf "Labelled \"%s\"\n" s
+;;
+
+let record_representation i ppf = let open Types in function
+  | Record_regular -> line i ppf "Record_regular\n"
+  | Record_float -> line i ppf "Record_float\n"
+  | Record_unboxed b -> line i ppf "Record_unboxed %b\n" b
+  | Record_inlined i -> line i ppf "Record_inlined %d\n" i
+  | Record_extension p -> line i ppf "Record_extension %a\n" fmt_path p
+
+let attribute i ppf k a =
+  line i ppf "%s \"%s\"\n" k a.Parsetree.attr_name.txt;
+  Printast.payload i ppf a.Parsetree.attr_payload
+
+let attributes i ppf l =
+  let i = i + 1 in
+  List.iter (fun a ->
+    line i ppf "attribute \"%s\"\n" a.Parsetree.attr_name.txt;
+    Printast.payload (i + 1) ppf a.Parsetree.attr_payload
+  ) l
+
+let rec core_type i ppf x =
+  line i ppf "core_type %a\n" fmt_location x.ctyp_loc;
+  attributes i ppf x.ctyp_attributes;
+  let i = i+1 in
+  match x.ctyp_desc with
+  | Ttyp_any -> line i ppf "Ttyp_any\n";
+  | Ttyp_var (s) -> line i ppf "Ttyp_var %s\n" s;
+  | Ttyp_arrow (l, ct1, ct2) ->
+      line i ppf "Ttyp_arrow\n";
+      arg_label i ppf l;
+      core_type i ppf ct1;
+      core_type i ppf ct2;
+  | Ttyp_tuple l ->
+      line i ppf "Ttyp_tuple\n";
+      list i core_type ppf l;
+  | Ttyp_constr (li, _, l) ->
+      line i ppf "Ttyp_constr %a\n" fmt_path li;
+      list i core_type ppf l;
+  | Ttyp_variant (l, closed, low) ->
+      line i ppf "Ttyp_variant closed=%a\n" fmt_closed_flag closed;
+      list i label_x_bool_x_core_type_list ppf l;
+      option i (fun i -> list i string) ppf low
+  | Ttyp_object (l, c) ->
+      line i ppf "Ttyp_object %a\n" fmt_closed_flag c;
+      let i = i + 1 in
+      List.iter (fun {of_desc; of_attributes; _} ->
+        match of_desc with
+        | OTtag (s, t) ->
+            line i ppf "method %s\n" s.txt;
+            attributes i ppf of_attributes;
+            core_type (i + 1) ppf t
+        | OTinherit ct ->
+            line i ppf "OTinherit\n";
+            core_type (i + 1) ppf ct
+        ) l
+  | Ttyp_class (li, _, l) ->
+      line i ppf "Ttyp_class %a\n" fmt_path li;
+      list i core_type ppf l;
+  | Ttyp_alias (ct, s) ->
+      line i ppf "Ttyp_alias \"%s\"\n" s;
+      core_type i ppf ct;
+  | Ttyp_poly (sl, ct) ->
+      line i ppf "Ttyp_poly%a\n"
+        (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x)) sl;
+      core_type i ppf ct;
+  | Ttyp_package { pack_path = s; pack_fields = l } ->
+      line i ppf "Ttyp_package %a\n" fmt_path s;
+      list i package_with ppf l;
+
+and package_with i ppf (s, t) =
+  line i ppf "with type %a\n" fmt_longident s;
+  core_type i ppf t
+
+and pattern : type k . _ -> _ -> k general_pattern -> unit = fun i ppf x ->
+  line i ppf "pattern %a\n" fmt_location x.pat_loc;
+  attributes i ppf x.pat_attributes;
+  let i = i+1 in
+  match x.pat_extra with
+    | extra :: rem ->
+        pattern_extra i ppf extra;
+        pattern i ppf { x with pat_extra = rem }
+    | [] ->
+  match x.pat_desc with
+  | Tpat_any -> line i ppf "Tpat_any\n";
+  | Tpat_var (s,_) -> line i ppf "Tpat_var \"%a\"\n" fmt_ident s;
+  | Tpat_alias (p, s,_) ->
+      line i ppf "Tpat_alias \"%a\"\n" fmt_ident s;
+      pattern i ppf p;
+  | Tpat_constant (c) -> line i ppf "Tpat_constant %a\n" fmt_constant c;
+  | Tpat_tuple (l) ->
+      line i ppf "Tpat_tuple\n";
+      list i pattern ppf l;
+  | Tpat_construct (li, _, po) ->
+      line i ppf "Tpat_construct %a\n" fmt_longident li;
+      list i pattern ppf po;
+  | Tpat_variant (l, po, _) ->
+      line i ppf "Tpat_variant \"%s\"\n" l;
+      option i pattern ppf po;
+  | Tpat_record (l, _c) ->
+      line i ppf "Tpat_record\n";
+      list i longident_x_pattern ppf l;
+  | Tpat_array (l) ->
+      line i ppf "Tpat_array\n";
+      list i pattern ppf l;
+  | Tpat_lazy p ->
+      line i ppf "Tpat_lazy\n";
+      pattern i ppf p;
+  | Tpat_exception p ->
+      line i ppf "Tpat_exception\n";
+      pattern i ppf p;
+  | Tpat_value p ->
+      line i ppf "Tpat_value\n";
+      pattern i ppf (p :> pattern);
+  | Tpat_or (p1, p2, _) ->
+      line i ppf "Tpat_or\n";
+      pattern i ppf p1;
+      pattern i ppf p2;
+
+and pattern_extra i ppf (extra_pat, _, attrs) =
+  match extra_pat with
+  | Tpat_unpack ->
+     line i ppf "Tpat_extra_unpack\n";
+     attributes i ppf attrs;
+  | Tpat_constraint cty ->
+     line i ppf "Tpat_extra_constraint\n";
+     attributes i ppf attrs;
+     core_type i ppf cty;
+  | Tpat_type (id, _) ->
+     line i ppf "Tpat_extra_type %a\n" fmt_path id;
+     attributes i ppf attrs;
+  | Tpat_open (id,_,_) ->
+     line i ppf "Tpat_extra_open \"%a\"\n" fmt_path id;
+     attributes i ppf attrs;
+
+and expression_extra i ppf x attrs =
+  match x with
+  | Texp_constraint ct ->
+      line i ppf "Texp_constraint\n";
+      attributes i ppf attrs;
+      core_type i ppf ct;
+  | Texp_coerce (cto1, cto2) ->
+      line i ppf "Texp_coerce\n";
+      attributes i ppf attrs;
+      option i core_type ppf cto1;
+      core_type i ppf cto2;
+  | Texp_poly cto ->
+      line i ppf "Texp_poly\n";
+      attributes i ppf attrs;
+      option i core_type ppf cto;
+  | Texp_newtype s ->
+      line i ppf "Texp_newtype \"%s\"\n" s;
+      attributes i ppf attrs;
+
+and expression i ppf x =
+  line i ppf "expression %a\n" fmt_location x.exp_loc;
+  attributes i ppf x.exp_attributes;
+  let i =
+    List.fold_left (fun i (extra,_,attrs) ->
+                      expression_extra i ppf extra attrs; i+1)
+      (i+1) x.exp_extra
+  in
+  match x.exp_desc with
+  | Texp_ident (li,_,_) -> line i ppf "Texp_ident %a\n" fmt_path li;
+  | Texp_instvar (_, li,_) -> line i ppf "Texp_instvar %a\n" fmt_path li;
+  | Texp_constant (c) -> line i ppf "Texp_constant %a\n" fmt_constant c;
+  | Texp_let (rf, l, e) ->
+      line i ppf "Texp_let %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l;
+      expression i ppf e;
+  | Texp_function { arg_label = p; param = _; cases; partial = _; } ->
+      line i ppf "Texp_function\n";
+      arg_label i ppf p;
+      list i case ppf cases;
+  | Texp_apply (e, l) ->
+      line i ppf "Texp_apply\n";
+      expression i ppf e;
+      list i label_x_expression ppf l;
+  | Texp_match (e, l, _partial) ->
+      line i ppf "Texp_match\n";
+      expression i ppf e;
+      list i case ppf l;
+  | Texp_try (e, l) ->
+      line i ppf "Texp_try\n";
+      expression i ppf e;
+      list i case ppf l;
+  | Texp_tuple (l) ->
+      line i ppf "Texp_tuple\n";
+      list i expression ppf l;
+  | Texp_construct (li, _, eo) ->
+      line i ppf "Texp_construct %a\n" fmt_longident li;
+      list i expression ppf eo;
+  | Texp_variant (l, eo) ->
+      line i ppf "Texp_variant \"%s\"\n" l;
+      option i expression ppf eo;
+  | Texp_record { fields; representation; extended_expression } ->
+      line i ppf "Texp_record\n";
+      let i = i+1 in
+      line i ppf "fields =\n";
+      array (i+1) record_field ppf fields;
+      line i ppf "representation =\n";
+      record_representation (i+1) ppf representation;
+      line i ppf "extended_expression =\n";
+      option (i+1) expression ppf extended_expression;
+  | Texp_field (e, li, _) ->
+      line i ppf "Texp_field\n";
+      expression i ppf e;
+      longident i ppf li;
+  | Texp_setfield (e1, li, _, e2) ->
+      line i ppf "Texp_setfield\n";
+      expression i ppf e1;
+      longident i ppf li;
+      expression i ppf e2;
+  | Texp_array (l) ->
+      line i ppf "Texp_array\n";
+      list i expression ppf l;
+  | Texp_ifthenelse (e1, e2, eo) ->
+      line i ppf "Texp_ifthenelse\n";
+      expression i ppf e1;
+      expression i ppf e2;
+      option i expression ppf eo;
+  | Texp_sequence (e1, e2) ->
+      line i ppf "Texp_sequence\n";
+      expression i ppf e1;
+      expression i ppf e2;
+  | Texp_while (e1, e2) ->
+      line i ppf "Texp_while\n";
+      expression i ppf e1;
+      expression i ppf e2;
+  | Texp_for (s, _, e1, e2, df, e3) ->
+      line i ppf "Texp_for \"%a\" %a\n" fmt_ident s fmt_direction_flag df;
+      expression i ppf e1;
+      expression i ppf e2;
+      expression i ppf e3;
+  | Texp_send (e, Tmeth_name s, eo) ->
+      line i ppf "Texp_send \"%s\"\n" s;
+      expression i ppf e;
+      option i expression ppf eo
+  | Texp_send (e, Tmeth_val s, eo) ->
+      line i ppf "Texp_send \"%a\"\n" fmt_ident s;
+      expression i ppf e;
+      option i expression ppf eo
+  | Texp_new (li, _, _) -> line i ppf "Texp_new %a\n" fmt_path li;
+  | Texp_setinstvar (_, s, _, e) ->
+      line i ppf "Texp_setinstvar \"%a\"\n" fmt_path s;
+      expression i ppf e;
+  | Texp_override (_, l) ->
+      line i ppf "Texp_override\n";
+      list i string_x_expression ppf l;
+  | Texp_letmodule (s, _, _, me, e) ->
+      line i ppf "Texp_letmodule \"%a\"\n" fmt_modname s;
+      module_expr i ppf me;
+      expression i ppf e;
+  | Texp_letexception (cd, e) ->
+      line i ppf "Texp_letexception\n";
+      extension_constructor i ppf cd;
+      expression i ppf e;
+  | Texp_assert (e) ->
+      line i ppf "Texp_assert";
+      expression i ppf e;
+  | Texp_lazy (e) ->
+      line i ppf "Texp_lazy";
+      expression i ppf e;
+  | Texp_object (s, _) ->
+      line i ppf "Texp_object";
+      class_structure i ppf s
+  | Texp_pack me ->
+      line i ppf "Texp_pack";
+      module_expr i ppf me
+  | Texp_letop {let_; ands; param = _; body; partial = _} ->
+      line i ppf "Texp_letop";
+      binding_op (i+1) ppf let_;
+      list (i+1) binding_op ppf ands;
+      case i ppf body
+  | Texp_unreachable ->
+      line i ppf "Texp_unreachable"
+  | Texp_extension_constructor (li, _) ->
+      line i ppf "Texp_extension_constructor %a" fmt_longident li
+  | Texp_open (o, e) ->
+      line i ppf "Texp_open %a\n"
+        fmt_override_flag o.open_override;
+      module_expr i ppf o.open_expr;
+      attributes i ppf o.open_attributes;
+      expression i ppf e;
+
+and value_description i ppf x =
+  line i ppf "value_description %a %a\n" fmt_ident x.val_id fmt_location
+       x.val_loc;
+  attributes i ppf x.val_attributes;
+  core_type (i+1) ppf x.val_desc;
+  list (i+1) string ppf x.val_prim;
+
+and binding_op i ppf x =
+  line i ppf "binding_op %a %a\n" fmt_path x.bop_op_path
+    fmt_location x.bop_loc;
+  expression i ppf x.bop_exp
+
+and type_parameter i ppf (x, _variance) = core_type i ppf x
+
+and type_declaration i ppf x =
+  line i ppf "type_declaration %a %a\n" fmt_ident x.typ_id fmt_location
+       x.typ_loc;
+  attributes i ppf x.typ_attributes;
+  let i = i+1 in
+  line i ppf "ptype_params =\n";
+  list (i+1) type_parameter ppf x.typ_params;
+  line i ppf "ptype_cstrs =\n";
+  list (i+1) core_type_x_core_type_x_location ppf x.typ_cstrs;
+  line i ppf "ptype_kind =\n";
+  type_kind (i+1) ppf x.typ_kind;
+  line i ppf "ptype_private = %a\n" fmt_private_flag x.typ_private;
+  line i ppf "ptype_manifest =\n";
+  option (i+1) core_type ppf x.typ_manifest;
+
+and type_kind i ppf x =
+  match x with
+  | Ttype_abstract ->
+      line i ppf "Ttype_abstract\n"
+  | Ttype_variant l ->
+      line i ppf "Ttype_variant\n";
+      list (i+1) constructor_decl ppf l;
+  | Ttype_record l ->
+      line i ppf "Ttype_record\n";
+      list (i+1) label_decl ppf l;
+  | Ttype_open ->
+      line i ppf "Ttype_open\n"
+
+and type_extension i ppf x =
+  line i ppf "type_extension\n";
+  attributes i ppf x.tyext_attributes;
+  let i = i+1 in
+  line i ppf "ptyext_path = %a\n" fmt_path x.tyext_path;
+  line i ppf "ptyext_params =\n";
+  list (i+1) type_parameter ppf x.tyext_params;
+  line i ppf "ptyext_constructors =\n";
+  list (i+1) extension_constructor ppf x.tyext_constructors;
+  line i ppf "ptyext_private = %a\n" fmt_private_flag x.tyext_private;
+
+and type_exception i ppf x =
+  line i ppf "type_exception\n";
+  attributes i ppf x.tyexn_attributes;
+  let i = i+1 in
+  line i ppf "ptyext_constructor =\n";
+  let i = i+1 in
+  extension_constructor i ppf x.tyexn_constructor
+
+and extension_constructor i ppf x =
+  line i ppf "extension_constructor %a\n" fmt_location x.ext_loc;
+  attributes i ppf x.ext_attributes;
+  let i = i + 1 in
+  line i ppf "pext_name = \"%a\"\n" fmt_ident x.ext_id;
+  line i ppf "pext_kind =\n";
+  extension_constructor_kind (i + 1) ppf x.ext_kind;
+
+and extension_constructor_kind i ppf x =
+  match x with
+      Text_decl(a, r) ->
+        line i ppf "Text_decl\n";
+        constructor_arguments (i+1) ppf a;
+        option (i+1) core_type ppf r;
+    | Text_rebind(p, _) ->
+        line i ppf "Text_rebind\n";
+        line (i+1) ppf "%a\n" fmt_path p;
+
+and class_type i ppf x =
+  line i ppf "class_type %a\n" fmt_location x.cltyp_loc;
+  attributes i ppf x.cltyp_attributes;
+  let i = i+1 in
+  match x.cltyp_desc with
+  | Tcty_constr (li, _, l) ->
+      line i ppf "Tcty_constr %a\n" fmt_path li;
+      list i core_type ppf l;
+  | Tcty_signature (cs) ->
+      line i ppf "Tcty_signature\n";
+      class_signature i ppf cs;
+  | Tcty_arrow (l, co, cl) ->
+      line i ppf "Tcty_arrow\n";
+      arg_label i ppf l;
+      core_type i ppf co;
+      class_type i ppf cl;
+  | Tcty_open (o, e) ->
+      line i ppf "Tcty_open %a %a\n"
+        fmt_override_flag o.open_override
+        fmt_path (fst o.open_expr);
+      class_type i ppf e
+
+and class_signature i ppf { csig_self = ct; csig_fields = l } =
+  line i ppf "class_signature\n";
+  core_type (i+1) ppf ct;
+  list (i+1) class_type_field ppf l;
+
+and class_type_field i ppf x =
+  line i ppf "class_type_field %a\n" fmt_location x.ctf_loc;
+  let i = i+1 in
+  attributes i ppf x.ctf_attributes;
+  match x.ctf_desc with
+  | Tctf_inherit (ct) ->
+      line i ppf "Tctf_inherit\n";
+      class_type i ppf ct;
+  | Tctf_val (s, mf, vf, ct) ->
+      line i ppf "Tctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf
+           fmt_virtual_flag vf;
+      core_type (i+1) ppf ct;
+  | Tctf_method (s, pf, vf, ct) ->
+      line i ppf "Tctf_method \"%s\" %a %a\n" s fmt_private_flag pf
+           fmt_virtual_flag vf;
+      core_type (i+1) ppf ct;
+  | Tctf_constraint (ct1, ct2) ->
+      line i ppf "Tctf_constraint\n";
+      core_type (i+1) ppf ct1;
+      core_type (i+1) ppf ct2;
+  | Tctf_attribute a ->
+      attribute i ppf "Tctf_attribute" a
+
+and class_description i ppf x =
+  line i ppf "class_description %a\n" fmt_location x.ci_loc;
+  attributes i ppf x.ci_attributes;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.ci_params;
+  line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt;
+  line i ppf "pci_expr =\n";
+  class_type (i+1) ppf x.ci_expr;
+
+and class_type_declaration i ppf x =
+  line i ppf "class_type_declaration %a\n" fmt_location x.ci_loc;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.ci_params;
+  line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt;
+  line i ppf "pci_expr =\n";
+  class_type (i+1) ppf x.ci_expr;
+
+and class_expr i ppf x =
+  line i ppf "class_expr %a\n" fmt_location x.cl_loc;
+  attributes i ppf x.cl_attributes;
+  let i = i+1 in
+  match x.cl_desc with
+  | Tcl_ident (li, _, l) ->
+      line i ppf "Tcl_ident %a\n" fmt_path li;
+      list i core_type ppf l;
+  | Tcl_structure (cs) ->
+      line i ppf "Tcl_structure\n";
+      class_structure i ppf cs;
+  | Tcl_fun (l, p, _, ce, _) ->
+      line i ppf "Tcl_fun\n";
+      arg_label i ppf l;
+      pattern i ppf p;
+      class_expr i ppf ce
+  | Tcl_apply (ce, l) ->
+      line i ppf "Tcl_apply\n";
+      class_expr i ppf ce;
+      list i label_x_expression ppf l;
+  | Tcl_let (rf, l1, l2, ce) ->
+      line i ppf "Tcl_let %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l1;
+      list i ident_x_expression_def ppf l2;
+      class_expr i ppf ce;
+  | Tcl_constraint (ce, Some ct, _, _, _) ->
+      line i ppf "Tcl_constraint\n";
+      class_expr i ppf ce;
+      class_type i ppf ct
+  | Tcl_constraint (ce, None, _, _, _) -> class_expr i ppf ce
+  | Tcl_open (o, e) ->
+      line i ppf "Tcl_open %a %a\n"
+        fmt_override_flag o.open_override
+        fmt_path (fst o.open_expr);
+      class_expr i ppf e
+
+and class_structure i ppf { cstr_self = p; cstr_fields = l } =
+  line i ppf "class_structure\n";
+  pattern (i+1) ppf p;
+  list (i+1) class_field ppf l;
+
+and class_field i ppf x =
+  line i ppf "class_field %a\n" fmt_location x.cf_loc;
+  let i = i + 1 in
+  attributes i ppf x.cf_attributes;
+  match x.cf_desc with
+  | Tcf_inherit (ovf, ce, so, _, _) ->
+      line i ppf "Tcf_inherit %a\n" fmt_override_flag ovf;
+      class_expr (i+1) ppf ce;
+      option (i+1) string ppf so;
+  | Tcf_val (s, mf, _, k, _) ->
+      line i ppf "Tcf_val \"%s\" %a\n" s.txt fmt_mutable_flag mf;
+      class_field_kind (i+1) ppf k
+  | Tcf_method (s, pf, k) ->
+      line i ppf "Tcf_method \"%s\" %a\n" s.txt fmt_private_flag pf;
+      class_field_kind (i+1) ppf k
+  | Tcf_constraint (ct1, ct2) ->
+      line i ppf "Tcf_constraint\n";
+      core_type (i+1) ppf ct1;
+      core_type (i+1) ppf ct2;
+  | Tcf_initializer (e) ->
+      line i ppf "Tcf_initializer\n";
+      expression (i+1) ppf e;
+  | Tcf_attribute a ->
+      attribute i ppf "Tcf_attribute" a
+
+and class_field_kind i ppf = function
+  | Tcfk_concrete (o, e) ->
+      line i ppf "Concrete %a\n" fmt_override_flag o;
+      expression i ppf e
+  | Tcfk_virtual t ->
+      line i ppf "Virtual\n";
+      core_type i ppf t
+
+and class_declaration i ppf x =
+  line i ppf "class_declaration %a\n" fmt_location x.ci_loc;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.ci_params;
+  line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt;
+  line i ppf "pci_expr =\n";
+  class_expr (i+1) ppf x.ci_expr;
+
+and module_type i ppf x =
+  line i ppf "module_type %a\n" fmt_location x.mty_loc;
+  attributes i ppf x.mty_attributes;
+  let i = i+1 in
+  match x.mty_desc with
+  | Tmty_ident (li,_) -> line i ppf "Tmty_ident %a\n" fmt_path li;
+  | Tmty_alias (li,_) -> line i ppf "Tmty_alias %a\n" fmt_path li;
+  | Tmty_signature (s) ->
+      line i ppf "Tmty_signature\n";
+      signature i ppf s;
+  | Tmty_functor (Unit, mt2) ->
+      line i ppf "Tmty_functor ()\n";
+      module_type i ppf mt2;
+  | Tmty_functor (Named (s, _, mt1), mt2) ->
+      line i ppf "Tmty_functor \"%a\"\n" fmt_modname s;
+      module_type i ppf mt1;
+      module_type i ppf mt2;
+  | Tmty_with (mt, l) ->
+      line i ppf "Tmty_with\n";
+      module_type i ppf mt;
+      list i longident_x_with_constraint ppf l;
+  | Tmty_typeof m ->
+      line i ppf "Tmty_typeof\n";
+      module_expr i ppf m;
+
+and signature i ppf x = list i signature_item ppf x.sig_items
+
+and signature_item i ppf x =
+  line i ppf "signature_item %a\n" fmt_location x.sig_loc;
+  let i = i+1 in
+  match x.sig_desc with
+  | Tsig_value vd ->
+      line i ppf "Tsig_value\n";
+      value_description i ppf vd;
+  | Tsig_type (rf, l) ->
+      line i ppf "Tsig_type %a\n" fmt_rec_flag rf;
+      list i type_declaration ppf l;
+  | Tsig_typesubst l ->
+      line i ppf "Tsig_typesubst\n";
+      list i type_declaration ppf l;
+  | Tsig_typext e ->
+      line i ppf "Tsig_typext\n";
+      type_extension i ppf e;
+  | Tsig_exception ext ->
+      line i ppf "Tsig_exception\n";
+      type_exception i ppf ext
+  | Tsig_module md ->
+      line i ppf "Tsig_module \"%a\"\n" fmt_modname md.md_id;
+      attributes i ppf md.md_attributes;
+      module_type i ppf md.md_type
+  | Tsig_modsubst ms ->
+      line i ppf "Tsig_modsubst \"%a\" = %a\n"
+        fmt_ident ms.ms_id fmt_path ms.ms_manifest;
+      attributes i ppf ms.ms_attributes;
+  | Tsig_recmodule decls ->
+      line i ppf "Tsig_recmodule\n";
+      list i module_declaration ppf decls;
+  | Tsig_modtype x ->
+      line i ppf "Tsig_modtype \"%a\"\n" fmt_ident x.mtd_id;
+      attributes i ppf x.mtd_attributes;
+      modtype_declaration i ppf x.mtd_type
+  | Tsig_open od ->
+      line i ppf "Tsig_open %a %a\n"
+        fmt_override_flag od.open_override
+        fmt_path (fst od.open_expr);
+      attributes i ppf od.open_attributes
+  | Tsig_include incl ->
+      line i ppf "Tsig_include\n";
+      attributes i ppf incl.incl_attributes;
+      module_type i ppf incl.incl_mod
+  | Tsig_class (l) ->
+      line i ppf "Tsig_class\n";
+      list i class_description ppf l;
+  | Tsig_class_type (l) ->
+      line i ppf "Tsig_class_type\n";
+      list i class_type_declaration ppf l;
+  | Tsig_attribute a ->
+      attribute i ppf "Tsig_attribute" a
+
+and module_declaration i ppf md =
+  line i ppf "%a" fmt_modname md.md_id;
+  attributes i ppf md.md_attributes;
+  module_type (i+1) ppf md.md_type;
+
+and module_binding i ppf x =
+  line i ppf "%a\n" fmt_modname x.mb_id;
+  attributes i ppf x.mb_attributes;
+  module_expr (i+1) ppf x.mb_expr
+
+and modtype_declaration i ppf = function
+  | None -> line i ppf "#abstract"
+  | Some mt -> module_type (i + 1) ppf mt
+
+and with_constraint i ppf x =
+  match x with
+  | Twith_type (td) ->
+      line i ppf "Twith_type\n";
+      type_declaration (i+1) ppf td;
+  | Twith_typesubst (td) ->
+      line i ppf "Twith_typesubst\n";
+      type_declaration (i+1) ppf td;
+  | Twith_module (li,_) -> line i ppf "Twith_module %a\n" fmt_path li;
+  | Twith_modsubst (li,_) -> line i ppf "Twith_modsubst %a\n" fmt_path li;
+
+and module_expr i ppf x =
+  line i ppf "module_expr %a\n" fmt_location x.mod_loc;
+  attributes i ppf x.mod_attributes;
+  let i = i+1 in
+  match x.mod_desc with
+  | Tmod_ident (li,_) -> line i ppf "Tmod_ident %a\n" fmt_path li;
+  | Tmod_structure (s) ->
+      line i ppf "Tmod_structure\n";
+      structure i ppf s;
+  | Tmod_functor (Unit, me) ->
+      line i ppf "Tmod_functor ()\n";
+      module_expr i ppf me;
+  | Tmod_functor (Named (s, _, mt), me) ->
+      line i ppf "Tmod_functor \"%a\"\n" fmt_modname s;
+      module_type i ppf mt;
+      module_expr i ppf me;
+  | Tmod_apply (me1, me2, _) ->
+      line i ppf "Tmod_apply\n";
+      module_expr i ppf me1;
+      module_expr i ppf me2;
+  | Tmod_constraint (me, _, Tmodtype_explicit mt, _) ->
+      line i ppf "Tmod_constraint\n";
+      module_expr i ppf me;
+      module_type i ppf mt;
+  | Tmod_constraint (me, _, Tmodtype_implicit, _) -> module_expr i ppf me
+  | Tmod_unpack (e, _) ->
+      line i ppf "Tmod_unpack\n";
+      expression i ppf e;
+
+and structure i ppf x = list i structure_item ppf x.str_items
+
+and structure_item i ppf x =
+  line i ppf "structure_item %a\n" fmt_location x.str_loc;
+  let i = i+1 in
+  match x.str_desc with
+  | Tstr_eval (e, attrs) ->
+      line i ppf "Tstr_eval\n";
+      attributes i ppf attrs;
+      expression i ppf e;
+  | Tstr_value (rf, l) ->
+      line i ppf "Tstr_value %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l;
+  | Tstr_primitive vd ->
+      line i ppf "Tstr_primitive\n";
+      value_description i ppf vd;
+  | Tstr_type (rf, l) ->
+      line i ppf "Tstr_type %a\n" fmt_rec_flag rf;
+      list i type_declaration ppf l;
+  | Tstr_typext te ->
+      line i ppf "Tstr_typext\n";
+      type_extension i ppf te
+  | Tstr_exception ext ->
+      line i ppf "Tstr_exception\n";
+      type_exception i ppf ext;
+  | Tstr_module x ->
+      line i ppf "Tstr_module\n";
+      module_binding i ppf x
+  | Tstr_recmodule bindings ->
+      line i ppf "Tstr_recmodule\n";
+      list i module_binding ppf bindings
+  | Tstr_modtype x ->
+      line i ppf "Tstr_modtype \"%a\"\n" fmt_ident x.mtd_id;
+      attributes i ppf x.mtd_attributes;
+      modtype_declaration i ppf x.mtd_type
+  | Tstr_open od ->
+      line i ppf "Tstr_open %a\n"
+        fmt_override_flag od.open_override;
+      module_expr i ppf od.open_expr;
+      attributes i ppf od.open_attributes
+  | Tstr_class (l) ->
+      line i ppf "Tstr_class\n";
+      list i class_declaration ppf (List.map (fun (cl, _) -> cl) l);
+  | Tstr_class_type (l) ->
+      line i ppf "Tstr_class_type\n";
+      list i class_type_declaration ppf (List.map (fun (_, _, cl) -> cl) l);
+  | Tstr_include incl ->
+      line i ppf "Tstr_include";
+      attributes i ppf incl.incl_attributes;
+      module_expr i ppf incl.incl_mod;
+  | Tstr_attribute a ->
+      attribute i ppf "Tstr_attribute" a
+
+and longident_x_with_constraint i ppf (li, _, wc) =
+  line i ppf "%a\n" fmt_path li;
+  with_constraint (i+1) ppf wc;
+
+and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
+  line i ppf "<constraint> %a\n" fmt_location l;
+  core_type (i+1) ppf ct1;
+  core_type (i+1) ppf ct2;
+
+and constructor_decl i ppf {cd_id; cd_name = _; cd_args; cd_res; cd_loc;
+                            cd_attributes} =
+  line i ppf "%a\n" fmt_location cd_loc;
+  line (i+1) ppf "%a\n" fmt_ident cd_id;
+  attributes i ppf cd_attributes;
+  constructor_arguments (i+1) ppf cd_args;
+  option (i+1) core_type ppf cd_res
+
+and constructor_arguments i ppf = function
+  | Cstr_tuple l -> list i core_type ppf l
+  | Cstr_record l -> list i label_decl ppf l
+
+and label_decl i ppf {ld_id; ld_name = _; ld_mutable; ld_type; ld_loc;
+                      ld_attributes} =
+  line i ppf "%a\n" fmt_location ld_loc;
+  attributes i ppf ld_attributes;
+  line (i+1) ppf "%a\n" fmt_mutable_flag ld_mutable;
+  line (i+1) ppf "%a" fmt_ident ld_id;
+  core_type (i+1) ppf ld_type
+
+and longident_x_pattern i ppf (li, _, p) =
+  line i ppf "%a\n" fmt_longident li;
+  pattern (i+1) ppf p;
+
+and case
+    : type k . _ -> _ -> k case -> unit
+  = fun i ppf {c_lhs; c_guard; c_rhs} ->
+  line i ppf "<case>\n";
+  pattern (i+1) ppf c_lhs;
+  begin match c_guard with
+  | None -> ()
+  | Some g -> line (i+1) ppf "<when>\n"; expression (i + 2) ppf g
+  end;
+  expression (i+1) ppf c_rhs;
+
+and value_binding i ppf x =
+  line i ppf "<def>\n";
+  attributes (i+1) ppf x.vb_attributes;
+  pattern (i+1) ppf x.vb_pat;
+  expression (i+1) ppf x.vb_expr
+
+and string_x_expression i ppf (s, _, e) =
+  line i ppf "<override> \"%a\"\n" fmt_path s;
+  expression (i+1) ppf e;
+
+and record_field i ppf = function
+  | _, Overridden (li, e) ->
+      line i ppf "%a\n" fmt_longident li;
+      expression (i+1) ppf e;
+  | _, Kept _ ->
+      line i ppf "<kept>"
+
+and label_x_expression i ppf (l, e) =
+  line i ppf "<arg>\n";
+  arg_label (i+1) ppf l;
+  (match e with None -> () | Some e -> expression (i+1) ppf e)
+
+and ident_x_expression_def i ppf (l, e) =
+  line i ppf "<def> \"%a\"\n" fmt_ident l;
+  expression (i+1) ppf e;
+
+and label_x_bool_x_core_type_list i ppf x =
+  match x.rf_desc with
+  | Ttag (l, b, ctl) ->
+      line i ppf "Ttag \"%s\" %s\n" l.txt (string_of_bool b);
+      attributes (i+1) ppf x.rf_attributes;
+      list (i+1) core_type ppf ctl
+  | Tinherit (ct) ->
+      line i ppf "Tinherit\n";
+      core_type (i+1) ppf ct
+;;
+
+let interface ppf x = list 0 signature_item ppf x.sig_items;;
+
+let implementation ppf x = list 0 structure_item ppf x.str_items;;
+
+let implementation_with_coercion ppf (x, _) = implementation ppf x
diff --git a/upstream/ocaml_411/typing/printtyped.mli b/upstream/ocaml_411/typing/printtyped.mli
new file mode 100644
index 0000000..ded42bb
--- /dev/null
+++ b/upstream/ocaml_411/typing/printtyped.mli
@@ -0,0 +1,23 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*              Damien Doligez, projet Para, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Typedtree;;
+open Format;;
+
+val interface : formatter -> signature -> unit;;
+val implementation : formatter -> structure -> unit;;
+
+val implementation_with_coercion :
+    formatter -> (structure * module_coercion) -> unit;;
diff --git a/upstream/ocaml_411/typing/rec_check.ml b/upstream/ocaml_411/typing/rec_check.ml
new file mode 100644
index 0000000..1248484
--- /dev/null
+++ b/upstream/ocaml_411/typing/rec_check.ml
@@ -0,0 +1,1258 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*               Jeremy Yallop, University of Cambridge                   *)
+(*               Gabriel Scherer, Project Parsifal, INRIA Saclay          *)
+(*               Alban Reynaud, ENS Lyon                                  *)
+(*                                                                        *)
+(*   Copyright 2017 Jeremy Yallop                                         *)
+(*   Copyright 2018 Alban Reynaud                                         *)
+(*   Copyright 2018 INRIA                                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Static checking of recursive declarations
+
+Some recursive definitions are meaningful
+{[
+  let rec factorial = function 0 -> 1 | n -> n * factorial (n - 1)
+  let rec infinite_list = 0 :: infinite_list
+]}
+but some other are meaningless
+{[
+  let rec x = x
+  let rec x = x+1
+|}
+
+Intuitively, a recursive definition makes sense when the body of the
+definition can be evaluated without fully knowing what the recursive
+name is yet.
+
+In the [factorial] example, the name [factorial] refers to a function,
+evaluating the function definition [function ...] can be done
+immediately and will not force a recursive call to [factorial] -- this
+will only happen later, when [factorial] is called with an argument.
+
+In the [infinite_list] example, we can evaluate [0 :: infinite_list]
+without knowing the full content of [infinite_list], but with just its
+address. This is a case of productive/guarded recursion.
+
+On the contrary, [let rec x = x] is unguarded recursion (the meaning
+is undetermined), and [let rec x = x+1] would need the value of [x]
+while evaluating its definition [x+1].
+
+This file implements a static check to decide which definitions are
+known to be meaningful, and which may be meaningless. In the general
+case, we handle a set of mutually-recursive definitions
+{[
+let rec x1 = e1
+and x2 = e2
+...
+and xn = en
+]}
+
+
+Our check (see function [is_valid_recursive_expression] is defined
+using two criteria:
+
+Usage of recursive variables: how does each of the [e1 .. en] use the
+ recursive variables [x1 .. xn]?
+
+Static or dynamic size: for which of the [ei] can we compute the
+  in-memory size of the value without evaluating [ei] (so that we can
+  pre-allocate it, and thus know its final address before evaluation).
+
+The "static or dynamic size" is decided by the classify_* functions below.
+
+The "variable usage" question is decided by a static analysis looking
+very much like a type system. The idea is to assign "access modes" to
+variables, where an "access mode" [m] is defined as either
+
+    m ::= Ignore (* the value is not used at all *)
+        | Delay (* the value is not needed at definition time *)
+        | Guard (* the value is stored under a data constructor *)
+        | Return (* the value result is directly returned *)
+        | Dereference (* full access and inspection of the value *)
+
+The access modes of an expression [e] are represented by a "context"
+[G], which is simply a mapping from variables (the variables used in
+[e]) to access modes.
+
+The core notion of the static check is a type-system-like judgment of
+the form [G |- e : m], which can be interpreted as meaning either of:
+
+- If we are allowed to use the variables of [e] at the modes in [G]
+  (but not more), then it is safe to use [e] at the mode [m].
+
+- If we want to use [e] at the mode [m], then its variables are
+  used at the modes in [G].
+
+In practice, for a given expression [e], our implementation takes the
+desired mode of use [m] as *input*, and returns a context [G] as
+*output*, which is (uniquely determined as) the most permissive choice
+of modes [G] for the variables of [e] such that [G |- e : m] holds.
+*)
+
+open Asttypes
+open Typedtree
+open Types
+
+exception Illegal_expr
+
+(** {1 Static or dynamic size} *)
+
+type sd = Static | Dynamic
+
+let is_ref : Types.value_description -> bool = function
+  | { Types.val_kind =
+        Types.Val_prim { Primitive.prim_name = "%makemutable";
+                          prim_arity = 1 } } ->
+        true
+  | _ -> false
+
+(* See the note on abstracted arguments in the documentation for
+    Typedtree.Texp_apply *)
+let is_abstracted_arg : arg_label * expression option -> bool = function
+  | (_, None) -> true
+  | (_, Some _) -> false
+
+let classify_expression : Typedtree.expression -> sd =
+  (* We need to keep track of the size of expressions
+      bound by local declarations, to be able to predict
+      the size of variables. Compare:
+
+        let rec r =
+          let y = fun () -> r ()
+          in y
+
+      and
+
+        let rec r =
+          let y = if Random.bool () then ignore else fun () -> r ()
+          in y
+
+    In both cases the final address of `r` must be known before `y` is compiled,
+    and this is only possible if `r` has a statically-known size.
+
+    The first definition can be allowed (`y` has a statically-known
+    size) but the second one is unsound (`y` has no statically-known size).
+  *)
+  let rec classify_expression env e = match e.exp_desc with
+    (* binding and variable cases *)
+    | Texp_let (rec_flag, vb, e) ->
+        let env = classify_value_bindings rec_flag env vb in
+        classify_expression env e
+    | Texp_ident (path, _, _) ->
+        classify_path env path
+
+    (* non-binding cases *)
+    | Texp_open (_, e)
+    | Texp_letmodule (_, _, _, _, e)
+    | Texp_sequence (_, e)
+    | Texp_letexception (_, e) ->
+        classify_expression env e
+
+    | Texp_construct (_, {cstr_tag = Cstr_unboxed}, [e]) ->
+        classify_expression env e
+    | Texp_construct _ ->
+        Static
+
+    | Texp_record { representation = Record_unboxed _;
+                    fields = [| _, Overridden (_,e) |] } ->
+        classify_expression env e
+    | Texp_record _ ->
+        Static
+
+    | Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, _)
+      when is_ref vd ->
+        Static
+    | Texp_apply (_,args)
+      when List.exists is_abstracted_arg args ->
+        Static
+    | Texp_apply _ ->
+        Dynamic
+
+    | Texp_for _
+    | Texp_constant _
+    | Texp_new _
+    | Texp_instvar _
+    | Texp_tuple _
+    | Texp_array _
+    | Texp_variant _
+    | Texp_setfield _
+    | Texp_while _
+    | Texp_setinstvar _
+    | Texp_pack _
+    | Texp_object _
+    | Texp_function _
+    | Texp_lazy _
+    | Texp_unreachable
+    | Texp_extension_constructor _ ->
+        Static
+
+    | Texp_match _
+    | Texp_ifthenelse _
+    | Texp_send _
+    | Texp_field _
+    | Texp_assert _
+    | Texp_try _
+    | Texp_override _
+    | Texp_letop _ ->
+        Dynamic
+  and classify_value_bindings rec_flag env bindings =
+    (* We use a non-recursive classification, classifying each
+        binding with respect to the old environment
+        (before all definitions), even if the bindings are recursive.
+
+        Note: computing a fixpoint in some way would be more
+        precise, as the following could be allowed:
+
+          let rec topdef =
+            let rec x = y and y = fun () -> topdef ()
+            in x
+    *)
+    ignore rec_flag;
+    let old_env = env in
+    let add_value_binding env vb =
+      match vb.vb_pat.pat_desc with
+      | Tpat_var (id, _loc) ->
+          let size = classify_expression old_env vb.vb_expr in
+          Ident.add id size env
+      | _ ->
+          (* Note: we don't try to compute any size for complex patterns *)
+          env
+    in
+    List.fold_left add_value_binding env bindings
+  and classify_path env = function
+    | Path.Pident x ->
+        begin
+          try Ident.find_same x env
+          with Not_found ->
+            (* an identifier will be missing from the map if either:
+                - it is a non-local identifier
+                  (bound outside the letrec-binding we are analyzing)
+                - or it is bound by a complex (let p = e in ...) local binding
+                - or it is bound within a module (let module M = ... in ...)
+                  that we are not traversing for size computation
+
+                For non-local identifiers it might be reasonable (although
+                not completely clear) to consider them Static (they have
+                already been evaluated), but for the others we must
+                under-approximate with Dynamic.
+
+                This could be fixed by a more complete implementation.
+            *)
+            Dynamic
+        end
+    | Path.Pdot _ | Path.Papply _ ->
+        (* local modules could have such paths to local definitions;
+            classify_expression could be extend to compute module
+            shapes more precisely *)
+        Dynamic
+  in classify_expression Ident.empty
+
+
+(** {1 Usage of recursive variables} *)
+
+module Mode = struct
+  (** For an expression in a program, its "usage mode" represents
+      static information about how the value produced by the expression
+      will be used by the context around it. *)
+  type t =
+    | Ignore
+    (** [Ignore] is for subexpressions that are not used at all during
+       the evaluation of the whole program. This is the mode of
+       a variable in an expression in which it does not occur. *)
+
+    | Delay
+    (** A [Delay] context can be fully evaluated without evaluating its argument
+        , which will only be needed at a later point of program execution. For
+        example, [fun x -> ?] or [lazy ?] are [Delay] contexts. *)
+
+    | Guard
+    (** A [Guard] context returns the value as a member of a data structure,
+        for example a variant constructor or record. The value can safely be
+        defined mutually-recursively with their context, for example in
+        [let rec li = 1 :: li].
+        When these subexpressions participate in a cyclic definition,
+        this definition is productive/guarded.
+
+        The [Guard] mode is also used when a value is not dereferenced,
+        it is returned by a sub-expression, but the result of this
+        sub-expression is discarded instead of being returned.
+        For example, the subterm [?] is in a [Guard] context
+        in [let _ = ? in e] and in [?; e].
+        When these subexpressions participate in a cyclic definition,
+        they cannot create a self-loop.
+    *)
+
+    | Return
+    (** A [Return] context returns its value without further inspection.
+        This value cannot be defined mutually-recursively with its context,
+        as there is a risk of self-loop: in [let rec x = y and y = x], the
+        two definitions use a single variable in [Return] context. *)
+
+    | Dereference
+    (** A [Dereference] context consumes, inspects and uses the value
+        in arbitrary ways. Such a value must be fully defined at the point
+        of usage, it cannot be defined mutually-recursively with its context. *)
+
+  let equal = ((=) : t -> t -> bool)
+
+  (* Lower-ranked modes demand/use less of the variable/expression they qualify
+     -- so they allow more recursive definitions.
+
+     Ignore < Delay < Guard < Return < Dereference
+  *)
+  let rank = function
+    | Ignore -> 0
+    | Delay -> 1
+    | Guard -> 2
+    | Return -> 3
+    | Dereference -> 4
+
+  (* Returns the more conservative (highest-ranking) mode of the two
+     arguments.
+
+     In judgments we write (m + m') for (join m m').
+  *)
+  let join m m' =
+    if rank m >= rank m' then m else m'
+
+  (* If x is used with the mode m in e[x], and e[x] is used with mode
+     m' in e'[e[x]], then x is used with mode m'[m] (our notation for
+     "compose m' m") in e'[e[x]].
+
+     Return is neutral for composition: m[Return] = m = Return[m].
+
+     Composition is associative and [Ignore] is a zero/annihilator for
+     it: (compose Ignore m) and (compose m Ignore) are both Ignore. *)
+  let compose m' m = match m', m with
+    | Ignore, _ | _, Ignore -> Ignore
+    | Dereference, _ -> Dereference
+    | Delay, _ -> Delay
+    | Guard, Return -> Guard
+    | Guard, ((Dereference | Guard | Delay) as m) -> m
+    | Return, Return -> Return
+    | Return, ((Dereference | Guard | Delay) as m) -> m
+end
+
+type mode = Mode.t = Ignore | Delay | Guard | Return | Dereference
+
+module Env :
+sig
+  type t
+
+  val single : Ident.t -> Mode.t -> t
+  (** Create an environment with a single identifier used with a given mode.
+  *)
+
+  val empty : t
+  (** An environment with no used identifiers. *)
+
+  val find : Ident.t -> t -> Mode.t
+  (** Find the mode of an identifier in an environment.  The default mode is
+      Ignore. *)
+
+  val unguarded : t -> Ident.t list -> Ident.t list
+  (** unguarded e l: the list of all identifiers in l that are dereferenced or
+      returned in the environment e. *)
+
+  val dependent : t -> Ident.t list -> Ident.t list
+  (** dependent e l: the list of all identifiers in l that are used in e
+      (not ignored). *)
+
+  val join : t -> t -> t
+  val join_list : t list -> t
+  (** Environments can be joined pointwise (variable per variable) *)
+
+  val compose : Mode.t -> t -> t
+  (** Environment composition m[G] extends mode composition m1[m2]
+      by composing each mode in G pointwise *)
+
+  val remove : Ident.t -> t -> t
+  (** Remove an identifier from an environment. *)
+
+  val take: Ident.t -> t -> Mode.t * t
+  (** Remove an identifier from an environment, and return its mode *)
+
+  val remove_list : Ident.t list -> t -> t
+  (** Remove all the identifiers of a list from an environment. *)
+
+  val equal : t -> t -> bool
+end = struct
+  module M = Map.Make(Ident)
+
+  (** A "t" maps each rec-bound variable to an access status *)
+  type t = Mode.t M.t
+
+  let equal = M.equal Mode.equal
+
+  let find (id: Ident.t) (tbl: t) =
+    try M.find id tbl with Not_found -> Ignore
+
+  let empty = M.empty
+
+  let join (x: t) (y: t) =
+    M.fold
+      (fun (id: Ident.t) (v: Mode.t) (tbl: t) ->
+         let v' = find id tbl in
+         M.add id (Mode.join v v') tbl)
+      x y
+
+  let join_list li = List.fold_left join empty li
+
+  let compose m env =
+    M.map (Mode.compose m) env
+
+  let single id mode = M.add id mode empty
+
+  let unguarded env li =
+    List.filter (fun id -> Mode.rank (find id env) > Mode.rank Guard) li
+
+  let dependent env li =
+    List.filter (fun id -> Mode.rank (find id env) > Mode.rank Ignore) li
+
+  let remove = M.remove
+
+  let take id env = (find id env, remove id env)
+
+  let remove_list l env =
+    List.fold_left (fun env id -> M.remove id env) env l
+end
+
+let remove_pat pat env =
+  Env.remove_list (pat_bound_idents pat) env
+
+let remove_patlist pats env =
+  List.fold_right remove_pat pats env
+
+(* Usage mode judgments.
+
+   There are two main groups of judgment functions:
+
+   - Judgments of the form "G |- ... : m"
+     compute the environment G of a subterm ... from its mode m, so
+     the corresponding function has type [... -> Mode.t -> Env.t].
+
+     We write [... -> term_judg] in this case.
+
+   - Judgments of the form "G |- ... : m -| G'"
+
+     correspond to binding constructs (for example "let x = e" in the
+     term "let x = e in body") that have both an exterior environment
+     G (the environment of the whole term "let x = e in body") and an
+     interior environment G' (the environment at the "in", after the
+     binding construct has introduced new names in scope).
+
+     For example, let-binding could be given the following rule:
+
+       G |- e : m + m'
+       -----------------------------------
+       G+G' |- (let x = e) : m -| x:m', G'
+
+     Checking the whole term composes this judgment
+     with the "G |- e : m" form for the let body:
+
+       G  |- (let x = e) : m -| G'
+       G' |- body : m
+       -------------------------------
+       G |- let x = e in body : m
+
+     To this judgment "G |- e : m -| G'" our implementation gives the
+     type [... -> Mode.t -> Env.t -> Env.t]: it takes the mode and
+     interior environment as inputs, and returns the exterior
+     environment.
+
+     We write [... -> bind_judg] in this case.
+*)
+type term_judg = Mode.t -> Env.t
+type bind_judg = Mode.t -> Env.t -> Env.t
+
+let option : 'a. ('a -> term_judg) -> 'a option -> term_judg =
+  fun f o m -> match o with
+    | None -> Env.empty
+    | Some v -> f v m
+let list : 'a. ('a -> term_judg) -> 'a list -> term_judg =
+  fun f li m ->
+    List.fold_left (fun env item -> Env.join env (f item m)) Env.empty li
+let array : 'a. ('a -> term_judg) -> 'a array -> term_judg =
+  fun f ar m ->
+    Array.fold_left (fun env item -> Env.join env (f item m)) Env.empty ar
+
+let single : Ident.t -> term_judg = Env.single
+let remove_id : Ident.t -> term_judg -> term_judg =
+  fun id f m -> Env.remove id (f m)
+let remove_ids : Ident.t list -> term_judg -> term_judg =
+  fun ids f m -> Env.remove_list ids (f m)
+
+let join : term_judg list -> term_judg =
+  fun li m -> Env.join_list (List.map (fun f -> f m) li)
+
+let empty = fun _ -> Env.empty
+
+(* A judgment [judg] takes a mode from the context as input, and
+   returns an environment. The judgment [judg << m], given a mode [m']
+   from the context, evaluates [judg] in the composed mode [m'[m]]. *)
+let (<<) : term_judg -> Mode.t -> term_judg =
+  fun f inner_mode -> fun outer_mode -> f (Mode.compose outer_mode inner_mode)
+
+(* A binding judgment [binder] expects a mode and an inner environment,
+   and returns an outer environment. [binder >> judg] computes
+   the inner environment as the environment returned by [judg]
+   in the ambient mode. *)
+let (>>) : bind_judg -> term_judg -> term_judg =
+  fun binder term mode -> binder mode (term mode)
+
+(* Expression judgment:
+     G |- e : m
+   where (m) is an input of the code and (G) is an output;
+   in the Prolog mode notation, this is (+G |- -e : -m).
+*)
+let rec expression : Typedtree.expression -> term_judg =
+  fun exp -> match exp.exp_desc with
+    | Texp_ident (pth, _, _) ->
+      path pth
+    | Texp_let (rec_flag, bindings, body) ->
+      (*
+         G  |- <bindings> : m -| G'
+         G' |- body : m
+         -------------------------------
+         G |- let <bindings> in body : m
+      *)
+      value_bindings rec_flag bindings >> expression body
+    | Texp_letmodule (x, _, _, mexp, e) ->
+      module_binding (x, mexp) >> expression e
+    | Texp_match (e, cases, _) ->
+      (*
+         (Gi; mi |- pi -> ei : m)^i
+         G |- e : sum(mi)^i
+         ----------------------------------------------
+         G + sum(Gi)^i |- match e with (pi -> ei)^i : m
+       *)
+      (fun mode ->
+        let pat_envs, pat_modes =
+          List.split (List.map (fun c -> case c mode) cases) in
+        let env_e = expression e (List.fold_left Mode.join Ignore pat_modes) in
+        Env.join_list (env_e :: pat_envs))
+    | Texp_for (_, _, low, high, _, body) ->
+      (*
+        G1 |- low: m[Dereference]
+        G2 |- high: m[Dereference]
+        G3 |- body: m[Guard]
+        ---
+        G1 + G2 + G3 |- for _ = low to high do body done: m
+      *)
+      join [
+        expression low << Dereference;
+        expression high << Dereference;
+        expression body << Guard;
+      ]
+    | Texp_constant _ ->
+      empty
+    | Texp_new (pth, _, _) ->
+      (*
+        G |- c: m[Dereference]
+        -----------------------
+        G |- new c: m
+      *)
+      path pth << Dereference
+    | Texp_instvar (self_path, pth, _inst_var) ->
+        join [path self_path << Dereference; path pth]
+    | Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, [_, Some arg])
+      when is_ref vd ->
+      (*
+        G |- e: m[Guard]
+        ------------------
+        G |- ref e: m
+      *)
+      expression arg << Guard
+    | Texp_apply (e, args)  ->
+        let arg (_, eo) = option expression eo in
+        let app_mode = if List.exists is_abstracted_arg args
+          then (* see the comment on Texp_apply in typedtree.mli;
+                  the non-abstracted arguments are bound to local
+                  variables, which corresponds to a Guard mode. *)
+            Guard
+          else Dereference
+        in
+        join [expression e; list arg args] << app_mode
+    | Texp_tuple exprs ->
+      list expression exprs << Guard
+    | Texp_array exprs ->
+      let array_mode = match Typeopt.array_kind exp with
+        | Lambda.Pfloatarray ->
+            (* (flat) float arrays unbox their elements *)
+            Dereference
+        | Lambda.Pgenarray ->
+            (* This is counted as a use, because constructing a generic array
+               involves inspecting to decide whether to unbox (PR#6939). *)
+            Dereference
+        | Lambda.Paddrarray | Lambda.Pintarray ->
+            (* non-generic, non-float arrays act as constructors *)
+            Guard
+      in
+      list expression exprs << array_mode
+    | Texp_construct (_, desc, exprs) ->
+      let access_constructor =
+        match desc.cstr_tag with
+        | Cstr_extension (pth, _) ->
+          path pth << Dereference
+        | _ -> empty
+      in
+      let m' = match desc.cstr_tag with
+        | Cstr_unboxed ->
+          Return
+        | Cstr_constant _ | Cstr_block _ | Cstr_extension _ ->
+          Guard
+      in
+      join [
+        access_constructor;
+        list expression exprs << m'
+      ]
+    | Texp_variant (_, eo) ->
+      (*
+        G |- e: m[Guard]
+        ------------------   -----------
+        G |- `A e: m         [] |- `A: m
+      *)
+      option expression eo << Guard
+    | Texp_record { fields = es; extended_expression = eo;
+                    representation = rep } ->
+        let field_mode = match rep with
+          | Record_float -> Dereference
+          | Record_unboxed _ -> Return
+          | Record_regular | Record_inlined _
+          | Record_extension _ -> Guard
+        in
+        let field (_label, field_def) = match field_def with
+            Kept _ -> empty
+          | Overridden (_, e) -> expression e
+        in
+        join [
+          array field es << field_mode;
+          option expression eo << Dereference
+        ]
+    | Texp_ifthenelse (cond, ifso, ifnot) ->
+      (*
+        Gc |- c: m[Dereference]
+        G1 |- e1: m
+        G2 |- e2: m
+        ---
+        Gc + G1 + G2 |- if c then e1 else e2: m
+
+      Note: `if c then e1 else e2` is treated in the same way as
+      `match c with true -> e1 | false -> e2`
+      *)
+      join [
+        expression cond << Dereference;
+        expression ifso;
+        option expression ifnot;
+      ]
+    | Texp_setfield (e1, _, _, e2) ->
+      (*
+        G1 |- e1: m[Dereference]
+        G2 |- e2: m[Dereference]
+        ---
+        G1 + G2 |- e1.x <- e2: m
+
+        Note: e2 is dereferenced in the case of a field assignment to
+        a record of unboxed floats in that case, e2 evaluates to
+        a boxed float and it is unboxed on assignment.
+      *)
+      join [
+        expression e1 << Dereference;
+        expression e2 << Dereference;
+      ]
+    | Texp_sequence (e1, e2) ->
+      (*
+        G1 |- e1: m[Guard]
+        G2 |- e2: m
+        --------------------
+        G1 + G2 |- e1; e2: m
+
+        Note: `e1; e2` is treated in the same way as `let _ = e1 in e2`
+      *)
+      join [
+        expression e1 << Guard;
+        expression e2;
+      ]
+    | Texp_while (cond, body) ->
+      (*
+        G1 |- cond: m[Dereference]
+        G2 |- body: m[Guard]
+        ---------------------------------
+        G1 + G2 |- while cond do body done: m
+      *)
+      join [
+        expression cond << Dereference;
+        expression body << Guard;
+      ]
+    | Texp_send (e1, _, eo) ->
+      (*
+        G |- e: m[Dereference]
+        ---------------------- (plus weird 'eo' option)
+        G |- e#x: m
+      *)
+      join [
+        expression e1 << Dereference;
+        option expression eo << Dereference;
+      ]
+    | Texp_field (e, _, _) ->
+      (*
+        G |- e: m[Dereference]
+        -----------------------
+        G |- e.x: m
+      *)
+      expression e << Dereference
+    | Texp_setinstvar (pth,_,_,e) ->
+      (*
+        G |- e: m[Dereference]
+        ----------------------
+        G |- x <- e: m
+      *)
+      join [
+        path pth << Dereference;
+        expression e << Dereference;
+      ]
+    | Texp_letexception ({ext_id}, e) ->
+      (* G |- e: m
+         ----------------------------
+         G |- let exception A in e: m
+      *)
+      remove_id ext_id (expression e)
+    | Texp_assert e ->
+      (*
+        G |- e: m[Dereference]
+        -----------------------
+        G |- assert e: m
+
+        Note: `assert e` is treated just as if `assert` was a function.
+      *)
+      expression e << Dereference
+    | Texp_pack mexp ->
+      (*
+        G |- M: m
+        ----------------
+        G |- module M: m
+      *)
+      modexp mexp
+    | Texp_object (clsstrct, _) ->
+      class_structure clsstrct
+    | Texp_try (e, cases) ->
+      (*
+        G |- e: m      (Gi; _ |- pi -> ei : m)^i
+        --------------------------------------------
+        G + sum(Gi)^i |- try e with (pi -> ei)^i : m
+
+        Contrarily to match, the patterns p do not inspect
+        the value of e, so their mode does not influence the
+        mode of e.
+      *)
+      let case_env c m = fst (case c m) in
+      join [
+        expression e;
+        list case_env cases;
+      ]
+    | Texp_override (pth, fields) ->
+      (*
+         G |- pth : m   (Gi |- ei : m[Dereference])^i
+         ----------------------------------------------------
+         G + sum(Gi)^i |- {< (xi = ei)^i >} (at path pth) : m
+
+         Note: {< .. >} is desugared to a function application, but
+         the function implementation might still use its arguments in
+         a guarded way only -- intuitively it should behave as a constructor.
+         We could possibly refine the arguments' Dereference into Guard here.
+      *)
+      let field (_, _, arg) = expression arg in
+      join [
+        path pth << Dereference;
+        list field fields << Dereference;
+      ]
+    | Texp_function { cases } ->
+      (*
+         (Gi; _ |- pi -> ei : m[Delay])^i
+         --------------------------------------
+         sum(Gi)^i |- function (pi -> ei)^i : m
+
+         Contrarily to match, the value that is pattern-matched
+         is bound locally, so the pattern modes do not influence
+         the final environment.
+      *)
+      let case_env c m = fst (case c m) in
+      list case_env cases << Delay
+    | Texp_lazy e ->
+      (*
+        G |- e: m[Delay]
+        ----------------  (modulo some subtle compiler optimizations)
+        G |- lazy e: m
+      *)
+      let lazy_mode = match Typeopt.classify_lazy_argument e with
+        | `Constant_or_function
+        | `Identifier _
+        | `Float_that_cannot_be_shortcut ->
+          Return
+        | `Other ->
+          Delay
+      in
+      expression e << lazy_mode
+    | Texp_letop{let_; ands; body; _} ->
+        let case_env c m = fst (case c m) in
+        join [
+          list binding_op (let_ :: ands) << Dereference;
+          case_env body << Delay
+        ]
+    | Texp_unreachable ->
+      (*
+        ----------
+        [] |- .: m
+      *)
+      empty
+    | Texp_extension_constructor (_lid, pth) ->
+      path pth << Dereference
+    | Texp_open (od, e) ->
+      open_declaration od >> expression e
+
+and binding_op : Typedtree.binding_op -> term_judg =
+  fun bop ->
+    join [path bop.bop_op_path; expression bop.bop_exp]
+
+and class_structure : Typedtree.class_structure -> term_judg =
+  fun cs -> list class_field cs.cstr_fields
+
+and class_field : Typedtree.class_field -> term_judg =
+  fun cf -> match cf.cf_desc with
+    | Tcf_inherit (_, ce, _super, _inh_vars, _inh_meths) ->
+      class_expr ce << Dereference
+    | Tcf_val (_lab, _mut, _, cfk, _) ->
+      class_field_kind cfk
+    | Tcf_method (_, _, cfk) ->
+      class_field_kind cfk
+    | Tcf_constraint _ ->
+      empty
+    | Tcf_initializer e ->
+      expression e << Dereference
+    | Tcf_attribute _ ->
+      empty
+
+and class_field_kind : Typedtree.class_field_kind -> term_judg =
+  fun cfk -> match cfk with
+    | Tcfk_virtual _ ->
+      empty
+    | Tcfk_concrete (_, e) ->
+      expression e << Dereference
+
+and modexp : Typedtree.module_expr -> term_judg =
+  fun mexp -> match mexp.mod_desc with
+    | Tmod_ident (pth, _) ->
+      path pth
+    | Tmod_structure s ->
+      structure s
+    | Tmod_functor (_, e) ->
+      modexp e << Delay
+    | Tmod_apply (f, p, _) ->
+      join [
+        modexp f << Dereference;
+        modexp p << Dereference;
+      ]
+    | Tmod_constraint (mexp, _, _, coe) ->
+      let rec coercion coe k = match coe with
+        | Tcoerce_none ->
+          k Return
+        | Tcoerce_structure _
+        | Tcoerce_functor _ ->
+          (* These coercions perform a shallow copy of the input module,
+             by creating a new module with fields obtained by accessing
+             the same fields in the input module. *)
+           k Dereference
+        | Tcoerce_primitive _ ->
+          (* This corresponds to 'external' declarations,
+             and the coercion ignores its argument *)
+          k Ignore
+        | Tcoerce_alias (_, pth, coe) ->
+          (* Alias coercions ignore their arguments, but they evaluate
+             their alias module 'pth' under another coercion. *)
+          coercion coe (fun m -> path pth << m)
+      in
+      coercion coe (fun m -> modexp mexp << m)
+    | Tmod_unpack (e, _) ->
+      expression e
+
+
+(* G |- pth : m *)
+and path : Path.t -> term_judg =
+  (*
+    ------------
+    x: m |- x: m
+
+    G |- A: m[Dereference]
+    -----------------------
+    G |- A.x: m
+
+    G1 |- A: m[Dereference]
+    G2 |- B: m[Dereference]
+    ------------------------ (as for term application)
+    G1 + G2 |- A(B): m
+  *)
+  fun pth -> match pth with
+    | Path.Pident x ->
+        single x
+    | Path.Pdot (t, _) ->
+        path t << Dereference
+    | Path.Papply (f, p) ->
+        join [
+          path f << Dereference;
+          path p << Dereference;
+        ]
+
+(* G |- struct ... end : m *)
+and structure : Typedtree.structure -> term_judg =
+  (*
+    G1, {x: _, x in vars(G1)} |- item1: G2 + ... + Gn in m
+    G2, {x: _, x in vars(G2)} |- item2: G3 + ... + Gn in m
+    ...
+    Gn, {x: _, x in vars(Gn)} |- itemn: [] in m
+    ---
+    (G1 + ... + Gn) - V |- struct item1 ... itemn end: m
+  *)
+  fun s m ->
+    List.fold_right (fun it env -> structure_item it m env)
+      s.str_items Env.empty
+
+(* G |- <structure item> : m -| G'
+   where G is an output and m, G' are inputs *)
+and structure_item : Typedtree.structure_item -> bind_judg =
+  fun s m env -> match s.str_desc with
+    | Tstr_eval (e, _) ->
+      (*
+        Ge |- e: m[Guard]
+        G |- items: m -| G'
+        ---------------------------------
+        Ge + G |- (e;; items): m -| G'
+
+        The expression `e` is treated in the same way as let _ = e
+      *)
+      let judg_e = expression e << Guard in
+      Env.join (judg_e m) env
+    | Tstr_value (rec_flag, bindings) ->
+      value_bindings rec_flag bindings m env
+    | Tstr_module {mb_id; mb_expr} ->
+      module_binding (mb_id, mb_expr) m env
+    | Tstr_recmodule mbs ->
+      let bindings = List.map (fun {mb_id; mb_expr} -> (mb_id, mb_expr)) mbs in
+      recursive_module_bindings bindings m env
+    | Tstr_primitive _ ->
+      env
+    | Tstr_type _ ->
+      (*
+        -------------------
+        G |- type t: m -| G
+      *)
+      env
+    | Tstr_typext {tyext_constructors = exts; _} ->
+      let ext_ids = List.map (fun {ext_id = id; _} -> id) exts in
+      Env.join
+        (list extension_constructor exts m)
+        (Env.remove_list ext_ids env)
+    | Tstr_exception {tyexn_constructor = ext; _} ->
+      Env.join
+        (extension_constructor ext m)
+        (Env.remove ext.ext_id env)
+    | Tstr_modtype _
+    | Tstr_class_type _
+    | Tstr_attribute _ ->
+      env
+    | Tstr_open od ->
+      open_declaration od m env
+    | Tstr_class classes ->
+        let class_ids =
+          let class_id ({ci_id_class = id; _}, _) = id in
+          List.map class_id classes in
+        let class_declaration ({ci_expr; _}, _) m =
+          Env.remove_list class_ids (class_expr ci_expr m) in
+        Env.join
+          (list class_declaration classes m)
+          (Env.remove_list class_ids env)
+    | Tstr_include { incl_mod = mexp; incl_type = mty; _ } ->
+      let included_ids = List.map Types.signature_item_id mty in
+      Env.join (modexp mexp m) (Env.remove_list included_ids env)
+
+(* G |- module M = E : m -| G *)
+and module_binding : (Ident.t option * Typedtree.module_expr) -> bind_judg =
+  fun (id, mexp) m env ->
+      (*
+        GE |- E: m[mM + Guard]
+        -------------------------------------
+        GE + G |- module M = E : m -| M:mM, G
+      *)
+      let judg_E, env =
+        match id with
+        | None -> modexp mexp << Guard, env
+        | Some id ->
+          let mM, env = Env.take id env in
+          let judg_E = modexp mexp << (Mode.join mM Guard) in
+          judg_E, env
+      in
+      Env.join (judg_E m) env
+
+and open_declaration : Typedtree.open_declaration -> bind_judg =
+  fun { open_expr = mexp; open_bound_items = sg; _ } m env ->
+      let judg_E = modexp mexp in
+      let bound_ids = List.map Types.signature_item_id sg in
+      Env.join (judg_E m) (Env.remove_list bound_ids env)
+
+and recursive_module_bindings
+  : (Ident.t option * Typedtree.module_expr) list -> bind_judg =
+  fun m_bindings m env ->
+    let mids = List.filter_map fst m_bindings in
+    let binding (mid, mexp) m =
+      let judg_E =
+        match mid with
+        | None -> modexp mexp << Guard
+        | Some mid ->
+          let mM = Env.find mid env in
+          modexp mexp << (Mode.join mM Guard)
+      in
+      Env.remove_list mids (judg_E m)
+    in
+    Env.join (list binding m_bindings m) (Env.remove_list mids env)
+
+and class_expr : Typedtree.class_expr -> term_judg =
+  fun ce -> match ce.cl_desc with
+    | Tcl_ident (pth, _, _) ->
+        path pth << Dereference
+    | Tcl_structure cs ->
+        class_structure cs
+    | Tcl_fun (_, _, args, ce, _) ->
+        let ids = List.map fst args in
+        remove_ids ids (class_expr ce << Delay)
+    | Tcl_apply (ce, args) ->
+        let arg (_label, eo) = option expression eo in
+        join [
+          class_expr ce << Dereference;
+          list arg args << Dereference;
+        ]
+    | Tcl_let (rec_flag, bindings, _, ce) ->
+      value_bindings rec_flag bindings >> class_expr ce
+    | Tcl_constraint (ce, _, _, _, _) ->
+        class_expr ce
+    | Tcl_open (_, ce) ->
+        class_expr ce
+
+and extension_constructor : Typedtree.extension_constructor -> term_judg =
+  fun ec -> match ec.ext_kind with
+    | Text_decl _ ->
+      empty
+    | Text_rebind (pth, _lid) ->
+      path pth
+
+(* G |- let (rec?) (pi = ei)^i : m -| G' *)
+and value_bindings : rec_flag -> Typedtree.value_binding list -> bind_judg =
+  fun rec_flag bindings mode bound_env ->
+    let all_bound_pats = List.map (fun vb -> vb.vb_pat) bindings in
+    let outer_env = remove_patlist all_bound_pats bound_env in
+    let bindings_env =
+      match rec_flag with
+      | Nonrecursive ->
+        (*
+           (Gi, pi:_ |- ei : m[mbody_i])^i   (pi : mbody_i -| D)^i
+           ------------------------------------------------------------
+           Sum(Gi) + (D - (pi)^i) |- let (pi=ei)^i : m -| D
+        *)
+          let binding_env {vb_pat; vb_expr; _} m =
+            let m' = Mode.compose m (pattern vb_pat bound_env) in
+            remove_pat vb_pat (expression vb_expr m') in
+          list binding_env bindings mode
+      | Recursive ->
+        (*
+           (Gi, (xj : mdef_ij)^j |- ei : m[mbody_i])^i   (xi : mbody_i -| D)^i
+           G'i = Gi + mdef_ij[G'j]
+           -------------------------------------------------------------------
+           Sum(G'i) + (D - (pi)^i) |- let rec (xi=ei)^i : m -| D
+
+           The (mdef_ij)^i,j are a family of modes over two indices:
+           mdef_ij represents the mode of use, within e_i the definition of x_i,
+           of the mutually-recursive variable x_j.
+
+           The (G'i)^i are defined from the (Gi)^i as a family of equations,
+           whose smallest solution is computed as a least fixpoint.
+
+           The (Gi)^i are the "immediate" dependencies of each (ei)^i
+           on the outer context (excluding the mutually-defined
+           variables).
+           The (G'i)^i contain the "transitive" dependencies as well:
+           if ei depends on xj, then the dependencies of G'i of xi
+           must contain the dependencies of G'j, composed by
+           the mode mdef_ij of use of xj in ei.
+
+           For example, consider:
+
+             let rec z =
+               let rec x = ref y
+               and y = ref z
+               in f x
+
+           this definition should be rejected as the body [f x]
+           dereferences [x], which can be used to access the
+           yet-unitialized value [z]. This requires realizing that [x]
+           depends on [z] through [y], which requires the transitive
+           closure computation.
+
+           An earlier version of our check would take only the (Gi)^i
+           instead of the (G'i)^i, which is incorrect and would accept
+           the example above.
+        *)
+          (* [binding_env] takes a binding (x_i = e_i)
+             and computes (Gi, (mdef_ij)^j). *)
+          let binding_env {vb_pat = x_i; vb_expr = e_i; _} =
+            let mbody_i = pattern x_i bound_env in
+            (* Gi, (x_j:mdef_ij)^j  *)
+            let rhs_env_i = expression e_i (Mode.compose mode mbody_i) in
+            (* (mdef_ij)^j (for a fixed i) *)
+            let mutual_modes =
+              let mdef_ij {vb_pat = x_j; _} = pattern x_j rhs_env_i in
+              List.map mdef_ij bindings in
+            (* Gi *)
+            let env_i = remove_patlist all_bound_pats rhs_env_i in
+            (* (Gi, (mdef_ij)^j) *)
+            (env_i, mutual_modes) in
+          let env, mdef =
+            List.split (List.map binding_env bindings) in
+          let rec transitive_closure env =
+            let transitive_deps env_i mdef_i =
+              (* Gi, (mdef_ij)^j => Gi + Sum_j mdef_ij[Gj] *)
+              Env.join env_i
+                (Env.join_list (List.map2 Env.compose mdef_i env)) in
+            let env' = List.map2 transitive_deps env mdef in
+            if List.for_all2 Env.equal env env'
+            then env'
+            else transitive_closure env'
+          in
+          let env'_i = transitive_closure env in
+          Env.join_list env'_i
+    in Env.join bindings_env outer_env
+
+(* G; m' |- (p -> e) : m
+   with outputs G, m' and input m
+
+   m' is the mode under which the scrutinee of p
+   (the value matched against p) is placed.
+*)
+and case
+    : 'k . 'k Typedtree.case -> mode -> Env.t * mode
+  = fun { Typedtree.c_lhs; c_guard; c_rhs } ->
+    (*
+       Ge |- e : m    Gg |- g : m[Dereference]
+       G := Ge+Gg     p : mp -| G
+       ----------------------------------------
+       G - p; m[mp] |- (p (when g)? -> e) : m
+    *)
+    let judg = join [
+        option expression c_guard << Dereference;
+        expression c_rhs;
+      ] in
+    (fun m ->
+       let env = judg m in
+       (remove_pat c_lhs env), Mode.compose m (pattern c_lhs env))
+
+(* p : m -| G
+   with output m and input G
+
+   m is the mode under which the scrutinee of p is placed.
+*)
+and pattern : type k . k general_pattern -> Env.t -> mode = fun pat env ->
+  (*
+    mp := | Dereference if p is destructuring
+          | Guard       otherwise
+    me := sum{G(x), x in vars(p)}
+    --------------------------------------------
+    p : (mp + me) -| G
+  *)
+  let m_pat = if is_destructuring_pattern pat
+              then Dereference
+              else Guard
+  in
+  let m_env =
+    pat_bound_idents pat
+    |> List.map (fun id -> Env.find id env)
+    |> List.fold_left Mode.join Ignore
+  in
+  Mode.join m_pat m_env
+
+and is_destructuring_pattern : type k . k general_pattern -> bool =
+  fun pat -> match pat.pat_desc with
+    | Tpat_any -> false
+    | Tpat_var (_, _) -> false
+    | Tpat_alias (pat, _, _) -> is_destructuring_pattern pat
+    | Tpat_constant _ -> true
+    | Tpat_tuple _ -> true
+    | Tpat_construct (_, _, _) -> true
+    | Tpat_variant _ -> true
+    | Tpat_record (_, _) -> true
+    | Tpat_array _ -> true
+    | Tpat_lazy _ -> true
+    | Tpat_value pat -> is_destructuring_pattern (pat :> pattern)
+    | Tpat_exception _ -> false
+    | Tpat_or (l,r,_) ->
+        is_destructuring_pattern l || is_destructuring_pattern r
+
+let is_valid_recursive_expression idlist expr =
+  let ty = expression expr Return in
+  match Env.unguarded ty idlist, Env.dependent ty idlist,
+        classify_expression expr with
+  | _ :: _, _, _ (* The expression inspects rec-bound variables *)
+  | [], _ :: _, Dynamic -> (* The expression depends on rec-bound variables
+                              and its size is unknown *)
+      false
+  | [], _, Static (* The expression has known size *)
+  | [], [], Dynamic -> (* The expression has unknown size,
+                          but does not depend on rec-bound variables *)
+      true
+
+(* A class declaration may contain let-bindings. If they are recursive,
+   their validity will already be checked by [is_valid_recursive_expression]
+   during type-checking. This function here prevents a different kind of
+   invalid recursion, which is the unsafe creations of objects of this class
+   in the let-binding. For example,
+   {|class a = let x = new a in object ... end|}
+   is forbidden, but
+   {|class a = let x () = new a in object ... end|}
+   is allowed.
+*)
+let is_valid_class_expr idlist ce =
+  let rec class_expr : mode -> Typedtree.class_expr -> Env.t =
+    fun mode ce -> match ce.cl_desc with
+      | Tcl_ident (_, _, _) ->
+        (*
+          ----------
+          [] |- a: m
+        *)
+        Env.empty
+      | Tcl_structure _ ->
+        (*
+          -----------------------
+          [] |- struct ... end: m
+        *)
+        Env.empty
+      | Tcl_fun (_, _, _, _, _) -> Env.empty
+        (*
+          ---------------------------
+          [] |- fun x1 ... xn -> C: m
+        *)
+      | Tcl_apply (_, _) -> Env.empty
+      | Tcl_let (rec_flag, bindings, _, ce) ->
+        value_bindings rec_flag bindings mode (class_expr mode ce)
+      | Tcl_constraint (ce, _, _, _, _) ->
+        class_expr mode ce
+      | Tcl_open (_, ce) ->
+        class_expr mode ce
+  in
+  match Env.unguarded (class_expr Return ce) idlist with
+  | [] -> true
+  | _ :: _ -> false
diff --git a/upstream/ocaml_411/typing/rec_check.mli b/upstream/ocaml_411/typing/rec_check.mli
new file mode 100644
index 0000000..aa5c1ca
--- /dev/null
+++ b/upstream/ocaml_411/typing/rec_check.mli
@@ -0,0 +1,19 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*               Jeremy Yallop, University of Cambridge                   *)
+(*                                                                        *)
+(*   Copyright 2017 Jeremy Yallop                                         *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+exception Illegal_expr
+
+val is_valid_recursive_expression : Ident.t list -> Typedtree.expression -> bool
+
+val is_valid_class_expr : Ident.t list -> Typedtree.class_expr -> bool
diff --git a/upstream/ocaml_411/typing/stypes.ml b/upstream/ocaml_411/typing/stypes.ml
new file mode 100644
index 0000000..dfbcc99
--- /dev/null
+++ b/upstream/ocaml_411/typing/stypes.ml
@@ -0,0 +1,210 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Damien Doligez, projet Moscova, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2003 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Recording and dumping (partial) type information *)
+
+(*
+  We record all types in a list as they are created.
+  This means we can dump type information even if type inference fails,
+  which is extremely important, since type information is most
+  interesting in case of errors.
+*)
+
+open Annot;;
+open Lexing;;
+open Location;;
+open Typedtree;;
+
+let output_int oc i = output_string oc (Int.to_string i)
+
+type annotation =
+  | Ti_pat : 'k pattern_category * 'k general_pattern -> annotation
+  | Ti_expr  of expression
+  | Ti_class of class_expr
+  | Ti_mod   of module_expr
+  | An_call of Location.t * Annot.call
+  | An_ident of Location.t * string * Annot.ident
+;;
+
+let get_location ti =
+  match ti with
+  | Ti_pat (_, p)   -> p.pat_loc
+  | Ti_expr e  -> e.exp_loc
+  | Ti_class c -> c.cl_loc
+  | Ti_mod m   -> m.mod_loc
+  | An_call (l, _k) -> l
+  | An_ident (l, _s, _k) -> l
+;;
+
+let annotations = ref ([] : annotation list);;
+let phrases = ref ([] : Location.t list);;
+
+let record ti =
+  if !Clflags.annotations && not (get_location ti).Location.loc_ghost then
+    annotations := ti :: !annotations
+;;
+
+let record_phrase loc =
+  if !Clflags.annotations then phrases := loc :: !phrases;
+;;
+
+(* comparison order:
+   the intervals are sorted by order of increasing upper bound
+   same upper bound -> sorted by decreasing lower bound
+*)
+let cmp_loc_inner_first loc1 loc2 =
+  match compare loc1.loc_end.pos_cnum loc2.loc_end.pos_cnum with
+  | 0 -> compare loc2.loc_start.pos_cnum loc1.loc_start.pos_cnum
+  | x -> x
+;;
+let cmp_ti_inner_first ti1 ti2 =
+  cmp_loc_inner_first (get_location ti1) (get_location ti2)
+;;
+
+let print_position pp pos =
+  if pos = dummy_pos then
+    output_string pp "--"
+  else begin
+    output_char pp '\"';
+    output_string pp (String.escaped pos.pos_fname);
+    output_string pp "\" ";
+    output_int pp pos.pos_lnum;
+    output_char pp ' ';
+    output_int pp pos.pos_bol;
+    output_char pp ' ';
+    output_int pp pos.pos_cnum;
+  end
+;;
+
+let print_location pp loc =
+  print_position pp loc.loc_start;
+  output_char pp ' ';
+  print_position pp loc.loc_end;
+;;
+
+let sort_filter_phrases () =
+  let ph = List.sort (fun x y -> cmp_loc_inner_first y x) !phrases in
+  let rec loop accu cur l =
+    match l with
+    | [] -> accu
+    | loc :: t ->
+       if cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum
+          && cur.loc_end.pos_cnum >= loc.loc_end.pos_cnum
+       then loop accu cur t
+       else loop (loc :: accu) loc t
+  in
+  phrases := loop [] Location.none ph;
+;;
+
+let rec printtyp_reset_maybe loc =
+  match !phrases with
+  | cur :: t when cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum ->
+     Printtyp.reset ();
+     phrases := t;
+     printtyp_reset_maybe loc;
+  | _ -> ()
+;;
+
+let call_kind_string k =
+  match k with
+  | Tail -> "tail"
+  | Stack -> "stack"
+  | Inline -> "inline"
+;;
+
+let print_ident_annot pp str k =
+  match k with
+  | Idef l ->
+      output_string pp "def ";
+      output_string pp str;
+      output_char pp ' ';
+      print_location pp l;
+      output_char pp '\n'
+  | Iref_internal l ->
+      output_string pp "int_ref ";
+      output_string pp str;
+      output_char pp ' ';
+      print_location pp l;
+      output_char pp '\n'
+  | Iref_external ->
+      output_string pp "ext_ref ";
+      output_string pp str;
+      output_char pp '\n'
+;;
+
+(* The format of the annotation file is documented in emacs/caml-types.el. *)
+
+let print_info pp prev_loc ti =
+  match ti with
+  | Ti_class _ | Ti_mod _ -> prev_loc
+  | Ti_pat  (_, {pat_loc = loc; pat_type = typ; pat_env = env})
+  | Ti_expr     {exp_loc = loc; exp_type = typ; exp_env = env} ->
+      if loc <> prev_loc then begin
+        print_location pp loc;
+        output_char pp '\n'
+      end;
+      output_string pp "type(\n";
+      printtyp_reset_maybe loc;
+      Printtyp.mark_loops typ;
+      Format.pp_print_string Format.str_formatter "  ";
+      Printtyp.wrap_printing_env ~error:false env
+                       (fun () -> Printtyp.type_sch Format.str_formatter typ);
+      Format.pp_print_newline Format.str_formatter ();
+      let s = Format.flush_str_formatter () in
+      output_string pp s;
+      output_string pp ")\n";
+      loc
+  | An_call (loc, k) ->
+      if loc <> prev_loc then begin
+        print_location pp loc;
+        output_char pp '\n'
+      end;
+      output_string pp "call(\n  ";
+      output_string pp (call_kind_string k);
+      output_string pp "\n)\n";
+      loc
+  | An_ident (loc, str, k) ->
+      if loc <> prev_loc then begin
+        print_location pp loc;
+        output_char pp '\n'
+      end;
+      output_string pp "ident(\n  ";
+      print_ident_annot pp str k;
+      output_string pp ")\n";
+      loc
+;;
+
+let get_info () =
+  let info = List.fast_sort cmp_ti_inner_first !annotations in
+  annotations := [];
+  info
+;;
+
+let dump filename =
+  if !Clflags.annotations then begin
+    let do_dump _temp_filename pp =
+      let info = get_info () in
+      sort_filter_phrases ();
+      ignore (List.fold_left (print_info pp) Location.none info) in
+    begin match filename with
+    | None -> do_dump "" stdout
+    | Some filename ->
+        Misc.output_to_file_via_temporary ~mode:[Open_text] filename do_dump
+    end;
+    phrases := [];
+  end else begin
+    annotations := [];
+  end;
+;;
diff --git a/upstream/ocaml_411/typing/stypes.mli b/upstream/ocaml_411/typing/stypes.mli
new file mode 100644
index 0000000..fda575f
--- /dev/null
+++ b/upstream/ocaml_411/typing/stypes.mli
@@ -0,0 +1,36 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Damien Doligez, projet Moscova, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2003 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Recording and dumping (partial) type information *)
+
+(* Clflags.save_types must be true *)
+
+open Typedtree;;
+
+type annotation =
+  | Ti_pat : 'k pattern_category * 'k general_pattern -> annotation
+  | Ti_expr  of expression
+  | Ti_class of class_expr
+  | Ti_mod   of module_expr
+  | An_call of Location.t * Annot.call
+  | An_ident of Location.t * string * Annot.ident
+;;
+
+val record : annotation -> unit;;
+val record_phrase : Location.t -> unit;;
+val dump : string option -> unit;;
+
+val get_location : annotation -> Location.t;;
+val get_info : unit -> annotation list;;
diff --git a/upstream/ocaml_411/typing/subst.ml b/upstream/ocaml_411/typing/subst.ml
new file mode 100644
index 0000000..9d209b2
--- /dev/null
+++ b/upstream/ocaml_411/typing/subst.ml
@@ -0,0 +1,555 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Substitutions *)
+
+open Misc
+open Path
+open Types
+open Btype
+
+type type_replacement =
+  | Path of Path.t
+  | Type_function of { params : type_expr list; body : type_expr }
+
+type t =
+  { types: type_replacement Path.Map.t;
+    modules: Path.t Path.Map.t;
+    modtypes: module_type Ident.Map.t;
+    for_saving: bool;
+  }
+
+let identity =
+  { types = Path.Map.empty;
+    modules = Path.Map.empty;
+    modtypes = Ident.Map.empty;
+    for_saving = false;
+  }
+
+let add_type_path id p s = { s with types = Path.Map.add id (Path p) s.types }
+let add_type id p s = add_type_path (Pident id) p s
+
+let add_type_function id ~params ~body s =
+  { s with types = Path.Map.add id (Type_function { params; body }) s.types }
+
+let add_module_path id p s = { s with modules = Path.Map.add id p s.modules }
+let add_module id p s = add_module_path (Pident id) p s
+
+let add_modtype id ty s = { s with modtypes = Ident.Map.add id ty s.modtypes }
+
+let for_saving s = { s with for_saving = true }
+
+let loc s x =
+  if s.for_saving && not !Clflags.keep_locs then Location.none else x
+
+let remove_loc =
+  let open Ast_mapper in
+  {default_mapper with location = (fun _this _loc -> Location.none)}
+
+let is_not_doc = function
+  | {Parsetree.attr_name = {Location.txt = "ocaml.doc"}; _} -> false
+  | {Parsetree.attr_name = {Location.txt = "ocaml.text"}; _} -> false
+  | {Parsetree.attr_name = {Location.txt = "doc"}; _} -> false
+  | {Parsetree.attr_name = {Location.txt = "text"}; _} -> false
+  | _ -> true
+
+let attrs s x =
+  let x =
+    if s.for_saving && not !Clflags.keep_docs then
+      List.filter is_not_doc x
+    else x
+  in
+    if s.for_saving && not !Clflags.keep_locs
+    then remove_loc.Ast_mapper.attributes remove_loc x
+    else x
+
+let rec module_path s path =
+  try Path.Map.find path s.modules
+  with Not_found ->
+    match path with
+    | Pident _ -> path
+    | Pdot(p, n) ->
+       Pdot(module_path s p, n)
+    | Papply(p1, p2) ->
+       Papply(module_path s p1, module_path s p2)
+
+let modtype_path s = function
+    Pident id as p ->
+      begin try
+        match Ident.Map.find id s.modtypes with
+          | Mty_ident p -> p
+          | _ -> fatal_error "Subst.modtype_path"
+      with Not_found -> p end
+  | Pdot(p, n) ->
+      Pdot(module_path s p, n)
+  | Papply _ ->
+      fatal_error "Subst.modtype_path"
+
+let type_path s path =
+  match Path.Map.find path s.types with
+  | Path p -> p
+  | Type_function _ -> assert false
+  | exception Not_found ->
+     match path with
+     | Pident _ -> path
+     | Pdot(p, n) ->
+        Pdot(module_path s p, n)
+     | Papply _ ->
+        fatal_error "Subst.type_path"
+
+let type_path s p =
+  match Path.constructor_typath p with
+  | Regular p -> type_path s p
+  | Cstr (ty_path, cstr) -> Pdot(type_path s ty_path, cstr)
+  | LocalExt _ -> type_path s p
+  | Ext (p, cstr) -> Pdot(module_path s p, cstr)
+
+let to_subst_by_type_function s p =
+  match Path.Map.find p s.types with
+  | Path _ -> false
+  | Type_function _ -> true
+  | exception Not_found -> false
+
+(* Special type ids for saved signatures *)
+
+let new_id = ref (-1)
+let reset_for_saving () = new_id := -1
+
+let newpersty desc =
+  decr new_id;
+  { desc; level = generic_level; scope = Btype.lowest_level; id = !new_id }
+
+(* ensure that all occurrences of 'Tvar None' are physically shared *)
+let tvar_none = Tvar None
+let tunivar_none = Tunivar None
+let norm = function
+  | Tvar None -> tvar_none
+  | Tunivar None -> tunivar_none
+  | d -> d
+
+let ctype_apply_env_empty = ref (fun _ -> assert false)
+
+(* Similar to [Ctype.nondep_type_rec]. *)
+let rec typexp copy_scope s ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tvar _ | Tunivar _ as desc ->
+      if s.for_saving || ty.id < 0 then
+        let ty' =
+          if s.for_saving then newpersty (norm desc)
+          else newty2 ty.level desc
+        in
+        For_copy.save_desc copy_scope ty desc;
+        ty.desc <- Tsubst ty';
+        ty'
+      else ty
+  | Tsubst ty ->
+      ty
+  | Tfield (m, k, _t1, _t2) when not s.for_saving && m = dummy_method
+      && field_kind_repr k <> Fabsent && (repr ty).level < generic_level ->
+      (* do not copy the type of self when it is not generalized *)
+      ty
+(* cannot do it, since it would omit substitution
+  | Tvariant row when not (static_row row) ->
+      ty
+*)
+  | _ ->
+    let desc = ty.desc in
+    For_copy.save_desc copy_scope ty desc;
+    let tm = row_of_type ty in
+    let has_fixed_row =
+      not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm in
+    (* Make a stub *)
+    let ty' = if s.for_saving then newpersty (Tvar None) else newgenvar () in
+    ty'.scope <- ty.scope;
+    ty.desc <- Tsubst ty';
+    ty'.desc <-
+      begin if has_fixed_row then
+        match tm.desc with (* PR#7348 *)
+          Tconstr (Pdot(m,i), tl, _abbrev) ->
+            let i' = String.sub i 0 (String.length i - 4) in
+            Tconstr(type_path s (Pdot(m,i')), tl, ref Mnil)
+        | _ -> assert false
+      else match desc with
+      | Tconstr (p, args, _abbrev) ->
+         let args = List.map (typexp copy_scope s) args in
+         begin match Path.Map.find p s.types with
+         | exception Not_found -> Tconstr(type_path s p, args, ref Mnil)
+         | Path _ -> Tconstr(type_path s p, args, ref Mnil)
+         | Type_function { params; body } ->
+            Tlink (!ctype_apply_env_empty params body args)
+         end
+      | Tpackage(p, n, tl) ->
+          Tpackage(modtype_path s p, n, List.map (typexp copy_scope s) tl)
+      | Tobject (t1, name) ->
+          let t1' = typexp copy_scope s t1 in
+          let name' =
+            match !name with
+            | None -> None
+            | Some (p, tl) ->
+                if to_subst_by_type_function s p
+                then None
+                else Some (type_path s p, List.map (typexp copy_scope s) tl)
+          in
+          Tobject (t1', ref name')
+      | Tvariant row ->
+          let row = row_repr row in
+          let more = repr row.row_more in
+          (* We must substitute in a subtle way *)
+          (* Tsubst takes a tuple containing the row var and the variant *)
+          begin match more.desc with
+            Tsubst {desc = Ttuple [_;ty2]} ->
+              (* This variant type has been already copied *)
+              ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *)
+              Tlink ty2
+          | _ ->
+              let dup =
+                s.for_saving || more.level = generic_level || static_row row ||
+                match more.desc with Tconstr _ -> true | _ -> false in
+              (* Various cases for the row variable *)
+              let more' =
+                match more.desc with
+                  Tsubst ty -> ty
+                | Tconstr _ | Tnil -> typexp copy_scope s more
+                | Tunivar _ | Tvar _ ->
+                    For_copy.save_desc copy_scope more more.desc;
+                    if s.for_saving then newpersty (norm more.desc) else
+                    if dup && is_Tvar more then newgenty more.desc else more
+                | _ -> assert false
+              in
+              (* Register new type first for recursion *)
+              more.desc <- Tsubst(newgenty(Ttuple[more';ty']));
+              (* Return a new copy *)
+              let row =
+                copy_row (typexp copy_scope s) true row (not dup) more' in
+              match row.row_name with
+              | Some (p, tl) ->
+                 Tvariant {row with row_name =
+                                      if to_subst_by_type_function s p
+                                      then None
+                                      else Some (type_path s p, tl)}
+              | None ->
+                  Tvariant row
+          end
+      | Tfield(_label, kind, _t1, t2) when field_kind_repr kind = Fabsent ->
+          Tlink (typexp copy_scope s t2)
+      | _ -> copy_type_desc (typexp copy_scope s) desc
+      end;
+    ty'
+
+(*
+   Always make a copy of the type. If this is not done, type levels
+   might not be correct.
+*)
+let type_expr s ty =
+  For_copy.with_scope (fun copy_scope -> typexp copy_scope s ty)
+
+let label_declaration copy_scope s l =
+  {
+    ld_id = l.ld_id;
+    ld_mutable = l.ld_mutable;
+    ld_type = typexp copy_scope s l.ld_type;
+    ld_loc = loc s l.ld_loc;
+    ld_attributes = attrs s l.ld_attributes;
+    ld_uid = l.ld_uid;
+  }
+
+let constructor_arguments copy_scope s = function
+  | Cstr_tuple l ->
+      Cstr_tuple (List.map (typexp copy_scope s) l)
+  | Cstr_record l ->
+      Cstr_record (List.map (label_declaration copy_scope s) l)
+
+let constructor_declaration copy_scope s c =
+  {
+    cd_id = c.cd_id;
+    cd_args = constructor_arguments copy_scope s c.cd_args;
+    cd_res = Option.map (typexp copy_scope s) c.cd_res;
+    cd_loc = loc s c.cd_loc;
+    cd_attributes = attrs s c.cd_attributes;
+    cd_uid = c.cd_uid;
+  }
+
+let type_declaration' copy_scope s decl =
+  { type_params = List.map (typexp copy_scope s) decl.type_params;
+    type_arity = decl.type_arity;
+    type_kind =
+      begin match decl.type_kind with
+        Type_abstract -> Type_abstract
+      | Type_variant cstrs ->
+          Type_variant (List.map (constructor_declaration copy_scope s) cstrs)
+      | Type_record(lbls, rep) ->
+          Type_record (List.map (label_declaration copy_scope s) lbls, rep)
+      | Type_open -> Type_open
+      end;
+    type_manifest =
+      begin
+        match decl.type_manifest with
+          None -> None
+        | Some ty -> Some(typexp copy_scope s ty)
+      end;
+    type_private = decl.type_private;
+    type_variance = decl.type_variance;
+    type_separability = decl.type_separability;
+    type_is_newtype = false;
+    type_expansion_scope = Btype.lowest_level;
+    type_loc = loc s decl.type_loc;
+    type_attributes = attrs s decl.type_attributes;
+    type_immediate = decl.type_immediate;
+    type_unboxed = decl.type_unboxed;
+    type_uid = decl.type_uid;
+  }
+
+let type_declaration s decl =
+  For_copy.with_scope (fun copy_scope -> type_declaration' copy_scope s decl)
+
+let class_signature copy_scope s sign =
+  { csig_self = typexp copy_scope s sign.csig_self;
+    csig_vars =
+      Vars.map
+        (function (m, v, t) -> (m, v, typexp copy_scope s t)) sign.csig_vars;
+    csig_concr = sign.csig_concr;
+    csig_inher =
+      List.map
+        (fun (p, tl) -> (type_path s p, List.map (typexp copy_scope s) tl))
+        sign.csig_inher;
+  }
+
+let rec class_type copy_scope s = function
+  | Cty_constr (p, tyl, cty) ->
+      let p' = type_path s p in
+      let tyl' = List.map (typexp copy_scope s) tyl in
+      let cty' = class_type copy_scope s cty in
+      Cty_constr (p', tyl', cty')
+  | Cty_signature sign ->
+      Cty_signature (class_signature copy_scope s sign)
+  | Cty_arrow (l, ty, cty) ->
+      Cty_arrow (l, typexp copy_scope s ty, class_type copy_scope s cty)
+
+let class_declaration' copy_scope s decl =
+  { cty_params = List.map (typexp copy_scope s) decl.cty_params;
+    cty_variance = decl.cty_variance;
+    cty_type = class_type copy_scope s decl.cty_type;
+    cty_path = type_path s decl.cty_path;
+    cty_new =
+      begin match decl.cty_new with
+      | None    -> None
+      | Some ty -> Some (typexp copy_scope s ty)
+      end;
+    cty_loc = loc s decl.cty_loc;
+    cty_attributes = attrs s decl.cty_attributes;
+    cty_uid = decl.cty_uid;
+  }
+
+let class_declaration s decl =
+  For_copy.with_scope (fun copy_scope -> class_declaration' copy_scope s decl)
+
+let cltype_declaration' copy_scope s decl =
+  { clty_params = List.map (typexp copy_scope s) decl.clty_params;
+    clty_variance = decl.clty_variance;
+    clty_type = class_type copy_scope s decl.clty_type;
+    clty_path = type_path s decl.clty_path;
+    clty_loc = loc s decl.clty_loc;
+    clty_attributes = attrs s decl.clty_attributes;
+    clty_uid = decl.clty_uid;
+  }
+
+let cltype_declaration s decl =
+  For_copy.with_scope (fun copy_scope -> cltype_declaration' copy_scope s decl)
+
+let class_type s cty =
+  For_copy.with_scope (fun copy_scope -> class_type copy_scope s cty)
+
+let value_description' copy_scope s descr =
+  { val_type = typexp copy_scope s descr.val_type;
+    val_kind = descr.val_kind;
+    val_loc = loc s descr.val_loc;
+    val_attributes = attrs s descr.val_attributes;
+    val_uid = descr.val_uid;
+   }
+
+let value_description s descr =
+  For_copy.with_scope (fun copy_scope -> value_description' copy_scope s descr)
+
+let extension_constructor' copy_scope s ext =
+  { ext_type_path = type_path s ext.ext_type_path;
+    ext_type_params = List.map (typexp copy_scope s) ext.ext_type_params;
+    ext_args = constructor_arguments copy_scope s ext.ext_args;
+    ext_ret_type = Option.map (typexp copy_scope s) ext.ext_ret_type;
+    ext_private = ext.ext_private;
+    ext_attributes = attrs s ext.ext_attributes;
+    ext_loc = if s.for_saving then Location.none else ext.ext_loc;
+    ext_uid = ext.ext_uid;
+  }
+
+let extension_constructor s ext =
+  For_copy.with_scope
+    (fun copy_scope -> extension_constructor' copy_scope s ext)
+
+type scoping =
+  | Keep
+  | Make_local
+  | Rescope of int
+
+let rename_bound_idents scoping s sg =
+  let rename =
+    let open Ident in
+    match scoping with
+    | Keep -> (fun id -> create_scoped ~scope:(scope id) (name id))
+    | Make_local -> Ident.rename
+    | Rescope scope -> (fun id -> create_scoped ~scope (name id))
+  in
+  let rec rename_bound_idents s sg = function
+    | [] -> sg, s
+    | Sig_type(id, td, rs, vis) :: rest ->
+        let id' = rename id in
+        rename_bound_idents
+          (add_type id (Pident id') s)
+          (Sig_type(id', td, rs, vis) :: sg)
+          rest
+    | Sig_module(id, pres, md, rs, vis) :: rest ->
+        let id' = rename id in
+        rename_bound_idents
+          (add_module id (Pident id') s)
+          (Sig_module (id', pres, md, rs, vis) :: sg)
+          rest
+    | Sig_modtype(id, mtd, vis) :: rest ->
+        let id' = rename id in
+        rename_bound_idents
+          (add_modtype id (Mty_ident(Pident id')) s)
+          (Sig_modtype(id', mtd, vis) :: sg)
+          rest
+    | Sig_class(id, cd, rs, vis) :: rest ->
+        (* cheat and pretend they are types cf. PR#6650 *)
+        let id' = rename id in
+        rename_bound_idents
+          (add_type id (Pident id') s)
+          (Sig_class(id', cd, rs, vis) :: sg)
+          rest
+    | Sig_class_type(id, ctd, rs, vis) :: rest ->
+        (* cheat and pretend they are types cf. PR#6650 *)
+        let id' = rename id in
+        rename_bound_idents
+          (add_type id (Pident id') s)
+          (Sig_class_type(id', ctd, rs, vis) :: sg)
+          rest
+    | Sig_value(id, vd, vis) :: rest ->
+        (* scope doesn't matter for value identifiers. *)
+        let id' = Ident.rename id in
+        rename_bound_idents s (Sig_value(id', vd, vis) :: sg) rest
+    | Sig_typext(id, ec, es, vis) :: rest ->
+        let id' = rename id in
+        rename_bound_idents s (Sig_typext(id',ec,es,vis) :: sg) rest
+  in
+  rename_bound_idents s [] sg
+
+let rec modtype scoping s = function
+    Mty_ident p as mty ->
+      begin match p with
+        Pident id ->
+          begin try Ident.Map.find id s.modtypes with Not_found -> mty end
+      | Pdot(p, n) ->
+          Mty_ident(Pdot(module_path s p, n))
+      | Papply _ ->
+          fatal_error "Subst.modtype"
+      end
+  | Mty_signature sg ->
+      Mty_signature(signature scoping s sg)
+  | Mty_functor(Unit, res) ->
+      Mty_functor(Unit, modtype scoping s res)
+  | Mty_functor(Named (None, arg), res) ->
+      Mty_functor(Named (None, (modtype scoping s) arg), modtype scoping s res)
+  | Mty_functor(Named (Some id, arg), res) ->
+      let id' = Ident.rename id in
+      Mty_functor(Named (Some id', (modtype scoping s) arg),
+                  modtype scoping (add_module id (Pident id') s) res)
+  | Mty_alias p ->
+      Mty_alias (module_path s p)
+
+and signature scoping s sg =
+  (* Components of signature may be mutually recursive (e.g. type declarations
+     or class and type declarations), so first build global renaming
+     substitution... *)
+  let (sg', s') = rename_bound_idents scoping s sg in
+  (* ... then apply it to each signature component in turn *)
+  For_copy.with_scope (fun copy_scope ->
+    List.rev_map (signature_item' copy_scope scoping s') sg'
+  )
+
+
+and signature_item' copy_scope scoping s comp =
+  match comp with
+    Sig_value(id, d, vis) ->
+      Sig_value(id, value_description' copy_scope s d, vis)
+  | Sig_type(id, d, rs, vis) ->
+      Sig_type(id, type_declaration' copy_scope s d, rs, vis)
+  | Sig_typext(id, ext, es, vis) ->
+      Sig_typext(id, extension_constructor' copy_scope s ext, es, vis)
+  | Sig_module(id, pres, d, rs, vis) ->
+      Sig_module(id, pres, module_declaration scoping s d, rs, vis)
+  | Sig_modtype(id, d, vis) ->
+      Sig_modtype(id, modtype_declaration scoping s d, vis)
+  | Sig_class(id, d, rs, vis) ->
+      Sig_class(id, class_declaration' copy_scope s d, rs, vis)
+  | Sig_class_type(id, d, rs, vis) ->
+      Sig_class_type(id, cltype_declaration' copy_scope s d, rs, vis)
+
+and signature_item scoping s comp =
+  For_copy.with_scope
+    (fun copy_scope -> signature_item' copy_scope scoping s comp)
+
+and module_declaration scoping s decl =
+  {
+    md_type = modtype scoping s decl.md_type;
+    md_attributes = attrs s decl.md_attributes;
+    md_loc = loc s decl.md_loc;
+    md_uid = decl.md_uid;
+  }
+
+and modtype_declaration scoping s decl  =
+  {
+    mtd_type = Option.map (modtype scoping s) decl.mtd_type;
+    mtd_attributes = attrs s decl.mtd_attributes;
+    mtd_loc = loc s decl.mtd_loc;
+    mtd_uid = decl.mtd_uid;
+  }
+
+
+(* For every binding k |-> d of m1, add k |-> f d to m2
+   and return resulting merged map. *)
+
+let merge_tbls f m1 m2 =
+  Ident.Map.fold (fun k d accu -> Ident.Map.add k (f d) accu) m1 m2
+
+let merge_path_maps f m1 m2 =
+  Path.Map.fold (fun k d accu -> Path.Map.add k (f d) accu) m1 m2
+
+let type_replacement s = function
+  | Path p -> Path (type_path s p)
+  | Type_function { params; body } ->
+    For_copy.with_scope (fun copy_scope ->
+     let params = List.map (typexp copy_scope s) params in
+     let body = typexp copy_scope s body in
+     Type_function { params; body })
+
+(* Composition of substitutions:
+     apply (compose s1 s2) x = apply s2 (apply s1 x) *)
+
+let compose s1 s2 =
+  { types = merge_path_maps (type_replacement s2) s1.types s2.types;
+    modules = merge_path_maps (module_path s2) s1.modules s2.modules;
+    modtypes = merge_tbls (modtype Keep s2) s1.modtypes s2.modtypes;
+    for_saving = s1.for_saving || s2.for_saving;
+  }
diff --git a/upstream/ocaml_411/typing/subst.mli b/upstream/ocaml_411/typing/subst.mli
new file mode 100644
index 0000000..67c0153
--- /dev/null
+++ b/upstream/ocaml_411/typing/subst.mli
@@ -0,0 +1,86 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Substitutions *)
+
+open Types
+
+type t
+
+(*
+   Substitutions are used to translate a type from one context to
+   another.  This requires substituting paths for identifiers, and
+   possibly also lowering the level of non-generic variables so that
+   they are inferior to the maximum level of the new context.
+
+   Substitutions can also be used to create a "clean" copy of a type.
+   Indeed, non-variable node of a type are duplicated, with their
+   levels set to generic level.  That way, the resulting type is
+   well-formed (decreasing levels), even if the original one was not.
+*)
+
+val identity: t
+
+val add_type: Ident.t -> Path.t -> t -> t
+val add_type_path: Path.t -> Path.t -> t -> t
+val add_type_function:
+  Path.t -> params:type_expr list -> body:type_expr -> t -> t
+val add_module: Ident.t -> Path.t -> t -> t
+val add_module_path: Path.t -> Path.t -> t -> t
+val add_modtype: Ident.t -> module_type -> t -> t
+val for_saving: t -> t
+val reset_for_saving: unit -> unit
+
+val module_path: t -> Path.t -> Path.t
+val type_path: t -> Path.t -> Path.t
+val modtype_path: t -> Path.t -> Path.t
+
+val type_expr: t -> type_expr -> type_expr
+val class_type: t -> class_type -> class_type
+val value_description: t -> value_description -> value_description
+val type_declaration: t -> type_declaration -> type_declaration
+val extension_constructor:
+        t -> extension_constructor -> extension_constructor
+val class_declaration: t -> class_declaration -> class_declaration
+val cltype_declaration: t -> class_type_declaration -> class_type_declaration
+
+(*
+   When applied to a signature item, a substitution not only modifies the types
+   present in its declaration, but also refreshes the identifier of the item.
+   Effectively this creates new declarations, and so one should decide what the
+   scope of this new declaration should be.
+
+   This is decided by the [scoping] argument passed to the following functions.
+*)
+
+type scoping =
+  | Keep
+  | Make_local
+  | Rescope of int
+
+val modtype: scoping -> t -> module_type -> module_type
+val signature: scoping -> t -> signature -> signature
+val signature_item: scoping -> t -> signature_item -> signature_item
+val modtype_declaration:
+  scoping -> t -> modtype_declaration -> modtype_declaration
+val module_declaration: scoping -> t -> module_declaration -> module_declaration
+
+(* Composition of substitutions:
+     apply (compose s1 s2) x = apply s2 (apply s1 x) *)
+val compose: t -> t -> t
+
+(* A forward reference to be filled in ctype.ml. *)
+val ctype_apply_env_empty:
+  (type_expr list -> type_expr -> type_expr list -> type_expr) ref
diff --git a/upstream/ocaml_411/typing/tast_iterator.ml b/upstream/ocaml_411/typing/tast_iterator.ml
new file mode 100644
index 0000000..db63fc0
--- /dev/null
+++ b/upstream/ocaml_411/typing/tast_iterator.ml
@@ -0,0 +1,510 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                          Isaac "Izzy" Avram                            *)
+(*                                                                        *)
+(*   Copyright 2019 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Typedtree
+
+type iterator =
+  {
+    binding_op: iterator -> binding_op -> unit;
+    case: 'k . iterator -> 'k case -> unit;
+    class_declaration: iterator -> class_declaration -> unit;
+    class_description: iterator -> class_description -> unit;
+    class_expr: iterator -> class_expr -> unit;
+    class_field: iterator -> class_field -> unit;
+    class_signature: iterator -> class_signature -> unit;
+    class_structure: iterator -> class_structure -> unit;
+    class_type: iterator -> class_type -> unit;
+    class_type_declaration: iterator -> class_type_declaration -> unit;
+    class_type_field: iterator -> class_type_field -> unit;
+    env: iterator -> Env.t -> unit;
+    expr: iterator -> expression -> unit;
+    extension_constructor: iterator -> extension_constructor -> unit;
+    module_binding: iterator -> module_binding -> unit;
+    module_coercion: iterator -> module_coercion -> unit;
+    module_declaration: iterator -> module_declaration -> unit;
+    module_substitution: iterator -> module_substitution -> unit;
+    module_expr: iterator -> module_expr -> unit;
+    module_type: iterator -> module_type -> unit;
+    module_type_declaration: iterator -> module_type_declaration -> unit;
+    package_type: iterator -> package_type -> unit;
+    pat: 'k . iterator -> 'k general_pattern -> unit;
+    row_field: iterator -> row_field -> unit;
+    object_field: iterator -> object_field -> unit;
+    open_declaration: iterator -> open_declaration -> unit;
+    open_description: iterator -> open_description -> unit;
+    signature: iterator -> signature -> unit;
+    signature_item: iterator -> signature_item -> unit;
+    structure: iterator -> structure -> unit;
+    structure_item: iterator -> structure_item -> unit;
+    typ: iterator -> core_type -> unit;
+    type_declaration: iterator -> type_declaration -> unit;
+    type_declarations: iterator -> (rec_flag * type_declaration list) -> unit;
+    type_extension: iterator -> type_extension -> unit;
+    type_exception: iterator -> type_exception -> unit;
+    type_kind: iterator -> type_kind -> unit;
+    value_binding: iterator -> value_binding -> unit;
+    value_bindings: iterator -> (rec_flag * value_binding list) -> unit;
+    value_description: iterator -> value_description -> unit;
+    with_constraint: iterator -> with_constraint -> unit;
+  }
+
+let structure sub {str_items; str_final_env; _} =
+  List.iter (sub.structure_item sub) str_items;
+  sub.env sub str_final_env
+
+let class_infos sub f x =
+  List.iter (fun (ct, _) -> sub.typ sub ct) x.ci_params;
+  f x.ci_expr
+
+let module_type_declaration sub {mtd_type; _} =
+  Option.iter (sub.module_type sub) mtd_type
+
+let module_declaration sub {md_type; _} =
+  sub.module_type sub md_type
+let module_substitution _ _ = ()
+
+let include_infos f {incl_mod; _} = f incl_mod
+
+let class_type_declaration sub x =
+  class_infos sub (sub.class_type sub) x
+
+let class_declaration sub x =
+  class_infos sub (sub.class_expr sub) x
+
+let structure_item sub {str_desc; str_env; _} =
+  sub.env sub str_env;
+  match str_desc with
+  | Tstr_eval   (exp, _) -> sub.expr sub exp
+  | Tstr_value  (rec_flag, list) -> sub.value_bindings sub (rec_flag, list)
+  | Tstr_primitive v -> sub.value_description sub v
+  | Tstr_type (rec_flag, list) -> sub.type_declarations sub (rec_flag, list)
+  | Tstr_typext te -> sub.type_extension sub te
+  | Tstr_exception ext -> sub.type_exception sub ext
+  | Tstr_module mb -> sub.module_binding sub mb
+  | Tstr_recmodule list -> List.iter (sub.module_binding sub) list
+  | Tstr_modtype x -> sub.module_type_declaration sub x
+  | Tstr_class list ->
+      List.iter (fun (cls,_) -> sub.class_declaration sub cls) list
+  | Tstr_class_type list ->
+      List.iter (fun (_, _, cltd) -> sub.class_type_declaration sub cltd) list
+  | Tstr_include incl -> include_infos (sub.module_expr sub) incl
+  | Tstr_open od -> sub.open_declaration sub od
+  | Tstr_attribute _ -> ()
+
+let value_description sub x = sub.typ sub x.val_desc
+
+let label_decl sub {ld_type; _} = sub.typ sub ld_type
+
+let constructor_args sub = function
+  | Cstr_tuple l -> List.iter (sub.typ sub) l
+  | Cstr_record l -> List.iter (label_decl sub) l
+
+let constructor_decl sub {cd_args; cd_res; _} =
+  constructor_args sub cd_args;
+  Option.iter (sub.typ sub) cd_res
+
+let type_kind sub = function
+  | Ttype_abstract -> ()
+  | Ttype_variant list -> List.iter (constructor_decl sub) list
+  | Ttype_record list -> List.iter (label_decl sub) list
+  | Ttype_open -> ()
+
+let type_declaration sub {typ_cstrs; typ_kind; typ_manifest; typ_params; _} =
+  List.iter
+    (fun (c1, c2, _) ->
+      sub.typ sub c1;
+      sub.typ sub c2)
+    typ_cstrs;
+  sub.type_kind sub typ_kind;
+  Option.iter (sub.typ sub) typ_manifest;
+  List.iter (fun (c, _) -> sub.typ sub c) typ_params
+
+let type_declarations sub (_, list) = List.iter (sub.type_declaration sub) list
+
+let type_extension sub {tyext_constructors; tyext_params; _} =
+  List.iter (fun (c, _) -> sub.typ sub c) tyext_params;
+  List.iter (sub.extension_constructor sub) tyext_constructors
+
+let type_exception sub {tyexn_constructor; _} =
+  sub.extension_constructor sub tyexn_constructor
+
+let extension_constructor sub {ext_kind; _} =
+  match ext_kind with
+  | Text_decl (ctl, cto) ->
+      constructor_args sub ctl;
+      Option.iter (sub.typ sub) cto
+  | Text_rebind _ -> ()
+
+let pat_extra sub (e, _loc, _attrs) = match e with
+  | Tpat_type _ -> ()
+  | Tpat_unpack -> ()
+  | Tpat_open (_, _, env) -> sub.env sub env
+  | Tpat_constraint ct -> sub.typ sub ct
+
+let pat
+  : type k . iterator -> k general_pattern -> unit
+  = fun sub {pat_extra = extra; pat_desc; pat_env; _} ->
+  sub.env sub pat_env;
+  List.iter (pat_extra sub) extra;
+  match pat_desc with
+  | Tpat_any  -> ()
+  | Tpat_var _ -> ()
+  | Tpat_constant _ -> ()
+  | Tpat_tuple l -> List.iter (sub.pat sub) l
+  | Tpat_construct (_, _, l) -> List.iter (sub.pat sub) l
+  | Tpat_variant (_, po, _) -> Option.iter (sub.pat sub) po
+  | Tpat_record (l, _) -> List.iter (fun (_, _, i) -> sub.pat sub i) l
+  | Tpat_array l -> List.iter (sub.pat sub) l
+  | Tpat_alias (p, _, _) -> sub.pat sub p
+  | Tpat_lazy p -> sub.pat sub p
+  | Tpat_value p -> sub.pat sub (p :> pattern)
+  | Tpat_exception p -> sub.pat sub p
+  | Tpat_or (p1, p2, _) ->
+      sub.pat sub p1;
+      sub.pat sub p2
+
+let expr sub {exp_extra; exp_desc; exp_env; _} =
+  let extra = function
+    | Texp_constraint cty -> sub.typ sub cty
+    | Texp_coerce (cty1, cty2) ->
+        Option.iter (sub.typ sub) cty1;
+        sub.typ sub cty2
+    | Texp_newtype _ -> ()
+    | Texp_poly cto -> Option.iter (sub.typ sub) cto
+  in
+  List.iter (fun (e, _, _) -> extra e) exp_extra;
+  sub.env sub exp_env;
+  match exp_desc with
+  | Texp_ident _  -> ()
+  | Texp_constant _ -> ()
+  | Texp_let (rec_flag, list, exp) ->
+      sub.value_bindings sub (rec_flag, list);
+      sub.expr sub exp
+  | Texp_function {cases; _} ->
+     List.iter (sub.case sub) cases
+  | Texp_apply (exp, list) ->
+      sub.expr sub exp;
+      List.iter (fun (_, o) -> Option.iter (sub.expr sub) o) list
+  | Texp_match (exp, cases, _) ->
+      sub.expr sub exp;
+      List.iter (sub.case sub) cases
+  | Texp_try (exp, cases) ->
+      sub.expr sub exp;
+      List.iter (sub.case sub) cases
+  | Texp_tuple list -> List.iter (sub.expr sub) list
+  | Texp_construct (_, _, args) -> List.iter (sub.expr sub) args
+  | Texp_variant (_, expo) -> Option.iter (sub.expr sub) expo
+  | Texp_record { fields; extended_expression; _} ->
+      Array.iter (function
+        | _, Kept _ -> ()
+        | _, Overridden (_, exp) -> sub.expr sub exp)
+        fields;
+      Option.iter (sub.expr sub) extended_expression;
+  | Texp_field (exp, _, _) -> sub.expr sub exp
+  | Texp_setfield (exp1, _, _, exp2) ->
+      sub.expr sub exp1;
+      sub.expr sub exp2
+  | Texp_array list -> List.iter (sub.expr sub) list
+  | Texp_ifthenelse (exp1, exp2, expo) ->
+      sub.expr sub exp1;
+      sub.expr sub exp2;
+      Option.iter (sub.expr sub) expo
+  | Texp_sequence (exp1, exp2) ->
+      sub.expr sub exp1;
+      sub.expr sub exp2
+  | Texp_while (exp1, exp2) ->
+      sub.expr sub exp1;
+      sub.expr sub exp2
+  | Texp_for (_, _, exp1, exp2, _, exp3) ->
+      sub.expr sub exp1;
+      sub.expr sub exp2;
+      sub.expr sub exp3
+  | Texp_send (exp, _, expo) ->
+      sub.expr sub exp;
+      Option.iter (sub.expr sub) expo
+  | Texp_new _ -> ()
+  | Texp_instvar _ -> ()
+  | Texp_setinstvar (_, _, _, exp) ->sub.expr sub exp
+  | Texp_override (_, list) ->
+      List.iter (fun (_, _, e) -> sub.expr sub e) list
+  | Texp_letmodule (_, _, _, mexpr, exp) ->
+      sub.module_expr sub mexpr;
+      sub.expr sub exp
+  | Texp_letexception (cd, exp) ->
+      sub.extension_constructor sub cd;
+      sub.expr sub exp
+  | Texp_assert exp -> sub.expr sub exp
+  | Texp_lazy exp -> sub.expr sub exp
+  | Texp_object (cl, _) -> sub.class_structure sub cl
+  | Texp_pack mexpr -> sub.module_expr sub mexpr
+  | Texp_letop {let_ = l; ands; body; _} ->
+      sub.binding_op sub l;
+      List.iter (sub.binding_op sub) ands;
+      sub.case sub body
+  | Texp_unreachable -> ()
+  | Texp_extension_constructor _ -> ()
+  | Texp_open (od, e) ->
+      sub.open_declaration sub od;
+      sub.expr sub e
+
+
+let package_type sub {pack_fields; _} =
+  List.iter (fun (_, p) -> sub.typ sub p) pack_fields
+
+let binding_op sub {bop_exp; _} = sub.expr sub bop_exp
+
+let signature sub {sig_items; sig_final_env; _} =
+  sub.env sub sig_final_env;
+  List.iter (sub.signature_item sub) sig_items
+
+let signature_item sub {sig_desc; sig_env; _} =
+  sub.env sub sig_env;
+  match sig_desc with
+  | Tsig_value v -> sub.value_description sub v
+  | Tsig_type (rf, tdl)  -> sub.type_declarations sub (rf, tdl)
+  | Tsig_typesubst list -> sub.type_declarations sub (Nonrecursive, list)
+  | Tsig_typext te -> sub.type_extension sub te
+  | Tsig_exception ext -> sub.type_exception sub ext
+  | Tsig_module x -> sub.module_declaration sub x
+  | Tsig_modsubst x -> sub.module_substitution sub x
+  | Tsig_recmodule list -> List.iter (sub.module_declaration sub) list
+  | Tsig_modtype x -> sub.module_type_declaration sub x
+  | Tsig_include incl -> include_infos (sub.module_type sub) incl
+  | Tsig_class list -> List.iter (sub.class_description sub) list
+  | Tsig_class_type list -> List.iter (sub.class_type_declaration sub) list
+  | Tsig_open od -> sub.open_description sub od
+  | Tsig_attribute _ -> ()
+
+let class_description sub x =
+  class_infos sub (sub.class_type sub) x
+
+let functor_parameter sub = function
+  | Unit -> ()
+  | Named (_, _, mtype) -> sub.module_type sub mtype
+
+let module_type sub {mty_desc; mty_env; _} =
+  sub.env sub mty_env;
+  match mty_desc with
+  | Tmty_ident _      -> ()
+  | Tmty_alias _      -> ()
+  | Tmty_signature sg -> sub.signature sub sg
+  | Tmty_functor (arg, mtype2) ->
+      functor_parameter sub arg;
+      sub.module_type sub mtype2
+  | Tmty_with (mtype, list) ->
+      sub.module_type sub mtype;
+      List.iter (fun (_, _, e) -> sub.with_constraint sub e) list
+  | Tmty_typeof mexpr -> sub.module_expr sub mexpr
+
+let with_constraint sub = function
+  | Twith_type      decl -> sub.type_declaration sub decl
+  | Twith_typesubst decl -> sub.type_declaration sub decl
+  | Twith_module    _    -> ()
+  | Twith_modsubst  _    -> ()
+
+let open_description sub {open_env; _} = sub.env sub open_env
+
+let open_declaration sub {open_expr; open_env; _} =
+  sub.module_expr sub open_expr;
+  sub.env sub open_env
+
+let module_coercion sub = function
+  | Tcoerce_none -> ()
+  | Tcoerce_functor (c1,c2) ->
+      sub.module_coercion sub c1;
+      sub.module_coercion sub c2
+  | Tcoerce_alias (env, _, c1) ->
+      sub.env sub env;
+      sub.module_coercion sub c1
+  | Tcoerce_structure (l1, l2) ->
+      List.iter (fun (_, c) -> sub.module_coercion sub c) l1;
+      List.iter (fun (_, _ ,c) -> sub.module_coercion sub c) l2
+  | Tcoerce_primitive {pc_env; _} -> sub.env sub pc_env
+
+let module_expr sub {mod_desc; mod_env; _} =
+  sub.env sub mod_env;
+  match mod_desc with
+  | Tmod_ident _      -> ()
+  | Tmod_structure st -> sub.structure sub st
+  | Tmod_functor (arg, mexpr) ->
+      functor_parameter sub arg;
+      sub.module_expr sub mexpr
+  | Tmod_apply (mexp1, mexp2, c) ->
+      sub.module_expr sub mexp1;
+      sub.module_expr sub mexp2;
+      sub.module_coercion sub c
+  | Tmod_constraint (mexpr, _, Tmodtype_implicit, c) ->
+      sub.module_expr sub mexpr;
+      sub.module_coercion sub c
+  | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, c) ->
+      sub.module_expr sub mexpr;
+      sub.module_type sub mtype;
+      sub.module_coercion sub c
+  | Tmod_unpack (exp, _) -> sub.expr sub exp
+
+let module_binding sub {mb_expr; _} = sub.module_expr sub mb_expr
+
+let class_expr sub {cl_desc; cl_env; _} =
+  sub.env sub cl_env;
+  match cl_desc with
+  | Tcl_constraint (cl, clty, _, _, _) ->
+      sub.class_expr sub cl;
+      Option.iter (sub.class_type sub) clty
+  | Tcl_structure clstr -> sub.class_structure sub clstr
+  | Tcl_fun (_, pat, priv, cl, _) ->
+      sub.pat sub pat;
+      List.iter (fun (_, e) -> sub.expr sub e) priv;
+      sub.class_expr sub cl
+  | Tcl_apply (cl, args) ->
+      sub.class_expr sub cl;
+      List.iter (fun (_, e) -> Option.iter (sub.expr sub) e) args
+  | Tcl_let (rec_flag, value_bindings, ivars, cl) ->
+      sub.value_bindings sub (rec_flag, value_bindings);
+      List.iter (fun (_, e) -> sub.expr sub e) ivars;
+      sub.class_expr sub cl
+  | Tcl_ident (_, _, tyl) -> List.iter (sub.typ sub) tyl
+  | Tcl_open (od, e) ->
+      sub.open_description sub od;
+      sub.class_expr sub e
+
+let class_type sub {cltyp_desc; cltyp_env; _} =
+  sub.env sub cltyp_env;
+  match cltyp_desc with
+  | Tcty_signature csg -> sub.class_signature sub csg
+  | Tcty_constr (_, _, list) -> List.iter (sub.typ sub) list
+  | Tcty_arrow (_, ct, cl) ->
+      sub.typ sub ct;
+      sub.class_type sub cl
+  | Tcty_open (od, e) ->
+      sub.open_description sub od;
+      sub.class_type sub e
+
+let class_signature sub {csig_self; csig_fields; _} =
+  sub.typ sub csig_self;
+  List.iter (sub.class_type_field sub) csig_fields
+
+let class_type_field sub {ctf_desc; _} =
+  match ctf_desc with
+  | Tctf_inherit ct -> sub.class_type sub ct
+  | Tctf_val (_, _, _, ct) ->  sub.typ sub ct
+  | Tctf_method (_, _, _, ct) -> sub.typ sub ct
+  | Tctf_constraint  (ct1, ct2) ->
+      sub.typ sub ct1;
+      sub.typ sub ct2
+  | Tctf_attribute _ -> ()
+
+let typ sub {ctyp_desc; ctyp_env; _} =
+  sub.env sub ctyp_env;
+  match ctyp_desc with
+  | Ttyp_any   -> ()
+  | Ttyp_var _ -> ()
+  | Ttyp_arrow (_, ct1, ct2) ->
+      sub.typ sub ct1;
+      sub.typ sub ct2
+  | Ttyp_tuple list -> List.iter (sub.typ sub) list
+  | Ttyp_constr (_, _, list) ->  List.iter (sub.typ sub) list
+  | Ttyp_object (list, _) -> List.iter (sub.object_field sub) list
+  | Ttyp_class (_, _, list) -> List.iter (sub.typ sub) list
+  | Ttyp_alias (ct, _) -> sub.typ sub ct
+  | Ttyp_variant (list, _, _) -> List.iter (sub.row_field sub) list
+  | Ttyp_poly (_, ct) -> sub.typ sub ct
+  | Ttyp_package pack -> sub.package_type sub pack
+
+let class_structure sub {cstr_self; cstr_fields; _} =
+  sub.pat sub cstr_self;
+  List.iter (sub.class_field sub) cstr_fields
+
+let row_field sub {rf_desc; _} =
+  match rf_desc with
+  | Ttag (_, _, list) -> List.iter (sub.typ sub) list
+  | Tinherit ct -> sub.typ sub ct
+
+let object_field sub {of_desc; _} =
+  match of_desc with
+  | OTtag (_, ct) -> sub.typ sub ct
+  | OTinherit ct -> sub.typ sub ct
+
+let class_field_kind sub = function
+  | Tcfk_virtual ct -> sub.typ sub ct
+  | Tcfk_concrete (_, e) -> sub.expr sub e
+
+let class_field sub {cf_desc; _} = match cf_desc with
+  | Tcf_inherit (_, cl, _, _, _) -> sub.class_expr sub cl
+  | Tcf_constraint (cty1, cty2) ->
+      sub.typ sub cty1;
+      sub.typ sub cty2
+  | Tcf_val (_, _, _, k, _) -> class_field_kind sub k
+  | Tcf_method (_, _, k) -> class_field_kind sub k
+  | Tcf_initializer exp -> sub.expr sub exp
+  | Tcf_attribute _ -> ()
+
+let value_bindings sub (_, list) = List.iter (sub.value_binding sub) list
+
+let case sub {c_lhs; c_guard; c_rhs} =
+  sub.pat sub c_lhs;
+  Option.iter (sub.expr sub) c_guard;
+  sub.expr sub c_rhs
+
+let value_binding sub {vb_pat; vb_expr; _} =
+  sub.pat sub vb_pat;
+  sub.expr sub vb_expr
+
+let env _sub _ = ()
+
+let default_iterator =
+  {
+    binding_op;
+    case;
+    class_declaration;
+    class_description;
+    class_expr;
+    class_field;
+    class_signature;
+    class_structure;
+    class_type;
+    class_type_declaration;
+    class_type_field;
+    env;
+    expr;
+    extension_constructor;
+    module_binding;
+    module_coercion;
+    module_declaration;
+    module_substitution;
+    module_expr;
+    module_type;
+    module_type_declaration;
+    package_type;
+    pat;
+    row_field;
+    object_field;
+    open_declaration;
+    open_description;
+    signature;
+    signature_item;
+    structure;
+    structure_item;
+    typ;
+    type_declaration;
+    type_declarations;
+    type_extension;
+    type_exception;
+    type_kind;
+    value_binding;
+    value_bindings;
+    value_description;
+    with_constraint;
+  }
diff --git a/upstream/ocaml_411/typing/tast_iterator.mli b/upstream/ocaml_411/typing/tast_iterator.mli
new file mode 100644
index 0000000..e126128
--- /dev/null
+++ b/upstream/ocaml_411/typing/tast_iterator.mli
@@ -0,0 +1,68 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                           Isaac "Izzy" Avram                           *)
+(*                                                                        *)
+(*   Copyright 2019 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(**
+Allows the implementation of typed tree inspection using open recursion
+*)
+
+open Asttypes
+open Typedtree
+
+type iterator =
+  {
+    binding_op: iterator -> binding_op -> unit;
+    case: 'k . iterator -> 'k case -> unit;
+    class_declaration: iterator -> class_declaration -> unit;
+    class_description: iterator -> class_description -> unit;
+    class_expr: iterator -> class_expr -> unit;
+    class_field: iterator -> class_field -> unit;
+    class_signature: iterator -> class_signature -> unit;
+    class_structure: iterator -> class_structure -> unit;
+    class_type: iterator -> class_type -> unit;
+    class_type_declaration: iterator -> class_type_declaration -> unit;
+    class_type_field: iterator -> class_type_field -> unit;
+    env: iterator -> Env.t -> unit;
+    expr: iterator -> expression -> unit;
+    extension_constructor: iterator -> extension_constructor -> unit;
+    module_binding: iterator -> module_binding -> unit;
+    module_coercion: iterator -> module_coercion -> unit;
+    module_declaration: iterator -> module_declaration -> unit;
+    module_substitution: iterator -> module_substitution -> unit;
+    module_expr: iterator -> module_expr -> unit;
+    module_type: iterator -> module_type -> unit;
+    module_type_declaration: iterator -> module_type_declaration -> unit;
+    package_type: iterator -> package_type -> unit;
+    pat: 'k . iterator -> 'k general_pattern -> unit;
+    row_field: iterator -> row_field -> unit;
+    object_field: iterator -> object_field -> unit;
+    open_declaration: iterator -> open_declaration -> unit;
+    open_description: iterator -> open_description -> unit;
+    signature: iterator -> signature -> unit;
+    signature_item: iterator -> signature_item -> unit;
+    structure: iterator -> structure -> unit;
+    structure_item: iterator -> structure_item -> unit;
+    typ: iterator -> core_type -> unit;
+    type_declaration: iterator -> type_declaration -> unit;
+    type_declarations: iterator -> (rec_flag * type_declaration list) -> unit;
+    type_extension: iterator -> type_extension -> unit;
+    type_exception: iterator -> type_exception -> unit;
+    type_kind: iterator -> type_kind -> unit;
+    value_binding: iterator -> value_binding -> unit;
+    value_bindings: iterator -> (rec_flag * value_binding list) -> unit;
+    value_description: iterator -> value_description -> unit;
+    with_constraint: iterator -> with_constraint -> unit;
+  }
+
+val default_iterator: iterator
diff --git a/upstream/ocaml_411/typing/tast_mapper.ml b/upstream/ocaml_411/typing/tast_mapper.ml
new file mode 100644
index 0000000..d8ceee1
--- /dev/null
+++ b/upstream/ocaml_411/typing/tast_mapper.ml
@@ -0,0 +1,744 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                        Alain Frisch, LexiFi                            *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Typedtree
+
+(* TODO: add 'methods' for location, attribute, extension,
+   include_declaration, include_description *)
+
+type mapper =
+  {
+    binding_op: mapper -> binding_op -> binding_op;
+    case: 'k . mapper -> 'k case -> 'k case;
+    class_declaration: mapper -> class_declaration -> class_declaration;
+    class_description: mapper -> class_description -> class_description;
+    class_expr: mapper -> class_expr -> class_expr;
+    class_field: mapper -> class_field -> class_field;
+    class_signature: mapper -> class_signature -> class_signature;
+    class_structure: mapper -> class_structure -> class_structure;
+    class_type: mapper -> class_type -> class_type;
+    class_type_declaration: mapper -> class_type_declaration ->
+      class_type_declaration;
+    class_type_field: mapper -> class_type_field -> class_type_field;
+    env: mapper -> Env.t -> Env.t;
+    expr: mapper -> expression -> expression;
+    extension_constructor: mapper -> extension_constructor ->
+      extension_constructor;
+    module_binding: mapper -> module_binding -> module_binding;
+    module_coercion: mapper -> module_coercion -> module_coercion;
+    module_declaration: mapper -> module_declaration -> module_declaration;
+    module_substitution: mapper -> module_substitution -> module_substitution;
+    module_expr: mapper -> module_expr -> module_expr;
+    module_type: mapper -> module_type -> module_type;
+    module_type_declaration:
+      mapper -> module_type_declaration -> module_type_declaration;
+    package_type: mapper -> package_type -> package_type;
+    pat: 'k . mapper -> 'k general_pattern -> 'k general_pattern;
+    row_field: mapper -> row_field -> row_field;
+    object_field: mapper -> object_field -> object_field;
+    open_declaration: mapper -> open_declaration -> open_declaration;
+    open_description: mapper -> open_description -> open_description;
+    signature: mapper -> signature -> signature;
+    signature_item: mapper -> signature_item -> signature_item;
+    structure: mapper -> structure -> structure;
+    structure_item: mapper -> structure_item -> structure_item;
+    typ: mapper -> core_type -> core_type;
+    type_declaration: mapper -> type_declaration -> type_declaration;
+    type_declarations: mapper -> (rec_flag * type_declaration list)
+      -> (rec_flag * type_declaration list);
+    type_extension: mapper -> type_extension -> type_extension;
+    type_exception: mapper -> type_exception -> type_exception;
+    type_kind: mapper -> type_kind -> type_kind;
+    value_binding: mapper -> value_binding -> value_binding;
+    value_bindings: mapper -> (rec_flag * value_binding list) ->
+      (rec_flag * value_binding list);
+    value_description: mapper -> value_description -> value_description;
+    with_constraint: mapper -> with_constraint -> with_constraint;
+  }
+
+let id x = x
+let tuple2 f1 f2 (x, y) = (f1 x, f2 y)
+let tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
+
+let structure sub {str_items; str_type; str_final_env} =
+  {
+    str_items = List.map (sub.structure_item sub) str_items;
+    str_final_env = sub.env sub str_final_env;
+    str_type;
+  }
+
+let class_infos sub f x =
+  {x with
+   ci_params = List.map (tuple2 (sub.typ sub) id) x.ci_params;
+   ci_expr = f x.ci_expr;
+  }
+
+let module_type_declaration sub x =
+  let mtd_type = Option.map (sub.module_type sub) x.mtd_type in
+  {x with mtd_type}
+
+let module_declaration sub x =
+  let md_type = sub.module_type sub x.md_type in
+  {x with md_type}
+
+let module_substitution _ x = x
+
+let include_infos f x = {x with incl_mod = f x.incl_mod}
+
+let class_type_declaration sub x =
+  class_infos sub (sub.class_type sub) x
+
+let class_declaration sub x =
+  class_infos sub (sub.class_expr sub) x
+
+let structure_item sub {str_desc; str_loc; str_env} =
+  let str_env = sub.env sub str_env in
+  let str_desc =
+    match str_desc with
+    | Tstr_eval (exp, attrs) -> Tstr_eval (sub.expr sub exp, attrs)
+    | Tstr_value (rec_flag, list) ->
+        let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in
+        Tstr_value (rec_flag, list)
+    | Tstr_primitive v -> Tstr_primitive (sub.value_description sub v)
+    | Tstr_type (rec_flag, list) ->
+        let (rec_flag, list) = sub.type_declarations sub (rec_flag, list) in
+        Tstr_type (rec_flag, list)
+    | Tstr_typext te -> Tstr_typext (sub.type_extension sub te)
+    | Tstr_exception ext -> Tstr_exception (sub.type_exception sub ext)
+    | Tstr_module mb -> Tstr_module (sub.module_binding sub mb)
+    | Tstr_recmodule list ->
+        Tstr_recmodule (List.map (sub.module_binding sub) list)
+    | Tstr_modtype x -> Tstr_modtype (sub.module_type_declaration sub x)
+    | Tstr_class list ->
+        Tstr_class
+          (List.map (tuple2 (sub.class_declaration sub) id) list)
+    | Tstr_class_type list ->
+        Tstr_class_type
+          (List.map (tuple3 id id (sub.class_type_declaration sub)) list)
+    | Tstr_include incl ->
+        Tstr_include (include_infos (sub.module_expr sub) incl)
+    | Tstr_open od -> Tstr_open (sub.open_declaration sub od)
+    | Tstr_attribute _ as d -> d
+  in
+  {str_desc; str_env; str_loc}
+
+let value_description sub x =
+  let val_desc = sub.typ sub x.val_desc in
+  {x with val_desc}
+
+let label_decl sub x =
+  let ld_type = sub.typ sub x.ld_type in
+  {x with ld_type}
+
+let constructor_args sub = function
+  | Cstr_tuple l -> Cstr_tuple (List.map (sub.typ sub) l)
+  | Cstr_record l -> Cstr_record (List.map (label_decl sub) l)
+
+let constructor_decl sub cd =
+  let cd_args = constructor_args sub cd.cd_args in
+  let cd_res = Option.map (sub.typ sub) cd.cd_res in
+  {cd with cd_args; cd_res}
+
+let type_kind sub = function
+  | Ttype_abstract -> Ttype_abstract
+  | Ttype_variant list -> Ttype_variant (List.map (constructor_decl sub) list)
+  | Ttype_record list -> Ttype_record (List.map (label_decl sub) list)
+  | Ttype_open -> Ttype_open
+
+let type_declaration sub x =
+  let typ_cstrs =
+    List.map
+      (tuple3 (sub.typ sub) (sub.typ sub) id)
+      x.typ_cstrs
+  in
+  let typ_kind = sub.type_kind sub x.typ_kind in
+  let typ_manifest = Option.map (sub.typ sub) x.typ_manifest in
+  let typ_params = List.map (tuple2 (sub.typ sub) id) x.typ_params in
+  {x with typ_cstrs; typ_kind; typ_manifest; typ_params}
+
+let type_declarations sub (rec_flag, list) =
+  (rec_flag, List.map (sub.type_declaration sub) list)
+
+let type_extension sub x =
+  let tyext_params = List.map (tuple2 (sub.typ sub) id) x.tyext_params in
+  let tyext_constructors =
+    List.map (sub.extension_constructor sub) x.tyext_constructors
+  in
+  {x with tyext_constructors; tyext_params}
+
+let type_exception sub x =
+  let tyexn_constructor =
+    sub.extension_constructor sub x.tyexn_constructor
+  in
+  {x with tyexn_constructor}
+
+let extension_constructor sub x =
+  let ext_kind =
+    match x.ext_kind with
+      Text_decl(ctl, cto) ->
+        Text_decl(constructor_args sub ctl, Option.map (sub.typ sub) cto)
+    | Text_rebind _ as d -> d
+  in
+  {x with ext_kind}
+
+let pat_extra sub = function
+  | Tpat_type _
+  | Tpat_unpack as d -> d
+  | Tpat_open (path,loc,env) ->  Tpat_open (path, loc, sub.env sub env)
+  | Tpat_constraint ct -> Tpat_constraint (sub.typ sub ct)
+
+let pat
+  : type k . mapper -> k general_pattern -> k general_pattern
+  = fun sub x ->
+  let pat_env = sub.env sub x.pat_env in
+  let pat_extra = List.map (tuple3 (pat_extra sub) id id) x.pat_extra in
+  let pat_desc : k pattern_desc =
+    match x.pat_desc with
+    | Tpat_any
+    | Tpat_var _
+    | Tpat_constant _ -> x.pat_desc
+    | Tpat_tuple l -> Tpat_tuple (List.map (sub.pat sub) l)
+    | Tpat_construct (loc, cd, l) ->
+        Tpat_construct (loc, cd, List.map (sub.pat sub) l)
+    | Tpat_variant (l, po, rd) ->
+        Tpat_variant (l, Option.map (sub.pat sub) po, rd)
+    | Tpat_record (l, closed) ->
+        Tpat_record (List.map (tuple3 id id (sub.pat sub)) l, closed)
+    | Tpat_array l -> Tpat_array (List.map (sub.pat sub) l)
+    | Tpat_alias (p, id, s) -> Tpat_alias (sub.pat sub p, id, s)
+    | Tpat_lazy p -> Tpat_lazy (sub.pat sub p)
+    | Tpat_value p ->
+       (as_computation_pattern (sub.pat sub (p :> pattern))).pat_desc
+    | Tpat_exception p ->
+       Tpat_exception (sub.pat sub p)
+    | Tpat_or (p1, p2, rd) ->
+        Tpat_or (sub.pat sub p1, sub.pat sub p2, rd)
+  in
+  {x with pat_extra; pat_desc; pat_env}
+
+let expr sub x =
+  let extra = function
+    | Texp_constraint cty ->
+        Texp_constraint (sub.typ sub cty)
+    | Texp_coerce (cty1, cty2) ->
+        Texp_coerce (Option.map (sub.typ sub) cty1, sub.typ sub cty2)
+    | Texp_newtype _ as d -> d
+    | Texp_poly cto -> Texp_poly (Option.map (sub.typ sub) cto)
+  in
+  let exp_extra = List.map (tuple3 extra id id) x.exp_extra in
+  let exp_env = sub.env sub x.exp_env in
+  let exp_desc =
+    match x.exp_desc with
+    | Texp_ident _
+    | Texp_constant _ as d -> d
+    | Texp_let (rec_flag, list, exp) ->
+        let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in
+        Texp_let (rec_flag, list, sub.expr sub exp)
+    | Texp_function { arg_label; param; cases; partial; } ->
+        let cases = List.map (sub.case sub) cases in
+        Texp_function { arg_label; param; cases; partial; }
+    | Texp_apply (exp, list) ->
+        Texp_apply (
+          sub.expr sub exp,
+          List.map (tuple2 id (Option.map (sub.expr sub))) list
+        )
+    | Texp_match (exp, cases, p) ->
+        Texp_match (
+          sub.expr sub exp,
+          List.map (sub.case sub) cases,
+          p
+        )
+    | Texp_try (exp, cases) ->
+        Texp_try (
+          sub.expr sub exp,
+          List.map (sub.case sub) cases
+        )
+    | Texp_tuple list ->
+        Texp_tuple (List.map (sub.expr sub) list)
+    | Texp_construct (lid, cd, args) ->
+        Texp_construct (lid, cd, List.map (sub.expr sub) args)
+    | Texp_variant (l, expo) ->
+        Texp_variant (l, Option.map (sub.expr sub) expo)
+    | Texp_record { fields; representation; extended_expression } ->
+        let fields = Array.map (function
+            | label, Kept t -> label, Kept t
+            | label, Overridden (lid, exp) ->
+                label, Overridden (lid, sub.expr sub exp))
+            fields
+        in
+        Texp_record {
+          fields; representation;
+          extended_expression = Option.map (sub.expr sub) extended_expression;
+        }
+    | Texp_field (exp, lid, ld) ->
+        Texp_field (sub.expr sub exp, lid, ld)
+    | Texp_setfield (exp1, lid, ld, exp2) ->
+        Texp_setfield (
+          sub.expr sub exp1,
+          lid,
+          ld,
+          sub.expr sub exp2
+        )
+    | Texp_array list ->
+        Texp_array (List.map (sub.expr sub) list)
+    | Texp_ifthenelse (exp1, exp2, expo) ->
+        Texp_ifthenelse (
+          sub.expr sub exp1,
+          sub.expr sub exp2,
+          Option.map (sub.expr sub) expo
+        )
+    | Texp_sequence (exp1, exp2) ->
+        Texp_sequence (
+          sub.expr sub exp1,
+          sub.expr sub exp2
+        )
+    | Texp_while (exp1, exp2) ->
+        Texp_while (
+          sub.expr sub exp1,
+          sub.expr sub exp2
+        )
+    | Texp_for (id, p, exp1, exp2, dir, exp3) ->
+        Texp_for (
+          id,
+          p,
+          sub.expr sub exp1,
+          sub.expr sub exp2,
+          dir,
+          sub.expr sub exp3
+        )
+    | Texp_send (exp, meth, expo) ->
+        Texp_send
+          (
+            sub.expr sub exp,
+            meth,
+            Option.map (sub.expr sub) expo
+          )
+    | Texp_new _
+    | Texp_instvar _ as d -> d
+    | Texp_setinstvar (path1, path2, id, exp) ->
+        Texp_setinstvar (
+          path1,
+          path2,
+          id,
+          sub.expr sub exp
+        )
+    | Texp_override (path, list) ->
+        Texp_override (
+          path,
+          List.map (tuple3 id id (sub.expr sub)) list
+        )
+    | Texp_letmodule (id, s, pres, mexpr, exp) ->
+        Texp_letmodule (
+          id,
+          s,
+          pres,
+          sub.module_expr sub mexpr,
+          sub.expr sub exp
+        )
+    | Texp_letexception (cd, exp) ->
+        Texp_letexception (
+          sub.extension_constructor sub cd,
+          sub.expr sub exp
+        )
+    | Texp_assert exp ->
+        Texp_assert (sub.expr sub exp)
+    | Texp_lazy exp ->
+        Texp_lazy (sub.expr sub exp)
+    | Texp_object (cl, sl) ->
+        Texp_object (sub.class_structure sub cl, sl)
+    | Texp_pack mexpr ->
+        Texp_pack (sub.module_expr sub mexpr)
+    | Texp_letop {let_; ands; param; body; partial} ->
+        Texp_letop{
+          let_ = sub.binding_op sub let_;
+          ands = List.map (sub.binding_op sub) ands;
+          param;
+          body = sub.case sub body;
+          partial;
+        }
+    | Texp_unreachable ->
+        Texp_unreachable
+    | Texp_extension_constructor _ as e ->
+        e
+    | Texp_open (od, e) ->
+        Texp_open (sub.open_declaration sub od, sub.expr sub e)
+  in
+  {x with exp_extra; exp_desc; exp_env}
+
+
+let package_type sub x =
+  let pack_fields = List.map (tuple2 id (sub.typ sub)) x.pack_fields in
+  {x with pack_fields}
+
+let binding_op sub x =
+  { x with bop_exp = sub.expr sub x.bop_exp }
+
+let signature sub x =
+  let sig_final_env = sub.env sub x.sig_final_env in
+  let sig_items = List.map (sub.signature_item sub) x.sig_items in
+  {x with sig_items; sig_final_env}
+
+let signature_item sub x =
+  let sig_env = sub.env sub x.sig_env in
+  let sig_desc =
+    match x.sig_desc with
+    | Tsig_value v ->
+        Tsig_value (sub.value_description sub v)
+    | Tsig_type (rec_flag, list) ->
+        let (rec_flag, list) = sub.type_declarations sub (rec_flag, list) in
+        Tsig_type (rec_flag, list)
+    | Tsig_typesubst list ->
+        let (_, list) = sub.type_declarations sub (Nonrecursive, list) in
+        Tsig_typesubst list
+    | Tsig_typext te ->
+        Tsig_typext (sub.type_extension sub te)
+    | Tsig_exception ext ->
+        Tsig_exception (sub.type_exception sub ext)
+    | Tsig_module x ->
+        Tsig_module (sub.module_declaration sub x)
+    | Tsig_modsubst x ->
+        Tsig_modsubst (sub.module_substitution sub x)
+    | Tsig_recmodule list ->
+        Tsig_recmodule (List.map (sub.module_declaration sub) list)
+    | Tsig_modtype x ->
+        Tsig_modtype (sub.module_type_declaration sub x)
+    | Tsig_include incl ->
+        Tsig_include (include_infos (sub.module_type sub) incl)
+    | Tsig_class list ->
+        Tsig_class (List.map (sub.class_description sub) list)
+    | Tsig_class_type list ->
+        Tsig_class_type
+          (List.map (sub.class_type_declaration sub) list)
+    | Tsig_open od -> Tsig_open (sub.open_description sub od)
+    | Tsig_attribute _ as d -> d
+  in
+  {x with sig_desc; sig_env}
+
+let class_description sub x =
+  class_infos sub (sub.class_type sub) x
+
+let functor_parameter sub = function
+  | Unit -> Unit
+  | Named (id, s, mtype) -> Named (id, s, sub.module_type sub mtype)
+
+let module_type sub x =
+  let mty_env = sub.env sub x.mty_env in
+  let mty_desc =
+    match x.mty_desc with
+    | Tmty_ident _
+    | Tmty_alias _ as d -> d
+    | Tmty_signature sg -> Tmty_signature (sub.signature sub sg)
+    | Tmty_functor (arg, mtype2) ->
+        Tmty_functor (functor_parameter sub arg, sub.module_type sub mtype2)
+    | Tmty_with (mtype, list) ->
+        Tmty_with (
+          sub.module_type sub mtype,
+          List.map (tuple3 id id (sub.with_constraint sub)) list
+        )
+    | Tmty_typeof mexpr ->
+        Tmty_typeof (sub.module_expr sub mexpr)
+  in
+  {x with mty_desc; mty_env}
+
+let with_constraint sub = function
+  | Twith_type decl -> Twith_type (sub.type_declaration sub decl)
+  | Twith_typesubst decl -> Twith_typesubst (sub.type_declaration sub decl)
+  | Twith_module _
+  | Twith_modsubst _ as d -> d
+
+let open_description sub od =
+  {od with open_env = sub.env sub od.open_env}
+
+let open_declaration sub od =
+  {od with open_expr = sub.module_expr sub od.open_expr;
+           open_env = sub.env sub od.open_env}
+
+let module_coercion sub = function
+  | Tcoerce_none -> Tcoerce_none
+  | Tcoerce_functor (c1,c2) ->
+      Tcoerce_functor (sub.module_coercion sub c1, sub.module_coercion sub c2)
+  | Tcoerce_alias (env, p, c1) ->
+      Tcoerce_alias (sub.env sub env, p, sub.module_coercion sub c1)
+  | Tcoerce_structure (l1, l2) ->
+      let l1' = List.map (fun (i,c) -> i, sub.module_coercion sub c) l1 in
+      let l2' =
+        List.map (fun (id,i,c) -> id, i, sub.module_coercion sub c) l2
+      in
+      Tcoerce_structure (l1', l2')
+  | Tcoerce_primitive pc ->
+      Tcoerce_primitive {pc with pc_env = sub.env sub pc.pc_env}
+
+let module_expr sub x =
+  let mod_env = sub.env sub x.mod_env in
+  let mod_desc =
+    match x.mod_desc with
+    | Tmod_ident _ as d -> d
+    | Tmod_structure st -> Tmod_structure (sub.structure sub st)
+    | Tmod_functor (arg, mexpr) ->
+        Tmod_functor (functor_parameter sub arg, sub.module_expr sub mexpr)
+    | Tmod_apply (mexp1, mexp2, c) ->
+        Tmod_apply (
+          sub.module_expr sub mexp1,
+          sub.module_expr sub mexp2,
+          sub.module_coercion sub c
+        )
+    | Tmod_constraint (mexpr, mt, Tmodtype_implicit, c) ->
+        Tmod_constraint (sub.module_expr sub mexpr, mt, Tmodtype_implicit,
+                         sub.module_coercion sub c)
+    | Tmod_constraint (mexpr, mt, Tmodtype_explicit mtype, c) ->
+        Tmod_constraint (
+          sub.module_expr sub mexpr,
+          mt,
+          Tmodtype_explicit (sub.module_type sub mtype),
+          sub.module_coercion sub c
+        )
+    | Tmod_unpack (exp, mty) ->
+        Tmod_unpack
+          (
+            sub.expr sub exp,
+            mty
+          )
+  in
+  {x with mod_desc; mod_env}
+
+let module_binding sub x =
+  let mb_expr = sub.module_expr sub x.mb_expr in
+  {x with mb_expr}
+
+let class_expr sub x =
+  let cl_env = sub.env sub x.cl_env in
+  let cl_desc =
+    match x.cl_desc with
+    | Tcl_constraint (cl, clty, vals, meths, concrs) ->
+        Tcl_constraint (
+          sub.class_expr sub cl,
+          Option.map (sub.class_type sub) clty,
+          vals,
+          meths,
+          concrs
+        )
+    | Tcl_structure clstr ->
+        Tcl_structure (sub.class_structure sub clstr)
+    | Tcl_fun (label, pat, priv, cl, partial) ->
+        Tcl_fun (
+          label,
+          sub.pat sub pat,
+          List.map (tuple2 id (sub.expr sub)) priv,
+          sub.class_expr sub cl,
+          partial
+        )
+    | Tcl_apply (cl, args) ->
+        Tcl_apply (
+          sub.class_expr sub cl,
+          List.map (tuple2 id (Option.map (sub.expr sub))) args
+        )
+    | Tcl_let (rec_flag, value_bindings, ivars, cl) ->
+        let (rec_flag, value_bindings) =
+          sub.value_bindings sub (rec_flag, value_bindings)
+        in
+        Tcl_let (
+          rec_flag,
+          value_bindings,
+          List.map (tuple2 id (sub.expr sub)) ivars,
+          sub.class_expr sub cl
+        )
+    | Tcl_ident (path, lid, tyl) ->
+        Tcl_ident (path, lid, List.map (sub.typ sub) tyl)
+    | Tcl_open (od, e) ->
+        Tcl_open (sub.open_description sub od, sub.class_expr sub e)
+  in
+  {x with cl_desc; cl_env}
+
+let class_type sub x =
+  let cltyp_env = sub.env sub x.cltyp_env in
+  let cltyp_desc =
+    match x.cltyp_desc with
+    | Tcty_signature csg -> Tcty_signature (sub.class_signature sub csg)
+    | Tcty_constr (path, lid, list) ->
+        Tcty_constr (
+          path,
+          lid,
+          List.map (sub.typ sub) list
+        )
+    | Tcty_arrow (label, ct, cl) ->
+        Tcty_arrow
+          (label,
+           sub.typ sub ct,
+           sub.class_type sub cl
+          )
+    | Tcty_open (od, e) ->
+        Tcty_open (sub.open_description sub od, sub.class_type sub e)
+  in
+  {x with cltyp_desc; cltyp_env}
+
+let class_signature sub x =
+  let csig_self = sub.typ sub x.csig_self in
+  let csig_fields = List.map (sub.class_type_field sub) x.csig_fields in
+  {x with csig_self; csig_fields}
+
+let class_type_field sub x =
+  let ctf_desc =
+    match x.ctf_desc with
+    | Tctf_inherit ct ->
+        Tctf_inherit (sub.class_type sub ct)
+    | Tctf_val (s, mut, virt, ct) ->
+        Tctf_val (s, mut, virt, sub.typ sub ct)
+    | Tctf_method (s, priv, virt, ct) ->
+        Tctf_method (s, priv, virt, sub.typ sub ct)
+    | Tctf_constraint  (ct1, ct2) ->
+        Tctf_constraint (sub.typ sub ct1, sub.typ sub ct2)
+    | Tctf_attribute _ as d -> d
+  in
+  {x with ctf_desc}
+
+let typ sub x =
+  let ctyp_env = sub.env sub x.ctyp_env in
+  let ctyp_desc =
+    match x.ctyp_desc with
+    | Ttyp_any
+    | Ttyp_var _ as d -> d
+    | Ttyp_arrow (label, ct1, ct2) ->
+        Ttyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2)
+    | Ttyp_tuple list -> Ttyp_tuple (List.map (sub.typ sub) list)
+    | Ttyp_constr (path, lid, list) ->
+        Ttyp_constr (path, lid, List.map (sub.typ sub) list)
+    | Ttyp_object (list, closed) ->
+        Ttyp_object ((List.map (sub.object_field sub) list), closed)
+    | Ttyp_class (path, lid, list) ->
+        Ttyp_class
+          (path,
+           lid,
+           List.map (sub.typ sub) list
+          )
+    | Ttyp_alias (ct, s) ->
+        Ttyp_alias (sub.typ sub ct, s)
+    | Ttyp_variant (list, closed, labels) ->
+        Ttyp_variant (List.map (sub.row_field sub) list, closed, labels)
+    | Ttyp_poly (sl, ct) ->
+        Ttyp_poly (sl, sub.typ sub ct)
+    | Ttyp_package pack ->
+        Ttyp_package (sub.package_type sub pack)
+  in
+  {x with ctyp_desc; ctyp_env}
+
+let class_structure sub x =
+  let cstr_self = sub.pat sub x.cstr_self in
+  let cstr_fields = List.map (sub.class_field sub) x.cstr_fields in
+  {x with cstr_self; cstr_fields}
+
+let row_field sub x =
+  let rf_desc = match x.rf_desc with
+    | Ttag (label, b, list) ->
+        Ttag (label, b, List.map (sub.typ sub) list)
+    | Tinherit ct -> Tinherit (sub.typ sub ct)
+  in
+  { x with rf_desc; }
+
+let object_field sub x =
+  let of_desc = match x.of_desc with
+    | OTtag (label, ct) ->
+        OTtag (label, (sub.typ sub ct))
+    | OTinherit ct -> OTinherit (sub.typ sub ct)
+  in
+  { x with of_desc; }
+
+let class_field_kind sub = function
+  | Tcfk_virtual ct -> Tcfk_virtual (sub.typ sub ct)
+  | Tcfk_concrete (ovf, e) -> Tcfk_concrete (ovf, sub.expr sub e)
+
+let class_field sub x =
+  let cf_desc =
+    match x.cf_desc with
+    | Tcf_inherit (ovf, cl, super, vals, meths) ->
+        Tcf_inherit (ovf, sub.class_expr sub cl, super, vals, meths)
+    | Tcf_constraint (cty, cty') ->
+        Tcf_constraint (
+          sub.typ sub cty,
+          sub.typ sub cty'
+        )
+    | Tcf_val (s, mf, id, k, b) ->
+        Tcf_val (s, mf, id, class_field_kind sub k, b)
+    | Tcf_method (s, priv, k) ->
+        Tcf_method (s, priv, class_field_kind sub k)
+    | Tcf_initializer exp ->
+        Tcf_initializer (sub.expr sub exp)
+    | Tcf_attribute _ as d -> d
+  in
+  {x with cf_desc}
+
+let value_bindings sub (rec_flag, list) =
+  (rec_flag, List.map (sub.value_binding sub) list)
+
+let case
+  : type k . mapper -> k case -> k case
+  = fun sub {c_lhs; c_guard; c_rhs} ->
+  {
+    c_lhs = sub.pat sub c_lhs;
+    c_guard = Option.map (sub.expr sub) c_guard;
+    c_rhs = sub.expr sub c_rhs;
+  }
+
+let value_binding sub x =
+  let vb_pat = sub.pat sub x.vb_pat in
+  let vb_expr = sub.expr sub x.vb_expr in
+  {x with vb_pat; vb_expr}
+
+let env _sub x = x
+
+let default =
+  {
+    binding_op;
+    case;
+    class_declaration;
+    class_description;
+    class_expr;
+    class_field;
+    class_signature;
+    class_structure;
+    class_type;
+    class_type_declaration;
+    class_type_field;
+    env;
+    expr;
+    extension_constructor;
+    module_binding;
+    module_coercion;
+    module_declaration;
+    module_substitution;
+    module_expr;
+    module_type;
+    module_type_declaration;
+    package_type;
+    pat;
+    row_field;
+    object_field;
+    open_declaration;
+    open_description;
+    signature;
+    signature_item;
+    structure;
+    structure_item;
+    typ;
+    type_declaration;
+    type_declarations;
+    type_extension;
+    type_exception;
+    type_kind;
+    value_binding;
+    value_bindings;
+    value_description;
+    with_constraint;
+  }
diff --git a/upstream/ocaml_411/typing/tast_mapper.mli b/upstream/ocaml_411/typing/tast_mapper.mli
new file mode 100644
index 0000000..ea6543d
--- /dev/null
+++ b/upstream/ocaml_411/typing/tast_mapper.mli
@@ -0,0 +1,72 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                        Alain Frisch, LexiFi                            *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Typedtree
+
+(** {1 A generic Typedtree mapper} *)
+
+type mapper =
+  {
+    binding_op: mapper -> binding_op -> binding_op;
+    case: 'k . mapper -> 'k case -> 'k case;
+    class_declaration: mapper -> class_declaration -> class_declaration;
+    class_description: mapper -> class_description -> class_description;
+    class_expr: mapper -> class_expr -> class_expr;
+    class_field: mapper -> class_field -> class_field;
+    class_signature: mapper -> class_signature -> class_signature;
+    class_structure: mapper -> class_structure -> class_structure;
+    class_type: mapper -> class_type -> class_type;
+    class_type_declaration: mapper -> class_type_declaration ->
+      class_type_declaration;
+    class_type_field: mapper -> class_type_field -> class_type_field;
+    env: mapper -> Env.t -> Env.t;
+    expr: mapper -> expression -> expression;
+    extension_constructor: mapper -> extension_constructor ->
+      extension_constructor;
+    module_binding: mapper -> module_binding -> module_binding;
+    module_coercion: mapper -> module_coercion -> module_coercion;
+    module_declaration: mapper -> module_declaration -> module_declaration;
+    module_substitution: mapper -> module_substitution -> module_substitution;
+    module_expr: mapper -> module_expr -> module_expr;
+    module_type: mapper -> module_type -> module_type;
+    module_type_declaration:
+      mapper -> module_type_declaration -> module_type_declaration;
+    package_type: mapper -> package_type -> package_type;
+    pat: 'k . mapper -> 'k general_pattern -> 'k general_pattern;
+    row_field: mapper -> row_field -> row_field;
+    object_field: mapper -> object_field -> object_field;
+    open_declaration: mapper -> open_declaration -> open_declaration;
+    open_description: mapper -> open_description -> open_description;
+    signature: mapper -> signature -> signature;
+    signature_item: mapper -> signature_item -> signature_item;
+    structure: mapper -> structure -> structure;
+    structure_item: mapper -> structure_item -> structure_item;
+    typ: mapper -> core_type -> core_type;
+    type_declaration: mapper -> type_declaration -> type_declaration;
+    type_declarations: mapper -> (rec_flag * type_declaration list)
+      -> (rec_flag * type_declaration list);
+    type_extension: mapper -> type_extension -> type_extension;
+    type_exception: mapper -> type_exception -> type_exception;
+    type_kind: mapper -> type_kind -> type_kind;
+    value_binding: mapper -> value_binding -> value_binding;
+    value_bindings: mapper -> (rec_flag * value_binding list) ->
+      (rec_flag * value_binding list);
+    value_description: mapper -> value_description -> value_description;
+    with_constraint: mapper -> with_constraint -> with_constraint;
+  }
+
+
+val default: mapper
diff --git a/upstream/ocaml_411/typing/type_immediacy.ml b/upstream/ocaml_411/typing/type_immediacy.ml
new file mode 100644
index 0000000..557ed42
--- /dev/null
+++ b/upstream/ocaml_411/typing/type_immediacy.ml
@@ -0,0 +1,43 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2019 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t =
+  | Unknown
+  | Always
+  | Always_on_64bits
+
+module Violation = struct
+  type t =
+    | Not_always_immediate
+    | Not_always_immediate_on_64bits
+end
+
+let coerce t ~as_ =
+  match t, as_ with
+  | _, Unknown
+  | Always, Always
+  | (Always | Always_on_64bits), Always_on_64bits -> Ok ()
+  | (Unknown | Always_on_64bits), Always ->
+      Error Violation.Not_always_immediate
+  | Unknown, Always_on_64bits ->
+      Error Violation.Not_always_immediate_on_64bits
+
+let of_attributes attrs =
+  match
+    Builtin_attributes.immediate attrs,
+    Builtin_attributes.immediate64 attrs
+  with
+  | true, _ -> Always
+  | false, true -> Always_on_64bits
+  | false, false -> Unknown
diff --git a/upstream/ocaml_411/typing/type_immediacy.mli b/upstream/ocaml_411/typing/type_immediacy.mli
new file mode 100644
index 0000000..3fc2e3b
--- /dev/null
+++ b/upstream/ocaml_411/typing/type_immediacy.mli
@@ -0,0 +1,40 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2019 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Immediacy status of a type *)
+
+type t =
+  | Unknown
+  (** We don't know anything *)
+  | Always
+  (** We know for sure that values of this type are always immediate *)
+  | Always_on_64bits
+  (** We know for sure that values of this type are always immediate
+      on 64 bit platforms. For other platforms, we know nothing. *)
+
+module Violation : sig
+  type t =
+    | Not_always_immediate
+    | Not_always_immediate_on_64bits
+end
+
+(** [coerce t ~as_] returns [Ok ()] iff [t] can be seen as type
+    immediacy [as_]. For instance, [Always] can be seen as
+    [Always_on_64bits] but the opposite is not true. Return [Error _]
+    if the coercion is not possible. *)
+val coerce : t -> as_:t -> (unit, Violation.t) result
+
+(** Return the immediateness of a type as indicated by the user via
+    attributes *)
+val of_attributes : Parsetree.attributes -> t
diff --git a/upstream/ocaml_411/typing/typeclass.ml b/upstream/ocaml_411/typing/typeclass.ml
new file mode 100644
index 0000000..31d4bc8
--- /dev/null
+++ b/upstream/ocaml_411/typing/typeclass.ml
@@ -0,0 +1,2062 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Parsetree
+open Asttypes
+open Path
+open Types
+open Typecore
+open Typetexp
+open Format
+
+type 'a class_info = {
+  cls_id : Ident.t;
+  cls_id_loc : string loc;
+  cls_decl : class_declaration;
+  cls_ty_id : Ident.t;
+  cls_ty_decl : class_type_declaration;
+  cls_obj_id : Ident.t;
+  cls_obj_abbr : type_declaration;
+  cls_typesharp_id : Ident.t;
+  cls_abbr : type_declaration;
+  cls_arity : int;
+  cls_pub_methods : string list;
+  cls_info : 'a;
+}
+
+type class_type_info = {
+  clsty_ty_id : Ident.t;
+  clsty_id_loc : string loc;
+  clsty_ty_decl : class_type_declaration;
+  clsty_obj_id : Ident.t;
+  clsty_obj_abbr : type_declaration;
+  clsty_typesharp_id : Ident.t;
+  clsty_abbr : type_declaration;
+  clsty_info : Typedtree.class_type_declaration;
+}
+
+type 'a full_class = {
+  id : Ident.t;
+  id_loc : tag loc;
+  clty: class_declaration;
+  ty_id: Ident.t;
+  cltydef: class_type_declaration;
+  obj_id: Ident.t;
+  obj_abbr: type_declaration;
+  cl_id: Ident.t;
+  cl_abbr: type_declaration;
+  arity: int;
+  pub_meths: string list;
+  coe: Warnings.loc list;
+  expr: 'a;
+  req: 'a Typedtree.class_infos;
+}
+
+type class_env = { val_env : Env.t; met_env : Env.t; par_env : Env.t }
+
+type error =
+    Unconsistent_constraint of Ctype.Unification_trace.t
+  | Field_type_mismatch of string * string * Ctype.Unification_trace.t
+  | Structure_expected of class_type
+  | Cannot_apply of class_type
+  | Apply_wrong_label of arg_label
+  | Pattern_type_clash of type_expr
+  | Repeated_parameter
+  | Unbound_class_2 of Longident.t
+  | Unbound_class_type_2 of Longident.t
+  | Abbrev_type_clash of type_expr * type_expr * type_expr
+  | Constructor_type_mismatch of string * Ctype.Unification_trace.t
+  | Virtual_class of bool * bool * string list * string list
+  | Parameter_arity_mismatch of Longident.t * int * int
+  | Parameter_mismatch of Ctype.Unification_trace.t
+  | Bad_parameters of Ident.t * type_expr * type_expr
+  | Class_match_failure of Ctype.class_match_failure list
+  | Unbound_val of string
+  | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure
+  | Non_generalizable_class of Ident.t * Types.class_declaration
+  | Cannot_coerce_self of type_expr
+  | Non_collapsable_conjunction of
+      Ident.t * Types.class_declaration * Ctype.Unification_trace.t
+  | Final_self_clash of Ctype.Unification_trace.t
+  | Mutability_mismatch of string * mutable_flag
+  | No_overriding of string * string
+  | Duplicate of string * string
+  | Closing_self_type of type_expr
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+open Typedtree
+
+let type_open_descr :
+  (?used_slot:bool ref -> Env.t -> Parsetree.open_description
+   -> open_description * Env.t) ref =
+  ref (fun ?used_slot:_ _ -> assert false)
+
+let ctyp desc typ env loc =
+  { ctyp_desc = desc; ctyp_type = typ; ctyp_loc = loc; ctyp_env = env;
+    ctyp_attributes = [] }
+
+                       (**********************)
+                       (*  Useful constants  *)
+                       (**********************)
+
+
+(*
+   Self type have a dummy private method, thus preventing it to become
+   closed.
+*)
+let dummy_method = Btype.dummy_method
+
+(*
+   Path associated to the temporary class type of a class being typed
+   (its constructor is not available).
+*)
+let unbound_class =
+  Path.Pident (Ident.create_local "*undef*")
+
+
+                (************************************)
+                (*  Some operations on class types  *)
+                (************************************)
+
+
+(* Fully expand the head of a class type *)
+let rec scrape_class_type =
+  function
+    Cty_constr (_, _, cty) -> scrape_class_type cty
+  | cty                     -> cty
+
+(* Generalize a class type *)
+let rec generalize_class_type gen =
+  function
+    Cty_constr (_, params, cty) ->
+      List.iter gen params;
+      generalize_class_type gen cty
+  | Cty_signature {csig_self = sty; csig_vars = vars; csig_inher = inher} ->
+      gen sty;
+      Vars.iter (fun _ (_, _, ty) -> gen ty) vars;
+      List.iter (fun (_,tl) -> List.iter gen tl) inher
+  | Cty_arrow (_, ty, cty) ->
+      gen ty;
+      generalize_class_type gen cty
+
+let generalize_class_type vars =
+  let gen = if vars then Ctype.generalize else Ctype.generalize_structure in
+  generalize_class_type gen
+
+(* Return the virtual methods of a class type *)
+let virtual_methods sign =
+  let (fields, _) =
+    Ctype.flatten_fields (Ctype.object_fields sign.Types.csig_self)
+  in
+  List.fold_left
+    (fun virt (lab, _, _) ->
+       if lab = dummy_method then virt else
+       if Concr.mem lab sign.csig_concr then virt else
+       lab::virt)
+    [] fields
+
+(* Return the constructor type associated to a class type *)
+let rec constructor_type constr cty =
+  match cty with
+    Cty_constr (_, _, cty) ->
+      constructor_type constr cty
+  | Cty_signature _ ->
+      constr
+  | Cty_arrow (l, ty, cty) ->
+      Ctype.newty (Tarrow (l, ty, constructor_type constr cty, Cok))
+
+let rec class_body cty =
+  match cty with
+    Cty_constr _ ->
+      cty (* Only class bodies can be abbreviated *)
+  | Cty_signature _ ->
+      cty
+  | Cty_arrow (_, _, cty) ->
+      class_body cty
+
+let extract_constraints cty =
+  let sign = Ctype.signature_of_class_type cty in
+  (Vars.fold (fun lab _ vars -> lab :: vars) sign.csig_vars [],
+   begin let (fields, _) =
+     Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
+   in
+   List.fold_left
+     (fun meths (lab, _, _) ->
+        if lab = dummy_method then meths else lab::meths)
+     [] fields
+   end,
+   sign.csig_concr)
+
+let rec abbreviate_class_type path params cty =
+  match cty with
+    Cty_constr (_, _, _) | Cty_signature _ ->
+      Cty_constr (path, params, cty)
+  | Cty_arrow (l, ty, cty) ->
+      Cty_arrow (l, ty, abbreviate_class_type path params cty)
+
+(* Check that all type variables are generalizable *)
+(* Use Env.empty to prevent expansion of recursively defined object types;
+   cf. typing-poly/poly.ml *)
+let rec closed_class_type =
+  function
+    Cty_constr (_, params, _) ->
+      List.for_all (Ctype.closed_schema Env.empty) params
+  | Cty_signature sign ->
+      Ctype.closed_schema Env.empty sign.csig_self
+        &&
+      Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema Env.empty ty && cc)
+        sign.csig_vars
+        true
+  | Cty_arrow (_, ty, cty) ->
+      Ctype.closed_schema Env.empty ty
+        &&
+      closed_class_type cty
+
+let closed_class cty =
+  List.for_all (Ctype.closed_schema Env.empty) cty.cty_params
+    &&
+  closed_class_type cty.cty_type
+
+let rec limited_generalize rv =
+  function
+    Cty_constr (_path, params, cty) ->
+      List.iter (Ctype.limited_generalize rv) params;
+      limited_generalize rv cty
+  | Cty_signature sign ->
+      Ctype.limited_generalize rv sign.csig_self;
+      Vars.iter (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty)
+        sign.csig_vars;
+      List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl)
+        sign.csig_inher
+  | Cty_arrow (_, ty, cty) ->
+      Ctype.limited_generalize rv ty;
+      limited_generalize rv cty
+
+(* Record a class type *)
+let rc node =
+  Cmt_format.add_saved_type (Cmt_format.Partial_class_expr node);
+  node
+
+
+                (***********************************)
+                (*  Primitives for typing classes  *)
+                (***********************************)
+
+
+(* Enter a value in the method environment only *)
+let enter_met_env ?check loc lab kind unbound_kind ty class_env =
+  let {val_env; met_env; par_env} = class_env in
+  let val_env = Env.enter_unbound_value lab unbound_kind val_env in
+  let par_env = Env.enter_unbound_value lab unbound_kind par_env in
+  let (id, met_env) =
+    Env.enter_value ?check lab
+      {val_type = ty; val_kind = kind;
+       val_attributes = []; Types.val_loc = loc;
+       val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); } met_env
+  in
+  let class_env = {val_env; met_env; par_env} in
+  (id,class_env )
+
+(* Enter an instance variable in the environment *)
+let enter_val cl_num vars inh lab mut virt ty class_env loc =
+  let val_env = class_env.val_env in
+  let (id, virt) =
+    try
+      let (id, mut', virt', ty') = Vars.find lab !vars in
+      if mut' <> mut then
+        raise (Error(loc, val_env, Mutability_mismatch(lab, mut)));
+      Ctype.unify val_env (Ctype.instance ty) (Ctype.instance ty');
+      (if not inh then Some id else None),
+      (if virt' = Concrete then virt' else virt)
+    with
+      Ctype.Unify tr ->
+        raise (Error(loc, val_env,
+                     Field_type_mismatch("instance variable", lab, tr)))
+    | Not_found -> None, virt
+  in
+  let (id, _) as result =
+    match id with Some id -> (id, class_env)
+    | None ->
+        enter_met_env Location.none lab (Val_ivar (mut, cl_num))
+          Val_unbound_instance_variable ty class_env
+  in
+  vars := Vars.add lab (id, mut, virt, ty) !vars;
+  result
+
+let concr_vals vars =
+  Vars.fold
+    (fun id (_, vf, _) s -> if vf = Virtual then s else Concr.add id s)
+    vars Concr.empty
+
+let inheritance self_type env ovf concr_meths warn_vals loc parent =
+  match scrape_class_type parent with
+    Cty_signature cl_sig ->
+
+      (* Methods *)
+      begin try
+        Ctype.unify env self_type cl_sig.csig_self
+      with Ctype.Unify trace ->
+        let open Ctype.Unification_trace in
+        match trace with
+        | Diff _ :: Incompatible_fields {name = n; _ } :: rem ->
+            raise(Error(loc, env, Field_type_mismatch ("method", n, rem)))
+        | _ -> assert false
+      end;
+
+      (* Overriding *)
+      let over_meths = Concr.inter cl_sig.csig_concr concr_meths in
+      let concr_vals = concr_vals cl_sig.csig_vars in
+      let over_vals = Concr.inter concr_vals warn_vals in
+      begin match ovf with
+        Some Fresh ->
+          let cname =
+            match parent with
+              Cty_constr (p, _, _) -> Path.name p
+            | _ -> "inherited"
+          in
+          if not (Concr.is_empty over_meths) then
+            Location.prerr_warning loc
+              (Warnings.Method_override (cname :: Concr.elements over_meths));
+          if not (Concr.is_empty over_vals) then
+            Location.prerr_warning loc
+              (Warnings.Instance_variable_override
+                 (cname :: Concr.elements over_vals));
+      | Some Override
+        when Concr.is_empty over_meths && Concr.is_empty over_vals ->
+        raise (Error(loc, env, No_overriding ("","")))
+      | _ -> ()
+      end;
+
+      let concr_meths = Concr.union cl_sig.csig_concr concr_meths
+      and warn_vals = Concr.union concr_vals warn_vals in
+
+      (cl_sig, concr_meths, warn_vals)
+
+  | _ ->
+      raise(Error(loc, env, Structure_expected parent))
+
+let virtual_method val_env meths self_type lab priv sty loc =
+  let (_, ty') =
+     Ctype.filter_self_method val_env lab priv meths self_type
+  in
+  let sty = Ast_helper.Typ.force_poly sty in
+  let cty = transl_simple_type val_env false sty in
+  let ty = cty.ctyp_type in
+  begin
+    try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
+        raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace)));
+  end;
+  cty
+
+let delayed_meth_specs = ref []
+
+let declare_method val_env meths self_type lab priv sty loc =
+  let (_, ty') =
+     Ctype.filter_self_method val_env lab priv meths self_type
+  in
+  let unif ty =
+    try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
+      raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace)))
+  in
+  let sty = Ast_helper.Typ.force_poly sty in
+  match sty.ptyp_desc, priv with
+    Ptyp_poly ([],sty'), Public ->
+(* TODO: we moved the [transl_simple_type_univars] outside of the lazy,
+so that we can get an immediate value. Is that correct ? Ask Jacques. *)
+      let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) val_env loc in
+      delayed_meth_specs :=
+      Warnings.mk_lazy (fun () ->
+            let cty = transl_simple_type_univars val_env sty' in
+            let ty = cty.ctyp_type in
+            unif ty;
+            returned_cty.ctyp_desc <- Ttyp_poly ([], cty);
+            returned_cty.ctyp_type <- ty;
+          ) ::
+      !delayed_meth_specs;
+      returned_cty
+  | _ ->
+      let cty = transl_simple_type val_env false sty in
+      let ty = cty.ctyp_type in
+      unif ty;
+      cty
+
+let type_constraint val_env sty sty' loc =
+  let cty  = transl_simple_type val_env false sty in
+  let ty = cty.ctyp_type in
+  let cty' = transl_simple_type val_env false sty' in
+  let ty' = cty'.ctyp_type in
+  begin
+    try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
+        raise(Error(loc, val_env, Unconsistent_constraint trace));
+  end;
+  (cty, cty')
+
+let make_method loc cl_num expr =
+  let open Ast_helper in
+  let mkid s = mkloc s loc in
+  Exp.fun_ ~loc:expr.pexp_loc Nolabel None
+    (Pat.alias ~loc (Pat.var ~loc (mkid "self-*")) (mkid ("self-" ^ cl_num)))
+    expr
+
+(*******************************)
+
+let add_val lab (mut, virt, ty) val_sig =
+  let virt =
+    try
+      let (_mut', virt', _ty') = Vars.find lab val_sig in
+      if virt' = Concrete then virt' else virt
+    with Not_found -> virt
+  in
+  Vars.add lab (mut, virt, ty) val_sig
+
+let rec class_type_field env self_type meths arg ctf =
+  Builtin_attributes.warning_scope ctf.pctf_attributes
+    (fun () -> class_type_field_aux env self_type meths arg ctf)
+
+and class_type_field_aux env self_type meths
+    (fields, val_sig, concr_meths, inher) ctf =
+
+  let loc = ctf.pctf_loc in
+  let mkctf desc =
+    { ctf_desc = desc; ctf_loc = loc; ctf_attributes = ctf.pctf_attributes }
+  in
+  match ctf.pctf_desc with
+    Pctf_inherit sparent ->
+      let parent = class_type env sparent in
+      let inher =
+        match parent.cltyp_type with
+          Cty_constr (p, tl, _) -> (p, tl) :: inher
+        | _ -> inher
+      in
+      let (cl_sig, concr_meths, _) =
+        inheritance self_type env None concr_meths Concr.empty sparent.pcty_loc
+          parent.cltyp_type
+      in
+      let val_sig =
+        Vars.fold add_val cl_sig.csig_vars val_sig in
+      (mkctf (Tctf_inherit parent) :: fields,
+       val_sig, concr_meths, inher)
+
+  | Pctf_val ({txt=lab}, mut, virt, sty) ->
+      let cty = transl_simple_type env false sty in
+      let ty = cty.ctyp_type in
+      (mkctf (Tctf_val (lab, mut, virt, cty)) :: fields,
+      add_val lab (mut, virt, ty) val_sig, concr_meths, inher)
+
+  | Pctf_method ({txt=lab}, priv, virt, sty)  ->
+      let cty =
+        declare_method env meths self_type lab priv sty  ctf.pctf_loc in
+      let concr_meths =
+        match virt with
+        | Concrete -> Concr.add lab concr_meths
+        | Virtual -> concr_meths
+      in
+      (mkctf (Tctf_method (lab, priv, virt, cty)) :: fields,
+        val_sig, concr_meths, inher)
+
+  | Pctf_constraint (sty, sty') ->
+      let (cty, cty') = type_constraint env sty sty'  ctf.pctf_loc in
+      (mkctf (Tctf_constraint (cty, cty')) :: fields,
+        val_sig, concr_meths, inher)
+
+  | Pctf_attribute x ->
+      Builtin_attributes.warning_attribute x;
+      (mkctf (Tctf_attribute x) :: fields,
+        val_sig, concr_meths, inher)
+
+  | Pctf_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and class_signature env {pcsig_self=sty; pcsig_fields=sign} =
+  let meths = ref Meths.empty in
+  let self_cty = transl_simple_type env false sty in
+  let self_cty = { self_cty with
+    ctyp_type = Ctype.expand_head env self_cty.ctyp_type } in
+  let self_type =  self_cty.ctyp_type in
+
+  (* Check that the binder is a correct type, and introduce a dummy
+     method preventing self type from being closed. *)
+  let dummy_obj = Ctype.newvar () in
+  Ctype.unify env (Ctype.filter_method env dummy_method Private dummy_obj)
+    (Ctype.newty (Ttuple []));
+  begin try
+    Ctype.unify env self_type dummy_obj
+  with Ctype.Unify _ ->
+    raise(Error(sty.ptyp_loc, env, Pattern_type_clash self_type))
+  end;
+
+  (* Class type fields *)
+  let (rev_fields, val_sig, concr_meths, inher) =
+    Builtin_attributes.warning_scope []
+      (fun () ->
+         List.fold_left (class_type_field env self_type meths)
+           ([], Vars.empty, Concr.empty, [])
+           sign
+      )
+  in
+  let cty =   {csig_self = self_type;
+   csig_vars = val_sig;
+   csig_concr = concr_meths;
+   csig_inher = inher}
+  in
+  { csig_self = self_cty;
+    csig_fields = List.rev rev_fields;
+    csig_type = cty;
+  }
+
+and class_type env scty =
+  Builtin_attributes.warning_scope scty.pcty_attributes
+    (fun () -> class_type_aux env scty)
+
+and class_type_aux env scty =
+  let cltyp desc typ =
+    {
+     cltyp_desc = desc;
+     cltyp_type = typ;
+     cltyp_loc = scty.pcty_loc;
+     cltyp_env = env;
+     cltyp_attributes = scty.pcty_attributes;
+    }
+  in
+  match scty.pcty_desc with
+    Pcty_constr (lid, styl) ->
+      let (path, decl) = Env.lookup_cltype ~loc:scty.pcty_loc lid.txt env in
+      if Path.same decl.clty_path unbound_class then
+        raise(Error(scty.pcty_loc, env, Unbound_class_type_2 lid.txt));
+      let (params, clty) =
+        Ctype.instance_class decl.clty_params decl.clty_type
+      in
+      if List.length params <> List.length styl then
+        raise(Error(scty.pcty_loc, env,
+                    Parameter_arity_mismatch (lid.txt, List.length params,
+                                                   List.length styl)));
+      let ctys = List.map2
+        (fun sty ty ->
+          let cty' = transl_simple_type env false sty in
+          let ty' = cty'.ctyp_type in
+          begin
+           try Ctype.unify env ty' ty with Ctype.Unify trace ->
+                  raise(Error(sty.ptyp_loc, env, Parameter_mismatch trace))
+            end;
+            cty'
+        )       styl params
+      in
+      let typ = Cty_constr (path, params, clty) in
+      cltyp (Tcty_constr ( path, lid , ctys)) typ
+
+  | Pcty_signature pcsig ->
+      let clsig = class_signature env pcsig in
+      let typ = Cty_signature clsig.csig_type in
+      cltyp (Tcty_signature clsig) typ
+
+  | Pcty_arrow (l, sty, scty) ->
+      let cty = transl_simple_type env false sty in
+      let ty = cty.ctyp_type in
+      let ty =
+        if Btype.is_optional l
+        then Ctype.newty (Tconstr(Predef.path_option,[ty], ref Mnil))
+        else ty in
+      let clty = class_type env scty in
+      let typ = Cty_arrow (l, ty, clty.cltyp_type) in
+      cltyp (Tcty_arrow (l, cty, clty)) typ
+
+  | Pcty_open (od, e) ->
+      let (od, newenv) = !type_open_descr env od in
+      let clty = class_type newenv e in
+      cltyp (Tcty_open (od, clty)) clty.cltyp_type
+
+  | Pcty_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+let class_type env scty =
+  delayed_meth_specs := [];
+  let cty = class_type env scty in
+  List.iter Lazy.force (List.rev !delayed_meth_specs);
+  delayed_meth_specs := [];
+  cty
+
+(*******************************)
+
+let rec class_field self_loc cl_num self_type meths vars arg cf =
+  Builtin_attributes.warning_scope cf.pcf_attributes
+    (fun () -> class_field_aux self_loc cl_num self_type meths vars arg cf)
+
+and class_field_aux self_loc cl_num self_type meths vars
+    (class_env, fields, concr_meths, warn_vals, inher,
+     local_meths, local_vals) cf =
+  let loc = cf.pcf_loc in
+  let mkcf desc =
+    { cf_desc = desc; cf_loc = loc; cf_attributes = cf.pcf_attributes }
+  in
+  let {val_env; met_env; par_env} = class_env in
+  match cf.pcf_desc with
+    Pcf_inherit (ovf, sparent, super) ->
+      let parent = class_expr cl_num val_env par_env sparent in
+      let inher =
+        match parent.cl_type with
+          Cty_constr (p, tl, _) -> (p, tl) :: inher
+        | _ -> inher
+      in
+      let (cl_sig, concr_meths, warn_vals) =
+        inheritance self_type val_env (Some ovf) concr_meths warn_vals
+          sparent.pcl_loc parent.cl_type
+      in
+      (* Variables *)
+      let (class_env, inh_vars) =
+        Vars.fold
+          (fun lab info (class_env, inh_vars) ->
+             let mut, vr, ty = info in
+             let (id, class_env) =
+                enter_val cl_num vars true lab mut vr ty class_env
+                 sparent.pcl_loc ;
+             in
+             (class_env, (lab, id) :: inh_vars))
+          cl_sig.csig_vars (class_env, [])
+      in
+      (* Inherited concrete methods *)
+      let inh_meths =
+        Concr.fold (fun lab rem -> (lab, Ident.create_local lab)::rem)
+          cl_sig.csig_concr []
+      in
+      (* Super *)
+      let (class_env,super) =
+        match super with
+          None ->
+            (class_env,None)
+        | Some {txt=name} ->
+            let (_id, class_env) =
+              enter_met_env ~check:(fun s -> Warnings.Unused_ancestor s)
+                sparent.pcl_loc name (Val_anc (inh_meths, cl_num))
+                Val_unbound_ancestor self_type class_env
+            in
+            (class_env,Some name)
+      in
+      (class_env,
+       lazy (mkcf (Tcf_inherit (ovf, parent, super, inh_vars, inh_meths)))
+       :: fields,
+       concr_meths, warn_vals, inher, local_meths, local_vals)
+
+  | Pcf_val (lab, mut, Cfk_virtual styp) ->
+      if !Clflags.principal then Ctype.begin_def ();
+      let cty = Typetexp.transl_simple_type val_env false styp in
+      let ty = cty.ctyp_type in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        Ctype.generalize_structure ty
+      end;
+      let (id, class_env') =
+        enter_val cl_num vars false lab.txt mut Virtual ty
+        class_env loc
+      in
+      (class_env',
+       lazy (mkcf (Tcf_val (lab, mut, id, Tcfk_virtual cty,
+                            met_env == class_env'.met_env)))
+             :: fields,
+             concr_meths, warn_vals, inher, local_meths, local_vals)
+
+  | Pcf_val (lab, mut, Cfk_concrete (ovf, sexp)) ->
+      if Concr.mem lab.txt local_vals then
+        raise(Error(loc, val_env, Duplicate ("instance variable", lab.txt)));
+      if Concr.mem lab.txt warn_vals then begin
+        if ovf = Fresh then
+          Location.prerr_warning lab.loc
+            (Warnings.Instance_variable_override[lab.txt])
+      end else begin
+        if ovf = Override then
+          raise(Error(loc, val_env,
+                      No_overriding ("instance variable", lab.txt)))
+      end;
+      if !Clflags.principal then Ctype.begin_def ();
+      let exp = type_exp val_env sexp in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        Ctype.generalize_structure exp.exp_type
+       end;
+      let (id, class_env') =
+        enter_val cl_num vars false lab.txt mut Concrete exp.exp_type
+        class_env loc
+      in
+      (class_env',
+       lazy (mkcf (Tcf_val (lab, mut, id,
+                    Tcfk_concrete (ovf, exp), met_env == class_env'.met_env)))
+       :: fields,
+       concr_meths, Concr.add lab.txt warn_vals, inher, local_meths,
+       Concr.add lab.txt local_vals)
+
+  | Pcf_method (lab, priv, Cfk_virtual sty) ->
+      let cty = virtual_method val_env meths self_type lab.txt priv sty loc in
+      (class_env,
+        lazy (mkcf(Tcf_method (lab, priv, Tcfk_virtual cty)))
+       ::fields,
+        concr_meths, warn_vals, inher, local_meths, local_vals)
+
+  | Pcf_method (lab, priv, Cfk_concrete (ovf, expr))  ->
+      let expr =
+        match expr.pexp_desc with
+        | Pexp_poly _ -> expr
+        | _ -> Ast_helper.Exp.poly ~loc:expr.pexp_loc expr None
+      in
+      if Concr.mem lab.txt local_meths then
+        raise(Error(loc, val_env, Duplicate ("method", lab.txt)));
+      if Concr.mem lab.txt concr_meths then begin
+        if ovf = Fresh then
+          Location.prerr_warning loc (Warnings.Method_override [lab.txt])
+      end else begin
+        if ovf = Override then
+          raise(Error(loc, val_env, No_overriding("method", lab.txt)))
+      end;
+      let (_, ty) =
+        Ctype.filter_self_method val_env lab.txt priv meths self_type
+      in
+      begin try match expr.pexp_desc with
+        Pexp_poly (sbody, sty) ->
+          begin match sty with None -> ()
+                | Some sty ->
+                    let sty = Ast_helper.Typ.force_poly sty in
+                    let cty' = Typetexp.transl_simple_type val_env false sty in
+                    let ty' = cty'.ctyp_type in
+              Ctype.unify val_env ty' ty
+          end;
+          begin match (Ctype.repr ty).desc with
+            Tvar _ ->
+              let ty' = Ctype.newvar () in
+              Ctype.unify val_env (Ctype.newty (Tpoly (ty', []))) ty;
+              Ctype.unify val_env (type_approx val_env sbody) ty'
+          | Tpoly (ty1, tl) ->
+              let _, ty1' = Ctype.instance_poly false tl ty1 in
+              let ty2 = type_approx val_env sbody in
+              Ctype.unify val_env ty2 ty1'
+          | _ -> assert false
+          end
+      | _ -> assert false
+      with Ctype.Unify trace ->
+        raise(Error(loc, val_env,
+                    Field_type_mismatch ("method", lab.txt, trace)))
+      end;
+      let meth_expr = make_method self_loc cl_num expr in
+      (* backup variables for Pexp_override *)
+      let vars_local = !vars in
+
+      let field =
+        Warnings.mk_lazy
+          (fun () ->
+             (* Read the generalized type *)
+             let (_, ty) = Meths.find lab.txt !meths in
+             let meth_type = mk_expected (
+               Btype.newgenty (Tarrow(Nolabel, self_type, ty, Cok))
+             ) in
+             Ctype.raise_nongen_level ();
+             vars := vars_local;
+             let texp = type_expect met_env meth_expr meth_type in
+             Ctype.end_def ();
+             mkcf (Tcf_method (lab, priv, Tcfk_concrete (ovf, texp)))
+          )
+      in
+      (class_env, field::fields,
+       Concr.add lab.txt concr_meths, warn_vals, inher,
+       Concr.add lab.txt local_meths, local_vals)
+
+  | Pcf_constraint (sty, sty') ->
+      let (cty, cty') = type_constraint val_env sty sty' loc in
+      (class_env,
+        lazy (mkcf (Tcf_constraint (cty, cty'))) :: fields,
+        concr_meths, warn_vals, inher, local_meths, local_vals)
+
+  | Pcf_initializer expr ->
+      let expr = make_method self_loc cl_num expr in
+      let vars_local = !vars in
+      let field =
+        lazy begin
+          Ctype.raise_nongen_level ();
+          let meth_type = mk_expected (
+            Ctype.newty
+              (Tarrow (Nolabel, self_type,
+                       Ctype.instance Predef.type_unit, Cok))
+          ) in
+          vars := vars_local;
+          let texp = type_expect met_env expr meth_type in
+          Ctype.end_def ();
+          mkcf (Tcf_initializer texp)
+        end in
+      (class_env, field::fields, concr_meths, warn_vals,
+       inher, local_meths, local_vals)
+  | Pcf_attribute x ->
+      Builtin_attributes.warning_attribute x;
+      (class_env,
+        lazy (mkcf (Tcf_attribute x)) :: fields,
+        concr_meths, warn_vals, inher, local_meths, local_vals)
+  | Pcf_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+(* N.B. the self type of a final object type doesn't contain a dummy method in
+   the beginning.
+   We only explicitly add a dummy method to class definitions (and class (type)
+   declarations)), which are later removed (made absent) by [final_decl].
+
+   If we ever find a dummy method in a final object self type, it means that
+   somehow we've unified the self type of the object with the self type of a not
+   yet finished class.
+   When this happens, we cannot close the object type and must error. *)
+and class_structure cl_num final val_env met_env loc
+  { pcstr_self = spat; pcstr_fields = str } =
+  (* Environment for substructures *)
+  let par_env = met_env in
+
+  (* Location of self. Used for locations of self arguments *)
+  let self_loc = {spat.ppat_loc with Location.loc_ghost = true} in
+
+  let self_type = Ctype.newobj (Ctype.newvar ()) in
+
+  (* Adding a dummy method to the self type prevents it from being closed /
+     escaping.
+     That isn't needed for objects though. *)
+  if not final then
+    Ctype.unify val_env
+      (Ctype.filter_method val_env dummy_method Private self_type)
+      (Ctype.newty (Ttuple []));
+
+  (* Private self is used for private method calls *)
+  let private_self = if final then Ctype.newvar () else self_type in
+
+  (* Self binder *)
+  let (pat, meths, vars, val_env, met_env, par_env) =
+    type_self_pattern cl_num private_self val_env met_env par_env spat
+  in
+  let public_self = pat.pat_type in
+
+  (* Check that the binder has a correct type *)
+  let ty =
+    if final then Ctype.newobj (Ctype.newvar()) else self_type in
+  begin try Ctype.unify val_env public_self ty with
+    Ctype.Unify _ ->
+      raise(Error(spat.ppat_loc, val_env, Pattern_type_clash public_self))
+  end;
+  let get_methods ty =
+    (fst (Ctype.flatten_fields
+            (Ctype.object_fields (Ctype.expand_head val_env ty)))) in
+  if final then begin
+    (* Copy known information to still empty self_type *)
+    List.iter
+      (fun (lab,kind,ty) ->
+        let k =
+          if Btype.field_kind_repr kind = Fpresent then Public else Private in
+        try Ctype.unify val_env ty
+            (Ctype.filter_method val_env lab k self_type)
+        with _ -> assert false)
+      (get_methods public_self)
+  end;
+
+  (* Typing of class fields *)
+  let class_env = {val_env; met_env; par_env} in
+  let (_, fields, concr_meths, _, inher, _local_meths, _local_vals) =
+    Builtin_attributes.warning_scope []
+      (fun () ->
+         List.fold_left (class_field self_loc cl_num self_type meths vars)
+           ( class_env,[], Concr.empty, Concr.empty, [],
+            Concr.empty, Concr.empty)
+           str
+      )
+  in
+  Ctype.unify val_env self_type (Ctype.newvar ()); (* useless ? *)
+  let sign =
+    {csig_self = public_self;
+     csig_vars = Vars.map (fun (_id, mut, vr, ty) -> (mut, vr, ty)) !vars;
+     csig_concr = concr_meths;
+      csig_inher = inher} in
+  let methods = get_methods self_type in
+  let priv_meths =
+    List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind <> Fpresent)
+      methods in
+  (* ensure that inherited methods are listed too *)
+  List.iter (fun (met, _kind, _ty) ->
+      if Meths.mem met !meths then () else
+      ignore (Ctype.filter_self_method val_env met Private meths self_type))
+    methods;
+  if final then begin
+    (* Unify private_self and a copy of self_type. self_type will not
+       be modified after this point *)
+    if not (Ctype.close_object self_type) then
+      raise(Error(loc, val_env, Closing_self_type self_type));
+    let mets = virtual_methods {sign with csig_self = self_type} in
+    let vals =
+      Vars.fold
+        (fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l)
+        sign.csig_vars [] in
+    if mets <> [] || vals <> [] then
+      raise(Error(loc, val_env, Virtual_class(true, final, mets, vals)));
+    let self_methods =
+      List.fold_right
+        (fun (lab,kind,ty) rem ->
+           Ctype.newty(Tfield(lab, Btype.copy_kind kind, ty, rem)))
+        methods (Ctype.newty Tnil) in
+    begin try
+      Ctype.unify val_env private_self
+        (Ctype.newty (Tobject(self_methods, ref None)));
+      Ctype.unify val_env public_self self_type
+    with Ctype.Unify trace -> raise(Error(loc, val_env, Final_self_clash trace))
+    end;
+  end;
+
+  (* Typing of method bodies *)
+  (* if !Clflags.principal then *) begin
+    let ms = !meths in
+    (* Generalize the spine of methods accessed through self *)
+    Meths.iter (fun _ (_,ty) -> Ctype.generalize_spine ty) ms;
+    meths :=
+      Meths.map (fun (id,ty) -> (id, Ctype.generic_instance ty)) ms;
+    (* But keep levels correct on the type of self *)
+    Meths.iter (fun _ (_,ty) -> Ctype.unify val_env ty (Ctype.newvar ())) ms
+  end;
+  let fields = List.map Lazy.force (List.rev fields) in
+  let meths = Meths.map (function (id, _ty) -> id) !meths in
+
+  (* Check for private methods made public *)
+  let pub_meths' =
+    List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind = Fpresent)
+      (get_methods public_self) in
+  let names = List.map (fun (x,_,_) -> x) in
+  let l1 = names priv_meths and l2 = names pub_meths' in
+  let added = List.filter (fun x -> List.mem x l1) l2 in
+  if added <> [] then
+    Location.prerr_warning loc (Warnings.Implicit_public_methods added);
+  let sign = if final then sign else
+      {sign with Types.csig_self = Ctype.expand_head val_env public_self} in
+  {
+    cstr_self = pat;
+    cstr_fields = fields;
+    cstr_type = sign;
+    cstr_meths = meths}, sign (* redondant, since already in cstr_type *)
+
+and class_expr cl_num val_env met_env scl =
+  Builtin_attributes.warning_scope scl.pcl_attributes
+    (fun () -> class_expr_aux cl_num val_env met_env scl)
+
+and class_expr_aux cl_num val_env met_env scl =
+  match scl.pcl_desc with
+    Pcl_constr (lid, styl) ->
+      let (path, decl) = Env.lookup_class ~loc:scl.pcl_loc lid.txt val_env in
+      if Path.same decl.cty_path unbound_class then
+        raise(Error(scl.pcl_loc, val_env, Unbound_class_2 lid.txt));
+      let tyl = List.map
+          (fun sty -> transl_simple_type val_env false sty)
+          styl
+      in
+      let (params, clty) =
+        Ctype.instance_class decl.cty_params decl.cty_type
+      in
+      let clty' = abbreviate_class_type path params clty in
+      if List.length params <> List.length tyl then
+        raise(Error(scl.pcl_loc, val_env,
+                    Parameter_arity_mismatch (lid.txt, List.length params,
+                                                   List.length tyl)));
+      List.iter2
+        (fun cty' ty ->
+          let ty' = cty'.ctyp_type in
+           try Ctype.unify val_env ty' ty with Ctype.Unify trace ->
+             raise(Error(cty'.ctyp_loc, val_env, Parameter_mismatch trace)))
+        tyl params;
+      let cl =
+        rc {cl_desc = Tcl_ident (path, lid, tyl);
+            cl_loc = scl.pcl_loc;
+            cl_type = clty';
+            cl_env = val_env;
+            cl_attributes = scl.pcl_attributes;
+           }
+      in
+      let (vals, meths, concrs) = extract_constraints clty in
+      rc {cl_desc = Tcl_constraint (cl, None, vals, meths, concrs);
+          cl_loc = scl.pcl_loc;
+          cl_type = clty';
+          cl_env = val_env;
+          cl_attributes = []; (* attributes are kept on the inner cl node *)
+         }
+  | Pcl_structure cl_str ->
+      let (desc, ty) =
+        class_structure cl_num false val_env met_env scl.pcl_loc cl_str in
+      rc {cl_desc = Tcl_structure desc;
+          cl_loc = scl.pcl_loc;
+          cl_type = Cty_signature ty;
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_fun (l, Some default, spat, sbody) ->
+      let loc = default.pexp_loc in
+      let open Ast_helper in
+      let scases = [
+        Exp.case
+          (Pat.construct ~loc
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
+             (Some (Pat.var ~loc (mknoloc "*sth*"))))
+          (Exp.ident ~loc (mknoloc (Longident.Lident "*sth*")));
+
+        Exp.case
+          (Pat.construct ~loc
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
+             None)
+          default;
+       ]
+      in
+      let smatch =
+        Exp.match_ ~loc (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*")))
+          scases
+      in
+      let sfun =
+        Cl.fun_ ~loc:scl.pcl_loc
+          l None
+          (Pat.var ~loc (mknoloc "*opt*"))
+          (Cl.let_ ~loc:scl.pcl_loc Nonrecursive [Vb.mk spat smatch] sbody)
+          (* Note: we don't put the '#default' attribute, as it
+             is not detected for class-level let bindings.  See #5975.*)
+      in
+      class_expr cl_num val_env met_env sfun
+  | Pcl_fun (l, None, spat, scl') ->
+      if !Clflags.principal then Ctype.begin_def ();
+      let (pat, pv, val_env', met_env) =
+        Typecore.type_class_arg_pattern cl_num val_env met_env l spat
+      in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        let gen {pat_type = ty} = Ctype.generalize_structure ty in
+        iter_pattern gen pat
+      end;
+      let pv =
+        List.map
+          begin fun (id, id', _ty) ->
+            let path = Pident id' in
+            (* do not mark the value as being used *)
+            let vd = Env.find_value path val_env' in
+            (id,
+             {exp_desc =
+              Texp_ident(path, mknoloc (Longident.Lident (Ident.name id)), vd);
+              exp_loc = Location.none; exp_extra = [];
+              exp_type = Ctype.instance vd.val_type;
+              exp_attributes = []; (* check *)
+              exp_env = val_env'})
+          end
+          pv
+      in
+      let not_function = function
+          Cty_arrow _ -> false
+        | _ -> true
+      in
+      let partial =
+        let dummy = type_exp val_env (Ast_helper.Exp.unreachable ()) in
+        Typecore.check_partial val_env pat.pat_type pat.pat_loc
+          [{c_lhs = pat; c_guard = None; c_rhs = dummy}]
+      in
+      Ctype.raise_nongen_level ();
+      let cl = class_expr cl_num val_env' met_env scl' in
+      Ctype.end_def ();
+      if Btype.is_optional l && not_function cl.cl_type then
+        Location.prerr_warning pat.pat_loc
+          Warnings.Unerasable_optional_argument;
+      rc {cl_desc = Tcl_fun (l, pat, pv, cl, partial);
+          cl_loc = scl.pcl_loc;
+          cl_type = Cty_arrow
+            (l, Ctype.instance pat.pat_type, cl.cl_type);
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_apply (scl', sargs) ->
+      assert (sargs <> []);
+      if !Clflags.principal then Ctype.begin_def ();
+      let cl = class_expr cl_num val_env met_env scl' in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        generalize_class_type false cl.cl_type;
+      end;
+      let rec nonopt_labels ls ty_fun =
+        match ty_fun with
+        | Cty_arrow (l, _, ty_res) ->
+            if Btype.is_optional l then nonopt_labels ls ty_res
+            else nonopt_labels (l::ls) ty_res
+        | _    -> ls
+      in
+      let ignore_labels =
+        !Clflags.classic ||
+        let labels = nonopt_labels [] cl.cl_type in
+        List.length labels = List.length sargs &&
+        List.for_all (fun (l,_) -> l = Nolabel) sargs &&
+        List.exists (fun l -> l <> Nolabel) labels &&
+        begin
+          Location.prerr_warning
+            cl.cl_loc
+            (Warnings.Labels_omitted
+               (List.map Printtyp.string_of_label
+                         (List.filter ((<>) Nolabel) labels)));
+          true
+        end
+      in
+      let rec type_args args omitted ty_fun ty_fun0 sargs =
+        match ty_fun, ty_fun0 with
+        | Cty_arrow (l, ty, ty_fun), Cty_arrow (_, ty0, ty_fun0)
+          when sargs <> [] ->
+            let name = Btype.label_name l
+            and optional = Btype.is_optional l in
+            let use_arg sarg l' =
+              Some (
+                if not optional || Btype.is_optional l' then
+                  type_argument val_env sarg ty ty0
+                else
+                  let ty' = extract_option_type val_env ty
+                  and ty0' = extract_option_type val_env ty0 in
+                  let arg = type_argument val_env sarg ty' ty0' in
+                  option_some val_env arg
+              )
+            in
+            let eliminate_optional_arg () =
+              Some (option_none val_env ty0 Location.none)
+            in
+            let remaining_sargs, arg =
+              if ignore_labels then begin
+                match sargs with
+                | [] -> assert false
+                | (l', sarg) :: remaining_sargs ->
+                    if name = Btype.label_name l' ||
+                       (not optional && l' = Nolabel)
+                    then
+                      (remaining_sargs, use_arg sarg l')
+                    else if
+                      optional &&
+                      not (List.exists (fun (l, _) -> name = Btype.label_name l)
+                             remaining_sargs)
+                    then
+                      (sargs, eliminate_optional_arg ())
+                    else
+                      raise(Error(sarg.pexp_loc, val_env, Apply_wrong_label l'))
+              end else
+                match Btype.extract_label name sargs with
+                | Some (l', sarg, _, remaining_sargs) ->
+                    if not optional && Btype.is_optional l' then
+                      Location.prerr_warning sarg.pexp_loc
+                        (Warnings.Nonoptional_label
+                           (Printtyp.string_of_label l));
+                    remaining_sargs, use_arg sarg l'
+                | None ->
+                    sargs,
+                    if Btype.is_optional l && List.mem_assoc Nolabel sargs then
+                      eliminate_optional_arg ()
+                    else
+                      None
+            in
+            let omitted = if arg = None then (l,ty0) :: omitted else omitted in
+            type_args ((l,arg)::args) omitted ty_fun ty_fun0 remaining_sargs
+        | _ ->
+            match sargs with
+              (l, sarg0)::_ ->
+                if omitted <> [] then
+                  raise(Error(sarg0.pexp_loc, val_env, Apply_wrong_label l))
+                else
+                  raise(Error(cl.cl_loc, val_env, Cannot_apply cl.cl_type))
+            | [] ->
+                (List.rev args,
+                 List.fold_left
+                   (fun ty_fun (l,ty) -> Cty_arrow(l,ty,ty_fun))
+                   ty_fun0 omitted)
+      in
+      let (args, cty) =
+        let (_, ty_fun0) = Ctype.instance_class [] cl.cl_type in
+        type_args [] [] cl.cl_type ty_fun0 sargs
+      in
+      rc {cl_desc = Tcl_apply (cl, args);
+          cl_loc = scl.pcl_loc;
+          cl_type = cty;
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_let (rec_flag, sdefs, scl') ->
+      let (defs, val_env) =
+        Typecore.type_let In_class_def val_env rec_flag sdefs None in
+      let (vals, met_env) =
+        List.fold_right
+          (fun (id, _id_loc, _typ) (vals, met_env) ->
+             let path = Pident id in
+             (* do not mark the value as used *)
+             let vd = Env.find_value path val_env in
+             Ctype.begin_def ();
+             let expr =
+               {exp_desc =
+                Texp_ident(path, mknoloc(Longident.Lident (Ident.name id)),vd);
+                exp_loc = Location.none; exp_extra = [];
+                exp_type = Ctype.instance vd.val_type;
+                exp_attributes = [];
+                exp_env = val_env;
+               }
+             in
+             Ctype.end_def ();
+             Ctype.generalize expr.exp_type;
+             let desc =
+               {val_type = expr.exp_type; val_kind = Val_ivar (Immutable,
+                                                               cl_num);
+                val_attributes = [];
+                Types.val_loc = vd.Types.val_loc;
+                val_uid = vd.val_uid;
+               }
+             in
+             let id' = Ident.create_local (Ident.name id) in
+             ((id', expr)
+              :: vals,
+              Env.add_value id' desc met_env))
+          (let_bound_idents_full defs)
+          ([], met_env)
+      in
+      let cl = class_expr cl_num val_env met_env scl' in
+      let () = if rec_flag = Recursive then
+        check_recursive_bindings val_env defs
+      in
+      rc {cl_desc = Tcl_let (rec_flag, defs, vals, cl);
+          cl_loc = scl.pcl_loc;
+          cl_type = cl.cl_type;
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_constraint (scl', scty) ->
+      Ctype.begin_class_def ();
+      let context = Typetexp.narrow () in
+      let cl = class_expr cl_num val_env met_env scl' in
+      Typetexp.widen context;
+      let context = Typetexp.narrow () in
+      let clty = class_type val_env scty in
+      Typetexp.widen context;
+      Ctype.end_def ();
+
+      limited_generalize (Ctype.row_variable (Ctype.self_type cl.cl_type))
+          cl.cl_type;
+      limited_generalize (Ctype.row_variable (Ctype.self_type clty.cltyp_type))
+        clty.cltyp_type;
+
+      begin match
+        Includeclass.class_types val_env cl.cl_type clty.cltyp_type
+      with
+        []    -> ()
+      | error -> raise(Error(cl.cl_loc, val_env, Class_match_failure error))
+      end;
+      let (vals, meths, concrs) = extract_constraints clty.cltyp_type in
+      rc {cl_desc = Tcl_constraint (cl, Some clty, vals, meths, concrs);
+          cl_loc = scl.pcl_loc;
+          cl_type = snd (Ctype.instance_class [] clty.cltyp_type);
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_open (pod, e) ->
+      let used_slot = ref false in
+      let (od, new_val_env) = !type_open_descr ~used_slot val_env pod in
+      let ( _, new_met_env) = !type_open_descr ~used_slot met_env pod in
+      let cl = class_expr cl_num new_val_env new_met_env e in
+      rc {cl_desc = Tcl_open (od, cl);
+          cl_loc = scl.pcl_loc;
+          cl_type = cl.cl_type;
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+(*******************************)
+
+(* Approximate the type of the constructor to allow recursive use *)
+(* of optional parameters                                         *)
+
+let var_option = Predef.type_option (Btype.newgenvar ())
+
+let rec approx_declaration cl =
+  match cl.pcl_desc with
+    Pcl_fun (l, _, _, cl) ->
+      let arg =
+        if Btype.is_optional l then Ctype.instance var_option
+        else Ctype.newvar () in
+      Ctype.newty (Tarrow (l, arg, approx_declaration cl, Cok))
+  | Pcl_let (_, _, cl) ->
+      approx_declaration cl
+  | Pcl_constraint (cl, _) ->
+      approx_declaration cl
+  | _ -> Ctype.newvar ()
+
+let rec approx_description ct =
+  match ct.pcty_desc with
+    Pcty_arrow (l, _, ct) ->
+      let arg =
+        if Btype.is_optional l then Ctype.instance var_option
+        else Ctype.newvar () in
+      Ctype.newty (Tarrow (l, arg, approx_description ct, Cok))
+  | _ -> Ctype.newvar ()
+
+(*******************************)
+
+let temp_abbrev loc env id arity uid =
+  let params = ref [] in
+  for _i = 1 to arity do
+    params := Ctype.newvar () :: !params
+  done;
+  let ty = Ctype.newobj (Ctype.newvar ()) in
+  let env =
+    Env.add_type ~check:true id
+      {type_params = !params;
+       type_arity = arity;
+       type_kind = Type_abstract;
+       type_private = Public;
+       type_manifest = Some ty;
+       type_variance = Misc.replicate_list Variance.full arity;
+       type_separability = Types.Separability.default_signature ~arity;
+       type_is_newtype = false;
+       type_expansion_scope = Btype.lowest_level;
+       type_loc = loc;
+       type_attributes = []; (* or keep attrs from the class decl? *)
+       type_immediate = Unknown;
+       type_unboxed = unboxed_false_default_false;
+       type_uid = uid;
+      }
+      env
+  in
+  (!params, ty, env)
+
+let initial_env define_class approx
+    (res, env) (cl, id, ty_id, obj_id, cl_id, uid) =
+  (* Temporary abbreviations *)
+  let arity = List.length cl.pci_params in
+  let (obj_params, obj_ty, env) = temp_abbrev cl.pci_loc env obj_id arity uid in
+  let (cl_params, cl_ty, env) = temp_abbrev cl.pci_loc env cl_id arity uid in
+
+  (* Temporary type for the class constructor *)
+  let constr_type = approx cl.pci_expr in
+  if !Clflags.principal then Ctype.generalize_spine constr_type;
+  let dummy_cty =
+    Cty_signature
+      { csig_self = Ctype.newvar ();
+        csig_vars = Vars.empty;
+        csig_concr = Concr.empty;
+        csig_inher = [] }
+  in
+  let dummy_class =
+    {Types.cty_params = [];             (* Dummy value *)
+     cty_variance = [];
+     cty_type = dummy_cty;        (* Dummy value *)
+     cty_path = unbound_class;
+     cty_new =
+       begin match cl.pci_virt with
+       | Virtual  -> None
+       | Concrete -> Some constr_type
+       end;
+     cty_loc = Location.none;
+     cty_attributes = [];
+     cty_uid = uid;
+    }
+  in
+  let env =
+    Env.add_cltype ty_id
+      {clty_params = [];            (* Dummy value *)
+       clty_variance = [];
+       clty_type = dummy_cty;       (* Dummy value *)
+       clty_path = unbound_class;
+       clty_loc = Location.none;
+       clty_attributes = [];
+       clty_uid = uid;
+      }
+      (
+        if define_class then
+          Env.add_class id dummy_class env
+        else
+          env
+      )
+  in
+  ((cl, id, ty_id,
+    obj_id, obj_params, obj_ty,
+    cl_id, cl_params, cl_ty,
+    constr_type, dummy_class)::res,
+   env)
+
+let class_infos define_class kind
+    (cl, id, ty_id,
+     obj_id, obj_params, obj_ty,
+     cl_id, cl_params, cl_ty,
+     constr_type, dummy_class)
+    (res, env) =
+
+  reset_type_variables ();
+  Ctype.begin_class_def ();
+
+  (* Introduce class parameters *)
+  let ci_params =
+    let make_param (sty, v) =
+      try
+          (transl_type_param env sty, v)
+      with Already_bound ->
+        raise(Error(sty.ptyp_loc, env, Repeated_parameter))
+    in
+      List.map make_param cl.pci_params
+  in
+  let params = List.map (fun (cty, _) -> cty.ctyp_type) ci_params in
+
+  (* Allow self coercions (only for class declarations) *)
+  let coercion_locs = ref [] in
+
+  (* Type the class expression *)
+  let (expr, typ) =
+    try
+      Typecore.self_coercion :=
+        (Path.Pident obj_id, coercion_locs) :: !Typecore.self_coercion;
+      let res = kind env cl.pci_expr in
+      Typecore.self_coercion := List.tl !Typecore.self_coercion;
+      res
+    with exn ->
+      Typecore.self_coercion := []; raise exn
+  in
+
+  Ctype.end_def ();
+
+  let sty = Ctype.self_type typ in
+
+  (* First generalize the type of the dummy method (cf PR#6123) *)
+  let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in
+  List.iter (fun (met, _, ty) -> if met = dummy_method then Ctype.generalize ty)
+    fields;
+  (* Generalize the row variable *)
+  let rv = Ctype.row_variable sty in
+  List.iter (Ctype.limited_generalize rv) params;
+  limited_generalize rv typ;
+
+  (* Check the abbreviation for the object type *)
+  let (obj_params', obj_type) = Ctype.instance_class params typ in
+  let constr = Ctype.newconstr (Path.Pident obj_id) obj_params in
+  begin
+    let ty = Ctype.self_type obj_type in
+    Ctype.hide_private_methods ty;
+    if not (Ctype.close_object ty) then
+      raise(Error(cl.pci_loc, env, Closing_self_type ty));
+    begin try
+      List.iter2 (Ctype.unify env) obj_params obj_params'
+    with Ctype.Unify _ ->
+      raise(Error(cl.pci_loc, env,
+            Bad_parameters (obj_id, constr,
+                            Ctype.newconstr (Path.Pident obj_id)
+                                            obj_params')))
+    end;
+    begin try
+      Ctype.unify env ty constr
+    with Ctype.Unify _ ->
+      raise(Error(cl.pci_loc, env,
+        Abbrev_type_clash (constr, ty, Ctype.expand_head env constr)))
+    end
+  end;
+
+  (* Check the other temporary abbreviation (#-type) *)
+  begin
+    let (cl_params', cl_type) = Ctype.instance_class params typ in
+    let ty = Ctype.self_type cl_type in
+    Ctype.hide_private_methods ty;
+    Ctype.set_object_name obj_id (Ctype.row_variable ty) cl_params ty;
+    begin try
+      List.iter2 (Ctype.unify env) cl_params cl_params'
+    with Ctype.Unify _ ->
+      raise(Error(cl.pci_loc, env,
+            Bad_parameters (cl_id,
+                            Ctype.newconstr (Path.Pident cl_id)
+                                            cl_params,
+                            Ctype.newconstr (Path.Pident cl_id)
+                                            cl_params')))
+    end;
+    begin try
+      Ctype.unify env ty cl_ty
+    with Ctype.Unify _ ->
+      let constr = Ctype.newconstr (Path.Pident cl_id) params in
+      raise(Error(cl.pci_loc, env, Abbrev_type_clash (constr, ty, cl_ty)))
+    end
+  end;
+
+  (* Type of the class constructor *)
+  begin try
+    Ctype.unify env
+      (constructor_type constr obj_type)
+      (Ctype.instance constr_type)
+  with Ctype.Unify trace ->
+    raise(Error(cl.pci_loc, env,
+                Constructor_type_mismatch (cl.pci_name.txt, trace)))
+  end;
+
+  (* Class and class type temporary definitions *)
+  let cty_variance = List.map (fun _ -> Variance.full) params in
+  let cltydef =
+    {clty_params = params; clty_type = class_body typ;
+     clty_variance = cty_variance;
+     clty_path = Path.Pident obj_id;
+     clty_loc = cl.pci_loc;
+     clty_attributes = cl.pci_attributes;
+     clty_uid = dummy_class.cty_uid;
+    }
+  and clty =
+    {cty_params = params; cty_type = typ;
+     cty_variance = cty_variance;
+     cty_path = Path.Pident obj_id;
+     cty_new =
+       begin match cl.pci_virt with
+       | Virtual  -> None
+       | Concrete -> Some constr_type
+       end;
+     cty_loc = cl.pci_loc;
+     cty_attributes = cl.pci_attributes;
+     cty_uid = dummy_class.cty_uid;
+    }
+  in
+  dummy_class.cty_type <- typ;
+  let env =
+    Env.add_cltype ty_id cltydef (
+    if define_class then Env.add_class id clty env else env)
+  in
+
+  if cl.pci_virt = Concrete then begin
+    let sign = Ctype.signature_of_class_type typ in
+    let mets = virtual_methods sign in
+    let vals =
+      Vars.fold
+        (fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l)
+        sign.csig_vars [] in
+    if mets <> []  || vals <> [] then
+      raise(Error(cl.pci_loc, env, Virtual_class(define_class, false, mets,
+                                                 vals)));
+  end;
+
+  (* Misc. *)
+  let arity = Ctype.class_type_arity typ in
+  let pub_meths =
+    let (fields, _) =
+      Ctype.flatten_fields (Ctype.object_fields (Ctype.expand_head env obj_ty))
+    in
+    List.map (function (lab, _, _) -> lab) fields
+  in
+
+  (* Final definitions *)
+  let (params', typ') = Ctype.instance_class params typ in
+  let cltydef =
+    {clty_params = params'; clty_type = class_body typ';
+     clty_variance = cty_variance;
+     clty_path = Path.Pident obj_id;
+     clty_loc = cl.pci_loc;
+     clty_attributes = cl.pci_attributes;
+     clty_uid = dummy_class.cty_uid;
+    }
+  and clty =
+    {cty_params = params'; cty_type = typ';
+     cty_variance = cty_variance;
+     cty_path = Path.Pident obj_id;
+     cty_new =
+       begin match cl.pci_virt with
+       | Virtual  -> None
+       | Concrete -> Some (Ctype.instance constr_type)
+       end;
+     cty_loc = cl.pci_loc;
+     cty_attributes = cl.pci_attributes;
+     cty_uid = dummy_class.cty_uid;
+    }
+  in
+  let obj_abbr =
+    let arity = List.length obj_params in
+    {
+     type_params = obj_params;
+     type_arity = arity;
+     type_kind = Type_abstract;
+     type_private = Public;
+     type_manifest = Some obj_ty;
+     type_variance = List.map (fun _ -> Variance.full) obj_params;
+     type_separability = Types.Separability.default_signature ~arity;
+     type_is_newtype = false;
+     type_expansion_scope = Btype.lowest_level;
+     type_loc = cl.pci_loc;
+     type_attributes = []; (* or keep attrs from cl? *)
+     type_immediate = Unknown;
+     type_unboxed = unboxed_false_default_false;
+     type_uid = dummy_class.cty_uid;
+    }
+  in
+  let (cl_params, cl_ty) =
+    Ctype.instance_parameterized_type params (Ctype.self_type typ)
+  in
+  Ctype.hide_private_methods cl_ty;
+  Ctype.set_object_name obj_id (Ctype.row_variable cl_ty) cl_params cl_ty;
+  let cl_abbr =
+    let arity = List.length cl_params in
+    {
+     type_params = cl_params;
+     type_arity = arity;
+     type_kind = Type_abstract;
+     type_private = Public;
+     type_manifest = Some cl_ty;
+     type_variance = List.map (fun _ -> Variance.full) cl_params;
+     type_separability = Types.Separability.default_signature ~arity;
+     type_is_newtype = false;
+     type_expansion_scope = Btype.lowest_level;
+     type_loc = cl.pci_loc;
+     type_attributes = []; (* or keep attrs from cl? *)
+     type_immediate = Unknown;
+     type_unboxed = unboxed_false_default_false;
+     type_uid = dummy_class.cty_uid;
+    }
+  in
+  ((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params,
+    arity, pub_meths, List.rev !coercion_locs, expr) :: res,
+   env)
+
+let final_decl env define_class
+    (cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params,
+     arity, pub_meths, coe, expr) =
+
+  begin try Ctype.collapse_conj_params env clty.cty_params
+  with Ctype.Unify trace ->
+    raise(Error(cl.pci_loc, env, Non_collapsable_conjunction (id, clty, trace)))
+  end;
+
+  (* make the dummy method disappear *)
+  begin
+    let self_type = Ctype.self_type clty.cty_type in
+    let methods, _ =
+      Ctype.flatten_fields
+        (Ctype.object_fields (Ctype.expand_head env self_type))
+    in
+    List.iter (fun (lab,kind,_) ->
+      if lab = dummy_method then
+        match Btype.field_kind_repr kind with
+          Fvar r -> Btype.set_kind r Fabsent
+        | _ -> ()
+    ) methods
+  end;
+
+  List.iter Ctype.generalize clty.cty_params;
+  generalize_class_type true clty.cty_type;
+  Option.iter  Ctype.generalize clty.cty_new;
+  List.iter Ctype.generalize obj_abbr.type_params;
+  Option.iter  Ctype.generalize obj_abbr.type_manifest;
+  List.iter Ctype.generalize cl_abbr.type_params;
+  Option.iter  Ctype.generalize cl_abbr.type_manifest;
+
+  if not (closed_class clty) then
+    raise(Error(cl.pci_loc, env, Non_generalizable_class (id, clty)));
+
+  begin match
+    Ctype.closed_class clty.cty_params
+      (Ctype.signature_of_class_type clty.cty_type)
+  with
+    None        -> ()
+  | Some reason ->
+      let printer =
+        if define_class
+        then function ppf -> Printtyp.class_declaration id ppf clty
+        else function ppf -> Printtyp.cltype_declaration id ppf cltydef
+      in
+      raise(Error(cl.pci_loc, env, Unbound_type_var(printer, reason)))
+  end;
+  { id; clty; ty_id; cltydef; obj_id; obj_abbr; cl_id; cl_abbr; arity;
+    pub_meths; coe; expr;
+    id_loc = cl.pci_name;
+    req = { ci_loc = cl.pci_loc;
+            ci_virt = cl.pci_virt;
+            ci_params = ci_params;
+        (* TODO : check that we have the correct use of identifiers *)
+            ci_id_name = cl.pci_name;
+            ci_id_class = id;
+            ci_id_class_type = ty_id;
+            ci_id_object = obj_id;
+            ci_id_typehash = cl_id;
+            ci_expr = expr;
+            ci_decl = clty;
+            ci_type_decl = cltydef;
+            ci_attributes = cl.pci_attributes;
+        }
+  }
+(*   (cl.pci_variance, cl.pci_loc)) *)
+
+let class_infos define_class kind
+    (cl, id, ty_id,
+     obj_id, obj_params, obj_ty,
+     cl_id, cl_params, cl_ty,
+     constr_type, dummy_class)
+    (res, env) =
+  Builtin_attributes.warning_scope cl.pci_attributes
+    (fun () ->
+       class_infos define_class kind
+         (cl, id, ty_id,
+          obj_id, obj_params, obj_ty,
+          cl_id, cl_params, cl_ty,
+          constr_type, dummy_class)
+         (res, env)
+    )
+
+let extract_type_decls { clty; cltydef; obj_id; obj_abbr; cl_abbr; req} decls =
+  (obj_id, obj_abbr, cl_abbr, clty, cltydef, req) :: decls
+
+let merge_type_decls decl (obj_abbr, cl_abbr, clty, cltydef) =
+  {decl with obj_abbr; cl_abbr; clty; cltydef}
+
+let final_env define_class env { id; clty; ty_id; cltydef; obj_id; obj_abbr;
+    cl_id; cl_abbr } =
+  (* Add definitions after cleaning them *)
+  Env.add_type ~check:true obj_id
+    (Subst.type_declaration Subst.identity obj_abbr) (
+  Env.add_type ~check:true cl_id
+    (Subst.type_declaration Subst.identity cl_abbr) (
+  Env.add_cltype ty_id (Subst.cltype_declaration Subst.identity cltydef) (
+  if define_class then
+    Env.add_class id (Subst.class_declaration Subst.identity clty) env
+  else env)))
+
+(* Check that #c is coercible to c if there is a self-coercion *)
+let check_coercions env { id; id_loc; clty; ty_id; cltydef; obj_id; obj_abbr;
+    cl_id; cl_abbr; arity; pub_meths; coe; req } =
+  begin match coe with [] -> ()
+  | loc :: _ ->
+      let cl_ty, obj_ty =
+        match cl_abbr.type_manifest, obj_abbr.type_manifest with
+          Some cl_ab, Some obj_ab ->
+            let cl_params, cl_ty =
+              Ctype.instance_parameterized_type cl_abbr.type_params cl_ab
+            and obj_params, obj_ty =
+              Ctype.instance_parameterized_type obj_abbr.type_params obj_ab
+            in
+            List.iter2 (Ctype.unify env) cl_params obj_params;
+            cl_ty, obj_ty
+        | _ -> assert false
+      in
+      begin try Ctype.subtype env cl_ty obj_ty ()
+      with Ctype.Subtype (tr1, tr2) ->
+        raise(Typecore.Error(loc, env, Typecore.Not_subtype(tr1, tr2)))
+      end;
+      if not (Ctype.opened_object cl_ty) then
+        raise(Error(loc, env, Cannot_coerce_self obj_ty))
+  end;
+  {cls_id = id;
+   cls_id_loc = id_loc;
+   cls_decl = clty;
+   cls_ty_id = ty_id;
+   cls_ty_decl = cltydef;
+   cls_obj_id = obj_id;
+   cls_obj_abbr = obj_abbr;
+   cls_typesharp_id = cl_id;
+   cls_abbr = cl_abbr;
+   cls_arity = arity;
+   cls_pub_methods = pub_meths;
+   cls_info=req}
+
+(*******************************)
+
+let type_classes define_class approx kind env cls =
+  let scope = Ctype.create_scope () in
+  let cls =
+    List.map
+      (function cl ->
+         (cl,
+          Ident.create_scoped ~scope cl.pci_name.txt,
+          Ident.create_scoped ~scope cl.pci_name.txt,
+          Ident.create_scoped ~scope cl.pci_name.txt,
+          Ident.create_scoped ~scope ("#" ^ cl.pci_name.txt),
+          Uid.mk ~current_unit:(Env.get_unit_name ())
+         ))
+      cls
+  in
+  Ctype.begin_class_def ();
+  let (res, env) =
+    List.fold_left (initial_env define_class approx) ([], env) cls
+  in
+  let (res, env) =
+    List.fold_right (class_infos define_class kind) res ([], env)
+  in
+  Ctype.end_def ();
+  let res = List.rev_map (final_decl env define_class) res in
+  let decls = List.fold_right extract_type_decls res [] in
+  let decls =
+    try Typedecl_variance.update_class_decls env decls
+    with Typedecl_variance.Error(loc, err) ->
+      raise (Typedecl.Error(loc, Typedecl.Variance err))
+  in
+  let res = List.map2 merge_type_decls res decls in
+  let env = List.fold_left (final_env define_class) env res in
+  let res = List.map (check_coercions env) res in
+  (res, env)
+
+let class_num = ref 0
+let class_declaration env sexpr =
+  incr class_num;
+  let expr = class_expr (Int.to_string !class_num) env env sexpr in
+  (expr, expr.cl_type)
+
+let class_description env sexpr =
+  let expr = class_type env sexpr in
+  (expr, expr.cltyp_type)
+
+let class_declarations env cls =
+  let info, env =
+    type_classes true approx_declaration class_declaration env cls
+  in
+  let ids, exprs =
+    List.split
+      (List.map
+         (fun ci -> ci.cls_id, ci.cls_info.ci_expr)
+         info)
+  in
+  check_recursive_class_bindings env ids exprs;
+  info, env
+
+let class_descriptions env cls =
+  type_classes true approx_description class_description env cls
+
+let class_type_declarations env cls =
+  let (decls, env) =
+    type_classes false approx_description class_description env cls
+  in
+  (List.map
+     (fun decl ->
+        {clsty_ty_id = decl.cls_ty_id;
+         clsty_id_loc = decl.cls_id_loc;
+         clsty_ty_decl = decl.cls_ty_decl;
+         clsty_obj_id = decl.cls_obj_id;
+         clsty_obj_abbr = decl.cls_obj_abbr;
+         clsty_typesharp_id = decl.cls_typesharp_id;
+         clsty_abbr = decl.cls_abbr;
+         clsty_info = decl.cls_info})
+     decls,
+   env)
+
+let rec unify_parents env ty cl =
+  match cl.cl_desc with
+    Tcl_ident (p, _, _) ->
+      begin try
+        let decl = Env.find_class p env in
+        let _, body = Ctype.find_cltype_for_path env decl.cty_path in
+        Ctype.unify env ty (Ctype.instance body)
+      with
+        Not_found -> ()
+      | _exn -> assert false
+      end
+  | Tcl_structure st -> unify_parents_struct env ty st
+  | Tcl_open (_, cl)
+  | Tcl_fun (_, _, _, cl, _)
+  | Tcl_apply (cl, _)
+  | Tcl_let (_, _, _, cl)
+  | Tcl_constraint (cl, _, _, _, _) -> unify_parents env ty cl
+and unify_parents_struct env ty st =
+  List.iter
+    (function
+      | {cf_desc = Tcf_inherit (_, cl, _, _, _)} ->
+          unify_parents env ty cl
+      | _ -> ())
+    st.cstr_fields
+
+let type_object env loc s =
+  incr class_num;
+  let (desc, sign) =
+    class_structure (Int.to_string !class_num) true env env loc s in
+  let sty = Ctype.expand_head env sign.csig_self in
+  Ctype.hide_private_methods sty;
+  let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in
+  let meths = List.map (fun (s,_,_) -> s) fields in
+  unify_parents_struct env sign.csig_self desc;
+  (desc, sign, meths)
+
+let () =
+  Typecore.type_object := type_object
+
+(*******************************)
+
+(* Approximate the class declaration as class ['params] id = object end *)
+let approx_class sdecl =
+  let open Ast_helper in
+  let self' = Typ.any () in
+  let clty' = Cty.signature ~loc:sdecl.pci_expr.pcty_loc (Csig.mk self' []) in
+  { sdecl with pci_expr = clty' }
+
+let approx_class_declarations env sdecls =
+  fst (class_type_declarations env (List.map approx_class sdecls))
+
+(*******************************)
+
+(* Error report *)
+
+open Format
+
+let report_error env ppf = function
+  | Repeated_parameter ->
+      fprintf ppf "A type parameter occurs several times"
+  | Unconsistent_constraint trace ->
+      fprintf ppf "The class constraints are not consistent.@.";
+      Printtyp.report_unification_error ppf env trace
+        (fun ppf -> fprintf ppf "Type")
+        (fun ppf -> fprintf ppf "is not compatible with type")
+  | Field_type_mismatch (k, m, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "The %s %s@ has type" k m)
+        (function ppf ->
+           fprintf ppf "but is expected to have type")
+  | Structure_expected clty ->
+      fprintf ppf
+        "@[This class expression is not a class structure; it has type@ %a@]"
+        Printtyp.class_type clty
+  | Cannot_apply _ ->
+      fprintf ppf
+        "This class expression is not a class function, it cannot be applied"
+  | Apply_wrong_label l ->
+      let mark_label = function
+        | Nolabel -> "out label"
+        |  l -> sprintf " label %s" (Btype.prefixed_label_name l) in
+      fprintf ppf "This argument cannot be applied with%s" (mark_label l)
+  | Pattern_type_clash ty ->
+      (* XXX Trace *)
+      (* XXX Revoir message d'erreur | Improve error message *)
+      fprintf ppf "@[%s@ %a@]"
+        "This pattern cannot match self: it only matches values of type"
+        Printtyp.type_expr ty
+  | Unbound_class_2 cl ->
+      fprintf ppf "@[The class@ %a@ is not yet completely defined@]"
+      Printtyp.longident cl
+  | Unbound_class_type_2 cl ->
+      fprintf ppf "@[The class type@ %a@ is not yet completely defined@]"
+      Printtyp.longident cl
+  | Abbrev_type_clash (abbrev, actual, expected) ->
+      (* XXX Afficher une trace ? | Print a trace? *)
+      Printtyp.reset_and_mark_loops_list [abbrev; actual; expected];
+      fprintf ppf "@[The abbreviation@ %a@ expands to type@ %a@ \
+       but is used with type@ %a@]"
+        !Oprint.out_type (Printtyp.tree_of_typexp false abbrev)
+        !Oprint.out_type (Printtyp.tree_of_typexp false actual)
+        !Oprint.out_type (Printtyp.tree_of_typexp false expected)
+  | Constructor_type_mismatch (c, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "The expression \"new %s\" has type" c)
+        (function ppf ->
+           fprintf ppf "but is used with type")
+  | Virtual_class (cl, imm, mets, vals) ->
+      let print_mets ppf mets =
+        List.iter (function met -> fprintf ppf "@ %s" met) mets in
+      let missings =
+        match mets, vals with
+          [], _ -> "variables"
+        | _, [] -> "methods"
+        | _ -> "methods and variables"
+      in
+      let print_msg ppf =
+        if imm then fprintf ppf "This object has virtual %s" missings
+        else if cl then fprintf ppf "This class should be virtual"
+        else fprintf ppf "This class type should be virtual"
+      in
+      fprintf ppf
+        "@[%t.@ @[<2>The following %s are undefined :%a@]@]"
+        print_msg missings print_mets (mets @ vals)
+  | Parameter_arity_mismatch(lid, expected, provided) ->
+      fprintf ppf
+        "@[The class constructor %a@ expects %i type argument(s),@ \
+           but is here applied to %i type argument(s)@]"
+        Printtyp.longident lid expected provided
+  | Parameter_mismatch trace ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "The type parameter")
+        (function ppf ->
+           fprintf ppf "does not meet its constraint: it should be")
+  | Bad_parameters (id, params, cstrs) ->
+      Printtyp.reset_and_mark_loops_list [params; cstrs];
+      fprintf ppf
+        "@[The abbreviation %a@ is used with parameters@ %a@ \
+           which are incompatible with constraints@ %a@]"
+        Printtyp.ident id
+        !Oprint.out_type (Printtyp.tree_of_typexp false params)
+        !Oprint.out_type (Printtyp.tree_of_typexp false cstrs)
+  | Class_match_failure error ->
+      Includeclass.report_error ppf error
+  | Unbound_val lab ->
+      fprintf ppf "Unbound instance variable %s" lab
+  | Unbound_type_var (printer, reason) ->
+      let print_common ppf kind ty0 real lab ty =
+        let ty1 =
+          if real then ty0 else Btype.newgenty(Tobject(ty0, ref None)) in
+        List.iter Printtyp.mark_loops [ty; ty1];
+        fprintf ppf
+          "The %s %s@ has type@;<1 2>%a@ where@ %a@ is unbound"
+          kind lab
+          !Oprint.out_type (Printtyp.tree_of_typexp false ty)
+          !Oprint.out_type (Printtyp.tree_of_typexp false ty0)
+      in
+      let print_reason ppf = function
+      | Ctype.CC_Method (ty0, real, lab, ty) ->
+          print_common ppf "method" ty0 real lab ty
+      | Ctype.CC_Value (ty0, real, lab, ty) ->
+          print_common ppf "instance variable" ty0 real lab ty
+      in
+      Printtyp.reset ();
+      fprintf ppf
+        "@[<v>@[Some type variables are unbound in this type:@;<1 2>%t@]@ \
+              @[%a@]@]"
+       printer print_reason reason
+  | Non_generalizable_class (id, clty) ->
+      fprintf ppf
+        "@[The type of this class,@ %a,@ \
+           contains type variables that cannot be generalized@]"
+        (Printtyp.class_declaration id) clty
+  | Cannot_coerce_self ty ->
+      fprintf ppf
+        "@[The type of self cannot be coerced to@ \
+           the type of the current class:@ %a.@.\
+           Some occurrences are contravariant@]"
+        Printtyp.type_scheme ty
+  | Non_collapsable_conjunction (id, clty, trace) ->
+      fprintf ppf
+        "@[The type of this class,@ %a,@ \
+           contains non-collapsible conjunctive types in constraints.@ %t@]"
+        (Printtyp.class_declaration id) clty
+        (fun ppf -> Printtyp.report_unification_error ppf env trace
+            (fun ppf -> fprintf ppf "Type")
+            (fun ppf -> fprintf ppf "is not compatible with type")
+        )
+  | Final_self_clash trace ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "This object is expected to have type")
+        (function ppf ->
+           fprintf ppf "but actually has type")
+  | Mutability_mismatch (_lab, mut) ->
+      let mut1, mut2 =
+        if mut = Immutable then "mutable", "immutable"
+        else "immutable", "mutable" in
+      fprintf ppf
+        "@[The instance variable is %s;@ it cannot be redefined as %s@]"
+        mut1 mut2
+  | No_overriding (_, "") ->
+      fprintf ppf "@[This inheritance does not override any method@ %s@]"
+        "instance variable"
+  | No_overriding (kind, name) ->
+      fprintf ppf "@[The %s `%s'@ has no previous definition@]" kind name
+  | Duplicate (kind, name) ->
+      fprintf ppf "@[The %s `%s'@ has multiple definitions in this object@]"
+                    kind name
+  | Closing_self_type self ->
+    fprintf ppf
+      "@[Cannot close type of object literal:@ %a@,\
+       it has been unified with the self type of a class that is not yet@ \
+       completely defined.@]"
+      Printtyp.type_scheme self
+
+let report_error env ppf err =
+  Printtyp.wrap_printing_env ~error:true
+    env (fun () -> report_error env ppf err)
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, env, err) ->
+        Some (Location.error_of_printer ~loc (report_error env) err)
+      | Error_forward err ->
+        Some err
+      | _ ->
+        None
+    )
diff --git a/upstream/ocaml_411/typing/typeclass.mli b/upstream/ocaml_411/typing/typeclass.mli
new file mode 100644
index 0000000..c350352
--- /dev/null
+++ b/upstream/ocaml_411/typing/typeclass.mli
@@ -0,0 +1,130 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Types
+open Format
+
+type 'a class_info = {
+  cls_id : Ident.t;
+  cls_id_loc : string loc;
+  cls_decl : class_declaration;
+  cls_ty_id : Ident.t;
+  cls_ty_decl : class_type_declaration;
+  cls_obj_id : Ident.t;
+  cls_obj_abbr : type_declaration;
+  cls_typesharp_id : Ident.t;
+  cls_abbr : type_declaration;
+  cls_arity : int;
+  cls_pub_methods : string list;
+  cls_info : 'a;
+}
+
+type class_type_info = {
+  clsty_ty_id : Ident.t;
+  clsty_id_loc : string loc;
+  clsty_ty_decl : class_type_declaration;
+  clsty_obj_id : Ident.t;
+  clsty_obj_abbr : type_declaration;
+  clsty_typesharp_id : Ident.t;
+  clsty_abbr : type_declaration;
+  clsty_info : Typedtree.class_type_declaration;
+}
+
+val class_declarations:
+  Env.t -> Parsetree.class_declaration list ->
+  Typedtree.class_declaration class_info list * Env.t
+
+(*
+and class_declaration =
+  (class_expr, Types.class_declaration) class_infos
+*)
+
+val class_descriptions:
+  Env.t -> Parsetree.class_description list ->
+  Typedtree.class_description class_info list * Env.t
+
+(*
+and class_description =
+  (class_type, unit) class_infos
+*)
+
+val class_type_declarations:
+  Env.t -> Parsetree.class_description list -> class_type_info list * Env.t
+
+(*
+and class_type_declaration =
+  (class_type, Types.class_type_declaration) class_infos
+*)
+
+val approx_class_declarations:
+  Env.t -> Parsetree.class_description list -> class_type_info list
+
+val virtual_methods: Types.class_signature -> label list
+
+(*
+val type_classes :
+           bool ->
+           ('a -> Types.type_expr) ->
+           (Env.t -> 'a -> 'b * Types.class_type) ->
+           Env.t ->
+           'a Parsetree.class_infos list ->
+  (  Ident.t * Types.class_declaration *
+     Ident.t * Types.class_type_declaration *
+     Ident.t * Types.type_declaration *
+     Ident.t * Types.type_declaration *
+     int * string list * 'b * 'b Typedtree.class_infos)
+           list * Env.t
+*)
+
+type error =
+    Unconsistent_constraint of Ctype.Unification_trace.t
+  | Field_type_mismatch of string * string * Ctype.Unification_trace.t
+  | Structure_expected of class_type
+  | Cannot_apply of class_type
+  | Apply_wrong_label of arg_label
+  | Pattern_type_clash of type_expr
+  | Repeated_parameter
+  | Unbound_class_2 of Longident.t
+  | Unbound_class_type_2 of Longident.t
+  | Abbrev_type_clash of type_expr * type_expr * type_expr
+  | Constructor_type_mismatch of string * Ctype.Unification_trace.t
+  | Virtual_class of bool * bool * string list * string list
+  | Parameter_arity_mismatch of Longident.t * int * int
+  | Parameter_mismatch of Ctype.Unification_trace.t
+  | Bad_parameters of Ident.t * type_expr * type_expr
+  | Class_match_failure of Ctype.class_match_failure list
+  | Unbound_val of string
+  | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure
+  | Non_generalizable_class of Ident.t * Types.class_declaration
+  | Cannot_coerce_self of type_expr
+  | Non_collapsable_conjunction of
+      Ident.t * Types.class_declaration * Ctype.Unification_trace.t
+  | Final_self_clash of Ctype.Unification_trace.t
+  | Mutability_mismatch of string * mutable_flag
+  | No_overriding of string * string
+  | Duplicate of string * string
+  | Closing_self_type of type_expr
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+val report_error : Env.t -> formatter -> error -> unit
+
+(* Forward decl filled in by Typemod.type_open_descr *)
+val type_open_descr :
+  (?used_slot:bool ref ->
+   Env.t -> Parsetree.open_description -> Typedtree.open_description * Env.t)
+    ref
diff --git a/upstream/ocaml_411/typing/typecore.ml b/upstream/ocaml_411/typing/typecore.ml
new file mode 100644
index 0000000..995ee91
--- /dev/null
+++ b/upstream/ocaml_411/typing/typecore.ml
@@ -0,0 +1,5550 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Typechecking for the core language *)
+
+open Misc
+open Asttypes
+open Parsetree
+open Types
+open Typedtree
+open Btype
+open Ctype
+
+type type_forcing_context =
+  | If_conditional
+  | If_no_else_branch
+  | While_loop_conditional
+  | While_loop_body
+  | For_loop_start_index
+  | For_loop_stop_index
+  | For_loop_body
+  | Assert_condition
+  | Sequence_left_hand_side
+  | When_guard
+
+type type_expected = {
+  ty: type_expr;
+  explanation: type_forcing_context option;
+}
+
+module Datatype_kind = struct
+  type t = Record | Variant
+
+  let type_name = function
+    | Record -> "record"
+    | Variant -> "variant"
+
+  let label_name = function
+    | Record -> "field"
+    | Variant -> "constructor"
+end
+
+type wrong_name = {
+  type_path: Path.t;
+  kind: Datatype_kind.t;
+  name: string loc;
+  valid_names: string list;
+}
+
+type existential_restriction =
+  | At_toplevel (** no existential types at the toplevel *)
+  | In_group (** nor with let ... and ... *)
+  | In_rec (** or recursive definition *)
+  | With_attributes (** or let[@any_attribute] = ... *)
+  | In_class_args (** or in class arguments *)
+  | In_class_def  (** or in [class c = let ... in ...] *)
+  | In_self_pattern (** or in self pattern *)
+
+type error =
+  | Constructor_arity_mismatch of Longident.t * int * int
+  | Label_mismatch of Longident.t * Ctype.Unification_trace.t
+  | Pattern_type_clash :
+      Ctype.Unification_trace.t * _ pattern_desc option -> error
+  | Or_pattern_type_clash of Ident.t * Ctype.Unification_trace.t
+  | Multiply_bound_variable of string
+  | Orpat_vars of Ident.t * Ident.t list
+  | Expr_type_clash of
+      Ctype.Unification_trace.t * type_forcing_context option
+      * expression_desc option
+  | Apply_non_function of type_expr
+  | Apply_wrong_label of arg_label * type_expr * bool
+  | Label_multiply_defined of string
+  | Label_missing of Ident.t list
+  | Label_not_mutable of Longident.t
+  | Wrong_name of string * type_expected * wrong_name
+  | Name_type_mismatch of
+      Datatype_kind.t * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list
+  | Invalid_format of string
+  | Undefined_method of type_expr * string * string list option
+  | Undefined_inherited_method of string * string list
+  | Virtual_class of Longident.t
+  | Private_type of type_expr
+  | Private_label of Longident.t * type_expr
+  | Private_constructor of constructor_description * type_expr
+  | Unbound_instance_variable of string * string list
+  | Instance_variable_not_mutable of string
+  | Not_subtype of Ctype.Unification_trace.t * Ctype.Unification_trace.t
+  | Outside_class
+  | Value_multiply_overridden of string
+  | Coercion_failure of
+      type_expr * type_expr * Ctype.Unification_trace.t * bool
+  | Too_many_arguments of bool * type_expr * type_forcing_context option
+  | Abstract_wrong_label of arg_label * type_expr * type_forcing_context option
+  | Scoping_let_module of string * type_expr
+  | Not_a_variant_type of Longident.t
+  | Incoherent_label_order
+  | Less_general of string * Ctype.Unification_trace.t
+  | Modules_not_allowed
+  | Cannot_infer_signature
+  | Not_a_packed_module of type_expr
+  | Unexpected_existential of existential_restriction * string * string list
+  | Invalid_interval
+  | Invalid_for_loop_index
+  | No_value_clauses
+  | Exception_pattern_disallowed
+  | Mixed_value_and_exception_patterns_under_guard
+  | Inlined_record_escape
+  | Inlined_record_expected
+  | Unrefuted_pattern of pattern
+  | Invalid_extension_constructor_payload
+  | Not_an_extension_constructor
+  | Literal_overflow of string
+  | Unknown_literal of string * char
+  | Illegal_letrec_pat
+  | Illegal_letrec_expr
+  | Illegal_class_expr
+  | Letop_type_clash of string * Ctype.Unification_trace.t
+  | Andop_type_clash of string * Ctype.Unification_trace.t
+  | Bindings_type_clash of Ctype.Unification_trace.t
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+(* Forward declaration, to be filled in by Typemod.type_module *)
+
+let type_module =
+  ref ((fun _env _md -> assert false) :
+       Env.t -> Parsetree.module_expr -> Typedtree.module_expr)
+
+(* Forward declaration, to be filled in by Typemod.type_open *)
+
+let type_open :
+  (?used_slot:bool ref -> override_flag -> Env.t -> Location.t ->
+   Longident.t loc -> Path.t * Env.t)
+    ref =
+  ref (fun ?used_slot:_ _ -> assert false)
+
+let type_open_decl :
+  (?used_slot:bool ref -> Env.t -> Parsetree.open_declaration
+   -> open_declaration * Types.signature * Env.t)
+    ref =
+  ref (fun ?used_slot:_ _ -> assert false)
+
+(* Forward declaration, to be filled in by Typemod.type_package *)
+
+let type_package =
+  ref (fun _ -> assert false)
+
+(* Forward declaration, to be filled in by Typeclass.class_structure *)
+let type_object =
+  ref (fun _env _s -> assert false :
+       Env.t -> Location.t -> Parsetree.class_structure ->
+         Typedtree.class_structure * Types.class_signature * string list)
+
+(*
+  Saving and outputting type information.
+  We keep these function names short, because they have to be
+  called each time we create a record of type [Typedtree.expression]
+  or [Typedtree.pattern] that will end up in the typed AST.
+*)
+let re node =
+  Cmt_format.add_saved_type (Cmt_format.Partial_expression node);
+  node
+;;
+let rp node =
+  Cmt_format.add_saved_type (Cmt_format.Partial_pattern (Value, node));
+  node
+;;
+let rcp node =
+  Cmt_format.add_saved_type (Cmt_format.Partial_pattern (Computation, node));
+  node
+;;
+
+
+type recarg =
+  | Allowed
+  | Required
+  | Rejected
+
+
+let mk_expected ?explanation ty = { ty; explanation; }
+
+let case lhs rhs =
+  {c_lhs = lhs; c_guard = None; c_rhs = rhs}
+
+(* Typing of constants *)
+
+let type_constant = function
+    Const_int _ -> instance Predef.type_int
+  | Const_char _ -> instance Predef.type_char
+  | Const_string _ -> instance Predef.type_string
+  | Const_float _ -> instance Predef.type_float
+  | Const_int32 _ -> instance Predef.type_int32
+  | Const_int64 _ -> instance Predef.type_int64
+  | Const_nativeint _ -> instance Predef.type_nativeint
+
+let constant : Parsetree.constant -> (Asttypes.constant, error) result =
+  function
+  | Pconst_integer (i,None) ->
+     begin
+       try Ok (Const_int (Misc.Int_literal_converter.int i))
+       with Failure _ -> Error (Literal_overflow "int")
+     end
+  | Pconst_integer (i,Some 'l') ->
+     begin
+       try Ok (Const_int32 (Misc.Int_literal_converter.int32 i))
+       with Failure _ -> Error (Literal_overflow "int32")
+     end
+  | Pconst_integer (i,Some 'L') ->
+     begin
+       try Ok (Const_int64 (Misc.Int_literal_converter.int64 i))
+       with Failure _ -> Error (Literal_overflow "int64")
+     end
+  | Pconst_integer (i,Some 'n') ->
+     begin
+       try Ok (Const_nativeint (Misc.Int_literal_converter.nativeint i))
+       with Failure _ -> Error (Literal_overflow "nativeint")
+     end
+  | Pconst_integer (i,Some c) -> Error (Unknown_literal (i, c))
+  | Pconst_char c -> Ok (Const_char c)
+  | Pconst_string (s,loc,d) -> Ok (Const_string (s,loc,d))
+  | Pconst_float (f,None)-> Ok (Const_float f)
+  | Pconst_float (f,Some c) -> Error (Unknown_literal (f, c))
+
+let constant_or_raise env loc cst =
+  match constant cst with
+  | Ok c -> c
+  | Error err -> raise (Error (loc, env, err))
+
+(* Specific version of type_option, using newty rather than newgenty *)
+
+let type_option ty =
+  newty (Tconstr(Predef.path_option,[ty], ref Mnil))
+
+let mkexp exp_desc exp_type exp_loc exp_env =
+  { exp_desc; exp_type; exp_loc; exp_env; exp_extra = []; exp_attributes = [] }
+
+let option_none env ty loc =
+  let lid = Longident.Lident "None" in
+  let cnone = Env.find_ident_constructor Predef.ident_none env in
+  mkexp (Texp_construct(mknoloc lid, cnone, [])) ty loc env
+
+let option_some env texp =
+  let lid = Longident.Lident "Some" in
+  let csome = Env.find_ident_constructor Predef.ident_some env in
+  mkexp ( Texp_construct(mknoloc lid , csome, [texp]) )
+    (type_option texp.exp_type) texp.exp_loc texp.exp_env
+
+let extract_option_type env ty =
+  match expand_head env ty with {desc = Tconstr(path, [ty], _)}
+    when Path.same path Predef.path_option -> ty
+  | _ -> assert false
+
+let extract_concrete_record env ty =
+  match extract_concrete_typedecl env ty with
+    (p0, p, {type_kind=Type_record (fields, _)}) -> (p0, p, fields)
+  | _ -> raise Not_found
+
+let extract_concrete_variant env ty =
+  match extract_concrete_typedecl env ty with
+    (p0, p, {type_kind=Type_variant cstrs}) -> (p0, p, cstrs)
+  | (p0, p, {type_kind=Type_open}) -> (p0, p, [])
+  | _ -> raise Not_found
+
+let extract_label_names env ty =
+  try
+    let (_, _,fields) = extract_concrete_record env ty in
+    List.map (fun l -> l.Types.ld_id) fields
+  with Not_found ->
+    assert false
+
+(* Typing of patterns *)
+
+(* unification inside type_exp and type_expect *)
+let unify_exp_types loc env ty expected_ty =
+  (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type
+    Printtyp.raw_type_expr expected_ty; *)
+  try
+    unify env ty expected_ty
+  with
+    Unify trace ->
+      raise(Error(loc, env, Expr_type_clash(trace, None, None)))
+  | Tags(l1,l2) ->
+      raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2)))
+
+(* level at which to create the local type declarations *)
+let gadt_equations_level = ref None
+let get_gadt_equations_level () =
+  match !gadt_equations_level with
+    Some y -> y
+  | None -> assert false
+
+(* unification inside type_pat*)
+let unify_pat_types ?(refine=false) loc env ty ty' =
+  try
+    if refine then
+      unify_gadt ~equations_level:(get_gadt_equations_level ()) env ty ty'
+    else
+      unify !env ty ty'
+  with
+  | Unify trace ->
+      raise(Error(loc, !env, Pattern_type_clash(trace, None)))
+  | Tags(l1,l2) ->
+      raise(Typetexp.Error(loc, !env, Typetexp.Variant_tags (l1, l2)))
+
+let unify_pat ?refine env pat expected_ty =
+  try unify_pat_types ?refine pat.pat_loc env pat.pat_type expected_ty
+  with Error (loc, env, Pattern_type_clash(trace, None)) ->
+    raise(Error(loc, env, Pattern_type_clash(trace, Some pat.pat_desc)))
+
+(* Creating new conjunctive types is not allowed when typing patterns *)
+(* make all Reither present in open variants *)
+let finalize_variant pat tag opat r =
+  let row =
+    match expand_head pat.pat_env pat.pat_type with
+      {desc = Tvariant row} -> r := row; row_repr row
+    | _ -> assert false
+  in
+  begin match row_field tag row with
+  | Rabsent -> () (* assert false *)
+  | Reither (true, [], _, e) when not row.row_closed ->
+      set_row_field e (Rpresent None)
+  | Reither (false, ty::tl, _, e) when not row.row_closed ->
+      set_row_field e (Rpresent (Some ty));
+      begin match opat with None -> assert false
+      | Some pat ->
+          let env = ref pat.pat_env in List.iter (unify_pat env pat) (ty::tl)
+      end
+  | Reither (c, _l, true, e) when not (row_fixed row) ->
+      set_row_field e (Reither (c, [], false, ref None))
+  | _ -> ()
+  end
+  (* Force check of well-formedness   WHY? *)
+  (* unify_pat pat.pat_env pat
+    (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false;
+                    row_bound=(); row_fixed=false; row_name=None})); *)
+
+let has_variants p =
+  exists_general_pattern
+    { f = fun (type k) (p : k general_pattern) -> match p.pat_desc with
+     | (Tpat_variant _) -> true
+     | _ -> false } p
+
+let finalize_variants p =
+  iter_general_pattern
+    { f = fun (type k) (p : k general_pattern) -> match p.pat_desc with
+     | Tpat_variant(tag, opat, r) ->
+        finalize_variant p tag opat r
+     | _ -> () } p
+
+(* pattern environment *)
+type pattern_variable =
+  {
+    pv_id: Ident.t;
+    pv_type: type_expr;
+    pv_loc: Location.t;
+    pv_as_var: bool;
+    pv_attributes: attributes;
+  }
+
+type module_variable =
+  string loc * Location.t
+
+let pattern_variables = ref ([] : pattern_variable list)
+let pattern_force = ref ([] : (unit -> unit) list)
+let pattern_scope = ref (None : Annot.ident option);;
+let allow_modules = ref false
+let module_variables = ref ([] : module_variable list)
+let reset_pattern scope allow =
+  pattern_variables := [];
+  pattern_force := [];
+  pattern_scope := scope;
+  allow_modules := allow;
+  module_variables := [];
+;;
+
+let maybe_add_pattern_variables_ghost loc_let env pv =
+  List.fold_right
+    (fun {pv_id; _} env ->
+       let name = Ident.name pv_id in
+       if Env.bound_value name env then env
+       else begin
+         Env.enter_unbound_value name
+           (Val_unbound_ghost_recursive loc_let) env
+       end
+    ) pv env
+
+let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty
+    attrs =
+  if List.exists (fun {pv_id; _} -> Ident.name pv_id = name.txt)
+      !pattern_variables
+  then raise(Error(loc, Env.empty, Multiply_bound_variable name.txt));
+  let id = Ident.create_local name.txt in
+  pattern_variables :=
+    {pv_id = id;
+     pv_type = ty;
+     pv_loc = loc;
+     pv_as_var = is_as_variable;
+     pv_attributes = attrs} :: !pattern_variables;
+  if is_module then begin
+    (* Note: unpack patterns enter a variable of the same name *)
+    if not !allow_modules then
+      raise (Error (loc, Env.empty, Modules_not_allowed));
+    module_variables := (name, loc) :: !module_variables
+  end;
+  id
+
+let sort_pattern_variables vs =
+  List.sort
+    (fun {pv_id = x; _} {pv_id = y; _} ->
+      Stdlib.compare (Ident.name x) (Ident.name y))
+    vs
+
+let enter_orpat_variables loc env  p1_vs p2_vs =
+  (* unify_vars operate on sorted lists *)
+
+  let p1_vs = sort_pattern_variables p1_vs
+  and p2_vs = sort_pattern_variables p2_vs in
+
+  let rec unify_vars p1_vs p2_vs =
+    let vars vs = List.map (fun {pv_id; _} -> pv_id) vs in
+    match p1_vs, p2_vs with
+      | {pv_id = x1; pv_type = t1; _}::rem1, {pv_id = x2; pv_type = t2; _}::rem2
+        when Ident.equal x1 x2 ->
+          if x1==x2 then
+            unify_vars rem1 rem2
+          else begin
+            begin try
+              unify_var env (newvar ()) t1;
+              unify env t1 t2
+            with
+            | Unify trace ->
+                raise(Error(loc, env, Or_pattern_type_clash(x1, trace)))
+            end;
+          (x2,x1)::unify_vars rem1 rem2
+          end
+      | [],[] -> []
+      | {pv_id; _}::_, [] | [],{pv_id; _}::_ ->
+          raise (Error (loc, env, Orpat_vars (pv_id, [])))
+      | {pv_id = x; _}::_, {pv_id = y; _}::_ ->
+          let err =
+            if Ident.name x < Ident.name y
+            then Orpat_vars (x, vars p2_vs)
+            else Orpat_vars (y, vars p1_vs) in
+          raise (Error (loc, env, err)) in
+  unify_vars p1_vs p2_vs
+
+let rec build_as_type env p =
+  match p.pat_desc with
+    Tpat_alias(p1,_, _) -> build_as_type env p1
+  | Tpat_tuple pl ->
+      let tyl = List.map (build_as_type env) pl in
+      newty (Ttuple tyl)
+  | Tpat_construct(_, cstr, pl) ->
+      let keep = cstr.cstr_private = Private || cstr.cstr_existentials <> [] in
+      if keep then p.pat_type else
+      let tyl = List.map (build_as_type env) pl in
+      let ty_args, ty_res = instance_constructor cstr in
+      List.iter2 (fun (p,ty) -> unify_pat env {p with pat_type = ty})
+        (List.combine pl tyl) ty_args;
+      ty_res
+  | Tpat_variant(l, p', _) ->
+      let ty = Option.map (build_as_type env) p' in
+      newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar();
+                      row_bound=(); row_name=None;
+                      row_fixed=None; row_closed=false})
+  | Tpat_record (lpl,_) ->
+      let lbl = snd3 (List.hd lpl) in
+      if lbl.lbl_private = Private then p.pat_type else
+      let ty = newvar () in
+      let ppl = List.map (fun (_, l, p) -> l.lbl_pos, p) lpl in
+      let do_label lbl =
+        let _, ty_arg, ty_res = instance_label false lbl in
+        unify_pat env {p with pat_type = ty} ty_res;
+        let refinable =
+          lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl &&
+          match (repr lbl.lbl_arg).desc with Tpoly _ -> false | _ -> true in
+        if refinable then begin
+          let arg = List.assoc lbl.lbl_pos ppl in
+          unify_pat env {arg with pat_type = build_as_type env arg} ty_arg
+        end else begin
+          let _, ty_arg', ty_res' = instance_label false lbl in
+          unify !env ty_arg ty_arg';
+          unify_pat env p ty_res'
+        end in
+      Array.iter do_label lbl.lbl_all;
+      ty
+  | Tpat_or(p1, p2, row) ->
+      begin match row with
+        None ->
+          let ty1 = build_as_type env p1 and ty2 = build_as_type env p2 in
+          unify_pat env {p2 with pat_type = ty2} ty1;
+          ty1
+      | Some row ->
+          let row = row_repr row in
+          newty (Tvariant{row with row_closed=false; row_more=newvar()})
+      end
+  | Tpat_any | Tpat_var _ | Tpat_constant _
+  | Tpat_array _ | Tpat_lazy _ -> p.pat_type
+
+let build_or_pat env loc lid =
+  let path, decl = Env.lookup_type ~loc:lid.loc lid.txt env in
+  let tyl = List.map (fun _ -> newvar()) decl.type_params in
+  let row0 =
+    let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in
+    match ty.desc with
+      Tvariant row when static_row row -> row
+    | _ -> raise(Error(lid.loc, env, Not_a_variant_type lid.txt))
+  in
+  let pats, fields =
+    List.fold_left
+      (fun (pats,fields) (l,f) ->
+        match row_field_repr f with
+          Rpresent None ->
+            (l,None) :: pats,
+            (l, Reither(true,[], true, ref None)) :: fields
+        | Rpresent (Some ty) ->
+            (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env;
+                      pat_type=ty; pat_extra=[]; pat_attributes=[]})
+            :: pats,
+            (l, Reither(false, [ty], true, ref None)) :: fields
+        | _ -> pats, fields)
+      ([],[]) (row_repr row0).row_fields in
+  let row =
+    { row_fields = List.rev fields; row_more = newvar(); row_bound = ();
+      row_closed = false; row_fixed = None; row_name = Some (path, tyl) }
+  in
+  let ty = newty (Tvariant row) in
+  let gloc = {loc with Location.loc_ghost=true} in
+  let row' = ref {row with row_more=newvar()} in
+  let pats =
+    List.map
+      (fun (l,p) ->
+        {pat_desc=Tpat_variant(l,p,row'); pat_loc=gloc;
+         pat_env=env; pat_type=ty; pat_extra=[]; pat_attributes=[]})
+      pats
+  in
+  match pats with
+    [] ->
+      (* empty polymorphic variants: not possible with the concrete language
+         but valid at the ast level *)
+      raise(Error(lid.loc, env, Not_a_variant_type lid.txt))
+  | pat :: pats ->
+      let r =
+        List.fold_left
+          (fun pat pat0 ->
+            {pat_desc=Tpat_or(pat0,pat,Some row0); pat_extra=[];
+             pat_loc=gloc; pat_env=env; pat_type=ty; pat_attributes=[]})
+          pat pats in
+      (path, rp { r with pat_loc = loc },ty)
+
+let split_cases env cases =
+  let add_case lst case = function
+    | None -> lst
+    | Some c_lhs -> { case with c_lhs } :: lst
+  in
+  List.fold_right (fun ({ c_lhs; c_guard } as case) (vals, exns) ->
+    match split_pattern c_lhs with
+    | Some _, Some _ when c_guard <> None ->
+      raise (Error (c_lhs.pat_loc, env,
+                    Mixed_value_and_exception_patterns_under_guard))
+    | vp, ep -> add_case vals case vp, add_case exns case ep
+  ) cases ([], [])
+
+(* Type paths *)
+
+let rec expand_path env p =
+  let decl =
+    try Some (Env.find_type p env) with Not_found -> None
+  in
+  match decl with
+    Some {type_manifest = Some ty} ->
+      begin match repr ty with
+        {desc=Tconstr(p,_,_)} -> expand_path env p
+      | _ -> assert false
+      end
+  | _ ->
+      let p' = Env.normalize_type_path None env p in
+      if Path.same p p' then p else expand_path env p'
+
+let compare_type_path env tpath1 tpath2 =
+  Path.same (expand_path env tpath1) (expand_path env tpath2)
+
+(* Records *)
+exception Wrong_name_disambiguation of Env.t * wrong_name
+
+let get_constr_type_path ty =
+  match (repr ty).desc with
+  | Tconstr(p, _, _) -> p
+  | _ -> assert false
+
+module NameChoice(Name : sig
+  type t
+  type usage
+  val kind: Datatype_kind.t
+  val get_name: t -> string
+  val get_type: t -> type_expr
+  val lookup_all_from_type:
+    Location.t -> usage -> Path.t -> Env.t -> (t * (unit -> unit)) list
+
+  (** Some names (for example the fields of inline records) are not
+      in the typing environment -- they behave as structural labels
+      rather than nominal labels.*)
+  val in_env: t -> bool
+end) = struct
+  open Name
+
+  let get_type_path d = get_constr_type_path (get_type d)
+
+  let lookup_from_type env type_path usage lid =
+    let descrs = lookup_all_from_type lid.loc usage type_path env in
+    match lid.txt with
+    | Longident.Lident name -> begin
+        match
+          List.find (fun (nd, _) -> get_name nd = name) descrs
+        with
+        | descr, use ->
+            use ();
+            descr
+        | exception Not_found ->
+            let valid_names = List.map (fun (nd, _) -> get_name nd) descrs in
+            raise (Wrong_name_disambiguation (env, {
+                    type_path;
+                    name = { lid with txt = name };
+                    kind;
+                    valid_names;
+              }))
+      end
+    | _ -> raise Not_found
+
+  let rec unique eq acc = function
+      [] -> List.rev acc
+    | x :: rem ->
+        if List.exists (eq x) acc then unique eq acc rem
+        else unique eq (x :: acc) rem
+
+  let ambiguous_types env lbl others =
+    let tpath = get_type_path lbl in
+    let others =
+      List.map (fun (lbl, _) -> get_type_path lbl) others in
+    let tpaths = unique (compare_type_path env) [tpath] others in
+    match tpaths with
+      [_] -> []
+    | _ -> let open Printtyp in
+        wrap_printing_env ~error:true env (fun () ->
+            reset(); strings_of_paths Type tpaths)
+
+  let disambiguate_by_type env tpath lbls =
+    match lbls with
+    | (Error _ : _ result) -> raise Not_found
+    | Ok lbls ->
+        let check_type (lbl, _) =
+          let lbl_tpath = get_type_path lbl in
+          compare_type_path env tpath lbl_tpath
+        in
+        List.find check_type lbls
+
+  (* warn if there are several distinct candidates in scope *)
+  let warn_if_ambiguous warn lid env lbl rest =
+    Printtyp.Conflicts.reset ();
+    let paths = ambiguous_types env lbl rest in
+    let expansion =
+      Format.asprintf "%t" Printtyp.Conflicts.print_explanations in
+    if paths <> [] then
+      warn lid.loc
+        (Warnings.Ambiguous_name ([Longident.last lid.txt],
+                                  paths, false, expansion))
+
+  (* a non-principal type was used for disambiguation *)
+  let warn_non_principal warn lid =
+    let name = Datatype_kind.label_name kind in
+    warn lid.loc
+      (Warnings.Not_principal
+         ("this type-based " ^ name ^ " disambiguation"))
+
+  (* we selected a name out of the lexical scope *)
+  let warn_out_of_scope warn lid env tpath =
+    let path_s =
+      Printtyp.wrap_printing_env ~error:true env
+        (fun () -> Printtyp.string_of_path tpath) in
+    warn lid.loc
+      (Warnings.Name_out_of_scope (path_s, [Longident.last lid.txt], false))
+
+  (* warn if the selected name is not the last introduced in scope
+     -- in these cases the resolution is different from pre-disambiguation OCaml
+     (this warning is not enabled by default, it is specifically for people
+      wishing to write backward-compatible code).
+   *)
+  let warn_if_disambiguated_name warn lid lbl scope =
+    match scope with
+    | Ok ((lab1,_) :: _) when lab1 == lbl -> ()
+    | _ ->
+        warn lid.loc
+          (Warnings.Disambiguated_name (get_name lbl))
+
+  let force_error : ('a, _) result -> 'a = function
+    | Ok lbls -> lbls
+    | Error (loc', env', err) ->
+       Env.lookup_error loc' env' err
+
+  type candidate = t * (unit -> unit)
+  type nonempty_candidate_filter =
+    candidate list -> (candidate list, candidate list) result
+  (** This type is used for candidate filtering functions.
+      Filtering typically proceeds in several passes, filtering
+      candidates through increasingly precise conditions.
+
+      We assume that the input list is non-empty, and the output is one of
+      - [Ok result] for a non-empty list [result] of valid candidates
+      - [Error candidates] with there are no valid candidates,
+        and [candidates] is a non-empty subset of the input, typically
+        the result of the last non-empty filtering step.
+   *)
+
+  (** [disambiguate] selects a concrete description for [lid] using
+     some contextual information:
+     - An optional [expected_type].
+     - A list of candidates labels in the current lexical scope,
+       [candidates_in_scope], that is actually at the type
+       [(label_descr list, lookup_error) result] so that the
+       lookup error is only raised when necessary.
+     - A filtering criterion on candidates in scope [filter_candidates],
+       representing extra contextual information that can help
+       candidate selection (see [disambiguate_label_by_ids]).
+   *)
+  let disambiguate
+        ?(warn=Location.prerr_warning)
+        ?(filter : nonempty_candidate_filter = Result.ok)
+        usage lid env
+        expected_type
+        candidates_in_scope =
+    let lbl = match expected_type with
+    | None ->
+        (* no expected type => no disambiguation *)
+        begin match filter (force_error candidates_in_scope) with
+        | Ok [] | Error [] -> assert false
+        | Error((lbl, _use) :: _rest) -> lbl (* will fail later *)
+        | Ok((lbl, use) :: rest) ->
+            use ();
+            warn_if_ambiguous warn lid env lbl rest;
+            lbl
+        end
+    | Some(tpath0, tpath, principal) ->
+       (* If [expected_type] is available, the candidate selected
+          will correspond to the type-based resolution.
+          There are two reasons to still check the lexical scope:
+          - for warning purposes
+          - for extension types, the type environment does not contain
+            a list of constructors, so using only type-based selection
+            would fail.
+        *)
+        (* note that [disambiguate_by_type] does not
+           force [candidates_in_scope]: we just skip this case if there
+           are no candidates in scope *)
+        begin match disambiguate_by_type env tpath candidates_in_scope with
+        | lbl, use ->
+          use ();
+          if not principal then begin
+            (* Check if non-principal type is affecting result *)
+            match (candidates_in_scope : _ result) with
+            | Error _ -> warn_non_principal warn lid
+            | Ok lbls ->
+            match filter lbls with
+            | Error _ -> warn_non_principal warn lid
+            | Ok [] -> assert false
+            | Ok ((lbl', _use') :: rest) ->
+            let lbl_tpath = get_type_path lbl' in
+            (* no principality warning if the non-principal
+               type-based selection corresponds to the last
+               definition in scope *)
+            if not (compare_type_path env tpath lbl_tpath)
+            then warn_non_principal warn lid
+            else warn_if_ambiguous warn lid env lbl rest;
+          end;
+          lbl
+        | exception Not_found ->
+        (* look outside the lexical scope *)
+        match lookup_from_type env tpath usage lid with
+        | lbl ->
+          (* warn only on nominal labels;
+             structural labels cannot be qualified anyway *)
+          if in_env lbl then warn_out_of_scope warn lid env tpath;
+          if not principal then warn_non_principal warn lid;
+          lbl
+        | exception Not_found ->
+        match filter (force_error candidates_in_scope) with
+        | Ok lbls | Error lbls ->
+        let tp = (tpath0, expand_path env tpath) in
+        let tpl =
+          List.map
+            (fun (lbl, _) ->
+               let tp0 = get_type_path lbl in
+               let tp = expand_path env tp0 in
+               (tp0, tp))
+            lbls
+        in
+        raise (Error (lid.loc, env,
+                      Name_type_mismatch (kind, lid.txt, tp, tpl)));
+        end
+    in
+    (* warn only on nominal labels *)
+    if in_env lbl then
+      warn_if_disambiguated_name warn lid lbl candidates_in_scope;
+    lbl
+end
+
+let wrap_disambiguate msg ty f x =
+  try f x with
+  | Wrong_name_disambiguation (env, wrong_name) ->
+    raise (Error (wrong_name.name.loc, env, Wrong_name (msg, ty, wrong_name)))
+
+module Label = NameChoice (struct
+  type t = label_description
+  type usage = unit
+  let kind = Datatype_kind.Record
+  let get_name lbl = lbl.lbl_name
+  let get_type lbl = lbl.lbl_res
+  let lookup_all_from_type loc () path env =
+    Env.lookup_all_labels_from_type ~loc path env
+  let in_env lbl =
+    match lbl.lbl_repres with
+    | Record_regular | Record_float | Record_unboxed false -> true
+    | Record_unboxed true | Record_inlined _ | Record_extension _ -> false
+end)
+
+(* In record-construction expressions and patterns, we have many labels
+   at once; find a candidate type in the intersection of the candidates
+   of each label. In the [closed] expression case, this candidate must
+   contain exactly all the labels.
+
+   If our successive refinements result in an empty list,
+   return [Error] with the last non-empty list of candidates
+   for use in error messages.
+*)
+let disambiguate_label_by_ids closed ids labels  : (_, _) result =
+  let check_ids (lbl, _) =
+    let lbls = Hashtbl.create 8 in
+    Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl.lbl_all;
+    List.for_all (Hashtbl.mem lbls) ids
+  and check_closed (lbl, _) =
+    (not closed || List.length ids = Array.length lbl.lbl_all)
+  in
+  match List.filter check_ids labels with
+  | [] -> Error labels
+  | labels ->
+  match List.filter check_closed labels with
+  | [] -> Error labels
+  | labels ->
+  Ok labels
+
+(* Only issue warnings once per record constructor/pattern *)
+let disambiguate_lid_a_list loc closed env expected_type lid_a_list =
+  let ids = List.map (fun (lid, _) -> Longident.last lid.txt) lid_a_list in
+  let w_pr = ref false and w_amb = ref []
+  and w_scope = ref [] and w_scope_ty = ref "" in
+  let warn loc msg =
+    let open Warnings in
+    match msg with
+    | Not_principal _ -> w_pr := true
+    | Ambiguous_name([s], l, _, ex) -> w_amb := (s, l, ex) :: !w_amb
+    | Name_out_of_scope(ty, [s], _) ->
+        w_scope := s :: !w_scope; w_scope_ty := ty
+    | _ -> Location.prerr_warning loc msg
+  in
+  let process_label lid =
+    let scope = Env.lookup_all_labels ~loc:lid.loc lid.txt env in
+    let filter : Label.nonempty_candidate_filter =
+      disambiguate_label_by_ids closed ids in
+    Label.disambiguate ~warn ~filter () lid env expected_type scope in
+  let lbl_a_list =
+    List.map (fun (lid,a) -> lid, process_label lid, a) lid_a_list in
+  if !w_pr then
+    Location.prerr_warning loc
+      (Warnings.Not_principal "this type-based record disambiguation")
+  else begin
+    match List.rev !w_amb with
+      (_,types,ex)::_ as amb ->
+        let paths =
+          List.map (fun (_,lbl,_) -> Label.get_type_path lbl) lbl_a_list in
+        let path = List.hd paths in
+        let fst3 (x,_,_) = x in
+        if List.for_all (compare_type_path env path) (List.tl paths) then
+          Location.prerr_warning loc
+            (Warnings.Ambiguous_name (List.map fst3 amb, types, true, ex))
+        else
+          List.iter
+            (fun (s,l,ex) -> Location.prerr_warning loc
+                (Warnings.Ambiguous_name ([s],l,false, ex)))
+            amb
+    | _ -> ()
+  end;
+  if !w_scope <> [] then
+    Location.prerr_warning loc
+      (Warnings.Name_out_of_scope (!w_scope_ty, List.rev !w_scope, true));
+  lbl_a_list
+
+let rec find_record_qual = function
+  | [] -> None
+  | ({ txt = Longident.Ldot (modname, _) }, _) :: _ -> Some modname
+  | _ :: rest -> find_record_qual rest
+
+let map_fold_cont f xs k =
+  List.fold_right (fun x k ys -> f x (fun y -> k (y :: ys)))
+    xs (fun ys -> k (List.rev ys)) []
+
+let type_label_a_list
+      ?labels loc closed env type_lbl_a expected_type lid_a_list k =
+  let lbl_a_list =
+    match lid_a_list, labels with
+      ({txt=Longident.Lident s}, _)::_, Some labels when Hashtbl.mem labels s ->
+        (* Special case for rebuilt syntax trees *)
+        List.map
+          (function lid, a -> match lid.txt with
+            Longident.Lident s -> lid, Hashtbl.find labels s, a
+          | _ -> assert false)
+          lid_a_list
+    | _ ->
+        let lid_a_list =
+          match find_record_qual lid_a_list with
+            None -> lid_a_list
+          | Some modname ->
+              List.map
+                (fun (lid, a as lid_a) ->
+                  match lid.txt with Longident.Lident s ->
+                    {lid with txt=Longident.Ldot (modname, s)}, a
+                  | _ -> lid_a)
+                lid_a_list
+        in
+        disambiguate_lid_a_list loc closed env expected_type lid_a_list
+  in
+  (* Invariant: records are sorted in the typed tree *)
+  let lbl_a_list =
+    List.sort
+      (fun (_,lbl1,_) (_,lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos)
+      lbl_a_list
+  in
+  map_fold_cont type_lbl_a lbl_a_list k
+;;
+
+(* Checks over the labels mentioned in a record pattern:
+   no duplicate definitions (error); properly closed (warning) *)
+
+let check_recordpat_labels loc lbl_pat_list closed =
+  match lbl_pat_list with
+  | [] -> ()                            (* should not happen *)
+  | (_, label1, _) :: _ ->
+      let all = label1.lbl_all in
+      let defined = Array.make (Array.length all) false in
+      let check_defined (_, label, _) =
+        if defined.(label.lbl_pos)
+        then raise(Error(loc, Env.empty, Label_multiply_defined label.lbl_name))
+        else defined.(label.lbl_pos) <- true in
+      List.iter check_defined lbl_pat_list;
+      if closed = Closed
+      && Warnings.is_active (Warnings.Non_closed_record_pattern "")
+      then begin
+        let undefined = ref [] in
+        for i = 0 to Array.length all - 1 do
+          if not defined.(i) then undefined := all.(i).lbl_name :: !undefined
+        done;
+        if !undefined <> [] then begin
+          let u = String.concat ", " (List.rev !undefined) in
+          Location.prerr_warning loc (Warnings.Non_closed_record_pattern u)
+        end
+      end
+
+(* Constructors *)
+
+module Constructor = NameChoice (struct
+  type t = constructor_description
+  type usage = Env.constructor_usage
+  let kind = Datatype_kind.Variant
+  let get_name cstr = cstr.cstr_name
+  let get_type cstr = cstr.cstr_res
+  let lookup_all_from_type loc usage path env =
+    match Env.lookup_all_constructors_from_type ~loc usage path env with
+    | _ :: _ as x -> x
+    | [] ->
+        match (Env.find_type path env).type_kind with
+        | Type_open ->
+            (* Extension constructors cannot be found by looking at the type
+               declaration.
+               We scan the whole environment to get an accurate spellchecking
+               hint in the subsequent error message *)
+            let filter lbl =
+              compare_type_path env
+                path (get_constr_type_path @@ get_type lbl) in
+            let add_valid x acc = if filter x then (x,ignore)::acc else acc in
+            Env.fold_constructors add_valid None env []
+        | _ -> []
+  let in_env _ = true
+end)
+
+(* unification of a type with a tconstr with
+   freshly created arguments *)
+let unify_head_only ~refine loc env ty constr =
+  let (_, ty_res) = instance_constructor constr in
+  let ty_res = repr ty_res in
+  match ty_res.desc with
+  | Tconstr(p,args,m) ->
+      ty_res.desc <- Tconstr(p,List.map (fun _ -> newvar ()) args,m);
+      enforce_constraints !env ty_res;
+      unify_pat_types ~refine loc env ty_res ty
+  | _ -> assert false
+
+(* Typing of patterns *)
+
+(* "half typed" cases are produced in [type_cases] when we've just typechecked
+   the pattern but haven't type-checked the body yet.
+   At this point we might have added some type equalities to the environment,
+   but haven't yet added identifiers bound by the pattern. *)
+type 'case_pattern half_typed_case =
+  { typed_pat: 'case_pattern;
+    pat_type_for_unif: type_expr;
+    untyped_case: Parsetree.case;
+    branch_env: Env.t;
+    pat_vars: pattern_variable list;
+    unpacks: module_variable list;
+    contains_gadt: bool; }
+
+let rec has_literal_pattern p = match p.ppat_desc with
+  | Ppat_constant _
+  | Ppat_interval _ ->
+     true
+  | Ppat_any
+  | Ppat_variant (_, None)
+  | Ppat_construct (_, None)
+  | Ppat_type _
+  | Ppat_var _
+  | Ppat_unpack _
+  | Ppat_extension _ ->
+     false
+  | Ppat_exception p
+  | Ppat_variant (_, Some p)
+  | Ppat_construct (_, Some p)
+  | Ppat_constraint (p, _)
+  | Ppat_alias (p, _)
+  | Ppat_lazy p
+  | Ppat_open (_, p) ->
+     has_literal_pattern p
+  | Ppat_tuple ps
+  | Ppat_array ps ->
+     List.exists has_literal_pattern ps
+  | Ppat_record (ps, _) ->
+     List.exists (fun (_,p) -> has_literal_pattern p) ps
+  | Ppat_or (p, q) ->
+     has_literal_pattern p || has_literal_pattern q
+
+let check_scope_escape loc env level ty =
+  try Ctype.check_scope_escape env level ty
+  with Unify trace ->
+    raise(Error(loc, env, Pattern_type_clash(trace, None)))
+
+type pattern_checking_mode =
+  | Normal
+  (** We are checking user code. *)
+  | Counter_example of counter_example_checking_info
+  (** In [Counter_example] mode, we are checking a counter-example
+      candidate produced by Parmatch. This is a syntactic pattern that
+      represents a set of values by using or-patterns (p_1 | ... | p_n)
+      to enumerate all alternatives in the counter-example
+      search. These or-patterns occur at every choice point, possibly
+      deep inside the pattern.
+
+      Parmatch does not use type information, so this pattern may
+      exhibit two issues:
+      - some parts of the pattern may be ill-typed due to GADTs, and
+      - some wildcard patterns may not match any values: their type is
+        empty.
+
+      The aim of [type_pat] in the [Counter_example] mode is to refine
+      this syntactic pattern into a well-typed pattern, and ensure
+      that it matches at least one concrete value.
+      - It filters ill-typed branches of or-patterns.
+        (see {!splitting_mode} below)
+      - It tries to check that wildcard patterns are non-empty.
+        (see {!explosion_fuel})
+  *)
+
+and counter_example_checking_info = {
+    explosion_fuel: int;
+    splitting_mode: splitting_mode;
+    constrs: (string, Types.constructor_description) Hashtbl.t;
+    labels: (string, Types.label_description) Hashtbl.t;
+  }
+(**
+    [explosion_fuel] controls the checking of wildcard patterns.  We
+    eliminate potentially-empty wildcard patterns by exploding them
+    into concrete sub-patterns, for example (K1 _ | K2 _) or
+    { l1: _; l2: _ }. [explosion_fuel] is the depth limit on wildcard
+    explosion. Such depth limit is required to avoid non-termination
+    and compilation-time blowups.
+
+    [splitting_mode] controls the handling of or-patterns.  In
+    [Counter_example] mode, we only need to select one branch that
+    leads to a well-typed pattern. Checking all branches is expensive,
+    we use different search strategies (see {!splitting_mode}) to
+    reduce the number of explored alternatives.
+
+    [constrs] and [labels] contain metadata produced by [Parmatch] to
+    type-check the given syntactic pattern. [Parmatch] produces
+    counter-examples by turning typed patterns into
+    [Parsetree.pattern]. In this process, constructor and label paths
+    are lost, and are replaced by generated strings. [constrs] and
+    [labels] map those synthetic names back to the typed descriptions
+    of the original names.
+ *)
+
+(** Due to GADT constraints, an or-pattern produced within
+    a counter-example may have ill-typed branches. Consider for example
+
+    {[
+      type _ tag = Int : int tag | Bool : bool tag
+    ]}
+
+    then [Parmatch] will propose the or-pattern [Int | Bool] whenever
+    a pattern of type [tag] is required to form a counter-example. For
+    example, a function expects a (int tag option) and only [None] is
+    handled by the user-written pattern. [Some (Int | Bool)] is not
+    well-typed in this context, only the sub-pattern [Some Int] is.
+    In this example, the expected type coming from the context
+    suffices to know which or-pattern branch must be chosen.
+
+    In the general case, choosing a branch can have non-local effects
+    on the typability of the term. For example, consider a tuple type
+    ['a tag * ...'a...], where the first component is a GADT.  All
+    constructor choices for this GADT lead to a well-typed branch in
+    isolation (['a] is unconstrained), but choosing one of them adds
+    a constraint on ['a] that may make the other tuple elements
+    ill-typed.
+
+    In general, after choosing each possible branch of the or-pattern,
+    [type_pat] has to check the rest of the pattern to tell if this
+    choice leads to a well-typed term. This may lead to an explosion
+    of typing/search work -- the rest of the term may in turn contain
+    alternatives.
+
+    We use careful strategies to try to limit counterexample-checking
+    time; [splitting_mode] represents those strategies.
+*)
+and splitting_mode =
+  | Backtrack_or
+  (** Always backtrack in or-patterns.
+
+      [Backtrack_or] selects a single alternative from an or-pattern
+      by using backtracking, trying to choose each branch in turn, and
+      to complete it into a valid sub-pattern. We call this
+      "splitting" the or-pattern.
+
+      We use this mode when looking for unused patterns or sub-patterns,
+      in particular to check a refutation clause (p -> .).
+    *)
+  | Refine_or of { inside_nonsplit_or: bool; }
+  (** Only backtrack when needed.
+
+      [Refine_or] tries another approach for refining or-pattern.
+
+      Instead of always splitting each or-pattern, It first attempts to
+      find branches that do not introduce new constraints (because they
+      do not contain GADT constructors). Those branches are such that,
+      if they fail, all other branches will fail.
+
+      If we find one such branch, we attempt to complete the subpattern
+      (checking what's outside the or-pattern), ignoring other
+      branches -- we never consider another branch choice again. If all
+      branches are constrained, it falls back to splitting the
+      or-pattern.
+
+      We use this mode when checking exhaustivity of pattern matching.
+  *)
+
+(** This exception is only used internally within [type_pat_aux], in
+    counter-example mode, to jump back to the parent or-pattern in the
+    [Refine_or] strategy.
+
+    Such a parent exists precisely when [inside_nonsplit_or = true];
+    it's an invariant that we always setup an exception handler for
+    [Need_backtrack] when we set this flag. *)
+exception Need_backtrack
+
+(** This exception is only used internally within [type_pat_aux], in
+    counter-example mode. We use it to discard counter-example candidates
+    that do not match any value. *)
+exception Empty_branch
+
+type abort_reason = Adds_constraints | Empty
+
+(** Remember current typing state for backtracking.
+   No variable information, as we only backtrack on
+   patterns without variables (cf. assert statements). *)
+type state =
+ { snapshot: Btype.snapshot;
+   levels: Ctype.levels;
+   env: Env.t; }
+let save_state env =
+  { snapshot = Btype.snapshot ();
+    levels = Ctype.save_levels ();
+    env = !env; }
+let set_state s env =
+  Btype.backtrack s.snapshot;
+  Ctype.set_levels s.levels;
+  env := s.env
+
+(** Find the first alternative in the tree of or-patterns for which
+   [f] does not raise an error. If all fail, the last error is
+   propagated *)
+let rec find_valid_alternative f pat =
+  match pat.ppat_desc with
+  | Ppat_or(p1,p2) ->
+      (try find_valid_alternative f p1 with
+       | Empty_branch | Error _ -> find_valid_alternative f p2
+      )
+  | _ -> f pat
+
+let no_explosion = function
+  | Normal -> Normal
+  | Counter_example info ->
+     Counter_example { info with explosion_fuel = 0 }
+
+let get_splitting_mode = function
+  | Normal -> None
+  | Counter_example {splitting_mode} -> Some splitting_mode
+
+let enter_nonsplit_or mode = match mode with
+  | Normal -> Normal
+  | Counter_example info ->
+     let splitting_mode = match info.splitting_mode with
+       | Backtrack_or ->
+          (* in Backtrack_or mode, or-patterns are always split *)
+          assert false
+       | Refine_or _ ->
+          Refine_or {inside_nonsplit_or = true}
+     in Counter_example { info with splitting_mode }
+
+(** The typedtree has two distinct syntactic categories for patterns,
+   "value" patterns, matching on values, and "computation" patterns
+   that match on the effect of a computation -- typically, exception
+   patterns (exception p).
+
+   On the other hand, the parsetree has an unstructured representation
+   where all categories of patterns are mixed together. The
+   decomposition according to the value/computation structure has to
+   happen during type-checking.
+
+   We don't want to duplicate the type-checking logic in two different
+   functions, depending on the kind of pattern to be produced. In
+   particular, there are both value and computation or-patterns, and
+   the type-checking logic for or-patterns is horribly complex; having
+   it in two different places would be twice as horirble.
+
+   The solution is to pass a GADT tag to [type_pat] to indicate whether
+   a value or computation pattern is expected. This way, there is a single
+   place where [Ppat_or] nodes are type-checked, the checking logic is shared,
+   and only at the end do we inspect the tag to decide to produce a value
+   or computation pattern.
+*)
+let pure
+  : type k . k pattern_category -> value general_pattern -> k general_pattern
+  = fun category pat ->
+  match category with
+  | Value -> pat
+  | Computation -> as_computation_pattern pat
+
+let only_impure
+  : type k . k pattern_category ->
+             computation general_pattern -> k general_pattern
+  = fun category pat ->
+  match category with
+  | Value ->
+     (* LATER: this exception could be renamed/generalized *)
+     raise (Error (pat.pat_loc, pat.pat_env,
+                   Exception_pattern_disallowed))
+  | Computation -> pat
+
+let as_comp_pattern
+  : type k . k pattern_category ->
+             k general_pattern -> computation general_pattern
+  = fun category pat ->
+  match category with
+  | Value -> as_computation_pattern pat
+  | Computation -> pat
+
+(* type_pat propagates the expected type.
+   Unification may update the typing environment.
+
+   In counter-example mode, [Empty_branch] is raised when the counter-example
+   does not match any value.  *)
+let rec type_pat
+  : type k r . k pattern_category -> no_existentials:_ -> mode:_ ->
+      env:_ -> _ -> _ -> (k general_pattern -> r) -> r
+  = fun category ~no_existentials ~mode
+        ~env sp expected_ty k ->
+  Builtin_attributes.warning_scope sp.ppat_attributes
+    (fun () ->
+       type_pat_aux category ~no_existentials ~mode
+         ~env sp expected_ty k
+    )
+
+and type_pat_aux
+  : type k r . k pattern_category -> no_existentials:_ -> mode:_ ->
+         env:_ -> _ -> _ -> (k general_pattern -> r) -> r
+  = fun category ~no_existentials ~mode
+      ~env sp expected_ty k ->
+  let type_pat category ?(mode=mode) ?(env=env) =
+    type_pat category ~no_existentials ~mode ~env
+  in
+  let loc = sp.ppat_loc in
+  let refine = match mode with Normal -> false | Counter_example _ -> true in
+  let unif (x : pattern) : pattern =
+    unify_pat ~refine env x (instance expected_ty);
+    x
+  in
+  let rp x =
+    let crp (x : k general_pattern) : k general_pattern =
+      match category with
+      | Value -> rp x
+      | Computation -> rcp x in
+    if mode = Normal then crp x else x in
+  let rp k x = k (rp x)
+  and rvp k x = k (rp (pure category x))
+  and rcp k x = k (rp (only_impure category x)) in
+  let construction_not_used_in_counterexamples = (mode = Normal) in
+  let must_backtrack_on_gadt = match get_splitting_mode mode with
+    | None -> false
+    | Some Backtrack_or -> false
+    | Some (Refine_or {inside_nonsplit_or}) -> inside_nonsplit_or
+  in
+  match sp.ppat_desc with
+    Ppat_any ->
+      let k' d = rvp k {
+        pat_desc = d;
+        pat_loc = loc; pat_extra=[];
+        pat_type = instance expected_ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env }
+      in
+      begin match mode with
+      | Normal -> k' Tpat_any
+      | Counter_example {explosion_fuel; _} when explosion_fuel <= 0 ->
+          k' Tpat_any
+      | Counter_example ({explosion_fuel; _} as info) ->
+         let open Parmatch in
+         begin match ppat_of_type !env expected_ty with
+         | PT_empty -> raise Empty_branch
+         | PT_any -> k' Tpat_any
+         | PT_pattern (explosion, sp, constrs, labels) ->
+            let explosion_fuel =
+              match explosion with
+              | PE_single -> explosion_fuel - 1
+              | PE_gadt_cases ->
+                  if must_backtrack_on_gadt then raise Need_backtrack;
+                  explosion_fuel - 5
+            in
+            let mode =
+              Counter_example { info with explosion_fuel; constrs; labels }
+            in
+            type_pat category ~mode sp expected_ty k
+         end
+      end
+  | Ppat_var name ->
+      let ty = instance expected_ty in
+      let id = (* PR#7330 *)
+        if name.txt = "*extension*" then
+          Ident.create_local name.txt
+        else
+          enter_variable loc name ty sp.ppat_attributes
+      in
+      rvp k {
+        pat_desc = Tpat_var (id, name);
+        pat_loc = loc; pat_extra=[];
+        pat_type = ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env }
+  | Ppat_unpack name ->
+      assert construction_not_used_in_counterexamples;
+      let t = instance expected_ty in
+      begin match name.txt with
+      | None ->
+          rvp k {
+            pat_desc = Tpat_any;
+            pat_loc = sp.ppat_loc;
+            pat_extra=[Tpat_unpack, name.loc, sp.ppat_attributes];
+            pat_type = t;
+            pat_attributes = [];
+            pat_env = !env }
+      | Some s ->
+          let v = { name with txt = s } in
+          let id = enter_variable loc v t ~is_module:true sp.ppat_attributes in
+          rvp k {
+            pat_desc = Tpat_var (id, v);
+            pat_loc = sp.ppat_loc;
+            pat_extra=[Tpat_unpack, loc, sp.ppat_attributes];
+            pat_type = t;
+            pat_attributes = [];
+            pat_env = !env }
+      end
+  | Ppat_constraint(
+      {ppat_desc=Ppat_var name; ppat_loc=lloc; ppat_attributes = attrs},
+      ({ptyp_desc=Ptyp_poly _} as sty)) ->
+      (* explicitly polymorphic type *)
+      assert construction_not_used_in_counterexamples;
+      let cty, force = Typetexp.transl_simple_type_delayed !env sty in
+      let ty = cty.ctyp_type in
+      unify_pat_types ~refine lloc env ty (instance expected_ty);
+      pattern_force := force :: !pattern_force;
+      begin match ty.desc with
+      | Tpoly (body, tyl) ->
+          begin_def ();
+          let _, ty' = instance_poly ~keep_names:true false tyl body in
+          end_def ();
+          generalize ty';
+          let id = enter_variable lloc name ty' attrs in
+          rvp k {
+            pat_desc = Tpat_var (id, name);
+            pat_loc = lloc;
+            pat_extra = [Tpat_constraint cty, loc, sp.ppat_attributes];
+            pat_type = ty;
+            pat_attributes = [];
+            pat_env = !env
+          }
+      | _ -> assert false
+      end
+  | Ppat_alias(sq, name) ->
+      assert construction_not_used_in_counterexamples;
+      type_pat Value sq expected_ty (fun q ->
+        begin_def ();
+        let ty_var = build_as_type env q in
+        end_def ();
+        generalize ty_var;
+        let id =
+          enter_variable ~is_as_variable:true loc name ty_var sp.ppat_attributes
+        in
+        rvp k {
+          pat_desc = Tpat_alias(q, id, name);
+          pat_loc = loc; pat_extra=[];
+          pat_type = q.pat_type;
+          pat_attributes = sp.ppat_attributes;
+          pat_env = !env })
+  | Ppat_constant cst ->
+      let cst = constant_or_raise !env loc cst in
+      rvp k @@ unif {
+        pat_desc = Tpat_constant cst;
+        pat_loc = loc; pat_extra=[];
+        pat_type = type_constant cst;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env }
+  | Ppat_interval (Pconst_char c1, Pconst_char c2) ->
+      let open Ast_helper.Pat in
+      let gloc = {loc with Location.loc_ghost=true} in
+      let rec loop c1 c2 =
+        if c1 = c2 then constant ~loc:gloc (Pconst_char c1)
+        else
+          or_ ~loc:gloc
+            (constant ~loc:gloc (Pconst_char c1))
+            (loop (Char.chr(Char.code c1 + 1)) c2)
+      in
+      let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in
+      let p = {p with ppat_loc=loc} in
+      type_pat category ~mode:(no_explosion mode) p expected_ty k
+        (* TODO: record 'extra' to remember about interval *)
+  | Ppat_interval _ ->
+      raise (Error (loc, !env, Invalid_interval))
+  | Ppat_tuple spl ->
+      assert (List.length spl >= 2);
+      let spl_ann = List.map (fun p -> (p,newgenvar ())) spl in
+      let ty = newgenty (Ttuple(List.map snd spl_ann)) in
+      begin_def ();
+      let expected_ty = instance expected_ty in
+      end_def ();
+      generalize_structure expected_ty;
+      unify_pat_types ~refine loc env ty expected_ty;
+      map_fold_cont (fun (p,t) -> type_pat Value p t) spl_ann (fun pl ->
+        rvp k {
+        pat_desc = Tpat_tuple pl;
+        pat_loc = loc; pat_extra=[];
+        pat_type = newty (Ttuple(List.map (fun p -> p.pat_type) pl));
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env })
+  | Ppat_construct(lid, sarg) ->
+      let expected_type =
+        try
+          let (p0, p, _) = extract_concrete_variant !env expected_ty in
+            Some (p0, p, true)
+        with Not_found -> None
+      in
+      let constr =
+        match lid.txt, mode with
+        | Longident.Lident s, Counter_example {constrs; _} ->
+           (* assert: cf. {!counter_example_checking_info} documentation *)
+            assert (Hashtbl.mem constrs s);
+            Hashtbl.find constrs s
+        | _ ->
+        let candidates =
+          Env.lookup_all_constructors Env.Pattern ~loc:lid.loc lid.txt !env in
+        wrap_disambiguate "This variant pattern is expected to have"
+          (mk_expected expected_ty)
+          (Constructor.disambiguate Env.Pattern lid !env expected_type)
+          candidates
+      in
+      if constr.cstr_generalized && must_backtrack_on_gadt then
+        raise Need_backtrack;
+      begin match no_existentials, constr.cstr_existentials with
+      | None, _ | _, [] -> ()
+      | Some r, (_ :: _ as exs)  ->
+          let exs = List.map (Ctype.existential_name constr) exs in
+          let name = constr.cstr_name in
+          raise (Error (loc, !env, Unexpected_existential (r,name, exs)))
+      end;
+      (* if constructor is gadt, we must verify that the expected type has the
+         correct head *)
+      if constr.cstr_generalized then
+        unify_head_only ~refine loc env (instance expected_ty) constr;
+      let sargs =
+        match sarg with
+          None -> []
+        | Some {ppat_desc = Ppat_tuple spl} when
+            constr.cstr_arity > 1 ||
+            Builtin_attributes.explicit_arity sp.ppat_attributes
+          -> spl
+        | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity <> 1 ->
+            if constr.cstr_arity = 0 then
+              Location.prerr_warning sp.ppat_loc
+                                     Warnings.Wildcard_arg_to_constant_constr;
+            replicate_list sp constr.cstr_arity
+        | Some sp -> [sp] in
+      if Builtin_attributes.warn_on_literal_pattern constr.cstr_attributes then
+        begin match List.filter has_literal_pattern sargs with
+        | sp :: _ ->
+           Location.prerr_warning sp.ppat_loc Warnings.Fragile_literal_pattern
+        | _ -> ()
+        end;
+      if List.length sargs <> constr.cstr_arity then
+        raise(Error(loc, !env, Constructor_arity_mismatch(lid.txt,
+                                     constr.cstr_arity, List.length sargs)));
+      begin_def ();
+      let (ty_args, ty_res) =
+        instance_constructor ~in_pattern:(env, get_gadt_equations_level ())
+          constr
+      in
+      let expected_ty = instance expected_ty in
+      (* PR#7214: do not use gadt unification for toplevel lets *)
+      unify_pat_types loc env ty_res expected_ty
+        ~refine:(refine || constr.cstr_generalized && no_existentials = None);
+      end_def ();
+      generalize_structure expected_ty;
+      generalize_structure ty_res;
+      List.iter generalize_structure ty_args;
+
+      let rec check_non_escaping p =
+        match p.ppat_desc with
+        | Ppat_or (p1, p2) ->
+            check_non_escaping p1;
+            check_non_escaping p2
+        | Ppat_alias (p, _) ->
+            check_non_escaping p
+        | Ppat_constraint _ ->
+            raise (Error (p.ppat_loc, !env, Inlined_record_escape))
+        | _ ->
+            ()
+      in
+      if constr.cstr_inlined <> None then List.iter check_non_escaping sargs;
+
+      map_fold_cont
+        (fun (p,t) -> type_pat Value p t)
+        (List.combine sargs ty_args)
+        (fun args ->
+          rvp k {
+            pat_desc=Tpat_construct(lid, constr, args);
+            pat_loc = loc; pat_extra=[];
+            pat_type = instance expected_ty;
+            pat_attributes = sp.ppat_attributes;
+            pat_env = !env })
+  | Ppat_variant(l, sarg) ->
+      let arg_type = match sarg with None -> [] | Some _ -> [newgenvar()] in
+      let row = { row_fields =
+                    [l, Reither(sarg = None, arg_type, true, ref None)];
+                  row_bound = ();
+                  row_closed = false;
+                  row_more = newgenvar ();
+                  row_fixed = None;
+                  row_name = None } in
+      begin_def ();
+      let expected_ty = instance expected_ty in
+      end_def ();
+      generalize_structure expected_ty;
+      (* PR#7404: allow some_private_tag blindly, as it would not unify with
+         the abstract row variable *)
+      if l = Parmatch.some_private_tag
+      then assert (match mode with Normal -> false | Counter_example _ -> true)
+      else unify_pat_types ~refine loc env (newgenty(Tvariant row)) expected_ty;
+      let k arg =
+        rvp k {
+        pat_desc = Tpat_variant(l, arg, ref {row with row_more = newvar()});
+        pat_loc = loc; pat_extra=[];
+        pat_type = instance expected_ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env }
+      in begin
+        (* PR#6235: propagate type information *)
+        match sarg, arg_type with
+          Some p, [ty] -> type_pat Value p ty (fun p -> k (Some p))
+        | _            -> k None
+      end
+  | Ppat_record(lid_sp_list, closed) ->
+      assert (lid_sp_list <> []);
+      let expected_type, record_ty =
+        try
+          let (p0, p,_) = extract_concrete_record !env expected_ty in
+          begin_def ();
+          let ty = instance expected_ty in
+          end_def ();
+          generalize_structure ty;
+          Some (p0, p, true), ty
+        with Not_found -> None, newvar ()
+      in
+      let type_label_pat (label_lid, label, sarg) k =
+        begin_def ();
+        let (_, ty_arg, ty_res) = instance_label false label in
+        begin try
+          unify_pat_types ~refine loc env ty_res (instance record_ty)
+        with Error(_loc, _env, Pattern_type_clash(trace, _)) ->
+          raise(Error(label_lid.loc, !env,
+                      Label_mismatch(label_lid.txt, trace)))
+        end;
+        end_def ();
+        generalize_structure ty_res;
+        generalize_structure ty_arg;
+        type_pat Value sarg ty_arg (fun arg ->
+          k (label_lid, label, arg))
+      in
+      let make_record_pat lbl_pat_list =
+        check_recordpat_labels loc lbl_pat_list closed;
+        {
+          pat_desc = Tpat_record (lbl_pat_list, closed);
+          pat_loc = loc; pat_extra=[];
+          pat_type = instance record_ty;
+          pat_attributes = sp.ppat_attributes;
+          pat_env = !env;
+        }
+      in
+      let k' pat = rvp k (unif pat) in
+      begin match mode with
+      | Normal ->
+          k' (wrap_disambiguate "This record pattern is expected to have"
+               (mk_expected expected_ty)
+               (type_label_a_list loc false !env type_label_pat expected_type
+                  lid_sp_list)
+               make_record_pat)
+      | Counter_example {labels; _} ->
+          type_label_a_list ~labels loc false !env type_label_pat expected_type
+            lid_sp_list (fun lbl_pat_list -> k' (make_record_pat lbl_pat_list))
+      end
+  | Ppat_array spl ->
+      let ty_elt = newgenvar() in
+      begin_def ();
+      let expected_ty = instance expected_ty in
+      end_def ();
+      generalize_structure expected_ty;
+      unify_pat_types ~refine
+        loc env (Predef.type_array ty_elt) expected_ty;
+      map_fold_cont (fun p -> type_pat Value p ty_elt) spl (fun pl ->
+        rvp k {
+        pat_desc = Tpat_array pl;
+        pat_loc = loc; pat_extra=[];
+        pat_type = instance expected_ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env })
+  | Ppat_or(sp1, sp2) ->
+      let may_split, must_split =
+        match get_splitting_mode mode with
+        | None -> false, false
+        | Some Backtrack_or -> true, true
+        | Some (Refine_or _) -> true, false in
+      let state = save_state env in
+      let split_or sp =
+        assert may_split;
+        let typ pat = type_pat category pat expected_ty k in
+        find_valid_alternative (fun pat -> set_state state env; typ pat) sp in
+      if must_split then split_or sp else begin
+        let initial_pattern_variables = !pattern_variables in
+        let initial_module_variables = !module_variables in
+        let equation_level = !gadt_equations_level in
+        let outter_lev = get_current_level () in
+        (* introduce a new scope *)
+        begin_def ();
+        let lev = get_current_level () in
+        gadt_equations_level := Some lev;
+        let env1 = ref !env in
+        let inside_or = enter_nonsplit_or mode in
+        let type_pat_result env sp : (_, abort_reason) result =
+          match
+            type_pat category ~mode:inside_or sp expected_ty ~env (fun x -> x)
+          with
+          | res -> Ok res
+          | exception Need_backtrack -> Error Adds_constraints
+          | exception Empty_branch -> Error Empty
+        in
+        let p1 = type_pat_result env1 sp1 in
+        let p1_variables = !pattern_variables in
+        let p1_module_variables = !module_variables in
+        pattern_variables := initial_pattern_variables;
+        module_variables := initial_module_variables;
+        let env2 = ref !env in
+        let p2 = type_pat_result env2 sp2 in
+        end_def ();
+        gadt_equations_level := equation_level;
+        let p2_variables = !pattern_variables in
+        (* Make sure no variable with an ambiguous type gets added to the
+           environment. *)
+        List.iter (fun { pv_type; pv_loc; _ } ->
+          check_scope_escape pv_loc !env1 outter_lev pv_type
+        ) p1_variables;
+        List.iter (fun { pv_type; pv_loc; _ } ->
+          check_scope_escape pv_loc !env2 outter_lev pv_type
+        ) p2_variables;
+        begin match p1, p2 with
+        | Error Empty, Error Empty ->
+            raise Empty_branch
+        | Error Adds_constraints, Error _
+        | Error _, Error Adds_constraints ->
+            let inside_nonsplit_or =
+              match get_splitting_mode mode with
+              | None | Some Backtrack_or -> false
+              | Some (Refine_or {inside_nonsplit_or}) -> inside_nonsplit_or in
+            if inside_nonsplit_or
+            then raise Need_backtrack
+            else split_or sp
+        | Ok p, Error _
+        | Error _, Ok p ->
+            rp k p
+        | Ok p1, Ok p2 ->
+            let alpha_env =
+              enter_orpat_variables loc !env p1_variables p2_variables in
+            let p2 = alpha_pat alpha_env p2 in
+            pattern_variables := p1_variables;
+            module_variables := p1_module_variables;
+            let make_pat desc =
+              { pat_desc = desc;
+                pat_loc = loc; pat_extra=[];
+                pat_type = instance expected_ty;
+                pat_attributes = sp.ppat_attributes;
+                pat_env = !env } in
+            rp k (make_pat (Tpat_or(p1, p2, None)))
+        end
+      end
+  | Ppat_lazy sp1 ->
+      let nv = newgenvar () in
+      unify_pat_types ~refine loc env (Predef.type_lazy_t nv) expected_ty;
+      (* do not explode under lazy: PR#7421 *)
+      type_pat Value ~mode:(no_explosion mode) sp1 nv (fun p1 ->
+        rvp k {
+        pat_desc = Tpat_lazy p1;
+        pat_loc = loc; pat_extra=[];
+        pat_type = instance expected_ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env })
+  | Ppat_constraint(sp, sty) ->
+      (* Pretend separate = true *)
+      begin_def();
+      let cty, force = Typetexp.transl_simple_type_delayed !env sty in
+      let ty = cty.ctyp_type in
+      end_def();
+      generalize_structure ty;
+      let ty, expected_ty' = instance ty, ty in
+      unify_pat_types ~refine loc env ty (instance expected_ty);
+      type_pat category sp expected_ty' (fun p ->
+        (*Format.printf "%a@.%a@."
+          Printtyp.raw_type_expr ty
+          Printtyp.raw_type_expr p.pat_type;*)
+        pattern_force := force :: !pattern_force;
+        let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in
+        let p : k general_pattern =
+          match category, (p : k general_pattern) with
+          | Value, {pat_desc = Tpat_var (id,s); _} ->
+            {p with
+              pat_type = ty;
+              pat_desc =
+                Tpat_alias
+                  ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s);
+              pat_extra = [extra];
+            }
+          | _, p ->
+             { p with pat_type = ty; pat_extra = extra::p.pat_extra }
+        in k p)
+  | Ppat_type lid ->
+      let (path, p,ty) = build_or_pat !env loc lid in
+      unify_pat_types ~refine loc env ty (instance expected_ty);
+      k @@ pure category @@ { p with pat_extra =
+        (Tpat_type (path, lid), loc, sp.ppat_attributes)
+        :: p.pat_extra }
+  | Ppat_open (lid,p) ->
+      let path, new_env =
+        !type_open Asttypes.Fresh !env sp.ppat_loc lid in
+      let new_env = ref new_env in
+      type_pat category ~env:new_env p expected_ty ( fun p ->
+        env := Env.copy_local !env ~from:!new_env;
+        k { p with pat_extra =( Tpat_open (path,lid,!new_env),
+                            loc, sp.ppat_attributes) :: p.pat_extra }
+      )
+  | Ppat_exception p ->
+      type_pat Value p Predef.type_exn (fun p_exn ->
+      rcp k {
+        pat_desc = Tpat_exception p_exn;
+        pat_loc = sp.ppat_loc;
+        pat_extra = [];
+        pat_type = expected_ty;
+        pat_env = !env;
+        pat_attributes = sp.ppat_attributes;
+      })
+  | Ppat_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+let type_pat category ?no_existentials ?(mode=Normal)
+    ?(lev=get_current_level()) env sp expected_ty =
+  Misc.protect_refs [Misc.R (gadt_equations_level, Some lev)] (fun () ->
+      let r =
+        type_pat category ~no_existentials ~mode
+          ~env sp expected_ty (fun x -> x)
+      in
+      map_general_pattern { f = fun p -> { p with pat_env = !env } } r
+    )
+
+(* this function is passed to Partial.parmatch
+   to type check gadt nonexhaustiveness *)
+let partial_pred ~lev ~splitting_mode ?(explode=0)
+      env expected_ty constrs labels p =
+  let env = ref env in
+  let state = save_state env in
+  let mode =
+    Counter_example {
+        splitting_mode;
+        explosion_fuel = explode;
+        constrs; labels;
+      } in
+  try
+    reset_pattern None true;
+    let typed_p = type_pat Value ~lev ~mode env p expected_ty in
+    set_state state env;
+    (* types are invalidated but we don't need them here *)
+    Some typed_p
+  with Error _ | Empty_branch ->
+    set_state state env;
+    None
+
+let check_partial ?(lev=get_current_level ()) env expected_ty loc cases =
+  let explode = match cases with [_] -> 5 | _ -> 0 in
+  let splitting_mode = Refine_or {inside_nonsplit_or = false} in
+  Parmatch.check_partial
+    (partial_pred ~lev ~splitting_mode ~explode env expected_ty) loc cases
+
+let check_unused ?(lev=get_current_level ()) env expected_ty cases =
+  Parmatch.check_unused
+    (fun refute constrs labels spat ->
+      match
+        partial_pred ~lev ~splitting_mode:Backtrack_or ~explode:5
+          env expected_ty constrs labels spat
+      with
+        Some pat when refute ->
+          raise (Error (spat.ppat_loc, env, Unrefuted_pattern pat))
+      | r -> r)
+    cases
+
+let iter_pattern_variables_type f : pattern_variable list -> unit =
+  List.iter (fun {pv_type; _} -> f pv_type)
+
+let add_pattern_variables ?check ?check_as env pv =
+  List.fold_right
+    (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} env ->
+       let check = if pv_as_var then check_as else check in
+       Env.add_value ?check pv_id
+         {val_type = pv_type; val_kind = Val_reg; Types.val_loc = pv_loc;
+          val_attributes = pv_attributes;
+          val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+         } env
+    )
+    pv env
+
+let type_pattern category ~lev env spat scope expected_ty =
+  reset_pattern scope true;
+  let new_env = ref env in
+  let pat = type_pat category ~lev new_env spat expected_ty in
+  let pvs = get_ref pattern_variables in
+  let unpacks = get_ref module_variables in
+  (pat, !new_env, get_ref pattern_force, pvs, unpacks)
+
+let type_pattern_list
+    category no_existentials env spatl scope expected_tys allow
+  =
+  reset_pattern scope allow;
+  let new_env = ref env in
+  let type_pat (attrs, pat) ty =
+    Builtin_attributes.warning_scope ~ppwarning:false attrs
+      (fun () ->
+         type_pat category ~no_existentials new_env pat ty
+      )
+  in
+  let patl = List.map2 type_pat spatl expected_tys in
+  let pvs = get_ref pattern_variables in
+  let unpacks =
+    List.map (fun (name, loc) ->
+      name, loc, Uid.mk ~current_unit:(Env.get_unit_name ())
+    ) (get_ref module_variables)
+  in
+  let new_env = add_pattern_variables !new_env pvs in
+  (patl, new_env, get_ref pattern_force, pvs, unpacks)
+
+let type_class_arg_pattern cl_num val_env met_env l spat =
+  reset_pattern None false;
+  let nv = newvar () in
+  let pat =
+    type_pat Value ~no_existentials:In_class_args (ref val_env) spat nv in
+  if has_variants pat then begin
+    Parmatch.pressure_variants val_env [pat];
+    finalize_variants pat;
+  end;
+  List.iter (fun f -> f()) (get_ref pattern_force);
+  if is_optional l then unify_pat (ref val_env) pat (type_option (newvar ()));
+  let (pv, val_env, met_env) =
+    List.fold_right
+      (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes}
+        (pv, val_env, met_env) ->
+         let check s =
+           if pv_as_var then Warnings.Unused_var s
+           else Warnings.Unused_var_strict s in
+         let id' = Ident.rename pv_id in
+         let val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in
+         let val_env =
+          Env.add_value pv_id
+            { val_type = pv_type
+            ; val_kind = Val_reg
+            ; val_attributes = pv_attributes
+            ; val_loc = pv_loc
+            ; val_uid
+            }
+            val_env
+         in
+         let met_env =
+          Env.add_value id' ~check
+            { val_type = pv_type
+            ; val_kind = Val_ivar (Immutable, cl_num)
+            ; val_attributes = pv_attributes
+            ; val_loc = pv_loc
+            ; val_uid
+            }
+            met_env
+         in
+         ((id', pv_id, pv_type)::pv, val_env, met_env))
+      !pattern_variables ([], val_env, met_env)
+  in
+  (pat, pv, val_env, met_env)
+
+let type_self_pattern cl_num privty val_env met_env par_env spat =
+  let open Ast_helper in
+  let spat =
+    Pat.mk (Ppat_alias (Pat.mk(Ppat_alias (spat, mknoloc "selfpat-*")),
+                        mknoloc ("selfpat-" ^ cl_num)))
+  in
+  reset_pattern None false;
+  let nv = newvar() in
+  let pat =
+    type_pat Value ~no_existentials:In_self_pattern (ref val_env) spat nv in
+  List.iter (fun f -> f()) (get_ref pattern_force);
+  let meths = ref Meths.empty in
+  let vars = ref Vars.empty in
+  let pv = !pattern_variables in
+  pattern_variables := [];
+  let (val_env, met_env, par_env) =
+    List.fold_right
+      (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes}
+           (val_env, met_env, par_env) ->
+         let name = Ident.name pv_id in
+         (Env.enter_unbound_value name Val_unbound_self val_env,
+          Env.add_value pv_id
+            {val_type = pv_type;
+             val_kind = Val_self (meths, vars, cl_num, privty);
+             val_attributes = pv_attributes;
+             val_loc = pv_loc;
+             val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+            }
+            ~check:(fun s -> if pv_as_var then Warnings.Unused_var s
+                             else Warnings.Unused_var_strict s)
+            met_env,
+          Env.enter_unbound_value name Val_unbound_self par_env))
+      pv (val_env, met_env, par_env)
+  in
+  (pat, meths, vars, val_env, met_env, par_env)
+
+let delayed_checks = ref []
+let reset_delayed_checks () = delayed_checks := []
+let add_delayed_check f =
+  delayed_checks := (f, Warnings.backup ()) :: !delayed_checks
+
+let force_delayed_checks () =
+  (* checks may change type levels *)
+  let snap = Btype.snapshot () in
+  let w_old = Warnings.backup () in
+  List.iter
+    (fun (f, w) -> Warnings.restore w; f ())
+    (List.rev !delayed_checks);
+  Warnings.restore w_old;
+  reset_delayed_checks ();
+  Btype.backtrack snap
+
+let rec final_subexpression exp =
+  match exp.exp_desc with
+    Texp_let (_, _, e)
+  | Texp_sequence (_, e)
+  | Texp_try (e, _)
+  | Texp_ifthenelse (_, e, _)
+  | Texp_match (_, {c_rhs=e} :: _, _)
+  | Texp_letmodule (_, _, _, _, e)
+  | Texp_letexception (_, e)
+  | Texp_open (_, e)
+    -> final_subexpression e
+  | _ -> exp
+
+(* Generalization criterion for expressions *)
+
+let rec is_nonexpansive exp =
+  match exp.exp_desc with
+  | Texp_ident _
+  | Texp_constant _
+  | Texp_unreachable
+  | Texp_function _
+  | Texp_array [] -> true
+  | Texp_let(_rec_flag, pat_exp_list, body) ->
+      List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list &&
+      is_nonexpansive body
+  | Texp_apply(e, (_,None)::el) ->
+      is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd el)
+  | Texp_match(e, cases, _) ->
+     (* Not sure this is necessary, if [e] is nonexpansive then we shouldn't
+         care if there are exception patterns. But the previous version enforced
+         that there be none, so... *)
+      let contains_exception_pat pat =
+        exists_general_pattern { f = fun (type k) (p : k general_pattern) ->
+          match p.pat_desc with
+          | Tpat_exception _ -> true
+          | _ -> false } pat
+      in
+      is_nonexpansive e &&
+      List.for_all
+        (fun {c_lhs; c_guard; c_rhs} ->
+           is_nonexpansive_opt c_guard && is_nonexpansive c_rhs
+           && not (contains_exception_pat c_lhs)
+        ) cases
+  | Texp_tuple el ->
+      List.for_all is_nonexpansive el
+  | Texp_construct( _, _, el) ->
+      List.for_all is_nonexpansive el
+  | Texp_variant(_, arg) -> is_nonexpansive_opt arg
+  | Texp_record { fields; extended_expression } ->
+      Array.for_all
+        (fun (lbl, definition) ->
+           match definition with
+           | Overridden (_, exp) ->
+               lbl.lbl_mut = Immutable && is_nonexpansive exp
+           | Kept _ -> true)
+        fields
+      && is_nonexpansive_opt extended_expression
+  | Texp_field(exp, _, _) -> is_nonexpansive exp
+  | Texp_ifthenelse(_cond, ifso, ifnot) ->
+      is_nonexpansive ifso && is_nonexpansive_opt ifnot
+  | Texp_sequence (_e1, e2) -> is_nonexpansive e2  (* PR#4354 *)
+  | Texp_new (_, _, cl_decl) -> Ctype.class_type_arity cl_decl.cty_type > 0
+  (* Note: nonexpansive only means no _observable_ side effects *)
+  | Texp_lazy e -> is_nonexpansive e
+  | Texp_object ({cstr_fields=fields; cstr_type = { csig_vars=vars}}, _) ->
+      let count = ref 0 in
+      List.for_all
+        (fun field -> match field.cf_desc with
+            Tcf_method _ -> true
+          | Tcf_val (_, _, _, Tcfk_concrete (_, e), _) ->
+              incr count; is_nonexpansive e
+          | Tcf_val (_, _, _, Tcfk_virtual _, _) ->
+              incr count; true
+          | Tcf_initializer e -> is_nonexpansive e
+          | Tcf_constraint _ -> true
+          | Tcf_inherit _ -> false
+          | Tcf_attribute _ -> true)
+        fields &&
+      Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable)
+        vars true &&
+      !count = 0
+  | Texp_letmodule (_, _, _, mexp, e)
+  | Texp_open ({ open_expr = mexp; _}, e) ->
+      is_nonexpansive_mod mexp && is_nonexpansive e
+  | Texp_pack mexp ->
+      is_nonexpansive_mod mexp
+  (* Computations which raise exceptions are nonexpansive, since (raise e) is
+     equivalent to (raise e; diverge), and a nonexpansive "diverge" can be
+     produced using lazy values or the relaxed value restriction.
+     See GPR#1142 *)
+  | Texp_assert exp ->
+      is_nonexpansive exp
+  | Texp_apply (
+      { exp_desc = Texp_ident (_, _, {val_kind =
+             Val_prim {Primitive.prim_name =
+                         ("%raise" | "%reraise" | "%raise_notrace")}}) },
+      [Nolabel, Some e]) ->
+     is_nonexpansive e
+  | Texp_array (_ :: _)
+  | Texp_apply _
+  | Texp_try _
+  | Texp_setfield _
+  | Texp_while _
+  | Texp_for _
+  | Texp_send _
+  | Texp_instvar _
+  | Texp_setinstvar _
+  | Texp_override _
+  | Texp_letexception _
+  | Texp_letop _
+  | Texp_extension_constructor _ ->
+    false
+
+and is_nonexpansive_mod mexp =
+  match mexp.mod_desc with
+  | Tmod_ident _
+  | Tmod_functor _ -> true
+  | Tmod_unpack (e, _) -> is_nonexpansive e
+  | Tmod_constraint (m, _, _, _) -> is_nonexpansive_mod m
+  | Tmod_structure str ->
+      List.for_all
+        (fun item -> match item.str_desc with
+          | Tstr_eval _ | Tstr_primitive _ | Tstr_type _
+          | Tstr_modtype _ | Tstr_class_type _  -> true
+          | Tstr_value (_, pat_exp_list) ->
+              List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list
+          | Tstr_module {mb_expr=m;_}
+          | Tstr_open {open_expr=m;_}
+          | Tstr_include {incl_mod=m;_} -> is_nonexpansive_mod m
+          | Tstr_recmodule id_mod_list ->
+              List.for_all (fun {mb_expr=m;_} -> is_nonexpansive_mod m)
+                id_mod_list
+          | Tstr_exception {tyexn_constructor = {ext_kind = Text_decl _}} ->
+              false (* true would be unsound *)
+          | Tstr_exception {tyexn_constructor = {ext_kind = Text_rebind _}} ->
+              true
+          | Tstr_typext te ->
+              List.for_all
+                (function {ext_kind = Text_decl _} -> false
+                        | {ext_kind = Text_rebind _} -> true)
+                te.tyext_constructors
+          | Tstr_class _ -> false (* could be more precise *)
+          | Tstr_attribute _ -> true
+        )
+        str.str_items
+  | Tmod_apply _ -> false
+
+and is_nonexpansive_opt = function
+  | None -> true
+  | Some e -> is_nonexpansive e
+
+let maybe_expansive e = not (is_nonexpansive e)
+
+let check_recursive_bindings env valbinds =
+  let ids = let_bound_idents valbinds in
+  List.iter
+    (fun {vb_expr} ->
+       if not (Rec_check.is_valid_recursive_expression ids vb_expr) then
+         raise(Error(vb_expr.exp_loc, env, Illegal_letrec_expr))
+    )
+    valbinds
+
+let check_recursive_class_bindings env ids exprs =
+  List.iter
+    (fun expr ->
+       if not (Rec_check.is_valid_class_expr ids expr) then
+         raise(Error(expr.cl_loc, env, Illegal_class_expr)))
+    exprs
+
+let is_prim ~name funct =
+  match funct.exp_desc with
+  | Texp_ident (_, _, {val_kind=Val_prim{Primitive.prim_name; _}}) ->
+      prim_name = name
+  | _ -> false
+(* Approximate the type of an expression, for better recursion *)
+
+let rec approx_type env sty =
+  match sty.ptyp_desc with
+    Ptyp_arrow (p, _, sty) ->
+      let ty1 = if is_optional p then type_option (newvar ()) else newvar () in
+      newty (Tarrow (p, ty1, approx_type env sty, Cok))
+  | Ptyp_tuple args ->
+      newty (Ttuple (List.map (approx_type env) args))
+  | Ptyp_constr (lid, ctl) ->
+      let path, decl = Env.lookup_type ~use:false ~loc:lid.loc lid.txt env in
+      if List.length ctl <> decl.type_arity then newvar ()
+      else begin
+        let tyl = List.map (approx_type env) ctl in
+        newconstr path tyl
+      end
+  | Ptyp_poly (_, sty) ->
+      approx_type env sty
+  | _ -> newvar ()
+
+let rec type_approx env sexp =
+  match sexp.pexp_desc with
+    Pexp_let (_, _, e) -> type_approx env e
+  | Pexp_fun (p, _, _, e) ->
+      let ty = if is_optional p then type_option (newvar ()) else newvar () in
+      newty (Tarrow(p, ty, type_approx env e, Cok))
+  | Pexp_function ({pc_rhs=e}::_) ->
+      newty (Tarrow(Nolabel, newvar (), type_approx env e, Cok))
+  | Pexp_match (_, {pc_rhs=e}::_) -> type_approx env e
+  | Pexp_try (e, _) -> type_approx env e
+  | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l))
+  | Pexp_ifthenelse (_,e,_) -> type_approx env e
+  | Pexp_sequence (_,e) -> type_approx env e
+  | Pexp_constraint (e, sty) ->
+      let ty = type_approx env e in
+      let ty1 = approx_type env sty in
+      begin try unify env ty ty1 with Unify trace ->
+        raise(Error(sexp.pexp_loc, env, Expr_type_clash (trace, None, None)))
+      end;
+      ty1
+  | Pexp_coerce (e, sty1, sty2) ->
+      let approx_ty_opt = function
+        | None -> newvar ()
+        | Some sty -> approx_type env sty
+      in
+      let ty = type_approx env e
+      and ty1 = approx_ty_opt sty1
+      and ty2 = approx_type env sty2 in
+      begin try unify env ty ty1 with Unify trace ->
+        raise(Error(sexp.pexp_loc, env, Expr_type_clash (trace, None, None)))
+      end;
+      ty2
+  | _ -> newvar ()
+
+(* List labels in a function type, and whether return type is a variable *)
+let rec list_labels_aux env visited ls ty_fun =
+  let ty = expand_head env ty_fun in
+  if List.memq ty visited then
+    List.rev ls, false
+  else match ty.desc with
+    Tarrow (l, _, ty_res, _) ->
+      list_labels_aux env (ty::visited) (l::ls) ty_res
+  | _ ->
+      List.rev ls, is_Tvar ty
+
+let list_labels env ty =
+  wrap_trace_gadt_instances env (list_labels_aux env [] []) ty
+
+(* Check that all univars are safe in a type. Both exp.exp_type and
+   ty_expected should already be generalized. *)
+let check_univars env kind exp ty_expected vars =
+  let pty = instance ty_expected in
+  begin_def ();
+  let exp_ty, vars =
+    match pty.desc with
+      Tpoly (body, tl) ->
+        (* Enforce scoping for type_let:
+           since body is not generic,  instance_poly only makes
+           copies of nodes that have a Tvar as descendant *)
+        let _, ty' = instance_poly true tl body in
+        let vars, exp_ty = instance_parameterized_type vars exp.exp_type in
+        unify_exp_types exp.exp_loc env exp_ty ty';
+        exp_ty, vars
+    | _ -> assert false
+  in
+  end_def ();
+  generalize exp_ty;
+  List.iter generalize vars;
+  let ty, complete = polyfy env exp_ty vars in
+  if not complete then
+    let ty_expected = instance ty_expected in
+    raise (Error (exp.exp_loc, env,
+                  Less_general(kind, [Unification_trace.diff ty ty_expected])))
+
+let generalize_and_check_univars env kind exp ty_expected vars =
+  generalize exp.exp_type;
+  generalize ty_expected;
+  List.iter generalize vars;
+  check_univars env kind exp ty_expected vars
+
+let check_partial_application statement exp =
+  let rec f delay =
+    let ty = (expand_head exp.exp_env exp.exp_type).desc in
+    let check_statement () =
+      match ty with
+      | Tconstr (p, _, _)  when Path.same p Predef.path_unit ->
+          ()
+      | _ ->
+          if statement then
+            let rec loop {exp_loc; exp_desc; exp_extra; _} =
+              match exp_desc with
+              | Texp_let (_, _, e)
+              | Texp_sequence (_, e)
+              | Texp_letexception (_, e)
+              | Texp_letmodule (_, _, _, _, e) ->
+                  loop e
+              | _ ->
+                  let loc =
+                    match List.find_opt (function
+                        | (Texp_constraint _, _, _) -> true
+                        | _ -> false) exp_extra
+                    with
+                    | Some (_, loc, _) -> loc
+                    | None -> exp_loc
+                  in
+                  Location.prerr_warning loc Warnings.Statement_type
+            in
+            loop exp
+    in
+    match ty, exp.exp_desc with
+    | Tarrow _, _ ->
+        let rec check {exp_desc; exp_loc; exp_extra; _} =
+          if List.exists (function
+              | (Texp_constraint _, _, _) -> true
+              | _ -> false) exp_extra then check_statement ()
+          else begin
+            match exp_desc with
+            | Texp_ident _ | Texp_constant _ | Texp_tuple _
+            | Texp_construct _ | Texp_variant _ | Texp_record _
+            | Texp_field _ | Texp_setfield _ | Texp_array _
+            | Texp_while _ | Texp_for _ | Texp_instvar _
+            | Texp_setinstvar _ | Texp_override _ | Texp_assert _
+            | Texp_lazy _ | Texp_object _ | Texp_pack _ | Texp_unreachable
+            | Texp_extension_constructor _ | Texp_ifthenelse (_, _, None)
+            | Texp_function _ ->
+                check_statement ()
+            | Texp_match (_, cases, _) ->
+                List.iter (fun {c_rhs; _} -> check c_rhs) cases
+            | Texp_try (e, cases) ->
+                check e; List.iter (fun {c_rhs; _} -> check c_rhs) cases
+            | Texp_ifthenelse (_, e1, Some e2) ->
+                check e1; check e2
+            | Texp_let (_, _, e) | Texp_sequence (_, e) | Texp_open (_, e)
+            | Texp_letexception (_, e) | Texp_letmodule (_, _, _, _, e) ->
+                check e
+            | Texp_apply _ | Texp_send _ | Texp_new _ | Texp_letop _ ->
+                Location.prerr_warning exp_loc Warnings.Partial_application
+          end
+        in
+        check exp
+    | Tvar _, _ ->
+        if delay then add_delayed_check (fun () -> f false)
+    | _ ->
+        check_statement ()
+  in
+  f true
+
+(* Check that a type is generalizable at some level *)
+let generalizable level ty =
+  let rec check ty =
+    let ty = repr ty in
+    if ty.level < lowest_level then () else
+    if ty.level <= level then raise Exit else
+    (mark_type_node ty; iter_type_expr check ty)
+  in
+  try check ty; unmark_type ty; true
+  with Exit -> unmark_type ty; false
+
+(* Hack to allow coercion of self. Will clean-up later. *)
+let self_coercion = ref ([] : (Path.t * Location.t list ref) list)
+
+(* Helpers for packaged modules. *)
+let create_package_type loc env (p, l) =
+  let s = !Typetexp.transl_modtype_longident loc env p in
+  let fields = List.map (fun (name, ct) ->
+                           name, Typetexp.transl_simple_type env false ct) l in
+  let ty = newty (Tpackage (s,
+                    List.map fst l,
+                   List.map (fun (_, cty) -> cty.ctyp_type) fields))
+  in
+   (s, fields, ty)
+
+(* Helpers for type_cases *)
+
+let contains_variant_either ty =
+  let rec loop ty =
+    let ty = repr ty in
+    if ty.level >= lowest_level then begin
+      mark_type_node ty;
+      match ty.desc with
+        Tvariant row ->
+          let row = row_repr row in
+          if not (is_fixed row) then
+            List.iter
+              (fun (_,f) ->
+                match row_field_repr f with Reither _ -> raise Exit | _ -> ())
+              row.row_fields;
+          iter_row loop row
+      | _ ->
+          iter_type_expr loop ty
+    end
+  in
+  try loop ty; unmark_type ty; false
+  with Exit -> unmark_type ty; true
+
+let shallow_iter_ppat f p =
+  match p.ppat_desc with
+  | Ppat_any | Ppat_var _ | Ppat_constant _ | Ppat_interval _
+  | Ppat_extension _
+  | Ppat_type _ | Ppat_unpack _ -> ()
+  | Ppat_array pats -> List.iter f pats
+  | Ppat_or (p1,p2) -> f p1; f p2
+  | Ppat_variant (_, arg) | Ppat_construct (_, arg) -> Option.iter f arg
+  | Ppat_tuple lst ->  List.iter f lst
+  | Ppat_exception p | Ppat_alias (p,_)
+  | Ppat_open (_,p)
+  | Ppat_constraint (p,_) | Ppat_lazy p -> f p
+  | Ppat_record (args, _flag) -> List.iter (fun (_,p) -> f p) args
+
+let exists_ppat f p =
+  let exception Found in
+  let rec loop p =
+    if f p then raise Found else ();
+    shallow_iter_ppat loop p in
+  match loop p with
+  | exception Found -> true
+  | () -> false
+
+let contains_polymorphic_variant p =
+  exists_ppat
+    (function
+     | {ppat_desc = (Ppat_variant _ | Ppat_type _)} -> true
+     | _ -> false)
+    p
+
+let contains_gadt p =
+  exists_general_pattern { f = fun (type k) (p : k general_pattern) ->
+     match p.pat_desc with
+     | Tpat_construct (_, cd, _) when cd.cstr_generalized -> true
+     | _ -> false } p
+
+(* There are various things that we need to do in presence of GADT constructors
+   that aren't required if there are none.
+   However, because of disambiguation, we can't know for sure whether the
+   patterns contain some GADT constructors. So we conservatively assume that
+   any constructor might be a GADT constructor. *)
+let may_contain_gadts p =
+  exists_ppat
+  (function
+   | {ppat_desc = Ppat_construct (_, _)} -> true
+   | _ -> false)
+  p
+
+let check_absent_variant env =
+  iter_general_pattern { f = fun (type k) (pat : k general_pattern) ->
+    match pat.pat_desc with
+    | Tpat_variant (s, arg, row) ->
+      let row = row_repr !row in
+      if List.exists (fun (s',fi) -> s = s' && row_field_repr fi <> Rabsent)
+          row.row_fields
+      || not (is_fixed row) && not (static_row row)  (* same as Ctype.poly *)
+      then () else
+      let ty_arg =
+        match arg with None -> [] | Some p -> [correct_levels p.pat_type] in
+      let row' = {row_fields = [s, Reither(arg=None,ty_arg,true,ref None)];
+                  row_more = newvar (); row_bound = ();
+                  row_closed = false; row_fixed = None; row_name = None} in
+      (* Should fail *)
+      unify_pat (ref env) {pat with pat_type = newty (Tvariant row')}
+                          (correct_levels pat.pat_type)
+    | _ -> () }
+
+(* Getting proper location of already typed expressions.
+
+   Used to avoid confusing locations on type error messages in presence of
+   type constraints.
+   For example:
+
+       (* Before patch *)
+       # let x : string = (5 : int);;
+                           ^
+       (* After patch *)
+       # let x : string = (5 : int);;
+                          ^^^^^^^^^
+*)
+let proper_exp_loc exp =
+  let rec aux = function
+    | [] -> exp.exp_loc
+    | ((Texp_constraint _ | Texp_coerce _), loc, _) :: _ -> loc
+    | _ :: rest -> aux rest
+  in
+  aux exp.exp_extra
+
+(* To find reasonable names for let-bound and lambda-bound idents *)
+
+let rec name_pattern default = function
+    [] -> Ident.create_local default
+  | p :: rem ->
+    match p.pat_desc with
+      Tpat_var (id, _) -> id
+    | Tpat_alias(_, id, _) -> id
+    | _ -> name_pattern default rem
+
+let name_cases default lst =
+  name_pattern default (List.map (fun c -> c.c_lhs) lst)
+
+(* Typing of expressions *)
+
+let unify_exp env exp expected_ty =
+  let loc = proper_exp_loc exp in
+  try
+    unify_exp_types loc env exp.exp_type expected_ty
+  with Error(loc, env, Expr_type_clash(trace, tfc, None)) ->
+    raise (Error(loc, env, Expr_type_clash(trace, tfc, Some exp.exp_desc)))
+
+let rec type_exp ?recarg env sexp =
+  (* We now delegate everything to type_expect *)
+  type_expect ?recarg env sexp (mk_expected (newvar ()))
+
+(* Typing of an expression with an expected type.
+   This provide better error messages, and allows controlled
+   propagation of return type information.
+   In the principal case, [type_expected'] may be at generic_level.
+ *)
+
+and type_expect ?in_function ?recarg env sexp ty_expected_explained =
+  let previous_saved_types = Cmt_format.get_saved_types () in
+  let exp =
+    Builtin_attributes.warning_scope sexp.pexp_attributes
+      (fun () ->
+         type_expect_ ?in_function ?recarg env sexp ty_expected_explained
+      )
+  in
+  Cmt_format.set_saved_types
+    (Cmt_format.Partial_expression exp :: previous_saved_types);
+  exp
+
+and with_explanation explanation f =
+  match explanation with
+  | None -> f ()
+  | Some explanation ->
+      try f ()
+      with Error (loc', env', Expr_type_clash(trace', None, exp'))
+        when not loc'.Location.loc_ghost ->
+        let err = Expr_type_clash(trace', Some explanation, exp') in
+        raise (Error (loc', env', err))
+
+and type_expect_
+    ?in_function ?(recarg=Rejected)
+    env sexp ty_expected_explained =
+  let { ty = ty_expected; explanation } = ty_expected_explained in
+  let loc = sexp.pexp_loc in
+  (* Record the expression type before unifying it with the expected type *)
+  let with_explanation = with_explanation explanation in
+  let rue exp =
+    with_explanation (fun () ->
+      unify_exp env (re exp) (instance ty_expected));
+    exp
+  in
+  match sexp.pexp_desc with
+  | Pexp_ident lid ->
+      let path, desc = type_ident env ~recarg lid in
+      let exp_desc =
+        match desc.val_kind with
+        | Val_ivar (_, cl_num) ->
+            let (self_path, _) =
+              Env.find_value_by_name
+                (Longident.Lident ("self-" ^ cl_num)) env
+            in
+            Texp_instvar(self_path, path,
+                         match lid.txt with
+                             Longident.Lident txt -> { txt; loc = lid.loc }
+                           | _ -> assert false)
+        | Val_self (_, _, cl_num, _) ->
+            let (path, _) =
+              Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env
+            in
+            Texp_ident(path, lid, desc)
+        | _ ->
+            Texp_ident(path, lid, desc)
+      in
+      rue {
+        exp_desc; exp_loc = loc; exp_extra = [];
+        exp_type = instance desc.val_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_constant(Pconst_string (str, _, _) as cst) -> (
+    let cst = constant_or_raise env loc cst in
+    (* Terrible hack for format strings *)
+    let ty_exp = expand_head env ty_expected in
+    let fmt6_path =
+      Path.(Pdot (Pident (Ident.create_persistent "CamlinternalFormatBasics"),
+                  "format6"))
+    in
+    let is_format = match ty_exp.desc with
+      | Tconstr(path, _, _) when Path.same path fmt6_path ->
+        if !Clflags.principal && ty_exp.level <> generic_level then
+          Location.prerr_warning loc
+            (Warnings.Not_principal "this coercion to format6");
+        true
+      | _ -> false
+    in
+    if is_format then
+      let format_parsetree =
+        { (type_format loc str env) with pexp_loc = sexp.pexp_loc }  in
+      type_expect ?in_function env format_parsetree ty_expected_explained
+    else
+      rue {
+        exp_desc = Texp_constant cst;
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance Predef.type_string;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  )
+  | Pexp_constant cst ->
+      let cst = constant_or_raise env loc cst in
+      rue {
+        exp_desc = Texp_constant cst;
+        exp_loc = loc; exp_extra = [];
+        exp_type = type_constant cst;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_let(Nonrecursive,
+             [{pvb_pat=spat; pvb_expr=sval; pvb_attributes=[]}], sbody)
+    when may_contain_gadts spat ->
+    (* TODO: allow non-empty attributes? *)
+      type_expect ?in_function env
+        {sexp with
+         pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody])}
+        ty_expected_explained
+  | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
+      let existential_context =
+        if rec_flag = Recursive then In_rec
+        else if List.compare_length_with spat_sexp_list 1 > 0 then In_group
+        else With_attributes in
+      let scp =
+        match sexp.pexp_attributes, rec_flag with
+        | [{attr_name = {txt="#default"}; _}], _ -> None
+        | _, Recursive -> Some (Annot.Idef loc)
+        | _, Nonrecursive -> Some (Annot.Idef sbody.pexp_loc)
+      in
+      let (pat_exp_list, new_env, unpacks) =
+        type_let existential_context env rec_flag spat_sexp_list scp true in
+      let body = type_unpacks new_env unpacks sbody ty_expected_explained in
+      let () =
+        if rec_flag = Recursive then
+          check_recursive_bindings env pat_exp_list
+      in
+      re {
+        exp_desc = Texp_let(rec_flag, pat_exp_list, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = body.exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_fun (l, Some default, spat, sbody) ->
+      assert(is_optional l); (* default allowed only with optional argument *)
+      let open Ast_helper in
+      let default_loc = default.pexp_loc in
+      let scases = [
+        Exp.case
+          (Pat.construct ~loc:default_loc
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
+             (Some (Pat.var ~loc:default_loc (mknoloc "*sth*"))))
+          (Exp.ident ~loc:default_loc (mknoloc (Longident.Lident "*sth*")));
+
+        Exp.case
+          (Pat.construct ~loc:default_loc
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
+             None)
+          default;
+       ]
+      in
+      let sloc =
+        { Location.loc_start = spat.ppat_loc.Location.loc_start;
+          loc_end = default_loc.Location.loc_end;
+          loc_ghost = true }
+      in
+      let smatch =
+        Exp.match_ ~loc:sloc
+          (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*")))
+          scases
+      in
+      let pat = Pat.var ~loc:sloc (mknoloc "*opt*") in
+      let body =
+        Exp.let_ ~loc Nonrecursive
+          ~attrs:[Attr.mk (mknoloc "#default") (PStr [])]
+          [Vb.mk spat smatch] sbody
+      in
+      type_function ?in_function loc sexp.pexp_attributes env
+                    ty_expected_explained l [Exp.case pat body]
+  | Pexp_fun (l, None, spat, sbody) ->
+      type_function ?in_function loc sexp.pexp_attributes env
+                    ty_expected_explained l [Ast_helper.Exp.case spat sbody]
+  | Pexp_function caselist ->
+      type_function ?in_function
+        loc sexp.pexp_attributes env ty_expected_explained Nolabel caselist
+  | Pexp_apply(sfunct, sargs) ->
+      assert (sargs <> []);
+      begin_def (); (* one more level for non-returning functions *)
+      if !Clflags.principal then begin_def ();
+      let funct = type_exp env sfunct in
+      if !Clflags.principal then begin
+          end_def ();
+          generalize_structure funct.exp_type
+        end;
+      let rec lower_args seen ty_fun =
+        let ty = expand_head env ty_fun in
+        if List.memq ty seen then () else
+        match ty.desc with
+          Tarrow (_l, ty_arg, ty_fun, _com) ->
+            (try unify_var env (newvar()) ty_arg with Unify _ -> assert false);
+            lower_args (ty::seen) ty_fun
+        | _ -> ()
+      in
+      let ty = instance funct.exp_type in
+      end_def ();
+      wrap_trace_gadt_instances env (lower_args []) ty;
+      begin_def ();
+      let (args, ty_res) = type_application env funct sargs in
+      end_def ();
+      unify_var env (newvar()) funct.exp_type;
+      rue {
+        exp_desc = Texp_apply(funct, args);
+        exp_loc = loc; exp_extra = [];
+        exp_type = ty_res;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_match(sarg, caselist) ->
+      begin_def ();
+      let arg = type_exp env sarg in
+      end_def ();
+      if maybe_expansive arg then lower_contravariant env arg.exp_type;
+      generalize arg.exp_type;
+      let cases, partial =
+        type_cases Computation env arg.exp_type ty_expected true loc caselist in
+      re {
+        exp_desc = Texp_match(arg, cases, partial);
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance ty_expected;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_try(sbody, caselist) ->
+      let body = type_expect env sbody ty_expected_explained in
+      let cases, _ =
+        type_cases Value env Predef.type_exn ty_expected false loc caselist in
+      re {
+        exp_desc = Texp_try(body, cases);
+        exp_loc = loc; exp_extra = [];
+        exp_type = body.exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_tuple sexpl ->
+      assert (List.length sexpl >= 2);
+      let subtypes = List.map (fun _ -> newgenvar ()) sexpl in
+      let to_unify = newgenty (Ttuple subtypes) in
+      with_explanation (fun () ->
+        unify_exp_types loc env to_unify ty_expected);
+      let expl =
+        List.map2 (fun body ty -> type_expect env body (mk_expected ty))
+          sexpl subtypes
+      in
+      re {
+        exp_desc = Texp_tuple expl;
+        exp_loc = loc; exp_extra = [];
+        (* Keep sharing *)
+        exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl));
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_construct(lid, sarg) ->
+      type_construct env loc lid sarg ty_expected_explained sexp.pexp_attributes
+  | Pexp_variant(l, sarg) ->
+      (* Keep sharing *)
+      let ty_expected0 = instance ty_expected in
+      begin try match
+        sarg, expand_head env ty_expected, expand_head env ty_expected0 with
+      | Some sarg, {desc = Tvariant row}, {desc = Tvariant row0} ->
+          let row = row_repr row in
+          begin match row_field_repr (List.assoc l row.row_fields),
+          row_field_repr (List.assoc l row0.row_fields) with
+            Rpresent (Some ty), Rpresent (Some ty0) ->
+              let arg = type_argument env sarg ty ty0 in
+              re { exp_desc = Texp_variant(l, Some arg);
+                   exp_loc = loc; exp_extra = [];
+                   exp_type = ty_expected0;
+                   exp_attributes = sexp.pexp_attributes;
+                   exp_env = env }
+          | _ -> raise Not_found
+          end
+      | _ -> raise Not_found
+      with Not_found ->
+        let arg = Option.map (type_exp env) sarg in
+        let arg_type = Option.map (fun arg -> arg.exp_type) arg in
+        rue {
+          exp_desc = Texp_variant(l, arg);
+          exp_loc = loc; exp_extra = [];
+          exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type];
+                                    row_more = newvar ();
+                                    row_bound = ();
+                                    row_closed = false;
+                                    row_fixed = None;
+                                    row_name = None});
+          exp_attributes = sexp.pexp_attributes;
+          exp_env = env }
+      end
+  | Pexp_record(lid_sexp_list, opt_sexp) ->
+      assert (lid_sexp_list <> []);
+      let opt_exp =
+        match opt_sexp with
+          None -> None
+        | Some sexp ->
+            if !Clflags.principal then begin_def ();
+            let exp = type_exp ~recarg env sexp in
+            if !Clflags.principal then begin
+              end_def ();
+              generalize_structure exp.exp_type
+            end;
+            Some exp
+      in
+      let ty_record, expected_type =
+        let get_path ty =
+          try
+            let (p0, p,_) = extract_concrete_record env ty in
+            let principal =
+              (repr ty).level = generic_level || not !Clflags.principal
+            in
+            Some (p0, p, principal)
+          with Not_found -> None
+        in
+        match get_path ty_expected with
+          None ->
+            begin match opt_exp with
+              None -> newvar (), None
+            | Some exp ->
+                match get_path exp.exp_type with
+                  None -> newvar (), None
+                | Some (_, p', _) as op ->
+                    let decl = Env.find_type p' env in
+                    begin_def ();
+                    let ty =
+                      newconstr p' (instance_list decl.type_params) in
+                    end_def ();
+                    generalize_structure ty;
+                    ty, op
+            end
+        | op -> ty_expected, op
+      in
+      let closed = (opt_sexp = None) in
+      let lbl_exp_list =
+        wrap_disambiguate "This record expression is expected to have"
+          (mk_expected ty_record)
+          (type_label_a_list loc closed env
+             (fun e k -> k (type_label_exp true env loc ty_record e))
+             expected_type lid_sexp_list)
+          (fun x -> x)
+      in
+      with_explanation (fun () ->
+        unify_exp_types loc env ty_record (instance ty_expected));
+
+      (* type_label_a_list returns a list of labels sorted by lbl_pos *)
+      (* note: check_duplicates would better be implemented in
+         type_label_a_list directly *)
+      let rec check_duplicates = function
+        | (_, lbl1, _) :: (_, lbl2, _) :: _ when lbl1.lbl_pos = lbl2.lbl_pos ->
+          raise(Error(loc, env, Label_multiply_defined lbl1.lbl_name))
+        | _ :: rem ->
+            check_duplicates rem
+        | [] -> ()
+      in
+      check_duplicates lbl_exp_list;
+      let opt_exp, label_definitions =
+        let (_lid, lbl, _lbl_exp) = List.hd lbl_exp_list in
+        let matching_label lbl =
+          List.find
+            (fun (_, lbl',_) -> lbl'.lbl_pos = lbl.lbl_pos)
+            lbl_exp_list
+        in
+        match opt_exp with
+          None ->
+            let label_definitions =
+              Array.map (fun lbl ->
+                  match matching_label lbl with
+                  | (lid, _lbl, lbl_exp) ->
+                      Overridden (lid, lbl_exp)
+                  | exception Not_found ->
+                      let present_indices =
+                        List.map (fun (_, lbl, _) -> lbl.lbl_pos) lbl_exp_list
+                      in
+                      let label_names = extract_label_names env ty_expected in
+                      let rec missing_labels n = function
+                          [] -> []
+                        | lbl :: rem ->
+                            if List.mem n present_indices
+                            then missing_labels (n + 1) rem
+                            else lbl :: missing_labels (n + 1) rem
+                      in
+                      let missing = missing_labels 0 label_names in
+                      raise(Error(loc, env, Label_missing missing)))
+                lbl.lbl_all
+            in
+            None, label_definitions
+        | Some exp ->
+            let ty_exp = instance exp.exp_type in
+            let unify_kept lbl =
+              let _, ty_arg1, ty_res1 = instance_label false lbl in
+              unify_exp_types exp.exp_loc env ty_exp ty_res1;
+              match matching_label lbl with
+              | lid, _lbl, lbl_exp ->
+                  (* do not connect result types for overridden labels *)
+                  Overridden (lid, lbl_exp)
+              | exception Not_found -> begin
+                  let _, ty_arg2, ty_res2 = instance_label false lbl in
+                  unify_exp_types loc env ty_arg1 ty_arg2;
+                  with_explanation (fun () ->
+                    unify_exp_types loc env (instance ty_expected) ty_res2);
+                  Kept ty_arg1
+                end
+            in
+            let label_definitions = Array.map unify_kept lbl.lbl_all in
+            Some {exp with exp_type = ty_exp}, label_definitions
+      in
+      let num_fields =
+        match lbl_exp_list with [] -> assert false
+        | (_, lbl,_)::_ -> Array.length lbl.lbl_all in
+      if opt_sexp <> None && List.length lid_sexp_list = num_fields then
+        Location.prerr_warning loc Warnings.Useless_record_with;
+      let label_descriptions, representation =
+        let (_, { lbl_all; lbl_repres }, _) = List.hd lbl_exp_list in
+        lbl_all, lbl_repres
+      in
+      let fields =
+        Array.map2 (fun descr def -> descr, def)
+          label_descriptions label_definitions
+      in
+      re {
+        exp_desc = Texp_record {
+            fields; representation;
+            extended_expression = opt_exp
+          };
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance ty_expected;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_field(srecord, lid) ->
+      let (record, label, _) = type_label_access env srecord lid in
+      let (_, ty_arg, ty_res) = instance_label false label in
+      unify_exp env record ty_res;
+      rue {
+        exp_desc = Texp_field(record, lid, label);
+        exp_loc = loc; exp_extra = [];
+        exp_type = ty_arg;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_setfield(srecord, lid, snewval) ->
+      let (record, label, expected_type) =
+        type_label_access env srecord lid in
+      let ty_record =
+        if expected_type = None then newvar () else record.exp_type in
+      let (label_loc, label, newval) =
+        type_label_exp false env loc ty_record (lid, label, snewval) in
+      unify_exp env record ty_record;
+      if label.lbl_mut = Immutable then
+        raise(Error(loc, env, Label_not_mutable lid.txt));
+      rue {
+        exp_desc = Texp_setfield(record, label_loc, label, newval);
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance Predef.type_unit;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_array(sargl) ->
+      let ty = newgenvar() in
+      let to_unify = Predef.type_array ty in
+      with_explanation (fun () ->
+        unify_exp_types loc env to_unify ty_expected);
+      let argl =
+        List.map (fun sarg -> type_expect env sarg (mk_expected ty)) sargl in
+      re {
+        exp_desc = Texp_array argl;
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance ty_expected;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_ifthenelse(scond, sifso, sifnot) ->
+      let cond = type_expect env scond
+          (mk_expected ~explanation:If_conditional Predef.type_bool) in
+      begin match sifnot with
+        None ->
+          let ifso = type_expect env sifso
+              (mk_expected ~explanation:If_no_else_branch Predef.type_unit) in
+          rue {
+            exp_desc = Texp_ifthenelse(cond, ifso, None);
+            exp_loc = loc; exp_extra = [];
+            exp_type = ifso.exp_type;
+            exp_attributes = sexp.pexp_attributes;
+            exp_env = env }
+      | Some sifnot ->
+          let ifso = type_expect env sifso ty_expected_explained in
+          let ifnot = type_expect env sifnot ty_expected_explained in
+          (* Keep sharing *)
+          unify_exp env ifnot ifso.exp_type;
+          re {
+            exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot);
+            exp_loc = loc; exp_extra = [];
+            exp_type = ifso.exp_type;
+            exp_attributes = sexp.pexp_attributes;
+            exp_env = env }
+      end
+  | Pexp_sequence(sexp1, sexp2) ->
+      let exp1 = type_statement ~explanation:Sequence_left_hand_side
+          env sexp1 in
+      let exp2 = type_expect env sexp2 ty_expected_explained in
+      re {
+        exp_desc = Texp_sequence(exp1, exp2);
+        exp_loc = loc; exp_extra = [];
+        exp_type = exp2.exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_while(scond, sbody) ->
+      let cond = type_expect env scond
+          (mk_expected ~explanation:While_loop_conditional Predef.type_bool) in
+      let body = type_statement ~explanation:While_loop_body env sbody in
+      rue {
+        exp_desc = Texp_while(cond, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance Predef.type_unit;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_for(param, slow, shigh, dir, sbody) ->
+      let low = type_expect env slow
+          (mk_expected ~explanation:For_loop_start_index Predef.type_int) in
+      let high = type_expect env shigh
+          (mk_expected ~explanation:For_loop_stop_index Predef.type_int) in
+      let id, new_env =
+        match param.ppat_desc with
+        | Ppat_any -> Ident.create_local "_for", env
+        | Ppat_var {txt} ->
+            Env.enter_value txt
+              {val_type = instance Predef.type_int;
+               val_attributes = [];
+               val_kind = Val_reg;
+               val_loc = loc;
+               val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+              } env
+              ~check:(fun s -> Warnings.Unused_for_index s)
+        | _ ->
+            raise (Error (param.ppat_loc, env, Invalid_for_loop_index))
+      in
+      let body = type_statement ~explanation:For_loop_body new_env sbody in
+      rue {
+        exp_desc = Texp_for(id, param, low, high, dir, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance Predef.type_unit;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_constraint (sarg, sty) ->
+      (* Pretend separate = true, 1% slowdown for lablgtk *)
+      begin_def ();
+      let cty = Typetexp.transl_simple_type env false sty in
+      let ty = cty.ctyp_type in
+      end_def ();
+      generalize_structure ty;
+      let (arg, ty') = (type_argument env sarg ty (instance ty), instance ty) in
+      rue {
+        exp_desc = arg.exp_desc;
+        exp_loc = arg.exp_loc;
+        exp_type = ty';
+        exp_attributes = arg.exp_attributes;
+        exp_env = env;
+        exp_extra =
+          (Texp_constraint cty, loc, sexp.pexp_attributes) :: arg.exp_extra;
+      }
+  | Pexp_coerce(sarg, sty, sty') ->
+      (* Pretend separate = true, 1% slowdown for lablgtk *)
+      (* Also see PR#7199 for a problem with the following:
+         let separate = !Clflags.principal || Env.has_local_constraints env in*)
+      let (arg, ty',cty,cty') =
+        match sty with
+        | None ->
+            let (cty', force) =
+              Typetexp.transl_simple_type_delayed env sty'
+            in
+            let ty' = cty'.ctyp_type in
+            begin_def ();
+            let arg = type_exp env sarg in
+            end_def ();
+            let tv = newvar () in
+            let gen = generalizable tv.level arg.exp_type in
+            unify_var env tv arg.exp_type;
+            begin match arg.exp_desc, !self_coercion, (repr ty').desc with
+              Texp_ident(_, _, {val_kind=Val_self _}), (path,r) :: _,
+              Tconstr(path',_,_) when Path.same path path' ->
+                (* prerr_endline "self coercion"; *)
+                r := loc :: !r;
+                force ()
+            | _ when free_variables ~env arg.exp_type = []
+                  && free_variables ~env ty' = [] ->
+                if not gen && (* first try a single coercion *)
+                  let snap = snapshot () in
+                  let ty, _b = enlarge_type env ty' in
+                  try
+                    force (); Ctype.unify env arg.exp_type ty; true
+                  with Unify _ ->
+                    backtrack snap; false
+                then ()
+                else begin try
+                  let force' = subtype env arg.exp_type ty' in
+                  force (); force' ();
+                  if not gen && !Clflags.principal then
+                    Location.prerr_warning loc
+                      (Warnings.Not_principal "this ground coercion");
+                with Subtype (tr1, tr2) ->
+                  (* prerr_endline "coercion failed"; *)
+                  raise(Error(loc, env, Not_subtype(tr1, tr2)))
+                end;
+            | _ ->
+                let ty, b = enlarge_type env ty' in
+                force ();
+                begin try Ctype.unify env arg.exp_type ty with Unify trace ->
+                  raise(Error(sarg.pexp_loc, env,
+                        Coercion_failure(ty', full_expand env ty', trace, b)))
+                end
+            end;
+            (arg, ty', None, cty')
+        | Some sty ->
+            begin_def ();
+            let (cty, force) =
+              Typetexp.transl_simple_type_delayed env sty
+            and (cty', force') =
+              Typetexp.transl_simple_type_delayed env sty'
+            in
+            let ty = cty.ctyp_type in
+            let ty' = cty'.ctyp_type in
+            begin try
+              let force'' = subtype env ty ty' in
+              force (); force' (); force'' ()
+            with Subtype (tr1, tr2) ->
+              raise(Error(loc, env, Not_subtype(tr1, tr2)))
+            end;
+            end_def ();
+            generalize_structure ty;
+            generalize_structure ty';
+            (type_argument env sarg ty (instance ty),
+             instance ty', Some cty, cty')
+      in
+      rue {
+        exp_desc = arg.exp_desc;
+        exp_loc = arg.exp_loc;
+        exp_type = ty';
+        exp_attributes = arg.exp_attributes;
+        exp_env = env;
+        exp_extra = (Texp_coerce (cty, cty'), loc, sexp.pexp_attributes) ::
+                       arg.exp_extra;
+      }
+  | Pexp_send (e, {txt=met}) ->
+      if !Clflags.principal then begin_def ();
+      let obj = type_exp env e in
+      let obj_meths = ref None in
+      begin try
+        let (meth, exp, typ) =
+          match obj.exp_desc with
+            Texp_ident(_path, _, {val_kind = Val_self (meths, _, _, privty)}) ->
+              obj_meths := Some meths;
+              let (id, typ) =
+                filter_self_method env met Private meths privty
+              in
+              if is_Tvar (repr typ) then
+                Location.prerr_warning loc
+                  (Warnings.Undeclared_virtual_method met);
+              (Tmeth_val id, None, typ)
+          | Texp_ident(_path, lid, {val_kind = Val_anc (methods, cl_num)}) ->
+              let method_id =
+                begin try List.assoc met methods with Not_found ->
+                  let valid_methods = List.map fst methods in
+                  raise(Error(e.pexp_loc, env,
+                              Undefined_inherited_method (met, valid_methods)))
+                end
+              in
+              begin match
+                Env.find_value_by_name
+                  (Longident.Lident ("selfpat-" ^ cl_num)) env,
+                Env.find_value_by_name
+                  (Longident.Lident ("self-" ^cl_num)) env
+              with
+              | (_, ({val_kind = Val_self (meths, _, _, privty)} as desc)),
+                (path, _) ->
+                  obj_meths := Some meths;
+                  let (_, typ) =
+                    filter_self_method env met Private meths privty
+                  in
+                  let method_type = newvar () in
+                  let (obj_ty, res_ty) = filter_arrow env method_type Nolabel in
+                  unify env obj_ty desc.val_type;
+                  unify env res_ty (instance typ);
+                  let method_desc =
+                    {val_type = method_type;
+                     val_kind = Val_reg;
+                     val_attributes = [];
+                     val_loc = Location.none;
+                     val_uid = Uid.internal_not_actually_unique;
+                    }
+                  in
+                  let exp_env = Env.add_value method_id method_desc env in
+                  let exp =
+                    Texp_apply({exp_desc =
+                                Texp_ident(Path.Pident method_id,
+                                           lid, method_desc);
+                                exp_loc = loc; exp_extra = [];
+                                exp_type = method_type;
+                                exp_attributes = []; (* check *)
+                                exp_env = exp_env},
+                          [ Nolabel,
+                            Some {exp_desc = Texp_ident(path, lid, desc);
+                                  exp_loc = obj.exp_loc; exp_extra = [];
+                                  exp_type = desc.val_type;
+                                  exp_attributes = []; (* check *)
+                                  exp_env = exp_env}
+                          ])
+                  in
+                  (Tmeth_name met, Some (re {exp_desc = exp;
+                                             exp_loc = loc; exp_extra = [];
+                                             exp_type = typ;
+                                             exp_attributes = []; (* check *)
+                                             exp_env = exp_env}), typ)
+              |  _ ->
+                  assert false
+              end
+          | _ ->
+              (Tmeth_name met, None,
+               filter_method env met Public obj.exp_type)
+        in
+        if !Clflags.principal then begin
+          end_def ();
+          generalize_structure typ;
+        end;
+        let typ =
+          match repr typ with
+            {desc = Tpoly (ty, [])} ->
+              instance ty
+          | {desc = Tpoly (ty, tl); level = l} ->
+              if !Clflags.principal && l <> generic_level then
+                Location.prerr_warning loc
+                  (Warnings.Not_principal "this use of a polymorphic method");
+              snd (instance_poly false tl ty)
+          | {desc = Tvar _} as ty ->
+              let ty' = newvar () in
+              unify env (instance ty) (newty(Tpoly(ty',[])));
+              (* if not !Clflags.nolabels then
+                 Location.prerr_warning loc (Warnings.Unknown_method met); *)
+              ty'
+          | _ ->
+              assert false
+        in
+        rue {
+          exp_desc = Texp_send(obj, meth, exp);
+          exp_loc = loc; exp_extra = [];
+          exp_type = typ;
+          exp_attributes = sexp.pexp_attributes;
+          exp_env = env }
+      with Unify _ ->
+        let valid_methods =
+          match !obj_meths with
+          | Some meths ->
+             Some (Meths.fold (fun meth _meth_ty li -> meth::li) !meths [])
+          | None ->
+             match (expand_head env obj.exp_type).desc with
+             | Tobject (fields, _) ->
+                let (fields, _) = Ctype.flatten_fields fields in
+                let collect_fields li (meth, meth_kind, _meth_ty) =
+                  if meth_kind = Fpresent then meth::li else li in
+                Some (List.fold_left collect_fields [] fields)
+             | _ -> None
+        in
+        raise(Error(e.pexp_loc, env,
+                    Undefined_method (obj.exp_type, met, valid_methods)))
+      end
+  | Pexp_new cl ->
+      let (cl_path, cl_decl) = Env.lookup_class ~loc:cl.loc cl.txt env in
+      begin match cl_decl.cty_new with
+          None ->
+            raise(Error(loc, env, Virtual_class cl.txt))
+        | Some ty ->
+            rue {
+              exp_desc = Texp_new (cl_path, cl, cl_decl);
+              exp_loc = loc; exp_extra = [];
+              exp_type = instance ty;
+              exp_attributes = sexp.pexp_attributes;
+              exp_env = env }
+        end
+  | Pexp_setinstvar (lab, snewval) -> begin
+      let (path, mut, cl_num, ty) =
+        Env.lookup_instance_variable ~loc lab.txt env
+      in
+      match mut with
+      | Mutable ->
+          let newval =
+            type_expect env snewval (mk_expected (instance ty))
+          in
+          let (path_self, _) =
+            Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env
+          in
+          rue {
+            exp_desc = Texp_setinstvar(path_self, path, lab, newval);
+            exp_loc = loc; exp_extra = [];
+            exp_type = instance Predef.type_unit;
+            exp_attributes = sexp.pexp_attributes;
+            exp_env = env }
+      | _ ->
+          raise(Error(loc, env, Instance_variable_not_mutable lab.txt))
+    end
+  | Pexp_override lst ->
+      let _ =
+       List.fold_right
+        (fun (lab, _) l ->
+           if List.exists (fun l -> l.txt = lab.txt) l then
+             raise(Error(loc, env,
+                         Value_multiply_overridden lab.txt));
+           lab::l)
+        lst
+        [] in
+      begin match
+        try
+          Env.find_value_by_name (Longident.Lident "selfpat-*") env,
+          Env.find_value_by_name (Longident.Lident "self-*") env
+        with Not_found ->
+          raise(Error(loc, env, Outside_class))
+      with
+        (_, {val_type = self_ty; val_kind = Val_self (_, vars, _, _)}),
+        (path_self, _) ->
+          let type_override (lab, snewval) =
+            begin try
+              let (id, _, _, ty) = Vars.find lab.txt !vars in
+              (Path.Pident id, lab,
+               type_expect env snewval (mk_expected (instance ty)))
+            with
+              Not_found ->
+                let vars = Vars.fold (fun var _ li -> var::li) !vars [] in
+                raise(Error(loc, env,
+                            Unbound_instance_variable (lab.txt, vars)))
+            end
+          in
+          let modifs = List.map type_override lst in
+          rue {
+            exp_desc = Texp_override(path_self, modifs);
+            exp_loc = loc; exp_extra = [];
+            exp_type = self_ty;
+            exp_attributes = sexp.pexp_attributes;
+            exp_env = env }
+      | _ ->
+          assert false
+      end
+  | Pexp_letmodule(name, smodl, sbody) ->
+      let ty = newvar() in
+      (* remember original level *)
+      begin_def ();
+      let context = Typetexp.narrow () in
+      let modl = !type_module env smodl in
+      Mtype.lower_nongen ty.level modl.mod_type;
+      let pres =
+        match modl.mod_type with
+        | Mty_alias _ -> Mp_absent
+        | _ -> Mp_present
+      in
+      let scope = create_scope () in
+      let md =
+        { md_type = modl.mod_type; md_attributes = []; md_loc = name.loc;
+          md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); }
+      in
+      let (id, new_env) =
+        match name.txt with
+        | None -> None, env
+        | Some name ->
+          let id, env = Env.enter_module_declaration ~scope name pres md env in
+          Some id, env
+      in
+      Typetexp.widen context;
+      (* ideally, we should catch Expr_type_clash errors
+         in type_expect triggered by escaping identifiers from the local module
+         and refine them into Scoping_let_module errors
+      *)
+      let body = type_expect new_env sbody ty_expected_explained in
+      (* go back to original level *)
+      end_def ();
+      Ctype.unify_var new_env ty body.exp_type;
+      re {
+        exp_desc = Texp_letmodule(id, name, pres, modl, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = ty;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_letexception(cd, sbody) ->
+      let (cd, newenv) = Typedecl.transl_exception env cd in
+      let body = type_expect newenv sbody ty_expected_explained in
+      re {
+        exp_desc = Texp_letexception(cd, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = body.exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+
+  | Pexp_assert (e) ->
+      let cond = type_expect env e
+          (mk_expected ~explanation:Assert_condition Predef.type_bool) in
+      let exp_type =
+        match cond.exp_desc with
+        | Texp_construct(_, {cstr_name="false"}, _) ->
+            instance ty_expected
+        | _ ->
+            instance Predef.type_unit
+      in
+      rue {
+        exp_desc = Texp_assert cond;
+        exp_loc = loc; exp_extra = [];
+        exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env;
+      }
+  | Pexp_lazy e ->
+      let ty = newgenvar () in
+      let to_unify = Predef.type_lazy_t ty in
+      with_explanation (fun () ->
+        unify_exp_types loc env to_unify ty_expected);
+      let arg = type_expect env e (mk_expected ty) in
+      re {
+        exp_desc = Texp_lazy arg;
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance ty_expected;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env;
+      }
+  | Pexp_object s ->
+      let desc, sign, meths = !type_object env loc s in
+      rue {
+        exp_desc = Texp_object (desc, (*sign,*) meths);
+        exp_loc = loc; exp_extra = [];
+        exp_type = sign.csig_self;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env;
+      }
+  | Pexp_poly(sbody, sty) ->
+      if !Clflags.principal then begin_def ();
+      let ty, cty =
+        match sty with None -> repr ty_expected, None
+        | Some sty ->
+            let sty = Ast_helper.Typ.force_poly sty in
+            let cty = Typetexp.transl_simple_type env false sty in
+            repr cty.ctyp_type, Some cty
+      in
+      if !Clflags.principal then begin
+        end_def ();
+        generalize_structure ty
+      end;
+      if sty <> None then
+        with_explanation (fun () ->
+          unify_exp_types loc env (instance ty) (instance ty_expected));
+      let exp =
+        match (expand_head env ty).desc with
+          Tpoly (ty', []) ->
+            let exp = type_expect env sbody (mk_expected ty') in
+            { exp with exp_type = instance ty }
+        | Tpoly (ty', tl) ->
+            (* One more level to generalize locally *)
+            begin_def ();
+            if !Clflags.principal then begin_def ();
+            let vars, ty'' = instance_poly true tl ty' in
+            if !Clflags.principal then begin
+              end_def ();
+              generalize_structure ty''
+            end;
+            let exp = type_expect env sbody (mk_expected ty'') in
+            end_def ();
+            generalize_and_check_univars env "method" exp ty_expected vars;
+            { exp with exp_type = instance ty }
+        | Tvar _ ->
+            let exp = type_exp env sbody in
+            let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in
+            unify_exp env exp ty;
+            exp
+        | _ -> assert false
+      in
+      re { exp with exp_extra =
+             (Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra }
+  | Pexp_newtype({txt=name}, sbody) ->
+      let ty =
+        if Typetexp.valid_tyvar_name name then
+          newvar ~name ()
+        else
+          newvar ()
+      in
+      (* remember original level *)
+      begin_def ();
+      (* Create a fake abstract type declaration for name. *)
+      let decl = {
+        type_params = [];
+        type_arity = 0;
+        type_kind = Type_abstract;
+        type_private = Public;
+        type_manifest = None;
+        type_variance = [];
+        type_separability = [];
+        type_is_newtype = true;
+        type_expansion_scope = Btype.lowest_level;
+        type_loc = loc;
+        type_attributes = [];
+        type_immediate = Unknown;
+        type_unboxed = unboxed_false_default_false;
+        type_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+      }
+      in
+      let scope = create_scope () in
+      let (id, new_env) = Env.enter_type ~scope name decl env in
+
+      let body = type_exp new_env sbody in
+      (* Replace every instance of this type constructor in the resulting
+         type. *)
+      let seen = Hashtbl.create 8 in
+      let rec replace t =
+        if Hashtbl.mem seen t.id then ()
+        else begin
+          Hashtbl.add seen t.id ();
+          match t.desc with
+          | Tconstr (Path.Pident id', _, _) when id == id' -> link_type t ty
+          | _ -> Btype.iter_type_expr replace t
+        end
+      in
+      let ety = Subst.type_expr Subst.identity body.exp_type in
+      replace ety;
+      (* back to original level *)
+      end_def ();
+      (* lower the levels of the result type *)
+      (* unify_var env ty ety; *)
+
+      (* non-expansive if the body is non-expansive, so we don't introduce
+         any new extra node in the typed AST. *)
+      rue { body with exp_loc = loc; exp_type = ety;
+            exp_extra =
+            (Texp_newtype name, loc, sexp.pexp_attributes) :: body.exp_extra }
+  | Pexp_pack m ->
+      let (p, nl) =
+        match Ctype.expand_head env (instance ty_expected) with
+          {desc = Tpackage (p, nl, _tl)} ->
+            if !Clflags.principal &&
+              (Ctype.expand_head env ty_expected).level < Btype.generic_level
+            then
+              Location.prerr_warning loc
+                (Warnings.Not_principal "this module packing");
+            (p, nl)
+        | {desc = Tvar _} ->
+            raise (Error (loc, env, Cannot_infer_signature))
+        | _ ->
+            raise (Error (loc, env, Not_a_packed_module ty_expected))
+      in
+      let (modl, tl') = !type_package env m p nl in
+      rue {
+        exp_desc = Texp_pack modl;
+        exp_loc = loc; exp_extra = [];
+        exp_type = newty (Tpackage (p, nl, tl'));
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_open (od, e) ->
+      let (od, _, newenv) = !type_open_decl env od in
+      let exp = type_expect newenv e ty_expected_explained in
+      rue {
+        exp_desc = Texp_open (od, exp);
+        exp_type = exp.exp_type;
+        exp_loc = loc;
+        exp_extra = [];
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env;
+      }
+  | Pexp_letop{ let_ = slet; ands = sands; body = sbody } ->
+      let rec loop spat_acc ty_acc sands =
+        match sands with
+        | [] -> spat_acc, ty_acc
+        | { pbop_pat = spat; _} :: rest ->
+            let ty = newvar () in
+            let loc = { slet.pbop_op.loc with Location.loc_ghost = true } in
+            let spat_acc = Ast_helper.Pat.tuple ~loc [spat_acc; spat] in
+            let ty_acc = newty (Ttuple [ty_acc; ty]) in
+            loop spat_acc ty_acc rest
+      in
+      if !Clflags.principal then begin_def ();
+      let let_loc = slet.pbop_op.loc in
+      let op_path, op_desc = type_binding_op_ident env slet.pbop_op in
+      let op_type = instance op_desc.val_type in
+      let spat_params, ty_params = loop slet.pbop_pat (newvar ()) sands in
+      let ty_func_result = newvar () in
+      let ty_func = newty (Tarrow(Nolabel, ty_params, ty_func_result, Cok)) in
+      let ty_result = newvar () in
+      let ty_andops = newvar () in
+      let ty_op =
+        newty (Tarrow(Nolabel, ty_andops,
+          newty (Tarrow(Nolabel, ty_func, ty_result, Cok)), Cok))
+      in
+      begin try
+        unify env op_type ty_op
+      with Unify trace ->
+        raise(Error(let_loc, env, Letop_type_clash(slet.pbop_op.txt, trace)))
+      end;
+      if !Clflags.principal then begin
+        end_def ();
+        generalize_structure ty_andops;
+        generalize_structure ty_params;
+        generalize_structure ty_func_result;
+        generalize_structure ty_result
+      end;
+      let exp, ands = type_andops env slet.pbop_exp sands ty_andops in
+      let scase = Ast_helper.Exp.case spat_params sbody in
+      let cases, partial =
+        type_cases Value env ty_params ty_func_result true loc [scase]
+      in
+      let body =
+        match cases with
+        | [case] -> case
+        | _ -> assert false
+      in
+      let param = name_cases "param" cases in
+      let let_ =
+        { bop_op_name = slet.pbop_op;
+          bop_op_path = op_path;
+          bop_op_val = op_desc;
+          bop_op_type = op_type;
+          bop_exp = exp;
+          bop_loc = slet.pbop_loc; }
+      in
+      let desc =
+        Texp_letop{let_; ands; param; body; partial}
+      in
+      rue { exp_desc = desc;
+            exp_loc = sexp.pexp_loc;
+            exp_extra = [];
+            exp_type = instance ty_result;
+            exp_env = env;
+            exp_attributes = sexp.pexp_attributes; }
+
+  | Pexp_extension ({ txt = ("ocaml.extension_constructor"
+                             |"extension_constructor"); _ },
+                    payload) ->
+      begin match payload with
+      | PStr [ { pstr_desc =
+                   Pstr_eval ({ pexp_desc = Pexp_construct (lid, None); _ }, _)
+               } ] ->
+          let path =
+            let cd =
+              Env.lookup_constructor Env.Positive ~loc:lid.loc lid.txt env
+            in
+            match cd.cstr_tag with
+            | Cstr_extension (path, _) -> path
+            | _ -> raise (Error (lid.loc, env, Not_an_extension_constructor))
+          in
+          rue {
+            exp_desc = Texp_extension_constructor (lid, path);
+            exp_loc = loc; exp_extra = [];
+            exp_type = instance Predef.type_extension_constructor;
+            exp_attributes = sexp.pexp_attributes;
+            exp_env = env }
+      | _ ->
+          raise (Error (loc, env, Invalid_extension_constructor_payload))
+      end
+  | Pexp_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+  | Pexp_unreachable ->
+      re { exp_desc = Texp_unreachable;
+           exp_loc = loc; exp_extra = [];
+           exp_type = instance ty_expected;
+           exp_attributes = sexp.pexp_attributes;
+           exp_env = env }
+
+and type_ident env ?(recarg=Rejected) lid =
+  let (path, desc) = Env.lookup_value ~loc:lid.loc lid.txt env in
+  let is_recarg =
+    match (repr desc.val_type).desc with
+    | Tconstr(p, _, _) -> Path.is_constructor_typath p
+    | _ -> false
+  in
+  begin match is_recarg, recarg, (repr desc.val_type).desc with
+  | _, Allowed, _
+  | true, Required, _
+  | false, Rejected, _ -> ()
+  | true, Rejected, _
+  | false, Required, (Tvar _ | Tconstr _) ->
+      raise (Error (lid.loc, env, Inlined_record_escape))
+  | false, Required, _  -> () (* will fail later *)
+  end;
+  path, desc
+
+and type_binding_op_ident env s =
+  let loc = s.loc in
+  let lid = Location.mkloc (Longident.Lident s.txt) loc in
+  let path, desc = type_ident env lid in
+  let path =
+    match desc.val_kind with
+    | Val_ivar _ ->
+        fatal_error "Illegal name for instance variable"
+    | Val_self (_, _, cl_num, _) ->
+        let path, _ =
+          Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env
+        in
+        path
+    | _ -> path
+  in
+  path, desc
+
+and type_function ?in_function loc attrs env ty_expected_explained l caselist =
+  let { ty = ty_expected; explanation } = ty_expected_explained in
+  let (loc_fun, ty_fun) =
+    match in_function with Some p -> p
+    | None -> (loc, instance ty_expected)
+  in
+  let separate = !Clflags.principal || Env.has_local_constraints env in
+  if separate then begin_def ();
+  let (ty_arg, ty_res) =
+    try filter_arrow env (instance ty_expected) l
+    with Unify _ ->
+      match expand_head env ty_expected with
+        {desc = Tarrow _} as ty ->
+          raise(Error(loc, env, Abstract_wrong_label(l, ty, explanation)))
+      | _ ->
+          raise(Error(loc_fun, env,
+                      Too_many_arguments (in_function <> None,
+                                          ty_fun,
+                                          explanation)))
+  in
+  let ty_arg =
+    if is_optional l then
+      let tv = newvar() in
+      begin
+        try unify env ty_arg (type_option tv)
+        with Unify _ -> assert false
+      end;
+      type_option tv
+    else ty_arg
+  in
+  if separate then begin
+    end_def ();
+    generalize_structure ty_arg;
+    generalize_structure ty_res
+  end;
+  let cases, partial =
+    type_cases Value ~in_function:(loc_fun,ty_fun) env ty_arg ty_res
+      true loc caselist in
+  let not_function ty =
+    let ls, tvar = list_labels env ty in
+    ls = [] && not tvar
+  in
+  if is_optional l && not_function ty_res then
+    Location.prerr_warning (List.hd cases).c_lhs.pat_loc
+      Warnings.Unerasable_optional_argument;
+  let param = name_cases "param" cases in
+  re {
+    exp_desc = Texp_function { arg_label = l; param; cases; partial; };
+    exp_loc = loc; exp_extra = [];
+    exp_type = instance (newgenty (Tarrow(l, ty_arg, ty_res, Cok)));
+    exp_attributes = attrs;
+    exp_env = env }
+
+
+and type_label_access env srecord lid =
+  if !Clflags.principal then begin_def ();
+  let record = type_exp ~recarg:Allowed env srecord in
+  if !Clflags.principal then begin
+    end_def ();
+    generalize_structure record.exp_type
+  end;
+  let ty_exp = record.exp_type in
+  let expected_type =
+    try
+      let (p0, p,_) = extract_concrete_record env ty_exp in
+      Some(p0, p, (repr ty_exp).level = generic_level || not !Clflags.principal)
+    with Not_found -> None
+  in
+  let labels = Env.lookup_all_labels ~loc:lid.loc lid.txt env in
+  let label =
+    wrap_disambiguate "This expression has" (mk_expected ty_exp)
+      (Label.disambiguate () lid env expected_type) labels in
+  (record, label, expected_type)
+
+(* Typing format strings for printing or reading.
+   These formats are used by functions in modules Printf, Format, and Scanf.
+   (Handling of * modifiers contributed by Thorsten Ohl.) *)
+
+and type_format loc str env =
+  let loc = {loc with Location.loc_ghost = true} in
+  try
+    CamlinternalFormatBasics.(CamlinternalFormat.(
+      let mk_exp_loc pexp_desc = {
+        pexp_desc = pexp_desc;
+        pexp_loc = loc;
+        pexp_loc_stack = [];
+        pexp_attributes = [];
+      } and mk_lid_loc lid = {
+        txt = lid;
+        loc = loc;
+      } in
+      let mk_constr name args =
+        let lid = Longident.(Ldot(Lident "CamlinternalFormatBasics", name)) in
+        let arg = match args with
+          | []          -> None
+          | [ e ]       -> Some e
+          | _ :: _ :: _ -> Some (mk_exp_loc (Pexp_tuple args)) in
+        mk_exp_loc (Pexp_construct (mk_lid_loc lid, arg)) in
+      let mk_cst cst = mk_exp_loc (Pexp_constant cst) in
+      let mk_int n = mk_cst (Pconst_integer (Int.to_string n, None))
+      and mk_string str = mk_cst (Pconst_string (str, loc, None))
+      and mk_char chr = mk_cst (Pconst_char chr) in
+      let rec mk_formatting_lit fmting = match fmting with
+        | Close_box ->
+          mk_constr "Close_box" []
+        | Close_tag ->
+          mk_constr "Close_tag" []
+        | Break (org, ns, ni) ->
+          mk_constr "Break" [ mk_string org; mk_int ns; mk_int ni ]
+        | FFlush ->
+          mk_constr "FFlush" []
+        | Force_newline ->
+          mk_constr "Force_newline" []
+        | Flush_newline ->
+          mk_constr "Flush_newline" []
+        | Magic_size (org, sz) ->
+          mk_constr "Magic_size" [ mk_string org; mk_int sz ]
+        | Escaped_at ->
+          mk_constr "Escaped_at" []
+        | Escaped_percent ->
+          mk_constr "Escaped_percent" []
+        | Scan_indic c ->
+          mk_constr "Scan_indic" [ mk_char c ]
+      and mk_formatting_gen : type a b c d e f .
+          (a, b, c, d, e, f) formatting_gen -> Parsetree.expression =
+        fun fmting -> match fmting with
+        | Open_tag (Format (fmt', str')) ->
+          mk_constr "Open_tag" [ mk_format fmt' str' ]
+        | Open_box (Format (fmt', str')) ->
+          mk_constr "Open_box" [ mk_format fmt' str' ]
+      and mk_format : type a b c d e f .
+          (a, b, c, d, e, f) CamlinternalFormatBasics.fmt -> string ->
+          Parsetree.expression = fun fmt str ->
+        mk_constr "Format" [ mk_fmt fmt; mk_string str ]
+      and mk_side side = match side with
+        | Left  -> mk_constr "Left"  []
+        | Right -> mk_constr "Right" []
+        | Zeros -> mk_constr "Zeros" []
+      and mk_iconv iconv = match iconv with
+        | Int_d  -> mk_constr "Int_d"  [] | Int_pd -> mk_constr "Int_pd" []
+        | Int_sd -> mk_constr "Int_sd" [] | Int_i  -> mk_constr "Int_i"  []
+        | Int_pi -> mk_constr "Int_pi" [] | Int_si -> mk_constr "Int_si" []
+        | Int_x  -> mk_constr "Int_x"  [] | Int_Cx -> mk_constr "Int_Cx" []
+        | Int_X  -> mk_constr "Int_X"  [] | Int_CX -> mk_constr "Int_CX" []
+        | Int_o  -> mk_constr "Int_o"  [] | Int_Co -> mk_constr "Int_Co" []
+        | Int_u  -> mk_constr "Int_u"  [] | Int_Cd -> mk_constr "Int_Cd" []
+        | Int_Ci -> mk_constr "Int_Ci" [] | Int_Cu -> mk_constr "Int_Cu" []
+      and mk_fconv fconv =
+        let flag = match fst fconv with
+        | Float_flag_ -> mk_constr "Float_flag_" []
+        | Float_flag_p -> mk_constr "Float_flag_p" []
+        | Float_flag_s -> mk_constr "Float_flag_s" [] in
+        let kind = match snd fconv with
+        | Float_f  -> mk_constr "Float_f"  []
+        | Float_e  -> mk_constr "Float_e"  []
+        | Float_E  -> mk_constr "Float_E"  []
+        | Float_g  -> mk_constr "Float_g"  []
+        | Float_G  -> mk_constr "Float_G"  []
+        | Float_h  -> mk_constr "Float_h"  []
+        | Float_H  -> mk_constr "Float_H"  []
+        | Float_F  -> mk_constr "Float_F"  []
+        | Float_CF -> mk_constr "Float_CF" [] in
+        mk_exp_loc (Pexp_tuple [flag; kind])
+      and mk_counter cnt = match cnt with
+        | Line_counter  -> mk_constr "Line_counter"  []
+        | Char_counter  -> mk_constr "Char_counter"  []
+        | Token_counter -> mk_constr "Token_counter" []
+      and mk_int_opt n_opt = match n_opt with
+        | None ->
+          let lid_loc = mk_lid_loc (Longident.Lident "None") in
+          mk_exp_loc (Pexp_construct (lid_loc, None))
+        | Some n ->
+          let lid_loc = mk_lid_loc (Longident.Lident "Some") in
+          mk_exp_loc (Pexp_construct (lid_loc, Some (mk_int n)))
+      and mk_fmtty : type a b c d e f g h i j k l .
+          (a, b, c, d, e, f, g, h, i, j, k, l) fmtty_rel -> Parsetree.expression
+          =
+      fun fmtty -> match fmtty with
+        | Char_ty rest      -> mk_constr "Char_ty"      [ mk_fmtty rest ]
+        | String_ty rest    -> mk_constr "String_ty"    [ mk_fmtty rest ]
+        | Int_ty rest       -> mk_constr "Int_ty"       [ mk_fmtty rest ]
+        | Int32_ty rest     -> mk_constr "Int32_ty"     [ mk_fmtty rest ]
+        | Nativeint_ty rest -> mk_constr "Nativeint_ty" [ mk_fmtty rest ]
+        | Int64_ty rest     -> mk_constr "Int64_ty"     [ mk_fmtty rest ]
+        | Float_ty rest     -> mk_constr "Float_ty"     [ mk_fmtty rest ]
+        | Bool_ty rest      -> mk_constr "Bool_ty"      [ mk_fmtty rest ]
+        | Alpha_ty rest     -> mk_constr "Alpha_ty"     [ mk_fmtty rest ]
+        | Theta_ty rest     -> mk_constr "Theta_ty"     [ mk_fmtty rest ]
+        | Any_ty rest       -> mk_constr "Any_ty"       [ mk_fmtty rest ]
+        | Reader_ty rest    -> mk_constr "Reader_ty"    [ mk_fmtty rest ]
+        | Ignored_reader_ty rest ->
+          mk_constr "Ignored_reader_ty" [ mk_fmtty rest ]
+        | Format_arg_ty (sub_fmtty, rest) ->
+          mk_constr "Format_arg_ty" [ mk_fmtty sub_fmtty; mk_fmtty rest ]
+        | Format_subst_ty (sub_fmtty1, sub_fmtty2, rest) ->
+          mk_constr "Format_subst_ty"
+            [ mk_fmtty sub_fmtty1; mk_fmtty sub_fmtty2; mk_fmtty rest ]
+        | End_of_fmtty -> mk_constr "End_of_fmtty" []
+      and mk_ignored : type a b c d e f .
+          (a, b, c, d, e, f) ignored -> Parsetree.expression =
+      fun ign -> match ign with
+        | Ignored_char ->
+          mk_constr "Ignored_char" []
+        | Ignored_caml_char ->
+          mk_constr "Ignored_caml_char" []
+        | Ignored_string pad_opt ->
+          mk_constr "Ignored_string" [ mk_int_opt pad_opt ]
+        | Ignored_caml_string pad_opt ->
+          mk_constr "Ignored_caml_string" [ mk_int_opt pad_opt ]
+        | Ignored_int (iconv, pad_opt) ->
+          mk_constr "Ignored_int" [ mk_iconv iconv; mk_int_opt pad_opt ]
+        | Ignored_int32 (iconv, pad_opt) ->
+          mk_constr "Ignored_int32" [ mk_iconv iconv; mk_int_opt pad_opt ]
+        | Ignored_nativeint (iconv, pad_opt) ->
+          mk_constr "Ignored_nativeint" [ mk_iconv iconv; mk_int_opt pad_opt ]
+        | Ignored_int64 (iconv, pad_opt) ->
+          mk_constr "Ignored_int64" [ mk_iconv iconv; mk_int_opt pad_opt ]
+        | Ignored_float (pad_opt, prec_opt) ->
+          mk_constr "Ignored_float" [ mk_int_opt pad_opt; mk_int_opt prec_opt ]
+        | Ignored_bool pad_opt ->
+          mk_constr "Ignored_bool" [ mk_int_opt pad_opt ]
+        | Ignored_format_arg (pad_opt, fmtty) ->
+          mk_constr "Ignored_format_arg" [ mk_int_opt pad_opt; mk_fmtty fmtty ]
+        | Ignored_format_subst (pad_opt, fmtty) ->
+          mk_constr "Ignored_format_subst" [
+            mk_int_opt pad_opt; mk_fmtty fmtty ]
+        | Ignored_reader ->
+          mk_constr "Ignored_reader" []
+        | Ignored_scan_char_set (width_opt, char_set) ->
+          mk_constr "Ignored_scan_char_set" [
+            mk_int_opt width_opt; mk_string char_set ]
+        | Ignored_scan_get_counter counter ->
+          mk_constr "Ignored_scan_get_counter" [
+            mk_counter counter
+          ]
+        | Ignored_scan_next_char ->
+          mk_constr "Ignored_scan_next_char" []
+      and mk_padding : type x y . (x, y) padding -> Parsetree.expression =
+      fun pad -> match pad with
+        | No_padding         -> mk_constr "No_padding" []
+        | Lit_padding (s, w) -> mk_constr "Lit_padding" [ mk_side s; mk_int w ]
+        | Arg_padding s      -> mk_constr "Arg_padding" [ mk_side s ]
+      and mk_precision : type x y . (x, y) precision -> Parsetree.expression =
+      fun prec -> match prec with
+        | No_precision    -> mk_constr "No_precision" []
+        | Lit_precision w -> mk_constr "Lit_precision" [ mk_int w ]
+        | Arg_precision   -> mk_constr "Arg_precision" []
+      and mk_fmt : type a b c d e f .
+          (a, b, c, d, e, f) fmt -> Parsetree.expression =
+      fun fmt -> match fmt with
+        | Char rest ->
+          mk_constr "Char" [ mk_fmt rest ]
+        | Caml_char rest ->
+          mk_constr "Caml_char" [ mk_fmt rest ]
+        | String (pad, rest) ->
+          mk_constr "String" [ mk_padding pad; mk_fmt rest ]
+        | Caml_string (pad, rest) ->
+          mk_constr "Caml_string" [ mk_padding pad; mk_fmt rest ]
+        | Int (iconv, pad, prec, rest) ->
+          mk_constr "Int" [
+            mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
+        | Int32 (iconv, pad, prec, rest) ->
+          mk_constr "Int32" [
+            mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
+        | Nativeint (iconv, pad, prec, rest) ->
+          mk_constr "Nativeint" [
+            mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
+        | Int64 (iconv, pad, prec, rest) ->
+          mk_constr "Int64" [
+            mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
+        | Float (fconv, pad, prec, rest) ->
+          mk_constr "Float" [
+            mk_fconv fconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
+        | Bool (pad, rest) ->
+          mk_constr "Bool" [ mk_padding pad; mk_fmt rest ]
+        | Flush rest ->
+          mk_constr "Flush" [ mk_fmt rest ]
+        | String_literal (s, rest) ->
+          mk_constr "String_literal" [ mk_string s; mk_fmt rest ]
+        | Char_literal (c, rest) ->
+          mk_constr "Char_literal" [ mk_char c; mk_fmt rest ]
+        | Format_arg (pad_opt, fmtty, rest) ->
+          mk_constr "Format_arg" [
+            mk_int_opt pad_opt; mk_fmtty fmtty; mk_fmt rest ]
+        | Format_subst (pad_opt, fmtty, rest) ->
+          mk_constr "Format_subst" [
+            mk_int_opt pad_opt; mk_fmtty fmtty; mk_fmt rest ]
+        | Alpha rest ->
+          mk_constr "Alpha" [ mk_fmt rest ]
+        | Theta rest ->
+          mk_constr "Theta" [ mk_fmt rest ]
+        | Formatting_lit (fmting, rest) ->
+          mk_constr "Formatting_lit" [ mk_formatting_lit fmting; mk_fmt rest ]
+        | Formatting_gen (fmting, rest) ->
+          mk_constr "Formatting_gen" [ mk_formatting_gen fmting; mk_fmt rest ]
+        | Reader rest ->
+          mk_constr "Reader" [ mk_fmt rest ]
+        | Scan_char_set (width_opt, char_set, rest) ->
+          mk_constr "Scan_char_set" [
+            mk_int_opt width_opt; mk_string char_set; mk_fmt rest ]
+        | Scan_get_counter (cnt, rest) ->
+          mk_constr "Scan_get_counter" [ mk_counter cnt; mk_fmt rest ]
+        | Scan_next_char rest ->
+          mk_constr "Scan_next_char" [ mk_fmt rest ]
+        | Ignored_param (ign, rest) ->
+          mk_constr "Ignored_param" [ mk_ignored ign; mk_fmt rest ]
+        | End_of_format ->
+          mk_constr "End_of_format" []
+        | Custom _ ->
+          (* Custom formatters have no syntax so they will never appear
+             in formats parsed from strings. *)
+          assert false
+      in
+      let legacy_behavior = not !Clflags.strict_formats in
+      let Fmt_EBB fmt = fmt_ebb_of_string ~legacy_behavior str in
+      mk_constr "Format" [ mk_fmt fmt; mk_string str ]
+    ))
+  with Failure msg ->
+    raise (Error (loc, env, Invalid_format msg))
+
+and type_label_exp create env loc ty_expected
+          (lid, label, sarg) =
+  (* Here also ty_expected may be at generic_level *)
+  begin_def ();
+  let separate = !Clflags.principal || Env.has_local_constraints env in
+  if separate then (begin_def (); begin_def ());
+  let (vars, ty_arg, ty_res) = instance_label true label in
+  if separate then begin
+    end_def ();
+    (* Generalize label information *)
+    generalize_structure ty_arg;
+    generalize_structure ty_res
+  end;
+  begin try
+    unify env (instance ty_res) (instance ty_expected)
+  with Unify trace ->
+    raise (Error(lid.loc, env, Label_mismatch(lid.txt, trace)))
+  end;
+  (* Instantiate so that we can generalize internal nodes *)
+  let ty_arg = instance ty_arg in
+  if separate then begin
+    end_def ();
+    (* Generalize information merged from ty_expected *)
+    generalize_structure ty_arg
+  end;
+  if label.lbl_private = Private then
+    if create then
+      raise (Error(loc, env, Private_type ty_expected))
+    else
+      raise (Error(lid.loc, env, Private_label(lid.txt, ty_expected)));
+  let arg =
+    let snap = if vars = [] then None else Some (Btype.snapshot ()) in
+    let arg = type_argument env sarg ty_arg (instance ty_arg) in
+    end_def ();
+    try
+      if (vars = []) then arg
+      else begin
+        if maybe_expansive arg then
+          lower_contravariant env arg.exp_type;
+        generalize_and_check_univars env "field value" arg label.lbl_arg vars;
+        {arg with exp_type = instance arg.exp_type}
+      end
+    with exn when maybe_expansive arg -> try
+      (* Try to retype without propagating ty_arg, cf PR#4862 *)
+      Option.iter Btype.backtrack snap;
+      begin_def ();
+      let arg = type_exp env sarg in
+      end_def ();
+      lower_contravariant env arg.exp_type;
+      begin_def ();
+      let arg = {arg with exp_type = instance arg.exp_type} in
+      unify_exp env arg (instance ty_arg);
+      end_def ();
+      generalize_and_check_univars env "field value" arg label.lbl_arg vars;
+      {arg with exp_type = instance arg.exp_type}
+    with Error (_, _, Less_general _) as e -> raise e
+    | _ -> raise exn    (* In case of failure return the first error *)
+  in
+  (lid, label, arg)
+
+and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected =
+  (* ty_expected' may be generic *)
+  let no_labels ty =
+    let ls, tvar = list_labels env ty in
+    not tvar && List.for_all ((=) Nolabel) ls
+  in
+  let rec is_inferred sexp =
+    match sexp.pexp_desc with
+      Pexp_ident _ | Pexp_apply _ | Pexp_field _ | Pexp_constraint _
+    | Pexp_coerce _ | Pexp_send _ | Pexp_new _ -> true
+    | Pexp_sequence (_, e) | Pexp_open (_, e) -> is_inferred e
+    | Pexp_ifthenelse (_, e1, Some e2) -> is_inferred e1 && is_inferred e2
+    | _ -> false
+  in
+  match expand_head env ty_expected' with
+    {desc = Tarrow(Nolabel,ty_arg,ty_res,_); level = lv}
+    when is_inferred sarg ->
+      (* apply optional arguments when expected type is "" *)
+      (* we must be very careful about not breaking the semantics *)
+      if !Clflags.principal then begin_def ();
+      let texp = type_exp env sarg in
+      if !Clflags.principal then begin
+        end_def ();
+        generalize_structure texp.exp_type
+      end;
+      let rec make_args args ty_fun =
+        match (expand_head env ty_fun).desc with
+        | Tarrow (l,ty_arg,ty_fun,_) when is_optional l ->
+            let ty = option_none env (instance ty_arg) sarg.pexp_loc in
+            make_args ((l, Some ty) :: args) ty_fun
+        | Tarrow (l,_,ty_res',_) when l = Nolabel || !Clflags.classic ->
+            List.rev args, ty_fun, no_labels ty_res'
+        | Tvar _ ->  List.rev args, ty_fun, false
+        |  _ -> [], texp.exp_type, false
+      in
+      let args, ty_fun', simple_res = make_args [] texp.exp_type in
+      let warn = !Clflags.principal &&
+        (lv <> generic_level || (repr ty_fun').level <> generic_level)
+      and texp = {texp with exp_type = instance texp.exp_type}
+      and ty_fun = instance ty_fun' in
+      if not (simple_res || no_labels ty_res) then begin
+        unify_exp env texp ty_expected;
+        texp
+      end else begin
+      unify_exp env {texp with exp_type = ty_fun} ty_expected;
+      if args = [] then texp else
+      (* eta-expand to avoid side effects *)
+      let var_pair name ty =
+        let id = Ident.create_local name in
+        let desc =
+          { val_type = ty; val_kind = Val_reg;
+            val_attributes = [];
+            val_loc = Location.none;
+            val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+          }
+        in
+        let exp_env = Env.add_value id desc env in
+        {pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[];
+         pat_attributes = [];
+         pat_loc = Location.none; pat_env = env},
+        {exp_type = ty; exp_loc = Location.none; exp_env = exp_env;
+         exp_extra = []; exp_attributes = [];
+         exp_desc =
+         Texp_ident(Path.Pident id, mknoloc (Longident.Lident name), desc)}
+      in
+      let eta_pat, eta_var = var_pair "eta" ty_arg in
+      let func texp =
+        let e =
+          {texp with exp_type = ty_res; exp_desc =
+           Texp_apply
+             (texp,
+              args @ [Nolabel, Some eta_var])}
+        in
+        let cases = [case eta_pat e] in
+        let param = name_cases "param" cases in
+        { texp with exp_type = ty_fun; exp_desc =
+          Texp_function { arg_label = Nolabel; param; cases;
+            partial = Total; } }
+      in
+      Location.prerr_warning texp.exp_loc
+        (Warnings.Eliminated_optional_arguments
+           (List.map (fun (l, _) -> Printtyp.string_of_label l) args));
+      if warn then Location.prerr_warning texp.exp_loc
+          (Warnings.Without_principality "eliminated optional argument");
+      (* let-expand to have side effects *)
+      let let_pat, let_var = var_pair "arg" texp.exp_type in
+      re { texp with exp_type = ty_fun; exp_desc =
+           Texp_let (Nonrecursive,
+                     [{vb_pat=let_pat; vb_expr=texp; vb_attributes=[];
+                       vb_loc=Location.none;
+                      }],
+                     func let_var) }
+      end
+  | _ ->
+      let texp = type_expect ?recarg env sarg
+        (mk_expected ?explanation ty_expected') in
+      unify_exp env texp ty_expected;
+      texp
+
+and type_application env funct sargs =
+  (* funct.exp_type may be generic *)
+  let result_type omitted ty_fun =
+    List.fold_left
+      (fun ty_fun (l,ty,lv) -> newty2 lv (Tarrow(l,ty,ty_fun,Cok)))
+      ty_fun omitted
+  in
+  let has_label l ty_fun =
+    let ls, tvar = list_labels env ty_fun in
+    tvar || List.mem l ls
+  in
+  let eliminated_optional_arguments = ref [] in
+  let omitted_parameters = ref [] in
+  let type_unknown_arg (ty_fun, typed_args) (lbl, sarg) =
+    let (ty_arg, ty_res) =
+      let ty_fun = expand_head env ty_fun in
+      match ty_fun.desc with
+      | Tvar _ ->
+          let t1 = newvar () and t2 = newvar () in
+          if ty_fun.level >= t1.level &&
+             not (is_prim ~name:"%identity" funct)
+          then
+            Location.prerr_warning sarg.pexp_loc Warnings.Unused_argument;
+          unify env ty_fun (newty (Tarrow(lbl,t1,t2,Clink(ref Cunknown))));
+          (t1, t2)
+      | Tarrow (l,t1,t2,_) when l = lbl
+        || !Clflags.classic && lbl = Nolabel && not (is_optional l) ->
+          (t1, t2)
+      | td ->
+          let ty_fun = match td with Tarrow _ -> newty td | _ -> ty_fun in
+          let ty_res =
+            result_type (!omitted_parameters @ !eliminated_optional_arguments)
+              ty_fun
+          in
+          match ty_res.desc with
+          | Tarrow _ ->
+              if !Clflags.classic || not (has_label lbl ty_fun) then
+                raise (Error(sarg.pexp_loc, env,
+                             Apply_wrong_label(lbl, ty_res, false)))
+              else
+                raise (Error(funct.exp_loc, env, Incoherent_label_order))
+          | _ ->
+              raise(Error(funct.exp_loc, env, Apply_non_function
+                            (expand_head env funct.exp_type)))
+    in
+    let arg () =
+      let arg = type_expect env sarg (mk_expected ty_arg) in
+      if is_optional lbl then
+        unify_exp env arg (type_option(newvar()));
+      arg
+    in
+    (ty_res, (lbl, Some arg) :: typed_args)
+  in
+  let ignore_labels =
+    !Clflags.classic ||
+    begin
+      let ls, tvar = list_labels env funct.exp_type in
+      not tvar &&
+      let labels = List.filter (fun l -> not (is_optional l)) ls in
+      List.length labels = List.length sargs &&
+      List.for_all (fun (l,_) -> l = Nolabel) sargs &&
+      List.exists (fun l -> l <> Nolabel) labels &&
+      (Location.prerr_warning
+         funct.exp_loc
+         (Warnings.Labels_omitted
+            (List.map Printtyp.string_of_label
+                      (List.filter ((<>) Nolabel) labels)));
+       true)
+    end
+  in
+  let warned = ref false in
+  let rec type_args args ty_fun ty_fun0 sargs =
+    match expand_head env ty_fun, expand_head env ty_fun0 with
+    | {desc=Tarrow (l, ty, ty_fun, com); level=lv} as ty_fun',
+      {desc=Tarrow (_, ty0, ty_fun0, _)}
+      when sargs <> [] && commu_repr com = Cok ->
+        let may_warn loc w =
+          if not !warned && !Clflags.principal && lv <> generic_level
+          then begin
+            warned := true;
+            Location.prerr_warning loc w
+          end
+        in
+        let name = label_name l
+        and optional = is_optional l in
+        let use_arg sarg l' =
+          Some (
+            if not optional || is_optional l' then
+              (fun () -> type_argument env sarg ty ty0)
+            else begin
+              may_warn sarg.pexp_loc
+                (Warnings.Not_principal "using an optional argument here");
+              (fun () -> option_some env (type_argument env sarg
+                                            (extract_option_type env ty)
+                                            (extract_option_type env ty0)))
+            end
+          )
+        in
+        let eliminate_optional_arg () =
+          may_warn funct.exp_loc
+            (Warnings.Without_principality "eliminated optional argument");
+          eliminated_optional_arguments :=
+            (l,ty,lv) :: !eliminated_optional_arguments;
+          Some (fun () -> option_none env (instance ty) Location.none)
+        in
+        let remaining_sargs, arg =
+          if ignore_labels then begin
+            (* No reordering is allowed, process arguments in order *)
+            match sargs with
+            | [] -> assert false
+            | (l', sarg) :: remaining_sargs ->
+                if name = label_name l' || (not optional && l' = Nolabel) then
+                  (remaining_sargs, use_arg sarg l')
+                else if
+                  optional &&
+                  not (List.exists (fun (l, _) -> name = label_name l)
+                         remaining_sargs) &&
+                  List.exists (function (Nolabel, _) -> true | _ -> false)
+                    sargs
+                then
+                  (sargs, eliminate_optional_arg ())
+                else
+                  raise(Error(sarg.pexp_loc, env,
+                              Apply_wrong_label(l', ty_fun', optional)))
+          end else
+            (* Arguments can be commuted, try to fetch the argument
+               corresponding to the first parameter. *)
+            match extract_label name sargs with
+            | Some (l', sarg, commuted, remaining_sargs) ->
+                if commuted then begin
+                  may_warn sarg.pexp_loc
+                    (Warnings.Not_principal "commuting this argument")
+                end;
+                if not optional && is_optional l' then
+                  Location.prerr_warning sarg.pexp_loc
+                    (Warnings.Nonoptional_label (Printtyp.string_of_label l));
+                remaining_sargs, use_arg sarg l'
+            | None ->
+                sargs,
+                if optional && List.mem_assoc Nolabel sargs then
+                  eliminate_optional_arg ()
+                else begin
+                  (* No argument was given for this parameter, we abstract over
+                     it. *)
+                  may_warn funct.exp_loc
+                    (Warnings.Without_principality "commuted an argument");
+                  omitted_parameters := (l,ty,lv) :: !omitted_parameters;
+                  None
+                end
+        in
+        type_args ((l,arg)::args) ty_fun ty_fun0 remaining_sargs
+    | _ ->
+        (* We're not looking at a *known* function type anymore, or there are no
+           arguments left. *)
+        let ty_fun, typed_args =
+          List.fold_left type_unknown_arg (ty_fun0, args) sargs
+        in
+        let args =
+          (* Force typing of arguments.
+             Careful: the order matters here. Using [List.rev_map] would be
+             incorrect. *)
+          List.map
+            (function
+              | l, None -> l, None
+              | l, Some f -> l, Some (f ()))
+            (List.rev typed_args)
+        in
+        let result_ty = instance (result_type !omitted_parameters ty_fun) in
+        args, result_ty
+  in
+  let is_ignore funct =
+    is_prim ~name:"%ignore" funct &&
+    (try ignore (filter_arrow env (instance funct.exp_type) Nolabel); true
+     with Unify _ -> false)
+  in
+  match sargs with
+  | (* Special case for ignore: avoid discarding warning *)
+    [Nolabel, sarg] when is_ignore funct ->
+      let ty_arg, ty_res = filter_arrow env (instance funct.exp_type) Nolabel in
+      let exp = type_expect env sarg (mk_expected ty_arg) in
+      check_partial_application false exp;
+      ([Nolabel, Some exp], ty_res)
+  | _ ->
+    let ty = funct.exp_type in
+    type_args [] ty (instance ty) sargs
+
+and type_construct env loc lid sarg ty_expected_explained attrs =
+  let { ty = ty_expected; explanation } = ty_expected_explained in
+  let expected_type =
+    try
+      let (p0, p,_) = extract_concrete_variant env ty_expected in
+      let principal =
+        (repr ty_expected).level = generic_level || not !Clflags.principal
+      in
+      Some(p0, p, principal)
+    with Not_found -> None
+  in
+  let constrs =
+    Env.lookup_all_constructors ~loc:lid.loc Env.Positive lid.txt env
+  in
+  let constr =
+    wrap_disambiguate "This variant expression is expected to have"
+      ty_expected_explained
+      (Constructor.disambiguate Env.Positive lid env expected_type) constrs
+  in
+  let sargs =
+    match sarg with
+      None -> []
+    | Some {pexp_desc = Pexp_tuple sel} when
+        constr.cstr_arity > 1 || Builtin_attributes.explicit_arity attrs
+      -> sel
+    | Some se -> [se] in
+  if List.length sargs <> constr.cstr_arity then
+    raise(Error(loc, env, Constructor_arity_mismatch
+                            (lid.txt, constr.cstr_arity, List.length sargs)));
+  let separate = !Clflags.principal || Env.has_local_constraints env in
+  if separate then (begin_def (); begin_def ());
+  let (ty_args, ty_res) = instance_constructor constr in
+  let texp =
+    re {
+      exp_desc = Texp_construct(lid, constr, []);
+      exp_loc = loc; exp_extra = [];
+      exp_type = ty_res;
+      exp_attributes = attrs;
+      exp_env = env } in
+  if separate then begin
+    end_def ();
+    generalize_structure ty_res;
+    with_explanation explanation (fun () ->
+      unify_exp env {texp with exp_type = instance ty_res}
+        (instance ty_expected));
+    end_def ();
+    List.iter generalize_structure ty_args;
+    generalize_structure ty_res;
+  end;
+  let ty_args0, ty_res =
+    match instance_list (ty_res :: ty_args) with
+      t :: tl -> tl, t
+    | _ -> assert false
+  in
+  let texp = {texp with exp_type = ty_res} in
+  if not separate then unify_exp env texp (instance ty_expected);
+  let recarg =
+    match constr.cstr_inlined with
+    | None -> Rejected
+    | Some _ ->
+      begin match sargs with
+      | [{pexp_desc =
+            Pexp_ident _ |
+            Pexp_record (_, (Some {pexp_desc = Pexp_ident _}| None))}] ->
+        Required
+      | _ ->
+        raise (Error(loc, env, Inlined_record_expected))
+      end
+  in
+  let args =
+    List.map2 (fun e (t,t0) -> type_argument ~recarg env e t t0) sargs
+      (List.combine ty_args ty_args0) in
+  if constr.cstr_private = Private then
+    begin match constr.cstr_tag with
+    | Cstr_extension _ ->
+        raise(Error(loc, env, Private_constructor (constr, ty_res)))
+    | Cstr_constant _ | Cstr_block _ | Cstr_unboxed ->
+        raise (Error(loc, env, Private_type ty_res));
+    end;
+  (* NOTE: shouldn't we call "re" on this final expression? -- AF *)
+  { texp with
+    exp_desc = Texp_construct(lid, constr, args) }
+
+(* Typing of statements (expressions whose values are discarded) *)
+
+and type_statement ?explanation env sexp =
+  begin_def();
+  let exp = type_exp env sexp in
+  end_def();
+  let ty = expand_head env exp.exp_type and tv = newvar() in
+  if is_Tvar ty && ty.level > tv.level then
+    Location.prerr_warning
+      (final_subexpression exp).exp_loc
+      Warnings.Nonreturning_statement;
+  if !Clflags.strict_sequence then
+    let expected_ty = instance Predef.type_unit in
+    with_explanation explanation (fun () ->
+      unify_exp env exp expected_ty);
+    exp
+  else begin
+    check_partial_application true exp;
+    unify_var env tv ty;
+    exp
+  end
+
+and type_unpacks ?in_function env unpacks sbody expected_ty =
+  let ty = newvar() in
+  (* remember original level *)
+  let extended_env, tunpacks =
+    List.fold_left (fun (env, unpacks) (name, loc, uid) ->
+      begin_def ();
+      let context = Typetexp.narrow () in
+      let modl =
+        !type_module env
+          Ast_helper.(
+            Mod.unpack ~loc
+              (Exp.ident ~loc:name.loc (mkloc (Longident.Lident name.txt)
+                                          name.loc)))
+      in
+      Mtype.lower_nongen ty.level modl.mod_type;
+      let pres =
+        match modl.mod_type with
+        | Mty_alias _ -> Mp_absent
+        | _ -> Mp_present
+      in
+      let scope = create_scope () in
+      let md =
+        { md_type = modl.mod_type; md_attributes = []; md_loc = name.loc;
+          md_uid = uid; }
+      in
+      let (id, env) =
+        Env.enter_module_declaration ~scope name.txt pres md env
+      in
+      Typetexp.widen context;
+      env, (id, name, pres, modl) :: unpacks
+    ) (env, []) unpacks
+  in
+  (* ideally, we should catch Expr_type_clash errors
+     in type_expect triggered by escaping identifiers from the local module
+     and refine them into Scoping_let_module errors
+  *)
+  let body = type_expect ?in_function extended_env sbody expected_ty in
+  let exp_loc = { body.exp_loc with loc_ghost = true } in
+  let exp_attributes = [Ast_helper.Attr.mk (mknoloc "#modulepat") (PStr [])] in
+  List.fold_left (fun body (id, name, pres, modl) ->
+    (* go back to parent level *)
+    end_def ();
+    Ctype.unify_var extended_env ty body.exp_type;
+    re {
+      exp_desc = Texp_letmodule(Some id, { name with txt = Some name.txt },
+                                pres, modl, body);
+      exp_loc;
+      exp_attributes;
+      exp_extra = [];
+      exp_type = ty;
+      exp_env = env }
+  ) body tunpacks
+
+(* Typing of match cases *)
+and type_cases
+    : type k . k pattern_category ->
+           ?in_function:_ -> _ -> _ -> _ -> _ -> _ -> Parsetree.case list ->
+           k case list * partial
+  = fun category ?in_function env ty_arg ty_res partial_flag loc caselist ->
+  (* ty_arg is _fully_ generalized *)
+  let patterns = List.map (fun {pc_lhs=p} -> p) caselist in
+  let contains_polyvars = List.exists contains_polymorphic_variant patterns in
+  let erase_either = contains_polyvars && contains_variant_either ty_arg in
+  let may_contain_gadts = List.exists may_contain_gadts patterns in
+  let ty_arg =
+    if (may_contain_gadts || erase_either) && not !Clflags.principal
+    then correct_levels ty_arg else ty_arg
+  in
+  let rec is_var spat =
+    match spat.ppat_desc with
+      Ppat_any | Ppat_var _ -> true
+    | Ppat_alias (spat, _) -> is_var spat
+    | _ -> false in
+  let needs_exhaust_check =
+    match caselist with
+      [{pc_rhs = {pexp_desc = Pexp_unreachable}}] -> true
+    | [{pc_lhs}] when is_var pc_lhs -> false
+    | _ -> true
+  in
+  let outer_level = get_current_level () in
+  let lev =
+    if may_contain_gadts then begin_def ();
+    get_current_level ()
+  in
+  let take_partial_instance =
+    if !Clflags.principal || erase_either
+    then Some false else None
+  in
+  begin_def (); (* propagation of the argument *)
+  let pattern_force = ref [] in
+(*  Format.printf "@[%i %i@ %a@]@." lev (get_current_level())
+    Printtyp.raw_type_expr ty_arg; *)
+  let half_typed_cases =
+    List.map
+      (fun ({pc_lhs; pc_guard; pc_rhs} as case) ->
+        let loc =
+          let open Location in
+          match pc_guard with
+          | None -> pc_rhs.pexp_loc
+          | Some g -> {pc_rhs.pexp_loc with loc_start=g.pexp_loc.loc_start}
+        in
+        if !Clflags.principal then begin_def (); (* propagation of pattern *)
+        let scope = Some (Annot.Idef loc) in
+        begin_def ();
+        let ty_arg = instance ?partial:take_partial_instance ty_arg in
+        end_def ();
+        generalize_structure ty_arg;
+        let (pat, ext_env, force, pvs, unpacks) =
+          type_pattern category ~lev env pc_lhs scope ty_arg
+        in
+        pattern_force := force @ !pattern_force;
+        let pat =
+          if !Clflags.principal then begin
+            end_def ();
+            iter_pattern_variables_type generalize_structure pvs;
+            { pat with pat_type = instance pat.pat_type }
+          end else pat
+        in
+        (* Ensure that no ambivalent pattern type escapes its branch *)
+        check_scope_escape pat.pat_loc env outer_level ty_arg;
+        { typed_pat = pat;
+          pat_type_for_unif = ty_arg;
+          untyped_case = case;
+          branch_env = ext_env;
+          pat_vars = pvs;
+          unpacks;
+          contains_gadt = contains_gadt (as_comp_pattern category pat); }
+        )
+      caselist in
+  let patl = List.map (fun { typed_pat; _ } -> typed_pat) half_typed_cases in
+  let does_contain_gadt =
+    List.exists (fun { contains_gadt; _ } -> contains_gadt) half_typed_cases
+  in
+  let ty_res, do_copy_types =
+    if does_contain_gadt && not !Clflags.principal then
+      correct_levels ty_res, Env.make_copy_of_types env
+    else ty_res, (fun env -> env)
+  in
+  (* Unify all cases (delayed to keep it order-free) *)
+  let ty_arg' = newvar () in
+  let unify_pats ty =
+    List.iter (fun { typed_pat = pat; pat_type_for_unif = pat_ty; _ } ->
+      unify_pat_types pat.pat_loc (ref env) pat_ty ty
+    ) half_typed_cases
+  in
+  unify_pats ty_arg';
+  (* Check for polymorphic variants to close *)
+  if List.exists has_variants patl then begin
+      Parmatch.pressure_variants_in_computation_pattern env
+        (List.map (as_comp_pattern category) patl);
+      List.iter finalize_variants patl
+  end;
+  (* `Contaminating' unifications start here *)
+  List.iter (fun f -> f()) !pattern_force;
+  (* Post-processing and generalization *)
+  if take_partial_instance <> None then unify_pats (instance ty_arg);
+  List.iter (fun { pat_vars; _ } ->
+    iter_pattern_variables_type (fun t -> unify_var env (newvar()) t) pat_vars
+  ) half_typed_cases;
+  end_def ();
+  generalize ty_arg';
+  List.iter (fun { pat_vars; _ } ->
+    iter_pattern_variables_type generalize pat_vars
+  ) half_typed_cases;
+  (* type bodies *)
+  let in_function = if List.length caselist = 1 then in_function else None in
+  let cases =
+    List.map
+      (fun { typed_pat = pat; branch_env = ext_env; pat_vars = pvs; unpacks;
+             untyped_case = {pc_lhs = _; pc_guard; pc_rhs};
+             contains_gadt; _ }  ->
+        let ext_env =
+          if contains_gadt then
+            do_copy_types ext_env
+          else
+            ext_env
+        in
+        let ext_env =
+          add_pattern_variables ext_env pvs
+            ~check:(fun s -> Warnings.Unused_var_strict s)
+            ~check_as:(fun s -> Warnings.Unused_var s)
+        in
+        let unpacks =
+          List.map (fun (name, loc) ->
+            name, loc, Uid.mk ~current_unit:(Env.get_unit_name ())
+          ) unpacks
+        in
+        let ty_res' =
+          if !Clflags.principal then begin
+            begin_def ();
+            let ty = instance ~partial:true ty_res in
+            end_def ();
+            generalize_structure ty; ty
+          end
+          else if contains_gadt then
+            (* Even though we've already done that, apparently we need to do it
+               again.
+               stdlib/camlinternalFormat.ml:2288 is an example of use of this
+               call to [correct_levels]... *)
+            correct_levels ty_res
+          else ty_res in
+(*        Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level())
+          Printtyp.raw_type_expr ty_res'; *)
+        let guard =
+          match pc_guard with
+          | None -> None
+          | Some scond ->
+              Some
+                (type_unpacks ext_env unpacks scond
+                   (mk_expected ~explanation:When_guard Predef.type_bool))
+        in
+        let exp =
+          type_unpacks ?in_function ext_env unpacks pc_rhs (mk_expected ty_res')
+        in
+        {
+         c_lhs = pat;
+         c_guard = guard;
+         c_rhs = {exp with exp_type = instance ty_res'}
+        }
+      )
+      half_typed_cases
+  in
+  if !Clflags.principal || does_contain_gadt then begin
+    let ty_res' = instance ty_res in
+    List.iter (fun c -> unify_exp env c.c_rhs ty_res') cases
+  end;
+  let do_init = may_contain_gadts || needs_exhaust_check in
+  let ty_arg_check =
+    if do_init then
+      (* Hack: use for_saving to copy variables too *)
+      Subst.type_expr (Subst.for_saving Subst.identity) ty_arg'
+    else ty_arg'
+  in
+  let val_cases, exn_cases =
+    match category with
+      | Value -> (cases : value case list), []
+      | Computation -> split_cases env cases in
+  if val_cases = [] && exn_cases <> [] then
+    raise (Error (loc, env, No_value_clauses));
+  let partial =
+    if partial_flag then
+      check_partial ~lev env ty_arg_check loc val_cases
+    else
+      Partial
+  in
+  let unused_check delayed =
+    List.iter (fun { typed_pat; branch_env; _ } ->
+      check_absent_variant branch_env (as_comp_pattern category typed_pat)
+    ) half_typed_cases;
+    if delayed then (begin_def (); init_def lev);
+    check_unused ~lev env ty_arg_check val_cases ;
+    check_unused ~lev env Predef.type_exn exn_cases ;
+    if delayed then end_def ();
+    Parmatch.check_ambiguous_bindings val_cases ;
+    Parmatch.check_ambiguous_bindings exn_cases
+  in
+  if contains_polyvars then
+    add_delayed_check (fun () -> unused_check true)
+  else
+    (* Check for unused cases, do not delay because of gadts *)
+    unused_check false;
+  if may_contain_gadts then begin
+    end_def ();
+    (* Ensure that existential types do not escape *)
+    unify_exp_types loc env (instance ty_res) (newvar ()) ;
+  end;
+  cases, partial
+
+(* Typing of let bindings *)
+
+and type_let
+    ?(check = fun s -> Warnings.Unused_var s)
+    ?(check_strict = fun s -> Warnings.Unused_var_strict s)
+    existential_context
+    env rec_flag spat_sexp_list scope allow =
+  let open Ast_helper in
+  begin_def();
+  if !Clflags.principal then begin_def ();
+
+  let is_fake_let =
+    match spat_sexp_list with
+    | [{pvb_expr={pexp_desc=Pexp_match(
+           {pexp_desc=Pexp_ident({ txt = Longident.Lident "*opt*"})},_)}}] ->
+        true (* the fake let-declaration introduced by fun ?(x = e) -> ... *)
+    | _ ->
+        false
+  in
+  let check = if is_fake_let then check_strict else check in
+
+  let spatl =
+    List.map
+      (fun {pvb_pat=spat; pvb_expr=sexp; pvb_attributes=attrs} ->
+        attrs,
+        match spat.ppat_desc, sexp.pexp_desc with
+          (Ppat_any | Ppat_constraint _), _ -> spat
+        | _, Pexp_coerce (_, _, sty)
+        | _, Pexp_constraint (_, sty) when !Clflags.principal ->
+            (* propagate type annotation to pattern,
+               to allow it to be generalized in -principal mode *)
+            Pat.constraint_
+              ~loc:{spat.ppat_loc with Location.loc_ghost=true}
+              spat
+              sty
+        | _ -> spat)
+      spat_sexp_list in
+  let nvs = List.map (fun _ -> newvar ()) spatl in
+  let (pat_list, new_env, force, pvs, unpacks) =
+    type_pattern_list Value existential_context env spatl scope nvs allow in
+  let attrs_list = List.map fst spatl in
+  let is_recursive = (rec_flag = Recursive) in
+  (* If recursive, first unify with an approximation of the expression *)
+  if is_recursive then
+    List.iter2
+      (fun pat binding ->
+        let pat =
+          match pat.pat_type.desc with
+          | Tpoly (ty, tl) ->
+              {pat with pat_type =
+               snd (instance_poly ~keep_names:true false tl ty)}
+          | _ -> pat
+        in unify_pat (ref env) pat (type_approx env binding.pvb_expr))
+      pat_list spat_sexp_list;
+  (* Polymorphic variant processing *)
+  List.iter
+    (fun pat ->
+      if has_variants pat then begin
+        Parmatch.pressure_variants env [pat];
+        finalize_variants pat
+      end)
+    pat_list;
+  (* Generalize the structure *)
+  let pat_list =
+    if !Clflags.principal then begin
+      end_def ();
+      iter_pattern_variables_type generalize_structure pvs;
+      List.map (fun pat ->
+        generalize_structure pat.pat_type;
+        {pat with pat_type = instance pat.pat_type}
+      ) pat_list
+    end else
+      pat_list
+  in
+  (* Only bind pattern variables after generalizing *)
+  List.iter (fun f -> f()) force;
+  let sexp_is_fun { pvb_expr = sexp; _ } =
+    match sexp.pexp_desc with
+    | Pexp_fun _ | Pexp_function _ -> true
+    | _ -> false
+  in
+  let exp_env =
+    if is_recursive then new_env
+    else if List.for_all sexp_is_fun spat_sexp_list
+    then begin
+      (* Add ghost bindings to help detecting missing "rec" keywords.
+
+         We only add those if the body of the definition is obviously a
+         function. The rationale is that, in other cases, the hint is probably
+         wrong (and the user is using "advanced features" anyway (lazy,
+         recursive values...)).
+
+         [pvb_loc] (below) is the location of the first let-binding (in case of
+         a let .. and ..), and is where the missing "rec" hint suggests to add a
+         "rec" keyword. *)
+      match spat_sexp_list with
+      | {pvb_loc; _} :: _ -> maybe_add_pattern_variables_ghost pvb_loc env pvs
+      | _ -> assert false
+    end
+    else env in
+
+  let current_slot = ref None in
+  let rec_needed = ref false in
+  let warn_about_unused_bindings =
+    List.exists
+      (fun attrs ->
+         Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () ->
+           Warnings.is_active (check "") || Warnings.is_active (check_strict "")
+           || (is_recursive && (Warnings.is_active Warnings.Unused_rec_flag))))
+      attrs_list
+  in
+  let pat_slot_list =
+    (* Algorithm to detect unused declarations in recursive bindings:
+       - During type checking of the definitions, we capture the 'value_used'
+         events on the bound identifiers and record them in a slot corresponding
+         to the current definition (!current_slot).
+         In effect, this creates a dependency graph between definitions.
+
+       - After type checking the definition (!current_slot = None),
+         when one of the bound identifier is effectively used, we trigger
+         again all the events recorded in the corresponding slot.
+         The effect is to traverse the transitive closure of the graph created
+         in the first step.
+
+       We also keep track of whether *all* variables in a given pattern
+       are unused. If this is the case, for local declarations, the issued
+       warning is 26, not 27.
+     *)
+    List.map2
+      (fun attrs pat ->
+         Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () ->
+           if not warn_about_unused_bindings then pat, None
+           else
+             let some_used = ref false in
+             (* has one of the identifier of this pattern been used? *)
+             let slot = ref [] in
+             List.iter
+               (fun id ->
+                  let vd = Env.find_value (Path.Pident id) new_env in
+                  (* note: Env.find_value does not trigger the value_used
+                           event *)
+                  let name = Ident.name id in
+                  let used = ref false in
+                  if not (name = "" || name.[0] = '_' || name.[0] = '#') then
+                    add_delayed_check
+                      (fun () ->
+                         if not !used then
+                           Location.prerr_warning vd.Types.val_loc
+                             ((if !some_used then check_strict else check) name)
+                      );
+                  Env.set_value_used_callback
+                    vd
+                    (fun () ->
+                       match !current_slot with
+                       | Some slot ->
+                         slot := vd.val_uid :: !slot; rec_needed := true
+                       | None ->
+                         List.iter Env.mark_value_used (get_ref slot);
+                         used := true;
+                         some_used := true
+                    )
+               )
+               (Typedtree.pat_bound_idents pat);
+             pat, Some slot
+         ))
+      attrs_list
+      pat_list
+  in
+  let exp_list =
+    List.map2
+      (fun {pvb_expr=sexp; pvb_attributes; _} (pat, slot) ->
+        if is_recursive then current_slot := slot;
+        match pat.pat_type.desc with
+        | Tpoly (ty, tl) ->
+            if !Clflags.principal then begin_def ();
+            let vars, ty' = instance_poly ~keep_names:true true tl ty in
+            if !Clflags.principal then begin
+              end_def ();
+              generalize_structure ty'
+            end;
+            let exp =
+              Builtin_attributes.warning_scope pvb_attributes (fun () ->
+                if rec_flag = Recursive then
+                  type_unpacks exp_env unpacks sexp (mk_expected ty')
+                else
+                  type_expect exp_env sexp (mk_expected ty')
+              )
+            in
+            exp, Some vars
+        | _ ->
+            let exp =
+              Builtin_attributes.warning_scope pvb_attributes (fun () ->
+                  if rec_flag = Recursive then
+                    type_unpacks exp_env unpacks sexp (mk_expected pat.pat_type)
+                  else
+                    type_expect exp_env sexp (mk_expected pat.pat_type))
+            in
+            exp, None)
+      spat_sexp_list pat_slot_list in
+  current_slot := None;
+  if is_recursive && not !rec_needed then begin
+    let {pvb_pat; pvb_attributes} = List.hd spat_sexp_list in
+    (* See PR#6677 *)
+    Builtin_attributes.warning_scope ~ppwarning:false pvb_attributes
+      (fun () ->
+         Location.prerr_warning pvb_pat.ppat_loc Warnings.Unused_rec_flag
+      )
+  end;
+  List.iter2
+    (fun pat (attrs, exp) ->
+       Builtin_attributes.warning_scope ~ppwarning:false attrs
+         (fun () ->
+            ignore(check_partial env pat.pat_type pat.pat_loc
+                     [case pat exp])
+         )
+    )
+    pat_list
+    (List.map2 (fun (attrs, _) (e, _) -> attrs, e) spatl exp_list);
+  let pvs = List.map (fun pv -> { pv with pv_type = instance pv.pv_type}) pvs in
+  end_def();
+  List.iter2
+    (fun pat (exp, _) ->
+       if maybe_expansive exp then
+         lower_contravariant env pat.pat_type)
+    pat_list exp_list;
+  iter_pattern_variables_type generalize pvs;
+  List.iter2
+    (fun pat (exp, vars) ->
+       match vars with
+       | None ->
+         (* We generalize expressions even if they are not bound to a variable
+            and do not have an expliclit polymorphic type annotation.  This is
+            not needed in general, however those types may be shown by the
+            interactive toplevel, for example:
+            {[
+              let _ = Array.get;;
+              - : 'a array -> int -> 'a = <fun>
+            ]}
+            so we do it anyway. *)
+         generalize exp.exp_type
+       | Some vars ->
+         generalize_and_check_univars env "definition" exp pat.pat_type vars)
+    pat_list exp_list;
+  let l = List.combine pat_list exp_list in
+  let l =
+    List.map2
+      (fun (p, (e, _)) pvb ->
+        {vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes;
+         vb_loc=pvb.pvb_loc;
+        })
+      l spat_sexp_list
+  in
+  if is_recursive then
+    List.iter
+      (fun {vb_pat=pat} -> match pat.pat_desc with
+           Tpat_var _ -> ()
+         | Tpat_alias ({pat_desc=Tpat_any}, _, _) -> ()
+         | _ -> raise(Error(pat.pat_loc, env, Illegal_letrec_pat)))
+      l;
+  List.iter (function
+      | {vb_pat = {pat_desc = Tpat_any; pat_extra; _}; vb_expr; _} ->
+          if not (List.exists (function (Tpat_constraint _, _, _) -> true
+                                      | _ -> false) pat_extra) then
+            check_partial_application false vb_expr
+      | _ -> ()) l;
+  (l, new_env, unpacks)
+
+and type_andops env sarg sands expected_ty =
+  let rec loop env let_sarg rev_sands expected_ty =
+    match rev_sands with
+    | [] -> type_expect env let_sarg (mk_expected expected_ty), []
+    | { pbop_op = sop; pbop_exp = sexp; pbop_loc = loc; _ } :: rest ->
+        if !Clflags.principal then begin_def ();
+        let op_path, op_desc = type_binding_op_ident env sop in
+        let op_type = instance op_desc.val_type in
+        let ty_arg = newvar () in
+        let ty_rest = newvar () in
+        let ty_result = newvar() in
+        let ty_rest_fun = newty (Tarrow(Nolabel, ty_arg, ty_result, Cok)) in
+        let ty_op = newty (Tarrow(Nolabel, ty_rest, ty_rest_fun, Cok)) in
+        begin try
+          unify env op_type ty_op
+        with Unify trace ->
+          raise(Error(sop.loc, env, Andop_type_clash(sop.txt, trace)))
+        end;
+        if !Clflags.principal then begin
+          end_def ();
+          generalize_structure ty_rest;
+          generalize_structure ty_arg;
+          generalize_structure ty_result
+        end;
+        let let_arg, rest = loop env let_sarg rest ty_rest in
+        let exp = type_expect env sexp (mk_expected ty_arg) in
+        begin try
+          unify env (instance ty_result) (instance expected_ty)
+        with Unify trace ->
+          raise(Error(loc, env, Bindings_type_clash(trace)))
+        end;
+        let andop =
+          { bop_op_name = sop;
+            bop_op_path = op_path;
+            bop_op_val = op_desc;
+            bop_op_type = op_type;
+            bop_exp = exp;
+            bop_loc = loc }
+        in
+        let_arg, andop :: rest
+  in
+  let let_arg, rev_ands = loop env sarg (List.rev sands) expected_ty in
+  let_arg, List.rev rev_ands
+
+(* Typing of toplevel bindings *)
+
+let type_binding env rec_flag spat_sexp_list scope =
+  Typetexp.reset_type_variables();
+  let (pat_exp_list, new_env, _unpacks) =
+    type_let
+      ~check:(fun s -> Warnings.Unused_value_declaration s)
+      ~check_strict:(fun s -> Warnings.Unused_value_declaration s)
+      At_toplevel
+      env rec_flag spat_sexp_list scope false
+  in
+  (pat_exp_list, new_env)
+
+let type_let existential_ctx env rec_flag spat_sexp_list scope =
+  let (pat_exp_list, new_env, _unpacks) =
+    type_let existential_ctx env rec_flag spat_sexp_list scope false in
+  (pat_exp_list, new_env)
+
+(* Typing of toplevel expressions *)
+
+let type_expression env sexp =
+  Typetexp.reset_type_variables();
+  begin_def();
+  let exp = type_exp env sexp in
+  end_def();
+  if maybe_expansive exp then lower_contravariant env exp.exp_type;
+  generalize exp.exp_type;
+  match sexp.pexp_desc with
+    Pexp_ident lid ->
+      let loc = sexp.pexp_loc in
+      (* Special case for keeping type variables when looking-up a variable *)
+      let (_path, desc) = Env.lookup_value ~use:false ~loc lid.txt env in
+      {exp with exp_type = desc.val_type}
+  | _ -> exp
+
+(* Error report *)
+
+let spellcheck ppf unbound_name valid_names =
+  Misc.did_you_mean ppf (fun () ->
+    Misc.spellcheck valid_names unbound_name
+  )
+
+let spellcheck_idents ppf unbound valid_idents =
+  spellcheck ppf (Ident.name unbound) (List.map Ident.name valid_idents)
+
+open Format
+
+let longident = Printtyp.longident
+
+(* Returns the first diff of the trace *)
+let type_clash_of_trace trace =
+  Ctype.Unification_trace.(explain trace (fun ~prev:_ -> function
+    | Diff diff -> Some diff
+    | _ -> None
+  ))
+
+(* Hint on type error on integer literals
+   To avoid confusion, it is disabled on float literals
+   and when the expected type is `int` *)
+let report_literal_type_constraint expected_type const =
+  let const_str = match const with
+    | Const_int n -> Some (Int.to_string n)
+    | Const_int32 n -> Some (Int32.to_string n)
+    | Const_int64 n -> Some (Int64.to_string n)
+    | Const_nativeint n -> Some (Nativeint.to_string n)
+    | _ -> None
+  in
+  let suffix =
+    if Path.same expected_type Predef.path_int32 then
+      Some 'l'
+    else if Path.same expected_type Predef.path_int64 then
+      Some 'L'
+    else if Path.same expected_type Predef.path_nativeint then
+      Some 'n'
+    else if Path.same expected_type Predef.path_float then
+      Some '.'
+    else None
+  in
+  match const_str, suffix with
+  | Some c, Some s -> [ Location.msg "@[Hint: Did you mean `%s%c'?@]" c s ]
+  | _, _ -> []
+
+let report_literal_type_constraint const = function
+  | Some Unification_trace.
+    { expected = { t = { desc = Tconstr (typ, [], _) } } } ->
+      report_literal_type_constraint typ const
+  | Some _ | None -> []
+
+let report_expr_type_clash_hints exp diff =
+  match exp with
+  | Some (Texp_constant const) -> report_literal_type_constraint const diff
+  | _ -> []
+
+let report_pattern_type_clash_hints
+      (type k) (pat : k pattern_desc option) diff =
+  match pat with
+  | Some (Tpat_constant const) -> report_literal_type_constraint const diff
+  | _ -> []
+
+let report_type_expected_explanation expl ppf =
+  let because expl_str = fprintf ppf "@ because it is in %s" expl_str in
+  match expl with
+  | If_conditional ->
+      because "the condition of an if-statement"
+  | If_no_else_branch ->
+      because "the result of a conditional with no else branch"
+  | While_loop_conditional ->
+      because "the condition of a while-loop"
+  | While_loop_body ->
+      because "the body of a while-loop"
+  | For_loop_start_index ->
+      because "a for-loop start index"
+  | For_loop_stop_index ->
+      because "a for-loop stop index"
+  | For_loop_body ->
+      because "the body of a for-loop"
+  | Assert_condition ->
+      because "the condition of an assertion"
+  | Sequence_left_hand_side ->
+      because "the left-hand side of a sequence"
+  | When_guard ->
+      because "a when-guard"
+
+let report_type_expected_explanation_opt expl ppf =
+  match expl with
+  | None -> ()
+  | Some expl -> report_type_expected_explanation expl ppf
+
+let report_unification_error ~loc ?sub env trace
+    ?type_expected_explanation txt1 txt2 =
+  Location.error_of_printer ~loc ?sub (fun ppf () ->
+    Printtyp.report_unification_error ppf env trace
+      ?type_expected_explanation txt1 txt2
+  ) ()
+
+let report_error ~loc env = function
+  | Constructor_arity_mismatch(lid, expected, provided) ->
+      Location.errorf ~loc
+       "@[The constructor %a@ expects %i argument(s),@ \
+        but is applied here to %i argument(s)@]"
+       longident lid expected provided
+  | Label_mismatch(lid, trace) ->
+      report_unification_error ~loc env trace
+        (function ppf ->
+           fprintf ppf "The record field %a@ belongs to the type"
+                   longident lid)
+        (function ppf ->
+           fprintf ppf "but is mixed here with fields of type")
+  | Pattern_type_clash (trace, pat) ->
+      let diff = type_clash_of_trace trace in
+      let sub = report_pattern_type_clash_hints pat diff in
+      Location.error_of_printer ~loc ~sub (fun ppf () ->
+        Printtyp.report_unification_error ppf env trace
+          (function ppf ->
+            fprintf ppf "This pattern matches values of type")
+          (function ppf ->
+            fprintf ppf "but a pattern was expected which matches values of \
+                         type");
+      ) ()
+  | Or_pattern_type_clash (id, trace) ->
+      report_unification_error ~loc env trace
+        (function ppf ->
+          fprintf ppf "The variable %s on the left-hand side of this \
+                       or-pattern has type" (Ident.name id))
+        (function ppf ->
+          fprintf ppf "but on the right-hand side it has type")
+  | Multiply_bound_variable name ->
+      Location.errorf ~loc
+        "Variable %s is bound several times in this matching"
+        name
+  | Orpat_vars (id, valid_idents) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        fprintf ppf
+          "Variable %s must occur on both sides of this | pattern"
+          (Ident.name id);
+        spellcheck_idents ppf id valid_idents
+      ) ()
+  | Expr_type_clash (trace, explanation, exp) ->
+      let diff = type_clash_of_trace trace in
+      let sub = report_expr_type_clash_hints exp diff in
+      Location.error_of_printer ~loc ~sub (fun ppf () ->
+        Printtyp.report_unification_error ppf env trace
+          ~type_expected_explanation:
+            (report_type_expected_explanation_opt explanation)
+          (function ppf ->
+             fprintf ppf "This expression has type")
+          (function ppf ->
+             fprintf ppf "but an expression was expected of type");
+      ) ()
+  | Apply_non_function typ ->
+      begin match (repr typ).desc with
+        Tarrow _ ->
+          Location.errorf ~loc
+            "@[<v>@[<2>This function has type@ %a@]\
+             @ @[It is applied to too many arguments;@ %s@]@]"
+            Printtyp.type_expr typ "maybe you forgot a `;'.";
+      | _ ->
+          Location.errorf ~loc "@[<v>@[<2>This expression has type@ %a@]@ %s@]"
+            Printtyp.type_expr typ
+            "This is not a function; it cannot be applied."
+      end
+  | Apply_wrong_label (l, ty, extra_info) ->
+      let print_label ppf = function
+        | Nolabel -> fprintf ppf "without label"
+        | l -> fprintf ppf "with label %s" (prefixed_label_name l)
+      in
+      let extra_info =
+        if not extra_info then
+          []
+        else
+          [ Location.msg
+              "Since OCaml 4.11, optional arguments do not commute when \
+               -nolabels is given" ]
+      in
+      Location.errorf ~loc ~sub:extra_info
+        "@[<v>@[<2>The function applied to this argument has type@ %a@]@.\
+         This argument cannot be applied %a@]"
+        Printtyp.type_expr ty print_label l
+  | Label_multiply_defined s ->
+      Location.errorf ~loc "The record field label %s is defined several times"
+        s
+  | Label_missing labels ->
+      let print_labels ppf =
+        List.iter (fun lbl -> fprintf ppf "@ %s" (Ident.name lbl)) in
+      Location.errorf ~loc "@[<hov>Some record fields are undefined:%a@]"
+        print_labels labels
+  | Label_not_mutable lid ->
+      Location.errorf ~loc "The record field %a is not mutable" longident lid
+  | Wrong_name (eorp, ty_expected, { type_path; kind; name; valid_names; }) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        Printtyp.wrap_printing_env ~error:true env (fun () ->
+          let { ty; explanation } = ty_expected in
+          if Path.is_constructor_typath type_path then begin
+            fprintf ppf
+              "@[The field %s is not part of the record \
+               argument for the %a constructor@]"
+              name.txt
+              Printtyp.type_path type_path;
+          end else begin
+            fprintf ppf
+              "@[@[<2>%s type@ %a%t@]@ \
+               The %s %s does not belong to type %a@]"
+              eorp Printtyp.type_expr ty
+              (report_type_expected_explanation_opt explanation)
+              (Datatype_kind.label_name kind)
+              name.txt (*kind*) Printtyp.type_path type_path;
+          end;
+          spellcheck ppf name.txt valid_names
+      )) ()
+  | Name_type_mismatch (kind, lid, tp, tpl) ->
+      let type_name = Datatype_kind.type_name kind in
+      let name = Datatype_kind.label_name kind in
+      Location.error_of_printer ~loc (fun ppf () ->
+        Printtyp.report_ambiguous_type_error ppf env tp tpl
+          (function ppf ->
+             fprintf ppf "The %s %a@ belongs to the %s type"
+               name longident lid type_name)
+          (function ppf ->
+             fprintf ppf "The %s %a@ belongs to one of the following %s types:"
+               name longident lid type_name)
+          (function ppf ->
+             fprintf ppf "but a %s was expected belonging to the %s type"
+               name type_name)
+      ) ()
+  | Invalid_format msg ->
+      Location.errorf ~loc "%s" msg
+  | Undefined_method (ty, me, valid_methods) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        Printtyp.wrap_printing_env ~error:true env (fun () ->
+          fprintf ppf
+            "@[<v>@[This expression has type@;<1 2>%a@]@,\
+             It has no method %s@]" Printtyp.type_expr ty me;
+          begin match valid_methods with
+            | None -> ()
+            | Some valid_methods -> spellcheck ppf me valid_methods
+          end
+      )) ()
+  | Undefined_inherited_method (me, valid_methods) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        fprintf ppf "This expression has no method %s" me;
+        spellcheck ppf me valid_methods;
+      ) ()
+  | Virtual_class cl ->
+      Location.errorf ~loc "Cannot instantiate the virtual class %a"
+        longident cl
+  | Unbound_instance_variable (var, valid_vars) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        fprintf ppf "Unbound instance variable %s" var;
+        spellcheck ppf var valid_vars;
+      ) ()
+  | Instance_variable_not_mutable v ->
+      Location.errorf ~loc "The instance variable %s is not mutable" v
+  | Not_subtype(tr1, tr2) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        Printtyp.report_subtyping_error ppf env tr1 "is not a subtype of" tr2
+      ) ()
+  | Outside_class ->
+      Location.errorf ~loc
+        "This object duplication occurs outside a method definition"
+  | Value_multiply_overridden v ->
+      Location.errorf ~loc
+        "The instance variable %s is overridden several times"
+        v
+  | Coercion_failure (ty, ty', trace, b) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        Printtyp.report_unification_error ppf env trace
+          (function ppf ->
+             let ty, ty' = Printtyp.prepare_expansion (ty, ty') in
+             fprintf ppf "This expression cannot be coerced to type@;<1 2>%a;@ \
+                          it has type"
+             (Printtyp.type_expansion ty) ty')
+          (function ppf ->
+             fprintf ppf "but is here used with type");
+        if b then
+          fprintf ppf ".@.@[<hov>%s@ %s@ %s@]"
+            "This simple coercion was not fully general."
+            "Hint: Consider using a fully explicit coercion"
+            "of the form: `(foo : ty1 :> ty2)'."
+      ) ()
+  | Too_many_arguments (in_function, ty, explanation) ->
+      if in_function then begin
+        Location.errorf ~loc
+          "This function expects too many arguments,@ \
+           it should have type@ %a%t"
+          Printtyp.type_expr ty
+          (report_type_expected_explanation_opt explanation)
+      end else begin
+        Location.errorf ~loc
+          "This expression should not be a function,@ \
+           the expected type is@ %a%t"
+          Printtyp.type_expr ty
+          (report_type_expected_explanation_opt explanation)
+      end
+  | Abstract_wrong_label (l, ty, explanation) ->
+      let label_mark = function
+        | Nolabel -> "but its first argument is not labelled"
+        | l -> sprintf "but its first argument is labelled %s"
+                       (prefixed_label_name l) in
+      Location.errorf ~loc
+        "@[<v>@[<2>This function should have type@ %a%t@]@,%s@]"
+        Printtyp.type_expr ty
+        (report_type_expected_explanation_opt explanation)
+        (label_mark l)
+  | Scoping_let_module(id, ty) ->
+      Location.errorf ~loc
+        "This `let module' expression has type@ %a@ \
+         In this type, the locally bound module name %s escapes its scope"
+        Printtyp.type_expr ty id
+  | Private_type ty ->
+      Location.errorf ~loc "Cannot create values of the private type %a"
+        Printtyp.type_expr ty
+  | Private_label (lid, ty) ->
+      Location.errorf ~loc "Cannot assign field %a of the private type %a"
+        longident lid Printtyp.type_expr ty
+  | Private_constructor (constr, ty) ->
+      Location.errorf ~loc
+        "Cannot use private constructor %s to create values of type %a"
+        constr.cstr_name Printtyp.type_expr ty
+  | Not_a_variant_type lid ->
+      Location.errorf ~loc "The type %a@ is not a variant type" longident lid
+  | Incoherent_label_order ->
+      Location.errorf ~loc
+        "This function is applied to arguments@ \
+        in an order different from other calls.@ \
+        This is only allowed when the real type is known."
+  | Less_general (kind, trace) ->
+      report_unification_error ~loc env trace
+        (fun ppf -> fprintf ppf "This %s has type" kind)
+        (fun ppf -> fprintf ppf "which is less general than")
+  | Modules_not_allowed ->
+      Location.errorf ~loc "Modules are not allowed in this pattern."
+  | Cannot_infer_signature ->
+      Location.errorf ~loc
+        "The signature for this packaged module couldn't be inferred."
+  | Not_a_packed_module ty ->
+      Location.errorf ~loc
+        "This expression is packed module, but the expected type is@ %a"
+        Printtyp.type_expr ty
+  | Unexpected_existential (reason, name, types) ->
+      let reason_str =
+        match reason with
+        | In_class_args ->
+            "Existential types are not allowed in class arguments"
+        | In_class_def ->
+            "Existential types are not allowed in bindings inside \
+             class definition"
+        | In_self_pattern ->
+            "Existential types are not allowed in self patterns"
+        | At_toplevel ->
+            "Existential types are not allowed in toplevel bindings"
+        | In_group ->
+            "Existential types are not allowed in \"let ... and ...\" bindings"
+        | In_rec ->
+            "Existential types are not allowed in recursive bindings"
+        | With_attributes ->
+            "Existential types are not allowed in presence of attributes"
+      in
+      begin match List.find (fun ty -> ty <> "$" ^ name) types with
+      | example ->
+          Location.errorf ~loc
+            "%s,@ but this pattern introduces the existential type %s."
+            reason_str example
+      | exception Not_found ->
+          Location.errorf ~loc
+            "%s,@ but the constructor %s introduces existential types."
+            reason_str name
+      end
+  | Invalid_interval ->
+      Location.errorf ~loc
+        "@[Only character intervals are supported in patterns.@]"
+  | Invalid_for_loop_index ->
+      Location.errorf ~loc
+        "@[Invalid for-loop index: only variables and _ are allowed.@]"
+  | No_value_clauses ->
+      Location.errorf ~loc
+        "None of the patterns in this 'match' expression match values."
+  | Exception_pattern_disallowed ->
+      Location.errorf ~loc
+        "@[Exception patterns are not allowed in this position.@]"
+  | Mixed_value_and_exception_patterns_under_guard ->
+      Location.errorf ~loc
+        "@[Mixing value and exception patterns under when-guards is not \
+         supported.@]"
+  | Inlined_record_escape ->
+      Location.errorf ~loc
+        "@[This form is not allowed as the type of the inlined record could \
+         escape.@]"
+  | Inlined_record_expected ->
+      Location.errorf ~loc
+        "@[This constructor expects an inlined record argument.@]"
+  | Unrefuted_pattern pat ->
+      Location.errorf ~loc
+        "@[%s@ %s@ %a@]"
+        "This match case could not be refuted."
+        "Here is an example of a value that would reach it:"
+        Printpat.top_pretty pat
+  | Invalid_extension_constructor_payload ->
+      Location.errorf ~loc
+        "Invalid [%%extension_constructor] payload, a constructor is expected."
+  | Not_an_extension_constructor ->
+      Location.errorf ~loc
+        "This constructor is not an extension constructor."
+  | Literal_overflow ty ->
+      Location.errorf ~loc
+        "Integer literal exceeds the range of representable integers of type %s"
+        ty
+  | Unknown_literal (n, m) ->
+      Location.errorf ~loc "Unknown modifier '%c' for literal %s%c" m n m
+  | Illegal_letrec_pat ->
+      Location.errorf ~loc
+        "Only variables are allowed as left-hand side of `let rec'"
+  | Illegal_letrec_expr ->
+      Location.errorf ~loc
+        "This kind of expression is not allowed as right-hand side of `let rec'"
+  | Illegal_class_expr ->
+      Location.errorf ~loc
+        "This kind of recursive class expression is not allowed"
+  | Letop_type_clash(name, trace) ->
+      report_unification_error ~loc env trace
+        (function ppf ->
+          fprintf ppf "The operator %s has type" name)
+        (function ppf ->
+          fprintf ppf "but it was expected to have type")
+  | Andop_type_clash(name, trace) ->
+      report_unification_error ~loc env trace
+        (function ppf ->
+          fprintf ppf "The operator %s has type" name)
+        (function ppf ->
+          fprintf ppf "but it was expected to have type")
+  | Bindings_type_clash(trace) ->
+      report_unification_error ~loc env trace
+        (function ppf ->
+          fprintf ppf "These bindings have type")
+        (function ppf ->
+          fprintf ppf "but bindings were expected of type")
+
+let report_error ~loc env err =
+  Printtyp.wrap_printing_env ~error:true env
+    (fun () -> report_error ~loc env err)
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, env, err) ->
+        Some (report_error ~loc env err)
+      | Error_forward err ->
+        Some err
+      | _ ->
+        None
+    )
+
+let () =
+  Persistent_env.add_delayed_check_forward := add_delayed_check;
+  Env.add_delayed_check_forward := add_delayed_check;
+  ()
+
+(* drop ?recarg argument from the external API *)
+let type_expect ?in_function env e ty = type_expect ?in_function env e ty
+let type_exp env e = type_exp env e
+let type_argument env e t1 t2 = type_argument env e t1 t2
diff --git a/upstream/ocaml_411/typing/typecore.mli b/upstream/ocaml_411/typing/typecore.mli
new file mode 100644
index 0000000..2c8d177
--- /dev/null
+++ b/upstream/ocaml_411/typing/typecore.mli
@@ -0,0 +1,226 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Type inference for the core language *)
+
+open Asttypes
+open Types
+
+(* This variant is used to print improved error messages, and does not affect
+   the behavior of the typechecker itself.
+
+   It describes possible explanation for types enforced by a keyword of the
+   language; e.g. "if" requires the condition to be of type bool, and the
+   then-branch to be of type unit if there is no else branch; "for" requires
+   indices to be of type int, and the body to be of type unit.
+*)
+type type_forcing_context =
+  | If_conditional
+  | If_no_else_branch
+  | While_loop_conditional
+  | While_loop_body
+  | For_loop_start_index
+  | For_loop_stop_index
+  | For_loop_body
+  | Assert_condition
+  | Sequence_left_hand_side
+  | When_guard
+
+(* The combination of a type and a "type forcing context". The intent is that it
+   describes a type that is "expected" (required) by the context. If unifying
+   with such a type fails, then the "explanation" field explains why it was
+   required, in order to display a more enlightening error message.
+*)
+type type_expected = private {
+  ty: type_expr;
+  explanation: type_forcing_context option;
+}
+
+val mk_expected:
+  ?explanation:type_forcing_context ->
+  type_expr ->
+  type_expected
+
+val is_nonexpansive: Typedtree.expression -> bool
+
+module Datatype_kind : sig
+  type t = Record | Variant
+  val type_name : t -> string
+  val label_name : t -> string
+end
+
+type wrong_name = {
+  type_path: Path.t;
+  kind: Datatype_kind.t;
+  name: string loc;
+  valid_names: string list;
+}
+
+type existential_restriction =
+  | At_toplevel (** no existential types at the toplevel *)
+  | In_group (** nor with [let ... and ...] *)
+  | In_rec (** or recursive definition *)
+  | With_attributes (** or [let[@any_attribute] = ...] *)
+  | In_class_args (** or in class arguments [class c (...) = ...] *)
+  | In_class_def (** or in [class c = let ... in ...] *)
+  | In_self_pattern (** or in self pattern *)
+
+val type_binding:
+        Env.t -> rec_flag ->
+          Parsetree.value_binding list ->
+          Annot.ident option ->
+          Typedtree.value_binding list * Env.t
+val type_let:
+        existential_restriction -> Env.t -> rec_flag ->
+          Parsetree.value_binding list ->
+          Annot.ident option ->
+          Typedtree.value_binding list * Env.t
+val type_expression:
+        Env.t -> Parsetree.expression -> Typedtree.expression
+val type_class_arg_pattern:
+        string -> Env.t -> Env.t -> arg_label -> Parsetree.pattern ->
+        Typedtree.pattern *
+        (Ident.t * Ident.t * type_expr) list *
+        Env.t * Env.t
+val type_self_pattern:
+        string -> type_expr -> Env.t -> Env.t -> Env.t -> Parsetree.pattern ->
+        Typedtree.pattern *
+        (Ident.t * type_expr) Meths.t ref *
+        (Ident.t * Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr)
+            Vars.t ref *
+        Env.t * Env.t * Env.t
+val check_partial:
+        ?lev:int -> Env.t -> type_expr ->
+        Location.t -> Typedtree.value Typedtree.case list -> Typedtree.partial
+val type_expect:
+        ?in_function:(Location.t * type_expr) ->
+        Env.t -> Parsetree.expression -> type_expected -> Typedtree.expression
+val type_exp:
+        Env.t -> Parsetree.expression -> Typedtree.expression
+val type_approx:
+        Env.t -> Parsetree.expression -> type_expr
+val type_argument:
+        Env.t -> Parsetree.expression ->
+        type_expr -> type_expr -> Typedtree.expression
+
+val option_some: Env.t -> Typedtree.expression -> Typedtree.expression
+val option_none: Env.t -> type_expr -> Location.t -> Typedtree.expression
+val extract_option_type: Env.t -> type_expr -> type_expr
+val generalizable: int -> type_expr -> bool
+val reset_delayed_checks: unit -> unit
+val force_delayed_checks: unit -> unit
+
+val name_pattern : string -> Typedtree.pattern list -> Ident.t
+val name_cases : string -> Typedtree.value Typedtree.case list -> Ident.t
+
+val self_coercion : (Path.t * Location.t list ref) list ref
+
+type error =
+  | Constructor_arity_mismatch of Longident.t * int * int
+  | Label_mismatch of Longident.t * Ctype.Unification_trace.t
+  | Pattern_type_clash :
+      Ctype.Unification_trace.t * _ Typedtree.pattern_desc option -> error
+  | Or_pattern_type_clash of Ident.t * Ctype.Unification_trace.t
+  | Multiply_bound_variable of string
+  | Orpat_vars of Ident.t * Ident.t list
+  | Expr_type_clash of
+      Ctype.Unification_trace.t * type_forcing_context option
+      * Typedtree.expression_desc option
+  | Apply_non_function of type_expr
+  | Apply_wrong_label of arg_label * type_expr * bool
+  | Label_multiply_defined of string
+  | Label_missing of Ident.t list
+  | Label_not_mutable of Longident.t
+  | Wrong_name of string * type_expected * wrong_name
+  | Name_type_mismatch of
+      Datatype_kind.t * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list
+  | Invalid_format of string
+  | Undefined_method of type_expr * string * string list option
+  | Undefined_inherited_method of string * string list
+  | Virtual_class of Longident.t
+  | Private_type of type_expr
+  | Private_label of Longident.t * type_expr
+  | Private_constructor of constructor_description * type_expr
+  | Unbound_instance_variable of string * string list
+  | Instance_variable_not_mutable of string
+  | Not_subtype of Ctype.Unification_trace.t * Ctype.Unification_trace.t
+  | Outside_class
+  | Value_multiply_overridden of string
+  | Coercion_failure of
+      type_expr * type_expr * Ctype.Unification_trace.t * bool
+  | Too_many_arguments of bool * type_expr * type_forcing_context option
+  | Abstract_wrong_label of arg_label * type_expr * type_forcing_context option
+  | Scoping_let_module of string * type_expr
+  | Not_a_variant_type of Longident.t
+  | Incoherent_label_order
+  | Less_general of string * Ctype.Unification_trace.t
+  | Modules_not_allowed
+  | Cannot_infer_signature
+  | Not_a_packed_module of type_expr
+  | Unexpected_existential of existential_restriction * string * string list
+  | Invalid_interval
+  | Invalid_for_loop_index
+  | No_value_clauses
+  | Exception_pattern_disallowed
+  | Mixed_value_and_exception_patterns_under_guard
+  | Inlined_record_escape
+  | Inlined_record_expected
+  | Unrefuted_pattern of Typedtree.pattern
+  | Invalid_extension_constructor_payload
+  | Not_an_extension_constructor
+  | Literal_overflow of string
+  | Unknown_literal of string * char
+  | Illegal_letrec_pat
+  | Illegal_letrec_expr
+  | Illegal_class_expr
+  | Letop_type_clash of string * Ctype.Unification_trace.t
+  | Andop_type_clash of string * Ctype.Unification_trace.t
+  | Bindings_type_clash of Ctype.Unification_trace.t
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+val report_error: loc:Location.t -> Env.t -> error -> Location.error
+ (** @deprecated.  Use {!Location.error_of_exn}, {!Location.print_report}. *)
+
+(* Forward declaration, to be filled in by Typemod.type_module *)
+val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref
+(* Forward declaration, to be filled in by Typemod.type_open *)
+val type_open:
+  (?used_slot:bool ref -> override_flag -> Env.t -> Location.t ->
+   Longident.t loc -> Path.t * Env.t)
+    ref
+(* Forward declaration, to be filled in by Typemod.type_open_decl *)
+val type_open_decl:
+  (?used_slot:bool ref -> Env.t -> Parsetree.open_declaration ->
+   Typedtree.open_declaration * Types.signature * Env.t)
+    ref
+(* Forward declaration, to be filled in by Typeclass.class_structure *)
+val type_object:
+  (Env.t -> Location.t -> Parsetree.class_structure ->
+   Typedtree.class_structure * Types.class_signature * string list) ref
+val type_package:
+  (Env.t -> Parsetree.module_expr -> Path.t -> Longident.t list ->
+  Typedtree.module_expr * type_expr list) ref
+
+val create_package_type : Location.t -> Env.t ->
+  Longident.t * (Longident.t * Parsetree.core_type) list ->
+  Path.t * (Longident.t * Typedtree.core_type) list * Types.type_expr
+
+val constant: Parsetree.constant -> (Asttypes.constant, error) result
+
+val check_recursive_bindings : Env.t -> Typedtree.value_binding list -> unit
+val check_recursive_class_bindings :
+  Env.t -> Ident.t list -> Typedtree.class_expr list -> unit
diff --git a/upstream/ocaml_411/typing/typedecl.ml b/upstream/ocaml_411/typing/typedecl.ml
new file mode 100644
index 0000000..d38a142
--- /dev/null
+++ b/upstream/ocaml_411/typing/typedecl.ml
@@ -0,0 +1,1872 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(**** Typing of type definitions ****)
+
+open Misc
+open Asttypes
+open Parsetree
+open Primitive
+open Types
+open Typetexp
+
+module String = Misc.Stdlib.String
+
+type native_repr_kind = Unboxed | Untagged
+
+type error =
+    Repeated_parameter
+  | Duplicate_constructor of string
+  | Too_many_constructors
+  | Duplicate_label of string
+  | Recursive_abbrev of string
+  | Cycle_in_def of string * type_expr
+  | Definition_mismatch of type_expr * Includecore.type_mismatch option
+  | Constraint_failed of type_expr * type_expr
+  | Inconsistent_constraint of Env.t * Ctype.Unification_trace.t
+  | Type_clash of Env.t * Ctype.Unification_trace.t
+  | Non_regular of {
+      definition: Path.t;
+      used_as: type_expr;
+      defined_as: type_expr;
+      expansions: (type_expr * type_expr) list;
+    }
+  | Null_arity_external
+  | Missing_native_external
+  | Unbound_type_var of type_expr * type_declaration
+  | Cannot_extend_private_type of Path.t
+  | Not_extensible_type of Path.t
+  | Extension_mismatch of Path.t * Includecore.type_mismatch
+  | Rebind_wrong_type of Longident.t * Env.t * Ctype.Unification_trace.t
+  | Rebind_mismatch of Longident.t * Path.t * Path.t
+  | Rebind_private of Longident.t
+  | Variance of Typedecl_variance.error
+  | Unavailable_type_constructor of Path.t
+  | Bad_fixed_type of string
+  | Unbound_type_var_ext of type_expr * extension_constructor
+  | Val_in_structure
+  | Multiple_native_repr_attributes
+  | Cannot_unbox_or_untag_type of native_repr_kind
+  | Deep_unbox_or_untag_attribute of native_repr_kind
+  | Immediacy of Typedecl_immediacy.error
+  | Separability of Typedecl_separability.error
+  | Bad_unboxed_attribute of string
+  | Boxed_and_unboxed
+  | Nonrec_gadt
+
+open Typedtree
+
+exception Error of Location.t * error
+
+(* Note: do not factor the branches in the following pattern-matching:
+   the records must be constants for the compiler to do sharing on them.
+*)
+let get_unboxed_from_attributes sdecl =
+  let unboxed = Builtin_attributes.has_unboxed sdecl.ptype_attributes in
+  let boxed = Builtin_attributes.has_boxed sdecl.ptype_attributes in
+  match boxed, unboxed, !Clflags.unboxed_types with
+  | true, true, _ -> raise (Error(sdecl.ptype_loc, Boxed_and_unboxed))
+  | true, false, _ -> unboxed_false_default_false
+  | false, true, _ -> unboxed_true_default_false
+  | false, false, false -> unboxed_false_default_true
+  | false, false, true -> unboxed_true_default_true
+
+(* Enter all declared types in the environment as abstract types *)
+
+let add_type ~check id decl env =
+  Builtin_attributes.warning_scope ~ppwarning:false decl.type_attributes
+    (fun () -> Env.add_type ~check id decl env)
+
+let enter_type rec_flag env sdecl (id, uid) =
+  let needed =
+    match rec_flag with
+    | Asttypes.Nonrecursive ->
+        begin match sdecl.ptype_kind with
+        | Ptype_variant scds ->
+            List.iter (fun cd ->
+              if cd.pcd_res <> None then raise (Error(cd.pcd_loc, Nonrec_gadt)))
+              scds
+        | _ -> ()
+        end;
+        Btype.is_row_name (Ident.name id)
+    | Asttypes.Recursive -> true
+  in
+  let arity = List.length sdecl.ptype_params in
+  if not needed then env else
+  let decl =
+    { type_params =
+        List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params;
+      type_arity = arity;
+      type_kind = Type_abstract;
+      type_private = sdecl.ptype_private;
+      type_manifest =
+        begin match sdecl.ptype_manifest with None -> None
+        | Some _ -> Some(Ctype.newvar ()) end;
+      type_variance = List.map (fun _ -> Variance.full) sdecl.ptype_params;
+      type_separability = Types.Separability.default_signature ~arity;
+      type_is_newtype = false;
+      type_expansion_scope = Btype.lowest_level;
+      type_loc = sdecl.ptype_loc;
+      type_attributes = sdecl.ptype_attributes;
+      type_immediate = Unknown;
+      type_unboxed = unboxed_false_default_false;
+      type_uid = uid;
+    }
+  in
+  add_type ~check:true id decl env
+
+let update_type temp_env env id loc =
+  let path = Path.Pident id in
+  let decl = Env.find_type path temp_env in
+  match decl.type_manifest with None -> ()
+  | Some ty ->
+      let params = List.map (fun _ -> Ctype.newvar ()) decl.type_params in
+      try Ctype.unify env (Ctype.newconstr path params) ty
+      with Ctype.Unify trace ->
+        raise (Error(loc, Type_clash (env, trace)))
+
+let get_unboxed_type_representation env ty =
+  match Typedecl_unboxed.get_unboxed_type_representation env ty with
+  | Typedecl_unboxed.This x -> Some x
+  | _ -> None
+
+(* Determine if a type's values are represented by floats at run-time. *)
+let is_float env ty =
+  match get_unboxed_type_representation env ty with
+    Some {desc = Tconstr(p, _, _); _} -> Path.same p Predef.path_float
+  | _ -> false
+
+(* Determine if a type definition defines a fixed type. (PW) *)
+let is_fixed_type sd =
+  let rec has_row_var sty =
+    match sty.ptyp_desc with
+      Ptyp_alias (sty, _) -> has_row_var sty
+    | Ptyp_class _
+    | Ptyp_object (_, Open)
+    | Ptyp_variant (_, Open, _)
+    | Ptyp_variant (_, Closed, Some _) -> true
+    | _ -> false
+  in
+  match sd.ptype_manifest with
+    None -> false
+  | Some sty ->
+      sd.ptype_kind = Ptype_abstract &&
+      sd.ptype_private = Private &&
+      has_row_var sty
+
+(* Set the row variable in a fixed type *)
+let set_fixed_row env loc p decl =
+  let tm =
+    match decl.type_manifest with
+      None -> assert false
+    | Some t -> Ctype.expand_head env t
+  in
+  let rv =
+    match tm.desc with
+      Tvariant row ->
+        let row = Btype.row_repr row in
+        tm.desc <- Tvariant {row with row_fixed = Some Fixed_private};
+        if Btype.static_row row then Btype.newgenty Tnil
+        else row.row_more
+    | Tobject (ty, _) ->
+        snd (Ctype.flatten_fields ty)
+    | _ ->
+        raise (Error (loc, Bad_fixed_type "is not an object or variant"))
+  in
+  if not (Btype.is_Tvar rv) then
+    raise (Error (loc, Bad_fixed_type "has no row variable"));
+  rv.desc <- Tconstr (p, decl.type_params, ref Mnil)
+
+(* Translate one type declaration *)
+
+let make_params env params =
+  let make_param (sty, v) =
+    try
+      (transl_type_param env sty, v)
+    with Already_bound ->
+      raise(Error(sty.ptyp_loc, Repeated_parameter))
+  in
+    List.map make_param params
+
+let transl_labels env closed lbls =
+  assert (lbls <> []);
+  let all_labels = ref String.Set.empty in
+  List.iter
+    (fun {pld_name = {txt=name; loc}} ->
+       if String.Set.mem name !all_labels then
+         raise(Error(loc, Duplicate_label name));
+       all_labels := String.Set.add name !all_labels)
+    lbls;
+  let mk {pld_name=name;pld_mutable=mut;pld_type=arg;pld_loc=loc;
+          pld_attributes=attrs} =
+    Builtin_attributes.warning_scope attrs
+      (fun () ->
+         let arg = Ast_helper.Typ.force_poly arg in
+         let cty = transl_simple_type env closed arg in
+         {ld_id = Ident.create_local name.txt;
+          ld_name = name; ld_mutable = mut;
+          ld_type = cty; ld_loc = loc; ld_attributes = attrs}
+      )
+  in
+  let lbls = List.map mk lbls in
+  let lbls' =
+    List.map
+      (fun ld ->
+         let ty = ld.ld_type.ctyp_type in
+         let ty = match ty.desc with Tpoly(t,[]) -> t | _ -> ty in
+         {Types.ld_id = ld.ld_id;
+          ld_mutable = ld.ld_mutable;
+          ld_type = ty;
+          ld_loc = ld.ld_loc;
+          ld_attributes = ld.ld_attributes;
+          ld_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+         }
+      )
+      lbls in
+  lbls, lbls'
+
+let transl_constructor_arguments env closed = function
+  | Pcstr_tuple l ->
+      let l = List.map (transl_simple_type env closed) l in
+      Types.Cstr_tuple (List.map (fun t -> t.ctyp_type) l),
+      Cstr_tuple l
+  | Pcstr_record l ->
+      let lbls, lbls' = transl_labels env closed l in
+      Types.Cstr_record lbls',
+      Cstr_record lbls
+
+let make_constructor env type_path type_params sargs sret_type =
+  match sret_type with
+  | None ->
+      let args, targs =
+        transl_constructor_arguments env true sargs
+      in
+        targs, None, args, None
+  | Some sret_type ->
+      (* if it's a generalized constructor we must first narrow and
+         then widen so as to not introduce any new constraints *)
+      let z = narrow () in
+      reset_type_variables ();
+      let args, targs =
+        transl_constructor_arguments env false sargs
+      in
+      let tret_type = transl_simple_type env false sret_type in
+      let ret_type = tret_type.ctyp_type in
+      (* TODO add back type_path as a parameter ? *)
+      begin match (Ctype.repr ret_type).desc with
+        | Tconstr (p', _, _) when Path.same type_path p' -> ()
+        | _ ->
+            raise (Error (sret_type.ptyp_loc, Constraint_failed
+                            (ret_type, Ctype.newconstr type_path type_params)))
+      end;
+      widen z;
+      targs, Some tret_type, args, Some ret_type
+
+let transl_declaration env sdecl (id, uid) =
+  (* Bind type parameters *)
+  reset_type_variables();
+  Ctype.begin_def ();
+  let tparams = make_params env sdecl.ptype_params in
+  let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in
+  let cstrs = List.map
+    (fun (sty, sty', loc) ->
+      transl_simple_type env false sty,
+      transl_simple_type env false sty', loc)
+    sdecl.ptype_cstrs
+  in
+  let raw_status = get_unboxed_from_attributes sdecl in
+  if raw_status.unboxed && not raw_status.default then begin
+    let bad msg = raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute msg)) in
+    match sdecl.ptype_kind with
+    | Ptype_abstract    -> bad "it is abstract"
+    | Ptype_open        -> bad "extensible variant types cannot be unboxed"
+    | Ptype_record fields -> begin match fields with
+        | [] -> bad "it has no fields"
+        | _::_::_ -> bad "it has more than one field"
+        | [{pld_mutable = Mutable}] -> bad "it is mutable"
+        | [{pld_mutable = Immutable}] -> ()
+      end
+    | Ptype_variant constructors -> begin match constructors with
+        | [] -> bad "it has no constructor"
+        | (_::_::_) -> bad "it has more than one constructor"
+        | [c] -> begin match c.pcd_args with
+            | Pcstr_tuple [] ->
+                bad "its constructor has no argument"
+            | Pcstr_tuple (_::_::_) ->
+                bad "its constructor has more than one argument"
+            | Pcstr_tuple [_]  ->
+                ()
+            | Pcstr_record [] ->
+                bad "its constructor has no fields"
+            | Pcstr_record (_::_::_) ->
+                bad "its constructor has more than one field"
+            | Pcstr_record [{pld_mutable = Mutable}] ->
+                bad "it is mutable"
+            | Pcstr_record [{pld_mutable = Immutable}] ->
+                ()
+          end
+      end
+  end;
+  let unboxed_status =
+    match sdecl.ptype_kind with
+    | Ptype_variant [{pcd_args = Pcstr_tuple [_]; _}]
+    | Ptype_variant [{pcd_args = Pcstr_record [{pld_mutable=Immutable; _}]; _}]
+    | Ptype_record [{pld_mutable=Immutable; _}] -> raw_status
+    | _ -> unboxed_false_default_false (* Not unboxable, mark as boxed *)
+  in
+  let unbox = unboxed_status.unboxed in
+  let (tkind, kind) =
+    match sdecl.ptype_kind with
+      | Ptype_abstract -> Ttype_abstract, Type_abstract
+      | Ptype_variant scstrs ->
+        if List.exists (fun cstr -> cstr.pcd_res <> None) scstrs then begin
+          match cstrs with
+            [] -> ()
+          | (_,_,loc)::_ ->
+              Location.prerr_warning loc Warnings.Constraint_on_gadt
+        end;
+        let all_constrs = ref String.Set.empty in
+        List.iter
+          (fun {pcd_name = {txt = name}} ->
+            if String.Set.mem name !all_constrs then
+              raise(Error(sdecl.ptype_loc, Duplicate_constructor name));
+            all_constrs := String.Set.add name !all_constrs)
+          scstrs;
+        if List.length
+            (List.filter (fun cd -> cd.pcd_args <> Pcstr_tuple []) scstrs)
+           > (Config.max_tag + 1) then
+          raise(Error(sdecl.ptype_loc, Too_many_constructors));
+        let make_cstr scstr =
+          let name = Ident.create_local scstr.pcd_name.txt in
+          let targs, tret_type, args, ret_type =
+            make_constructor env (Path.Pident id) params
+                             scstr.pcd_args scstr.pcd_res
+          in
+          let tcstr =
+            { cd_id = name;
+              cd_name = scstr.pcd_name;
+              cd_args = targs;
+              cd_res = tret_type;
+              cd_loc = scstr.pcd_loc;
+              cd_attributes = scstr.pcd_attributes }
+          in
+          let cstr =
+            { Types.cd_id = name;
+              cd_args = args;
+              cd_res = ret_type;
+              cd_loc = scstr.pcd_loc;
+              cd_attributes = scstr.pcd_attributes;
+              cd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) }
+          in
+            tcstr, cstr
+        in
+        let make_cstr scstr =
+          Builtin_attributes.warning_scope scstr.pcd_attributes
+            (fun () -> make_cstr scstr)
+        in
+        let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in
+          Ttype_variant tcstrs, Type_variant cstrs
+      | Ptype_record lbls ->
+          let lbls, lbls' = transl_labels env true lbls in
+          let rep =
+            if unbox then Record_unboxed false
+            else if List.for_all (fun l -> is_float env l.Types.ld_type) lbls'
+            then Record_float
+            else Record_regular
+          in
+          Ttype_record lbls, Type_record(lbls', rep)
+      | Ptype_open -> Ttype_open, Type_open
+      in
+    let (tman, man) = match sdecl.ptype_manifest with
+        None -> None, None
+      | Some sty ->
+        let no_row = not (is_fixed_type sdecl) in
+        let cty = transl_simple_type env no_row sty in
+        Some cty, Some cty.ctyp_type
+    in
+    let arity = List.length params in
+    let decl =
+      { type_params = params;
+        type_arity = arity;
+        type_kind = kind;
+        type_private = sdecl.ptype_private;
+        type_manifest = man;
+        type_variance = List.map (fun _ -> Variance.full) params;
+        type_separability = Types.Separability.default_signature ~arity;
+        type_is_newtype = false;
+        type_expansion_scope = Btype.lowest_level;
+        type_loc = sdecl.ptype_loc;
+        type_attributes = sdecl.ptype_attributes;
+        type_immediate = Unknown;
+        type_unboxed = unboxed_status;
+        type_uid = uid;
+      } in
+
+  (* Check constraints *)
+    List.iter
+      (fun (cty, cty', loc) ->
+        let ty = cty.ctyp_type in
+        let ty' = cty'.ctyp_type in
+        try Ctype.unify env ty ty' with Ctype.Unify tr ->
+          raise(Error(loc, Inconsistent_constraint (env, tr))))
+      cstrs;
+    Ctype.end_def ();
+  (* Add abstract row *)
+    if is_fixed_type sdecl then begin
+      let p, _ =
+        try Env.find_type_by_name
+              (Longident.Lident(Ident.name id ^ "#row")) env
+        with Not_found -> assert false
+      in
+      set_fixed_row env sdecl.ptype_loc p decl
+    end;
+  (* Check for cyclic abbreviations *)
+    begin match decl.type_manifest with None -> ()
+      | Some ty ->
+        if Ctype.cyclic_abbrev env id ty then
+          raise(Error(sdecl.ptype_loc, Recursive_abbrev sdecl.ptype_name.txt));
+    end;
+    {
+      typ_id = id;
+      typ_name = sdecl.ptype_name;
+      typ_params = tparams;
+      typ_type = decl;
+      typ_cstrs = cstrs;
+      typ_loc = sdecl.ptype_loc;
+      typ_manifest = tman;
+      typ_kind = tkind;
+      typ_private = sdecl.ptype_private;
+      typ_attributes = sdecl.ptype_attributes;
+    }
+
+(* Generalize a type declaration *)
+
+let generalize_decl decl =
+  List.iter Ctype.generalize decl.type_params;
+  Btype.iter_type_expr_kind Ctype.generalize decl.type_kind;
+  begin match decl.type_manifest with
+  | None    -> ()
+  | Some ty -> Ctype.generalize ty
+  end
+
+(* Check that all constraints are enforced *)
+
+module TypeSet = Btype.TypeSet
+module TypeMap = Btype.TypeMap
+
+let rec check_constraints_rec env loc visited ty =
+  let ty = Ctype.repr ty in
+  if TypeSet.mem ty !visited then () else begin
+  visited := TypeSet.add ty !visited;
+  match ty.desc with
+  | Tconstr (path, args, _) ->
+      let args' = List.map (fun _ -> Ctype.newvar ()) args in
+      let ty' = Ctype.newconstr path args' in
+      begin try Ctype.enforce_constraints env ty'
+      with Ctype.Unify _ -> assert false
+      | Not_found -> raise (Error(loc, Unavailable_type_constructor path))
+      end;
+      if not (Ctype.matches env ty ty') then
+        raise (Error(loc, Constraint_failed (ty, ty')));
+      List.iter (check_constraints_rec env loc visited) args
+  | Tpoly (ty, tl) ->
+      let _, ty = Ctype.instance_poly false tl ty in
+      check_constraints_rec env loc visited ty
+  | _ ->
+      Btype.iter_type_expr (check_constraints_rec env loc visited) ty
+  end
+
+let check_constraints_labels env visited l pl =
+  let rec get_loc name = function
+      [] -> assert false
+    | pld :: tl ->
+        if name = pld.pld_name.txt then pld.pld_type.ptyp_loc
+        else get_loc name tl
+  in
+  List.iter
+    (fun {Types.ld_id=name; ld_type=ty} ->
+       check_constraints_rec env (get_loc (Ident.name name) pl) visited ty)
+    l
+
+let check_constraints env sdecl (_, decl) =
+  let visited = ref TypeSet.empty in
+  begin match decl.type_kind with
+  | Type_abstract -> ()
+  | Type_variant l ->
+      let find_pl = function
+          Ptype_variant pl -> pl
+        | Ptype_record _ | Ptype_abstract | Ptype_open -> assert false
+      in
+      let pl = find_pl sdecl.ptype_kind in
+      let pl_index =
+        let foldf acc x =
+          String.Map.add x.pcd_name.txt x acc
+        in
+        List.fold_left foldf String.Map.empty pl
+      in
+      List.iter
+        (fun {Types.cd_id=name; cd_args; cd_res} ->
+          let {pcd_args; pcd_res; _} =
+            try String.Map.find (Ident.name name) pl_index
+            with Not_found -> assert false in
+          begin match cd_args, pcd_args with
+          | Cstr_tuple tyl, Pcstr_tuple styl ->
+              List.iter2
+                (fun sty ty ->
+                   check_constraints_rec env sty.ptyp_loc visited ty)
+                styl tyl
+          | Cstr_record tyl, Pcstr_record styl ->
+              check_constraints_labels env visited tyl styl
+          | _ -> assert false
+          end;
+          match pcd_res, cd_res with
+          | Some sr, Some r ->
+              check_constraints_rec env sr.ptyp_loc visited r
+          | _ ->
+              () )
+        l
+  | Type_record (l, _) ->
+      let find_pl = function
+          Ptype_record pl -> pl
+        | Ptype_variant _ | Ptype_abstract | Ptype_open -> assert false
+      in
+      let pl = find_pl sdecl.ptype_kind in
+      check_constraints_labels env visited l pl
+  | Type_open -> ()
+  end;
+  begin match decl.type_manifest with
+  | None -> ()
+  | Some ty ->
+      let sty =
+        match sdecl.ptype_manifest with Some sty -> sty | _ -> assert false
+      in
+      check_constraints_rec env sty.ptyp_loc visited ty
+  end
+
+(*
+   If both a variant/record definition and a type equation are given,
+   need to check that the equation refers to a type of the same kind
+   with the same constructors and labels.
+*)
+let check_coherence env loc dpath decl =
+  match decl with
+    { type_kind = (Type_variant _ | Type_record _| Type_open);
+      type_manifest = Some ty } ->
+      begin match (Ctype.repr ty).desc with
+        Tconstr(path, args, _) ->
+          begin try
+            let decl' = Env.find_type path env in
+            let err =
+              if List.length args <> List.length decl.type_params
+              then Some Includecore.Arity
+              else if not (Ctype.equal env false args decl.type_params)
+              then Some Includecore.Constraint
+              else
+                Includecore.type_declarations ~loc ~equality:true env
+                  ~mark:true
+                  (Path.last path)
+                  decl'
+                  dpath
+                  (Subst.type_declaration
+                     (Subst.add_type_path dpath path Subst.identity) decl)
+            in
+            if err <> None then
+              raise(Error(loc, Definition_mismatch (ty, err)))
+          with Not_found ->
+            raise(Error(loc, Unavailable_type_constructor path))
+          end
+      | _ -> raise(Error(loc, Definition_mismatch (ty, None)))
+      end
+  | _ -> ()
+
+let check_abbrev env sdecl (id, decl) =
+  check_coherence env sdecl.ptype_loc (Path.Pident id) decl
+
+(* Check that recursion is well-founded *)
+
+let check_well_founded env loc path to_check ty =
+  let visited = ref TypeMap.empty in
+  let rec check ty0 parents ty =
+    let ty = Btype.repr ty in
+    if TypeSet.mem ty parents then begin
+      (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*)
+      if match ty0.desc with
+      | Tconstr (p, _, _) -> Path.same p path
+      | _ -> false
+      then raise (Error (loc, Recursive_abbrev (Path.name path)))
+      else raise (Error (loc, Cycle_in_def (Path.name path, ty0)))
+    end;
+    let (fini, parents) =
+      try
+        let prev = TypeMap.find ty !visited in
+        if TypeSet.subset parents prev then (true, parents) else
+        (false, TypeSet.union parents prev)
+      with Not_found ->
+        (false, parents)
+    in
+    if fini then () else
+    let rec_ok =
+      match ty.desc with
+        Tconstr(p,_,_) ->
+          !Clflags.recursive_types && Ctype.is_contractive env p
+      | Tobject _ | Tvariant _ -> true
+      | _ -> !Clflags.recursive_types
+    in
+    let visited' = TypeMap.add ty parents !visited in
+    let arg_exn =
+      try
+        visited := visited';
+        let parents =
+          if rec_ok then TypeSet.empty else TypeSet.add ty parents in
+        Btype.iter_type_expr (check ty0 parents) ty;
+        None
+      with e ->
+        visited := visited'; Some e
+    in
+    match ty.desc with
+    | Tconstr(p, _, _) when arg_exn <> None || to_check p ->
+        if to_check p then Option.iter raise arg_exn
+        else Btype.iter_type_expr (check ty0 TypeSet.empty) ty;
+        begin try
+          let ty' = Ctype.try_expand_once_opt env ty in
+          let ty0 = if TypeSet.is_empty parents then ty else ty0 in
+          check ty0 (TypeSet.add ty parents) ty'
+        with
+          Ctype.Cannot_expand -> Option.iter raise arg_exn
+        end
+    | _ -> Option.iter raise arg_exn
+  in
+  let snap = Btype.snapshot () in
+  try Ctype.wrap_trace_gadt_instances env (check ty TypeSet.empty) ty
+  with Ctype.Unify _ ->
+    (* Will be detected by check_recursion *)
+    Btype.backtrack snap
+
+let check_well_founded_manifest env loc path decl =
+  if decl.type_manifest = None then () else
+  let args = List.map (fun _ -> Ctype.newvar()) decl.type_params in
+  check_well_founded env loc path (Path.same path) (Ctype.newconstr path args)
+
+let check_well_founded_decl env loc path decl to_check =
+  let open Btype in
+  let it =
+    {type_iterators with
+     it_type_expr = (fun _ -> check_well_founded env loc path to_check)} in
+  it.it_type_declaration it (Ctype.generic_instance_declaration decl)
+
+(* Check for ill-defined abbrevs *)
+
+let check_recursion env loc path decl to_check =
+  (* to_check is true for potentially mutually recursive paths.
+     (path, decl) is the type declaration to be checked. *)
+
+  if decl.type_params = [] then () else
+
+  let visited = ref [] in
+
+  let rec check_regular cpath args prev_exp prev_expansions ty =
+    let ty = Ctype.repr ty in
+    if not (List.memq ty !visited) then begin
+      visited := ty :: !visited;
+      match ty.desc with
+      | Tconstr(path', args', _) ->
+          if Path.same path path' then begin
+            if not (Ctype.equal env false args args') then
+              raise (Error(loc,
+                     Non_regular {
+                       definition=path;
+                       used_as=ty;
+                       defined_as=Ctype.newconstr path args;
+                       expansions=List.rev prev_expansions;
+                     }))
+          end
+          (* Attempt to expand a type abbreviation if:
+              1- [to_check path'] holds
+                 (otherwise the expansion cannot involve [path]);
+              2- we haven't expanded this type constructor before
+                 (otherwise we could loop if [path'] is itself
+                 a non-regular abbreviation). *)
+          else if to_check path' && not (List.mem path' prev_exp) then begin
+            try
+              (* Attempt expansion *)
+              let (params0, body0, _) = Env.find_type_expansion path' env in
+              let (params, body) =
+                Ctype.instance_parameterized_type params0 body0 in
+              begin
+                try List.iter2 (Ctype.unify env) params args'
+                with Ctype.Unify _ ->
+                  raise (Error(loc, Constraint_failed
+                                 (ty, Ctype.newconstr path' params0)));
+              end;
+              check_regular path' args
+                (path' :: prev_exp) ((ty,body) :: prev_expansions)
+                body
+            with Not_found -> ()
+          end;
+          List.iter (check_regular cpath args prev_exp prev_expansions) args'
+      | Tpoly (ty, tl) ->
+          let (_, ty) = Ctype.instance_poly ~keep_names:true false tl ty in
+          check_regular cpath args prev_exp prev_expansions ty
+      | _ ->
+          Btype.iter_type_expr
+            (check_regular cpath args prev_exp prev_expansions) ty
+    end in
+
+  Option.iter
+    (fun body ->
+      let (args, body) =
+        Ctype.instance_parameterized_type
+          ~keep_names:true decl.type_params body in
+      check_regular path args [] [] body)
+    decl.type_manifest
+
+let check_abbrev_recursion env id_loc_list to_check tdecl =
+  let decl = tdecl.typ_type in
+  let id = tdecl.typ_id in
+  check_recursion env (List.assoc id id_loc_list) (Path.Pident id) decl to_check
+
+let check_duplicates sdecl_list =
+  let labels = Hashtbl.create 7 and constrs = Hashtbl.create 7 in
+  List.iter
+    (fun sdecl -> match sdecl.ptype_kind with
+      Ptype_variant cl ->
+        List.iter
+          (fun pcd ->
+            try
+              let name' = Hashtbl.find constrs pcd.pcd_name.txt in
+              Location.prerr_warning pcd.pcd_loc
+                (Warnings.Duplicate_definitions
+                   ("constructor", pcd.pcd_name.txt, name',
+                    sdecl.ptype_name.txt))
+            with Not_found ->
+              Hashtbl.add constrs pcd.pcd_name.txt sdecl.ptype_name.txt)
+          cl
+    | Ptype_record fl ->
+        List.iter
+          (fun {pld_name=cname;pld_loc=loc} ->
+            try
+              let name' = Hashtbl.find labels cname.txt in
+              Location.prerr_warning loc
+                (Warnings.Duplicate_definitions
+                   ("label", cname.txt, name', sdecl.ptype_name.txt))
+            with Not_found -> Hashtbl.add labels cname.txt sdecl.ptype_name.txt)
+          fl
+    | Ptype_abstract -> ()
+    | Ptype_open -> ())
+    sdecl_list
+
+(* Force recursion to go through id for private types*)
+let name_recursion sdecl id decl =
+  match decl with
+  | { type_kind = Type_abstract;
+      type_manifest = Some ty;
+      type_private = Private; } when is_fixed_type sdecl ->
+    let ty = Ctype.repr ty in
+    let ty' = Btype.newty2 ty.level ty.desc in
+    if Ctype.deep_occur ty ty' then
+      let td = Tconstr(Path.Pident id, decl.type_params, ref Mnil) in
+      Btype.link_type ty (Btype.newty2 ty.level td);
+      {decl with type_manifest = Some ty'}
+    else decl
+  | _ -> decl
+
+let name_recursion_decls sdecls decls =
+  List.map2 (fun sdecl (id, decl) -> (id, name_recursion sdecl id decl))
+    sdecls decls
+
+(* Warn on definitions of type "type foo = ()" which redefine a different unit
+   type and are likely a mistake. *)
+let check_redefined_unit (td: Parsetree.type_declaration) =
+  let open Parsetree in
+  let is_unit_constructor cd = cd.pcd_name.txt = "()" in
+  match td with
+  | { ptype_name = { txt = name };
+      ptype_manifest = None;
+      ptype_kind = Ptype_variant [ cd ] }
+    when is_unit_constructor cd ->
+      Location.prerr_warning td.ptype_loc (Warnings.Redefining_unit name)
+  | _ ->
+      ()
+
+let add_types_to_env decls env =
+  List.fold_right
+    (fun (id, decl) env -> add_type ~check:true id decl env)
+    decls env
+
+(* Translate a set of type declarations, mutually recursive or not *)
+let transl_type_decl env rec_flag sdecl_list =
+  List.iter check_redefined_unit sdecl_list;
+  (* Add dummy types for fixed rows *)
+  let fixed_types = List.filter is_fixed_type sdecl_list in
+  let sdecl_list =
+    List.map
+      (fun sdecl ->
+         let ptype_name =
+           let loc = { sdecl.ptype_name.loc with Location.loc_ghost = true } in
+           mkloc (sdecl.ptype_name.txt ^"#row") loc
+         in
+         let ptype_kind = Ptype_abstract in
+         let ptype_manifest = None in
+         let ptype_loc = { sdecl.ptype_loc with Location.loc_ghost = true } in
+        {sdecl with
+           ptype_name; ptype_kind; ptype_manifest; ptype_loc })
+      fixed_types
+    @ sdecl_list
+  in
+
+  (* Create identifiers. *)
+  let scope = Ctype.create_scope () in
+  let ids_list =
+    List.map (fun sdecl ->
+      Ident.create_scoped ~scope sdecl.ptype_name.txt,
+      Uid.mk ~current_unit:(Env.get_unit_name ())
+    ) sdecl_list
+  in
+  Ctype.begin_def();
+  (* Enter types. *)
+  let temp_env =
+    List.fold_left2 (enter_type rec_flag) env sdecl_list ids_list in
+  (* Translate each declaration. *)
+  let current_slot = ref None in
+  let warn_unused = Warnings.is_active (Warnings.Unused_type_declaration "") in
+  let ids_slots (id, _uid as ids) =
+    match rec_flag with
+    | Asttypes.Recursive when warn_unused ->
+        (* See typecore.ml for a description of the algorithm used
+             to detect unused declarations in a set of recursive definitions. *)
+        let slot = ref [] in
+        let td = Env.find_type (Path.Pident id) temp_env in
+        Env.set_type_used_callback
+          td
+          (fun old_callback ->
+             match !current_slot with
+             | Some slot -> slot := td.type_uid :: !slot
+             | None ->
+                 List.iter Env.mark_type_used (get_ref slot);
+                 old_callback ()
+          );
+        ids, Some slot
+    | Asttypes.Recursive | Asttypes.Nonrecursive ->
+        ids, None
+  in
+  let transl_declaration name_sdecl (id, slot) =
+    current_slot := slot;
+    Builtin_attributes.warning_scope
+      name_sdecl.ptype_attributes
+      (fun () -> transl_declaration temp_env name_sdecl id)
+  in
+  let tdecls =
+    List.map2 transl_declaration sdecl_list (List.map ids_slots ids_list) in
+  let decls =
+    List.map (fun tdecl -> (tdecl.typ_id, tdecl.typ_type)) tdecls in
+  current_slot := None;
+  (* Check for duplicates *)
+  check_duplicates sdecl_list;
+  (* Build the final env. *)
+  let new_env = add_types_to_env decls env in
+  (* Update stubs *)
+  begin match rec_flag with
+    | Asttypes.Nonrecursive -> ()
+    | Asttypes.Recursive ->
+      List.iter2
+        (fun (id, _) sdecl -> update_type temp_env new_env id sdecl.ptype_loc)
+        ids_list sdecl_list
+  end;
+  (* Generalize type declarations. *)
+  Ctype.end_def();
+  List.iter (fun (_, decl) -> generalize_decl decl) decls;
+  (* Check for ill-formed abbrevs *)
+  let id_loc_list =
+    List.map2 (fun (id, _) sdecl -> (id, sdecl.ptype_loc))
+      ids_list sdecl_list
+  in
+  List.iter (fun (id, decl) ->
+    check_well_founded_manifest new_env (List.assoc id id_loc_list)
+      (Path.Pident id) decl)
+    decls;
+  let to_check =
+    function Path.Pident id -> List.mem_assoc id id_loc_list | _ -> false in
+  List.iter (fun (id, decl) ->
+    check_well_founded_decl new_env (List.assoc id id_loc_list) (Path.Pident id)
+      decl to_check)
+    decls;
+  List.iter (check_abbrev_recursion new_env id_loc_list to_check) tdecls;
+  (* Check that all type variables are closed *)
+  List.iter2
+    (fun sdecl tdecl ->
+      let decl = tdecl.typ_type in
+       match Ctype.closed_type_decl decl with
+         Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl)))
+       | None   -> ())
+    sdecl_list tdecls;
+  (* Check that constraints are enforced *)
+  List.iter2 (check_constraints new_env) sdecl_list decls;
+  (* Add type properties to declarations *)
+  let decls =
+    try
+      decls
+      |> name_recursion_decls sdecl_list
+      |> Typedecl_variance.update_decls env sdecl_list
+      |> Typedecl_immediacy.update_decls env
+      |> Typedecl_separability.update_decls env
+    with
+    | Typedecl_variance.Error (loc, err) ->
+        raise (Error (loc, Variance err))
+    | Typedecl_immediacy.Error (loc, err) ->
+        raise (Error (loc, Immediacy err))
+    | Typedecl_separability.Error (loc, err) ->
+        raise (Error (loc, Separability err))
+  in
+  (* Compute the final environment with variance and immediacy *)
+  let final_env = add_types_to_env decls env in
+  (* Check re-exportation *)
+  List.iter2 (check_abbrev final_env) sdecl_list decls;
+  (* Keep original declaration *)
+  let final_decls =
+    List.map2
+      (fun tdecl (_id2, decl) ->
+        { tdecl with typ_type = decl }
+      ) tdecls decls
+  in
+  (* Done *)
+  (final_decls, final_env)
+
+(* Translating type extensions *)
+
+let transl_extension_constructor env type_path type_params
+                                 typext_params priv sext =
+  let scope = Ctype.create_scope () in
+  let id = Ident.create_scoped ~scope sext.pext_name.txt in
+  let args, ret_type, kind =
+    match sext.pext_kind with
+      Pext_decl(sargs, sret_type) ->
+        let targs, tret_type, args, ret_type =
+          make_constructor env type_path typext_params
+            sargs sret_type
+        in
+          args, ret_type, Text_decl(targs, tret_type)
+    | Pext_rebind lid ->
+        let usage = if priv = Public then Env.Positive else Env.Privatize in
+        let cdescr = Env.lookup_constructor ~loc:lid.loc usage lid.txt env in
+        let (args, cstr_res) = Ctype.instance_constructor cdescr in
+        let res, ret_type =
+          if cdescr.cstr_generalized then
+            let params = Ctype.instance_list type_params in
+            let res = Ctype.newconstr type_path params in
+            let ret_type = Some (Ctype.newconstr type_path params) in
+              res, ret_type
+          else (Ctype.newconstr type_path typext_params), None
+        in
+        begin
+          try
+            Ctype.unify env cstr_res res
+          with Ctype.Unify trace ->
+            raise (Error(lid.loc,
+                     Rebind_wrong_type(lid.txt, env, trace)))
+        end;
+        (* Remove "_" names from parameters used in the constructor *)
+        if not cdescr.cstr_generalized then begin
+          let vars =
+            Ctype.free_variables (Btype.newgenty (Ttuple args))
+          in
+            List.iter
+              (function {desc = Tvar (Some "_")} as ty ->
+                          if List.memq ty vars then ty.desc <- Tvar None
+                        | _ -> ())
+              typext_params
+        end;
+        (* Ensure that constructor's type matches the type being extended *)
+        let cstr_type_path, cstr_type_params =
+          match cdescr.cstr_res.desc with
+            Tconstr (p, _, _) ->
+              let decl = Env.find_type p env in
+                p, decl.type_params
+          | _ -> assert false
+        in
+        let cstr_types =
+          (Btype.newgenty
+             (Tconstr(cstr_type_path, cstr_type_params, ref Mnil)))
+          :: cstr_type_params
+        in
+        let ext_types =
+          (Btype.newgenty
+             (Tconstr(type_path, type_params, ref Mnil)))
+          :: type_params
+        in
+        if not (Ctype.equal env true cstr_types ext_types) then
+          raise (Error(lid.loc,
+                       Rebind_mismatch(lid.txt, cstr_type_path, type_path)));
+        (* Disallow rebinding private constructors to non-private *)
+        begin
+          match cdescr.cstr_private, priv with
+            Private, Public ->
+              raise (Error(lid.loc, Rebind_private lid.txt))
+          | _ -> ()
+        end;
+        let path =
+          match cdescr.cstr_tag with
+            Cstr_extension(path, _) -> path
+          | _ -> assert false
+        in
+        let args =
+          match cdescr.cstr_inlined with
+          | None ->
+              Types.Cstr_tuple args
+          | Some decl ->
+              let tl =
+                match args with
+                | [ {desc=Tconstr(_, tl, _)} ] -> tl
+                | _ -> assert false
+              in
+              let decl = Ctype.instance_declaration decl in
+              assert (List.length decl.type_params = List.length tl);
+              List.iter2 (Ctype.unify env) decl.type_params tl;
+              let lbls =
+                match decl.type_kind with
+                | Type_record (lbls, Record_extension _) -> lbls
+                | _ -> assert false
+              in
+              Types.Cstr_record lbls
+        in
+        args, ret_type, Text_rebind(path, lid)
+  in
+  let ext =
+    { ext_type_path = type_path;
+      ext_type_params = typext_params;
+      ext_args = args;
+      ext_ret_type = ret_type;
+      ext_private = priv;
+      Types.ext_loc = sext.pext_loc;
+      Types.ext_attributes = sext.pext_attributes;
+      ext_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+    }
+  in
+    { ext_id = id;
+      ext_name = sext.pext_name;
+      ext_type = ext;
+      ext_kind = kind;
+      Typedtree.ext_loc = sext.pext_loc;
+      Typedtree.ext_attributes = sext.pext_attributes; }
+
+let transl_extension_constructor env type_path type_params
+    typext_params priv sext =
+  Builtin_attributes.warning_scope sext.pext_attributes
+    (fun () -> transl_extension_constructor env type_path type_params
+        typext_params priv sext)
+
+let is_rebind ext =
+  match ext.ext_kind with
+  | Text_rebind _ -> true
+  | Text_decl _ -> false
+
+let transl_type_extension extend env loc styext =
+  reset_type_variables();
+  Ctype.begin_def();
+  let type_path, type_decl =
+    let lid = styext.ptyext_path in
+    Env.lookup_type ~loc:lid.loc lid.txt env
+  in
+  begin
+    match type_decl.type_kind with
+    | Type_open -> begin
+        match type_decl.type_private with
+        | Private when extend -> begin
+            match
+              List.find
+                (function {pext_kind = Pext_decl _} -> true
+                        | {pext_kind = Pext_rebind _} -> false)
+                styext.ptyext_constructors
+            with
+            | {pext_loc} ->
+                raise (Error(pext_loc, Cannot_extend_private_type type_path))
+            | exception Not_found -> ()
+          end
+        | _ -> ()
+      end
+    | _ ->
+        raise (Error(loc, Not_extensible_type type_path))
+  end;
+  let type_variance =
+    List.map (fun v ->
+                let (co, cn) = Variance.get_upper v in
+                  (not cn, not co, false))
+             type_decl.type_variance
+  in
+  let err =
+    if type_decl.type_arity <> List.length styext.ptyext_params then
+      Some Includecore.Arity
+    else
+      if List.for_all2
+           (fun (c1, n1, _) (c2, n2, _) -> (not c2 || c1) && (not n2 || n1))
+           type_variance
+           (Typedecl_variance.variance_of_params styext.ptyext_params)
+      then None else Some Includecore.Variance
+  in
+  begin match err with
+  | None -> ()
+  | Some err -> raise (Error(loc, Extension_mismatch (type_path, err)))
+  end;
+  let ttype_params = make_params env styext.ptyext_params in
+  let type_params = List.map (fun (cty, _) -> cty.ctyp_type) ttype_params in
+  List.iter2 (Ctype.unify_var env)
+    (Ctype.instance_list type_decl.type_params)
+    type_params;
+  let constructors =
+    List.map (transl_extension_constructor env type_path
+               type_decl.type_params type_params styext.ptyext_private)
+      styext.ptyext_constructors
+  in
+  Ctype.end_def();
+  (* Generalize types *)
+  List.iter Ctype.generalize type_params;
+  List.iter
+    (fun ext ->
+       Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args;
+       Option.iter Ctype.generalize ext.ext_type.ext_ret_type)
+    constructors;
+  (* Check that all type variables are closed *)
+  List.iter
+    (fun ext ->
+       match Ctype.closed_extension_constructor ext.ext_type with
+         Some ty ->
+           raise(Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type)))
+       | None -> ())
+    constructors;
+  (* Check variances are correct *)
+  List.iter
+    (fun ext->
+       (* Note that [loc] here is distinct from [type_decl.type_loc], which
+          makes the [loc] parameter to this function useful. [loc] is the
+          location of the extension, while [type_decl] points to the original
+          type declaration being extended. *)
+       try Typedecl_variance.check_variance_extension
+             env type_decl ext (type_variance, loc)
+       with Typedecl_variance.Error (loc, err) ->
+         raise (Error (loc, Variance err)))
+    constructors;
+  (* Add extension constructors to the environment *)
+  let newenv =
+    List.fold_left
+      (fun env ext ->
+         let rebind = is_rebind ext in
+         Env.add_extension ~check:true ~rebind ext.ext_id ext.ext_type env)
+      env constructors
+  in
+  let tyext =
+    { tyext_path = type_path;
+      tyext_txt = styext.ptyext_path;
+      tyext_params = ttype_params;
+      tyext_constructors = constructors;
+      tyext_private = styext.ptyext_private;
+      tyext_loc = styext.ptyext_loc;
+      tyext_attributes = styext.ptyext_attributes; }
+  in
+    (tyext, newenv)
+
+let transl_type_extension extend env loc styext =
+  Builtin_attributes.warning_scope styext.ptyext_attributes
+    (fun () -> transl_type_extension extend env loc styext)
+
+let transl_exception env sext =
+  reset_type_variables();
+  Ctype.begin_def();
+  let ext =
+    transl_extension_constructor env
+      Predef.path_exn [] [] Asttypes.Public sext
+  in
+  Ctype.end_def();
+  (* Generalize types *)
+  Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args;
+  Option.iter Ctype.generalize ext.ext_type.ext_ret_type;
+  (* Check that all type variables are closed *)
+  begin match Ctype.closed_extension_constructor ext.ext_type with
+    Some ty ->
+      raise (Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type)))
+  | None -> ()
+  end;
+  let rebind = is_rebind ext in
+  let newenv =
+    Env.add_extension ~check:true ~rebind ext.ext_id ext.ext_type env
+  in
+  ext, newenv
+
+let transl_type_exception env t =
+  Builtin_attributes.check_no_alert t.ptyexn_attributes;
+  let contructor, newenv =
+    Builtin_attributes.warning_scope t.ptyexn_attributes
+      (fun () ->
+         transl_exception env t.ptyexn_constructor
+      )
+  in
+  {tyexn_constructor = contructor;
+   tyexn_loc = t.ptyexn_loc;
+   tyexn_attributes = t.ptyexn_attributes}, newenv
+
+
+type native_repr_attribute =
+  | Native_repr_attr_absent
+  | Native_repr_attr_present of native_repr_kind
+
+let get_native_repr_attribute attrs ~global_repr =
+  match
+    Attr_helper.get_no_payload_attribute ["unboxed"; "ocaml.unboxed"]  attrs,
+    Attr_helper.get_no_payload_attribute ["untagged"; "ocaml.untagged"] attrs,
+    global_repr
+  with
+  | None, None, None -> Native_repr_attr_absent
+  | None, None, Some repr -> Native_repr_attr_present repr
+  | Some _, None, None -> Native_repr_attr_present Unboxed
+  | None, Some _, None -> Native_repr_attr_present Untagged
+  | Some { Location.loc }, _, _
+  | _, Some { Location.loc }, _ ->
+    raise (Error (loc, Multiple_native_repr_attributes))
+
+let native_repr_of_type env kind ty =
+  match kind, (Ctype.expand_head_opt env ty).desc with
+  | Untagged, Tconstr (path, _, _) when Path.same path Predef.path_int ->
+    Some Untagged_int
+  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_float ->
+    Some Unboxed_float
+  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int32 ->
+    Some (Unboxed_integer Pint32)
+  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int64 ->
+    Some (Unboxed_integer Pint64)
+  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_nativeint ->
+    Some (Unboxed_integer Pnativeint)
+  | _ ->
+    None
+
+(* Raises an error when [core_type] contains an [@unboxed] or [@untagged]
+   attribute in a strict sub-term. *)
+let error_if_has_deep_native_repr_attributes core_type =
+  let open Ast_iterator in
+  let this_iterator =
+    { default_iterator with typ = fun iterator core_type ->
+      begin
+        match
+          get_native_repr_attribute core_type.ptyp_attributes ~global_repr:None
+        with
+        | Native_repr_attr_present kind ->
+           raise (Error (core_type.ptyp_loc,
+                         Deep_unbox_or_untag_attribute kind))
+        | Native_repr_attr_absent -> ()
+      end;
+      default_iterator.typ iterator core_type }
+  in
+  default_iterator.typ this_iterator core_type
+
+let make_native_repr env core_type ty ~global_repr =
+  error_if_has_deep_native_repr_attributes core_type;
+  match get_native_repr_attribute core_type.ptyp_attributes ~global_repr with
+  | Native_repr_attr_absent ->
+    Same_as_ocaml_repr
+  | Native_repr_attr_present kind ->
+    begin match native_repr_of_type env kind ty with
+    | None ->
+      raise (Error (core_type.ptyp_loc, Cannot_unbox_or_untag_type kind))
+    | Some repr -> repr
+    end
+
+let rec parse_native_repr_attributes env core_type ty ~global_repr =
+  match core_type.ptyp_desc, (Ctype.repr ty).desc,
+    get_native_repr_attribute core_type.ptyp_attributes ~global_repr:None
+  with
+  | Ptyp_arrow _, Tarrow _, Native_repr_attr_present kind  ->
+    raise (Error (core_type.ptyp_loc, Cannot_unbox_or_untag_type kind))
+  | Ptyp_arrow (_, ct1, ct2), Tarrow (_, t1, t2, _), _ ->
+    let repr_arg = make_native_repr env ct1 t1 ~global_repr in
+    let repr_args, repr_res =
+      parse_native_repr_attributes env ct2 t2 ~global_repr
+    in
+    (repr_arg :: repr_args, repr_res)
+  | Ptyp_arrow _, _, _ | _, Tarrow _, _ -> assert false
+  | _ -> ([], make_native_repr env core_type ty ~global_repr)
+
+
+let check_unboxable env loc ty =
+  let check_type acc ty : Path.Set.t =
+    let ty = Ctype.repr (Ctype.expand_head_opt env ty) in
+    try match ty.desc with
+      | Tconstr (p, _, _) ->
+        let tydecl = Env.find_type p env in
+        if tydecl.type_unboxed.default then
+          Path.Set.add p acc
+        else acc
+      | _ -> acc
+    with Not_found -> acc
+  in
+  let all_unboxable_types = Btype.fold_type_expr check_type Path.Set.empty ty in
+  Path.Set.fold
+    (fun p () ->
+       Location.prerr_warning loc
+         (Warnings.Unboxable_type_in_prim_decl (Path.name p))
+    )
+    all_unboxable_types
+    ()
+
+(* Translate a value declaration *)
+let transl_value_decl env loc valdecl =
+  let cty = Typetexp.transl_type_scheme env valdecl.pval_type in
+  let ty = cty.ctyp_type in
+  let v =
+  match valdecl.pval_prim with
+    [] when Env.is_in_signature env ->
+      { val_type = ty; val_kind = Val_reg; Types.val_loc = loc;
+        val_attributes = valdecl.pval_attributes;
+        val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+      }
+  | [] ->
+      raise (Error(valdecl.pval_loc, Val_in_structure))
+  | _ ->
+      let global_repr =
+        match
+          get_native_repr_attribute valdecl.pval_attributes ~global_repr:None
+        with
+        | Native_repr_attr_present repr -> Some repr
+        | Native_repr_attr_absent -> None
+      in
+      let native_repr_args, native_repr_res =
+        parse_native_repr_attributes env valdecl.pval_type ty ~global_repr
+      in
+      let prim =
+        Primitive.parse_declaration valdecl
+          ~native_repr_args
+          ~native_repr_res
+      in
+      if prim.prim_arity = 0 &&
+         (prim.prim_name = "" || prim.prim_name.[0] <> '%') then
+        raise(Error(valdecl.pval_type.ptyp_loc, Null_arity_external));
+      if !Clflags.native_code
+      && prim.prim_arity > 5
+      && prim.prim_native_name = ""
+      then raise(Error(valdecl.pval_type.ptyp_loc, Missing_native_external));
+      check_unboxable env loc ty;
+      { val_type = ty; val_kind = Val_prim prim; Types.val_loc = loc;
+        val_attributes = valdecl.pval_attributes;
+        val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+      }
+  in
+  let (id, newenv) =
+    Env.enter_value valdecl.pval_name.txt v env
+      ~check:(fun s -> Warnings.Unused_value_declaration s)
+  in
+  let desc =
+    {
+     val_id = id;
+     val_name = valdecl.pval_name;
+     val_desc = cty; val_val = v;
+     val_prim = valdecl.pval_prim;
+     val_loc = valdecl.pval_loc;
+     val_attributes = valdecl.pval_attributes;
+    }
+  in
+  desc, newenv
+
+let transl_value_decl env loc valdecl =
+  Builtin_attributes.warning_scope valdecl.pval_attributes
+    (fun () -> transl_value_decl env loc valdecl)
+
+(* Translate a "with" constraint -- much simplified version of
+   transl_type_decl. For a constraint [Sig with t = sdecl],
+   there are two declarations of interest in two environments:
+   - [sig_decl] is the declaration of [t] in [Sig],
+     in the environment [sig_env] (containing the declarations
+     of [Sig] before [t])
+   - [sdecl] is the new syntactic declaration, to be type-checked
+     in the current, outer environment [with_env].
+
+   In particular, note that [sig_env] is an extension of
+   [outer_env].
+*)
+let transl_with_constraint id row_path ~sig_env ~sig_decl ~outer_env sdecl =
+  Env.mark_type_used sig_decl.type_uid;
+  reset_type_variables();
+  Ctype.begin_def();
+  (* In the first part of this function, we typecheck the syntactic
+     declaration [sdecl] in the outer environment [outer_env]. *)
+  let env = outer_env in
+  let loc = sdecl.ptype_loc in
+  let tparams = make_params env sdecl.ptype_params in
+  let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in
+  let arity = List.length params in
+  let constraints =
+    List.map (fun (ty, ty', loc) ->
+      let cty = transl_simple_type env false ty in
+      let cty' = transl_simple_type env false ty' in
+      (* Note: We delay the unification of those constraints
+         after the unification of parameters, so that clashing
+         constraints report an error on the constraint location
+         rather than the parameter location. *)
+      (cty, cty', loc)
+    ) sdecl.ptype_cstrs
+  in
+  let no_row = not (is_fixed_type sdecl) in
+  let (tman, man) =  match sdecl.ptype_manifest with
+      None -> None, None
+    | Some sty ->
+        let cty = transl_simple_type env no_row sty in
+        Some cty, Some cty.ctyp_type
+  in
+  (* In the second part, we check the consistency between the two
+     declarations and compute a "merged" declaration; we now need to
+     work in the larger signature environment [sig_env], because
+     [sig_decl.type_params] and [sig_decl.type_kind] are only valid
+     there. *)
+  let env = sig_env in
+  let sig_decl = Ctype.instance_declaration sig_decl in
+  let arity_ok = arity = sig_decl.type_arity in
+  if arity_ok then
+    List.iter2 (fun (cty, _) tparam ->
+      try Ctype.unify_var env cty.ctyp_type tparam
+      with Ctype.Unify tr ->
+        raise(Error(cty.ctyp_loc, Inconsistent_constraint (env, tr)))
+    ) tparams sig_decl.type_params;
+  List.iter (fun (cty, cty', loc) ->
+    (* Note: contraints must also be enforced in [sig_env] because
+       they may contain parameter variables from [tparams]
+       that have now be unified in [sig_env]. *)
+    try Ctype.unify env cty.ctyp_type cty'.ctyp_type
+    with Ctype.Unify tr ->
+      raise(Error(loc, Inconsistent_constraint (env, tr)))
+  ) constraints;
+  let priv =
+    if sdecl.ptype_private = Private then Private else
+    if arity_ok && sig_decl.type_kind <> Type_abstract
+    then sig_decl.type_private else sdecl.ptype_private
+  in
+  if arity_ok && sig_decl.type_kind <> Type_abstract
+  && sdecl.ptype_private = Private then
+    Location.deprecated loc "spurious use of private";
+  let type_kind, type_unboxed =
+    if arity_ok && man <> None then
+      sig_decl.type_kind, sig_decl.type_unboxed
+    else
+      Type_abstract, unboxed_false_default_false
+  in
+  let new_sig_decl =
+    { type_params = params;
+      type_arity = arity;
+      type_kind;
+      type_private = priv;
+      type_manifest = man;
+      type_variance = [];
+      type_separability = Types.Separability.default_signature ~arity;
+      type_is_newtype = false;
+      type_expansion_scope = Btype.lowest_level;
+      type_loc = loc;
+      type_attributes = sdecl.ptype_attributes;
+      type_immediate = Unknown;
+      type_unboxed;
+      type_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+    }
+  in
+  begin match row_path with None -> ()
+  | Some p -> set_fixed_row env loc p new_sig_decl
+  end;
+  begin match Ctype.closed_type_decl new_sig_decl with None -> ()
+  | Some ty -> raise(Error(loc, Unbound_type_var(ty, new_sig_decl)))
+  end;
+  let new_sig_decl = name_recursion sdecl id new_sig_decl in
+  let new_type_variance =
+    let required = Typedecl_variance.variance_of_sdecl sdecl in
+    try
+      Typedecl_variance.compute_decl env ~check:true new_sig_decl required
+    with Typedecl_variance.Error (loc, err) ->
+      raise (Error (loc, Variance err)) in
+  let new_type_immediate =
+    (* Typedecl_immediacy.compute_decl never raises *)
+    Typedecl_immediacy.compute_decl env new_sig_decl in
+  let new_type_separability =
+    try Typedecl_separability.compute_decl env new_sig_decl
+    with Typedecl_separability.Error (loc, err) ->
+      raise (Error (loc, Separability err)) in
+  let new_sig_decl =
+    (* we intentionally write this without a fragile { decl with ... }
+       to ensure that people adding new fields to type declarations
+       consider whether they need to recompute it here; for an example
+       of bug caused by the previous approach, see #9607 *)
+    {
+      type_params = new_sig_decl.type_params;
+      type_arity = new_sig_decl.type_arity;
+      type_kind = new_sig_decl.type_kind;
+      type_private = new_sig_decl.type_private;
+      type_manifest = new_sig_decl.type_manifest;
+      type_unboxed = new_sig_decl.type_unboxed;
+      type_is_newtype = new_sig_decl.type_is_newtype;
+      type_expansion_scope = new_sig_decl.type_expansion_scope;
+      type_loc = new_sig_decl.type_loc;
+      type_attributes = new_sig_decl.type_attributes;
+      type_uid = new_sig_decl.type_uid;
+
+      type_variance = new_type_variance;
+      type_immediate = new_type_immediate;
+      type_separability = new_type_separability;
+    } in
+  Ctype.end_def();
+  generalize_decl new_sig_decl;
+  {
+    typ_id = id;
+    typ_name = sdecl.ptype_name;
+    typ_params = tparams;
+    typ_type = new_sig_decl;
+    typ_cstrs = constraints;
+    typ_loc = loc;
+    typ_manifest = tman;
+    typ_kind = Ttype_abstract;
+    typ_private = sdecl.ptype_private;
+    typ_attributes = sdecl.ptype_attributes;
+  }
+
+(* Approximate a type declaration: just make all types abstract *)
+
+let abstract_type_decl arity =
+  let rec make_params n =
+    if n <= 0 then [] else Ctype.newvar() :: make_params (n-1) in
+  Ctype.begin_def();
+  let decl =
+    { type_params = make_params arity;
+      type_arity = arity;
+      type_kind = Type_abstract;
+      type_private = Public;
+      type_manifest = None;
+      type_variance = replicate_list Variance.full arity;
+      type_separability = Types.Separability.default_signature ~arity;
+      type_is_newtype = false;
+      type_expansion_scope = Btype.lowest_level;
+      type_loc = Location.none;
+      type_attributes = [];
+      type_immediate = Unknown;
+      type_unboxed = unboxed_false_default_false;
+      type_uid = Uid.internal_not_actually_unique;
+     } in
+  Ctype.end_def();
+  generalize_decl decl;
+  decl
+
+let approx_type_decl sdecl_list =
+  let scope = Ctype.create_scope () in
+  List.map
+    (fun sdecl ->
+      (Ident.create_scoped ~scope sdecl.ptype_name.txt,
+       abstract_type_decl (List.length sdecl.ptype_params)))
+    sdecl_list
+
+(* Variant of check_abbrev_recursion to check the well-formedness
+   conditions on type abbreviations defined within recursive modules. *)
+
+let check_recmod_typedecl env loc recmod_ids path decl =
+  (* recmod_ids is the list of recursively-defined module idents.
+     (path, decl) is the type declaration to be checked. *)
+  let to_check path = Path.exists_free recmod_ids path in
+  check_well_founded_decl env loc path decl to_check;
+  check_recursion env loc path decl to_check;
+  (* additionally check coherece, as one might build an incoherent signature,
+     and use it to build an incoherent module, cf. #7851 *)
+  check_coherence env loc path decl
+
+
+(**** Error report ****)
+
+open Format
+
+let explain_unbound_gen ppf tv tl typ kwd pr =
+  try
+    let ti = List.find (fun ti -> Ctype.deep_occur tv (typ ti)) tl in
+    let ty0 = (* Hack to force aliasing when needed *)
+      Btype.newgenty (Tobject(tv, ref None)) in
+    Printtyp.reset_and_mark_loops_list [typ ti; ty0];
+    fprintf ppf
+      ".@.@[<hov2>In %s@ %a@;<1 -2>the variable %a is unbound@]"
+      kwd pr ti Printtyp.marked_type_expr tv
+  with Not_found -> ()
+
+let explain_unbound ppf tv tl typ kwd lab =
+  explain_unbound_gen ppf tv tl typ kwd
+    (fun ppf ti ->
+       fprintf ppf "%s%a" (lab ti) Printtyp.marked_type_expr (typ ti)
+    )
+
+let explain_unbound_single ppf tv ty =
+  let trivial ty =
+    explain_unbound ppf tv [ty] (fun t -> t) "type" (fun _ -> "") in
+  match (Ctype.repr ty).desc with
+    Tobject(fi,_) ->
+      let (tl, rv) = Ctype.flatten_fields fi in
+      if rv == tv then trivial ty else
+      explain_unbound ppf tv tl (fun (_,_,t) -> t)
+        "method" (fun (lab,_,_) -> lab ^ ": ")
+  | Tvariant row ->
+      let row = Btype.row_repr row in
+      if row.row_more == tv then trivial ty else
+      explain_unbound ppf tv row.row_fields
+        (fun (_l,f) -> match Btype.row_field_repr f with
+          Rpresent (Some t) -> t
+        | Reither (_,[t],_,_) -> t
+        | Reither (_,tl,_,_) -> Btype.newgenty (Ttuple tl)
+        | _ -> Btype.newgenty (Ttuple[]))
+        "case" (fun (lab,_) -> "`" ^ lab ^ " of ")
+  | _ -> trivial ty
+
+
+let tys_of_constr_args = function
+  | Types.Cstr_tuple tl -> tl
+  | Types.Cstr_record lbls -> List.map (fun l -> l.Types.ld_type) lbls
+
+let report_error ppf = function
+  | Repeated_parameter ->
+      fprintf ppf "A type parameter occurs several times"
+  | Duplicate_constructor s ->
+      fprintf ppf "Two constructors are named %s" s
+  | Too_many_constructors ->
+      fprintf ppf
+        "@[Too many non-constant constructors@ -- maximum is %i %s@]"
+        (Config.max_tag + 1) "non-constant constructors"
+  | Duplicate_label s ->
+      fprintf ppf "Two labels are named %s" s
+  | Recursive_abbrev s ->
+      fprintf ppf "The type abbreviation %s is cyclic" s
+  | Cycle_in_def (s, ty) ->
+      fprintf ppf "@[<v>The definition of %s contains a cycle:@ %a@]"
+        s Printtyp.type_expr ty
+  | Definition_mismatch (ty, None) ->
+      fprintf ppf "@[<v>@[<hov>%s@ %s@;<1 2>%a@]@]"
+        "This variant or record definition" "does not match that of type"
+        Printtyp.type_expr ty
+  | Definition_mismatch (ty, Some err) ->
+      fprintf ppf "@[<v>@[<hov>%s@ %s@;<1 2>%a@]%a@]"
+        "This variant or record definition" "does not match that of type"
+        Printtyp.type_expr ty
+        (Includecore.report_type_mismatch "the original" "this" "definition")
+        err
+  | Constraint_failed (ty, ty') ->
+      Printtyp.reset_and_mark_loops ty;
+      Printtyp.mark_loops ty';
+      Printtyp.Naming_context.reset ();
+      fprintf ppf "@[%s@ @[<hv>Type@ %a@ should be an instance of@ %a@]@]"
+        "Constraints are not satisfied in this type."
+        !Oprint.out_type (Printtyp.tree_of_typexp false ty)
+        !Oprint.out_type (Printtyp.tree_of_typexp false ty')
+  | Non_regular { definition; used_as; defined_as; expansions } ->
+      let pp_expansion ppf (ty,body) =
+        Format.fprintf ppf "%a = %a"
+          Printtyp.type_expr ty
+          Printtyp.type_expr body in
+      let comma ppf () = Format.fprintf ppf ",@;<1 2>" in
+      let pp_expansions ppf expansions =
+        Format.(pp_print_list ~pp_sep:comma pp_expansion) ppf expansions in
+      Printtyp.reset_and_mark_loops used_as;
+      Printtyp.mark_loops defined_as;
+      Printtyp.Naming_context.reset ();
+      begin match expansions with
+      | [] ->
+          fprintf ppf
+            "@[<hv>This recursive type is not regular.@ \
+             The type constructor %s is defined as@;<1 2>type %a@ \
+             but it is used as@;<1 2>%a.@ \
+             All uses need to match the definition for the recursive type \
+             to be regular.@]"
+            (Path.name definition)
+            !Oprint.out_type (Printtyp.tree_of_typexp false defined_as)
+            !Oprint.out_type (Printtyp.tree_of_typexp false used_as)
+      | _ :: _ ->
+          fprintf ppf
+            "@[<hv>This recursive type is not regular.@ \
+             The type constructor %s is defined as@;<1 2>type %a@ \
+             but it is used as@;<1 2>%a@ \
+             after the following expansion(s):@;<1 2>%a@ \
+             All uses need to match the definition for the recursive type \
+             to be regular.@]"
+            (Path.name definition)
+            !Oprint.out_type (Printtyp.tree_of_typexp false defined_as)
+            !Oprint.out_type (Printtyp.tree_of_typexp false used_as)
+            pp_expansions expansions
+      end
+  | Inconsistent_constraint (env, trace) ->
+      fprintf ppf "The type constraints are not consistent.@.";
+      Printtyp.report_unification_error ppf env trace
+        (fun ppf -> fprintf ppf "Type")
+        (fun ppf -> fprintf ppf "is not compatible with type")
+  | Type_clash (env, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "This type constructor expands to type")
+        (function ppf ->
+           fprintf ppf "but is used here with type")
+  | Null_arity_external ->
+      fprintf ppf "External identifiers must be functions"
+  | Missing_native_external ->
+      fprintf ppf "@[<hv>An external function with more than 5 arguments \
+                   requires a second stub function@ \
+                   for native-code compilation@]"
+  | Unbound_type_var (ty, decl) ->
+      fprintf ppf "A type variable is unbound in this type declaration";
+      let ty = Ctype.repr ty in
+      begin match decl.type_kind, decl.type_manifest with
+      | Type_variant tl, _ ->
+          explain_unbound_gen ppf ty tl (fun c ->
+              let tl = tys_of_constr_args c.Types.cd_args in
+              Btype.newgenty (Ttuple tl)
+            )
+            "case" (fun ppf c ->
+                fprintf ppf
+                  "%a of %a" Printtyp.ident c.Types.cd_id
+                  Printtyp.constructor_arguments c.Types.cd_args)
+      | Type_record (tl, _), _ ->
+          explain_unbound ppf ty tl (fun l -> l.Types.ld_type)
+            "field" (fun l -> Ident.name l.Types.ld_id ^ ": ")
+      | Type_abstract, Some ty' ->
+          explain_unbound_single ppf ty ty'
+      | _ -> ()
+      end
+  | Unbound_type_var_ext (ty, ext) ->
+      fprintf ppf "A type variable is unbound in this extension constructor";
+      let args = tys_of_constr_args ext.ext_args in
+      explain_unbound ppf ty args (fun c -> c) "type" (fun _ -> "")
+  | Cannot_extend_private_type path ->
+      fprintf ppf "@[%s@ %a@]"
+        "Cannot extend private type definition"
+        Printtyp.path path
+  | Not_extensible_type path ->
+      fprintf ppf "@[%s@ %a@ %s@]"
+        "Type definition"
+        Printtyp.path path
+        "is not extensible"
+  | Extension_mismatch (path, err) ->
+      fprintf ppf "@[<v>@[<hov>%s@ %s@;<1 2>%s@]%a@]"
+        "This extension" "does not match the definition of type"
+        (Path.name path)
+        (Includecore.report_type_mismatch
+           "the type" "this extension" "definition")
+        err
+  | Rebind_wrong_type (lid, env, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "The constructor %a@ has type"
+             Printtyp.longident lid)
+        (function ppf ->
+           fprintf ppf "but was expected to be of type")
+  | Rebind_mismatch (lid, p, p') ->
+      fprintf ppf
+        "@[%s@ %a@ %s@ %s@ %s@ %s@ %s@]"
+        "The constructor" Printtyp.longident lid
+        "extends type" (Path.name p)
+        "whose declaration does not match"
+        "the declaration of type" (Path.name p')
+  | Rebind_private lid ->
+      fprintf ppf "@[%s@ %a@ %s@]"
+        "The constructor"
+        Printtyp.longident lid
+        "is private"
+  | Variance (Typedecl_variance.Bad_variance (n, v1, v2)) ->
+      let variance (p,n,i) =
+        let inj = if i then "injective " else "" in
+        match p, n with
+          true,  true  -> inj ^ "invariant"
+        | true,  false -> inj ^ "covariant"
+        | false, true  -> inj ^ "contravariant"
+        | false, false -> if inj = "" then "unrestricted" else inj
+      in
+      let suffix n =
+        let teen = (n mod 100)/10 = 1 in
+        match n mod 10 with
+        | 1 when not teen -> "st"
+        | 2 when not teen -> "nd"
+        | 3 when not teen -> "rd"
+        | _ -> "th"
+      in
+      (match n with
+       | Variance_not_reflected ->
+           fprintf ppf "@[%s@ %s@ It"
+             "In this definition, a type variable has a variance that"
+             "is not reflected by its occurrence in type parameters."
+       | No_variable ->
+           fprintf ppf "@[%s@ %s@]"
+             "In this definition, a type variable cannot be deduced"
+             "from the type parameters."
+       | Variance_not_deducible ->
+           fprintf ppf "@[%s@ %s@ It"
+             "In this definition, a type variable has a variance that"
+             "cannot be deduced from the type parameters."
+       | Variance_not_satisfied n ->
+           fprintf ppf "@[%s@ %s@ The %d%s type parameter"
+             "In this definition, expected parameter"
+             "variances are not satisfied."
+             n (suffix n));
+      (match n with
+       | No_variable -> ()
+       | _ ->
+           fprintf ppf " was expected to be %s,@ but it is %s.@]"
+             (variance v2) (variance v1))
+  | Unavailable_type_constructor p ->
+      fprintf ppf "The definition of type %a@ is unavailable" Printtyp.path p
+  | Bad_fixed_type r ->
+      fprintf ppf "This fixed type %s" r
+  | Variance Typedecl_variance.Varying_anonymous ->
+      fprintf ppf "@[%s@ %s@ %s@]"
+        "In this GADT definition," "the variance of some parameter"
+        "cannot be checked"
+  | Val_in_structure ->
+      fprintf ppf "Value declarations are only allowed in signatures"
+  | Multiple_native_repr_attributes ->
+      fprintf ppf "Too many [@@unboxed]/[@@untagged] attributes"
+  | Cannot_unbox_or_untag_type Unboxed ->
+      fprintf ppf "@[Don't know how to unbox this type.@ \
+                   Only float, int32, int64 and nativeint can be unboxed.@]"
+  | Cannot_unbox_or_untag_type Untagged ->
+      fprintf ppf "@[Don't know how to untag this type.@ \
+                   Only int can be untagged.@]"
+  | Deep_unbox_or_untag_attribute kind ->
+      fprintf ppf
+        "@[The attribute '%s' should be attached to@ \
+         a direct argument or result of the primitive,@ \
+         it should not occur deeply into its type.@]"
+        (match kind with Unboxed -> "@unboxed" | Untagged -> "@untagged")
+  | Immediacy (Typedecl_immediacy.Bad_immediacy_attribute violation) ->
+      fprintf ppf "@[%a@]" Format.pp_print_text
+        (match violation with
+         | Type_immediacy.Violation.Not_always_immediate ->
+             "Types marked with the immediate attribute must be \
+              non-pointer types like int or bool."
+         | Type_immediacy.Violation.Not_always_immediate_on_64bits ->
+             "Types marked with the immediate64 attribute must be \
+              produced using the Stdlib.Sys.Immediate64.Make functor.")
+  | Bad_unboxed_attribute msg ->
+      fprintf ppf "@[This type cannot be unboxed because@ %s.@]" msg
+  | Separability (Typedecl_separability.Non_separable_evar evar) ->
+      let pp_evar ppf = function
+        | None ->
+            fprintf ppf "an unnamed existential variable"
+        | Some str ->
+            fprintf ppf "the existential variable %a"
+              Pprintast.tyvar str in
+      fprintf ppf "@[This type cannot be unboxed because@ \
+                   it might contain both float and non-float values,@ \
+                   depending on the instantiation of %a.@ \
+                   You should annotate it with [%@%@ocaml.boxed].@]"
+        pp_evar evar
+  | Boxed_and_unboxed ->
+      fprintf ppf "@[A type cannot be boxed and unboxed at the same time.@]"
+  | Nonrec_gadt ->
+      fprintf ppf
+        "@[GADT case syntax cannot be used in a 'nonrec' block.@]"
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, err) ->
+        Some (Location.error_of_printer ~loc report_error err)
+      | _ ->
+        None
+    )
diff --git a/upstream/ocaml_411/typing/typedecl.mli b/upstream/ocaml_411/typing/typedecl.mli
new file mode 100644
index 0000000..88f5b2f
--- /dev/null
+++ b/upstream/ocaml_411/typing/typedecl.mli
@@ -0,0 +1,106 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Typing of type definitions and primitive definitions *)
+
+open Types
+open Format
+
+val transl_type_decl:
+    Env.t -> Asttypes.rec_flag -> Parsetree.type_declaration list ->
+    Typedtree.type_declaration list * Env.t
+
+val transl_exception:
+    Env.t -> Parsetree.extension_constructor ->
+    Typedtree.extension_constructor * Env.t
+
+val transl_type_exception:
+    Env.t ->
+    Parsetree.type_exception -> Typedtree.type_exception * Env.t
+
+val transl_type_extension:
+    bool -> Env.t -> Location.t -> Parsetree.type_extension ->
+    Typedtree.type_extension * Env.t
+
+val transl_value_decl:
+    Env.t -> Location.t ->
+    Parsetree.value_description -> Typedtree.value_description * Env.t
+
+val transl_with_constraint:
+    Ident.t -> Path.t option ->
+    sig_env:Env.t -> sig_decl:Types.type_declaration ->
+    outer_env:Env.t -> Parsetree.type_declaration ->
+    Typedtree.type_declaration
+
+val abstract_type_decl: int -> type_declaration
+val approx_type_decl:
+    Parsetree.type_declaration list ->
+                                  (Ident.t * type_declaration) list
+val check_recmod_typedecl:
+    Env.t -> Location.t -> Ident.t list -> Path.t -> type_declaration -> unit
+val check_coherence:
+    Env.t -> Location.t -> Path.t -> type_declaration -> unit
+
+(* for fixed types *)
+val is_fixed_type : Parsetree.type_declaration -> bool
+
+(* for typeopt.ml *)
+val get_unboxed_type_representation: Env.t -> type_expr -> type_expr option
+
+type native_repr_kind = Unboxed | Untagged
+
+type error =
+    Repeated_parameter
+  | Duplicate_constructor of string
+  | Too_many_constructors
+  | Duplicate_label of string
+  | Recursive_abbrev of string
+  | Cycle_in_def of string * type_expr
+  | Definition_mismatch of type_expr * Includecore.type_mismatch option
+  | Constraint_failed of type_expr * type_expr
+  | Inconsistent_constraint of Env.t * Ctype.Unification_trace.t
+  | Type_clash of Env.t * Ctype.Unification_trace.t
+  | Non_regular of {
+      definition: Path.t;
+      used_as: type_expr;
+      defined_as: type_expr;
+      expansions: (type_expr * type_expr) list;
+    }
+  | Null_arity_external
+  | Missing_native_external
+  | Unbound_type_var of type_expr * type_declaration
+  | Cannot_extend_private_type of Path.t
+  | Not_extensible_type of Path.t
+  | Extension_mismatch of Path.t * Includecore.type_mismatch
+  | Rebind_wrong_type of Longident.t * Env.t * Ctype.Unification_trace.t
+  | Rebind_mismatch of Longident.t * Path.t * Path.t
+  | Rebind_private of Longident.t
+  | Variance of Typedecl_variance.error
+  | Unavailable_type_constructor of Path.t
+  | Bad_fixed_type of string
+  | Unbound_type_var_ext of type_expr * extension_constructor
+  | Val_in_structure
+  | Multiple_native_repr_attributes
+  | Cannot_unbox_or_untag_type of native_repr_kind
+  | Deep_unbox_or_untag_attribute of native_repr_kind
+  | Immediacy of Typedecl_immediacy.error
+  | Separability of Typedecl_separability.error
+  | Bad_unboxed_attribute of string
+  | Boxed_and_unboxed
+  | Nonrec_gadt
+
+exception Error of Location.t * error
+
+val report_error: formatter -> error -> unit
diff --git a/upstream/ocaml_411/typing/typedecl_immediacy.ml b/upstream/ocaml_411/typing/typedecl_immediacy.ml
new file mode 100644
index 0000000..ccd09e8
--- /dev/null
+++ b/upstream/ocaml_411/typing/typedecl_immediacy.ml
@@ -0,0 +1,71 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Types
+
+type error = Bad_immediacy_attribute of Type_immediacy.Violation.t
+exception Error of Location.t * error
+
+let compute_decl env tdecl =
+  match (tdecl.type_kind, tdecl.type_manifest) with
+  | (Type_variant [{cd_args = Cstr_tuple [arg]; _}], _)
+    | (Type_variant [{cd_args = Cstr_record [{ld_type = arg; _}]; _}], _)
+    | (Type_record ([{ld_type = arg; _}], _), _)
+  when tdecl.type_unboxed.unboxed ->
+    begin match Typedecl_unboxed.get_unboxed_type_representation env arg with
+    | Typedecl_unboxed.Unavailable -> Type_immediacy.Unknown
+    | Typedecl_unboxed.This argrepr -> Ctype.immediacy env argrepr
+    | Typedecl_unboxed.Only_on_64_bits argrepr ->
+        match Ctype.immediacy env argrepr with
+        | Type_immediacy.Always -> Type_immediacy.Always_on_64bits
+        | Type_immediacy.Always_on_64bits | Type_immediacy.Unknown as x -> x
+    end
+  | (Type_variant (_ :: _ as cstrs), _) ->
+    if not (List.exists (fun c -> c.Types.cd_args <> Types.Cstr_tuple []) cstrs)
+    then
+      Type_immediacy.Always
+    else
+      Type_immediacy.Unknown
+  | (Type_abstract, Some(typ)) -> Ctype.immediacy env typ
+  | (Type_abstract, None) -> Type_immediacy.of_attributes tdecl.type_attributes
+  | _ -> Type_immediacy.Unknown
+
+let property : (Type_immediacy.t, unit) Typedecl_properties.property =
+  let open Typedecl_properties in
+  let eq = (=) in
+  let merge ~prop:_ ~new_prop = new_prop in
+  let default _decl = Type_immediacy.Unknown in
+  let compute env decl () = compute_decl env decl in
+  let update_decl decl immediacy = { decl with type_immediate = immediacy } in
+  let check _env _id decl () =
+    let written_by_user = Type_immediacy.of_attributes decl.type_attributes in
+    match Type_immediacy.coerce decl.type_immediate ~as_:written_by_user with
+    | Ok () -> ()
+    | Error violation ->
+        raise (Error (decl.type_loc,
+                      Bad_immediacy_attribute violation))
+  in
+  {
+    eq;
+    merge;
+    default;
+    compute;
+    update_decl;
+    check;
+  }
+
+let update_decls env decls =
+  Typedecl_properties.compute_property_noreq property env decls
diff --git a/upstream/ocaml_411/typing/typedecl_immediacy.mli b/upstream/ocaml_411/typing/typedecl_immediacy.mli
new file mode 100644
index 0000000..17fb985
--- /dev/null
+++ b/upstream/ocaml_411/typing/typedecl_immediacy.mli
@@ -0,0 +1,27 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type error = Bad_immediacy_attribute of Type_immediacy.Violation.t
+exception Error of Location.t * error
+
+val compute_decl : Env.t -> Types.type_declaration -> Type_immediacy.t
+
+val property : (Type_immediacy.t, unit) Typedecl_properties.property
+
+val update_decls :
+  Env.t ->
+  (Ident.t * Typedecl_properties.decl) list ->
+  (Ident.t * Typedecl_properties.decl) list
diff --git a/upstream/ocaml_411/typing/typedecl_properties.ml b/upstream/ocaml_411/typing/typedecl_properties.ml
new file mode 100644
index 0000000..28a1bb6
--- /dev/null
+++ b/upstream/ocaml_411/typing/typedecl_properties.ml
@@ -0,0 +1,73 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type decl = Types.type_declaration
+
+type ('prop, 'req) property = {
+  eq : 'prop -> 'prop -> bool;
+  merge : prop:'prop -> new_prop:'prop -> 'prop;
+
+  default : decl -> 'prop;
+  compute : Env.t -> decl -> 'req -> 'prop;
+  update_decl : decl -> 'prop -> decl;
+
+  check : Env.t -> Ident.t -> decl -> 'req -> unit;
+}
+
+let add_type ~check id decl env =
+  let open Types in
+  Builtin_attributes.warning_scope ~ppwarning:false decl.type_attributes
+    (fun () -> Env.add_type ~check id decl env)
+
+let add_types_to_env decls env =
+  List.fold_right
+    (fun (id, decl) env -> add_type ~check:true id decl env)
+    decls env
+
+let compute_property
+: ('prop, 'req) property -> Env.t ->
+  (Ident.t * decl) list -> 'req list -> (Ident.t * decl) list
+= fun property env decls required ->
+  (* [decls] and [required] must be lists of the same size,
+     with [required] containing the requirement for the corresponding
+     declaration in [decls]. *)
+  let props = List.map (fun (_id, decl) -> property.default decl) decls in
+  let rec compute_fixpoint props =
+    let new_decls =
+      List.map2 (fun (id, decl) prop ->
+          (id, property.update_decl decl prop))
+        decls props in
+    let new_env = add_types_to_env new_decls env in
+    let new_props =
+      List.map2
+        (fun (_id, decl) (prop, req) ->
+           let new_prop = property.compute new_env decl req in
+           property.merge ~prop ~new_prop)
+        new_decls (List.combine props required) in
+    if not (List.for_all2 property.eq props new_props)
+    then compute_fixpoint new_props
+    else begin
+      List.iter2
+        (fun (id, decl) req -> property.check new_env id decl req)
+        new_decls required;
+      new_decls
+    end
+  in
+  compute_fixpoint props
+
+let compute_property_noreq property env decls =
+  let req = List.map (fun _ -> ()) decls in
+  compute_property property env decls req
diff --git a/upstream/ocaml_411/typing/typedecl_properties.mli b/upstream/ocaml_411/typing/typedecl_properties.mli
new file mode 100644
index 0000000..153c3f7
--- /dev/null
+++ b/upstream/ocaml_411/typing/typedecl_properties.mli
@@ -0,0 +1,55 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type decl = Types.type_declaration
+
+(** An abstract interface for properties of type definitions, such as
+   variance and immediacy, that are computed by a fixpoint on
+   mutually-recursive type declarations. This interface contains all
+   the operations needed to initialize and run the fixpoint
+   computation, and then (optionally) check that the result is
+   consistent with the declaration or user expectations. *)
+
+type ('prop, 'req) property = {
+  eq : 'prop -> 'prop -> bool;
+  merge : prop:'prop -> new_prop:'prop -> 'prop;
+
+  default : decl -> 'prop;
+  compute : Env.t -> decl -> 'req -> 'prop;
+  update_decl : decl -> 'prop -> decl;
+
+  check : Env.t -> Ident.t -> decl -> 'req -> unit;
+}
+(** ['prop] represents the type of property values
+    ({!Types.Variance.t}, just 'bool' for immediacy, etc).
+
+    ['req] represents the property value required by the author of the
+    declaration, if they gave an expectation: [type +'a t = ...].
+
+    Some properties have no natural notion of user requirement, or
+    their requirement is global, or already stored in
+    [type_declaration]; they can just use [unit] as ['req] parameter. *)
+
+
+(** [compute_property prop env decls req] performs a fixpoint computation
+    to determine the final values of a property on a set of mutually-recursive
+    type declarations. The [req] argument must be a list of the same size as
+    [decls], providing the user requirement for each declaration. *)
+val compute_property : ('prop, 'req) property -> Env.t ->
+  (Ident.t * decl) list -> 'req list -> (Ident.t * decl) list
+
+val compute_property_noreq : ('prop, unit) property -> Env.t ->
+  (Ident.t * decl) list -> (Ident.t * decl) list
diff --git a/upstream/ocaml_411/typing/typedecl_separability.ml b/upstream/ocaml_411/typing/typedecl_separability.ml
new file mode 100644
index 0000000..32e3422
--- /dev/null
+++ b/upstream/ocaml_411/typing/typedecl_separability.ml
@@ -0,0 +1,731 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Types
+
+type type_definition = type_declaration
+(* We should use 'declaration' for interfaces, and 'definition' for
+   implementations. The name type_declaration in types.ml is improper
+   for our usage -- although for OCaml types the declaration and
+   definition languages are the same. *)
+
+(** assuming that a datatype has a single constructor/label with
+   a single argument, [argument_to_unbox] represents the
+   information we need to check the argument for separability. *)
+type argument_to_unbox = {
+  kind: parameter_kind; (* for error messages *)
+  mutability: Asttypes.mutable_flag;
+  argument_type: type_expr;
+  result_type_parameter_instances: type_expr list;
+  (** result_type_parameter_instances represents the domain of the
+     constructor; usually it is just a list of the datatype parameter
+     ('a, 'b, ...), but when using GADTs or constraints it could
+     contain arbitrary type expressions.
+
+     For example, [type 'a t = 'b constraint 'a = 'b * int] has
+     [['b * int]] as [result_type_parameter_instances], and so does
+     [type _ t = T : 'b -> ('b * int) t]. *)
+  location : Location.t;
+}
+and parameter_kind =
+  | Record_field
+  | Constructor_parameter
+  | Constructor_field (** inlined records *)
+
+(** ['a multiplicity] counts the number of ['a] in
+    a structure in which expect to see only one ['a]. *)
+type 'a multiplicity =
+  | Zero
+  | One of 'a
+  | Several
+
+type arity = argument_to_unbox multiplicity (**how many parameters?*)
+
+type branching = arity multiplicity (**how many constructors?*)
+
+(** Summarize the right-hand-side of a type declaration,
+    for separability-checking purposes. See {!structure} below. *)
+type type_structure =
+  | Synonym of type_expr
+  | Abstract
+  | Open
+  | Algebraic of branching
+
+let demultiply_list
+  : type a b. a list -> (a -> b) -> b multiplicity
+  = fun li f -> match li with
+  | [] -> Zero
+  | [v] -> One (f v)
+  | _::_::_ -> Several
+
+let structure : type_definition -> type_structure = fun def ->
+  match def.type_kind with
+  | Type_open -> Open
+  | Type_abstract ->
+      begin match def.type_manifest with
+      | None -> Abstract
+      | Some type_expr -> Synonym type_expr
+      end
+  | Type_record (labels, _) ->
+      Algebraic (One (
+        demultiply_list labels @@ fun ld -> {
+          location = ld.ld_loc;
+          kind = Record_field;
+          mutability = ld.ld_mutable;
+          argument_type = ld.ld_type;
+          result_type_parameter_instances = def.type_params;
+        }
+      ))
+  | Type_variant constructors ->
+      Algebraic (demultiply_list constructors @@ fun cd ->
+        let result_type_parameter_instances =
+          match cd.cd_res with
+          (* cd_res is the optional return type (in a GADT);
+             if None, just use the type parameters *)
+          | None -> def.type_params
+          | Some ret_type ->
+              begin match Ctype.repr ret_type with
+              | {desc=Tconstr (_, tyl, _)} ->
+                  List.map Ctype.repr tyl
+              | _ -> assert false
+              end
+        in
+        begin match cd.cd_args with
+        | Cstr_tuple tys ->
+            demultiply_list tys @@ fun argument_type -> {
+              location = cd.cd_loc;
+              kind = Constructor_parameter;
+              mutability = Asttypes.Immutable;
+              argument_type;
+              result_type_parameter_instances;
+            }
+        | Cstr_record labels ->
+            demultiply_list labels @@ fun ld ->
+              let argument_type = ld.ld_type in
+              {
+                location = ld.ld_loc;
+                kind = Constructor_field;
+                mutability = ld.ld_mutable;
+                argument_type;
+                result_type_parameter_instances;
+              }
+        end)
+
+
+type error =
+  | Non_separable_evar of string option
+
+exception Error of Location.t * error
+
+(* see the .mli file for explanations on the modes *)
+module Sep = Types.Separability
+type mode = Sep.t = Ind | Sep | Deepsep
+
+let rank = Sep.rank
+let max_mode = Sep.max
+
+(** If the type context [e(_)] imposes the mode [m] on its hole [_],
+    and the type context [e'(_)] imposes the mode [m'] on its hole [_],
+    then the mode on [_] imposed by the context composition [e(e'(_))]
+    is [compose m m'].
+
+    This operation differs from [max_mode]: [max_mode Ind Sep] is [Sep],
+    but [compose Ind Sep] is [Ind]. *)
+let compose
+  : mode -> mode -> mode
+  = fun m1 m2 ->
+  match m1 with
+  | Deepsep -> Deepsep
+  | Sep -> m2
+  | Ind -> Ind
+
+type type_var = {
+  text: string option; (** the user name of the type variable, None for '_' *)
+  id: int; (** the identifier of the type node (type_expr.id) of the variable *)
+}
+
+module TVarMap = Map.Make(struct
+    type t = type_var
+    let compare v1 v2 = compare v1.id v2.id
+  end)
+type context = mode TVarMap.t
+let (++) = TVarMap.union (fun _ m1 m2 -> Some(max_mode m1 m2))
+let empty = TVarMap.empty
+
+
+(** [immediate_subtypes ty] returns the list of all the
+   immediate sub-type-expressions of [ty]. They represent the biggest
+   sub-components that may be extracted using a constraint. For
+   example, the immediate sub-type-expressions of [int * (bool * 'a)]
+   are [int] and [bool * 'a].
+
+   Smaller components are extracted recursively in [check_type]. *)
+let rec immediate_subtypes : type_expr -> type_expr list = fun ty ->
+  (* Note: Btype.fold_type_expr is not suitable here:
+     - it does not do the right thing on Tpoly, iterating on type
+       parameters as well as the subtype
+     - it performs a shallow traversal of object types,
+       while our implementation collects all method types *)
+  match (Ctype.repr ty).desc with
+  (* these are the important cases,
+     on which immediate_subtypes is called from [check_type] *)
+  | Tarrow(_,ty1,ty2,_) ->
+      [ty1; ty2]
+  | Ttuple(tys)
+  | Tpackage(_,_,tys) ->
+      tys
+  | Tobject(row,class_ty) ->
+      let class_subtys =
+        match !class_ty with
+        | None        -> []
+        | Some(_,tys) -> tys
+      in
+      immediate_subtypes_object_row class_subtys row
+  | Tvariant(row) ->
+      immediate_subtypes_variant_row [] row
+
+  (* the cases below are not called from [check_type],
+     they are here for completeness *)
+  | Tnil | Tfield _ ->
+      (* these should only occur under Tobject and not at the toplevel,
+         but "better safe than sorry" *)
+      immediate_subtypes_object_row [] ty
+  | Tlink _ | Tsubst _ -> assert false (* impossible due to Ctype.repr *)
+  | Tvar _ | Tunivar _ -> []
+  | Tpoly (pty, _) -> [pty]
+  | Tconstr (_path, tys, _) -> tys
+
+and immediate_subtypes_object_row acc ty = match (Ctype.repr ty).desc with
+  | Tnil -> acc
+  | Tfield (_label, _kind, ty, rest) ->
+      let acc = ty :: acc in
+      immediate_subtypes_object_row acc rest
+  | _ -> ty :: acc
+
+and immediate_subtypes_variant_row acc desc =
+  let add_subtypes acc =
+    let add_subtype acc (_l, rf) =
+      immediate_subtypes_variant_row_field acc rf in
+    List.fold_left add_subtype acc desc.row_fields in
+  let add_row acc =
+    let row = Ctype.repr desc.row_more in
+    match row.desc with
+    | Tvariant more -> immediate_subtypes_variant_row acc more
+    | _ -> row :: acc
+  in
+  add_row (add_subtypes acc)
+
+and immediate_subtypes_variant_row_field acc = function
+  | Rpresent(None)
+  | Rabsent            -> acc
+  | Rpresent(Some(ty)) -> ty :: acc
+  | Reither(_,field_types,_,r) ->
+      let acc = List.rev_append field_types acc in
+      begin match !r with
+      | None -> acc
+      | Some rf -> immediate_subtypes_variant_row_field acc rf
+      end
+
+let free_variables ty =
+  Ctype.free_variables (Ctype.repr ty)
+  |> List.map (fun {desc; id; _} ->
+      match desc with
+      | Tvar text -> {text; id}
+      | _ ->
+          (* Ctype.free_variables only returns Tvar nodes *)
+          assert false)
+
+(** Coinductive hypotheses to handle equi-recursive types
+
+    OCaml allows infinite/cyclic types, such as
+      (int * 'a) as 'a
+    whose infinite unfolding is (int * (int * (int * (int * ...)))).
+
+    Remark: this specific type is only accepted if the -rectypes option
+    is passed, but such "equi-recursive types" are accepted by
+    default if the cycle goes through an object type or polymorphic
+    variant type:
+      [ `int | `other of 'a ] as 'a
+      < head : int; rest : 'a > as 'a
+
+    We have to take those infinite types in account in our
+    separability-checking program: a naive implementation would loop
+    infinitely when trying to prove that one of them is Deepsep.
+
+    After type-checking, the cycle-introducing form (... as 'a) does
+    not appear explicitly in the syntax of types: types are graphs/trees
+    with cycles in them, and we have to use the type_expr.id field,
+    an identifier for each node in the graph/tree, to detect cycles.
+
+    We avoid looping by remembering the set of separability queries
+    that we have already asked ourselves (in the current
+    search branch). For example, if we are asked to check
+
+      (int * 'a) : Deepsep
+
+    our algorithm will check both (int : Deepsep) and ('a : Deepsep),
+    but it will remember in these sub-checks that it is in the process
+    of checking (int * 'a) : Deepsep, adding it to a list of "active
+    goals", or "coinductive hypotheses".
+
+    Each new sub-query will start by checking whether the query
+    already appears as a coinductive hypothesis; in our example, this
+    can happen if 'a and (int * 'a) are in fact the same node in the
+    cyclic tree. In that case, we return immediately (instead of looping):
+    we reason that, assuming that 'a is indeed Deepsep, then it is
+    the case that (int * 'a) is also Deepsep.
+
+    This kind of cyclic reasoning can be dangerous: it would be wrong
+    to argue that an arbitrary 'a type is Deepsep by saying:
+    "assuming that 'a is Deepsep, then it is the case that 'a is
+    also Deepsep". In the first case, we made an assumption on 'a,
+    and used it on a type (int * 'a) which has 'a as a strict sub-component;
+    in the second, we use it on the same type 'a directly, which is invalid.
+
+    Now consider a type of the form (('a t) as 'a): while 'a is a sub-component
+    of ('a t), it may still be wrong to reason coinductively about it,
+    as ('a t) may be defined as (type 'a t = 'a).
+
+    When moving from (int * 'a) to a subcomponent (int) or ('a), we
+    say that the coinductive hypothesis on (int * 'a : m) is "safe":
+    it can be used immediately to prove the subcomponents, because we
+    made progress moving to a strict subcomponent (we are guarded
+    under a computational type constructor). On the other hand, when
+    moving from ('a t) to ('a), we say that the coinductive hypothesis
+    ('a t : m) is "unsafe" for the subgoal, as we don't know whether
+    we have made strict progress. In the general case, we keep track
+    of a set of safe and unsafe hypotheses made in the past, and we
+    use them to terminate checking if we encounter them again,
+    ensuring termination.
+
+    If we encounter a (ty : m) goal that is exactly a safe hypothesis,
+    we terminate with a success. In fact, we can use mode subtyping here:
+    if (ty : m') appears as a hypothesis with (m' >= m), then we would
+    succeed for (ty : m'), so (ty : m) should succeed as well.
+
+    On the other hand, if we encounter a (ty : m) goal that is an
+    *unsafe* hypothesis, we terminate the check with a failure. In this case,
+    we cannot work modulo mode subtyping: if (ty : m') appears with
+    (m' >= m), then the check (ty : m') would have failed, but it is still
+    possible that the weaker current query (ty : m) would succeed.
+
+    In usual coinductive-reasoning systems, unsafe hypotheses are turned
+    into safe hypotheses each time strict progress is made (for each
+    guarded sub-goal). Consider ((int * 'a) t as 'a : deepsep) for example:
+    the idea is that the ((int * 'a) t : deepsep) hypothesis would be
+    unsafe when checking ((int * 'a) : deepsep), but that the progress
+    step from (int * 'a : deepsep) to ('a : deepsep) would turn all
+    past unsafe hypotheses into safe hypotheses. There is a problem
+    with this, though, due to constraints: what if (_ t) is defined as
+
+      type 'b t = 'a constraint 'b = (int * 'a)
+
+    ?
+
+    In that case, then 'a is precisely the one-step unfolding
+    of the ((int * 'a) t) definition, and it would be an invalid,
+    cyclic reasoning to prove ('a : deepsep) from the now-safe
+    hypothesis ((int * 'a) t : deepsep).
+
+    Surprisingly-fortunately, we have exactly the information we need
+    to know whether (_ t) may or may not pull a constraint trick of
+    this nature: we can look at its mode signature, where constraints
+    are marked by a Deepsep mode. If we see Deepsep, we know that a
+    constraint exists, but we don't know what the constraint is:
+    we cannot tell at which point, when decomposing the parameter type,
+    a sub-component can be considered safe again. To model this,
+    we add a third category of co-inductive hypotheses: to "safe" and
+    "unsafe" we add the category of "poison" hypotheses, which remain
+    poisonous during the remaining of the type decomposition,
+    even in presence of safe, computational types constructors:
+
+    - when going under a computational constructor,
+      "unsafe" hypotheses become "safe"
+    - when going under a constraining type (more precisely, under
+      a type parameter that is marked Deepsep in the mode signature),
+      "unsafe" hypotheses become "poison"
+
+    The mode signature tells us even a bit more: if a parameter
+    is marked "Ind", we know that the type constructor cannot unfold
+    to this parameter (otherwise it would be Sep), so going under
+    this parameter can be considered a safe/guarded move: if
+    we have to check (foo t : m) with ((_ : Ind) t) in the signature,
+    we can recursively check (foo : Ind) with (foo t : m) marked
+    as "safe", rather than "unsafe".
+*)
+module TypeMap = Btype.TypeMap
+module ModeSet = Set.Make(Types.Separability)
+
+type coinductive_hyps = {
+  safe: ModeSet.t TypeMap.t;
+  unsafe: ModeSet.t TypeMap.t;
+  poison: ModeSet.t TypeMap.t;
+}
+
+module Hyps : sig
+  type t = coinductive_hyps
+  val empty : t
+  val add : type_expr -> mode -> t -> t
+  val guard : t -> t
+  val poison : t -> t
+  val safe : type_expr -> mode -> t -> bool
+  val unsafe : type_expr -> mode -> t -> bool
+end = struct
+  type t = coinductive_hyps
+
+  let empty = {
+    safe = TypeMap.empty;
+    unsafe = TypeMap.empty;
+    poison = TypeMap.empty;
+  }
+
+  let of_opt = function
+    | Some ms -> ms
+    | None -> ModeSet.empty
+
+  let merge map1 map2 =
+    TypeMap.merge (fun _k ms1 ms2 ->
+        Some (ModeSet.union (of_opt ms1) (of_opt ms2))
+      ) map1 map2
+
+  let guard {safe; unsafe; poison;} = {
+    safe = merge safe unsafe;
+    unsafe = TypeMap.empty;
+    poison;
+  }
+
+  let poison {safe; unsafe; poison;} = {
+    safe;
+    unsafe = TypeMap.empty;
+    poison = merge poison unsafe;
+  }
+
+  let add ty m hyps =
+    let m_map = TypeMap.singleton ty (ModeSet.singleton m) in
+    { hyps with unsafe = merge m_map hyps.unsafe; }
+
+  let find ty map = try TypeMap.find ty map with Not_found -> ModeSet.empty
+
+  let safe ty m hyps =
+    match ModeSet.max_elt_opt (find ty hyps.safe) with
+    | None -> false
+    | Some best_safe -> rank best_safe >= rank m
+
+  let unsafe ty m {safe = _; unsafe; poison} =
+    let in_map s = ModeSet.mem m (find ty s) in
+    List.exists in_map [unsafe; poison]
+end
+
+(** For a type expression [ty] (without constraints and existentials),
+    any mode checking [ty : m] is satisfied in the "worse case" context
+    that maps all free variables of [ty] to the most demanding mode,
+    Deepsep. *)
+let worst_case ty =
+  let add ctx tvar = TVarMap.add tvar Deepsep ctx in
+  List.fold_left add TVarMap.empty (free_variables ty)
+
+
+(** [check_type env sigma ty m] returns the most permissive context [gamma]
+    such that [ty] is separable at mode [m] in [gamma], under
+    the signature [sigma]. *)
+let check_type
+  : Env.t -> type_expr -> mode -> context
+  = fun env ty m ->
+  let rec check_type hyps ty m =
+    let ty = Ctype.repr ty in
+    if Hyps.safe ty m hyps then empty
+    else if Hyps.unsafe ty m hyps then worst_case ty
+    else
+    let hyps = Hyps.add ty m hyps in
+    match (ty.desc, m) with
+    (* Impossible case due to the call to [Ctype.repr]. *)
+    | (Tlink _            , _      ) -> assert false
+    (* Impossible case (according to comment in [typing/types.mli]. *)
+    | (Tsubst(_)          , _      ) -> assert false
+    (* "Indifferent" case, the empty context is sufficient. *)
+    | (_                  , Ind    ) -> empty
+    (* Variable case, add constraint. *)
+    | (Tvar(alpha)        , m      ) ->
+        TVarMap.singleton {text = alpha; id = ty.Types.id} m
+    (* "Separable" case for constructors with known memory representation. *)
+    | (Tarrow _           , Sep    )
+    | (Ttuple _           , Sep    )
+    | (Tvariant(_)        , Sep    )
+    | (Tobject(_,_)       , Sep    )
+    | ((Tnil | Tfield _)  , Sep    )
+    | (Tpackage(_,_,_)    , Sep    ) -> empty
+    (* "Deeply separable" case for these same constructors. *)
+    | (Tarrow _           , Deepsep)
+    | (Ttuple _           , Deepsep)
+    | (Tvariant(_)        , Deepsep)
+    | (Tobject(_,_)       , Deepsep)
+    | ((Tnil | Tfield _)  , Deepsep)
+    | (Tpackage(_,_,_)    , Deepsep) ->
+        let tys = immediate_subtypes ty in
+        let on_subtype context ty =
+          context ++ check_type (Hyps.guard hyps) ty Deepsep in
+        List.fold_left on_subtype empty tys
+    (* Polymorphic type, and corresponding polymorphic variable.
+
+       In theory, [Tpoly] (forall alpha. tau) would add a new variable
+       (alpha) in scope, check its body (tau) recursively, and then
+       remove the new variable from the resulting context. Because the
+       rule accepts any mode for this variable, the removal never
+       fails.
+
+       In practice the implementation is simplified by ignoring the
+       new variable, and always returning the [empty] context
+       (instead of (alpha : m) in the [Tunivar] case: the constraint
+       on the variable is removed/ignored at the variable occurrence
+       site, rather than at the variable-introduction site. *)
+    (* Note: that we are semantically incomplete in the Deepsep case
+       (following the syntactic typing rules): the semantics only
+       requires that *closed* sub-type-expressions be (deeply)
+       separable; sub-type-expressions containing the quantified
+       variable cannot be extracted by constraints (this would be
+       a scope violation), so they could be ignored if they occur
+       under a separating type constructor. *)
+    | (Tpoly(pty,_)       , m      ) ->
+        check_type hyps pty m
+    | (Tunivar(_)         , _      ) -> empty
+    (* Type constructor case. *)
+    | (Tconstr(path,tys,_), m      ) ->
+        let msig = (Env.find_type path env).type_separability in
+        let on_param context (ty, m_param) =
+          let hyps = match m_param with
+            | Ind -> Hyps.guard hyps
+            | Sep -> hyps
+            | Deepsep -> Hyps.poison hyps in
+          context ++ check_type hyps ty (compose m m_param) in
+        List.fold_left on_param empty (List.combine tys msig)
+  in
+  check_type Hyps.empty ty m
+
+let best_msig decl = List.map (fun _ -> Ind) decl.type_params
+let worst_msig decl = List.map (fun _ -> Deepsep) decl.type_params
+
+(** [msig_of_external_type decl] infers the mode signature of an
+    abstract/external type. We must assume the worst, namely that this
+    type may be defined as an unboxed algebraic datatype imposing deep
+    separability of its parameters.
+
+    One exception is when the type is marked "immediate", which
+    guarantees that its representation is only integers.  Immediate
+    types are always separable, so [Ind] suffices for their
+    parameters.
+
+    Note: this differs from {!Types.Separability.default_signature},
+    which does not have access to the declaration and its immediacy. *)
+let msig_of_external_type decl =
+  match decl.type_immediate with
+  | Always | Always_on_64bits -> best_msig decl
+  | Unknown -> worst_msig decl
+
+(** [msig_of_context ~decl_loc constructor context] returns the
+   separability signature of a single-constructor type whose
+   definition is valid in the mode context [context].
+
+   Note: A GADT constructor introduces existential type variables, and
+   may also introduce some equalities between its return type
+   parameters and type expressions containing universal and
+   existential variables. In other words, it introduces new type
+   variables in scope, and restricts existing variables by adding
+   equality constraints.
+
+   [msig_of_context] performs the reverse transformation: the context
+   [ctx] computed from the argument of the constructor mentions
+   existential variables, and the function returns a context over the
+   (universal) type parameters only. (Type constraints do not
+   introduce existential variables, but they do introduce equalities;
+   they are handled as GADTs equalities by this function.)
+
+   The transformation is separability-preserving in the following
+   sense: for any valid instance of the result mode signature
+   (replacing the universal type parameters with ground types
+   respecting the variable's separability mode), any possible
+   extension of this context instance with ground instances for the
+   existential variables of [parameter] that respects the equation
+   constraints will validate the separability requirements of the
+   modes in the input context [ctx].
+
+   Sometimes no such universal context exists, as an existential type
+   cannot be safely introduced, then this function raises an [Error]
+   exception with a [Non_separable_evar] payload.  *)
+let msig_of_context : decl_loc:Location.t -> parameters:type_expr list
+    -> context -> Sep.signature =
+  fun ~decl_loc ~parameters context ->
+    let handle_equation (acc, context) param_instance =
+      (* In the theory, GADT equations are of the form
+           ('a = <ty>)
+         for each type parameter 'a of the type constructor. For each
+         such equation, we should "strengthen" the current context in
+         the following way:
+         - if <ty> is another variable 'b,
+           the mode of 'a is set to the mode of 'b,
+           and 'b is set to Ind
+         - if <ty> is a type expression whose variables are all Ind,
+           set 'a to Ind and discard the equation
+         - otherwise (one of the variable of 'b is not Ind),
+           set 'a to Deepsep and set all variables of <ty> to Ind
+
+         In practice, type parameters are determined by their position
+         in a list, they do not necessarily have a corresponding type variable.
+         Instead of "setting 'a" in the context as in the description above,
+         we build a list of modes by repeated consing into
+         an accumulator variable [acc], setting existential variables
+         to Ind as we go. *)
+      let param_instance = Ctype.repr param_instance in
+      let get context var =
+        try TVarMap.find var context with Not_found -> Ind in
+      let set_ind context var =
+        TVarMap.add var Ind context in
+      let is_ind context var = match get context var with
+        | Ind -> true
+        | Sep | Deepsep -> false in
+      match param_instance.desc with
+      | Tvar text ->
+          let var = {text; id = param_instance.Types.id} in
+          (get context var) :: acc, (set_ind context var)
+      | _ ->
+          let instance_exis = free_variables param_instance in
+          if List.for_all (is_ind context) instance_exis then
+            Ind :: acc, context
+          else
+            Deepsep :: acc, List.fold_left set_ind context instance_exis
+    in
+    let mode_signature, context =
+      let (mode_signature_rev, ctx) =
+        List.fold_left handle_equation ([], context) parameters in
+      (* Note: our inference system is not principal, because the
+         inference result depends on the order in which those
+         equations are processed. (To our knowledge this is the only
+         source of non-principality.) If two parameters ('a, 'b) are
+         forced to be equal to each other, and also separable, then
+         either modes (Sep, Ind) and (Ind, Sep) are correct, allow
+         more declarations than (Sep, Sep), but (Ind, Ind) would be
+         unsound.
+
+         Such a non-principal example is the following:
+
+           type ('a, 'b) almost_eq =
+             | Almost_refl : 'c -> ('c, 'c) almost_eq
+
+         (This example looks strange: GADT equations are typically
+         either on only one parameter, or on two parameters that are
+         not used to classify constructor arguments. Indeed, we have
+         not found non-principal declarations in real-world code.)
+
+         In a non-principal system, it is important the our choice of
+         non-unique solution be at least predictable. We find it more
+         natural, when either ('a : Sep, 'b : Ind) and ('a : Ind,
+         'b : Sep) are correct because 'a = 'b, to choose to make the
+         first/leftmost parameter more constrained. We read this as
+         saying that 'a must be Sep, and 'b = 'a so 'b can be
+         Ind. (We define the second parameter as equal of the first,
+         already-seen parameter; instead of saying that the first
+         parameter is equal to the not-yet-seen second one.)
+
+         This is achieved by processing the equations from left to
+         right with List.fold_left, instead of using
+         List.fold_right. The code is slightly more awkward as it
+         needs a List.rev on the accumulated modes, but it gives
+         a more predictable/natural (non-principal) behavior.
+  *)
+      (List.rev mode_signature_rev, ctx) in
+    (* After all variables determined by the parameters have been set to Ind
+       by [handle_equation], all variables remaining in the context are
+       purely existential and should not require a stronger mode than Ind. *)
+    let check_existential evar mode =
+      if rank mode > rank Ind then
+        raise (Error (decl_loc, Non_separable_evar evar.text))
+    in
+    TVarMap.iter check_existential context;
+    mode_signature
+
+(** [check_def env def] returns the signature required
+    for the type definition [def] in the typing environment [env].
+
+    The exception [Error] is raised if we discover that
+    no such signature exists -- the definition will always be invalid.
+    This only happens when the definition is marked to be unboxed. *)
+
+let check_def
+  : Env.t -> type_definition -> Sep.signature
+  = fun env def ->
+  let boxed = not def.type_unboxed.unboxed in
+  match structure def with
+  | Abstract ->
+      assert boxed;
+      msig_of_external_type def
+  | Synonym type_expr ->
+      check_type env type_expr Sep
+      |> msig_of_context ~decl_loc:def.type_loc ~parameters:def.type_params
+  | Open | Algebraic (Zero | Several | One (Zero | Several)) ->
+      assert boxed;
+      best_msig def
+  | Algebraic (One (One constructor)) ->
+    if boxed then best_msig def
+    else
+      check_type env constructor.argument_type Sep
+      |> msig_of_context ~decl_loc:def.type_loc
+           ~parameters:constructor.result_type_parameter_instances
+
+let compute_decl env decl =
+  if Config.flat_float_array then check_def env decl
+  else
+    (* Hack: in -no-flat-float-array mode, instead of always returning
+       [best_msig], we first compute the separability signature --
+       falling back to [best_msig] if it fails.
+
+       This discipline is conservative: it never
+       rejects -no-flat-float-array programs. At the same time it
+       guarantees that, for any program that is also accepted
+       in -flat-float-array mode, the same separability will be
+       inferred in the two modes. In particular, the same .cmi files
+       and digests will be produced.
+
+       Before we introduced this hack, the production of different
+       .cmi files would break the build system of the compiler itself,
+       when trying to build a -no-flat-float-array system from
+       a bootstrap compiler itself using -flat-float-array. See #9291.
+       *)
+    try check_def env decl with
+    | Error _ ->
+       (* It could be nice to emit a warning here, so that users know
+          that their definition would be rejected in -flat-float-array mode *)
+       best_msig decl
+
+(** Separability as a generic property *)
+type prop = Types.Separability.signature
+
+let property : (prop, unit) Typedecl_properties.property =
+  let open Typedecl_properties in
+  let eq ts1 ts2 =
+    List.length ts1 = List.length ts2
+    && List.for_all2 Sep.eq ts1 ts2 in
+  let merge ~prop:_ ~new_prop =
+    (* the update function is monotonous: ~new_prop is always
+       more informative than ~prop, which can be ignored *)
+    new_prop in
+  let default decl = best_msig decl in
+  let compute env decl () = compute_decl env decl in
+  let update_decl decl type_separability = { decl with type_separability } in
+  let check _env _id _decl () = () in (* FIXME run final check? *)
+  { eq; merge; default; compute; update_decl; check; }
+
+(* Definition using the fixpoint infrastructure. *)
+let update_decls env decls =
+  Typedecl_properties.compute_property_noreq property env decls
diff --git a/upstream/ocaml_411/typing/typedecl_separability.mli b/upstream/ocaml_411/typing/typedecl_separability.mli
new file mode 100644
index 0000000..079e640
--- /dev/null
+++ b/upstream/ocaml_411/typing/typedecl_separability.mli
@@ -0,0 +1,132 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** The OCaml runtime assumes for type-directed optimizations that all types
+    are "separable". A type is "separable" if either all its inhabitants
+    (the values of this type) are floating-point numbers, or none of them are.
+
+    (Note: This assumption is required for the dynamic float array optimization;
+    it is only made if Config.flat_float_array is set,
+    otherwise the code in this module becomes trivial
+    -- see {!compute_decl}.)
+
+    This soundness requirement could be broken by type declarations mixing
+    existentials and the "[@@unboxed]" annotation. Consider the declaration
+
+    {[
+       type any = Any : 'a -> any [@@unboxed]
+    ]}
+
+   which corresponds to the existential type "exists a. a". If this type is
+   allowed to be unboxed, then it is inhabited by both [float] values
+   and non-[float] values. On the contrary, if unboxing is disallowed, the
+   inhabitants are all blocks with the [Any] constructors pointing to its
+   parameter: they may point to a float, but they are not floats.
+
+   The present module contains a static analysis ensuring that declarations
+   annotated with "[@@unboxed]" can be safely unboxed. The idea is to check
+   the "separability" (in the above sense) of the argument type that would
+   be unboxed, and reject the unboxed declaration if it would create a
+   non-separable type.
+
+   Checking mutually-recursive type declarations is a bit subtle.
+   Consider, for example, the following declarations.
+
+   {[
+      type foo = Foo : 'a t -> foo   [@@unboxed]
+      and 'a t = ...
+   ]}
+
+   Deciding whether the type [foo] should be accepted requires inspecting
+   the declaration of ['a t], which may itself refer to [foo] in turn.
+   In general, the analysis performs a fixpoint computation. It is somewhat
+   similar to what is done for inferring the variance of type parameters.
+
+   Our analysis is defined using inference rules for our judgment
+   [Def; Gamma |- t : m], in which a type expression [t] is checked
+   against a "mode" [m]. This "mode" describes the separability
+   requirement on the type expression (see below for
+   more details). The mode [Gamma] maps type variables to modes and
+   [Def] records the "mode signature" of the mutually-recursive type
+   declarations that are being checked.
+
+   The "mode signature" of a type with parameters [('a, 'b) t] is of the
+   form [('a : m1, 'b : m2) t], where [m1] and [m2] are modes. Its meaning
+   is the following: a concrete instance [(foo, bar) t] of the type is
+   separable if [foo] has mode [m1] and [bar] has mode [m2]. *)
+
+type error =
+  | Non_separable_evar of string option
+exception Error of Location.t * error
+(** Exception raised when a type declaration is not separable, or when its
+    separability cannot be established. *)
+
+type mode = Types.Separability.t = Ind | Sep | Deepsep
+(** The mode [Sep] ("separable") characterizes types that are indeed separable:
+    either they only contain floating-point values, or none of the values
+    at this type are floating-point values.
+    On a type parameter, it indicates that this parameter must be
+    separable for the whole type definition to be separable. For
+    example, the mode signature for the type declaration [type 'a
+    t = 'a] is [('a : Sep) t]. For the right-hand side to be
+    separable, the parameter ['a] must be separable.
+
+    The mode [Ind] ("indifferent") characterizes any type -- separable
+    or not.
+    On a type parameter, it indicates that this parameter needs not be
+    separable for the whole type definition to be separable. For
+    example, [type 'a t = 'a * bool] does not require its parameter
+    ['a] to be separable as ['a * bool] can never contain [float]
+    values. Its mode signature is thus [('a : Ind) t].
+
+    Finally, the mode [Deepsep] ("deeply separable") characterizes
+    types that are separable, and whose type sub-expressions are also
+    separable. This advanced feature is only used in the presence of
+    constraints.
+    For example, [type 'a t = 'b   constraint 'a = 'b * bool]
+    may not be separable even if ['a] is (its separately depends on 'b,
+    a fragment of 'a), so its mode signature is [('a : Deepsep) t].
+
+    The different modes are ordered as [Ind < Sep < Deepsep] (from the least
+    demanding to the most demanding). *)
+
+val compute_decl : Env.t -> Types.type_declaration -> mode list
+(** [compute_decl env def] returns the signature required
+    for the type definition [def] in the typing environment [env]
+    -- including signatures for the current recursive block.
+
+    The {!Error} exception is raised if no such signature exists
+    -- the definition will always be invalid. This only happens
+    when the definition is marked to be unboxed.
+
+    Variant (or record) declarations that are not marked with the
+    "[@@unboxed]" annotation, including those that contain several variants
+    (or labels), are always separable. In particular, their mode signatures
+    do not require anything of their type parameters, which are marked [Ind].
+
+    Finally, if {!Config.flat_float_array} is not set, then separability
+    is not required anymore; we just use [Ind] as the mode of each parameter
+    without any check.
+*)
+
+(** Property interface (see {!Typedecl_properties}). These functions
+    rely on {!compute_decl} and raise the {!Error} exception on error. *)
+type prop = Types.Separability.signature
+val property : (prop, unit) Typedecl_properties.property
+val update_decls :
+  Env.t ->
+  (Ident.t * Typedecl_properties.decl) list ->
+  (Ident.t * Typedecl_properties.decl) list
diff --git a/upstream/ocaml_411/typing/typedecl_unboxed.ml b/upstream/ocaml_411/typing/typedecl_unboxed.ml
new file mode 100644
index 0000000..e2d29a8
--- /dev/null
+++ b/upstream/ocaml_411/typing/typedecl_unboxed.ml
@@ -0,0 +1,57 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Types
+
+type t =
+  | Unavailable
+  | This of type_expr
+  | Only_on_64_bits of type_expr
+
+(* We use the Ctype.expand_head_opt version of expand_head to get access
+   to the manifest type of private abbreviations. *)
+let rec get_unboxed_type_representation env ty fuel =
+  if fuel < 0 then Unavailable else
+  let ty = Ctype.repr (Ctype.expand_head_opt env ty) in
+  match ty.desc with
+  | Tconstr (p, args, _) ->
+    begin match Env.find_type p env with
+    | exception Not_found -> This ty
+    | {type_immediate = Always; _} ->
+        This Predef.type_int
+    | {type_immediate = Always_on_64bits; _} ->
+        Only_on_64_bits Predef.type_int
+    | {type_unboxed = {unboxed = false}} -> This ty
+    | {type_params; type_kind =
+         Type_record ([{ld_type = ty2; _}], _)
+       | Type_variant [{cd_args = Cstr_tuple [ty2]; _}]
+       | Type_variant [{cd_args = Cstr_record [{ld_type = ty2; _}]; _}]}
+
+      ->
+        let ty2 = match ty2.desc with Tpoly (t, _) -> t | _ -> ty2 in
+        get_unboxed_type_representation env
+          (Ctype.apply env type_params ty2 args) (fuel - 1)
+    | {type_kind=Type_abstract} -> Unavailable
+          (* This case can occur when checking a recursive unboxed type
+             declaration. *)
+    | _ -> assert false (* only the above can be unboxed *)
+    end
+  | _ -> This ty
+
+let get_unboxed_type_representation env ty =
+  (* Do not give too much fuel: PR#7424 *)
+  get_unboxed_type_representation env ty 100
+;;
diff --git a/upstream/ocaml_411/typing/typedecl_unboxed.mli b/upstream/ocaml_411/typing/typedecl_unboxed.mli
new file mode 100644
index 0000000..9afd38e
--- /dev/null
+++ b/upstream/ocaml_411/typing/typedecl_unboxed.mli
@@ -0,0 +1,25 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Types
+
+type t =
+  | Unavailable
+  | This of type_expr
+  | Only_on_64_bits of type_expr
+
+(* for typeopt.ml *)
+val get_unboxed_type_representation: Env.t -> type_expr -> t
diff --git a/upstream/ocaml_411/typing/typedecl_variance.ml b/upstream/ocaml_411/typing/typedecl_variance.ml
new file mode 100644
index 0000000..6b3bd28
--- /dev/null
+++ b/upstream/ocaml_411/typing/typedecl_variance.ml
@@ -0,0 +1,384 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Types
+
+module TypeSet = Btype.TypeSet
+module TypeMap = Btype.TypeMap
+
+type surface_variance = bool * bool * bool
+
+type variance_error =
+| Variance_not_satisfied of int
+| No_variable
+| Variance_not_reflected
+| Variance_not_deducible
+
+type error =
+| Bad_variance of variance_error * surface_variance * surface_variance
+| Varying_anonymous
+
+
+exception Error of Location.t * error
+
+(* Compute variance *)
+
+let get_variance ty visited =
+  try TypeMap.find ty !visited with Not_found -> Variance.null
+
+let compute_variance env visited vari ty =
+  let rec compute_variance_rec vari ty =
+    (* Format.eprintf "%a: %x@." Printtyp.type_expr ty (Obj.magic vari); *)
+    let ty = Ctype.repr ty in
+    let vari' = get_variance ty visited in
+    if Variance.subset vari vari' then () else
+    let vari = Variance.union vari vari' in
+    visited := TypeMap.add ty vari !visited;
+    let compute_same = compute_variance_rec vari in
+    match ty.desc with
+      Tarrow (_, ty1, ty2, _) ->
+        let open Variance in
+        let v = conjugate vari in
+        let v1 =
+          if mem May_pos v || mem May_neg v
+          then set May_weak true v else v
+        in
+        compute_variance_rec v1 ty1;
+        compute_same ty2
+    | Ttuple tl ->
+        List.iter compute_same tl
+    | Tconstr (path, tl, _) ->
+        let open Variance in
+        if tl = [] then () else begin
+          try
+            let decl = Env.find_type path env in
+            let cvari f = mem f vari in
+            List.iter2
+              (fun ty v ->
+                let cv f = mem f v in
+                let strict =
+                  cvari Inv && cv Inj || (cvari Pos || cvari Neg) && cv Inv
+                in
+                if strict then compute_variance_rec full ty else
+                let p1 = inter v vari
+                and n1 = inter v (conjugate vari) in
+                let v1 =
+                  union (inter covariant (union p1 (conjugate p1)))
+                    (inter (conjugate covariant) (union n1 (conjugate n1)))
+                and weak =
+                  cvari May_weak && (cv May_pos || cv May_neg) ||
+                  (cvari May_pos || cvari May_neg) && cv May_weak
+                in
+                let v2 = set May_weak weak v1 in
+                compute_variance_rec v2 ty)
+              tl decl.type_variance
+          with Not_found ->
+            List.iter (compute_variance_rec may_inv) tl
+        end
+    | Tobject (ty, _) ->
+        compute_same ty
+    | Tfield (_, _, ty1, ty2) ->
+        compute_same ty1;
+        compute_same ty2
+    | Tsubst ty ->
+        compute_same ty
+    | Tvariant row ->
+        let row = Btype.row_repr row in
+        List.iter
+          (fun (_,f) ->
+            match Btype.row_field_repr f with
+              Rpresent (Some ty) ->
+                compute_same ty
+            | Reither (_, tyl, _, _) ->
+                let open Variance in
+                let upper =
+                  List.fold_left (fun s f -> set f true s)
+                    null [May_pos; May_neg; May_weak]
+                in
+                let v = inter vari upper in
+                (* cf PR#7269:
+                   if List.length tyl > 1 then upper else inter vari upper *)
+                List.iter (compute_variance_rec v) tyl
+            | _ -> ())
+          row.row_fields;
+        compute_same row.row_more
+    | Tpoly (ty, _) ->
+        compute_same ty
+    | Tvar _ | Tnil | Tlink _ | Tunivar _ -> ()
+    | Tpackage (_, _, tyl) ->
+        let v =
+          Variance.(if mem Pos vari || mem Neg vari then full else may_inv)
+        in
+        List.iter (compute_variance_rec v) tyl
+  in
+  compute_variance_rec vari ty
+
+let make p n i =
+  let open Variance in
+  set May_pos p (set May_neg n (set May_weak n (set Inj i null)))
+
+let compute_variance_type env ~check (required, loc) decl tyl =
+  (* Requirements *)
+  let required =
+    List.map (fun (c,n,i) -> if c || n then (c,n,i) else (true,true,i))
+      required
+  in
+  (* Prepare *)
+  let params = List.map Btype.repr decl.type_params in
+  let tvl = ref TypeMap.empty in
+  (* Compute occurrences in the body *)
+  let open Variance in
+  List.iter
+    (fun (cn,ty) ->
+      compute_variance env tvl (if cn then full else covariant) ty)
+    tyl;
+  if check then begin
+    (* Check variance of parameters *)
+    let pos = ref 0 in
+    List.iter2
+      (fun ty (c, n, i) ->
+        incr pos;
+        let var = get_variance ty tvl in
+        let (co,cn) = get_upper var and ij = mem Inj var in
+        if Btype.is_Tvar ty && (co && not c || cn && not n || not ij && i)
+        then raise (Error(loc, Bad_variance
+                                (Variance_not_satisfied !pos,
+                                                        (co,cn,ij),
+                                                        (c,n,i)))))
+      params required;
+    (* Check propagation from constrained parameters *)
+    let args = Btype.newgenty (Ttuple params) in
+    let fvl = Ctype.free_variables args in
+    let fvl = List.filter (fun v -> not (List.memq v params)) fvl in
+    (* If there are no extra variables there is nothing to do *)
+    if fvl = [] then () else
+    let tvl2 = ref TypeMap.empty in
+    List.iter2
+      (fun ty (p,n,_) ->
+        if Btype.is_Tvar ty then () else
+        let v =
+          if p then if n then full else covariant else conjugate covariant in
+        compute_variance env tvl2 v ty)
+      params required;
+    let visited = ref TypeSet.empty in
+    let rec check ty =
+      let ty = Ctype.repr ty in
+      if TypeSet.mem ty !visited then () else
+      let visited' = TypeSet.add ty !visited in
+      visited := visited';
+      let v1 = get_variance ty tvl in
+      let snap = Btype.snapshot () in
+      let v2 =
+        TypeMap.fold
+          (fun t vt v ->
+            if Ctype.equal env false [ty] [t] then union vt v else v)
+          !tvl2 null in
+      Btype.backtrack snap;
+      let (c1,n1) = get_upper v1 and (c2,n2,_,i2) = get_lower v2 in
+      if c1 && not c2 || n1 && not n2 then
+        if List.memq ty fvl then
+          let code = if not i2 then No_variable
+                     else if c2 || n2 then Variance_not_reflected
+                     else Variance_not_deducible in
+          raise (Error (loc, Bad_variance (code, (c1,n1,false), (c2,n2,false))))
+        else
+          Btype.iter_type_expr check ty
+    in
+    List.iter (fun (_,ty) -> check ty) tyl;
+  end;
+  List.map2
+    (fun ty (p, n, i) ->
+      let v = get_variance ty tvl in
+      let tr = decl.type_private in
+      (* Use required variance where relevant *)
+      let concr = decl.type_kind <> Type_abstract (*|| tr = Type_new*) in
+      let (p, n) =
+        if tr = Private || not (Btype.is_Tvar ty) then (p, n) (* set *)
+        else (false, false) (* only check *)
+      and i = concr  || i && tr = Private in
+      let v = union v (make p n i) in
+      let v =
+        if not concr then v else
+        if mem Pos v && mem Neg v then full else
+        if Btype.is_Tvar ty then v else
+        union v
+          (if p then if n then full else covariant else conjugate covariant)
+      in
+      if decl.type_kind = Type_abstract && tr = Public then v else
+      set May_weak (mem May_neg v) v)
+    params required
+
+let add_false = List.map (fun ty -> false, ty)
+
+(* A parameter is constrained if it is either instantiated,
+   or it is a variable appearing in another parameter *)
+let constrained vars ty =
+  match ty.desc with
+  | Tvar _ -> List.exists (fun tl -> List.memq ty tl) vars
+  | _ -> true
+
+let for_constr = function
+  | Types.Cstr_tuple l -> add_false l
+  | Types.Cstr_record l ->
+      List.map
+        (fun {Types.ld_mutable; ld_type} -> (ld_mutable = Mutable, ld_type))
+        l
+
+let compute_variance_gadt env ~check (required, loc as rloc) decl
+    (tl, ret_type_opt) =
+  match ret_type_opt with
+  | None ->
+      compute_variance_type env ~check rloc {decl with type_private = Private}
+        (for_constr tl)
+  | Some ret_type ->
+      match Ctype.repr ret_type with
+      | {desc=Tconstr (_, tyl, _)} ->
+          (* let tyl = List.map (Ctype.expand_head env) tyl in *)
+          let tyl = List.map Ctype.repr tyl in
+          let fvl = List.map (Ctype.free_variables ?env:None) tyl in
+          let _ =
+            List.fold_left2
+              (fun (fv1,fv2) ty (c,n,_) ->
+                match fv2 with [] -> assert false
+                | fv :: fv2 ->
+                    (* fv1 @ fv2 = free_variables of other parameters *)
+                    if (c||n) && constrained (fv1 @ fv2) ty then
+                      raise (Error(loc, Varying_anonymous));
+                    (fv :: fv1, fv2))
+              ([], fvl) tyl required
+          in
+          compute_variance_type env ~check rloc
+            {decl with type_params = tyl; type_private = Private}
+            (for_constr tl)
+      | _ -> assert false
+
+let compute_variance_extension env ~check decl ext rloc =
+  compute_variance_gadt env ~check rloc
+    {decl with type_params = ext.ext_type_params}
+    (ext.ext_args, ext.ext_ret_type)
+
+let compute_variance_decl env ~check decl (required, _ as rloc) =
+  if (decl.type_kind = Type_abstract || decl.type_kind = Type_open)
+       && decl.type_manifest = None then
+    List.map
+      (fun (c, n, i) ->
+        make (not n) (not c) (decl.type_kind <> Type_abstract || i))
+      required
+  else
+  let mn =
+    match decl.type_manifest with
+      None -> []
+    | Some ty -> [false, ty]
+  in
+  match decl.type_kind with
+    Type_abstract | Type_open ->
+      compute_variance_type env ~check rloc decl mn
+  | Type_variant tll ->
+      if List.for_all (fun c -> c.Types.cd_res = None) tll then
+        compute_variance_type env ~check rloc decl
+          (mn @ List.flatten (List.map (fun c -> for_constr c.Types.cd_args)
+                                tll))
+      else begin
+        let mn =
+          List.map (fun (_,ty) -> (Types.Cstr_tuple [ty],None)) mn in
+        let tll =
+          mn @ List.map (fun c -> c.Types.cd_args, c.Types.cd_res) tll in
+        match List.map (compute_variance_gadt env ~check rloc decl) tll with
+        | vari :: rem ->
+            let varl = List.fold_left (List.map2 Variance.union) vari rem in
+            List.map
+              Variance.(fun v -> if mem Pos v && mem Neg v then full else v)
+              varl
+        | _ -> assert false
+      end
+  | Type_record (ftl, _) ->
+      compute_variance_type env ~check rloc decl
+        (mn @ List.map (fun {Types.ld_mutable; ld_type} ->
+             (ld_mutable = Mutable, ld_type)) ftl)
+
+let is_hash id =
+  let s = Ident.name id in
+  String.length s > 0 && s.[0] = '#'
+
+let check_variance_extension env decl ext rloc =
+  (* TODO: refactorize compute_variance_extension *)
+  ignore (compute_variance_extension env ~check:true decl
+    ext.Typedtree.ext_type rloc)
+
+let compute_decl env ~check decl req =
+  compute_variance_decl env ~check decl (req, decl.type_loc)
+
+let check_decl env decl req =
+  ignore (compute_variance_decl env ~check:true decl (req, decl.type_loc))
+
+type prop = Variance.t list
+type req = surface_variance list
+let property : (prop, req) Typedecl_properties.property =
+  let open Typedecl_properties in
+  let eq li1 li2 =
+    try List.for_all2 Variance.eq li1 li2 with _ -> false in
+  let merge ~prop ~new_prop =
+    List.map2 Variance.union prop new_prop in
+  let default decl =
+    List.map (fun _ -> Variance.null) decl.type_params in
+  let compute env decl req =
+    compute_decl env ~check:false decl req in
+  let update_decl decl variance =
+    { decl with type_variance = variance } in
+  let check env id decl req =
+    if is_hash id then () else check_decl env decl req in
+  {
+    eq;
+    merge;
+    default;
+    compute;
+    update_decl;
+    check;
+  }
+
+let transl_variance : Asttypes.variance -> _ = function
+  | Covariant -> (true, false, false)
+  | Contravariant -> (false, true, false)
+  | Invariant -> (false, false, false)
+
+let variance_of_params ptype_params =
+  List.map transl_variance (List.map snd ptype_params)
+
+let variance_of_sdecl sdecl =
+  variance_of_params sdecl.Parsetree.ptype_params
+
+let update_decls env sdecls decls =
+  let required = List.map variance_of_sdecl sdecls in
+  Typedecl_properties.compute_property property env decls required
+
+let update_class_decls env cldecls =
+  let decls, required =
+    List.fold_right
+      (fun (obj_id, obj_abbr, _cl_abbr, _clty, _cltydef, ci) (decls, req) ->
+        (obj_id, obj_abbr) :: decls,
+        variance_of_params ci.Typedtree.ci_params :: req)
+      cldecls ([],[])
+  in
+  let decls =
+    Typedecl_properties.compute_property property env decls required in
+  List.map2
+    (fun (_,decl) (_, _, cl_abbr, clty, cltydef, _) ->
+      let variance = decl.type_variance in
+      (decl, {cl_abbr with type_variance = variance},
+       {clty with cty_variance = variance},
+       {cltydef with clty_variance = variance}))
+    decls cldecls
diff --git a/upstream/ocaml_411/typing/typedecl_variance.mli b/upstream/ocaml_411/typing/typedecl_variance.mli
new file mode 100644
index 0000000..99ce18d
--- /dev/null
+++ b/upstream/ocaml_411/typing/typedecl_variance.mli
@@ -0,0 +1,62 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Types
+open Typedecl_properties
+
+type surface_variance = bool * bool * bool
+
+val variance_of_params :
+  (Parsetree.core_type * Asttypes.variance) list -> surface_variance list
+val variance_of_sdecl :
+  Parsetree.type_declaration -> surface_variance list
+
+type prop = Variance.t list
+type req = surface_variance list
+val property : (Variance.t list, req) property
+
+type variance_error =
+| Variance_not_satisfied of int
+| No_variable
+| Variance_not_reflected
+| Variance_not_deducible
+
+type error =
+| Bad_variance of variance_error * surface_variance * surface_variance
+| Varying_anonymous
+
+exception Error of Location.t * error
+
+val check_variance_extension :
+  Env.t -> type_declaration ->
+  Typedtree.extension_constructor -> req * Location.t -> unit
+
+val compute_decl :
+  Env.t -> check:bool -> type_declaration -> req -> prop
+
+val update_decls :
+  Env.t -> Parsetree.type_declaration list ->
+  (Ident.t * type_declaration) list ->
+  (Ident.t * type_declaration) list
+
+val update_class_decls :
+  Env.t ->
+  (Ident.t * Typedecl_properties.decl * Types.type_declaration *
+   Types.class_declaration * Types.class_type_declaration *
+   'a Typedtree.class_infos) list ->
+  (Typedecl_properties.decl * Types.type_declaration *
+   Types.class_declaration * Types.class_type_declaration) list
+(* FIXME: improve this horrible interface *)
diff --git a/upstream/ocaml_411/typing/typedtree.ml b/upstream/ocaml_411/typing/typedtree.ml
new file mode 100644
index 0000000..c2d0a0c
--- /dev/null
+++ b/upstream/ocaml_411/typing/typedtree.ml
@@ -0,0 +1,841 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Abstract syntax tree after typing *)
+
+open Asttypes
+open Types
+
+(* Value expressions for the core language *)
+
+type partial = Partial | Total
+
+type attribute = Parsetree.attribute
+type attributes = attribute list
+
+type value = Value_pattern
+type computation = Computation_pattern
+
+type _ pattern_category =
+| Value : value pattern_category
+| Computation : computation pattern_category
+
+type pattern = value general_pattern
+and 'k general_pattern = 'k pattern_desc pattern_data
+
+and 'a pattern_data =
+  { pat_desc: 'a;
+    pat_loc: Location.t;
+    pat_extra : (pat_extra * Location.t * attribute list) list;
+    pat_type: type_expr;
+    pat_env: Env.t;
+    pat_attributes: attribute list;
+   }
+
+and pat_extra =
+  | Tpat_constraint of core_type
+  | Tpat_type of Path.t * Longident.t loc
+  | Tpat_open of Path.t * Longident.t loc * Env.t
+  | Tpat_unpack
+
+and 'k pattern_desc =
+  (* value patterns *)
+  | Tpat_any : value pattern_desc
+  | Tpat_var : Ident.t * string loc -> value pattern_desc
+  | Tpat_alias :
+      value general_pattern * Ident.t * string loc -> value pattern_desc
+  | Tpat_constant : constant -> value pattern_desc
+  | Tpat_tuple : value general_pattern list -> value pattern_desc
+  | Tpat_construct :
+      Longident.t loc * constructor_description * value general_pattern list ->
+      value pattern_desc
+  | Tpat_variant :
+      label * value general_pattern option * row_desc ref ->
+      value pattern_desc
+  | Tpat_record :
+      (Longident.t loc * label_description * value general_pattern) list *
+        closed_flag ->
+      value pattern_desc
+  | Tpat_array : value general_pattern list -> value pattern_desc
+  | Tpat_lazy : value general_pattern -> value pattern_desc
+  (* computation patterns *)
+  | Tpat_value : tpat_value_argument -> computation pattern_desc
+  | Tpat_exception : value general_pattern -> computation pattern_desc
+  (* generic constructions *)
+  | Tpat_or :
+      'k general_pattern * 'k general_pattern * row_desc option ->
+      'k pattern_desc
+
+and tpat_value_argument = value general_pattern
+
+and expression =
+  { exp_desc: expression_desc;
+    exp_loc: Location.t;
+    exp_extra: (exp_extra * Location.t * attribute list) list;
+    exp_type: type_expr;
+    exp_env: Env.t;
+    exp_attributes: attribute list;
+   }
+
+and exp_extra =
+  | Texp_constraint of core_type
+  | Texp_coerce of core_type option * core_type
+  | Texp_poly of core_type option
+  | Texp_newtype of string
+
+and expression_desc =
+    Texp_ident of Path.t * Longident.t loc * Types.value_description
+  | Texp_constant of constant
+  | Texp_let of rec_flag * value_binding list * expression
+  | Texp_function of { arg_label : arg_label; param : Ident.t;
+      cases : value case list; partial : partial; }
+  | Texp_apply of expression * (arg_label * expression option) list
+  | Texp_match of expression * computation case list * partial
+  | Texp_try of expression * value case list
+  | Texp_tuple of expression list
+  | Texp_construct of
+      Longident.t loc * constructor_description * expression list
+  | Texp_variant of label * expression option
+  | Texp_record of {
+      fields : ( Types.label_description * record_label_definition ) array;
+      representation : Types.record_representation;
+      extended_expression : expression option;
+    }
+  | Texp_field of expression * Longident.t loc * label_description
+  | Texp_setfield of
+      expression * Longident.t loc * label_description * expression
+  | Texp_array of expression list
+  | Texp_ifthenelse of expression * expression * expression option
+  | Texp_sequence of expression * expression
+  | Texp_while of expression * expression
+  | Texp_for of
+      Ident.t * Parsetree.pattern * expression * expression * direction_flag *
+        expression
+  | Texp_send of expression * meth * expression option
+  | Texp_new of Path.t * Longident.t loc * Types.class_declaration
+  | Texp_instvar of Path.t * Path.t * string loc
+  | Texp_setinstvar of Path.t * Path.t * string loc * expression
+  | Texp_override of Path.t * (Path.t * string loc * expression) list
+  | Texp_letmodule of
+      Ident.t option * string option loc * Types.module_presence * module_expr *
+        expression
+  | Texp_letexception of extension_constructor * expression
+  | Texp_assert of expression
+  | Texp_lazy of expression
+  | Texp_object of class_structure * string list
+  | Texp_pack of module_expr
+  | Texp_letop of {
+      let_ : binding_op;
+      ands : binding_op list;
+      param : Ident.t;
+      body : value case;
+      partial : partial;
+    }
+  | Texp_unreachable
+  | Texp_extension_constructor of Longident.t loc * Path.t
+  | Texp_open of open_declaration * expression
+
+and meth =
+    Tmeth_name of string
+  | Tmeth_val of Ident.t
+
+and 'k case =
+    {
+     c_lhs: 'k general_pattern;
+     c_guard: expression option;
+     c_rhs: expression;
+    }
+
+and record_label_definition =
+  | Kept of Types.type_expr
+  | Overridden of Longident.t loc * expression
+
+and binding_op =
+  {
+    bop_op_path : Path.t;
+    bop_op_name : string loc;
+    bop_op_val : Types.value_description;
+    bop_op_type : Types.type_expr;
+    bop_exp : expression;
+    bop_loc : Location.t;
+  }
+
+(* Value expressions for the class language *)
+
+and class_expr =
+    {
+     cl_desc: class_expr_desc;
+     cl_loc: Location.t;
+     cl_type: Types.class_type;
+     cl_env: Env.t;
+     cl_attributes: attribute list;
+    }
+
+and class_expr_desc =
+    Tcl_ident of Path.t * Longident.t loc * core_type list
+  | Tcl_structure of class_structure
+  | Tcl_fun of
+      arg_label * pattern * (Ident.t * expression) list
+      * class_expr * partial
+  | Tcl_apply of class_expr * (arg_label * expression option) list
+  | Tcl_let of rec_flag * value_binding list *
+                  (Ident.t * expression) list * class_expr
+  | Tcl_constraint of
+      class_expr * class_type option * string list * string list * Concr.t
+    (* Visible instance variables, methods and concrete methods *)
+  | Tcl_open of open_description * class_expr
+
+and class_structure =
+  {
+   cstr_self: pattern;
+   cstr_fields: class_field list;
+   cstr_type: Types.class_signature;
+   cstr_meths: Ident.t Meths.t;
+  }
+
+and class_field =
+   {
+    cf_desc: class_field_desc;
+    cf_loc: Location.t;
+    cf_attributes: attribute list;
+  }
+
+and class_field_kind =
+  | Tcfk_virtual of core_type
+  | Tcfk_concrete of override_flag * expression
+
+and class_field_desc =
+    Tcf_inherit of
+      override_flag * class_expr * string option * (string * Ident.t) list *
+        (string * Ident.t) list
+    (* Inherited instance variables and concrete methods *)
+  | Tcf_val of string loc * mutable_flag * Ident.t * class_field_kind * bool
+  | Tcf_method of string loc * private_flag * class_field_kind
+  | Tcf_constraint of core_type * core_type
+  | Tcf_initializer of expression
+  | Tcf_attribute of attribute
+
+(* Value expressions for the module language *)
+
+and module_expr =
+  { mod_desc: module_expr_desc;
+    mod_loc: Location.t;
+    mod_type: Types.module_type;
+    mod_env: Env.t;
+    mod_attributes: attribute list;
+   }
+
+and module_type_constraint =
+  Tmodtype_implicit
+| Tmodtype_explicit of module_type
+
+and functor_parameter =
+  | Unit
+  | Named of Ident.t option * string option loc * module_type
+
+and module_expr_desc =
+    Tmod_ident of Path.t * Longident.t loc
+  | Tmod_structure of structure
+  | Tmod_functor of functor_parameter * module_expr
+  | Tmod_apply of module_expr * module_expr * module_coercion
+  | Tmod_constraint of
+      module_expr * Types.module_type * module_type_constraint * module_coercion
+  | Tmod_unpack of expression * Types.module_type
+
+and structure = {
+  str_items : structure_item list;
+  str_type : Types.signature;
+  str_final_env : Env.t;
+}
+
+and structure_item =
+  { str_desc : structure_item_desc;
+    str_loc : Location.t;
+    str_env : Env.t
+  }
+
+and structure_item_desc =
+    Tstr_eval of expression * attributes
+  | Tstr_value of rec_flag * value_binding list
+  | Tstr_primitive of value_description
+  | Tstr_type of rec_flag * type_declaration list
+  | Tstr_typext of type_extension
+  | Tstr_exception of type_exception
+  | Tstr_module of module_binding
+  | Tstr_recmodule of module_binding list
+  | Tstr_modtype of module_type_declaration
+  | Tstr_open of open_declaration
+  | Tstr_class of (class_declaration * string list) list
+  | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list
+  | Tstr_include of include_declaration
+  | Tstr_attribute of attribute
+
+and module_binding =
+    {
+     mb_id: Ident.t option;
+     mb_name: string option loc;
+     mb_presence: module_presence;
+     mb_expr: module_expr;
+     mb_attributes: attribute list;
+     mb_loc: Location.t;
+    }
+
+and value_binding =
+  {
+    vb_pat: pattern;
+    vb_expr: expression;
+    vb_attributes: attributes;
+    vb_loc: Location.t;
+  }
+
+and module_coercion =
+    Tcoerce_none
+  | Tcoerce_structure of (int * module_coercion) list *
+                         (Ident.t * int * module_coercion) list
+  | Tcoerce_functor of module_coercion * module_coercion
+  | Tcoerce_primitive of primitive_coercion
+  | Tcoerce_alias of Env.t * Path.t * module_coercion
+
+and module_type =
+  { mty_desc: module_type_desc;
+    mty_type : Types.module_type;
+    mty_env : Env.t;
+    mty_loc: Location.t;
+    mty_attributes: attribute list;
+   }
+
+and module_type_desc =
+    Tmty_ident of Path.t * Longident.t loc
+  | Tmty_signature of signature
+  | Tmty_functor of functor_parameter * module_type
+  | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list
+  | Tmty_typeof of module_expr
+  | Tmty_alias of Path.t * Longident.t loc
+
+(* Keep primitive type information for type-based lambda-code specialization *)
+and primitive_coercion =
+  {
+    pc_desc: Primitive.description;
+    pc_type: type_expr;
+    pc_env: Env.t;
+    pc_loc : Location.t;
+  }
+
+and signature = {
+  sig_items : signature_item list;
+  sig_type : Types.signature;
+  sig_final_env : Env.t;
+}
+
+and signature_item =
+  { sig_desc: signature_item_desc;
+    sig_env : Env.t; (* BINANNOT ADDED *)
+    sig_loc: Location.t }
+
+and signature_item_desc =
+    Tsig_value of value_description
+  | Tsig_type of rec_flag * type_declaration list
+  | Tsig_typesubst of type_declaration list
+  | Tsig_typext of type_extension
+  | Tsig_exception of type_exception
+  | Tsig_module of module_declaration
+  | Tsig_modsubst of module_substitution
+  | Tsig_recmodule of module_declaration list
+  | Tsig_modtype of module_type_declaration
+  | Tsig_open of open_description
+  | Tsig_include of include_description
+  | Tsig_class of class_description list
+  | Tsig_class_type of class_type_declaration list
+  | Tsig_attribute of attribute
+
+and module_declaration =
+    {
+     md_id: Ident.t option;
+     md_name: string option loc;
+     md_presence: module_presence;
+     md_type: module_type;
+     md_attributes: attribute list;
+     md_loc: Location.t;
+    }
+
+and module_substitution =
+    {
+     ms_id: Ident.t;
+     ms_name: string loc;
+     ms_manifest: Path.t;
+     ms_txt: Longident.t loc;
+     ms_attributes: attributes;
+     ms_loc: Location.t;
+    }
+
+and module_type_declaration =
+    {
+     mtd_id: Ident.t;
+     mtd_name: string loc;
+     mtd_type: module_type option;
+     mtd_attributes: attribute list;
+     mtd_loc: Location.t;
+    }
+
+and 'a open_infos =
+    {
+     open_expr: 'a;
+     open_bound_items: Types.signature;
+     open_override: override_flag;
+     open_env: Env.t;
+     open_loc: Location.t;
+     open_attributes: attribute list;
+    }
+
+and open_description = (Path.t * Longident.t loc) open_infos
+
+and open_declaration = module_expr open_infos
+
+and 'a include_infos =
+    {
+     incl_mod: 'a;
+     incl_type: Types.signature;
+     incl_loc: Location.t;
+     incl_attributes: attribute list;
+    }
+
+and include_description = module_type include_infos
+
+and include_declaration = module_expr include_infos
+
+and with_constraint =
+    Twith_type of type_declaration
+  | Twith_module of Path.t * Longident.t loc
+  | Twith_typesubst of type_declaration
+  | Twith_modsubst of Path.t * Longident.t loc
+
+and core_type =
+(* mutable because of [Typeclass.declare_method] *)
+  { mutable ctyp_desc : core_type_desc;
+    mutable ctyp_type : type_expr;
+    ctyp_env : Env.t; (* BINANNOT ADDED *)
+    ctyp_loc : Location.t;
+    ctyp_attributes: attribute list;
+   }
+
+and core_type_desc =
+    Ttyp_any
+  | Ttyp_var of string
+  | Ttyp_arrow of arg_label * core_type * core_type
+  | Ttyp_tuple of core_type list
+  | Ttyp_constr of Path.t * Longident.t loc * core_type list
+  | Ttyp_object of object_field list * closed_flag
+  | Ttyp_class of Path.t * Longident.t loc * core_type list
+  | Ttyp_alias of core_type * string
+  | Ttyp_variant of row_field list * closed_flag * label list option
+  | Ttyp_poly of string list * core_type
+  | Ttyp_package of package_type
+
+and package_type = {
+  pack_path : Path.t;
+  pack_fields : (Longident.t loc * core_type) list;
+  pack_type : Types.module_type;
+  pack_txt : Longident.t loc;
+}
+
+and row_field = {
+  rf_desc : row_field_desc;
+  rf_loc : Location.t;
+  rf_attributes : attributes;
+}
+
+and row_field_desc =
+    Ttag of string loc * bool * core_type list
+  | Tinherit of core_type
+
+and object_field = {
+  of_desc : object_field_desc;
+  of_loc : Location.t;
+  of_attributes : attributes;
+}
+
+and object_field_desc =
+  | OTtag of string loc * core_type
+  | OTinherit of core_type
+
+and value_description =
+  { val_id: Ident.t;
+    val_name: string loc;
+    val_desc: core_type;
+    val_val: Types.value_description;
+    val_prim: string list;
+    val_loc: Location.t;
+    val_attributes: attribute list;
+    }
+
+and type_declaration =
+  { typ_id: Ident.t;
+    typ_name: string loc;
+    typ_params: (core_type * variance) list;
+    typ_type: Types.type_declaration;
+    typ_cstrs: (core_type * core_type * Location.t) list;
+    typ_kind: type_kind;
+    typ_private: private_flag;
+    typ_manifest: core_type option;
+    typ_loc: Location.t;
+    typ_attributes: attribute list;
+   }
+
+and type_kind =
+    Ttype_abstract
+  | Ttype_variant of constructor_declaration list
+  | Ttype_record of label_declaration list
+  | Ttype_open
+
+and label_declaration =
+    {
+     ld_id: Ident.t;
+     ld_name: string loc;
+     ld_mutable: mutable_flag;
+     ld_type: core_type;
+     ld_loc: Location.t;
+     ld_attributes: attribute list;
+    }
+
+and constructor_declaration =
+    {
+     cd_id: Ident.t;
+     cd_name: string loc;
+     cd_args: constructor_arguments;
+     cd_res: core_type option;
+     cd_loc: Location.t;
+     cd_attributes: attribute list;
+    }
+
+and constructor_arguments =
+  | Cstr_tuple of core_type list
+  | Cstr_record of label_declaration list
+
+and type_extension =
+  {
+    tyext_path: Path.t;
+    tyext_txt: Longident.t loc;
+    tyext_params: (core_type * variance) list;
+    tyext_constructors: extension_constructor list;
+    tyext_private: private_flag;
+    tyext_loc: Location.t;
+    tyext_attributes: attribute list;
+  }
+
+and type_exception =
+  {
+    tyexn_constructor: extension_constructor;
+    tyexn_loc: Location.t;
+    tyexn_attributes: attribute list;
+  }
+
+and extension_constructor =
+  {
+    ext_id: Ident.t;
+    ext_name: string loc;
+    ext_type: Types.extension_constructor;
+    ext_kind: extension_constructor_kind;
+    ext_loc: Location.t;
+    ext_attributes: attribute list;
+  }
+
+and extension_constructor_kind =
+    Text_decl of constructor_arguments * core_type option
+  | Text_rebind of Path.t * Longident.t loc
+
+and class_type =
+    {
+     cltyp_desc: class_type_desc;
+     cltyp_type: Types.class_type;
+     cltyp_env: Env.t;
+     cltyp_loc: Location.t;
+     cltyp_attributes: attribute list;
+    }
+
+and class_type_desc =
+    Tcty_constr of Path.t * Longident.t loc * core_type list
+  | Tcty_signature of class_signature
+  | Tcty_arrow of arg_label * core_type * class_type
+  | Tcty_open of open_description * class_type
+
+and class_signature = {
+    csig_self: core_type;
+    csig_fields: class_type_field list;
+    csig_type: Types.class_signature;
+  }
+
+and class_type_field = {
+    ctf_desc: class_type_field_desc;
+    ctf_loc: Location.t;
+    ctf_attributes: attribute list;
+  }
+
+and class_type_field_desc =
+  | Tctf_inherit of class_type
+  | Tctf_val of (string * mutable_flag * virtual_flag * core_type)
+  | Tctf_method of (string * private_flag * virtual_flag * core_type)
+  | Tctf_constraint of (core_type * core_type)
+  | Tctf_attribute of attribute
+
+and class_declaration =
+  class_expr class_infos
+
+and class_description =
+  class_type class_infos
+
+and class_type_declaration =
+  class_type class_infos
+
+and 'a class_infos =
+  { ci_virt: virtual_flag;
+    ci_params: (core_type * variance) list;
+    ci_id_name: string loc;
+    ci_id_class: Ident.t;
+    ci_id_class_type: Ident.t;
+    ci_id_object: Ident.t;
+    ci_id_typehash: Ident.t;
+    ci_expr: 'a;
+    ci_decl: Types.class_declaration;
+    ci_type_decl: Types.class_type_declaration;
+    ci_loc: Location.t;
+    ci_attributes: attribute list;
+   }
+
+(* Auxiliary functions over the a.s.t. *)
+
+let as_computation_pattern (p : pattern) : computation general_pattern =
+  {
+    pat_desc = Tpat_value p;
+    pat_loc = p.pat_loc;
+    pat_extra = [];
+    pat_type = p.pat_type;
+    pat_env = p.pat_env;
+    pat_attributes = [];
+  }
+
+let rec classify_pattern_desc : type k . k pattern_desc -> k pattern_category =
+  function
+  | Tpat_alias _ -> Value
+  | Tpat_tuple _ -> Value
+  | Tpat_construct _ -> Value
+  | Tpat_variant _ -> Value
+  | Tpat_record _ -> Value
+  | Tpat_array _ -> Value
+  | Tpat_lazy _ -> Value
+  | Tpat_any -> Value
+  | Tpat_var _ -> Value
+  | Tpat_constant _ -> Value
+
+  | Tpat_value _ -> Computation
+  | Tpat_exception _ -> Computation
+
+  | Tpat_or(p1, p2, _) ->
+     begin match classify_pattern p1, classify_pattern p2 with
+     | Value, Value -> Value
+     | Computation, Computation -> Computation
+     end
+
+and classify_pattern
+  : type k . k general_pattern -> k pattern_category
+  = fun pat ->
+  classify_pattern_desc pat.pat_desc
+
+type pattern_action =
+  { f : 'k . 'k general_pattern -> unit }
+let shallow_iter_pattern_desc
+  : type k . pattern_action -> k pattern_desc -> unit
+  = fun f -> function
+  | Tpat_alias(p, _, _) -> f.f p
+  | Tpat_tuple patl -> List.iter f.f patl
+  | Tpat_construct(_, _, patl) -> List.iter f.f patl
+  | Tpat_variant(_, pat, _) -> Option.iter f.f pat
+  | Tpat_record (lbl_pat_list, _) ->
+      List.iter (fun (_, _, pat) -> f.f pat) lbl_pat_list
+  | Tpat_array patl -> List.iter f.f patl
+  | Tpat_lazy p -> f.f p
+  | Tpat_any
+  | Tpat_var _
+  | Tpat_constant _ -> ()
+  | Tpat_value p -> f.f p
+  | Tpat_exception p -> f.f p
+  | Tpat_or(p1, p2, _) -> f.f p1; f.f p2
+
+type pattern_transformation =
+  { f : 'k . 'k general_pattern -> 'k general_pattern }
+let shallow_map_pattern_desc
+  : type k . pattern_transformation -> k pattern_desc -> k pattern_desc
+  = fun f d -> match d with
+  | Tpat_alias (p1, id, s) ->
+      Tpat_alias (f.f p1, id, s)
+  | Tpat_tuple pats ->
+      Tpat_tuple (List.map f.f pats)
+  | Tpat_record (lpats, closed) ->
+      Tpat_record (List.map (fun (lid, l,p) -> lid, l, f.f p) lpats, closed)
+  | Tpat_construct (lid, c,pats) ->
+      Tpat_construct (lid, c, List.map f.f pats)
+  | Tpat_array pats ->
+      Tpat_array (List.map f.f pats)
+  | Tpat_lazy p1 -> Tpat_lazy (f.f p1)
+  | Tpat_variant (x1, Some p1, x2) ->
+      Tpat_variant (x1, Some (f.f p1), x2)
+  | Tpat_var _
+  | Tpat_constant _
+  | Tpat_any
+  | Tpat_variant (_,None,_) -> d
+  | Tpat_value p -> Tpat_value (f.f p)
+  | Tpat_exception p -> Tpat_exception (f.f p)
+  | Tpat_or (p1,p2,path) ->
+      Tpat_or (f.f p1, f.f p2, path)
+
+let rec iter_general_pattern
+  : type k . pattern_action -> k general_pattern -> unit
+  = fun f p ->
+  f.f p;
+  shallow_iter_pattern_desc
+    { f = fun p -> iter_general_pattern f p }
+    p.pat_desc
+
+let iter_pattern (f : pattern -> unit) =
+  iter_general_pattern
+    { f = fun (type k) (p : k general_pattern) ->
+          match classify_pattern p with
+          | Value -> f p
+          | Computation -> () }
+
+let rec map_general_pattern
+  : type k . pattern_transformation -> k general_pattern -> k general_pattern
+  = fun f p ->
+  let pat_desc =
+    shallow_map_pattern_desc
+      { f = fun p -> map_general_pattern f p }
+      p.pat_desc in
+  f.f { p with pat_desc }
+
+type pattern_predicate = { f : 'k . 'k general_pattern -> bool }
+let exists_general_pattern (f : pattern_predicate) p =
+  let exception Found in
+  match
+    iter_general_pattern
+      { f = fun p -> if f.f p then raise Found else () }
+      p
+  with
+  | exception Found -> true
+  | () -> false
+
+let exists_pattern (f : pattern -> bool) =
+  exists_general_pattern
+    { f = fun (type k) (p : k general_pattern) ->
+          match classify_pattern p with
+          | Value -> f p
+          | Computation -> false }
+
+
+(* List the identifiers bound by a pattern or a let *)
+
+let rec iter_bound_idents
+  : type k . _ -> k general_pattern -> _
+  = fun f pat ->
+  match pat.pat_desc with
+  | Tpat_var (id,s) ->
+     f (id,s,pat.pat_type)
+  | Tpat_alias(p, id, s) ->
+      iter_bound_idents f p;
+      f (id,s,pat.pat_type)
+  | Tpat_or(p1, _, _) ->
+      (* Invariant : both arguments bind the same variables *)
+      iter_bound_idents f p1
+  | d ->
+     shallow_iter_pattern_desc
+       { f = fun p -> iter_bound_idents f p }
+       d
+
+let rev_pat_bound_idents_full pat =
+  let idents_full = ref [] in
+  let add id_full = idents_full := id_full :: !idents_full in
+  iter_bound_idents add pat;
+  !idents_full
+
+let rev_only_idents idents_full =
+  List.rev_map (fun (id,_,_) -> id) idents_full
+
+let pat_bound_idents_full pat =
+  List.rev (rev_pat_bound_idents_full pat)
+let pat_bound_idents pat =
+  rev_only_idents (rev_pat_bound_idents_full pat)
+
+let rev_let_bound_idents_full bindings =
+  let idents_full = ref [] in
+  let add id_full = idents_full := id_full :: !idents_full in
+  List.iter (fun vb -> iter_bound_idents add vb.vb_pat) bindings;
+  !idents_full
+
+let let_bound_idents_full bindings =
+  List.rev (rev_let_bound_idents_full bindings)
+let let_bound_idents pat =
+  rev_only_idents (rev_let_bound_idents_full pat)
+
+let alpha_var env id = List.assoc id env
+
+let rec alpha_pat
+  : type k . _ -> k general_pattern -> k general_pattern
+  = fun env p -> match p.pat_desc with
+  | Tpat_var (id, s) -> (* note the ``Not_found'' case *)
+      {p with pat_desc =
+       try Tpat_var (alpha_var env id, s) with
+       | Not_found -> Tpat_any}
+  | Tpat_alias (p1, id, s) ->
+      let new_p =  alpha_pat env p1 in
+      begin try
+        {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s)}
+      with
+      | Not_found -> new_p
+      end
+  | d ->
+     let pat_desc =
+       shallow_map_pattern_desc { f = fun p -> alpha_pat env p } d in
+     {p with pat_desc}
+
+let mkloc = Location.mkloc
+let mknoloc = Location.mknoloc
+
+let split_pattern pat =
+  let combine_opts merge p1 p2 =
+    match p1, p2 with
+    | None, None -> None
+    | Some p, None
+    | None, Some p ->
+        Some p
+    | Some p1, Some p2 ->
+        Some (merge p1 p2)
+  in
+  let into pat p1 p2 =
+    (* The third parameter of [Tpat_or] is [Some _] only for "#typ"
+       patterns, which we do *not* expand. Hence we can put [None] here. *)
+    { pat with pat_desc = Tpat_or (p1, p2, None) } in
+  let rec split_pattern cpat =
+    match cpat.pat_desc with
+    | Tpat_value p ->
+        Some p, None
+    | Tpat_exception p ->
+        None, Some p
+    | Tpat_or (cp1, cp2, _) ->
+        let vals1, exns1 = split_pattern cp1 in
+        let vals2, exns2 = split_pattern cp2 in
+        combine_opts (into cpat) vals1 vals2,
+        (* We could change the pattern type for exception patterns to
+           [Predef.exn], but it doesn't really matter. *)
+        combine_opts (into cpat) exns1 exns2
+  in
+  split_pattern pat
diff --git a/upstream/ocaml_411/typing/typedtree.mli b/upstream/ocaml_411/typing/typedtree.mli
new file mode 100644
index 0000000..a8f8d24
--- /dev/null
+++ b/upstream/ocaml_411/typing/typedtree.mli
@@ -0,0 +1,805 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Abstract syntax tree after typing *)
+
+
+(** By comparison with {!Parsetree}:
+    - Every {!Longindent.t} is accompanied by a resolved {!Path.t}.
+
+*)
+
+open Asttypes
+
+(* Value expressions for the core language *)
+
+type partial = Partial | Total
+
+(** {1 Extension points} *)
+
+type attribute = Parsetree.attribute
+type attributes = attribute list
+
+(** {1 Core language} *)
+
+type value = Value_pattern
+type computation = Computation_pattern
+
+type _ pattern_category =
+| Value : value pattern_category
+| Computation : computation pattern_category
+
+type pattern = value general_pattern
+and 'k general_pattern = 'k pattern_desc pattern_data
+
+and 'a pattern_data =
+  { pat_desc: 'a;
+    pat_loc: Location.t;
+    pat_extra : (pat_extra * Location.t * attributes) list;
+    pat_type: Types.type_expr;
+    pat_env: Env.t;
+    pat_attributes: attributes;
+   }
+
+and pat_extra =
+  | Tpat_constraint of core_type
+        (** P : T          { pat_desc = P
+                           ; pat_extra = (Tpat_constraint T, _, _) :: ... }
+         *)
+  | Tpat_type of Path.t * Longident.t loc
+        (** #tconst        { pat_desc = disjunction
+                           ; pat_extra = (Tpat_type (P, "tconst"), _, _) :: ...}
+
+                           where [disjunction] is a [Tpat_or _] representing the
+                           branches of [tconst].
+         *)
+  | Tpat_open of Path.t * Longident.t loc * Env.t
+  | Tpat_unpack
+        (** (module P)     { pat_desc  = Tpat_var "P"
+                           ; pat_extra = (Tpat_unpack, _, _) :: ... }
+         *)
+
+and 'k pattern_desc =
+  (* value patterns *)
+  | Tpat_any : value pattern_desc
+        (** _ *)
+  | Tpat_var : Ident.t * string loc -> value pattern_desc
+        (** x *)
+  | Tpat_alias :
+      value general_pattern * Ident.t * string loc -> value pattern_desc
+        (** P as a *)
+  | Tpat_constant : constant -> value pattern_desc
+        (** 1, 'a', "true", 1.0, 1l, 1L, 1n *)
+  | Tpat_tuple : value general_pattern list -> value pattern_desc
+        (** (P1, ..., Pn)
+
+            Invariant: n >= 2
+         *)
+  | Tpat_construct :
+      Longident.t loc * Types.constructor_description *
+        value general_pattern list ->
+      value pattern_desc
+        (** C                []
+            C P              [P]
+            C (P1, ..., Pn)  [P1; ...; Pn]
+          *)
+  | Tpat_variant :
+      label * value general_pattern option * Types.row_desc ref ->
+      value pattern_desc
+        (** `A             (None)
+            `A P           (Some P)
+
+            See {!Types.row_desc} for an explanation of the last parameter.
+         *)
+  | Tpat_record :
+      (Longident.t loc * Types.label_description * value general_pattern) list *
+        closed_flag ->
+      value pattern_desc
+        (** { l1=P1; ...; ln=Pn }     (flag = Closed)
+            { l1=P1; ...; ln=Pn; _}   (flag = Open)
+
+            Invariant: n > 0
+         *)
+  | Tpat_array : value general_pattern list -> value pattern_desc
+        (** [| P1; ...; Pn |] *)
+  | Tpat_lazy : value general_pattern -> value pattern_desc
+        (** lazy P *)
+  (* computation patterns *)
+  | Tpat_value : tpat_value_argument -> computation pattern_desc
+        (** P
+
+            Invariant: Tpat_value pattern should not carry
+            pat_attributes or pat_extra metadata coming from user
+            syntax, which must be on the inner pattern node -- to
+            facilitate searching for a certain value pattern
+            constructor with a specific attributed.
+
+            To enforce this restriction, we made the argument of
+            the Tpat_value constructor a private synonym of [pattern],
+            requiring you to use the [as_computation_pattern] function
+            below instead of using the [Tpat_value] constructor directly.
+         *)
+  | Tpat_exception : value general_pattern -> computation pattern_desc
+        (** exception P *)
+  (* generic constructions *)
+  | Tpat_or :
+      'k general_pattern * 'k general_pattern * Types.row_desc option ->
+      'k pattern_desc
+        (** P1 | P2
+
+            [row_desc] = [Some _] when translating [Ppat_type _],
+                         [None] otherwise.
+         *)
+
+and tpat_value_argument = private value general_pattern
+
+and expression =
+  { exp_desc: expression_desc;
+    exp_loc: Location.t;
+    exp_extra: (exp_extra * Location.t * attributes) list;
+    exp_type: Types.type_expr;
+    exp_env: Env.t;
+    exp_attributes: attributes;
+   }
+
+and exp_extra =
+  | Texp_constraint of core_type
+        (** E : T *)
+  | Texp_coerce of core_type option * core_type
+        (** E :> T           [Texp_coerce (None, T)]
+            E : T0 :> T      [Texp_coerce (Some T0, T)]
+         *)
+  | Texp_poly of core_type option
+        (** Used for method bodies. *)
+  | Texp_newtype of string
+        (** fun (type t) ->  *)
+
+and expression_desc =
+    Texp_ident of Path.t * Longident.t loc * Types.value_description
+        (** x
+            M.x
+         *)
+  | Texp_constant of constant
+        (** 1, 'a', "true", 1.0, 1l, 1L, 1n *)
+  | Texp_let of rec_flag * value_binding list * expression
+        (** let P1 = E1 and ... and Pn = EN in E       (flag = Nonrecursive)
+            let rec P1 = E1 and ... and Pn = EN in E   (flag = Recursive)
+         *)
+  | Texp_function of { arg_label : arg_label; param : Ident.t;
+      cases : value case list; partial : partial; }
+        (** [Pexp_fun] and [Pexp_function] both translate to [Texp_function].
+            See {!Parsetree} for more details.
+
+            [param] is the identifier that is to be used to name the
+            parameter of the function.
+
+            partial =
+              [Partial] if the pattern match is partial
+              [Total] otherwise.
+         *)
+  | Texp_apply of expression * (arg_label * expression option) list
+        (** E0 ~l1:E1 ... ~ln:En
+
+            The expression can be None if the expression is abstracted over
+            this argument. It currently appears when a label is applied.
+
+            For example:
+            let f x ~y = x + y in
+            f ~y:3
+
+            The resulting typedtree for the application is:
+            Texp_apply (Texp_ident "f/1037",
+                        [(Nolabel, None);
+                         (Labelled "y", Some (Texp_constant Const_int 3))
+                        ])
+         *)
+  | Texp_match of expression * computation case list * partial
+        (** match E0 with
+            | P1 -> E1
+            | P2 | exception P3 -> E2
+            | exception P4 -> E3
+
+            [Texp_match (E0, [(P1, E1); (P2 | exception P3, E2);
+                              (exception P4, E3)], _)]
+         *)
+  | Texp_try of expression * value case list
+        (** try E with P1 -> E1 | ... | PN -> EN *)
+  | Texp_tuple of expression list
+        (** (E1, ..., EN) *)
+  | Texp_construct of
+      Longident.t loc * Types.constructor_description * expression list
+        (** C                []
+            C E              [E]
+            C (E1, ..., En)  [E1;...;En]
+         *)
+  | Texp_variant of label * expression option
+  | Texp_record of {
+      fields : ( Types.label_description * record_label_definition ) array;
+      representation : Types.record_representation;
+      extended_expression : expression option;
+    }
+        (** { l1=P1; ...; ln=Pn }           (extended_expression = None)
+            { E0 with l1=P1; ...; ln=Pn }   (extended_expression = Some E0)
+
+            Invariant: n > 0
+
+            If the type is { l1: t1; l2: t2 }, the expression
+            { E0 with t2=P2 } is represented as
+            Texp_record
+              { fields = [| l1, Kept t1; l2 Override P2 |]; representation;
+                extended_expression = Some E0 }
+        *)
+  | Texp_field of expression * Longident.t loc * Types.label_description
+  | Texp_setfield of
+      expression * Longident.t loc * Types.label_description * expression
+  | Texp_array of expression list
+  | Texp_ifthenelse of expression * expression * expression option
+  | Texp_sequence of expression * expression
+  | Texp_while of expression * expression
+  | Texp_for of
+      Ident.t * Parsetree.pattern * expression * expression * direction_flag *
+        expression
+  | Texp_send of expression * meth * expression option
+  | Texp_new of Path.t * Longident.t loc * Types.class_declaration
+  | Texp_instvar of Path.t * Path.t * string loc
+  | Texp_setinstvar of Path.t * Path.t * string loc * expression
+  | Texp_override of Path.t * (Path.t * string loc * expression) list
+  | Texp_letmodule of
+      Ident.t option * string option loc * Types.module_presence * module_expr *
+        expression
+  | Texp_letexception of extension_constructor * expression
+  | Texp_assert of expression
+  | Texp_lazy of expression
+  | Texp_object of class_structure * string list
+  | Texp_pack of module_expr
+  | Texp_letop of {
+      let_ : binding_op;
+      ands : binding_op list;
+      param : Ident.t;
+      body : value case;
+      partial : partial;
+    }
+  | Texp_unreachable
+  | Texp_extension_constructor of Longident.t loc * Path.t
+  | Texp_open of open_declaration * expression
+        (** let open[!] M in e *)
+
+and meth =
+    Tmeth_name of string
+  | Tmeth_val of Ident.t
+
+and 'k case =
+    {
+     c_lhs: 'k general_pattern;
+     c_guard: expression option;
+     c_rhs: expression;
+    }
+
+and record_label_definition =
+  | Kept of Types.type_expr
+  | Overridden of Longident.t loc * expression
+
+and binding_op =
+  {
+    bop_op_path : Path.t;
+    bop_op_name : string loc;
+    bop_op_val : Types.value_description;
+    bop_op_type : Types.type_expr;
+    (* This is the type at which the operator was used.
+       It is always an instance of [bop_op_val.val_type] *)
+    bop_exp : expression;
+    bop_loc : Location.t;
+  }
+
+(* Value expressions for the class language *)
+
+and class_expr =
+    {
+     cl_desc: class_expr_desc;
+     cl_loc: Location.t;
+     cl_type: Types.class_type;
+     cl_env: Env.t;
+     cl_attributes: attributes;
+    }
+
+and class_expr_desc =
+    Tcl_ident of Path.t * Longident.t loc * core_type list
+  | Tcl_structure of class_structure
+  | Tcl_fun of
+      arg_label * pattern * (Ident.t * expression) list
+      * class_expr * partial
+  | Tcl_apply of class_expr * (arg_label * expression option) list
+  | Tcl_let of rec_flag * value_binding list *
+                  (Ident.t * expression) list * class_expr
+  | Tcl_constraint of
+      class_expr * class_type option * string list * string list * Types.Concr.t
+  (* Visible instance variables, methods and concrete methods *)
+  | Tcl_open of open_description * class_expr
+
+and class_structure =
+  {
+   cstr_self: pattern;
+   cstr_fields: class_field list;
+   cstr_type: Types.class_signature;
+   cstr_meths: Ident.t Types.Meths.t;
+  }
+
+and class_field =
+   {
+    cf_desc: class_field_desc;
+    cf_loc: Location.t;
+    cf_attributes: attributes;
+  }
+
+and class_field_kind =
+  | Tcfk_virtual of core_type
+  | Tcfk_concrete of override_flag * expression
+
+and class_field_desc =
+    Tcf_inherit of
+      override_flag * class_expr * string option * (string * Ident.t) list *
+        (string * Ident.t) list
+    (* Inherited instance variables and concrete methods *)
+  | Tcf_val of string loc * mutable_flag * Ident.t * class_field_kind * bool
+  | Tcf_method of string loc * private_flag * class_field_kind
+  | Tcf_constraint of core_type * core_type
+  | Tcf_initializer of expression
+  | Tcf_attribute of attribute
+
+(* Value expressions for the module language *)
+
+and module_expr =
+  { mod_desc: module_expr_desc;
+    mod_loc: Location.t;
+    mod_type: Types.module_type;
+    mod_env: Env.t;
+    mod_attributes: attributes;
+   }
+
+(** Annotations for [Tmod_constraint]. *)
+and module_type_constraint =
+  | Tmodtype_implicit
+  (** The module type constraint has been synthesized during typechecking. *)
+  | Tmodtype_explicit of module_type
+  (** The module type was in the source file. *)
+
+and functor_parameter =
+  | Unit
+  | Named of Ident.t option * string option loc * module_type
+
+and module_expr_desc =
+    Tmod_ident of Path.t * Longident.t loc
+  | Tmod_structure of structure
+  | Tmod_functor of functor_parameter * module_expr
+  | Tmod_apply of module_expr * module_expr * module_coercion
+  | Tmod_constraint of
+      module_expr * Types.module_type * module_type_constraint * module_coercion
+    (** ME          (constraint = Tmodtype_implicit)
+        (ME : MT)   (constraint = Tmodtype_explicit MT)
+     *)
+  | Tmod_unpack of expression * Types.module_type
+
+and structure = {
+  str_items : structure_item list;
+  str_type : Types.signature;
+  str_final_env : Env.t;
+}
+
+and structure_item =
+  { str_desc : structure_item_desc;
+    str_loc : Location.t;
+    str_env : Env.t
+  }
+
+and structure_item_desc =
+    Tstr_eval of expression * attributes
+  | Tstr_value of rec_flag * value_binding list
+  | Tstr_primitive of value_description
+  | Tstr_type of rec_flag * type_declaration list
+  | Tstr_typext of type_extension
+  | Tstr_exception of type_exception
+  | Tstr_module of module_binding
+  | Tstr_recmodule of module_binding list
+  | Tstr_modtype of module_type_declaration
+  | Tstr_open of open_declaration
+  | Tstr_class of (class_declaration * string list) list
+  | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list
+  | Tstr_include of include_declaration
+  | Tstr_attribute of attribute
+
+and module_binding =
+    {
+     mb_id: Ident.t option;
+     mb_name: string option loc;
+     mb_presence: Types.module_presence;
+     mb_expr: module_expr;
+     mb_attributes: attributes;
+     mb_loc: Location.t;
+    }
+
+and value_binding =
+  {
+    vb_pat: pattern;
+    vb_expr: expression;
+    vb_attributes: attributes;
+    vb_loc: Location.t;
+  }
+
+and module_coercion =
+    Tcoerce_none
+  | Tcoerce_structure of (int * module_coercion) list *
+                         (Ident.t * int * module_coercion) list
+  | Tcoerce_functor of module_coercion * module_coercion
+  | Tcoerce_primitive of primitive_coercion
+  | Tcoerce_alias of Env.t * Path.t * module_coercion
+
+and module_type =
+  { mty_desc: module_type_desc;
+    mty_type : Types.module_type;
+    mty_env : Env.t;
+    mty_loc: Location.t;
+    mty_attributes: attributes;
+   }
+
+and module_type_desc =
+    Tmty_ident of Path.t * Longident.t loc
+  | Tmty_signature of signature
+  | Tmty_functor of functor_parameter * module_type
+  | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list
+  | Tmty_typeof of module_expr
+  | Tmty_alias of Path.t * Longident.t loc
+
+and primitive_coercion =
+  {
+    pc_desc: Primitive.description;
+    pc_type: Types.type_expr;
+    pc_env: Env.t;
+    pc_loc : Location.t;
+  }
+
+and signature = {
+  sig_items : signature_item list;
+  sig_type : Types.signature;
+  sig_final_env : Env.t;
+}
+
+and signature_item =
+  { sig_desc: signature_item_desc;
+    sig_env : Env.t; (* BINANNOT ADDED *)
+    sig_loc: Location.t }
+
+and signature_item_desc =
+    Tsig_value of value_description
+  | Tsig_type of rec_flag * type_declaration list
+  | Tsig_typesubst of type_declaration list
+  | Tsig_typext of type_extension
+  | Tsig_exception of type_exception
+  | Tsig_module of module_declaration
+  | Tsig_modsubst of module_substitution
+  | Tsig_recmodule of module_declaration list
+  | Tsig_modtype of module_type_declaration
+  | Tsig_open of open_description
+  | Tsig_include of include_description
+  | Tsig_class of class_description list
+  | Tsig_class_type of class_type_declaration list
+  | Tsig_attribute of attribute
+
+and module_declaration =
+    {
+     md_id: Ident.t option;
+     md_name: string option loc;
+     md_presence: Types.module_presence;
+     md_type: module_type;
+     md_attributes: attributes;
+     md_loc: Location.t;
+    }
+
+and module_substitution =
+    {
+     ms_id: Ident.t;
+     ms_name: string loc;
+     ms_manifest: Path.t;
+     ms_txt: Longident.t loc;
+     ms_attributes: attributes;
+     ms_loc: Location.t;
+    }
+
+and module_type_declaration =
+    {
+     mtd_id: Ident.t;
+     mtd_name: string loc;
+     mtd_type: module_type option;
+     mtd_attributes: attributes;
+     mtd_loc: Location.t;
+    }
+
+and 'a open_infos =
+    {
+     open_expr: 'a;
+     open_bound_items: Types.signature;
+     open_override: override_flag;
+     open_env: Env.t;
+     open_loc: Location.t;
+     open_attributes: attribute list;
+    }
+
+and open_description = (Path.t * Longident.t loc) open_infos
+
+and open_declaration = module_expr open_infos
+
+
+and 'a include_infos =
+    {
+     incl_mod: 'a;
+     incl_type: Types.signature;
+     incl_loc: Location.t;
+     incl_attributes: attribute list;
+    }
+
+and include_description = module_type include_infos
+
+and include_declaration = module_expr include_infos
+
+and with_constraint =
+    Twith_type of type_declaration
+  | Twith_module of Path.t * Longident.t loc
+  | Twith_typesubst of type_declaration
+  | Twith_modsubst of Path.t * Longident.t loc
+
+and core_type =
+  { mutable ctyp_desc : core_type_desc;
+      (** mutable because of [Typeclass.declare_method] *)
+    mutable ctyp_type : Types.type_expr;
+      (** mutable because of [Typeclass.declare_method] *)
+    ctyp_env : Env.t; (* BINANNOT ADDED *)
+    ctyp_loc : Location.t;
+    ctyp_attributes: attributes;
+   }
+
+and core_type_desc =
+    Ttyp_any
+  | Ttyp_var of string
+  | Ttyp_arrow of arg_label * core_type * core_type
+  | Ttyp_tuple of core_type list
+  | Ttyp_constr of Path.t * Longident.t loc * core_type list
+  | Ttyp_object of object_field list * closed_flag
+  | Ttyp_class of Path.t * Longident.t loc * core_type list
+  | Ttyp_alias of core_type * string
+  | Ttyp_variant of row_field list * closed_flag * label list option
+  | Ttyp_poly of string list * core_type
+  | Ttyp_package of package_type
+
+and package_type = {
+  pack_path : Path.t;
+  pack_fields : (Longident.t loc * core_type) list;
+  pack_type : Types.module_type;
+  pack_txt : Longident.t loc;
+}
+
+and row_field = {
+  rf_desc : row_field_desc;
+  rf_loc : Location.t;
+  rf_attributes : attributes;
+}
+
+and row_field_desc =
+    Ttag of string loc * bool * core_type list
+  | Tinherit of core_type
+
+and object_field = {
+  of_desc : object_field_desc;
+  of_loc : Location.t;
+  of_attributes : attributes;
+}
+
+and object_field_desc =
+  | OTtag of string loc * core_type
+  | OTinherit of core_type
+
+and value_description =
+  { val_id: Ident.t;
+    val_name: string loc;
+    val_desc: core_type;
+    val_val: Types.value_description;
+    val_prim: string list;
+    val_loc: Location.t;
+    val_attributes: attributes;
+    }
+
+and type_declaration =
+  {
+    typ_id: Ident.t;
+    typ_name: string loc;
+    typ_params: (core_type * variance) list;
+    typ_type: Types.type_declaration;
+    typ_cstrs: (core_type * core_type * Location.t) list;
+    typ_kind: type_kind;
+    typ_private: private_flag;
+    typ_manifest: core_type option;
+    typ_loc: Location.t;
+    typ_attributes: attributes;
+   }
+
+and type_kind =
+    Ttype_abstract
+  | Ttype_variant of constructor_declaration list
+  | Ttype_record of label_declaration list
+  | Ttype_open
+
+and label_declaration =
+    {
+     ld_id: Ident.t;
+     ld_name: string loc;
+     ld_mutable: mutable_flag;
+     ld_type: core_type;
+     ld_loc: Location.t;
+     ld_attributes: attributes;
+    }
+
+and constructor_declaration =
+    {
+     cd_id: Ident.t;
+     cd_name: string loc;
+     cd_args: constructor_arguments;
+     cd_res: core_type option;
+     cd_loc: Location.t;
+     cd_attributes: attributes;
+    }
+
+and constructor_arguments =
+  | Cstr_tuple of core_type list
+  | Cstr_record of label_declaration list
+
+and type_extension =
+  {
+    tyext_path: Path.t;
+    tyext_txt: Longident.t loc;
+    tyext_params: (core_type * variance) list;
+    tyext_constructors: extension_constructor list;
+    tyext_private: private_flag;
+    tyext_loc: Location.t;
+    tyext_attributes: attributes;
+  }
+
+and type_exception =
+  {
+    tyexn_constructor: extension_constructor;
+    tyexn_loc: Location.t;
+    tyexn_attributes: attribute list;
+  }
+
+and extension_constructor =
+  {
+    ext_id: Ident.t;
+    ext_name: string loc;
+    ext_type : Types.extension_constructor;
+    ext_kind : extension_constructor_kind;
+    ext_loc : Location.t;
+    ext_attributes: attributes;
+  }
+
+and extension_constructor_kind =
+    Text_decl of constructor_arguments * core_type option
+  | Text_rebind of Path.t * Longident.t loc
+
+and class_type =
+    {
+     cltyp_desc: class_type_desc;
+     cltyp_type: Types.class_type;
+     cltyp_env: Env.t;
+     cltyp_loc: Location.t;
+     cltyp_attributes: attributes;
+    }
+
+and class_type_desc =
+    Tcty_constr of Path.t * Longident.t loc * core_type list
+  | Tcty_signature of class_signature
+  | Tcty_arrow of arg_label * core_type * class_type
+  | Tcty_open of open_description * class_type
+
+and class_signature = {
+    csig_self : core_type;
+    csig_fields : class_type_field list;
+    csig_type : Types.class_signature;
+  }
+
+and class_type_field = {
+    ctf_desc: class_type_field_desc;
+    ctf_loc: Location.t;
+    ctf_attributes: attributes;
+  }
+
+and class_type_field_desc =
+  | Tctf_inherit of class_type
+  | Tctf_val of (string * mutable_flag * virtual_flag * core_type)
+  | Tctf_method of (string * private_flag * virtual_flag * core_type)
+  | Tctf_constraint of (core_type * core_type)
+  | Tctf_attribute of attribute
+
+and class_declaration =
+  class_expr class_infos
+
+and class_description =
+  class_type class_infos
+
+and class_type_declaration =
+  class_type class_infos
+
+and 'a class_infos =
+  { ci_virt: virtual_flag;
+    ci_params: (core_type * variance) list;
+    ci_id_name : string loc;
+    ci_id_class: Ident.t;
+    ci_id_class_type : Ident.t;
+    ci_id_object : Ident.t;
+    ci_id_typehash : Ident.t;
+    ci_expr: 'a;
+    ci_decl: Types.class_declaration;
+    ci_type_decl : Types.class_type_declaration;
+    ci_loc: Location.t;
+    ci_attributes: attributes;
+   }
+
+(* Auxiliary functions over the a.s.t. *)
+
+(** [as_computation_pattern p] is a computation pattern with description
+    [Tpat_value p], which enforces a correct placement of pat_attributes
+    and pat_extra metadata (on the inner value pattern, rather than on
+    the computation pattern). *)
+val as_computation_pattern: pattern -> computation general_pattern
+
+val classify_pattern_desc: 'k pattern_desc -> 'k pattern_category
+val classify_pattern: 'k general_pattern -> 'k pattern_category
+
+type pattern_action =
+  { f : 'k . 'k general_pattern -> unit }
+val shallow_iter_pattern_desc:
+    pattern_action -> 'k pattern_desc -> unit
+
+type pattern_transformation =
+  { f : 'k . 'k general_pattern -> 'k general_pattern }
+val shallow_map_pattern_desc:
+    pattern_transformation -> 'k pattern_desc -> 'k pattern_desc
+
+val iter_general_pattern: pattern_action -> 'k general_pattern -> unit
+val iter_pattern: (pattern -> unit) -> pattern -> unit
+
+type pattern_predicate = { f : 'k . 'k general_pattern -> bool }
+val exists_general_pattern: pattern_predicate -> 'k general_pattern -> bool
+val exists_pattern: (pattern -> bool) -> pattern -> bool
+
+(** bottom-up mapping of patterns: the transformation function is
+    called on the children before being called on the parent *)
+val map_general_pattern:
+  pattern_transformation -> 'k general_pattern -> 'k general_pattern
+
+val let_bound_idents: value_binding list -> Ident.t list
+val let_bound_idents_full:
+    value_binding list -> (Ident.t * string loc * Types.type_expr) list
+
+(** Alpha conversion of patterns *)
+val alpha_pat:
+  (Ident.t * Ident.t) list -> 'k general_pattern -> 'k general_pattern
+
+val mknoloc: 'a -> 'a Asttypes.loc
+val mkloc: 'a -> Location.t -> 'a Asttypes.loc
+
+val pat_bound_idents: 'k general_pattern -> Ident.t list
+val pat_bound_idents_full:
+  'k general_pattern -> (Ident.t * string loc * Types.type_expr) list
+
+(** Splits an or pattern into its value (left) and exception (right) parts. *)
+val split_pattern:
+  computation general_pattern -> pattern option * pattern option
diff --git a/upstream/ocaml_411/typing/typemod.ml b/upstream/ocaml_411/typing/typemod.ml
new file mode 100644
index 0000000..1f7c480
--- /dev/null
+++ b/upstream/ocaml_411/typing/typemod.ml
@@ -0,0 +1,2947 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Misc
+open Longident
+open Path
+open Asttypes
+open Parsetree
+open Types
+open Format
+
+module String = Misc.Stdlib.String
+
+module Sig_component_kind = struct
+  type t =
+    | Value
+    | Type
+    | Module
+    | Module_type
+    | Extension_constructor
+    | Class
+    | Class_type
+
+  let to_string = function
+    | Value -> "value"
+    | Type -> "type"
+    | Module -> "module"
+    | Module_type -> "module type"
+    | Extension_constructor -> "extension constructor"
+    | Class -> "class"
+    | Class_type -> "class type"
+
+  (** Whether the name of a component of that kind can appear in a type. *)
+  let can_appear_in_types = function
+    | Value
+    | Extension_constructor ->
+        false
+    | Type
+    | Module
+    | Module_type
+    | Class
+    | Class_type ->
+        true
+end
+
+type hiding_error =
+  | Illegal_shadowing of {
+      shadowed_item_id: Ident.t;
+      shadowed_item_kind: Sig_component_kind.t;
+      shadowed_item_loc: Location.t;
+      shadower_id: Ident.t;
+      user_id: Ident.t;
+      user_kind: Sig_component_kind.t;
+      user_loc: Location.t;
+    }
+  | Appears_in_signature of {
+      opened_item_id: Ident.t;
+      opened_item_kind: Sig_component_kind.t;
+      user_id: Ident.t;
+      user_kind: Sig_component_kind.t;
+      user_loc: Location.t;
+    }
+
+type error =
+    Cannot_apply of module_type
+  | Not_included of Includemod.error list
+  | Cannot_eliminate_dependency of module_type
+  | Signature_expected
+  | Structure_expected of module_type
+  | With_no_component of Longident.t
+  | With_mismatch of Longident.t * Includemod.error list
+  | With_makes_applicative_functor_ill_typed of
+      Longident.t * Path.t * Includemod.error list
+  | With_changes_module_alias of Longident.t * Ident.t * Path.t
+  | With_cannot_remove_constrained_type
+  | Repeated_name of Sig_component_kind.t * string
+  | Non_generalizable of type_expr
+  | Non_generalizable_class of Ident.t * class_declaration
+  | Non_generalizable_module of module_type
+  | Implementation_is_required of string
+  | Interface_not_compiled of string
+  | Not_allowed_in_functor_body
+  | Not_a_packed_module of type_expr
+  | Incomplete_packed_module of type_expr
+  | Scoping_pack of Longident.t * type_expr
+  | Recursive_module_require_explicit_type
+  | Apply_generative
+  | Cannot_scrape_alias of Path.t
+  | Badly_formed_signature of string * Typedecl.error
+  | Cannot_hide_id of hiding_error
+  | Invalid_type_subst_rhs
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+open Typedtree
+
+let rec path_concat head p =
+  match p with
+    Pident tail -> Pdot (Pident head, Ident.name tail)
+  | Pdot (pre, s) -> Pdot (path_concat head pre, s)
+  | Papply _ -> assert false
+
+(* Extract a signature from a module type *)
+
+let extract_sig env loc mty =
+  match Env.scrape_alias env mty with
+    Mty_signature sg -> sg
+  | Mty_alias path ->
+      raise(Error(loc, env, Cannot_scrape_alias path))
+  | _ -> raise(Error(loc, env, Signature_expected))
+
+let extract_sig_open env loc mty =
+  match Env.scrape_alias env mty with
+    Mty_signature sg -> sg
+  | Mty_alias path ->
+      raise(Error(loc, env, Cannot_scrape_alias path))
+  | mty -> raise(Error(loc, env, Structure_expected mty))
+
+(* Compute the environment after opening a module *)
+
+let type_open_ ?used_slot ?toplevel ovf env loc lid =
+  let path = Env.lookup_module_path ~load:true ~loc:lid.loc lid.txt env in
+  match Env.open_signature ~loc ?used_slot ?toplevel ovf path env with
+  | Ok env -> path, env
+  | Error _ ->
+      let md = Env.find_module path env in
+      ignore (extract_sig_open env lid.loc md.md_type);
+      assert false
+
+let initial_env ~loc ~safe_string ~initially_opened_module
+    ~open_implicit_modules =
+  let env =
+    if safe_string then
+      Env.initial_safe_string
+    else
+      Env.initial_unsafe_string
+  in
+  let open_module env m =
+    let open Asttypes in
+    let lexbuf = Lexing.from_string m in
+    let txt =
+      Location.init lexbuf (Printf.sprintf "command line argument: -open %S" m);
+      Parse.simple_module_path lexbuf in
+        snd (type_open_ Override env loc {txt;loc})
+  in
+  let add_units env units =
+    String.Set.fold
+      (fun name env ->
+         Env.add_persistent_structure (Ident.create_persistent name) env)
+      units
+      env
+  in
+  let units =
+    List.rev_map Env.persistent_structures_of_dir (Load_path.get ())
+  in
+  let env, units =
+    match initially_opened_module with
+    | None -> (env, units)
+    | Some m ->
+        (* Locate the directory that contains [m], adds the units it
+           contains to the environment and open [m] in the resulting
+           environment. *)
+        let rec loop before after =
+          match after with
+          | [] -> None
+          | units :: after ->
+              if String.Set.mem m units then
+                Some (units, List.rev_append before after)
+              else
+                loop (units :: before) after
+        in
+        let env, units =
+          match loop [] units with
+          | None ->
+              (env, units)
+          | Some (units_containing_m, other_units) ->
+              (add_units env units_containing_m, other_units)
+        in
+        (open_module env m, units)
+  in
+  let env = List.fold_left add_units env units in
+  List.fold_left open_module env open_implicit_modules
+
+let type_open_descr ?used_slot ?toplevel env sod =
+  let (path, newenv) =
+    Builtin_attributes.warning_scope sod.popen_attributes
+      (fun () ->
+         type_open_ ?used_slot ?toplevel sod.popen_override env sod.popen_loc
+           sod.popen_expr
+      )
+  in
+  let od =
+    {
+      open_expr = (path, sod.popen_expr);
+      open_bound_items = [];
+      open_override = sod.popen_override;
+      open_env = newenv;
+      open_attributes = sod.popen_attributes;
+      open_loc = sod.popen_loc;
+    }
+  in
+  (od, newenv)
+
+(* Forward declaration, to be filled in by type_module_type_of *)
+let type_module_type_of_fwd :
+    (Env.t -> Parsetree.module_expr ->
+      Typedtree.module_expr * Types.module_type) ref
+  = ref (fun _env _m -> assert false)
+
+(* Additional validity checks on type definitions arising from
+   recursive modules *)
+
+let check_recmod_typedecls env decls =
+  let recmod_ids = List.map fst decls in
+  List.iter
+    (fun (id, md) ->
+      List.iter
+        (fun path ->
+          Typedecl.check_recmod_typedecl env md.Types.md_loc recmod_ids
+                                         path (Env.find_type path env))
+        (Mtype.type_paths env (Pident id) md.Types.md_type))
+    decls
+
+(* Merge one "with" constraint in a signature *)
+
+let rec add_rec_types env = function
+    Sig_type(id, decl, Trec_next, _) :: rem ->
+      add_rec_types (Env.add_type ~check:true id decl env) rem
+  | _ -> env
+
+let check_type_decl env loc id row_id newdecl decl rs rem =
+  let env = Env.add_type ~check:true id newdecl env in
+  let env =
+    match row_id with
+    | None -> env
+    | Some id -> Env.add_type ~check:false id newdecl env
+  in
+  let env = if rs = Trec_not then env else add_rec_types env rem in
+  Includemod.type_declarations ~mark:Mark_both ~loc env id newdecl decl;
+  Typedecl.check_coherence env loc (Path.Pident id) newdecl
+
+let update_rec_next rs rem =
+  match rs with
+    Trec_next -> rem
+  | Trec_first | Trec_not ->
+      match rem with
+        Sig_type (id, decl, Trec_next, priv) :: rem ->
+          Sig_type (id, decl, rs, priv) :: rem
+      | Sig_module (id, pres, mty, Trec_next, priv) :: rem ->
+          Sig_module (id, pres, mty, rs, priv) :: rem
+      | _ -> rem
+
+let make_variance p n i =
+  let open Variance in
+  set May_pos p (set May_neg n (set May_weak n (set Inj i null)))
+
+let rec iter_path_apply p ~f =
+  match p with
+  | Pident _ -> ()
+  | Pdot (p, _) -> iter_path_apply p ~f
+  | Papply (p1, p2) ->
+     iter_path_apply p1 ~f;
+     iter_path_apply p2 ~f;
+     f p1 p2 (* after recursing, so we know both paths are well typed *)
+
+let path_is_strict_prefix =
+  let rec list_is_strict_prefix l ~prefix =
+    match l, prefix with
+    | [], [] -> false
+    | _ :: _, [] -> true
+    | [], _ :: _ -> false
+    | s1 :: t1, s2 :: t2 ->
+       String.equal s1 s2 && list_is_strict_prefix t1 ~prefix:t2
+  in
+  fun path ~prefix ->
+    match Path.flatten path, Path.flatten prefix with
+    | `Contains_apply, _ | _, `Contains_apply -> false
+    | `Ok (ident1, l1), `Ok (ident2, l2) ->
+       Ident.same ident1 ident2
+       && list_is_strict_prefix l1 ~prefix:l2
+
+let iterator_with_env env =
+  let env = ref (lazy env) in
+  let super = Btype.type_iterators in
+  env, { super with
+    Btype.it_signature = (fun self sg ->
+      (* add all items to the env before recursing down, to handle recursive
+         definitions *)
+      let env_before = !env in
+      env := lazy (Env.add_signature sg (Lazy.force env_before));
+      super.Btype.it_signature self sg;
+      env := env_before
+    );
+    Btype.it_module_type = (fun self -> function
+    | Mty_functor (param, mty_body) ->
+      let env_before = !env in
+      begin match param with
+      | Unit -> ()
+      | Named (param, mty_arg) ->
+        self.Btype.it_module_type self mty_arg;
+        match param with
+        | None -> ()
+        | Some id ->
+          env := lazy (Env.add_module ~arg:true id Mp_present
+                       mty_arg (Lazy.force env_before))
+      end;
+      self.Btype.it_module_type self mty_body;
+      env := env_before;
+    | mty ->
+      super.Btype.it_module_type self mty
+    )
+  }
+
+let retype_applicative_functor_type ~loc env funct arg =
+  let mty_functor = (Env.find_module funct env).md_type in
+  let mty_arg = (Env.find_module arg env).md_type in
+  let mty_param =
+    match Env.scrape_alias env mty_functor with
+    | Mty_functor (Named (_, mty_param), _) -> mty_param
+    | _ -> assert false (* could trigger due to MPR#7611 *)
+  in
+  Includemod.check_modtype_inclusion ~loc env mty_arg arg mty_param
+
+(* When doing a deep destructive substitution with type M.N.t := .., we change M
+   and M.N and so we have to check that uses of the modules other than just
+   extracting components from them still make sense. There are only two such
+   kinds of uses:
+   - applicative functor types: F(M).t might not be well typed anymore
+   - aliases: module A = M still makes sense but it doesn't mean the same thing
+     anymore, so it's forbidden until it's clear what we should do with it.
+   This function would be called with M.N.t and N.t to check for these uses. *)
+let check_usage_of_path_of_substituted_item paths env signature ~loc ~lid =
+  let iterator =
+    let env, super = iterator_with_env env in
+    { super with
+      Btype.it_signature_item = (fun self -> function
+      | Sig_module (id, _, { md_type = Mty_alias aliased_path; _ }, _, _)
+        when List.exists
+               (fun path -> path_is_strict_prefix path ~prefix:aliased_path)
+               paths
+        ->
+         let e = With_changes_module_alias (lid.txt, id, aliased_path) in
+         raise(Error(loc, Lazy.force !env, e))
+      | sig_item ->
+         super.Btype.it_signature_item self sig_item
+      );
+      Btype.it_path = (fun referenced_path ->
+        iter_path_apply referenced_path ~f:(fun funct arg ->
+          if List.exists
+               (fun path -> path_is_strict_prefix path ~prefix:arg)
+               paths
+          then
+            let env = Lazy.force !env in
+            try retype_applicative_functor_type ~loc env funct arg
+            with Includemod.Error explanation ->
+              raise(Error(loc, env,
+                          With_makes_applicative_functor_ill_typed
+                            (lid.txt, referenced_path, explanation)))
+        )
+      );
+    }
+  in
+  iterator.Btype.it_signature iterator signature;
+  Btype.unmark_iterators.Btype.it_signature Btype.unmark_iterators signature
+
+(* After substitution one also needs to re-check the well-foundedness
+   of type declarations in recursive modules *)
+let rec extract_next_modules = function
+  | Sig_module (id, _, mty, Trec_next, _) :: rem ->
+      let (id_mty_l, rem) = extract_next_modules rem in
+      ((id, mty) :: id_mty_l, rem)
+  | sg -> ([], sg)
+
+let check_well_formed_module env loc context mty =
+  (* Format.eprintf "@[check_well_formed_module@ %a@]@."
+     Printtyp.modtype mty; *)
+  let open Btype in
+  let iterator =
+    let rec check_signature env = function
+      | [] -> ()
+      | Sig_module (id, _, mty, Trec_first, _) :: rem ->
+          let (id_mty_l, rem) = extract_next_modules rem in
+          begin try
+            check_recmod_typedecls (Lazy.force env) ((id, mty) :: id_mty_l)
+          with Typedecl.Error (_, err) ->
+            raise (Error (loc, Lazy.force env,
+                          Badly_formed_signature(context, err)))
+          end;
+          check_signature env rem
+      | _ :: rem ->
+          check_signature env rem
+    in
+    let env, super = iterator_with_env env in
+    { super with
+      it_type_expr = (fun _self _ty -> ());
+      it_signature = (fun self sg ->
+        let env_before = !env in
+        let env = lazy (Env.add_signature sg (Lazy.force env_before)) in
+        check_signature env sg;
+        super.it_signature self sg);
+    }
+  in
+  iterator.it_module_type iterator mty
+
+let () = Env.check_well_formed_module := check_well_formed_module
+
+let type_decl_is_alias sdecl = (* assuming no explicit constraint *)
+  match sdecl.ptype_manifest with
+  | Some {ptyp_desc = Ptyp_constr (lid, stl)}
+       when List.length stl = List.length sdecl.ptype_params ->
+     begin
+       match
+         List.iter2 (fun x (y, _) ->
+             match x, y with
+               {ptyp_desc=Ptyp_var sx}, {ptyp_desc=Ptyp_var sy}
+                  when sx = sy -> ()
+             | _, _ -> raise Exit)
+           stl sdecl.ptype_params;
+       with
+       | exception Exit -> None
+       | () -> Some lid
+     end
+  | _ -> None
+;;
+
+let params_are_constrained =
+  let rec loop = function
+    | [] -> false
+    | hd :: tl ->
+       match (Btype.repr hd).desc with
+       | Tvar _ -> List.memq hd tl || loop tl
+       | _ -> true
+  in
+  loop
+;;
+
+let merge_constraint initial_env remove_aliases loc sg constr =
+  let lid =
+    match constr with
+    | Pwith_type (lid, _) | Pwith_module (lid, _)
+    | Pwith_typesubst (lid, _) | Pwith_modsubst (lid, _) -> lid
+  in
+  let destructive_substitution =
+    match constr with
+    | Pwith_type _ | Pwith_module _ -> false
+    | Pwith_typesubst _ | Pwith_modsubst _ -> true
+  in
+  let real_ids = ref [] in
+  let rec merge sig_env sg namelist row_id =
+    match (sg, namelist, constr) with
+      ([], _, _) ->
+        raise(Error(loc, sig_env, With_no_component lid.txt))
+    | (Sig_type(id, decl, rs, priv) :: rem, [s],
+       Pwith_type (_, ({ptype_kind = Ptype_abstract} as sdecl)))
+      when Ident.name id = s && Typedecl.is_fixed_type sdecl ->
+        let decl_row =
+          let arity = List.length sdecl.ptype_params in
+          {
+            type_params =
+              List.map (fun _ -> Btype.newgenvar()) sdecl.ptype_params;
+            type_arity = arity;
+            type_kind = Type_abstract;
+            type_private = Private;
+            type_manifest = None;
+            type_variance =
+              List.map
+                (fun (_, v) ->
+                   let (c, n) =
+                     match v with
+                     | Covariant -> true, false
+                     | Contravariant -> false, true
+                     | Invariant -> false, false
+                   in
+                   make_variance (not n) (not c) false
+                )
+                sdecl.ptype_params;
+            type_separability =
+              Types.Separability.default_signature ~arity;
+            type_loc = sdecl.ptype_loc;
+            type_is_newtype = false;
+            type_expansion_scope = Btype.lowest_level;
+            type_attributes = [];
+            type_immediate = Unknown;
+            type_unboxed = unboxed_false_default_false;
+            type_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+          }
+        and id_row = Ident.create_local (s^"#row") in
+        let initial_env =
+          Env.add_type ~check:false id_row decl_row initial_env
+        in
+        let tdecl =
+          Typedecl.transl_with_constraint id (Some(Pident id_row))
+            ~sig_env ~sig_decl:decl ~outer_env:initial_env sdecl in
+        let newdecl = tdecl.typ_type in
+        check_type_decl sig_env sdecl.ptype_loc id row_id newdecl decl rs rem;
+        let decl_row = {decl_row with type_params = newdecl.type_params} in
+        let rs' = if rs = Trec_first then Trec_not else rs in
+        (Pident id, lid, Twith_type tdecl),
+        Sig_type(id_row, decl_row, rs', priv)
+        :: Sig_type(id, newdecl, rs, priv)
+        :: rem
+    | (Sig_type(id, sig_decl, rs, priv) :: rem , [s],
+       (Pwith_type (_, sdecl) | Pwith_typesubst (_, sdecl) as constr))
+      when Ident.name id = s ->
+        let tdecl =
+          Typedecl.transl_with_constraint id None
+            ~sig_env ~sig_decl ~outer_env:initial_env sdecl in
+        let newdecl = tdecl.typ_type and loc = sdecl.ptype_loc in
+        check_type_decl sig_env loc id row_id newdecl sig_decl rs rem;
+        begin match constr with
+          Pwith_type _ ->
+            (Pident id, lid, Twith_type tdecl),
+            Sig_type(id, newdecl, rs, priv) :: rem
+        | (* Pwith_typesubst *) _ ->
+            real_ids := [Pident id];
+            (Pident id, lid, Twith_typesubst tdecl),
+            update_rec_next rs rem
+        end
+    | (Sig_type(id, _, _, _) :: rem, [s], (Pwith_type _ | Pwith_typesubst _))
+      when Ident.name id = s ^ "#row" ->
+        merge sig_env rem namelist (Some id)
+    | (Sig_module(id, pres, md, rs, priv) :: rem, [s], Pwith_module (_, lid'))
+      when Ident.name id = s ->
+        let path, md' = Env.lookup_module ~loc lid'.txt initial_env in
+        let mty = md'.md_type in
+        let mty = Mtype.scrape_for_type_of ~remove_aliases sig_env mty in
+        let md'' = { md' with md_type = mty } in
+        let newmd = Mtype.strengthen_decl ~aliasable:false sig_env md'' path in
+        ignore(Includemod.modtypes  ~mark:Mark_both ~loc sig_env
+                 newmd.md_type md.md_type);
+        (Pident id, lid, Twith_module (path, lid')),
+        Sig_module(id, pres, newmd, rs, priv) :: rem
+    | (Sig_module(id, _, md, rs, _) :: rem, [s], Pwith_modsubst (_, lid'))
+      when Ident.name id = s ->
+        let path, md' = Env.lookup_module ~loc lid'.txt initial_env in
+        let aliasable = not (Env.is_functor_arg path sig_env) in
+        ignore
+          (Includemod.strengthened_module_decl ~loc ~mark:Mark_both
+             ~aliasable sig_env md' path md);
+        real_ids := [Pident id];
+        (Pident id, lid, Twith_modsubst (path, lid')),
+        update_rec_next rs rem
+    | (Sig_module(id, _, md, rs, priv) as item :: rem, s :: namelist, constr)
+      when Ident.name id = s ->
+        let sg = extract_sig sig_env loc md.md_type in
+        let ((path, _, tcstr), newsg) = merge_signature sig_env sg namelist in
+        let path = path_concat id path in
+        real_ids := path :: !real_ids;
+        let item =
+          match md.md_type, constr with
+            Mty_alias _, (Pwith_module _ | Pwith_type _) ->
+              (* A module alias cannot be refined, so keep it
+                 and just check that the constraint is correct *)
+              item
+          | _ ->
+              let newmd = {md with md_type = Mty_signature newsg} in
+              Sig_module(id, Mp_present, newmd, rs, priv)
+        in
+        (path, lid, tcstr),
+        item :: rem
+    | (item :: rem, _, _) ->
+        let (cstr, items) = merge sig_env rem namelist row_id
+        in
+        cstr, item :: items
+  and merge_signature env sg namelist =
+    let sig_env = Env.add_signature sg env in
+    merge sig_env sg namelist None
+  in
+  try
+    let names = Longident.flatten lid.txt in
+    let (tcstr, sg) = merge_signature initial_env sg names in
+    if destructive_substitution then (
+      match List.rev !real_ids with
+      | [] -> assert false
+      | last :: rest ->
+        (* The last item is the one that's removed. We don't need to check how
+           it's used since it's replaced by a more specific type/module. *)
+        assert (match last with Pident _ -> true | _ -> false);
+        match rest with
+        | [] -> ()
+        | _ :: _ ->
+          check_usage_of_path_of_substituted_item
+            rest initial_env sg ~loc ~lid;
+    );
+    let sg =
+    match tcstr with
+    | (_, _, Twith_typesubst tdecl) ->
+       let how_to_extend_subst =
+         let sdecl =
+           match constr with
+           | Pwith_typesubst (_, sdecl) -> sdecl
+           | _ -> assert false
+         in
+         match type_decl_is_alias sdecl with
+         | Some lid ->
+            let replacement, _ =
+              try Env.find_type_by_name lid.txt initial_env
+              with Not_found -> assert false
+            in
+            fun s path -> Subst.add_type_path path replacement s
+         | None ->
+            let body = Option.get tdecl.typ_type.type_manifest in
+            let params = tdecl.typ_type.type_params in
+            if params_are_constrained params
+            then raise(Error(loc, initial_env,
+                             With_cannot_remove_constrained_type));
+            fun s path -> Subst.add_type_function path ~params ~body s
+       in
+       let sub = List.fold_left how_to_extend_subst Subst.identity !real_ids in
+       (* This signature will not be used directly, it will always be freshened
+          by the caller. So what we do with the scope doesn't really matter. But
+          making it local makes it unlikely that we will ever use the result of
+          this function unfreshened without issue. *)
+       Subst.signature Make_local sub sg
+    | (_, _, Twith_modsubst (real_path, _)) ->
+       let sub =
+         List.fold_left
+           (fun s path -> Subst.add_module_path path real_path s)
+           Subst.identity
+           !real_ids
+       in
+       (* See explanation in the [Twith_typesubst] case above. *)
+       Subst.signature Make_local sub sg
+    | _ ->
+       sg
+    in
+    check_well_formed_module initial_env loc "this instantiated signature"
+      (Mty_signature sg);
+    (tcstr, sg)
+  with Includemod.Error explanation ->
+    raise(Error(loc, initial_env, With_mismatch(lid.txt, explanation)))
+
+(* Add recursion flags on declarations arising from a mutually recursive
+   block. *)
+
+let map_rec fn decls rem =
+  match decls with
+  | [] -> rem
+  | d1 :: dl -> fn Trec_first d1 :: map_end (fn Trec_next) dl rem
+
+let map_rec_type ~rec_flag fn decls rem =
+  match decls with
+  | [] -> rem
+  | d1 :: dl ->
+      let first =
+        match rec_flag with
+        | Recursive -> Trec_first
+        | Nonrecursive -> Trec_not
+      in
+      fn first d1 :: map_end (fn Trec_next) dl rem
+
+let rec map_rec_type_with_row_types ~rec_flag fn decls rem =
+  match decls with
+  | [] -> rem
+  | d1 :: dl ->
+      if Btype.is_row_name (Ident.name d1.typ_id) then
+        fn Trec_not d1 :: map_rec_type_with_row_types ~rec_flag fn dl rem
+      else
+        map_rec_type ~rec_flag fn decls rem
+
+(* Add type extension flags to extension constructors *)
+let map_ext fn exts rem =
+  match exts with
+  | [] -> rem
+  | d1 :: dl -> fn Text_first d1 :: map_end (fn Text_next) dl rem
+
+(* Auxiliary for translating recursively-defined module types.
+   Return a module type that approximates the shape of the given module
+   type AST.  Retain only module, type, and module type
+   components of signatures.  For types, retain only their arity,
+   making them abstract otherwise. *)
+
+let rec approx_modtype env smty =
+  match smty.pmty_desc with
+    Pmty_ident lid ->
+      let (path, _info) =
+        Env.lookup_modtype ~use:false ~loc:smty.pmty_loc lid.txt env
+      in
+      Mty_ident path
+  | Pmty_alias lid ->
+      let path =
+        Env.lookup_module_path ~use:false ~load:false
+          ~loc:smty.pmty_loc lid.txt env
+      in
+      Mty_alias(path)
+  | Pmty_signature ssg ->
+      Mty_signature(approx_sig env ssg)
+  | Pmty_functor(param, sres) ->
+      let (param, newenv) =
+        match param with
+        | Unit -> Types.Unit, env
+        | Named (param, sarg) ->
+          let arg = approx_modtype env sarg in
+          match param.txt with
+          | None -> Types.Named (None, arg), env
+          | Some name ->
+            let rarg = Mtype.scrape_for_functor_arg env arg in
+            let scope = Ctype.create_scope () in
+            let (id, newenv) =
+              Env.enter_module ~scope ~arg:true name Mp_present rarg env
+            in
+            Types.Named (Some id, arg), newenv
+      in
+      let res = approx_modtype newenv sres in
+      Mty_functor(param, res)
+  | Pmty_with(sbody, constraints) ->
+      let body = approx_modtype env sbody in
+      List.iter
+        (fun sdecl ->
+          match sdecl with
+          | Pwith_type _ -> ()
+          | Pwith_typesubst _ -> ()
+          | Pwith_module (_, lid') ->
+              (* Lookup the module to make sure that it is not recursive.
+                 (GPR#1626) *)
+              ignore (Env.lookup_module ~use:false ~loc:lid'.loc lid'.txt env)
+          | Pwith_modsubst (_, lid') ->
+              ignore (Env.lookup_module ~use:false ~loc:lid'.loc lid'.txt env))
+        constraints;
+      body
+  | Pmty_typeof smod ->
+      let (_, mty) = !type_module_type_of_fwd env smod in
+      mty
+  | Pmty_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and approx_module_declaration env pmd =
+  {
+    Types.md_type = approx_modtype env pmd.pmd_type;
+    md_attributes = pmd.pmd_attributes;
+    md_loc = pmd.pmd_loc;
+    md_uid = Uid.internal_not_actually_unique;
+  }
+
+and approx_sig env ssg =
+  match ssg with
+    [] -> []
+  | item :: srem ->
+      match item.psig_desc with
+      | Psig_type (rec_flag, sdecls) ->
+          let decls = Typedecl.approx_type_decl sdecls in
+          let rem = approx_sig env srem in
+          map_rec_type ~rec_flag
+            (fun rs (id, info) -> Sig_type(id, info, rs, Exported)) decls rem
+      | Psig_typesubst _ -> approx_sig env srem
+      | Psig_module { pmd_name = { txt = None; _ }; _ } ->
+          approx_sig env srem
+      | Psig_module pmd ->
+          let scope = Ctype.create_scope () in
+          let md = approx_module_declaration env pmd in
+          let pres =
+            match md.Types.md_type with
+            | Mty_alias _ -> Mp_absent
+            | _ -> Mp_present
+          in
+          let id, newenv =
+            Env.enter_module_declaration ~scope (Option.get pmd.pmd_name.txt)
+              pres md env
+          in
+          Sig_module(id, pres, md, Trec_not, Exported) :: approx_sig newenv srem
+      | Psig_modsubst pms ->
+          let scope = Ctype.create_scope () in
+          let _, md =
+            Env.lookup_module ~use:false ~loc:pms.pms_manifest.loc
+               pms.pms_manifest.txt env
+          in
+          let pres =
+            match md.Types.md_type with
+            | Mty_alias _ -> Mp_absent
+            | _ -> Mp_present
+          in
+          let _, newenv =
+            Env.enter_module_declaration ~scope pms.pms_name.txt pres md env
+          in
+          approx_sig newenv srem
+      | Psig_recmodule sdecls ->
+          let scope = Ctype.create_scope () in
+          let decls =
+            List.filter_map
+              (fun pmd ->
+                 Option.map (fun name ->
+                   Ident.create_scoped ~scope name,
+                   approx_module_declaration env pmd
+                 ) pmd.pmd_name.txt
+              )
+              sdecls
+          in
+          let newenv =
+            List.fold_left
+              (fun env (id, md) -> Env.add_module_declaration ~check:false
+                  id Mp_present md env)
+              env decls
+          in
+          map_rec
+            (fun rs (id, md) -> Sig_module(id, Mp_present, md, rs, Exported))
+            decls
+            (approx_sig newenv srem)
+      | Psig_modtype d ->
+          let info = approx_modtype_info env d in
+          let scope = Ctype.create_scope () in
+          let (id, newenv) =
+            Env.enter_modtype ~scope d.pmtd_name.txt info env
+          in
+          Sig_modtype(id, info, Exported) :: approx_sig newenv srem
+      | Psig_open sod ->
+          let _, env = type_open_descr env sod in
+          approx_sig env srem
+      | Psig_include sincl ->
+          let smty = sincl.pincl_mod in
+          let mty = approx_modtype env smty in
+          let scope = Ctype.create_scope () in
+          let sg, newenv = Env.enter_signature ~scope
+              (extract_sig env smty.pmty_loc mty) env in
+          sg @ approx_sig newenv srem
+      | Psig_class sdecls | Psig_class_type sdecls ->
+          let decls = Typeclass.approx_class_declarations env sdecls in
+          let rem = approx_sig env srem in
+          map_rec (fun rs decl ->
+            let open Typeclass in [
+              Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs,
+                             Exported);
+              Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs, Exported);
+              Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs, Exported);
+            ]
+          ) decls [rem]
+          |> List.flatten
+      | _ ->
+          approx_sig env srem
+
+and approx_modtype_info env sinfo =
+  {
+   mtd_type = Option.map (approx_modtype env) sinfo.pmtd_type;
+   mtd_attributes = sinfo.pmtd_attributes;
+   mtd_loc = sinfo.pmtd_loc;
+   mtd_uid = Uid.internal_not_actually_unique;
+  }
+
+let approx_modtype env smty =
+  Warnings.without_warnings
+    (fun () -> approx_modtype env smty)
+
+(* Auxiliaries for checking the validity of name shadowing in signatures and
+   structures.
+   If a shadowing is valid, we also record some information (its ident,
+   location where it first appears, etc) about the item that gets shadowed. *)
+module Signature_names : sig
+  type t
+
+  type info = [
+    | `Exported
+    | `From_open
+    | `Shadowable of Ident.t * Location.t
+    | `Substituted_away of Subst.t
+  ]
+
+  val create : unit -> t
+
+  val check_value     : ?info:info -> t -> Location.t -> Ident.t -> unit
+  val check_type      : ?info:info -> t -> Location.t -> Ident.t -> unit
+  val check_typext    : ?info:info -> t -> Location.t -> Ident.t -> unit
+  val check_module    : ?info:info -> t -> Location.t -> Ident.t -> unit
+  val check_modtype   : ?info:info -> t -> Location.t -> Ident.t -> unit
+  val check_class     : ?info:info -> t -> Location.t -> Ident.t -> unit
+  val check_class_type: ?info:info -> t -> Location.t -> Ident.t -> unit
+
+  val check_sig_item:
+    ?info:info -> t -> Location.t -> Types.signature_item -> unit
+
+  val simplify: Env.t -> t -> Types.signature -> Types.signature
+end = struct
+
+  type bound_info = [
+    | `Exported
+    | `Shadowable of Ident.t * Location.t
+  ]
+
+  type info = [
+    | `From_open
+    | `Substituted_away of Subst.t
+    | bound_info
+  ]
+
+  type hide_reason =
+    | From_open
+    | Shadowed_by of Ident.t * Location.t
+
+  type to_be_removed = {
+    mutable subst: Subst.t;
+    mutable hide: (Sig_component_kind.t * Location.t * hide_reason) Ident.Map.t;
+  }
+
+  type names_infos = (string, bound_info) Hashtbl.t
+
+  type names = {
+    values: names_infos;
+    types: names_infos;
+    modules: names_infos;
+    modtypes: names_infos;
+    typexts: names_infos;
+    classes: names_infos;
+    class_types: names_infos;
+  }
+
+  let new_names () = {
+    values = Hashtbl.create 16;
+    types = Hashtbl.create 16;
+    modules = Hashtbl.create 16;
+    modtypes = Hashtbl.create 16;
+    typexts = Hashtbl.create 16;
+    classes = Hashtbl.create 16;
+    class_types = Hashtbl.create 16;
+  }
+
+  type t = {
+    bound: names;
+    to_be_removed: to_be_removed;
+  }
+
+  let create () = {
+    bound = new_names ();
+    to_be_removed = {
+      subst = Subst.identity;
+      hide = Ident.Map.empty;
+    };
+  }
+
+  let check cl loc (tbl : names_infos) id (info : info) to_be_removed =
+    match info with
+    | `Substituted_away s ->
+        to_be_removed.subst <- Subst.compose s to_be_removed.subst
+    | `From_open ->
+        to_be_removed.hide <-
+          Ident.Map.add id (cl, loc, From_open) to_be_removed.hide
+    | #bound_info as bound_info ->
+        let name = Ident.name id in
+        match Hashtbl.find_opt tbl name with
+        | None -> Hashtbl.add tbl name bound_info
+        | Some (`Shadowable (shadowed_id, shadowed_loc)) ->
+            Hashtbl.replace tbl name bound_info;
+            let reason = Shadowed_by (id, loc) in
+            to_be_removed.hide <-
+              Ident.Map.add shadowed_id (cl, shadowed_loc, reason)
+                to_be_removed.hide
+        | Some `Exported ->
+            raise(Error(loc, Env.empty, Repeated_name(cl, name)))
+
+  let check_value ?info t loc id =
+    let info =
+      match info with
+      | Some i -> i
+      | None -> `Shadowable (id, loc)
+    in
+    check Sig_component_kind.Value loc t.bound.values id info t.to_be_removed
+  let check_type ?(info=`Exported) t loc id =
+    check Sig_component_kind.Type loc t.bound.types id info t.to_be_removed
+  let check_module ?(info=`Exported) t loc id =
+    check Sig_component_kind.Module loc t.bound.modules id info t.to_be_removed
+  let check_modtype ?(info=`Exported) t loc id =
+    check Sig_component_kind.Module_type loc t.bound.modtypes id info
+      t.to_be_removed
+  let check_typext ?(info=`Exported) t loc id =
+    check Sig_component_kind.Extension_constructor loc t.bound.typexts id info
+      t.to_be_removed
+  let check_class ?(info=`Exported) t loc id =
+    check Sig_component_kind.Class loc t.bound.classes id info t.to_be_removed
+  let check_class_type ?(info=`Exported) t loc id =
+    check Sig_component_kind.Class_type loc t.bound.class_types id info
+      t.to_be_removed
+
+  let check_sig_item ?info names loc component =
+    let info id loc =
+      match info with
+      | None -> `Shadowable (id, loc)
+      | Some i -> i
+    in
+    match component with
+    | Sig_type(id, _, _, _) ->
+        check_type names loc id ~info:(info id loc)
+    | Sig_module(id, _, _, _, _) ->
+        check_module names loc id ~info:(info id loc)
+    | Sig_modtype(id, _, _) ->
+        check_modtype names loc id ~info:(info id loc)
+    | Sig_typext(id, _, _, _) ->
+        check_typext names loc id ~info:(info id loc)
+    | Sig_value (id, _, _) ->
+        check_value names loc id ~info:(info id loc)
+    | Sig_class (id, _, _, _) ->
+        check_class names loc id ~info:(info id loc)
+    | Sig_class_type (id, _, _, _) ->
+        check_class_type names loc id ~info:(info id loc)
+
+  (* We usually require name uniqueness of signature components (e.g. types,
+     modules, etc), however in some situation reusing the name is allowed: if
+     the component is a value or an extension, or if the name is introduced by
+     an include.
+     When there are multiple specifications of a component with the same name,
+     we try to keep only the last (rightmost) one, removing all references to
+     the previous ones from the signature.
+     If some reference cannot be removed, then we error out with
+     [Cannot_hide_id].
+  *)
+
+  let simplify env t sg =
+    let to_remove = t.to_be_removed in
+    let ids_to_remove =
+      Ident.Map.fold (fun id (kind,  _, _) lst ->
+        if Sig_component_kind.can_appear_in_types kind then
+          id :: lst
+        else
+          lst
+      ) to_remove.hide []
+    in
+    let aux component sg =
+      let user_kind, user_id, user_loc =
+        let open Sig_component_kind in
+        match component with
+        | Sig_value(id, v, _) -> Value, id, v.val_loc
+        | Sig_type (id, td, _, _) -> Type, id, td.type_loc
+        | Sig_typext (id, te, _, _) -> Extension_constructor, id, te.ext_loc
+        | Sig_module (id, _, md, _, _) -> Module, id, md.md_loc
+        | Sig_modtype (id, mtd, _) -> Module_type, id, mtd.mtd_loc
+        | Sig_class (id, c, _, _) -> Class, id, c.cty_loc
+        | Sig_class_type (id, ct, _, _) -> Class_type, id, ct.clty_loc
+      in
+      if Ident.Map.mem user_id to_remove.hide then
+        sg
+      else begin
+        let component =
+          if to_remove.subst == Subst.identity then
+            component
+          else
+            Subst.signature_item Keep to_remove.subst component
+        in
+        let component =
+          match ids_to_remove with
+          | [] -> component
+          | ids ->
+            try Mtype.nondep_sig_item env ids component with
+            | Ctype.Nondep_cannot_erase removed_item_id ->
+              let (removed_item_kind, removed_item_loc, reason) =
+                Ident.Map.find removed_item_id to_remove.hide
+              in
+              let err_loc, hiding_error =
+                match reason with
+                | From_open ->
+                  removed_item_loc,
+                  Appears_in_signature {
+                    opened_item_kind = removed_item_kind;
+                    opened_item_id = removed_item_id;
+                    user_id;
+                    user_kind;
+                    user_loc;
+                  }
+                | Shadowed_by (shadower_id, shadower_loc) ->
+                  shadower_loc,
+                  Illegal_shadowing {
+                    shadowed_item_kind = removed_item_kind;
+                    shadowed_item_id = removed_item_id;
+                    shadowed_item_loc = removed_item_loc;
+                    shadower_id;
+                    user_id;
+                    user_kind;
+                    user_loc;
+                  }
+              in
+              raise (Error(err_loc, env, Cannot_hide_id hiding_error))
+        in
+        component :: sg
+      end
+    in
+    List.fold_right aux sg []
+end
+
+let has_remove_aliases_attribute attr =
+  let remove_aliases =
+    Attr_helper.get_no_payload_attribute
+      ["remove_aliases"; "ocaml.remove_aliases"] attr
+  in
+  match remove_aliases with
+  | None -> false
+  | Some _ -> true
+
+(* Check and translate a module type expression *)
+
+let transl_modtype_longident loc env lid =
+  let (path, _info) = Env.lookup_modtype ~loc lid env in
+  path
+
+let transl_module_alias loc env lid =
+  Env.lookup_module_path ~load:false ~loc lid env
+
+let mkmty desc typ env loc attrs =
+  let mty = {
+    mty_desc = desc;
+    mty_type = typ;
+    mty_loc = loc;
+    mty_env = env;
+    mty_attributes = attrs;
+    } in
+  Cmt_format.add_saved_type (Cmt_format.Partial_module_type mty);
+  mty
+
+let mksig desc env loc =
+  let sg = { sig_desc = desc; sig_loc = loc; sig_env = env } in
+  Cmt_format.add_saved_type (Cmt_format.Partial_signature_item sg);
+  sg
+
+(* let signature sg = List.map (fun item -> item.sig_type) sg *)
+
+let rec transl_modtype env smty =
+  Builtin_attributes.warning_scope smty.pmty_attributes
+    (fun () -> transl_modtype_aux env smty)
+
+and transl_modtype_functor_arg env sarg =
+  let mty = transl_modtype env sarg in
+  {mty with mty_type = Mtype.scrape_for_functor_arg env mty.mty_type}
+
+and transl_modtype_aux env smty =
+  let loc = smty.pmty_loc in
+  match smty.pmty_desc with
+    Pmty_ident lid ->
+      let path = transl_modtype_longident loc env lid.txt in
+      mkmty (Tmty_ident (path, lid)) (Mty_ident path) env loc
+        smty.pmty_attributes
+  | Pmty_alias lid ->
+      let path = transl_module_alias loc env lid.txt in
+      mkmty (Tmty_alias (path, lid)) (Mty_alias path) env loc
+        smty.pmty_attributes
+  | Pmty_signature ssg ->
+      let sg = transl_signature env ssg in
+      mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc
+        smty.pmty_attributes
+  | Pmty_functor(sarg_opt, sres) ->
+      let t_arg, ty_arg, newenv =
+        match sarg_opt with
+        | Unit -> Unit, Types.Unit, env
+        | Named (param, sarg) ->
+          let arg = transl_modtype_functor_arg env sarg in
+          let (id, newenv) =
+            match param.txt with
+            | None -> None, env
+            | Some name ->
+              let scope = Ctype.create_scope () in
+              let id, newenv =
+                let arg_md =
+                  { md_type = arg.mty_type;
+                    md_attributes = [];
+                    md_loc = param.loc;
+                    md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+                  }
+                in
+                Env.enter_module_declaration ~scope ~arg:true name Mp_present
+                  arg_md env
+              in
+              Some id, newenv
+          in
+          Named (id, param, arg), Types.Named (id, arg.mty_type), newenv
+      in
+      let res = transl_modtype newenv sres in
+      mkmty (Tmty_functor (t_arg, res))
+        (Mty_functor(ty_arg, res.mty_type)) env loc
+        smty.pmty_attributes
+  | Pmty_with(sbody, constraints) ->
+      let body = transl_modtype env sbody in
+      let init_sg = extract_sig env sbody.pmty_loc body.mty_type in
+      let remove_aliases = has_remove_aliases_attribute smty.pmty_attributes in
+      let (rev_tcstrs, final_sg) =
+        List.fold_left
+          (fun (rev_tcstrs,sg) sdecl ->
+            let (tcstr, sg) =
+              merge_constraint env remove_aliases smty.pmty_loc sg sdecl
+            in
+            (tcstr :: rev_tcstrs, sg)
+        )
+        ([],init_sg) constraints in
+      let scope = Ctype.create_scope () in
+      mkmty (Tmty_with ( body, List.rev rev_tcstrs))
+        (Mtype.freshen ~scope (Mty_signature final_sg)) env loc
+        smty.pmty_attributes
+  | Pmty_typeof smod ->
+      let env = Env.in_signature false env in
+      let tmty, mty = !type_module_type_of_fwd env smod in
+      mkmty (Tmty_typeof tmty) mty env loc smty.pmty_attributes
+  | Pmty_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and transl_signature env sg =
+  let names = Signature_names.create () in
+  let rec transl_sig env sg =
+    match sg with
+      [] -> [], [], env
+    | item :: srem ->
+        let loc = item.psig_loc in
+        match item.psig_desc with
+        | Psig_value sdesc ->
+            let (tdesc, newenv) =
+              Typedecl.transl_value_decl env item.psig_loc sdesc
+            in
+            Signature_names.check_value names tdesc.val_loc tdesc.val_id;
+            let (trem,rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_value tdesc) env loc :: trem,
+            Sig_value(tdesc.val_id, tdesc.val_val, Exported) :: rem,
+              final_env
+        | Psig_type (rec_flag, sdecls) ->
+            let (decls, newenv) =
+              Typedecl.transl_type_decl env rec_flag sdecls
+            in
+            List.iter (fun td ->
+              Signature_names.check_type names td.typ_loc td.typ_id
+            ) decls;
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            let sg =
+              map_rec_type_with_row_types ~rec_flag
+                (fun rs td -> Sig_type(td.typ_id, td.typ_type, rs, Exported))
+                decls rem
+            in
+            mksig (Tsig_type (rec_flag, decls)) env loc :: trem,
+            sg,
+            final_env
+        | Psig_typesubst sdecls ->
+            let (decls, newenv) =
+              Typedecl.transl_type_decl env Nonrecursive sdecls
+            in
+            List.iter (fun td ->
+              if td.typ_kind <> Ttype_abstract || td.typ_manifest = None ||
+                 td.typ_private = Private
+              then
+                raise (Error (td.typ_loc, env, Invalid_type_subst_rhs));
+              let params = td.typ_type.type_params in
+              if params_are_constrained params
+              then raise(Error(loc, env, With_cannot_remove_constrained_type));
+              let info =
+                  let subst =
+                    Subst.add_type_function (Pident td.typ_id)
+                      ~params
+                      ~body:(Option.get td.typ_type.type_manifest)
+                      Subst.identity
+                  in
+                  Some (`Substituted_away subst)
+              in
+              Signature_names.check_type ?info names td.typ_loc td.typ_id
+            ) decls;
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            let sg = rem
+            in
+            mksig (Tsig_typesubst decls) env loc :: trem,
+            sg,
+            final_env
+        | Psig_typext styext ->
+            let (tyext, newenv) =
+              Typedecl.transl_type_extension false env item.psig_loc styext
+            in
+            let constructors = tyext.tyext_constructors in
+            List.iter (fun ext ->
+              Signature_names.check_typext names ext.ext_loc ext.ext_id
+            ) constructors;
+            let (trem, rem, final_env) = transl_sig newenv srem in
+              mksig (Tsig_typext tyext) env loc :: trem,
+              map_ext (fun es ext ->
+                Sig_typext(ext.ext_id, ext.ext_type, es, Exported)
+              ) constructors rem,
+              final_env
+        | Psig_exception sext ->
+            let (ext, newenv) = Typedecl.transl_type_exception env sext in
+            let constructor = ext.tyexn_constructor in
+            Signature_names.check_typext names constructor.ext_loc
+              constructor.ext_id;
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_exception ext) env loc :: trem,
+            Sig_typext(constructor.ext_id,
+                       constructor.ext_type,
+                       Text_exception,
+                       Exported) :: rem,
+            final_env
+        | Psig_module pmd ->
+            let scope = Ctype.create_scope () in
+            let tmty =
+              Builtin_attributes.warning_scope pmd.pmd_attributes
+                (fun () -> transl_modtype env pmd.pmd_type)
+            in
+            let pres =
+              match tmty.mty_type with
+              | Mty_alias _ -> Mp_absent
+              | _ -> Mp_present
+            in
+            let md = {
+              md_type=tmty.mty_type;
+              md_attributes=pmd.pmd_attributes;
+              md_loc=pmd.pmd_loc;
+              md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+            }
+            in
+            let id, newenv =
+              match pmd.pmd_name.txt with
+              | None -> None, env
+              | Some name ->
+                let id, newenv =
+                  Env.enter_module_declaration ~scope name pres md env
+                in
+                Signature_names.check_module names pmd.pmd_name.loc id;
+                Some id, newenv
+            in
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_module {md_id=id; md_name=pmd.pmd_name;
+                                md_presence=pres; md_type=tmty;
+                                md_loc=pmd.pmd_loc;
+                                md_attributes=pmd.pmd_attributes})
+              env loc :: trem,
+            (match id with
+             | None -> rem
+             | Some id -> Sig_module(id, pres, md, Trec_not, Exported) :: rem),
+            final_env
+        | Psig_modsubst pms ->
+            let scope = Ctype.create_scope () in
+            let path, md =
+              Env.lookup_module ~loc:pms.pms_manifest.loc
+                pms.pms_manifest.txt env
+            in
+            let aliasable = not (Env.is_functor_arg path env) in
+            let md =
+              if not aliasable then
+                md
+              else
+                { md_type = Mty_alias path;
+                  md_attributes = pms.pms_attributes;
+                  md_loc = pms.pms_loc;
+                  md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+                }
+            in
+            let pres =
+              match md.md_type with
+              | Mty_alias _ -> Mp_absent
+              | _ -> Mp_present
+            in
+            let id, newenv =
+              Env.enter_module_declaration ~scope pms.pms_name.txt pres md env
+            in
+            let info =
+              `Substituted_away (Subst.add_module id path Subst.identity)
+            in
+            Signature_names.check_module ~info names pms.pms_name.loc id;
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_modsubst {ms_id=id; ms_name=pms.pms_name;
+                                  ms_manifest=path; ms_txt=pms.pms_manifest;
+                                  ms_loc=pms.pms_loc;
+                                  ms_attributes=pms.pms_attributes})
+              env loc :: trem,
+            rem,
+            final_env
+        | Psig_recmodule sdecls ->
+            let (tdecls, newenv) =
+              transl_recmodule_modtypes env sdecls in
+            let decls =
+              List.filter_map (fun (md, uid) ->
+                match md.md_id with
+                | None -> None
+                | Some id -> Some (id, md, uid)
+              ) tdecls
+            in
+            List.iter (fun (id, md, _) ->
+              Signature_names.check_module names md.md_loc id
+            ) decls;
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_recmodule (List.map fst tdecls)) env loc :: trem,
+            map_rec (fun rs (id, md, uid) ->
+                let d = {Types.md_type = md.md_type.mty_type;
+                         md_attributes = md.md_attributes;
+                         md_loc = md.md_loc;
+                         md_uid = uid;
+                        } in
+                Sig_module(id, Mp_present, d, rs, Exported))
+              decls rem,
+            final_env
+        | Psig_modtype pmtd ->
+            let newenv, mtd, sg = transl_modtype_decl names env pmtd in
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_modtype mtd) env loc :: trem,
+            sg :: rem,
+            final_env
+        | Psig_open sod ->
+            let (od, newenv) = type_open_descr env sod in
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_open od) env loc :: trem,
+            rem, final_env
+        | Psig_include sincl ->
+            let smty = sincl.pincl_mod in
+            let tmty =
+              Builtin_attributes.warning_scope sincl.pincl_attributes
+                (fun () -> transl_modtype env smty)
+            in
+            let mty = tmty.mty_type in
+            let scope = Ctype.create_scope () in
+            let sg, newenv = Env.enter_signature ~scope
+                       (extract_sig env smty.pmty_loc mty) env in
+            List.iter (Signature_names.check_sig_item names item.psig_loc) sg;
+            let incl =
+              { incl_mod = tmty;
+                incl_type = sg;
+                incl_attributes = sincl.pincl_attributes;
+                incl_loc = sincl.pincl_loc;
+              }
+            in
+            let (trem, rem, final_env) = transl_sig newenv srem  in
+            mksig (Tsig_include incl) env loc :: trem,
+            sg @ rem,
+            final_env
+        | Psig_class cl ->
+            let (classes, newenv) = Typeclass.class_descriptions env cl in
+            List.iter (fun cls ->
+              let open Typeclass in
+              let loc = cls.cls_id_loc.Location.loc in
+              Signature_names.check_type names loc cls.cls_obj_id;
+              Signature_names.check_class names loc cls.cls_id;
+              Signature_names.check_class_type names loc cls.cls_ty_id;
+              Signature_names.check_type names loc cls.cls_typesharp_id;
+            ) classes;
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            let sg =
+              map_rec (fun rs cls ->
+                let open Typeclass in
+                [Sig_class(cls.cls_id, cls.cls_decl, rs, Exported);
+                 Sig_class_type(cls.cls_ty_id, cls.cls_ty_decl, rs, Exported);
+                 Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs, Exported);
+                 Sig_type(cls.cls_typesharp_id, cls.cls_abbr, rs, Exported)]
+              ) classes [rem]
+              |> List.flatten
+            in
+            let typedtree =
+              mksig (Tsig_class
+                       (List.map (fun decr ->
+                          decr.Typeclass.cls_info) classes)) env loc
+              :: trem
+            in
+            typedtree, sg, final_env
+        | Psig_class_type cl ->
+            let (classes, newenv) = Typeclass.class_type_declarations env cl in
+            List.iter (fun decl ->
+              let open Typeclass in
+              let loc = decl.clsty_id_loc.Location.loc in
+              Signature_names.check_class_type names loc decl.clsty_ty_id;
+              Signature_names.check_type names loc decl.clsty_obj_id;
+              Signature_names.check_type names loc decl.clsty_typesharp_id;
+            ) classes;
+            let (trem,rem, final_env) = transl_sig newenv srem in
+            let sg =
+              map_rec (fun rs decl ->
+                let open Typeclass in
+                [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs,
+                                Exported);
+                 Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs, Exported);
+                 Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs,
+                          Exported)
+                ]
+              ) classes [rem]
+              |> List.flatten
+            in
+            let typedtree =
+              mksig
+                (Tsig_class_type
+                   (List.map (fun decl -> decl.Typeclass.clsty_info) classes))
+                env loc
+              :: trem
+            in
+            typedtree, sg, final_env
+        | Psig_attribute x ->
+            Builtin_attributes.warning_attribute x;
+            let (trem,rem, final_env) = transl_sig env srem in
+            mksig (Tsig_attribute x) env loc :: trem, rem, final_env
+        | Psig_extension (ext, _attrs) ->
+            raise (Error_forward (Builtin_attributes.error_of_extension ext))
+  in
+  let previous_saved_types = Cmt_format.get_saved_types () in
+  Builtin_attributes.warning_scope []
+    (fun () ->
+       let (trem, rem, final_env) = transl_sig (Env.in_signature true env) sg in
+       let rem = Signature_names.simplify final_env names rem in
+       let sg =
+         { sig_items = trem; sig_type = rem; sig_final_env = final_env }
+       in
+       Cmt_format.set_saved_types
+         ((Cmt_format.Partial_signature sg) :: previous_saved_types);
+       sg
+    )
+
+and transl_modtype_decl names env pmtd =
+  Builtin_attributes.warning_scope pmtd.pmtd_attributes
+    (fun () -> transl_modtype_decl_aux names env pmtd)
+
+and transl_modtype_decl_aux names env
+    {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} =
+  let tmty =
+    Option.map (transl_modtype (Env.in_signature true env)) pmtd_type
+  in
+  let decl =
+    {
+     Types.mtd_type=Option.map (fun t -> t.mty_type) tmty;
+     mtd_attributes=pmtd_attributes;
+     mtd_loc=pmtd_loc;
+     mtd_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+    }
+  in
+  let scope = Ctype.create_scope () in
+  let (id, newenv) = Env.enter_modtype ~scope pmtd_name.txt decl env in
+  Signature_names.check_modtype names pmtd_loc id;
+  let mtd =
+    {
+     mtd_id=id;
+     mtd_name=pmtd_name;
+     mtd_type=tmty;
+     mtd_attributes=pmtd_attributes;
+     mtd_loc=pmtd_loc;
+    }
+  in
+  newenv, mtd, Sig_modtype(id, decl, Exported)
+
+and transl_recmodule_modtypes env sdecls =
+  let make_env curr =
+    List.fold_left
+      (fun env (id, _, md, _) ->
+         Option.fold ~none:env
+           ~some:(fun id -> Env.add_module_declaration ~check:true ~arg:true
+                              id Mp_present md env) id)
+      env curr in
+  let transition env_c curr =
+    List.map2
+      (fun pmd (id, id_loc, md, _) ->
+        let tmty =
+          Builtin_attributes.warning_scope pmd.pmd_attributes
+            (fun () -> transl_modtype env_c pmd.pmd_type)
+        in
+        let md = { md with Types.md_type = tmty.mty_type } in
+        (id, id_loc, md, tmty))
+      sdecls curr in
+  let map_mtys curr =
+    List.filter_map
+      (fun (id, _, md, _) -> Option.map (fun id -> (id, md)) id)
+      curr
+  in
+  let scope = Ctype.create_scope () in
+  let ids =
+    List.map (fun x -> Option.map (Ident.create_scoped ~scope) x.pmd_name.txt)
+      sdecls
+  in
+  let approx_env =
+    List.fold_left
+      (fun env ->
+         Option.fold ~none:env ~some:(fun id -> (* cf #5965 *)
+           Env.enter_unbound_module (Ident.name id)
+             Mod_unbound_illegal_recursion env
+         ))
+      env ids
+  in
+  let init =
+    List.map2
+      (fun id pmd ->
+         let md =
+           { md_type = approx_modtype approx_env pmd.pmd_type;
+             md_loc = pmd.pmd_loc;
+             md_attributes = pmd.pmd_attributes;
+             md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) }
+         in
+        (id, pmd.pmd_name, md, ()))
+      ids sdecls
+  in
+  let env0 = make_env init in
+  let dcl1 =
+    Warnings.without_warnings
+      (fun () -> transition env0 init)
+  in
+  let env1 = make_env dcl1 in
+  check_recmod_typedecls env1 (map_mtys dcl1);
+  let dcl2 = transition env1 dcl1 in
+(*
+  List.iter
+    (fun (id, mty) ->
+      Format.printf "%a: %a@." Printtyp.ident id Printtyp.modtype mty)
+    dcl2;
+*)
+  let env2 = make_env dcl2 in
+  check_recmod_typedecls env2 (map_mtys dcl2);
+  let dcl2 =
+    List.map2 (fun pmd (id, id_loc, md, mty) ->
+      let tmd =
+        {md_id=id; md_name=id_loc; md_type=mty;
+         md_presence=Mp_present;
+         md_loc=pmd.pmd_loc;
+         md_attributes=pmd.pmd_attributes}
+      in
+      tmd, md.md_uid
+    ) sdecls dcl2
+  in
+  (dcl2, env2)
+
+(* Try to convert a module expression to a module path. *)
+
+exception Not_a_path
+
+let rec path_of_module mexp =
+  match mexp.mod_desc with
+  | Tmod_ident (p,_) -> p
+  | Tmod_apply(funct, arg, _coercion) when !Clflags.applicative_functors ->
+      Papply(path_of_module funct, path_of_module arg)
+  | Tmod_constraint (mexp, _, _, _) ->
+      path_of_module mexp
+  | _ -> raise Not_a_path
+
+let path_of_module mexp =
+ try Some (path_of_module mexp) with Not_a_path -> None
+
+(* Check that all core type schemes in a structure are closed *)
+
+let rec closed_modtype env = function
+    Mty_ident _ -> true
+  | Mty_alias _ -> true
+  | Mty_signature sg ->
+      let env = Env.add_signature sg env in
+      List.for_all (closed_signature_item env) sg
+  | Mty_functor(arg_opt, body) ->
+      let env =
+        match arg_opt with
+        | Unit
+        | Named (None, _) -> env
+        | Named (Some id, param) ->
+            Env.add_module ~arg:true id Mp_present param env
+      in
+      closed_modtype env body
+
+and closed_signature_item env = function
+    Sig_value(_id, desc, _) -> Ctype.closed_schema env desc.val_type
+  | Sig_module(_id, _, md, _, _) -> closed_modtype env md.md_type
+  | _ -> true
+
+let check_nongen_scheme env sig_item =
+  match sig_item with
+    Sig_value(_id, vd, _) ->
+      if not (Ctype.closed_schema env vd.val_type) then
+        raise (Error (vd.val_loc, env, Non_generalizable vd.val_type))
+  | Sig_module (_id, _, md, _, _) ->
+      if not (closed_modtype env md.md_type) then
+        raise(Error(md.md_loc, env, Non_generalizable_module md.md_type))
+  | _ -> ()
+
+let check_nongen_schemes env sg =
+  List.iter (check_nongen_scheme env) sg
+
+(* Helpers for typing recursive modules *)
+
+let anchor_submodule name anchor =
+  match anchor, name with
+  | None, _
+  | _, None ->
+      None
+  | Some p, Some name ->
+      Some(Pdot(p, name))
+
+let anchor_recmodule = Option.map (fun id -> Pident id)
+
+let enrich_type_decls anchor decls oldenv newenv =
+  match anchor with
+    None -> newenv
+  | Some p ->
+      List.fold_left
+        (fun e info ->
+          let id = info.typ_id in
+          let info' =
+            Mtype.enrich_typedecl oldenv (Pdot(p, Ident.name id))
+              id info.typ_type
+          in
+            Env.add_type ~check:true id info' e)
+        oldenv decls
+
+let enrich_module_type anchor name mty env =
+  match anchor, name with
+  | None, _
+  | _, None ->
+      mty
+  | Some p, Some name ->
+      Mtype.enrich_modtype env (Pdot(p, name)) mty
+
+let check_recmodule_inclusion env bindings =
+  (* PR#4450, PR#4470: consider
+        module rec X : DECL = MOD  where MOD has inferred type ACTUAL
+     The "natural" typing condition
+        E, X: ACTUAL |- ACTUAL <: DECL
+     leads to circularities through manifest types.
+     Instead, we "unroll away" the potential circularities a finite number
+     of times.  The (weaker) condition we implement is:
+        E, X: DECL,
+           X1: ACTUAL,
+           X2: ACTUAL{X <- X1}/X1
+           ...
+           Xn: ACTUAL{X <- X(n-1)}/X(n-1)
+        |- ACTUAL{X <- Xn}/Xn <: DECL{X <- Xn}
+     so that manifest types rooted at X(n+1) are expanded in terms of X(n),
+     avoiding circularities.  The strengthenings ensure that
+     Xn.t = X(n-1).t = ... = X2.t = X1.t.
+     N can be chosen arbitrarily; larger values of N result in more
+     recursive definitions being accepted.  A good choice appears to be
+     the number of mutually recursive declarations. *)
+
+  let subst_and_strengthen env scope s id mty =
+    let mty = Subst.modtype (Rescope scope) s mty in
+    match id with
+    | None -> mty
+    | Some id ->
+        Mtype.strengthen ~aliasable:false env mty
+          (Subst.module_path s (Pident id))
+  in
+
+  let rec check_incl first_time n env s =
+    let scope = Ctype.create_scope () in
+    if n > 0 then begin
+      (* Generate fresh names Y_i for the rec. bound module idents X_i *)
+      let bindings1 =
+        List.map
+          (fun (id, _name, _mty_decl, _modl, mty_actual, _attrs, _loc, _uid) ->
+             let ids =
+               Option.map
+                 (fun id -> (id, Ident.create_scoped ~scope (Ident.name id))) id
+             in
+             (ids, mty_actual))
+          bindings in
+      (* Enter the Y_i in the environment with their actual types substituted
+         by the input substitution s *)
+      let env' =
+        List.fold_left
+          (fun env (ids, mty_actual) ->
+             match ids with
+             | None -> env
+             | Some (id, id') ->
+               let mty_actual' =
+                 if first_time
+                 then mty_actual
+                 else subst_and_strengthen env scope s (Some id) mty_actual
+               in
+               Env.add_module ~arg:false id' Mp_present mty_actual' env)
+          env bindings1 in
+      (* Build the output substitution Y_i <- X_i *)
+      let s' =
+        List.fold_left
+          (fun s (ids, _mty_actual) ->
+             match ids with
+             | None -> s
+             | Some (id, id') -> Subst.add_module id (Pident id') s)
+          Subst.identity bindings1 in
+      (* Recurse with env' and s' *)
+      check_incl false (n-1) env' s'
+    end else begin
+      (* Base case: check inclusion of s(mty_actual) in s(mty_decl)
+         and insert coercion if needed *)
+      let check_inclusion
+            (id, name, mty_decl, modl, mty_actual, attrs, loc, uid) =
+        let mty_decl' = Subst.modtype (Rescope scope) s mty_decl.mty_type
+        and mty_actual' = subst_and_strengthen env scope s id mty_actual in
+        let coercion =
+          try
+            Includemod.modtypes ~loc:modl.mod_loc ~mark:Mark_both env
+              mty_actual' mty_decl'
+          with Includemod.Error msg ->
+            raise(Error(modl.mod_loc, env, Not_included msg)) in
+        let modl' =
+            { mod_desc = Tmod_constraint(modl, mty_decl.mty_type,
+                Tmodtype_explicit mty_decl, coercion);
+              mod_type = mty_decl.mty_type;
+              mod_env = env;
+              mod_loc = modl.mod_loc;
+              mod_attributes = [];
+             } in
+        let mb =
+          {
+            mb_id = id;
+            mb_name = name;
+            mb_presence = Mp_present;
+            mb_expr = modl';
+            mb_attributes = attrs;
+            mb_loc = loc;
+          }
+        in
+        mb, uid
+      in
+      List.map check_inclusion bindings
+    end
+  in check_incl true (List.length bindings) env Subst.identity
+
+(* Helper for unpack *)
+
+let rec package_constraints env loc mty constrs =
+  if constrs = [] then mty
+  else let sg = extract_sig env loc mty in
+  let sg' =
+    List.map
+      (function
+        | Sig_type (id, ({type_params=[]} as td), rs, priv)
+          when List.mem_assoc [Ident.name id] constrs ->
+            let ty = List.assoc [Ident.name id] constrs in
+            Sig_type (id, {td with type_manifest = Some ty}, rs, priv)
+        | Sig_module (id, _, md, rs, priv) ->
+            let rec aux = function
+              | (m :: ((_ :: _) as l), t) :: rest when m = Ident.name id ->
+                  (l, t) :: aux rest
+              | _ :: rest -> aux rest
+              | [] -> []
+            in
+            let md =
+              {md with
+               md_type = package_constraints env loc md.md_type (aux constrs)
+              }
+            in
+            Sig_module (id, Mp_present, md, rs, priv)
+        | item -> item
+      )
+      sg
+  in
+  Mty_signature sg'
+
+let modtype_of_package env loc p nl tl =
+  match (Env.find_modtype p env).mtd_type with
+  | Some mty when nl <> [] ->
+      package_constraints env loc mty
+        (List.combine (List.map Longident.flatten nl) tl)
+  | _ | exception Not_found (* missing cmi *) ->
+      if nl = [] then Mty_ident p
+      else raise(Error(loc, env, Signature_expected))
+
+let package_subtype env p1 nl1 tl1 p2 nl2 tl2 =
+  let mkmty p nl tl =
+    let ntl =
+      List.filter (fun (_n,t) -> Ctype.free_variables t = [])
+        (List.combine nl tl) in
+    let (nl, tl) = List.split ntl in
+    modtype_of_package env Location.none p nl tl
+  in
+  let mty1 = mkmty p1 nl1 tl1 and mty2 = mkmty p2 nl2 tl2 in
+  let loc = Location.none in
+  match Includemod.modtypes ~loc ~mark:Mark_both env mty1 mty2 with
+  | Tcoerce_none -> true
+  | _ | exception Includemod.Error _ -> false
+
+let () = Ctype.package_subtype := package_subtype
+
+let wrap_constraint env mark arg mty explicit =
+  let mark = if mark then Includemod.Mark_both else Includemod.Mark_neither in
+  let coercion =
+    try
+      Includemod.modtypes ~loc:arg.mod_loc env ~mark arg.mod_type mty
+    with Includemod.Error msg ->
+      raise(Error(arg.mod_loc, env, Not_included msg)) in
+  { mod_desc = Tmod_constraint(arg, mty, explicit, coercion);
+    mod_type = mty;
+    mod_env = env;
+    mod_attributes = [];
+    mod_loc = arg.mod_loc }
+
+(* Type a module value expression *)
+
+let rec type_module ?(alias=false) sttn funct_body anchor env smod =
+  Builtin_attributes.warning_scope smod.pmod_attributes
+    (fun () -> type_module_aux ~alias sttn funct_body anchor env smod)
+
+and type_module_aux ~alias sttn funct_body anchor env smod =
+  match smod.pmod_desc with
+    Pmod_ident lid ->
+      let path =
+        Env.lookup_module_path ~load:(not alias) ~loc:smod.pmod_loc lid.txt env
+      in
+      let md = { mod_desc = Tmod_ident (path, lid);
+                 mod_type = Mty_alias path;
+                 mod_env = env;
+                 mod_attributes = smod.pmod_attributes;
+                 mod_loc = smod.pmod_loc } in
+      let aliasable = not (Env.is_functor_arg path env) in
+      let md =
+        if alias && aliasable then
+          (Env.add_required_global (Path.head path); md)
+        else match (Env.find_module path env).md_type with
+        | Mty_alias p1 when not alias ->
+            let p1 = Env.normalize_module_path (Some smod.pmod_loc) env p1 in
+            let mty = Includemod.expand_module_alias env [] p1 in
+            { md with
+              mod_desc =
+                Tmod_constraint (md, mty, Tmodtype_implicit,
+                                 Tcoerce_alias (env, path, Tcoerce_none));
+              mod_type =
+                if sttn then Mtype.strengthen ~aliasable:true env mty p1
+                else mty }
+        | mty ->
+            let mty =
+              if sttn then Mtype.strengthen ~aliasable env mty path
+              else mty
+            in
+            { md with mod_type = mty }
+      in md
+  | Pmod_structure sstr ->
+      let (str, sg, names, _finalenv) =
+        type_structure funct_body anchor env sstr smod.pmod_loc in
+      let md =
+        { mod_desc = Tmod_structure str;
+          mod_type = Mty_signature sg;
+          mod_env = env;
+          mod_attributes = smod.pmod_attributes;
+          mod_loc = smod.pmod_loc }
+      in
+      let sg' = Signature_names.simplify _finalenv names sg in
+      if List.length sg' = List.length sg then md else
+      wrap_constraint env false md (Mty_signature sg')
+        Tmodtype_implicit
+  | Pmod_functor(arg_opt, sbody) ->
+      let t_arg, ty_arg, newenv, funct_body =
+        match arg_opt with
+        | Unit -> Unit, Types.Unit, env, false
+        | Named (param, smty) ->
+          let mty = transl_modtype_functor_arg env smty in
+          let scope = Ctype.create_scope () in
+          let (id, newenv) =
+            match param.txt with
+            | None -> None, env
+            | Some name ->
+              let arg_md =
+                { md_type = mty.mty_type;
+                  md_attributes = [];
+                  md_loc = param.loc;
+                  md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+                }
+              in
+              let id, newenv =
+                Env.enter_module_declaration ~scope ~arg:true name Mp_present
+                  arg_md env
+              in
+              Some id, newenv
+          in
+          Named (id, param, mty), Types.Named (id, mty.mty_type), newenv, true
+      in
+      let body = type_module sttn funct_body None newenv sbody in
+      { mod_desc = Tmod_functor(t_arg, body);
+        mod_type = Mty_functor(ty_arg, body.mod_type);
+        mod_env = env;
+        mod_attributes = smod.pmod_attributes;
+        mod_loc = smod.pmod_loc }
+  | Pmod_apply(sfunct, sarg) ->
+      let arg = type_module true funct_body None env sarg in
+      let path = path_of_module arg in
+      let funct =
+        type_module (sttn && path <> None) funct_body None env sfunct in
+      begin match Env.scrape_alias env funct.mod_type with
+      | Mty_functor (Unit, mty_res) ->
+          if sarg.pmod_desc <> Pmod_structure [] then
+            raise (Error (sfunct.pmod_loc, env, Apply_generative));
+          if funct_body && Mtype.contains_type env funct.mod_type then
+            raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
+          { mod_desc = Tmod_apply(funct, arg, Tcoerce_none);
+            mod_type = mty_res;
+            mod_env = env;
+            mod_attributes = smod.pmod_attributes;
+            mod_loc = smod.pmod_loc }
+      | Mty_functor (Named (param, mty_param), mty_res) as mty_functor ->
+          let coercion =
+            try
+              Includemod.modtypes ~loc:sarg.pmod_loc ~mark:Mark_both env
+                arg.mod_type mty_param
+            with Includemod.Error msg ->
+              raise(Error(sarg.pmod_loc, env, Not_included msg)) in
+          let mty_appl =
+            match path with
+            | Some path ->
+                let scope = Ctype.create_scope () in
+                let subst =
+                  match param with
+                  | None -> Subst.identity
+                  | Some p -> Subst.add_module p path Subst.identity
+                in
+                Subst.modtype (Rescope scope) subst mty_res
+            | None ->
+                let env, nondep_mty =
+                  match param with
+                  | None -> env, mty_res
+                  | Some param ->
+                      let env =
+                        Env.add_module ~arg:true param Mp_present arg.mod_type
+                          env
+                      in
+                      check_well_formed_module env smod.pmod_loc
+                        "the signature of this functor application" mty_res;
+                      try env, Mtype.nondep_supertype env [param] mty_res
+                      with Ctype.Nondep_cannot_erase _ ->
+                        raise(Error(smod.pmod_loc, env,
+                                    Cannot_eliminate_dependency mty_functor))
+                in
+                begin match
+                  Includemod.modtypes ~mark:Mark_neither
+                    ~loc:smod.pmod_loc env mty_res nondep_mty
+                with
+                | Tcoerce_none -> ()
+                | _ ->
+                  fatal_error
+                    "unexpected coercion from original module type to \
+                     nondep_supertype one"
+                | exception Includemod.Error _ ->
+                  fatal_error
+                    "nondep_supertype not included in original module type"
+                end;
+                nondep_mty
+          in
+          check_well_formed_module env smod.pmod_loc
+            "the signature of this functor application" mty_appl;
+          { mod_desc = Tmod_apply(funct, arg, coercion);
+            mod_type = mty_appl;
+            mod_env = env;
+            mod_attributes = smod.pmod_attributes;
+            mod_loc = smod.pmod_loc }
+      | Mty_alias path ->
+          raise(Error(sfunct.pmod_loc, env, Cannot_scrape_alias path))
+      | _ ->
+          raise(Error(sfunct.pmod_loc, env, Cannot_apply funct.mod_type))
+      end
+  | Pmod_constraint(sarg, smty) ->
+      let arg = type_module ~alias true funct_body anchor env sarg in
+      let mty = transl_modtype env smty in
+      let md =
+        wrap_constraint env true arg mty.mty_type (Tmodtype_explicit mty)
+      in
+      { md with
+        mod_loc = smod.pmod_loc;
+        mod_attributes = smod.pmod_attributes;
+      }
+
+  | Pmod_unpack sexp ->
+      if !Clflags.principal then Ctype.begin_def ();
+      let exp = Typecore.type_exp env sexp in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        Ctype.generalize_structure exp.exp_type
+      end;
+      let mty =
+        match Ctype.expand_head env exp.exp_type with
+          {desc = Tpackage (p, nl, tl)} ->
+            if List.exists (fun t -> Ctype.free_variables t <> []) tl then
+              raise (Error (smod.pmod_loc, env,
+                            Incomplete_packed_module exp.exp_type));
+            if !Clflags.principal &&
+              not (Typecore.generalizable (Btype.generic_level-1) exp.exp_type)
+            then
+              Location.prerr_warning smod.pmod_loc
+                (Warnings.Not_principal "this module unpacking");
+            modtype_of_package env smod.pmod_loc p nl tl
+        | {desc = Tvar _} ->
+            raise (Typecore.Error
+                     (smod.pmod_loc, env, Typecore.Cannot_infer_signature))
+        | _ ->
+            raise (Error(smod.pmod_loc, env, Not_a_packed_module exp.exp_type))
+      in
+      if funct_body && Mtype.contains_type env mty then
+        raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
+      { mod_desc = Tmod_unpack(exp, mty);
+        mod_type = mty;
+        mod_env = env;
+        mod_attributes = smod.pmod_attributes;
+        mod_loc = smod.pmod_loc }
+  | Pmod_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and type_open_decl ?used_slot ?toplevel funct_body names env sod =
+  Builtin_attributes.warning_scope sod.popen_attributes
+    (fun () ->
+       type_open_decl_aux ?used_slot ?toplevel funct_body names env sod
+    )
+
+and type_open_decl_aux ?used_slot ?toplevel funct_body names env od =
+  let loc = od.popen_loc in
+  match od.popen_expr.pmod_desc with
+  | Pmod_ident lid ->
+    let path, newenv =
+      type_open_ ?used_slot ?toplevel od.popen_override env loc lid
+    in
+    let md = { mod_desc = Tmod_ident (path, lid);
+               mod_type = Mty_alias path;
+               mod_env = env;
+               mod_attributes = od.popen_expr.pmod_attributes;
+               mod_loc = od.popen_expr.pmod_loc }
+    in
+    let open_descr = {
+      open_expr = md;
+      open_bound_items = [];
+      open_override = od.popen_override;
+      open_env = newenv;
+      open_loc = loc;
+      open_attributes = od.popen_attributes
+    } in
+    open_descr, [], newenv
+  | _ ->
+    let md = type_module true funct_body None env od.popen_expr in
+    let scope = Ctype.create_scope () in
+    let sg, newenv =
+      Env.enter_signature ~scope (extract_sig_open env md.mod_loc md.mod_type)
+        env
+    in
+    let info, visibility =
+      match toplevel with
+      | Some false | None -> Some `From_open, Hidden
+      | Some true -> None, Exported
+    in
+    List.iter (Signature_names.check_sig_item ?info names loc) sg;
+    let sg =
+      List.map (function
+        | Sig_value(id, vd, _) -> Sig_value(id, vd, visibility)
+        | Sig_type(id, td, rs, _) -> Sig_type(id, td, rs, visibility)
+        | Sig_typext(id, ec, et, _) -> Sig_typext(id, ec, et, visibility)
+        | Sig_module(id, mp, md, rs, _) ->
+            Sig_module(id, mp, md, rs, visibility)
+        | Sig_modtype(id, mtd, _) -> Sig_modtype(id, mtd, visibility)
+        | Sig_class(id, cd, rs, _) -> Sig_class(id, cd, rs, visibility)
+        | Sig_class_type(id, ctd, rs, _) ->
+            Sig_class_type(id, ctd, rs, visibility)
+      ) sg
+    in
+    let open_descr = {
+      open_expr = md;
+      open_bound_items = sg;
+      open_override = od.popen_override;
+      open_env = newenv;
+      open_loc = loc;
+      open_attributes = od.popen_attributes
+    } in
+    open_descr, sg, newenv
+
+and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
+  let names = Signature_names.create () in
+
+  let type_str_item env srem {pstr_loc = loc; pstr_desc = desc} =
+    match desc with
+    | Pstr_eval (sexpr, attrs) ->
+        let expr =
+          Builtin_attributes.warning_scope attrs
+            (fun () -> Typecore.type_expression env sexpr)
+        in
+        Tstr_eval (expr, attrs), [], env
+    | Pstr_value(rec_flag, sdefs) ->
+        let scope =
+          match rec_flag with
+          | Recursive ->
+              Some (Annot.Idef {scope with
+                                Location.loc_start = loc.Location.loc_start})
+          | Nonrecursive ->
+              let start =
+                match srem with
+                | [] -> loc.Location.loc_end
+                | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start
+              in
+              Some (Annot.Idef {scope with Location.loc_start = start})
+        in
+        let (defs, newenv) =
+          Typecore.type_binding env rec_flag sdefs scope in
+        let () = if rec_flag = Recursive then
+          Typecore.check_recursive_bindings env defs
+        in
+        (* Note: Env.find_value does not trigger the value_used event. Values
+           will be marked as being used during the signature inclusion test. *)
+        Tstr_value(rec_flag, defs),
+        List.map (fun (id, { Asttypes.loc; _ }, _typ)->
+          Signature_names.check_value names loc id;
+          Sig_value(id, Env.find_value (Pident id) newenv, Exported)
+        ) (let_bound_idents_full defs),
+        newenv
+    | Pstr_primitive sdesc ->
+        let (desc, newenv) = Typedecl.transl_value_decl env loc sdesc in
+        Signature_names.check_value names desc.val_loc desc.val_id;
+        Tstr_primitive desc,
+        [Sig_value(desc.val_id, desc.val_val, Exported)],
+        newenv
+    | Pstr_type (rec_flag, sdecls) ->
+        let (decls, newenv) = Typedecl.transl_type_decl env rec_flag sdecls in
+        List.iter
+          Signature_names.(fun td -> check_type names td.typ_loc td.typ_id)
+          decls;
+        Tstr_type (rec_flag, decls),
+        map_rec_type_with_row_types ~rec_flag
+          (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs, Exported))
+          decls [],
+        enrich_type_decls anchor decls env newenv
+    | Pstr_typext styext ->
+        let (tyext, newenv) =
+          Typedecl.transl_type_extension true env loc styext
+        in
+        let constructors = tyext.tyext_constructors in
+        List.iter
+          Signature_names.(fun ext -> check_typext names ext.ext_loc ext.ext_id)
+          constructors;
+        (Tstr_typext tyext,
+         map_ext
+           (fun es ext -> Sig_typext(ext.ext_id, ext.ext_type, es, Exported))
+           constructors [],
+         newenv)
+    | Pstr_exception sext ->
+        let (ext, newenv) = Typedecl.transl_type_exception env sext in
+        let constructor = ext.tyexn_constructor in
+        Signature_names.check_typext names constructor.ext_loc
+          constructor.ext_id;
+        Tstr_exception ext,
+        [Sig_typext(constructor.ext_id,
+                    constructor.ext_type,
+                    Text_exception,
+                    Exported)],
+        newenv
+    | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs;
+                   pmb_loc;
+                  } ->
+        let outer_scope = Ctype.get_current_level () in
+        let scope = Ctype.create_scope () in
+        let modl =
+          Builtin_attributes.warning_scope attrs
+            (fun () ->
+               type_module ~alias:true true funct_body
+                 (anchor_submodule name.txt anchor) env smodl
+            )
+        in
+        let pres =
+          match modl.mod_type with
+          | Mty_alias _ -> Mp_absent
+          | _ -> Mp_present
+        in
+        let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in
+        let md =
+          { md_type = enrich_module_type anchor name.txt modl.mod_type env;
+            md_attributes = attrs;
+            md_loc = pmb_loc;
+            md_uid;
+          }
+        in
+        (*prerr_endline (Ident.unique_toplevel_name id);*)
+        Mtype.lower_nongen outer_scope md.md_type;
+        let id, newenv, sg =
+          match name.txt with
+          | None -> None, env, []
+          | Some name ->
+            let id, e = Env.enter_module_declaration ~scope name pres md env in
+            Signature_names.check_module names pmb_loc id;
+            Some id, e,
+            [Sig_module(id, pres,
+                        {md_type = modl.mod_type;
+                         md_attributes = attrs;
+                         md_loc = pmb_loc;
+                         md_uid;
+                        }, Trec_not, Exported)]
+        in
+        Tstr_module {mb_id=id; mb_name=name; mb_expr=modl;
+                     mb_presence=pres; mb_attributes=attrs;  mb_loc=pmb_loc; },
+        sg,
+        newenv
+    | Pstr_recmodule sbind ->
+        let sbind =
+          List.map
+            (function
+              | {pmb_name = name;
+                 pmb_expr = {pmod_desc=Pmod_constraint(expr, typ)};
+                 pmb_attributes = attrs;
+                 pmb_loc = loc;
+                } ->
+                  name, typ, expr, attrs, loc
+              | mb ->
+                  raise (Error (mb.pmb_expr.pmod_loc, env,
+                                Recursive_module_require_explicit_type))
+            )
+            sbind
+        in
+        let (decls, newenv) =
+          transl_recmodule_modtypes env
+            (List.map (fun (name, smty, _smodl, attrs, loc) ->
+                 {pmd_name=name; pmd_type=smty;
+                  pmd_attributes=attrs; pmd_loc=loc}) sbind
+            ) in
+        List.iter
+          (fun (md, _) ->
+            Option.iter Signature_names.(check_module names md.md_loc) md.md_id)
+          decls;
+        let bindings1 =
+          List.map2
+            (fun ({md_id=id; md_type=mty}, uid) (name, _, smodl, attrs, loc) ->
+               let modl =
+                 Builtin_attributes.warning_scope attrs
+                   (fun () ->
+                      type_module true funct_body (anchor_recmodule id)
+                        newenv smodl
+                   )
+               in
+               let mty' =
+                 enrich_module_type anchor name.txt modl.mod_type newenv
+               in
+               (id, name, mty, modl, mty', attrs, loc, uid))
+            decls sbind in
+        let newenv = (* allow aliasing recursive modules from outside *)
+          List.fold_left
+            (fun env (md, uid) ->
+               match md.md_id with
+               | None -> env
+               | Some id ->
+                   let mdecl =
+                     {
+                       md_type = md.md_type.mty_type;
+                       md_attributes = md.md_attributes;
+                       md_loc = md.md_loc;
+                       md_uid = uid;
+                     }
+                   in
+                   Env.add_module_declaration ~check:true
+                     id Mp_present mdecl env
+            )
+            env decls
+        in
+        let bindings2 =
+          check_recmodule_inclusion newenv bindings1 in
+        let mbs =
+          List.filter_map (fun (mb, uid) ->
+            Option.map (fun id -> id, mb, uid)  mb.mb_id
+          ) bindings2
+        in
+        Tstr_recmodule (List.map fst bindings2),
+        map_rec (fun rs (id, mb, uid) ->
+            Sig_module(id, Mp_present, {
+                md_type=mb.mb_expr.mod_type;
+                md_attributes=mb.mb_attributes;
+                md_loc=mb.mb_loc;
+                md_uid = uid;
+              }, rs, Exported))
+           mbs [],
+        newenv
+    | Pstr_modtype pmtd ->
+        (* check that it is non-abstract *)
+        let newenv, mtd, sg = transl_modtype_decl names env pmtd in
+        Tstr_modtype mtd, [sg], newenv
+    | Pstr_open sod ->
+        let (od, sg, newenv) =
+          type_open_decl ~toplevel funct_body names env sod
+        in
+        Tstr_open od, sg, newenv
+    | Pstr_class cl ->
+        let (classes, new_env) = Typeclass.class_declarations env cl in
+        List.iter (fun cls ->
+          let open Typeclass in
+          let loc = cls.cls_id_loc.Location.loc in
+          Signature_names.check_class names loc cls.cls_id;
+          Signature_names.check_class_type names loc cls.cls_ty_id;
+          Signature_names.check_type names loc cls.cls_obj_id;
+          Signature_names.check_type names loc cls.cls_typesharp_id;
+        ) classes;
+        Tstr_class
+          (List.map (fun cls ->
+               (cls.Typeclass.cls_info,
+                cls.Typeclass.cls_pub_methods)) classes),
+(* TODO: check with Jacques why this is here
+      Tstr_class_type
+          (List.map (fun (_,_, i, d, _,_,_,_,_,_,c) -> (i, c)) classes) ::
+      Tstr_type
+          (List.map (fun (_,_,_,_, i, d, _,_,_,_,_) -> (i, d)) classes) ::
+      Tstr_type
+          (List.map (fun (_,_,_,_,_,_, i, d, _,_,_) -> (i, d)) classes) ::
+*)
+        List.flatten
+          (map_rec
+            (fun rs cls ->
+              let open Typeclass in
+              [Sig_class(cls.cls_id, cls.cls_decl, rs, Exported);
+               Sig_class_type(cls.cls_ty_id, cls.cls_ty_decl, rs, Exported);
+               Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs, Exported);
+               Sig_type(cls.cls_typesharp_id, cls.cls_abbr, rs, Exported)])
+             classes []),
+        new_env
+    | Pstr_class_type cl ->
+        let (classes, new_env) = Typeclass.class_type_declarations env cl in
+        List.iter (fun decl ->
+          let open Typeclass in
+          let loc = decl.clsty_id_loc.Location.loc in
+          Signature_names.check_class_type names loc decl.clsty_ty_id;
+          Signature_names.check_type names loc decl.clsty_obj_id;
+          Signature_names.check_type names loc decl.clsty_typesharp_id;
+        ) classes;
+        Tstr_class_type
+          (List.map (fun cl ->
+               (cl.Typeclass.clsty_ty_id,
+                cl.Typeclass.clsty_id_loc,
+                cl.Typeclass.clsty_info)) classes),
+(*  TODO: check with Jacques why this is here
+           Tstr_type
+             (List.map (fun (_, _, i, d, _, _) -> (i, d)) classes) ::
+           Tstr_type
+             (List.map (fun (_, _, _, _, i, d) -> (i, d)) classes) :: *)
+        List.flatten
+          (map_rec
+             (fun rs decl ->
+                let open Typeclass in
+                [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs,
+                                Exported);
+                 Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs, Exported);
+                 Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs,
+                          Exported)
+                ])
+             classes []),
+        new_env
+    | Pstr_include sincl ->
+        let smodl = sincl.pincl_mod in
+        let modl =
+          Builtin_attributes.warning_scope sincl.pincl_attributes
+            (fun () -> type_module true funct_body None env smodl)
+        in
+        let scope = Ctype.create_scope () in
+        (* Rename all identifiers bound by this signature to avoid clashes *)
+        let sg, new_env = Env.enter_signature ~scope
+            (extract_sig_open env smodl.pmod_loc modl.mod_type) env in
+        List.iter (Signature_names.check_sig_item names loc) sg;
+        let incl =
+          { incl_mod = modl;
+            incl_type = sg;
+            incl_attributes = sincl.pincl_attributes;
+            incl_loc = sincl.pincl_loc;
+          }
+        in
+        Tstr_include incl, sg, new_env
+    | Pstr_extension (ext, _attrs) ->
+        raise (Error_forward (Builtin_attributes.error_of_extension ext))
+    | Pstr_attribute x ->
+        Builtin_attributes.warning_attribute x;
+        Tstr_attribute x, [], env
+  in
+  let rec type_struct env sstr =
+    match sstr with
+    | [] -> ([], [], env)
+    | pstr :: srem ->
+        let previous_saved_types = Cmt_format.get_saved_types () in
+        let desc, sg, new_env = type_str_item env srem pstr in
+        let str = { str_desc = desc; str_loc = pstr.pstr_loc; str_env = env } in
+        Cmt_format.set_saved_types (Cmt_format.Partial_structure_item str
+                                    :: previous_saved_types);
+        let (str_rem, sig_rem, final_env) = type_struct new_env srem in
+        (str :: str_rem, sg @ sig_rem, final_env)
+  in
+  let previous_saved_types = Cmt_format.get_saved_types () in
+  let run () =
+    let (items, sg, final_env) = type_struct env sstr in
+    let str = { str_items = items; str_type = sg; str_final_env = final_env } in
+    Cmt_format.set_saved_types
+      (Cmt_format.Partial_structure str :: previous_saved_types);
+    str, sg, names, final_env
+  in
+  if toplevel then run ()
+  else Builtin_attributes.warning_scope [] run
+
+let type_toplevel_phrase env s =
+  Env.reset_required_globals ();
+  let (str, sg, to_remove_from_sg, env) =
+    type_structure ~toplevel:true false None env s Location.none in
+  (str, sg, to_remove_from_sg, env)
+
+let type_module_alias = type_module ~alias:true true false None
+let type_module = type_module true false None
+let type_structure = type_structure false None
+
+(* Normalize types in a signature *)
+
+let rec normalize_modtype env = function
+    Mty_ident _
+  | Mty_alias _ -> ()
+  | Mty_signature sg -> normalize_signature env sg
+  | Mty_functor(_param, body) -> normalize_modtype env body
+
+and normalize_signature env = List.iter (normalize_signature_item env)
+
+and normalize_signature_item env = function
+    Sig_value(_id, desc, _) -> Ctype.normalize_type env desc.val_type
+  | Sig_module(_id, _, md, _, _) -> normalize_modtype env md.md_type
+  | _ -> ()
+
+(* Extract the module type of a module expression *)
+
+let type_module_type_of env smod =
+  let remove_aliases = has_remove_aliases_attribute smod.pmod_attributes in
+  let tmty =
+    match smod.pmod_desc with
+    | Pmod_ident lid -> (* turn off strengthening in this case *)
+        let path, md = Env.lookup_module ~loc:smod.pmod_loc lid.txt env in
+          { mod_desc = Tmod_ident (path, lid);
+            mod_type = md.md_type;
+            mod_env = env;
+            mod_attributes = smod.pmod_attributes;
+            mod_loc = smod.pmod_loc }
+    | _ -> type_module env smod
+  in
+  let mty = Mtype.scrape_for_type_of ~remove_aliases env tmty.mod_type in
+  (* PR#5036: must not contain non-generalized type variables *)
+  if not (closed_modtype env mty) then
+    raise(Error(smod.pmod_loc, env, Non_generalizable_module mty));
+  tmty, mty
+
+(* For Typecore *)
+
+(* Graft a longident onto a path *)
+let rec extend_path path =
+  fun lid ->
+    match lid with
+    | Lident name -> Pdot(path, name)
+    | Ldot(m, name) -> Pdot(extend_path path m, name)
+    | Lapply _ -> assert false
+
+(* Lookup a type's longident within a signature *)
+let lookup_type_in_sig sg =
+  let types, modules =
+    List.fold_left
+      (fun acc item ->
+         match item with
+         | Sig_type(id, _, _, _) ->
+             let types, modules = acc in
+             let types = String.Map.add (Ident.name id) id types in
+             types, modules
+         | Sig_module(id, _, _, _, _) ->
+             let types, modules = acc in
+             let modules = String.Map.add (Ident.name id) id modules in
+             types, modules
+         | _ -> acc)
+      (String.Map.empty, String.Map.empty) sg
+  in
+  let rec module_path = function
+    | Lident name -> Pident (String.Map.find name modules)
+    | Ldot(m, name) -> Pdot(module_path m, name)
+    | Lapply _ -> assert false
+  in
+  fun lid ->
+    match lid with
+    | Lident name -> Pident (String.Map.find name types)
+    | Ldot(m, name) -> Pdot(module_path m, name)
+    | Lapply _ -> assert false
+
+let type_package env m p nl =
+  (* Same as Pexp_letmodule *)
+  (* remember original level *)
+  Ctype.begin_def ();
+  let context = Typetexp.narrow () in
+  let modl = type_module env m in
+  let scope = Ctype.create_scope () in
+  Typetexp.widen context;
+  let nl', tl', env =
+    match nl with
+    | [] -> [], [], env
+    | nl ->
+      let type_path, env =
+        match modl.mod_desc with
+        | Tmod_ident (mp,_)
+        | Tmod_constraint
+            ({mod_desc=Tmod_ident (mp,_)}, _, Tmodtype_implicit, _) ->
+          (* We special case these because interactions between
+             strengthening of module types and packages can cause
+             spurious escape errors. See examples from PR#6982 in the
+             testsuite. This can be removed when such issues are
+             fixed. *)
+          extend_path mp, env
+        | _ ->
+          let sg = extract_sig_open env modl.mod_loc modl.mod_type in
+          let sg, env = Env.enter_signature ~scope sg env in
+          lookup_type_in_sig sg, env
+      in
+      let nl', tl' =
+        List.fold_right
+          (fun lid (nl, tl) ->
+             match type_path lid with
+             | exception Not_found -> (nl, tl)
+             | path -> begin
+                 match Env.find_type path env with
+                 | exception Not_found -> (nl, tl)
+                 | decl ->
+                     if decl.type_arity > 0 then begin
+                       (nl, tl)
+                     end else begin
+                       let t = Btype.newgenty (Tconstr (path,[],ref Mnil)) in
+                       (lid :: nl, t :: tl)
+                     end
+               end)
+          nl ([], [])
+      in
+      nl', tl', env
+  in
+  (* go back to original level *)
+  Ctype.end_def ();
+  let mty =
+    if nl = [] then (Mty_ident p)
+    else modtype_of_package env modl.mod_loc p nl' tl'
+  in
+  List.iter2
+    (fun n ty ->
+      try Ctype.unify env ty (Ctype.newvar ())
+      with Ctype.Unify _ ->
+        raise (Error(modl.mod_loc, env, Scoping_pack (n,ty))))
+    nl' tl';
+  let modl = wrap_constraint env true modl mty Tmodtype_implicit in
+  (* Dropped exports should have produced an error above *)
+  assert (List.length nl = List.length tl');
+  modl, tl'
+
+(* Fill in the forward declarations *)
+
+let type_open_decl ?used_slot env od =
+  type_open_decl ?used_slot ?toplevel:None false (Signature_names.create ()) env
+    od
+
+let type_open_descr ?used_slot env od =
+  type_open_descr ?used_slot ?toplevel:None env od
+
+let () =
+  Typecore.type_module := type_module_alias;
+  Typetexp.transl_modtype_longident := transl_modtype_longident;
+  Typetexp.transl_modtype := transl_modtype;
+  Typecore.type_open := type_open_ ?toplevel:None;
+  Typecore.type_open_decl := type_open_decl;
+  Typecore.type_package := type_package;
+  Typeclass.type_open_descr := type_open_descr;
+  type_module_type_of_fwd := type_module_type_of
+
+
+(* Typecheck an implementation file *)
+
+let gen_annot outputprefix sourcefile annots =
+  Cmt2annot.gen_annot (Some (outputprefix ^ ".annot"))
+    ~sourcefile:(Some sourcefile) ~use_summaries:false annots
+
+let type_implementation sourcefile outputprefix modulename initial_env ast =
+  Cmt_format.clear ();
+  Misc.try_finally (fun () ->
+      Typecore.reset_delayed_checks ();
+      Env.reset_required_globals ();
+      if !Clflags.print_types then (* #7656 *)
+        Warnings.parse_options false "-32-34-37-38-60";
+      let (str, sg, names, finalenv) =
+        type_structure initial_env ast (Location.in_file sourcefile) in
+      let simple_sg = Signature_names.simplify finalenv names sg in
+      if !Clflags.print_types then begin
+        Typecore.force_delayed_checks ();
+        Printtyp.wrap_printing_env ~error:false initial_env
+          (fun () -> fprintf std_formatter "%a@."
+              (Printtyp.printed_signature sourcefile) simple_sg
+          );
+        gen_annot outputprefix sourcefile (Cmt_format.Implementation str);
+        (str, Tcoerce_none)   (* result is ignored by Compile.implementation *)
+      end else begin
+        let sourceintf =
+          Filename.remove_extension sourcefile ^ !Config.interface_suffix in
+        if Sys.file_exists sourceintf then begin
+          let intf_file =
+            try
+              Load_path.find_uncap (modulename ^ ".cmi")
+            with Not_found ->
+              raise(Error(Location.in_file sourcefile, Env.empty,
+                          Interface_not_compiled sourceintf)) in
+          let dclsig = Env.read_signature modulename intf_file in
+          let coercion =
+            Includemod.compunit initial_env ~mark:Mark_positive
+              sourcefile sg intf_file dclsig
+          in
+          Typecore.force_delayed_checks ();
+          (* It is important to run these checks after the inclusion test above,
+             so that value declarations which are not used internally but
+             exported are not reported as being unused. *)
+          let annots = Cmt_format.Implementation str in
+          Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename
+            annots (Some sourcefile) initial_env None;
+          gen_annot outputprefix sourcefile annots;
+          (str, coercion)
+        end else begin
+          let coercion =
+            Includemod.compunit initial_env ~mark:Mark_positive
+              sourcefile sg "(inferred signature)" simple_sg
+          in
+          check_nongen_schemes finalenv simple_sg;
+          normalize_signature finalenv simple_sg;
+          Typecore.force_delayed_checks ();
+          (* See comment above. Here the target signature contains all
+             the value being exported. We can still capture unused
+             declarations like "let x = true;; let x = 1;;", because in this
+             case, the inferred signature contains only the last declaration. *)
+          if not !Clflags.dont_write_files then begin
+            let alerts = Builtin_attributes.alerts_of_str ast in
+            let cmi =
+              Env.save_signature ~alerts
+                simple_sg modulename (outputprefix ^ ".cmi")
+            in
+            let annots = Cmt_format.Implementation str in
+            Cmt_format.save_cmt  (outputprefix ^ ".cmt") modulename
+              annots (Some sourcefile) initial_env (Some cmi);
+            gen_annot outputprefix sourcefile annots
+          end;
+          (str, coercion)
+        end
+      end
+    )
+    ~exceptionally:(fun () ->
+        let annots =
+          Cmt_format.Partial_implementation
+            (Array.of_list (Cmt_format.get_saved_types ()))
+        in
+        Cmt_format.save_cmt  (outputprefix ^ ".cmt") modulename
+          annots (Some sourcefile) initial_env None;
+        gen_annot outputprefix sourcefile annots
+      )
+
+let save_signature modname tsg outputprefix source_file initial_env cmi =
+  Cmt_format.save_cmt  (outputprefix ^ ".cmti") modname
+    (Cmt_format.Interface tsg) (Some source_file) initial_env (Some cmi)
+
+let type_interface env ast =
+  transl_signature env ast
+
+(* "Packaging" of several compilation units into one unit
+   having them as sub-modules.  *)
+
+let package_signatures units =
+  let units_with_ids =
+    List.map
+      (fun (name, sg) ->
+        let oldid = Ident.create_persistent name in
+        let newid = Ident.create_local name in
+        (oldid, newid, sg))
+      units
+  in
+  let subst =
+    List.fold_left
+      (fun acc (oldid, newid, _) ->
+        Subst.add_module oldid (Pident newid) acc)
+      Subst.identity units_with_ids
+  in
+  List.map
+    (fun (_, newid, sg) ->
+      (* This signature won't be used for anything, it'll just be saved in a cmi
+         and cmt. *)
+      let sg = Subst.signature Make_local subst sg in
+      let md =
+        { md_type=Mty_signature sg;
+          md_attributes=[];
+          md_loc=Location.none;
+          md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+        }
+      in
+      Sig_module(newid, Mp_present, md, Trec_not, Exported))
+    units_with_ids
+
+let package_units initial_env objfiles cmifile modulename =
+  (* Read the signatures of the units *)
+  let units =
+    List.map
+      (fun f ->
+         let pref = chop_extensions f in
+         let modname = String.capitalize_ascii(Filename.basename pref) in
+         let sg = Env.read_signature modname (pref ^ ".cmi") in
+         if Filename.check_suffix f ".cmi" &&
+            not(Mtype.no_code_needed_sig Env.initial_safe_string sg)
+         then raise(Error(Location.none, Env.empty,
+                          Implementation_is_required f));
+         (modname, Env.read_signature modname (pref ^ ".cmi")))
+      objfiles in
+  (* Compute signature of packaged unit *)
+  Ident.reinit();
+  let sg = package_signatures units in
+  (* See if explicit interface is provided *)
+  let prefix = Filename.remove_extension cmifile in
+  let mlifile = prefix ^ !Config.interface_suffix in
+  if Sys.file_exists mlifile then begin
+    if not (Sys.file_exists cmifile) then begin
+      raise(Error(Location.in_file mlifile, Env.empty,
+                  Interface_not_compiled mlifile))
+    end;
+    let dclsig = Env.read_signature modulename cmifile in
+    Cmt_format.save_cmt  (prefix ^ ".cmt") modulename
+      (Cmt_format.Packed (sg, objfiles)) None initial_env  None ;
+    Includemod.compunit initial_env ~mark:Mark_both
+      "(obtained by packing)" sg mlifile dclsig
+  end else begin
+    (* Determine imports *)
+    let unit_names = List.map fst units in
+    let imports =
+      List.filter
+        (fun (name, _crc) -> not (List.mem name unit_names))
+        (Env.imports()) in
+    (* Write packaged signature *)
+    if not !Clflags.dont_write_files then begin
+      let cmi =
+        Env.save_signature_with_imports ~alerts:Misc.Stdlib.String.Map.empty
+          sg modulename
+          (prefix ^ ".cmi") imports
+      in
+      Cmt_format.save_cmt (prefix ^ ".cmt")  modulename
+        (Cmt_format.Packed (cmi.Cmi_format.cmi_sign, objfiles)) None initial_env
+        (Some cmi)
+    end;
+    Tcoerce_none
+  end
+
+(* Error report *)
+
+open Printtyp
+
+let report_error ppf = function
+    Cannot_apply mty ->
+      fprintf ppf
+        "@[This module is not a functor; it has type@ %a@]" modtype mty
+  | Not_included errs ->
+      fprintf ppf
+        "@[<v>Signature mismatch:@ %a@]" Includemod.report_error errs
+  | Cannot_eliminate_dependency mty ->
+      fprintf ppf
+        "@[This functor has type@ %a@ \
+           The parameter cannot be eliminated in the result type.@ \
+           Please bind the argument to a module identifier.@]" modtype mty
+  | Signature_expected -> fprintf ppf "This module type is not a signature"
+  | Structure_expected mty ->
+      fprintf ppf
+        "@[This module is not a structure; it has type@ %a" modtype mty
+  | With_no_component lid ->
+      fprintf ppf
+        "@[The signature constrained by `with' has no component named %a@]"
+        longident lid
+  | With_mismatch(lid, explanation) ->
+      fprintf ppf
+        "@[<v>\
+           @[In this `with' constraint, the new definition of %a@ \
+             does not match its original definition@ \
+             in the constrained signature:@]@ \
+           %a@]"
+        longident lid Includemod.report_error explanation
+  | With_makes_applicative_functor_ill_typed(lid, path, explanation) ->
+      fprintf ppf
+        "@[<v>\
+           @[This `with' constraint on %a makes the applicative functor @ \
+             type %s ill-typed in the constrained signature:@]@ \
+           %a@]"
+        longident lid (Path.name path) Includemod.report_error explanation
+  | With_changes_module_alias(lid, id, path) ->
+      fprintf ppf
+        "@[<v>\
+           @[This `with' constraint on %a changes %s, which is aliased @ \
+             in the constrained signature (as %s)@].@]"
+        longident lid (Path.name path) (Ident.name id)
+  | With_cannot_remove_constrained_type ->
+      fprintf ppf
+        "@[<v>Destructive substitutions are not supported for constrained @ \
+              types (other than when replacing a type constructor with @ \
+              a type constructor with the same arguments).@]"
+  | Repeated_name(kind, name) ->
+      fprintf ppf
+        "@[Multiple definition of the %s name %s.@ \
+         Names must be unique in a given structure or signature.@]"
+        (Sig_component_kind.to_string kind) name
+  | Non_generalizable typ ->
+      fprintf ppf
+        "@[The type of this expression,@ %a,@ \
+           contains type variables that cannot be generalized@]" type_scheme typ
+  | Non_generalizable_class (id, desc) ->
+      fprintf ppf
+        "@[The type of this class,@ %a,@ \
+           contains type variables that cannot be generalized@]"
+        (class_declaration id) desc
+  | Non_generalizable_module mty ->
+      fprintf ppf
+        "@[The type of this module,@ %a,@ \
+           contains type variables that cannot be generalized@]" modtype mty
+  | Implementation_is_required intf_name ->
+      fprintf ppf
+        "@[The interface %a@ declares values, not just types.@ \
+           An implementation must be provided.@]"
+        Location.print_filename intf_name
+  | Interface_not_compiled intf_name ->
+      fprintf ppf
+        "@[Could not find the .cmi file for interface@ %a.@]"
+        Location.print_filename intf_name
+  | Not_allowed_in_functor_body ->
+      fprintf ppf
+        "@[This expression creates fresh types.@ %s@]"
+        "It is not allowed inside applicative functors."
+  | Not_a_packed_module ty ->
+      fprintf ppf
+        "This expression is not a packed module. It has type@ %a"
+        type_expr ty
+  | Incomplete_packed_module ty ->
+      fprintf ppf
+        "The type of this packed module contains variables:@ %a"
+        type_expr ty
+  | Scoping_pack (lid, ty) ->
+      fprintf ppf
+        "The type %a in this module cannot be exported.@ " longident lid;
+      fprintf ppf
+        "Its type contains local dependencies:@ %a" type_expr ty
+  | Recursive_module_require_explicit_type ->
+      fprintf ppf "Recursive modules require an explicit module type."
+  | Apply_generative ->
+      fprintf ppf "This is a generative functor. It can only be applied to ()"
+  | Cannot_scrape_alias p ->
+      fprintf ppf
+        "This is an alias for module %a, which is missing"
+        path p
+  | Badly_formed_signature (context, err) ->
+      fprintf ppf "@[In %s:@ %a@]" context Typedecl.report_error err
+  | Cannot_hide_id Illegal_shadowing
+      { shadowed_item_kind; shadowed_item_id; shadowed_item_loc;
+        shadower_id; user_id; user_kind; user_loc } ->
+      let shadowed_item_kind= Sig_component_kind.to_string shadowed_item_kind in
+      fprintf ppf
+        "@[<v>Illegal shadowing of included %s %a by %a@ \
+         %a:@;<1 2>%s %a came from this include@ \
+         %a:@;<1 2>The %s %s has no valid type if %a is shadowed@]"
+        shadowed_item_kind Ident.print shadowed_item_id Ident.print shadower_id
+        Location.print_loc shadowed_item_loc
+        (String.capitalize_ascii shadowed_item_kind)
+        Ident.print shadowed_item_id
+        Location.print_loc user_loc
+        (Sig_component_kind.to_string user_kind) (Ident.name user_id)
+        Ident.print shadowed_item_id
+  | Cannot_hide_id Appears_in_signature
+      { opened_item_kind; opened_item_id; user_id; user_kind; user_loc } ->
+      let opened_item_kind= Sig_component_kind.to_string opened_item_kind in
+      fprintf ppf
+        "@[<v>The %s %a introduced by this open appears in the signature@ \
+         %a:@;<1 2>The %s %s has no valid type if %a is hidden@]"
+        opened_item_kind Ident.print opened_item_id
+        Location.print_loc user_loc
+        (Sig_component_kind.to_string user_kind) (Ident.name user_id)
+        Ident.print opened_item_id
+  | Invalid_type_subst_rhs ->
+      fprintf ppf "Only type synonyms are allowed on the right of :="
+
+let report_error env ppf err =
+  Printtyp.wrap_printing_env ~error:true env (fun () -> report_error ppf err)
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, env, err) ->
+        Some (Location.error_of_printer ~loc (report_error env) err)
+      | Error_forward err ->
+        Some err
+      | _ ->
+        None
+    )
diff --git a/upstream/ocaml_411/typing/typemod.mli b/upstream/ocaml_411/typing/typemod.mli
new file mode 100644
index 0000000..f74a57d
--- /dev/null
+++ b/upstream/ocaml_411/typing/typemod.mli
@@ -0,0 +1,137 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Type-checking of the module language and typed ast hooks
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Types
+open Format
+
+module Signature_names : sig
+  type t
+
+  val simplify: Env.t -> t -> signature -> signature
+end
+
+val type_module:
+        Env.t -> Parsetree.module_expr -> Typedtree.module_expr
+val type_structure:
+  Env.t -> Parsetree.structure -> Location.t ->
+  Typedtree.structure * Types.signature * Signature_names.t * Env.t
+val type_toplevel_phrase:
+  Env.t -> Parsetree.structure ->
+  Typedtree.structure * Types.signature * Signature_names.t * Env.t
+val type_implementation:
+  string -> string -> string -> Env.t -> Parsetree.structure ->
+  Typedtree.structure * Typedtree.module_coercion
+val type_interface:
+        Env.t -> Parsetree.signature -> Typedtree.signature
+val transl_signature:
+        Env.t -> Parsetree.signature -> Typedtree.signature
+val check_nongen_schemes:
+        Env.t -> Types.signature -> unit
+        (*
+val type_open_:
+        ?used_slot:bool ref -> ?toplevel:bool ->
+        Asttypes.override_flag ->
+        Env.t -> Location.t -> Longident.t Asttypes.loc -> Path.t * Env.t
+        *)
+val modtype_of_package:
+        Env.t -> Location.t ->
+        Path.t -> Longident.t list -> type_expr list -> module_type
+
+val path_of_module : Typedtree.module_expr -> Path.t option
+
+val save_signature:
+  string -> Typedtree.signature -> string -> string ->
+  Env.t -> Cmi_format.cmi_infos -> unit
+
+val package_units:
+  Env.t -> string list -> string -> string -> Typedtree.module_coercion
+
+(* Should be in Envaux, but it breaks the build of the debugger *)
+val initial_env:
+  loc:Location.t -> safe_string:bool ->
+  initially_opened_module:string option ->
+  open_implicit_modules:string list -> Env.t
+
+module Sig_component_kind : sig
+  type t =
+    | Value
+    | Type
+    | Module
+    | Module_type
+    | Extension_constructor
+    | Class
+    | Class_type
+
+  val to_string : t -> string
+end
+
+type hiding_error =
+  | Illegal_shadowing of {
+      shadowed_item_id: Ident.t;
+      shadowed_item_kind: Sig_component_kind.t;
+      shadowed_item_loc: Location.t;
+      shadower_id: Ident.t;
+      user_id: Ident.t;
+      user_kind: Sig_component_kind.t;
+      user_loc: Location.t;
+    }
+  | Appears_in_signature of {
+      opened_item_id: Ident.t;
+      opened_item_kind: Sig_component_kind.t;
+      user_id: Ident.t;
+      user_kind: Sig_component_kind.t;
+      user_loc: Location.t;
+    }
+
+type error =
+    Cannot_apply of module_type
+  | Not_included of Includemod.error list
+  | Cannot_eliminate_dependency of module_type
+  | Signature_expected
+  | Structure_expected of module_type
+  | With_no_component of Longident.t
+  | With_mismatch of Longident.t * Includemod.error list
+  | With_makes_applicative_functor_ill_typed of
+      Longident.t * Path.t * Includemod.error list
+  | With_changes_module_alias of Longident.t * Ident.t * Path.t
+  | With_cannot_remove_constrained_type
+  | Repeated_name of Sig_component_kind.t * string
+  | Non_generalizable of type_expr
+  | Non_generalizable_class of Ident.t * class_declaration
+  | Non_generalizable_module of module_type
+  | Implementation_is_required of string
+  | Interface_not_compiled of string
+  | Not_allowed_in_functor_body
+  | Not_a_packed_module of type_expr
+  | Incomplete_packed_module of type_expr
+  | Scoping_pack of Longident.t * type_expr
+  | Recursive_module_require_explicit_type
+  | Apply_generative
+  | Cannot_scrape_alias of Path.t
+  | Badly_formed_signature of string * Typedecl.error
+  | Cannot_hide_id of hiding_error
+  | Invalid_type_subst_rhs
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+val report_error: Env.t -> formatter -> error -> unit
diff --git a/upstream/ocaml_411/typing/typeopt.ml b/upstream/ocaml_411/typing/typeopt.ml
new file mode 100644
index 0000000..8ca209a
--- /dev/null
+++ b/upstream/ocaml_411/typing/typeopt.ml
@@ -0,0 +1,215 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Auxiliaries for type-based optimizations, e.g. array kinds *)
+
+open Path
+open Types
+open Asttypes
+open Typedtree
+open Lambda
+
+let scrape_ty env ty =
+  let ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in
+  match ty.desc with
+  | Tconstr (p, _, _) ->
+      begin match Env.find_type p env with
+      | {type_unboxed = {unboxed = true; _}; _} ->
+        begin match Typedecl.get_unboxed_type_representation env ty with
+        | None -> ty
+        | Some ty2 -> ty2
+        end
+      | _ -> ty
+      | exception Not_found -> ty
+      end
+  | _ -> ty
+
+let scrape env ty =
+  (scrape_ty env ty).desc
+
+let is_function_type env ty =
+  match scrape env ty with
+  | Tarrow (_, lhs, rhs, _) -> Some (lhs, rhs)
+  | _ -> None
+
+let is_base_type env ty base_ty_path =
+  match scrape env ty with
+  | Tconstr(p, _, _) -> Path.same p base_ty_path
+  | _ -> false
+
+let maybe_pointer_type env ty =
+  let ty = scrape_ty env ty in
+  if Ctype.maybe_pointer_type env ty then
+    Pointer
+  else
+    Immediate
+
+let maybe_pointer exp = maybe_pointer_type exp.exp_env exp.exp_type
+
+type classification =
+  | Int
+  | Float
+  | Lazy
+  | Addr  (* anything except a float or a lazy *)
+  | Any
+
+let classify env ty =
+  let ty = scrape_ty env ty in
+  if maybe_pointer_type env ty = Immediate then Int
+  else match ty.desc with
+  | Tvar _ | Tunivar _ ->
+      Any
+  | Tconstr (p, _args, _abbrev) ->
+      if Path.same p Predef.path_float then Float
+      else if Path.same p Predef.path_lazy_t then Lazy
+      else if Path.same p Predef.path_string
+           || Path.same p Predef.path_bytes
+           || Path.same p Predef.path_array
+           || Path.same p Predef.path_nativeint
+           || Path.same p Predef.path_int32
+           || Path.same p Predef.path_int64 then Addr
+      else begin
+        try
+          match (Env.find_type p env).type_kind with
+          | Type_abstract ->
+              Any
+          | Type_record _ | Type_variant _ | Type_open ->
+              Addr
+        with Not_found ->
+          (* This can happen due to e.g. missing -I options,
+             causing some .cmi files to be unavailable.
+             Maybe we should emit a warning. *)
+          Any
+      end
+  | Tarrow _ | Ttuple _ | Tpackage _ | Tobject _ | Tnil | Tvariant _ ->
+      Addr
+  | Tlink _ | Tsubst _ | Tpoly _ | Tfield _ ->
+      assert false
+
+let array_type_kind env ty =
+  match scrape env ty with
+  | Tconstr(p, [elt_ty], _) | Tpoly({desc = Tconstr(p, [elt_ty], _)}, _)
+    when Path.same p Predef.path_array ->
+      begin match classify env elt_ty with
+      | Any -> if Config.flat_float_array then Pgenarray else Paddrarray
+      | Float -> if Config.flat_float_array then Pfloatarray else Paddrarray
+      | Addr | Lazy -> Paddrarray
+      | Int -> Pintarray
+      end
+  | Tconstr(p, [], _) | Tpoly({desc = Tconstr(p, [], _)}, _)
+    when Path.same p Predef.path_floatarray ->
+      Pfloatarray
+  | _ ->
+      (* This can happen with e.g. Obj.field *)
+      Pgenarray
+
+let array_kind exp = array_type_kind exp.exp_env exp.exp_type
+
+let array_pattern_kind pat = array_type_kind pat.pat_env pat.pat_type
+
+let bigarray_decode_type env ty tbl dfl =
+  match scrape env ty with
+  | Tconstr(Pdot(Pident mod_id, type_name), [], _)
+    when Ident.name mod_id = "Stdlib__bigarray" ->
+      begin try List.assoc type_name tbl with Not_found -> dfl end
+  | _ ->
+      dfl
+
+let kind_table =
+  ["float32_elt", Pbigarray_float32;
+   "float64_elt", Pbigarray_float64;
+   "int8_signed_elt", Pbigarray_sint8;
+   "int8_unsigned_elt", Pbigarray_uint8;
+   "int16_signed_elt", Pbigarray_sint16;
+   "int16_unsigned_elt", Pbigarray_uint16;
+   "int32_elt", Pbigarray_int32;
+   "int64_elt", Pbigarray_int64;
+   "int_elt", Pbigarray_caml_int;
+   "nativeint_elt", Pbigarray_native_int;
+   "complex32_elt", Pbigarray_complex32;
+   "complex64_elt", Pbigarray_complex64]
+
+let layout_table =
+  ["c_layout", Pbigarray_c_layout;
+   "fortran_layout", Pbigarray_fortran_layout]
+
+let bigarray_type_kind_and_layout env typ =
+  match scrape env typ with
+  | Tconstr(_p, [_caml_type; elt_type; layout_type], _abbrev) ->
+      (bigarray_decode_type env elt_type kind_table Pbigarray_unknown,
+       bigarray_decode_type env layout_type layout_table
+                            Pbigarray_unknown_layout)
+  | _ ->
+      (Pbigarray_unknown, Pbigarray_unknown_layout)
+
+let value_kind env ty =
+  match scrape env ty with
+  | Tconstr(p, _, _) when Path.same p Predef.path_int ->
+      Pintval
+  | Tconstr(p, _, _) when Path.same p Predef.path_char ->
+      Pintval
+  | Tconstr(p, _, _) when Path.same p Predef.path_float ->
+      Pfloatval
+  | Tconstr(p, _, _) when Path.same p Predef.path_int32 ->
+      Pboxedintval Pint32
+  | Tconstr(p, _, _) when Path.same p Predef.path_int64 ->
+      Pboxedintval Pint64
+  | Tconstr(p, _, _) when Path.same p Predef.path_nativeint ->
+      Pboxedintval Pnativeint
+  | _ ->
+      Pgenval
+
+let function_return_value_kind env ty =
+  match is_function_type env ty with
+  | Some (_lhs, rhs) -> value_kind env rhs
+  | None -> Pgenval
+
+(** Whether a forward block is needed for a lazy thunk on a value, i.e.
+    if the value can be represented as a float/forward/lazy *)
+let lazy_val_requires_forward env ty =
+  match classify env ty with
+  | Any | Lazy -> true
+  | Float -> Config.flat_float_array
+  | Addr | Int -> false
+
+(** The compilation of the expression [lazy e] depends on the form of e:
+    constants, floats and identifiers are optimized.  The optimization must be
+    taken into account when determining whether a recursive binding is safe. *)
+let classify_lazy_argument : Typedtree.expression ->
+                             [`Constant_or_function
+                             |`Float_that_cannot_be_shortcut
+                             |`Identifier of [`Forward_value|`Other]
+                             |`Other] =
+  fun e -> match e.exp_desc with
+    | Texp_constant
+        ( Const_int _ | Const_char _ | Const_string _
+        | Const_int32 _ | Const_int64 _ | Const_nativeint _ )
+    | Texp_function _
+    | Texp_construct (_, {cstr_arity = 0}, _) ->
+       `Constant_or_function
+    | Texp_constant(Const_float _) ->
+       if Config.flat_float_array
+       then `Float_that_cannot_be_shortcut
+       else `Constant_or_function
+    | Texp_ident _ when lazy_val_requires_forward e.exp_env e.exp_type ->
+       `Identifier `Forward_value
+    | Texp_ident _ ->
+       `Identifier `Other
+    | _ ->
+       `Other
+
+let value_kind_union k1 k2 =
+  if k1 = k2 then k1
+  else Pgenval
diff --git a/upstream/ocaml_411/typing/typeopt.mli b/upstream/ocaml_411/typing/typeopt.mli
new file mode 100644
index 0000000..0f6b9f3
--- /dev/null
+++ b/upstream/ocaml_411/typing/typeopt.mli
@@ -0,0 +1,43 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Auxiliaries for type-based optimizations, e.g. array kinds *)
+
+val is_function_type :
+      Env.t -> Types.type_expr -> (Types.type_expr * Types.type_expr) option
+val is_base_type : Env.t -> Types.type_expr -> Path.t -> bool
+
+val maybe_pointer_type : Env.t -> Types.type_expr
+  -> Lambda.immediate_or_pointer
+val maybe_pointer : Typedtree.expression -> Lambda.immediate_or_pointer
+
+val array_type_kind : Env.t -> Types.type_expr -> Lambda.array_kind
+val array_kind : Typedtree.expression -> Lambda.array_kind
+val array_pattern_kind : Typedtree.pattern -> Lambda.array_kind
+val bigarray_type_kind_and_layout :
+      Env.t -> Types.type_expr -> Lambda.bigarray_kind * Lambda.bigarray_layout
+val value_kind : Env.t -> Types.type_expr -> Lambda.value_kind
+val function_return_value_kind : Env.t -> Types.type_expr -> Lambda.value_kind
+
+val classify_lazy_argument : Typedtree.expression ->
+                             [ `Constant_or_function
+                             | `Float_that_cannot_be_shortcut
+                             | `Identifier of [`Forward_value | `Other]
+                             | `Other]
+
+val value_kind_union :
+      Lambda.value_kind -> Lambda.value_kind -> Lambda.value_kind
+  (** [value_kind_union k1 k2] is a value_kind at least as general as
+      [k1] and [k2] *)
diff --git a/upstream/ocaml_411/typing/types.ml b/upstream/ocaml_411/typing/types.ml
new file mode 100644
index 0000000..f03a4bc
--- /dev/null
+++ b/upstream/ocaml_411/typing/types.ml
@@ -0,0 +1,470 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Representation of types and declarations *)
+
+open Asttypes
+
+(* Type expressions for the core language *)
+
+type type_expr =
+  { mutable desc: type_desc;
+    mutable level: int;
+    mutable scope: int;
+    id: int }
+
+and type_desc =
+    Tvar of string option
+  | Tarrow of arg_label * type_expr * type_expr * commutable
+  | Ttuple of type_expr list
+  | Tconstr of Path.t * type_expr list * abbrev_memo ref
+  | Tobject of type_expr * (Path.t * type_expr list) option ref
+  | Tfield of string * field_kind * type_expr * type_expr
+  | Tnil
+  | Tlink of type_expr
+  | Tsubst of type_expr         (* for copying *)
+  | Tvariant of row_desc
+  | Tunivar of string option
+  | Tpoly of type_expr * type_expr list
+  | Tpackage of Path.t * Longident.t list * type_expr list
+
+and row_desc =
+    { row_fields: (label * row_field) list;
+      row_more: type_expr;
+      row_bound: unit;
+      row_closed: bool;
+      row_fixed: fixed_explanation option;
+      row_name: (Path.t * type_expr list) option }
+and fixed_explanation =
+  | Univar of type_expr | Fixed_private | Reified of Path.t | Rigid
+and row_field =
+    Rpresent of type_expr option
+  | Reither of bool * type_expr list * bool * row_field option ref
+        (* 1st true denotes a constant constructor *)
+        (* 2nd true denotes a tag in a pattern matching, and
+           is erased later *)
+  | Rabsent
+
+and abbrev_memo =
+    Mnil
+  | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo
+  | Mlink of abbrev_memo ref
+
+and field_kind =
+    Fvar of field_kind option ref
+  | Fpresent
+  | Fabsent
+
+and commutable =
+    Cok
+  | Cunknown
+  | Clink of commutable ref
+
+module TypeOps = struct
+  type t = type_expr
+  let compare t1 t2 = t1.id - t2.id
+  let hash t = t.id
+  let equal t1 t2 = t1 == t2
+end
+
+(* *)
+
+module Uid = struct
+  type t =
+    | Compilation_unit of string
+    | Item of { comp_unit: string; id: int }
+    | Internal
+    | Predef of string
+
+  include Identifiable.Make(struct
+    type nonrec t = t
+
+    let equal (x : t) y = x = y
+    let compare (x : t) y = compare x y
+    let hash (x : t) = Hashtbl.hash x
+
+    let print fmt = function
+      | Internal -> Format.pp_print_string fmt "<internal>"
+      | Predef name -> Format.fprintf fmt "<predef:%s>" name
+      | Compilation_unit s -> Format.pp_print_string fmt s
+      | Item { comp_unit; id } -> Format.fprintf fmt "%s.%d" comp_unit id
+
+    let output oc t =
+      let fmt = Format.formatter_of_out_channel oc in
+      print fmt t
+  end)
+
+  let id = ref (-1)
+
+  let reinit () = id := (-1)
+
+  let mk  ~current_unit =
+      incr id;
+      Item { comp_unit = current_unit; id = !id }
+
+  let of_compilation_unit_id id =
+    if not (Ident.persistent id) then
+      Misc.fatal_errorf "Types.Uid.of_compilation_unit_id %S" (Ident.name id);
+    Compilation_unit (Ident.name id)
+
+  let of_predef_id id =
+    if not (Ident.is_predef id) then
+      Misc.fatal_errorf "Types.Uid.of_predef_id %S" (Ident.name id);
+    Predef (Ident.name id)
+
+  let internal_not_actually_unique = Internal
+
+  let for_actual_declaration = function
+    | Item _ -> true
+    | _ -> false
+end
+
+(* Maps of methods and instance variables *)
+
+module Meths = Misc.Stdlib.String.Map
+module Vars = Meths
+
+(* Value descriptions *)
+
+type value_description =
+  { val_type: type_expr;                (* Type of the value *)
+    val_kind: value_kind;
+    val_loc: Location.t;
+    val_attributes: Parsetree.attributes;
+    val_uid: Uid.t;
+  }
+
+and value_kind =
+    Val_reg                             (* Regular value *)
+  | Val_prim of Primitive.description   (* Primitive *)
+  | Val_ivar of mutable_flag * string   (* Instance variable (mutable ?) *)
+  | Val_self of (Ident.t * type_expr) Meths.t ref *
+                (Ident.t * Asttypes.mutable_flag *
+                 Asttypes.virtual_flag * type_expr) Vars.t ref *
+                string * type_expr
+                                        (* Self *)
+  | Val_anc of (string * Ident.t) list * string
+                                        (* Ancestor *)
+
+(* Variance *)
+
+module Variance = struct
+  type t = int
+  type f = May_pos | May_neg | May_weak | Inj | Pos | Neg | Inv
+  let single = function
+    | May_pos -> 1
+    | May_neg -> 2
+    | May_weak -> 4
+    | Inj -> 8
+    | Pos -> 16
+    | Neg -> 32
+    | Inv -> 64
+  let union v1 v2 = v1 lor v2
+  let inter v1 v2 = v1 land v2
+  let subset v1 v2 = (v1 land v2 = v1)
+  let eq (v1 : t) v2 = (v1 = v2)
+  let set x b v =
+    if b then v lor single x else  v land (lnot (single x))
+  let mem x = subset (single x)
+  let null = 0
+  let may_inv = 7
+  let full = 127
+  let covariant = single May_pos lor single Pos lor single Inj
+  let swap f1 f2 v =
+    let v' = set f1 (mem f2 v) v in set f2 (mem f1 v) v'
+  let conjugate v = swap May_pos May_neg (swap Pos Neg v)
+  let get_upper v = (mem May_pos v, mem May_neg v)
+  let get_lower v = (mem Pos v, mem Neg v, mem Inv v, mem Inj v)
+end
+
+module Separability = struct
+  type t = Ind | Sep | Deepsep
+  type signature = t list
+  let eq (m1 : t) m2 = (m1 = m2)
+  let rank = function
+    | Ind -> 0
+    | Sep -> 1
+    | Deepsep -> 2
+  let compare m1 m2 = compare (rank m1) (rank m2)
+  let max m1 m2 = if rank m1 >= rank m2 then m1 else m2
+
+  let print ppf = function
+    | Ind -> Format.fprintf ppf "Ind"
+    | Sep -> Format.fprintf ppf "Sep"
+    | Deepsep -> Format.fprintf ppf "Deepsep"
+
+  let print_signature ppf modes =
+    let pp_sep ppf () = Format.fprintf ppf ",@," in
+    Format.fprintf ppf "@[(%a)@]"
+      (Format.pp_print_list ~pp_sep print) modes
+
+  let default_signature ~arity =
+    let default_mode = if Config.flat_float_array then Deepsep else Ind in
+    List.init arity (fun _ -> default_mode)
+end
+
+(* Type definitions *)
+
+type type_declaration =
+  { type_params: type_expr list;
+    type_arity: int;
+    type_kind: type_kind;
+    type_private: private_flag;
+    type_manifest: type_expr option;
+    type_variance: Variance.t list;
+    type_separability: Separability.t list;
+    type_is_newtype: bool;
+    type_expansion_scope: int;
+    type_loc: Location.t;
+    type_attributes: Parsetree.attributes;
+    type_immediate: Type_immediacy.t;
+    type_unboxed: unboxed_status;
+    type_uid: Uid.t;
+ }
+
+and type_kind =
+    Type_abstract
+  | Type_record of label_declaration list  * record_representation
+  | Type_variant of constructor_declaration list
+  | Type_open
+
+and record_representation =
+    Record_regular                      (* All fields are boxed / tagged *)
+  | Record_float                        (* All fields are floats *)
+  | Record_unboxed of bool    (* Unboxed single-field record, inlined or not *)
+  | Record_inlined of int               (* Inlined record *)
+  | Record_extension of Path.t          (* Inlined record under extension *)
+
+and label_declaration =
+  {
+    ld_id: Ident.t;
+    ld_mutable: mutable_flag;
+    ld_type: type_expr;
+    ld_loc: Location.t;
+    ld_attributes: Parsetree.attributes;
+    ld_uid: Uid.t;
+  }
+
+and constructor_declaration =
+  {
+    cd_id: Ident.t;
+    cd_args: constructor_arguments;
+    cd_res: type_expr option;
+    cd_loc: Location.t;
+    cd_attributes: Parsetree.attributes;
+    cd_uid: Uid.t;
+  }
+
+and constructor_arguments =
+  | Cstr_tuple of type_expr list
+  | Cstr_record of label_declaration list
+
+and unboxed_status =
+  {
+    unboxed: bool;
+    default: bool; (* False if the unboxed field was set from an attribute. *)
+  }
+
+let unboxed_false_default_false = {unboxed = false; default = false}
+let unboxed_false_default_true = {unboxed = false; default = true}
+let unboxed_true_default_false = {unboxed = true; default = false}
+let unboxed_true_default_true = {unboxed = true; default = true}
+
+type extension_constructor =
+  { ext_type_path: Path.t;
+    ext_type_params: type_expr list;
+    ext_args: constructor_arguments;
+    ext_ret_type: type_expr option;
+    ext_private: private_flag;
+    ext_loc: Location.t;
+    ext_attributes: Parsetree.attributes;
+    ext_uid: Uid.t;
+  }
+
+and type_transparence =
+    Type_public      (* unrestricted expansion *)
+  | Type_new         (* "new" type *)
+  | Type_private     (* private type *)
+
+(* Type expressions for the class language *)
+
+module Concr = Misc.Stdlib.String.Set
+
+type class_type =
+    Cty_constr of Path.t * type_expr list * class_type
+  | Cty_signature of class_signature
+  | Cty_arrow of arg_label * type_expr * class_type
+
+and class_signature =
+  { csig_self: type_expr;
+    csig_vars:
+      (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
+    csig_concr: Concr.t;
+    csig_inher: (Path.t * type_expr list) list }
+
+type class_declaration =
+  { cty_params: type_expr list;
+    mutable cty_type: class_type;
+    cty_path: Path.t;
+    cty_new: type_expr option;
+    cty_variance: Variance.t list;
+    cty_loc: Location.t;
+    cty_attributes: Parsetree.attributes;
+    cty_uid: Uid.t;
+ }
+
+type class_type_declaration =
+  { clty_params: type_expr list;
+    clty_type: class_type;
+    clty_path: Path.t;
+    clty_variance: Variance.t list;
+    clty_loc: Location.t;
+    clty_attributes: Parsetree.attributes;
+    clty_uid: Uid.t;
+  }
+
+(* Type expressions for the module language *)
+
+type visibility =
+  | Exported
+  | Hidden
+
+type module_type =
+    Mty_ident of Path.t
+  | Mty_signature of signature
+  | Mty_functor of functor_parameter * module_type
+  | Mty_alias of Path.t
+
+and functor_parameter =
+  | Unit
+  | Named of Ident.t option * module_type
+
+and module_presence =
+  | Mp_present
+  | Mp_absent
+
+and signature = signature_item list
+
+and signature_item =
+    Sig_value of Ident.t * value_description * visibility
+  | Sig_type of Ident.t * type_declaration * rec_status * visibility
+  | Sig_typext of Ident.t * extension_constructor * ext_status * visibility
+  | Sig_module of
+      Ident.t * module_presence * module_declaration * rec_status * visibility
+  | Sig_modtype of Ident.t * modtype_declaration * visibility
+  | Sig_class of Ident.t * class_declaration * rec_status * visibility
+  | Sig_class_type of Ident.t * class_type_declaration * rec_status * visibility
+
+and module_declaration =
+  {
+    md_type: module_type;
+    md_attributes: Parsetree.attributes;
+    md_loc: Location.t;
+    md_uid: Uid.t;
+  }
+
+and modtype_declaration =
+  {
+    mtd_type: module_type option;  (* Note: abstract *)
+    mtd_attributes: Parsetree.attributes;
+    mtd_loc: Location.t;
+    mtd_uid: Uid.t;
+  }
+
+and rec_status =
+    Trec_not                   (* first in a nonrecursive group *)
+  | Trec_first                 (* first in a recursive group *)
+  | Trec_next                  (* not first in a recursive/nonrecursive group *)
+
+and ext_status =
+    Text_first                     (* first constructor of an extension *)
+  | Text_next                      (* not first constructor of an extension *)
+  | Text_exception                 (* an exception *)
+
+
+(* Constructor and record label descriptions inserted held in typing
+   environments *)
+
+type constructor_description =
+  { cstr_name: string;                  (* Constructor name *)
+    cstr_res: type_expr;                (* Type of the result *)
+    cstr_existentials: type_expr list;  (* list of existentials *)
+    cstr_args: type_expr list;          (* Type of the arguments *)
+    cstr_arity: int;                    (* Number of arguments *)
+    cstr_tag: constructor_tag;          (* Tag for heap blocks *)
+    cstr_consts: int;                   (* Number of constant constructors *)
+    cstr_nonconsts: int;                (* Number of non-const constructors *)
+    cstr_normal: int;                   (* Number of non generalized constrs *)
+    cstr_generalized: bool;             (* Constrained return type? *)
+    cstr_private: private_flag;         (* Read-only constructor? *)
+    cstr_loc: Location.t;
+    cstr_attributes: Parsetree.attributes;
+    cstr_inlined: type_declaration option;
+    cstr_uid: Uid.t;
+   }
+
+and constructor_tag =
+    Cstr_constant of int                (* Constant constructor (an int) *)
+  | Cstr_block of int                   (* Regular constructor (a block) *)
+  | Cstr_unboxed                        (* Constructor of an unboxed type *)
+  | Cstr_extension of Path.t * bool     (* Extension constructor
+                                           true if a constant false if a block*)
+
+let equal_tag t1 t2 =
+  match (t1, t2) with
+  | Cstr_constant i1, Cstr_constant i2 -> i2 = i1
+  | Cstr_block i1, Cstr_block i2 -> i2 = i1
+  | Cstr_unboxed, Cstr_unboxed -> true
+  | Cstr_extension (path1, b1), Cstr_extension (path2, b2) ->
+      Path.same path1 path2 && b1 = b2
+  | (Cstr_constant _|Cstr_block _|Cstr_unboxed|Cstr_extension _), _ -> false
+
+let may_equal_constr c1 c2 = match c1.cstr_tag,c2.cstr_tag with
+| Cstr_extension _,Cstr_extension _ -> c1.cstr_arity = c2.cstr_arity
+| tag1,tag2 -> equal_tag tag1 tag2
+
+type label_description =
+  { lbl_name: string;                   (* Short name *)
+    lbl_res: type_expr;                 (* Type of the result *)
+    lbl_arg: type_expr;                 (* Type of the argument *)
+    lbl_mut: mutable_flag;              (* Is this a mutable field? *)
+    lbl_pos: int;                       (* Position in block *)
+    lbl_all: label_description array;   (* All the labels in this type *)
+    lbl_repres: record_representation;  (* Representation for this record *)
+    lbl_private: private_flag;          (* Read-only field? *)
+    lbl_loc: Location.t;
+    lbl_attributes: Parsetree.attributes;
+    lbl_uid: Uid.t;
+   }
+
+let rec bound_value_identifiers = function
+    [] -> []
+  | Sig_value(id, {val_kind = Val_reg}, _) :: rem ->
+      id :: bound_value_identifiers rem
+  | Sig_typext(id, _, _, _) :: rem -> id :: bound_value_identifiers rem
+  | Sig_module(id, Mp_present, _, _, _) :: rem ->
+      id :: bound_value_identifiers rem
+  | Sig_class(id, _, _, _) :: rem -> id :: bound_value_identifiers rem
+  | _ :: rem -> bound_value_identifiers rem
+
+let signature_item_id = function
+  | Sig_value (id, _, _)
+  | Sig_type (id, _, _, _)
+  | Sig_typext (id, _, _, _)
+  | Sig_module (id, _, _, _, _)
+  | Sig_modtype (id, _, _)
+  | Sig_class (id, _, _, _)
+  | Sig_class_type (id, _, _, _)
+    -> id
diff --git a/upstream/ocaml_411/typing/types.mli b/upstream/ocaml_411/typing/types.mli
new file mode 100644
index 0000000..7dc2053
--- /dev/null
+++ b/upstream/ocaml_411/typing/types.mli
@@ -0,0 +1,577 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** {0 Representation of types and declarations} *)
+
+(** [Types] defines the representation of types and declarations (that is, the
+    content of module signatures).
+
+    CMI files are made of marshalled types.
+*)
+
+(** Asttypes exposes basic definitions shared both by Parsetree and Types. *)
+open Asttypes
+
+(** Type expressions for the core language.
+
+    The [type_desc] variant defines all the possible type expressions one can
+    find in OCaml. [type_expr] wraps this with some annotations.
+
+    The [level] field tracks the level of polymorphism associated to a type,
+    guiding the generalization algorithm.
+    Put shortly, when referring to a type in a given environment, both the type
+    and the environment have a level. If the type has an higher level, then it
+    can be considered fully polymorphic (type variables will be printed as
+    ['a]), otherwise it'll be weakly polymorphic, or non generalized (type
+    variables printed as ['_a]).
+    See [http://okmij.org/ftp/ML/generalization.html] for more information.
+
+    Note about [type_declaration]: one should not make the confusion between
+    [type_expr] and [type_declaration].
+
+    [type_declaration] refers specifically to the [type] construct in OCaml
+    language, where you create and name a new type or type alias.
+
+    [type_expr] is used when you refer to existing types, e.g. when annotating
+    the expected type of a value.
+
+    Also, as the type system of OCaml is generative, a [type_declaration] can
+    have the side-effect of introducing a new type constructor, different from
+    all other known types.
+    Whereas [type_expr] is a pure construct which allows referring to existing
+    types.
+
+    Note on mutability: TBD.
+ *)
+type type_expr =
+  { mutable desc: type_desc;
+    mutable level: int;
+    mutable scope: int;
+    id: int }
+
+and type_desc =
+  | Tvar of string option
+  (** [Tvar (Some "a")] ==> ['a] or ['_a]
+      [Tvar None]       ==> [_] *)
+
+  | Tarrow of arg_label * type_expr * type_expr * commutable
+  (** [Tarrow (Nolabel,      e1, e2, c)] ==> [e1    -> e2]
+      [Tarrow (Labelled "l", e1, e2, c)] ==> [l:e1  -> e2]
+      [Tarrow (Optional "l", e1, e2, c)] ==> [?l:e1 -> e2]
+
+      See [commutable] for the last argument. *)
+
+  | Ttuple of type_expr list
+  (** [Ttuple [t1;...;tn]] ==> [(t1 * ... * tn)] *)
+
+  | Tconstr of Path.t * type_expr list * abbrev_memo ref
+  (** [Tconstr (`A.B.t', [t1;...;tn], _)] ==> [(t1,...,tn) A.B.t]
+      The last parameter keep tracks of known expansions, see [abbrev_memo]. *)
+
+  | Tobject of type_expr * (Path.t * type_expr list) option ref
+  (** [Tobject (`f1:t1;...;fn: tn', `None')] ==> [< f1: t1; ...; fn: tn >]
+      f1, fn are represented as a linked list of types using Tfield and Tnil
+      constructors.
+
+      [Tobject (_, `Some (`A.ct', [t1;...;tn]')] ==> [(t1, ..., tn) A.ct].
+      where A.ct is the type of some class.
+
+      There are also special cases for so-called "class-types", cf. [Typeclass]
+      and [Ctype.set_object_name]:
+
+        [Tobject (Tfield(_,_,...(Tfield(_,_,rv)...),
+                         Some(`A.#ct`, [rv;t1;...;tn])]
+             ==> [(t1, ..., tn) #A.ct]
+        [Tobject (_, Some(`A.#ct`, [Tnil;t1;...;tn])] ==> [(t1, ..., tn) A.ct]
+
+      where [rv] is the hidden row variable.
+  *)
+
+  | Tfield of string * field_kind * type_expr * type_expr
+  (** [Tfield ("foo", Fpresent, t, ts)] ==> [<...; foo : t; ts>] *)
+
+  | Tnil
+  (** [Tnil] ==> [<...; >] *)
+
+  | Tlink of type_expr
+  (** Indirection used by unification engine. *)
+
+  | Tsubst of type_expr         (* for copying *)
+  (** [Tsubst] is used temporarily to store information in low-level
+      functions manipulating representation of types, such as
+      instantiation or copy.
+      This constructor should not appear outside of these cases. *)
+
+  | Tvariant of row_desc
+  (** Representation of polymorphic variants, see [row_desc]. *)
+
+  | Tunivar of string option
+  (** Occurrence of a type variable introduced by a
+      forall quantifier / [Tpoly]. *)
+
+  | Tpoly of type_expr * type_expr list
+  (** [Tpoly (ty,tyl)] ==> ['a1... 'an. ty],
+      where 'a1 ... 'an are names given to types in tyl
+      and occurrences of those types in ty. *)
+
+  | Tpackage of Path.t * Longident.t list * type_expr list
+  (** Type of a first-class module (a.k.a package). *)
+
+(** [  `X | `Y ]       (row_closed = true)
+    [< `X | `Y ]       (row_closed = true)
+    [> `X | `Y ]       (row_closed = false)
+    [< `X | `Y > `X ]  (row_closed = true)
+
+    type t = [> `X ] as 'a      (row_more = Tvar a)
+    type t = private [> `X ]    (row_more = Tconstr (t#row, [], ref Mnil))
+
+    And for:
+
+        let f = function `X -> `X -> | `Y -> `X
+
+    the type of "f" will be a [Tarrow] whose lhs will (basically) be:
+
+        Tvariant { row_fields = [("X", _)];
+                   row_more   =
+                     Tvariant { row_fields = [("Y", _)];
+                                row_more   =
+                                  Tvariant { row_fields = [];
+                                             row_more   = _;
+                                             _ };
+                                _ };
+                   _
+                 }
+
+*)
+and row_desc =
+    { row_fields: (label * row_field) list;
+      row_more: type_expr;
+      row_bound: unit; (* kept for compatibility *)
+      row_closed: bool;
+      row_fixed: fixed_explanation option;
+      row_name: (Path.t * type_expr list) option }
+and fixed_explanation =
+  | Univar of type_expr (** The row type was bound to an univar *)
+  | Fixed_private (** The row type is private *)
+  | Reified of Path.t (** The row was reified *)
+  | Rigid (** The row type was made rigid during constraint verification *)
+and row_field =
+    Rpresent of type_expr option
+  | Reither of bool * type_expr list * bool * row_field option ref
+        (* 1st true denotes a constant constructor *)
+        (* 2nd true denotes a tag in a pattern matching, and
+           is erased later *)
+  | Rabsent
+
+(** [abbrev_memo] allows one to keep track of different expansions of a type
+    alias. This is done for performance purposes.
+
+    For instance, when defining [type 'a pair = 'a * 'a], when one refers to an
+    ['a pair], it is just a shortcut for the ['a * 'a] type.
+    This expansion will be stored in the [abbrev_memo] of the corresponding
+    [Tconstr] node.
+
+    In practice, [abbrev_memo] behaves like list of expansions with a mutable
+    tail.
+
+    Note on marshalling: [abbrev_memo] must not appear in saved types.
+    [Btype], with [cleanup_abbrev] and [memo], takes care of tracking and
+    removing abbreviations.
+*)
+and abbrev_memo =
+  | Mnil (** No known abbreviation *)
+
+  | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo
+  (** Found one abbreviation.
+      A valid abbreviation should be at least as visible and reachable by the
+      same path.
+      The first expression is the abbreviation and the second the expansion. *)
+
+  | Mlink of abbrev_memo ref
+  (** Abbreviations can be found after this indirection *)
+
+and field_kind =
+    Fvar of field_kind option ref
+  | Fpresent
+  | Fabsent
+
+(** [commutable] is a flag appended to every arrow type.
+
+    When typing an application, if the type of the functional is
+    known, its type is instantiated with [Cok] arrows, otherwise as
+    [Clink (ref Cunknown)].
+
+    When the type is not known, the application will be used to infer
+    the actual type.  This is fragile in presence of labels where
+    there is no principal type.
+
+    Two incompatible applications relying on [Cunknown] arrows will
+    trigger an error.
+
+    let f g =
+      g ~a:() ~b:();
+      g ~b:() ~a:();
+
+    Error: This function is applied to arguments
+    in an order different from other calls.
+    This is only allowed when the real type is known.
+*)
+and commutable =
+    Cok
+  | Cunknown
+  | Clink of commutable ref
+
+module TypeOps : sig
+  type t = type_expr
+  val compare : t -> t -> int
+  val equal : t -> t -> bool
+  val hash : t -> int
+end
+
+(* *)
+
+module Uid : sig
+  type t
+
+  val reinit : unit -> unit
+
+  val mk : current_unit:string -> t
+  val of_compilation_unit_id : Ident.t -> t
+  val of_predef_id : Ident.t -> t
+  val internal_not_actually_unique : t
+
+  val for_actual_declaration : t -> bool
+
+  include Identifiable.S with type t := t
+end
+
+(* Maps of methods and instance variables *)
+
+module Meths : Map.S with type key = string
+module Vars  : Map.S with type key = string
+
+(* Value descriptions *)
+
+type value_description =
+  { val_type: type_expr;                (* Type of the value *)
+    val_kind: value_kind;
+    val_loc: Location.t;
+    val_attributes: Parsetree.attributes;
+    val_uid: Uid.t;
+  }
+
+and value_kind =
+    Val_reg                             (* Regular value *)
+  | Val_prim of Primitive.description   (* Primitive *)
+  | Val_ivar of mutable_flag * string   (* Instance variable (mutable ?) *)
+  | Val_self of (Ident.t * type_expr) Meths.t ref *
+                (Ident.t * mutable_flag * virtual_flag * type_expr) Vars.t ref *
+                string * type_expr
+                                        (* Self *)
+  | Val_anc of (string * Ident.t) list * string
+                                        (* Ancestor *)
+
+(* Variance *)
+
+module Variance : sig
+  type t
+  type f = May_pos | May_neg | May_weak | Inj | Pos | Neg | Inv
+  val null : t                          (* no occurrence *)
+  val full : t                          (* strictly invariant *)
+  val covariant : t                     (* strictly covariant *)
+  val may_inv : t                       (* maybe invariant *)
+  val union  : t -> t -> t
+  val inter  : t -> t -> t
+  val subset : t -> t -> bool
+  val eq : t -> t -> bool
+  val set : f -> bool -> t -> t
+  val mem : f -> t -> bool
+  val conjugate : t -> t                (* exchange positive and negative *)
+  val get_upper : t -> bool * bool                  (* may_pos, may_neg   *)
+  val get_lower : t -> bool * bool * bool * bool    (* pos, neg, inv, inj *)
+end
+
+module Separability : sig
+  (** see {!Typedecl_separability} for an explanation of separability
+      and separability modes.*)
+
+  type t = Ind | Sep | Deepsep
+  val eq : t -> t -> bool
+  val print : Format.formatter -> t -> unit
+
+  val rank : t -> int
+  (** Modes are ordered from the least to the most demanding:
+      Ind < Sep < Deepsep.
+      'rank' maps them to integers in an order-respecting way:
+      m1 < m2  <=>  rank m1 < rank m2 *)
+
+  val compare : t -> t -> int
+  (** Compare two mode according to their mode ordering. *)
+
+  val max : t -> t -> t
+  (** [max_mode m1 m2] returns the most demanding mode. It is used to
+      express the conjunction of two parameter mode constraints. *)
+
+  type signature = t list
+  (** The 'separability signature' of a type assigns a mode for
+      each of its parameters. [('a, 'b) t] has mode [(m1, m2)] if
+      [(t1, t2) t] is separable whenever [t1, t2] have mode [m1, m2]. *)
+
+  val print_signature : Format.formatter -> signature -> unit
+
+  val default_signature : arity:int -> signature
+  (** The most pessimistic separability for a completely unknown type. *)
+end
+
+(* Type definitions *)
+
+type type_declaration =
+  { type_params: type_expr list;
+    type_arity: int;
+    type_kind: type_kind;
+    type_private: private_flag;
+    type_manifest: type_expr option;
+    type_variance: Variance.t list;
+    (* covariant, contravariant, weakly contravariant, injective *)
+    type_separability: Separability.t list;
+    type_is_newtype: bool;
+    type_expansion_scope: int;
+    type_loc: Location.t;
+    type_attributes: Parsetree.attributes;
+    type_immediate: Type_immediacy.t;
+    type_unboxed: unboxed_status;
+    type_uid: Uid.t;
+  }
+
+and type_kind =
+    Type_abstract
+  | Type_record of label_declaration list  * record_representation
+  | Type_variant of constructor_declaration list
+  | Type_open
+
+and record_representation =
+    Record_regular                      (* All fields are boxed / tagged *)
+  | Record_float                        (* All fields are floats *)
+  | Record_unboxed of bool    (* Unboxed single-field record, inlined or not *)
+  | Record_inlined of int               (* Inlined record *)
+  | Record_extension of Path.t          (* Inlined record under extension *)
+
+and label_declaration =
+  {
+    ld_id: Ident.t;
+    ld_mutable: mutable_flag;
+    ld_type: type_expr;
+    ld_loc: Location.t;
+    ld_attributes: Parsetree.attributes;
+    ld_uid: Uid.t;
+  }
+
+and constructor_declaration =
+  {
+    cd_id: Ident.t;
+    cd_args: constructor_arguments;
+    cd_res: type_expr option;
+    cd_loc: Location.t;
+    cd_attributes: Parsetree.attributes;
+    cd_uid: Uid.t;
+  }
+
+and constructor_arguments =
+  | Cstr_tuple of type_expr list
+  | Cstr_record of label_declaration list
+
+and unboxed_status = private
+  (* This type must be private in order to ensure perfect sharing of the
+     four possible values. Otherwise, ocamlc.byte and ocamlc.opt produce
+     different executables. *)
+  {
+    unboxed: bool;
+    default: bool; (* True for unannotated unboxable types. *)
+  }
+
+val unboxed_false_default_false : unboxed_status
+val unboxed_false_default_true : unboxed_status
+val unboxed_true_default_false : unboxed_status
+val unboxed_true_default_true : unboxed_status
+
+type extension_constructor =
+  {
+    ext_type_path: Path.t;
+    ext_type_params: type_expr list;
+    ext_args: constructor_arguments;
+    ext_ret_type: type_expr option;
+    ext_private: private_flag;
+    ext_loc: Location.t;
+    ext_attributes: Parsetree.attributes;
+    ext_uid: Uid.t;
+  }
+
+and type_transparence =
+    Type_public      (* unrestricted expansion *)
+  | Type_new         (* "new" type *)
+  | Type_private     (* private type *)
+
+(* Type expressions for the class language *)
+
+module Concr : Set.S with type elt = string
+
+type class_type =
+    Cty_constr of Path.t * type_expr list * class_type
+  | Cty_signature of class_signature
+  | Cty_arrow of arg_label * type_expr * class_type
+
+and class_signature =
+  { csig_self: type_expr;
+    csig_vars:
+      (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
+    csig_concr: Concr.t;
+    csig_inher: (Path.t * type_expr list) list }
+
+type class_declaration =
+  { cty_params: type_expr list;
+    mutable cty_type: class_type;
+    cty_path: Path.t;
+    cty_new: type_expr option;
+    cty_variance: Variance.t list;
+    cty_loc: Location.t;
+    cty_attributes: Parsetree.attributes;
+    cty_uid: Uid.t;
+  }
+
+type class_type_declaration =
+  { clty_params: type_expr list;
+    clty_type: class_type;
+    clty_path: Path.t;
+    clty_variance: Variance.t list;
+    clty_loc: Location.t;
+    clty_attributes: Parsetree.attributes;
+    clty_uid: Uid.t;
+  }
+
+(* Type expressions for the module language *)
+
+type visibility =
+  | Exported
+  | Hidden
+
+type module_type =
+    Mty_ident of Path.t
+  | Mty_signature of signature
+  | Mty_functor of functor_parameter * module_type
+  | Mty_alias of Path.t
+
+and functor_parameter =
+  | Unit
+  | Named of Ident.t option * module_type
+
+and module_presence =
+  | Mp_present
+  | Mp_absent
+
+and signature = signature_item list
+
+and signature_item =
+    Sig_value of Ident.t * value_description * visibility
+  | Sig_type of Ident.t * type_declaration * rec_status * visibility
+  | Sig_typext of Ident.t * extension_constructor * ext_status * visibility
+  | Sig_module of
+      Ident.t * module_presence * module_declaration * rec_status * visibility
+  | Sig_modtype of Ident.t * modtype_declaration * visibility
+  | Sig_class of Ident.t * class_declaration * rec_status * visibility
+  | Sig_class_type of Ident.t * class_type_declaration * rec_status * visibility
+
+and module_declaration =
+  {
+    md_type: module_type;
+    md_attributes: Parsetree.attributes;
+    md_loc: Location.t;
+    md_uid: Uid.t;
+  }
+
+and modtype_declaration =
+  {
+    mtd_type: module_type option;  (* None: abstract *)
+    mtd_attributes: Parsetree.attributes;
+    mtd_loc: Location.t;
+    mtd_uid: Uid.t;
+  }
+
+and rec_status =
+    Trec_not                   (* first in a nonrecursive group *)
+  | Trec_first                 (* first in a recursive group *)
+  | Trec_next                  (* not first in a recursive/nonrecursive group *)
+
+and ext_status =
+    Text_first                     (* first constructor in an extension *)
+  | Text_next                      (* not first constructor in an extension *)
+  | Text_exception
+
+
+(* Constructor and record label descriptions inserted held in typing
+   environments *)
+
+type constructor_description =
+  { cstr_name: string;                  (* Constructor name *)
+    cstr_res: type_expr;                (* Type of the result *)
+    cstr_existentials: type_expr list;  (* list of existentials *)
+    cstr_args: type_expr list;          (* Type of the arguments *)
+    cstr_arity: int;                    (* Number of arguments *)
+    cstr_tag: constructor_tag;          (* Tag for heap blocks *)
+    cstr_consts: int;                   (* Number of constant constructors *)
+    cstr_nonconsts: int;                (* Number of non-const constructors *)
+    cstr_normal: int;                   (* Number of non generalized constrs *)
+    cstr_generalized: bool;             (* Constrained return type? *)
+    cstr_private: private_flag;         (* Read-only constructor? *)
+    cstr_loc: Location.t;
+    cstr_attributes: Parsetree.attributes;
+    cstr_inlined: type_declaration option;
+    cstr_uid: Uid.t;
+   }
+
+and constructor_tag =
+    Cstr_constant of int                (* Constant constructor (an int) *)
+  | Cstr_block of int                   (* Regular constructor (a block) *)
+  | Cstr_unboxed                        (* Constructor of an unboxed type *)
+  | Cstr_extension of Path.t * bool     (* Extension constructor
+                                           true if a constant false if a block*)
+
+(* Constructors are the same *)
+val equal_tag :  constructor_tag -> constructor_tag -> bool
+
+(* Constructors may be the same, given potential rebinding *)
+val may_equal_constr :
+    constructor_description ->  constructor_description -> bool
+
+type label_description =
+  { lbl_name: string;                   (* Short name *)
+    lbl_res: type_expr;                 (* Type of the result *)
+    lbl_arg: type_expr;                 (* Type of the argument *)
+    lbl_mut: mutable_flag;              (* Is this a mutable field? *)
+    lbl_pos: int;                       (* Position in block *)
+    lbl_all: label_description array;   (* All the labels in this type *)
+    lbl_repres: record_representation;  (* Representation for this record *)
+    lbl_private: private_flag;          (* Read-only field? *)
+    lbl_loc: Location.t;
+    lbl_attributes: Parsetree.attributes;
+    lbl_uid: Uid.t;
+  }
+
+(** Extracts the list of "value" identifiers bound by a signature.
+    "Value" identifiers are identifiers for signature components that
+    correspond to a run-time value: values, extensions, modules, classes.
+    Note: manifest primitives do not correspond to a run-time value! *)
+val bound_value_identifiers: signature -> Ident.t list
+
+val signature_item_id : signature_item -> Ident.t
diff --git a/upstream/ocaml_411/typing/typetexp.ml b/upstream/ocaml_411/typing/typetexp.ml
new file mode 100644
index 0000000..a55e53d
--- /dev/null
+++ b/upstream/ocaml_411/typing/typetexp.ml
@@ -0,0 +1,813 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* typetexp.ml,v 1.34.4.9 2002/01/07 08:39:16 garrigue Exp *)
+
+(* Typechecking of type expressions for the core language *)
+
+open Asttypes
+open Misc
+open Parsetree
+open Typedtree
+open Types
+open Ctype
+
+exception Already_bound
+
+type error =
+    Unbound_type_variable of string
+  | Undefined_type_constructor of Path.t
+  | Type_arity_mismatch of Longident.t * int * int
+  | Bound_type_variable of string
+  | Recursive_type
+  | Unbound_row_variable of Longident.t
+  | Type_mismatch of Ctype.Unification_trace.t
+  | Alias_type_mismatch of Ctype.Unification_trace.t
+  | Present_has_conjunction of string
+  | Present_has_no_type of string
+  | Constructor_mismatch of type_expr * type_expr
+  | Not_a_variant of type_expr
+  | Variant_tags of string * string
+  | Invalid_variable_name of string
+  | Cannot_quantify of string * type_expr
+  | Multiple_constraints_on_type of Longident.t
+  | Method_mismatch of string * type_expr * type_expr
+  | Opened_object of Path.t option
+  | Not_an_object of type_expr
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+(** Map indexed by type variable names. *)
+module TyVarMap = Misc.Stdlib.String.Map
+
+type variable_context = int * type_expr TyVarMap.t
+
+(* Support for first-class modules. *)
+
+let transl_modtype_longident = ref (fun _ -> assert false)
+let transl_modtype = ref (fun _ -> assert false)
+
+let create_package_mty fake loc env (p, l) =
+  let l =
+    List.sort
+      (fun (s1, _t1) (s2, _t2) ->
+         if s1.txt = s2.txt then
+           raise (Error (loc, env, Multiple_constraints_on_type s1.txt));
+         compare s1.txt s2.txt)
+      l
+  in
+  l,
+  List.fold_left
+    (fun mty (s, t) ->
+      let d = {ptype_name = mkloc (Longident.last s.txt) s.loc;
+               ptype_params = [];
+               ptype_cstrs = [];
+               ptype_kind = Ptype_abstract;
+               ptype_private = Asttypes.Public;
+               ptype_manifest = if fake then None else Some t;
+               ptype_attributes = [];
+               ptype_loc = loc} in
+      Ast_helper.Mty.mk ~loc
+        (Pmty_with (mty, [ Pwith_type ({ txt = s.txt; loc }, d) ]))
+    )
+    (Ast_helper.Mty.mk ~loc (Pmty_ident p))
+    l
+
+(* Translation of type expressions *)
+
+let type_variables = ref (TyVarMap.empty : type_expr TyVarMap.t)
+let univars        = ref ([] : (string * type_expr) list)
+let pre_univars    = ref ([] : type_expr list)
+let used_variables = ref (TyVarMap.empty : (type_expr * Location.t) TyVarMap.t)
+
+let reset_type_variables () =
+  reset_global_level ();
+  Ctype.reset_reified_var_counter ();
+  type_variables := TyVarMap.empty
+
+let narrow () =
+  (increase_global_level (), !type_variables)
+
+let widen (gl, tv) =
+  restore_global_level gl;
+  type_variables := tv
+
+let strict_ident c = (c = '_' || c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z')
+
+let validate_name = function
+    None -> None
+  | Some name as s ->
+      if name <> "" && strict_ident name.[0] then s else None
+
+let new_global_var ?name () =
+  new_global_var ?name:(validate_name name) ()
+let newvar ?name () =
+  newvar ?name:(validate_name name) ()
+
+let type_variable loc name =
+  try
+    TyVarMap.find name !type_variables
+  with Not_found ->
+    raise(Error(loc, Env.empty, Unbound_type_variable ("'" ^ name)))
+
+let valid_tyvar_name name =
+  name <> "" && name.[0] <> '_'
+
+let transl_type_param env styp =
+  let loc = styp.ptyp_loc in
+  match styp.ptyp_desc with
+    Ptyp_any ->
+      let ty = new_global_var ~name:"_" () in
+        { ctyp_desc = Ttyp_any; ctyp_type = ty; ctyp_env = env;
+          ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; }
+  | Ptyp_var name ->
+      let ty =
+        try
+          if not (valid_tyvar_name name) then
+            raise (Error (loc, Env.empty, Invalid_variable_name ("'" ^ name)));
+          ignore (TyVarMap.find name !type_variables);
+          raise Already_bound
+        with Not_found ->
+          let v = new_global_var ~name () in
+            type_variables := TyVarMap.add name v !type_variables;
+            v
+      in
+        { ctyp_desc = Ttyp_var name; ctyp_type = ty; ctyp_env = env;
+          ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; }
+  | _ -> assert false
+
+let transl_type_param env styp =
+  (* Currently useless, since type parameters cannot hold attributes
+     (but this could easily be lifted in the future). *)
+  Builtin_attributes.warning_scope styp.ptyp_attributes
+    (fun () -> transl_type_param env styp)
+
+
+let new_pre_univar ?name () =
+  let v = newvar ?name () in pre_univars := v :: !pre_univars; v
+
+type policy = Fixed | Extensible | Univars
+
+let rec transl_type env policy styp =
+  Builtin_attributes.warning_scope styp.ptyp_attributes
+    (fun () -> transl_type_aux env policy styp)
+
+and transl_type_aux env policy styp =
+  let loc = styp.ptyp_loc in
+  let ctyp ctyp_desc ctyp_type =
+    { ctyp_desc; ctyp_type; ctyp_env = env;
+      ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes }
+  in
+  match styp.ptyp_desc with
+    Ptyp_any ->
+      let ty =
+        if policy = Univars then new_pre_univar () else
+          if policy = Fixed then
+            raise (Error (styp.ptyp_loc, env, Unbound_type_variable "_"))
+          else newvar ()
+      in
+      ctyp Ttyp_any ty
+  | Ptyp_var name ->
+    let ty =
+      if not (valid_tyvar_name name) then
+        raise (Error (styp.ptyp_loc, env, Invalid_variable_name ("'" ^ name)));
+      begin try
+        instance (List.assoc name !univars)
+      with Not_found -> try
+        instance (fst (TyVarMap.find name !used_variables))
+      with Not_found ->
+        let v =
+          if policy = Univars then new_pre_univar ~name () else newvar ~name ()
+        in
+        used_variables := TyVarMap.add name (v, styp.ptyp_loc) !used_variables;
+        v
+      end
+    in
+    ctyp (Ttyp_var name) ty
+  | Ptyp_arrow(l, st1, st2) ->
+    let cty1 = transl_type env policy st1 in
+    let cty2 = transl_type env policy st2 in
+    let ty1 = cty1.ctyp_type in
+    let ty1 =
+      if Btype.is_optional l
+      then newty (Tconstr(Predef.path_option,[ty1], ref Mnil))
+      else ty1 in
+    let ty = newty (Tarrow(l, ty1, cty2.ctyp_type, Cok)) in
+    ctyp (Ttyp_arrow (l, cty1, cty2)) ty
+  | Ptyp_tuple stl ->
+    assert (List.length stl >= 2);
+    let ctys = List.map (transl_type env policy) stl in
+    let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in
+    ctyp (Ttyp_tuple ctys) ty
+  | Ptyp_constr(lid, stl) ->
+      let (path, decl) = Env.lookup_type ~loc:lid.loc lid.txt env in
+      let stl =
+        match stl with
+        | [ {ptyp_desc=Ptyp_any} as t ] when decl.type_arity > 1 ->
+            List.map (fun _ -> t) decl.type_params
+        | _ -> stl
+      in
+      if List.length stl <> decl.type_arity then
+        raise(Error(styp.ptyp_loc, env,
+                    Type_arity_mismatch(lid.txt, decl.type_arity,
+                                        List.length stl)));
+      let args = List.map (transl_type env policy) stl in
+      let params = instance_list decl.type_params in
+      let unify_param =
+        match decl.type_manifest with
+          None -> unify_var
+        | Some ty ->
+            if (repr ty).level = Btype.generic_level then unify_var else unify
+      in
+      List.iter2
+        (fun (sty, cty) ty' ->
+           try unify_param env ty' cty.ctyp_type with Unify trace ->
+             let trace = Unification_trace.swap trace in
+             raise (Error(sty.ptyp_loc, env, Type_mismatch trace))
+        )
+        (List.combine stl args) params;
+      let constr =
+        newconstr path (List.map (fun ctyp -> ctyp.ctyp_type) args) in
+      begin try
+        Ctype.enforce_constraints env constr
+      with Unify trace ->
+        raise (Error(styp.ptyp_loc, env, Type_mismatch trace))
+      end;
+      ctyp (Ttyp_constr (path, lid, args)) constr
+  | Ptyp_object (fields, o) ->
+      let ty, fields = transl_fields env policy o fields in
+      ctyp (Ttyp_object (fields, o)) (newobj ty)
+  | Ptyp_class(lid, stl) ->
+      let (path, decl, _is_variant) =
+        try
+          let path, decl = Env.find_type_by_name lid.txt env in
+          let rec check decl =
+            match decl.type_manifest with
+              None -> raise Not_found
+            | Some ty ->
+                match (repr ty).desc with
+                  Tvariant row when Btype.static_row row -> ()
+                | Tconstr (path, _, _) ->
+                    check (Env.find_type path env)
+                | _ -> raise Not_found
+          in check decl;
+          Location.deprecated styp.ptyp_loc
+            "old syntax for polymorphic variant type";
+          ignore(Env.lookup_type ~loc:lid.loc lid.txt env);
+          (path, decl,true)
+        with Not_found -> try
+          let lid2 =
+            match lid.txt with
+              Longident.Lident s     -> Longident.Lident ("#" ^ s)
+            | Longident.Ldot(r, s)   -> Longident.Ldot (r, "#" ^ s)
+            | Longident.Lapply(_, _) -> fatal_error "Typetexp.transl_type"
+          in
+          let path, decl = Env.find_type_by_name lid2 env in
+          ignore(Env.lookup_cltype ~loc:lid.loc lid.txt env);
+          (path, decl, false)
+        with Not_found ->
+          ignore (Env.lookup_cltype ~loc:lid.loc lid.txt env); assert false
+      in
+      if List.length stl <> decl.type_arity then
+        raise(Error(styp.ptyp_loc, env,
+                    Type_arity_mismatch(lid.txt, decl.type_arity,
+                                        List.length stl)));
+      let args = List.map (transl_type env policy) stl in
+      let params = instance_list decl.type_params in
+      List.iter2
+        (fun (sty, cty) ty' ->
+           try unify_var env ty' cty.ctyp_type with Unify trace ->
+             let trace = Unification_trace.swap trace in
+             raise (Error(sty.ptyp_loc, env, Type_mismatch trace))
+        )
+        (List.combine stl args) params;
+        let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in
+      let ty =
+        try Ctype.expand_head env (newconstr path ty_args)
+        with Unify trace ->
+          raise (Error(styp.ptyp_loc, env, Type_mismatch trace))
+      in
+      let ty = match ty.desc with
+        Tvariant row ->
+          let row = Btype.row_repr row in
+          let fields =
+            List.map
+              (fun (l,f) -> l,
+                match Btype.row_field_repr f with
+                | Rpresent (Some ty) ->
+                    Reither(false, [ty], false, ref None)
+                | Rpresent None ->
+                    Reither (true, [], false, ref None)
+                | _ -> f)
+              row.row_fields
+          in
+          let row = { row_closed = true; row_fields = fields;
+                      row_bound = (); row_name = Some (path, ty_args);
+                      row_fixed = None; row_more = newvar () } in
+          let static = Btype.static_row row in
+          let row =
+            if static then { row with row_more = newty Tnil }
+            else if policy <> Univars then row
+            else { row with row_more = new_pre_univar () }
+          in
+          newty (Tvariant row)
+      | Tobject (fi, _) ->
+          let _, tv = flatten_fields fi in
+          if policy = Univars then pre_univars := tv :: !pre_univars;
+          ty
+      | _ ->
+          assert false
+      in
+      ctyp (Ttyp_class (path, lid, args)) ty
+  | Ptyp_alias(st, alias) ->
+      let cty =
+        try
+          let t =
+            try List.assoc alias !univars
+            with Not_found ->
+              instance (fst(TyVarMap.find alias !used_variables))
+          in
+          let ty = transl_type env policy st in
+          begin try unify_var env t ty.ctyp_type with Unify trace ->
+            let trace = Unification_trace.swap trace in
+            raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace))
+          end;
+          ty
+        with Not_found ->
+          if !Clflags.principal then begin_def ();
+          let t = newvar () in
+          used_variables :=
+            TyVarMap.add alias (t, styp.ptyp_loc) !used_variables;
+          let ty = transl_type env policy st in
+          begin try unify_var env t ty.ctyp_type with Unify trace ->
+            let trace = Unification_trace.swap trace in
+            raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace))
+          end;
+          if !Clflags.principal then begin
+            end_def ();
+            generalize_structure t;
+          end;
+          let t = instance t in
+          let px = Btype.proxy t in
+          begin match px.desc with
+          | Tvar None -> Btype.set_type_desc px (Tvar (Some alias))
+          | Tunivar None -> Btype.set_type_desc px (Tunivar (Some alias))
+          | _ -> ()
+          end;
+          { ty with ctyp_type = t }
+      in
+      ctyp (Ttyp_alias (cty, alias)) cty.ctyp_type
+  | Ptyp_variant(fields, closed, present) ->
+      let name = ref None in
+      let mkfield l f =
+        newty (Tvariant {row_fields=[l,f]; row_more=newvar();
+                         row_bound=(); row_closed=true;
+                         row_fixed=None; row_name=None}) in
+      let hfields = Hashtbl.create 17 in
+      let add_typed_field loc l f =
+        let h = Btype.hash_variant l in
+        try
+          let (l',f') = Hashtbl.find hfields h in
+          (* Check for tag conflicts *)
+          if l <> l' then raise(Error(styp.ptyp_loc, env, Variant_tags(l, l')));
+          let ty = mkfield l f and ty' = mkfield l f' in
+          if equal env false [ty] [ty'] then () else
+          try unify env ty ty'
+          with Unify _trace ->
+            raise(Error(loc, env, Constructor_mismatch (ty,ty')))
+        with Not_found ->
+          Hashtbl.add hfields h (l,f)
+      in
+      let add_field field =
+        let rf_loc = field.prf_loc in
+        let rf_attributes = field.prf_attributes in
+        let rf_desc = match field.prf_desc with
+        | Rtag (l, c, stl) ->
+            name := None;
+            let tl =
+              Builtin_attributes.warning_scope rf_attributes
+                (fun () -> List.map (transl_type env policy) stl)
+            in
+            let f = match present with
+              Some present when not (List.mem l.txt present) ->
+                let ty_tl = List.map (fun cty -> cty.ctyp_type) tl in
+                Reither(c, ty_tl, false, ref None)
+            | _ ->
+                if List.length stl > 1 || c && stl <> [] then
+                  raise(Error(styp.ptyp_loc, env,
+                              Present_has_conjunction l.txt));
+                match tl with [] -> Rpresent None
+                | st :: _ ->
+                      Rpresent (Some st.ctyp_type)
+            in
+            add_typed_field styp.ptyp_loc l.txt f;
+              Ttag (l,c,tl)
+        | Rinherit sty ->
+            let cty = transl_type env policy sty in
+            let ty = cty.ctyp_type in
+            let nm =
+              match repr cty.ctyp_type with
+                {desc=Tconstr(p, tl, _)} -> Some(p, tl)
+              | _                        -> None
+            in
+            begin try
+              (* Set name if there are no fields yet *)
+              Hashtbl.iter (fun _ _ -> raise Exit) hfields;
+              name := nm
+            with Exit ->
+              (* Unset it otherwise *)
+              name := None
+            end;
+            let fl = match expand_head env cty.ctyp_type, nm with
+              {desc=Tvariant row}, _ when Btype.static_row row ->
+                let row = Btype.row_repr row in
+                row.row_fields
+            | {desc=Tvar _}, Some(p, _) ->
+                raise(Error(sty.ptyp_loc, env, Undefined_type_constructor p))
+            | _ ->
+                raise(Error(sty.ptyp_loc, env, Not_a_variant ty))
+            in
+            List.iter
+              (fun (l, f) ->
+                let f = match present with
+                  Some present when not (List.mem l present) ->
+                    begin match f with
+                      Rpresent(Some ty) ->
+                        Reither(false, [ty], false, ref None)
+                    | Rpresent None ->
+                        Reither(true, [], false, ref None)
+                    | _ ->
+                        assert false
+                    end
+                | _ -> f
+                in
+                add_typed_field sty.ptyp_loc l f)
+              fl;
+              Tinherit cty
+        in
+        { rf_desc; rf_loc; rf_attributes; }
+      in
+      let tfields = List.map add_field fields in
+      let fields = Hashtbl.fold (fun _ p l -> p :: l) hfields [] in
+      begin match present with None -> ()
+      | Some present ->
+          List.iter
+            (fun l -> if not (List.mem_assoc l fields) then
+              raise(Error(styp.ptyp_loc, env, Present_has_no_type l)))
+            present
+      end;
+      let row =
+        { row_fields = List.rev fields; row_more = newvar ();
+          row_bound = (); row_closed = (closed = Closed);
+          row_fixed = None; row_name = !name } in
+      let static = Btype.static_row row in
+      let row =
+        if static then { row with row_more = newty Tnil }
+        else if policy <> Univars then row
+        else { row with row_more = new_pre_univar () }
+      in
+      let ty = newty (Tvariant row) in
+      ctyp (Ttyp_variant (tfields, closed, present)) ty
+  | Ptyp_poly(vars, st) ->
+      let vars = List.map (fun v -> v.txt) vars in
+      begin_def();
+      let new_univars = List.map (fun name -> name, newvar ~name ()) vars in
+      let old_univars = !univars in
+      univars := new_univars @ !univars;
+      let cty = transl_type env policy st in
+      let ty = cty.ctyp_type in
+      univars := old_univars;
+      end_def();
+      generalize ty;
+      let ty_list =
+        List.fold_left
+          (fun tyl (name, ty1) ->
+            let v = Btype.proxy ty1 in
+            if deep_occur v ty then begin
+              match v.desc with
+                Tvar name when v.level = Btype.generic_level ->
+                  v.desc <- Tunivar name;
+                  v :: tyl
+              | _ ->
+                raise (Error (styp.ptyp_loc, env, Cannot_quantify (name, v)))
+            end else tyl)
+          [] new_univars
+      in
+      let ty' = Btype.newgenty (Tpoly(ty, List.rev ty_list)) in
+      unify_var env (newvar()) ty';
+      ctyp (Ttyp_poly (vars, cty)) ty'
+  | Ptyp_package (p, l) ->
+      let l, mty = create_package_mty true styp.ptyp_loc env (p, l) in
+      let z = narrow () in
+      let mty = !transl_modtype env mty in
+      widen z;
+      let ptys = List.map (fun (s, pty) ->
+                             s, transl_type env policy pty
+                          ) l in
+      let path = !transl_modtype_longident styp.ptyp_loc env p.txt in
+      let ty = newty (Tpackage (path,
+                       List.map (fun (s, _pty) -> s.txt) l,
+                       List.map (fun (_,cty) -> cty.ctyp_type) ptys))
+      in
+      ctyp (Ttyp_package {
+            pack_path = path;
+            pack_type = mty.mty_type;
+            pack_fields = ptys;
+            pack_txt = p;
+           }) ty
+  | Ptyp_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and transl_poly_type env policy t =
+  transl_type env policy (Ast_helper.Typ.force_poly t)
+
+and transl_fields env policy o fields =
+  let hfields = Hashtbl.create 17 in
+  let add_typed_field loc l ty =
+    try
+      let ty' = Hashtbl.find hfields l in
+      if equal env false [ty] [ty'] then () else
+        try unify env ty ty'
+        with Unify _trace ->
+          raise(Error(loc, env, Method_mismatch (l, ty, ty')))
+    with Not_found ->
+      Hashtbl.add hfields l ty in
+  let add_field {pof_desc; pof_loc; pof_attributes;} =
+    let of_loc = pof_loc in
+    let of_attributes = pof_attributes in
+    let of_desc = match pof_desc with
+    | Otag (s, ty1) -> begin
+        let ty1 =
+          Builtin_attributes.warning_scope of_attributes
+            (fun () -> transl_poly_type env policy ty1)
+        in
+        let field = OTtag (s, ty1) in
+        add_typed_field ty1.ctyp_loc s.txt ty1.ctyp_type;
+        field
+      end
+    | Oinherit sty -> begin
+        let cty = transl_type env policy sty in
+        let nm =
+          match repr cty.ctyp_type with
+            {desc=Tconstr(p, _, _)} -> Some p
+          | _                        -> None in
+        let t = expand_head env cty.ctyp_type in
+        match t, nm with
+          {desc=Tobject ({desc=(Tfield _ | Tnil) as tf}, _)}, _ -> begin
+            if opened_object t then
+              raise (Error (sty.ptyp_loc, env, Opened_object nm));
+            let rec iter_add = function
+              | Tfield (s, _k, ty1, ty2) -> begin
+                  add_typed_field sty.ptyp_loc s ty1;
+                  iter_add ty2.desc
+                end
+              | Tnil -> ()
+              | _ -> assert false in
+            iter_add tf;
+            OTinherit cty
+            end
+        | {desc=Tvar _}, Some p ->
+            raise (Error (sty.ptyp_loc, env, Undefined_type_constructor p))
+        | _ -> raise (Error (sty.ptyp_loc, env, Not_an_object t))
+      end in
+    { of_desc; of_loc; of_attributes; }
+  in
+  let object_fields = List.map add_field fields in
+  let fields = Hashtbl.fold (fun s ty l -> (s, ty) :: l) hfields [] in
+  let ty_init =
+     match o, policy with
+     | Closed, _ -> newty Tnil
+     | Open, Univars -> new_pre_univar ()
+     | Open, _ -> newvar () in
+  let ty = List.fold_left (fun ty (s, ty') ->
+      newty (Tfield (s, Fpresent, ty', ty))) ty_init fields in
+  ty, object_fields
+
+
+(* Make the rows "fixed" in this type, to make universal check easier *)
+let rec make_fixed_univars ty =
+  let ty = repr ty in
+  if ty.level >= Btype.lowest_level then begin
+    Btype.mark_type_node ty;
+    match ty.desc with
+    | Tvariant row ->
+        let row = Btype.row_repr row in
+        let more = Btype.row_more row in
+        if Btype.is_Tunivar more then
+          ty.desc <- Tvariant
+              {row with row_fixed=Some(Univar more);
+               row_fields = List.map
+                 (fun (s,f as p) -> match Btype.row_field_repr f with
+                   Reither (c, tl, _m, r) -> s, Reither (c, tl, true, r)
+                 | _ -> p)
+                 row.row_fields};
+        Btype.iter_row make_fixed_univars row
+    | _ ->
+        Btype.iter_type_expr make_fixed_univars ty
+  end
+
+let make_fixed_univars ty =
+  make_fixed_univars ty;
+  Btype.unmark_type ty
+
+let create_package_mty = create_package_mty false
+
+let globalize_used_variables env fixed =
+  let r = ref [] in
+  TyVarMap.iter
+    (fun name (ty, loc) ->
+      let v = new_global_var () in
+      let snap = Btype.snapshot () in
+      if try unify env v ty; true with _ -> Btype.backtrack snap; false
+      then try
+        r := (loc, v,  TyVarMap.find name !type_variables) :: !r
+      with Not_found ->
+        if fixed && Btype.is_Tvar (repr ty) then
+          raise(Error(loc, env, Unbound_type_variable ("'"^name)));
+        let v2 = new_global_var () in
+        r := (loc, v, v2) :: !r;
+        type_variables := TyVarMap.add name v2 !type_variables)
+    !used_variables;
+  used_variables := TyVarMap.empty;
+  fun () ->
+    List.iter
+      (function (loc, t1, t2) ->
+        try unify env t1 t2 with Unify trace ->
+          raise (Error(loc, env, Type_mismatch trace)))
+      !r
+
+let transl_simple_type env fixed styp =
+  univars := []; used_variables := TyVarMap.empty;
+  let typ = transl_type env (if fixed then Fixed else Extensible) styp in
+  globalize_used_variables env fixed ();
+  make_fixed_univars typ.ctyp_type;
+  typ
+
+let transl_simple_type_univars env styp =
+  univars := []; used_variables := TyVarMap.empty; pre_univars := [];
+  begin_def ();
+  let typ = transl_type env Univars styp in
+  (* Only keep already global variables in used_variables *)
+  let new_variables = !used_variables in
+  used_variables := TyVarMap.empty;
+  TyVarMap.iter
+    (fun name p ->
+      if TyVarMap.mem name !type_variables then
+        used_variables := TyVarMap.add name p !used_variables)
+    new_variables;
+  globalize_used_variables env false ();
+  end_def ();
+  generalize typ.ctyp_type;
+  let univs =
+    List.fold_left
+      (fun acc v ->
+        let v = repr v in
+        match v.desc with
+          Tvar name when v.level = Btype.generic_level ->
+            v.desc <- Tunivar name; v :: acc
+        | _ -> acc)
+      [] !pre_univars
+  in
+  make_fixed_univars typ.ctyp_type;
+    { typ with ctyp_type =
+        instance (Btype.newgenty (Tpoly (typ.ctyp_type, univs))) }
+
+let transl_simple_type_delayed env styp =
+  univars := []; used_variables := TyVarMap.empty;
+  let typ = transl_type env Extensible styp in
+  make_fixed_univars typ.ctyp_type;
+  (typ, globalize_used_variables env false)
+
+let transl_type_scheme env styp =
+  reset_type_variables();
+  begin_def();
+  let typ = transl_simple_type env false styp in
+  end_def();
+  generalize typ.ctyp_type;
+  typ
+
+
+(* Error report *)
+
+open Format
+open Printtyp
+
+let report_error env ppf = function
+  | Unbound_type_variable name ->
+      let add_name name _ l = if name = "_" then l else ("'" ^ name) :: l in
+      let names = TyVarMap.fold add_name !type_variables [] in
+    fprintf ppf "The type variable %s is unbound in this type declaration.@ %a"
+      name
+      did_you_mean (fun () -> Misc.spellcheck names name )
+  | Undefined_type_constructor p ->
+    fprintf ppf "The type constructor@ %a@ is not yet completely defined"
+      path p
+  | Type_arity_mismatch(lid, expected, provided) ->
+    fprintf ppf
+      "@[The type constructor %a@ expects %i argument(s),@ \
+        but is here applied to %i argument(s)@]"
+      longident lid expected provided
+  | Bound_type_variable name ->
+    fprintf ppf "Already bound type parameter %a" Pprintast.tyvar name
+  | Recursive_type ->
+    fprintf ppf "This type is recursive"
+  | Unbound_row_variable lid ->
+      (* we don't use "spellcheck" here: this error is not raised
+         anywhere so it's unclear how it should be handled *)
+      fprintf ppf "Unbound row variable in #%a" longident lid
+  | Type_mismatch trace ->
+      Printtyp.report_unification_error ppf Env.empty trace
+        (function ppf ->
+           fprintf ppf "This type")
+        (function ppf ->
+           fprintf ppf "should be an instance of type")
+  | Alias_type_mismatch trace ->
+      Printtyp.report_unification_error ppf Env.empty trace
+        (function ppf ->
+           fprintf ppf "This alias is bound to type")
+        (function ppf ->
+           fprintf ppf "but is used as an instance of type")
+  | Present_has_conjunction l ->
+      fprintf ppf "The present constructor %s has a conjunctive type" l
+  | Present_has_no_type l ->
+      fprintf ppf
+        "@[<v>@[The constructor %s is missing from the upper bound@ \
+         (between '<'@ and '>')@ of this polymorphic variant@ \
+         but is present in@ its lower bound (after '>').@]@,\
+         @[Hint: Either add `%s in the upper bound,@ \
+         or remove it@ from the lower bound.@]@]"
+         l l
+  | Constructor_mismatch (ty, ty') ->
+      wrap_printing_env ~error:true env (fun ()  ->
+        Printtyp.reset_and_mark_loops_list [ty; ty'];
+        fprintf ppf "@[<hov>%s %a@ %s@ %a@]"
+          "This variant type contains a constructor"
+          !Oprint.out_type (tree_of_typexp false ty)
+          "which should be"
+           !Oprint.out_type (tree_of_typexp false ty'))
+  | Not_a_variant ty ->
+      fprintf ppf
+        "@[The type %a@ does not expand to a polymorphic variant type@]"
+        Printtyp.type_expr ty;
+      begin match ty.desc with
+        | Tvar (Some s) ->
+           (* PR#7012: help the user that wrote 'Foo instead of `Foo *)
+           Misc.did_you_mean ppf (fun () -> ["`" ^ s])
+        | _ -> ()
+      end
+  | Variant_tags (lab1, lab2) ->
+      fprintf ppf
+        "@[Variant tags `%s@ and `%s have the same hash value.@ %s@]"
+        lab1 lab2 "Change one of them."
+  | Invalid_variable_name name ->
+      fprintf ppf "The type variable name %s is not allowed in programs" name
+  | Cannot_quantify (name, v) ->
+      fprintf ppf
+        "@[<hov>The universal type variable %a cannot be generalized:@ "
+        Pprintast.tyvar name;
+      if Btype.is_Tvar v then
+        fprintf ppf "it escapes its scope"
+      else if Btype.is_Tunivar v then
+        fprintf ppf "it is already bound to another variable"
+      else
+        fprintf ppf "it is bound to@ %a" Printtyp.type_expr v;
+      fprintf ppf ".@]";
+  | Multiple_constraints_on_type s ->
+      fprintf ppf "Multiple constraints for type %a" longident s
+  | Method_mismatch (l, ty, ty') ->
+      wrap_printing_env ~error:true env (fun ()  ->
+        fprintf ppf "@[<hov>Method '%s' has type %a,@ which should be %a@]"
+          l Printtyp.type_expr ty Printtyp.type_expr ty')
+  | Opened_object nm ->
+      fprintf ppf
+        "Illegal open object type%a"
+        (fun ppf -> function
+             Some p -> fprintf ppf "@ %a" path p
+           | None -> fprintf ppf "") nm
+  | Not_an_object ty ->
+      fprintf ppf "@[The type %a@ is not an object type@]"
+        Printtyp.type_expr ty
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, env, err) ->
+        Some (Location.error_of_printer ~loc (report_error env) err)
+      | Error_forward err ->
+        Some err
+      | _ ->
+        None
+    )
diff --git a/upstream/ocaml_411/typing/typetexp.mli b/upstream/ocaml_411/typing/typetexp.mli
new file mode 100644
index 0000000..5475abb
--- /dev/null
+++ b/upstream/ocaml_411/typing/typetexp.mli
@@ -0,0 +1,76 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Typechecking of type expressions for the core language *)
+
+open Types
+
+val valid_tyvar_name : string -> bool
+
+val transl_simple_type:
+        Env.t -> bool -> Parsetree.core_type -> Typedtree.core_type
+val transl_simple_type_univars:
+        Env.t -> Parsetree.core_type -> Typedtree.core_type
+val transl_simple_type_delayed:
+        Env.t -> Parsetree.core_type -> Typedtree.core_type * (unit -> unit)
+        (* Translate a type, but leave type variables unbound. Returns
+           the type and a function that binds the type variable. *)
+val transl_type_scheme:
+        Env.t -> Parsetree.core_type -> Typedtree.core_type
+val reset_type_variables: unit -> unit
+val type_variable: Location.t -> string -> type_expr
+val transl_type_param:
+  Env.t -> Parsetree.core_type -> Typedtree.core_type
+
+type variable_context
+val narrow: unit -> variable_context
+val widen: variable_context -> unit
+
+exception Already_bound
+
+type error =
+    Unbound_type_variable of string
+  | Undefined_type_constructor of Path.t
+  | Type_arity_mismatch of Longident.t * int * int
+  | Bound_type_variable of string
+  | Recursive_type
+  | Unbound_row_variable of Longident.t
+  | Type_mismatch of Ctype.Unification_trace.t
+  | Alias_type_mismatch of Ctype.Unification_trace.t
+  | Present_has_conjunction of string
+  | Present_has_no_type of string
+  | Constructor_mismatch of type_expr * type_expr
+  | Not_a_variant of type_expr
+  | Variant_tags of string * string
+  | Invalid_variable_name of string
+  | Cannot_quantify of string * type_expr
+  | Multiple_constraints_on_type of Longident.t
+  | Method_mismatch of string * type_expr * type_expr
+  | Opened_object of Path.t option
+  | Not_an_object of type_expr
+
+exception Error of Location.t * Env.t * error
+
+val report_error: Env.t -> Format.formatter -> error -> unit
+
+(* Support for first-class modules. *)
+val transl_modtype_longident:  (* from Typemod *)
+    (Location.t -> Env.t -> Longident.t -> Path.t) ref
+val transl_modtype: (* from Typemod *)
+    (Env.t -> Parsetree.module_type -> Typedtree.module_type) ref
+val create_package_mty:
+    Location.t -> Env.t -> Parsetree.package_type ->
+    (Longident.t Asttypes.loc * Parsetree.core_type) list *
+      Parsetree.module_type
diff --git a/upstream/ocaml_411/typing/untypeast.ml b/upstream/ocaml_411/typing/untypeast.ml
new file mode 100644
index 0000000..7106da5
--- /dev/null
+++ b/upstream/ocaml_411/typing/untypeast.ml
@@ -0,0 +1,889 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*    Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay)     *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Longident
+open Asttypes
+open Parsetree
+open Ast_helper
+
+module T = Typedtree
+
+type mapper = {
+  attribute: mapper -> T.attribute -> attribute;
+  attributes: mapper -> T.attribute list -> attribute list;
+  binding_op: mapper -> T.binding_op -> T.pattern -> binding_op;
+  case: 'k . mapper -> 'k T.case -> case;
+  class_declaration: mapper -> T.class_declaration -> class_declaration;
+  class_description: mapper -> T.class_description -> class_description;
+  class_expr: mapper -> T.class_expr -> class_expr;
+  class_field: mapper -> T.class_field -> class_field;
+  class_signature: mapper -> T.class_signature -> class_signature;
+  class_structure: mapper -> T.class_structure -> class_structure;
+  class_type: mapper -> T.class_type -> class_type;
+  class_type_declaration: mapper -> T.class_type_declaration
+                          -> class_type_declaration;
+  class_type_field: mapper -> T.class_type_field -> class_type_field;
+  constructor_declaration: mapper -> T.constructor_declaration
+                           -> constructor_declaration;
+  expr: mapper -> T.expression -> expression;
+  extension_constructor: mapper -> T.extension_constructor
+                         -> extension_constructor;
+  include_declaration: mapper -> T.include_declaration -> include_declaration;
+  include_description: mapper -> T.include_description -> include_description;
+  label_declaration: mapper -> T.label_declaration -> label_declaration;
+  location: mapper -> Location.t -> Location.t;
+  module_binding: mapper -> T.module_binding -> module_binding;
+  module_declaration: mapper -> T.module_declaration -> module_declaration;
+  module_substitution: mapper -> T.module_substitution -> module_substitution;
+  module_expr: mapper -> T.module_expr -> module_expr;
+  module_type: mapper -> T.module_type -> module_type;
+  module_type_declaration:
+    mapper -> T.module_type_declaration -> module_type_declaration;
+  package_type: mapper -> T.package_type -> package_type;
+  open_declaration: mapper -> T.open_declaration -> open_declaration;
+  open_description: mapper -> T.open_description -> open_description;
+  pat: 'k . mapper -> 'k T.general_pattern -> pattern;
+  row_field: mapper -> T.row_field -> row_field;
+  object_field: mapper -> T.object_field -> object_field;
+  signature: mapper -> T.signature -> signature;
+  signature_item: mapper -> T.signature_item -> signature_item;
+  structure: mapper -> T.structure -> structure;
+  structure_item: mapper -> T.structure_item -> structure_item;
+  typ: mapper -> T.core_type -> core_type;
+  type_declaration: mapper -> T.type_declaration -> type_declaration;
+  type_extension: mapper -> T.type_extension -> type_extension;
+  type_exception: mapper -> T.type_exception -> type_exception;
+  type_kind: mapper -> T.type_kind -> type_kind;
+  value_binding: mapper -> T.value_binding -> value_binding;
+  value_description: mapper -> T.value_description -> value_description;
+  with_constraint:
+    mapper -> (Path.t * Longident.t Location.loc * T.with_constraint)
+    -> with_constraint;
+}
+
+open T
+
+(*
+Some notes:
+
+   * For Pexp_function, we cannot go back to the exact original version
+   when there is a default argument, because the default argument is
+   translated in the typer. The code, if printed, will not be parsable because
+   new generated identifiers are not correct.
+
+   * For Pexp_apply, it is unclear whether arguments are reordered, especially
+    when there are optional arguments.
+
+*)
+
+
+(** Utility functions. *)
+
+let string_is_prefix sub str =
+  let sublen = String.length sub in
+  String.length str >= sublen && String.sub str 0 sublen = sub
+
+let rec lident_of_path = function
+  | Path.Pident id -> Longident.Lident (Ident.name id)
+  | Path.Pdot (p, s) -> Longident.Ldot (lident_of_path p, s)
+  | Path.Papply (p1, p2) ->
+      Longident.Lapply (lident_of_path p1, lident_of_path p2)
+
+let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}
+
+(** Try a name [$name$0], check if it's free, if not, increment and repeat. *)
+let fresh_name s env =
+  let rec aux i =
+    let name = s ^ Int.to_string i in
+    if Env.bound_value name env then aux (i+1)
+    else name
+  in
+  aux 0
+
+(** Extract the [n] patterns from the case of a letop *)
+let rec extract_letop_patterns n pat =
+  if n = 0 then pat, []
+  else begin
+    match pat.pat_desc with
+    | Tpat_tuple([first; rest]) ->
+        let next, others = extract_letop_patterns (n-1) rest in
+        first, next :: others
+    | _ ->
+      let rec anys n =
+        if n = 0 then []
+        else { pat with pat_desc = Tpat_any } :: anys (n-1)
+      in
+      { pat with pat_desc = Tpat_any }, anys (n-1)
+  end
+
+(** Mapping functions. *)
+
+let constant = function
+  | Const_char c -> Pconst_char c
+  | Const_string (s,loc,d) -> Pconst_string (s,loc,d)
+  | Const_int i -> Pconst_integer (Int.to_string i, None)
+  | Const_int32 i -> Pconst_integer (Int32.to_string i, Some 'l')
+  | Const_int64 i -> Pconst_integer (Int64.to_string i, Some 'L')
+  | Const_nativeint i -> Pconst_integer (Nativeint.to_string i, Some 'n')
+  | Const_float f -> Pconst_float (f,None)
+
+let attribute sub a = {
+    attr_name = map_loc sub a.attr_name;
+    attr_payload = a.attr_payload;
+    attr_loc = a.attr_loc
+  }
+
+let attributes sub l = List.map (sub.attribute sub) l
+
+let structure sub str =
+  List.map (sub.structure_item sub) str.str_items
+
+let open_description sub od =
+  let loc = sub.location sub od.open_loc in
+  let attrs = sub.attributes sub od.open_attributes in
+  Opn.mk ~loc ~attrs
+    ~override:od.open_override
+    (snd od.open_expr)
+
+let open_declaration sub od =
+  let loc = sub.location sub od.open_loc in
+  let attrs = sub.attributes sub od.open_attributes in
+  Opn.mk ~loc ~attrs
+    ~override:od.open_override
+    (sub.module_expr sub od.open_expr)
+
+let structure_item sub item =
+  let loc = sub.location sub item.str_loc in
+  let desc =
+    match item.str_desc with
+      Tstr_eval (exp, attrs) -> Pstr_eval (sub.expr sub exp, attrs)
+    | Tstr_value (rec_flag, list) ->
+        Pstr_value (rec_flag, List.map (sub.value_binding sub) list)
+    | Tstr_primitive vd ->
+        Pstr_primitive (sub.value_description sub vd)
+    | Tstr_type (rec_flag, list) ->
+        Pstr_type (rec_flag, List.map (sub.type_declaration sub) list)
+    | Tstr_typext tyext ->
+        Pstr_typext (sub.type_extension sub tyext)
+    | Tstr_exception ext ->
+        Pstr_exception (sub.type_exception sub ext)
+    | Tstr_module mb ->
+        Pstr_module (sub.module_binding sub mb)
+    | Tstr_recmodule list ->
+        Pstr_recmodule (List.map (sub.module_binding sub) list)
+    | Tstr_modtype mtd ->
+        Pstr_modtype (sub.module_type_declaration sub mtd)
+    | Tstr_open od ->
+        Pstr_open (sub.open_declaration sub od)
+    | Tstr_class list ->
+        Pstr_class
+          (List.map
+             (fun (ci, _) -> sub.class_declaration sub ci)
+             list)
+    | Tstr_class_type list ->
+        Pstr_class_type
+          (List.map
+             (fun (_id, _name, ct) -> sub.class_type_declaration sub ct)
+             list)
+    | Tstr_include incl ->
+        Pstr_include (sub.include_declaration sub incl)
+    | Tstr_attribute x ->
+        Pstr_attribute x
+  in
+  Str.mk ~loc desc
+
+let value_description sub v =
+  let loc = sub.location sub v.val_loc in
+  let attrs = sub.attributes sub v.val_attributes in
+  Val.mk ~loc ~attrs
+    ~prim:v.val_prim
+    (map_loc sub v.val_name)
+    (sub.typ sub v.val_desc)
+
+let module_binding sub mb =
+  let loc = sub.location sub mb.mb_loc in
+  let attrs = sub.attributes sub mb.mb_attributes in
+  Mb.mk ~loc ~attrs
+    (map_loc sub mb.mb_name)
+    (sub.module_expr sub mb.mb_expr)
+
+let type_parameter sub (ct, v) = (sub.typ sub ct, v)
+
+let type_declaration sub decl =
+  let loc = sub.location sub decl.typ_loc in
+  let attrs = sub.attributes sub decl.typ_attributes in
+  Type.mk ~loc ~attrs
+    ~params:(List.map (type_parameter sub) decl.typ_params)
+    ~cstrs:(
+      List.map
+        (fun (ct1, ct2, loc) ->
+           (sub.typ sub ct1, sub.typ sub ct2, sub.location sub loc))
+        decl.typ_cstrs)
+    ~kind:(sub.type_kind sub decl.typ_kind)
+    ~priv:decl.typ_private
+    ?manifest:(Option.map (sub.typ sub) decl.typ_manifest)
+    (map_loc sub decl.typ_name)
+
+let type_kind sub tk = match tk with
+  | Ttype_abstract -> Ptype_abstract
+  | Ttype_variant list ->
+      Ptype_variant (List.map (sub.constructor_declaration sub) list)
+  | Ttype_record list ->
+      Ptype_record (List.map (sub.label_declaration sub) list)
+  | Ttype_open -> Ptype_open
+
+let constructor_arguments sub = function
+   | Cstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l)
+   | Cstr_record l -> Pcstr_record (List.map (sub.label_declaration sub) l)
+
+let constructor_declaration sub cd =
+  let loc = sub.location sub cd.cd_loc in
+  let attrs = sub.attributes sub cd.cd_attributes in
+  Type.constructor ~loc ~attrs
+    ~args:(constructor_arguments sub cd.cd_args)
+    ?res:(Option.map (sub.typ sub) cd.cd_res)
+    (map_loc sub cd.cd_name)
+
+let label_declaration sub ld =
+  let loc = sub.location sub ld.ld_loc in
+  let attrs = sub.attributes sub ld.ld_attributes in
+  Type.field ~loc ~attrs
+    ~mut:ld.ld_mutable
+    (map_loc sub ld.ld_name)
+    (sub.typ sub ld.ld_type)
+
+let type_extension sub tyext =
+  let attrs = sub.attributes sub tyext.tyext_attributes in
+  Te.mk ~attrs
+    ~params:(List.map (type_parameter sub) tyext.tyext_params)
+    ~priv:tyext.tyext_private
+    (map_loc sub tyext.tyext_txt)
+    (List.map (sub.extension_constructor sub) tyext.tyext_constructors)
+
+let type_exception sub tyexn =
+  let attrs = sub.attributes sub tyexn.tyexn_attributes in
+  Te.mk_exception ~attrs
+    (sub.extension_constructor sub tyexn.tyexn_constructor)
+
+let extension_constructor sub ext =
+  let loc = sub.location sub ext.ext_loc in
+  let attrs = sub.attributes sub ext.ext_attributes in
+  Te.constructor ~loc ~attrs
+    (map_loc sub ext.ext_name)
+    (match ext.ext_kind with
+      | Text_decl (args, ret) ->
+          Pext_decl (constructor_arguments sub args,
+                     Option.map (sub.typ sub) ret)
+      | Text_rebind (_p, lid) -> Pext_rebind (map_loc sub lid)
+    )
+
+let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat ->
+  let loc = sub.location sub pat.pat_loc in
+  (* todo: fix attributes on extras *)
+  let attrs = sub.attributes sub pat.pat_attributes in
+  let desc =
+  match pat with
+      { pat_extra=[Tpat_unpack, loc, _attrs]; pat_desc = Tpat_any; _ } ->
+        Ppat_unpack { txt = None; loc  }
+    | { pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } ->
+        Ppat_unpack { name with txt = Some name.txt }
+    | { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } ->
+        Ppat_type (map_loc sub lid)
+    | { pat_extra= (Tpat_constraint ct, _, _attrs) :: rem; _ } ->
+        Ppat_constraint (sub.pat sub { pat with pat_extra=rem },
+                         sub.typ sub ct)
+    | _ ->
+    match pat.pat_desc with
+      Tpat_any -> Ppat_any
+    | Tpat_var (id, name) ->
+        begin
+          match (Ident.name id).[0] with
+            'A'..'Z' ->
+              Ppat_unpack { name with txt = Some name.txt}
+          | _ ->
+              Ppat_var name
+        end
+
+    (* We transform (_ as x) in x if _ and x have the same location.
+       The compiler transforms (x:t) into (_ as x : t).
+       This avoids transforming a warning 27 into a 26.
+     *)
+    | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name)
+         when pat_loc = pat.pat_loc ->
+       Ppat_var name
+
+    | Tpat_alias (pat, _id, name) ->
+        Ppat_alias (sub.pat sub pat, name)
+    | Tpat_constant cst -> Ppat_constant (constant cst)
+    | Tpat_tuple list ->
+        Ppat_tuple (List.map (sub.pat sub) list)
+    | Tpat_construct (lid, _, args) ->
+        Ppat_construct (map_loc sub lid,
+          (match args with
+              [] -> None
+            | [arg] -> Some (sub.pat sub arg)
+            | args ->
+                Some
+                  (Pat.tuple ~loc
+                     (List.map (sub.pat sub) args)
+                  )
+          ))
+    | Tpat_variant (label, pato, _) ->
+        Ppat_variant (label, Option.map (sub.pat sub) pato)
+    | Tpat_record (list, closed) ->
+        Ppat_record (List.map (fun (lid, _, pat) ->
+            map_loc sub lid, sub.pat sub pat) list, closed)
+    | Tpat_array list -> Ppat_array (List.map (sub.pat sub) list)
+    | Tpat_lazy p -> Ppat_lazy (sub.pat sub p)
+
+    | Tpat_exception p -> Ppat_exception (sub.pat sub p)
+    | Tpat_value p -> (sub.pat sub (p :> pattern)).ppat_desc
+    | Tpat_or (p1, p2, _) -> Ppat_or (sub.pat sub p1, sub.pat sub p2)
+  in
+  Pat.mk ~loc ~attrs desc
+
+let exp_extra sub (extra, loc, attrs) sexp =
+  let loc = sub.location sub loc in
+  let attrs = sub.attributes sub attrs in
+  let desc =
+    match extra with
+      Texp_coerce (cty1, cty2) ->
+        Pexp_coerce (sexp,
+                     Option.map (sub.typ sub) cty1,
+                     sub.typ sub cty2)
+    | Texp_constraint cty ->
+        Pexp_constraint (sexp, sub.typ sub cty)
+    | Texp_poly cto -> Pexp_poly (sexp, Option.map (sub.typ sub) cto)
+    | Texp_newtype s -> Pexp_newtype (mkloc s loc, sexp)
+  in
+  Exp.mk ~loc ~attrs desc
+
+let case : type k . mapper -> k case -> _ = fun sub {c_lhs; c_guard; c_rhs} ->
+  {
+   pc_lhs = sub.pat sub c_lhs;
+   pc_guard = Option.map (sub.expr sub) c_guard;
+   pc_rhs = sub.expr sub c_rhs;
+  }
+
+let value_binding sub vb =
+  let loc = sub.location sub vb.vb_loc in
+  let attrs = sub.attributes sub vb.vb_attributes in
+  Vb.mk ~loc ~attrs
+    (sub.pat sub vb.vb_pat)
+    (sub.expr sub vb.vb_expr)
+
+let expression sub exp =
+  let loc = sub.location sub exp.exp_loc in
+  let attrs = sub.attributes sub exp.exp_attributes in
+  let desc =
+    match exp.exp_desc with
+      Texp_ident (_path, lid, _) -> Pexp_ident (map_loc sub lid)
+    | Texp_constant cst -> Pexp_constant (constant cst)
+    | Texp_let (rec_flag, list, exp) ->
+        Pexp_let (rec_flag,
+          List.map (sub.value_binding sub) list,
+          sub.expr sub exp)
+
+    (* Pexp_function can't have a label, so we split in 3 cases. *)
+    (* One case, no guard: It's a fun. *)
+    | Texp_function { arg_label; cases = [{c_lhs=p; c_guard=None; c_rhs=e}];
+          _ } ->
+        Pexp_fun (arg_label, None, sub.pat sub p, sub.expr sub e)
+    (* No label: it's a function. *)
+    | Texp_function { arg_label = Nolabel; cases; _; } ->
+        Pexp_function (List.map (sub.case sub) cases)
+    (* Mix of both, we generate `fun ~label:$name$ -> match $name$ with ...` *)
+    | Texp_function { arg_label = Labelled s | Optional s as label; cases;
+          _ } ->
+        let name = fresh_name s exp.exp_env in
+        Pexp_fun (label, None, Pat.var ~loc {loc;txt = name },
+          Exp.match_ ~loc (Exp.ident ~loc {loc;txt= Lident name})
+                          (List.map (sub.case sub) cases))
+    | Texp_apply (exp, list) ->
+        Pexp_apply (sub.expr sub exp,
+          List.fold_right (fun (label, expo) list ->
+              match expo with
+                None -> list
+              | Some exp -> (label, sub.expr sub exp) :: list
+          ) list [])
+    | Texp_match (exp, cases, _) ->
+      Pexp_match (sub.expr sub exp, List.map (sub.case sub) cases)
+    | Texp_try (exp, cases) ->
+        Pexp_try (sub.expr sub exp, List.map (sub.case sub) cases)
+    | Texp_tuple list ->
+        Pexp_tuple (List.map (sub.expr sub) list)
+    | Texp_construct (lid, _, args) ->
+        Pexp_construct (map_loc sub lid,
+          (match args with
+              [] -> None
+          | [ arg ] -> Some (sub.expr sub arg)
+          | args ->
+              Some
+                (Exp.tuple ~loc (List.map (sub.expr sub) args))
+          ))
+    | Texp_variant (label, expo) ->
+        Pexp_variant (label, Option.map (sub.expr sub) expo)
+    | Texp_record { fields; extended_expression; _ } ->
+        let list = Array.fold_left (fun l -> function
+            | _, Kept _ -> l
+            | _, Overridden (lid, exp) -> (lid, sub.expr sub exp) :: l)
+            [] fields
+        in
+        Pexp_record (list, Option.map (sub.expr sub) extended_expression)
+    | Texp_field (exp, lid, _label) ->
+        Pexp_field (sub.expr sub exp, map_loc sub lid)
+    | Texp_setfield (exp1, lid, _label, exp2) ->
+        Pexp_setfield (sub.expr sub exp1, map_loc sub lid,
+          sub.expr sub exp2)
+    | Texp_array list ->
+        Pexp_array (List.map (sub.expr sub) list)
+    | Texp_ifthenelse (exp1, exp2, expo) ->
+        Pexp_ifthenelse (sub.expr sub exp1,
+          sub.expr sub exp2,
+          Option.map (sub.expr sub) expo)
+    | Texp_sequence (exp1, exp2) ->
+        Pexp_sequence (sub.expr sub exp1, sub.expr sub exp2)
+    | Texp_while (exp1, exp2) ->
+        Pexp_while (sub.expr sub exp1, sub.expr sub exp2)
+    | Texp_for (_id, name, exp1, exp2, dir, exp3) ->
+        Pexp_for (name,
+          sub.expr sub exp1, sub.expr sub exp2,
+          dir, sub.expr sub exp3)
+    | Texp_send (exp, meth, _) ->
+        Pexp_send (sub.expr sub exp, match meth with
+            Tmeth_name name -> mkloc name loc
+          | Tmeth_val id -> mkloc (Ident.name id) loc)
+    | Texp_new (_path, lid, _) -> Pexp_new (map_loc sub lid)
+    | Texp_instvar (_, path, name) ->
+      Pexp_ident ({loc = sub.location sub name.loc ; txt = lident_of_path path})
+    | Texp_setinstvar (_, _path, lid, exp) ->
+        Pexp_setinstvar (map_loc sub lid, sub.expr sub exp)
+    | Texp_override (_, list) ->
+        Pexp_override (List.map (fun (_path, lid, exp) ->
+              (map_loc sub lid, sub.expr sub exp)
+          ) list)
+    | Texp_letmodule (_id, name, _pres, mexpr, exp) ->
+        Pexp_letmodule (name, sub.module_expr sub mexpr,
+          sub.expr sub exp)
+    | Texp_letexception (ext, exp) ->
+        Pexp_letexception (sub.extension_constructor sub ext,
+                           sub.expr sub exp)
+    | Texp_assert exp -> Pexp_assert (sub.expr sub exp)
+    | Texp_lazy exp -> Pexp_lazy (sub.expr sub exp)
+    | Texp_object (cl, _) ->
+        Pexp_object (sub.class_structure sub cl)
+    | Texp_pack (mexpr) ->
+        Pexp_pack (sub.module_expr sub mexpr)
+    | Texp_letop {let_; ands; body; _} ->
+        let pat, and_pats =
+          extract_letop_patterns (List.length ands) body.c_lhs
+        in
+        let let_ = sub.binding_op sub let_ pat in
+        let ands = List.map2 (sub.binding_op sub) ands and_pats in
+        let body = sub.expr sub body.c_rhs in
+        Pexp_letop {let_; ands; body }
+    | Texp_unreachable ->
+        Pexp_unreachable
+    | Texp_extension_constructor (lid, _) ->
+        Pexp_extension ({ txt = "ocaml.extension_constructor"; loc },
+                        PStr [ Str.eval ~loc
+                                 (Exp.construct ~loc (map_loc sub lid) None)
+                             ])
+    | Texp_open (od, exp) ->
+        Pexp_open (sub.open_declaration sub od, sub.expr sub exp)
+  in
+  List.fold_right (exp_extra sub) exp.exp_extra
+    (Exp.mk ~loc ~attrs desc)
+
+let binding_op sub bop pat =
+  let pbop_op = bop.bop_op_name in
+  let pbop_pat = sub.pat sub pat in
+  let pbop_exp = sub.expr sub bop.bop_exp in
+  let pbop_loc = bop.bop_loc in
+  {pbop_op; pbop_pat; pbop_exp; pbop_loc}
+
+let package_type sub pack =
+  (map_loc sub pack.pack_txt,
+    List.map (fun (s, ct) ->
+        (s, sub.typ sub ct)) pack.pack_fields)
+
+let module_type_declaration sub mtd =
+  let loc = sub.location sub mtd.mtd_loc in
+  let attrs = sub.attributes sub mtd.mtd_attributes in
+  Mtd.mk ~loc ~attrs
+    ?typ:(Option.map (sub.module_type sub) mtd.mtd_type)
+    (map_loc sub mtd.mtd_name)
+
+let signature sub sg =
+  List.map (sub.signature_item sub) sg.sig_items
+
+let signature_item sub item =
+  let loc = sub.location sub item.sig_loc in
+  let desc =
+    match item.sig_desc with
+      Tsig_value v ->
+        Psig_value (sub.value_description sub v)
+    | Tsig_type (rec_flag, list) ->
+        Psig_type (rec_flag, List.map (sub.type_declaration sub) list)
+    | Tsig_typesubst list ->
+        Psig_typesubst (List.map (sub.type_declaration sub) list)
+    | Tsig_typext tyext ->
+        Psig_typext (sub.type_extension sub tyext)
+    | Tsig_exception ext ->
+        Psig_exception (sub.type_exception sub ext)
+    | Tsig_module md ->
+        Psig_module (sub.module_declaration sub md)
+    | Tsig_modsubst ms ->
+        Psig_modsubst (sub.module_substitution sub ms)
+    | Tsig_recmodule list ->
+        Psig_recmodule (List.map (sub.module_declaration sub) list)
+    | Tsig_modtype mtd ->
+        Psig_modtype (sub.module_type_declaration sub mtd)
+    | Tsig_open od ->
+        Psig_open (sub.open_description sub od)
+    | Tsig_include incl ->
+        Psig_include (sub.include_description sub incl)
+    | Tsig_class list ->
+        Psig_class (List.map (sub.class_description sub) list)
+    | Tsig_class_type list ->
+        Psig_class_type (List.map (sub.class_type_declaration sub) list)
+    | Tsig_attribute x ->
+        Psig_attribute x
+  in
+  Sig.mk ~loc desc
+
+let module_declaration sub md =
+  let loc = sub.location sub md.md_loc in
+  let attrs = sub.attributes sub md.md_attributes in
+  Md.mk ~loc ~attrs
+    (map_loc sub md.md_name)
+    (sub.module_type sub md.md_type)
+
+let module_substitution sub ms =
+  let loc = sub.location sub ms.ms_loc in
+  let attrs = sub.attributes sub ms.ms_attributes in
+  Ms.mk ~loc ~attrs
+    (map_loc sub ms.ms_name)
+    (map_loc sub ms.ms_txt)
+
+let include_infos f sub incl =
+  let loc = sub.location sub incl.incl_loc in
+  let attrs = sub.attributes sub incl.incl_attributes in
+  Incl.mk ~loc ~attrs
+    (f sub incl.incl_mod)
+
+let include_declaration sub = include_infos sub.module_expr sub
+let include_description sub = include_infos sub.module_type sub
+
+let class_infos f sub ci =
+  let loc = sub.location sub ci.ci_loc in
+  let attrs = sub.attributes sub ci.ci_attributes in
+  Ci.mk ~loc ~attrs
+    ~virt:ci.ci_virt
+    ~params:(List.map (type_parameter sub) ci.ci_params)
+    (map_loc sub ci.ci_id_name)
+    (f sub ci.ci_expr)
+
+let class_declaration sub = class_infos sub.class_expr sub
+let class_description sub = class_infos sub.class_type sub
+let class_type_declaration sub = class_infos sub.class_type sub
+
+let functor_parameter sub : functor_parameter -> Parsetree.functor_parameter =
+  function
+  | Unit -> Unit
+  | Named (_, name, mtype) -> Named (name, sub.module_type sub mtype)
+
+let module_type sub mty =
+  let loc = sub.location sub mty.mty_loc in
+  let attrs = sub.attributes sub mty.mty_attributes in
+  let desc = match mty.mty_desc with
+      Tmty_ident (_path, lid) -> Pmty_ident (map_loc sub lid)
+    | Tmty_alias (_path, lid) -> Pmty_alias (map_loc sub lid)
+    | Tmty_signature sg -> Pmty_signature (sub.signature sub sg)
+    | Tmty_functor (arg, mtype2) ->
+        Pmty_functor (functor_parameter sub arg, sub.module_type sub mtype2)
+    | Tmty_with (mtype, list) ->
+        Pmty_with (sub.module_type sub mtype,
+          List.map (sub.with_constraint sub) list)
+    | Tmty_typeof mexpr ->
+        Pmty_typeof (sub.module_expr sub mexpr)
+  in
+  Mty.mk ~loc ~attrs desc
+
+let with_constraint sub (_path, lid, cstr) =
+  match cstr with
+  | Twith_type decl ->
+      Pwith_type (map_loc sub lid, sub.type_declaration sub decl)
+  | Twith_module (_path, lid2) ->
+      Pwith_module (map_loc sub lid, map_loc sub lid2)
+  | Twith_typesubst decl ->
+     Pwith_typesubst (map_loc sub lid, sub.type_declaration sub decl)
+  | Twith_modsubst (_path, lid2) ->
+      Pwith_modsubst (map_loc sub lid, map_loc sub lid2)
+
+let module_expr sub mexpr =
+  let loc = sub.location sub mexpr.mod_loc in
+  let attrs = sub.attributes sub mexpr.mod_attributes in
+  match mexpr.mod_desc with
+      Tmod_constraint (m, _, Tmodtype_implicit, _ ) ->
+        sub.module_expr sub m
+    | _ ->
+        let desc = match mexpr.mod_desc with
+            Tmod_ident (_p, lid) -> Pmod_ident (map_loc sub lid)
+          | Tmod_structure st -> Pmod_structure (sub.structure sub st)
+          | Tmod_functor (arg, mexpr) ->
+              Pmod_functor
+                (functor_parameter sub arg, sub.module_expr sub mexpr)
+          | Tmod_apply (mexp1, mexp2, _) ->
+              Pmod_apply (sub.module_expr sub mexp1, sub.module_expr sub mexp2)
+          | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) ->
+              Pmod_constraint (sub.module_expr sub mexpr,
+                sub.module_type sub mtype)
+          | Tmod_constraint (_mexpr, _, Tmodtype_implicit, _) ->
+              assert false
+          | Tmod_unpack (exp, _pack) ->
+              Pmod_unpack (sub.expr sub exp)
+              (* TODO , sub.package_type sub pack) *)
+        in
+        Mod.mk ~loc ~attrs desc
+
+let class_expr sub cexpr =
+  let loc = sub.location sub cexpr.cl_loc in
+  let attrs = sub.attributes sub cexpr.cl_attributes in
+  let desc = match cexpr.cl_desc with
+    | Tcl_constraint ( { cl_desc = Tcl_ident (_path, lid, tyl); _ },
+                       None, _, _, _ ) ->
+        Pcl_constr (map_loc sub lid,
+          List.map (sub.typ sub) tyl)
+    | Tcl_structure clstr -> Pcl_structure (sub.class_structure sub clstr)
+
+    | Tcl_fun (label, pat, _pv, cl, _partial) ->
+        Pcl_fun (label, None, sub.pat sub pat, sub.class_expr sub cl)
+
+    | Tcl_apply (cl, args) ->
+        Pcl_apply (sub.class_expr sub cl,
+          List.fold_right (fun (label, expo) list ->
+              match expo with
+                None -> list
+              | Some exp -> (label, sub.expr sub exp) :: list
+          ) args [])
+
+    | Tcl_let (rec_flat, bindings, _ivars, cl) ->
+        Pcl_let (rec_flat,
+          List.map (sub.value_binding sub) bindings,
+          sub.class_expr sub cl)
+
+    | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) ->
+        Pcl_constraint (sub.class_expr sub cl,  sub.class_type sub clty)
+
+    | Tcl_open (od, e) ->
+        Pcl_open (sub.open_description sub od, sub.class_expr sub e)
+
+    | Tcl_ident _ -> assert false
+    | Tcl_constraint (_, None, _, _, _) -> assert false
+  in
+  Cl.mk ~loc ~attrs desc
+
+let class_type sub ct =
+  let loc = sub.location sub ct.cltyp_loc in
+  let attrs = sub.attributes sub ct.cltyp_attributes in
+  let desc = match ct.cltyp_desc with
+      Tcty_signature csg -> Pcty_signature (sub.class_signature sub csg)
+    | Tcty_constr (_path, lid, list) ->
+        Pcty_constr (map_loc sub lid, List.map (sub.typ sub) list)
+    | Tcty_arrow (label, ct, cl) ->
+        Pcty_arrow (label, sub.typ sub ct, sub.class_type sub cl)
+    | Tcty_open (od, e) ->
+        Pcty_open (sub.open_description sub od, sub.class_type sub e)
+  in
+  Cty.mk ~loc ~attrs desc
+
+let class_signature sub cs =
+  {
+    pcsig_self = sub.typ sub cs.csig_self;
+    pcsig_fields = List.map (sub.class_type_field sub) cs.csig_fields;
+  }
+
+let class_type_field sub ctf =
+  let loc = sub.location sub ctf.ctf_loc in
+  let attrs = sub.attributes sub ctf.ctf_attributes in
+  let desc = match ctf.ctf_desc with
+      Tctf_inherit ct -> Pctf_inherit (sub.class_type sub ct)
+    | Tctf_val (s, mut, virt, ct) ->
+        Pctf_val (mkloc s loc, mut, virt, sub.typ sub ct)
+    | Tctf_method  (s, priv, virt, ct) ->
+        Pctf_method  (mkloc s loc, priv, virt, sub.typ sub ct)
+    | Tctf_constraint  (ct1, ct2) ->
+        Pctf_constraint (sub.typ sub ct1, sub.typ sub ct2)
+    | Tctf_attribute x -> Pctf_attribute x
+  in
+  Ctf.mk ~loc ~attrs desc
+
+let core_type sub ct =
+  let loc = sub.location sub ct.ctyp_loc in
+  let attrs = sub.attributes sub ct.ctyp_attributes in
+  let desc = match ct.ctyp_desc with
+      Ttyp_any -> Ptyp_any
+    | Ttyp_var s -> Ptyp_var s
+    | Ttyp_arrow (label, ct1, ct2) ->
+        Ptyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2)
+    | Ttyp_tuple list -> Ptyp_tuple (List.map (sub.typ sub) list)
+    | Ttyp_constr (_path, lid, list) ->
+        Ptyp_constr (map_loc sub lid,
+          List.map (sub.typ sub) list)
+    | Ttyp_object (list, o) ->
+        Ptyp_object
+          (List.map (sub.object_field sub) list, o)
+    | Ttyp_class (_path, lid, list) ->
+        Ptyp_class (map_loc sub lid, List.map (sub.typ sub) list)
+    | Ttyp_alias (ct, s) ->
+        Ptyp_alias (sub.typ sub ct, s)
+    | Ttyp_variant (list, bool, labels) ->
+        Ptyp_variant (List.map (sub.row_field sub) list, bool, labels)
+    | Ttyp_poly (list, ct) ->
+        let list = List.map (fun v -> mkloc v loc) list in
+        Ptyp_poly (list, sub.typ sub ct)
+    | Ttyp_package pack -> Ptyp_package (sub.package_type sub pack)
+  in
+  Typ.mk ~loc ~attrs desc
+
+let class_structure sub cs =
+  let rec remove_self = function
+    | { pat_desc = Tpat_alias (p, id, _s) }
+      when string_is_prefix "selfpat-" (Ident.name id) ->
+        remove_self p
+    | p -> p
+  in
+  { pcstr_self = sub.pat sub (remove_self cs.cstr_self);
+    pcstr_fields = List.map (sub.class_field sub) cs.cstr_fields;
+  }
+
+let row_field sub {rf_loc; rf_desc; rf_attributes;} =
+  let loc = sub.location sub rf_loc in
+  let attrs = sub.attributes sub rf_attributes in
+  let desc = match rf_desc with
+    | Ttag (label, bool, list) ->
+        Rtag (label, bool, List.map (sub.typ sub) list)
+    | Tinherit ct -> Rinherit (sub.typ sub ct)
+  in
+  Rf.mk ~loc ~attrs desc
+
+let object_field sub {of_loc; of_desc; of_attributes;} =
+  let loc = sub.location sub of_loc in
+  let attrs = sub.attributes sub of_attributes in
+  let desc = match of_desc with
+    | OTtag (label, ct) ->
+        Otag (label, sub.typ sub ct)
+    | OTinherit ct -> Oinherit (sub.typ sub ct)
+  in
+  Of.mk ~loc ~attrs desc
+
+and is_self_pat = function
+  | { pat_desc = Tpat_alias(_pat, id, _) } ->
+      string_is_prefix "self-" (Ident.name id)
+  | _ -> false
+
+let class_field sub cf =
+  let loc = sub.location sub cf.cf_loc in
+  let attrs = sub.attributes sub cf.cf_attributes in
+  let desc = match cf.cf_desc with
+      Tcf_inherit (ovf, cl, super, _vals, _meths) ->
+        Pcf_inherit (ovf, sub.class_expr sub cl,
+                     Option.map (fun v -> mkloc v loc) super)
+    | Tcf_constraint (cty, cty') ->
+        Pcf_constraint (sub.typ sub cty, sub.typ sub cty')
+    | Tcf_val (lab, mut, _, Tcfk_virtual cty, _) ->
+        Pcf_val (lab, mut, Cfk_virtual (sub.typ sub cty))
+    | Tcf_val (lab, mut, _, Tcfk_concrete (o, exp), _) ->
+        Pcf_val (lab, mut, Cfk_concrete (o, sub.expr sub exp))
+    | Tcf_method (lab, priv, Tcfk_virtual cty) ->
+        Pcf_method (lab, priv, Cfk_virtual (sub.typ sub cty))
+    | Tcf_method (lab, priv, Tcfk_concrete (o, exp)) ->
+        let remove_fun_self = function
+          | { exp_desc =
+              Texp_function { arg_label = Nolabel; cases = [case]; _ } }
+            when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs
+          | e -> e
+        in
+        let exp = remove_fun_self exp in
+        Pcf_method (lab, priv, Cfk_concrete (o, sub.expr sub exp))
+    | Tcf_initializer exp ->
+        let remove_fun_self = function
+          | { exp_desc =
+              Texp_function { arg_label = Nolabel; cases = [case]; _ } }
+            when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs
+          | e -> e
+        in
+        let exp = remove_fun_self exp in
+        Pcf_initializer (sub.expr sub exp)
+    | Tcf_attribute x -> Pcf_attribute x
+  in
+  Cf.mk ~loc ~attrs desc
+
+let location _sub l = l
+
+let default_mapper =
+  {
+    attribute = attribute;
+    attributes = attributes;
+    binding_op = binding_op;
+    structure = structure;
+    structure_item = structure_item;
+    module_expr = module_expr;
+    signature = signature;
+    signature_item = signature_item;
+    module_type = module_type;
+    with_constraint = with_constraint;
+    class_declaration = class_declaration;
+    class_expr = class_expr;
+    class_field = class_field;
+    class_structure = class_structure;
+    class_type = class_type;
+    class_type_field = class_type_field;
+    class_signature = class_signature;
+    class_type_declaration = class_type_declaration;
+    class_description = class_description;
+    type_declaration = type_declaration;
+    type_kind = type_kind;
+    typ = core_type;
+    type_extension = type_extension;
+    type_exception = type_exception;
+    extension_constructor = extension_constructor;
+    value_description = value_description;
+    pat = pattern;
+    expr = expression;
+    module_declaration = module_declaration;
+    module_substitution = module_substitution;
+    module_type_declaration = module_type_declaration;
+    module_binding = module_binding;
+    package_type = package_type ;
+    open_declaration = open_declaration;
+    open_description = open_description;
+    include_description = include_description;
+    include_declaration = include_declaration;
+    value_binding = value_binding;
+    constructor_declaration = constructor_declaration;
+    label_declaration = label_declaration;
+    case = case;
+    location = location;
+    row_field = row_field ;
+    object_field = object_field ;
+  }
+
+let untype_structure ?(mapper=default_mapper) structure =
+  mapper.structure mapper structure
+
+let untype_signature ?(mapper=default_mapper) signature =
+  mapper.signature mapper signature
diff --git a/upstream/ocaml_411/typing/untypeast.mli b/upstream/ocaml_411/typing/untypeast.mli
new file mode 100644
index 0000000..d8a0151
--- /dev/null
+++ b/upstream/ocaml_411/typing/untypeast.mli
@@ -0,0 +1,85 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*      Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay)   *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Parsetree
+
+val lident_of_path : Path.t -> Longident.t
+
+type mapper = {
+  attribute: mapper -> Typedtree.attribute -> attribute;
+  attributes: mapper -> Typedtree.attribute list -> attribute list;
+  binding_op:
+    mapper ->
+    Typedtree.binding_op -> Typedtree.pattern -> binding_op;
+  case: 'k . mapper -> 'k Typedtree.case -> case;
+  class_declaration: mapper -> Typedtree.class_declaration -> class_declaration;
+  class_description: mapper -> Typedtree.class_description -> class_description;
+  class_expr: mapper -> Typedtree.class_expr -> class_expr;
+  class_field: mapper -> Typedtree.class_field -> class_field;
+  class_signature: mapper -> Typedtree.class_signature -> class_signature;
+  class_structure: mapper -> Typedtree.class_structure -> class_structure;
+  class_type: mapper -> Typedtree.class_type -> class_type;
+  class_type_declaration: mapper -> Typedtree.class_type_declaration
+                          -> class_type_declaration;
+  class_type_field: mapper -> Typedtree.class_type_field -> class_type_field;
+  constructor_declaration: mapper -> Typedtree.constructor_declaration
+                           -> constructor_declaration;
+  expr: mapper -> Typedtree.expression -> expression;
+  extension_constructor: mapper -> Typedtree.extension_constructor
+                         -> extension_constructor;
+  include_declaration:
+    mapper -> Typedtree.include_declaration -> include_declaration;
+  include_description:
+    mapper -> Typedtree.include_description -> include_description;
+  label_declaration:
+    mapper -> Typedtree.label_declaration -> label_declaration;
+  location: mapper -> Location.t -> Location.t;
+  module_binding: mapper -> Typedtree.module_binding -> module_binding;
+  module_declaration:
+    mapper -> Typedtree.module_declaration -> module_declaration;
+  module_substitution:
+    mapper -> Typedtree.module_substitution -> module_substitution;
+  module_expr: mapper -> Typedtree.module_expr -> module_expr;
+  module_type: mapper -> Typedtree.module_type -> module_type;
+  module_type_declaration:
+    mapper -> Typedtree.module_type_declaration -> module_type_declaration;
+  package_type: mapper -> Typedtree.package_type -> package_type;
+  open_declaration: mapper -> Typedtree.open_declaration -> open_declaration;
+  open_description: mapper -> Typedtree.open_description -> open_description;
+  pat: 'k . mapper -> 'k Typedtree.general_pattern -> pattern;
+  row_field: mapper -> Typedtree.row_field -> row_field;
+  object_field: mapper -> Typedtree.object_field -> object_field;
+  signature: mapper -> Typedtree.signature -> signature;
+  signature_item: mapper -> Typedtree.signature_item -> signature_item;
+  structure: mapper -> Typedtree.structure -> structure;
+  structure_item: mapper -> Typedtree.structure_item -> structure_item;
+  typ: mapper -> Typedtree.core_type -> core_type;
+  type_declaration: mapper -> Typedtree.type_declaration -> type_declaration;
+  type_extension: mapper -> Typedtree.type_extension -> type_extension;
+  type_exception: mapper -> Typedtree.type_exception -> type_exception;
+  type_kind: mapper -> Typedtree.type_kind -> type_kind;
+  value_binding: mapper -> Typedtree.value_binding -> value_binding;
+  value_description: mapper -> Typedtree.value_description -> value_description;
+  with_constraint:
+    mapper -> (Path.t * Longident.t Location.loc * Typedtree.with_constraint)
+    -> with_constraint;
+}
+
+val default_mapper : mapper
+
+val untype_structure : ?mapper:mapper -> Typedtree.structure -> structure
+val untype_signature : ?mapper:mapper -> Typedtree.signature -> signature
+
+val constant : Asttypes.constant -> Parsetree.constant
diff --git a/upstream/ocaml_411/utils/arg_helper.ml b/upstream/ocaml_411/utils/arg_helper.ml
new file mode 100644
index 0000000..fa80007
--- /dev/null
+++ b/upstream/ocaml_411/utils/arg_helper.ml
@@ -0,0 +1,127 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2015--2016 OCamlPro SAS                                    *)
+(*   Copyright 2015--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+let fatal err =
+  prerr_endline err;
+  exit 2
+
+module Make (S : sig
+  module Key : sig
+    type t
+    val of_string : string -> t
+    module Map : Map.S with type key = t
+  end
+
+  module Value : sig
+    type t
+    val of_string : string -> t
+  end
+end) = struct
+  type parsed = {
+    base_default : S.Value.t;
+    base_override : S.Value.t S.Key.Map.t;
+    user_default : S.Value.t option;
+    user_override : S.Value.t S.Key.Map.t;
+  }
+
+  let default v =
+    { base_default = v;
+      base_override = S.Key.Map.empty;
+      user_default = None;
+      user_override = S.Key.Map.empty; }
+
+  let set_base_default value t =
+    { t with base_default = value }
+
+  let add_base_override key value t =
+    { t with base_override = S.Key.Map.add key value t.base_override }
+
+  let reset_base_overrides t =
+    { t with base_override = S.Key.Map.empty }
+
+  let set_user_default value t =
+    { t with user_default = Some value }
+
+  let add_user_override key value t =
+    { t with user_override = S.Key.Map.add key value t.user_override }
+
+  exception Parse_failure of exn
+
+  let parse_exn str ~update =
+    (* Is the removal of empty chunks really relevant here? *)
+    (* (It has been added to mimic the old Misc.String.split.) *)
+    let values = String.split_on_char ',' str |> List.filter ((<>) "") in
+    let parsed =
+      List.fold_left (fun acc value ->
+          match String.index value '=' with
+          | exception Not_found ->
+            begin match S.Value.of_string value with
+            | value -> set_user_default value acc
+            | exception exn -> raise (Parse_failure exn)
+            end
+          | equals ->
+            let key_value_pair = value in
+            let length = String.length key_value_pair in
+            assert (equals >= 0 && equals < length);
+            if equals = 0 then begin
+              raise (Parse_failure (
+                Failure "Missing key in argument specification"))
+            end;
+            let key =
+              let key = String.sub key_value_pair 0 equals in
+              try S.Key.of_string key
+              with exn -> raise (Parse_failure exn)
+            in
+            let value =
+              let value =
+                String.sub key_value_pair (equals + 1) (length - equals - 1)
+              in
+              try S.Value.of_string value
+              with exn -> raise (Parse_failure exn)
+            in
+            add_user_override key value acc)
+        !update
+        values
+    in
+    update := parsed
+
+  let parse str help_text update =
+    match parse_exn str ~update with
+    | () -> ()
+    | exception (Parse_failure exn) ->
+      fatal (Printf.sprintf "%s: %s" (Printexc.to_string exn) help_text)
+
+  type parse_result =
+    | Ok
+    | Parse_failed of exn
+
+  let parse_no_error str update =
+    match parse_exn str ~update with
+    | () -> Ok
+    | exception (Parse_failure exn) -> Parse_failed exn
+
+  let get ~key parsed =
+    match S.Key.Map.find key parsed.user_override with
+    | value -> value
+    | exception Not_found ->
+      match parsed.user_default with
+      | Some value -> value
+      | None ->
+        match S.Key.Map.find key parsed.base_override with
+        | value -> value
+        | exception Not_found -> parsed.base_default
+
+end
diff --git a/upstream/ocaml_411/utils/arg_helper.mli b/upstream/ocaml_411/utils/arg_helper.mli
new file mode 100644
index 0000000..18f60fe
--- /dev/null
+++ b/upstream/ocaml_411/utils/arg_helper.mli
@@ -0,0 +1,68 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2015--2016 OCamlPro SAS                                    *)
+(*   Copyright 2015--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Decipher command line arguments of the form
+        <value> | <key>=<value>[,...]
+
+    (as used for example for the specification of inlining parameters
+    varying by simplification round).
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+module Make (S : sig
+  module Key : sig
+    type t
+
+    (** The textual representation of a key must not contain '=' or ','. *)
+    val of_string : string -> t
+
+    module Map : Map.S with type key = t
+  end
+
+  module Value : sig
+    type t
+
+    (** The textual representation of a value must not contain ','. *)
+    val of_string : string -> t
+  end
+end) : sig
+  type parsed
+
+  val default : S.Value.t -> parsed
+
+  val set_base_default : S.Value.t -> parsed -> parsed
+
+  val add_base_override : S.Key.t -> S.Value.t -> parsed -> parsed
+
+  val reset_base_overrides : parsed -> parsed
+
+  val set_user_default : S.Value.t -> parsed -> parsed
+
+  val add_user_override : S.Key.t -> S.Value.t -> parsed -> parsed
+
+  val parse : string -> string -> parsed ref -> unit
+
+  type parse_result =
+    | Ok
+    | Parse_failed of exn
+
+  val parse_no_error : string -> parsed ref -> parse_result
+
+  val get : key:S.Key.t -> parsed -> S.Value.t
+end
diff --git a/upstream/ocaml_411/utils/build_path_prefix_map.ml b/upstream/ocaml_411/utils/build_path_prefix_map.ml
new file mode 100644
index 0000000..c204d3a
--- /dev/null
+++ b/upstream/ocaml_411/utils/build_path_prefix_map.ml
@@ -0,0 +1,119 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*            Gabriel Scherer, projet Parsifal, INRIA Saclay              *)
+(*                                                                        *)
+(*   Copyright 2017 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type path = string
+type path_prefix = string
+type error_message = string
+
+let errorf fmt = Printf.kprintf (fun err -> Error err) fmt
+
+let encode_prefix str =
+  let buf = Buffer.create (String.length str) in
+  let push_char = function
+    | '%' -> Buffer.add_string buf "%#"
+    | '=' -> Buffer.add_string buf "%+"
+    | ':' -> Buffer.add_string buf "%."
+    | c -> Buffer.add_char buf c
+  in
+  String.iter push_char str;
+  Buffer.contents buf
+
+let decode_prefix str =
+  let buf = Buffer.create (String.length str) in
+  let rec loop i =
+    if i >= String.length str
+    then Ok (Buffer.contents buf)
+    else match str.[i] with
+      | ('=' | ':') as c ->
+        errorf "invalid character '%c' in key or value" c
+      | '%' ->
+        let push c = Buffer.add_char buf c; loop (i + 2) in
+        if i + 1 = String.length str then
+          errorf "invalid encoded string %S (trailing '%%')" str
+        else begin match str.[i + 1] with
+            | '#' -> push '%'
+            | '+' -> push '='
+            | '.' -> push ':'
+            | c -> errorf "invalid %%-escaped character '%c'" c
+        end
+      | c ->
+        Buffer.add_char buf c;
+        loop (i + 1)
+  in loop 0
+
+type pair = { target: path_prefix; source : path_prefix }
+
+let encode_pair { target; source } =
+  String.concat "=" [encode_prefix target; encode_prefix source]
+
+let decode_pair str =
+  match String.index str '=' with
+  | exception Not_found ->
+    errorf "invalid key/value pair %S, no '=' separator" str
+  | equal_pos ->
+    let encoded_target = String.sub str 0 equal_pos in
+    let encoded_source =
+      String.sub str (equal_pos + 1) (String.length str - equal_pos - 1) in
+    match decode_prefix encoded_target, decode_prefix encoded_source with
+    | Ok target, Ok source -> Ok { target; source }
+    | ((Error _ as err), _) | (_, (Error _ as err)) -> err
+
+type map = pair option list
+
+let encode_map map =
+  let encode_elem = function
+    | None -> ""
+    | Some pair -> encode_pair pair
+  in
+  List.map encode_elem map
+  |> String.concat ":"
+
+let decode_map str =
+  let exception Shortcut of error_message in
+  let decode_or_empty = function
+    | "" -> None
+    | pair ->
+      begin match decode_pair pair with
+        | Ok str -> Some str
+        | Error err -> raise (Shortcut err)
+      end
+  in
+  let pairs = String.split_on_char ':' str in
+  match List.map decode_or_empty pairs with
+  | exception (Shortcut err) -> Error err
+  | map -> Ok map
+
+let rewrite_opt prefix_map path =
+  let is_prefix = function
+    | None -> false
+    | Some { target = _; source } ->
+      String.length source <= String.length path
+      && String.equal source (String.sub path 0 (String.length source))
+  in
+  match
+    List.find is_prefix
+      (* read key/value pairs from right to left, as the spec demands *)
+      (List.rev prefix_map)
+  with
+  | exception Not_found -> None
+  | None -> None
+  | Some { source; target } ->
+      Some (target ^ (String.sub path (String.length source)
+                       (String.length path - String.length source)))
+
+let rewrite prefix_map path =
+  match rewrite_opt prefix_map path with
+  | None -> path
+  | Some path -> path
diff --git a/upstream/ocaml_411/utils/build_path_prefix_map.mli b/upstream/ocaml_411/utils/build_path_prefix_map.mli
new file mode 100644
index 0000000..dbcc8dc
--- /dev/null
+++ b/upstream/ocaml_411/utils/build_path_prefix_map.mli
@@ -0,0 +1,47 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*            Gabriel Scherer, projet Parsifal, INRIA Saclay              *)
+(*                                                                        *)
+(*   Copyright 2017 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Rewrite paths for reproducible builds
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+
+type path = string
+type path_prefix = string
+type error_message = string
+
+val encode_prefix : path_prefix -> string
+val decode_prefix : string -> (path_prefix, error_message) result
+
+type pair = { target: path_prefix; source : path_prefix }
+
+val encode_pair : pair -> string
+val decode_pair : string -> (pair, error_message) result
+
+type map = pair option list
+
+val encode_map : map -> string
+val decode_map : string -> (map, error_message) result
+
+val rewrite_opt : map -> path -> path option
+(** [rewrite_opt map path] tries to find a source in [map]
+    that is a prefix of the input [path]. If it succeeds,
+    it replaces this prefix with the corresponding target.
+    If it fails, it just returns [None]. *)
+
+val rewrite : map -> path -> path
diff --git a/upstream/ocaml_411/utils/ccomp.ml b/upstream/ocaml_411/utils/ccomp.ml
new file mode 100644
index 0000000..2de6bb1
--- /dev/null
+++ b/upstream/ocaml_411/utils/ccomp.ml
@@ -0,0 +1,226 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Compiling C files and building C libraries *)
+
+let command cmdline =
+  if !Clflags.verbose then begin
+    prerr_string "+ ";
+    prerr_string cmdline;
+    prerr_newline()
+  end;
+  let res = Sys.command cmdline in
+  if res = 127 then raise (Sys_error cmdline);
+  res
+
+let run_command cmdline = ignore(command cmdline)
+
+(* Build @responsefile to work around OS limitations on
+   command-line length.
+   Under Windows, the max length is 8187 minus the length of the
+   COMSPEC variable (or 7 if it's not set).  To be on the safe side,
+   we'll use a response file if we need to pass 4096 or more bytes of
+   arguments.
+   For Unix-like systems, the threshold is 2^16 (64 KiB), which is
+   within the lowest observed limits (2^17 per argument under Linux;
+   between 70000 and 80000 for macOS).
+*)
+
+let build_diversion lst =
+  let (responsefile, oc) = Filename.open_temp_file "camlresp" "" in
+  List.iter (fun f -> Printf.fprintf oc "%s\n" f) lst;
+  close_out oc;
+  at_exit (fun () -> Misc.remove_file responsefile);
+  "@" ^ responsefile
+
+let quote_files lst =
+  let lst = List.filter (fun f -> f <> "") lst in
+  let quoted = List.map Filename.quote lst in
+  let s = String.concat " " quoted in
+  if String.length s >= 65536
+  || (String.length s >= 4096 && Sys.os_type = "Win32")
+  then build_diversion quoted
+  else s
+
+let quote_prefixed pr lst =
+  let lst = List.filter (fun f -> f <> "") lst in
+  let lst = List.map (fun f -> pr ^ f) lst in
+  quote_files lst
+
+let quote_optfile = function
+  | None -> ""
+  | Some f -> Filename.quote f
+
+let display_msvc_output file name =
+  let c = open_in file in
+  try
+    let first = input_line c in
+    if first <> Filename.basename name then
+      print_endline first;
+    while true do
+      print_endline (input_line c)
+    done
+  with _ ->
+    close_in c;
+    Sys.remove file
+
+let compile_file ?output ?(opt="") ?stable_name name =
+  let (pipe, file) =
+    if Config.ccomp_type = "msvc" && not !Clflags.verbose then
+      try
+        let (t, c) = Filename.open_temp_file "msvc" "stdout" in
+        close_out c;
+        (Printf.sprintf " > %s" (Filename.quote t), t)
+      with _ ->
+        ("", "")
+    else
+      ("", "") in
+  let debug_prefix_map =
+    match stable_name with
+    | Some stable when Config.c_has_debug_prefix_map ->
+      Printf.sprintf " -fdebug-prefix-map=%s=%s" name stable
+    | Some _ | None -> "" in
+  let exit =
+    command
+      (Printf.sprintf
+         "%s%s %s %s -c %s %s %s %s %s%s"
+         (match !Clflags.c_compiler with
+          | Some cc -> cc
+          | None ->
+              (* #7678: ocamlopt only calls the C compiler to process .c files
+                 from the command line, and the behaviour between
+                 ocamlc/ocamlopt should be identical. *)
+              (String.concat " " [Config.c_compiler;
+                                  Config.ocamlc_cflags;
+                                  Config.ocamlc_cppflags]))
+         debug_prefix_map
+         (match output with
+          | None -> ""
+          | Some o -> Printf.sprintf "%s%s" Config.c_output_obj o)
+         opt
+         (if !Clflags.debug && Config.ccomp_type <> "msvc" then "-g" else "")
+         (String.concat " " (List.rev !Clflags.all_ccopts))
+         (quote_prefixed "-I"
+            (List.map (Misc.expand_directory Config.standard_library)
+               (List.rev !Clflags.include_dirs)))
+         (Clflags.std_include_flag "-I")
+         (Filename.quote name)
+         (* cl tediously includes the name of the C file as the first thing it
+            outputs (in fairness, the tedious thing is that there's no switch to
+            disable this behaviour). In the absence of the Unix module, use
+            a temporary file to filter the output (cannot pipe the output to a
+            filter because this removes the exit status of cl, which is wanted.
+          *)
+         pipe) in
+  if pipe <> ""
+  then display_msvc_output file name;
+  exit
+
+let macos_create_empty_archive ~quoted_archive =
+  let result =
+    command (Printf.sprintf "%s rc %s /dev/null" Config.ar quoted_archive)
+  in
+  if result <> 0 then result
+  else
+    let result =
+      command (Printf.sprintf "%s %s 2> /dev/null" Config.ranlib quoted_archive)
+    in
+    if result <> 0 then result
+    else
+      command (Printf.sprintf "%s d %s /dev/null" Config.ar quoted_archive)
+
+let create_archive archive file_list =
+  Misc.remove_file archive;
+  let quoted_archive = Filename.quote archive in
+  match Config.ccomp_type with
+    "msvc" ->
+      command(Printf.sprintf "link /lib /nologo /out:%s %s"
+                             quoted_archive (quote_files file_list))
+  | _ ->
+      assert(String.length Config.ar > 0);
+      let is_macosx =
+        match Config.system with
+        | "macosx" -> true
+        | _ -> false
+      in
+      if is_macosx && file_list = [] then  (* PR#6550 *)
+        macos_create_empty_archive ~quoted_archive
+      else
+        let r1 =
+          command(Printf.sprintf "%s rc %s %s"
+                  Config.ar quoted_archive (quote_files file_list)) in
+        if r1 <> 0 || String.length Config.ranlib = 0
+        then r1
+        else command(Config.ranlib ^ " " ^ quoted_archive)
+
+let expand_libname name =
+  if String.length name < 2 || String.sub name 0 2 <> "-l"
+  then name
+  else begin
+    let libname =
+      "lib" ^ String.sub name 2 (String.length name - 2) ^ Config.ext_lib in
+    try
+      Load_path.find libname
+    with Not_found ->
+      libname
+  end
+
+type link_mode =
+  | Exe
+  | Dll
+  | MainDll
+  | Partial
+
+let remove_Wl cclibs =
+  cclibs |> List.map (fun cclib ->
+    (* -Wl,-foo,bar -> -foo bar *)
+    if String.length cclib >= 4 && "-Wl," = String.sub cclib 0 4 then
+      String.map (function ',' -> ' ' | c -> c)
+                 (String.sub cclib 4 (String.length cclib - 4))
+    else cclib)
+
+let call_linker mode output_name files extra =
+  Profile.record_call "c-linker" (fun () ->
+    let cmd =
+      if mode = Partial then
+        let l_prefix =
+          match Config.ccomp_type with
+          | "msvc" -> "/libpath:"
+          | _ -> "-L"
+        in
+        Printf.sprintf "%s%s %s %s %s"
+          Config.native_pack_linker
+          (Filename.quote output_name)
+          (quote_prefixed l_prefix (Load_path.get_paths ()))
+          (quote_files (remove_Wl files))
+          extra
+      else
+        Printf.sprintf "%s -o %s %s %s %s %s %s"
+          (match !Clflags.c_compiler, mode with
+          | Some cc, _ -> cc
+          | None, Exe -> Config.mkexe
+          | None, Dll -> Config.mkdll
+          | None, MainDll -> Config.mkmaindll
+          | None, Partial -> assert false
+          )
+          (Filename.quote output_name)
+          ""  (*(Clflags.std_include_flag "-I")*)
+          (quote_prefixed "-L" (Load_path.get_paths ()))
+          (String.concat " " (List.rev !Clflags.all_ccopts))
+          (quote_files files)
+          extra
+    in
+    command cmd
+  )
diff --git a/upstream/ocaml_411/utils/ccomp.mli b/upstream/ocaml_411/utils/ccomp.mli
new file mode 100644
index 0000000..8972425
--- /dev/null
+++ b/upstream/ocaml_411/utils/ccomp.mli
@@ -0,0 +1,39 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Compiling C files and building C libraries
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+val command: string -> int
+val run_command: string -> unit
+val compile_file:
+  ?output:string -> ?opt:string -> ?stable_name:string -> string -> int
+val create_archive: string -> string list -> int
+val expand_libname: string -> string
+val quote_files: string list -> string
+val quote_optfile: string option -> string
+(*val make_link_options: string list -> string*)
+
+type link_mode =
+  | Exe
+  | Dll
+  | MainDll
+  | Partial
+
+val call_linker: link_mode -> string -> string list -> string -> int
diff --git a/upstream/ocaml_411/utils/clflags.ml b/upstream/ocaml_411/utils/clflags.ml
new file mode 100644
index 0000000..4035c28
--- /dev/null
+++ b/upstream/ocaml_411/utils/clflags.ml
@@ -0,0 +1,504 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Command-line parameters *)
+
+module Int_arg_helper = Arg_helper.Make (struct
+  module Key = struct
+    include Numbers.Int
+    let of_string = int_of_string
+  end
+
+  module Value = struct
+    include Numbers.Int
+    let of_string = int_of_string
+  end
+end)
+module Float_arg_helper = Arg_helper.Make (struct
+  module Key = struct
+    include Numbers.Int
+    let of_string = int_of_string
+  end
+
+  module Value = struct
+    include Numbers.Float
+    let of_string = float_of_string
+  end
+end)
+
+let objfiles = ref ([] : string list)   (* .cmo and .cma files *)
+and ccobjs = ref ([] : string list)     (* .o, .a, .so and -cclib -lxxx *)
+and dllibs = ref ([] : string list)     (* .so and -dllib -lxxx *)
+
+let compile_only = ref false            (* -c *)
+and output_name = ref (None : string option) (* -o *)
+and include_dirs = ref ([] : string list)(* -I *)
+and no_std_include = ref false          (* -nostdlib *)
+and print_types = ref false             (* -i *)
+and make_archive = ref false            (* -a *)
+and debug = ref false                   (* -g *)
+and debug_full = ref false              (* For full DWARF support *)
+and unsafe = ref false                  (* -unsafe *)
+and use_linscan = ref false             (* -linscan *)
+and link_everything = ref false         (* -linkall *)
+and custom_runtime = ref false          (* -custom *)
+and no_check_prims = ref false          (* -no-check-prims *)
+and bytecode_compatible_32 = ref false  (* -compat-32 *)
+and output_c_object = ref false         (* -output-obj *)
+and output_complete_object = ref false  (* -output-complete-obj *)
+and output_complete_executable = ref false  (* -output-complete-exe *)
+and all_ccopts = ref ([] : string list)     (* -ccopt *)
+and classic = ref false                 (* -nolabels *)
+and nopervasives = ref false            (* -nopervasives *)
+and match_context_rows = ref 32         (* -match-context-rows *)
+and preprocessor = ref(None : string option) (* -pp *)
+and all_ppx = ref ([] : string list)        (* -ppx *)
+let absname = ref false                 (* -absname *)
+let annotations = ref false             (* -annot *)
+let binary_annotations = ref false      (* -annot *)
+and use_threads = ref false             (* -thread *)
+and noassert = ref false                (* -noassert *)
+and verbose = ref false                 (* -verbose *)
+and noversion = ref false               (* -no-version *)
+and noprompt = ref false                (* -noprompt *)
+and nopromptcont = ref false            (* -nopromptcont *)
+and init_file = ref (None : string option)   (* -init *)
+and noinit = ref false                  (* -noinit *)
+and open_modules = ref []               (* -open *)
+and use_prims = ref ""                  (* -use-prims ... *)
+and use_runtime = ref ""                (* -use-runtime ... *)
+and plugin = ref false                  (* -plugin ... *)
+and principal = ref false               (* -principal *)
+and real_paths = ref true               (* -short-paths *)
+and recursive_types = ref false         (* -rectypes *)
+and strict_sequence = ref false         (* -strict-sequence *)
+and strict_formats = ref false          (* -strict-formats *)
+and applicative_functors = ref true     (* -no-app-funct *)
+and make_runtime = ref false            (* -make-runtime *)
+and c_compiler = ref (None: string option) (* -cc *)
+and no_auto_link = ref false            (* -noautolink *)
+and dllpaths = ref ([] : string list)   (* -dllpath *)
+and make_package = ref false            (* -pack *)
+and for_package = ref (None: string option) (* -for-pack *)
+and error_size = ref 500                (* -error-size *)
+and float_const_prop = ref true         (* -no-float-const-prop *)
+and transparent_modules = ref false     (* -trans-mod *)
+let unique_ids = ref true               (* -d(no-)unique-ds *)
+let locations = ref true                (* -d(no-)locations *)
+let dump_source = ref false             (* -dsource *)
+let dump_parsetree = ref false          (* -dparsetree *)
+and dump_typedtree = ref false          (* -dtypedtree *)
+and dump_rawlambda = ref false          (* -drawlambda *)
+and dump_lambda = ref false             (* -dlambda *)
+and dump_rawclambda = ref false         (* -drawclambda *)
+and dump_clambda = ref false            (* -dclambda *)
+and dump_rawflambda = ref false            (* -drawflambda *)
+and dump_flambda = ref false            (* -dflambda *)
+and dump_flambda_let = ref (None : int option) (* -dflambda-let=... *)
+and dump_flambda_verbose = ref false    (* -dflambda-verbose *)
+and dump_instr = ref false              (* -dinstr *)
+and keep_camlprimc_file = ref false     (* -dcamlprimc *)
+
+let keep_asm_file = ref false           (* -S *)
+let optimize_for_speed = ref true       (* -compact *)
+and opaque = ref false                  (* -opaque *)
+
+and dump_cmm = ref false                (* -dcmm *)
+let dump_selection = ref false          (* -dsel *)
+let dump_cse = ref false                (* -dcse *)
+let dump_live = ref false               (* -dlive *)
+let dump_avail = ref false              (* -davail *)
+let dump_spill = ref false              (* -dspill *)
+let dump_split = ref false              (* -dsplit *)
+let dump_interf = ref false             (* -dinterf *)
+let dump_prefer = ref false             (* -dprefer *)
+let dump_regalloc = ref false           (* -dalloc *)
+let dump_reload = ref false             (* -dreload *)
+let dump_scheduling = ref false         (* -dscheduling *)
+let dump_linear = ref false             (* -dlinear *)
+let dump_interval = ref false           (* -dinterval *)
+let keep_startup_file = ref false       (* -dstartup *)
+let dump_combine = ref false            (* -dcombine *)
+let profile_columns : Profile.column list ref = ref [] (* -dprofile/-dtimings *)
+
+let debug_runavail = ref false          (* -drunavail *)
+
+let native_code = ref false             (* set to true under ocamlopt *)
+
+let force_slash = ref false             (* for ocamldep *)
+let clambda_checks = ref false          (* -clambda-checks *)
+
+let flambda_invariant_checks =
+  ref Config.with_flambda_invariants    (* -flambda-(no-)invariants *)
+
+let dont_write_files = ref false        (* set to true under ocamldoc *)
+
+let insn_sched_default = true
+let insn_sched = ref insn_sched_default (* -[no-]insn-sched *)
+
+let std_include_flag prefix =
+  if !no_std_include then ""
+  else (prefix ^ (Filename.quote Config.standard_library))
+;;
+
+let std_include_dir () =
+  if !no_std_include then [] else [Config.standard_library]
+;;
+
+let shared = ref false (* -shared *)
+let dlcode = ref true (* not -nodynlink *)
+
+let pic_code = ref (match Config.architecture with (* -fPIC *)
+                     | "amd64" -> true
+                     | _       -> false)
+
+let runtime_variant = ref "";;      (* -runtime-variant *)
+let with_runtime = ref true;;         (* -with-runtime *)
+
+let keep_docs = ref false              (* -keep-docs *)
+let keep_locs = ref true               (* -keep-locs *)
+let unsafe_string =
+  if Config.safe_string then ref false
+  else ref (not Config.default_safe_string)
+                                   (* -safe-string / -unsafe-string *)
+
+let classic_inlining = ref false       (* -Oclassic *)
+let inlining_report = ref false    (* -inlining-report *)
+
+let afl_instrument = ref Config.afl_instrument (* -afl-instrument *)
+let afl_inst_ratio = ref 100           (* -afl-inst-ratio *)
+
+let function_sections = ref false      (* -function-sections *)
+
+let simplify_rounds = ref None        (* -rounds *)
+let default_simplify_rounds = ref 1        (* -rounds *)
+let rounds () =
+  match !simplify_rounds with
+  | None -> !default_simplify_rounds
+  | Some r -> r
+
+let default_inline_threshold = if Config.flambda then 10. else 10. /. 8.
+let inline_toplevel_multiplier = 16
+let default_inline_toplevel_threshold =
+  int_of_float ((float inline_toplevel_multiplier) *. default_inline_threshold)
+let default_inline_call_cost = 5
+let default_inline_alloc_cost = 7
+let default_inline_prim_cost = 3
+let default_inline_branch_cost = 5
+let default_inline_indirect_cost = 4
+let default_inline_branch_factor = 0.1
+let default_inline_lifting_benefit = 1300
+let default_inline_max_unroll = 0
+let default_inline_max_depth = 1
+
+let inline_threshold = ref (Float_arg_helper.default default_inline_threshold)
+let inline_toplevel_threshold =
+  ref (Int_arg_helper.default default_inline_toplevel_threshold)
+let inline_call_cost = ref (Int_arg_helper.default default_inline_call_cost)
+let inline_alloc_cost = ref (Int_arg_helper.default default_inline_alloc_cost)
+let inline_prim_cost = ref (Int_arg_helper.default default_inline_prim_cost)
+let inline_branch_cost =
+  ref (Int_arg_helper.default default_inline_branch_cost)
+let inline_indirect_cost =
+  ref (Int_arg_helper.default default_inline_indirect_cost)
+let inline_branch_factor =
+  ref (Float_arg_helper.default default_inline_branch_factor)
+let inline_lifting_benefit =
+  ref (Int_arg_helper.default default_inline_lifting_benefit)
+let inline_max_unroll =
+  ref (Int_arg_helper.default default_inline_max_unroll)
+let inline_max_depth =
+  ref (Int_arg_helper.default default_inline_max_depth)
+
+
+let unbox_specialised_args = ref true   (* -no-unbox-specialised-args *)
+let unbox_free_vars_of_closures = ref true
+let unbox_closures = ref false          (* -unbox-closures *)
+let default_unbox_closures_factor = 10
+let unbox_closures_factor =
+  ref default_unbox_closures_factor      (* -unbox-closures-factor *)
+let remove_unused_arguments = ref false (* -remove-unused-arguments *)
+
+type inlining_arguments = {
+  inline_call_cost : int option;
+  inline_alloc_cost : int option;
+  inline_prim_cost : int option;
+  inline_branch_cost : int option;
+  inline_indirect_cost : int option;
+  inline_lifting_benefit : int option;
+  inline_branch_factor : float option;
+  inline_max_depth : int option;
+  inline_max_unroll : int option;
+  inline_threshold : float option;
+  inline_toplevel_threshold : int option;
+}
+
+let set_int_arg round (arg:Int_arg_helper.parsed ref) default value =
+  let value : int =
+    match value with
+    | None -> default
+    | Some value -> value
+  in
+  match round with
+  | None ->
+    arg := Int_arg_helper.set_base_default value
+             (Int_arg_helper.reset_base_overrides !arg)
+  | Some round ->
+    arg := Int_arg_helper.add_base_override round value !arg
+
+let set_float_arg round (arg:Float_arg_helper.parsed ref) default value =
+  let value =
+    match value with
+    | None -> default
+    | Some value -> value
+  in
+  match round with
+  | None ->
+    arg := Float_arg_helper.set_base_default value
+             (Float_arg_helper.reset_base_overrides !arg)
+  | Some round ->
+    arg := Float_arg_helper.add_base_override round value !arg
+
+let use_inlining_arguments_set ?round (arg:inlining_arguments) =
+  let set_int = set_int_arg round in
+  let set_float = set_float_arg round in
+  set_int inline_call_cost default_inline_call_cost arg.inline_call_cost;
+  set_int inline_alloc_cost default_inline_alloc_cost arg.inline_alloc_cost;
+  set_int inline_prim_cost default_inline_prim_cost arg.inline_prim_cost;
+  set_int inline_branch_cost
+    default_inline_branch_cost arg.inline_branch_cost;
+  set_int inline_indirect_cost
+    default_inline_indirect_cost arg.inline_indirect_cost;
+  set_int inline_lifting_benefit
+    default_inline_lifting_benefit arg.inline_lifting_benefit;
+  set_float inline_branch_factor
+    default_inline_branch_factor arg.inline_branch_factor;
+  set_int inline_max_depth
+    default_inline_max_depth arg.inline_max_depth;
+  set_int inline_max_unroll
+    default_inline_max_unroll arg.inline_max_unroll;
+  set_float inline_threshold
+    default_inline_threshold arg.inline_threshold;
+  set_int inline_toplevel_threshold
+    default_inline_toplevel_threshold arg.inline_toplevel_threshold
+
+(* o1 is the default *)
+let o1_arguments = {
+  inline_call_cost = None;
+  inline_alloc_cost = None;
+  inline_prim_cost = None;
+  inline_branch_cost = None;
+  inline_indirect_cost = None;
+  inline_lifting_benefit = None;
+  inline_branch_factor = None;
+  inline_max_depth = None;
+  inline_max_unroll = None;
+  inline_threshold = None;
+  inline_toplevel_threshold = None;
+}
+
+let classic_arguments = {
+  inline_call_cost = None;
+  inline_alloc_cost = None;
+  inline_prim_cost = None;
+  inline_branch_cost = None;
+  inline_indirect_cost = None;
+  inline_lifting_benefit = None;
+  inline_branch_factor = None;
+  inline_max_depth = None;
+  inline_max_unroll = None;
+  (* [inline_threshold] matches the current compiler's default.
+     Note that this particular fraction can be expressed exactly in
+     floating point. *)
+  inline_threshold = Some (10. /. 8.);
+  (* [inline_toplevel_threshold] is not used in classic mode. *)
+  inline_toplevel_threshold = Some 1;
+}
+
+let o2_arguments = {
+  inline_call_cost = Some (2 * default_inline_call_cost);
+  inline_alloc_cost = Some (2 * default_inline_alloc_cost);
+  inline_prim_cost = Some (2 * default_inline_prim_cost);
+  inline_branch_cost = Some (2 * default_inline_branch_cost);
+  inline_indirect_cost = Some (2 * default_inline_indirect_cost);
+  inline_lifting_benefit = None;
+  inline_branch_factor = None;
+  inline_max_depth = Some 2;
+  inline_max_unroll = None;
+  inline_threshold = Some 25.;
+  inline_toplevel_threshold = Some (25 * inline_toplevel_multiplier);
+}
+
+let o3_arguments = {
+  inline_call_cost = Some (3 * default_inline_call_cost);
+  inline_alloc_cost = Some (3 * default_inline_alloc_cost);
+  inline_prim_cost = Some (3 * default_inline_prim_cost);
+  inline_branch_cost = Some (3 * default_inline_branch_cost);
+  inline_indirect_cost = Some (3 * default_inline_indirect_cost);
+  inline_lifting_benefit = None;
+  inline_branch_factor = Some 0.;
+  inline_max_depth = Some 3;
+  inline_max_unroll = Some 1;
+  inline_threshold = Some 50.;
+  inline_toplevel_threshold = Some (50 * inline_toplevel_multiplier);
+}
+
+let all_passes = ref []
+let dumped_passes_list = ref []
+let dumped_pass s =
+  assert(List.mem s !all_passes);
+  List.mem s !dumped_passes_list
+
+let set_dumped_pass s enabled =
+  if (List.mem s !all_passes) then begin
+    let passes_without_s = List.filter ((<>) s) !dumped_passes_list in
+    let dumped_passes =
+      if enabled then
+        s :: passes_without_s
+      else
+        passes_without_s
+    in
+    dumped_passes_list := dumped_passes
+  end
+
+let dump_into_file = ref false (* -dump-into-file *)
+
+type 'a env_reader = {
+  parse : string -> 'a option;
+  print : 'a -> string;
+  usage : string;
+  env_var : string;
+}
+
+let color = ref None (* -color *)
+
+let color_reader = {
+  parse = (function
+    | "auto" -> Some Misc.Color.Auto
+    | "always" -> Some Misc.Color.Always
+    | "never" -> Some Misc.Color.Never
+    | _ -> None);
+  print = (function
+    | Misc.Color.Auto -> "auto"
+    | Misc.Color.Always -> "always"
+    | Misc.Color.Never -> "never");
+  usage = "expected \"auto\", \"always\" or \"never\"";
+  env_var = "OCAML_COLOR";
+}
+
+let error_style = ref None (* -error-style *)
+
+let error_style_reader = {
+  parse = (function
+    | "contextual" -> Some Misc.Error_style.Contextual
+    | "short" -> Some Misc.Error_style.Short
+    | _ -> None);
+  print = (function
+    | Misc.Error_style.Contextual -> "contextual"
+    | Misc.Error_style.Short -> "short");
+  usage = "expected \"contextual\" or \"short\"";
+  env_var = "OCAML_ERROR_STYLE";
+}
+
+let unboxed_types = ref false
+
+(* This is used by the -stop-after option. *)
+module Compiler_pass = struct
+  (* If you add a new pass, the following must be updated:
+     - the variable `passes` below
+     - the manpages in man/ocaml{c,opt}.m
+     - the manual manual/manual/cmds/unified-options.etex
+  *)
+  type t = Parsing | Typing | Scheduling
+
+  let to_string = function
+    | Parsing -> "parsing"
+    | Typing -> "typing"
+    | Scheduling -> "scheduling"
+
+  let of_string = function
+    | "parsing" -> Some Parsing
+    | "typing" -> Some Typing
+    | "scheduling" -> Some Scheduling
+    | _ -> None
+
+  let rank = function
+    | Parsing -> 0
+    | Typing -> 1
+    | Scheduling -> 50
+
+  let passes = [
+    Parsing;
+    Typing;
+    Scheduling;
+  ]
+  let is_compilation_pass _ = true
+  let is_native_only = function
+    | Scheduling -> true
+    | _ -> false
+
+  let enabled is_native t = not (is_native_only t) || is_native
+
+  let available_pass_names ~native =
+    passes
+    |> List.filter (enabled native)
+    |> List.map to_string
+end
+
+let stop_after = ref None (* -stop-after *)
+
+let should_stop_after pass =
+  if Compiler_pass.(rank Typing <= rank pass) && !print_types then true
+  else
+    match !stop_after with
+    | None -> false
+    | Some stop -> Compiler_pass.rank stop <= Compiler_pass.rank pass
+
+module String = Misc.Stdlib.String
+
+let arg_spec = ref []
+let arg_names = ref String.Map.empty
+
+let reset_arguments () =
+  arg_spec := [];
+  arg_names := String.Map.empty
+
+let add_arguments loc args =
+  List.iter (function (arg_name, _, _) as arg ->
+    try
+      let loc2 = String.Map.find arg_name !arg_names in
+      Printf.eprintf
+        "Warning: compiler argument %s is already defined:\n" arg_name;
+      Printf.eprintf "   First definition: %s\n" loc2;
+      Printf.eprintf "   New definition: %s\n" loc;
+    with Not_found ->
+      arg_spec := !arg_spec @ [ arg ];
+      arg_names := String.Map.add arg_name loc !arg_names
+  ) args
+
+let print_arguments usage =
+  Arg.usage !arg_spec usage
+
+(* This function is almost the same as [Arg.parse_expand], except
+   that [Arg.parse_expand] could not be used because it does not take a
+   reference for [arg_spec].*)
+let parse_arguments f msg =
+  try
+    let argv = ref Sys.argv in
+    let current = ref (!Arg.current) in
+    Arg.parse_and_expand_argv_dynamic current argv arg_spec f msg
+  with
+  | Arg.Bad msg -> Printf.eprintf "%s" msg; exit 2
+  | Arg.Help msg -> Printf.printf "%s" msg; exit 0
diff --git a/upstream/ocaml_411/utils/clflags.mli b/upstream/ocaml_411/utils/clflags.mli
new file mode 100644
index 0000000..5be371a
--- /dev/null
+++ b/upstream/ocaml_411/utils/clflags.mli
@@ -0,0 +1,266 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2005 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Command line flags *)
+
+(** Optimization parameters represented as ints indexed by round number. *)
+module Int_arg_helper : sig
+  type parsed
+
+  val parse : string -> string -> parsed ref -> unit
+
+  type parse_result =
+    | Ok
+    | Parse_failed of exn
+  val parse_no_error : string -> parsed ref -> parse_result
+
+  val get : key:int -> parsed -> int
+end
+
+(** Optimization parameters represented as floats indexed by round number. *)
+module Float_arg_helper : sig
+  type parsed
+
+  val parse : string -> string -> parsed ref -> unit
+
+  type parse_result =
+    | Ok
+    | Parse_failed of exn
+  val parse_no_error : string -> parsed ref -> parse_result
+
+  val get : key:int -> parsed -> float
+end
+
+type inlining_arguments = {
+  inline_call_cost : int option;
+  inline_alloc_cost : int option;
+  inline_prim_cost : int option;
+  inline_branch_cost : int option;
+  inline_indirect_cost : int option;
+  inline_lifting_benefit : int option;
+  inline_branch_factor : float option;
+  inline_max_depth : int option;
+  inline_max_unroll : int option;
+  inline_threshold : float option;
+  inline_toplevel_threshold : int option;
+}
+
+val classic_arguments : inlining_arguments
+val o1_arguments : inlining_arguments
+val o2_arguments : inlining_arguments
+val o3_arguments : inlining_arguments
+
+(** Set all the inlining arguments for a round.
+    The default is set if no round is provided. *)
+val use_inlining_arguments_set : ?round:int -> inlining_arguments -> unit
+
+val objfiles : string list ref
+val ccobjs : string list ref
+val dllibs : string list ref
+val compile_only : bool ref
+val output_name : string option ref
+val include_dirs : string list ref
+val no_std_include : bool ref
+val print_types : bool ref
+val make_archive : bool ref
+val debug : bool ref
+val debug_full : bool ref
+val unsafe : bool ref
+val use_linscan : bool ref
+val link_everything : bool ref
+val custom_runtime : bool ref
+val no_check_prims : bool ref
+val bytecode_compatible_32 : bool ref
+val output_c_object : bool ref
+val output_complete_object : bool ref
+val output_complete_executable : bool ref
+val all_ccopts : string list ref
+val classic : bool ref
+val nopervasives : bool ref
+val match_context_rows : int ref
+val open_modules : string list ref
+val preprocessor : string option ref
+val all_ppx : string list ref
+val absname : bool ref
+val annotations : bool ref
+val binary_annotations : bool ref
+val use_threads : bool ref
+val noassert : bool ref
+val verbose : bool ref
+val noprompt : bool ref
+val nopromptcont : bool ref
+val init_file : string option ref
+val noinit : bool ref
+val noversion : bool ref
+val use_prims : string ref
+val use_runtime : string ref
+val plugin : bool ref
+val principal : bool ref
+val real_paths : bool ref
+val recursive_types : bool ref
+val strict_sequence : bool ref
+val strict_formats : bool ref
+val applicative_functors : bool ref
+val make_runtime : bool ref
+val c_compiler : string option ref
+val no_auto_link : bool ref
+val dllpaths : string list ref
+val make_package : bool ref
+val for_package : string option ref
+val error_size : int ref
+val float_const_prop : bool ref
+val transparent_modules : bool ref
+val unique_ids : bool ref
+val locations : bool ref
+val dump_source : bool ref
+val dump_parsetree : bool ref
+val dump_typedtree : bool ref
+val dump_rawlambda : bool ref
+val dump_lambda : bool ref
+val dump_rawclambda : bool ref
+val dump_clambda : bool ref
+val dump_rawflambda : bool ref
+val dump_flambda : bool ref
+val dump_flambda_let : int option ref
+val dump_instr : bool ref
+val keep_camlprimc_file : bool ref
+val keep_asm_file : bool ref
+val optimize_for_speed : bool ref
+val dump_cmm : bool ref
+val dump_selection : bool ref
+val dump_cse : bool ref
+val dump_live : bool ref
+val dump_avail : bool ref
+val debug_runavail : bool ref
+val dump_spill : bool ref
+val dump_split : bool ref
+val dump_interf : bool ref
+val dump_prefer : bool ref
+val dump_regalloc : bool ref
+val dump_reload : bool ref
+val dump_scheduling : bool ref
+val dump_linear : bool ref
+val dump_interval : bool ref
+val keep_startup_file : bool ref
+val dump_combine : bool ref
+val native_code : bool ref
+val default_inline_threshold : float
+val inline_threshold : Float_arg_helper.parsed ref
+val inlining_report : bool ref
+val simplify_rounds : int option ref
+val default_simplify_rounds : int ref
+val rounds : unit -> int
+val default_inline_max_unroll : int
+val inline_max_unroll : Int_arg_helper.parsed ref
+val default_inline_toplevel_threshold : int
+val inline_toplevel_threshold : Int_arg_helper.parsed ref
+val default_inline_call_cost : int
+val default_inline_alloc_cost : int
+val default_inline_prim_cost : int
+val default_inline_branch_cost : int
+val default_inline_indirect_cost : int
+val default_inline_lifting_benefit : int
+val inline_call_cost : Int_arg_helper.parsed ref
+val inline_alloc_cost : Int_arg_helper.parsed ref
+val inline_prim_cost : Int_arg_helper.parsed ref
+val inline_branch_cost : Int_arg_helper.parsed ref
+val inline_indirect_cost : Int_arg_helper.parsed ref
+val inline_lifting_benefit : Int_arg_helper.parsed ref
+val default_inline_branch_factor : float
+val inline_branch_factor : Float_arg_helper.parsed ref
+val dont_write_files : bool ref
+val std_include_flag : string -> string
+val std_include_dir : unit -> string list
+val shared : bool ref
+val dlcode : bool ref
+val pic_code : bool ref
+val runtime_variant : string ref
+val with_runtime : bool ref
+val force_slash : bool ref
+val keep_docs : bool ref
+val keep_locs : bool ref
+val unsafe_string : bool ref
+val opaque : bool ref
+val profile_columns : Profile.column list ref
+val flambda_invariant_checks : bool ref
+val unbox_closures : bool ref
+val unbox_closures_factor : int ref
+val default_unbox_closures_factor : int
+val unbox_free_vars_of_closures : bool ref
+val unbox_specialised_args : bool ref
+val clambda_checks : bool ref
+val default_inline_max_depth : int
+val inline_max_depth : Int_arg_helper.parsed ref
+val remove_unused_arguments : bool ref
+val dump_flambda_verbose : bool ref
+val classic_inlining : bool ref
+val afl_instrument : bool ref
+val afl_inst_ratio : int ref
+val function_sections : bool ref
+
+val all_passes : string list ref
+val dumped_pass : string -> bool
+val set_dumped_pass : string -> bool -> unit
+
+val dump_into_file : bool ref
+
+(* Support for flags that can also be set from an environment variable *)
+type 'a env_reader = {
+  parse : string -> 'a option;
+  print : 'a -> string;
+  usage : string;
+  env_var : string;
+}
+
+val color : Misc.Color.setting option ref
+val color_reader : Misc.Color.setting env_reader
+
+val error_style : Misc.Error_style.setting option ref
+val error_style_reader : Misc.Error_style.setting env_reader
+
+val unboxed_types : bool ref
+
+val insn_sched : bool ref
+val insn_sched_default : bool
+
+module Compiler_pass : sig
+  type t = Parsing | Typing | Scheduling
+  val of_string : string -> t option
+  val to_string : t -> string
+  val is_compilation_pass : t -> bool
+  val available_pass_names : native:bool -> string list
+end
+val stop_after : Compiler_pass.t option ref
+val should_stop_after : Compiler_pass.t -> bool
+
+val arg_spec : (string * Arg.spec * string) list ref
+
+(* [add_arguments __LOC__ args] will add the arguments from [args] at
+   the end of [arg_spec], checking that they have not already been
+   added by [add_arguments] before. A warning is printed showing the
+   locations of the function from which the argument was previously
+   added. *)
+val add_arguments : string -> (string * Arg.spec * string) list -> unit
+
+(* [parse_arguments anon_arg usage] will parse the arguments, using
+  the arguments provided in [Clflags.arg_spec].
+*)
+val parse_arguments : Arg.anon_fun -> string -> unit
+
+(* [print_arguments usage] print the standard usage message *)
+val print_arguments : string -> unit
+
+(* [reset_arguments ()] clear all declared arguments *)
+val reset_arguments : unit -> unit
diff --git a/upstream/ocaml_411/utils/config.mli b/upstream/ocaml_411/utils/config.mli
new file mode 100644
index 0000000..515a428
--- /dev/null
+++ b/upstream/ocaml_411/utils/config.mli
@@ -0,0 +1,250 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** System configuration
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+val version: string
+(** The current version number of the system *)
+
+val standard_library: string
+(** The directory containing the standard libraries *)
+
+val ccomp_type: string
+(** The "kind" of the C compiler, assembler and linker used: one of
+    "cc" (for Unix-style C compilers)
+    "msvc" (for Microsoft Visual C++ and MASM) *)
+
+val c_compiler: string
+(** The compiler to use for compiling C files *)
+
+val c_output_obj: string
+(** Name of the option of the C compiler for specifying the output
+    file *)
+
+val c_has_debug_prefix_map : bool
+(** Whether the C compiler supports -fdebug-prefix-map *)
+
+val as_has_debug_prefix_map : bool
+(** Whether the assembler supports --debug-prefix-map *)
+
+val ocamlc_cflags : string
+(** The flags ocamlc should pass to the C compiler *)
+
+val ocamlc_cppflags : string
+(** The flags ocamlc should pass to the C preprocessor *)
+
+val ocamlopt_cflags : string
+  [@@ocaml.deprecated "Use ocamlc_cflags instead."]
+(** @deprecated {!ocamlc_cflags} should be used instead.
+    The flags ocamlopt should pass to the C compiler *)
+
+val ocamlopt_cppflags : string
+  [@@ocaml.deprecated "Use ocamlc_cppflags instead."]
+(** @deprecated {!ocamlc_cppflags} should be used instead.
+    The flags ocamlopt should pass to the C preprocessor *)
+
+val bytecomp_c_libraries: string
+(** The C libraries to link with custom runtimes *)
+
+val native_c_libraries: string
+(** The C libraries to link with native-code programs *)
+
+val native_pack_linker: string
+(** The linker to use for packaging (ocamlopt -pack) and for partial
+    links (ocamlopt -output-obj). *)
+
+val mkdll: string
+(** The linker command line to build dynamic libraries. *)
+
+val mkexe: string
+(** The linker command line to build executables. *)
+
+val mkmaindll: string
+(** The linker command line to build main programs as dlls. *)
+
+val ranlib: string
+(** Command to randomize a library, or "" if not needed *)
+
+val ar: string
+(** Name of the ar command, or "" if not needed  (MSVC) *)
+
+val interface_suffix: string ref
+(** Suffix for interface file names *)
+
+val exec_magic_number: string
+(** Magic number for bytecode executable files *)
+
+val cmi_magic_number: string
+(** Magic number for compiled interface files *)
+
+val cmo_magic_number: string
+(** Magic number for object bytecode files *)
+
+val cma_magic_number: string
+(** Magic number for archive files *)
+
+val cmx_magic_number: string
+(** Magic number for compilation unit descriptions *)
+
+val cmxa_magic_number: string
+(** Magic number for libraries of compilation unit descriptions *)
+
+val ast_intf_magic_number: string
+(** Magic number for file holding an interface syntax tree *)
+
+val ast_impl_magic_number: string
+(** Magic number for file holding an implementation syntax tree *)
+
+val cmxs_magic_number: string
+(** Magic number for dynamically-loadable plugins *)
+
+val cmt_magic_number: string
+(** Magic number for compiled interface files *)
+
+val max_tag: int
+(** Biggest tag that can be stored in the header of a regular block. *)
+
+val lazy_tag : int
+(** Normally the same as Obj.lazy_tag.  Separate definition because
+    of technical reasons for bootstrapping. *)
+
+val max_young_wosize: int
+(** Maximal size of arrays that are directly allocated in the
+    minor heap *)
+
+val stack_threshold: int
+(** Size in words of safe area at bottom of VM stack,
+    see runtime/caml/config.h *)
+
+val stack_safety_margin: int
+(** Size in words of the safety margin between the bottom of
+    the stack and the stack pointer. This margin can be used by
+    intermediate computations of some instructions, or the event
+    handler. *)
+
+val architecture: string
+(** Name of processor type for the native-code compiler *)
+
+val model: string
+(** Name of processor submodel for the native-code compiler *)
+
+val system: string
+(** Name of operating system for the native-code compiler *)
+
+val asm: string
+(** The assembler (and flags) to use for assembling
+    ocamlopt-generated code. *)
+
+val asm_cfi_supported: bool
+(** Whether assembler understands CFI directives *)
+
+val with_frame_pointers : bool
+(** Whether assembler should maintain frame pointers *)
+
+val ext_obj: string
+(** Extension for object files, e.g. [.o] under Unix. *)
+
+val ext_asm: string
+(** Extension for assembler files, e.g. [.s] under Unix. *)
+
+val ext_lib: string
+(** Extension for library files, e.g. [.a] under Unix. *)
+
+val ext_dll: string
+(** Extension for dynamically-loaded libraries, e.g. [.so] under Unix.*)
+
+val default_executable_name: string
+(** Name of executable produced by linking if none is given with -o,
+    e.g. [a.out] under Unix. *)
+
+val systhread_supported : bool
+(** Whether the system thread library is implemented *)
+
+val flexdll_dirs : string list
+(** Directories needed for the FlexDLL objects *)
+
+val host : string
+(** Whether the compiler is a cross-compiler *)
+
+val target : string
+(** Whether the compiler is a cross-compiler *)
+
+val flambda : bool
+(** Whether the compiler was configured for flambda *)
+
+val with_flambda_invariants : bool
+(** Whether the invariants checks for flambda are enabled *)
+
+val spacetime : bool
+(** Whether the compiler was configured for Spacetime profiling *)
+
+val enable_call_counts : bool
+(** Whether call counts are to be available when Spacetime profiling *)
+
+val profinfo : bool
+(** Whether the compiler was configured for profiling *)
+
+val profinfo_width : int
+(** How many bits are to be used in values' headers for profiling
+    information *)
+
+val libunwind_available : bool
+(** Whether the libunwind library is available on the target *)
+
+val libunwind_link_flags : string
+(** Linker flags to use libunwind *)
+
+val safe_string: bool
+(** Whether the compiler was configured with -force-safe-string;
+    in that case, the -unsafe-string compile-time option is unavailable
+
+    @since 4.05.0 *)
+
+val default_safe_string: bool
+(** Whether the compiler was configured to use the -safe-string
+    or -unsafe-string compile-time option by default.
+
+    @since 4.06.0 *)
+
+val flat_float_array : bool
+(** Whether the compiler and runtime automagically flatten float
+    arrays *)
+
+val function_sections : bool
+(** Whether the compiler was configured to generate
+    each function in a separate section *)
+
+val windows_unicode: bool
+(** Whether Windows Unicode runtime is enabled *)
+
+val supports_shared_libraries: bool
+(** Whether shared libraries are supported
+
+    @since 4.08.0 *)
+
+val afl_instrument : bool
+(** Whether afl-fuzz instrumentation is generated by default *)
+
+
+(** Access to configuration values *)
+val print_config : out_channel -> unit
+
+val config_var : string -> string option
+(** the configuration value of a variable, if it exists *)
diff --git a/upstream/ocaml_411/utils/config.mlp b/upstream/ocaml_411/utils/config.mlp
new file mode 100644
index 0000000..49ffc5b
--- /dev/null
+++ b/upstream/ocaml_411/utils/config.mlp
@@ -0,0 +1,242 @@
+#2 "utils/config.mlp"
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* The main OCaml version string has moved to ../VERSION *)
+let version = Sys.ocaml_version
+
+let standard_library_default = "%%LIBDIR%%"
+
+let standard_library =
+  try
+    Sys.getenv "OCAMLLIB"
+  with Not_found ->
+  try
+    Sys.getenv "CAMLLIB"
+  with Not_found ->
+    standard_library_default
+
+let ccomp_type = "%%CCOMPTYPE%%"
+let c_compiler = "%%CC%%"
+let c_output_obj = "%%OUTPUTOBJ%%"
+let c_has_debug_prefix_map = %%CC_HAS_DEBUG_PREFIX_MAP%%
+let as_has_debug_prefix_map = %%AS_HAS_DEBUG_PREFIX_MAP%%
+let ocamlc_cflags = "%%OCAMLC_CFLAGS%%"
+let ocamlc_cppflags = "%%OCAMLC_CPPFLAGS%%"
+(* #7678: ocamlopt uses these only to compile .c files, and the behaviour for
+          the two drivers should be identical. *)
+let ocamlopt_cflags = "%%OCAMLC_CFLAGS%%"
+let ocamlopt_cppflags = "%%OCAMLOPT_CPPFLAGS%%"
+let bytecomp_c_libraries = "%%BYTECCLIBS%%"
+(* bytecomp_c_compiler and native_c_compiler have been supported for a
+   long time and are retained for backwards compatibility.
+   For programs that don't need compatibility with older OCaml releases
+   the recommended approach is to use the constituent variables
+   c_compiler, ocamlc_cflags, ocamlc_cppflags etc., directly.
+*)
+let bytecomp_c_compiler =
+  c_compiler ^ " " ^ ocamlc_cflags ^ " " ^ ocamlc_cppflags
+let native_c_compiler =
+  c_compiler ^ " " ^ ocamlopt_cflags ^ " " ^ ocamlopt_cppflags
+let native_c_libraries = "%%NATIVECCLIBS%%"
+let native_pack_linker = "%%PACKLD%%"
+let ranlib = "%%RANLIBCMD%%"
+let ar = "%%ARCMD%%"
+let mkdll, mkexe, mkmaindll =
+  (* @@DRA Cygwin - but only if shared libraries are enabled, which we
+     should be able to detect? *)
+  if Sys.os_type = "Win32" then
+    try
+      let flexlink =
+        let flexlink = Sys.getenv "OCAML_FLEXLINK" in
+        let f i =
+          let c = flexlink.[i] in
+          if c = '/' then '\\' else c in
+        (String.init (String.length flexlink) f) ^ " %%FLEXLINK_FLAGS%%" in
+      flexlink,
+      flexlink ^ " -exe%%FLEXLINK_LDFLAGS%%",
+      flexlink ^ " -maindll"
+    with Not_found ->
+      "%%MKDLL%%", "%%MKEXE%%", "%%MKMAINDLL%%"
+  else
+    "%%MKDLL%%", "%%MKEXE%%", "%%MKMAINDLL%%"
+
+let flambda = %%FLAMBDA%%
+let with_flambda_invariants = %%WITH_FLAMBDA_INVARIANTS%%
+let safe_string = %%FORCE_SAFE_STRING%%
+let default_safe_string = %%DEFAULT_SAFE_STRING%%
+let windows_unicode = %%WINDOWS_UNICODE%% != 0
+let supports_shared_libraries = %%SUPPORTS_SHARED_LIBRARIES%%
+
+let flat_float_array = %%FLAT_FLOAT_ARRAY%%
+
+let function_sections = %%FUNCTION_SECTIONS%%
+let afl_instrument = %%AFL_INSTRUMENT%%
+
+let exec_magic_number = "Caml1999X028"
+    (* exec_magic_number is duplicated in runtime/caml/exec.h *)
+and cmi_magic_number = "Caml1999I028"
+and cmo_magic_number = "Caml1999O028"
+and cma_magic_number = "Caml1999A028"
+and cmx_magic_number =
+  if flambda then
+    "Caml1999y028"
+  else
+    "Caml1999Y028"
+and cmxa_magic_number =
+  if flambda then
+    "Caml1999z028"
+  else
+    "Caml1999Z028"
+and ast_impl_magic_number = "Caml1999M028"
+and ast_intf_magic_number = "Caml1999N028"
+and cmxs_magic_number = "Caml1999D028"
+and cmt_magic_number = "Caml1999T028"
+
+let interface_suffix = ref ".mli"
+
+let max_tag = 245
+(* This is normally the same as in obj.ml, but we have to define it
+   separately because it can differ when we're in the middle of a
+   bootstrapping phase. *)
+let lazy_tag = 246
+
+let max_young_wosize = 256
+let stack_threshold = 256 (* see runtime/caml/config.h *)
+let stack_safety_margin = 60
+
+let architecture = "%%ARCH%%"
+let model = "%%MODEL%%"
+let system = "%%SYSTEM%%"
+
+let asm = "%%ASM%%"
+let asm_cfi_supported = %%ASM_CFI_SUPPORTED%%
+let with_frame_pointers = %%WITH_FRAME_POINTERS%%
+let spacetime = %%WITH_SPACETIME%%
+let enable_call_counts = %%ENABLE_CALL_COUNTS%%
+let libunwind_available = %%LIBUNWIND_AVAILABLE%%
+let libunwind_link_flags = "%%LIBUNWIND_LINK_FLAGS%%"
+let profinfo = %%WITH_PROFINFO%%
+let profinfo_width = %%PROFINFO_WIDTH%%
+
+let ext_exe = "%%EXE%%"
+let ext_obj = "%%EXT_OBJ%%"
+let ext_asm = "%%EXT_ASM%%"
+let ext_lib = "%%EXT_LIB%%"
+let ext_dll = "%%EXT_DLL%%"
+
+let host = "%%HOST%%"
+let target = "%%TARGET%%"
+
+let default_executable_name =
+  match Sys.os_type with
+    "Unix" -> "a.out"
+  | "Win32" | "Cygwin" -> "camlprog.exe"
+  | _ -> "camlprog"
+
+let systhread_supported = %%SYSTHREAD_SUPPORT%%;;
+
+let flexdll_dirs = [%%FLEXDLL_DIR%%];;
+
+type configuration_value =
+  | String of string
+  | Int of int
+  | Bool of bool
+
+let configuration_variables =
+  let p x v = (x, String v) in
+  let p_int x v = (x, Int v) in
+  let p_bool x v = (x, Bool v) in
+[
+  p "version" version;
+  p "standard_library_default" standard_library_default;
+  p "standard_library" standard_library;
+  p "ccomp_type" ccomp_type;
+  p "c_compiler" c_compiler;
+  p "ocamlc_cflags" ocamlc_cflags;
+  p "ocamlc_cppflags" ocamlc_cppflags;
+  p "ocamlopt_cflags" ocamlopt_cflags;
+  p "ocamlopt_cppflags" ocamlopt_cppflags;
+  p "bytecomp_c_compiler" bytecomp_c_compiler;
+  p "native_c_compiler" native_c_compiler;
+  p "bytecomp_c_libraries" bytecomp_c_libraries;
+  p "native_c_libraries" native_c_libraries;
+  p "native_pack_linker" native_pack_linker;
+  p "ranlib" ranlib;
+  p "architecture" architecture;
+  p "model" model;
+  p_int "int_size" Sys.int_size;
+  p_int "word_size" Sys.word_size;
+  p "system" system;
+  p "asm" asm;
+  p_bool "asm_cfi_supported" asm_cfi_supported;
+  p_bool "with_frame_pointers" with_frame_pointers;
+  p "ext_exe" ext_exe;
+  p "ext_obj" ext_obj;
+  p "ext_asm" ext_asm;
+  p "ext_lib" ext_lib;
+  p "ext_dll" ext_dll;
+  p "os_type" Sys.os_type;
+  p "default_executable_name" default_executable_name;
+  p_bool "systhread_supported" systhread_supported;
+  p "host" host;
+  p "target" target;
+  p_bool "flambda" flambda;
+  p_bool "spacetime" spacetime;
+  p_bool "safe_string" safe_string;
+  p_bool "default_safe_string" default_safe_string;
+  p_bool "flat_float_array" flat_float_array;
+  p_bool "function_sections" function_sections;
+  p_bool "afl_instrument" afl_instrument;
+  p_bool "windows_unicode" windows_unicode;
+  p_bool "supports_shared_libraries" supports_shared_libraries;
+
+  p "exec_magic_number" exec_magic_number;
+  p "cmi_magic_number" cmi_magic_number;
+  p "cmo_magic_number" cmo_magic_number;
+  p "cma_magic_number" cma_magic_number;
+  p "cmx_magic_number" cmx_magic_number;
+  p "cmxa_magic_number" cmxa_magic_number;
+  p "ast_impl_magic_number" ast_impl_magic_number;
+  p "ast_intf_magic_number" ast_intf_magic_number;
+  p "cmxs_magic_number" cmxs_magic_number;
+  p "cmt_magic_number" cmt_magic_number;
+]
+
+let print_config_value oc = function
+  | String s ->
+      Printf.fprintf oc "%s" s
+  | Int n ->
+      Printf.fprintf oc "%d" n
+  | Bool p ->
+      Printf.fprintf oc "%B" p
+
+let print_config oc =
+  let print (x, v) =
+    Printf.fprintf oc "%s: %a\n" x print_config_value v in
+  List.iter print configuration_variables;
+  flush oc;
+;;
+
+let config_var x =
+  match List.assoc_opt x configuration_variables with
+  | None -> None
+  | Some v ->
+      let s = match v with
+        | String s -> s
+        | Int n -> Int.to_string n
+        | Bool b -> string_of_bool b
+      in
+      Some s
diff --git a/upstream/ocaml_411/utils/consistbl.ml b/upstream/ocaml_411/utils/consistbl.ml
new file mode 100644
index 0000000..b329911
--- /dev/null
+++ b/upstream/ocaml_411/utils/consistbl.ml
@@ -0,0 +1,97 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Consistency tables: for checking consistency of module CRCs *)
+
+open Misc
+
+module Make (Module_name : sig
+  type t
+  module Set : Set.S with type elt = t
+  module Map : Map.S with type key = t
+  module Tbl : Hashtbl.S with type key = t
+  val compare : t -> t -> int
+end) = struct
+  type t = (Digest.t * filepath) Module_name.Tbl.t
+
+  let create () = Module_name.Tbl.create 13
+
+  let clear = Module_name.Tbl.clear
+
+  exception Inconsistency of {
+    unit_name : Module_name.t;
+    inconsistent_source : string;
+    original_source : string;
+  }
+
+  exception Not_available of Module_name.t
+
+  let check_ tbl name crc source =
+    let (old_crc, old_source) = Module_name.Tbl.find tbl name in
+    if crc <> old_crc then raise(Inconsistency {
+        unit_name = name;
+        inconsistent_source = source;
+        original_source = old_source;
+      })
+
+  let check tbl name crc source =
+    try check_ tbl name crc source
+    with Not_found ->
+      Module_name.Tbl.add tbl name (crc, source)
+
+  let check_noadd tbl name crc source =
+    try check_ tbl name crc source
+    with Not_found ->
+      raise (Not_available name)
+
+  let set tbl name crc source = Module_name.Tbl.add tbl name (crc, source)
+
+  let source tbl name = snd (Module_name.Tbl.find tbl name)
+
+  let extract l tbl =
+    let l = List.sort_uniq Module_name.compare l in
+    List.fold_left
+      (fun assc name ->
+         try
+           let (crc, _) = Module_name.Tbl.find tbl name in
+             (name, Some crc) :: assc
+         with Not_found ->
+           (name, None) :: assc)
+      [] l
+
+  let extract_map mod_names tbl =
+    Module_name.Set.fold
+      (fun name result ->
+         try
+           let (crc, _) = Module_name.Tbl.find tbl name in
+           Module_name.Map.add name (Some crc) result
+         with Not_found ->
+           Module_name.Map.add name None result)
+      mod_names
+      Module_name.Map.empty
+
+  let filter p tbl =
+    let to_remove = ref [] in
+    Module_name.Tbl.iter
+      (fun name _ ->
+        if not (p name) then to_remove := name :: !to_remove)
+      tbl;
+    List.iter
+      (fun name ->
+         while Module_name.Tbl.mem tbl name do
+           Module_name.Tbl.remove tbl name
+         done)
+      !to_remove
+end
diff --git a/upstream/ocaml_411/utils/consistbl.mli b/upstream/ocaml_411/utils/consistbl.mli
new file mode 100644
index 0000000..5067add
--- /dev/null
+++ b/upstream/ocaml_411/utils/consistbl.mli
@@ -0,0 +1,82 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Consistency tables: for checking consistency of module CRCs
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Misc
+
+module Make (Module_name : sig
+  type t
+  module Set : Set.S with type elt = t
+  module Map : Map.S with type key = t
+  module Tbl : Hashtbl.S with type key = t
+  val compare : t -> t -> int
+end) : sig
+  type t
+
+  val create: unit -> t
+
+  val clear: t -> unit
+
+  val check: t -> Module_name.t -> Digest.t -> filepath -> unit
+        (* [check tbl name crc source]
+             checks consistency of ([name], [crc]) with infos previously
+             stored in [tbl].  If no CRC was previously associated with
+             [name], record ([name], [crc]) in [tbl].
+             [source] is the name of the file from which the information
+             comes from.  This is used for error reporting. *)
+
+  val check_noadd: t -> Module_name.t -> Digest.t -> filepath -> unit
+        (* Same as [check], but raise [Not_available] if no CRC was previously
+             associated with [name]. *)
+
+  val set: t -> Module_name.t -> Digest.t -> filepath -> unit
+        (* [set tbl name crc source] forcefully associates [name] with
+           [crc] in [tbl], even if [name] already had a different CRC
+           associated with [name] in [tbl]. *)
+
+  val source: t -> Module_name.t -> filepath
+        (* [source tbl name] returns the file name associated with [name]
+           if the latter has an associated CRC in [tbl].
+           Raise [Not_found] otherwise. *)
+
+  val extract: Module_name.t list -> t -> (Module_name.t * Digest.t option) list
+        (* [extract tbl names] returns an associative list mapping each string
+           in [names] to the CRC associated with it in [tbl]. If no CRC is
+           associated with a name then it is mapped to [None]. *)
+
+  val extract_map : Module_name.Set.t -> t -> Digest.t option Module_name.Map.t
+        (* Like [extract] but with a more sophisticated type. *)
+
+  val filter: (Module_name.t -> bool) -> t -> unit
+        (* [filter pred tbl] removes from [tbl] table all (name, CRC) pairs
+           such that [pred name] is [false]. *)
+
+  exception Inconsistency of {
+    unit_name : Module_name.t;
+    inconsistent_source : string;
+    original_source : string;
+  }
+  (* Raised by [check] when a CRC mismatch is detected. *)
+
+  exception Not_available of Module_name.t
+        (* Raised by [check_noadd] when a name doesn't have an associated
+           CRC. *)
+end
diff --git a/upstream/ocaml_411/utils/identifiable.ml b/upstream/ocaml_411/utils/identifiable.ml
new file mode 100644
index 0000000..9bbfb65
--- /dev/null
+++ b/upstream/ocaml_411/utils/identifiable.ml
@@ -0,0 +1,249 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+module type Thing = sig
+  type t
+
+  include Hashtbl.HashedType with type t := t
+  include Map.OrderedType with type t := t
+
+  val output : out_channel -> t -> unit
+  val print : Format.formatter -> t -> unit
+end
+
+module type Set = sig
+  module T : Set.OrderedType
+  include Set.S
+    with type elt = T.t
+     and type t = Set.Make (T).t
+
+  val output : out_channel -> t -> unit
+  val print : Format.formatter -> t -> unit
+  val to_string : t -> string
+  val of_list : elt list -> t
+  val map : (elt -> elt) -> t -> t
+end
+
+module type Map = sig
+  module T : Map.OrderedType
+  include Map.S
+    with type key = T.t
+     and type 'a t = 'a Map.Make (T).t
+
+  val of_list : (key * 'a) list -> 'a t
+
+  val disjoint_union :
+    ?eq:('a -> 'a -> bool) -> ?print:(Format.formatter -> 'a -> unit) -> 'a t ->
+    'a t -> 'a t
+
+  val union_right : 'a t -> 'a t -> 'a t
+
+  val union_left : 'a t -> 'a t -> 'a t
+
+  val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
+  val rename : key t -> key -> key
+  val map_keys : (key -> key) -> 'a t -> 'a t
+  val keys : 'a t -> Set.Make(T).t
+  val data : 'a t -> 'a list
+  val of_set : (key -> 'a) -> Set.Make(T).t -> 'a t
+  val transpose_keys_and_data : key t -> key t
+  val transpose_keys_and_data_set : key t -> Set.Make(T).t t
+  val print :
+    (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
+end
+
+module type Tbl = sig
+  module T : sig
+    type t
+    include Map.OrderedType with type t := t
+    include Hashtbl.HashedType with type t := t
+  end
+  include Hashtbl.S
+    with type key = T.t
+     and type 'a t = 'a Hashtbl.Make (T).t
+
+  val to_list : 'a t -> (T.t * 'a) list
+  val of_list : (T.t * 'a) list -> 'a t
+
+  val to_map : 'a t -> 'a Map.Make(T).t
+  val of_map : 'a Map.Make(T).t -> 'a t
+  val memoize : 'a t -> (key -> 'a) -> key -> 'a
+  val map : 'a t -> ('a -> 'b) -> 'b t
+end
+
+module Pair (A : Thing) (B : Thing) : Thing with type t = A.t * B.t = struct
+  type t = A.t * B.t
+
+  let compare (a1, b1) (a2, b2) =
+    let c = A.compare a1 a2 in
+    if c <> 0 then c
+    else B.compare b1 b2
+
+  let output oc (a, b) = Printf.fprintf oc " (%a, %a)" A.output a B.output b
+  let hash (a, b) = Hashtbl.hash (A.hash a, B.hash b)
+  let equal (a1, b1) (a2, b2) = A.equal a1 a2 && B.equal b1 b2
+  let print ppf (a, b) = Format.fprintf ppf " (%a, @ %a)" A.print a B.print b
+end
+
+module Make_map (T : Thing) = struct
+  include Map.Make (T)
+
+  let of_list l =
+    List.fold_left (fun map (id, v) -> add id v map) empty l
+
+  let disjoint_union ?eq ?print m1 m2 =
+    union (fun id v1 v2 ->
+        let ok = match eq with
+          | None -> false
+          | Some eq -> eq v1 v2
+        in
+        if not ok then
+          let err =
+            match print with
+            | None ->
+              Format.asprintf "Map.disjoint_union %a" T.print id
+            | Some print ->
+              Format.asprintf "Map.disjoint_union %a => %a <> %a"
+                T.print id print v1 print v2
+          in
+          Misc.fatal_error err
+        else Some v1)
+      m1 m2
+
+  let union_right m1 m2 =
+    merge (fun _id x y -> match x, y with
+        | None, None -> None
+        | None, Some v
+        | Some v, None
+        | Some _, Some v -> Some v)
+      m1 m2
+
+  let union_left m1 m2 = union_right m2 m1
+
+  let union_merge f m1 m2 =
+    let aux _ m1 m2 =
+      match m1, m2 with
+      | None, m | m, None -> m
+      | Some m1, Some m2 -> Some (f m1 m2)
+    in
+    merge aux m1 m2
+
+  let rename m v =
+    try find v m
+    with Not_found -> v
+
+  let map_keys f m =
+    of_list (List.map (fun (k, v) -> f k, v) (bindings m))
+
+  let print f ppf s =
+    let elts ppf s = iter (fun id v ->
+        Format.fprintf ppf "@ (@[%a@ %a@])" T.print id f v) s in
+    Format.fprintf ppf "@[<1>{@[%a@ @]}@]" elts s
+
+  module T_set = Set.Make (T)
+
+  let keys map = fold (fun k _ set -> T_set.add k set) map T_set.empty
+
+  let data t = List.map snd (bindings t)
+
+  let of_set f set = T_set.fold (fun e map -> add e (f e) map) set empty
+
+  let transpose_keys_and_data map = fold (fun k v m -> add v k m) map empty
+  let transpose_keys_and_data_set map =
+    fold (fun k v m ->
+        let set =
+          match find v m with
+          | exception Not_found ->
+            T_set.singleton k
+          | set ->
+            T_set.add k set
+        in
+        add v set m)
+      map empty
+end
+
+module Make_set (T : Thing) = struct
+  include Set.Make (T)
+
+  let output oc s =
+    Printf.fprintf oc " ( ";
+    iter (fun v -> Printf.fprintf oc "%a " T.output v) s;
+    Printf.fprintf oc ")"
+
+  let print ppf s =
+    let elts ppf s = iter (fun e -> Format.fprintf ppf "@ %a" T.print e) s in
+    Format.fprintf ppf "@[<1>{@[%a@ @]}@]" elts s
+
+  let to_string s = Format.asprintf "%a" print s
+
+  let of_list l = match l with
+    | [] -> empty
+    | [t] -> singleton t
+    | t :: q -> List.fold_left (fun acc e -> add e acc) (singleton t) q
+
+  let map f s = of_list (List.map f (elements s))
+end
+
+module Make_tbl (T : Thing) = struct
+  include Hashtbl.Make (T)
+
+  module T_map = Make_map (T)
+
+  let to_list t =
+    fold (fun key datum elts -> (key, datum)::elts) t []
+
+  let of_list elts =
+    let t = create 42 in
+    List.iter (fun (key, datum) -> add t key datum) elts;
+    t
+
+  let to_map v = fold T_map.add v T_map.empty
+
+  let of_map m =
+    let t = create (T_map.cardinal m) in
+    T_map.iter (fun k v -> add t k v) m;
+    t
+
+  let memoize t f = fun key ->
+    try find t key with
+    | Not_found ->
+      let r = f key in
+      add t key r;
+      r
+
+  let map t f =
+    of_map (T_map.map f (to_map t))
+end
+
+module type S = sig
+  type t
+
+  module T : Thing with type t = t
+  include Thing with type t := T.t
+
+  module Set : Set with module T := T
+  module Map : Map with module T := T
+  module Tbl : Tbl with module T := T
+end
+
+module Make (T : Thing) = struct
+  module T = T
+  include T
+
+  module Set = Make_set (T)
+  module Map = Make_map (T)
+  module Tbl = Make_tbl (T)
+end
diff --git a/upstream/ocaml_411/utils/identifiable.mli b/upstream/ocaml_411/utils/identifiable.mli
new file mode 100644
index 0000000..0da5a66
--- /dev/null
+++ b/upstream/ocaml_411/utils/identifiable.mli
@@ -0,0 +1,113 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Uniform interface for common data structures over various things.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+module type Thing = sig
+  type t
+
+  include Hashtbl.HashedType with type t := t
+  include Map.OrderedType with type t := t
+
+  val output : out_channel -> t -> unit
+  val print : Format.formatter -> t -> unit
+end
+
+module Pair : functor (A : Thing) (B : Thing) -> Thing with type t = A.t * B.t
+
+module type Set = sig
+  module T : Set.OrderedType
+  include Set.S
+    with type elt = T.t
+     and type t = Set.Make (T).t
+
+  val output : out_channel -> t -> unit
+  val print : Format.formatter -> t -> unit
+  val to_string : t -> string
+  val of_list : elt list -> t
+  val map : (elt -> elt) -> t -> t
+end
+
+module type Map = sig
+  module T : Map.OrderedType
+  include Map.S
+    with type key = T.t
+     and type 'a t = 'a Map.Make (T).t
+
+  val of_list : (key * 'a) list -> 'a t
+
+  (** [disjoint_union m1 m2] contains all bindings from [m1] and
+      [m2]. If some binding is present in both and the associated
+      value is not equal, a Fatal_error is raised *)
+  val disjoint_union :
+    ?eq:('a -> 'a -> bool) -> ?print:(Format.formatter -> 'a -> unit) -> 'a t ->
+    'a t -> 'a t
+
+  (** [union_right m1 m2] contains all bindings from [m1] and [m2]. If
+      some binding is present in both, the one from [m2] is taken *)
+  val union_right : 'a t -> 'a t -> 'a t
+
+  (** [union_left m1 m2 = union_right m2 m1] *)
+  val union_left : 'a t -> 'a t -> 'a t
+
+  val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
+  val rename : key t -> key -> key
+  val map_keys : (key -> key) -> 'a t -> 'a t
+  val keys : 'a t -> Set.Make(T).t
+  val data : 'a t -> 'a list
+  val of_set : (key -> 'a) -> Set.Make(T).t -> 'a t
+  val transpose_keys_and_data : key t -> key t
+  val transpose_keys_and_data_set : key t -> Set.Make(T).t t
+  val print :
+    (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
+end
+
+module type Tbl = sig
+  module T : sig
+    type t
+    include Map.OrderedType with type t := t
+    include Hashtbl.HashedType with type t := t
+  end
+  include Hashtbl.S
+    with type key = T.t
+     and type 'a t = 'a Hashtbl.Make (T).t
+
+  val to_list : 'a t -> (T.t * 'a) list
+  val of_list : (T.t * 'a) list -> 'a t
+
+  val to_map : 'a t -> 'a Map.Make(T).t
+  val of_map : 'a Map.Make(T).t -> 'a t
+  val memoize : 'a t -> (key -> 'a) -> key -> 'a
+  val map : 'a t -> ('a -> 'b) -> 'b t
+end
+
+module type S = sig
+  type t
+
+  module T : Thing with type t = t
+  include Thing with type t := T.t
+
+  module Set : Set with module T := T
+  module Map : Map with module T := T
+  module Tbl : Tbl with module T := T
+end
+
+module Make (T : Thing) : S with type t := T.t
diff --git a/upstream/ocaml_411/utils/int_replace_polymorphic_compare.ml b/upstream/ocaml_411/utils/int_replace_polymorphic_compare.ml
new file mode 100644
index 0000000..7cd6bf1
--- /dev/null
+++ b/upstream/ocaml_411/utils/int_replace_polymorphic_compare.ml
@@ -0,0 +1,8 @@
+let ( = )   : int -> int -> bool = Stdlib.( = )
+let ( <> )  : int -> int -> bool = Stdlib.( <> )
+let ( < )   : int -> int -> bool = Stdlib.( < )
+let ( > )   : int -> int -> bool = Stdlib.( > )
+let ( <= )  : int -> int -> bool = Stdlib.( <= )
+let ( >= )  : int -> int -> bool = Stdlib.( >= )
+
+let compare : int -> int -> int  = Stdlib.compare
diff --git a/upstream/ocaml_411/utils/int_replace_polymorphic_compare.mli b/upstream/ocaml_411/utils/int_replace_polymorphic_compare.mli
new file mode 100644
index 0000000..689e741
--- /dev/null
+++ b/upstream/ocaml_411/utils/int_replace_polymorphic_compare.mli
@@ -0,0 +1,8 @@
+val ( = )   : int -> int -> bool
+val ( <> )  : int -> int -> bool
+val ( < )   : int -> int -> bool
+val ( > )   : int -> int -> bool
+val ( <= )  : int -> int -> bool
+val ( >= )  : int -> int -> bool
+
+val compare : int -> int -> int
diff --git a/upstream/ocaml_411/utils/load_path.ml b/upstream/ocaml_411/utils/load_path.ml
new file mode 100644
index 0000000..d95ef07
--- /dev/null
+++ b/upstream/ocaml_411/utils/load_path.ml
@@ -0,0 +1,89 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2018 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+module SMap = Misc.Stdlib.String.Map
+
+(* Mapping from basenames to full filenames *)
+type registry = string SMap.t ref
+
+let files : registry = ref SMap.empty
+let files_uncap : registry = ref SMap.empty
+
+module Dir = struct
+  type t = {
+    path : string;
+    files : string list;
+  }
+
+  let path t = t.path
+  let files t = t.files
+
+  (* For backward compatibility reason, simulate the behavior of
+     [Misc.find_in_path]: silently ignore directories that don't exist
+     + treat [""] as the current directory. *)
+  let readdir_compat dir =
+    try
+      Sys.readdir (if dir = "" then Filename.current_dir_name else dir)
+    with Sys_error _ ->
+      [||]
+
+  let create path =
+    { path; files = Array.to_list (readdir_compat path) }
+end
+
+let dirs = ref []
+
+let reset () =
+  files := SMap.empty;
+  files_uncap := SMap.empty;
+  dirs := []
+
+let get () = !dirs
+let get_paths () = List.map Dir.path !dirs
+
+let add dir =
+  let add_file base =
+    let fn = Filename.concat dir.Dir.path base in
+    files := SMap.add base fn !files;
+    files_uncap := SMap.add (String.uncapitalize_ascii base) fn !files_uncap;
+  in
+  List.iter add_file dir.Dir.files;
+  dirs := dir :: !dirs
+
+let remove_dir dir =
+  let new_dirs = List.filter (fun d -> Dir.path d <> dir) !dirs in
+  if new_dirs <> !dirs then begin
+    reset ();
+    List.iter add (List.rev new_dirs)
+  end
+
+let add_dir dir = add (Dir.create dir)
+
+let init l =
+  reset ();
+  List.iter add_dir (List.rev l)
+
+let is_basename fn = Filename.basename fn = fn
+
+let find fn =
+  if is_basename fn then
+    SMap.find fn !files
+  else
+    Misc.find_in_path (get_paths ()) fn
+
+let find_uncap fn =
+  if is_basename fn then
+    SMap.find (String.uncapitalize_ascii fn) !files_uncap
+  else
+    Misc.find_in_path_uncap (get_paths ()) fn
diff --git a/upstream/ocaml_411/utils/load_path.mli b/upstream/ocaml_411/utils/load_path.mli
new file mode 100644
index 0000000..433eaab
--- /dev/null
+++ b/upstream/ocaml_411/utils/load_path.mli
@@ -0,0 +1,67 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2018 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Management of include directories.
+
+    This module offers a high level interface to locating files in the
+    load path, which is constructed from [-I] command line flags and a few
+    other parameters.
+
+    It makes the assumption that the contents of include directories
+    doesn't change during the execution of the compiler.
+*)
+
+val add_dir : string -> unit
+(** Add a directory to the load path *)
+
+val remove_dir : string -> unit
+(** Remove a directory from the load path *)
+
+val reset : unit -> unit
+(** Remove all directories *)
+
+val init : string list -> unit
+(** [init l] is the same as [reset (); List.iter add_dir (List.rev l)] *)
+
+val get_paths : unit -> string list
+(** Return the list of directories passed to [add_dir] so far, in
+    reverse order. *)
+
+val find : string -> string
+(** Locate a file in the load path. Raise [Not_found] if the file
+    cannot be found. This function is optimized for the case where the
+    filename is a basename, i.e. doesn't contain a directory
+    separator. *)
+
+val find_uncap : string -> string
+(** Same as [find], but search also for uncapitalized name, i.e.  if
+    name is Foo.ml, allow /path/Foo.ml and /path/foo.ml to match. *)
+
+module Dir : sig
+  type t
+  (** Represent one directory in the load path. *)
+
+  val create : string -> t
+
+  val path : t -> string
+
+  val files : t -> string list
+  (** All the files in that directory. This doesn't include files in
+      sub-directories of this directory. *)
+end
+
+val add : Dir.t -> unit
+
+val get : unit -> Dir.t list
+(** Same as [get_paths ()], except that it returns a [Dir.t list]. *)
diff --git a/upstream/ocaml_411/utils/misc.ml b/upstream/ocaml_411/utils/misc.ml
new file mode 100644
index 0000000..df2e74d
--- /dev/null
+++ b/upstream/ocaml_411/utils/misc.ml
@@ -0,0 +1,1190 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Errors *)
+
+exception Fatal_error
+
+let fatal_errorf fmt =
+  Format.kfprintf
+    (fun _ -> raise Fatal_error)
+    Format.err_formatter
+    ("@?>> Fatal error: " ^^ fmt ^^ "@.")
+
+let fatal_error msg = fatal_errorf "%s" msg
+
+(* Exceptions *)
+
+let try_finally ?(always=(fun () -> ())) ?(exceptionally=(fun () -> ())) work =
+  match work () with
+    | result ->
+      begin match always () with
+        | () -> result
+        | exception always_exn ->
+          let always_bt = Printexc.get_raw_backtrace () in
+          exceptionally ();
+          Printexc.raise_with_backtrace always_exn always_bt
+      end
+    | exception work_exn ->
+      let work_bt = Printexc.get_raw_backtrace () in
+      begin match always () with
+        | () ->
+          exceptionally ();
+          Printexc.raise_with_backtrace work_exn work_bt
+        | exception always_exn ->
+          let always_bt = Printexc.get_raw_backtrace () in
+          exceptionally ();
+          Printexc.raise_with_backtrace always_exn always_bt
+      end
+
+type ref_and_value = R : 'a ref * 'a -> ref_and_value
+
+let protect_refs =
+  let set_refs l = List.iter (fun (R (r, v)) -> r := v) l in
+  fun refs f ->
+    let backup = List.map (fun (R (r, _)) -> R (r, !r)) refs in
+    set_refs refs;
+    Fun.protect ~finally:(fun () -> set_refs backup) f
+
+(* List functions *)
+
+let rec map_end f l1 l2 =
+  match l1 with
+    [] -> l2
+  | hd::tl -> f hd :: map_end f tl l2
+
+let rec map_left_right f = function
+    [] -> []
+  | hd::tl -> let res = f hd in res :: map_left_right f tl
+
+let rec for_all2 pred l1 l2 =
+  match (l1, l2) with
+    ([], []) -> true
+  | (hd1::tl1, hd2::tl2) -> pred hd1 hd2 && for_all2 pred tl1 tl2
+  | (_, _) -> false
+
+let rec replicate_list elem n =
+  if n <= 0 then [] else elem :: replicate_list elem (n-1)
+
+let rec list_remove x = function
+    [] -> []
+  | hd :: tl ->
+      if hd = x then tl else hd :: list_remove x tl
+
+let rec split_last = function
+    [] -> assert false
+  | [x] -> ([], x)
+  | hd :: tl ->
+      let (lst, last) = split_last tl in
+      (hd :: lst, last)
+
+module Stdlib = struct
+  module List = struct
+    type 'a t = 'a list
+
+    let rec compare cmp l1 l2 =
+      match l1, l2 with
+      | [], [] -> 0
+      | [], _::_ -> -1
+      | _::_, [] -> 1
+      | h1::t1, h2::t2 ->
+        let c = cmp h1 h2 in
+        if c <> 0 then c
+        else compare cmp t1 t2
+
+    let rec equal eq l1 l2 =
+      match l1, l2 with
+      | ([], []) -> true
+      | (hd1 :: tl1, hd2 :: tl2) -> eq hd1 hd2 && equal eq tl1 tl2
+      | (_, _) -> false
+
+    let rec find_map f = function
+      | x :: xs ->
+          begin match f x with
+          | None -> find_map f xs
+          | Some _ as y -> y
+          end
+      | [] -> None
+
+    let map2_prefix f l1 l2 =
+      let rec aux acc l1 l2 =
+        match l1, l2 with
+        | [], _ -> (List.rev acc, l2)
+        | _ :: _, [] -> raise (Invalid_argument "map2_prefix")
+        | h1::t1, h2::t2 ->
+          let h = f h1 h2 in
+          aux (h :: acc) t1 t2
+      in
+      aux [] l1 l2
+
+    let some_if_all_elements_are_some l =
+      let rec aux acc l =
+        match l with
+        | [] -> Some (List.rev acc)
+        | None :: _ -> None
+        | Some h :: t -> aux (h :: acc) t
+      in
+      aux [] l
+
+    let split_at n l =
+      let rec aux n acc l =
+        if n = 0
+        then List.rev acc, l
+        else
+          match l with
+          | [] -> raise (Invalid_argument "split_at")
+          | t::q -> aux (n-1) (t::acc) q
+      in
+      aux n [] l
+
+    let rec is_prefix ~equal t ~of_ =
+      match t, of_ with
+      | [], [] -> true
+      | _::_, [] -> false
+      | [], _::_ -> true
+      | x1::t, x2::of_ -> equal x1 x2 && is_prefix ~equal t ~of_
+
+    type 'a longest_common_prefix_result = {
+      longest_common_prefix : 'a list;
+      first_without_longest_common_prefix : 'a list;
+      second_without_longest_common_prefix : 'a list;
+    }
+
+    let find_and_chop_longest_common_prefix ~equal ~first ~second =
+      let rec find_prefix ~longest_common_prefix_rev l1 l2 =
+        match l1, l2 with
+        | elt1 :: l1, elt2 :: l2 when equal elt1 elt2 ->
+          let longest_common_prefix_rev = elt1 :: longest_common_prefix_rev in
+          find_prefix ~longest_common_prefix_rev l1 l2
+        | l1, l2 ->
+          { longest_common_prefix = List.rev longest_common_prefix_rev;
+            first_without_longest_common_prefix = l1;
+            second_without_longest_common_prefix = l2;
+          }
+      in
+      find_prefix ~longest_common_prefix_rev:[] first second
+  end
+
+  module Option = struct
+    type 'a t = 'a option
+
+    let print print_contents ppf t =
+      match t with
+      | None -> Format.pp_print_string ppf "None"
+      | Some contents ->
+        Format.fprintf ppf "@[(Some@ %a)@]" print_contents contents
+  end
+
+  module Array = struct
+    let exists2 p a1 a2 =
+      let n = Array.length a1 in
+      if Array.length a2 <> n then invalid_arg "Misc.Stdlib.Array.exists2";
+      let rec loop i =
+        if i = n then false
+        else if p (Array.unsafe_get a1 i) (Array.unsafe_get a2 i) then true
+        else loop (succ i) in
+      loop 0
+
+    let for_alli p a =
+      let n = Array.length a in
+      let rec loop i =
+        if i = n then true
+        else if p i (Array.unsafe_get a i) then loop (succ i)
+        else false in
+      loop 0
+
+    let all_somes a =
+      try
+        Some (Array.map (function None -> raise_notrace Exit | Some x -> x) a)
+      with
+      | Exit -> None
+  end
+
+  module String = struct
+    include String
+    module Set = Set.Make(String)
+    module Map = Map.Make(String)
+    module Tbl = Hashtbl.Make(struct
+      include String
+      let hash = Hashtbl.hash
+    end)
+
+    let for_all f t =
+      let len = String.length t in
+      let rec loop i =
+        i = len || (f t.[i] && loop (i + 1))
+      in
+      loop 0
+
+    let print ppf t =
+      Format.pp_print_string ppf t
+  end
+
+  external compare : 'a -> 'a -> int = "%compare"
+end
+
+(* File functions *)
+
+let find_in_path path name =
+  if not (Filename.is_implicit name) then
+    if Sys.file_exists name then name else raise Not_found
+  else begin
+    let rec try_dir = function
+      [] -> raise Not_found
+    | dir::rem ->
+        let fullname = Filename.concat dir name in
+        if Sys.file_exists fullname then fullname else try_dir rem
+    in try_dir path
+  end
+
+let find_in_path_rel path name =
+  let rec simplify s =
+    let open Filename in
+    let base = basename s in
+    let dir = dirname s in
+    if dir = s then dir
+    else if base = current_dir_name then simplify dir
+    else concat (simplify dir) base
+  in
+  let rec try_dir = function
+    [] -> raise Not_found
+  | dir::rem ->
+      let fullname = simplify (Filename.concat dir name) in
+      if Sys.file_exists fullname then fullname else try_dir rem
+  in try_dir path
+
+let find_in_path_uncap path name =
+  let uname = String.uncapitalize_ascii name in
+  let rec try_dir = function
+    [] -> raise Not_found
+  | dir::rem ->
+      let fullname = Filename.concat dir name
+      and ufullname = Filename.concat dir uname in
+      if Sys.file_exists ufullname then ufullname
+      else if Sys.file_exists fullname then fullname
+      else try_dir rem
+  in try_dir path
+
+let remove_file filename =
+  try
+    if Sys.file_exists filename
+    then Sys.remove filename
+  with Sys_error _msg ->
+    ()
+
+(* Expand a -I option: if it starts with +, make it relative to the standard
+   library directory *)
+
+let expand_directory alt s =
+  if String.length s > 0 && s.[0] = '+'
+  then Filename.concat alt
+                       (String.sub s 1 (String.length s - 1))
+  else s
+
+let path_separator =
+  match Sys.os_type with
+  | "Win32" -> ';'
+  | _ -> ':'
+
+let split_path_contents ?(sep = path_separator) = function
+  | "" -> []
+  | s -> String.split_on_char sep s
+
+(* Hashtable functions *)
+
+let create_hashtable size init =
+  let tbl = Hashtbl.create size in
+  List.iter (fun (key, data) -> Hashtbl.add tbl key data) init;
+  tbl
+
+(* File copy *)
+
+let copy_file ic oc =
+  let buff = Bytes.create 0x1000 in
+  let rec copy () =
+    let n = input ic buff 0 0x1000 in
+    if n = 0 then () else (output oc buff 0 n; copy())
+  in copy()
+
+let copy_file_chunk ic oc len =
+  let buff = Bytes.create 0x1000 in
+  let rec copy n =
+    if n <= 0 then () else begin
+      let r = input ic buff 0 (min n 0x1000) in
+      if r = 0 then raise End_of_file else (output oc buff 0 r; copy(n-r))
+    end
+  in copy len
+
+let string_of_file ic =
+  let b = Buffer.create 0x10000 in
+  let buff = Bytes.create 0x1000 in
+  let rec copy () =
+    let n = input ic buff 0 0x1000 in
+    if n = 0 then Buffer.contents b else
+      (Buffer.add_subbytes b buff 0 n; copy())
+  in copy()
+
+let output_to_file_via_temporary ?(mode = [Open_text]) filename fn =
+  let (temp_filename, oc) =
+    Filename.open_temp_file
+       ~mode ~perms:0o666 ~temp_dir:(Filename.dirname filename)
+       (Filename.basename filename) ".tmp" in
+    (* The 0o666 permissions will be modified by the umask.  It's just
+       like what [open_out] and [open_out_bin] do.
+       With temp_dir = dirname filename, we ensure that the returned
+       temp file is in the same directory as filename itself, making
+       it safe to rename temp_filename to filename later.
+       With prefix = basename filename, we are almost certain that
+       the first generated name will be unique.  A fixed prefix
+       would work too but might generate more collisions if many
+       files are being produced simultaneously in the same directory. *)
+  match fn temp_filename oc with
+  | res ->
+      close_out oc;
+      begin try
+        Sys.rename temp_filename filename; res
+      with exn ->
+        remove_file temp_filename; raise exn
+      end
+  | exception exn ->
+      close_out oc; remove_file temp_filename; raise exn
+
+let protect_writing_to_file ~filename ~f =
+  let outchan = open_out_bin filename in
+  try_finally ~always:(fun () -> close_out outchan)
+    ~exceptionally:(fun () -> remove_file filename)
+    (fun () -> f outchan)
+
+(* Integer operations *)
+
+let rec log2 n =
+  if n <= 1 then 0 else 1 + log2(n asr 1)
+
+let align n a =
+  if n >= 0 then (n + a - 1) land (-a) else n land (-a)
+
+let no_overflow_add a b = (a lxor b) lor (a lxor (lnot (a+b))) < 0
+
+let no_overflow_sub a b = (a lxor (lnot b)) lor (b lxor (a-b)) < 0
+
+(* Taken from Hacker's Delight, chapter "Overflow Detection" *)
+let no_overflow_mul a b =
+  not ((a = min_int && b < 0) || (b <> 0 && (a * b) / b <> a))
+
+let no_overflow_lsl a k =
+  0 <= k && k < Sys.word_size - 1 && min_int asr k <= a && a <= max_int asr k
+
+module Int_literal_converter = struct
+  (* To convert integer literals, allowing max_int + 1 (PR#4210) *)
+  let cvt_int_aux str neg of_string =
+    if String.length str = 0 || str.[0]= '-'
+    then of_string str
+    else neg (of_string ("-" ^ str))
+  let int s = cvt_int_aux s (~-) int_of_string
+  let int32 s = cvt_int_aux s Int32.neg Int32.of_string
+  let int64 s = cvt_int_aux s Int64.neg Int64.of_string
+  let nativeint s = cvt_int_aux s Nativeint.neg Nativeint.of_string
+end
+
+(* String operations *)
+
+let chop_extensions file =
+  let dirname = Filename.dirname file and basename = Filename.basename file in
+  try
+    let pos = String.index basename '.' in
+    let basename = String.sub basename 0 pos in
+    if Filename.is_implicit file && dirname = Filename.current_dir_name then
+      basename
+    else
+      Filename.concat dirname basename
+  with Not_found -> file
+
+let search_substring pat str start =
+  let rec search i j =
+    if j >= String.length pat then i
+    else if i + j >= String.length str then raise Not_found
+    else if str.[i + j] = pat.[j] then search i (j+1)
+    else search (i+1) 0
+  in search start 0
+
+let replace_substring ~before ~after str =
+  let rec search acc curr =
+    match search_substring before str curr with
+      | next ->
+         let prefix = String.sub str curr (next - curr) in
+         search (prefix :: acc) (next + String.length before)
+      | exception Not_found ->
+        let suffix = String.sub str curr (String.length str - curr) in
+        List.rev (suffix :: acc)
+  in String.concat after (search [] 0)
+
+let rev_split_words s =
+  let rec split1 res i =
+    if i >= String.length s then res else begin
+      match s.[i] with
+        ' ' | '\t' | '\r' | '\n' -> split1 res (i+1)
+      | _ -> split2 res i (i+1)
+    end
+  and split2 res i j =
+    if j >= String.length s then String.sub s i (j-i) :: res else begin
+      match s.[j] with
+        ' ' | '\t' | '\r' | '\n' -> split1 (String.sub s i (j-i) :: res) (j+1)
+      | _ -> split2 res i (j+1)
+    end
+  in split1 [] 0
+
+let get_ref r =
+  let v = !r in
+  r := []; v
+
+let set_or_ignore f opt x =
+  match f x with
+  | None -> ()
+  | Some y -> opt := Some y
+
+let fst3 (x, _, _) = x
+let snd3 (_,x,_) = x
+let thd3 (_,_,x) = x
+
+let fst4 (x, _, _, _) = x
+let snd4 (_,x,_, _) = x
+let thd4 (_,_,x,_) = x
+let for4 (_,_,_,x) = x
+
+
+module LongString = struct
+  type t = bytes array
+
+  let create str_size =
+    let tbl_size = str_size / Sys.max_string_length + 1 in
+    let tbl = Array.make tbl_size Bytes.empty in
+    for i = 0 to tbl_size - 2 do
+      tbl.(i) <- Bytes.create Sys.max_string_length;
+    done;
+    tbl.(tbl_size - 1) <- Bytes.create (str_size mod Sys.max_string_length);
+    tbl
+
+  let length tbl =
+    let tbl_size = Array.length tbl in
+    Sys.max_string_length * (tbl_size - 1) + Bytes.length tbl.(tbl_size - 1)
+
+  let get tbl ind =
+    Bytes.get tbl.(ind / Sys.max_string_length) (ind mod Sys.max_string_length)
+
+  let set tbl ind c =
+    Bytes.set tbl.(ind / Sys.max_string_length) (ind mod Sys.max_string_length)
+              c
+
+  let blit src srcoff dst dstoff len =
+    for i = 0 to len - 1 do
+      set dst (dstoff + i) (get src (srcoff + i))
+    done
+
+  let blit_string src srcoff dst dstoff len =
+    for i = 0 to len - 1 do
+      set dst (dstoff + i) (String.get src (srcoff + i))
+    done
+
+  let output oc tbl pos len =
+    for i = pos to pos + len - 1 do
+      output_char oc (get tbl i)
+    done
+
+  let input_bytes_into tbl ic len =
+    let count = ref len in
+    Array.iter (fun str ->
+      let chunk = min !count (Bytes.length str) in
+      really_input ic str 0 chunk;
+      count := !count - chunk) tbl
+
+  let input_bytes ic len =
+    let tbl = create len in
+    input_bytes_into tbl ic len;
+    tbl
+end
+
+
+let edit_distance a b cutoff =
+  let la, lb = String.length a, String.length b in
+  let cutoff =
+    (* using max_int for cutoff would cause overflows in (i + cutoff + 1);
+       we bring it back to the (max la lb) worstcase *)
+    min (max la lb) cutoff in
+  if abs (la - lb) > cutoff then None
+  else begin
+    (* initialize with 'cutoff + 1' so that not-yet-written-to cases have
+       the worst possible cost; this is useful when computing the cost of
+       a case just at the boundary of the cutoff diagonal. *)
+    let m = Array.make_matrix (la + 1) (lb + 1) (cutoff + 1) in
+    m.(0).(0) <- 0;
+    for i = 1 to la do
+      m.(i).(0) <- i;
+    done;
+    for j = 1 to lb do
+      m.(0).(j) <- j;
+    done;
+    for i = 1 to la do
+      for j = max 1 (i - cutoff - 1) to min lb (i + cutoff + 1) do
+        let cost = if a.[i-1] = b.[j-1] then 0 else 1 in
+        let best =
+          (* insert, delete or substitute *)
+          min (1 + min m.(i-1).(j) m.(i).(j-1)) (m.(i-1).(j-1) + cost)
+        in
+        let best =
+          (* swap two adjacent letters; we use "cost" again in case of
+             a swap between two identical letters; this is slightly
+             redundant as this is a double-substitution case, but it
+             was done this way in most online implementations and
+             imitation has its virtues *)
+          if not (i > 1 && j > 1 && a.[i-1] = b.[j-2] && a.[i-2] = b.[j-1])
+          then best
+          else min best (m.(i-2).(j-2) + cost)
+        in
+        m.(i).(j) <- best
+      done;
+    done;
+    let result = m.(la).(lb) in
+    if result > cutoff
+    then None
+    else Some result
+  end
+
+let spellcheck env name =
+  let cutoff =
+    match String.length name with
+      | 1 | 2 -> 0
+      | 3 | 4 -> 1
+      | 5 | 6 -> 2
+      | _ -> 3
+  in
+  let compare target acc head =
+    match edit_distance target head cutoff with
+      | None -> acc
+      | Some dist ->
+         let (best_choice, best_dist) = acc in
+         if dist < best_dist then ([head], dist)
+         else if dist = best_dist then (head :: best_choice, dist)
+         else acc
+  in
+  let env = List.sort_uniq (fun s1 s2 -> String.compare s2 s1) env in
+  fst (List.fold_left (compare name) ([], max_int) env)
+
+let did_you_mean ppf get_choices =
+  (* flush now to get the error report early, in the (unheard of) case
+     where the search in the get_choices function would take a bit of
+     time; in the worst case, the user has seen the error, she can
+     interrupt the process before the spell-checking terminates. *)
+  Format.fprintf ppf "@?";
+  match get_choices () with
+  | [] -> ()
+  | choices ->
+     let rest, last = split_last choices in
+     Format.fprintf ppf "@\nHint: Did you mean %s%s%s?@?"
+       (String.concat ", " rest)
+       (if rest = [] then "" else " or ")
+       last
+
+let cut_at s c =
+  let pos = String.index s c in
+  String.sub s 0 pos, String.sub s (pos+1) (String.length s - pos - 1)
+
+(* Color handling *)
+module Color = struct
+  (* use ANSI color codes, see https://en.wikipedia.org/wiki/ANSI_escape_code *)
+  type color =
+    | Black
+    | Red
+    | Green
+    | Yellow
+    | Blue
+    | Magenta
+    | Cyan
+    | White
+  ;;
+
+  type style =
+    | FG of color (* foreground *)
+    | BG of color (* background *)
+    | Bold
+    | Reset
+
+  let ansi_of_color = function
+    | Black -> "0"
+    | Red -> "1"
+    | Green -> "2"
+    | Yellow -> "3"
+    | Blue -> "4"
+    | Magenta -> "5"
+    | Cyan -> "6"
+    | White -> "7"
+
+  let code_of_style = function
+    | FG c -> "3" ^ ansi_of_color c
+    | BG c -> "4" ^ ansi_of_color c
+    | Bold -> "1"
+    | Reset -> "0"
+
+  let ansi_of_style_l l =
+    let s = match l with
+      | [] -> code_of_style Reset
+      | [s] -> code_of_style s
+      | _ -> String.concat ";" (List.map code_of_style l)
+    in
+    "\x1b[" ^ s ^ "m"
+
+  type styles = {
+    error: style list;
+    warning: style list;
+    loc: style list;
+  }
+
+  let default_styles = {
+    warning = [Bold; FG Magenta];
+    error = [Bold; FG Red];
+    loc = [Bold];
+  }
+
+  let cur_styles = ref default_styles
+  let get_styles () = !cur_styles
+  let set_styles s = cur_styles := s
+
+  (* map a tag to a style, if the tag is known.
+     @raise Not_found otherwise *)
+  let style_of_tag s = match s with
+    | Format.String_tag "error" -> (!cur_styles).error
+    | Format.String_tag "warning" -> (!cur_styles).warning
+    | Format.String_tag "loc" -> (!cur_styles).loc
+    | _ -> raise Not_found
+
+  let color_enabled = ref true
+
+  (* either prints the tag of [s] or delegates to [or_else] *)
+  let mark_open_tag ~or_else s =
+    try
+      let style = style_of_tag s in
+      if !color_enabled then ansi_of_style_l style else ""
+    with Not_found -> or_else s
+
+  let mark_close_tag ~or_else s =
+    try
+      let _ = style_of_tag s in
+      if !color_enabled then ansi_of_style_l [Reset] else ""
+    with Not_found -> or_else s
+
+  (* add color handling to formatter [ppf] *)
+  let set_color_tag_handling ppf =
+    let open Format in
+    let functions = pp_get_formatter_stag_functions ppf () in
+    let functions' = {functions with
+      mark_open_stag=(mark_open_tag ~or_else:functions.mark_open_stag);
+      mark_close_stag=(mark_close_tag ~or_else:functions.mark_close_stag);
+    } in
+    pp_set_mark_tags ppf true; (* enable tags *)
+    pp_set_formatter_stag_functions ppf functions';
+    ()
+
+  external isatty : out_channel -> bool = "caml_sys_isatty"
+
+  (* reasonable heuristic on whether colors should be enabled *)
+  let should_enable_color () =
+    let term = try Sys.getenv "TERM" with Not_found -> "" in
+    term <> "dumb"
+    && term <> ""
+    && isatty stderr
+
+  type setting = Auto | Always | Never
+
+  let default_setting = Auto
+
+  let setup =
+    let first = ref true in (* initialize only once *)
+    let formatter_l =
+      [Format.std_formatter; Format.err_formatter; Format.str_formatter]
+    in
+    let enable_color = function
+      | Auto -> should_enable_color ()
+      | Always -> true
+      | Never -> false
+    in
+    fun o ->
+      if !first then (
+        first := false;
+        Format.set_mark_tags true;
+        List.iter set_color_tag_handling formatter_l;
+        color_enabled := (match o with
+          | Some s -> enable_color s
+          | None -> enable_color default_setting)
+      );
+      ()
+end
+
+module Error_style = struct
+  type setting =
+    | Contextual
+    | Short
+
+  let default_setting = Contextual
+end
+
+let normalise_eol s =
+  let b = Buffer.create 80 in
+    for i = 0 to String.length s - 1 do
+      if s.[i] <> '\r' then Buffer.add_char b s.[i]
+    done;
+    Buffer.contents b
+
+let delete_eol_spaces src =
+  let len_src = String.length src in
+  let dst = Bytes.create len_src in
+  let rec loop i_src i_dst =
+    if i_src = len_src then
+      i_dst
+    else
+      match src.[i_src] with
+      | ' ' | '\t' ->
+        loop_spaces 1 (i_src + 1) i_dst
+      | c ->
+        Bytes.set dst i_dst c;
+        loop (i_src + 1) (i_dst + 1)
+  and loop_spaces spaces i_src i_dst =
+    if i_src = len_src then
+      i_dst
+    else
+      match src.[i_src] with
+      | ' ' | '\t' ->
+        loop_spaces (spaces + 1) (i_src + 1) i_dst
+      | '\n' ->
+        Bytes.set dst i_dst '\n';
+        loop (i_src + 1) (i_dst + 1)
+      | _ ->
+        for n = 0 to spaces do
+          Bytes.set dst (i_dst + n) src.[i_src - spaces + n]
+        done;
+        loop (i_src + 1) (i_dst + spaces + 1)
+  in
+  let stop = loop 0 0 in
+  Bytes.sub_string dst 0 stop
+
+let pp_two_columns ?(sep = "|") ?max_lines ppf (lines: (string * string) list) =
+  let left_column_size =
+    List.fold_left (fun acc (s, _) -> max acc (String.length s)) 0 lines in
+  let lines_nb = List.length lines in
+  let ellipsed_first, ellipsed_last =
+    match max_lines with
+    | Some max_lines when lines_nb > max_lines ->
+        let printed_lines = max_lines - 1 in (* the ellipsis uses one line *)
+        let lines_before = printed_lines / 2 + printed_lines mod 2 in
+        let lines_after = printed_lines / 2 in
+        (lines_before, lines_nb - lines_after - 1)
+    | _ -> (-1, -1)
+  in
+  Format.fprintf ppf "@[<v>";
+  List.iteri (fun k (line_l, line_r) ->
+    if k = ellipsed_first then Format.fprintf ppf "...@,";
+    if ellipsed_first <= k && k <= ellipsed_last then ()
+    else Format.fprintf ppf "%*s %s %s@," left_column_size line_l sep line_r
+  ) lines;
+  Format.fprintf ppf "@]"
+
+(* showing configuration and configuration variables *)
+let show_config_and_exit () =
+  Config.print_config stdout;
+  exit 0
+
+let show_config_variable_and_exit x =
+  match Config.config_var x with
+  | Some v ->
+      (* we intentionally don't print a newline to avoid Windows \r
+         issues: bash only strips the trailing \n when using a command
+         substitution $(ocamlc -config-var foo), so a trailing \r would
+         remain if printing a newline under Windows and scripts would
+         have to use $(ocamlc -config-var foo | tr -d '\r')
+         for portability. Ugh. *)
+      print_string v;
+      exit 0
+  | None ->
+      exit 2
+
+let get_build_path_prefix_map =
+  let init = ref false in
+  let map_cache = ref None in
+  fun () ->
+    if not !init then begin
+      init := true;
+      match Sys.getenv "BUILD_PATH_PREFIX_MAP" with
+      | exception Not_found -> ()
+      | encoded_map ->
+        match Build_path_prefix_map.decode_map encoded_map with
+          | Error err ->
+              fatal_errorf
+                "Invalid value for the environment variable \
+                 BUILD_PATH_PREFIX_MAP: %s" err
+          | Ok map -> map_cache := Some map
+    end;
+    !map_cache
+
+let debug_prefix_map_flags () =
+  if not Config.as_has_debug_prefix_map then
+    []
+  else begin
+    match get_build_path_prefix_map () with
+    | None -> []
+    | Some map ->
+      List.fold_right
+        (fun map_elem acc ->
+           match map_elem with
+           | None -> acc
+           | Some { Build_path_prefix_map.target; source; } ->
+             (Printf.sprintf "--debug-prefix-map %s=%s"
+                (Filename.quote source)
+                (Filename.quote target)) :: acc)
+        map
+        []
+  end
+
+let print_if ppf flag printer arg =
+  if !flag then Format.fprintf ppf "%a@." printer arg;
+  arg
+
+
+type filepath = string
+type modname = string
+type crcs = (modname * Digest.t option) list
+
+type alerts = string Stdlib.String.Map.t
+
+
+module EnvLazy = struct
+  type ('a,'b) t = ('a,'b) eval ref
+
+  and ('a,'b) eval =
+    | Done of 'b
+    | Raise of exn
+    | Thunk of 'a
+
+  type undo =
+    | Nil
+    | Cons : ('a, 'b) t * 'a * undo -> undo
+
+  type log = undo ref
+
+  let force f x =
+    match !x with
+    | Done x -> x
+    | Raise e -> raise e
+    | Thunk e ->
+        match f e with
+        | y ->
+          x := Done y;
+          y
+        | exception e ->
+          x := Raise e;
+          raise e
+
+  let get_arg x =
+    match !x with Thunk a -> Some a | _ -> None
+
+  let create x =
+    ref (Thunk x)
+
+  let create_forced y =
+    ref (Done y)
+
+  let create_failed e =
+    ref (Raise e)
+
+  let log () =
+    ref Nil
+
+  let force_logged log f x =
+    match !x with
+    | Done x -> x
+    | Raise e -> raise e
+    | Thunk e ->
+      match f e with
+      | (Error _ as err : _ result) ->
+          x := Done err;
+          log := Cons(x, e, !log);
+          err
+      | Ok _ as res ->
+          x := Done res;
+          res
+      | exception e ->
+          x := Raise e;
+          raise e
+
+  let backtrack log =
+    let rec loop = function
+      | Nil -> ()
+      | Cons(x, e, rest) ->
+          x := Thunk e;
+          loop rest
+    in
+    loop !log
+
+end
+
+
+module Magic_number = struct
+  type native_obj_config = {
+    flambda : bool;
+  }
+  let native_obj_config = {
+    flambda = Config.flambda;
+  }
+
+  type version = int
+
+  type kind =
+    | Exec
+    | Cmi | Cmo | Cma
+    | Cmx of native_obj_config | Cmxa of native_obj_config
+    | Cmxs
+    | Cmt
+    | Ast_impl | Ast_intf
+
+  (* please keep up-to-date, this is used for sanity checking *)
+  let all_native_obj_configs = [
+      {flambda = true};
+      {flambda = false};
+    ]
+  let all_kinds = [
+    Exec;
+    Cmi; Cmo; Cma;
+  ]
+  @ List.map (fun conf -> Cmx conf) all_native_obj_configs
+  @ List.map (fun conf -> Cmxa conf) all_native_obj_configs
+  @ [
+    Cmt;
+    Ast_impl; Ast_intf;
+  ]
+
+  type raw = string
+  type info = {
+    kind: kind;
+    version: version;
+  }
+
+  type raw_kind = string
+
+  let parse_kind : raw_kind -> kind option = function
+    | "Caml1999X" -> Some Exec
+    | "Caml1999I" -> Some Cmi
+    | "Caml1999O" -> Some Cmo
+    | "Caml1999A" -> Some Cma
+    | "Caml1999y" -> Some (Cmx {flambda = true})
+    | "Caml1999Y" -> Some (Cmx {flambda = false})
+    | "Caml1999z" -> Some (Cmxa {flambda = true})
+    | "Caml1999Z" -> Some (Cmxa {flambda = false})
+
+    (* Caml2007D and Caml2012T were used instead of the common Caml1999 prefix
+       between the introduction of those magic numbers and October 2017
+       (8ba70ff194b66c0a50ffb97d41fe9c4bdf9362d6).
+
+       We accept them here, but will always produce/show kind prefixes
+       that follow the current convention, Caml1999{D,T}. *)
+    | "Caml2007D" | "Caml1999D" -> Some Cmxs
+    | "Caml2012T" | "Caml1999T" -> Some Cmt
+
+    | "Caml1999M" -> Some Ast_impl
+    | "Caml1999N" -> Some Ast_intf
+    | _ -> None
+
+  (* note: over time the magic kind number has changed for certain kinds;
+     this function returns them as they are produced by the current compiler,
+     but [parse_kind] accepts older formats as well. *)
+  let raw_kind : kind -> raw = function
+    | Exec -> "Caml1999X"
+    | Cmi -> "Caml1999I"
+    | Cmo -> "Caml1999O"
+    | Cma -> "Caml1999A"
+    | Cmx config ->
+       if config.flambda
+       then "Caml1999y"
+       else "Caml1999Y"
+    | Cmxa config ->
+       if config.flambda
+       then "Caml1999z"
+       else "Caml1999Z"
+    | Cmxs -> "Caml1999D"
+    | Cmt -> "Caml1999T"
+    | Ast_impl -> "Caml1999M"
+    | Ast_intf -> "Caml1999N"
+
+  let string_of_kind : kind -> string = function
+    | Exec -> "exec"
+    | Cmi -> "cmi"
+    | Cmo -> "cmo"
+    | Cma -> "cma"
+    | Cmx _ -> "cmx"
+    | Cmxa _ -> "cmxa"
+    | Cmxs -> "cmxs"
+    | Cmt -> "cmt"
+    | Ast_impl -> "ast_impl"
+    | Ast_intf -> "ast_intf"
+
+  let human_description_of_native_obj_config : native_obj_config -> string =
+    fun[@warning "+9"] {flambda} ->
+      if flambda then "flambda" else "non flambda"
+
+  let human_name_of_kind : kind -> string = function
+    | Exec -> "executable"
+    | Cmi -> "compiled interface file"
+    | Cmo -> "bytecode object file"
+    | Cma -> "bytecode library"
+    | Cmx config ->
+       Printf.sprintf "native compilation unit description (%s)"
+         (human_description_of_native_obj_config config)
+    | Cmxa config ->
+       Printf.sprintf "static native library (%s)"
+         (human_description_of_native_obj_config config)
+    | Cmxs -> "dynamic native library"
+    | Cmt -> "compiled typedtree file"
+    | Ast_impl -> "serialized implementation AST"
+    | Ast_intf -> "serialized interface AST"
+
+  let kind_length = 9
+  let version_length = 3
+  let magic_length =
+    kind_length + version_length
+
+  type parse_error =
+    | Truncated of string
+    | Not_a_magic_number of string
+
+  let explain_parse_error kind_opt error =
+       Printf.sprintf
+         "We expected a valid %s, but the file %s."
+         (Option.fold ~none:"object file" ~some:human_name_of_kind kind_opt)
+         (match error with
+            | Truncated "" -> "is empty"
+            | Truncated _ -> "is truncated"
+            | Not_a_magic_number _ -> "has a different format")
+
+  let parse s : (info, parse_error) result =
+    if String.length s = magic_length then begin
+      let raw_kind = String.sub s 0 kind_length in
+      let raw_version = String.sub s kind_length version_length in
+      match parse_kind raw_kind with
+      | None -> Error (Not_a_magic_number s)
+      | Some kind ->
+          begin match int_of_string raw_version with
+          | exception _ -> Error (Truncated s)
+          | version -> Ok { kind; version }
+          end
+    end
+    else begin
+      (* a header is "truncated" if it starts like a valid magic number,
+         that is if its longest segment of length at most [kind_length]
+         is a prefix of [raw_kind kind] for some kind [kind] *)
+      let sub_length = min kind_length (String.length s) in
+      let starts_as kind =
+        String.sub s 0 sub_length = String.sub (raw_kind kind) 0 sub_length
+      in
+      if List.exists starts_as all_kinds then Error (Truncated s)
+      else Error (Not_a_magic_number s)
+    end
+
+  let read_info ic =
+    let header = Buffer.create magic_length in
+    begin
+      try Buffer.add_channel header ic magic_length
+      with End_of_file -> ()
+    end;
+    parse (Buffer.contents header)
+
+  let raw { kind; version; } =
+    Printf.sprintf "%s%03d" (raw_kind kind) version
+
+  let current_raw kind =
+    let open Config in
+    match[@warning "+9"] kind with
+      | Exec -> exec_magic_number
+      | Cmi -> cmi_magic_number
+      | Cmo -> cmo_magic_number
+      | Cma -> cma_magic_number
+      | Cmx config ->
+         (* the 'if' guarantees that in the common case
+            we return the "trusted" value from Config. *)
+         let reference = cmx_magic_number in
+         if config = native_obj_config then reference
+         else
+           (* otherwise we stitch together the magic number
+              for a different configuration by concatenating
+              the right magic kind at this configuration
+              and the rest of the current raw number for our configuration. *)
+           let raw_kind = raw_kind kind in
+           let len = String.length raw_kind in
+           raw_kind ^ String.sub reference len (String.length reference - len)
+      | Cmxa config ->
+         let reference = cmxa_magic_number in
+         if config = native_obj_config then reference
+         else
+           let raw_kind = raw_kind kind in
+           let len = String.length raw_kind in
+           raw_kind ^ String.sub reference len (String.length reference - len)
+      | Cmxs -> cmxs_magic_number
+      | Cmt -> cmt_magic_number
+      | Ast_intf -> ast_intf_magic_number
+      | Ast_impl -> ast_impl_magic_number
+
+  (* it would seem more direct to define current_version with the
+     correct numbers and current_raw on top of it, but for now we
+     consider the Config.foo values to be ground truth, and don't want
+     to trust the present module instead. *)
+  let current_version kind =
+    let raw = current_raw kind in
+    try int_of_string (String.sub raw kind_length version_length)
+    with _ -> assert false
+
+  type 'a unexpected = { expected : 'a; actual : 'a }
+  type unexpected_error =
+    | Kind of kind unexpected
+    | Version of kind * version unexpected
+
+  let explain_unexpected_error = function
+    | Kind { actual; expected } ->
+        Printf.sprintf "We expected a %s (%s) but got a %s (%s) instead."
+          (human_name_of_kind expected) (string_of_kind expected)
+          (human_name_of_kind actual) (string_of_kind actual)
+    | Version (kind, { actual; expected }) ->
+        Printf.sprintf "This seems to be a %s (%s) for %s version of OCaml."
+          (human_name_of_kind kind) (string_of_kind kind)
+          (if actual < expected then "an older" else "a newer")
+
+  let check_current expected_kind { kind; version } : _ result =
+    if kind <> expected_kind then begin
+      let actual, expected = kind, expected_kind in
+      Error (Kind { actual; expected })
+    end else begin
+      let actual, expected = version, current_version kind in
+      if actual <> expected
+      then Error (Version (kind, { actual; expected }))
+      else Ok ()
+    end
+
+  type error =
+    | Parse_error of parse_error
+    | Unexpected_error of unexpected_error
+
+  let read_current_info ~expected_kind ic =
+    match read_info ic with
+      | Error err -> Error (Parse_error err)
+      | Ok info ->
+         let kind = Option.value ~default:info.kind expected_kind in
+         match check_current kind info with
+           | Error err -> Error (Unexpected_error err)
+           | Ok () -> Ok info
+end
diff --git a/upstream/ocaml_411/utils/misc.mli b/upstream/ocaml_411/utils/misc.mli
new file mode 100644
index 0000000..9af1059
--- /dev/null
+++ b/upstream/ocaml_411/utils/misc.mli
@@ -0,0 +1,688 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Miscellaneous useful types and functions
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+val fatal_error: string -> 'a
+val fatal_errorf: ('a, Format.formatter, unit, 'b) format4 -> 'a
+exception Fatal_error
+
+val try_finally :
+  ?always:(unit -> unit) ->
+  ?exceptionally:(unit -> unit) ->
+  (unit -> 'a) -> 'a
+(** [try_finally work ~always ~exceptionally] is designed to run code
+    in [work] that may fail with an exception, and has two kind of
+    cleanup routines: [always], that must be run after any execution
+    of the function (typically, freeing system resources), and
+    [exceptionally], that should be run only if [work] or [always]
+    failed with an exception (typically, undoing user-visible state
+    changes that would only make sense if the function completes
+    correctly). For example:
+
+    {[
+      let objfile = outputprefix ^ ".cmo" in
+      let oc = open_out_bin objfile in
+      Misc.try_finally
+        (fun () ->
+           bytecode
+           ++ Timings.(accumulate_time (Generate sourcefile))
+               (Emitcode.to_file oc modulename objfile);
+           Warnings.check_fatal ())
+        ~always:(fun () -> close_out oc)
+        ~exceptionally:(fun _exn -> remove_file objfile);
+    ]}
+
+    If [exceptionally] fail with an exception, it is propagated as
+    usual.
+
+    If [always] or [exceptionally] use exceptions internally for
+    control-flow but do not raise, then [try_finally] is careful to
+    preserve any exception backtrace coming from [work] or [always]
+    for easier debugging.
+*)
+
+
+val map_end: ('a -> 'b) -> 'a list -> 'b list -> 'b list
+        (* [map_end f l t] is [map f l @ t], just more efficient. *)
+val map_left_right: ('a -> 'b) -> 'a list -> 'b list
+        (* Like [List.map], with guaranteed left-to-right evaluation order *)
+val for_all2: ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+        (* Same as [List.for_all] but for a binary predicate.
+           In addition, this [for_all2] never fails: given two lists
+           with different lengths, it returns false. *)
+val replicate_list: 'a -> int -> 'a list
+        (* [replicate_list elem n] is the list with [n] elements
+           all identical to [elem]. *)
+val list_remove: 'a -> 'a list -> 'a list
+        (* [list_remove x l] returns a copy of [l] with the first
+           element equal to [x] removed. *)
+val split_last: 'a list -> 'a list * 'a
+        (* Return the last element and the other elements of the given list. *)
+
+type ref_and_value = R : 'a ref * 'a -> ref_and_value
+
+val protect_refs : ref_and_value list -> (unit -> 'a) -> 'a
+(** [protect_refs l f] temporarily sets [r] to [v] for each [R (r, v)] in [l]
+    while executing [f]. The previous contents of the references is restored
+    even if [f] raises an exception, without altering the exception backtrace.
+*)
+
+module Stdlib : sig
+  module List : sig
+    type 'a t = 'a list
+
+    val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
+    (** The lexicographic order supported by the provided order.
+        There is no constraint on the relative lengths of the lists. *)
+
+    val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+    (** Returns [true] iff the given lists have the same length and content
+        with respect to the given equality function. *)
+
+    val find_map : ('a -> 'b option) -> 'a t -> 'b option
+    (** [find_map f l] returns the first evaluation of [f] that returns [Some],
+       or returns None if there is no such element. *)
+
+    val some_if_all_elements_are_some : 'a option t -> 'a t option
+    (** If all elements of the given list are [Some _] then [Some xs]
+        is returned with the [xs] being the contents of those [Some]s, with
+        order preserved.  Otherwise return [None]. *)
+
+    val map2_prefix : ('a -> 'b -> 'c) -> 'a t -> 'b t -> ('c t * 'b t)
+    (** [let r1, r2 = map2_prefix f l1 l2]
+        If [l1] is of length n and [l2 = h2 @ t2] with h2 of length n,
+        r1 is [List.map2 f l1 h1] and r2 is t2. *)
+
+    val split_at : int -> 'a t -> 'a t * 'a t
+    (** [split_at n l] returns the pair [before, after] where [before] is
+        the [n] first elements of [l] and [after] the remaining ones.
+        If [l] has less than [n] elements, raises Invalid_argument. *)
+
+    val is_prefix
+       : equal:('a -> 'a -> bool)
+      -> 'a list
+      -> of_:'a list
+      -> bool
+    (** Returns [true] iff the given list, with respect to the given equality
+        function on list members, is a prefix of the list [of_]. *)
+
+    type 'a longest_common_prefix_result = private {
+      longest_common_prefix : 'a list;
+      first_without_longest_common_prefix : 'a list;
+      second_without_longest_common_prefix : 'a list;
+    }
+
+    val find_and_chop_longest_common_prefix
+       : equal:('a -> 'a -> bool)
+      -> first:'a list
+      -> second:'a list
+      -> 'a longest_common_prefix_result
+    (** Returns the longest list that, with respect to the provided equality
+        function, is a prefix of both of the given lists.  The input lists,
+        each with such longest common prefix removed, are also returned. *)
+  end
+
+  module Option : sig
+    type 'a t = 'a option
+
+    val print
+       : (Format.formatter -> 'a -> unit)
+      -> Format.formatter
+      -> 'a t
+      -> unit
+  end
+
+  module Array : sig
+    val exists2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
+    (* Same as [Array.exists], but for a two-argument predicate. Raise
+       Invalid_argument if the two arrays are determined to have
+       different lengths. *)
+
+    val for_alli : (int -> 'a -> bool) -> 'a array -> bool
+    (** Same as {!Array.for_all}, but the
+        function is applied with the index of the element as first argument,
+        and the element itself as second argument. *)
+
+    val all_somes : 'a option array -> 'a array option
+  end
+
+  module String : sig
+    include module type of String
+    module Set : Set.S with type elt = string
+    module Map : Map.S with type key = string
+    module Tbl : Hashtbl.S with type key = string
+
+    val print : Format.formatter -> t -> unit
+
+    val for_all : (char -> bool) -> t -> bool
+  end
+
+  external compare : 'a -> 'a -> int = "%compare"
+end
+
+val find_in_path: string list -> string -> string
+        (* Search a file in a list of directories. *)
+val find_in_path_rel: string list -> string -> string
+        (* Search a relative file in a list of directories. *)
+val find_in_path_uncap: string list -> string -> string
+        (* Same, but search also for uncapitalized name, i.e.
+           if name is Foo.ml, allow /path/Foo.ml and /path/foo.ml
+           to match. *)
+val remove_file: string -> unit
+        (* Delete the given file if it exists. Never raise an error. *)
+val expand_directory: string -> string -> string
+        (* [expand_directory alt file] eventually expands a [+] at the
+           beginning of file into [alt] (an alternate root directory) *)
+
+val split_path_contents: ?sep:char -> string -> string list
+(* [split_path_contents ?sep s] interprets [s] as the value of a "PATH"-like
+   variable and returns the corresponding list of directories. [s] is split
+   using the platform-specific delimiter, or [~sep] if it is passed.
+
+   Returns the empty list if [s] is empty. *)
+
+val create_hashtable: int -> ('a * 'b) list -> ('a, 'b) Hashtbl.t
+        (* Create a hashtable of the given size and fills it with the
+           given bindings. *)
+
+val copy_file: in_channel -> out_channel -> unit
+        (* [copy_file ic oc] reads the contents of file [ic] and copies
+           them to [oc]. It stops when encountering EOF on [ic]. *)
+val copy_file_chunk: in_channel -> out_channel -> int -> unit
+        (* [copy_file_chunk ic oc n] reads [n] bytes from [ic] and copies
+           them to [oc]. It raises [End_of_file] when encountering
+           EOF on [ic]. *)
+val string_of_file: in_channel -> string
+        (* [string_of_file ic] reads the contents of file [ic] and copies
+           them to a string. It stops when encountering EOF on [ic]. *)
+val output_to_file_via_temporary:
+      ?mode:open_flag list -> string -> (string -> out_channel -> 'a) -> 'a
+        (* Produce output in temporary file, then rename it
+           (as atomically as possible) to the desired output file name.
+           [output_to_file_via_temporary filename fn] opens a temporary file
+           which is passed to [fn] (name + output channel).  When [fn] returns,
+           the channel is closed and the temporary file is renamed to
+           [filename]. *)
+
+(** Open the given [filename] for writing (in binary mode), pass the
+    [out_channel] to the given function, then close the channel. If the function
+    raises an exception then [filename] will be removed. *)
+val protect_writing_to_file
+   : filename:string
+  -> f:(out_channel -> 'a)
+  -> 'a
+
+val log2: int -> int
+        (* [log2 n] returns [s] such that [n = 1 lsl s]
+           if [n] is a power of 2*)
+val align: int -> int -> int
+        (* [align n a] rounds [n] upwards to a multiple of [a]
+           (a power of 2). *)
+val no_overflow_add: int -> int -> bool
+        (* [no_overflow_add n1 n2] returns [true] if the computation of
+           [n1 + n2] does not overflow. *)
+val no_overflow_sub: int -> int -> bool
+        (* [no_overflow_sub n1 n2] returns [true] if the computation of
+           [n1 - n2] does not overflow. *)
+val no_overflow_mul: int -> int -> bool
+        (* [no_overflow_mul n1 n2] returns [true] if the computation of
+           [n1 * n2] does not overflow. *)
+val no_overflow_lsl: int -> int -> bool
+        (* [no_overflow_lsl n k] returns [true] if the computation of
+           [n lsl k] does not overflow. *)
+
+module Int_literal_converter : sig
+  val int : string -> int
+  val int32 : string -> int32
+  val int64 : string -> int64
+  val nativeint : string -> nativeint
+end
+
+val chop_extensions: string -> string
+        (* Return the given file name without its extensions. The extensions
+           is the longest suffix starting with a period and not including
+           a directory separator, [.xyz.uvw] for instance.
+
+           Return the given name if it does not contain an extension. *)
+
+val search_substring: string -> string -> int -> int
+        (* [search_substring pat str start] returns the position of the first
+           occurrence of string [pat] in string [str].  Search starts
+           at offset [start] in [str].  Raise [Not_found] if [pat]
+           does not occur. *)
+
+val replace_substring: before:string -> after:string -> string -> string
+        (* [replace_substring ~before ~after str] replaces all
+           occurrences of [before] with [after] in [str] and returns
+           the resulting string. *)
+
+val rev_split_words: string -> string list
+        (* [rev_split_words s] splits [s] in blank-separated words, and returns
+           the list of words in reverse order. *)
+
+val get_ref: 'a list ref -> 'a list
+        (* [get_ref lr] returns the content of the list reference [lr] and reset
+           its content to the empty list. *)
+
+val set_or_ignore : ('a -> 'b option) -> 'b option ref -> 'a -> unit
+        (* [set_or_ignore f opt x] sets [opt] to [f x] if it returns [Some _],
+           or leaves it unmodified if it returns [None]. *)
+
+val fst3: 'a * 'b * 'c -> 'a
+val snd3: 'a * 'b * 'c -> 'b
+val thd3: 'a * 'b * 'c -> 'c
+
+val fst4: 'a * 'b * 'c * 'd -> 'a
+val snd4: 'a * 'b * 'c * 'd -> 'b
+val thd4: 'a * 'b * 'c * 'd -> 'c
+val for4: 'a * 'b * 'c * 'd -> 'd
+
+module LongString :
+  sig
+    type t = bytes array
+    val create : int -> t
+    val length : t -> int
+    val get : t -> int -> char
+    val set : t -> int -> char -> unit
+    val blit : t -> int -> t -> int -> int -> unit
+    val blit_string : string -> int -> t -> int -> int -> unit
+    val output : out_channel -> t -> int -> int -> unit
+    val input_bytes_into : t -> in_channel -> int -> unit
+    val input_bytes : in_channel -> int -> t
+  end
+
+val edit_distance : string -> string -> int -> int option
+(** [edit_distance a b cutoff] computes the edit distance between
+    strings [a] and [b]. To help efficiency, it uses a cutoff: if the
+    distance [d] is smaller than [cutoff], it returns [Some d], else
+    [None].
+
+    The distance algorithm currently used is Damerau-Levenshtein: it
+    computes the number of insertion, deletion, substitution of
+    letters, or swapping of adjacent letters to go from one word to the
+    other. The particular algorithm may change in the future.
+*)
+
+val spellcheck : string list -> string -> string list
+(** [spellcheck env name] takes a list of names [env] that exist in
+    the current environment and an erroneous [name], and returns a
+    list of suggestions taken from [env], that are close enough to
+    [name] that it may be a typo for one of them. *)
+
+val did_you_mean : Format.formatter -> (unit -> string list) -> unit
+(** [did_you_mean ppf get_choices] hints that the user may have meant
+    one of the option returned by calling [get_choices]. It does nothing
+    if the returned list is empty.
+
+    The [unit -> ...] thunking is meant to delay any potentially-slow
+    computation (typically computing edit-distance with many things
+    from the current environment) to when the hint message is to be
+    printed. You should print an understandable error message before
+    calling [did_you_mean], so that users get a clear notification of
+    the failure even if producing the hint is slow.
+*)
+
+val cut_at : string -> char -> string * string
+(** [String.cut_at s c] returns a pair containing the sub-string before
+   the first occurrence of [c] in [s], and the sub-string after the
+   first occurrence of [c] in [s].
+   [let (before, after) = String.cut_at s c in
+    before ^ String.make 1 c ^ after] is the identity if [s] contains [c].
+
+   Raise [Not_found] if the character does not appear in the string
+   @since 4.01
+*)
+
+(* Color handling *)
+module Color : sig
+  type color =
+    | Black
+    | Red
+    | Green
+    | Yellow
+    | Blue
+    | Magenta
+    | Cyan
+    | White
+  ;;
+
+  type style =
+    | FG of color (* foreground *)
+    | BG of color (* background *)
+    | Bold
+    | Reset
+
+  val ansi_of_style_l : style list -> string
+  (* ANSI escape sequence for the given style *)
+
+  type styles = {
+    error: style list;
+    warning: style list;
+    loc: style list;
+  }
+
+  val default_styles: styles
+  val get_styles: unit -> styles
+  val set_styles: styles -> unit
+
+  type setting = Auto | Always | Never
+
+  val default_setting : setting
+
+  val setup : setting option -> unit
+  (* [setup opt] will enable or disable color handling on standard formatters
+     according to the value of color setting [opt].
+     Only the first call to this function has an effect. *)
+
+  val set_color_tag_handling : Format.formatter -> unit
+  (* adds functions to support color tags to the given formatter. *)
+end
+
+(* See the -error-style option *)
+module Error_style : sig
+  type setting =
+    | Contextual
+    | Short
+
+  val default_setting : setting
+end
+
+val normalise_eol : string -> string
+(** [normalise_eol s] returns a fresh copy of [s] with any '\r' characters
+   removed. Intended for pre-processing text which will subsequently be printed
+   on a channel which performs EOL transformations (i.e. Windows) *)
+
+val delete_eol_spaces : string -> string
+(** [delete_eol_spaces s] returns a fresh copy of [s] with any end of
+   line spaces removed. Intended to normalize the output of the
+   toplevel for tests. *)
+
+val pp_two_columns :
+  ?sep:string -> ?max_lines:int ->
+  Format.formatter -> (string * string) list -> unit
+(** [pp_two_columns ?sep ?max_lines ppf l] prints the lines in [l] as two
+   columns separated by [sep] ("|" by default). [max_lines] can be used to
+   indicate a maximum number of lines to print -- an ellipsis gets inserted at
+   the middle if the input has too many lines.
+
+   Example:
+
+    {v pp_two_columns ~max_lines:3 Format.std_formatter [
+      "abc", "hello";
+      "def", "zzz";
+      "a"  , "bllbl";
+      "bb" , "dddddd";
+    ] v}
+
+    prints
+
+    {v
+    abc | hello
+    ...
+    bb  | dddddd
+    v}
+*)
+
+(** configuration variables *)
+val show_config_and_exit : unit -> unit
+val show_config_variable_and_exit : string -> unit
+
+val get_build_path_prefix_map: unit -> Build_path_prefix_map.map option
+(** Returns the map encoded in the [BUILD_PATH_PREFIX_MAP] environment
+    variable. *)
+
+val debug_prefix_map_flags: unit -> string list
+(** Returns the list of [--debug-prefix-map] flags to be passed to the
+    assembler, built from the [BUILD_PATH_PREFIX_MAP] environment variable. *)
+
+val print_if :
+  Format.formatter -> bool ref -> (Format.formatter -> 'a -> unit) -> 'a -> 'a
+(** [print_if ppf flag fmt x] prints [x] with [fmt] on [ppf] if [b] is true. *)
+
+
+type filepath = string
+type modname = string
+type crcs = (modname * Digest.t option) list
+
+type alerts = string Stdlib.String.Map.t
+
+
+module EnvLazy: sig
+  type ('a,'b) t
+
+  type log
+
+  val force : ('a -> 'b) -> ('a,'b) t -> 'b
+  val create : 'a -> ('a,'b) t
+  val get_arg : ('a,'b) t -> 'a option
+  val create_forced : 'b -> ('a, 'b) t
+  val create_failed : exn -> ('a, 'b) t
+
+  (* [force_logged log f t] is equivalent to [force f t] but if [f]
+     returns [Error _] then [t] is recorded in [log]. [backtrack log]
+     will then reset all the recorded [t]s back to their original
+     state. *)
+  val log : unit -> log
+  val force_logged :
+    log -> ('a -> ('b, 'c) result) -> ('a,('b, 'c) result) t -> ('b, 'c) result
+  val backtrack : log -> unit
+
+end
+
+
+module Magic_number : sig
+  (** a typical magic number is "Caml1999I011"; it is formed of an
+      alphanumeric prefix, here Caml1990I, followed by a version,
+      here 011. The prefix identifies the kind of the versioned data:
+      here the I indicates that it is the magic number for .cmi files.
+
+      All magic numbers have the same byte length, [magic_length], and
+      this is important for users as it gives them the number of bytes
+      to read to obtain the byte sequence that should be a magic
+      number. Typical user code will look like:
+      {[
+        let ic = open_in_bin path in
+        let magic =
+          try really_input_string ic Magic_number.magic_length
+          with End_of_file -> ... in
+        match Magic_number.parse magic with
+        | Error parse_error -> ...
+        | Ok info -> ...
+      ]}
+
+      A given compiler version expects one specific version for each
+      kind of object file, and will fail if given an unsupported
+      version. Because versions grow monotonically, you can compare
+      the parsed version with the expected "current version" for
+      a kind, to tell whether the wrong-magic object file comes from
+      the past or from the future.
+
+      An example of code block that expects the "currently supported version"
+      of a given kind of magic numbers, here [Cmxa], is as follows:
+      {[
+        let ic = open_in_bin path in
+        begin
+          try Magic_number.(expect_current Cmxa (get_info ic)) with
+          | Parse_error error -> ...
+          | Unexpected error -> ...
+        end;
+        ...
+      ]}
+
+      Parse errors distinguish inputs that are [Not_a_magic_number str],
+      which are likely to come from the file being completely
+      different, and [Truncated str], raised by headers that are the
+      (possibly empty) prefix of a valid magic number.
+
+      Unexpected errors correspond to valid magic numbers that are not
+      the one expected, either because it corresponds to a different
+      kind, or to a newer or older version.
+
+      The helper functions [explain_parse_error] and [explain_unexpected_error]
+      will generate a textual explanation of each error,
+      for use in error messages.
+
+      @since 4.11.0
+  *)
+
+  type native_obj_config = {
+    flambda : bool;
+  }
+  (** native object files have a format and magic number that depend
+     on certain native-compiler configuration parameters. This
+     configuration space is expressed by the [native_obj_config]
+     type. *)
+
+  val native_obj_config : native_obj_config
+  (** the native object file configuration of the active/configured compiler. *)
+
+  type version = int
+
+  type kind =
+    | Exec
+    | Cmi | Cmo | Cma
+    | Cmx of native_obj_config | Cmxa of native_obj_config
+    | Cmxs
+    | Cmt | Ast_impl | Ast_intf
+
+  type info = {
+    kind: kind;
+    version: version;
+    (** Note: some versions of the compiler use the same [version] suffix
+        for all kinds, but others use different versions counters for different
+        kinds. We may only assume that versions are growing monotonically
+        (not necessarily always by one) between compiler versions. *)
+  }
+
+  type raw = string
+  (** the type of raw magic numbers,
+      such as "Caml1999A027" for the .cma files of OCaml 4.10 *)
+
+  (** {3 Parsing magic numbers} *)
+
+  type parse_error =
+    | Truncated of string
+    | Not_a_magic_number of string
+
+  val explain_parse_error : kind option -> parse_error -> string
+  (** Produces an explanation for a parse error. If no kind is provided,
+      we use an unspecific formulation suggesting that any compiler-produced
+      object file would have been satisfying. *)
+
+  val parse : raw -> (info, parse_error) result
+  (** Parses a raw magic number *)
+
+  val read_info : in_channel -> (info, parse_error) result
+  (** Read a raw magic number from an input channel.
+
+      If the data read [str] is not a valid magic number, it can be
+      recovered from the [Truncated str | Not_a_magic_number str]
+      payload of the [Error parse_error] case.
+
+      If parsing succeeds with an [Ok info] result, we know that
+      exactly [magic_length] bytes have been consumed from the
+      input_channel.
+
+      If you also wish to enforce that the magic number
+      is at the current version, see {!read_current_info} below.
+   *)
+
+  val magic_length : int
+  (** all magic numbers take the same number of bytes *)
+
+
+  (** {3 Checking that magic numbers are current} *)
+
+  type 'a unexpected = { expected : 'a; actual : 'a }
+  type unexpected_error =
+    | Kind of kind unexpected
+    | Version of kind * version unexpected
+
+  val check_current : kind -> info -> (unit, unexpected_error) result
+  (** [check_current kind info] checks that the provided magic [info]
+      is the current version of [kind]'s magic header. *)
+
+  val explain_unexpected_error : unexpected_error -> string
+  (** Provides an explanation of the [unexpected_error]. *)
+
+  type error =
+    | Parse_error of parse_error
+    | Unexpected_error of unexpected_error
+
+  val read_current_info :
+    expected_kind:kind option -> in_channel -> (info, error) result
+  (** Read a magic number as [read_info],
+      and check that it is the current version as its kind.
+      If the [expected_kind] argument is [None], any kind is accepted. *)
+
+
+  (** {3 Information on magic numbers} *)
+
+  val string_of_kind : kind -> string
+  (** a user-printable string for a kind, eg. "exec" or "cmo", to use
+      in error messages. *)
+
+  val human_name_of_kind : kind -> string
+  (** a user-meaningful name for a kind, eg. "executable file" or
+      "bytecode object file", to use in error messages. *)
+
+  val current_raw : kind -> raw
+  (** the current magic number of each kind *)
+
+  val current_version : kind -> version
+  (** the current version of each kind *)
+
+
+  (** {3 Raw representations}
+
+      Mainly for internal usage and testing. *)
+
+  type raw_kind = string
+  (** the type of raw magic numbers kinds,
+      such as "Caml1999A" for .cma files *)
+
+  val parse_kind : raw_kind -> kind option
+  (** parse a raw kind into a kind *)
+
+  val raw_kind : kind -> raw_kind
+  (** the current raw representation of a kind.
+
+      In some cases the raw representation of a kind has changed
+      over compiler versions, so other files of the same kind
+      may have different raw kinds.
+      Note that all currently known cases are parsed correctly by [parse_kind].
+  *)
+
+  val raw : info -> raw
+  (** A valid raw representation of the magic number.
+
+      Due to past and future changes in the string representation of
+      magic numbers, we cannot guarantee that the raw strings returned
+      for past and future versions actually match the expectations of
+      those compilers. The representation is accurate for current
+      versions, and it is correctly parsed back into the desired
+      version by the parsing functions above.
+   *)
+
+  (**/**)
+
+  val all_kinds : kind list
+end
diff --git a/upstream/ocaml_411/utils/numbers.ml b/upstream/ocaml_411/utils/numbers.ml
new file mode 100644
index 0000000..1680675
--- /dev/null
+++ b/upstream/ocaml_411/utils/numbers.ml
@@ -0,0 +1,88 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Int_base = Identifiable.Make (struct
+  type t = int
+
+  let compare x y = x - y
+  let output oc x = Printf.fprintf oc "%i" x
+  let hash i = i
+  let equal (i : int) j = i = j
+  let print = Format.pp_print_int
+end)
+
+module Int = struct
+  type t = int
+
+  include Int_base
+
+  let rec zero_to_n n =
+    if n < 0 then Set.empty else Set.add n (zero_to_n (n-1))
+
+  let to_string n = Int.to_string n
+end
+
+module Int8 = struct
+  type t = int
+
+  let zero = 0
+  let one = 1
+
+  let of_int_exn i =
+    if i < -(1 lsl 7) || i > ((1 lsl 7) - 1) then
+      Misc.fatal_errorf "Int8.of_int_exn: %d is out of range" i
+    else
+      i
+
+  let to_int i = i
+end
+
+module Int16 = struct
+  type t = int
+
+  let of_int_exn i =
+    if i < -(1 lsl 15) || i > ((1 lsl 15) - 1) then
+      Misc.fatal_errorf "Int16.of_int_exn: %d is out of range" i
+    else
+      i
+
+  let lower_int64 = Int64.neg (Int64.shift_left Int64.one 15)
+  let upper_int64 = Int64.sub (Int64.shift_left Int64.one 15) Int64.one
+
+  let of_int64_exn i =
+    if Int64.compare i lower_int64 < 0
+        || Int64.compare i upper_int64 > 0
+    then
+      Misc.fatal_errorf "Int16.of_int64_exn: %Ld is out of range" i
+    else
+      Int64.to_int i
+
+  let to_int t = t
+end
+
+module Float = struct
+  type t = float
+
+  include Identifiable.Make (struct
+    type t = float
+
+    let compare x y = Stdlib.compare x y
+    let output oc x = Printf.fprintf oc "%f" x
+    let hash f = Hashtbl.hash f
+    let equal (i : float) j = i = j
+    let print = Format.pp_print_float
+  end)
+end
diff --git a/upstream/ocaml_411/utils/numbers.mli b/upstream/ocaml_411/utils/numbers.mli
new file mode 100644
index 0000000..fa565e6
--- /dev/null
+++ b/upstream/ocaml_411/utils/numbers.mli
@@ -0,0 +1,51 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Modules about numbers, some of which satisfy {!Identifiable.S}.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+module Int : sig
+  include Identifiable.S with type t = int
+
+  (** [zero_to_n n] is the set of numbers \{0, ..., n\} (inclusive). *)
+  val zero_to_n : int -> Set.t
+  val to_string : int -> string
+end
+
+module Int8 : sig
+  type t
+
+  val zero : t
+  val one : t
+
+  val of_int_exn : int -> t
+  val to_int : t -> int
+end
+
+module Int16 : sig
+  type t
+
+  val of_int_exn : int -> t
+  val of_int64_exn : Int64.t -> t
+
+  val to_int : t -> int
+end
+
+module Float : Identifiable.S with type t = float
diff --git a/upstream/ocaml_411/utils/profile.ml b/upstream/ocaml_411/utils/profile.ml
new file mode 100644
index 0000000..02e3a16
--- /dev/null
+++ b/upstream/ocaml_411/utils/profile.ml
@@ -0,0 +1,335 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Pierre Chambart, OCamlPro                         *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-18-40-42-48"]
+
+type file = string
+
+external time_include_children: bool -> float = "caml_sys_time_include_children"
+let cpu_time () = time_include_children true
+
+module Measure = struct
+  type t = {
+    time : float;
+    allocated_words : float;
+    top_heap_words : int;
+  }
+  let create () =
+    let stat = Gc.quick_stat () in
+    {
+      time = cpu_time ();
+      allocated_words = stat.minor_words +. stat.major_words;
+      top_heap_words = stat.top_heap_words;
+    }
+  let zero = { time = 0.; allocated_words = 0.; top_heap_words = 0 }
+end
+
+module Measure_diff = struct
+  let timestamp = let r = ref (-1) in fun () -> incr r; !r
+  type t = {
+    timestamp : int;
+    duration : float;
+    allocated_words : float;
+    top_heap_words_increase : int;
+  }
+  let zero () = {
+    timestamp = timestamp ();
+    duration = 0.;
+    allocated_words = 0.;
+    top_heap_words_increase = 0;
+  }
+  let accumulate t (m1 : Measure.t) (m2 : Measure.t) = {
+    timestamp = t.timestamp;
+    duration = t.duration +. (m2.time -. m1.time);
+    allocated_words =
+      t.allocated_words +. (m2.allocated_words -. m1.allocated_words);
+    top_heap_words_increase =
+      t.top_heap_words_increase + (m2.top_heap_words - m1.top_heap_words);
+  }
+  let of_diff m1 m2 =
+    accumulate (zero ()) m1 m2
+end
+
+type hierarchy =
+  | E of (string, Measure_diff.t * hierarchy) Hashtbl.t
+[@@unboxed]
+
+let create () = E (Hashtbl.create 2)
+let hierarchy = ref (create ())
+let initial_measure = ref None
+let reset () = hierarchy := create (); initial_measure := None
+
+let record_call ?(accumulate = false) name f =
+  let E prev_hierarchy = !hierarchy in
+  let start_measure = Measure.create () in
+  if !initial_measure = None then initial_measure := Some start_measure;
+  let this_measure_diff, this_table =
+    (* We allow the recording of multiple categories by the same name, for tools
+       like ocamldoc that use the compiler libs but don't care about profile
+       information, and so may record, say, "parsing" multiple times. *)
+    if accumulate
+    then
+      match Hashtbl.find prev_hierarchy name with
+      | exception Not_found -> Measure_diff.zero (), Hashtbl.create 2
+      | measure_diff, E table ->
+        Hashtbl.remove prev_hierarchy name;
+        measure_diff, table
+    else Measure_diff.zero (), Hashtbl.create 2
+  in
+  hierarchy := E this_table;
+  Misc.try_finally f
+    ~always:(fun () ->
+        hierarchy := E prev_hierarchy;
+        let end_measure = Measure.create () in
+        let measure_diff =
+          Measure_diff.accumulate this_measure_diff start_measure end_measure in
+        Hashtbl.add prev_hierarchy name (measure_diff, E this_table))
+
+let record ?accumulate pass f x = record_call ?accumulate pass (fun () -> f x)
+
+type display = {
+  to_string : max:float -> width:int -> string;
+  worth_displaying : max:float -> bool;
+}
+
+let time_display v : display =
+  (* Because indentation is meaningful, and because the durations are
+     the first element of each row, we can't pad them with spaces. *)
+  let to_string_without_unit v ~width = Printf.sprintf "%0*.03f" width v in
+  let to_string ~max:_ ~width =
+    to_string_without_unit v ~width:(width - 1) ^ "s" in
+  let worth_displaying ~max:_ =
+    float_of_string (to_string_without_unit v ~width:0) <> 0. in
+  { to_string; worth_displaying }
+
+let memory_word_display =
+  (* To make memory numbers easily comparable across rows, we choose a single
+     scale for an entire column. To keep the display compact and not overly
+     precise (no one cares about the exact number of bytes), we pick the largest
+     scale we can and we only show 3 digits. Avoiding showing tiny numbers also
+     allows us to avoid displaying passes that barely allocate compared to the
+     rest of the compiler.  *)
+  let bytes_of_words words = words *. float_of_int (Sys.word_size / 8) in
+  let to_string_without_unit v ~width scale =
+    let precision = 3 and precision_power = 1e3 in
+    let v_rescaled = bytes_of_words v /. scale in
+    let v_rounded =
+      floor (v_rescaled *. precision_power +. 0.5) /. precision_power in
+    let v_str = Printf.sprintf "%.*f" precision v_rounded in
+    let index_of_dot = String.index v_str '.' in
+    let v_str_truncated =
+      String.sub v_str 0
+        (if index_of_dot >= precision
+         then index_of_dot
+         else precision + 1)
+    in
+    Printf.sprintf "%*s" width v_str_truncated
+  in
+  let choose_memory_scale =
+    let units = [|"B"; "kB"; "MB"; "GB"|] in
+    fun words ->
+      let bytes = bytes_of_words words in
+      let scale = ref (Array.length units - 1) in
+      while !scale > 0 && bytes < 1024. ** float_of_int !scale do
+        decr scale
+      done;
+      1024. ** float_of_int !scale, units.(!scale)
+  in
+  fun ?previous v : display ->
+    let to_string ~max ~width =
+      let scale, scale_str = choose_memory_scale max in
+      let width = width - String.length scale_str in
+      to_string_without_unit v ~width scale ^ scale_str
+    in
+    let worth_displaying ~max =
+      let scale, _ = choose_memory_scale max in
+      float_of_string (to_string_without_unit v ~width:0 scale) <> 0.
+      && match previous with
+      | None -> true
+      | Some p ->
+         (* This branch is for numbers that represent absolute quantity, rather
+            than differences. It allows us to skip displaying the same absolute
+            quantity many times in a row. *)
+         to_string_without_unit p ~width:0 scale
+         <> to_string_without_unit v ~width:0 scale
+    in
+    { to_string; worth_displaying }
+
+let profile_list (E table) =
+  let l = Hashtbl.fold (fun k d l -> (k, d) :: l) table [] in
+  List.sort (fun (_, (p1, _)) (_, (p2, _)) ->
+    compare p1.Measure_diff.timestamp p2.Measure_diff.timestamp) l
+
+let compute_other_category (E table : hierarchy) (total : Measure_diff.t) =
+  let r = ref total in
+  Hashtbl.iter (fun _pass ((p2 : Measure_diff.t), _) ->
+    let p1 = !r in
+    r := {
+      timestamp = p1.timestamp;
+      duration = p1.duration -. p2.duration;
+      allocated_words = p1.allocated_words -. p2.allocated_words;
+      top_heap_words_increase =
+        p1.top_heap_words_increase - p2.top_heap_words_increase;
+    }
+  ) table;
+  !r
+
+type row = R of string * (float * display) list * row list
+type column = [ `Time | `Alloc | `Top_heap | `Abs_top_heap ]
+
+let rec rows_of_hierarchy ~nesting make_row name measure_diff hierarchy env =
+  let rows =
+    rows_of_hierarchy_list
+      ~nesting:(nesting + 1) make_row hierarchy measure_diff env in
+  let values, env =
+    make_row env measure_diff ~toplevel_other:(nesting = 0 && name = "other") in
+  R (name, values, rows), env
+
+and rows_of_hierarchy_list ~nesting make_row hierarchy total env =
+  let list = profile_list hierarchy in
+  let list =
+    if list <> [] || nesting = 0
+    then list @ [ "other", (compute_other_category hierarchy total, create ()) ]
+    else []
+  in
+  let env = ref env in
+  List.map (fun (name, (measure_diff, hierarchy)) ->
+    let a, env' =
+      rows_of_hierarchy ~nesting make_row name measure_diff hierarchy !env in
+    env := env';
+    a
+  ) list
+
+let rows_of_hierarchy hierarchy measure_diff initial_measure columns =
+  (* Computing top heap size is a bit complicated: if the compiler applies a
+     list of passes n times (rather than applying pass1 n times, then pass2 n
+     times etc), we only show one row for that pass but what does "top heap
+     size at the end of that pass" even mean?
+     It seems the only sensible answer is to pretend the compiler applied pass1
+     n times, pass2 n times by accumulating all the heap size increases that
+     happened during each pass, and then compute what the heap size would have
+     been. So that's what we do.
+     There's a bit of extra complication, which is that the heap can increase in
+     between measurements. So the heap sizes can be a bit off until the "other"
+     rows account for what's missing. We special case the toplevel "other" row
+     so that any increases that happened before the start of the compilation is
+     correctly reported, as a lot of code may run before the start of the
+     compilation (eg functor applications). *)
+    let make_row prev_top_heap_words (p : Measure_diff.t) ~toplevel_other =
+      let top_heap_words =
+        prev_top_heap_words
+        + p.top_heap_words_increase
+        - if toplevel_other
+          then initial_measure.Measure.top_heap_words
+          else 0
+      in
+      let make value ~f = value, f value in
+      List.map (function
+        | `Time ->
+          make p.duration ~f:time_display
+        | `Alloc ->
+          make p.allocated_words ~f:memory_word_display
+        | `Top_heap ->
+          make (float_of_int p.top_heap_words_increase) ~f:memory_word_display
+        | `Abs_top_heap ->
+          make (float_of_int top_heap_words)
+           ~f:(memory_word_display ~previous:(float_of_int prev_top_heap_words))
+      ) columns,
+      top_heap_words
+  in
+  rows_of_hierarchy_list ~nesting:0 make_row hierarchy measure_diff
+    initial_measure.top_heap_words
+
+let max_by_column ~n_columns rows =
+  let a = Array.make n_columns 0. in
+  let rec loop (R (_, values, rows)) =
+    List.iteri (fun i (v, _) -> a.(i) <- max a.(i) v) values;
+    List.iter loop rows
+  in
+  List.iter loop rows;
+  a
+
+let width_by_column ~n_columns ~display_cell rows =
+  let a = Array.make n_columns 1 in
+  let rec loop (R (_, values, rows)) =
+    List.iteri (fun i cell ->
+      let _, str = display_cell i cell ~width:0 in
+      a.(i) <- max a.(i) (String.length str)
+    ) values;
+    List.iter loop rows;
+  in
+  List.iter loop rows;
+  a
+
+let display_rows ppf rows =
+  let n_columns =
+    match rows with
+    | [] -> 0
+    | R (_, values, _) :: _ -> List.length values
+  in
+  let maxs = max_by_column ~n_columns rows in
+  let display_cell i (_, c) ~width =
+    let display_cell = c.worth_displaying ~max:maxs.(i) in
+    display_cell, if display_cell
+                  then c.to_string ~max:maxs.(i) ~width
+                  else String.make width '-'
+  in
+  let widths = width_by_column ~n_columns ~display_cell rows in
+  let rec loop (R (name, values, rows)) ~indentation =
+    let worth_displaying, cell_strings =
+      values
+      |> List.mapi (fun i cell -> display_cell i cell ~width:widths.(i))
+      |> List.split
+    in
+    if List.exists (fun b -> b) worth_displaying then
+      Format.fprintf ppf "%s%s %s@\n"
+        indentation (String.concat " " cell_strings) name;
+    List.iter (loop ~indentation:("  " ^ indentation)) rows;
+  in
+  List.iter (loop ~indentation:"") rows
+
+let print ppf columns =
+  match columns with
+  | [] -> ()
+  | _ :: _ ->
+     let initial_measure =
+       match !initial_measure with
+       | Some v -> v
+       | None -> Measure.zero
+     in
+     let total = Measure_diff.of_diff Measure.zero (Measure.create ()) in
+     display_rows ppf
+       (rows_of_hierarchy !hierarchy total initial_measure columns)
+
+let column_mapping = [
+  "time", `Time;
+  "alloc", `Alloc;
+  "top-heap", `Top_heap;
+  "absolute-top-heap", `Abs_top_heap;
+]
+
+let column_names = List.map fst column_mapping
+
+let options_doc =
+  Printf.sprintf
+    " Print performance information for each pass\
+   \n    The columns are: %s."
+    (String.concat " " column_names)
+
+let all_columns = List.map snd column_mapping
+
+let generate = "generate"
+let transl = "transl"
+let typing = "typing"
diff --git a/upstream/ocaml_411/utils/profile.mli b/upstream/ocaml_411/utils/profile.mli
new file mode 100644
index 0000000..7eff695
--- /dev/null
+++ b/upstream/ocaml_411/utils/profile.mli
@@ -0,0 +1,49 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Pierre Chambart, OCamlPro                         *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Compiler performance recording
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type file = string
+
+val reset : unit -> unit
+(** erase all recorded profile information *)
+
+val record_call : ?accumulate:bool -> string -> (unit -> 'a) -> 'a
+(** [record_call pass f] calls [f] and records its profile information. *)
+
+val record : ?accumulate:bool -> string -> ('a -> 'b) -> 'a -> 'b
+(** [record pass f arg] records the profile information of [f arg] *)
+
+type column = [ `Time | `Alloc | `Top_heap | `Abs_top_heap ]
+
+val print : Format.formatter -> column list -> unit
+(** Prints the selected recorded profiling information to the formatter. *)
+
+(** Command line flags *)
+
+val options_doc : string
+val all_columns : column list
+
+(** A few pass names that are needed in several places, and shared to
+    avoid typos. *)
+
+val generate : string
+val transl : string
+val typing : string
diff --git a/upstream/ocaml_411/utils/strongly_connected_components.ml b/upstream/ocaml_411/utils/strongly_connected_components.ml
new file mode 100644
index 0000000..a11f698
--- /dev/null
+++ b/upstream/ocaml_411/utils/strongly_connected_components.ml
@@ -0,0 +1,200 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Int = Numbers.Int
+
+module Kosaraju : sig
+  type component_graph =
+    { sorted_connected_components : int list array;
+      component_edges : int list array;
+    }
+
+  val component_graph : int list array -> component_graph
+end = struct
+  let transpose graph =
+    let size = Array.length graph in
+    let transposed = Array.make size [] in
+    let add src dst = transposed.(src) <- dst :: transposed.(src) in
+    Array.iteri (fun src dsts -> List.iter (fun dst -> add dst src) dsts)
+      graph;
+    transposed
+
+  let depth_first_order (graph : int list array) : int array =
+    let size = Array.length graph in
+    let marked = Array.make size false in
+    let stack = Array.make size ~-1 in
+    let pos = ref 0 in
+    let push i =
+      stack.(!pos) <- i;
+      incr pos
+    in
+    let rec aux node =
+      if not marked.(node)
+      then begin
+        marked.(node) <- true;
+        List.iter aux graph.(node);
+        push node
+      end
+    in
+    for i = 0 to size - 1 do
+      aux i
+    done;
+    stack
+
+  let mark order graph =
+    let size = Array.length graph in
+    let graph = transpose graph in
+    let marked = Array.make size false in
+    let id = Array.make size ~-1 in
+    let count = ref 0 in
+    let rec aux node =
+      if not marked.(node)
+      then begin
+        marked.(node) <- true;
+        id.(node) <- !count;
+        List.iter aux graph.(node)
+      end
+    in
+    for i = size - 1 downto 0 do
+      let node = order.(i) in
+      if not marked.(node)
+      then begin
+        aux order.(i);
+        incr count
+      end
+    done;
+    id, !count
+
+  let kosaraju graph =
+    let dfo = depth_first_order graph in
+    let components, ncomponents = mark dfo graph in
+    ncomponents, components
+
+  type component_graph =
+    { sorted_connected_components : int list array;
+      component_edges : int list array;
+    }
+
+  let component_graph graph =
+    let ncomponents, components = kosaraju graph in
+    let id_scc = Array.make ncomponents [] in
+    let component_graph = Array.make ncomponents Int.Set.empty in
+    let add_component_dep node set =
+      let node_deps = graph.(node) in
+      List.fold_left (fun set dep -> Int.Set.add components.(dep) set)
+        set node_deps
+    in
+    Array.iteri (fun node component ->
+        id_scc.(component) <- node :: id_scc.(component);
+        component_graph.(component) <-
+          add_component_dep node (component_graph.(component)))
+      components;
+    { sorted_connected_components = id_scc;
+      component_edges = Array.map Int.Set.elements component_graph;
+    }
+end
+
+module type S = sig
+  module Id : Identifiable.S
+
+  type directed_graph = Id.Set.t Id.Map.t
+
+  type component =
+    | Has_loop of Id.t list
+    | No_loop of Id.t
+
+  val connected_components_sorted_from_roots_to_leaf
+     : directed_graph
+    -> component array
+
+  val component_graph : directed_graph -> (component * int list) array
+end
+
+module Make (Id : Identifiable.S) = struct
+  type directed_graph = Id.Set.t Id.Map.t
+
+  type component =
+    | Has_loop of Id.t list
+    | No_loop of Id.t
+
+  (* Ensure that the dependency graph does not have external dependencies. *)
+  (* Note: this function is currently not used. *)
+  let _check dependencies =
+    Id.Map.iter (fun id set ->
+        Id.Set.iter (fun v ->
+            if not (Id.Map.mem v dependencies)
+            then
+              Misc.fatal_errorf "Strongly_connected_components.check: the \
+                  graph has external dependencies (%a -> %a)"
+               Id.print id Id.print v)
+          set)
+      dependencies
+
+  type numbering = {
+    back : int Id.Map.t;
+    forth : Id.t array;
+  }
+
+  let number graph =
+    let size = Id.Map.cardinal graph in
+    let bindings = Id.Map.bindings graph in
+    let a = Array.of_list bindings in
+    let forth = Array.map fst a in
+    let back =
+      let back = ref Id.Map.empty in
+      for i = 0 to size - 1 do
+        back := Id.Map.add forth.(i) i !back;
+      done;
+      !back
+    in
+    let integer_graph =
+      Array.init size (fun i ->
+        let _, dests = a.(i) in
+        Id.Set.fold (fun dest acc ->
+            let v =
+              try Id.Map.find dest back
+              with Not_found ->
+                Misc.fatal_errorf
+                  "Strongly_connected_components: missing dependency %a"
+                  Id.print dest
+            in
+            v :: acc)
+          dests [])
+    in
+    { back; forth }, integer_graph
+
+  let component_graph graph =
+    let numbering, integer_graph = number graph in
+    let { Kosaraju. sorted_connected_components;
+          component_edges } =
+      Kosaraju.component_graph integer_graph
+    in
+    Array.mapi (fun component nodes ->
+        match nodes with
+        | [] -> assert false
+        | [node] ->
+          (if List.mem node integer_graph.(node)
+           then Has_loop [numbering.forth.(node)]
+           else No_loop numbering.forth.(node)),
+            component_edges.(component)
+        | _::_ ->
+          (Has_loop (List.map (fun node -> numbering.forth.(node)) nodes)),
+            component_edges.(component))
+      sorted_connected_components
+
+  let connected_components_sorted_from_roots_to_leaf graph =
+    Array.map fst (component_graph graph)
+end
diff --git a/upstream/ocaml_411/utils/strongly_connected_components.mli b/upstream/ocaml_411/utils/strongly_connected_components.mli
new file mode 100644
index 0000000..e700952
--- /dev/null
+++ b/upstream/ocaml_411/utils/strongly_connected_components.mli
@@ -0,0 +1,43 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Kosaraju's algorithm for strongly connected components.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+module type S = sig
+  module Id : Identifiable.S
+
+  type directed_graph = Id.Set.t Id.Map.t
+  (** If (a -> set) belongs to the map, it means that there are edges
+      from [a] to every element of [set].  It is assumed that no edge
+      points to a vertex not represented in the map. *)
+
+  type component =
+    | Has_loop of Id.t list
+    | No_loop of Id.t
+
+  val connected_components_sorted_from_roots_to_leaf
+     : directed_graph
+    -> component array
+
+  val component_graph : directed_graph -> (component * int list) array
+end
+
+module Make (Id : Identifiable.S) : S with module Id := Id
diff --git a/upstream/ocaml_411/utils/targetint.ml b/upstream/ocaml_411/utils/targetint.ml
new file mode 100644
index 0000000..9d15a2f
--- /dev/null
+++ b/upstream/ocaml_411/utils/targetint.ml
@@ -0,0 +1,104 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                        Nicolas Ojeda Bar, LexiFi                       *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type repr =
+  | Int32 of int32
+  | Int64 of int64
+
+module type S = sig
+  type t
+  val zero : t
+  val one : t
+  val minus_one : t
+  val neg : t -> t
+  val add : t -> t -> t
+  val sub : t -> t -> t
+  val mul : t -> t -> t
+  val div : t -> t -> t
+  val unsigned_div : t -> t -> t
+  val rem : t -> t -> t
+  val unsigned_rem : t -> t -> t
+  val succ : t -> t
+  val pred : t -> t
+  val abs : t -> t
+  val max_int : t
+  val min_int : t
+  val logand : t -> t -> t
+  val logor : t -> t -> t
+  val logxor : t -> t -> t
+  val lognot : t -> t
+  val shift_left : t -> int -> t
+  val shift_right : t -> int -> t
+  val shift_right_logical : t -> int -> t
+  val of_int : int -> t
+  val of_int_exn : int -> t
+  val to_int : t -> int
+  val of_float : float -> t
+  val to_float : t -> float
+  val of_int32 : int32 -> t
+  val to_int32 : t -> int32
+  val of_int64 : int64 -> t
+  val to_int64 : t -> int64
+  val of_string : string -> t
+  val to_string : t -> string
+  val compare: t -> t -> int
+  val unsigned_compare : t -> t -> int
+  val equal: t -> t -> bool
+  val repr: t -> repr
+  val print : Format.formatter -> t -> unit
+end
+
+let size = Sys.word_size
+(* Later, this will be set by the configure script
+   in order to support cross-compilation. *)
+
+module Int32 = struct
+  include Int32
+  let of_int_exn =
+    match Sys.word_size with (* size of [int] *)
+    | 32 ->
+        Int32.of_int
+    | 64 ->
+        fun n ->
+          if n < Int32.(to_int min_int) || n > Int32.(to_int max_int) then
+            Misc.fatal_errorf "Targetint.of_int_exn: 0x%x out of range" n
+          else
+            Int32.of_int n
+    | _ ->
+        assert false
+  let of_int32 x = x
+  let to_int32 x = x
+  let of_int64 = Int64.to_int32
+  let to_int64 = Int64.of_int32
+  let repr x = Int32 x
+  let print ppf t = Format.fprintf ppf "%ld" t
+end
+
+module Int64 = struct
+  include Int64
+  let of_int_exn = Int64.of_int
+  let of_int64 x = x
+  let to_int64 x = x
+  let repr x = Int64 x
+  let print ppf t = Format.fprintf ppf "%Ld" t
+end
+
+include (val
+          (match size with
+           | 32 -> (module Int32)
+           | 64 -> (module Int64)
+           | _ -> assert false
+          ) : S)
diff --git a/upstream/ocaml_411/utils/targetint.mli b/upstream/ocaml_411/utils/targetint.mli
new file mode 100644
index 0000000..72d464d
--- /dev/null
+++ b/upstream/ocaml_411/utils/targetint.mli
@@ -0,0 +1,207 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                        Nicolas Ojeda Bar, LexiFi                       *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Target processor-native integers.
+
+   This module provides operations on the type of
+   signed 32-bit integers (on 32-bit target platforms) or
+   signed 64-bit integers (on 64-bit target platforms).
+   This integer type has exactly the same width as that of a
+   pointer type in the C compiler.  All arithmetic operations over
+   are taken modulo 2{^32} or 2{^64} depending
+   on the word size of the target architecture.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type t
+(** The type of target integers. *)
+
+val zero : t
+(** The target integer 0.*)
+
+val one : t
+(** The target integer 1.*)
+
+val minus_one : t
+(** The target integer -1.*)
+
+val neg : t -> t
+(** Unary negation. *)
+
+val add : t -> t -> t
+(** Addition. *)
+
+val sub : t -> t -> t
+(** Subtraction. *)
+
+val mul : t -> t -> t
+(** Multiplication. *)
+
+val div : t -> t -> t
+(** Integer division.  Raise [Division_by_zero] if the second
+   argument is zero.  This division rounds the real quotient of
+   its arguments towards zero, as specified for {!Stdlib.(/)}. *)
+
+val unsigned_div : t -> t -> t
+(** Same as {!div}, except that arguments and result are interpreted as {e
+    unsigned} integers. *)
+
+val rem : t -> t -> t
+(** Integer remainder.  If [y] is not zero, the result
+   of [Targetint.rem x y] satisfies the following properties:
+   [Targetint.zero <= Nativeint.rem x y < Targetint.abs y] and
+   [x = Targetint.add (Targetint.mul (Targetint.div x y) y)
+                      (Targetint.rem x y)].
+   If [y = 0], [Targetint.rem x y] raises [Division_by_zero]. *)
+
+val unsigned_rem : t -> t -> t
+(** Same as {!rem}, except that arguments and result are interpreted as {e
+    unsigned} integers. *)
+
+val succ : t -> t
+(** Successor.
+   [Targetint.succ x] is [Targetint.add x Targetint.one]. *)
+
+val pred : t -> t
+(** Predecessor.
+   [Targetint.pred x] is [Targetint.sub x Targetint.one]. *)
+
+val abs : t -> t
+(** Return the absolute value of its argument. *)
+
+val size : int
+(** The size in bits of a target native integer. *)
+
+val max_int : t
+(** The greatest representable target integer,
+    either 2{^31} - 1 on a 32-bit platform,
+    or 2{^63} - 1 on a 64-bit platform. *)
+
+val min_int : t
+(** The smallest representable target integer,
+   either -2{^31} on a 32-bit platform,
+   or -2{^63} on a 64-bit platform. *)
+
+val logand : t -> t -> t
+(** Bitwise logical and. *)
+
+val logor : t -> t -> t
+(** Bitwise logical or. *)
+
+val logxor : t -> t -> t
+(** Bitwise logical exclusive or. *)
+
+val lognot : t -> t
+(** Bitwise logical negation. *)
+
+val shift_left : t -> int -> t
+(** [Targetint.shift_left x y] shifts [x] to the left by [y] bits.
+    The result is unspecified if [y < 0] or [y >= bitsize],
+    where [bitsize] is [32] on a 32-bit platform and
+    [64] on a 64-bit platform. *)
+
+val shift_right : t -> int -> t
+(** [Targetint.shift_right x y] shifts [x] to the right by [y] bits.
+    This is an arithmetic shift: the sign bit of [x] is replicated
+    and inserted in the vacated bits.
+    The result is unspecified if [y < 0] or [y >= bitsize]. *)
+
+val shift_right_logical : t -> int -> t
+(** [Targetint.shift_right_logical x y] shifts [x] to the right
+    by [y] bits.
+    This is a logical shift: zeroes are inserted in the vacated bits
+    regardless of the sign of [x].
+    The result is unspecified if [y < 0] or [y >= bitsize]. *)
+
+val of_int : int -> t
+(** Convert the given integer (type [int]) to a target integer
+    (type [t]), module the target word size. *)
+
+val of_int_exn : int -> t
+(** Convert the given integer (type [int]) to a target integer
+    (type [t]).  Raises a fatal error if the conversion is not exact. *)
+
+val to_int : t -> int
+(** Convert the given target integer (type [t]) to an
+    integer (type [int]).  The high-order bit is lost during
+    the conversion. *)
+
+val of_float : float -> t
+(** Convert the given floating-point number to a target integer,
+   discarding the fractional part (truncate towards 0).
+   The result of the conversion is undefined if, after truncation,
+   the number is outside the range
+   \[{!Targetint.min_int}, {!Targetint.max_int}\]. *)
+
+val to_float : t -> float
+(** Convert the given target integer to a floating-point number. *)
+
+val of_int32 : int32 -> t
+(** Convert the given 32-bit integer (type [int32])
+    to a target integer. *)
+
+val to_int32 : t -> int32
+(** Convert the given target integer to a
+    32-bit integer (type [int32]).  On 64-bit platforms,
+    the 64-bit native integer is taken modulo 2{^32},
+    i.e. the top 32 bits are lost.  On 32-bit platforms,
+    the conversion is exact. *)
+
+val of_int64 : int64 -> t
+(** Convert the given 64-bit integer (type [int64])
+    to a target integer. *)
+
+val to_int64 : t -> int64
+(** Convert the given target integer to a
+    64-bit integer (type [int64]). *)
+
+val of_string : string -> t
+(** Convert the given string to a target integer.
+    The string is read in decimal (by default) or in hexadecimal,
+    octal or binary if the string begins with [0x], [0o] or [0b]
+    respectively.
+    Raise [Failure "int_of_string"] if the given string is not
+    a valid representation of an integer, or if the integer represented
+    exceeds the range of integers representable in type [nativeint]. *)
+
+val to_string : t -> string
+(** Return the string representation of its argument, in decimal. *)
+
+val compare: t -> t -> int
+(** The comparison function for target integers, with the same specification as
+    {!Stdlib.compare}.  Along with the type [t], this function [compare]
+    allows the module [Targetint] to be passed as argument to the functors
+    {!Set.Make} and {!Map.Make}. *)
+
+val unsigned_compare: t -> t -> int
+(** Same as {!compare}, except that arguments are interpreted as {e unsigned}
+    integers. *)
+
+val equal: t -> t -> bool
+(** The equal function for target ints. *)
+
+type repr =
+  | Int32 of int32
+  | Int64 of int64
+
+val repr : t -> repr
+(** The concrete representation of a native integer. *)
+
+val print : Format.formatter -> t -> unit
+(** Print a target integer to a formatter. *)
diff --git a/upstream/ocaml_411/utils/terminfo.ml b/upstream/ocaml_411/utils/terminfo.ml
new file mode 100644
index 0000000..1b4a357
--- /dev/null
+++ b/upstream/ocaml_411/utils/terminfo.ml
@@ -0,0 +1,45 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Paris                  *)
+(*                                                                        *)
+(*   Copyright 2017 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Printf
+
+external isatty : out_channel -> bool = "caml_sys_isatty"
+external terminfo_rows: out_channel -> int = "caml_terminfo_rows"
+
+type status =
+  | Uninitialised
+  | Bad_term
+  | Good_term
+
+let setup oc =
+  let term = try Sys.getenv "TERM" with Not_found -> "" in
+  (* Same heuristics as in Misc.Color.should_enable_color *)
+  if term <> "" && term <> "dumb" && isatty oc
+  then Good_term
+  else Bad_term
+
+let num_lines oc =
+  let rows = terminfo_rows oc in
+  if rows > 0 then rows else 24
+    (* 24 is a reasonable default for an ANSI-style terminal *)
+
+let backup oc n =
+  if n >= 1 then fprintf oc "\027[%dA%!" n
+
+let resume oc n =
+  if n >= 1 then fprintf oc "\027[%dB%!" n
+
+let standout oc b =
+  output_string oc (if b then "\027[4m" else "\027[0m"); flush oc
diff --git a/upstream/ocaml_411/utils/terminfo.mli b/upstream/ocaml_411/utils/terminfo.mli
new file mode 100644
index 0000000..10f5f54
--- /dev/null
+++ b/upstream/ocaml_411/utils/terminfo.mli
@@ -0,0 +1,32 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Basic interface to the terminfo database
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type status =
+  | Uninitialised
+  | Bad_term
+  | Good_term
+
+val setup : out_channel -> status
+val num_lines : out_channel -> int
+val backup : out_channel -> int -> unit
+val standout : out_channel -> bool -> unit
+val resume : out_channel -> int -> unit
diff --git a/upstream/ocaml_411/utils/warnings.ml b/upstream/ocaml_411/utils/warnings.ml
new file mode 100644
index 0000000..7adb349
--- /dev/null
+++ b/upstream/ocaml_411/utils/warnings.ml
@@ -0,0 +1,797 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Pierre Weis && Damien Doligez, INRIA Rocquencourt          *)
+(*                                                                        *)
+(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* When you change this, you need to update:
+   - the list 'description' at the bottom of this file
+   - man/ocamlc.m
+*)
+
+type loc = {
+  loc_start: Lexing.position;
+  loc_end: Lexing.position;
+  loc_ghost: bool;
+}
+
+type t =
+  | Comment_start                           (*  1 *)
+  | Comment_not_end                         (*  2 *)
+(*| Deprecated --> alert "deprecated" *)    (*  3 *)
+  | Fragile_match of string                 (*  4 *)
+  | Partial_application                     (*  5 *)
+  | Labels_omitted of string list           (*  6 *)
+  | Method_override of string list          (*  7 *)
+  | Partial_match of string                 (*  8 *)
+  | Non_closed_record_pattern of string     (*  9 *)
+  | Statement_type                          (* 10 *)
+  | Unused_match                            (* 11 *)
+  | Unused_pat                              (* 12 *)
+  | Instance_variable_override of string list (* 13 *)
+  | Illegal_backslash                       (* 14 *)
+  | Implicit_public_methods of string list  (* 15 *)
+  | Unerasable_optional_argument            (* 16 *)
+  | Undeclared_virtual_method of string     (* 17 *)
+  | Not_principal of string                 (* 18 *)
+  | Without_principality of string          (* 19 *)
+  | Unused_argument                         (* 20 *)
+  | Nonreturning_statement                  (* 21 *)
+  | Preprocessor of string                  (* 22 *)
+  | Useless_record_with                     (* 23 *)
+  | Bad_module_name of string               (* 24 *)
+  | All_clauses_guarded                     (* 8, used to be 25 *)
+  | Unused_var of string                    (* 26 *)
+  | Unused_var_strict of string             (* 27 *)
+  | Wildcard_arg_to_constant_constr         (* 28 *)
+  | Eol_in_string                           (* 29 *)
+  | Duplicate_definitions of string * string * string * string (*30 *)
+  | Multiple_definition of string * string * string (* 31 *)
+  | Unused_value_declaration of string      (* 32 *)
+  | Unused_open of string                   (* 33 *)
+  | Unused_type_declaration of string       (* 34 *)
+  | Unused_for_index of string              (* 35 *)
+  | Unused_ancestor of string               (* 36 *)
+  | Unused_constructor of string * bool * bool  (* 37 *)
+  | Unused_extension of string * bool * bool * bool (* 38 *)
+  | Unused_rec_flag                         (* 39 *)
+  | Name_out_of_scope of string * string list * bool (* 40 *)
+  | Ambiguous_name of string list * string list *  bool * string (* 41 *)
+  | Disambiguated_name of string            (* 42 *)
+  | Nonoptional_label of string             (* 43 *)
+  | Open_shadow_identifier of string * string (* 44 *)
+  | Open_shadow_label_constructor of string * string (* 45 *)
+  | Bad_env_variable of string * string     (* 46 *)
+  | Attribute_payload of string * string    (* 47 *)
+  | Eliminated_optional_arguments of string list (* 48 *)
+  | No_cmi_file of string * string option   (* 49 *)
+  | Bad_docstring of bool                   (* 50 *)
+  | Expect_tailcall                         (* 51 *)
+  | Fragile_literal_pattern                 (* 52 *)
+  | Misplaced_attribute of string           (* 53 *)
+  | Duplicated_attribute of string          (* 54 *)
+  | Inlining_impossible of string           (* 55 *)
+  | Unreachable_case                        (* 56 *)
+  | Ambiguous_pattern of string list        (* 57 *)
+  | No_cmx_file of string                   (* 58 *)
+  | Assignment_to_non_mutable_value         (* 59 *)
+  | Unused_module of string                 (* 60 *)
+  | Unboxable_type_in_prim_decl of string   (* 61 *)
+  | Constraint_on_gadt                      (* 62 *)
+  | Erroneous_printed_signature of string   (* 63 *)
+  | Unsafe_without_parsing                  (* 64 *)
+  | Redefining_unit of string               (* 65 *)
+  | Unused_open_bang of string              (* 66 *)
+  | Unused_functor_parameter of string      (* 67 *)
+;;
+
+(* If you remove a warning, leave a hole in the numbering.  NEVER change
+   the numbers of existing warnings.
+   If you add a new warning, add it at the end with a new number;
+   do NOT reuse one of the holes.
+*)
+
+type alert = {kind:string; message:string; def:loc; use:loc}
+
+
+let number = function
+  | Comment_start -> 1
+  | Comment_not_end -> 2
+  | Fragile_match _ -> 4
+  | Partial_application -> 5
+  | Labels_omitted _ -> 6
+  | Method_override _ -> 7
+  | Partial_match _ -> 8
+  | Non_closed_record_pattern _ -> 9
+  | Statement_type -> 10
+  | Unused_match -> 11
+  | Unused_pat -> 12
+  | Instance_variable_override _ -> 13
+  | Illegal_backslash -> 14
+  | Implicit_public_methods _ -> 15
+  | Unerasable_optional_argument -> 16
+  | Undeclared_virtual_method _ -> 17
+  | Not_principal _ -> 18
+  | Without_principality _ -> 19
+  | Unused_argument -> 20
+  | Nonreturning_statement -> 21
+  | Preprocessor _ -> 22
+  | Useless_record_with -> 23
+  | Bad_module_name _ -> 24
+  | All_clauses_guarded -> 8 (* used to be 25 *)
+  | Unused_var _ -> 26
+  | Unused_var_strict _ -> 27
+  | Wildcard_arg_to_constant_constr -> 28
+  | Eol_in_string -> 29
+  | Duplicate_definitions _ -> 30
+  | Multiple_definition _ -> 31
+  | Unused_value_declaration _ -> 32
+  | Unused_open _ -> 33
+  | Unused_type_declaration _ -> 34
+  | Unused_for_index _ -> 35
+  | Unused_ancestor _ -> 36
+  | Unused_constructor _ -> 37
+  | Unused_extension _ -> 38
+  | Unused_rec_flag -> 39
+  | Name_out_of_scope _ -> 40
+  | Ambiguous_name _ -> 41
+  | Disambiguated_name _ -> 42
+  | Nonoptional_label _ -> 43
+  | Open_shadow_identifier _ -> 44
+  | Open_shadow_label_constructor _ -> 45
+  | Bad_env_variable _ -> 46
+  | Attribute_payload _ -> 47
+  | Eliminated_optional_arguments _ -> 48
+  | No_cmi_file _ -> 49
+  | Bad_docstring _ -> 50
+  | Expect_tailcall -> 51
+  | Fragile_literal_pattern -> 52
+  | Misplaced_attribute _ -> 53
+  | Duplicated_attribute _ -> 54
+  | Inlining_impossible _ -> 55
+  | Unreachable_case -> 56
+  | Ambiguous_pattern _ -> 57
+  | No_cmx_file _ -> 58
+  | Assignment_to_non_mutable_value -> 59
+  | Unused_module _ -> 60
+  | Unboxable_type_in_prim_decl _ -> 61
+  | Constraint_on_gadt -> 62
+  | Erroneous_printed_signature _ -> 63
+  | Unsafe_without_parsing -> 64
+  | Redefining_unit _ -> 65
+  | Unused_open_bang _ -> 66
+  | Unused_functor_parameter _ -> 67
+;;
+
+let last_warning_number = 67
+;;
+
+(* Must be the max number returned by the [number] function. *)
+
+let letter = function
+  | 'a' ->
+     let rec loop i = if i = 0 then [] else i :: loop (i - 1) in
+     loop last_warning_number
+  | 'b' -> []
+  | 'c' -> [1; 2]
+  | 'd' -> [3]
+  | 'e' -> [4]
+  | 'f' -> [5]
+  | 'g' -> []
+  | 'h' -> []
+  | 'i' -> []
+  | 'j' -> []
+  | 'k' -> [32; 33; 34; 35; 36; 37; 38; 39]
+  | 'l' -> [6]
+  | 'm' -> [7]
+  | 'n' -> []
+  | 'o' -> []
+  | 'p' -> [8]
+  | 'q' -> []
+  | 'r' -> [9]
+  | 's' -> [10]
+  | 't' -> []
+  | 'u' -> [11; 12]
+  | 'v' -> [13]
+  | 'w' -> []
+  | 'x' -> [14; 15; 16; 17; 18; 19; 20; 21; 22; 23; 24; 30]
+  | 'y' -> [26]
+  | 'z' -> [27]
+  | _ -> assert false
+;;
+
+type state =
+  {
+    active: bool array;
+    error: bool array;
+    alerts: (Misc.Stdlib.String.Set.t * bool); (* false:set complement *)
+    alert_errors: (Misc.Stdlib.String.Set.t * bool); (* false:set complement *)
+  }
+
+let current =
+  ref
+    {
+      active = Array.make (last_warning_number + 1) true;
+      error = Array.make (last_warning_number + 1) false;
+      alerts = (Misc.Stdlib.String.Set.empty, false); (* all enabled *)
+      alert_errors = (Misc.Stdlib.String.Set.empty, true); (* all soft *)
+    }
+
+let disabled = ref false
+
+let without_warnings f =
+  Misc.protect_refs [Misc.R(disabled, true)] f
+
+let backup () = !current
+
+let restore x = current := x
+
+let is_active x =
+  not !disabled && (!current).active.(number x)
+
+let is_error x =
+  not !disabled && (!current).error.(number x)
+
+let alert_is_active {kind; _} =
+  not !disabled &&
+  let (set, pos) = (!current).alerts in
+  Misc.Stdlib.String.Set.mem kind set = pos
+
+let alert_is_error {kind; _} =
+  not !disabled &&
+  let (set, pos) = (!current).alert_errors in
+  Misc.Stdlib.String.Set.mem kind set = pos
+
+let mk_lazy f =
+  let state = backup () in
+  lazy
+    (
+      let prev = backup () in
+      restore state;
+      try
+        let r = f () in
+        restore prev;
+        r
+      with exn ->
+        restore prev;
+        raise exn
+    )
+
+let set_alert ~error ~enable s =
+  let upd =
+    match s with
+    | "all" ->
+        (Misc.Stdlib.String.Set.empty, not enable)
+    | s ->
+        let (set, pos) =
+          if error then (!current).alert_errors else (!current).alerts
+        in
+        let f =
+          if enable = pos
+          then Misc.Stdlib.String.Set.add
+          else Misc.Stdlib.String.Set.remove
+        in
+        (f s set, pos)
+  in
+  if error then
+    current := {(!current) with alert_errors=upd}
+  else
+    current := {(!current) with alerts=upd}
+
+let parse_alert_option s =
+  let n = String.length s in
+  let id_char = function
+    | 'a'..'z' | 'A'..'Z' | '_' | '\'' | '0'..'9' -> true
+    | _ -> false
+  in
+  let rec parse_id i =
+    if i < n && id_char s.[i] then parse_id (i + 1) else i
+  in
+  let rec scan i =
+    if i = n then ()
+    else if i + 1 = n then raise (Arg.Bad "Ill-formed list of alert settings")
+    else match s.[i], s.[i+1] with
+      | '+', '+' -> id (set_alert ~error:true ~enable:true) (i + 2)
+      | '+', _ -> id (set_alert ~error:false ~enable:true) (i + 1)
+      | '-', '-' -> id (set_alert ~error:true ~enable:false) (i + 2)
+      | '-', _ -> id (set_alert ~error:false ~enable:false) (i + 1)
+      | '@', _ ->
+          id (fun s ->
+              set_alert ~error:true ~enable:true s;
+              set_alert ~error:false ~enable:true s)
+            (i + 1)
+      | _ -> raise (Arg.Bad "Ill-formed list of alert settings")
+  and id f i =
+    let j = parse_id i in
+    if j = i then raise (Arg.Bad "Ill-formed list of alert settings");
+    let id = String.sub s i (j - i) in
+    f id;
+    scan j
+  in
+  scan 0
+
+let parse_opt error active errflag s =
+  let flags = if errflag then error else active in
+  let set i =
+    if i = 3 then set_alert ~error:errflag ~enable:true "deprecated"
+    else flags.(i) <- true
+  in
+  let clear i =
+    if i = 3 then set_alert ~error:errflag ~enable:false "deprecated"
+    else flags.(i) <- false
+  in
+  let set_all i =
+    if i = 3 then begin
+      set_alert ~error:false ~enable:true "deprecated";
+      set_alert ~error:true ~enable:true "deprecated"
+    end
+    else begin
+      active.(i) <- true;
+      error.(i) <- true
+    end
+  in
+  let error () = raise (Arg.Bad "Ill-formed list of warnings") in
+  let rec get_num n i =
+    if i >= String.length s then i, n
+    else match s.[i] with
+    | '0'..'9' -> get_num (10 * n + Char.code s.[i] - Char.code '0') (i + 1)
+    | _ -> i, n
+  in
+  let get_range i =
+    let i, n1 = get_num 0 i in
+    if i + 2 < String.length s && s.[i] = '.' && s.[i + 1] = '.' then
+      let i, n2 = get_num 0 (i + 2) in
+      if n2 < n1 then error ();
+      i, n1, n2
+    else
+      i, n1, n1
+  in
+  let rec loop i =
+    if i >= String.length s then () else
+    match s.[i] with
+    | 'A' .. 'Z' ->
+       List.iter set (letter (Char.lowercase_ascii s.[i]));
+       loop (i+1)
+    | 'a' .. 'z' ->
+       List.iter clear (letter s.[i]);
+       loop (i+1)
+    | '+' -> loop_letter_num set (i+1)
+    | '-' -> loop_letter_num clear (i+1)
+    | '@' -> loop_letter_num set_all (i+1)
+    | _ -> error ()
+  and loop_letter_num myset i =
+    if i >= String.length s then error () else
+    match s.[i] with
+    | '0' .. '9' ->
+        let i, n1, n2 = get_range i in
+        for n = n1 to min n2 last_warning_number do myset n done;
+        loop i
+    | 'A' .. 'Z' ->
+       List.iter myset (letter (Char.lowercase_ascii s.[i]));
+       loop (i+1)
+    | 'a' .. 'z' ->
+       List.iter myset (letter s.[i]);
+       loop (i+1)
+    | _ -> error ()
+  in
+  loop 0
+;;
+
+let parse_options errflag s =
+  let error = Array.copy (!current).error in
+  let active = Array.copy (!current).active in
+  parse_opt error active errflag s;
+  current := {(!current) with error; active}
+
+(* If you change these, don't forget to change them in man/ocamlc.m *)
+let defaults_w = "+a-4-6-7-9-27-29-30-32..42-44-45-48-50-60-66-67";;
+let defaults_warn_error = "-a+31";;
+
+let () = parse_options false defaults_w;;
+let () = parse_options true defaults_warn_error;;
+
+let ref_manual_explanation () =
+  (* manual references are checked a posteriori by the manual
+     cross-reference consistency check in manual/tests*)
+  let[@manual.ref "s:comp-warnings"] chapter, section = 9, 5 in
+  Printf.sprintf "(See manual section %d.%d)" chapter section
+
+let message = function
+  | Comment_start ->
+      "this `(*' is the start of a comment.\n\
+       Hint: Did you forget spaces when writing the infix operator `( * )'?"
+  | Comment_not_end -> "this is not the end of a comment."
+  | Fragile_match "" ->
+      "this pattern-matching is fragile."
+  | Fragile_match s ->
+      "this pattern-matching is fragile.\n\
+       It will remain exhaustive when constructors are added to type " ^ s ^ "."
+  | Partial_application ->
+      "this function application is partial,\n\
+       maybe some arguments are missing."
+  | Labels_omitted [] -> assert false
+  | Labels_omitted [l] ->
+     "label " ^ l ^ " was omitted in the application of this function."
+  | Labels_omitted ls ->
+     "labels " ^ String.concat ", " ls ^
+       " were omitted in the application of this function."
+  | Method_override [lab] ->
+      "the method " ^ lab ^ " is overridden."
+  | Method_override (cname :: slist) ->
+      String.concat " "
+        ("the following methods are overridden by the class"
+         :: cname  :: ":\n " :: slist)
+  | Method_override [] -> assert false
+  | Partial_match "" -> "this pattern-matching is not exhaustive."
+  | Partial_match s ->
+      "this pattern-matching is not exhaustive.\n\
+       Here is an example of a case that is not matched:\n" ^ s
+  | Non_closed_record_pattern s ->
+      "the following labels are not bound in this record pattern:\n" ^ s ^
+      "\nEither bind these labels explicitly or add '; _' to the pattern."
+  | Statement_type ->
+      "this expression should have type unit."
+  | Unused_match -> "this match case is unused."
+  | Unused_pat   -> "this sub-pattern is unused."
+  | Instance_variable_override [lab] ->
+      "the instance variable " ^ lab ^ " is overridden.\n" ^
+      "The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)"
+  | Instance_variable_override (cname :: slist) ->
+      String.concat " "
+        ("the following instance variables are overridden by the class"
+         :: cname  :: ":\n " :: slist) ^
+      "\nThe behaviour changed in ocaml 3.10 (previous behaviour was hiding.)"
+  | Instance_variable_override [] -> assert false
+  | Illegal_backslash -> "illegal backslash escape in string."
+  | Implicit_public_methods l ->
+      "the following private methods were made public implicitly:\n "
+      ^ String.concat " " l ^ "."
+  | Unerasable_optional_argument -> "this optional argument cannot be erased."
+  | Undeclared_virtual_method m -> "the virtual method "^m^" is not declared."
+  | Not_principal s -> s^" is not principal."
+  | Without_principality s -> s^" without principality."
+  | Unused_argument -> "this argument will not be used by the function."
+  | Nonreturning_statement ->
+      "this statement never returns (or has an unsound type.)"
+  | Preprocessor s -> s
+  | Useless_record_with ->
+      "all the fields are explicitly listed in this record:\n\
+       the 'with' clause is useless."
+  | Bad_module_name (modname) ->
+      "bad source file name: \"" ^ modname ^ "\" is not a valid module name."
+  | All_clauses_guarded ->
+      "this pattern-matching is not exhaustive.\n\
+       All clauses in this pattern-matching are guarded."
+  | Unused_var v | Unused_var_strict v -> "unused variable " ^ v ^ "."
+  | Wildcard_arg_to_constant_constr ->
+     "wildcard pattern given as argument to a constant constructor"
+  | Eol_in_string ->
+     "unescaped end-of-line in a string constant (non-portable code)"
+  | Duplicate_definitions (kind, cname, tc1, tc2) ->
+      Printf.sprintf "the %s %s is defined in both types %s and %s."
+        kind cname tc1 tc2
+  | Multiple_definition(modname, file1, file2) ->
+      Printf.sprintf
+        "files %s and %s both define a module named %s"
+        file1 file2 modname
+  | Unused_value_declaration v -> "unused value " ^ v ^ "."
+  | Unused_open s -> "unused open " ^ s ^ "."
+  | Unused_open_bang s -> "unused open! " ^ s ^ "."
+  | Unused_type_declaration s -> "unused type " ^ s ^ "."
+  | Unused_for_index s -> "unused for-loop index " ^ s ^ "."
+  | Unused_ancestor s -> "unused ancestor variable " ^ s ^ "."
+  | Unused_constructor (s, false, false) -> "unused constructor " ^ s ^ "."
+  | Unused_constructor (s, true, _) ->
+      "constructor " ^ s ^
+      " is never used to build values.\n\
+        (However, this constructor appears in patterns.)"
+  | Unused_constructor (s, false, true) ->
+      "constructor " ^ s ^
+      " is never used to build values.\n\
+        Its type is exported as a private type."
+  | Unused_extension (s, is_exception, cu_pattern, cu_privatize) ->
+     let kind =
+       if is_exception then "exception" else "extension constructor" in
+     let name = kind ^ " " ^ s in
+     begin match cu_pattern, cu_privatize with
+       | false, false -> "unused " ^ name
+       | true, _ ->
+          name ^
+          " is never used to build values.\n\
+           (However, this constructor appears in patterns.)"
+       | false, true ->
+          name ^
+          " is never used to build values.\n\
+            It is exported or rebound as a private extension."
+     end
+  | Unused_rec_flag ->
+      "unused rec flag."
+  | Name_out_of_scope (ty, [nm], false) ->
+      nm ^ " was selected from type " ^ ty ^
+      ".\nIt is not visible in the current scope, and will not \n\
+       be selected if the type becomes unknown."
+  | Name_out_of_scope (_, _, false) -> assert false
+  | Name_out_of_scope (ty, slist, true) ->
+      "this record of type "^ ty ^" contains fields that are \n\
+       not visible in the current scope: "
+      ^ String.concat " " slist ^ ".\n\
+       They will not be selected if the type becomes unknown."
+  | Ambiguous_name ([s], tl, false, expansion) ->
+      s ^ " belongs to several types: " ^ String.concat " " tl ^
+      "\nThe first one was selected. Please disambiguate if this is wrong."
+      ^ expansion
+  | Ambiguous_name (_, _, false, _ ) -> assert false
+  | Ambiguous_name (_slist, tl, true, expansion) ->
+      "these field labels belong to several types: " ^
+      String.concat " " tl ^
+      "\nThe first one was selected. Please disambiguate if this is wrong."
+      ^ expansion
+  | Disambiguated_name s ->
+      "this use of " ^ s ^ " relies on type-directed disambiguation,\n\
+       it will not compile with OCaml 4.00 or earlier."
+  | Nonoptional_label s ->
+      "the label " ^ s ^ " is not optional."
+  | Open_shadow_identifier (kind, s) ->
+      Printf.sprintf
+        "this open statement shadows the %s identifier %s (which is later used)"
+        kind s
+  | Open_shadow_label_constructor (kind, s) ->
+      Printf.sprintf
+        "this open statement shadows the %s %s (which is later used)"
+        kind s
+  | Bad_env_variable (var, s) ->
+      Printf.sprintf "illegal environment variable %s : %s" var s
+  | Attribute_payload (a, s) ->
+      Printf.sprintf "illegal payload for attribute '%s'.\n%s" a s
+  | Eliminated_optional_arguments sl ->
+      Printf.sprintf "implicit elimination of optional argument%s %s"
+        (if List.length sl = 1 then "" else "s")
+        (String.concat ", " sl)
+  | No_cmi_file(name, None) ->
+      "no cmi file was found in path for module " ^ name
+  | No_cmi_file(name, Some msg) ->
+      Printf.sprintf
+        "no valid cmi file was found in path for module %s. %s"
+        name msg
+  | Bad_docstring unattached ->
+      if unattached then "unattached documentation comment (ignored)"
+      else "ambiguous documentation comment"
+  | Expect_tailcall ->
+      Printf.sprintf "expected tailcall"
+  | Fragile_literal_pattern ->
+      Printf.sprintf
+        "Code should not depend on the actual values of\n\
+         this constructor's arguments. They are only for information\n\
+         and may change in future versions. %t" ref_manual_explanation
+  | Unreachable_case ->
+      "this match case is unreachable.\n\
+       Consider replacing it with a refutation case '<pat> -> .'"
+  | Misplaced_attribute attr_name ->
+      Printf.sprintf "the %S attribute cannot appear in this context" attr_name
+  | Duplicated_attribute attr_name ->
+      Printf.sprintf "the %S attribute is used more than once on this \
+          expression"
+        attr_name
+  | Inlining_impossible reason ->
+      Printf.sprintf "Cannot inline: %s" reason
+  | Ambiguous_pattern vars ->
+      let msg =
+        let vars = List.sort String.compare vars in
+        match vars with
+        | [] -> assert false
+        | [x] -> "variable " ^ x
+        | _::_ ->
+            "variables " ^ String.concat "," vars in
+      Printf.sprintf
+        "Ambiguous or-pattern variables under guard;\n\
+         %s may match different arguments. %t"
+        msg ref_manual_explanation
+  | No_cmx_file name ->
+      Printf.sprintf
+        "no cmx file was found in path for module %s, \
+         and its interface was not compiled with -opaque" name
+  | Assignment_to_non_mutable_value ->
+      "A potential assignment to a non-mutable value was detected \n\
+        in this source file.  Such assignments may generate incorrect code \n\
+        when using Flambda."
+  | Unused_module s -> "unused module " ^ s ^ "."
+  | Unboxable_type_in_prim_decl t ->
+      Printf.sprintf
+        "This primitive declaration uses type %s, whose representation\n\
+         may be either boxed or unboxed. Without an annotation to indicate\n\
+         which representation is intended, the boxed representation has been\n\
+         selected by default. This default choice may change in future\n\
+         versions of the compiler, breaking the primitive implementation.\n\
+         You should explicitly annotate the declaration of %s\n\
+         with [@@boxed] or [@@unboxed], so that its external interface\n\
+         remains stable in the future." t t
+  | Constraint_on_gadt ->
+      "Type constraints do not apply to GADT cases of variant types."
+  | Erroneous_printed_signature s ->
+      "The printed interface differs from the inferred interface.\n\
+       The inferred interface contained items which could not be printed\n\
+       properly due to name collisions between identifiers."
+     ^ s
+     ^ "\nBeware that this warning is purely informational and will not catch\n\
+        all instances of erroneous printed interface."
+  | Unsafe_without_parsing ->
+     "option -unsafe used with a preprocessor returning a syntax tree"
+  | Redefining_unit name ->
+      Printf.sprintf
+        "This type declaration is defining a new '()' constructor\n\
+         which shadows the existing one.\n\
+         Hint: Did you mean 'type %s = unit'?" name
+  | Unused_functor_parameter s -> "unused functor parameter " ^ s ^ "."
+;;
+
+let nerrors = ref 0;;
+
+type reporting_information =
+  { id : string
+  ; message : string
+  ; is_error : bool
+  ; sub_locs : (loc * string) list;
+  }
+
+let report w =
+  match is_active w with
+  | false -> `Inactive
+  | true ->
+     if is_error w then incr nerrors;
+     `Active
+       { id = string_of_int (number w);
+         message = message w;
+         is_error = is_error w;
+         sub_locs = [];
+       }
+
+let report_alert (alert : alert) =
+  match alert_is_active alert with
+  | false -> `Inactive
+  | true ->
+      let is_error = alert_is_error alert in
+      if is_error then incr nerrors;
+      let message = Misc.normalise_eol alert.message in
+       (* Reduce \r\n to \n:
+           - Prevents any \r characters being printed on Unix when processing
+             Windows sources
+           - Prevents \r\r\n being generated on Windows, which affects the
+             testsuite
+       *)
+      let sub_locs =
+        if not alert.def.loc_ghost && not alert.use.loc_ghost then
+          [
+            alert.def, "Definition";
+            alert.use, "Expected signature";
+          ]
+        else
+          []
+      in
+      `Active
+        {
+          id = alert.kind;
+          message;
+          is_error;
+          sub_locs;
+        }
+
+exception Errors;;
+
+let reset_fatal () =
+  nerrors := 0
+
+let check_fatal () =
+  if !nerrors > 0 then begin
+    nerrors := 0;
+    raise Errors;
+  end;
+;;
+
+let descriptions =
+  [
+    1, "Suspicious-looking start-of-comment mark.";
+    2, "Suspicious-looking end-of-comment mark.";
+    3, "Deprecated synonym for the 'deprecated' alert.";
+    4, "Fragile pattern matching: matching that will remain complete even\n\
+   \    if additional constructors are added to one of the variant types\n\
+   \    matched.";
+    5, "Partially applied function: expression whose result has function\n\
+   \    type and is ignored.";
+    6, "Label omitted in function application.";
+    7, "Method overridden.";
+    8, "Partial match: missing cases in pattern-matching.";
+    9, "Missing fields in a record pattern.";
+   10, "Expression on the left-hand side of a sequence that doesn't have \
+      type\n\
+   \    \"unit\" (and that is not a function, see warning number 5).";
+   11, "Redundant case in a pattern matching (unused match case).";
+   12, "Redundant sub-pattern in a pattern-matching.";
+   13, "Instance variable overridden.";
+   14, "Illegal backslash escape in a string constant.";
+   15, "Private method made public implicitly.";
+   16, "Unerasable optional argument.";
+   17, "Undeclared virtual method.";
+   18, "Non-principal type.";
+   19, "Type without principality.";
+   20, "Unused function argument.";
+   21, "Non-returning statement.";
+   22, "Preprocessor warning.";
+   23, "Useless record \"with\" clause.";
+   24, "Bad module name: the source file name is not a valid OCaml module \
+        name.";
+   25, "Deprecated: now part of warning 8.";
+   26, "Suspicious unused variable: unused variable that is bound\n\
+   \    with \"let\" or \"as\", and doesn't start with an underscore (\"_\")\n\
+   \    character.";
+   27, "Innocuous unused variable: unused variable that is not bound with\n\
+   \    \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\
+   \    character.";
+   28, "Wildcard pattern given as argument to a constant constructor.";
+   29, "Unescaped end-of-line in a string constant (non-portable code).";
+   30, "Two labels or constructors of the same name are defined in two\n\
+   \    mutually recursive types.";
+   31, "A module is linked twice in the same executable.";
+   32, "Unused value declaration.";
+   33, "Unused open statement.";
+   34, "Unused type declaration.";
+   35, "Unused for-loop index.";
+   36, "Unused ancestor variable.";
+   37, "Unused constructor.";
+   38, "Unused extension constructor.";
+   39, "Unused rec flag.";
+   40, "Constructor or label name used out of scope.";
+   41, "Ambiguous constructor or label name.";
+   42, "Disambiguated constructor or label name (compatibility warning).";
+   43, "Nonoptional label applied as optional.";
+   44, "Open statement shadows an already defined identifier.";
+   45, "Open statement shadows an already defined label or constructor.";
+   46, "Error in environment variable.";
+   47, "Illegal attribute payload.";
+   48, "Implicit elimination of optional arguments.";
+   49, "Absent cmi file when looking up module alias.";
+   50, "Unexpected documentation comment.";
+   51, "Warning on non-tail calls if @tailcall present.";
+   52, "Fragile constant pattern.";
+   53, "Attribute cannot appear in this context.";
+   54, "Attribute used more than once on an expression.";
+   55, "Inlining impossible.";
+   56, "Unreachable case in a pattern-matching (based on type information).";
+   57, "Ambiguous or-pattern variables under guard.";
+   58, "Missing cmx file.";
+   59, "Assignment to non-mutable value.";
+   60, "Unused module declaration.";
+   61, "Unboxable type in primitive declaration.";
+   62, "Type constraint on GADT type declaration.";
+   63, "Erroneous printed signature.";
+   64, "-unsafe used with a preprocessor returning a syntax tree.";
+   65, "Type declaration defining a new '()' constructor.";
+   66, "Unused open! statement.";
+   67, "Unused functor parameter.";
+  ]
+;;
+
+let help_warnings () =
+  List.iter (fun (i, s) -> Printf.printf "%3i %s\n" i s) descriptions;
+  print_endline "  A all warnings";
+  for i = Char.code 'b' to Char.code 'z' do
+    let c = Char.chr i in
+    match letter c with
+    | [] -> ()
+    | [n] ->
+        Printf.printf "  %c Alias for warning %i.\n" (Char.uppercase_ascii c) n
+    | l ->
+        Printf.printf "  %c warnings %s.\n"
+          (Char.uppercase_ascii c)
+          (String.concat ", " (List.map Int.to_string l))
+  done;
+  exit 0
+;;
diff --git a/upstream/ocaml_411/utils/warnings.mli b/upstream/ocaml_411/utils/warnings.mli
new file mode 100644
index 0000000..b80ab34
--- /dev/null
+++ b/upstream/ocaml_411/utils/warnings.mli
@@ -0,0 +1,140 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Pierre Weis && Damien Doligez, INRIA Rocquencourt          *)
+(*                                                                        *)
+(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Warning definitions
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type loc = {
+  loc_start: Lexing.position;
+  loc_end: Lexing.position;
+  loc_ghost: bool;
+}
+
+type t =
+  | Comment_start                           (*  1 *)
+  | Comment_not_end                         (*  2 *)
+(*| Deprecated --> alert "deprecated" *)    (*  3 *)
+  | Fragile_match of string                 (*  4 *)
+  | Partial_application                     (*  5 *)
+  | Labels_omitted of string list           (*  6 *)
+  | Method_override of string list          (*  7 *)
+  | Partial_match of string                 (*  8 *)
+  | Non_closed_record_pattern of string     (*  9 *)
+  | Statement_type                          (* 10 *)
+  | Unused_match                            (* 11 *)
+  | Unused_pat                              (* 12 *)
+  | Instance_variable_override of string list (* 13 *)
+  | Illegal_backslash                       (* 14 *)
+  | Implicit_public_methods of string list  (* 15 *)
+  | Unerasable_optional_argument            (* 16 *)
+  | Undeclared_virtual_method of string     (* 17 *)
+  | Not_principal of string                 (* 18 *)
+  | Without_principality of string          (* 19 *)
+  | Unused_argument                         (* 20 *)
+  | Nonreturning_statement                  (* 21 *)
+  | Preprocessor of string                  (* 22 *)
+  | Useless_record_with                     (* 23 *)
+  | Bad_module_name of string               (* 24 *)
+  | All_clauses_guarded                     (* 8, used to be 25 *)
+  | Unused_var of string                    (* 26 *)
+  | Unused_var_strict of string             (* 27 *)
+  | Wildcard_arg_to_constant_constr         (* 28 *)
+  | Eol_in_string                           (* 29 *)
+  | Duplicate_definitions of string * string * string * string (* 30 *)
+  | Multiple_definition of string * string * string (* 31 *)
+  | Unused_value_declaration of string      (* 32 *)
+  | Unused_open of string                   (* 33 *)
+  | Unused_type_declaration of string       (* 34 *)
+  | Unused_for_index of string              (* 35 *)
+  | Unused_ancestor of string               (* 36 *)
+  | Unused_constructor of string * bool * bool (* 37 *)
+  | Unused_extension of string * bool * bool * bool (* 38 *)
+  | Unused_rec_flag                         (* 39 *)
+  | Name_out_of_scope of string * string list * bool   (* 40 *)
+  | Ambiguous_name of string list * string list * bool * string (* 41 *)
+  | Disambiguated_name of string            (* 42 *)
+  | Nonoptional_label of string             (* 43 *)
+  | Open_shadow_identifier of string * string (* 44 *)
+  | Open_shadow_label_constructor of string * string (* 45 *)
+  | Bad_env_variable of string * string     (* 46 *)
+  | Attribute_payload of string * string    (* 47 *)
+  | Eliminated_optional_arguments of string list (* 48 *)
+  | No_cmi_file of string * string option   (* 49 *)
+  | Bad_docstring of bool                   (* 50 *)
+  | Expect_tailcall                         (* 51 *)
+  | Fragile_literal_pattern                 (* 52 *)
+  | Misplaced_attribute of string           (* 53 *)
+  | Duplicated_attribute of string          (* 54 *)
+  | Inlining_impossible of string           (* 55 *)
+  | Unreachable_case                        (* 56 *)
+  | Ambiguous_pattern of string list        (* 57 *)
+  | No_cmx_file of string                   (* 58 *)
+  | Assignment_to_non_mutable_value         (* 59 *)
+  | Unused_module of string                 (* 60 *)
+  | Unboxable_type_in_prim_decl of string   (* 61 *)
+  | Constraint_on_gadt                      (* 62 *)
+  | Erroneous_printed_signature of string   (* 63 *)
+  | Unsafe_without_parsing                  (* 64 *)
+  | Redefining_unit of string               (* 65 *)
+  | Unused_open_bang of string              (* 66 *)
+  | Unused_functor_parameter of string      (* 67 *)
+;;
+
+type alert = {kind:string; message:string; def:loc; use:loc}
+
+val parse_options : bool -> string -> unit;;
+
+val parse_alert_option: string -> unit
+  (** Disable/enable alerts based on the parameter to the -alert
+      command-line option.  Raises [Arg.Bad] if the string is not a
+      valid specification.
+  *)
+
+val without_warnings : (unit -> 'a) -> 'a
+  (** Run the thunk with all warnings and alerts disabled. *)
+
+val is_active : t -> bool;;
+val is_error : t -> bool;;
+
+val defaults_w : string;;
+val defaults_warn_error : string;;
+
+type reporting_information =
+  { id : string
+  ; message : string
+  ; is_error : bool
+  ; sub_locs : (loc * string) list;
+  }
+
+val report : t -> [ `Active of reporting_information | `Inactive ]
+val report_alert : alert -> [ `Active of reporting_information | `Inactive ]
+
+exception Errors;;
+
+val check_fatal : unit -> unit;;
+val reset_fatal: unit -> unit
+
+val help_warnings: unit -> unit
+
+type state
+val backup: unit -> state
+val restore: state -> unit
+val mk_lazy: (unit -> 'a) -> 'a Lazy.t
+    (** Like [Lazy.of_fun], but the function is applied with
+        the warning/alert settings at the time [mk_lazy] is called. *)
diff --git a/upstream/ocaml_412/base-rev.txt b/upstream/ocaml_412/base-rev.txt
new file mode 100644
index 0000000..61ab0d4
--- /dev/null
+++ b/upstream/ocaml_412/base-rev.txt
@@ -0,0 +1 @@
+364eab41966ae0c1f9d7a4819bbba0ed409cdf5f
diff --git a/upstream/ocaml_412/file_formats/cmi_format.ml b/upstream/ocaml_412/file_formats/cmi_format.ml
new file mode 100644
index 0000000..eadf676
--- /dev/null
+++ b/upstream/ocaml_412/file_formats/cmi_format.ml
@@ -0,0 +1,118 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Misc
+
+type pers_flags =
+  | Rectypes
+  | Alerts of alerts
+  | Opaque
+  | Unsafe_string
+
+type error =
+  | Not_an_interface of filepath
+  | Wrong_version_interface of filepath * string
+  | Corrupted_interface of filepath
+
+exception Error of error
+
+(* these type abbreviations are not exported;
+   they are used to provide consistency across
+   input_value and output_value usage. *)
+type signature = Types.signature_item list
+type flags = pers_flags list
+type header = modname * signature
+
+type cmi_infos = {
+    cmi_name : modname;
+    cmi_sign : signature;
+    cmi_crcs : crcs;
+    cmi_flags : flags;
+}
+
+let input_cmi ic =
+  let (name, sign) = (input_value ic : header) in
+  let crcs = (input_value ic : crcs) in
+  let flags = (input_value ic : flags) in
+  {
+      cmi_name = name;
+      cmi_sign = sign;
+      cmi_crcs = crcs;
+      cmi_flags = flags;
+    }
+
+let read_cmi filename =
+  let ic = open_in_bin filename in
+  try
+    let buffer =
+      really_input_string ic (String.length Config.cmi_magic_number)
+    in
+    if buffer <> Config.cmi_magic_number then begin
+      close_in ic;
+      let pre_len = String.length Config.cmi_magic_number - 3 in
+      if String.sub buffer 0 pre_len
+          = String.sub Config.cmi_magic_number 0 pre_len then
+      begin
+        let msg =
+          if buffer < Config.cmi_magic_number then "an older" else "a newer" in
+        raise (Error (Wrong_version_interface (filename, msg)))
+      end else begin
+        raise(Error(Not_an_interface filename))
+      end
+    end;
+    let cmi = input_cmi ic in
+    close_in ic;
+    cmi
+  with End_of_file | Failure _ ->
+      close_in ic;
+      raise(Error(Corrupted_interface(filename)))
+    | Error e ->
+      close_in ic;
+      raise (Error e)
+
+let output_cmi filename oc cmi =
+(* beware: the provided signature must have been substituted for saving *)
+  output_string oc Config.cmi_magic_number;
+  output_value oc ((cmi.cmi_name, cmi.cmi_sign) : header);
+  flush oc;
+  let crc = Digest.file filename in
+  let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in
+  output_value oc (crcs : crcs);
+  output_value oc (cmi.cmi_flags : flags);
+  crc
+
+(* Error report *)
+
+open Format
+
+let report_error ppf = function
+  | Not_an_interface filename ->
+      fprintf ppf "%a@ is not a compiled interface"
+        Location.print_filename filename
+  | Wrong_version_interface (filename, older_newer) ->
+      fprintf ppf
+        "%a@ is not a compiled interface for this version of OCaml.@.\
+         It seems to be for %s version of OCaml."
+        Location.print_filename filename older_newer
+  | Corrupted_interface filename ->
+      fprintf ppf "Corrupted compiled interface@ %a"
+        Location.print_filename filename
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )
diff --git a/upstream/ocaml_412/file_formats/cmi_format.mli b/upstream/ocaml_412/file_formats/cmi_format.mli
new file mode 100644
index 0000000..d4d665f
--- /dev/null
+++ b/upstream/ocaml_412/file_formats/cmi_format.mli
@@ -0,0 +1,51 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Misc
+
+type pers_flags =
+  | Rectypes
+  | Alerts of alerts
+  | Opaque
+  | Unsafe_string
+
+type cmi_infos = {
+    cmi_name : modname;
+    cmi_sign : Types.signature_item list;
+    cmi_crcs : crcs;
+    cmi_flags : pers_flags list;
+}
+
+(* write the magic + the cmi information *)
+val output_cmi : string -> out_channel -> cmi_infos -> Digest.t
+
+(* read the cmi information (the magic is supposed to have already been read) *)
+val input_cmi : in_channel -> cmi_infos
+
+(* read a cmi from a filename, checking the magic *)
+val read_cmi : string -> cmi_infos
+
+(* Error report *)
+
+type error =
+  | Not_an_interface of filepath
+  | Wrong_version_interface of filepath * string
+  | Corrupted_interface of filepath
+
+exception Error of error
+
+open Format
+
+val report_error: formatter -> error -> unit
diff --git a/upstream/ocaml_412/file_formats/cmt_format.ml b/upstream/ocaml_412/file_formats/cmt_format.ml
new file mode 100644
index 0000000..709509a
--- /dev/null
+++ b/upstream/ocaml_412/file_formats/cmt_format.ml
@@ -0,0 +1,194 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Cmi_format
+open Typedtree
+
+(* Note that in Typerex, there is an awful hack to save a cmt file
+   together with the interface file that was generated by ocaml (this
+   is because the installed version of ocaml might differ from the one
+   integrated in Typerex).
+*)
+
+
+
+let read_magic_number ic =
+  let len_magic_number = String.length Config.cmt_magic_number in
+  really_input_string ic len_magic_number
+
+type binary_annots =
+  | Packed of Types.signature * string list
+  | Implementation of structure
+  | Interface of signature
+  | Partial_implementation of binary_part array
+  | Partial_interface of binary_part array
+
+and binary_part =
+| Partial_structure of structure
+| Partial_structure_item of structure_item
+| Partial_expression of expression
+| Partial_pattern : 'k pattern_category * 'k general_pattern -> binary_part
+| Partial_class_expr of class_expr
+| Partial_signature of signature
+| Partial_signature_item of signature_item
+| Partial_module_type of module_type
+
+type cmt_infos = {
+  cmt_modname : string;
+  cmt_annots : binary_annots;
+  cmt_value_dependencies :
+    (Types.value_description * Types.value_description) list;
+  cmt_comments : (string * Location.t) list;
+  cmt_args : string array;
+  cmt_sourcefile : string option;
+  cmt_builddir : string;
+  cmt_loadpath : string list;
+  cmt_source_digest : Digest.t option;
+  cmt_initial_env : Env.t;
+  cmt_imports : (string * Digest.t option) list;
+  cmt_interface_digest : Digest.t option;
+  cmt_use_summaries : bool;
+}
+
+type error =
+    Not_a_typedtree of string
+
+let need_to_clear_env =
+  try ignore (Sys.getenv "OCAML_BINANNOT_WITHENV"); false
+  with Not_found -> true
+
+let keep_only_summary = Env.keep_only_summary
+
+open Tast_mapper
+
+let cenv =
+  {Tast_mapper.default with env = fun _sub env -> keep_only_summary env}
+
+let clear_part = function
+  | Partial_structure s -> Partial_structure (cenv.structure cenv s)
+  | Partial_structure_item s ->
+      Partial_structure_item (cenv.structure_item cenv s)
+  | Partial_expression e -> Partial_expression (cenv.expr cenv e)
+  | Partial_pattern (category, p) -> Partial_pattern (category, cenv.pat cenv p)
+  | Partial_class_expr ce -> Partial_class_expr (cenv.class_expr cenv ce)
+  | Partial_signature s -> Partial_signature (cenv.signature cenv s)
+  | Partial_signature_item s ->
+      Partial_signature_item (cenv.signature_item cenv s)
+  | Partial_module_type s -> Partial_module_type (cenv.module_type cenv s)
+
+let clear_env binary_annots =
+  if need_to_clear_env then
+    match binary_annots with
+    | Implementation s -> Implementation (cenv.structure cenv s)
+    | Interface s -> Interface (cenv.signature cenv s)
+    | Packed _ -> binary_annots
+    | Partial_implementation array ->
+        Partial_implementation (Array.map clear_part array)
+    | Partial_interface array ->
+        Partial_interface (Array.map clear_part array)
+
+  else binary_annots
+
+exception Error of error
+
+let input_cmt ic = (input_value ic : cmt_infos)
+
+let output_cmt oc cmt =
+  output_string oc Config.cmt_magic_number;
+  output_value oc (cmt : cmt_infos)
+
+let read filename =
+(*  Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *)
+  let ic = open_in_bin filename in
+  Misc.try_finally
+    ~always:(fun () -> close_in ic)
+    (fun () ->
+       let magic_number = read_magic_number ic in
+       let cmi, cmt =
+         if magic_number = Config.cmt_magic_number then
+           None, Some (input_cmt ic)
+         else if magic_number = Config.cmi_magic_number then
+           let cmi = Cmi_format.input_cmi ic in
+           let cmt = try
+               let magic_number = read_magic_number ic in
+               if magic_number = Config.cmt_magic_number then
+                 let cmt = input_cmt ic in
+                 Some cmt
+               else None
+             with _ -> None
+           in
+           Some cmi, cmt
+         else
+           raise(Cmi_format.Error(Cmi_format.Not_an_interface filename))
+       in
+       cmi, cmt
+    )
+
+let read_cmt filename =
+  match read filename with
+      _, None -> raise (Error (Not_a_typedtree filename))
+    | _, Some cmt -> cmt
+
+let read_cmi filename =
+  match read filename with
+      None, _ ->
+        raise (Cmi_format.Error (Cmi_format.Not_an_interface filename))
+    | Some cmi, _ -> cmi
+
+let saved_types = ref []
+let value_deps = ref []
+
+let clear () =
+  saved_types := [];
+  value_deps := []
+
+let add_saved_type b = saved_types := b :: !saved_types
+let get_saved_types () = !saved_types
+let set_saved_types l = saved_types := l
+
+let record_value_dependency vd1 vd2 =
+  if vd1.Types.val_loc <> vd2.Types.val_loc then
+    value_deps := (vd1, vd2) :: !value_deps
+
+let save_cmt filename modname binary_annots sourcefile initial_env cmi =
+  if !Clflags.binary_annotations && not !Clflags.print_types then begin
+    Misc.output_to_file_via_temporary
+       ~mode:[Open_binary] filename
+       (fun temp_file_name oc ->
+         let this_crc =
+           match cmi with
+           | None -> None
+           | Some cmi -> Some (output_cmi temp_file_name oc cmi)
+         in
+         let source_digest = Option.map Digest.file sourcefile in
+         let cmt = {
+           cmt_modname = modname;
+           cmt_annots = clear_env binary_annots;
+           cmt_value_dependencies = !value_deps;
+           cmt_comments = Lexer.comments ();
+           cmt_args = Sys.argv;
+           cmt_sourcefile = sourcefile;
+           cmt_builddir = Location.rewrite_absolute_path (Sys.getcwd ());
+           cmt_loadpath = Load_path.get_paths ();
+           cmt_source_digest = source_digest;
+           cmt_initial_env = if need_to_clear_env then
+               keep_only_summary initial_env else initial_env;
+           cmt_imports = List.sort compare (Env.imports ());
+           cmt_interface_digest = this_crc;
+           cmt_use_summaries = need_to_clear_env;
+         } in
+         output_cmt oc cmt)
+  end;
+  clear ()
diff --git a/upstream/ocaml_412/file_formats/cmt_format.mli b/upstream/ocaml_412/file_formats/cmt_format.mli
new file mode 100644
index 0000000..8a52c4b
--- /dev/null
+++ b/upstream/ocaml_412/file_formats/cmt_format.mli
@@ -0,0 +1,123 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** cmt and cmti files format. *)
+
+open Misc
+
+(** The layout of a cmt file is as follows:
+      <cmt> := \{<cmi>\} <cmt magic> \{cmt infos\} \{<source info>\}
+    where <cmi> is the cmi file format:
+      <cmi> := <cmi magic> <cmi info>.
+    More precisely, the optional <cmi> part must be present if and only if
+    the file is:
+    - a cmti, or
+    - a cmt, for a ml file which has no corresponding mli (hence no
+    corresponding cmti).
+
+    Thus, we provide a common reading function for cmi and cmt(i)
+    files which returns an option for each of the three parts: cmi
+    info, cmt info, source info. *)
+
+open Typedtree
+
+type binary_annots =
+  | Packed of Types.signature * string list
+  | Implementation of structure
+  | Interface of signature
+  | Partial_implementation of binary_part array
+  | Partial_interface of binary_part array
+
+and binary_part =
+  | Partial_structure of structure
+  | Partial_structure_item of structure_item
+  | Partial_expression of expression
+  | Partial_pattern : 'k pattern_category * 'k general_pattern -> binary_part
+  | Partial_class_expr of class_expr
+  | Partial_signature of signature
+  | Partial_signature_item of signature_item
+  | Partial_module_type of module_type
+
+type cmt_infos = {
+  cmt_modname : modname;
+  cmt_annots : binary_annots;
+  cmt_value_dependencies :
+    (Types.value_description * Types.value_description) list;
+  cmt_comments : (string * Location.t) list;
+  cmt_args : string array;
+  cmt_sourcefile : string option;
+  cmt_builddir : string;
+  cmt_loadpath : string list;
+  cmt_source_digest : string option;
+  cmt_initial_env : Env.t;
+  cmt_imports : crcs;
+  cmt_interface_digest : Digest.t option;
+  cmt_use_summaries : bool;
+}
+
+type error =
+    Not_a_typedtree of string
+
+exception Error of error
+
+(** [read filename] opens filename, and extract both the cmi_infos, if
+    it exists, and the cmt_infos, if it exists. Thus, it can be used
+    with .cmi, .cmt and .cmti files.
+
+    .cmti files always contain a cmi_infos at the beginning. .cmt files
+    only contain a cmi_infos at the beginning if there is no associated
+    .cmti file.
+*)
+val read : string -> Cmi_format.cmi_infos option * cmt_infos option
+
+val read_cmt : string -> cmt_infos
+val read_cmi : string -> Cmi_format.cmi_infos
+
+(** [save_cmt filename modname binary_annots sourcefile initial_env cmi]
+    writes a cmt(i) file.  *)
+val save_cmt :
+  string ->  (* filename.cmt to generate *)
+  string ->  (* module name *)
+  binary_annots ->
+  string option ->  (* source file *)
+  Env.t -> (* initial env *)
+  Cmi_format.cmi_infos option -> (* if a .cmi was generated *)
+  unit
+
+(* Miscellaneous functions *)
+
+val read_magic_number : in_channel -> string
+
+val clear: unit -> unit
+
+val add_saved_type : binary_part -> unit
+val get_saved_types : unit -> binary_part list
+val set_saved_types : binary_part list -> unit
+
+val record_value_dependency:
+  Types.value_description -> Types.value_description -> unit
+
+
+(*
+
+  val is_magic_number : string -> bool
+  val read : in_channel -> Env.cmi_infos option * t
+  val write_magic_number : out_channel -> unit
+  val write : out_channel -> t -> unit
+
+  val find : string list -> string -> string
+  val read_signature : 'a -> string -> Types.signature * 'b list * 'c list
+
+*)
diff --git a/upstream/ocaml_412/parsing/ast_helper.ml b/upstream/ocaml_412/parsing/ast_helper.ml
new file mode 100644
index 0000000..2d51dda
--- /dev/null
+++ b/upstream/ocaml_412/parsing/ast_helper.ml
@@ -0,0 +1,642 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Helpers to produce Parsetree fragments *)
+
+open Asttypes
+open Parsetree
+open Docstrings
+
+type 'a with_loc = 'a Location.loc
+type loc = Location.t
+
+type lid = Longident.t with_loc
+type str = string with_loc
+type str_opt = string option with_loc
+type attrs = attribute list
+
+let default_loc = ref Location.none
+
+let with_default_loc l f =
+  Misc.protect_refs [Misc.R (default_loc, l)] f
+
+module Const = struct
+  let integer ?suffix i = Pconst_integer (i, suffix)
+  let int ?suffix i = integer ?suffix (Int.to_string i)
+  let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i)
+  let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i)
+  let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i)
+  let float ?suffix f = Pconst_float (f, suffix)
+  let char c = Pconst_char c
+  let string ?quotation_delimiter ?(loc= !default_loc) s =
+    Pconst_string (s, loc, quotation_delimiter)
+end
+
+module Attr = struct
+  let mk ?(loc= !default_loc) name payload =
+    { attr_name = name;
+      attr_payload = payload;
+      attr_loc = loc }
+end
+
+module Typ = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {ptyp_desc = d;
+     ptyp_loc = loc;
+     ptyp_loc_stack = [];
+     ptyp_attributes = attrs}
+
+  let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]}
+
+  let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any
+  let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a)
+  let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c))
+  let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a)
+  let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b))
+  let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b))
+  let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b))
+  let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b))
+  let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c))
+  let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b))
+  let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b))
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a)
+
+  let force_poly t =
+    match t.ptyp_desc with
+    | Ptyp_poly _ -> t
+    | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *)
+
+  let varify_constructors var_names t =
+    let check_variable vl loc v =
+      if List.mem v vl then
+        raise Syntaxerr.(Error(Variable_in_scope(loc,v))) in
+    let var_names = List.map (fun v -> v.txt) var_names in
+    let rec loop t =
+      let desc =
+        match t.ptyp_desc with
+        | Ptyp_any -> Ptyp_any
+        | Ptyp_var x ->
+            check_variable var_names t.ptyp_loc x;
+            Ptyp_var x
+        | Ptyp_arrow (label,core_type,core_type') ->
+            Ptyp_arrow(label, loop core_type, loop core_type')
+        | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst)
+        | Ptyp_constr( { txt = Longident.Lident s }, [])
+          when List.mem s var_names ->
+            Ptyp_var s
+        | Ptyp_constr(longident, lst) ->
+            Ptyp_constr(longident, List.map loop lst)
+        | Ptyp_object (lst, o) ->
+            Ptyp_object (List.map loop_object_field lst, o)
+        | Ptyp_class (longident, lst) ->
+            Ptyp_class (longident, List.map loop lst)
+        | Ptyp_alias(core_type, string) ->
+            check_variable var_names t.ptyp_loc string;
+            Ptyp_alias(loop core_type, string)
+        | Ptyp_variant(row_field_list, flag, lbl_lst_option) ->
+            Ptyp_variant(List.map loop_row_field row_field_list,
+                         flag, lbl_lst_option)
+        | Ptyp_poly(string_lst, core_type) ->
+          List.iter (fun v ->
+            check_variable var_names t.ptyp_loc v.txt) string_lst;
+            Ptyp_poly(string_lst, loop core_type)
+        | Ptyp_package(longident,lst) ->
+            Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst)
+        | Ptyp_extension (s, arg) ->
+            Ptyp_extension (s, arg)
+      in
+      {t with ptyp_desc = desc}
+    and loop_row_field field =
+      let prf_desc = match field.prf_desc with
+        | Rtag(label,flag,lst) ->
+            Rtag(label,flag,List.map loop lst)
+        | Rinherit t ->
+            Rinherit (loop t)
+      in
+      { field with prf_desc; }
+    and loop_object_field field =
+      let pof_desc = match field.pof_desc with
+        | Otag(label, t) ->
+            Otag(label, loop t)
+        | Oinherit t ->
+            Oinherit (loop t)
+      in
+      { field with pof_desc; }
+    in
+    loop t
+
+end
+
+module Pat = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {ppat_desc = d;
+     ppat_loc = loc;
+     ppat_loc_stack = [];
+     ppat_attributes = attrs}
+  let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]}
+
+  let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any
+  let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a)
+  let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b))
+  let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a)
+  let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b))
+  let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a)
+  let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b))
+  let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b))
+  let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b))
+  let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a)
+  let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b))
+  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b))
+  let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a)
+  let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a)
+  let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a)
+  let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b))
+  let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a)
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a)
+end
+
+module Exp = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {pexp_desc = d;
+     pexp_loc = loc;
+     pexp_loc_stack = [];
+     pexp_attributes = attrs}
+  let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]}
+
+  let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a)
+  let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a)
+  let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c))
+  let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d))
+  let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a)
+  let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b))
+  let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b))
+  let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b))
+  let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a)
+  let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b))
+  let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b))
+  let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b))
+  let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b))
+  let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c))
+  let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a)
+  let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c))
+  let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b))
+  let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b))
+  let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e))
+  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b))
+  let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c))
+  let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b))
+  let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a)
+  let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b))
+  let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a)
+  let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c))
+  let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b))
+  let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a)
+  let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a)
+  let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b))
+  let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a)
+  let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b))
+  let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a)
+  let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_open (a, b))
+  let letop ?loc ?attrs let_ ands body =
+    mk ?loc ?attrs (Pexp_letop {let_; ands; body})
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a)
+  let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable
+
+  let case lhs ?guard rhs =
+    {
+     pc_lhs = lhs;
+     pc_guard = guard;
+     pc_rhs = rhs;
+    }
+
+  let binding_op op pat exp loc =
+    {
+      pbop_op = op;
+      pbop_pat = pat;
+      pbop_exp = exp;
+      pbop_loc = loc;
+    }
+end
+
+module Mty = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs}
+  let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]}
+
+  let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a)
+  let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a)
+  let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a)
+  let functor_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_functor (a, b))
+  let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b))
+  let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a)
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a)
+end
+
+module Mod = struct
+let mk ?(loc = !default_loc) ?(attrs = []) d =
+  {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs}
+  let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]}
+
+  let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x)
+  let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x)
+  let functor_ ?loc ?attrs arg body =
+    mk ?loc ?attrs (Pmod_functor (arg, body))
+  let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2))
+  let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty))
+  let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e)
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a)
+end
+
+module Sig = struct
+  let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc}
+
+  let value ?loc a = mk ?loc (Psig_value a)
+  let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a))
+  let type_subst ?loc a = mk ?loc (Psig_typesubst a)
+  let type_extension ?loc a = mk ?loc (Psig_typext a)
+  let exception_ ?loc a = mk ?loc (Psig_exception a)
+  let module_ ?loc a = mk ?loc (Psig_module a)
+  let mod_subst ?loc a = mk ?loc (Psig_modsubst a)
+  let rec_module ?loc a = mk ?loc (Psig_recmodule a)
+  let modtype ?loc a = mk ?loc (Psig_modtype a)
+  let open_ ?loc a = mk ?loc (Psig_open a)
+  let include_ ?loc a = mk ?loc (Psig_include a)
+  let class_ ?loc a = mk ?loc (Psig_class a)
+  let class_type ?loc a = mk ?loc (Psig_class_type a)
+  let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs))
+  let attribute ?loc a = mk ?loc (Psig_attribute a)
+  let text txt =
+    let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
+    List.map
+      (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
+      f_txt
+end
+
+module Str = struct
+  let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc}
+
+  let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs))
+  let value ?loc a b = mk ?loc (Pstr_value (a, b))
+  let primitive ?loc a = mk ?loc (Pstr_primitive a)
+  let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a))
+  let type_extension ?loc a = mk ?loc (Pstr_typext a)
+  let exception_ ?loc a = mk ?loc (Pstr_exception a)
+  let module_ ?loc a = mk ?loc (Pstr_module a)
+  let rec_module ?loc a = mk ?loc (Pstr_recmodule a)
+  let modtype ?loc a = mk ?loc (Pstr_modtype a)
+  let open_ ?loc a = mk ?loc (Pstr_open a)
+  let class_ ?loc a = mk ?loc (Pstr_class a)
+  let class_type ?loc a = mk ?loc (Pstr_class_type a)
+  let include_ ?loc a = mk ?loc (Pstr_include a)
+  let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs))
+  let attribute ?loc a = mk ?loc (Pstr_attribute a)
+  let text txt =
+    let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
+    List.map
+      (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
+      f_txt
+end
+
+module Cl = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {
+     pcl_desc = d;
+     pcl_loc = loc;
+     pcl_attributes = attrs;
+    }
+  let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]}
+
+  let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b))
+  let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a)
+  let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d))
+  let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b))
+  let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c))
+  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b))
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a)
+  let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_open (a, b))
+end
+
+module Cty = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {
+     pcty_desc = d;
+     pcty_loc = loc;
+     pcty_attributes = attrs;
+    }
+  let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]}
+
+  let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b))
+  let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a)
+  let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c))
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a)
+  let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcty_open (a, b))
+end
+
+module Ctf = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+           ?(docs = empty_docs) d =
+    {
+     pctf_desc = d;
+     pctf_loc = loc;
+     pctf_attributes = add_docs_attrs docs attrs;
+    }
+
+  let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a)
+  let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d))
+  let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d))
+  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b))
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a)
+  let attribute ?loc a = mk ?loc (Pctf_attribute a)
+  let text txt =
+   let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
+     List.map
+      (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
+      f_txt
+
+  let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]}
+
+end
+
+module Cf = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) d =
+    {
+     pcf_desc = d;
+     pcf_loc = loc;
+     pcf_attributes = add_docs_attrs docs attrs;
+    }
+
+  let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c))
+  let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c))
+  let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c))
+  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b))
+  let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a)
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a)
+  let attribute ?loc a = mk ?loc (Pcf_attribute a)
+  let text txt =
+    let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
+    List.map
+      (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
+      f_txt
+
+  let virtual_ ct = Cfk_virtual ct
+  let concrete o e = Cfk_concrete (o, e)
+
+  let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]}
+
+end
+
+module Val = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+        ?(prim = []) name typ =
+    {
+     pval_name = name;
+     pval_type = typ;
+     pval_attributes = add_docs_attrs docs attrs;
+     pval_loc = loc;
+     pval_prim = prim;
+    }
+end
+
+module Md = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = []) name typ =
+    {
+     pmd_name = name;
+     pmd_type = typ;
+     pmd_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pmd_loc = loc;
+    }
+end
+
+module Ms = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = []) name syn =
+    {
+     pms_name = name;
+     pms_manifest = syn;
+     pms_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pms_loc = loc;
+    }
+end
+
+module Mtd = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = []) ?typ name =
+    {
+     pmtd_name = name;
+     pmtd_type = typ;
+     pmtd_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pmtd_loc = loc;
+    }
+end
+
+module Mb = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = []) name expr =
+    {
+     pmb_name = name;
+     pmb_expr = expr;
+     pmb_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pmb_loc = loc;
+    }
+end
+
+module Opn = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+        ?(override = Fresh) expr =
+    {
+     popen_expr = expr;
+     popen_override = override;
+     popen_loc = loc;
+     popen_attributes = add_docs_attrs docs attrs;
+    }
+end
+
+module Incl = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr =
+    {
+     pincl_mod = mexpr;
+     pincl_loc = loc;
+     pincl_attributes = add_docs_attrs docs attrs;
+    }
+
+end
+
+module Vb = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+        ?(text = []) pat expr =
+    {
+     pvb_pat = pat;
+     pvb_expr = expr;
+     pvb_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pvb_loc = loc;
+    }
+end
+
+module Ci = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = [])
+        ?(virt = Concrete) ?(params = []) name expr =
+    {
+     pci_virt = virt;
+     pci_params = params;
+     pci_name = name;
+     pci_expr = expr;
+     pci_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pci_loc = loc;
+    }
+end
+
+module Type = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = [])
+      ?(params = [])
+      ?(cstrs = [])
+      ?(kind = Ptype_abstract)
+      ?(priv = Public)
+      ?manifest
+      name =
+    {
+     ptype_name = name;
+     ptype_params = params;
+     ptype_cstrs = cstrs;
+     ptype_kind = kind;
+     ptype_private = priv;
+     ptype_manifest = manifest;
+     ptype_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     ptype_loc = loc;
+    }
+
+  let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info)
+        ?(args = Pcstr_tuple []) ?res name =
+    {
+     pcd_name = name;
+     pcd_args = args;
+     pcd_res = res;
+     pcd_loc = loc;
+     pcd_attributes = add_info_attrs info attrs;
+    }
+
+  let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info)
+        ?(mut = Immutable) name typ =
+    {
+     pld_name = name;
+     pld_mutable = mut;
+     pld_type = typ;
+     pld_loc = loc;
+     pld_attributes = add_info_attrs info attrs;
+    }
+
+end
+
+(** Type extensions *)
+module Te = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+        ?(params = []) ?(priv = Public) path constructors =
+    {
+     ptyext_path = path;
+     ptyext_params = params;
+     ptyext_constructors = constructors;
+     ptyext_private = priv;
+     ptyext_loc = loc;
+     ptyext_attributes = add_docs_attrs docs attrs;
+    }
+
+  let mk_exception ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+      constructor =
+    {
+     ptyexn_constructor = constructor;
+     ptyexn_loc = loc;
+     ptyexn_attributes = add_docs_attrs docs attrs;
+    }
+
+  let constructor ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(info = empty_info) name kind =
+    {
+     pext_name = name;
+     pext_kind = kind;
+     pext_loc = loc;
+     pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
+    }
+
+  let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+             ?(info = empty_info) ?(args = Pcstr_tuple []) ?res name =
+    {
+     pext_name = name;
+     pext_kind = Pext_decl(args, res);
+     pext_loc = loc;
+     pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
+    }
+
+  let rebind ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(info = empty_info) name lid =
+    {
+     pext_name = name;
+     pext_kind = Pext_rebind lid;
+     pext_loc = loc;
+     pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
+    }
+
+end
+
+module Csig = struct
+  let mk self fields =
+    {
+     pcsig_self = self;
+     pcsig_fields = fields;
+    }
+end
+
+module Cstr = struct
+  let mk self fields =
+    {
+     pcstr_self = self;
+     pcstr_fields = fields;
+    }
+end
+
+(** Row fields *)
+module Rf = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) desc = {
+    prf_desc = desc;
+    prf_loc = loc;
+    prf_attributes = attrs;
+  }
+  let tag ?loc ?attrs label const tys =
+    mk ?loc ?attrs (Rtag (label, const, tys))
+  let inherit_?loc ty =
+    mk ?loc (Rinherit ty)
+end
+
+(** Object fields *)
+module Of = struct
+  let mk ?(loc = !default_loc) ?(attrs=[]) desc = {
+    pof_desc = desc;
+    pof_loc = loc;
+    pof_attributes = attrs;
+  }
+  let tag ?loc ?attrs label ty =
+    mk ?loc ?attrs (Otag (label, ty))
+  let inherit_ ?loc ty =
+    mk ?loc (Oinherit ty)
+end
diff --git a/upstream/ocaml_412/parsing/ast_helper.mli b/upstream/ocaml_412/parsing/ast_helper.mli
new file mode 100644
index 0000000..8182e5d
--- /dev/null
+++ b/upstream/ocaml_412/parsing/ast_helper.mli
@@ -0,0 +1,491 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Helpers to produce Parsetree fragments
+
+  {b Warning} This module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Asttypes
+open Docstrings
+open Parsetree
+
+type 'a with_loc = 'a Location.loc
+type loc = Location.t
+
+type lid = Longident.t with_loc
+type str = string with_loc
+type str_opt = string option with_loc
+type attrs = attribute list
+
+(** {1 Default locations} *)
+
+val default_loc: loc ref
+    (** Default value for all optional location arguments. *)
+
+val with_default_loc: loc -> (unit -> 'a) -> 'a
+    (** Set the [default_loc] within the scope of the execution
+        of the provided function. *)
+
+(** {1 Constants} *)
+
+module Const : sig
+  val char : char -> constant
+  val string :
+    ?quotation_delimiter:string -> ?loc:Location.t -> string -> constant
+  val integer : ?suffix:char -> string -> constant
+  val int : ?suffix:char -> int -> constant
+  val int32 : ?suffix:char -> int32 -> constant
+  val int64 : ?suffix:char -> int64 -> constant
+  val nativeint : ?suffix:char -> nativeint -> constant
+  val float : ?suffix:char -> string -> constant
+end
+
+(** {1 Attributes} *)
+module Attr : sig
+  val mk: ?loc:loc -> str -> payload -> attribute
+end
+
+(** {1 Core language} *)
+
+(** Type expressions *)
+module Typ :
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type
+    val attr: core_type -> attribute -> core_type
+
+    val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type
+    val var: ?loc:loc -> ?attrs:attrs -> string -> core_type
+    val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type
+               -> core_type
+    val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type
+    val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
+    val object_: ?loc:loc -> ?attrs:attrs -> object_field list
+                   -> closed_flag -> core_type
+    val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
+    val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type
+    val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag
+                 -> label list option -> core_type
+    val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type
+    val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list
+                 -> core_type
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type
+
+    val force_poly: core_type -> core_type
+
+    val varify_constructors: str list -> core_type -> core_type
+    (** [varify_constructors newtypes te] is type expression [te], of which
+        any of nullary type constructor [tc] is replaced by type variable of
+        the same name, if [tc]'s name appears in [newtypes].
+        Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te]
+        appears in [newtypes].
+        @since 4.05
+     *)
+  end
+
+(** Patterns *)
+module Pat:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern
+    val attr:pattern -> attribute -> pattern
+
+    val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern
+    val var: ?loc:loc -> ?attrs:attrs -> str -> pattern
+    val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern
+    val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern
+    val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern
+    val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern
+    val construct: ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern
+    val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern
+    val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag
+                -> pattern
+    val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern
+    val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern
+    val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern
+    val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern
+    val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern
+    val unpack: ?loc:loc -> ?attrs:attrs -> str_opt -> pattern
+    val open_: ?loc:loc -> ?attrs:attrs  -> lid -> pattern -> pattern
+    val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern
+  end
+
+(** Expressions *)
+module Exp:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression
+    val attr: expression -> attribute -> expression
+
+    val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression
+    val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression
+    val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list
+              -> expression -> expression
+    val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option
+              -> pattern -> expression -> expression
+    val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression
+    val apply: ?loc:loc -> ?attrs:attrs -> expression
+               -> (arg_label * expression) list -> expression
+    val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list
+                -> expression
+    val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression
+    val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression
+    val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option
+                   -> expression
+    val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option
+                 -> expression
+    val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list
+                -> expression option -> expression
+    val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression
+    val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression
+                  -> expression
+    val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression
+    val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression
+                    -> expression option -> expression
+    val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression
+                  -> expression
+    val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression
+                -> expression
+    val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression
+              -> direction_flag -> expression -> expression
+    val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option
+                -> core_type -> expression
+    val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type
+                     -> expression
+    val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression
+    val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression
+    val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression
+    val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list
+                  -> expression
+    val letmodule: ?loc:loc -> ?attrs:attrs -> str_opt -> module_expr
+                   -> expression -> expression
+    val letexception:
+      ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression
+      -> expression
+    val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression
+    val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression
+    val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option
+              -> expression
+    val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression
+    val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression
+    val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression
+    val open_: ?loc:loc -> ?attrs:attrs -> open_declaration -> expression
+               -> expression
+    val letop: ?loc:loc -> ?attrs:attrs -> binding_op
+               -> binding_op list -> expression -> expression
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression
+    val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression
+
+    val case: pattern -> ?guard:expression -> expression -> case
+    val binding_op: str -> pattern -> expression -> loc -> binding_op
+  end
+
+(** Value declarations *)
+module Val:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
+      ?prim:string list -> str -> core_type -> value_description
+  end
+
+(** Type declarations *)
+module Type:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      ?params:(core_type * (variance * injectivity)) list ->
+      ?cstrs:(core_type * core_type * loc) list ->
+      ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str ->
+      type_declaration
+
+    val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info ->
+      ?args:constructor_arguments -> ?res:core_type -> str ->
+      constructor_declaration
+    val field: ?loc:loc -> ?attrs:attrs -> ?info:info ->
+      ?mut:mutable_flag -> str -> core_type -> label_declaration
+  end
+
+(** Type extensions *)
+module Te:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
+      ?params:(core_type * (variance * injectivity)) list ->
+      ?priv:private_flag -> lid -> extension_constructor list -> type_extension
+
+    val mk_exception: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
+      extension_constructor -> type_exception
+
+    val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
+      str -> extension_constructor_kind -> extension_constructor
+
+    val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
+      ?args:constructor_arguments -> ?res:core_type -> str ->
+      extension_constructor
+    val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
+      str -> lid -> extension_constructor
+  end
+
+(** {1 Module language} *)
+
+(** Module type expressions *)
+module Mty:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type
+    val attr: module_type -> attribute -> module_type
+
+    val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type
+    val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type
+    val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type
+    val functor_: ?loc:loc -> ?attrs:attrs ->
+      functor_parameter -> module_type -> module_type
+    val with_: ?loc:loc -> ?attrs:attrs -> module_type ->
+      with_constraint list -> module_type
+    val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type
+  end
+
+(** Module expressions *)
+module Mod:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr
+    val attr: module_expr -> attribute -> module_expr
+
+    val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr
+    val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr
+    val functor_: ?loc:loc -> ?attrs:attrs ->
+      functor_parameter -> module_expr -> module_expr
+    val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr ->
+      module_expr
+    val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type ->
+      module_expr
+    val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr
+  end
+
+(** Signature items *)
+module Sig:
+  sig
+    val mk: ?loc:loc -> signature_item_desc -> signature_item
+
+    val value: ?loc:loc -> value_description -> signature_item
+    val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item
+    val type_subst: ?loc:loc -> type_declaration list -> signature_item
+    val type_extension: ?loc:loc -> type_extension -> signature_item
+    val exception_: ?loc:loc -> type_exception -> signature_item
+    val module_: ?loc:loc -> module_declaration -> signature_item
+    val mod_subst: ?loc:loc -> module_substitution -> signature_item
+    val rec_module: ?loc:loc -> module_declaration list -> signature_item
+    val modtype: ?loc:loc -> module_type_declaration -> signature_item
+    val open_: ?loc:loc -> open_description -> signature_item
+    val include_: ?loc:loc -> include_description -> signature_item
+    val class_: ?loc:loc -> class_description list -> signature_item
+    val class_type: ?loc:loc -> class_type_declaration list -> signature_item
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item
+    val attribute: ?loc:loc -> attribute -> signature_item
+    val text: text -> signature_item list
+  end
+
+(** Structure items *)
+module Str:
+  sig
+    val mk: ?loc:loc -> structure_item_desc -> structure_item
+
+    val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item
+    val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item
+    val primitive: ?loc:loc -> value_description -> structure_item
+    val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item
+    val type_extension: ?loc:loc -> type_extension -> structure_item
+    val exception_: ?loc:loc -> type_exception -> structure_item
+    val module_: ?loc:loc -> module_binding -> structure_item
+    val rec_module: ?loc:loc -> module_binding list -> structure_item
+    val modtype: ?loc:loc -> module_type_declaration -> structure_item
+    val open_: ?loc:loc -> open_declaration -> structure_item
+    val class_: ?loc:loc -> class_declaration list -> structure_item
+    val class_type: ?loc:loc -> class_type_declaration list -> structure_item
+    val include_: ?loc:loc -> include_declaration -> structure_item
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item
+    val attribute: ?loc:loc -> attribute -> structure_item
+    val text: text -> structure_item list
+  end
+
+(** Module declarations *)
+module Md:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      str_opt -> module_type -> module_declaration
+  end
+
+(** Module substitutions *)
+module Ms:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      str -> lid -> module_substitution
+  end
+
+(** Module type declarations *)
+module Mtd:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      ?typ:module_type -> str -> module_type_declaration
+  end
+
+(** Module bindings *)
+module Mb:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      str_opt -> module_expr -> module_binding
+  end
+
+(** Opens *)
+module Opn:
+  sig
+    val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs ->
+      ?override:override_flag -> 'a -> 'a open_infos
+  end
+
+(** Includes *)
+module Incl:
+  sig
+    val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos
+  end
+
+(** Value bindings *)
+module Vb:
+  sig
+    val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      pattern -> expression -> value_binding
+  end
+
+
+(** {1 Class language} *)
+
+(** Class type expressions *)
+module Cty:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type
+    val attr: class_type -> attribute -> class_type
+
+    val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type
+    val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type
+    val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type ->
+      class_type -> class_type
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type
+    val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_type
+               -> class_type
+  end
+
+(** Class type fields *)
+module Ctf:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
+      class_type_field_desc -> class_type_field
+    val attr: class_type_field -> attribute -> class_type_field
+
+    val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field
+    val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag ->
+      virtual_flag -> core_type -> class_type_field
+    val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag ->
+      virtual_flag -> core_type -> class_type_field
+    val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type ->
+      class_type_field
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field
+    val attribute: ?loc:loc -> attribute -> class_type_field
+    val text: text -> class_type_field list
+  end
+
+(** Class expressions *)
+module Cl:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr
+    val attr: class_expr -> attribute -> class_expr
+
+    val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr
+    val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr
+    val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option ->
+      pattern -> class_expr -> class_expr
+    val apply: ?loc:loc -> ?attrs:attrs -> class_expr ->
+      (arg_label * expression) list -> class_expr
+    val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list ->
+      class_expr -> class_expr
+    val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type ->
+      class_expr
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr
+    val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_expr
+               -> class_expr
+  end
+
+(** Class fields *)
+module Cf:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc ->
+      class_field
+    val attr: class_field -> attribute -> class_field
+
+    val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr ->
+      str option -> class_field
+    val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag ->
+      class_field_kind -> class_field
+    val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag ->
+      class_field_kind -> class_field
+    val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type ->
+      class_field
+    val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field
+    val attribute: ?loc:loc -> attribute -> class_field
+    val text: text -> class_field list
+
+    val virtual_: core_type -> class_field_kind
+    val concrete: override_flag -> expression -> class_field_kind
+
+  end
+
+(** Classes *)
+module Ci:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      ?virt:virtual_flag ->
+      ?params:(core_type * (variance * injectivity)) list ->
+      str -> 'a -> 'a class_infos
+  end
+
+(** Class signatures *)
+module Csig:
+  sig
+    val mk: core_type -> class_type_field list -> class_signature
+  end
+
+(** Class structures *)
+module Cstr:
+  sig
+    val mk: pattern -> class_field list -> class_structure
+  end
+
+(** Row fields *)
+module Rf:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> row_field_desc -> row_field
+    val tag: ?loc:loc -> ?attrs:attrs ->
+      label with_loc -> bool -> core_type list -> row_field
+    val inherit_: ?loc:loc -> core_type -> row_field
+  end
+
+(** Object fields *)
+module Of:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs ->
+      object_field_desc -> object_field
+    val tag: ?loc:loc -> ?attrs:attrs ->
+      label with_loc -> core_type -> object_field
+    val inherit_: ?loc:loc -> core_type -> object_field
+  end
diff --git a/upstream/ocaml_412/parsing/ast_iterator.ml b/upstream/ocaml_412/parsing/ast_iterator.ml
new file mode 100644
index 0000000..5f016c0
--- /dev/null
+++ b/upstream/ocaml_412/parsing/ast_iterator.ml
@@ -0,0 +1,673 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Nicolas Ojeda Bar, LexiFi                         *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* A generic Parsetree mapping class *)
+
+(*
+[@@@ocaml.warning "+9"]
+  (* Ensure that record patterns don't miss any field. *)
+*)
+
+
+open Parsetree
+open Location
+
+type iterator = {
+  attribute: iterator -> attribute -> unit;
+  attributes: iterator -> attribute list -> unit;
+  binding_op: iterator -> binding_op -> unit;
+  case: iterator -> case -> unit;
+  cases: iterator -> case list -> unit;
+  class_declaration: iterator -> class_declaration -> unit;
+  class_description: iterator -> class_description -> unit;
+  class_expr: iterator -> class_expr -> unit;
+  class_field: iterator -> class_field -> unit;
+  class_signature: iterator -> class_signature -> unit;
+  class_structure: iterator -> class_structure -> unit;
+  class_type: iterator -> class_type -> unit;
+  class_type_declaration: iterator -> class_type_declaration -> unit;
+  class_type_field: iterator -> class_type_field -> unit;
+  constructor_declaration: iterator -> constructor_declaration -> unit;
+  expr: iterator -> expression -> unit;
+  extension: iterator -> extension -> unit;
+  extension_constructor: iterator -> extension_constructor -> unit;
+  include_declaration: iterator -> include_declaration -> unit;
+  include_description: iterator -> include_description -> unit;
+  label_declaration: iterator -> label_declaration -> unit;
+  location: iterator -> Location.t -> unit;
+  module_binding: iterator -> module_binding -> unit;
+  module_declaration: iterator -> module_declaration -> unit;
+  module_substitution: iterator -> module_substitution -> unit;
+  module_expr: iterator -> module_expr -> unit;
+  module_type: iterator -> module_type -> unit;
+  module_type_declaration: iterator -> module_type_declaration -> unit;
+  open_declaration: iterator -> open_declaration -> unit;
+  open_description: iterator -> open_description -> unit;
+  pat: iterator -> pattern -> unit;
+  payload: iterator -> payload -> unit;
+  signature: iterator -> signature -> unit;
+  signature_item: iterator -> signature_item -> unit;
+  structure: iterator -> structure -> unit;
+  structure_item: iterator -> structure_item -> unit;
+  typ: iterator -> core_type -> unit;
+  row_field: iterator -> row_field -> unit;
+  object_field: iterator -> object_field -> unit;
+  type_declaration: iterator -> type_declaration -> unit;
+  type_extension: iterator -> type_extension -> unit;
+  type_exception: iterator -> type_exception -> unit;
+  type_kind: iterator -> type_kind -> unit;
+  value_binding: iterator -> value_binding -> unit;
+  value_description: iterator -> value_description -> unit;
+  with_constraint: iterator -> with_constraint -> unit;
+}
+(** A [iterator] record implements one "method" per syntactic category,
+    using an open recursion style: each method takes as its first
+    argument the iterator to be applied to children in the syntax
+    tree. *)
+
+let iter_fst f (x, _) = f x
+let iter_snd f (_, y) = f y
+let iter_tuple f1 f2 (x, y) = f1 x; f2 y
+let iter_tuple3 f1 f2 f3 (x, y, z) = f1 x; f2 y; f3 z
+let iter_opt f = function None -> () | Some x -> f x
+
+let iter_loc sub {loc; txt = _} = sub.location sub loc
+
+module T = struct
+  (* Type expressions for the core language *)
+
+  let row_field sub {
+      prf_desc;
+      prf_loc;
+      prf_attributes;
+    } =
+    sub.location sub prf_loc;
+    sub.attributes sub prf_attributes;
+    match prf_desc with
+    | Rtag (_, _, tl) -> List.iter (sub.typ sub) tl
+    | Rinherit t -> sub.typ sub t
+
+  let object_field sub {
+      pof_desc;
+      pof_loc;
+      pof_attributes;
+    } =
+    sub.location sub pof_loc;
+    sub.attributes sub pof_attributes;
+    match pof_desc with
+    | Otag (_, t) -> sub.typ sub t
+    | Oinherit t -> sub.typ sub t
+
+  let iter sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Ptyp_any
+    | Ptyp_var _ -> ()
+    | Ptyp_arrow (_lab, t1, t2) ->
+        sub.typ sub t1; sub.typ sub t2
+    | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl
+    | Ptyp_constr (lid, tl) ->
+        iter_loc sub lid; List.iter (sub.typ sub) tl
+    | Ptyp_object (ol, _o) ->
+        List.iter (object_field sub) ol
+    | Ptyp_class (lid, tl) ->
+        iter_loc sub lid; List.iter (sub.typ sub) tl
+    | Ptyp_alias (t, _) -> sub.typ sub t
+    | Ptyp_variant (rl, _b, _ll) ->
+        List.iter (row_field sub) rl
+    | Ptyp_poly (_, t) -> sub.typ sub t
+    | Ptyp_package (lid, l) ->
+        iter_loc sub lid;
+        List.iter (iter_tuple (iter_loc sub) (sub.typ sub)) l
+    | Ptyp_extension x -> sub.extension sub x
+
+  let iter_type_declaration sub
+      {ptype_name; ptype_params; ptype_cstrs;
+       ptype_kind;
+       ptype_private = _;
+       ptype_manifest;
+       ptype_attributes;
+       ptype_loc} =
+    iter_loc sub ptype_name;
+    List.iter (iter_fst (sub.typ sub)) ptype_params;
+    List.iter
+      (iter_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub))
+      ptype_cstrs;
+    sub.type_kind sub ptype_kind;
+    iter_opt (sub.typ sub) ptype_manifest;
+    sub.location sub ptype_loc;
+    sub.attributes sub ptype_attributes
+
+  let iter_type_kind sub = function
+    | Ptype_abstract -> ()
+    | Ptype_variant l ->
+        List.iter (sub.constructor_declaration sub) l
+    | Ptype_record l -> List.iter (sub.label_declaration sub) l
+    | Ptype_open -> ()
+
+  let iter_constructor_arguments sub = function
+    | Pcstr_tuple l -> List.iter (sub.typ sub) l
+    | Pcstr_record l ->
+        List.iter (sub.label_declaration sub) l
+
+  let iter_type_extension sub
+      {ptyext_path; ptyext_params;
+       ptyext_constructors;
+       ptyext_private = _;
+       ptyext_loc;
+       ptyext_attributes} =
+    iter_loc sub ptyext_path;
+    List.iter (sub.extension_constructor sub) ptyext_constructors;
+    List.iter (iter_fst (sub.typ sub)) ptyext_params;
+    sub.location sub ptyext_loc;
+    sub.attributes sub ptyext_attributes
+
+  let iter_type_exception sub
+      {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} =
+    sub.extension_constructor sub ptyexn_constructor;
+    sub.location sub ptyexn_loc;
+    sub.attributes sub ptyexn_attributes
+
+  let iter_extension_constructor_kind sub = function
+      Pext_decl(ctl, cto) ->
+        iter_constructor_arguments sub ctl; iter_opt (sub.typ sub) cto
+    | Pext_rebind li ->
+        iter_loc sub li
+
+  let iter_extension_constructor sub
+      {pext_name;
+       pext_kind;
+       pext_loc;
+       pext_attributes} =
+    iter_loc sub pext_name;
+    iter_extension_constructor_kind sub pext_kind;
+    sub.location sub pext_loc;
+    sub.attributes sub pext_attributes
+
+end
+
+module CT = struct
+  (* Type expressions for the class language *)
+
+  let iter sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pcty_constr (lid, tys) ->
+        iter_loc sub lid; List.iter (sub.typ sub) tys
+    | Pcty_signature x -> sub.class_signature sub x
+    | Pcty_arrow (_lab, t, ct) ->
+        sub.typ sub t; sub.class_type sub ct
+    | Pcty_extension x -> sub.extension sub x
+    | Pcty_open (o, e) ->
+        sub.open_description sub o; sub.class_type sub e
+
+  let iter_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
+    =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pctf_inherit ct -> sub.class_type sub ct
+    | Pctf_val (_s, _m, _v, t) -> sub.typ sub t
+    | Pctf_method (_s, _p, _v, t) -> sub.typ sub t
+    | Pctf_constraint (t1, t2) ->
+        sub.typ sub t1; sub.typ sub t2
+    | Pctf_attribute x -> sub.attribute sub x
+    | Pctf_extension x -> sub.extension sub x
+
+  let iter_signature sub {pcsig_self; pcsig_fields} =
+    sub.typ sub pcsig_self;
+    List.iter (sub.class_type_field sub) pcsig_fields
+end
+
+let iter_functor_param sub = function
+  | Unit -> ()
+  | Named (name, mty) ->
+    iter_loc sub name;
+    sub.module_type sub mty
+
+module MT = struct
+  (* Type expressions for the module language *)
+
+  let iter sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pmty_ident s -> iter_loc sub s
+    | Pmty_alias s -> iter_loc sub s
+    | Pmty_signature sg -> sub.signature sub sg
+    | Pmty_functor (param, mt2) ->
+        iter_functor_param sub param;
+        sub.module_type sub mt2
+    | Pmty_with (mt, l) ->
+        sub.module_type sub mt;
+        List.iter (sub.with_constraint sub) l
+    | Pmty_typeof me -> sub.module_expr sub me
+    | Pmty_extension x -> sub.extension sub x
+
+  let iter_with_constraint sub = function
+    | Pwith_type (lid, d) ->
+        iter_loc sub lid; sub.type_declaration sub d
+    | Pwith_module (lid, lid2) ->
+        iter_loc sub lid; iter_loc sub lid2
+    | Pwith_typesubst (lid, d) ->
+        iter_loc sub lid; sub.type_declaration sub d
+    | Pwith_modsubst (s, lid) ->
+        iter_loc sub s; iter_loc sub lid
+
+  let iter_signature_item sub {psig_desc = desc; psig_loc = loc} =
+    sub.location sub loc;
+    match desc with
+    | Psig_value vd -> sub.value_description sub vd
+    | Psig_type (_, l)
+    | Psig_typesubst l ->
+      List.iter (sub.type_declaration sub) l
+    | Psig_typext te -> sub.type_extension sub te
+    | Psig_exception ed -> sub.type_exception sub ed
+    | Psig_module x -> sub.module_declaration sub x
+    | Psig_modsubst x -> sub.module_substitution sub x
+    | Psig_recmodule l ->
+        List.iter (sub.module_declaration sub) l
+    | Psig_modtype x -> sub.module_type_declaration sub x
+    | Psig_open x -> sub.open_description sub x
+    | Psig_include x -> sub.include_description sub x
+    | Psig_class l -> List.iter (sub.class_description sub) l
+    | Psig_class_type l ->
+        List.iter (sub.class_type_declaration sub) l
+    | Psig_extension (x, attrs) ->
+        sub.attributes sub attrs;
+        sub.extension sub x
+    | Psig_attribute x -> sub.attribute sub x
+end
+
+
+module M = struct
+  (* Value expressions for the module language *)
+
+  let iter sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pmod_ident x -> iter_loc sub x
+    | Pmod_structure str -> sub.structure sub str
+    | Pmod_functor (param, body) ->
+        iter_functor_param sub param;
+        sub.module_expr sub body
+    | Pmod_apply (m1, m2) ->
+        sub.module_expr sub m1; sub.module_expr sub m2
+    | Pmod_constraint (m, mty) ->
+        sub.module_expr sub m; sub.module_type sub mty
+    | Pmod_unpack e -> sub.expr sub e
+    | Pmod_extension x -> sub.extension sub x
+
+  let iter_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
+    sub.location sub loc;
+    match desc with
+    | Pstr_eval (x, attrs) ->
+        sub.attributes sub attrs; sub.expr sub x
+    | Pstr_value (_r, vbs) -> List.iter (sub.value_binding sub) vbs
+    | Pstr_primitive vd -> sub.value_description sub vd
+    | Pstr_type (_rf, l) -> List.iter (sub.type_declaration sub) l
+    | Pstr_typext te -> sub.type_extension sub te
+    | Pstr_exception ed -> sub.type_exception sub ed
+    | Pstr_module x -> sub.module_binding sub x
+    | Pstr_recmodule l -> List.iter (sub.module_binding sub) l
+    | Pstr_modtype x -> sub.module_type_declaration sub x
+    | Pstr_open x -> sub.open_declaration sub x
+    | Pstr_class l -> List.iter (sub.class_declaration sub) l
+    | Pstr_class_type l ->
+        List.iter (sub.class_type_declaration sub) l
+    | Pstr_include x -> sub.include_declaration sub x
+    | Pstr_extension (x, attrs) ->
+        sub.attributes sub attrs; sub.extension sub x
+    | Pstr_attribute x -> sub.attribute sub x
+end
+
+module E = struct
+  (* Value expressions for the core language *)
+
+  let iter sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pexp_ident x -> iter_loc sub x
+    | Pexp_constant _ -> ()
+    | Pexp_let (_r, vbs, e) ->
+        List.iter (sub.value_binding sub) vbs;
+        sub.expr sub e
+    | Pexp_fun (_lab, def, p, e) ->
+        iter_opt (sub.expr sub) def;
+        sub.pat sub p;
+        sub.expr sub e
+    | Pexp_function pel -> sub.cases sub pel
+    | Pexp_apply (e, l) ->
+        sub.expr sub e; List.iter (iter_snd (sub.expr sub)) l
+    | Pexp_match (e, pel) ->
+        sub.expr sub e; sub.cases sub pel
+    | Pexp_try (e, pel) -> sub.expr sub e; sub.cases sub pel
+    | Pexp_tuple el -> List.iter (sub.expr sub) el
+    | Pexp_construct (lid, arg) ->
+        iter_loc sub lid; iter_opt (sub.expr sub) arg
+    | Pexp_variant (_lab, eo) ->
+        iter_opt (sub.expr sub) eo
+    | Pexp_record (l, eo) ->
+        List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) l;
+        iter_opt (sub.expr sub) eo
+    | Pexp_field (e, lid) ->
+        sub.expr sub e; iter_loc sub lid
+    | Pexp_setfield (e1, lid, e2) ->
+        sub.expr sub e1; iter_loc sub lid;
+        sub.expr sub e2
+    | Pexp_array el -> List.iter (sub.expr sub) el
+    | Pexp_ifthenelse (e1, e2, e3) ->
+        sub.expr sub e1; sub.expr sub e2;
+        iter_opt (sub.expr sub) e3
+    | Pexp_sequence (e1, e2) ->
+        sub.expr sub e1; sub.expr sub e2
+    | Pexp_while (e1, e2) ->
+        sub.expr sub e1; sub.expr sub e2
+    | Pexp_for (p, e1, e2, _d, e3) ->
+        sub.pat sub p; sub.expr sub e1; sub.expr sub e2;
+        sub.expr sub e3
+    | Pexp_coerce (e, t1, t2) ->
+        sub.expr sub e; iter_opt (sub.typ sub) t1;
+        sub.typ sub t2
+    | Pexp_constraint (e, t) ->
+        sub.expr sub e; sub.typ sub t
+    | Pexp_send (e, _s) -> sub.expr sub e
+    | Pexp_new lid -> iter_loc sub lid
+    | Pexp_setinstvar (s, e) ->
+        iter_loc sub s; sub.expr sub e
+    | Pexp_override sel ->
+        List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) sel
+    | Pexp_letmodule (s, me, e) ->
+        iter_loc sub s; sub.module_expr sub me;
+        sub.expr sub e
+    | Pexp_letexception (cd, e) ->
+        sub.extension_constructor sub cd;
+        sub.expr sub e
+    | Pexp_assert e -> sub.expr sub e
+    | Pexp_lazy e -> sub.expr sub e
+    | Pexp_poly (e, t) ->
+        sub.expr sub e; iter_opt (sub.typ sub) t
+    | Pexp_object cls -> sub.class_structure sub cls
+    | Pexp_newtype (_s, e) -> sub.expr sub e
+    | Pexp_pack me -> sub.module_expr sub me
+    | Pexp_open (o, e) ->
+        sub.open_declaration sub o; sub.expr sub e
+    | Pexp_letop {let_; ands; body} ->
+        sub.binding_op sub let_;
+        List.iter (sub.binding_op sub) ands;
+        sub.expr sub body
+    | Pexp_extension x -> sub.extension sub x
+    | Pexp_unreachable -> ()
+
+  let iter_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} =
+    iter_loc sub pbop_op;
+    sub.pat sub pbop_pat;
+    sub.expr sub pbop_exp;
+    sub.location sub pbop_loc
+
+end
+
+module P = struct
+  (* Patterns *)
+
+  let iter sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Ppat_any -> ()
+    | Ppat_var s -> iter_loc sub s
+    | Ppat_alias (p, s) -> sub.pat sub p; iter_loc sub s
+    | Ppat_constant _ -> ()
+    | Ppat_interval _ -> ()
+    | Ppat_tuple pl -> List.iter (sub.pat sub) pl
+    | Ppat_construct (l, p) ->
+        iter_loc sub l; iter_opt (sub.pat sub) p
+    | Ppat_variant (_l, p) -> iter_opt (sub.pat sub) p
+    | Ppat_record (lpl, _cf) ->
+        List.iter (iter_tuple (iter_loc sub) (sub.pat sub)) lpl
+    | Ppat_array pl -> List.iter (sub.pat sub) pl
+    | Ppat_or (p1, p2) -> sub.pat sub p1; sub.pat sub p2
+    | Ppat_constraint (p, t) ->
+        sub.pat sub p; sub.typ sub t
+    | Ppat_type s -> iter_loc sub s
+    | Ppat_lazy p -> sub.pat sub p
+    | Ppat_unpack s -> iter_loc sub s
+    | Ppat_exception p -> sub.pat sub p
+    | Ppat_extension x -> sub.extension sub x
+    | Ppat_open (lid, p) ->
+        iter_loc sub lid; sub.pat sub p
+
+end
+
+module CE = struct
+  (* Value expressions for the class language *)
+
+  let iter sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pcl_constr (lid, tys) ->
+        iter_loc sub lid; List.iter (sub.typ sub) tys
+    | Pcl_structure s ->
+        sub.class_structure sub s
+    | Pcl_fun (_lab, e, p, ce) ->
+        iter_opt (sub.expr sub) e;
+        sub.pat sub p;
+        sub.class_expr sub ce
+    | Pcl_apply (ce, l) ->
+        sub.class_expr sub ce;
+        List.iter (iter_snd (sub.expr sub)) l
+    | Pcl_let (_r, vbs, ce) ->
+        List.iter (sub.value_binding sub) vbs;
+        sub.class_expr sub ce
+    | Pcl_constraint (ce, ct) ->
+        sub.class_expr sub ce; sub.class_type sub ct
+    | Pcl_extension x -> sub.extension sub x
+    | Pcl_open (o, e) ->
+        sub.open_description sub o; sub.class_expr sub e
+
+  let iter_kind sub = function
+    | Cfk_concrete (_o, e) -> sub.expr sub e
+    | Cfk_virtual t -> sub.typ sub t
+
+  let iter_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pcf_inherit (_o, ce, _s) -> sub.class_expr sub ce
+    | Pcf_val (s, _m, k) -> iter_loc sub s; iter_kind sub k
+    | Pcf_method (s, _p, k) ->
+        iter_loc sub s; iter_kind sub k
+    | Pcf_constraint (t1, t2) ->
+        sub.typ sub t1; sub.typ sub t2
+    | Pcf_initializer e -> sub.expr sub e
+    | Pcf_attribute x -> sub.attribute sub x
+    | Pcf_extension x -> sub.extension sub x
+
+  let iter_structure sub {pcstr_self; pcstr_fields} =
+    sub.pat sub pcstr_self;
+    List.iter (sub.class_field sub) pcstr_fields
+
+  let class_infos sub f {pci_virt = _; pci_params = pl; pci_name; pci_expr;
+                         pci_loc; pci_attributes} =
+    List.iter (iter_fst (sub.typ sub)) pl;
+    iter_loc sub pci_name;
+    f pci_expr;
+    sub.location sub pci_loc;
+    sub.attributes sub pci_attributes
+end
+
+(* Now, a generic AST mapper, to be extended to cover all kinds and
+   cases of the OCaml grammar.  The default behavior of the mapper is
+   the identity. *)
+
+let default_iterator =
+  {
+    structure = (fun this l -> List.iter (this.structure_item this) l);
+    structure_item = M.iter_structure_item;
+    module_expr = M.iter;
+    signature = (fun this l -> List.iter (this.signature_item this) l);
+    signature_item = MT.iter_signature_item;
+    module_type = MT.iter;
+    with_constraint = MT.iter_with_constraint;
+    class_declaration =
+      (fun this -> CE.class_infos this (this.class_expr this));
+    class_expr = CE.iter;
+    class_field = CE.iter_field;
+    class_structure = CE.iter_structure;
+    class_type = CT.iter;
+    class_type_field = CT.iter_field;
+    class_signature = CT.iter_signature;
+    class_type_declaration =
+      (fun this -> CE.class_infos this (this.class_type this));
+    class_description =
+      (fun this -> CE.class_infos this (this.class_type this));
+    type_declaration = T.iter_type_declaration;
+    type_kind = T.iter_type_kind;
+    typ = T.iter;
+    row_field = T.row_field;
+    object_field = T.object_field;
+    type_extension = T.iter_type_extension;
+    type_exception = T.iter_type_exception;
+    extension_constructor = T.iter_extension_constructor;
+    value_description =
+      (fun this {pval_name; pval_type; pval_prim = _; pval_loc;
+                 pval_attributes} ->
+        iter_loc this pval_name;
+        this.typ this pval_type;
+        this.location this pval_loc;
+        this.attributes this pval_attributes;
+      );
+
+    pat = P.iter;
+    expr = E.iter;
+    binding_op = E.iter_binding_op;
+
+    module_declaration =
+      (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} ->
+         iter_loc this pmd_name;
+         this.module_type this pmd_type;
+         this.location this pmd_loc;
+         this.attributes this pmd_attributes;
+      );
+
+    module_substitution =
+      (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} ->
+         iter_loc this pms_name;
+         iter_loc this pms_manifest;
+         this.location this pms_loc;
+         this.attributes this pms_attributes;
+      );
+
+    module_type_declaration =
+      (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} ->
+         iter_loc this pmtd_name;
+         iter_opt (this.module_type this) pmtd_type;
+         this.location this pmtd_loc;
+         this.attributes this pmtd_attributes;
+      );
+
+    module_binding =
+      (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} ->
+         iter_loc this pmb_name; this.module_expr this pmb_expr;
+         this.location this pmb_loc;
+         this.attributes this pmb_attributes;
+      );
+
+    open_declaration =
+      (fun this {popen_expr; popen_override = _; popen_attributes; popen_loc} ->
+         this.module_expr this popen_expr;
+         this.location this popen_loc;
+         this.attributes this popen_attributes
+      );
+
+    open_description =
+      (fun this {popen_expr; popen_override = _; popen_attributes; popen_loc} ->
+         iter_loc this popen_expr;
+         this.location this popen_loc;
+         this.attributes this popen_attributes
+      );
+
+
+    include_description =
+      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+         this.module_type this pincl_mod;
+         this.location this pincl_loc;
+         this.attributes this pincl_attributes
+      );
+
+    include_declaration =
+      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+         this.module_expr this pincl_mod;
+         this.location this pincl_loc;
+         this.attributes this pincl_attributes
+      );
+
+
+    value_binding =
+      (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} ->
+         this.pat this pvb_pat;
+         this.expr this pvb_expr;
+         this.location this pvb_loc;
+         this.attributes this pvb_attributes
+      );
+
+
+    constructor_declaration =
+      (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} ->
+         iter_loc this pcd_name;
+         T.iter_constructor_arguments this pcd_args;
+         iter_opt (this.typ this) pcd_res;
+         this.location this pcd_loc;
+         this.attributes this pcd_attributes
+      );
+
+    label_declaration =
+      (fun this {pld_name; pld_type; pld_loc; pld_mutable = _; pld_attributes}->
+         iter_loc this pld_name;
+         this.typ this pld_type;
+         this.location this pld_loc;
+         this.attributes this pld_attributes
+      );
+
+    cases = (fun this l -> List.iter (this.case this) l);
+    case =
+      (fun this {pc_lhs; pc_guard; pc_rhs} ->
+         this.pat this pc_lhs;
+         iter_opt (this.expr this) pc_guard;
+         this.expr this pc_rhs
+      );
+
+    location = (fun _this _l -> ());
+
+    extension = (fun this (s, e) -> iter_loc this s; this.payload this e);
+    attribute = (fun this a ->
+      iter_loc this a.attr_name;
+      this.payload this a.attr_payload;
+      this.location this a.attr_loc
+    );
+    attributes = (fun this l -> List.iter (this.attribute this) l);
+    payload =
+      (fun this -> function
+         | PStr x -> this.structure this x
+         | PSig x -> this.signature this x
+         | PTyp x -> this.typ this x
+         | PPat (x, g) -> this.pat this x; iter_opt (this.expr this) g
+      );
+  }
diff --git a/upstream/ocaml_412/parsing/ast_iterator.mli b/upstream/ocaml_412/parsing/ast_iterator.mli
new file mode 100644
index 0000000..26308d2
--- /dev/null
+++ b/upstream/ocaml_412/parsing/ast_iterator.mli
@@ -0,0 +1,83 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Nicolas Ojeda Bar, LexiFi                         *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** {!iterator} enables AST inspection using open recursion.  A
+    typical mapper would be based on {!default_iterator}, a trivial iterator,
+    and will fall back on it for handling the syntax it does not modify.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Parsetree
+
+(** {1 A generic Parsetree iterator} *)
+
+type iterator = {
+  attribute: iterator -> attribute -> unit;
+  attributes: iterator -> attribute list -> unit;
+  binding_op: iterator -> binding_op -> unit;
+  case: iterator -> case -> unit;
+  cases: iterator -> case list -> unit;
+  class_declaration: iterator -> class_declaration -> unit;
+  class_description: iterator -> class_description -> unit;
+  class_expr: iterator -> class_expr -> unit;
+  class_field: iterator -> class_field -> unit;
+  class_signature: iterator -> class_signature -> unit;
+  class_structure: iterator -> class_structure -> unit;
+  class_type: iterator -> class_type -> unit;
+  class_type_declaration: iterator -> class_type_declaration -> unit;
+  class_type_field: iterator -> class_type_field -> unit;
+  constructor_declaration: iterator -> constructor_declaration -> unit;
+  expr: iterator -> expression -> unit;
+  extension: iterator -> extension -> unit;
+  extension_constructor: iterator -> extension_constructor -> unit;
+  include_declaration: iterator -> include_declaration -> unit;
+  include_description: iterator -> include_description -> unit;
+  label_declaration: iterator -> label_declaration -> unit;
+  location: iterator -> Location.t -> unit;
+  module_binding: iterator -> module_binding -> unit;
+  module_declaration: iterator -> module_declaration -> unit;
+  module_substitution: iterator -> module_substitution -> unit;
+  module_expr: iterator -> module_expr -> unit;
+  module_type: iterator -> module_type -> unit;
+  module_type_declaration: iterator -> module_type_declaration -> unit;
+  open_declaration: iterator -> open_declaration -> unit;
+  open_description: iterator -> open_description -> unit;
+  pat: iterator -> pattern -> unit;
+  payload: iterator -> payload -> unit;
+  signature: iterator -> signature -> unit;
+  signature_item: iterator -> signature_item -> unit;
+  structure: iterator -> structure -> unit;
+  structure_item: iterator -> structure_item -> unit;
+  typ: iterator -> core_type -> unit;
+  row_field: iterator -> row_field -> unit;
+  object_field: iterator -> object_field -> unit;
+  type_declaration: iterator -> type_declaration -> unit;
+  type_extension: iterator -> type_extension -> unit;
+  type_exception: iterator -> type_exception -> unit;
+  type_kind: iterator -> type_kind -> unit;
+  value_binding: iterator -> value_binding -> unit;
+  value_description: iterator -> value_description -> unit;
+  with_constraint: iterator -> with_constraint -> unit;
+}
+(** A [iterator] record implements one "method" per syntactic category,
+    using an open recursion style: each method takes as its first
+    argument the iterator to be applied to children in the syntax
+    tree. *)
+
+val default_iterator: iterator
+(** A default iterator, which implements a "do not do anything" mapping. *)
diff --git a/upstream/ocaml_412/parsing/ast_mapper.ml b/upstream/ocaml_412/parsing/ast_mapper.ml
new file mode 100644
index 0000000..dadf5ea
--- /dev/null
+++ b/upstream/ocaml_412/parsing/ast_mapper.ml
@@ -0,0 +1,1068 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* A generic Parsetree mapping class *)
+
+(*
+[@@@ocaml.warning "+9"]
+  (* Ensure that record patterns don't miss any field. *)
+*)
+
+open Parsetree
+open Ast_helper
+open Location
+
+module String = Misc.Stdlib.String
+
+type mapper = {
+  attribute: mapper -> attribute -> attribute;
+  attributes: mapper -> attribute list -> attribute list;
+  binding_op: mapper -> binding_op -> binding_op;
+  case: mapper -> case -> case;
+  cases: mapper -> case list -> case list;
+  class_declaration: mapper -> class_declaration -> class_declaration;
+  class_description: mapper -> class_description -> class_description;
+  class_expr: mapper -> class_expr -> class_expr;
+  class_field: mapper -> class_field -> class_field;
+  class_signature: mapper -> class_signature -> class_signature;
+  class_structure: mapper -> class_structure -> class_structure;
+  class_type: mapper -> class_type -> class_type;
+  class_type_declaration: mapper -> class_type_declaration
+                          -> class_type_declaration;
+  class_type_field: mapper -> class_type_field -> class_type_field;
+  constant: mapper -> constant -> constant;
+  constructor_declaration: mapper -> constructor_declaration
+                           -> constructor_declaration;
+  expr: mapper -> expression -> expression;
+  extension: mapper -> extension -> extension;
+  extension_constructor: mapper -> extension_constructor
+                         -> extension_constructor;
+  include_declaration: mapper -> include_declaration -> include_declaration;
+  include_description: mapper -> include_description -> include_description;
+  label_declaration: mapper -> label_declaration -> label_declaration;
+  location: mapper -> Location.t -> Location.t;
+  module_binding: mapper -> module_binding -> module_binding;
+  module_declaration: mapper -> module_declaration -> module_declaration;
+  module_substitution: mapper -> module_substitution -> module_substitution;
+  module_expr: mapper -> module_expr -> module_expr;
+  module_type: mapper -> module_type -> module_type;
+  module_type_declaration: mapper -> module_type_declaration
+                           -> module_type_declaration;
+  open_declaration: mapper -> open_declaration -> open_declaration;
+  open_description: mapper -> open_description -> open_description;
+  pat: mapper -> pattern -> pattern;
+  payload: mapper -> payload -> payload;
+  signature: mapper -> signature -> signature;
+  signature_item: mapper -> signature_item -> signature_item;
+  structure: mapper -> structure -> structure;
+  structure_item: mapper -> structure_item -> structure_item;
+  typ: mapper -> core_type -> core_type;
+  type_declaration: mapper -> type_declaration -> type_declaration;
+  type_extension: mapper -> type_extension -> type_extension;
+  type_exception: mapper -> type_exception -> type_exception;
+  type_kind: mapper -> type_kind -> type_kind;
+  value_binding: mapper -> value_binding -> value_binding;
+  value_description: mapper -> value_description -> value_description;
+  with_constraint: mapper -> with_constraint -> with_constraint;
+}
+
+let map_fst f (x, y) = (f x, y)
+let map_snd f (x, y) = (x, f y)
+let map_tuple f1 f2 (x, y) = (f1 x, f2 y)
+let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
+let map_opt f = function None -> None | Some x -> Some (f x)
+
+let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}
+
+module C = struct
+  (* Constants *)
+
+  let map sub c = match c with
+    | Pconst_integer _
+    | Pconst_char _
+    | Pconst_float _
+      -> c
+    | Pconst_string (s, loc, quotation_delimiter) ->
+        let loc = sub.location sub loc in
+        Const.string ~loc ?quotation_delimiter s
+end
+
+module T = struct
+  (* Type expressions for the core language *)
+
+  let row_field sub {
+      prf_desc;
+      prf_loc;
+      prf_attributes;
+    } =
+    let loc = sub.location sub prf_loc in
+    let attrs = sub.attributes sub prf_attributes in
+    let desc = match prf_desc with
+      | Rtag (l, b, tl) -> Rtag (map_loc sub l, b, List.map (sub.typ sub) tl)
+      | Rinherit t -> Rinherit (sub.typ sub t)
+    in
+    Rf.mk ~loc ~attrs desc
+
+  let object_field sub {
+      pof_desc;
+      pof_loc;
+      pof_attributes;
+    } =
+    let loc = sub.location sub pof_loc in
+    let attrs = sub.attributes sub pof_attributes in
+    let desc = match pof_desc with
+      | Otag (l, t) -> Otag (map_loc sub l, sub.typ sub t)
+      | Oinherit t -> Oinherit (sub.typ sub t)
+    in
+    Of.mk ~loc ~attrs desc
+
+  let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
+    let open Typ in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Ptyp_any -> any ~loc ~attrs ()
+    | Ptyp_var s -> var ~loc ~attrs s
+    | Ptyp_arrow (lab, t1, t2) ->
+        arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2)
+    | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
+    | Ptyp_constr (lid, tl) ->
+        constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
+    | Ptyp_object (l, o) ->
+        object_ ~loc ~attrs (List.map (object_field sub) l) o
+    | Ptyp_class (lid, tl) ->
+        class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
+    | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s
+    | Ptyp_variant (rl, b, ll) ->
+        variant ~loc ~attrs (List.map (row_field sub) rl) b ll
+    | Ptyp_poly (sl, t) -> poly ~loc ~attrs
+                             (List.map (map_loc sub) sl) (sub.typ sub t)
+    | Ptyp_package (lid, l) ->
+        package ~loc ~attrs (map_loc sub lid)
+          (List.map (map_tuple (map_loc sub) (sub.typ sub)) l)
+    | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_type_declaration sub
+      {ptype_name; ptype_params; ptype_cstrs;
+       ptype_kind;
+       ptype_private;
+       ptype_manifest;
+       ptype_attributes;
+       ptype_loc} =
+    let loc = sub.location sub ptype_loc in
+    let attrs = sub.attributes sub ptype_attributes in
+    Type.mk ~loc ~attrs (map_loc sub ptype_name)
+      ~params:(List.map (map_fst (sub.typ sub)) ptype_params)
+      ~priv:ptype_private
+      ~cstrs:(List.map
+                (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub))
+                ptype_cstrs)
+      ~kind:(sub.type_kind sub ptype_kind)
+      ?manifest:(map_opt (sub.typ sub) ptype_manifest)
+
+  let map_type_kind sub = function
+    | Ptype_abstract -> Ptype_abstract
+    | Ptype_variant l ->
+        Ptype_variant (List.map (sub.constructor_declaration sub) l)
+    | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l)
+    | Ptype_open -> Ptype_open
+
+  let map_constructor_arguments sub = function
+    | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l)
+    | Pcstr_record l ->
+        Pcstr_record (List.map (sub.label_declaration sub) l)
+
+  let map_type_extension sub
+      {ptyext_path; ptyext_params;
+       ptyext_constructors;
+       ptyext_private;
+       ptyext_loc;
+       ptyext_attributes} =
+    let loc = sub.location sub ptyext_loc in
+    let attrs = sub.attributes sub ptyext_attributes in
+    Te.mk ~loc ~attrs
+      (map_loc sub ptyext_path)
+      (List.map (sub.extension_constructor sub) ptyext_constructors)
+      ~params:(List.map (map_fst (sub.typ sub)) ptyext_params)
+      ~priv:ptyext_private
+
+  let map_type_exception sub
+      {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} =
+    let loc = sub.location sub ptyexn_loc in
+    let attrs = sub.attributes sub ptyexn_attributes in
+    Te.mk_exception ~loc ~attrs
+      (sub.extension_constructor sub ptyexn_constructor)
+
+  let map_extension_constructor_kind sub = function
+      Pext_decl(ctl, cto) ->
+        Pext_decl(map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto)
+    | Pext_rebind li ->
+        Pext_rebind (map_loc sub li)
+
+  let map_extension_constructor sub
+      {pext_name;
+       pext_kind;
+       pext_loc;
+       pext_attributes} =
+    let loc = sub.location sub pext_loc in
+    let attrs = sub.attributes sub pext_attributes in
+    Te.constructor ~loc ~attrs
+      (map_loc sub pext_name)
+      (map_extension_constructor_kind sub pext_kind)
+
+end
+
+module CT = struct
+  (* Type expressions for the class language *)
+
+  let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} =
+    let open Cty in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pcty_constr (lid, tys) ->
+        constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
+    | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x)
+    | Pcty_arrow (lab, t, ct) ->
+        arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct)
+    | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x)
+    | Pcty_open (o, ct) ->
+        open_ ~loc ~attrs (sub.open_description sub o) (sub.class_type sub ct)
+
+  let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
+    =
+    let open Ctf in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct)
+    | Pctf_val (s, m, v, t) ->
+        val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t)
+    | Pctf_method (s, p, v, t) ->
+        method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t)
+    | Pctf_constraint (t1, t2) ->
+        constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
+    | Pctf_attribute x -> attribute ~loc (sub.attribute sub x)
+    | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_signature sub {pcsig_self; pcsig_fields} =
+    Csig.mk
+      (sub.typ sub pcsig_self)
+      (List.map (sub.class_type_field sub) pcsig_fields)
+end
+
+let map_functor_param sub = function
+  | Unit -> Unit
+  | Named (s, mt) -> Named (map_loc sub s, sub.module_type sub mt)
+
+module MT = struct
+  (* Type expressions for the module language *)
+
+  let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} =
+    let open Mty in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s)
+    | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s)
+    | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg)
+    | Pmty_functor (param, mt) ->
+        functor_ ~loc ~attrs
+          (map_functor_param sub param)
+          (sub.module_type sub mt)
+    | Pmty_with (mt, l) ->
+        with_ ~loc ~attrs (sub.module_type sub mt)
+          (List.map (sub.with_constraint sub) l)
+    | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me)
+    | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_with_constraint sub = function
+    | Pwith_type (lid, d) ->
+        Pwith_type (map_loc sub lid, sub.type_declaration sub d)
+    | Pwith_module (lid, lid2) ->
+        Pwith_module (map_loc sub lid, map_loc sub lid2)
+    | Pwith_typesubst (lid, d) ->
+        Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d)
+    | Pwith_modsubst (s, lid) ->
+        Pwith_modsubst (map_loc sub s, map_loc sub lid)
+
+  let map_signature_item sub {psig_desc = desc; psig_loc = loc} =
+    let open Sig in
+    let loc = sub.location sub loc in
+    match desc with
+    | Psig_value vd -> value ~loc (sub.value_description sub vd)
+    | Psig_type (rf, l) ->
+        type_ ~loc rf (List.map (sub.type_declaration sub) l)
+    | Psig_typesubst l ->
+        type_subst ~loc (List.map (sub.type_declaration sub) l)
+    | Psig_typext te -> type_extension ~loc (sub.type_extension sub te)
+    | Psig_exception ed -> exception_ ~loc (sub.type_exception sub ed)
+    | Psig_module x -> module_ ~loc (sub.module_declaration sub x)
+    | Psig_modsubst x -> mod_subst ~loc (sub.module_substitution sub x)
+    | Psig_recmodule l ->
+        rec_module ~loc (List.map (sub.module_declaration sub) l)
+    | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
+    | Psig_open x -> open_ ~loc (sub.open_description sub x)
+    | Psig_include x -> include_ ~loc (sub.include_description sub x)
+    | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l)
+    | Psig_class_type l ->
+        class_type ~loc (List.map (sub.class_type_declaration sub) l)
+    | Psig_extension (x, attrs) ->
+        let attrs = sub.attributes sub attrs in
+        extension ~loc ~attrs (sub.extension sub x)
+    | Psig_attribute x -> attribute ~loc (sub.attribute sub x)
+end
+
+
+module M = struct
+  (* Value expressions for the module language *)
+
+  let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} =
+    let open Mod in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x)
+    | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str)
+    | Pmod_functor (param, body) ->
+        functor_ ~loc ~attrs
+          (map_functor_param sub param)
+          (sub.module_expr sub body)
+    | Pmod_apply (m1, m2) ->
+        apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2)
+    | Pmod_constraint (m, mty) ->
+        constraint_ ~loc ~attrs (sub.module_expr sub m)
+                    (sub.module_type sub mty)
+    | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e)
+    | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
+    let open Str in
+    let loc = sub.location sub loc in
+    match desc with
+    | Pstr_eval (x, attrs) ->
+        let attrs = sub.attributes sub attrs in
+        eval ~loc ~attrs (sub.expr sub x)
+    | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs)
+    | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd)
+    | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l)
+    | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te)
+    | Pstr_exception ed -> exception_ ~loc (sub.type_exception sub ed)
+    | Pstr_module x -> module_ ~loc (sub.module_binding sub x)
+    | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l)
+    | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
+    | Pstr_open x -> open_ ~loc (sub.open_declaration sub x)
+    | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l)
+    | Pstr_class_type l ->
+        class_type ~loc (List.map (sub.class_type_declaration sub) l)
+    | Pstr_include x -> include_ ~loc (sub.include_declaration sub x)
+    | Pstr_extension (x, attrs) ->
+        let attrs = sub.attributes sub attrs in
+        extension ~loc ~attrs (sub.extension sub x)
+    | Pstr_attribute x -> attribute ~loc (sub.attribute sub x)
+end
+
+module E = struct
+  (* Value expressions for the core language *)
+
+  let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} =
+    let open Exp in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x)
+    | Pexp_constant x -> constant ~loc ~attrs (sub.constant sub x)
+    | Pexp_let (r, vbs, e) ->
+        let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
+          (sub.expr sub e)
+    | Pexp_fun (lab, def, p, e) ->
+        fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p)
+          (sub.expr sub e)
+    | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel)
+    | Pexp_apply (e, l) ->
+        apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l)
+    | Pexp_match (e, pel) ->
+        match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
+    | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
+    | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el)
+    | Pexp_construct (lid, arg) ->
+        construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg)
+    | Pexp_variant (lab, eo) ->
+        variant ~loc ~attrs lab (map_opt (sub.expr sub) eo)
+    | Pexp_record (l, eo) ->
+        record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l)
+          (map_opt (sub.expr sub) eo)
+    | Pexp_field (e, lid) ->
+        field ~loc ~attrs (sub.expr sub e) (map_loc sub lid)
+    | Pexp_setfield (e1, lid, e2) ->
+        setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid)
+          (sub.expr sub e2)
+    | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el)
+    | Pexp_ifthenelse (e1, e2, e3) ->
+        ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
+          (map_opt (sub.expr sub) e3)
+    | Pexp_sequence (e1, e2) ->
+        sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
+    | Pexp_while (e1, e2) ->
+        while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
+    | Pexp_for (p, e1, e2, d, e3) ->
+        for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d
+          (sub.expr sub e3)
+    | Pexp_coerce (e, t1, t2) ->
+        coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1)
+          (sub.typ sub t2)
+    | Pexp_constraint (e, t) ->
+        constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t)
+    | Pexp_send (e, s) ->
+        send ~loc ~attrs (sub.expr sub e) (map_loc sub s)
+    | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid)
+    | Pexp_setinstvar (s, e) ->
+        setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e)
+    | Pexp_override sel ->
+        override ~loc ~attrs
+          (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel)
+    | Pexp_letmodule (s, me, e) ->
+        letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me)
+          (sub.expr sub e)
+    | Pexp_letexception (cd, e) ->
+        letexception ~loc ~attrs
+          (sub.extension_constructor sub cd)
+          (sub.expr sub e)
+    | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e)
+    | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e)
+    | Pexp_poly (e, t) ->
+        poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t)
+    | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls)
+    | Pexp_newtype (s, e) ->
+        newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e)
+    | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me)
+    | Pexp_open (o, e) ->
+        open_ ~loc ~attrs (sub.open_declaration sub o) (sub.expr sub e)
+    | Pexp_letop {let_; ands; body} ->
+        letop ~loc ~attrs (sub.binding_op sub let_)
+          (List.map (sub.binding_op sub) ands) (sub.expr sub body)
+    | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x)
+    | Pexp_unreachable -> unreachable ~loc ~attrs ()
+
+  let map_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} =
+    let open Exp in
+    let op = map_loc sub pbop_op in
+    let pat = sub.pat sub pbop_pat in
+    let exp = sub.expr sub pbop_exp in
+    let loc = sub.location sub pbop_loc in
+    binding_op op pat exp loc
+
+end
+
+module P = struct
+  (* Patterns *)
+
+  let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} =
+    let open Pat in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Ppat_any -> any ~loc ~attrs ()
+    | Ppat_var s -> var ~loc ~attrs (map_loc sub s)
+    | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s)
+    | Ppat_constant c -> constant ~loc ~attrs (sub.constant sub c)
+    | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2
+    | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl)
+    | Ppat_construct (l, p) ->
+        construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p)
+    | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p)
+    | Ppat_record (lpl, cf) ->
+        record ~loc ~attrs
+               (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf
+    | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl)
+    | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2)
+    | Ppat_constraint (p, t) ->
+        constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t)
+    | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s)
+    | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p)
+    | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s)
+    | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p)
+    | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p)
+    | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x)
+end
+
+module CE = struct
+  (* Value expressions for the class language *)
+
+  let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} =
+    let open Cl in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pcl_constr (lid, tys) ->
+        constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
+    | Pcl_structure s ->
+        structure ~loc ~attrs (sub.class_structure sub s)
+    | Pcl_fun (lab, e, p, ce) ->
+        fun_ ~loc ~attrs lab
+          (map_opt (sub.expr sub) e)
+          (sub.pat sub p)
+          (sub.class_expr sub ce)
+    | Pcl_apply (ce, l) ->
+        apply ~loc ~attrs (sub.class_expr sub ce)
+          (List.map (map_snd (sub.expr sub)) l)
+    | Pcl_let (r, vbs, ce) ->
+        let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
+          (sub.class_expr sub ce)
+    | Pcl_constraint (ce, ct) ->
+        constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct)
+    | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x)
+    | Pcl_open (o, ce) ->
+        open_ ~loc ~attrs (sub.open_description sub o) (sub.class_expr sub ce)
+
+  let map_kind sub = function
+    | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e)
+    | Cfk_virtual t -> Cfk_virtual (sub.typ sub t)
+
+  let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} =
+    let open Cf in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pcf_inherit (o, ce, s) ->
+        inherit_ ~loc ~attrs o (sub.class_expr sub ce)
+          (map_opt (map_loc sub) s)
+    | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k)
+    | Pcf_method (s, p, k) ->
+        method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k)
+    | Pcf_constraint (t1, t2) ->
+        constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
+    | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e)
+    | Pcf_attribute x -> attribute ~loc (sub.attribute sub x)
+    | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_structure sub {pcstr_self; pcstr_fields} =
+    {
+      pcstr_self = sub.pat sub pcstr_self;
+      pcstr_fields = List.map (sub.class_field sub) pcstr_fields;
+    }
+
+  let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr;
+                         pci_loc; pci_attributes} =
+    let loc = sub.location sub pci_loc in
+    let attrs = sub.attributes sub pci_attributes in
+    Ci.mk ~loc ~attrs
+     ~virt:pci_virt
+     ~params:(List.map (map_fst (sub.typ sub)) pl)
+      (map_loc sub pci_name)
+      (f pci_expr)
+end
+
+(* Now, a generic AST mapper, to be extended to cover all kinds and
+   cases of the OCaml grammar.  The default behavior of the mapper is
+   the identity. *)
+
+let default_mapper =
+  {
+    constant = C.map;
+    structure = (fun this l -> List.map (this.structure_item this) l);
+    structure_item = M.map_structure_item;
+    module_expr = M.map;
+    signature = (fun this l -> List.map (this.signature_item this) l);
+    signature_item = MT.map_signature_item;
+    module_type = MT.map;
+    with_constraint = MT.map_with_constraint;
+    class_declaration =
+      (fun this -> CE.class_infos this (this.class_expr this));
+    class_expr = CE.map;
+    class_field = CE.map_field;
+    class_structure = CE.map_structure;
+    class_type = CT.map;
+    class_type_field = CT.map_field;
+    class_signature = CT.map_signature;
+    class_type_declaration =
+      (fun this -> CE.class_infos this (this.class_type this));
+    class_description =
+      (fun this -> CE.class_infos this (this.class_type this));
+    type_declaration = T.map_type_declaration;
+    type_kind = T.map_type_kind;
+    typ = T.map;
+    type_extension = T.map_type_extension;
+    type_exception = T.map_type_exception;
+    extension_constructor = T.map_extension_constructor;
+    value_description =
+      (fun this {pval_name; pval_type; pval_prim; pval_loc;
+                 pval_attributes} ->
+        Val.mk
+          (map_loc this pval_name)
+          (this.typ this pval_type)
+          ~attrs:(this.attributes this pval_attributes)
+          ~loc:(this.location this pval_loc)
+          ~prim:pval_prim
+      );
+
+    pat = P.map;
+    expr = E.map;
+    binding_op = E.map_binding_op;
+
+    module_declaration =
+      (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} ->
+         Md.mk
+           (map_loc this pmd_name)
+           (this.module_type this pmd_type)
+           ~attrs:(this.attributes this pmd_attributes)
+           ~loc:(this.location this pmd_loc)
+      );
+
+    module_substitution =
+      (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} ->
+         Ms.mk
+           (map_loc this pms_name)
+           (map_loc this pms_manifest)
+           ~attrs:(this.attributes this pms_attributes)
+           ~loc:(this.location this pms_loc)
+      );
+
+    module_type_declaration =
+      (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} ->
+         Mtd.mk
+           (map_loc this pmtd_name)
+           ?typ:(map_opt (this.module_type this) pmtd_type)
+           ~attrs:(this.attributes this pmtd_attributes)
+           ~loc:(this.location this pmtd_loc)
+      );
+
+    module_binding =
+      (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} ->
+         Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr)
+           ~attrs:(this.attributes this pmb_attributes)
+           ~loc:(this.location this pmb_loc)
+      );
+
+
+    open_declaration =
+      (fun this {popen_expr; popen_override; popen_attributes; popen_loc} ->
+         Opn.mk (this.module_expr this popen_expr)
+           ~override:popen_override
+           ~loc:(this.location this popen_loc)
+           ~attrs:(this.attributes this popen_attributes)
+      );
+
+    open_description =
+      (fun this {popen_expr; popen_override; popen_attributes; popen_loc} ->
+         Opn.mk (map_loc this popen_expr)
+           ~override:popen_override
+           ~loc:(this.location this popen_loc)
+           ~attrs:(this.attributes this popen_attributes)
+      );
+
+    include_description =
+      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+         Incl.mk (this.module_type this pincl_mod)
+           ~loc:(this.location this pincl_loc)
+           ~attrs:(this.attributes this pincl_attributes)
+      );
+
+    include_declaration =
+      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+         Incl.mk (this.module_expr this pincl_mod)
+           ~loc:(this.location this pincl_loc)
+           ~attrs:(this.attributes this pincl_attributes)
+      );
+
+
+    value_binding =
+      (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} ->
+         Vb.mk
+           (this.pat this pvb_pat)
+           (this.expr this pvb_expr)
+           ~loc:(this.location this pvb_loc)
+           ~attrs:(this.attributes this pvb_attributes)
+      );
+
+
+    constructor_declaration =
+      (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} ->
+        Type.constructor
+          (map_loc this pcd_name)
+          ~args:(T.map_constructor_arguments this pcd_args)
+          ?res:(map_opt (this.typ this) pcd_res)
+          ~loc:(this.location this pcd_loc)
+          ~attrs:(this.attributes this pcd_attributes)
+      );
+
+    label_declaration =
+      (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} ->
+         Type.field
+           (map_loc this pld_name)
+           (this.typ this pld_type)
+           ~mut:pld_mutable
+           ~loc:(this.location this pld_loc)
+           ~attrs:(this.attributes this pld_attributes)
+      );
+
+    cases = (fun this l -> List.map (this.case this) l);
+    case =
+      (fun this {pc_lhs; pc_guard; pc_rhs} ->
+         {
+           pc_lhs = this.pat this pc_lhs;
+           pc_guard = map_opt (this.expr this) pc_guard;
+           pc_rhs = this.expr this pc_rhs;
+         }
+      );
+
+
+
+    location = (fun _this l -> l);
+
+    extension = (fun this (s, e) -> (map_loc this s, this.payload this e));
+    attribute = (fun this a ->
+      {
+        attr_name = map_loc this a.attr_name;
+        attr_payload = this.payload this a.attr_payload;
+        attr_loc = this.location this a.attr_loc
+      }
+    );
+    attributes = (fun this l -> List.map (this.attribute this) l);
+    payload =
+      (fun this -> function
+         | PStr x -> PStr (this.structure this x)
+         | PSig x -> PSig (this.signature this x)
+         | PTyp x -> PTyp (this.typ this x)
+         | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g)
+      );
+  }
+
+let extension_of_error {kind; main; sub} =
+  if kind <> Location.Report_error then
+    raise (Invalid_argument "extension_of_error: expected kind Report_error");
+  let str_of_pp pp_msg = Format.asprintf "%t" pp_msg in
+  let extension_of_sub sub =
+    { loc = sub.loc; txt = "ocaml.error" },
+    PStr ([Str.eval (Exp.constant
+                       (Pconst_string (str_of_pp sub.txt, sub.loc, None)))])
+  in
+  { loc = main.loc; txt = "ocaml.error" },
+  PStr (Str.eval (Exp.constant
+                    (Pconst_string (str_of_pp main.txt, main.loc, None))) ::
+        List.map (fun msg -> Str.extension (extension_of_sub msg)) sub)
+
+let attribute_of_warning loc s =
+  Attr.mk
+    {loc; txt = "ocaml.ppwarning" }
+    (PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, loc, None)))]))
+
+let cookies = ref String.Map.empty
+
+let get_cookie k =
+  try Some (String.Map.find k !cookies)
+  with Not_found -> None
+
+let set_cookie k v =
+  cookies := String.Map.add k v !cookies
+
+let tool_name_ref = ref "_none_"
+
+let tool_name () = !tool_name_ref
+
+
+module PpxContext = struct
+  open Longident
+  open Asttypes
+  open Ast_helper
+
+  let lid name = { txt = Lident name; loc = Location.none }
+
+  let make_string s = Exp.constant (Const.string s)
+
+  let make_bool x =
+    if x
+    then Exp.construct (lid "true") None
+    else Exp.construct (lid "false") None
+
+  let rec make_list f lst =
+    match lst with
+    | x :: rest ->
+      Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest]))
+    | [] ->
+      Exp.construct (lid "[]") None
+
+  let make_pair f1 f2 (x1, x2) =
+    Exp.tuple [f1 x1; f2 x2]
+
+  let make_option f opt =
+    match opt with
+    | Some x -> Exp.construct (lid "Some") (Some (f x))
+    | None   -> Exp.construct (lid "None") None
+
+  let get_cookies () =
+    lid "cookies",
+    make_list (make_pair make_string (fun x -> x))
+      (String.Map.bindings !cookies)
+
+  let mk fields =
+    {
+      attr_name = { txt = "ocaml.ppx.context"; loc = Location.none };
+      attr_payload = Parsetree.PStr [Str.eval (Exp.record fields None)];
+      attr_loc = Location.none
+    }
+
+  let make ~tool_name () =
+    let fields =
+      [
+        lid "tool_name",    make_string tool_name;
+        lid "include_dirs", make_list make_string !Clflags.include_dirs;
+        lid "load_path",    make_list make_string (Load_path.get_paths ());
+        lid "open_modules", make_list make_string !Clflags.open_modules;
+        lid "for_package",  make_option make_string !Clflags.for_package;
+        lid "debug",        make_bool !Clflags.debug;
+        lid "use_threads",  make_bool !Clflags.use_threads;
+        lid "use_vmthreads", make_bool false;
+        lid "recursive_types", make_bool !Clflags.recursive_types;
+        lid "principal", make_bool !Clflags.principal;
+        lid "transparent_modules", make_bool !Clflags.transparent_modules;
+        lid "unboxed_types", make_bool !Clflags.unboxed_types;
+        lid "unsafe_string", make_bool !Clflags.unsafe_string;
+        get_cookies ()
+      ]
+    in
+    mk fields
+
+  let get_fields = function
+    | PStr [{pstr_desc = Pstr_eval
+                 ({ pexp_desc = Pexp_record (fields, None) }, [])}] ->
+        fields
+    | _ ->
+        raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax"
+
+  let restore fields =
+    let field name payload =
+      let rec get_string = function
+        | { pexp_desc = Pexp_constant (Pconst_string (str, _, None)) } -> str
+        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
+                             { %s }] string syntax" name
+      and get_bool pexp =
+        match pexp with
+        | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"},
+                                       None)} ->
+            true
+        | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"},
+                                       None)} ->
+            false
+        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
+                             { %s }] bool syntax" name
+      and get_list elem = function
+        | {pexp_desc =
+             Pexp_construct ({txt = Longident.Lident "::"},
+                             Some {pexp_desc = Pexp_tuple [exp; rest]}) } ->
+            elem exp :: get_list elem rest
+        | {pexp_desc =
+             Pexp_construct ({txt = Longident.Lident "[]"}, None)} ->
+            []
+        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
+                             { %s }] list syntax" name
+      and get_pair f1 f2 = function
+        | {pexp_desc = Pexp_tuple [e1; e2]} ->
+            (f1 e1, f2 e2)
+        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
+                             { %s }] pair syntax" name
+      and get_option elem = function
+        | { pexp_desc =
+              Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } ->
+            Some (elem exp)
+        | { pexp_desc =
+              Pexp_construct ({ txt = Longident.Lident "None" }, None) } ->
+            None
+        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
+                             { %s }] option syntax" name
+      in
+      match name with
+      | "tool_name" ->
+          tool_name_ref := get_string payload
+      | "include_dirs" ->
+          Clflags.include_dirs := get_list get_string payload
+      | "load_path" ->
+          Load_path.init (get_list get_string payload)
+      | "open_modules" ->
+          Clflags.open_modules := get_list get_string payload
+      | "for_package" ->
+          Clflags.for_package := get_option get_string payload
+      | "debug" ->
+          Clflags.debug := get_bool payload
+      | "use_threads" ->
+          Clflags.use_threads := get_bool payload
+      | "use_vmthreads" ->
+          if get_bool payload then
+            raise_errorf "Internal error: vmthreads not supported after 4.09.0"
+      | "recursive_types" ->
+          Clflags.recursive_types := get_bool payload
+      | "principal" ->
+          Clflags.principal := get_bool payload
+      | "transparent_modules" ->
+          Clflags.transparent_modules := get_bool payload
+      | "unboxed_types" ->
+          Clflags.unboxed_types := get_bool payload
+      | "unsafe_string" ->
+          Clflags.unsafe_string := get_bool payload
+      | "cookies" ->
+          let l = get_list (get_pair get_string (fun x -> x)) payload in
+          cookies :=
+            List.fold_left
+              (fun s (k, v) -> String.Map.add k v s) String.Map.empty
+              l
+      | _ ->
+          ()
+    in
+    List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields
+
+  let update_cookies fields =
+    let fields =
+      List.filter
+        (function ({txt=Lident "cookies"}, _) -> false | _ -> true)
+        fields
+    in
+    fields @ [get_cookies ()]
+end
+
+let ppx_context = PpxContext.make
+
+let extension_of_exn exn =
+  match error_of_exn exn with
+  | Some (`Ok error) -> extension_of_error error
+  | Some `Already_displayed ->
+      { loc = Location.none; txt = "ocaml.error" }, PStr []
+  | None -> raise exn
+
+
+let apply_lazy ~source ~target mapper =
+  let implem ast =
+    let fields, ast =
+      match ast with
+      | {pstr_desc = Pstr_attribute ({attr_name = {txt = "ocaml.ppx.context"};
+                                      attr_payload = x})} :: l ->
+          PpxContext.get_fields x, l
+      | _ -> [], ast
+    in
+    PpxContext.restore fields;
+    let ast =
+      try
+        let mapper = mapper () in
+        mapper.structure mapper ast
+      with exn ->
+        [{pstr_desc = Pstr_extension (extension_of_exn exn, []);
+          pstr_loc  = Location.none}]
+    in
+    let fields = PpxContext.update_cookies fields in
+    Str.attribute (PpxContext.mk fields) :: ast
+  in
+  let iface ast =
+    let fields, ast =
+      match ast with
+      | {psig_desc = Psig_attribute ({attr_name = {txt = "ocaml.ppx.context"};
+                                      attr_payload = x;
+                                      attr_loc = _})} :: l ->
+          PpxContext.get_fields x, l
+      | _ -> [], ast
+    in
+    PpxContext.restore fields;
+    let ast =
+      try
+        let mapper = mapper () in
+        mapper.signature mapper ast
+      with exn ->
+        [{psig_desc = Psig_extension (extension_of_exn exn, []);
+          psig_loc  = Location.none}]
+    in
+    let fields = PpxContext.update_cookies fields in
+    Sig.attribute (PpxContext.mk fields) :: ast
+  in
+
+  let ic = open_in_bin source in
+  let magic =
+    really_input_string ic (String.length Config.ast_impl_magic_number)
+  in
+
+  let rewrite transform =
+    Location.input_name := input_value ic;
+    let ast = input_value ic in
+    close_in ic;
+    let ast = transform ast in
+    let oc = open_out_bin target in
+    output_string oc magic;
+    output_value oc !Location.input_name;
+    output_value oc ast;
+    close_out oc
+  and fail () =
+    close_in ic;
+    failwith "Ast_mapper: OCaml version mismatch or malformed input";
+  in
+
+  if magic = Config.ast_impl_magic_number then
+    rewrite (implem : structure -> structure)
+  else if magic = Config.ast_intf_magic_number then
+    rewrite (iface : signature -> signature)
+  else fail ()
+
+let drop_ppx_context_str ~restore = function
+  | {pstr_desc = Pstr_attribute
+                   {attr_name = {Location.txt = "ocaml.ppx.context"};
+                    attr_payload = a;
+                    attr_loc = _}}
+    :: items ->
+      if restore then
+        PpxContext.restore (PpxContext.get_fields a);
+      items
+  | items -> items
+
+let drop_ppx_context_sig ~restore = function
+  | {psig_desc = Psig_attribute
+                   {attr_name = {Location.txt = "ocaml.ppx.context"};
+                    attr_payload = a;
+                    attr_loc = _}}
+    :: items ->
+      if restore then
+        PpxContext.restore (PpxContext.get_fields a);
+      items
+  | items -> items
+
+let add_ppx_context_str ~tool_name ast =
+  Ast_helper.Str.attribute (ppx_context ~tool_name ()) :: ast
+
+let add_ppx_context_sig ~tool_name ast =
+  Ast_helper.Sig.attribute (ppx_context ~tool_name ()) :: ast
+
+
+let apply ~source ~target mapper =
+  apply_lazy ~source ~target (fun () -> mapper)
+
+let run_main mapper =
+  try
+    let a = Sys.argv in
+    let n = Array.length a in
+    if n > 2 then
+      let mapper () =
+        try mapper (Array.to_list (Array.sub a 1 (n - 3)))
+        with exn ->
+          (* PR#6463 *)
+          let f _ _ = raise exn in
+          {default_mapper with structure = f; signature = f}
+      in
+      apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) mapper
+    else begin
+      Printf.eprintf "Usage: %s [extra_args] <infile> <outfile>\n%!"
+                     Sys.executable_name;
+      exit 2
+    end
+  with exn ->
+    prerr_endline (Printexc.to_string exn);
+    exit 2
+
+let register_function = ref (fun _name f -> run_main f)
+let register name f = !register_function name f
diff --git a/upstream/ocaml_412/parsing/ast_mapper.mli b/upstream/ocaml_412/parsing/ast_mapper.mli
new file mode 100644
index 0000000..69f6b01
--- /dev/null
+++ b/upstream/ocaml_412/parsing/ast_mapper.mli
@@ -0,0 +1,208 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** The interface of a -ppx rewriter
+
+  A -ppx rewriter is a program that accepts a serialized abstract syntax
+  tree and outputs another, possibly modified, abstract syntax tree.
+  This module encapsulates the interface between the compiler and
+  the -ppx rewriters, handling such details as the serialization format,
+  forwarding of command-line flags, and storing state.
+
+  {!mapper} enables AST rewriting using open recursion.
+  A typical mapper would be based on {!default_mapper}, a deep
+  identity mapper, and will fall back on it for handling the syntax it
+  does not modify. For example:
+
+  {[
+open Asttypes
+open Parsetree
+open Ast_mapper
+
+let test_mapper argv =
+  { default_mapper with
+    expr = fun mapper expr ->
+      match expr with
+      | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} ->
+        Ast_helper.Exp.constant (Const_int 42)
+      | other -> default_mapper.expr mapper other; }
+
+let () =
+  register "ppx_test" test_mapper]}
+
+  This -ppx rewriter, which replaces [[%test]] in expressions with
+  the constant [42], can be compiled using
+  [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml].
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+  *)
+
+open Parsetree
+
+(** {1 A generic Parsetree mapper} *)
+
+type mapper = {
+  attribute: mapper -> attribute -> attribute;
+  attributes: mapper -> attribute list -> attribute list;
+  binding_op: mapper -> binding_op -> binding_op;
+  case: mapper -> case -> case;
+  cases: mapper -> case list -> case list;
+  class_declaration: mapper -> class_declaration -> class_declaration;
+  class_description: mapper -> class_description -> class_description;
+  class_expr: mapper -> class_expr -> class_expr;
+  class_field: mapper -> class_field -> class_field;
+  class_signature: mapper -> class_signature -> class_signature;
+  class_structure: mapper -> class_structure -> class_structure;
+  class_type: mapper -> class_type -> class_type;
+  class_type_declaration: mapper -> class_type_declaration
+                          -> class_type_declaration;
+  class_type_field: mapper -> class_type_field -> class_type_field;
+  constant: mapper -> constant -> constant;
+  constructor_declaration: mapper -> constructor_declaration
+                           -> constructor_declaration;
+  expr: mapper -> expression -> expression;
+  extension: mapper -> extension -> extension;
+  extension_constructor: mapper -> extension_constructor
+                         -> extension_constructor;
+  include_declaration: mapper -> include_declaration -> include_declaration;
+  include_description: mapper -> include_description -> include_description;
+  label_declaration: mapper -> label_declaration -> label_declaration;
+  location: mapper -> Location.t -> Location.t;
+  module_binding: mapper -> module_binding -> module_binding;
+  module_declaration: mapper -> module_declaration -> module_declaration;
+  module_substitution: mapper -> module_substitution -> module_substitution;
+  module_expr: mapper -> module_expr -> module_expr;
+  module_type: mapper -> module_type -> module_type;
+  module_type_declaration: mapper -> module_type_declaration
+                           -> module_type_declaration;
+  open_declaration: mapper -> open_declaration -> open_declaration;
+  open_description: mapper -> open_description -> open_description;
+  pat: mapper -> pattern -> pattern;
+  payload: mapper -> payload -> payload;
+  signature: mapper -> signature -> signature;
+  signature_item: mapper -> signature_item -> signature_item;
+  structure: mapper -> structure -> structure;
+  structure_item: mapper -> structure_item -> structure_item;
+  typ: mapper -> core_type -> core_type;
+  type_declaration: mapper -> type_declaration -> type_declaration;
+  type_extension: mapper -> type_extension -> type_extension;
+  type_exception: mapper -> type_exception -> type_exception;
+  type_kind: mapper -> type_kind -> type_kind;
+  value_binding: mapper -> value_binding -> value_binding;
+  value_description: mapper -> value_description -> value_description;
+  with_constraint: mapper -> with_constraint -> with_constraint;
+}
+(** A mapper record implements one "method" per syntactic category,
+    using an open recursion style: each method takes as its first
+    argument the mapper to be applied to children in the syntax
+    tree. *)
+
+val default_mapper: mapper
+(** A default mapper, which implements a "deep identity" mapping. *)
+
+(** {1 Apply mappers to compilation units} *)
+
+val tool_name: unit -> string
+(** Can be used within a ppx preprocessor to know which tool is
+    calling it ["ocamlc"], ["ocamlopt"], ["ocamldoc"], ["ocamldep"],
+    ["ocaml"], ...  Some global variables that reflect command-line
+    options are automatically synchronized between the calling tool
+    and the ppx preprocessor: {!Clflags.include_dirs},
+    {!Load_path}, {!Clflags.open_modules}, {!Clflags.for_package},
+    {!Clflags.debug}. *)
+
+
+val apply: source:string -> target:string -> mapper -> unit
+(** Apply a mapper (parametrized by the unit name) to a dumped
+    parsetree found in the [source] file and put the result in the
+    [target] file. The [structure] or [signature] field of the mapper
+    is applied to the implementation or interface.  *)
+
+val run_main: (string list -> mapper) -> unit
+(** Entry point to call to implement a standalone -ppx rewriter from a
+    mapper, parametrized by the command line arguments.  The current
+    unit name can be obtained from {!Location.input_name}.  This
+    function implements proper error reporting for uncaught
+    exceptions. *)
+
+(** {1 Registration API} *)
+
+val register_function: (string -> (string list -> mapper) -> unit) ref
+
+val register: string -> (string list -> mapper) -> unit
+(** Apply the [register_function].  The default behavior is to run the
+    mapper immediately, taking arguments from the process command
+    line.  This is to support a scenario where a mapper is linked as a
+    stand-alone executable.
+
+    It is possible to overwrite the [register_function] to define
+    "-ppx drivers", which combine several mappers in a single process.
+    Typically, a driver starts by defining [register_function] to a
+    custom implementation, then lets ppx rewriters (linked statically
+    or dynamically) register themselves, and then run all or some of
+    them.  It is also possible to have -ppx drivers apply rewriters to
+    only specific parts of an AST.
+
+    The first argument to [register] is a symbolic name to be used by
+    the ppx driver.  *)
+
+
+(** {1 Convenience functions to write mappers} *)
+
+val map_opt: ('a -> 'b) -> 'a option -> 'b option
+
+val extension_of_error: Location.error -> extension
+(** Encode an error into an 'ocaml.error' extension node which can be
+    inserted in a generated Parsetree.  The compiler will be
+    responsible for reporting the error. *)
+
+val attribute_of_warning: Location.t -> string -> attribute
+(** Encode a warning message into an 'ocaml.ppwarning' attribute which can be
+    inserted in a generated Parsetree.  The compiler will be
+    responsible for reporting the warning. *)
+
+(** {1 Helper functions to call external mappers} *)
+
+val add_ppx_context_str:
+    tool_name:string -> Parsetree.structure -> Parsetree.structure
+(** Extract information from the current environment and encode it
+    into an attribute which is prepended to the list of structure
+    items in order to pass the information to an external
+    processor. *)
+
+val add_ppx_context_sig:
+    tool_name:string -> Parsetree.signature -> Parsetree.signature
+(** Same as [add_ppx_context_str], but for signatures. *)
+
+val drop_ppx_context_str:
+    restore:bool -> Parsetree.structure -> Parsetree.structure
+(** Drop the ocaml.ppx.context attribute from a structure.  If
+    [restore] is true, also restore the associated data in the current
+    process. *)
+
+val drop_ppx_context_sig:
+    restore:bool -> Parsetree.signature -> Parsetree.signature
+(** Same as [drop_ppx_context_str], but for signatures. *)
+
+(** {1 Cookies} *)
+
+(** Cookies are used to pass information from a ppx processor to
+    a further invocation of itself, when called from the OCaml
+    toplevel (or other tools that support cookies). *)
+
+val set_cookie: string -> Parsetree.expression -> unit
+val get_cookie: string -> Parsetree.expression option
diff --git a/upstream/ocaml_412/parsing/asttypes.mli b/upstream/ocaml_412/parsing/asttypes.mli
new file mode 100644
index 0000000..f4745fb
--- /dev/null
+++ b/upstream/ocaml_412/parsing/asttypes.mli
@@ -0,0 +1,67 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Auxiliary AST types used by parsetree and typedtree.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type constant =
+    Const_int of int
+  | Const_char of char
+  | Const_string of string * Location.t * string option
+  | Const_float of string
+  | Const_int32 of int32
+  | Const_int64 of int64
+  | Const_nativeint of nativeint
+
+type rec_flag = Nonrecursive | Recursive
+
+type direction_flag = Upto | Downto
+
+(* Order matters, used in polymorphic comparison *)
+type private_flag = Private | Public
+
+type mutable_flag = Immutable | Mutable
+
+type virtual_flag = Virtual | Concrete
+
+type override_flag = Override | Fresh
+
+type closed_flag = Closed | Open
+
+type label = string
+
+type arg_label =
+    Nolabel
+  | Labelled of string (*  label:T -> ... *)
+  | Optional of string (* ?label:T -> ... *)
+
+type 'a loc = 'a Location.loc = {
+  txt : 'a;
+  loc : Location.t;
+}
+
+
+type variance =
+  | Covariant
+  | Contravariant
+  | NoVariance
+
+type injectivity =
+  | Injective
+  | NoInjectivity
diff --git a/upstream/ocaml_412/parsing/attr_helper.ml b/upstream/ocaml_412/parsing/attr_helper.ml
new file mode 100644
index 0000000..0a616cd
--- /dev/null
+++ b/upstream/ocaml_412/parsing/attr_helper.ml
@@ -0,0 +1,54 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                  Jeremie Dimino, Jane Street Europe                    *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Parsetree
+
+type error =
+  | Multiple_attributes of string
+  | No_payload_expected of string
+
+exception Error of Location.t * error
+
+let get_no_payload_attribute alt_names attrs =
+  match List.filter (fun a -> List.mem a.attr_name.txt alt_names) attrs with
+  | [] -> None
+  | [ {attr_name = name; attr_payload = PStr []; attr_loc = _} ] -> Some name
+  | [ {attr_name = name; _} ] ->
+    raise (Error (name.loc, No_payload_expected name.txt))
+  | _ :: {attr_name = name; _} :: _ ->
+    raise (Error (name.loc, Multiple_attributes name.txt))
+
+let has_no_payload_attribute alt_names attrs =
+  match get_no_payload_attribute alt_names attrs with
+  | None   -> false
+  | Some _ -> true
+
+open Format
+
+let report_error ppf = function
+  | Multiple_attributes name ->
+    fprintf ppf "Too many `%s' attributes" name
+  | No_payload_expected name ->
+    fprintf ppf "Attribute `%s' does not accept a payload" name
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, err) ->
+        Some (Location.error_of_printer ~loc report_error err)
+      | _ ->
+        None
+    )
diff --git a/upstream/ocaml_412/parsing/attr_helper.mli b/upstream/ocaml_412/parsing/attr_helper.mli
new file mode 100644
index 0000000..a3ddc0c
--- /dev/null
+++ b/upstream/ocaml_412/parsing/attr_helper.mli
@@ -0,0 +1,41 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                  Jeremie Dimino, Jane Street Europe                    *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Helpers for attributes
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Asttypes
+open Parsetree
+
+type error =
+  | Multiple_attributes of string
+  | No_payload_expected of string
+
+(** The [string list] argument of the following functions is a list of
+    alternative names for the attribute we are looking for. For instance:
+
+    {[
+      ["foo"; "ocaml.foo"]
+    ]} *)
+val get_no_payload_attribute : string list -> attributes -> string loc option
+val has_no_payload_attribute : string list -> attributes -> bool
+
+exception Error of Location.t * error
+
+val report_error: Format.formatter -> error -> unit
diff --git a/upstream/ocaml_412/parsing/builtin_attributes.ml b/upstream/ocaml_412/parsing/builtin_attributes.ml
new file mode 100644
index 0000000..af495e9
--- /dev/null
+++ b/upstream/ocaml_412/parsing/builtin_attributes.ml
@@ -0,0 +1,287 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Parsetree
+
+let string_of_cst = function
+  | Pconst_string(s, _, _) -> Some s
+  | _ -> None
+
+let string_of_payload = function
+  | PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant c},_)}] ->
+      string_of_cst c
+  | _ -> None
+
+let string_of_opt_payload p =
+  match string_of_payload p with
+  | Some s -> s
+  | None -> ""
+
+let error_of_extension ext =
+  let submessage_from main_loc main_txt = function
+    | {pstr_desc=Pstr_extension
+           (({txt = ("ocaml.error"|"error"); loc}, p), _)} ->
+        begin match p with
+        | PStr([{pstr_desc=Pstr_eval
+                     ({pexp_desc=Pexp_constant(Pconst_string(msg,_,_))}, _)}
+               ]) ->
+            { Location.loc; txt = fun ppf -> Format.pp_print_text ppf msg }
+        | _ ->
+            { Location.loc; txt = fun ppf ->
+                Format.fprintf ppf
+                  "Invalid syntax for sub-message of extension '%s'." main_txt }
+        end
+    | {pstr_desc=Pstr_extension (({txt; loc}, _), _)} ->
+        { Location.loc; txt = fun ppf ->
+            Format.fprintf ppf "Uninterpreted extension '%s'." txt }
+    | _ ->
+        { Location.loc = main_loc; txt = fun ppf ->
+            Format.fprintf ppf
+              "Invalid syntax for sub-message of extension '%s'." main_txt }
+  in
+  match ext with
+  | ({txt = ("ocaml.error"|"error") as txt; loc}, p) ->
+      begin match p with
+      | PStr [] -> raise Location.Already_displayed_error
+      | PStr({pstr_desc=Pstr_eval
+                  ({pexp_desc=Pexp_constant(Pconst_string(msg,_,_))}, _)}::
+             inner) ->
+          let sub = List.map (submessage_from loc txt) inner in
+          Location.error_of_printer ~loc ~sub Format.pp_print_text msg
+      | _ ->
+          Location.errorf ~loc "Invalid syntax for extension '%s'." txt
+      end
+  | ({txt; loc}, _) ->
+      Location.errorf ~loc "Uninterpreted extension '%s'." txt
+
+let kind_and_message = function
+  | PStr[
+      {pstr_desc=
+         Pstr_eval
+           ({pexp_desc=Pexp_apply
+                 ({pexp_desc=Pexp_ident{txt=Longident.Lident id}},
+                  [Nolabel,{pexp_desc=Pexp_constant (Pconst_string(s,_,_))}])
+            },_)}] ->
+      Some (id, s)
+  | PStr[
+      {pstr_desc=
+         Pstr_eval
+           ({pexp_desc=Pexp_ident{txt=Longident.Lident id}},_)}] ->
+      Some (id, "")
+  | _ -> None
+
+let cat s1 s2 =
+  if s2 = "" then s1 else s1 ^ "\n" ^ s2
+
+let alert_attr x =
+  match x.attr_name.txt with
+  | "ocaml.deprecated"|"deprecated" ->
+      Some (x, "deprecated", string_of_opt_payload x.attr_payload)
+  | "ocaml.alert"|"alert" ->
+      begin match kind_and_message x.attr_payload with
+      | Some (kind, message) -> Some (x, kind, message)
+      | None -> None (* note: bad payloads detected by warning_attribute *)
+      end
+  | _ -> None
+
+let alert_attrs l =
+  List.filter_map alert_attr l
+
+let alerts_of_attrs l =
+  List.fold_left
+    (fun acc (_, kind, message) ->
+       let upd = function
+         | None | Some "" -> Some message
+         | Some s -> Some (cat s message)
+       in
+       Misc.Stdlib.String.Map.update kind upd acc
+    )
+    Misc.Stdlib.String.Map.empty
+    (alert_attrs l)
+
+let check_alerts loc attrs s =
+  Misc.Stdlib.String.Map.iter
+    (fun kind message -> Location.alert loc ~kind (cat s message))
+    (alerts_of_attrs attrs)
+
+let check_alerts_inclusion ~def ~use loc attrs1 attrs2 s =
+  let m2 = alerts_of_attrs attrs2 in
+  Misc.Stdlib.String.Map.iter
+    (fun kind msg ->
+       if not (Misc.Stdlib.String.Map.mem kind m2) then
+         Location.alert ~def ~use ~kind loc (cat s msg)
+    )
+    (alerts_of_attrs attrs1)
+
+let rec deprecated_mutable_of_attrs = function
+  | [] -> None
+  | {attr_name =  {txt = "ocaml.deprecated_mutable"|"deprecated_mutable"; _};
+     attr_payload = p} :: _ ->
+     Some (string_of_opt_payload p)
+  | _ :: tl -> deprecated_mutable_of_attrs tl
+
+let check_deprecated_mutable loc attrs s =
+  match deprecated_mutable_of_attrs attrs with
+  | None -> ()
+  | Some txt ->
+      Location.deprecated loc (Printf.sprintf "mutating field %s" (cat s txt))
+
+let check_deprecated_mutable_inclusion ~def ~use loc attrs1 attrs2 s =
+  match deprecated_mutable_of_attrs attrs1,
+        deprecated_mutable_of_attrs attrs2
+  with
+  | None, _ | Some _, Some _ -> ()
+  | Some txt, None ->
+      Location.deprecated ~def ~use loc
+        (Printf.sprintf "mutating field %s" (cat s txt))
+
+let rec attrs_of_sig = function
+  | {psig_desc = Psig_attribute a} :: tl ->
+      a :: attrs_of_sig tl
+  | _ ->
+      []
+
+let alerts_of_sig sg = alerts_of_attrs (attrs_of_sig sg)
+
+let rec attrs_of_str = function
+  | {pstr_desc = Pstr_attribute a} :: tl ->
+      a :: attrs_of_str tl
+  | _ ->
+      []
+
+let alerts_of_str str = alerts_of_attrs (attrs_of_str str)
+
+let check_no_alert attrs =
+  List.iter
+    (fun (a, _, _) ->
+       Location.prerr_warning a.attr_loc
+         (Warnings.Misplaced_attribute a.attr_name.txt)
+    )
+    (alert_attrs attrs)
+
+let warn_payload loc txt msg =
+  Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg))
+
+let warning_attribute ?(ppwarning = true) =
+  let process loc txt errflag payload =
+    match string_of_payload payload with
+    | Some s ->
+        begin try Warnings.parse_options errflag s
+        with Arg.Bad msg -> warn_payload loc txt msg
+        end
+    | None ->
+        warn_payload loc txt "A single string literal is expected"
+  in
+  let process_alert loc txt = function
+    | PStr[{pstr_desc=
+              Pstr_eval(
+                {pexp_desc=Pexp_constant(Pconst_string(s,_,_))},
+                _)
+           }] ->
+        begin try Warnings.parse_alert_option s
+        with Arg.Bad msg -> warn_payload loc txt msg
+        end
+    | k ->
+        match kind_and_message k with
+        | Some ("all", _) ->
+            warn_payload loc txt "The alert name 'all' is reserved"
+        | Some _ -> ()
+        | None -> warn_payload loc txt "Invalid payload"
+  in
+  function
+  | {attr_name = {txt = ("ocaml.warning"|"warning") as txt; _};
+     attr_loc;
+     attr_payload;
+     } ->
+      process attr_loc txt false attr_payload
+  | {attr_name = {txt = ("ocaml.warnerror"|"warnerror") as txt; _};
+     attr_loc;
+     attr_payload
+    } ->
+      process attr_loc txt true attr_payload
+  | {attr_name = {txt="ocaml.ppwarning"|"ppwarning"; _};
+     attr_loc = _;
+     attr_payload =
+       PStr [
+         { pstr_desc=
+             Pstr_eval({pexp_desc=Pexp_constant (Pconst_string (s, _, _))},_);
+           pstr_loc }
+       ];
+    } when ppwarning ->
+     Location.prerr_warning pstr_loc (Warnings.Preprocessor s)
+  | {attr_name = {txt = ("ocaml.alert"|"alert") as txt; _};
+     attr_loc;
+     attr_payload;
+     } ->
+      process_alert attr_loc txt attr_payload
+  | _ ->
+     ()
+
+let warning_scope ?ppwarning attrs f =
+  let prev = Warnings.backup () in
+  try
+    List.iter (warning_attribute ?ppwarning) (List.rev attrs);
+    let ret = f () in
+    Warnings.restore prev;
+    ret
+  with exn ->
+    Warnings.restore prev;
+    raise exn
+
+
+let warn_on_literal_pattern =
+  List.exists
+    (fun a -> match a.attr_name.txt with
+       | "ocaml.warn_on_literal_pattern"|"warn_on_literal_pattern" -> true
+       | _ -> false
+    )
+
+let explicit_arity =
+  List.exists
+    (fun a -> match a.attr_name.txt with
+       | "ocaml.explicit_arity"|"explicit_arity" -> true
+       | _ -> false
+    )
+
+let immediate =
+  List.exists
+    (fun a -> match a.attr_name.txt with
+       | "ocaml.immediate"|"immediate" -> true
+       | _ -> false
+    )
+
+let immediate64 =
+  List.exists
+    (fun a -> match a.attr_name.txt with
+       | "ocaml.immediate64"|"immediate64" -> true
+       | _ -> false
+    )
+
+(* The "ocaml.boxed (default)" and "ocaml.unboxed (default)"
+   attributes cannot be input by the user, they are added by the
+   compiler when applying the default setting. This is done to record
+   in the .cmi the default used by the compiler when compiling the
+   source file because the default can change between compiler
+   invocations. *)
+
+let check l a = List.mem a.attr_name.txt l
+
+let has_unboxed attr =
+  List.exists (check ["ocaml.unboxed"; "unboxed"])
+    attr
+
+let has_boxed attr =
+  List.exists (check ["ocaml.boxed"; "boxed"]) attr
diff --git a/upstream/ocaml_412/parsing/builtin_attributes.mli b/upstream/ocaml_412/parsing/builtin_attributes.mli
new file mode 100644
index 0000000..6200fd7
--- /dev/null
+++ b/upstream/ocaml_412/parsing/builtin_attributes.mli
@@ -0,0 +1,84 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Support for some of the builtin attributes
+
+    - ocaml.deprecated
+    - ocaml.alert
+    - ocaml.error
+    - ocaml.ppwarning
+    - ocaml.warning
+    - ocaml.warnerror
+    - ocaml.explicit_arity (for camlp4/camlp5)
+    - ocaml.warn_on_literal_pattern
+    - ocaml.deprecated_mutable
+    - ocaml.immediate
+    - ocaml.immediate64
+    - ocaml.boxed / ocaml.unboxed
+
+    {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+val check_alerts: Location.t -> Parsetree.attributes -> string -> unit
+val check_alerts_inclusion:
+  def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes ->
+  Parsetree.attributes -> string -> unit
+val alerts_of_attrs: Parsetree.attributes -> Misc.alerts
+val alerts_of_sig: Parsetree.signature -> Misc.alerts
+val alerts_of_str: Parsetree.structure -> Misc.alerts
+
+val check_deprecated_mutable:
+    Location.t -> Parsetree.attributes -> string -> unit
+val check_deprecated_mutable_inclusion:
+  def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes ->
+  Parsetree.attributes -> string -> unit
+
+val check_no_alert: Parsetree.attributes -> unit
+
+val error_of_extension: Parsetree.extension -> Location.error
+
+val warning_attribute: ?ppwarning:bool -> Parsetree.attribute -> unit
+  (** Apply warning settings from the specified attribute.
+      "ocaml.warning"/"ocaml.warnerror" (and variants without the prefix)
+      are processed and other attributes are ignored.
+
+      Also implement ocaml.ppwarning (unless ~ppwarning:false is
+      passed).
+  *)
+
+val warning_scope:
+  ?ppwarning:bool ->
+  Parsetree.attributes -> (unit -> 'a) -> 'a
+  (** Execute a function in a new scope for warning settings.  This
+      means that the effect of any call to [warning_attribute] during
+      the execution of this function will be discarded after
+      execution.
+
+      The function also takes a list of attributes which are processed
+      with [warning_attribute] in the fresh scope before the function
+      is executed.
+  *)
+
+val warn_on_literal_pattern: Parsetree.attributes -> bool
+val explicit_arity: Parsetree.attributes -> bool
+
+
+val immediate: Parsetree.attributes -> bool
+val immediate64: Parsetree.attributes -> bool
+
+val has_unboxed: Parsetree.attributes -> bool
+val has_boxed: Parsetree.attributes -> bool
diff --git a/upstream/ocaml_412/parsing/docstrings.ml b/upstream/ocaml_412/parsing/docstrings.ml
new file mode 100644
index 0000000..a39f75d
--- /dev/null
+++ b/upstream/ocaml_412/parsing/docstrings.ml
@@ -0,0 +1,425 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                               Leo White                                *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Location
+
+(* Docstrings *)
+
+(* A docstring is "attached" if it has been inserted in the AST. This
+   is used for generating unexpected docstring warnings. *)
+type ds_attached =
+  | Unattached   (* Not yet attached anything.*)
+  | Info         (* Attached to a field or constructor. *)
+  | Docs         (* Attached to an item or as floating text. *)
+
+(* A docstring is "associated" with an item if there are no blank lines between
+   them. This is used for generating docstring ambiguity warnings. *)
+type ds_associated =
+  | Zero             (* Not associated with an item *)
+  | One              (* Associated with one item *)
+  | Many             (* Associated with multiple items (ambiguity) *)
+
+type docstring =
+  { ds_body: string;
+    ds_loc: Location.t;
+    mutable ds_attached: ds_attached;
+    mutable ds_associated: ds_associated; }
+
+(* List of docstrings *)
+
+let docstrings : docstring list ref = ref []
+
+(* Warn for unused and ambiguous docstrings *)
+
+let warn_bad_docstrings () =
+  if Warnings.is_active (Warnings.Unexpected_docstring true) then begin
+    List.iter
+      (fun ds ->
+         match ds.ds_attached with
+         | Info -> ()
+         | Unattached ->
+           prerr_warning ds.ds_loc (Warnings.Unexpected_docstring true)
+         | Docs ->
+             match ds.ds_associated with
+             | Zero | One -> ()
+             | Many ->
+               prerr_warning ds.ds_loc (Warnings.Unexpected_docstring false))
+      (List.rev !docstrings)
+end
+
+(* Docstring constructors and destructors *)
+
+let docstring body loc =
+  let ds =
+    { ds_body = body;
+      ds_loc = loc;
+      ds_attached = Unattached;
+      ds_associated = Zero; }
+  in
+  ds
+
+let register ds =
+  docstrings := ds :: !docstrings
+
+let docstring_body ds = ds.ds_body
+
+let docstring_loc ds = ds.ds_loc
+
+(* Docstrings attached to items *)
+
+type docs =
+  { docs_pre: docstring option;
+    docs_post: docstring option; }
+
+let empty_docs = { docs_pre = None; docs_post = None }
+
+let doc_loc = {txt = "ocaml.doc"; loc = Location.none}
+
+let docs_attr ds =
+  let open Parsetree in
+  let body = ds.ds_body in
+  let loc = ds.ds_loc in
+  let exp =
+    { pexp_desc = Pexp_constant (Pconst_string(body, loc, None));
+      pexp_loc = loc;
+      pexp_loc_stack = [];
+      pexp_attributes = []; }
+  in
+  let item =
+    { pstr_desc = Pstr_eval (exp, []); pstr_loc = loc }
+  in
+  { attr_name = doc_loc;
+    attr_payload = PStr [item];
+    attr_loc = loc }
+
+let add_docs_attrs docs attrs =
+  let attrs =
+    match docs.docs_pre with
+    | None | Some { ds_body=""; _ } -> attrs
+    | Some ds -> docs_attr ds :: attrs
+  in
+  let attrs =
+    match docs.docs_post with
+    | None | Some { ds_body=""; _ } -> attrs
+    | Some ds -> attrs @ [docs_attr ds]
+  in
+  attrs
+
+(* Docstrings attached to constructors or fields *)
+
+type info = docstring option
+
+let empty_info = None
+
+let info_attr = docs_attr
+
+let add_info_attrs info attrs =
+  match info with
+  | None | Some {ds_body=""; _} -> attrs
+  | Some ds -> attrs @ [info_attr ds]
+
+(* Docstrings not attached to a specific item *)
+
+type text = docstring list
+
+let empty_text = []
+let empty_text_lazy = lazy []
+
+let text_loc = {txt = "ocaml.text"; loc = Location.none}
+
+let text_attr ds =
+  let open Parsetree in
+  let body = ds.ds_body in
+  let loc = ds.ds_loc in
+  let exp =
+    { pexp_desc = Pexp_constant (Pconst_string(body, loc, None));
+      pexp_loc = loc;
+      pexp_loc_stack = [];
+      pexp_attributes = []; }
+  in
+  let item =
+    { pstr_desc = Pstr_eval (exp, []); pstr_loc = loc }
+  in
+  { attr_name = text_loc;
+    attr_payload = PStr [item];
+    attr_loc = loc }
+
+let add_text_attrs dsl attrs =
+  let fdsl = List.filter (function {ds_body=""} -> false| _ ->true) dsl in
+  (List.map text_attr fdsl) @ attrs
+
+(* Find the first non-info docstring in a list, attach it and return it *)
+let get_docstring ~info dsl =
+  let rec loop = function
+    | [] -> None
+    | {ds_attached = Info; _} :: rest -> loop rest
+    | ds :: _ ->
+        ds.ds_attached <- if info then Info else Docs;
+        Some ds
+  in
+  loop dsl
+
+(* Find all the non-info docstrings in a list, attach them and return them *)
+let get_docstrings dsl =
+  let rec loop acc = function
+    | [] -> List.rev acc
+    | {ds_attached = Info; _} :: rest -> loop acc rest
+    | ds :: rest ->
+        ds.ds_attached <- Docs;
+        loop (ds :: acc) rest
+  in
+    loop [] dsl
+
+(* "Associate" all the docstrings in a list *)
+let associate_docstrings dsl =
+  List.iter
+    (fun ds ->
+       match ds.ds_associated with
+       | Zero -> ds.ds_associated <- One
+       | (One | Many) -> ds.ds_associated <- Many)
+    dsl
+
+(* Map from positions to pre docstrings *)
+
+let pre_table : (Lexing.position, docstring list) Hashtbl.t =
+  Hashtbl.create 50
+
+let set_pre_docstrings pos dsl =
+  if dsl <> [] then Hashtbl.add pre_table pos dsl
+
+let get_pre_docs pos =
+  try
+    let dsl = Hashtbl.find pre_table pos in
+      associate_docstrings dsl;
+      get_docstring ~info:false dsl
+  with Not_found -> None
+
+let mark_pre_docs pos =
+  try
+    let dsl = Hashtbl.find pre_table pos in
+      associate_docstrings dsl
+  with Not_found -> ()
+
+(* Map from positions to post docstrings *)
+
+let post_table : (Lexing.position, docstring list) Hashtbl.t =
+  Hashtbl.create 50
+
+let set_post_docstrings pos dsl =
+  if dsl <> [] then Hashtbl.add post_table pos dsl
+
+let get_post_docs pos =
+  try
+    let dsl = Hashtbl.find post_table pos in
+      associate_docstrings dsl;
+      get_docstring ~info:false dsl
+  with Not_found -> None
+
+let mark_post_docs pos =
+  try
+    let dsl = Hashtbl.find post_table pos in
+      associate_docstrings dsl
+  with Not_found -> ()
+
+let get_info pos =
+  try
+    let dsl = Hashtbl.find post_table pos in
+      get_docstring ~info:true dsl
+  with Not_found -> None
+
+(* Map from positions to floating docstrings *)
+
+let floating_table : (Lexing.position, docstring list) Hashtbl.t =
+  Hashtbl.create 50
+
+let set_floating_docstrings pos dsl =
+  if dsl <> [] then Hashtbl.add floating_table pos dsl
+
+let get_text pos =
+  try
+    let dsl = Hashtbl.find floating_table pos in
+      get_docstrings dsl
+  with Not_found -> []
+
+let get_post_text pos =
+  try
+    let dsl = Hashtbl.find post_table pos in
+      get_docstrings dsl
+  with Not_found -> []
+
+(* Maps from positions to extra docstrings *)
+
+let pre_extra_table : (Lexing.position, docstring list) Hashtbl.t =
+  Hashtbl.create 50
+
+let set_pre_extra_docstrings pos dsl =
+  if dsl <> [] then Hashtbl.add pre_extra_table pos dsl
+
+let get_pre_extra_text pos =
+  try
+    let dsl = Hashtbl.find pre_extra_table pos in
+      get_docstrings dsl
+  with Not_found -> []
+
+let post_extra_table : (Lexing.position, docstring list) Hashtbl.t =
+  Hashtbl.create 50
+
+let set_post_extra_docstrings pos dsl =
+  if dsl <> [] then Hashtbl.add post_extra_table pos dsl
+
+let get_post_extra_text pos =
+  try
+    let dsl = Hashtbl.find post_extra_table pos in
+      get_docstrings dsl
+  with Not_found -> []
+
+(* Docstrings from parser actions *)
+module WithParsing = struct
+let symbol_docs () =
+  { docs_pre = get_pre_docs (Parsing.symbol_start_pos ());
+    docs_post = get_post_docs (Parsing.symbol_end_pos ()); }
+
+let symbol_docs_lazy () =
+  let p1 = Parsing.symbol_start_pos () in
+  let p2 = Parsing.symbol_end_pos () in
+    lazy { docs_pre = get_pre_docs p1;
+           docs_post = get_post_docs p2; }
+
+let rhs_docs pos1 pos2 =
+  { docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1);
+    docs_post = get_post_docs (Parsing.rhs_end_pos pos2); }
+
+let rhs_docs_lazy pos1 pos2 =
+  let p1 = Parsing.rhs_start_pos pos1 in
+  let p2 = Parsing.rhs_end_pos pos2 in
+    lazy { docs_pre = get_pre_docs p1;
+           docs_post = get_post_docs p2; }
+
+let mark_symbol_docs () =
+  mark_pre_docs (Parsing.symbol_start_pos ());
+  mark_post_docs (Parsing.symbol_end_pos ())
+
+let mark_rhs_docs pos1 pos2 =
+  mark_pre_docs (Parsing.rhs_start_pos pos1);
+  mark_post_docs (Parsing.rhs_end_pos pos2)
+
+let symbol_info () =
+  get_info (Parsing.symbol_end_pos ())
+
+let rhs_info pos =
+  get_info (Parsing.rhs_end_pos pos)
+
+let symbol_text () =
+  get_text (Parsing.symbol_start_pos ())
+
+let symbol_text_lazy () =
+  let pos = Parsing.symbol_start_pos () in
+    lazy (get_text pos)
+
+let rhs_text pos =
+  get_text (Parsing.rhs_start_pos pos)
+
+let rhs_post_text pos =
+  get_post_text (Parsing.rhs_end_pos pos)
+
+let rhs_text_lazy pos =
+  let pos = Parsing.rhs_start_pos pos in
+    lazy (get_text pos)
+
+let symbol_pre_extra_text () =
+  get_pre_extra_text (Parsing.symbol_start_pos ())
+
+let symbol_post_extra_text () =
+  get_post_extra_text (Parsing.symbol_end_pos ())
+
+let rhs_pre_extra_text pos =
+  get_pre_extra_text (Parsing.rhs_start_pos pos)
+
+let rhs_post_extra_text pos =
+  get_post_extra_text (Parsing.rhs_end_pos pos)
+end
+
+include WithParsing
+
+module WithMenhir = struct
+let symbol_docs (startpos, endpos) =
+  { docs_pre = get_pre_docs startpos;
+    docs_post = get_post_docs endpos; }
+
+let symbol_docs_lazy (p1, p2) =
+  lazy { docs_pre = get_pre_docs p1;
+         docs_post = get_post_docs p2; }
+
+let rhs_docs pos1 pos2 =
+  { docs_pre = get_pre_docs pos1;
+    docs_post = get_post_docs pos2; }
+
+let rhs_docs_lazy p1 p2 =
+    lazy { docs_pre = get_pre_docs p1;
+           docs_post = get_post_docs p2; }
+
+let mark_symbol_docs (startpos, endpos) =
+  mark_pre_docs startpos;
+  mark_post_docs endpos;
+  ()
+
+let mark_rhs_docs pos1 pos2 =
+  mark_pre_docs pos1;
+  mark_post_docs pos2;
+  ()
+
+let symbol_info endpos =
+  get_info endpos
+
+let rhs_info endpos =
+  get_info endpos
+
+let symbol_text startpos =
+  get_text startpos
+
+let symbol_text_lazy startpos =
+  lazy (get_text startpos)
+
+let rhs_text pos =
+  get_text pos
+
+let rhs_post_text pos =
+  get_post_text pos
+
+let rhs_text_lazy pos =
+  lazy (get_text pos)
+
+let symbol_pre_extra_text startpos =
+  get_pre_extra_text startpos
+
+let symbol_post_extra_text endpos =
+  get_post_extra_text endpos
+
+let rhs_pre_extra_text pos =
+  get_pre_extra_text pos
+
+let rhs_post_extra_text pos =
+  get_post_extra_text pos
+end
+
+(* (Re)Initialise all comment state *)
+
+let init () =
+  docstrings := [];
+  Hashtbl.reset pre_table;
+  Hashtbl.reset post_table;
+  Hashtbl.reset floating_table;
+  Hashtbl.reset pre_extra_table;
+  Hashtbl.reset post_extra_table
diff --git a/upstream/ocaml_412/parsing/docstrings.mli b/upstream/ocaml_412/parsing/docstrings.mli
new file mode 100644
index 0000000..bf2508f
--- /dev/null
+++ b/upstream/ocaml_412/parsing/docstrings.mli
@@ -0,0 +1,223 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                               Leo White                                *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Documentation comments
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+(** (Re)Initialise all docstring state *)
+val init : unit -> unit
+
+(** Emit warnings for unattached and ambiguous docstrings *)
+val warn_bad_docstrings : unit -> unit
+
+(** {2 Docstrings} *)
+
+(** Documentation comments *)
+type docstring
+
+(** Create a docstring *)
+val docstring : string -> Location.t -> docstring
+
+(** Register a docstring *)
+val register : docstring -> unit
+
+(** Get the text of a docstring *)
+val docstring_body : docstring -> string
+
+(** Get the location of a docstring *)
+val docstring_loc : docstring -> Location.t
+
+(** {2 Set functions}
+
+   These functions are used by the lexer to associate docstrings to
+   the locations of tokens. *)
+
+(** Docstrings immediately preceding a token *)
+val set_pre_docstrings : Lexing.position -> docstring list -> unit
+
+(** Docstrings immediately following a token *)
+val set_post_docstrings : Lexing.position -> docstring list -> unit
+
+(** Docstrings not immediately adjacent to a token *)
+val set_floating_docstrings : Lexing.position -> docstring list -> unit
+
+(** Docstrings immediately following the token which precedes this one *)
+val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit
+
+(** Docstrings immediately preceding the token which follows this one *)
+val set_post_extra_docstrings : Lexing.position -> docstring list -> unit
+
+(** {2 Items}
+
+    The {!docs} type represents documentation attached to an item. *)
+
+type docs =
+  { docs_pre: docstring option;
+    docs_post: docstring option; }
+
+val empty_docs : docs
+
+val docs_attr : docstring -> Parsetree.attribute
+
+(** Convert item documentation to attributes and add them to an
+    attribute list *)
+val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes
+
+(** Fetch the item documentation for the current symbol. This also
+    marks this documentation (for ambiguity warnings). *)
+val symbol_docs : unit -> docs
+val symbol_docs_lazy : unit -> docs Lazy.t
+
+(** Fetch the item documentation for the symbols between two
+    positions. This also marks this documentation (for ambiguity
+    warnings). *)
+val rhs_docs : int -> int -> docs
+val rhs_docs_lazy : int -> int -> docs Lazy.t
+
+(** Mark the item documentation for the current symbol (for ambiguity
+    warnings). *)
+val mark_symbol_docs : unit -> unit
+
+(** Mark as associated the item documentation for the symbols between
+    two positions (for ambiguity warnings) *)
+val mark_rhs_docs : int -> int -> unit
+
+(** {2 Fields and constructors}
+
+    The {!info} type represents documentation attached to a field or
+    constructor. *)
+
+type info = docstring option
+
+val empty_info : info
+
+val info_attr : docstring -> Parsetree.attribute
+
+(** Convert field info to attributes and add them to an
+    attribute list *)
+val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes
+
+(** Fetch the field info for the current symbol. *)
+val symbol_info : unit -> info
+
+(** Fetch the field info following the symbol at a given position. *)
+val rhs_info : int -> info
+
+(** {2 Unattached comments}
+
+    The {!text} type represents documentation which is not attached to
+    anything. *)
+
+type text = docstring list
+
+val empty_text : text
+val empty_text_lazy : text Lazy.t
+
+val text_attr : docstring -> Parsetree.attribute
+
+(** Convert text to attributes and add them to an attribute list *)
+val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes
+
+(** Fetch the text preceding the current symbol. *)
+val symbol_text : unit -> text
+val symbol_text_lazy : unit -> text Lazy.t
+
+(** Fetch the text preceding the symbol at the given position. *)
+val rhs_text : int -> text
+val rhs_text_lazy : int -> text Lazy.t
+
+(** {2 Extra text}
+
+    There may be additional text attached to the delimiters of a block
+    (e.g. [struct] and [end]). This is fetched by the following
+    functions, which are applied to the contents of the block rather
+    than the delimiters. *)
+
+(** Fetch additional text preceding the current symbol *)
+val symbol_pre_extra_text : unit -> text
+
+(** Fetch additional text following the current symbol *)
+val symbol_post_extra_text : unit -> text
+
+(** Fetch additional text preceding the symbol at the given position *)
+val rhs_pre_extra_text : int -> text
+
+(** Fetch additional text following the symbol at the given position *)
+val rhs_post_extra_text : int -> text
+
+(** Fetch text following the symbol at the given position *)
+val rhs_post_text : int -> text
+
+module WithMenhir: sig
+(** Fetch the item documentation for the current symbol. This also
+    marks this documentation (for ambiguity warnings). *)
+val symbol_docs : Lexing.position * Lexing.position -> docs
+val symbol_docs_lazy : Lexing.position * Lexing.position -> docs Lazy.t
+
+(** Fetch the item documentation for the symbols between two
+    positions. This also marks this documentation (for ambiguity
+    warnings). *)
+val rhs_docs : Lexing.position -> Lexing.position -> docs
+val rhs_docs_lazy : Lexing.position -> Lexing.position -> docs Lazy.t
+
+(** Mark the item documentation for the current symbol (for ambiguity
+    warnings). *)
+val mark_symbol_docs : Lexing.position * Lexing.position -> unit
+
+(** Mark as associated the item documentation for the symbols between
+    two positions (for ambiguity warnings) *)
+val mark_rhs_docs : Lexing.position -> Lexing.position -> unit
+
+(** Fetch the field info for the current symbol. *)
+val symbol_info : Lexing.position -> info
+
+(** Fetch the field info following the symbol at a given position. *)
+val rhs_info : Lexing.position -> info
+
+(** Fetch the text preceding the current symbol. *)
+val symbol_text : Lexing.position -> text
+val symbol_text_lazy : Lexing.position -> text Lazy.t
+
+(** Fetch the text preceding the symbol at the given position. *)
+val rhs_text : Lexing.position -> text
+val rhs_text_lazy : Lexing.position -> text Lazy.t
+
+(** {3 Extra text}
+
+    There may be additional text attached to the delimiters of a block
+    (e.g. [struct] and [end]). This is fetched by the following
+    functions, which are applied to the contents of the block rather
+    than the delimiters. *)
+
+(** Fetch additional text preceding the current symbol *)
+val symbol_pre_extra_text : Lexing.position -> text
+
+(** Fetch additional text following the current symbol *)
+val symbol_post_extra_text : Lexing.position -> text
+
+(** Fetch additional text preceding the symbol at the given position *)
+val rhs_pre_extra_text : Lexing.position -> text
+
+(** Fetch additional text following the symbol at the given position *)
+val rhs_post_extra_text : Lexing.position -> text
+
+(** Fetch text following the symbol at the given position *)
+val rhs_post_text : Lexing.position -> text
+
+end
diff --git a/upstream/ocaml_412/parsing/lexer.mli b/upstream/ocaml_412/parsing/lexer.mli
new file mode 100644
index 0000000..cde2ad5
--- /dev/null
+++ b/upstream/ocaml_412/parsing/lexer.mli
@@ -0,0 +1,64 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** The lexical analyzer
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+val init : unit -> unit
+val token: Lexing.lexbuf -> Parser.token
+val skip_hash_bang: Lexing.lexbuf -> unit
+
+type error =
+  | Illegal_character of char
+  | Illegal_escape of string * string option
+  | Reserved_sequence of string * string option
+  | Unterminated_comment of Location.t
+  | Unterminated_string
+  | Unterminated_string_in_comment of Location.t * Location.t
+  | Keyword_as_label of string
+  | Invalid_literal of string
+  | Invalid_directive of string * string option
+;;
+
+exception Error of error * Location.t
+
+val in_comment : unit -> bool;;
+val in_string : unit -> bool;;
+
+
+val print_warnings : bool ref
+val handle_docstrings: bool ref
+val comments : unit -> (string * Location.t) list
+val token_with_comments : Lexing.lexbuf -> Parser.token
+
+(*
+  [set_preprocessor init preprocessor] registers [init] as the function
+to call to initialize the preprocessor when the lexer is initialized,
+and [preprocessor] a function that is called when a new token is needed
+by the parser, as [preprocessor lexer lexbuf] where [lexer] is the
+lexing function.
+
+When a preprocessor is configured by calling [set_preprocessor], the lexer
+changes its behavior to accept backslash-newline as a token-separating blank.
+*)
+
+val set_preprocessor :
+  (unit -> unit) ->
+  ((Lexing.lexbuf -> Parser.token) -> Lexing.lexbuf -> Parser.token) ->
+  unit
diff --git a/upstream/ocaml_412/parsing/lexer.mll b/upstream/ocaml_412/parsing/lexer.mll
new file mode 100644
index 0000000..9533904
--- /dev/null
+++ b/upstream/ocaml_412/parsing/lexer.mll
@@ -0,0 +1,862 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* The lexer definition *)
+
+{
+open Lexing
+open Misc
+open Parser
+
+type error =
+  | Illegal_character of char
+  | Illegal_escape of string * string option
+  | Reserved_sequence of string * string option
+  | Unterminated_comment of Location.t
+  | Unterminated_string
+  | Unterminated_string_in_comment of Location.t * Location.t
+  | Keyword_as_label of string
+  | Invalid_literal of string
+  | Invalid_directive of string * string option
+;;
+
+exception Error of error * Location.t;;
+
+(* The table of keywords *)
+
+let keyword_table =
+  create_hashtable 149 [
+    "and", AND;
+    "as", AS;
+    "assert", ASSERT;
+    "begin", BEGIN;
+    "class", CLASS;
+    "constraint", CONSTRAINT;
+    "do", DO;
+    "done", DONE;
+    "downto", DOWNTO;
+    "else", ELSE;
+    "end", END;
+    "exception", EXCEPTION;
+    "external", EXTERNAL;
+    "false", FALSE;
+    "for", FOR;
+    "fun", FUN;
+    "function", FUNCTION;
+    "functor", FUNCTOR;
+    "if", IF;
+    "in", IN;
+    "include", INCLUDE;
+    "inherit", INHERIT;
+    "initializer", INITIALIZER;
+    "lazy", LAZY;
+    "let", LET;
+    "match", MATCH;
+    "method", METHOD;
+    "module", MODULE;
+    "mutable", MUTABLE;
+    "new", NEW;
+    "nonrec", NONREC;
+    "object", OBJECT;
+    "of", OF;
+    "open", OPEN;
+    "or", OR;
+(*  "parser", PARSER; *)
+    "private", PRIVATE;
+    "rec", REC;
+    "sig", SIG;
+    "struct", STRUCT;
+    "then", THEN;
+    "to", TO;
+    "true", TRUE;
+    "try", TRY;
+    "type", TYPE;
+    "val", VAL;
+    "virtual", VIRTUAL;
+    "when", WHEN;
+    "while", WHILE;
+    "with", WITH;
+
+    "lor", INFIXOP3("lor"); (* Should be INFIXOP2 *)
+    "lxor", INFIXOP3("lxor"); (* Should be INFIXOP2 *)
+    "mod", INFIXOP3("mod");
+    "land", INFIXOP3("land");
+    "lsl", INFIXOP4("lsl");
+    "lsr", INFIXOP4("lsr");
+    "asr", INFIXOP4("asr")
+]
+
+(* To buffer string literals *)
+
+let string_buffer = Buffer.create 256
+let reset_string_buffer () = Buffer.reset string_buffer
+let get_stored_string () = Buffer.contents string_buffer
+
+let store_string_char c = Buffer.add_char string_buffer c
+let store_string_utf_8_uchar u = Buffer.add_utf_8_uchar string_buffer u
+let store_string s = Buffer.add_string string_buffer s
+let store_lexeme lexbuf = store_string (Lexing.lexeme lexbuf)
+
+(* To store the position of the beginning of a string and comment *)
+let string_start_loc = ref Location.none;;
+let comment_start_loc = ref [];;
+let in_comment () = !comment_start_loc <> [];;
+let is_in_string = ref false
+let in_string () = !is_in_string
+let print_warnings = ref true
+
+(* Escaped chars are interpreted in strings unless they are in comments. *)
+let store_escaped_char lexbuf c =
+  if in_comment () then store_lexeme lexbuf else store_string_char c
+
+let store_escaped_uchar lexbuf u =
+  if in_comment () then store_lexeme lexbuf else store_string_utf_8_uchar u
+
+let compute_quoted_string_idloc {Location.loc_start = orig_loc } shift id =
+  let id_start_pos = orig_loc.Lexing.pos_cnum + shift in
+  let loc_start =
+    Lexing.{orig_loc with pos_cnum = id_start_pos }
+  in
+  let loc_end =
+    Lexing.{orig_loc with pos_cnum = id_start_pos + String.length id}
+  in
+  {Location. loc_start ; loc_end ; loc_ghost = false }
+
+let wrap_string_lexer f lexbuf =
+  let loc_start = lexbuf.lex_curr_p in
+  reset_string_buffer();
+  is_in_string := true;
+  let string_start = lexbuf.lex_start_p in
+  string_start_loc := Location.curr lexbuf;
+  let loc_end = f lexbuf in
+  is_in_string := false;
+  lexbuf.lex_start_p <- string_start;
+  let loc = Location.{loc_ghost= false; loc_start; loc_end} in
+  get_stored_string (), loc
+
+let wrap_comment_lexer comment lexbuf =
+  let start_loc = Location.curr lexbuf  in
+  comment_start_loc := [start_loc];
+  reset_string_buffer ();
+  let end_loc = comment lexbuf in
+  let s = get_stored_string () in
+  reset_string_buffer ();
+  s,
+  { start_loc with Location.loc_end = end_loc.Location.loc_end }
+
+let error lexbuf e = raise (Error(e, Location.curr lexbuf))
+let error_loc loc e = raise (Error(e, loc))
+
+(* to translate escape sequences *)
+
+let digit_value c =
+  match c with
+  | 'a' .. 'f' -> 10 + Char.code c - Char.code 'a'
+  | 'A' .. 'F' -> 10 + Char.code c - Char.code 'A'
+  | '0' .. '9' -> Char.code c - Char.code '0'
+  | _ -> assert false
+
+let num_value lexbuf ~base ~first ~last =
+  let c = ref 0 in
+  for i = first to last do
+    let v = digit_value (Lexing.lexeme_char lexbuf i) in
+    assert(v < base);
+    c := (base * !c) + v
+  done;
+  !c
+
+let char_for_backslash = function
+  | 'n' -> '\010'
+  | 'r' -> '\013'
+  | 'b' -> '\008'
+  | 't' -> '\009'
+  | c   -> c
+
+let illegal_escape lexbuf reason =
+  let error = Illegal_escape (Lexing.lexeme lexbuf, Some reason) in
+  raise (Error (error, Location.curr lexbuf))
+
+let char_for_decimal_code lexbuf i =
+  let c = num_value lexbuf ~base:10 ~first:i ~last:(i+2) in
+  if (c < 0 || c > 255) then
+    if in_comment ()
+    then 'x'
+    else
+      illegal_escape lexbuf
+        (Printf.sprintf
+          "%d is outside the range of legal characters (0-255)." c)
+  else Char.chr c
+
+let char_for_octal_code lexbuf i =
+  let c = num_value lexbuf ~base:8 ~first:i ~last:(i+2) in
+  if (c < 0 || c > 255) then
+    if in_comment ()
+    then 'x'
+    else
+      illegal_escape lexbuf
+        (Printf.sprintf
+          "o%o (=%d) is outside the range of legal characters (0-255)." c c)
+  else Char.chr c
+
+let char_for_hexadecimal_code lexbuf i =
+  Char.chr (num_value lexbuf ~base:16 ~first:i ~last:(i+1))
+
+let uchar_for_uchar_escape lexbuf =
+  let len = Lexing.lexeme_end lexbuf - Lexing.lexeme_start lexbuf in
+  let first = 3 (* skip opening \u{ *) in
+  let last = len - 2 (* skip closing } *) in
+  let digit_count = last - first + 1 in
+  match digit_count > 6 with
+  | true ->
+      illegal_escape lexbuf
+        "too many digits, expected 1 to 6 hexadecimal digits"
+  | false ->
+      let cp = num_value lexbuf ~base:16 ~first ~last in
+      if Uchar.is_valid cp then Uchar.unsafe_of_int cp else
+      illegal_escape lexbuf
+        (Printf.sprintf "%X is not a Unicode scalar value" cp)
+
+let is_keyword name = Hashtbl.mem keyword_table name
+
+let check_label_name lexbuf name =
+  if is_keyword name then error lexbuf (Keyword_as_label name)
+
+(* Update the current location with file name and line number. *)
+
+let update_loc lexbuf file line absolute chars =
+  let pos = lexbuf.lex_curr_p in
+  let new_file = match file with
+                 | None -> pos.pos_fname
+                 | Some s -> s
+  in
+  lexbuf.lex_curr_p <- { pos with
+    pos_fname = new_file;
+    pos_lnum = if absolute then line else pos.pos_lnum + line;
+    pos_bol = pos.pos_cnum - chars;
+  }
+;;
+
+let preprocessor = ref None
+
+let escaped_newlines = ref false
+
+(* Warn about Latin-1 characters used in idents *)
+
+let warn_latin1 lexbuf =
+  Location.deprecated
+    (Location.curr lexbuf)
+    "ISO-Latin1 characters in identifiers"
+
+let handle_docstrings = ref true
+let comment_list = ref []
+
+let add_comment com =
+  comment_list := com :: !comment_list
+
+let add_docstring_comment ds =
+  let com =
+    ("*" ^ Docstrings.docstring_body ds, Docstrings.docstring_loc ds)
+  in
+    add_comment com
+
+let comments () = List.rev !comment_list
+
+(* Error report *)
+
+open Format
+
+let prepare_error loc = function
+  | Illegal_character c ->
+      Location.errorf ~loc "Illegal character (%s)" (Char.escaped c)
+  | Illegal_escape (s, explanation) ->
+      Location.errorf ~loc
+        "Illegal backslash escape in string or character (%s)%t" s
+        (fun ppf -> match explanation with
+           | None -> ()
+           | Some expl -> fprintf ppf ": %s" expl)
+  | Reserved_sequence (s, explanation) ->
+      Location.errorf ~loc
+        "Reserved character sequence: %s%t" s
+        (fun ppf -> match explanation with
+           | None -> ()
+           | Some expl -> fprintf ppf " %s" expl)
+  | Unterminated_comment _ ->
+      Location.errorf ~loc "Comment not terminated"
+  | Unterminated_string ->
+      Location.errorf ~loc "String literal not terminated"
+  | Unterminated_string_in_comment (_, literal_loc) ->
+      Location.errorf ~loc
+        "This comment contains an unterminated string literal"
+        ~sub:[Location.msg ~loc:literal_loc "String literal begins here"]
+  | Keyword_as_label kwd ->
+      Location.errorf ~loc
+        "`%s' is a keyword, it cannot be used as label name" kwd
+  | Invalid_literal s ->
+      Location.errorf ~loc "Invalid literal %s" s
+  | Invalid_directive (dir, explanation) ->
+      Location.errorf ~loc "Invalid lexer directive %S%t" dir
+        (fun ppf -> match explanation with
+           | None -> ()
+           | Some expl -> fprintf ppf ": %s" expl)
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (err, loc) ->
+          Some (prepare_error loc err)
+      | _ ->
+          None
+    )
+
+}
+
+let newline = ('\013'* '\010')
+let blank = [' ' '\009' '\012']
+let lowercase = ['a'-'z' '_']
+let uppercase = ['A'-'Z']
+let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9']
+let lowercase_latin1 = ['a'-'z' '\223'-'\246' '\248'-'\255' '_']
+let uppercase_latin1 = ['A'-'Z' '\192'-'\214' '\216'-'\222']
+let identchar_latin1 =
+  ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
+(* This should be kept in sync with the [is_identchar] function in [env.ml] *)
+
+let symbolchar =
+  ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
+let dotsymbolchar =
+  ['!' '$' '%' '&' '*' '+' '-' '/' ':' '=' '>' '?' '@' '^' '|']
+let symbolchar_or_hash =
+  symbolchar | '#'
+let kwdopchar =
+  ['$' '&' '*' '+' '-' '/' '<' '=' '>' '@' '^' '|']
+
+let ident = (lowercase | uppercase) identchar*
+let extattrident = ident ('.' ident)*
+
+let decimal_literal =
+  ['0'-'9'] ['0'-'9' '_']*
+let hex_digit =
+  ['0'-'9' 'A'-'F' 'a'-'f']
+let hex_literal =
+  '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']['0'-'9' 'A'-'F' 'a'-'f' '_']*
+let oct_literal =
+  '0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']*
+let bin_literal =
+  '0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']*
+let int_literal =
+  decimal_literal | hex_literal | oct_literal | bin_literal
+let float_literal =
+  ['0'-'9'] ['0'-'9' '_']*
+  ('.' ['0'-'9' '_']* )?
+  (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )?
+let hex_float_literal =
+  '0' ['x' 'X']
+  ['0'-'9' 'A'-'F' 'a'-'f'] ['0'-'9' 'A'-'F' 'a'-'f' '_']*
+  ('.' ['0'-'9' 'A'-'F' 'a'-'f' '_']* )?
+  (['p' 'P'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )?
+let literal_modifier = ['G'-'Z' 'g'-'z']
+
+rule token = parse
+  | ('\\' as bs) newline {
+      if not !escaped_newlines then error lexbuf (Illegal_character bs);
+      update_loc lexbuf None 1 false 0;
+      token lexbuf }
+  | newline
+      { update_loc lexbuf None 1 false 0;
+        EOL }
+  | blank +
+      { token lexbuf }
+  | "_"
+      { UNDERSCORE }
+  | "~"
+      { TILDE }
+  | ".~"
+      { error lexbuf
+          (Reserved_sequence (".~", Some "is reserved for use in MetaOCaml")) }
+  | "~" (lowercase identchar * as name) ':'
+      { check_label_name lexbuf name;
+        LABEL name }
+  | "~" (lowercase_latin1 identchar_latin1 * as name) ':'
+      { warn_latin1 lexbuf;
+        LABEL name }
+  | "?"
+      { QUESTION }
+  | "?" (lowercase identchar * as name) ':'
+      { check_label_name lexbuf name;
+        OPTLABEL name }
+  | "?" (lowercase_latin1 identchar_latin1 * as name) ':'
+      { warn_latin1 lexbuf;
+        OPTLABEL name }
+  | lowercase identchar * as name
+      { try Hashtbl.find keyword_table name
+        with Not_found -> LIDENT name }
+  | lowercase_latin1 identchar_latin1 * as name
+      { warn_latin1 lexbuf; LIDENT name }
+  | uppercase identchar * as name
+      { UIDENT name } (* No capitalized keywords *)
+  | uppercase_latin1 identchar_latin1 * as name
+      { warn_latin1 lexbuf; UIDENT name }
+  | int_literal as lit { INT (lit, None) }
+  | (int_literal as lit) (literal_modifier as modif)
+      { INT (lit, Some modif) }
+  | float_literal | hex_float_literal as lit
+      { FLOAT (lit, None) }
+  | (float_literal | hex_float_literal as lit) (literal_modifier as modif)
+      { FLOAT (lit, Some modif) }
+  | (float_literal | hex_float_literal | int_literal) identchar+ as invalid
+      { error lexbuf (Invalid_literal invalid) }
+  | "\""
+      { let s, loc = wrap_string_lexer string lexbuf in
+        STRING (s, loc, None) }
+  | "{" (lowercase* as delim) "|"
+      { let s, loc = wrap_string_lexer (quoted_string delim) lexbuf in
+        STRING (s, loc, Some delim) }
+  | "{%" (extattrident as id) "|"
+      { let orig_loc = Location.curr lexbuf in
+        let s, loc = wrap_string_lexer (quoted_string "") lexbuf in
+        let idloc = compute_quoted_string_idloc orig_loc 2 id in
+        QUOTED_STRING_EXPR (id, idloc, s, loc, Some "") }
+  | "{%" (extattrident as id) blank+ (lowercase* as delim) "|"
+      { let orig_loc = Location.curr lexbuf in
+        let s, loc = wrap_string_lexer (quoted_string delim) lexbuf in
+        let idloc = compute_quoted_string_idloc orig_loc 2 id in
+        QUOTED_STRING_EXPR (id, idloc, s, loc, Some delim) }
+  | "{%%" (extattrident as id) "|"
+      { let orig_loc = Location.curr lexbuf in
+        let s, loc = wrap_string_lexer (quoted_string "") lexbuf in
+        let idloc = compute_quoted_string_idloc orig_loc 3 id in
+        QUOTED_STRING_ITEM (id, idloc, s, loc, Some "") }
+  | "{%%" (extattrident as id) blank+ (lowercase* as delim) "|"
+      { let orig_loc = Location.curr lexbuf in
+        let s, loc = wrap_string_lexer (quoted_string delim) lexbuf in
+        let idloc = compute_quoted_string_idloc orig_loc 3 id in
+        QUOTED_STRING_ITEM (id, idloc, s, loc, Some delim) }
+  | "\'" newline "\'"
+      { update_loc lexbuf None 1 false 1;
+        (* newline is ('\013'* '\010') *)
+        CHAR '\n' }
+  | "\'" ([^ '\\' '\'' '\010' '\013'] as c) "\'"
+      { CHAR c }
+  | "\'\\" (['\\' '\'' '\"' 'n' 't' 'b' 'r' ' '] as c) "\'"
+      { CHAR (char_for_backslash c) }
+  | "\'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "\'"
+      { CHAR(char_for_decimal_code lexbuf 2) }
+  | "\'\\" 'o' ['0'-'7'] ['0'-'7'] ['0'-'7'] "\'"
+      { CHAR(char_for_octal_code lexbuf 3) }
+  | "\'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "\'"
+      { CHAR(char_for_hexadecimal_code lexbuf 3) }
+  | "\'" ("\\" _ as esc)
+      { error lexbuf (Illegal_escape (esc, None)) }
+  | "(*"
+      { let s, loc = wrap_comment_lexer comment lexbuf in
+        COMMENT (s, loc) }
+  | "(**"
+      { let s, loc = wrap_comment_lexer comment lexbuf in
+        if !handle_docstrings then
+          DOCSTRING (Docstrings.docstring s loc)
+        else
+          COMMENT ("*" ^ s, loc)
+      }
+  | "(**" (('*'+) as stars)
+      { let s, loc =
+          wrap_comment_lexer
+            (fun lexbuf ->
+               store_string ("*" ^ stars);
+               comment lexbuf)
+            lexbuf
+        in
+        COMMENT (s, loc) }
+  | "(*)"
+      { if !print_warnings then
+          Location.prerr_warning (Location.curr lexbuf) Warnings.Comment_start;
+        let s, loc = wrap_comment_lexer comment lexbuf in
+        COMMENT (s, loc) }
+  | "(*" (('*'*) as stars) "*)"
+      { if !handle_docstrings && stars="" then
+         (* (**) is an empty docstring *)
+          DOCSTRING(Docstrings.docstring "" (Location.curr lexbuf))
+        else
+          COMMENT (stars, Location.curr lexbuf) }
+  | "*)"
+      { let loc = Location.curr lexbuf in
+        Location.prerr_warning loc Warnings.Comment_not_end;
+        lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1;
+        let curpos = lexbuf.lex_curr_p in
+        lexbuf.lex_curr_p <- { curpos with pos_cnum = curpos.pos_cnum - 1 };
+        STAR
+      }
+  | "#"
+      { let at_beginning_of_line pos = (pos.pos_cnum = pos.pos_bol) in
+        if not (at_beginning_of_line lexbuf.lex_start_p)
+        then HASH
+        else try directive lexbuf with Failure _ -> HASH
+      }
+  | "&"  { AMPERSAND }
+  | "&&" { AMPERAMPER }
+  | "`"  { BACKQUOTE }
+  | "\'" { QUOTE }
+  | "("  { LPAREN }
+  | ")"  { RPAREN }
+  | "*"  { STAR }
+  | ","  { COMMA }
+  | "->" { MINUSGREATER }
+  | "."  { DOT }
+  | ".." { DOTDOT }
+  | "." (dotsymbolchar symbolchar* as op) { DOTOP op }
+  | ":"  { COLON }
+  | "::" { COLONCOLON }
+  | ":=" { COLONEQUAL }
+  | ":>" { COLONGREATER }
+  | ";"  { SEMI }
+  | ";;" { SEMISEMI }
+  | "<"  { LESS }
+  | "<-" { LESSMINUS }
+  | "="  { EQUAL }
+  | "["  { LBRACKET }
+  | "[|" { LBRACKETBAR }
+  | "[<" { LBRACKETLESS }
+  | "[>" { LBRACKETGREATER }
+  | "]"  { RBRACKET }
+  | "{"  { LBRACE }
+  | "{<" { LBRACELESS }
+  | "|"  { BAR }
+  | "||" { BARBAR }
+  | "|]" { BARRBRACKET }
+  | ">"  { GREATER }
+  | ">]" { GREATERRBRACKET }
+  | "}"  { RBRACE }
+  | ">}" { GREATERRBRACE }
+  | "[@" { LBRACKETAT }
+  | "[@@"  { LBRACKETATAT }
+  | "[@@@" { LBRACKETATATAT }
+  | "[%"   { LBRACKETPERCENT }
+  | "[%%"  { LBRACKETPERCENTPERCENT }
+  | "!"  { BANG }
+  | "!=" { INFIXOP0 "!=" }
+  | "+"  { PLUS }
+  | "+." { PLUSDOT }
+  | "+=" { PLUSEQ }
+  | "-"  { MINUS }
+  | "-." { MINUSDOT }
+
+  | "!" symbolchar_or_hash + as op
+            { PREFIXOP op }
+  | ['~' '?'] symbolchar_or_hash + as op
+            { PREFIXOP op }
+  | ['=' '<' '>' '|' '&' '$'] symbolchar * as op
+            { INFIXOP0 op }
+  | ['@' '^'] symbolchar * as op
+            { INFIXOP1 op }
+  | ['+' '-'] symbolchar * as op
+            { INFIXOP2 op }
+  | "**" symbolchar * as op
+            { INFIXOP4 op }
+  | '%'     { PERCENT }
+  | ['*' '/' '%'] symbolchar * as op
+            { INFIXOP3 op }
+  | '#' symbolchar_or_hash + as op
+            { HASHOP op }
+  | "let" kwdopchar dotsymbolchar * as op
+            { LETOP op }
+  | "and" kwdopchar dotsymbolchar * as op
+            { ANDOP op }
+  | eof { EOF }
+  | (_ as illegal_char)
+      { error lexbuf (Illegal_character illegal_char) }
+
+and directive = parse
+  | ([' ' '\t']* (['0'-'9']+ as num) [' ' '\t']*
+        ("\"" ([^ '\010' '\013' '\"' ] * as name) "\"") as directive)
+        [^ '\010' '\013'] *
+      {
+        match int_of_string num with
+        | exception _ ->
+            (* PR#7165 *)
+            let explanation = "line number out of range" in
+            error lexbuf (Invalid_directive ("#" ^ directive, Some explanation))
+        | line_num ->
+           (* Documentation says that the line number should be
+              positive, but we have never guarded against this and it
+              might have useful hackish uses. *)
+            update_loc lexbuf (Some name) (line_num - 1) true 0;
+            token lexbuf
+      }
+and comment = parse
+    "(*"
+      { comment_start_loc := (Location.curr lexbuf) :: !comment_start_loc;
+        store_lexeme lexbuf;
+        comment lexbuf
+      }
+  | "*)"
+      { match !comment_start_loc with
+        | [] -> assert false
+        | [_] -> comment_start_loc := []; Location.curr lexbuf
+        | _ :: l -> comment_start_loc := l;
+                  store_lexeme lexbuf;
+                  comment lexbuf
+       }
+  | "\""
+      {
+        string_start_loc := Location.curr lexbuf;
+        store_string_char '\"';
+        is_in_string := true;
+        let _loc = try string lexbuf
+        with Error (Unterminated_string, str_start) ->
+          match !comment_start_loc with
+          | [] -> assert false
+          | loc :: _ ->
+            let start = List.hd (List.rev !comment_start_loc) in
+            comment_start_loc := [];
+            error_loc loc (Unterminated_string_in_comment (start, str_start))
+        in
+        is_in_string := false;
+        store_string_char '\"';
+        comment lexbuf }
+  | "{" ('%' '%'? extattrident blank*)? (lowercase* as delim) "|"
+      {
+        string_start_loc := Location.curr lexbuf;
+        store_lexeme lexbuf;
+        is_in_string := true;
+        let _loc = try quoted_string delim lexbuf
+        with Error (Unterminated_string, str_start) ->
+          match !comment_start_loc with
+          | [] -> assert false
+          | loc :: _ ->
+            let start = List.hd (List.rev !comment_start_loc) in
+            comment_start_loc := [];
+            error_loc loc (Unterminated_string_in_comment (start, str_start))
+        in
+        is_in_string := false;
+        store_string_char '|';
+        store_string delim;
+        store_string_char '}';
+        comment lexbuf }
+  | "\'\'"
+      { store_lexeme lexbuf; comment lexbuf }
+  | "\'" newline "\'"
+      { update_loc lexbuf None 1 false 1;
+        store_lexeme lexbuf;
+        comment lexbuf
+      }
+  | "\'" [^ '\\' '\'' '\010' '\013' ] "\'"
+      { store_lexeme lexbuf; comment lexbuf }
+  | "\'\\" ['\\' '\"' '\'' 'n' 't' 'b' 'r' ' '] "\'"
+      { store_lexeme lexbuf; comment lexbuf }
+  | "\'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "\'"
+      { store_lexeme lexbuf; comment lexbuf }
+  | "\'\\" 'o' ['0'-'3'] ['0'-'7'] ['0'-'7'] "\'"
+      { store_lexeme lexbuf; comment lexbuf }
+  | "\'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "\'"
+      { store_lexeme lexbuf; comment lexbuf }
+  | eof
+      { match !comment_start_loc with
+        | [] -> assert false
+        | loc :: _ ->
+          let start = List.hd (List.rev !comment_start_loc) in
+          comment_start_loc := [];
+          error_loc loc (Unterminated_comment start)
+      }
+  | newline
+      { update_loc lexbuf None 1 false 0;
+        store_lexeme lexbuf;
+        comment lexbuf
+      }
+  | ident
+      { store_lexeme lexbuf; comment lexbuf }
+  | _
+      { store_lexeme lexbuf; comment lexbuf }
+
+and string = parse
+    '\"'
+      { lexbuf.lex_start_p }
+  | '\\' newline ([' ' '\t'] * as space)
+      { update_loc lexbuf None 1 false (String.length space);
+        if in_comment () then store_lexeme lexbuf;
+        string lexbuf
+      }
+  | '\\' (['\\' '\'' '\"' 'n' 't' 'b' 'r' ' '] as c)
+      { store_escaped_char lexbuf (char_for_backslash c);
+        string lexbuf }
+  | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9']
+      { store_escaped_char lexbuf (char_for_decimal_code lexbuf 1);
+         string lexbuf }
+  | '\\' 'o' ['0'-'7'] ['0'-'7'] ['0'-'7']
+      { store_escaped_char lexbuf (char_for_octal_code lexbuf 2);
+         string lexbuf }
+  | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F']
+      { store_escaped_char lexbuf (char_for_hexadecimal_code lexbuf 2);
+         string lexbuf }
+  | '\\' 'u' '{' hex_digit+ '}'
+        { store_escaped_uchar lexbuf (uchar_for_uchar_escape lexbuf);
+          string lexbuf }
+  | '\\' _
+      { if not (in_comment ()) then begin
+(*  Should be an error, but we are very lax.
+          error lexbuf (Illegal_escape (Lexing.lexeme lexbuf, None))
+*)
+          let loc = Location.curr lexbuf in
+          Location.prerr_warning loc Warnings.Illegal_backslash;
+        end;
+        store_lexeme lexbuf;
+        string lexbuf
+      }
+  | newline
+      { if not (in_comment ()) then
+          Location.prerr_warning (Location.curr lexbuf) Warnings.Eol_in_string;
+        update_loc lexbuf None 1 false 0;
+        store_lexeme lexbuf;
+        string lexbuf
+      }
+  | eof
+      { is_in_string := false;
+        error_loc !string_start_loc Unterminated_string }
+  | (_ as c)
+      { store_string_char c;
+        string lexbuf }
+
+and quoted_string delim = parse
+  | newline
+      { update_loc lexbuf None 1 false 0;
+        store_lexeme lexbuf;
+        quoted_string delim lexbuf
+      }
+  | eof
+      { is_in_string := false;
+        error_loc !string_start_loc Unterminated_string }
+  | "|" (lowercase* as edelim) "}"
+      {
+        if delim = edelim then lexbuf.lex_start_p
+        else (store_lexeme lexbuf; quoted_string delim lexbuf)
+      }
+  | (_ as c)
+      { store_string_char c;
+        quoted_string delim lexbuf }
+
+and skip_hash_bang = parse
+  | "#!" [^ '\n']* '\n' [^ '\n']* "\n!#\n"
+      { update_loc lexbuf None 3 false 0 }
+  | "#!" [^ '\n']* '\n'
+      { update_loc lexbuf None 1 false 0 }
+  | "" { () }
+
+{
+
+  let token_with_comments lexbuf =
+    match !preprocessor with
+    | None -> token lexbuf
+    | Some (_init, preprocess) -> preprocess token lexbuf
+
+  type newline_state =
+    | NoLine (* There have been no blank lines yet. *)
+    | NewLine
+        (* There have been no blank lines, and the previous
+           token was a newline. *)
+    | BlankLine (* There have been blank lines. *)
+
+  type doc_state =
+    | Initial  (* There have been no docstrings yet *)
+    | After of docstring list
+        (* There have been docstrings, none of which were
+           preceded by a blank line *)
+    | Before of docstring list * docstring list * docstring list
+        (* There have been docstrings, some of which were
+           preceded by a blank line *)
+
+  and docstring = Docstrings.docstring
+
+  let token lexbuf =
+    let post_pos = lexeme_end_p lexbuf in
+    let attach lines docs pre_pos =
+      let open Docstrings in
+        match docs, lines with
+        | Initial, _ -> ()
+        | After a, (NoLine | NewLine) ->
+            set_post_docstrings post_pos (List.rev a);
+            set_pre_docstrings pre_pos a;
+        | After a, BlankLine ->
+            set_post_docstrings post_pos (List.rev a);
+            set_pre_extra_docstrings pre_pos (List.rev a)
+        | Before(a, f, b), (NoLine | NewLine) ->
+            set_post_docstrings post_pos (List.rev a);
+            set_post_extra_docstrings post_pos
+              (List.rev_append f (List.rev b));
+            set_floating_docstrings pre_pos (List.rev f);
+            set_pre_extra_docstrings pre_pos (List.rev a);
+            set_pre_docstrings pre_pos b
+        | Before(a, f, b), BlankLine ->
+            set_post_docstrings post_pos (List.rev a);
+            set_post_extra_docstrings post_pos
+              (List.rev_append f (List.rev b));
+            set_floating_docstrings pre_pos
+              (List.rev_append f (List.rev b));
+            set_pre_extra_docstrings pre_pos (List.rev a)
+    in
+    let rec loop lines docs lexbuf =
+      match token_with_comments lexbuf with
+      | COMMENT (s, loc) ->
+          add_comment (s, loc);
+          let lines' =
+            match lines with
+            | NoLine -> NoLine
+            | NewLine -> NoLine
+            | BlankLine -> BlankLine
+          in
+          loop lines' docs lexbuf
+      | EOL ->
+          let lines' =
+            match lines with
+            | NoLine -> NewLine
+            | NewLine -> BlankLine
+            | BlankLine -> BlankLine
+          in
+          loop lines' docs lexbuf
+      | DOCSTRING doc ->
+          Docstrings.register doc;
+          add_docstring_comment doc;
+          let docs' =
+            if Docstrings.docstring_body doc = "/*" then
+              match docs with
+              | Initial -> Before([], [doc], [])
+              | After a -> Before (a, [doc], [])
+              | Before(a, f, b) -> Before(a, doc :: b @ f, [])
+            else
+              match docs, lines with
+              | Initial, (NoLine | NewLine) -> After [doc]
+              | Initial, BlankLine -> Before([], [], [doc])
+              | After a, (NoLine | NewLine) -> After (doc :: a)
+              | After a, BlankLine -> Before (a, [], [doc])
+              | Before(a, f, b), (NoLine | NewLine) -> Before(a, f, doc :: b)
+              | Before(a, f, b), BlankLine -> Before(a, b @ f, [doc])
+          in
+          loop NoLine docs' lexbuf
+      | tok ->
+          attach lines docs (lexeme_start_p lexbuf);
+          tok
+    in
+      loop NoLine Initial lexbuf
+
+  let init () =
+    is_in_string := false;
+    comment_start_loc := [];
+    comment_list := [];
+    match !preprocessor with
+    | None -> ()
+    | Some (init, _preprocess) -> init ()
+
+  let set_preprocessor init preprocess =
+    escaped_newlines := true;
+    preprocessor := Some (init, preprocess)
+
+}
diff --git a/upstream/ocaml_412/parsing/location.ml b/upstream/ocaml_412/parsing/location.ml
new file mode 100644
index 0000000..fa31fea
--- /dev/null
+++ b/upstream/ocaml_412/parsing/location.ml
@@ -0,0 +1,943 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Lexing
+
+type t = Warnings.loc =
+  { loc_start: position; loc_end: position; loc_ghost: bool };;
+
+let in_file name =
+  let loc = { dummy_pos with pos_fname = name } in
+  { loc_start = loc; loc_end = loc; loc_ghost = true }
+;;
+
+let none = in_file "_none_";;
+let is_none l = (l = none);;
+
+let curr lexbuf = {
+  loc_start = lexbuf.lex_start_p;
+  loc_end = lexbuf.lex_curr_p;
+  loc_ghost = false
+};;
+
+let init lexbuf fname =
+  lexbuf.lex_curr_p <- {
+    pos_fname = fname;
+    pos_lnum = 1;
+    pos_bol = 0;
+    pos_cnum = 0;
+  }
+;;
+
+let symbol_rloc () = {
+  loc_start = Parsing.symbol_start_pos ();
+  loc_end = Parsing.symbol_end_pos ();
+  loc_ghost = false;
+};;
+
+let symbol_gloc () = {
+  loc_start = Parsing.symbol_start_pos ();
+  loc_end = Parsing.symbol_end_pos ();
+  loc_ghost = true;
+};;
+
+let rhs_loc n = {
+  loc_start = Parsing.rhs_start_pos n;
+  loc_end = Parsing.rhs_end_pos n;
+  loc_ghost = false;
+};;
+
+let rhs_interval m n = {
+  loc_start = Parsing.rhs_start_pos m;
+  loc_end = Parsing.rhs_end_pos n;
+  loc_ghost = false;
+};;
+
+(* return file, line, char from the given position *)
+let get_pos_info pos =
+  (pos.pos_fname, pos.pos_lnum, pos.pos_cnum - pos.pos_bol)
+;;
+
+type 'a loc = {
+  txt : 'a;
+  loc : t;
+}
+
+let mkloc txt loc = { txt ; loc }
+let mknoloc txt = mkloc txt none
+
+(******************************************************************************)
+(* Input info *)
+
+let input_name = ref "_none_"
+let input_lexbuf = ref (None : lexbuf option)
+let input_phrase_buffer = ref (None : Buffer.t option)
+
+(******************************************************************************)
+(* Terminal info *)
+
+let status = ref Terminfo.Uninitialised
+
+let setup_terminal () =
+  if !status = Terminfo.Uninitialised then
+    status := Terminfo.setup stdout
+
+(* The number of lines already printed after input.
+
+   This is used by [highlight_terminfo] to identify the current position of the
+   input in the terminal. This would not be possible without this information,
+   since printing several warnings/errors adds text between the user input and
+   the bottom of the terminal.
+*)
+let num_loc_lines = ref 0
+
+(* This is used by the toplevel to reset [num_loc_lines] before each phrase *)
+let reset () =
+  num_loc_lines := 0
+
+(* This is used by the toplevel *)
+let echo_eof () =
+  print_newline ();
+  incr num_loc_lines
+
+(* Code printing errors and warnings must be wrapped using this function, in
+   order to update [num_loc_lines].
+
+   [print_updating_num_loc_lines ppf f arg] is equivalent to calling [f ppf
+   arg], and additionally updates [num_loc_lines]. *)
+let print_updating_num_loc_lines ppf f arg =
+  let open Format in
+  let out_functions = pp_get_formatter_out_functions ppf () in
+  let out_string str start len =
+    let rec count i c =
+      if i = start + len then c
+      else if String.get str i = '\n' then count (succ i) (succ c)
+      else count (succ i) c in
+    num_loc_lines := !num_loc_lines + count start 0 ;
+    out_functions.out_string str start len in
+  pp_set_formatter_out_functions ppf
+    { out_functions with out_string } ;
+  f ppf arg ;
+  pp_print_flush ppf ();
+  pp_set_formatter_out_functions ppf out_functions
+
+let setup_colors () =
+  Misc.Color.setup !Clflags.color
+
+(******************************************************************************)
+(* Printing locations, e.g. 'File "foo.ml", line 3, characters 10-12' *)
+
+let rewrite_absolute_path path =
+  match Misc.get_build_path_prefix_map () with
+  | None -> path
+  | Some map -> Build_path_prefix_map.rewrite map path
+
+let absolute_path s = (* This function could go into Filename *)
+  let open Filename in
+  let s =
+    if not (is_relative s) then s
+    else (rewrite_absolute_path (concat (Sys.getcwd ()) s))
+  in
+  (* Now simplify . and .. components *)
+  let rec aux s =
+    let base = basename s in
+    let dir = dirname s in
+    if dir = s then dir
+    else if base = current_dir_name then aux dir
+    else if base = parent_dir_name then dirname (aux dir)
+    else concat (aux dir) base
+  in
+  aux s
+
+let show_filename file =
+  if !Clflags.absname then absolute_path file else file
+
+let print_filename ppf file =
+  Format.pp_print_string ppf (show_filename file)
+
+(* Best-effort printing of the text describing a location, of the form
+   'File "foo.ml", line 3, characters 10-12'.
+
+   Some of the information (filename, line number or characters numbers) in the
+   location might be invalid; in which case we do not print it.
+ *)
+let print_loc ppf loc =
+  setup_colors ();
+  let file_valid = function
+    | "_none_" ->
+        (* This is a dummy placeholder, but we print it anyway to please editors
+           that parse locations in error messages (e.g. Emacs). *)
+        true
+    | "" | "//toplevel//" -> false
+    | _ -> true
+  in
+  let line_valid line = line > 0 in
+  let chars_valid ~startchar ~endchar = startchar <> -1 && endchar <> -1 in
+
+  let file =
+    (* According to the comment in location.mli, if [pos_fname] is "", we must
+       use [!input_name]. *)
+    if loc.loc_start.pos_fname = "" then !input_name
+    else loc.loc_start.pos_fname
+  in
+  let startline = loc.loc_start.pos_lnum in
+  let endline = loc.loc_end.pos_lnum in
+  let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in
+  let endchar = loc.loc_end.pos_cnum - loc.loc_end.pos_bol in
+
+  let first = ref true in
+  let capitalize s =
+    if !first then (first := false; String.capitalize_ascii s)
+    else s in
+  let comma () =
+    if !first then () else Format.fprintf ppf ", " in
+
+  Format.fprintf ppf "@{<loc>";
+
+  if file_valid file then
+    Format.fprintf ppf "%s \"%a\"" (capitalize "file") print_filename file;
+
+  (* Print "line 1" in the case of a dummy line number. This is to please the
+     existing setup of editors that parse locations in error messages (e.g.
+     Emacs). *)
+  comma ();
+  let startline = if line_valid startline then startline else 1 in
+  let endline = if line_valid endline then endline else startline in
+  begin if startline = endline then
+    Format.fprintf ppf "%s %i" (capitalize "line") startline
+  else
+    Format.fprintf ppf "%s %i-%i" (capitalize "lines") startline endline
+  end;
+
+  if chars_valid ~startchar ~endchar then (
+    comma ();
+    Format.fprintf ppf "%s %i-%i" (capitalize "characters") startchar endchar
+  );
+
+  Format.fprintf ppf "@}"
+
+(* Print a comma-separated list of locations *)
+let print_locs ppf locs =
+  Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ")
+    print_loc ppf locs
+
+(******************************************************************************)
+(* An interval set structure; additionally, it stores user-provided information
+   at interval boundaries.
+
+   The implementation provided here is naive and assumes the number of intervals
+   to be small, but the interface would allow for a more efficient
+   implementation if needed.
+
+   Note: the structure only stores maximal intervals (that therefore do not
+   overlap).
+*)
+
+module ISet : sig
+  type 'a bound = 'a * int
+  type 'a t
+  (* bounds are included *)
+  val of_intervals : ('a bound * 'a bound) list -> 'a t
+
+  val mem : 'a t -> pos:int -> bool
+  val find_bound_in : 'a t -> range:(int * int) -> 'a bound option
+
+  val is_start : 'a t -> pos:int -> 'a option
+  val is_end : 'a t -> pos:int -> 'a option
+
+  val extrema : 'a t -> ('a bound * 'a bound) option
+end
+=
+struct
+  type 'a bound = 'a * int
+
+  (* non overlapping intervals *)
+  type 'a t = ('a bound * 'a bound) list
+
+  let of_intervals intervals =
+    let pos =
+      List.map (fun ((a, x), (b, y)) ->
+        if x > y then [] else [((a, x), `S); ((b, y), `E)]
+      ) intervals
+      |> List.flatten
+      |> List.sort (fun ((_, x), k) ((_, y), k') ->
+        (* Make `S come before `E so that consecutive intervals get merged
+           together in the fold below *)
+        let kn = function `S -> 0 | `E -> 1 in
+        compare (x, kn k) (y, kn k'))
+    in
+    let nesting, acc =
+      List.fold_left (fun (nesting, acc) (a, kind) ->
+        match kind, nesting with
+        | `S, `Outside -> `Inside (a, 0), acc
+        | `S, `Inside (s, n) -> `Inside (s, n+1), acc
+        | `E, `Outside -> assert false
+        | `E, `Inside (s, 0) -> `Outside, ((s, a) :: acc)
+        | `E, `Inside (s, n) -> `Inside (s, n-1), acc
+      ) (`Outside, []) pos in
+    assert (nesting = `Outside);
+    List.rev acc
+
+  let mem iset ~pos =
+    List.exists (fun ((_, s), (_, e)) -> s <= pos && pos <= e) iset
+
+  let find_bound_in iset ~range:(start, end_)  =
+    List.find_map (fun ((a, x), (b, y)) ->
+      if start <= x && x <= end_ then Some (a, x)
+      else if start <= y && y <= end_ then Some (b, y)
+      else None
+    ) iset
+
+  let is_start iset ~pos =
+    List.find_map (fun ((a, x), _) ->
+      if pos = x then Some a else None
+    ) iset
+
+  let is_end iset ~pos =
+    List.find_map (fun (_, (b, y)) ->
+      if pos = y then Some b else None
+    ) iset
+
+  let extrema iset =
+    if iset = [] then None
+    else Some (fst (List.hd iset), snd (List.hd (List.rev iset)))
+end
+
+(******************************************************************************)
+(* Toplevel: highlighting and quoting locations *)
+
+(* Highlight the locations using standout mode.
+
+   If [locs] is empty, this function is a no-op.
+*)
+let highlight_terminfo lb ppf locs =
+  Format.pp_print_flush ppf ();  (* avoid mixing Format and normal output *)
+  (* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *)
+  let pos0 = -lb.lex_abs_pos in
+  (* Do nothing if the buffer does not contain the whole phrase. *)
+  if pos0 < 0 then raise Exit;
+  (* Count number of lines in phrase *)
+  let lines = ref !num_loc_lines in
+  for i = pos0 to lb.lex_buffer_len - 1 do
+    if Bytes.get lb.lex_buffer i = '\n' then incr lines
+  done;
+  (* If too many lines, give up *)
+  if !lines >= Terminfo.num_lines stdout - 2 then raise Exit;
+  (* Move cursor up that number of lines *)
+  flush stdout; Terminfo.backup stdout !lines;
+  (* Print the input, switching to standout for the location *)
+  let bol = ref false in
+  print_string "# ";
+  for pos = 0 to lb.lex_buffer_len - pos0 - 1 do
+    if !bol then (print_string "  "; bol := false);
+    if List.exists (fun loc -> pos = loc.loc_start.pos_cnum) locs then
+      Terminfo.standout stdout true;
+    if List.exists (fun loc -> pos = loc.loc_end.pos_cnum) locs then
+      Terminfo.standout stdout false;
+    let c = Bytes.get lb.lex_buffer (pos + pos0) in
+    print_char c;
+    bol := (c = '\n')
+  done;
+  (* Make sure standout mode is over *)
+  Terminfo.standout stdout false;
+  (* Position cursor back to original location *)
+  Terminfo.resume stdout !num_loc_lines;
+  flush stdout
+
+let highlight_terminfo lb ppf locs =
+  try highlight_terminfo lb ppf locs
+  with Exit -> ()
+
+(* Highlight the location by printing it again.
+
+   There are two different styles for highlighting errors in "dumb" mode,
+   depending if the error fits on a single line or spans across several lines.
+
+   For single-line errors,
+
+     foo the_error bar
+
+   gets displayed as follows, where X is the line number:
+
+     X | foo the_error bar
+             ^^^^^^^^^
+
+
+   For multi-line errors,
+
+     foo the_
+     error bar
+
+   gets displayed as:
+
+     X1 | ....the_
+     X2 | error....
+
+   An ellipsis hides the middle lines of the multi-line error if it has more
+   than [max_lines] lines.
+
+   If [locs] is empty then this function is a no-op.
+*)
+
+type input_line = {
+  text : string;
+  start_pos : int;
+}
+
+(* Takes a list of lines with possibly missing line numbers.
+
+   If the line numbers that are present are consistent with the number of lines
+   between them, then infer the intermediate line numbers.
+
+   This is not always the case, typically if lexer line directives are
+   involved... *)
+let infer_line_numbers
+    (lines: (int option * input_line) list):
+  (int option * input_line) list
+  =
+  let (_, offset, consistent) =
+    List.fold_left (fun (i, offset, consistent) (lnum, _) ->
+      match lnum, offset with
+      | None, _ -> (i+1, offset, consistent)
+      | Some n, None -> (i+1, Some (n - i), consistent)
+      | Some n, Some m -> (i+1, offset, consistent && n = m + i)
+    ) (0, None, true) lines
+  in
+  match offset, consistent with
+  | Some m, true ->
+      List.mapi (fun i (_, line) -> (Some (m + i), line)) lines
+  | _, _ ->
+      lines
+
+(* [get_lines] must return the lines to highlight, given starting and ending
+   positions.
+
+   See [lines_around_from_current_input] below for an instantiation of
+   [get_lines] that reads from the current input.
+*)
+let highlight_quote ppf
+    ~(get_lines: start_pos:position -> end_pos:position -> input_line list)
+    ?(max_lines = 10)
+    highlight_tag
+    locs
+  =
+  let iset = ISet.of_intervals @@ List.filter_map (fun loc ->
+    let s, e = loc.loc_start, loc.loc_end in
+    if s.pos_cnum = -1 || e.pos_cnum = -1 then None
+    else Some ((s, s.pos_cnum), (e, e.pos_cnum - 1))
+  ) locs in
+  match ISet.extrema iset with
+  | None -> ()
+  | Some ((leftmost, _), (rightmost, _)) ->
+      let lines =
+        get_lines ~start_pos:leftmost ~end_pos:rightmost
+        |> List.map (fun ({ text; start_pos } as line) ->
+          let end_pos = start_pos + String.length text - 1 in
+          let line_nb =
+            match ISet.find_bound_in iset ~range:(start_pos, end_pos) with
+            | None -> None
+            | Some (p, _) -> Some p.pos_lnum
+          in
+          (line_nb, line))
+        |> infer_line_numbers
+        |> List.map (fun (lnum, { text; start_pos }) ->
+          (text,
+           Option.fold ~some:Int.to_string ~none:"" lnum,
+           start_pos))
+      in
+    Format.fprintf ppf "@[<v>";
+    begin match lines with
+    | [] | [("", _, _)] -> ()
+    | [(line, line_nb, line_start_cnum)] ->
+        (* Single-line error *)
+        Format.fprintf ppf "%s | %s@," line_nb line;
+        Format.fprintf ppf "%*s   " (String.length line_nb) "";
+        for pos = line_start_cnum to rightmost.pos_cnum - 1 do
+          if ISet.is_start iset ~pos <> None then
+            Format.fprintf ppf "@{<%s>" highlight_tag;
+          if ISet.mem iset ~pos then Format.pp_print_char ppf '^'
+          else Format.pp_print_char ppf ' ';
+          if ISet.is_end iset ~pos <> None then
+            Format.fprintf ppf "@}"
+        done;
+        Format.fprintf ppf "@}@,"
+    | _ ->
+        (* Multi-line error *)
+        Misc.pp_two_columns ~sep:"|" ~max_lines ppf
+        @@ List.map (fun (line, line_nb, line_start_cnum) ->
+          let line = String.mapi (fun i car ->
+            if ISet.mem iset ~pos:(line_start_cnum + i) then car else '.'
+          ) line in
+          (line_nb, line)
+        ) lines
+    end;
+    Format.fprintf ppf "@]"
+
+
+
+let lines_around
+    ~(start_pos: position) ~(end_pos: position)
+    ~(seek: int -> unit)
+    ~(read_char: unit -> char option):
+  input_line list
+  =
+  seek start_pos.pos_bol;
+  let lines = ref [] in
+  let bol = ref start_pos.pos_bol in
+  let cur = ref start_pos.pos_bol in
+  let b = Buffer.create 80 in
+  let add_line () =
+    if !bol < !cur then begin
+      let text = Buffer.contents b in
+      Buffer.clear b;
+      lines := { text; start_pos = !bol } :: !lines;
+      bol := !cur
+    end
+  in
+  let rec loop () =
+    if !bol >= end_pos.pos_cnum then ()
+    else begin
+      match read_char () with
+      | None ->
+          (* end of input *)
+          add_line ()
+      | Some c ->
+          incr cur;
+          match c with
+          | '\r' -> loop ()
+          | '\n' -> add_line (); loop ()
+          | _ -> Buffer.add_char b c; loop ()
+    end
+  in
+  loop ();
+  List.rev !lines
+
+(* Try to get lines from a lexbuf *)
+let lines_around_from_lexbuf
+    ~(start_pos: position) ~(end_pos: position)
+    (lb: lexbuf):
+  input_line list
+  =
+  (* Converts a global position to one that is relative to the lexing buffer *)
+  let rel n = n - lb.lex_abs_pos in
+  if rel start_pos.pos_bol < 0 then begin
+    (* Do nothing if the buffer does not contain the input (because it has been
+       refilled while lexing it) *)
+    []
+  end else begin
+    let pos = ref 0 in (* relative position *)
+    let seek n = pos := rel n in
+    let read_char () =
+      if !pos >= lb.lex_buffer_len then (* end of buffer *) None
+      else
+        let c = Bytes.get lb.lex_buffer !pos in
+        incr pos; Some c
+    in
+    lines_around ~start_pos ~end_pos ~seek ~read_char
+  end
+
+(* Attempt to get lines from the phrase buffer *)
+let lines_around_from_phrasebuf
+    ~(start_pos: position) ~(end_pos: position)
+    (pb: Buffer.t):
+  input_line list
+  =
+  let pos = ref 0 in
+  let seek n = pos := n in
+  let read_char () =
+    if !pos >= Buffer.length pb then None
+    else begin
+      let c = Buffer.nth pb !pos in
+      incr pos; Some c
+    end
+  in
+  lines_around ~start_pos ~end_pos ~seek ~read_char
+
+(* Get lines from a file *)
+let lines_around_from_file
+    ~(start_pos: position) ~(end_pos: position)
+    (filename: string):
+  input_line list
+  =
+  try
+    let cin = open_in_bin filename in
+    let read_char () =
+      try Some (input_char cin) with End_of_file -> None
+    in
+    let lines =
+      lines_around ~start_pos ~end_pos ~seek:(seek_in cin) ~read_char
+    in
+    close_in cin;
+    lines
+  with Sys_error _ -> []
+
+(* A [get_lines] function for [highlight_quote] that reads from the current
+   input.
+
+   It first tries to read from [!input_lexbuf], then if that fails (because the
+   lexbuf no longer contains the input we want), it reads from [!input_name]
+   directly *)
+let lines_around_from_current_input ~start_pos ~end_pos =
+  (* Be a bit defensive, and do not try to open one of the possible
+     [!input_name] values that we know do not denote valid filenames. *)
+  let file_valid = function
+    | "//toplevel//" | "_none_" | "" -> false
+    | _ -> true
+  in
+  let from_file () =
+    if file_valid !input_name then
+      lines_around_from_file !input_name ~start_pos ~end_pos
+    else
+      []
+  in
+  match !input_lexbuf, !input_phrase_buffer, !input_name with
+  | _, Some pb, "//toplevel//" ->
+      begin match lines_around_from_phrasebuf pb ~start_pos ~end_pos with
+      | [] -> (* Could not read the input from the phrase buffer. This is likely
+                 a sign that we were given a buggy location. *)
+          []
+      | lines ->
+          lines
+      end
+  | Some lb, _, _ ->
+      begin match lines_around_from_lexbuf lb ~start_pos ~end_pos with
+      | [] -> (* The input is likely not in the lexbuf anymore *)
+          from_file ()
+      | lines ->
+          lines
+      end
+  | None, _, _ ->
+      from_file ()
+
+(******************************************************************************)
+(* Reporting errors and warnings *)
+
+type msg = (Format.formatter -> unit) loc
+
+let msg ?(loc = none) fmt =
+  Format.kdprintf (fun txt -> { loc; txt }) fmt
+
+type report_kind =
+  | Report_error
+  | Report_warning of string
+  | Report_warning_as_error of string
+  | Report_alert of string
+  | Report_alert_as_error of string
+
+type report = {
+  kind : report_kind;
+  main : msg;
+  sub : msg list;
+}
+
+type report_printer = {
+  (* The entry point *)
+  pp : report_printer ->
+    Format.formatter -> report -> unit;
+
+  pp_report_kind : report_printer -> report ->
+    Format.formatter -> report_kind -> unit;
+  pp_main_loc : report_printer -> report ->
+    Format.formatter -> t -> unit;
+  pp_main_txt : report_printer -> report ->
+    Format.formatter -> (Format.formatter -> unit) -> unit;
+  pp_submsgs : report_printer -> report ->
+    Format.formatter -> msg list -> unit;
+  pp_submsg : report_printer -> report ->
+    Format.formatter -> msg -> unit;
+  pp_submsg_loc : report_printer -> report ->
+    Format.formatter -> t -> unit;
+  pp_submsg_txt : report_printer -> report ->
+    Format.formatter -> (Format.formatter -> unit) -> unit;
+}
+
+let is_dummy_loc loc =
+  (* Fixme: this should be just [loc.loc_ghost] and the function should be
+     inlined below. However, currently, the compiler emits in some places ghost
+     locations with valid ranges that should still be printed. These locations
+     should be made non-ghost -- in the meantime we just check if the ranges are
+     valid. *)
+  loc.loc_start.pos_cnum = -1 || loc.loc_end.pos_cnum = -1
+
+(* It only makes sense to highlight (i.e. quote or underline the corresponding
+   source code) locations that originate from the current input.
+
+   As of now, this should only happen in the following cases:
+
+   - if dummy locs or ghost locs leak out of the compiler or a buggy ppx;
+
+   - more generally, if some code uses the compiler-libs API and feeds it
+   locations that do not match the current values of [!Location.input_name],
+   [!Location.input_lexbuf];
+
+   - when calling the compiler on a .ml file that contains lexer line directives
+   indicating an other file. This should happen relatively rarely in practice --
+   in particular this is not what happens when using -pp or -ppx or a ppx
+   driver.
+*)
+let is_quotable_loc loc =
+  not (is_dummy_loc loc)
+  && loc.loc_start.pos_fname = !input_name
+  && loc.loc_end.pos_fname = !input_name
+
+let error_style () =
+  match !Clflags.error_style with
+  | Some setting -> setting
+  | None -> Misc.Error_style.default_setting
+
+let batch_mode_printer : report_printer =
+  let pp_loc _self report ppf loc =
+    let tag = match report.kind with
+      | Report_warning_as_error _
+      | Report_alert_as_error _
+      | Report_error -> "error"
+      | Report_warning _
+      | Report_alert _ -> "warning"
+    in
+    let highlight ppf loc =
+      match error_style () with
+      | Misc.Error_style.Contextual ->
+          if is_quotable_loc loc then
+            highlight_quote ppf
+              ~get_lines:lines_around_from_current_input
+              tag [loc]
+      | Misc.Error_style.Short ->
+          ()
+    in
+    Format.fprintf ppf "@[<v>%a:@ %a@]" print_loc loc highlight loc
+  in
+  let pp_txt ppf txt = Format.fprintf ppf "@[%t@]" txt in
+  let pp self ppf report =
+    setup_colors ();
+    (* Make sure we keep [num_loc_lines] updated. *)
+    print_updating_num_loc_lines ppf (fun ppf () ->
+      Format.fprintf ppf "@[<v>%a%a: %a%a@]@."
+      (self.pp_main_loc self report) report.main.loc
+      (self.pp_report_kind self report) report.kind
+      (self.pp_main_txt self report) report.main.txt
+      (self.pp_submsgs self report) report.sub
+    ) ()
+  in
+  let pp_report_kind _self _ ppf = function
+    | Report_error -> Format.fprintf ppf "@{<error>Error@}"
+    | Report_warning w -> Format.fprintf ppf "@{<warning>Warning@} %s" w
+    | Report_warning_as_error w ->
+        Format.fprintf ppf "@{<error>Error@} (warning %s)" w
+    | Report_alert w -> Format.fprintf ppf "@{<warning>Alert@} %s" w
+    | Report_alert_as_error w ->
+        Format.fprintf ppf "@{<error>Error@} (alert %s)" w
+  in
+  let pp_main_loc self report ppf loc =
+    pp_loc self report ppf loc
+  in
+  let pp_main_txt _self _ ppf txt =
+    pp_txt ppf txt
+  in
+  let pp_submsgs self report ppf msgs =
+    List.iter (fun msg ->
+      Format.fprintf ppf "@,%a" (self.pp_submsg self report) msg
+    ) msgs
+  in
+  let pp_submsg self report ppf { loc; txt } =
+    Format.fprintf ppf "@[%a  %a@]"
+      (self.pp_submsg_loc self report) loc
+      (self.pp_submsg_txt self report) txt
+  in
+  let pp_submsg_loc self report ppf loc =
+    if not loc.loc_ghost then
+      pp_loc self report ppf loc
+  in
+  let pp_submsg_txt _self _ ppf loc =
+    pp_txt ppf loc
+  in
+  { pp; pp_report_kind; pp_main_loc; pp_main_txt;
+    pp_submsgs; pp_submsg; pp_submsg_loc; pp_submsg_txt }
+
+let terminfo_toplevel_printer (lb: lexbuf): report_printer =
+  let pp self ppf err =
+    setup_colors ();
+    (* Highlight all toplevel locations of the report, instead of displaying
+       the main location. Do it now instead of in [pp_main_loc], to avoid
+       messing with Format boxes. *)
+    let sub_locs = List.map (fun { loc; _ } -> loc) err.sub in
+    let all_locs = err.main.loc :: sub_locs in
+    let locs_highlighted = List.filter is_quotable_loc all_locs in
+    highlight_terminfo lb ppf locs_highlighted;
+    batch_mode_printer.pp self ppf err
+  in
+  let pp_main_loc _ _ _ _ = () in
+  let pp_submsg_loc _ _ ppf loc =
+    if not loc.loc_ghost then
+      Format.fprintf ppf "%a:@ " print_loc loc in
+  { batch_mode_printer with pp; pp_main_loc; pp_submsg_loc }
+
+let best_toplevel_printer () =
+  setup_terminal ();
+  match !status, !input_lexbuf with
+  | Terminfo.Good_term, Some lb ->
+      terminfo_toplevel_printer lb
+  | _, _ ->
+      batch_mode_printer
+
+(* Creates a printer for the current input *)
+let default_report_printer () : report_printer =
+  if !input_name = "//toplevel//" then
+    best_toplevel_printer ()
+  else
+    batch_mode_printer
+
+let report_printer = ref default_report_printer
+
+let print_report ppf report =
+  let printer = !report_printer () in
+  printer.pp printer ppf report
+
+(******************************************************************************)
+(* Reporting errors *)
+
+type error = report
+
+let report_error ppf err =
+  print_report ppf err
+
+let mkerror loc sub txt =
+  { kind = Report_error; main = { loc; txt }; sub }
+
+let errorf ?(loc = none) ?(sub = []) =
+  Format.kdprintf (mkerror loc sub)
+
+let error ?(loc = none) ?(sub = []) msg_str =
+  mkerror loc sub (fun ppf -> Format.pp_print_string ppf msg_str)
+
+let error_of_printer ?(loc = none) ?(sub = []) pp x =
+  mkerror loc sub (fun ppf -> pp ppf x)
+
+let error_of_printer_file print x =
+  error_of_printer ~loc:(in_file !input_name) print x
+
+(******************************************************************************)
+(* Reporting warnings: generating a report from a warning number using the
+   information in [Warnings] + convenience functions. *)
+
+let default_warning_alert_reporter report mk (loc: t) w : report option =
+  match report w with
+  | `Inactive -> None
+  | `Active { Warnings.id; message; is_error; sub_locs } ->
+      let msg_of_str str = fun ppf -> Format.pp_print_string ppf str in
+      let kind = mk is_error id in
+      let main = { loc; txt = msg_of_str message } in
+      let sub = List.map (fun (loc, sub_message) ->
+        { loc; txt = msg_of_str sub_message }
+      ) sub_locs in
+      Some { kind; main; sub }
+
+
+let default_warning_reporter =
+  default_warning_alert_reporter
+    Warnings.report
+    (fun is_error id ->
+       if is_error then Report_warning_as_error id
+       else Report_warning id
+    )
+
+let warning_reporter = ref default_warning_reporter
+let report_warning loc w = !warning_reporter loc w
+
+let formatter_for_warnings = ref Format.err_formatter
+
+let print_warning loc ppf w =
+  match report_warning loc w with
+  | None -> ()
+  | Some report -> print_report ppf report
+
+let prerr_warning loc w = print_warning loc !formatter_for_warnings w
+
+let default_alert_reporter =
+  default_warning_alert_reporter
+    Warnings.report_alert
+    (fun is_error id ->
+       if is_error then Report_alert_as_error id
+       else Report_alert id
+    )
+
+let alert_reporter = ref default_alert_reporter
+let report_alert loc w = !alert_reporter loc w
+
+let print_alert loc ppf w =
+  match report_alert loc w with
+  | None -> ()
+  | Some report -> print_report ppf report
+
+let prerr_alert loc w = print_alert loc !formatter_for_warnings w
+
+let alert ?(def = none) ?(use = none) ~kind loc message =
+  prerr_alert loc {Warnings.kind; message; def; use}
+
+let deprecated ?def ?use loc message =
+  alert ?def ?use ~kind:"deprecated" loc message
+
+(******************************************************************************)
+(* Reporting errors on exceptions *)
+
+let error_of_exn : (exn -> error option) list ref = ref []
+
+let register_error_of_exn f = error_of_exn := f :: !error_of_exn
+
+exception Already_displayed_error = Warnings.Errors
+
+let error_of_exn exn =
+  match exn with
+  | Already_displayed_error -> Some `Already_displayed
+  | _ ->
+     let rec loop = function
+       | [] -> None
+       | f :: rest ->
+          match f exn with
+          | Some error -> Some (`Ok error)
+          | None -> loop rest
+     in
+     loop !error_of_exn
+
+let () =
+  register_error_of_exn
+    (function
+      | Sys_error msg ->
+          Some (errorf ~loc:(in_file !input_name) "I/O error: %s" msg)
+      | _ -> None
+    )
+
+external reraise : exn -> 'a = "%reraise"
+
+let report_exception ppf exn =
+  let rec loop n exn =
+    match error_of_exn exn with
+    | None -> reraise exn
+    | Some `Already_displayed -> ()
+    | Some (`Ok err) -> report_error ppf err
+    | exception exn when n > 0 -> loop (n-1) exn
+  in
+  loop 5 exn
+
+exception Error of error
+
+let () =
+  register_error_of_exn
+    (function
+      | Error e -> Some e
+      | _ -> None
+    )
+
+let raise_errorf ?(loc = none) ?(sub = []) =
+  Format.kdprintf (fun txt -> raise (Error (mkerror loc sub txt)))
diff --git a/upstream/ocaml_412/parsing/location.mli b/upstream/ocaml_412/parsing/location.mli
new file mode 100644
index 0000000..ecf39b2
--- /dev/null
+++ b/upstream/ocaml_412/parsing/location.mli
@@ -0,0 +1,287 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** {1 Source code locations (ranges of positions), used in parsetree}
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Format
+
+type t = Warnings.loc = {
+  loc_start: Lexing.position;
+  loc_end: Lexing.position;
+  loc_ghost: bool;
+}
+
+(** Note on the use of Lexing.position in this module.
+   If [pos_fname = ""], then use [!input_name] instead.
+   If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and
+     re-parse the file to get the line and character numbers.
+   Else all fields are correct.
+*)
+
+val none : t
+(** An arbitrary value of type [t]; describes an empty ghost range. *)
+
+val is_none : t -> bool
+(** True for [Location.none], false any other location *)
+
+val in_file : string -> t
+(** Return an empty ghost range located in a given file. *)
+
+val init : Lexing.lexbuf -> string -> unit
+(** Set the file name and line number of the [lexbuf] to be the start
+    of the named file. *)
+
+val curr : Lexing.lexbuf -> t
+(** Get the location of the current token from the [lexbuf]. *)
+
+val symbol_rloc: unit -> t
+val symbol_gloc: unit -> t
+
+(** [rhs_loc n] returns the location of the symbol at position [n], starting
+  at 1, in the current parser rule. *)
+val rhs_loc: int -> t
+
+val rhs_interval: int -> int -> t
+
+val get_pos_info: Lexing.position -> string * int * int
+(** file, line, char *)
+
+type 'a loc = {
+  txt : 'a;
+  loc : t;
+}
+
+val mknoloc : 'a -> 'a loc
+val mkloc : 'a -> t -> 'a loc
+
+
+(** {1 Input info} *)
+
+val input_name: string ref
+val input_lexbuf: Lexing.lexbuf option ref
+
+(* This is used for reporting errors coming from the toplevel.
+
+   When running a toplevel session (i.e. when [!input_name] is "//toplevel//"),
+   [!input_phrase_buffer] should be [Some buf] where [buf] contains the last
+   toplevel phrase. *)
+val input_phrase_buffer: Buffer.t option ref
+
+
+(** {1 Toplevel-specific functions} *)
+
+val echo_eof: unit -> unit
+val reset: unit -> unit
+
+
+(** {1 Printing locations} *)
+
+val rewrite_absolute_path: string -> string
+    (** rewrite absolute path to honor the BUILD_PATH_PREFIX_MAP
+        variable (https://reproducible-builds.org/specs/build-path-prefix-map/)
+        if it is set. *)
+
+val absolute_path: string -> string
+
+val show_filename: string -> string
+    (** In -absname mode, return the absolute path for this filename.
+        Otherwise, returns the filename unchanged. *)
+
+val print_filename: formatter -> string -> unit
+
+val print_loc: formatter -> t -> unit
+val print_locs: formatter -> t list -> unit
+
+
+(** {1 Toplevel-specific location highlighting} *)
+
+val highlight_terminfo:
+  Lexing.lexbuf -> formatter -> t list -> unit
+
+
+(** {1 Reporting errors and warnings} *)
+
+(** {2 The type of reports and report printers} *)
+
+type msg = (Format.formatter -> unit) loc
+
+val msg: ?loc:t -> ('a, Format.formatter, unit, msg) format4 -> 'a
+
+type report_kind =
+  | Report_error
+  | Report_warning of string
+  | Report_warning_as_error of string
+  | Report_alert of string
+  | Report_alert_as_error of string
+
+type report = {
+  kind : report_kind;
+  main : msg;
+  sub : msg list;
+}
+
+type report_printer = {
+  (* The entry point *)
+  pp : report_printer ->
+    Format.formatter -> report -> unit;
+
+  pp_report_kind : report_printer -> report ->
+    Format.formatter -> report_kind -> unit;
+  pp_main_loc : report_printer -> report ->
+    Format.formatter -> t -> unit;
+  pp_main_txt : report_printer -> report ->
+    Format.formatter -> (Format.formatter -> unit) -> unit;
+  pp_submsgs : report_printer -> report ->
+    Format.formatter -> msg list -> unit;
+  pp_submsg : report_printer -> report ->
+    Format.formatter -> msg -> unit;
+  pp_submsg_loc : report_printer -> report ->
+    Format.formatter -> t -> unit;
+  pp_submsg_txt : report_printer -> report ->
+    Format.formatter -> (Format.formatter -> unit) -> unit;
+}
+(** A printer for [report]s, defined using open-recursion.
+    The goal is to make it easy to define new printers by re-using code from
+    existing ones.
+*)
+
+(** {2 Report printers used in the compiler} *)
+
+val batch_mode_printer: report_printer
+
+val terminfo_toplevel_printer: Lexing.lexbuf -> report_printer
+
+val best_toplevel_printer: unit -> report_printer
+(** Detects the terminal capabilities and selects an adequate printer *)
+
+(** {2 Printing a [report]} *)
+
+val print_report: formatter -> report -> unit
+(** Display an error or warning report. *)
+
+val report_printer: (unit -> report_printer) ref
+(** Hook for redefining the printer of reports.
+
+    The hook is a [unit -> report_printer] and not simply a [report_printer]:
+    this is useful so that it can detect the type of the output (a file, a
+    terminal, ...) and select a printer accordingly. *)
+
+val default_report_printer: unit -> report_printer
+(** Original report printer for use in hooks. *)
+
+
+(** {1 Reporting warnings} *)
+
+(** {2 Converting a [Warnings.t] into a [report]} *)
+
+val report_warning: t -> Warnings.t -> report option
+(** [report_warning loc w] produces a report for the given warning [w], or
+   [None] if the warning is not to be printed. *)
+
+val warning_reporter: (t -> Warnings.t -> report option) ref
+(** Hook for intercepting warnings. *)
+
+val default_warning_reporter: t -> Warnings.t -> report option
+(** Original warning reporter for use in hooks. *)
+
+(** {2 Printing warnings} *)
+
+val formatter_for_warnings : formatter ref
+
+val print_warning: t -> formatter -> Warnings.t -> unit
+(** Prints a warning. This is simply the composition of [report_warning] and
+   [print_report]. *)
+
+val prerr_warning: t -> Warnings.t -> unit
+(** Same as [print_warning], but uses [!formatter_for_warnings] as output
+   formatter. *)
+
+(** {1 Reporting alerts} *)
+
+(** {2 Converting an [Alert.t] into a [report]} *)
+
+val report_alert: t -> Warnings.alert -> report option
+(** [report_alert loc w] produces a report for the given alert [w], or
+   [None] if the alert is not to be printed. *)
+
+val alert_reporter: (t -> Warnings.alert -> report option) ref
+(** Hook for intercepting alerts. *)
+
+val default_alert_reporter: t -> Warnings.alert -> report option
+(** Original alert reporter for use in hooks. *)
+
+(** {2 Printing alerts} *)
+
+val print_alert: t -> formatter -> Warnings.alert -> unit
+(** Prints an alert. This is simply the composition of [report_alert] and
+   [print_report]. *)
+
+val prerr_alert: t -> Warnings.alert -> unit
+(** Same as [print_alert], but uses [!formatter_for_warnings] as output
+   formatter. *)
+
+val deprecated: ?def:t -> ?use:t -> t -> string -> unit
+(** Prints a deprecation alert. *)
+
+val alert: ?def:t -> ?use:t -> kind:string -> t -> string -> unit
+(** Prints an arbitrary alert. *)
+
+
+(** {1 Reporting errors} *)
+
+type error = report
+(** An [error] is a [report] which [report_kind] must be [Report_error]. *)
+
+val error: ?loc:t -> ?sub:msg list -> string -> error
+
+val errorf: ?loc:t -> ?sub:msg list ->
+  ('a, Format.formatter, unit, error) format4 -> 'a
+
+val error_of_printer: ?loc:t -> ?sub:msg list ->
+  (formatter -> 'a -> unit) -> 'a -> error
+
+val error_of_printer_file: (formatter -> 'a -> unit) -> 'a -> error
+
+
+(** {1 Automatically reporting errors for raised exceptions} *)
+
+val register_error_of_exn: (exn -> error option) -> unit
+(** Each compiler module which defines a custom type of exception
+    which can surface as a user-visible error should register
+    a "printer" for this exception using [register_error_of_exn].
+    The result of the printer is an [error] value containing
+    a location, a message, and optionally sub-messages (each of them
+    being located as well). *)
+
+val error_of_exn: exn -> [ `Ok of error | `Already_displayed ] option
+
+exception Error of error
+(** Raising [Error e] signals an error [e]; the exception will be caught and the
+   error will be printed. *)
+
+exception Already_displayed_error
+(** Raising [Already_displayed_error] signals an error which has already been
+   printed. The exception will be caught, but nothing will be printed *)
+
+val raise_errorf: ?loc:t -> ?sub:msg list ->
+  ('a, Format.formatter, unit, 'b) format4 -> 'a
+
+val report_exception: formatter -> exn -> unit
+(** Reraise the exception if it is unknown. *)
diff --git a/upstream/ocaml_412/parsing/longident.ml b/upstream/ocaml_412/parsing/longident.ml
new file mode 100644
index 0000000..eaafb02
--- /dev/null
+++ b/upstream/ocaml_412/parsing/longident.ml
@@ -0,0 +1,50 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t =
+    Lident of string
+  | Ldot of t * string
+  | Lapply of t * t
+
+let rec flat accu = function
+    Lident s -> s :: accu
+  | Ldot(lid, s) -> flat (s :: accu) lid
+  | Lapply(_, _) -> Misc.fatal_error "Longident.flat"
+
+let flatten lid = flat [] lid
+
+let last = function
+    Lident s -> s
+  | Ldot(_, s) -> s
+  | Lapply(_, _) -> Misc.fatal_error "Longident.last"
+
+
+let rec split_at_dots s pos =
+  try
+    let dot = String.index_from s pos '.' in
+    String.sub s pos (dot - pos) :: split_at_dots s (dot + 1)
+  with Not_found ->
+    [String.sub s pos (String.length s - pos)]
+
+let unflatten l =
+  match l with
+  | [] -> None
+  | hd :: tl -> Some (List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl)
+
+let parse s =
+  match unflatten (split_at_dots s 0) with
+  | None -> Lident ""  (* should not happen, but don't put assert false
+                          so as not to crash the toplevel (see Genprintval) *)
+  | Some v -> v
diff --git a/upstream/ocaml_412/parsing/longident.mli b/upstream/ocaml_412/parsing/longident.mli
new file mode 100644
index 0000000..0708630
--- /dev/null
+++ b/upstream/ocaml_412/parsing/longident.mli
@@ -0,0 +1,60 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Long identifiers, used in parsetree.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type t =
+    Lident of string
+  | Ldot of t * string
+  | Lapply of t * t
+
+val flatten: t -> string list
+val unflatten: string list -> t option
+(** For a non-empty list [l], [unflatten l] is [Some lid] where [lid] is
+    the long identifier created by concatenating the elements of [l]
+    with [Ldot].
+    [unflatten []] is [None].
+*)
+
+val last: t -> string
+val parse: string -> t
+[@@deprecated "this function may misparse its input,\n\
+use \"Parse.longident\" or \"Longident.unflatten\""]
+(**
+
+   This function is broken on identifiers that are not just "Word.Word.word";
+   for example, it returns incorrect results on infix operators
+   and extended module paths.
+
+   If you want to generate long identifiers that are a list of
+   dot-separated identifiers, the function {!unflatten} is safer and faster.
+   {!unflatten} is available since OCaml 4.06.0.
+
+   If you want to parse any identifier correctly, use the long-identifiers
+   functions from the {!Parse} module, in particular {!Parse.longident}.
+   They are available since OCaml 4.11, and also provide proper
+   input-location support.
+
+*)
+
+
+
+(** To print a longident, see {!Pprintast.longident}, using
+    {!Format.asprintf} to convert to a string. *)
diff --git a/upstream/ocaml_412/parsing/parse.ml b/upstream/ocaml_412/parsing/parse.ml
new file mode 100644
index 0000000..b0cee44
--- /dev/null
+++ b/upstream/ocaml_412/parsing/parse.ml
@@ -0,0 +1,173 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Entry points in the parser *)
+
+(* Skip tokens to the end of the phrase *)
+
+let last_token = ref Parser.EOF
+
+let token lexbuf =
+  let token = Lexer.token lexbuf in
+  last_token := token;
+  token
+
+let rec skip_phrase lexbuf =
+  match token lexbuf with
+  | Parser.SEMISEMI | Parser.EOF -> ()
+  | _ -> skip_phrase lexbuf
+  | exception (Lexer.Error (Lexer.Unterminated_comment _, _)
+              | Lexer.Error (Lexer.Unterminated_string, _)
+              | Lexer.Error (Lexer.Reserved_sequence _, _)
+              | Lexer.Error (Lexer.Unterminated_string_in_comment _, _)
+              | Lexer.Error (Lexer.Illegal_character _, _)) ->
+      skip_phrase lexbuf
+
+let maybe_skip_phrase lexbuf =
+  match !last_token with
+  | Parser.SEMISEMI | Parser.EOF -> ()
+  | _ -> skip_phrase lexbuf
+
+let wrap parsing_fun lexbuf =
+  try
+    Docstrings.init ();
+    Lexer.init ();
+    let ast = parsing_fun lexbuf in
+    Parsing.clear_parser();
+    Docstrings.warn_bad_docstrings ();
+    last_token := Parser.EOF;
+    ast
+  with
+  | Lexer.Error(Lexer.Illegal_character _, _) as err
+    when !Location.input_name = "//toplevel//"->
+      skip_phrase lexbuf;
+      raise err
+  | Syntaxerr.Error _ as err
+    when !Location.input_name = "//toplevel//" ->
+      maybe_skip_phrase lexbuf;
+      raise err
+  | Parsing.Parse_error | Syntaxerr.Escape_error ->
+      let loc = Location.curr lexbuf in
+      if !Location.input_name = "//toplevel//"
+      then maybe_skip_phrase lexbuf;
+      raise(Syntaxerr.Error(Syntaxerr.Other loc))
+
+let rec loop lexbuf in_error checkpoint =
+  let module I = Parser.MenhirInterpreter in
+  match checkpoint with
+  | I.InputNeeded _env ->
+      let triple =
+        if in_error then
+          (* The parser detected an error.
+             At this point we don't want to consume input anymore. In the
+             top-level, it would translate into waiting for the user to type
+             something, just to raise an error at some earlier position, rather
+             than just raising the error immediately.
+
+             This worked before with yacc because, AFAICT (@let-def):
+             - yacc eagerly reduces "default reduction" (when the next action
+               is to reduce the same production no matter what token is read,
+               yacc reduces it immediately rather than waiting for that token
+               to be read)
+             - error productions in OCaml grammar are always in a position that
+               allows default reduction ("error" symbol is the last producer,
+               and the lookahead token will not be used to disambiguate between
+               two possible error rules)
+             This solution is fragile because it relies on an optimization
+             (default reduction), that changes the semantics of the parser the
+             way it is implemented in Yacc (an optimization that changes
+             semantics? hmmmm).
+
+             Rather than relying on implementation details of the parser, when
+             an error is detected in this loop we stop looking at the input and
+             fill the parser with EOF tokens.
+             The skip_phrase logic will resynchronize the input stream by
+             looking for the next ';;'.  *)
+          (Parser.EOF, lexbuf.Lexing.lex_curr_p, lexbuf.Lexing.lex_curr_p)
+        else
+          let token = token lexbuf in
+          (token, lexbuf.Lexing.lex_start_p, lexbuf.Lexing.lex_curr_p)
+      in
+      let checkpoint = I.offer checkpoint triple in
+      loop lexbuf in_error checkpoint
+  | I.Shifting _ | I.AboutToReduce _ ->
+      loop lexbuf in_error (I.resume checkpoint)
+  | I.Accepted v -> v
+  | I.Rejected -> raise Parser.Error
+  | I.HandlingError _ ->
+      loop lexbuf true (I.resume checkpoint)
+
+let wrap_menhir entry lexbuf =
+  let initial = entry lexbuf.Lexing.lex_curr_p in
+  wrap (fun lexbuf -> loop lexbuf false initial) lexbuf
+
+let implementation = wrap_menhir Parser.Incremental.implementation
+and interface = wrap_menhir Parser.Incremental.interface
+and toplevel_phrase = wrap_menhir Parser.Incremental.toplevel_phrase
+and use_file = wrap_menhir Parser.Incremental.use_file
+and core_type = wrap_menhir Parser.Incremental.parse_core_type
+and expression = wrap_menhir Parser.Incremental.parse_expression
+and pattern = wrap_menhir Parser.Incremental.parse_pattern
+
+let longident = wrap_menhir Parser.Incremental.parse_any_longident
+let val_ident = wrap_menhir Parser.Incremental.parse_val_longident
+let constr_ident= wrap_menhir Parser.Incremental.parse_constr_longident
+let extended_module_path =
+  wrap_menhir Parser.Incremental.parse_mod_ext_longident
+let simple_module_path = wrap_menhir Parser.Incremental.parse_mod_longident
+let type_ident = wrap_menhir Parser.Incremental.parse_mty_longident
+
+(* Error reporting for Syntaxerr *)
+(* The code has been moved here so that one can reuse Pprintast.tyvar *)
+
+let prepare_error err =
+  let open Syntaxerr in
+  match err with
+  | Unclosed(opening_loc, opening, closing_loc, closing) ->
+      Location.errorf
+        ~loc:closing_loc
+        ~sub:[
+          Location.msg ~loc:opening_loc
+            "This '%s' might be unmatched" opening
+        ]
+        "Syntax error: '%s' expected" closing
+
+  | Expecting (loc, nonterm) ->
+      Location.errorf ~loc "Syntax error: %s expected." nonterm
+  | Not_expecting (loc, nonterm) ->
+      Location.errorf ~loc "Syntax error: %s not expected." nonterm
+  | Applicative_path loc ->
+      Location.errorf ~loc
+        "Syntax error: applicative paths of the form F(X).t \
+         are not supported when the option -no-app-func is set."
+  | Variable_in_scope (loc, var) ->
+      Location.errorf ~loc
+        "In this scoped type, variable %a \
+         is reserved for the local type %s."
+        Pprintast.tyvar var var
+  | Other loc ->
+      Location.errorf ~loc "Syntax error"
+  | Ill_formed_ast (loc, s) ->
+      Location.errorf ~loc
+        "broken invariant in parsetree: %s" s
+  | Invalid_package_type (loc, s) ->
+      Location.errorf ~loc "invalid package type: %s" s
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Syntaxerr.Error err -> Some (prepare_error err)
+      | _ -> None
+    )
diff --git a/upstream/ocaml_412/parsing/parse.mli b/upstream/ocaml_412/parsing/parse.mli
new file mode 100644
index 0000000..8669a4b
--- /dev/null
+++ b/upstream/ocaml_412/parsing/parse.mli
@@ -0,0 +1,108 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Entry points in the parser
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+val implementation : Lexing.lexbuf -> Parsetree.structure
+val interface : Lexing.lexbuf -> Parsetree.signature
+val toplevel_phrase : Lexing.lexbuf -> Parsetree.toplevel_phrase
+val use_file : Lexing.lexbuf -> Parsetree.toplevel_phrase list
+val core_type : Lexing.lexbuf -> Parsetree.core_type
+val expression : Lexing.lexbuf -> Parsetree.expression
+val pattern : Lexing.lexbuf -> Parsetree.pattern
+
+(** The functions below can be used to parse Longident safely. *)
+
+val longident: Lexing.lexbuf -> Longident.t
+(**
+   The function [longident] is guaranteed to parse all subclasses
+   of {!Longident.t} used in OCaml: values, constructors, simple or extended
+   module paths, and types or module types.
+
+   However, this function accepts inputs which are not accepted by the
+   compiler, because they combine functor applications and infix operators.
+   In valid OCaml syntax, only value-level identifiers may end with infix
+   operators [Foo.( + )].
+   Moreover, in value-level identifiers the module path [Foo] must be simple
+   ([M.N] rather than [F(X)]): functor applications may only appear in
+   type-level identifiers.
+   As a consequence, a path such as [F(X).( + )] is not a valid OCaml
+   identifier; but it is accepted by this function.
+*)
+
+(** The next functions are specialized to a subclass of {!Longident.t} *)
+
+val val_ident: Lexing.lexbuf -> Longident.t
+(**
+   This function parses a syntactically valid path for a value. For instance,
+   [x], [M.x], and [(+.)] are valid. Contrarily, [M.A], [F(X).x], and [true]
+   are rejected.
+
+   Longident for OCaml's value cannot contain functor application.
+   The last component of the {!Longident.t} is not capitalized,
+   but can be an operator [A.Path.To.(.%.%.(;..)<-)]
+*)
+
+val constr_ident: Lexing.lexbuf -> Longident.t
+(**
+   This function parses a syntactically valid path for a variant constructor.
+   For instance, [A], [M.A] and [M.(::)] are valid, but both [M.a]
+   and [F(X).A] are rejected.
+
+   Longident for OCaml's variant constructors cannot contain functor
+   application.
+   The last component of the {!Longident.t} is capitalized,
+   or it may be one the special constructors: [true],[false],[()],[[]],[(::)].
+   Among those special constructors, only [(::)] can be prefixed by a module
+   path ([A.B.C.(::)]).
+*)
+
+
+val simple_module_path: Lexing.lexbuf -> Longident.t
+(**
+   This function parses a syntactically valid path for a module.
+   For instance, [A], and [M.A] are valid, but both [M.a]
+   and [F(X).A] are rejected.
+
+   Longident for OCaml's module cannot contain functor application.
+   The last component of the {!Longident.t} is capitalized.
+*)
+
+
+val extended_module_path: Lexing.lexbuf -> Longident.t
+(**
+   This function parse syntactically valid path for an extended module.
+   For instance, [A.B] and [F(A).B] are valid. Contrarily,
+   [(.%())] or [[]] are both rejected.
+
+   The last component of the {!Longident.t} is capitalized.
+
+*)
+
+val type_ident: Lexing.lexbuf -> Longident.t
+(**
+   This function parse syntactically valid path for a type or a module type.
+   For instance, [A], [t], [M.t] and [F(X).t] are valid. Contrarily,
+   [(.%())] or [[]] are both rejected.
+
+   In path for type and module types, only operators and special constructors
+   are rejected.
+
+*)
diff --git a/upstream/ocaml_412/parsing/parser.mly b/upstream/ocaml_412/parsing/parser.mly
new file mode 100644
index 0000000..1fe25c8
--- /dev/null
+++ b/upstream/ocaml_412/parsing/parser.mly
@@ -0,0 +1,3777 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 1996 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* The parser definition */
+
+%{
+
+open Asttypes
+open Longident
+open Parsetree
+open Ast_helper
+open Docstrings
+open Docstrings.WithMenhir
+
+let mkloc = Location.mkloc
+let mknoloc = Location.mknoloc
+
+let make_loc (startpos, endpos) = {
+  Location.loc_start = startpos;
+  Location.loc_end = endpos;
+  Location.loc_ghost = false;
+}
+
+let ghost_loc (startpos, endpos) = {
+  Location.loc_start = startpos;
+  Location.loc_end = endpos;
+  Location.loc_ghost = true;
+}
+
+let mktyp ~loc ?attrs d = Typ.mk ~loc:(make_loc loc) ?attrs d
+let mkpat ~loc d = Pat.mk ~loc:(make_loc loc) d
+let mkexp ~loc d = Exp.mk ~loc:(make_loc loc) d
+let mkmty ~loc ?attrs d = Mty.mk ~loc:(make_loc loc) ?attrs d
+let mksig ~loc d = Sig.mk ~loc:(make_loc loc) d
+let mkmod ~loc ?attrs d = Mod.mk ~loc:(make_loc loc) ?attrs d
+let mkstr ~loc d = Str.mk ~loc:(make_loc loc) d
+let mkclass ~loc ?attrs d = Cl.mk ~loc:(make_loc loc) ?attrs d
+let mkcty ~loc ?attrs d = Cty.mk ~loc:(make_loc loc) ?attrs d
+
+let pstr_typext (te, ext) =
+  (Pstr_typext te, ext)
+let pstr_primitive (vd, ext) =
+  (Pstr_primitive vd, ext)
+let pstr_type ((nr, ext), tys) =
+  (Pstr_type (nr, tys), ext)
+let pstr_exception (te, ext) =
+  (Pstr_exception te, ext)
+let pstr_include (body, ext) =
+  (Pstr_include body, ext)
+let pstr_recmodule (ext, bindings) =
+  (Pstr_recmodule bindings, ext)
+
+let psig_typext (te, ext) =
+  (Psig_typext te, ext)
+let psig_value (vd, ext) =
+  (Psig_value vd, ext)
+let psig_type ((nr, ext), tys) =
+  (Psig_type (nr, tys), ext)
+let psig_typesubst ((nr, ext), tys) =
+  assert (nr = Recursive); (* see [no_nonrec_flag] *)
+  (Psig_typesubst tys, ext)
+let psig_exception (te, ext) =
+  (Psig_exception te, ext)
+let psig_include (body, ext) =
+  (Psig_include body, ext)
+
+let mkctf ~loc ?attrs ?docs d =
+  Ctf.mk ~loc:(make_loc loc) ?attrs ?docs d
+let mkcf ~loc ?attrs ?docs d =
+  Cf.mk ~loc:(make_loc loc) ?attrs ?docs d
+
+let mkrhs rhs loc = mkloc rhs (make_loc loc)
+let ghrhs rhs loc = mkloc rhs (ghost_loc loc)
+
+let push_loc x acc =
+  if x.Location.loc_ghost
+  then acc
+  else x :: acc
+
+let reloc_pat ~loc x =
+  { x with ppat_loc = make_loc loc;
+           ppat_loc_stack = push_loc x.ppat_loc x.ppat_loc_stack };;
+let reloc_exp ~loc x =
+  { x with pexp_loc = make_loc loc;
+           pexp_loc_stack = push_loc x.pexp_loc x.pexp_loc_stack };;
+let reloc_typ ~loc x =
+  { x with ptyp_loc = make_loc loc;
+           ptyp_loc_stack = push_loc x.ptyp_loc x.ptyp_loc_stack };;
+
+let mkexpvar ~loc (name : string) =
+  mkexp ~loc (Pexp_ident(mkrhs (Lident name) loc))
+
+let mkoperator =
+  mkexpvar
+
+let mkpatvar ~loc name =
+  mkpat ~loc (Ppat_var (mkrhs name loc))
+
+(*
+  Ghost expressions and patterns:
+  expressions and patterns that do not appear explicitly in the
+  source file they have the loc_ghost flag set to true.
+  Then the profiler will not try to instrument them and the
+  -annot option will not try to display their type.
+
+  Every grammar rule that generates an element with a location must
+  make at most one non-ghost element, the topmost one.
+
+  How to tell whether your location must be ghost:
+  A location corresponds to a range of characters in the source file.
+  If the location contains a piece of code that is syntactically
+  valid (according to the documentation), and corresponds to the
+  AST node, then the location must be real; in all other cases,
+  it must be ghost.
+*)
+let ghexp ~loc d = Exp.mk ~loc:(ghost_loc loc) d
+let ghpat ~loc d = Pat.mk ~loc:(ghost_loc loc) d
+let ghtyp ~loc d = Typ.mk ~loc:(ghost_loc loc) d
+let ghloc ~loc d = { txt = d; loc = ghost_loc loc }
+let ghstr ~loc d = Str.mk ~loc:(ghost_loc loc) d
+let ghsig ~loc d = Sig.mk ~loc:(ghost_loc loc) d
+
+let mkinfix arg1 op arg2 =
+  Pexp_apply(op, [Nolabel, arg1; Nolabel, arg2])
+
+let neg_string f =
+  if String.length f > 0 && f.[0] = '-'
+  then String.sub f 1 (String.length f - 1)
+  else "-" ^ f
+
+let mkuminus ~oploc name arg =
+  match name, arg.pexp_desc with
+  | "-", Pexp_constant(Pconst_integer (n,m)) ->
+      Pexp_constant(Pconst_integer(neg_string n,m))
+  | ("-" | "-."), Pexp_constant(Pconst_float (f, m)) ->
+      Pexp_constant(Pconst_float(neg_string f, m))
+  | _ ->
+      Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg])
+
+let mkuplus ~oploc name arg =
+  let desc = arg.pexp_desc in
+  match name, desc with
+  | "+", Pexp_constant(Pconst_integer _)
+  | ("+" | "+."), Pexp_constant(Pconst_float _) -> desc
+  | _ ->
+      Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg])
+
+(* TODO define an abstraction boundary between locations-as-pairs
+   and locations-as-Location.t; it should be clear when we move from
+   one world to the other *)
+
+let mkexp_cons_desc consloc args =
+  Pexp_construct(mkrhs (Lident "::") consloc, Some args)
+let mkexp_cons ~loc consloc args =
+  mkexp ~loc (mkexp_cons_desc consloc args)
+
+let mkpat_cons_desc consloc args =
+  Ppat_construct(mkrhs (Lident "::") consloc, Some args)
+let mkpat_cons ~loc consloc args =
+  mkpat ~loc (mkpat_cons_desc consloc args)
+
+let ghexp_cons_desc consloc args =
+  Pexp_construct(ghrhs (Lident "::") consloc, Some args)
+let ghpat_cons_desc consloc args =
+  Ppat_construct(ghrhs (Lident "::") consloc, Some args)
+
+let rec mktailexp nilloc = let open Location in function
+    [] ->
+      let nil = ghloc ~loc:nilloc (Lident "[]") in
+      Pexp_construct (nil, None), nilloc
+  | e1 :: el ->
+      let exp_el, el_loc = mktailexp nilloc el in
+      let loc = (e1.pexp_loc.loc_start, snd el_loc) in
+      let arg = ghexp ~loc (Pexp_tuple [e1; ghexp ~loc:el_loc exp_el]) in
+      ghexp_cons_desc loc arg, loc
+
+let rec mktailpat nilloc = let open Location in function
+    [] ->
+      let nil = ghloc ~loc:nilloc (Lident "[]") in
+      Ppat_construct (nil, None), nilloc
+  | p1 :: pl ->
+      let pat_pl, el_loc = mktailpat nilloc pl in
+      let loc = (p1.ppat_loc.loc_start, snd el_loc) in
+      let arg = ghpat ~loc (Ppat_tuple [p1; ghpat ~loc:el_loc pat_pl]) in
+      ghpat_cons_desc loc arg, loc
+
+let mkstrexp e attrs =
+  { pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc }
+
+let mkexp_constraint ~loc e (t1, t2) =
+  match t1, t2 with
+  | Some t, None -> ghexp ~loc (Pexp_constraint(e, t))
+  | _, Some t -> ghexp ~loc (Pexp_coerce(e, t1, t))
+  | None, None -> assert false
+
+let mkexp_opt_constraint ~loc e = function
+  | None -> e
+  | Some constraint_ -> mkexp_constraint ~loc e constraint_
+
+let mkpat_opt_constraint ~loc p = function
+  | None -> p
+  | Some typ -> ghpat ~loc (Ppat_constraint(p, typ))
+
+let syntax_error () =
+  raise Syntaxerr.Escape_error
+
+let unclosed opening_name opening_loc closing_name closing_loc =
+  raise(Syntaxerr.Error(Syntaxerr.Unclosed(make_loc opening_loc, opening_name,
+                                           make_loc closing_loc, closing_name)))
+
+let expecting loc nonterm =
+    raise Syntaxerr.(Error(Expecting(make_loc loc, nonterm)))
+
+let not_expecting loc nonterm =
+    raise Syntaxerr.(Error(Not_expecting(make_loc loc, nonterm)))
+
+let dotop ~left ~right ~assign ~ext ~multi =
+  let assign = if assign then "<-" else "" in
+  let mid = if multi then ";.." else "" in
+  String.concat "" ["."; ext; left; mid; right; assign]
+let paren = "(",")"
+let brace = "{", "}"
+let bracket = "[", "]"
+let lident x =  Lident x
+let ldot x y = Ldot(x,y)
+let dotop_fun ~loc dotop =
+  ghexp ~loc (Pexp_ident (ghloc ~loc dotop))
+
+let array_function ~loc str name =
+  ghloc ~loc (Ldot(Lident str,
+                   (if !Clflags.unsafe then "unsafe_" ^ name else name)))
+
+let array_get_fun ~loc =
+  ghexp ~loc (Pexp_ident(array_function ~loc "Array" "get"))
+let string_get_fun ~loc =
+  ghexp ~loc (Pexp_ident(array_function ~loc "String" "get"))
+
+let array_set_fun ~loc =
+  ghexp ~loc (Pexp_ident(array_function ~loc "Array" "set"))
+let string_set_fun ~loc =
+  ghexp ~loc (Pexp_ident(array_function ~loc "String" "set"))
+
+let multi_indices ~loc = function
+  | [a] -> false, a
+  | l -> true, mkexp ~loc (Pexp_array l)
+
+let index_get ~loc get_fun array index =
+  let args = [Nolabel, array; Nolabel, index] in
+   mkexp ~loc (Pexp_apply(get_fun, args))
+
+let index_set ~loc set_fun array index value =
+  let args = [Nolabel, array; Nolabel, index; Nolabel, value] in
+   mkexp ~loc (Pexp_apply(set_fun, args))
+
+let array_get ~loc = index_get ~loc (array_get_fun ~loc)
+let string_get ~loc = index_get ~loc (string_get_fun ~loc)
+let dotop_get ~loc path (left,right) ext array index =
+  let multi, index = multi_indices ~loc index in
+  index_get ~loc
+    (dotop_fun ~loc (path @@ dotop ~left ~right ~ext ~multi ~assign:false))
+    array index
+
+let array_set ~loc = index_set ~loc (array_set_fun ~loc)
+let string_set ~loc = index_set ~loc (string_set_fun ~loc)
+let dotop_set ~loc path (left,right) ext array index value=
+  let multi, index = multi_indices ~loc index in
+  index_set ~loc
+    (dotop_fun ~loc (path @@ dotop ~left ~right ~ext ~multi ~assign:true))
+    array index value
+
+
+let bigarray_function ~loc str name =
+  ghloc ~loc (Ldot(Ldot(Lident "Bigarray", str), name))
+
+let bigarray_untuplify = function
+    { pexp_desc = Pexp_tuple explist; pexp_loc = _ } -> explist
+  | exp -> [exp]
+
+let bigarray_get ~loc arr arg =
+  let mkexp, ghexp = mkexp ~loc, ghexp ~loc in
+  let bigarray_function = bigarray_function ~loc in
+  let get = if !Clflags.unsafe then "unsafe_get" else "get" in
+  match bigarray_untuplify arg with
+    [c1] ->
+      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" get)),
+                       [Nolabel, arr; Nolabel, c1]))
+  | [c1;c2] ->
+      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" get)),
+                       [Nolabel, arr; Nolabel, c1; Nolabel, c2]))
+  | [c1;c2;c3] ->
+      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" get)),
+                       [Nolabel, arr; Nolabel, c1; Nolabel, c2; Nolabel, c3]))
+  | coords ->
+      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "get")),
+                       [Nolabel, arr; Nolabel, ghexp(Pexp_array coords)]))
+
+let bigarray_set ~loc arr arg newval =
+  let mkexp, ghexp = mkexp ~loc, ghexp ~loc in
+  let bigarray_function = bigarray_function ~loc in
+  let set = if !Clflags.unsafe then "unsafe_set" else "set" in
+  match bigarray_untuplify arg with
+    [c1] ->
+      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" set)),
+                       [Nolabel, arr; Nolabel, c1; Nolabel, newval]))
+  | [c1;c2] ->
+      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" set)),
+                       [Nolabel, arr; Nolabel, c1;
+                        Nolabel, c2; Nolabel, newval]))
+  | [c1;c2;c3] ->
+      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" set)),
+                       [Nolabel, arr; Nolabel, c1;
+                        Nolabel, c2; Nolabel, c3; Nolabel, newval]))
+  | coords ->
+      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "set")),
+                       [Nolabel, arr;
+                        Nolabel, ghexp(Pexp_array coords);
+                        Nolabel, newval]))
+
+let lapply ~loc p1 p2 =
+  if !Clflags.applicative_functors
+  then Lapply(p1, p2)
+  else raise (Syntaxerr.Error(
+                  Syntaxerr.Applicative_path (make_loc loc)))
+
+(* [loc_map] could be [Location.map]. *)
+let loc_map (f : 'a -> 'b) (x : 'a Location.loc) : 'b Location.loc =
+  { x with txt = f x.txt }
+
+let make_ghost x = { x with loc = { x.loc with loc_ghost = true }}
+
+let loc_last (id : Longident.t Location.loc) : string Location.loc =
+  loc_map Longident.last id
+
+let loc_lident (id : string Location.loc) : Longident.t Location.loc =
+  loc_map (fun x -> Lident x) id
+
+let exp_of_longident ~loc lid =
+  let lid = make_ghost (loc_map (fun id -> Lident (Longident.last id)) lid) in
+  ghexp ~loc (Pexp_ident lid)
+
+let exp_of_label ~loc lbl =
+  mkexp ~loc (Pexp_ident (loc_lident lbl))
+
+let pat_of_label lbl =
+  Pat.mk ~loc:lbl.loc  (Ppat_var (loc_last lbl))
+
+let mk_newtypes ~loc newtypes exp =
+  let mkexp = mkexp ~loc in
+  List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp)))
+    newtypes exp
+
+let wrap_type_annotation ~loc newtypes core_type body =
+  let mkexp, ghtyp = mkexp ~loc, ghtyp ~loc in
+  let mk_newtypes = mk_newtypes ~loc in
+  let exp = mkexp(Pexp_constraint(body,core_type)) in
+  let exp = mk_newtypes newtypes exp in
+  (exp, ghtyp(Ptyp_poly(newtypes, Typ.varify_constructors newtypes core_type)))
+
+let wrap_exp_attrs ~loc body (ext, attrs) =
+  let ghexp = ghexp ~loc in
+  (* todo: keep exact location for the entire attribute *)
+  let body = {body with pexp_attributes = attrs @ body.pexp_attributes} in
+  match ext with
+  | None -> body
+  | Some id -> ghexp(Pexp_extension (id, PStr [mkstrexp body []]))
+
+let mkexp_attrs ~loc d attrs =
+  wrap_exp_attrs ~loc (mkexp ~loc d) attrs
+
+let wrap_typ_attrs ~loc typ (ext, attrs) =
+  (* todo: keep exact location for the entire attribute *)
+  let typ = {typ with ptyp_attributes = attrs @ typ.ptyp_attributes} in
+  match ext with
+  | None -> typ
+  | Some id -> ghtyp ~loc (Ptyp_extension (id, PTyp typ))
+
+let wrap_pat_attrs ~loc pat (ext, attrs) =
+  (* todo: keep exact location for the entire attribute *)
+  let pat = {pat with ppat_attributes = attrs @ pat.ppat_attributes} in
+  match ext with
+  | None -> pat
+  | Some id -> ghpat ~loc (Ppat_extension (id, PPat (pat, None)))
+
+let mkpat_attrs ~loc d attrs =
+  wrap_pat_attrs ~loc (mkpat ~loc d) attrs
+
+let wrap_class_attrs ~loc:_ body attrs =
+  {body with pcl_attributes = attrs @ body.pcl_attributes}
+let wrap_mod_attrs ~loc:_ attrs body =
+  {body with pmod_attributes = attrs @ body.pmod_attributes}
+let wrap_mty_attrs ~loc:_ attrs body =
+  {body with pmty_attributes = attrs @ body.pmty_attributes}
+
+let wrap_str_ext ~loc body ext =
+  match ext with
+  | None -> body
+  | Some id -> ghstr ~loc (Pstr_extension ((id, PStr [body]), []))
+
+let wrap_mkstr_ext ~loc (item, ext) =
+  wrap_str_ext ~loc (mkstr ~loc item) ext
+
+let wrap_sig_ext ~loc body ext =
+  match ext with
+  | None -> body
+  | Some id -> ghsig ~loc (Psig_extension ((id, PSig [body]), []))
+
+let wrap_mksig_ext ~loc (item, ext) =
+  wrap_sig_ext ~loc (mksig ~loc item) ext
+
+let mk_quotedext ~loc (id, idloc, str, strloc, delim) =
+  let exp_id = mkloc id idloc in
+  let e = ghexp ~loc (Pexp_constant (Pconst_string (str, strloc, delim))) in
+  (exp_id, PStr [mkstrexp e []])
+
+let text_str pos = Str.text (rhs_text pos)
+let text_sig pos = Sig.text (rhs_text pos)
+let text_cstr pos = Cf.text (rhs_text pos)
+let text_csig pos = Ctf.text (rhs_text pos)
+let text_def pos =
+  List.map (fun def -> Ptop_def [def]) (Str.text (rhs_text pos))
+
+let extra_text startpos endpos text items =
+  match items with
+  | [] ->
+      let post = rhs_post_text endpos in
+      let post_extras = rhs_post_extra_text endpos in
+      text post @ text post_extras
+  | _ :: _ ->
+      let pre_extras = rhs_pre_extra_text startpos in
+      let post_extras = rhs_post_extra_text endpos in
+        text pre_extras @ items @ text post_extras
+
+let extra_str p1 p2 items = extra_text p1 p2 Str.text items
+let extra_sig p1 p2 items = extra_text p1 p2 Sig.text items
+let extra_cstr p1 p2 items = extra_text p1 p2 Cf.text items
+let extra_csig p1 p2 items = extra_text p1 p2 Ctf.text  items
+let extra_def p1 p2 items =
+  extra_text p1 p2
+    (fun txt -> List.map (fun def -> Ptop_def [def]) (Str.text txt))
+    items
+
+let extra_rhs_core_type ct ~pos =
+  let docs = rhs_info pos in
+  { ct with ptyp_attributes = add_info_attrs docs ct.ptyp_attributes }
+
+type let_binding =
+  { lb_pattern: pattern;
+    lb_expression: expression;
+    lb_attributes: attributes;
+    lb_docs: docs Lazy.t;
+    lb_text: text Lazy.t;
+    lb_loc: Location.t; }
+
+type let_bindings =
+  { lbs_bindings: let_binding list;
+    lbs_rec: rec_flag;
+    lbs_extension: string Asttypes.loc option;
+    lbs_loc: Location.t }
+
+let mklb first ~loc (p, e) attrs =
+  {
+    lb_pattern = p;
+    lb_expression = e;
+    lb_attributes = attrs;
+    lb_docs = symbol_docs_lazy loc;
+    lb_text = (if first then empty_text_lazy
+               else symbol_text_lazy (fst loc));
+    lb_loc = make_loc loc;
+  }
+
+let mklbs ~loc ext rf lb =
+  {
+    lbs_bindings = [lb];
+    lbs_rec = rf;
+    lbs_extension = ext ;
+    lbs_loc = make_loc loc;
+  }
+
+let addlb lbs lb =
+  { lbs with lbs_bindings = lb :: lbs.lbs_bindings }
+
+let val_of_let_bindings ~loc lbs =
+  let bindings =
+    List.map
+      (fun lb ->
+         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
+           ~docs:(Lazy.force lb.lb_docs)
+           ~text:(Lazy.force lb.lb_text)
+           lb.lb_pattern lb.lb_expression)
+      lbs.lbs_bindings
+  in
+  let str = mkstr ~loc (Pstr_value(lbs.lbs_rec, List.rev bindings)) in
+  match lbs.lbs_extension with
+  | None -> str
+  | Some id -> ghstr ~loc (Pstr_extension((id, PStr [str]), []))
+
+let expr_of_let_bindings ~loc lbs body =
+  let bindings =
+    List.map
+      (fun lb ->
+         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
+           lb.lb_pattern lb.lb_expression)
+      lbs.lbs_bindings
+  in
+    mkexp_attrs ~loc (Pexp_let(lbs.lbs_rec, List.rev bindings, body))
+      (lbs.lbs_extension, [])
+
+let class_of_let_bindings ~loc lbs body =
+  let bindings =
+    List.map
+      (fun lb ->
+         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
+           lb.lb_pattern lb.lb_expression)
+      lbs.lbs_bindings
+  in
+    (* Our use of let_bindings(no_ext) guarantees the following: *)
+    assert (lbs.lbs_extension = None);
+    mkclass ~loc (Pcl_let (lbs.lbs_rec, List.rev bindings, body))
+
+(* Alternatively, we could keep the generic module type in the Parsetree
+   and extract the package type during type-checking. In that case,
+   the assertions below should be turned into explicit checks. *)
+let package_type_of_module_type pmty =
+  let err loc s =
+    raise (Syntaxerr.Error (Syntaxerr.Invalid_package_type (loc, s)))
+  in
+  let map_cstr = function
+    | Pwith_type (lid, ptyp) ->
+        let loc = ptyp.ptype_loc in
+        if ptyp.ptype_params <> [] then
+          err loc "parametrized types are not supported";
+        if ptyp.ptype_cstrs <> [] then
+          err loc "constrained types are not supported";
+        if ptyp.ptype_private <> Public then
+          err loc "private types are not supported";
+
+        (* restrictions below are checked by the 'with_constraint' rule *)
+        assert (ptyp.ptype_kind = Ptype_abstract);
+        assert (ptyp.ptype_attributes = []);
+        let ty =
+          match ptyp.ptype_manifest with
+          | Some ty -> ty
+          | None -> assert false
+        in
+        (lid, ty)
+    | _ ->
+        err pmty.pmty_loc "only 'with type t =' constraints are supported"
+  in
+  match pmty with
+  | {pmty_desc = Pmty_ident lid} -> (lid, [], pmty.pmty_attributes)
+  | {pmty_desc = Pmty_with({pmty_desc = Pmty_ident lid}, cstrs)} ->
+      (lid, List.map map_cstr cstrs, pmty.pmty_attributes)
+  | _ ->
+      err pmty.pmty_loc
+        "only module type identifier and 'with type' constraints are supported"
+
+let mk_directive_arg ~loc k =
+  { pdira_desc = k;
+    pdira_loc = make_loc loc;
+  }
+
+let mk_directive ~loc name arg =
+  Ptop_dir {
+      pdir_name = name;
+      pdir_arg = arg;
+      pdir_loc = make_loc loc;
+    }
+
+%}
+
+/* Tokens */
+
+%token AMPERAMPER
+%token AMPERSAND
+%token AND
+%token AS
+%token ASSERT
+%token BACKQUOTE
+%token BANG
+%token BAR
+%token BARBAR
+%token BARRBRACKET
+%token BEGIN
+%token <char> CHAR
+%token CLASS
+%token COLON
+%token COLONCOLON
+%token COLONEQUAL
+%token COLONGREATER
+%token COMMA
+%token CONSTRAINT
+%token DO
+%token DONE
+%token DOT
+%token DOTDOT
+%token DOWNTO
+%token ELSE
+%token END
+%token EOF
+%token EQUAL
+%token EXCEPTION
+%token EXTERNAL
+%token FALSE
+%token <string * char option> FLOAT
+%token FOR
+%token FUN
+%token FUNCTION
+%token FUNCTOR
+%token GREATER
+%token GREATERRBRACE
+%token GREATERRBRACKET
+%token IF
+%token IN
+%token INCLUDE
+%token <string> INFIXOP0
+%token <string> INFIXOP1
+%token <string> INFIXOP2
+%token <string> INFIXOP3
+%token <string> INFIXOP4
+%token <string> DOTOP
+%token <string> LETOP
+%token <string> ANDOP
+%token INHERIT
+%token INITIALIZER
+%token <string * char option> INT
+%token <string> LABEL
+%token LAZY
+%token LBRACE
+%token LBRACELESS
+%token LBRACKET
+%token LBRACKETBAR
+%token LBRACKETLESS
+%token LBRACKETGREATER
+%token LBRACKETPERCENT
+%token LBRACKETPERCENTPERCENT
+%token LESS
+%token LESSMINUS
+%token LET
+%token <string> LIDENT
+%token LPAREN
+%token LBRACKETAT
+%token LBRACKETATAT
+%token LBRACKETATATAT
+%token MATCH
+%token METHOD
+%token MINUS
+%token MINUSDOT
+%token MINUSGREATER
+%token MODULE
+%token MUTABLE
+%token NEW
+%token NONREC
+%token OBJECT
+%token OF
+%token OPEN
+%token <string> OPTLABEL
+%token OR
+/* %token PARSER */
+%token PERCENT
+%token PLUS
+%token PLUSDOT
+%token PLUSEQ
+%token <string> PREFIXOP
+%token PRIVATE
+%token QUESTION
+%token QUOTE
+%token RBRACE
+%token RBRACKET
+%token REC
+%token RPAREN
+%token SEMI
+%token SEMISEMI
+%token HASH
+%token <string> HASHOP
+%token SIG
+%token STAR
+%token <string * Location.t * string option> STRING
+%token
+  <string * Location.t * string * Location.t * string option> QUOTED_STRING_EXPR
+%token
+  <string * Location.t * string * Location.t * string option> QUOTED_STRING_ITEM
+%token STRUCT
+%token THEN
+%token TILDE
+%token TO
+%token TRUE
+%token TRY
+%token TYPE
+%token <string> UIDENT
+%token UNDERSCORE
+%token VAL
+%token VIRTUAL
+%token WHEN
+%token WHILE
+%token WITH
+%token <string * Location.t> COMMENT
+%token <Docstrings.docstring> DOCSTRING
+
+%token EOL
+
+/* Precedences and associativities.
+
+Tokens and rules have precedences.  A reduce/reduce conflict is resolved
+in favor of the first rule (in source file order).  A shift/reduce conflict
+is resolved by comparing the precedence and associativity of the token to
+be shifted with those of the rule to be reduced.
+
+By default, a rule has the precedence of its rightmost terminal (if any).
+
+When there is a shift/reduce conflict between a rule and a token that
+have the same precedence, it is resolved using the associativity:
+if the token is left-associative, the parser will reduce; if
+right-associative, the parser will shift; if non-associative,
+the parser will declare a syntax error.
+
+We will only use associativities with operators of the kind  x * x -> x
+for example, in the rules of the form    expr: expr BINOP expr
+in all other cases, we define two precedences if needed to resolve
+conflicts.
+
+The precedences must be listed from low to high.
+*/
+
+%nonassoc IN
+%nonassoc below_SEMI
+%nonassoc SEMI                          /* below EQUAL ({lbl=...; lbl=...}) */
+%nonassoc LET                           /* above SEMI ( ...; let ... in ...) */
+%nonassoc below_WITH
+%nonassoc FUNCTION WITH                 /* below BAR  (match ... with ...) */
+%nonassoc AND             /* above WITH (module rec A: SIG with ... and ...) */
+%nonassoc THEN                          /* below ELSE (if ... then ...) */
+%nonassoc ELSE                          /* (if ... then ... else ...) */
+%nonassoc LESSMINUS                     /* below COLONEQUAL (lbl <- x := e) */
+%right    COLONEQUAL                    /* expr (e := e := e) */
+%nonassoc AS
+%left     BAR                           /* pattern (p|p|p) */
+%nonassoc below_COMMA
+%left     COMMA                         /* expr/expr_comma_list (e,e,e) */
+%right    MINUSGREATER                  /* function_type (t -> t -> t) */
+%right    OR BARBAR                     /* expr (e || e || e) */
+%right    AMPERSAND AMPERAMPER          /* expr (e && e && e) */
+%nonassoc below_EQUAL
+%left     INFIXOP0 EQUAL LESS GREATER   /* expr (e OP e OP e) */
+%right    INFIXOP1                      /* expr (e OP e OP e) */
+%nonassoc below_LBRACKETAT
+%nonassoc LBRACKETAT
+%right    COLONCOLON                    /* expr (e :: e :: e) */
+%left     INFIXOP2 PLUS PLUSDOT MINUS MINUSDOT PLUSEQ /* expr (e OP e OP e) */
+%left     PERCENT INFIXOP3 STAR                 /* expr (e OP e OP e) */
+%right    INFIXOP4                      /* expr (e OP e OP e) */
+%nonassoc prec_unary_minus prec_unary_plus /* unary - */
+%nonassoc prec_constant_constructor     /* cf. simple_expr (C versus C x) */
+%nonassoc prec_constr_appl              /* above AS BAR COLONCOLON COMMA */
+%nonassoc below_HASH
+%nonassoc HASH                         /* simple_expr/toplevel_directive */
+%left     HASHOP
+%nonassoc below_DOT
+%nonassoc DOT DOTOP
+/* Finally, the first tokens of simple_expr are above everything else. */
+%nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT INT
+          LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN
+          NEW PREFIXOP STRING TRUE UIDENT
+          LBRACKETPERCENT QUOTED_STRING_EXPR
+
+
+/* Entry points */
+
+%start implementation                   /* for implementation files */
+%type <Parsetree.structure> implementation
+%start interface                        /* for interface files */
+%type <Parsetree.signature> interface
+%start toplevel_phrase                  /* for interactive use */
+%type <Parsetree.toplevel_phrase> toplevel_phrase
+%start use_file                         /* for the #use directive */
+%type <Parsetree.toplevel_phrase list> use_file
+%start parse_core_type
+%type <Parsetree.core_type> parse_core_type
+%start parse_expression
+%type <Parsetree.expression> parse_expression
+%start parse_pattern
+%type <Parsetree.pattern> parse_pattern
+%start parse_constr_longident
+%type <Longident.t> parse_constr_longident
+%start parse_val_longident
+%type <Longident.t> parse_val_longident
+%start parse_mty_longident
+%type <Longident.t> parse_mty_longident
+%start parse_mod_ext_longident
+%type <Longident.t> parse_mod_ext_longident
+%start parse_mod_longident
+%type <Longident.t> parse_mod_longident
+%start parse_any_longident
+%type <Longident.t> parse_any_longident
+%%
+
+/* macros */
+%inline extra_str(symb): symb { extra_str $startpos $endpos $1 };
+%inline extra_sig(symb): symb { extra_sig $startpos $endpos $1 };
+%inline extra_cstr(symb): symb { extra_cstr $startpos $endpos $1 };
+%inline extra_csig(symb): symb { extra_csig $startpos $endpos $1 };
+%inline extra_def(symb): symb { extra_def $startpos $endpos $1 };
+%inline extra_text(symb): symb { extra_text $startpos $endpos $1 };
+%inline extra_rhs(symb): symb { extra_rhs_core_type $1 ~pos:$endpos($1) };
+%inline mkrhs(symb): symb
+    { mkrhs $1 $sloc }
+;
+
+%inline text_str(symb): symb
+  { text_str $startpos @ [$1] }
+%inline text_str_SEMISEMI: SEMISEMI
+  { text_str $startpos }
+%inline text_sig(symb): symb
+  { text_sig $startpos @ [$1] }
+%inline text_sig_SEMISEMI: SEMISEMI
+  { text_sig $startpos }
+%inline text_def(symb): symb
+  { text_def $startpos @ [$1] }
+%inline top_def(symb): symb
+  { Ptop_def [$1] }
+%inline text_cstr(symb): symb
+  { text_cstr $startpos @ [$1] }
+%inline text_csig(symb): symb
+  { text_csig $startpos @ [$1] }
+
+(* Using this %inline definition means that we do not control precisely
+   when [mark_rhs_docs] is called, but I don't think this matters. *)
+%inline mark_rhs_docs(symb): symb
+  { mark_rhs_docs $startpos $endpos;
+    $1 }
+
+%inline op(symb): symb
+   { mkoperator ~loc:$sloc $1 }
+
+%inline mkloc(symb): symb
+    { mkloc $1 (make_loc $sloc) }
+
+%inline mkexp(symb): symb
+    { mkexp ~loc:$sloc $1 }
+%inline mkpat(symb): symb
+    { mkpat ~loc:$sloc $1 }
+%inline mktyp(symb): symb
+    { mktyp ~loc:$sloc $1 }
+%inline mkstr(symb): symb
+    { mkstr ~loc:$sloc $1 }
+%inline mksig(symb): symb
+    { mksig ~loc:$sloc $1 }
+%inline mkmod(symb): symb
+    { mkmod ~loc:$sloc $1 }
+%inline mkmty(symb): symb
+    { mkmty ~loc:$sloc $1 }
+%inline mkcty(symb): symb
+    { mkcty ~loc:$sloc $1 }
+%inline mkctf(symb): symb
+    { mkctf ~loc:$sloc $1 }
+%inline mkcf(symb): symb
+    { mkcf ~loc:$sloc $1 }
+%inline mkclass(symb): symb
+    { mkclass ~loc:$sloc $1 }
+
+%inline wrap_mkstr_ext(symb): symb
+    { wrap_mkstr_ext ~loc:$sloc $1 }
+%inline wrap_mksig_ext(symb): symb
+    { wrap_mksig_ext ~loc:$sloc $1 }
+
+%inline mk_directive_arg(symb): symb
+    { mk_directive_arg ~loc:$sloc $1 }
+
+/* Generic definitions */
+
+(* [iloption(X)] recognizes either nothing or [X]. Assuming [X] produces
+   an OCaml list, it produces an OCaml list, too. *)
+
+%inline iloption(X):
+  /* nothing */
+    { [] }
+| x = X
+    { x }
+
+(* [llist(X)] recognizes a possibly empty list of [X]s. It is left-recursive. *)
+
+reversed_llist(X):
+  /* empty */
+    { [] }
+| xs = reversed_llist(X) x = X
+    { x :: xs }
+
+%inline llist(X):
+  xs = rev(reversed_llist(X))
+    { xs }
+
+(* [reversed_nonempty_llist(X)] recognizes a nonempty list of [X]s, and produces
+   an OCaml list in reverse order -- that is, the last element in the input text
+   appears first in this list. Its definition is left-recursive. *)
+
+reversed_nonempty_llist(X):
+  x = X
+    { [ x ] }
+| xs = reversed_nonempty_llist(X) x = X
+    { x :: xs }
+
+(* [nonempty_llist(X)] recognizes a nonempty list of [X]s, and produces an OCaml
+   list in direct order -- that is, the first element in the input text appears
+   first in this list. *)
+
+%inline nonempty_llist(X):
+  xs = rev(reversed_nonempty_llist(X))
+    { xs }
+
+(* [reversed_separated_nonempty_llist(separator, X)] recognizes a nonempty list
+   of [X]s, separated with [separator]s, and produces an OCaml list in reverse
+   order -- that is, the last element in the input text appears first in this
+   list. Its definition is left-recursive. *)
+
+(* [inline_reversed_separated_nonempty_llist(separator, X)] is semantically
+   equivalent to [reversed_separated_nonempty_llist(separator, X)], but is
+   marked %inline, which means that the case of a list of length one and
+   the case of a list of length more than one will be distinguished at the
+   use site, and will give rise there to two productions. This can be used
+   to avoid certain conflicts. *)
+
+%inline inline_reversed_separated_nonempty_llist(separator, X):
+  x = X
+    { [ x ] }
+| xs = reversed_separated_nonempty_llist(separator, X)
+  separator
+  x = X
+    { x :: xs }
+
+reversed_separated_nonempty_llist(separator, X):
+  xs = inline_reversed_separated_nonempty_llist(separator, X)
+    { xs }
+
+(* [separated_nonempty_llist(separator, X)] recognizes a nonempty list of [X]s,
+   separated with [separator]s, and produces an OCaml list in direct order --
+   that is, the first element in the input text appears first in this list. *)
+
+%inline separated_nonempty_llist(separator, X):
+  xs = rev(reversed_separated_nonempty_llist(separator, X))
+    { xs }
+
+%inline inline_separated_nonempty_llist(separator, X):
+  xs = rev(inline_reversed_separated_nonempty_llist(separator, X))
+    { xs }
+
+(* [reversed_separated_nontrivial_llist(separator, X)] recognizes a list of at
+   least two [X]s, separated with [separator]s, and produces an OCaml list in
+   reverse order -- that is, the last element in the input text appears first
+   in this list. Its definition is left-recursive. *)
+
+reversed_separated_nontrivial_llist(separator, X):
+  xs = reversed_separated_nontrivial_llist(separator, X)
+  separator
+  x = X
+    { x :: xs }
+| x1 = X
+  separator
+  x2 = X
+    { [ x2; x1 ] }
+
+(* [separated_nontrivial_llist(separator, X)] recognizes a list of at least
+   two [X]s, separated with [separator]s, and produces an OCaml list in direct
+   order -- that is, the first element in the input text appears first in this
+   list. *)
+
+%inline separated_nontrivial_llist(separator, X):
+  xs = rev(reversed_separated_nontrivial_llist(separator, X))
+    { xs }
+
+(* [separated_or_terminated_nonempty_list(delimiter, X)] recognizes a nonempty
+   list of [X]s, separated with [delimiter]s, and optionally terminated with a
+   final [delimiter]. Its definition is right-recursive. *)
+
+separated_or_terminated_nonempty_list(delimiter, X):
+  x = X ioption(delimiter)
+    { [x] }
+| x = X
+  delimiter
+  xs = separated_or_terminated_nonempty_list(delimiter, X)
+    { x :: xs }
+
+(* [reversed_preceded_or_separated_nonempty_llist(delimiter, X)] recognizes a
+   nonempty list of [X]s, separated with [delimiter]s, and optionally preceded
+   with a leading [delimiter]. It produces an OCaml list in reverse order. Its
+   definition is left-recursive. *)
+
+reversed_preceded_or_separated_nonempty_llist(delimiter, X):
+  ioption(delimiter) x = X
+    { [x] }
+| xs = reversed_preceded_or_separated_nonempty_llist(delimiter, X)
+  delimiter
+  x = X
+    { x :: xs }
+
+(* [preceded_or_separated_nonempty_llist(delimiter, X)] recognizes a nonempty
+   list of [X]s, separated with [delimiter]s, and optionally preceded with a
+   leading [delimiter]. It produces an OCaml list in direct order. *)
+
+%inline preceded_or_separated_nonempty_llist(delimiter, X):
+  xs = rev(reversed_preceded_or_separated_nonempty_llist(delimiter, X))
+    { xs }
+
+(* [bar_llist(X)] recognizes a nonempty list of [X]'s, separated with BARs,
+   with an optional leading BAR. We assume that [X] is itself parameterized
+   with an opening symbol, which can be [epsilon] or [BAR]. *)
+
+(* This construction may seem needlessly complicated: one might think that
+   using [preceded_or_separated_nonempty_llist(BAR, X)], where [X] is *not*
+   itself parameterized, would be sufficient. Indeed, this simpler approach
+   would recognize the same language. However, the two approaches differ in
+   the footprint of [X]. We want the start location of [X] to include [BAR]
+   when present. In the future, we might consider switching to the simpler
+   definition, at the cost of producing slightly different locations. TODO *)
+
+reversed_bar_llist(X):
+    (* An [X] without a leading BAR. *)
+    x = X(epsilon)
+      { [x] }
+  | (* An [X] with a leading BAR. *)
+    x = X(BAR)
+      { [x] }
+  | (* An initial list, followed with a BAR and an [X]. *)
+    xs = reversed_bar_llist(X)
+    x = X(BAR)
+      { x :: xs }
+
+%inline bar_llist(X):
+  xs = reversed_bar_llist(X)
+    { List.rev xs }
+
+(* [xlist(A, B)] recognizes [AB*]. We assume that the semantic value for [A]
+   is a pair [x, b], while the semantic value for [B*] is a list [bs].
+   We return the pair [x, b :: bs]. *)
+
+%inline xlist(A, B):
+  a = A bs = B*
+    { let (x, b) = a in x, b :: bs }
+
+(* [listx(delimiter, X, Y)] recognizes a nonempty list of [X]s, optionally
+   followed with a [Y], separated-or-terminated with [delimiter]s. The
+   semantic value is a pair of a list of [X]s and an optional [Y]. *)
+
+listx(delimiter, X, Y):
+| x = X ioption(delimiter)
+    { [x], None }
+| x = X delimiter y = Y delimiter?
+    { [x], Some y }
+| x = X
+  delimiter
+  tail = listx(delimiter, X, Y)
+    { let xs, y = tail in
+      x :: xs, y }
+
+(* -------------------------------------------------------------------------- *)
+
+(* Entry points. *)
+
+(* An .ml file. *)
+implementation:
+  structure EOF
+    { $1 }
+;
+
+(* An .mli file. *)
+interface:
+  signature EOF
+    { $1 }
+;
+
+(* A toplevel phrase. *)
+toplevel_phrase:
+  (* An expression with attributes, ended by a double semicolon. *)
+  extra_str(text_str(str_exp))
+  SEMISEMI
+    { Ptop_def $1 }
+| (* A list of structure items, ended by a double semicolon. *)
+  extra_str(flatten(text_str(structure_item)*))
+  SEMISEMI
+    { Ptop_def $1 }
+| (* A directive, ended by a double semicolon. *)
+  toplevel_directive
+  SEMISEMI
+    { $1 }
+| (* End of input. *)
+  EOF
+    { raise End_of_file }
+;
+
+(* An .ml file that is read by #use. *)
+use_file:
+  (* An optional standalone expression,
+     followed with a series of elements,
+     followed with EOF. *)
+  extra_def(append(
+    optional_use_file_standalone_expression,
+    flatten(use_file_element*)
+  ))
+  EOF
+    { $1 }
+;
+
+(* An optional standalone expression is just an expression with attributes
+   (str_exp), with extra wrapping. *)
+%inline optional_use_file_standalone_expression:
+  iloption(text_def(top_def(str_exp)))
+    { $1 }
+;
+
+(* An element in a #used file is one of the following:
+   - a double semicolon followed with an optional standalone expression;
+   - a structure item;
+   - a toplevel directive.
+ *)
+%inline use_file_element:
+  preceded(SEMISEMI, optional_use_file_standalone_expression)
+| text_def(top_def(structure_item))
+| text_def(mark_rhs_docs(toplevel_directive))
+      { $1 }
+;
+
+parse_core_type:
+  core_type EOF
+    { $1 }
+;
+
+parse_expression:
+  seq_expr EOF
+    { $1 }
+;
+
+parse_pattern:
+  pattern EOF
+    { $1 }
+;
+
+parse_mty_longident:
+  mty_longident EOF
+    { $1 }
+;
+
+parse_val_longident:
+  val_longident EOF
+    { $1 }
+;
+
+parse_constr_longident:
+  constr_longident EOF
+    { $1 }
+;
+
+parse_mod_ext_longident:
+  mod_ext_longident EOF
+    { $1 }
+;
+
+parse_mod_longident:
+  mod_longident EOF
+    { $1 }
+;
+
+parse_any_longident:
+  any_longident EOF
+    { $1 }
+;
+(* -------------------------------------------------------------------------- *)
+
+(* Functor arguments appear in module expressions and module types. *)
+
+%inline functor_args:
+  reversed_nonempty_llist(functor_arg)
+    { $1 }
+    (* Produce a reversed list on purpose;
+       later processed using [fold_left]. *)
+;
+
+functor_arg:
+    (* An anonymous and untyped argument. *)
+    LPAREN RPAREN
+      { $startpos, Unit }
+  | (* An argument accompanied with an explicit type. *)
+    LPAREN x = mkrhs(module_name) COLON mty = module_type RPAREN
+      { $startpos, Named (x, mty) }
+;
+
+module_name:
+    (* A named argument. *)
+    x = UIDENT
+      { Some x }
+  | (* An anonymous argument. *)
+    UNDERSCORE
+      { None }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+(* Module expressions. *)
+
+(* The syntax of module expressions is not properly stratified. The cases of
+   functors, functor applications, and attributes interact and cause conflicts,
+   which are resolved by precedence declarations. This is concise but fragile.
+   Perhaps in the future an explicit stratification could be used. *)
+
+module_expr:
+  | STRUCT attrs = attributes s = structure END
+      { mkmod ~loc:$sloc ~attrs (Pmod_structure s) }
+  | STRUCT attributes structure error
+      { unclosed "struct" $loc($1) "end" $loc($4) }
+  | FUNCTOR attrs = attributes args = functor_args MINUSGREATER me = module_expr
+      { wrap_mod_attrs ~loc:$sloc attrs (
+          List.fold_left (fun acc (startpos, arg) ->
+            mkmod ~loc:(startpos, $endpos) (Pmod_functor (arg, acc))
+          ) me args
+        ) }
+  | me = paren_module_expr
+      { me }
+  | me = module_expr attr = attribute
+      { Mod.attr me attr }
+  | mkmod(
+      (* A module identifier. *)
+      x = mkrhs(mod_longident)
+        { Pmod_ident x }
+    | (* In a functor application, the actual argument must be parenthesized. *)
+      me1 = module_expr me2 = paren_module_expr
+        { Pmod_apply(me1, me2) }
+    | (* Application to unit is sugar for application to an empty structure. *)
+      me1 = module_expr LPAREN RPAREN
+        { (* TODO review mkmod location *)
+          Pmod_apply(me1, mkmod ~loc:$sloc (Pmod_structure [])) }
+    | (* An extension. *)
+      ex = extension
+        { Pmod_extension ex }
+    )
+    { $1 }
+;
+
+(* A parenthesized module expression is a module expression that begins
+   and ends with parentheses. *)
+
+paren_module_expr:
+    (* A module expression annotated with a module type. *)
+    LPAREN me = module_expr COLON mty = module_type RPAREN
+      { mkmod ~loc:$sloc (Pmod_constraint(me, mty)) }
+  | LPAREN module_expr COLON module_type error
+      { unclosed "(" $loc($1) ")" $loc($5) }
+  | (* A module expression within parentheses. *)
+    LPAREN me = module_expr RPAREN
+      { me (* TODO consider reloc *) }
+  | LPAREN module_expr error
+      { unclosed "(" $loc($1) ")" $loc($3) }
+  | (* A core language expression that produces a first-class module.
+       This expression can be annotated in various ways. *)
+    LPAREN VAL attrs = attributes e = expr_colon_package_type RPAREN
+      { mkmod ~loc:$sloc ~attrs (Pmod_unpack e) }
+  | LPAREN VAL attributes expr COLON error
+      { unclosed "(" $loc($1) ")" $loc($6) }
+  | LPAREN VAL attributes expr COLONGREATER error
+      { unclosed "(" $loc($1) ")" $loc($6) }
+  | LPAREN VAL attributes expr error
+      { unclosed "(" $loc($1) ")" $loc($5) }
+;
+
+(* The various ways of annotating a core language expression that
+   produces a first-class module that we wish to unpack. *)
+%inline expr_colon_package_type:
+    e = expr
+      { e }
+  | e = expr COLON ty = package_type
+      { ghexp ~loc:$loc (Pexp_constraint (e, ty)) }
+  | e = expr COLON ty1 = package_type COLONGREATER ty2 = package_type
+      { ghexp ~loc:$loc (Pexp_coerce (e, Some ty1, ty2)) }
+  | e = expr COLONGREATER ty2 = package_type
+      { ghexp ~loc:$loc (Pexp_coerce (e, None, ty2)) }
+;
+
+(* A structure, which appears between STRUCT and END (among other places),
+   begins with an optional standalone expression, and continues with a list
+   of structure elements. *)
+structure:
+  extra_str(append(
+    optional_structure_standalone_expression,
+    flatten(structure_element*)
+  ))
+  { $1 }
+;
+
+(* An optional standalone expression is just an expression with attributes
+   (str_exp), with extra wrapping. *)
+%inline optional_structure_standalone_expression:
+  items = iloption(mark_rhs_docs(text_str(str_exp)))
+    { items }
+;
+
+(* An expression with attributes, wrapped as a structure item. *)
+%inline str_exp:
+  e = seq_expr
+  attrs = post_item_attributes
+    { mkstrexp e attrs }
+;
+
+(* A structure element is one of the following:
+   - a double semicolon followed with an optional standalone expression;
+   - a structure item. *)
+%inline structure_element:
+    append(text_str_SEMISEMI, optional_structure_standalone_expression)
+  | text_str(structure_item)
+      { $1 }
+;
+
+(* A structure item. *)
+structure_item:
+    let_bindings(ext)
+      { val_of_let_bindings ~loc:$sloc $1 }
+  | mkstr(
+      item_extension post_item_attributes
+        { let docs = symbol_docs $sloc in
+          Pstr_extension ($1, add_docs_attrs docs $2) }
+    | floating_attribute
+        { Pstr_attribute $1 }
+    )
+  | wrap_mkstr_ext(
+      primitive_declaration
+        { pstr_primitive $1 }
+    | value_description
+        { pstr_primitive $1 }
+    | type_declarations
+        { pstr_type $1 }
+    | str_type_extension
+        { pstr_typext $1 }
+    | str_exception_declaration
+        { pstr_exception $1 }
+    | module_binding
+        { $1 }
+    | rec_module_bindings
+        { pstr_recmodule $1 }
+    | module_type_declaration
+        { let (body, ext) = $1 in (Pstr_modtype body, ext) }
+    | open_declaration
+        { let (body, ext) = $1 in (Pstr_open body, ext) }
+    | class_declarations
+        { let (ext, l) = $1 in (Pstr_class l, ext) }
+    | class_type_declarations
+        { let (ext, l) = $1 in (Pstr_class_type l, ext) }
+    | include_statement(module_expr)
+        { pstr_include $1 }
+    )
+    { $1 }
+;
+
+(* A single module binding. *)
+%inline module_binding:
+  MODULE
+  ext = ext attrs1 = attributes
+  name = mkrhs(module_name)
+  body = module_binding_body
+  attrs2 = post_item_attributes
+    { let docs = symbol_docs $sloc in
+      let loc = make_loc $sloc in
+      let attrs = attrs1 @ attrs2 in
+      let body = Mb.mk name body ~attrs ~loc ~docs in
+      Pstr_module body, ext }
+;
+
+(* The body (right-hand side) of a module binding. *)
+module_binding_body:
+    EQUAL me = module_expr
+      { me }
+  | mkmod(
+      COLON mty = module_type EQUAL me = module_expr
+        { Pmod_constraint(me, mty) }
+    | arg_and_pos = functor_arg body = module_binding_body
+        { let (_, arg) = arg_and_pos in
+          Pmod_functor(arg, body) }
+  ) { $1 }
+;
+
+(* A group of recursive module bindings. *)
+%inline rec_module_bindings:
+  xlist(rec_module_binding, and_module_binding)
+    { $1 }
+;
+
+(* The first binding in a group of recursive module bindings. *)
+%inline rec_module_binding:
+  MODULE
+  ext = ext
+  attrs1 = attributes
+  REC
+  name = mkrhs(module_name)
+  body = module_binding_body
+  attrs2 = post_item_attributes
+  {
+    let loc = make_loc $sloc in
+    let attrs = attrs1 @ attrs2 in
+    let docs = symbol_docs $sloc in
+    ext,
+    Mb.mk name body ~attrs ~loc ~docs
+  }
+;
+
+(* The following bindings in a group of recursive module bindings. *)
+%inline and_module_binding:
+  AND
+  attrs1 = attributes
+  name = mkrhs(module_name)
+  body = module_binding_body
+  attrs2 = post_item_attributes
+  {
+    let loc = make_loc $sloc in
+    let attrs = attrs1 @ attrs2 in
+    let docs = symbol_docs $sloc in
+    let text = symbol_text $symbolstartpos in
+    Mb.mk name body ~attrs ~loc ~text ~docs
+  }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+(* Shared material between structures and signatures. *)
+
+(* An [include] statement can appear in a structure or in a signature,
+   which is why this definition is parameterized. *)
+%inline include_statement(thing):
+  INCLUDE
+  ext = ext
+  attrs1 = attributes
+  thing = thing
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Incl.mk thing ~attrs ~loc ~docs, ext
+  }
+;
+
+(* A module type declaration. *)
+module_type_declaration:
+  MODULE TYPE
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(ident)
+  typ = preceded(EQUAL, module_type)?
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Mtd.mk id ?typ ~attrs ~loc ~docs, ext
+  }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+(* Opens. *)
+
+open_declaration:
+  OPEN
+  override = override_flag
+  ext = ext
+  attrs1 = attributes
+  me = module_expr
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Opn.mk me ~override ~attrs ~loc ~docs, ext
+  }
+;
+
+open_description:
+  OPEN
+  override = override_flag
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(mod_ext_longident)
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Opn.mk id ~override ~attrs ~loc ~docs, ext
+  }
+;
+
+%inline open_dot_declaration: mkrhs(mod_longident)
+  { let loc = make_loc $loc($1) in
+    let me = Mod.ident ~loc $1 in
+    Opn.mk ~loc me }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+/* Module types */
+
+module_type:
+  | SIG attrs = attributes s = signature END
+      { mkmty ~loc:$sloc ~attrs (Pmty_signature s) }
+  | SIG attributes signature error
+      { unclosed "sig" $loc($1) "end" $loc($4) }
+  | FUNCTOR attrs = attributes args = functor_args
+    MINUSGREATER mty = module_type
+      %prec below_WITH
+      { wrap_mty_attrs ~loc:$sloc attrs (
+          List.fold_left (fun acc (startpos, arg) ->
+            mkmty ~loc:(startpos, $endpos) (Pmty_functor (arg, acc))
+          ) mty args
+        ) }
+  | MODULE TYPE OF attributes module_expr %prec below_LBRACKETAT
+      { mkmty ~loc:$sloc ~attrs:$4 (Pmty_typeof $5) }
+  | LPAREN module_type RPAREN
+      { $2 }
+  | LPAREN module_type error
+      { unclosed "(" $loc($1) ")" $loc($3) }
+  | module_type attribute
+      { Mty.attr $1 $2 }
+  | mkmty(
+      mkrhs(mty_longident)
+        { Pmty_ident $1 }
+    | module_type MINUSGREATER module_type
+        %prec below_WITH
+        { Pmty_functor(Named (mknoloc None, $1), $3) }
+    | module_type WITH separated_nonempty_llist(AND, with_constraint)
+        { Pmty_with($1, $3) }
+/*  | LPAREN MODULE mkrhs(mod_longident) RPAREN
+        { Pmty_alias $3 } */
+    | extension
+        { Pmty_extension $1 }
+    )
+    { $1 }
+;
+(* A signature, which appears between SIG and END (among other places),
+   is a list of signature elements. *)
+signature:
+  extra_sig(flatten(signature_element*))
+    { $1 }
+;
+
+(* A signature element is one of the following:
+   - a double semicolon;
+   - a signature item. *)
+%inline signature_element:
+    text_sig_SEMISEMI
+  | text_sig(signature_item)
+      { $1 }
+;
+
+(* A signature item. *)
+signature_item:
+  | item_extension post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mksig ~loc:$sloc (Psig_extension ($1, (add_docs_attrs docs $2))) }
+  | mksig(
+      floating_attribute
+        { Psig_attribute $1 }
+    )
+    { $1 }
+  | wrap_mksig_ext(
+      value_description
+        { psig_value $1 }
+    | primitive_declaration
+        { psig_value $1 }
+    | type_declarations
+        { psig_type $1 }
+    | type_subst_declarations
+        { psig_typesubst $1 }
+    | sig_type_extension
+        { psig_typext $1 }
+    | sig_exception_declaration
+        { psig_exception $1 }
+    | module_declaration
+        { let (body, ext) = $1 in (Psig_module body, ext) }
+    | module_alias
+        { let (body, ext) = $1 in (Psig_module body, ext) }
+    | module_subst
+        { let (body, ext) = $1 in (Psig_modsubst body, ext) }
+    | rec_module_declarations
+        { let (ext, l) = $1 in (Psig_recmodule l, ext) }
+    | module_type_declaration
+        { let (body, ext) = $1 in (Psig_modtype body, ext) }
+    | open_description
+        { let (body, ext) = $1 in (Psig_open body, ext) }
+    | include_statement(module_type)
+        { psig_include $1 }
+    | class_descriptions
+        { let (ext, l) = $1 in (Psig_class l, ext) }
+    | class_type_declarations
+        { let (ext, l) = $1 in (Psig_class_type l, ext) }
+    )
+    { $1 }
+
+(* A module declaration. *)
+%inline module_declaration:
+  MODULE
+  ext = ext attrs1 = attributes
+  name = mkrhs(module_name)
+  body = module_declaration_body
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Md.mk name body ~attrs ~loc ~docs, ext
+  }
+;
+
+(* The body (right-hand side) of a module declaration. *)
+module_declaration_body:
+    COLON mty = module_type
+      { mty }
+  | mkmty(
+      arg_and_pos = functor_arg body = module_declaration_body
+        { let (_, arg) = arg_and_pos in
+          Pmty_functor(arg, body) }
+    )
+    { $1 }
+;
+
+(* A module alias declaration (in a signature). *)
+%inline module_alias:
+  MODULE
+  ext = ext attrs1 = attributes
+  name = mkrhs(module_name)
+  EQUAL
+  body = module_expr_alias
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Md.mk name body ~attrs ~loc ~docs, ext
+  }
+;
+%inline module_expr_alias:
+  id = mkrhs(mod_longident)
+    { Mty.alias ~loc:(make_loc $sloc) id }
+;
+(* A module substitution (in a signature). *)
+module_subst:
+  MODULE
+  ext = ext attrs1 = attributes
+  uid = mkrhs(UIDENT)
+  COLONEQUAL
+  body = mkrhs(mod_ext_longident)
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Ms.mk uid body ~attrs ~loc ~docs, ext
+  }
+| MODULE ext attributes mkrhs(UIDENT) COLONEQUAL error
+    { expecting $loc($6) "module path" }
+;
+
+(* A group of recursive module declarations. *)
+%inline rec_module_declarations:
+  xlist(rec_module_declaration, and_module_declaration)
+    { $1 }
+;
+%inline rec_module_declaration:
+  MODULE
+  ext = ext
+  attrs1 = attributes
+  REC
+  name = mkrhs(module_name)
+  COLON
+  mty = module_type
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    ext, Md.mk name mty ~attrs ~loc ~docs
+  }
+;
+%inline and_module_declaration:
+  AND
+  attrs1 = attributes
+  name = mkrhs(module_name)
+  COLON
+  mty = module_type
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let docs = symbol_docs $sloc in
+    let loc = make_loc $sloc in
+    let text = symbol_text $symbolstartpos in
+    Md.mk name mty ~attrs ~loc ~text ~docs
+  }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+(* Class declarations. *)
+
+%inline class_declarations:
+  xlist(class_declaration, and_class_declaration)
+    { $1 }
+;
+%inline class_declaration:
+  CLASS
+  ext = ext
+  attrs1 = attributes
+  virt = virtual_flag
+  params = formal_class_parameters
+  id = mkrhs(LIDENT)
+  body = class_fun_binding
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    ext,
+    Ci.mk id body ~virt ~params ~attrs ~loc ~docs
+  }
+;
+%inline and_class_declaration:
+  AND
+  attrs1 = attributes
+  virt = virtual_flag
+  params = formal_class_parameters
+  id = mkrhs(LIDENT)
+  body = class_fun_binding
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    let text = symbol_text $symbolstartpos in
+    Ci.mk id body ~virt ~params ~attrs ~loc ~text ~docs
+  }
+;
+
+class_fun_binding:
+    EQUAL class_expr
+      { $2 }
+  | mkclass(
+      COLON class_type EQUAL class_expr
+        { Pcl_constraint($4, $2) }
+    | labeled_simple_pattern class_fun_binding
+      { let (l,o,p) = $1 in Pcl_fun(l, o, p, $2) }
+    ) { $1 }
+;
+
+formal_class_parameters:
+  params = class_parameters(type_parameter)
+    { params }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+(* Class expressions. *)
+
+class_expr:
+    class_simple_expr
+      { $1 }
+  | FUN attributes class_fun_def
+      { wrap_class_attrs ~loc:$sloc $3 $2 }
+  | let_bindings(no_ext) IN class_expr
+      { class_of_let_bindings ~loc:$sloc $1 $3 }
+  | LET OPEN override_flag attributes mkrhs(mod_longident) IN class_expr
+      { let loc = ($startpos($2), $endpos($5)) in
+        let od = Opn.mk ~override:$3 ~loc:(make_loc loc) $5 in
+        mkclass ~loc:$sloc ~attrs:$4 (Pcl_open(od, $7)) }
+  | class_expr attribute
+      { Cl.attr $1 $2 }
+  | mkclass(
+      class_simple_expr nonempty_llist(labeled_simple_expr)
+        { Pcl_apply($1, $2) }
+    | extension
+        { Pcl_extension $1 }
+    ) { $1 }
+;
+class_simple_expr:
+  | LPAREN class_expr RPAREN
+      { $2 }
+  | LPAREN class_expr error
+      { unclosed "(" $loc($1) ")" $loc($3) }
+  | mkclass(
+      tys = actual_class_parameters cid = mkrhs(class_longident)
+        { Pcl_constr(cid, tys) }
+    | OBJECT attributes class_structure error
+        { unclosed "object" $loc($1) "end" $loc($4) }
+    | LPAREN class_expr COLON class_type RPAREN
+        { Pcl_constraint($2, $4) }
+    | LPAREN class_expr COLON class_type error
+        { unclosed "(" $loc($1) ")" $loc($5) }
+    ) { $1 }
+  | OBJECT attributes class_structure END
+    { mkclass ~loc:$sloc ~attrs:$2 (Pcl_structure $3) }
+;
+
+class_fun_def:
+  mkclass(
+    labeled_simple_pattern MINUSGREATER e = class_expr
+  | labeled_simple_pattern e = class_fun_def
+      { let (l,o,p) = $1 in Pcl_fun(l, o, p, e) }
+  ) { $1 }
+;
+%inline class_structure:
+  |  class_self_pattern extra_cstr(class_fields)
+       { Cstr.mk $1 $2 }
+;
+class_self_pattern:
+    LPAREN pattern RPAREN
+      { reloc_pat ~loc:$sloc $2 }
+  | mkpat(LPAREN pattern COLON core_type RPAREN
+      { Ppat_constraint($2, $4) })
+      { $1 }
+  | /* empty */
+      { ghpat ~loc:$sloc Ppat_any }
+;
+%inline class_fields:
+  flatten(text_cstr(class_field)*)
+    { $1 }
+;
+class_field:
+  | INHERIT override_flag attributes class_expr
+    self = preceded(AS, mkrhs(LIDENT))?
+    post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkcf ~loc:$sloc (Pcf_inherit ($2, $4, self)) ~attrs:($3@$6) ~docs }
+  | VAL value post_item_attributes
+      { let v, attrs = $2 in
+        let docs = symbol_docs $sloc in
+        mkcf ~loc:$sloc (Pcf_val v) ~attrs:(attrs@$3) ~docs }
+  | METHOD method_ post_item_attributes
+      { let meth, attrs = $2 in
+        let docs = symbol_docs $sloc in
+        mkcf ~loc:$sloc (Pcf_method meth) ~attrs:(attrs@$3) ~docs }
+  | CONSTRAINT attributes constrain_field post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkcf ~loc:$sloc (Pcf_constraint $3) ~attrs:($2@$4) ~docs }
+  | INITIALIZER attributes seq_expr post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkcf ~loc:$sloc (Pcf_initializer $3) ~attrs:($2@$4) ~docs }
+  | item_extension post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkcf ~loc:$sloc (Pcf_extension $1) ~attrs:$2 ~docs }
+  | mkcf(floating_attribute
+      { Pcf_attribute $1 })
+      { $1 }
+;
+value:
+    no_override_flag
+    attrs = attributes
+    mutable_ = virtual_with_mutable_flag
+    label = mkrhs(label) COLON ty = core_type
+      { (label, mutable_, Cfk_virtual ty), attrs }
+  | override_flag attributes mutable_flag mkrhs(label) EQUAL seq_expr
+      { ($4, $3, Cfk_concrete ($1, $6)), $2 }
+  | override_flag attributes mutable_flag mkrhs(label) type_constraint
+    EQUAL seq_expr
+      { let e = mkexp_constraint ~loc:$sloc $7 $5 in
+        ($4, $3, Cfk_concrete ($1, e)), $2
+      }
+;
+method_:
+    no_override_flag
+    attrs = attributes
+    private_ = virtual_with_private_flag
+    label = mkrhs(label) COLON ty = poly_type
+      { (label, private_, Cfk_virtual ty), attrs }
+  | override_flag attributes private_flag mkrhs(label) strict_binding
+      { let e = $5 in
+        let loc = Location.(e.pexp_loc.loc_start, e.pexp_loc.loc_end) in
+        ($4, $3,
+        Cfk_concrete ($1, ghexp ~loc (Pexp_poly (e, None)))), $2 }
+  | override_flag attributes private_flag mkrhs(label)
+    COLON poly_type EQUAL seq_expr
+      { let poly_exp =
+          let loc = ($startpos($6), $endpos($8)) in
+          ghexp ~loc (Pexp_poly($8, Some $6)) in
+        ($4, $3, Cfk_concrete ($1, poly_exp)), $2 }
+  | override_flag attributes private_flag mkrhs(label) COLON TYPE lident_list
+    DOT core_type EQUAL seq_expr
+      { let poly_exp_loc = ($startpos($7), $endpos($11)) in
+        let poly_exp =
+          let exp, poly =
+            (* it seems odd to use the global ~loc here while poly_exp_loc
+               is tighter, but this is what ocamlyacc does;
+               TODO improve parser.mly *)
+            wrap_type_annotation ~loc:$sloc $7 $9 $11 in
+          ghexp ~loc:poly_exp_loc (Pexp_poly(exp, Some poly)) in
+        ($4, $3,
+        Cfk_concrete ($1, poly_exp)), $2 }
+;
+
+/* Class types */
+
+class_type:
+    class_signature
+      { $1 }
+  | mkcty(
+      label = arg_label
+      domain = tuple_type
+      MINUSGREATER
+      codomain = class_type
+        { Pcty_arrow(label, domain, codomain) }
+    ) { $1 }
+ ;
+class_signature:
+    mkcty(
+      tys = actual_class_parameters cid = mkrhs(clty_longident)
+        { Pcty_constr (cid, tys) }
+    | extension
+        { Pcty_extension $1 }
+    ) { $1 }
+  | OBJECT attributes class_sig_body END
+      { mkcty ~loc:$sloc ~attrs:$2 (Pcty_signature $3) }
+  | OBJECT attributes class_sig_body error
+      { unclosed "object" $loc($1) "end" $loc($4) }
+  | class_signature attribute
+      { Cty.attr $1 $2 }
+  | LET OPEN override_flag attributes mkrhs(mod_longident) IN class_signature
+      { let loc = ($startpos($2), $endpos($5)) in
+        let od = Opn.mk ~override:$3 ~loc:(make_loc loc) $5 in
+        mkcty ~loc:$sloc ~attrs:$4 (Pcty_open(od, $7)) }
+;
+%inline class_parameters(parameter):
+  | /* empty */
+      { [] }
+  | LBRACKET params = separated_nonempty_llist(COMMA, parameter) RBRACKET
+      { params }
+;
+%inline actual_class_parameters:
+  tys = class_parameters(core_type)
+    { tys }
+;
+%inline class_sig_body:
+    class_self_type extra_csig(class_sig_fields)
+      { Csig.mk $1 $2 }
+;
+class_self_type:
+    LPAREN core_type RPAREN
+      { $2 }
+  | mktyp((* empty *) { Ptyp_any })
+      { $1 }
+;
+%inline class_sig_fields:
+  flatten(text_csig(class_sig_field)*)
+    { $1 }
+;
+class_sig_field:
+    INHERIT attributes class_signature post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkctf ~loc:$sloc (Pctf_inherit $3) ~attrs:($2@$4) ~docs }
+  | VAL attributes value_type post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkctf ~loc:$sloc (Pctf_val $3) ~attrs:($2@$4) ~docs }
+  | METHOD attributes private_virtual_flags mkrhs(label) COLON poly_type
+    post_item_attributes
+      { let (p, v) = $3 in
+        let docs = symbol_docs $sloc in
+        mkctf ~loc:$sloc (Pctf_method ($4, p, v, $6)) ~attrs:($2@$7) ~docs }
+  | CONSTRAINT attributes constrain_field post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkctf ~loc:$sloc (Pctf_constraint $3) ~attrs:($2@$4) ~docs }
+  | item_extension post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkctf ~loc:$sloc (Pctf_extension $1) ~attrs:$2 ~docs }
+  | mkctf(floating_attribute
+      { Pctf_attribute $1 })
+      { $1 }
+;
+%inline value_type:
+  flags = mutable_virtual_flags
+  label = mkrhs(label)
+  COLON
+  ty = core_type
+  {
+    let mut, virt = flags in
+    label, mut, virt, ty
+  }
+;
+%inline constrain:
+    core_type EQUAL core_type
+    { $1, $3, make_loc $sloc }
+;
+constrain_field:
+  core_type EQUAL core_type
+    { $1, $3 }
+;
+(* A group of class descriptions. *)
+%inline class_descriptions:
+  xlist(class_description, and_class_description)
+    { $1 }
+;
+%inline class_description:
+  CLASS
+  ext = ext
+  attrs1 = attributes
+  virt = virtual_flag
+  params = formal_class_parameters
+  id = mkrhs(LIDENT)
+  COLON
+  cty = class_type
+  attrs2 = post_item_attributes
+    {
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let docs = symbol_docs $sloc in
+      ext,
+      Ci.mk id cty ~virt ~params ~attrs ~loc ~docs
+    }
+;
+%inline and_class_description:
+  AND
+  attrs1 = attributes
+  virt = virtual_flag
+  params = formal_class_parameters
+  id = mkrhs(LIDENT)
+  COLON
+  cty = class_type
+  attrs2 = post_item_attributes
+    {
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let docs = symbol_docs $sloc in
+      let text = symbol_text $symbolstartpos in
+      Ci.mk id cty ~virt ~params ~attrs ~loc ~text ~docs
+    }
+;
+class_type_declarations:
+  xlist(class_type_declaration, and_class_type_declaration)
+    { $1 }
+;
+%inline class_type_declaration:
+  CLASS TYPE
+  ext = ext
+  attrs1 = attributes
+  virt = virtual_flag
+  params = formal_class_parameters
+  id = mkrhs(LIDENT)
+  EQUAL
+  csig = class_signature
+  attrs2 = post_item_attributes
+    {
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let docs = symbol_docs $sloc in
+      ext,
+      Ci.mk id csig ~virt ~params ~attrs ~loc ~docs
+    }
+;
+%inline and_class_type_declaration:
+  AND
+  attrs1 = attributes
+  virt = virtual_flag
+  params = formal_class_parameters
+  id = mkrhs(LIDENT)
+  EQUAL
+  csig = class_signature
+  attrs2 = post_item_attributes
+    {
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let docs = symbol_docs $sloc in
+      let text = symbol_text $symbolstartpos in
+      Ci.mk id csig ~virt ~params ~attrs ~loc ~text ~docs
+    }
+;
+
+/* Core expressions */
+
+seq_expr:
+  | expr        %prec below_SEMI  { $1 }
+  | expr SEMI                     { $1 }
+  | mkexp(expr SEMI seq_expr
+    { Pexp_sequence($1, $3) })
+    { $1 }
+  | expr SEMI PERCENT attr_id seq_expr
+    { let seq = mkexp ~loc:$sloc (Pexp_sequence ($1, $5)) in
+      let payload = PStr [mkstrexp seq []] in
+      mkexp ~loc:$sloc (Pexp_extension ($4, payload)) }
+;
+labeled_simple_pattern:
+    QUESTION LPAREN label_let_pattern opt_default RPAREN
+      { (Optional (fst $3), $4, snd $3) }
+  | QUESTION label_var
+      { (Optional (fst $2), None, snd $2) }
+  | OPTLABEL LPAREN let_pattern opt_default RPAREN
+      { (Optional $1, $4, $3) }
+  | OPTLABEL pattern_var
+      { (Optional $1, None, $2) }
+  | TILDE LPAREN label_let_pattern RPAREN
+      { (Labelled (fst $3), None, snd $3) }
+  | TILDE label_var
+      { (Labelled (fst $2), None, snd $2) }
+  | LABEL simple_pattern
+      { (Labelled $1, None, $2) }
+  | simple_pattern
+      { (Nolabel, None, $1) }
+;
+
+pattern_var:
+  mkpat(
+      mkrhs(LIDENT)     { Ppat_var $1 }
+    | UNDERSCORE        { Ppat_any }
+  ) { $1 }
+;
+
+%inline opt_default:
+  preceded(EQUAL, seq_expr)?
+    { $1 }
+;
+label_let_pattern:
+    x = label_var
+      { x }
+  | x = label_var COLON cty = core_type
+      { let lab, pat = x in
+        lab,
+        mkpat ~loc:$sloc (Ppat_constraint (pat, cty)) }
+;
+%inline label_var:
+    mkrhs(LIDENT)
+      { ($1.Location.txt, mkpat ~loc:$sloc (Ppat_var $1)) }
+;
+let_pattern:
+    pattern
+      { $1 }
+  | mkpat(pattern COLON core_type
+      { Ppat_constraint($1, $3) })
+      { $1 }
+;
+
+expr:
+    simple_expr %prec below_HASH
+      { $1 }
+  | expr_attrs
+      { let desc, attrs = $1 in
+        mkexp_attrs ~loc:$sloc desc attrs }
+  | mkexp(expr_)
+      { $1 }
+  | let_bindings(ext) IN seq_expr
+      { expr_of_let_bindings ~loc:$sloc $1 $3 }
+  | pbop_op = mkrhs(LETOP) bindings = letop_bindings IN body = seq_expr
+      { let (pbop_pat, pbop_exp, rev_ands) = bindings in
+        let ands = List.rev rev_ands in
+        let pbop_loc = make_loc $sloc in
+        let let_ = {pbop_op; pbop_pat; pbop_exp; pbop_loc} in
+        mkexp ~loc:$sloc (Pexp_letop{ let_; ands; body}) }
+  | expr COLONCOLON expr
+      { mkexp_cons ~loc:$sloc $loc($2) (ghexp ~loc:$sloc (Pexp_tuple[$1;$3])) }
+  | mkrhs(label) LESSMINUS expr
+      { mkexp ~loc:$sloc (Pexp_setinstvar($1, $3)) }
+  | simple_expr DOT mkrhs(label_longident) LESSMINUS expr
+      { mkexp ~loc:$sloc (Pexp_setfield($1, $3, $5)) }
+  | simple_expr DOT LPAREN seq_expr RPAREN LESSMINUS expr
+      { array_set ~loc:$sloc $1 $4 $7 }
+  | simple_expr DOT LBRACKET seq_expr RBRACKET LESSMINUS expr
+      { string_set ~loc:$sloc $1 $4 $7 }
+  | simple_expr DOT LBRACE expr RBRACE LESSMINUS expr
+      { bigarray_set ~loc:$sloc $1 $4 $7 }
+  | simple_expr DOTOP LBRACKET expr_semi_list RBRACKET LESSMINUS expr
+      { dotop_set ~loc:$sloc lident bracket $2 $1 $4 $7 }
+  | simple_expr DOTOP LPAREN expr_semi_list RPAREN LESSMINUS expr
+      { dotop_set ~loc:$sloc lident paren $2 $1 $4 $7 }
+  | simple_expr DOTOP LBRACE expr_semi_list RBRACE LESSMINUS expr
+      { dotop_set ~loc:$sloc lident brace $2 $1 $4 $7 }
+  | simple_expr DOT mod_longident DOTOP LBRACKET expr_semi_list RBRACKET
+      LESSMINUS expr
+      { dotop_set ~loc:$sloc (ldot $3) bracket $4 $1 $6 $9 }
+  | simple_expr DOT mod_longident DOTOP LPAREN expr_semi_list RPAREN
+      LESSMINUS expr
+      { dotop_set ~loc:$sloc (ldot $3) paren $4 $1 $6 $9  }
+  | simple_expr DOT mod_longident DOTOP LBRACE expr_semi_list RBRACE
+      LESSMINUS expr
+      { dotop_set ~loc:$sloc (ldot $3) brace $4 $1 $6 $9 }
+  | expr attribute
+      { Exp.attr $1 $2 }
+  | UNDERSCORE
+     { not_expecting $loc($1) "wildcard \"_\"" }
+;
+%inline expr_attrs:
+  | LET MODULE ext_attributes mkrhs(module_name) module_binding_body IN seq_expr
+      { Pexp_letmodule($4, $5, $7), $3 }
+  | LET EXCEPTION ext_attributes let_exception_declaration IN seq_expr
+      { Pexp_letexception($4, $6), $3 }
+  | LET OPEN override_flag ext_attributes module_expr IN seq_expr
+      { let open_loc = make_loc ($startpos($2), $endpos($5)) in
+        let od = Opn.mk $5 ~override:$3 ~loc:open_loc in
+        Pexp_open(od, $7), $4 }
+  | FUNCTION ext_attributes match_cases
+      { Pexp_function $3, $2 }
+  | FUN ext_attributes labeled_simple_pattern fun_def
+      { let (l,o,p) = $3 in
+        Pexp_fun(l, o, p, $4), $2 }
+  | FUN ext_attributes LPAREN TYPE lident_list RPAREN fun_def
+      { (mk_newtypes ~loc:$sloc $5 $7).pexp_desc, $2 }
+  | MATCH ext_attributes seq_expr WITH match_cases
+      { Pexp_match($3, $5), $2 }
+  | TRY ext_attributes seq_expr WITH match_cases
+      { Pexp_try($3, $5), $2 }
+  | TRY ext_attributes seq_expr WITH error
+      { syntax_error() }
+  | IF ext_attributes seq_expr THEN expr ELSE expr
+      { Pexp_ifthenelse($3, $5, Some $7), $2 }
+  | IF ext_attributes seq_expr THEN expr
+      { Pexp_ifthenelse($3, $5, None), $2 }
+  | WHILE ext_attributes seq_expr DO seq_expr DONE
+      { Pexp_while($3, $5), $2 }
+  | FOR ext_attributes pattern EQUAL seq_expr direction_flag seq_expr DO
+    seq_expr DONE
+      { Pexp_for($3, $5, $7, $6, $9), $2 }
+  | ASSERT ext_attributes simple_expr %prec below_HASH
+      { Pexp_assert $3, $2 }
+  | LAZY ext_attributes simple_expr %prec below_HASH
+      { Pexp_lazy $3, $2 }
+  | OBJECT ext_attributes class_structure END
+      { Pexp_object $3, $2 }
+  | OBJECT ext_attributes class_structure error
+      { unclosed "object" $loc($1) "end" $loc($4) }
+;
+%inline expr_:
+  | simple_expr nonempty_llist(labeled_simple_expr)
+      { Pexp_apply($1, $2) }
+  | expr_comma_list %prec below_COMMA
+      { Pexp_tuple($1) }
+  | mkrhs(constr_longident) simple_expr %prec below_HASH
+      { Pexp_construct($1, Some $2) }
+  | name_tag simple_expr %prec below_HASH
+      { Pexp_variant($1, Some $2) }
+  | e1 = expr op = op(infix_operator) e2 = expr
+      { mkinfix e1 op e2 }
+  | subtractive expr %prec prec_unary_minus
+      { mkuminus ~oploc:$loc($1) $1 $2 }
+  | additive expr %prec prec_unary_plus
+      { mkuplus ~oploc:$loc($1) $1 $2 }
+;
+
+simple_expr:
+  | LPAREN seq_expr RPAREN
+      { reloc_exp ~loc:$sloc $2 }
+  | LPAREN seq_expr error
+      { unclosed "(" $loc($1) ")" $loc($3) }
+  | LPAREN seq_expr type_constraint RPAREN
+      { mkexp_constraint ~loc:$sloc $2 $3 }
+  | simple_expr DOT LPAREN seq_expr RPAREN
+      { array_get ~loc:$sloc $1 $4 }
+  | simple_expr DOT LPAREN seq_expr error
+      { unclosed "(" $loc($3) ")" $loc($5) }
+  | simple_expr DOT LBRACKET seq_expr RBRACKET
+      { string_get ~loc:$sloc $1 $4 }
+  | simple_expr DOT LBRACKET seq_expr error
+      { unclosed "[" $loc($3) "]" $loc($5) }
+  | simple_expr DOTOP LBRACKET expr_semi_list RBRACKET
+      { dotop_get ~loc:$sloc lident bracket $2 $1 $4 }
+  | simple_expr DOTOP LBRACKET expr_semi_list error
+      { unclosed "[" $loc($3) "]" $loc($5) }
+  | simple_expr DOTOP LPAREN expr_semi_list RPAREN
+      { dotop_get ~loc:$sloc lident paren $2 $1 $4  }
+  | simple_expr DOTOP LPAREN expr_semi_list error
+      { unclosed "(" $loc($3) ")" $loc($5) }
+  | simple_expr DOTOP LBRACE expr_semi_list RBRACE
+      { dotop_get ~loc:$sloc lident brace $2 $1 $4 }
+  | simple_expr DOTOP LBRACE expr error
+      { unclosed "{" $loc($3) "}" $loc($5) }
+  | simple_expr DOT mod_longident DOTOP LBRACKET expr_semi_list RBRACKET
+      { dotop_get ~loc:$sloc (ldot $3) bracket $4 $1 $6  }
+  | simple_expr DOT
+    mod_longident DOTOP LBRACKET expr_semi_list error
+      { unclosed "[" $loc($5) "]" $loc($7) }
+  | simple_expr DOT mod_longident DOTOP LPAREN expr_semi_list RPAREN
+      { dotop_get ~loc:$sloc (ldot $3) paren $4 $1 $6 }
+  | simple_expr DOT
+    mod_longident DOTOP LPAREN expr_semi_list error
+      { unclosed "(" $loc($5) ")" $loc($7) }
+  | simple_expr DOT mod_longident DOTOP LBRACE expr_semi_list RBRACE
+      { dotop_get ~loc:$sloc (ldot $3) brace $4 $1 $6  }
+  | simple_expr DOT
+    mod_longident DOTOP LBRACE expr_semi_list error
+      { unclosed "{" $loc($5) "}" $loc($7) }
+  | simple_expr DOT LBRACE expr RBRACE
+      { bigarray_get ~loc:$sloc $1 $4 }
+  | simple_expr DOT LBRACE expr error
+      { unclosed "{" $loc($3) "}" $loc($5) }
+  | simple_expr_attrs
+    { let desc, attrs = $1 in
+      mkexp_attrs ~loc:$sloc desc attrs }
+  | mkexp(simple_expr_)
+      { $1 }
+;
+%inline simple_expr_attrs:
+  | BEGIN ext = ext attrs = attributes e = seq_expr END
+      { e.pexp_desc, (ext, attrs @ e.pexp_attributes) }
+  | BEGIN ext_attributes END
+      { Pexp_construct (mkloc (Lident "()") (make_loc $sloc), None), $2 }
+  | BEGIN ext_attributes seq_expr error
+      { unclosed "begin" $loc($1) "end" $loc($4) }
+  | NEW ext_attributes mkrhs(class_longident)
+      { Pexp_new($3), $2 }
+  | LPAREN MODULE ext_attributes module_expr RPAREN
+      { Pexp_pack $4, $3 }
+  | LPAREN MODULE ext_attributes module_expr COLON package_type RPAREN
+      { Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $4), $6), $3 }
+  | LPAREN MODULE ext_attributes module_expr COLON error
+      { unclosed "(" $loc($1) ")" $loc($6) }
+;
+%inline simple_expr_:
+  | mkrhs(val_longident)
+      { Pexp_ident ($1) }
+  | constant
+      { Pexp_constant $1 }
+  | mkrhs(constr_longident) %prec prec_constant_constructor
+      { Pexp_construct($1, None) }
+  | name_tag %prec prec_constant_constructor
+      { Pexp_variant($1, None) }
+  | op(PREFIXOP) simple_expr
+      { Pexp_apply($1, [Nolabel,$2]) }
+  | op(BANG {"!"}) simple_expr
+      { Pexp_apply($1, [Nolabel,$2]) }
+  | LBRACELESS object_expr_content GREATERRBRACE
+      { Pexp_override $2 }
+  | LBRACELESS object_expr_content error
+      { unclosed "{<" $loc($1) ">}" $loc($3) }
+  | LBRACELESS GREATERRBRACE
+      { Pexp_override [] }
+  | simple_expr DOT mkrhs(label_longident)
+      { Pexp_field($1, $3) }
+  | od=open_dot_declaration DOT LPAREN seq_expr RPAREN
+      { Pexp_open(od, $4) }
+  | od=open_dot_declaration DOT LBRACELESS object_expr_content GREATERRBRACE
+      { (* TODO: review the location of Pexp_override *)
+        Pexp_open(od, mkexp ~loc:$sloc (Pexp_override $4)) }
+  | mod_longident DOT LBRACELESS object_expr_content error
+      { unclosed "{<" $loc($3) ">}" $loc($5) }
+  | simple_expr HASH mkrhs(label)
+      { Pexp_send($1, $3) }
+  | simple_expr op(HASHOP) simple_expr
+      { mkinfix $1 $2 $3 }
+  | extension
+      { Pexp_extension $1 }
+  | od=open_dot_declaration DOT mkrhs(LPAREN RPAREN {Lident "()"})
+      { Pexp_open(od, mkexp ~loc:($loc($3)) (Pexp_construct($3, None))) }
+  | mod_longident DOT LPAREN seq_expr error
+      { unclosed "(" $loc($3) ")" $loc($5) }
+  | LBRACE record_expr_content RBRACE
+      { let (exten, fields) = $2 in
+        Pexp_record(fields, exten) }
+  | LBRACE record_expr_content error
+      { unclosed "{" $loc($1) "}" $loc($3) }
+  | od=open_dot_declaration DOT LBRACE record_expr_content RBRACE
+      { let (exten, fields) = $4 in
+        Pexp_open(od, mkexp ~loc:($startpos($3), $endpos)
+                        (Pexp_record(fields, exten))) }
+  | mod_longident DOT LBRACE record_expr_content error
+      { unclosed "{" $loc($3) "}" $loc($5) }
+  | LBRACKETBAR expr_semi_list BARRBRACKET
+      { Pexp_array($2) }
+  | LBRACKETBAR expr_semi_list error
+      { unclosed "[|" $loc($1) "|]" $loc($3) }
+  | LBRACKETBAR BARRBRACKET
+      { Pexp_array [] }
+  | od=open_dot_declaration DOT LBRACKETBAR expr_semi_list BARRBRACKET
+      { Pexp_open(od, mkexp ~loc:($startpos($3), $endpos) (Pexp_array($4))) }
+  | od=open_dot_declaration DOT LBRACKETBAR BARRBRACKET
+      { (* TODO: review the location of Pexp_array *)
+        Pexp_open(od, mkexp ~loc:($startpos($3), $endpos) (Pexp_array [])) }
+  | mod_longident DOT
+    LBRACKETBAR expr_semi_list error
+      { unclosed "[|" $loc($3) "|]" $loc($5) }
+  | LBRACKET expr_semi_list RBRACKET
+      { fst (mktailexp $loc($3) $2) }
+  | LBRACKET expr_semi_list error
+      { unclosed "[" $loc($1) "]" $loc($3) }
+  | od=open_dot_declaration DOT LBRACKET expr_semi_list RBRACKET
+      { let list_exp =
+          (* TODO: review the location of list_exp *)
+          let tail_exp, _tail_loc = mktailexp $loc($5) $4 in
+          mkexp ~loc:($startpos($3), $endpos) tail_exp in
+        Pexp_open(od, list_exp) }
+  | od=open_dot_declaration DOT mkrhs(LBRACKET RBRACKET {Lident "[]"})
+      { Pexp_open(od, mkexp ~loc:$loc($3) (Pexp_construct($3, None))) }
+  | mod_longident DOT
+    LBRACKET expr_semi_list error
+      { unclosed "[" $loc($3) "]" $loc($5) }
+  | od=open_dot_declaration DOT LPAREN MODULE ext_attributes module_expr COLON
+    package_type RPAREN
+      { let modexp =
+          mkexp_attrs ~loc:($startpos($3), $endpos)
+            (Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $6), $8)) $5 in
+        Pexp_open(od, modexp) }
+  | mod_longident DOT
+    LPAREN MODULE ext_attributes module_expr COLON error
+      { unclosed "(" $loc($3) ")" $loc($8) }
+;
+labeled_simple_expr:
+    simple_expr %prec below_HASH
+      { (Nolabel, $1) }
+  | LABEL simple_expr %prec below_HASH
+      { (Labelled $1, $2) }
+  | TILDE label = LIDENT
+      { let loc = $loc(label) in
+        (Labelled label, mkexpvar ~loc label) }
+  | QUESTION label = LIDENT
+      { let loc = $loc(label) in
+        (Optional label, mkexpvar ~loc label) }
+  | OPTLABEL simple_expr %prec below_HASH
+      { (Optional $1, $2) }
+;
+%inline lident_list:
+  xs = mkrhs(LIDENT)+
+    { xs }
+;
+%inline let_ident:
+    val_ident { mkpatvar ~loc:$sloc $1 }
+;
+let_binding_body:
+    let_ident strict_binding
+      { ($1, $2) }
+  | let_ident type_constraint EQUAL seq_expr
+      { let v = $1 in (* PR#7344 *)
+        let t =
+          match $2 with
+            Some t, None -> t
+          | _, Some t -> t
+          | _ -> assert false
+        in
+        let loc = Location.(t.ptyp_loc.loc_start, t.ptyp_loc.loc_end) in
+        let typ = ghtyp ~loc (Ptyp_poly([],t)) in
+        let patloc = ($startpos($1), $endpos($2)) in
+        (ghpat ~loc:patloc (Ppat_constraint(v, typ)),
+         mkexp_constraint ~loc:$sloc $4 $2) }
+  | let_ident COLON typevar_list DOT core_type EQUAL seq_expr
+      (* TODO: could replace [typevar_list DOT core_type]
+               with [mktyp(poly(core_type))]
+               and simplify the semantic action? *)
+      { let typloc = ($startpos($3), $endpos($5)) in
+        let patloc = ($startpos($1), $endpos($5)) in
+        (ghpat ~loc:patloc
+           (Ppat_constraint($1, ghtyp ~loc:typloc (Ptyp_poly($3,$5)))),
+         $7) }
+  | let_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr
+      { let exp, poly =
+          wrap_type_annotation ~loc:$sloc $4 $6 $8 in
+        let loc = ($startpos($1), $endpos($6)) in
+        (ghpat ~loc (Ppat_constraint($1, poly)), exp) }
+  | pattern_no_exn EQUAL seq_expr
+      { ($1, $3) }
+  | simple_pattern_not_ident COLON core_type EQUAL seq_expr
+      { let loc = ($startpos($1), $endpos($3)) in
+        (ghpat ~loc (Ppat_constraint($1, $3)), $5) }
+;
+(* The formal parameter EXT can be instantiated with ext or no_ext
+   so as to indicate whether an extension is allowed or disallowed. *)
+let_bindings(EXT):
+    let_binding(EXT)                            { $1 }
+  | let_bindings(EXT) and_let_binding           { addlb $1 $2 }
+;
+%inline let_binding(EXT):
+  LET
+  ext = EXT
+  attrs1 = attributes
+  rec_flag = rec_flag
+  body = let_binding_body
+  attrs2 = post_item_attributes
+    {
+      let attrs = attrs1 @ attrs2 in
+      mklbs ~loc:$sloc ext rec_flag (mklb ~loc:$sloc true body attrs)
+    }
+;
+and_let_binding:
+  AND
+  attrs1 = attributes
+  body = let_binding_body
+  attrs2 = post_item_attributes
+    {
+      let attrs = attrs1 @ attrs2 in
+      mklb ~loc:$sloc false body attrs
+    }
+;
+letop_binding_body:
+    pat = let_ident exp = strict_binding
+      { (pat, exp) }
+  | pat = simple_pattern COLON typ = core_type EQUAL exp = seq_expr
+      { let loc = ($startpos(pat), $endpos(typ)) in
+        (ghpat ~loc (Ppat_constraint(pat, typ)), exp) }
+  | pat = pattern_no_exn EQUAL exp = seq_expr
+      { (pat, exp) }
+;
+letop_bindings:
+    body = letop_binding_body
+      { let let_pat, let_exp = body in
+        let_pat, let_exp, [] }
+  | bindings = letop_bindings pbop_op = mkrhs(ANDOP) body = let_binding_body
+      { let let_pat, let_exp, rev_ands = bindings in
+        let pbop_pat, pbop_exp = body in
+        let pbop_loc = make_loc $sloc in
+        let and_ = {pbop_op; pbop_pat; pbop_exp; pbop_loc} in
+        let_pat, let_exp, and_ :: rev_ands }
+;
+fun_binding:
+    strict_binding
+      { $1 }
+  | type_constraint EQUAL seq_expr
+      { mkexp_constraint ~loc:$sloc $3 $1 }
+;
+strict_binding:
+    EQUAL seq_expr
+      { $2 }
+  | labeled_simple_pattern fun_binding
+      { let (l, o, p) = $1 in ghexp ~loc:$sloc (Pexp_fun(l, o, p, $2)) }
+  | LPAREN TYPE lident_list RPAREN fun_binding
+      { mk_newtypes ~loc:$sloc $3 $5 }
+;
+%inline match_cases:
+  xs = preceded_or_separated_nonempty_llist(BAR, match_case)
+    { xs }
+;
+match_case:
+    pattern MINUSGREATER seq_expr
+      { Exp.case $1 $3 }
+  | pattern WHEN seq_expr MINUSGREATER seq_expr
+      { Exp.case $1 ~guard:$3 $5 }
+  | pattern MINUSGREATER DOT
+      { Exp.case $1 (Exp.unreachable ~loc:(make_loc $loc($3)) ()) }
+;
+fun_def:
+    MINUSGREATER seq_expr
+      { $2 }
+  | mkexp(COLON atomic_type MINUSGREATER seq_expr
+      { Pexp_constraint ($4, $2) })
+      { $1 }
+/* Cf #5939: we used to accept (fun p when e0 -> e) */
+  | labeled_simple_pattern fun_def
+      {
+       let (l,o,p) = $1 in
+       ghexp ~loc:$sloc (Pexp_fun(l, o, p, $2))
+      }
+  | LPAREN TYPE lident_list RPAREN fun_def
+      { mk_newtypes ~loc:$sloc $3 $5 }
+;
+%inline expr_comma_list:
+  es = separated_nontrivial_llist(COMMA, expr)
+    { es }
+;
+record_expr_content:
+  eo = ioption(terminated(simple_expr, WITH))
+  fields = separated_or_terminated_nonempty_list(SEMI, record_expr_field)
+    { eo, fields }
+;
+%inline record_expr_field:
+  | label = mkrhs(label_longident)
+    c = type_constraint?
+    eo = preceded(EQUAL, expr)?
+      { let e =
+          match eo with
+          | None ->
+              (* No pattern; this is a pun. Desugar it. *)
+              exp_of_longident ~loc:$sloc label
+          | Some e ->
+              e
+        in
+        label, mkexp_opt_constraint ~loc:$sloc e c }
+;
+%inline object_expr_content:
+  xs = separated_or_terminated_nonempty_list(SEMI, object_expr_field)
+    { xs }
+;
+%inline object_expr_field:
+    label = mkrhs(label)
+    oe = preceded(EQUAL, expr)?
+      { let e =
+          match oe with
+          | None ->
+              (* No expression; this is a pun. Desugar it. *)
+              exp_of_label ~loc:$sloc label
+          | Some e ->
+              e
+        in
+        label, e }
+;
+%inline expr_semi_list:
+  es = separated_or_terminated_nonempty_list(SEMI, expr)
+    { es }
+;
+type_constraint:
+    COLON core_type                             { (Some $2, None) }
+  | COLON core_type COLONGREATER core_type      { (Some $2, Some $4) }
+  | COLONGREATER core_type                      { (None, Some $2) }
+  | COLON error                                 { syntax_error() }
+  | COLONGREATER error                          { syntax_error() }
+;
+
+/* Patterns */
+
+(* Whereas [pattern] is an arbitrary pattern, [pattern_no_exn] is a pattern
+   that does not begin with the [EXCEPTION] keyword. Thus, [pattern_no_exn]
+   is the intersection of the context-free language [pattern] with the
+   regular language [^EXCEPTION .*].
+
+   Ideally, we would like to use [pattern] everywhere and check in a later
+   phase that EXCEPTION patterns are used only where they are allowed (there
+   is code in typing/typecore.ml to this end). Unfortunately, in the
+   definition of [let_binding_body], we cannot allow [pattern]. That would
+   create a shift/reduce conflict: upon seeing LET EXCEPTION ..., the parser
+   wouldn't know whether this is the beginning of a LET EXCEPTION construct or
+   the beginning of a LET construct whose pattern happens to begin with
+   EXCEPTION. The conflict is avoided there by using [pattern_no_exn] in the
+   definition of [let_binding_body].
+
+   In order to avoid duplication between the definitions of [pattern] and
+   [pattern_no_exn], we create a parameterized definition [pattern_(self)]
+   and instantiate it twice. *)
+
+pattern:
+    pattern_(pattern)
+      { $1 }
+  | EXCEPTION ext_attributes pattern %prec prec_constr_appl
+      { mkpat_attrs ~loc:$sloc (Ppat_exception $3) $2}
+;
+
+pattern_no_exn:
+    pattern_(pattern_no_exn)
+      { $1 }
+;
+
+%inline pattern_(self):
+  | self COLONCOLON pattern
+      { mkpat_cons ~loc:$sloc $loc($2) (ghpat ~loc:$sloc (Ppat_tuple[$1;$3])) }
+  | self attribute
+      { Pat.attr $1 $2 }
+  | pattern_gen
+      { $1 }
+  | mkpat(
+      self AS mkrhs(val_ident)
+        { Ppat_alias($1, $3) }
+    | self AS error
+        { expecting $loc($3) "identifier" }
+    | pattern_comma_list(self) %prec below_COMMA
+        { Ppat_tuple(List.rev $1) }
+    | self COLONCOLON error
+        { expecting $loc($3) "pattern" }
+    | self BAR pattern
+        { Ppat_or($1, $3) }
+    | self BAR error
+        { expecting $loc($3) "pattern" }
+  ) { $1 }
+;
+
+pattern_gen:
+    simple_pattern
+      { $1 }
+  | mkpat(
+      mkrhs(constr_longident) pattern %prec prec_constr_appl
+        { Ppat_construct($1, Some $2) }
+    | name_tag pattern %prec prec_constr_appl
+        { Ppat_variant($1, Some $2) }
+    ) { $1 }
+  | LAZY ext_attributes simple_pattern
+      { mkpat_attrs ~loc:$sloc (Ppat_lazy $3) $2}
+;
+simple_pattern:
+    mkpat(mkrhs(val_ident) %prec below_EQUAL
+      { Ppat_var ($1) })
+      { $1 }
+  | simple_pattern_not_ident { $1 }
+;
+
+simple_pattern_not_ident:
+  | LPAREN pattern RPAREN
+      { reloc_pat ~loc:$sloc $2 }
+  | simple_delimited_pattern
+      { $1 }
+  | LPAREN MODULE ext_attributes mkrhs(module_name) RPAREN
+      { mkpat_attrs ~loc:$sloc (Ppat_unpack $4) $3 }
+  | LPAREN MODULE ext_attributes mkrhs(module_name) COLON package_type RPAREN
+      { mkpat_attrs ~loc:$sloc
+          (Ppat_constraint(mkpat ~loc:$loc($4) (Ppat_unpack $4), $6))
+          $3 }
+  | mkpat(simple_pattern_not_ident_)
+      { $1 }
+;
+%inline simple_pattern_not_ident_:
+  | UNDERSCORE
+      { Ppat_any }
+  | signed_constant
+      { Ppat_constant $1 }
+  | signed_constant DOTDOT signed_constant
+      { Ppat_interval ($1, $3) }
+  | mkrhs(constr_longident)
+      { Ppat_construct($1, None) }
+  | name_tag
+      { Ppat_variant($1, None) }
+  | HASH mkrhs(type_longident)
+      { Ppat_type ($2) }
+  | mkrhs(mod_longident) DOT simple_delimited_pattern
+      { Ppat_open($1, $3) }
+  | mkrhs(mod_longident) DOT mkrhs(LBRACKET RBRACKET {Lident "[]"})
+    { Ppat_open($1, mkpat ~loc:$sloc (Ppat_construct($3, None))) }
+  | mkrhs(mod_longident) DOT mkrhs(LPAREN RPAREN {Lident "()"})
+    { Ppat_open($1, mkpat ~loc:$sloc (Ppat_construct($3, None))) }
+  | mkrhs(mod_longident) DOT LPAREN pattern RPAREN
+      { Ppat_open ($1, $4) }
+  | mod_longident DOT LPAREN pattern error
+      { unclosed "(" $loc($3) ")" $loc($5)  }
+  | mod_longident DOT LPAREN error
+      { expecting $loc($4) "pattern" }
+  | LPAREN pattern error
+      { unclosed "(" $loc($1) ")" $loc($3) }
+  | LPAREN pattern COLON core_type RPAREN
+      { Ppat_constraint($2, $4) }
+  | LPAREN pattern COLON core_type error
+      { unclosed "(" $loc($1) ")" $loc($5) }
+  | LPAREN pattern COLON error
+      { expecting $loc($4) "type" }
+  | LPAREN MODULE ext_attributes module_name COLON package_type
+    error
+      { unclosed "(" $loc($1) ")" $loc($7) }
+  | extension
+      { Ppat_extension $1 }
+;
+
+simple_delimited_pattern:
+  mkpat(
+      LBRACE record_pat_content RBRACE
+      { let (fields, closed) = $2 in
+        Ppat_record(fields, closed) }
+    | LBRACE record_pat_content error
+      { unclosed "{" $loc($1) "}" $loc($3) }
+    | LBRACKET pattern_semi_list RBRACKET
+      { fst (mktailpat $loc($3) $2) }
+    | LBRACKET pattern_semi_list error
+      { unclosed "[" $loc($1) "]" $loc($3) }
+    | LBRACKETBAR pattern_semi_list BARRBRACKET
+      { Ppat_array $2 }
+    | LBRACKETBAR BARRBRACKET
+      { Ppat_array [] }
+    | LBRACKETBAR pattern_semi_list error
+      { unclosed "[|" $loc($1) "|]" $loc($3) }
+  ) { $1 }
+
+pattern_comma_list(self):
+    pattern_comma_list(self) COMMA pattern      { $3 :: $1 }
+  | self COMMA pattern                          { [$3; $1] }
+  | self COMMA error                            { expecting $loc($3) "pattern" }
+;
+%inline pattern_semi_list:
+  ps = separated_or_terminated_nonempty_list(SEMI, pattern)
+    { ps }
+;
+(* A label-pattern list is a nonempty list of label-pattern pairs, optionally
+   followed with an UNDERSCORE, separated-or-terminated with semicolons. *)
+%inline record_pat_content:
+  listx(SEMI, record_pat_field, UNDERSCORE)
+    { let fields, closed = $1 in
+      let closed = match closed with Some () -> Open | None -> Closed in
+      fields, closed }
+;
+%inline record_pat_field:
+  label = mkrhs(label_longident)
+  octy = preceded(COLON, core_type)?
+  opat = preceded(EQUAL, pattern)?
+    { let label, pat =
+        match opat with
+        | None ->
+            (* No pattern; this is a pun. Desugar it.
+               But that the pattern was there and the label reconstructed (which
+               piece of AST is marked as ghost is important for warning
+               emission). *)
+            make_ghost label, pat_of_label label
+        | Some pat ->
+            label, pat
+      in
+      label, mkpat_opt_constraint ~loc:$sloc pat octy
+    }
+;
+
+/* Value descriptions */
+
+value_description:
+  VAL
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(val_ident)
+  COLON
+  ty = core_type
+  attrs2 = post_item_attributes
+    { let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let docs = symbol_docs $sloc in
+      Val.mk id ty ~attrs ~loc ~docs,
+      ext }
+;
+
+/* Primitive declarations */
+
+primitive_declaration:
+  EXTERNAL
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(val_ident)
+  COLON
+  ty = core_type
+  EQUAL
+  prim = raw_string+
+  attrs2 = post_item_attributes
+    { let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let docs = symbol_docs $sloc in
+      Val.mk id ty ~prim ~attrs ~loc ~docs,
+      ext }
+;
+
+(* Type declarations and type substitutions. *)
+
+(* Type declarations [type t = u] and type substitutions [type t := u] are very
+   similar, so we view them as instances of [generic_type_declarations]. In the
+   case of a type declaration, the use of [nonrec_flag] means that [NONREC] may
+   be absent or present, whereas in the case of a type substitution, the use of
+   [no_nonrec_flag] means that [NONREC] must be absent. The use of [type_kind]
+   versus [type_subst_kind] means that in the first case, we expect an [EQUAL]
+   sign, whereas in the second case, we expect [COLONEQUAL]. *)
+
+%inline type_declarations:
+  generic_type_declarations(nonrec_flag, type_kind)
+    { $1 }
+;
+
+%inline type_subst_declarations:
+  generic_type_declarations(no_nonrec_flag, type_subst_kind)
+    { $1 }
+;
+
+(* A set of type declarations or substitutions begins with a
+   [generic_type_declaration] and continues with a possibly empty list of
+   [generic_and_type_declaration]s. *)
+
+%inline generic_type_declarations(flag, kind):
+  xlist(
+    generic_type_declaration(flag, kind),
+    generic_and_type_declaration(kind)
+  )
+  { $1 }
+;
+
+(* [generic_type_declaration] and [generic_and_type_declaration] look similar,
+   but are in reality different enough that it is difficult to share anything
+   between them. *)
+
+generic_type_declaration(flag, kind):
+  TYPE
+  ext = ext
+  attrs1 = attributes
+  flag = flag
+  params = type_parameters
+  id = mkrhs(LIDENT)
+  kind_priv_manifest = kind
+  cstrs = constraints
+  attrs2 = post_item_attributes
+    {
+      let (kind, priv, manifest) = kind_priv_manifest in
+      let docs = symbol_docs $sloc in
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      (flag, ext),
+      Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs
+    }
+;
+%inline generic_and_type_declaration(kind):
+  AND
+  attrs1 = attributes
+  params = type_parameters
+  id = mkrhs(LIDENT)
+  kind_priv_manifest = kind
+  cstrs = constraints
+  attrs2 = post_item_attributes
+    {
+      let (kind, priv, manifest) = kind_priv_manifest in
+      let docs = symbol_docs $sloc in
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let text = symbol_text $symbolstartpos in
+      Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ~text
+    }
+;
+%inline constraints:
+  llist(preceded(CONSTRAINT, constrain))
+    { $1 }
+;
+(* Lots of %inline expansion are required for [nonempty_type_kind] to be
+   LR(1). At the cost of some manual expansion, it would be possible to give a
+   definition that leads to a smaller grammar (after expansion) and therefore
+   a smaller automaton. *)
+nonempty_type_kind:
+  | priv = inline_private_flag
+    ty = core_type
+      { (Ptype_abstract, priv, Some ty) }
+  | oty = type_synonym
+    priv = inline_private_flag
+    cs = constructor_declarations
+      { (Ptype_variant cs, priv, oty) }
+  | oty = type_synonym
+    priv = inline_private_flag
+    DOTDOT
+      { (Ptype_open, priv, oty) }
+  | oty = type_synonym
+    priv = inline_private_flag
+    LBRACE ls = label_declarations RBRACE
+      { (Ptype_record ls, priv, oty) }
+;
+%inline type_synonym:
+  ioption(terminated(core_type, EQUAL))
+    { $1 }
+;
+type_kind:
+    /*empty*/
+      { (Ptype_abstract, Public, None) }
+  | EQUAL nonempty_type_kind
+      { $2 }
+;
+%inline type_subst_kind:
+    COLONEQUAL nonempty_type_kind
+      { $2 }
+;
+type_parameters:
+    /* empty */
+      { [] }
+  | p = type_parameter
+      { [p] }
+  | LPAREN ps = separated_nonempty_llist(COMMA, type_parameter) RPAREN
+      { ps }
+;
+type_parameter:
+    type_variance type_variable        { $2, $1 }
+;
+type_variable:
+  mktyp(
+    QUOTE tyvar = ident
+      { Ptyp_var tyvar }
+  | UNDERSCORE
+      { Ptyp_any }
+  ) { $1 }
+;
+
+type_variance:
+    /* empty */                             { NoVariance, NoInjectivity }
+  | PLUS                                    { Covariant, NoInjectivity }
+  | MINUS                                   { Contravariant, NoInjectivity }
+  | BANG                                    { NoVariance, Injective }
+  | PLUS BANG | BANG PLUS                   { Covariant, Injective }
+  | MINUS BANG | BANG MINUS                 { Contravariant, Injective }
+  | INFIXOP2
+      { if $1 = "+!" then Covariant, Injective else
+        if $1 = "-!" then Contravariant, Injective else
+        expecting $loc($1) "type_variance" }
+  | PREFIXOP
+      { if $1 = "!+" then Covariant, Injective else
+        if $1 = "!-" then Contravariant, Injective else
+        expecting $loc($1) "type_variance" }
+;
+
+(* A sequence of constructor declarations is either a single BAR, which
+   means that the list is empty, or a nonempty BAR-separated list of
+   declarations, with an optional leading BAR. *)
+constructor_declarations:
+  | BAR
+      { [] }
+  | cs = bar_llist(constructor_declaration)
+      { cs }
+;
+(* A constructor declaration begins with an opening symbol, which can
+   be either epsilon or BAR. Note that this opening symbol is included
+   in the footprint $sloc. *)
+(* Because [constructor_declaration] and [extension_constructor_declaration]
+   are identical except for their semantic actions, we introduce the symbol
+   [generic_constructor_declaration], whose semantic action is neutral -- it
+   merely returns a tuple. *)
+generic_constructor_declaration(opening):
+  opening
+  cid = mkrhs(constr_ident)
+  args_res = generalized_constructor_arguments
+  attrs = attributes
+    {
+      let args, res = args_res in
+      let info = symbol_info $endpos in
+      let loc = make_loc $sloc in
+      cid, args, res, attrs, loc, info
+    }
+;
+%inline constructor_declaration(opening):
+  d = generic_constructor_declaration(opening)
+    {
+      let cid, args, res, attrs, loc, info = d in
+      Type.constructor cid ~args ?res ~attrs ~loc ~info
+    }
+;
+str_exception_declaration:
+  sig_exception_declaration
+    { $1 }
+| EXCEPTION
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(constr_ident)
+  EQUAL
+  lid = mkrhs(constr_longident)
+  attrs2 = attributes
+  attrs = post_item_attributes
+  { let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Te.mk_exception ~attrs
+      (Te.rebind id lid ~attrs:(attrs1 @ attrs2) ~loc ~docs)
+    , ext }
+;
+sig_exception_declaration:
+  EXCEPTION
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(constr_ident)
+  args_res = generalized_constructor_arguments
+  attrs2 = attributes
+  attrs = post_item_attributes
+    { let args, res = args_res in
+      let loc = make_loc ($startpos, $endpos(attrs2)) in
+      let docs = symbol_docs $sloc in
+      Te.mk_exception ~attrs
+        (Te.decl id ~args ?res ~attrs:(attrs1 @ attrs2) ~loc ~docs)
+      , ext }
+;
+%inline let_exception_declaration:
+    mkrhs(constr_ident) generalized_constructor_arguments attributes
+      { let args, res = $2 in
+        Te.decl $1 ~args ?res ~attrs:$3 ~loc:(make_loc $sloc) }
+;
+generalized_constructor_arguments:
+    /*empty*/                     { (Pcstr_tuple [],None) }
+  | OF constructor_arguments      { ($2,None) }
+  | COLON constructor_arguments MINUSGREATER atomic_type %prec below_HASH
+                                  { ($2,Some $4) }
+  | COLON atomic_type %prec below_HASH
+                                  { (Pcstr_tuple [],Some $2) }
+;
+
+constructor_arguments:
+  | tys = inline_separated_nonempty_llist(STAR, atomic_type)
+    %prec below_HASH
+      { Pcstr_tuple tys }
+  | LBRACE label_declarations RBRACE
+      { Pcstr_record $2 }
+;
+label_declarations:
+    label_declaration                           { [$1] }
+  | label_declaration_semi                      { [$1] }
+  | label_declaration_semi label_declarations   { $1 :: $2 }
+;
+label_declaration:
+    mutable_flag mkrhs(label) COLON poly_type_no_attr attributes
+      { let info = symbol_info $endpos in
+        Type.field $2 $4 ~mut:$1 ~attrs:$5 ~loc:(make_loc $sloc) ~info }
+;
+label_declaration_semi:
+    mutable_flag mkrhs(label) COLON poly_type_no_attr attributes SEMI attributes
+      { let info =
+          match rhs_info $endpos($5) with
+          | Some _ as info_before_semi -> info_before_semi
+          | None -> symbol_info $endpos
+       in
+       Type.field $2 $4 ~mut:$1 ~attrs:($5 @ $7) ~loc:(make_loc $sloc) ~info }
+;
+
+/* Type Extensions */
+
+%inline str_type_extension:
+  type_extension(extension_constructor)
+    { $1 }
+;
+%inline sig_type_extension:
+  type_extension(extension_constructor_declaration)
+    { $1 }
+;
+%inline type_extension(declaration):
+  TYPE
+  ext = ext
+  attrs1 = attributes
+  no_nonrec_flag
+  params = type_parameters
+  tid = mkrhs(type_longident)
+  PLUSEQ
+  priv = private_flag
+  cs = bar_llist(declaration)
+  attrs2 = post_item_attributes
+    { let docs = symbol_docs $sloc in
+      let attrs = attrs1 @ attrs2 in
+      Te.mk tid cs ~params ~priv ~attrs ~docs,
+      ext }
+;
+%inline extension_constructor(opening):
+    extension_constructor_declaration(opening)
+      { $1 }
+  | extension_constructor_rebind(opening)
+      { $1 }
+;
+%inline extension_constructor_declaration(opening):
+  d = generic_constructor_declaration(opening)
+    {
+      let cid, args, res, attrs, loc, info = d in
+      Te.decl cid ~args ?res ~attrs ~loc ~info
+    }
+;
+extension_constructor_rebind(opening):
+  opening
+  cid = mkrhs(constr_ident)
+  EQUAL
+  lid = mkrhs(constr_longident)
+  attrs = attributes
+      { let info = symbol_info $endpos in
+        Te.rebind cid lid ~attrs ~loc:(make_loc $sloc) ~info }
+;
+
+/* "with" constraints (additional type equations over signature components) */
+
+with_constraint:
+    TYPE type_parameters mkrhs(label_longident) with_type_binder
+    core_type_no_attr constraints
+      { let lident = loc_last $3 in
+        Pwith_type
+          ($3,
+           (Type.mk lident
+              ~params:$2
+              ~cstrs:$6
+              ~manifest:$5
+              ~priv:$4
+              ~loc:(make_loc $sloc))) }
+    /* used label_longident instead of type_longident to disallow
+       functor applications in type path */
+  | TYPE type_parameters mkrhs(label_longident)
+    COLONEQUAL core_type_no_attr
+      { let lident = loc_last $3 in
+        Pwith_typesubst
+         ($3,
+           (Type.mk lident
+              ~params:$2
+              ~manifest:$5
+              ~loc:(make_loc $sloc))) }
+  | MODULE mkrhs(mod_longident) EQUAL mkrhs(mod_ext_longident)
+      { Pwith_module ($2, $4) }
+  | MODULE mkrhs(mod_longident) COLONEQUAL mkrhs(mod_ext_longident)
+      { Pwith_modsubst ($2, $4) }
+;
+with_type_binder:
+    EQUAL          { Public }
+  | EQUAL PRIVATE  { Private }
+;
+
+/* Polymorphic types */
+
+%inline typevar:
+  QUOTE mkrhs(ident)
+    { $2 }
+;
+%inline typevar_list:
+  nonempty_llist(typevar)
+    { $1 }
+;
+%inline poly(X):
+  typevar_list DOT X
+    { Ptyp_poly($1, $3) }
+;
+possibly_poly(X):
+  X
+    { $1 }
+| mktyp(poly(X))
+    { $1 }
+;
+%inline poly_type:
+  possibly_poly(core_type)
+    { $1 }
+;
+%inline poly_type_no_attr:
+  possibly_poly(core_type_no_attr)
+    { $1 }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+(* Core language types. *)
+
+(* A core type (core_type) is a core type without attributes (core_type_no_attr)
+   followed with a list of attributes. *)
+core_type:
+    core_type_no_attr
+      { $1 }
+  | core_type attribute
+      { Typ.attr $1 $2 }
+;
+
+(* A core type without attributes is currently defined as an alias type, but
+   this could change in the future if new forms of types are introduced. From
+   the outside, one should use core_type_no_attr. *)
+%inline core_type_no_attr:
+  alias_type
+    { $1 }
+;
+
+(* Alias types include:
+   - function types (see below);
+   - proper alias types:                  'a -> int as 'a
+ *)
+alias_type:
+    function_type
+      { $1 }
+  | mktyp(
+      ty = alias_type AS QUOTE tyvar = ident
+        { Ptyp_alias(ty, tyvar) }
+    )
+    { $1 }
+;
+
+(* Function types include:
+   - tuple types (see below);
+   - proper function types:               int -> int
+                                          foo: int -> int
+                                          ?foo: int -> int
+ *)
+function_type:
+  | ty = tuple_type
+    %prec MINUSGREATER
+      { ty }
+  | mktyp(
+      label = arg_label
+      domain = extra_rhs(tuple_type)
+      MINUSGREATER
+      codomain = function_type
+        { Ptyp_arrow(label, domain, codomain) }
+    )
+    { $1 }
+;
+%inline arg_label:
+  | label = optlabel
+      { Optional label }
+  | label = LIDENT COLON
+      { Labelled label }
+  | /* empty */
+      { Nolabel }
+;
+(* Tuple types include:
+   - atomic types (see below);
+   - proper tuple types:                  int * int * int list
+   A proper tuple type is a star-separated list of at least two atomic types.
+ *)
+tuple_type:
+  | ty = atomic_type
+    %prec below_HASH
+      { ty }
+  | mktyp(
+      tys = separated_nontrivial_llist(STAR, atomic_type)
+        { Ptyp_tuple tys }
+    )
+    { $1 }
+;
+
+(* Atomic types are the most basic level in the syntax of types.
+   Atomic types include:
+   - types between parentheses:           (int -> int)
+   - first-class module types:            (module S)
+   - type variables:                      'a
+   - applications of type constructors:   int, int list, int option list
+   - variant types:                       [`A]
+ *)
+atomic_type:
+  | LPAREN core_type RPAREN
+      { $2 }
+  | LPAREN MODULE ext_attributes package_type RPAREN
+      { wrap_typ_attrs ~loc:$sloc (reloc_typ ~loc:$sloc $4) $3 }
+  | mktyp( /* begin mktyp group */
+      QUOTE ident
+        { Ptyp_var $2 }
+    | UNDERSCORE
+        { Ptyp_any }
+    | tys = actual_type_parameters
+      tid = mkrhs(type_longident)
+        { Ptyp_constr(tid, tys) }
+    | LESS meth_list GREATER
+        { let (f, c) = $2 in Ptyp_object (f, c) }
+    | LESS GREATER
+        { Ptyp_object ([], Closed) }
+    | tys = actual_type_parameters
+      HASH
+      cid = mkrhs(clty_longident)
+        { Ptyp_class(cid, tys) }
+    | LBRACKET tag_field RBRACKET
+        (* not row_field; see CONFLICTS *)
+        { Ptyp_variant([$2], Closed, None) }
+    | LBRACKET BAR row_field_list RBRACKET
+        { Ptyp_variant($3, Closed, None) }
+    | LBRACKET row_field BAR row_field_list RBRACKET
+        { Ptyp_variant($2 :: $4, Closed, None) }
+    | LBRACKETGREATER BAR? row_field_list RBRACKET
+        { Ptyp_variant($3, Open, None) }
+    | LBRACKETGREATER RBRACKET
+        { Ptyp_variant([], Open, None) }
+    | LBRACKETLESS BAR? row_field_list RBRACKET
+        { Ptyp_variant($3, Closed, Some []) }
+    | LBRACKETLESS BAR? row_field_list GREATER name_tag_list RBRACKET
+        { Ptyp_variant($3, Closed, Some $5) }
+    | extension
+        { Ptyp_extension $1 }
+  )
+  { $1 } /* end mktyp group */
+;
+
+(* This is the syntax of the actual type parameters in an application of
+   a type constructor, such as int, int list, or (int, bool) Hashtbl.t.
+   We allow one of the following:
+   - zero parameters;
+   - one parameter:
+     an atomic type;
+     among other things, this can be an arbitrary type between parentheses;
+   - two or more parameters:
+     arbitrary types, between parentheses, separated with commas.
+ *)
+%inline actual_type_parameters:
+  | /* empty */
+      { [] }
+  | ty = atomic_type
+      { [ty] }
+  | LPAREN tys = separated_nontrivial_llist(COMMA, core_type) RPAREN
+      { tys }
+;
+
+%inline package_type: module_type
+      { let (lid, cstrs, attrs) = package_type_of_module_type $1 in
+        let descr = Ptyp_package (lid, cstrs) in
+        mktyp ~loc:$sloc ~attrs descr }
+;
+%inline row_field_list:
+  separated_nonempty_llist(BAR, row_field)
+    { $1 }
+;
+row_field:
+    tag_field
+      { $1 }
+  | core_type
+      { Rf.inherit_ ~loc:(make_loc $sloc) $1 }
+;
+tag_field:
+    mkrhs(name_tag) OF opt_ampersand amper_type_list attributes
+      { let info = symbol_info $endpos in
+        let attrs = add_info_attrs info $5 in
+        Rf.tag ~loc:(make_loc $sloc) ~attrs $1 $3 $4 }
+  | mkrhs(name_tag) attributes
+      { let info = symbol_info $endpos in
+        let attrs = add_info_attrs info $2 in
+        Rf.tag ~loc:(make_loc $sloc) ~attrs $1 true [] }
+;
+opt_ampersand:
+    AMPERSAND                                   { true }
+  | /* empty */                                 { false }
+;
+%inline amper_type_list:
+  separated_nonempty_llist(AMPERSAND, core_type_no_attr)
+    { $1 }
+;
+%inline name_tag_list:
+  nonempty_llist(name_tag)
+    { $1 }
+;
+(* A method list (in an object type). *)
+meth_list:
+    head = field_semi         tail = meth_list
+  | head = inherit_field SEMI tail = meth_list
+      { let (f, c) = tail in (head :: f, c) }
+  | head = field_semi
+  | head = inherit_field SEMI
+      { [head], Closed }
+  | head = field
+  | head = inherit_field
+      { [head], Closed }
+  | DOTDOT
+      { [], Open }
+;
+%inline field:
+  mkrhs(label) COLON poly_type_no_attr attributes
+    { let info = symbol_info $endpos in
+      let attrs = add_info_attrs info $4 in
+      Of.tag ~loc:(make_loc $sloc) ~attrs $1 $3 }
+;
+
+%inline field_semi:
+  mkrhs(label) COLON poly_type_no_attr attributes SEMI attributes
+    { let info =
+        match rhs_info $endpos($4) with
+        | Some _ as info_before_semi -> info_before_semi
+        | None -> symbol_info $endpos
+      in
+      let attrs = add_info_attrs info ($4 @ $6) in
+      Of.tag ~loc:(make_loc $sloc) ~attrs $1 $3 }
+;
+
+%inline inherit_field:
+  ty = atomic_type
+    { Of.inherit_ ~loc:(make_loc $sloc) ty }
+;
+
+%inline label:
+    LIDENT                                      { $1 }
+;
+
+/* Constants */
+
+constant:
+  | INT          { let (n, m) = $1 in Pconst_integer (n, m) }
+  | CHAR         { Pconst_char $1 }
+  | STRING       { let (s, strloc, d) = $1 in Pconst_string (s, strloc, d) }
+  | FLOAT        { let (f, m) = $1 in Pconst_float (f, m) }
+;
+signed_constant:
+    constant     { $1 }
+  | MINUS INT    { let (n, m) = $2 in Pconst_integer("-" ^ n, m) }
+  | MINUS FLOAT  { let (f, m) = $2 in Pconst_float("-" ^ f, m) }
+  | PLUS INT     { let (n, m) = $2 in Pconst_integer (n, m) }
+  | PLUS FLOAT   { let (f, m) = $2 in Pconst_float(f, m) }
+;
+
+/* Identifiers and long identifiers */
+
+ident:
+    UIDENT                    { $1 }
+  | LIDENT                    { $1 }
+;
+val_extra_ident:
+  | LPAREN operator RPAREN    { $2 }
+  | LPAREN operator error     { unclosed "(" $loc($1) ")" $loc($3) }
+  | LPAREN error              { expecting $loc($2) "operator" }
+  | LPAREN MODULE error       { expecting $loc($3) "module-expr" }
+;
+val_ident:
+    LIDENT                    { $1 }
+  | val_extra_ident           { $1 }
+;
+operator:
+    PREFIXOP                                    { $1 }
+  | LETOP                                       { $1 }
+  | ANDOP                                       { $1 }
+  | DOTOP LPAREN index_mod RPAREN               { "."^ $1 ^"(" ^ $3 ^ ")" }
+  | DOTOP LPAREN index_mod RPAREN LESSMINUS     { "."^ $1 ^ "(" ^ $3 ^ ")<-" }
+  | DOTOP LBRACKET index_mod RBRACKET           { "."^ $1 ^"[" ^ $3 ^ "]" }
+  | DOTOP LBRACKET index_mod RBRACKET LESSMINUS { "."^ $1 ^ "[" ^ $3 ^ "]<-" }
+  | DOTOP LBRACE index_mod RBRACE               { "."^ $1 ^"{" ^ $3 ^ "}" }
+  | DOTOP LBRACE index_mod RBRACE LESSMINUS     { "."^ $1 ^ "{" ^ $3 ^ "}<-" }
+  | HASHOP                                      { $1 }
+  | BANG                                        { "!" }
+  | infix_operator                              { $1 }
+;
+%inline infix_operator:
+  | op = INFIXOP0 { op }
+  | op = INFIXOP1 { op }
+  | op = INFIXOP2 { op }
+  | op = INFIXOP3 { op }
+  | op = INFIXOP4 { op }
+  | PLUS           {"+"}
+  | PLUSDOT       {"+."}
+  | PLUSEQ        {"+="}
+  | MINUS          {"-"}
+  | MINUSDOT      {"-."}
+  | STAR           {"*"}
+  | PERCENT        {"%"}
+  | EQUAL          {"="}
+  | LESS           {"<"}
+  | GREATER        {">"}
+  | OR            {"or"}
+  | BARBAR        {"||"}
+  | AMPERSAND      {"&"}
+  | AMPERAMPER    {"&&"}
+  | COLONEQUAL    {":="}
+;
+index_mod:
+| { "" }
+| SEMI DOTDOT { ";.." }
+;
+
+%inline constr_extra_ident:
+  | LPAREN COLONCOLON RPAREN                    { "::" }
+;
+constr_extra_nonprefix_ident:
+  | LBRACKET RBRACKET                           { "[]" }
+  | LPAREN RPAREN                               { "()" }
+  | FALSE                                       { "false" }
+  | TRUE                                        { "true" }
+;
+constr_ident:
+    UIDENT                                      { $1 }
+  | constr_extra_ident                          { $1 }
+  | constr_extra_nonprefix_ident                { $1 }
+;
+constr_longident:
+    mod_longident       %prec below_DOT  { $1 } /* A.B.x vs (A).B.x */
+  | mod_longident DOT constr_extra_ident { Ldot($1,$3) }
+  | constr_extra_ident                   { Lident $1 }
+  | constr_extra_nonprefix_ident         { Lident $1 }
+;
+mk_longident(prefix,final):
+   | final            { Lident $1 }
+   | prefix DOT final { Ldot($1,$3) }
+;
+val_longident:
+    mk_longident(mod_longident, val_ident) { $1 }
+;
+label_longident:
+    mk_longident(mod_longident, LIDENT) { $1 }
+;
+type_longident:
+    mk_longident(mod_ext_longident, LIDENT)  { $1 }
+;
+mod_longident:
+    mk_longident(mod_longident, UIDENT)  { $1 }
+;
+mod_ext_longident:
+    mk_longident(mod_ext_longident, UIDENT) { $1 }
+  | mod_ext_longident LPAREN mod_ext_longident RPAREN
+      { lapply ~loc:$sloc $1 $3 }
+  | mod_ext_longident LPAREN error
+      { expecting $loc($3) "module path" }
+;
+mty_longident:
+    mk_longident(mod_ext_longident,ident) { $1 }
+;
+clty_longident:
+    mk_longident(mod_ext_longident,LIDENT) { $1 }
+;
+class_longident:
+   mk_longident(mod_longident,LIDENT) { $1 }
+;
+
+/* For compiler-libs: parse all valid longidents and a little more:
+   final identifiers which are value specific are accepted even when
+   the path prefix is only valid for types: (e.g. F(X).(::)) */
+any_longident:
+  | mk_longident (mod_ext_longident,
+     ident | constr_extra_ident | val_extra_ident { $1 }
+    ) { $1 }
+  | constr_extra_nonprefix_ident { Lident $1 }
+;
+
+/* Toplevel directives */
+
+toplevel_directive:
+  HASH dir = mkrhs(ident)
+  arg = ioption(mk_directive_arg(toplevel_directive_argument))
+    { mk_directive ~loc:$sloc dir arg }
+;
+
+%inline toplevel_directive_argument:
+  | STRING        { let (s, _, _) = $1 in Pdir_string s }
+  | INT           { let (n, m) = $1 in Pdir_int (n ,m) }
+  | val_longident { Pdir_ident $1 }
+  | mod_longident { Pdir_ident $1 }
+  | FALSE         { Pdir_bool false }
+  | TRUE          { Pdir_bool true }
+;
+
+/* Miscellaneous */
+
+(* The symbol epsilon can be used instead of an /* empty */ comment. *)
+%inline epsilon:
+  /* empty */
+    { () }
+;
+
+%inline raw_string:
+  s = STRING
+    { let body, _, _ = s in body }
+;
+
+name_tag:
+    BACKQUOTE ident                             { $2 }
+;
+rec_flag:
+    /* empty */                                 { Nonrecursive }
+  | REC                                         { Recursive }
+;
+%inline nonrec_flag:
+    /* empty */                                 { Recursive }
+  | NONREC                                      { Nonrecursive }
+;
+%inline no_nonrec_flag:
+    /* empty */ { Recursive }
+  | NONREC      { not_expecting $loc "nonrec flag" }
+;
+direction_flag:
+    TO                                          { Upto }
+  | DOWNTO                                      { Downto }
+;
+private_flag:
+  inline_private_flag
+    { $1 }
+;
+%inline inline_private_flag:
+    /* empty */                                 { Public }
+  | PRIVATE                                     { Private }
+;
+mutable_flag:
+    /* empty */                                 { Immutable }
+  | MUTABLE                                     { Mutable }
+;
+virtual_flag:
+    /* empty */                                 { Concrete }
+  | VIRTUAL                                     { Virtual }
+;
+mutable_virtual_flags:
+    /* empty */
+      { Immutable, Concrete }
+  | MUTABLE
+      { Mutable, Concrete }
+  | VIRTUAL
+      { Immutable, Virtual }
+  | MUTABLE VIRTUAL
+  | VIRTUAL MUTABLE
+      { Mutable, Virtual }
+;
+private_virtual_flags:
+    /* empty */  { Public, Concrete }
+  | PRIVATE { Private, Concrete }
+  | VIRTUAL { Public, Virtual }
+  | PRIVATE VIRTUAL { Private, Virtual }
+  | VIRTUAL PRIVATE { Private, Virtual }
+;
+(* This nonterminal symbol indicates the definite presence of a VIRTUAL
+   keyword and the possible presence of a MUTABLE keyword. *)
+virtual_with_mutable_flag:
+  | VIRTUAL { Immutable }
+  | MUTABLE VIRTUAL { Mutable }
+  | VIRTUAL MUTABLE { Mutable }
+;
+(* This nonterminal symbol indicates the definite presence of a VIRTUAL
+   keyword and the possible presence of a PRIVATE keyword. *)
+virtual_with_private_flag:
+  | VIRTUAL { Public }
+  | PRIVATE VIRTUAL { Private }
+  | VIRTUAL PRIVATE { Private }
+;
+%inline no_override_flag:
+    /* empty */                                 { Fresh }
+;
+%inline override_flag:
+    /* empty */                                 { Fresh }
+  | BANG                                        { Override }
+;
+subtractive:
+  | MINUS                                       { "-" }
+  | MINUSDOT                                    { "-." }
+;
+additive:
+  | PLUS                                        { "+" }
+  | PLUSDOT                                     { "+." }
+;
+optlabel:
+   | OPTLABEL                                   { $1 }
+   | QUESTION LIDENT COLON                      { $2 }
+;
+
+/* Attributes and extensions */
+
+single_attr_id:
+    LIDENT { $1 }
+  | UIDENT { $1 }
+  | AND { "and" }
+  | AS { "as" }
+  | ASSERT { "assert" }
+  | BEGIN { "begin" }
+  | CLASS { "class" }
+  | CONSTRAINT { "constraint" }
+  | DO { "do" }
+  | DONE { "done" }
+  | DOWNTO { "downto" }
+  | ELSE { "else" }
+  | END { "end" }
+  | EXCEPTION { "exception" }
+  | EXTERNAL { "external" }
+  | FALSE { "false" }
+  | FOR { "for" }
+  | FUN { "fun" }
+  | FUNCTION { "function" }
+  | FUNCTOR { "functor" }
+  | IF { "if" }
+  | IN { "in" }
+  | INCLUDE { "include" }
+  | INHERIT { "inherit" }
+  | INITIALIZER { "initializer" }
+  | LAZY { "lazy" }
+  | LET { "let" }
+  | MATCH { "match" }
+  | METHOD { "method" }
+  | MODULE { "module" }
+  | MUTABLE { "mutable" }
+  | NEW { "new" }
+  | NONREC { "nonrec" }
+  | OBJECT { "object" }
+  | OF { "of" }
+  | OPEN { "open" }
+  | OR { "or" }
+  | PRIVATE { "private" }
+  | REC { "rec" }
+  | SIG { "sig" }
+  | STRUCT { "struct" }
+  | THEN { "then" }
+  | TO { "to" }
+  | TRUE { "true" }
+  | TRY { "try" }
+  | TYPE { "type" }
+  | VAL { "val" }
+  | VIRTUAL { "virtual" }
+  | WHEN { "when" }
+  | WHILE { "while" }
+  | WITH { "with" }
+/* mod/land/lor/lxor/lsl/lsr/asr are not supported for now */
+;
+
+attr_id:
+  mkloc(
+      single_attr_id { $1 }
+    | single_attr_id DOT attr_id { $1 ^ "." ^ $3.txt }
+  ) { $1 }
+;
+attribute:
+  LBRACKETAT attr_id payload RBRACKET
+    { Attr.mk ~loc:(make_loc $sloc) $2 $3 }
+;
+post_item_attribute:
+  LBRACKETATAT attr_id payload RBRACKET
+    { Attr.mk ~loc:(make_loc $sloc) $2 $3 }
+;
+floating_attribute:
+  LBRACKETATATAT attr_id payload RBRACKET
+    { mark_symbol_docs $sloc;
+      Attr.mk ~loc:(make_loc $sloc) $2 $3 }
+;
+%inline post_item_attributes:
+  post_item_attribute*
+    { $1 }
+;
+%inline attributes:
+  attribute*
+    { $1 }
+;
+ext:
+  | /* empty */     { None }
+  | PERCENT attr_id { Some $2 }
+;
+%inline no_ext:
+  | /* empty */     { None }
+  | PERCENT attr_id { not_expecting $loc "extension" }
+;
+%inline ext_attributes:
+  ext attributes    { $1, $2 }
+;
+extension:
+  | LBRACKETPERCENT attr_id payload RBRACKET { ($2, $3) }
+  | QUOTED_STRING_EXPR
+    { mk_quotedext ~loc:$sloc $1 }
+;
+item_extension:
+  | LBRACKETPERCENTPERCENT attr_id payload RBRACKET { ($2, $3) }
+  | QUOTED_STRING_ITEM
+    { mk_quotedext ~loc:$sloc $1 }
+;
+payload:
+    structure { PStr $1 }
+  | COLON signature { PSig $2 }
+  | COLON core_type { PTyp $2 }
+  | QUESTION pattern { PPat ($2, None) }
+  | QUESTION pattern WHEN seq_expr { PPat ($2, Some $4) }
+;
+%%
diff --git a/upstream/ocaml_412/parsing/parsetree.mli b/upstream/ocaml_412/parsing/parsetree.mli
new file mode 100644
index 0000000..58239c8
--- /dev/null
+++ b/upstream/ocaml_412/parsing/parsetree.mli
@@ -0,0 +1,970 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Abstract syntax tree produced by parsing
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Asttypes
+
+type constant =
+    Pconst_integer of string * char option
+  (* 3 3l 3L 3n
+
+     Suffixes [g-z][G-Z] are accepted by the parser.
+     Suffixes except 'l', 'L' and 'n' are rejected by the typechecker
+  *)
+  | Pconst_char of char
+  (* 'c' *)
+  | Pconst_string of string * Location.t * string option
+  (* "constant"
+     {delim|other constant|delim}
+
+     The location span the content of the string, without the delimiters.
+  *)
+  | Pconst_float of string * char option
+  (* 3.4 2e5 1.4e-4
+
+     Suffixes [g-z][G-Z] are accepted by the parser.
+     Suffixes are rejected by the typechecker.
+  *)
+
+type location_stack = Location.t list
+
+(** {1 Extension points} *)
+
+type attribute = {
+    attr_name : string loc;
+    attr_payload : payload;
+    attr_loc : Location.t;
+  }
+       (* [@id ARG]
+          [@@id ARG]
+
+          Metadata containers passed around within the AST.
+          The compiler ignores unknown attributes.
+       *)
+
+and extension = string loc * payload
+      (* [%id ARG]
+         [%%id ARG]
+
+         Sub-language placeholder -- rejected by the typechecker.
+      *)
+
+and attributes = attribute list
+
+and payload =
+  | PStr of structure
+  | PSig of signature (* : SIG *)
+  | PTyp of core_type  (* : T *)
+  | PPat of pattern * expression option  (* ? P  or  ? P when E *)
+
+(** {1 Core language} *)
+
+(* Type expressions *)
+
+and core_type =
+    {
+     ptyp_desc: core_type_desc;
+     ptyp_loc: Location.t;
+     ptyp_loc_stack: location_stack;
+     ptyp_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and core_type_desc =
+  | Ptyp_any
+        (*  _ *)
+  | Ptyp_var of string
+        (* 'a *)
+  | Ptyp_arrow of arg_label * core_type * core_type
+        (* T1 -> T2       Simple
+           ~l:T1 -> T2    Labelled
+           ?l:T1 -> T2    Optional
+         *)
+  | Ptyp_tuple of core_type list
+        (* T1 * ... * Tn
+
+           Invariant: n >= 2
+        *)
+  | Ptyp_constr of Longident.t loc * core_type list
+        (* tconstr
+           T tconstr
+           (T1, ..., Tn) tconstr
+         *)
+  | Ptyp_object of object_field list * closed_flag
+        (* < l1:T1; ...; ln:Tn >     (flag = Closed)
+           < l1:T1; ...; ln:Tn; .. > (flag = Open)
+         *)
+  | Ptyp_class of Longident.t loc * core_type list
+        (* #tconstr
+           T #tconstr
+           (T1, ..., Tn) #tconstr
+         *)
+  | Ptyp_alias of core_type * string
+        (* T as 'a *)
+  | Ptyp_variant of row_field list * closed_flag * label list option
+        (* [ `A|`B ]         (flag = Closed; labels = None)
+           [> `A|`B ]        (flag = Open;   labels = None)
+           [< `A|`B ]        (flag = Closed; labels = Some [])
+           [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"])
+         *)
+  | Ptyp_poly of string loc list * core_type
+        (* 'a1 ... 'an. T
+
+           Can only appear in the following context:
+
+           - As the core_type of a Ppat_constraint node corresponding
+             to a constraint on a let-binding: let x : 'a1 ... 'an. T
+             = e ...
+
+           - Under Cfk_virtual for methods (not values).
+
+           - As the core_type of a Pctf_method node.
+
+           - As the core_type of a Pexp_poly node.
+
+           - As the pld_type field of a label_declaration.
+
+           - As a core_type of a Ptyp_object node.
+         *)
+
+  | Ptyp_package of package_type
+        (* (module S) *)
+  | Ptyp_extension of extension
+        (* [%id] *)
+
+and package_type = Longident.t loc * (Longident.t loc * core_type) list
+      (*
+        (module S)
+        (module S with type t1 = T1 and ... and tn = Tn)
+       *)
+
+and row_field = {
+  prf_desc : row_field_desc;
+  prf_loc : Location.t;
+  prf_attributes : attributes;
+}
+
+and row_field_desc =
+  | Rtag of label loc * bool * core_type list
+        (* [`A]                   ( true,  [] )
+           [`A of T]              ( false, [T] )
+           [`A of T1 & .. & Tn]   ( false, [T1;...Tn] )
+           [`A of & T1 & .. & Tn] ( true,  [T1;...Tn] )
+
+          - The 'bool' field is true if the tag contains a
+            constant (empty) constructor.
+          - '&' occurs when several types are used for the same constructor
+            (see 4.2 in the manual)
+        *)
+  | Rinherit of core_type
+        (* [ | t ] *)
+
+and object_field = {
+  pof_desc : object_field_desc;
+  pof_loc : Location.t;
+  pof_attributes : attributes;
+}
+
+and object_field_desc =
+  | Otag of label loc * core_type
+  | Oinherit of core_type
+
+(* Patterns *)
+
+and pattern =
+    {
+     ppat_desc: pattern_desc;
+     ppat_loc: Location.t;
+     ppat_loc_stack: location_stack;
+     ppat_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and pattern_desc =
+  | Ppat_any
+        (* _ *)
+  | Ppat_var of string loc
+        (* x *)
+  | Ppat_alias of pattern * string loc
+        (* P as 'a *)
+  | Ppat_constant of constant
+        (* 1, 'a', "true", 1.0, 1l, 1L, 1n *)
+  | Ppat_interval of constant * constant
+        (* 'a'..'z'
+
+           Other forms of interval are recognized by the parser
+           but rejected by the type-checker. *)
+  | Ppat_tuple of pattern list
+        (* (P1, ..., Pn)
+
+           Invariant: n >= 2
+        *)
+  | Ppat_construct of Longident.t loc * pattern option
+        (* C                None
+           C P              Some P
+           C (P1, ..., Pn)  Some (Ppat_tuple [P1; ...; Pn])
+         *)
+  | Ppat_variant of label * pattern option
+        (* `A             (None)
+           `A P           (Some P)
+         *)
+  | Ppat_record of (Longident.t loc * pattern) list * closed_flag
+        (* { l1=P1; ...; ln=Pn }     (flag = Closed)
+           { l1=P1; ...; ln=Pn; _}   (flag = Open)
+
+           Invariant: n > 0
+         *)
+  | Ppat_array of pattern list
+        (* [| P1; ...; Pn |] *)
+  | Ppat_or of pattern * pattern
+        (* P1 | P2 *)
+  | Ppat_constraint of pattern * core_type
+        (* (P : T) *)
+  | Ppat_type of Longident.t loc
+        (* #tconst *)
+  | Ppat_lazy of pattern
+        (* lazy P *)
+  | Ppat_unpack of string option loc
+        (* (module P)        Some "P"
+           (module _)        None
+
+           Note: (module P : S) is represented as
+           Ppat_constraint(Ppat_unpack, Ptyp_package)
+         *)
+  | Ppat_exception of pattern
+        (* exception P *)
+  | Ppat_extension of extension
+        (* [%id] *)
+  | Ppat_open of Longident.t loc * pattern
+        (* M.(P) *)
+
+(* Value expressions *)
+
+and expression =
+    {
+     pexp_desc: expression_desc;
+     pexp_loc: Location.t;
+     pexp_loc_stack: location_stack;
+     pexp_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and expression_desc =
+  | Pexp_ident of Longident.t loc
+        (* x
+           M.x
+         *)
+  | Pexp_constant of constant
+        (* 1, 'a', "true", 1.0, 1l, 1L, 1n *)
+  | Pexp_let of rec_flag * value_binding list * expression
+        (* let P1 = E1 and ... and Pn = EN in E       (flag = Nonrecursive)
+           let rec P1 = E1 and ... and Pn = EN in E   (flag = Recursive)
+         *)
+  | Pexp_function of case list
+        (* function P1 -> E1 | ... | Pn -> En *)
+  | Pexp_fun of arg_label * expression option * pattern * expression
+        (* fun P -> E1                          (Simple, None)
+           fun ~l:P -> E1                       (Labelled l, None)
+           fun ?l:P -> E1                       (Optional l, None)
+           fun ?l:(P = E0) -> E1                (Optional l, Some E0)
+
+           Notes:
+           - If E0 is provided, only Optional is allowed.
+           - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun.
+           - "let f P = E" is represented using Pexp_fun.
+         *)
+  | Pexp_apply of expression * (arg_label * expression) list
+        (* E0 ~l1:E1 ... ~ln:En
+           li can be empty (non labeled argument) or start with '?'
+           (optional argument).
+
+           Invariant: n > 0
+         *)
+  | Pexp_match of expression * case list
+        (* match E0 with P1 -> E1 | ... | Pn -> En *)
+  | Pexp_try of expression * case list
+        (* try E0 with P1 -> E1 | ... | Pn -> En *)
+  | Pexp_tuple of expression list
+        (* (E1, ..., En)
+
+           Invariant: n >= 2
+        *)
+  | Pexp_construct of Longident.t loc * expression option
+        (* C                None
+           C E              Some E
+           C (E1, ..., En)  Some (Pexp_tuple[E1;...;En])
+        *)
+  | Pexp_variant of label * expression option
+        (* `A             (None)
+           `A E           (Some E)
+         *)
+  | Pexp_record of (Longident.t loc * expression) list * expression option
+        (* { l1=P1; ...; ln=Pn }     (None)
+           { E0 with l1=P1; ...; ln=Pn }   (Some E0)
+
+           Invariant: n > 0
+         *)
+  | Pexp_field of expression * Longident.t loc
+        (* E.l *)
+  | Pexp_setfield of expression * Longident.t loc * expression
+        (* E1.l <- E2 *)
+  | Pexp_array of expression list
+        (* [| E1; ...; En |] *)
+  | Pexp_ifthenelse of expression * expression * expression option
+        (* if E1 then E2 else E3 *)
+  | Pexp_sequence of expression * expression
+        (* E1; E2 *)
+  | Pexp_while of expression * expression
+        (* while E1 do E2 done *)
+  | Pexp_for of
+      pattern *  expression * expression * direction_flag * expression
+        (* for i = E1 to E2 do E3 done      (flag = Upto)
+           for i = E1 downto E2 do E3 done  (flag = Downto)
+         *)
+  | Pexp_constraint of expression * core_type
+        (* (E : T) *)
+  | Pexp_coerce of expression * core_type option * core_type
+        (* (E :> T)        (None, T)
+           (E : T0 :> T)   (Some T0, T)
+         *)
+  | Pexp_send of expression * label loc
+        (*  E # m *)
+  | Pexp_new of Longident.t loc
+        (* new M.c *)
+  | Pexp_setinstvar of label loc * expression
+        (* x <- 2 *)
+  | Pexp_override of (label loc * expression) list
+        (* {< x1 = E1; ...; Xn = En >} *)
+  | Pexp_letmodule of string option loc * module_expr * expression
+        (* let module M = ME in E *)
+  | Pexp_letexception of extension_constructor * expression
+        (* let exception C in E *)
+  | Pexp_assert of expression
+        (* assert E
+           Note: "assert false" is treated in a special way by the
+           type-checker. *)
+  | Pexp_lazy of expression
+        (* lazy E *)
+  | Pexp_poly of expression * core_type option
+        (* Used for method bodies.
+
+           Can only be used as the expression under Cfk_concrete
+           for methods (not values). *)
+  | Pexp_object of class_structure
+        (* object ... end *)
+  | Pexp_newtype of string loc * expression
+        (* fun (type t) -> E *)
+  | Pexp_pack of module_expr
+        (* (module ME)
+
+           (module ME : S) is represented as
+           Pexp_constraint(Pexp_pack, Ptyp_package S) *)
+  | Pexp_open of open_declaration * expression
+        (* M.(E)
+           let open M in E
+           let! open M in E *)
+  | Pexp_letop of letop
+        (* let* P = E in E
+           let* P = E and* P = E in E *)
+  | Pexp_extension of extension
+        (* [%id] *)
+  | Pexp_unreachable
+        (* . *)
+
+and case =   (* (P -> E) or (P when E0 -> E) *)
+    {
+     pc_lhs: pattern;
+     pc_guard: expression option;
+     pc_rhs: expression;
+   }
+
+and letop =
+  {
+    let_ : binding_op;
+    ands : binding_op list;
+    body : expression;
+  }
+
+and binding_op =
+  {
+    pbop_op : string loc;
+    pbop_pat : pattern;
+    pbop_exp : expression;
+    pbop_loc : Location.t;
+  }
+
+(* Value descriptions *)
+
+and value_description =
+    {
+     pval_name: string loc;
+     pval_type: core_type;
+     pval_prim: string list;
+     pval_attributes: attributes;  (* ... [@@id1] [@@id2] *)
+     pval_loc: Location.t;
+    }
+
+(*
+  val x: T                            (prim = [])
+  external x: T = "s1" ... "sn"       (prim = ["s1";..."sn"])
+*)
+
+(* Type declarations *)
+
+and type_declaration =
+    {
+     ptype_name: string loc;
+     ptype_params: (core_type * (variance * injectivity)) list;
+           (* ('a1,...'an) t; None represents  _*)
+     ptype_cstrs: (core_type * core_type * Location.t) list;
+           (* ... constraint T1=T1'  ... constraint Tn=Tn' *)
+     ptype_kind: type_kind;
+     ptype_private: private_flag;   (* = private ... *)
+     ptype_manifest: core_type option;  (* = T *)
+     ptype_attributes: attributes;   (* ... [@@id1] [@@id2] *)
+     ptype_loc: Location.t;
+    }
+
+(*
+  type t                     (abstract, no manifest)
+  type t = T0                (abstract, manifest=T0)
+  type t = C of T | ...      (variant,  no manifest)
+  type t = T0 = C of T | ... (variant,  manifest=T0)
+  type t = {l: T; ...}       (record,   no manifest)
+  type t = T0 = {l : T; ...} (record,   manifest=T0)
+  type t = ..                (open,     no manifest)
+*)
+
+and type_kind =
+  | Ptype_abstract
+  | Ptype_variant of constructor_declaration list
+  | Ptype_record of label_declaration list
+        (* Invariant: non-empty list *)
+  | Ptype_open
+
+and label_declaration =
+    {
+     pld_name: string loc;
+     pld_mutable: mutable_flag;
+     pld_type: core_type;
+     pld_loc: Location.t;
+     pld_attributes: attributes; (* l : T [@id1] [@id2] *)
+    }
+
+(*  { ...; l: T; ... }            (mutable=Immutable)
+    { ...; mutable l: T; ... }    (mutable=Mutable)
+
+    Note: T can be a Ptyp_poly.
+*)
+
+and constructor_declaration =
+    {
+     pcd_name: string loc;
+     pcd_args: constructor_arguments;
+     pcd_res: core_type option;
+     pcd_loc: Location.t;
+     pcd_attributes: attributes; (* C of ... [@id1] [@id2] *)
+    }
+
+and constructor_arguments =
+  | Pcstr_tuple of core_type list
+  | Pcstr_record of label_declaration list
+
+(*
+  | C of T1 * ... * Tn     (res = None,    args = Pcstr_tuple [])
+  | C: T0                  (res = Some T0, args = [])
+  | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple)
+  | C of {...}             (res = None,    args = Pcstr_record)
+  | C: {...} -> T0         (res = Some T0, args = Pcstr_record)
+  | C of {...} as t        (res = None,    args = Pcstr_record)
+*)
+
+and type_extension =
+    {
+     ptyext_path: Longident.t loc;
+     ptyext_params: (core_type * (variance * injectivity)) list;
+     ptyext_constructors: extension_constructor list;
+     ptyext_private: private_flag;
+     ptyext_loc: Location.t;
+     ptyext_attributes: attributes;   (* ... [@@id1] [@@id2] *)
+    }
+(*
+  type t += ...
+*)
+
+and extension_constructor =
+    {
+     pext_name: string loc;
+     pext_kind : extension_constructor_kind;
+     pext_loc : Location.t;
+     pext_attributes: attributes; (* C of ... [@id1] [@id2] *)
+   }
+
+(* exception E *)
+and type_exception =
+  {
+    ptyexn_constructor: extension_constructor;
+    ptyexn_loc: Location.t;
+    ptyexn_attributes: attributes; (* ... [@@id1] [@@id2] *)
+  }
+
+and extension_constructor_kind =
+    Pext_decl of constructor_arguments * core_type option
+      (*
+         | C of T1 * ... * Tn     ([T1; ...; Tn], None)
+         | C: T0                  ([], Some T0)
+         | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0)
+       *)
+  | Pext_rebind of Longident.t loc
+      (*
+         | C = D
+       *)
+
+(** {1 Class language} *)
+
+(* Type expressions for the class language *)
+
+and class_type =
+    {
+     pcty_desc: class_type_desc;
+     pcty_loc: Location.t;
+     pcty_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and class_type_desc =
+  | Pcty_constr of Longident.t loc * core_type list
+        (* c
+           ['a1, ..., 'an] c *)
+  | Pcty_signature of class_signature
+        (* object ... end *)
+  | Pcty_arrow of arg_label * core_type * class_type
+        (* T -> CT       Simple
+           ~l:T -> CT    Labelled l
+           ?l:T -> CT    Optional l
+         *)
+  | Pcty_extension of extension
+        (* [%id] *)
+  | Pcty_open of open_description * class_type
+        (* let open M in CT *)
+
+and class_signature =
+    {
+     pcsig_self: core_type;
+     pcsig_fields: class_type_field list;
+    }
+(* object('selfpat) ... end
+   object ... end             (self = Ptyp_any)
+ *)
+
+and class_type_field =
+    {
+     pctf_desc: class_type_field_desc;
+     pctf_loc: Location.t;
+     pctf_attributes: attributes; (* ... [@@id1] [@@id2] *)
+    }
+
+and class_type_field_desc =
+  | Pctf_inherit of class_type
+        (* inherit CT *)
+  | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type)
+        (* val x: T *)
+  | Pctf_method  of (label loc * private_flag * virtual_flag * core_type)
+        (* method x: T
+
+           Note: T can be a Ptyp_poly.
+         *)
+  | Pctf_constraint  of (core_type * core_type)
+        (* constraint T1 = T2 *)
+  | Pctf_attribute of attribute
+        (* [@@@id] *)
+  | Pctf_extension of extension
+        (* [%%id] *)
+
+and 'a class_infos =
+    {
+     pci_virt: virtual_flag;
+     pci_params: (core_type * (variance * injectivity)) list;
+     pci_name: string loc;
+     pci_expr: 'a;
+     pci_loc: Location.t;
+     pci_attributes: attributes;  (* ... [@@id1] [@@id2] *)
+    }
+(* class c = ...
+   class ['a1,...,'an] c = ...
+   class virtual c = ...
+
+   Also used for "class type" declaration.
+*)
+
+and class_description = class_type class_infos
+
+and class_type_declaration = class_type class_infos
+
+(* Value expressions for the class language *)
+
+and class_expr =
+    {
+     pcl_desc: class_expr_desc;
+     pcl_loc: Location.t;
+     pcl_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and class_expr_desc =
+  | Pcl_constr of Longident.t loc * core_type list
+        (* c
+           ['a1, ..., 'an] c *)
+  | Pcl_structure of class_structure
+        (* object ... end *)
+  | Pcl_fun of arg_label * expression option * pattern * class_expr
+        (* fun P -> CE                          (Simple, None)
+           fun ~l:P -> CE                       (Labelled l, None)
+           fun ?l:P -> CE                       (Optional l, None)
+           fun ?l:(P = E0) -> CE                (Optional l, Some E0)
+         *)
+  | Pcl_apply of class_expr * (arg_label * expression) list
+        (* CE ~l1:E1 ... ~ln:En
+           li can be empty (non labeled argument) or start with '?'
+           (optional argument).
+
+           Invariant: n > 0
+         *)
+  | Pcl_let of rec_flag * value_binding list * class_expr
+        (* let P1 = E1 and ... and Pn = EN in CE      (flag = Nonrecursive)
+           let rec P1 = E1 and ... and Pn = EN in CE  (flag = Recursive)
+         *)
+  | Pcl_constraint of class_expr * class_type
+        (* (CE : CT) *)
+  | Pcl_extension of extension
+  (* [%id] *)
+  | Pcl_open of open_description * class_expr
+  (* let open M in CE *)
+
+
+and class_structure =
+    {
+     pcstr_self: pattern;
+     pcstr_fields: class_field list;
+    }
+(* object(selfpat) ... end
+   object ... end           (self = Ppat_any)
+ *)
+
+and class_field =
+    {
+     pcf_desc: class_field_desc;
+     pcf_loc: Location.t;
+     pcf_attributes: attributes; (* ... [@@id1] [@@id2] *)
+    }
+
+and class_field_desc =
+  | Pcf_inherit of override_flag * class_expr * string loc option
+        (* inherit CE
+           inherit CE as x
+           inherit! CE
+           inherit! CE as x
+         *)
+  | Pcf_val of (label loc * mutable_flag * class_field_kind)
+        (* val x = E
+           val virtual x: T
+         *)
+  | Pcf_method of (label loc * private_flag * class_field_kind)
+        (* method x = E            (E can be a Pexp_poly)
+           method virtual x: T     (T can be a Ptyp_poly)
+         *)
+  | Pcf_constraint of (core_type * core_type)
+        (* constraint T1 = T2 *)
+  | Pcf_initializer of expression
+        (* initializer E *)
+  | Pcf_attribute of attribute
+        (* [@@@id] *)
+  | Pcf_extension of extension
+        (* [%%id] *)
+
+and class_field_kind =
+  | Cfk_virtual of core_type
+  | Cfk_concrete of override_flag * expression
+
+and class_declaration = class_expr class_infos
+
+(** {1 Module language} *)
+
+(* Type expressions for the module language *)
+
+and module_type =
+    {
+     pmty_desc: module_type_desc;
+     pmty_loc: Location.t;
+     pmty_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and module_type_desc =
+  | Pmty_ident of Longident.t loc
+        (* S *)
+  | Pmty_signature of signature
+        (* sig ... end *)
+  | Pmty_functor of functor_parameter * module_type
+        (* functor(X : MT1) -> MT2 *)
+  | Pmty_with of module_type * with_constraint list
+        (* MT with ... *)
+  | Pmty_typeof of module_expr
+        (* module type of ME *)
+  | Pmty_extension of extension
+        (* [%id] *)
+  | Pmty_alias of Longident.t loc
+        (* (module M) *)
+
+and functor_parameter =
+  | Unit
+        (* () *)
+  | Named of string option loc * module_type
+        (* (X : MT)          Some X, MT
+           (_ : MT)          None, MT *)
+
+and signature = signature_item list
+
+and signature_item =
+    {
+     psig_desc: signature_item_desc;
+     psig_loc: Location.t;
+    }
+
+and signature_item_desc =
+  | Psig_value of value_description
+        (*
+          val x: T
+          external x: T = "s1" ... "sn"
+         *)
+  | Psig_type of rec_flag * type_declaration list
+        (* type t1 = ... and ... and tn  = ... *)
+  | Psig_typesubst of type_declaration list
+        (* type t1 := ... and ... and tn := ...  *)
+  | Psig_typext of type_extension
+        (* type t1 += ... *)
+  | Psig_exception of type_exception
+        (* exception C of T *)
+  | Psig_module of module_declaration
+        (* module X = M
+           module X : MT *)
+  | Psig_modsubst of module_substitution
+        (* module X := M *)
+  | Psig_recmodule of module_declaration list
+        (* module rec X1 : MT1 and ... and Xn : MTn *)
+  | Psig_modtype of module_type_declaration
+        (* module type S = MT
+           module type S *)
+  | Psig_open of open_description
+        (* open X *)
+  | Psig_include of include_description
+        (* include MT *)
+  | Psig_class of class_description list
+        (* class c1 : ... and ... and cn : ... *)
+  | Psig_class_type of class_type_declaration list
+        (* class type ct1 = ... and ... and ctn = ... *)
+  | Psig_attribute of attribute
+        (* [@@@id] *)
+  | Psig_extension of extension * attributes
+        (* [%%id] *)
+
+and module_declaration =
+    {
+     pmd_name: string option loc;
+     pmd_type: module_type;
+     pmd_attributes: attributes; (* ... [@@id1] [@@id2] *)
+     pmd_loc: Location.t;
+    }
+(* S : MT *)
+
+and module_substitution =
+    {
+     pms_name: string loc;
+     pms_manifest: Longident.t loc;
+     pms_attributes: attributes; (* ... [@@id1] [@@id2] *)
+     pms_loc: Location.t;
+    }
+
+and module_type_declaration =
+    {
+     pmtd_name: string loc;
+     pmtd_type: module_type option;
+     pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *)
+     pmtd_loc: Location.t;
+    }
+(* S = MT
+   S       (abstract module type declaration, pmtd_type = None)
+*)
+
+and 'a open_infos =
+    {
+     popen_expr: 'a;
+     popen_override: override_flag;
+     popen_loc: Location.t;
+     popen_attributes: attributes;
+    }
+(* open! X - popen_override = Override (silences the 'used identifier
+                              shadowing' warning)
+   open  X - popen_override = Fresh
+ *)
+
+and open_description = Longident.t loc open_infos
+(* open M.N
+   open M(N).O *)
+
+and open_declaration = module_expr open_infos
+(* open M.N
+   open M(N).O
+   open struct ... end *)
+
+and 'a include_infos =
+    {
+     pincl_mod: 'a;
+     pincl_loc: Location.t;
+     pincl_attributes: attributes;
+    }
+
+and include_description = module_type include_infos
+(* include MT *)
+
+and include_declaration = module_expr include_infos
+(* include ME *)
+
+and with_constraint =
+  | Pwith_type of Longident.t loc * type_declaration
+        (* with type X.t = ...
+
+           Note: the last component of the longident must match
+           the name of the type_declaration. *)
+  | Pwith_module of Longident.t loc * Longident.t loc
+        (* with module X.Y = Z *)
+  | Pwith_typesubst of Longident.t loc * type_declaration
+        (* with type X.t := ..., same format as [Pwith_type] *)
+  | Pwith_modsubst of Longident.t loc * Longident.t loc
+        (* with module X.Y := Z *)
+
+(* Value expressions for the module language *)
+
+and module_expr =
+    {
+     pmod_desc: module_expr_desc;
+     pmod_loc: Location.t;
+     pmod_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and module_expr_desc =
+  | Pmod_ident of Longident.t loc
+        (* X *)
+  | Pmod_structure of structure
+        (* struct ... end *)
+  | Pmod_functor of functor_parameter * module_expr
+        (* functor(X : MT1) -> ME *)
+  | Pmod_apply of module_expr * module_expr
+        (* ME1(ME2) *)
+  | Pmod_constraint of module_expr * module_type
+        (* (ME : MT) *)
+  | Pmod_unpack of expression
+        (* (val E) *)
+  | Pmod_extension of extension
+        (* [%id] *)
+
+and structure = structure_item list
+
+and structure_item =
+    {
+     pstr_desc: structure_item_desc;
+     pstr_loc: Location.t;
+    }
+
+and structure_item_desc =
+  | Pstr_eval of expression * attributes
+        (* E *)
+  | Pstr_value of rec_flag * value_binding list
+        (* let P1 = E1 and ... and Pn = EN       (flag = Nonrecursive)
+           let rec P1 = E1 and ... and Pn = EN   (flag = Recursive)
+         *)
+  | Pstr_primitive of value_description
+        (*  val x: T
+            external x: T = "s1" ... "sn" *)
+  | Pstr_type of rec_flag * type_declaration list
+        (* type t1 = ... and ... and tn = ... *)
+  | Pstr_typext of type_extension
+        (* type t1 += ... *)
+  | Pstr_exception of type_exception
+        (* exception C of T
+           exception C = M.X *)
+  | Pstr_module of module_binding
+        (* module X = ME *)
+  | Pstr_recmodule of module_binding list
+        (* module rec X1 = ME1 and ... and Xn = MEn *)
+  | Pstr_modtype of module_type_declaration
+        (* module type S = MT *)
+  | Pstr_open of open_declaration
+        (* open X *)
+  | Pstr_class of class_declaration list
+        (* class c1 = ... and ... and cn = ... *)
+  | Pstr_class_type of class_type_declaration list
+        (* class type ct1 = ... and ... and ctn = ... *)
+  | Pstr_include of include_declaration
+        (* include ME *)
+  | Pstr_attribute of attribute
+        (* [@@@id] *)
+  | Pstr_extension of extension * attributes
+        (* [%%id] *)
+
+and value_binding =
+  {
+    pvb_pat: pattern;
+    pvb_expr: expression;
+    pvb_attributes: attributes;
+    pvb_loc: Location.t;
+  }
+
+and module_binding =
+    {
+     pmb_name: string option loc;
+     pmb_expr: module_expr;
+     pmb_attributes: attributes;
+     pmb_loc: Location.t;
+    }
+(* X = ME *)
+
+(** {1 Toplevel} *)
+
+(* Toplevel phrases *)
+
+type toplevel_phrase =
+  | Ptop_def of structure
+  | Ptop_dir of toplevel_directive
+     (* #use, #load ... *)
+
+and toplevel_directive =
+  {
+    pdir_name : string loc;
+    pdir_arg : directive_argument option;
+    pdir_loc : Location.t;
+  }
+
+and directive_argument =
+  {
+    pdira_desc : directive_argument_desc;
+    pdira_loc : Location.t;
+  }
+
+and directive_argument_desc =
+  | Pdir_string of string
+  | Pdir_int of string * char option
+  | Pdir_ident of Longident.t
+  | Pdir_bool of bool
diff --git a/upstream/ocaml_412/parsing/pprintast.ml b/upstream/ocaml_412/parsing/pprintast.ml
new file mode 100644
index 0000000..f2b49de
--- /dev/null
+++ b/upstream/ocaml_412/parsing/pprintast.ml
@@ -0,0 +1,1667 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Thomas Gazagnaire, OCamlPro                       *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*               Hongbo Zhang, University of Pennsylvania                 *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Original Code from Ber-metaocaml, modified for 3.12.0 and fixed *)
+(* Printing code expressions *)
+(* Authors:  Ed Pizzi, Fabrice Le Fessant *)
+(* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *)
+(* TODO more fine-grained precedence pretty-printing *)
+
+open Asttypes
+open Format
+open Location
+open Longident
+open Parsetree
+open Ast_helper
+
+let prefix_symbols  = [ '!'; '?'; '~' ] ;;
+let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/';
+                      '$'; '%'; '#' ]
+
+(* type fixity = Infix| Prefix  *)
+let special_infix_strings =
+  ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ]
+
+let letop s =
+  String.length s > 3
+  && s.[0] = 'l'
+  && s.[1] = 'e'
+  && s.[2] = 't'
+  && List.mem s.[3] infix_symbols
+
+let andop s =
+  String.length s > 3
+  && s.[0] = 'a'
+  && s.[1] = 'n'
+  && s.[2] = 'd'
+  && List.mem s.[3] infix_symbols
+
+(* determines if the string is an infix string.
+   checks backwards, first allowing a renaming postfix ("_102") which
+   may have resulted from Pexp -> Texp -> Pexp translation, then checking
+   if all the characters in the beginning of the string are valid infix
+   characters. *)
+let fixity_of_string  = function
+  | "" -> `Normal
+  | s when List.mem s special_infix_strings -> `Infix s
+  | s when List.mem s.[0] infix_symbols -> `Infix s
+  | s when List.mem s.[0] prefix_symbols -> `Prefix s
+  | s when s.[0] = '.' -> `Mixfix s
+  | s when letop s -> `Letop s
+  | s when andop s -> `Andop s
+  | _ -> `Normal
+
+let view_fixity_of_exp = function
+  | {pexp_desc = Pexp_ident {txt=Lident l;_}; pexp_attributes = []} ->
+      fixity_of_string l
+  | _ -> `Normal
+
+let is_infix  = function `Infix _ -> true | _  -> false
+let is_mixfix = function `Mixfix _ -> true | _ -> false
+let is_kwdop = function `Letop _ | `Andop _ -> true | _ -> false
+
+let first_is c str =
+  str <> "" && str.[0] = c
+let last_is c str =
+  str <> "" && str.[String.length str - 1] = c
+
+let first_is_in cs str =
+  str <> "" && List.mem str.[0] cs
+
+(* which identifiers are in fact operators needing parentheses *)
+let needs_parens txt =
+  let fix = fixity_of_string txt in
+  is_infix fix
+  || is_mixfix fix
+  || is_kwdop fix
+  || first_is_in prefix_symbols txt
+
+(* some infixes need spaces around parens to avoid clashes with comment
+   syntax *)
+let needs_spaces txt =
+  first_is '*' txt || last_is '*' txt
+
+(* add parentheses to binders when they are in fact infix or prefix operators *)
+let protect_ident ppf txt =
+  let format : (_, _, _) format =
+    if not (needs_parens txt) then "%s"
+    else if needs_spaces txt then "(@;%s@;)"
+    else "(%s)"
+  in fprintf ppf format txt
+
+let protect_longident ppf print_longident longprefix txt =
+  let format : (_, _, _) format =
+    if not (needs_parens txt) then "%a.%s"
+    else if needs_spaces txt then  "%a.(@;%s@;)"
+    else "%a.(%s)" in
+  fprintf ppf format print_longident longprefix txt
+
+type space_formatter = (unit, Format.formatter, unit) format
+
+let override = function
+  | Override -> "!"
+  | Fresh -> ""
+
+(* variance encoding: need to sync up with the [parser.mly] *)
+let type_variance = function
+  | NoVariance -> ""
+  | Covariant -> "+"
+  | Contravariant -> "-"
+
+let type_injectivity = function
+  | NoInjectivity -> ""
+  | Injective -> "!"
+
+type construct =
+  [ `cons of expression list
+  | `list of expression list
+  | `nil
+  | `normal
+  | `simple of Longident.t
+  | `tuple ]
+
+let view_expr x =
+  match x.pexp_desc with
+  | Pexp_construct ( {txt= Lident "()"; _},_) -> `tuple
+  | Pexp_construct ( {txt= Lident "[]";_},_) -> `nil
+  | Pexp_construct ( {txt= Lident"::";_},Some _) ->
+      let rec loop exp acc = match exp with
+          | {pexp_desc=Pexp_construct ({txt=Lident "[]";_},_);
+             pexp_attributes = []} ->
+              (List.rev acc,true)
+          | {pexp_desc=
+             Pexp_construct ({txt=Lident "::";_},
+                             Some ({pexp_desc= Pexp_tuple([e1;e2]);
+                                    pexp_attributes = []}));
+             pexp_attributes = []}
+            ->
+              loop e2 (e1::acc)
+          | e -> (List.rev (e::acc),false) in
+      let (ls,b) = loop x []  in
+      if b then
+        `list ls
+      else `cons ls
+  | Pexp_construct (x,None) -> `simple (x.txt)
+  | _ -> `normal
+
+let is_simple_construct :construct -> bool = function
+  | `nil | `tuple | `list _ | `simple _  -> true
+  | `cons _ | `normal -> false
+
+let pp = fprintf
+
+type ctxt = {
+  pipe : bool;
+  semi : bool;
+  ifthenelse : bool;
+}
+
+let reset_ctxt = { pipe=false; semi=false; ifthenelse=false }
+let under_pipe ctxt = { ctxt with pipe=true }
+let under_semi ctxt = { ctxt with semi=true }
+let under_ifthenelse ctxt = { ctxt with ifthenelse=true }
+(*
+let reset_semi ctxt = { ctxt with semi=false }
+let reset_ifthenelse ctxt = { ctxt with ifthenelse=false }
+let reset_pipe ctxt = { ctxt with pipe=false }
+*)
+
+let list : 'a . ?sep:space_formatter -> ?first:space_formatter ->
+  ?last:space_formatter -> (Format.formatter -> 'a -> unit) ->
+  Format.formatter -> 'a list -> unit
+  = fun ?sep ?first ?last fu f xs ->
+    let first = match first with Some x -> x |None -> ("": _ format6)
+    and last = match last with Some x -> x |None -> ("": _ format6)
+    and sep = match sep with Some x -> x |None -> ("@ ": _ format6) in
+    let aux f = function
+      | [] -> ()
+      | [x] -> fu f x
+      | xs ->
+          let rec loop  f = function
+            | [x] -> fu f x
+            | x::xs ->  fu f x; pp f sep; loop f xs;
+            | _ -> assert false in begin
+            pp f first; loop f xs; pp f last;
+          end in
+    aux f xs
+
+let option : 'a. ?first:space_formatter -> ?last:space_formatter ->
+  (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit
+  = fun  ?first  ?last fu f a ->
+    let first = match first with Some x -> x | None -> ("": _ format6)
+    and last = match last with Some x -> x | None -> ("": _ format6) in
+    match a with
+    | None -> ()
+    | Some x -> pp f first; fu f x; pp f last
+
+let paren: 'a . ?first:space_formatter -> ?last:space_formatter ->
+  bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit
+  = fun  ?(first=("": _ format6)) ?(last=("": _ format6)) b fu f x ->
+    if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")")
+    else fu f x
+
+let rec longident f = function
+  | Lident s -> protect_ident f s
+  | Ldot(y,s) -> protect_longident f longident y s
+  | Lapply (y,s) ->
+      pp f "%a(%a)" longident y longident s
+
+let longident_loc f x = pp f "%a" longident x.txt
+
+let constant f = function
+  | Pconst_char i ->
+      pp f "%C"  i
+  | Pconst_string (i, _, None) ->
+      pp f "%S" i
+  | Pconst_string (i, _, Some delim) ->
+      pp f "{%s|%s|%s}" delim i delim
+  | Pconst_integer (i, None) ->
+      paren (first_is '-' i) (fun f -> pp f "%s") f i
+  | Pconst_integer (i, Some m) ->
+      paren (first_is '-' i) (fun f (i, m) -> pp f "%s%c" i m) f (i,m)
+  | Pconst_float (i, None) ->
+      paren (first_is '-' i) (fun f -> pp f "%s") f i
+  | Pconst_float (i, Some m) ->
+      paren (first_is '-' i) (fun f (i,m) -> pp f "%s%c" i m) f (i,m)
+
+(* trailing space*)
+let mutable_flag f = function
+  | Immutable -> ()
+  | Mutable -> pp f "mutable@;"
+let virtual_flag f  = function
+  | Concrete -> ()
+  | Virtual -> pp f "virtual@;"
+
+(* trailing space added *)
+let rec_flag f rf =
+  match rf with
+  | Nonrecursive -> ()
+  | Recursive -> pp f "rec "
+let nonrec_flag f rf =
+  match rf with
+  | Nonrecursive -> pp f "nonrec "
+  | Recursive -> ()
+let direction_flag f = function
+  | Upto -> pp f "to@ "
+  | Downto -> pp f "downto@ "
+let private_flag f = function
+  | Public -> ()
+  | Private -> pp f "private@ "
+
+let iter_loc f ctxt {txt; loc = _} = f ctxt txt
+
+let constant_string f s = pp f "%S" s
+
+let tyvar ppf s =
+  if String.length s >= 2 && s.[1] = '\'' then
+    (* without the space, this would be parsed as
+       a character literal *)
+    Format.fprintf ppf "' %s" s
+  else
+    Format.fprintf ppf "'%s" s
+
+let tyvar_loc f str = tyvar f str.txt
+let string_quot f x = pp f "`%s" x
+
+(* c ['a,'b] *)
+let rec class_params_def ctxt f =  function
+  | [] -> ()
+  | l ->
+      pp f "[%a] " (* space *)
+        (list (type_param ctxt) ~sep:",") l
+
+and type_with_label ctxt f (label, c) =
+  match label with
+  | Nolabel    -> core_type1 ctxt f c (* otherwise parenthesize *)
+  | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c
+  | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c
+
+and core_type ctxt f x =
+  if x.ptyp_attributes <> [] then begin
+    pp f "((%a)%a)" (core_type ctxt) {x with ptyp_attributes=[]}
+      (attributes ctxt) x.ptyp_attributes
+  end
+  else match x.ptyp_desc with
+    | Ptyp_arrow (l, ct1, ct2) ->
+        pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
+          (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2
+    | Ptyp_alias (ct, s) ->
+        pp f "@[<2>%a@;as@;%a@]" (core_type1 ctxt) ct tyvar s
+    | Ptyp_poly ([], ct) ->
+        core_type ctxt f ct
+    | Ptyp_poly (sl, ct) ->
+        pp f "@[<2>%a%a@]"
+          (fun f l ->
+             pp f "%a"
+               (fun f l -> match l with
+                  | [] -> ()
+                  | _ ->
+                      pp f "%a@;.@;"
+                        (list tyvar_loc ~sep:"@;")  l)
+               l)
+          sl (core_type ctxt) ct
+    | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x
+
+and core_type1 ctxt f x =
+  if x.ptyp_attributes <> [] then core_type ctxt f x
+  else match x.ptyp_desc with
+    | Ptyp_any -> pp f "_";
+    | Ptyp_var s -> tyvar f  s;
+    | Ptyp_tuple l ->  pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l
+    | Ptyp_constr (li, l) ->
+        pp f (* "%a%a@;" *) "%a%a"
+          (fun f l -> match l with
+             |[] -> ()
+             |[x]-> pp f "%a@;" (core_type1 ctxt)  x
+             | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l)
+          l longident_loc li
+    | Ptyp_variant (l, closed, low) ->
+        let first_is_inherit = match l with
+          | {Parsetree.prf_desc = Rinherit _}::_ -> true
+          | _ -> false in
+        let type_variant_helper f x =
+          match x.prf_desc with
+          | Rtag (l, _, ctl) ->
+              pp f "@[<2>%a%a@;%a@]" (iter_loc string_quot) l
+                (fun f l -> match l with
+                   |[] -> ()
+                   | _ -> pp f "@;of@;%a"
+                            (list (core_type ctxt) ~sep:"&")  ctl) ctl
+                (attributes ctxt) x.prf_attributes
+          | Rinherit ct -> core_type ctxt f ct in
+        pp f "@[<2>[%a%a]@]"
+          (fun f l ->
+             match l, closed with
+             | [], Closed -> ()
+             | [], Open -> pp f ">" (* Cf #7200: print [>] correctly *)
+             | _ ->
+                 pp f "%s@;%a"
+                   (match (closed,low) with
+                    | (Closed,None) -> if first_is_inherit then " |" else ""
+                    | (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*)
+                    | (Open,_) -> ">")
+                   (list type_variant_helper ~sep:"@;<1 -2>| ") l) l
+          (fun f low -> match low with
+             |Some [] |None -> ()
+             |Some xs ->
+                 pp f ">@ %a"
+                   (list string_quot) xs) low
+    | Ptyp_object (l, o) ->
+        let core_field_type f x = match x.pof_desc with
+          | Otag (l, ct) ->
+            (* Cf #7200 *)
+            pp f "@[<hov2>%s: %a@ %a@ @]" l.txt
+              (core_type ctxt) ct (attributes ctxt) x.pof_attributes
+          | Oinherit ct ->
+            pp f "@[<hov2>%a@ @]" (core_type ctxt) ct
+        in
+        let field_var f = function
+          | Asttypes.Closed -> ()
+          | Asttypes.Open ->
+              match l with
+              | [] -> pp f ".."
+              | _ -> pp f " ;.."
+        in
+        pp f "@[<hov2><@ %a%a@ > @]"
+          (list core_field_type ~sep:";") l
+          field_var o (* Cf #7200 *)
+    | Ptyp_class (li, l) ->   (*FIXME*)
+        pp f "@[<hov2>%a#%a@]"
+          (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") l
+          longident_loc li
+    | Ptyp_package (lid, cstrs) ->
+        let aux f (s, ct) =
+          pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct  in
+        (match cstrs with
+         |[] -> pp f "@[<hov2>(module@ %a)@]" longident_loc lid
+         |_ ->
+             pp f "@[<hov2>(module@ %a@ with@ %a)@]" longident_loc lid
+               (list aux  ~sep:"@ and@ ")  cstrs)
+    | Ptyp_extension e -> extension ctxt f e
+    | _ -> paren true (core_type ctxt) f x
+
+(********************pattern********************)
+(* be cautious when use [pattern], [pattern1] is preferred *)
+and pattern ctxt f x =
+  if x.ppat_attributes <> [] then begin
+    pp f "((%a)%a)" (pattern ctxt) {x with ppat_attributes=[]}
+      (attributes ctxt) x.ppat_attributes
+  end
+  else match x.ppat_desc with
+    | Ppat_alias (p, s) ->
+        pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt
+    | _ -> pattern_or ctxt f x
+
+and pattern_or ctxt f x =
+  let rec left_associative x acc = match x with
+    | {ppat_desc=Ppat_or (p1,p2); ppat_attributes = []} ->
+        left_associative p1 (p2 :: acc)
+    | x -> x :: acc
+  in
+  match left_associative x [] with
+  | [] -> assert false
+  | [x] -> pattern1 ctxt f x
+  | orpats ->
+      pp f "@[<hov0>%a@]" (list ~sep:"@ | " (pattern1 ctxt)) orpats
+
+and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit =
+  let rec pattern_list_helper f = function
+    | {ppat_desc =
+         Ppat_construct
+           ({ txt = Lident("::") ;_},
+            Some ({ppat_desc = Ppat_tuple([pat1; pat2]);_}));
+       ppat_attributes = []}
+
+      ->
+        pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*)
+    | p -> pattern1 ctxt f p
+  in
+  if x.ppat_attributes <> [] then pattern ctxt f x
+  else match x.ppat_desc with
+    | Ppat_variant (l, Some p) ->
+        pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) p
+    | Ppat_construct (({txt=Lident("()"|"[]");_}), _) -> simple_pattern ctxt f x
+    | Ppat_construct (({txt;_} as li), po) ->
+        (* FIXME The third field always false *)
+        if txt = Lident "::" then
+          pp f "%a" pattern_list_helper x
+        else
+          (match po with
+           | Some x -> pp f "%a@;%a"  longident_loc li (simple_pattern ctxt) x
+           | None -> pp f "%a" longident_loc li)
+    | _ -> simple_pattern ctxt f x
+
+and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit =
+  if x.ppat_attributes <> [] then pattern ctxt f x
+  else match x.ppat_desc with
+    | Ppat_construct (({txt=Lident ("()"|"[]" as x);_}), _) -> pp f  "%s" x
+    | Ppat_any -> pp f "_";
+    | Ppat_var ({txt = txt;_}) -> protect_ident f txt
+    | Ppat_array l ->
+        pp f "@[<2>[|%a|]@]"  (list (pattern1 ctxt) ~sep:";") l
+    | Ppat_unpack { txt = None } ->
+        pp f "(module@ _)@ "
+    | Ppat_unpack { txt = Some s } ->
+        pp f "(module@ %s)@ " s
+    | Ppat_type li ->
+        pp f "#%a" longident_loc li
+    | Ppat_record (l, closed) ->
+        let longident_x_pattern f (li, p) =
+          match (li,p) with
+          | ({txt=Lident s;_ },
+             {ppat_desc=Ppat_var {txt;_};
+              ppat_attributes=[]; _})
+            when s = txt ->
+              pp f "@[<2>%a@]"  longident_loc li
+          | _ ->
+              pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p
+        in
+        begin match closed with
+        | Closed ->
+            pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l
+        | _ ->
+            pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l
+        end
+    | Ppat_tuple l ->
+        pp f "@[<1>(%a)@]" (list  ~sep:",@;" (pattern1 ctxt))  l (* level1*)
+    | Ppat_constant (c) -> pp f "%a" constant c
+    | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2
+    | Ppat_variant (l,None) ->  pp f "`%s" l
+    | Ppat_constraint (p, ct) ->
+        pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct
+    | Ppat_lazy p ->
+        pp f "@[<2>(lazy@;%a)@]" (simple_pattern ctxt) p
+    | Ppat_exception p ->
+        pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p
+    | Ppat_extension e -> extension ctxt f e
+    | Ppat_open (lid, p) ->
+        let with_paren =
+        match p.ppat_desc with
+        | Ppat_array _ | Ppat_record _
+        | Ppat_construct (({txt=Lident ("()"|"[]");_}), _) -> false
+        | _ -> true in
+        pp f "@[<2>%a.%a @]" longident_loc lid
+          (paren with_paren @@ pattern1 ctxt) p
+    | _ -> paren true (pattern ctxt) f x
+
+and label_exp ctxt f (l,opt,p) =
+  match l with
+  | Nolabel ->
+      (* single case pattern parens needed here *)
+      pp f "%a@ " (simple_pattern ctxt) p
+  | Optional rest ->
+      begin match p with
+      | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []}
+        when txt = rest ->
+          (match opt with
+           | Some o -> pp f "?(%s=@;%a)@;" rest  (expression ctxt) o
+           | None -> pp f "?%s@ " rest)
+      | _ ->
+          (match opt with
+           | Some o ->
+               pp f "?%s:(%a=@;%a)@;"
+                 rest (pattern1 ctxt) p (expression ctxt) o
+           | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p)
+      end
+  | Labelled l -> match p with
+    | {ppat_desc  = Ppat_var {txt;_}; ppat_attributes = []}
+      when txt = l ->
+        pp f "~%s@;" l
+    | _ ->  pp f "~%s:%a@;" l (simple_pattern ctxt) p
+
+and sugar_expr ctxt f e =
+  if e.pexp_attributes <> [] then false
+  else match e.pexp_desc with
+  | Pexp_apply ({ pexp_desc = Pexp_ident {txt = id; _};
+                  pexp_attributes=[]; _}, args)
+    when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin
+      let print_indexop a path_prefix assign left sep right print_index indices
+          rem_args =
+        let print_path ppf = function
+          | None -> ()
+          | Some m -> pp ppf ".%a" longident m in
+        match assign, rem_args with
+            | false, [] ->
+              pp f "@[%a%a%s%a%s@]"
+                (simple_expr ctxt) a print_path path_prefix
+                left (list ~sep print_index) indices right; true
+            | true, [v] ->
+              pp f "@[%a%a%s%a%s@ <-@;<1 2>%a@]"
+                (simple_expr ctxt) a print_path path_prefix
+                left (list ~sep print_index) indices right
+                (simple_expr ctxt) v; true
+            | _ -> false in
+      match id, List.map snd args with
+      | Lident "!", [e] ->
+        pp f "@[<hov>!%a@]" (simple_expr ctxt) e; true
+      | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin
+          let assign = func = "set" in
+          let print = print_indexop a None assign in
+          match path, other_args with
+          | Lident "Array", i :: rest ->
+            print ".(" "" ")" (expression ctxt) [i] rest
+          | Lident "String", i :: rest ->
+            print ".[" "" "]" (expression ctxt) [i] rest
+          | Ldot (Lident "Bigarray", "Array1"), i1 :: rest ->
+            print ".{" "," "}" (simple_expr ctxt) [i1] rest
+          | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest ->
+            print ".{" "," "}" (simple_expr ctxt) [i1; i2] rest
+          | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest ->
+            print ".{" "," "}" (simple_expr ctxt) [i1; i2; i3] rest
+          | Ldot (Lident "Bigarray", "Genarray"),
+            {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest ->
+              print ".{" "," "}" (simple_expr ctxt) indexes rest
+          | _ -> false
+        end
+      | (Lident s | Ldot(_,s)) , a :: i :: rest
+        when first_is '.' s ->
+          (* extract operator:
+             assignment operators end with [right_bracket ^ "<-"],
+             access operators end with [right_bracket] directly
+          *)
+          let multi_indices = String.contains s ';' in
+          let i =
+              match i.pexp_desc with
+                | Pexp_array l when multi_indices -> l
+                | _ -> [ i ] in
+          let assign = last_is '-' s in
+          let kind =
+            (* extract the right end bracket *)
+            let n = String.length s in
+            if assign then s.[n - 3] else s.[n - 1] in
+          let left, right = match kind with
+            | ')' -> '(', ")"
+            | ']' -> '[', "]"
+            | '}' -> '{', "}"
+            | _ -> assert false in
+          let path_prefix = match id with
+            | Ldot(m,_) -> Some m
+            | _ -> None in
+          let left = String.sub s 0 (1+String.index s left) in
+          print_indexop a path_prefix assign left ";" right
+            (if multi_indices then expression ctxt else simple_expr ctxt)
+            i rest
+      | _ -> false
+    end
+  | _ -> false
+
+and expression ctxt f x =
+  if x.pexp_attributes <> [] then
+    pp f "((%a)@,%a)" (expression ctxt) {x with pexp_attributes=[]}
+      (attributes ctxt) x.pexp_attributes
+  else match x.pexp_desc with
+    | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _
+    | Pexp_newtype _
+      when ctxt.pipe || ctxt.semi ->
+        paren true (expression reset_ctxt) f x
+    | Pexp_ifthenelse _ | Pexp_sequence _ when ctxt.ifthenelse ->
+        paren true (expression reset_ctxt) f x
+    | Pexp_let _ | Pexp_letmodule _ | Pexp_open _
+      | Pexp_letexception _ | Pexp_letop _
+        when ctxt.semi ->
+        paren true (expression reset_ctxt) f x
+    | Pexp_fun (l, e0, p, e) ->
+        pp f "@[<2>fun@;%a->@;%a@]"
+          (label_exp ctxt) (l, e0, p)
+          (expression ctxt) e
+    | Pexp_newtype (lid, e) ->
+        pp f "@[<2>fun@;(type@;%s)@;->@;%a@]" lid.txt
+          (expression ctxt) e
+    | Pexp_function l ->
+        pp f "@[<hv>function%a@]" (case_list ctxt) l
+    | Pexp_match (e, l) ->
+        pp f "@[<hv0>@[<hv0>@[<2>match %a@]@ with@]%a@]"
+          (expression reset_ctxt) e (case_list ctxt) l
+
+    | Pexp_try (e, l) ->
+        pp f "@[<0>@[<hv2>try@ %a@]@ @[<0>with%a@]@]"
+             (* "try@;@[<2>%a@]@\nwith@\n%a"*)
+          (expression reset_ctxt) e  (case_list ctxt) l
+    | Pexp_let (rf, l, e) ->
+        (* pp f "@[<2>let %a%a in@;<1 -2>%a@]"
+           (*no indentation here, a new line*) *)
+        (*   rec_flag rf *)
+        pp f "@[<2>%a in@;<1 -2>%a@]"
+          (bindings reset_ctxt) (rf,l)
+          (expression ctxt) e
+    | Pexp_apply (e, l) ->
+        begin if not (sugar_expr ctxt f x) then
+            match view_fixity_of_exp e with
+            | `Infix s ->
+                begin match l with
+                | [ (Nolabel, _) as arg1; (Nolabel, _) as arg2 ] ->
+                    (* FIXME associativity label_x_expression_param *)
+                    pp f "@[<2>%a@;%s@;%a@]"
+                      (label_x_expression_param reset_ctxt) arg1 s
+                      (label_x_expression_param ctxt) arg2
+                | _ ->
+                    pp f "@[<2>%a %a@]"
+                      (simple_expr ctxt) e
+                      (list (label_x_expression_param ctxt)) l
+                end
+            | `Prefix s ->
+                let s =
+                  if List.mem s ["~+";"~-";"~+.";"~-."] &&
+                   (match l with
+                    (* See #7200: avoid turning (~- 1) into (- 1) which is
+                       parsed as an int literal *)
+                    |[(_,{pexp_desc=Pexp_constant _})] -> false
+                    | _ -> true)
+                  then String.sub s 1 (String.length s -1)
+                  else s in
+                begin match l with
+                | [(Nolabel, x)] ->
+                  pp f "@[<2>%s@;%a@]" s (simple_expr ctxt) x
+                | _   ->
+                  pp f "@[<2>%a %a@]" (simple_expr ctxt) e
+                    (list (label_x_expression_param ctxt)) l
+                end
+            | _ ->
+                pp f "@[<hov2>%a@]" begin fun f (e,l) ->
+                  pp f "%a@ %a" (expression2 ctxt) e
+                    (list (label_x_expression_param reset_ctxt))  l
+                    (* reset here only because [function,match,try,sequence]
+                       are lower priority *)
+                end (e,l)
+        end
+
+    | Pexp_construct (li, Some eo)
+      when not (is_simple_construct (view_expr x))-> (* Not efficient FIXME*)
+        (match view_expr x with
+         | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;"
+         | `normal ->
+             pp f "@[<2>%a@;%a@]" longident_loc li
+               (simple_expr ctxt) eo
+         | _ -> assert false)
+    | Pexp_setfield (e1, li, e2) ->
+        pp f "@[<2>%a.%a@ <-@ %a@]"
+          (simple_expr ctxt) e1 longident_loc li (simple_expr ctxt) e2
+    | Pexp_ifthenelse (e1, e2, eo) ->
+        (* @;@[<2>else@ %a@]@] *)
+        let fmt:(_,_,_)format ="@[<hv0>@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" in
+        let expression_under_ifthenelse = expression (under_ifthenelse ctxt) in
+        pp f fmt expression_under_ifthenelse e1 expression_under_ifthenelse e2
+          (fun f eo -> match eo with
+             | Some x ->
+                 pp f "@;@[<2>else@;%a@]" (expression (under_semi ctxt)) x
+             | None -> () (* pp f "()" *)) eo
+    | Pexp_sequence _ ->
+        let rec sequence_helper acc = function
+          | {pexp_desc=Pexp_sequence(e1,e2); pexp_attributes = []} ->
+              sequence_helper (e1::acc) e2
+          | v -> List.rev (v::acc) in
+        let lst = sequence_helper [] x in
+        pp f "@[<hv>%a@]"
+          (list (expression (under_semi ctxt)) ~sep:";@;") lst
+    | Pexp_new (li) ->
+        pp f "@[<hov2>new@ %a@]" longident_loc li;
+    | Pexp_setinstvar (s, e) ->
+        pp f "@[<hov2>%s@ <-@ %a@]" s.txt (expression ctxt) e
+    | Pexp_override l -> (* FIXME *)
+        let string_x_expression f (s, e) =
+          pp f "@[<hov2>%s@ =@ %a@]" s.txt (expression ctxt) e in
+        pp f "@[<hov2>{<%a>}@]"
+          (list string_x_expression  ~sep:";"  )  l;
+    | Pexp_letmodule (s, me, e) ->
+        pp f "@[<hov2>let@ module@ %s@ =@ %a@ in@ %a@]"
+          (Option.value s.txt ~default:"_")
+          (module_expr reset_ctxt) me (expression ctxt) e
+    | Pexp_letexception (cd, e) ->
+        pp f "@[<hov2>let@ exception@ %a@ in@ %a@]"
+          (extension_constructor ctxt) cd
+          (expression ctxt) e
+    | Pexp_assert e ->
+        pp f "@[<hov2>assert@ %a@]" (simple_expr ctxt) e
+    | Pexp_lazy (e) ->
+        pp f "@[<hov2>lazy@ %a@]" (simple_expr ctxt) e
+    (* Pexp_poly: impossible but we should print it anyway, rather than
+       assert false *)
+    | Pexp_poly (e, None) ->
+        pp f "@[<hov2>!poly!@ %a@]" (simple_expr ctxt) e
+    | Pexp_poly (e, Some ct) ->
+        pp f "@[<hov2>(!poly!@ %a@ : %a)@]"
+          (simple_expr ctxt) e (core_type ctxt) ct
+    | Pexp_open (o, e) ->
+        pp f "@[<2>let open%s %a in@;%a@]"
+          (override o.popen_override) (module_expr ctxt) o.popen_expr
+          (expression ctxt) e
+    | Pexp_variant (l,Some eo) ->
+        pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo
+    | Pexp_letop {let_; ands; body} ->
+        pp f "@[<2>@[<v>%a@,%a@] in@;<1 -2>%a@]"
+          (binding_op ctxt) let_
+          (list ~sep:"@," (binding_op ctxt)) ands
+          (expression ctxt) body
+    | Pexp_extension e -> extension ctxt f e
+    | Pexp_unreachable -> pp f "."
+    | _ -> expression1 ctxt f x
+
+and expression1 ctxt f x =
+  if x.pexp_attributes <> [] then expression ctxt f x
+  else match x.pexp_desc with
+    | Pexp_object cs -> pp f "%a" (class_structure ctxt) cs
+    | _ -> expression2 ctxt f x
+(* used in [Pexp_apply] *)
+
+and expression2 ctxt f x =
+  if x.pexp_attributes <> [] then expression ctxt f x
+  else match x.pexp_desc with
+    | Pexp_field (e, li) ->
+        pp f "@[<hov2>%a.%a@]" (simple_expr ctxt) e longident_loc li
+    | Pexp_send (e, s) -> pp f "@[<hov2>%a#%s@]" (simple_expr ctxt) e s.txt
+
+    | _ -> simple_expr ctxt f x
+
+and simple_expr ctxt f x =
+  if x.pexp_attributes <> [] then expression ctxt f x
+  else match x.pexp_desc with
+    | Pexp_construct _  when is_simple_construct (view_expr x) ->
+        (match view_expr x with
+         | `nil -> pp f "[]"
+         | `tuple -> pp f "()"
+         | `list xs ->
+             pp f "@[<hv0>[%a]@]"
+               (list (expression (under_semi ctxt)) ~sep:";@;") xs
+         | `simple x -> longident f x
+         | _ -> assert false)
+    | Pexp_ident li ->
+        longident_loc f li
+    (* (match view_fixity_of_exp x with *)
+    (* |`Normal -> longident_loc f li *)
+    (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *)
+    | Pexp_constant c -> constant f c;
+    | Pexp_pack me ->
+        pp f "(module@;%a)" (module_expr ctxt) me
+    | Pexp_tuple l ->
+        pp f "@[<hov2>(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l
+    | Pexp_constraint (e, ct) ->
+        pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct
+    | Pexp_coerce (e, cto1, ct) ->
+        pp f "(%a%a :> %a)" (expression ctxt) e
+          (option (core_type ctxt) ~first:" : " ~last:" ") cto1 (* no sep hint*)
+          (core_type ctxt) ct
+    | Pexp_variant (l, None) -> pp f "`%s" l
+    | Pexp_record (l, eo) ->
+        let longident_x_expression f ( li, e) =
+          match e with
+          |  {pexp_desc=Pexp_ident {txt;_};
+              pexp_attributes=[]; _} when li.txt = txt ->
+              pp f "@[<hov2>%a@]" longident_loc li
+          | _ ->
+              pp f "@[<hov2>%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e
+        in
+        pp f "@[<hv0>@[<hv2>{@;%a%a@]@;}@]"(* "@[<hov2>{%a%a}@]" *)
+          (option ~last:" with@;" (simple_expr ctxt)) eo
+          (list longident_x_expression ~sep:";@;") l
+    | Pexp_array (l) ->
+        pp f "@[<0>@[<2>[|%a|]@]@]"
+          (list (simple_expr (under_semi ctxt)) ~sep:";") l
+    | Pexp_while (e1, e2) ->
+        let fmt : (_,_,_) format = "@[<2>while@;%a@;do@;%a@;done@]" in
+        pp f fmt (expression ctxt) e1 (expression ctxt) e2
+    | Pexp_for (s, e1, e2, df, e3) ->
+        let fmt:(_,_,_)format =
+          "@[<hv0>@[<hv2>@[<2>for %a =@;%a@;%a%a@;do@]@;%a@]@;done@]" in
+        let expression = expression ctxt in
+        pp f fmt (pattern ctxt) s expression e1 direction_flag
+          df expression e2 expression e3
+    | _ ->  paren true (expression ctxt) f x
+
+and attributes ctxt f l =
+  List.iter (attribute ctxt f) l
+
+and item_attributes ctxt f l =
+  List.iter (item_attribute ctxt f) l
+
+and attribute ctxt f a =
+  pp f "@[<2>[@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload
+
+and item_attribute ctxt f a =
+  pp f "@[<2>[@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload
+
+and floating_attribute ctxt f a =
+  pp f "@[<2>[@@@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload
+
+and value_description ctxt f x =
+  (* note: value_description has an attribute field,
+           but they're already printed by the callers this method *)
+  pp f "@[<hov2>%a%a@]" (core_type ctxt) x.pval_type
+    (fun f x ->
+       if x.pval_prim <> []
+       then pp f "@ =@ %a" (list constant_string) x.pval_prim
+    ) x
+
+and extension ctxt f (s, e) =
+  pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e
+
+and item_extension ctxt f (s, e) =
+  pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e
+
+and exception_declaration ctxt f x =
+  pp f "@[<hov2>exception@ %a@]%a"
+    (extension_constructor ctxt) x.ptyexn_constructor
+    (item_attributes ctxt) x.ptyexn_attributes
+
+and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} =
+  let class_type_field f x =
+    match x.pctf_desc with
+    | Pctf_inherit (ct) ->
+        pp f "@[<2>inherit@ %a@]%a" (class_type ctxt) ct
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_val (s, mf, vf, ct) ->
+        pp f "@[<2>val @ %a%a%s@ :@ %a@]%a"
+          mutable_flag mf virtual_flag vf s.txt (core_type ctxt) ct
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_method (s, pf, vf, ct) ->
+        pp f "@[<2>method %a %a%s :@;%a@]%a"
+          private_flag pf virtual_flag vf s.txt (core_type ctxt) ct
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_constraint (ct1, ct2) ->
+        pp f "@[<2>constraint@ %a@ =@ %a@]%a"
+          (core_type ctxt) ct1 (core_type ctxt) ct2
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_attribute a -> floating_attribute ctxt f a
+    | Pctf_extension e ->
+        item_extension ctxt f e;
+        item_attributes ctxt f x.pctf_attributes
+  in
+  pp f "@[<hv0>@[<hv2>object@[<1>%a@]@ %a@]@ end@]"
+    (fun f -> function
+         {ptyp_desc=Ptyp_any; ptyp_attributes=[]; _} -> ()
+       | ct -> pp f " (%a)" (core_type ctxt) ct) ct
+    (list class_type_field ~sep:"@;") l
+
+(* call [class_signature] called by [class_signature] *)
+and class_type ctxt f x =
+  match x.pcty_desc with
+  | Pcty_signature cs ->
+      class_signature ctxt f cs;
+      attributes ctxt f x.pcty_attributes
+  | Pcty_constr (li, l) ->
+      pp f "%a%a%a"
+        (fun f l -> match l with
+           | [] -> ()
+           | _  -> pp f "[%a]@ " (list (core_type ctxt) ~sep:"," ) l) l
+        longident_loc li
+        (attributes ctxt) x.pcty_attributes
+  | Pcty_arrow (l, co, cl) ->
+      pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
+        (type_with_label ctxt) (l,co)
+        (class_type ctxt) cl
+  | Pcty_extension e ->
+      extension ctxt f e;
+      attributes ctxt f x.pcty_attributes
+  | Pcty_open (o, e) ->
+      pp f "@[<2>let open%s %a in@;%a@]"
+        (override o.popen_override) longident_loc o.popen_expr
+        (class_type ctxt) e
+
+(* [class type a = object end] *)
+and class_type_declaration_list ctxt f l =
+  let class_type_declaration kwd f x =
+    let { pci_params=ls; pci_name={ txt; _ }; _ } = x in
+    pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd
+      virtual_flag x.pci_virt
+      (class_params_def ctxt) ls txt
+      (class_type ctxt) x.pci_expr
+      (item_attributes ctxt) x.pci_attributes
+  in
+  match l with
+  | [] -> ()
+  | [x] -> class_type_declaration "class type" f x
+  | x :: xs ->
+      pp f "@[<v>%a@,%a@]"
+        (class_type_declaration "class type") x
+        (list ~sep:"@," (class_type_declaration "and")) xs
+
+and class_field ctxt f x =
+  match x.pcf_desc with
+  | Pcf_inherit (ovf, ce, so) ->
+      pp f "@[<2>inherit@ %s@ %a%a@]%a" (override ovf)
+        (class_expr ctxt) ce
+        (fun f so -> match so with
+           | None -> ();
+           | Some (s) -> pp f "@ as %s" s.txt ) so
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_val (s, mf, Cfk_concrete (ovf, e)) ->
+      pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf)
+        mutable_flag mf s.txt
+        (expression ctxt) e
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_method (s, pf, Cfk_virtual ct) ->
+      pp f "@[<2>method virtual %a %s :@;%a@]%a"
+        private_flag pf s.txt
+        (core_type ctxt) ct
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_val (s, mf, Cfk_virtual ct) ->
+      pp f "@[<2>val virtual %a%s :@ %a@]%a"
+        mutable_flag mf s.txt
+        (core_type ctxt) ct
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_method (s, pf, Cfk_concrete (ovf, e)) ->
+      let bind e =
+        binding ctxt f
+          {pvb_pat=
+             {ppat_desc=Ppat_var s;
+              ppat_loc=Location.none;
+              ppat_loc_stack=[];
+              ppat_attributes=[]};
+           pvb_expr=e;
+           pvb_attributes=[];
+           pvb_loc=Location.none;
+          }
+      in
+      pp f "@[<2>method%s %a%a@]%a"
+        (override ovf)
+        private_flag pf
+        (fun f -> function
+           | {pexp_desc=Pexp_poly (e, Some ct); pexp_attributes=[]; _} ->
+               pp f "%s :@;%a=@;%a"
+                 s.txt (core_type ctxt) ct (expression ctxt) e
+           | {pexp_desc=Pexp_poly (e, None); pexp_attributes=[]; _} ->
+               bind e
+           | _ -> bind e) e
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_constraint (ct1, ct2) ->
+      pp f "@[<2>constraint %a =@;%a@]%a"
+        (core_type ctxt) ct1
+        (core_type ctxt) ct2
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_initializer (e) ->
+      pp f "@[<2>initializer@ %a@]%a"
+        (expression ctxt) e
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_attribute a -> floating_attribute ctxt f a
+  | Pcf_extension e ->
+      item_extension ctxt f e;
+      item_attributes ctxt f x.pcf_attributes
+
+and class_structure ctxt f { pcstr_self = p; pcstr_fields =  l } =
+  pp f "@[<hv0>@[<hv2>object%a@;%a@]@;end@]"
+    (fun f p -> match p.ppat_desc with
+       | Ppat_any -> ()
+       | Ppat_constraint _ -> pp f " %a" (pattern ctxt) p
+       | _ -> pp f " (%a)" (pattern ctxt) p) p
+    (list (class_field ctxt)) l
+
+and class_expr ctxt f x =
+  if x.pcl_attributes <> [] then begin
+    pp f "((%a)%a)" (class_expr ctxt) {x with pcl_attributes=[]}
+      (attributes ctxt) x.pcl_attributes
+  end else
+    match x.pcl_desc with
+    | Pcl_structure (cs) -> class_structure ctxt f cs
+    | Pcl_fun (l, eo, p, e) ->
+        pp f "fun@ %a@ ->@ %a"
+          (label_exp ctxt) (l,eo,p)
+          (class_expr ctxt) e
+    | Pcl_let (rf, l, ce) ->
+        pp f "%a@ in@ %a"
+          (bindings ctxt) (rf,l)
+          (class_expr ctxt) ce
+    | Pcl_apply (ce, l) ->
+        pp f "((%a)@ %a)" (* Cf: #7200 *)
+          (class_expr ctxt) ce
+          (list (label_x_expression_param ctxt)) l
+    | Pcl_constr (li, l) ->
+        pp f "%a%a"
+          (fun f l-> if l <>[] then
+              pp f "[%a]@ "
+                (list (core_type ctxt) ~sep:",") l) l
+          longident_loc li
+    | Pcl_constraint (ce, ct) ->
+        pp f "(%a@ :@ %a)"
+          (class_expr ctxt) ce
+          (class_type ctxt) ct
+    | Pcl_extension e -> extension ctxt f e
+    | Pcl_open (o, e) ->
+        pp f "@[<2>let open%s %a in@;%a@]"
+          (override o.popen_override) longident_loc o.popen_expr
+          (class_expr ctxt) e
+
+and module_type ctxt f x =
+  if x.pmty_attributes <> [] then begin
+    pp f "((%a)%a)" (module_type ctxt) {x with pmty_attributes=[]}
+      (attributes ctxt) x.pmty_attributes
+  end else
+    match x.pmty_desc with
+    | Pmty_functor (Unit, mt2) ->
+        pp f "@[<hov2>functor () ->@ %a@]" (module_type ctxt) mt2
+    | Pmty_functor (Named (s, mt1), mt2) ->
+        begin match s.txt with
+        | None ->
+            pp f "@[<hov2>%a@ ->@ %a@]"
+              (module_type1 ctxt) mt1 (module_type ctxt) mt2
+        | Some name ->
+            pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" name
+              (module_type ctxt) mt1 (module_type ctxt) mt2
+        end
+    | Pmty_with (mt, []) -> module_type ctxt f mt
+    | Pmty_with (mt, l) ->
+        let with_constraint f = function
+          | Pwith_type (li, ({ptype_params= ls ;_} as td)) ->
+              let ls = List.map fst ls in
+              pp f "type@ %a %a =@ %a"
+                (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")")
+                ls longident_loc li (type_declaration ctxt) td
+          | Pwith_module (li, li2) ->
+              pp f "module %a =@ %a" longident_loc li longident_loc li2;
+          | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) ->
+              let ls = List.map fst ls in
+              pp f "type@ %a %a :=@ %a"
+                (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")")
+                ls longident_loc li
+                (type_declaration ctxt) td
+          | Pwith_modsubst (li, li2) ->
+             pp f "module %a :=@ %a" longident_loc li longident_loc li2 in
+        pp f "@[<hov2>%a@ with@ %a@]"
+          (module_type1 ctxt) mt (list with_constraint ~sep:"@ and@ ") l
+    | _ -> module_type1 ctxt f x
+
+and module_type1 ctxt f x =
+  if x.pmty_attributes <> [] then module_type ctxt f x
+  else match x.pmty_desc with
+    | Pmty_ident li ->
+        pp f "%a" longident_loc li;
+    | Pmty_alias li ->
+        pp f "(module %a)" longident_loc li;
+    | Pmty_signature (s) ->
+        pp f "@[<hv0>@[<hv2>sig@ %a@]@ end@]" (* "@[<hov>sig@ %a@ end@]" *)
+          (list (signature_item ctxt)) s (* FIXME wrong indentation*)
+    | Pmty_typeof me ->
+        pp f "@[<hov2>module@ type@ of@ %a@]" (module_expr ctxt) me
+    | Pmty_extension e -> extension ctxt f e
+    | _ -> paren true (module_type ctxt) f x
+
+and signature ctxt f x =  list ~sep:"@\n" (signature_item ctxt) f x
+
+and signature_item ctxt f x : unit =
+  match x.psig_desc with
+  | Psig_type (rf, l) ->
+      type_def_list ctxt f (rf, true, l)
+  | Psig_typesubst l ->
+      type_def_list ctxt f (Nonrecursive, false, l)
+  | Psig_value vd ->
+      let intro = if vd.pval_prim = [] then "val" else "external" in
+      pp f "@[<2>%s@ %a@ :@ %a@]%a" intro
+        protect_ident vd.pval_name.txt
+        (value_description ctxt) vd
+        (item_attributes ctxt) vd.pval_attributes
+  | Psig_typext te ->
+      type_extension ctxt f te
+  | Psig_exception ed ->
+      exception_declaration ctxt f ed
+  | Psig_class l ->
+      let class_description kwd f ({pci_params=ls;pci_name={txt;_};_} as x) =
+        pp f "@[<2>%s %a%a%s@;:@;%a@]%a" kwd
+          virtual_flag x.pci_virt
+          (class_params_def ctxt) ls txt
+          (class_type ctxt) x.pci_expr
+          (item_attributes ctxt) x.pci_attributes
+      in begin
+        match l with
+        | [] -> ()
+        | [x] -> class_description "class" f x
+        | x :: xs ->
+            pp f "@[<v>%a@,%a@]"
+              (class_description "class") x
+              (list ~sep:"@," (class_description "and")) xs
+      end
+  | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias;
+                            pmty_attributes=[]; _};_} as pmd) ->
+      pp f "@[<hov>module@ %s@ =@ %a@]%a"
+        (Option.value pmd.pmd_name.txt ~default:"_")
+        longident_loc alias
+        (item_attributes ctxt) pmd.pmd_attributes
+  | Psig_module pmd ->
+      pp f "@[<hov>module@ %s@ :@ %a@]%a"
+        (Option.value pmd.pmd_name.txt ~default:"_")
+        (module_type ctxt) pmd.pmd_type
+        (item_attributes ctxt) pmd.pmd_attributes
+  | Psig_modsubst pms ->
+      pp f "@[<hov>module@ %s@ :=@ %a@]%a" pms.pms_name.txt
+        longident_loc pms.pms_manifest
+        (item_attributes ctxt) pms.pms_attributes
+  | Psig_open od ->
+      pp f "@[<hov2>open%s@ %a@]%a"
+        (override od.popen_override)
+        longident_loc od.popen_expr
+        (item_attributes ctxt) od.popen_attributes
+  | Psig_include incl ->
+      pp f "@[<hov2>include@ %a@]%a"
+        (module_type ctxt) incl.pincl_mod
+        (item_attributes ctxt) incl.pincl_attributes
+  | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
+      pp f "@[<hov2>module@ type@ %s%a@]%a"
+        s.txt
+        (fun f md -> match md with
+           | None -> ()
+           | Some mt ->
+               pp_print_space f () ;
+               pp f "@ =@ %a" (module_type ctxt) mt
+        ) md
+        (item_attributes ctxt) attrs
+  | Psig_class_type (l) -> class_type_declaration_list ctxt f l
+  | Psig_recmodule decls ->
+      let rec  string_x_module_type_list f ?(first=true) l =
+        match l with
+        | [] -> () ;
+        | pmd :: tl ->
+            if not first then
+              pp f "@ @[<hov2>and@ %s:@ %a@]%a"
+                (Option.value pmd.pmd_name.txt ~default:"_")
+                (module_type1 ctxt) pmd.pmd_type
+                (item_attributes ctxt) pmd.pmd_attributes
+            else
+              pp f "@[<hov2>module@ rec@ %s:@ %a@]%a"
+                (Option.value pmd.pmd_name.txt ~default:"_")
+                (module_type1 ctxt) pmd.pmd_type
+                (item_attributes ctxt) pmd.pmd_attributes;
+            string_x_module_type_list f ~first:false tl
+      in
+      string_x_module_type_list f decls
+  | Psig_attribute a -> floating_attribute ctxt f a
+  | Psig_extension(e, a) ->
+      item_extension ctxt f e;
+      item_attributes ctxt f a
+
+and module_expr ctxt f x =
+  if x.pmod_attributes <> [] then
+    pp f "((%a)%a)" (module_expr ctxt) {x with pmod_attributes=[]}
+      (attributes ctxt) x.pmod_attributes
+  else match x.pmod_desc with
+    | Pmod_structure (s) ->
+        pp f "@[<hv2>struct@;@[<0>%a@]@;<1 -2>end@]"
+          (list (structure_item ctxt) ~sep:"@\n") s;
+    | Pmod_constraint (me, mt) ->
+        pp f "@[<hov2>(%a@ :@ %a)@]"
+          (module_expr ctxt) me
+          (module_type ctxt) mt
+    | Pmod_ident (li) ->
+        pp f "%a" longident_loc li;
+    | Pmod_functor (Unit, me) ->
+        pp f "functor ()@;->@;%a" (module_expr ctxt) me
+    | Pmod_functor (Named (s, mt), me) ->
+        pp f "functor@ (%s@ :@ %a)@;->@;%a"
+          (Option.value s.txt ~default:"_")
+          (module_type ctxt) mt (module_expr ctxt) me
+    | Pmod_apply (me1, me2) ->
+        pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2
+        (* Cf: #7200 *)
+    | Pmod_unpack e ->
+        pp f "(val@ %a)" (expression ctxt) e
+    | Pmod_extension e -> extension ctxt f e
+
+and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x
+
+and payload ctxt f = function
+  | PStr [{pstr_desc = Pstr_eval (e, attrs)}] ->
+      pp f "@[<2>%a@]%a"
+        (expression ctxt) e
+        (item_attributes ctxt) attrs
+  | PStr x -> structure ctxt f x
+  | PTyp x -> pp f ":@ "; core_type ctxt f x
+  | PSig x -> pp f ":@ "; signature ctxt f x
+  | PPat (x, None) -> pp f "?@ "; pattern ctxt f x
+  | PPat (x, Some e) ->
+      pp f "?@ "; pattern ctxt f x;
+      pp f " when "; expression ctxt f e
+
+(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *)
+and binding ctxt f {pvb_pat=p; pvb_expr=x; _} =
+  (* .pvb_attributes have already been printed by the caller, #bindings *)
+  let rec pp_print_pexp_function f x =
+    if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x
+    else match x.pexp_desc with
+      | Pexp_fun (label, eo, p, e) ->
+          if label=Nolabel then
+            pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e
+          else
+            pp f "%a@ %a"
+              (label_exp ctxt) (label,eo,p) pp_print_pexp_function e
+      | Pexp_newtype (str,e) ->
+          pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e
+      | _ -> pp f "=@;%a" (expression ctxt) x
+  in
+  let tyvars_str tyvars = List.map (fun v -> v.txt) tyvars in
+  let is_desugared_gadt p e =
+    let gadt_pattern =
+      match p with
+      | {ppat_desc=Ppat_constraint({ppat_desc=Ppat_var _} as pat,
+                                   {ptyp_desc=Ptyp_poly (args_tyvars, rt)});
+         ppat_attributes=[]}->
+          Some (pat, args_tyvars, rt)
+      | _ -> None in
+    let rec gadt_exp tyvars e =
+      match e with
+      | {pexp_desc=Pexp_newtype (tyvar, e); pexp_attributes=[]} ->
+          gadt_exp (tyvar :: tyvars) e
+      | {pexp_desc=Pexp_constraint (e, ct); pexp_attributes=[]} ->
+          Some (List.rev tyvars, e, ct)
+      | _ -> None in
+    let gadt_exp = gadt_exp [] e in
+    match gadt_pattern, gadt_exp with
+    | Some (p, pt_tyvars, pt_ct), Some (e_tyvars, e, e_ct)
+      when tyvars_str pt_tyvars = tyvars_str e_tyvars ->
+      let ety = Typ.varify_constructors e_tyvars e_ct in
+      if ety = pt_ct then
+      Some (p, pt_tyvars, e_ct, e) else None
+    | _ -> None in
+  if x.pexp_attributes <> []
+  then
+    match p with
+    | {ppat_desc=Ppat_constraint({ppat_desc=Ppat_var _; _} as pat,
+                                 ({ptyp_desc=Ptyp_poly _; _} as typ));
+       ppat_attributes=[]; _} ->
+        pp f "%a@;: %a@;=@;%a"
+          (simple_pattern ctxt) pat (core_type ctxt) typ (expression ctxt) x
+    | _ ->
+        pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x
+  else
+  match is_desugared_gadt p x with
+  | Some (p, [], ct, e) ->
+      pp f "%a@;: %a@;=@;%a"
+        (simple_pattern ctxt) p (core_type ctxt) ct (expression ctxt) e
+  | Some (p, tyvars, ct, e) -> begin
+    pp f "%a@;: type@;%a.@;%a@;=@;%a"
+    (simple_pattern ctxt) p (list pp_print_string ~sep:"@;")
+    (tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e
+    end
+  | None -> begin
+      match p with
+      | {ppat_desc=Ppat_constraint(p ,ty);
+         ppat_attributes=[]} -> (* special case for the first*)
+          begin match ty with
+          | {ptyp_desc=Ptyp_poly _; ptyp_attributes=[]} ->
+              pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p
+                (core_type ctxt) ty (expression ctxt) x
+          | _ ->
+              pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p
+                (core_type ctxt) ty (expression ctxt) x
+          end
+      | {ppat_desc=Ppat_var _; ppat_attributes=[]} ->
+          pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x
+      | _ ->
+          pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x
+    end
+
+(* [in] is not printed *)
+and bindings ctxt f (rf,l) =
+  let binding kwd rf f x =
+    pp f "@[<2>%s %a%a@]%a" kwd rec_flag rf
+      (binding ctxt) x (item_attributes ctxt) x.pvb_attributes
+  in
+  match l with
+  | [] -> ()
+  | [x] -> binding "let" rf f x
+  | x::xs ->
+      pp f "@[<v>%a@,%a@]"
+        (binding "let" rf) x
+        (list ~sep:"@," (binding "and" Nonrecursive)) xs
+
+and binding_op ctxt f x =
+  pp f "@[<2>%s %a@;=@;%a@]"
+    x.pbop_op.txt (pattern ctxt) x.pbop_pat (expression ctxt) x.pbop_exp
+
+and structure_item ctxt f x =
+  match x.pstr_desc with
+  | Pstr_eval (e, attrs) ->
+      pp f "@[<hov2>;;%a@]%a"
+        (expression ctxt) e
+        (item_attributes ctxt) attrs
+  | Pstr_type (_, []) -> assert false
+  | Pstr_type (rf, l)  -> type_def_list ctxt f (rf, true, l)
+  | Pstr_value (rf, l) ->
+      (* pp f "@[<hov2>let %a%a@]"  rec_flag rf bindings l *)
+      pp f "@[<2>%a@]" (bindings ctxt) (rf,l)
+  | Pstr_typext te -> type_extension ctxt f te
+  | Pstr_exception ed -> exception_declaration ctxt f ed
+  | Pstr_module x ->
+      let rec module_helper = function
+        | {pmod_desc=Pmod_functor(arg_opt,me'); pmod_attributes = []} ->
+            begin match arg_opt with
+            | Unit -> pp f "()"
+            | Named (s, mt) ->
+              pp f "(%s:%a)" (Option.value s.txt ~default:"_")
+                (module_type ctxt) mt
+            end;
+            module_helper me'
+        | me -> me
+      in
+      pp f "@[<hov2>module %s%a@]%a"
+        (Option.value x.pmb_name.txt ~default:"_")
+        (fun f me ->
+           let me = module_helper me in
+           match me with
+           | {pmod_desc=
+                Pmod_constraint
+                  (me',
+                   ({pmty_desc=(Pmty_ident (_)
+                               | Pmty_signature (_));_} as mt));
+              pmod_attributes = []} ->
+               pp f " :@;%a@;=@;%a@;"
+                 (module_type ctxt) mt (module_expr ctxt) me'
+           | _ -> pp f " =@ %a" (module_expr ctxt) me
+        ) x.pmb_expr
+        (item_attributes ctxt) x.pmb_attributes
+  | Pstr_open od ->
+      pp f "@[<2>open%s@;%a@]%a"
+        (override od.popen_override)
+        (module_expr ctxt) od.popen_expr
+        (item_attributes ctxt) od.popen_attributes
+  | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
+      pp f "@[<hov2>module@ type@ %s%a@]%a"
+        s.txt
+        (fun f md -> match md with
+           | None -> ()
+           | Some mt ->
+               pp_print_space f () ;
+               pp f "@ =@ %a" (module_type ctxt) mt
+        ) md
+        (item_attributes ctxt) attrs
+  | Pstr_class l ->
+      let extract_class_args cl =
+        let rec loop acc = function
+          | {pcl_desc=Pcl_fun (l, eo, p, cl'); pcl_attributes = []} ->
+              loop ((l,eo,p) :: acc) cl'
+          | cl -> List.rev acc, cl
+        in
+        let args, cl = loop [] cl in
+        let constr, cl =
+          match cl with
+          | {pcl_desc=Pcl_constraint (cl', ct); pcl_attributes = []} ->
+              Some ct, cl'
+          | _ -> None, cl
+        in
+        args, constr, cl
+      in
+      let class_constraint f ct = pp f ": @[%a@] " (class_type ctxt) ct in
+      let class_declaration kwd f
+          ({pci_params=ls; pci_name={txt;_}; _} as x) =
+        let args, constr, cl = extract_class_args x.pci_expr in
+        pp f "@[<2>%s %a%a%s %a%a=@;%a@]%a" kwd
+          virtual_flag x.pci_virt
+          (class_params_def ctxt) ls txt
+          (list (label_exp ctxt)) args
+          (option class_constraint) constr
+          (class_expr ctxt) cl
+          (item_attributes ctxt) x.pci_attributes
+      in begin
+        match l with
+        | [] -> ()
+        | [x] -> class_declaration "class" f x
+        | x :: xs ->
+            pp f "@[<v>%a@,%a@]"
+              (class_declaration "class") x
+              (list ~sep:"@," (class_declaration "and")) xs
+      end
+  | Pstr_class_type l -> class_type_declaration_list ctxt f l
+  | Pstr_primitive vd ->
+      pp f "@[<hov2>external@ %a@ :@ %a@]%a"
+        protect_ident vd.pval_name.txt
+        (value_description ctxt) vd
+        (item_attributes ctxt) vd.pval_attributes
+  | Pstr_include incl ->
+      pp f "@[<hov2>include@ %a@]%a"
+        (module_expr ctxt) incl.pincl_mod
+        (item_attributes ctxt) incl.pincl_attributes
+  | Pstr_recmodule decls -> (* 3.07 *)
+      let aux f = function
+        | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) ->
+            pp f "@[<hov2>@ and@ %s:%a@ =@ %a@]%a"
+              (Option.value pmb.pmb_name.txt ~default:"_")
+              (module_type ctxt) typ
+              (module_expr ctxt) expr
+              (item_attributes ctxt) pmb.pmb_attributes
+        | pmb ->
+            pp f "@[<hov2>@ and@ %s@ =@ %a@]%a"
+              (Option.value pmb.pmb_name.txt ~default:"_")
+              (module_expr ctxt) pmb.pmb_expr
+              (item_attributes ctxt) pmb.pmb_attributes
+      in
+      begin match decls with
+      | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 ->
+          pp f "@[<hv>@[<hov2>module@ rec@ %s:%a@ =@ %a@]%a@ %a@]"
+            (Option.value pmb.pmb_name.txt ~default:"_")
+            (module_type ctxt) typ
+            (module_expr ctxt) expr
+            (item_attributes ctxt) pmb.pmb_attributes
+            (fun f l2 -> List.iter (aux f) l2) l2
+      | pmb :: l2 ->
+          pp f "@[<hv>@[<hov2>module@ rec@ %s@ =@ %a@]%a@ %a@]"
+            (Option.value pmb.pmb_name.txt ~default:"_")
+            (module_expr ctxt) pmb.pmb_expr
+            (item_attributes ctxt) pmb.pmb_attributes
+            (fun f l2 -> List.iter (aux f) l2) l2
+      | _ -> assert false
+      end
+  | Pstr_attribute a -> floating_attribute ctxt f a
+  | Pstr_extension(e, a) ->
+      item_extension ctxt f e;
+      item_attributes ctxt f a
+
+and type_param ctxt f (ct, (a,b)) =
+  pp f "%s%s%a" (type_variance a) (type_injectivity b) (core_type ctxt) ct
+
+and type_params ctxt f = function
+  | [] -> ()
+  | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l
+
+and type_def_list ctxt f (rf, exported, l) =
+  let type_decl kwd rf f x =
+    let eq =
+      if (x.ptype_kind = Ptype_abstract)
+         && (x.ptype_manifest = None) then ""
+      else if exported then " ="
+      else " :="
+    in
+    pp f "@[<2>%s %a%a%s%s%a@]%a" kwd
+      nonrec_flag rf
+      (type_params ctxt) x.ptype_params
+      x.ptype_name.txt eq
+      (type_declaration ctxt) x
+      (item_attributes ctxt) x.ptype_attributes
+  in
+  match l with
+  | [] -> assert false
+  | [x] -> type_decl "type" rf f x
+  | x :: xs -> pp f "@[<v>%a@,%a@]"
+                 (type_decl "type" rf) x
+                 (list ~sep:"@," (type_decl "and" Recursive)) xs
+
+and record_declaration ctxt f lbls =
+  let type_record_field f pld =
+    pp f "@[<2>%a%s:@;%a@;%a@]"
+      mutable_flag pld.pld_mutable
+      pld.pld_name.txt
+      (core_type ctxt) pld.pld_type
+      (attributes ctxt) pld.pld_attributes
+  in
+  pp f "{@\n%a}"
+    (list type_record_field ~sep:";@\n" )  lbls
+
+and type_declaration ctxt f x =
+  (* type_declaration has an attribute field,
+     but it's been printed by the caller of this method *)
+  let priv f =
+    match x.ptype_private with
+    | Public -> ()
+    | Private -> pp f "@;private"
+  in
+  let manifest f =
+    match x.ptype_manifest with
+    | None -> ()
+    | Some y ->
+        if x.ptype_kind = Ptype_abstract then
+          pp f "%t@;%a" priv (core_type ctxt) y
+        else
+          pp f "@;%a" (core_type ctxt) y
+  in
+  let constructor_declaration f pcd =
+    pp f "|@;";
+    constructor_declaration ctxt f
+      (pcd.pcd_name.txt, pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes)
+  in
+  let repr f =
+    let intro f =
+      if x.ptype_manifest = None then ()
+      else pp f "@;="
+    in
+    match x.ptype_kind with
+    | Ptype_variant xs ->
+      let variants fmt xs =
+        if xs = [] then pp fmt " |" else
+          pp fmt "@\n%a" (list ~sep:"@\n" constructor_declaration) xs
+      in pp f "%t%t%a" intro priv variants xs
+    | Ptype_abstract -> ()
+    | Ptype_record l ->
+        pp f "%t%t@;%a" intro priv (record_declaration ctxt) l
+    | Ptype_open -> pp f "%t%t@;.." intro priv
+  in
+  let constraints f =
+    List.iter
+      (fun (ct1,ct2,_) ->
+         pp f "@[<hov2>@ constraint@ %a@ =@ %a@]"
+           (core_type ctxt) ct1 (core_type ctxt) ct2)
+      x.ptype_cstrs
+  in
+  pp f "%t%t%t" manifest repr constraints
+
+and type_extension ctxt f x =
+  let extension_constructor f x =
+    pp f "@\n|@;%a" (extension_constructor ctxt) x
+  in
+  pp f "@[<2>type %a%a += %a@ %a@]%a"
+    (fun f -> function
+       | [] -> ()
+       | l ->
+           pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l)
+    x.ptyext_params
+    longident_loc x.ptyext_path
+    private_flag x.ptyext_private (* Cf: #7200 *)
+    (list ~sep:"" extension_constructor)
+    x.ptyext_constructors
+    (item_attributes ctxt) x.ptyext_attributes
+
+and constructor_declaration ctxt f (name, args, res, attrs) =
+  let name =
+    match name with
+    | "::" -> "(::)"
+    | s -> s in
+  match res with
+  | None ->
+      pp f "%s%a@;%a" name
+        (fun f -> function
+           | Pcstr_tuple [] -> ()
+           | Pcstr_tuple l ->
+             pp f "@;of@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l
+           | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l
+        ) args
+        (attributes ctxt) attrs
+  | Some r ->
+      pp f "%s:@;%a@;%a" name
+        (fun f -> function
+           | Pcstr_tuple [] -> core_type1 ctxt f r
+           | Pcstr_tuple l -> pp f "%a@;->@;%a"
+                                (list (core_type1 ctxt) ~sep:"@;*@;") l
+                                (core_type1 ctxt) r
+           | Pcstr_record l ->
+               pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r
+        )
+        args
+        (attributes ctxt) attrs
+
+and extension_constructor ctxt f x =
+  (* Cf: #7200 *)
+  match x.pext_kind with
+  | Pext_decl(l, r) ->
+      constructor_declaration ctxt f (x.pext_name.txt, l, r, x.pext_attributes)
+  | Pext_rebind li ->
+      pp f "%s@;=@;%a%a" x.pext_name.txt
+        longident_loc li
+        (attributes ctxt) x.pext_attributes
+
+and case_list ctxt f l : unit =
+  let aux f {pc_lhs; pc_guard; pc_rhs} =
+    pp f "@;| @[<2>%a%a@;->@;%a@]"
+      (pattern ctxt) pc_lhs (option (expression ctxt) ~first:"@;when@;")
+      pc_guard (expression (under_pipe ctxt)) pc_rhs
+  in
+  list aux f l ~sep:""
+
+and label_x_expression_param ctxt f (l,e) =
+  let simple_name = match e with
+    | {pexp_desc=Pexp_ident {txt=Lident l;_};
+       pexp_attributes=[]} -> Some l
+    | _ -> None
+  in match l with
+  | Nolabel  -> expression2 ctxt f e (* level 2*)
+  | Optional str ->
+      if Some str = simple_name then
+        pp f "?%s" str
+      else
+        pp f "?%s:%a" str (simple_expr ctxt) e
+  | Labelled lbl ->
+      if Some lbl = simple_name then
+        pp f "~%s" lbl
+      else
+        pp f "~%s:%a" lbl (simple_expr ctxt) e
+
+and directive_argument f x =
+  match x.pdira_desc with
+  | Pdir_string (s) -> pp f "@ %S" s
+  | Pdir_int (n, None) -> pp f "@ %s" n
+  | Pdir_int (n, Some m) -> pp f "@ %s%c" n m
+  | Pdir_ident (li) -> pp f "@ %a" longident li
+  | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b)
+
+let toplevel_phrase f x =
+  match x with
+  | Ptop_def (s) ->pp f "@[<hov0>%a@]"  (list (structure_item reset_ctxt)) s
+   (* pp_open_hvbox f 0; *)
+   (* pp_print_list structure_item f s ; *)
+   (* pp_close_box f (); *)
+  | Ptop_dir {pdir_name; pdir_arg = None; _} ->
+   pp f "@[<hov2>#%s@]" pdir_name.txt
+  | Ptop_dir {pdir_name; pdir_arg = Some pdir_arg; _} ->
+   pp f "@[<hov2>#%s@ %a@]" pdir_name.txt directive_argument pdir_arg
+
+let expression f x =
+  pp f "@[%a@]" (expression reset_ctxt) x
+
+let string_of_expression x =
+  ignore (flush_str_formatter ()) ;
+  let f = str_formatter in
+  expression f x;
+  flush_str_formatter ()
+
+let string_of_structure x =
+  ignore (flush_str_formatter ());
+  let f = str_formatter in
+  structure reset_ctxt f x;
+  flush_str_formatter ()
+
+let top_phrase f x =
+  pp_print_newline f ();
+  toplevel_phrase f x;
+  pp f ";;";
+  pp_print_newline f ()
+
+let core_type = core_type reset_ctxt
+let pattern = pattern reset_ctxt
+let signature = signature reset_ctxt
+let structure = structure reset_ctxt
diff --git a/upstream/ocaml_412/parsing/pprintast.mli b/upstream/ocaml_412/parsing/pprintast.mli
new file mode 100644
index 0000000..454e60e
--- /dev/null
+++ b/upstream/ocaml_412/parsing/pprintast.mli
@@ -0,0 +1,44 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Hongbo Zhang (University of Pennsylvania)                  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+
+(** Pretty-printers for {!Parsetree}
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type space_formatter = (unit, Format.formatter, unit) format
+
+val longident : Format.formatter -> Longident.t -> unit
+val expression : Format.formatter -> Parsetree.expression -> unit
+val string_of_expression : Parsetree.expression -> string
+
+val pattern: Format.formatter -> Parsetree.pattern -> unit
+
+val core_type: Format.formatter -> Parsetree.core_type -> unit
+
+val signature: Format.formatter -> Parsetree.signature -> unit
+val structure: Format.formatter -> Parsetree.structure -> unit
+val string_of_structure: Parsetree.structure -> string
+
+val toplevel_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit
+val top_phrase: Format.formatter -> Parsetree.toplevel_phrase -> unit
+
+
+val tyvar: Format.formatter -> string -> unit
+  (** Print a type variable name, taking care of the special treatment
+      required for the single quote character in second position. *)
diff --git a/upstream/ocaml_412/parsing/printast.ml b/upstream/ocaml_412/parsing/printast.ml
new file mode 100644
index 0000000..4e3ef2b
--- /dev/null
+++ b/upstream/ocaml_412/parsing/printast.ml
@@ -0,0 +1,965 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*              Damien Doligez, projet Para, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes;;
+open Format;;
+open Lexing;;
+open Location;;
+open Parsetree;;
+
+let fmt_position with_name f l =
+  let fname = if with_name then l.pos_fname else "" in
+  if l.pos_lnum = -1
+  then fprintf f "%s[%d]" fname l.pos_cnum
+  else fprintf f "%s[%d,%d+%d]" fname l.pos_lnum l.pos_bol
+               (l.pos_cnum - l.pos_bol)
+;;
+
+let fmt_location f loc =
+  if not !Clflags.locations then ()
+  else begin
+    let p_2nd_name = loc.loc_start.pos_fname <> loc.loc_end.pos_fname in
+    fprintf f "(%a..%a)" (fmt_position true) loc.loc_start
+                         (fmt_position p_2nd_name) loc.loc_end;
+    if loc.loc_ghost then fprintf f " ghost";
+  end
+;;
+
+let rec fmt_longident_aux f x =
+  match x with
+  | Longident.Lident (s) -> fprintf f "%s" s;
+  | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s;
+  | Longident.Lapply (y, z) ->
+      fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z;
+;;
+
+let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x;;
+
+let fmt_longident_loc f (x : Longident.t loc) =
+  fprintf f "\"%a\" %a" fmt_longident_aux x.txt fmt_location x.loc;
+;;
+
+let fmt_string_loc f (x : string loc) =
+  fprintf f "\"%s\" %a" x.txt fmt_location x.loc;
+;;
+
+let fmt_str_opt_loc f (x : string option loc) =
+  fprintf f "\"%s\" %a" (Option.value x.txt ~default:"_") fmt_location x.loc;
+;;
+
+let fmt_char_option f = function
+  | None -> fprintf f "None"
+  | Some c -> fprintf f "Some %c" c
+
+let fmt_constant f x =
+  match x with
+  | Pconst_integer (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m;
+  | Pconst_char (c) -> fprintf f "PConst_char %02x" (Char.code c);
+  | Pconst_string (s, strloc, None) ->
+      fprintf f "PConst_string(%S,%a,None)" s fmt_location strloc ;
+  | Pconst_string (s, strloc, Some delim) ->
+      fprintf f "PConst_string (%S,%a,Some %S)" s fmt_location strloc delim;
+  | Pconst_float (s,m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m;
+;;
+
+let fmt_mutable_flag f x =
+  match x with
+  | Immutable -> fprintf f "Immutable";
+  | Mutable -> fprintf f "Mutable";
+;;
+
+let fmt_virtual_flag f x =
+  match x with
+  | Virtual -> fprintf f "Virtual";
+  | Concrete -> fprintf f "Concrete";
+;;
+
+let fmt_override_flag f x =
+  match x with
+  | Override -> fprintf f "Override";
+  | Fresh -> fprintf f "Fresh";
+;;
+
+let fmt_closed_flag f x =
+  match x with
+  | Closed -> fprintf f "Closed"
+  | Open -> fprintf f "Open"
+
+let fmt_rec_flag f x =
+  match x with
+  | Nonrecursive -> fprintf f "Nonrec";
+  | Recursive -> fprintf f "Rec";
+;;
+
+let fmt_direction_flag f x =
+  match x with
+  | Upto -> fprintf f "Up";
+  | Downto -> fprintf f "Down";
+;;
+
+let fmt_private_flag f x =
+  match x with
+  | Public -> fprintf f "Public";
+  | Private -> fprintf f "Private";
+;;
+
+let line i f s (*...*) =
+  fprintf f "%s" (String.make ((2*i) mod 72) ' ');
+  fprintf f s (*...*)
+;;
+
+let list i f ppf l =
+  match l with
+  | [] -> line i ppf "[]\n";
+  | _ :: _ ->
+     line i ppf "[\n";
+     List.iter (f (i+1) ppf) l;
+     line i ppf "]\n";
+;;
+
+let option i f ppf x =
+  match x with
+  | None -> line i ppf "None\n";
+  | Some x ->
+      line i ppf "Some\n";
+      f (i+1) ppf x;
+;;
+
+let longident_loc i ppf li = line i ppf "%a\n" fmt_longident_loc li;;
+let string i ppf s = line i ppf "\"%s\"\n" s;;
+let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s;;
+let str_opt_loc i ppf s = line i ppf "%a\n" fmt_str_opt_loc s;;
+let arg_label i ppf = function
+  | Nolabel -> line i ppf "Nolabel\n"
+  | Optional s -> line i ppf "Optional \"%s\"\n" s
+  | Labelled s -> line i ppf "Labelled \"%s\"\n" s
+;;
+
+let rec core_type i ppf x =
+  line i ppf "core_type %a\n" fmt_location x.ptyp_loc;
+  attributes i ppf x.ptyp_attributes;
+  let i = i+1 in
+  match x.ptyp_desc with
+  | Ptyp_any -> line i ppf "Ptyp_any\n";
+  | Ptyp_var (s) -> line i ppf "Ptyp_var %s\n" s;
+  | Ptyp_arrow (l, ct1, ct2) ->
+      line i ppf "Ptyp_arrow\n";
+      arg_label i ppf l;
+      core_type i ppf ct1;
+      core_type i ppf ct2;
+  | Ptyp_tuple l ->
+      line i ppf "Ptyp_tuple\n";
+      list i core_type ppf l;
+  | Ptyp_constr (li, l) ->
+      line i ppf "Ptyp_constr %a\n" fmt_longident_loc li;
+      list i core_type ppf l;
+  | Ptyp_variant (l, closed, low) ->
+      line i ppf "Ptyp_variant closed=%a\n" fmt_closed_flag closed;
+      list i label_x_bool_x_core_type_list ppf l;
+      option i (fun i -> list i string) ppf low
+  | Ptyp_object (l, c) ->
+      line i ppf "Ptyp_object %a\n" fmt_closed_flag c;
+      let i = i + 1 in
+      List.iter (fun field ->
+        match field.pof_desc with
+          | Otag (l, t) ->
+            line i ppf "method %s\n" l.txt;
+            attributes i ppf field.pof_attributes;
+            core_type (i + 1) ppf t
+          | Oinherit ct ->
+              line i ppf "Oinherit\n";
+              core_type (i + 1) ppf ct
+      ) l
+  | Ptyp_class (li, l) ->
+      line i ppf "Ptyp_class %a\n" fmt_longident_loc li;
+      list i core_type ppf l
+  | Ptyp_alias (ct, s) ->
+      line i ppf "Ptyp_alias \"%s\"\n" s;
+      core_type i ppf ct;
+  | Ptyp_poly (sl, ct) ->
+      line i ppf "Ptyp_poly%a\n"
+        (fun ppf ->
+           List.iter (fun x -> fprintf ppf " %a" Pprintast.tyvar x.txt)
+        )
+        sl;
+      core_type i ppf ct;
+  | Ptyp_package (s, l) ->
+      line i ppf "Ptyp_package %a\n" fmt_longident_loc s;
+      list i package_with ppf l;
+  | Ptyp_extension (s, arg) ->
+      line i ppf "Ptyp_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and package_with i ppf (s, t) =
+  line i ppf "with type %a\n" fmt_longident_loc s;
+  core_type i ppf t
+
+and pattern i ppf x =
+  line i ppf "pattern %a\n" fmt_location x.ppat_loc;
+  attributes i ppf x.ppat_attributes;
+  let i = i+1 in
+  match x.ppat_desc with
+  | Ppat_any -> line i ppf "Ppat_any\n";
+  | Ppat_var (s) -> line i ppf "Ppat_var %a\n" fmt_string_loc s;
+  | Ppat_alias (p, s) ->
+      line i ppf "Ppat_alias %a\n" fmt_string_loc s;
+      pattern i ppf p;
+  | Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c;
+  | Ppat_interval (c1, c2) ->
+      line i ppf "Ppat_interval %a..%a\n" fmt_constant c1 fmt_constant c2;
+  | Ppat_tuple (l) ->
+      line i ppf "Ppat_tuple\n";
+      list i pattern ppf l;
+  | Ppat_construct (li, po) ->
+      line i ppf "Ppat_construct %a\n" fmt_longident_loc li;
+      option i pattern ppf po;
+  | Ppat_variant (l, po) ->
+      line i ppf "Ppat_variant \"%s\"\n" l;
+      option i pattern ppf po;
+  | Ppat_record (l, c) ->
+      line i ppf "Ppat_record %a\n" fmt_closed_flag c;
+      list i longident_x_pattern ppf l;
+  | Ppat_array (l) ->
+      line i ppf "Ppat_array\n";
+      list i pattern ppf l;
+  | Ppat_or (p1, p2) ->
+      line i ppf "Ppat_or\n";
+      pattern i ppf p1;
+      pattern i ppf p2;
+  | Ppat_lazy p ->
+      line i ppf "Ppat_lazy\n";
+      pattern i ppf p;
+  | Ppat_constraint (p, ct) ->
+      line i ppf "Ppat_constraint\n";
+      pattern i ppf p;
+      core_type i ppf ct;
+  | Ppat_type (li) ->
+      line i ppf "Ppat_type\n";
+      longident_loc i ppf li
+  | Ppat_unpack s ->
+      line i ppf "Ppat_unpack %a\n" fmt_str_opt_loc s;
+  | Ppat_exception p ->
+      line i ppf "Ppat_exception\n";
+      pattern i ppf p
+  | Ppat_open (m,p) ->
+      line i ppf "Ppat_open \"%a\"\n" fmt_longident_loc m;
+      pattern i ppf p
+  | Ppat_extension (s, arg) ->
+      line i ppf "Ppat_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and expression i ppf x =
+  line i ppf "expression %a\n" fmt_location x.pexp_loc;
+  attributes i ppf x.pexp_attributes;
+  let i = i+1 in
+  match x.pexp_desc with
+  | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li;
+  | Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c;
+  | Pexp_let (rf, l, e) ->
+      line i ppf "Pexp_let %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l;
+      expression i ppf e;
+  | Pexp_function l ->
+      line i ppf "Pexp_function\n";
+      list i case ppf l;
+  | Pexp_fun (l, eo, p, e) ->
+      line i ppf "Pexp_fun\n";
+      arg_label i ppf l;
+      option i expression ppf eo;
+      pattern i ppf p;
+      expression i ppf e;
+  | Pexp_apply (e, l) ->
+      line i ppf "Pexp_apply\n";
+      expression i ppf e;
+      list i label_x_expression ppf l;
+  | Pexp_match (e, l) ->
+      line i ppf "Pexp_match\n";
+      expression i ppf e;
+      list i case ppf l;
+  | Pexp_try (e, l) ->
+      line i ppf "Pexp_try\n";
+      expression i ppf e;
+      list i case ppf l;
+  | Pexp_tuple (l) ->
+      line i ppf "Pexp_tuple\n";
+      list i expression ppf l;
+  | Pexp_construct (li, eo) ->
+      line i ppf "Pexp_construct %a\n" fmt_longident_loc li;
+      option i expression ppf eo;
+  | Pexp_variant (l, eo) ->
+      line i ppf "Pexp_variant \"%s\"\n" l;
+      option i expression ppf eo;
+  | Pexp_record (l, eo) ->
+      line i ppf "Pexp_record\n";
+      list i longident_x_expression ppf l;
+      option i expression ppf eo;
+  | Pexp_field (e, li) ->
+      line i ppf "Pexp_field\n";
+      expression i ppf e;
+      longident_loc i ppf li;
+  | Pexp_setfield (e1, li, e2) ->
+      line i ppf "Pexp_setfield\n";
+      expression i ppf e1;
+      longident_loc i ppf li;
+      expression i ppf e2;
+  | Pexp_array (l) ->
+      line i ppf "Pexp_array\n";
+      list i expression ppf l;
+  | Pexp_ifthenelse (e1, e2, eo) ->
+      line i ppf "Pexp_ifthenelse\n";
+      expression i ppf e1;
+      expression i ppf e2;
+      option i expression ppf eo;
+  | Pexp_sequence (e1, e2) ->
+      line i ppf "Pexp_sequence\n";
+      expression i ppf e1;
+      expression i ppf e2;
+  | Pexp_while (e1, e2) ->
+      line i ppf "Pexp_while\n";
+      expression i ppf e1;
+      expression i ppf e2;
+  | Pexp_for (p, e1, e2, df, e3) ->
+      line i ppf "Pexp_for %a\n" fmt_direction_flag df;
+      pattern i ppf p;
+      expression i ppf e1;
+      expression i ppf e2;
+      expression i ppf e3;
+  | Pexp_constraint (e, ct) ->
+      line i ppf "Pexp_constraint\n";
+      expression i ppf e;
+      core_type i ppf ct;
+  | Pexp_coerce (e, cto1, cto2) ->
+      line i ppf "Pexp_coerce\n";
+      expression i ppf e;
+      option i core_type ppf cto1;
+      core_type i ppf cto2;
+  | Pexp_send (e, s) ->
+      line i ppf "Pexp_send \"%s\"\n" s.txt;
+      expression i ppf e;
+  | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident_loc li;
+  | Pexp_setinstvar (s, e) ->
+      line i ppf "Pexp_setinstvar %a\n" fmt_string_loc s;
+      expression i ppf e;
+  | Pexp_override (l) ->
+      line i ppf "Pexp_override\n";
+      list i string_x_expression ppf l;
+  | Pexp_letmodule (s, me, e) ->
+      line i ppf "Pexp_letmodule %a\n" fmt_str_opt_loc s;
+      module_expr i ppf me;
+      expression i ppf e;
+  | Pexp_letexception (cd, e) ->
+      line i ppf "Pexp_letexception\n";
+      extension_constructor i ppf cd;
+      expression i ppf e;
+  | Pexp_assert (e) ->
+      line i ppf "Pexp_assert\n";
+      expression i ppf e;
+  | Pexp_lazy (e) ->
+      line i ppf "Pexp_lazy\n";
+      expression i ppf e;
+  | Pexp_poly (e, cto) ->
+      line i ppf "Pexp_poly\n";
+      expression i ppf e;
+      option i core_type ppf cto;
+  | Pexp_object s ->
+      line i ppf "Pexp_object\n";
+      class_structure i ppf s
+  | Pexp_newtype (s, e) ->
+      line i ppf "Pexp_newtype \"%s\"\n" s.txt;
+      expression i ppf e
+  | Pexp_pack me ->
+      line i ppf "Pexp_pack\n";
+      module_expr i ppf me
+  | Pexp_open (o, e) ->
+      line i ppf "Pexp_open %a\n" fmt_override_flag o.popen_override;
+      module_expr i ppf o.popen_expr;
+      expression i ppf e
+  | Pexp_letop {let_; ands; body} ->
+      line i ppf "Pexp_letop\n";
+      binding_op i ppf let_;
+      list i binding_op ppf ands;
+      expression i ppf body
+  | Pexp_extension (s, arg) ->
+      line i ppf "Pexp_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+  | Pexp_unreachable ->
+      line i ppf "Pexp_unreachable"
+
+and value_description i ppf x =
+  line i ppf "value_description %a %a\n" fmt_string_loc
+       x.pval_name fmt_location x.pval_loc;
+  attributes i ppf x.pval_attributes;
+  core_type (i+1) ppf x.pval_type;
+  list (i+1) string ppf x.pval_prim
+
+and type_parameter i ppf (x, _variance) = core_type i ppf x
+
+and type_declaration i ppf x =
+  line i ppf "type_declaration %a %a\n" fmt_string_loc x.ptype_name
+       fmt_location x.ptype_loc;
+  attributes i ppf x.ptype_attributes;
+  let i = i+1 in
+  line i ppf "ptype_params =\n";
+  list (i+1) type_parameter ppf x.ptype_params;
+  line i ppf "ptype_cstrs =\n";
+  list (i+1) core_type_x_core_type_x_location ppf x.ptype_cstrs;
+  line i ppf "ptype_kind =\n";
+  type_kind (i+1) ppf x.ptype_kind;
+  line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private;
+  line i ppf "ptype_manifest =\n";
+  option (i+1) core_type ppf x.ptype_manifest
+
+and attribute i ppf k a =
+  line i ppf "%s \"%s\"\n" k a.attr_name.txt;
+  payload i ppf a.attr_payload;
+
+and attributes i ppf l =
+  let i = i + 1 in
+  List.iter (fun a ->
+    line i ppf "attribute \"%s\"\n" a.attr_name.txt;
+    payload (i + 1) ppf a.attr_payload;
+  ) l;
+
+and payload i ppf = function
+  | PStr x -> structure i ppf x
+  | PSig x -> signature i ppf x
+  | PTyp x -> core_type i ppf x
+  | PPat (x, None) -> pattern i ppf x
+  | PPat (x, Some g) ->
+    pattern i ppf x;
+    line i ppf "<when>\n";
+    expression (i + 1) ppf g
+
+
+and type_kind i ppf x =
+  match x with
+  | Ptype_abstract ->
+      line i ppf "Ptype_abstract\n"
+  | Ptype_variant l ->
+      line i ppf "Ptype_variant\n";
+      list (i+1) constructor_decl ppf l;
+  | Ptype_record l ->
+      line i ppf "Ptype_record\n";
+      list (i+1) label_decl ppf l;
+  | Ptype_open ->
+      line i ppf "Ptype_open\n";
+
+and type_extension i ppf x =
+  line i ppf "type_extension\n";
+  attributes i ppf x.ptyext_attributes;
+  let i = i+1 in
+  line i ppf "ptyext_path = %a\n" fmt_longident_loc x.ptyext_path;
+  line i ppf "ptyext_params =\n";
+  list (i+1) type_parameter ppf x.ptyext_params;
+  line i ppf "ptyext_constructors =\n";
+  list (i+1) extension_constructor ppf x.ptyext_constructors;
+  line i ppf "ptyext_private = %a\n" fmt_private_flag x.ptyext_private;
+
+and type_exception i ppf x =
+  line i ppf "type_exception\n";
+  attributes i ppf x.ptyexn_attributes;
+  let i = i+1 in
+  line i ppf "ptyext_constructor =\n";
+  let i = i+1 in
+  extension_constructor i ppf x.ptyexn_constructor
+
+and extension_constructor i ppf x =
+  line i ppf "extension_constructor %a\n" fmt_location x.pext_loc;
+  attributes i ppf x.pext_attributes;
+  let i = i + 1 in
+  line i ppf "pext_name = \"%s\"\n" x.pext_name.txt;
+  line i ppf "pext_kind =\n";
+  extension_constructor_kind (i + 1) ppf x.pext_kind;
+
+and extension_constructor_kind i ppf x =
+  match x with
+      Pext_decl(a, r) ->
+        line i ppf "Pext_decl\n";
+        constructor_arguments (i+1) ppf a;
+        option (i+1) core_type ppf r;
+    | Pext_rebind li ->
+        line i ppf "Pext_rebind\n";
+        line (i+1) ppf "%a\n" fmt_longident_loc li;
+
+and class_type i ppf x =
+  line i ppf "class_type %a\n" fmt_location x.pcty_loc;
+  attributes i ppf x.pcty_attributes;
+  let i = i+1 in
+  match x.pcty_desc with
+  | Pcty_constr (li, l) ->
+      line i ppf "Pcty_constr %a\n" fmt_longident_loc li;
+      list i core_type ppf l;
+  | Pcty_signature (cs) ->
+      line i ppf "Pcty_signature\n";
+      class_signature i ppf cs;
+  | Pcty_arrow (l, co, cl) ->
+      line i ppf "Pcty_arrow\n";
+      arg_label i ppf l;
+      core_type i ppf co;
+      class_type i ppf cl;
+  | Pcty_extension (s, arg) ->
+      line i ppf "Pcty_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+  | Pcty_open (o, e) ->
+      line i ppf "Pcty_open %a %a\n" fmt_override_flag o.popen_override
+        fmt_longident_loc o.popen_expr;
+      class_type i ppf e
+
+and class_signature i ppf cs =
+  line i ppf "class_signature\n";
+  core_type (i+1) ppf cs.pcsig_self;
+  list (i+1) class_type_field ppf cs.pcsig_fields;
+
+and class_type_field i ppf x =
+  line i ppf "class_type_field %a\n" fmt_location x.pctf_loc;
+  let i = i+1 in
+  attributes i ppf x.pctf_attributes;
+  match x.pctf_desc with
+  | Pctf_inherit (ct) ->
+      line i ppf "Pctf_inherit\n";
+      class_type i ppf ct;
+  | Pctf_val (s, mf, vf, ct) ->
+      line i ppf "Pctf_val \"%s\" %a %a\n" s.txt fmt_mutable_flag mf
+           fmt_virtual_flag vf;
+      core_type (i+1) ppf ct;
+  | Pctf_method (s, pf, vf, ct) ->
+      line i ppf "Pctf_method \"%s\" %a %a\n" s.txt fmt_private_flag pf
+           fmt_virtual_flag vf;
+      core_type (i+1) ppf ct;
+  | Pctf_constraint (ct1, ct2) ->
+      line i ppf "Pctf_constraint\n";
+      core_type (i+1) ppf ct1;
+      core_type (i+1) ppf ct2;
+  | Pctf_attribute a ->
+      attribute i ppf "Pctf_attribute" a
+  | Pctf_extension (s, arg) ->
+      line i ppf "Pctf_extension \"%s\"\n" s.txt;
+     payload i ppf arg
+
+and class_description i ppf x =
+  line i ppf "class_description %a\n" fmt_location x.pci_loc;
+  attributes i ppf x.pci_attributes;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.pci_params;
+  line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
+  line i ppf "pci_expr =\n";
+  class_type (i+1) ppf x.pci_expr;
+
+and class_type_declaration i ppf x =
+  line i ppf "class_type_declaration %a\n" fmt_location x.pci_loc;
+  attributes i ppf x.pci_attributes;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.pci_params;
+  line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
+  line i ppf "pci_expr =\n";
+  class_type (i+1) ppf x.pci_expr;
+
+and class_expr i ppf x =
+  line i ppf "class_expr %a\n" fmt_location x.pcl_loc;
+  attributes i ppf x.pcl_attributes;
+  let i = i+1 in
+  match x.pcl_desc with
+  | Pcl_constr (li, l) ->
+      line i ppf "Pcl_constr %a\n" fmt_longident_loc li;
+      list i core_type ppf l;
+  | Pcl_structure (cs) ->
+      line i ppf "Pcl_structure\n";
+      class_structure i ppf cs;
+  | Pcl_fun (l, eo, p, e) ->
+      line i ppf "Pcl_fun\n";
+      arg_label i ppf l;
+      option i expression ppf eo;
+      pattern i ppf p;
+      class_expr i ppf e;
+  | Pcl_apply (ce, l) ->
+      line i ppf "Pcl_apply\n";
+      class_expr i ppf ce;
+      list i label_x_expression ppf l;
+  | Pcl_let (rf, l, ce) ->
+      line i ppf "Pcl_let %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l;
+      class_expr i ppf ce;
+  | Pcl_constraint (ce, ct) ->
+      line i ppf "Pcl_constraint\n";
+      class_expr i ppf ce;
+      class_type i ppf ct;
+  | Pcl_extension (s, arg) ->
+      line i ppf "Pcl_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+  | Pcl_open (o, e) ->
+      line i ppf "Pcl_open %a %a\n" fmt_override_flag o.popen_override
+        fmt_longident_loc o.popen_expr;
+      class_expr i ppf e
+
+and class_structure i ppf { pcstr_self = p; pcstr_fields = l } =
+  line i ppf "class_structure\n";
+  pattern (i+1) ppf p;
+  list (i+1) class_field ppf l;
+
+and class_field i ppf x =
+  line i ppf "class_field %a\n" fmt_location x.pcf_loc;
+  let i = i + 1 in
+  attributes i ppf x.pcf_attributes;
+  match x.pcf_desc with
+  | Pcf_inherit (ovf, ce, so) ->
+      line i ppf "Pcf_inherit %a\n" fmt_override_flag ovf;
+      class_expr (i+1) ppf ce;
+      option (i+1) string_loc ppf so;
+  | Pcf_val (s, mf, k) ->
+      line i ppf "Pcf_val %a\n" fmt_mutable_flag mf;
+      line (i+1) ppf "%a\n" fmt_string_loc s;
+      class_field_kind (i+1) ppf k
+  | Pcf_method (s, pf, k) ->
+      line i ppf "Pcf_method %a\n" fmt_private_flag pf;
+      line (i+1) ppf "%a\n" fmt_string_loc s;
+      class_field_kind (i+1) ppf k
+  | Pcf_constraint (ct1, ct2) ->
+      line i ppf "Pcf_constraint\n";
+      core_type (i+1) ppf ct1;
+      core_type (i+1) ppf ct2;
+  | Pcf_initializer (e) ->
+      line i ppf "Pcf_initializer\n";
+      expression (i+1) ppf e;
+  | Pcf_attribute a ->
+      attribute i ppf "Pcf_attribute" a
+  | Pcf_extension (s, arg) ->
+      line i ppf "Pcf_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and class_field_kind i ppf = function
+  | Cfk_concrete (o, e) ->
+      line i ppf "Concrete %a\n" fmt_override_flag o;
+      expression i ppf e
+  | Cfk_virtual t ->
+      line i ppf "Virtual\n";
+      core_type i ppf t
+
+and class_declaration i ppf x =
+  line i ppf "class_declaration %a\n" fmt_location x.pci_loc;
+  attributes i ppf x.pci_attributes;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.pci_params;
+  line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
+  line i ppf "pci_expr =\n";
+  class_expr (i+1) ppf x.pci_expr;
+
+and module_type i ppf x =
+  line i ppf "module_type %a\n" fmt_location x.pmty_loc;
+  attributes i ppf x.pmty_attributes;
+  let i = i+1 in
+  match x.pmty_desc with
+  | Pmty_ident li -> line i ppf "Pmty_ident %a\n" fmt_longident_loc li;
+  | Pmty_alias li -> line i ppf "Pmty_alias %a\n" fmt_longident_loc li;
+  | Pmty_signature (s) ->
+      line i ppf "Pmty_signature\n";
+      signature i ppf s;
+  | Pmty_functor (Unit, mt2) ->
+      line i ppf "Pmty_functor ()\n";
+      module_type i ppf mt2;
+  | Pmty_functor (Named (s, mt1), mt2) ->
+      line i ppf "Pmty_functor %a\n" fmt_str_opt_loc s;
+      module_type i ppf mt1;
+      module_type i ppf mt2;
+  | Pmty_with (mt, l) ->
+      line i ppf "Pmty_with\n";
+      module_type i ppf mt;
+      list i with_constraint ppf l;
+  | Pmty_typeof m ->
+      line i ppf "Pmty_typeof\n";
+      module_expr i ppf m;
+  | Pmty_extension (s, arg) ->
+      line i ppf "Pmod_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and signature i ppf x = list i signature_item ppf x
+
+and signature_item i ppf x =
+  line i ppf "signature_item %a\n" fmt_location x.psig_loc;
+  let i = i+1 in
+  match x.psig_desc with
+  | Psig_value vd ->
+      line i ppf "Psig_value\n";
+      value_description i ppf vd;
+  | Psig_type (rf, l) ->
+      line i ppf "Psig_type %a\n" fmt_rec_flag rf;
+      list i type_declaration ppf l;
+  | Psig_typesubst l ->
+      line i ppf "Psig_typesubst\n";
+      list i type_declaration ppf l;
+  | Psig_typext te ->
+      line i ppf "Psig_typext\n";
+      type_extension i ppf te
+  | Psig_exception te ->
+      line i ppf "Psig_exception\n";
+      type_exception i ppf te
+  | Psig_module pmd ->
+      line i ppf "Psig_module %a\n" fmt_str_opt_loc pmd.pmd_name;
+      attributes i ppf pmd.pmd_attributes;
+      module_type i ppf pmd.pmd_type
+  | Psig_modsubst pms ->
+      line i ppf "Psig_modsubst %a = %a\n"
+        fmt_string_loc pms.pms_name
+        fmt_longident_loc pms.pms_manifest;
+      attributes i ppf pms.pms_attributes;
+  | Psig_recmodule decls ->
+      line i ppf "Psig_recmodule\n";
+      list i module_declaration ppf decls;
+  | Psig_modtype x ->
+      line i ppf "Psig_modtype %a\n" fmt_string_loc x.pmtd_name;
+      attributes i ppf x.pmtd_attributes;
+      modtype_declaration i ppf x.pmtd_type
+  | Psig_open od ->
+      line i ppf "Psig_open %a %a\n" fmt_override_flag od.popen_override
+        fmt_longident_loc od.popen_expr;
+      attributes i ppf od.popen_attributes
+  | Psig_include incl ->
+      line i ppf "Psig_include\n";
+      module_type i ppf incl.pincl_mod;
+      attributes i ppf incl.pincl_attributes
+  | Psig_class (l) ->
+      line i ppf "Psig_class\n";
+      list i class_description ppf l;
+  | Psig_class_type (l) ->
+      line i ppf "Psig_class_type\n";
+      list i class_type_declaration ppf l;
+  | Psig_extension ((s, arg), attrs) ->
+      line i ppf "Psig_extension \"%s\"\n" s.txt;
+      attributes i ppf attrs;
+      payload i ppf arg
+  | Psig_attribute a ->
+      attribute i ppf "Psig_attribute" a
+
+and modtype_declaration i ppf = function
+  | None -> line i ppf "#abstract"
+  | Some mt -> module_type (i+1) ppf mt
+
+and with_constraint i ppf x =
+  match x with
+  | Pwith_type (lid, td) ->
+      line i ppf "Pwith_type %a\n" fmt_longident_loc lid;
+      type_declaration (i+1) ppf td;
+  | Pwith_typesubst (lid, td) ->
+      line i ppf "Pwith_typesubst %a\n" fmt_longident_loc lid;
+      type_declaration (i+1) ppf td;
+  | Pwith_module (lid1, lid2) ->
+      line i ppf "Pwith_module %a = %a\n"
+        fmt_longident_loc lid1
+        fmt_longident_loc lid2;
+  | Pwith_modsubst (lid1, lid2) ->
+      line i ppf "Pwith_modsubst %a = %a\n"
+        fmt_longident_loc lid1
+        fmt_longident_loc lid2;
+
+and module_expr i ppf x =
+  line i ppf "module_expr %a\n" fmt_location x.pmod_loc;
+  attributes i ppf x.pmod_attributes;
+  let i = i+1 in
+  match x.pmod_desc with
+  | Pmod_ident (li) -> line i ppf "Pmod_ident %a\n" fmt_longident_loc li;
+  | Pmod_structure (s) ->
+      line i ppf "Pmod_structure\n";
+      structure i ppf s;
+  | Pmod_functor (Unit, me) ->
+      line i ppf "Pmod_functor ()\n";
+      module_expr i ppf me;
+  | Pmod_functor (Named (s, mt), me) ->
+      line i ppf "Pmod_functor %a\n" fmt_str_opt_loc s;
+      module_type i ppf mt;
+      module_expr i ppf me;
+  | Pmod_apply (me1, me2) ->
+      line i ppf "Pmod_apply\n";
+      module_expr i ppf me1;
+      module_expr i ppf me2;
+  | Pmod_constraint (me, mt) ->
+      line i ppf "Pmod_constraint\n";
+      module_expr i ppf me;
+      module_type i ppf mt;
+  | Pmod_unpack (e) ->
+      line i ppf "Pmod_unpack\n";
+      expression i ppf e;
+  | Pmod_extension (s, arg) ->
+      line i ppf "Pmod_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and structure i ppf x = list i structure_item ppf x
+
+and structure_item i ppf x =
+  line i ppf "structure_item %a\n" fmt_location x.pstr_loc;
+  let i = i+1 in
+  match x.pstr_desc with
+  | Pstr_eval (e, attrs) ->
+      line i ppf "Pstr_eval\n";
+      attributes i ppf attrs;
+      expression i ppf e;
+  | Pstr_value (rf, l) ->
+      line i ppf "Pstr_value %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l;
+  | Pstr_primitive vd ->
+      line i ppf "Pstr_primitive\n";
+      value_description i ppf vd;
+  | Pstr_type (rf, l) ->
+      line i ppf "Pstr_type %a\n" fmt_rec_flag rf;
+      list i type_declaration ppf l;
+  | Pstr_typext te ->
+      line i ppf "Pstr_typext\n";
+      type_extension i ppf te
+  | Pstr_exception te ->
+      line i ppf "Pstr_exception\n";
+      type_exception i ppf te
+  | Pstr_module x ->
+      line i ppf "Pstr_module\n";
+      module_binding i ppf x
+  | Pstr_recmodule bindings ->
+      line i ppf "Pstr_recmodule\n";
+      list i module_binding ppf bindings;
+  | Pstr_modtype x ->
+      line i ppf "Pstr_modtype %a\n" fmt_string_loc x.pmtd_name;
+      attributes i ppf x.pmtd_attributes;
+      modtype_declaration i ppf x.pmtd_type
+  | Pstr_open od ->
+      line i ppf "Pstr_open %a\n" fmt_override_flag od.popen_override;
+      module_expr i ppf od.popen_expr;
+      attributes i ppf od.popen_attributes
+  | Pstr_class (l) ->
+      line i ppf "Pstr_class\n";
+      list i class_declaration ppf l;
+  | Pstr_class_type (l) ->
+      line i ppf "Pstr_class_type\n";
+      list i class_type_declaration ppf l;
+  | Pstr_include incl ->
+      line i ppf "Pstr_include";
+      attributes i ppf incl.pincl_attributes;
+      module_expr i ppf incl.pincl_mod
+  | Pstr_extension ((s, arg), attrs) ->
+      line i ppf "Pstr_extension \"%s\"\n" s.txt;
+      attributes i ppf attrs;
+      payload i ppf arg
+  | Pstr_attribute a ->
+      attribute i ppf "Pstr_attribute" a
+
+and module_declaration i ppf pmd =
+  str_opt_loc i ppf pmd.pmd_name;
+  attributes i ppf pmd.pmd_attributes;
+  module_type (i+1) ppf pmd.pmd_type;
+
+and module_binding i ppf x =
+  str_opt_loc i ppf x.pmb_name;
+  attributes i ppf x.pmb_attributes;
+  module_expr (i+1) ppf x.pmb_expr
+
+and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
+  line i ppf "<constraint> %a\n" fmt_location l;
+  core_type (i+1) ppf ct1;
+  core_type (i+1) ppf ct2;
+
+and constructor_decl i ppf
+                     {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} =
+  line i ppf "%a\n" fmt_location pcd_loc;
+  line (i+1) ppf "%a\n" fmt_string_loc pcd_name;
+  attributes i ppf pcd_attributes;
+  constructor_arguments (i+1) ppf pcd_args;
+  option (i+1) core_type ppf pcd_res
+
+and constructor_arguments i ppf = function
+  | Pcstr_tuple l -> list i core_type ppf l
+  | Pcstr_record l -> list i label_decl ppf l
+
+and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes}=
+  line i ppf "%a\n" fmt_location pld_loc;
+  attributes i ppf pld_attributes;
+  line (i+1) ppf "%a\n" fmt_mutable_flag pld_mutable;
+  line (i+1) ppf "%a" fmt_string_loc pld_name;
+  core_type (i+1) ppf pld_type
+
+and longident_x_pattern i ppf (li, p) =
+  line i ppf "%a\n" fmt_longident_loc li;
+  pattern (i+1) ppf p;
+
+and case i ppf {pc_lhs; pc_guard; pc_rhs} =
+  line i ppf "<case>\n";
+  pattern (i+1) ppf pc_lhs;
+  begin match pc_guard with
+  | None -> ()
+  | Some g -> line (i+1) ppf "<when>\n"; expression (i + 2) ppf g
+  end;
+  expression (i+1) ppf pc_rhs;
+
+and value_binding i ppf x =
+  line i ppf "<def>\n";
+  attributes (i+1) ppf x.pvb_attributes;
+  pattern (i+1) ppf x.pvb_pat;
+  expression (i+1) ppf x.pvb_expr
+
+and binding_op i ppf x =
+  line i ppf "<binding_op> %a %a"
+    fmt_string_loc x.pbop_op fmt_location x.pbop_loc;
+  pattern (i+1) ppf x.pbop_pat;
+  expression (i+1) ppf x.pbop_exp;
+
+and string_x_expression i ppf (s, e) =
+  line i ppf "<override> %a\n" fmt_string_loc s;
+  expression (i+1) ppf e;
+
+and longident_x_expression i ppf (li, e) =
+  line i ppf "%a\n" fmt_longident_loc li;
+  expression (i+1) ppf e;
+
+and label_x_expression i ppf (l,e) =
+  line i ppf "<arg>\n";
+  arg_label i ppf l;
+  expression (i+1) ppf e;
+
+and label_x_bool_x_core_type_list i ppf x =
+  match x.prf_desc with
+    Rtag (l, b, ctl) ->
+      line i ppf "Rtag \"%s\" %s\n" l.txt (string_of_bool b);
+      attributes (i+1) ppf x.prf_attributes;
+      list (i+1) core_type ppf ctl
+  | Rinherit (ct) ->
+      line i ppf "Rinherit\n";
+      core_type (i+1) ppf ct
+;;
+
+let rec toplevel_phrase i ppf x =
+  match x with
+  | Ptop_def (s) ->
+      line i ppf "Ptop_def\n";
+      structure (i+1) ppf s;
+  | Ptop_dir {pdir_name; pdir_arg; _} ->
+      line i ppf "Ptop_dir \"%s\"\n" pdir_name.txt;
+      match pdir_arg with
+      | None -> ()
+      | Some da -> directive_argument i ppf da;
+
+and directive_argument i ppf x =
+  match x.pdira_desc with
+  | Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s;
+  | Pdir_int (n, None) -> line i ppf "Pdir_int %s\n" n;
+  | Pdir_int (n, Some m) -> line i ppf "Pdir_int %s%c\n" n m;
+  | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident li;
+  | Pdir_bool (b) -> line i ppf "Pdir_bool %s\n" (string_of_bool b);
+;;
+
+let interface ppf x = list 0 signature_item ppf x;;
+
+let implementation ppf x = list 0 structure_item ppf x;;
+
+let top_phrase ppf x = toplevel_phrase 0 ppf x;;
diff --git a/upstream/ocaml_412/parsing/printast.mli b/upstream/ocaml_412/parsing/printast.mli
new file mode 100644
index 0000000..8215654
--- /dev/null
+++ b/upstream/ocaml_412/parsing/printast.mli
@@ -0,0 +1,32 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*              Damien Doligez, projet Para, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Raw printer for {!Parsetree}
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Parsetree;;
+open Format;;
+
+val interface : formatter -> signature_item list -> unit;;
+val implementation : formatter -> structure_item list -> unit;;
+val top_phrase : formatter -> toplevel_phrase -> unit;;
+
+val expression: int -> formatter -> expression -> unit
+val structure: int -> formatter -> structure -> unit
+val payload: int -> formatter -> payload -> unit
diff --git a/upstream/ocaml_412/parsing/syntaxerr.ml b/upstream/ocaml_412/parsing/syntaxerr.ml
new file mode 100644
index 0000000..49372b9
--- /dev/null
+++ b/upstream/ocaml_412/parsing/syntaxerr.ml
@@ -0,0 +1,43 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Auxiliary type for reporting syntax errors *)
+
+type error =
+    Unclosed of Location.t * string * Location.t * string
+  | Expecting of Location.t * string
+  | Not_expecting of Location.t * string
+  | Applicative_path of Location.t
+  | Variable_in_scope of Location.t * string
+  | Other of Location.t
+  | Ill_formed_ast of Location.t * string
+  | Invalid_package_type of Location.t * string
+
+exception Error of error
+exception Escape_error
+
+let location_of_error = function
+  | Unclosed(l,_,_,_)
+  | Applicative_path l
+  | Variable_in_scope(l,_)
+  | Other l
+  | Not_expecting (l, _)
+  | Ill_formed_ast (l, _)
+  | Invalid_package_type (l, _)
+  | Expecting (l, _) -> l
+
+
+let ill_formed_ast loc s =
+  raise (Error (Ill_formed_ast (loc, s)))
diff --git a/upstream/ocaml_412/parsing/syntaxerr.mli b/upstream/ocaml_412/parsing/syntaxerr.mli
new file mode 100644
index 0000000..26ba712
--- /dev/null
+++ b/upstream/ocaml_412/parsing/syntaxerr.mli
@@ -0,0 +1,37 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Auxiliary type for reporting syntax errors
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type error =
+    Unclosed of Location.t * string * Location.t * string
+  | Expecting of Location.t * string
+  | Not_expecting of Location.t * string
+  | Applicative_path of Location.t
+  | Variable_in_scope of Location.t * string
+  | Other of Location.t
+  | Ill_formed_ast of Location.t * string
+  | Invalid_package_type of Location.t * string
+
+exception Error of error
+exception Escape_error
+
+val location_of_error: error -> Location.t
+val ill_formed_ast: Location.t -> string -> 'a
diff --git a/upstream/ocaml_412/typing/annot.mli b/upstream/ocaml_412/typing/annot.mli
new file mode 100644
index 0000000..3cae8f2
--- /dev/null
+++ b/upstream/ocaml_412/typing/annot.mli
@@ -0,0 +1,24 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Data types for annotations (Stypes.ml) *)
+
+type call = Tail | Stack | Inline;;
+
+type ident =
+  | Iref_internal of Location.t (* defining occurrence *)
+  | Iref_external
+  | Idef of Location.t          (* scope *)
+;;
diff --git a/upstream/ocaml_412/typing/btype.ml b/upstream/ocaml_412/typing/btype.ml
new file mode 100644
index 0000000..98531f1
--- /dev/null
+++ b/upstream/ocaml_412/typing/btype.ml
@@ -0,0 +1,822 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Basic operations on core types *)
+
+open Asttypes
+open Types
+
+open Local_store
+
+(**** Sets, maps and hashtables of types ****)
+
+module TypeSet = Set.Make(TypeOps)
+module TypeMap = Map.Make (TypeOps)
+module TypeHash = Hashtbl.Make(TypeOps)
+
+(**** Forward declarations ****)
+
+let print_raw =
+  ref (fun _ -> assert false : Format.formatter -> type_expr -> unit)
+
+(**** Type level management ****)
+
+let generic_level = Ident.highest_scope
+
+(* Used to mark a type during a traversal. *)
+let lowest_level = Ident.lowest_scope
+let pivot_level = 2 * lowest_level - 1
+    (* pivot_level - lowest_level < lowest_level *)
+
+(**** Some type creators ****)
+
+let new_id = s_ref (-1)
+
+let newty2 level desc  =
+  incr new_id; { desc; level; scope = lowest_level; id = !new_id }
+let newgenty desc      = newty2 generic_level desc
+let newgenvar ?name () = newgenty (Tvar name)
+(*
+let newmarkedvar level =
+  incr new_id; { desc = Tvar; level = pivot_level - level; id = !new_id }
+let newmarkedgenvar () =
+  incr new_id;
+  { desc = Tvar; level = pivot_level - generic_level; id = !new_id }
+*)
+
+(**** Check some types ****)
+
+let is_Tvar = function {desc=Tvar _} -> true | _ -> false
+let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false
+let is_Tconstr = function {desc=Tconstr _} -> true | _ -> false
+
+let dummy_method = "*dummy method*"
+
+(**** Definitions for backtracking ****)
+
+type change =
+    Ctype of type_expr * type_desc
+  | Ccompress of type_expr * type_desc * type_desc
+  | Clevel of type_expr * int
+  | Cscope of type_expr * int
+  | Cname of
+      (Path.t * type_expr list) option ref * (Path.t * type_expr list) option
+  | Crow of row_field option ref * row_field option
+  | Ckind of field_kind option ref * field_kind option
+  | Ccommu of commutable ref * commutable
+  | Cuniv of type_expr option ref * type_expr option
+  | Ctypeset of TypeSet.t ref * TypeSet.t
+
+type changes =
+    Change of change * changes ref
+  | Unchanged
+  | Invalid
+
+let trail = s_table Weak.create 1
+
+let log_change ch =
+  match Weak.get !trail 0 with None -> ()
+  | Some r ->
+      let r' = ref Unchanged in
+      r := Change (ch, r');
+      Weak.set !trail 0 (Some r')
+
+(**** Representative of a type ****)
+
+let rec field_kind_repr =
+  function
+    Fvar {contents = Some kind} -> field_kind_repr kind
+  | kind                        -> kind
+
+let rec repr_link compress t d =
+ function
+   {desc = Tlink t' as d'} ->
+     repr_link true t d' t'
+ | {desc = Tfield (_, k, _, t') as d'} when field_kind_repr k = Fabsent ->
+     repr_link true t d' t'
+ | t' ->
+     if compress then begin
+       log_change (Ccompress (t, t.desc, d)); t.desc <- d
+     end;
+     t'
+
+let repr t =
+  match t.desc with
+   Tlink t' as d ->
+     repr_link false t d t'
+ | Tfield (_, k, _, t') as d when field_kind_repr k = Fabsent ->
+     repr_link false t d t'
+ | _ -> t
+
+let rec commu_repr = function
+    Clink r when !r <> Cunknown -> commu_repr !r
+  | c -> c
+
+let rec row_field_repr_aux tl = function
+    Reither(_, tl', _, {contents = Some fi}) ->
+      row_field_repr_aux (tl@tl') fi
+  | Reither(c, tl', m, r) ->
+      Reither(c, tl@tl', m, r)
+  | Rpresent (Some _) when tl <> [] ->
+      Rpresent (Some (List.hd tl))
+  | fi -> fi
+
+let row_field_repr fi = row_field_repr_aux [] fi
+
+let rec rev_concat l ll =
+  match ll with
+    [] -> l
+  | l'::ll -> rev_concat (l'@l) ll
+
+let rec row_repr_aux ll row =
+  match (repr row.row_more).desc with
+  | Tvariant row' ->
+      let f = row.row_fields in
+      row_repr_aux (if f = [] then ll else f::ll) row'
+  | _ ->
+      if ll = [] then row else
+      {row with row_fields = rev_concat row.row_fields ll}
+
+let row_repr row = row_repr_aux [] row
+
+let rec row_field tag row =
+  let rec find = function
+    | (tag',f) :: fields ->
+        if tag = tag' then row_field_repr f else find fields
+    | [] ->
+        match repr row.row_more with
+        | {desc=Tvariant row'} -> row_field tag row'
+        | _ -> Rabsent
+  in find row.row_fields
+
+let rec row_more row =
+  match repr row.row_more with
+  | {desc=Tvariant row'} -> row_more row'
+  | ty -> ty
+
+let merge_fixed_explanation fixed1 fixed2 =
+  match fixed1, fixed2 with
+  | Some Univar _ as x, _ | _, (Some Univar _ as x) -> x
+  | Some Fixed_private as x, _ | _, (Some Fixed_private as x) -> x
+  | Some Reified _ as x, _ | _, (Some Reified _ as x) -> x
+  | Some Rigid as x, _ | _, (Some Rigid as x) -> x
+  | None, None -> None
+
+
+let fixed_explanation row =
+  let row = row_repr row in
+  match row.row_fixed with
+  | Some _ as x -> x
+  | None ->
+      let more = repr row.row_more in
+      match more.desc with
+      | Tvar _ | Tnil -> None
+      | Tunivar _ -> Some (Univar more)
+      | Tconstr (p,_,_) -> Some (Reified p)
+      | _ -> assert false
+
+let is_fixed row = match row.row_fixed with
+  | None -> false
+  | Some _ -> true
+
+let row_fixed row = fixed_explanation row <> None
+
+
+let static_row row =
+  let row = row_repr row in
+  row.row_closed &&
+  List.for_all
+    (fun (_,f) -> match row_field_repr f with Reither _ -> false | _ -> true)
+    row.row_fields
+
+let hash_variant s =
+  let accu = ref 0 in
+  for i = 0 to String.length s - 1 do
+    accu := 223 * !accu + Char.code s.[i]
+  done;
+  (* reduce to 31 bits *)
+  accu := !accu land (1 lsl 31 - 1);
+  (* make it signed for 64 bits architectures *)
+  if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu
+
+let proxy ty =
+  let ty0 = repr ty in
+  match ty0.desc with
+  | Tvariant row when not (static_row row) ->
+      row_more row
+  | Tobject (ty, _) ->
+      let rec proxy_obj ty =
+        match ty.desc with
+          Tfield (_, _, _, ty) | Tlink ty -> proxy_obj ty
+        | Tvar _ | Tunivar _ | Tconstr _ -> ty
+        | Tnil -> ty0
+        | _ -> assert false
+      in proxy_obj ty
+  | _ -> ty0
+
+(**** Utilities for fixed row private types ****)
+
+let row_of_type t =
+  match (repr t).desc with
+    Tobject(t,_) ->
+      let rec get_row t =
+        let t = repr t in
+        match t.desc with
+          Tfield(_,_,_,t) -> get_row t
+        | _ -> t
+      in get_row t
+  | Tvariant row ->
+      row_more row
+  | _ ->
+      t
+
+let has_constr_row t =
+  not (is_Tconstr t) && is_Tconstr (row_of_type t)
+
+let is_row_name s =
+  let l = String.length s in
+  if l < 4 then false else String.sub s (l-4) 4 = "#row"
+
+let is_constr_row ~allow_ident t =
+  match t.desc with
+    Tconstr (Path.Pident id, _, _) when allow_ident ->
+      is_row_name (Ident.name id)
+  | Tconstr (Path.Pdot (_, s), _, _) -> is_row_name s
+  | _ -> false
+
+
+                  (**********************************)
+                  (*  Utilities for type traversal  *)
+                  (**********************************)
+
+let rec fold_row f init row =
+  let result =
+    List.fold_left
+      (fun init (_, fi) ->
+         match row_field_repr fi with
+         | Rpresent(Some ty) -> f init ty
+         | Reither(_, tl, _, _) -> List.fold_left f init tl
+         | _ -> init)
+      init
+      row.row_fields
+  in
+  match (repr row.row_more).desc with
+    Tvariant row -> fold_row f result row
+  | Tvar _ | Tunivar _ | Tsubst _ | Tconstr _ | Tnil ->
+    begin match
+      Option.map (fun (_,l) -> List.fold_left f result l) row.row_name
+    with
+    | None -> result
+    | Some result -> result
+    end
+  | _ -> assert false
+
+let iter_row f row =
+  fold_row (fun () v -> f v) () row
+
+let fold_type_expr f init ty =
+  match ty.desc with
+    Tvar _              -> init
+  | Tarrow (_, ty1, ty2, _) ->
+    let result = f init ty1 in
+    f result ty2
+  | Ttuple l            -> List.fold_left f init l
+  | Tconstr (_, l, _)   -> List.fold_left f init l
+  | Tobject(ty, {contents = Some (_, p)})
+    ->
+    let result = f init ty in
+    List.fold_left f result p
+  | Tobject (ty, _)     -> f init ty
+  | Tvariant row        ->
+    let result = fold_row f init row in
+    f result (row_more row)
+  | Tfield (_, _, ty1, ty2) ->
+    let result = f init ty1 in
+    f result ty2
+  | Tnil                -> init
+  | Tlink ty            -> f init ty
+  | Tsubst ty           -> f init ty
+  | Tunivar _           -> init
+  | Tpoly (ty, tyl)     ->
+    let result = f init ty in
+    List.fold_left f result tyl
+  | Tpackage (_, _, l)  -> List.fold_left f init l
+
+let iter_type_expr f ty =
+  fold_type_expr (fun () v -> f v) () ty
+
+let rec iter_abbrev f = function
+    Mnil                   -> ()
+  | Mcons(_, _, ty, ty', rem) -> f ty; f ty'; iter_abbrev f rem
+  | Mlink rem              -> iter_abbrev f !rem
+
+type type_iterators =
+  { it_signature: type_iterators -> signature -> unit;
+    it_signature_item: type_iterators -> signature_item -> unit;
+    it_value_description: type_iterators -> value_description -> unit;
+    it_type_declaration: type_iterators -> type_declaration -> unit;
+    it_extension_constructor: type_iterators -> extension_constructor -> unit;
+    it_module_declaration: type_iterators -> module_declaration -> unit;
+    it_modtype_declaration: type_iterators -> modtype_declaration -> unit;
+    it_class_declaration: type_iterators -> class_declaration -> unit;
+    it_class_type_declaration: type_iterators -> class_type_declaration -> unit;
+    it_functor_param: type_iterators -> functor_parameter -> unit;
+    it_module_type: type_iterators -> module_type -> unit;
+    it_class_type: type_iterators -> class_type -> unit;
+    it_type_kind: type_iterators -> type_kind -> unit;
+    it_do_type_expr: type_iterators -> type_expr -> unit;
+    it_type_expr: type_iterators -> type_expr -> unit;
+    it_path: Path.t -> unit; }
+
+let iter_type_expr_cstr_args f = function
+  | Cstr_tuple tl -> List.iter f tl
+  | Cstr_record lbls -> List.iter (fun d -> f d.ld_type) lbls
+
+let map_type_expr_cstr_args f = function
+  | Cstr_tuple tl -> Cstr_tuple (List.map f tl)
+  | Cstr_record lbls ->
+      Cstr_record (List.map (fun d -> {d with ld_type=f d.ld_type}) lbls)
+
+let iter_type_expr_kind f = function
+  | Type_abstract -> ()
+  | Type_variant cstrs ->
+      List.iter
+        (fun cd ->
+           iter_type_expr_cstr_args f cd.cd_args;
+           Option.iter f cd.cd_res
+        )
+        cstrs
+  | Type_record(lbls, _) ->
+      List.iter (fun d -> f d.ld_type) lbls
+  | Type_open ->
+      ()
+
+
+let type_iterators =
+  let it_signature it =
+    List.iter (it.it_signature_item it)
+  and it_signature_item it = function
+      Sig_value (_, vd, _)          -> it.it_value_description it vd
+    | Sig_type (_, td, _, _)        -> it.it_type_declaration it td
+    | Sig_typext (_, td, _, _)      -> it.it_extension_constructor it td
+    | Sig_module (_, _, md, _, _)   -> it.it_module_declaration it md
+    | Sig_modtype (_, mtd, _)       -> it.it_modtype_declaration it mtd
+    | Sig_class (_, cd, _, _)       -> it.it_class_declaration it cd
+    | Sig_class_type (_, ctd, _, _) -> it.it_class_type_declaration it ctd
+  and it_value_description it vd =
+    it.it_type_expr it vd.val_type
+  and it_type_declaration it td =
+    List.iter (it.it_type_expr it) td.type_params;
+    Option.iter (it.it_type_expr it) td.type_manifest;
+    it.it_type_kind it td.type_kind
+  and it_extension_constructor it td =
+    it.it_path td.ext_type_path;
+    List.iter (it.it_type_expr it) td.ext_type_params;
+    iter_type_expr_cstr_args (it.it_type_expr it) td.ext_args;
+    Option.iter (it.it_type_expr it) td.ext_ret_type
+  and it_module_declaration it md =
+    it.it_module_type it md.md_type
+  and it_modtype_declaration it mtd =
+    Option.iter (it.it_module_type it) mtd.mtd_type
+  and it_class_declaration it cd =
+    List.iter (it.it_type_expr it) cd.cty_params;
+    it.it_class_type it cd.cty_type;
+    Option.iter (it.it_type_expr it) cd.cty_new;
+    it.it_path cd.cty_path
+  and it_class_type_declaration it ctd =
+    List.iter (it.it_type_expr it) ctd.clty_params;
+    it.it_class_type it ctd.clty_type;
+    it.it_path ctd.clty_path
+  and it_functor_param it = function
+    | Unit -> ()
+    | Named (_, mt) -> it.it_module_type it mt
+  and it_module_type it = function
+      Mty_ident p
+    | Mty_alias p -> it.it_path p
+    | Mty_signature sg -> it.it_signature it sg
+    | Mty_functor (p, mt) ->
+        it.it_functor_param it p;
+        it.it_module_type it mt
+  and it_class_type it = function
+      Cty_constr (p, tyl, cty) ->
+        it.it_path p;
+        List.iter (it.it_type_expr it) tyl;
+        it.it_class_type it cty
+    | Cty_signature cs ->
+        it.it_type_expr it cs.csig_self;
+        Vars.iter (fun _ (_,_,ty) -> it.it_type_expr it ty) cs.csig_vars;
+        List.iter
+          (fun (p, tl) -> it.it_path p; List.iter (it.it_type_expr it) tl)
+          cs.csig_inher
+    | Cty_arrow  (_, ty, cty) ->
+        it.it_type_expr it ty;
+        it.it_class_type it cty
+  and it_type_kind it kind =
+    iter_type_expr_kind (it.it_type_expr it) kind
+  and it_do_type_expr it ty =
+    iter_type_expr (it.it_type_expr it) ty;
+    match ty.desc with
+      Tconstr (p, _, _)
+    | Tobject (_, {contents=Some (p, _)})
+    | Tpackage (p, _, _) ->
+        it.it_path p
+    | Tvariant row ->
+        Option.iter (fun (p,_) -> it.it_path p) (row_repr row).row_name
+    | _ -> ()
+  and it_path _p = ()
+  in
+  { it_path; it_type_expr = it_do_type_expr; it_do_type_expr;
+    it_type_kind; it_class_type; it_functor_param; it_module_type;
+    it_signature; it_class_type_declaration; it_class_declaration;
+    it_modtype_declaration; it_module_declaration; it_extension_constructor;
+    it_type_declaration; it_value_description; it_signature_item; }
+
+let copy_row f fixed row keep more =
+  let fields = List.map
+      (fun (l, fi) -> l,
+        match row_field_repr fi with
+        | Rpresent(Some ty) -> Rpresent(Some(f ty))
+        | Reither(c, tl, m, e) ->
+            let e = if keep then e else ref None in
+            let m = if is_fixed row then fixed else m in
+            let tl = List.map f tl in
+            Reither(c, tl, m, e)
+        | _ -> fi)
+      row.row_fields in
+  let name =
+    match row.row_name with
+    | None -> None
+    | Some (path, tl) -> Some (path, List.map f tl) in
+  let row_fixed = if fixed then row.row_fixed else None in
+  { row_fields = fields; row_more = more;
+    row_bound = (); row_fixed;
+    row_closed = row.row_closed; row_name = name; }
+
+let rec copy_kind = function
+    Fvar{contents = Some k} -> copy_kind k
+  | Fvar _   -> Fvar (ref None)
+  | Fpresent -> Fpresent
+  | Fabsent  -> assert false
+
+let copy_commu c =
+  if commu_repr c = Cok then Cok else Clink (ref Cunknown)
+
+(* Since univars may be used as row variables, we need to do some
+   encoding during substitution *)
+let rec norm_univar ty =
+  match ty.desc with
+    Tunivar _ | Tsubst _ -> ty
+  | Tlink ty           -> norm_univar ty
+  | Ttuple (ty :: _)   -> norm_univar ty
+  | _                  -> assert false
+
+let rec copy_type_desc ?(keep_names=false) f = function
+    Tvar _ as ty        -> if keep_names then ty else Tvar None
+  | Tarrow (p, ty1, ty2, c)-> Tarrow (p, f ty1, f ty2, copy_commu c)
+  | Ttuple l            -> Ttuple (List.map f l)
+  | Tconstr (p, l, _)   -> Tconstr (p, List.map f l, ref Mnil)
+  | Tobject(ty, {contents = Some (p, tl)})
+                        -> Tobject (f ty, ref (Some(p, List.map f tl)))
+  | Tobject (ty, _)     -> Tobject (f ty, ref None)
+  | Tvariant _          -> assert false (* too ambiguous *)
+  | Tfield (p, k, ty1, ty2) -> (* the kind is kept shared *)
+      Tfield (p, field_kind_repr k, f ty1, f ty2)
+  | Tnil                -> Tnil
+  | Tlink ty            -> copy_type_desc f ty.desc
+  | Tsubst _            -> assert false
+  | Tunivar _ as ty     -> ty (* always keep the name *)
+  | Tpoly (ty, tyl)     ->
+      let tyl = List.map (fun x -> norm_univar (f x)) tyl in
+      Tpoly (f ty, tyl)
+  | Tpackage (p, n, l)  -> Tpackage (p, n, List.map f l)
+
+(* Utilities for copying *)
+
+module For_copy : sig
+  type copy_scope
+
+  val save_desc: copy_scope -> type_expr -> type_desc -> unit
+
+  val dup_kind: copy_scope -> field_kind option ref -> unit
+
+  val with_scope: (copy_scope -> 'a) -> 'a
+end = struct
+  type copy_scope = {
+    mutable saved_desc : (type_expr * type_desc) list;
+    (* Save association of generic nodes with their description. *)
+
+    mutable saved_kinds: field_kind option ref list;
+    (* duplicated kind variables *)
+
+    mutable new_kinds  : field_kind option ref list;
+    (* new kind variables *)
+  }
+
+  let save_desc copy_scope ty desc =
+    copy_scope.saved_desc <- (ty, desc) :: copy_scope.saved_desc
+
+  let dup_kind copy_scope r =
+    assert (Option.is_none !r);
+    if not (List.memq r copy_scope.new_kinds) then begin
+      copy_scope.saved_kinds <- r :: copy_scope.saved_kinds;
+      let r' = ref None in
+      copy_scope.new_kinds <- r' :: copy_scope.new_kinds;
+      r := Some (Fvar r')
+    end
+
+  (* Restore type descriptions. *)
+  let cleanup { saved_desc; saved_kinds; _ } =
+    List.iter (fun (ty, desc) -> ty.desc <- desc) saved_desc;
+    List.iter (fun r -> r := None) saved_kinds
+
+  let with_scope f =
+    let scope = { saved_desc = []; saved_kinds = []; new_kinds = [] } in
+    let res = f scope in
+    cleanup scope;
+    res
+end
+
+(* Mark a type. *)
+let rec mark_type ty =
+  let ty = repr ty in
+  if ty.level >= lowest_level then begin
+    ty.level <- pivot_level - ty.level;
+    iter_type_expr mark_type ty
+  end
+
+let mark_type_node ty =
+  let ty = repr ty in
+  if ty.level >= lowest_level then begin
+    ty.level <- pivot_level - ty.level;
+  end
+
+let mark_type_params ty =
+  iter_type_expr mark_type ty
+
+let type_iterators =
+  let it_type_expr it ty =
+    let ty = repr ty in
+    if ty.level >= lowest_level then begin
+      mark_type_node ty;
+      it.it_do_type_expr it ty;
+    end
+  in
+  {type_iterators with it_type_expr}
+
+
+(* Remove marks from a type. *)
+let rec unmark_type ty =
+  let ty = repr ty in
+  if ty.level < lowest_level then begin
+    ty.level <- pivot_level - ty.level;
+    iter_type_expr unmark_type ty
+  end
+
+let unmark_iterators =
+  let it_type_expr _it ty = unmark_type ty in
+  {type_iterators with it_type_expr}
+
+let unmark_type_decl decl =
+  unmark_iterators.it_type_declaration unmark_iterators decl
+
+let unmark_extension_constructor ext =
+  List.iter unmark_type ext.ext_type_params;
+  iter_type_expr_cstr_args unmark_type ext.ext_args;
+  Option.iter unmark_type ext.ext_ret_type
+
+let unmark_class_signature sign =
+  unmark_type sign.csig_self;
+  Vars.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_vars
+
+let unmark_class_type cty =
+  unmark_iterators.it_class_type unmark_iterators cty
+
+
+                  (*******************************************)
+                  (*  Memorization of abbreviation expansion *)
+                  (*******************************************)
+
+(* Search whether the expansion has been memorized. *)
+
+let lte_public p1 p2 =  (* Private <= Public *)
+  match p1, p2 with
+  | Private, _ | _, Public -> true
+  | Public, Private -> false
+
+let rec find_expans priv p1 = function
+    Mnil -> None
+  | Mcons (priv', p2, _ty0, ty, _)
+    when lte_public priv priv' && Path.same p1 p2 -> Some ty
+  | Mcons (_, _, _, _, rem)   -> find_expans priv p1 rem
+  | Mlink {contents = rem} -> find_expans priv p1 rem
+
+(* debug: check for cycles in abbreviation. only works with -principal
+let rec check_expans visited ty =
+  let ty = repr ty in
+  assert (not (List.memq ty visited));
+  match ty.desc with
+    Tconstr (path, args, abbrev) ->
+      begin match find_expans path !abbrev with
+        Some ty' -> check_expans (ty :: visited) ty'
+      | None -> ()
+      end
+  | _ -> ()
+*)
+
+let memo = s_ref []
+        (* Contains the list of saved abbreviation expansions. *)
+
+let cleanup_abbrev () =
+        (* Remove all memorized abbreviation expansions. *)
+  List.iter (fun abbr -> abbr := Mnil) !memo;
+  memo := []
+
+let memorize_abbrev mem priv path v v' =
+        (* Memorize the expansion of an abbreviation. *)
+  mem := Mcons (priv, path, v, v', !mem);
+  (* check_expans [] v; *)
+  memo := mem :: !memo
+
+let rec forget_abbrev_rec mem path =
+  match mem with
+    Mnil ->
+      mem
+  | Mcons (_, path', _, _, rem) when Path.same path path' ->
+      rem
+  | Mcons (priv, path', v, v', rem) ->
+      Mcons (priv, path', v, v', forget_abbrev_rec rem path)
+  | Mlink mem' ->
+      mem' := forget_abbrev_rec !mem' path;
+      raise Exit
+
+let forget_abbrev mem path =
+  try mem := forget_abbrev_rec !mem path with Exit -> ()
+
+(* debug: check for invalid abbreviations
+let rec check_abbrev_rec = function
+    Mnil -> true
+  | Mcons (_, ty1, ty2, rem) ->
+      repr ty1 != repr ty2
+  | Mlink mem' ->
+      check_abbrev_rec !mem'
+
+let check_memorized_abbrevs () =
+  List.for_all (fun mem -> check_abbrev_rec !mem) !memo
+*)
+
+                  (**********************************)
+                  (*  Utilities for labels          *)
+                  (**********************************)
+
+let is_optional = function Optional _ -> true | _ -> false
+
+let label_name = function
+    Nolabel -> ""
+  | Labelled s
+  | Optional s -> s
+
+let prefixed_label_name = function
+    Nolabel -> ""
+  | Labelled s -> "~" ^ s
+  | Optional s -> "?" ^ s
+
+let rec extract_label_aux hd l = function
+  | [] -> None
+  | (l',t as p) :: ls ->
+      if label_name l' = l then
+        Some (l', t, hd <> [], List.rev_append hd ls)
+      else
+        extract_label_aux (p::hd) l ls
+
+let extract_label l ls = extract_label_aux [] l ls
+
+
+                  (**********************************)
+                  (*  Utilities for backtracking    *)
+                  (**********************************)
+
+let undo_change = function
+    Ctype  (ty, desc) -> ty.desc <- desc
+  | Ccompress  (ty, desc, _) -> ty.desc <- desc
+  | Clevel (ty, level) -> ty.level <- level
+  | Cscope (ty, scope) -> ty.scope <- scope
+  | Cname  (r, v) -> r := v
+  | Crow   (r, v) -> r := v
+  | Ckind  (r, v) -> r := v
+  | Ccommu (r, v) -> r := v
+  | Cuniv  (r, v) -> r := v
+  | Ctypeset (r, v) -> r := v
+
+type snapshot = changes ref * int
+let last_snapshot = s_ref 0
+
+let log_type ty =
+  if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc))
+let link_type ty ty' =
+  log_type ty;
+  let desc = ty.desc in
+  ty.desc <- Tlink ty';
+  (* Name is a user-supplied name for this unification variable (obtained
+   * through a type annotation for instance). *)
+  match desc, ty'.desc with
+    Tvar name, Tvar name' ->
+      begin match name, name' with
+      | Some _, None ->  log_type ty'; ty'.desc <- Tvar name
+      | None, Some _ ->  ()
+      | Some _, Some _ ->
+          if ty.level < ty'.level then (log_type ty'; ty'.desc <- Tvar name)
+      | None, None   ->  ()
+      end
+  | _ -> ()
+  (* ; assert (check_memorized_abbrevs ()) *)
+  (*  ; check_expans [] ty' *)
+let set_type_desc ty td =
+  if td != ty.desc then begin
+    log_type ty;
+    ty.desc <- td
+  end
+let set_level ty level =
+  if level <> ty.level then begin
+    if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level));
+    ty.level <- level
+  end
+let set_scope ty scope =
+  if scope <> ty.scope then begin
+    if ty.id <= !last_snapshot then log_change (Cscope (ty, ty.scope));
+    ty.scope <- scope
+  end
+let set_univar rty ty =
+  log_change (Cuniv (rty, !rty)); rty := Some ty
+let set_name nm v =
+  log_change (Cname (nm, !nm)); nm := v
+let set_row_field e v =
+  log_change (Crow (e, !e)); e := Some v
+let set_kind rk k =
+  log_change (Ckind (rk, !rk)); rk := Some k
+let set_commu rc c =
+  log_change (Ccommu (rc, !rc)); rc := c
+let set_typeset rs s =
+  log_change (Ctypeset (rs, !rs)); rs := s
+
+let snapshot () =
+  let old = !last_snapshot in
+  last_snapshot := !new_id;
+  match Weak.get !trail 0 with Some r -> (r, old)
+  | None ->
+      let r = ref Unchanged in
+      Weak.set !trail 0 (Some r);
+      (r, old)
+
+let rec rev_log accu = function
+    Unchanged -> accu
+  | Invalid -> assert false
+  | Change (ch, next) ->
+      let d = !next in
+      next := Invalid;
+      rev_log (ch::accu) d
+
+let backtrack (changes, old) =
+  match !changes with
+    Unchanged -> last_snapshot := old
+  | Invalid -> failwith "Btype.backtrack"
+  | Change _ as change ->
+      cleanup_abbrev ();
+      let backlog = rev_log [] change in
+      List.iter undo_change backlog;
+      changes := Unchanged;
+      last_snapshot := old;
+      Weak.set !trail 0 (Some changes)
+
+let rec rev_compress_log log r =
+  match !r with
+    Unchanged | Invalid ->
+      log
+  | Change (Ccompress _, next) ->
+      rev_compress_log (r::log) next
+  | Change (_, next) ->
+      rev_compress_log log next
+
+let undo_compress (changes, _old) =
+  match !changes with
+    Unchanged
+  | Invalid -> ()
+  | Change _ ->
+      let log = rev_compress_log [] changes in
+      List.iter
+        (fun r -> match !r with
+          Change (Ccompress (ty, desc, d), next) when ty.desc == d ->
+            ty.desc <- desc; r := !next
+        | _ -> ())
+        log
diff --git a/upstream/ocaml_412/typing/btype.mli b/upstream/ocaml_412/typing/btype.mli
new file mode 100644
index 0000000..7c215ed
--- /dev/null
+++ b/upstream/ocaml_412/typing/btype.mli
@@ -0,0 +1,255 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Basic operations on core types *)
+
+open Asttypes
+open Types
+
+(**** Sets, maps and hashtables of types ****)
+
+module TypeSet  : Set.S with type elt = type_expr
+module TypeMap  : Map.S with type key = type_expr
+module TypeHash : Hashtbl.S with type key = type_expr
+
+(**** Levels ****)
+
+val generic_level: int
+
+val newty2: int -> type_desc -> type_expr
+        (* Create a type *)
+val newgenty: type_desc -> type_expr
+        (* Create a generic type *)
+val newgenvar: ?name:string -> unit -> type_expr
+        (* Return a fresh generic variable *)
+
+(* Use Tsubst instead
+val newmarkedvar: int -> type_expr
+        (* Return a fresh marked variable *)
+val newmarkedgenvar: unit -> type_expr
+        (* Return a fresh marked generic variable *)
+*)
+
+(**** Types ****)
+
+val is_Tvar: type_expr -> bool
+val is_Tunivar: type_expr -> bool
+val is_Tconstr: type_expr -> bool
+val dummy_method: label
+
+val repr: type_expr -> type_expr
+        (* Return the canonical representative of a type. *)
+
+val field_kind_repr: field_kind -> field_kind
+        (* Return the canonical representative of an object field
+           kind. *)
+
+val commu_repr: commutable -> commutable
+        (* Return the canonical representative of a commutation lock *)
+
+(**** polymorphic variants ****)
+
+val row_repr: row_desc -> row_desc
+        (* Return the canonical representative of a row description *)
+val row_field_repr: row_field -> row_field
+val row_field: label -> row_desc -> row_field
+        (* Return the canonical representative of a row field *)
+val row_more: row_desc -> type_expr
+        (* Return the extension variable of the row *)
+
+val is_fixed: row_desc -> bool
+(* Return whether the row is directly marked as fixed or not *)
+
+val row_fixed: row_desc -> bool
+(* Return whether the row should be treated as fixed or not.
+   In particular, [is_fixed row] implies [row_fixed row].
+*)
+
+val fixed_explanation: row_desc -> fixed_explanation option
+(* Return the potential explanation for the fixed row *)
+
+val merge_fixed_explanation:
+  fixed_explanation option -> fixed_explanation option
+  -> fixed_explanation option
+(* Merge two explanations for a fixed row *)
+
+val static_row: row_desc -> bool
+        (* Return whether the row is static or not *)
+val hash_variant: label -> int
+        (* Hash function for variant tags *)
+
+val proxy: type_expr -> type_expr
+        (* Return the proxy representative of the type: either itself
+           or a row variable *)
+
+(**** Utilities for private abbreviations with fixed rows ****)
+val row_of_type: type_expr -> type_expr
+val has_constr_row: type_expr -> bool
+val is_row_name: string -> bool
+val is_constr_row: allow_ident:bool -> type_expr -> bool
+
+(**** Utilities for type traversal ****)
+
+val iter_type_expr: (type_expr -> unit) -> type_expr -> unit
+        (* Iteration on types *)
+val fold_type_expr: ('a -> type_expr -> 'a) -> 'a -> type_expr -> 'a
+val iter_row: (type_expr -> unit) -> row_desc -> unit
+        (* Iteration on types in a row *)
+val fold_row: ('a -> type_expr -> 'a) -> 'a -> row_desc -> 'a
+val iter_abbrev: (type_expr -> unit) -> abbrev_memo -> unit
+        (* Iteration on types in an abbreviation list *)
+
+type type_iterators =
+  { it_signature: type_iterators -> signature -> unit;
+    it_signature_item: type_iterators -> signature_item -> unit;
+    it_value_description: type_iterators -> value_description -> unit;
+    it_type_declaration: type_iterators -> type_declaration -> unit;
+    it_extension_constructor: type_iterators -> extension_constructor -> unit;
+    it_module_declaration: type_iterators -> module_declaration -> unit;
+    it_modtype_declaration: type_iterators -> modtype_declaration -> unit;
+    it_class_declaration: type_iterators -> class_declaration -> unit;
+    it_class_type_declaration: type_iterators -> class_type_declaration -> unit;
+    it_functor_param: type_iterators -> functor_parameter -> unit;
+    it_module_type: type_iterators -> module_type -> unit;
+    it_class_type: type_iterators -> class_type -> unit;
+    it_type_kind: type_iterators -> type_kind -> unit;
+    it_do_type_expr: type_iterators -> type_expr -> unit;
+    it_type_expr: type_iterators -> type_expr -> unit;
+    it_path: Path.t -> unit; }
+val type_iterators: type_iterators
+        (* Iteration on arbitrary type information.
+           [it_type_expr] calls [mark_type_node] to avoid loops. *)
+val unmark_iterators: type_iterators
+        (* Unmark any structure containing types. See [unmark_type] below. *)
+
+val copy_type_desc:
+    ?keep_names:bool -> (type_expr -> type_expr) -> type_desc -> type_desc
+        (* Copy on types *)
+val copy_row:
+    (type_expr -> type_expr) ->
+    bool -> row_desc -> bool -> type_expr -> row_desc
+val copy_kind: field_kind -> field_kind
+
+module For_copy : sig
+
+  type copy_scope
+        (* The private state that the primitives below are mutating, it should
+           remain scoped within a single [with_scope] call.
+
+           While it is possible to circumvent that discipline in various
+           ways, you should NOT do that. *)
+
+  val save_desc: copy_scope -> type_expr -> type_desc -> unit
+        (* Save a type description *)
+
+  val dup_kind: copy_scope -> field_kind option ref -> unit
+        (* Save a None field_kind, and make it point to a fresh Fvar *)
+
+  val with_scope: (copy_scope -> 'a) -> 'a
+        (* [with_scope f] calls [f] and restores saved type descriptions
+           before returning its result. *)
+end
+
+val lowest_level: int
+        (* Marked type: ty.level < lowest_level *)
+val pivot_level: int
+        (* Type marking: ty.level <- pivot_level - ty.level *)
+val mark_type: type_expr -> unit
+        (* Mark a type *)
+val mark_type_node: type_expr -> unit
+        (* Mark a type node (but not its sons) *)
+val mark_type_params: type_expr -> unit
+        (* Mark the sons of a type node *)
+val unmark_type: type_expr -> unit
+val unmark_type_decl: type_declaration -> unit
+val unmark_extension_constructor: extension_constructor -> unit
+val unmark_class_type: class_type -> unit
+val unmark_class_signature: class_signature -> unit
+        (* Remove marks from a type *)
+
+(**** Memorization of abbreviation expansion ****)
+
+val find_expans: private_flag -> Path.t -> abbrev_memo -> type_expr option
+        (* Look up a memorized abbreviation *)
+val cleanup_abbrev: unit -> unit
+        (* Flush the cache of abbreviation expansions.
+           When some types are saved (using [output_value]), this
+           function MUST be called just before. *)
+val memorize_abbrev:
+        abbrev_memo ref ->
+        private_flag -> Path.t -> type_expr -> type_expr -> unit
+        (* Add an expansion in the cache *)
+val forget_abbrev:
+        abbrev_memo ref -> Path.t -> unit
+        (* Remove an abbreviation from the cache *)
+
+(**** Utilities for labels ****)
+
+val is_optional : arg_label -> bool
+val label_name : arg_label -> label
+
+(* Returns the label name with first character '?' or '~' as appropriate. *)
+val prefixed_label_name : arg_label -> label
+
+val extract_label :
+    label -> (arg_label * 'a) list ->
+    (arg_label * 'a * bool * (arg_label * 'a) list) option
+(* actual label,
+   value,
+   whether (label, value) was at the head of the list,
+   list without the extracted (label, value) *)
+
+(**** Utilities for backtracking ****)
+
+type snapshot
+        (* A snapshot for backtracking *)
+val snapshot: unit -> snapshot
+        (* Make a snapshot for later backtracking. Costs nothing *)
+val backtrack: snapshot -> unit
+        (* Backtrack to a given snapshot. Only possible if you have
+           not already backtracked to a previous snapshot.
+           Calls [cleanup_abbrev] internally *)
+val undo_compress: snapshot -> unit
+        (* Backtrack only path compression. Only meaningful if you have
+           not already backtracked to a previous snapshot.
+           Does not call [cleanup_abbrev] *)
+
+(* Functions to use when modifying a type (only Ctype?) *)
+val link_type: type_expr -> type_expr -> unit
+        (* Set the desc field of [t1] to [Tlink t2], logging the old
+           value if there is an active snapshot *)
+val set_type_desc: type_expr -> type_desc -> unit
+        (* Set directly the desc field, without sharing *)
+val set_level: type_expr -> int -> unit
+val set_scope: type_expr -> int -> unit
+val set_name:
+    (Path.t * type_expr list) option ref ->
+    (Path.t * type_expr list) option -> unit
+val set_row_field: row_field option ref -> row_field -> unit
+val set_univar: type_expr option ref -> type_expr -> unit
+val set_kind: field_kind option ref -> field_kind -> unit
+val set_commu: commutable ref -> commutable -> unit
+val set_typeset: TypeSet.t ref -> TypeSet.t -> unit
+        (* Set references, logging the old value *)
+
+(**** Forward declarations ****)
+val print_raw: (Format.formatter -> type_expr -> unit) ref
+
+val iter_type_expr_kind: (type_expr -> unit) -> (type_kind -> unit)
+
+val iter_type_expr_cstr_args: (type_expr -> unit) ->
+  (constructor_arguments -> unit)
+val map_type_expr_cstr_args: (type_expr -> type_expr) ->
+  (constructor_arguments -> constructor_arguments)
diff --git a/upstream/ocaml_412/typing/ctype.ml b/upstream/ocaml_412/typing/ctype.ml
new file mode 100644
index 0000000..00bce3b
--- /dev/null
+++ b/upstream/ocaml_412/typing/ctype.ml
@@ -0,0 +1,4923 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Operations on core types *)
+
+open Misc
+open Asttypes
+open Types
+open Btype
+
+open Local_store
+
+(*
+   Type manipulation after type inference
+   ======================================
+   If one wants to manipulate a type after type inference (for
+   instance, during code generation or in the debugger), one must
+   first make sure that the type levels are correct, using the
+   function [correct_levels]. Then, this type can be correctly
+   manipulated by [apply], [expand_head] and [moregeneral].
+*)
+
+(*
+   General notes
+   =============
+   - As much sharing as possible should be kept : it makes types
+     smaller and better abbreviated.
+     When necessary, some sharing can be lost. Types will still be
+     printed correctly (+++ TO DO...), and abbreviations defined by a
+     class do not depend on sharing thanks to constrained
+     abbreviations. (Of course, even if some sharing is lost, typing
+     will still be correct.)
+   - All nodes of a type have a level : that way, one know whether a
+     node need to be duplicated or not when instantiating a type.
+   - Levels of a type are decreasing (generic level being considered
+     as greatest).
+   - The level of a type constructor is superior to the binding
+     time of its path.
+   - Recursive types without limitation should be handled (even if
+     there is still an occur check). This avoid treating specially the
+     case for objects, for instance. Furthermore, the occur check
+     policy can then be easily changed.
+*)
+
+(**** Errors ****)
+
+module Unification_trace = struct
+
+  type position = First | Second
+  let swap_position = function
+    | First -> Second
+    | Second -> First
+
+  type desc = { t: type_expr; expanded: type_expr option }
+  type 'a diff = { got: 'a; expected: 'a}
+
+  type 'a escape =
+    | Constructor of Path.t
+    | Univ of type_expr
+    (* The type_expr argument of [Univ] is always a [Tunivar _],
+       we keep a [type_expr] to track renaming in {!Printtyp} *)
+    | Self
+    | Module_type of Path.t
+    | Equation of 'a
+
+  type fixed_row_case =
+    | Cannot_be_closed
+    | Cannot_add_tags of string list
+
+  type variant =
+    | No_intersection
+    | No_tags of position * (Asttypes.label * row_field) list
+    | Incompatible_types_for of string
+    | Fixed_row of position * fixed_row_case * fixed_explanation
+
+
+  type obj =
+    | Missing_field of position * string
+    | Abstract_row of position
+    | Self_cannot_be_closed
+
+  type 'a elt =
+    | Diff of 'a diff
+    | Variant of variant
+    | Obj of obj
+    | Escape of {context:type_expr option; kind: 'a escape}
+    | Incompatible_fields of {name:string; diff:type_expr diff }
+    | Rec_occur of type_expr * type_expr
+
+  type t = desc elt list
+  let short t = { t; expanded = None }
+  let map_diff f r =
+    (* ordering is often meaningful when dealing with type_expr *)
+    let got = f r.got in
+    let expected = f r.expected in
+    { got; expected}
+  let diff got expected = Diff (map_diff short {got;expected})
+
+  let map_elt f = function
+    | Diff x -> Diff (map_diff f x)
+    | Escape {kind=Equation x; context} -> Escape {kind=Equation(f x); context}
+    | Rec_occur (_,_)
+    | Escape {kind=(Univ _ | Self|Constructor _ | Module_type _ ); _}
+    | Variant _ | Obj _
+    | Incompatible_fields _ as x -> x
+  let map f = List.map (map_elt f)
+
+
+  (* Convert desc to type_expr * type_expr *)
+  let flatten_desc f x = match x.expanded with
+    | None -> f x.t x.t
+    | Some expanded -> f x.t expanded
+  let flatten f = map (flatten_desc f)
+
+  (* Permute the expected and actual values *)
+  let swap_diff x = { got = x.expected; expected = x.got }
+  let swap_elt = function
+    | Diff x -> Diff (swap_diff x)
+    | Incompatible_fields {name;diff} ->
+        Incompatible_fields { name; diff = swap_diff diff}
+    | Obj (Missing_field(pos,s)) -> Obj(Missing_field(swap_position pos,s))
+    | Obj (Abstract_row pos) -> Obj(Abstract_row (swap_position pos))
+    | Variant (Fixed_row(pos,k,f)) -> Variant (Fixed_row(swap_position pos,k,f))
+    | Variant (No_tags(pos,f)) -> Variant (No_tags(swap_position pos,f))
+    | x -> x
+  let swap x = List.map swap_elt x
+
+  exception Unify of t
+
+  let escape kind =  Escape { kind; context = None}
+  let scope_escape x = Unify[escape (Equation (short x))]
+  let rec_occur x y = Unify[Rec_occur(x, y)]
+  let incompatible_fields name got expected =
+    Incompatible_fields {name; diff={got; expected} }
+
+  let explain trace f =
+    let rec explain = function
+      | [] -> None
+      | [h] -> f ~prev:None h
+      | h :: (prev :: _ as rem) ->
+        match f ~prev:(Some prev) h with
+        | Some _ as m -> m
+        | None -> explain rem in
+    explain (List.rev trace)
+
+end
+module Trace = Unification_trace
+
+exception Unify = Trace.Unify
+
+exception Tags of label * label
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Tags (l, l') ->
+          Some
+            Location.
+              (errorf ~loc:(in_file !input_name)
+                 "In this program,@ variant constructors@ `%s and `%s@ \
+                  have the same hash value.@ Change one of them." l l'
+              )
+      | _ -> None
+    )
+
+exception Subtype of Unification_trace.t * Unification_trace.t
+
+exception Cannot_expand
+
+exception Cannot_apply
+
+(**** Type level management ****)
+
+let current_level = s_ref 0
+let nongen_level = s_ref 0
+let global_level = s_ref 1
+let saved_level = s_ref []
+
+type levels =
+    { current_level: int; nongen_level: int; global_level: int;
+      saved_level: (int * int) list; }
+let save_levels () =
+  { current_level = !current_level;
+    nongen_level = !nongen_level;
+    global_level = !global_level;
+    saved_level = !saved_level }
+let set_levels l =
+  current_level := l.current_level;
+  nongen_level := l.nongen_level;
+  global_level := l.global_level;
+  saved_level := l.saved_level
+
+let get_current_level () = !current_level
+let init_def level = current_level := level; nongen_level := level
+let begin_def () =
+  saved_level := (!current_level, !nongen_level) :: !saved_level;
+  incr current_level; nongen_level := !current_level
+let begin_class_def () =
+  saved_level := (!current_level, !nongen_level) :: !saved_level;
+  incr current_level
+let raise_nongen_level () =
+  saved_level := (!current_level, !nongen_level) :: !saved_level;
+  nongen_level := !current_level
+let end_def () =
+  let (cl, nl) = List.hd !saved_level in
+  saved_level := List.tl !saved_level;
+  current_level := cl; nongen_level := nl
+let create_scope () =
+  init_def (!current_level + 1);
+  !current_level
+
+let reset_global_level () =
+  global_level := !current_level + 1
+let increase_global_level () =
+  let gl = !global_level in
+  global_level := !current_level;
+  gl
+let restore_global_level gl =
+  global_level := gl
+
+(**** Whether a path points to an object type (with hidden row variable) ****)
+let is_object_type path =
+  let name =
+    match path with Path.Pident id -> Ident.name id
+    | Path.Pdot(_, s) -> s
+    | Path.Papply _ -> assert false
+  in name.[0] = '#'
+
+(**** Control tracing of GADT instances *)
+
+let trace_gadt_instances = ref false
+let check_trace_gadt_instances env =
+  not !trace_gadt_instances && Env.has_local_constraints env &&
+  (trace_gadt_instances := true; cleanup_abbrev (); true)
+
+let reset_trace_gadt_instances b =
+  if b then trace_gadt_instances := false
+
+let wrap_trace_gadt_instances env f x =
+  let b = check_trace_gadt_instances env in
+  let y = f x in
+  reset_trace_gadt_instances b;
+  y
+
+(**** Abbreviations without parameters ****)
+(* Shall reset after generalizing *)
+
+let simple_abbrevs = ref Mnil
+
+let proper_abbrevs path tl abbrev =
+  if tl <> [] || !trace_gadt_instances || !Clflags.principal ||
+     is_object_type path
+  then abbrev
+  else simple_abbrevs
+
+(**** Some type creators ****)
+
+(* Re-export generic type creators *)
+
+let newty2             = Btype.newty2
+let newty desc         = newty2 !current_level desc
+
+let newvar ?name ()         = newty2 !current_level (Tvar name)
+let newvar2 ?name level     = newty2 level (Tvar name)
+let new_global_var ?name () = newty2 !global_level (Tvar name)
+
+let newobj fields      = newty (Tobject (fields, ref None))
+
+let newconstr path tyl = newty (Tconstr (path, tyl, ref Mnil))
+
+let none = newty (Ttuple [])                (* Clearly ill-formed type *)
+
+(**** Representative of a type ****)
+
+(* Re-export repr *)
+let repr = repr
+
+(**** Type maps ****)
+
+module TypePairs =
+  Hashtbl.Make (struct
+    type t = type_expr * type_expr
+    let equal (t1, t1') (t2, t2') = (t1 == t2) && (t1' == t2')
+    let hash (t, t') = t.id + 93 * t'.id
+ end)
+
+
+(**** unification mode ****)
+
+type unification_mode =
+  | Expression (* unification in expression *)
+  | Pattern (* unification in pattern which may add local constraints *)
+
+type equations_generation =
+  | Forbidden
+  | Allowed of { equated_types : unit TypePairs.t }
+
+let umode = ref Expression
+let equations_generation = ref Forbidden
+let assume_injective = ref false
+let allow_recursive_equation = ref false
+
+let can_generate_equations () =
+  match !equations_generation with
+  | Forbidden -> false
+  | _ -> true
+
+let set_mode_pattern ~generate ~injective ~allow_recursive f =
+  Misc.protect_refs
+    [ Misc.R (umode, Pattern);
+      Misc.R (equations_generation, generate);
+      Misc.R (assume_injective, injective);
+      Misc.R (allow_recursive_equation, allow_recursive);
+    ] f
+
+(*** Checks for type definitions ***)
+
+let in_current_module = function
+  | Path.Pident _ -> true
+  | Path.Pdot _ | Path.Papply _ -> false
+
+let in_pervasives p =
+  in_current_module p &&
+  try ignore (Env.find_type p Env.initial_safe_string); true
+  with Not_found -> false
+
+let is_datatype decl=
+  match decl.type_kind with
+    Type_record _ | Type_variant _ | Type_open -> true
+  | Type_abstract -> false
+
+
+                  (**********************************************)
+                  (*  Miscellaneous operations on object types  *)
+                  (**********************************************)
+
+(* Note:
+   We need to maintain some invariants:
+   * cty_self must be a Tobject
+   * ...
+*)
+
+(**** Object field manipulation. ****)
+
+let object_fields ty =
+  match (repr ty).desc with
+    Tobject (fields, _) -> fields
+  | _                   -> assert false
+
+let flatten_fields ty =
+  let rec flatten l ty =
+    let ty = repr ty in
+    match ty.desc with
+      Tfield(s, k, ty1, ty2) ->
+        flatten ((s, k, ty1)::l) ty2
+    | _ ->
+        (l, ty)
+  in
+    let (l, r) = flatten [] ty in
+    (List.sort (fun (n, _, _) (n', _, _) -> compare n n') l, r)
+
+let build_fields level =
+  List.fold_right
+    (fun (s, k, ty1) ty2 -> newty2 level (Tfield(s, k, ty1, ty2)))
+
+let associate_fields fields1 fields2 =
+  let rec associate p s s' =
+    function
+      (l, []) ->
+        (List.rev p, (List.rev s) @ l, List.rev s')
+    | ([], l') ->
+        (List.rev p, List.rev s, (List.rev s') @ l')
+    | ((n, k, t)::r, (n', k', t')::r') when n = n' ->
+        associate ((n, k, t, k', t')::p) s s' (r, r')
+    | ((n, k, t)::r, ((n', _k', _t')::_ as l')) when n < n' ->
+        associate p ((n, k, t)::s) s' (r, l')
+    | (((_n, _k, _t)::_ as l), (n', k', t')::r') (* when n > n' *) ->
+        associate p s ((n', k', t')::s') (l, r')
+  in
+  associate [] [] [] (fields1, fields2)
+
+let rec has_dummy_method ty =
+  match repr ty with
+    {desc = Tfield (m, _, _, ty2)} ->
+      m = dummy_method || has_dummy_method ty2
+  | _ -> false
+
+let is_self_type = function
+  | Tobject (ty, _) -> has_dummy_method ty
+  | _ -> false
+
+(**** Check whether an object is open ****)
+
+(* +++ The abbreviation should eventually be expanded *)
+let rec object_row ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tobject (t, _)     -> object_row t
+  | Tfield(_, _, _, t) -> object_row t
+  | _ -> ty
+
+let opened_object ty =
+  match (object_row ty).desc with
+  | Tvar _  | Tunivar _ | Tconstr _ -> true
+  | _                               -> false
+
+let concrete_object ty =
+  match (object_row ty).desc with
+  | Tvar _             -> false
+  | _                  -> true
+
+(**** Close an object ****)
+
+let close_object ty =
+  let rec close ty =
+    let ty = repr ty in
+    match ty.desc with
+      Tvar _ ->
+        link_type ty (newty2 ty.level Tnil); true
+    | Tfield(lab, _, _, _) when lab = dummy_method ->
+        false
+    | Tfield(_, _, _, ty') -> close ty'
+    | _                    -> assert false
+  in
+  match (repr ty).desc with
+    Tobject (ty, _)   -> close ty
+  | _                 -> assert false
+
+(**** Row variable of an object type ****)
+
+let row_variable ty =
+  let rec find ty =
+    let ty = repr ty in
+    match ty.desc with
+      Tfield (_, _, _, ty) -> find ty
+    | Tvar _               -> ty
+    | _                    -> assert false
+  in
+  match (repr ty).desc with
+    Tobject (fi, _) -> find fi
+  | _               -> assert false
+
+(**** Object name manipulation ****)
+(* +++ Bientot obsolete *)
+
+let set_object_name id rv params ty =
+  match (repr ty).desc with
+    Tobject (_fi, nm) ->
+      set_name nm (Some (Path.Pident id, rv::params))
+  | _ ->
+      assert false
+
+let remove_object_name ty =
+  match (repr ty).desc with
+    Tobject (_, nm)   -> set_name nm None
+  | Tconstr (_, _, _) -> ()
+  | _                 -> fatal_error "Ctype.remove_object_name"
+
+(**** Hiding of private methods ****)
+
+let hide_private_methods ty =
+  match (repr ty).desc with
+    Tobject (fi, nm) ->
+      nm := None;
+      let (fl, _) = flatten_fields fi in
+      List.iter
+        (function (_, k, _) ->
+          match field_kind_repr k with
+            Fvar r -> set_kind r Fabsent
+          | _      -> ())
+        fl
+  | _ ->
+      assert false
+
+
+                              (*******************************)
+                              (*  Operations on class types  *)
+                              (*******************************)
+
+
+let rec signature_of_class_type =
+  function
+    Cty_constr (_, _, cty) -> signature_of_class_type cty
+  | Cty_signature sign     -> sign
+  | Cty_arrow (_, _, cty)   -> signature_of_class_type cty
+
+let self_type cty =
+  repr (signature_of_class_type cty).csig_self
+
+let rec class_type_arity =
+  function
+    Cty_constr (_, _, cty) ->  class_type_arity cty
+  | Cty_signature _        ->  0
+  | Cty_arrow (_, _, cty)    ->  1 + class_type_arity cty
+
+
+                  (*******************************************)
+                  (*  Miscellaneous operations on row types  *)
+                  (*******************************************)
+
+let sort_row_fields = List.sort (fun (p,_) (q,_) -> compare p q)
+
+let rec merge_rf r1 r2 pairs fi1 fi2 =
+  match fi1, fi2 with
+    (l1,f1 as p1)::fi1', (l2,f2 as p2)::fi2' ->
+      if l1 = l2 then merge_rf r1 r2 ((l1,f1,f2)::pairs) fi1' fi2' else
+      if l1 < l2 then merge_rf (p1::r1) r2 pairs fi1' fi2 else
+      merge_rf r1 (p2::r2) pairs fi1 fi2'
+  | [], _ -> (List.rev r1, List.rev_append r2 fi2, pairs)
+  | _, [] -> (List.rev_append r1 fi1, List.rev r2, pairs)
+
+let merge_row_fields fi1 fi2 =
+  match fi1, fi2 with
+    [], _ | _, [] -> (fi1, fi2, [])
+  | [p1], _ when not (List.mem_assoc (fst p1) fi2) -> (fi1, fi2, [])
+  | _, [p2] when not (List.mem_assoc (fst p2) fi1) -> (fi1, fi2, [])
+  | _ -> merge_rf [] [] [] (sort_row_fields fi1) (sort_row_fields fi2)
+
+let rec filter_row_fields erase = function
+    [] -> []
+  | (_l,f as p)::fi ->
+      let fi = filter_row_fields erase fi in
+      match row_field_repr f with
+        Rabsent -> fi
+      | Reither(_,_,false,e) when erase -> set_row_field e Rabsent; fi
+      | _ -> p :: fi
+
+                    (**************************************)
+                    (*  Check genericity of type schemes  *)
+                    (**************************************)
+
+
+exception Non_closed of type_expr * bool
+
+let free_variables = ref []
+let really_closed = ref None
+
+(* [free_vars_rec] collects the variables of the input type
+   expression into the [free_variables] reference. It is used for
+   several different things in the type-checker, with the following
+   bells and whistles:
+   - If [really_closed] is Some typing environment, types in the environment
+     are expanded to check whether the apparently-free variable would vanish
+     during expansion.
+   - We collect both type variables and row variables, paired with a boolean
+     that is [true] if we have a row variable.
+   - We do not count "virtual" free variables -- free variables stored in
+     the abbreviation of an object type that has been expanded (we store
+     the abbreviations for use when displaying the type).
+
+   The functions [free_vars] and [free_variables] below receive
+   a typing environment as an optional [?env] parameter and
+   set [really_closed] accordingly.
+   [free_vars] returns a [(variable * bool) list], while
+   [free_variables] drops the type/row information
+   and only returns a [variable list].
+ *)
+let rec free_vars_rec real ty =
+  let ty = repr ty in
+  if ty.level >= lowest_level then begin
+    ty.level <- pivot_level - ty.level;
+    begin match ty.desc, !really_closed with
+      Tvar _, _ ->
+        free_variables := (ty, real) :: !free_variables
+    | Tconstr (path, tl, _), Some env ->
+        begin try
+          let (_, body, _) = Env.find_type_expansion path env in
+          if (repr body).level <> generic_level then
+            free_variables := (ty, real) :: !free_variables
+        with Not_found -> ()
+        end;
+        List.iter (free_vars_rec true) tl
+(* Do not count "virtual" free variables
+    | Tobject(ty, {contents = Some (_, p)}) ->
+        free_vars_rec false ty; List.iter (free_vars_rec true) p
+*)
+    | Tobject (ty, _), _ ->
+        free_vars_rec false ty
+    | Tfield (_, _, ty1, ty2), _ ->
+        free_vars_rec true ty1; free_vars_rec false ty2
+    | Tvariant row, _ ->
+        let row = row_repr row in
+        iter_row (free_vars_rec true) row;
+        if not (static_row row) then free_vars_rec false row.row_more
+    | _    ->
+        iter_type_expr (free_vars_rec true) ty
+    end;
+  end
+
+let free_vars ?env ty =
+  free_variables := [];
+  really_closed := env;
+  free_vars_rec true ty;
+  let res = !free_variables in
+  free_variables := [];
+  really_closed := None;
+  res
+
+let free_variables ?env ty =
+  let tl = List.map fst (free_vars ?env ty) in
+  unmark_type ty;
+  tl
+
+let closed_type ty =
+  match free_vars ty with
+      []           -> ()
+  | (v, real) :: _ -> raise (Non_closed (v, real))
+
+let closed_parameterized_type params ty =
+  List.iter mark_type params;
+  let ok =
+    try closed_type ty; true with Non_closed _ -> false in
+  List.iter unmark_type params;
+  unmark_type ty;
+  ok
+
+let closed_type_decl decl =
+  try
+    List.iter mark_type decl.type_params;
+    begin match decl.type_kind with
+      Type_abstract ->
+        ()
+    | Type_variant v ->
+        List.iter
+          (fun {cd_args; cd_res; _} ->
+            match cd_res with
+            | Some _ -> ()
+            | None ->
+                match cd_args with
+                | Cstr_tuple l ->  List.iter closed_type l
+                | Cstr_record l -> List.iter (fun l -> closed_type l.ld_type) l
+          )
+          v
+    | Type_record(r, _rep) ->
+        List.iter (fun l -> closed_type l.ld_type) r
+    | Type_open -> ()
+    end;
+    begin match decl.type_manifest with
+      None    -> ()
+    | Some ty -> closed_type ty
+    end;
+    unmark_type_decl decl;
+    None
+  with Non_closed (ty, _) ->
+    unmark_type_decl decl;
+    Some ty
+
+let closed_extension_constructor ext =
+  try
+    List.iter mark_type ext.ext_type_params;
+    begin match ext.ext_ret_type with
+    | Some _ -> ()
+    | None -> iter_type_expr_cstr_args closed_type ext.ext_args
+    end;
+    unmark_extension_constructor ext;
+    None
+  with Non_closed (ty, _) ->
+    unmark_extension_constructor ext;
+    Some ty
+
+type closed_class_failure =
+    CC_Method of type_expr * bool * string * type_expr
+  | CC_Value of type_expr * bool * string * type_expr
+
+exception CCFailure of closed_class_failure
+
+let closed_class params sign =
+  let ty = object_fields (repr sign.csig_self) in
+  let (fields, rest) = flatten_fields ty in
+  List.iter mark_type params;
+  mark_type rest;
+  List.iter
+    (fun (lab, _, ty) -> if lab = dummy_method then mark_type ty)
+    fields;
+  try
+    mark_type_node (repr sign.csig_self);
+    List.iter
+      (fun (lab, kind, ty) ->
+        if field_kind_repr kind = Fpresent then
+        try closed_type ty with Non_closed (ty0, real) ->
+          raise (CCFailure (CC_Method (ty0, real, lab, ty))))
+      fields;
+    mark_type_params (repr sign.csig_self);
+    List.iter unmark_type params;
+    unmark_class_signature sign;
+    None
+  with CCFailure reason ->
+    mark_type_params (repr sign.csig_self);
+    List.iter unmark_type params;
+    unmark_class_signature sign;
+    Some reason
+
+
+                            (**********************)
+                            (*  Type duplication  *)
+                            (**********************)
+
+
+(* Duplicate a type, preserving only type variables *)
+let duplicate_type ty =
+  Subst.type_expr Subst.identity ty
+
+(* Same, for class types *)
+let duplicate_class_type ty =
+  Subst.class_type Subst.identity ty
+
+
+                         (*****************************)
+                         (*  Type level manipulation  *)
+                         (*****************************)
+
+(*
+   It would be a bit more efficient to remove abbreviation expansions
+   rather than generalizing them: these expansions will usually not be
+   used anymore. However, this is not possible in the general case, as
+   [expand_abbrev] (via [subst]) requires these expansions to be
+   preserved. Does it worth duplicating this code ?
+*)
+let rec generalize ty =
+  let ty = repr ty in
+  if (ty.level > !current_level) && (ty.level <> generic_level) then begin
+    set_level ty generic_level;
+    begin match ty.desc with
+      Tconstr (_, _, abbrev) ->
+        iter_abbrev generalize !abbrev
+    | _ -> ()
+    end;
+    iter_type_expr generalize ty
+  end
+
+let generalize ty =
+  simple_abbrevs := Mnil;
+  generalize ty
+
+(* Generalize the structure and lower the variables *)
+
+let rec generalize_structure var_level ty =
+  let ty = repr ty in
+  if ty.level <> generic_level then begin
+    if is_Tvar ty && ty.level > var_level then
+      set_level ty var_level
+    else if
+      ty.level > !current_level &&
+      match ty.desc with
+        Tconstr (p, _, abbrev) ->
+          not (is_object_type p) && (abbrev := Mnil; true)
+      | _ -> true
+    then begin
+      set_level ty generic_level;
+      iter_type_expr (generalize_structure var_level) ty
+    end
+  end
+
+let generalize_structure ty =
+  simple_abbrevs := Mnil;
+  generalize_structure !current_level ty
+
+(* Generalize the spine of a function, if the level >= !current_level *)
+
+let rec generalize_spine ty =
+  let ty = repr ty in
+  if ty.level < !current_level || ty.level = generic_level then () else
+  match ty.desc with
+    Tarrow (_, ty1, ty2, _) ->
+      set_level ty generic_level;
+      generalize_spine ty1;
+      generalize_spine ty2;
+  | Tpoly (ty', _) ->
+      set_level ty generic_level;
+      generalize_spine ty'
+  | Ttuple tyl
+  | Tpackage (_, _, tyl) ->
+      set_level ty generic_level;
+      List.iter generalize_spine tyl
+  | Tconstr (p, tyl, memo) when not (is_object_type p) ->
+      set_level ty generic_level;
+      memo := Mnil;
+      List.iter generalize_spine tyl
+  | _ -> ()
+
+let forward_try_expand_once = (* Forward declaration *)
+  ref (fun _env _ty -> raise Cannot_expand)
+
+(*
+   Lower the levels of a type (assume [level] is not
+   [generic_level]).
+*)
+
+let rec normalize_package_path env p =
+  let t =
+    try (Env.find_modtype p env).mtd_type
+    with Not_found -> None
+  in
+  match t with
+  | Some (Mty_ident p) -> normalize_package_path env p
+  | Some (Mty_signature _ | Mty_functor _ | Mty_alias _) | None ->
+      match p with
+        Path.Pdot (p1, s) ->
+          (* For module aliases *)
+          let p1' = Env.normalize_module_path None env p1 in
+          if Path.same p1 p1' then p else
+          normalize_package_path env (Path.Pdot (p1', s))
+      | _ -> p
+
+let rec check_scope_escape env level ty =
+  let mark ty =
+    (* Mark visited types with [ty.level < lowest_level]. *)
+    set_level ty (pivot_level - ty.level)
+  in
+  let ty = repr ty in
+  (* If the type hasn't been marked, check it. Otherwise, we have already
+     checked it.
+  *)
+  if ty.level >= lowest_level then begin
+    if level < ty.scope then
+      raise(Trace.scope_escape ty);
+    begin match ty.desc with
+    | Tconstr (p, _, _) when level < Path.scope p ->
+        begin match !forward_try_expand_once env ty with
+        | ty' ->
+            mark ty;
+            check_scope_escape env level ty'
+        | exception Cannot_expand ->
+            raise Trace.(Unify [escape (Constructor p)])
+        end
+    | Tpackage (p, nl, tl) when level < Path.scope p ->
+        let p' = normalize_package_path env p in
+        if Path.same p p' then raise Trace.(Unify [escape (Module_type p)]);
+        let orig_level = ty.level in
+        mark ty;
+        check_scope_escape env level
+          (Btype.newty2 orig_level (Tpackage (p', nl, tl)))
+    | _ ->
+      mark ty;
+      iter_type_expr (check_scope_escape env level) ty
+    end;
+  end
+
+let check_scope_escape env level ty =
+  let snap = snapshot () in
+  try check_scope_escape env level ty; backtrack snap
+  with Unify [Trace.Escape x] ->
+    backtrack snap;
+    raise Trace.(Unify[Escape { x with context = Some ty }])
+
+let update_scope scope ty =
+  let ty = repr ty in
+  let scope = max scope ty.scope in
+  if ty.level < scope then raise (Trace.scope_escape ty);
+  set_scope ty scope
+
+(* Note: the level of a type constructor must be greater than its binding
+    time. That way, a type constructor cannot escape the scope of its
+    definition, as would be the case in
+      let x = ref []
+      module M = struct type t let _ = (x : t list ref) end
+    (without this constraint, the type system would actually be unsound.)
+*)
+
+let rec update_level env level expand ty =
+  let ty = repr ty in
+  if ty.level > level then begin
+    if level < ty.scope then raise (Trace.scope_escape ty);
+    match ty.desc with
+      Tconstr(p, _tl, _abbrev) when level < Path.scope p ->
+        (* Try first to replace an abbreviation by its expansion. *)
+        begin try
+          link_type ty (!forward_try_expand_once env ty);
+          update_level env level expand ty
+        with Cannot_expand ->
+          raise Trace.(Unify [escape(Constructor p)])
+        end
+    | Tconstr(p, (_ :: _ as tl), _) ->
+        let variance =
+          try (Env.find_type p env).type_variance
+          with Not_found -> List.map (fun _ -> Variance.unknown) tl in
+        let needs_expand =
+          expand ||
+          List.exists2
+            (fun var ty -> var = Variance.null && (repr ty).level > level)
+            variance tl
+        in
+        begin try
+          if not needs_expand then raise Cannot_expand;
+          link_type ty (!forward_try_expand_once env ty);
+          update_level env level expand ty
+        with Cannot_expand ->
+          set_level ty level;
+          iter_type_expr (update_level env level expand) ty
+        end
+    | Tpackage (p, nl, tl) when level < Path.scope p ->
+        let p' = normalize_package_path env p in
+        if Path.same p p' then raise Trace.(Unify [escape (Module_type p)]);
+        set_type_desc ty (Tpackage (p', nl, tl));
+        update_level env level expand ty
+    | Tobject(_, ({contents=Some(p, _tl)} as nm))
+      when level < Path.scope p ->
+        set_name nm None;
+        update_level env level expand ty
+    | Tvariant row ->
+        let row = row_repr row in
+        begin match row.row_name with
+        | Some (p, _tl) when level < Path.scope p ->
+            set_type_desc ty (Tvariant {row with row_name = None})
+        | _ -> ()
+        end;
+        set_level ty level;
+        iter_type_expr (update_level env level expand) ty
+    | Tfield(lab, _, ty1, _)
+      when lab = dummy_method && (repr ty1).level > level ->
+        raise Trace.(Unify [escape Self])
+    | _ ->
+        set_level ty level;
+        (* XXX what about abbreviations in Tconstr ? *)
+        iter_type_expr (update_level env level expand) ty
+  end
+
+(* First try without expanding, then expand everything,
+   to avoid combinatorial blow-up *)
+let update_level env level ty =
+  let ty = repr ty in
+  if ty.level > level then begin
+    let snap = snapshot () in
+    try
+      update_level env level false ty
+    with Unify _ ->
+      backtrack snap;
+      update_level env level true ty
+  end
+
+(* Lower level of type variables inside contravariant branches *)
+
+let rec lower_contravariant env var_level visited contra ty =
+  let ty = repr ty in
+  let must_visit =
+    ty.level > var_level &&
+    match Hashtbl.find visited ty.id with
+    | done_contra -> contra && not done_contra
+    | exception Not_found -> true
+  in
+  if must_visit then begin
+    Hashtbl.add visited ty.id contra;
+    let lower_rec = lower_contravariant env var_level visited in
+    match ty.desc with
+      Tvar _ -> if contra then set_level ty var_level
+    | Tconstr (_, [], _) -> ()
+    | Tconstr (path, tyl, _abbrev) ->
+       let variance, maybe_expand =
+         try
+           let typ = Env.find_type path env in
+           typ.type_variance,
+           typ.type_kind = Type_abstract
+          with Not_found ->
+            (* See testsuite/tests/typing-missing-cmi-2 for an example *)
+            List.map (fun _ -> Variance.unknown) tyl,
+            false
+        in
+        if List.for_all ((=) Variance.null) variance then () else
+          let not_expanded () =
+            List.iter2
+              (fun v t ->
+                if v = Variance.null then () else
+                  if Variance.(mem May_weak v)
+                  then lower_rec true t
+                  else lower_rec contra t)
+              variance tyl in
+          if maybe_expand then (* we expand cautiously to avoid missing cmis *)
+            match !forward_try_expand_once env ty with
+            | ty -> lower_rec contra ty
+            | exception Cannot_expand -> not_expanded ()
+          else not_expanded ()
+    | Tpackage (_, _, tyl) ->
+        List.iter (lower_rec true) tyl
+    | Tarrow (_, t1, t2, _) ->
+        lower_rec true t1;
+        lower_rec contra t2
+    | _ ->
+        iter_type_expr (lower_rec contra) ty
+  end
+
+let lower_contravariant env ty =
+  simple_abbrevs := Mnil;
+  lower_contravariant env !nongen_level (Hashtbl.create 7) false ty
+
+(* Correct the levels of type [ty]. *)
+let correct_levels ty =
+  duplicate_type ty
+
+(* Only generalize the type ty0 in ty *)
+let limited_generalize ty0 ty =
+  let ty0 = repr ty0 in
+
+  let graph = Hashtbl.create 17 in
+  let idx = ref lowest_level in
+  let roots = ref [] in
+
+  let rec inverse pty ty =
+    let ty = repr ty in
+    if (ty.level > !current_level) || (ty.level = generic_level) then begin
+      decr idx;
+      Hashtbl.add graph !idx (ty, ref pty);
+      if (ty.level = generic_level) || (ty == ty0) then
+        roots := ty :: !roots;
+      set_level ty !idx;
+      iter_type_expr (inverse [ty]) ty
+    end else if ty.level < lowest_level then begin
+      let (_, parents) = Hashtbl.find graph ty.level in
+      parents := pty @ !parents
+    end
+
+  and generalize_parents ty =
+    let idx = ty.level in
+    if idx <> generic_level then begin
+      set_level ty generic_level;
+      List.iter generalize_parents !(snd (Hashtbl.find graph idx));
+      (* Special case for rows: must generalize the row variable *)
+      match ty.desc with
+        Tvariant row ->
+          let more = row_more row in
+          let lv = more.level in
+          if (lv < lowest_level || lv > !current_level)
+          && lv <> generic_level then set_level more generic_level
+      | _ -> ()
+    end
+  in
+
+  inverse [] ty;
+  if ty0.level < lowest_level then
+    iter_type_expr (inverse []) ty0;
+  List.iter generalize_parents !roots;
+  Hashtbl.iter
+    (fun _ (ty, _) ->
+       if ty.level <> generic_level then set_level ty !current_level)
+    graph
+
+
+(* Compute statically the free univars of all nodes in a type *)
+(* This avoids doing it repeatedly during instantiation *)
+
+type inv_type_expr =
+    { inv_type : type_expr;
+      mutable inv_parents : inv_type_expr list }
+
+let rec inv_type hash pty ty =
+  let ty = repr ty in
+  try
+    let inv = TypeHash.find hash ty in
+    inv.inv_parents <- pty @ inv.inv_parents
+  with Not_found ->
+    let inv = { inv_type = ty; inv_parents = pty } in
+    TypeHash.add hash ty inv;
+    iter_type_expr (inv_type hash [inv]) ty
+
+let compute_univars ty =
+  let inverted = TypeHash.create 17 in
+  inv_type inverted [] ty;
+  let node_univars = TypeHash.create 17 in
+  let rec add_univar univ inv =
+    match inv.inv_type.desc with
+      Tpoly (_ty, tl) when List.memq univ (List.map repr tl) -> ()
+    | _ ->
+        try
+          let univs = TypeHash.find node_univars inv.inv_type in
+          if not (TypeSet.mem univ !univs) then begin
+            univs := TypeSet.add univ !univs;
+            List.iter (add_univar univ) inv.inv_parents
+          end
+        with Not_found ->
+          TypeHash.add node_univars inv.inv_type (ref(TypeSet.singleton univ));
+          List.iter (add_univar univ) inv.inv_parents
+  in
+  TypeHash.iter (fun ty inv -> if is_Tunivar ty then add_univar ty inv)
+    inverted;
+  fun ty ->
+    try !(TypeHash.find node_univars ty) with Not_found -> TypeSet.empty
+
+
+let fully_generic ty =
+  let rec aux acc ty =
+    acc &&
+    let ty = repr ty in
+    ty.level < lowest_level || (
+      ty.level = generic_level && (
+        mark_type_node ty;
+        fold_type_expr aux true ty
+      )
+    )
+  in
+  let res = aux true ty in
+  unmark_type ty;
+  res
+
+
+                              (*******************)
+                              (*  Instantiation  *)
+                              (*******************)
+
+
+let rec find_repr p1 =
+  function
+    Mnil ->
+      None
+  | Mcons (Public, p2, ty, _, _) when Path.same p1 p2 ->
+      Some ty
+  | Mcons (_, _, _, _, rem) ->
+      find_repr p1 rem
+  | Mlink {contents = rem} ->
+      find_repr p1 rem
+
+(*
+   Generic nodes are duplicated, while non-generic nodes are left
+   as-is.
+   During instantiation, the description of a generic node is first
+   replaced by a link to a stub ([Tsubst (newvar ())]). Once the
+   copy is made, it replaces the stub.
+   After instantiation, the description of generic node, which was
+   stored by [save_desc], must be put back, using [cleanup_types].
+*)
+
+let abbreviations = ref (ref Mnil)
+  (* Abbreviation memorized. *)
+
+(* partial: we may not wish to copy the non generic types
+   before we call type_pat *)
+let rec copy ?partial ?keep_names scope ty =
+  let copy = copy ?partial ?keep_names scope in
+  let ty = repr ty in
+  match ty.desc with
+    Tsubst ty -> ty
+  | _ ->
+    if ty.level <> generic_level && partial = None then ty else
+    (* We only forget types that are non generic and do not contain
+       free univars *)
+    let forget =
+      if ty.level = generic_level then generic_level else
+      match partial with
+        None -> assert false
+      | Some (free_univars, keep) ->
+          if TypeSet.is_empty (free_univars ty) then
+            if keep then ty.level else !current_level
+          else generic_level
+    in
+    if forget <> generic_level then newty2 forget (Tvar None) else
+    let desc = ty.desc in
+    For_copy.save_desc scope ty desc;
+    let t = newvar() in          (* Stub *)
+    set_scope t ty.scope;
+    ty.desc <- Tsubst t;
+    t.desc <-
+      begin match desc with
+      | Tconstr (p, tl, _) ->
+          let abbrevs = proper_abbrevs p tl !abbreviations in
+          begin match find_repr p !abbrevs with
+            Some ty when repr ty != t ->
+              Tlink ty
+          | _ ->
+          (*
+             One must allocate a new reference, so that abbrevia-
+             tions belonging to different branches of a type are
+             independent.
+             Moreover, a reference containing a [Mcons] must be
+             shared, so that the memorized expansion of an abbrevi-
+             ation can be released by changing the content of just
+             one reference.
+          *)
+              Tconstr (p, List.map copy tl,
+                       ref (match !(!abbreviations) with
+                              Mcons _ -> Mlink !abbreviations
+                            | abbrev  -> abbrev))
+          end
+      | Tvariant row0 ->
+          let row = row_repr row0 in
+          let more = repr row.row_more in
+          (* We must substitute in a subtle way *)
+          (* Tsubst takes a tuple containing the row var and the variant *)
+          begin match more.desc with
+            Tsubst {desc = Ttuple [_;ty2]} ->
+              (* This variant type has been already copied *)
+              ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *)
+              Tlink ty2
+          | _ ->
+              (* If the row variable is not generic, we must keep it *)
+              let keep = more.level <> generic_level && partial = None in
+              let more' =
+                match more.desc with
+                  Tsubst ty -> ty
+                | Tconstr _ | Tnil ->
+                    For_copy.save_desc scope more more.desc;
+                    copy more
+                | Tvar _ | Tunivar _ ->
+                    For_copy.save_desc scope more more.desc;
+                    if keep then more else newty more.desc
+                |  _ -> assert false
+              in
+              let row =
+                match repr more' with (* PR#6163 *)
+                  {desc=Tconstr (x,_,_)} when not (is_fixed row) ->
+                    {row with row_fixed = Some (Reified x)}
+                | _ -> row
+              in
+              (* Open row if partial for pattern and contains Reither *)
+              let more', row =
+                match partial with
+                  Some (free_univars, false) ->
+                    let more' =
+                      if more.id != more'.id then more' else
+                      let lv = if keep then more.level else !current_level in
+                      newty2 lv (Tvar None)
+                    in
+                    let not_reither (_, f) =
+                      match row_field_repr f with
+                        Reither _ -> false
+                      | _ -> true
+                    in
+                    if row.row_closed && not (is_fixed row)
+                    && TypeSet.is_empty (free_univars ty)
+                    && not (List.for_all not_reither row.row_fields) then
+                      (more',
+                       {row_fields = List.filter not_reither row.row_fields;
+                        row_more = more'; row_bound = ();
+                        row_closed = false; row_fixed = None; row_name = None})
+                    else (more', row)
+                | _ -> (more', row)
+              in
+              (* Register new type first for recursion *)
+              more.desc <- Tsubst(newgenty(Ttuple[more';t]));
+              (* Return a new copy *)
+              Tvariant (copy_row copy true row keep more')
+          end
+      | Tfield (_p, k, _ty1, ty2) ->
+          begin match field_kind_repr k with
+            Fabsent  -> Tlink (copy ty2)
+          | Fpresent -> copy_type_desc copy desc
+          | Fvar r ->
+              For_copy.dup_kind scope r;
+              copy_type_desc copy desc
+          end
+      | Tobject (ty1, _) when partial <> None ->
+          Tobject (copy ty1, ref None)
+      | _ -> copy_type_desc ?keep_names copy desc
+      end;
+    t
+
+(**** Variants of instantiations ****)
+
+let instance ?partial sch =
+  let partial =
+    match partial with
+      None -> None
+    | Some keep -> Some (compute_univars sch, keep)
+  in
+  For_copy.with_scope (fun scope -> copy ?partial scope sch)
+
+let generic_instance sch =
+  let old = !current_level in
+  current_level := generic_level;
+  let ty = instance sch in
+  current_level := old;
+  ty
+
+let instance_list schl =
+  For_copy.with_scope (fun scope -> List.map (fun t -> copy scope t) schl)
+
+let reified_var_counter = ref Vars.empty
+let reset_reified_var_counter () =
+  reified_var_counter := Vars.empty
+
+(* names given to new type constructors.
+   Used for existential types and
+   local constraints *)
+let get_new_abstract_name s =
+  let index =
+    try Vars.find s !reified_var_counter + 1
+    with Not_found -> 0 in
+  reified_var_counter := Vars.add s index !reified_var_counter;
+  if index = 0 && s <> "" && s.[String.length s - 1] <> '$' then s else
+  Printf.sprintf "%s%d" s index
+
+let new_declaration expansion_scope manifest =
+  {
+    type_params = [];
+    type_arity = 0;
+    type_kind = Type_abstract;
+    type_private = Public;
+    type_manifest = manifest;
+    type_variance = [];
+    type_separability = [];
+    type_is_newtype = true;
+    type_expansion_scope = expansion_scope;
+    type_loc = Location.none;
+    type_attributes = [];
+    type_immediate = Unknown;
+    type_unboxed = unboxed_false_default_false;
+    type_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+  }
+
+let existential_name cstr ty = match repr ty with
+  | {desc = Tvar (Some name)} -> "$" ^ cstr.cstr_name ^ "_'" ^ name
+  | _ -> "$" ^ cstr.cstr_name
+
+let instance_constructor ?in_pattern cstr =
+  For_copy.with_scope (fun scope ->
+    begin match in_pattern with
+    | None -> ()
+    | Some (env, expansion_scope) ->
+        let process existential =
+          let decl = new_declaration expansion_scope None in
+          let name = existential_name cstr existential in
+          let path =
+            Path.Pident
+              (Ident.create_scoped ~scope:expansion_scope
+                 (get_new_abstract_name name))
+          in
+          let new_env = Env.add_local_type path decl !env in
+          env := new_env;
+          let to_unify = newty (Tconstr (path,[],ref Mnil)) in
+          let tv = copy scope existential in
+          assert (is_Tvar tv);
+          link_type tv to_unify
+        in
+        List.iter process cstr.cstr_existentials
+    end;
+    let ty_res = copy scope cstr.cstr_res in
+    let ty_args = List.map (copy scope) cstr.cstr_args in
+    (ty_args, ty_res)
+  )
+
+let instance_parameterized_type ?keep_names sch_args sch =
+  For_copy.with_scope (fun scope ->
+    let ty_args = List.map (fun t -> copy ?keep_names scope t) sch_args in
+    let ty = copy scope sch in
+    (ty_args, ty)
+  )
+
+let instance_parameterized_type_2 sch_args sch_lst sch =
+  For_copy.with_scope (fun scope ->
+    let ty_args = List.map (copy scope) sch_args in
+    let ty_lst = List.map (copy scope) sch_lst in
+    let ty = copy scope sch in
+    (ty_args, ty_lst, ty)
+  )
+
+let map_kind f = function
+  | Type_abstract -> Type_abstract
+  | Type_open -> Type_open
+  | Type_variant cl ->
+      Type_variant (
+        List.map
+          (fun c ->
+             {c with
+              cd_args = map_type_expr_cstr_args f c.cd_args;
+              cd_res = Option.map f c.cd_res
+             })
+          cl)
+  | Type_record (fl, rr) ->
+      Type_record (
+        List.map
+          (fun l ->
+             {l with ld_type = f l.ld_type}
+          ) fl, rr)
+
+
+let instance_declaration decl =
+  For_copy.with_scope (fun scope ->
+    {decl with type_params = List.map (copy scope) decl.type_params;
+     type_manifest = Option.map (copy scope) decl.type_manifest;
+     type_kind = map_kind (copy scope) decl.type_kind;
+    }
+  )
+
+let generic_instance_declaration decl =
+  let old = !current_level in
+  current_level := generic_level;
+  let decl = instance_declaration decl in
+  current_level := old;
+  decl
+
+let instance_class params cty =
+  let rec copy_class_type scope = function
+    | Cty_constr (path, tyl, cty) ->
+        let tyl' = List.map (copy scope) tyl in
+        let cty' = copy_class_type scope cty in
+        Cty_constr (path, tyl', cty')
+    | Cty_signature sign ->
+        Cty_signature
+          {csig_self = copy scope sign.csig_self;
+           csig_vars =
+             Vars.map (function (m, v, ty) -> (m, v, copy scope ty))
+               sign.csig_vars;
+           csig_concr = sign.csig_concr;
+           csig_inher =
+             List.map (fun (p,tl) -> (p, List.map (copy scope) tl))
+               sign.csig_inher}
+    | Cty_arrow (l, ty, cty) ->
+        Cty_arrow (l, copy scope ty, copy_class_type scope cty)
+  in
+  For_copy.with_scope (fun scope ->
+    let params' = List.map (copy scope) params in
+    let cty' = copy_class_type scope cty in
+    (params', cty')
+  )
+
+(**** Instantiation for types with free universal variables ****)
+
+let rec diff_list l1 l2 =
+  if l1 == l2 then [] else
+  match l1 with [] -> invalid_arg "Ctype.diff_list"
+  | a :: l1 -> a :: diff_list l1 l2
+
+let conflicts free bound =
+  let bound = List.map repr bound in
+  TypeSet.exists (fun t -> List.memq (repr t) bound) free
+
+let delayed_copy = ref []
+    (* copying to do later *)
+
+(* Copy without sharing until there are no free univars left *)
+(* all free univars must be included in [visited]            *)
+let rec copy_sep cleanup_scope fixed free bound visited ty =
+  let ty = repr ty in
+  let univars = free ty in
+  if TypeSet.is_empty univars then
+    if ty.level <> generic_level then ty else
+    let t = newvar () in
+    delayed_copy :=
+      lazy (t.desc <- Tlink (copy cleanup_scope ty))
+      :: !delayed_copy;
+    t
+  else try
+    let t, bound_t = List.assq ty visited in
+    let dl = if is_Tunivar ty then [] else diff_list bound bound_t in
+    if dl <> [] && conflicts univars dl then raise Not_found;
+    t
+  with Not_found -> begin
+    let t = newvar() in          (* Stub *)
+    let visited =
+      match ty.desc with
+        Tarrow _ | Ttuple _ | Tvariant _ | Tconstr _ | Tobject _ | Tpackage _ ->
+          (ty,(t,bound)) :: visited
+      | Tvar _ | Tfield _ | Tnil | Tpoly _ | Tunivar _ | Tlink _ | Tsubst _ ->
+          visited
+    in
+    let copy_rec = copy_sep cleanup_scope fixed free bound visited in
+    t.desc <-
+      begin match ty.desc with
+      | Tvariant row0 ->
+          let row = row_repr row0 in
+          let more = repr row.row_more in
+          (* We shall really check the level on the row variable *)
+          let keep = is_Tvar more && more.level <> generic_level in
+          let more' = copy_rec more in
+          let fixed' = fixed && (is_Tvar more || is_Tunivar more) in
+          let row = copy_row copy_rec fixed' row keep more' in
+          Tvariant row
+      | Tpoly (t1, tl) ->
+          let tl = List.map repr tl in
+          let tl' = List.map (fun t -> newty t.desc) tl in
+          let bound = tl @ bound in
+          let visited =
+            List.map2 (fun ty t -> ty,(t,bound)) tl tl' @ visited in
+          Tpoly (copy_sep cleanup_scope fixed free bound visited t1, tl')
+      | _ -> copy_type_desc copy_rec ty.desc
+      end;
+    t
+  end
+
+let instance_poly' cleanup_scope ~keep_names fixed univars sch =
+  let univars = List.map repr univars in
+  let copy_var ty =
+    match ty.desc with
+      Tunivar name -> if keep_names then newty (Tvar name) else newvar ()
+    | _ -> assert false
+  in
+  let vars = List.map copy_var univars in
+  let pairs = List.map2 (fun u v -> u, (v, [])) univars vars in
+  delayed_copy := [];
+  let ty = copy_sep cleanup_scope fixed (compute_univars sch) [] pairs sch in
+  List.iter Lazy.force !delayed_copy;
+  delayed_copy := [];
+  vars, ty
+
+let instance_poly ?(keep_names=false) fixed univars sch =
+  For_copy.with_scope (fun cleanup_scope ->
+    instance_poly' cleanup_scope ~keep_names fixed univars sch
+  )
+
+let instance_label fixed lbl =
+  For_copy.with_scope (fun scope ->
+    let ty_res = copy scope lbl.lbl_res in
+    let vars, ty_arg =
+      match repr lbl.lbl_arg with
+        {desc = Tpoly (ty, tl)} ->
+          instance_poly' scope ~keep_names:false fixed tl ty
+      | _ ->
+          [], copy scope lbl.lbl_arg
+    in
+    (vars, ty_arg, ty_res)
+  )
+
+(**** Instantiation with parameter substitution ****)
+
+let unify' = (* Forward declaration *)
+  ref (fun _env _ty1 _ty2 -> raise (Unify []))
+
+let subst env level priv abbrev ty params args body =
+  if List.length params <> List.length args then raise (Unify []);
+  let old_level = !current_level in
+  current_level := level;
+  try
+    let body0 = newvar () in          (* Stub *)
+    begin match ty with
+      None      -> ()
+    | Some ({desc = Tconstr (path, tl, _)} as ty) ->
+        let abbrev = proper_abbrevs path tl abbrev in
+        memorize_abbrev abbrev priv path ty body0
+    | _ ->
+        assert false
+    end;
+    abbreviations := abbrev;
+    let (params', body') = instance_parameterized_type params body in
+    abbreviations := ref Mnil;
+    !unify' env body0 body';
+    List.iter2 (!unify' env) params' args;
+    current_level := old_level;
+    body'
+  with Unify _ as exn ->
+    current_level := old_level;
+    raise exn
+
+(*
+   Only the shape of the type matters, not whether it is generic or
+   not. [generic_level] might be somewhat slower, but it ensures
+   invariants on types are enforced (decreasing levels), and we don't
+   care about efficiency here.
+*)
+let apply env params body args =
+  try
+    subst env generic_level Public (ref Mnil) None params args body
+  with
+    Unify _ -> raise Cannot_apply
+
+let () = Subst.ctype_apply_env_empty := apply Env.empty
+
+                              (****************************)
+                              (*  Abbreviation expansion  *)
+                              (****************************)
+
+(*
+   If the environment has changed, memorized expansions might not
+   be correct anymore, and so we flush the cache. This is safe but
+   quite pessimistic: it would be enough to flush the cache when a
+   type or module definition is overridden in the environment.
+*)
+let previous_env = ref Env.empty
+(*let string_of_kind = function Public -> "public" | Private -> "private"*)
+let check_abbrev_env env =
+  if env != !previous_env then begin
+    (* prerr_endline "cleanup expansion cache"; *)
+    cleanup_abbrev ();
+    previous_env := env
+  end
+
+
+(* Expand an abbreviation. The expansion is memorized. *)
+(*
+   Assume the level is greater than the path binding time of the
+   expanded abbreviation.
+*)
+(*
+   An abbreviation expansion will fail in either of these cases:
+   1. The type constructor does not correspond to a manifest type.
+   2. The type constructor is defined in an external file, and this
+      file is not in the path (missing -I options).
+   3. The type constructor is not in the "local" environment. This can
+      happens when a non-generic type variable has been instantiated
+      afterwards to the not yet defined type constructor. (Actually,
+      this cannot happen at the moment due to the strong constraints
+      between type levels and constructor binding time.)
+   4. The expansion requires the expansion of another abbreviation,
+      and this other expansion fails.
+*)
+let expand_abbrev_gen kind find_type_expansion env ty =
+  check_abbrev_env env;
+  match ty with
+    {desc = Tconstr (path, args, abbrev); level = level; scope} ->
+      let lookup_abbrev = proper_abbrevs path args abbrev in
+      begin match find_expans kind path !lookup_abbrev with
+        Some ty' ->
+          (* prerr_endline
+            ("found a "^string_of_kind kind^" expansion for "^Path.name path);*)
+          if level <> generic_level then
+            begin try
+              update_level env level ty'
+            with Unify _ ->
+              (* XXX This should not happen.
+                 However, levels are not correctly restored after a
+                 typing error *)
+              ()
+            end;
+          begin try
+            update_scope scope ty';
+          with Unify _ ->
+            (* XXX This should not happen.
+               However, levels are not correctly restored after a
+               typing error *)
+            ()
+          end;
+          let ty' = repr ty' in
+          (* assert (ty != ty'); *) (* PR#7324 *)
+          ty'
+      | None ->
+          match find_type_expansion path env with
+          | exception Not_found ->
+            (* another way to expand is to normalize the path itself *)
+            let path' = Env.normalize_type_path None env path in
+            if Path.same path path' then raise Cannot_expand
+            else newty2 level (Tconstr (path', args, abbrev))
+          | (params, body, lv) ->
+            (* prerr_endline
+              ("add a "^string_of_kind kind^" expansion for "^Path.name path);*)
+            let ty' = subst env level kind abbrev (Some ty) params args body in
+            (* For gadts, remember type as non exportable *)
+            (* The ambiguous level registered for ty' should be the highest *)
+            if !trace_gadt_instances then begin
+              let scope = max lv ty.scope in
+              if level < scope then raise (Trace.scope_escape ty);
+              set_scope ty scope;
+              set_scope ty' scope
+            end;
+            ty'
+      end
+  | _ ->
+      assert false
+
+(* Expand respecting privacy *)
+let expand_abbrev env ty =
+  expand_abbrev_gen Public Env.find_type_expansion env ty
+
+(* Expand once the head of a type *)
+let expand_head_once env ty =
+  try expand_abbrev env (repr ty) with Cannot_expand -> assert false
+
+(* Check whether a type can be expanded *)
+let safe_abbrev env ty =
+  let snap = Btype.snapshot () in
+  try ignore (expand_abbrev env ty); true
+  with Cannot_expand | Unify _ ->
+    Btype.backtrack snap;
+    false
+
+(* Expand the head of a type once.
+   Raise Cannot_expand if the type cannot be expanded.
+   May raise Unify, if a recursion was hidden in the type. *)
+let try_expand_once env ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tconstr _ -> repr (expand_abbrev env ty)
+  | _ -> raise Cannot_expand
+
+(* This one only raises Cannot_expand *)
+let try_expand_safe env ty =
+  let snap = Btype.snapshot () in
+  try try_expand_once env ty
+  with Unify _ ->
+    Btype.backtrack snap; raise Cannot_expand
+
+(* Fully expand the head of a type. *)
+let rec try_expand_head try_once env ty =
+  let ty' = try_once env ty in
+  try try_expand_head try_once env ty'
+  with Cannot_expand -> ty'
+
+(* Unsafe full expansion, may raise Unify. *)
+let expand_head_unif env ty =
+  try try_expand_head try_expand_once env ty with Cannot_expand -> repr ty
+
+(* Safe version of expand_head, never fails *)
+let expand_head env ty =
+  try try_expand_head try_expand_safe env ty with Cannot_expand -> repr ty
+
+let _ = forward_try_expand_once := try_expand_safe
+
+
+(* Expand until we find a non-abstract type declaration,
+   use try_expand_safe to avoid raising "Unify _" when
+   called on recursive types
+ *)
+
+let rec extract_concrete_typedecl env ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tconstr (p, _, _) ->
+      let decl = Env.find_type p env in
+      if decl.type_kind <> Type_abstract then (p, p, decl) else
+      let ty =
+        try try_expand_safe env ty with Cannot_expand -> raise Not_found
+      in
+      let (_, p', decl) = extract_concrete_typedecl env ty in
+        (p, p', decl)
+  | _ -> raise Not_found
+
+(* Implementing function [expand_head_opt], the compiler's own version of
+   [expand_head] used for type-based optimisations.
+   [expand_head_opt] uses [Env.find_type_expansion_opt] to access the
+   manifest type information of private abstract data types which is
+   normally hidden to the type-checker out of the implementation module of
+   the private abbreviation. *)
+
+let expand_abbrev_opt =
+  expand_abbrev_gen Private Env.find_type_expansion_opt
+
+let try_expand_once_opt env ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tconstr _ -> repr (expand_abbrev_opt env ty)
+  | _ -> raise Cannot_expand
+
+let rec try_expand_head_opt env ty =
+  let ty' = try_expand_once_opt env ty in
+  begin try
+    try_expand_head_opt env ty'
+  with Cannot_expand ->
+    ty'
+  end
+
+let expand_head_opt env ty =
+  let snap = Btype.snapshot () in
+  try try_expand_head_opt env ty
+  with Cannot_expand | Unify _ -> (* expand_head shall never fail *)
+    Btype.backtrack snap;
+    repr ty
+
+(* Make sure that the type parameters of the type constructor [ty]
+   respect the type constraints *)
+let enforce_constraints env ty =
+  match ty with
+    {desc = Tconstr (path, args, _abbrev); level = level} ->
+      begin try
+        let decl = Env.find_type path env in
+        ignore
+          (subst env level Public (ref Mnil) None decl.type_params args
+             (newvar2 level))
+      with Not_found -> ()
+      end
+  | _ ->
+      assert false
+
+(* Recursively expand the head of a type.
+   Also expand #-types. *)
+let full_expand env ty =
+  let ty = repr (expand_head env ty) in
+  match ty.desc with
+    Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar (repr v) ->
+      newty2 ty.level (Tobject (fi, ref None))
+  | _ ->
+      ty
+
+(*
+   Check whether the abbreviation expands to a well-defined type.
+   During the typing of a class, abbreviations for correspondings
+   types expand to non-generic types.
+*)
+let generic_abbrev env path =
+  try
+    let (_, body, _) = Env.find_type_expansion path env in
+    (repr body).level = generic_level
+  with
+    Not_found ->
+      false
+
+let generic_private_abbrev env path =
+  try
+    match Env.find_type path env with
+      {type_kind = Type_abstract;
+       type_private = Private;
+       type_manifest = Some body} ->
+         (repr body).level = generic_level
+    | _ -> false
+  with Not_found -> false
+
+let is_contractive env p =
+  try
+    let decl = Env.find_type p env in
+    in_pervasives p && decl.type_manifest = None || is_datatype decl
+  with Not_found -> false
+
+
+                              (*****************)
+                              (*  Occur check  *)
+                              (*****************)
+
+
+exception Occur
+
+let rec occur_rec env allow_recursive visited ty0 = function
+  | {desc=Tlink ty} ->
+      occur_rec env allow_recursive visited ty0 ty
+  | ty ->
+  if ty == ty0  then raise Occur;
+  match ty.desc with
+    Tconstr(p, _tl, _abbrev) ->
+      if allow_recursive && is_contractive env p then () else
+      begin try
+        if TypeSet.mem ty visited then raise Occur;
+        let visited = TypeSet.add ty visited in
+        iter_type_expr (occur_rec env allow_recursive visited ty0) ty
+      with Occur -> try
+        let ty' = try_expand_head try_expand_once env ty in
+        (* This call used to be inlined, but there seems no reason for it.
+           Message was referring to change in rev. 1.58 of the CVS repo. *)
+        occur_rec env allow_recursive visited ty0 ty'
+      with Cannot_expand ->
+        raise Occur
+      end
+  | Tobject _ | Tvariant _ ->
+      ()
+  | _ ->
+      if allow_recursive ||  TypeSet.mem ty visited then () else begin
+        let visited = TypeSet.add ty visited in
+        iter_type_expr (occur_rec env allow_recursive visited ty0) ty
+      end
+
+let type_changed = ref false (* trace possible changes to the studied type *)
+
+let merge r b = if b then r := true
+
+let occur env ty0 ty =
+  let allow_recursive =
+    !Clflags.recursive_types || !umode = Pattern && !allow_recursive_equation in
+  let old = !type_changed in
+  try
+    while
+      type_changed := false;
+      occur_rec env allow_recursive TypeSet.empty ty0 ty;
+      !type_changed
+    do () (* prerr_endline "changed" *) done;
+    merge type_changed old
+  with exn ->
+    merge type_changed old;
+    match exn with
+    | Occur -> raise (Trace.rec_occur ty0 ty)
+    | _ -> raise exn
+
+let occur_in env ty0 t =
+  try occur env ty0 t; false with Unify _ -> true
+
+(* Check that a local constraint is well-founded *)
+(* PR#6405: not needed since we allow recursion and work on normalized types *)
+(* PR#6992: we actually need it for contractiveness *)
+(* This is a simplified version of occur, only for the rectypes case *)
+
+let rec local_non_recursive_abbrev ~allow_rec strict visited env p ty =
+  (*Format.eprintf "@[Check %s =@ %a@]@." (Path.name p) !Btype.print_raw ty;*)
+  let ty = repr ty in
+  if not (List.memq ty visited) then begin
+    match ty.desc with
+      Tconstr(p', args, _abbrev) ->
+        if Path.same p p' then raise Occur;
+        if allow_rec && not strict && is_contractive env p' then () else
+        let visited = ty :: visited in
+        begin try
+          (* try expanding, since [p] could be hidden *)
+          local_non_recursive_abbrev ~allow_rec strict visited env p
+            (try_expand_head try_expand_once_opt env ty)
+        with Cannot_expand ->
+          let params =
+            try (Env.find_type p' env).type_params
+            with Not_found -> args
+          in
+          List.iter2
+            (fun tv ty ->
+              let strict = strict || not (is_Tvar (repr tv)) in
+              local_non_recursive_abbrev ~allow_rec strict visited env p ty)
+            params args
+        end
+    | Tobject _ | Tvariant _ when not strict ->
+        ()
+    | _ ->
+        if strict || not allow_rec then (* PR#7374 *)
+          let visited = ty :: visited in
+          iter_type_expr
+            (local_non_recursive_abbrev ~allow_rec true visited env p) ty
+  end
+
+let local_non_recursive_abbrev env p ty =
+  let allow_rec =
+    !Clflags.recursive_types || !umode = Pattern && !allow_recursive_equation in
+  try (* PR#7397: need to check trace_gadt_instances *)
+    wrap_trace_gadt_instances env
+      (local_non_recursive_abbrev ~allow_rec false [] env p) ty;
+    true
+  with Occur -> false
+
+
+                   (*****************************)
+                   (*  Polymorphic Unification  *)
+                   (*****************************)
+
+(* Since we cannot duplicate universal variables, unification must
+   be done at meta-level, using bindings in univar_pairs *)
+let rec unify_univar t1 t2 = function
+    (cl1, cl2) :: rem ->
+      let find_univ t cl =
+        try
+          let (_, r) = List.find (fun (t',_) -> t == repr t') cl in
+          Some r
+        with Not_found -> None
+      in
+      begin match find_univ t1 cl1, find_univ t2 cl2 with
+        Some {contents=Some t'2}, Some _ when t2 == repr t'2 ->
+          ()
+      | Some({contents=None} as r1), Some({contents=None} as r2) ->
+          set_univar r1 t2; set_univar r2 t1
+      | None, None ->
+          unify_univar t1 t2 rem
+      | _ ->
+          raise (Unify [])
+      end
+  | [] -> raise (Unify [])
+
+(* Test the occurrence of free univars in a type *)
+(* that's way too expensive. Must do some kind of caching *)
+let occur_univar env ty =
+  let visited = ref TypeMap.empty in
+  let rec occur_rec bound ty =
+    let ty = repr ty in
+    if ty.level >= lowest_level &&
+      if TypeSet.is_empty bound then
+        (ty.level <- pivot_level - ty.level; true)
+      else try
+        let bound' = TypeMap.find ty !visited in
+        if TypeSet.exists (fun x -> not (TypeSet.mem x bound)) bound' then
+          (visited := TypeMap.add ty (TypeSet.inter bound bound') !visited;
+           true)
+        else false
+      with Not_found ->
+        visited := TypeMap.add ty bound !visited;
+        true
+    then
+      match ty.desc with
+        Tunivar _ ->
+          if not (TypeSet.mem ty bound) then
+            raise Trace.(Unify [escape (Univ ty)])
+      | Tpoly (ty, tyl) ->
+          let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in
+          occur_rec bound  ty
+      | Tconstr (_, [], _) -> ()
+      | Tconstr (p, tl, _) ->
+          begin try
+            let td = Env.find_type p env in
+            List.iter2
+              (fun t v ->
+                (* The null variance only occurs in type abbreviations and
+                   corresponds to type variables that do not occur in the
+                   definition (expansion would erase them completely).
+                   The type-checker consistently ignores type expressions
+                   in this position. Physical expansion, as done in `occur`,
+                   would be costly here, since we need to check inside
+                   object and variant types too. *)
+                if not Variance.(eq v null) then occur_rec bound t)
+              tl td.type_variance
+          with Not_found ->
+            List.iter (occur_rec bound) tl
+          end
+      | _ -> iter_type_expr (occur_rec bound) ty
+  in
+  Misc.try_finally (fun () ->
+      occur_rec TypeSet.empty ty
+    )
+    ~always:(fun () -> unmark_type ty)
+
+(* Grouping univars by families according to their binders *)
+let add_univars =
+  List.fold_left (fun s (t,_) -> TypeSet.add (repr t) s)
+
+let get_univar_family univar_pairs univars =
+  if univars = [] then TypeSet.empty else
+  let insert s = function
+      cl1, (_::_ as cl2) ->
+        if List.exists (fun (t1,_) -> TypeSet.mem (repr t1) s) cl1 then
+          add_univars s cl2
+        else s
+    | _ -> s
+  in
+  let s = List.fold_right TypeSet.add univars TypeSet.empty in
+  List.fold_left insert s univar_pairs
+
+(* Whether a family of univars escapes from a type *)
+let univars_escape env univar_pairs vl ty =
+  let family = get_univar_family univar_pairs vl in
+  let visited = ref TypeSet.empty in
+  let rec occur t =
+    let t = repr t in
+    if TypeSet.mem t !visited then () else begin
+      visited := TypeSet.add t !visited;
+      match t.desc with
+        Tpoly (t, tl) ->
+          if List.exists (fun t -> TypeSet.mem (repr t) family) tl then ()
+          else occur t
+      | Tunivar _ ->
+          if TypeSet.mem t family then raise Trace.(Unify [escape(Univ t)])
+      | Tconstr (_, [], _) -> ()
+      | Tconstr (p, tl, _) ->
+          begin try
+            let td = Env.find_type p env in
+            List.iter2
+              (* see occur_univar *)
+              (fun t v -> if not Variance.(eq v null) then occur t)
+              tl td.type_variance
+          with Not_found ->
+            List.iter occur tl
+          end
+      | _ ->
+          iter_type_expr occur t
+    end
+  in
+  occur ty
+
+(* Wrapper checking that no variable escapes and updating univar_pairs *)
+let enter_poly env univar_pairs t1 tl1 t2 tl2 f =
+  let old_univars = !univar_pairs in
+  let known_univars =
+    List.fold_left (fun s (cl,_) -> add_univars s cl)
+      TypeSet.empty old_univars
+  in
+  let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
+  if List.exists (fun t -> TypeSet.mem t known_univars) tl1 then
+     univars_escape env old_univars tl1 (newty(Tpoly(t2,tl2)));
+  if List.exists (fun t -> TypeSet.mem t known_univars) tl2 then
+    univars_escape env old_univars tl2 (newty(Tpoly(t1,tl1)));
+  let cl1 = List.map (fun t -> t, ref None) tl1
+  and cl2 = List.map (fun t -> t, ref None) tl2 in
+  univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars;
+  Misc.try_finally (fun () -> f t1 t2)
+    ~always:(fun () -> univar_pairs := old_univars)
+
+let univar_pairs = ref []
+
+(**** Instantiate a generic type into a poly type ***)
+
+let polyfy env ty vars =
+  let subst_univar scope ty =
+    let ty = repr ty in
+    match ty.desc with
+    | Tvar name when ty.level = generic_level ->
+        For_copy.save_desc scope ty ty.desc;
+        let t = newty (Tunivar name) in
+        ty.desc <- Tsubst t;
+        Some t
+    | _ -> None
+  in
+  (* need to expand twice? cf. Ctype.unify2 *)
+  let vars = List.map (expand_head env) vars in
+  let vars = List.map (expand_head env) vars in
+  For_copy.with_scope (fun scope ->
+    let vars' = List.filter_map (subst_univar scope) vars in
+    let ty = copy scope ty in
+    let ty = newty2 ty.level (Tpoly(repr ty, vars')) in
+    let complete = List.length vars = List.length vars' in
+    ty, complete
+  )
+
+(* assumption: [ty] is fully generalized. *)
+let reify_univars env ty =
+  let vars = free_variables ty in
+  let ty, _ = polyfy env ty vars in
+  ty
+
+                              (*****************)
+                              (*  Unification  *)
+                              (*****************)
+
+
+
+let rec has_cached_expansion p abbrev =
+  match abbrev with
+    Mnil                   -> false
+  | Mcons(_, p', _, _, rem)   -> Path.same p p' || has_cached_expansion p rem
+  | Mlink rem              -> has_cached_expansion p !rem
+
+(**** Transform error trace ****)
+(* +++ Move it to some other place ? *)
+
+let expand_trace env trace =
+  let expand_desc x = match x.Trace.expanded with
+    | None -> Trace.{ t = repr x.t; expanded= Some(full_expand env x.t) }
+    | Some _ -> x in
+  Unification_trace.map expand_desc trace
+
+(**** Unification ****)
+
+(* Return whether [t0] occurs in [ty]. Objects are also traversed. *)
+let deep_occur t0 ty =
+  let rec occur_rec ty =
+    let ty = repr ty in
+    if ty.level >= t0.level then begin
+      if ty == t0 then raise Occur;
+      ty.level <- pivot_level - ty.level;
+      iter_type_expr occur_rec ty
+    end
+  in
+  try
+    occur_rec ty; unmark_type ty; false
+  with Occur ->
+    unmark_type ty; true
+
+(*
+   1. When unifying two non-abbreviated types, one type is made a link
+      to the other. When unifying an abbreviated type with a
+      non-abbreviated type, the non-abbreviated type is made a link to
+      the other one. When unifying to abbreviated types, these two
+      types are kept distincts, but they are made to (temporally)
+      expand to the same type.
+   2. Abbreviations with at least one parameter are systematically
+      expanded. The overhead does not seem too high, and that way
+      abbreviations where some parameters does not appear in the
+      expansion, such as ['a t = int], are correctly handled. In
+      particular, for this example, unifying ['a t] with ['b t] keeps
+      ['a] and ['b] distincts. (Is it really important ?)
+   3. Unifying an abbreviation ['a t = 'a] with ['a] should not yield
+      ['a t as 'a]. Indeed, the type variable would otherwise be lost.
+      This problem occurs for abbreviations expanding to a type
+      variable, but also to many other constrained abbreviations (for
+      instance, [(< x : 'a > -> unit) t = <x : 'a>]). The solution is
+      that, if an abbreviation is unified with some subpart of its
+      parameters, then the parameter actually does not get
+      abbreviated.  It would be possible to check whether some
+      information is indeed lost, but it probably does not worth it.
+*)
+
+let gadt_equations_level = ref None
+
+let get_gadt_equations_level () =
+  match !gadt_equations_level with
+  | None -> assert false
+  | Some x -> x
+
+
+(* a local constraint can be added only if the rhs
+   of the constraint does not contain any Tvars.
+   They need to be removed using this function *)
+let reify env t =
+  let fresh_constr_scope = get_gadt_equations_level () in
+  let create_fresh_constr lev name =
+    let name = match name with Some s -> "$'"^s | _ -> "$" in
+    let path =
+      Path.Pident
+        (Ident.create_scoped ~scope:fresh_constr_scope
+           (get_new_abstract_name name))
+    in
+    let decl = new_declaration fresh_constr_scope None in
+    let new_env = Env.add_local_type path decl !env in
+    let t = newty2 lev (Tconstr (path,[],ref Mnil))  in
+    env := new_env;
+    path, t
+  in
+  let visited = ref TypeSet.empty in
+  let rec iterator ty =
+    let ty = repr ty in
+    if TypeSet.mem ty !visited then () else begin
+      visited := TypeSet.add ty !visited;
+      match ty.desc with
+        Tvar o ->
+          let path, t = create_fresh_constr ty.level o in
+          link_type ty t;
+          if ty.level < fresh_constr_scope then
+            raise Trace.(Unify [escape (Constructor path)])
+      | Tvariant r ->
+          let r = row_repr r in
+          if not (static_row r) then begin
+            if is_fixed r then iterator (row_more r) else
+            let m = r.row_more in
+            match m.desc with
+              Tvar o ->
+                let path, t = create_fresh_constr m.level o in
+                let row =
+                  let row_fixed = Some (Reified path) in
+                  {r with row_fields=[]; row_fixed; row_more = t} in
+                link_type m (newty2 m.level (Tvariant row));
+                if m.level < fresh_constr_scope then
+                  raise Trace.(Unify [escape (Constructor path)])
+            | _ -> assert false
+          end;
+          iter_row iterator r
+      | Tconstr (p, _, _) when is_object_type p ->
+          iter_type_expr iterator (full_expand !env ty)
+      | _ ->
+          iter_type_expr iterator ty
+    end
+  in
+  iterator t
+
+let is_newtype env p =
+  try
+    let decl = Env.find_type p env in
+    decl.type_expansion_scope <> Btype.lowest_level &&
+    decl.type_kind = Type_abstract &&
+    decl.type_private = Public
+  with Not_found -> false
+
+let non_aliasable p decl =
+  (* in_pervasives p ||  (subsumed by in_current_module) *)
+  in_current_module p && not decl.type_is_newtype
+
+let is_instantiable env p =
+  try
+    let decl = Env.find_type p env in
+    decl.type_kind = Type_abstract &&
+    decl.type_private = Public &&
+    decl.type_arity = 0 &&
+    decl.type_manifest = None &&
+    not (non_aliasable p decl)
+  with Not_found -> false
+
+
+(* PR#7113: -safe-string should be a global property *)
+let compatible_paths p1 p2 =
+  let open Predef in
+  Path.same p1 p2 ||
+  Path.same p1 path_bytes && Path.same p2 path_string ||
+  Path.same p1 path_string && Path.same p2 path_bytes
+
+(* Check for datatypes carefully; see PR#6348 *)
+let rec expands_to_datatype env ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tconstr (p, _, _) ->
+      begin try
+        is_datatype (Env.find_type p env) ||
+        expands_to_datatype env (try_expand_once env ty)
+      with Not_found | Cannot_expand -> false
+      end
+  | _ -> false
+
+(* mcomp type_pairs subst env t1 t2 does not raise an
+   exception if it is possible that t1 and t2 are actually
+   equal, assuming the types in type_pairs are equal and
+   that the mapping subst holds.
+   Assumes that both t1 and t2 do not contain any tvars
+   and that both their objects and variants are closed
+ *)
+
+let rec mcomp type_pairs env t1 t2 =
+  if t1 == t2 then () else
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if t1 == t2 then () else
+  match (t1.desc, t2.desc) with
+  | (Tvar _, _)
+  | (_, Tvar _)  ->
+      ()
+  | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
+      ()
+  | _ ->
+      let t1' = expand_head_opt env t1 in
+      let t2' = expand_head_opt env t2 in
+      (* Expansion may have changed the representative of the types... *)
+      let t1' = repr t1' and t2' = repr t2' in
+      if t1' == t2' then () else
+      begin try TypePairs.find type_pairs (t1', t2')
+      with Not_found ->
+        TypePairs.add type_pairs (t1', t2') ();
+        match (t1'.desc, t2'.desc) with
+        | (Tvar _, _)
+        | (_, Tvar _)  ->
+            ()
+        | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _))
+          when l1 = l2 || not (is_optional l1 || is_optional l2) ->
+            mcomp type_pairs env t1 t2;
+            mcomp type_pairs env u1 u2;
+        | (Ttuple tl1, Ttuple tl2) ->
+            mcomp_list type_pairs env tl1 tl2
+        | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) ->
+            mcomp_type_decl type_pairs env p1 p2 tl1 tl2
+        | (Tconstr (p, _, _), _) | (_, Tconstr (p, _, _)) ->
+            begin try
+              let decl = Env.find_type p env in
+              if non_aliasable p decl || is_datatype decl then raise (Unify [])
+            with Not_found -> ()
+            end
+        (*
+        | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) when n1 = n2 ->
+            mcomp_list type_pairs env tl1 tl2
+        *)
+        | (Tpackage _, Tpackage _) -> ()
+        | (Tvariant row1, Tvariant row2) ->
+            mcomp_row type_pairs env row1 row2
+        | (Tobject (fi1, _), Tobject (fi2, _)) ->
+            mcomp_fields type_pairs env fi1 fi2
+        | (Tfield _, Tfield _) ->       (* Actually unused *)
+            mcomp_fields type_pairs env t1' t2'
+        | (Tnil, Tnil) ->
+            ()
+        | (Tpoly (t1, []), Tpoly (t2, [])) ->
+            mcomp type_pairs env t1 t2
+        | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+            enter_poly env univar_pairs t1 tl1 t2 tl2
+              (mcomp type_pairs env)
+        | (Tunivar _, Tunivar _) ->
+            unify_univar t1' t2' !univar_pairs
+        | (_, _) ->
+            raise (Unify [])
+      end
+
+and mcomp_list type_pairs env tl1 tl2 =
+  if List.length tl1 <> List.length tl2 then
+    raise (Unify []);
+  List.iter2 (mcomp type_pairs env) tl1 tl2
+
+and mcomp_fields type_pairs env ty1 ty2 =
+  if not (concrete_object ty1 && concrete_object ty2) then assert false;
+  let (fields2, rest2) = flatten_fields ty2 in
+  let (fields1, rest1) = flatten_fields ty1 in
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  let has_present =
+    List.exists (fun (_, k, _) -> field_kind_repr k = Fpresent) in
+  mcomp type_pairs env rest1 rest2;
+  if has_present miss1  && (object_row ty2).desc = Tnil
+  || has_present miss2  && (object_row ty1).desc = Tnil then raise (Unify []);
+  List.iter
+    (function (_n, k1, t1, k2, t2) ->
+       mcomp_kind k1 k2;
+       mcomp type_pairs env t1 t2)
+    pairs
+
+and mcomp_kind k1 k2 =
+  let k1 = field_kind_repr k1 in
+  let k2 = field_kind_repr k2 in
+  match k1, k2 with
+    (Fpresent, Fabsent)
+  | (Fabsent, Fpresent) -> raise (Unify [])
+  | _                   -> ()
+
+and mcomp_row type_pairs env row1 row2 =
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
+  let cannot_erase (_,f) =
+    match row_field_repr f with
+      Rpresent _ -> true
+    | Rabsent | Reither _ -> false
+  in
+  if row1.row_closed && List.exists cannot_erase r2
+  || row2.row_closed && List.exists cannot_erase r1 then raise (Unify []);
+  List.iter
+    (fun (_,f1,f2) ->
+      match row_field_repr f1, row_field_repr f2 with
+      | Rpresent None, (Rpresent (Some _) | Reither (_, _::_, _, _) | Rabsent)
+      | Rpresent (Some _), (Rpresent None | Reither (true, _, _, _) | Rabsent)
+      | (Reither (_, _::_, _, _) | Rabsent), Rpresent None
+      | (Reither (true, _, _, _) | Rabsent), Rpresent (Some _) ->
+          raise (Unify [])
+      | Rpresent(Some t1), Rpresent(Some t2) ->
+          mcomp type_pairs env t1 t2
+      | Rpresent(Some t1), Reither(false, tl2, _, _) ->
+          List.iter (mcomp type_pairs env t1) tl2
+      | Reither(false, tl1, _, _), Rpresent(Some t2) ->
+          List.iter (mcomp type_pairs env t2) tl1
+      | _ -> ())
+    pairs
+
+and mcomp_type_decl type_pairs env p1 p2 tl1 tl2 =
+  try
+    let decl = Env.find_type p1 env in
+    let decl' = Env.find_type p2 env in
+    if compatible_paths p1 p2 then begin
+      let inj =
+        try List.map Variance.(mem Inj) (Env.find_type p1 env).type_variance
+        with Not_found -> List.map (fun _ -> false) tl1
+      in
+      List.iter2
+        (fun i (t1,t2) -> if i then mcomp type_pairs env t1 t2)
+        inj (List.combine tl1 tl2)
+    end else if non_aliasable p1 decl && non_aliasable p2 decl' then
+      raise (Unify [])
+    else
+      match decl.type_kind, decl'.type_kind with
+      | Type_record (lst,r), Type_record (lst',r') when r = r' ->
+          mcomp_list type_pairs env tl1 tl2;
+          mcomp_record_description type_pairs env lst lst'
+      | Type_variant v1, Type_variant v2 ->
+          mcomp_list type_pairs env tl1 tl2;
+          mcomp_variant_description type_pairs env v1 v2
+      | Type_open, Type_open ->
+          mcomp_list type_pairs env tl1 tl2
+      | Type_abstract, Type_abstract -> ()
+      | Type_abstract, _ when not (non_aliasable p1 decl)-> ()
+      | _, Type_abstract when not (non_aliasable p2 decl') -> ()
+      | _ -> raise (Unify [])
+  with Not_found -> ()
+
+and mcomp_type_option type_pairs env t t' =
+  match t, t' with
+    None, None -> ()
+  | Some t, Some t' -> mcomp type_pairs env t t'
+  | _ -> raise (Unify [])
+
+and mcomp_variant_description type_pairs env xs ys =
+  let rec iter = fun x y ->
+    match x, y with
+    | c1 :: xs, c2 :: ys   ->
+      mcomp_type_option type_pairs env c1.cd_res c2.cd_res;
+      begin match c1.cd_args, c2.cd_args with
+      | Cstr_tuple l1, Cstr_tuple l2 -> mcomp_list type_pairs env l1 l2
+      | Cstr_record l1, Cstr_record l2 ->
+          mcomp_record_description type_pairs env l1 l2
+      | _ -> raise (Unify [])
+      end;
+     if Ident.name c1.cd_id = Ident.name c2.cd_id
+      then iter xs ys
+      else raise (Unify [])
+    | [],[] -> ()
+    | _ -> raise (Unify [])
+  in
+  iter xs ys
+
+and mcomp_record_description type_pairs env =
+  let rec iter x y =
+    match x, y with
+    | l1 :: xs, l2 :: ys ->
+        mcomp type_pairs env l1.ld_type l2.ld_type;
+        if Ident.name l1.ld_id = Ident.name l2.ld_id &&
+           l1.ld_mutable = l2.ld_mutable
+        then iter xs ys
+        else raise (Unify [])
+    | [], [] -> ()
+    | _ -> raise (Unify [])
+  in
+  iter
+
+let mcomp env t1 t2 =
+  mcomp (TypePairs.create 4) env t1 t2
+
+(* Real unification *)
+
+let find_lowest_level ty =
+  let lowest = ref generic_level in
+  let rec find ty =
+    let ty = repr ty in
+    if ty.level >= lowest_level then begin
+      if ty.level < !lowest then lowest := ty.level;
+      ty.level <- pivot_level - ty.level;
+      iter_type_expr find ty
+    end
+  in find ty; unmark_type ty; !lowest
+
+let find_expansion_scope env path =
+  (Env.find_type path env).type_expansion_scope
+
+let add_gadt_equation env source destination =
+  (* Format.eprintf "@[add_gadt_equation %s %a@]@."
+    (Path.name source) !Btype.print_raw destination; *)
+  if local_non_recursive_abbrev !env source destination then begin
+    let destination = duplicate_type destination in
+    let expansion_scope =
+      max (Path.scope source) (get_gadt_equations_level ())
+    in
+    let decl = new_declaration expansion_scope (Some destination) in
+    env := Env.add_local_type source decl !env;
+    cleanup_abbrev ()
+  end
+
+let unify_eq_set = TypePairs.create 11
+
+let order_type_pair t1 t2 =
+  if t1.id <= t2.id then (t1, t2) else (t2, t1)
+
+let add_type_equality t1 t2 =
+  TypePairs.add unify_eq_set (order_type_pair t1 t2) ()
+
+let eq_package_path env p1 p2 =
+  Path.same p1 p2 ||
+  Path.same (normalize_package_path env p1) (normalize_package_path env p2)
+
+let nondep_type' = ref (fun _ _ _ -> assert false)
+let package_subtype = ref (fun _ _ _ _ _ _ _ -> assert false)
+
+exception Nondep_cannot_erase of Ident.t
+
+let rec concat_longident lid1 =
+  let open Longident in
+  function
+    Lident s -> Ldot (lid1, s)
+  | Ldot (lid2, s) -> Ldot (concat_longident lid1 lid2, s)
+  | Lapply (lid2, lid) -> Lapply (concat_longident lid1 lid2, lid)
+
+let nondep_instance env level id ty =
+  let ty = !nondep_type' env [id] ty in
+  if level = generic_level then duplicate_type ty else
+  let old = !current_level in
+  current_level := level;
+  let ty = instance ty in
+  current_level := old;
+  ty
+
+(* Find the type paths nl1 in the module type mty2, and add them to the
+   list (nl2, tl2). raise Not_found if impossible *)
+let complete_type_list ?(allow_absent=false) env nl1 lv2 mty2 nl2 tl2 =
+  (* This is morally WRONG: we're adding a (dummy) module without a scope in the
+     environment. However no operation which cares about levels/scopes is going
+     to happen while this module exists.
+     The only operations that happen are:
+     - Env.find_type_by_name
+     - nondep_instance
+     None of which check the scope.
+
+     It'd be nice if we avoided creating such temporary dummy modules and broken
+     environments though. *)
+  let id2 = Ident.create_local "Pkg" in
+  let env' = Env.add_module id2 Mp_present mty2 env in
+  let rec complete nl1 ntl2 =
+    match nl1, ntl2 with
+      [], _ -> ntl2
+    | n :: nl, (n2, _ as nt2) :: ntl' when n >= n2 ->
+        nt2 :: complete (if n = n2 then nl else nl1) ntl'
+    | n :: nl, _ ->
+        let lid = concat_longident (Longident.Lident "Pkg") n in
+        match Env.find_type_by_name lid env' with
+        | (_, {type_arity = 0; type_kind = Type_abstract;
+               type_private = Public; type_manifest = Some t2}) ->
+            begin match nondep_instance env' lv2 id2 t2 with
+            | t -> (n, t) :: complete nl ntl2
+            | exception Nondep_cannot_erase _ ->
+                if allow_absent then
+                  complete nl ntl2
+                else
+                  raise Exit
+            end
+        | (_, {type_arity = 0; type_kind = Type_abstract;
+               type_private = Public; type_manifest = None})
+          when allow_absent ->
+            complete nl ntl2
+        | _ -> raise Exit
+        | exception Not_found when allow_absent->
+            complete nl ntl2
+  in
+  match complete nl1 (List.combine nl2 tl2) with
+  | res -> res
+  | exception Exit -> raise Not_found
+
+(* raise Not_found rather than Unify if the module types are incompatible *)
+let unify_package env unify_list lv1 p1 n1 tl1 lv2 p2 n2 tl2 =
+  let ntl2 = complete_type_list env n1 lv2 (Mty_ident p2) n2 tl2
+  and ntl1 = complete_type_list env n2 lv1 (Mty_ident p1) n1 tl1 in
+  unify_list (List.map snd ntl1) (List.map snd ntl2);
+  if eq_package_path env p1 p2
+  || !package_subtype env p1 n1 tl1 p2 n2 tl2
+  && !package_subtype env p2 n2 tl2 p1 n1 tl1 then () else raise Not_found
+
+
+(* force unification in Reither when one side has a non-conjunctive type *)
+let rigid_variants = ref false
+
+let unify_eq t1 t2 =
+  t1 == t2 ||
+  match !umode with
+  | Expression -> false
+  | Pattern ->
+      try TypePairs.find unify_eq_set (order_type_pair t1 t2); true
+      with Not_found -> false
+
+let unify1_var env t1 t2 =
+  assert (is_Tvar t1);
+  occur env t1 t2;
+  occur_univar env t2;
+  let d1 = t1.desc in
+  link_type t1 t2;
+  try
+    update_level env t1.level t2;
+    update_scope t1.scope t2
+  with Unify _ as e ->
+    t1.desc <- d1;
+    raise e
+
+(* Can only be called when generate_equations is true *)
+let record_equation t1 t2 =
+  match !equations_generation with
+  | Forbidden -> assert false
+  | Allowed { equated_types } -> TypePairs.add equated_types (t1, t2) ()
+
+let rec unify (env:Env.t ref) t1 t2 =
+  (* First step: special cases (optimizations) *)
+  if t1 == t2 then () else
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if unify_eq t1 t2 then () else
+  let reset_tracing = check_trace_gadt_instances !env in
+
+  try
+    type_changed := true;
+    begin match (t1.desc, t2.desc) with
+      (Tvar _, Tconstr _) when deep_occur t1 t2 ->
+        unify2 env t1 t2
+    | (Tconstr _, Tvar _) when deep_occur t2 t1 ->
+        unify2 env t1 t2
+    | (Tvar _, _) ->
+        unify1_var !env t1 t2
+    | (_, Tvar _) ->
+        unify1_var !env t2 t1
+    | (Tunivar _, Tunivar _) ->
+        unify_univar t1 t2 !univar_pairs;
+        update_level !env t1.level t2;
+        update_scope t1.scope t2;
+        link_type t1 t2
+    | (Tconstr (p1, [], a1), Tconstr (p2, [], a2))
+          when Path.same p1 p2 (* && actual_mode !env = Old *)
+            (* This optimization assumes that t1 does not expand to t2
+               (and conversely), so we fall back to the general case
+               when any of the types has a cached expansion. *)
+            && not (has_cached_expansion p1 !a1
+                 || has_cached_expansion p2 !a2) ->
+        update_level !env t1.level t2;
+        update_scope t1.scope t2;
+        link_type t1 t2
+    | (Tconstr (p1, [], _), Tconstr (p2, [], _))
+      when Env.has_local_constraints !env
+      && is_newtype !env p1 && is_newtype !env p2 ->
+        (* Do not use local constraints more than necessary *)
+        begin try
+          if find_expansion_scope !env p1 > find_expansion_scope !env p2 then
+            unify env t1 (try_expand_once !env t2)
+          else
+            unify env (try_expand_once !env t1) t2
+        with Cannot_expand ->
+          unify2 env t1 t2
+        end
+    | _ ->
+        unify2 env t1 t2
+    end;
+    reset_trace_gadt_instances reset_tracing;
+  with Unify trace ->
+    reset_trace_gadt_instances reset_tracing;
+    raise( Unify (Trace.diff t1 t2 :: trace) )
+
+and unify2 env t1 t2 =
+  (* Second step: expansion of abbreviations *)
+  (* Expansion may change the representative of the types. *)
+  ignore (expand_head_unif !env t1);
+  ignore (expand_head_unif !env t2);
+  let t1' = expand_head_unif !env t1 in
+  let t2' = expand_head_unif !env t2 in
+  let lv = min t1'.level t2'.level in
+  let scope = max t1'.scope t2'.scope in
+  update_level !env lv t2;
+  update_level !env lv t1;
+  update_scope scope t2;
+  update_scope scope t1;
+  if unify_eq t1' t2' then () else
+
+  let t1 = repr t1 and t2 = repr t2 in
+  let t1, t2 =
+    if !Clflags.principal
+    && (find_lowest_level t1' < lv || find_lowest_level t2' < lv) then
+      (* Expand abbreviations hiding a lower level *)
+      (* Should also do it for parameterized types, after unification... *)
+      (match t1.desc with Tconstr (_, [], _) -> t1' | _ -> t1),
+      (match t2.desc with Tconstr (_, [], _) -> t2' | _ -> t2)
+    else (t1, t2)
+  in
+  if unify_eq t1 t1' || not (unify_eq t2 t2') then
+    unify3 env t1 t1' t2 t2'
+  else
+    try unify3 env t2 t2' t1 t1' with Unify trace ->
+      raise (Unify (Trace.swap trace))
+
+and unify3 env t1 t1' t2 t2' =
+  (* Third step: truly unification *)
+  (* Assumes either [t1 == t1'] or [t2 != t2'] *)
+  let d1 = t1'.desc and d2 = t2'.desc in
+  let create_recursion = (t2 != t2') && (deep_occur t1' t2) in
+
+  begin match (d1, d2) with (* handle vars and univars specially *)
+    (Tunivar _, Tunivar _) ->
+      unify_univar t1' t2' !univar_pairs;
+      link_type t1' t2'
+  | (Tvar _, _) ->
+      occur !env t1' t2;
+      occur_univar !env t2;
+      link_type t1' t2;
+  | (_, Tvar _) ->
+      occur !env t2' t1;
+      occur_univar !env t1;
+      link_type t2' t1;
+  | (Tfield _, Tfield _) -> (* special case for GADTs *)
+      unify_fields env t1' t2'
+  | _ ->
+    begin match !umode with
+    | Expression ->
+        occur !env t1' t2';
+        if is_self_type d1 (* PR#7711: do not abbreviate self type *)
+        then link_type t1' t2'
+        else link_type t1' t2
+    | Pattern ->
+        add_type_equality t1' t2'
+    end;
+    try
+      begin match (d1, d2) with
+        (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2 ||
+        (!Clflags.classic || !umode = Pattern) &&
+        not (is_optional l1 || is_optional l2) ->
+          unify  env t1 t2; unify env  u1 u2;
+          begin match commu_repr c1, commu_repr c2 with
+            Clink r, c2 -> set_commu r c2
+          | c1, Clink r -> set_commu r c1
+          | _ -> ()
+          end
+      | (Ttuple tl1, Ttuple tl2) ->
+          unify_list env tl1 tl2
+      | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 ->
+          if !umode = Expression || !equations_generation = Forbidden then
+            unify_list env tl1 tl2
+          else if !assume_injective then
+            set_mode_pattern ~generate:!equations_generation ~injective:false
+              ~allow_recursive:!allow_recursive_equation
+              (fun () -> unify_list env tl1 tl2)
+          else if in_current_module p1 (* || in_pervasives p1 *)
+                  || List.exists (expands_to_datatype !env) [t1'; t1; t2] then
+            unify_list env tl1 tl2
+          else
+            let inj =
+              try List.map Variance.(mem Inj)
+                    (Env.find_type p1 !env).type_variance
+              with Not_found -> List.map (fun _ -> false) tl1
+            in
+            List.iter2
+              (fun i (t1, t2) ->
+                if i then unify env t1 t2 else
+                set_mode_pattern ~generate:Forbidden ~injective:false
+                  ~allow_recursive:!allow_recursive_equation
+                  begin fun () ->
+                    let snap = snapshot () in
+                    try unify env t1 t2 with Unify _ ->
+                      backtrack snap;
+                      reify env t1; reify env t2
+                  end)
+              inj (List.combine tl1 tl2)
+      | (Tconstr (path,[],_),
+         Tconstr (path',[],_))
+        when is_instantiable !env path && is_instantiable !env path'
+        && can_generate_equations () ->
+          let source, destination =
+            if Path.scope path > Path.scope path'
+            then  path , t2'
+            else  path', t1'
+          in
+          record_equation t1' t2';
+          add_gadt_equation env source destination
+      | (Tconstr (path,[],_), _)
+        when is_instantiable !env path && can_generate_equations () ->
+          reify env t2';
+          record_equation t1' t2';
+          add_gadt_equation env path t2'
+      | (_, Tconstr (path,[],_))
+        when is_instantiable !env path && can_generate_equations () ->
+          reify env t1';
+          record_equation t1' t2';
+          add_gadt_equation env path t1'
+      | (Tconstr (_,_,_), _) | (_, Tconstr (_,_,_)) when !umode = Pattern ->
+          reify env t1';
+          reify env t2';
+          if can_generate_equations () then (
+            mcomp !env t1' t2';
+            record_equation t1' t2'
+          )
+      | (Tobject (fi1, nm1), Tobject (fi2, _)) ->
+          unify_fields env fi1 fi2;
+          (* Type [t2'] may have been instantiated by [unify_fields] *)
+          (* XXX One should do some kind of unification... *)
+          begin match (repr t2').desc with
+            Tobject (_, {contents = Some (_, va::_)}) when
+              (match (repr va).desc with
+                Tvar _|Tunivar _|Tnil -> true | _ -> false) -> ()
+          | Tobject (_, nm2) -> set_name nm2 !nm1
+          | _ -> ()
+          end
+      | (Tvariant row1, Tvariant row2) ->
+          if !umode = Expression then
+            unify_row env row1 row2
+          else begin
+            let snap = snapshot () in
+            try unify_row env row1 row2
+            with Unify _ ->
+              backtrack snap;
+              reify env t1';
+              reify env t2';
+              if can_generate_equations () then (
+                mcomp !env t1' t2';
+                record_equation t1' t2'
+              )
+          end
+      | (Tfield(f,kind,_,rem), Tnil) | (Tnil, Tfield(f,kind,_,rem)) ->
+          begin match field_kind_repr kind with
+            Fvar r when f <> dummy_method ->
+              set_kind r Fabsent;
+              if d2 = Tnil then unify env rem t2'
+              else unify env (newty2 rem.level Tnil) rem
+          | _      ->
+              if f = dummy_method then
+                raise (Unify Trace.[Obj Self_cannot_be_closed])
+              else if d1 = Tnil then
+                raise (Unify Trace.[Obj(Missing_field (First, f))])
+              else
+                raise (Unify Trace.[Obj(Missing_field (Second, f))])
+          end
+      | (Tnil, Tnil) ->
+          ()
+      | (Tpoly (t1, []), Tpoly (t2, [])) ->
+          unify env t1 t2
+      | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+          enter_poly !env univar_pairs t1 tl1 t2 tl2 (unify env)
+      | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) ->
+          begin try
+            unify_package !env (unify_list env)
+              t1.level p1 n1 tl1 t2.level p2 n2 tl2
+          with Not_found ->
+            if !umode = Expression then raise (Unify []);
+            List.iter (reify env) (tl1 @ tl2);
+            (* if !generate_equations then List.iter2 (mcomp !env) tl1 tl2 *)
+          end
+      | (Tnil,  Tconstr _ ) -> raise (Unify Trace.[Obj(Abstract_row Second)])
+      | (Tconstr _,  Tnil ) -> raise (Unify Trace.[Obj(Abstract_row First)])
+      | (_, _) -> raise (Unify [])
+      end;
+      (* XXX Commentaires + changer "create_recursion"
+         ||| Comments + change "create_recursion" *)
+      if create_recursion then
+        match t2.desc with
+          Tconstr (p, tl, abbrev) ->
+            forget_abbrev abbrev p;
+            let t2'' = expand_head_unif !env t2 in
+            if not (closed_parameterized_type tl t2'') then
+              link_type (repr t2) (repr t2')
+        | _ ->
+            () (* t2 has already been expanded by update_level *)
+    with Unify trace ->
+      t1'.desc <- d1;
+      raise (Unify trace)
+  end
+
+and unify_list env tl1 tl2 =
+  if List.length tl1 <> List.length tl2 then
+    raise (Unify []);
+  List.iter2 (unify env) tl1 tl2
+
+(* Build a fresh row variable for unification *)
+and make_rowvar level use1 rest1 use2 rest2  =
+  let set_name ty name =
+    match ty.desc with
+      Tvar None -> set_type_desc ty (Tvar name)
+    | _ -> ()
+  in
+  let name =
+    match rest1.desc, rest2.desc with
+      Tvar (Some _ as name1), Tvar (Some _ as name2) ->
+        if rest1.level <= rest2.level then name1 else name2
+    | Tvar (Some _ as name), _ ->
+        if use2 then set_name rest2 name; name
+    | _, Tvar (Some _ as name) ->
+        if use1 then set_name rest2 name; name
+    | _ -> None
+  in
+  if use1 then rest1 else
+  if use2 then rest2 else newvar2 ?name level
+
+and unify_fields env ty1 ty2 =          (* Optimization *)
+  let (fields1, rest1) = flatten_fields ty1
+  and (fields2, rest2) = flatten_fields ty2 in
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  let l1 = (repr ty1).level and l2 = (repr ty2).level in
+  let va = make_rowvar (min l1 l2) (miss2=[]) rest1 (miss1=[]) rest2 in
+  let d1 = rest1.desc and d2 = rest2.desc in
+  try
+    unify env (build_fields l1 miss1 va) rest2;
+    unify env rest1 (build_fields l2 miss2 va);
+    List.iter
+      (fun (n, k1, t1, k2, t2) ->
+        unify_kind k1 k2;
+        try
+          if !trace_gadt_instances then begin
+            update_level !env va.level t1;
+            update_scope va.scope t1
+          end;
+          unify env t1 t2
+        with Unify trace ->
+          raise( Unify (Trace.incompatible_fields n t1 t2 :: trace) )
+      )
+      pairs
+  with exn ->
+    set_type_desc rest1 d1;
+    set_type_desc rest2 d2;
+    raise exn
+
+and unify_kind k1 k2 =
+  let k1 = field_kind_repr k1 in
+  let k2 = field_kind_repr k2 in
+  if k1 == k2 then () else
+  match k1, k2 with
+    (Fvar r, (Fvar _ | Fpresent)) -> set_kind r k2
+  | (Fpresent, Fvar r)            -> set_kind r k1
+  | (Fpresent, Fpresent)          -> ()
+  | _                             -> assert false
+
+and unify_row env row1 row2 =
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let rm1 = row_more row1 and rm2 = row_more row2 in
+  if unify_eq rm1 rm2 then () else
+  let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
+  if r1 <> [] && r2 <> [] then begin
+    let ht = Hashtbl.create (List.length r1) in
+    List.iter (fun (l,_) -> Hashtbl.add ht (hash_variant l) l) r1;
+    List.iter
+      (fun (l,_) ->
+        try raise (Tags(l, Hashtbl.find ht (hash_variant l)))
+        with Not_found -> ())
+      r2
+  end;
+  let fixed1 = fixed_explanation row1 and fixed2 = fixed_explanation row2 in
+  let more = match fixed1, fixed2 with
+    | Some _, Some _ -> if rm2.level < rm1.level then rm2 else rm1
+    | Some _, None -> rm1
+    | None, Some _ -> rm2
+    | None, None -> newty2 (min rm1.level rm2.level) (Tvar None)
+  in
+  let fixed = merge_fixed_explanation fixed1 fixed2
+  and closed = row1.row_closed || row2.row_closed in
+  let keep switch =
+    List.for_all
+      (fun (_,f1,f2) ->
+        let f1, f2 = switch f1 f2 in
+        row_field_repr f1 = Rabsent || row_field_repr f2 <> Rabsent)
+      pairs
+  in
+  let empty fields =
+    List.for_all (fun (_,f) -> row_field_repr f = Rabsent) fields in
+  (* Check whether we are going to build an empty type *)
+  if closed && (empty r1 || row2.row_closed) && (empty r2 || row1.row_closed)
+  && List.for_all
+      (fun (_,f1,f2) ->
+        row_field_repr f1 = Rabsent || row_field_repr f2 = Rabsent)
+      pairs
+  then raise Trace.( Unify [Variant No_intersection] );
+  let name =
+    if row1.row_name <> None && (row1.row_closed || empty r2) &&
+      (not row2.row_closed || keep (fun f1 f2 -> f1, f2) && empty r1)
+    then row1.row_name
+    else if row2.row_name <> None && (row2.row_closed || empty r1) &&
+      (not row1.row_closed || keep (fun f1 f2 -> f2, f1) && empty r2)
+    then row2.row_name
+    else None
+  in
+  let row0 = {row_fields = []; row_more = more; row_bound = ();
+              row_closed = closed; row_fixed = fixed; row_name = name} in
+  let set_more row rest =
+    let rest =
+      if closed then
+        filter_row_fields row.row_closed rest
+      else rest in
+    begin match fixed_explanation row with
+      | None ->
+          if rest <> [] && row.row_closed then
+            let pos = if row == row1 then Trace.First else Trace.Second in
+            raise Trace.(Unify [Variant (No_tags(pos,rest))])
+      | Some fixed ->
+          let pos = if row == row1 then Trace.First else Trace.Second in
+          if closed && not row.row_closed then
+            raise Trace.(Unify [Variant(Fixed_row(pos,Cannot_be_closed,fixed))])
+          else if rest <> [] then
+            let case = Trace.Cannot_add_tags (List.map fst rest) in
+            raise Trace.(Unify [Variant(Fixed_row(pos,case,fixed))])
+    end;
+    (* The following test is not principal... should rather use Tnil *)
+    let rm = row_more row in
+    (*if !trace_gadt_instances && rm.desc = Tnil then () else*)
+    if !trace_gadt_instances then
+      update_level !env rm.level (newgenty (Tvariant row));
+    if row_fixed row then
+      if more == rm then () else
+      if is_Tvar rm then link_type rm more else unify env rm more
+    else
+      let ty = newgenty (Tvariant {row0 with row_fields = rest}) in
+      update_level !env rm.level ty;
+      update_scope rm.scope ty;
+      link_type rm ty
+  in
+  let md1 = rm1.desc and md2 = rm2.desc in
+  begin try
+    set_more row2 r1;
+    set_more row1 r2;
+    List.iter
+      (fun (l,f1,f2) ->
+        try unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2
+        with Unify trace ->
+          raise Trace.( Unify( Variant (Incompatible_types_for l) :: trace ))
+      )
+      pairs;
+    if static_row row1 then begin
+      let rm = row_more row1 in
+      if is_Tvar rm then link_type rm (newty2 rm.level Tnil)
+    end
+  with exn ->
+    set_type_desc rm1 md1; set_type_desc rm2 md2; raise exn
+  end
+
+and unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 =
+  let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
+  let if_not_fixed (pos,fixed) f =
+    match fixed with
+    | None -> f ()
+    | Some fix ->
+        let tr = Trace.[ Variant (Fixed_row (pos,Cannot_add_tags [l],fix)) ] in
+        raise (Unify tr) in
+  let first = Trace.First, fixed1 and second = Trace.Second, fixed2 in
+  let either_fixed = match fixed1, fixed2 with
+    | None, None -> false
+    | _ -> true in
+  if f1 == f2 then () else
+  match f1, f2 with
+    Rpresent(Some t1), Rpresent(Some t2) -> unify env t1 t2
+  | Rpresent None, Rpresent None -> ()
+  | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) ->
+      if e1 == e2 then () else
+      if either_fixed && not (c1 || c2)
+      && List.length tl1 = List.length tl2 then begin
+        (* PR#7496 *)
+        let f = Reither (c1 || c2, [], m1 || m2, ref None) in
+        set_row_field e1 f; set_row_field e2 f;
+        List.iter2 (unify env) tl1 tl2
+      end
+      else let redo =
+        (m1 || m2 || either_fixed ||
+         !rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) &&
+        begin match tl1 @ tl2 with [] -> false
+        | t1 :: tl ->
+            if c1 || c2 then raise (Unify []);
+            List.iter (unify env t1) tl;
+            !e1 <> None || !e2 <> None
+        end in
+      if redo then unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 else
+      let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
+      let rec remq tl = function [] -> []
+        | ty :: tl' ->
+            if List.memq ty tl then remq tl tl' else ty :: remq tl tl'
+      in
+      let tl1' = remq tl2 tl1 and tl2' = remq tl1 tl2 in
+      (* PR#6744 *)
+      let split_univars =
+        List.partition
+          (fun ty -> try occur_univar !env ty; true with Unify _ -> false) in
+      let (tl1',tlu1) = split_univars tl1'
+      and (tl2',tlu2) = split_univars tl2' in
+      begin match tlu1, tlu2 with
+        [], [] -> ()
+      | (tu1::tlu1), _ :: _ ->
+          (* Attempt to merge all the types containing univars *)
+          List.iter (unify env tu1) (tlu1@tlu2)
+      | (tu::_, []) | ([], tu::_) -> occur_univar !env tu
+      end;
+      (* Is this handling of levels really principal? *)
+      List.iter (fun ty ->
+        let rm = repr rm2 in
+        update_level !env rm.level ty;
+        update_scope rm.scope ty;
+      ) tl1';
+      List.iter (fun ty ->
+        let rm = repr rm1 in
+        update_level !env rm.level ty;
+        update_scope rm.scope ty;
+      ) tl2';
+      let e = ref None in
+      let f1' = Reither(c1 || c2, tl2', m1 || m2, e)
+      and f2' = Reither(c1 || c2, tl1', m1 || m2, e) in
+      set_row_field e1 f1'; set_row_field e2 f2';
+  | Reither(_, _, false, e1), Rabsent ->
+      if_not_fixed first (fun () -> set_row_field e1 f2)
+  | Rabsent, Reither(_, _, false, e2) ->
+      if_not_fixed second (fun () -> set_row_field e2 f1)
+  | Rabsent, Rabsent -> ()
+  | Reither(false, tl, _, e1), Rpresent(Some t2) ->
+      if_not_fixed first (fun () ->
+          set_row_field e1 f2;
+          let rm = repr rm1 in
+          update_level !env rm.level t2;
+          update_scope rm.scope t2;
+          (try List.iter (fun t1 -> unify env t1 t2) tl
+           with exn -> e1 := None; raise exn)
+        )
+  | Rpresent(Some t1), Reither(false, tl, _, e2) ->
+      if_not_fixed second (fun () ->
+          set_row_field e2 f1;
+          let rm = repr rm2 in
+          update_level !env rm.level t1;
+          update_scope rm.scope t1;
+          (try List.iter (unify env t1) tl
+           with exn -> e2 := None; raise exn)
+        )
+  | Reither(true, [], _, e1), Rpresent None ->
+      if_not_fixed first (fun () -> set_row_field e1 f2)
+  | Rpresent None, Reither(true, [], _, e2) ->
+      if_not_fixed second (fun () -> set_row_field e2 f1)
+  | _ -> raise (Unify [])
+
+
+let unify env ty1 ty2 =
+  let snap = Btype.snapshot () in
+  try
+    unify env ty1 ty2
+  with
+    Unify trace ->
+      undo_compress snap;
+      raise (Unify (expand_trace !env trace))
+
+let unify_gadt ~equations_level:lev ~allow_recursive (env:Env.t ref) ty1 ty2 =
+  try
+    univar_pairs := [];
+    gadt_equations_level := Some lev;
+    let equated_types = TypePairs.create 0 in
+    set_mode_pattern
+      ~generate:(Allowed { equated_types })
+      ~injective:true
+      ~allow_recursive
+      (fun () -> unify env ty1 ty2);
+    gadt_equations_level := None;
+    TypePairs.clear unify_eq_set;
+    equated_types
+  with e ->
+    gadt_equations_level := None;
+    TypePairs.clear unify_eq_set;
+    raise e
+
+let unify_var env t1 t2 =
+  let t1 = repr t1 and t2 = repr t2 in
+  if t1 == t2 then () else
+  match t1.desc, t2.desc with
+    Tvar _, Tconstr _ when deep_occur t1 t2 ->
+      unify (ref env) t1 t2
+  | Tvar _, _ ->
+      let reset_tracing = check_trace_gadt_instances env in
+      begin try
+        occur env t1 t2;
+        update_level env t1.level t2;
+        update_scope t1.scope t2;
+        link_type t1 t2;
+        reset_trace_gadt_instances reset_tracing;
+      with Unify trace ->
+        reset_trace_gadt_instances reset_tracing;
+        let expanded_trace = expand_trace env @@ Trace.diff t1 t2 :: trace in
+        raise (Unify expanded_trace)
+      end
+  | _ ->
+      unify (ref env) t1 t2
+
+let _ = unify' := unify_var
+
+let unify_pairs env ty1 ty2 pairs =
+  univar_pairs := pairs;
+  unify env ty1 ty2
+
+let unify env ty1 ty2 =
+  unify_pairs (ref env) ty1 ty2 []
+
+
+
+(**** Special cases of unification ****)
+
+let expand_head_trace env t =
+  let reset_tracing = check_trace_gadt_instances env in
+  let t = expand_head_unif env t in
+  reset_trace_gadt_instances reset_tracing;
+  t
+
+(*
+   Unify [t] and [l:'a -> 'b]. Return ['a] and ['b].
+   In label mode, label mismatch is accepted when
+   (1) the requested label is ""
+   (2) the original label is not optional
+*)
+
+let filter_arrow env t l =
+  let t = expand_head_trace env t in
+  match t.desc with
+    Tvar _ ->
+      let lv = t.level in
+      let t1 = newvar2 lv and t2 = newvar2 lv in
+      let t' = newty2 lv (Tarrow (l, t1, t2, Cok)) in
+      link_type t t';
+      (t1, t2)
+  | Tarrow(l', t1, t2, _)
+    when l = l' || !Clflags.classic && l = Nolabel && not (is_optional l') ->
+      (t1, t2)
+  | _ ->
+      raise (Unify [])
+
+(* Used by [filter_method]. *)
+let rec filter_method_field env name priv ty =
+  let ty = expand_head_trace env ty in
+  match ty.desc with
+    Tvar _ ->
+      let level = ty.level in
+      let ty1 = newvar2 level and ty2 = newvar2 level in
+      let ty' = newty2 level (Tfield (name,
+                                      begin match priv with
+                                        Private -> Fvar (ref None)
+                                      | Public  -> Fpresent
+                                      end,
+                                      ty1, ty2))
+      in
+      link_type ty ty';
+      ty1
+  | Tfield(n, kind, ty1, ty2) ->
+      let kind = field_kind_repr kind in
+      if (n = name) && (kind <> Fabsent) then begin
+        if priv = Public then
+          unify_kind kind Fpresent;
+        ty1
+      end else
+        filter_method_field env name priv ty2
+  | _ ->
+      raise (Unify [])
+
+(* Unify [ty] and [< name : 'a; .. >]. Return ['a]. *)
+let filter_method env name priv ty =
+  let ty = expand_head_trace env ty in
+  match ty.desc with
+    Tvar _ ->
+      let ty1 = newvar () in
+      let ty' = newobj ty1 in
+      update_level env ty.level ty';
+      update_scope ty.scope ty';
+      link_type ty ty';
+      filter_method_field env name priv ty1
+  | Tobject(f, _) ->
+      filter_method_field env name priv f
+  | _ ->
+      raise (Unify [])
+
+let check_filter_method env name priv ty =
+  ignore(filter_method env name priv ty)
+
+let filter_self_method env lab priv meths ty =
+  let ty' = filter_method env lab priv ty in
+  try
+    Meths.find lab !meths
+  with Not_found ->
+    let pair = (Ident.create_local lab, ty') in
+    meths := Meths.add lab pair !meths;
+    pair
+
+
+                        (***********************************)
+                        (*  Matching between type schemes  *)
+                        (***********************************)
+
+(*
+   Update the level of [ty]. First check that the levels of generic
+   variables from the subject are not lowered.
+*)
+let moregen_occur env level ty =
+  let rec occur ty =
+    let ty = repr ty in
+    if ty.level > level then begin
+      if is_Tvar ty && ty.level >= generic_level - 1 then raise Occur;
+      ty.level <- pivot_level - ty.level;
+      iter_type_expr occur ty
+    end
+  in
+  begin try
+    occur ty; unmark_type ty
+  with Occur ->
+    unmark_type ty; raise (Unify [])
+  end;
+  (* also check for free univars *)
+  occur_univar env ty;
+  update_level env level ty
+
+let may_instantiate inst_nongen t1 =
+  if inst_nongen then t1.level <> generic_level - 1
+                 else t1.level =  generic_level
+
+let rec moregen inst_nongen type_pairs env t1 t2 =
+  if t1 == t2 then () else
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if t1 == t2 then () else
+
+  try
+    match (t1.desc, t2.desc) with
+      (Tvar _, _) when may_instantiate inst_nongen t1 ->
+        moregen_occur env t1.level t2;
+        update_scope t1.scope t2;
+        occur env t1 t2;
+        link_type t1 t2
+    | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
+        ()
+    | _ ->
+        let t1' = expand_head env t1 in
+        let t2' = expand_head env t2 in
+        (* Expansion may have changed the representative of the types... *)
+        let t1' = repr t1' and t2' = repr t2' in
+        if t1' == t2' then () else
+        begin try
+          TypePairs.find type_pairs (t1', t2')
+        with Not_found ->
+          TypePairs.add type_pairs (t1', t2') ();
+          match (t1'.desc, t2'.desc) with
+            (Tvar _, _) when may_instantiate inst_nongen t1' ->
+              moregen_occur env t1'.level t2;
+              update_scope t1'.scope t2;
+              link_type t1' t2
+          | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2
+            || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
+              moregen inst_nongen type_pairs env t1 t2;
+              moregen inst_nongen type_pairs env u1 u2
+          | (Ttuple tl1, Ttuple tl2) ->
+              moregen_list inst_nongen type_pairs env tl1 tl2
+          | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
+                when Path.same p1 p2 ->
+              moregen_list inst_nongen type_pairs env tl1 tl2
+          | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) ->
+              begin try
+                unify_package env (moregen_list inst_nongen type_pairs env)
+                  t1'.level p1 n1 tl1 t2'.level p2 n2 tl2
+              with Not_found -> raise (Unify [])
+              end
+          | (Tvariant row1, Tvariant row2) ->
+              moregen_row inst_nongen type_pairs env row1 row2
+          | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) ->
+              moregen_fields inst_nongen type_pairs env fi1 fi2
+          | (Tfield _, Tfield _) ->           (* Actually unused *)
+              moregen_fields inst_nongen type_pairs env t1' t2'
+          | (Tnil, Tnil) ->
+              ()
+          | (Tpoly (t1, []), Tpoly (t2, [])) ->
+              moregen inst_nongen type_pairs env t1 t2
+          | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+              enter_poly env univar_pairs t1 tl1 t2 tl2
+                (moregen inst_nongen type_pairs env)
+          | (Tunivar _, Tunivar _) ->
+              unify_univar t1' t2' !univar_pairs
+          | (_, _) ->
+              raise (Unify [])
+        end
+  with Unify trace ->  raise( Unify ( Trace.diff t1 t2 :: trace ) )
+
+and moregen_list inst_nongen type_pairs env tl1 tl2 =
+  if List.length tl1 <> List.length tl2 then
+    raise (Unify []);
+  List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2
+
+and moregen_fields inst_nongen type_pairs env ty1 ty2 =
+  let (fields1, rest1) = flatten_fields ty1
+  and (fields2, rest2) = flatten_fields ty2 in
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  if miss1 <> [] then raise (Unify []);
+  moregen inst_nongen type_pairs env rest1
+    (build_fields (repr ty2).level miss2 rest2);
+  List.iter
+    (fun (n, k1, t1, k2, t2) ->
+       moregen_kind k1 k2;
+       try moregen inst_nongen type_pairs env t1 t2 with Unify trace ->
+         let e = Trace.diff
+             (newty (Tfield(n, k1, t1, rest2)))
+             (newty (Tfield(n, k2, t2, rest2))) in
+         raise( Unify ( e :: trace ) )
+    )
+    pairs
+
+and moregen_kind k1 k2 =
+  let k1 = field_kind_repr k1 in
+  let k2 = field_kind_repr k2 in
+  if k1 == k2 then () else
+  match k1, k2 with
+    (Fvar r, (Fvar _ | Fpresent))  -> set_kind r k2
+  | (Fpresent, Fpresent)           -> ()
+  | _                              -> raise (Unify [])
+
+and moregen_row inst_nongen type_pairs env row1 row2 =
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let rm1 = repr row1.row_more and rm2 = repr row2.row_more in
+  if rm1 == rm2 then () else
+  let may_inst =
+    is_Tvar rm1 && may_instantiate inst_nongen rm1 || rm1.desc = Tnil in
+  let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
+  let r1, r2 =
+    if row2.row_closed then
+      filter_row_fields may_inst r1, filter_row_fields false r2
+    else r1, r2
+  in
+  if r1 <> [] || row1.row_closed && (not row2.row_closed || r2 <> [])
+  then raise (Unify []);
+  begin match rm1.desc, rm2.desc with
+    Tunivar _, Tunivar _ ->
+      unify_univar rm1 rm2 !univar_pairs
+  | Tunivar _, _ | _, Tunivar _ ->
+      raise (Unify [])
+  | _ when static_row row1 -> ()
+  | _ when may_inst ->
+      let ext =
+        newgenty (Tvariant {row2 with row_fields = r2; row_name = None})
+      in
+      moregen_occur env rm1.level ext;
+      update_scope rm1.scope ext;
+      link_type rm1 ext
+  | Tconstr _, Tconstr _ ->
+      moregen inst_nongen type_pairs env rm1 rm2
+  | _ -> raise (Unify [])
+  end;
+  List.iter
+    (fun (_l,f1,f2) ->
+      let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
+      if f1 == f2 then () else
+      match f1, f2 with
+        Rpresent(Some t1), Rpresent(Some t2) ->
+          moregen inst_nongen type_pairs env t1 t2
+      | Rpresent None, Rpresent None -> ()
+      | Reither(false, tl1, _, e1), Rpresent(Some t2) when may_inst ->
+          set_row_field e1 f2;
+          List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1
+      | Reither(c1, tl1, _, e1), Reither(c2, tl2, m2, e2) ->
+          if e1 != e2 then begin
+            if c1 && not c2 then raise(Unify []);
+            set_row_field e1 (Reither (c2, [], m2, e2));
+            if List.length tl1 = List.length tl2 then
+              List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2
+            else match tl2 with
+              t2 :: _ ->
+                List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2)
+                  tl1
+            | [] ->
+                if tl1 <> [] then raise (Unify [])
+          end
+      | Reither(true, [], _, e1), Rpresent None when may_inst ->
+          set_row_field e1 f2
+      | Reither(_, _, _, e1), Rabsent when may_inst ->
+          set_row_field e1 f2
+      | Rabsent, Rabsent -> ()
+      | _ -> raise (Unify []))
+    pairs
+
+(* Must empty univar_pairs first *)
+let moregen inst_nongen type_pairs env patt subj =
+  univar_pairs := [];
+  moregen inst_nongen type_pairs env patt subj
+
+(*
+   Non-generic variable can be instantiated only if [inst_nongen] is
+   true. So, [inst_nongen] should be set to false if the subject might
+   contain non-generic variables (and we do not want them to be
+   instantiated).
+   Usually, the subject is given by the user, and the pattern
+   is unimportant.  So, no need to propagate abbreviations.
+*)
+let moregeneral env inst_nongen pat_sch subj_sch =
+  let old_level = !current_level in
+  current_level := generic_level - 1;
+  (*
+     Generic variables are first duplicated with [instance].  So,
+     their levels are lowered to [generic_level - 1].  The subject is
+     then copied with [duplicate_type].  That way, its levels won't be
+     changed.
+  *)
+  let subj = duplicate_type (instance subj_sch) in
+  current_level := generic_level;
+  (* Duplicate generic variables *)
+  let patt = instance pat_sch in
+  let res =
+    try moregen inst_nongen (TypePairs.create 13) env patt subj; true with
+      Unify _ -> false
+  in
+  current_level := old_level;
+  res
+
+
+(* Alternative approach: "rigidify" a type scheme,
+   and check validity after unification *)
+(* Simpler, no? *)
+
+let rec rigidify_rec vars ty =
+  let ty = repr ty in
+  if ty.level >= lowest_level then begin
+    ty.level <- pivot_level - ty.level;
+    match ty.desc with
+    | Tvar _ ->
+        if not (List.memq ty !vars) then vars := ty :: !vars
+    | Tvariant row ->
+        let row = row_repr row in
+        let more = repr row.row_more in
+        if is_Tvar more && not (row_fixed row) then begin
+          let more' = newty2 more.level more.desc in
+          let row' =
+            {row with row_fixed=Some Rigid; row_fields=[]; row_more=more'}
+          in link_type more (newty2 ty.level (Tvariant row'))
+        end;
+        iter_row (rigidify_rec vars) row;
+        (* only consider the row variable if the variant is not static *)
+        if not (static_row row) then rigidify_rec vars (row_more row)
+    | _ ->
+        iter_type_expr (rigidify_rec vars) ty
+  end
+
+let rigidify ty =
+  let vars = ref [] in
+  rigidify_rec vars ty;
+  unmark_type ty;
+  !vars
+
+let all_distinct_vars env vars =
+  let tyl = ref [] in
+  List.for_all
+    (fun ty ->
+      let ty = expand_head env ty in
+      if List.memq ty !tyl then false else
+      (tyl := ty :: !tyl; is_Tvar ty))
+    vars
+
+let matches env ty ty' =
+  let snap = snapshot () in
+  let vars = rigidify ty in
+  cleanup_abbrev ();
+  let ok =
+    try unify env ty ty'; all_distinct_vars env vars
+    with Unify _ -> false
+  in
+  backtrack snap;
+  ok
+
+
+                 (*********************************************)
+                 (*  Equivalence between parameterized types  *)
+                 (*********************************************)
+
+let expand_head_rigid env ty =
+  let old = !rigid_variants in
+  rigid_variants := true;
+  let ty' = expand_head env ty in
+  rigid_variants := old; ty'
+
+let normalize_subst subst =
+  if List.exists
+      (function {desc=Tlink _}, _ | _, {desc=Tlink _} -> true | _ -> false)
+      !subst
+  then subst := List.map (fun (t1,t2) -> repr t1, repr t2) !subst
+
+let rec eqtype rename type_pairs subst env t1 t2 =
+  if t1 == t2 then () else
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if t1 == t2 then () else
+
+  try
+    match (t1.desc, t2.desc) with
+      (Tvar _, Tvar _) when rename ->
+        begin try
+          normalize_subst subst;
+          if List.assq t1 !subst != t2 then raise (Unify [])
+        with Not_found ->
+          if List.exists (fun (_, t) -> t == t2) !subst then raise (Unify []);
+          subst := (t1, t2) :: !subst
+        end
+    | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
+        ()
+    | _ ->
+        let t1' = expand_head_rigid env t1 in
+        let t2' = expand_head_rigid env t2 in
+        (* Expansion may have changed the representative of the types... *)
+        let t1' = repr t1' and t2' = repr t2' in
+        if t1' == t2' then () else
+        begin try
+          TypePairs.find type_pairs (t1', t2')
+        with Not_found ->
+          TypePairs.add type_pairs (t1', t2') ();
+          match (t1'.desc, t2'.desc) with
+            (Tvar _, Tvar _) when rename ->
+              begin try
+                normalize_subst subst;
+                if List.assq t1' !subst != t2' then raise (Unify [])
+              with Not_found ->
+                if List.exists (fun (_, t) -> t == t2') !subst
+                then raise (Unify []);
+                subst := (t1', t2') :: !subst
+              end
+          | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2
+            || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
+              eqtype rename type_pairs subst env t1 t2;
+              eqtype rename type_pairs subst env u1 u2;
+          | (Ttuple tl1, Ttuple tl2) ->
+              eqtype_list rename type_pairs subst env tl1 tl2
+          | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
+                when Path.same p1 p2 ->
+              eqtype_list rename type_pairs subst env tl1 tl2
+          | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) ->
+              begin try
+                unify_package env (eqtype_list rename type_pairs subst env)
+                  t1'.level p1 n1 tl1 t2'.level p2 n2 tl2
+              with Not_found -> raise (Unify [])
+              end
+          | (Tvariant row1, Tvariant row2) ->
+              eqtype_row rename type_pairs subst env row1 row2
+          | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) ->
+              eqtype_fields rename type_pairs subst env fi1 fi2
+          | (Tfield _, Tfield _) ->       (* Actually unused *)
+              eqtype_fields rename type_pairs subst env t1' t2'
+          | (Tnil, Tnil) ->
+              ()
+          | (Tpoly (t1, []), Tpoly (t2, [])) ->
+              eqtype rename type_pairs subst env t1 t2
+          | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+              enter_poly env univar_pairs t1 tl1 t2 tl2
+                (eqtype rename type_pairs subst env)
+          | (Tunivar _, Tunivar _) ->
+              unify_univar t1' t2' !univar_pairs
+          | (_, _) ->
+              raise (Unify [])
+        end
+  with Unify trace ->  raise ( Unify (Trace.diff t1 t2 :: trace) )
+
+and eqtype_list rename type_pairs subst env tl1 tl2 =
+  if List.length tl1 <> List.length tl2 then
+    raise (Unify []);
+  List.iter2 (eqtype rename type_pairs subst env) tl1 tl2
+
+and eqtype_fields rename type_pairs subst env ty1 ty2 =
+  let (fields1, rest1) = flatten_fields ty1 in
+  let (fields2, rest2) = flatten_fields ty2 in
+  (* First check if same row => already equal *)
+  let same_row =
+    rest1 == rest2 || TypePairs.mem type_pairs (rest1,rest2) ||
+    (rename && List.mem (rest1, rest2) !subst)
+  in
+  if same_row then () else
+  (* Try expansion, needed when called from Includecore.type_manifest *)
+  match expand_head_rigid env rest2 with
+    {desc=Tobject(ty2,_)} -> eqtype_fields rename type_pairs subst env ty1 ty2
+  | _ ->
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  eqtype rename type_pairs subst env rest1 rest2;
+  if (miss1 <> []) || (miss2 <> []) then raise (Unify []);
+  List.iter
+    (function (n, k1, t1, k2, t2) ->
+       eqtype_kind k1 k2;
+       try eqtype rename type_pairs subst env t1 t2 with Unify trace ->
+         let e = Trace.diff
+             (newty (Tfield(n, k1, t1, rest2)))
+             (newty (Tfield(n, k2, t2, rest2))) in
+         raise ( Unify ( e :: trace ) )
+    )
+    pairs
+
+and eqtype_kind k1 k2 =
+  let k1 = field_kind_repr k1 in
+  let k2 = field_kind_repr k2 in
+  match k1, k2 with
+    (Fvar _, Fvar _)
+  | (Fpresent, Fpresent) -> ()
+  | _                    -> raise (Unify [])
+
+and eqtype_row rename type_pairs subst env row1 row2 =
+  (* Try expansion, needed when called from Includecore.type_manifest *)
+  match expand_head_rigid env (row_more row2) with
+    {desc=Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2
+  | _ ->
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
+  if row1.row_closed <> row2.row_closed
+  || not row1.row_closed && (r1 <> [] || r2 <> [])
+  || filter_row_fields false (r1 @ r2) <> []
+  then raise (Unify []);
+  if not (static_row row1) then
+    eqtype rename type_pairs subst env row1.row_more row2.row_more;
+  List.iter
+    (fun (_,f1,f2) ->
+      match row_field_repr f1, row_field_repr f2 with
+        Rpresent(Some t1), Rpresent(Some t2) ->
+          eqtype rename type_pairs subst env t1 t2
+      | Reither(c1, [], _, _), Reither(c2, [], _, _) when c1 = c2 ->
+          ()
+      | Reither(c1, t1::tl1, _, _), Reither(c2, t2::tl2, _, _) when c1 = c2 ->
+          eqtype rename type_pairs subst env t1 t2;
+          if List.length tl1 = List.length tl2 then
+            (* if same length allow different types (meaning?) *)
+            List.iter2 (eqtype rename type_pairs subst env) tl1 tl2
+          else begin
+            (* otherwise everything must be equal *)
+            List.iter (eqtype rename type_pairs subst env t1) tl2;
+            List.iter (fun t1 -> eqtype rename type_pairs subst env t1 t2) tl1
+          end
+      | Rpresent None, Rpresent None -> ()
+      | Rabsent, Rabsent -> ()
+      | _ -> raise (Unify []))
+    pairs
+
+(* Must empty univar_pairs first *)
+let eqtype_list rename type_pairs subst env tl1 tl2 =
+  univar_pairs := [];
+  let snap = Btype.snapshot () in
+  Misc.try_finally
+    ~always:(fun () -> backtrack snap)
+    (fun () -> eqtype_list rename type_pairs subst env tl1 tl2)
+
+let eqtype rename type_pairs subst env t1 t2 =
+  eqtype_list rename type_pairs subst env [t1] [t2]
+
+(* Two modes: with or without renaming of variables *)
+let equal env rename tyl1 tyl2 =
+  try
+    eqtype_list rename (TypePairs.create 11) (ref []) env tyl1 tyl2; true
+  with
+    Unify _ -> false
+
+
+                          (*************************)
+                          (*  Class type matching  *)
+                          (*************************)
+
+
+type class_match_failure =
+    CM_Virtual_class
+  | CM_Parameter_arity_mismatch of int * int
+  | CM_Type_parameter_mismatch of Env.t * Unification_trace.t
+  | CM_Class_type_mismatch of Env.t * class_type * class_type
+  | CM_Parameter_mismatch of Env.t * Unification_trace.t
+  | CM_Val_type_mismatch of string * Env.t * Unification_trace.t
+  | CM_Meth_type_mismatch of string * Env.t * Unification_trace.t
+  | CM_Non_mutable_value of string
+  | CM_Non_concrete_value of string
+  | CM_Missing_value of string
+  | CM_Missing_method of string
+  | CM_Hide_public of string
+  | CM_Hide_virtual of string * string
+  | CM_Public_method of string
+  | CM_Private_method of string
+  | CM_Virtual_method of string
+
+exception Failure of class_match_failure list
+
+let rec moregen_clty trace type_pairs env cty1 cty2 =
+  try
+    match cty1, cty2 with
+      Cty_constr (_, _, cty1), _ ->
+        moregen_clty true type_pairs env cty1 cty2
+    | _, Cty_constr (_, _, cty2) ->
+        moregen_clty true type_pairs env cty1 cty2
+    | Cty_arrow (l1, ty1, cty1'), Cty_arrow (l2, ty2, cty2') when l1 = l2 ->
+        begin try moregen true type_pairs env ty1 ty2 with Unify trace ->
+          raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)])
+        end;
+        moregen_clty false type_pairs env cty1' cty2'
+    | Cty_signature sign1, Cty_signature sign2 ->
+        let ty1 = object_fields (repr sign1.csig_self) in
+        let ty2 = object_fields (repr sign2.csig_self) in
+        let (fields1, _rest1) = flatten_fields ty1
+        and (fields2, _rest2) = flatten_fields ty2 in
+        let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in
+        List.iter
+          (fun (lab, _k1, t1, _k2, t2) ->
+            begin try moregen true type_pairs env t1 t2 with Unify trace ->
+              raise (Failure [CM_Meth_type_mismatch
+                                 (lab, env, expand_trace env trace)])
+           end)
+        pairs;
+      Vars.iter
+        (fun lab (_mut, _v, ty) ->
+           let (_mut', _v', ty') = Vars.find lab sign1.csig_vars in
+           try moregen true type_pairs env ty' ty with Unify trace ->
+             raise (Failure [CM_Val_type_mismatch
+                                (lab, env, expand_trace env trace)]))
+        sign2.csig_vars
+  | _ ->
+      raise (Failure [])
+  with
+    Failure error when trace || error = [] ->
+      raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error))
+
+let match_class_types ?(trace=true) env pat_sch subj_sch =
+  let type_pairs = TypePairs.create 53 in
+  let old_level = !current_level in
+  current_level := generic_level - 1;
+  (*
+     Generic variables are first duplicated with [instance].  So,
+     their levels are lowered to [generic_level - 1].  The subject is
+     then copied with [duplicate_type].  That way, its levels won't be
+     changed.
+  *)
+  let (_, subj_inst) = instance_class [] subj_sch in
+  let subj = duplicate_class_type subj_inst in
+  current_level := generic_level;
+  (* Duplicate generic variables *)
+  let (_, patt) = instance_class [] pat_sch in
+  let res =
+    let sign1 = signature_of_class_type patt in
+    let sign2 = signature_of_class_type subj in
+    let t1 = repr sign1.csig_self in
+    let t2 = repr sign2.csig_self in
+    TypePairs.add type_pairs (t1, t2) ();
+    let (fields1, rest1) = flatten_fields (object_fields t1)
+    and (fields2, rest2) = flatten_fields (object_fields t2) in
+    let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+    let error =
+      List.fold_right
+        (fun (lab, k, _) err ->
+           let err =
+             let k = field_kind_repr k in
+             begin match k with
+               Fvar r -> set_kind r Fabsent; err
+             | _      -> CM_Hide_public lab::err
+             end
+           in
+           if lab = dummy_method || Concr.mem lab sign1.csig_concr then err
+           else CM_Hide_virtual ("method", lab) :: err)
+        miss1 []
+    in
+    let missing_method = List.map (fun (m, _, _) -> m) miss2 in
+    let error =
+      (List.map (fun m -> CM_Missing_method m) missing_method) @ error
+    in
+    (* Always succeeds *)
+    moregen true type_pairs env rest1 rest2;
+    let error =
+      List.fold_right
+        (fun (lab, k1, _t1, k2, _t2) err ->
+           try moregen_kind k1 k2; err with
+             Unify _ -> CM_Public_method lab::err)
+        pairs error
+    in
+    let error =
+      Vars.fold
+        (fun lab (mut, vr, _ty) err ->
+          try
+            let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in
+            if mut = Mutable && mut' <> Mutable then
+              CM_Non_mutable_value lab::err
+            else if vr = Concrete && vr' <> Concrete then
+              CM_Non_concrete_value lab::err
+            else
+              err
+          with Not_found ->
+            CM_Missing_value lab::err)
+        sign2.csig_vars error
+    in
+    let error =
+      Vars.fold
+        (fun lab (_,vr,_) err ->
+          if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then
+            CM_Hide_virtual ("instance variable", lab) :: err
+          else err)
+        sign1.csig_vars error
+    in
+    let error =
+      List.fold_right
+        (fun e l ->
+           if List.mem e missing_method then l else CM_Virtual_method e::l)
+        (Concr.elements (Concr.diff sign2.csig_concr sign1.csig_concr))
+        error
+    in
+    match error with
+      [] ->
+        begin try
+          moregen_clty trace type_pairs env patt subj;
+          []
+        with
+          Failure r -> r
+        end
+    | error ->
+        CM_Class_type_mismatch (env, patt, subj)::error
+  in
+  current_level := old_level;
+  res
+
+let rec equal_clty trace type_pairs subst env cty1 cty2 =
+  try
+    match cty1, cty2 with
+      Cty_constr (_, _, cty1), Cty_constr (_, _, cty2) ->
+        equal_clty true type_pairs subst env cty1 cty2
+    | Cty_constr (_, _, cty1), _ ->
+        equal_clty true type_pairs subst env cty1 cty2
+    | _, Cty_constr (_, _, cty2) ->
+        equal_clty true type_pairs subst env cty1 cty2
+    | Cty_arrow (l1, ty1, cty1'), Cty_arrow (l2, ty2, cty2') when l1 = l2 ->
+        begin try eqtype true type_pairs subst env ty1 ty2 with Unify trace ->
+          raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)])
+        end;
+        equal_clty false type_pairs subst env cty1' cty2'
+    | Cty_signature sign1, Cty_signature sign2 ->
+        let ty1 = object_fields (repr sign1.csig_self) in
+        let ty2 = object_fields (repr sign2.csig_self) in
+        let (fields1, _rest1) = flatten_fields ty1
+        and (fields2, _rest2) = flatten_fields ty2 in
+        let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in
+        List.iter
+          (fun (lab, _k1, t1, _k2, t2) ->
+             begin try eqtype true type_pairs subst env t1 t2 with
+               Unify trace ->
+                 raise (Failure [CM_Meth_type_mismatch
+                                    (lab, env, expand_trace env trace)])
+             end)
+          pairs;
+        Vars.iter
+          (fun lab (_, _, ty) ->
+             let (_, _, ty') = Vars.find lab sign1.csig_vars in
+             try eqtype true type_pairs subst env ty' ty with Unify trace ->
+               raise (Failure [CM_Val_type_mismatch
+                                  (lab, env, expand_trace env trace)]))
+          sign2.csig_vars
+    | _ ->
+        raise
+          (Failure (if trace then []
+                    else [CM_Class_type_mismatch (env, cty1, cty2)]))
+  with
+    Failure error when trace ->
+      raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error))
+
+let match_class_declarations env patt_params patt_type subj_params subj_type =
+  let type_pairs = TypePairs.create 53 in
+  let subst = ref [] in
+  let sign1 = signature_of_class_type patt_type in
+  let sign2 = signature_of_class_type subj_type in
+  let t1 = repr sign1.csig_self in
+  let t2 = repr sign2.csig_self in
+  TypePairs.add type_pairs (t1, t2) ();
+  let (fields1, rest1) = flatten_fields (object_fields t1)
+  and (fields2, rest2) = flatten_fields (object_fields t2) in
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  let error =
+    List.fold_right
+      (fun (lab, k, _) err ->
+        let err =
+          let k = field_kind_repr k in
+          begin match k with
+            Fvar _ -> err
+          | _      -> CM_Hide_public lab::err
+          end
+        in
+        if Concr.mem lab sign1.csig_concr then err
+        else CM_Hide_virtual ("method", lab) :: err)
+      miss1 []
+  in
+  let missing_method = List.map (fun (m, _, _) -> m) miss2 in
+  let error =
+    (List.map (fun m -> CM_Missing_method m) missing_method) @ error
+  in
+  (* Always succeeds *)
+  eqtype true type_pairs subst env rest1 rest2;
+  let error =
+    List.fold_right
+      (fun (lab, k1, _t1, k2, _t2) err ->
+        let k1 = field_kind_repr k1 in
+        let k2 = field_kind_repr k2 in
+        match k1, k2 with
+          (Fvar _, Fvar _)
+        | (Fpresent, Fpresent) -> err
+        | (Fvar _, Fpresent)   -> CM_Private_method lab::err
+        | (Fpresent, Fvar _)  -> CM_Public_method lab::err
+        | _                    -> assert false)
+      pairs error
+  in
+  let error =
+    Vars.fold
+      (fun lab (mut, vr, _ty) err ->
+         try
+           let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in
+           if mut = Mutable && mut' <> Mutable then
+             CM_Non_mutable_value lab::err
+           else if vr = Concrete && vr' <> Concrete then
+             CM_Non_concrete_value lab::err
+           else
+             err
+         with Not_found ->
+           CM_Missing_value lab::err)
+      sign2.csig_vars error
+  in
+  let error =
+    Vars.fold
+      (fun lab (_,vr,_) err ->
+        if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then
+          CM_Hide_virtual ("instance variable", lab) :: err
+        else err)
+      sign1.csig_vars error
+  in
+  let error =
+    List.fold_right
+      (fun e l ->
+        if List.mem e missing_method then l else CM_Virtual_method e::l)
+      (Concr.elements (Concr.diff sign2.csig_concr sign1.csig_concr))
+      error
+  in
+  match error with
+    [] ->
+      begin try
+        let lp = List.length patt_params in
+        let ls = List.length subj_params in
+        if lp  <> ls then
+          raise (Failure [CM_Parameter_arity_mismatch (lp, ls)]);
+        List.iter2 (fun p s ->
+          try eqtype true type_pairs subst env p s with Unify trace ->
+            raise (Failure [CM_Type_parameter_mismatch
+                               (env, expand_trace env trace)]))
+          patt_params subj_params;
+     (* old code: equal_clty false type_pairs subst env patt_type subj_type; *)
+        equal_clty false type_pairs subst env
+          (Cty_signature sign1) (Cty_signature sign2);
+        (* Use moregeneral for class parameters, need to recheck everything to
+           keeps relationships (PR#4824) *)
+        let clty_params =
+          List.fold_right (fun ty cty -> Cty_arrow (Labelled "*",ty,cty)) in
+        match_class_types ~trace:false env
+          (clty_params patt_params patt_type)
+          (clty_params subj_params subj_type)
+      with
+        Failure r -> r
+      end
+  | error ->
+      error
+
+
+                              (***************)
+                              (*  Subtyping  *)
+                              (***************)
+
+
+(**** Build a subtype of a given type. ****)
+
+(* build_subtype:
+   [visited] traces traversed object and variant types
+   [loops] is a mapping from variables to variables, to reproduce
+     positive loops in a class type
+   [posi] true if the current variance is positive
+   [level] number of expansions/enlargement allowed on this branch *)
+
+let warn = ref false  (* whether double coercion might do better *)
+let pred_expand n = if n mod 2 = 0 && n > 0 then pred n else n
+let pred_enlarge n = if n mod 2 = 1 then pred n else n
+
+type change = Unchanged | Equiv | Changed
+let collect l = List.fold_left (fun c1 (_, c2) -> max c1 c2) Unchanged l
+
+let rec filter_visited = function
+    [] -> []
+  | {desc=Tobject _|Tvariant _} :: _ as l -> l
+  | _ :: l -> filter_visited l
+
+let memq_warn t visited =
+  if List.memq t visited then (warn := true; true) else false
+
+let find_cltype_for_path env p =
+  let cl_abbr = Env.find_hash_type p env in
+  match cl_abbr.type_manifest with
+    Some ty ->
+      begin match (repr ty).desc with
+        Tobject(_,{contents=Some(p',_)}) when Path.same p p' -> cl_abbr, ty
+      | _ -> raise Not_found
+      end
+  | None -> assert false
+
+let has_constr_row' env t =
+  has_constr_row (expand_abbrev env t)
+
+let rec build_subtype env visited loops posi level t =
+  let t = repr t in
+  match t.desc with
+    Tvar _ ->
+      if posi then
+        try
+          let t' = List.assq t loops in
+          warn := true;
+          (t', Equiv)
+        with Not_found ->
+          (t, Unchanged)
+      else
+        (t, Unchanged)
+  | Tarrow(l, t1, t2, _) ->
+      if memq_warn t visited then (t, Unchanged) else
+      let visited = t :: visited in
+      let (t1', c1) = build_subtype env visited loops (not posi) level t1 in
+      let (t2', c2) = build_subtype env visited loops posi level t2 in
+      let c = max c1 c2 in
+      if c > Unchanged then (newty (Tarrow(l, t1', t2', Cok)), c)
+      else (t, Unchanged)
+  | Ttuple tlist ->
+      if memq_warn t visited then (t, Unchanged) else
+      let visited = t :: visited in
+      let tlist' =
+        List.map (build_subtype env visited loops posi level) tlist
+      in
+      let c = collect tlist' in
+      if c > Unchanged then (newty (Ttuple (List.map fst tlist')), c)
+      else (t, Unchanged)
+  | Tconstr(p, tl, abbrev)
+    when level > 0 && generic_abbrev env p && safe_abbrev env t
+    && not (has_constr_row' env t) ->
+      let t' = repr (expand_abbrev env t) in
+      let level' = pred_expand level in
+      begin try match t'.desc with
+        Tobject _ when posi && not (opened_object t') ->
+          let cl_abbr, body = find_cltype_for_path env p in
+          let ty =
+            subst env !current_level Public abbrev None
+              cl_abbr.type_params tl body in
+          let ty = repr ty in
+          let ty1, tl1 =
+            match ty.desc with
+              Tobject(ty1,{contents=Some(p',tl1)}) when Path.same p p' ->
+                ty1, tl1
+            | _ -> raise Not_found
+          in
+          (* Fix PR#4505: do not set ty to Tvar when it appears in tl1,
+             as this occurrence might break the occur check.
+             XXX not clear whether this correct anyway... *)
+          if List.exists (deep_occur ty) tl1 then raise Not_found;
+          ty.desc <- Tvar None;
+          let t'' = newvar () in
+          let loops = (ty, t'') :: loops in
+          (* May discard [visited] as level is going down *)
+          let (ty1', c) =
+            build_subtype env [t'] loops posi (pred_enlarge level') ty1 in
+          assert (is_Tvar t'');
+          let nm =
+            if c > Equiv || deep_occur ty ty1' then None else Some(p,tl1) in
+          t''.desc <- Tobject (ty1', ref nm);
+          (try unify_var env ty t with Unify _ -> assert false);
+          (t'', Changed)
+      | _ -> raise Not_found
+      with Not_found ->
+        let (t'',c) = build_subtype env visited loops posi level' t' in
+        if c > Unchanged then (t'',c)
+        else (t, Unchanged)
+      end
+  | Tconstr(p, tl, _abbrev) ->
+      (* Must check recursion on constructors, since we do not always
+         expand them *)
+      if memq_warn t visited then (t, Unchanged) else
+      let visited = t :: visited in
+      begin try
+        let decl = Env.find_type p env in
+        if level = 0 && generic_abbrev env p && safe_abbrev env t
+        && not (has_constr_row' env t)
+        then warn := true;
+        let tl' =
+          List.map2
+            (fun v t ->
+              let (co,cn) = Variance.get_upper v in
+              if cn then
+                if co then (t, Unchanged)
+                else build_subtype env visited loops (not posi) level t
+              else
+                if co then build_subtype env visited loops posi level t
+                else (newvar(), Changed))
+            decl.type_variance tl
+        in
+        let c = collect tl' in
+        if c > Unchanged then (newconstr p (List.map fst tl'), c)
+        else (t, Unchanged)
+      with Not_found ->
+        (t, Unchanged)
+      end
+  | Tvariant row ->
+      let row = row_repr row in
+      if memq_warn t visited || not (static_row row) then (t, Unchanged) else
+      let level' = pred_enlarge level in
+      let visited =
+        t :: if level' < level then [] else filter_visited visited in
+      let fields = filter_row_fields false row.row_fields in
+      let fields =
+        List.map
+          (fun (l,f as orig) -> match row_field_repr f with
+            Rpresent None ->
+              if posi then
+                (l, Reither(true, [], false, ref None)), Unchanged
+              else
+                orig, Unchanged
+          | Rpresent(Some t) ->
+              let (t', c) = build_subtype env visited loops posi level' t in
+              let f =
+                if posi && level > 0
+                then Reither(false, [t'], false, ref None)
+                else Rpresent(Some t')
+              in (l, f), c
+          | _ -> assert false)
+          fields
+      in
+      let c = collect fields in
+      let row =
+        { row_fields = List.map fst fields; row_more = newvar();
+          row_bound = (); row_closed = posi; row_fixed = None;
+          row_name = if c > Unchanged then None else row.row_name }
+      in
+      (newty (Tvariant row), Changed)
+  | Tobject (t1, _) ->
+      if memq_warn t visited || opened_object t1 then (t, Unchanged) else
+      let level' = pred_enlarge level in
+      let visited =
+        t :: if level' < level then [] else filter_visited visited in
+      let (t1', c) = build_subtype env visited loops posi level' t1 in
+      if c > Unchanged then (newty (Tobject (t1', ref None)), c)
+      else (t, Unchanged)
+  | Tfield(s, _, t1, t2) (* Always present *) ->
+      let (t1', c1) = build_subtype env visited loops posi level t1 in
+      let (t2', c2) = build_subtype env visited loops posi level t2 in
+      let c = max c1 c2 in
+      if c > Unchanged then (newty (Tfield(s, Fpresent, t1', t2')), c)
+      else (t, Unchanged)
+  | Tnil ->
+      if posi then
+        let v = newvar () in
+        (v, Changed)
+      else begin
+        warn := true;
+        (t, Unchanged)
+      end
+  | Tsubst _ | Tlink _ ->
+      assert false
+  | Tpoly(t1, tl) ->
+      let (t1', c) = build_subtype env visited loops posi level t1 in
+      if c > Unchanged then (newty (Tpoly(t1', tl)), c)
+      else (t, Unchanged)
+  | Tunivar _ | Tpackage _ ->
+      (t, Unchanged)
+
+let enlarge_type env ty =
+  warn := false;
+  (* [level = 4] allows 2 expansions involving objects/variants *)
+  let (ty', _) = build_subtype env [] [] true 4 ty in
+  (ty', !warn)
+
+(**** Check whether a type is a subtype of another type. ****)
+
+(*
+    During the traversal, a trace of visited types is maintained. It
+    is printed in case of error.
+    Constraints (pairs of types that must be equals) are accumulated
+    rather than being enforced straight. Indeed, the result would
+    otherwise depend on the order in which these constraints are
+    enforced.
+    A function enforcing these constraints is returned. That way, type
+    variables can be bound to their actual values before this function
+    is called (see Typecore).
+    Only well-defined abbreviations are expanded (hence the tests
+    [generic_abbrev ...]).
+*)
+
+let subtypes = TypePairs.create 17
+
+let subtype_error env trace =
+  raise (Subtype (expand_trace env (List.rev trace), []))
+
+let rec subtype_rec env trace t1 t2 cstrs =
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if t1 == t2 then cstrs else
+
+  begin try
+    TypePairs.find subtypes (t1, t2);
+    cstrs
+  with Not_found ->
+    TypePairs.add subtypes (t1, t2) ();
+    match (t1.desc, t2.desc) with
+      (Tvar _, _) | (_, Tvar _) ->
+        (trace, t1, t2, !univar_pairs)::cstrs
+    | (Tarrow(l1, t1, u1, _), Tarrow(l2, t2, u2, _)) when l1 = l2
+      || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
+        let cstrs = subtype_rec env (Trace.diff t2 t1::trace) t2 t1 cstrs in
+        subtype_rec env (Trace.diff u1 u2::trace) u1 u2 cstrs
+    | (Ttuple tl1, Ttuple tl2) ->
+        subtype_list env trace tl1 tl2 cstrs
+    | (Tconstr(p1, [], _), Tconstr(p2, [], _)) when Path.same p1 p2 ->
+        cstrs
+    | (Tconstr(p1, _tl1, _abbrev1), _)
+      when generic_abbrev env p1 && safe_abbrev env t1 ->
+        subtype_rec env trace (expand_abbrev env t1) t2 cstrs
+    | (_, Tconstr(p2, _tl2, _abbrev2))
+      when generic_abbrev env p2 && safe_abbrev env t2 ->
+        subtype_rec env trace t1 (expand_abbrev env t2) cstrs
+    | (Tconstr(p1, tl1, _), Tconstr(p2, tl2, _)) when Path.same p1 p2 ->
+        begin try
+          let decl = Env.find_type p1 env in
+          List.fold_left2
+            (fun cstrs v (t1, t2) ->
+              let (co, cn) = Variance.get_upper v in
+              if co then
+                if cn then
+                  (trace, newty2 t1.level (Ttuple[t1]),
+                   newty2 t2.level (Ttuple[t2]), !univar_pairs) :: cstrs
+                else subtype_rec env (Trace.diff t1 t2::trace) t1 t2 cstrs
+              else
+                if cn then subtype_rec env (Trace.diff t2 t1::trace) t2 t1 cstrs
+                else cstrs)
+            cstrs decl.type_variance (List.combine tl1 tl2)
+        with Not_found ->
+          (trace, t1, t2, !univar_pairs)::cstrs
+        end
+    | (Tconstr(p1, _, _), _) when generic_private_abbrev env p1 ->
+        subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs
+(*  | (_, Tconstr(p2, _, _)) when generic_private_abbrev false env p2 ->
+        subtype_rec env trace t1 (expand_abbrev_opt env t2) cstrs *)
+    | (Tobject (f1, _), Tobject (f2, _))
+      when is_Tvar (object_row f1) && is_Tvar (object_row f2) ->
+        (* Same row variable implies same object. *)
+        (trace, t1, t2, !univar_pairs)::cstrs
+    | (Tobject (f1, _), Tobject (f2, _)) ->
+        subtype_fields env trace f1 f2 cstrs
+    | (Tvariant row1, Tvariant row2) ->
+        begin try
+          subtype_row env trace row1 row2 cstrs
+        with Exit ->
+          (trace, t1, t2, !univar_pairs)::cstrs
+        end
+    | (Tpoly (u1, []), Tpoly (u2, [])) ->
+        subtype_rec env trace u1 u2 cstrs
+    | (Tpoly (u1, tl1), Tpoly (u2, [])) ->
+        let _, u1' = instance_poly false tl1 u1 in
+        subtype_rec env trace u1' u2 cstrs
+    | (Tpoly (u1, tl1), Tpoly (u2,tl2)) ->
+        begin try
+          enter_poly env univar_pairs u1 tl1 u2 tl2
+            (fun t1 t2 -> subtype_rec env trace t1 t2 cstrs)
+        with Unify _ ->
+          (trace, t1, t2, !univar_pairs)::cstrs
+        end
+    | (Tpackage (p1, nl1, tl1), Tpackage (p2, nl2, tl2)) ->
+        begin try
+          let ntl1 = complete_type_list env nl2 t1.level (Mty_ident p1) nl1 tl1
+          and ntl2 = complete_type_list env nl1 t2.level (Mty_ident p2) nl2 tl2
+              ~allow_absent:true in
+          let cstrs' =
+            List.map
+              (fun (n2,t2) -> (trace, List.assoc n2 ntl1, t2, !univar_pairs))
+              ntl2
+          in
+          if eq_package_path env p1 p2 then cstrs' @ cstrs
+          else begin
+            (* need to check module subtyping *)
+            let snap = Btype.snapshot () in
+            try
+              List.iter (fun (_, t1, t2, _) -> unify env t1 t2) cstrs';
+              if !package_subtype env p1 nl1 tl1 p2 nl2 tl2
+              then (Btype.backtrack snap; cstrs' @ cstrs)
+              else raise (Unify [])
+            with Unify _ ->
+              Btype.backtrack snap; raise Not_found
+          end
+        with Not_found ->
+          (trace, t1, t2, !univar_pairs)::cstrs
+        end
+    | (_, _) ->
+        (trace, t1, t2, !univar_pairs)::cstrs
+  end
+
+and subtype_list env trace tl1 tl2 cstrs =
+  if List.length tl1 <> List.length tl2 then
+    subtype_error env trace;
+  List.fold_left2
+    (fun cstrs t1 t2 -> subtype_rec env (Trace.diff t1 t2::trace) t1 t2 cstrs)
+    cstrs tl1 tl2
+
+and subtype_fields env trace ty1 ty2 cstrs =
+  (* Assume that either rest1 or rest2 is not Tvar *)
+  let (fields1, rest1) = flatten_fields ty1 in
+  let (fields2, rest2) = flatten_fields ty2 in
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  let cstrs =
+    if rest2.desc = Tnil then cstrs else
+    if miss1 = [] then
+      subtype_rec env (Trace.diff rest1 rest2::trace) rest1 rest2 cstrs
+    else
+      (trace, build_fields (repr ty1).level miss1 rest1, rest2,
+       !univar_pairs) :: cstrs
+  in
+  let cstrs =
+    if miss2 = [] then cstrs else
+    (trace, rest1, build_fields (repr ty2).level miss2 (newvar ()),
+     !univar_pairs) :: cstrs
+  in
+  List.fold_left
+    (fun cstrs (_, _k1, t1, _k2, t2) ->
+      (* These fields are always present *)
+      subtype_rec env (Trace.diff t1 t2::trace) t1 t2 cstrs)
+    cstrs pairs
+
+and subtype_row env trace row1 row2 cstrs =
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let r1, r2, pairs =
+    merge_row_fields row1.row_fields row2.row_fields in
+  let r1 = if row2.row_closed then filter_row_fields false r1 else r1 in
+  let r2 = if row1.row_closed then filter_row_fields false r2 else r2 in
+  let more1 = repr row1.row_more
+  and more2 = repr row2.row_more in
+  match more1.desc, more2.desc with
+    Tconstr(p1,_,_), Tconstr(p2,_,_) when Path.same p1 p2 ->
+      subtype_rec env (Trace.diff more1 more2::trace) more1 more2 cstrs
+  | (Tvar _|Tconstr _|Tnil), (Tvar _|Tconstr _|Tnil)
+    when row1.row_closed && r1 = [] ->
+      List.fold_left
+        (fun cstrs (_,f1,f2) ->
+          match row_field_repr f1, row_field_repr f2 with
+            (Rpresent None|Reither(true,_,_,_)), Rpresent None ->
+              cstrs
+          | Rpresent(Some t1), Rpresent(Some t2) ->
+              subtype_rec env (Trace.diff t1 t2::trace) t1 t2 cstrs
+          | Reither(false, t1::_, _, _), Rpresent(Some t2) ->
+              subtype_rec env (Trace.diff t1 t2::trace) t1 t2 cstrs
+          | Rabsent, _ -> cstrs
+          | _ -> raise Exit)
+        cstrs pairs
+  | Tunivar _, Tunivar _
+    when row1.row_closed = row2.row_closed && r1 = [] && r2 = [] ->
+      let cstrs =
+        subtype_rec env (Trace.diff more1 more2::trace) more1 more2 cstrs in
+      List.fold_left
+        (fun cstrs (_,f1,f2) ->
+          match row_field_repr f1, row_field_repr f2 with
+            Rpresent None, Rpresent None
+          | Reither(true,[],_,_), Reither(true,[],_,_)
+          | Rabsent, Rabsent ->
+              cstrs
+          | Rpresent(Some t1), Rpresent(Some t2)
+          | Reither(false,[t1],_,_), Reither(false,[t2],_,_) ->
+              subtype_rec env (Trace.diff t1 t2::trace) t1 t2 cstrs
+          | _ -> raise Exit)
+        cstrs pairs
+  | _ ->
+      raise Exit
+
+let subtype env ty1 ty2 =
+  TypePairs.clear subtypes;
+  univar_pairs := [];
+  (* Build constraint set. *)
+  let cstrs = subtype_rec env [Trace.diff ty1 ty2] ty1 ty2 [] in
+  TypePairs.clear subtypes;
+  (* Enforce constraints. *)
+  function () ->
+    List.iter
+      (function (trace0, t1, t2, pairs) ->
+         try unify_pairs (ref env) t1 t2 pairs with Unify trace ->
+           raise (Subtype (expand_trace env (List.rev trace0),
+                           List.tl trace)))
+      (List.rev cstrs)
+
+                              (*******************)
+                              (*  Miscellaneous  *)
+                              (*******************)
+
+(* Utility for printing. The resulting type is not used in computation. *)
+let rec unalias_object ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tfield (s, k, t1, t2) ->
+      newty2 ty.level (Tfield (s, k, t1, unalias_object t2))
+  | Tvar _ | Tnil ->
+      newty2 ty.level ty.desc
+  | Tunivar _ ->
+      ty
+  | Tconstr _ ->
+      newvar2 ty.level
+  | _ ->
+      assert false
+
+let unalias ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tvar _ | Tunivar _ ->
+      ty
+  | Tvariant row ->
+      let row = row_repr row in
+      let more = row.row_more in
+      newty2 ty.level
+        (Tvariant {row with row_more = newty2 more.level more.desc})
+  | Tobject (ty, nm) ->
+      newty2 ty.level (Tobject (unalias_object ty, nm))
+  | _ ->
+      newty2 ty.level ty.desc
+
+(* Return the arity (as for curried functions) of the given type. *)
+let rec arity ty =
+  match (repr ty).desc with
+    Tarrow(_, _t1, t2, _) -> 1 + arity t2
+  | _ -> 0
+
+(* Check whether an abbreviation expands to itself. *)
+let cyclic_abbrev env id ty =
+  let rec check_cycle seen ty =
+    let ty = repr ty in
+    match ty.desc with
+      Tconstr (p, _tl, _abbrev) ->
+        p = Path.Pident id || List.memq ty seen ||
+        begin try
+          check_cycle (ty :: seen) (expand_abbrev_opt env ty)
+        with
+          Cannot_expand -> false
+        | Unify _ -> true
+        end
+    | _ ->
+        false
+  in check_cycle [] ty
+
+(* Check for non-generalizable type variables *)
+exception Non_closed0
+let visited = ref TypeSet.empty
+
+let rec closed_schema_rec env ty =
+  let ty = repr ty in
+  if TypeSet.mem ty !visited then () else begin
+    visited := TypeSet.add ty !visited;
+    match ty.desc with
+      Tvar _ when ty.level <> generic_level ->
+        raise Non_closed0
+    | Tconstr _ ->
+        let old = !visited in
+        begin try iter_type_expr (closed_schema_rec env) ty
+        with Non_closed0 -> try
+          visited := old;
+          closed_schema_rec env (try_expand_head try_expand_safe env ty)
+        with Cannot_expand ->
+          raise Non_closed0
+        end
+    | Tfield(_, kind, t1, t2) ->
+        if field_kind_repr kind = Fpresent then
+          closed_schema_rec env t1;
+        closed_schema_rec env t2
+    | Tvariant row ->
+        let row = row_repr row in
+        iter_row (closed_schema_rec env) row;
+        if not (static_row row) then closed_schema_rec env row.row_more
+    | _ ->
+        iter_type_expr (closed_schema_rec env) ty
+  end
+
+(* Return whether all variables of type [ty] are generic. *)
+let closed_schema env ty =
+  visited := TypeSet.empty;
+  try
+    closed_schema_rec env ty;
+    visited := TypeSet.empty;
+    true
+  with Non_closed0 ->
+    visited := TypeSet.empty;
+    false
+
+(* Normalize a type before printing, saving... *)
+(* Cannot use mark_type because deep_occur uses it too *)
+let rec normalize_type_rec visited ty =
+  let ty = repr ty in
+  if not (TypeSet.mem ty !visited) then begin
+    visited := TypeSet.add ty !visited;
+    let tm = row_of_type ty in
+    begin if not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm then
+      match tm.desc with (* PR#7348 *)
+        Tconstr (Path.Pdot(m,i), tl, _abbrev) ->
+          let i' = String.sub i 0 (String.length i - 4) in
+          set_type_desc ty (Tconstr(Path.Pdot(m,i'), tl, ref Mnil))
+      | _ -> assert false
+    else match ty.desc with
+    | Tvariant row ->
+      let row = row_repr row in
+      let fields = List.map
+          (fun (l,f0) ->
+            let f = row_field_repr f0 in l,
+            match f with Reither(b, ty::(_::_ as tyl), m, e) ->
+              let tyl' =
+                List.fold_left
+                  (fun tyl ty ->
+                    if List.exists
+                        (fun ty' -> equal Env.empty false [ty] [ty']) tyl
+                    then tyl else ty::tyl)
+                  [ty] tyl
+              in
+              if f != f0 || List.length tyl' < List.length tyl then
+                Reither(b, List.rev tyl', m, e)
+              else f
+            | _ -> f)
+          row.row_fields in
+      let fields =
+        List.sort (fun (p,_) (q,_) -> compare p q)
+          (List.filter (fun (_,fi) -> fi <> Rabsent) fields) in
+      set_type_desc ty (Tvariant {row with row_fields = fields})
+    | Tobject (fi, nm) ->
+        begin match !nm with
+        | None -> ()
+        | Some (n, v :: l) ->
+            if deep_occur ty (newgenty (Ttuple l)) then
+              (* The abbreviation may be hiding something, so remove it *)
+              set_name nm None
+            else let v' = repr v in
+            begin match v'.desc with
+            | Tvar _ | Tunivar _ ->
+                if v' != v then set_name nm (Some (n, v' :: l))
+            | Tnil ->
+                set_type_desc ty (Tconstr (n, l, ref Mnil))
+            | _ -> set_name nm None
+            end
+        | _ ->
+            fatal_error "Ctype.normalize_type_rec"
+        end;
+        let fi = repr fi in
+        if fi.level < lowest_level then () else
+        let fields, row = flatten_fields fi in
+        let fi' = build_fields fi.level fields row in
+        set_type_desc fi fi'.desc
+    | _ -> ()
+    end;
+    iter_type_expr (normalize_type_rec visited) ty
+  end
+
+let normalize_type ty =
+  normalize_type_rec (ref TypeSet.empty) ty
+
+
+                              (*************************)
+                              (*  Remove dependencies  *)
+                              (*************************)
+
+
+(*
+   Variables are left unchanged. Other type nodes are duplicated, with
+   levels set to generic level.
+   We cannot use Tsubst here, because unification may be called by
+   expand_abbrev.
+*)
+
+let nondep_hash     = TypeHash.create 47
+let nondep_variants = TypeHash.create 17
+let clear_hash ()   =
+  TypeHash.clear nondep_hash; TypeHash.clear nondep_variants
+
+let rec nondep_type_rec ?(expand_private=false) env ids ty =
+  let expand_abbrev env t =
+    if expand_private then expand_abbrev_opt env t else expand_abbrev env t
+  in
+  match ty.desc with
+    Tvar _ | Tunivar _ -> ty
+  | Tlink ty -> nondep_type_rec env ids ty
+  | _ -> try TypeHash.find nondep_hash ty
+  with Not_found ->
+    let ty' = newgenvar () in        (* Stub *)
+    TypeHash.add nondep_hash ty ty';
+    ty'.desc <-
+      begin match ty.desc with
+      | Tconstr(p, tl, _abbrev) ->
+          begin match Path.find_free_opt ids p with
+          | Some id ->
+              begin try
+                Tlink (nondep_type_rec ~expand_private env ids
+                         (expand_abbrev env (newty2 ty.level ty.desc)))
+                (*
+                   The [Tlink] is important. The expanded type may be a
+                   variable, or may not be completely copied yet
+                   (recursive type), so one cannot just take its
+                   description.
+                 *)
+              with Cannot_expand | Unify _ ->
+                raise (Nondep_cannot_erase id)
+              end
+          | None ->
+              Tconstr(p, List.map (nondep_type_rec env ids) tl, ref Mnil)
+          end
+      | Tpackage(p, nl, tl) when Path.exists_free ids p ->
+          let p' = normalize_package_path env p in
+          begin match Path.find_free_opt ids p' with
+          | Some id -> raise (Nondep_cannot_erase id)
+          | None -> Tpackage (p', nl, List.map (nondep_type_rec env ids) tl)
+          end
+      | Tobject (t1, name) ->
+          Tobject (nondep_type_rec env ids t1,
+                 ref (match !name with
+                        None -> None
+                      | Some (p, tl) ->
+                          if Path.exists_free ids p then None
+                          else Some (p, List.map (nondep_type_rec env ids) tl)))
+      | Tvariant row ->
+          let row = row_repr row in
+          let more = repr row.row_more in
+          (* We must keep sharing according to the row variable *)
+          begin try
+            let ty2 = TypeHash.find nondep_variants more in
+            (* This variant type has been already copied *)
+            TypeHash.add nondep_hash ty ty2;
+            Tlink ty2
+          with Not_found ->
+            (* Register new type first for recursion *)
+            TypeHash.add nondep_variants more ty';
+            let static = static_row row in
+            let more' = if static then newgenty Tnil else more in
+            (* Return a new copy *)
+            let row =
+              copy_row (nondep_type_rec env ids) true row true more' in
+            match row.row_name with
+              Some (p, _tl) when Path.exists_free ids p ->
+                Tvariant {row with row_name = None}
+            | _ -> Tvariant row
+          end
+      | _ -> copy_type_desc (nondep_type_rec env ids) ty.desc
+      end;
+    ty'
+
+let nondep_type env id ty =
+  try
+    let ty' = nondep_type_rec env id ty in
+    clear_hash ();
+    ty'
+  with Nondep_cannot_erase _ as exn ->
+    clear_hash ();
+    raise exn
+
+let () = nondep_type' := nondep_type
+
+(* Preserve sharing inside type declarations. *)
+let nondep_type_decl env mid is_covariant decl =
+  try
+    let params = List.map (nondep_type_rec env mid) decl.type_params in
+    let tk =
+      try map_kind (nondep_type_rec env mid) decl.type_kind
+      with Nondep_cannot_erase _ when is_covariant -> Type_abstract
+    and tm, priv =
+      match decl.type_manifest with
+      | None -> None, decl.type_private
+      | Some ty ->
+          try Some (nondep_type_rec env mid ty), decl.type_private
+          with Nondep_cannot_erase _ when is_covariant ->
+            clear_hash ();
+            try Some (nondep_type_rec ~expand_private:true env mid ty),
+                Private
+            with Nondep_cannot_erase _ ->
+              None, decl.type_private
+    in
+    clear_hash ();
+    let priv =
+      match tm with
+      | Some ty when Btype.has_constr_row ty -> Private
+      | _ -> priv
+    in
+    { type_params = params;
+      type_arity = decl.type_arity;
+      type_kind = tk;
+      type_manifest = tm;
+      type_private = priv;
+      type_variance = decl.type_variance;
+      type_separability = decl.type_separability;
+      type_is_newtype = false;
+      type_expansion_scope = Btype.lowest_level;
+      type_loc = decl.type_loc;
+      type_attributes = decl.type_attributes;
+      type_immediate = decl.type_immediate;
+      type_unboxed = decl.type_unboxed;
+      type_uid = decl.type_uid;
+    }
+  with Nondep_cannot_erase _ as exn ->
+    clear_hash ();
+    raise exn
+
+(* Preserve sharing inside extension constructors. *)
+let nondep_extension_constructor env ids ext =
+  try
+    let type_path, type_params =
+      match Path.find_free_opt ids ext.ext_type_path with
+      | Some id ->
+        begin
+          let ty =
+            newgenty (Tconstr(ext.ext_type_path, ext.ext_type_params, ref Mnil))
+          in
+          let ty' = nondep_type_rec env ids ty in
+            match (repr ty').desc with
+                Tconstr(p, tl, _) -> p, tl
+              | _ -> raise (Nondep_cannot_erase id)
+        end
+      | None ->
+        let type_params =
+          List.map (nondep_type_rec env ids) ext.ext_type_params
+        in
+          ext.ext_type_path, type_params
+    in
+    let args = map_type_expr_cstr_args (nondep_type_rec env ids) ext.ext_args in
+    let ret_type = Option.map (nondep_type_rec env ids) ext.ext_ret_type in
+      clear_hash ();
+      { ext_type_path = type_path;
+        ext_type_params = type_params;
+        ext_args = args;
+        ext_ret_type = ret_type;
+        ext_private = ext.ext_private;
+        ext_attributes = ext.ext_attributes;
+        ext_loc = ext.ext_loc;
+        ext_uid = ext.ext_uid;
+      }
+  with Nondep_cannot_erase _ as exn ->
+    clear_hash ();
+    raise exn
+
+
+(* Preserve sharing inside class types. *)
+let nondep_class_signature env id sign =
+  { csig_self = nondep_type_rec env id sign.csig_self;
+    csig_vars =
+      Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t))
+        sign.csig_vars;
+    csig_concr = sign.csig_concr;
+    csig_inher =
+      List.map (fun (p,tl) -> (p, List.map (nondep_type_rec env id) tl))
+        sign.csig_inher }
+
+let rec nondep_class_type env ids =
+  function
+    Cty_constr (p, _, cty) when Path.exists_free ids p ->
+      nondep_class_type env ids cty
+  | Cty_constr (p, tyl, cty) ->
+      Cty_constr (p, List.map (nondep_type_rec env ids) tyl,
+                   nondep_class_type env ids cty)
+  | Cty_signature sign ->
+      Cty_signature (nondep_class_signature env ids sign)
+  | Cty_arrow (l, ty, cty) ->
+      Cty_arrow (l, nondep_type_rec env ids ty, nondep_class_type env ids cty)
+
+let nondep_class_declaration env ids decl =
+  assert (not (Path.exists_free ids decl.cty_path));
+  let decl =
+    { cty_params = List.map (nondep_type_rec env ids) decl.cty_params;
+      cty_variance = decl.cty_variance;
+      cty_type = nondep_class_type env ids decl.cty_type;
+      cty_path = decl.cty_path;
+      cty_new =
+        begin match decl.cty_new with
+          None    -> None
+        | Some ty -> Some (nondep_type_rec env ids ty)
+        end;
+      cty_loc = decl.cty_loc;
+      cty_attributes = decl.cty_attributes;
+      cty_uid = decl.cty_uid;
+    }
+  in
+  clear_hash ();
+  decl
+
+let nondep_cltype_declaration env ids decl =
+  assert (not (Path.exists_free ids decl.clty_path));
+  let decl =
+    { clty_params = List.map (nondep_type_rec env ids) decl.clty_params;
+      clty_variance = decl.clty_variance;
+      clty_type = nondep_class_type env ids decl.clty_type;
+      clty_path = decl.clty_path;
+      clty_loc = decl.clty_loc;
+      clty_attributes = decl.clty_attributes;
+      clty_uid = decl.clty_uid;
+    }
+  in
+  clear_hash ();
+  decl
+
+(* collapse conjunctive types in class parameters *)
+let rec collapse_conj env visited ty =
+  let ty = repr ty in
+  if List.memq ty visited then () else
+  let visited = ty :: visited in
+  match ty.desc with
+    Tvariant row ->
+      let row = row_repr row in
+      List.iter
+        (fun (_l,fi) ->
+          match row_field_repr fi with
+            Reither (c, t1::(_::_ as tl), m, e) ->
+              List.iter (unify env t1) tl;
+              set_row_field e (Reither (c, [t1], m, ref None))
+          | _ ->
+              ())
+        row.row_fields;
+      iter_row (collapse_conj env visited) row
+  | _ ->
+      iter_type_expr (collapse_conj env visited) ty
+
+let collapse_conj_params env params =
+  List.iter (collapse_conj env []) params
+
+let same_constr env t1 t2 =
+  let t1 = expand_head env t1 in
+  let t2 = expand_head env t2 in
+  match t1.desc, t2.desc with
+  | Tconstr (p1, _, _), Tconstr (p2, _, _) -> Path.same p1 p2
+  | _ -> false
+
+let () =
+  Env.same_constr := same_constr
+
+let is_immediate = function
+  | Type_immediacy.Unknown -> false
+  | Type_immediacy.Always -> true
+  | Type_immediacy.Always_on_64bits ->
+      (* In bytecode, we don't know at compile time whether we are
+         targeting 32 or 64 bits. *)
+      !Clflags.native_code && Sys.word_size = 64
+
+let immediacy env typ =
+   match (repr typ).desc with
+  | Tconstr(p, _args, _abbrev) ->
+    begin try
+      let type_decl = Env.find_type p env in
+      type_decl.type_immediate
+    with Not_found -> Type_immediacy.Unknown
+    (* This can happen due to e.g. missing -I options,
+       causing some .cmi files to be unavailable.
+       Maybe we should emit a warning. *)
+    end
+  | Tvariant row ->
+      let row = Btype.row_repr row in
+      (* if all labels are devoid of arguments, not a pointer *)
+      if
+        not row.row_closed
+        || List.exists
+          (function
+            | _, (Rpresent (Some _) | Reither (false, _, _, _)) -> true
+            | _ -> false)
+          row.row_fields
+      then
+        Type_immediacy.Unknown
+      else
+        Type_immediacy.Always
+  | _ -> Type_immediacy.Unknown
+
+let maybe_pointer_type env typ = not (is_immediate (immediacy env typ))
diff --git a/upstream/ocaml_412/typing/ctype.mli b/upstream/ocaml_412/typing/ctype.mli
new file mode 100644
index 0000000..4215e14
--- /dev/null
+++ b/upstream/ocaml_412/typing/ctype.mli
@@ -0,0 +1,393 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Operations on core types *)
+
+open Asttypes
+open Types
+
+module TypePairs : Hashtbl.S with type key = type_expr * type_expr
+
+module Unification_trace: sig
+  (** Unification traces are used to explain unification errors
+      when printing error messages *)
+
+  type position = First | Second
+  type desc = { t: type_expr; expanded: type_expr option }
+  type 'a diff = { got: 'a; expected: 'a}
+
+   (** Scope escape related errors *)
+    type 'a escape =
+    | Constructor of Path.t
+    | Univ of type_expr
+    (** The type_expr argument of [Univ] is always a [Tunivar _],
+        we keep a [type_expr] to track renaming in {!Printtyp} *)
+    | Self
+    | Module_type of Path.t
+    | Equation of 'a
+
+   (** Errors for polymorphic variants *)
+
+  type fixed_row_case =
+    | Cannot_be_closed
+    | Cannot_add_tags of string list
+
+  type variant =
+    | No_intersection
+    | No_tags of position * (Asttypes.label * row_field) list
+    | Incompatible_types_for of string
+    | Fixed_row of position * fixed_row_case * fixed_explanation
+    (** Fixed row types,  e.g. ['a. [> `X] as 'a] *)
+
+  type obj =
+    | Missing_field of position * string
+    | Abstract_row of position
+    | Self_cannot_be_closed
+
+  type 'a elt =
+    | Diff of 'a diff
+    | Variant of variant
+    | Obj of obj
+    | Escape of {context: type_expr option; kind:'a escape}
+    | Incompatible_fields of {name:string; diff: type_expr diff }
+    | Rec_occur of type_expr * type_expr
+
+  type t = desc elt list
+
+  val diff: type_expr -> type_expr -> desc elt
+
+  (** [map_diff f {expected;got}] is [{expected=f expected; got=f got}] *)
+  val map_diff: ('a -> 'b) -> 'a diff -> 'b diff
+
+  (** [flatten f trace] flattens all elements of type {!desc} in
+      [trace] to either [f x.t expanded] if [x.expanded=Some expanded]
+      or [f x.t x.t] otherwise *)
+  val flatten: (type_expr -> type_expr -> 'a) -> t -> 'a elt list
+
+  (** Switch [expected] and [got] *)
+  val swap: t -> t
+
+  (** [explain trace f] calls [f] on trace elements starting from the end
+      until [f ~prev elt] is [Some _], returns that
+      or [None] if the end of the trace is reached. *)
+  val explain:
+          'a elt list ->
+          (prev:'a elt option -> 'a elt -> 'b option) ->
+          'b option
+
+end
+
+exception Unify of Unification_trace.t
+exception Tags of label * label
+exception Subtype of Unification_trace.t * Unification_trace.t
+exception Cannot_expand
+exception Cannot_apply
+
+val init_def: int -> unit
+        (* Set the initial variable level *)
+val begin_def: unit -> unit
+        (* Raise the variable level by one at the beginning of a definition. *)
+val end_def: unit -> unit
+        (* Lower the variable level by one at the end of a definition *)
+val begin_class_def: unit -> unit
+val raise_nongen_level: unit -> unit
+val reset_global_level: unit -> unit
+        (* Reset the global level before typing an expression *)
+val increase_global_level: unit -> int
+val restore_global_level: int -> unit
+        (* This pair of functions is only used in Typetexp *)
+type levels =
+    { current_level: int; nongen_level: int; global_level: int;
+      saved_level: (int * int) list; }
+val save_levels: unit -> levels
+val set_levels: levels -> unit
+
+val create_scope : unit -> int
+
+val newty: type_desc -> type_expr
+val newvar: ?name:string -> unit -> type_expr
+val newvar2: ?name:string -> int -> type_expr
+        (* Return a fresh variable *)
+val new_global_var: ?name:string -> unit -> type_expr
+        (* Return a fresh variable, bound at toplevel
+           (as type variables ['a] in type constraints). *)
+val newobj: type_expr -> type_expr
+val newconstr: Path.t -> type_expr list -> type_expr
+val none: type_expr
+        (* A dummy type expression *)
+
+val repr: type_expr -> type_expr
+        (* Return the canonical representative of a type. *)
+
+val object_fields: type_expr -> type_expr
+val flatten_fields:
+        type_expr -> (string * field_kind * type_expr) list * type_expr
+(** Transform a field type into a list of pairs label-type.
+    The fields are sorted.
+
+    Beware of the interaction with GADTs:
+
+    Due to the introduction of object indexes for GADTs, the row variable of
+    an object may now be an expansible type abbreviation.
+    A first consequence is that [flatten_fields] will not completely flatten
+    the object, since the type abbreviation will not be expanded
+    ([flatten_fields] does not receive the current environment).
+    Another consequence is that various functions may be called with the
+    expansion of this type abbreviation, which is a Tfield, e.g. during
+    printing.
+
+    Concrete problems have been fixed, but new bugs may appear in the
+    future. (Test cases were added to typing-gadts/test.ml)
+*)
+
+val associate_fields:
+        (string * field_kind * type_expr) list ->
+        (string * field_kind * type_expr) list ->
+        (string * field_kind * type_expr * field_kind * type_expr) list *
+        (string * field_kind * type_expr) list *
+        (string * field_kind * type_expr) list
+val opened_object: type_expr -> bool
+val close_object: type_expr -> bool
+val row_variable: type_expr -> type_expr
+        (* Return the row variable of an open object type *)
+val set_object_name:
+        Ident.t -> type_expr -> type_expr list -> type_expr -> unit
+val remove_object_name: type_expr -> unit
+val hide_private_methods: type_expr -> unit
+val find_cltype_for_path: Env.t -> Path.t -> type_declaration * type_expr
+
+val sort_row_fields: (label * row_field) list -> (label * row_field) list
+val merge_row_fields:
+        (label * row_field) list -> (label * row_field) list ->
+        (label * row_field) list * (label * row_field) list *
+        (label * row_field * row_field) list
+val filter_row_fields:
+        bool -> (label * row_field) list -> (label * row_field) list
+
+val generalize: type_expr -> unit
+        (* Generalize in-place the given type *)
+val lower_contravariant: Env.t -> type_expr -> unit
+        (* Lower level of type variables inside contravariant branches;
+           to be used before generalize for expansive expressions *)
+val generalize_structure: type_expr -> unit
+        (* Same, but variables are only lowered to !current_level *)
+val generalize_spine: type_expr -> unit
+        (* Special function to generalize a method during inference *)
+val correct_levels: type_expr -> type_expr
+        (* Returns a copy with decreasing levels *)
+val limited_generalize: type_expr -> type_expr -> unit
+        (* Only generalize some part of the type
+           Make the remaining of the type non-generalizable *)
+
+val fully_generic: type_expr -> bool
+
+val check_scope_escape : Env.t -> int -> type_expr -> unit
+        (* [check_scope_escape env lvl ty] ensures that [ty] could be raised
+           to the level [lvl] without any scope escape.
+           Raises [Unify] otherwise *)
+
+val instance: ?partial:bool -> type_expr -> type_expr
+        (* Take an instance of a type scheme *)
+        (* partial=None  -> normal
+           partial=false -> newvar() for non generic subterms
+           partial=true  -> newty2 ty.level Tvar for non generic subterms *)
+val generic_instance: type_expr -> type_expr
+        (* Same as instance, but new nodes at generic_level *)
+val instance_list: type_expr list -> type_expr list
+        (* Take an instance of a list of type schemes *)
+val existential_name: constructor_description -> type_expr -> string
+val instance_constructor:
+        ?in_pattern:Env.t ref * int ->
+        constructor_description -> type_expr list * type_expr
+        (* Same, for a constructor *)
+val instance_parameterized_type:
+        ?keep_names:bool ->
+        type_expr list -> type_expr -> type_expr list * type_expr
+val instance_parameterized_type_2:
+        type_expr list -> type_expr list -> type_expr ->
+        type_expr list * type_expr list * type_expr
+val instance_declaration: type_declaration -> type_declaration
+val generic_instance_declaration: type_declaration -> type_declaration
+        (* Same as instance_declaration, but new nodes at generic_level *)
+val instance_class:
+        type_expr list -> class_type -> type_expr list * class_type
+val instance_poly:
+        ?keep_names:bool ->
+        bool -> type_expr list -> type_expr -> type_expr list * type_expr
+        (* Take an instance of a type scheme containing free univars *)
+val polyfy: Env.t -> type_expr -> type_expr list -> type_expr * bool
+val instance_label:
+        bool -> label_description -> type_expr list * type_expr * type_expr
+        (* Same, for a label *)
+val apply:
+        Env.t -> type_expr list -> type_expr -> type_expr list -> type_expr
+        (* [apply [p1...pN] t [a1...aN]] match the arguments [ai] to
+        the parameters [pi] and returns the corresponding instance of
+        [t]. Exception [Cannot_apply] is raised in case of failure. *)
+
+val expand_head_once: Env.t -> type_expr -> type_expr
+val expand_head: Env.t -> type_expr -> type_expr
+val try_expand_once_opt: Env.t -> type_expr -> type_expr
+val expand_head_opt: Env.t -> type_expr -> type_expr
+(** The compiler's own version of [expand_head] necessary for type-based
+    optimisations. *)
+
+val full_expand: Env.t -> type_expr -> type_expr
+val extract_concrete_typedecl:
+        Env.t -> type_expr -> Path.t * Path.t * type_declaration
+        (* Return the original path of the types, and the first concrete
+           type declaration found expanding it.
+           Raise [Not_found] if none appears or not a type constructor. *)
+
+val enforce_constraints: Env.t -> type_expr -> unit
+
+val unify: Env.t -> type_expr -> type_expr -> unit
+        (* Unify the two types given. Raise [Unify] if not possible. *)
+val unify_gadt:
+        equations_level:int -> allow_recursive:bool ->
+        Env.t ref -> type_expr -> type_expr -> unit TypePairs.t
+        (* Unify the two types given and update the environment with the
+           local constraints. Raise [Unify] if not possible.
+           Returns the pairs of types that have been equated.  *)
+val unify_var: Env.t -> type_expr -> type_expr -> unit
+        (* Same as [unify], but allow free univars when first type
+           is a variable. *)
+val filter_arrow: Env.t -> type_expr -> arg_label -> type_expr * type_expr
+        (* A special case of unification (with l:'a -> 'b). *)
+val filter_method: Env.t -> string -> private_flag -> type_expr -> type_expr
+        (* A special case of unification (with {m : 'a; 'b}). *)
+val check_filter_method: Env.t -> string -> private_flag -> type_expr -> unit
+        (* A special case of unification (with {m : 'a; 'b}), returning unit. *)
+val occur_in: Env.t -> type_expr -> type_expr -> bool
+val deep_occur: type_expr -> type_expr -> bool
+val filter_self_method:
+        Env.t -> string -> private_flag -> (Ident.t * type_expr) Meths.t ref ->
+        type_expr -> Ident.t * type_expr
+val moregeneral: Env.t -> bool -> type_expr -> type_expr -> bool
+        (* Check if the first type scheme is more general than the second. *)
+
+val rigidify: type_expr -> type_expr list
+        (* "Rigidify" a type and return its type variable *)
+val all_distinct_vars: Env.t -> type_expr list -> bool
+        (* Check those types are all distinct type variables *)
+val matches: Env.t -> type_expr -> type_expr -> bool
+        (* Same as [moregeneral false], implemented using the two above
+           functions and backtracking. Ignore levels *)
+
+val reify_univars : Env.t -> Types.type_expr -> Types.type_expr
+        (* Replaces all the variables of a type by a univar. *)
+
+type class_match_failure =
+    CM_Virtual_class
+  | CM_Parameter_arity_mismatch of int * int
+  | CM_Type_parameter_mismatch of Env.t * Unification_trace.t
+  | CM_Class_type_mismatch of Env.t * class_type * class_type
+  | CM_Parameter_mismatch of Env.t * Unification_trace.t
+  | CM_Val_type_mismatch of string * Env.t * Unification_trace.t
+  | CM_Meth_type_mismatch of string * Env.t * Unification_trace.t
+  | CM_Non_mutable_value of string
+  | CM_Non_concrete_value of string
+  | CM_Missing_value of string
+  | CM_Missing_method of string
+  | CM_Hide_public of string
+  | CM_Hide_virtual of string * string
+  | CM_Public_method of string
+  | CM_Private_method of string
+  | CM_Virtual_method of string
+val match_class_types:
+    ?trace:bool -> Env.t -> class_type -> class_type -> class_match_failure list
+        (* Check if the first class type is more general than the second. *)
+val equal: Env.t -> bool -> type_expr list -> type_expr list -> bool
+        (* [equal env [x1...xn] tau [y1...yn] sigma]
+           checks whether the parameterized types
+           [/\x1.../\xn.tau] and [/\y1.../\yn.sigma] are equivalent. *)
+val match_class_declarations:
+        Env.t -> type_expr list -> class_type -> type_expr list ->
+        class_type -> class_match_failure list
+        (* Check if the first class type is more general than the second. *)
+
+val enlarge_type: Env.t -> type_expr -> type_expr * bool
+        (* Make a type larger, flag is true if some pruning had to be done *)
+val subtype: Env.t -> type_expr -> type_expr -> unit -> unit
+        (* [subtype env t1 t2] checks that [t1] is a subtype of [t2].
+           It accumulates the constraints the type variables must
+           enforce and returns a function that enforces this
+           constraints. *)
+
+exception Nondep_cannot_erase of Ident.t
+
+val nondep_type: Env.t -> Ident.t list -> type_expr -> type_expr
+        (* Return a type equivalent to the given type but without
+           references to any of the given identifiers.
+           Raise [Nondep_cannot_erase id] if no such type exists because [id],
+           in particular, could not be erased. *)
+val nondep_type_decl:
+        Env.t -> Ident.t list -> bool -> type_declaration -> type_declaration
+        (* Same for type declarations. *)
+val nondep_extension_constructor:
+        Env.t -> Ident.t list -> extension_constructor ->
+        extension_constructor
+          (* Same for extension constructor *)
+val nondep_class_declaration:
+        Env.t -> Ident.t list -> class_declaration -> class_declaration
+        (* Same for class declarations. *)
+val nondep_cltype_declaration:
+  Env.t -> Ident.t list -> class_type_declaration -> class_type_declaration
+        (* Same for class type declarations. *)
+(*val correct_abbrev: Env.t -> Path.t -> type_expr list -> type_expr -> unit*)
+val cyclic_abbrev: Env.t -> Ident.t -> type_expr -> bool
+val is_contractive: Env.t -> Path.t -> bool
+val normalize_type: type_expr -> unit
+
+val closed_schema: Env.t -> type_expr -> bool
+        (* Check whether the given type scheme contains no non-generic
+           type variables *)
+
+val free_variables: ?env:Env.t -> type_expr -> type_expr list
+        (* If env present, then check for incomplete definitions too *)
+val closed_type_decl: type_declaration -> type_expr option
+val closed_extension_constructor: extension_constructor -> type_expr option
+type closed_class_failure =
+    CC_Method of type_expr * bool * string * type_expr
+  | CC_Value of type_expr * bool * string * type_expr
+val closed_class:
+        type_expr list -> class_signature -> closed_class_failure option
+        (* Check whether all type variables are bound *)
+
+val unalias: type_expr -> type_expr
+val signature_of_class_type: class_type -> class_signature
+val self_type: class_type -> type_expr
+val class_type_arity: class_type -> int
+val arity: type_expr -> int
+        (* Return the arity (as for curried functions) of the given type. *)
+
+val collapse_conj_params: Env.t -> type_expr list -> unit
+        (* Collapse conjunctive types in class parameters *)
+
+val get_current_level: unit -> int
+val wrap_trace_gadt_instances: Env.t -> ('a -> 'b) -> 'a -> 'b
+val reset_reified_var_counter: unit -> unit
+
+val immediacy : Env.t -> type_expr -> Type_immediacy.t
+
+val maybe_pointer_type : Env.t -> type_expr -> bool
+       (* True if type is possibly pointer, false if definitely not a pointer *)
+
+(* Stubs *)
+val package_subtype :
+    (Env.t -> Path.t -> Longident.t list -> type_expr list ->
+      Path.t -> Longident.t list -> type_expr list -> bool) ref
+
+val mcomp : Env.t -> type_expr -> type_expr -> unit
diff --git a/upstream/ocaml_412/typing/datarepr.ml b/upstream/ocaml_412/typing/datarepr.ml
new file mode 100644
index 0000000..989395c
--- /dev/null
+++ b/upstream/ocaml_412/typing/datarepr.ml
@@ -0,0 +1,258 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Compute constructor and label descriptions from type declarations,
+   determining their representation. *)
+
+open Asttypes
+open Types
+open Btype
+
+(* Simplified version of Ctype.free_vars *)
+let free_vars ?(param=false) ty =
+  let ret = ref TypeSet.empty in
+  let rec loop ty =
+    let ty = repr ty in
+    if ty.level >= lowest_level then begin
+      ty.level <- pivot_level - ty.level;
+      match ty.desc with
+      | Tvar _ ->
+          ret := TypeSet.add ty !ret
+      | Tvariant row ->
+          let row = row_repr row in
+          iter_row loop row;
+          if not (static_row row) then begin
+            match row.row_more.desc with
+            | Tvar _ when param -> ret := TypeSet.add ty !ret
+            | _ -> loop row.row_more
+          end
+      (* XXX: What about Tobject ? *)
+      | _ ->
+          iter_type_expr loop ty
+    end
+  in
+  loop ty;
+  unmark_type ty;
+  !ret
+
+let newgenconstr path tyl = newgenty (Tconstr (path, tyl, ref Mnil))
+
+let constructor_existentials cd_args cd_res =
+  let tyl =
+    match cd_args with
+    | Cstr_tuple l -> l
+    | Cstr_record l -> List.map (fun l -> l.ld_type) l
+  in
+  let existentials =
+    match cd_res with
+    | None -> []
+    | Some type_ret ->
+        let arg_vars_set = free_vars (newgenty (Ttuple tyl)) in
+        let res_vars = free_vars type_ret in
+        TypeSet.elements (TypeSet.diff arg_vars_set res_vars)
+  in
+  (tyl, existentials)
+
+let constructor_args ~current_unit priv cd_args cd_res path rep =
+  let tyl, existentials = constructor_existentials cd_args cd_res in
+  match cd_args with
+  | Cstr_tuple l -> existentials, l, None
+  | Cstr_record lbls ->
+      let arg_vars_set = free_vars ~param:true (newgenty (Ttuple tyl)) in
+      let type_params = TypeSet.elements arg_vars_set in
+      let type_unboxed =
+        match rep with
+        | Record_unboxed _ -> unboxed_true_default_false
+        | _ -> unboxed_false_default_false
+      in
+      let arity = List.length type_params in
+      let tdecl =
+        {
+          type_params;
+          type_arity = arity;
+          type_kind = Type_record (lbls, rep);
+          type_private = priv;
+          type_manifest = None;
+          type_variance = Variance.unknown_signature ~injective:true ~arity;
+          type_separability = Types.Separability.default_signature ~arity;
+          type_is_newtype = false;
+          type_expansion_scope = Btype.lowest_level;
+          type_loc = Location.none;
+          type_attributes = [];
+          type_immediate = Unknown;
+          type_unboxed;
+          type_uid = Uid.mk ~current_unit;
+        }
+      in
+      existentials,
+      [ newgenconstr path type_params ],
+      Some tdecl
+
+let constructor_descrs ~current_unit ty_path decl cstrs =
+  let ty_res = newgenconstr ty_path decl.type_params in
+  let num_consts = ref 0 and num_nonconsts = ref 0  and num_normal = ref 0 in
+  List.iter
+    (fun {cd_args; cd_res; _} ->
+      if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts;
+      if cd_res = None then incr num_normal)
+    cstrs;
+  let rec describe_constructors idx_const idx_nonconst = function
+      [] -> []
+    | {cd_id; cd_args; cd_res; cd_loc; cd_attributes; cd_uid} :: rem ->
+        let ty_res =
+          match cd_res with
+          | Some ty_res' -> ty_res'
+          | None -> ty_res
+        in
+        let (tag, descr_rem) =
+          match cd_args with
+          | _ when decl.type_unboxed.unboxed ->
+            assert (rem = []);
+            (Cstr_unboxed, [])
+          | Cstr_tuple [] -> (Cstr_constant idx_const,
+                   describe_constructors (idx_const+1) idx_nonconst rem)
+          | _  -> (Cstr_block idx_nonconst,
+                   describe_constructors idx_const (idx_nonconst+1) rem) in
+        let cstr_name = Ident.name cd_id in
+        let existentials, cstr_args, cstr_inlined =
+          let representation =
+            if decl.type_unboxed.unboxed
+            then Record_unboxed true
+            else Record_inlined idx_nonconst
+          in
+          constructor_args ~current_unit decl.type_private cd_args cd_res
+            (Path.Pdot (ty_path, cstr_name)) representation
+        in
+        let cstr =
+          { cstr_name;
+            cstr_res = ty_res;
+            cstr_existentials = existentials;
+            cstr_args;
+            cstr_arity = List.length cstr_args;
+            cstr_tag = tag;
+            cstr_consts = !num_consts;
+            cstr_nonconsts = !num_nonconsts;
+            cstr_normal = !num_normal;
+            cstr_private = decl.type_private;
+            cstr_generalized = cd_res <> None;
+            cstr_loc = cd_loc;
+            cstr_attributes = cd_attributes;
+            cstr_inlined;
+            cstr_uid = cd_uid;
+          } in
+        (cd_id, cstr) :: descr_rem in
+  describe_constructors 0 0 cstrs
+
+let extension_descr ~current_unit path_ext ext =
+  let ty_res =
+    match ext.ext_ret_type with
+        Some type_ret -> type_ret
+      | None -> newgenconstr ext.ext_type_path ext.ext_type_params
+  in
+  let existentials, cstr_args, cstr_inlined =
+    constructor_args ~current_unit ext.ext_private ext.ext_args ext.ext_ret_type
+      path_ext (Record_extension path_ext)
+  in
+    { cstr_name = Path.last path_ext;
+      cstr_res = ty_res;
+      cstr_existentials = existentials;
+      cstr_args;
+      cstr_arity = List.length cstr_args;
+      cstr_tag = Cstr_extension(path_ext, cstr_args = []);
+      cstr_consts = -1;
+      cstr_nonconsts = -1;
+      cstr_private = ext.ext_private;
+      cstr_normal = -1;
+      cstr_generalized = ext.ext_ret_type <> None;
+      cstr_loc = ext.ext_loc;
+      cstr_attributes = ext.ext_attributes;
+      cstr_inlined;
+      cstr_uid = ext.ext_uid;
+    }
+
+let none = {desc = Ttuple []; level = -1; scope = Btype.generic_level; id = -1}
+                                        (* Clearly ill-formed type *)
+let dummy_label =
+  { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable;
+    lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular;
+    lbl_private = Public;
+    lbl_loc = Location.none;
+    lbl_attributes = [];
+    lbl_uid = Uid.internal_not_actually_unique;
+  }
+
+let label_descrs ty_res lbls repres priv =
+  let all_labels = Array.make (List.length lbls) dummy_label in
+  let rec describe_labels num = function
+      [] -> []
+    | l :: rest ->
+        let lbl =
+          { lbl_name = Ident.name l.ld_id;
+            lbl_res = ty_res;
+            lbl_arg = l.ld_type;
+            lbl_mut = l.ld_mutable;
+            lbl_pos = num;
+            lbl_all = all_labels;
+            lbl_repres = repres;
+            lbl_private = priv;
+            lbl_loc = l.ld_loc;
+            lbl_attributes = l.ld_attributes;
+            lbl_uid = l.ld_uid;
+          } in
+        all_labels.(num) <- lbl;
+        (l.ld_id, lbl) :: describe_labels (num+1) rest in
+  describe_labels 0 lbls
+
+exception Constr_not_found
+
+let rec find_constr tag num_const num_nonconst = function
+    [] ->
+      raise Constr_not_found
+  | {cd_args = Cstr_tuple []; _} as c  :: rem ->
+      if tag = Cstr_constant num_const
+      then c
+      else find_constr tag (num_const + 1) num_nonconst rem
+  | c :: rem ->
+      if tag = Cstr_block num_nonconst || tag = Cstr_unboxed
+      then c
+      else find_constr tag num_const (num_nonconst + 1) rem
+
+let find_constr_by_tag tag cstrlist =
+  find_constr tag 0 0 cstrlist
+
+let constructors_of_type ~current_unit ty_path decl =
+  match decl.type_kind with
+  | Type_variant cstrs -> constructor_descrs ~current_unit ty_path decl cstrs
+  | Type_record _ | Type_abstract | Type_open -> []
+
+let labels_of_type ty_path decl =
+  match decl.type_kind with
+  | Type_record(labels, rep) ->
+      label_descrs (newgenconstr ty_path decl.type_params)
+        labels rep decl.type_private
+  | Type_variant _ | Type_abstract | Type_open -> []
+
+(* Set row_name in Env, cf. GPR#1204/1329 *)
+let set_row_name decl path =
+  match decl.type_manifest with
+    None -> ()
+  | Some ty ->
+      let ty = repr ty in
+      match ty.desc with
+        Tvariant row when static_row row ->
+          let row = {(row_repr row) with
+                     row_name = Some (path, decl.type_params)} in
+          ty.desc <- Tvariant row
+      | _ -> ()
diff --git a/upstream/ocaml_412/typing/datarepr.mli b/upstream/ocaml_412/typing/datarepr.mli
new file mode 100644
index 0000000..e3962e3
--- /dev/null
+++ b/upstream/ocaml_412/typing/datarepr.mli
@@ -0,0 +1,49 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Compute constructor and label descriptions from type declarations,
+   determining their representation. *)
+
+open Types
+
+val extension_descr:
+  current_unit:string -> Path.t -> extension_constructor ->
+  constructor_description
+
+val labels_of_type:
+  Path.t -> type_declaration ->
+  (Ident.t * label_description) list
+val constructors_of_type:
+  current_unit:string -> Path.t -> type_declaration ->
+  (Ident.t * constructor_description) list
+
+
+exception Constr_not_found
+
+val find_constr_by_tag:
+  constructor_tag -> constructor_declaration list ->
+    constructor_declaration
+
+val constructor_existentials :
+    constructor_arguments -> type_expr option -> type_expr list * type_expr list
+(** Takes [cd_args] and [cd_res] from a [constructor_declaration] and
+    returns:
+    - the types of the constructor's arguments
+    - the existential variables introduced by the constructor
+ *)
+
+
+(* Set the polymorphic variant row_name field *)
+val set_row_name : type_declaration -> Path.t -> unit
diff --git a/upstream/ocaml_412/typing/env.ml b/upstream/ocaml_412/typing/env.ml
new file mode 100644
index 0000000..108bb71
--- /dev/null
+++ b/upstream/ocaml_412/typing/env.ml
@@ -0,0 +1,3234 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Environment handling *)
+
+open Cmi_format
+open Misc
+open Asttypes
+open Longident
+open Path
+open Types
+open Btype
+
+open Local_store
+
+module String = Misc.Stdlib.String
+
+let add_delayed_check_forward = ref (fun _ -> assert false)
+
+type 'a usage_tbl = ('a -> unit) Types.Uid.Tbl.t
+(** This table is used to track usage of value declarations.
+    A declaration is identified by its uid.
+    The callback attached to a declaration is called whenever the value (or
+    type, or ...) is used explicitly (lookup_value, ...) or implicitly
+    (inclusion test between signatures, cf Includemod.value_descriptions, ...).
+*)
+
+let value_declarations  : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16
+let type_declarations   : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16
+let module_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16
+
+type constructor_usage = Positive | Pattern | Privatize
+type constructor_usages =
+    {
+     mutable cu_positive: bool;
+     mutable cu_pattern: bool;
+     mutable cu_privatize: bool;
+    }
+let add_constructor_usage ~rebind priv cu usage =
+  let private_or_rebind =
+    match priv with
+    | Asttypes.Private -> true
+    | Asttypes.Public -> rebind
+  in
+  if private_or_rebind then begin
+    cu.cu_positive <- true
+  end else begin
+    match usage with
+    | Positive -> cu.cu_positive <- true
+    | Pattern -> cu.cu_pattern <- true
+    | Privatize -> cu.cu_privatize <- true
+  end
+
+let constructor_usages () =
+  {cu_positive = false; cu_pattern = false; cu_privatize = false}
+
+let used_constructors : constructor_usage usage_tbl ref =
+  s_table Types.Uid.Tbl.create 16
+
+(** Map indexed by the name of module components. *)
+module NameMap = String.Map
+
+type value_unbound_reason =
+  | Val_unbound_instance_variable
+  | Val_unbound_self
+  | Val_unbound_ancestor
+  | Val_unbound_ghost_recursive of Location.t
+
+type module_unbound_reason =
+  | Mod_unbound_illegal_recursion
+
+type summary =
+    Env_empty
+  | Env_value of summary * Ident.t * value_description
+  | Env_type of summary * Ident.t * type_declaration
+  | Env_extension of summary * Ident.t * extension_constructor
+  | Env_module of summary * Ident.t * module_presence * module_declaration
+  | Env_modtype of summary * Ident.t * modtype_declaration
+  | Env_class of summary * Ident.t * class_declaration
+  | Env_cltype of summary * Ident.t * class_type_declaration
+  | Env_open of summary * Path.t
+  | Env_functor_arg of summary * Ident.t
+  | Env_constraints of summary * type_declaration Path.Map.t
+  | Env_copy_types of summary
+  | Env_persistent of summary * Ident.t
+  | Env_value_unbound of summary * string * value_unbound_reason
+  | Env_module_unbound of summary * string * module_unbound_reason
+
+type address =
+  | Aident of Ident.t
+  | Adot of address * int
+
+module TycompTbl =
+  struct
+    (** This module is used to store components of types (i.e. labels
+        and constructors).  We keep a representation of each nested
+        "open" and the set of local bindings between each of them. *)
+
+    type 'a t = {
+      current: 'a Ident.tbl;
+      (** Local bindings since the last open. *)
+
+      opened: 'a opened option;
+      (** Symbolic representation of the last (innermost) open, if any. *)
+    }
+
+    and 'a opened = {
+      components: ('a list) NameMap.t;
+      (** Components from the opened module. We keep a list of
+          bindings for each name, as in comp_labels and
+          comp_constrs. *)
+
+      using: (string -> ('a * 'a) option -> unit) option;
+      (** A callback to be applied when a component is used from this
+          "open".  This is used to detect unused "opens".  The
+          arguments are used to detect shadowing. *)
+
+      next: 'a t;
+      (** The table before opening the module. *)
+    }
+
+    let empty = { current = Ident.empty; opened = None }
+
+    let add id x tbl =
+      {tbl with current = Ident.add id x tbl.current}
+
+    let add_open slot wrap components next =
+      let using =
+        match slot with
+        | None -> None
+        | Some f -> Some (fun s x -> f s (wrap x))
+      in
+      {
+        current = Ident.empty;
+        opened = Some {using; components; next};
+      }
+
+    let rec find_same id tbl =
+      try Ident.find_same id tbl.current
+      with Not_found as exn ->
+        begin match tbl.opened with
+        | Some {next; _} -> find_same id next
+        | None -> raise exn
+        end
+
+    let nothing = fun () -> ()
+
+    let mk_callback rest name desc using =
+      match using with
+      | None -> nothing
+      | Some f ->
+          (fun () ->
+             match rest with
+             | [] -> f name None
+             | (hidden, _) :: _ -> f name (Some (desc, hidden)))
+
+    let rec find_all ~mark name tbl =
+      List.map (fun (_id, desc) -> desc, nothing)
+        (Ident.find_all name tbl.current) @
+      match tbl.opened with
+      | None -> []
+      | Some {using; next; components} ->
+          let rest = find_all ~mark name next in
+          let using = if mark then using else None in
+          match NameMap.find name components with
+          | exception Not_found -> rest
+          | opened ->
+              List.map
+                (fun desc -> desc, mk_callback rest name desc using)
+                opened
+              @ rest
+
+    let rec fold_name f tbl acc =
+      let acc = Ident.fold_name (fun _id d -> f d) tbl.current acc in
+      match tbl.opened with
+      | Some {using = _; next; components} ->
+          acc
+          |> NameMap.fold
+            (fun _name -> List.fold_right f)
+            components
+          |> fold_name f next
+      | None ->
+          acc
+
+    let rec local_keys tbl acc =
+      let acc = Ident.fold_all (fun k _ accu -> k::accu) tbl.current acc in
+      match tbl.opened with
+      | Some o -> local_keys o.next acc
+      | None -> acc
+
+    let diff_keys is_local tbl1 tbl2 =
+      let keys2 = local_keys tbl2 [] in
+      List.filter
+        (fun id ->
+           is_local (find_same id tbl2) &&
+           try ignore (find_same id tbl1); false
+           with Not_found -> true)
+        keys2
+
+  end
+
+
+module IdTbl =
+  struct
+    (** This module is used to store all kinds of components except
+        (labels and constructors) in environments.  We keep a
+        representation of each nested "open" and the set of local
+        bindings between each of them. *)
+
+
+    type ('a, 'b) t = {
+      current: 'a Ident.tbl;
+      (** Local bindings since the last open *)
+
+      layer: ('a, 'b) layer;
+      (** Symbolic representation of the last (innermost) open, if any. *)
+    }
+
+    and ('a, 'b) layer =
+      | Open of {
+          root: Path.t;
+          (** The path of the opened module, to be prefixed in front of
+              its local names to produce a valid path in the current
+              environment. *)
+
+          components: 'b NameMap.t;
+          (** Components from the opened module. *)
+
+          using: (string -> ('a * 'a) option -> unit) option;
+          (** A callback to be applied when a component is used from this
+              "open".  This is used to detect unused "opens".  The
+              arguments are used to detect shadowing. *)
+
+          next: ('a, 'b) t;
+          (** The table before opening the module. *)
+        }
+
+      | Map of {
+          f: ('a -> 'a);
+          next: ('a, 'b) t;
+        }
+
+      | Nothing
+
+    let empty = { current = Ident.empty; layer = Nothing }
+
+    let add id x tbl =
+      {tbl with current = Ident.add id x tbl.current}
+
+    let remove id tbl =
+      {tbl with current = Ident.remove id tbl.current}
+
+    let add_open slot wrap root components next =
+      let using =
+        match slot with
+        | None -> None
+        | Some f -> Some (fun s x -> f s (wrap x))
+      in
+      {
+        current = Ident.empty;
+        layer = Open {using; root; components; next};
+      }
+
+    let map f next =
+      {
+        current = Ident.empty;
+        layer = Map {f; next}
+      }
+
+    let rec find_same id tbl =
+      try Ident.find_same id tbl.current
+      with Not_found as exn ->
+        begin match tbl.layer with
+        | Open {next; _} -> find_same id next
+        | Map {f; next} -> f (find_same id next)
+        | Nothing -> raise exn
+        end
+
+    let rec find_name wrap ~mark name tbl =
+      try
+        let (id, desc) = Ident.find_name name tbl.current in
+        Pident id, desc
+      with Not_found as exn ->
+        begin match tbl.layer with
+        | Open {using; root; next; components} ->
+            begin try
+              let descr = wrap (NameMap.find name components) in
+              let res = Pdot (root, name), descr in
+              if mark then begin match using with
+              | None -> ()
+              | Some f -> begin
+                  match find_name wrap ~mark:false name next with
+                  | exception Not_found -> f name None
+                  | _, descr' -> f name (Some (descr', descr))
+                end
+              end;
+              res
+            with Not_found ->
+              find_name wrap ~mark name next
+            end
+        | Map {f; next} ->
+            let (p, desc) =  find_name wrap ~mark name next in
+            p, f desc
+        | Nothing ->
+            raise exn
+        end
+
+    let rec find_all wrap name tbl =
+      List.map
+        (fun (id, desc) -> Pident id, desc)
+        (Ident.find_all name tbl.current) @
+      match tbl.layer with
+      | Nothing -> []
+      | Open {root; using = _; next; components} ->
+          begin try
+            let desc = wrap (NameMap.find name components) in
+            (Pdot (root, name), desc) :: find_all wrap name next
+          with Not_found ->
+            find_all wrap name next
+          end
+      | Map {f; next} ->
+          List.map (fun (p, desc) -> (p, f desc))
+            (find_all wrap name next)
+
+    let rec fold_name wrap f tbl acc =
+      let acc =
+        Ident.fold_name
+          (fun id d -> f (Ident.name id) (Pident id, d))
+          tbl.current acc
+      in
+      match tbl.layer with
+      | Open {root; using = _; next; components} ->
+          acc
+          |> NameMap.fold
+            (fun name desc -> f name (Pdot (root, name), wrap desc))
+            components
+          |> fold_name wrap f next
+      | Nothing ->
+          acc
+      | Map {f=g; next} ->
+          acc
+          |> fold_name wrap
+               (fun name (path, desc) -> f name (path, g desc))
+               next
+
+    let rec local_keys tbl acc =
+      let acc = Ident.fold_all (fun k _ accu -> k::accu) tbl.current acc in
+      match tbl.layer with
+      | Open {next; _ } | Map {next; _} -> local_keys next acc
+      | Nothing -> acc
+
+
+    let rec iter wrap f tbl =
+      Ident.iter (fun id desc -> f id (Pident id, desc)) tbl.current;
+      match tbl.layer with
+      | Open {root; using = _; next; components} ->
+          NameMap.iter
+            (fun s x ->
+               let root_scope = Path.scope root in
+              f (Ident.create_scoped ~scope:root_scope s)
+                (Pdot (root, s), wrap x))
+            components;
+          iter wrap f next
+      | Map {f=g; next} ->
+          iter wrap (fun id (path, desc) -> f id (path, g desc)) next
+      | Nothing -> ()
+
+    let diff_keys tbl1 tbl2 =
+      let keys2 = local_keys tbl2 [] in
+      List.filter
+        (fun id ->
+           try ignore (find_same id tbl1); false
+           with Not_found -> true)
+        keys2
+
+
+  end
+
+type type_descriptions =
+    constructor_description list * label_description list
+
+let in_signature_flag = 0x01
+
+type t = {
+  values: (value_entry, value_data) IdTbl.t;
+  constrs: constructor_data TycompTbl.t;
+  labels: label_data TycompTbl.t;
+  types: (type_data, type_data) IdTbl.t;
+  modules: (module_entry, module_data) IdTbl.t;
+  modtypes: (modtype_data, modtype_data) IdTbl.t;
+  classes: (class_data, class_data) IdTbl.t;
+  cltypes: (cltype_data, cltype_data) IdTbl.t;
+  functor_args: unit Ident.tbl;
+  summary: summary;
+  local_constraints: type_declaration Path.Map.t;
+  flags: int;
+}
+
+and module_declaration_lazy =
+  (Subst.t * Subst.scoping * module_declaration, module_declaration) EnvLazy.t
+
+and module_components =
+  {
+    alerts: alerts;
+    uid: Uid.t;
+    comps:
+      (components_maker,
+       (module_components_repr, module_components_failure) result)
+        EnvLazy.t;
+  }
+
+and components_maker = {
+  cm_env: t;
+  cm_freshening_subst: Subst.t option;
+  cm_prefixing_subst: Subst.t;
+  cm_path: Path.t;
+  cm_addr: address_lazy;
+  cm_mty: Types.module_type;
+}
+
+and module_components_repr =
+    Structure_comps of structure_components
+  | Functor_comps of functor_components
+
+and module_components_failure =
+  | No_components_abstract
+  | No_components_alias of Path.t
+
+and structure_components = {
+  mutable comp_values: value_data NameMap.t;
+  mutable comp_constrs: constructor_data list NameMap.t;
+  mutable comp_labels: label_data list NameMap.t;
+  mutable comp_types: type_data NameMap.t;
+  mutable comp_modules: module_data NameMap.t;
+  mutable comp_modtypes: modtype_data NameMap.t;
+  mutable comp_classes: class_data NameMap.t;
+  mutable comp_cltypes: cltype_data NameMap.t;
+}
+
+and functor_components = {
+  fcomp_arg: functor_parameter;
+  (* Formal parameter and argument signature *)
+  fcomp_res: module_type;               (* Result signature *)
+  fcomp_cache: (Path.t, module_components) Hashtbl.t;  (* For memoization *)
+  fcomp_subst_cache: (Path.t, module_type) Hashtbl.t
+}
+
+and address_unforced =
+  | Projection of { parent : address_lazy; pos : int; }
+  | ModAlias of { env : t; path : Path.t; }
+
+and address_lazy = (address_unforced, address) EnvLazy.t
+
+and value_data =
+  { vda_description : value_description;
+    vda_address : address_lazy }
+
+and value_entry =
+  | Val_bound of value_data
+  | Val_unbound of value_unbound_reason
+
+and constructor_data =
+  { cda_description : constructor_description;
+    cda_address : address_lazy option; }
+
+and label_data = label_description
+
+and type_data =
+  { tda_declaration : type_declaration;
+    tda_descriptions : type_descriptions; }
+
+and module_data =
+  { mda_declaration : module_declaration_lazy;
+    mda_components : module_components;
+    mda_address : address_lazy; }
+
+and module_entry =
+  | Mod_local of module_data
+  | Mod_persistent
+  | Mod_unbound of module_unbound_reason
+
+and modtype_data = modtype_declaration
+
+and class_data =
+  { clda_declaration : class_declaration;
+    clda_address : address_lazy }
+
+and cltype_data = class_type_declaration
+
+let empty_structure =
+  Structure_comps {
+    comp_values = NameMap.empty;
+    comp_constrs = NameMap.empty;
+    comp_labels = NameMap.empty;
+    comp_types = NameMap.empty;
+    comp_modules = NameMap.empty; comp_modtypes = NameMap.empty;
+    comp_classes = NameMap.empty;
+    comp_cltypes = NameMap.empty }
+
+type unbound_value_hint =
+  | No_hint
+  | Missing_rec of Location.t
+
+type lookup_error =
+  | Unbound_value of Longident.t * unbound_value_hint
+  | Unbound_type of Longident.t
+  | Unbound_constructor of Longident.t
+  | Unbound_label of Longident.t
+  | Unbound_module of Longident.t
+  | Unbound_class of Longident.t
+  | Unbound_modtype of Longident.t
+  | Unbound_cltype of Longident.t
+  | Unbound_instance_variable of string
+  | Not_an_instance_variable of string
+  | Masked_instance_variable of Longident.t
+  | Masked_self_variable of Longident.t
+  | Masked_ancestor_variable of Longident.t
+  | Structure_used_as_functor of Longident.t
+  | Abstract_used_as_functor of Longident.t
+  | Functor_used_as_structure of Longident.t
+  | Abstract_used_as_structure of Longident.t
+  | Generative_used_as_applicative of Longident.t
+  | Illegal_reference_to_recursive_module
+  | Cannot_scrape_alias of Longident.t * Path.t
+
+type error =
+  | Missing_module of Location.t * Path.t * Path.t
+  | Illegal_value_name of Location.t * string
+  | Lookup_error of Location.t * t * lookup_error
+
+exception Error of error
+
+let error err = raise (Error err)
+
+let lookup_error loc env err =
+  error (Lookup_error(loc, env, err))
+
+let copy_local ~from env =
+  { env with
+    local_constraints = from.local_constraints;
+    flags = from.flags }
+
+let same_constr = ref (fun _ _ _ -> assert false)
+
+let check_well_formed_module = ref (fun _ -> assert false)
+
+(* Helper to decide whether to report an identifier shadowing
+   by some 'open'. For labels and constructors, we do not report
+   if the two elements are from the same re-exported declaration.
+
+   Later, one could also interpret some attributes on value and
+   type declarations to silence the shadowing warnings. *)
+
+let check_shadowing env = function
+  | `Constructor (Some (cda1, cda2))
+    when not (!same_constr env
+                cda1.cda_description.cstr_res
+                cda2.cda_description.cstr_res) ->
+      Some "constructor"
+  | `Label (Some (l1, l2))
+    when not (!same_constr env l1.lbl_res l2.lbl_res) ->
+      Some "label"
+  | `Value (Some _) -> Some "value"
+  | `Type (Some _) -> Some "type"
+  | `Module (Some _) | `Component (Some _) -> Some "module"
+  | `Module_type (Some _) -> Some "module type"
+  | `Class (Some _) -> Some "class"
+  | `Class_type (Some _) -> Some "class type"
+  | `Constructor _ | `Label _
+  | `Value None | `Type None | `Module None | `Module_type None
+  | `Class None | `Class_type None | `Component None ->
+      None
+
+let subst_modtype_maker (subst, scoping, md) =
+  {md with md_type = Subst.modtype scoping subst md.md_type}
+
+let empty = {
+  values = IdTbl.empty; constrs = TycompTbl.empty;
+  labels = TycompTbl.empty; types = IdTbl.empty;
+  modules = IdTbl.empty; modtypes = IdTbl.empty;
+  classes = IdTbl.empty; cltypes = IdTbl.empty;
+  summary = Env_empty; local_constraints = Path.Map.empty;
+  flags = 0;
+  functor_args = Ident.empty;
+ }
+
+let in_signature b env =
+  let flags =
+    if b then env.flags lor in_signature_flag
+    else env.flags land (lnot in_signature_flag)
+  in
+  {env with flags}
+
+let is_in_signature env = env.flags land in_signature_flag <> 0
+
+let has_local_constraints env =
+  not (Path.Map.is_empty env.local_constraints)
+
+let is_ident = function
+    Pident _ -> true
+  | Pdot _ | Papply _ -> false
+
+let is_ext cda =
+  match cda.cda_description with
+  | {cstr_tag = Cstr_extension _} -> true
+  | _ -> false
+
+let is_local_ext cda =
+  match cda.cda_description with
+  | {cstr_tag = Cstr_extension(p, _)} -> is_ident p
+  | _ -> false
+
+let diff env1 env2 =
+  IdTbl.diff_keys env1.values env2.values @
+  TycompTbl.diff_keys is_local_ext env1.constrs env2.constrs @
+  IdTbl.diff_keys env1.modules env2.modules @
+  IdTbl.diff_keys env1.classes env2.classes
+
+(* Functions for use in "wrap" parameters in IdTbl *)
+let wrap_identity x = x
+let wrap_value vda = Val_bound vda
+let wrap_module mda = Mod_local mda
+
+(* Forward declarations *)
+
+let components_of_module_maker' =
+  ref ((fun _ -> assert false) :
+          components_maker ->
+            (module_components_repr, module_components_failure) result)
+
+let components_of_functor_appl' =
+  ref ((fun ~loc:_ _f _env _p1 _p2 -> assert false) :
+          loc:Location.t -> functor_components -> t ->
+            Path.t -> Path.t -> module_components)
+let check_functor_application =
+  (* to be filled by Includemod *)
+  ref ((fun ~errors:_ ~loc:_ _env _mty1 _path1 _mty2 _path2 -> assert false) :
+          errors:bool -> loc:Location.t -> t -> module_type ->
+            Path.t -> module_type -> Path.t -> unit)
+let strengthen =
+  (* to be filled with Mtype.strengthen *)
+  ref ((fun ~aliasable:_ _env _mty _path -> assert false) :
+         aliasable:bool -> t -> module_type -> Path.t -> module_type)
+
+let md md_type =
+  {md_type; md_attributes=[]; md_loc=Location.none
+  ;md_uid = Uid.internal_not_actually_unique}
+
+(* Print addresses *)
+
+let rec print_address ppf = function
+  | Aident id -> Format.fprintf ppf "%s" (Ident.name id)
+  | Adot(a, pos) -> Format.fprintf ppf "%a.[%i]" print_address a pos
+
+(* The name of the compilation unit currently compiled.
+   "" if outside a compilation unit. *)
+module Current_unit_name : sig
+  val get : unit -> modname
+  val set : modname -> unit
+  val is : modname -> bool
+  val is_ident : Ident.t -> bool
+  val is_path : Path.t -> bool
+end = struct
+  let current_unit =
+    ref ""
+  let get () =
+    !current_unit
+  let set name =
+    current_unit := name
+  let is name =
+    !current_unit = name
+  let is_ident id =
+    Ident.persistent id && is (Ident.name id)
+  let is_path = function
+  | Pident id -> is_ident id
+  | Pdot _ | Papply _ -> false
+end
+
+let set_unit_name = Current_unit_name.set
+let get_unit_name = Current_unit_name.get
+
+let find_same_module id tbl =
+  match IdTbl.find_same id tbl with
+  | x -> x
+  | exception Not_found
+    when Ident.persistent id && not (Current_unit_name.is_ident id) ->
+      Mod_persistent
+
+let find_name_module ~mark name tbl =
+  match IdTbl.find_name wrap_module ~mark name tbl with
+  | x -> x
+  | exception Not_found when not (Current_unit_name.is name) ->
+      let path = Pident(Ident.create_persistent name) in
+      path, Mod_persistent
+
+let add_persistent_structure id env =
+  if not (Ident.persistent id) then invalid_arg "Env.add_persistent_structure";
+  if Current_unit_name.is_ident id then env
+  else begin
+    let material =
+      (* This addition only observably changes the environment if it shadows a
+         non-persistent module already in the environment.
+         (See PR#9345) *)
+      match
+        IdTbl.find_name wrap_module ~mark:false (Ident.name id) env.modules
+      with
+      | exception Not_found | _, Mod_persistent -> false
+      | _ -> true
+    in
+    let summary =
+      if material then Env_persistent (env.summary, id)
+      else env.summary
+    in
+    let modules =
+      (* With [-no-alias-deps], non-material additions should not
+         affect the environment at all. We should only observe the
+         existence of a cmi when accessing components of the module.
+         (See #9991). *)
+      if material || not !Clflags.transparent_modules then
+        IdTbl.add id Mod_persistent env.modules
+      else
+        env.modules
+    in
+    { env with modules; summary }
+  end
+
+let components_of_module ~alerts ~uid env fs ps path addr mty =
+  {
+    alerts;
+    uid;
+    comps = EnvLazy.create {
+      cm_env = env;
+      cm_freshening_subst = fs;
+      cm_prefixing_subst = ps;
+      cm_path = path;
+      cm_addr = addr;
+      cm_mty = mty
+    }
+  }
+
+let sign_of_cmi ~freshen { Persistent_env.Persistent_signature.cmi; _ } =
+  let name = cmi.cmi_name in
+  let sign = cmi.cmi_sign in
+  let flags = cmi.cmi_flags in
+  let id = Ident.create_persistent name in
+  let path = Pident id in
+  let alerts =
+    List.fold_left (fun acc -> function Alerts s -> s | _ -> acc)
+      Misc.Stdlib.String.Map.empty
+      flags
+  in
+  let md =
+    { md_type =  Mty_signature sign;
+      md_loc = Location.none;
+      md_attributes = [];
+      md_uid = Uid.of_compilation_unit_id id;
+    }
+  in
+  let mda_address = EnvLazy.create_forced (Aident id) in
+  let mda_declaration =
+    EnvLazy.create (Subst.identity, Subst.Make_local, md)
+  in
+  let mda_components =
+    let freshening_subst =
+      if freshen then (Some Subst.identity) else None
+    in
+    components_of_module ~alerts ~uid:md.md_uid
+      empty freshening_subst Subst.identity
+      path mda_address (Mty_signature sign)
+  in
+  {
+    mda_declaration;
+    mda_components;
+    mda_address;
+  }
+
+let read_sign_of_cmi = sign_of_cmi ~freshen:true
+
+let save_sign_of_cmi = sign_of_cmi ~freshen:false
+
+let persistent_env : module_data Persistent_env.t ref =
+  s_table Persistent_env.empty ()
+
+let without_cmis f x =
+  Persistent_env.without_cmis !persistent_env f x
+
+let imports () = Persistent_env.imports !persistent_env
+
+let import_crcs ~source crcs =
+  Persistent_env.import_crcs !persistent_env ~source crcs
+
+let read_pers_mod modname filename =
+  Persistent_env.read !persistent_env read_sign_of_cmi modname filename
+
+let find_pers_mod name =
+  Persistent_env.find !persistent_env read_sign_of_cmi name
+
+let check_pers_mod ~loc name =
+  Persistent_env.check !persistent_env read_sign_of_cmi ~loc name
+
+let crc_of_unit name =
+  Persistent_env.crc_of_unit !persistent_env read_sign_of_cmi name
+
+let is_imported_opaque modname =
+  Persistent_env.is_imported_opaque !persistent_env modname
+
+let register_import_as_opaque modname =
+  Persistent_env.register_import_as_opaque !persistent_env modname
+
+let reset_declaration_caches () =
+  Types.Uid.Tbl.clear !value_declarations;
+  Types.Uid.Tbl.clear !type_declarations;
+  Types.Uid.Tbl.clear !module_declarations;
+  Types.Uid.Tbl.clear !used_constructors;
+  ()
+
+let reset_cache () =
+  Current_unit_name.set "";
+  Persistent_env.clear !persistent_env;
+  reset_declaration_caches ();
+  ()
+
+let reset_cache_toplevel () =
+  Persistent_env.clear_missing !persistent_env;
+  reset_declaration_caches ();
+  ()
+
+(* get_components *)
+
+let get_components_res c =
+  match Persistent_env.can_load_cmis !persistent_env with
+  | Persistent_env.Can_load_cmis ->
+    EnvLazy.force !components_of_module_maker' c.comps
+  | Persistent_env.Cannot_load_cmis log ->
+    EnvLazy.force_logged log !components_of_module_maker' c.comps
+
+let get_components c =
+  match get_components_res c with
+  | Error _ -> empty_structure
+  | Ok c -> c
+
+(* Module type of functor application *)
+
+let modtype_of_functor_appl fcomp p1 p2 =
+  match fcomp.fcomp_res with
+  | Mty_alias _ as mty -> mty
+  | mty ->
+      try
+        Hashtbl.find fcomp.fcomp_subst_cache p2
+      with Not_found ->
+        let scope = Path.scope (Papply(p1, p2)) in
+        let mty =
+          let subst =
+            match fcomp.fcomp_arg with
+            | Unit
+            | Named (None, _) -> Subst.identity
+            | Named (Some param, _) -> Subst.add_module param p2 Subst.identity
+          in
+          Subst.modtype (Rescope scope) subst mty
+        in
+        Hashtbl.add fcomp.fcomp_subst_cache p2 mty;
+        mty
+
+let check_functor_appl ~errors ~loc env p1 f arg p2 md =
+  if not (Hashtbl.mem f.fcomp_cache p2) then
+    !check_functor_application ~errors ~loc env md.md_type p2 arg p1
+
+(* Lookup by identifier *)
+
+let find_ident_module id env =
+  match find_same_module id env.modules with
+  | Mod_local data -> data
+  | Mod_unbound _ -> raise Not_found
+  | Mod_persistent -> find_pers_mod (Ident.name id)
+
+let rec find_module_components path env =
+  match path with
+  | Pident id -> (find_ident_module id env).mda_components
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      (NameMap.find s sc.comp_modules).mda_components
+  | Papply(p1, p2) ->
+      let fc = find_functor_components p1 env in
+      let loc = Location.(in_file !input_name) in
+      !components_of_functor_appl' ~loc fc env p1 p2
+
+and find_structure_components path env =
+  match get_components (find_module_components path env) with
+  | Structure_comps c -> c
+  | Functor_comps _ -> raise Not_found
+
+and find_functor_components path env =
+  match get_components (find_module_components path env) with
+  | Functor_comps f -> f
+  | Structure_comps _ -> raise Not_found
+
+let find_module ~alias path env =
+  match path with
+  | Pident id ->
+      let data = find_ident_module id env in
+      EnvLazy.force subst_modtype_maker data.mda_declaration
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      let data = NameMap.find s sc.comp_modules in
+      EnvLazy.force subst_modtype_maker data.mda_declaration
+  | Papply(p1, p2) ->
+      let fc = find_functor_components p1 env in
+      if alias then md (fc.fcomp_res)
+      else md (modtype_of_functor_appl fc p1 p2)
+
+let find_value_full path env =
+  match path with
+  | Pident id -> begin
+      match IdTbl.find_same id env.values with
+      | Val_bound data -> data
+      | Val_unbound _ -> raise Not_found
+    end
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      NameMap.find s sc.comp_values
+  | Papply _ -> raise Not_found
+
+let find_type_full path env =
+  match path with
+  | Pident id -> IdTbl.find_same id env.types
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      NameMap.find s sc.comp_types
+  | Papply _ -> raise Not_found
+
+let find_modtype path env =
+  match path with
+  | Pident id -> IdTbl.find_same id env.modtypes
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      NameMap.find s sc.comp_modtypes
+  | Papply _ -> raise Not_found
+
+let find_class_full path env =
+  match path with
+  | Pident id -> IdTbl.find_same id env.classes
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      NameMap.find s sc.comp_classes
+  | Papply _ -> raise Not_found
+
+let find_cltype path env =
+  match path with
+  | Pident id -> IdTbl.find_same id env.cltypes
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      NameMap.find s sc.comp_cltypes
+  | Papply _ -> raise Not_found
+
+let find_value path env =
+  (find_value_full path env).vda_description
+
+let find_class path env =
+  (find_class_full path env).clda_declaration
+
+let find_ident_constructor id env =
+  (TycompTbl.find_same id env.constrs).cda_description
+
+let find_ident_label id env =
+  TycompTbl.find_same id env.labels
+
+let type_of_cstr path = function
+  | {cstr_inlined = Some decl; _} ->
+      let labels =
+        List.map snd (Datarepr.labels_of_type path decl)
+      in
+      { tda_declaration = decl; tda_descriptions = ([], labels) }
+  | _ ->
+      assert false
+
+let find_type_full path env =
+  match Path.constructor_typath path with
+  | Regular p -> begin
+      match Path.Map.find p env.local_constraints with
+      | decl ->
+          { tda_declaration = decl; tda_descriptions = [], [] }
+      | exception Not_found -> find_type_full p env
+    end
+  | Cstr (ty_path, s) ->
+      let tda =
+        try find_type_full ty_path env
+        with Not_found -> assert false
+      in
+      let (cstrs, _) = tda.tda_descriptions in
+      let cstr =
+        try List.find (fun cstr -> cstr.cstr_name = s) cstrs
+        with Not_found -> assert false
+      in
+      type_of_cstr path cstr
+  | LocalExt id ->
+      let cstr =
+        try (TycompTbl.find_same id env.constrs).cda_description
+        with Not_found -> assert false
+      in
+      type_of_cstr path cstr
+  | Ext (mod_path, s) ->
+      let comps =
+        try find_structure_components mod_path env
+        with Not_found -> assert false
+      in
+      let cstrs =
+        try NameMap.find s comps.comp_constrs
+        with Not_found -> assert false
+      in
+      let exts = List.filter is_ext cstrs in
+      match exts with
+      | [cda] -> type_of_cstr path cda.cda_description
+      | _ -> assert false
+
+let find_type p env =
+  (find_type_full p env).tda_declaration
+let find_type_descrs p env =
+  (find_type_full p env).tda_descriptions
+
+let rec find_module_address path env =
+  match path with
+  | Pident id -> get_address (find_ident_module id env).mda_address
+  | Pdot(p, s) ->
+      let c = find_structure_components p env in
+      get_address (NameMap.find s c.comp_modules).mda_address
+  | Papply _ -> raise Not_found
+
+and force_address = function
+  | Projection { parent; pos } -> Adot(get_address parent, pos)
+  | ModAlias { env; path } -> find_module_address path env
+
+and get_address a =
+  EnvLazy.force force_address a
+
+let find_value_address path env =
+  get_address (find_value_full path env).vda_address
+
+let find_class_address path env =
+  get_address (find_class_full path env).clda_address
+
+let rec get_constrs_address = function
+  | [] -> raise Not_found
+  | cda :: rest ->
+    match cda.cda_address with
+    | None -> get_constrs_address rest
+    | Some a -> get_address a
+
+let find_constructor_address path env =
+  match path with
+  | Pident id -> begin
+      let cda = TycompTbl.find_same id env.constrs in
+      match cda.cda_address with
+      | None -> raise Not_found
+      | Some addr -> get_address addr
+    end
+  | Pdot(p, s) ->
+      let c = find_structure_components p env in
+      get_constrs_address (NameMap.find s c.comp_constrs)
+  | Papply _ ->
+      raise Not_found
+
+let find_hash_type path env =
+  match path with
+  | Pident id ->
+      let name = "#" ^ Ident.name id in
+      let _, tda =
+        IdTbl.find_name wrap_identity ~mark:false name env.types
+      in
+      tda.tda_declaration
+  | Pdot(p, s) ->
+      let c = find_structure_components p env in
+      let name = "#" ^ s in
+      let tda = NameMap.find name c.comp_types in
+      tda.tda_declaration
+  | Papply _ ->
+      raise Not_found
+
+let required_globals = s_ref []
+let reset_required_globals () = required_globals := []
+let get_required_globals () = !required_globals
+let add_required_global id =
+  if Ident.global id && not !Clflags.transparent_modules
+  && not (List.exists (Ident.same id) !required_globals)
+  then required_globals := id :: !required_globals
+
+let rec normalize_module_path lax env = function
+  | Pident id as path when lax && Ident.persistent id ->
+      path (* fast path (avoids lookup) *)
+  | Pdot (p, s) as path ->
+      let p' = normalize_module_path lax env p in
+      if p == p' then expand_module_path lax env path
+      else expand_module_path lax env (Pdot(p', s))
+  | Papply (p1, p2) as path ->
+      let p1' = normalize_module_path lax env p1 in
+      let p2' = normalize_module_path true env p2 in
+      if p1 == p1' && p2 == p2' then expand_module_path lax env path
+      else expand_module_path lax env (Papply(p1', p2'))
+  | Pident _ as path ->
+      expand_module_path lax env path
+
+and expand_module_path lax env path =
+  try match find_module ~alias:true path env with
+    {md_type=Mty_alias path1} ->
+      let path' = normalize_module_path lax env path1 in
+      if lax || !Clflags.transparent_modules then path' else
+      let id = Path.head path in
+      if Ident.global id && not (Ident.same id (Path.head path'))
+      then add_required_global id;
+      path'
+  | _ -> path
+  with Not_found when lax
+  || (match path with Pident id -> not (Ident.persistent id) | _ -> true) ->
+      path
+
+let normalize_module_path oloc env path =
+  try normalize_module_path (oloc = None) env path
+  with Not_found ->
+    match oloc with None -> assert false
+    | Some loc ->
+        error (Missing_module(loc, path,
+                              normalize_module_path true env path))
+
+let normalize_path_prefix oloc env path =
+  match path with
+    Pdot(p, s) ->
+      let p2 = normalize_module_path oloc env p in
+      if p == p2 then path else Pdot(p2, s)
+  | Pident _ ->
+      path
+  | Papply _ ->
+      assert false
+
+let normalize_type_path oloc env path =
+  (* Inlined version of Path.is_constructor_typath:
+     constructor type paths (i.e. path pointing to an inline
+     record argument of a constructpr) are built as a regular
+     type path followed by a capitalized constructor name. *)
+  match path with
+  | Pident _ ->
+      path
+  | Pdot(p, s) ->
+      let p2 =
+        if Path.is_uident s && not (Path.is_uident (Path.last p)) then
+          (* Cstr M.t.C *)
+          normalize_path_prefix oloc env p
+        else
+          (* Regular M.t, Ext M.C *)
+          normalize_module_path oloc env p
+      in
+      if p == p2 then path else Pdot (p2, s)
+  | Papply _ ->
+      assert false
+
+let rec normalize_modtype_path env path =
+  let path = normalize_path_prefix None env path in
+  expand_modtype_path env path
+
+and expand_modtype_path env path =
+  match (find_modtype path env).mtd_type with
+  | Some (Mty_ident path) -> normalize_modtype_path env path
+  | _ | exception Not_found -> path
+
+let find_module path env =
+  find_module ~alias:false path env
+
+(* Find the manifest type associated to a type when appropriate:
+   - the type should be public or should have a private row,
+   - the type should have an associated manifest type. *)
+let find_type_expansion path env =
+  let decl = find_type path env in
+  match decl.type_manifest with
+  | Some body when decl.type_private = Public
+              || decl.type_kind <> Type_abstract
+              || Btype.has_constr_row body ->
+      (decl.type_params, body, decl.type_expansion_scope)
+  (* The manifest type of Private abstract data types without
+     private row are still considered unknown to the type system.
+     Hence, this case is caught by the following clause that also handles
+     purely abstract data types without manifest type definition. *)
+  | _ -> raise Not_found
+
+(* Find the manifest type information associated to a type, i.e.
+   the necessary information for the compiler's type-based optimisations.
+   In particular, the manifest type associated to a private abstract type
+   is revealed for the sake of compiler's type-based optimisations. *)
+let find_type_expansion_opt path env =
+  let decl = find_type path env in
+  match decl.type_manifest with
+  (* The manifest type of Private abstract data types can still get
+     an approximation using their manifest type. *)
+  | Some body ->
+      (decl.type_params, body, decl.type_expansion_scope)
+  | _ -> raise Not_found
+
+let find_modtype_expansion path env =
+  match (find_modtype path env).mtd_type with
+  | None -> raise Not_found
+  | Some mty -> mty
+
+let rec is_functor_arg path env =
+  match path with
+    Pident id ->
+      begin try Ident.find_same id env.functor_args; true
+      with Not_found -> false
+      end
+  | Pdot (p, _s) -> is_functor_arg p env
+  | Papply _ -> true
+
+(* Copying types associated with values *)
+
+let make_copy_of_types env0 =
+  let memo = Hashtbl.create 16 in
+  let copy t =
+    try
+      Hashtbl.find memo t.id
+    with Not_found ->
+      let t2 = Subst.type_expr Subst.identity t in
+      Hashtbl.add memo t.id t2;
+      t2
+  in
+  let f = function
+    | Val_unbound _ as entry -> entry
+    | Val_bound vda ->
+        let desc = vda.vda_description in
+        let desc = { desc with val_type = copy desc.val_type } in
+        Val_bound { vda with vda_description = desc }
+  in
+  let values =
+    IdTbl.map f env0.values
+  in
+  (fun env ->
+     if env.values != env0.values then fatal_error "Env.make_copy_of_types";
+     {env with values; summary = Env_copy_types env.summary}
+  )
+
+(* Helper to handle optional substitutions. *)
+
+let may_subst subst_f sub x =
+  match sub with
+  | None -> x
+  | Some sub -> subst_f sub x
+
+(* Iter on an environment (ignoring the body of functors and
+   not yet evaluated structures) *)
+
+type iter_cont = unit -> unit
+let iter_env_cont = ref []
+
+let rec scrape_alias_for_visit env (sub : Subst.t option) mty =
+  match mty with
+  | Mty_alias path ->
+      begin match may_subst Subst.module_path sub path with
+      | Pident id
+        when Ident.persistent id
+          && not (Persistent_env.looked_up !persistent_env (Ident.name id)) ->
+          false
+      | path -> (* PR#6600: find_module may raise Not_found *)
+          try scrape_alias_for_visit env sub (find_module path env).md_type
+          with Not_found -> false
+      end
+  | _ -> true
+
+let iter_env wrap proj1 proj2 f env () =
+  IdTbl.iter wrap (fun id x -> f (Pident id) x) (proj1 env);
+  let rec iter_components path path' mcomps =
+    let cont () =
+      let visit =
+        match EnvLazy.get_arg mcomps.comps with
+        | None -> true
+        | Some { cm_mty; cm_freshening_subst; _ } ->
+            scrape_alias_for_visit env cm_freshening_subst cm_mty
+      in
+      if not visit then () else
+      match get_components mcomps with
+        Structure_comps comps ->
+          NameMap.iter
+            (fun s d -> f (Pdot (path, s)) (Pdot (path', s), d))
+            (proj2 comps);
+          NameMap.iter
+            (fun s mda ->
+              iter_components
+                (Pdot (path, s)) (Pdot (path', s)) mda.mda_components)
+            comps.comp_modules
+      | Functor_comps _ -> ()
+    in iter_env_cont := (path, cont) :: !iter_env_cont
+  in
+  IdTbl.iter wrap_module
+    (fun id (path, entry) ->
+       match entry with
+       | Mod_unbound _ -> ()
+       | Mod_local data ->
+           iter_components (Pident id) path data.mda_components
+       | Mod_persistent ->
+           let modname = Ident.name id in
+           match Persistent_env.find_in_cache !persistent_env modname with
+           | None -> ()
+           | Some data ->
+               iter_components (Pident id) path data.mda_components)
+    env.modules
+
+let run_iter_cont l =
+  iter_env_cont := [];
+  List.iter (fun c -> c ()) l;
+  let cont = List.rev !iter_env_cont in
+  iter_env_cont := [];
+  cont
+
+let iter_types f =
+  iter_env wrap_identity (fun env -> env.types) (fun sc -> sc.comp_types)
+    (fun p1 (p2, tda) -> f p1 (p2, tda.tda_declaration))
+
+let same_types env1 env2 =
+  env1.types == env2.types && env1.modules == env2.modules
+
+let used_persistent () =
+  Persistent_env.fold !persistent_env
+    (fun s _m r -> Concr.add s r)
+    Concr.empty
+
+let find_all_comps wrap proj s (p, mda) =
+  match get_components mda.mda_components with
+    Functor_comps _ -> []
+  | Structure_comps comps ->
+      try
+        let c = NameMap.find s (proj comps) in
+        [Pdot(p,s), wrap c]
+      with Not_found -> []
+
+let rec find_shadowed_comps path env =
+  match path with
+  | Pident id ->
+      List.filter_map
+        (fun (p, data) ->
+           match data with
+           | Mod_local x -> Some (p, x)
+           | Mod_unbound _ | Mod_persistent -> None)
+        (IdTbl.find_all wrap_module (Ident.name id) env.modules)
+  | Pdot (p, s) ->
+      let l = find_shadowed_comps p env in
+      let l' =
+        List.map
+          (find_all_comps wrap_identity
+             (fun comps -> comps.comp_modules) s) l
+      in
+      List.flatten l'
+  | Papply _ -> []
+
+let find_shadowed wrap proj1 proj2 path env =
+  match path with
+    Pident id ->
+      IdTbl.find_all wrap (Ident.name id) (proj1 env)
+  | Pdot (p, s) ->
+      let l = find_shadowed_comps p env in
+      let l' = List.map (find_all_comps wrap proj2 s) l in
+      List.flatten l'
+  | Papply _ -> []
+
+let find_shadowed_types path env =
+  List.map fst
+    (find_shadowed wrap_identity
+       (fun env -> env.types) (fun comps -> comps.comp_types) path env)
+
+(* Expand manifest module type names at the top of the given module type *)
+
+let rec scrape_alias env sub ?path mty =
+  match mty, path with
+    Mty_ident _, _ ->
+      let p =
+        match may_subst (Subst.modtype Keep) sub mty with
+        | Mty_ident p -> p
+        | _ -> assert false (* only [Mty_ident]s in [sub] *)
+      in
+      begin try
+        scrape_alias env sub (find_modtype_expansion p env) ?path
+      with Not_found ->
+        mty
+      end
+  | Mty_alias path, _ ->
+      let path = may_subst Subst.module_path sub path in
+      begin try
+        scrape_alias env sub (find_module path env).md_type ~path
+      with Not_found ->
+        (*Location.prerr_warning Location.none
+          (Warnings.No_cmi_file (Path.name path));*)
+        mty
+      end
+  | mty, Some path ->
+      !strengthen ~aliasable:true env mty path
+  | _ -> mty
+
+(* Given a signature and a root path, prefix all idents in the signature
+   by the root path and build the corresponding substitution. *)
+
+let prefix_idents root freshening_sub prefixing_sub sg =
+  let refresh id add_fn = function
+    | None -> id, None
+    | Some sub ->
+      let id' = Ident.rename id in
+      id', Some (add_fn id (Pident id') sub)
+  in
+  let rec prefix_idents root items_and_paths freshening_sub prefixing_sub =
+    function
+    | [] -> (List.rev items_and_paths, freshening_sub, prefixing_sub)
+    | Sig_value(id, _, _) as item :: rem ->
+      let p = Pdot(root, Ident.name id) in
+      prefix_idents root
+        ((item, p) :: items_and_paths) freshening_sub prefixing_sub rem
+    | Sig_type(id, td, rs, vis) :: rem ->
+      let p = Pdot(root, Ident.name id) in
+      let id', freshening_sub = refresh id Subst.add_type freshening_sub in
+      prefix_idents root
+        ((Sig_type(id', td, rs, vis), p) :: items_and_paths)
+        freshening_sub
+        (Subst.add_type id' p prefixing_sub)
+        rem
+    | Sig_typext(id, ec, es, vis) :: rem ->
+      let p = Pdot(root, Ident.name id) in
+      let id', freshening_sub = refresh id Subst.add_type freshening_sub in
+      (* we extend the substitution in case of an inlined record *)
+      prefix_idents root
+        ((Sig_typext(id', ec, es, vis), p) :: items_and_paths)
+        freshening_sub
+        (Subst.add_type id' p prefixing_sub)
+        rem
+    | Sig_module(id, pres, md, rs, vis) :: rem ->
+      let p = Pdot(root, Ident.name id) in
+      let id', freshening_sub = refresh id Subst.add_module freshening_sub in
+      prefix_idents root
+        ((Sig_module(id', pres, md, rs, vis), p) :: items_and_paths)
+        freshening_sub
+        (Subst.add_module id' p prefixing_sub)
+        rem
+    | Sig_modtype(id, mtd, vis) :: rem ->
+      let p = Pdot(root, Ident.name id) in
+      let id', freshening_sub =
+        refresh id (fun i p s -> Subst.add_modtype i (Mty_ident p) s)
+          freshening_sub
+      in
+      prefix_idents root
+        ((Sig_modtype(id', mtd, vis), p) :: items_and_paths)
+        freshening_sub
+        (Subst.add_modtype id' (Mty_ident p) prefixing_sub)
+        rem
+    | Sig_class(id, cd, rs, vis) :: rem ->
+      (* pretend this is a type, cf. PR#6650 *)
+      let p = Pdot(root, Ident.name id) in
+      let id', freshening_sub = refresh id Subst.add_type freshening_sub in
+      prefix_idents root
+        ((Sig_class(id', cd, rs, vis), p) :: items_and_paths)
+        freshening_sub
+        (Subst.add_type id' p prefixing_sub)
+        rem
+    | Sig_class_type(id, ctd, rs, vis) :: rem ->
+      let p = Pdot(root, Ident.name id) in
+      let id', freshening_sub = refresh id Subst.add_type freshening_sub in
+      prefix_idents root
+        ((Sig_class_type(id', ctd, rs, vis), p) :: items_and_paths)
+        freshening_sub
+        (Subst.add_type id' p prefixing_sub)
+        rem
+  in
+  prefix_idents root [] freshening_sub prefixing_sub sg
+
+(* Compute structure descriptions *)
+
+let add_to_tbl id decl tbl =
+  let decls = try NameMap.find id tbl with Not_found -> [] in
+  NameMap.add id (decl :: decls) tbl
+
+let value_declaration_address (_ : t) id decl =
+  match decl.val_kind with
+  | Val_prim _ -> EnvLazy.create_failed Not_found
+  | _ -> EnvLazy.create_forced (Aident id)
+
+let extension_declaration_address (_ : t) id (_ : extension_constructor) =
+  EnvLazy.create_forced (Aident id)
+
+let class_declaration_address (_ : t) id (_ : class_declaration) =
+  EnvLazy.create_forced (Aident id)
+
+let module_declaration_address env id presence md =
+  match presence with
+  | Mp_absent -> begin
+      match md.md_type with
+      | Mty_alias path -> EnvLazy.create (ModAlias {env; path})
+      | _ -> assert false
+    end
+  | Mp_present ->
+      EnvLazy.create_forced (Aident id)
+
+let is_identchar c =
+  (* This should be kept in sync with the [identchar_latin1] character class
+     in [lexer.mll] *)
+  match c with
+  | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214'
+  | '\216'..'\246' | '\248'..'\255' | '\'' | '0'..'9' ->
+    true
+  | _ ->
+    false
+
+let rec components_of_module_maker
+          {cm_env; cm_freshening_subst; cm_prefixing_subst;
+           cm_path; cm_addr; cm_mty} : _ result =
+  match scrape_alias cm_env cm_freshening_subst cm_mty with
+    Mty_signature sg ->
+      let c =
+        { comp_values = NameMap.empty;
+          comp_constrs = NameMap.empty;
+          comp_labels = NameMap.empty; comp_types = NameMap.empty;
+          comp_modules = NameMap.empty; comp_modtypes = NameMap.empty;
+          comp_classes = NameMap.empty; comp_cltypes = NameMap.empty }
+      in
+      let items_and_paths, freshening_sub, prefixing_sub =
+        prefix_idents cm_path cm_freshening_subst cm_prefixing_subst sg
+      in
+      let env = ref cm_env in
+      let pos = ref 0 in
+      let next_address () =
+        let addr : address_unforced =
+          Projection { parent = cm_addr; pos = !pos }
+        in
+        incr pos;
+        EnvLazy.create addr
+      in
+      let sub = may_subst Subst.compose freshening_sub prefixing_sub in
+      List.iter (fun (item, path) ->
+        match item with
+          Sig_value(id, decl, _) ->
+            let decl' = Subst.value_description sub decl in
+            let addr =
+              match decl.val_kind with
+              | Val_prim _ -> EnvLazy.create_failed Not_found
+              | _ -> next_address ()
+            in
+            let vda = { vda_description = decl'; vda_address = addr } in
+            c.comp_values <- NameMap.add (Ident.name id) vda c.comp_values;
+        | Sig_type(id, decl, _, _) ->
+            let fresh_decl =
+              may_subst Subst.type_declaration freshening_sub decl
+            in
+            let final_decl = Subst.type_declaration prefixing_sub fresh_decl in
+            Datarepr.set_row_name final_decl
+              (Subst.type_path prefixing_sub (Path.Pident id));
+            let constructors =
+              List.map snd
+                (Datarepr.constructors_of_type ~current_unit:(get_unit_name ())
+                   path final_decl)
+            in
+            let labels =
+              List.map snd (Datarepr.labels_of_type path final_decl) in
+            let tda =
+              { tda_declaration = final_decl;
+                tda_descriptions = (constructors, labels); }
+            in
+            c.comp_types <- NameMap.add (Ident.name id) tda c.comp_types;
+            List.iter
+              (fun descr ->
+                 let cda = { cda_description = descr; cda_address = None } in
+                 c.comp_constrs <-
+                   add_to_tbl descr.cstr_name cda c.comp_constrs)
+              constructors;
+            List.iter
+              (fun descr ->
+                c.comp_labels <-
+                  add_to_tbl descr.lbl_name descr c.comp_labels)
+              labels;
+            env := store_type_infos id fresh_decl !env
+        | Sig_typext(id, ext, _, _) ->
+            let ext' = Subst.extension_constructor sub ext in
+            let descr =
+              Datarepr.extension_descr ~current_unit:(get_unit_name ()) path
+                ext'
+            in
+            let addr = next_address () in
+            let cda = { cda_description = descr; cda_address = Some addr } in
+            c.comp_constrs <- add_to_tbl (Ident.name id) cda c.comp_constrs
+        | Sig_module(id, pres, md, _, _) ->
+            let md' =
+              (* The prefixed items get the same scope as [cm_path], which is
+                 the prefix. *)
+              EnvLazy.create (sub, Subst.Rescope (Path.scope cm_path), md)
+            in
+            let addr =
+              match pres with
+              | Mp_absent -> begin
+                  match md.md_type with
+                  | Mty_alias p ->
+                      let path = may_subst Subst.module_path freshening_sub p in
+                      EnvLazy.create (ModAlias {env = !env; path})
+                  | _ -> assert false
+                end
+              | Mp_present -> next_address ()
+            in
+            let alerts =
+              Builtin_attributes.alerts_of_attrs md.md_attributes
+            in
+            let comps =
+              components_of_module ~alerts ~uid:md.md_uid !env freshening_sub
+                prefixing_sub path addr md.md_type
+            in
+            let mda =
+              { mda_declaration = md';
+                mda_components = comps;
+                mda_address = addr }
+            in
+            c.comp_modules <-
+              NameMap.add (Ident.name id) mda c.comp_modules;
+            env :=
+              store_module ~freshening_sub ~check:None id addr pres md !env
+        | Sig_modtype(id, decl, _) ->
+            let fresh_decl =
+              (* the fresh_decl is only going in the local temporary env, and
+                 shouldn't be used for anything. So we make the items local. *)
+              may_subst (Subst.modtype_declaration Make_local) freshening_sub
+                decl
+            in
+            let final_decl =
+              (* The prefixed items get the same scope as [cm_path], which is
+                 the prefix. *)
+              Subst.modtype_declaration (Rescope (Path.scope cm_path))
+                prefixing_sub fresh_decl
+            in
+            c.comp_modtypes <-
+              NameMap.add (Ident.name id) final_decl c.comp_modtypes;
+            env := store_modtype id fresh_decl !env
+        | Sig_class(id, decl, _, _) ->
+            let decl' = Subst.class_declaration sub decl in
+            let addr = next_address () in
+            let clda = { clda_declaration = decl'; clda_address = addr } in
+            c.comp_classes <- NameMap.add (Ident.name id) clda c.comp_classes
+        | Sig_class_type(id, decl, _, _) ->
+            let decl' = Subst.cltype_declaration sub decl in
+            c.comp_cltypes <-
+              NameMap.add (Ident.name id) decl' c.comp_cltypes)
+        items_and_paths;
+        Ok (Structure_comps c)
+  | Mty_functor(arg, ty_res) ->
+      let sub =
+        may_subst Subst.compose cm_freshening_subst cm_prefixing_subst
+      in
+      let scoping = Subst.Rescope (Path.scope cm_path) in
+        Ok (Functor_comps {
+          (* fcomp_arg and fcomp_res must be prefixed eagerly, because
+             they are interpreted in the outer environment *)
+          fcomp_arg =
+            (match arg with
+            | Unit -> Unit
+            | Named (param, ty_arg) ->
+              Named (param, Subst.modtype scoping sub ty_arg));
+          fcomp_res = Subst.modtype scoping sub ty_res;
+          fcomp_cache = Hashtbl.create 17;
+          fcomp_subst_cache = Hashtbl.create 17 })
+  | Mty_ident _ -> Error No_components_abstract
+  | Mty_alias p -> Error (No_components_alias p)
+
+(* Insertion of bindings by identifier + path *)
+
+and check_usage loc id uid warn tbl =
+  if not loc.Location.loc_ghost &&
+     Uid.for_actual_declaration uid &&
+     Warnings.is_active (warn "")
+  then begin
+    let name = Ident.name id in
+    if Types.Uid.Tbl.mem tbl uid then ()
+    else let used = ref false in
+    Types.Uid.Tbl.add tbl uid (fun () -> used := true);
+    if not (name = "" || name.[0] = '_' || name.[0] = '#')
+    then
+      !add_delayed_check_forward
+        (fun () -> if not !used then Location.prerr_warning loc (warn name))
+  end;
+
+and check_value_name name loc =
+  (* Note: we could also check here general validity of the
+     identifier, to protect against bad identifiers forged by -pp or
+     -ppx preprocessors. *)
+  if String.length name > 0 && not (is_identchar name.[0]) then
+    for i = 1 to String.length name - 1 do
+      if name.[i] = '#' then
+        error (Illegal_value_name(loc, name))
+    done
+
+and store_value ?check id addr decl env =
+  check_value_name (Ident.name id) decl.val_loc;
+  Option.iter
+    (fun f -> check_usage decl.val_loc id decl.val_uid f !value_declarations)
+    check;
+  let vda = { vda_description = decl; vda_address = addr } in
+  { env with
+    values = IdTbl.add id (Val_bound vda) env.values;
+    summary = Env_value(env.summary, id, decl) }
+
+and store_type ~check id info env =
+  let loc = info.type_loc in
+  if check then
+    check_usage loc id info.type_uid
+      (fun s -> Warnings.Unused_type_declaration s)
+      !type_declarations;
+  let path = Pident id in
+  let constructors =
+    Datarepr.constructors_of_type path info
+      ~current_unit:(get_unit_name ())
+  in
+  let labels = Datarepr.labels_of_type path info in
+  let descrs = (List.map snd constructors, List.map snd labels) in
+  let tda = { tda_declaration = info; tda_descriptions = descrs } in
+  if check && not loc.Location.loc_ghost &&
+    Warnings.is_active (Warnings.Unused_constructor ("", false, false))
+  then begin
+    let ty_name = Ident.name id in
+    let priv = info.type_private in
+    List.iter
+      begin fun (_, cstr) ->
+        let name = cstr.cstr_name in
+        let loc = cstr.cstr_loc in
+        let k = cstr.cstr_uid in
+        if not (Types.Uid.Tbl.mem !used_constructors k) then
+          let used = constructor_usages () in
+          Types.Uid.Tbl.add !used_constructors k
+            (add_constructor_usage ~rebind:false priv used);
+          if not (ty_name = "" || ty_name.[0] = '_')
+          then !add_delayed_check_forward
+              (fun () ->
+                if not (is_in_signature env) && not used.cu_positive then
+                  Location.prerr_warning loc
+                    (Warnings.Unused_constructor
+                       (name, used.cu_pattern, used.cu_privatize)))
+      end
+      constructors
+  end;
+  { env with
+    constrs =
+      List.fold_right
+        (fun (id, descr) constrs ->
+           let cda = { cda_description = descr; cda_address = None } in
+           TycompTbl.add id cda constrs)
+        constructors env.constrs;
+    labels =
+      List.fold_right
+        (fun (id, descr) labels -> TycompTbl.add id descr labels)
+        labels env.labels;
+    types = IdTbl.add id tda env.types;
+    summary = Env_type(env.summary, id, info) }
+
+and store_type_infos id info env =
+  (* Simplified version of store_type that doesn't compute and store
+     constructor and label infos, but simply record the arity and
+     manifest-ness of the type.  Used in components_of_module to
+     keep track of type abbreviations (e.g. type t = float) in the
+     computation of label representations. *)
+  let tda = { tda_declaration = info; tda_descriptions = [], [] } in
+  { env with
+    types = IdTbl.add id tda env.types;
+    summary = Env_type(env.summary, id, info) }
+
+and store_extension ~check ~rebind id addr ext env =
+  let loc = ext.ext_loc in
+  let cstr =
+    Datarepr.extension_descr ~current_unit:(get_unit_name ()) (Pident id) ext
+  in
+  let cda = { cda_description = cstr; cda_address = Some addr } in
+  if check && not loc.Location.loc_ghost &&
+    Warnings.is_active (Warnings.Unused_extension ("", false, false, false))
+  then begin
+    let priv = ext.ext_private in
+    let is_exception = Path.same ext.ext_type_path Predef.path_exn in
+    let name = cstr.cstr_name in
+    let k = cstr.cstr_uid in
+    if not (Types.Uid.Tbl.mem !used_constructors k) then begin
+      let used = constructor_usages () in
+      Types.Uid.Tbl.add !used_constructors k
+        (add_constructor_usage ~rebind priv used);
+      !add_delayed_check_forward
+        (fun () ->
+          if not (is_in_signature env) && not used.cu_positive then
+            Location.prerr_warning loc
+              (Warnings.Unused_extension
+                 (name, is_exception, used.cu_pattern, used.cu_privatize)
+              )
+        )
+    end;
+  end;
+  { env with
+    constrs = TycompTbl.add id cda env.constrs;
+    summary = Env_extension(env.summary, id, ext) }
+
+and store_module ~check ~freshening_sub id addr presence md env =
+  let loc = md.md_loc in
+  Option.iter
+    (fun f -> check_usage loc id md.md_uid f !module_declarations) check;
+  let alerts = Builtin_attributes.alerts_of_attrs md.md_attributes in
+  let module_decl_lazy =
+    match freshening_sub with
+    | None -> EnvLazy.create_forced md
+    | Some s -> EnvLazy.create (s, Subst.Rescope (Ident.scope id), md)
+  in
+  let comps =
+    components_of_module ~alerts ~uid:md.md_uid
+      env freshening_sub Subst.identity (Pident id) addr md.md_type
+  in
+  let mda =
+    { mda_declaration = module_decl_lazy;
+      mda_components = comps;
+      mda_address = addr }
+  in
+  { env with
+    modules = IdTbl.add id (Mod_local mda) env.modules;
+    summary = Env_module(env.summary, id, presence, md) }
+
+and store_modtype id info env =
+  { env with
+    modtypes = IdTbl.add id info env.modtypes;
+    summary = Env_modtype(env.summary, id, info) }
+
+and store_class id addr desc env =
+  let clda = { clda_declaration = desc; clda_address = addr } in
+  { env with
+    classes = IdTbl.add id clda env.classes;
+    summary = Env_class(env.summary, id, desc) }
+
+and store_cltype id desc env =
+  { env with
+    cltypes = IdTbl.add id desc env.cltypes;
+    summary = Env_cltype(env.summary, id, desc) }
+
+let scrape_alias env mty = scrape_alias env None mty
+
+(* Compute the components of a functor application in a path. *)
+
+let components_of_functor_appl ~loc f env p1 p2 =
+  try
+    Hashtbl.find f.fcomp_cache p2
+  with Not_found ->
+    let p = Papply(p1, p2) in
+    let sub =
+      match f.fcomp_arg with
+      | Unit
+      | Named (None, _) -> Subst.identity
+      | Named (Some param, _) -> Subst.add_module param p2 Subst.identity
+    in
+    (* we have to apply eagerly instead of passing sub to [components_of_module]
+       because of the call to [check_well_formed_module]. *)
+    let mty = Subst.modtype (Rescope (Path.scope p)) sub f.fcomp_res in
+    let addr = EnvLazy.create_failed Not_found in
+    !check_well_formed_module env loc
+      ("the signature of " ^ Path.name p) mty;
+    let comps =
+      components_of_module ~alerts:Misc.Stdlib.String.Map.empty
+        ~uid:Uid.internal_not_actually_unique
+        (*???*)
+        env None Subst.identity p addr mty
+    in
+    Hashtbl.add f.fcomp_cache p2 comps;
+    comps
+
+(* Define forward functions *)
+
+let _ =
+  components_of_functor_appl' := components_of_functor_appl;
+  components_of_module_maker' := components_of_module_maker
+
+(* Insertion of bindings by identifier *)
+
+let add_functor_arg id env =
+  {env with
+   functor_args = Ident.add id () env.functor_args;
+   summary = Env_functor_arg (env.summary, id)}
+
+let add_value ?check id desc env =
+  let addr = value_declaration_address env id desc in
+  store_value ?check id addr desc env
+
+let add_type ~check id info env =
+  store_type ~check id info env
+
+and add_extension ~check ~rebind id ext env =
+  let addr = extension_declaration_address env id ext in
+  store_extension ~check ~rebind id addr ext env
+
+and add_module_declaration ?(arg=false) ~check id presence md env =
+  let check =
+    if not check then
+      None
+    else if arg && is_in_signature env then
+      Some (fun s -> Warnings.Unused_functor_parameter s)
+    else
+      Some (fun s -> Warnings.Unused_module s)
+  in
+  let addr = module_declaration_address env id presence md in
+  let env = store_module ~freshening_sub:None ~check id addr presence md env in
+  if arg then add_functor_arg id env else env
+
+and add_modtype id info env =
+  store_modtype id info env
+
+and add_class id ty env =
+  let addr = class_declaration_address env id ty in
+  store_class id addr ty env
+
+and add_cltype id ty env =
+  store_cltype id ty env
+
+let add_module ?arg id presence mty env =
+  add_module_declaration ~check:false ?arg id presence (md mty) env
+
+let add_local_type path info env =
+  { env with
+    local_constraints = Path.Map.add path info env.local_constraints }
+
+
+(* Insertion of bindings by name *)
+
+let enter_value ?check name desc env =
+  let id = Ident.create_local name in
+  let addr = value_declaration_address env id desc in
+  let env = store_value ?check id addr desc env in
+  (id, env)
+
+let enter_type ~scope name info env =
+  let id = Ident.create_scoped ~scope name in
+  let env = store_type ~check:true id info env in
+  (id, env)
+
+let enter_extension ~scope ~rebind name ext env =
+  let id = Ident.create_scoped ~scope name in
+  let addr = extension_declaration_address env id ext in
+  let env = store_extension ~check:true ~rebind id addr ext env in
+  (id, env)
+
+let enter_module_declaration ~scope ?arg s presence md env =
+  let id = Ident.create_scoped ~scope s in
+  (id, add_module_declaration ?arg ~check:true id presence md env)
+
+let enter_modtype ~scope name mtd env =
+  let id = Ident.create_scoped ~scope name in
+  let env = store_modtype id mtd env in
+  (id, env)
+
+let enter_class ~scope name desc env =
+  let id = Ident.create_scoped ~scope name in
+  let addr = class_declaration_address env id desc in
+  let env = store_class id addr desc env in
+  (id, env)
+
+let enter_cltype ~scope name desc env =
+  let id = Ident.create_scoped ~scope name in
+  let env = store_cltype id desc env in
+  (id, env)
+
+let enter_module ~scope ?arg s presence mty env =
+  enter_module_declaration ~scope ?arg s presence (md mty) env
+
+(* Insertion of all components of a signature *)
+
+let add_item comp env =
+  match comp with
+    Sig_value(id, decl, _)    -> add_value id decl env
+  | Sig_type(id, decl, _, _)  -> add_type ~check:false id decl env
+  | Sig_typext(id, ext, _, _) ->
+      add_extension ~check:false ~rebind:false id ext env
+  | Sig_module(id, presence, md, _, _) ->
+      add_module_declaration ~check:false id presence md env
+  | Sig_modtype(id, decl, _)  -> add_modtype id decl env
+  | Sig_class(id, decl, _, _) -> add_class id decl env
+  | Sig_class_type(id, decl, _, _) -> add_cltype id decl env
+
+let rec add_signature sg env =
+  match sg with
+    [] -> env
+  | comp :: rem -> add_signature rem (add_item comp env)
+
+let enter_signature ~scope sg env =
+  let sg = Subst.signature (Rescope scope) Subst.identity sg in
+  sg, add_signature sg env
+
+(* Add "unbound" bindings *)
+
+let enter_unbound_value name reason env =
+  let id = Ident.create_local name in
+  { env with
+    values = IdTbl.add id (Val_unbound reason) env.values;
+    summary = Env_value_unbound(env.summary, name, reason) }
+
+let enter_unbound_module name reason env =
+  let id = Ident.create_local name in
+  { env with
+    modules = IdTbl.add id (Mod_unbound reason) env.modules;
+    summary = Env_module_unbound(env.summary, name, reason) }
+
+(* Open a signature path *)
+
+let add_components slot root env0 comps =
+  let add_l w comps env0 =
+    TycompTbl.add_open slot w comps env0
+  in
+  let add w comps env0 = IdTbl.add_open slot w root comps env0 in
+  let constrs =
+    add_l (fun x -> `Constructor x) comps.comp_constrs env0.constrs
+  in
+  let labels =
+    add_l (fun x -> `Label x) comps.comp_labels env0.labels
+  in
+  let values =
+    add (fun x -> `Value x) comps.comp_values env0.values
+  in
+  let types =
+    add (fun x -> `Type x) comps.comp_types env0.types
+  in
+  let modtypes =
+    add (fun x -> `Module_type x) comps.comp_modtypes env0.modtypes
+  in
+  let classes =
+    add (fun x -> `Class x) comps.comp_classes env0.classes
+  in
+  let cltypes =
+    add (fun x -> `Class_type x) comps.comp_cltypes env0.cltypes
+  in
+  let modules =
+    add (fun x -> `Module x) comps.comp_modules env0.modules
+  in
+  { env0 with
+    summary = Env_open(env0.summary, root);
+    constrs;
+    labels;
+    values;
+    types;
+    modtypes;
+    classes;
+    cltypes;
+    modules;
+  }
+
+let open_signature slot root env0 : (_,_) result =
+  match get_components_res (find_module_components root env0) with
+  | Error _ -> Error `Not_found
+  | exception Not_found -> Error `Not_found
+  | Ok (Functor_comps _) -> Error `Functor
+  | Ok (Structure_comps comps) ->
+    Ok (add_components slot root env0 comps)
+
+
+(* Open a signature from a file *)
+
+let open_pers_signature name env =
+  match open_signature None (Pident(Ident.create_persistent name)) env with
+  | (Ok _ | Error `Not_found as res) -> res
+  | Error `Functor -> assert false
+        (* a compilation unit cannot refer to a functor *)
+
+let open_signature
+    ?(used_slot = ref false)
+    ?(loc = Location.none) ?(toplevel = false)
+    ovf root env =
+  let unused =
+    match ovf with
+    | Asttypes.Fresh -> Warnings.Unused_open (Path.name root)
+    | Asttypes.Override -> Warnings.Unused_open_bang (Path.name root)
+  in
+  let warn_unused =
+    Warnings.is_active unused
+  and warn_shadow_id =
+    Warnings.is_active (Warnings.Open_shadow_identifier ("", ""))
+  and warn_shadow_lc =
+    Warnings.is_active (Warnings.Open_shadow_label_constructor ("",""))
+  in
+  if not toplevel && not loc.Location.loc_ghost
+     && (warn_unused || warn_shadow_id || warn_shadow_lc)
+  then begin
+    let used = used_slot in
+    if warn_unused then
+      !add_delayed_check_forward
+        (fun () ->
+           if not !used then begin
+             used := true;
+             Location.prerr_warning loc unused
+           end
+        );
+    let shadowed = ref [] in
+    let slot s b =
+      begin match check_shadowing env b with
+      | Some kind when
+          ovf = Asttypes.Fresh && not (List.mem (kind, s) !shadowed) ->
+          shadowed := (kind, s) :: !shadowed;
+          let w =
+            match kind with
+            | "label" | "constructor" ->
+                Warnings.Open_shadow_label_constructor (kind, s)
+            | _ -> Warnings.Open_shadow_identifier (kind, s)
+          in
+          Location.prerr_warning loc w
+      | _ -> ()
+      end;
+      used := true
+    in
+    open_signature (Some slot) root env
+  end
+  else open_signature None root env
+
+(* Read a signature from a file *)
+let read_signature modname filename =
+  let mda = read_pers_mod modname filename in
+  let md = EnvLazy.force subst_modtype_maker mda.mda_declaration in
+  match md.md_type with
+  | Mty_signature sg -> sg
+  | Mty_ident _ | Mty_functor _ | Mty_alias _ -> assert false
+
+let is_identchar_latin1 = function
+  | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214' | '\216'..'\246'
+  | '\248'..'\255' | '\'' | '0'..'9' -> true
+  | _ -> false
+
+let unit_name_of_filename fn =
+  match Filename.extension fn with
+  | ".cmi" -> begin
+      let unit =
+        String.capitalize_ascii (Filename.remove_extension fn)
+      in
+      if String.for_all is_identchar_latin1 unit then
+        Some unit
+      else
+        None
+    end
+  | _ -> None
+
+let persistent_structures_of_dir dir =
+  Load_path.Dir.files dir
+  |> List.to_seq
+  |> Seq.filter_map unit_name_of_filename
+  |> String.Set.of_seq
+
+(* Save a signature to a file *)
+let save_signature_with_transform cmi_transform ~alerts sg modname filename =
+  Btype.cleanup_abbrev ();
+  Subst.reset_for_saving ();
+  let sg = Subst.signature Make_local (Subst.for_saving Subst.identity) sg in
+  let cmi =
+    Persistent_env.make_cmi !persistent_env modname sg alerts
+    |> cmi_transform in
+  let pm = save_sign_of_cmi
+      { Persistent_env.Persistent_signature.cmi; filename } in
+  Persistent_env.save_cmi !persistent_env
+    { Persistent_env.Persistent_signature.filename; cmi } pm;
+  cmi
+
+let save_signature ~alerts sg modname filename =
+  save_signature_with_transform (fun cmi -> cmi)
+    ~alerts sg modname filename
+
+let save_signature_with_imports ~alerts sg modname filename imports =
+  let with_imports cmi = { cmi with cmi_crcs = imports } in
+  save_signature_with_transform with_imports
+    ~alerts sg modname filename
+
+(* Make the initial environment *)
+let (initial_safe_string, initial_unsafe_string) =
+  Predef.build_initial_env
+    (add_type ~check:false)
+    (add_extension ~check:false ~rebind:false)
+    empty
+
+(* Tracking usage *)
+
+let mark_module_used uid =
+  match Types.Uid.Tbl.find !module_declarations uid with
+  | mark -> mark ()
+  | exception Not_found -> ()
+
+let mark_modtype_used _uid = ()
+
+let mark_value_used uid =
+  match Types.Uid.Tbl.find !value_declarations uid with
+  | mark -> mark ()
+  | exception Not_found -> ()
+
+let mark_type_used uid =
+  match Types.Uid.Tbl.find !type_declarations uid with
+  | mark -> mark ()
+  | exception Not_found -> ()
+
+let mark_type_path_used env path =
+  match find_type path env with
+  | decl -> mark_type_used decl.type_uid
+  | exception Not_found -> ()
+
+let mark_constructor_used usage cd =
+  match Types.Uid.Tbl.find !used_constructors cd.cd_uid with
+  | mark -> mark usage
+  | exception Not_found -> ()
+
+let mark_extension_used usage ext =
+  match Types.Uid.Tbl.find !used_constructors ext.ext_uid with
+  | mark -> mark usage
+  | exception Not_found -> ()
+
+let mark_constructor_description_used usage env cstr =
+  let ty_path =
+    match repr cstr.cstr_res with
+    | {desc=Tconstr(path, _, _)} -> path
+    | _ -> assert false
+  in
+  mark_type_path_used env ty_path;
+  match Types.Uid.Tbl.find !used_constructors cstr.cstr_uid with
+  | mark -> mark usage
+  | exception Not_found -> ()
+
+let mark_label_description_used () env lbl =
+  let ty_path =
+    match repr lbl.lbl_res with
+    | {desc=Tconstr(path, _, _)} -> path
+    | _ -> assert false
+  in
+  mark_type_path_used env ty_path
+
+let mark_class_used uid =
+  match Types.Uid.Tbl.find !type_declarations uid with
+  | mark -> mark ()
+  | exception Not_found -> ()
+
+let mark_cltype_used uid =
+  match Types.Uid.Tbl.find !type_declarations uid with
+  | mark -> mark ()
+  | exception Not_found -> ()
+
+let set_value_used_callback vd callback =
+  Types.Uid.Tbl.add !value_declarations vd.val_uid callback
+
+let set_type_used_callback td callback =
+  if Uid.for_actual_declaration td.type_uid then
+    let old =
+      try Types.Uid.Tbl.find !type_declarations td.type_uid
+      with Not_found -> ignore
+    in
+    Types.Uid.Tbl.replace !type_declarations td.type_uid
+      (fun () -> callback old)
+
+(* Lookup by name *)
+
+let may_lookup_error report_errors loc env err =
+  if report_errors then lookup_error loc env err
+  else raise Not_found
+
+let report_module_unbound ~errors ~loc env reason =
+  match reason with
+  | Mod_unbound_illegal_recursion ->
+      (* see #5965 *)
+    may_lookup_error errors loc env Illegal_reference_to_recursive_module
+
+let report_value_unbound ~errors ~loc env reason lid =
+  match reason with
+  | Val_unbound_instance_variable ->
+      may_lookup_error errors loc env (Masked_instance_variable lid)
+  | Val_unbound_self ->
+      may_lookup_error errors loc env (Masked_self_variable lid)
+  | Val_unbound_ancestor ->
+      may_lookup_error errors loc env (Masked_ancestor_variable lid)
+  | Val_unbound_ghost_recursive rloc ->
+      let show_hint =
+        (* Only display the "missing rec" hint for non-ghost code *)
+        not loc.Location.loc_ghost
+        && not rloc.Location.loc_ghost
+      in
+      let hint =
+        if show_hint then Missing_rec rloc else No_hint
+      in
+      may_lookup_error errors loc env (Unbound_value(lid, hint))
+
+let use_module ~use ~loc path mda =
+  if use then begin
+    let comps = mda.mda_components in
+    mark_module_used comps.uid;
+    Misc.Stdlib.String.Map.iter
+      (fun kind message ->
+         let message = if message = "" then "" else "\n" ^ message in
+         Location.alert ~kind loc
+           (Printf.sprintf "module %s%s" (Path.name path) message)
+      )
+      comps.alerts
+  end
+
+let use_value ~use ~loc path vda =
+  if use then begin
+    let desc = vda.vda_description in
+    mark_value_used desc.val_uid;
+    Builtin_attributes.check_alerts loc desc.val_attributes
+      (Path.name path)
+  end
+
+let use_type ~use ~loc path tda =
+  if use then begin
+    let decl = tda.tda_declaration in
+    mark_type_used decl.type_uid;
+    Builtin_attributes.check_alerts loc decl.type_attributes
+      (Path.name path)
+  end
+
+let use_modtype ~use ~loc path desc =
+  if use then begin
+    mark_modtype_used desc.mtd_uid;
+    Builtin_attributes.check_alerts loc desc.mtd_attributes
+      (Path.name path)
+  end
+
+let use_class ~use ~loc path clda =
+  if use then begin
+    let desc = clda.clda_declaration in
+    mark_class_used desc.cty_uid;
+    Builtin_attributes.check_alerts loc desc.cty_attributes
+      (Path.name path)
+  end
+
+let use_cltype ~use ~loc path desc =
+  if use then begin
+    mark_cltype_used desc.clty_uid;
+    Builtin_attributes.check_alerts loc desc.clty_attributes
+      (Path.name path)
+  end
+
+let use_label ~use ~loc env lbl =
+  if use then begin
+    mark_label_description_used () env lbl;
+    Builtin_attributes.check_alerts loc lbl.lbl_attributes lbl.lbl_name
+  end
+
+let use_constructor_desc ~use ~loc usage env cstr =
+  if use then begin
+    mark_constructor_description_used usage env cstr;
+    Builtin_attributes.check_alerts loc cstr.cstr_attributes cstr.cstr_name
+  end
+
+let use_constructor ~use ~loc usage env cda =
+  use_constructor_desc ~use ~loc usage env cda.cda_description
+
+type _ load =
+  | Load : module_data load
+  | Don't_load : unit load
+
+let lookup_ident_module (type a) (load : a load) ~errors ~use ~loc s env =
+  let path, data =
+    match find_name_module ~mark:use s env.modules with
+    | res -> res
+    | exception Not_found ->
+        may_lookup_error errors loc env (Unbound_module (Lident s))
+  in
+  match data with
+  | Mod_local mda -> begin
+      use_module ~use ~loc path mda;
+      match load with
+      | Load -> path, (mda : a)
+      | Don't_load -> path, (() : a)
+    end
+  | Mod_unbound reason ->
+      report_module_unbound ~errors ~loc env reason
+  | Mod_persistent -> begin
+      match load with
+      | Don't_load ->
+          check_pers_mod ~loc s;
+          path, (() : a)
+      | Load -> begin
+          match find_pers_mod s with
+          | mda ->
+              use_module ~use ~loc path mda;
+              path, (mda : a)
+          | exception Not_found ->
+              may_lookup_error errors loc env (Unbound_module (Lident s))
+        end
+    end
+
+let lookup_ident_value ~errors ~use ~loc name env =
+  match IdTbl.find_name wrap_value ~mark:use name env.values with
+  | (path, Val_bound vda) ->
+      use_value ~use ~loc path vda;
+      path, vda.vda_description
+  | (_, Val_unbound reason) ->
+      report_value_unbound ~errors ~loc env reason (Lident name)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_value (Lident name, No_hint))
+
+let lookup_ident_type ~errors ~use ~loc s env =
+  match IdTbl.find_name wrap_identity ~mark:use s env.types with
+  | (path, data) as res ->
+      use_type ~use ~loc path data;
+      res
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_type (Lident s))
+
+let lookup_ident_modtype ~errors ~use ~loc s env =
+  match IdTbl.find_name wrap_identity ~mark:use s env.modtypes with
+  | (path, data) as res ->
+      use_modtype ~use ~loc path data;
+      res
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_modtype (Lident s))
+
+let lookup_ident_class ~errors ~use ~loc s env =
+  match IdTbl.find_name wrap_identity ~mark:use s env.classes with
+  | (path, clda) ->
+      use_class ~use ~loc path clda;
+      path, clda.clda_declaration
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_class (Lident s))
+
+let lookup_ident_cltype ~errors ~use ~loc s env =
+  match IdTbl.find_name wrap_identity ~mark:use s env.cltypes with
+  | (path, data) as res ->
+      use_cltype ~use ~loc path data;
+      res
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_cltype (Lident s))
+
+let lookup_all_ident_labels ~errors ~use ~loc s env =
+  match TycompTbl.find_all ~mark:use s env.labels with
+  | [] -> may_lookup_error errors loc env (Unbound_label (Lident s))
+  | lbls -> begin
+      List.map
+        (fun (lbl, use_fn) ->
+           let use_fn () =
+             use_label ~use ~loc env lbl;
+             use_fn ()
+           in
+           (lbl, use_fn))
+        lbls
+    end
+
+let lookup_all_ident_constructors ~errors ~use ~loc usage s env =
+  match TycompTbl.find_all ~mark:use s env.constrs with
+  | [] -> may_lookup_error errors loc env (Unbound_constructor (Lident s))
+  | cstrs ->
+      List.map
+        (fun (cda, use_fn) ->
+           let use_fn () =
+             use_constructor ~use ~loc usage env cda;
+             use_fn ()
+           in
+           (cda.cda_description, use_fn))
+        cstrs
+
+let rec lookup_module_components ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s ->
+      let path, data = lookup_ident_module Load ~errors ~use ~loc s env in
+      path, data.mda_components
+  | Ldot(l, s) ->
+      let path, data = lookup_dot_module ~errors ~use ~loc l s env in
+      path, data.mda_components
+  | Lapply(l1, l2) ->
+      let p1, f, arg = lookup_functor_components ~errors ~use ~loc l1 env in
+      let p2, md = lookup_module ~errors ~use ~loc l2 env in
+      check_functor_appl ~errors ~loc env p1 f arg p2 md;
+      let comps = !components_of_functor_appl' ~loc f env p1 p2 in
+      (Papply(p1, p2), comps)
+
+and lookup_structure_components ~errors ~use ~loc lid env =
+  let path, comps = lookup_module_components ~errors ~use ~loc lid env in
+  match get_components_res comps with
+  | Ok (Structure_comps comps) -> path, comps
+  | Ok (Functor_comps _) ->
+      may_lookup_error errors loc env (Functor_used_as_structure lid)
+  | Error No_components_abstract ->
+      may_lookup_error errors loc env (Abstract_used_as_structure lid)
+  | Error (No_components_alias p) ->
+      may_lookup_error errors loc env (Cannot_scrape_alias(lid, p))
+
+and lookup_functor_components ~errors ~use ~loc lid env =
+  let path, comps = lookup_module_components ~errors ~use ~loc lid env in
+  match get_components_res comps with
+  | Ok (Functor_comps fcomps) -> begin
+      match fcomps.fcomp_arg with
+      | Unit -> (* PR#7611 *)
+          may_lookup_error errors loc env (Generative_used_as_applicative lid)
+      | Named (_, arg) -> path, fcomps, arg
+    end
+  | Ok (Structure_comps _) ->
+      may_lookup_error errors loc env (Structure_used_as_functor lid)
+  | Error No_components_abstract ->
+      may_lookup_error errors loc env (Abstract_used_as_functor lid)
+  | Error (No_components_alias p) ->
+      may_lookup_error errors loc env (Cannot_scrape_alias(lid, p))
+
+and lookup_module ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s ->
+      let path, data = lookup_ident_module Load ~errors ~use ~loc s env in
+      let md = EnvLazy.force subst_modtype_maker data.mda_declaration in
+      path, md
+  | Ldot(l, s) ->
+      let path, data = lookup_dot_module ~errors ~use ~loc l s env in
+      let md = EnvLazy.force subst_modtype_maker data.mda_declaration in
+      path, md
+  | Lapply(l1, l2) ->
+      let p1, fc, arg = lookup_functor_components ~errors ~use ~loc l1 env in
+      let p2, md2 = lookup_module ~errors ~use ~loc l2 env in
+      check_functor_appl ~errors ~loc env p1 fc arg p2 md2;
+      let md = md (modtype_of_functor_appl fc p1 p2) in
+      Papply(p1, p2), md
+
+and lookup_dot_module ~errors ~use ~loc l s env =
+  let p, comps = lookup_structure_components ~errors ~use ~loc l env in
+  match NameMap.find s comps.comp_modules with
+  | mda ->
+      let path = Pdot(p, s) in
+      use_module ~use ~loc path mda;
+      (path, mda)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_module (Ldot(l, s)))
+
+let lookup_dot_value ~errors ~use ~loc l s env =
+  let (path, comps) =
+    lookup_structure_components ~errors ~use ~loc l env
+  in
+  match NameMap.find s comps.comp_values with
+  | vda ->
+      let path = Pdot(path, s) in
+      use_value ~use ~loc path vda;
+      (path, vda.vda_description)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_value (Ldot(l, s), No_hint))
+
+let lookup_dot_type ~errors ~use ~loc l s env =
+  let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in
+  match NameMap.find s comps.comp_types with
+  | tda ->
+      let path = Pdot(p, s) in
+      use_type ~use ~loc path tda;
+      (path, tda)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_type (Ldot(l, s)))
+
+let lookup_dot_modtype ~errors ~use ~loc l s env =
+  let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in
+  match NameMap.find s comps.comp_modtypes with
+  | desc ->
+      let path = Pdot(p, s) in
+      use_modtype ~use ~loc path desc;
+      (path, desc)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_modtype (Ldot(l, s)))
+
+let lookup_dot_class ~errors ~use ~loc l s env =
+  let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in
+  match NameMap.find s comps.comp_classes with
+  | clda ->
+      let path = Pdot(p, s) in
+      use_class ~use ~loc path clda;
+      (path, clda.clda_declaration)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_class (Ldot(l, s)))
+
+let lookup_dot_cltype ~errors ~use ~loc l s env =
+  let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in
+  match NameMap.find s comps.comp_cltypes with
+  | desc ->
+      let path = Pdot(p, s) in
+      use_cltype ~use ~loc path desc;
+      (path, desc)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_cltype (Ldot(l, s)))
+
+let lookup_all_dot_labels ~errors ~use ~loc l s env =
+  let (_, comps) = lookup_structure_components ~errors ~use ~loc l env in
+  match NameMap.find s comps.comp_labels with
+  | [] | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_label (Ldot(l, s)))
+  | lbls ->
+      List.map
+        (fun lbl ->
+           let use_fun () = use_label ~use ~loc env lbl in
+           (lbl, use_fun))
+        lbls
+
+let lookup_all_dot_constructors ~errors ~use ~loc usage l s env =
+  match l with
+  | Longident.Lident "*predef*" ->
+      (* Hack to support compilation of default arguments *)
+      lookup_all_ident_constructors
+        ~errors ~use ~loc usage s initial_safe_string
+  | _ ->
+      let (_, comps) = lookup_structure_components ~errors ~use ~loc l env in
+      match NameMap.find s comps.comp_constrs with
+      | [] | exception Not_found ->
+          may_lookup_error errors loc env (Unbound_constructor (Ldot(l, s)))
+      | cstrs ->
+          List.map
+            (fun cda ->
+               let use_fun () = use_constructor ~use ~loc usage env cda in
+               (cda.cda_description, use_fun))
+            cstrs
+
+(* General forms of the lookup functions *)
+
+let lookup_module_path ~errors ~use ~loc ~load lid env : Path.t =
+  match lid with
+  | Lident s ->
+      if !Clflags.transparent_modules && not load then
+        fst (lookup_ident_module Don't_load ~errors ~use ~loc s env)
+      else
+        fst (lookup_ident_module Load ~errors ~use ~loc s env)
+  | Ldot(l, s) -> fst (lookup_dot_module ~errors ~use ~loc l s env)
+  | Lapply(l1, l2) ->
+      let (p1, f, arg) = lookup_functor_components ~errors ~use ~loc l1 env in
+      let p2, md2 = lookup_module ~errors ~use ~loc l2 env in
+      check_functor_appl ~errors ~loc env p1 f arg p2 md2;
+      Papply(p1, p2)
+
+let lookup_value ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s -> lookup_ident_value ~errors ~use ~loc s env
+  | Ldot(l, s) -> lookup_dot_value ~errors ~use ~loc l s env
+  | Lapply _ -> assert false
+
+let lookup_type_full ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s -> lookup_ident_type ~errors ~use ~loc s env
+  | Ldot(l, s) -> lookup_dot_type ~errors ~use ~loc l s env
+  | Lapply _ -> assert false
+
+let lookup_type ~errors ~use ~loc lid env =
+  let (path, tda) = lookup_type_full ~errors ~use ~loc lid env in
+  path, tda.tda_declaration
+
+let lookup_modtype ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s -> lookup_ident_modtype ~errors ~use ~loc s env
+  | Ldot(l, s) -> lookup_dot_modtype ~errors ~use ~loc l s env
+  | Lapply _ -> assert false
+
+let lookup_class ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s -> lookup_ident_class ~errors ~use ~loc s env
+  | Ldot(l, s) -> lookup_dot_class ~errors ~use ~loc l s env
+  | Lapply _ -> assert false
+
+let lookup_cltype ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s -> lookup_ident_cltype ~errors ~use ~loc s env
+  | Ldot(l, s) -> lookup_dot_cltype ~errors ~use ~loc l s env
+  | Lapply _ -> assert false
+
+let lookup_all_labels ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s -> lookup_all_ident_labels ~errors ~use ~loc s env
+  | Ldot(l, s) -> lookup_all_dot_labels ~errors ~use ~loc l s env
+  | Lapply _ -> assert false
+
+let lookup_label ~errors ~use ~loc lid env =
+  match lookup_all_labels ~errors ~use ~loc lid env with
+  | [] -> assert false
+  | (desc, use) :: _ -> use (); desc
+
+let lookup_all_labels_from_type ~use ~loc ty_path env =
+  match find_type_descrs ty_path env with
+  | exception Not_found -> []
+  | (_, lbls) ->
+      List.map
+        (fun lbl ->
+           let use_fun () = use_label ~use ~loc env lbl in
+           (lbl, use_fun))
+        lbls
+
+let lookup_all_constructors ~errors ~use ~loc usage lid env =
+  match lid with
+  | Lident s -> lookup_all_ident_constructors ~errors ~use ~loc usage s env
+  | Ldot(l, s) -> lookup_all_dot_constructors ~errors ~use ~loc usage l s env
+  | Lapply _ -> assert false
+
+let lookup_constructor ~errors ~use ~loc usage lid env =
+  match lookup_all_constructors ~errors ~use ~loc usage lid env with
+  | [] -> assert false
+  | (desc, use) :: _ -> use (); desc
+
+let lookup_all_constructors_from_type ~use ~loc usage ty_path env =
+  match find_type_descrs ty_path env with
+  | exception Not_found -> []
+  | (cstrs, _) ->
+      List.map
+        (fun cstr ->
+           let use_fun () =
+             use_constructor_desc ~use ~loc usage env cstr
+           in
+           (cstr, use_fun))
+        cstrs
+
+(* Lookup functions that do not mark the item as used or
+   warn if it has alerts, and raise [Not_found] rather
+   than report errors *)
+
+let find_module_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_module ~errors:false ~use:false ~loc lid env
+
+let find_value_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_value ~errors:false ~use:false ~loc lid env
+
+let find_type_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_type ~errors:false ~use:false ~loc lid env
+
+let find_modtype_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_modtype ~errors:false ~use:false ~loc lid env
+
+let find_class_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_class ~errors:false ~use:false ~loc lid env
+
+let find_cltype_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_cltype ~errors:false ~use:false ~loc lid env
+
+let find_constructor_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_constructor ~errors:false ~use:false ~loc Positive lid env
+
+let find_label_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_label ~errors:false ~use:false ~loc lid env
+
+(* Ordinary lookup functions *)
+
+let lookup_module_path ?(use=true) ~loc ~load lid env =
+  lookup_module_path ~errors:true ~use ~loc ~load lid env
+
+let lookup_module ?(use=true) ~loc lid env =
+  lookup_module ~errors:true ~use ~loc lid env
+
+let lookup_value ?(use=true) ~loc lid env =
+  check_value_name (Longident.last lid) loc;
+  lookup_value ~errors:true ~use ~loc lid env
+
+let lookup_type ?(use=true) ~loc lid env =
+  lookup_type ~errors:true ~use ~loc lid env
+
+let lookup_modtype ?(use=true) ~loc lid env =
+  lookup_modtype ~errors:true ~use ~loc lid env
+
+let lookup_class ?(use=true) ~loc lid env =
+  lookup_class ~errors:true ~use ~loc lid env
+
+let lookup_cltype ?(use=true) ~loc lid env =
+  lookup_cltype ~errors:true ~use ~loc lid env
+
+let lookup_all_constructors ?(use=true) ~loc usage lid env =
+  match lookup_all_constructors ~errors:true ~use ~loc usage lid env with
+  | exception Error(Lookup_error(loc', env', err)) ->
+      (Error(loc', env', err) : _ result)
+  | cstrs -> Ok cstrs
+
+let lookup_constructor ?(use=true) ~loc lid env =
+  lookup_constructor ~errors:true ~use ~loc lid env
+
+let lookup_all_constructors_from_type ?(use=true) ~loc usage ty_path env =
+  lookup_all_constructors_from_type ~use ~loc usage ty_path env
+
+let lookup_all_labels ?(use=true) ~loc lid env =
+  match lookup_all_labels ~errors:true ~use ~loc lid env with
+  | exception Error(Lookup_error(loc', env', err)) ->
+      (Error(loc', env', err) : _ result)
+  | lbls -> Ok lbls
+
+let lookup_label ?(use=true) ~loc lid env =
+  lookup_label ~errors:true ~use ~loc lid env
+
+let lookup_all_labels_from_type ?(use=true) ~loc ty_path env =
+  lookup_all_labels_from_type ~use ~loc ty_path env
+
+let lookup_instance_variable ?(use=true) ~loc name env =
+  match IdTbl.find_name wrap_value ~mark:use name env.values with
+  | (path, Val_bound vda) -> begin
+      let desc = vda.vda_description in
+      match desc.val_kind with
+      | Val_ivar(mut, cl_num) ->
+          use_value ~use ~loc path vda;
+          path, mut, cl_num, desc.val_type
+      | _ ->
+          lookup_error loc env (Not_an_instance_variable name)
+    end
+  | (_, Val_unbound Val_unbound_instance_variable) ->
+      lookup_error loc env (Masked_instance_variable (Lident name))
+  | (_, Val_unbound Val_unbound_self) ->
+      lookup_error loc env (Not_an_instance_variable name)
+  | (_, Val_unbound Val_unbound_ancestor) ->
+      lookup_error loc env (Not_an_instance_variable name)
+  | (_, Val_unbound Val_unbound_ghost_recursive _) ->
+      lookup_error loc env (Unbound_instance_variable name)
+  | exception Not_found ->
+      lookup_error loc env (Unbound_instance_variable name)
+
+(* Checking if a name is bound *)
+
+let bound_module name env =
+  match IdTbl.find_name wrap_module ~mark:false name env.modules with
+  | _ -> true
+  | exception Not_found ->
+      if Current_unit_name.is name then false
+      else begin
+        match find_pers_mod name with
+        | _ -> true
+        | exception Not_found -> false
+      end
+
+let bound wrap proj name env =
+  match IdTbl.find_name wrap ~mark:false name (proj env) with
+  | _ -> true
+  | exception Not_found -> false
+
+let bound_value name env =
+  bound wrap_value (fun env -> env.values) name env
+
+let bound_type name env =
+  bound wrap_identity (fun env -> env.types) name env
+
+let bound_modtype name env =
+  bound wrap_identity (fun env -> env.modtypes) name env
+
+let bound_class name env =
+  bound wrap_identity (fun env -> env.classes) name env
+
+let bound_cltype name env =
+  bound wrap_identity (fun env -> env.cltypes) name env
+
+(* Folding on environments *)
+
+let find_all wrap proj1 proj2 f lid env acc =
+  match lid with
+  | None ->
+      IdTbl.fold_name wrap
+        (fun name (p, data) acc -> f name p data acc)
+        (proj1 env) acc
+  | Some l ->
+      let p, desc =
+        lookup_module_components
+          ~errors:false ~use:false ~loc:Location.none l env
+      in
+      begin match get_components desc with
+      | Structure_comps c ->
+          NameMap.fold
+            (fun s data acc -> f s (Pdot (p, s)) (wrap data) acc)
+            (proj2 c) acc
+      | Functor_comps _ ->
+          acc
+      end
+
+let find_all_simple_list proj1 proj2 f lid env acc =
+  match lid with
+  | None ->
+      TycompTbl.fold_name
+        (fun data acc -> f data acc)
+        (proj1 env) acc
+  | Some l ->
+      let (_p, desc) =
+        lookup_module_components
+          ~errors:false ~use:false ~loc:Location.none l env
+      in
+      begin match get_components desc with
+      | Structure_comps c ->
+          NameMap.fold
+            (fun _s comps acc ->
+               match comps with
+               | [] -> acc
+               | data :: _ -> f data acc)
+            (proj2 c) acc
+      | Functor_comps _ ->
+          acc
+      end
+
+let fold_modules f lid env acc =
+  match lid with
+  | None ->
+      IdTbl.fold_name wrap_module
+        (fun name (p, entry) acc ->
+           match entry with
+           | Mod_unbound _ -> acc
+           | Mod_local mda ->
+               let md =
+                 EnvLazy.force subst_modtype_maker mda.mda_declaration
+               in
+               f name p md acc
+           | Mod_persistent ->
+               match Persistent_env.find_in_cache !persistent_env name with
+               | None -> acc
+               | Some mda ->
+                   let md =
+                     EnvLazy.force subst_modtype_maker mda.mda_declaration
+                   in
+                   f name p md acc)
+        env.modules
+        acc
+  | Some l ->
+      let p, desc =
+        lookup_module_components
+          ~errors:false ~use:false ~loc:Location.none l env
+      in
+      begin match get_components desc with
+      | Structure_comps c ->
+          NameMap.fold
+            (fun s mda acc ->
+               let md =
+                 EnvLazy.force subst_modtype_maker mda.mda_declaration
+               in
+               f s (Pdot (p, s)) md acc)
+            c.comp_modules
+            acc
+      | Functor_comps _ ->
+          acc
+      end
+
+let fold_values f =
+  find_all wrap_value (fun env -> env.values) (fun sc -> sc.comp_values)
+    (fun k p ve acc ->
+       match ve with
+       | Val_unbound _ -> acc
+       | Val_bound vda -> f k p vda.vda_description acc)
+and fold_constructors f =
+  find_all_simple_list (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
+    (fun cda acc -> f cda.cda_description acc)
+and fold_labels f =
+  find_all_simple_list (fun env -> env.labels) (fun sc -> sc.comp_labels) f
+and fold_types f =
+  find_all wrap_identity
+    (fun env -> env.types) (fun sc -> sc.comp_types)
+    (fun k p tda acc -> f k p tda.tda_declaration acc)
+and fold_modtypes f =
+  find_all wrap_identity
+    (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) f
+and fold_classes f =
+  find_all wrap_identity (fun env -> env.classes) (fun sc -> sc.comp_classes)
+    (fun k p clda acc -> f k p clda.clda_declaration acc)
+and fold_cltypes f =
+  find_all wrap_identity
+    (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) f
+
+let filter_non_loaded_persistent f env =
+  let to_remove =
+    IdTbl.fold_name wrap_module
+      (fun name (_, entry) acc ->
+         match entry with
+         | Mod_local _ -> acc
+         | Mod_unbound _ -> acc
+         | Mod_persistent ->
+             match Persistent_env.find_in_cache !persistent_env name with
+             | Some _ -> acc
+             | None ->
+                 if f (Ident.create_persistent name) then
+                   acc
+                 else
+                   String.Set.add name acc)
+      env.modules
+      String.Set.empty
+  in
+  let remove_ids tbl ids =
+    String.Set.fold
+      (fun name tbl -> IdTbl.remove (Ident.create_persistent name) tbl)
+      ids
+      tbl
+  in
+  let rec filter_summary summary ids =
+    if String.Set.is_empty ids then
+      summary
+    else
+      match summary with
+      | Env_empty -> summary
+      | Env_value (s, id, vd) ->
+          Env_value (filter_summary s ids, id, vd)
+      | Env_type (s, id, td) ->
+          Env_type (filter_summary s ids, id, td)
+      | Env_extension (s, id, ec) ->
+          Env_extension (filter_summary s ids, id, ec)
+      | Env_module (s, id, mp, md) ->
+          Env_module (filter_summary s ids, id, mp, md)
+      | Env_modtype (s, id, md) ->
+          Env_modtype (filter_summary s ids, id, md)
+      | Env_class (s, id, cd) ->
+          Env_class (filter_summary s ids, id, cd)
+      | Env_cltype (s, id, ctd) ->
+          Env_cltype (filter_summary s ids, id, ctd)
+      | Env_open (s, p) ->
+          Env_open (filter_summary s ids, p)
+      | Env_functor_arg (s, id) ->
+          Env_functor_arg (filter_summary s ids, id)
+      | Env_constraints (s, cstrs) ->
+          Env_constraints (filter_summary s ids, cstrs)
+      | Env_copy_types s ->
+          Env_copy_types (filter_summary s ids)
+      | Env_persistent (s, id) ->
+          if String.Set.mem (Ident.name id) ids then
+            filter_summary s (String.Set.remove (Ident.name id) ids)
+          else
+            Env_persistent (filter_summary s ids, id)
+      | Env_value_unbound (s, n, r) ->
+          Env_value_unbound (filter_summary s ids, n, r)
+      | Env_module_unbound (s, n, r) ->
+          Env_module_unbound (filter_summary s ids, n, r)
+  in
+  { env with
+    modules = remove_ids env.modules to_remove;
+    summary = filter_summary env.summary to_remove;
+  }
+
+(* Return the environment summary *)
+
+let summary env =
+  if Path.Map.is_empty env.local_constraints then env.summary
+  else Env_constraints (env.summary, env.local_constraints)
+
+let last_env = s_ref empty
+let last_reduced_env = s_ref empty
+
+let keep_only_summary env =
+  if !last_env == env then !last_reduced_env
+  else begin
+    let new_env =
+      {
+       empty with
+       summary = env.summary;
+       local_constraints = env.local_constraints;
+       flags = env.flags;
+      }
+    in
+    last_env := env;
+    last_reduced_env := new_env;
+    new_env
+  end
+
+
+let env_of_only_summary env_from_summary env =
+  let new_env = env_from_summary env.summary Subst.identity in
+  { new_env with
+    local_constraints = env.local_constraints;
+    flags = env.flags;
+  }
+
+(* Error report *)
+
+open Format
+
+(* Forward declarations *)
+
+let print_longident =
+  ref ((fun _ _ -> assert false) : formatter -> Longident.t -> unit)
+
+let print_path =
+  ref ((fun _ _ -> assert false) : formatter -> Path.t -> unit)
+
+let spellcheck ppf extract env lid =
+  let choices ~path name = Misc.spellcheck (extract path env) name in
+  match lid with
+    | Longident.Lapply _ -> ()
+    | Longident.Lident s ->
+       Misc.did_you_mean ppf (fun () -> choices ~path:None s)
+    | Longident.Ldot (r, s) ->
+       Misc.did_you_mean ppf (fun () -> choices ~path:(Some r) s)
+
+let spellcheck_name ppf extract env name =
+  Misc.did_you_mean ppf
+    (fun () -> Misc.spellcheck (extract env) name)
+
+let extract_values path env =
+  fold_values (fun name _ _ acc -> name :: acc) path env []
+let extract_types path env =
+  fold_types (fun name _ _ acc -> name :: acc) path env []
+let extract_modules path env =
+  fold_modules (fun name _ _ acc -> name :: acc) path env []
+let extract_constructors path env =
+  fold_constructors (fun desc acc -> desc.cstr_name :: acc) path env []
+let extract_labels path env =
+  fold_labels (fun desc acc -> desc.lbl_name :: acc) path env []
+let extract_classes path env =
+  fold_classes (fun name _ _ acc -> name :: acc) path env []
+let extract_modtypes path env =
+  fold_modtypes (fun name _ _ acc -> name :: acc) path env []
+let extract_cltypes path env =
+  fold_cltypes (fun name _ _ acc -> name :: acc) path env []
+let extract_instance_variables env =
+  fold_values
+    (fun name _ descr acc ->
+       match descr.val_kind with
+       | Val_ivar _ -> name :: acc
+       | _ -> acc) None env []
+
+let report_lookup_error _loc env ppf = function
+  | Unbound_value(lid, hint) -> begin
+      fprintf ppf "Unbound value %a" !print_longident lid;
+      spellcheck ppf extract_values env lid;
+      match hint with
+      | No_hint -> ()
+      | Missing_rec def_loc ->
+          let (_, line, _) =
+            Location.get_pos_info def_loc.Location.loc_start
+          in
+          fprintf ppf
+            "@.@[%s@ %s %i@]"
+            "Hint: If this is a recursive definition,"
+            "you should add the 'rec' keyword on line"
+            line
+    end
+  | Unbound_type lid ->
+      fprintf ppf "Unbound type constructor %a" !print_longident lid;
+      spellcheck ppf extract_types env lid;
+  | Unbound_module lid -> begin
+      fprintf ppf "Unbound module %a" !print_longident lid;
+       match find_modtype_by_name lid env with
+      | exception Not_found -> spellcheck ppf extract_modules env lid;
+      | _ ->
+         fprintf ppf
+           "@.@[%s %a, %s@]"
+           "Hint: There is a module type named"
+           !print_longident lid
+           "but module types are not modules"
+    end
+  | Unbound_constructor lid ->
+      fprintf ppf "Unbound constructor %a" !print_longident lid;
+      spellcheck ppf extract_constructors env lid;
+  | Unbound_label lid ->
+      fprintf ppf "Unbound record field %a" !print_longident lid;
+      spellcheck ppf extract_labels env lid;
+  | Unbound_class lid -> begin
+      fprintf ppf "Unbound class %a" !print_longident lid;
+      match find_cltype_by_name lid env with
+      | exception Not_found -> spellcheck ppf extract_classes env lid;
+      | _ ->
+         fprintf ppf
+           "@.@[%s %a, %s@]"
+           "Hint: There is a class type named"
+           !print_longident lid
+           "but classes are not class types"
+    end
+  | Unbound_modtype lid -> begin
+      fprintf ppf "Unbound module type %a" !print_longident lid;
+      match find_module_by_name lid env with
+      | exception Not_found -> spellcheck ppf extract_modtypes env lid;
+      | _ ->
+         fprintf ppf
+           "@.@[%s %a, %s@]"
+           "Hint: There is a module named"
+           !print_longident lid
+           "but modules are not module types"
+    end
+  | Unbound_cltype lid ->
+      fprintf ppf "Unbound class type %a" !print_longident lid;
+      spellcheck ppf extract_cltypes env lid;
+  | Unbound_instance_variable s ->
+      fprintf ppf "Unbound instance variable %s" s;
+      spellcheck_name ppf extract_instance_variables env s;
+  | Not_an_instance_variable s ->
+      fprintf ppf "The value %s is not an instance variable" s;
+      spellcheck_name ppf extract_instance_variables env s;
+  | Masked_instance_variable lid ->
+      fprintf ppf
+        "The instance variable %a@ \
+         cannot be accessed from the definition of another instance variable"
+        !print_longident lid
+  | Masked_self_variable lid ->
+      fprintf ppf
+        "The self variable %a@ \
+         cannot be accessed from the definition of an instance variable"
+        !print_longident lid
+  | Masked_ancestor_variable lid ->
+      fprintf ppf
+        "The ancestor variable %a@ \
+         cannot be accessed from the definition of an instance variable"
+        !print_longident lid
+  | Illegal_reference_to_recursive_module ->
+     fprintf ppf "Illegal recursive module reference"
+  | Structure_used_as_functor lid ->
+      fprintf ppf "@[The module %a is a structure, it cannot be applied@]"
+        !print_longident lid
+  | Abstract_used_as_functor lid ->
+      fprintf ppf "@[The module %a is abstract, it cannot be applied@]"
+        !print_longident lid
+  | Functor_used_as_structure lid ->
+      fprintf ppf "@[The module %a is a functor, \
+                   it cannot have any components@]" !print_longident lid
+  | Abstract_used_as_structure lid ->
+      fprintf ppf "@[The module %a is abstract, \
+                   it cannot have any components@]" !print_longident lid
+  | Generative_used_as_applicative lid ->
+      fprintf ppf "@[The functor %a is generative,@ it@ cannot@ be@ \
+                   applied@ in@ type@ expressions@]" !print_longident lid
+  | Cannot_scrape_alias(lid, p) ->
+      let cause =
+        if Current_unit_name.is_path p then "is the current compilation unit"
+        else "is missing"
+      in
+      fprintf ppf
+        "The module %a is an alias for module %a, which %s"
+        !print_longident lid !print_path p cause
+
+let report_error ppf = function
+  | Missing_module(_, path1, path2) ->
+      fprintf ppf "@[@[<hov>";
+      if Path.same path1 path2 then
+        fprintf ppf "Internal path@ %s@ is dangling." (Path.name path1)
+      else
+        fprintf ppf "Internal path@ %s@ expands to@ %s@ which is dangling."
+          (Path.name path1) (Path.name path2);
+      fprintf ppf "@]@ @[%s@ %s@ %s.@]@]"
+        "The compiled interface for module" (Ident.name (Path.head path2))
+        "was not found"
+  | Illegal_value_name(_loc, name) ->
+      fprintf ppf "'%s' is not a valid value identifier."
+        name
+  | Lookup_error(loc, t, err) -> report_lookup_error loc t ppf err
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err ->
+          let loc =
+            match err with
+            | Missing_module (loc, _, _)
+            | Illegal_value_name (loc, _)
+            | Lookup_error(loc, _, _) -> loc
+          in
+          let error_of_printer =
+            if loc = Location.none
+            then Location.error_of_printer_file
+            else Location.error_of_printer ~loc ?sub:None
+          in
+          Some (error_of_printer report_error err)
+      | _ ->
+          None
+    )
diff --git a/upstream/ocaml_412/typing/env.mli b/upstream/ocaml_412/typing/env.mli
new file mode 100644
index 0000000..76c3ff7
--- /dev/null
+++ b/upstream/ocaml_412/typing/env.mli
@@ -0,0 +1,472 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Environment handling *)
+
+open Types
+open Misc
+
+type value_unbound_reason =
+  | Val_unbound_instance_variable
+  | Val_unbound_self
+  | Val_unbound_ancestor
+  | Val_unbound_ghost_recursive of Location.t
+
+type module_unbound_reason =
+  | Mod_unbound_illegal_recursion
+
+type summary =
+    Env_empty
+  | Env_value of summary * Ident.t * value_description
+  | Env_type of summary * Ident.t * type_declaration
+  | Env_extension of summary * Ident.t * extension_constructor
+  | Env_module of summary * Ident.t * module_presence * module_declaration
+  | Env_modtype of summary * Ident.t * modtype_declaration
+  | Env_class of summary * Ident.t * class_declaration
+  | Env_cltype of summary * Ident.t * class_type_declaration
+  | Env_open of summary * Path.t
+  (** The string set argument of [Env_open] represents a list of module names
+      to skip, i.e. that won't be imported in the toplevel namespace. *)
+  | Env_functor_arg of summary * Ident.t
+  | Env_constraints of summary * type_declaration Path.Map.t
+  | Env_copy_types of summary
+  | Env_persistent of summary * Ident.t
+  | Env_value_unbound of summary * string * value_unbound_reason
+  | Env_module_unbound of summary * string * module_unbound_reason
+
+type address =
+  | Aident of Ident.t
+  | Adot of address * int
+
+type t
+
+val empty: t
+val initial_safe_string: t
+val initial_unsafe_string: t
+val diff: t -> t -> Ident.t list
+val copy_local: from:t -> t -> t
+
+type type_descriptions =
+    constructor_description list * label_description list
+
+(* For short-paths *)
+type iter_cont
+val iter_types:
+    (Path.t -> Path.t * type_declaration -> unit) ->
+    t -> iter_cont
+val run_iter_cont: iter_cont list -> (Path.t * iter_cont) list
+val same_types: t -> t -> bool
+val used_persistent: unit -> Concr.t
+val find_shadowed_types: Path.t -> t -> Path.t list
+val without_cmis: ('a -> 'b) -> 'a -> 'b
+(* [without_cmis f arg] applies [f] to [arg], but does not
+   allow opening cmis during its execution *)
+
+(* Lookup by paths *)
+
+val find_value: Path.t -> t -> value_description
+val find_type: Path.t -> t -> type_declaration
+val find_type_descrs: Path.t -> t -> type_descriptions
+val find_module: Path.t -> t -> module_declaration
+val find_modtype: Path.t -> t -> modtype_declaration
+val find_class: Path.t -> t -> class_declaration
+val find_cltype: Path.t -> t -> class_type_declaration
+
+val find_ident_constructor: Ident.t -> t -> constructor_description
+val find_ident_label: Ident.t -> t -> label_description
+
+val find_type_expansion:
+    Path.t -> t -> type_expr list * type_expr * int
+val find_type_expansion_opt:
+    Path.t -> t -> type_expr list * type_expr * int
+(* Find the manifest type information associated to a type for the sake
+   of the compiler's type-based optimisations. *)
+val find_modtype_expansion: Path.t -> t -> module_type
+
+val find_hash_type: Path.t -> t -> type_declaration
+(* Find the "#t" type given the path for "t" *)
+
+val find_value_address: Path.t -> t -> address
+val find_module_address: Path.t -> t -> address
+val find_class_address: Path.t -> t -> address
+val find_constructor_address: Path.t -> t -> address
+
+val add_functor_arg: Ident.t -> t -> t
+val is_functor_arg: Path.t -> t -> bool
+
+val normalize_module_path: Location.t option -> t -> Path.t -> Path.t
+(* Normalize the path to a concrete module.
+   If the option is None, allow returning dangling paths.
+   Otherwise raise a Missing_module error, and may add forgotten
+   head as required global. *)
+
+val normalize_type_path: Location.t option -> t -> Path.t -> Path.t
+(* Normalize the prefix part of the type path *)
+
+val normalize_path_prefix: Location.t option -> t -> Path.t -> Path.t
+(* Normalize the prefix part of other kinds of paths
+   (value/modtype/etc) *)
+
+val normalize_modtype_path: t -> Path.t -> Path.t
+(* Normalize a module type path *)
+
+val reset_required_globals: unit -> unit
+val get_required_globals: unit -> Ident.t list
+val add_required_global: Ident.t -> unit
+
+val has_local_constraints: t -> bool
+
+(* Mark definitions as used *)
+val mark_value_used: Uid.t -> unit
+val mark_module_used: Uid.t -> unit
+val mark_type_used: Uid.t -> unit
+
+type constructor_usage = Positive | Pattern | Privatize
+val mark_constructor_used:
+    constructor_usage -> constructor_declaration -> unit
+val mark_extension_used:
+    constructor_usage -> extension_constructor -> unit
+
+(* Lookup by long identifiers *)
+
+(* Lookup errors *)
+
+type unbound_value_hint =
+  | No_hint
+  | Missing_rec of Location.t
+
+type lookup_error =
+  | Unbound_value of Longident.t * unbound_value_hint
+  | Unbound_type of Longident.t
+  | Unbound_constructor of Longident.t
+  | Unbound_label of Longident.t
+  | Unbound_module of Longident.t
+  | Unbound_class of Longident.t
+  | Unbound_modtype of Longident.t
+  | Unbound_cltype of Longident.t
+  | Unbound_instance_variable of string
+  | Not_an_instance_variable of string
+  | Masked_instance_variable of Longident.t
+  | Masked_self_variable of Longident.t
+  | Masked_ancestor_variable of Longident.t
+  | Structure_used_as_functor of Longident.t
+  | Abstract_used_as_functor of Longident.t
+  | Functor_used_as_structure of Longident.t
+  | Abstract_used_as_structure of Longident.t
+  | Generative_used_as_applicative of Longident.t
+  | Illegal_reference_to_recursive_module
+  | Cannot_scrape_alias of Longident.t * Path.t
+
+val lookup_error: Location.t -> t -> lookup_error -> 'a
+
+(* The [lookup_foo] functions will emit proper error messages (by
+   raising [Error]) if the identifier cannot be found, whereas the
+   [find_foo_by_name] functions will raise [Not_found] instead.
+
+   The [~use] parameters of the [lookup_foo] functions control
+   whether this lookup should be counted as a use for usage
+   warnings and alerts.
+
+   [Longident.t]s in the program source should be looked up using
+   [lookup_foo ~use:true] exactly one time -- otherwise warnings may be
+   emitted the wrong number of times. *)
+
+val lookup_value:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  Path.t * value_description
+val lookup_type:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  Path.t * type_declaration
+val lookup_module:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  Path.t * module_declaration
+val lookup_modtype:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  Path.t * modtype_declaration
+val lookup_class:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  Path.t * class_declaration
+val lookup_cltype:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  Path.t * class_type_declaration
+
+val lookup_module_path:
+  ?use:bool -> loc:Location.t -> load:bool -> Longident.t -> t -> Path.t
+
+val lookup_constructor:
+  ?use:bool -> loc:Location.t -> constructor_usage -> Longident.t -> t ->
+  constructor_description
+val lookup_all_constructors:
+  ?use:bool -> loc:Location.t -> constructor_usage -> Longident.t -> t ->
+  ((constructor_description * (unit -> unit)) list,
+   Location.t * t * lookup_error) result
+val lookup_all_constructors_from_type:
+  ?use:bool -> loc:Location.t -> constructor_usage -> Path.t -> t ->
+  (constructor_description * (unit -> unit)) list
+
+val lookup_label:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  label_description
+val lookup_all_labels:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  ((label_description * (unit -> unit)) list,
+   Location.t * t * lookup_error) result
+val lookup_all_labels_from_type:
+  ?use:bool -> loc:Location.t -> Path.t -> t ->
+  (label_description * (unit -> unit)) list
+
+val lookup_instance_variable:
+  ?use:bool -> loc:Location.t -> string -> t ->
+  Path.t * Asttypes.mutable_flag * string * type_expr
+
+val find_value_by_name:
+  Longident.t -> t -> Path.t * value_description
+val find_type_by_name:
+  Longident.t -> t -> Path.t * type_declaration
+val find_module_by_name:
+  Longident.t -> t -> Path.t * module_declaration
+val find_modtype_by_name:
+  Longident.t -> t -> Path.t * modtype_declaration
+val find_class_by_name:
+  Longident.t -> t -> Path.t * class_declaration
+val find_cltype_by_name:
+  Longident.t -> t -> Path.t * class_type_declaration
+
+val find_constructor_by_name:
+  Longident.t -> t -> constructor_description
+val find_label_by_name:
+  Longident.t -> t -> label_description
+
+(* Check if a name is bound *)
+
+val bound_value: string -> t -> bool
+val bound_module: string -> t -> bool
+val bound_type: string -> t -> bool
+val bound_modtype: string -> t -> bool
+val bound_class: string -> t -> bool
+val bound_cltype: string -> t -> bool
+
+val make_copy_of_types: t -> (t -> t)
+
+(* Insertion by identifier *)
+
+val add_value:
+    ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t
+val add_type: check:bool -> Ident.t -> type_declaration -> t -> t
+val add_extension:
+  check:bool -> rebind:bool -> Ident.t -> extension_constructor -> t -> t
+val add_module:
+  ?arg:bool -> Ident.t -> module_presence -> module_type -> t -> t
+val add_module_declaration: ?arg:bool -> check:bool -> Ident.t ->
+  module_presence -> module_declaration -> t -> t
+val add_modtype: Ident.t -> modtype_declaration -> t -> t
+val add_class: Ident.t -> class_declaration -> t -> t
+val add_cltype: Ident.t -> class_type_declaration -> t -> t
+val add_local_type: Path.t -> type_declaration -> t -> t
+
+(* Insertion of persistent signatures *)
+
+(* [add_persistent_structure id env] is an environment such that
+   module [id] points to the persistent structure contained in the
+   external compilation unit with the same name.
+
+   The compilation unit itself is looked up in the load path when the
+   contents of the module is accessed. *)
+val add_persistent_structure : Ident.t -> t -> t
+
+(* Returns the set of persistent structures found in the given
+   directory. *)
+val persistent_structures_of_dir : Load_path.Dir.t -> Misc.Stdlib.String.Set.t
+
+(* [filter_non_loaded_persistent f env] removes all the persistent
+   structures that are not yet loaded and for which [f] returns
+   [false]. *)
+val filter_non_loaded_persistent : (Ident.t -> bool) -> t -> t
+
+(* Insertion of all fields of a signature. *)
+
+val add_item: signature_item -> t -> t
+val add_signature: signature -> t -> t
+
+(* Insertion of all fields of a signature, relative to the given path.
+   Used to implement open. Returns None if the path refers to a functor,
+   not a structure. *)
+val open_signature:
+    ?used_slot:bool ref ->
+    ?loc:Location.t -> ?toplevel:bool ->
+    Asttypes.override_flag -> Path.t ->
+    t -> (t, [`Not_found | `Functor]) result
+
+val open_pers_signature: string -> t -> (t, [`Not_found]) result
+
+(* Insertion by name *)
+
+val enter_value:
+    ?check:(string -> Warnings.t) ->
+    string -> value_description -> t -> Ident.t * t
+val enter_type: scope:int -> string -> type_declaration -> t -> Ident.t * t
+val enter_extension:
+  scope:int -> rebind:bool -> string ->
+  extension_constructor -> t -> Ident.t * t
+val enter_module:
+  scope:int -> ?arg:bool -> string -> module_presence ->
+  module_type -> t -> Ident.t * t
+val enter_module_declaration:
+  scope:int -> ?arg:bool -> string -> module_presence ->
+  module_declaration -> t -> Ident.t * t
+val enter_modtype:
+  scope:int -> string -> modtype_declaration -> t -> Ident.t * t
+val enter_class: scope:int -> string -> class_declaration -> t -> Ident.t * t
+val enter_cltype:
+  scope:int -> string -> class_type_declaration -> t -> Ident.t * t
+
+(* Same as [add_signature] but refreshes (new stamp) and rescopes bound idents
+   in the process. *)
+val enter_signature: scope:int -> signature -> t -> signature * t
+
+val enter_unbound_value : string -> value_unbound_reason -> t -> t
+
+val enter_unbound_module : string -> module_unbound_reason -> t -> t
+
+(* Initialize the cache of in-core module interfaces. *)
+val reset_cache: unit -> unit
+
+(* To be called before each toplevel phrase. *)
+val reset_cache_toplevel: unit -> unit
+
+(* Remember the name of the current compilation unit. *)
+val set_unit_name: string -> unit
+val get_unit_name: unit -> string
+
+(* Read, save a signature to/from a file *)
+val read_signature: modname -> filepath -> signature
+        (* Arguments: module name, file name. Results: signature. *)
+val save_signature:
+  alerts:alerts -> signature -> modname -> filepath
+  -> Cmi_format.cmi_infos
+        (* Arguments: signature, module name, file name. *)
+val save_signature_with_imports:
+  alerts:alerts -> signature -> modname -> filepath -> crcs
+  -> Cmi_format.cmi_infos
+        (* Arguments: signature, module name, file name,
+           imported units with their CRCs. *)
+
+(* Return the CRC of the interface of the given compilation unit *)
+val crc_of_unit: modname -> Digest.t
+
+(* Return the set of compilation units imported, with their CRC *)
+val imports: unit -> crcs
+
+(* may raise Persistent_env.Consistbl.Inconsistency *)
+val import_crcs: source:string -> crcs -> unit
+
+(* [is_imported_opaque md] returns true if [md] is an opaque imported module *)
+val is_imported_opaque: modname -> bool
+
+(* [register_import_as_opaque md] registers [md] as an opaque imported module *)
+val register_import_as_opaque: modname -> unit
+
+(* Summaries -- compact representation of an environment, to be
+   exported in debugging information. *)
+
+val summary: t -> summary
+
+(* Return an equivalent environment where all fields have been reset,
+   except the summary. The initial environment can be rebuilt from the
+   summary, using Envaux.env_of_only_summary. *)
+
+val keep_only_summary : t -> t
+val env_of_only_summary : (summary -> Subst.t -> t) -> t -> t
+
+(* Error report *)
+
+type error =
+  | Missing_module of Location.t * Path.t * Path.t
+  | Illegal_value_name of Location.t * string
+  | Lookup_error of Location.t * t * lookup_error
+
+exception Error of error
+
+open Format
+
+val report_error: formatter -> error -> unit
+
+val report_lookup_error: Location.t -> t -> formatter -> lookup_error -> unit
+
+val in_signature: bool -> t -> t
+
+val is_in_signature: t -> bool
+
+val set_value_used_callback:
+    value_description -> (unit -> unit) -> unit
+val set_type_used_callback:
+    type_declaration -> ((unit -> unit) -> unit) -> unit
+
+(* Forward declaration to break mutual recursion with Includemod. *)
+val check_functor_application:
+      (errors:bool -> loc:Location.t -> t -> module_type ->
+         Path.t -> module_type -> Path.t -> unit) ref
+(* Forward declaration to break mutual recursion with Typemod. *)
+val check_well_formed_module:
+    (t -> Location.t -> string -> module_type -> unit) ref
+(* Forward declaration to break mutual recursion with Typecore. *)
+val add_delayed_check_forward: ((unit -> unit) -> unit) ref
+(* Forward declaration to break mutual recursion with Mtype. *)
+val strengthen:
+    (aliasable:bool -> t -> module_type -> Path.t -> module_type) ref
+(* Forward declaration to break mutual recursion with Ctype. *)
+val same_constr: (t -> type_expr -> type_expr -> bool) ref
+(* Forward declaration to break mutual recursion with Printtyp. *)
+val print_longident: (Format.formatter -> Longident.t -> unit) ref
+(* Forward declaration to break mutual recursion with Printtyp. *)
+val print_path: (Format.formatter -> Path.t -> unit) ref
+
+
+(** Folds *)
+
+val fold_values:
+  (string -> Path.t -> value_description -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+val fold_types:
+  (string -> Path.t -> type_declaration -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+val fold_constructors:
+  (constructor_description -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+val fold_labels:
+  (label_description -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+
+(** Persistent structures are only traversed if they are already loaded. *)
+val fold_modules:
+  (string -> Path.t -> module_declaration -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+
+val fold_modtypes:
+  (string -> Path.t -> modtype_declaration -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+val fold_classes:
+  (string -> Path.t -> class_declaration -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+val fold_cltypes:
+  (string -> Path.t -> class_type_declaration -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+
+
+(** Utilities *)
+val scrape_alias: t -> module_type -> module_type
+val check_value_name: string -> Location.t -> unit
+
+val print_address : Format.formatter -> address -> unit
diff --git a/upstream/ocaml_412/typing/ident.ml b/upstream/ocaml_412/typing/ident.ml
new file mode 100644
index 0000000..feb590d
--- /dev/null
+++ b/upstream/ocaml_412/typing/ident.ml
@@ -0,0 +1,360 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Local_store
+
+let lowest_scope  = 0
+let highest_scope = 100000000
+
+type t =
+  | Local of { name: string; stamp: int }
+  | Scoped of { name: string; stamp: int; scope: int }
+  | Global of string
+  | Predef of { name: string; stamp: int }
+      (* the stamp is here only for fast comparison, but the name of
+         predefined identifiers is always unique. *)
+
+(* A stamp of 0 denotes a persistent identifier *)
+
+let currentstamp = s_ref 0
+let predefstamp = s_ref 0
+
+let create_scoped ~scope s =
+  incr currentstamp;
+  Scoped { name = s; stamp = !currentstamp; scope }
+
+let create_local s =
+  incr currentstamp;
+  Local { name = s; stamp = !currentstamp }
+
+let create_predef s =
+  incr predefstamp;
+  Predef { name = s; stamp = !predefstamp }
+
+let create_persistent s =
+  Global s
+
+let name = function
+  | Local { name; _ }
+  | Scoped { name; _ }
+  | Global name
+  | Predef { name; _ } -> name
+
+let rename = function
+  | Local { name; stamp = _ }
+  | Scoped { name; stamp = _; scope = _ } ->
+      incr currentstamp;
+      Local { name; stamp = !currentstamp }
+  | id ->
+      Misc.fatal_errorf "Ident.rename %s" (name id)
+
+let unique_name = function
+  | Local { name; stamp }
+  | Scoped { name; stamp } -> name ^ "_" ^ Int.to_string stamp
+  | Global name ->
+      (* we're adding a fake stamp, because someone could have named his unit
+         [Foo_123] and since we're using unique_name to produce symbol names,
+         we might clash with an ident [Local { "Foo"; 123 }]. *)
+      name ^ "_0"
+  | Predef { name; _ } ->
+      (* we know that none of the predef names (currently) finishes in
+         "_<some number>", and that their name is unique. *)
+      name
+
+let unique_toplevel_name = function
+  | Local { name; stamp }
+  | Scoped { name; stamp } -> name ^ "/" ^ Int.to_string stamp
+  | Global name
+  | Predef { name; _ } -> name
+
+let persistent = function
+  | Global _ -> true
+  | _ -> false
+
+let equal i1 i2 =
+  match i1, i2 with
+  | Local { name = name1; _ }, Local { name = name2; _ }
+  | Scoped { name = name1; _ }, Scoped { name = name2; _ }
+  | Global name1, Global name2 ->
+      name1 = name2
+  | Predef { stamp = s1; _ }, Predef { stamp = s2 } ->
+      (* if they don't have the same stamp, they don't have the same name *)
+      s1 = s2
+  | _ ->
+      false
+
+let same i1 i2 =
+  match i1, i2 with
+  | Local { stamp = s1; _ }, Local { stamp = s2; _ }
+  | Scoped { stamp = s1; _ }, Scoped { stamp = s2; _ }
+  | Predef { stamp = s1; _ }, Predef { stamp = s2 } ->
+      s1 = s2
+  | Global name1, Global name2 ->
+      name1 = name2
+  | _ ->
+      false
+
+let stamp = function
+  | Local { stamp; _ }
+  | Scoped { stamp; _ } -> stamp
+  | _ -> 0
+
+let scope = function
+  | Scoped { scope; _ } -> scope
+  | Local _ -> highest_scope
+  | Global _ | Predef _ -> lowest_scope
+
+let reinit_level = ref (-1)
+
+let reinit () =
+  if !reinit_level < 0
+  then reinit_level := !currentstamp
+  else currentstamp := !reinit_level
+
+let global = function
+  | Local _
+  | Scoped _ -> false
+  | Global _
+  | Predef _ -> true
+
+let is_predef = function
+  | Predef _ -> true
+  | _ -> false
+
+let print ~with_scope ppf =
+  let open Format in
+  function
+  | Global name -> fprintf ppf "%s!" name
+  | Predef { name; stamp = n } ->
+      fprintf ppf "%s%s!" name
+        (if !Clflags.unique_ids then sprintf "/%i" n else "")
+  | Local { name; stamp = n } ->
+      fprintf ppf "%s%s" name
+        (if !Clflags.unique_ids then sprintf "/%i" n else "")
+  | Scoped { name; stamp = n; scope } ->
+      fprintf ppf "%s%s%s" name
+        (if !Clflags.unique_ids then sprintf "/%i" n else "")
+        (if with_scope then sprintf "[%i]" scope else "")
+
+let print_with_scope ppf id = print ~with_scope:true ppf id
+
+let print ppf id = print ~with_scope:false ppf id
+
+type 'a tbl =
+    Empty
+  | Node of 'a tbl * 'a data * 'a tbl * int
+
+and 'a data =
+  { ident: t;
+    data: 'a;
+    previous: 'a data option }
+
+let empty = Empty
+
+(* Inline expansion of height for better speed
+ * let height = function
+ *     Empty -> 0
+ *   | Node(_,_,_,h) -> h
+ *)
+
+let mknode l d r =
+  let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h
+  and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+  Node(l, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+let balance l d r =
+  let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h
+  and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+  if hl > hr + 1 then
+    match l with
+    | Node (ll, ld, lr, _)
+      when (match ll with Empty -> 0 | Node(_,_,_,h) -> h) >=
+           (match lr with Empty -> 0 | Node(_,_,_,h) -> h) ->
+        mknode ll ld (mknode lr d r)
+    | Node (ll, ld, Node(lrl, lrd, lrr, _), _) ->
+        mknode (mknode ll ld lrl) lrd (mknode lrr d r)
+    | _ -> assert false
+  else if hr > hl + 1 then
+    match r with
+    | Node (rl, rd, rr, _)
+      when (match rr with Empty -> 0 | Node(_,_,_,h) -> h) >=
+           (match rl with Empty -> 0 | Node(_,_,_,h) -> h) ->
+        mknode (mknode l d rl) rd rr
+    | Node (Node (rll, rld, rlr, _), rd, rr, _) ->
+        mknode (mknode l d rll) rld (mknode rlr rd rr)
+    | _ -> assert false
+  else
+    mknode l d r
+
+let rec add id data = function
+    Empty ->
+      Node(Empty, {ident = id; data = data; previous = None}, Empty, 1)
+  | Node(l, k, r, h) ->
+      let c = String.compare (name id) (name k.ident) in
+      if c = 0 then
+        Node(l, {ident = id; data = data; previous = Some k}, r, h)
+      else if c < 0 then
+        balance (add id data l) k r
+      else
+        balance l k (add id data r)
+
+let rec min_binding = function
+    Empty -> raise Not_found
+  | Node (Empty, d, _, _) -> d
+  | Node (l, _, _, _) -> min_binding l
+
+let rec remove_min_binding = function
+    Empty -> invalid_arg "Map.remove_min_elt"
+  | Node (Empty, _, r, _) -> r
+  | Node (l, d, r, _) -> balance (remove_min_binding l) d r
+
+let merge t1 t2 =
+  match (t1, t2) with
+    (Empty, t) -> t
+  | (t, Empty) -> t
+  | (_, _) ->
+      let d = min_binding t2 in
+      balance t1 d (remove_min_binding t2)
+
+let rec remove id = function
+    Empty ->
+      Empty
+  | (Node (l, k, r, h) as m) ->
+      let c = String.compare (name id) (name k.ident) in
+      if c = 0 then
+        match k.previous with
+        | None -> merge l r
+        | Some k -> Node (l, k, r, h)
+      else if c < 0 then
+        let ll = remove id l in if l == ll then m else balance ll k r
+      else
+        let rr = remove id r in if r == rr then m else balance l k rr
+
+let rec find_previous id = function
+    None ->
+      raise Not_found
+  | Some k ->
+      if same id k.ident then k.data else find_previous id k.previous
+
+let rec find_same id = function
+    Empty ->
+      raise Not_found
+  | Node(l, k, r, _) ->
+      let c = String.compare (name id) (name k.ident) in
+      if c = 0 then
+        if same id k.ident
+        then k.data
+        else find_previous id k.previous
+      else
+        find_same id (if c < 0 then l else r)
+
+let rec find_name n = function
+    Empty ->
+      raise Not_found
+  | Node(l, k, r, _) ->
+      let c = String.compare n (name k.ident) in
+      if c = 0 then
+        k.ident, k.data
+      else
+        find_name n (if c < 0 then l else r)
+
+let rec get_all = function
+  | None -> []
+  | Some k -> (k.ident, k.data) :: get_all k.previous
+
+let rec find_all n = function
+    Empty ->
+      []
+  | Node(l, k, r, _) ->
+      let c = String.compare n (name k.ident) in
+      if c = 0 then
+        (k.ident, k.data) :: get_all k.previous
+      else
+        find_all n (if c < 0 then l else r)
+
+let rec fold_aux f stack accu = function
+    Empty ->
+      begin match stack with
+        [] -> accu
+      | a :: l -> fold_aux f l accu a
+      end
+  | Node(l, k, r, _) ->
+      fold_aux f (l :: stack) (f k accu) r
+
+let fold_name f tbl accu = fold_aux (fun k -> f k.ident k.data) [] accu tbl
+
+let rec fold_data f d accu =
+  match d with
+    None -> accu
+  | Some k -> f k.ident k.data (fold_data f k.previous accu)
+
+let fold_all f tbl accu =
+  fold_aux (fun k -> fold_data f (Some k)) [] accu tbl
+
+(* let keys tbl = fold_name (fun k _ accu -> k::accu) tbl [] *)
+
+let rec iter f = function
+    Empty -> ()
+  | Node(l, k, r, _) ->
+      iter f l; f k.ident k.data; iter f r
+
+(* Idents for sharing keys *)
+
+(* They should be 'totally fresh' -> neg numbers *)
+let key_name = ""
+
+let make_key_generator () =
+  let c = ref 1 in
+  function
+  | Local _
+  | Scoped _ ->
+      let stamp = !c in
+      decr c ;
+      Local { name = key_name; stamp = stamp }
+  | global_id ->
+      Misc.fatal_errorf "Ident.make_key_generator () %s" (name global_id)
+
+let compare x y =
+  match x, y with
+  | Local x, Local y ->
+      let c = x.stamp - y.stamp in
+      if c <> 0 then c
+      else compare x.name y.name
+  | Local _, _ -> 1
+  | _, Local _ -> (-1)
+  | Scoped x, Scoped y ->
+      let c = x.stamp - y.stamp in
+      if c <> 0 then c
+      else compare x.name y.name
+  | Scoped _, _ -> 1
+  | _, Scoped _ -> (-1)
+  | Global x, Global y -> compare x y
+  | Global _, _ -> 1
+  | _, Global _ -> (-1)
+  | Predef { stamp = s1; _ }, Predef { stamp = s2; _ } -> compare s1 s2
+
+let output oc id = output_string oc (unique_name id)
+let hash i = (Char.code (name i).[0]) lxor (stamp i)
+
+let original_equal = equal
+include Identifiable.Make (struct
+  type nonrec t = t
+  let compare = compare
+  let output = output
+  let print = print
+  let hash = hash
+  let equal = same
+end)
+let equal = original_equal
diff --git a/upstream/ocaml_412/typing/ident.mli b/upstream/ocaml_412/typing/ident.mli
new file mode 100644
index 0000000..ff48efb
--- /dev/null
+++ b/upstream/ocaml_412/typing/ident.mli
@@ -0,0 +1,80 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Identifiers (unique names) *)
+
+type t
+
+include Identifiable.S with type t := t
+(* Notes:
+   - [equal] compares identifiers by name
+   - [compare x y] is 0 if [same x y] is true.
+   - [compare] compares identifiers by binding location
+*)
+
+val print_with_scope : Format.formatter -> t -> unit
+        (** Same as {!print} except that it will also add a "[n]" suffix
+            if the scope of the argument is [n]. *)
+
+
+val create_scoped: scope:int -> string -> t
+val create_local: string -> t
+val create_persistent: string -> t
+val create_predef: string -> t
+
+val rename: t -> t
+        (** Creates an identifier with the same name as the input, a fresh
+            stamp, and no scope.
+            @raise [Fatal_error] if called on a persistent / predef ident. *)
+
+val name: t -> string
+val unique_name: t -> string
+val unique_toplevel_name: t -> string
+val persistent: t -> bool
+val same: t -> t -> bool
+        (** Compare identifiers by binding location.
+            Two identifiers are the same either if they are both
+            non-persistent and have been created by the same call to
+            [create_*], or if they are both persistent and have the same
+            name. *)
+
+val compare: t -> t -> int
+
+val global: t -> bool
+val is_predef: t -> bool
+
+val scope: t -> int
+
+val lowest_scope : int
+val highest_scope: int
+
+val reinit: unit -> unit
+
+type 'a tbl
+        (* Association tables from identifiers to type 'a. *)
+
+val empty: 'a tbl
+val add: t -> 'a -> 'a tbl -> 'a tbl
+val find_same: t -> 'a tbl -> 'a
+val find_name: string -> 'a tbl -> t * 'a
+val find_all: string -> 'a tbl -> (t * 'a) list
+val fold_name: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b
+val fold_all: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b
+val iter: (t -> 'a -> unit) -> 'a tbl -> unit
+val remove: t -> 'a tbl -> 'a tbl
+
+(* Idents for sharing keys *)
+
+val make_key_generator : unit -> (t -> t)
diff --git a/upstream/ocaml_412/typing/includeclass.ml b/upstream/ocaml_412/typing/includeclass.ml
new file mode 100644
index 0000000..483088d
--- /dev/null
+++ b/upstream/ocaml_412/typing/includeclass.ml
@@ -0,0 +1,116 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Jerome Vouillon, projet Cristal, INRIA Rocquencourt          *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the class language *)
+
+open Types
+
+let class_types env cty1 cty2 =
+  Ctype.match_class_types env cty1 cty2
+
+let class_type_declarations ~loc env cty1 cty2 =
+  Builtin_attributes.check_alerts_inclusion
+    ~def:cty1.clty_loc
+    ~use:cty2.clty_loc
+    loc
+    cty1.clty_attributes cty2.clty_attributes
+    (Path.last cty1.clty_path);
+  Ctype.match_class_declarations env
+    cty1.clty_params cty1.clty_type
+    cty2.clty_params cty2.clty_type
+
+let class_declarations env cty1 cty2 =
+  match cty1.cty_new, cty2.cty_new with
+    None, Some _ ->
+      [Ctype.CM_Virtual_class]
+  | _ ->
+      Ctype.match_class_declarations env
+        cty1.cty_params cty1.cty_type
+        cty2.cty_params cty2.cty_type
+
+open Format
+open Ctype
+
+(*
+let rec hide_params = function
+    Tcty_arrow ("*", _, cty) -> hide_params cty
+  | cty -> cty
+*)
+
+let include_err ppf =
+  function
+  | CM_Virtual_class ->
+      fprintf ppf "A class cannot be changed from virtual to concrete"
+  | CM_Parameter_arity_mismatch _ ->
+      fprintf ppf
+        "The classes do not have the same number of type parameters"
+  | CM_Type_parameter_mismatch (env, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+          fprintf ppf "A type parameter has type")
+        (function ppf ->
+          fprintf ppf "but is expected to have type")
+  | CM_Class_type_mismatch (env, cty1, cty2) ->
+      Printtyp.wrap_printing_env ~error:true env (fun () ->
+        fprintf ppf
+          "@[The class type@;<1 2>%a@ %s@;<1 2>%a@]"
+          Printtyp.class_type cty1
+          "is not matched by the class type"
+          Printtyp.class_type cty2)
+  | CM_Parameter_mismatch (env, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+          fprintf ppf "A parameter has type")
+        (function ppf ->
+          fprintf ppf "but is expected to have type")
+  | CM_Val_type_mismatch (lab, env, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+          fprintf ppf "The instance variable %s@ has type" lab)
+        (function ppf ->
+          fprintf ppf "but is expected to have type")
+  | CM_Meth_type_mismatch (lab, env, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+          fprintf ppf "The method %s@ has type" lab)
+        (function ppf ->
+          fprintf ppf "but is expected to have type")
+  | CM_Non_mutable_value lab ->
+      fprintf ppf
+       "@[The non-mutable instance variable %s cannot become mutable@]" lab
+  | CM_Non_concrete_value lab ->
+      fprintf ppf
+       "@[The virtual instance variable %s cannot become concrete@]" lab
+  | CM_Missing_value lab ->
+      fprintf ppf "@[The first class type has no instance variable %s@]" lab
+  | CM_Missing_method lab ->
+      fprintf ppf "@[The first class type has no method %s@]" lab
+  | CM_Hide_public lab ->
+     fprintf ppf "@[The public method %s cannot be hidden@]" lab
+  | CM_Hide_virtual (k, lab) ->
+      fprintf ppf "@[The virtual %s %s cannot be hidden@]" k lab
+  | CM_Public_method lab ->
+      fprintf ppf "@[The public method %s cannot become private@]" lab
+  | CM_Virtual_method lab ->
+      fprintf ppf "@[The virtual method %s cannot become concrete@]" lab
+  | CM_Private_method lab ->
+      fprintf ppf "@[The private method %s cannot become public@]" lab
+
+let report_error ppf = function
+  |  [] -> ()
+  | err :: errs ->
+      let print_errs ppf errs =
+         List.iter (fun err -> fprintf ppf "@ %a" include_err err) errs in
+      fprintf ppf "@[<v>%a%a@]" include_err err print_errs errs
diff --git a/upstream/ocaml_412/typing/includeclass.mli b/upstream/ocaml_412/typing/includeclass.mli
new file mode 100644
index 0000000..ebfa978
--- /dev/null
+++ b/upstream/ocaml_412/typing/includeclass.mli
@@ -0,0 +1,32 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Jerome Vouillon, projet Cristal, INRIA Rocquencourt          *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the class language *)
+
+open Types
+open Ctype
+open Format
+
+val class_types:
+        Env.t -> class_type -> class_type -> class_match_failure list
+val class_type_declarations:
+  loc:Location.t ->
+  Env.t -> class_type_declaration -> class_type_declaration ->
+  class_match_failure list
+val class_declarations:
+  Env.t -> class_declaration -> class_declaration ->
+  class_match_failure list
+
+val report_error: formatter -> class_match_failure list -> unit
diff --git a/upstream/ocaml_412/typing/includecore.ml b/upstream/ocaml_412/typing/includecore.ml
new file mode 100644
index 0000000..5325d97
--- /dev/null
+++ b/upstream/ocaml_412/typing/includecore.ml
@@ -0,0 +1,508 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the core language *)
+
+open Asttypes
+open Path
+open Types
+open Typedtree
+
+(* Inclusion between value descriptions *)
+
+exception Dont_match
+
+let value_descriptions ~loc env name
+    (vd1 : Types.value_description)
+    (vd2 : Types.value_description) =
+  Builtin_attributes.check_alerts_inclusion
+    ~def:vd1.val_loc
+    ~use:vd2.val_loc
+    loc
+    vd1.val_attributes vd2.val_attributes
+    name;
+  if Ctype.moregeneral env true vd1.val_type vd2.val_type then begin
+    match (vd1.val_kind, vd2.val_kind) with
+        (Val_prim p1, Val_prim p2) ->
+          if p1 = p2 then Tcoerce_none else raise Dont_match
+      | (Val_prim p, _) ->
+          let pc = {pc_desc = p; pc_type = vd2.Types.val_type;
+                  pc_env = env; pc_loc = vd1.Types.val_loc; } in
+          Tcoerce_primitive pc
+      | (_, Val_prim _) -> raise Dont_match
+      | (_, _) -> Tcoerce_none
+  end else
+    raise Dont_match
+
+(* Inclusion between "private" annotations *)
+
+let private_flags decl1 decl2 =
+  match decl1.type_private, decl2.type_private with
+  | Private, Public ->
+      decl2.type_kind = Type_abstract &&
+      (decl2.type_manifest = None || decl1.type_kind <> Type_abstract)
+  | _, _ -> true
+
+(* Inclusion between manifest types (particularly for private row types) *)
+
+let is_absrow env ty =
+  match ty.desc with
+    Tconstr(Pident _, _, _) ->
+      begin match Ctype.expand_head env ty with
+        {desc=Tobject _|Tvariant _} -> true
+      | _ -> false
+      end
+  | _ -> false
+
+let type_manifest env ty1 params1 ty2 params2 priv2 =
+  let ty1' = Ctype.expand_head env ty1 and ty2' = Ctype.expand_head env ty2 in
+  match ty1'.desc, ty2'.desc with
+    Tvariant row1, Tvariant row2 when is_absrow env (Btype.row_more row2) ->
+      let row1 = Btype.row_repr row1 and row2 = Btype.row_repr row2 in
+      Ctype.equal env true (ty1::params1) (row2.row_more::params2) &&
+      begin match row1.row_more with
+        {desc=Tvar _|Tconstr _|Tnil} -> true
+      | _ -> false
+      end &&
+      let r1, r2, pairs =
+        Ctype.merge_row_fields row1.row_fields row2.row_fields in
+      (not row2.row_closed ||
+       row1.row_closed && Ctype.filter_row_fields false r1 = []) &&
+      List.for_all
+        (fun (_,f) -> match Btype.row_field_repr f with
+          Rabsent | Reither _ -> true | Rpresent _ -> false)
+        r2 &&
+      let to_equal = ref (List.combine params1 params2) in
+      List.for_all
+        (fun (_, f1, f2) ->
+          match Btype.row_field_repr f1, Btype.row_field_repr f2 with
+            Rpresent(Some t1),
+            (Rpresent(Some t2) | Reither(false, [t2], _, _)) ->
+              to_equal := (t1,t2) :: !to_equal; true
+          | Rpresent None, (Rpresent None | Reither(true, [], _, _)) -> true
+          | Reither(c1,tl1,_,_), Reither(c2,tl2,_,_)
+            when List.length tl1 = List.length tl2 && c1 = c2 ->
+              to_equal := List.combine tl1 tl2 @ !to_equal; true
+          | Rabsent, (Reither _ | Rabsent) -> true
+          | _ -> false)
+        pairs &&
+      let tl1, tl2 = List.split !to_equal in
+      Ctype.equal env true tl1 tl2
+  | Tobject (fi1, _), Tobject (fi2, _)
+    when is_absrow env (snd(Ctype.flatten_fields fi2)) ->
+      let (fields2,rest2) = Ctype.flatten_fields fi2 in
+      Ctype.equal env true (ty1::params1) (rest2::params2) &&
+      let (fields1,rest1) = Ctype.flatten_fields fi1 in
+      (match rest1 with {desc=Tnil|Tvar _|Tconstr _} -> true | _ -> false) &&
+      let pairs, _miss1, miss2 = Ctype.associate_fields fields1 fields2 in
+      miss2 = [] &&
+      let tl1, tl2 =
+        List.split (List.map (fun (_,_,t1,_,t2) -> t1, t2) pairs) in
+      Ctype.equal env true (params1 @ tl1) (params2 @ tl2)
+  | _ ->
+      let rec check_super ty1 =
+        Ctype.equal env true (ty1 :: params1) (ty2 :: params2) ||
+        priv2 = Private &&
+        try check_super
+              (Ctype.try_expand_once_opt env (Ctype.expand_head env ty1))
+        with Ctype.Cannot_expand -> false
+      in check_super ty1
+
+(* Inclusion between type declarations *)
+
+type position = Ctype.Unification_trace.position = First | Second
+
+let choose ord first second =
+  match ord with
+  | First -> first
+  | Second -> second
+
+let choose_other ord first second =
+  match ord with
+  | First -> choose Second first second
+  | Second -> choose First first second
+
+type label_mismatch =
+  | Type
+  | Mutability of position
+
+type record_mismatch =
+  | Label_mismatch of Types.label_declaration
+                      * Types.label_declaration
+                      * label_mismatch
+  | Label_names of int * Ident.t * Ident.t
+  | Label_missing of position * Ident.t
+  | Unboxed_float_representation of position
+
+type constructor_mismatch =
+  | Type
+  | Arity
+  | Inline_record of record_mismatch
+  | Kind of position
+  | Explicit_return_type of position
+
+type variant_mismatch =
+  | Constructor_mismatch of Types.constructor_declaration
+                            * Types.constructor_declaration
+                            * constructor_mismatch
+  | Constructor_names of int * Ident.t * Ident.t
+  | Constructor_missing of position * Ident.t
+
+type extension_constructor_mismatch =
+  | Constructor_privacy
+  | Constructor_mismatch of Ident.t
+                            * Types.extension_constructor
+                            * Types.extension_constructor
+                            * constructor_mismatch
+
+type type_mismatch =
+  | Arity
+  | Privacy
+  | Kind
+  | Constraint
+  | Manifest
+  | Variance
+  | Record_mismatch of record_mismatch
+  | Variant_mismatch of variant_mismatch
+  | Unboxed_representation of position
+  | Immediate of Type_immediacy.Violation.t
+
+let report_label_mismatch first second ppf err =
+  let pr fmt = Format.fprintf ppf fmt in
+  match (err : label_mismatch) with
+  | Type -> pr "The types are not equal."
+  | Mutability ord ->
+      pr "%s is mutable and %s is not."
+        (String.capitalize_ascii  (choose ord first second))
+        (choose_other ord first second)
+
+let report_record_mismatch first second decl ppf err =
+  let pr fmt = Format.fprintf ppf fmt in
+  match err with
+  | Label_mismatch (l1, l2, err) ->
+      pr
+        "@[<hv>Fields do not match:@;<1 2>%a@ is not compatible with:\
+         @;<1 2>%a@ %a"
+        Printtyp.label l1
+        Printtyp.label l2
+        (report_label_mismatch first second) err
+  | Label_names (n, name1, name2) ->
+      pr "@[<hv>Fields number %i have different names, %s and %s.@]"
+        n (Ident.name name1) (Ident.name name2)
+  | Label_missing (ord, s) ->
+      pr "@[<hv>The field %s is only present in %s %s.@]"
+        (Ident.name s) (choose ord first second) decl
+  | Unboxed_float_representation ord ->
+      pr "@[<hv>Their internal representations differ:@ %s %s %s.@]"
+        (choose ord first second) decl
+        "uses unboxed float representation"
+
+let report_constructor_mismatch first second decl ppf err =
+  let pr fmt  = Format.fprintf ppf fmt in
+  match (err : constructor_mismatch) with
+  | Type -> pr "The types are not equal."
+  | Arity -> pr "They have different arities."
+  | Inline_record err -> report_record_mismatch first second decl ppf err
+  | Kind ord ->
+      pr "%s uses inline records and %s doesn't."
+        (String.capitalize_ascii (choose ord first second))
+        (choose_other ord first second)
+  | Explicit_return_type ord ->
+      pr "%s has explicit return type and %s doesn't."
+        (String.capitalize_ascii (choose ord first second))
+        (choose_other ord first second)
+
+let report_variant_mismatch first second decl ppf err =
+  let pr fmt = Format.fprintf ppf fmt in
+  match (err : variant_mismatch) with
+  | Constructor_mismatch (c1, c2, err) ->
+      pr
+        "@[<hv>Constructors do not match:@;<1 2>%a@ is not compatible with:\
+         @;<1 2>%a@ %a"
+        Printtyp.constructor c1
+        Printtyp.constructor c2
+        (report_constructor_mismatch first second decl) err
+  | Constructor_names (n, name1, name2) ->
+      pr "Constructors number %i have different names, %s and %s."
+        n (Ident.name name1) (Ident.name name2)
+  | Constructor_missing (ord, s) ->
+      pr "The constructor %s is only present in %s %s."
+        (Ident.name s) (choose ord first second) decl
+
+let report_extension_constructor_mismatch first second decl ppf err =
+  let pr fmt = Format.fprintf ppf fmt in
+  match (err : extension_constructor_mismatch) with
+  | Constructor_privacy -> pr "A private type would be revealed."
+  | Constructor_mismatch (id, ext1, ext2, err) ->
+      pr "@[<hv>Constructors do not match:@;<1 2>%a@ is not compatible with:\
+          @;<1 2>%a@ %a@]"
+        (Printtyp.extension_only_constructor id) ext1
+        (Printtyp.extension_only_constructor id) ext2
+        (report_constructor_mismatch first second decl) err
+
+let report_type_mismatch0 first second decl ppf err =
+  let pr fmt = Format.fprintf ppf fmt in
+  match err with
+  | Arity -> pr "They have different arities."
+  | Privacy -> pr "A private type would be revealed."
+  | Kind -> pr "Their kinds differ."
+  | Constraint -> pr "Their constraints differ."
+  | Manifest -> ()
+  | Variance -> pr "Their variances do not agree."
+  | Record_mismatch err -> report_record_mismatch first second decl ppf err
+  | Variant_mismatch err -> report_variant_mismatch first second decl ppf err
+  | Unboxed_representation ord ->
+      pr "Their internal representations differ:@ %s %s %s."
+         (choose ord first second) decl
+         "uses unboxed representation"
+  | Immediate violation ->
+      let first = StringLabels.capitalize_ascii first in
+      match violation with
+      | Type_immediacy.Violation.Not_always_immediate ->
+          pr "%s is not an immediate type." first
+      | Type_immediacy.Violation.Not_always_immediate_on_64bits ->
+          pr "%s is not a type that is always immediate on 64 bit platforms."
+            first
+
+let report_type_mismatch first second decl ppf err =
+  if err = Manifest then () else
+  Format.fprintf ppf "@ %a" (report_type_mismatch0 first second decl) err
+
+let rec compare_constructor_arguments ~loc env params1 params2 arg1 arg2 =
+  match arg1, arg2 with
+  | Types.Cstr_tuple arg1, Types.Cstr_tuple arg2 ->
+      if List.length arg1 <> List.length arg2 then
+        Some (Arity : constructor_mismatch)
+      else if
+        (* Ctype.equal must be called on all arguments at once, cf. PR#7378 *)
+        Ctype.equal env true (params1 @ arg1) (params2 @ arg2)
+      then None else Some Type
+  | Types.Cstr_record l1, Types.Cstr_record l2 ->
+      Option.map
+        (fun rec_err -> Inline_record rec_err)
+        (compare_records env ~loc params1 params2 0 l1 l2)
+  | Types.Cstr_record _, _ -> Some (Kind First : constructor_mismatch)
+  | _, Types.Cstr_record _ -> Some (Kind Second : constructor_mismatch)
+
+and compare_constructors ~loc env params1 params2 res1 res2 args1 args2 =
+  match res1, res2 with
+  | Some r1, Some r2 ->
+      if Ctype.equal env true [r1] [r2] then
+        compare_constructor_arguments ~loc env [r1] [r2] args1 args2
+      else Some Type
+  | Some _, None -> Some (Explicit_return_type First)
+  | None, Some _ -> Some (Explicit_return_type Second)
+  | None, None ->
+      compare_constructor_arguments ~loc env params1 params2 args1 args2
+
+and compare_variants ~loc env params1 params2 n
+    (cstrs1 : Types.constructor_declaration list)
+    (cstrs2 : Types.constructor_declaration list) =
+  match cstrs1, cstrs2 with
+  | [], []   -> None
+  | [], c::_ -> Some (Constructor_missing (Second, c.Types.cd_id))
+  | c::_, [] -> Some (Constructor_missing (First, c.Types.cd_id))
+  | cd1::rem1, cd2::rem2 ->
+      if Ident.name cd1.cd_id <> Ident.name cd2.cd_id then
+        Some (Constructor_names (n, cd1.cd_id, cd2.cd_id))
+      else begin
+        Builtin_attributes.check_alerts_inclusion
+          ~def:cd1.cd_loc
+          ~use:cd2.cd_loc
+          loc
+          cd1.cd_attributes cd2.cd_attributes
+          (Ident.name cd1.cd_id);
+        match compare_constructors ~loc env params1 params2
+                cd1.cd_res cd2.cd_res cd1.cd_args cd2.cd_args with
+        | Some r ->
+            Some ((Constructor_mismatch (cd1, cd2, r)) : variant_mismatch)
+        | None -> compare_variants ~loc env params1 params2 (n+1) rem1 rem2
+      end
+
+and compare_labels env params1 params2
+      (ld1 : Types.label_declaration)
+      (ld2 : Types.label_declaration) =
+      if ld1.ld_mutable <> ld2.ld_mutable
+      then
+        let ord = if ld1.ld_mutable = Asttypes.Mutable then First else Second in
+        Some (Mutability  ord)
+      else
+        if Ctype.equal env true (ld1.ld_type::params1) (ld2.ld_type::params2)
+        then None
+        else Some (Type : label_mismatch)
+
+and compare_records ~loc env params1 params2 n
+    (labels1 : Types.label_declaration list)
+    (labels2 : Types.label_declaration list) =
+  match labels1, labels2 with
+  | [], []           -> None
+  | [], l::_ -> Some (Label_missing (Second, l.Types.ld_id))
+  | l::_, [] -> Some (Label_missing (First, l.Types.ld_id))
+  | ld1::rem1, ld2::rem2 ->
+      if Ident.name ld1.ld_id <> Ident.name ld2.ld_id
+      then Some (Label_names (n, ld1.ld_id, ld2.ld_id))
+      else begin
+        Builtin_attributes.check_deprecated_mutable_inclusion
+          ~def:ld1.ld_loc
+          ~use:ld2.ld_loc
+          loc
+          ld1.ld_attributes ld2.ld_attributes
+          (Ident.name ld1.ld_id);
+        match compare_labels env params1 params2 ld1 ld2 with
+        | Some r -> Some (Label_mismatch (ld1, ld2, r))
+        (* add arguments to the parameters, cf. PR#7378 *)
+        | None -> compare_records ~loc env
+                    (ld1.ld_type::params1) (ld2.ld_type::params2)
+                    (n+1)
+                    rem1 rem2
+      end
+
+let compare_records_with_representation ~loc env params1 params2 n
+      labels1 labels2 rep1 rep2
+  =
+  match compare_records ~loc env params1 params2 n labels1 labels2 with
+  | None when rep1 <> rep2 ->
+      let pos = if rep2 = Record_float then Second else First in
+      Some (Unboxed_float_representation pos)
+  | err -> err
+
+let type_declarations ?(equality = false) ~loc env ~mark name
+      decl1 path decl2 =
+  Builtin_attributes.check_alerts_inclusion
+    ~def:decl1.type_loc
+    ~use:decl2.type_loc
+    loc
+    decl1.type_attributes decl2.type_attributes
+    name;
+  if decl1.type_arity <> decl2.type_arity then Some Arity else
+  if not (private_flags decl1 decl2) then Some Privacy else
+  let err = match (decl1.type_manifest, decl2.type_manifest) with
+      (_, None) ->
+        if Ctype.equal env true decl1.type_params decl2.type_params
+        then None else Some Constraint
+    | (Some ty1, Some ty2) ->
+        if type_manifest env ty1 decl1.type_params ty2 decl2.type_params
+            decl2.type_private
+        then None else Some Manifest
+    | (None, Some ty2) ->
+        let ty1 =
+          Btype.newgenty (Tconstr(path, decl2.type_params, ref Mnil))
+        in
+        if Ctype.equal env true decl1.type_params decl2.type_params then
+          if Ctype.equal env false [ty1] [ty2] then None
+          else Some Manifest
+        else Some Constraint
+  in
+  if err <> None then err else
+  let err =
+    match (decl2.type_kind, decl1.type_unboxed.unboxed,
+           decl2.type_unboxed.unboxed) with
+    | Type_abstract, _, _ -> None
+    | _, true, false -> Some (Unboxed_representation First)
+    | _, false, true -> Some (Unboxed_representation Second)
+    | _ -> None
+  in
+  if err <> None then err else
+  let err = match (decl1.type_kind, decl2.type_kind) with
+      (_, Type_abstract) -> None
+    | (Type_variant cstrs1, Type_variant cstrs2) ->
+        if mark then begin
+          let mark usage cstrs =
+            List.iter (Env.mark_constructor_used usage) cstrs
+          in
+          let usage =
+            if decl2.type_private = Public then Env.Positive
+            else Env.Privatize
+          in
+          mark usage cstrs1;
+          if equality then mark Env.Positive cstrs2
+        end;
+        Option.map
+          (fun var_err -> Variant_mismatch var_err)
+          (compare_variants ~loc env decl1.type_params decl2.type_params 1
+             cstrs1 cstrs2)
+    | (Type_record(labels1,rep1), Type_record(labels2,rep2)) ->
+        Option.map (fun rec_err -> Record_mismatch rec_err)
+          (compare_records_with_representation ~loc env
+             decl1.type_params decl2.type_params 1
+             labels1 labels2
+             rep1 rep2)
+    | (Type_open, Type_open) -> None
+    | (_, _) -> Some Kind
+  in
+  if err <> None then err else
+  let abstr = decl2.type_kind = Type_abstract && decl2.type_manifest = None in
+  (* If attempt to assign a non-immediate type (e.g. string) to a type that
+   * must be immediate, then we error *)
+  let err =
+    if not abstr then
+      None
+    else
+      match
+        Type_immediacy.coerce decl1.type_immediate ~as_:decl2.type_immediate
+      with
+      | Ok () -> None
+      | Error violation -> Some (Immediate violation)
+  in
+  if err <> None then err else
+  let need_variance =
+    abstr || decl1.type_private = Private || decl1.type_kind = Type_open in
+  if not need_variance then None else
+  let abstr = abstr || decl2.type_private = Private in
+  let opn = decl2.type_kind = Type_open && decl2.type_manifest = None in
+  let constrained ty = not (Btype.(is_Tvar (repr ty))) in
+  if List.for_all2
+      (fun ty (v1,v2) ->
+        let open Variance in
+        let imp a b = not a || b in
+        let (co1,cn1) = get_upper v1 and (co2,cn2) = get_upper v2 in
+        (if abstr then (imp co1 co2 && imp cn1 cn2)
+         else if opn || constrained ty then (co1 = co2 && cn1 = cn2)
+         else true) &&
+        let (p1,n1,i1,j1) = get_lower v1 and (p2,n2,i2,j2) = get_lower v2 in
+        imp abstr (imp p2 p1 && imp n2 n1 && imp i2 i1 && imp j2 j1))
+      decl2.type_params (List.combine decl1.type_variance decl2.type_variance)
+  then None else Some Variance
+
+(* Inclusion between extension constructors *)
+
+let extension_constructors ~loc env ~mark id ext1 ext2 =
+  if mark then begin
+    let usage =
+      if ext2.ext_private = Public then Env.Positive
+      else Env.Privatize
+    in
+    Env.mark_extension_used usage ext1
+  end;
+  let ty1 =
+    Btype.newgenty (Tconstr(ext1.ext_type_path, ext1.ext_type_params, ref Mnil))
+  in
+  let ty2 =
+    Btype.newgenty (Tconstr(ext2.ext_type_path, ext2.ext_type_params, ref Mnil))
+  in
+  if not (Ctype.equal env true (ty1 :: ext1.ext_type_params)
+                               (ty2 :: ext2.ext_type_params))
+  then Some (Constructor_mismatch (id, ext1, ext2, Type))
+  else
+    let r =
+      compare_constructors ~loc env ext1.ext_type_params ext2.ext_type_params
+        ext1.ext_ret_type ext2.ext_ret_type
+        ext1.ext_args ext2.ext_args
+    in
+    match r with
+    | Some r -> Some (Constructor_mismatch (id, ext1, ext2, r))
+    | None -> match ext1.ext_private, ext2.ext_private with
+        Private, Public -> Some Constructor_privacy
+      | _, _ -> None
diff --git a/upstream/ocaml_412/typing/includecore.mli b/upstream/ocaml_412/typing/includecore.mli
new file mode 100644
index 0000000..560d0ac
--- /dev/null
+++ b/upstream/ocaml_412/typing/includecore.mli
@@ -0,0 +1,90 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the core language *)
+
+open Typedtree
+open Types
+
+exception Dont_match
+
+type position = Ctype.Unification_trace.position = First | Second
+
+type label_mismatch =
+  | Type
+  | Mutability of position
+
+type record_mismatch =
+  | Label_mismatch of label_declaration * label_declaration * label_mismatch
+  | Label_names of int * Ident.t * Ident.t
+  | Label_missing of position * Ident.t
+  | Unboxed_float_representation of position
+
+type constructor_mismatch =
+  | Type
+  | Arity
+  | Inline_record of record_mismatch
+  | Kind of position
+  | Explicit_return_type of position
+
+type variant_mismatch =
+  | Constructor_mismatch of constructor_declaration
+                            * constructor_declaration
+                            * constructor_mismatch
+  | Constructor_names of int * Ident.t * Ident.t
+  | Constructor_missing of position * Ident.t
+
+type extension_constructor_mismatch =
+  | Constructor_privacy
+  | Constructor_mismatch of Ident.t
+                            * extension_constructor
+                            * extension_constructor
+                            * constructor_mismatch
+
+type type_mismatch =
+  | Arity
+  | Privacy
+  | Kind
+  | Constraint
+  | Manifest
+  | Variance
+  | Record_mismatch of record_mismatch
+  | Variant_mismatch of variant_mismatch
+  | Unboxed_representation of position
+  | Immediate of Type_immediacy.Violation.t
+
+val value_descriptions:
+  loc:Location.t -> Env.t -> string ->
+  value_description -> value_description -> module_coercion
+
+val type_declarations:
+  ?equality:bool ->
+  loc:Location.t ->
+  Env.t -> mark:bool -> string ->
+  type_declaration -> Path.t -> type_declaration -> type_mismatch option
+
+val extension_constructors:
+  loc:Location.t -> Env.t -> mark:bool -> Ident.t ->
+  extension_constructor -> extension_constructor ->
+  extension_constructor_mismatch option
+(*
+val class_types:
+        Env.t -> class_type -> class_type -> bool
+*)
+
+val report_type_mismatch:
+    string -> string -> string -> Format.formatter -> type_mismatch -> unit
+val report_extension_constructor_mismatch: string -> string -> string ->
+  Format.formatter -> extension_constructor_mismatch -> unit
diff --git a/upstream/ocaml_412/typing/includemod.ml b/upstream/ocaml_412/typing/includemod.ml
new file mode 100644
index 0000000..e2e63ec
--- /dev/null
+++ b/upstream/ocaml_412/typing/includemod.ml
@@ -0,0 +1,896 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the module language *)
+
+open Misc
+open Typedtree
+open Types
+
+type symptom =
+    Missing_field of Ident.t * Location.t * string (* kind *)
+  | Value_descriptions of Ident.t * value_description * value_description
+  | Type_declarations of Ident.t * type_declaration
+        * type_declaration * Includecore.type_mismatch
+  | Extension_constructors of Ident.t * extension_constructor
+        * extension_constructor * Includecore.extension_constructor_mismatch
+  | Module_types of module_type * module_type
+  | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration
+  | Modtype_permutation of Types.module_type * Typedtree.module_coercion
+  | Interface_mismatch of string * string
+  | Class_type_declarations of
+      Ident.t * class_type_declaration * class_type_declaration *
+      Ctype.class_match_failure list
+  | Class_declarations of
+      Ident.t * class_declaration * class_declaration *
+      Ctype.class_match_failure list
+  | Unbound_modtype_path of Path.t
+  | Unbound_module_path of Path.t
+  | Invalid_module_alias of Path.t
+
+type pos =
+  | Module of Ident.t
+  | Modtype of Ident.t
+  | Arg of functor_parameter
+  | Body of functor_parameter
+type error = pos list * Env.t * symptom
+
+exception Error of error list
+exception Apply_error of Location.t * Path.t * Path.t * error list
+
+type mark =
+  | Mark_both
+  | Mark_positive
+  | Mark_negative
+  | Mark_neither
+
+let negate_mark = function
+  | Mark_both -> Mark_both
+  | Mark_positive -> Mark_negative
+  | Mark_negative -> Mark_positive
+  | Mark_neither -> Mark_neither
+
+let mark_positive = function
+  | Mark_both | Mark_positive -> true
+  | Mark_negative | Mark_neither -> false
+
+(* All functions "blah env x1 x2" check that x1 is included in x2,
+   i.e. that x1 is the type of an implementation that fulfills the
+   specification x2. If not, Error is raised with a backtrace of the error. *)
+
+(* Inclusion between value descriptions *)
+
+let value_descriptions ~loc env ~mark cxt subst id vd1 vd2 =
+  Cmt_format.record_value_dependency vd1 vd2;
+  if mark_positive mark then
+    Env.mark_value_used vd1.val_uid;
+  let vd2 = Subst.value_description subst vd2 in
+  try
+    Includecore.value_descriptions ~loc env (Ident.name id) vd1 vd2
+  with Includecore.Dont_match ->
+    raise(Error[cxt, env, Value_descriptions(id, vd1, vd2)])
+
+(* Inclusion between type declarations *)
+
+let type_declarations ~loc env ~mark ?old_env:_ cxt subst id decl1 decl2 =
+  let mark = mark_positive mark in
+  if mark then
+    Env.mark_type_used decl1.type_uid;
+  let decl2 = Subst.type_declaration subst decl2 in
+  match
+    Includecore.type_declarations ~loc env ~mark
+      (Ident.name id) decl1 (Path.Pident id) decl2
+  with
+  | None -> ()
+  | Some err ->
+      raise(Error[cxt, env, Type_declarations(id, decl1, decl2, err)])
+
+(* Inclusion between extension constructors *)
+
+let extension_constructors ~loc env ~mark cxt subst id ext1 ext2 =
+  let mark = mark_positive mark in
+  let ext2 = Subst.extension_constructor subst ext2 in
+  match Includecore.extension_constructors ~loc env ~mark id ext1 ext2 with
+  | None -> ()
+  | Some err ->
+      raise(Error[cxt, env, Extension_constructors(id, ext1, ext2, err)])
+
+(* Inclusion between class declarations *)
+
+let class_type_declarations ~loc ~old_env:_ env cxt subst id decl1 decl2 =
+  let decl2 = Subst.cltype_declaration subst decl2 in
+  match Includeclass.class_type_declarations ~loc env decl1 decl2 with
+    []     -> ()
+  | reason ->
+      raise(Error[cxt, env,
+                  Class_type_declarations(id, decl1, decl2, reason)])
+
+let class_declarations ~old_env:_ env cxt subst id decl1 decl2 =
+  let decl2 = Subst.class_declaration subst decl2 in
+  match Includeclass.class_declarations env decl1 decl2 with
+    []     -> ()
+  | reason ->
+      raise(Error[cxt, env, Class_declarations(id, decl1, decl2, reason)])
+
+(* Expand a module type identifier when possible *)
+
+exception Dont_match
+
+let try_expand_modtype_path env path =
+  try
+    Env.find_modtype_expansion path env
+  with Not_found -> raise Dont_match
+
+let expand_module_alias env cxt path =
+  try (Env.find_module path env).md_type
+  with Not_found ->
+    raise(Error[cxt, env, Unbound_module_path path])
+
+(* Extract name, kind and ident from a signature item *)
+
+type field_desc =
+    Field_value of string
+  | Field_type of string
+  | Field_exception of string
+  | Field_typext of string
+  | Field_module of string
+  | Field_modtype of string
+  | Field_class of string
+  | Field_classtype of string
+
+let kind_of_field_desc = function
+  | Field_value _ -> "value"
+  | Field_type _ -> "type"
+  | Field_exception _ -> "exception"
+  | Field_typext _ -> "extension constructor"
+  | Field_module _ -> "module"
+  | Field_modtype _ -> "module type"
+  | Field_class _ -> "class"
+  | Field_classtype _ -> "class type"
+
+(** Map indexed by both field types and names.
+    This avoids name clashes between different sorts of fields
+    such as values and types. *)
+module FieldMap = Map.Make(struct
+    type t = field_desc
+    let compare = Stdlib.compare
+  end)
+
+let item_ident_name = function
+    Sig_value(id, d, _) -> (id, d.val_loc, Field_value(Ident.name id))
+  | Sig_type(id, d, _, _) -> (id, d.type_loc, Field_type(Ident.name id))
+  | Sig_typext(id, d, _, _) ->
+     let kind =
+       if Path.same d.ext_type_path Predef.path_exn
+       then Field_exception(Ident.name id)
+       else Field_typext(Ident.name id)
+     in
+     (id, d.ext_loc, kind)
+  | Sig_module(id, _, d, _, _) -> (id, d.md_loc, Field_module(Ident.name id))
+  | Sig_modtype(id, d, _) -> (id, d.mtd_loc, Field_modtype(Ident.name id))
+  | Sig_class(id, d, _, _) -> (id, d.cty_loc, Field_class(Ident.name id))
+  | Sig_class_type(id, d, _, _) ->
+      (id, d.clty_loc, Field_classtype(Ident.name id))
+
+let is_runtime_component = function
+  | Sig_value(_,{val_kind = Val_prim _}, _)
+  | Sig_type(_,_,_,_)
+  | Sig_module(_,Mp_absent,_,_,_)
+  | Sig_modtype(_,_,_)
+  | Sig_class_type(_,_,_,_) -> false
+  | Sig_value(_,_,_)
+  | Sig_typext(_,_,_,_)
+  | Sig_module(_,Mp_present,_,_,_)
+  | Sig_class(_,_,_,_) -> true
+
+(* Print a coercion *)
+
+let rec print_list pr ppf = function
+    [] -> ()
+  | [a] -> pr ppf a
+  | a :: l -> pr ppf a; Format.fprintf ppf ";@ "; print_list pr ppf l
+let print_list pr ppf l =
+  Format.fprintf ppf "[@[%a@]]" (print_list pr) l
+
+let rec print_coercion ppf c =
+  let pr fmt = Format.fprintf ppf fmt in
+  match c with
+    Tcoerce_none -> pr "id"
+  | Tcoerce_structure (fl, nl) ->
+      pr "@[<2>struct@ %a@ %a@]"
+        (print_list print_coercion2) fl
+        (print_list print_coercion3) nl
+  | Tcoerce_functor (inp, out) ->
+      pr "@[<2>functor@ (%a)@ (%a)@]"
+        print_coercion inp
+        print_coercion out
+  | Tcoerce_primitive {pc_desc; pc_env = _; pc_type}  ->
+      pr "prim %s@ (%a)" pc_desc.Primitive.prim_name
+        Printtyp.raw_type_expr pc_type
+  | Tcoerce_alias (_, p, c) ->
+      pr "@[<2>alias %a@ (%a)@]"
+        Printtyp.path p
+        print_coercion c
+and print_coercion2 ppf (n, c) =
+  Format.fprintf ppf "@[%d,@ %a@]" n print_coercion c
+and print_coercion3 ppf (i, n, c) =
+  Format.fprintf ppf "@[%s, %d,@ %a@]"
+    (Ident.unique_name i) n print_coercion c
+
+(* Simplify a structure coercion *)
+
+let equal_module_paths env p1 subst p2 =
+  Path.same p1 p2
+  || Path.same (Env.normalize_module_path None env p1)
+       (Env.normalize_module_path None env
+          (Subst.module_path subst p2))
+
+let equal_modtype_paths env p1 subst p2 =
+  Path.same p1 p2
+  || Path.same (Env.normalize_modtype_path env p1)
+       (Env.normalize_modtype_path env
+          (Subst.modtype_path subst p2))
+
+let simplify_structure_coercion cc id_pos_list =
+  let rec is_identity_coercion pos = function
+  | [] ->
+      true
+  | (n, c) :: rem ->
+      n = pos && c = Tcoerce_none && is_identity_coercion (pos + 1) rem in
+  if is_identity_coercion 0 cc
+  then Tcoerce_none
+  else Tcoerce_structure (cc, id_pos_list)
+
+(* Inclusion between module types.
+   Return the restriction that transforms a value of the smaller type
+   into a value of the bigger type. *)
+
+let rec modtypes ~loc env ~mark cxt subst mty1 mty2 =
+  try
+    try_modtypes ~loc env ~mark cxt subst mty1 mty2
+  with
+    Dont_match ->
+      raise(Error[cxt, env,
+                  Module_types(mty1, Subst.modtype Make_local subst mty2)])
+  | Error reasons as err ->
+      match mty1, mty2 with
+        Mty_alias _, _
+      | _, Mty_alias _ -> raise err
+      | _ ->
+          raise(Error((cxt, env,
+                       Module_types(mty1, Subst.modtype Make_local subst mty2))
+                      :: reasons))
+
+and try_modtypes ~loc env ~mark cxt subst mty1 mty2 =
+  match mty1, mty2 with
+  | (Mty_alias p1, Mty_alias p2) ->
+      if Env.is_functor_arg p2 env then
+        raise (Error[cxt, env, Invalid_module_alias p2]);
+      if not (equal_module_paths env p1 subst p2) then
+        raise Dont_match;
+      Tcoerce_none
+  | (Mty_alias p1, _) ->
+      let p1 = try
+        Env.normalize_module_path (Some Location.none) env p1
+      with Env.Error (Env.Missing_module (_, _, path)) ->
+        raise (Error[cxt, env, Unbound_module_path path])
+      in
+      let mty1 = expand_module_alias env cxt p1 in
+      strengthened_modtypes ~loc ~aliasable:true env ~mark cxt
+        subst mty1 p1 mty2
+  | (Mty_ident p1, Mty_ident p2) ->
+      let p1 = Env.normalize_modtype_path env p1 in
+      let p2 = Env.normalize_modtype_path env (Subst.modtype_path subst p2) in
+      if Path.same p1 p2 then Tcoerce_none
+      else
+        try_modtypes ~loc env ~mark cxt subst
+          (try_expand_modtype_path env p1)
+          (try_expand_modtype_path env p2)
+  | (Mty_ident p1, _) ->
+      let p1 = Env.normalize_modtype_path env p1 in
+      try_modtypes ~loc env ~mark cxt subst
+        (try_expand_modtype_path env p1) mty2
+  | (_, Mty_ident p2) ->
+      let p2 = Env.normalize_modtype_path env (Subst.modtype_path subst p2) in
+      try_modtypes ~loc env ~mark cxt subst mty1
+        (try_expand_modtype_path env p2)
+  | (Mty_signature sig1, Mty_signature sig2) ->
+      signatures ~loc env ~mark cxt subst sig1 sig2
+  | (Mty_functor(Unit, res1), Mty_functor(Unit, res2)) ->
+    begin
+      match modtypes ~loc env ~mark (Body Unit::cxt) subst res1 res2 with
+      | Tcoerce_none -> Tcoerce_none
+      | cc -> Tcoerce_functor (Tcoerce_none, cc)
+    end
+  | (Mty_functor(Named (param1, arg1) as arg, res1),
+     Mty_functor(Named (param2, arg2), res2)) ->
+      let arg2' = Subst.modtype Keep subst arg2 in
+      let cc_arg =
+        modtypes ~loc env ~mark:(negate_mark mark)
+          (Arg arg::cxt) Subst.identity arg2' arg1
+      in
+      let env, subst =
+        match param1, param2 with
+        | Some p1, Some p2 ->
+            Env.add_module p1 Mp_present arg2' env,
+            Subst.add_module p2 (Path.Pident p1) subst
+        | None, Some p2 ->
+            Env.add_module p2 Mp_present arg2' env, subst
+        | Some p1, None ->
+            Env.add_module p1 Mp_present arg2' env, subst
+        | None, None ->
+            env, subst
+      in
+      let cc_res = modtypes ~loc env ~mark (Body arg::cxt) subst res1 res2 in
+      begin match (cc_arg, cc_res) with
+          (Tcoerce_none, Tcoerce_none) -> Tcoerce_none
+        | _ -> Tcoerce_functor(cc_arg, cc_res)
+      end
+  | (_, _) ->
+      raise Dont_match
+
+and strengthened_modtypes ~loc ~aliasable env ~mark cxt subst mty1 path1 mty2 =
+  match mty1, mty2 with
+  | Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 ->
+      Tcoerce_none
+  | _, _ ->
+      let mty1 = Mtype.strengthen ~aliasable env mty1 path1 in
+      modtypes ~loc env ~mark cxt subst mty1 mty2
+
+and strengthened_module_decl ~loc ~aliasable env ~mark cxt subst md1 path1 md2 =
+  match md1.md_type, md2.md_type with
+  | Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 ->
+      Tcoerce_none
+  | _, _ ->
+      let md1 = Mtype.strengthen_decl ~aliasable env md1 path1 in
+      modtypes ~loc env ~mark cxt subst md1.md_type md2.md_type
+
+(* Inclusion between signatures *)
+
+and signatures ~loc env ~mark cxt subst sig1 sig2 =
+  (* Environment used to check inclusion of components *)
+  let new_env =
+    Env.add_signature sig1 (Env.in_signature true env) in
+  (* Keep ids for module aliases *)
+  let (id_pos_list,_) =
+    List.fold_left
+      (fun (l,pos) -> function
+          Sig_module (id, Mp_present, _, _, _) ->
+            ((id,pos,Tcoerce_none)::l , pos+1)
+        | item -> (l, if is_runtime_component item then pos+1 else pos))
+      ([], 0) sig1 in
+  (* Build a table of the components of sig1, along with their positions.
+     The table is indexed by kind and name of component *)
+  let rec build_component_table pos tbl = function
+      [] -> pos, tbl
+    | (Sig_value (_, _, Hidden)
+      |Sig_type (_, _, _, Hidden)
+      |Sig_typext (_, _, _, Hidden)
+      |Sig_module (_, _, _, _, Hidden)
+      |Sig_modtype (_, _, Hidden)
+      |Sig_class (_, _, _, Hidden)
+      |Sig_class_type (_, _, _, Hidden)
+      ) as item :: rem ->
+        let pos = if is_runtime_component item then pos + 1 else pos in
+        build_component_table pos tbl rem (* do not pair private items. *)
+    | item :: rem ->
+        let (id, _loc, name) = item_ident_name item in
+        let pos, nextpos =
+          if is_runtime_component item then pos, pos + 1
+          else -1, pos
+        in
+        build_component_table nextpos
+                              (FieldMap.add name (id, item, pos) tbl) rem in
+  let len1, comps1 =
+    build_component_table 0 FieldMap.empty sig1 in
+  let len2 =
+    List.fold_left
+      (fun n i -> if is_runtime_component i then n + 1 else n)
+      0
+      sig2
+  in
+  (* Pair each component of sig2 with a component of sig1,
+     identifying the names along the way.
+     Return a coercion list indicating, for all run-time components
+     of sig2, the position of the matching run-time components of sig1
+     and the coercion to be applied to it. *)
+  let rec pair_components subst paired unpaired = function
+      [] ->
+        begin match unpaired with
+            [] ->
+              let cc =
+                signature_components ~loc env ~mark new_env cxt subst
+                  (List.rev paired)
+              in
+              if len1 = len2 then (* see PR#5098 *)
+                simplify_structure_coercion cc id_pos_list
+              else
+                Tcoerce_structure (cc, id_pos_list)
+          | _  -> raise(Error unpaired)
+        end
+    | item2 :: rem ->
+        let (id2, loc, name2) = item_ident_name item2 in
+        let name2, report =
+          match item2, name2 with
+            Sig_type (_, {type_manifest=None}, _, _), Field_type s
+            when Btype.is_row_name s ->
+              (* Do not report in case of failure,
+                 as the main type will generate an error *)
+              Field_type (String.sub s 0 (String.length s - 4)), false
+          | _ -> name2, true
+        in
+        begin try
+          let (id1, item1, pos1) = FieldMap.find name2 comps1 in
+          let new_subst =
+            match item2 with
+              Sig_type _ ->
+                Subst.add_type id2 (Path.Pident id1) subst
+            | Sig_module _ ->
+                Subst.add_module id2 (Path.Pident id1) subst
+            | Sig_modtype _ ->
+                Subst.add_modtype id2 (Mty_ident (Path.Pident id1)) subst
+            | Sig_value _ | Sig_typext _
+            | Sig_class _ | Sig_class_type _ ->
+                subst
+          in
+          pair_components new_subst
+            ((item1, item2, pos1) :: paired) unpaired rem
+        with Not_found ->
+          let unpaired =
+            if report then
+              (cxt, env, Missing_field (id2, loc, kind_of_field_desc name2)) ::
+              unpaired
+            else unpaired in
+          pair_components subst paired unpaired rem
+        end in
+  (* Do the pairing and checking, and return the final coercion *)
+  pair_components subst [] [] sig2
+
+(* Inclusion between signature components *)
+
+and signature_components ~loc old_env ~mark env cxt subst paired =
+  let comps_rec rem =
+    signature_components ~loc old_env ~mark env cxt subst rem
+  in
+  match paired with
+    [] -> []
+  | (Sig_value(id1, valdecl1, _), Sig_value(_id2, valdecl2, _), pos) :: rem ->
+      let cc =
+        value_descriptions ~loc env ~mark cxt subst id1 valdecl1 valdecl2
+      in
+      begin match valdecl2.val_kind with
+        Val_prim _ -> comps_rec rem
+      | _ -> (pos, cc) :: comps_rec rem
+      end
+  | (Sig_type(id1, tydecl1, _, _), Sig_type(_id2, tydecl2, _, _), _pos) :: rem
+    ->
+      type_declarations ~loc ~old_env env ~mark cxt subst id1 tydecl1 tydecl2;
+      comps_rec rem
+  | (Sig_typext(id1, ext1, _, _), Sig_typext(_id2, ext2, _, _), pos)
+    :: rem ->
+      extension_constructors ~loc env ~mark cxt subst id1 ext1 ext2;
+      (pos, Tcoerce_none) :: comps_rec rem
+  | (Sig_module(id1, pres1, mty1, _, _),
+     Sig_module(_id2, pres2, mty2, _, _), pos) :: rem -> begin
+      let cc = module_declarations ~loc env ~mark cxt subst id1 mty1 mty2 in
+      let rem = comps_rec rem in
+      match pres1, pres2, mty1.md_type with
+      | Mp_present, Mp_present, _ -> (pos, cc) :: rem
+      | _, Mp_absent, _ -> rem
+      | Mp_absent, Mp_present, Mty_alias p1 ->
+          (pos, Tcoerce_alias (env, p1, cc)) :: rem
+      | Mp_absent, Mp_present, _ -> assert false
+    end
+  | (Sig_modtype(id1, info1, _), Sig_modtype(_id2, info2, _), _pos) :: rem ->
+      modtype_infos ~loc env ~mark cxt subst id1 info1 info2;
+      comps_rec rem
+  | (Sig_class(id1, decl1, _, _), Sig_class(_id2, decl2, _, _), pos) :: rem ->
+      class_declarations ~old_env env cxt subst id1 decl1 decl2;
+      (pos, Tcoerce_none) :: comps_rec rem
+  | (Sig_class_type(id1, info1, _, _),
+     Sig_class_type(_id2, info2, _, _), _pos) :: rem ->
+      class_type_declarations ~loc ~old_env env cxt subst id1 info1 info2;
+      comps_rec rem
+  | _ ->
+      assert false
+
+and module_declarations ~loc env ~mark cxt subst id1 md1 md2 =
+  Builtin_attributes.check_alerts_inclusion
+    ~def:md1.md_loc
+    ~use:md2.md_loc
+    loc
+    md1.md_attributes md2.md_attributes
+    (Ident.name id1);
+  let p1 = Path.Pident id1 in
+  if mark_positive mark then
+    Env.mark_module_used md1.md_uid;
+  strengthened_modtypes ~loc ~aliasable:true env ~mark (Module id1::cxt) subst
+    md1.md_type p1 md2.md_type
+
+(* Inclusion between module type specifications *)
+
+and modtype_infos ~loc env ~mark cxt subst id info1 info2 =
+  Builtin_attributes.check_alerts_inclusion
+    ~def:info1.mtd_loc
+    ~use:info2.mtd_loc
+    loc
+    info1.mtd_attributes info2.mtd_attributes
+    (Ident.name id);
+  let info2 = Subst.modtype_declaration Keep subst info2 in
+  let cxt' = Modtype id :: cxt in
+  try
+    match (info1.mtd_type, info2.mtd_type) with
+      (None, None) -> ()
+    | (Some _, None) -> ()
+    | (Some mty1, Some mty2) ->
+        check_modtype_equiv ~loc env ~mark cxt' mty1 mty2
+    | (None, Some mty2) ->
+        check_modtype_equiv ~loc env ~mark cxt' (Mty_ident(Path.Pident id)) mty2
+  with Error reasons ->
+    raise(Error((cxt, env, Modtype_infos(id, info1, info2)) :: reasons))
+
+and check_modtype_equiv ~loc env ~mark cxt mty1 mty2 =
+  match
+    (modtypes ~loc env ~mark cxt Subst.identity mty1 mty2,
+     modtypes ~loc env ~mark:(negate_mark mark) cxt Subst.identity mty2 mty1)
+  with
+    (Tcoerce_none, Tcoerce_none) -> ()
+  | (c1, _c2) ->
+      (* Format.eprintf "@[c1 = %a@ c2 = %a@]@."
+        print_coercion _c1 print_coercion _c2; *)
+      raise(Error [cxt, env, Modtype_permutation (mty1, c1)])
+
+(* Simplified inclusion check between module types (for Env) *)
+
+let can_alias env path =
+  let rec no_apply = function
+    | Path.Pident _ -> true
+    | Path.Pdot(p, _) -> no_apply p
+    | Path.Papply _ -> false
+  in
+  no_apply path && not (Env.is_functor_arg path env)
+
+let check_modtype_inclusion ~loc env mty1 path1 mty2 =
+  let aliasable = can_alias env path1 in
+  ignore
+    (strengthened_modtypes ~loc ~aliasable env ~mark:Mark_both []
+       Subst.identity mty1 path1 mty2)
+
+let () =
+  Env.check_functor_application :=
+    (fun ~errors ~loc env mty1 path1 mty2 path2 ->
+       try
+         check_modtype_inclusion ~loc env mty1 path1 mty2
+       with Error errs ->
+         if errors then
+           raise (Apply_error(loc, path1, path2, errs))
+         else
+           raise Not_found)
+
+(* Check that an implementation of a compilation unit meets its
+   interface. *)
+
+let compunit env ~mark impl_name impl_sig intf_name intf_sig =
+  try
+    signatures ~loc:(Location.in_file impl_name) env ~mark []
+      Subst.identity impl_sig intf_sig
+  with Error reasons ->
+    raise(Error(([], Env.empty,Interface_mismatch(impl_name, intf_name))
+                :: reasons))
+
+(* Hide the context and substitution parameters to the outside world *)
+
+let modtypes ~loc env ~mark mty1 mty2 =
+  modtypes ~loc env ~mark [] Subst.identity mty1 mty2
+let signatures env ~mark sig1 sig2 =
+  signatures ~loc:Location.none env ~mark [] Subst.identity sig1 sig2
+let type_declarations ~loc env ~mark id decl1 decl2 =
+  type_declarations ~loc env ~mark [] Subst.identity id decl1 decl2
+let strengthened_module_decl ~loc ~aliasable env ~mark
+      md1 path1 md2 =
+  strengthened_module_decl ~loc ~aliasable env ~mark [] Subst.identity
+    md1 path1 md2
+
+(*
+let modtypes env m1 m2 =
+  let c = modtypes env m1 m2 in
+  Format.eprintf "@[<2>modtypes@ %a@ %a =@ %a@]@."
+    Printtyp.modtype m1 Printtyp.modtype m2
+    print_coercion c;
+  c
+*)
+
+(* Error report *)
+
+module Illegal_permutation = struct
+  (** Extraction of information in case of illegal permutation
+      in a module type *)
+
+  (** When examining coercions, we only have runtime component indices,
+      we use thus a limited version of {!pos}. *)
+  type coerce_pos =
+    | Item of int
+    | InArg
+    | InBody
+
+  let either f x g y = match f x with
+    | None -> g y
+    | Some _ as v -> v
+
+  (** We extract a lone transposition from a full tree of permutations. *)
+  let rec transposition_under path = function
+    | Tcoerce_structure(c,_) ->
+        either
+          (not_fixpoint path 0) c
+          (first_non_id path 0) c
+    | Tcoerce_functor(arg,res) ->
+        either
+          (transposition_under (InArg::path)) arg
+          (transposition_under (InBody::path)) res
+    | Tcoerce_none -> None
+    | Tcoerce_alias _ | Tcoerce_primitive _ ->
+        (* these coercions are not inversible, and raise an error earlier when
+           checking for module type equivalence *)
+        assert false
+  (* we search the first point which is not invariant at the current level *)
+  and not_fixpoint path pos = function
+    | [] -> None
+    | (n, _) :: q ->
+        if n = pos then
+          not_fixpoint path (pos+1) q
+        else
+          Some(List.rev path, pos, n)
+  (* we search the first item with a non-identity inner coercion *)
+  and first_non_id path pos = function
+    | [] -> None
+    | (_,Tcoerce_none) :: q -> first_non_id path (pos + 1) q
+    | (_,c) :: q ->
+        either
+          (transposition_under (Item pos :: path)) c
+          (first_non_id path (pos + 1)) q
+
+  let transposition c =
+    match transposition_under [] c with
+    | None -> raise Not_found
+    | Some x -> x
+
+  let rec runtime_item k = function
+    | [] -> raise Not_found
+    | item :: q ->
+        if not(is_runtime_component item) then
+          runtime_item k q
+        else if k = 0 then
+          item
+        else
+          runtime_item (k-1) q
+
+  (* Find module type at position [path] and convert the [coerce_pos] path to
+     a [pos] path *)
+  let rec find env ctx path mt = match mt, path with
+    | (Mty_ident p | Mty_alias p), _ ->
+        begin match (Env.find_modtype p env).mtd_type with
+        | None -> raise Not_found
+        | Some mt -> find env ctx path mt
+        end
+    | Mty_signature s , [] -> List.rev ctx, s
+    | Mty_signature s, Item k :: q ->
+        begin match runtime_item k s with
+        | Sig_module (id, _, md,_,_) -> find env (Module id :: ctx) q md.md_type
+        | _ -> raise Not_found
+        end
+    | Mty_functor(Named (_,mt) as arg,_), InArg :: q ->
+        find env (Arg arg :: ctx) q mt
+    | Mty_functor(arg, mt), InBody :: q ->
+        find env (Body arg :: ctx) q mt
+    | _ -> raise Not_found
+
+  let find env path mt = find env [] path mt
+  let item mt k = item_ident_name (runtime_item k mt)
+
+  let pp_item ppf (id,_,kind) =
+    Format.fprintf ppf "%s %S" (kind_of_field_desc kind) (Ident.name id)
+
+  let pp ctx_printer env ppf (mty,c) =
+    try
+      let p, k, l = transposition c in
+      let ctx, mt = find env p mty in
+      Format.fprintf ppf
+        "@[<hv 2>Illegal permutation of runtime components in a module type.@ \
+         @[For example,@ %a@[the %a@ and the %a are not in the same order@ \
+         in the expected and actual module types.@]@]"
+        ctx_printer ctx pp_item (item mt k) pp_item (item mt l)
+    with Not_found -> (* this should not happen *)
+      Format.fprintf ppf
+        "Illegal permutation of runtime components in a module type."
+
+end
+
+open Format
+
+let show_loc msg ppf loc =
+  let pos = loc.Location.loc_start in
+  if List.mem pos.Lexing.pos_fname [""; "_none_"; "//toplevel//"] then ()
+  else fprintf ppf "@\n@[<2>%a:@ %s@]" Location.print_loc loc msg
+
+let show_locs ppf (loc1, loc2) =
+  show_loc "Expected declaration" ppf loc2;
+  show_loc "Actual declaration" ppf loc1
+
+let path_of_context = function
+    Module id :: rem ->
+      let rec subm path = function
+        | [] -> path
+        | Module id :: rem -> subm (Path.Pdot (path, Ident.name id)) rem
+        | _ -> assert false
+      in subm (Path.Pident id) rem
+  | _ -> assert false
+
+
+let rec context ppf = function
+    Module id :: rem ->
+      fprintf ppf "@[<2>module %a%a@]" Printtyp.ident id args rem
+  | Modtype id :: rem ->
+      fprintf ppf "@[<2>module type %a =@ %a@]"
+        Printtyp.ident id context_mty rem
+  | Body x :: rem ->
+      fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem
+  | Arg x :: rem ->
+      fprintf ppf "functor (%s : %a) -> ..." (argname x) context_mty rem
+  | [] ->
+      fprintf ppf "<here>"
+and context_mty ppf = function
+    (Module _ | Modtype _) :: _ as rem ->
+      fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem
+  | cxt -> context ppf cxt
+and args ppf = function
+    Body x :: rem ->
+      fprintf ppf "(%s)%a" (argname x) args rem
+  | Arg x :: rem ->
+      fprintf ppf "(%s :@ %a) : ..." (argname  x) context_mty rem
+  | cxt ->
+      fprintf ppf " :@ %a" context_mty cxt
+and argname = function
+  | Unit -> ""
+  | Named (None, _) -> "_"
+  | Named (Some id, _) -> Ident.name id
+
+let alt_context ppf cxt =
+  if cxt = [] then () else
+  if List.for_all (function Module _ -> true | _ -> false) cxt then
+    fprintf ppf "in module %a,@ " Printtyp.path (path_of_context cxt)
+  else
+    fprintf ppf "@[<hv 2>at position@ %a,@]@ " context cxt
+
+let context ppf cxt =
+  if cxt = [] then () else
+  if List.for_all (function Module _ -> true | _ -> false) cxt then
+    fprintf ppf "In module %a:@ " Printtyp.path (path_of_context cxt)
+  else
+    fprintf ppf "@[<hv 2>At position@ %a@]@ " context cxt
+
+let include_err env ppf = function
+  | Missing_field (id, loc, kind) ->
+      fprintf ppf "The %s `%a' is required but not provided"
+        kind Printtyp.ident id;
+      show_loc "Expected declaration" ppf loc
+  | Value_descriptions(id, d1, d2) ->
+      fprintf ppf
+        "@[<hv 2>Values do not match:@ %a@;<1 -2>is not included in@ %a@]"
+        !Oprint.out_sig_item (Printtyp.tree_of_value_description id d1)
+        !Oprint.out_sig_item (Printtyp.tree_of_value_description id d2);
+      show_locs ppf (d1.val_loc, d2.val_loc)
+  | Type_declarations(id, d1, d2, err) ->
+      fprintf ppf "@[<v>@[<hv>%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]"
+        "Type declarations do not match"
+        !Oprint.out_sig_item
+        (Printtyp.tree_of_type_declaration id d1 Trec_first)
+        "is not included in"
+        !Oprint.out_sig_item
+        (Printtyp.tree_of_type_declaration id d2 Trec_first)
+        (Includecore.report_type_mismatch
+           "the first" "the second" "declaration") err
+        show_locs (d1.type_loc, d2.type_loc)
+  | Extension_constructors(id, x1, x2, err) ->
+      fprintf ppf "@[<v>@[<hv>%s:@;<1 2>%a@ %s@;<1 2>%a@]@ %a%a@]"
+        "Extension declarations do not match"
+        !Oprint.out_sig_item
+        (Printtyp.tree_of_extension_constructor id x1 Text_first)
+        "is not included in"
+        !Oprint.out_sig_item
+        (Printtyp.tree_of_extension_constructor id x2 Text_first)
+        (Includecore.report_extension_constructor_mismatch
+           "the first" "the second" "declaration") err
+        show_locs (x1.ext_loc, x2.ext_loc)
+  | Module_types(mty1, mty2)->
+      fprintf ppf
+       "@[<hv 2>Modules do not match:@ \
+        %a@;<1 -2>is not included in@ %a@]"
+      !Oprint.out_module_type (Printtyp.tree_of_modtype mty1)
+      !Oprint.out_module_type (Printtyp.tree_of_modtype mty2)
+  | Modtype_infos(id, d1, d2) ->
+      fprintf ppf
+       "@[<hv 2>Module type declarations do not match:@ \
+        %a@;<1 -2>does not match@ %a@]"
+      !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d1)
+      !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d2)
+  | Modtype_permutation (mty,c) ->
+      Illegal_permutation.pp alt_context env ppf (mty,c)
+  | Interface_mismatch(impl_name, intf_name) ->
+      fprintf ppf "@[The implementation %s@ does not match the interface %s:"
+       impl_name intf_name
+  | Class_type_declarations(id, d1, d2, reason) ->
+      fprintf ppf
+       "@[<hv 2>Class type declarations do not match:@ \
+        %a@;<1 -2>does not match@ %a@]@ %a"
+       !Oprint.out_sig_item
+       (Printtyp.tree_of_cltype_declaration id d1 Trec_first)
+       !Oprint.out_sig_item
+       (Printtyp.tree_of_cltype_declaration id d2 Trec_first)
+      Includeclass.report_error reason
+  | Class_declarations(id, d1, d2, reason) ->
+      fprintf ppf
+       "@[<hv 2>Class declarations do not match:@ \
+        %a@;<1 -2>does not match@ %a@]@ %a"
+      !Oprint.out_sig_item (Printtyp.tree_of_class_declaration id d1 Trec_first)
+      !Oprint.out_sig_item (Printtyp.tree_of_class_declaration id d2 Trec_first)
+      Includeclass.report_error reason
+  | Unbound_modtype_path path ->
+      fprintf ppf "Unbound module type %a" Printtyp.path path
+  | Unbound_module_path path ->
+      fprintf ppf "Unbound module %a" Printtyp.path path
+  | Invalid_module_alias path ->
+      fprintf ppf "Module %a cannot be aliased" Printtyp.path path
+
+let include_err ppf (cxt, env, err) =
+  Printtyp.wrap_printing_env ~error:true env (fun () ->
+    fprintf ppf "@[<v>%a%a@]" context (List.rev cxt) (include_err env) err)
+
+let buffer = ref Bytes.empty
+let is_big obj =
+  let size = !Clflags.error_size in
+  size > 0 &&
+  begin
+    if Bytes.length !buffer < size then buffer := Bytes.create size;
+    try ignore (Marshal.to_buffer !buffer 0 size obj []); false
+    with _ -> true
+  end
+
+let report_error ppf errs =
+  if errs = [] then () else
+  let (errs , err) = split_last errs in
+  let pe = ref true in
+  let include_err' ppf (_,_,obj as err) =
+    if not (is_big obj) then fprintf ppf "%a@ " include_err err
+    else if !pe then (fprintf ppf "...@ "; pe := false)
+  in
+  let print_errs ppf = List.iter (include_err' ppf) in
+  Printtyp.Conflicts.reset();
+  fprintf ppf "@[<v>%a%a%t@]" print_errs errs include_err err
+    Printtyp.Conflicts.print_explanations
+
+let report_apply_error p1 p2 ppf errs =
+  fprintf ppf "@[The type of %a does not match %a's parameter@ %a@]"
+    Printtyp.path p1 Printtyp.path p2 report_error errs
+
+(* We could do a better job to split the individual error items
+   as sub-messages of the main interface mismatch on the whole unit. *)
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | Apply_error(loc, p1, p2, err) ->
+          Some (Location.error_of_printer ~loc (report_apply_error p1 p2) err)
+      | _ -> None
+    )
diff --git a/upstream/ocaml_412/typing/includemod.mli b/upstream/ocaml_412/typing/includemod.mli
new file mode 100644
index 0000000..855b786
--- /dev/null
+++ b/upstream/ocaml_412/typing/includemod.mli
@@ -0,0 +1,93 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the module language *)
+
+open Typedtree
+open Types
+open Format
+
+(** Type describing which arguments of an inclusion to consider as used
+    for the usage warnings. [Mark_both] is the default. *)
+type mark =
+  | Mark_both
+      (** Mark definitions used from both arguments *)
+  | Mark_positive
+      (** Mark definitions used from the positive (first) argument *)
+  | Mark_negative
+      (** Mark definitions used from the negative (second) argument *)
+  | Mark_neither
+      (** Do not mark definitions used from either argument *)
+
+val modtypes:
+  loc:Location.t -> Env.t -> mark:mark ->
+  module_type -> module_type -> module_coercion
+
+val strengthened_module_decl:
+  loc:Location.t -> aliasable:bool -> Env.t -> mark:mark ->
+  module_declaration -> Path.t -> module_declaration -> module_coercion
+
+val check_modtype_inclusion :
+  loc:Location.t -> Env.t -> Types.module_type -> Path.t -> Types.module_type ->
+  unit
+(** [check_modtype_inclusion ~loc env mty1 path1 mty2] checks that the
+    functor application F(M) is well typed, where mty2 is the type of
+    the argument of F and path1/mty1 is the path/unstrenghened type of M. *)
+
+val signatures: Env.t -> mark:mark ->
+  signature -> signature -> module_coercion
+
+val compunit:
+      Env.t -> mark:mark -> string -> signature ->
+      string -> signature -> module_coercion
+
+val type_declarations:
+  loc:Location.t -> Env.t -> mark:mark ->
+  Ident.t -> type_declaration -> type_declaration -> unit
+
+val print_coercion: formatter -> module_coercion -> unit
+
+type symptom =
+    Missing_field of Ident.t * Location.t * string (* kind *)
+  | Value_descriptions of Ident.t * value_description * value_description
+  | Type_declarations of Ident.t * type_declaration
+        * type_declaration * Includecore.type_mismatch
+  | Extension_constructors of Ident.t * extension_constructor
+        * extension_constructor * Includecore.extension_constructor_mismatch
+  | Module_types of module_type * module_type
+  | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration
+  | Modtype_permutation of Types.module_type * Typedtree.module_coercion
+  | Interface_mismatch of string * string
+  | Class_type_declarations of
+      Ident.t * class_type_declaration * class_type_declaration *
+      Ctype.class_match_failure list
+  | Class_declarations of
+      Ident.t * class_declaration * class_declaration *
+      Ctype.class_match_failure list
+  | Unbound_modtype_path of Path.t
+  | Unbound_module_path of Path.t
+  | Invalid_module_alias of Path.t
+
+type pos =
+  | Module of Ident.t
+  | Modtype of Ident.t
+  | Arg of functor_parameter
+  | Body of functor_parameter
+type error = pos list * Env.t * symptom
+
+exception Error of error list
+
+val report_error: formatter -> error list -> unit
+val expand_module_alias: Env.t -> pos list -> Path.t -> Types.module_type
diff --git a/upstream/ocaml_412/typing/mtype.ml b/upstream/ocaml_412/typing/mtype.ml
new file mode 100644
index 0000000..07b28b3
--- /dev/null
+++ b/upstream/ocaml_412/typing/mtype.ml
@@ -0,0 +1,529 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Operations on module types *)
+
+open Asttypes
+open Path
+open Types
+
+
+let rec scrape env mty =
+  match mty with
+    Mty_ident p ->
+      begin try
+        scrape env (Env.find_modtype_expansion p env)
+      with Not_found ->
+        mty
+      end
+  | _ -> mty
+
+let freshen ~scope mty =
+  Subst.modtype (Rescope scope) Subst.identity mty
+
+let rec strengthen ~aliasable env mty p =
+  match scrape env mty with
+    Mty_signature sg ->
+      Mty_signature(strengthen_sig ~aliasable env sg p)
+  | Mty_functor(Named (Some param, arg), res)
+    when !Clflags.applicative_functors ->
+      Mty_functor(Named (Some param, arg),
+        strengthen ~aliasable:false env res (Papply(p, Pident param)))
+  | Mty_functor(Named (None, arg), res)
+    when !Clflags.applicative_functors ->
+      let param = Ident.create_scoped ~scope:(Path.scope p) "Arg" in
+      Mty_functor(Named (Some param, arg),
+        strengthen ~aliasable:false env res (Papply(p, Pident param)))
+  | mty ->
+      mty
+
+and strengthen_sig ~aliasable env sg p =
+  match sg with
+    [] -> []
+  | (Sig_value(_, _, _) as sigelt) :: rem ->
+      sigelt :: strengthen_sig ~aliasable env rem p
+  | Sig_type(id, {type_kind=Type_abstract}, _, _) ::
+    (Sig_type(id', {type_private=Private}, _, _) :: _ as rem)
+    when Ident.name id = Ident.name id' ^ "#row" ->
+      strengthen_sig ~aliasable env rem p
+  | Sig_type(id, decl, rs, vis) :: rem ->
+      let newdecl =
+        match decl.type_manifest, decl.type_private, decl.type_kind with
+          Some _, Public, _ -> decl
+        | Some _, Private, (Type_record _ | Type_variant _) -> decl
+        | _ ->
+            let manif =
+              Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id),
+                                          decl.type_params, ref Mnil))) in
+            if decl.type_kind = Type_abstract then
+              { decl with type_private = Public; type_manifest = manif }
+            else
+              { decl with type_manifest = manif }
+      in
+      Sig_type(id, newdecl, rs, vis) :: strengthen_sig ~aliasable env rem p
+  | (Sig_typext _ as sigelt) :: rem ->
+      sigelt :: strengthen_sig ~aliasable env rem p
+  | Sig_module(id, pres, md, rs, vis) :: rem ->
+      let str =
+        strengthen_decl ~aliasable env md (Pdot(p, Ident.name id))
+      in
+      Sig_module(id, pres, str, rs, vis)
+      :: strengthen_sig ~aliasable
+        (Env.add_module_declaration ~check:false id pres md env) rem p
+      (* Need to add the module in case it defines manifest module types *)
+  | Sig_modtype(id, decl, vis) :: rem ->
+      let newdecl =
+        match decl.mtd_type with
+          None ->
+            {decl with mtd_type = Some(Mty_ident(Pdot(p,Ident.name id)))}
+        | Some _ ->
+            decl
+      in
+      Sig_modtype(id, newdecl, vis) ::
+      strengthen_sig ~aliasable (Env.add_modtype id decl env) rem p
+      (* Need to add the module type in case it is manifest *)
+  | (Sig_class _ as sigelt) :: rem ->
+      sigelt :: strengthen_sig ~aliasable env rem p
+  | (Sig_class_type _ as sigelt) :: rem ->
+      sigelt :: strengthen_sig ~aliasable env rem p
+
+and strengthen_decl ~aliasable env md p =
+  match md.md_type with
+  | Mty_alias _ -> md
+  | _ when aliasable -> {md with md_type = Mty_alias p}
+  | mty -> {md with md_type = strengthen ~aliasable env mty p}
+
+let () = Env.strengthen := strengthen
+
+let rec make_aliases_absent pres mty =
+  match mty with
+  | Mty_alias _ -> Mp_absent, mty
+  | Mty_signature sg ->
+      pres, Mty_signature(make_aliases_absent_sig sg)
+  | Mty_functor(arg, res) ->
+      let _, res = make_aliases_absent Mp_present res in
+      pres, Mty_functor(arg, res)
+  | mty ->
+      pres, mty
+
+and make_aliases_absent_sig sg =
+  match sg with
+    [] -> []
+  | Sig_module(id, pres, md, rs, priv) :: rem ->
+      let pres, md_type = make_aliases_absent pres md.md_type in
+      let md = { md with md_type } in
+      Sig_module(id, pres, md, rs, priv) :: make_aliases_absent_sig rem
+  | sigelt :: rem ->
+      sigelt :: make_aliases_absent_sig rem
+
+let scrape_for_type_of env pres mty =
+  let rec loop env path mty =
+    match mty, path with
+    | Mty_alias path, _ -> begin
+        try
+          let md = Env.find_module path env in
+          loop env (Some path) md.md_type
+        with Not_found -> mty
+      end
+    | mty, Some path ->
+        strengthen ~aliasable:false env mty path
+    | _ -> mty
+  in
+  make_aliases_absent pres (loop env None mty)
+
+(* In nondep_supertype, env is only used for the type it assigns to id.
+   Hence there is no need to keep env up-to-date by adding the bindings
+   traversed. *)
+
+type variance = Co | Contra | Strict
+
+let rec nondep_mty_with_presence env va ids pres mty =
+  match mty with
+    Mty_ident p ->
+      begin match Path.find_free_opt ids p with
+      | Some id ->
+          let expansion =
+            try Env.find_modtype_expansion p env
+            with Not_found ->
+              raise (Ctype.Nondep_cannot_erase id)
+          in
+          nondep_mty_with_presence env va ids pres expansion
+      | None -> pres, mty
+      end
+  | Mty_alias p ->
+      begin match Path.find_free_opt ids p with
+      | Some id ->
+          let expansion =
+            try Env.find_module p env
+            with Not_found ->
+              raise (Ctype.Nondep_cannot_erase id)
+          in
+          nondep_mty_with_presence env va ids Mp_present expansion.md_type
+      | None -> pres, mty
+      end
+  | Mty_signature sg ->
+      let mty = Mty_signature(nondep_sig env va ids sg) in
+      pres, mty
+  | Mty_functor(Unit, res) ->
+      pres, Mty_functor(Unit, nondep_mty env va ids res)
+  | Mty_functor(Named (param, arg), res) ->
+      let var_inv =
+        match va with Co -> Contra | Contra -> Co | Strict -> Strict in
+      let res_env =
+        match param with
+        | None -> env
+        | Some param -> Env.add_module ~arg:true param Mp_present arg env
+      in
+      let mty =
+        Mty_functor(Named (param, nondep_mty env var_inv ids arg),
+                    nondep_mty res_env va ids res)
+      in
+      pres, mty
+
+and nondep_mty env va ids mty =
+  snd (nondep_mty_with_presence env va ids Mp_present mty)
+
+and nondep_sig_item env va ids = function
+  | Sig_value(id, d, vis) ->
+      Sig_value(id,
+                {d with val_type = Ctype.nondep_type env ids d.val_type},
+                vis)
+  | Sig_type(id, d, rs, vis) ->
+      Sig_type(id, Ctype.nondep_type_decl env ids (va = Co) d, rs, vis)
+  | Sig_typext(id, ext, es, vis) ->
+      Sig_typext(id, Ctype.nondep_extension_constructor env ids ext, es, vis)
+  | Sig_module(id, pres, md, rs, vis) ->
+      let pres, mty = nondep_mty_with_presence env va ids pres md.md_type in
+      Sig_module(id, pres, {md with md_type = mty}, rs, vis)
+  | Sig_modtype(id, d, vis) ->
+      begin try
+        Sig_modtype(id, nondep_modtype_decl env ids d, vis)
+      with Ctype.Nondep_cannot_erase _ as exn ->
+        match va with
+          Co -> Sig_modtype(id, {mtd_type=None; mtd_loc=Location.none;
+                                 mtd_attributes=[]; mtd_uid = d.mtd_uid}, vis)
+        | _  -> raise exn
+      end
+  | Sig_class(id, d, rs, vis) ->
+      Sig_class(id, Ctype.nondep_class_declaration env ids d, rs, vis)
+  | Sig_class_type(id, d, rs, vis) ->
+      Sig_class_type(id, Ctype.nondep_cltype_declaration env ids d, rs, vis)
+
+and nondep_sig env va ids sg =
+  let scope = Ctype.create_scope () in
+  let sg, env = Env.enter_signature ~scope sg env in
+  List.map (nondep_sig_item env va ids) sg
+
+and nondep_modtype_decl env ids mtd =
+  {mtd with mtd_type = Option.map (nondep_mty env Strict ids) mtd.mtd_type}
+
+let nondep_supertype env ids = nondep_mty env Co ids
+let nondep_sig_item env ids = nondep_sig_item env Co ids
+
+let enrich_typedecl env p id decl =
+  match decl.type_manifest with
+    Some _ -> decl
+  | None ->
+      try
+        let orig_decl = Env.find_type p env in
+        if decl.type_arity <> orig_decl.type_arity then
+          decl
+        else
+          let orig_ty =
+            Ctype.reify_univars env
+              (Btype.newgenty(Tconstr(p, orig_decl.type_params, ref Mnil)))
+          in
+          let new_ty =
+            Ctype.reify_univars env
+              (Btype.newgenty(Tconstr(Pident id, decl.type_params, ref Mnil)))
+          in
+          let env = Env.add_type ~check:false id decl env in
+          Ctype.mcomp env orig_ty new_ty;
+          let orig_ty =
+            Btype.newgenty(Tconstr(p, decl.type_params, ref Mnil))
+          in
+          {decl with type_manifest = Some orig_ty}
+      with Not_found | Ctype.Unify _ ->
+        (* - Not_found: type which was not present in the signature, so we don't
+           have anything to do.
+           - Unify: the current declaration is not compatible with the one we
+           got from the signature. We should just fail now, but then, we could
+           also have failed if the arities of the two decls were different,
+           which we didn't. *)
+        decl
+
+let rec enrich_modtype env p mty =
+  match mty with
+    Mty_signature sg ->
+      Mty_signature(List.map (enrich_item env p) sg)
+  | _ ->
+      mty
+
+and enrich_item env p = function
+    Sig_type(id, decl, rs, priv) ->
+      Sig_type(id,
+                enrich_typedecl env (Pdot(p, Ident.name id)) id decl, rs, priv)
+  | Sig_module(id, pres, md, rs, priv) ->
+      Sig_module(id, pres,
+                  {md with
+                   md_type = enrich_modtype env
+                       (Pdot(p, Ident.name id)) md.md_type},
+                 rs,
+                 priv)
+  | item -> item
+
+let rec type_paths env p mty =
+  match scrape env mty with
+    Mty_ident _ -> []
+  | Mty_alias _ -> []
+  | Mty_signature sg -> type_paths_sig env p sg
+  | Mty_functor _ -> []
+
+and type_paths_sig env p sg =
+  match sg with
+    [] -> []
+  | Sig_type(id, _decl, _, _) :: rem ->
+      Pdot(p, Ident.name id) :: type_paths_sig env p rem
+  | Sig_module(id, pres, md, _, _) :: rem ->
+      type_paths env (Pdot(p, Ident.name id)) md.md_type @
+      type_paths_sig (Env.add_module_declaration ~check:false id pres md env)
+        p rem
+  | Sig_modtype(id, decl, _) :: rem ->
+      type_paths_sig (Env.add_modtype id decl env) p rem
+  | (Sig_value _ | Sig_typext _ | Sig_class _ | Sig_class_type _) :: rem ->
+      type_paths_sig env p rem
+
+
+let rec no_code_needed_mod env pres mty =
+  match pres with
+  | Mp_absent -> true
+  | Mp_present -> begin
+      match scrape env mty with
+        Mty_ident _ -> false
+      | Mty_signature sg -> no_code_needed_sig env sg
+      | Mty_functor _ -> false
+      | Mty_alias _ -> false
+    end
+
+and no_code_needed_sig env sg =
+  match sg with
+    [] -> true
+  | Sig_value(_id, decl, _) :: rem ->
+      begin match decl.val_kind with
+      | Val_prim _ -> no_code_needed_sig env rem
+      | _ -> false
+      end
+  | Sig_module(id, pres, md, _, _) :: rem ->
+      no_code_needed_mod env pres md.md_type &&
+      no_code_needed_sig
+        (Env.add_module_declaration ~check:false id pres md env) rem
+  | (Sig_type _ | Sig_modtype _ | Sig_class_type _) :: rem ->
+      no_code_needed_sig env rem
+  | (Sig_typext _ | Sig_class _) :: _ ->
+      false
+
+let no_code_needed env mty = no_code_needed_mod env Mp_present mty
+
+(* Check whether a module type may return types *)
+
+let rec contains_type env = function
+    Mty_ident path ->
+      begin try match (Env.find_modtype path env).mtd_type with
+      | None -> raise Exit (* PR#6427 *)
+      | Some mty -> contains_type env mty
+      with Not_found -> raise Exit
+      end
+  | Mty_signature sg ->
+      contains_type_sig env sg
+  | Mty_functor (_, body) ->
+      contains_type env body
+  | Mty_alias _ ->
+      ()
+
+and contains_type_sig env = List.iter (contains_type_item env)
+
+and contains_type_item env = function
+    Sig_type (_,({type_manifest = None} |
+                 {type_kind = Type_abstract; type_private = Private}),_, _)
+  | Sig_modtype _
+  | Sig_typext (_, {ext_args = Cstr_record _}, _, _) ->
+      (* We consider that extension constructors with an inlined
+         record create a type (the inlined record), even though
+         it would be technically safe to ignore that considering
+         the current constraints which guarantee that this type
+         is kept local to expressions.  *)
+      raise Exit
+  | Sig_module (_, _, {md_type = mty}, _, _) ->
+      contains_type env mty
+  | Sig_value _
+  | Sig_type _
+  | Sig_typext _
+  | Sig_class _
+  | Sig_class_type _ ->
+      ()
+
+let contains_type env mty =
+  try contains_type env mty; false with Exit -> true
+
+
+(* Remove module aliases from a signature *)
+
+let rec get_prefixes = function
+  | Pident _ -> Path.Set.empty
+  | Pdot (p, _)
+  | Papply (p, _) -> Path.Set.add p (get_prefixes p)
+
+let rec get_arg_paths = function
+  | Pident _ -> Path.Set.empty
+  | Pdot (p, _) -> get_arg_paths p
+  | Papply (p1, p2) ->
+      Path.Set.add p2
+        (Path.Set.union (get_prefixes p2)
+           (Path.Set.union (get_arg_paths p1) (get_arg_paths p2)))
+
+let rec rollback_path subst p =
+  try Pident (Path.Map.find p subst)
+  with Not_found ->
+    match p with
+      Pident _ | Papply _ -> p
+    | Pdot (p1, s) ->
+        let p1' = rollback_path subst p1 in
+        if Path.same p1 p1' then p else rollback_path subst (Pdot (p1', s))
+
+let rec collect_ids subst bindings p =
+    begin match rollback_path subst p with
+      Pident id ->
+        let ids =
+          try collect_ids subst bindings (Ident.find_same id bindings)
+          with Not_found -> Ident.Set.empty
+        in
+        Ident.Set.add id ids
+    | _ -> Ident.Set.empty
+    end
+
+let collect_arg_paths mty =
+  let open Btype in
+  let paths = ref Path.Set.empty
+  and subst = ref Path.Map.empty
+  and bindings = ref Ident.empty in
+  (* let rt = Ident.create "Root" in
+     and prefix = ref (Path.Pident rt) in *)
+  let it_path p = paths := Path.Set.union (get_arg_paths p) !paths
+  and it_signature_item it si =
+    type_iterators.it_signature_item it si;
+    match si with
+    | Sig_module (id, _, {md_type=Mty_alias p}, _, _) ->
+        bindings := Ident.add id p !bindings
+    | Sig_module (id, _, {md_type=Mty_signature sg}, _, _) ->
+        List.iter
+          (function Sig_module (id', _, _, _, _) ->
+              subst :=
+                Path.Map.add (Pdot (Pident id, Ident.name id')) id' !subst
+            | _ -> ())
+          sg
+    | _ -> ()
+  in
+  let it = {type_iterators with it_path; it_signature_item} in
+  it.it_module_type it mty;
+  it.it_module_type unmark_iterators mty;
+  Path.Set.fold (fun p -> Ident.Set.union (collect_ids !subst !bindings p))
+    !paths Ident.Set.empty
+
+type remove_alias_args =
+    { mutable modified: bool;
+      exclude: Ident.t -> Path.t -> bool;
+      scrape: Env.t -> module_type -> module_type }
+
+let rec remove_aliases_mty env args pres mty =
+  let args' = {args with modified = false} in
+  let res =
+    match args.scrape env mty with
+      Mty_signature sg ->
+        Mp_present, Mty_signature (remove_aliases_sig env args' sg)
+    | Mty_alias _ ->
+        let mty' = Env.scrape_alias env mty in
+        if mty' = mty then begin
+          pres, mty
+        end else begin
+          args'.modified <- true;
+          remove_aliases_mty env args' Mp_present mty'
+        end
+    | mty ->
+        Mp_present, mty
+  in
+  if args'.modified then begin
+    args.modified <- true;
+    res
+  end else begin
+    pres, mty
+  end
+
+and remove_aliases_sig env args sg =
+  match sg with
+    [] -> []
+  | Sig_module(id, pres, md, rs, priv) :: rem  ->
+      let pres, mty =
+        match md.md_type with
+          Mty_alias p when args.exclude id p ->
+            pres, md.md_type
+        | mty ->
+            remove_aliases_mty env args pres mty
+      in
+      Sig_module(id, pres, {md with md_type = mty} , rs, priv) ::
+      remove_aliases_sig (Env.add_module id pres mty env) args rem
+  | Sig_modtype(id, mtd, priv) :: rem ->
+      Sig_modtype(id, mtd, priv) ::
+      remove_aliases_sig (Env.add_modtype id mtd env) args rem
+  | it :: rem ->
+      it :: remove_aliases_sig env args rem
+
+let scrape_for_functor_arg env mty =
+  let exclude _id p =
+    try ignore (Env.find_module p env); true with Not_found -> false
+  in
+  let _, mty =
+    remove_aliases_mty env {modified=false; exclude; scrape} Mp_present mty
+  in
+  mty
+
+let scrape_for_type_of ~remove_aliases env mty =
+  if remove_aliases then begin
+    let excl = collect_arg_paths mty in
+    let exclude id _p = Ident.Set.mem id excl in
+    let scrape _ mty = mty in
+    let _, mty =
+      remove_aliases_mty env {modified=false; exclude; scrape} Mp_present mty
+    in
+    mty
+  end else begin
+    let _, mty = scrape_for_type_of env Mp_present mty in
+    mty
+  end
+
+(* Lower non-generalizable type variables *)
+
+let lower_nongen nglev mty =
+  let open Btype in
+  let it_type_expr it ty =
+    let ty = repr ty in
+    match ty with
+      {desc=Tvar _; level} ->
+        if level < generic_level && level > nglev then set_level ty nglev
+    | _ ->
+        type_iterators.it_type_expr it ty
+  in
+  let it = {type_iterators with it_type_expr} in
+  it.it_module_type it mty;
+  it.it_module_type unmark_iterators mty
diff --git a/upstream/ocaml_412/typing/mtype.mli b/upstream/ocaml_412/typing/mtype.mli
new file mode 100644
index 0000000..68d290b
--- /dev/null
+++ b/upstream/ocaml_412/typing/mtype.mli
@@ -0,0 +1,55 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Operations on module types *)
+
+open Types
+
+val scrape: Env.t -> module_type -> module_type
+        (* Expand toplevel module type abbreviations
+           till hitting a "hard" module type (signature, functor,
+           or abstract module type ident. *)
+val scrape_for_functor_arg: Env.t -> module_type -> module_type
+        (* Remove aliases in a functor argument type *)
+val scrape_for_type_of:
+  remove_aliases:bool -> Env.t -> module_type -> module_type
+        (* Process type for module type of *)
+val freshen: scope:int -> module_type -> module_type
+        (* Return an alpha-equivalent copy of the given module type
+           where bound identifiers are fresh. *)
+val strengthen: aliasable:bool -> Env.t -> module_type -> Path.t -> module_type
+        (* Strengthen abstract type components relative to the
+           given path. *)
+val strengthen_decl:
+  aliasable:bool -> Env.t -> module_declaration -> Path.t -> module_declaration
+val nondep_supertype: Env.t -> Ident.t list -> module_type -> module_type
+        (* Return the smallest supertype of the given type
+           in which none of the given idents appears.
+           @raise [Ctype.Nondep_cannot_erase] if no such type exists. *)
+val nondep_sig_item: Env.t -> Ident.t list -> signature_item -> signature_item
+        (* Returns the signature item with its type updated
+           to be the smallest supertype of its initial type
+           in which none of the given idents appears.
+           @raise [Ctype.Nondep_cannot_erase] if no such type exists. *)
+val no_code_needed: Env.t -> module_type -> bool
+val no_code_needed_sig: Env.t -> signature -> bool
+        (* Determine whether a module needs no implementation code,
+           i.e. consists only of type definitions. *)
+val enrich_modtype: Env.t -> Path.t -> module_type -> module_type
+val enrich_typedecl: Env.t -> Path.t -> Ident.t -> type_declaration ->
+  type_declaration
+val type_paths: Env.t -> Path.t -> module_type -> Path.t list
+val contains_type: Env.t -> module_type -> bool
+val lower_nongen: int -> module_type -> unit
diff --git a/upstream/ocaml_412/typing/oprint.ml b/upstream/ocaml_412/typing/oprint.ml
new file mode 100644
index 0000000..b28641c
--- /dev/null
+++ b/upstream/ocaml_412/typing/oprint.ml
@@ -0,0 +1,822 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Projet Cristal, INRIA Rocquencourt                   *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Format
+open Outcometree
+
+exception Ellipsis
+
+let cautious f ppf arg =
+  try f ppf arg with
+    Ellipsis -> fprintf ppf "..."
+
+let print_lident ppf = function
+  | "::" -> pp_print_string ppf "(::)"
+  | s -> pp_print_string ppf s
+
+let rec print_ident ppf =
+  function
+    Oide_ident s -> print_lident ppf s.printed_name
+  | Oide_dot (id, s) ->
+      print_ident ppf id; pp_print_char ppf '.'; print_lident ppf s
+  | Oide_apply (id1, id2) ->
+      fprintf ppf "%a(%a)" print_ident id1 print_ident id2
+
+let out_ident = ref print_ident
+
+(* Check a character matches the [identchar_latin1] class from the lexer *)
+let is_ident_char c =
+  match c with
+  | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214' | '\216'..'\246'
+  | '\248'..'\255' | '\'' | '0'..'9' -> true
+  | _ -> false
+
+let all_ident_chars s =
+  let rec loop s len i =
+    if i < len then begin
+      if is_ident_char s.[i] then loop s len (i+1)
+      else false
+    end else begin
+      true
+    end
+  in
+  let len = String.length s in
+  loop s len 0
+
+let parenthesized_ident name =
+  (List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"])
+  || not (all_ident_chars name)
+
+let value_ident ppf name =
+  if parenthesized_ident name then
+    fprintf ppf "( %s )" name
+  else
+    pp_print_string ppf name
+
+(* Values *)
+
+let valid_float_lexeme s =
+  let l = String.length s in
+  let rec loop i =
+    if i >= l then s ^ "." else
+    match s.[i] with
+    | '0' .. '9' | '-' -> loop (i+1)
+    | _ -> s
+  in loop 0
+
+let float_repres f =
+  match classify_float f with
+    FP_nan -> "nan"
+  | FP_infinite ->
+      if f < 0.0 then "neg_infinity" else "infinity"
+  | _ ->
+      let float_val =
+        let s1 = Printf.sprintf "%.12g" f in
+        if f = float_of_string s1 then s1 else
+        let s2 = Printf.sprintf "%.15g" f in
+        if f = float_of_string s2 then s2 else
+        Printf.sprintf "%.18g" f
+      in valid_float_lexeme float_val
+
+let parenthesize_if_neg ppf fmt v isneg =
+  if isneg then pp_print_char ppf '(';
+  fprintf ppf fmt v;
+  if isneg then pp_print_char ppf ')'
+
+let escape_string s =
+  (* Escape only C0 control characters (bytes <= 0x1F), DEL(0x7F), '\\'
+     and '"' *)
+   let n = ref 0 in
+  for i = 0 to String.length s - 1 do
+    n := !n +
+      (match String.unsafe_get s i with
+       | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2
+       | '\x00' .. '\x1F'
+       | '\x7F' -> 4
+       | _ -> 1)
+  done;
+  if !n = String.length s then s else begin
+    let s' = Bytes.create !n in
+    n := 0;
+    for i = 0 to String.length s - 1 do
+      begin match String.unsafe_get s i with
+      | ('\"' | '\\') as c ->
+          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n c
+      | '\n' ->
+          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'n'
+      | '\t' ->
+          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 't'
+      | '\r' ->
+          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'r'
+      | '\b' ->
+          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'b'
+      | '\x00' .. '\x1F' | '\x7F' as c ->
+          let a = Char.code c in
+          Bytes.unsafe_set s' !n '\\';
+          incr n;
+          Bytes.unsafe_set s' !n (Char.chr (48 + a / 100));
+          incr n;
+          Bytes.unsafe_set s' !n (Char.chr (48 + (a / 10) mod 10));
+          incr n;
+          Bytes.unsafe_set s' !n (Char.chr (48 + a mod 10));
+      | c -> Bytes.unsafe_set s' !n c
+      end;
+      incr n
+    done;
+    Bytes.to_string s'
+  end
+
+
+let print_out_string ppf s =
+  let not_escaped =
+    (* let the user dynamically choose if strings should be escaped: *)
+    match Sys.getenv_opt "OCAMLTOP_UTF_8" with
+    | None -> true
+    | Some x ->
+        match bool_of_string_opt x with
+        | None -> true
+        | Some f -> f in
+  if not_escaped then
+    fprintf ppf "\"%s\"" (escape_string s)
+  else
+    fprintf ppf "%S" s
+
+let print_out_value ppf tree =
+  let rec print_tree_1 ppf =
+    function
+    | Oval_constr (name, [param]) ->
+        fprintf ppf "@[<1>%a@ %a@]" print_ident name print_constr_param param
+    | Oval_constr (name, (_ :: _ as params)) ->
+        fprintf ppf "@[<1>%a@ (%a)@]" print_ident name
+          (print_tree_list print_tree_1 ",") params
+    | Oval_variant (name, Some param) ->
+        fprintf ppf "@[<2>`%s@ %a@]" name print_constr_param param
+    | tree -> print_simple_tree ppf tree
+  and print_constr_param ppf = function
+    | Oval_int i -> parenthesize_if_neg ppf "%i" i (i < 0)
+    | Oval_int32 i -> parenthesize_if_neg ppf "%lil" i (i < 0l)
+    | Oval_int64 i -> parenthesize_if_neg ppf "%LiL" i (i < 0L)
+    | Oval_nativeint i -> parenthesize_if_neg ppf "%nin" i (i < 0n)
+    | Oval_float f ->
+        parenthesize_if_neg ppf "%s" (float_repres f)
+                                     (f < 0.0 || 1. /. f = neg_infinity)
+    | Oval_string (_,_, Ostr_bytes) as tree ->
+      pp_print_char ppf '(';
+      print_simple_tree ppf tree;
+      pp_print_char ppf ')';
+    | tree -> print_simple_tree ppf tree
+  and print_simple_tree ppf =
+    function
+      Oval_int i -> fprintf ppf "%i" i
+    | Oval_int32 i -> fprintf ppf "%lil" i
+    | Oval_int64 i -> fprintf ppf "%LiL" i
+    | Oval_nativeint i -> fprintf ppf "%nin" i
+    | Oval_float f -> pp_print_string ppf (float_repres f)
+    | Oval_char c -> fprintf ppf "%C" c
+    | Oval_string (s, maxlen, kind) ->
+       begin try
+         let len = String.length s in
+         let s = if len > maxlen then String.sub s 0 maxlen else s in
+         begin match kind with
+         | Ostr_bytes -> fprintf ppf "Bytes.of_string %S" s
+         | Ostr_string -> print_out_string ppf s
+         end;
+         (if len > maxlen then
+            fprintf ppf
+              "... (* string length %d; truncated *)" len
+         )
+          with
+          Invalid_argument _ (* "String.create" *)-> fprintf ppf "<huge string>"
+        end
+    | Oval_list tl ->
+        fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ";") tl
+    | Oval_array tl ->
+        fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ";") tl
+    | Oval_constr (name, []) -> print_ident ppf name
+    | Oval_variant (name, None) -> fprintf ppf "`%s" name
+    | Oval_stuff s -> pp_print_string ppf s
+    | Oval_record fel ->
+        fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel
+    | Oval_ellipsis -> raise Ellipsis
+    | Oval_printer f -> f ppf
+    | Oval_tuple tree_list ->
+        fprintf ppf "@[<1>(%a)@]" (print_tree_list print_tree_1 ",") tree_list
+    | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree_1) tree
+  and print_fields first ppf =
+    function
+      [] -> ()
+    | (name, tree) :: fields ->
+        if not first then fprintf ppf ";@ ";
+        fprintf ppf "@[<1>%a@ =@ %a@]" print_ident name (cautious print_tree_1)
+          tree;
+        print_fields false ppf fields
+  and print_tree_list print_item sep ppf tree_list =
+    let rec print_list first ppf =
+      function
+        [] -> ()
+      | tree :: tree_list ->
+          if not first then fprintf ppf "%s@ " sep;
+          print_item ppf tree;
+          print_list false ppf tree_list
+    in
+    cautious (print_list true) ppf tree_list
+  in
+  cautious print_tree_1 ppf tree
+
+let out_value = ref print_out_value
+
+(* Types *)
+
+let rec print_list_init pr sep ppf =
+  function
+    [] -> ()
+  | a :: l -> sep ppf; pr ppf a; print_list_init pr sep ppf l
+
+let rec print_list pr sep ppf =
+  function
+    [] -> ()
+  | [a] -> pr ppf a
+  | a :: l -> pr ppf a; sep ppf; print_list pr sep ppf l
+
+let pr_present =
+  print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ")
+
+let pr_var = Pprintast.tyvar
+
+let pr_vars =
+  print_list pr_var (fun ppf -> fprintf ppf "@ ")
+
+let rec print_out_type ppf =
+  function
+  | Otyp_alias (ty, s) ->
+      fprintf ppf "@[%a@ as %a@]" print_out_type ty pr_var s
+  | Otyp_poly (sl, ty) ->
+      fprintf ppf "@[<hov 2>%a.@ %a@]"
+        pr_vars sl
+        print_out_type ty
+  | ty ->
+      print_out_type_1 ppf ty
+
+and print_out_type_1 ppf =
+  function
+    Otyp_arrow (lab, ty1, ty2) ->
+      pp_open_box ppf 0;
+      if lab <> "" then (pp_print_string ppf lab; pp_print_char ppf ':');
+      print_out_type_2 ppf ty1;
+      pp_print_string ppf " ->";
+      pp_print_space ppf ();
+      print_out_type_1 ppf ty2;
+      pp_close_box ppf ()
+  | ty -> print_out_type_2 ppf ty
+and print_out_type_2 ppf =
+  function
+    Otyp_tuple tyl ->
+      fprintf ppf "@[<0>%a@]" (print_typlist print_simple_out_type " *") tyl
+  | ty -> print_simple_out_type ppf ty
+and print_simple_out_type ppf =
+  function
+    Otyp_class (ng, id, tyl) ->
+      fprintf ppf "@[%a%s#%a@]" print_typargs tyl (if ng then "_" else "")
+        print_ident id
+  | Otyp_constr (id, tyl) ->
+      pp_open_box ppf 0;
+      print_typargs ppf tyl;
+      print_ident ppf id;
+      pp_close_box ppf ()
+  | Otyp_object (fields, rest) ->
+      fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields
+  | Otyp_stuff s -> pp_print_string ppf s
+  | Otyp_var (ng, s) -> pr_var ppf (if ng then "_" ^ s else s)
+  | Otyp_variant (non_gen, row_fields, closed, tags) ->
+      let print_present ppf =
+        function
+          None | Some [] -> ()
+        | Some l -> fprintf ppf "@;<1 -2>> @[<hov>%a@]" pr_present l
+      in
+      let print_fields ppf =
+        function
+          Ovar_fields fields ->
+            print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ")
+              ppf fields
+        | Ovar_typ typ ->
+           print_simple_out_type ppf typ
+      in
+      fprintf ppf "%s@[<hov>[%s@[<hv>@[<hv>%a@]%a@]@ ]@]"
+        (if non_gen then "_" else "")
+        (if closed then if tags = None then " " else "< "
+         else if tags = None then "> " else "? ")
+        print_fields row_fields
+        print_present tags
+  | Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty ->
+      pp_open_box ppf 1;
+      pp_print_char ppf '(';
+      print_out_type ppf ty;
+      pp_print_char ppf ')';
+      pp_close_box ppf ()
+  | Otyp_abstract | Otyp_open
+  | Otyp_sum _ | Otyp_manifest (_, _) -> ()
+  | Otyp_record lbls -> print_record_decl ppf lbls
+  | Otyp_module (p, n, tyl) ->
+      fprintf ppf "@[<1>(module %a" print_ident p;
+      let first = ref true in
+      List.iter2
+        (fun s t ->
+          let sep = if !first then (first := false; "with") else "and" in
+          fprintf ppf " %s type %s = %a" sep s print_out_type t
+        )
+        n tyl;
+      fprintf ppf ")@]"
+  | Otyp_attribute (t, attr) ->
+      fprintf ppf "@[<1>(%a [@@%s])@]" print_out_type t attr.oattr_name
+and print_record_decl ppf lbls =
+  fprintf ppf "{%a@;<1 -2>}"
+    (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls
+and print_fields rest ppf =
+  function
+    [] ->
+      begin match rest with
+        Some non_gen -> fprintf ppf "%s.." (if non_gen then "_" else "")
+      | None -> ()
+      end
+  | [s, t] ->
+      fprintf ppf "%s : %a" s print_out_type t;
+      begin match rest with
+        Some _ -> fprintf ppf ";@ "
+      | None -> ()
+      end;
+      print_fields rest ppf []
+  | (s, t) :: l ->
+      fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l
+and print_row_field ppf (l, opt_amp, tyl) =
+  let pr_of ppf =
+    if opt_amp then fprintf ppf " of@ &@ "
+    else if tyl <> [] then fprintf ppf " of@ "
+    else fprintf ppf ""
+  in
+  fprintf ppf "@[<hv 2>`%s%t%a@]" l pr_of (print_typlist print_out_type " &")
+    tyl
+and print_typlist print_elem sep ppf =
+  function
+    [] -> ()
+  | [ty] -> print_elem ppf ty
+  | ty :: tyl ->
+      print_elem ppf ty;
+      pp_print_string ppf sep;
+      pp_print_space ppf ();
+      print_typlist print_elem sep ppf tyl
+and print_typargs ppf =
+  function
+    [] -> ()
+  | [ty1] -> print_simple_out_type ppf ty1; pp_print_space ppf ()
+  | tyl ->
+      pp_open_box ppf 1;
+      pp_print_char ppf '(';
+      print_typlist print_out_type "," ppf tyl;
+      pp_print_char ppf ')';
+      pp_close_box ppf ();
+      pp_print_space ppf ()
+and print_out_label ppf (name, mut, arg) =
+  fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name
+    print_out_type arg
+
+let out_label = ref print_out_label
+
+let out_type = ref print_out_type
+
+(* Class types *)
+
+let print_type_parameter ppf s =
+  if s = "_" then fprintf ppf "_" else pr_var ppf s
+
+let type_parameter ppf (ty, (var, inj)) =
+  let open Asttypes in
+  fprintf ppf "%s%s%a"
+    (match var with Covariant -> "+" | Contravariant -> "-" | NoVariance ->  "")
+    (match inj with Injective -> "!" | NoInjectivity -> "")
+    print_type_parameter ty
+
+let print_out_class_params ppf =
+  function
+    [] -> ()
+  | tyl ->
+      fprintf ppf "@[<1>[%a]@]@ "
+        (print_list type_parameter (fun ppf -> fprintf ppf ", "))
+        tyl
+
+let rec print_out_class_type ppf =
+  function
+    Octy_constr (id, tyl) ->
+      let pr_tyl ppf =
+        function
+          [] -> ()
+        | tyl ->
+            fprintf ppf "@[<1>[%a]@]@ " (print_typlist !out_type ",") tyl
+      in
+      fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id
+  | Octy_arrow (lab, ty, cty) ->
+      fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "")
+        print_out_type_2 ty print_out_class_type cty
+  | Octy_signature (self_ty, csil) ->
+      let pr_param ppf =
+        function
+          Some ty -> fprintf ppf "@ @[(%a)@]" !out_type ty
+        | None -> ()
+      in
+      fprintf ppf "@[<hv 2>@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty
+        (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ "))
+        csil
+and print_out_class_sig_item ppf =
+  function
+    Ocsg_constraint (ty1, ty2) ->
+      fprintf ppf "@[<2>constraint %a =@ %a@]" !out_type ty1
+        !out_type ty2
+  | Ocsg_method (name, priv, virt, ty) ->
+      fprintf ppf "@[<2>method %s%s%s :@ %a@]"
+        (if priv then "private " else "") (if virt then "virtual " else "")
+        name !out_type ty
+  | Ocsg_value (name, mut, vr, ty) ->
+      fprintf ppf "@[<2>val %s%s%s :@ %a@]"
+        (if mut then "mutable " else "")
+        (if vr then "virtual " else "")
+        name !out_type ty
+
+let out_class_type = ref print_out_class_type
+
+(* Signature *)
+
+let out_module_type = ref (fun _ -> failwith "Oprint.out_module_type")
+let out_sig_item = ref (fun _ -> failwith "Oprint.out_sig_item")
+let out_signature = ref (fun _ -> failwith "Oprint.out_signature")
+let out_type_extension = ref (fun _ -> failwith "Oprint.out_type_extension")
+
+(* For anonymous functor arguments, the logic to choose between
+   the long-form
+     functor (_ : S) -> ...
+   and the short-form
+     S -> ...
+   is as follows: if we are already printing long-form functor arguments,
+   we use the long form unless all remaining functor arguments can use
+   the short form. (Otherwise use the short form.)
+
+   For example,
+     functor (X : S1) (_ : S2) (Y : S3) (_ : S4) (_ : S5) -> sig end
+   will get printed as
+     functor (X : S1) (_ : S2) (Y : S3) -> S4 -> S5 -> sig end
+
+   but
+     functor (_ : S1) (_ : S2) (Y : S3) (_ : S4) (_ : S5) -> sig end
+   gets printed as
+     S1 -> S2 -> functor (Y : S3) -> S4 -> S5 -> sig end
+*)
+
+(* take a module type that may be a functor type,
+   and return the longest prefix list of arguments
+   that should be printed in long form. *)
+let collect_functor_arguments mty =
+  let rec collect_args acc = function
+    | Omty_functor (param, mty_res) ->
+       collect_args (param :: acc) mty_res
+    | non_functor -> (acc, non_functor)
+  in
+  let rec uncollect_anonymous_suffix acc rest = match acc with
+      | Some (None, mty_arg) :: acc ->
+          uncollect_anonymous_suffix acc
+            (Omty_functor (Some (None, mty_arg), rest))
+      | _ :: _ | [] ->
+         (acc, rest)
+  in
+  let (acc, non_functor) = collect_args [] mty in
+  let (acc, rest) = uncollect_anonymous_suffix acc non_functor in
+  (List.rev acc, rest)
+
+let rec print_out_module_type ppf mty =
+  print_out_functor ppf mty
+and print_out_functor ppf = function
+  | Omty_functor _ as t ->
+     let rec print_functor ppf = function
+       | Omty_functor (Some (None, mty_arg), mty_res) ->
+          fprintf ppf "%a ->@ %a"
+            print_simple_out_module_type mty_arg
+            print_functor mty_res
+       | Omty_functor _ as non_anonymous_functor ->
+          let (args, rest) = collect_functor_arguments non_anonymous_functor in
+          let print_arg ppf = function
+            | None ->
+               fprintf ppf "()"
+            | Some (param, mty) ->
+               fprintf ppf "(%s : %a)"
+                 (Option.value param ~default:"_")
+                 print_out_module_type mty
+          in
+          fprintf ppf "@[<2>functor@ %a@]@ ->@ %a"
+            (pp_print_list ~pp_sep:pp_print_space print_arg) args
+            print_functor rest
+       | non_functor ->
+          print_simple_out_module_type ppf non_functor
+     in
+     fprintf ppf "@[<2>%a@]" print_functor t
+  | t -> print_simple_out_module_type ppf t
+and print_simple_out_module_type ppf =
+  function
+    Omty_abstract -> ()
+  | Omty_ident id -> fprintf ppf "%a" print_ident id
+  | Omty_signature sg ->
+     begin match sg with
+       | [] -> fprintf ppf "sig end"
+       | sg ->
+          fprintf ppf "@[<hv 2>sig@ %a@;<1 -2>end@]" print_out_signature sg
+     end
+  | Omty_alias id -> fprintf ppf "(module %a)" print_ident id
+  | Omty_functor _ as non_simple ->
+     fprintf ppf "(%a)" print_out_module_type non_simple
+and print_out_signature ppf =
+  function
+    [] -> ()
+  | [item] -> !out_sig_item ppf item
+  | Osig_typext(ext, Oext_first) :: items ->
+      (* Gather together the extension constructors *)
+      let rec gather_extensions acc items =
+        match items with
+            Osig_typext(ext, Oext_next) :: items ->
+              gather_extensions
+                ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc)
+                items
+          | _ -> (List.rev acc, items)
+      in
+      let exts, items =
+        gather_extensions
+          [(ext.oext_name, ext.oext_args, ext.oext_ret_type)]
+          items
+      in
+      let te =
+        { otyext_name = ext.oext_type_name;
+          otyext_params = ext.oext_type_params;
+          otyext_constructors = exts;
+          otyext_private = ext.oext_private }
+      in
+        fprintf ppf "%a@ %a" !out_type_extension te print_out_signature items
+  | item :: items ->
+      fprintf ppf "%a@ %a" !out_sig_item item print_out_signature items
+and print_out_sig_item ppf =
+  function
+    Osig_class (vir_flag, name, params, clt, rs) ->
+      fprintf ppf "@[<2>%s%s@ %a%s@ :@ %a@]"
+        (if rs = Orec_next then "and" else "class")
+        (if vir_flag then " virtual" else "") print_out_class_params params
+        name !out_class_type clt
+  | Osig_class_type (vir_flag, name, params, clt, rs) ->
+      fprintf ppf "@[<2>%s%s@ %a%s@ =@ %a@]"
+        (if rs = Orec_next then "and" else "class type")
+        (if vir_flag then " virtual" else "") print_out_class_params params
+        name !out_class_type clt
+  | Osig_typext (ext, Oext_exception) ->
+      fprintf ppf "@[<2>exception %a@]"
+        print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type)
+  | Osig_typext (ext, _es) ->
+      print_out_extension_constructor ppf ext
+  | Osig_modtype (name, Omty_abstract) ->
+      fprintf ppf "@[<2>module type %s@]" name
+  | Osig_modtype (name, mty) ->
+      fprintf ppf "@[<2>module type %s =@ %a@]" name !out_module_type mty
+  | Osig_module (name, Omty_alias id, _) ->
+      fprintf ppf "@[<2>module %s =@ %a@]" name print_ident id
+  | Osig_module (name, mty, rs) ->
+      fprintf ppf "@[<2>%s %s :@ %a@]"
+        (match rs with Orec_not -> "module"
+                     | Orec_first -> "module rec"
+                     | Orec_next -> "and")
+        name !out_module_type mty
+  | Osig_type(td, rs) ->
+        print_out_type_decl
+          (match rs with
+           | Orec_not   -> "type nonrec"
+           | Orec_first -> "type"
+           | Orec_next  -> "and")
+          ppf td
+  | Osig_value vd ->
+      let kwd = if vd.oval_prims = [] then "val" else "external" in
+      let pr_prims ppf =
+        function
+          [] -> ()
+        | s :: sl ->
+            fprintf ppf "@ = \"%s\"" s;
+            List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl
+      in
+      fprintf ppf "@[<2>%s %a :@ %a%a%a@]" kwd value_ident vd.oval_name
+        !out_type vd.oval_type pr_prims vd.oval_prims
+        (fun ppf -> List.iter (fun a -> fprintf ppf "@ [@@@@%s]" a.oattr_name))
+        vd.oval_attributes
+  | Osig_ellipsis ->
+      fprintf ppf "..."
+
+and print_out_type_decl kwd ppf td =
+  let print_constraints ppf =
+    List.iter
+      (fun (ty1, ty2) ->
+         fprintf ppf "@ @[<2>constraint %a =@ %a@]" !out_type ty1
+           !out_type ty2)
+      td.otype_cstrs
+  in
+  let type_defined ppf =
+    match td.otype_params with
+      [] -> pp_print_string ppf td.otype_name
+    | [param] -> fprintf ppf "@[%a@ %s@]" type_parameter param td.otype_name
+    | _ ->
+        fprintf ppf "@[(@[%a)@]@ %s@]"
+          (print_list type_parameter (fun ppf -> fprintf ppf ",@ "))
+          td.otype_params
+          td.otype_name
+  in
+  let print_manifest ppf =
+    function
+      Otyp_manifest (ty, _) -> fprintf ppf " =@ %a" !out_type ty
+    | _ -> ()
+  in
+  let print_name_params ppf =
+    fprintf ppf "%s %t%a" kwd type_defined print_manifest td.otype_type
+  in
+  let ty =
+    match td.otype_type with
+      Otyp_manifest (_, ty) -> ty
+    | _ -> td.otype_type
+  in
+  let print_private ppf = function
+    Asttypes.Private -> fprintf ppf " private"
+  | Asttypes.Public -> ()
+  in
+  let print_immediate ppf =
+    match td.otype_immediate with
+    | Unknown -> ()
+    | Always -> fprintf ppf " [%@%@immediate]"
+    | Always_on_64bits -> fprintf ppf " [%@%@immediate64]"
+  in
+  let print_unboxed ppf =
+    if td.otype_unboxed then fprintf ppf " [%@%@unboxed]" else ()
+  in
+  let print_out_tkind ppf = function
+  | Otyp_abstract -> ()
+  | Otyp_record lbls ->
+      fprintf ppf " =%a %a"
+        print_private td.otype_private
+        print_record_decl lbls
+  | Otyp_sum constrs ->
+      let variants fmt constrs =
+        if constrs = [] then fprintf fmt "|" else
+        fprintf fmt "%a" (print_list print_out_constr
+          (fun ppf -> fprintf ppf "@ | ")) constrs in
+      fprintf ppf " =%a@;<1 2>%a"
+        print_private td.otype_private variants constrs
+  | Otyp_open ->
+      fprintf ppf " =%a .."
+        print_private td.otype_private
+  | ty ->
+      fprintf ppf " =%a@;<1 2>%a"
+        print_private td.otype_private
+        !out_type ty
+  in
+  fprintf ppf "@[<2>@[<hv 2>%t%a@]%t%t%t@]"
+    print_name_params
+    print_out_tkind ty
+    print_constraints
+    print_immediate
+    print_unboxed
+
+and print_out_constr ppf (name, tyl,ret_type_opt) =
+  let name =
+    match name with
+    | "::" -> "(::)"   (* #7200 *)
+    | s -> s
+  in
+  match ret_type_opt with
+  | None ->
+      begin match tyl with
+      | [] ->
+          pp_print_string ppf name
+      | _ ->
+          fprintf ppf "@[<2>%s of@ %a@]" name
+            (print_typlist print_simple_out_type " *") tyl
+      end
+  | Some ret_type ->
+      begin match tyl with
+      | [] ->
+          fprintf ppf "@[<2>%s :@ %a@]" name print_simple_out_type  ret_type
+      | _ ->
+          fprintf ppf "@[<2>%s :@ %a -> %a@]" name
+            (print_typlist print_simple_out_type " *")
+            tyl print_simple_out_type ret_type
+      end
+
+and print_out_extension_constructor ppf ext =
+  let print_extended_type ppf =
+      match ext.oext_type_params with
+        [] -> fprintf ppf "%s" ext.oext_type_name
+      | [ty_param] ->
+        fprintf ppf "@[%a@ %s@]"
+          print_type_parameter
+          ty_param
+          ext.oext_type_name
+      | _ ->
+        fprintf ppf "@[(@[%a)@]@ %s@]"
+          (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ "))
+          ext.oext_type_params
+          ext.oext_type_name
+  in
+  fprintf ppf "@[<hv 2>type %t +=%s@;<1 2>%a@]"
+    print_extended_type
+    (if ext.oext_private = Asttypes.Private then " private" else "")
+    print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type)
+
+and print_out_type_extension ppf te =
+  let print_extended_type ppf =
+    match te.otyext_params with
+      [] -> fprintf ppf "%s" te.otyext_name
+    | [param] ->
+      fprintf ppf "@[%a@ %s@]"
+        print_type_parameter param
+        te.otyext_name
+    | _ ->
+        fprintf ppf "@[(@[%a)@]@ %s@]"
+          (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ "))
+          te.otyext_params
+          te.otyext_name
+  in
+  fprintf ppf "@[<hv 2>type %t +=%s@;<1 2>%a@]"
+    print_extended_type
+    (if te.otyext_private = Asttypes.Private then " private" else "")
+    (print_list print_out_constr (fun ppf -> fprintf ppf "@ | "))
+    te.otyext_constructors
+
+let out_constr = ref print_out_constr
+let _ = out_module_type := print_out_module_type
+let _ = out_signature := print_out_signature
+let _ = out_sig_item := print_out_sig_item
+let _ = out_type_extension := print_out_type_extension
+
+(* Phrases *)
+
+let print_out_exception ppf exn outv =
+  match exn with
+    Sys.Break -> fprintf ppf "Interrupted.@."
+  | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@."
+  | Stack_overflow ->
+      fprintf ppf "Stack overflow during evaluation (looping recursion?).@."
+  | _ -> match Printexc.use_printers exn with
+        | None -> fprintf ppf "@[Exception:@ %a.@]@." !out_value outv
+        | Some s -> fprintf ppf "@[Exception:@ %s@]@." s
+
+let rec print_items ppf =
+  function
+    [] -> ()
+  | (Osig_typext(ext, Oext_first), None) :: items ->
+      (* Gather together extension constructors *)
+      let rec gather_extensions acc items =
+        match items with
+            (Osig_typext(ext, Oext_next), None) :: items ->
+              gather_extensions
+                ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc)
+                items
+          | _ -> (List.rev acc, items)
+      in
+      let exts, items =
+        gather_extensions
+          [(ext.oext_name, ext.oext_args, ext.oext_ret_type)]
+          items
+      in
+      let te =
+        { otyext_name = ext.oext_type_name;
+          otyext_params = ext.oext_type_params;
+          otyext_constructors = exts;
+          otyext_private = ext.oext_private }
+      in
+        fprintf ppf "@[%a@]" !out_type_extension te;
+        if items <> [] then fprintf ppf "@ %a" print_items items
+  | (tree, valopt) :: items ->
+      begin match valopt with
+        Some v ->
+          fprintf ppf "@[<2>%a =@ %a@]" !out_sig_item tree
+            !out_value v
+      | None -> fprintf ppf "@[%a@]" !out_sig_item tree
+      end;
+      if items <> [] then fprintf ppf "@ %a" print_items items
+
+let print_out_phrase ppf =
+  function
+    Ophr_eval (outv, ty) ->
+      fprintf ppf "@[- : %a@ =@ %a@]@." !out_type ty !out_value outv
+  | Ophr_signature [] -> ()
+  | Ophr_signature items -> fprintf ppf "@[<v>%a@]@." print_items items
+  | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv
+
+let out_phrase = ref print_out_phrase
diff --git a/upstream/ocaml_412/typing/oprint.mli b/upstream/ocaml_412/typing/oprint.mli
new file mode 100644
index 0000000..2eaaa26
--- /dev/null
+++ b/upstream/ocaml_412/typing/oprint.mli
@@ -0,0 +1,32 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Projet Cristal, INRIA Rocquencourt                   *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Format
+open Outcometree
+
+val out_ident : (formatter -> out_ident -> unit) ref
+val out_value : (formatter -> out_value -> unit) ref
+val out_label : (formatter -> string * bool * out_type -> unit) ref
+val out_type : (formatter -> out_type -> unit) ref
+val out_constr :
+  (formatter -> string * out_type list * out_type option -> unit) ref
+val out_class_type : (formatter -> out_class_type -> unit) ref
+val out_module_type : (formatter -> out_module_type -> unit) ref
+val out_sig_item : (formatter -> out_sig_item -> unit) ref
+val out_signature : (formatter -> out_sig_item list -> unit) ref
+val out_type_extension : (formatter -> out_type_extension -> unit) ref
+val out_phrase : (formatter -> out_phrase -> unit) ref
+
+val parenthesized_ident : string -> bool
diff --git a/upstream/ocaml_412/typing/outcometree.mli b/upstream/ocaml_412/typing/outcometree.mli
new file mode 100644
index 0000000..2ab89f4
--- /dev/null
+++ b/upstream/ocaml_412/typing/outcometree.mli
@@ -0,0 +1,150 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*      Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt          *)
+(*                                                                        *)
+(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Module [Outcometree]: results displayed by the toplevel *)
+
+(* These types represent messages that the toplevel displays as normal
+   results or errors. The real displaying is customisable using the hooks:
+      [Toploop.print_out_value]
+      [Toploop.print_out_type]
+      [Toploop.print_out_sig_item]
+      [Toploop.print_out_phrase] *)
+
+(** An [out_name] is a string representation of an identifier which can be
+    rewritten on the fly to avoid name collisions *)
+type out_name = { mutable printed_name: string }
+
+type out_ident =
+  | Oide_apply of out_ident * out_ident
+  | Oide_dot of out_ident * string
+  | Oide_ident of out_name
+
+type out_string =
+  | Ostr_string
+  | Ostr_bytes
+
+type out_attribute =
+  { oattr_name: string }
+
+type out_value =
+  | Oval_array of out_value list
+  | Oval_char of char
+  | Oval_constr of out_ident * out_value list
+  | Oval_ellipsis
+  | Oval_float of float
+  | Oval_int of int
+  | Oval_int32 of int32
+  | Oval_int64 of int64
+  | Oval_nativeint of nativeint
+  | Oval_list of out_value list
+  | Oval_printer of (Format.formatter -> unit)
+  | Oval_record of (out_ident * out_value) list
+  | Oval_string of string * int * out_string (* string, size-to-print, kind *)
+  | Oval_stuff of string
+  | Oval_tuple of out_value list
+  | Oval_variant of string * out_value option
+
+type out_type_param = string * (Asttypes.variance * Asttypes.injectivity)
+
+type out_type =
+  | Otyp_abstract
+  | Otyp_open
+  | Otyp_alias of out_type * string
+  | Otyp_arrow of string * out_type * out_type
+  | Otyp_class of bool * out_ident * out_type list
+  | Otyp_constr of out_ident * out_type list
+  | Otyp_manifest of out_type * out_type
+  | Otyp_object of (string * out_type) list * bool option
+  | Otyp_record of (string * bool * out_type) list
+  | Otyp_stuff of string
+  | Otyp_sum of (string * out_type list * out_type option) list
+  | Otyp_tuple of out_type list
+  | Otyp_var of bool * string
+  | Otyp_variant of
+      bool * out_variant * bool * (string list) option
+  | Otyp_poly of string list * out_type
+  | Otyp_module of out_ident * string list * out_type list
+  | Otyp_attribute of out_type * out_attribute
+
+and out_variant =
+  | Ovar_fields of (string * bool * out_type list) list
+  | Ovar_typ of out_type
+
+type out_class_type =
+  | Octy_constr of out_ident * out_type list
+  | Octy_arrow of string * out_type * out_class_type
+  | Octy_signature of out_type option * out_class_sig_item list
+and out_class_sig_item =
+  | Ocsg_constraint of out_type * out_type
+  | Ocsg_method of string * bool * bool * out_type
+  | Ocsg_value of string * bool * bool * out_type
+
+type out_module_type =
+  | Omty_abstract
+  | Omty_functor of (string option * out_module_type) option * out_module_type
+  | Omty_ident of out_ident
+  | Omty_signature of out_sig_item list
+  | Omty_alias of out_ident
+and out_sig_item =
+  | Osig_class of
+      bool * string * out_type_param list * out_class_type *
+        out_rec_status
+  | Osig_class_type of
+      bool * string * out_type_param list * out_class_type *
+        out_rec_status
+  | Osig_typext of out_extension_constructor * out_ext_status
+  | Osig_modtype of string * out_module_type
+  | Osig_module of string * out_module_type * out_rec_status
+  | Osig_type of out_type_decl * out_rec_status
+  | Osig_value of out_val_decl
+  | Osig_ellipsis
+and out_type_decl =
+  { otype_name: string;
+    otype_params: out_type_param list;
+    otype_type: out_type;
+    otype_private: Asttypes.private_flag;
+    otype_immediate: Type_immediacy.t;
+    otype_unboxed: bool;
+    otype_cstrs: (out_type * out_type) list }
+and out_extension_constructor =
+  { oext_name: string;
+    oext_type_name: string;
+    oext_type_params: string list;
+    oext_args: out_type list;
+    oext_ret_type: out_type option;
+    oext_private: Asttypes.private_flag }
+and out_type_extension =
+  { otyext_name: string;
+    otyext_params: string list;
+    otyext_constructors: (string * out_type list * out_type option) list;
+    otyext_private: Asttypes.private_flag }
+and out_val_decl =
+  { oval_name: string;
+    oval_type: out_type;
+    oval_prims: string list;
+    oval_attributes: out_attribute list }
+and out_rec_status =
+  | Orec_not
+  | Orec_first
+  | Orec_next
+and out_ext_status =
+  | Oext_first
+  | Oext_next
+  | Oext_exception
+
+type out_phrase =
+  | Ophr_eval of out_value * out_type
+  | Ophr_signature of (out_sig_item * out_value option) list
+  | Ophr_exception of (exn * out_value)
diff --git a/upstream/ocaml_412/typing/parmatch.ml b/upstream/ocaml_412/typing/parmatch.ml
new file mode 100644
index 0000000..57834d3
--- /dev/null
+++ b/upstream/ocaml_412/typing/parmatch.ml
@@ -0,0 +1,2503 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Detection of partial matches and unused match cases. *)
+
+open Misc
+open Asttypes
+open Types
+open Typedtree
+
+
+(*************************************)
+(* Utilities for building patterns   *)
+(*************************************)
+
+let make_pat desc ty tenv =
+  {pat_desc = desc; pat_loc = Location.none; pat_extra = [];
+   pat_type = ty ; pat_env = tenv;
+   pat_attributes = [];
+  }
+
+let omega = Patterns.omega
+let omegas = Patterns.omegas
+let omega_list = Patterns.omega_list
+
+let extra_pat =
+  make_pat
+    (Tpat_var (Ident.create_local "+", mknoloc "+"))
+    Ctype.none Env.empty
+
+
+(*******************)
+(* Coherence check *)
+(*******************)
+
+(* For some of the operations we do in this module, we would like (because it
+   simplifies matters) to assume that patterns appearing on a given column in a
+   pattern matrix are /coherent/ (think "of the same type").
+   Unfortunately that is not always true.
+
+   Consider the following (well-typed) example:
+   {[
+     type _ t = S : string t | U : unit t
+
+     let f (type a) (t1 : a t) (t2 : a t) (a : a) =
+       match t1, t2, a with
+       | U, _, () -> ()
+       | _, S, "" -> ()
+   ]}
+
+   Clearly the 3rd column contains incoherent patterns.
+
+   On the example above, most of the algorithms will explore the pattern matrix
+   as illustrated by the following tree:
+
+   {v
+                                                   S
+                                                -------> | "" |
+                             U     | S, "" | __/         | () |
+                         --------> | _, () |   \ not S
+        | U, _, () | __/                        -------> | () |
+        | _, S, "" |   \
+                        ---------> | S, "" | ----------> | "" |
+                          not U                    S
+   v}
+
+   where following an edge labelled by a pattern P means "assuming the value I
+   am matching on is filtered by [P] on the column I am currently looking at,
+   then the following submatrix is still reachable".
+
+   Notice that at any point of that tree, if the first column of a matrix is
+   incoherent, then the branch leading to it can only be taken if the scrutinee
+   is ill-typed.
+   In the example above the only case where we have a matrix with an incoherent
+   first column is when we consider [t1, t2, a] to be [U, S, ...]. However such
+   a value would be ill-typed, so we can never actually get there.
+
+   Checking the first column at each step of the recursion and making the
+   conscious decision of "aborting" the algorithm whenever the first column
+   becomes incoherent, allows us to retain the initial assumption in later
+   stages of the algorithms.
+
+   ---
+
+   N.B. two patterns can be considered coherent even though they might not be of
+   the same type.
+
+   That's in part because we only care about the "head" of patterns and leave
+   checking coherence of subpatterns for the next steps of the algorithm:
+   ('a', 'b') and (1, ()) will be deemed coherent because they are both a tuples
+   of arity 2 (we'll notice at a later stage the incoherence of 'a' and 1).
+
+   But also because it can be hard/costly to determine exactly whether two
+   patterns are of the same type or not (eg. in the example above with _ and S,
+   but see also the module [Coherence_illustration] in
+   testsuite/tests/basic-more/robustmatch.ml).
+
+   For the moment our weak, loosely-syntactic, coherence check seems to be
+   enough and we leave it to each user to consider (and document!) what happens
+   when an "incoherence" is not detected by this check.
+*)
+
+(* Given the first column of a simplified matrix, this function first looks for
+   a "discriminating" pattern on that column (i.e. a non-omega one) and then
+   check that every other head pattern in the column is coherent with that one.
+*)
+let all_coherent column =
+  let open Patterns.Head in
+  let coherent_heads hp1 hp2 =
+    match hp1.pat_desc, hp2.pat_desc with
+    | Construct c, Construct c' ->
+      c.cstr_consts = c'.cstr_consts
+      && c.cstr_nonconsts = c'.cstr_nonconsts
+    | Constant c1, Constant c2 -> begin
+        match c1, c2 with
+        | Const_char _, Const_char _
+        | Const_int _, Const_int _
+        | Const_int32 _, Const_int32 _
+        | Const_int64 _, Const_int64 _
+        | Const_nativeint _, Const_nativeint _
+        | Const_float _, Const_float _
+        | Const_string _, Const_string _ -> true
+        | ( Const_char _
+          | Const_int _
+          | Const_int32 _
+          | Const_int64 _
+          | Const_nativeint _
+          | Const_float _
+          | Const_string _), _ -> false
+      end
+    | Tuple l1, Tuple l2 -> l1 = l2
+    | Record (lbl1 :: _), Record (lbl2 :: _) ->
+      Array.length lbl1.lbl_all = Array.length lbl2.lbl_all
+    | Any, _
+    | _, Any
+    | Record [], Record []
+    | Variant _, Variant _
+    | Array _, Array _
+    | Lazy, Lazy -> true
+    | _, _ -> false
+  in
+  match
+    List.find
+      (function
+       | { pat_desc = Any } -> false
+       | _ -> true)
+      column
+  with
+  | exception Not_found ->
+    (* only omegas on the column: the column is coherent. *)
+    true
+  | discr_pat ->
+    List.for_all (coherent_heads discr_pat) column
+
+let first_column simplified_matrix =
+  List.map (fun ((head, _args), _rest) -> head) simplified_matrix
+
+(***********************)
+(* Compatibility check *)
+(***********************)
+
+(* Patterns p and q compatible means:
+   there exists value V that matches both, However....
+
+  The case of extension types is dubious, as constructor rebind permits
+  that different constructors are the same (and are thus compatible).
+
+  Compilation must take this into account, consider:
+
+  type t = ..
+  type t += A|B
+  type t += C=A
+
+  let f x y = match x,y with
+  | true,A  -> '1'
+  | _,C     -> '2'
+  | false,A -> '3'
+  | _,_     -> '_'
+
+  As C is bound to A the value of f false A is '2' (and not '3' as it would
+  be in the absence of rebinding).
+
+  Not considering rebinding, patterns "false,A" and "_,C" are incompatible
+  and the compiler can swap the second and third clause, resulting in the
+  (more efficiently compiled) matching
+
+  match x,y with
+  | true,A  -> '1'
+  | false,A -> '3'
+  | _,C     -> '2'
+  | _,_     -> '_'
+
+  This is not correct: when C is bound to A, "f false A" returns '2' (not '3')
+
+
+  However, diagnostics do not take constructor rebinding into account.
+  Notice, that due to module abstraction constructor rebinding is hidden.
+
+  module X : sig type t = .. type t += A|B end = struct
+    type t = ..
+    type t += A
+    type t += B=A
+  end
+
+  open X
+
+  let f x = match x with
+  | A -> '1'
+  | B -> '2'
+  | _ -> '_'
+
+  The second clause above will NOT (and cannot) be flagged as useless.
+
+  Finally, there are two compatibility functions:
+   compat p q      ---> 'syntactic compatibility, used for diagnostics.
+   may_compat p q --->   a safe approximation of possible compat,
+                         for compilation
+
+*)
+
+
+let is_absent tag row = Btype.row_field tag !row = Rabsent
+
+let is_absent_pat d =
+  match d.pat_desc with
+  | Patterns.Head.Variant { tag; cstr_row; _ } -> is_absent tag cstr_row
+  | _ -> false
+
+let const_compare x y =
+  match x,y with
+  | Const_float f1, Const_float f2 ->
+      Stdlib.compare (float_of_string f1) (float_of_string f2)
+  | Const_string (s1, _, _), Const_string (s2, _, _) ->
+      String.compare s1 s2
+  | (Const_int _
+    |Const_char _
+    |Const_string (_, _, _)
+    |Const_float _
+    |Const_int32 _
+    |Const_int64 _
+    |Const_nativeint _
+    ), _ -> Stdlib.compare x y
+
+let records_args l1 l2 =
+  (* Invariant: fields are already sorted by Typecore.type_label_a_list *)
+  let rec combine r1 r2 l1 l2 = match l1,l2 with
+  | [],[] -> List.rev r1, List.rev r2
+  | [],(_,_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2
+  | (_,_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 []
+  | (_,lbl1,p1)::rem1, ( _,lbl2,p2)::rem2 ->
+      if lbl1.lbl_pos < lbl2.lbl_pos then
+        combine (p1::r1) (omega::r2) rem1 l2
+      else if lbl1.lbl_pos > lbl2.lbl_pos then
+        combine (omega::r1) (p2::r2) l1 rem2
+      else (* same label on both sides *)
+        combine (p1::r1) (p2::r2) rem1 rem2 in
+  combine [] [] l1 l2
+
+
+
+module Compat
+    (Constr:sig
+      val equal :
+          Types.constructor_description ->
+            Types.constructor_description ->
+              bool
+    end) = struct
+
+  let rec compat p q = match p.pat_desc,q.pat_desc with
+(* Variables match any value *)
+  | ((Tpat_any|Tpat_var _),_)
+  | (_,(Tpat_any|Tpat_var _)) -> true
+(* Structural induction *)
+  | Tpat_alias (p,_,_),_      -> compat p q
+  | _,Tpat_alias (q,_,_)      -> compat p q
+  | Tpat_or (p1,p2,_),_ ->
+      (compat p1 q || compat p2 q)
+  | _,Tpat_or (q1,q2,_) ->
+      (compat p q1 || compat p q2)
+(* Constructors, with special case for extension *)
+  | Tpat_construct (_, c1,ps1), Tpat_construct (_, c2,ps2) ->
+      Constr.equal c1 c2 && compats ps1 ps2
+(* More standard stuff *)
+  | Tpat_variant(l1,op1, _), Tpat_variant(l2,op2,_) ->
+      l1=l2 && ocompat op1 op2
+  | Tpat_constant c1, Tpat_constant c2 ->
+      const_compare c1 c2 = 0
+  | Tpat_tuple ps, Tpat_tuple qs -> compats ps qs
+  | Tpat_lazy p, Tpat_lazy q -> compat p q
+  | Tpat_record (l1,_),Tpat_record (l2,_) ->
+      let ps,qs = records_args l1 l2 in
+      compats ps qs
+  | Tpat_array ps, Tpat_array qs ->
+      List.length ps = List.length qs &&
+      compats ps qs
+  | _,_  -> false
+
+  and ocompat op oq = match op,oq with
+  | None,None -> true
+  | Some p,Some q -> compat p q
+  | (None,Some _)|(Some _,None) -> false
+
+  and compats ps qs = match ps,qs with
+  | [], [] -> true
+  | p::ps, q::qs -> compat p q && compats ps qs
+  | _,_    -> false
+
+end
+
+module SyntacticCompat =
+  Compat
+    (struct
+      let equal c1 c2 =  Types.equal_tag c1.cstr_tag c2.cstr_tag
+    end)
+
+let compat =  SyntacticCompat.compat
+and compats = SyntacticCompat.compats
+
+(* Due to (potential) rebinding, two extension constructors
+   of the same arity type may equal *)
+
+exception Empty (* Empty pattern *)
+
+(****************************************)
+(* Utilities for retrieving type paths  *)
+(****************************************)
+
+(* May need a clean copy, cf. PR#4745 *)
+let clean_copy ty =
+  if ty.level = Btype.generic_level then ty
+  else Subst.type_expr Subst.identity ty
+
+let get_constructor_type_path ty tenv =
+  let ty = Ctype.repr (Ctype.expand_head tenv (clean_copy ty)) in
+  match ty.desc with
+  | Tconstr (path,_,_) -> path
+  | _ -> assert false
+
+(****************************)
+(* Utilities for matching   *)
+(****************************)
+
+(* Check top matching *)
+let simple_match d h =
+  let open Patterns.Head in
+  match d.pat_desc, h.pat_desc with
+  | Construct c1, Construct c2 ->
+      Types.equal_tag c1.cstr_tag c2.cstr_tag
+  | Variant { tag = t1; _ }, Variant { tag = t2 } ->
+      t1 = t2
+  | Constant c1, Constant c2 -> const_compare c1 c2 = 0
+  | Lazy, Lazy -> true
+  | Record _, Record _ -> true
+  | Tuple len1, Tuple len2
+  | Array len1, Array len2 -> len1 = len2
+  | _, Any -> true
+  | _, _ -> false
+
+
+
+(* extract record fields as a whole *)
+let record_arg ph =
+  let open Patterns.Head in
+  match ph.pat_desc with
+  | Any -> []
+  | Record args -> args
+  | _ -> fatal_error "Parmatch.as_record"
+
+
+let extract_fields lbls arg =
+  let get_field pos arg =
+    match List.find (fun (lbl,_) -> pos = lbl.lbl_pos) arg with
+    | _, p -> p
+    | exception Not_found -> omega
+  in
+  List.map (fun lbl -> get_field lbl.lbl_pos arg) lbls
+
+(* Build argument list when p2 >= p1, where p1 is a simple pattern *)
+let simple_match_args discr head args =
+  let open Patterns.Head in
+  match head.pat_desc with
+  | Constant _ -> []
+  | Construct _
+  | Variant _
+  | Tuple _
+  | Array _
+  | Lazy -> args
+  | Record lbls ->  extract_fields (record_arg discr) (List.combine lbls args)
+  | Any ->
+      begin match discr.pat_desc with
+      | Construct cstr -> Patterns.omegas cstr.cstr_arity
+      | Variant { has_arg = true }
+      | Lazy -> [Patterns.omega]
+      | Record lbls ->  omega_list lbls
+      | Array len
+      | Tuple len -> Patterns.omegas len
+      | Variant { has_arg = false }
+      | Any
+      | Constant _ -> []
+      end
+
+(* Consider a pattern matrix whose first column has been simplified to contain
+   only _ or a head constructor
+     | p1, r1...
+     | p2, r2...
+     | p3, r3...
+     | ...
+
+   We build a normalized /discriminating/ pattern from a pattern [q] by folding
+   over the first column of the matrix, "refining" [q] as we go:
+
+   - when we encounter a row starting with [Tuple] or [Lazy] then we
+   can stop and return that head, as we cannot refine any further. Indeed,
+   these constructors are alone in their signature, so they will subsume
+   whatever other head we might find, as well as the head we're threading
+   along.
+
+   - when we find a [Record] then it is a bit more involved: it is also alone
+   in its signature, however it might only be matching a subset of the
+   record fields. We use these fields to refine our accumulator and keep going
+   as another row might match on different fields.
+
+   - rows starting with a wildcard do not bring any information, so we ignore
+   them and keep going
+
+   - if we encounter anything else (i.e. any other constructor), then we just
+   stop and return our accumulator.
+*)
+let discr_pat q pss =
+  let open Patterns.Head in
+  let rec refine_pat acc = function
+    | [] -> acc
+    | ((head, _), _) :: rows ->
+      match head.pat_desc with
+      | Any -> refine_pat acc rows
+      | Tuple _ | Lazy -> head
+      | Record lbls ->
+        (* N.B. we could make this case "simpler" by refining the record case
+           using [all_record_args].
+           In which case we wouldn't need to fold over the first column for
+           records.
+           However it makes the witness we generate for the exhaustivity warning
+           less pretty. *)
+        let fields =
+          List.fold_right (fun lbl r ->
+            if List.exists (fun l -> l.lbl_pos = lbl.lbl_pos) r then
+              r
+            else
+              lbl :: r
+          ) lbls (record_arg acc)
+        in
+        let d = { head with pat_desc = Record fields } in
+        refine_pat d rows
+      | _ -> acc
+  in
+  let q, _ = deconstruct q in
+  match q.pat_desc with
+  (* short-circuiting: clearly if we have anything other than [Record] or
+     [Any] to start with, we're not going to be able refine at all. So
+     there's no point going over the matrix. *)
+  | Any | Record _ -> refine_pat q pss
+  | _ -> q
+
+(*
+   In case a matching value is found, set actual arguments
+   of the matching pattern.
+*)
+
+let rec read_args xs r = match xs,r with
+| [],_ -> [],r
+| _::xs, arg::rest ->
+   let args,rest = read_args xs rest in
+   arg::args,rest
+| _,_ ->
+    fatal_error "Parmatch.read_args"
+
+let do_set_args ~erase_mutable q r = match q with
+| {pat_desc = Tpat_tuple omegas} ->
+    let args,rest = read_args omegas r in
+    make_pat (Tpat_tuple args) q.pat_type q.pat_env::rest
+| {pat_desc = Tpat_record (omegas,closed)} ->
+    let args,rest = read_args omegas r in
+    make_pat
+      (Tpat_record
+         (List.map2 (fun (lid, lbl,_) arg ->
+           if
+             erase_mutable &&
+             (match lbl.lbl_mut with
+             | Mutable -> true | Immutable -> false)
+           then
+             lid, lbl, omega
+           else
+             lid, lbl, arg)
+            omegas args, closed))
+      q.pat_type q.pat_env::
+    rest
+| {pat_desc = Tpat_construct (lid, c,omegas)} ->
+    let args,rest = read_args omegas r in
+    make_pat
+      (Tpat_construct (lid, c,args))
+      q.pat_type q.pat_env::
+    rest
+| {pat_desc = Tpat_variant (l, omega, row)} ->
+    let arg, rest =
+      match omega, r with
+        Some _, a::r -> Some a, r
+      | None, r -> None, r
+      | _ -> assert false
+    in
+    make_pat
+      (Tpat_variant (l, arg, row)) q.pat_type q.pat_env::
+    rest
+| {pat_desc = Tpat_lazy _omega} ->
+    begin match r with
+      arg::rest ->
+        make_pat (Tpat_lazy arg) q.pat_type q.pat_env::rest
+    | _ -> fatal_error "Parmatch.do_set_args (lazy)"
+    end
+| {pat_desc = Tpat_array omegas} ->
+    let args,rest = read_args omegas r in
+    make_pat
+      (Tpat_array args) q.pat_type q.pat_env::
+    rest
+| {pat_desc=Tpat_constant _|Tpat_any} ->
+    q::r (* case any is used in matching.ml *)
+| _ -> fatal_error "Parmatch.set_args"
+
+let set_args q r = do_set_args ~erase_mutable:false q r
+and set_args_erase_mutable q r = do_set_args ~erase_mutable:true q r
+
+(* Given a matrix of non-empty rows
+   p1 :: r1...
+   p2 :: r2...
+   p3 :: r3...
+
+   Simplify the first column [p1 p2 p3] by splitting all or-patterns.
+   The result is a list of pairs
+     ((pattern head, arguments), rest of row)
+
+   For example,
+     x :: r1
+     (Some _) as y :: r2
+     (None as x) as y :: r3
+     (Some x | (None as x)) :: r4
+   becomes
+     ((   _ , [ ] ), r1)
+     (( Some, [_] ), r2)
+     (( None, [ ] ), r3)
+     (( Some, [x] ), r4)
+     (( None, [ ] ), r4)
+ *)
+let simplify_head_pat ~add_column p ps k =
+  let rec simplify_head_pat p ps k =
+    match Patterns.General.(view p |> strip_vars).pat_desc with
+    | `Or (p1,p2,_) -> simplify_head_pat p1 ps (simplify_head_pat p2 ps k)
+    | #Patterns.Simple.view as view ->
+       add_column (Patterns.Head.deconstruct { p with pat_desc = view }) ps k
+  in simplify_head_pat p ps k
+
+let rec simplify_first_col = function
+  | [] -> []
+  | [] :: _ -> assert false (* the rows are non-empty! *)
+  | (p::ps) :: rows ->
+      let add_column p ps k = (p, ps) :: k in
+      simplify_head_pat ~add_column p ps (simplify_first_col rows)
+
+
+(* Builds the specialized matrix of [pss] according to the discriminating
+   pattern head [d].
+   See section 3.1 of http://moscova.inria.fr/~maranget/papers/warn/warn.pdf
+
+   NOTES:
+   - we are polymorphic on the type of matrices we work on, in particular a row
+   might not simply be a [pattern list]. That's why we have the [extend_row]
+   parameter.
+*)
+let build_specialized_submatrix ~extend_row discr pss =
+  let rec filter_rec = function
+    | ((head, args), ps) :: pss ->
+        if simple_match discr head
+        then extend_row (simple_match_args discr head args) ps :: filter_rec pss
+        else filter_rec pss
+    | _ -> [] in
+  filter_rec pss
+
+(* The "default" and "specialized" matrices of a given matrix.
+   See section 3.1 of http://moscova.inria.fr/~maranget/papers/warn/warn.pdf .
+*)
+type 'matrix specialized_matrices = {
+  default : 'matrix;
+  constrs : (Patterns.Head.t * 'matrix) list;
+}
+
+(* Consider a pattern matrix whose first column has been simplified
+   to contain only _ or a head constructor
+     | p1, r1...
+     | p2, r2...
+     | p3, r3...
+     | ...
+
+   We split this matrix into a list of /specialized/ sub-matrices, one for
+   each head constructor appearing in the first column. For each row whose
+   first column starts with a head constructor, remove this head
+   column, prepend one column for each argument of the constructor,
+   and add the resulting row in the sub-matrix corresponding to this
+   head constructor.
+
+   Rows whose left column is omega (the Any pattern _) may match any
+   head constructor, so they are added to all sub-matrices.
+
+   In the case where all the rows in the matrix have an omega on their first
+   column, then there is only one /specialized/ sub-matrix, formed of all these
+   omega rows.
+   This matrix is also called the /default/ matrix.
+
+   See the documentation of [build_specialized_submatrix] for an explanation of
+   the [extend_row] parameter.
+*)
+let build_specialized_submatrices ~extend_row discr rows =
+  let extend_group discr p args r rs =
+    let r = extend_row (simple_match_args discr p args) r in
+    (discr, r :: rs)
+  in
+
+  (* insert a row of head [p] and rest [r] into the right group
+
+     Note: with this implementation, the order of the groups
+     is the order of their first row in the source order.
+     This is a nice property to get exhaustivity counter-examples
+     in source order.
+  *)
+  let rec insert_constr head args r = function
+    | [] ->
+      (* if no group matched this row, it has a head constructor that
+         was never seen before; add a new sub-matrix for this head *)
+      [extend_group head head args r []]
+    | (q0,rs) as bd::env ->
+      if simple_match q0 head
+      then extend_group q0 head args r rs :: env
+      else bd :: insert_constr head args r env
+  in
+
+  (* insert a row of head omega into all groups *)
+  let insert_omega r env =
+    List.map (fun (q0,rs) -> extend_group q0 Patterns.Head.omega [] r rs) env
+  in
+
+  let rec form_groups constr_groups omega_tails = function
+    | [] -> (constr_groups, omega_tails)
+    | ((head, args), tail) :: rest ->
+        match head.pat_desc with
+        | Patterns.Head.Any ->
+            (* note that calling insert_omega here would be wrong
+               as some groups may not have been formed yet, if the
+               first row with this head pattern comes after in the list *)
+            form_groups constr_groups (tail :: omega_tails) rest
+        | _ ->
+            form_groups
+              (insert_constr head args tail constr_groups) omega_tails rest
+  in
+
+  let constr_groups, omega_tails =
+    let initial_constr_group =
+      let open Patterns.Head in
+      match discr.pat_desc with
+      | Record _ | Tuple _ | Lazy ->
+        (* [discr] comes from [discr_pat], and in this case subsumes any of the
+           patterns we could find on the first column of [rows]. So it is better
+           to use it for our initial environment than any of the normalized
+           pattern we might obtain from the first column. *)
+        [discr,[]]
+      | _ -> []
+    in
+    form_groups initial_constr_group [] rows
+  in
+
+  (* groups are accumulated in reverse order;
+     we restore the order of rows in the source code *)
+  let default = List.rev omega_tails in
+  let constrs =
+    List.fold_right insert_omega omega_tails constr_groups
+    |> List.map (fun (discr, rs) -> (discr, List.rev rs))
+  in
+  { default; constrs; }
+
+(* Variant related functions *)
+
+let set_last a =
+  let rec loop = function
+    | [] -> assert false
+    | [_] -> [Patterns.General.erase a]
+    | x::l -> x :: loop l
+  in
+  function
+  | (_, []) -> (Patterns.Head.deconstruct a, [])
+  | (first, row) -> (first, loop row)
+
+(* mark constructor lines for failure when they are incomplete *)
+let mark_partial =
+  let zero = make_pat (`Constant (Const_int 0)) Ctype.none Env.empty in
+  List.map (fun ((hp, _), _ as ps) ->
+    match hp.pat_desc with
+    | Patterns.Head.Any -> ps
+    | _ -> set_last zero ps
+  )
+
+let close_variant env row =
+  let row = Btype.row_repr row in
+  let nm =
+    List.fold_left
+      (fun nm (_tag,f) ->
+        match Btype.row_field_repr f with
+        | Reither(_, _, false, e) ->
+            (* m=false means that this tag is not explicitly matched *)
+            Btype.set_row_field e Rabsent;
+            None
+        | Rabsent | Reither (_, _, true, _) | Rpresent _ -> nm)
+      row.row_name row.row_fields in
+  if not row.row_closed || nm != row.row_name then begin
+    (* this unification cannot fail *)
+    Ctype.unify env row.row_more
+      (Btype.newgenty
+         (Tvariant {row with row_fields = []; row_more = Btype.newgenvar();
+                    row_closed = true; row_name = nm}))
+  end
+
+(*
+  Check whether the first column of env makes up a complete signature or
+  not. We work on the discriminating pattern heads of each sub-matrix: they
+  are not omega/Any.
+*)
+let full_match closing env =  match env with
+| [] -> false
+| (discr, _) :: _ ->
+  let open Patterns.Head in
+  match discr.pat_desc with
+  | Any -> assert false
+  | Construct { cstr_tag = Cstr_extension _ ; _ } -> false
+  | Construct c -> List.length env = c.cstr_consts + c.cstr_nonconsts
+  | Variant { type_row; _ } ->
+      let fields =
+        List.map
+          (fun (d, _) ->
+            match d.pat_desc with
+            | Variant { tag } -> tag
+            | _ -> assert false)
+          env
+      in
+      let row = type_row () in
+      if closing && not (Btype.row_fixed row) then
+        (* closing=true, we are considering the variant as closed *)
+        List.for_all
+          (fun (tag,f) ->
+            match Btype.row_field_repr f with
+              Rabsent | Reither(_, _, false, _) -> true
+            | Reither (_, _, true, _)
+                (* m=true, do not discard matched tags, rather warn *)
+            | Rpresent _ -> List.mem tag fields)
+          row.row_fields
+      else
+        row.row_closed &&
+        List.for_all
+          (fun (tag,f) ->
+            Btype.row_field_repr f = Rabsent || List.mem tag fields)
+          row.row_fields
+  | Constant Const_char _ ->
+      List.length env = 256
+  | Constant _
+  | Array _ -> false
+  | Tuple _
+  | Record _
+  | Lazy -> true
+
+(* Written as a non-fragile matching, PR#7451 originated from a fragile matching
+   below. *)
+let should_extend ext env = match ext with
+| None -> false
+| Some ext -> begin match env with
+  | [] -> assert false
+  | (p,_)::_ ->
+      let open Patterns.Head in
+      begin match p.pat_desc with
+      | Construct {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)} ->
+          let path = get_constructor_type_path p.pat_type p.pat_env in
+          Path.same path ext
+      | Construct {cstr_tag=(Cstr_extension _)} -> false
+      | Constant _ | Tuple _ | Variant _ | Record _ | Array _ | Lazy -> false
+      | Any -> assert false
+      end
+end
+
+module ConstructorTagHashtbl = Hashtbl.Make(
+  struct
+    type t = Types.constructor_tag
+    let hash = Hashtbl.hash
+    let equal = Types.equal_tag
+  end
+)
+
+(* complement constructor tags *)
+let complete_tags nconsts nconstrs tags =
+  let seen_const = Array.make nconsts false
+  and seen_constr = Array.make nconstrs false in
+  List.iter
+    (function
+      | Cstr_constant i -> seen_const.(i) <- true
+      | Cstr_block i -> seen_constr.(i) <- true
+      | _  -> assert false)
+    tags ;
+  let r = ConstructorTagHashtbl.create (nconsts+nconstrs) in
+  for i = 0 to nconsts-1 do
+    if not seen_const.(i) then
+      ConstructorTagHashtbl.add r (Cstr_constant i) ()
+  done ;
+  for i = 0 to nconstrs-1 do
+    if not seen_constr.(i) then
+      ConstructorTagHashtbl.add r (Cstr_block i) ()
+  done ;
+  r
+
+(* build a pattern from a constructor description *)
+let pat_of_constr ex_pat cstr =
+  {ex_pat with pat_desc =
+   Tpat_construct (mknoloc (Longident.Lident cstr.cstr_name),
+                   cstr, omegas cstr.cstr_arity)}
+
+let orify x y = make_pat (Tpat_or (x, y, None)) x.pat_type x.pat_env
+
+let rec orify_many = function
+| [] -> assert false
+| [x] -> x
+| x :: xs -> orify x (orify_many xs)
+
+(* build an or-pattern from a constructor list *)
+let pat_of_constrs ex_pat cstrs =
+  let ex_pat = Patterns.Head.to_omega_pattern ex_pat in
+  if cstrs = [] then raise Empty else
+  orify_many (List.map (pat_of_constr ex_pat) cstrs)
+
+let pats_of_type ?(always=false) env ty =
+  let ty' = Ctype.expand_head env ty in
+  match ty'.desc with
+  | Tconstr (path, _, _) ->
+      begin try match (Env.find_type path env).type_kind with
+      | Type_variant cl when always || List.length cl <= 1 ||
+        (* Only explode when all constructors are GADTs *)
+        List.for_all (fun cd -> cd.Types.cd_res <> None) cl ->
+          let cstrs = fst (Env.find_type_descrs path env) in
+          List.map (pat_of_constr (make_pat Tpat_any ty env)) cstrs
+      | Type_record _ ->
+          let labels = snd (Env.find_type_descrs path env) in
+          let fields =
+            List.map (fun ld ->
+              mknoloc (Longident.Lident ld.lbl_name), ld, omega)
+              labels
+          in
+          [make_pat (Tpat_record (fields, Closed)) ty env]
+      | _ -> [omega]
+      with Not_found -> [omega]
+      end
+  | Ttuple tl ->
+      [make_pat (Tpat_tuple (omegas (List.length tl))) ty env]
+  | _ -> [omega]
+
+let rec get_variant_constructors env ty =
+  match (Ctype.repr ty).desc with
+  | Tconstr (path,_,_) -> begin
+      try match Env.find_type path env with
+      | {type_kind=Type_variant _} ->
+          fst (Env.find_type_descrs path env)
+      | {type_manifest = Some _} ->
+          get_variant_constructors env
+            (Ctype.expand_head_once env (clean_copy ty))
+      | _ -> fatal_error "Parmatch.get_variant_constructors"
+      with Not_found ->
+        fatal_error "Parmatch.get_variant_constructors"
+    end
+  | _ -> fatal_error "Parmatch.get_variant_constructors"
+
+(* Sends back a pattern that complements constructor tags all_tag *)
+let complete_constrs constr all_tags =
+  let c = constr.pat_desc in
+  let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in
+  let constrs = get_variant_constructors constr.pat_env c.cstr_res in
+  let others =
+    List.filter
+      (fun cnstr -> ConstructorTagHashtbl.mem not_tags cnstr.cstr_tag)
+      constrs in
+  let const, nonconst =
+    List.partition (fun cnstr -> cnstr.cstr_arity = 0) others in
+  const @ nonconst
+
+let build_other_constrs env p =
+  let open Patterns.Head in
+  match p.pat_desc with
+  | Construct ({ cstr_tag = Cstr_constant _ | Cstr_block _ } as c) ->
+      let constr = { p with pat_desc = c } in
+      let get_tag q =
+        match q.pat_desc with
+        | Construct c -> c.cstr_tag
+        | _ -> fatal_error "Parmatch.get_tag" in
+      let all_tags =  List.map (fun (p,_) -> get_tag p) env in
+      pat_of_constrs p (complete_constrs constr all_tags)
+  | _ -> extra_pat
+
+(* Auxiliary for build_other *)
+
+let build_other_constant proj make first next p env =
+  let all = List.map (fun (p, _) -> proj p.pat_desc) env in
+  let rec try_const i =
+    if List.mem i all
+    then try_const (next i)
+    else make_pat (make i) p.pat_type p.pat_env
+  in try_const first
+
+(*
+  Builds a pattern that is incompatible with all patterns in
+  the first column of env
+*)
+
+let some_private_tag = "<some private tag>"
+
+let build_other ext env =
+  match env with
+  | [] -> omega
+  | (d, _) :: _ ->
+      let open Patterns.Head in
+      match d.pat_desc with
+      | Construct { cstr_tag = Cstr_extension _ } ->
+          (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *)
+          make_pat
+            (Tpat_var (Ident.create_local "*extension*",
+                       {txt="*extension*"; loc = d.pat_loc}))
+            Ctype.none Env.empty
+      | Construct _ ->
+          begin match ext with
+          | Some ext ->
+              if Path.same ext (get_constructor_type_path d.pat_type d.pat_env)
+              then
+                extra_pat
+              else
+                build_other_constrs env d
+          | _ ->
+              build_other_constrs env d
+          end
+      | Variant { cstr_row; type_row } ->
+          let tags =
+            List.map
+              (fun (d, _) ->
+                match d.pat_desc with
+                | Variant { tag } -> tag
+                | _ -> assert false)
+              env
+            in
+            let make_other_pat tag const =
+              let arg = if const then None else Some Patterns.omega in
+              make_pat (Tpat_variant(tag, arg, cstr_row)) d.pat_type d.pat_env
+            in
+            let row = type_row () in
+            begin match
+              List.fold_left
+                (fun others (tag,f) ->
+                  if List.mem tag tags then others else
+                  match Btype.row_field_repr f with
+                    Rabsent (* | Reither _ *) -> others
+                  (* This one is called after erasing pattern info *)
+                  | Reither (c, _, _, _) -> make_other_pat tag c :: others
+                  | Rpresent arg -> make_other_pat tag (arg = None) :: others)
+                [] row.row_fields
+            with
+              [] ->
+                let tag =
+                  if Btype.row_fixed row then some_private_tag else
+                  let rec mktag tag =
+                    if List.mem tag tags then mktag (tag ^ "'") else tag in
+                  mktag "AnyOtherTag"
+                in make_other_pat tag true
+            | pat::other_pats ->
+                List.fold_left
+                  (fun p_res pat ->
+                    make_pat (Tpat_or (pat, p_res, None)) d.pat_type d.pat_env)
+                  pat other_pats
+            end
+      | Constant Const_char _ ->
+          let all_chars =
+            List.map
+              (fun (p,_) -> match p.pat_desc with
+              | Constant (Const_char c) -> c
+              | _ -> assert false)
+              env
+          in
+          let rec find_other i imax =
+            if i > imax then raise Not_found
+            else
+              let ci = Char.chr i in
+              if List.mem ci all_chars then
+                find_other (i+1) imax
+              else
+                make_pat (Tpat_constant (Const_char ci)) d.pat_type d.pat_env
+          in
+          let rec try_chars = function
+            | [] -> Patterns.omega
+            | (c1,c2) :: rest ->
+                try
+                  find_other (Char.code c1) (Char.code c2)
+                with
+                | Not_found -> try_chars rest
+          in
+          try_chars
+            [ 'a', 'z' ; 'A', 'Z' ; '0', '9' ;
+              ' ', '~' ; Char.chr 0 , Char.chr 255]
+      | Constant Const_int _ ->
+          build_other_constant
+            (function Constant(Const_int i) -> i | _ -> assert false)
+            (function i -> Tpat_constant(Const_int i))
+            0 succ d env
+      | Constant Const_int32 _ ->
+          build_other_constant
+            (function Constant(Const_int32 i) -> i | _ -> assert false)
+            (function i -> Tpat_constant(Const_int32 i))
+            0l Int32.succ d env
+      | Constant Const_int64 _ ->
+          build_other_constant
+            (function Constant(Const_int64 i) -> i | _ -> assert false)
+            (function i -> Tpat_constant(Const_int64 i))
+            0L Int64.succ d env
+      | Constant Const_nativeint _ ->
+          build_other_constant
+            (function Constant(Const_nativeint i) -> i | _ -> assert false)
+            (function i -> Tpat_constant(Const_nativeint i))
+            0n Nativeint.succ d env
+      | Constant Const_string _ ->
+          build_other_constant
+            (function Constant(Const_string (s, _, _)) -> String.length s
+                    | _ -> assert false)
+            (function i ->
+               Tpat_constant
+                 (Const_string(String.make i '*',Location.none,None)))
+            0 succ d env
+      | Constant Const_float _ ->
+          build_other_constant
+            (function Constant(Const_float f) -> float_of_string f
+                    | _ -> assert false)
+            (function f -> Tpat_constant(Const_float (string_of_float f)))
+            0.0 (fun f -> f +. 1.0) d env
+      | Array _ ->
+          let all_lengths =
+            List.map
+              (fun (p,_) -> match p.pat_desc with
+              | Array len -> len
+              | _ -> assert false)
+              env in
+          let rec try_arrays l =
+            if List.mem l all_lengths then try_arrays (l+1)
+            else
+              make_pat (Tpat_array (omegas l)) d.pat_type d.pat_env in
+          try_arrays 0
+      | _ -> Patterns.omega
+
+let rec has_instance p = match p.pat_desc with
+  | Tpat_variant (l,_,r) when is_absent l r -> false
+  | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true
+  | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) -> has_instance p
+  | Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2
+  | Tpat_construct (_,_,ps) | Tpat_tuple ps | Tpat_array ps ->
+      has_instances ps
+  | Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,x) -> x) lps)
+  | Tpat_lazy p
+    -> has_instance p
+
+and has_instances = function
+  | [] -> true
+  | q::rem -> has_instance q && has_instances rem
+
+(*
+  Core function :
+  Is the last row of pattern matrix pss + qs satisfiable ?
+  That is :
+    Does there exists at least one value vector, es such that :
+     1- for all ps in pss ps # es (ps and es are not compatible)
+     2- qs <= es                  (es matches qs)
+
+   ---
+
+   In two places in the following function, we check the coherence of the first
+   column of (pss + qs).
+   If it is incoherent, then we exit early saying that (pss + qs) is not
+   satisfiable (which is equivalent to saying "oh, we shouldn't have considered
+   that branch, no good result came come from here").
+
+   But what happens if we have a coherent but ill-typed column?
+   - we might end up returning [false], which is equivalent to noticing the
+   incompatibility: clearly this is fine.
+   - if we end up returning [true] then we're saying that [qs] is useful while
+   it is not. This is sad but not the end of the world, we're just allowing dead
+   code to survive.
+*)
+let rec satisfiable pss qs = match pss with
+| [] -> has_instances qs
+| _  ->
+    match qs with
+    | [] -> false
+    | q::qs ->
+       match Patterns.General.(view q |> strip_vars).pat_desc with
+       | `Or(q1,q2,_) ->
+          satisfiable pss (q1::qs) || satisfiable pss (q2::qs)
+       | `Any ->
+          let pss = simplify_first_col pss in
+          if not (all_coherent (first_column pss)) then
+            false
+          else begin
+            let { default; constrs } =
+              let q0 = discr_pat Patterns.Simple.omega pss in
+              build_specialized_submatrices ~extend_row:(@) q0 pss in
+            if not (full_match false constrs) then
+              satisfiable default qs
+            else
+              List.exists
+                (fun (p,pss) ->
+                   not (is_absent_pat p) &&
+                   satisfiable pss
+                     (simple_match_args p Patterns.Head.omega [] @ qs))
+                constrs
+          end
+       | `Variant (l,_,r) when is_absent l r -> false
+       | #Patterns.Simple.view as view ->
+          let q = { q with pat_desc = view } in
+          let pss = simplify_first_col pss in
+          let hq, qargs = Patterns.Head.deconstruct q in
+          if not (all_coherent (hq :: first_column pss)) then
+            false
+          else begin
+              let q0 = discr_pat q pss in
+              satisfiable (build_specialized_submatrix ~extend_row:(@) q0 pss)
+                (simple_match_args q0 hq qargs @ qs)
+            end
+
+(* While [satisfiable] only checks whether the last row of [pss + qs] is
+   satisfiable, this function returns the (possibly empty) list of vectors [es]
+   which verify:
+     1- for all ps in pss, ps # es (ps and es are not compatible)
+     2- qs <= es                   (es matches qs)
+
+   This is done to enable GADT handling
+
+   For considerations regarding the coherence check, see the comment on
+   [satisfiable] above.  *)
+let rec list_satisfying_vectors pss qs =
+  match pss with
+  | [] -> if has_instances qs then [qs] else []
+  | _  ->
+      match qs with
+      | [] -> []
+      | q :: qs ->
+         match Patterns.General.(view q |> strip_vars).pat_desc with
+         | `Or(q1,q2,_) ->
+            list_satisfying_vectors pss (q1::qs) @
+            list_satisfying_vectors pss (q2::qs)
+         | `Any ->
+            let pss = simplify_first_col pss in
+            if not (all_coherent (first_column pss)) then
+              []
+            else begin
+              let q0 = discr_pat Patterns.Simple.omega pss in
+              let wild default_matrix p =
+                List.map (fun qs -> p::qs)
+                  (list_satisfying_vectors default_matrix qs)
+              in
+              match build_specialized_submatrices ~extend_row:(@) q0 pss with
+              | { default; constrs = [] } ->
+                  (* first column of pss is made of variables only *)
+                  wild default omega
+              | { default; constrs = ((p,_)::_ as constrs) } ->
+                  let for_constrs () =
+                    List.flatten (
+                      List.map (fun (p,pss) ->
+                        if is_absent_pat p then
+                          []
+                        else
+                          let witnesses =
+                            list_satisfying_vectors pss
+                              (simple_match_args p Patterns.Head.omega [] @ qs)
+                          in
+                          let p = Patterns.Head.to_omega_pattern p in
+                          List.map (set_args p) witnesses
+                      ) constrs
+                    )
+                  in
+                  if full_match false constrs then for_constrs () else
+                  begin match p.pat_desc with
+                  | Construct _ ->
+                      (* activate this code
+                         for checking non-gadt constructors *)
+                      wild default (build_other_constrs constrs p)
+                      @ for_constrs ()
+                  | _ ->
+                      wild default Patterns.omega
+                  end
+          end
+      | `Variant (l, _, r) when is_absent l r -> []
+      | #Patterns.Simple.view as view ->
+          let q = { q with pat_desc = view } in
+          let hq, qargs = Patterns.Head.deconstruct q in
+          let pss = simplify_first_col pss in
+          if not (all_coherent (hq :: first_column pss)) then
+            []
+          else begin
+            let q0 = discr_pat q pss in
+            List.map (set_args (Patterns.Head.to_omega_pattern q0))
+              (list_satisfying_vectors
+                 (build_specialized_submatrix ~extend_row:(@) q0 pss)
+                 (simple_match_args q0 hq qargs @ qs))
+          end
+
+(******************************************)
+(* Look for a row that matches some value *)
+(******************************************)
+
+(*
+  Useful for seeing if the example of
+  non-matched value can indeed be matched
+  (by a guarded clause)
+*)
+
+let rec do_match pss qs = match qs with
+| [] ->
+    begin match pss  with
+    | []::_ -> true
+    | _ -> false
+    end
+| q::qs -> match Patterns.General.(view q |> strip_vars).pat_desc with
+  | `Or (q1,q2,_) ->
+      do_match pss (q1::qs) || do_match pss (q2::qs)
+  | `Any ->
+      let rec remove_first_column = function
+        | (_::ps)::rem -> ps::remove_first_column rem
+        | _ -> []
+      in
+      do_match (remove_first_column pss) qs
+  | #Patterns.Simple.view as view ->
+      let q = { q with pat_desc = view } in
+      let q0, qargs = Patterns.Head.deconstruct q in
+      let pss = simplify_first_col pss in
+      (* [pss] will (or won't) match [q0 :: qs] regardless of the coherence of
+         its first column. *)
+      do_match
+        (build_specialized_submatrix ~extend_row:(@) q0 pss)
+        (qargs @ qs)
+
+(*
+let print_pat pat =
+  let rec string_of_pat pat =
+    match pat.pat_desc with
+        Tpat_var _ -> "v"
+      | Tpat_any -> "_"
+      | Tpat_alias (p, x) -> Printf.sprintf "(%s) as ?"  (string_of_pat p)
+      | Tpat_constant n -> "0"
+      | Tpat_construct (_, lid, _) ->
+        Printf.sprintf "%s" (String.concat "." (Longident.flatten lid.txt))
+      | Tpat_lazy p ->
+        Printf.sprintf "(lazy %s)" (string_of_pat p)
+      | Tpat_or (p1,p2,_) ->
+        Printf.sprintf "(%s | %s)" (string_of_pat p1) (string_of_pat p2)
+      | Tpat_tuple list ->
+        Printf.sprintf "(%s)" (String.concat "," (List.map string_of_pat list))
+      | Tpat_variant (_, _, _) -> "variant"
+      | Tpat_record (_, _) -> "record"
+      | Tpat_array _ -> "array"
+  in
+  Printf.fprintf stderr "PAT[%s]\n%!" (string_of_pat pat)
+*)
+
+(*
+  Now another satisfiable function that additionally
+  supplies an example of a matching value.
+
+  This function should be called for exhaustiveness check only.
+*)
+let rec exhaust (ext:Path.t option) pss n = match pss with
+| []    ->  Seq.return (omegas n)
+| []::_ ->  Seq.empty
+| [(p :: ps)] -> exhaust_single_row ext p ps n
+| pss   -> specialize_and_exhaust ext pss n
+
+and exhaust_single_row ext p ps n =
+  (* Shortcut: in the single-row case p :: ps we know that all
+     counter-examples are either of the form
+       counter-example(p) :: omegas
+     or
+       p :: counter-examples(ps)
+
+     This is very interesting in the case where p contains
+     or-patterns, as the non-shortcut path below would do a separate
+     search for each constructor of the or-pattern, which can lead to
+     an exponential blowup on examples such as
+
+       | (A|B), (A|B), (A|B), (A|B) -> foo
+
+     Note that this shortcut also applies to examples such as
+
+       | A, A, A, A -> foo | (A|B), (A|B), (A|B), (A|B) -> bar
+
+     thanks to the [get_mins] preprocessing step which will drop the
+     first row (subsumed by the second). Code with this shape does
+     occur naturally when people want to avoid fragile pattern
+     matches: if A and B are the only two constructors, this is the
+     best way to make a non-fragile distinction between "all As" and
+     "at least one B".
+  *)
+  List.to_seq [Some p; None] |> Seq.flat_map
+    (function
+      | Some p ->
+          let sub_witnesses = exhaust ext [ps] (n - 1) in
+          Seq.map (fun row -> p :: row) sub_witnesses
+      | None ->
+          (* note: calling [exhaust] recursively of p would
+             result in an infinite loop in the case n=1 *)
+          let p_witnesses = specialize_and_exhaust ext [[p]] 1 in
+          Seq.map (fun p_row -> p_row @ omegas (n - 1)) p_witnesses
+    )
+
+and specialize_and_exhaust ext pss n =
+  let pss = simplify_first_col pss in
+  if not (all_coherent (first_column pss)) then
+    (* We're considering an ill-typed branch, we won't actually be able to
+       produce a well typed value taking that branch. *)
+    Seq.empty
+  else begin
+    (* Assuming the first column is ill-typed but considered coherent, we
+       might end up producing an ill-typed witness of non-exhaustivity
+       corresponding to the current branch.
+
+       If [exhaust] has been called by [do_check_partial], then the witnesses
+       produced get typechecked and the ill-typed ones are discarded.
+
+       If [exhaust] has been called by [do_check_fragile], then it is possible
+       we might fail to warn the user that the matching is fragile. See for
+       example testsuite/tests/warnings/w04_failure.ml. *)
+    let q0 = discr_pat Patterns.Simple.omega pss in
+    match build_specialized_submatrices ~extend_row:(@) q0 pss with
+    | { default; constrs = [] } ->
+        (* first column of pss is made of variables only *)
+        let sub_witnesses = exhaust ext default (n-1) in
+        let q0 = Patterns.Head.to_omega_pattern q0 in
+        Seq.map (fun row -> q0::row) sub_witnesses
+    | { default; constrs } ->
+        let try_non_omega (p,pss) =
+          if is_absent_pat p then
+            Seq.empty
+          else
+            let sub_witnesses =
+              exhaust
+                ext pss
+                (List.length (simple_match_args p Patterns.Head.omega [])
+                 + n - 1)
+            in
+            let p = Patterns.Head.to_omega_pattern p in
+            Seq.map (set_args p) sub_witnesses
+        in
+        let try_omega () =
+          if full_match false constrs && not (should_extend ext constrs) then
+            Seq.empty
+          else
+            let sub_witnesses = exhaust ext default (n-1) in
+            match build_other ext constrs with
+            | exception Empty ->
+                (* cannot occur, since constructors don't make
+                   a full signature *)
+                fatal_error "Parmatch.exhaust"
+            | p ->
+                Seq.map (fun tail -> p :: tail) sub_witnesses
+        in
+        (* Lazily compute witnesses for all constructor submatrices
+           (Some constr_mat) then the wildcard/default submatrix (None).
+           Note that the call to [try_omega ()] is delayed to after
+           all constructor matrices have been traversed. *)
+        List.map (fun constr_mat -> Some constr_mat) constrs @ [None]
+        |> List.to_seq
+        |> Seq.flat_map
+          (function
+            | Some constr_mat -> try_non_omega constr_mat
+            | None -> try_omega ())
+  end
+
+let exhaust ext pss n =
+  exhaust ext pss n
+  |> Seq.map (function
+     | [x] -> x
+     | _ -> assert false)
+
+(*
+   Another exhaustiveness check, enforcing variant typing.
+   Note that it does not check exact exhaustiveness, but whether a
+   matching could be made exhaustive by closing all variant types.
+   When this is true of all other columns, the current column is left
+   open (even if it means that the whole matching is not exhaustive as
+   a result).
+   When this is false for the matrix minus the current column, and the
+   current column is composed of variant tags, we close the variant
+   (even if it doesn't help in making the matching exhaustive).
+*)
+
+let rec pressure_variants tdefs = function
+  | []    -> false
+  | []::_ -> true
+  | pss   ->
+      let pss = simplify_first_col pss in
+      if not (all_coherent (first_column pss)) then
+        true
+      else begin
+        let q0 = discr_pat Patterns.Simple.omega pss in
+        match build_specialized_submatrices ~extend_row:(@) q0 pss with
+        | { default; constrs = [] } -> pressure_variants tdefs default
+        | { default; constrs } ->
+            let rec try_non_omega = function
+              | (_p,pss) :: rem ->
+                  let ok = pressure_variants tdefs pss in
+                  (* The order below matters : we want [pressure_variants] to be
+                    called on all the specialized submatrices because we might
+                    close some variant in any of them regardless of whether [ok]
+                    is true for [pss] or not *)
+                  try_non_omega rem && ok
+              | [] -> true
+            in
+            if full_match (tdefs=None) constrs then
+              try_non_omega constrs
+            else if tdefs = None then
+              pressure_variants None default
+            else
+              let full = full_match true constrs in
+              let ok =
+                if full then
+                  try_non_omega constrs
+                else begin
+                  let { constrs = partial_constrs; _ } =
+                    build_specialized_submatrices ~extend_row:(@) q0
+                      (mark_partial pss)
+                  in
+                  try_non_omega partial_constrs
+                end
+              in
+              begin match constrs, tdefs with
+              | [], _
+              | _, None -> ()
+              | (d, _) :: _, Some env ->
+                match d.pat_desc with
+                | Variant { type_row; _ } ->
+                  let row = type_row () in
+                  if Btype.row_fixed row
+                  || pressure_variants None default then ()
+                  else close_variant env row
+                | _ -> ()
+              end;
+              ok
+      end
+
+
+(* Yet another satisfiable function *)
+
+(*
+   This time every_satisfiable pss qs checks the
+   utility of every expansion of qs.
+   Expansion means expansion of or-patterns inside qs
+*)
+
+type answer =
+  | Used                                (* Useful pattern *)
+  | Unused                              (* Useless pattern *)
+  | Upartial of Typedtree.pattern list  (* Mixed, with list of useless ones *)
+
+
+
+(* this row type enable column processing inside the matrix
+    - left  ->  elements not to be processed,
+    - right ->  elements to be processed
+*)
+type usefulness_row =
+  {no_ors : pattern list ; ors : pattern list ; active : pattern list}
+
+(*
+let pretty_row {ors=ors ; no_ors=no_ors; active=active} =
+  pretty_line ors ; prerr_string " *" ;
+  pretty_line no_ors ; prerr_string " *" ;
+  pretty_line active
+
+let pretty_rows rs =
+  prerr_endline "begin matrix" ;
+  List.iter
+    (fun r ->
+      pretty_row r ;
+      prerr_endline "")
+    rs ;
+  prerr_endline "end matrix"
+*)
+
+(* Initial build *)
+let make_row ps = {ors=[] ; no_ors=[]; active=ps}
+
+let make_rows pss = List.map make_row pss
+
+
+(* Useful to detect and expand or pats inside as pats *)
+let is_var p = match Patterns.General.(view p |> strip_vars).pat_desc with
+| `Any -> true
+| _    -> false
+
+let is_var_column rs =
+  List.for_all
+    (fun r -> match r.active with
+    | p::_ -> is_var p
+    | []   -> assert false)
+    rs
+
+(* Standard or-args for left-to-right matching *)
+let rec or_args p = match p.pat_desc with
+| Tpat_or (p1,p2,_) -> p1,p2
+| Tpat_alias (p,_,_)  -> or_args p
+| _                 -> assert false
+
+(* Just remove current column *)
+let remove r = match r.active with
+| _::rem -> {r with active=rem}
+| []     -> assert false
+
+let remove_column rs = List.map remove rs
+
+(* Current column has been processed *)
+let push_no_or r = match r.active with
+| p::rem -> { r with no_ors = p::r.no_ors ; active=rem}
+| [] -> assert false
+
+let push_or r = match r.active with
+| p::rem -> { r with ors = p::r.ors ; active=rem}
+| [] -> assert false
+
+let push_or_column rs = List.map push_or rs
+and push_no_or_column rs = List.map push_no_or rs
+
+let rec simplify_first_usefulness_col = function
+  | [] -> []
+  | row :: rows ->
+    match row.active with
+    | [] -> assert false (* the rows are non-empty! *)
+    | p :: ps ->
+      let add_column p ps k =
+        (p, { row with active = ps }) :: k in
+      simplify_head_pat ~add_column p ps
+        (simplify_first_usefulness_col rows)
+
+(* Back to normal matrices *)
+let make_vector r = List.rev r.no_ors
+
+let make_matrix rs = List.map make_vector rs
+
+
+(* Standard union on answers *)
+let union_res r1 r2 = match r1, r2 with
+| (Unused,_)
+| (_, Unused) -> Unused
+| Used,_    -> r2
+| _, Used   -> r1
+| Upartial u1, Upartial u2 -> Upartial (u1@u2)
+
+(* propose or pats for expansion *)
+let extract_elements qs =
+  let rec do_rec seen = function
+    | [] -> []
+    | q::rem ->
+        {no_ors= List.rev_append seen rem @ qs.no_ors ;
+        ors=[] ;
+        active = [q]}::
+        do_rec (q::seen) rem in
+  do_rec [] qs.ors
+
+(* idem for matrices *)
+let transpose rs = match rs with
+| [] -> assert false
+| r::rem ->
+    let i = List.map (fun x -> [x]) r in
+    List.fold_left
+      (List.map2 (fun r x -> x::r))
+      i rem
+
+let extract_columns pss qs = match pss with
+| [] -> List.map (fun _ -> []) qs.ors
+| _  ->
+  let rows = List.map extract_elements pss in
+  transpose rows
+
+(* Core function
+   The idea is to first look for or patterns (recursive case), then
+   check or-patterns argument usefulness (terminal case)
+*)
+
+let rec every_satisfiables pss qs = match qs.active with
+| []     ->
+    (* qs is now partitionned,  check usefulness *)
+    begin match qs.ors with
+    | [] -> (* no or-patterns *)
+        if satisfiable (make_matrix pss) (make_vector qs) then
+          Used
+        else
+          Unused
+    | _  -> (* n or-patterns -> 2n expansions *)
+        List.fold_right2
+          (fun pss qs r -> match r with
+          | Unused -> Unused
+          | _ ->
+              match qs.active with
+              | [q] ->
+                  let q1,q2 = or_args q in
+                  let r_loc = every_both pss qs q1 q2 in
+                  union_res r r_loc
+              | _   -> assert false)
+          (extract_columns pss qs) (extract_elements qs)
+          Used
+    end
+| q::rem ->
+    begin match Patterns.General.(view q |> strip_vars).pat_desc with
+    | `Any ->
+        if is_var_column pss then
+          (* forget about ``all-variable''  columns now *)
+          every_satisfiables (remove_column pss) (remove qs)
+        else
+          (* otherwise this is direct food for satisfiable *)
+          every_satisfiables (push_no_or_column pss) (push_no_or qs)
+    | `Or (q1,q2,_) ->
+        if
+          q1.pat_loc.Location.loc_ghost &&
+          q2.pat_loc.Location.loc_ghost
+        then
+          (* syntactically generated or-pats should not be expanded *)
+          every_satisfiables (push_no_or_column pss) (push_no_or qs)
+        else
+          (* this is a real or-pattern *)
+          every_satisfiables (push_or_column pss) (push_or qs)
+    | `Variant (l,_,r) when is_absent l r -> (* Ah Jacques... *)
+        Unused
+    | #Patterns.Simple.view as view ->
+        let q = { q with pat_desc = view } in
+        (* standard case, filter matrix *)
+        let pss = simplify_first_usefulness_col pss in
+        let hq, args = Patterns.Head.deconstruct q in
+        (* The handling of incoherent matrices is kept in line with
+           [satisfiable] *)
+        if not (all_coherent (hq :: first_column pss)) then
+          Unused
+        else begin
+          let q0 = discr_pat q pss in
+          every_satisfiables
+            (build_specialized_submatrix q0 pss
+              ~extend_row:(fun ps r -> { r with active = ps @ r.active }))
+            {qs with active=simple_match_args q0 hq args @ rem}
+        end
+    end
+
+(*
+  This function ``every_both'' performs the usefulness check
+  of or-pat q1|q2.
+  The trick is to call every_satisfied twice with
+  current active columns restricted to q1 and q2,
+  That way,
+  - others orpats in qs.ors will not get expanded.
+  - all matching work performed on qs.no_ors is not performed again.
+  *)
+and every_both pss qs q1 q2 =
+  let qs1 = {qs with active=[q1]}
+  and qs2 =  {qs with active=[q2]} in
+  let r1 = every_satisfiables pss qs1
+  and r2 =  every_satisfiables (if compat q1 q2 then qs1::pss else pss) qs2 in
+  match r1 with
+  | Unused ->
+      begin match r2 with
+      | Unused -> Unused
+      | Used   -> Upartial [q1]
+      | Upartial u2 -> Upartial (q1::u2)
+      end
+  | Used ->
+      begin match r2 with
+      | Unused -> Upartial [q2]
+      | _      -> r2
+      end
+  | Upartial u1 ->
+      begin match r2 with
+      | Unused -> Upartial (u1@[q2])
+      | Used   -> r1
+      | Upartial u2 -> Upartial (u1 @ u2)
+      end
+
+
+
+
+(* le_pat p q  means, forall V,  V matches q implies V matches p *)
+let rec le_pat p q =
+  match (p.pat_desc, q.pat_desc) with
+  | (Tpat_var _|Tpat_any),_ -> true
+  | Tpat_alias(p,_,_), _ -> le_pat p q
+  | _, Tpat_alias(q,_,_) -> le_pat p q
+  | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0
+  | Tpat_construct(_,c1,ps), Tpat_construct(_,c2,qs) ->
+      Types.equal_tag c1.cstr_tag c2.cstr_tag && le_pats ps qs
+  | Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) ->
+      (l1 = l2 && le_pat p1 p2)
+  | Tpat_variant(l1,None,_r1), Tpat_variant(l2,None,_) ->
+      l1 = l2
+  | Tpat_variant(_,_,_), Tpat_variant(_,_,_) -> false
+  | Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs
+  | Tpat_lazy p, Tpat_lazy q -> le_pat p q
+  | Tpat_record (l1,_), Tpat_record (l2,_) ->
+      let ps,qs = records_args l1 l2 in
+      le_pats ps qs
+  | Tpat_array(ps), Tpat_array(qs) ->
+      List.length ps = List.length qs && le_pats ps qs
+(* In all other cases, enumeration is performed *)
+  | _,_  -> not (satisfiable [[p]] [q])
+
+and le_pats ps qs =
+  match ps,qs with
+    p::ps, q::qs -> le_pat p q && le_pats ps qs
+  | _, _         -> true
+
+let get_mins le ps =
+  let rec select_rec r = function
+      [] -> r
+    | p::ps ->
+        if List.exists (fun p0 -> le p0 p) ps
+        then select_rec r ps
+        else select_rec (p::r) ps in
+  select_rec [] (select_rec [] ps)
+
+(*
+  lub p q is a pattern that matches all values matched by p and q
+  may raise Empty, when p and q are not compatible
+*)
+
+let rec lub p q = match p.pat_desc,q.pat_desc with
+| Tpat_alias (p,_,_),_      -> lub p q
+| _,Tpat_alias (q,_,_)      -> lub p q
+| (Tpat_any|Tpat_var _),_ -> q
+| _,(Tpat_any|Tpat_var _) -> p
+| Tpat_or (p1,p2,_),_     -> orlub p1 p2 q
+| _,Tpat_or (q1,q2,_)     -> orlub q1 q2 p (* Thanks god, lub is commutative *)
+| Tpat_constant c1, Tpat_constant c2 when const_compare c1 c2 = 0 -> p
+| Tpat_tuple ps, Tpat_tuple qs ->
+    let rs = lubs ps qs in
+    make_pat (Tpat_tuple rs) p.pat_type p.pat_env
+| Tpat_lazy p, Tpat_lazy q ->
+    let r = lub p q in
+    make_pat (Tpat_lazy r) p.pat_type p.pat_env
+| Tpat_construct (lid, c1,ps1), Tpat_construct (_,c2,ps2)
+      when  Types.equal_tag c1.cstr_tag c2.cstr_tag  ->
+        let rs = lubs ps1 ps2 in
+        make_pat (Tpat_construct (lid, c1,rs))
+          p.pat_type p.pat_env
+| Tpat_variant(l1,Some p1,row), Tpat_variant(l2,Some p2,_)
+          when  l1=l2 ->
+            let r=lub p1 p2 in
+            make_pat (Tpat_variant (l1,Some r,row)) p.pat_type p.pat_env
+| Tpat_variant (l1,None,_row), Tpat_variant(l2,None,_)
+              when l1 = l2 -> p
+| Tpat_record (l1,closed),Tpat_record (l2,_) ->
+    let rs = record_lubs l1 l2 in
+    make_pat (Tpat_record (rs, closed)) p.pat_type p.pat_env
+| Tpat_array ps, Tpat_array qs
+      when List.length ps = List.length qs ->
+        let rs = lubs ps qs in
+        make_pat (Tpat_array rs) p.pat_type p.pat_env
+| _,_  ->
+    raise Empty
+
+and orlub p1 p2 q =
+  try
+    let r1 = lub p1 q in
+    try
+      {q with pat_desc=(Tpat_or (r1,lub p2 q,None))}
+  with
+  | Empty -> r1
+with
+| Empty -> lub p2 q
+
+and record_lubs l1 l2 =
+  let rec lub_rec l1 l2 = match l1,l2 with
+  | [],_ -> l2
+  | _,[] -> l1
+  | (lid1, lbl1,p1)::rem1, (lid2, lbl2,p2)::rem2 ->
+      if lbl1.lbl_pos < lbl2.lbl_pos then
+        (lid1, lbl1,p1)::lub_rec rem1 l2
+      else if lbl2.lbl_pos < lbl1.lbl_pos  then
+        (lid2, lbl2,p2)::lub_rec l1 rem2
+      else
+        (lid1, lbl1,lub p1 p2)::lub_rec rem1 rem2 in
+  lub_rec l1 l2
+
+and lubs ps qs = match ps,qs with
+| p::ps, q::qs -> lub p q :: lubs ps qs
+| _,_ -> []
+
+
+(******************************)
+(* Exported variant closing   *)
+(******************************)
+
+(* Apply pressure to variants *)
+
+let pressure_variants tdefs patl =
+  ignore (pressure_variants
+            (Some tdefs)
+            (List.map (fun p -> [p; omega]) patl))
+
+let pressure_variants_in_computation_pattern tdefs patl =
+  let add_row pss p_opt =
+    match p_opt with
+    | None -> pss
+    | Some p -> p :: pss
+  in
+  let val_pss, exn_pss =
+    List.fold_right (fun pat (vpss, epss)->
+      let (vp, ep) = split_pattern pat in
+      add_row vpss vp, add_row epss ep
+    ) patl ([], [])
+  in
+  pressure_variants tdefs val_pss;
+  pressure_variants tdefs exn_pss
+
+(*****************************)
+(* Utilities for diagnostics *)
+(*****************************)
+
+(*
+  Build up a working pattern matrix by forgetting
+  about guarded patterns
+*)
+
+let rec initial_matrix = function
+    [] -> []
+  | {c_guard=Some _} :: rem -> initial_matrix rem
+  | {c_guard=None; c_lhs=p} :: rem -> [p] :: initial_matrix rem
+
+(*
+   Build up a working pattern matrix by keeping
+   only the patterns which are guarded
+*)
+let rec initial_only_guarded = function
+  | [] -> []
+  | { c_guard = None; _} :: rem ->
+      initial_only_guarded rem
+  | { c_lhs = pat; _ } :: rem ->
+      [pat] :: initial_only_guarded rem
+
+
+(************************)
+(* Exhaustiveness check *)
+(************************)
+
+(* conversion from Typedtree.pattern to Parsetree.pattern list *)
+module Conv = struct
+  open Parsetree
+  let mkpat desc = Ast_helper.Pat.mk desc
+
+  let name_counter = ref 0
+  let fresh name =
+    let current = !name_counter in
+    name_counter := !name_counter + 1;
+    "#$" ^ name ^ Int.to_string current
+
+  let conv typed =
+    let constrs = Hashtbl.create 7 in
+    let labels = Hashtbl.create 7 in
+    let rec loop pat =
+      match pat.pat_desc with
+        Tpat_or (pa,pb,_) ->
+          mkpat (Ppat_or (loop pa, loop pb))
+      | Tpat_var (_, ({txt="*extension*"} as nm)) -> (* PR#7330 *)
+          mkpat (Ppat_var nm)
+      | Tpat_any
+      | Tpat_var _ ->
+          mkpat Ppat_any
+      | Tpat_constant c ->
+          mkpat (Ppat_constant (Untypeast.constant c))
+      | Tpat_alias (p,_,_) -> loop p
+      | Tpat_tuple lst ->
+          mkpat (Ppat_tuple (List.map loop lst))
+      | Tpat_construct (cstr_lid, cstr, lst) ->
+          let id = fresh cstr.cstr_name in
+          let lid = { cstr_lid with txt = Longident.Lident id } in
+          Hashtbl.add constrs id cstr;
+          let arg =
+            match List.map loop lst with
+            | []  -> None
+            | [p] -> Some p
+            | lst -> Some (mkpat (Ppat_tuple lst))
+          in
+          mkpat (Ppat_construct(lid, arg))
+      | Tpat_variant(label,p_opt,_row_desc) ->
+          let arg = Option.map loop p_opt in
+          mkpat (Ppat_variant(label, arg))
+      | Tpat_record (subpatterns, _closed_flag) ->
+          let fields =
+            List.map
+              (fun (_, lbl, p) ->
+                let id = fresh lbl.lbl_name in
+                Hashtbl.add labels id lbl;
+                (mknoloc (Longident.Lident id), loop p))
+              subpatterns
+          in
+          mkpat (Ppat_record (fields, Open))
+      | Tpat_array lst ->
+          mkpat (Ppat_array (List.map loop lst))
+      | Tpat_lazy p ->
+          mkpat (Ppat_lazy (loop p))
+    in
+    let ps = loop typed in
+    (ps, constrs, labels)
+end
+
+
+(* Whether the counter-example contains an extension pattern *)
+let contains_extension pat =
+  exists_pattern
+    (function
+     | {pat_desc=Tpat_var (_, {txt="*extension*"})} -> true
+     | _ -> false)
+    pat
+
+(* Build a pattern from its expected type *)
+type pat_explosion = PE_single | PE_gadt_cases
+type ppat_of_type =
+  | PT_empty
+  | PT_any
+  | PT_pattern of
+      pat_explosion *
+      Parsetree.pattern *
+      (string, constructor_description) Hashtbl.t *
+      (string, label_description) Hashtbl.t
+
+let ppat_of_type env ty =
+  match pats_of_type env ty with
+  | [] -> PT_empty
+  | [{pat_desc = Tpat_any}] -> PT_any
+  | [pat] ->
+      let (ppat, constrs, labels) = Conv.conv pat in
+      PT_pattern (PE_single, ppat, constrs, labels)
+  | pats ->
+      let (ppat, constrs, labels) = Conv.conv (orify_many pats) in
+      PT_pattern (PE_gadt_cases, ppat, constrs, labels)
+
+let typecheck ~pred p =
+  let (pattern,constrs,labels) = Conv.conv p in
+  pred constrs labels pattern
+
+let do_check_partial ~pred loc casel pss = match pss with
+| [] ->
+        (*
+          This can occur
+          - For empty matches generated by ocamlp4 (no warning)
+          - when all patterns have guards (then, casel <> [])
+          (specific warning)
+          Then match MUST be considered non-exhaustive,
+          otherwise compilation of PM is broken.
+          *)
+    begin match casel with
+    | [] -> ()
+    | _  ->
+      if Warnings.is_active Warnings.All_clauses_guarded then
+        Location.prerr_warning loc Warnings.All_clauses_guarded
+    end ;
+    Partial
+| ps::_  ->
+    let counter_examples =
+      exhaust None pss (List.length ps)
+      |> Seq.filter_map (typecheck ~pred) in
+    match counter_examples () with
+    | Seq.Nil -> Total
+    | Seq.Cons (v, _rest) ->
+      if Warnings.is_active (Warnings.Partial_match "") then begin
+        let errmsg =
+          try
+            let buf = Buffer.create 16 in
+            let fmt = Format.formatter_of_buffer buf in
+            Printpat.top_pretty fmt v;
+            if do_match (initial_only_guarded casel) [v] then
+              Buffer.add_string buf
+                "\n(However, some guarded clause may match this value.)";
+            if contains_extension v then
+              Buffer.add_string buf
+                "\nMatching over values of extensible variant types \
+                   (the *extension* above)\n\
+              must include a wild card pattern in order to be exhaustive."
+            ;
+            Buffer.contents buf
+          with _ ->
+            ""
+        in
+        Location.prerr_warning loc (Warnings.Partial_match errmsg)
+      end;
+      Partial
+
+(*****************)
+(* Fragile check *)
+(*****************)
+
+(* Collect all data types in a pattern *)
+
+let rec add_path path = function
+  | [] -> [path]
+  | x::rem as paths ->
+      if Path.same path x then paths
+      else x::add_path path rem
+
+let extendable_path path =
+  not
+    (Path.same path Predef.path_bool ||
+    Path.same path Predef.path_list ||
+    Path.same path Predef.path_unit ||
+    Path.same path Predef.path_option)
+
+let rec collect_paths_from_pat r p = match p.pat_desc with
+| Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)},ps)
+  ->
+    let path = get_constructor_type_path p.pat_type p.pat_env in
+    List.fold_left
+      collect_paths_from_pat
+      (if extendable_path path then add_path path r else r)
+      ps
+| Tpat_any|Tpat_var _|Tpat_constant _| Tpat_variant (_,None,_) -> r
+| Tpat_tuple ps | Tpat_array ps
+| Tpat_construct (_, {cstr_tag=Cstr_extension _}, ps)->
+    List.fold_left collect_paths_from_pat r ps
+| Tpat_record (lps,_) ->
+    List.fold_left
+      (fun r (_, _, p) -> collect_paths_from_pat r p)
+      r lps
+| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_) -> collect_paths_from_pat r p
+| Tpat_or (p1,p2,_) ->
+    collect_paths_from_pat (collect_paths_from_pat r p1) p2
+| Tpat_lazy p
+    ->
+    collect_paths_from_pat r p
+
+
+(*
+  Actual fragile check
+   1. Collect data types in the patterns of the match.
+   2. One exhaustivity check per datatype, considering that
+      the type is extended.
+*)
+
+let do_check_fragile loc casel pss =
+  let exts =
+    List.fold_left
+      (fun r c -> collect_paths_from_pat r c.c_lhs)
+      [] casel in
+  match exts with
+  | [] -> ()
+  | _ -> match pss with
+    | [] -> ()
+    | ps::_ ->
+        List.iter
+          (fun ext ->
+            let witnesses = exhaust (Some ext) pss (List.length ps) in
+            match witnesses () with
+            | Seq.Nil ->
+                Location.prerr_warning
+                  loc
+                  (Warnings.Fragile_match (Path.name ext))
+            | Seq.Cons _ -> ())
+          exts
+
+(********************************)
+(* Exported unused clause check *)
+(********************************)
+
+let check_unused pred casel =
+  if Warnings.is_active Warnings.Redundant_case
+  || List.exists (fun c -> c.c_rhs.exp_desc = Texp_unreachable) casel then
+    let rec do_rec pref = function
+      | [] -> ()
+      | {c_lhs=q; c_guard; c_rhs} :: rem ->
+          let qs = [q] in
+            begin try
+              let pss =
+                (* prev was accumulated in reverse order;
+                   restore source order to get ordered counter-examples *)
+                List.rev pref
+                |> List.filter (compats qs)
+                |> get_mins le_pats in
+              (* First look for redundant or partially redundant patterns *)
+              let r = every_satisfiables (make_rows pss) (make_row qs) in
+              let refute = (c_rhs.exp_desc = Texp_unreachable) in
+              (* Do not warn for unused [pat -> .] *)
+              if r = Unused && refute then () else
+              let r =
+                (* Do not refine if either:
+                   - we already know the clause is unused
+                   - the clause under consideration is not a refutation clause
+                     and either:
+                     + there are no other lines
+                     + we do not care whether the types prevent this clause to
+                       be reached.
+                     If the clause under consideration *is* a refutation clause
+                     then we do need to check more carefully whether it can be
+                     refuted or not.  *)
+                let skip =
+                  r = Unused || (not refute && pref = []) ||
+                  not(refute || Warnings.is_active Warnings.Unreachable_case) in
+                if skip then r else
+                (* Then look for empty patterns *)
+                let sfs = list_satisfying_vectors pss qs in
+                if sfs = [] then Unused else
+                let sfs =
+                  List.map (function [u] -> u | _ -> assert false) sfs in
+                let u = orify_many sfs in
+                (*Format.eprintf "%a@." pretty_val u;*)
+                let (pattern,constrs,labels) = Conv.conv u in
+                let pattern = {pattern with Parsetree.ppat_loc = q.pat_loc} in
+                match pred refute constrs labels pattern with
+                  None when not refute ->
+                    Location.prerr_warning q.pat_loc Warnings.Unreachable_case;
+                    Used
+                | _ -> r
+              in
+              match r with
+              | Unused ->
+                  Location.prerr_warning
+                    q.pat_loc Warnings.Redundant_case
+              | Upartial ps ->
+                  List.iter
+                    (fun p ->
+                      Location.prerr_warning
+                        p.pat_loc Warnings.Redundant_subpat)
+                    ps
+              | Used -> ()
+            with Empty | Not_found -> assert false
+            end ;
+
+          if c_guard <> None then
+            do_rec pref rem
+          else
+            do_rec ([q]::pref) rem in
+
+    do_rec [] casel
+
+(*********************************)
+(* Exported irrefutability tests *)
+(*********************************)
+
+let irrefutable pat = le_pat pat omega
+
+let inactive ~partial pat =
+  match partial with
+  | Partial -> false
+  | Total -> begin
+      let rec loop pat =
+        match pat.pat_desc with
+        | Tpat_lazy _ | Tpat_array _ ->
+          false
+        | Tpat_any | Tpat_var _ | Tpat_variant (_, None, _) ->
+            true
+        | Tpat_constant c -> begin
+            match c with
+            | Const_string _ -> Config.safe_string
+            | Const_int _ | Const_char _ | Const_float _
+            | Const_int32 _ | Const_int64 _ | Const_nativeint _ -> true
+          end
+        | Tpat_tuple ps | Tpat_construct (_, _, ps) ->
+            List.for_all (fun p -> loop p) ps
+        | Tpat_alias (p,_,_) | Tpat_variant (_, Some p, _) ->
+            loop p
+        | Tpat_record (ldps,_) ->
+            List.for_all
+              (fun (_, lbl, p) -> lbl.lbl_mut = Immutable && loop p)
+              ldps
+        | Tpat_or (p,q,_) ->
+            loop p && loop q
+      in
+      loop pat
+  end
+
+
+
+
+
+
+
+(*********************************)
+(* Exported exhaustiveness check *)
+(*********************************)
+
+(*
+   Fragile check is performed when required and
+   on exhaustive matches only.
+*)
+
+let check_partial pred loc casel =
+  let pss = initial_matrix casel in
+  let pss = get_mins le_pats pss in
+  let total = do_check_partial ~pred loc casel pss in
+  if
+    total = Total && Warnings.is_active (Warnings.Fragile_match "")
+  then begin
+    do_check_fragile loc casel pss
+  end ;
+  total
+
+(*************************************)
+(* Ambiguous variable in or-patterns *)
+(*************************************)
+
+(* Specification: ambiguous variables in or-patterns.
+
+   The semantics of or-patterns in OCaml is specified with
+   a left-to-right bias: a value [v] matches the pattern [p | q] if it
+   matches [p] or [q], but if it matches both, the environment
+   captured by the match is the environment captured by [p], never the
+   one captured by [q].
+
+   While this property is generally well-understood, one specific case
+   where users expect a different semantics is when a pattern is
+   followed by a when-guard: [| p when g -> e]. Consider for example:
+
+     | ((Const x, _) | (_, Const x)) when is_neutral x -> branch
+
+   The semantics is clear: match the scrutinee against the pattern, if
+   it matches, test the guard, and if the guard passes, take the
+   branch.
+
+   However, consider the input [(Const a, Const b)], where [a] fails
+   the test [is_neutral f], while [b] passes the test [is_neutral
+   b]. With the left-to-right semantics, the clause above is *not*
+   taken by its input: matching [(Const a, Const b)] against the
+   or-pattern succeeds in the left branch, it returns the environment
+   [x -> a], and then the guard [is_neutral a] is tested and fails,
+   the branch is not taken. Most users, however, intuitively expect
+   that any pair that has one side passing the test will take the
+   branch. They assume it is equivalent to the following:
+
+     | (Const x, _) when is_neutral x -> branch
+     | (_, Const x) when is_neutral x -> branch
+
+   while it is not.
+
+   The code below is dedicated to finding these confusing cases: the
+   cases where a guard uses "ambiguous" variables, that are bound to
+   different parts of the scrutinees by different sides of
+   a or-pattern. In other words, it finds the cases where the
+   specified left-to-right semantics is not equivalent to
+   a non-deterministic semantics (any branch can be taken) relatively
+   to a specific guard.
+*)
+
+let pattern_vars p = Ident.Set.of_list (Typedtree.pat_bound_idents p)
+
+(* Row for ambiguous variable search,
+   row is the traditional pattern row,
+   varsets contain a list of head variable sets (varsets)
+
+   A given varset contains all the variables that appeared at the head
+   of a pattern in the row at some point during traversal: they would
+   all be bound to the same value at matching time. On the contrary,
+   two variables of different varsets appeared at different places in
+   the pattern and may be bound to distinct sub-parts of the matched
+   value.
+
+   All rows of a (sub)matrix have rows of the same length,
+   but also varsets of the same length.
+
+   Varsets are populated when simplifying the first column
+   -- the variables of the head pattern are collected in a new varset.
+   For example,
+     { row = x :: r1; varsets = s1 }
+     { row = (Some _) as y :: r2; varsets  = s2 }
+     { row = (None as x) as y :: r3; varsets = s3 }
+     { row = (Some x | (None as x)) :: r4 with varsets = s4 }
+   becomes
+     (_, { row = r1; varsets = {x} :: s1 })
+     (Some _, { row = r2; varsets = {y} :: s2 })
+     (None, { row = r3; varsets = {x, y} :: s3 })
+     (Some x, { row = r4; varsets = {} :: s4 })
+     (None, { row = r4; varsets = {x} :: s4 })
+*)
+type amb_row = { row : pattern list ; varsets : Ident.Set.t list; }
+
+let simplify_head_amb_pat head_bound_variables varsets ~add_column p ps k =
+  let rec simpl head_bound_variables varsets p ps k =
+    match (Patterns.General.view p).pat_desc with
+    | `Alias (p,x,_) ->
+      simpl (Ident.Set.add x head_bound_variables) varsets p ps k
+    | `Var (x, _) ->
+      simpl (Ident.Set.add x head_bound_variables) varsets Patterns.omega ps k
+    | `Or (p1,p2,_) ->
+      simpl head_bound_variables varsets p1 ps
+        (simpl head_bound_variables varsets p2 ps k)
+    | #Patterns.Simple.view as view ->
+      add_column (Patterns.Head.deconstruct { p with pat_desc = view })
+        { row = ps; varsets = head_bound_variables :: varsets; } k
+  in simpl head_bound_variables varsets p ps k
+
+(*
+   To accurately report ambiguous variables, one must consider
+   that previous clauses have already matched some values.
+   Consider for example:
+
+     | (Foo x, Foo y) -> ...
+     | ((Foo x, _) | (_, Foo x)) when bar x -> ...
+
+   The second line taken in isolation uses an unstable variable,
+   but the discriminating values, of the shape [(Foo v1, Foo v2)],
+   would all be filtered by the line above.
+
+   To track this information, the matrices we analyze contain both
+   *positive* rows, that describe the rows currently being analyzed
+   (of type Varsets.row, so that their varsets are tracked) and
+   *negative rows*, that describe the cases already matched against.
+
+   The values matched by a signed matrix are the values matched by
+   some of the positive rows but none of the negative rows. In
+   particular, a variable is stable if, for any value not matched by
+   any of the negative rows, the environment captured by any of the
+   matching positive rows is identical.
+*)
+type ('a, 'b) signed = Positive of 'a | Negative of 'b
+
+let rec simplify_first_amb_col = function
+  | [] -> []
+  | (Negative [] | Positive { row = []; _ }) :: _  -> assert false
+  | Negative (n :: ns) :: rem ->
+      let add_column n ns k = (n, Negative ns) :: k in
+      simplify_head_pat
+        ~add_column n ns (simplify_first_amb_col rem)
+  | Positive { row = p::ps; varsets; }::rem ->
+      let add_column p ps k = (p, Positive ps) :: k in
+      simplify_head_amb_pat
+        Ident.Set.empty varsets
+        ~add_column p ps (simplify_first_amb_col rem)
+
+(* Compute stable bindings *)
+
+type stable_vars =
+  | All
+  | Vars of Ident.Set.t
+
+let stable_inter sv1 sv2 = match sv1, sv2 with
+  | All, sv | sv, All -> sv
+  | Vars s1, Vars s2 -> Vars (Ident.Set.inter s1 s2)
+
+let reduce f = function
+| [] -> invalid_arg "reduce"
+| x::xs -> List.fold_left f x xs
+
+let rec matrix_stable_vars m = match m with
+  | [] -> All
+  | ((Positive {row = []; _} | Negative []) :: _) as empty_rows ->
+      let exception Negative_empty_row in
+      (* if at least one empty row is negative, the matrix matches no value *)
+      let get_varsets = function
+        | Negative n ->
+            (* All rows have the same number of columns;
+               if the first row is empty, they all are. *)
+            assert (n = []);
+            raise Negative_empty_row
+        | Positive p ->
+            assert (p.row = []);
+            p.varsets in
+      begin match List.map get_varsets empty_rows with
+      | exception Negative_empty_row -> All
+      | rows_varsets ->
+          let stables_in_varsets =
+            reduce (List.map2 Ident.Set.inter) rows_varsets in
+          (* The stable variables are those stable at any position *)
+          Vars
+            (List.fold_left Ident.Set.union Ident.Set.empty stables_in_varsets)
+      end
+  | m ->
+      let is_negative = function
+        | Negative _ -> true
+        | Positive _ -> false in
+      if List.for_all is_negative m then
+        (* optimization: quit early if there are no positive rows.
+           This may happen often when the initial matrix has many
+           negative cases and few positive cases (a small guarded
+           clause after a long list of clauses) *)
+        All
+      else begin
+        let m = simplify_first_amb_col m in
+        if not (all_coherent (first_column m)) then
+          All
+        else begin
+          (* If the column is ill-typed but deemed coherent, we might
+             spuriously warn about some variables being unstable.
+             As sad as that might be, the warning can be silenced by
+             splitting the or-pattern...  *)
+          let submatrices =
+            let extend_row columns = function
+              | Negative r -> Negative (columns @ r)
+              | Positive r -> Positive { r with row = columns @ r.row } in
+            let q0 = discr_pat Patterns.Simple.omega m in
+            let { default; constrs } =
+              build_specialized_submatrices ~extend_row q0 m in
+            let non_default = List.map snd constrs in
+            if full_match false constrs
+            then non_default
+            else default :: non_default in
+          (* A stable variable must be stable in each submatrix. *)
+          let submat_stable = List.map matrix_stable_vars submatrices in
+          List.fold_left stable_inter All submat_stable
+        end
+      end
+
+let pattern_stable_vars ns p =
+  matrix_stable_vars
+    (List.fold_left (fun m n -> Negative n :: m)
+       [Positive {varsets = []; row = [p]}] ns)
+
+(* All identifier paths that appear in an expression that occurs
+   as a clause right hand side or guard.
+
+  The function is rather complex due to the compilation of
+  unpack patterns by introducing code in rhs expressions
+  and **guards**.
+
+  For pattern (module M:S)  -> e the code is
+  let module M_mod = unpack M .. in e
+
+  Hence M is "free" in e iff M_mod is free in e.
+
+  Not doing so will yield excessive  warning in
+  (module (M:S) } ...) when true -> ....
+  as M is always present in
+  let module M_mod = unpack M .. in true
+*)
+
+let all_rhs_idents exp =
+  let ids = ref Ident.Set.empty in
+(* Very hackish, detect unpack pattern  compilation
+   and perform "indirect check for them" *)
+  let is_unpack exp =
+      List.exists
+        (fun attr -> attr.Parsetree.attr_name.txt = "#modulepat")
+        exp.exp_attributes in
+  let open Tast_iterator in
+  let expr_iter iter exp =
+    (match exp.exp_desc with
+      | Texp_ident (path, _lid, _descr) ->
+        List.iter (fun id -> ids := Ident.Set.add id !ids) (Path.heads path)
+      (* Use default iterator methods for rest of match.*)
+      | _ -> Tast_iterator.default_iterator.expr iter exp);
+
+    if is_unpack exp then begin match exp.exp_desc with
+    | Texp_letmodule
+        (id_mod,_,_,
+         {mod_desc=
+          Tmod_unpack ({exp_desc=Texp_ident (Path.Pident id_exp,_,_)},_)},
+         _) ->
+           assert (Ident.Set.mem id_exp !ids) ;
+           begin match id_mod with
+           | Some id_mod when not (Ident.Set.mem id_mod !ids) ->
+             ids := Ident.Set.remove id_exp !ids
+           | _ -> ()
+           end
+    | _ -> assert false
+    end
+  in
+  let iterator = {Tast_iterator.default_iterator with expr = expr_iter} in
+  iterator.expr iterator exp;
+  !ids
+
+let check_ambiguous_bindings =
+  let open Warnings in
+  let warn0 = Ambiguous_var_in_pattern_guard [] in
+  fun cases ->
+    if is_active warn0 then
+      let check_case ns case = match case with
+        | { c_lhs = p; c_guard=None ; _} -> [p]::ns
+        | { c_lhs=p; c_guard=Some g; _} ->
+            let all =
+              Ident.Set.inter (pattern_vars p) (all_rhs_idents g) in
+            if not (Ident.Set.is_empty all) then begin
+              match pattern_stable_vars ns p with
+              | All -> ()
+              | Vars stable ->
+                  let ambiguous = Ident.Set.diff all stable in
+                  if not (Ident.Set.is_empty ambiguous) then begin
+                    let pps =
+                      Ident.Set.elements ambiguous |> List.map Ident.name in
+                    let warn = Ambiguous_var_in_pattern_guard pps in
+                    Location.prerr_warning p.pat_loc warn
+                  end
+            end;
+            ns
+      in
+      ignore (List.fold_left check_case [] cases)
diff --git a/upstream/ocaml_412/typing/parmatch.mli b/upstream/ocaml_412/typing/parmatch.mli
new file mode 100644
index 0000000..8736ed2
--- /dev/null
+++ b/upstream/ocaml_412/typing/parmatch.mli
@@ -0,0 +1,134 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Detection of partial matches and unused match cases. *)
+
+open Asttypes
+open Typedtree
+open Types
+
+val const_compare : constant -> constant -> int
+(** [const_compare c1 c2] compares the actual values represented by [c1] and
+    [c2], while simply using [Stdlib.compare] would compare the
+    representations.
+
+    cf. MPR#5758 *)
+
+val le_pat : pattern -> pattern -> bool
+(** [le_pat p q]  means: forall V,  V matches q implies V matches p *)
+
+val le_pats : pattern list -> pattern list -> bool
+(** [le_pats (p1 .. pm) (q1 .. qn)] means: forall i <= m, [le_pat pi qi] *)
+
+(** Exported compatibility functor, abstracted over constructor equality *)
+module Compat :
+  functor
+    (_ : sig
+      val equal :
+          Types.constructor_description ->
+            Types.constructor_description ->
+              bool
+     end) -> sig
+       val compat : pattern -> pattern -> bool
+       val compats : pattern list -> pattern list -> bool
+     end
+
+exception Empty
+
+val lub : pattern -> pattern -> pattern
+(** [lub p q] is a pattern that matches all values matched by [p] and [q].
+    May raise [Empty], when [p] and [q] are not compatible. *)
+
+val lubs : pattern list -> pattern list -> pattern list
+(** [lubs [p1; ...; pn] [q1; ...; qk]], where [n < k], is
+    [[lub p1 q1; ...; lub pk qk]].  *)
+
+val get_mins : ('a -> 'a -> bool) -> 'a list -> 'a list
+
+(** Those two functions recombine one pattern and its arguments:
+    For instance:
+      (_,_)::p1::p2::rem -> (p1, p2)::rem
+    The second one will replace mutable arguments by '_'
+*)
+val set_args : pattern -> pattern list -> pattern list
+val set_args_erase_mutable : pattern -> pattern list -> pattern list
+
+val pat_of_constr : pattern -> constructor_description -> pattern
+val complete_constrs :
+    constructor_description pattern_data ->
+    constructor_tag list ->
+    constructor_description list
+
+(** [ppat_of_type] builds an untyped pattern from its expected type,
+    for explosion of wildcard patterns in Typecore.type_pat.
+
+    There are four interesting cases:
+    - the type is empty ([PT_empty])
+    - no further explosion is necessary ([PT_any])
+    - a single pattern is generated, from a record or tuple type
+      or a single-variant type ([PE_single])
+    - an or-pattern is generated, in the case that all branches
+      are GADT constructors ([PE_gadt_cases]).
+ *)
+type pat_explosion = PE_single | PE_gadt_cases
+type ppat_of_type =
+  | PT_empty
+  | PT_any
+  | PT_pattern of
+      pat_explosion *
+      Parsetree.pattern *
+      (string, constructor_description) Hashtbl.t *
+      (string, label_description) Hashtbl.t
+
+val ppat_of_type: Env.t -> type_expr -> ppat_of_type
+
+val pressure_variants:
+  Env.t -> pattern list -> unit
+val pressure_variants_in_computation_pattern:
+  Env.t -> computation general_pattern list -> unit
+
+(** [check_partial pred loc caselist] and [check_unused refute pred caselist]
+    are called with a function [pred] which will be given counter-example
+    candidates: they may be partially ill-typed, and have to be type-checked
+    to extract a valid counter-example.
+    [pred] returns a valid counter-example or [None].
+    [refute] indicates that [check_unused] was called on a refutation clause.
+ *)
+val check_partial:
+    ((string, constructor_description) Hashtbl.t ->
+     (string, label_description) Hashtbl.t ->
+     Parsetree.pattern -> pattern option) ->
+    Location.t -> value case list -> partial
+val check_unused:
+    (bool ->
+     (string, constructor_description) Hashtbl.t ->
+     (string, label_description) Hashtbl.t ->
+     Parsetree.pattern -> pattern option) ->
+    value case list -> unit
+
+(* Irrefutability tests *)
+val irrefutable : pattern -> bool
+
+(** An inactive pattern is a pattern, matching against which can be duplicated,
+    erased or delayed without change in observable behavior of the program.
+    Patterns containing (lazy _) subpatterns or reads of mutable fields are
+    active. *)
+val inactive : partial:partial -> pattern -> bool
+
+(* Ambiguous bindings *)
+val check_ambiguous_bindings : value case list -> unit
+
+(* The tag used for open polymorphic variant types with an abstract row *)
+val some_private_tag : label
diff --git a/upstream/ocaml_412/typing/path.ml b/upstream/ocaml_412/typing/path.ml
new file mode 100644
index 0000000..e5a8d7e
--- /dev/null
+++ b/upstream/ocaml_412/typing/path.ml
@@ -0,0 +1,129 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t =
+    Pident of Ident.t
+  | Pdot of t * string
+  | Papply of t * t
+
+let rec same p1 p2 =
+  p1 == p2
+  || match (p1, p2) with
+    (Pident id1, Pident id2) -> Ident.same id1 id2
+  | (Pdot(p1, s1), Pdot(p2, s2)) -> s1 = s2 && same p1 p2
+  | (Papply(fun1, arg1), Papply(fun2, arg2)) ->
+       same fun1 fun2 && same arg1 arg2
+  | (_, _) -> false
+
+let rec compare p1 p2 =
+  if p1 == p2 then 0
+  else match (p1, p2) with
+    (Pident id1, Pident id2) -> Ident.compare id1 id2
+  | (Pdot(p1, s1), Pdot(p2, s2)) ->
+      let h = compare p1 p2 in
+      if h <> 0 then h else String.compare s1 s2
+  | (Papply(fun1, arg1), Papply(fun2, arg2)) ->
+      let h = compare fun1 fun2 in
+      if h <> 0 then h else compare arg1 arg2
+  | ((Pident _ | Pdot _), (Pdot _ | Papply _)) -> -1
+  | ((Pdot _ | Papply _), (Pident _ | Pdot _)) -> 1
+
+let rec find_free_opt ids = function
+    Pident id -> List.find_opt (Ident.same id) ids
+  | Pdot(p, _s) -> find_free_opt ids p
+  | Papply(p1, p2) ->
+      match find_free_opt ids p1 with
+      | None -> find_free_opt ids p2
+      | Some _ as res -> res
+
+let exists_free ids p =
+  match find_free_opt ids p with
+  | None -> false
+  | _ -> true
+
+let rec scope = function
+    Pident id -> Ident.scope id
+  | Pdot(p, _s) -> scope p
+  | Papply(p1, p2) -> max (scope p1) (scope p2)
+
+let kfalse _ = false
+
+let rec name ?(paren=kfalse) = function
+    Pident id -> Ident.name id
+  | Pdot(p, s) ->
+      name ~paren p ^ if paren s then ".( " ^ s ^ " )" else "." ^ s
+  | Papply(p1, p2) -> name ~paren p1 ^ "(" ^ name ~paren p2 ^ ")"
+
+let rec print ppf = function
+  | Pident id -> Ident.print_with_scope ppf id
+  | Pdot(p, s) -> Format.fprintf ppf "%a.%s" print p s
+  | Papply(p1, p2) -> Format.fprintf ppf "%a(%a)" print p1 print p2
+
+let rec head = function
+    Pident id -> id
+  | Pdot(p, _s) -> head p
+  | Papply _ -> assert false
+
+let flatten =
+  let rec flatten acc = function
+    | Pident id -> `Ok (id, acc)
+    | Pdot (p, s) -> flatten (s :: acc) p
+    | Papply _ -> `Contains_apply
+  in
+  fun t -> flatten [] t
+
+let heads p =
+  let rec heads p acc = match p with
+    | Pident id -> id :: acc
+    | Pdot (p, _s) -> heads p acc
+    | Papply(p1, p2) ->
+        heads p1 (heads p2 acc)
+  in heads p []
+
+let rec last = function
+  | Pident id -> Ident.name id
+  | Pdot(_, s) -> s
+  | Papply(_, p) -> last p
+
+let is_uident s =
+  assert (s <> "");
+  match s.[0] with
+  | 'A'..'Z' -> true
+  | _ -> false
+
+type typath =
+  | Regular of t
+  | Ext of t * string
+  | LocalExt of Ident.t
+  | Cstr of t * string
+
+let constructor_typath = function
+  | Pident id when is_uident (Ident.name id) -> LocalExt id
+  | Pdot(ty_path, s) when is_uident s ->
+      if is_uident (last ty_path) then Ext (ty_path, s)
+      else Cstr (ty_path, s)
+  | p -> Regular p
+
+let is_constructor_typath p =
+  match constructor_typath p with
+  | Regular _ -> false
+  | _ -> true
+
+module T = struct
+  type nonrec t = t
+  let compare = compare
+end
+module Set = Set.Make(T)
+module Map = Map.Make(T)
diff --git a/upstream/ocaml_412/typing/path.mli b/upstream/ocaml_412/typing/path.mli
new file mode 100644
index 0000000..bddf9d6
--- /dev/null
+++ b/upstream/ocaml_412/typing/path.mli
@@ -0,0 +1,52 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Access paths *)
+
+type t =
+    Pident of Ident.t
+  | Pdot of t * string
+  | Papply of t * t
+
+val same: t -> t -> bool
+val compare: t -> t -> int
+val find_free_opt: Ident.t list -> t -> Ident.t option
+val exists_free: Ident.t list -> t -> bool
+val scope: t -> int
+val flatten : t -> [ `Contains_apply | `Ok of Ident.t * string list ]
+
+val name: ?paren:(string -> bool) -> t -> string
+    (* [paren] tells whether a path suffix needs parentheses *)
+val head: t -> Ident.t
+
+val print: Format.formatter -> t -> unit
+
+val heads: t -> Ident.t list
+
+val last: t -> string
+
+val is_uident: string -> bool
+
+type typath =
+  | Regular of t
+  | Ext of t * string
+  | LocalExt of Ident.t
+  | Cstr of t * string
+
+val constructor_typath: t -> typath
+val is_constructor_typath: t -> bool
+
+module Map : Map.S with type key = t
+module Set : Set.S with type elt = t
diff --git a/upstream/ocaml_412/typing/patterns.ml b/upstream/ocaml_412/typing/patterns.ml
new file mode 100644
index 0000000..a67ac9d
--- /dev/null
+++ b/upstream/ocaml_412/typing/patterns.ml
@@ -0,0 +1,254 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Gabriel Scherer, projet Partout, INRIA Paris-Saclay           *)
+(*          Thomas Refis, Jane Street Europe                              *)
+(*                                                                        *)
+(*   Copyright 2019 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Types
+open Typedtree
+
+(* useful pattern auxiliary functions *)
+
+let omega = {
+  pat_desc = Tpat_any;
+  pat_loc = Location.none;
+  pat_extra = [];
+  pat_type = Ctype.none;
+  pat_env = Env.empty;
+  pat_attributes = [];
+}
+
+let rec omegas i =
+  if i <= 0 then [] else omega :: omegas (i-1)
+
+let omega_list l = List.map (fun _ -> omega) l
+
+module Non_empty_row = struct
+  type 'a t = 'a * Typedtree.pattern list
+
+  let of_initial = function
+    | [] -> assert false
+    | pat :: patl -> (pat, patl)
+
+  let map_first f (p, patl) = (f p, patl)
+end
+
+(* "views" on patterns are polymorphic variants
+   that allow to restrict the set of pattern constructors
+   statically allowed at a particular place *)
+
+module Simple = struct
+  type view = [
+    | `Any
+    | `Constant of constant
+    | `Tuple of pattern list
+    | `Construct of
+        Longident.t loc * constructor_description * pattern list
+    | `Variant of label * pattern option * row_desc ref
+    | `Record of
+        (Longident.t loc * label_description * pattern) list * closed_flag
+    | `Array of pattern list
+    | `Lazy of pattern
+  ]
+
+  type pattern = view pattern_data
+
+  let omega = { omega with pat_desc = `Any }
+end
+
+module Half_simple = struct
+  type view = [
+    | Simple.view
+    | `Or of pattern * pattern * row_desc option
+  ]
+
+  type pattern = view pattern_data
+end
+
+module General = struct
+  type view = [
+    | Half_simple.view
+    | `Var of Ident.t * string loc
+    | `Alias of pattern * Ident.t * string loc
+  ]
+  type pattern = view pattern_data
+
+  let view_desc = function
+    | Tpat_any ->
+       `Any
+    | Tpat_var (id, str) ->
+       `Var (id, str)
+    | Tpat_alias (p, id, str) ->
+       `Alias (p, id, str)
+    | Tpat_constant cst ->
+       `Constant cst
+    | Tpat_tuple ps ->
+       `Tuple ps
+    | Tpat_construct (cstr, cstr_descr, args) ->
+       `Construct (cstr, cstr_descr, args)
+    | Tpat_variant (cstr, arg, row_desc) ->
+       `Variant (cstr, arg, row_desc)
+    | Tpat_record (fields, closed) ->
+       `Record (fields, closed)
+    | Tpat_array ps -> `Array ps
+    | Tpat_or (p, q, row_desc) -> `Or (p, q, row_desc)
+    | Tpat_lazy p -> `Lazy p
+
+  let view p : pattern =
+    { p with pat_desc = view_desc p.pat_desc }
+
+  let erase_desc = function
+    | `Any -> Tpat_any
+    | `Var (id, str) -> Tpat_var (id, str)
+    | `Alias (p, id, str) -> Tpat_alias (p, id, str)
+    | `Constant cst -> Tpat_constant cst
+    | `Tuple ps -> Tpat_tuple ps
+    | `Construct (cstr, cst_descr, args) ->
+       Tpat_construct (cstr, cst_descr, args)
+    | `Variant (cstr, arg, row_desc) ->
+       Tpat_variant (cstr, arg, row_desc)
+    | `Record (fields, closed) ->
+       Tpat_record (fields, closed)
+    | `Array ps -> Tpat_array ps
+    | `Or (p, q, row_desc) -> Tpat_or (p, q, row_desc)
+    | `Lazy p -> Tpat_lazy p
+
+  let erase p : Typedtree.pattern =
+    { p with pat_desc = erase_desc p.pat_desc }
+
+  let rec strip_vars (p : pattern) : Half_simple.pattern =
+    match p.pat_desc with
+    | `Alias (p, _, _) -> strip_vars (view p)
+    | `Var _ -> { p with pat_desc = `Any }
+    | #Half_simple.view as view -> { p with pat_desc = view }
+end
+
+(* the head constructor of a simple pattern *)
+
+module Head : sig
+  type desc =
+    | Any
+    | Construct of constructor_description
+    | Constant of constant
+    | Tuple of int
+    | Record of label_description list
+    | Variant of
+        { tag: label; has_arg: bool;
+          cstr_row: row_desc ref;
+          type_row : unit -> row_desc; }
+    | Array of int
+    | Lazy
+
+  type t = desc pattern_data
+
+  val arity : t -> int
+
+  (** [deconstruct p] returns the head of [p] and the list of sub patterns. *)
+  val deconstruct : Simple.pattern -> t * pattern list
+
+  (** reconstructs a pattern, putting wildcards as sub-patterns. *)
+  val to_omega_pattern : t -> pattern
+
+  val omega : t
+end = struct
+  type desc =
+    | Any
+    | Construct of constructor_description
+    | Constant of constant
+    | Tuple of int
+    | Record of label_description list
+    | Variant of
+        { tag: label; has_arg: bool;
+          cstr_row: row_desc ref;
+          type_row : unit -> row_desc; }
+          (* the row of the type may evolve if [close_variant] is called,
+             hence the (unit -> ...) delay *)
+    | Array of int
+    | Lazy
+
+  type t = desc pattern_data
+
+  let deconstruct (q : Simple.pattern) =
+    let deconstruct_desc = function
+      | `Any -> Any, []
+      | `Constant c -> Constant c, []
+      | `Tuple args ->
+          Tuple (List.length args), args
+      | `Construct (_, c, args) ->
+          Construct c, args
+      | `Variant (tag, arg, cstr_row) ->
+          let has_arg, pats =
+            match arg with
+            | None -> false, []
+            | Some a -> true, [a]
+          in
+          let type_row () =
+            match Ctype.expand_head q.pat_env q.pat_type with
+              | {desc = Tvariant type_row} -> Btype.row_repr type_row
+              | _ -> assert false
+          in
+          Variant {tag; has_arg; cstr_row; type_row}, pats
+      | `Array args ->
+          Array (List.length args), args
+      | `Record (largs, _) ->
+          let lbls = List.map (fun (_,lbl,_) -> lbl) largs in
+          let pats = List.map (fun (_,_,pat) -> pat) largs in
+          Record lbls, pats
+      | `Lazy p ->
+          Lazy, [p]
+    in
+    let desc, pats = deconstruct_desc q.pat_desc in
+    { q with pat_desc = desc }, pats
+
+  let arity t =
+    match t.pat_desc with
+      | Any -> 0
+      | Constant _ -> 0
+      | Construct c -> c.cstr_arity
+      | Tuple n | Array n -> n
+      | Record l -> List.length l
+      | Variant { has_arg; _ } -> if has_arg then 1 else 0
+      | Lazy -> 1
+
+  let to_omega_pattern t =
+    let pat_desc =
+      let mkloc x = Location.mkloc x t.pat_loc in
+      match t.pat_desc with
+      | Any -> Tpat_any
+      | Lazy -> Tpat_lazy omega
+      | Constant c -> Tpat_constant c
+      | Tuple n -> Tpat_tuple (omegas n)
+      | Array n -> Tpat_array (omegas n)
+      | Construct c ->
+          let lid_loc = mkloc (Longident.Lident c.cstr_name) in
+          Tpat_construct (lid_loc, c, omegas c.cstr_arity)
+      | Variant { tag; has_arg; cstr_row } ->
+          let arg_opt = if has_arg then Some omega else None in
+          Tpat_variant (tag, arg_opt, cstr_row)
+      | Record lbls ->
+          let lst =
+            List.map (fun lbl ->
+              let lid_loc = mkloc (Longident.Lident lbl.lbl_name) in
+              (lid_loc, lbl, omega)
+            ) lbls
+          in
+          Tpat_record (lst, Closed)
+    in
+    { t with
+      pat_desc;
+      pat_extra = [];
+    }
+
+  let omega = { omega with pat_desc = Any }
+end
diff --git a/upstream/ocaml_412/typing/patterns.mli b/upstream/ocaml_412/typing/patterns.mli
new file mode 100644
index 0000000..66dd2d0
--- /dev/null
+++ b/upstream/ocaml_412/typing/patterns.mli
@@ -0,0 +1,109 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Gabriel Scherer, projet Partout, INRIA Paris-Saclay           *)
+(*          Thomas Refis, Jane Street Europe                              *)
+(*                                                                        *)
+(*   Copyright 2019 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Typedtree
+open Types
+
+val omega : pattern
+(** aka. "Tpat_any" or "_"  *)
+
+val omegas : int -> pattern list
+(** [List.init (fun _ -> omega)] *)
+
+val omega_list : 'a list -> pattern list
+(** [List.map (fun _ -> omega)] *)
+
+module Non_empty_row : sig
+  type 'a t = 'a * Typedtree.pattern list
+
+  val of_initial : Typedtree.pattern list -> Typedtree.pattern t
+  (** 'assert false' on empty rows *)
+
+  val map_first : ('a -> 'b) -> 'a t -> 'b t
+end
+
+module Simple : sig
+  type view = [
+    | `Any
+    | `Constant of constant
+    | `Tuple of pattern list
+    | `Construct of
+        Longident.t loc * constructor_description * pattern list
+    | `Variant of label * pattern option * row_desc ref
+    | `Record of
+        (Longident.t loc * label_description * pattern) list * closed_flag
+    | `Array of pattern list
+    | `Lazy of pattern
+  ]
+  type pattern = view pattern_data
+
+  val omega : [> view ] pattern_data
+end
+
+module Half_simple : sig
+  type view = [
+    | Simple.view
+    | `Or of pattern * pattern * row_desc option
+  ]
+  type pattern = view pattern_data
+end
+
+module General : sig
+  type view = [
+    | Half_simple.view
+    | `Var of Ident.t * string loc
+    | `Alias of pattern * Ident.t * string loc
+  ]
+  type pattern = view pattern_data
+
+  val view : Typedtree.pattern -> pattern
+  val erase : [< view ] pattern_data -> Typedtree.pattern
+
+  val strip_vars : pattern -> Half_simple.pattern
+end
+
+module Head : sig
+  type desc =
+    | Any
+    | Construct of constructor_description
+    | Constant of constant
+    | Tuple of int
+    | Record of label_description list
+    | Variant of
+        { tag: label; has_arg: bool;
+          cstr_row: row_desc ref;
+          type_row : unit -> row_desc; }
+          (* the row of the type may evolve if [close_variant] is called,
+             hence the (unit -> ...) delay *)
+    | Array of int
+    | Lazy
+
+  type t = desc pattern_data
+
+  val arity : t -> int
+
+  (** [deconstruct p] returns the head of [p] and the list of sub patterns.
+
+      @raise [Invalid_arg _] if [p] is an or- or an exception-pattern.  *)
+  val deconstruct : Simple.pattern -> t * pattern list
+
+  (** reconstructs a pattern, putting wildcards as sub-patterns. *)
+  val to_omega_pattern : t -> pattern
+
+  val omega : t
+
+end
diff --git a/upstream/ocaml_412/typing/persistent_env.ml b/upstream/ocaml_412/typing/persistent_env.ml
new file mode 100644
index 0000000..1931f5f
--- /dev/null
+++ b/upstream/ocaml_412/typing/persistent_env.ml
@@ -0,0 +1,373 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Xavier Leroy, projet Gallium, INRIA Rocquencourt                     *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*                                                                        *)
+(*   Copyright 2019 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Persistent structure descriptions *)
+
+open Misc
+open Cmi_format
+
+module Consistbl = Consistbl.Make (Misc.Stdlib.String)
+
+let add_delayed_check_forward = ref (fun _ -> assert false)
+
+type error =
+  | Illegal_renaming of modname * modname * filepath
+  | Inconsistent_import of modname * filepath * filepath
+  | Need_recursive_types of modname
+  | Depend_on_unsafe_string_unit of modname
+
+exception Error of error
+let error err = raise (Error err)
+
+module Persistent_signature = struct
+  type t =
+    { filename : string;
+      cmi : Cmi_format.cmi_infos }
+
+  let load = ref (fun ~unit_name ->
+      match Load_path.find_uncap (unit_name ^ ".cmi") with
+      | filename -> Some { filename; cmi = read_cmi filename }
+      | exception Not_found -> None)
+end
+
+type can_load_cmis =
+  | Can_load_cmis
+  | Cannot_load_cmis of EnvLazy.log
+
+type pers_struct = {
+  ps_name: string;
+  ps_crcs: (string * Digest.t option) list;
+  ps_filename: string;
+  ps_flags: pers_flags list;
+}
+
+module String = Misc.Stdlib.String
+
+(* If a .cmi file is missing (or invalid), we
+   store it as Missing in the cache. *)
+type 'a pers_struct_info =
+  | Missing
+  | Found of pers_struct * 'a
+
+type 'a t = {
+  persistent_structures : (string, 'a pers_struct_info) Hashtbl.t;
+  imported_units: String.Set.t ref;
+  imported_opaque_units: String.Set.t ref;
+  crc_units: Consistbl.t;
+  can_load_cmis: can_load_cmis ref;
+}
+
+let empty () = {
+  persistent_structures = Hashtbl.create 17;
+  imported_units = ref String.Set.empty;
+  imported_opaque_units = ref String.Set.empty;
+  crc_units = Consistbl.create ();
+  can_load_cmis = ref Can_load_cmis;
+}
+
+let clear penv =
+  let {
+    persistent_structures;
+    imported_units;
+    imported_opaque_units;
+    crc_units;
+    can_load_cmis;
+  } = penv in
+  Hashtbl.clear persistent_structures;
+  imported_units := String.Set.empty;
+  imported_opaque_units := String.Set.empty;
+  Consistbl.clear crc_units;
+  can_load_cmis := Can_load_cmis;
+  ()
+
+let clear_missing {persistent_structures; _} =
+  let missing_entries =
+    Hashtbl.fold
+      (fun name r acc -> if r = Missing then name :: acc else acc)
+      persistent_structures []
+  in
+  List.iter (Hashtbl.remove persistent_structures) missing_entries
+
+let add_import {imported_units; _} s =
+  imported_units := String.Set.add s !imported_units
+
+let register_import_as_opaque {imported_opaque_units; _} s =
+  imported_opaque_units := String.Set.add s !imported_opaque_units
+
+let find_in_cache {persistent_structures; _} s =
+  match Hashtbl.find persistent_structures s with
+  | exception Not_found -> None
+  | Missing -> None
+  | Found (_ps, pm) -> Some pm
+
+let import_crcs penv ~source crcs =
+  let {crc_units; _} = penv in
+  let import_crc (name, crco) =
+    match crco with
+    | None -> ()
+    | Some crc ->
+        add_import penv name;
+        Consistbl.check crc_units name crc source
+  in List.iter import_crc crcs
+
+let check_consistency penv ps =
+  try import_crcs penv ~source:ps.ps_filename ps.ps_crcs
+  with Consistbl.Inconsistency {
+      unit_name = name;
+      inconsistent_source = source;
+      original_source = auth;
+    } ->
+    error (Inconsistent_import(name, auth, source))
+
+let can_load_cmis penv =
+  !(penv.can_load_cmis)
+let set_can_load_cmis penv setting =
+  penv.can_load_cmis := setting
+
+let without_cmis penv f x =
+  let log = EnvLazy.log () in
+  let res =
+    Misc.(protect_refs
+            [R (penv.can_load_cmis, Cannot_load_cmis log)]
+            (fun () -> f x))
+  in
+  EnvLazy.backtrack log;
+  res
+
+let fold {persistent_structures; _} f x =
+  Hashtbl.fold (fun modname pso x -> match pso with
+      | Missing -> x
+      | Found (_, pm) -> f modname pm x)
+    persistent_structures x
+
+(* Reading persistent structures from .cmi files *)
+
+let save_pers_struct penv crc ps pm =
+  let {persistent_structures; crc_units; _} = penv in
+  let modname = ps.ps_name in
+  Hashtbl.add persistent_structures modname (Found (ps, pm));
+  List.iter
+    (function
+        | Rectypes -> ()
+        | Alerts _ -> ()
+        | Unsafe_string -> ()
+        | Opaque -> register_import_as_opaque penv modname)
+    ps.ps_flags;
+  Consistbl.set crc_units modname crc ps.ps_filename;
+  add_import penv modname
+
+let acknowledge_pers_struct penv check modname pers_sig pm =
+  let { Persistent_signature.filename; cmi } = pers_sig in
+  let name = cmi.cmi_name in
+  let crcs = cmi.cmi_crcs in
+  let flags = cmi.cmi_flags in
+  let ps = { ps_name = name;
+             ps_crcs = crcs;
+             ps_filename = filename;
+             ps_flags = flags;
+           } in
+  if ps.ps_name <> modname then
+    error (Illegal_renaming(modname, ps.ps_name, filename));
+  List.iter
+    (function
+        | Rectypes ->
+            if not !Clflags.recursive_types then
+              error (Need_recursive_types(ps.ps_name))
+        | Unsafe_string ->
+            if Config.safe_string then
+              error (Depend_on_unsafe_string_unit(ps.ps_name));
+        | Alerts _ -> ()
+        | Opaque -> register_import_as_opaque penv modname)
+    ps.ps_flags;
+  if check then check_consistency penv ps;
+  let {persistent_structures; _} = penv in
+  Hashtbl.add persistent_structures modname (Found (ps, pm));
+  ps
+
+let read_pers_struct penv val_of_pers_sig check modname filename =
+  add_import penv modname;
+  let cmi = read_cmi filename in
+  let pers_sig = { Persistent_signature.filename; cmi } in
+  let pm = val_of_pers_sig pers_sig in
+  let ps = acknowledge_pers_struct penv check modname pers_sig pm in
+  (ps, pm)
+
+let find_pers_struct penv val_of_pers_sig check name =
+  let {persistent_structures; _} = penv in
+  if name = "*predef*" then raise Not_found;
+  match Hashtbl.find persistent_structures name with
+  | Found (ps, pm) -> (ps, pm)
+  | Missing -> raise Not_found
+  | exception Not_found ->
+    match can_load_cmis penv with
+    | Cannot_load_cmis _ -> raise Not_found
+    | Can_load_cmis ->
+        let psig =
+          match !Persistent_signature.load ~unit_name:name with
+          | Some psig -> psig
+          | None ->
+            Hashtbl.add persistent_structures name Missing;
+            raise Not_found
+        in
+        add_import penv name;
+        let pm = val_of_pers_sig psig in
+        let ps = acknowledge_pers_struct penv check name psig pm in
+        (ps, pm)
+
+(* Emits a warning if there is no valid cmi for name *)
+let check_pers_struct penv f ~loc name =
+  try
+    ignore (find_pers_struct penv f false name)
+  with
+  | Not_found ->
+      let warn = Warnings.No_cmi_file(name, None) in
+        Location.prerr_warning loc warn
+  | Cmi_format.Error err ->
+      let msg = Format.asprintf "%a" Cmi_format.report_error err in
+      let warn = Warnings.No_cmi_file(name, Some msg) in
+        Location.prerr_warning loc warn
+  | Error err ->
+      let msg =
+        match err with
+        | Illegal_renaming(name, ps_name, filename) ->
+            Format.asprintf
+              " %a@ contains the compiled interface for @ \
+               %s when %s was expected"
+              Location.print_filename filename ps_name name
+        | Inconsistent_import _ -> assert false
+        | Need_recursive_types name ->
+            Format.sprintf
+              "%s uses recursive types"
+              name
+        | Depend_on_unsafe_string_unit name ->
+            Printf.sprintf "%s uses -unsafe-string"
+              name
+      in
+      let warn = Warnings.No_cmi_file(name, Some msg) in
+        Location.prerr_warning loc warn
+
+let read penv f modname filename =
+  snd (read_pers_struct penv f true modname filename)
+
+let find penv f name =
+  snd (find_pers_struct penv f true name)
+
+let check penv f ~loc name =
+  let {persistent_structures; _} = penv in
+  if not (Hashtbl.mem persistent_structures name) then begin
+    (* PR#6843: record the weak dependency ([add_import]) regardless of
+       whether the check succeeds, to help make builds more
+       deterministic. *)
+    add_import penv name;
+    if (Warnings.is_active (Warnings.No_cmi_file("", None))) then
+      !add_delayed_check_forward
+        (fun () -> check_pers_struct penv f ~loc name)
+  end
+
+let crc_of_unit penv f name =
+  let (ps, _pm) = find_pers_struct penv f true name in
+  let crco =
+    try
+      List.assoc name ps.ps_crcs
+    with Not_found ->
+      assert false
+  in
+    match crco with
+      None -> assert false
+    | Some crc -> crc
+
+let imports {imported_units; crc_units; _} =
+  Consistbl.extract (String.Set.elements !imported_units) crc_units
+
+let looked_up {persistent_structures; _} modname =
+  Hashtbl.mem persistent_structures modname
+
+let is_imported {imported_units; _} s =
+  String.Set.mem s !imported_units
+
+let is_imported_opaque {imported_opaque_units; _} s =
+  String.Set.mem s !imported_opaque_units
+
+let make_cmi penv modname sign alerts =
+  let flags =
+    List.concat [
+      if !Clflags.recursive_types then [Cmi_format.Rectypes] else [];
+      if !Clflags.opaque then [Cmi_format.Opaque] else [];
+      (if !Clflags.unsafe_string then [Cmi_format.Unsafe_string] else []);
+      [Alerts alerts];
+    ]
+  in
+  let crcs = imports penv in
+  {
+    cmi_name = modname;
+    cmi_sign = sign;
+    cmi_crcs = crcs;
+    cmi_flags = flags
+  }
+
+let save_cmi penv psig pm =
+  let { Persistent_signature.filename; cmi } = psig in
+  Misc.try_finally (fun () ->
+      let {
+        cmi_name = modname;
+        cmi_sign = _;
+        cmi_crcs = imports;
+        cmi_flags = flags;
+      } = cmi in
+      let crc =
+        output_to_file_via_temporary (* see MPR#7472, MPR#4991 *)
+          ~mode: [Open_binary] filename
+          (fun temp_filename oc -> output_cmi temp_filename oc cmi) in
+      (* Enter signature in persistent table so that imports()
+         will also return its crc *)
+      let ps =
+        { ps_name = modname;
+          ps_crcs = (cmi.cmi_name, Some crc) :: imports;
+          ps_filename = filename;
+          ps_flags = flags;
+        } in
+      save_pers_struct penv crc ps pm
+    )
+    ~exceptionally:(fun () -> remove_file filename)
+
+let report_error ppf =
+  let open Format in
+  function
+  | Illegal_renaming(modname, ps_name, filename) -> fprintf ppf
+      "Wrong file naming: %a@ contains the compiled interface for@ \
+       %s when %s was expected"
+      Location.print_filename filename ps_name modname
+  | Inconsistent_import(name, source1, source2) -> fprintf ppf
+      "@[<hov>The files %a@ and %a@ \
+              make inconsistent assumptions@ over interface %s@]"
+      Location.print_filename source1 Location.print_filename source2 name
+  | Need_recursive_types(import) ->
+      fprintf ppf
+        "@[<hov>Invalid import of %s, which uses recursive types.@ %s@]"
+        import "The compilation flag -rectypes is required"
+  | Depend_on_unsafe_string_unit(import) ->
+      fprintf ppf
+        "@[<hov>Invalid import of %s, compiled with -unsafe-string.@ %s@]"
+        import "This compiler has been configured in strict \
+                                  safe-string mode (-force-safe-string)"
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err ->
+          Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )
diff --git a/upstream/ocaml_412/typing/persistent_env.mli b/upstream/ocaml_412/typing/persistent_env.mli
new file mode 100644
index 0000000..ac3109c
--- /dev/null
+++ b/upstream/ocaml_412/typing/persistent_env.mli
@@ -0,0 +1,105 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Xavier Leroy, projet Gallium, INRIA Rocquencourt                     *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*                                                                        *)
+(*   Copyright 2019 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Misc
+
+module Consistbl : module type of struct
+  include Consistbl.Make (Misc.Stdlib.String)
+end
+
+type error =
+  | Illegal_renaming of modname * modname * filepath
+  | Inconsistent_import of modname * filepath * filepath
+  | Need_recursive_types of modname
+  | Depend_on_unsafe_string_unit of modname
+
+exception Error of error
+
+val report_error: Format.formatter -> error -> unit
+
+module Persistent_signature : sig
+  type t =
+    { filename : string; (** Name of the file containing the signature. *)
+      cmi : Cmi_format.cmi_infos }
+
+  (** Function used to load a persistent signature. The default is to look for
+      the .cmi file in the load path. This function can be overridden to load
+      it from memory, for instance to build a self-contained toplevel. *)
+  val load : (unit_name:string -> t option) ref
+end
+
+type can_load_cmis =
+  | Can_load_cmis
+  | Cannot_load_cmis of Misc.EnvLazy.log
+
+type 'a t
+
+val empty : unit -> 'a t
+
+val clear : 'a t -> unit
+val clear_missing : 'a t -> unit
+
+val fold : 'a t -> (modname -> 'a -> 'b -> 'b) -> 'b -> 'b
+
+val read : 'a t -> (Persistent_signature.t -> 'a)
+  -> modname -> filepath -> 'a
+val find : 'a t -> (Persistent_signature.t -> 'a)
+  -> modname -> 'a
+
+val find_in_cache : 'a t -> modname -> 'a option
+
+val check : 'a t -> (Persistent_signature.t -> 'a)
+  -> loc:Location.t -> modname -> unit
+
+(* [looked_up penv md] checks if one has already tried
+   to read the signature for [md] in the environment
+   [penv] (it may have failed) *)
+val looked_up : 'a t -> modname -> bool
+
+(* [is_imported penv md] checks if [md] has been successfully
+   imported in the environment [penv] *)
+val is_imported : 'a t -> modname -> bool
+
+(* [is_imported_opaque penv md] checks if [md] has been imported
+   in [penv] as an opaque module *)
+val is_imported_opaque : 'a t -> modname -> bool
+
+(* [register_import_as_opaque penv md] registers [md] in [penv] as an
+   opaque module *)
+val register_import_as_opaque : 'a t -> modname -> unit
+
+val make_cmi : 'a t -> modname -> Types.signature -> alerts
+  -> Cmi_format.cmi_infos
+
+val save_cmi : 'a t -> Persistent_signature.t -> 'a -> unit
+
+val can_load_cmis : 'a t -> can_load_cmis
+val set_can_load_cmis : 'a t -> can_load_cmis -> unit
+val without_cmis : 'a t -> ('b -> 'c) -> 'b -> 'c
+(* [without_cmis penv f arg] applies [f] to [arg], but does not
+    allow [penv] to openi cmis during its execution *)
+
+(* may raise Consistbl.Inconsistency *)
+val import_crcs : 'a t -> source:filepath -> crcs -> unit
+
+(* Return the set of compilation units imported, with their CRC *)
+val imports : 'a t -> crcs
+
+(* Return the CRC of the interface of the given compilation unit *)
+val crc_of_unit: 'a t -> (Persistent_signature.t -> 'a) -> modname -> Digest.t
+
+(* Forward declaration to break mutual recursion with Typecore. *)
+val add_delayed_check_forward: ((unit -> unit) -> unit) ref
diff --git a/upstream/ocaml_412/typing/predef.ml b/upstream/ocaml_412/typing/predef.ml
new file mode 100644
index 0000000..786d1dc
--- /dev/null
+++ b/upstream/ocaml_412/typing/predef.ml
@@ -0,0 +1,250 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Predefined type constructors (with special typing rules in typecore) *)
+
+open Path
+open Types
+open Btype
+
+let builtin_idents = ref []
+
+let wrap create s =
+  let id = create s in
+  builtin_idents := (s, id) :: !builtin_idents;
+  id
+
+let ident_create = wrap Ident.create_predef
+
+let ident_int = ident_create "int"
+and ident_char = ident_create "char"
+and ident_bytes = ident_create "bytes"
+and ident_float = ident_create "float"
+and ident_bool = ident_create "bool"
+and ident_unit = ident_create "unit"
+and ident_exn = ident_create "exn"
+and ident_array = ident_create "array"
+and ident_list = ident_create "list"
+and ident_option = ident_create "option"
+and ident_nativeint = ident_create "nativeint"
+and ident_int32 = ident_create "int32"
+and ident_int64 = ident_create "int64"
+and ident_lazy_t = ident_create "lazy_t"
+and ident_string = ident_create "string"
+and ident_extension_constructor = ident_create "extension_constructor"
+and ident_floatarray = ident_create "floatarray"
+
+let path_int = Pident ident_int
+and path_char = Pident ident_char
+and path_bytes = Pident ident_bytes
+and path_float = Pident ident_float
+and path_bool = Pident ident_bool
+and path_unit = Pident ident_unit
+and path_exn = Pident ident_exn
+and path_array = Pident ident_array
+and path_list = Pident ident_list
+and path_option = Pident ident_option
+and path_nativeint = Pident ident_nativeint
+and path_int32 = Pident ident_int32
+and path_int64 = Pident ident_int64
+and path_lazy_t = Pident ident_lazy_t
+and path_string = Pident ident_string
+and path_extension_constructor = Pident ident_extension_constructor
+and path_floatarray = Pident ident_floatarray
+
+let type_int = newgenty (Tconstr(path_int, [], ref Mnil))
+and type_char = newgenty (Tconstr(path_char, [], ref Mnil))
+and type_bytes = newgenty (Tconstr(path_bytes, [], ref Mnil))
+and type_float = newgenty (Tconstr(path_float, [], ref Mnil))
+and type_bool = newgenty (Tconstr(path_bool, [], ref Mnil))
+and type_unit = newgenty (Tconstr(path_unit, [], ref Mnil))
+and type_exn = newgenty (Tconstr(path_exn, [], ref Mnil))
+and type_array t = newgenty (Tconstr(path_array, [t], ref Mnil))
+and type_list t = newgenty (Tconstr(path_list, [t], ref Mnil))
+and type_option t = newgenty (Tconstr(path_option, [t], ref Mnil))
+and type_nativeint = newgenty (Tconstr(path_nativeint, [], ref Mnil))
+and type_int32 = newgenty (Tconstr(path_int32, [], ref Mnil))
+and type_int64 = newgenty (Tconstr(path_int64, [], ref Mnil))
+and type_lazy_t t = newgenty (Tconstr(path_lazy_t, [t], ref Mnil))
+and type_string = newgenty (Tconstr(path_string, [], ref Mnil))
+and type_extension_constructor =
+      newgenty (Tconstr(path_extension_constructor, [], ref Mnil))
+and type_floatarray = newgenty (Tconstr(path_floatarray, [], ref Mnil))
+
+let ident_match_failure = ident_create "Match_failure"
+and ident_out_of_memory = ident_create "Out_of_memory"
+and ident_invalid_argument = ident_create "Invalid_argument"
+and ident_failure = ident_create "Failure"
+and ident_not_found = ident_create "Not_found"
+and ident_sys_error = ident_create "Sys_error"
+and ident_end_of_file = ident_create "End_of_file"
+and ident_division_by_zero = ident_create "Division_by_zero"
+and ident_stack_overflow = ident_create "Stack_overflow"
+and ident_sys_blocked_io = ident_create "Sys_blocked_io"
+and ident_assert_failure = ident_create "Assert_failure"
+and ident_undefined_recursive_module =
+        ident_create "Undefined_recursive_module"
+
+let all_predef_exns = [
+  ident_match_failure;
+  ident_out_of_memory;
+  ident_invalid_argument;
+  ident_failure;
+  ident_not_found;
+  ident_sys_error;
+  ident_end_of_file;
+  ident_division_by_zero;
+  ident_stack_overflow;
+  ident_sys_blocked_io;
+  ident_assert_failure;
+  ident_undefined_recursive_module;
+]
+
+let path_match_failure = Pident ident_match_failure
+and path_assert_failure = Pident ident_assert_failure
+and path_undefined_recursive_module = Pident ident_undefined_recursive_module
+
+let cstr id args =
+  {
+    cd_id = id;
+    cd_args = Cstr_tuple args;
+    cd_res = None;
+    cd_loc = Location.none;
+    cd_attributes = [];
+    cd_uid = Uid.of_predef_id id;
+  }
+
+let ident_false = ident_create "false"
+and ident_true = ident_create "true"
+and ident_void = ident_create "()"
+and ident_nil = ident_create "[]"
+and ident_cons = ident_create "::"
+and ident_none = ident_create "None"
+and ident_some = ident_create "Some"
+
+let mk_add_type add_type type_ident
+      ?manifest ?(immediate=Type_immediacy.Unknown) ?(kind=Type_abstract) env =
+  let decl =
+    {type_params = [];
+     type_arity = 0;
+     type_kind = kind;
+     type_loc = Location.none;
+     type_private = Asttypes.Public;
+     type_manifest = manifest;
+     type_variance = [];
+     type_separability = [];
+     type_is_newtype = false;
+     type_expansion_scope = lowest_level;
+     type_attributes = [];
+     type_immediate = immediate;
+     type_unboxed = unboxed_false_default_false;
+     type_uid = Uid.of_predef_id type_ident;
+    }
+  in
+  add_type type_ident decl env
+
+let common_initial_env add_type add_extension empty_env =
+  let add_type = mk_add_type add_type
+  and add_type1 type_ident
+      ~variance ~separability ?(kind=fun _ -> Type_abstract) env =
+    let param = newgenvar () in
+    let decl =
+      {type_params = [param];
+       type_arity = 1;
+       type_kind = kind param;
+       type_loc = Location.none;
+       type_private = Asttypes.Public;
+       type_manifest = None;
+       type_variance = [variance];
+       type_separability = [separability];
+       type_is_newtype = false;
+       type_expansion_scope = lowest_level;
+       type_attributes = [];
+       type_immediate = Unknown;
+       type_unboxed = unboxed_false_default_false;
+       type_uid = Uid.of_predef_id type_ident;
+      }
+    in
+    add_type type_ident decl env
+  in
+  let add_extension id l =
+    add_extension id
+      { ext_type_path = path_exn;
+        ext_type_params = [];
+        ext_args = Cstr_tuple l;
+        ext_ret_type = None;
+        ext_private = Asttypes.Public;
+        ext_loc = Location.none;
+        ext_attributes = [Ast_helper.Attr.mk
+                            (Location.mknoloc "ocaml.warn_on_literal_pattern")
+                            (Parsetree.PStr [])];
+        ext_uid = Uid.of_predef_id id;
+      }
+  in
+  add_extension ident_match_failure
+                         [newgenty (Ttuple[type_string; type_int; type_int])] (
+  add_extension ident_out_of_memory [] (
+  add_extension ident_stack_overflow [] (
+  add_extension ident_invalid_argument [type_string] (
+  add_extension ident_failure [type_string] (
+  add_extension ident_not_found [] (
+  add_extension ident_sys_blocked_io [] (
+  add_extension ident_sys_error [type_string] (
+  add_extension ident_end_of_file [] (
+  add_extension ident_division_by_zero [] (
+  add_extension ident_assert_failure
+                         [newgenty (Ttuple[type_string; type_int; type_int])] (
+  add_extension ident_undefined_recursive_module
+                         [newgenty (Ttuple[type_string; type_int; type_int])] (
+  add_type ident_int64 (
+  add_type ident_int32 (
+  add_type ident_nativeint (
+  add_type1 ident_lazy_t ~variance:Variance.covariant
+    ~separability:Separability.Ind (
+  add_type1 ident_option ~variance:Variance.covariant
+    ~separability:Separability.Ind
+    ~kind:(fun tvar ->
+      Type_variant([cstr ident_none []; cstr ident_some [tvar]])
+    ) (
+  add_type1 ident_list ~variance:Variance.covariant
+    ~separability:Separability.Ind
+    ~kind:(fun tvar ->
+      Type_variant([cstr ident_nil []; cstr ident_cons [tvar; type_list tvar]])
+    ) (
+  add_type1 ident_array ~variance:Variance.full ~separability:Separability.Ind (
+  add_type ident_exn ~kind:Type_open (
+  add_type ident_unit ~immediate:Always
+    ~kind:(Type_variant([cstr ident_void []])) (
+  add_type ident_bool ~immediate:Always
+    ~kind:(Type_variant([cstr ident_false []; cstr ident_true []])) (
+  add_type ident_float (
+  add_type ident_string (
+  add_type ident_char ~immediate:Always (
+  add_type ident_int ~immediate:Always (
+  add_type ident_extension_constructor (
+  add_type ident_floatarray (
+    empty_env))))))))))))))))))))))))))))
+
+let build_initial_env add_type add_exception empty_env =
+  let common = common_initial_env add_type add_exception empty_env in
+  let add_type = mk_add_type add_type in
+  let safe_string = add_type ident_bytes common in
+  let unsafe_string = add_type ident_bytes ~manifest:type_string common in
+  (safe_string, unsafe_string)
+
+let builtin_values =
+  List.map (fun id -> (Ident.name id, id)) all_predef_exns
+
+let builtin_idents = List.rev !builtin_idents
diff --git a/upstream/ocaml_412/typing/predef.mli b/upstream/ocaml_412/typing/predef.mli
new file mode 100644
index 0000000..962a276
--- /dev/null
+++ b/upstream/ocaml_412/typing/predef.mli
@@ -0,0 +1,87 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Predefined type constructors (with special typing rules in typecore) *)
+
+open Types
+
+val type_int: type_expr
+val type_char: type_expr
+val type_string: type_expr
+val type_bytes: type_expr
+val type_float: type_expr
+val type_bool: type_expr
+val type_unit: type_expr
+val type_exn: type_expr
+val type_array: type_expr -> type_expr
+val type_list: type_expr -> type_expr
+val type_option: type_expr -> type_expr
+val type_nativeint: type_expr
+val type_int32: type_expr
+val type_int64: type_expr
+val type_lazy_t: type_expr -> type_expr
+val type_extension_constructor:type_expr
+val type_floatarray:type_expr
+
+val path_int: Path.t
+val path_char: Path.t
+val path_string: Path.t
+val path_bytes: Path.t
+val path_float: Path.t
+val path_bool: Path.t
+val path_unit: Path.t
+val path_exn: Path.t
+val path_array: Path.t
+val path_list: Path.t
+val path_option: Path.t
+val path_nativeint: Path.t
+val path_int32: Path.t
+val path_int64: Path.t
+val path_lazy_t: Path.t
+val path_extension_constructor: Path.t
+val path_floatarray: Path.t
+
+val path_match_failure: Path.t
+val path_assert_failure : Path.t
+val path_undefined_recursive_module : Path.t
+
+val ident_false : Ident.t
+val ident_true : Ident.t
+val ident_void : Ident.t
+val ident_nil : Ident.t
+val ident_cons : Ident.t
+val ident_none : Ident.t
+val ident_some : Ident.t
+
+(* To build the initial environment. Since there is a nasty mutual
+   recursion between predef and env, we break it by parameterizing
+   over Env.t, Env.add_type and Env.add_extension. *)
+
+val build_initial_env:
+  (Ident.t -> type_declaration -> 'a -> 'a) ->
+  (Ident.t -> extension_constructor -> 'a -> 'a) ->
+  'a -> 'a * 'a
+
+(* To initialize linker tables *)
+
+val builtin_values: (string * Ident.t) list
+val builtin_idents: (string * Ident.t) list
+
+(** All predefined exceptions, exposed as [Ident.t] for flambda (for
+    building value approximations).
+    The [Ident.t] for division by zero is also exported explicitly
+    so flambda can generate code to raise it. *)
+val ident_division_by_zero: Ident.t
+val all_predef_exns : Ident.t list
diff --git a/upstream/ocaml_412/typing/primitive.ml b/upstream/ocaml_412/typing/primitive.ml
new file mode 100644
index 0000000..0c3372b
--- /dev/null
+++ b/upstream/ocaml_412/typing/primitive.ml
@@ -0,0 +1,227 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Description of primitive functions *)
+
+open Misc
+open Parsetree
+
+type boxed_integer = Pnativeint | Pint32 | Pint64
+
+type native_repr =
+  | Same_as_ocaml_repr
+  | Unboxed_float
+  | Unboxed_integer of boxed_integer
+  | Untagged_int
+
+type description =
+  { prim_name: string;         (* Name of primitive  or C function *)
+    prim_arity: int;           (* Number of arguments *)
+    prim_alloc: bool;          (* Does it allocates or raise? *)
+    prim_native_name: string;  (* Name of C function for the nat. code gen. *)
+    prim_native_repr_args: native_repr list;
+    prim_native_repr_res: native_repr }
+
+type error =
+  | Old_style_float_with_native_repr_attribute
+  | Old_style_noalloc_with_noalloc_attribute
+  | No_native_primitive_with_repr_attribute
+
+exception Error of Location.t * error
+
+let is_ocaml_repr = function
+  | Same_as_ocaml_repr -> true
+  | Unboxed_float
+  | Unboxed_integer _
+  | Untagged_int -> false
+
+let is_unboxed = function
+  | Same_as_ocaml_repr
+  | Untagged_int -> false
+  | Unboxed_float
+  | Unboxed_integer _ -> true
+
+let is_untagged = function
+  | Untagged_int -> true
+  | Same_as_ocaml_repr
+  | Unboxed_float
+  | Unboxed_integer _ -> false
+
+let rec make_native_repr_args arity x =
+  if arity = 0 then
+    []
+  else
+    x :: make_native_repr_args (arity - 1) x
+
+let simple ~name ~arity ~alloc =
+  {prim_name = name;
+   prim_arity = arity;
+   prim_alloc = alloc;
+   prim_native_name = "";
+   prim_native_repr_args = make_native_repr_args arity Same_as_ocaml_repr;
+   prim_native_repr_res = Same_as_ocaml_repr}
+
+let make ~name ~alloc ~native_name ~native_repr_args ~native_repr_res =
+  {prim_name = name;
+   prim_arity = List.length native_repr_args;
+   prim_alloc = alloc;
+   prim_native_name = native_name;
+   prim_native_repr_args = native_repr_args;
+   prim_native_repr_res = native_repr_res}
+
+let parse_declaration valdecl ~native_repr_args ~native_repr_res =
+  let arity = List.length native_repr_args in
+  let name, native_name, old_style_noalloc, old_style_float =
+    match valdecl.pval_prim with
+    | name :: "noalloc" :: name2 :: "float" :: _ -> (name, name2, true, true)
+    | name :: "noalloc" :: name2 :: _ -> (name, name2, true, false)
+    | name :: name2 :: "float" :: _ -> (name, name2, false, true)
+    | name :: "noalloc" :: _ -> (name, "", true, false)
+    | name :: name2 :: _ -> (name, name2, false, false)
+    | name :: _ -> (name, "", false, false)
+    | [] ->
+        fatal_error "Primitive.parse_declaration"
+  in
+  let noalloc_attribute =
+    Attr_helper.has_no_payload_attribute ["noalloc"; "ocaml.noalloc"]
+      valdecl.pval_attributes
+  in
+  if old_style_float &&
+     not (List.for_all is_ocaml_repr native_repr_args &&
+          is_ocaml_repr native_repr_res) then
+    raise (Error (valdecl.pval_loc,
+                  Old_style_float_with_native_repr_attribute));
+  if old_style_noalloc && noalloc_attribute then
+    raise (Error (valdecl.pval_loc,
+                  Old_style_noalloc_with_noalloc_attribute));
+  (* The compiler used to assume "noalloc" with "float", we just make this
+     explicit now (GPR#167): *)
+  let old_style_noalloc = old_style_noalloc || old_style_float in
+  if old_style_float then
+    Location.deprecated valdecl.pval_loc
+      "[@@unboxed] + [@@noalloc] should be used\n\
+       instead of \"float\""
+  else if old_style_noalloc then
+    Location.deprecated valdecl.pval_loc
+      "[@@noalloc] should be used instead of \"noalloc\"";
+  if native_name = "" &&
+     not (List.for_all is_ocaml_repr native_repr_args &&
+          is_ocaml_repr native_repr_res) then
+    raise (Error (valdecl.pval_loc,
+                  No_native_primitive_with_repr_attribute));
+  let noalloc = old_style_noalloc || noalloc_attribute in
+  let native_repr_args, native_repr_res =
+    if old_style_float then
+      (make_native_repr_args arity Unboxed_float, Unboxed_float)
+    else
+      (native_repr_args, native_repr_res)
+  in
+  {prim_name = name;
+   prim_arity = arity;
+   prim_alloc = not noalloc;
+   prim_native_name = native_name;
+   prim_native_repr_args = native_repr_args;
+   prim_native_repr_res = native_repr_res}
+
+open Outcometree
+
+let rec add_native_repr_attributes ty attrs =
+  match ty, attrs with
+  | Otyp_arrow (label, a, b), attr_opt :: rest ->
+    let b = add_native_repr_attributes b rest in
+    let a =
+      match attr_opt with
+      | None -> a
+      | Some attr -> Otyp_attribute (a, attr)
+    in
+    Otyp_arrow (label, a, b)
+  | _, [Some attr] -> Otyp_attribute (ty, attr)
+  | _ ->
+    assert (List.for_all (fun x -> x = None) attrs);
+    ty
+
+let oattr_unboxed = { oattr_name = "unboxed" }
+let oattr_untagged = { oattr_name = "untagged" }
+let oattr_noalloc = { oattr_name = "noalloc" }
+
+let print p osig_val_decl =
+  let prims =
+    if p.prim_native_name <> "" then
+      [p.prim_name; p.prim_native_name]
+    else
+      [p.prim_name]
+  in
+  let for_all f =
+    List.for_all f p.prim_native_repr_args && f p.prim_native_repr_res
+  in
+  let all_unboxed = for_all is_unboxed in
+  let all_untagged = for_all is_untagged in
+  let attrs = if p.prim_alloc then [] else [oattr_noalloc] in
+  let attrs =
+    if all_unboxed then
+      oattr_unboxed :: attrs
+    else if all_untagged then
+      oattr_untagged :: attrs
+    else
+      attrs
+  in
+  let attr_of_native_repr = function
+    | Same_as_ocaml_repr -> None
+    | Unboxed_float
+    | Unboxed_integer _ -> if all_unboxed then None else Some oattr_unboxed
+    | Untagged_int -> if all_untagged then None else Some oattr_untagged
+  in
+  let type_attrs =
+    List.map attr_of_native_repr p.prim_native_repr_args @
+    [attr_of_native_repr p.prim_native_repr_res]
+  in
+  { osig_val_decl with
+    oval_prims = prims;
+    oval_type = add_native_repr_attributes osig_val_decl.oval_type type_attrs;
+    oval_attributes = attrs }
+
+let native_name p =
+  if p.prim_native_name <> ""
+  then p.prim_native_name
+  else p.prim_name
+
+let byte_name p =
+  p.prim_name
+
+let native_name_is_external p =
+  let nat_name = native_name p in
+  nat_name <> "" && nat_name.[0] <> '%'
+
+let report_error ppf err =
+  match err with
+  | Old_style_float_with_native_repr_attribute ->
+    Format.fprintf ppf "Cannot use \"float\" in conjunction with \
+                        [%@unboxed]/[%@untagged]."
+  | Old_style_noalloc_with_noalloc_attribute ->
+    Format.fprintf ppf "Cannot use \"noalloc\" in conjunction with \
+                        [%@%@noalloc]."
+  | No_native_primitive_with_repr_attribute ->
+    Format.fprintf ppf
+      "[@The native code version of the primitive is mandatory@ \
+       when attributes [%@untagged] or [%@unboxed] are present.@]"
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, err) ->
+        Some (Location.error_of_printer ~loc report_error err)
+      | _ ->
+        None
+    )
diff --git a/upstream/ocaml_412/typing/primitive.mli b/upstream/ocaml_412/typing/primitive.mli
new file mode 100644
index 0000000..ddd3977
--- /dev/null
+++ b/upstream/ocaml_412/typing/primitive.mli
@@ -0,0 +1,76 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Description of primitive functions *)
+
+type boxed_integer = Pnativeint | Pint32 | Pint64
+
+(* Representation of arguments/result for the native code version
+   of a primitive *)
+type native_repr =
+  | Same_as_ocaml_repr
+  | Unboxed_float
+  | Unboxed_integer of boxed_integer
+  | Untagged_int
+
+type description = private
+  { prim_name: string;         (* Name of primitive  or C function *)
+    prim_arity: int;           (* Number of arguments *)
+    prim_alloc: bool;          (* Does it allocates or raise? *)
+    prim_native_name: string;  (* Name of C function for the nat. code gen. *)
+    prim_native_repr_args: native_repr list;
+    prim_native_repr_res: native_repr }
+
+(* Invariant [List.length d.prim_native_repr_args = d.prim_arity] *)
+
+val simple
+  :  name:string
+  -> arity:int
+  -> alloc:bool
+  -> description
+
+val make
+  :  name:string
+  -> alloc:bool
+  -> native_name:string
+  -> native_repr_args: native_repr list
+  -> native_repr_res: native_repr
+  -> description
+
+val parse_declaration
+  :  Parsetree.value_description
+  -> native_repr_args:native_repr list
+  -> native_repr_res:native_repr
+  -> description
+
+val print
+  :  description
+  -> Outcometree.out_val_decl
+  -> Outcometree.out_val_decl
+
+val native_name: description -> string
+val byte_name: description -> string
+
+(** [native_name_is_externa] returns [true] iff the [native_name] for the
+    given primitive identifies that the primitive is not implemented in the
+    compiler itself. *)
+val native_name_is_external : description -> bool
+
+type error =
+  | Old_style_float_with_native_repr_attribute
+  | Old_style_noalloc_with_noalloc_attribute
+  | No_native_primitive_with_repr_attribute
+
+exception Error of Location.t * error
diff --git a/upstream/ocaml_412/typing/printpat.ml b/upstream/ocaml_412/typing/printpat.ml
new file mode 100644
index 0000000..43a1864
--- /dev/null
+++ b/upstream/ocaml_412/typing/printpat.ml
@@ -0,0 +1,163 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Values as patterns pretty printer *)
+
+open Asttypes
+open Typedtree
+open Types
+open Format
+
+let is_cons = function
+| {cstr_name = "::"} -> true
+| _ -> false
+
+let pretty_const c = match c with
+| Const_int i -> Printf.sprintf "%d" i
+| Const_char c -> Printf.sprintf "%C" c
+| Const_string (s, _, _) -> Printf.sprintf "%S" s
+| Const_float f -> Printf.sprintf "%s" f
+| Const_int32 i -> Printf.sprintf "%ldl" i
+| Const_int64 i -> Printf.sprintf "%LdL" i
+| Const_nativeint i -> Printf.sprintf "%ndn" i
+
+let pretty_extra ppf (cstr, _loc, _attrs) pretty_rest rest =
+  match cstr with
+  | Tpat_unpack ->
+     fprintf ppf "@[(module %a)@]" pretty_rest rest
+  | Tpat_constraint _ ->
+     fprintf ppf "@[(%a : _)@]" pretty_rest rest
+  | Tpat_type _ ->
+     fprintf ppf "@[(# %a)@]" pretty_rest rest
+  | Tpat_open _ ->
+     fprintf ppf "@[(# %a)@]" pretty_rest rest
+
+let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v ->
+  match v.pat_extra with
+    | extra :: rem ->
+       pretty_extra ppf extra
+         pretty_val { v with pat_extra = rem }
+    | [] ->
+  match v.pat_desc with
+  | Tpat_any -> fprintf ppf "_"
+  | Tpat_var (x,_) -> fprintf ppf "%s" (Ident.name x)
+  | Tpat_constant c -> fprintf ppf "%s" (pretty_const c)
+  | Tpat_tuple vs ->
+      fprintf ppf "@[(%a)@]" (pretty_vals ",") vs
+  | Tpat_construct (_, cstr, []) ->
+      fprintf ppf "%s" cstr.cstr_name
+  | Tpat_construct (_, cstr, [w]) ->
+      fprintf ppf "@[<2>%s@ %a@]" cstr.cstr_name pretty_arg w
+  | Tpat_construct (_, cstr, vs) ->
+      let name = cstr.cstr_name in
+      begin match (name, vs) with
+        ("::", [v1;v2]) ->
+          fprintf ppf "@[%a::@,%a@]" pretty_car v1 pretty_cdr v2
+      |  _ ->
+          fprintf ppf "@[<2>%s@ @[(%a)@]@]" name (pretty_vals ",") vs
+      end
+  | Tpat_variant (l, None, _) ->
+      fprintf ppf "`%s" l
+  | Tpat_variant (l, Some w, _) ->
+      fprintf ppf "@[<2>`%s@ %a@]" l pretty_arg w
+  | Tpat_record (lvs,_) ->
+      let filtered_lvs = List.filter
+          (function
+            | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
+            | _ -> true) lvs in
+      begin match filtered_lvs with
+      | [] -> fprintf ppf "_"
+      | (_, lbl, _) :: q ->
+          let elision_mark ppf =
+            (* we assume that there is no label repetitions here *)
+             if Array.length lbl.lbl_all > 1 + List.length q then
+               fprintf ppf ";@ _@ "
+             else () in
+          fprintf ppf "@[{%a%t}@]"
+            pretty_lvals filtered_lvs elision_mark
+      end
+  | Tpat_array vs ->
+      fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
+  | Tpat_lazy v ->
+      fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v
+  | Tpat_alias (v, x,_) ->
+      fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x
+  | Tpat_value v ->
+      fprintf ppf "%a" pretty_val (v :> pattern)
+  | Tpat_exception v ->
+      fprintf ppf "@[<2>exception@ %a@]" pretty_arg v
+  | Tpat_or _ ->
+      fprintf ppf "@[(%a)@]" pretty_or v
+
+and pretty_car ppf v = match v.pat_desc with
+| Tpat_construct (_,cstr, [_ ; _])
+    when is_cons cstr ->
+      fprintf ppf "(%a)" pretty_val v
+| _ -> pretty_val ppf v
+
+and pretty_cdr ppf v = match v.pat_desc with
+| Tpat_construct (_,cstr, [v1 ; v2])
+    when is_cons cstr ->
+      fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2
+| _ -> pretty_val ppf v
+
+and pretty_arg ppf v = match v.pat_desc with
+| Tpat_construct (_,_,_::_)
+| Tpat_variant (_, Some _, _) -> fprintf ppf "(%a)" pretty_val v
+|  _ -> pretty_val ppf v
+
+and pretty_or : type k . _ -> k general_pattern -> _ = fun ppf v ->
+  match v.pat_desc with
+  | Tpat_or (v,w,_) ->
+      fprintf ppf "%a|@,%a" pretty_or v pretty_or w
+  | _ -> pretty_val ppf v
+
+and pretty_vals sep ppf = function
+  | [] -> ()
+  | [v] -> pretty_val ppf v
+  | v::vs ->
+      fprintf ppf "%a%s@ %a" pretty_val v sep (pretty_vals sep) vs
+
+and pretty_lvals ppf = function
+  | [] -> ()
+  | [_,lbl,v] ->
+      fprintf ppf "%s=%a" lbl.lbl_name pretty_val v
+  | (_, lbl,v)::rest ->
+      fprintf ppf "%s=%a;@ %a"
+        lbl.lbl_name pretty_val v pretty_lvals rest
+
+let top_pretty ppf v =
+  fprintf ppf "@[%a@]@?" pretty_val v
+
+let pretty_pat p =
+  top_pretty Format.str_formatter p ;
+  prerr_string (Format.flush_str_formatter ())
+
+type 'k matrix = 'k general_pattern list list
+
+let pretty_line fmt =
+  List.iter (fun p ->
+    Format.fprintf fmt " <";
+    top_pretty fmt p;
+    Format.fprintf fmt ">";
+  )
+
+let pretty_matrix fmt (pss : 'k matrix) =
+  Format.fprintf fmt "begin matrix\n" ;
+  List.iter (fun ps ->
+    pretty_line fmt ps ;
+    Format.fprintf fmt "\n"
+  ) pss;
+  Format.fprintf fmt "end matrix\n%!"
diff --git a/upstream/ocaml_412/typing/printpat.mli b/upstream/ocaml_412/typing/printpat.mli
new file mode 100644
index 0000000..1865a2a
--- /dev/null
+++ b/upstream/ocaml_412/typing/printpat.mli
@@ -0,0 +1,27 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+
+
+val pretty_const
+    : Asttypes.constant -> string
+val top_pretty
+    : Format.formatter -> 'k Typedtree.general_pattern -> unit
+val pretty_pat
+    : 'k Typedtree.general_pattern -> unit
+val pretty_line
+    : Format.formatter -> 'k Typedtree.general_pattern list -> unit
+val pretty_matrix
+    : Format.formatter -> 'k Typedtree.general_pattern list list -> unit
diff --git a/upstream/ocaml_412/typing/printtyp.ml b/upstream/ocaml_412/typing/printtyp.ml
new file mode 100644
index 0000000..9e32969
--- /dev/null
+++ b/upstream/ocaml_412/typing/printtyp.ml
@@ -0,0 +1,2255 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Printing functions *)
+
+open Misc
+open Ctype
+open Format
+open Longident
+open Path
+open Asttypes
+open Types
+open Btype
+open Outcometree
+
+module String = Misc.Stdlib.String
+
+(* Print a long identifier *)
+
+let rec longident ppf = function
+  | Lident s -> pp_print_string ppf s
+  | Ldot(p, s) -> fprintf ppf "%a.%s" longident p s
+  | Lapply(p1, p2) -> fprintf ppf "%a(%a)" longident p1 longident p2
+
+let () = Env.print_longident := longident
+
+(* Print an identifier avoiding name collisions *)
+
+module Out_name = struct
+  let create x = { printed_name = x }
+  let print x = x.printed_name
+  let set out_name x = out_name.printed_name <- x
+end
+
+(* printing environment for path shortening and naming *)
+let printing_env = ref Env.empty
+
+(* When printing, it is important to only observe the
+   current printing environment, without reading any new
+   cmi present on the file system *)
+let in_printing_env f = Env.without_cmis f !printing_env
+
+let human_unique n id = Printf.sprintf "%s/%d" (Ident.name id) n
+
+type namespace =
+  | Type
+  | Module
+  | Module_type
+  | Class
+  | Class_type
+  | Other (** Other bypasses the unique name identifier mechanism *)
+
+module Namespace = struct
+
+  let id = function
+    | Type -> 0
+    | Module -> 1
+    | Module_type -> 2
+    | Class -> 3
+    | Class_type -> 4
+    | Other -> 5
+
+  let size = 1 + id Other
+
+  let show =
+    function
+    | Type -> "type"
+    | Module -> "module"
+    | Module_type -> "module type"
+    | Class -> "class"
+    | Class_type -> "class type"
+    | Other -> ""
+
+  let pp ppf x = Format.pp_print_string ppf (show x)
+
+  (** The two functions below should never access the filesystem,
+      and thus use {!in_printing_env} rather than directly
+      accessing the printing environment *)
+  let lookup =
+    let to_lookup f lid = fst @@ in_printing_env (f (Lident lid)) in
+    function
+    | Type -> to_lookup Env.find_type_by_name
+    | Module -> to_lookup Env.find_module_by_name
+    | Module_type -> to_lookup Env.find_modtype_by_name
+    | Class -> to_lookup Env.find_class_by_name
+    | Class_type -> to_lookup Env.find_cltype_by_name
+    | Other -> fun _ -> raise Not_found
+
+  let location namespace id =
+    let path = Path.Pident id in
+    try Some (
+        match namespace with
+        | Type -> (in_printing_env @@ Env.find_type path).type_loc
+        | Module -> (in_printing_env @@ Env.find_module path).md_loc
+        | Module_type -> (in_printing_env @@ Env.find_modtype path).mtd_loc
+        | Class -> (in_printing_env @@ Env.find_class path).cty_loc
+        | Class_type -> (in_printing_env @@ Env.find_cltype path).clty_loc
+        | Other -> Location.none
+      ) with Not_found -> None
+
+  let best_class_namespace = function
+    | Papply _ | Pdot _ -> Module
+    | Pident c ->
+        match location Class c with
+        | Some _ -> Class
+        | None -> Class_type
+
+end
+
+(** {2 Conflicts printing}
+    Conflicts arise when multiple items are attributed the same name,
+    the following module stores the global conflict references and
+    provides the printing functions for explaining the source of
+    the conflicts.
+*)
+module Conflicts = struct
+  module M = String.Map
+  type explanation =
+    { kind: namespace; name:string; root_name:string; location:Location.t}
+  let explanations = ref M.empty
+  let collect_explanation namespace n id =
+    let name = human_unique n id in
+    let root_name = Ident.name id in
+    if not (M.mem name !explanations) then
+      match Namespace.location namespace id with
+      | None -> ()
+      | Some location ->
+          let explanation = { kind = namespace; location; name; root_name } in
+          explanations := M.add name explanation !explanations
+
+  let pp_explanation ppf r=
+    Format.fprintf ppf "@[<v 2>%a:@,Definition of %s %s@]"
+      Location.print_loc r.location (Namespace.show r.kind) r.name
+
+  let print_located_explanations ppf l =
+    Format.fprintf ppf "@[<v>%a@]" (Format.pp_print_list pp_explanation) l
+
+  let reset () = explanations := M.empty
+  let list_explanations () =
+    let c = !explanations in
+    reset ();
+    c |> M.bindings |> List.map snd |> List.sort Stdlib.compare
+
+
+  let print_toplevel_hint ppf l =
+    let conj ppf () = Format.fprintf ppf " and@ " in
+    let pp_namespace_plural ppf n = Format.fprintf ppf "%as" Namespace.pp n in
+    let root_names = List.map (fun r -> r.kind, r.root_name) l in
+    let unique_root_names = List.sort_uniq Stdlib.compare root_names in
+    let submsgs = Array.make Namespace.size [] in
+    let () = List.iter (fun (n,_ as x) ->
+        submsgs.(Namespace.id n) <- x :: submsgs.(Namespace.id n)
+      )  unique_root_names in
+    let pp_submsg ppf names =
+      match names with
+      | [] -> ()
+      | [namespace, a] ->
+          Format.fprintf ppf
+        "@ \
+         @[<2>Hint: The %a %s has been defined multiple times@ \
+         in@ this@ toplevel@ session.@ \
+         Some toplevel values still refer to@ old@ versions@ of@ this@ %a.\
+         @ Did you try to redefine them?@]"
+        Namespace.pp namespace a Namespace.pp namespace
+      | (namespace, _) :: _ :: _ ->
+      Format.fprintf ppf
+        "@ \
+         @[<2>Hint: The %a %a have been defined multiple times@ \
+         in@ this@ toplevel@ session.@ \
+         Some toplevel values still refer to@ old@ versions@ of@ those@ %a.\
+         @ Did you try to redefine them?@]"
+        pp_namespace_plural namespace
+        Format.(pp_print_list ~pp_sep:conj pp_print_string) (List.map snd names)
+        pp_namespace_plural namespace in
+    Array.iter (pp_submsg ppf) submsgs
+
+  let print_explanations ppf =
+    let ltop, l =
+      (* isolate toplevel locations, since they are too imprecise *)
+      let from_toplevel a =
+        a.location.Location.loc_start.Lexing.pos_fname = "//toplevel//" in
+      List.partition from_toplevel (list_explanations ())
+    in
+    begin match l with
+    | [] -> ()
+    | l -> Format.fprintf ppf "@ %a" print_located_explanations l
+    end;
+    (* if there are name collisions in a toplevel session,
+       display at least one generic hint by namespace *)
+    print_toplevel_hint ppf ltop
+
+  let exists () = M.cardinal !explanations >0
+end
+
+
+module Naming_context = struct
+
+module M = String.Map
+module S = String.Set
+
+let enabled = ref true
+let enable b = enabled := b
+
+(** Name mapping *)
+type mapping =
+  | Need_unique_name of int Ident.Map.t
+  (** The same name has already been attributed to multiple types.
+      The [map] argument contains the specific binding time attributed to each
+      types.
+  *)
+  | Uniquely_associated_to of Ident.t * out_name
+    (** For now, the name [Ident.name id] has been attributed to [id],
+        [out_name] is used to expand this name if a conflict arises
+        at a later point
+    *)
+  | Associated_to_pervasives of out_name
+  (** [Associated_to_pervasives out_name] is used when the item
+      [Stdlib.$name] has been associated to the name [$name].
+      Upon a conflict, this name will be expanded to ["Stdlib." ^ name ] *)
+
+let hid_start = 0
+
+let add_hid_id id map =
+  let new_id = 1 + Ident.Map.fold (fun _ -> max) map hid_start in
+  new_id, Ident.Map.add id new_id  map
+
+let find_hid id map =
+  try Ident.Map.find id map, map with
+  Not_found -> add_hid_id id map
+
+let pervasives name = "Stdlib." ^ name
+
+let map = Array.make Namespace.size M.empty
+let get namespace = map.(Namespace.id namespace)
+let set namespace x = map.(Namespace.id namespace) <- x
+
+(* Names used in recursive definitions are not considered when determining
+   if a name is already attributed in the current environment.
+   This is a weaker version of hidden_rec_items used by short-path. *)
+let protected = ref S.empty
+let add_protected id = protected := S.add (Ident.name id) !protected
+let reset_protected () = protected := S.empty
+let with_hidden id f =
+  protect_refs [ R(protected,S.add (Ident.name id) !protected)] f
+
+let pervasives_name namespace name =
+  if not !enabled then Out_name.create name else
+  match M.find name (get namespace) with
+  | Associated_to_pervasives r -> r
+  | Need_unique_name _ -> Out_name.create (pervasives name)
+  | Uniquely_associated_to (id',r) ->
+      let hid, map = add_hid_id id' Ident.Map.empty in
+      Out_name.set r (human_unique hid id');
+      Conflicts.collect_explanation namespace hid id';
+      set namespace @@ M.add name (Need_unique_name map) (get namespace);
+      Out_name.create (pervasives name)
+  | exception Not_found ->
+      let r = Out_name.create name in
+      set namespace @@ M.add name (Associated_to_pervasives r) (get namespace);
+      r
+
+(** Lookup for preexisting named item within the current {!printing_env} *)
+let env_ident namespace name =
+  if S.mem name !protected then None else
+  match Namespace.lookup namespace name with
+  | Pident id -> Some id
+  | _ -> None
+  | exception Not_found -> None
+
+(** Associate a name to the identifier [id] within [namespace] *)
+let ident_name_simple namespace id =
+  if not !enabled then Out_name.create (Ident.name id) else
+  let name = Ident.name id in
+  match M.find name (get namespace) with
+  | Uniquely_associated_to (id',r) when Ident.same id id' ->
+      r
+  | Need_unique_name map ->
+      let hid, m = find_hid id map in
+      Conflicts.collect_explanation namespace hid id;
+      set namespace @@ M.add name (Need_unique_name m) (get namespace);
+      Out_name.create (human_unique hid id)
+  | Uniquely_associated_to (id',r) ->
+      let hid', m = find_hid id' Ident.Map.empty in
+      let hid, m = find_hid id m in
+      Out_name.set r (human_unique hid' id');
+      List.iter (fun (id,hid) -> Conflicts.collect_explanation namespace hid id)
+        [id, hid; id', hid' ];
+      set namespace @@ M.add name (Need_unique_name m) (get namespace);
+      Out_name.create (human_unique hid id)
+  | Associated_to_pervasives r ->
+      Out_name.set r ("Stdlib." ^ Out_name.print r);
+      let hid, m = find_hid id Ident.Map.empty in
+      set namespace @@ M.add name (Need_unique_name m) (get namespace);
+      Out_name.create (human_unique hid id)
+  | exception Not_found ->
+      let r = Out_name.create name in
+      set namespace
+      @@ M.add name (Uniquely_associated_to (id,r) ) (get namespace);
+      r
+
+(** Same as {!ident_name_simple} but lookup to existing named identifiers
+    in the current {!printing_env} *)
+let ident_name namespace id =
+  begin match env_ident namespace (Ident.name id) with
+  | Some id' -> ignore (ident_name_simple namespace id')
+  | None -> ()
+  end;
+  ident_name_simple namespace id
+
+let reset () =
+  Array.iteri ( fun i _ -> map.(i) <- M.empty ) map
+
+end
+let ident_name = Naming_context.ident_name
+let reset_naming_context = Naming_context.reset
+
+let ident ppf id = pp_print_string ppf
+    (Out_name.print (Naming_context.ident_name_simple Other id))
+
+(* Print a path *)
+
+let ident_stdlib = Ident.create_persistent "Stdlib"
+
+let non_shadowed_pervasive = function
+  | Pdot(Pident id, s) as path ->
+      Ident.same id ident_stdlib &&
+      (match in_printing_env (Env.find_type_by_name (Lident s)) with
+       | (path', _) -> Path.same path path'
+       | exception Not_found -> true)
+  | _ -> false
+
+let find_double_underscore s =
+  let len = String.length s in
+  let rec loop i =
+    if i + 1 >= len then
+      None
+    else if s.[i] = '_' && s.[i + 1] = '_' then
+      Some i
+    else
+      loop (i + 1)
+  in
+  loop 0
+
+let rec module_path_is_an_alias_of env path ~alias_of =
+  match Env.find_module path env with
+  | { md_type = Mty_alias path'; _ } ->
+    Path.same path' alias_of ||
+    module_path_is_an_alias_of env path' ~alias_of
+  | _ -> false
+  | exception Not_found -> false
+
+(* Simple heuristic to print Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias
+   for Foo__bar. This pattern is used by the stdlib. *)
+let rec rewrite_double_underscore_paths env p =
+  match p with
+  | Pdot (p, s) ->
+    Pdot (rewrite_double_underscore_paths env p, s)
+  | Papply (a, b) ->
+    Papply (rewrite_double_underscore_paths env a,
+            rewrite_double_underscore_paths env b)
+  | Pident id ->
+    let name = Ident.name id in
+    match find_double_underscore name with
+    | None -> p
+    | Some i ->
+      let better_lid =
+        Ldot
+          (Lident (String.sub name 0 i),
+           String.capitalize_ascii
+             (String.sub name (i + 2) (String.length name - i - 2)))
+      in
+      match Env.find_module_by_name better_lid env with
+      | exception Not_found -> p
+      | p', _ ->
+          if module_path_is_an_alias_of env p' ~alias_of:p then
+            p'
+          else
+          p
+
+let rewrite_double_underscore_paths env p =
+  if env == Env.empty then
+    p
+  else
+    rewrite_double_underscore_paths env p
+
+let rec tree_of_path namespace = function
+  | Pident id ->
+      Oide_ident (ident_name namespace id)
+  | Pdot(_, s) as path when non_shadowed_pervasive path ->
+      Oide_ident (Naming_context.pervasives_name namespace s)
+  | Pdot(Pident t, s)
+    when namespace=Type && not (Path.is_uident (Ident.name t)) ->
+      (* [t.A]: inline record of the constructor [A] from type [t] *)
+      Oide_dot (Oide_ident (ident_name Type t), s)
+  | Pdot(p, s) ->
+      Oide_dot (tree_of_path Module p, s)
+  | Papply(p1, p2) ->
+      Oide_apply (tree_of_path Module p1, tree_of_path Module p2)
+
+let tree_of_path namespace p =
+  tree_of_path namespace (rewrite_double_underscore_paths !printing_env p)
+
+let path ppf p =
+  !Oprint.out_ident ppf (tree_of_path Other p)
+
+let string_of_path p =
+  Format.asprintf "%a" path p
+
+let strings_of_paths namespace p =
+  reset_naming_context ();
+  let trees = List.map (tree_of_path namespace) p in
+  List.map (Format.asprintf "%a" !Oprint.out_ident) trees
+
+let () = Env.print_path := path
+
+(* Print a recursive annotation *)
+
+let tree_of_rec = function
+  | Trec_not -> Orec_not
+  | Trec_first -> Orec_first
+  | Trec_next -> Orec_next
+
+(* Print a raw type expression, with sharing *)
+
+let raw_list pr ppf = function
+    [] -> fprintf ppf "[]"
+  | a :: l ->
+      fprintf ppf "@[<1>[%a%t]@]" pr a
+        (fun ppf -> List.iter (fun x -> fprintf ppf ";@,%a" pr x) l)
+
+let kind_vars = ref []
+let kind_count = ref 0
+
+let rec safe_kind_repr v = function
+    Fvar {contents=Some k}  ->
+      if List.memq k v then "Fvar loop" else
+      safe_kind_repr (k::v) k
+  | Fvar r ->
+      let vid =
+        try List.assq r !kind_vars
+        with Not_found ->
+          let c = incr kind_count; !kind_count in
+          kind_vars := (r,c) :: !kind_vars;
+          c
+      in
+      Printf.sprintf "Fvar {None}@%d" vid
+  | Fpresent -> "Fpresent"
+  | Fabsent -> "Fabsent"
+
+let rec safe_commu_repr v = function
+    Cok -> "Cok"
+  | Cunknown -> "Cunknown"
+  | Clink r ->
+      if List.memq r v then "Clink loop" else
+      safe_commu_repr (r::v) !r
+
+let rec safe_repr v = function
+    {desc = Tlink t} when not (List.memq t v) ->
+      safe_repr (t::v) t
+  | t -> t
+
+let rec list_of_memo = function
+    Mnil -> []
+  | Mcons (_priv, p, _t1, _t2, rem) -> p :: list_of_memo rem
+  | Mlink rem -> list_of_memo !rem
+
+let print_name ppf = function
+    None -> fprintf ppf "None"
+  | Some name -> fprintf ppf "\"%s\"" name
+
+let string_of_label = function
+    Nolabel -> ""
+  | Labelled s -> s
+  | Optional s -> "?"^s
+
+let visited = ref []
+let rec raw_type ppf ty =
+  let ty = safe_repr [] ty in
+  if List.memq ty !visited then fprintf ppf "{id=%d}" ty.id else begin
+    visited := ty :: !visited;
+    fprintf ppf "@[<1>{id=%d;level=%d;scope=%d;desc=@,%a}@]" ty.id ty.level
+      ty.scope raw_type_desc ty.desc
+  end
+and raw_type_list tl = raw_list raw_type tl
+and raw_type_desc ppf = function
+    Tvar name -> fprintf ppf "Tvar %a" print_name name
+  | Tarrow(l,t1,t2,c) ->
+      fprintf ppf "@[<hov1>Tarrow(\"%s\",@,%a,@,%a,@,%s)@]"
+        (string_of_label l) raw_type t1 raw_type t2
+        (safe_commu_repr [] c)
+  | Ttuple tl ->
+      fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl
+  | Tconstr (p, tl, abbrev) ->
+      fprintf ppf "@[<hov1>Tconstr(@,%a,@,%a,@,%a)@]" path p
+        raw_type_list tl
+        (raw_list path) (list_of_memo !abbrev)
+  | Tobject (t, nm) ->
+      fprintf ppf "@[<hov1>Tobject(@,%a,@,@[<1>ref%t@])@]" raw_type t
+        (fun ppf ->
+          match !nm with None -> fprintf ppf " None"
+          | Some(p,tl) ->
+              fprintf ppf "(Some(@,%a,@,%a))" path p raw_type_list tl)
+  | Tfield (f, k, t1, t2) ->
+      fprintf ppf "@[<hov1>Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f
+        (safe_kind_repr [] k)
+        raw_type t1 raw_type t2
+  | Tnil -> fprintf ppf "Tnil"
+  | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t
+  | Tsubst t -> fprintf ppf "@[<1>Tsubst@,%a@]" raw_type t
+  | Tunivar name -> fprintf ppf "Tunivar %a" print_name name
+  | Tpoly (t, tl) ->
+      fprintf ppf "@[<hov1>Tpoly(@,%a,@,%a)@]"
+        raw_type t
+        raw_type_list tl
+  | Tvariant row ->
+      fprintf ppf
+        "@[<hov1>{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%B;@ %s%a;@ @[<1>%s%t@]}@]"
+        "row_fields="
+        (raw_list (fun ppf (l, f) ->
+          fprintf ppf "@[%s,@ %a@]" l raw_field f))
+        row.row_fields
+        "row_more=" raw_type row.row_more
+        "row_closed=" row.row_closed
+        "row_fixed=" raw_row_fixed row.row_fixed
+        "row_name="
+        (fun ppf ->
+          match row.row_name with None -> fprintf ppf "None"
+          | Some(p,tl) ->
+              fprintf ppf "Some(@,%a,@,%a)" path p raw_type_list tl)
+  | Tpackage (p, _, tl) ->
+      fprintf ppf "@[<hov1>Tpackage(@,%a@,%a)@]" path p
+        raw_type_list tl
+and raw_row_fixed ppf = function
+| None -> fprintf ppf "None"
+| Some Types.Fixed_private -> fprintf ppf "Some Fixed_private"
+| Some Types.Rigid -> fprintf ppf "Some Rigid"
+| Some Types.Univar t -> fprintf ppf "Some(Univar(%a))" raw_type t
+| Some Types.Reified p -> fprintf ppf "Some(Reified(%a))" path p
+
+and raw_field ppf = function
+    Rpresent None -> fprintf ppf "Rpresent None"
+  | Rpresent (Some t) -> fprintf ppf "@[<1>Rpresent(Some@,%a)@]" raw_type t
+  | Reither (c,tl,m,e) ->
+      fprintf ppf "@[<hov1>Reither(%B,@,%a,@,%B,@,@[<1>ref%t@])@]" c
+        raw_type_list tl m
+        (fun ppf ->
+          match !e with None -> fprintf ppf " None"
+          | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f)
+  | Rabsent -> fprintf ppf "Rabsent"
+
+let raw_type_expr ppf t =
+  visited := []; kind_vars := []; kind_count := 0;
+  raw_type ppf t;
+  visited := []; kind_vars := []
+
+let () = Btype.print_raw := raw_type_expr
+
+(* Normalize paths *)
+
+type param_subst = Id | Nth of int | Map of int list
+
+let is_nth = function
+    Nth _ -> true
+  | _ -> false
+
+let compose l1 = function
+  | Id -> Map l1
+  | Map l2 -> Map (List.map (List.nth l1) l2)
+  | Nth n  -> Nth (List.nth l1 n)
+
+let apply_subst s1 tyl =
+  if tyl = [] then []
+  (* cf. PR#7543: Typemod.type_package doesn't respect type constructor arity *)
+  else
+    match s1 with
+      Nth n1 -> [List.nth tyl n1]
+    | Map l1 -> List.map (List.nth tyl) l1
+    | Id -> tyl
+
+type best_path = Paths of Path.t list | Best of Path.t
+
+(** Short-paths cache: the five mutable variables below implement a one-slot
+    cache for short-paths
+ *)
+let printing_old = ref Env.empty
+let printing_pers = ref Concr.empty
+(** {!printing_old} and  {!printing_pers} are the keys of the one-slot cache *)
+
+let printing_depth = ref 0
+let printing_cont = ref ([] : Env.iter_cont list)
+let printing_map = ref Path.Map.empty
+(**
+   - {!printing_map} is the main value stored in the cache.
+   Note that it is evaluated lazily and its value is updated during printing.
+   - {!printing_dep} is the current exploration depth of the environment,
+   it is used to determine whenever the {!printing_map} should be evaluated
+   further before completing a request.
+   - {!printing_cont} is the list of continuations needed to evaluate
+   the {!printing_map} one level further (see also {!Env.run_iter_cont})
+*)
+
+let same_type t t' = repr t == repr t'
+
+let rec index l x =
+  match l with
+    [] -> raise Not_found
+  | a :: l -> if x == a then 0 else 1 + index l x
+
+let rec uniq = function
+    [] -> true
+  | a :: l -> not (List.memq a l) && uniq l
+
+let rec normalize_type_path ?(cache=false) env p =
+  try
+    let (params, ty, _) = Env.find_type_expansion p env in
+    let params = List.map repr params in
+    match repr ty with
+      {desc = Tconstr (p1, tyl, _)} ->
+        let tyl = List.map repr tyl in
+        if List.length params = List.length tyl
+        && List.for_all2 (==) params tyl
+        then normalize_type_path ~cache env p1
+        else if cache || List.length params <= List.length tyl
+             || not (uniq tyl) then (p, Id)
+        else
+          let l1 = List.map (index params) tyl in
+          let (p2, s2) = normalize_type_path ~cache env p1 in
+          (p2, compose l1 s2)
+    | ty ->
+        (p, Nth (index params ty))
+  with
+    Not_found ->
+      (Env.normalize_type_path None env p, Id)
+
+let penalty s =
+  if s <> "" && s.[0] = '_' then
+    10
+  else
+    match find_double_underscore s with
+    | None -> 1
+    | Some _ -> 10
+
+let rec path_size = function
+    Pident id ->
+      penalty (Ident.name id), -Ident.scope id
+  | Pdot (p, _) ->
+      let (l, b) = path_size p in (1+l, b)
+  | Papply (p1, p2) ->
+      let (l, b) = path_size p1 in
+      (l + fst (path_size p2), b)
+
+let same_printing_env env =
+  let used_pers = Env.used_persistent () in
+  Env.same_types !printing_old env && Concr.equal !printing_pers used_pers
+
+let set_printing_env env =
+  printing_env := env;
+  if !Clflags.real_paths ||
+     !printing_env == Env.empty ||
+     same_printing_env env then
+    ()
+  else begin
+    (* printf "Reset printing_map@."; *)
+    printing_old := env;
+    printing_pers := Env.used_persistent ();
+    printing_map := Path.Map.empty;
+    printing_depth := 0;
+    (* printf "Recompute printing_map.@."; *)
+    let cont =
+      Env.iter_types
+        (fun p (p', _decl) ->
+          let (p1, s1) = normalize_type_path env p' ~cache:true in
+          (* Format.eprintf "%a -> %a = %a@." path p path p' path p1 *)
+          if s1 = Id then
+          try
+            let r = Path.Map.find p1 !printing_map in
+            match !r with
+              Paths l -> r := Paths (p :: l)
+            | Best p' -> r := Paths [p; p'] (* assert false *)
+          with Not_found ->
+            printing_map := Path.Map.add p1 (ref (Paths [p])) !printing_map)
+        env in
+    printing_cont := [cont];
+  end
+
+let wrap_printing_env env f =
+  set_printing_env env; reset_naming_context ();
+  try_finally f ~always:(fun () -> set_printing_env Env.empty)
+
+let wrap_printing_env ~error env f =
+  if error then Env.without_cmis (wrap_printing_env env) f
+  else wrap_printing_env env f
+
+let rec lid_of_path = function
+    Path.Pident id ->
+      Longident.Lident (Ident.name id)
+  | Path.Pdot (p1, s) ->
+      Longident.Ldot (lid_of_path p1, s)
+  | Path.Papply (p1, p2) ->
+      Longident.Lapply (lid_of_path p1, lid_of_path p2)
+
+let is_unambiguous path env =
+  let l = Env.find_shadowed_types path env in
+  List.exists (Path.same path) l || (* concrete paths are ok *)
+  match l with
+    [] -> true
+  | p :: rem ->
+      (* allow also coherent paths:  *)
+      let normalize p = fst (normalize_type_path ~cache:true env p) in
+      let p' = normalize p in
+      List.for_all (fun p -> Path.same (normalize p) p') rem ||
+      (* also allow repeatedly defining and opening (for toplevel) *)
+      let id = lid_of_path p in
+      List.for_all (fun p -> lid_of_path p = id) rem &&
+      Path.same p (fst (Env.find_type_by_name id env))
+
+let rec get_best_path r =
+  match !r with
+    Best p' -> p'
+  | Paths [] -> raise Not_found
+  | Paths l ->
+      r := Paths [];
+      List.iter
+        (fun p ->
+          (* Format.eprintf "evaluating %a@." path p; *)
+          match !r with
+            Best p' when path_size p >= path_size p' -> ()
+          | _ -> if is_unambiguous p !printing_env then r := Best p)
+              (* else Format.eprintf "%a ignored as ambiguous@." path p *)
+        l;
+      get_best_path r
+
+let best_type_path p =
+  if !printing_env == Env.empty
+  then (p, Id)
+  else if !Clflags.real_paths
+  then (p, Id)
+  else
+    let (p', s) = normalize_type_path !printing_env p in
+    let get_path () = get_best_path (Path.Map.find  p' !printing_map) in
+    while !printing_cont <> [] &&
+      try fst (path_size (get_path ())) > !printing_depth with Not_found -> true
+    do
+      printing_cont := List.map snd (Env.run_iter_cont !printing_cont);
+      incr printing_depth;
+    done;
+    let p'' = try get_path () with Not_found -> p' in
+    (* Format.eprintf "%a = %a -> %a@." path p path p' path p''; *)
+    (p'', s)
+
+(* Print a type expression *)
+
+let names = ref ([] : (type_expr * string) list)
+let name_counter = ref 0
+let named_vars = ref ([] : string list)
+
+let weak_counter = ref 1
+let weak_var_map = ref TypeMap.empty
+let named_weak_vars = ref String.Set.empty
+
+let reset_names () = names := []; name_counter := 0; named_vars := []
+let add_named_var ty =
+  match ty.desc with
+    Tvar (Some name) | Tunivar (Some name) ->
+      if List.mem name !named_vars then () else
+      named_vars := name :: !named_vars
+  | _ -> ()
+
+let name_is_already_used name =
+  List.mem name !named_vars
+  || List.exists (fun (_, name') -> name = name') !names
+  || String.Set.mem name !named_weak_vars
+
+let rec new_name () =
+  let name =
+    if !name_counter < 26
+    then String.make 1 (Char.chr(97 + !name_counter))
+    else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^
+           Int.to_string(!name_counter / 26) in
+  incr name_counter;
+  if name_is_already_used name then new_name () else name
+
+let rec new_weak_name ty () =
+  let name = "weak" ^ Int.to_string !weak_counter in
+  incr weak_counter;
+  if name_is_already_used name then new_weak_name ty ()
+  else begin
+      named_weak_vars := String.Set.add name !named_weak_vars;
+      weak_var_map := TypeMap.add ty name !weak_var_map;
+      name
+    end
+
+let name_of_type name_generator t =
+  (* We've already been through repr at this stage, so t is our representative
+     of the union-find class. *)
+  try List.assq t !names with Not_found ->
+    try TypeMap.find t !weak_var_map with Not_found ->
+    let name =
+      match t.desc with
+        Tvar (Some name) | Tunivar (Some name) ->
+          (* Some part of the type we've already printed has assigned another
+           * unification variable to that name. We want to keep the name, so try
+           * adding a number until we find a name that's not taken. *)
+          let current_name = ref name in
+          let i = ref 0 in
+          while List.exists (fun (_, name') -> !current_name = name') !names do
+            current_name := name ^ (Int.to_string !i);
+            i := !i + 1;
+          done;
+          !current_name
+      | _ ->
+          (* No name available, create a new one *)
+          name_generator ()
+    in
+    (* Exception for type declarations *)
+    if name <> "_" then names := (t, name) :: !names;
+    name
+
+let check_name_of_type t = ignore(name_of_type new_name t)
+
+let remove_names tyl =
+  let tyl = List.map repr tyl in
+  names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names
+
+let visited_objects = ref ([] : type_expr list)
+let aliased = ref ([] : type_expr list)
+let delayed = ref ([] : type_expr list)
+
+let add_delayed t =
+  if not (List.memq t !delayed) then delayed := t :: !delayed
+
+let is_aliased ty = List.memq (proxy ty) !aliased
+let add_alias ty =
+  let px = proxy ty in
+  if not (is_aliased px) then begin
+    aliased := px :: !aliased;
+    add_named_var px
+  end
+
+let aliasable ty =
+  match ty.desc with
+    Tvar _ | Tunivar _ | Tpoly _ -> false
+  | Tconstr (p, _, _) ->
+      not (is_nth (snd (best_type_path p)))
+  | _ -> true
+
+let namable_row row =
+  row.row_name <> None &&
+  List.for_all
+    (fun (_, f) ->
+       match row_field_repr f with
+       | Reither(c, l, _, _) ->
+           row.row_closed && if c then l = [] else List.length l = 1
+       | _ -> true)
+    row.row_fields
+
+let rec mark_loops_rec visited ty =
+  let ty = repr ty in
+  let px = proxy ty in
+  if List.memq px visited && aliasable ty then add_alias px else
+    let visited = px :: visited in
+    match ty.desc with
+    | Tvar _ -> add_named_var ty
+    | Tarrow(_, ty1, ty2, _) ->
+        mark_loops_rec visited ty1; mark_loops_rec visited ty2
+    | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl
+    | Tconstr(p, tyl, _) ->
+        let (_p', s) = best_type_path p in
+        List.iter (mark_loops_rec visited) (apply_subst s tyl)
+    | Tpackage (_, _, tyl) ->
+        List.iter (mark_loops_rec visited) tyl
+    | Tvariant row ->
+        if List.memq px !visited_objects then add_alias px else
+         begin
+          let row = row_repr row in
+          if not (static_row row) then
+            visited_objects := px :: !visited_objects;
+          match row.row_name with
+          | Some(_p, tyl) when namable_row row ->
+              List.iter (mark_loops_rec visited) tyl
+          | _ ->
+              iter_row (mark_loops_rec visited) row
+         end
+    | Tobject (fi, nm) ->
+        if List.memq px !visited_objects then add_alias px else
+         begin
+          if opened_object ty then
+            visited_objects := px :: !visited_objects;
+          begin match !nm with
+          | None ->
+              let fields, _ = flatten_fields fi in
+              List.iter
+                (fun (_, kind, ty) ->
+                  if field_kind_repr kind = Fpresent then
+                    mark_loops_rec visited ty)
+                fields
+          | Some (_, l) ->
+              List.iter (mark_loops_rec visited) (List.tl l)
+          end
+        end
+    | Tfield(_, kind, ty1, ty2) when field_kind_repr kind = Fpresent ->
+        mark_loops_rec visited ty1; mark_loops_rec visited ty2
+    | Tfield(_, _, _, ty2) ->
+        mark_loops_rec visited ty2
+    | Tnil -> ()
+    | Tsubst ty -> mark_loops_rec visited ty
+    | Tlink _ -> fatal_error "Printtyp.mark_loops_rec (2)"
+    | Tpoly (ty, tyl) ->
+        List.iter (fun t -> add_alias t) tyl;
+        mark_loops_rec visited ty
+    | Tunivar _ -> add_named_var ty
+
+let mark_loops ty =
+  normalize_type ty;
+  mark_loops_rec [] ty;;
+
+let reset_loop_marks () =
+  visited_objects := []; aliased := []; delayed := []
+
+let reset_except_context () =
+  reset_names (); reset_loop_marks ()
+
+let reset () =
+  reset_naming_context (); Conflicts.reset ();
+  reset_except_context ()
+
+let reset_and_mark_loops ty =
+  reset_except_context (); mark_loops ty
+
+let reset_and_mark_loops_list tyl =
+  reset_except_context (); List.iter mark_loops tyl
+
+(* Disabled in classic mode when printing an unification error *)
+let print_labels = ref true
+
+let rec tree_of_typexp sch ty =
+  let ty = repr ty in
+  let px = proxy ty in
+  if List.mem_assq px !names && not (List.memq px !delayed) then
+   let mark = is_non_gen sch ty in
+   let name = name_of_type (if mark then new_weak_name ty else new_name) px in
+   Otyp_var (mark, name) else
+
+  let pr_typ () =
+    match ty.desc with
+    | Tvar _ ->
+        (*let lev =
+          if is_non_gen sch ty then "/" ^ Int.to_string ty.level else "" in*)
+        let non_gen = is_non_gen sch ty in
+        let name_gen = if non_gen then new_weak_name ty else new_name in
+        Otyp_var (non_gen, name_of_type name_gen ty)
+    | Tarrow(l, ty1, ty2, _) ->
+        let lab =
+          if !print_labels || is_optional l then string_of_label l else ""
+        in
+        let t1 =
+          if is_optional l then
+            match (repr ty1).desc with
+            | Tconstr(path, [ty], _)
+              when Path.same path Predef.path_option ->
+                tree_of_typexp sch ty
+            | _ -> Otyp_stuff "<hidden>"
+          else tree_of_typexp sch ty1 in
+        Otyp_arrow (lab, t1, tree_of_typexp sch ty2)
+    | Ttuple tyl ->
+        Otyp_tuple (tree_of_typlist sch tyl)
+    | Tconstr(p, tyl, _abbrev) ->
+        let p', s = best_type_path p in
+        let tyl' = apply_subst s tyl in
+        if is_nth s && not (tyl'=[]) then tree_of_typexp sch (List.hd tyl') else
+        Otyp_constr (tree_of_path Type p', tree_of_typlist sch tyl')
+    | Tvariant row ->
+        let row = row_repr row in
+        let fields =
+          if row.row_closed then
+            List.filter (fun (_, f) -> row_field_repr f <> Rabsent)
+              row.row_fields
+          else row.row_fields in
+        let present =
+          List.filter
+            (fun (_, f) ->
+               match row_field_repr f with
+               | Rpresent _ -> true
+               | _ -> false)
+            fields in
+        let all_present = List.length present = List.length fields in
+        begin match row.row_name with
+        | Some(p, tyl) when namable_row row ->
+            let (p', s) = best_type_path p in
+            let id = tree_of_path Type p' in
+            let args = tree_of_typlist sch (apply_subst s tyl) in
+            let out_variant =
+              if is_nth s then List.hd args else Otyp_constr (id, args) in
+            if row.row_closed && all_present then
+              out_variant
+            else
+              let non_gen = is_non_gen sch px in
+              let tags =
+                if all_present then None else Some (List.map fst present) in
+              Otyp_variant (non_gen, Ovar_typ out_variant, row.row_closed, tags)
+        | _ ->
+            let non_gen =
+              not (row.row_closed && all_present) && is_non_gen sch px in
+            let fields = List.map (tree_of_row_field sch) fields in
+            let tags =
+              if all_present then None else Some (List.map fst present) in
+            Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags)
+        end
+    | Tobject (fi, nm) ->
+        tree_of_typobject sch fi !nm
+    | Tnil | Tfield _ ->
+        tree_of_typobject sch ty None
+    | Tsubst ty ->
+        tree_of_typexp sch ty
+    | Tlink _ ->
+        fatal_error "Printtyp.tree_of_typexp"
+    | Tpoly (ty, []) ->
+        tree_of_typexp sch ty
+    | Tpoly (ty, tyl) ->
+        (*let print_names () =
+          List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names;
+          prerr_string "; " in *)
+        let tyl = List.map repr tyl in
+        if tyl = [] then tree_of_typexp sch ty else begin
+          let old_delayed = !delayed in
+          (* Make the names delayed, so that the real type is
+             printed once when used as proxy *)
+          List.iter add_delayed tyl;
+          let tl = List.map (name_of_type new_name) tyl in
+          let tr = Otyp_poly (tl, tree_of_typexp sch ty) in
+          (* Forget names when we leave scope *)
+          remove_names tyl;
+          delayed := old_delayed; tr
+        end
+    | Tunivar _ ->
+        Otyp_var (false, name_of_type new_name ty)
+    | Tpackage (p, n, tyl) ->
+        let n =
+          List.map (fun li -> String.concat "." (Longident.flatten li)) n in
+        Otyp_module (tree_of_path Module_type p, n, tree_of_typlist sch tyl)
+  in
+  if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed;
+  if is_aliased px && aliasable ty then begin
+    check_name_of_type px;
+    Otyp_alias (pr_typ (), name_of_type new_name px) end
+  else pr_typ ()
+
+and tree_of_row_field sch (l, f) =
+  match row_field_repr f with
+  | Rpresent None | Reither(true, [], _, _) -> (l, false, [])
+  | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty])
+  | Reither(c, tyl, _, _) ->
+      if c (* contradiction: constant constructor with an argument *)
+      then (l, true, tree_of_typlist sch tyl)
+      else (l, false, tree_of_typlist sch tyl)
+  | Rabsent -> (l, false, [] (* actually, an error *))
+
+and tree_of_typlist sch tyl =
+  List.map (tree_of_typexp sch) tyl
+
+and tree_of_typobject sch fi nm =
+  begin match nm with
+  | None ->
+      let pr_fields fi =
+        let (fields, rest) = flatten_fields fi in
+        let present_fields =
+          List.fold_right
+            (fun (n, k, t) l ->
+               match field_kind_repr k with
+               | Fpresent -> (n, t) :: l
+               | _ -> l)
+            fields [] in
+        let sorted_fields =
+          List.sort
+            (fun (n, _) (n', _) -> String.compare n n') present_fields in
+        tree_of_typfields sch rest sorted_fields in
+      let (fields, rest) = pr_fields fi in
+      Otyp_object (fields, rest)
+  | Some (p, ty :: tyl) ->
+      let non_gen = is_non_gen sch (repr ty) in
+      let args = tree_of_typlist sch tyl in
+      let (p', s) = best_type_path p in
+      assert (s = Id);
+      Otyp_class (non_gen, tree_of_path Type p', args)
+  | _ ->
+      fatal_error "Printtyp.tree_of_typobject"
+  end
+
+and is_non_gen sch ty =
+    sch && is_Tvar ty && ty.level <> generic_level
+
+and tree_of_typfields sch rest = function
+  | [] ->
+      let rest =
+        match rest.desc with
+        | Tvar _ | Tunivar _ -> Some (is_non_gen sch rest)
+        | Tconstr _ -> Some false
+        | Tnil -> None
+        | _ -> fatal_error "typfields (1)"
+      in
+      ([], rest)
+  | (s, t) :: l ->
+      let field = (s, tree_of_typexp sch t) in
+      let (fields, rest) = tree_of_typfields sch rest l in
+      (field :: fields, rest)
+
+let typexp sch ppf ty =
+  !Oprint.out_type ppf (tree_of_typexp sch ty)
+
+let marked_type_expr ppf ty = typexp false ppf ty
+
+let type_expr ppf ty =
+  (* [type_expr] is used directly by error message printers,
+     we mark eventual loops ourself to avoid any misuse and stack overflow *)
+  reset_and_mark_loops ty;
+  marked_type_expr ppf ty
+
+and type_sch ppf ty = typexp true ppf ty
+
+and type_scheme ppf ty = reset_and_mark_loops ty; typexp true ppf ty
+
+let type_path ppf p =
+  let (p', s) = best_type_path p in
+  let p = if (s = Id) then p' else p in
+  let t = tree_of_path Type p in
+  !Oprint.out_ident ppf t
+
+(* Maxence *)
+let type_scheme_max ?(b_reset_names=true) ppf ty =
+  if b_reset_names then reset_names () ;
+  typexp true ppf ty
+(* End Maxence *)
+
+let tree_of_type_scheme ty = reset_and_mark_loops ty; tree_of_typexp true ty
+
+(* Print one type declaration *)
+
+let tree_of_constraints params =
+  List.fold_right
+    (fun ty list ->
+       let ty' = unalias ty in
+       if proxy ty != proxy ty' then
+         let tr = tree_of_typexp true ty in
+         (tr, tree_of_typexp true ty') :: list
+       else list)
+    params []
+
+let filter_params tyl =
+  let params =
+    List.fold_left
+      (fun tyl ty ->
+        let ty = repr ty in
+        if List.memq ty tyl then Btype.newgenty (Tsubst ty) :: tyl
+        else ty :: tyl)
+      [] tyl
+  in List.rev params
+
+let mark_loops_constructor_arguments = function
+  | Cstr_tuple l -> List.iter mark_loops l
+  | Cstr_record l -> List.iter (fun l -> mark_loops l.ld_type) l
+
+let rec tree_of_type_decl id decl =
+
+  reset_except_context();
+
+  let params = filter_params decl.type_params in
+
+  begin match decl.type_manifest with
+  | Some ty ->
+      let vars = free_variables ty in
+      List.iter
+        (function {desc = Tvar (Some "_")} as ty ->
+            if List.memq ty vars then ty.desc <- Tvar None
+          | _ -> ())
+        params
+  | None -> ()
+  end;
+
+  List.iter add_alias params;
+  List.iter mark_loops params;
+  List.iter check_name_of_type (List.map proxy params);
+  let ty_manifest =
+    match decl.type_manifest with
+    | None -> None
+    | Some ty ->
+        let ty =
+          (* Special hack to hide variant name *)
+          match repr ty with {desc=Tvariant row} ->
+            let row = row_repr row in
+            begin match row.row_name with
+              Some (Pident id', _) when Ident.same id id' ->
+                newgenty (Tvariant {row with row_name = None})
+            | _ -> ty
+            end
+          | _ -> ty
+        in
+        mark_loops ty;
+        Some ty
+  in
+  begin match decl.type_kind with
+  | Type_abstract -> ()
+  | Type_variant cstrs ->
+      List.iter
+        (fun c ->
+           mark_loops_constructor_arguments c.cd_args;
+           Option.iter mark_loops c.cd_res)
+        cstrs
+  | Type_record(l, _rep) ->
+      List.iter (fun l -> mark_loops l.ld_type) l
+  | Type_open -> ()
+  end;
+
+  let type_param =
+    function
+    | Otyp_var (_, id) -> id
+    | _ -> "?"
+  in
+  let type_defined decl =
+    let abstr =
+      match decl.type_kind with
+        Type_abstract ->
+          decl.type_manifest = None || decl.type_private = Private
+      | Type_record _ ->
+          decl.type_private = Private
+      | Type_variant tll ->
+          decl.type_private = Private ||
+          List.exists (fun cd -> cd.cd_res <> None) tll
+      | Type_open ->
+          decl.type_manifest = None
+    in
+    let vari =
+      List.map2
+        (fun ty v ->
+          let is_var = is_Tvar (repr ty) in
+          if abstr || not is_var then
+            let inj =
+              decl.type_kind = Type_abstract && Variance.mem Inj v &&
+              match decl.type_manifest with
+              | None -> true
+              | Some ty -> (* only abstract or private row types *)
+                  decl.type_private = Private &&
+                  Btype.is_constr_row ~allow_ident:true (Btype.row_of_type ty)
+            and (co, cn) = Variance.get_upper v in
+            (if not cn then Covariant else
+             if not co then Contravariant else NoVariance),
+            (if inj then Injective else NoInjectivity)
+          else (NoVariance, NoInjectivity))
+        decl.type_params decl.type_variance
+    in
+    (Ident.name id,
+     List.map2 (fun ty cocn -> type_param (tree_of_typexp false ty), cocn)
+       params vari)
+  in
+  let tree_of_manifest ty1 =
+    match ty_manifest with
+    | None -> ty1
+    | Some ty -> Otyp_manifest (tree_of_typexp false ty, ty1)
+  in
+  let (name, args) = type_defined decl in
+  let constraints = tree_of_constraints params in
+  let ty, priv =
+    match decl.type_kind with
+    | Type_abstract ->
+        begin match ty_manifest with
+        | None -> (Otyp_abstract, Public)
+        | Some ty ->
+            tree_of_typexp false ty, decl.type_private
+        end
+    | Type_variant cstrs ->
+        tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)),
+        decl.type_private
+    | Type_record(lbls, _rep) ->
+        tree_of_manifest (Otyp_record (List.map tree_of_label lbls)),
+        decl.type_private
+    | Type_open ->
+        tree_of_manifest Otyp_open,
+        decl.type_private
+  in
+    { otype_name = name;
+      otype_params = args;
+      otype_type = ty;
+      otype_private = priv;
+      otype_immediate = Type_immediacy.of_attributes decl.type_attributes;
+      otype_unboxed = decl.type_unboxed.unboxed;
+      otype_cstrs = constraints }
+
+and tree_of_constructor_arguments = function
+  | Cstr_tuple l -> tree_of_typlist false l
+  | Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ]
+
+and tree_of_constructor cd =
+  let name = Ident.name cd.cd_id in
+  let arg () = tree_of_constructor_arguments cd.cd_args in
+  match cd.cd_res with
+  | None -> (name, arg (), None)
+  | Some res ->
+      let nm = !names in
+      names := [];
+      let ret = tree_of_typexp false res in
+      let args = arg () in
+      names := nm;
+      (name, args, Some ret)
+
+and tree_of_label l =
+  (Ident.name l.ld_id, l.ld_mutable = Mutable, tree_of_typexp false l.ld_type)
+
+let constructor ppf c =
+  reset_except_context ();
+  !Oprint.out_constr ppf (tree_of_constructor c)
+
+let label ppf l =
+  reset_except_context ();
+  !Oprint.out_label ppf (tree_of_label l)
+
+let tree_of_type_declaration id decl rs =
+  Osig_type (tree_of_type_decl id decl, tree_of_rec rs)
+
+let type_declaration id ppf decl =
+  !Oprint.out_sig_item ppf (tree_of_type_declaration id decl Trec_first)
+
+let constructor_arguments ppf a =
+  let tys = tree_of_constructor_arguments a in
+  !Oprint.out_type ppf (Otyp_tuple tys)
+
+(* Print an extension declaration *)
+
+let extension_constructor_args_and_ret_type_subtree ext_args ext_ret_type =
+  match ext_ret_type with
+  | None -> (tree_of_constructor_arguments ext_args, None)
+  | Some res ->
+    let nm = !names in
+    names := [];
+    let ret = tree_of_typexp false res in
+    let args = tree_of_constructor_arguments ext_args in
+    names := nm;
+    (args, Some ret)
+
+let tree_of_extension_constructor id ext es =
+  reset_except_context ();
+  let ty_name = Path.name ext.ext_type_path in
+  let ty_params = filter_params ext.ext_type_params in
+  List.iter add_alias ty_params;
+  List.iter mark_loops ty_params;
+  List.iter check_name_of_type (List.map proxy ty_params);
+  mark_loops_constructor_arguments ext.ext_args;
+  Option.iter mark_loops ext.ext_ret_type;
+  let type_param =
+    function
+    | Otyp_var (_, id) -> id
+    | _ -> "?"
+  in
+  let ty_params =
+    List.map (fun ty -> type_param (tree_of_typexp false ty)) ty_params
+  in
+  let name = Ident.name id in
+  let args, ret =
+    extension_constructor_args_and_ret_type_subtree
+      ext.ext_args
+      ext.ext_ret_type
+  in
+  let ext =
+    { oext_name = name;
+      oext_type_name = ty_name;
+      oext_type_params = ty_params;
+      oext_args = args;
+      oext_ret_type = ret;
+      oext_private = ext.ext_private }
+  in
+  let es =
+    match es with
+        Text_first -> Oext_first
+      | Text_next -> Oext_next
+      | Text_exception -> Oext_exception
+  in
+    Osig_typext (ext, es)
+
+let extension_constructor id ppf ext =
+  !Oprint.out_sig_item ppf (tree_of_extension_constructor id ext Text_first)
+
+let extension_only_constructor id ppf ext =
+  reset_except_context ();
+  let name = Ident.name id in
+  let args, ret =
+    extension_constructor_args_and_ret_type_subtree
+      ext.ext_args
+      ext.ext_ret_type
+  in
+  Format.fprintf ppf "@[<hv>%a@]"
+    !Oprint.out_constr (name, args, ret)
+
+(* Print a value declaration *)
+
+let tree_of_value_description id decl =
+  (* Format.eprintf "@[%a@]@." raw_type_expr decl.val_type; *)
+  let id = Ident.name id in
+  let ty = tree_of_type_scheme decl.val_type in
+  let vd =
+    { oval_name = id;
+      oval_type = ty;
+      oval_prims = [];
+      oval_attributes = [] }
+  in
+  let vd =
+    match decl.val_kind with
+    | Val_prim p -> Primitive.print p vd
+    | _ -> vd
+  in
+  Osig_value vd
+
+let value_description id ppf decl =
+  !Oprint.out_sig_item ppf (tree_of_value_description id decl)
+
+(* Print a class type *)
+
+let method_type (_, kind, ty) =
+  match field_kind_repr kind, repr ty with
+    Fpresent, {desc=Tpoly(ty, tyl)} -> (ty, tyl)
+  | _       , ty                    -> (ty, [])
+
+let tree_of_metho sch concrete csil (lab, kind, ty) =
+  if lab <> dummy_method then begin
+    let kind = field_kind_repr kind in
+    let priv = kind <> Fpresent in
+    let virt = not (Concr.mem lab concrete) in
+    let (ty, tyl) = method_type (lab, kind, ty) in
+    let tty = tree_of_typexp sch ty in
+    remove_names tyl;
+    Ocsg_method (lab, priv, virt, tty) :: csil
+  end
+  else csil
+
+let rec prepare_class_type params = function
+  | Cty_constr (_p, tyl, cty) ->
+      let sty = Ctype.self_type cty in
+      if List.memq (proxy sty) !visited_objects
+      || not (List.for_all is_Tvar params)
+      || List.exists (deep_occur sty) tyl
+      then prepare_class_type params cty
+      else List.iter mark_loops tyl
+  | Cty_signature sign ->
+      let sty = repr sign.csig_self in
+      (* Self may have a name *)
+      let px = proxy sty in
+      if List.memq px !visited_objects then add_alias sty
+      else visited_objects := px :: !visited_objects;
+      let (fields, _) =
+        Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
+      in
+      List.iter (fun met -> mark_loops (fst (method_type met))) fields;
+      Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.csig_vars
+  | Cty_arrow (_, ty, cty) ->
+      mark_loops ty;
+      prepare_class_type params cty
+
+let rec tree_of_class_type sch params =
+  function
+  | Cty_constr (p', tyl, cty) ->
+      let sty = Ctype.self_type cty in
+      if List.memq (proxy sty) !visited_objects
+      || not (List.for_all is_Tvar params)
+      then
+        tree_of_class_type sch params cty
+      else
+        let namespace = Namespace.best_class_namespace p' in
+        Octy_constr (tree_of_path namespace p', tree_of_typlist true tyl)
+  | Cty_signature sign ->
+      let sty = repr sign.csig_self in
+      let self_ty =
+        if is_aliased sty then
+          Some (Otyp_var (false, name_of_type new_name (proxy sty)))
+        else None
+      in
+      let (fields, _) =
+        Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
+      in
+      let csil = [] in
+      let csil =
+        List.fold_left
+          (fun csil (ty1, ty2) -> Ocsg_constraint (ty1, ty2) :: csil)
+          csil (tree_of_constraints params)
+      in
+      let all_vars =
+        Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.csig_vars []
+      in
+      (* Consequence of PR#3607: order of Map.fold has changed! *)
+      let all_vars = List.rev all_vars in
+      let csil =
+        List.fold_left
+          (fun csil (l, m, v, t) ->
+            Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp sch t)
+            :: csil)
+          csil all_vars
+      in
+      let csil =
+        List.fold_left (tree_of_metho sch sign.csig_concr) csil fields
+      in
+      Octy_signature (self_ty, List.rev csil)
+  | Cty_arrow (l, ty, cty) ->
+      let lab =
+        if !print_labels || is_optional l then string_of_label l else ""
+      in
+      let tr =
+       if is_optional l then
+         match (repr ty).desc with
+         | Tconstr(path, [ty], _) when Path.same path Predef.path_option ->
+             tree_of_typexp sch ty
+         | _ -> Otyp_stuff "<hidden>"
+       else tree_of_typexp sch ty in
+      Octy_arrow (lab, tr, tree_of_class_type sch params cty)
+
+let class_type ppf cty =
+  reset ();
+  prepare_class_type [] cty;
+  !Oprint.out_class_type ppf (tree_of_class_type false [] cty)
+
+let tree_of_class_param param variance =
+  (match tree_of_typexp true param with
+    Otyp_var (_, s) -> s
+  | _ -> "?"),
+  if is_Tvar (repr param) then Asttypes.(NoVariance, NoInjectivity)
+                          else variance
+
+let class_variance =
+  let open Variance in let open Asttypes in
+  List.map (fun v ->
+    (if not (mem May_pos v) then Contravariant else
+     if not (mem May_neg v) then Covariant else NoVariance),
+    NoInjectivity)
+
+let tree_of_class_declaration id cl rs =
+  let params = filter_params cl.cty_params in
+
+  reset_except_context ();
+  List.iter add_alias params;
+  prepare_class_type params cl.cty_type;
+  let sty = Ctype.self_type cl.cty_type in
+  List.iter mark_loops params;
+
+  List.iter check_name_of_type (List.map proxy params);
+  if is_aliased sty then check_name_of_type (proxy sty);
+
+  let vir_flag = cl.cty_new = None in
+  Osig_class
+    (vir_flag, Ident.name id,
+     List.map2 tree_of_class_param params (class_variance cl.cty_variance),
+     tree_of_class_type true params cl.cty_type,
+     tree_of_rec rs)
+
+let class_declaration id ppf cl =
+  !Oprint.out_sig_item ppf (tree_of_class_declaration id cl Trec_first)
+
+let tree_of_cltype_declaration id cl rs =
+  let params = List.map repr cl.clty_params in
+
+  reset_except_context ();
+  List.iter add_alias params;
+  prepare_class_type params cl.clty_type;
+  let sty = Ctype.self_type cl.clty_type in
+  List.iter mark_loops params;
+
+  List.iter check_name_of_type (List.map proxy params);
+  if is_aliased sty then check_name_of_type (proxy sty);
+
+  let sign = Ctype.signature_of_class_type cl.clty_type in
+
+  let virt =
+    let (fields, _) =
+      Ctype.flatten_fields (Ctype.object_fields sign.csig_self) in
+    List.exists
+      (fun (lab, _, _) ->
+         not (lab = dummy_method || Concr.mem lab sign.csig_concr))
+      fields
+    || Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.csig_vars false
+  in
+
+  Osig_class_type
+    (virt, Ident.name id,
+     List.map2 tree_of_class_param params (class_variance cl.clty_variance),
+     tree_of_class_type true params cl.clty_type,
+     tree_of_rec rs)
+
+let cltype_declaration id ppf cl =
+  !Oprint.out_sig_item ppf (tree_of_cltype_declaration id cl Trec_first)
+
+(* Print a module type *)
+
+let wrap_env fenv ftree arg =
+  (* We save the current value of the short-path cache *)
+  (* From keys *)
+  let env = !printing_env in
+  let old_pers = !printing_pers in
+  (* to data *)
+  let old_map = !printing_map in
+  let old_depth = !printing_depth in
+  let old_cont = !printing_cont in
+  set_printing_env (fenv env);
+  let tree = ftree arg in
+  if !Clflags.real_paths
+     || same_printing_env env then ()
+   (* our cached key is still live in the cache, and we want to keep all
+      progress made on the computation of the [printing_map] *)
+  else begin
+    (* we restore the snapshotted cache before calling set_printing_env *)
+    printing_old := env;
+    printing_pers := old_pers;
+    printing_depth := old_depth;
+    printing_cont := old_cont;
+    printing_map := old_map
+  end;
+  set_printing_env env;
+  tree
+
+let filter_rem_sig item rem =
+  match item, rem with
+  | Sig_class _, ctydecl :: tydecl1 :: tydecl2 :: rem ->
+      ([ctydecl; tydecl1; tydecl2], rem)
+  | Sig_class_type _, tydecl1 :: tydecl2 :: rem ->
+      ([tydecl1; tydecl2], rem)
+  | _ ->
+      ([], rem)
+
+let dummy =
+  {
+    type_params = [];
+    type_arity = 0;
+    type_kind = Type_abstract;
+    type_private = Public;
+    type_manifest = None;
+    type_variance = [];
+    type_separability = [];
+    type_is_newtype = false;
+    type_expansion_scope = Btype.lowest_level;
+    type_loc = Location.none;
+    type_attributes = [];
+    type_immediate = Unknown;
+    type_unboxed = unboxed_false_default_false;
+    type_uid = Uid.internal_not_actually_unique;
+  }
+
+let hide ids env = List.fold_right
+    (fun id -> Env.add_type ~check:false (Ident.rename id) dummy)
+    ids env
+
+let hide_rec_items = function
+  | Sig_type(id, _decl, rs, _) ::rem
+    when rs = Trec_first && not !Clflags.real_paths ->
+      let rec get_ids = function
+          Sig_type (id, _, Trec_next, _) :: rem ->
+            id :: get_ids rem
+        | _ -> []
+      in
+      let ids = id :: get_ids rem in
+      set_printing_env
+        (hide ids !printing_env)
+  | _ -> ()
+
+let recursive_sigitem = function
+  | Sig_class(id,_,rs,_) -> Some(id,rs,3)
+  | Sig_class_type (id,_,rs,_) -> Some(id,rs,2)
+  | Sig_type(id, _, rs, _)
+  | Sig_module(id, _, _, rs, _) -> Some (id,rs,0)
+  | _ -> None
+
+let skip k l = snd (Misc.Stdlib.List.split_at k l)
+
+let protect_rec_items items =
+  let rec get_ids recs = function
+    | [] -> []
+    | item :: rem -> match recursive_sigitem item with
+      | Some (id, r, k ) when r = recs -> id :: get_ids Trec_next (skip k rem)
+      | _ -> [] in
+  List.iter Naming_context.add_protected (get_ids Trec_first items)
+
+let stop_type_group env =
+  Naming_context.reset_protected ();
+  set_printing_env env
+
+let still_in_type_group env' in_type_group item =
+  match in_type_group, recursive_sigitem item with
+  | true, Some (_,Trec_next,_) -> true
+  | _, Some (_, (Trec_not | Trec_first),_) ->
+      stop_type_group env' ; true
+  | _ -> stop_type_group env'; false
+
+let rec tree_of_modtype ?(ellipsis=false) = function
+  | Mty_ident p ->
+      Omty_ident (tree_of_path Module_type p)
+  | Mty_signature sg ->
+      Omty_signature (if ellipsis then [Osig_ellipsis]
+                      else tree_of_signature sg)
+  | Mty_functor(param, ty_res) ->
+      let param, res =
+        match param with
+        | Unit -> None, tree_of_modtype ~ellipsis ty_res
+        | Named (param, ty_arg) ->
+          let name, env =
+            match param with
+            | None -> None, fun env -> env
+            | Some id ->
+                Some (Ident.name id),
+                Env.add_module ~arg:true id Mp_present ty_arg
+          in
+          Some (name, tree_of_modtype ~ellipsis:false ty_arg),
+          wrap_env env (tree_of_modtype ~ellipsis) ty_res
+      in
+      Omty_functor (param, res)
+  | Mty_alias p ->
+      Omty_alias (tree_of_path Module p)
+
+and tree_of_signature sg =
+  wrap_env (fun env -> env) (tree_of_signature_rec !printing_env false) sg
+
+and tree_of_signature_rec env' in_type_group = function
+    [] -> stop_type_group env'; []
+  | item :: rem as items ->
+      let in_type_group = still_in_type_group env' in_type_group item in
+      let (sg, rem) = filter_rem_sig item rem in
+      hide_rec_items items;
+      protect_rec_items items;
+      reset_naming_context ();
+      let trees = trees_of_sigitem item in
+      let env' = Env.add_signature (item :: sg) env' in
+      trees @ tree_of_signature_rec env' in_type_group rem
+
+and trees_of_sigitem = function
+  | Sig_value(id, decl, _) ->
+      [tree_of_value_description id decl]
+  | Sig_type(id, _, _, _) when is_row_name (Ident.name id) ->
+      []
+  | Sig_type(id, decl, rs, _) ->
+      [tree_of_type_declaration id decl rs]
+  | Sig_typext(id, ext, es, _) ->
+      [tree_of_extension_constructor id ext es]
+  | Sig_module(id, _, md, rs, _) ->
+      let ellipsis =
+        List.exists (function
+          | Parsetree.{attr_name = {txt="..."}; attr_payload = PStr []} -> true
+          | _ -> false)
+          md.md_attributes in
+      [tree_of_module id md.md_type rs ~ellipsis]
+  | Sig_modtype(id, decl, _) ->
+      [tree_of_modtype_declaration id decl]
+  | Sig_class(id, decl, rs, _) ->
+      [tree_of_class_declaration id decl rs]
+  | Sig_class_type(id, decl, rs, _) ->
+      [tree_of_cltype_declaration id decl rs]
+
+and tree_of_modtype_declaration id decl =
+  let mty =
+    match decl.mtd_type with
+    | None -> Omty_abstract
+    | Some mty -> tree_of_modtype mty
+  in
+  Osig_modtype (Ident.name id, mty)
+
+and tree_of_module id ?ellipsis mty rs =
+  Osig_module (Ident.name id, tree_of_modtype ?ellipsis mty, tree_of_rec rs)
+
+let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty)
+let modtype_declaration id ppf decl =
+  !Oprint.out_sig_item ppf (tree_of_modtype_declaration id decl)
+
+(* For the toplevel: merge with tree_of_signature? *)
+
+(* Refresh weak variable map in the toplevel *)
+let refresh_weak () =
+  let refresh t name (m,s) =
+    if is_non_gen true (repr t) then
+      begin
+        TypeMap.add t name m,
+        String.Set.add name s
+      end
+    else m, s in
+  let m, s =
+    TypeMap.fold refresh !weak_var_map (TypeMap.empty ,String.Set.empty)  in
+  named_weak_vars := s;
+  weak_var_map := m
+
+let print_items showval env x =
+  refresh_weak();
+  reset_naming_context ();
+  Conflicts.reset ();
+  let rec print showval in_type_group env = function
+  | [] -> stop_type_group env; []
+  | item :: rem as items ->
+      let in_type_group = still_in_type_group env in_type_group item in
+      let (sg, rem) = filter_rem_sig item rem in
+      hide_rec_items items;
+      protect_rec_items items;
+      reset_naming_context ();
+      let trees = trees_of_sigitem item in
+      List.map (fun d -> (d, showval env item)) trees @
+      print showval in_type_group (Env.add_signature (item :: sg) env) rem in
+  print showval false env x
+
+(* Print a signature body (used by -i when compiling a .ml) *)
+
+let print_signature ppf tree =
+  fprintf ppf "@[<v>%a@]" !Oprint.out_signature tree
+
+let signature ppf sg =
+  fprintf ppf "%a" print_signature (tree_of_signature sg)
+
+(* Print a signature body (used by -i when compiling a .ml) *)
+let printed_signature sourcefile ppf sg =
+  (* we are tracking any collision event for warning 63 *)
+  Conflicts.reset ();
+  reset_naming_context ();
+  let t = tree_of_signature sg in
+  if Warnings.(is_active @@ Erroneous_printed_signature "")
+  && Conflicts.exists ()
+  then begin
+    let conflicts = Format.asprintf "%t" Conflicts.print_explanations in
+    Location.prerr_warning (Location.in_file sourcefile)
+      (Warnings.Erroneous_printed_signature conflicts);
+    Warnings.check_fatal ()
+  end;
+  fprintf ppf "%a" print_signature t
+
+(* Print an unification error *)
+
+let same_path t t' =
+  let t = repr t and t' = repr t' in
+  t == t' ||
+  match t.desc, t'.desc with
+    Tconstr(p,tl,_), Tconstr(p',tl',_) ->
+      let (p1, s1) = best_type_path p and (p2, s2)  = best_type_path p' in
+      begin match s1, s2 with
+        Nth n1, Nth n2 when n1 = n2 -> true
+      | (Id | Map _), (Id | Map _) when Path.same p1 p2 ->
+          let tl = apply_subst s1 tl and tl' = apply_subst s2 tl' in
+          List.length tl = List.length tl' &&
+          List.for_all2 same_type tl tl'
+      | _ -> false
+      end
+  | _ ->
+      false
+
+type 'a diff = Same of 'a | Diff of 'a * 'a
+
+let trees_of_type_expansion (t,t') =
+  if same_path t t'
+  then begin add_delayed (proxy t); Same (tree_of_typexp false t) end
+  else
+    let t' = if proxy t == proxy t' then unalias t' else t' in
+    (* beware order matter due to side effect,
+       e.g. when printing object types *)
+    let first = tree_of_typexp false t in
+    let second = tree_of_typexp false t' in
+    if first = second then Same first
+    else Diff(first,second)
+
+let type_expansion ppf = function
+  | Same t -> !Oprint.out_type ppf t
+  | Diff(t,t') ->
+      fprintf ppf "@[<2>%a@ =@ %a@]"  !Oprint.out_type t  !Oprint.out_type t'
+
+module Trace = Ctype.Unification_trace
+
+let trees_of_trace = List.map (Trace.map_diff trees_of_type_expansion)
+
+let trees_of_type_path_expansion (tp,tp') =
+  if Path.same tp tp' then Same(tree_of_path Type tp) else
+    Diff(tree_of_path Type tp, tree_of_path Type tp')
+
+let type_path_expansion ppf = function
+  | Same p -> !Oprint.out_ident ppf p
+  | Diff(p,p') ->
+      fprintf ppf "@[<2>%a@ =@ %a@]"
+        !Oprint.out_ident p
+        !Oprint.out_ident p'
+
+let rec trace fst txt ppf = function
+  | {Trace.got; expected} :: rem ->
+      if not fst then fprintf ppf "@,";
+      fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@] %a"
+       type_expansion got txt type_expansion expected
+       (trace false txt) rem
+  | _ -> ()
+
+
+type printing_status =
+  | Discard
+  | Keep
+  | Optional_refinement
+  (** An [Optional_refinement] printing status is attributed to trace
+      elements that are focusing on a new subpart of a structural type.
+      Since the whole type should have been printed earlier in the trace,
+      we only print those elements if they are the last printed element
+      of a trace, and there is no explicit explanation for the
+      type error.
+  *)
+
+let printing_status  = function
+  | Trace.(Diff { got=t1, t1'; expected=t2, t2'}) ->
+      if  is_constr_row ~allow_ident:true t1'
+       || is_constr_row ~allow_ident:true t2'
+      then Discard
+      else if same_path t1 t1' && same_path t2 t2' then Optional_refinement
+      else Keep
+  | _ -> Keep
+
+(** Flatten the trace and remove elements that are always discarded
+    during printing *)
+let prepare_trace f tr =
+  let clean_trace x l = match printing_status x with
+    | Keep -> x :: l
+    | Optional_refinement when l = [] -> [x]
+    | Optional_refinement | Discard -> l
+  in
+  match Trace.flatten f tr with
+  | [] -> []
+  | elt :: rem -> (* the first element is always kept *)
+      elt :: List.fold_right clean_trace rem []
+
+(** Keep elements that are not [Diff _ ] and take the decision
+    for the last element, require a prepared trace *)
+let rec filter_trace keep_last = function
+  | [] -> []
+  | [Trace.Diff d as elt] when printing_status elt = Optional_refinement ->
+      if keep_last then [d] else []
+  | Trace.Diff d :: rem -> d :: filter_trace keep_last rem
+  | _ :: rem -> filter_trace keep_last rem
+
+let type_path_list =
+  Format.pp_print_list ~pp_sep:(fun ppf () -> Format.pp_print_break ppf 2 0)
+    type_path_expansion
+
+(* Hide variant name and var, to force printing the expanded type *)
+let hide_variant_name t =
+  match repr t with
+  | {desc = Tvariant row} as t when (row_repr row).row_name <> None ->
+      newty2 t.level
+        (Tvariant {(row_repr row) with row_name = None;
+                   row_more = newvar2 (row_more row).level})
+  | _ -> t
+
+let prepare_expansion (t, t') =
+  let t' = hide_variant_name t' in
+  mark_loops t;
+  if not (same_path t t') then mark_loops t';
+  (t, t')
+
+let may_prepare_expansion compact (t, t') =
+  match (repr t').desc with
+    Tvariant _ | Tobject _ when compact ->
+      mark_loops t; (t, t)
+  | _ -> prepare_expansion (t, t')
+
+let print_tag ppf = fprintf ppf "`%s"
+
+let print_tags =
+  let comma ppf () = Format.fprintf ppf ",@ " in
+  Format.pp_print_list ~pp_sep:comma print_tag
+
+let is_unit env ty =
+  match (Ctype.expand_head env ty).desc with
+  | Tconstr (p, _, _) -> Path.same p Predef.path_unit
+  | _ -> false
+
+let unifiable env ty1 ty2 =
+  let snap = Btype.snapshot () in
+  let res =
+    try Ctype.unify env ty1 ty2; true
+    with Unify _ -> false
+  in
+  Btype.backtrack snap;
+  res
+
+let explanation_diff env t3 t4 : (Format.formatter -> unit) option =
+  match t3.desc, t4.desc with
+  | Tarrow (_, ty1, ty2, _), _
+    when is_unit env ty1 && unifiable env ty2 t4 ->
+      Some (fun ppf ->
+        fprintf ppf
+          "@,@[Hint: Did you forget to provide `()' as argument?@]")
+  | _, Tarrow (_, ty1, ty2, _)
+    when is_unit env ty1 && unifiable env t3 ty2 ->
+      Some (fun ppf ->
+        fprintf ppf
+          "@,@[Hint: Did you forget to wrap the expression using \
+           `fun () ->'?@]")
+  | _ ->
+      None
+
+let print_pos ppf = function
+  | Trace.First -> fprintf ppf "first"
+  | Trace.Second -> fprintf ppf "second"
+
+let explain_fixed_row_case ppf = function
+  | Trace.Cannot_be_closed -> Format.fprintf ppf "it cannot be closed"
+  | Trace.Cannot_add_tags tags ->
+      Format.fprintf ppf "it may not allow the tag(s) %a"
+        print_tags tags
+
+let explain_fixed_row pos expl = match expl with
+  | Types.Fixed_private ->
+      dprintf "The %a variant type is private" print_pos pos
+  | Types.Univar x ->
+      dprintf "The %a variant type is bound to the universal type variable %a"
+        print_pos pos type_expr x
+  | Types.Reified p ->
+      let p = tree_of_path Type p in
+      dprintf "The %a variant type is bound to %a" print_pos pos
+        !Oprint.out_ident p
+  | Types.Rigid -> ignore
+
+let explain_variant = function
+  | Trace.No_intersection ->
+      Some(dprintf "@,These two variant types have no intersection")
+  | Trace.No_tags(pos,fields) -> Some(
+      dprintf
+        "@,@[The %a variant type does not allow tag(s)@ @[<hov>%a@]@]"
+        print_pos pos
+        print_tags (List.map fst fields)
+    )
+  | Trace.Incompatible_types_for s ->
+      Some(dprintf "@,Types for tag `%s are incompatible" s)
+  | Trace.Fixed_row (pos, k, (Univar _ | Reified _ | Fixed_private as e)) ->
+      Some (
+        dprintf "@,@[%t,@ %a@]" (explain_fixed_row pos e)
+          explain_fixed_row_case k
+      )
+  | Trace.Fixed_row (_,_, Rigid) ->
+      (* this case never happens *)
+      None
+
+
+let explain_escape intro prev ctx e =
+  let pre = match ctx with
+    | Some ctx ->  dprintf "@[%t@;<1 2>%a@]" intro type_expr ctx
+    | None -> match e, prev with
+      | Trace.Univ _, Some(Trace.Incompatible_fields {name; diff}) ->
+          dprintf "@,@[The method %s has type@ %a,@ \
+                   but the expected method type was@ %a@]" name
+            type_expr diff.Trace.got type_expr diff.Trace.expected
+      | _ -> ignore in
+  match e with
+  | Trace.Univ u ->  Some(
+      dprintf "%t@,The universal variable %a would escape its scope"
+        pre type_expr u)
+  | Trace.Constructor p -> Some(
+      dprintf
+        "%t@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
+        pre path p
+    )
+  | Trace.Module_type p -> Some(
+      dprintf
+        "%t@,@[The module type@;<1 2>%a@ would escape its scope@]"
+        pre path p
+    )
+  | Trace.Equation (_,t) -> Some(
+      dprintf "%t @,@[<hov>This instance of %a is ambiguous:@ %s@]"
+        pre type_expr t
+        "it would escape the scope of its equation"
+    )
+  | Trace.Self ->
+      Some (dprintf "%t@,Self type cannot escape its class" pre)
+
+
+let explain_object = function
+  | Trace.Self_cannot_be_closed ->
+      Some (dprintf "@,Self type cannot be unified with a closed object type")
+  | Trace.Missing_field (pos,f) ->
+      Some(dprintf "@,@[The %a object type has no method %s@]" print_pos pos f)
+  | Trace.Abstract_row pos -> Some(
+      dprintf
+        "@,@[The %a object type has an abstract row, it cannot be closed@]"
+        print_pos pos
+    )
+
+
+let explanation intro prev env = function
+  | Trace.Diff { Trace.got = _, s; expected = _,t } -> explanation_diff env s t
+  | Trace.Escape {kind;context} -> explain_escape intro prev context kind
+  | Trace.Incompatible_fields { name; _ } ->
+        Some(dprintf "@,Types for method %s are incompatible" name)
+  | Trace.Variant v -> explain_variant v
+  | Trace.Obj o -> explain_object o
+  | Trace.Rec_occur(x,y) ->
+      reset_and_mark_loops y;
+      begin match x.desc with
+      | Tvar _ | Tunivar _  ->
+          Some(dprintf "@,@[<hov>The type variable %a occurs inside@ %a@]"
+                 marked_type_expr x marked_type_expr y)
+      | _ ->
+          (* We had a delayed unification of the type variable with
+             a non-variable after the occur check. *)
+          Some ignore
+           (* There is no need to search further for an explanation, but
+              we don't want to print a message of the form:
+                {[ The type int occurs inside int list -> 'a |}
+           *)
+      end
+
+let mismatch intro env trace =
+  Trace.explain trace (fun ~prev h -> explanation intro prev env h)
+
+let explain mis ppf =
+  match mis with
+  | None -> ()
+  | Some explain -> explain ppf
+
+let warn_on_missing_def env ppf t =
+  match t.desc with
+  | Tconstr (p,_,_) ->
+    begin
+      try
+        ignore(Env.find_type p env : Types.type_declaration)
+      with Not_found ->
+        fprintf ppf
+          "@,@[%a is abstract because no corresponding cmi file was found \
+           in path.@]" path p
+    end
+  | _ -> ()
+
+
+let prepare_expansion_head empty_tr = function
+  | Trace.Diff d ->
+      Some(Trace.map_diff (may_prepare_expansion empty_tr) d)
+  | _ -> None
+
+let head_error_printer txt_got txt_but = function
+  | None -> ignore
+  | Some d ->
+      let d = Trace.map_diff trees_of_type_expansion d in
+      dprintf "%t@;<1 2>%a@ %t@;<1 2>%a"
+        txt_got type_expansion d.Trace.got
+        txt_but type_expansion d.Trace.expected
+
+let warn_on_missing_defs env ppf = function
+  | None -> ()
+  | Some {Trace.got=te1,_; expected=te2,_ } ->
+      warn_on_missing_def env ppf te1;
+      warn_on_missing_def env ppf te2
+
+let unification_error env tr txt1 ppf txt2 ty_expect_explanation =
+  reset ();
+  let tr = prepare_trace (fun t t' -> t, hide_variant_name t') tr in
+  let mis = mismatch txt1 env tr in
+  match tr with
+  | [] -> assert false
+  | elt :: tr ->
+    try
+      print_labels := not !Clflags.classic;
+      let tr = filter_trace (mis = None) tr in
+      let head = prepare_expansion_head (tr=[]) elt in
+      let tr = List.map (Trace.map_diff prepare_expansion) tr in
+      let head_error = head_error_printer txt1 txt2 head in
+      let tr = trees_of_trace tr in
+      fprintf ppf
+        "@[<v>\
+          @[%t%t@]%a%t\
+         @]"
+        head_error
+        ty_expect_explanation
+        (trace false "is not compatible with type") tr
+        (explain mis);
+      if env <> Env.empty
+      then warn_on_missing_defs env ppf head;
+      Conflicts.print_explanations ppf;
+      print_labels := true
+    with exn ->
+      print_labels := true;
+      raise exn
+
+let report_unification_error ppf env tr
+    ?(type_expected_explanation = fun _ -> ())
+    txt1 txt2 =
+  wrap_printing_env env (fun () -> unification_error env tr txt1 ppf txt2
+                            type_expected_explanation)
+    ~error:true
+;;
+
+(** [trace] requires the trace to be prepared *)
+let trace fst keep_last txt ppf tr =
+  print_labels := not !Clflags.classic;
+  try match tr with
+    | elt :: tr' ->
+        let elt = match elt with
+          | Trace.Diff diff -> [Trace.map_diff trees_of_type_expansion diff]
+          | _ -> [] in
+        let tr =
+          trees_of_trace
+          @@ List.map (Trace.map_diff prepare_expansion)
+          @@ filter_trace keep_last tr' in
+      if fst then trace fst txt ppf (elt @ tr)
+      else trace fst txt ppf tr;
+      print_labels := true
+  | _ -> ()
+  with exn ->
+    print_labels := true;
+    raise exn
+
+let report_subtyping_error ppf env tr1 txt1 tr2 =
+  wrap_printing_env ~error:true env (fun () ->
+    reset ();
+    let tr1 = prepare_trace (fun t t' -> prepare_expansion (t, t')) tr1 in
+    let tr2 = prepare_trace (fun t t' -> prepare_expansion (t, t')) tr2 in
+    let keep_first = match tr2 with
+      | Trace.[Obj _ | Variant _ | Escape _ ] | [] -> true
+      | _ -> false in
+    fprintf ppf "@[<v>%a" (trace true keep_first txt1) tr1;
+    if tr2 = [] then fprintf ppf "@]" else
+    let mis = mismatch (dprintf "Within this type") env tr2 in
+    fprintf ppf "%a%t%t@]"
+      (trace false (mis = None) "is not compatible with type") tr2
+      (explain mis)
+      Conflicts.print_explanations
+  )
+
+
+let report_ambiguous_type_error ppf env tp0 tpl txt1 txt2 txt3 =
+  wrap_printing_env ~error:true env (fun () ->
+    reset ();
+    let tp0 = trees_of_type_path_expansion tp0 in
+      match tpl with
+      [] -> assert false
+    | [tp] ->
+        fprintf ppf
+          "@[%t@;<1 2>%a@ \
+             %t@;<1 2>%a\
+           @]"
+          txt1 type_path_expansion (trees_of_type_path_expansion tp)
+          txt3 type_path_expansion tp0
+    | _ ->
+        fprintf ppf
+          "@[%t@;<1 2>@[<hv>%a@]\
+             @ %t@;<1 2>%a\
+           @]"
+          txt2 type_path_list (List.map trees_of_type_path_expansion tpl)
+          txt3 type_path_expansion tp0)
+
+(* Adapt functions to exposed interface *)
+let tree_of_path = tree_of_path Other
+let tree_of_modtype = tree_of_modtype ~ellipsis:false
+let type_expansion ty ppf ty' =
+  type_expansion ppf (trees_of_type_expansion (ty,ty'))
+let tree_of_type_declaration id td rs =
+  Naming_context.with_hidden id ( (* for disambiguation *)
+    wrap_env (hide [id]) (* for short-path *)
+      (fun () -> tree_of_type_declaration id td rs)
+  )
diff --git a/upstream/ocaml_412/typing/printtyp.mli b/upstream/ocaml_412/typing/printtyp.mli
new file mode 100644
index 0000000..fba02c6
--- /dev/null
+++ b/upstream/ocaml_412/typing/printtyp.mli
@@ -0,0 +1,186 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Printing functions *)
+
+open Format
+open Types
+open Outcometree
+
+val longident: formatter -> Longident.t -> unit
+val ident: formatter -> Ident.t -> unit
+val tree_of_path: Path.t -> out_ident
+val path: formatter -> Path.t -> unit
+val string_of_path: Path.t -> string
+
+val type_path: formatter -> Path.t -> unit
+(** Print a type path taking account of [-short-paths].
+    Calls should be within [wrap_printing_env]. *)
+
+module Out_name: sig
+  val create: string -> out_name
+  val print: out_name -> string
+end
+
+type namespace =
+  | Type
+  | Module
+  | Module_type
+  | Class
+  | Class_type
+  | Other (** Other bypasses the unique name for identifier mechanism *)
+
+val strings_of_paths: namespace -> Path.t list -> string list
+    (** Print a list of paths, using the same naming context to
+        avoid name collisions *)
+
+val raw_type_expr: formatter -> type_expr -> unit
+val string_of_label: Asttypes.arg_label -> string
+
+val wrap_printing_env: error:bool -> Env.t -> (unit -> 'a) -> 'a
+    (* Call the function using the environment for type path shortening *)
+    (* This affects all the printing functions below *)
+    (* Also, if [~error:true], then disable the loading of cmis *)
+
+module Naming_context: sig
+  val enable: bool -> unit
+  (** When contextual names are enabled, the mapping between identifiers
+      and names is ensured to be one-to-one. *)
+
+  val reset: unit -> unit
+  (** Reset the naming context *)
+end
+
+(** The [Conflicts] module keeps track of conflicts arising when attributing
+    names to identifiers and provides functions that can print explanations
+    for these conflict in error messages *)
+module Conflicts: sig
+  val exists: unit -> bool
+  (** [exists()] returns true if the current naming context renamed
+        an identifier to avoid a name collision *)
+
+  type explanation =
+    { kind: namespace;
+      name:string;
+      root_name:string;
+      location:Location.t
+    }
+
+  val list_explanations: unit -> explanation list
+(** [list_explanations()] return the list of conflict explanations
+    collected up to this point, and reset the list of collected
+    explanations *)
+
+  val print_located_explanations:
+    Format.formatter -> explanation list -> unit
+
+  val print_explanations: Format.formatter -> unit
+  (** Print all conflict explanations collected up to this point *)
+
+  val reset: unit -> unit
+end
+
+val reset: unit -> unit
+val mark_loops: type_expr -> unit
+val reset_and_mark_loops: type_expr -> unit
+val reset_and_mark_loops_list: type_expr list -> unit
+
+val type_expr: formatter -> type_expr -> unit
+val marked_type_expr: formatter -> type_expr -> unit
+(** The function [type_expr] is the safe version of the pair
+    [(typed_expr, marked_type_expr)]:
+    it takes care of marking loops in the type expression and resetting
+    type variable names before printing.
+      Contrarily, the function [marked_type_expr] should only be called on
+    type expressions whose loops have been marked or it may stackoverflow
+    (see #8860 for examples).
+ *)
+
+val constructor_arguments: formatter -> constructor_arguments -> unit
+val tree_of_type_scheme: type_expr -> out_type
+val type_sch : formatter -> type_expr -> unit
+val type_scheme: formatter -> type_expr -> unit
+(* Maxence *)
+val reset_names: unit -> unit
+val type_scheme_max: ?b_reset_names: bool ->
+        formatter -> type_expr -> unit
+(* End Maxence *)
+val tree_of_value_description: Ident.t -> value_description -> out_sig_item
+val value_description: Ident.t -> formatter -> value_description -> unit
+val label : formatter -> label_declaration -> unit
+val constructor : formatter -> constructor_declaration -> unit
+val tree_of_type_declaration:
+    Ident.t -> type_declaration -> rec_status -> out_sig_item
+val type_declaration: Ident.t -> formatter -> type_declaration -> unit
+val tree_of_extension_constructor:
+    Ident.t -> extension_constructor -> ext_status -> out_sig_item
+val extension_constructor:
+    Ident.t -> formatter -> extension_constructor -> unit
+(* Prints extension constructor with the type signature:
+     type ('a, 'b) bar += A of float
+*)
+
+val extension_only_constructor:
+    Ident.t -> formatter -> extension_constructor -> unit
+(* Prints only extension constructor without type signature:
+     A of float
+*)
+
+val tree_of_module:
+    Ident.t -> ?ellipsis:bool -> module_type -> rec_status -> out_sig_item
+val modtype: formatter -> module_type -> unit
+val signature: formatter -> signature -> unit
+val tree_of_modtype: module_type -> out_module_type
+val tree_of_modtype_declaration:
+    Ident.t -> modtype_declaration -> out_sig_item
+val tree_of_signature: Types.signature -> out_sig_item list
+val tree_of_typexp: bool -> type_expr -> out_type
+val modtype_declaration: Ident.t -> formatter -> modtype_declaration -> unit
+val class_type: formatter -> class_type -> unit
+val tree_of_class_declaration:
+    Ident.t -> class_declaration -> rec_status -> out_sig_item
+val class_declaration: Ident.t -> formatter -> class_declaration -> unit
+val tree_of_cltype_declaration:
+    Ident.t -> class_type_declaration -> rec_status -> out_sig_item
+val cltype_declaration: Ident.t -> formatter -> class_type_declaration -> unit
+val type_expansion: type_expr -> Format.formatter -> type_expr -> unit
+val prepare_expansion: type_expr * type_expr -> type_expr * type_expr
+val trace:
+  bool -> bool-> string -> formatter
+  -> (type_expr * type_expr) Ctype.Unification_trace.elt list -> unit
+val report_unification_error:
+    formatter -> Env.t ->
+    Ctype.Unification_trace.t ->
+    ?type_expected_explanation:(formatter -> unit) ->
+    (formatter -> unit) -> (formatter -> unit) ->
+    unit
+val report_subtyping_error:
+    formatter -> Env.t -> Ctype.Unification_trace.t -> string
+    -> Ctype.Unification_trace.t -> unit
+val report_ambiguous_type_error:
+    formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list ->
+    (formatter -> unit) -> (formatter -> unit) -> (formatter -> unit) -> unit
+
+(* for toploop *)
+val print_items: (Env.t -> signature_item -> 'a option) ->
+  Env.t -> signature_item list -> (out_sig_item * 'a option) list
+
+(* Simple heuristic to rewrite Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias
+   for Foo__bar. This pattern is used by the stdlib. *)
+val rewrite_double_underscore_paths: Env.t -> Path.t -> Path.t
+
+(** [printed_signature sourcefile ppf sg] print the signature [sg] of
+    [sourcefile] with potential warnings for name collisions *)
+val printed_signature: string -> formatter -> signature -> unit
diff --git a/upstream/ocaml_412/typing/printtyped.ml b/upstream/ocaml_412/typing/printtyped.ml
new file mode 100644
index 0000000..15aa097
--- /dev/null
+++ b/upstream/ocaml_412/typing/printtyped.ml
@@ -0,0 +1,945 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes;;
+open Format;;
+open Lexing;;
+open Location;;
+open Typedtree;;
+
+let fmt_position f l =
+  if l.pos_lnum = -1
+  then fprintf f "%s[%d]" l.pos_fname l.pos_cnum
+  else fprintf f "%s[%d,%d+%d]" l.pos_fname l.pos_lnum l.pos_bol
+               (l.pos_cnum - l.pos_bol)
+;;
+
+let fmt_location f loc =
+  if not !Clflags.locations then ()
+  else begin
+    fprintf f "(%a..%a)" fmt_position loc.loc_start fmt_position loc.loc_end;
+    if loc.loc_ghost then fprintf f " ghost";
+  end
+;;
+
+let rec fmt_longident_aux f x =
+  match x with
+  | Longident.Lident (s) -> fprintf f "%s" s;
+  | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s;
+  | Longident.Lapply (y, z) ->
+      fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z;
+;;
+
+let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x.txt;;
+
+let fmt_ident = Ident.print
+
+let fmt_modname f = function
+  | None -> fprintf f "_";
+  | Some id -> Ident.print f id
+
+let rec fmt_path_aux f x =
+  match x with
+  | Path.Pident (s) -> fprintf f "%a" fmt_ident s;
+  | Path.Pdot (y, s) -> fprintf f "%a.%s" fmt_path_aux y s;
+  | Path.Papply (y, z) ->
+      fprintf f "%a(%a)" fmt_path_aux y fmt_path_aux z;
+;;
+
+let fmt_path f x = fprintf f "\"%a\"" fmt_path_aux x;;
+
+let fmt_constant f x =
+  match x with
+  | Const_int (i) -> fprintf f "Const_int %d" i;
+  | Const_char (c) -> fprintf f "Const_char %02x" (Char.code c);
+  | Const_string (s, strloc, None) ->
+      fprintf f "Const_string(%S,%a,None)" s fmt_location strloc;
+  | Const_string (s, strloc, Some delim) ->
+      fprintf f "Const_string (%S,%a,Some %S)" s fmt_location strloc delim;
+  | Const_float (s) -> fprintf f "Const_float %s" s;
+  | Const_int32 (i) -> fprintf f "Const_int32 %ld" i;
+  | Const_int64 (i) -> fprintf f "Const_int64 %Ld" i;
+  | Const_nativeint (i) -> fprintf f "Const_nativeint %nd" i;
+;;
+
+let fmt_mutable_flag f x =
+  match x with
+  | Immutable -> fprintf f "Immutable";
+  | Mutable -> fprintf f "Mutable";
+;;
+
+let fmt_virtual_flag f x =
+  match x with
+  | Virtual -> fprintf f "Virtual";
+  | Concrete -> fprintf f "Concrete";
+;;
+
+let fmt_override_flag f x =
+  match x with
+  | Override -> fprintf f "Override";
+  | Fresh -> fprintf f "Fresh";
+;;
+
+let fmt_closed_flag f x =
+  match x with
+  | Closed -> fprintf f "Closed"
+  | Open -> fprintf f "Open"
+
+let fmt_rec_flag f x =
+  match x with
+  | Nonrecursive -> fprintf f "Nonrec";
+  | Recursive -> fprintf f "Rec";
+;;
+
+let fmt_direction_flag f x =
+  match x with
+  | Upto -> fprintf f "Up";
+  | Downto -> fprintf f "Down";
+;;
+
+let fmt_private_flag f x =
+  match x with
+  | Public -> fprintf f "Public";
+  | Private -> fprintf f "Private";
+;;
+
+let line i f s (*...*) =
+  fprintf f "%s" (String.make (2*i) ' ');
+  fprintf f s (*...*)
+;;
+
+let list i f ppf l =
+  match l with
+  | [] -> line i ppf "[]\n";
+  | _ :: _ ->
+     line i ppf "[\n";
+     List.iter (f (i+1) ppf) l;
+     line i ppf "]\n";
+;;
+
+let array i f ppf a =
+  if Array.length a = 0 then
+    line i ppf "[]\n"
+  else begin
+    line i ppf "[\n";
+    Array.iter (f (i+1) ppf) a;
+    line i ppf "]\n"
+  end
+;;
+
+let option i f ppf x =
+  match x with
+  | None -> line i ppf "None\n";
+  | Some x ->
+      line i ppf "Some\n";
+      f (i+1) ppf x;
+;;
+
+let longident i ppf li = line i ppf "%a\n" fmt_longident li;;
+let string i ppf s = line i ppf "\"%s\"\n" s;;
+let arg_label i ppf = function
+  | Nolabel -> line i ppf "Nolabel\n"
+  | Optional s -> line i ppf "Optional \"%s\"\n" s
+  | Labelled s -> line i ppf "Labelled \"%s\"\n" s
+;;
+
+let record_representation i ppf = let open Types in function
+  | Record_regular -> line i ppf "Record_regular\n"
+  | Record_float -> line i ppf "Record_float\n"
+  | Record_unboxed b -> line i ppf "Record_unboxed %b\n" b
+  | Record_inlined i -> line i ppf "Record_inlined %d\n" i
+  | Record_extension p -> line i ppf "Record_extension %a\n" fmt_path p
+
+let attribute i ppf k a =
+  line i ppf "%s \"%s\"\n" k a.Parsetree.attr_name.txt;
+  Printast.payload i ppf a.Parsetree.attr_payload
+
+let attributes i ppf l =
+  let i = i + 1 in
+  List.iter (fun a ->
+    line i ppf "attribute \"%s\"\n" a.Parsetree.attr_name.txt;
+    Printast.payload (i + 1) ppf a.Parsetree.attr_payload
+  ) l
+
+let rec core_type i ppf x =
+  line i ppf "core_type %a\n" fmt_location x.ctyp_loc;
+  attributes i ppf x.ctyp_attributes;
+  let i = i+1 in
+  match x.ctyp_desc with
+  | Ttyp_any -> line i ppf "Ttyp_any\n";
+  | Ttyp_var (s) -> line i ppf "Ttyp_var %s\n" s;
+  | Ttyp_arrow (l, ct1, ct2) ->
+      line i ppf "Ttyp_arrow\n";
+      arg_label i ppf l;
+      core_type i ppf ct1;
+      core_type i ppf ct2;
+  | Ttyp_tuple l ->
+      line i ppf "Ttyp_tuple\n";
+      list i core_type ppf l;
+  | Ttyp_constr (li, _, l) ->
+      line i ppf "Ttyp_constr %a\n" fmt_path li;
+      list i core_type ppf l;
+  | Ttyp_variant (l, closed, low) ->
+      line i ppf "Ttyp_variant closed=%a\n" fmt_closed_flag closed;
+      list i label_x_bool_x_core_type_list ppf l;
+      option i (fun i -> list i string) ppf low
+  | Ttyp_object (l, c) ->
+      line i ppf "Ttyp_object %a\n" fmt_closed_flag c;
+      let i = i + 1 in
+      List.iter (fun {of_desc; of_attributes; _} ->
+        match of_desc with
+        | OTtag (s, t) ->
+            line i ppf "method %s\n" s.txt;
+            attributes i ppf of_attributes;
+            core_type (i + 1) ppf t
+        | OTinherit ct ->
+            line i ppf "OTinherit\n";
+            core_type (i + 1) ppf ct
+        ) l
+  | Ttyp_class (li, _, l) ->
+      line i ppf "Ttyp_class %a\n" fmt_path li;
+      list i core_type ppf l;
+  | Ttyp_alias (ct, s) ->
+      line i ppf "Ttyp_alias \"%s\"\n" s;
+      core_type i ppf ct;
+  | Ttyp_poly (sl, ct) ->
+      line i ppf "Ttyp_poly%a\n"
+        (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x)) sl;
+      core_type i ppf ct;
+  | Ttyp_package { pack_path = s; pack_fields = l } ->
+      line i ppf "Ttyp_package %a\n" fmt_path s;
+      list i package_with ppf l;
+
+and package_with i ppf (s, t) =
+  line i ppf "with type %a\n" fmt_longident s;
+  core_type i ppf t
+
+and pattern : type k . _ -> _ -> k general_pattern -> unit = fun i ppf x ->
+  line i ppf "pattern %a\n" fmt_location x.pat_loc;
+  attributes i ppf x.pat_attributes;
+  let i = i+1 in
+  match x.pat_extra with
+    | extra :: rem ->
+        pattern_extra i ppf extra;
+        pattern i ppf { x with pat_extra = rem }
+    | [] ->
+  match x.pat_desc with
+  | Tpat_any -> line i ppf "Tpat_any\n";
+  | Tpat_var (s,_) -> line i ppf "Tpat_var \"%a\"\n" fmt_ident s;
+  | Tpat_alias (p, s,_) ->
+      line i ppf "Tpat_alias \"%a\"\n" fmt_ident s;
+      pattern i ppf p;
+  | Tpat_constant (c) -> line i ppf "Tpat_constant %a\n" fmt_constant c;
+  | Tpat_tuple (l) ->
+      line i ppf "Tpat_tuple\n";
+      list i pattern ppf l;
+  | Tpat_construct (li, _, po) ->
+      line i ppf "Tpat_construct %a\n" fmt_longident li;
+      list i pattern ppf po;
+  | Tpat_variant (l, po, _) ->
+      line i ppf "Tpat_variant \"%s\"\n" l;
+      option i pattern ppf po;
+  | Tpat_record (l, _c) ->
+      line i ppf "Tpat_record\n";
+      list i longident_x_pattern ppf l;
+  | Tpat_array (l) ->
+      line i ppf "Tpat_array\n";
+      list i pattern ppf l;
+  | Tpat_lazy p ->
+      line i ppf "Tpat_lazy\n";
+      pattern i ppf p;
+  | Tpat_exception p ->
+      line i ppf "Tpat_exception\n";
+      pattern i ppf p;
+  | Tpat_value p ->
+      line i ppf "Tpat_value\n";
+      pattern i ppf (p :> pattern);
+  | Tpat_or (p1, p2, _) ->
+      line i ppf "Tpat_or\n";
+      pattern i ppf p1;
+      pattern i ppf p2;
+
+and pattern_extra i ppf (extra_pat, _, attrs) =
+  match extra_pat with
+  | Tpat_unpack ->
+     line i ppf "Tpat_extra_unpack\n";
+     attributes i ppf attrs;
+  | Tpat_constraint cty ->
+     line i ppf "Tpat_extra_constraint\n";
+     attributes i ppf attrs;
+     core_type i ppf cty;
+  | Tpat_type (id, _) ->
+     line i ppf "Tpat_extra_type %a\n" fmt_path id;
+     attributes i ppf attrs;
+  | Tpat_open (id,_,_) ->
+     line i ppf "Tpat_extra_open \"%a\"\n" fmt_path id;
+     attributes i ppf attrs;
+
+and expression_extra i ppf x attrs =
+  match x with
+  | Texp_constraint ct ->
+      line i ppf "Texp_constraint\n";
+      attributes i ppf attrs;
+      core_type i ppf ct;
+  | Texp_coerce (cto1, cto2) ->
+      line i ppf "Texp_coerce\n";
+      attributes i ppf attrs;
+      option i core_type ppf cto1;
+      core_type i ppf cto2;
+  | Texp_poly cto ->
+      line i ppf "Texp_poly\n";
+      attributes i ppf attrs;
+      option i core_type ppf cto;
+  | Texp_newtype s ->
+      line i ppf "Texp_newtype \"%s\"\n" s;
+      attributes i ppf attrs;
+
+and expression i ppf x =
+  line i ppf "expression %a\n" fmt_location x.exp_loc;
+  attributes i ppf x.exp_attributes;
+  let i =
+    List.fold_left (fun i (extra,_,attrs) ->
+                      expression_extra i ppf extra attrs; i+1)
+      (i+1) x.exp_extra
+  in
+  match x.exp_desc with
+  | Texp_ident (li,_,_) -> line i ppf "Texp_ident %a\n" fmt_path li;
+  | Texp_instvar (_, li,_) -> line i ppf "Texp_instvar %a\n" fmt_path li;
+  | Texp_constant (c) -> line i ppf "Texp_constant %a\n" fmt_constant c;
+  | Texp_let (rf, l, e) ->
+      line i ppf "Texp_let %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l;
+      expression i ppf e;
+  | Texp_function { arg_label = p; param = _; cases; partial = _; } ->
+      line i ppf "Texp_function\n";
+      arg_label i ppf p;
+      list i case ppf cases;
+  | Texp_apply (e, l) ->
+      line i ppf "Texp_apply\n";
+      expression i ppf e;
+      list i label_x_expression ppf l;
+  | Texp_match (e, l, _partial) ->
+      line i ppf "Texp_match\n";
+      expression i ppf e;
+      list i case ppf l;
+  | Texp_try (e, l) ->
+      line i ppf "Texp_try\n";
+      expression i ppf e;
+      list i case ppf l;
+  | Texp_tuple (l) ->
+      line i ppf "Texp_tuple\n";
+      list i expression ppf l;
+  | Texp_construct (li, _, eo) ->
+      line i ppf "Texp_construct %a\n" fmt_longident li;
+      list i expression ppf eo;
+  | Texp_variant (l, eo) ->
+      line i ppf "Texp_variant \"%s\"\n" l;
+      option i expression ppf eo;
+  | Texp_record { fields; representation; extended_expression } ->
+      line i ppf "Texp_record\n";
+      let i = i+1 in
+      line i ppf "fields =\n";
+      array (i+1) record_field ppf fields;
+      line i ppf "representation =\n";
+      record_representation (i+1) ppf representation;
+      line i ppf "extended_expression =\n";
+      option (i+1) expression ppf extended_expression;
+  | Texp_field (e, li, _) ->
+      line i ppf "Texp_field\n";
+      expression i ppf e;
+      longident i ppf li;
+  | Texp_setfield (e1, li, _, e2) ->
+      line i ppf "Texp_setfield\n";
+      expression i ppf e1;
+      longident i ppf li;
+      expression i ppf e2;
+  | Texp_array (l) ->
+      line i ppf "Texp_array\n";
+      list i expression ppf l;
+  | Texp_ifthenelse (e1, e2, eo) ->
+      line i ppf "Texp_ifthenelse\n";
+      expression i ppf e1;
+      expression i ppf e2;
+      option i expression ppf eo;
+  | Texp_sequence (e1, e2) ->
+      line i ppf "Texp_sequence\n";
+      expression i ppf e1;
+      expression i ppf e2;
+  | Texp_while (e1, e2) ->
+      line i ppf "Texp_while\n";
+      expression i ppf e1;
+      expression i ppf e2;
+  | Texp_for (s, _, e1, e2, df, e3) ->
+      line i ppf "Texp_for \"%a\" %a\n" fmt_ident s fmt_direction_flag df;
+      expression i ppf e1;
+      expression i ppf e2;
+      expression i ppf e3;
+  | Texp_send (e, Tmeth_name s, eo) ->
+      line i ppf "Texp_send \"%s\"\n" s;
+      expression i ppf e;
+      option i expression ppf eo
+  | Texp_send (e, Tmeth_val s, eo) ->
+      line i ppf "Texp_send \"%a\"\n" fmt_ident s;
+      expression i ppf e;
+      option i expression ppf eo
+  | Texp_new (li, _, _) -> line i ppf "Texp_new %a\n" fmt_path li;
+  | Texp_setinstvar (_, s, _, e) ->
+      line i ppf "Texp_setinstvar \"%a\"\n" fmt_path s;
+      expression i ppf e;
+  | Texp_override (_, l) ->
+      line i ppf "Texp_override\n";
+      list i string_x_expression ppf l;
+  | Texp_letmodule (s, _, _, me, e) ->
+      line i ppf "Texp_letmodule \"%a\"\n" fmt_modname s;
+      module_expr i ppf me;
+      expression i ppf e;
+  | Texp_letexception (cd, e) ->
+      line i ppf "Texp_letexception\n";
+      extension_constructor i ppf cd;
+      expression i ppf e;
+  | Texp_assert (e) ->
+      line i ppf "Texp_assert";
+      expression i ppf e;
+  | Texp_lazy (e) ->
+      line i ppf "Texp_lazy";
+      expression i ppf e;
+  | Texp_object (s, _) ->
+      line i ppf "Texp_object";
+      class_structure i ppf s
+  | Texp_pack me ->
+      line i ppf "Texp_pack";
+      module_expr i ppf me
+  | Texp_letop {let_; ands; param = _; body; partial = _} ->
+      line i ppf "Texp_letop";
+      binding_op (i+1) ppf let_;
+      list (i+1) binding_op ppf ands;
+      case i ppf body
+  | Texp_unreachable ->
+      line i ppf "Texp_unreachable"
+  | Texp_extension_constructor (li, _) ->
+      line i ppf "Texp_extension_constructor %a" fmt_longident li
+  | Texp_open (o, e) ->
+      line i ppf "Texp_open %a\n"
+        fmt_override_flag o.open_override;
+      module_expr i ppf o.open_expr;
+      attributes i ppf o.open_attributes;
+      expression i ppf e;
+
+and value_description i ppf x =
+  line i ppf "value_description %a %a\n" fmt_ident x.val_id fmt_location
+       x.val_loc;
+  attributes i ppf x.val_attributes;
+  core_type (i+1) ppf x.val_desc;
+  list (i+1) string ppf x.val_prim;
+
+and binding_op i ppf x =
+  line i ppf "binding_op %a %a\n" fmt_path x.bop_op_path
+    fmt_location x.bop_loc;
+  expression i ppf x.bop_exp
+
+and type_parameter i ppf (x, _variance) = core_type i ppf x
+
+and type_declaration i ppf x =
+  line i ppf "type_declaration %a %a\n" fmt_ident x.typ_id fmt_location
+       x.typ_loc;
+  attributes i ppf x.typ_attributes;
+  let i = i+1 in
+  line i ppf "ptype_params =\n";
+  list (i+1) type_parameter ppf x.typ_params;
+  line i ppf "ptype_cstrs =\n";
+  list (i+1) core_type_x_core_type_x_location ppf x.typ_cstrs;
+  line i ppf "ptype_kind =\n";
+  type_kind (i+1) ppf x.typ_kind;
+  line i ppf "ptype_private = %a\n" fmt_private_flag x.typ_private;
+  line i ppf "ptype_manifest =\n";
+  option (i+1) core_type ppf x.typ_manifest;
+
+and type_kind i ppf x =
+  match x with
+  | Ttype_abstract ->
+      line i ppf "Ttype_abstract\n"
+  | Ttype_variant l ->
+      line i ppf "Ttype_variant\n";
+      list (i+1) constructor_decl ppf l;
+  | Ttype_record l ->
+      line i ppf "Ttype_record\n";
+      list (i+1) label_decl ppf l;
+  | Ttype_open ->
+      line i ppf "Ttype_open\n"
+
+and type_extension i ppf x =
+  line i ppf "type_extension\n";
+  attributes i ppf x.tyext_attributes;
+  let i = i+1 in
+  line i ppf "ptyext_path = %a\n" fmt_path x.tyext_path;
+  line i ppf "ptyext_params =\n";
+  list (i+1) type_parameter ppf x.tyext_params;
+  line i ppf "ptyext_constructors =\n";
+  list (i+1) extension_constructor ppf x.tyext_constructors;
+  line i ppf "ptyext_private = %a\n" fmt_private_flag x.tyext_private;
+
+and type_exception i ppf x =
+  line i ppf "type_exception\n";
+  attributes i ppf x.tyexn_attributes;
+  let i = i+1 in
+  line i ppf "ptyext_constructor =\n";
+  let i = i+1 in
+  extension_constructor i ppf x.tyexn_constructor
+
+and extension_constructor i ppf x =
+  line i ppf "extension_constructor %a\n" fmt_location x.ext_loc;
+  attributes i ppf x.ext_attributes;
+  let i = i + 1 in
+  line i ppf "pext_name = \"%a\"\n" fmt_ident x.ext_id;
+  line i ppf "pext_kind =\n";
+  extension_constructor_kind (i + 1) ppf x.ext_kind;
+
+and extension_constructor_kind i ppf x =
+  match x with
+      Text_decl(a, r) ->
+        line i ppf "Text_decl\n";
+        constructor_arguments (i+1) ppf a;
+        option (i+1) core_type ppf r;
+    | Text_rebind(p, _) ->
+        line i ppf "Text_rebind\n";
+        line (i+1) ppf "%a\n" fmt_path p;
+
+and class_type i ppf x =
+  line i ppf "class_type %a\n" fmt_location x.cltyp_loc;
+  attributes i ppf x.cltyp_attributes;
+  let i = i+1 in
+  match x.cltyp_desc with
+  | Tcty_constr (li, _, l) ->
+      line i ppf "Tcty_constr %a\n" fmt_path li;
+      list i core_type ppf l;
+  | Tcty_signature (cs) ->
+      line i ppf "Tcty_signature\n";
+      class_signature i ppf cs;
+  | Tcty_arrow (l, co, cl) ->
+      line i ppf "Tcty_arrow\n";
+      arg_label i ppf l;
+      core_type i ppf co;
+      class_type i ppf cl;
+  | Tcty_open (o, e) ->
+      line i ppf "Tcty_open %a %a\n"
+        fmt_override_flag o.open_override
+        fmt_path (fst o.open_expr);
+      class_type i ppf e
+
+and class_signature i ppf { csig_self = ct; csig_fields = l } =
+  line i ppf "class_signature\n";
+  core_type (i+1) ppf ct;
+  list (i+1) class_type_field ppf l;
+
+and class_type_field i ppf x =
+  line i ppf "class_type_field %a\n" fmt_location x.ctf_loc;
+  let i = i+1 in
+  attributes i ppf x.ctf_attributes;
+  match x.ctf_desc with
+  | Tctf_inherit (ct) ->
+      line i ppf "Tctf_inherit\n";
+      class_type i ppf ct;
+  | Tctf_val (s, mf, vf, ct) ->
+      line i ppf "Tctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf
+           fmt_virtual_flag vf;
+      core_type (i+1) ppf ct;
+  | Tctf_method (s, pf, vf, ct) ->
+      line i ppf "Tctf_method \"%s\" %a %a\n" s fmt_private_flag pf
+           fmt_virtual_flag vf;
+      core_type (i+1) ppf ct;
+  | Tctf_constraint (ct1, ct2) ->
+      line i ppf "Tctf_constraint\n";
+      core_type (i+1) ppf ct1;
+      core_type (i+1) ppf ct2;
+  | Tctf_attribute a ->
+      attribute i ppf "Tctf_attribute" a
+
+and class_description i ppf x =
+  line i ppf "class_description %a\n" fmt_location x.ci_loc;
+  attributes i ppf x.ci_attributes;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.ci_params;
+  line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt;
+  line i ppf "pci_expr =\n";
+  class_type (i+1) ppf x.ci_expr;
+
+and class_type_declaration i ppf x =
+  line i ppf "class_type_declaration %a\n" fmt_location x.ci_loc;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.ci_params;
+  line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt;
+  line i ppf "pci_expr =\n";
+  class_type (i+1) ppf x.ci_expr;
+
+and class_expr i ppf x =
+  line i ppf "class_expr %a\n" fmt_location x.cl_loc;
+  attributes i ppf x.cl_attributes;
+  let i = i+1 in
+  match x.cl_desc with
+  | Tcl_ident (li, _, l) ->
+      line i ppf "Tcl_ident %a\n" fmt_path li;
+      list i core_type ppf l;
+  | Tcl_structure (cs) ->
+      line i ppf "Tcl_structure\n";
+      class_structure i ppf cs;
+  | Tcl_fun (l, p, _, ce, _) ->
+      line i ppf "Tcl_fun\n";
+      arg_label i ppf l;
+      pattern i ppf p;
+      class_expr i ppf ce
+  | Tcl_apply (ce, l) ->
+      line i ppf "Tcl_apply\n";
+      class_expr i ppf ce;
+      list i label_x_expression ppf l;
+  | Tcl_let (rf, l1, l2, ce) ->
+      line i ppf "Tcl_let %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l1;
+      list i ident_x_expression_def ppf l2;
+      class_expr i ppf ce;
+  | Tcl_constraint (ce, Some ct, _, _, _) ->
+      line i ppf "Tcl_constraint\n";
+      class_expr i ppf ce;
+      class_type i ppf ct
+  | Tcl_constraint (ce, None, _, _, _) -> class_expr i ppf ce
+  | Tcl_open (o, e) ->
+      line i ppf "Tcl_open %a %a\n"
+        fmt_override_flag o.open_override
+        fmt_path (fst o.open_expr);
+      class_expr i ppf e
+
+and class_structure i ppf { cstr_self = p; cstr_fields = l } =
+  line i ppf "class_structure\n";
+  pattern (i+1) ppf p;
+  list (i+1) class_field ppf l;
+
+and class_field i ppf x =
+  line i ppf "class_field %a\n" fmt_location x.cf_loc;
+  let i = i + 1 in
+  attributes i ppf x.cf_attributes;
+  match x.cf_desc with
+  | Tcf_inherit (ovf, ce, so, _, _) ->
+      line i ppf "Tcf_inherit %a\n" fmt_override_flag ovf;
+      class_expr (i+1) ppf ce;
+      option (i+1) string ppf so;
+  | Tcf_val (s, mf, _, k, _) ->
+      line i ppf "Tcf_val \"%s\" %a\n" s.txt fmt_mutable_flag mf;
+      class_field_kind (i+1) ppf k
+  | Tcf_method (s, pf, k) ->
+      line i ppf "Tcf_method \"%s\" %a\n" s.txt fmt_private_flag pf;
+      class_field_kind (i+1) ppf k
+  | Tcf_constraint (ct1, ct2) ->
+      line i ppf "Tcf_constraint\n";
+      core_type (i+1) ppf ct1;
+      core_type (i+1) ppf ct2;
+  | Tcf_initializer (e) ->
+      line i ppf "Tcf_initializer\n";
+      expression (i+1) ppf e;
+  | Tcf_attribute a ->
+      attribute i ppf "Tcf_attribute" a
+
+and class_field_kind i ppf = function
+  | Tcfk_concrete (o, e) ->
+      line i ppf "Concrete %a\n" fmt_override_flag o;
+      expression i ppf e
+  | Tcfk_virtual t ->
+      line i ppf "Virtual\n";
+      core_type i ppf t
+
+and class_declaration i ppf x =
+  line i ppf "class_declaration %a\n" fmt_location x.ci_loc;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.ci_params;
+  line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt;
+  line i ppf "pci_expr =\n";
+  class_expr (i+1) ppf x.ci_expr;
+
+and module_type i ppf x =
+  line i ppf "module_type %a\n" fmt_location x.mty_loc;
+  attributes i ppf x.mty_attributes;
+  let i = i+1 in
+  match x.mty_desc with
+  | Tmty_ident (li,_) -> line i ppf "Tmty_ident %a\n" fmt_path li;
+  | Tmty_alias (li,_) -> line i ppf "Tmty_alias %a\n" fmt_path li;
+  | Tmty_signature (s) ->
+      line i ppf "Tmty_signature\n";
+      signature i ppf s;
+  | Tmty_functor (Unit, mt2) ->
+      line i ppf "Tmty_functor ()\n";
+      module_type i ppf mt2;
+  | Tmty_functor (Named (s, _, mt1), mt2) ->
+      line i ppf "Tmty_functor \"%a\"\n" fmt_modname s;
+      module_type i ppf mt1;
+      module_type i ppf mt2;
+  | Tmty_with (mt, l) ->
+      line i ppf "Tmty_with\n";
+      module_type i ppf mt;
+      list i longident_x_with_constraint ppf l;
+  | Tmty_typeof m ->
+      line i ppf "Tmty_typeof\n";
+      module_expr i ppf m;
+
+and signature i ppf x = list i signature_item ppf x.sig_items
+
+and signature_item i ppf x =
+  line i ppf "signature_item %a\n" fmt_location x.sig_loc;
+  let i = i+1 in
+  match x.sig_desc with
+  | Tsig_value vd ->
+      line i ppf "Tsig_value\n";
+      value_description i ppf vd;
+  | Tsig_type (rf, l) ->
+      line i ppf "Tsig_type %a\n" fmt_rec_flag rf;
+      list i type_declaration ppf l;
+  | Tsig_typesubst l ->
+      line i ppf "Tsig_typesubst\n";
+      list i type_declaration ppf l;
+  | Tsig_typext e ->
+      line i ppf "Tsig_typext\n";
+      type_extension i ppf e;
+  | Tsig_exception ext ->
+      line i ppf "Tsig_exception\n";
+      type_exception i ppf ext
+  | Tsig_module md ->
+      line i ppf "Tsig_module \"%a\"\n" fmt_modname md.md_id;
+      attributes i ppf md.md_attributes;
+      module_type i ppf md.md_type
+  | Tsig_modsubst ms ->
+      line i ppf "Tsig_modsubst \"%a\" = %a\n"
+        fmt_ident ms.ms_id fmt_path ms.ms_manifest;
+      attributes i ppf ms.ms_attributes;
+  | Tsig_recmodule decls ->
+      line i ppf "Tsig_recmodule\n";
+      list i module_declaration ppf decls;
+  | Tsig_modtype x ->
+      line i ppf "Tsig_modtype \"%a\"\n" fmt_ident x.mtd_id;
+      attributes i ppf x.mtd_attributes;
+      modtype_declaration i ppf x.mtd_type
+  | Tsig_open od ->
+      line i ppf "Tsig_open %a %a\n"
+        fmt_override_flag od.open_override
+        fmt_path (fst od.open_expr);
+      attributes i ppf od.open_attributes
+  | Tsig_include incl ->
+      line i ppf "Tsig_include\n";
+      attributes i ppf incl.incl_attributes;
+      module_type i ppf incl.incl_mod
+  | Tsig_class (l) ->
+      line i ppf "Tsig_class\n";
+      list i class_description ppf l;
+  | Tsig_class_type (l) ->
+      line i ppf "Tsig_class_type\n";
+      list i class_type_declaration ppf l;
+  | Tsig_attribute a ->
+      attribute i ppf "Tsig_attribute" a
+
+and module_declaration i ppf md =
+  line i ppf "%a" fmt_modname md.md_id;
+  attributes i ppf md.md_attributes;
+  module_type (i+1) ppf md.md_type;
+
+and module_binding i ppf x =
+  line i ppf "%a\n" fmt_modname x.mb_id;
+  attributes i ppf x.mb_attributes;
+  module_expr (i+1) ppf x.mb_expr
+
+and modtype_declaration i ppf = function
+  | None -> line i ppf "#abstract"
+  | Some mt -> module_type (i + 1) ppf mt
+
+and with_constraint i ppf x =
+  match x with
+  | Twith_type (td) ->
+      line i ppf "Twith_type\n";
+      type_declaration (i+1) ppf td;
+  | Twith_typesubst (td) ->
+      line i ppf "Twith_typesubst\n";
+      type_declaration (i+1) ppf td;
+  | Twith_module (li,_) -> line i ppf "Twith_module %a\n" fmt_path li;
+  | Twith_modsubst (li,_) -> line i ppf "Twith_modsubst %a\n" fmt_path li;
+
+and module_expr i ppf x =
+  line i ppf "module_expr %a\n" fmt_location x.mod_loc;
+  attributes i ppf x.mod_attributes;
+  let i = i+1 in
+  match x.mod_desc with
+  | Tmod_ident (li,_) -> line i ppf "Tmod_ident %a\n" fmt_path li;
+  | Tmod_structure (s) ->
+      line i ppf "Tmod_structure\n";
+      structure i ppf s;
+  | Tmod_functor (Unit, me) ->
+      line i ppf "Tmod_functor ()\n";
+      module_expr i ppf me;
+  | Tmod_functor (Named (s, _, mt), me) ->
+      line i ppf "Tmod_functor \"%a\"\n" fmt_modname s;
+      module_type i ppf mt;
+      module_expr i ppf me;
+  | Tmod_apply (me1, me2, _) ->
+      line i ppf "Tmod_apply\n";
+      module_expr i ppf me1;
+      module_expr i ppf me2;
+  | Tmod_constraint (me, _, Tmodtype_explicit mt, _) ->
+      line i ppf "Tmod_constraint\n";
+      module_expr i ppf me;
+      module_type i ppf mt;
+  | Tmod_constraint (me, _, Tmodtype_implicit, _) -> module_expr i ppf me
+  | Tmod_unpack (e, _) ->
+      line i ppf "Tmod_unpack\n";
+      expression i ppf e;
+
+and structure i ppf x = list i structure_item ppf x.str_items
+
+and structure_item i ppf x =
+  line i ppf "structure_item %a\n" fmt_location x.str_loc;
+  let i = i+1 in
+  match x.str_desc with
+  | Tstr_eval (e, attrs) ->
+      line i ppf "Tstr_eval\n";
+      attributes i ppf attrs;
+      expression i ppf e;
+  | Tstr_value (rf, l) ->
+      line i ppf "Tstr_value %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l;
+  | Tstr_primitive vd ->
+      line i ppf "Tstr_primitive\n";
+      value_description i ppf vd;
+  | Tstr_type (rf, l) ->
+      line i ppf "Tstr_type %a\n" fmt_rec_flag rf;
+      list i type_declaration ppf l;
+  | Tstr_typext te ->
+      line i ppf "Tstr_typext\n";
+      type_extension i ppf te
+  | Tstr_exception ext ->
+      line i ppf "Tstr_exception\n";
+      type_exception i ppf ext;
+  | Tstr_module x ->
+      line i ppf "Tstr_module\n";
+      module_binding i ppf x
+  | Tstr_recmodule bindings ->
+      line i ppf "Tstr_recmodule\n";
+      list i module_binding ppf bindings
+  | Tstr_modtype x ->
+      line i ppf "Tstr_modtype \"%a\"\n" fmt_ident x.mtd_id;
+      attributes i ppf x.mtd_attributes;
+      modtype_declaration i ppf x.mtd_type
+  | Tstr_open od ->
+      line i ppf "Tstr_open %a\n"
+        fmt_override_flag od.open_override;
+      module_expr i ppf od.open_expr;
+      attributes i ppf od.open_attributes
+  | Tstr_class (l) ->
+      line i ppf "Tstr_class\n";
+      list i class_declaration ppf (List.map (fun (cl, _) -> cl) l);
+  | Tstr_class_type (l) ->
+      line i ppf "Tstr_class_type\n";
+      list i class_type_declaration ppf (List.map (fun (_, _, cl) -> cl) l);
+  | Tstr_include incl ->
+      line i ppf "Tstr_include";
+      attributes i ppf incl.incl_attributes;
+      module_expr i ppf incl.incl_mod;
+  | Tstr_attribute a ->
+      attribute i ppf "Tstr_attribute" a
+
+and longident_x_with_constraint i ppf (li, _, wc) =
+  line i ppf "%a\n" fmt_path li;
+  with_constraint (i+1) ppf wc;
+
+and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
+  line i ppf "<constraint> %a\n" fmt_location l;
+  core_type (i+1) ppf ct1;
+  core_type (i+1) ppf ct2;
+
+and constructor_decl i ppf {cd_id; cd_name = _; cd_args; cd_res; cd_loc;
+                            cd_attributes} =
+  line i ppf "%a\n" fmt_location cd_loc;
+  line (i+1) ppf "%a\n" fmt_ident cd_id;
+  attributes i ppf cd_attributes;
+  constructor_arguments (i+1) ppf cd_args;
+  option (i+1) core_type ppf cd_res
+
+and constructor_arguments i ppf = function
+  | Cstr_tuple l -> list i core_type ppf l
+  | Cstr_record l -> list i label_decl ppf l
+
+and label_decl i ppf {ld_id; ld_name = _; ld_mutable; ld_type; ld_loc;
+                      ld_attributes} =
+  line i ppf "%a\n" fmt_location ld_loc;
+  attributes i ppf ld_attributes;
+  line (i+1) ppf "%a\n" fmt_mutable_flag ld_mutable;
+  line (i+1) ppf "%a" fmt_ident ld_id;
+  core_type (i+1) ppf ld_type
+
+and longident_x_pattern i ppf (li, _, p) =
+  line i ppf "%a\n" fmt_longident li;
+  pattern (i+1) ppf p;
+
+and case
+    : type k . _ -> _ -> k case -> unit
+  = fun i ppf {c_lhs; c_guard; c_rhs} ->
+  line i ppf "<case>\n";
+  pattern (i+1) ppf c_lhs;
+  begin match c_guard with
+  | None -> ()
+  | Some g -> line (i+1) ppf "<when>\n"; expression (i + 2) ppf g
+  end;
+  expression (i+1) ppf c_rhs;
+
+and value_binding i ppf x =
+  line i ppf "<def>\n";
+  attributes (i+1) ppf x.vb_attributes;
+  pattern (i+1) ppf x.vb_pat;
+  expression (i+1) ppf x.vb_expr
+
+and string_x_expression i ppf (s, _, e) =
+  line i ppf "<override> \"%a\"\n" fmt_path s;
+  expression (i+1) ppf e;
+
+and record_field i ppf = function
+  | _, Overridden (li, e) ->
+      line i ppf "%a\n" fmt_longident li;
+      expression (i+1) ppf e;
+  | _, Kept _ ->
+      line i ppf "<kept>"
+
+and label_x_expression i ppf (l, e) =
+  line i ppf "<arg>\n";
+  arg_label (i+1) ppf l;
+  (match e with None -> () | Some e -> expression (i+1) ppf e)
+
+and ident_x_expression_def i ppf (l, e) =
+  line i ppf "<def> \"%a\"\n" fmt_ident l;
+  expression (i+1) ppf e;
+
+and label_x_bool_x_core_type_list i ppf x =
+  match x.rf_desc with
+  | Ttag (l, b, ctl) ->
+      line i ppf "Ttag \"%s\" %s\n" l.txt (string_of_bool b);
+      attributes (i+1) ppf x.rf_attributes;
+      list (i+1) core_type ppf ctl
+  | Tinherit (ct) ->
+      line i ppf "Tinherit\n";
+      core_type (i+1) ppf ct
+;;
+
+let interface ppf x = list 0 signature_item ppf x.sig_items;;
+
+let implementation ppf x = list 0 structure_item ppf x.str_items;;
+
+let implementation_with_coercion ppf (x, _) = implementation ppf x
diff --git a/upstream/ocaml_412/typing/printtyped.mli b/upstream/ocaml_412/typing/printtyped.mli
new file mode 100644
index 0000000..ded42bb
--- /dev/null
+++ b/upstream/ocaml_412/typing/printtyped.mli
@@ -0,0 +1,23 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*              Damien Doligez, projet Para, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Typedtree;;
+open Format;;
+
+val interface : formatter -> signature -> unit;;
+val implementation : formatter -> structure -> unit;;
+
+val implementation_with_coercion :
+    formatter -> (structure * module_coercion) -> unit;;
diff --git a/upstream/ocaml_412/typing/rec_check.ml b/upstream/ocaml_412/typing/rec_check.ml
new file mode 100644
index 0000000..1248484
--- /dev/null
+++ b/upstream/ocaml_412/typing/rec_check.ml
@@ -0,0 +1,1258 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*               Jeremy Yallop, University of Cambridge                   *)
+(*               Gabriel Scherer, Project Parsifal, INRIA Saclay          *)
+(*               Alban Reynaud, ENS Lyon                                  *)
+(*                                                                        *)
+(*   Copyright 2017 Jeremy Yallop                                         *)
+(*   Copyright 2018 Alban Reynaud                                         *)
+(*   Copyright 2018 INRIA                                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Static checking of recursive declarations
+
+Some recursive definitions are meaningful
+{[
+  let rec factorial = function 0 -> 1 | n -> n * factorial (n - 1)
+  let rec infinite_list = 0 :: infinite_list
+]}
+but some other are meaningless
+{[
+  let rec x = x
+  let rec x = x+1
+|}
+
+Intuitively, a recursive definition makes sense when the body of the
+definition can be evaluated without fully knowing what the recursive
+name is yet.
+
+In the [factorial] example, the name [factorial] refers to a function,
+evaluating the function definition [function ...] can be done
+immediately and will not force a recursive call to [factorial] -- this
+will only happen later, when [factorial] is called with an argument.
+
+In the [infinite_list] example, we can evaluate [0 :: infinite_list]
+without knowing the full content of [infinite_list], but with just its
+address. This is a case of productive/guarded recursion.
+
+On the contrary, [let rec x = x] is unguarded recursion (the meaning
+is undetermined), and [let rec x = x+1] would need the value of [x]
+while evaluating its definition [x+1].
+
+This file implements a static check to decide which definitions are
+known to be meaningful, and which may be meaningless. In the general
+case, we handle a set of mutually-recursive definitions
+{[
+let rec x1 = e1
+and x2 = e2
+...
+and xn = en
+]}
+
+
+Our check (see function [is_valid_recursive_expression] is defined
+using two criteria:
+
+Usage of recursive variables: how does each of the [e1 .. en] use the
+ recursive variables [x1 .. xn]?
+
+Static or dynamic size: for which of the [ei] can we compute the
+  in-memory size of the value without evaluating [ei] (so that we can
+  pre-allocate it, and thus know its final address before evaluation).
+
+The "static or dynamic size" is decided by the classify_* functions below.
+
+The "variable usage" question is decided by a static analysis looking
+very much like a type system. The idea is to assign "access modes" to
+variables, where an "access mode" [m] is defined as either
+
+    m ::= Ignore (* the value is not used at all *)
+        | Delay (* the value is not needed at definition time *)
+        | Guard (* the value is stored under a data constructor *)
+        | Return (* the value result is directly returned *)
+        | Dereference (* full access and inspection of the value *)
+
+The access modes of an expression [e] are represented by a "context"
+[G], which is simply a mapping from variables (the variables used in
+[e]) to access modes.
+
+The core notion of the static check is a type-system-like judgment of
+the form [G |- e : m], which can be interpreted as meaning either of:
+
+- If we are allowed to use the variables of [e] at the modes in [G]
+  (but not more), then it is safe to use [e] at the mode [m].
+
+- If we want to use [e] at the mode [m], then its variables are
+  used at the modes in [G].
+
+In practice, for a given expression [e], our implementation takes the
+desired mode of use [m] as *input*, and returns a context [G] as
+*output*, which is (uniquely determined as) the most permissive choice
+of modes [G] for the variables of [e] such that [G |- e : m] holds.
+*)
+
+open Asttypes
+open Typedtree
+open Types
+
+exception Illegal_expr
+
+(** {1 Static or dynamic size} *)
+
+type sd = Static | Dynamic
+
+let is_ref : Types.value_description -> bool = function
+  | { Types.val_kind =
+        Types.Val_prim { Primitive.prim_name = "%makemutable";
+                          prim_arity = 1 } } ->
+        true
+  | _ -> false
+
+(* See the note on abstracted arguments in the documentation for
+    Typedtree.Texp_apply *)
+let is_abstracted_arg : arg_label * expression option -> bool = function
+  | (_, None) -> true
+  | (_, Some _) -> false
+
+let classify_expression : Typedtree.expression -> sd =
+  (* We need to keep track of the size of expressions
+      bound by local declarations, to be able to predict
+      the size of variables. Compare:
+
+        let rec r =
+          let y = fun () -> r ()
+          in y
+
+      and
+
+        let rec r =
+          let y = if Random.bool () then ignore else fun () -> r ()
+          in y
+
+    In both cases the final address of `r` must be known before `y` is compiled,
+    and this is only possible if `r` has a statically-known size.
+
+    The first definition can be allowed (`y` has a statically-known
+    size) but the second one is unsound (`y` has no statically-known size).
+  *)
+  let rec classify_expression env e = match e.exp_desc with
+    (* binding and variable cases *)
+    | Texp_let (rec_flag, vb, e) ->
+        let env = classify_value_bindings rec_flag env vb in
+        classify_expression env e
+    | Texp_ident (path, _, _) ->
+        classify_path env path
+
+    (* non-binding cases *)
+    | Texp_open (_, e)
+    | Texp_letmodule (_, _, _, _, e)
+    | Texp_sequence (_, e)
+    | Texp_letexception (_, e) ->
+        classify_expression env e
+
+    | Texp_construct (_, {cstr_tag = Cstr_unboxed}, [e]) ->
+        classify_expression env e
+    | Texp_construct _ ->
+        Static
+
+    | Texp_record { representation = Record_unboxed _;
+                    fields = [| _, Overridden (_,e) |] } ->
+        classify_expression env e
+    | Texp_record _ ->
+        Static
+
+    | Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, _)
+      when is_ref vd ->
+        Static
+    | Texp_apply (_,args)
+      when List.exists is_abstracted_arg args ->
+        Static
+    | Texp_apply _ ->
+        Dynamic
+
+    | Texp_for _
+    | Texp_constant _
+    | Texp_new _
+    | Texp_instvar _
+    | Texp_tuple _
+    | Texp_array _
+    | Texp_variant _
+    | Texp_setfield _
+    | Texp_while _
+    | Texp_setinstvar _
+    | Texp_pack _
+    | Texp_object _
+    | Texp_function _
+    | Texp_lazy _
+    | Texp_unreachable
+    | Texp_extension_constructor _ ->
+        Static
+
+    | Texp_match _
+    | Texp_ifthenelse _
+    | Texp_send _
+    | Texp_field _
+    | Texp_assert _
+    | Texp_try _
+    | Texp_override _
+    | Texp_letop _ ->
+        Dynamic
+  and classify_value_bindings rec_flag env bindings =
+    (* We use a non-recursive classification, classifying each
+        binding with respect to the old environment
+        (before all definitions), even if the bindings are recursive.
+
+        Note: computing a fixpoint in some way would be more
+        precise, as the following could be allowed:
+
+          let rec topdef =
+            let rec x = y and y = fun () -> topdef ()
+            in x
+    *)
+    ignore rec_flag;
+    let old_env = env in
+    let add_value_binding env vb =
+      match vb.vb_pat.pat_desc with
+      | Tpat_var (id, _loc) ->
+          let size = classify_expression old_env vb.vb_expr in
+          Ident.add id size env
+      | _ ->
+          (* Note: we don't try to compute any size for complex patterns *)
+          env
+    in
+    List.fold_left add_value_binding env bindings
+  and classify_path env = function
+    | Path.Pident x ->
+        begin
+          try Ident.find_same x env
+          with Not_found ->
+            (* an identifier will be missing from the map if either:
+                - it is a non-local identifier
+                  (bound outside the letrec-binding we are analyzing)
+                - or it is bound by a complex (let p = e in ...) local binding
+                - or it is bound within a module (let module M = ... in ...)
+                  that we are not traversing for size computation
+
+                For non-local identifiers it might be reasonable (although
+                not completely clear) to consider them Static (they have
+                already been evaluated), but for the others we must
+                under-approximate with Dynamic.
+
+                This could be fixed by a more complete implementation.
+            *)
+            Dynamic
+        end
+    | Path.Pdot _ | Path.Papply _ ->
+        (* local modules could have such paths to local definitions;
+            classify_expression could be extend to compute module
+            shapes more precisely *)
+        Dynamic
+  in classify_expression Ident.empty
+
+
+(** {1 Usage of recursive variables} *)
+
+module Mode = struct
+  (** For an expression in a program, its "usage mode" represents
+      static information about how the value produced by the expression
+      will be used by the context around it. *)
+  type t =
+    | Ignore
+    (** [Ignore] is for subexpressions that are not used at all during
+       the evaluation of the whole program. This is the mode of
+       a variable in an expression in which it does not occur. *)
+
+    | Delay
+    (** A [Delay] context can be fully evaluated without evaluating its argument
+        , which will only be needed at a later point of program execution. For
+        example, [fun x -> ?] or [lazy ?] are [Delay] contexts. *)
+
+    | Guard
+    (** A [Guard] context returns the value as a member of a data structure,
+        for example a variant constructor or record. The value can safely be
+        defined mutually-recursively with their context, for example in
+        [let rec li = 1 :: li].
+        When these subexpressions participate in a cyclic definition,
+        this definition is productive/guarded.
+
+        The [Guard] mode is also used when a value is not dereferenced,
+        it is returned by a sub-expression, but the result of this
+        sub-expression is discarded instead of being returned.
+        For example, the subterm [?] is in a [Guard] context
+        in [let _ = ? in e] and in [?; e].
+        When these subexpressions participate in a cyclic definition,
+        they cannot create a self-loop.
+    *)
+
+    | Return
+    (** A [Return] context returns its value without further inspection.
+        This value cannot be defined mutually-recursively with its context,
+        as there is a risk of self-loop: in [let rec x = y and y = x], the
+        two definitions use a single variable in [Return] context. *)
+
+    | Dereference
+    (** A [Dereference] context consumes, inspects and uses the value
+        in arbitrary ways. Such a value must be fully defined at the point
+        of usage, it cannot be defined mutually-recursively with its context. *)
+
+  let equal = ((=) : t -> t -> bool)
+
+  (* Lower-ranked modes demand/use less of the variable/expression they qualify
+     -- so they allow more recursive definitions.
+
+     Ignore < Delay < Guard < Return < Dereference
+  *)
+  let rank = function
+    | Ignore -> 0
+    | Delay -> 1
+    | Guard -> 2
+    | Return -> 3
+    | Dereference -> 4
+
+  (* Returns the more conservative (highest-ranking) mode of the two
+     arguments.
+
+     In judgments we write (m + m') for (join m m').
+  *)
+  let join m m' =
+    if rank m >= rank m' then m else m'
+
+  (* If x is used with the mode m in e[x], and e[x] is used with mode
+     m' in e'[e[x]], then x is used with mode m'[m] (our notation for
+     "compose m' m") in e'[e[x]].
+
+     Return is neutral for composition: m[Return] = m = Return[m].
+
+     Composition is associative and [Ignore] is a zero/annihilator for
+     it: (compose Ignore m) and (compose m Ignore) are both Ignore. *)
+  let compose m' m = match m', m with
+    | Ignore, _ | _, Ignore -> Ignore
+    | Dereference, _ -> Dereference
+    | Delay, _ -> Delay
+    | Guard, Return -> Guard
+    | Guard, ((Dereference | Guard | Delay) as m) -> m
+    | Return, Return -> Return
+    | Return, ((Dereference | Guard | Delay) as m) -> m
+end
+
+type mode = Mode.t = Ignore | Delay | Guard | Return | Dereference
+
+module Env :
+sig
+  type t
+
+  val single : Ident.t -> Mode.t -> t
+  (** Create an environment with a single identifier used with a given mode.
+  *)
+
+  val empty : t
+  (** An environment with no used identifiers. *)
+
+  val find : Ident.t -> t -> Mode.t
+  (** Find the mode of an identifier in an environment.  The default mode is
+      Ignore. *)
+
+  val unguarded : t -> Ident.t list -> Ident.t list
+  (** unguarded e l: the list of all identifiers in l that are dereferenced or
+      returned in the environment e. *)
+
+  val dependent : t -> Ident.t list -> Ident.t list
+  (** dependent e l: the list of all identifiers in l that are used in e
+      (not ignored). *)
+
+  val join : t -> t -> t
+  val join_list : t list -> t
+  (** Environments can be joined pointwise (variable per variable) *)
+
+  val compose : Mode.t -> t -> t
+  (** Environment composition m[G] extends mode composition m1[m2]
+      by composing each mode in G pointwise *)
+
+  val remove : Ident.t -> t -> t
+  (** Remove an identifier from an environment. *)
+
+  val take: Ident.t -> t -> Mode.t * t
+  (** Remove an identifier from an environment, and return its mode *)
+
+  val remove_list : Ident.t list -> t -> t
+  (** Remove all the identifiers of a list from an environment. *)
+
+  val equal : t -> t -> bool
+end = struct
+  module M = Map.Make(Ident)
+
+  (** A "t" maps each rec-bound variable to an access status *)
+  type t = Mode.t M.t
+
+  let equal = M.equal Mode.equal
+
+  let find (id: Ident.t) (tbl: t) =
+    try M.find id tbl with Not_found -> Ignore
+
+  let empty = M.empty
+
+  let join (x: t) (y: t) =
+    M.fold
+      (fun (id: Ident.t) (v: Mode.t) (tbl: t) ->
+         let v' = find id tbl in
+         M.add id (Mode.join v v') tbl)
+      x y
+
+  let join_list li = List.fold_left join empty li
+
+  let compose m env =
+    M.map (Mode.compose m) env
+
+  let single id mode = M.add id mode empty
+
+  let unguarded env li =
+    List.filter (fun id -> Mode.rank (find id env) > Mode.rank Guard) li
+
+  let dependent env li =
+    List.filter (fun id -> Mode.rank (find id env) > Mode.rank Ignore) li
+
+  let remove = M.remove
+
+  let take id env = (find id env, remove id env)
+
+  let remove_list l env =
+    List.fold_left (fun env id -> M.remove id env) env l
+end
+
+let remove_pat pat env =
+  Env.remove_list (pat_bound_idents pat) env
+
+let remove_patlist pats env =
+  List.fold_right remove_pat pats env
+
+(* Usage mode judgments.
+
+   There are two main groups of judgment functions:
+
+   - Judgments of the form "G |- ... : m"
+     compute the environment G of a subterm ... from its mode m, so
+     the corresponding function has type [... -> Mode.t -> Env.t].
+
+     We write [... -> term_judg] in this case.
+
+   - Judgments of the form "G |- ... : m -| G'"
+
+     correspond to binding constructs (for example "let x = e" in the
+     term "let x = e in body") that have both an exterior environment
+     G (the environment of the whole term "let x = e in body") and an
+     interior environment G' (the environment at the "in", after the
+     binding construct has introduced new names in scope).
+
+     For example, let-binding could be given the following rule:
+
+       G |- e : m + m'
+       -----------------------------------
+       G+G' |- (let x = e) : m -| x:m', G'
+
+     Checking the whole term composes this judgment
+     with the "G |- e : m" form for the let body:
+
+       G  |- (let x = e) : m -| G'
+       G' |- body : m
+       -------------------------------
+       G |- let x = e in body : m
+
+     To this judgment "G |- e : m -| G'" our implementation gives the
+     type [... -> Mode.t -> Env.t -> Env.t]: it takes the mode and
+     interior environment as inputs, and returns the exterior
+     environment.
+
+     We write [... -> bind_judg] in this case.
+*)
+type term_judg = Mode.t -> Env.t
+type bind_judg = Mode.t -> Env.t -> Env.t
+
+let option : 'a. ('a -> term_judg) -> 'a option -> term_judg =
+  fun f o m -> match o with
+    | None -> Env.empty
+    | Some v -> f v m
+let list : 'a. ('a -> term_judg) -> 'a list -> term_judg =
+  fun f li m ->
+    List.fold_left (fun env item -> Env.join env (f item m)) Env.empty li
+let array : 'a. ('a -> term_judg) -> 'a array -> term_judg =
+  fun f ar m ->
+    Array.fold_left (fun env item -> Env.join env (f item m)) Env.empty ar
+
+let single : Ident.t -> term_judg = Env.single
+let remove_id : Ident.t -> term_judg -> term_judg =
+  fun id f m -> Env.remove id (f m)
+let remove_ids : Ident.t list -> term_judg -> term_judg =
+  fun ids f m -> Env.remove_list ids (f m)
+
+let join : term_judg list -> term_judg =
+  fun li m -> Env.join_list (List.map (fun f -> f m) li)
+
+let empty = fun _ -> Env.empty
+
+(* A judgment [judg] takes a mode from the context as input, and
+   returns an environment. The judgment [judg << m], given a mode [m']
+   from the context, evaluates [judg] in the composed mode [m'[m]]. *)
+let (<<) : term_judg -> Mode.t -> term_judg =
+  fun f inner_mode -> fun outer_mode -> f (Mode.compose outer_mode inner_mode)
+
+(* A binding judgment [binder] expects a mode and an inner environment,
+   and returns an outer environment. [binder >> judg] computes
+   the inner environment as the environment returned by [judg]
+   in the ambient mode. *)
+let (>>) : bind_judg -> term_judg -> term_judg =
+  fun binder term mode -> binder mode (term mode)
+
+(* Expression judgment:
+     G |- e : m
+   where (m) is an input of the code and (G) is an output;
+   in the Prolog mode notation, this is (+G |- -e : -m).
+*)
+let rec expression : Typedtree.expression -> term_judg =
+  fun exp -> match exp.exp_desc with
+    | Texp_ident (pth, _, _) ->
+      path pth
+    | Texp_let (rec_flag, bindings, body) ->
+      (*
+         G  |- <bindings> : m -| G'
+         G' |- body : m
+         -------------------------------
+         G |- let <bindings> in body : m
+      *)
+      value_bindings rec_flag bindings >> expression body
+    | Texp_letmodule (x, _, _, mexp, e) ->
+      module_binding (x, mexp) >> expression e
+    | Texp_match (e, cases, _) ->
+      (*
+         (Gi; mi |- pi -> ei : m)^i
+         G |- e : sum(mi)^i
+         ----------------------------------------------
+         G + sum(Gi)^i |- match e with (pi -> ei)^i : m
+       *)
+      (fun mode ->
+        let pat_envs, pat_modes =
+          List.split (List.map (fun c -> case c mode) cases) in
+        let env_e = expression e (List.fold_left Mode.join Ignore pat_modes) in
+        Env.join_list (env_e :: pat_envs))
+    | Texp_for (_, _, low, high, _, body) ->
+      (*
+        G1 |- low: m[Dereference]
+        G2 |- high: m[Dereference]
+        G3 |- body: m[Guard]
+        ---
+        G1 + G2 + G3 |- for _ = low to high do body done: m
+      *)
+      join [
+        expression low << Dereference;
+        expression high << Dereference;
+        expression body << Guard;
+      ]
+    | Texp_constant _ ->
+      empty
+    | Texp_new (pth, _, _) ->
+      (*
+        G |- c: m[Dereference]
+        -----------------------
+        G |- new c: m
+      *)
+      path pth << Dereference
+    | Texp_instvar (self_path, pth, _inst_var) ->
+        join [path self_path << Dereference; path pth]
+    | Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, [_, Some arg])
+      when is_ref vd ->
+      (*
+        G |- e: m[Guard]
+        ------------------
+        G |- ref e: m
+      *)
+      expression arg << Guard
+    | Texp_apply (e, args)  ->
+        let arg (_, eo) = option expression eo in
+        let app_mode = if List.exists is_abstracted_arg args
+          then (* see the comment on Texp_apply in typedtree.mli;
+                  the non-abstracted arguments are bound to local
+                  variables, which corresponds to a Guard mode. *)
+            Guard
+          else Dereference
+        in
+        join [expression e; list arg args] << app_mode
+    | Texp_tuple exprs ->
+      list expression exprs << Guard
+    | Texp_array exprs ->
+      let array_mode = match Typeopt.array_kind exp with
+        | Lambda.Pfloatarray ->
+            (* (flat) float arrays unbox their elements *)
+            Dereference
+        | Lambda.Pgenarray ->
+            (* This is counted as a use, because constructing a generic array
+               involves inspecting to decide whether to unbox (PR#6939). *)
+            Dereference
+        | Lambda.Paddrarray | Lambda.Pintarray ->
+            (* non-generic, non-float arrays act as constructors *)
+            Guard
+      in
+      list expression exprs << array_mode
+    | Texp_construct (_, desc, exprs) ->
+      let access_constructor =
+        match desc.cstr_tag with
+        | Cstr_extension (pth, _) ->
+          path pth << Dereference
+        | _ -> empty
+      in
+      let m' = match desc.cstr_tag with
+        | Cstr_unboxed ->
+          Return
+        | Cstr_constant _ | Cstr_block _ | Cstr_extension _ ->
+          Guard
+      in
+      join [
+        access_constructor;
+        list expression exprs << m'
+      ]
+    | Texp_variant (_, eo) ->
+      (*
+        G |- e: m[Guard]
+        ------------------   -----------
+        G |- `A e: m         [] |- `A: m
+      *)
+      option expression eo << Guard
+    | Texp_record { fields = es; extended_expression = eo;
+                    representation = rep } ->
+        let field_mode = match rep with
+          | Record_float -> Dereference
+          | Record_unboxed _ -> Return
+          | Record_regular | Record_inlined _
+          | Record_extension _ -> Guard
+        in
+        let field (_label, field_def) = match field_def with
+            Kept _ -> empty
+          | Overridden (_, e) -> expression e
+        in
+        join [
+          array field es << field_mode;
+          option expression eo << Dereference
+        ]
+    | Texp_ifthenelse (cond, ifso, ifnot) ->
+      (*
+        Gc |- c: m[Dereference]
+        G1 |- e1: m
+        G2 |- e2: m
+        ---
+        Gc + G1 + G2 |- if c then e1 else e2: m
+
+      Note: `if c then e1 else e2` is treated in the same way as
+      `match c with true -> e1 | false -> e2`
+      *)
+      join [
+        expression cond << Dereference;
+        expression ifso;
+        option expression ifnot;
+      ]
+    | Texp_setfield (e1, _, _, e2) ->
+      (*
+        G1 |- e1: m[Dereference]
+        G2 |- e2: m[Dereference]
+        ---
+        G1 + G2 |- e1.x <- e2: m
+
+        Note: e2 is dereferenced in the case of a field assignment to
+        a record of unboxed floats in that case, e2 evaluates to
+        a boxed float and it is unboxed on assignment.
+      *)
+      join [
+        expression e1 << Dereference;
+        expression e2 << Dereference;
+      ]
+    | Texp_sequence (e1, e2) ->
+      (*
+        G1 |- e1: m[Guard]
+        G2 |- e2: m
+        --------------------
+        G1 + G2 |- e1; e2: m
+
+        Note: `e1; e2` is treated in the same way as `let _ = e1 in e2`
+      *)
+      join [
+        expression e1 << Guard;
+        expression e2;
+      ]
+    | Texp_while (cond, body) ->
+      (*
+        G1 |- cond: m[Dereference]
+        G2 |- body: m[Guard]
+        ---------------------------------
+        G1 + G2 |- while cond do body done: m
+      *)
+      join [
+        expression cond << Dereference;
+        expression body << Guard;
+      ]
+    | Texp_send (e1, _, eo) ->
+      (*
+        G |- e: m[Dereference]
+        ---------------------- (plus weird 'eo' option)
+        G |- e#x: m
+      *)
+      join [
+        expression e1 << Dereference;
+        option expression eo << Dereference;
+      ]
+    | Texp_field (e, _, _) ->
+      (*
+        G |- e: m[Dereference]
+        -----------------------
+        G |- e.x: m
+      *)
+      expression e << Dereference
+    | Texp_setinstvar (pth,_,_,e) ->
+      (*
+        G |- e: m[Dereference]
+        ----------------------
+        G |- x <- e: m
+      *)
+      join [
+        path pth << Dereference;
+        expression e << Dereference;
+      ]
+    | Texp_letexception ({ext_id}, e) ->
+      (* G |- e: m
+         ----------------------------
+         G |- let exception A in e: m
+      *)
+      remove_id ext_id (expression e)
+    | Texp_assert e ->
+      (*
+        G |- e: m[Dereference]
+        -----------------------
+        G |- assert e: m
+
+        Note: `assert e` is treated just as if `assert` was a function.
+      *)
+      expression e << Dereference
+    | Texp_pack mexp ->
+      (*
+        G |- M: m
+        ----------------
+        G |- module M: m
+      *)
+      modexp mexp
+    | Texp_object (clsstrct, _) ->
+      class_structure clsstrct
+    | Texp_try (e, cases) ->
+      (*
+        G |- e: m      (Gi; _ |- pi -> ei : m)^i
+        --------------------------------------------
+        G + sum(Gi)^i |- try e with (pi -> ei)^i : m
+
+        Contrarily to match, the patterns p do not inspect
+        the value of e, so their mode does not influence the
+        mode of e.
+      *)
+      let case_env c m = fst (case c m) in
+      join [
+        expression e;
+        list case_env cases;
+      ]
+    | Texp_override (pth, fields) ->
+      (*
+         G |- pth : m   (Gi |- ei : m[Dereference])^i
+         ----------------------------------------------------
+         G + sum(Gi)^i |- {< (xi = ei)^i >} (at path pth) : m
+
+         Note: {< .. >} is desugared to a function application, but
+         the function implementation might still use its arguments in
+         a guarded way only -- intuitively it should behave as a constructor.
+         We could possibly refine the arguments' Dereference into Guard here.
+      *)
+      let field (_, _, arg) = expression arg in
+      join [
+        path pth << Dereference;
+        list field fields << Dereference;
+      ]
+    | Texp_function { cases } ->
+      (*
+         (Gi; _ |- pi -> ei : m[Delay])^i
+         --------------------------------------
+         sum(Gi)^i |- function (pi -> ei)^i : m
+
+         Contrarily to match, the value that is pattern-matched
+         is bound locally, so the pattern modes do not influence
+         the final environment.
+      *)
+      let case_env c m = fst (case c m) in
+      list case_env cases << Delay
+    | Texp_lazy e ->
+      (*
+        G |- e: m[Delay]
+        ----------------  (modulo some subtle compiler optimizations)
+        G |- lazy e: m
+      *)
+      let lazy_mode = match Typeopt.classify_lazy_argument e with
+        | `Constant_or_function
+        | `Identifier _
+        | `Float_that_cannot_be_shortcut ->
+          Return
+        | `Other ->
+          Delay
+      in
+      expression e << lazy_mode
+    | Texp_letop{let_; ands; body; _} ->
+        let case_env c m = fst (case c m) in
+        join [
+          list binding_op (let_ :: ands) << Dereference;
+          case_env body << Delay
+        ]
+    | Texp_unreachable ->
+      (*
+        ----------
+        [] |- .: m
+      *)
+      empty
+    | Texp_extension_constructor (_lid, pth) ->
+      path pth << Dereference
+    | Texp_open (od, e) ->
+      open_declaration od >> expression e
+
+and binding_op : Typedtree.binding_op -> term_judg =
+  fun bop ->
+    join [path bop.bop_op_path; expression bop.bop_exp]
+
+and class_structure : Typedtree.class_structure -> term_judg =
+  fun cs -> list class_field cs.cstr_fields
+
+and class_field : Typedtree.class_field -> term_judg =
+  fun cf -> match cf.cf_desc with
+    | Tcf_inherit (_, ce, _super, _inh_vars, _inh_meths) ->
+      class_expr ce << Dereference
+    | Tcf_val (_lab, _mut, _, cfk, _) ->
+      class_field_kind cfk
+    | Tcf_method (_, _, cfk) ->
+      class_field_kind cfk
+    | Tcf_constraint _ ->
+      empty
+    | Tcf_initializer e ->
+      expression e << Dereference
+    | Tcf_attribute _ ->
+      empty
+
+and class_field_kind : Typedtree.class_field_kind -> term_judg =
+  fun cfk -> match cfk with
+    | Tcfk_virtual _ ->
+      empty
+    | Tcfk_concrete (_, e) ->
+      expression e << Dereference
+
+and modexp : Typedtree.module_expr -> term_judg =
+  fun mexp -> match mexp.mod_desc with
+    | Tmod_ident (pth, _) ->
+      path pth
+    | Tmod_structure s ->
+      structure s
+    | Tmod_functor (_, e) ->
+      modexp e << Delay
+    | Tmod_apply (f, p, _) ->
+      join [
+        modexp f << Dereference;
+        modexp p << Dereference;
+      ]
+    | Tmod_constraint (mexp, _, _, coe) ->
+      let rec coercion coe k = match coe with
+        | Tcoerce_none ->
+          k Return
+        | Tcoerce_structure _
+        | Tcoerce_functor _ ->
+          (* These coercions perform a shallow copy of the input module,
+             by creating a new module with fields obtained by accessing
+             the same fields in the input module. *)
+           k Dereference
+        | Tcoerce_primitive _ ->
+          (* This corresponds to 'external' declarations,
+             and the coercion ignores its argument *)
+          k Ignore
+        | Tcoerce_alias (_, pth, coe) ->
+          (* Alias coercions ignore their arguments, but they evaluate
+             their alias module 'pth' under another coercion. *)
+          coercion coe (fun m -> path pth << m)
+      in
+      coercion coe (fun m -> modexp mexp << m)
+    | Tmod_unpack (e, _) ->
+      expression e
+
+
+(* G |- pth : m *)
+and path : Path.t -> term_judg =
+  (*
+    ------------
+    x: m |- x: m
+
+    G |- A: m[Dereference]
+    -----------------------
+    G |- A.x: m
+
+    G1 |- A: m[Dereference]
+    G2 |- B: m[Dereference]
+    ------------------------ (as for term application)
+    G1 + G2 |- A(B): m
+  *)
+  fun pth -> match pth with
+    | Path.Pident x ->
+        single x
+    | Path.Pdot (t, _) ->
+        path t << Dereference
+    | Path.Papply (f, p) ->
+        join [
+          path f << Dereference;
+          path p << Dereference;
+        ]
+
+(* G |- struct ... end : m *)
+and structure : Typedtree.structure -> term_judg =
+  (*
+    G1, {x: _, x in vars(G1)} |- item1: G2 + ... + Gn in m
+    G2, {x: _, x in vars(G2)} |- item2: G3 + ... + Gn in m
+    ...
+    Gn, {x: _, x in vars(Gn)} |- itemn: [] in m
+    ---
+    (G1 + ... + Gn) - V |- struct item1 ... itemn end: m
+  *)
+  fun s m ->
+    List.fold_right (fun it env -> structure_item it m env)
+      s.str_items Env.empty
+
+(* G |- <structure item> : m -| G'
+   where G is an output and m, G' are inputs *)
+and structure_item : Typedtree.structure_item -> bind_judg =
+  fun s m env -> match s.str_desc with
+    | Tstr_eval (e, _) ->
+      (*
+        Ge |- e: m[Guard]
+        G |- items: m -| G'
+        ---------------------------------
+        Ge + G |- (e;; items): m -| G'
+
+        The expression `e` is treated in the same way as let _ = e
+      *)
+      let judg_e = expression e << Guard in
+      Env.join (judg_e m) env
+    | Tstr_value (rec_flag, bindings) ->
+      value_bindings rec_flag bindings m env
+    | Tstr_module {mb_id; mb_expr} ->
+      module_binding (mb_id, mb_expr) m env
+    | Tstr_recmodule mbs ->
+      let bindings = List.map (fun {mb_id; mb_expr} -> (mb_id, mb_expr)) mbs in
+      recursive_module_bindings bindings m env
+    | Tstr_primitive _ ->
+      env
+    | Tstr_type _ ->
+      (*
+        -------------------
+        G |- type t: m -| G
+      *)
+      env
+    | Tstr_typext {tyext_constructors = exts; _} ->
+      let ext_ids = List.map (fun {ext_id = id; _} -> id) exts in
+      Env.join
+        (list extension_constructor exts m)
+        (Env.remove_list ext_ids env)
+    | Tstr_exception {tyexn_constructor = ext; _} ->
+      Env.join
+        (extension_constructor ext m)
+        (Env.remove ext.ext_id env)
+    | Tstr_modtype _
+    | Tstr_class_type _
+    | Tstr_attribute _ ->
+      env
+    | Tstr_open od ->
+      open_declaration od m env
+    | Tstr_class classes ->
+        let class_ids =
+          let class_id ({ci_id_class = id; _}, _) = id in
+          List.map class_id classes in
+        let class_declaration ({ci_expr; _}, _) m =
+          Env.remove_list class_ids (class_expr ci_expr m) in
+        Env.join
+          (list class_declaration classes m)
+          (Env.remove_list class_ids env)
+    | Tstr_include { incl_mod = mexp; incl_type = mty; _ } ->
+      let included_ids = List.map Types.signature_item_id mty in
+      Env.join (modexp mexp m) (Env.remove_list included_ids env)
+
+(* G |- module M = E : m -| G *)
+and module_binding : (Ident.t option * Typedtree.module_expr) -> bind_judg =
+  fun (id, mexp) m env ->
+      (*
+        GE |- E: m[mM + Guard]
+        -------------------------------------
+        GE + G |- module M = E : m -| M:mM, G
+      *)
+      let judg_E, env =
+        match id with
+        | None -> modexp mexp << Guard, env
+        | Some id ->
+          let mM, env = Env.take id env in
+          let judg_E = modexp mexp << (Mode.join mM Guard) in
+          judg_E, env
+      in
+      Env.join (judg_E m) env
+
+and open_declaration : Typedtree.open_declaration -> bind_judg =
+  fun { open_expr = mexp; open_bound_items = sg; _ } m env ->
+      let judg_E = modexp mexp in
+      let bound_ids = List.map Types.signature_item_id sg in
+      Env.join (judg_E m) (Env.remove_list bound_ids env)
+
+and recursive_module_bindings
+  : (Ident.t option * Typedtree.module_expr) list -> bind_judg =
+  fun m_bindings m env ->
+    let mids = List.filter_map fst m_bindings in
+    let binding (mid, mexp) m =
+      let judg_E =
+        match mid with
+        | None -> modexp mexp << Guard
+        | Some mid ->
+          let mM = Env.find mid env in
+          modexp mexp << (Mode.join mM Guard)
+      in
+      Env.remove_list mids (judg_E m)
+    in
+    Env.join (list binding m_bindings m) (Env.remove_list mids env)
+
+and class_expr : Typedtree.class_expr -> term_judg =
+  fun ce -> match ce.cl_desc with
+    | Tcl_ident (pth, _, _) ->
+        path pth << Dereference
+    | Tcl_structure cs ->
+        class_structure cs
+    | Tcl_fun (_, _, args, ce, _) ->
+        let ids = List.map fst args in
+        remove_ids ids (class_expr ce << Delay)
+    | Tcl_apply (ce, args) ->
+        let arg (_label, eo) = option expression eo in
+        join [
+          class_expr ce << Dereference;
+          list arg args << Dereference;
+        ]
+    | Tcl_let (rec_flag, bindings, _, ce) ->
+      value_bindings rec_flag bindings >> class_expr ce
+    | Tcl_constraint (ce, _, _, _, _) ->
+        class_expr ce
+    | Tcl_open (_, ce) ->
+        class_expr ce
+
+and extension_constructor : Typedtree.extension_constructor -> term_judg =
+  fun ec -> match ec.ext_kind with
+    | Text_decl _ ->
+      empty
+    | Text_rebind (pth, _lid) ->
+      path pth
+
+(* G |- let (rec?) (pi = ei)^i : m -| G' *)
+and value_bindings : rec_flag -> Typedtree.value_binding list -> bind_judg =
+  fun rec_flag bindings mode bound_env ->
+    let all_bound_pats = List.map (fun vb -> vb.vb_pat) bindings in
+    let outer_env = remove_patlist all_bound_pats bound_env in
+    let bindings_env =
+      match rec_flag with
+      | Nonrecursive ->
+        (*
+           (Gi, pi:_ |- ei : m[mbody_i])^i   (pi : mbody_i -| D)^i
+           ------------------------------------------------------------
+           Sum(Gi) + (D - (pi)^i) |- let (pi=ei)^i : m -| D
+        *)
+          let binding_env {vb_pat; vb_expr; _} m =
+            let m' = Mode.compose m (pattern vb_pat bound_env) in
+            remove_pat vb_pat (expression vb_expr m') in
+          list binding_env bindings mode
+      | Recursive ->
+        (*
+           (Gi, (xj : mdef_ij)^j |- ei : m[mbody_i])^i   (xi : mbody_i -| D)^i
+           G'i = Gi + mdef_ij[G'j]
+           -------------------------------------------------------------------
+           Sum(G'i) + (D - (pi)^i) |- let rec (xi=ei)^i : m -| D
+
+           The (mdef_ij)^i,j are a family of modes over two indices:
+           mdef_ij represents the mode of use, within e_i the definition of x_i,
+           of the mutually-recursive variable x_j.
+
+           The (G'i)^i are defined from the (Gi)^i as a family of equations,
+           whose smallest solution is computed as a least fixpoint.
+
+           The (Gi)^i are the "immediate" dependencies of each (ei)^i
+           on the outer context (excluding the mutually-defined
+           variables).
+           The (G'i)^i contain the "transitive" dependencies as well:
+           if ei depends on xj, then the dependencies of G'i of xi
+           must contain the dependencies of G'j, composed by
+           the mode mdef_ij of use of xj in ei.
+
+           For example, consider:
+
+             let rec z =
+               let rec x = ref y
+               and y = ref z
+               in f x
+
+           this definition should be rejected as the body [f x]
+           dereferences [x], which can be used to access the
+           yet-unitialized value [z]. This requires realizing that [x]
+           depends on [z] through [y], which requires the transitive
+           closure computation.
+
+           An earlier version of our check would take only the (Gi)^i
+           instead of the (G'i)^i, which is incorrect and would accept
+           the example above.
+        *)
+          (* [binding_env] takes a binding (x_i = e_i)
+             and computes (Gi, (mdef_ij)^j). *)
+          let binding_env {vb_pat = x_i; vb_expr = e_i; _} =
+            let mbody_i = pattern x_i bound_env in
+            (* Gi, (x_j:mdef_ij)^j  *)
+            let rhs_env_i = expression e_i (Mode.compose mode mbody_i) in
+            (* (mdef_ij)^j (for a fixed i) *)
+            let mutual_modes =
+              let mdef_ij {vb_pat = x_j; _} = pattern x_j rhs_env_i in
+              List.map mdef_ij bindings in
+            (* Gi *)
+            let env_i = remove_patlist all_bound_pats rhs_env_i in
+            (* (Gi, (mdef_ij)^j) *)
+            (env_i, mutual_modes) in
+          let env, mdef =
+            List.split (List.map binding_env bindings) in
+          let rec transitive_closure env =
+            let transitive_deps env_i mdef_i =
+              (* Gi, (mdef_ij)^j => Gi + Sum_j mdef_ij[Gj] *)
+              Env.join env_i
+                (Env.join_list (List.map2 Env.compose mdef_i env)) in
+            let env' = List.map2 transitive_deps env mdef in
+            if List.for_all2 Env.equal env env'
+            then env'
+            else transitive_closure env'
+          in
+          let env'_i = transitive_closure env in
+          Env.join_list env'_i
+    in Env.join bindings_env outer_env
+
+(* G; m' |- (p -> e) : m
+   with outputs G, m' and input m
+
+   m' is the mode under which the scrutinee of p
+   (the value matched against p) is placed.
+*)
+and case
+    : 'k . 'k Typedtree.case -> mode -> Env.t * mode
+  = fun { Typedtree.c_lhs; c_guard; c_rhs } ->
+    (*
+       Ge |- e : m    Gg |- g : m[Dereference]
+       G := Ge+Gg     p : mp -| G
+       ----------------------------------------
+       G - p; m[mp] |- (p (when g)? -> e) : m
+    *)
+    let judg = join [
+        option expression c_guard << Dereference;
+        expression c_rhs;
+      ] in
+    (fun m ->
+       let env = judg m in
+       (remove_pat c_lhs env), Mode.compose m (pattern c_lhs env))
+
+(* p : m -| G
+   with output m and input G
+
+   m is the mode under which the scrutinee of p is placed.
+*)
+and pattern : type k . k general_pattern -> Env.t -> mode = fun pat env ->
+  (*
+    mp := | Dereference if p is destructuring
+          | Guard       otherwise
+    me := sum{G(x), x in vars(p)}
+    --------------------------------------------
+    p : (mp + me) -| G
+  *)
+  let m_pat = if is_destructuring_pattern pat
+              then Dereference
+              else Guard
+  in
+  let m_env =
+    pat_bound_idents pat
+    |> List.map (fun id -> Env.find id env)
+    |> List.fold_left Mode.join Ignore
+  in
+  Mode.join m_pat m_env
+
+and is_destructuring_pattern : type k . k general_pattern -> bool =
+  fun pat -> match pat.pat_desc with
+    | Tpat_any -> false
+    | Tpat_var (_, _) -> false
+    | Tpat_alias (pat, _, _) -> is_destructuring_pattern pat
+    | Tpat_constant _ -> true
+    | Tpat_tuple _ -> true
+    | Tpat_construct (_, _, _) -> true
+    | Tpat_variant _ -> true
+    | Tpat_record (_, _) -> true
+    | Tpat_array _ -> true
+    | Tpat_lazy _ -> true
+    | Tpat_value pat -> is_destructuring_pattern (pat :> pattern)
+    | Tpat_exception _ -> false
+    | Tpat_or (l,r,_) ->
+        is_destructuring_pattern l || is_destructuring_pattern r
+
+let is_valid_recursive_expression idlist expr =
+  let ty = expression expr Return in
+  match Env.unguarded ty idlist, Env.dependent ty idlist,
+        classify_expression expr with
+  | _ :: _, _, _ (* The expression inspects rec-bound variables *)
+  | [], _ :: _, Dynamic -> (* The expression depends on rec-bound variables
+                              and its size is unknown *)
+      false
+  | [], _, Static (* The expression has known size *)
+  | [], [], Dynamic -> (* The expression has unknown size,
+                          but does not depend on rec-bound variables *)
+      true
+
+(* A class declaration may contain let-bindings. If they are recursive,
+   their validity will already be checked by [is_valid_recursive_expression]
+   during type-checking. This function here prevents a different kind of
+   invalid recursion, which is the unsafe creations of objects of this class
+   in the let-binding. For example,
+   {|class a = let x = new a in object ... end|}
+   is forbidden, but
+   {|class a = let x () = new a in object ... end|}
+   is allowed.
+*)
+let is_valid_class_expr idlist ce =
+  let rec class_expr : mode -> Typedtree.class_expr -> Env.t =
+    fun mode ce -> match ce.cl_desc with
+      | Tcl_ident (_, _, _) ->
+        (*
+          ----------
+          [] |- a: m
+        *)
+        Env.empty
+      | Tcl_structure _ ->
+        (*
+          -----------------------
+          [] |- struct ... end: m
+        *)
+        Env.empty
+      | Tcl_fun (_, _, _, _, _) -> Env.empty
+        (*
+          ---------------------------
+          [] |- fun x1 ... xn -> C: m
+        *)
+      | Tcl_apply (_, _) -> Env.empty
+      | Tcl_let (rec_flag, bindings, _, ce) ->
+        value_bindings rec_flag bindings mode (class_expr mode ce)
+      | Tcl_constraint (ce, _, _, _, _) ->
+        class_expr mode ce
+      | Tcl_open (_, ce) ->
+        class_expr mode ce
+  in
+  match Env.unguarded (class_expr Return ce) idlist with
+  | [] -> true
+  | _ :: _ -> false
diff --git a/upstream/ocaml_412/typing/rec_check.mli b/upstream/ocaml_412/typing/rec_check.mli
new file mode 100644
index 0000000..aa5c1ca
--- /dev/null
+++ b/upstream/ocaml_412/typing/rec_check.mli
@@ -0,0 +1,19 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*               Jeremy Yallop, University of Cambridge                   *)
+(*                                                                        *)
+(*   Copyright 2017 Jeremy Yallop                                         *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+exception Illegal_expr
+
+val is_valid_recursive_expression : Ident.t list -> Typedtree.expression -> bool
+
+val is_valid_class_expr : Ident.t list -> Typedtree.class_expr -> bool
diff --git a/upstream/ocaml_412/typing/stypes.ml b/upstream/ocaml_412/typing/stypes.ml
new file mode 100644
index 0000000..dfbcc99
--- /dev/null
+++ b/upstream/ocaml_412/typing/stypes.ml
@@ -0,0 +1,210 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Damien Doligez, projet Moscova, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2003 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Recording and dumping (partial) type information *)
+
+(*
+  We record all types in a list as they are created.
+  This means we can dump type information even if type inference fails,
+  which is extremely important, since type information is most
+  interesting in case of errors.
+*)
+
+open Annot;;
+open Lexing;;
+open Location;;
+open Typedtree;;
+
+let output_int oc i = output_string oc (Int.to_string i)
+
+type annotation =
+  | Ti_pat : 'k pattern_category * 'k general_pattern -> annotation
+  | Ti_expr  of expression
+  | Ti_class of class_expr
+  | Ti_mod   of module_expr
+  | An_call of Location.t * Annot.call
+  | An_ident of Location.t * string * Annot.ident
+;;
+
+let get_location ti =
+  match ti with
+  | Ti_pat (_, p)   -> p.pat_loc
+  | Ti_expr e  -> e.exp_loc
+  | Ti_class c -> c.cl_loc
+  | Ti_mod m   -> m.mod_loc
+  | An_call (l, _k) -> l
+  | An_ident (l, _s, _k) -> l
+;;
+
+let annotations = ref ([] : annotation list);;
+let phrases = ref ([] : Location.t list);;
+
+let record ti =
+  if !Clflags.annotations && not (get_location ti).Location.loc_ghost then
+    annotations := ti :: !annotations
+;;
+
+let record_phrase loc =
+  if !Clflags.annotations then phrases := loc :: !phrases;
+;;
+
+(* comparison order:
+   the intervals are sorted by order of increasing upper bound
+   same upper bound -> sorted by decreasing lower bound
+*)
+let cmp_loc_inner_first loc1 loc2 =
+  match compare loc1.loc_end.pos_cnum loc2.loc_end.pos_cnum with
+  | 0 -> compare loc2.loc_start.pos_cnum loc1.loc_start.pos_cnum
+  | x -> x
+;;
+let cmp_ti_inner_first ti1 ti2 =
+  cmp_loc_inner_first (get_location ti1) (get_location ti2)
+;;
+
+let print_position pp pos =
+  if pos = dummy_pos then
+    output_string pp "--"
+  else begin
+    output_char pp '\"';
+    output_string pp (String.escaped pos.pos_fname);
+    output_string pp "\" ";
+    output_int pp pos.pos_lnum;
+    output_char pp ' ';
+    output_int pp pos.pos_bol;
+    output_char pp ' ';
+    output_int pp pos.pos_cnum;
+  end
+;;
+
+let print_location pp loc =
+  print_position pp loc.loc_start;
+  output_char pp ' ';
+  print_position pp loc.loc_end;
+;;
+
+let sort_filter_phrases () =
+  let ph = List.sort (fun x y -> cmp_loc_inner_first y x) !phrases in
+  let rec loop accu cur l =
+    match l with
+    | [] -> accu
+    | loc :: t ->
+       if cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum
+          && cur.loc_end.pos_cnum >= loc.loc_end.pos_cnum
+       then loop accu cur t
+       else loop (loc :: accu) loc t
+  in
+  phrases := loop [] Location.none ph;
+;;
+
+let rec printtyp_reset_maybe loc =
+  match !phrases with
+  | cur :: t when cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum ->
+     Printtyp.reset ();
+     phrases := t;
+     printtyp_reset_maybe loc;
+  | _ -> ()
+;;
+
+let call_kind_string k =
+  match k with
+  | Tail -> "tail"
+  | Stack -> "stack"
+  | Inline -> "inline"
+;;
+
+let print_ident_annot pp str k =
+  match k with
+  | Idef l ->
+      output_string pp "def ";
+      output_string pp str;
+      output_char pp ' ';
+      print_location pp l;
+      output_char pp '\n'
+  | Iref_internal l ->
+      output_string pp "int_ref ";
+      output_string pp str;
+      output_char pp ' ';
+      print_location pp l;
+      output_char pp '\n'
+  | Iref_external ->
+      output_string pp "ext_ref ";
+      output_string pp str;
+      output_char pp '\n'
+;;
+
+(* The format of the annotation file is documented in emacs/caml-types.el. *)
+
+let print_info pp prev_loc ti =
+  match ti with
+  | Ti_class _ | Ti_mod _ -> prev_loc
+  | Ti_pat  (_, {pat_loc = loc; pat_type = typ; pat_env = env})
+  | Ti_expr     {exp_loc = loc; exp_type = typ; exp_env = env} ->
+      if loc <> prev_loc then begin
+        print_location pp loc;
+        output_char pp '\n'
+      end;
+      output_string pp "type(\n";
+      printtyp_reset_maybe loc;
+      Printtyp.mark_loops typ;
+      Format.pp_print_string Format.str_formatter "  ";
+      Printtyp.wrap_printing_env ~error:false env
+                       (fun () -> Printtyp.type_sch Format.str_formatter typ);
+      Format.pp_print_newline Format.str_formatter ();
+      let s = Format.flush_str_formatter () in
+      output_string pp s;
+      output_string pp ")\n";
+      loc
+  | An_call (loc, k) ->
+      if loc <> prev_loc then begin
+        print_location pp loc;
+        output_char pp '\n'
+      end;
+      output_string pp "call(\n  ";
+      output_string pp (call_kind_string k);
+      output_string pp "\n)\n";
+      loc
+  | An_ident (loc, str, k) ->
+      if loc <> prev_loc then begin
+        print_location pp loc;
+        output_char pp '\n'
+      end;
+      output_string pp "ident(\n  ";
+      print_ident_annot pp str k;
+      output_string pp ")\n";
+      loc
+;;
+
+let get_info () =
+  let info = List.fast_sort cmp_ti_inner_first !annotations in
+  annotations := [];
+  info
+;;
+
+let dump filename =
+  if !Clflags.annotations then begin
+    let do_dump _temp_filename pp =
+      let info = get_info () in
+      sort_filter_phrases ();
+      ignore (List.fold_left (print_info pp) Location.none info) in
+    begin match filename with
+    | None -> do_dump "" stdout
+    | Some filename ->
+        Misc.output_to_file_via_temporary ~mode:[Open_text] filename do_dump
+    end;
+    phrases := [];
+  end else begin
+    annotations := [];
+  end;
+;;
diff --git a/upstream/ocaml_412/typing/stypes.mli b/upstream/ocaml_412/typing/stypes.mli
new file mode 100644
index 0000000..fda575f
--- /dev/null
+++ b/upstream/ocaml_412/typing/stypes.mli
@@ -0,0 +1,36 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Damien Doligez, projet Moscova, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2003 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Recording and dumping (partial) type information *)
+
+(* Clflags.save_types must be true *)
+
+open Typedtree;;
+
+type annotation =
+  | Ti_pat : 'k pattern_category * 'k general_pattern -> annotation
+  | Ti_expr  of expression
+  | Ti_class of class_expr
+  | Ti_mod   of module_expr
+  | An_call of Location.t * Annot.call
+  | An_ident of Location.t * string * Annot.ident
+;;
+
+val record : annotation -> unit;;
+val record_phrase : Location.t -> unit;;
+val dump : string option -> unit;;
+
+val get_location : annotation -> Location.t;;
+val get_info : unit -> annotation list;;
diff --git a/upstream/ocaml_412/typing/subst.ml b/upstream/ocaml_412/typing/subst.ml
new file mode 100644
index 0000000..9ad1ecb
--- /dev/null
+++ b/upstream/ocaml_412/typing/subst.ml
@@ -0,0 +1,557 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Substitutions *)
+
+open Misc
+open Path
+open Types
+open Btype
+
+open Local_store
+
+type type_replacement =
+  | Path of Path.t
+  | Type_function of { params : type_expr list; body : type_expr }
+
+type t =
+  { types: type_replacement Path.Map.t;
+    modules: Path.t Path.Map.t;
+    modtypes: module_type Ident.Map.t;
+    for_saving: bool;
+  }
+
+let identity =
+  { types = Path.Map.empty;
+    modules = Path.Map.empty;
+    modtypes = Ident.Map.empty;
+    for_saving = false;
+  }
+
+let add_type_path id p s = { s with types = Path.Map.add id (Path p) s.types }
+let add_type id p s = add_type_path (Pident id) p s
+
+let add_type_function id ~params ~body s =
+  { s with types = Path.Map.add id (Type_function { params; body }) s.types }
+
+let add_module_path id p s = { s with modules = Path.Map.add id p s.modules }
+let add_module id p s = add_module_path (Pident id) p s
+
+let add_modtype id ty s = { s with modtypes = Ident.Map.add id ty s.modtypes }
+
+let for_saving s = { s with for_saving = true }
+
+let loc s x =
+  if s.for_saving && not !Clflags.keep_locs then Location.none else x
+
+let remove_loc =
+  let open Ast_mapper in
+  {default_mapper with location = (fun _this _loc -> Location.none)}
+
+let is_not_doc = function
+  | {Parsetree.attr_name = {Location.txt = "ocaml.doc"}; _} -> false
+  | {Parsetree.attr_name = {Location.txt = "ocaml.text"}; _} -> false
+  | {Parsetree.attr_name = {Location.txt = "doc"}; _} -> false
+  | {Parsetree.attr_name = {Location.txt = "text"}; _} -> false
+  | _ -> true
+
+let attrs s x =
+  let x =
+    if s.for_saving && not !Clflags.keep_docs then
+      List.filter is_not_doc x
+    else x
+  in
+    if s.for_saving && not !Clflags.keep_locs
+    then remove_loc.Ast_mapper.attributes remove_loc x
+    else x
+
+let rec module_path s path =
+  try Path.Map.find path s.modules
+  with Not_found ->
+    match path with
+    | Pident _ -> path
+    | Pdot(p, n) ->
+       Pdot(module_path s p, n)
+    | Papply(p1, p2) ->
+       Papply(module_path s p1, module_path s p2)
+
+let modtype_path s = function
+    Pident id as p ->
+      begin try
+        match Ident.Map.find id s.modtypes with
+          | Mty_ident p -> p
+          | _ -> fatal_error "Subst.modtype_path"
+      with Not_found -> p end
+  | Pdot(p, n) ->
+      Pdot(module_path s p, n)
+  | Papply _ ->
+      fatal_error "Subst.modtype_path"
+
+let type_path s path =
+  match Path.Map.find path s.types with
+  | Path p -> p
+  | Type_function _ -> assert false
+  | exception Not_found ->
+     match path with
+     | Pident _ -> path
+     | Pdot(p, n) ->
+        Pdot(module_path s p, n)
+     | Papply _ ->
+        fatal_error "Subst.type_path"
+
+let type_path s p =
+  match Path.constructor_typath p with
+  | Regular p -> type_path s p
+  | Cstr (ty_path, cstr) -> Pdot(type_path s ty_path, cstr)
+  | LocalExt _ -> type_path s p
+  | Ext (p, cstr) -> Pdot(module_path s p, cstr)
+
+let to_subst_by_type_function s p =
+  match Path.Map.find p s.types with
+  | Path _ -> false
+  | Type_function _ -> true
+  | exception Not_found -> false
+
+(* Special type ids for saved signatures *)
+
+let new_id = s_ref (-1)
+let reset_for_saving () = new_id := -1
+
+let newpersty desc =
+  decr new_id;
+  { desc; level = generic_level; scope = Btype.lowest_level; id = !new_id }
+
+(* ensure that all occurrences of 'Tvar None' are physically shared *)
+let tvar_none = Tvar None
+let tunivar_none = Tunivar None
+let norm = function
+  | Tvar None -> tvar_none
+  | Tunivar None -> tunivar_none
+  | d -> d
+
+let ctype_apply_env_empty = ref (fun _ -> assert false)
+
+(* Similar to [Ctype.nondep_type_rec]. *)
+let rec typexp copy_scope s ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tvar _ | Tunivar _ as desc ->
+      if s.for_saving || ty.id < 0 then
+        let ty' =
+          if s.for_saving then newpersty (norm desc)
+          else newty2 ty.level desc
+        in
+        For_copy.save_desc copy_scope ty desc;
+        ty.desc <- Tsubst ty';
+        ty'
+      else ty
+  | Tsubst ty ->
+      ty
+  | Tfield (m, k, _t1, _t2) when not s.for_saving && m = dummy_method
+      && field_kind_repr k <> Fabsent && (repr ty).level < generic_level ->
+      (* do not copy the type of self when it is not generalized *)
+      ty
+(* cannot do it, since it would omit substitution
+  | Tvariant row when not (static_row row) ->
+      ty
+*)
+  | _ ->
+    let desc = ty.desc in
+    For_copy.save_desc copy_scope ty desc;
+    let tm = row_of_type ty in
+    let has_fixed_row =
+      not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm in
+    (* Make a stub *)
+    let ty' = if s.for_saving then newpersty (Tvar None) else newgenvar () in
+    ty'.scope <- ty.scope;
+    ty.desc <- Tsubst ty';
+    ty'.desc <-
+      begin if has_fixed_row then
+        match tm.desc with (* PR#7348 *)
+          Tconstr (Pdot(m,i), tl, _abbrev) ->
+            let i' = String.sub i 0 (String.length i - 4) in
+            Tconstr(type_path s (Pdot(m,i')), tl, ref Mnil)
+        | _ -> assert false
+      else match desc with
+      | Tconstr (p, args, _abbrev) ->
+         let args = List.map (typexp copy_scope s) args in
+         begin match Path.Map.find p s.types with
+         | exception Not_found -> Tconstr(type_path s p, args, ref Mnil)
+         | Path _ -> Tconstr(type_path s p, args, ref Mnil)
+         | Type_function { params; body } ->
+            Tlink (!ctype_apply_env_empty params body args)
+         end
+      | Tpackage(p, n, tl) ->
+          Tpackage(modtype_path s p, n, List.map (typexp copy_scope s) tl)
+      | Tobject (t1, name) ->
+          let t1' = typexp copy_scope s t1 in
+          let name' =
+            match !name with
+            | None -> None
+            | Some (p, tl) ->
+                if to_subst_by_type_function s p
+                then None
+                else Some (type_path s p, List.map (typexp copy_scope s) tl)
+          in
+          Tobject (t1', ref name')
+      | Tvariant row ->
+          let row = row_repr row in
+          let more = repr row.row_more in
+          (* We must substitute in a subtle way *)
+          (* Tsubst takes a tuple containing the row var and the variant *)
+          begin match more.desc with
+            Tsubst {desc = Ttuple [_;ty2]} ->
+              (* This variant type has been already copied *)
+              ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *)
+              Tlink ty2
+          | _ ->
+              let dup =
+                s.for_saving || more.level = generic_level || static_row row ||
+                match more.desc with Tconstr _ -> true | _ -> false in
+              (* Various cases for the row variable *)
+              let more' =
+                match more.desc with
+                  Tsubst ty -> ty
+                | Tconstr _ | Tnil -> typexp copy_scope s more
+                | Tunivar _ | Tvar _ ->
+                    For_copy.save_desc copy_scope more more.desc;
+                    if s.for_saving then newpersty (norm more.desc) else
+                    if dup && is_Tvar more then newgenty more.desc else more
+                | _ -> assert false
+              in
+              (* Register new type first for recursion *)
+              more.desc <- Tsubst(newgenty(Ttuple[more';ty']));
+              (* Return a new copy *)
+              let row =
+                copy_row (typexp copy_scope s) true row (not dup) more' in
+              match row.row_name with
+              | Some (p, tl) ->
+                 Tvariant {row with row_name =
+                                      if to_subst_by_type_function s p
+                                      then None
+                                      else Some (type_path s p, tl)}
+              | None ->
+                  Tvariant row
+          end
+      | Tfield(_label, kind, _t1, t2) when field_kind_repr kind = Fabsent ->
+          Tlink (typexp copy_scope s t2)
+      | _ -> copy_type_desc (typexp copy_scope s) desc
+      end;
+    ty'
+
+(*
+   Always make a copy of the type. If this is not done, type levels
+   might not be correct.
+*)
+let type_expr s ty =
+  For_copy.with_scope (fun copy_scope -> typexp copy_scope s ty)
+
+let label_declaration copy_scope s l =
+  {
+    ld_id = l.ld_id;
+    ld_mutable = l.ld_mutable;
+    ld_type = typexp copy_scope s l.ld_type;
+    ld_loc = loc s l.ld_loc;
+    ld_attributes = attrs s l.ld_attributes;
+    ld_uid = l.ld_uid;
+  }
+
+let constructor_arguments copy_scope s = function
+  | Cstr_tuple l ->
+      Cstr_tuple (List.map (typexp copy_scope s) l)
+  | Cstr_record l ->
+      Cstr_record (List.map (label_declaration copy_scope s) l)
+
+let constructor_declaration copy_scope s c =
+  {
+    cd_id = c.cd_id;
+    cd_args = constructor_arguments copy_scope s c.cd_args;
+    cd_res = Option.map (typexp copy_scope s) c.cd_res;
+    cd_loc = loc s c.cd_loc;
+    cd_attributes = attrs s c.cd_attributes;
+    cd_uid = c.cd_uid;
+  }
+
+let type_declaration' copy_scope s decl =
+  { type_params = List.map (typexp copy_scope s) decl.type_params;
+    type_arity = decl.type_arity;
+    type_kind =
+      begin match decl.type_kind with
+        Type_abstract -> Type_abstract
+      | Type_variant cstrs ->
+          Type_variant (List.map (constructor_declaration copy_scope s) cstrs)
+      | Type_record(lbls, rep) ->
+          Type_record (List.map (label_declaration copy_scope s) lbls, rep)
+      | Type_open -> Type_open
+      end;
+    type_manifest =
+      begin
+        match decl.type_manifest with
+          None -> None
+        | Some ty -> Some(typexp copy_scope s ty)
+      end;
+    type_private = decl.type_private;
+    type_variance = decl.type_variance;
+    type_separability = decl.type_separability;
+    type_is_newtype = false;
+    type_expansion_scope = Btype.lowest_level;
+    type_loc = loc s decl.type_loc;
+    type_attributes = attrs s decl.type_attributes;
+    type_immediate = decl.type_immediate;
+    type_unboxed = decl.type_unboxed;
+    type_uid = decl.type_uid;
+  }
+
+let type_declaration s decl =
+  For_copy.with_scope (fun copy_scope -> type_declaration' copy_scope s decl)
+
+let class_signature copy_scope s sign =
+  { csig_self = typexp copy_scope s sign.csig_self;
+    csig_vars =
+      Vars.map
+        (function (m, v, t) -> (m, v, typexp copy_scope s t)) sign.csig_vars;
+    csig_concr = sign.csig_concr;
+    csig_inher =
+      List.map
+        (fun (p, tl) -> (type_path s p, List.map (typexp copy_scope s) tl))
+        sign.csig_inher;
+  }
+
+let rec class_type copy_scope s = function
+  | Cty_constr (p, tyl, cty) ->
+      let p' = type_path s p in
+      let tyl' = List.map (typexp copy_scope s) tyl in
+      let cty' = class_type copy_scope s cty in
+      Cty_constr (p', tyl', cty')
+  | Cty_signature sign ->
+      Cty_signature (class_signature copy_scope s sign)
+  | Cty_arrow (l, ty, cty) ->
+      Cty_arrow (l, typexp copy_scope s ty, class_type copy_scope s cty)
+
+let class_declaration' copy_scope s decl =
+  { cty_params = List.map (typexp copy_scope s) decl.cty_params;
+    cty_variance = decl.cty_variance;
+    cty_type = class_type copy_scope s decl.cty_type;
+    cty_path = type_path s decl.cty_path;
+    cty_new =
+      begin match decl.cty_new with
+      | None    -> None
+      | Some ty -> Some (typexp copy_scope s ty)
+      end;
+    cty_loc = loc s decl.cty_loc;
+    cty_attributes = attrs s decl.cty_attributes;
+    cty_uid = decl.cty_uid;
+  }
+
+let class_declaration s decl =
+  For_copy.with_scope (fun copy_scope -> class_declaration' copy_scope s decl)
+
+let cltype_declaration' copy_scope s decl =
+  { clty_params = List.map (typexp copy_scope s) decl.clty_params;
+    clty_variance = decl.clty_variance;
+    clty_type = class_type copy_scope s decl.clty_type;
+    clty_path = type_path s decl.clty_path;
+    clty_loc = loc s decl.clty_loc;
+    clty_attributes = attrs s decl.clty_attributes;
+    clty_uid = decl.clty_uid;
+  }
+
+let cltype_declaration s decl =
+  For_copy.with_scope (fun copy_scope -> cltype_declaration' copy_scope s decl)
+
+let class_type s cty =
+  For_copy.with_scope (fun copy_scope -> class_type copy_scope s cty)
+
+let value_description' copy_scope s descr =
+  { val_type = typexp copy_scope s descr.val_type;
+    val_kind = descr.val_kind;
+    val_loc = loc s descr.val_loc;
+    val_attributes = attrs s descr.val_attributes;
+    val_uid = descr.val_uid;
+   }
+
+let value_description s descr =
+  For_copy.with_scope (fun copy_scope -> value_description' copy_scope s descr)
+
+let extension_constructor' copy_scope s ext =
+  { ext_type_path = type_path s ext.ext_type_path;
+    ext_type_params = List.map (typexp copy_scope s) ext.ext_type_params;
+    ext_args = constructor_arguments copy_scope s ext.ext_args;
+    ext_ret_type = Option.map (typexp copy_scope s) ext.ext_ret_type;
+    ext_private = ext.ext_private;
+    ext_attributes = attrs s ext.ext_attributes;
+    ext_loc = if s.for_saving then Location.none else ext.ext_loc;
+    ext_uid = ext.ext_uid;
+  }
+
+let extension_constructor s ext =
+  For_copy.with_scope
+    (fun copy_scope -> extension_constructor' copy_scope s ext)
+
+type scoping =
+  | Keep
+  | Make_local
+  | Rescope of int
+
+let rename_bound_idents scoping s sg =
+  let rename =
+    let open Ident in
+    match scoping with
+    | Keep -> (fun id -> create_scoped ~scope:(scope id) (name id))
+    | Make_local -> Ident.rename
+    | Rescope scope -> (fun id -> create_scoped ~scope (name id))
+  in
+  let rec rename_bound_idents s sg = function
+    | [] -> sg, s
+    | Sig_type(id, td, rs, vis) :: rest ->
+        let id' = rename id in
+        rename_bound_idents
+          (add_type id (Pident id') s)
+          (Sig_type(id', td, rs, vis) :: sg)
+          rest
+    | Sig_module(id, pres, md, rs, vis) :: rest ->
+        let id' = rename id in
+        rename_bound_idents
+          (add_module id (Pident id') s)
+          (Sig_module (id', pres, md, rs, vis) :: sg)
+          rest
+    | Sig_modtype(id, mtd, vis) :: rest ->
+        let id' = rename id in
+        rename_bound_idents
+          (add_modtype id (Mty_ident(Pident id')) s)
+          (Sig_modtype(id', mtd, vis) :: sg)
+          rest
+    | Sig_class(id, cd, rs, vis) :: rest ->
+        (* cheat and pretend they are types cf. PR#6650 *)
+        let id' = rename id in
+        rename_bound_idents
+          (add_type id (Pident id') s)
+          (Sig_class(id', cd, rs, vis) :: sg)
+          rest
+    | Sig_class_type(id, ctd, rs, vis) :: rest ->
+        (* cheat and pretend they are types cf. PR#6650 *)
+        let id' = rename id in
+        rename_bound_idents
+          (add_type id (Pident id') s)
+          (Sig_class_type(id', ctd, rs, vis) :: sg)
+          rest
+    | Sig_value(id, vd, vis) :: rest ->
+        (* scope doesn't matter for value identifiers. *)
+        let id' = Ident.rename id in
+        rename_bound_idents s (Sig_value(id', vd, vis) :: sg) rest
+    | Sig_typext(id, ec, es, vis) :: rest ->
+        let id' = rename id in
+        rename_bound_idents s (Sig_typext(id',ec,es,vis) :: sg) rest
+  in
+  rename_bound_idents s [] sg
+
+let rec modtype scoping s = function
+    Mty_ident p as mty ->
+      begin match p with
+        Pident id ->
+          begin try Ident.Map.find id s.modtypes with Not_found -> mty end
+      | Pdot(p, n) ->
+          Mty_ident(Pdot(module_path s p, n))
+      | Papply _ ->
+          fatal_error "Subst.modtype"
+      end
+  | Mty_signature sg ->
+      Mty_signature(signature scoping s sg)
+  | Mty_functor(Unit, res) ->
+      Mty_functor(Unit, modtype scoping s res)
+  | Mty_functor(Named (None, arg), res) ->
+      Mty_functor(Named (None, (modtype scoping s) arg), modtype scoping s res)
+  | Mty_functor(Named (Some id, arg), res) ->
+      let id' = Ident.rename id in
+      Mty_functor(Named (Some id', (modtype scoping s) arg),
+                  modtype scoping (add_module id (Pident id') s) res)
+  | Mty_alias p ->
+      Mty_alias (module_path s p)
+
+and signature scoping s sg =
+  (* Components of signature may be mutually recursive (e.g. type declarations
+     or class and type declarations), so first build global renaming
+     substitution... *)
+  let (sg', s') = rename_bound_idents scoping s sg in
+  (* ... then apply it to each signature component in turn *)
+  For_copy.with_scope (fun copy_scope ->
+    List.rev_map (signature_item' copy_scope scoping s') sg'
+  )
+
+
+and signature_item' copy_scope scoping s comp =
+  match comp with
+    Sig_value(id, d, vis) ->
+      Sig_value(id, value_description' copy_scope s d, vis)
+  | Sig_type(id, d, rs, vis) ->
+      Sig_type(id, type_declaration' copy_scope s d, rs, vis)
+  | Sig_typext(id, ext, es, vis) ->
+      Sig_typext(id, extension_constructor' copy_scope s ext, es, vis)
+  | Sig_module(id, pres, d, rs, vis) ->
+      Sig_module(id, pres, module_declaration scoping s d, rs, vis)
+  | Sig_modtype(id, d, vis) ->
+      Sig_modtype(id, modtype_declaration scoping s d, vis)
+  | Sig_class(id, d, rs, vis) ->
+      Sig_class(id, class_declaration' copy_scope s d, rs, vis)
+  | Sig_class_type(id, d, rs, vis) ->
+      Sig_class_type(id, cltype_declaration' copy_scope s d, rs, vis)
+
+and signature_item scoping s comp =
+  For_copy.with_scope
+    (fun copy_scope -> signature_item' copy_scope scoping s comp)
+
+and module_declaration scoping s decl =
+  {
+    md_type = modtype scoping s decl.md_type;
+    md_attributes = attrs s decl.md_attributes;
+    md_loc = loc s decl.md_loc;
+    md_uid = decl.md_uid;
+  }
+
+and modtype_declaration scoping s decl  =
+  {
+    mtd_type = Option.map (modtype scoping s) decl.mtd_type;
+    mtd_attributes = attrs s decl.mtd_attributes;
+    mtd_loc = loc s decl.mtd_loc;
+    mtd_uid = decl.mtd_uid;
+  }
+
+
+(* For every binding k |-> d of m1, add k |-> f d to m2
+   and return resulting merged map. *)
+
+let merge_tbls f m1 m2 =
+  Ident.Map.fold (fun k d accu -> Ident.Map.add k (f d) accu) m1 m2
+
+let merge_path_maps f m1 m2 =
+  Path.Map.fold (fun k d accu -> Path.Map.add k (f d) accu) m1 m2
+
+let type_replacement s = function
+  | Path p -> Path (type_path s p)
+  | Type_function { params; body } ->
+    For_copy.with_scope (fun copy_scope ->
+     let params = List.map (typexp copy_scope s) params in
+     let body = typexp copy_scope s body in
+     Type_function { params; body })
+
+(* Composition of substitutions:
+     apply (compose s1 s2) x = apply s2 (apply s1 x) *)
+
+let compose s1 s2 =
+  { types = merge_path_maps (type_replacement s2) s1.types s2.types;
+    modules = merge_path_maps (module_path s2) s1.modules s2.modules;
+    modtypes = merge_tbls (modtype Keep s2) s1.modtypes s2.modtypes;
+    for_saving = s1.for_saving || s2.for_saving;
+  }
diff --git a/upstream/ocaml_412/typing/subst.mli b/upstream/ocaml_412/typing/subst.mli
new file mode 100644
index 0000000..67c0153
--- /dev/null
+++ b/upstream/ocaml_412/typing/subst.mli
@@ -0,0 +1,86 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Substitutions *)
+
+open Types
+
+type t
+
+(*
+   Substitutions are used to translate a type from one context to
+   another.  This requires substituting paths for identifiers, and
+   possibly also lowering the level of non-generic variables so that
+   they are inferior to the maximum level of the new context.
+
+   Substitutions can also be used to create a "clean" copy of a type.
+   Indeed, non-variable node of a type are duplicated, with their
+   levels set to generic level.  That way, the resulting type is
+   well-formed (decreasing levels), even if the original one was not.
+*)
+
+val identity: t
+
+val add_type: Ident.t -> Path.t -> t -> t
+val add_type_path: Path.t -> Path.t -> t -> t
+val add_type_function:
+  Path.t -> params:type_expr list -> body:type_expr -> t -> t
+val add_module: Ident.t -> Path.t -> t -> t
+val add_module_path: Path.t -> Path.t -> t -> t
+val add_modtype: Ident.t -> module_type -> t -> t
+val for_saving: t -> t
+val reset_for_saving: unit -> unit
+
+val module_path: t -> Path.t -> Path.t
+val type_path: t -> Path.t -> Path.t
+val modtype_path: t -> Path.t -> Path.t
+
+val type_expr: t -> type_expr -> type_expr
+val class_type: t -> class_type -> class_type
+val value_description: t -> value_description -> value_description
+val type_declaration: t -> type_declaration -> type_declaration
+val extension_constructor:
+        t -> extension_constructor -> extension_constructor
+val class_declaration: t -> class_declaration -> class_declaration
+val cltype_declaration: t -> class_type_declaration -> class_type_declaration
+
+(*
+   When applied to a signature item, a substitution not only modifies the types
+   present in its declaration, but also refreshes the identifier of the item.
+   Effectively this creates new declarations, and so one should decide what the
+   scope of this new declaration should be.
+
+   This is decided by the [scoping] argument passed to the following functions.
+*)
+
+type scoping =
+  | Keep
+  | Make_local
+  | Rescope of int
+
+val modtype: scoping -> t -> module_type -> module_type
+val signature: scoping -> t -> signature -> signature
+val signature_item: scoping -> t -> signature_item -> signature_item
+val modtype_declaration:
+  scoping -> t -> modtype_declaration -> modtype_declaration
+val module_declaration: scoping -> t -> module_declaration -> module_declaration
+
+(* Composition of substitutions:
+     apply (compose s1 s2) x = apply s2 (apply s1 x) *)
+val compose: t -> t -> t
+
+(* A forward reference to be filled in ctype.ml. *)
+val ctype_apply_env_empty:
+  (type_expr list -> type_expr -> type_expr list -> type_expr) ref
diff --git a/upstream/ocaml_412/typing/tast_iterator.ml b/upstream/ocaml_412/typing/tast_iterator.ml
new file mode 100644
index 0000000..db63fc0
--- /dev/null
+++ b/upstream/ocaml_412/typing/tast_iterator.ml
@@ -0,0 +1,510 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                          Isaac "Izzy" Avram                            *)
+(*                                                                        *)
+(*   Copyright 2019 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Typedtree
+
+type iterator =
+  {
+    binding_op: iterator -> binding_op -> unit;
+    case: 'k . iterator -> 'k case -> unit;
+    class_declaration: iterator -> class_declaration -> unit;
+    class_description: iterator -> class_description -> unit;
+    class_expr: iterator -> class_expr -> unit;
+    class_field: iterator -> class_field -> unit;
+    class_signature: iterator -> class_signature -> unit;
+    class_structure: iterator -> class_structure -> unit;
+    class_type: iterator -> class_type -> unit;
+    class_type_declaration: iterator -> class_type_declaration -> unit;
+    class_type_field: iterator -> class_type_field -> unit;
+    env: iterator -> Env.t -> unit;
+    expr: iterator -> expression -> unit;
+    extension_constructor: iterator -> extension_constructor -> unit;
+    module_binding: iterator -> module_binding -> unit;
+    module_coercion: iterator -> module_coercion -> unit;
+    module_declaration: iterator -> module_declaration -> unit;
+    module_substitution: iterator -> module_substitution -> unit;
+    module_expr: iterator -> module_expr -> unit;
+    module_type: iterator -> module_type -> unit;
+    module_type_declaration: iterator -> module_type_declaration -> unit;
+    package_type: iterator -> package_type -> unit;
+    pat: 'k . iterator -> 'k general_pattern -> unit;
+    row_field: iterator -> row_field -> unit;
+    object_field: iterator -> object_field -> unit;
+    open_declaration: iterator -> open_declaration -> unit;
+    open_description: iterator -> open_description -> unit;
+    signature: iterator -> signature -> unit;
+    signature_item: iterator -> signature_item -> unit;
+    structure: iterator -> structure -> unit;
+    structure_item: iterator -> structure_item -> unit;
+    typ: iterator -> core_type -> unit;
+    type_declaration: iterator -> type_declaration -> unit;
+    type_declarations: iterator -> (rec_flag * type_declaration list) -> unit;
+    type_extension: iterator -> type_extension -> unit;
+    type_exception: iterator -> type_exception -> unit;
+    type_kind: iterator -> type_kind -> unit;
+    value_binding: iterator -> value_binding -> unit;
+    value_bindings: iterator -> (rec_flag * value_binding list) -> unit;
+    value_description: iterator -> value_description -> unit;
+    with_constraint: iterator -> with_constraint -> unit;
+  }
+
+let structure sub {str_items; str_final_env; _} =
+  List.iter (sub.structure_item sub) str_items;
+  sub.env sub str_final_env
+
+let class_infos sub f x =
+  List.iter (fun (ct, _) -> sub.typ sub ct) x.ci_params;
+  f x.ci_expr
+
+let module_type_declaration sub {mtd_type; _} =
+  Option.iter (sub.module_type sub) mtd_type
+
+let module_declaration sub {md_type; _} =
+  sub.module_type sub md_type
+let module_substitution _ _ = ()
+
+let include_infos f {incl_mod; _} = f incl_mod
+
+let class_type_declaration sub x =
+  class_infos sub (sub.class_type sub) x
+
+let class_declaration sub x =
+  class_infos sub (sub.class_expr sub) x
+
+let structure_item sub {str_desc; str_env; _} =
+  sub.env sub str_env;
+  match str_desc with
+  | Tstr_eval   (exp, _) -> sub.expr sub exp
+  | Tstr_value  (rec_flag, list) -> sub.value_bindings sub (rec_flag, list)
+  | Tstr_primitive v -> sub.value_description sub v
+  | Tstr_type (rec_flag, list) -> sub.type_declarations sub (rec_flag, list)
+  | Tstr_typext te -> sub.type_extension sub te
+  | Tstr_exception ext -> sub.type_exception sub ext
+  | Tstr_module mb -> sub.module_binding sub mb
+  | Tstr_recmodule list -> List.iter (sub.module_binding sub) list
+  | Tstr_modtype x -> sub.module_type_declaration sub x
+  | Tstr_class list ->
+      List.iter (fun (cls,_) -> sub.class_declaration sub cls) list
+  | Tstr_class_type list ->
+      List.iter (fun (_, _, cltd) -> sub.class_type_declaration sub cltd) list
+  | Tstr_include incl -> include_infos (sub.module_expr sub) incl
+  | Tstr_open od -> sub.open_declaration sub od
+  | Tstr_attribute _ -> ()
+
+let value_description sub x = sub.typ sub x.val_desc
+
+let label_decl sub {ld_type; _} = sub.typ sub ld_type
+
+let constructor_args sub = function
+  | Cstr_tuple l -> List.iter (sub.typ sub) l
+  | Cstr_record l -> List.iter (label_decl sub) l
+
+let constructor_decl sub {cd_args; cd_res; _} =
+  constructor_args sub cd_args;
+  Option.iter (sub.typ sub) cd_res
+
+let type_kind sub = function
+  | Ttype_abstract -> ()
+  | Ttype_variant list -> List.iter (constructor_decl sub) list
+  | Ttype_record list -> List.iter (label_decl sub) list
+  | Ttype_open -> ()
+
+let type_declaration sub {typ_cstrs; typ_kind; typ_manifest; typ_params; _} =
+  List.iter
+    (fun (c1, c2, _) ->
+      sub.typ sub c1;
+      sub.typ sub c2)
+    typ_cstrs;
+  sub.type_kind sub typ_kind;
+  Option.iter (sub.typ sub) typ_manifest;
+  List.iter (fun (c, _) -> sub.typ sub c) typ_params
+
+let type_declarations sub (_, list) = List.iter (sub.type_declaration sub) list
+
+let type_extension sub {tyext_constructors; tyext_params; _} =
+  List.iter (fun (c, _) -> sub.typ sub c) tyext_params;
+  List.iter (sub.extension_constructor sub) tyext_constructors
+
+let type_exception sub {tyexn_constructor; _} =
+  sub.extension_constructor sub tyexn_constructor
+
+let extension_constructor sub {ext_kind; _} =
+  match ext_kind with
+  | Text_decl (ctl, cto) ->
+      constructor_args sub ctl;
+      Option.iter (sub.typ sub) cto
+  | Text_rebind _ -> ()
+
+let pat_extra sub (e, _loc, _attrs) = match e with
+  | Tpat_type _ -> ()
+  | Tpat_unpack -> ()
+  | Tpat_open (_, _, env) -> sub.env sub env
+  | Tpat_constraint ct -> sub.typ sub ct
+
+let pat
+  : type k . iterator -> k general_pattern -> unit
+  = fun sub {pat_extra = extra; pat_desc; pat_env; _} ->
+  sub.env sub pat_env;
+  List.iter (pat_extra sub) extra;
+  match pat_desc with
+  | Tpat_any  -> ()
+  | Tpat_var _ -> ()
+  | Tpat_constant _ -> ()
+  | Tpat_tuple l -> List.iter (sub.pat sub) l
+  | Tpat_construct (_, _, l) -> List.iter (sub.pat sub) l
+  | Tpat_variant (_, po, _) -> Option.iter (sub.pat sub) po
+  | Tpat_record (l, _) -> List.iter (fun (_, _, i) -> sub.pat sub i) l
+  | Tpat_array l -> List.iter (sub.pat sub) l
+  | Tpat_alias (p, _, _) -> sub.pat sub p
+  | Tpat_lazy p -> sub.pat sub p
+  | Tpat_value p -> sub.pat sub (p :> pattern)
+  | Tpat_exception p -> sub.pat sub p
+  | Tpat_or (p1, p2, _) ->
+      sub.pat sub p1;
+      sub.pat sub p2
+
+let expr sub {exp_extra; exp_desc; exp_env; _} =
+  let extra = function
+    | Texp_constraint cty -> sub.typ sub cty
+    | Texp_coerce (cty1, cty2) ->
+        Option.iter (sub.typ sub) cty1;
+        sub.typ sub cty2
+    | Texp_newtype _ -> ()
+    | Texp_poly cto -> Option.iter (sub.typ sub) cto
+  in
+  List.iter (fun (e, _, _) -> extra e) exp_extra;
+  sub.env sub exp_env;
+  match exp_desc with
+  | Texp_ident _  -> ()
+  | Texp_constant _ -> ()
+  | Texp_let (rec_flag, list, exp) ->
+      sub.value_bindings sub (rec_flag, list);
+      sub.expr sub exp
+  | Texp_function {cases; _} ->
+     List.iter (sub.case sub) cases
+  | Texp_apply (exp, list) ->
+      sub.expr sub exp;
+      List.iter (fun (_, o) -> Option.iter (sub.expr sub) o) list
+  | Texp_match (exp, cases, _) ->
+      sub.expr sub exp;
+      List.iter (sub.case sub) cases
+  | Texp_try (exp, cases) ->
+      sub.expr sub exp;
+      List.iter (sub.case sub) cases
+  | Texp_tuple list -> List.iter (sub.expr sub) list
+  | Texp_construct (_, _, args) -> List.iter (sub.expr sub) args
+  | Texp_variant (_, expo) -> Option.iter (sub.expr sub) expo
+  | Texp_record { fields; extended_expression; _} ->
+      Array.iter (function
+        | _, Kept _ -> ()
+        | _, Overridden (_, exp) -> sub.expr sub exp)
+        fields;
+      Option.iter (sub.expr sub) extended_expression;
+  | Texp_field (exp, _, _) -> sub.expr sub exp
+  | Texp_setfield (exp1, _, _, exp2) ->
+      sub.expr sub exp1;
+      sub.expr sub exp2
+  | Texp_array list -> List.iter (sub.expr sub) list
+  | Texp_ifthenelse (exp1, exp2, expo) ->
+      sub.expr sub exp1;
+      sub.expr sub exp2;
+      Option.iter (sub.expr sub) expo
+  | Texp_sequence (exp1, exp2) ->
+      sub.expr sub exp1;
+      sub.expr sub exp2
+  | Texp_while (exp1, exp2) ->
+      sub.expr sub exp1;
+      sub.expr sub exp2
+  | Texp_for (_, _, exp1, exp2, _, exp3) ->
+      sub.expr sub exp1;
+      sub.expr sub exp2;
+      sub.expr sub exp3
+  | Texp_send (exp, _, expo) ->
+      sub.expr sub exp;
+      Option.iter (sub.expr sub) expo
+  | Texp_new _ -> ()
+  | Texp_instvar _ -> ()
+  | Texp_setinstvar (_, _, _, exp) ->sub.expr sub exp
+  | Texp_override (_, list) ->
+      List.iter (fun (_, _, e) -> sub.expr sub e) list
+  | Texp_letmodule (_, _, _, mexpr, exp) ->
+      sub.module_expr sub mexpr;
+      sub.expr sub exp
+  | Texp_letexception (cd, exp) ->
+      sub.extension_constructor sub cd;
+      sub.expr sub exp
+  | Texp_assert exp -> sub.expr sub exp
+  | Texp_lazy exp -> sub.expr sub exp
+  | Texp_object (cl, _) -> sub.class_structure sub cl
+  | Texp_pack mexpr -> sub.module_expr sub mexpr
+  | Texp_letop {let_ = l; ands; body; _} ->
+      sub.binding_op sub l;
+      List.iter (sub.binding_op sub) ands;
+      sub.case sub body
+  | Texp_unreachable -> ()
+  | Texp_extension_constructor _ -> ()
+  | Texp_open (od, e) ->
+      sub.open_declaration sub od;
+      sub.expr sub e
+
+
+let package_type sub {pack_fields; _} =
+  List.iter (fun (_, p) -> sub.typ sub p) pack_fields
+
+let binding_op sub {bop_exp; _} = sub.expr sub bop_exp
+
+let signature sub {sig_items; sig_final_env; _} =
+  sub.env sub sig_final_env;
+  List.iter (sub.signature_item sub) sig_items
+
+let signature_item sub {sig_desc; sig_env; _} =
+  sub.env sub sig_env;
+  match sig_desc with
+  | Tsig_value v -> sub.value_description sub v
+  | Tsig_type (rf, tdl)  -> sub.type_declarations sub (rf, tdl)
+  | Tsig_typesubst list -> sub.type_declarations sub (Nonrecursive, list)
+  | Tsig_typext te -> sub.type_extension sub te
+  | Tsig_exception ext -> sub.type_exception sub ext
+  | Tsig_module x -> sub.module_declaration sub x
+  | Tsig_modsubst x -> sub.module_substitution sub x
+  | Tsig_recmodule list -> List.iter (sub.module_declaration sub) list
+  | Tsig_modtype x -> sub.module_type_declaration sub x
+  | Tsig_include incl -> include_infos (sub.module_type sub) incl
+  | Tsig_class list -> List.iter (sub.class_description sub) list
+  | Tsig_class_type list -> List.iter (sub.class_type_declaration sub) list
+  | Tsig_open od -> sub.open_description sub od
+  | Tsig_attribute _ -> ()
+
+let class_description sub x =
+  class_infos sub (sub.class_type sub) x
+
+let functor_parameter sub = function
+  | Unit -> ()
+  | Named (_, _, mtype) -> sub.module_type sub mtype
+
+let module_type sub {mty_desc; mty_env; _} =
+  sub.env sub mty_env;
+  match mty_desc with
+  | Tmty_ident _      -> ()
+  | Tmty_alias _      -> ()
+  | Tmty_signature sg -> sub.signature sub sg
+  | Tmty_functor (arg, mtype2) ->
+      functor_parameter sub arg;
+      sub.module_type sub mtype2
+  | Tmty_with (mtype, list) ->
+      sub.module_type sub mtype;
+      List.iter (fun (_, _, e) -> sub.with_constraint sub e) list
+  | Tmty_typeof mexpr -> sub.module_expr sub mexpr
+
+let with_constraint sub = function
+  | Twith_type      decl -> sub.type_declaration sub decl
+  | Twith_typesubst decl -> sub.type_declaration sub decl
+  | Twith_module    _    -> ()
+  | Twith_modsubst  _    -> ()
+
+let open_description sub {open_env; _} = sub.env sub open_env
+
+let open_declaration sub {open_expr; open_env; _} =
+  sub.module_expr sub open_expr;
+  sub.env sub open_env
+
+let module_coercion sub = function
+  | Tcoerce_none -> ()
+  | Tcoerce_functor (c1,c2) ->
+      sub.module_coercion sub c1;
+      sub.module_coercion sub c2
+  | Tcoerce_alias (env, _, c1) ->
+      sub.env sub env;
+      sub.module_coercion sub c1
+  | Tcoerce_structure (l1, l2) ->
+      List.iter (fun (_, c) -> sub.module_coercion sub c) l1;
+      List.iter (fun (_, _ ,c) -> sub.module_coercion sub c) l2
+  | Tcoerce_primitive {pc_env; _} -> sub.env sub pc_env
+
+let module_expr sub {mod_desc; mod_env; _} =
+  sub.env sub mod_env;
+  match mod_desc with
+  | Tmod_ident _      -> ()
+  | Tmod_structure st -> sub.structure sub st
+  | Tmod_functor (arg, mexpr) ->
+      functor_parameter sub arg;
+      sub.module_expr sub mexpr
+  | Tmod_apply (mexp1, mexp2, c) ->
+      sub.module_expr sub mexp1;
+      sub.module_expr sub mexp2;
+      sub.module_coercion sub c
+  | Tmod_constraint (mexpr, _, Tmodtype_implicit, c) ->
+      sub.module_expr sub mexpr;
+      sub.module_coercion sub c
+  | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, c) ->
+      sub.module_expr sub mexpr;
+      sub.module_type sub mtype;
+      sub.module_coercion sub c
+  | Tmod_unpack (exp, _) -> sub.expr sub exp
+
+let module_binding sub {mb_expr; _} = sub.module_expr sub mb_expr
+
+let class_expr sub {cl_desc; cl_env; _} =
+  sub.env sub cl_env;
+  match cl_desc with
+  | Tcl_constraint (cl, clty, _, _, _) ->
+      sub.class_expr sub cl;
+      Option.iter (sub.class_type sub) clty
+  | Tcl_structure clstr -> sub.class_structure sub clstr
+  | Tcl_fun (_, pat, priv, cl, _) ->
+      sub.pat sub pat;
+      List.iter (fun (_, e) -> sub.expr sub e) priv;
+      sub.class_expr sub cl
+  | Tcl_apply (cl, args) ->
+      sub.class_expr sub cl;
+      List.iter (fun (_, e) -> Option.iter (sub.expr sub) e) args
+  | Tcl_let (rec_flag, value_bindings, ivars, cl) ->
+      sub.value_bindings sub (rec_flag, value_bindings);
+      List.iter (fun (_, e) -> sub.expr sub e) ivars;
+      sub.class_expr sub cl
+  | Tcl_ident (_, _, tyl) -> List.iter (sub.typ sub) tyl
+  | Tcl_open (od, e) ->
+      sub.open_description sub od;
+      sub.class_expr sub e
+
+let class_type sub {cltyp_desc; cltyp_env; _} =
+  sub.env sub cltyp_env;
+  match cltyp_desc with
+  | Tcty_signature csg -> sub.class_signature sub csg
+  | Tcty_constr (_, _, list) -> List.iter (sub.typ sub) list
+  | Tcty_arrow (_, ct, cl) ->
+      sub.typ sub ct;
+      sub.class_type sub cl
+  | Tcty_open (od, e) ->
+      sub.open_description sub od;
+      sub.class_type sub e
+
+let class_signature sub {csig_self; csig_fields; _} =
+  sub.typ sub csig_self;
+  List.iter (sub.class_type_field sub) csig_fields
+
+let class_type_field sub {ctf_desc; _} =
+  match ctf_desc with
+  | Tctf_inherit ct -> sub.class_type sub ct
+  | Tctf_val (_, _, _, ct) ->  sub.typ sub ct
+  | Tctf_method (_, _, _, ct) -> sub.typ sub ct
+  | Tctf_constraint  (ct1, ct2) ->
+      sub.typ sub ct1;
+      sub.typ sub ct2
+  | Tctf_attribute _ -> ()
+
+let typ sub {ctyp_desc; ctyp_env; _} =
+  sub.env sub ctyp_env;
+  match ctyp_desc with
+  | Ttyp_any   -> ()
+  | Ttyp_var _ -> ()
+  | Ttyp_arrow (_, ct1, ct2) ->
+      sub.typ sub ct1;
+      sub.typ sub ct2
+  | Ttyp_tuple list -> List.iter (sub.typ sub) list
+  | Ttyp_constr (_, _, list) ->  List.iter (sub.typ sub) list
+  | Ttyp_object (list, _) -> List.iter (sub.object_field sub) list
+  | Ttyp_class (_, _, list) -> List.iter (sub.typ sub) list
+  | Ttyp_alias (ct, _) -> sub.typ sub ct
+  | Ttyp_variant (list, _, _) -> List.iter (sub.row_field sub) list
+  | Ttyp_poly (_, ct) -> sub.typ sub ct
+  | Ttyp_package pack -> sub.package_type sub pack
+
+let class_structure sub {cstr_self; cstr_fields; _} =
+  sub.pat sub cstr_self;
+  List.iter (sub.class_field sub) cstr_fields
+
+let row_field sub {rf_desc; _} =
+  match rf_desc with
+  | Ttag (_, _, list) -> List.iter (sub.typ sub) list
+  | Tinherit ct -> sub.typ sub ct
+
+let object_field sub {of_desc; _} =
+  match of_desc with
+  | OTtag (_, ct) -> sub.typ sub ct
+  | OTinherit ct -> sub.typ sub ct
+
+let class_field_kind sub = function
+  | Tcfk_virtual ct -> sub.typ sub ct
+  | Tcfk_concrete (_, e) -> sub.expr sub e
+
+let class_field sub {cf_desc; _} = match cf_desc with
+  | Tcf_inherit (_, cl, _, _, _) -> sub.class_expr sub cl
+  | Tcf_constraint (cty1, cty2) ->
+      sub.typ sub cty1;
+      sub.typ sub cty2
+  | Tcf_val (_, _, _, k, _) -> class_field_kind sub k
+  | Tcf_method (_, _, k) -> class_field_kind sub k
+  | Tcf_initializer exp -> sub.expr sub exp
+  | Tcf_attribute _ -> ()
+
+let value_bindings sub (_, list) = List.iter (sub.value_binding sub) list
+
+let case sub {c_lhs; c_guard; c_rhs} =
+  sub.pat sub c_lhs;
+  Option.iter (sub.expr sub) c_guard;
+  sub.expr sub c_rhs
+
+let value_binding sub {vb_pat; vb_expr; _} =
+  sub.pat sub vb_pat;
+  sub.expr sub vb_expr
+
+let env _sub _ = ()
+
+let default_iterator =
+  {
+    binding_op;
+    case;
+    class_declaration;
+    class_description;
+    class_expr;
+    class_field;
+    class_signature;
+    class_structure;
+    class_type;
+    class_type_declaration;
+    class_type_field;
+    env;
+    expr;
+    extension_constructor;
+    module_binding;
+    module_coercion;
+    module_declaration;
+    module_substitution;
+    module_expr;
+    module_type;
+    module_type_declaration;
+    package_type;
+    pat;
+    row_field;
+    object_field;
+    open_declaration;
+    open_description;
+    signature;
+    signature_item;
+    structure;
+    structure_item;
+    typ;
+    type_declaration;
+    type_declarations;
+    type_extension;
+    type_exception;
+    type_kind;
+    value_binding;
+    value_bindings;
+    value_description;
+    with_constraint;
+  }
diff --git a/upstream/ocaml_412/typing/tast_iterator.mli b/upstream/ocaml_412/typing/tast_iterator.mli
new file mode 100644
index 0000000..e126128
--- /dev/null
+++ b/upstream/ocaml_412/typing/tast_iterator.mli
@@ -0,0 +1,68 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                           Isaac "Izzy" Avram                           *)
+(*                                                                        *)
+(*   Copyright 2019 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(**
+Allows the implementation of typed tree inspection using open recursion
+*)
+
+open Asttypes
+open Typedtree
+
+type iterator =
+  {
+    binding_op: iterator -> binding_op -> unit;
+    case: 'k . iterator -> 'k case -> unit;
+    class_declaration: iterator -> class_declaration -> unit;
+    class_description: iterator -> class_description -> unit;
+    class_expr: iterator -> class_expr -> unit;
+    class_field: iterator -> class_field -> unit;
+    class_signature: iterator -> class_signature -> unit;
+    class_structure: iterator -> class_structure -> unit;
+    class_type: iterator -> class_type -> unit;
+    class_type_declaration: iterator -> class_type_declaration -> unit;
+    class_type_field: iterator -> class_type_field -> unit;
+    env: iterator -> Env.t -> unit;
+    expr: iterator -> expression -> unit;
+    extension_constructor: iterator -> extension_constructor -> unit;
+    module_binding: iterator -> module_binding -> unit;
+    module_coercion: iterator -> module_coercion -> unit;
+    module_declaration: iterator -> module_declaration -> unit;
+    module_substitution: iterator -> module_substitution -> unit;
+    module_expr: iterator -> module_expr -> unit;
+    module_type: iterator -> module_type -> unit;
+    module_type_declaration: iterator -> module_type_declaration -> unit;
+    package_type: iterator -> package_type -> unit;
+    pat: 'k . iterator -> 'k general_pattern -> unit;
+    row_field: iterator -> row_field -> unit;
+    object_field: iterator -> object_field -> unit;
+    open_declaration: iterator -> open_declaration -> unit;
+    open_description: iterator -> open_description -> unit;
+    signature: iterator -> signature -> unit;
+    signature_item: iterator -> signature_item -> unit;
+    structure: iterator -> structure -> unit;
+    structure_item: iterator -> structure_item -> unit;
+    typ: iterator -> core_type -> unit;
+    type_declaration: iterator -> type_declaration -> unit;
+    type_declarations: iterator -> (rec_flag * type_declaration list) -> unit;
+    type_extension: iterator -> type_extension -> unit;
+    type_exception: iterator -> type_exception -> unit;
+    type_kind: iterator -> type_kind -> unit;
+    value_binding: iterator -> value_binding -> unit;
+    value_bindings: iterator -> (rec_flag * value_binding list) -> unit;
+    value_description: iterator -> value_description -> unit;
+    with_constraint: iterator -> with_constraint -> unit;
+  }
+
+val default_iterator: iterator
diff --git a/upstream/ocaml_412/typing/tast_mapper.ml b/upstream/ocaml_412/typing/tast_mapper.ml
new file mode 100644
index 0000000..d8ceee1
--- /dev/null
+++ b/upstream/ocaml_412/typing/tast_mapper.ml
@@ -0,0 +1,744 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                        Alain Frisch, LexiFi                            *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Typedtree
+
+(* TODO: add 'methods' for location, attribute, extension,
+   include_declaration, include_description *)
+
+type mapper =
+  {
+    binding_op: mapper -> binding_op -> binding_op;
+    case: 'k . mapper -> 'k case -> 'k case;
+    class_declaration: mapper -> class_declaration -> class_declaration;
+    class_description: mapper -> class_description -> class_description;
+    class_expr: mapper -> class_expr -> class_expr;
+    class_field: mapper -> class_field -> class_field;
+    class_signature: mapper -> class_signature -> class_signature;
+    class_structure: mapper -> class_structure -> class_structure;
+    class_type: mapper -> class_type -> class_type;
+    class_type_declaration: mapper -> class_type_declaration ->
+      class_type_declaration;
+    class_type_field: mapper -> class_type_field -> class_type_field;
+    env: mapper -> Env.t -> Env.t;
+    expr: mapper -> expression -> expression;
+    extension_constructor: mapper -> extension_constructor ->
+      extension_constructor;
+    module_binding: mapper -> module_binding -> module_binding;
+    module_coercion: mapper -> module_coercion -> module_coercion;
+    module_declaration: mapper -> module_declaration -> module_declaration;
+    module_substitution: mapper -> module_substitution -> module_substitution;
+    module_expr: mapper -> module_expr -> module_expr;
+    module_type: mapper -> module_type -> module_type;
+    module_type_declaration:
+      mapper -> module_type_declaration -> module_type_declaration;
+    package_type: mapper -> package_type -> package_type;
+    pat: 'k . mapper -> 'k general_pattern -> 'k general_pattern;
+    row_field: mapper -> row_field -> row_field;
+    object_field: mapper -> object_field -> object_field;
+    open_declaration: mapper -> open_declaration -> open_declaration;
+    open_description: mapper -> open_description -> open_description;
+    signature: mapper -> signature -> signature;
+    signature_item: mapper -> signature_item -> signature_item;
+    structure: mapper -> structure -> structure;
+    structure_item: mapper -> structure_item -> structure_item;
+    typ: mapper -> core_type -> core_type;
+    type_declaration: mapper -> type_declaration -> type_declaration;
+    type_declarations: mapper -> (rec_flag * type_declaration list)
+      -> (rec_flag * type_declaration list);
+    type_extension: mapper -> type_extension -> type_extension;
+    type_exception: mapper -> type_exception -> type_exception;
+    type_kind: mapper -> type_kind -> type_kind;
+    value_binding: mapper -> value_binding -> value_binding;
+    value_bindings: mapper -> (rec_flag * value_binding list) ->
+      (rec_flag * value_binding list);
+    value_description: mapper -> value_description -> value_description;
+    with_constraint: mapper -> with_constraint -> with_constraint;
+  }
+
+let id x = x
+let tuple2 f1 f2 (x, y) = (f1 x, f2 y)
+let tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
+
+let structure sub {str_items; str_type; str_final_env} =
+  {
+    str_items = List.map (sub.structure_item sub) str_items;
+    str_final_env = sub.env sub str_final_env;
+    str_type;
+  }
+
+let class_infos sub f x =
+  {x with
+   ci_params = List.map (tuple2 (sub.typ sub) id) x.ci_params;
+   ci_expr = f x.ci_expr;
+  }
+
+let module_type_declaration sub x =
+  let mtd_type = Option.map (sub.module_type sub) x.mtd_type in
+  {x with mtd_type}
+
+let module_declaration sub x =
+  let md_type = sub.module_type sub x.md_type in
+  {x with md_type}
+
+let module_substitution _ x = x
+
+let include_infos f x = {x with incl_mod = f x.incl_mod}
+
+let class_type_declaration sub x =
+  class_infos sub (sub.class_type sub) x
+
+let class_declaration sub x =
+  class_infos sub (sub.class_expr sub) x
+
+let structure_item sub {str_desc; str_loc; str_env} =
+  let str_env = sub.env sub str_env in
+  let str_desc =
+    match str_desc with
+    | Tstr_eval (exp, attrs) -> Tstr_eval (sub.expr sub exp, attrs)
+    | Tstr_value (rec_flag, list) ->
+        let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in
+        Tstr_value (rec_flag, list)
+    | Tstr_primitive v -> Tstr_primitive (sub.value_description sub v)
+    | Tstr_type (rec_flag, list) ->
+        let (rec_flag, list) = sub.type_declarations sub (rec_flag, list) in
+        Tstr_type (rec_flag, list)
+    | Tstr_typext te -> Tstr_typext (sub.type_extension sub te)
+    | Tstr_exception ext -> Tstr_exception (sub.type_exception sub ext)
+    | Tstr_module mb -> Tstr_module (sub.module_binding sub mb)
+    | Tstr_recmodule list ->
+        Tstr_recmodule (List.map (sub.module_binding sub) list)
+    | Tstr_modtype x -> Tstr_modtype (sub.module_type_declaration sub x)
+    | Tstr_class list ->
+        Tstr_class
+          (List.map (tuple2 (sub.class_declaration sub) id) list)
+    | Tstr_class_type list ->
+        Tstr_class_type
+          (List.map (tuple3 id id (sub.class_type_declaration sub)) list)
+    | Tstr_include incl ->
+        Tstr_include (include_infos (sub.module_expr sub) incl)
+    | Tstr_open od -> Tstr_open (sub.open_declaration sub od)
+    | Tstr_attribute _ as d -> d
+  in
+  {str_desc; str_env; str_loc}
+
+let value_description sub x =
+  let val_desc = sub.typ sub x.val_desc in
+  {x with val_desc}
+
+let label_decl sub x =
+  let ld_type = sub.typ sub x.ld_type in
+  {x with ld_type}
+
+let constructor_args sub = function
+  | Cstr_tuple l -> Cstr_tuple (List.map (sub.typ sub) l)
+  | Cstr_record l -> Cstr_record (List.map (label_decl sub) l)
+
+let constructor_decl sub cd =
+  let cd_args = constructor_args sub cd.cd_args in
+  let cd_res = Option.map (sub.typ sub) cd.cd_res in
+  {cd with cd_args; cd_res}
+
+let type_kind sub = function
+  | Ttype_abstract -> Ttype_abstract
+  | Ttype_variant list -> Ttype_variant (List.map (constructor_decl sub) list)
+  | Ttype_record list -> Ttype_record (List.map (label_decl sub) list)
+  | Ttype_open -> Ttype_open
+
+let type_declaration sub x =
+  let typ_cstrs =
+    List.map
+      (tuple3 (sub.typ sub) (sub.typ sub) id)
+      x.typ_cstrs
+  in
+  let typ_kind = sub.type_kind sub x.typ_kind in
+  let typ_manifest = Option.map (sub.typ sub) x.typ_manifest in
+  let typ_params = List.map (tuple2 (sub.typ sub) id) x.typ_params in
+  {x with typ_cstrs; typ_kind; typ_manifest; typ_params}
+
+let type_declarations sub (rec_flag, list) =
+  (rec_flag, List.map (sub.type_declaration sub) list)
+
+let type_extension sub x =
+  let tyext_params = List.map (tuple2 (sub.typ sub) id) x.tyext_params in
+  let tyext_constructors =
+    List.map (sub.extension_constructor sub) x.tyext_constructors
+  in
+  {x with tyext_constructors; tyext_params}
+
+let type_exception sub x =
+  let tyexn_constructor =
+    sub.extension_constructor sub x.tyexn_constructor
+  in
+  {x with tyexn_constructor}
+
+let extension_constructor sub x =
+  let ext_kind =
+    match x.ext_kind with
+      Text_decl(ctl, cto) ->
+        Text_decl(constructor_args sub ctl, Option.map (sub.typ sub) cto)
+    | Text_rebind _ as d -> d
+  in
+  {x with ext_kind}
+
+let pat_extra sub = function
+  | Tpat_type _
+  | Tpat_unpack as d -> d
+  | Tpat_open (path,loc,env) ->  Tpat_open (path, loc, sub.env sub env)
+  | Tpat_constraint ct -> Tpat_constraint (sub.typ sub ct)
+
+let pat
+  : type k . mapper -> k general_pattern -> k general_pattern
+  = fun sub x ->
+  let pat_env = sub.env sub x.pat_env in
+  let pat_extra = List.map (tuple3 (pat_extra sub) id id) x.pat_extra in
+  let pat_desc : k pattern_desc =
+    match x.pat_desc with
+    | Tpat_any
+    | Tpat_var _
+    | Tpat_constant _ -> x.pat_desc
+    | Tpat_tuple l -> Tpat_tuple (List.map (sub.pat sub) l)
+    | Tpat_construct (loc, cd, l) ->
+        Tpat_construct (loc, cd, List.map (sub.pat sub) l)
+    | Tpat_variant (l, po, rd) ->
+        Tpat_variant (l, Option.map (sub.pat sub) po, rd)
+    | Tpat_record (l, closed) ->
+        Tpat_record (List.map (tuple3 id id (sub.pat sub)) l, closed)
+    | Tpat_array l -> Tpat_array (List.map (sub.pat sub) l)
+    | Tpat_alias (p, id, s) -> Tpat_alias (sub.pat sub p, id, s)
+    | Tpat_lazy p -> Tpat_lazy (sub.pat sub p)
+    | Tpat_value p ->
+       (as_computation_pattern (sub.pat sub (p :> pattern))).pat_desc
+    | Tpat_exception p ->
+       Tpat_exception (sub.pat sub p)
+    | Tpat_or (p1, p2, rd) ->
+        Tpat_or (sub.pat sub p1, sub.pat sub p2, rd)
+  in
+  {x with pat_extra; pat_desc; pat_env}
+
+let expr sub x =
+  let extra = function
+    | Texp_constraint cty ->
+        Texp_constraint (sub.typ sub cty)
+    | Texp_coerce (cty1, cty2) ->
+        Texp_coerce (Option.map (sub.typ sub) cty1, sub.typ sub cty2)
+    | Texp_newtype _ as d -> d
+    | Texp_poly cto -> Texp_poly (Option.map (sub.typ sub) cto)
+  in
+  let exp_extra = List.map (tuple3 extra id id) x.exp_extra in
+  let exp_env = sub.env sub x.exp_env in
+  let exp_desc =
+    match x.exp_desc with
+    | Texp_ident _
+    | Texp_constant _ as d -> d
+    | Texp_let (rec_flag, list, exp) ->
+        let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in
+        Texp_let (rec_flag, list, sub.expr sub exp)
+    | Texp_function { arg_label; param; cases; partial; } ->
+        let cases = List.map (sub.case sub) cases in
+        Texp_function { arg_label; param; cases; partial; }
+    | Texp_apply (exp, list) ->
+        Texp_apply (
+          sub.expr sub exp,
+          List.map (tuple2 id (Option.map (sub.expr sub))) list
+        )
+    | Texp_match (exp, cases, p) ->
+        Texp_match (
+          sub.expr sub exp,
+          List.map (sub.case sub) cases,
+          p
+        )
+    | Texp_try (exp, cases) ->
+        Texp_try (
+          sub.expr sub exp,
+          List.map (sub.case sub) cases
+        )
+    | Texp_tuple list ->
+        Texp_tuple (List.map (sub.expr sub) list)
+    | Texp_construct (lid, cd, args) ->
+        Texp_construct (lid, cd, List.map (sub.expr sub) args)
+    | Texp_variant (l, expo) ->
+        Texp_variant (l, Option.map (sub.expr sub) expo)
+    | Texp_record { fields; representation; extended_expression } ->
+        let fields = Array.map (function
+            | label, Kept t -> label, Kept t
+            | label, Overridden (lid, exp) ->
+                label, Overridden (lid, sub.expr sub exp))
+            fields
+        in
+        Texp_record {
+          fields; representation;
+          extended_expression = Option.map (sub.expr sub) extended_expression;
+        }
+    | Texp_field (exp, lid, ld) ->
+        Texp_field (sub.expr sub exp, lid, ld)
+    | Texp_setfield (exp1, lid, ld, exp2) ->
+        Texp_setfield (
+          sub.expr sub exp1,
+          lid,
+          ld,
+          sub.expr sub exp2
+        )
+    | Texp_array list ->
+        Texp_array (List.map (sub.expr sub) list)
+    | Texp_ifthenelse (exp1, exp2, expo) ->
+        Texp_ifthenelse (
+          sub.expr sub exp1,
+          sub.expr sub exp2,
+          Option.map (sub.expr sub) expo
+        )
+    | Texp_sequence (exp1, exp2) ->
+        Texp_sequence (
+          sub.expr sub exp1,
+          sub.expr sub exp2
+        )
+    | Texp_while (exp1, exp2) ->
+        Texp_while (
+          sub.expr sub exp1,
+          sub.expr sub exp2
+        )
+    | Texp_for (id, p, exp1, exp2, dir, exp3) ->
+        Texp_for (
+          id,
+          p,
+          sub.expr sub exp1,
+          sub.expr sub exp2,
+          dir,
+          sub.expr sub exp3
+        )
+    | Texp_send (exp, meth, expo) ->
+        Texp_send
+          (
+            sub.expr sub exp,
+            meth,
+            Option.map (sub.expr sub) expo
+          )
+    | Texp_new _
+    | Texp_instvar _ as d -> d
+    | Texp_setinstvar (path1, path2, id, exp) ->
+        Texp_setinstvar (
+          path1,
+          path2,
+          id,
+          sub.expr sub exp
+        )
+    | Texp_override (path, list) ->
+        Texp_override (
+          path,
+          List.map (tuple3 id id (sub.expr sub)) list
+        )
+    | Texp_letmodule (id, s, pres, mexpr, exp) ->
+        Texp_letmodule (
+          id,
+          s,
+          pres,
+          sub.module_expr sub mexpr,
+          sub.expr sub exp
+        )
+    | Texp_letexception (cd, exp) ->
+        Texp_letexception (
+          sub.extension_constructor sub cd,
+          sub.expr sub exp
+        )
+    | Texp_assert exp ->
+        Texp_assert (sub.expr sub exp)
+    | Texp_lazy exp ->
+        Texp_lazy (sub.expr sub exp)
+    | Texp_object (cl, sl) ->
+        Texp_object (sub.class_structure sub cl, sl)
+    | Texp_pack mexpr ->
+        Texp_pack (sub.module_expr sub mexpr)
+    | Texp_letop {let_; ands; param; body; partial} ->
+        Texp_letop{
+          let_ = sub.binding_op sub let_;
+          ands = List.map (sub.binding_op sub) ands;
+          param;
+          body = sub.case sub body;
+          partial;
+        }
+    | Texp_unreachable ->
+        Texp_unreachable
+    | Texp_extension_constructor _ as e ->
+        e
+    | Texp_open (od, e) ->
+        Texp_open (sub.open_declaration sub od, sub.expr sub e)
+  in
+  {x with exp_extra; exp_desc; exp_env}
+
+
+let package_type sub x =
+  let pack_fields = List.map (tuple2 id (sub.typ sub)) x.pack_fields in
+  {x with pack_fields}
+
+let binding_op sub x =
+  { x with bop_exp = sub.expr sub x.bop_exp }
+
+let signature sub x =
+  let sig_final_env = sub.env sub x.sig_final_env in
+  let sig_items = List.map (sub.signature_item sub) x.sig_items in
+  {x with sig_items; sig_final_env}
+
+let signature_item sub x =
+  let sig_env = sub.env sub x.sig_env in
+  let sig_desc =
+    match x.sig_desc with
+    | Tsig_value v ->
+        Tsig_value (sub.value_description sub v)
+    | Tsig_type (rec_flag, list) ->
+        let (rec_flag, list) = sub.type_declarations sub (rec_flag, list) in
+        Tsig_type (rec_flag, list)
+    | Tsig_typesubst list ->
+        let (_, list) = sub.type_declarations sub (Nonrecursive, list) in
+        Tsig_typesubst list
+    | Tsig_typext te ->
+        Tsig_typext (sub.type_extension sub te)
+    | Tsig_exception ext ->
+        Tsig_exception (sub.type_exception sub ext)
+    | Tsig_module x ->
+        Tsig_module (sub.module_declaration sub x)
+    | Tsig_modsubst x ->
+        Tsig_modsubst (sub.module_substitution sub x)
+    | Tsig_recmodule list ->
+        Tsig_recmodule (List.map (sub.module_declaration sub) list)
+    | Tsig_modtype x ->
+        Tsig_modtype (sub.module_type_declaration sub x)
+    | Tsig_include incl ->
+        Tsig_include (include_infos (sub.module_type sub) incl)
+    | Tsig_class list ->
+        Tsig_class (List.map (sub.class_description sub) list)
+    | Tsig_class_type list ->
+        Tsig_class_type
+          (List.map (sub.class_type_declaration sub) list)
+    | Tsig_open od -> Tsig_open (sub.open_description sub od)
+    | Tsig_attribute _ as d -> d
+  in
+  {x with sig_desc; sig_env}
+
+let class_description sub x =
+  class_infos sub (sub.class_type sub) x
+
+let functor_parameter sub = function
+  | Unit -> Unit
+  | Named (id, s, mtype) -> Named (id, s, sub.module_type sub mtype)
+
+let module_type sub x =
+  let mty_env = sub.env sub x.mty_env in
+  let mty_desc =
+    match x.mty_desc with
+    | Tmty_ident _
+    | Tmty_alias _ as d -> d
+    | Tmty_signature sg -> Tmty_signature (sub.signature sub sg)
+    | Tmty_functor (arg, mtype2) ->
+        Tmty_functor (functor_parameter sub arg, sub.module_type sub mtype2)
+    | Tmty_with (mtype, list) ->
+        Tmty_with (
+          sub.module_type sub mtype,
+          List.map (tuple3 id id (sub.with_constraint sub)) list
+        )
+    | Tmty_typeof mexpr ->
+        Tmty_typeof (sub.module_expr sub mexpr)
+  in
+  {x with mty_desc; mty_env}
+
+let with_constraint sub = function
+  | Twith_type decl -> Twith_type (sub.type_declaration sub decl)
+  | Twith_typesubst decl -> Twith_typesubst (sub.type_declaration sub decl)
+  | Twith_module _
+  | Twith_modsubst _ as d -> d
+
+let open_description sub od =
+  {od with open_env = sub.env sub od.open_env}
+
+let open_declaration sub od =
+  {od with open_expr = sub.module_expr sub od.open_expr;
+           open_env = sub.env sub od.open_env}
+
+let module_coercion sub = function
+  | Tcoerce_none -> Tcoerce_none
+  | Tcoerce_functor (c1,c2) ->
+      Tcoerce_functor (sub.module_coercion sub c1, sub.module_coercion sub c2)
+  | Tcoerce_alias (env, p, c1) ->
+      Tcoerce_alias (sub.env sub env, p, sub.module_coercion sub c1)
+  | Tcoerce_structure (l1, l2) ->
+      let l1' = List.map (fun (i,c) -> i, sub.module_coercion sub c) l1 in
+      let l2' =
+        List.map (fun (id,i,c) -> id, i, sub.module_coercion sub c) l2
+      in
+      Tcoerce_structure (l1', l2')
+  | Tcoerce_primitive pc ->
+      Tcoerce_primitive {pc with pc_env = sub.env sub pc.pc_env}
+
+let module_expr sub x =
+  let mod_env = sub.env sub x.mod_env in
+  let mod_desc =
+    match x.mod_desc with
+    | Tmod_ident _ as d -> d
+    | Tmod_structure st -> Tmod_structure (sub.structure sub st)
+    | Tmod_functor (arg, mexpr) ->
+        Tmod_functor (functor_parameter sub arg, sub.module_expr sub mexpr)
+    | Tmod_apply (mexp1, mexp2, c) ->
+        Tmod_apply (
+          sub.module_expr sub mexp1,
+          sub.module_expr sub mexp2,
+          sub.module_coercion sub c
+        )
+    | Tmod_constraint (mexpr, mt, Tmodtype_implicit, c) ->
+        Tmod_constraint (sub.module_expr sub mexpr, mt, Tmodtype_implicit,
+                         sub.module_coercion sub c)
+    | Tmod_constraint (mexpr, mt, Tmodtype_explicit mtype, c) ->
+        Tmod_constraint (
+          sub.module_expr sub mexpr,
+          mt,
+          Tmodtype_explicit (sub.module_type sub mtype),
+          sub.module_coercion sub c
+        )
+    | Tmod_unpack (exp, mty) ->
+        Tmod_unpack
+          (
+            sub.expr sub exp,
+            mty
+          )
+  in
+  {x with mod_desc; mod_env}
+
+let module_binding sub x =
+  let mb_expr = sub.module_expr sub x.mb_expr in
+  {x with mb_expr}
+
+let class_expr sub x =
+  let cl_env = sub.env sub x.cl_env in
+  let cl_desc =
+    match x.cl_desc with
+    | Tcl_constraint (cl, clty, vals, meths, concrs) ->
+        Tcl_constraint (
+          sub.class_expr sub cl,
+          Option.map (sub.class_type sub) clty,
+          vals,
+          meths,
+          concrs
+        )
+    | Tcl_structure clstr ->
+        Tcl_structure (sub.class_structure sub clstr)
+    | Tcl_fun (label, pat, priv, cl, partial) ->
+        Tcl_fun (
+          label,
+          sub.pat sub pat,
+          List.map (tuple2 id (sub.expr sub)) priv,
+          sub.class_expr sub cl,
+          partial
+        )
+    | Tcl_apply (cl, args) ->
+        Tcl_apply (
+          sub.class_expr sub cl,
+          List.map (tuple2 id (Option.map (sub.expr sub))) args
+        )
+    | Tcl_let (rec_flag, value_bindings, ivars, cl) ->
+        let (rec_flag, value_bindings) =
+          sub.value_bindings sub (rec_flag, value_bindings)
+        in
+        Tcl_let (
+          rec_flag,
+          value_bindings,
+          List.map (tuple2 id (sub.expr sub)) ivars,
+          sub.class_expr sub cl
+        )
+    | Tcl_ident (path, lid, tyl) ->
+        Tcl_ident (path, lid, List.map (sub.typ sub) tyl)
+    | Tcl_open (od, e) ->
+        Tcl_open (sub.open_description sub od, sub.class_expr sub e)
+  in
+  {x with cl_desc; cl_env}
+
+let class_type sub x =
+  let cltyp_env = sub.env sub x.cltyp_env in
+  let cltyp_desc =
+    match x.cltyp_desc with
+    | Tcty_signature csg -> Tcty_signature (sub.class_signature sub csg)
+    | Tcty_constr (path, lid, list) ->
+        Tcty_constr (
+          path,
+          lid,
+          List.map (sub.typ sub) list
+        )
+    | Tcty_arrow (label, ct, cl) ->
+        Tcty_arrow
+          (label,
+           sub.typ sub ct,
+           sub.class_type sub cl
+          )
+    | Tcty_open (od, e) ->
+        Tcty_open (sub.open_description sub od, sub.class_type sub e)
+  in
+  {x with cltyp_desc; cltyp_env}
+
+let class_signature sub x =
+  let csig_self = sub.typ sub x.csig_self in
+  let csig_fields = List.map (sub.class_type_field sub) x.csig_fields in
+  {x with csig_self; csig_fields}
+
+let class_type_field sub x =
+  let ctf_desc =
+    match x.ctf_desc with
+    | Tctf_inherit ct ->
+        Tctf_inherit (sub.class_type sub ct)
+    | Tctf_val (s, mut, virt, ct) ->
+        Tctf_val (s, mut, virt, sub.typ sub ct)
+    | Tctf_method (s, priv, virt, ct) ->
+        Tctf_method (s, priv, virt, sub.typ sub ct)
+    | Tctf_constraint  (ct1, ct2) ->
+        Tctf_constraint (sub.typ sub ct1, sub.typ sub ct2)
+    | Tctf_attribute _ as d -> d
+  in
+  {x with ctf_desc}
+
+let typ sub x =
+  let ctyp_env = sub.env sub x.ctyp_env in
+  let ctyp_desc =
+    match x.ctyp_desc with
+    | Ttyp_any
+    | Ttyp_var _ as d -> d
+    | Ttyp_arrow (label, ct1, ct2) ->
+        Ttyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2)
+    | Ttyp_tuple list -> Ttyp_tuple (List.map (sub.typ sub) list)
+    | Ttyp_constr (path, lid, list) ->
+        Ttyp_constr (path, lid, List.map (sub.typ sub) list)
+    | Ttyp_object (list, closed) ->
+        Ttyp_object ((List.map (sub.object_field sub) list), closed)
+    | Ttyp_class (path, lid, list) ->
+        Ttyp_class
+          (path,
+           lid,
+           List.map (sub.typ sub) list
+          )
+    | Ttyp_alias (ct, s) ->
+        Ttyp_alias (sub.typ sub ct, s)
+    | Ttyp_variant (list, closed, labels) ->
+        Ttyp_variant (List.map (sub.row_field sub) list, closed, labels)
+    | Ttyp_poly (sl, ct) ->
+        Ttyp_poly (sl, sub.typ sub ct)
+    | Ttyp_package pack ->
+        Ttyp_package (sub.package_type sub pack)
+  in
+  {x with ctyp_desc; ctyp_env}
+
+let class_structure sub x =
+  let cstr_self = sub.pat sub x.cstr_self in
+  let cstr_fields = List.map (sub.class_field sub) x.cstr_fields in
+  {x with cstr_self; cstr_fields}
+
+let row_field sub x =
+  let rf_desc = match x.rf_desc with
+    | Ttag (label, b, list) ->
+        Ttag (label, b, List.map (sub.typ sub) list)
+    | Tinherit ct -> Tinherit (sub.typ sub ct)
+  in
+  { x with rf_desc; }
+
+let object_field sub x =
+  let of_desc = match x.of_desc with
+    | OTtag (label, ct) ->
+        OTtag (label, (sub.typ sub ct))
+    | OTinherit ct -> OTinherit (sub.typ sub ct)
+  in
+  { x with of_desc; }
+
+let class_field_kind sub = function
+  | Tcfk_virtual ct -> Tcfk_virtual (sub.typ sub ct)
+  | Tcfk_concrete (ovf, e) -> Tcfk_concrete (ovf, sub.expr sub e)
+
+let class_field sub x =
+  let cf_desc =
+    match x.cf_desc with
+    | Tcf_inherit (ovf, cl, super, vals, meths) ->
+        Tcf_inherit (ovf, sub.class_expr sub cl, super, vals, meths)
+    | Tcf_constraint (cty, cty') ->
+        Tcf_constraint (
+          sub.typ sub cty,
+          sub.typ sub cty'
+        )
+    | Tcf_val (s, mf, id, k, b) ->
+        Tcf_val (s, mf, id, class_field_kind sub k, b)
+    | Tcf_method (s, priv, k) ->
+        Tcf_method (s, priv, class_field_kind sub k)
+    | Tcf_initializer exp ->
+        Tcf_initializer (sub.expr sub exp)
+    | Tcf_attribute _ as d -> d
+  in
+  {x with cf_desc}
+
+let value_bindings sub (rec_flag, list) =
+  (rec_flag, List.map (sub.value_binding sub) list)
+
+let case
+  : type k . mapper -> k case -> k case
+  = fun sub {c_lhs; c_guard; c_rhs} ->
+  {
+    c_lhs = sub.pat sub c_lhs;
+    c_guard = Option.map (sub.expr sub) c_guard;
+    c_rhs = sub.expr sub c_rhs;
+  }
+
+let value_binding sub x =
+  let vb_pat = sub.pat sub x.vb_pat in
+  let vb_expr = sub.expr sub x.vb_expr in
+  {x with vb_pat; vb_expr}
+
+let env _sub x = x
+
+let default =
+  {
+    binding_op;
+    case;
+    class_declaration;
+    class_description;
+    class_expr;
+    class_field;
+    class_signature;
+    class_structure;
+    class_type;
+    class_type_declaration;
+    class_type_field;
+    env;
+    expr;
+    extension_constructor;
+    module_binding;
+    module_coercion;
+    module_declaration;
+    module_substitution;
+    module_expr;
+    module_type;
+    module_type_declaration;
+    package_type;
+    pat;
+    row_field;
+    object_field;
+    open_declaration;
+    open_description;
+    signature;
+    signature_item;
+    structure;
+    structure_item;
+    typ;
+    type_declaration;
+    type_declarations;
+    type_extension;
+    type_exception;
+    type_kind;
+    value_binding;
+    value_bindings;
+    value_description;
+    with_constraint;
+  }
diff --git a/upstream/ocaml_412/typing/tast_mapper.mli b/upstream/ocaml_412/typing/tast_mapper.mli
new file mode 100644
index 0000000..ea6543d
--- /dev/null
+++ b/upstream/ocaml_412/typing/tast_mapper.mli
@@ -0,0 +1,72 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                        Alain Frisch, LexiFi                            *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Typedtree
+
+(** {1 A generic Typedtree mapper} *)
+
+type mapper =
+  {
+    binding_op: mapper -> binding_op -> binding_op;
+    case: 'k . mapper -> 'k case -> 'k case;
+    class_declaration: mapper -> class_declaration -> class_declaration;
+    class_description: mapper -> class_description -> class_description;
+    class_expr: mapper -> class_expr -> class_expr;
+    class_field: mapper -> class_field -> class_field;
+    class_signature: mapper -> class_signature -> class_signature;
+    class_structure: mapper -> class_structure -> class_structure;
+    class_type: mapper -> class_type -> class_type;
+    class_type_declaration: mapper -> class_type_declaration ->
+      class_type_declaration;
+    class_type_field: mapper -> class_type_field -> class_type_field;
+    env: mapper -> Env.t -> Env.t;
+    expr: mapper -> expression -> expression;
+    extension_constructor: mapper -> extension_constructor ->
+      extension_constructor;
+    module_binding: mapper -> module_binding -> module_binding;
+    module_coercion: mapper -> module_coercion -> module_coercion;
+    module_declaration: mapper -> module_declaration -> module_declaration;
+    module_substitution: mapper -> module_substitution -> module_substitution;
+    module_expr: mapper -> module_expr -> module_expr;
+    module_type: mapper -> module_type -> module_type;
+    module_type_declaration:
+      mapper -> module_type_declaration -> module_type_declaration;
+    package_type: mapper -> package_type -> package_type;
+    pat: 'k . mapper -> 'k general_pattern -> 'k general_pattern;
+    row_field: mapper -> row_field -> row_field;
+    object_field: mapper -> object_field -> object_field;
+    open_declaration: mapper -> open_declaration -> open_declaration;
+    open_description: mapper -> open_description -> open_description;
+    signature: mapper -> signature -> signature;
+    signature_item: mapper -> signature_item -> signature_item;
+    structure: mapper -> structure -> structure;
+    structure_item: mapper -> structure_item -> structure_item;
+    typ: mapper -> core_type -> core_type;
+    type_declaration: mapper -> type_declaration -> type_declaration;
+    type_declarations: mapper -> (rec_flag * type_declaration list)
+      -> (rec_flag * type_declaration list);
+    type_extension: mapper -> type_extension -> type_extension;
+    type_exception: mapper -> type_exception -> type_exception;
+    type_kind: mapper -> type_kind -> type_kind;
+    value_binding: mapper -> value_binding -> value_binding;
+    value_bindings: mapper -> (rec_flag * value_binding list) ->
+      (rec_flag * value_binding list);
+    value_description: mapper -> value_description -> value_description;
+    with_constraint: mapper -> with_constraint -> with_constraint;
+  }
+
+
+val default: mapper
diff --git a/upstream/ocaml_412/typing/type_immediacy.ml b/upstream/ocaml_412/typing/type_immediacy.ml
new file mode 100644
index 0000000..557ed42
--- /dev/null
+++ b/upstream/ocaml_412/typing/type_immediacy.ml
@@ -0,0 +1,43 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2019 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t =
+  | Unknown
+  | Always
+  | Always_on_64bits
+
+module Violation = struct
+  type t =
+    | Not_always_immediate
+    | Not_always_immediate_on_64bits
+end
+
+let coerce t ~as_ =
+  match t, as_ with
+  | _, Unknown
+  | Always, Always
+  | (Always | Always_on_64bits), Always_on_64bits -> Ok ()
+  | (Unknown | Always_on_64bits), Always ->
+      Error Violation.Not_always_immediate
+  | Unknown, Always_on_64bits ->
+      Error Violation.Not_always_immediate_on_64bits
+
+let of_attributes attrs =
+  match
+    Builtin_attributes.immediate attrs,
+    Builtin_attributes.immediate64 attrs
+  with
+  | true, _ -> Always
+  | false, true -> Always_on_64bits
+  | false, false -> Unknown
diff --git a/upstream/ocaml_412/typing/type_immediacy.mli b/upstream/ocaml_412/typing/type_immediacy.mli
new file mode 100644
index 0000000..3fc2e3b
--- /dev/null
+++ b/upstream/ocaml_412/typing/type_immediacy.mli
@@ -0,0 +1,40 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2019 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Immediacy status of a type *)
+
+type t =
+  | Unknown
+  (** We don't know anything *)
+  | Always
+  (** We know for sure that values of this type are always immediate *)
+  | Always_on_64bits
+  (** We know for sure that values of this type are always immediate
+      on 64 bit platforms. For other platforms, we know nothing. *)
+
+module Violation : sig
+  type t =
+    | Not_always_immediate
+    | Not_always_immediate_on_64bits
+end
+
+(** [coerce t ~as_] returns [Ok ()] iff [t] can be seen as type
+    immediacy [as_]. For instance, [Always] can be seen as
+    [Always_on_64bits] but the opposite is not true. Return [Error _]
+    if the coercion is not possible. *)
+val coerce : t -> as_:t -> (unit, Violation.t) result
+
+(** Return the immediateness of a type as indicated by the user via
+    attributes *)
+val of_attributes : Parsetree.attributes -> t
diff --git a/upstream/ocaml_412/typing/typeclass.ml b/upstream/ocaml_412/typing/typeclass.ml
new file mode 100644
index 0000000..12dec43
--- /dev/null
+++ b/upstream/ocaml_412/typing/typeclass.ml
@@ -0,0 +1,2064 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Parsetree
+open Asttypes
+open Path
+open Types
+open Typecore
+open Typetexp
+open Format
+
+type 'a class_info = {
+  cls_id : Ident.t;
+  cls_id_loc : string loc;
+  cls_decl : class_declaration;
+  cls_ty_id : Ident.t;
+  cls_ty_decl : class_type_declaration;
+  cls_obj_id : Ident.t;
+  cls_obj_abbr : type_declaration;
+  cls_typesharp_id : Ident.t;
+  cls_abbr : type_declaration;
+  cls_arity : int;
+  cls_pub_methods : string list;
+  cls_info : 'a;
+}
+
+type class_type_info = {
+  clsty_ty_id : Ident.t;
+  clsty_id_loc : string loc;
+  clsty_ty_decl : class_type_declaration;
+  clsty_obj_id : Ident.t;
+  clsty_obj_abbr : type_declaration;
+  clsty_typesharp_id : Ident.t;
+  clsty_abbr : type_declaration;
+  clsty_info : Typedtree.class_type_declaration;
+}
+
+type 'a full_class = {
+  id : Ident.t;
+  id_loc : tag loc;
+  clty: class_declaration;
+  ty_id: Ident.t;
+  cltydef: class_type_declaration;
+  obj_id: Ident.t;
+  obj_abbr: type_declaration;
+  cl_id: Ident.t;
+  cl_abbr: type_declaration;
+  arity: int;
+  pub_meths: string list;
+  coe: Warnings.loc list;
+  expr: 'a;
+  req: 'a Typedtree.class_infos;
+}
+
+type class_env = { val_env : Env.t; met_env : Env.t; par_env : Env.t }
+
+type error =
+    Unconsistent_constraint of Ctype.Unification_trace.t
+  | Field_type_mismatch of string * string * Ctype.Unification_trace.t
+  | Structure_expected of class_type
+  | Cannot_apply of class_type
+  | Apply_wrong_label of arg_label
+  | Pattern_type_clash of type_expr
+  | Repeated_parameter
+  | Unbound_class_2 of Longident.t
+  | Unbound_class_type_2 of Longident.t
+  | Abbrev_type_clash of type_expr * type_expr * type_expr
+  | Constructor_type_mismatch of string * Ctype.Unification_trace.t
+  | Virtual_class of bool * bool * string list * string list
+  | Parameter_arity_mismatch of Longident.t * int * int
+  | Parameter_mismatch of Ctype.Unification_trace.t
+  | Bad_parameters of Ident.t * type_expr * type_expr
+  | Class_match_failure of Ctype.class_match_failure list
+  | Unbound_val of string
+  | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure
+  | Non_generalizable_class of Ident.t * Types.class_declaration
+  | Cannot_coerce_self of type_expr
+  | Non_collapsable_conjunction of
+      Ident.t * Types.class_declaration * Ctype.Unification_trace.t
+  | Final_self_clash of Ctype.Unification_trace.t
+  | Mutability_mismatch of string * mutable_flag
+  | No_overriding of string * string
+  | Duplicate of string * string
+  | Closing_self_type of type_expr
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+open Typedtree
+
+let type_open_descr :
+  (?used_slot:bool ref -> Env.t -> Parsetree.open_description
+   -> open_description * Env.t) ref =
+  ref (fun ?used_slot:_ _ -> assert false)
+
+let ctyp desc typ env loc =
+  { ctyp_desc = desc; ctyp_type = typ; ctyp_loc = loc; ctyp_env = env;
+    ctyp_attributes = [] }
+
+                       (**********************)
+                       (*  Useful constants  *)
+                       (**********************)
+
+
+(*
+   Self type have a dummy private method, thus preventing it to become
+   closed.
+*)
+let dummy_method = Btype.dummy_method
+
+(*
+   Path associated to the temporary class type of a class being typed
+   (its constructor is not available).
+*)
+let unbound_class =
+  Path.Pident (Ident.create_local "*undef*")
+
+
+                (************************************)
+                (*  Some operations on class types  *)
+                (************************************)
+
+
+(* Fully expand the head of a class type *)
+let rec scrape_class_type =
+  function
+    Cty_constr (_, _, cty) -> scrape_class_type cty
+  | cty                     -> cty
+
+(* Generalize a class type *)
+let rec generalize_class_type gen =
+  function
+    Cty_constr (_, params, cty) ->
+      List.iter gen params;
+      generalize_class_type gen cty
+  | Cty_signature {csig_self = sty; csig_vars = vars; csig_inher = inher} ->
+      gen sty;
+      Vars.iter (fun _ (_, _, ty) -> gen ty) vars;
+      List.iter (fun (_,tl) -> List.iter gen tl) inher
+  | Cty_arrow (_, ty, cty) ->
+      gen ty;
+      generalize_class_type gen cty
+
+let generalize_class_type vars =
+  let gen = if vars then Ctype.generalize else Ctype.generalize_structure in
+  generalize_class_type gen
+
+(* Return the virtual methods of a class type *)
+let virtual_methods sign =
+  let (fields, _) =
+    Ctype.flatten_fields (Ctype.object_fields sign.Types.csig_self)
+  in
+  List.fold_left
+    (fun virt (lab, _, _) ->
+       if lab = dummy_method then virt else
+       if Concr.mem lab sign.csig_concr then virt else
+       lab::virt)
+    [] fields
+
+(* Return the constructor type associated to a class type *)
+let rec constructor_type constr cty =
+  match cty with
+    Cty_constr (_, _, cty) ->
+      constructor_type constr cty
+  | Cty_signature _ ->
+      constr
+  | Cty_arrow (l, ty, cty) ->
+      Ctype.newty (Tarrow (l, ty, constructor_type constr cty, Cok))
+
+let rec class_body cty =
+  match cty with
+    Cty_constr _ ->
+      cty (* Only class bodies can be abbreviated *)
+  | Cty_signature _ ->
+      cty
+  | Cty_arrow (_, _, cty) ->
+      class_body cty
+
+let extract_constraints cty =
+  let sign = Ctype.signature_of_class_type cty in
+  (Vars.fold (fun lab _ vars -> lab :: vars) sign.csig_vars [],
+   begin let (fields, _) =
+     Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
+   in
+   List.fold_left
+     (fun meths (lab, _, _) ->
+        if lab = dummy_method then meths else lab::meths)
+     [] fields
+   end,
+   sign.csig_concr)
+
+let rec abbreviate_class_type path params cty =
+  match cty with
+    Cty_constr (_, _, _) | Cty_signature _ ->
+      Cty_constr (path, params, cty)
+  | Cty_arrow (l, ty, cty) ->
+      Cty_arrow (l, ty, abbreviate_class_type path params cty)
+
+(* Check that all type variables are generalizable *)
+(* Use Env.empty to prevent expansion of recursively defined object types;
+   cf. typing-poly/poly.ml *)
+let rec closed_class_type =
+  function
+    Cty_constr (_, params, _) ->
+      List.for_all (Ctype.closed_schema Env.empty) params
+  | Cty_signature sign ->
+      Ctype.closed_schema Env.empty sign.csig_self
+        &&
+      Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema Env.empty ty && cc)
+        sign.csig_vars
+        true
+  | Cty_arrow (_, ty, cty) ->
+      Ctype.closed_schema Env.empty ty
+        &&
+      closed_class_type cty
+
+let closed_class cty =
+  List.for_all (Ctype.closed_schema Env.empty) cty.cty_params
+    &&
+  closed_class_type cty.cty_type
+
+let rec limited_generalize rv =
+  function
+    Cty_constr (_path, params, cty) ->
+      List.iter (Ctype.limited_generalize rv) params;
+      limited_generalize rv cty
+  | Cty_signature sign ->
+      Ctype.limited_generalize rv sign.csig_self;
+      Vars.iter (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty)
+        sign.csig_vars;
+      List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl)
+        sign.csig_inher
+  | Cty_arrow (_, ty, cty) ->
+      Ctype.limited_generalize rv ty;
+      limited_generalize rv cty
+
+(* Record a class type *)
+let rc node =
+  Cmt_format.add_saved_type (Cmt_format.Partial_class_expr node);
+  node
+
+
+                (***********************************)
+                (*  Primitives for typing classes  *)
+                (***********************************)
+
+
+(* Enter a value in the method environment only *)
+let enter_met_env ?check loc lab kind unbound_kind ty class_env =
+  let {val_env; met_env; par_env} = class_env in
+  let val_env = Env.enter_unbound_value lab unbound_kind val_env in
+  let par_env = Env.enter_unbound_value lab unbound_kind par_env in
+  let (id, met_env) =
+    Env.enter_value ?check lab
+      {val_type = ty; val_kind = kind;
+       val_attributes = []; Types.val_loc = loc;
+       val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); } met_env
+  in
+  let class_env = {val_env; met_env; par_env} in
+  (id,class_env )
+
+(* Enter an instance variable in the environment *)
+let enter_val cl_num vars inh lab mut virt ty class_env loc =
+  let val_env = class_env.val_env in
+  let (id, virt) =
+    try
+      let (id, mut', virt', ty') = Vars.find lab !vars in
+      if mut' <> mut then
+        raise (Error(loc, val_env, Mutability_mismatch(lab, mut)));
+      Ctype.unify val_env (Ctype.instance ty) (Ctype.instance ty');
+      (if not inh then Some id else None),
+      (if virt' = Concrete then virt' else virt)
+    with
+      Ctype.Unify tr ->
+        raise (Error(loc, val_env,
+                     Field_type_mismatch("instance variable", lab, tr)))
+    | Not_found -> None, virt
+  in
+  let (id, _) as result =
+    match id with Some id -> (id, class_env)
+    | None ->
+        enter_met_env Location.none lab (Val_ivar (mut, cl_num))
+          Val_unbound_instance_variable ty class_env
+  in
+  vars := Vars.add lab (id, mut, virt, ty) !vars;
+  result
+
+let concr_vals vars =
+  Vars.fold
+    (fun id (_, vf, _) s -> if vf = Virtual then s else Concr.add id s)
+    vars Concr.empty
+
+let inheritance self_type env ovf concr_meths warn_vals loc parent =
+  match scrape_class_type parent with
+    Cty_signature cl_sig ->
+
+      (* Methods *)
+      begin try
+        Ctype.unify env self_type cl_sig.csig_self
+      with Ctype.Unify trace ->
+        let open Ctype.Unification_trace in
+        match trace with
+        | Diff _ :: Incompatible_fields {name = n; _ } :: rem ->
+            raise(Error(loc, env, Field_type_mismatch ("method", n, rem)))
+        | _ -> assert false
+      end;
+
+      (* Overriding *)
+      let over_meths = Concr.inter cl_sig.csig_concr concr_meths in
+      let concr_vals = concr_vals cl_sig.csig_vars in
+      let over_vals = Concr.inter concr_vals warn_vals in
+      begin match ovf with
+        Some Fresh ->
+          let cname =
+            match parent with
+              Cty_constr (p, _, _) -> Path.name p
+            | _ -> "inherited"
+          in
+          if not (Concr.is_empty over_meths) then
+            Location.prerr_warning loc
+              (Warnings.Method_override (cname :: Concr.elements over_meths));
+          if not (Concr.is_empty over_vals) then
+            Location.prerr_warning loc
+              (Warnings.Instance_variable_override
+                 (cname :: Concr.elements over_vals));
+      | Some Override
+        when Concr.is_empty over_meths && Concr.is_empty over_vals ->
+        raise (Error(loc, env, No_overriding ("","")))
+      | _ -> ()
+      end;
+
+      let concr_meths = Concr.union cl_sig.csig_concr concr_meths
+      and warn_vals = Concr.union concr_vals warn_vals in
+
+      (cl_sig, concr_meths, warn_vals)
+
+  | _ ->
+      raise(Error(loc, env, Structure_expected parent))
+
+let virtual_method val_env meths self_type lab priv sty loc =
+  let (_, ty') =
+     Ctype.filter_self_method val_env lab priv meths self_type
+  in
+  let sty = Ast_helper.Typ.force_poly sty in
+  let cty = transl_simple_type val_env false sty in
+  let ty = cty.ctyp_type in
+  begin
+    try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
+        raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace)));
+  end;
+  cty
+
+let delayed_meth_specs = ref []
+
+let declare_method val_env meths self_type lab priv sty loc =
+  let (_, ty') =
+     Ctype.filter_self_method val_env lab priv meths self_type
+  in
+  let unif ty =
+    try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
+      raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace)))
+  in
+  let sty = Ast_helper.Typ.force_poly sty in
+  match sty.ptyp_desc, priv with
+    Ptyp_poly ([],sty'), Public ->
+(* TODO: we moved the [transl_simple_type_univars] outside of the lazy,
+so that we can get an immediate value. Is that correct ? Ask Jacques. *)
+      let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) val_env loc in
+      delayed_meth_specs :=
+      Warnings.mk_lazy (fun () ->
+            let cty = transl_simple_type_univars val_env sty' in
+            let ty = cty.ctyp_type in
+            unif ty;
+            returned_cty.ctyp_desc <- Ttyp_poly ([], cty);
+            returned_cty.ctyp_type <- ty;
+          ) ::
+      !delayed_meth_specs;
+      returned_cty
+  | _ ->
+      let cty = transl_simple_type val_env false sty in
+      let ty = cty.ctyp_type in
+      unif ty;
+      cty
+
+let type_constraint val_env sty sty' loc =
+  let cty  = transl_simple_type val_env false sty in
+  let ty = cty.ctyp_type in
+  let cty' = transl_simple_type val_env false sty' in
+  let ty' = cty'.ctyp_type in
+  begin
+    try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
+        raise(Error(loc, val_env, Unconsistent_constraint trace));
+  end;
+  (cty, cty')
+
+let make_method loc cl_num expr =
+  let open Ast_helper in
+  let mkid s = mkloc s loc in
+  Exp.fun_ ~loc:expr.pexp_loc Nolabel None
+    (Pat.alias ~loc (Pat.var ~loc (mkid "self-*")) (mkid ("self-" ^ cl_num)))
+    expr
+
+(*******************************)
+
+let add_val lab (mut, virt, ty) val_sig =
+  let virt =
+    try
+      let (_mut', virt', _ty') = Vars.find lab val_sig in
+      if virt' = Concrete then virt' else virt
+    with Not_found -> virt
+  in
+  Vars.add lab (mut, virt, ty) val_sig
+
+let rec class_type_field env self_type meths arg ctf =
+  Builtin_attributes.warning_scope ctf.pctf_attributes
+    (fun () -> class_type_field_aux env self_type meths arg ctf)
+
+and class_type_field_aux env self_type meths
+    (fields, val_sig, concr_meths, inher) ctf =
+
+  let loc = ctf.pctf_loc in
+  let mkctf desc =
+    { ctf_desc = desc; ctf_loc = loc; ctf_attributes = ctf.pctf_attributes }
+  in
+  match ctf.pctf_desc with
+    Pctf_inherit sparent ->
+      let parent = class_type env sparent in
+      let inher =
+        match parent.cltyp_type with
+          Cty_constr (p, tl, _) -> (p, tl) :: inher
+        | _ -> inher
+      in
+      let (cl_sig, concr_meths, _) =
+        inheritance self_type env None concr_meths Concr.empty sparent.pcty_loc
+          parent.cltyp_type
+      in
+      let val_sig =
+        Vars.fold add_val cl_sig.csig_vars val_sig in
+      (mkctf (Tctf_inherit parent) :: fields,
+       val_sig, concr_meths, inher)
+
+  | Pctf_val ({txt=lab}, mut, virt, sty) ->
+      let cty = transl_simple_type env false sty in
+      let ty = cty.ctyp_type in
+      (mkctf (Tctf_val (lab, mut, virt, cty)) :: fields,
+      add_val lab (mut, virt, ty) val_sig, concr_meths, inher)
+
+  | Pctf_method ({txt=lab}, priv, virt, sty)  ->
+      let cty =
+        declare_method env meths self_type lab priv sty  ctf.pctf_loc in
+      let concr_meths =
+        match virt with
+        | Concrete -> Concr.add lab concr_meths
+        | Virtual -> concr_meths
+      in
+      (mkctf (Tctf_method (lab, priv, virt, cty)) :: fields,
+        val_sig, concr_meths, inher)
+
+  | Pctf_constraint (sty, sty') ->
+      let (cty, cty') = type_constraint env sty sty'  ctf.pctf_loc in
+      (mkctf (Tctf_constraint (cty, cty')) :: fields,
+        val_sig, concr_meths, inher)
+
+  | Pctf_attribute x ->
+      Builtin_attributes.warning_attribute x;
+      (mkctf (Tctf_attribute x) :: fields,
+        val_sig, concr_meths, inher)
+
+  | Pctf_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and class_signature env {pcsig_self=sty; pcsig_fields=sign} =
+  let meths = ref Meths.empty in
+  let self_cty = transl_simple_type env false sty in
+  let self_cty = { self_cty with
+    ctyp_type = Ctype.expand_head env self_cty.ctyp_type } in
+  let self_type =  self_cty.ctyp_type in
+
+  (* Check that the binder is a correct type, and introduce a dummy
+     method preventing self type from being closed. *)
+  let dummy_obj = Ctype.newvar () in
+  Ctype.unify env (Ctype.filter_method env dummy_method Private dummy_obj)
+    (Ctype.newty (Ttuple []));
+  begin try
+    Ctype.unify env self_type dummy_obj
+  with Ctype.Unify _ ->
+    raise(Error(sty.ptyp_loc, env, Pattern_type_clash self_type))
+  end;
+
+  (* Class type fields *)
+  let (rev_fields, val_sig, concr_meths, inher) =
+    Builtin_attributes.warning_scope []
+      (fun () ->
+         List.fold_left (class_type_field env self_type meths)
+           ([], Vars.empty, Concr.empty, [])
+           sign
+      )
+  in
+  let cty =   {csig_self = self_type;
+   csig_vars = val_sig;
+   csig_concr = concr_meths;
+   csig_inher = inher}
+  in
+  { csig_self = self_cty;
+    csig_fields = List.rev rev_fields;
+    csig_type = cty;
+  }
+
+and class_type env scty =
+  Builtin_attributes.warning_scope scty.pcty_attributes
+    (fun () -> class_type_aux env scty)
+
+and class_type_aux env scty =
+  let cltyp desc typ =
+    {
+     cltyp_desc = desc;
+     cltyp_type = typ;
+     cltyp_loc = scty.pcty_loc;
+     cltyp_env = env;
+     cltyp_attributes = scty.pcty_attributes;
+    }
+  in
+  match scty.pcty_desc with
+    Pcty_constr (lid, styl) ->
+      let (path, decl) = Env.lookup_cltype ~loc:scty.pcty_loc lid.txt env in
+      if Path.same decl.clty_path unbound_class then
+        raise(Error(scty.pcty_loc, env, Unbound_class_type_2 lid.txt));
+      let (params, clty) =
+        Ctype.instance_class decl.clty_params decl.clty_type
+      in
+      if List.length params <> List.length styl then
+        raise(Error(scty.pcty_loc, env,
+                    Parameter_arity_mismatch (lid.txt, List.length params,
+                                                   List.length styl)));
+      let ctys = List.map2
+        (fun sty ty ->
+          let cty' = transl_simple_type env false sty in
+          let ty' = cty'.ctyp_type in
+          begin
+           try Ctype.unify env ty' ty with Ctype.Unify trace ->
+                  raise(Error(sty.ptyp_loc, env, Parameter_mismatch trace))
+            end;
+            cty'
+        )       styl params
+      in
+      let typ = Cty_constr (path, params, clty) in
+      cltyp (Tcty_constr ( path, lid , ctys)) typ
+
+  | Pcty_signature pcsig ->
+      let clsig = class_signature env pcsig in
+      let typ = Cty_signature clsig.csig_type in
+      cltyp (Tcty_signature clsig) typ
+
+  | Pcty_arrow (l, sty, scty) ->
+      let cty = transl_simple_type env false sty in
+      let ty = cty.ctyp_type in
+      let ty =
+        if Btype.is_optional l
+        then Ctype.newty (Tconstr(Predef.path_option,[ty], ref Mnil))
+        else ty in
+      let clty = class_type env scty in
+      let typ = Cty_arrow (l, ty, clty.cltyp_type) in
+      cltyp (Tcty_arrow (l, cty, clty)) typ
+
+  | Pcty_open (od, e) ->
+      let (od, newenv) = !type_open_descr env od in
+      let clty = class_type newenv e in
+      cltyp (Tcty_open (od, clty)) clty.cltyp_type
+
+  | Pcty_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+let class_type env scty =
+  delayed_meth_specs := [];
+  let cty = class_type env scty in
+  List.iter Lazy.force (List.rev !delayed_meth_specs);
+  delayed_meth_specs := [];
+  cty
+
+(*******************************)
+
+let rec class_field self_loc cl_num self_type meths vars arg cf =
+  Builtin_attributes.warning_scope cf.pcf_attributes
+    (fun () -> class_field_aux self_loc cl_num self_type meths vars arg cf)
+
+and class_field_aux self_loc cl_num self_type meths vars
+    (class_env, fields, concr_meths, warn_vals, inher,
+     local_meths, local_vals) cf =
+  let loc = cf.pcf_loc in
+  let mkcf desc =
+    { cf_desc = desc; cf_loc = loc; cf_attributes = cf.pcf_attributes }
+  in
+  let {val_env; met_env; par_env} = class_env in
+  match cf.pcf_desc with
+    Pcf_inherit (ovf, sparent, super) ->
+      let parent = class_expr cl_num val_env par_env sparent in
+      let inher =
+        match parent.cl_type with
+          Cty_constr (p, tl, _) -> (p, tl) :: inher
+        | _ -> inher
+      in
+      let (cl_sig, concr_meths, warn_vals) =
+        inheritance self_type val_env (Some ovf) concr_meths warn_vals
+          sparent.pcl_loc parent.cl_type
+      in
+      (* Variables *)
+      let (class_env, inh_vars) =
+        Vars.fold
+          (fun lab info (class_env, inh_vars) ->
+             let mut, vr, ty = info in
+             let (id, class_env) =
+                enter_val cl_num vars true lab mut vr ty class_env
+                 sparent.pcl_loc ;
+             in
+             (class_env, (lab, id) :: inh_vars))
+          cl_sig.csig_vars (class_env, [])
+      in
+      (* Inherited concrete methods *)
+      let inh_meths =
+        Concr.fold (fun lab rem -> (lab, Ident.create_local lab)::rem)
+          cl_sig.csig_concr []
+      in
+      (* Super *)
+      let (class_env,super) =
+        match super with
+          None ->
+            (class_env,None)
+        | Some {txt=name} ->
+            let (_id, class_env) =
+              enter_met_env ~check:(fun s -> Warnings.Unused_ancestor s)
+                sparent.pcl_loc name (Val_anc (inh_meths, cl_num))
+                Val_unbound_ancestor self_type class_env
+            in
+            (class_env,Some name)
+      in
+      (class_env,
+       lazy (mkcf (Tcf_inherit (ovf, parent, super, inh_vars, inh_meths)))
+       :: fields,
+       concr_meths, warn_vals, inher, local_meths, local_vals)
+
+  | Pcf_val (lab, mut, Cfk_virtual styp) ->
+      if !Clflags.principal then Ctype.begin_def ();
+      let cty = Typetexp.transl_simple_type val_env false styp in
+      let ty = cty.ctyp_type in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        Ctype.generalize_structure ty
+      end;
+      let (id, class_env') =
+        enter_val cl_num vars false lab.txt mut Virtual ty
+        class_env loc
+      in
+      (class_env',
+       lazy (mkcf (Tcf_val (lab, mut, id, Tcfk_virtual cty,
+                            met_env == class_env'.met_env)))
+             :: fields,
+             concr_meths, warn_vals, inher, local_meths, local_vals)
+
+  | Pcf_val (lab, mut, Cfk_concrete (ovf, sexp)) ->
+      if Concr.mem lab.txt local_vals then
+        raise(Error(loc, val_env, Duplicate ("instance variable", lab.txt)));
+      if Concr.mem lab.txt warn_vals then begin
+        if ovf = Fresh then
+          Location.prerr_warning lab.loc
+            (Warnings.Instance_variable_override[lab.txt])
+      end else begin
+        if ovf = Override then
+          raise(Error(loc, val_env,
+                      No_overriding ("instance variable", lab.txt)))
+      end;
+      if !Clflags.principal then Ctype.begin_def ();
+      let exp = type_exp val_env sexp in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        Ctype.generalize_structure exp.exp_type
+       end;
+      let (id, class_env') =
+        enter_val cl_num vars false lab.txt mut Concrete exp.exp_type
+        class_env loc
+      in
+      (class_env',
+       lazy (mkcf (Tcf_val (lab, mut, id,
+                    Tcfk_concrete (ovf, exp), met_env == class_env'.met_env)))
+       :: fields,
+       concr_meths, Concr.add lab.txt warn_vals, inher, local_meths,
+       Concr.add lab.txt local_vals)
+
+  | Pcf_method (lab, priv, Cfk_virtual sty) ->
+      let cty = virtual_method val_env meths self_type lab.txt priv sty loc in
+      (class_env,
+        lazy (mkcf(Tcf_method (lab, priv, Tcfk_virtual cty)))
+       ::fields,
+        concr_meths, warn_vals, inher, local_meths, local_vals)
+
+  | Pcf_method (lab, priv, Cfk_concrete (ovf, expr))  ->
+      let expr =
+        match expr.pexp_desc with
+        | Pexp_poly _ -> expr
+        | _ -> Ast_helper.Exp.poly ~loc:expr.pexp_loc expr None
+      in
+      if Concr.mem lab.txt local_meths then
+        raise(Error(loc, val_env, Duplicate ("method", lab.txt)));
+      if Concr.mem lab.txt concr_meths then begin
+        if ovf = Fresh then
+          Location.prerr_warning loc (Warnings.Method_override [lab.txt])
+      end else begin
+        if ovf = Override then
+          raise(Error(loc, val_env, No_overriding("method", lab.txt)))
+      end;
+      let (_, ty) =
+        Ctype.filter_self_method val_env lab.txt priv meths self_type
+      in
+      begin try match expr.pexp_desc with
+        Pexp_poly (sbody, sty) ->
+          begin match sty with None -> ()
+                | Some sty ->
+                    let sty = Ast_helper.Typ.force_poly sty in
+                    let cty' = Typetexp.transl_simple_type val_env false sty in
+                    let ty' = cty'.ctyp_type in
+              Ctype.unify val_env ty' ty
+          end;
+          begin match (Ctype.repr ty).desc with
+            Tvar _ ->
+              let ty' = Ctype.newvar () in
+              Ctype.unify val_env (Ctype.newty (Tpoly (ty', []))) ty;
+              Ctype.unify val_env (type_approx val_env sbody) ty'
+          | Tpoly (ty1, tl) ->
+              let _, ty1' = Ctype.instance_poly false tl ty1 in
+              let ty2 = type_approx val_env sbody in
+              Ctype.unify val_env ty2 ty1'
+          | _ -> assert false
+          end
+      | _ -> assert false
+      with Ctype.Unify trace ->
+        raise(Error(loc, val_env,
+                    Field_type_mismatch ("method", lab.txt, trace)))
+      end;
+      let meth_expr = make_method self_loc cl_num expr in
+      (* backup variables for Pexp_override *)
+      let vars_local = !vars in
+
+      let field =
+        Warnings.mk_lazy
+          (fun () ->
+             (* Read the generalized type *)
+             let (_, ty) = Meths.find lab.txt !meths in
+             let meth_type = mk_expected (
+               Btype.newgenty (Tarrow(Nolabel, self_type, ty, Cok))
+             ) in
+             Ctype.raise_nongen_level ();
+             vars := vars_local;
+             let texp = type_expect met_env meth_expr meth_type in
+             Ctype.end_def ();
+             mkcf (Tcf_method (lab, priv, Tcfk_concrete (ovf, texp)))
+          )
+      in
+      (class_env, field::fields,
+       Concr.add lab.txt concr_meths, warn_vals, inher,
+       Concr.add lab.txt local_meths, local_vals)
+
+  | Pcf_constraint (sty, sty') ->
+      let (cty, cty') = type_constraint val_env sty sty' loc in
+      (class_env,
+        lazy (mkcf (Tcf_constraint (cty, cty'))) :: fields,
+        concr_meths, warn_vals, inher, local_meths, local_vals)
+
+  | Pcf_initializer expr ->
+      let expr = make_method self_loc cl_num expr in
+      let vars_local = !vars in
+      let field =
+        lazy begin
+          Ctype.raise_nongen_level ();
+          let meth_type = mk_expected (
+            Ctype.newty
+              (Tarrow (Nolabel, self_type,
+                       Ctype.instance Predef.type_unit, Cok))
+          ) in
+          vars := vars_local;
+          let texp = type_expect met_env expr meth_type in
+          Ctype.end_def ();
+          mkcf (Tcf_initializer texp)
+        end in
+      (class_env, field::fields, concr_meths, warn_vals,
+       inher, local_meths, local_vals)
+  | Pcf_attribute x ->
+      Builtin_attributes.warning_attribute x;
+      (class_env,
+        lazy (mkcf (Tcf_attribute x)) :: fields,
+        concr_meths, warn_vals, inher, local_meths, local_vals)
+  | Pcf_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+(* N.B. the self type of a final object type doesn't contain a dummy method in
+   the beginning.
+   We only explicitly add a dummy method to class definitions (and class (type)
+   declarations)), which are later removed (made absent) by [final_decl].
+
+   If we ever find a dummy method in a final object self type, it means that
+   somehow we've unified the self type of the object with the self type of a not
+   yet finished class.
+   When this happens, we cannot close the object type and must error. *)
+and class_structure cl_num final val_env met_env loc
+  { pcstr_self = spat; pcstr_fields = str } =
+  (* Environment for substructures *)
+  let par_env = met_env in
+
+  (* Location of self. Used for locations of self arguments *)
+  let self_loc = {spat.ppat_loc with Location.loc_ghost = true} in
+
+  let self_type = Ctype.newobj (Ctype.newvar ()) in
+
+  (* Adding a dummy method to the self type prevents it from being closed /
+     escaping.
+     That isn't needed for objects though. *)
+  if not final then
+    Ctype.unify val_env
+      (Ctype.filter_method val_env dummy_method Private self_type)
+      (Ctype.newty (Ttuple []));
+
+  (* Private self is used for private method calls *)
+  let private_self = if final then Ctype.newvar () else self_type in
+
+  (* Self binder *)
+  let (pat, meths, vars, val_env, met_env, par_env) =
+    type_self_pattern cl_num private_self val_env met_env par_env spat
+  in
+  let public_self = pat.pat_type in
+
+  (* Check that the binder has a correct type *)
+  let ty =
+    if final then Ctype.newobj (Ctype.newvar()) else self_type in
+  begin try Ctype.unify val_env public_self ty with
+    Ctype.Unify _ ->
+      raise(Error(spat.ppat_loc, val_env, Pattern_type_clash public_self))
+  end;
+  let get_methods ty =
+    (fst (Ctype.flatten_fields
+            (Ctype.object_fields (Ctype.expand_head val_env ty)))) in
+  if final then begin
+    (* Copy known information to still empty self_type *)
+    List.iter
+      (fun (lab,kind,ty) ->
+        let k =
+          if Btype.field_kind_repr kind = Fpresent then Public else Private in
+        try Ctype.unify val_env ty
+            (Ctype.filter_method val_env lab k self_type)
+        with _ -> assert false)
+      (get_methods public_self)
+  end;
+
+  (* Typing of class fields *)
+  let class_env = {val_env; met_env; par_env} in
+  let (_, fields, concr_meths, _, inher, _local_meths, _local_vals) =
+    Builtin_attributes.warning_scope []
+      (fun () ->
+         List.fold_left (class_field self_loc cl_num self_type meths vars)
+           ( class_env,[], Concr.empty, Concr.empty, [],
+            Concr.empty, Concr.empty)
+           str
+      )
+  in
+  Ctype.unify val_env self_type (Ctype.newvar ()); (* useless ? *)
+  let sign =
+    {csig_self = public_self;
+     csig_vars = Vars.map (fun (_id, mut, vr, ty) -> (mut, vr, ty)) !vars;
+     csig_concr = concr_meths;
+      csig_inher = inher} in
+  let methods = get_methods self_type in
+  let priv_meths =
+    List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind <> Fpresent)
+      methods in
+  (* ensure that inherited methods are listed too *)
+  List.iter (fun (met, _kind, _ty) ->
+      if Meths.mem met !meths then () else
+      ignore (Ctype.filter_self_method val_env met Private meths self_type))
+    methods;
+  if final then begin
+    (* Unify private_self and a copy of self_type. self_type will not
+       be modified after this point *)
+    if not (Ctype.close_object self_type) then
+      raise(Error(loc, val_env, Closing_self_type self_type));
+    let mets = virtual_methods {sign with csig_self = self_type} in
+    let vals =
+      Vars.fold
+        (fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l)
+        sign.csig_vars [] in
+    if mets <> [] || vals <> [] then
+      raise(Error(loc, val_env, Virtual_class(true, final, mets, vals)));
+    let self_methods =
+      List.fold_right
+        (fun (lab,kind,ty) rem ->
+           Ctype.newty(Tfield(lab, Btype.copy_kind kind, ty, rem)))
+        methods (Ctype.newty Tnil) in
+    begin try
+      Ctype.unify val_env private_self
+        (Ctype.newty (Tobject(self_methods, ref None)));
+      Ctype.unify val_env public_self self_type
+    with Ctype.Unify trace -> raise(Error(loc, val_env, Final_self_clash trace))
+    end;
+  end;
+
+  (* Typing of method bodies *)
+  (* if !Clflags.principal then *) begin
+    let ms = !meths in
+    (* Generalize the spine of methods accessed through self *)
+    Meths.iter (fun _ (_,ty) -> Ctype.generalize_spine ty) ms;
+    meths :=
+      Meths.map (fun (id,ty) -> (id, Ctype.generic_instance ty)) ms;
+    (* But keep levels correct on the type of self *)
+    Meths.iter (fun _ (_,ty) -> Ctype.unify val_env ty (Ctype.newvar ())) ms
+  end;
+  let fields = List.map Lazy.force (List.rev fields) in
+  let meths = Meths.map (function (id, _ty) -> id) !meths in
+
+  (* Check for private methods made public *)
+  let pub_meths' =
+    List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind = Fpresent)
+      (get_methods public_self) in
+  let names = List.map (fun (x,_,_) -> x) in
+  let l1 = names priv_meths and l2 = names pub_meths' in
+  let added = List.filter (fun x -> List.mem x l1) l2 in
+  if added <> [] then
+    Location.prerr_warning loc (Warnings.Implicit_public_methods added);
+  let sign = if final then sign else
+      {sign with Types.csig_self = Ctype.expand_head val_env public_self} in
+  {
+    cstr_self = pat;
+    cstr_fields = fields;
+    cstr_type = sign;
+    cstr_meths = meths}, sign (* redondant, since already in cstr_type *)
+
+and class_expr cl_num val_env met_env scl =
+  Builtin_attributes.warning_scope scl.pcl_attributes
+    (fun () -> class_expr_aux cl_num val_env met_env scl)
+
+and class_expr_aux cl_num val_env met_env scl =
+  match scl.pcl_desc with
+    Pcl_constr (lid, styl) ->
+      let (path, decl) = Env.lookup_class ~loc:scl.pcl_loc lid.txt val_env in
+      if Path.same decl.cty_path unbound_class then
+        raise(Error(scl.pcl_loc, val_env, Unbound_class_2 lid.txt));
+      let tyl = List.map
+          (fun sty -> transl_simple_type val_env false sty)
+          styl
+      in
+      let (params, clty) =
+        Ctype.instance_class decl.cty_params decl.cty_type
+      in
+      let clty' = abbreviate_class_type path params clty in
+      if List.length params <> List.length tyl then
+        raise(Error(scl.pcl_loc, val_env,
+                    Parameter_arity_mismatch (lid.txt, List.length params,
+                                                   List.length tyl)));
+      List.iter2
+        (fun cty' ty ->
+          let ty' = cty'.ctyp_type in
+           try Ctype.unify val_env ty' ty with Ctype.Unify trace ->
+             raise(Error(cty'.ctyp_loc, val_env, Parameter_mismatch trace)))
+        tyl params;
+      let cl =
+        rc {cl_desc = Tcl_ident (path, lid, tyl);
+            cl_loc = scl.pcl_loc;
+            cl_type = clty';
+            cl_env = val_env;
+            cl_attributes = scl.pcl_attributes;
+           }
+      in
+      let (vals, meths, concrs) = extract_constraints clty in
+      rc {cl_desc = Tcl_constraint (cl, None, vals, meths, concrs);
+          cl_loc = scl.pcl_loc;
+          cl_type = clty';
+          cl_env = val_env;
+          cl_attributes = []; (* attributes are kept on the inner cl node *)
+         }
+  | Pcl_structure cl_str ->
+      let (desc, ty) =
+        class_structure cl_num false val_env met_env scl.pcl_loc cl_str in
+      rc {cl_desc = Tcl_structure desc;
+          cl_loc = scl.pcl_loc;
+          cl_type = Cty_signature ty;
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_fun (l, Some default, spat, sbody) ->
+      let loc = default.pexp_loc in
+      let open Ast_helper in
+      let scases = [
+        Exp.case
+          (Pat.construct ~loc
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
+             (Some (Pat.var ~loc (mknoloc "*sth*"))))
+          (Exp.ident ~loc (mknoloc (Longident.Lident "*sth*")));
+
+        Exp.case
+          (Pat.construct ~loc
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
+             None)
+          default;
+       ]
+      in
+      let smatch =
+        Exp.match_ ~loc (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*")))
+          scases
+      in
+      let sfun =
+        Cl.fun_ ~loc:scl.pcl_loc
+          l None
+          (Pat.var ~loc (mknoloc "*opt*"))
+          (Cl.let_ ~loc:scl.pcl_loc Nonrecursive [Vb.mk spat smatch] sbody)
+          (* Note: we don't put the '#default' attribute, as it
+             is not detected for class-level let bindings.  See #5975.*)
+      in
+      class_expr cl_num val_env met_env sfun
+  | Pcl_fun (l, None, spat, scl') ->
+      if !Clflags.principal then Ctype.begin_def ();
+      let (pat, pv, val_env', met_env) =
+        Typecore.type_class_arg_pattern cl_num val_env met_env l spat
+      in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        let gen {pat_type = ty} = Ctype.generalize_structure ty in
+        iter_pattern gen pat
+      end;
+      let pv =
+        List.map
+          begin fun (id, id', _ty) ->
+            let path = Pident id' in
+            (* do not mark the value as being used *)
+            let vd = Env.find_value path val_env' in
+            (id,
+             {exp_desc =
+              Texp_ident(path, mknoloc (Longident.Lident (Ident.name id)), vd);
+              exp_loc = Location.none; exp_extra = [];
+              exp_type = Ctype.instance vd.val_type;
+              exp_attributes = []; (* check *)
+              exp_env = val_env'})
+          end
+          pv
+      in
+      let rec not_nolabel_function = function
+        | Cty_arrow(Nolabel, _, _) -> false
+        | Cty_arrow(_, _, cty) -> not_nolabel_function cty
+        | _ -> true
+      in
+      let partial =
+        let dummy = type_exp val_env (Ast_helper.Exp.unreachable ()) in
+        Typecore.check_partial val_env pat.pat_type pat.pat_loc
+          [{c_lhs = pat; c_guard = None; c_rhs = dummy}]
+      in
+      Ctype.raise_nongen_level ();
+      let cl = class_expr cl_num val_env' met_env scl' in
+      Ctype.end_def ();
+      if Btype.is_optional l && not_nolabel_function cl.cl_type then
+        Location.prerr_warning pat.pat_loc
+          Warnings.Unerasable_optional_argument;
+      rc {cl_desc = Tcl_fun (l, pat, pv, cl, partial);
+          cl_loc = scl.pcl_loc;
+          cl_type = Cty_arrow
+            (l, Ctype.instance pat.pat_type, cl.cl_type);
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_apply (scl', sargs) ->
+      assert (sargs <> []);
+      if !Clflags.principal then Ctype.begin_def ();
+      let cl = class_expr cl_num val_env met_env scl' in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        generalize_class_type false cl.cl_type;
+      end;
+      let rec nonopt_labels ls ty_fun =
+        match ty_fun with
+        | Cty_arrow (l, _, ty_res) ->
+            if Btype.is_optional l then nonopt_labels ls ty_res
+            else nonopt_labels (l::ls) ty_res
+        | _    -> ls
+      in
+      let ignore_labels =
+        !Clflags.classic ||
+        let labels = nonopt_labels [] cl.cl_type in
+        List.length labels = List.length sargs &&
+        List.for_all (fun (l,_) -> l = Nolabel) sargs &&
+        List.exists (fun l -> l <> Nolabel) labels &&
+        begin
+          Location.prerr_warning
+            cl.cl_loc
+            (Warnings.Labels_omitted
+               (List.map Printtyp.string_of_label
+                         (List.filter ((<>) Nolabel) labels)));
+          true
+        end
+      in
+      let rec type_args args omitted ty_fun ty_fun0 sargs =
+        match ty_fun, ty_fun0 with
+        | Cty_arrow (l, ty, ty_fun), Cty_arrow (_, ty0, ty_fun0)
+          when sargs <> [] ->
+            let name = Btype.label_name l
+            and optional = Btype.is_optional l in
+            let use_arg sarg l' =
+              Some (
+                if not optional || Btype.is_optional l' then
+                  type_argument val_env sarg ty ty0
+                else
+                  let ty' = extract_option_type val_env ty
+                  and ty0' = extract_option_type val_env ty0 in
+                  let arg = type_argument val_env sarg ty' ty0' in
+                  option_some val_env arg
+              )
+            in
+            let eliminate_optional_arg () =
+              Some (option_none val_env ty0 Location.none)
+            in
+            let remaining_sargs, arg =
+              if ignore_labels then begin
+                match sargs with
+                | [] -> assert false
+                | (l', sarg) :: remaining_sargs ->
+                    if name = Btype.label_name l' ||
+                       (not optional && l' = Nolabel)
+                    then
+                      (remaining_sargs, use_arg sarg l')
+                    else if
+                      optional &&
+                      not (List.exists (fun (l, _) -> name = Btype.label_name l)
+                             remaining_sargs)
+                    then
+                      (sargs, eliminate_optional_arg ())
+                    else
+                      raise(Error(sarg.pexp_loc, val_env, Apply_wrong_label l'))
+              end else
+                match Btype.extract_label name sargs with
+                | Some (l', sarg, _, remaining_sargs) ->
+                    if not optional && Btype.is_optional l' then
+                      Location.prerr_warning sarg.pexp_loc
+                        (Warnings.Nonoptional_label
+                           (Printtyp.string_of_label l));
+                    remaining_sargs, use_arg sarg l'
+                | None ->
+                    sargs,
+                    if Btype.is_optional l && List.mem_assoc Nolabel sargs then
+                      eliminate_optional_arg ()
+                    else
+                      None
+            in
+            let omitted = if arg = None then (l,ty0) :: omitted else omitted in
+            type_args ((l,arg)::args) omitted ty_fun ty_fun0 remaining_sargs
+        | _ ->
+            match sargs with
+              (l, sarg0)::_ ->
+                if omitted <> [] then
+                  raise(Error(sarg0.pexp_loc, val_env, Apply_wrong_label l))
+                else
+                  raise(Error(cl.cl_loc, val_env, Cannot_apply cl.cl_type))
+            | [] ->
+                (List.rev args,
+                 List.fold_left
+                   (fun ty_fun (l,ty) -> Cty_arrow(l,ty,ty_fun))
+                   ty_fun0 omitted)
+      in
+      let (args, cty) =
+        let (_, ty_fun0) = Ctype.instance_class [] cl.cl_type in
+        type_args [] [] cl.cl_type ty_fun0 sargs
+      in
+      rc {cl_desc = Tcl_apply (cl, args);
+          cl_loc = scl.pcl_loc;
+          cl_type = cty;
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_let (rec_flag, sdefs, scl') ->
+      let (defs, val_env) =
+        Typecore.type_let In_class_def val_env rec_flag sdefs in
+      let (vals, met_env) =
+        List.fold_right
+          (fun (id, _id_loc, _typ) (vals, met_env) ->
+             let path = Pident id in
+             (* do not mark the value as used *)
+             let vd = Env.find_value path val_env in
+             Ctype.begin_def ();
+             let expr =
+               {exp_desc =
+                Texp_ident(path, mknoloc(Longident.Lident (Ident.name id)),vd);
+                exp_loc = Location.none; exp_extra = [];
+                exp_type = Ctype.instance vd.val_type;
+                exp_attributes = [];
+                exp_env = val_env;
+               }
+             in
+             Ctype.end_def ();
+             Ctype.generalize expr.exp_type;
+             let desc =
+               {val_type = expr.exp_type; val_kind = Val_ivar (Immutable,
+                                                               cl_num);
+                val_attributes = [];
+                Types.val_loc = vd.Types.val_loc;
+                val_uid = vd.val_uid;
+               }
+             in
+             let id' = Ident.create_local (Ident.name id) in
+             ((id', expr)
+              :: vals,
+              Env.add_value id' desc met_env))
+          (let_bound_idents_full defs)
+          ([], met_env)
+      in
+      let cl = class_expr cl_num val_env met_env scl' in
+      let () = if rec_flag = Recursive then
+        check_recursive_bindings val_env defs
+      in
+      rc {cl_desc = Tcl_let (rec_flag, defs, vals, cl);
+          cl_loc = scl.pcl_loc;
+          cl_type = cl.cl_type;
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_constraint (scl', scty) ->
+      Ctype.begin_class_def ();
+      let context = Typetexp.narrow () in
+      let cl = class_expr cl_num val_env met_env scl' in
+      Typetexp.widen context;
+      let context = Typetexp.narrow () in
+      let clty = class_type val_env scty in
+      Typetexp.widen context;
+      Ctype.end_def ();
+
+      limited_generalize (Ctype.row_variable (Ctype.self_type cl.cl_type))
+          cl.cl_type;
+      limited_generalize (Ctype.row_variable (Ctype.self_type clty.cltyp_type))
+        clty.cltyp_type;
+
+      begin match
+        Includeclass.class_types val_env cl.cl_type clty.cltyp_type
+      with
+        []    -> ()
+      | error -> raise(Error(cl.cl_loc, val_env, Class_match_failure error))
+      end;
+      let (vals, meths, concrs) = extract_constraints clty.cltyp_type in
+      rc {cl_desc = Tcl_constraint (cl, Some clty, vals, meths, concrs);
+          cl_loc = scl.pcl_loc;
+          cl_type = snd (Ctype.instance_class [] clty.cltyp_type);
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_open (pod, e) ->
+      let used_slot = ref false in
+      let (od, new_val_env) = !type_open_descr ~used_slot val_env pod in
+      let ( _, new_met_env) = !type_open_descr ~used_slot met_env pod in
+      let cl = class_expr cl_num new_val_env new_met_env e in
+      rc {cl_desc = Tcl_open (od, cl);
+          cl_loc = scl.pcl_loc;
+          cl_type = cl.cl_type;
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+(*******************************)
+
+(* Approximate the type of the constructor to allow recursive use *)
+(* of optional parameters                                         *)
+
+let var_option = Predef.type_option (Btype.newgenvar ())
+
+let rec approx_declaration cl =
+  match cl.pcl_desc with
+    Pcl_fun (l, _, _, cl) ->
+      let arg =
+        if Btype.is_optional l then Ctype.instance var_option
+        else Ctype.newvar () in
+      Ctype.newty (Tarrow (l, arg, approx_declaration cl, Cok))
+  | Pcl_let (_, _, cl) ->
+      approx_declaration cl
+  | Pcl_constraint (cl, _) ->
+      approx_declaration cl
+  | _ -> Ctype.newvar ()
+
+let rec approx_description ct =
+  match ct.pcty_desc with
+    Pcty_arrow (l, _, ct) ->
+      let arg =
+        if Btype.is_optional l then Ctype.instance var_option
+        else Ctype.newvar () in
+      Ctype.newty (Tarrow (l, arg, approx_description ct, Cok))
+  | _ -> Ctype.newvar ()
+
+(*******************************)
+
+let temp_abbrev loc env id arity uid =
+  let params = ref [] in
+  for _i = 1 to arity do
+    params := Ctype.newvar () :: !params
+  done;
+  let ty = Ctype.newobj (Ctype.newvar ()) in
+  let env =
+    Env.add_type ~check:true id
+      {type_params = !params;
+       type_arity = arity;
+       type_kind = Type_abstract;
+       type_private = Public;
+       type_manifest = Some ty;
+       type_variance = Variance.unknown_signature ~injective:false ~arity;
+       type_separability = Types.Separability.default_signature ~arity;
+       type_is_newtype = false;
+       type_expansion_scope = Btype.lowest_level;
+       type_loc = loc;
+       type_attributes = []; (* or keep attrs from the class decl? *)
+       type_immediate = Unknown;
+       type_unboxed = unboxed_false_default_false;
+       type_uid = uid;
+      }
+      env
+  in
+  (!params, ty, env)
+
+let initial_env define_class approx
+    (res, env) (cl, id, ty_id, obj_id, cl_id, uid) =
+  (* Temporary abbreviations *)
+  let arity = List.length cl.pci_params in
+  let (obj_params, obj_ty, env) = temp_abbrev cl.pci_loc env obj_id arity uid in
+  let (cl_params, cl_ty, env) = temp_abbrev cl.pci_loc env cl_id arity uid in
+
+  (* Temporary type for the class constructor *)
+  let constr_type = approx cl.pci_expr in
+  if !Clflags.principal then Ctype.generalize_spine constr_type;
+  let dummy_cty =
+    Cty_signature
+      { csig_self = Ctype.newvar ();
+        csig_vars = Vars.empty;
+        csig_concr = Concr.empty;
+        csig_inher = [] }
+  in
+  let dummy_class =
+    {Types.cty_params = [];             (* Dummy value *)
+     cty_variance = [];
+     cty_type = dummy_cty;        (* Dummy value *)
+     cty_path = unbound_class;
+     cty_new =
+       begin match cl.pci_virt with
+       | Virtual  -> None
+       | Concrete -> Some constr_type
+       end;
+     cty_loc = Location.none;
+     cty_attributes = [];
+     cty_uid = uid;
+    }
+  in
+  let env =
+    Env.add_cltype ty_id
+      {clty_params = [];            (* Dummy value *)
+       clty_variance = [];
+       clty_type = dummy_cty;       (* Dummy value *)
+       clty_path = unbound_class;
+       clty_loc = Location.none;
+       clty_attributes = [];
+       clty_uid = uid;
+      }
+      (
+        if define_class then
+          Env.add_class id dummy_class env
+        else
+          env
+      )
+  in
+  ((cl, id, ty_id,
+    obj_id, obj_params, obj_ty,
+    cl_id, cl_params, cl_ty,
+    constr_type, dummy_class)::res,
+   env)
+
+let class_infos define_class kind
+    (cl, id, ty_id,
+     obj_id, obj_params, obj_ty,
+     cl_id, cl_params, cl_ty,
+     constr_type, dummy_class)
+    (res, env) =
+
+  reset_type_variables ();
+  Ctype.begin_class_def ();
+
+  (* Introduce class parameters *)
+  let ci_params =
+    let make_param (sty, v) =
+      try
+          (transl_type_param env sty, v)
+      with Already_bound ->
+        raise(Error(sty.ptyp_loc, env, Repeated_parameter))
+    in
+      List.map make_param cl.pci_params
+  in
+  let params = List.map (fun (cty, _) -> cty.ctyp_type) ci_params in
+
+  (* Allow self coercions (only for class declarations) *)
+  let coercion_locs = ref [] in
+
+  (* Type the class expression *)
+  let (expr, typ) =
+    try
+      Typecore.self_coercion :=
+        (Path.Pident obj_id, coercion_locs) :: !Typecore.self_coercion;
+      let res = kind env cl.pci_expr in
+      Typecore.self_coercion := List.tl !Typecore.self_coercion;
+      res
+    with exn ->
+      Typecore.self_coercion := []; raise exn
+  in
+
+  Ctype.end_def ();
+
+  let sty = Ctype.self_type typ in
+
+  (* First generalize the type of the dummy method (cf PR#6123) *)
+  let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in
+  List.iter (fun (met, _, ty) -> if met = dummy_method then Ctype.generalize ty)
+    fields;
+  (* Generalize the row variable *)
+  let rv = Ctype.row_variable sty in
+  List.iter (Ctype.limited_generalize rv) params;
+  limited_generalize rv typ;
+
+  (* Check the abbreviation for the object type *)
+  let (obj_params', obj_type) = Ctype.instance_class params typ in
+  let constr = Ctype.newconstr (Path.Pident obj_id) obj_params in
+  begin
+    let ty = Ctype.self_type obj_type in
+    Ctype.hide_private_methods ty;
+    if not (Ctype.close_object ty) then
+      raise(Error(cl.pci_loc, env, Closing_self_type ty));
+    begin try
+      List.iter2 (Ctype.unify env) obj_params obj_params'
+    with Ctype.Unify _ ->
+      raise(Error(cl.pci_loc, env,
+            Bad_parameters (obj_id, constr,
+                            Ctype.newconstr (Path.Pident obj_id)
+                                            obj_params')))
+    end;
+    begin try
+      Ctype.unify env ty constr
+    with Ctype.Unify _ ->
+      raise(Error(cl.pci_loc, env,
+        Abbrev_type_clash (constr, ty, Ctype.expand_head env constr)))
+    end
+  end;
+
+  (* Check the other temporary abbreviation (#-type) *)
+  begin
+    let (cl_params', cl_type) = Ctype.instance_class params typ in
+    let ty = Ctype.self_type cl_type in
+    Ctype.hide_private_methods ty;
+    Ctype.set_object_name obj_id (Ctype.row_variable ty) cl_params ty;
+    begin try
+      List.iter2 (Ctype.unify env) cl_params cl_params'
+    with Ctype.Unify _ ->
+      raise(Error(cl.pci_loc, env,
+            Bad_parameters (cl_id,
+                            Ctype.newconstr (Path.Pident cl_id)
+                                            cl_params,
+                            Ctype.newconstr (Path.Pident cl_id)
+                                            cl_params')))
+    end;
+    begin try
+      Ctype.unify env ty cl_ty
+    with Ctype.Unify _ ->
+      let constr = Ctype.newconstr (Path.Pident cl_id) params in
+      raise(Error(cl.pci_loc, env, Abbrev_type_clash (constr, ty, cl_ty)))
+    end
+  end;
+
+  (* Type of the class constructor *)
+  begin try
+    Ctype.unify env
+      (constructor_type constr obj_type)
+      (Ctype.instance constr_type)
+  with Ctype.Unify trace ->
+    raise(Error(cl.pci_loc, env,
+                Constructor_type_mismatch (cl.pci_name.txt, trace)))
+  end;
+
+  (* Class and class type temporary definitions *)
+  let cty_variance =
+    Variance.unknown_signature ~injective:false ~arity:(List.length params) in
+  let cltydef =
+    {clty_params = params; clty_type = class_body typ;
+     clty_variance = cty_variance;
+     clty_path = Path.Pident obj_id;
+     clty_loc = cl.pci_loc;
+     clty_attributes = cl.pci_attributes;
+     clty_uid = dummy_class.cty_uid;
+    }
+  and clty =
+    {cty_params = params; cty_type = typ;
+     cty_variance = cty_variance;
+     cty_path = Path.Pident obj_id;
+     cty_new =
+       begin match cl.pci_virt with
+       | Virtual  -> None
+       | Concrete -> Some constr_type
+       end;
+     cty_loc = cl.pci_loc;
+     cty_attributes = cl.pci_attributes;
+     cty_uid = dummy_class.cty_uid;
+    }
+  in
+  dummy_class.cty_type <- typ;
+  let env =
+    Env.add_cltype ty_id cltydef (
+    if define_class then Env.add_class id clty env else env)
+  in
+
+  if cl.pci_virt = Concrete then begin
+    let sign = Ctype.signature_of_class_type typ in
+    let mets = virtual_methods sign in
+    let vals =
+      Vars.fold
+        (fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l)
+        sign.csig_vars [] in
+    if mets <> []  || vals <> [] then
+      raise(Error(cl.pci_loc, env, Virtual_class(define_class, false, mets,
+                                                 vals)));
+  end;
+
+  (* Misc. *)
+  let arity = Ctype.class_type_arity typ in
+  let pub_meths =
+    let (fields, _) =
+      Ctype.flatten_fields (Ctype.object_fields (Ctype.expand_head env obj_ty))
+    in
+    List.map (function (lab, _, _) -> lab) fields
+  in
+
+  (* Final definitions *)
+  let (params', typ') = Ctype.instance_class params typ in
+  let cltydef =
+    {clty_params = params'; clty_type = class_body typ';
+     clty_variance = cty_variance;
+     clty_path = Path.Pident obj_id;
+     clty_loc = cl.pci_loc;
+     clty_attributes = cl.pci_attributes;
+     clty_uid = dummy_class.cty_uid;
+    }
+  and clty =
+    {cty_params = params'; cty_type = typ';
+     cty_variance = cty_variance;
+     cty_path = Path.Pident obj_id;
+     cty_new =
+       begin match cl.pci_virt with
+       | Virtual  -> None
+       | Concrete -> Some (Ctype.instance constr_type)
+       end;
+     cty_loc = cl.pci_loc;
+     cty_attributes = cl.pci_attributes;
+     cty_uid = dummy_class.cty_uid;
+    }
+  in
+  let obj_abbr =
+    let arity = List.length obj_params in
+    {
+     type_params = obj_params;
+     type_arity = arity;
+     type_kind = Type_abstract;
+     type_private = Public;
+     type_manifest = Some obj_ty;
+     type_variance = Variance.unknown_signature ~injective:false ~arity;
+     type_separability = Types.Separability.default_signature ~arity;
+     type_is_newtype = false;
+     type_expansion_scope = Btype.lowest_level;
+     type_loc = cl.pci_loc;
+     type_attributes = []; (* or keep attrs from cl? *)
+     type_immediate = Unknown;
+     type_unboxed = unboxed_false_default_false;
+     type_uid = dummy_class.cty_uid;
+    }
+  in
+  let (cl_params, cl_ty) =
+    Ctype.instance_parameterized_type params (Ctype.self_type typ)
+  in
+  Ctype.hide_private_methods cl_ty;
+  Ctype.set_object_name obj_id (Ctype.row_variable cl_ty) cl_params cl_ty;
+  let cl_abbr =
+    let arity = List.length cl_params in
+    {
+     type_params = cl_params;
+     type_arity = arity;
+     type_kind = Type_abstract;
+     type_private = Public;
+     type_manifest = Some cl_ty;
+     type_variance = Variance.unknown_signature ~injective:false ~arity;
+     type_separability = Types.Separability.default_signature ~arity;
+     type_is_newtype = false;
+     type_expansion_scope = Btype.lowest_level;
+     type_loc = cl.pci_loc;
+     type_attributes = []; (* or keep attrs from cl? *)
+     type_immediate = Unknown;
+     type_unboxed = unboxed_false_default_false;
+     type_uid = dummy_class.cty_uid;
+    }
+  in
+  ((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params,
+    arity, pub_meths, List.rev !coercion_locs, expr) :: res,
+   env)
+
+let final_decl env define_class
+    (cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params,
+     arity, pub_meths, coe, expr) =
+
+  begin try Ctype.collapse_conj_params env clty.cty_params
+  with Ctype.Unify trace ->
+    raise(Error(cl.pci_loc, env, Non_collapsable_conjunction (id, clty, trace)))
+  end;
+
+  (* make the dummy method disappear *)
+  begin
+    let self_type = Ctype.self_type clty.cty_type in
+    let methods, _ =
+      Ctype.flatten_fields
+        (Ctype.object_fields (Ctype.expand_head env self_type))
+    in
+    List.iter (fun (lab,kind,_) ->
+      if lab = dummy_method then
+        match Btype.field_kind_repr kind with
+          Fvar r -> Btype.set_kind r Fabsent
+        | _ -> ()
+    ) methods
+  end;
+
+  List.iter Ctype.generalize clty.cty_params;
+  generalize_class_type true clty.cty_type;
+  Option.iter  Ctype.generalize clty.cty_new;
+  List.iter Ctype.generalize obj_abbr.type_params;
+  Option.iter  Ctype.generalize obj_abbr.type_manifest;
+  List.iter Ctype.generalize cl_abbr.type_params;
+  Option.iter  Ctype.generalize cl_abbr.type_manifest;
+
+  if not (closed_class clty) then
+    raise(Error(cl.pci_loc, env, Non_generalizable_class (id, clty)));
+
+  begin match
+    Ctype.closed_class clty.cty_params
+      (Ctype.signature_of_class_type clty.cty_type)
+  with
+    None        -> ()
+  | Some reason ->
+      let printer =
+        if define_class
+        then function ppf -> Printtyp.class_declaration id ppf clty
+        else function ppf -> Printtyp.cltype_declaration id ppf cltydef
+      in
+      raise(Error(cl.pci_loc, env, Unbound_type_var(printer, reason)))
+  end;
+  { id; clty; ty_id; cltydef; obj_id; obj_abbr; cl_id; cl_abbr; arity;
+    pub_meths; coe; expr;
+    id_loc = cl.pci_name;
+    req = { ci_loc = cl.pci_loc;
+            ci_virt = cl.pci_virt;
+            ci_params = ci_params;
+        (* TODO : check that we have the correct use of identifiers *)
+            ci_id_name = cl.pci_name;
+            ci_id_class = id;
+            ci_id_class_type = ty_id;
+            ci_id_object = obj_id;
+            ci_id_typehash = cl_id;
+            ci_expr = expr;
+            ci_decl = clty;
+            ci_type_decl = cltydef;
+            ci_attributes = cl.pci_attributes;
+        }
+  }
+(*   (cl.pci_variance, cl.pci_loc)) *)
+
+let class_infos define_class kind
+    (cl, id, ty_id,
+     obj_id, obj_params, obj_ty,
+     cl_id, cl_params, cl_ty,
+     constr_type, dummy_class)
+    (res, env) =
+  Builtin_attributes.warning_scope cl.pci_attributes
+    (fun () ->
+       class_infos define_class kind
+         (cl, id, ty_id,
+          obj_id, obj_params, obj_ty,
+          cl_id, cl_params, cl_ty,
+          constr_type, dummy_class)
+         (res, env)
+    )
+
+let extract_type_decls { clty; cltydef; obj_id; obj_abbr; cl_abbr; req} decls =
+  (obj_id, obj_abbr, cl_abbr, clty, cltydef, req) :: decls
+
+let merge_type_decls decl (obj_abbr, cl_abbr, clty, cltydef) =
+  {decl with obj_abbr; cl_abbr; clty; cltydef}
+
+let final_env define_class env { id; clty; ty_id; cltydef; obj_id; obj_abbr;
+    cl_id; cl_abbr } =
+  (* Add definitions after cleaning them *)
+  Env.add_type ~check:true obj_id
+    (Subst.type_declaration Subst.identity obj_abbr) (
+  Env.add_type ~check:true cl_id
+    (Subst.type_declaration Subst.identity cl_abbr) (
+  Env.add_cltype ty_id (Subst.cltype_declaration Subst.identity cltydef) (
+  if define_class then
+    Env.add_class id (Subst.class_declaration Subst.identity clty) env
+  else env)))
+
+(* Check that #c is coercible to c if there is a self-coercion *)
+let check_coercions env { id; id_loc; clty; ty_id; cltydef; obj_id; obj_abbr;
+    cl_id; cl_abbr; arity; pub_meths; coe; req } =
+  begin match coe with [] -> ()
+  | loc :: _ ->
+      let cl_ty, obj_ty =
+        match cl_abbr.type_manifest, obj_abbr.type_manifest with
+          Some cl_ab, Some obj_ab ->
+            let cl_params, cl_ty =
+              Ctype.instance_parameterized_type cl_abbr.type_params cl_ab
+            and obj_params, obj_ty =
+              Ctype.instance_parameterized_type obj_abbr.type_params obj_ab
+            in
+            List.iter2 (Ctype.unify env) cl_params obj_params;
+            cl_ty, obj_ty
+        | _ -> assert false
+      in
+      begin try Ctype.subtype env cl_ty obj_ty ()
+      with Ctype.Subtype (tr1, tr2) ->
+        raise(Typecore.Error(loc, env, Typecore.Not_subtype(tr1, tr2)))
+      end;
+      if not (Ctype.opened_object cl_ty) then
+        raise(Error(loc, env, Cannot_coerce_self obj_ty))
+  end;
+  {cls_id = id;
+   cls_id_loc = id_loc;
+   cls_decl = clty;
+   cls_ty_id = ty_id;
+   cls_ty_decl = cltydef;
+   cls_obj_id = obj_id;
+   cls_obj_abbr = obj_abbr;
+   cls_typesharp_id = cl_id;
+   cls_abbr = cl_abbr;
+   cls_arity = arity;
+   cls_pub_methods = pub_meths;
+   cls_info=req}
+
+(*******************************)
+
+let type_classes define_class approx kind env cls =
+  let scope = Ctype.create_scope () in
+  let cls =
+    List.map
+      (function cl ->
+         (cl,
+          Ident.create_scoped ~scope cl.pci_name.txt,
+          Ident.create_scoped ~scope cl.pci_name.txt,
+          Ident.create_scoped ~scope cl.pci_name.txt,
+          Ident.create_scoped ~scope ("#" ^ cl.pci_name.txt),
+          Uid.mk ~current_unit:(Env.get_unit_name ())
+         ))
+      cls
+  in
+  Ctype.begin_class_def ();
+  let (res, env) =
+    List.fold_left (initial_env define_class approx) ([], env) cls
+  in
+  let (res, env) =
+    List.fold_right (class_infos define_class kind) res ([], env)
+  in
+  Ctype.end_def ();
+  let res = List.rev_map (final_decl env define_class) res in
+  let decls = List.fold_right extract_type_decls res [] in
+  let decls =
+    try Typedecl_variance.update_class_decls env decls
+    with Typedecl_variance.Error(loc, err) ->
+      raise (Typedecl.Error(loc, Typedecl.Variance err))
+  in
+  let res = List.map2 merge_type_decls res decls in
+  let env = List.fold_left (final_env define_class) env res in
+  let res = List.map (check_coercions env) res in
+  (res, env)
+
+let class_num = ref 0
+let class_declaration env sexpr =
+  incr class_num;
+  let expr = class_expr (Int.to_string !class_num) env env sexpr in
+  (expr, expr.cl_type)
+
+let class_description env sexpr =
+  let expr = class_type env sexpr in
+  (expr, expr.cltyp_type)
+
+let class_declarations env cls =
+  let info, env =
+    type_classes true approx_declaration class_declaration env cls
+  in
+  let ids, exprs =
+    List.split
+      (List.map
+         (fun ci -> ci.cls_id, ci.cls_info.ci_expr)
+         info)
+  in
+  check_recursive_class_bindings env ids exprs;
+  info, env
+
+let class_descriptions env cls =
+  type_classes true approx_description class_description env cls
+
+let class_type_declarations env cls =
+  let (decls, env) =
+    type_classes false approx_description class_description env cls
+  in
+  (List.map
+     (fun decl ->
+        {clsty_ty_id = decl.cls_ty_id;
+         clsty_id_loc = decl.cls_id_loc;
+         clsty_ty_decl = decl.cls_ty_decl;
+         clsty_obj_id = decl.cls_obj_id;
+         clsty_obj_abbr = decl.cls_obj_abbr;
+         clsty_typesharp_id = decl.cls_typesharp_id;
+         clsty_abbr = decl.cls_abbr;
+         clsty_info = decl.cls_info})
+     decls,
+   env)
+
+let rec unify_parents env ty cl =
+  match cl.cl_desc with
+    Tcl_ident (p, _, _) ->
+      begin try
+        let decl = Env.find_class p env in
+        let _, body = Ctype.find_cltype_for_path env decl.cty_path in
+        Ctype.unify env ty (Ctype.instance body)
+      with
+        Not_found -> ()
+      | _exn -> assert false
+      end
+  | Tcl_structure st -> unify_parents_struct env ty st
+  | Tcl_open (_, cl)
+  | Tcl_fun (_, _, _, cl, _)
+  | Tcl_apply (cl, _)
+  | Tcl_let (_, _, _, cl)
+  | Tcl_constraint (cl, _, _, _, _) -> unify_parents env ty cl
+and unify_parents_struct env ty st =
+  List.iter
+    (function
+      | {cf_desc = Tcf_inherit (_, cl, _, _, _)} ->
+          unify_parents env ty cl
+      | _ -> ())
+    st.cstr_fields
+
+let type_object env loc s =
+  incr class_num;
+  let (desc, sign) =
+    class_structure (Int.to_string !class_num) true env env loc s in
+  let sty = Ctype.expand_head env sign.csig_self in
+  Ctype.hide_private_methods sty;
+  let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in
+  let meths = List.map (fun (s,_,_) -> s) fields in
+  unify_parents_struct env sign.csig_self desc;
+  (desc, sign, meths)
+
+let () =
+  Typecore.type_object := type_object
+
+(*******************************)
+
+(* Approximate the class declaration as class ['params] id = object end *)
+let approx_class sdecl =
+  let open Ast_helper in
+  let self' = Typ.any () in
+  let clty' = Cty.signature ~loc:sdecl.pci_expr.pcty_loc (Csig.mk self' []) in
+  { sdecl with pci_expr = clty' }
+
+let approx_class_declarations env sdecls =
+  fst (class_type_declarations env (List.map approx_class sdecls))
+
+(*******************************)
+
+(* Error report *)
+
+open Format
+
+let report_error env ppf = function
+  | Repeated_parameter ->
+      fprintf ppf "A type parameter occurs several times"
+  | Unconsistent_constraint trace ->
+      fprintf ppf "The class constraints are not consistent.@.";
+      Printtyp.report_unification_error ppf env trace
+        (fun ppf -> fprintf ppf "Type")
+        (fun ppf -> fprintf ppf "is not compatible with type")
+  | Field_type_mismatch (k, m, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "The %s %s@ has type" k m)
+        (function ppf ->
+           fprintf ppf "but is expected to have type")
+  | Structure_expected clty ->
+      fprintf ppf
+        "@[This class expression is not a class structure; it has type@ %a@]"
+        Printtyp.class_type clty
+  | Cannot_apply _ ->
+      fprintf ppf
+        "This class expression is not a class function, it cannot be applied"
+  | Apply_wrong_label l ->
+      let mark_label = function
+        | Nolabel -> "out label"
+        |  l -> sprintf " label %s" (Btype.prefixed_label_name l) in
+      fprintf ppf "This argument cannot be applied with%s" (mark_label l)
+  | Pattern_type_clash ty ->
+      (* XXX Trace *)
+      (* XXX Revoir message d'erreur | Improve error message *)
+      fprintf ppf "@[%s@ %a@]"
+        "This pattern cannot match self: it only matches values of type"
+        Printtyp.type_expr ty
+  | Unbound_class_2 cl ->
+      fprintf ppf "@[The class@ %a@ is not yet completely defined@]"
+      Printtyp.longident cl
+  | Unbound_class_type_2 cl ->
+      fprintf ppf "@[The class type@ %a@ is not yet completely defined@]"
+      Printtyp.longident cl
+  | Abbrev_type_clash (abbrev, actual, expected) ->
+      (* XXX Afficher une trace ? | Print a trace? *)
+      Printtyp.reset_and_mark_loops_list [abbrev; actual; expected];
+      fprintf ppf "@[The abbreviation@ %a@ expands to type@ %a@ \
+       but is used with type@ %a@]"
+        !Oprint.out_type (Printtyp.tree_of_typexp false abbrev)
+        !Oprint.out_type (Printtyp.tree_of_typexp false actual)
+        !Oprint.out_type (Printtyp.tree_of_typexp false expected)
+  | Constructor_type_mismatch (c, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "The expression \"new %s\" has type" c)
+        (function ppf ->
+           fprintf ppf "but is used with type")
+  | Virtual_class (cl, imm, mets, vals) ->
+      let print_mets ppf mets =
+        List.iter (function met -> fprintf ppf "@ %s" met) mets in
+      let missings =
+        match mets, vals with
+          [], _ -> "variables"
+        | _, [] -> "methods"
+        | _ -> "methods and variables"
+      in
+      let print_msg ppf =
+        if imm then fprintf ppf "This object has virtual %s" missings
+        else if cl then fprintf ppf "This class should be virtual"
+        else fprintf ppf "This class type should be virtual"
+      in
+      fprintf ppf
+        "@[%t.@ @[<2>The following %s are undefined :%a@]@]"
+        print_msg missings print_mets (mets @ vals)
+  | Parameter_arity_mismatch(lid, expected, provided) ->
+      fprintf ppf
+        "@[The class constructor %a@ expects %i type argument(s),@ \
+           but is here applied to %i type argument(s)@]"
+        Printtyp.longident lid expected provided
+  | Parameter_mismatch trace ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "The type parameter")
+        (function ppf ->
+           fprintf ppf "does not meet its constraint: it should be")
+  | Bad_parameters (id, params, cstrs) ->
+      Printtyp.reset_and_mark_loops_list [params; cstrs];
+      fprintf ppf
+        "@[The abbreviation %a@ is used with parameters@ %a@ \
+           which are incompatible with constraints@ %a@]"
+        Printtyp.ident id
+        !Oprint.out_type (Printtyp.tree_of_typexp false params)
+        !Oprint.out_type (Printtyp.tree_of_typexp false cstrs)
+  | Class_match_failure error ->
+      Includeclass.report_error ppf error
+  | Unbound_val lab ->
+      fprintf ppf "Unbound instance variable %s" lab
+  | Unbound_type_var (printer, reason) ->
+      let print_common ppf kind ty0 real lab ty =
+        let ty1 =
+          if real then ty0 else Btype.newgenty(Tobject(ty0, ref None)) in
+        List.iter Printtyp.mark_loops [ty; ty1];
+        fprintf ppf
+          "The %s %s@ has type@;<1 2>%a@ where@ %a@ is unbound"
+          kind lab
+          !Oprint.out_type (Printtyp.tree_of_typexp false ty)
+          !Oprint.out_type (Printtyp.tree_of_typexp false ty0)
+      in
+      let print_reason ppf = function
+      | Ctype.CC_Method (ty0, real, lab, ty) ->
+          print_common ppf "method" ty0 real lab ty
+      | Ctype.CC_Value (ty0, real, lab, ty) ->
+          print_common ppf "instance variable" ty0 real lab ty
+      in
+      Printtyp.reset ();
+      fprintf ppf
+        "@[<v>@[Some type variables are unbound in this type:@;<1 2>%t@]@ \
+              @[%a@]@]"
+       printer print_reason reason
+  | Non_generalizable_class (id, clty) ->
+      fprintf ppf
+        "@[The type of this class,@ %a,@ \
+           contains type variables that cannot be generalized@]"
+        (Printtyp.class_declaration id) clty
+  | Cannot_coerce_self ty ->
+      fprintf ppf
+        "@[The type of self cannot be coerced to@ \
+           the type of the current class:@ %a.@.\
+           Some occurrences are contravariant@]"
+        Printtyp.type_scheme ty
+  | Non_collapsable_conjunction (id, clty, trace) ->
+      fprintf ppf
+        "@[The type of this class,@ %a,@ \
+           contains non-collapsible conjunctive types in constraints.@ %t@]"
+        (Printtyp.class_declaration id) clty
+        (fun ppf -> Printtyp.report_unification_error ppf env trace
+            (fun ppf -> fprintf ppf "Type")
+            (fun ppf -> fprintf ppf "is not compatible with type")
+        )
+  | Final_self_clash trace ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "This object is expected to have type")
+        (function ppf ->
+           fprintf ppf "but actually has type")
+  | Mutability_mismatch (_lab, mut) ->
+      let mut1, mut2 =
+        if mut = Immutable then "mutable", "immutable"
+        else "immutable", "mutable" in
+      fprintf ppf
+        "@[The instance variable is %s;@ it cannot be redefined as %s@]"
+        mut1 mut2
+  | No_overriding (_, "") ->
+      fprintf ppf "@[This inheritance does not override any method@ %s@]"
+        "instance variable"
+  | No_overriding (kind, name) ->
+      fprintf ppf "@[The %s `%s'@ has no previous definition@]" kind name
+  | Duplicate (kind, name) ->
+      fprintf ppf "@[The %s `%s'@ has multiple definitions in this object@]"
+                    kind name
+  | Closing_self_type self ->
+    fprintf ppf
+      "@[Cannot close type of object literal:@ %a@,\
+       it has been unified with the self type of a class that is not yet@ \
+       completely defined.@]"
+      Printtyp.type_scheme self
+
+let report_error env ppf err =
+  Printtyp.wrap_printing_env ~error:true
+    env (fun () -> report_error env ppf err)
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, env, err) ->
+        Some (Location.error_of_printer ~loc (report_error env) err)
+      | Error_forward err ->
+        Some err
+      | _ ->
+        None
+    )
diff --git a/upstream/ocaml_412/typing/typeclass.mli b/upstream/ocaml_412/typing/typeclass.mli
new file mode 100644
index 0000000..c350352
--- /dev/null
+++ b/upstream/ocaml_412/typing/typeclass.mli
@@ -0,0 +1,130 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Types
+open Format
+
+type 'a class_info = {
+  cls_id : Ident.t;
+  cls_id_loc : string loc;
+  cls_decl : class_declaration;
+  cls_ty_id : Ident.t;
+  cls_ty_decl : class_type_declaration;
+  cls_obj_id : Ident.t;
+  cls_obj_abbr : type_declaration;
+  cls_typesharp_id : Ident.t;
+  cls_abbr : type_declaration;
+  cls_arity : int;
+  cls_pub_methods : string list;
+  cls_info : 'a;
+}
+
+type class_type_info = {
+  clsty_ty_id : Ident.t;
+  clsty_id_loc : string loc;
+  clsty_ty_decl : class_type_declaration;
+  clsty_obj_id : Ident.t;
+  clsty_obj_abbr : type_declaration;
+  clsty_typesharp_id : Ident.t;
+  clsty_abbr : type_declaration;
+  clsty_info : Typedtree.class_type_declaration;
+}
+
+val class_declarations:
+  Env.t -> Parsetree.class_declaration list ->
+  Typedtree.class_declaration class_info list * Env.t
+
+(*
+and class_declaration =
+  (class_expr, Types.class_declaration) class_infos
+*)
+
+val class_descriptions:
+  Env.t -> Parsetree.class_description list ->
+  Typedtree.class_description class_info list * Env.t
+
+(*
+and class_description =
+  (class_type, unit) class_infos
+*)
+
+val class_type_declarations:
+  Env.t -> Parsetree.class_description list -> class_type_info list * Env.t
+
+(*
+and class_type_declaration =
+  (class_type, Types.class_type_declaration) class_infos
+*)
+
+val approx_class_declarations:
+  Env.t -> Parsetree.class_description list -> class_type_info list
+
+val virtual_methods: Types.class_signature -> label list
+
+(*
+val type_classes :
+           bool ->
+           ('a -> Types.type_expr) ->
+           (Env.t -> 'a -> 'b * Types.class_type) ->
+           Env.t ->
+           'a Parsetree.class_infos list ->
+  (  Ident.t * Types.class_declaration *
+     Ident.t * Types.class_type_declaration *
+     Ident.t * Types.type_declaration *
+     Ident.t * Types.type_declaration *
+     int * string list * 'b * 'b Typedtree.class_infos)
+           list * Env.t
+*)
+
+type error =
+    Unconsistent_constraint of Ctype.Unification_trace.t
+  | Field_type_mismatch of string * string * Ctype.Unification_trace.t
+  | Structure_expected of class_type
+  | Cannot_apply of class_type
+  | Apply_wrong_label of arg_label
+  | Pattern_type_clash of type_expr
+  | Repeated_parameter
+  | Unbound_class_2 of Longident.t
+  | Unbound_class_type_2 of Longident.t
+  | Abbrev_type_clash of type_expr * type_expr * type_expr
+  | Constructor_type_mismatch of string * Ctype.Unification_trace.t
+  | Virtual_class of bool * bool * string list * string list
+  | Parameter_arity_mismatch of Longident.t * int * int
+  | Parameter_mismatch of Ctype.Unification_trace.t
+  | Bad_parameters of Ident.t * type_expr * type_expr
+  | Class_match_failure of Ctype.class_match_failure list
+  | Unbound_val of string
+  | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure
+  | Non_generalizable_class of Ident.t * Types.class_declaration
+  | Cannot_coerce_self of type_expr
+  | Non_collapsable_conjunction of
+      Ident.t * Types.class_declaration * Ctype.Unification_trace.t
+  | Final_self_clash of Ctype.Unification_trace.t
+  | Mutability_mismatch of string * mutable_flag
+  | No_overriding of string * string
+  | Duplicate of string * string
+  | Closing_self_type of type_expr
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+val report_error : Env.t -> formatter -> error -> unit
+
+(* Forward decl filled in by Typemod.type_open_descr *)
+val type_open_descr :
+  (?used_slot:bool ref ->
+   Env.t -> Parsetree.open_description -> Typedtree.open_description * Env.t)
+    ref
diff --git a/upstream/ocaml_412/typing/typecore.ml b/upstream/ocaml_412/typing/typecore.ml
new file mode 100644
index 0000000..2c17714
--- /dev/null
+++ b/upstream/ocaml_412/typing/typecore.ml
@@ -0,0 +1,5591 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Typechecking for the core language *)
+
+open Misc
+open Asttypes
+open Parsetree
+open Types
+open Typedtree
+open Btype
+open Ctype
+
+type type_forcing_context =
+  | If_conditional
+  | If_no_else_branch
+  | While_loop_conditional
+  | While_loop_body
+  | For_loop_start_index
+  | For_loop_stop_index
+  | For_loop_body
+  | Assert_condition
+  | Sequence_left_hand_side
+  | When_guard
+
+type type_expected = {
+  ty: type_expr;
+  explanation: type_forcing_context option;
+}
+
+module Datatype_kind = struct
+  type t = Record | Variant
+
+  let type_name = function
+    | Record -> "record"
+    | Variant -> "variant"
+
+  let label_name = function
+    | Record -> "field"
+    | Variant -> "constructor"
+end
+
+type wrong_name = {
+  type_path: Path.t;
+  kind: Datatype_kind.t;
+  name: string loc;
+  valid_names: string list;
+}
+
+type existential_restriction =
+  | At_toplevel (** no existential types at the toplevel *)
+  | In_group (** nor with let ... and ... *)
+  | In_rec (** or recursive definition *)
+  | With_attributes (** or let[@any_attribute] = ... *)
+  | In_class_args (** or in class arguments *)
+  | In_class_def  (** or in [class c = let ... in ...] *)
+  | In_self_pattern (** or in self pattern *)
+
+type error =
+  | Constructor_arity_mismatch of Longident.t * int * int
+  | Label_mismatch of Longident.t * Ctype.Unification_trace.t
+  | Pattern_type_clash :
+      Ctype.Unification_trace.t * _ pattern_desc option -> error
+  | Or_pattern_type_clash of Ident.t * Ctype.Unification_trace.t
+  | Multiply_bound_variable of string
+  | Orpat_vars of Ident.t * Ident.t list
+  | Expr_type_clash of
+      Ctype.Unification_trace.t * type_forcing_context option
+      * expression_desc option
+  | Apply_non_function of type_expr
+  | Apply_wrong_label of arg_label * type_expr * bool
+  | Label_multiply_defined of string
+  | Label_missing of Ident.t list
+  | Label_not_mutable of Longident.t
+  | Wrong_name of string * type_expected * wrong_name
+  | Name_type_mismatch of
+      Datatype_kind.t * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list
+  | Invalid_format of string
+  | Undefined_method of type_expr * string * string list option
+  | Undefined_inherited_method of string * string list
+  | Virtual_class of Longident.t
+  | Private_type of type_expr
+  | Private_label of Longident.t * type_expr
+  | Private_constructor of constructor_description * type_expr
+  | Unbound_instance_variable of string * string list
+  | Instance_variable_not_mutable of string
+  | Not_subtype of Ctype.Unification_trace.t * Ctype.Unification_trace.t
+  | Outside_class
+  | Value_multiply_overridden of string
+  | Coercion_failure of
+      type_expr * type_expr * Ctype.Unification_trace.t * bool
+  | Too_many_arguments of bool * type_expr * type_forcing_context option
+  | Abstract_wrong_label of arg_label * type_expr * type_forcing_context option
+  | Scoping_let_module of string * type_expr
+  | Not_a_variant_type of Longident.t
+  | Incoherent_label_order
+  | Less_general of string * Ctype.Unification_trace.t
+  | Modules_not_allowed
+  | Cannot_infer_signature
+  | Not_a_packed_module of type_expr
+  | Unexpected_existential of existential_restriction * string * string list
+  | Invalid_interval
+  | Invalid_for_loop_index
+  | No_value_clauses
+  | Exception_pattern_disallowed
+  | Mixed_value_and_exception_patterns_under_guard
+  | Inlined_record_escape
+  | Inlined_record_expected
+  | Unrefuted_pattern of pattern
+  | Invalid_extension_constructor_payload
+  | Not_an_extension_constructor
+  | Literal_overflow of string
+  | Unknown_literal of string * char
+  | Illegal_letrec_pat
+  | Illegal_letrec_expr
+  | Illegal_class_expr
+  | Letop_type_clash of string * Ctype.Unification_trace.t
+  | Andop_type_clash of string * Ctype.Unification_trace.t
+  | Bindings_type_clash of Ctype.Unification_trace.t
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+(* Forward declaration, to be filled in by Typemod.type_module *)
+
+let type_module =
+  ref ((fun _env _md -> assert false) :
+       Env.t -> Parsetree.module_expr -> Typedtree.module_expr)
+
+(* Forward declaration, to be filled in by Typemod.type_open *)
+
+let type_open :
+  (?used_slot:bool ref -> override_flag -> Env.t -> Location.t ->
+   Longident.t loc -> Path.t * Env.t)
+    ref =
+  ref (fun ?used_slot:_ _ -> assert false)
+
+let type_open_decl :
+  (?used_slot:bool ref -> Env.t -> Parsetree.open_declaration
+   -> open_declaration * Types.signature * Env.t)
+    ref =
+  ref (fun ?used_slot:_ _ -> assert false)
+
+(* Forward declaration, to be filled in by Typemod.type_package *)
+
+let type_package =
+  ref (fun _ -> assert false)
+
+(* Forward declaration, to be filled in by Typeclass.class_structure *)
+let type_object =
+  ref (fun _env _s -> assert false :
+       Env.t -> Location.t -> Parsetree.class_structure ->
+         Typedtree.class_structure * Types.class_signature * string list)
+
+(*
+  Saving and outputting type information.
+  We keep these function names short, because they have to be
+  called each time we create a record of type [Typedtree.expression]
+  or [Typedtree.pattern] that will end up in the typed AST.
+*)
+let re node =
+  Cmt_format.add_saved_type (Cmt_format.Partial_expression node);
+  node
+;;
+let rp node =
+  Cmt_format.add_saved_type (Cmt_format.Partial_pattern (Value, node));
+  node
+;;
+let rcp node =
+  Cmt_format.add_saved_type (Cmt_format.Partial_pattern (Computation, node));
+  node
+;;
+
+
+type recarg =
+  | Allowed
+  | Required
+  | Rejected
+
+
+let mk_expected ?explanation ty = { ty; explanation; }
+
+let case lhs rhs =
+  {c_lhs = lhs; c_guard = None; c_rhs = rhs}
+
+(* Typing of constants *)
+
+let type_constant = function
+    Const_int _ -> instance Predef.type_int
+  | Const_char _ -> instance Predef.type_char
+  | Const_string _ -> instance Predef.type_string
+  | Const_float _ -> instance Predef.type_float
+  | Const_int32 _ -> instance Predef.type_int32
+  | Const_int64 _ -> instance Predef.type_int64
+  | Const_nativeint _ -> instance Predef.type_nativeint
+
+let constant : Parsetree.constant -> (Asttypes.constant, error) result =
+  function
+  | Pconst_integer (i,None) ->
+     begin
+       try Ok (Const_int (Misc.Int_literal_converter.int i))
+       with Failure _ -> Error (Literal_overflow "int")
+     end
+  | Pconst_integer (i,Some 'l') ->
+     begin
+       try Ok (Const_int32 (Misc.Int_literal_converter.int32 i))
+       with Failure _ -> Error (Literal_overflow "int32")
+     end
+  | Pconst_integer (i,Some 'L') ->
+     begin
+       try Ok (Const_int64 (Misc.Int_literal_converter.int64 i))
+       with Failure _ -> Error (Literal_overflow "int64")
+     end
+  | Pconst_integer (i,Some 'n') ->
+     begin
+       try Ok (Const_nativeint (Misc.Int_literal_converter.nativeint i))
+       with Failure _ -> Error (Literal_overflow "nativeint")
+     end
+  | Pconst_integer (i,Some c) -> Error (Unknown_literal (i, c))
+  | Pconst_char c -> Ok (Const_char c)
+  | Pconst_string (s,loc,d) -> Ok (Const_string (s,loc,d))
+  | Pconst_float (f,None)-> Ok (Const_float f)
+  | Pconst_float (f,Some c) -> Error (Unknown_literal (f, c))
+
+let constant_or_raise env loc cst =
+  match constant cst with
+  | Ok c -> c
+  | Error err -> raise (Error (loc, env, err))
+
+(* Specific version of type_option, using newty rather than newgenty *)
+
+let type_option ty =
+  newty (Tconstr(Predef.path_option,[ty], ref Mnil))
+
+let mkexp exp_desc exp_type exp_loc exp_env =
+  { exp_desc; exp_type; exp_loc; exp_env; exp_extra = []; exp_attributes = [] }
+
+let option_none env ty loc =
+  let lid = Longident.Lident "None" in
+  let cnone = Env.find_ident_constructor Predef.ident_none env in
+  mkexp (Texp_construct(mknoloc lid, cnone, [])) ty loc env
+
+let option_some env texp =
+  let lid = Longident.Lident "Some" in
+  let csome = Env.find_ident_constructor Predef.ident_some env in
+  mkexp ( Texp_construct(mknoloc lid , csome, [texp]) )
+    (type_option texp.exp_type) texp.exp_loc texp.exp_env
+
+let extract_option_type env ty =
+  match expand_head env ty with {desc = Tconstr(path, [ty], _)}
+    when Path.same path Predef.path_option -> ty
+  | _ -> assert false
+
+let extract_concrete_record env ty =
+  match extract_concrete_typedecl env ty with
+    (p0, p, {type_kind=Type_record (fields, _)}) -> (p0, p, fields)
+  | _ -> raise Not_found
+
+let extract_concrete_variant env ty =
+  match extract_concrete_typedecl env ty with
+    (p0, p, {type_kind=Type_variant cstrs}) -> (p0, p, cstrs)
+  | (p0, p, {type_kind=Type_open}) -> (p0, p, [])
+  | _ -> raise Not_found
+
+let extract_label_names env ty =
+  try
+    let (_, _,fields) = extract_concrete_record env ty in
+    List.map (fun l -> l.Types.ld_id) fields
+  with Not_found ->
+    assert false
+
+(* Typing of patterns *)
+
+(* unification inside type_exp and type_expect *)
+let unify_exp_types loc env ty expected_ty =
+  (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type
+    Printtyp.raw_type_expr expected_ty; *)
+  try
+    unify env ty expected_ty
+  with
+    Unify trace ->
+      raise(Error(loc, env, Expr_type_clash(trace, None, None)))
+  | Tags(l1,l2) ->
+      raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2)))
+
+(* level at which to create the local type declarations *)
+let gadt_equations_level = ref None
+let get_gadt_equations_level () =
+  match !gadt_equations_level with
+    Some y -> y
+  | None -> assert false
+
+let nothing_equated = TypePairs.create 0
+
+(* unification inside type_pat*)
+let unify_pat_types_return_equated_pairs ?(refine = None) loc env ty ty' =
+  try
+    match refine with
+    | Some allow_recursive ->
+        unify_gadt ~equations_level:(get_gadt_equations_level ())
+          ~allow_recursive env ty ty'
+    | None ->
+        unify !env ty ty';
+        nothing_equated
+  with
+  | Unify trace ->
+      raise(Error(loc, !env, Pattern_type_clash(trace, None)))
+  | Tags(l1,l2) ->
+      raise(Typetexp.Error(loc, !env, Typetexp.Variant_tags (l1, l2)))
+
+let unify_pat_types ?refine loc env ty ty' =
+  ignore (unify_pat_types_return_equated_pairs ?refine loc env ty ty')
+
+let unify_pat ?refine env pat expected_ty =
+  try unify_pat_types ?refine pat.pat_loc env pat.pat_type expected_ty
+  with Error (loc, env, Pattern_type_clash(trace, None)) ->
+    raise(Error(loc, env, Pattern_type_clash(trace, Some pat.pat_desc)))
+
+(* Creating new conjunctive types is not allowed when typing patterns *)
+(* make all Reither present in open variants *)
+let finalize_variant pat tag opat r =
+  let row =
+    match expand_head pat.pat_env pat.pat_type with
+      {desc = Tvariant row} -> r := row; row_repr row
+    | _ -> assert false
+  in
+  begin match row_field tag row with
+  | Rabsent -> () (* assert false *)
+  | Reither (true, [], _, e) when not row.row_closed ->
+      set_row_field e (Rpresent None)
+  | Reither (false, ty::tl, _, e) when not row.row_closed ->
+      set_row_field e (Rpresent (Some ty));
+      begin match opat with None -> assert false
+      | Some pat ->
+          let env = ref pat.pat_env in List.iter (unify_pat env pat) (ty::tl)
+      end
+  | Reither (c, _l, true, e) when not (row_fixed row) ->
+      set_row_field e (Reither (c, [], false, ref None))
+  | _ -> ()
+  end
+  (* Force check of well-formedness   WHY? *)
+  (* unify_pat pat.pat_env pat
+    (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false;
+                    row_bound=(); row_fixed=false; row_name=None})); *)
+
+let has_variants p =
+  exists_general_pattern
+    { f = fun (type k) (p : k general_pattern) -> match p.pat_desc with
+     | (Tpat_variant _) -> true
+     | _ -> false } p
+
+let finalize_variants p =
+  iter_general_pattern
+    { f = fun (type k) (p : k general_pattern) -> match p.pat_desc with
+     | Tpat_variant(tag, opat, r) ->
+        finalize_variant p tag opat r
+     | _ -> () } p
+
+(* pattern environment *)
+type pattern_variable =
+  {
+    pv_id: Ident.t;
+    pv_type: type_expr;
+    pv_loc: Location.t;
+    pv_as_var: bool;
+    pv_attributes: attributes;
+  }
+
+type module_variable =
+  string loc * Location.t
+
+let pattern_variables = ref ([] : pattern_variable list)
+let pattern_force = ref ([] : (unit -> unit) list)
+let allow_modules = ref false
+let module_variables = ref ([] : module_variable list)
+let reset_pattern allow =
+  pattern_variables := [];
+  pattern_force := [];
+  allow_modules := allow;
+  module_variables := [];
+;;
+
+let maybe_add_pattern_variables_ghost loc_let env pv =
+  List.fold_right
+    (fun {pv_id; _} env ->
+       let name = Ident.name pv_id in
+       if Env.bound_value name env then env
+       else begin
+         Env.enter_unbound_value name
+           (Val_unbound_ghost_recursive loc_let) env
+       end
+    ) pv env
+
+let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty
+    attrs =
+  if List.exists (fun {pv_id; _} -> Ident.name pv_id = name.txt)
+      !pattern_variables
+  then raise(Error(loc, Env.empty, Multiply_bound_variable name.txt));
+  let id = Ident.create_local name.txt in
+  pattern_variables :=
+    {pv_id = id;
+     pv_type = ty;
+     pv_loc = loc;
+     pv_as_var = is_as_variable;
+     pv_attributes = attrs} :: !pattern_variables;
+  if is_module then begin
+    (* Note: unpack patterns enter a variable of the same name *)
+    if not !allow_modules then
+      raise (Error (loc, Env.empty, Modules_not_allowed));
+    module_variables := (name, loc) :: !module_variables
+  end;
+  id
+
+let sort_pattern_variables vs =
+  List.sort
+    (fun {pv_id = x; _} {pv_id = y; _} ->
+      Stdlib.compare (Ident.name x) (Ident.name y))
+    vs
+
+let enter_orpat_variables loc env  p1_vs p2_vs =
+  (* unify_vars operate on sorted lists *)
+
+  let p1_vs = sort_pattern_variables p1_vs
+  and p2_vs = sort_pattern_variables p2_vs in
+
+  let rec unify_vars p1_vs p2_vs =
+    let vars vs = List.map (fun {pv_id; _} -> pv_id) vs in
+    match p1_vs, p2_vs with
+      | {pv_id = x1; pv_type = t1; _}::rem1, {pv_id = x2; pv_type = t2; _}::rem2
+        when Ident.equal x1 x2 ->
+          if x1==x2 then
+            unify_vars rem1 rem2
+          else begin
+            begin try
+              unify_var env (newvar ()) t1;
+              unify env t1 t2
+            with
+            | Unify trace ->
+                raise(Error(loc, env, Or_pattern_type_clash(x1, trace)))
+            end;
+          (x2,x1)::unify_vars rem1 rem2
+          end
+      | [],[] -> []
+      | {pv_id; _}::_, [] | [],{pv_id; _}::_ ->
+          raise (Error (loc, env, Orpat_vars (pv_id, [])))
+      | {pv_id = x; _}::_, {pv_id = y; _}::_ ->
+          let err =
+            if Ident.name x < Ident.name y
+            then Orpat_vars (x, vars p2_vs)
+            else Orpat_vars (y, vars p1_vs) in
+          raise (Error (loc, env, err)) in
+  unify_vars p1_vs p2_vs
+
+let rec build_as_type env p =
+  let as_ty = build_as_type_aux env p in
+  (* Cf. #1655 *)
+  List.fold_left (fun as_ty (extra, _loc, _attrs) ->
+    match extra with
+    | Tpat_type _ | Tpat_open _ | Tpat_unpack -> as_ty
+    | Tpat_constraint cty ->
+      begin_def ();
+      let ty = instance cty.ctyp_type in
+      end_def ();
+      generalize_structure ty;
+      (* This call to unify can't fail since the pattern is well typed. *)
+      unify !env (instance as_ty) (instance ty);
+      ty
+  ) as_ty p.pat_extra
+
+and build_as_type_aux env p =
+  match p.pat_desc with
+    Tpat_alias(p1,_, _) -> build_as_type env p1
+  | Tpat_tuple pl ->
+      let tyl = List.map (build_as_type env) pl in
+      newty (Ttuple tyl)
+  | Tpat_construct(_, cstr, pl) ->
+      let keep = cstr.cstr_private = Private || cstr.cstr_existentials <> [] in
+      if keep then p.pat_type else
+      let tyl = List.map (build_as_type env) pl in
+      let ty_args, ty_res = instance_constructor cstr in
+      List.iter2 (fun (p,ty) -> unify_pat env {p with pat_type = ty})
+        (List.combine pl tyl) ty_args;
+      ty_res
+  | Tpat_variant(l, p', _) ->
+      let ty = Option.map (build_as_type env) p' in
+      newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar();
+                      row_bound=(); row_name=None;
+                      row_fixed=None; row_closed=false})
+  | Tpat_record (lpl,_) ->
+      let lbl = snd3 (List.hd lpl) in
+      if lbl.lbl_private = Private then p.pat_type else
+      let ty = newvar () in
+      let ppl = List.map (fun (_, l, p) -> l.lbl_pos, p) lpl in
+      let do_label lbl =
+        let _, ty_arg, ty_res = instance_label false lbl in
+        unify_pat env {p with pat_type = ty} ty_res;
+        let refinable =
+          lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl &&
+          match (repr lbl.lbl_arg).desc with Tpoly _ -> false | _ -> true in
+        if refinable then begin
+          let arg = List.assoc lbl.lbl_pos ppl in
+          unify_pat env {arg with pat_type = build_as_type env arg} ty_arg
+        end else begin
+          let _, ty_arg', ty_res' = instance_label false lbl in
+          unify !env ty_arg ty_arg';
+          unify_pat env p ty_res'
+        end in
+      Array.iter do_label lbl.lbl_all;
+      ty
+  | Tpat_or(p1, p2, row) ->
+      begin match row with
+        None ->
+          let ty1 = build_as_type env p1 and ty2 = build_as_type env p2 in
+          unify_pat env {p2 with pat_type = ty2} ty1;
+          ty1
+      | Some row ->
+          let row = row_repr row in
+          newty (Tvariant{row with row_closed=false; row_more=newvar()})
+      end
+  | Tpat_any | Tpat_var _ | Tpat_constant _
+  | Tpat_array _ | Tpat_lazy _ -> p.pat_type
+
+let build_or_pat env loc lid =
+  let path, decl = Env.lookup_type ~loc:lid.loc lid.txt env in
+  let tyl = List.map (fun _ -> newvar()) decl.type_params in
+  let row0 =
+    let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in
+    match ty.desc with
+      Tvariant row when static_row row -> row
+    | _ -> raise(Error(lid.loc, env, Not_a_variant_type lid.txt))
+  in
+  let pats, fields =
+    List.fold_left
+      (fun (pats,fields) (l,f) ->
+        match row_field_repr f with
+          Rpresent None ->
+            (l,None) :: pats,
+            (l, Reither(true,[], true, ref None)) :: fields
+        | Rpresent (Some ty) ->
+            (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env;
+                      pat_type=ty; pat_extra=[]; pat_attributes=[]})
+            :: pats,
+            (l, Reither(false, [ty], true, ref None)) :: fields
+        | _ -> pats, fields)
+      ([],[]) (row_repr row0).row_fields in
+  let row =
+    { row_fields = List.rev fields; row_more = newvar(); row_bound = ();
+      row_closed = false; row_fixed = None; row_name = Some (path, tyl) }
+  in
+  let ty = newty (Tvariant row) in
+  let gloc = {loc with Location.loc_ghost=true} in
+  let row' = ref {row with row_more=newvar()} in
+  let pats =
+    List.map
+      (fun (l,p) ->
+        {pat_desc=Tpat_variant(l,p,row'); pat_loc=gloc;
+         pat_env=env; pat_type=ty; pat_extra=[]; pat_attributes=[]})
+      pats
+  in
+  match pats with
+    [] ->
+      (* empty polymorphic variants: not possible with the concrete language
+         but valid at the ast level *)
+      raise(Error(lid.loc, env, Not_a_variant_type lid.txt))
+  | pat :: pats ->
+      let r =
+        List.fold_left
+          (fun pat pat0 ->
+            {pat_desc=Tpat_or(pat0,pat,Some row0); pat_extra=[];
+             pat_loc=gloc; pat_env=env; pat_type=ty; pat_attributes=[]})
+          pat pats in
+      (path, rp { r with pat_loc = loc },ty)
+
+let split_cases env cases =
+  let add_case lst case = function
+    | None -> lst
+    | Some c_lhs -> { case with c_lhs } :: lst
+  in
+  List.fold_right (fun ({ c_lhs; c_guard } as case) (vals, exns) ->
+    match split_pattern c_lhs with
+    | Some _, Some _ when c_guard <> None ->
+      raise (Error (c_lhs.pat_loc, env,
+                    Mixed_value_and_exception_patterns_under_guard))
+    | vp, ep -> add_case vals case vp, add_case exns case ep
+  ) cases ([], [])
+
+(* Type paths *)
+
+let rec expand_path env p =
+  let decl =
+    try Some (Env.find_type p env) with Not_found -> None
+  in
+  match decl with
+    Some {type_manifest = Some ty} ->
+      begin match repr ty with
+        {desc=Tconstr(p,_,_)} -> expand_path env p
+      | _ -> assert false
+      end
+  | _ ->
+      let p' = Env.normalize_type_path None env p in
+      if Path.same p p' then p else expand_path env p'
+
+let compare_type_path env tpath1 tpath2 =
+  Path.same (expand_path env tpath1) (expand_path env tpath2)
+
+(* Records *)
+exception Wrong_name_disambiguation of Env.t * wrong_name
+
+let get_constr_type_path ty =
+  match (repr ty).desc with
+  | Tconstr(p, _, _) -> p
+  | _ -> assert false
+
+module NameChoice(Name : sig
+  type t
+  type usage
+  val kind: Datatype_kind.t
+  val get_name: t -> string
+  val get_type: t -> type_expr
+  val lookup_all_from_type:
+    Location.t -> usage -> Path.t -> Env.t -> (t * (unit -> unit)) list
+
+  (** Some names (for example the fields of inline records) are not
+      in the typing environment -- they behave as structural labels
+      rather than nominal labels.*)
+  val in_env: t -> bool
+end) = struct
+  open Name
+
+  let get_type_path d = get_constr_type_path (get_type d)
+
+  let lookup_from_type env type_path usage lid =
+    let descrs = lookup_all_from_type lid.loc usage type_path env in
+    match lid.txt with
+    | Longident.Lident name -> begin
+        match
+          List.find (fun (nd, _) -> get_name nd = name) descrs
+        with
+        | descr, use ->
+            use ();
+            descr
+        | exception Not_found ->
+            let valid_names = List.map (fun (nd, _) -> get_name nd) descrs in
+            raise (Wrong_name_disambiguation (env, {
+                    type_path;
+                    name = { lid with txt = name };
+                    kind;
+                    valid_names;
+              }))
+      end
+    | _ -> raise Not_found
+
+  let rec unique eq acc = function
+      [] -> List.rev acc
+    | x :: rem ->
+        if List.exists (eq x) acc then unique eq acc rem
+        else unique eq (x :: acc) rem
+
+  let ambiguous_types env lbl others =
+    let tpath = get_type_path lbl in
+    let others =
+      List.map (fun (lbl, _) -> get_type_path lbl) others in
+    let tpaths = unique (compare_type_path env) [tpath] others in
+    match tpaths with
+      [_] -> []
+    | _ -> let open Printtyp in
+        wrap_printing_env ~error:true env (fun () ->
+            reset(); strings_of_paths Type tpaths)
+
+  let disambiguate_by_type env tpath lbls =
+    match lbls with
+    | (Error _ : _ result) -> raise Not_found
+    | Ok lbls ->
+        let check_type (lbl, _) =
+          let lbl_tpath = get_type_path lbl in
+          compare_type_path env tpath lbl_tpath
+        in
+        List.find check_type lbls
+
+  (* warn if there are several distinct candidates in scope *)
+  let warn_if_ambiguous warn lid env lbl rest =
+    Printtyp.Conflicts.reset ();
+    let paths = ambiguous_types env lbl rest in
+    let expansion =
+      Format.asprintf "%t" Printtyp.Conflicts.print_explanations in
+    if paths <> [] then
+      warn lid.loc
+        (Warnings.Ambiguous_name ([Longident.last lid.txt],
+                                  paths, false, expansion))
+
+  (* a non-principal type was used for disambiguation *)
+  let warn_non_principal warn lid =
+    let name = Datatype_kind.label_name kind in
+    warn lid.loc
+      (Warnings.Not_principal
+         ("this type-based " ^ name ^ " disambiguation"))
+
+  (* we selected a name out of the lexical scope *)
+  let warn_out_of_scope warn lid env tpath =
+    let path_s =
+      Printtyp.wrap_printing_env ~error:true env
+        (fun () -> Printtyp.string_of_path tpath) in
+    warn lid.loc
+      (Warnings.Name_out_of_scope (path_s, [Longident.last lid.txt], false))
+
+  (* warn if the selected name is not the last introduced in scope
+     -- in these cases the resolution is different from pre-disambiguation OCaml
+     (this warning is not enabled by default, it is specifically for people
+      wishing to write backward-compatible code).
+   *)
+  let warn_if_disambiguated_name warn lid lbl scope =
+    match scope with
+    | Ok ((lab1,_) :: _) when lab1 == lbl -> ()
+    | _ ->
+        warn lid.loc
+          (Warnings.Disambiguated_name (get_name lbl))
+
+  let force_error : ('a, _) result -> 'a = function
+    | Ok lbls -> lbls
+    | Error (loc', env', err) ->
+       Env.lookup_error loc' env' err
+
+  type candidate = t * (unit -> unit)
+  type nonempty_candidate_filter =
+    candidate list -> (candidate list, candidate list) result
+  (** This type is used for candidate filtering functions.
+      Filtering typically proceeds in several passes, filtering
+      candidates through increasingly precise conditions.
+
+      We assume that the input list is non-empty, and the output is one of
+      - [Ok result] for a non-empty list [result] of valid candidates
+      - [Error candidates] with there are no valid candidates,
+        and [candidates] is a non-empty subset of the input, typically
+        the result of the last non-empty filtering step.
+   *)
+
+  (** [disambiguate] selects a concrete description for [lid] using
+     some contextual information:
+     - An optional [expected_type].
+     - A list of candidates labels in the current lexical scope,
+       [candidates_in_scope], that is actually at the type
+       [(label_descr list, lookup_error) result] so that the
+       lookup error is only raised when necessary.
+     - A filtering criterion on candidates in scope [filter_candidates],
+       representing extra contextual information that can help
+       candidate selection (see [disambiguate_label_by_ids]).
+   *)
+  let disambiguate
+        ?(warn=Location.prerr_warning)
+        ?(filter : nonempty_candidate_filter = Result.ok)
+        usage lid env
+        expected_type
+        candidates_in_scope =
+    let lbl = match expected_type with
+    | None ->
+        (* no expected type => no disambiguation *)
+        begin match filter (force_error candidates_in_scope) with
+        | Ok [] | Error [] -> assert false
+        | Error((lbl, _use) :: _rest) -> lbl (* will fail later *)
+        | Ok((lbl, use) :: rest) ->
+            use ();
+            warn_if_ambiguous warn lid env lbl rest;
+            lbl
+        end
+    | Some(tpath0, tpath, principal) ->
+       (* If [expected_type] is available, the candidate selected
+          will correspond to the type-based resolution.
+          There are two reasons to still check the lexical scope:
+          - for warning purposes
+          - for extension types, the type environment does not contain
+            a list of constructors, so using only type-based selection
+            would fail.
+        *)
+        (* note that [disambiguate_by_type] does not
+           force [candidates_in_scope]: we just skip this case if there
+           are no candidates in scope *)
+        begin match disambiguate_by_type env tpath candidates_in_scope with
+        | lbl, use ->
+          use ();
+          if not principal then begin
+            (* Check if non-principal type is affecting result *)
+            match (candidates_in_scope : _ result) with
+            | Error _ -> warn_non_principal warn lid
+            | Ok lbls ->
+            match filter lbls with
+            | Error _ -> warn_non_principal warn lid
+            | Ok [] -> assert false
+            | Ok ((lbl', _use') :: rest) ->
+            let lbl_tpath = get_type_path lbl' in
+            (* no principality warning if the non-principal
+               type-based selection corresponds to the last
+               definition in scope *)
+            if not (compare_type_path env tpath lbl_tpath)
+            then warn_non_principal warn lid
+            else warn_if_ambiguous warn lid env lbl rest;
+          end;
+          lbl
+        | exception Not_found ->
+        (* look outside the lexical scope *)
+        match lookup_from_type env tpath usage lid with
+        | lbl ->
+          (* warn only on nominal labels;
+             structural labels cannot be qualified anyway *)
+          if in_env lbl then warn_out_of_scope warn lid env tpath;
+          if not principal then warn_non_principal warn lid;
+          lbl
+        | exception Not_found ->
+        match filter (force_error candidates_in_scope) with
+        | Ok lbls | Error lbls ->
+        let tp = (tpath0, expand_path env tpath) in
+        let tpl =
+          List.map
+            (fun (lbl, _) ->
+               let tp0 = get_type_path lbl in
+               let tp = expand_path env tp0 in
+               (tp0, tp))
+            lbls
+        in
+        raise (Error (lid.loc, env,
+                      Name_type_mismatch (kind, lid.txt, tp, tpl)));
+        end
+    in
+    (* warn only on nominal labels *)
+    if in_env lbl then
+      warn_if_disambiguated_name warn lid lbl candidates_in_scope;
+    lbl
+end
+
+let wrap_disambiguate msg ty f x =
+  try f x with
+  | Wrong_name_disambiguation (env, wrong_name) ->
+    raise (Error (wrong_name.name.loc, env, Wrong_name (msg, ty, wrong_name)))
+
+module Label = NameChoice (struct
+  type t = label_description
+  type usage = unit
+  let kind = Datatype_kind.Record
+  let get_name lbl = lbl.lbl_name
+  let get_type lbl = lbl.lbl_res
+  let lookup_all_from_type loc () path env =
+    Env.lookup_all_labels_from_type ~loc path env
+  let in_env lbl =
+    match lbl.lbl_repres with
+    | Record_regular | Record_float | Record_unboxed false -> true
+    | Record_unboxed true | Record_inlined _ | Record_extension _ -> false
+end)
+
+(* In record-construction expressions and patterns, we have many labels
+   at once; find a candidate type in the intersection of the candidates
+   of each label. In the [closed] expression case, this candidate must
+   contain exactly all the labels.
+
+   If our successive refinements result in an empty list,
+   return [Error] with the last non-empty list of candidates
+   for use in error messages.
+*)
+let disambiguate_label_by_ids closed ids labels  : (_, _) result =
+  let check_ids (lbl, _) =
+    let lbls = Hashtbl.create 8 in
+    Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl.lbl_all;
+    List.for_all (Hashtbl.mem lbls) ids
+  and check_closed (lbl, _) =
+    (not closed || List.length ids = Array.length lbl.lbl_all)
+  in
+  match List.filter check_ids labels with
+  | [] -> Error labels
+  | labels ->
+  match List.filter check_closed labels with
+  | [] -> Error labels
+  | labels ->
+  Ok labels
+
+(* Only issue warnings once per record constructor/pattern *)
+let disambiguate_lid_a_list loc closed env expected_type lid_a_list =
+  let ids = List.map (fun (lid, _) -> Longident.last lid.txt) lid_a_list in
+  let w_pr = ref false and w_amb = ref []
+  and w_scope = ref [] and w_scope_ty = ref "" in
+  let warn loc msg =
+    let open Warnings in
+    match msg with
+    | Not_principal _ -> w_pr := true
+    | Ambiguous_name([s], l, _, ex) -> w_amb := (s, l, ex) :: !w_amb
+    | Name_out_of_scope(ty, [s], _) ->
+        w_scope := s :: !w_scope; w_scope_ty := ty
+    | _ -> Location.prerr_warning loc msg
+  in
+  let process_label lid =
+    let scope = Env.lookup_all_labels ~loc:lid.loc lid.txt env in
+    let filter : Label.nonempty_candidate_filter =
+      disambiguate_label_by_ids closed ids in
+    Label.disambiguate ~warn ~filter () lid env expected_type scope in
+  let lbl_a_list =
+    List.map (fun (lid,a) -> lid, process_label lid, a) lid_a_list in
+  if !w_pr then
+    Location.prerr_warning loc
+      (Warnings.Not_principal "this type-based record disambiguation")
+  else begin
+    match List.rev !w_amb with
+      (_,types,ex)::_ as amb ->
+        let paths =
+          List.map (fun (_,lbl,_) -> Label.get_type_path lbl) lbl_a_list in
+        let path = List.hd paths in
+        let fst3 (x,_,_) = x in
+        if List.for_all (compare_type_path env path) (List.tl paths) then
+          Location.prerr_warning loc
+            (Warnings.Ambiguous_name (List.map fst3 amb, types, true, ex))
+        else
+          List.iter
+            (fun (s,l,ex) -> Location.prerr_warning loc
+                (Warnings.Ambiguous_name ([s],l,false, ex)))
+            amb
+    | _ -> ()
+  end;
+  if !w_scope <> [] then
+    Location.prerr_warning loc
+      (Warnings.Name_out_of_scope (!w_scope_ty, List.rev !w_scope, true));
+  lbl_a_list
+
+let rec find_record_qual = function
+  | [] -> None
+  | ({ txt = Longident.Ldot (modname, _) }, _) :: _ -> Some modname
+  | _ :: rest -> find_record_qual rest
+
+let map_fold_cont f xs k =
+  List.fold_right (fun x k ys -> f x (fun y -> k (y :: ys)))
+    xs (fun ys -> k (List.rev ys)) []
+
+let type_label_a_list
+      ?labels loc closed env type_lbl_a expected_type lid_a_list k =
+  let lbl_a_list =
+    match lid_a_list, labels with
+      ({txt=Longident.Lident s}, _)::_, Some labels when Hashtbl.mem labels s ->
+        (* Special case for rebuilt syntax trees *)
+        List.map
+          (function lid, a -> match lid.txt with
+            Longident.Lident s -> lid, Hashtbl.find labels s, a
+          | _ -> assert false)
+          lid_a_list
+    | _ ->
+        let lid_a_list =
+          match find_record_qual lid_a_list with
+            None -> lid_a_list
+          | Some modname ->
+              List.map
+                (fun (lid, a as lid_a) ->
+                  match lid.txt with Longident.Lident s ->
+                    {lid with txt=Longident.Ldot (modname, s)}, a
+                  | _ -> lid_a)
+                lid_a_list
+        in
+        disambiguate_lid_a_list loc closed env expected_type lid_a_list
+  in
+  (* Invariant: records are sorted in the typed tree *)
+  let lbl_a_list =
+    List.sort
+      (fun (_,lbl1,_) (_,lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos)
+      lbl_a_list
+  in
+  map_fold_cont type_lbl_a lbl_a_list k
+;;
+
+(* Checks over the labels mentioned in a record pattern:
+   no duplicate definitions (error); properly closed (warning) *)
+
+let check_recordpat_labels loc lbl_pat_list closed =
+  match lbl_pat_list with
+  | [] -> ()                            (* should not happen *)
+  | (_, label1, _) :: _ ->
+      let all = label1.lbl_all in
+      let defined = Array.make (Array.length all) false in
+      let check_defined (_, label, _) =
+        if defined.(label.lbl_pos)
+        then raise(Error(loc, Env.empty, Label_multiply_defined label.lbl_name))
+        else defined.(label.lbl_pos) <- true in
+      List.iter check_defined lbl_pat_list;
+      if closed = Closed
+      && Warnings.is_active (Warnings.Missing_record_field_pattern "")
+      then begin
+        let undefined = ref [] in
+        for i = 0 to Array.length all - 1 do
+          if not defined.(i) then undefined := all.(i).lbl_name :: !undefined
+        done;
+        if !undefined <> [] then begin
+          let u = String.concat ", " (List.rev !undefined) in
+          Location.prerr_warning loc (Warnings.Missing_record_field_pattern u)
+        end
+      end
+
+(* Constructors *)
+
+module Constructor = NameChoice (struct
+  type t = constructor_description
+  type usage = Env.constructor_usage
+  let kind = Datatype_kind.Variant
+  let get_name cstr = cstr.cstr_name
+  let get_type cstr = cstr.cstr_res
+  let lookup_all_from_type loc usage path env =
+    match Env.lookup_all_constructors_from_type ~loc usage path env with
+    | _ :: _ as x -> x
+    | [] ->
+        match (Env.find_type path env).type_kind with
+        | Type_open ->
+            (* Extension constructors cannot be found by looking at the type
+               declaration.
+               We scan the whole environment to get an accurate spellchecking
+               hint in the subsequent error message *)
+            let filter lbl =
+              compare_type_path env
+                path (get_constr_type_path @@ get_type lbl) in
+            let add_valid x acc = if filter x then (x,ignore)::acc else acc in
+            Env.fold_constructors add_valid None env []
+        | _ -> []
+  let in_env _ = true
+end)
+
+(* unification of a type with a tconstr with
+   freshly created arguments *)
+let unify_head_only ~refine loc env ty constr =
+  let (_, ty_res) = instance_constructor constr in
+  let ty_res = repr ty_res in
+  match ty_res.desc with
+  | Tconstr(p,args,m) ->
+      ty_res.desc <- Tconstr(p,List.map (fun _ -> newvar ()) args,m);
+      enforce_constraints !env ty_res;
+      unify_pat_types ~refine loc env ty_res ty
+  | _ -> assert false
+
+(* Typing of patterns *)
+
+(* "half typed" cases are produced in [type_cases] when we've just typechecked
+   the pattern but haven't type-checked the body yet.
+   At this point we might have added some type equalities to the environment,
+   but haven't yet added identifiers bound by the pattern. *)
+type 'case_pattern half_typed_case =
+  { typed_pat: 'case_pattern;
+    pat_type_for_unif: type_expr;
+    untyped_case: Parsetree.case;
+    branch_env: Env.t;
+    pat_vars: pattern_variable list;
+    unpacks: module_variable list;
+    contains_gadt: bool; }
+
+let rec has_literal_pattern p = match p.ppat_desc with
+  | Ppat_constant _
+  | Ppat_interval _ ->
+     true
+  | Ppat_any
+  | Ppat_variant (_, None)
+  | Ppat_construct (_, None)
+  | Ppat_type _
+  | Ppat_var _
+  | Ppat_unpack _
+  | Ppat_extension _ ->
+     false
+  | Ppat_exception p
+  | Ppat_variant (_, Some p)
+  | Ppat_construct (_, Some p)
+  | Ppat_constraint (p, _)
+  | Ppat_alias (p, _)
+  | Ppat_lazy p
+  | Ppat_open (_, p) ->
+     has_literal_pattern p
+  | Ppat_tuple ps
+  | Ppat_array ps ->
+     List.exists has_literal_pattern ps
+  | Ppat_record (ps, _) ->
+     List.exists (fun (_,p) -> has_literal_pattern p) ps
+  | Ppat_or (p, q) ->
+     has_literal_pattern p || has_literal_pattern q
+
+let check_scope_escape loc env level ty =
+  try Ctype.check_scope_escape env level ty
+  with Unify trace ->
+    raise(Error(loc, env, Pattern_type_clash(trace, None)))
+
+type pattern_checking_mode =
+  | Normal
+  (** We are checking user code. *)
+  | Counter_example of counter_example_checking_info
+  (** In [Counter_example] mode, we are checking a counter-example
+      candidate produced by Parmatch. This is a syntactic pattern that
+      represents a set of values by using or-patterns (p_1 | ... | p_n)
+      to enumerate all alternatives in the counter-example
+      search. These or-patterns occur at every choice point, possibly
+      deep inside the pattern.
+
+      Parmatch does not use type information, so this pattern may
+      exhibit two issues:
+      - some parts of the pattern may be ill-typed due to GADTs, and
+      - some wildcard patterns may not match any values: their type is
+        empty.
+
+      The aim of [type_pat] in the [Counter_example] mode is to refine
+      this syntactic pattern into a well-typed pattern, and ensure
+      that it matches at least one concrete value.
+      - It filters ill-typed branches of or-patterns.
+        (see {!splitting_mode} below)
+      - It tries to check that wildcard patterns are non-empty.
+        (see {!explosion_fuel})
+  *)
+
+and counter_example_checking_info = {
+    explosion_fuel: int;
+    splitting_mode: splitting_mode;
+    constrs: (string, Types.constructor_description) Hashtbl.t;
+    labels: (string, Types.label_description) Hashtbl.t;
+  }
+(**
+    [explosion_fuel] controls the checking of wildcard patterns.  We
+    eliminate potentially-empty wildcard patterns by exploding them
+    into concrete sub-patterns, for example (K1 _ | K2 _) or
+    { l1: _; l2: _ }. [explosion_fuel] is the depth limit on wildcard
+    explosion. Such depth limit is required to avoid non-termination
+    and compilation-time blowups.
+
+    [splitting_mode] controls the handling of or-patterns.  In
+    [Counter_example] mode, we only need to select one branch that
+    leads to a well-typed pattern. Checking all branches is expensive,
+    we use different search strategies (see {!splitting_mode}) to
+    reduce the number of explored alternatives.
+
+    [constrs] and [labels] contain metadata produced by [Parmatch] to
+    type-check the given syntactic pattern. [Parmatch] produces
+    counter-examples by turning typed patterns into
+    [Parsetree.pattern]. In this process, constructor and label paths
+    are lost, and are replaced by generated strings. [constrs] and
+    [labels] map those synthetic names back to the typed descriptions
+    of the original names.
+ *)
+
+(** Due to GADT constraints, an or-pattern produced within
+    a counter-example may have ill-typed branches. Consider for example
+
+    {[
+      type _ tag = Int : int tag | Bool : bool tag
+    ]}
+
+    then [Parmatch] will propose the or-pattern [Int | Bool] whenever
+    a pattern of type [tag] is required to form a counter-example. For
+    example, a function expects a (int tag option) and only [None] is
+    handled by the user-written pattern. [Some (Int | Bool)] is not
+    well-typed in this context, only the sub-pattern [Some Int] is.
+    In this example, the expected type coming from the context
+    suffices to know which or-pattern branch must be chosen.
+
+    In the general case, choosing a branch can have non-local effects
+    on the typability of the term. For example, consider a tuple type
+    ['a tag * ...'a...], where the first component is a GADT.  All
+    constructor choices for this GADT lead to a well-typed branch in
+    isolation (['a] is unconstrained), but choosing one of them adds
+    a constraint on ['a] that may make the other tuple elements
+    ill-typed.
+
+    In general, after choosing each possible branch of the or-pattern,
+    [type_pat] has to check the rest of the pattern to tell if this
+    choice leads to a well-typed term. This may lead to an explosion
+    of typing/search work -- the rest of the term may in turn contain
+    alternatives.
+
+    We use careful strategies to try to limit counterexample-checking
+    time; [splitting_mode] represents those strategies.
+*)
+and splitting_mode =
+  | Backtrack_or
+  (** Always backtrack in or-patterns.
+
+      [Backtrack_or] selects a single alternative from an or-pattern
+      by using backtracking, trying to choose each branch in turn, and
+      to complete it into a valid sub-pattern. We call this
+      "splitting" the or-pattern.
+
+      We use this mode when looking for unused patterns or sub-patterns,
+      in particular to check a refutation clause (p -> .).
+    *)
+  | Refine_or of { inside_nonsplit_or: bool; }
+  (** Only backtrack when needed.
+
+      [Refine_or] tries another approach for refining or-pattern.
+
+      Instead of always splitting each or-pattern, It first attempts to
+      find branches that do not introduce new constraints (because they
+      do not contain GADT constructors). Those branches are such that,
+      if they fail, all other branches will fail.
+
+      If we find one such branch, we attempt to complete the subpattern
+      (checking what's outside the or-pattern), ignoring other
+      branches -- we never consider another branch choice again. If all
+      branches are constrained, it falls back to splitting the
+      or-pattern.
+
+      We use this mode when checking exhaustivity of pattern matching.
+  *)
+
+(** This exception is only used internally within [type_pat_aux], in
+    counter-example mode, to jump back to the parent or-pattern in the
+    [Refine_or] strategy.
+
+    Such a parent exists precisely when [inside_nonsplit_or = true];
+    it's an invariant that we always setup an exception handler for
+    [Need_backtrack] when we set this flag. *)
+exception Need_backtrack
+
+(** This exception is only used internally within [type_pat_aux], in
+    counter-example mode. We use it to discard counter-example candidates
+    that do not match any value. *)
+exception Empty_branch
+
+type abort_reason = Adds_constraints | Empty
+
+(** Remember current typing state for backtracking.
+   No variable information, as we only backtrack on
+   patterns without variables (cf. assert statements). *)
+type state =
+ { snapshot: Btype.snapshot;
+   levels: Ctype.levels;
+   env: Env.t; }
+let save_state env =
+  { snapshot = Btype.snapshot ();
+    levels = Ctype.save_levels ();
+    env = !env; }
+let set_state s env =
+  Btype.backtrack s.snapshot;
+  Ctype.set_levels s.levels;
+  env := s.env
+
+(** Find the first alternative in the tree of or-patterns for which
+   [f] does not raise an error. If all fail, the last error is
+   propagated *)
+let rec find_valid_alternative f pat =
+  match pat.ppat_desc with
+  | Ppat_or(p1,p2) ->
+      (try find_valid_alternative f p1 with
+       | Empty_branch | Error _ -> find_valid_alternative f p2
+      )
+  | _ -> f pat
+
+let no_explosion = function
+  | Normal -> Normal
+  | Counter_example info ->
+     Counter_example { info with explosion_fuel = 0 }
+
+let get_splitting_mode = function
+  | Normal -> None
+  | Counter_example {splitting_mode} -> Some splitting_mode
+
+let enter_nonsplit_or mode = match mode with
+  | Normal -> Normal
+  | Counter_example info ->
+     let splitting_mode = match info.splitting_mode with
+       | Backtrack_or ->
+          (* in Backtrack_or mode, or-patterns are always split *)
+          assert false
+       | Refine_or _ ->
+          Refine_or {inside_nonsplit_or = true}
+     in Counter_example { info with splitting_mode }
+
+(** The typedtree has two distinct syntactic categories for patterns,
+   "value" patterns, matching on values, and "computation" patterns
+   that match on the effect of a computation -- typically, exception
+   patterns (exception p).
+
+   On the other hand, the parsetree has an unstructured representation
+   where all categories of patterns are mixed together. The
+   decomposition according to the value/computation structure has to
+   happen during type-checking.
+
+   We don't want to duplicate the type-checking logic in two different
+   functions, depending on the kind of pattern to be produced. In
+   particular, there are both value and computation or-patterns, and
+   the type-checking logic for or-patterns is horribly complex; having
+   it in two different places would be twice as horirble.
+
+   The solution is to pass a GADT tag to [type_pat] to indicate whether
+   a value or computation pattern is expected. This way, there is a single
+   place where [Ppat_or] nodes are type-checked, the checking logic is shared,
+   and only at the end do we inspect the tag to decide to produce a value
+   or computation pattern.
+*)
+let pure
+  : type k . k pattern_category -> value general_pattern -> k general_pattern
+  = fun category pat ->
+  match category with
+  | Value -> pat
+  | Computation -> as_computation_pattern pat
+
+let only_impure
+  : type k . k pattern_category ->
+             computation general_pattern -> k general_pattern
+  = fun category pat ->
+  match category with
+  | Value ->
+     (* LATER: this exception could be renamed/generalized *)
+     raise (Error (pat.pat_loc, pat.pat_env,
+                   Exception_pattern_disallowed))
+  | Computation -> pat
+
+let as_comp_pattern
+  : type k . k pattern_category ->
+             k general_pattern -> computation general_pattern
+  = fun category pat ->
+  match category with
+  | Value -> as_computation_pattern pat
+  | Computation -> pat
+
+(* type_pat propagates the expected type.
+   Unification may update the typing environment.
+
+   In counter-example mode, [Empty_branch] is raised when the counter-example
+   does not match any value.  *)
+let rec type_pat
+  : type k r . k pattern_category -> no_existentials:_ -> mode:_ ->
+      env:_ -> _ -> _ -> (k general_pattern -> r) -> r
+  = fun category ~no_existentials ~mode
+        ~env sp expected_ty k ->
+  Builtin_attributes.warning_scope sp.ppat_attributes
+    (fun () ->
+       type_pat_aux category ~no_existentials ~mode
+         ~env sp expected_ty k
+    )
+
+and type_pat_aux
+  : type k r . k pattern_category -> no_existentials:_ -> mode:_ ->
+         env:_ -> _ -> _ -> (k general_pattern -> r) -> r
+  = fun category ~no_existentials ~mode
+      ~env sp expected_ty k ->
+  let type_pat category ?(mode=mode) ?(env=env) =
+    type_pat category ~no_existentials ~mode ~env
+  in
+  let loc = sp.ppat_loc in
+  let refine =
+    match mode with Normal -> None | Counter_example _ -> Some true in
+  let unif (x : pattern) : pattern =
+    unify_pat ~refine env x (instance expected_ty);
+    x
+  in
+  let rp x =
+    let crp (x : k general_pattern) : k general_pattern =
+      match category with
+      | Value -> rp x
+      | Computation -> rcp x in
+    if mode = Normal then crp x else x in
+  let rp k x = k (rp x)
+  and rvp k x = k (rp (pure category x))
+  and rcp k x = k (rp (only_impure category x)) in
+  let construction_not_used_in_counterexamples = (mode = Normal) in
+  let must_backtrack_on_gadt = match get_splitting_mode mode with
+    | None -> false
+    | Some Backtrack_or -> false
+    | Some (Refine_or {inside_nonsplit_or}) -> inside_nonsplit_or
+  in
+  match sp.ppat_desc with
+    Ppat_any ->
+      let k' d = rvp k {
+        pat_desc = d;
+        pat_loc = loc; pat_extra=[];
+        pat_type = instance expected_ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env }
+      in
+      begin match mode with
+      | Normal -> k' Tpat_any
+      | Counter_example {explosion_fuel; _} when explosion_fuel <= 0 ->
+          k' Tpat_any
+      | Counter_example ({explosion_fuel; _} as info) ->
+         let open Parmatch in
+         begin match ppat_of_type !env expected_ty with
+         | PT_empty -> raise Empty_branch
+         | PT_any -> k' Tpat_any
+         | PT_pattern (explosion, sp, constrs, labels) ->
+            let explosion_fuel =
+              match explosion with
+              | PE_single -> explosion_fuel - 1
+              | PE_gadt_cases ->
+                  if must_backtrack_on_gadt then raise Need_backtrack;
+                  explosion_fuel - 5
+            in
+            let mode =
+              Counter_example { info with explosion_fuel; constrs; labels }
+            in
+            type_pat category ~mode sp expected_ty k
+         end
+      end
+  | Ppat_var name ->
+      let ty = instance expected_ty in
+      let id = (* PR#7330 *)
+        if name.txt = "*extension*" then
+          Ident.create_local name.txt
+        else
+          enter_variable loc name ty sp.ppat_attributes
+      in
+      rvp k {
+        pat_desc = Tpat_var (id, name);
+        pat_loc = loc; pat_extra=[];
+        pat_type = ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env }
+  | Ppat_unpack name ->
+      assert construction_not_used_in_counterexamples;
+      let t = instance expected_ty in
+      begin match name.txt with
+      | None ->
+          rvp k {
+            pat_desc = Tpat_any;
+            pat_loc = sp.ppat_loc;
+            pat_extra=[Tpat_unpack, name.loc, sp.ppat_attributes];
+            pat_type = t;
+            pat_attributes = [];
+            pat_env = !env }
+      | Some s ->
+          let v = { name with txt = s } in
+          let id = enter_variable loc v t ~is_module:true sp.ppat_attributes in
+          rvp k {
+            pat_desc = Tpat_var (id, v);
+            pat_loc = sp.ppat_loc;
+            pat_extra=[Tpat_unpack, loc, sp.ppat_attributes];
+            pat_type = t;
+            pat_attributes = [];
+            pat_env = !env }
+      end
+  | Ppat_constraint(
+      {ppat_desc=Ppat_var name; ppat_loc=lloc; ppat_attributes = attrs},
+      ({ptyp_desc=Ptyp_poly _} as sty)) ->
+      (* explicitly polymorphic type *)
+      assert construction_not_used_in_counterexamples;
+      let cty, ty, force = Typetexp.transl_simple_type_delayed !env sty in
+      unify_pat_types ~refine lloc env ty (instance expected_ty);
+      pattern_force := force :: !pattern_force;
+      begin match ty.desc with
+      | Tpoly (body, tyl) ->
+          begin_def ();
+          init_def generic_level;
+          let _, ty' = instance_poly ~keep_names:true false tyl body in
+          end_def ();
+          let id = enter_variable lloc name ty' attrs in
+          rvp k {
+            pat_desc = Tpat_var (id, name);
+            pat_loc = lloc;
+            pat_extra = [Tpat_constraint cty, loc, sp.ppat_attributes];
+            pat_type = ty;
+            pat_attributes = [];
+            pat_env = !env
+          }
+      | _ -> assert false
+      end
+  | Ppat_alias(sq, name) ->
+      assert construction_not_used_in_counterexamples;
+      type_pat Value sq expected_ty (fun q ->
+        begin_def ();
+        let ty_var = build_as_type env q in
+        end_def ();
+        generalize ty_var;
+        let id =
+          enter_variable ~is_as_variable:true loc name ty_var sp.ppat_attributes
+        in
+        rvp k {
+          pat_desc = Tpat_alias(q, id, name);
+          pat_loc = loc; pat_extra=[];
+          pat_type = q.pat_type;
+          pat_attributes = sp.ppat_attributes;
+          pat_env = !env })
+  | Ppat_constant cst ->
+      let cst = constant_or_raise !env loc cst in
+      rvp k @@ unif {
+        pat_desc = Tpat_constant cst;
+        pat_loc = loc; pat_extra=[];
+        pat_type = type_constant cst;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env }
+  | Ppat_interval (Pconst_char c1, Pconst_char c2) ->
+      let open Ast_helper.Pat in
+      let gloc = {loc with Location.loc_ghost=true} in
+      let rec loop c1 c2 =
+        if c1 = c2 then constant ~loc:gloc (Pconst_char c1)
+        else
+          or_ ~loc:gloc
+            (constant ~loc:gloc (Pconst_char c1))
+            (loop (Char.chr(Char.code c1 + 1)) c2)
+      in
+      let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in
+      let p = {p with ppat_loc=loc} in
+      type_pat category ~mode:(no_explosion mode) p expected_ty k
+        (* TODO: record 'extra' to remember about interval *)
+  | Ppat_interval _ ->
+      raise (Error (loc, !env, Invalid_interval))
+  | Ppat_tuple spl ->
+      assert (List.length spl >= 2);
+      let spl_ann = List.map (fun p -> (p,newgenvar ())) spl in
+      let ty = newgenty (Ttuple(List.map snd spl_ann)) in
+      let expected_ty = generic_instance expected_ty in
+      unify_pat_types ~refine loc env ty expected_ty;
+      map_fold_cont (fun (p,t) -> type_pat Value p t) spl_ann (fun pl ->
+        rvp k {
+        pat_desc = Tpat_tuple pl;
+        pat_loc = loc; pat_extra=[];
+        pat_type = newty (Ttuple(List.map (fun p -> p.pat_type) pl));
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env })
+  | Ppat_construct(lid, sarg) ->
+      let expected_type =
+        try
+          let (p0, p, _) = extract_concrete_variant !env expected_ty in
+          let principal =
+            (repr expected_ty).level = generic_level || not !Clflags.principal
+          in
+            Some (p0, p, principal)
+        with Not_found -> None
+      in
+      let constr =
+        match lid.txt, mode with
+        | Longident.Lident s, Counter_example {constrs; _} ->
+           (* assert: cf. {!counter_example_checking_info} documentation *)
+            assert (Hashtbl.mem constrs s);
+            Hashtbl.find constrs s
+        | _ ->
+        let candidates =
+          Env.lookup_all_constructors Env.Pattern ~loc:lid.loc lid.txt !env in
+        wrap_disambiguate "This variant pattern is expected to have"
+          (mk_expected expected_ty)
+          (Constructor.disambiguate Env.Pattern lid !env expected_type)
+          candidates
+      in
+      if constr.cstr_generalized && must_backtrack_on_gadt then
+        raise Need_backtrack;
+      begin match no_existentials, constr.cstr_existentials with
+      | None, _ | _, [] -> ()
+      | Some r, (_ :: _ as exs)  ->
+          let exs = List.map (Ctype.existential_name constr) exs in
+          let name = constr.cstr_name in
+          raise (Error (loc, !env, Unexpected_existential (r,name, exs)))
+      end;
+      (* if constructor is gadt, we must verify that the expected type has the
+         correct head *)
+      if constr.cstr_generalized then
+        unify_head_only ~refine loc env (instance expected_ty) constr;
+      let sargs =
+        match sarg with
+          None -> []
+        | Some {ppat_desc = Ppat_tuple spl} when
+            constr.cstr_arity > 1 ||
+            Builtin_attributes.explicit_arity sp.ppat_attributes
+          -> spl
+        | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity <> 1 ->
+            if constr.cstr_arity = 0 then
+              Location.prerr_warning sp.ppat_loc
+                                     Warnings.Wildcard_arg_to_constant_constr;
+            replicate_list sp constr.cstr_arity
+        | Some sp -> [sp] in
+      if Builtin_attributes.warn_on_literal_pattern constr.cstr_attributes then
+        begin match List.filter has_literal_pattern sargs with
+        | sp :: _ ->
+           Location.prerr_warning sp.ppat_loc Warnings.Fragile_literal_pattern
+        | _ -> ()
+        end;
+      if List.length sargs <> constr.cstr_arity then
+        raise(Error(loc, !env, Constructor_arity_mismatch(lid.txt,
+                                     constr.cstr_arity, List.length sargs)));
+      begin_def ();
+      let (ty_args, ty_res) =
+        instance_constructor ~in_pattern:(env, get_gadt_equations_level ())
+          constr
+      in
+      let expected_ty = instance expected_ty in
+      (* PR#7214: do not use gadt unification for toplevel lets *)
+      let refine =
+        if refine = None && constr.cstr_generalized && no_existentials = None
+        then Some false
+        else refine
+      in
+      let equated_types =
+        unify_pat_types_return_equated_pairs ~refine loc env ty_res expected_ty
+      in
+      end_def ();
+      generalize_structure expected_ty;
+      generalize_structure ty_res;
+      List.iter generalize_structure ty_args;
+      if !Clflags.principal then (
+        let exception Warn_only_once in
+        try
+          TypePairs.iter (fun (t1, t2) () ->
+            generalize_structure t1;
+            generalize_structure t2;
+            if not (fully_generic t1 && fully_generic t2) then
+              let msg =
+                Format.asprintf
+                  "typing this pattern requires considering@ %a@ and@ %a@ as \
+                   equal.@,\
+                   But the knowledge of these types"
+                  Printtyp.type_expr t1
+                  Printtyp.type_expr t2
+              in
+              Location.prerr_warning loc (Warnings.Not_principal msg);
+              raise Warn_only_once
+          ) equated_types
+        with Warn_only_once -> ()
+      );
+
+      let rec check_non_escaping p =
+        match p.ppat_desc with
+        | Ppat_or (p1, p2) ->
+            check_non_escaping p1;
+            check_non_escaping p2
+        | Ppat_alias (p, _) ->
+            check_non_escaping p
+        | Ppat_constraint _ ->
+            raise (Error (p.ppat_loc, !env, Inlined_record_escape))
+        | _ ->
+            ()
+      in
+      if constr.cstr_inlined <> None then List.iter check_non_escaping sargs;
+
+      map_fold_cont
+        (fun (p,t) -> type_pat Value p t)
+        (List.combine sargs ty_args)
+        (fun args ->
+          rvp k {
+            pat_desc=Tpat_construct(lid, constr, args);
+            pat_loc = loc; pat_extra=[];
+            pat_type = instance expected_ty;
+            pat_attributes = sp.ppat_attributes;
+            pat_env = !env })
+  | Ppat_variant(l, sarg) ->
+      let arg_type = match sarg with None -> [] | Some _ -> [newgenvar()] in
+      let row = { row_fields =
+                    [l, Reither(sarg = None, arg_type, true, ref None)];
+                  row_bound = ();
+                  row_closed = false;
+                  row_more = newgenvar ();
+                  row_fixed = None;
+                  row_name = None } in
+      let expected_ty = generic_instance expected_ty in
+      (* PR#7404: allow some_private_tag blindly, as it would not unify with
+         the abstract row variable *)
+      if l = Parmatch.some_private_tag
+      then assert (match mode with Normal -> false | Counter_example _ -> true)
+      else unify_pat_types ~refine loc env (newgenty(Tvariant row)) expected_ty;
+      let k arg =
+        rvp k {
+        pat_desc = Tpat_variant(l, arg, ref {row with row_more = newvar()});
+        pat_loc = loc; pat_extra=[];
+        pat_type = instance expected_ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env }
+      in begin
+        (* PR#6235: propagate type information *)
+        match sarg, arg_type with
+          Some p, [ty] -> type_pat Value p ty (fun p -> k (Some p))
+        | _            -> k None
+      end
+  | Ppat_record(lid_sp_list, closed) ->
+      assert (lid_sp_list <> []);
+      let expected_type, record_ty =
+        try
+          let (p0, p,_) = extract_concrete_record !env expected_ty in
+          let ty = generic_instance expected_ty in
+          let principal =
+            (repr expected_ty).level = generic_level || not !Clflags.principal
+          in
+          Some (p0, p, principal), ty
+        with Not_found -> None, newvar ()
+      in
+      let type_label_pat (label_lid, label, sarg) k =
+        begin_def ();
+        let (_, ty_arg, ty_res) = instance_label false label in
+        begin try
+          unify_pat_types ~refine loc env ty_res (instance record_ty)
+        with Error(_loc, _env, Pattern_type_clash(trace, _)) ->
+          raise(Error(label_lid.loc, !env,
+                      Label_mismatch(label_lid.txt, trace)))
+        end;
+        end_def ();
+        generalize_structure ty_res;
+        generalize_structure ty_arg;
+        type_pat Value sarg ty_arg (fun arg ->
+          k (label_lid, label, arg))
+      in
+      let make_record_pat lbl_pat_list =
+        check_recordpat_labels loc lbl_pat_list closed;
+        {
+          pat_desc = Tpat_record (lbl_pat_list, closed);
+          pat_loc = loc; pat_extra=[];
+          pat_type = instance record_ty;
+          pat_attributes = sp.ppat_attributes;
+          pat_env = !env;
+        }
+      in
+      let k' pat = rvp k (unif pat) in
+      begin match mode with
+      | Normal ->
+          k' (wrap_disambiguate "This record pattern is expected to have"
+               (mk_expected expected_ty)
+               (type_label_a_list loc false !env type_label_pat expected_type
+                  lid_sp_list)
+               make_record_pat)
+      | Counter_example {labels; _} ->
+          type_label_a_list ~labels loc false !env type_label_pat expected_type
+            lid_sp_list (fun lbl_pat_list -> k' (make_record_pat lbl_pat_list))
+      end
+  | Ppat_array spl ->
+      let ty_elt = newgenvar() in
+      let expected_ty = generic_instance expected_ty in
+      unify_pat_types ~refine
+        loc env (Predef.type_array ty_elt) expected_ty;
+      map_fold_cont (fun p -> type_pat Value p ty_elt) spl (fun pl ->
+        rvp k {
+        pat_desc = Tpat_array pl;
+        pat_loc = loc; pat_extra=[];
+        pat_type = instance expected_ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env })
+  | Ppat_or(sp1, sp2) ->
+      let may_split, must_split =
+        match get_splitting_mode mode with
+        | None -> false, false
+        | Some Backtrack_or -> true, true
+        | Some (Refine_or _) -> true, false in
+      let state = save_state env in
+      let split_or sp =
+        assert may_split;
+        let typ pat = type_pat category pat expected_ty k in
+        find_valid_alternative (fun pat -> set_state state env; typ pat) sp in
+      if must_split then split_or sp else begin
+        let initial_pattern_variables = !pattern_variables in
+        let initial_module_variables = !module_variables in
+        let equation_level = !gadt_equations_level in
+        let outter_lev = get_current_level () in
+        (* introduce a new scope *)
+        begin_def ();
+        let lev = get_current_level () in
+        gadt_equations_level := Some lev;
+        let env1 = ref !env in
+        let inside_or = enter_nonsplit_or mode in
+        let type_pat_result env sp : (_, abort_reason) result =
+          match
+            type_pat category ~mode:inside_or sp expected_ty ~env (fun x -> x)
+          with
+          | res -> Ok res
+          | exception Need_backtrack -> Error Adds_constraints
+          | exception Empty_branch -> Error Empty
+        in
+        let p1 = type_pat_result env1 sp1 in
+        let p1_variables = !pattern_variables in
+        let p1_module_variables = !module_variables in
+        pattern_variables := initial_pattern_variables;
+        module_variables := initial_module_variables;
+        let env2 = ref !env in
+        let p2 = type_pat_result env2 sp2 in
+        end_def ();
+        gadt_equations_level := equation_level;
+        let p2_variables = !pattern_variables in
+        (* Make sure no variable with an ambiguous type gets added to the
+           environment. *)
+        List.iter (fun { pv_type; pv_loc; _ } ->
+          check_scope_escape pv_loc !env1 outter_lev pv_type
+        ) p1_variables;
+        List.iter (fun { pv_type; pv_loc; _ } ->
+          check_scope_escape pv_loc !env2 outter_lev pv_type
+        ) p2_variables;
+        begin match p1, p2 with
+        | Error Empty, Error Empty ->
+            raise Empty_branch
+        | Error Adds_constraints, Error _
+        | Error _, Error Adds_constraints ->
+            let inside_nonsplit_or =
+              match get_splitting_mode mode with
+              | None | Some Backtrack_or -> false
+              | Some (Refine_or {inside_nonsplit_or}) -> inside_nonsplit_or in
+            if inside_nonsplit_or
+            then raise Need_backtrack
+            else split_or sp
+        | Ok p, Error _
+        | Error _, Ok p ->
+            rp k p
+        | Ok p1, Ok p2 ->
+            let alpha_env =
+              enter_orpat_variables loc !env p1_variables p2_variables in
+            let p2 = alpha_pat alpha_env p2 in
+            pattern_variables := p1_variables;
+            module_variables := p1_module_variables;
+            let make_pat desc =
+              { pat_desc = desc;
+                pat_loc = loc; pat_extra=[];
+                pat_type = instance expected_ty;
+                pat_attributes = sp.ppat_attributes;
+                pat_env = !env } in
+            rp k (make_pat (Tpat_or(p1, p2, None)))
+        end
+      end
+  | Ppat_lazy sp1 ->
+      let nv = newgenvar () in
+      unify_pat_types ~refine loc env (Predef.type_lazy_t nv)
+        (generic_instance expected_ty);
+      (* do not explode under lazy: PR#7421 *)
+      type_pat Value ~mode:(no_explosion mode) sp1 nv (fun p1 ->
+        rvp k {
+        pat_desc = Tpat_lazy p1;
+        pat_loc = loc; pat_extra=[];
+        pat_type = instance expected_ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env })
+  | Ppat_constraint(sp, sty) ->
+      (* Pretend separate = true *)
+      begin_def();
+      let cty, ty, force = Typetexp.transl_simple_type_delayed !env sty in
+      end_def();
+      generalize_structure ty;
+      let ty, expected_ty' = instance ty, ty in
+      unify_pat_types ~refine loc env ty (instance expected_ty);
+      type_pat category sp expected_ty' (fun p ->
+        (*Format.printf "%a@.%a@."
+          Printtyp.raw_type_expr ty
+          Printtyp.raw_type_expr p.pat_type;*)
+        pattern_force := force :: !pattern_force;
+        let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in
+        let p : k general_pattern =
+          match category, (p : k general_pattern) with
+          | Value, {pat_desc = Tpat_var (id,s); _} ->
+            {p with
+              pat_type = ty;
+              pat_desc =
+                Tpat_alias
+                  ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s);
+              pat_extra = [extra];
+            }
+          | _, p ->
+             { p with pat_type = ty; pat_extra = extra::p.pat_extra }
+        in k p)
+  | Ppat_type lid ->
+      let (path, p,ty) = build_or_pat !env loc lid in
+      unify_pat_types ~refine loc env ty (instance expected_ty);
+      k @@ pure category @@ { p with pat_extra =
+        (Tpat_type (path, lid), loc, sp.ppat_attributes)
+        :: p.pat_extra }
+  | Ppat_open (lid,p) ->
+      let path, new_env =
+        !type_open Asttypes.Fresh !env sp.ppat_loc lid in
+      let new_env = ref new_env in
+      type_pat category ~env:new_env p expected_ty ( fun p ->
+        env := Env.copy_local !env ~from:!new_env;
+        k { p with pat_extra =( Tpat_open (path,lid,!new_env),
+                            loc, sp.ppat_attributes) :: p.pat_extra }
+      )
+  | Ppat_exception p ->
+      type_pat Value p Predef.type_exn (fun p_exn ->
+      rcp k {
+        pat_desc = Tpat_exception p_exn;
+        pat_loc = sp.ppat_loc;
+        pat_extra = [];
+        pat_type = expected_ty;
+        pat_env = !env;
+        pat_attributes = sp.ppat_attributes;
+      })
+  | Ppat_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+let type_pat category ?no_existentials ?(mode=Normal)
+    ?(lev=get_current_level()) env sp expected_ty =
+  Misc.protect_refs [Misc.R (gadt_equations_level, Some lev)] (fun () ->
+        type_pat category ~no_existentials ~mode
+          ~env sp expected_ty (fun x -> x)
+    )
+
+(* this function is passed to Partial.parmatch
+   to type check gadt nonexhaustiveness *)
+let partial_pred ~lev ~splitting_mode ?(explode=0)
+      env expected_ty constrs labels p =
+  let env = ref env in
+  let state = save_state env in
+  let mode =
+    Counter_example {
+        splitting_mode;
+        explosion_fuel = explode;
+        constrs; labels;
+      } in
+  try
+    reset_pattern true;
+    let typed_p = type_pat Value ~lev ~mode env p expected_ty in
+    set_state state env;
+    (* types are invalidated but we don't need them here *)
+    Some typed_p
+  with Error _ | Empty_branch ->
+    set_state state env;
+    None
+
+let check_partial ?(lev=get_current_level ()) env expected_ty loc cases =
+  let explode = match cases with [_] -> 5 | _ -> 0 in
+  let splitting_mode = Refine_or {inside_nonsplit_or = false} in
+  Parmatch.check_partial
+    (partial_pred ~lev ~splitting_mode ~explode env expected_ty) loc cases
+
+let check_unused ?(lev=get_current_level ()) env expected_ty cases =
+  Parmatch.check_unused
+    (fun refute constrs labels spat ->
+      match
+        partial_pred ~lev ~splitting_mode:Backtrack_or ~explode:5
+          env expected_ty constrs labels spat
+      with
+        Some pat when refute ->
+          raise (Error (spat.ppat_loc, env, Unrefuted_pattern pat))
+      | r -> r)
+    cases
+
+let iter_pattern_variables_type f : pattern_variable list -> unit =
+  List.iter (fun {pv_type; _} -> f pv_type)
+
+let add_pattern_variables ?check ?check_as env pv =
+  List.fold_right
+    (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} env ->
+       let check = if pv_as_var then check_as else check in
+       Env.add_value ?check pv_id
+         {val_type = pv_type; val_kind = Val_reg; Types.val_loc = pv_loc;
+          val_attributes = pv_attributes;
+          val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+         } env
+    )
+    pv env
+
+let type_pattern category ~lev env spat expected_ty =
+  reset_pattern true;
+  let new_env = ref env in
+  let pat = type_pat category ~lev new_env spat expected_ty in
+  let pvs = get_ref pattern_variables in
+  let unpacks = get_ref module_variables in
+  (pat, !new_env, get_ref pattern_force, pvs, unpacks)
+
+let type_pattern_list
+    category no_existentials env spatl expected_tys allow
+  =
+  reset_pattern allow;
+  let new_env = ref env in
+  let type_pat (attrs, pat) ty =
+    Builtin_attributes.warning_scope ~ppwarning:false attrs
+      (fun () ->
+         type_pat category ~no_existentials new_env pat ty
+      )
+  in
+  let patl = List.map2 type_pat spatl expected_tys in
+  let pvs = get_ref pattern_variables in
+  let unpacks =
+    List.map (fun (name, loc) ->
+      name, loc, Uid.mk ~current_unit:(Env.get_unit_name ())
+    ) (get_ref module_variables)
+  in
+  let new_env = add_pattern_variables !new_env pvs in
+  (patl, new_env, get_ref pattern_force, pvs, unpacks)
+
+let type_class_arg_pattern cl_num val_env met_env l spat =
+  reset_pattern false;
+  let nv = newvar () in
+  let pat =
+    type_pat Value ~no_existentials:In_class_args (ref val_env) spat nv in
+  if has_variants pat then begin
+    Parmatch.pressure_variants val_env [pat];
+    finalize_variants pat;
+  end;
+  List.iter (fun f -> f()) (get_ref pattern_force);
+  if is_optional l then unify_pat (ref val_env) pat (type_option (newvar ()));
+  let (pv, val_env, met_env) =
+    List.fold_right
+      (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes}
+        (pv, val_env, met_env) ->
+         let check s =
+           if pv_as_var then Warnings.Unused_var s
+           else Warnings.Unused_var_strict s in
+         let id' = Ident.rename pv_id in
+         let val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in
+         let val_env =
+          Env.add_value pv_id
+            { val_type = pv_type
+            ; val_kind = Val_reg
+            ; val_attributes = pv_attributes
+            ; val_loc = pv_loc
+            ; val_uid
+            }
+            val_env
+         in
+         let met_env =
+          Env.add_value id' ~check
+            { val_type = pv_type
+            ; val_kind = Val_ivar (Immutable, cl_num)
+            ; val_attributes = pv_attributes
+            ; val_loc = pv_loc
+            ; val_uid
+            }
+            met_env
+         in
+         ((id', pv_id, pv_type)::pv, val_env, met_env))
+      !pattern_variables ([], val_env, met_env)
+  in
+  (pat, pv, val_env, met_env)
+
+let type_self_pattern cl_num privty val_env met_env par_env spat =
+  let open Ast_helper in
+  let spat =
+    Pat.mk (Ppat_alias (Pat.mk(Ppat_alias (spat, mknoloc "selfpat-*")),
+                        mknoloc ("selfpat-" ^ cl_num)))
+  in
+  reset_pattern false;
+  let nv = newvar() in
+  let pat =
+    type_pat Value ~no_existentials:In_self_pattern (ref val_env) spat nv in
+  List.iter (fun f -> f()) (get_ref pattern_force);
+  let meths = ref Meths.empty in
+  let vars = ref Vars.empty in
+  let pv = !pattern_variables in
+  pattern_variables := [];
+  let (val_env, met_env, par_env) =
+    List.fold_right
+      (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes}
+           (val_env, met_env, par_env) ->
+         let name = Ident.name pv_id in
+         (Env.enter_unbound_value name Val_unbound_self val_env,
+          Env.add_value pv_id
+            {val_type = pv_type;
+             val_kind = Val_self (meths, vars, cl_num, privty);
+             val_attributes = pv_attributes;
+             val_loc = pv_loc;
+             val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+            }
+            ~check:(fun s -> if pv_as_var then Warnings.Unused_var s
+                             else Warnings.Unused_var_strict s)
+            met_env,
+          Env.enter_unbound_value name Val_unbound_self par_env))
+      pv (val_env, met_env, par_env)
+  in
+  (pat, meths, vars, val_env, met_env, par_env)
+
+let delayed_checks = ref []
+let reset_delayed_checks () = delayed_checks := []
+let add_delayed_check f =
+  delayed_checks := (f, Warnings.backup ()) :: !delayed_checks
+
+let force_delayed_checks () =
+  (* checks may change type levels *)
+  let snap = Btype.snapshot () in
+  let w_old = Warnings.backup () in
+  List.iter
+    (fun (f, w) -> Warnings.restore w; f ())
+    (List.rev !delayed_checks);
+  Warnings.restore w_old;
+  reset_delayed_checks ();
+  Btype.backtrack snap
+
+let rec final_subexpression exp =
+  match exp.exp_desc with
+    Texp_let (_, _, e)
+  | Texp_sequence (_, e)
+  | Texp_try (e, _)
+  | Texp_ifthenelse (_, e, _)
+  | Texp_match (_, {c_rhs=e} :: _, _)
+  | Texp_letmodule (_, _, _, _, e)
+  | Texp_letexception (_, e)
+  | Texp_open (_, e)
+    -> final_subexpression e
+  | _ -> exp
+
+(* Generalization criterion for expressions *)
+
+let rec is_nonexpansive exp =
+  match exp.exp_desc with
+  | Texp_ident _
+  | Texp_constant _
+  | Texp_unreachable
+  | Texp_function _
+  | Texp_array [] -> true
+  | Texp_let(_rec_flag, pat_exp_list, body) ->
+      List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list &&
+      is_nonexpansive body
+  | Texp_apply(e, (_,None)::el) ->
+      is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd el)
+  | Texp_match(e, cases, _) ->
+     (* Not sure this is necessary, if [e] is nonexpansive then we shouldn't
+         care if there are exception patterns. But the previous version enforced
+         that there be none, so... *)
+      let contains_exception_pat pat =
+        exists_general_pattern { f = fun (type k) (p : k general_pattern) ->
+          match p.pat_desc with
+          | Tpat_exception _ -> true
+          | _ -> false } pat
+      in
+      is_nonexpansive e &&
+      List.for_all
+        (fun {c_lhs; c_guard; c_rhs} ->
+           is_nonexpansive_opt c_guard && is_nonexpansive c_rhs
+           && not (contains_exception_pat c_lhs)
+        ) cases
+  | Texp_tuple el ->
+      List.for_all is_nonexpansive el
+  | Texp_construct( _, _, el) ->
+      List.for_all is_nonexpansive el
+  | Texp_variant(_, arg) -> is_nonexpansive_opt arg
+  | Texp_record { fields; extended_expression } ->
+      Array.for_all
+        (fun (lbl, definition) ->
+           match definition with
+           | Overridden (_, exp) ->
+               lbl.lbl_mut = Immutable && is_nonexpansive exp
+           | Kept _ -> true)
+        fields
+      && is_nonexpansive_opt extended_expression
+  | Texp_field(exp, _, _) -> is_nonexpansive exp
+  | Texp_ifthenelse(_cond, ifso, ifnot) ->
+      is_nonexpansive ifso && is_nonexpansive_opt ifnot
+  | Texp_sequence (_e1, e2) -> is_nonexpansive e2  (* PR#4354 *)
+  | Texp_new (_, _, cl_decl) -> Ctype.class_type_arity cl_decl.cty_type > 0
+  (* Note: nonexpansive only means no _observable_ side effects *)
+  | Texp_lazy e -> is_nonexpansive e
+  | Texp_object ({cstr_fields=fields; cstr_type = { csig_vars=vars}}, _) ->
+      let count = ref 0 in
+      List.for_all
+        (fun field -> match field.cf_desc with
+            Tcf_method _ -> true
+          | Tcf_val (_, _, _, Tcfk_concrete (_, e), _) ->
+              incr count; is_nonexpansive e
+          | Tcf_val (_, _, _, Tcfk_virtual _, _) ->
+              incr count; true
+          | Tcf_initializer e -> is_nonexpansive e
+          | Tcf_constraint _ -> true
+          | Tcf_inherit _ -> false
+          | Tcf_attribute _ -> true)
+        fields &&
+      Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable)
+        vars true &&
+      !count = 0
+  | Texp_letmodule (_, _, _, mexp, e)
+  | Texp_open ({ open_expr = mexp; _}, e) ->
+      is_nonexpansive_mod mexp && is_nonexpansive e
+  | Texp_pack mexp ->
+      is_nonexpansive_mod mexp
+  (* Computations which raise exceptions are nonexpansive, since (raise e) is
+     equivalent to (raise e; diverge), and a nonexpansive "diverge" can be
+     produced using lazy values or the relaxed value restriction.
+     See GPR#1142 *)
+  | Texp_assert exp ->
+      is_nonexpansive exp
+  | Texp_apply (
+      { exp_desc = Texp_ident (_, _, {val_kind =
+             Val_prim {Primitive.prim_name =
+                         ("%raise" | "%reraise" | "%raise_notrace")}}) },
+      [Nolabel, Some e]) ->
+     is_nonexpansive e
+  | Texp_array (_ :: _)
+  | Texp_apply _
+  | Texp_try _
+  | Texp_setfield _
+  | Texp_while _
+  | Texp_for _
+  | Texp_send _
+  | Texp_instvar _
+  | Texp_setinstvar _
+  | Texp_override _
+  | Texp_letexception _
+  | Texp_letop _
+  | Texp_extension_constructor _ ->
+    false
+
+and is_nonexpansive_mod mexp =
+  match mexp.mod_desc with
+  | Tmod_ident _
+  | Tmod_functor _ -> true
+  | Tmod_unpack (e, _) -> is_nonexpansive e
+  | Tmod_constraint (m, _, _, _) -> is_nonexpansive_mod m
+  | Tmod_structure str ->
+      List.for_all
+        (fun item -> match item.str_desc with
+          | Tstr_eval _ | Tstr_primitive _ | Tstr_type _
+          | Tstr_modtype _ | Tstr_class_type _  -> true
+          | Tstr_value (_, pat_exp_list) ->
+              List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list
+          | Tstr_module {mb_expr=m;_}
+          | Tstr_open {open_expr=m;_}
+          | Tstr_include {incl_mod=m;_} -> is_nonexpansive_mod m
+          | Tstr_recmodule id_mod_list ->
+              List.for_all (fun {mb_expr=m;_} -> is_nonexpansive_mod m)
+                id_mod_list
+          | Tstr_exception {tyexn_constructor = {ext_kind = Text_decl _}} ->
+              false (* true would be unsound *)
+          | Tstr_exception {tyexn_constructor = {ext_kind = Text_rebind _}} ->
+              true
+          | Tstr_typext te ->
+              List.for_all
+                (function {ext_kind = Text_decl _} -> false
+                        | {ext_kind = Text_rebind _} -> true)
+                te.tyext_constructors
+          | Tstr_class _ -> false (* could be more precise *)
+          | Tstr_attribute _ -> true
+        )
+        str.str_items
+  | Tmod_apply _ -> false
+
+and is_nonexpansive_opt = function
+  | None -> true
+  | Some e -> is_nonexpansive e
+
+let maybe_expansive e = not (is_nonexpansive e)
+
+let check_recursive_bindings env valbinds =
+  let ids = let_bound_idents valbinds in
+  List.iter
+    (fun {vb_expr} ->
+       if not (Rec_check.is_valid_recursive_expression ids vb_expr) then
+         raise(Error(vb_expr.exp_loc, env, Illegal_letrec_expr))
+    )
+    valbinds
+
+let check_recursive_class_bindings env ids exprs =
+  List.iter
+    (fun expr ->
+       if not (Rec_check.is_valid_class_expr ids expr) then
+         raise(Error(expr.cl_loc, env, Illegal_class_expr)))
+    exprs
+
+let is_prim ~name funct =
+  match funct.exp_desc with
+  | Texp_ident (_, _, {val_kind=Val_prim{Primitive.prim_name; _}}) ->
+      prim_name = name
+  | _ -> false
+(* Approximate the type of an expression, for better recursion *)
+
+let rec approx_type env sty =
+  match sty.ptyp_desc with
+    Ptyp_arrow (p, _, sty) ->
+      let ty1 = if is_optional p then type_option (newvar ()) else newvar () in
+      newty (Tarrow (p, ty1, approx_type env sty, Cok))
+  | Ptyp_tuple args ->
+      newty (Ttuple (List.map (approx_type env) args))
+  | Ptyp_constr (lid, ctl) ->
+      let path, decl = Env.lookup_type ~use:false ~loc:lid.loc lid.txt env in
+      if List.length ctl <> decl.type_arity then newvar ()
+      else begin
+        let tyl = List.map (approx_type env) ctl in
+        newconstr path tyl
+      end
+  | Ptyp_poly (_, sty) ->
+      approx_type env sty
+  | _ -> newvar ()
+
+let rec type_approx env sexp =
+  match sexp.pexp_desc with
+    Pexp_let (_, _, e) -> type_approx env e
+  | Pexp_fun (p, _, _, e) ->
+      let ty = if is_optional p then type_option (newvar ()) else newvar () in
+      newty (Tarrow(p, ty, type_approx env e, Cok))
+  | Pexp_function ({pc_rhs=e}::_) ->
+      newty (Tarrow(Nolabel, newvar (), type_approx env e, Cok))
+  | Pexp_match (_, {pc_rhs=e}::_) -> type_approx env e
+  | Pexp_try (e, _) -> type_approx env e
+  | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l))
+  | Pexp_ifthenelse (_,e,_) -> type_approx env e
+  | Pexp_sequence (_,e) -> type_approx env e
+  | Pexp_constraint (e, sty) ->
+      let ty = type_approx env e in
+      let ty1 = approx_type env sty in
+      begin try unify env ty ty1 with Unify trace ->
+        raise(Error(sexp.pexp_loc, env, Expr_type_clash (trace, None, None)))
+      end;
+      ty1
+  | Pexp_coerce (e, sty1, sty2) ->
+      let approx_ty_opt = function
+        | None -> newvar ()
+        | Some sty -> approx_type env sty
+      in
+      let ty = type_approx env e
+      and ty1 = approx_ty_opt sty1
+      and ty2 = approx_type env sty2 in
+      begin try unify env ty ty1 with Unify trace ->
+        raise(Error(sexp.pexp_loc, env, Expr_type_clash (trace, None, None)))
+      end;
+      ty2
+  | _ -> newvar ()
+
+(* List labels in a function type, and whether return type is a variable *)
+let rec list_labels_aux env visited ls ty_fun =
+  let ty = expand_head env ty_fun in
+  if List.memq ty visited then
+    List.rev ls, false
+  else match ty.desc with
+    Tarrow (l, _, ty_res, _) ->
+      list_labels_aux env (ty::visited) (l::ls) ty_res
+  | _ ->
+      List.rev ls, is_Tvar ty
+
+let list_labels env ty =
+  wrap_trace_gadt_instances env (list_labels_aux env [] []) ty
+
+(* Check that all univars are safe in a type. Both exp.exp_type and
+   ty_expected should already be generalized. *)
+let check_univars env kind exp ty_expected vars =
+  let pty = instance ty_expected in
+  begin_def ();
+  let exp_ty, vars =
+    match pty.desc with
+      Tpoly (body, tl) ->
+        (* Enforce scoping for type_let:
+           since body is not generic,  instance_poly only makes
+           copies of nodes that have a Tvar as descendant *)
+        let _, ty' = instance_poly true tl body in
+        let vars, exp_ty = instance_parameterized_type vars exp.exp_type in
+        unify_exp_types exp.exp_loc env exp_ty ty';
+        exp_ty, vars
+    | _ -> assert false
+  in
+  end_def ();
+  generalize exp_ty;
+  List.iter generalize vars;
+  let ty, complete = polyfy env exp_ty vars in
+  if not complete then
+    let ty_expected = instance ty_expected in
+    raise (Error (exp.exp_loc, env,
+                  Less_general(kind, [Unification_trace.diff ty ty_expected])))
+
+let generalize_and_check_univars env kind exp ty_expected vars =
+  generalize exp.exp_type;
+  generalize ty_expected;
+  List.iter generalize vars;
+  check_univars env kind exp ty_expected vars
+
+let check_partial_application statement exp =
+  let rec f delay =
+    let ty = (expand_head exp.exp_env exp.exp_type).desc in
+    let check_statement () =
+      match ty with
+      | Tconstr (p, _, _)  when Path.same p Predef.path_unit ->
+          ()
+      | _ ->
+          if statement then
+            let rec loop {exp_loc; exp_desc; exp_extra; _} =
+              match exp_desc with
+              | Texp_let (_, _, e)
+              | Texp_sequence (_, e)
+              | Texp_letexception (_, e)
+              | Texp_letmodule (_, _, _, _, e) ->
+                  loop e
+              | _ ->
+                  let loc =
+                    match List.find_opt (function
+                        | (Texp_constraint _, _, _) -> true
+                        | _ -> false) exp_extra
+                    with
+                    | Some (_, loc, _) -> loc
+                    | None -> exp_loc
+                  in
+                  Location.prerr_warning loc Warnings.Non_unit_statement
+            in
+            loop exp
+    in
+    match ty, exp.exp_desc with
+    | Tarrow _, _ ->
+        let rec check {exp_desc; exp_loc; exp_extra; _} =
+          if List.exists (function
+              | (Texp_constraint _, _, _) -> true
+              | _ -> false) exp_extra then check_statement ()
+          else begin
+            match exp_desc with
+            | Texp_ident _ | Texp_constant _ | Texp_tuple _
+            | Texp_construct _ | Texp_variant _ | Texp_record _
+            | Texp_field _ | Texp_setfield _ | Texp_array _
+            | Texp_while _ | Texp_for _ | Texp_instvar _
+            | Texp_setinstvar _ | Texp_override _ | Texp_assert _
+            | Texp_lazy _ | Texp_object _ | Texp_pack _ | Texp_unreachable
+            | Texp_extension_constructor _ | Texp_ifthenelse (_, _, None)
+            | Texp_function _ ->
+                check_statement ()
+            | Texp_match (_, cases, _) ->
+                List.iter (fun {c_rhs; _} -> check c_rhs) cases
+            | Texp_try (e, cases) ->
+                check e; List.iter (fun {c_rhs; _} -> check c_rhs) cases
+            | Texp_ifthenelse (_, e1, Some e2) ->
+                check e1; check e2
+            | Texp_let (_, _, e) | Texp_sequence (_, e) | Texp_open (_, e)
+            | Texp_letexception (_, e) | Texp_letmodule (_, _, _, _, e) ->
+                check e
+            | Texp_apply _ | Texp_send _ | Texp_new _ | Texp_letop _ ->
+                Location.prerr_warning exp_loc
+                  Warnings.Ignored_partial_application
+          end
+        in
+        check exp
+    | Tvar _, _ ->
+        if delay then add_delayed_check (fun () -> f false)
+    | _ ->
+        check_statement ()
+  in
+  f true
+
+(* Check that a type is generalizable at some level *)
+let generalizable level ty =
+  let rec check ty =
+    let ty = repr ty in
+    if ty.level < lowest_level then () else
+    if ty.level <= level then raise Exit else
+    (mark_type_node ty; iter_type_expr check ty)
+  in
+  try check ty; unmark_type ty; true
+  with Exit -> unmark_type ty; false
+
+(* Hack to allow coercion of self. Will clean-up later. *)
+let self_coercion = ref ([] : (Path.t * Location.t list ref) list)
+
+(* Helpers for packaged modules. *)
+let create_package_type loc env (p, l) =
+  let s = !Typetexp.transl_modtype_longident loc env p in
+  let fields = List.map (fun (name, ct) ->
+                           name, Typetexp.transl_simple_type env false ct) l in
+  let ty = newty (Tpackage (s,
+                    List.map fst l,
+                   List.map (fun (_, cty) -> cty.ctyp_type) fields))
+  in
+   (s, fields, ty)
+
+(* Helpers for type_cases *)
+
+let contains_variant_either ty =
+  let rec loop ty =
+    let ty = repr ty in
+    if ty.level >= lowest_level then begin
+      mark_type_node ty;
+      match ty.desc with
+        Tvariant row ->
+          let row = row_repr row in
+          if not (is_fixed row) then
+            List.iter
+              (fun (_,f) ->
+                match row_field_repr f with Reither _ -> raise Exit | _ -> ())
+              row.row_fields;
+          iter_row loop row
+      | _ ->
+          iter_type_expr loop ty
+    end
+  in
+  try loop ty; unmark_type ty; false
+  with Exit -> unmark_type ty; true
+
+let shallow_iter_ppat f p =
+  match p.ppat_desc with
+  | Ppat_any | Ppat_var _ | Ppat_constant _ | Ppat_interval _
+  | Ppat_extension _
+  | Ppat_type _ | Ppat_unpack _ -> ()
+  | Ppat_array pats -> List.iter f pats
+  | Ppat_or (p1,p2) -> f p1; f p2
+  | Ppat_variant (_, arg) | Ppat_construct (_, arg) -> Option.iter f arg
+  | Ppat_tuple lst ->  List.iter f lst
+  | Ppat_exception p | Ppat_alias (p,_)
+  | Ppat_open (_,p)
+  | Ppat_constraint (p,_) | Ppat_lazy p -> f p
+  | Ppat_record (args, _flag) -> List.iter (fun (_,p) -> f p) args
+
+let exists_ppat f p =
+  let exception Found in
+  let rec loop p =
+    if f p then raise Found else ();
+    shallow_iter_ppat loop p in
+  match loop p with
+  | exception Found -> true
+  | () -> false
+
+let contains_polymorphic_variant p =
+  exists_ppat
+    (function
+     | {ppat_desc = (Ppat_variant _ | Ppat_type _)} -> true
+     | _ -> false)
+    p
+
+let contains_gadt p =
+  exists_general_pattern { f = fun (type k) (p : k general_pattern) ->
+     match p.pat_desc with
+     | Tpat_construct (_, cd, _) when cd.cstr_generalized -> true
+     | _ -> false } p
+
+(* There are various things that we need to do in presence of GADT constructors
+   that aren't required if there are none.
+   However, because of disambiguation, we can't know for sure whether the
+   patterns contain some GADT constructors. So we conservatively assume that
+   any constructor might be a GADT constructor. *)
+let may_contain_gadts p =
+  exists_ppat
+  (function
+   | {ppat_desc = Ppat_construct (_, _)} -> true
+   | _ -> false)
+  p
+
+let check_absent_variant env =
+  iter_general_pattern { f = fun (type k) (pat : k general_pattern) ->
+    match pat.pat_desc with
+    | Tpat_variant (s, arg, row) ->
+      let row = row_repr !row in
+      if List.exists (fun (s',fi) -> s = s' && row_field_repr fi <> Rabsent)
+          row.row_fields
+      || not (is_fixed row) && not (static_row row)  (* same as Ctype.poly *)
+      then () else
+      let ty_arg =
+        match arg with None -> [] | Some p -> [correct_levels p.pat_type] in
+      let row' = {row_fields = [s, Reither(arg=None,ty_arg,true,ref None)];
+                  row_more = newvar (); row_bound = ();
+                  row_closed = false; row_fixed = None; row_name = None} in
+      (* Should fail *)
+      unify_pat (ref env) {pat with pat_type = newty (Tvariant row')}
+                          (correct_levels pat.pat_type)
+    | _ -> () }
+
+(* Getting proper location of already typed expressions.
+
+   Used to avoid confusing locations on type error messages in presence of
+   type constraints.
+   For example:
+
+       (* Before patch *)
+       # let x : string = (5 : int);;
+                           ^
+       (* After patch *)
+       # let x : string = (5 : int);;
+                          ^^^^^^^^^
+*)
+let proper_exp_loc exp =
+  let rec aux = function
+    | [] -> exp.exp_loc
+    | ((Texp_constraint _ | Texp_coerce _), loc, _) :: _ -> loc
+    | _ :: rest -> aux rest
+  in
+  aux exp.exp_extra
+
+(* To find reasonable names for let-bound and lambda-bound idents *)
+
+let rec name_pattern default = function
+    [] -> Ident.create_local default
+  | p :: rem ->
+    match p.pat_desc with
+      Tpat_var (id, _) -> id
+    | Tpat_alias(_, id, _) -> id
+    | _ -> name_pattern default rem
+
+let name_cases default lst =
+  name_pattern default (List.map (fun c -> c.c_lhs) lst)
+
+(* Typing of expressions *)
+
+let unify_exp env exp expected_ty =
+  let loc = proper_exp_loc exp in
+  try
+    unify_exp_types loc env exp.exp_type expected_ty
+  with Error(loc, env, Expr_type_clash(trace, tfc, None)) ->
+    raise (Error(loc, env, Expr_type_clash(trace, tfc, Some exp.exp_desc)))
+
+let rec type_exp ?recarg env sexp =
+  (* We now delegate everything to type_expect *)
+  type_expect ?recarg env sexp (mk_expected (newvar ()))
+
+(* Typing of an expression with an expected type.
+   This provide better error messages, and allows controlled
+   propagation of return type information.
+   In the principal case, [type_expected'] may be at generic_level.
+ *)
+
+and type_expect ?in_function ?recarg env sexp ty_expected_explained =
+  let previous_saved_types = Cmt_format.get_saved_types () in
+  let exp =
+    Builtin_attributes.warning_scope sexp.pexp_attributes
+      (fun () ->
+         type_expect_ ?in_function ?recarg env sexp ty_expected_explained
+      )
+  in
+  Cmt_format.set_saved_types
+    (Cmt_format.Partial_expression exp :: previous_saved_types);
+  exp
+
+and with_explanation explanation f =
+  match explanation with
+  | None -> f ()
+  | Some explanation ->
+      try f ()
+      with Error (loc', env', Expr_type_clash(trace', None, exp'))
+        when not loc'.Location.loc_ghost ->
+        let err = Expr_type_clash(trace', Some explanation, exp') in
+        raise (Error (loc', env', err))
+
+and type_expect_
+    ?in_function ?(recarg=Rejected)
+    env sexp ty_expected_explained =
+  let { ty = ty_expected; explanation } = ty_expected_explained in
+  let loc = sexp.pexp_loc in
+  (* Record the expression type before unifying it with the expected type *)
+  let with_explanation = with_explanation explanation in
+  let rue exp =
+    with_explanation (fun () ->
+      unify_exp env (re exp) (instance ty_expected));
+    exp
+  in
+  match sexp.pexp_desc with
+  | Pexp_ident lid ->
+      let path, desc = type_ident env ~recarg lid in
+      let exp_desc =
+        match desc.val_kind with
+        | Val_ivar (_, cl_num) ->
+            let (self_path, _) =
+              Env.find_value_by_name
+                (Longident.Lident ("self-" ^ cl_num)) env
+            in
+            Texp_instvar(self_path, path,
+                         match lid.txt with
+                             Longident.Lident txt -> { txt; loc = lid.loc }
+                           | _ -> assert false)
+        | Val_self (_, _, cl_num, _) ->
+            let (path, _) =
+              Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env
+            in
+            Texp_ident(path, lid, desc)
+        | _ ->
+            Texp_ident(path, lid, desc)
+      in
+      rue {
+        exp_desc; exp_loc = loc; exp_extra = [];
+        exp_type = instance desc.val_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_constant(Pconst_string (str, _, _) as cst) -> (
+    let cst = constant_or_raise env loc cst in
+    (* Terrible hack for format strings *)
+    let ty_exp = expand_head env ty_expected in
+    let fmt6_path =
+      Path.(Pdot (Pident (Ident.create_persistent "CamlinternalFormatBasics"),
+                  "format6"))
+    in
+    let is_format = match ty_exp.desc with
+      | Tconstr(path, _, _) when Path.same path fmt6_path ->
+        if !Clflags.principal && ty_exp.level <> generic_level then
+          Location.prerr_warning loc
+            (Warnings.Not_principal "this coercion to format6");
+        true
+      | _ -> false
+    in
+    if is_format then
+      let format_parsetree =
+        { (type_format loc str env) with pexp_loc = sexp.pexp_loc }  in
+      type_expect ?in_function env format_parsetree ty_expected_explained
+    else
+      rue {
+        exp_desc = Texp_constant cst;
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance Predef.type_string;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  )
+  | Pexp_constant cst ->
+      let cst = constant_or_raise env loc cst in
+      rue {
+        exp_desc = Texp_constant cst;
+        exp_loc = loc; exp_extra = [];
+        exp_type = type_constant cst;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_let(Nonrecursive,
+             [{pvb_pat=spat; pvb_expr=sval; pvb_attributes=[]}], sbody)
+    when may_contain_gadts spat ->
+    (* TODO: allow non-empty attributes? *)
+      type_expect ?in_function env
+        {sexp with
+         pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody])}
+        ty_expected_explained
+  | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
+      let existential_context =
+        if rec_flag = Recursive then In_rec
+        else if List.compare_length_with spat_sexp_list 1 > 0 then In_group
+        else With_attributes in
+      let (pat_exp_list, new_env, unpacks) =
+        type_let existential_context env rec_flag spat_sexp_list true in
+      let body = type_unpacks new_env unpacks sbody ty_expected_explained in
+      let () =
+        if rec_flag = Recursive then
+          check_recursive_bindings env pat_exp_list
+      in
+      re {
+        exp_desc = Texp_let(rec_flag, pat_exp_list, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = body.exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_fun (l, Some default, spat, sbody) ->
+      assert(is_optional l); (* default allowed only with optional argument *)
+      let open Ast_helper in
+      let default_loc = default.pexp_loc in
+      let scases = [
+        Exp.case
+          (Pat.construct ~loc:default_loc
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
+             (Some (Pat.var ~loc:default_loc (mknoloc "*sth*"))))
+          (Exp.ident ~loc:default_loc (mknoloc (Longident.Lident "*sth*")));
+
+        Exp.case
+          (Pat.construct ~loc:default_loc
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
+             None)
+          default;
+       ]
+      in
+      let sloc =
+        { Location.loc_start = spat.ppat_loc.Location.loc_start;
+          loc_end = default_loc.Location.loc_end;
+          loc_ghost = true }
+      in
+      let smatch =
+        Exp.match_ ~loc:sloc
+          (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*")))
+          scases
+      in
+      let pat = Pat.var ~loc:sloc (mknoloc "*opt*") in
+      let body =
+        Exp.let_ ~loc Nonrecursive
+          ~attrs:[Attr.mk (mknoloc "#default") (PStr [])]
+          [Vb.mk spat smatch] sbody
+      in
+      type_function ?in_function loc sexp.pexp_attributes env
+                    ty_expected_explained l [Exp.case pat body]
+  | Pexp_fun (l, None, spat, sbody) ->
+      type_function ?in_function loc sexp.pexp_attributes env
+                    ty_expected_explained l [Ast_helper.Exp.case spat sbody]
+  | Pexp_function caselist ->
+      type_function ?in_function
+        loc sexp.pexp_attributes env ty_expected_explained Nolabel caselist
+  | Pexp_apply(sfunct, sargs) ->
+      assert (sargs <> []);
+      begin_def (); (* one more level for non-returning functions *)
+      if !Clflags.principal then begin_def ();
+      let funct = type_exp env sfunct in
+      if !Clflags.principal then begin
+          end_def ();
+          generalize_structure funct.exp_type
+        end;
+      let rec lower_args seen ty_fun =
+        let ty = expand_head env ty_fun in
+        if List.memq ty seen then () else
+        match ty.desc with
+          Tarrow (_l, ty_arg, ty_fun, _com) ->
+            (try unify_var env (newvar()) ty_arg with Unify _ -> assert false);
+            lower_args (ty::seen) ty_fun
+        | _ -> ()
+      in
+      let ty = instance funct.exp_type in
+      end_def ();
+      wrap_trace_gadt_instances env (lower_args []) ty;
+      begin_def ();
+      let (args, ty_res) = type_application env funct sargs in
+      end_def ();
+      unify_var env (newvar()) funct.exp_type;
+      let exp =
+        { exp_desc = Texp_apply(funct, args);
+          exp_loc = loc; exp_extra = [];
+          exp_type = ty_res;
+          exp_attributes = sexp.pexp_attributes;
+          exp_env = env } in
+      begin
+        try rue exp
+        with Error (_, _, Expr_type_clash _) as err ->
+          Misc.reraise_preserving_backtrace err (fun () ->
+            check_partial_application false exp)
+      end
+  | Pexp_match(sarg, caselist) ->
+      begin_def ();
+      let arg = type_exp env sarg in
+      end_def ();
+      if maybe_expansive arg then lower_contravariant env arg.exp_type;
+      generalize arg.exp_type;
+      let cases, partial =
+        type_cases Computation env
+          arg.exp_type ty_expected_explained true loc caselist in
+      re {
+        exp_desc = Texp_match(arg, cases, partial);
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance ty_expected;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_try(sbody, caselist) ->
+      let body = type_expect env sbody ty_expected_explained in
+      let cases, _ =
+        type_cases Value env
+          Predef.type_exn ty_expected_explained false loc caselist in
+      re {
+        exp_desc = Texp_try(body, cases);
+        exp_loc = loc; exp_extra = [];
+        exp_type = body.exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_tuple sexpl ->
+      assert (List.length sexpl >= 2);
+      let subtypes = List.map (fun _ -> newgenvar ()) sexpl in
+      let to_unify = newgenty (Ttuple subtypes) in
+      with_explanation (fun () ->
+        unify_exp_types loc env to_unify (generic_instance ty_expected));
+      let expl =
+        List.map2 (fun body ty -> type_expect env body (mk_expected ty))
+          sexpl subtypes
+      in
+      re {
+        exp_desc = Texp_tuple expl;
+        exp_loc = loc; exp_extra = [];
+        (* Keep sharing *)
+        exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl));
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_construct(lid, sarg) ->
+      type_construct env loc lid sarg ty_expected_explained sexp.pexp_attributes
+  | Pexp_variant(l, sarg) ->
+      (* Keep sharing *)
+      let ty_expected0 = instance ty_expected in
+      begin try match
+        sarg, expand_head env ty_expected, expand_head env ty_expected0 with
+      | Some sarg, {desc = Tvariant row}, {desc = Tvariant row0} ->
+          let row = row_repr row in
+          begin match row_field_repr (List.assoc l row.row_fields),
+          row_field_repr (List.assoc l row0.row_fields) with
+            Rpresent (Some ty), Rpresent (Some ty0) ->
+              let arg = type_argument env sarg ty ty0 in
+              re { exp_desc = Texp_variant(l, Some arg);
+                   exp_loc = loc; exp_extra = [];
+                   exp_type = ty_expected0;
+                   exp_attributes = sexp.pexp_attributes;
+                   exp_env = env }
+          | _ -> raise Not_found
+          end
+      | _ -> raise Not_found
+      with Not_found ->
+        let arg = Option.map (type_exp env) sarg in
+        let arg_type = Option.map (fun arg -> arg.exp_type) arg in
+        rue {
+          exp_desc = Texp_variant(l, arg);
+          exp_loc = loc; exp_extra = [];
+          exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type];
+                                    row_more = newvar ();
+                                    row_bound = ();
+                                    row_closed = false;
+                                    row_fixed = None;
+                                    row_name = None});
+          exp_attributes = sexp.pexp_attributes;
+          exp_env = env }
+      end
+  | Pexp_record(lid_sexp_list, opt_sexp) ->
+      assert (lid_sexp_list <> []);
+      let opt_exp =
+        match opt_sexp with
+          None -> None
+        | Some sexp ->
+            if !Clflags.principal then begin_def ();
+            let exp = type_exp ~recarg env sexp in
+            if !Clflags.principal then begin
+              end_def ();
+              generalize_structure exp.exp_type
+            end;
+            Some exp
+      in
+      let ty_record, expected_type =
+        let get_path ty =
+          try
+            let (p0, p,_) = extract_concrete_record env ty in
+            let principal =
+              (repr ty).level = generic_level || not !Clflags.principal
+            in
+            Some (p0, p, principal)
+          with Not_found -> None
+        in
+        let opath = get_path ty_expected in
+        match opath with
+          None | Some (_, _, false) ->
+            let ty = if opath = None then newvar () else ty_expected in
+            begin match opt_exp with
+              None -> ty, opath
+            | Some exp ->
+                match get_path exp.exp_type with
+                  None ->
+                    ty, opath
+                | Some (_, p', _) as opath ->
+                    let decl = Env.find_type p' env in
+                    begin_def ();
+                    let ty =
+                      newconstr p' (instance_list decl.type_params) in
+                    end_def ();
+                    generalize_structure ty;
+                    ty, opath
+            end
+        | _ -> ty_expected, opath
+      in
+      let closed = (opt_sexp = None) in
+      let lbl_exp_list =
+        wrap_disambiguate "This record expression is expected to have"
+          (mk_expected ty_record)
+          (type_label_a_list loc closed env
+             (fun e k -> k (type_label_exp true env loc ty_record e))
+             expected_type lid_sexp_list)
+          (fun x -> x)
+      in
+      with_explanation (fun () ->
+        unify_exp_types loc env (instance ty_record) (instance ty_expected));
+
+      (* type_label_a_list returns a list of labels sorted by lbl_pos *)
+      (* note: check_duplicates would better be implemented in
+         type_label_a_list directly *)
+      let rec check_duplicates = function
+        | (_, lbl1, _) :: (_, lbl2, _) :: _ when lbl1.lbl_pos = lbl2.lbl_pos ->
+          raise(Error(loc, env, Label_multiply_defined lbl1.lbl_name))
+        | _ :: rem ->
+            check_duplicates rem
+        | [] -> ()
+      in
+      check_duplicates lbl_exp_list;
+      let opt_exp, label_definitions =
+        let (_lid, lbl, _lbl_exp) = List.hd lbl_exp_list in
+        let matching_label lbl =
+          List.find
+            (fun (_, lbl',_) -> lbl'.lbl_pos = lbl.lbl_pos)
+            lbl_exp_list
+        in
+        match opt_exp with
+          None ->
+            let label_definitions =
+              Array.map (fun lbl ->
+                  match matching_label lbl with
+                  | (lid, _lbl, lbl_exp) ->
+                      Overridden (lid, lbl_exp)
+                  | exception Not_found ->
+                      let present_indices =
+                        List.map (fun (_, lbl, _) -> lbl.lbl_pos) lbl_exp_list
+                      in
+                      let label_names = extract_label_names env ty_expected in
+                      let rec missing_labels n = function
+                          [] -> []
+                        | lbl :: rem ->
+                            if List.mem n present_indices
+                            then missing_labels (n + 1) rem
+                            else lbl :: missing_labels (n + 1) rem
+                      in
+                      let missing = missing_labels 0 label_names in
+                      raise(Error(loc, env, Label_missing missing)))
+                lbl.lbl_all
+            in
+            None, label_definitions
+        | Some exp ->
+            let ty_exp = instance exp.exp_type in
+            let unify_kept lbl =
+              let _, ty_arg1, ty_res1 = instance_label false lbl in
+              unify_exp_types exp.exp_loc env ty_exp ty_res1;
+              match matching_label lbl with
+              | lid, _lbl, lbl_exp ->
+                  (* do not connect result types for overridden labels *)
+                  Overridden (lid, lbl_exp)
+              | exception Not_found -> begin
+                  let _, ty_arg2, ty_res2 = instance_label false lbl in
+                  unify_exp_types loc env ty_arg1 ty_arg2;
+                  with_explanation (fun () ->
+                    unify_exp_types loc env (instance ty_expected) ty_res2);
+                  Kept ty_arg1
+                end
+            in
+            let label_definitions = Array.map unify_kept lbl.lbl_all in
+            Some {exp with exp_type = ty_exp}, label_definitions
+      in
+      let num_fields =
+        match lbl_exp_list with [] -> assert false
+        | (_, lbl,_)::_ -> Array.length lbl.lbl_all in
+      if opt_sexp <> None && List.length lid_sexp_list = num_fields then
+        Location.prerr_warning loc Warnings.Useless_record_with;
+      let label_descriptions, representation =
+        let (_, { lbl_all; lbl_repres }, _) = List.hd lbl_exp_list in
+        lbl_all, lbl_repres
+      in
+      let fields =
+        Array.map2 (fun descr def -> descr, def)
+          label_descriptions label_definitions
+      in
+      re {
+        exp_desc = Texp_record {
+            fields; representation;
+            extended_expression = opt_exp
+          };
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance ty_expected;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_field(srecord, lid) ->
+      let (record, label, _) = type_label_access env srecord lid in
+      let (_, ty_arg, ty_res) = instance_label false label in
+      unify_exp env record ty_res;
+      rue {
+        exp_desc = Texp_field(record, lid, label);
+        exp_loc = loc; exp_extra = [];
+        exp_type = ty_arg;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_setfield(srecord, lid, snewval) ->
+      let (record, label, expected_type) =
+        type_label_access env srecord lid in
+      let ty_record =
+        if expected_type = None then newvar () else record.exp_type in
+      let (label_loc, label, newval) =
+        type_label_exp false env loc ty_record (lid, label, snewval) in
+      unify_exp env record ty_record;
+      if label.lbl_mut = Immutable then
+        raise(Error(loc, env, Label_not_mutable lid.txt));
+      rue {
+        exp_desc = Texp_setfield(record, label_loc, label, newval);
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance Predef.type_unit;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_array(sargl) ->
+      let ty = newgenvar() in
+      let to_unify = Predef.type_array ty in
+      with_explanation (fun () ->
+        unify_exp_types loc env to_unify (generic_instance ty_expected));
+      let argl =
+        List.map (fun sarg -> type_expect env sarg (mk_expected ty)) sargl in
+      re {
+        exp_desc = Texp_array argl;
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance ty_expected;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_ifthenelse(scond, sifso, sifnot) ->
+      let cond = type_expect env scond
+          (mk_expected ~explanation:If_conditional Predef.type_bool) in
+      begin match sifnot with
+        None ->
+          let ifso = type_expect env sifso
+              (mk_expected ~explanation:If_no_else_branch Predef.type_unit) in
+          rue {
+            exp_desc = Texp_ifthenelse(cond, ifso, None);
+            exp_loc = loc; exp_extra = [];
+            exp_type = ifso.exp_type;
+            exp_attributes = sexp.pexp_attributes;
+            exp_env = env }
+      | Some sifnot ->
+          let ifso = type_expect env sifso ty_expected_explained in
+          let ifnot = type_expect env sifnot ty_expected_explained in
+          (* Keep sharing *)
+          unify_exp env ifnot ifso.exp_type;
+          re {
+            exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot);
+            exp_loc = loc; exp_extra = [];
+            exp_type = ifso.exp_type;
+            exp_attributes = sexp.pexp_attributes;
+            exp_env = env }
+      end
+  | Pexp_sequence(sexp1, sexp2) ->
+      let exp1 = type_statement ~explanation:Sequence_left_hand_side
+          env sexp1 in
+      let exp2 = type_expect env sexp2 ty_expected_explained in
+      re {
+        exp_desc = Texp_sequence(exp1, exp2);
+        exp_loc = loc; exp_extra = [];
+        exp_type = exp2.exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_while(scond, sbody) ->
+      let cond = type_expect env scond
+          (mk_expected ~explanation:While_loop_conditional Predef.type_bool) in
+      let body = type_statement ~explanation:While_loop_body env sbody in
+      rue {
+        exp_desc = Texp_while(cond, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance Predef.type_unit;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_for(param, slow, shigh, dir, sbody) ->
+      let low = type_expect env slow
+          (mk_expected ~explanation:For_loop_start_index Predef.type_int) in
+      let high = type_expect env shigh
+          (mk_expected ~explanation:For_loop_stop_index Predef.type_int) in
+      let id, new_env =
+        match param.ppat_desc with
+        | Ppat_any -> Ident.create_local "_for", env
+        | Ppat_var {txt} ->
+            Env.enter_value txt
+              {val_type = instance Predef.type_int;
+               val_attributes = [];
+               val_kind = Val_reg;
+               val_loc = loc;
+               val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+              } env
+              ~check:(fun s -> Warnings.Unused_for_index s)
+        | _ ->
+            raise (Error (param.ppat_loc, env, Invalid_for_loop_index))
+      in
+      let body = type_statement ~explanation:For_loop_body new_env sbody in
+      rue {
+        exp_desc = Texp_for(id, param, low, high, dir, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance Predef.type_unit;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_constraint (sarg, sty) ->
+      (* Pretend separate = true, 1% slowdown for lablgtk *)
+      begin_def ();
+      let cty = Typetexp.transl_simple_type env false sty in
+      let ty = cty.ctyp_type in
+      end_def ();
+      generalize_structure ty;
+      let (arg, ty') = (type_argument env sarg ty (instance ty), instance ty) in
+      rue {
+        exp_desc = arg.exp_desc;
+        exp_loc = arg.exp_loc;
+        exp_type = ty';
+        exp_attributes = arg.exp_attributes;
+        exp_env = env;
+        exp_extra =
+          (Texp_constraint cty, loc, sexp.pexp_attributes) :: arg.exp_extra;
+      }
+  | Pexp_coerce(sarg, sty, sty') ->
+      (* Pretend separate = true, 1% slowdown for lablgtk *)
+      (* Also see PR#7199 for a problem with the following:
+         let separate = !Clflags.principal || Env.has_local_constraints env in*)
+      let (arg, ty',cty,cty') =
+        match sty with
+        | None ->
+            let (cty', ty', force) =
+              Typetexp.transl_simple_type_delayed env sty'
+            in
+            begin_def ();
+            let arg = type_exp env sarg in
+            end_def ();
+            let tv = newvar () in
+            let gen = generalizable tv.level arg.exp_type in
+            unify_var env tv arg.exp_type;
+            begin match arg.exp_desc, !self_coercion, (repr ty').desc with
+              Texp_ident(_, _, {val_kind=Val_self _}), (path,r) :: _,
+              Tconstr(path',_,_) when Path.same path path' ->
+                (* prerr_endline "self coercion"; *)
+                r := loc :: !r;
+                force ()
+            | _ when free_variables ~env arg.exp_type = []
+                  && free_variables ~env ty' = [] ->
+                if not gen && (* first try a single coercion *)
+                  let snap = snapshot () in
+                  let ty, _b = enlarge_type env ty' in
+                  try
+                    force (); Ctype.unify env arg.exp_type ty; true
+                  with Unify _ ->
+                    backtrack snap; false
+                then ()
+                else begin try
+                  let force' = subtype env arg.exp_type ty' in
+                  force (); force' ();
+                  if not gen && !Clflags.principal then
+                    Location.prerr_warning loc
+                      (Warnings.Not_principal "this ground coercion");
+                with Subtype (tr1, tr2) ->
+                  (* prerr_endline "coercion failed"; *)
+                  raise(Error(loc, env, Not_subtype(tr1, tr2)))
+                end;
+            | _ ->
+                let ty, b = enlarge_type env ty' in
+                force ();
+                begin try Ctype.unify env arg.exp_type ty with Unify trace ->
+                  raise(Error(sarg.pexp_loc, env,
+                        Coercion_failure(ty', full_expand env ty', trace, b)))
+                end
+            end;
+            (arg, ty', None, cty')
+        | Some sty ->
+            begin_def ();
+            let (cty, ty, force) =
+              Typetexp.transl_simple_type_delayed env sty
+            and (cty', ty', force') =
+              Typetexp.transl_simple_type_delayed env sty'
+            in
+            begin try
+              let force'' = subtype env ty ty' in
+              force (); force' (); force'' ()
+            with Subtype (tr1, tr2) ->
+              raise(Error(loc, env, Not_subtype(tr1, tr2)))
+            end;
+            end_def ();
+            generalize_structure ty;
+            generalize_structure ty';
+            (type_argument env sarg ty (instance ty),
+             instance ty', Some cty, cty')
+      in
+      rue {
+        exp_desc = arg.exp_desc;
+        exp_loc = arg.exp_loc;
+        exp_type = ty';
+        exp_attributes = arg.exp_attributes;
+        exp_env = env;
+        exp_extra = (Texp_coerce (cty, cty'), loc, sexp.pexp_attributes) ::
+                       arg.exp_extra;
+      }
+  | Pexp_send (e, {txt=met}) ->
+      if !Clflags.principal then begin_def ();
+      let obj = type_exp env e in
+      let obj_meths = ref None in
+      begin try
+        let (meth, exp, typ) =
+          match obj.exp_desc with
+            Texp_ident(_path, _, {val_kind = Val_self (meths, _, _, privty)}) ->
+              obj_meths := Some meths;
+              let (id, typ) =
+                filter_self_method env met Private meths privty
+              in
+              if is_Tvar (repr typ) then
+                Location.prerr_warning loc
+                  (Warnings.Undeclared_virtual_method met);
+              (Tmeth_val id, None, typ)
+          | Texp_ident(_path, lid, {val_kind = Val_anc (methods, cl_num)}) ->
+              let method_id =
+                begin try List.assoc met methods with Not_found ->
+                  let valid_methods = List.map fst methods in
+                  raise(Error(e.pexp_loc, env,
+                              Undefined_inherited_method (met, valid_methods)))
+                end
+              in
+              begin match
+                Env.find_value_by_name
+                  (Longident.Lident ("selfpat-" ^ cl_num)) env,
+                Env.find_value_by_name
+                  (Longident.Lident ("self-" ^cl_num)) env
+              with
+              | (_, ({val_kind = Val_self (meths, _, _, privty)} as desc)),
+                (path, _) ->
+                  obj_meths := Some meths;
+                  let (_, typ) =
+                    filter_self_method env met Private meths privty
+                  in
+                  let method_type = newvar () in
+                  let (obj_ty, res_ty) = filter_arrow env method_type Nolabel in
+                  unify env obj_ty desc.val_type;
+                  unify env res_ty (instance typ);
+                  let method_desc =
+                    {val_type = method_type;
+                     val_kind = Val_reg;
+                     val_attributes = [];
+                     val_loc = Location.none;
+                     val_uid = Uid.internal_not_actually_unique;
+                    }
+                  in
+                  let exp_env = Env.add_value method_id method_desc env in
+                  let exp =
+                    Texp_apply({exp_desc =
+                                Texp_ident(Path.Pident method_id,
+                                           lid, method_desc);
+                                exp_loc = loc; exp_extra = [];
+                                exp_type = method_type;
+                                exp_attributes = []; (* check *)
+                                exp_env = exp_env},
+                          [ Nolabel,
+                            Some {exp_desc = Texp_ident(path, lid, desc);
+                                  exp_loc = obj.exp_loc; exp_extra = [];
+                                  exp_type = desc.val_type;
+                                  exp_attributes = []; (* check *)
+                                  exp_env = exp_env}
+                          ])
+                  in
+                  (Tmeth_name met, Some (re {exp_desc = exp;
+                                             exp_loc = loc; exp_extra = [];
+                                             exp_type = typ;
+                                             exp_attributes = []; (* check *)
+                                             exp_env = exp_env}), typ)
+              |  _ ->
+                  assert false
+              end
+          | _ ->
+              (Tmeth_name met, None,
+               filter_method env met Public obj.exp_type)
+        in
+        if !Clflags.principal then begin
+          end_def ();
+          generalize_structure typ;
+        end;
+        let typ =
+          match repr typ with
+            {desc = Tpoly (ty, [])} ->
+              instance ty
+          | {desc = Tpoly (ty, tl); level = l} ->
+              if !Clflags.principal && l <> generic_level then
+                Location.prerr_warning loc
+                  (Warnings.Not_principal "this use of a polymorphic method");
+              snd (instance_poly false tl ty)
+          | {desc = Tvar _} as ty ->
+              let ty' = newvar () in
+              unify env (instance ty) (newty(Tpoly(ty',[])));
+              (* if not !Clflags.nolabels then
+                 Location.prerr_warning loc (Warnings.Unknown_method met); *)
+              ty'
+          | _ ->
+              assert false
+        in
+        rue {
+          exp_desc = Texp_send(obj, meth, exp);
+          exp_loc = loc; exp_extra = [];
+          exp_type = typ;
+          exp_attributes = sexp.pexp_attributes;
+          exp_env = env }
+      with Unify _ ->
+        let valid_methods =
+          match !obj_meths with
+          | Some meths ->
+             Some (Meths.fold (fun meth _meth_ty li -> meth::li) !meths [])
+          | None ->
+             match (expand_head env obj.exp_type).desc with
+             | Tobject (fields, _) ->
+                let (fields, _) = Ctype.flatten_fields fields in
+                let collect_fields li (meth, meth_kind, _meth_ty) =
+                  if meth_kind = Fpresent then meth::li else li in
+                Some (List.fold_left collect_fields [] fields)
+             | _ -> None
+        in
+        raise(Error(e.pexp_loc, env,
+                    Undefined_method (obj.exp_type, met, valid_methods)))
+      end
+  | Pexp_new cl ->
+      let (cl_path, cl_decl) = Env.lookup_class ~loc:cl.loc cl.txt env in
+      begin match cl_decl.cty_new with
+          None ->
+            raise(Error(loc, env, Virtual_class cl.txt))
+        | Some ty ->
+            rue {
+              exp_desc = Texp_new (cl_path, cl, cl_decl);
+              exp_loc = loc; exp_extra = [];
+              exp_type = instance ty;
+              exp_attributes = sexp.pexp_attributes;
+              exp_env = env }
+        end
+  | Pexp_setinstvar (lab, snewval) -> begin
+      let (path, mut, cl_num, ty) =
+        Env.lookup_instance_variable ~loc lab.txt env
+      in
+      match mut with
+      | Mutable ->
+          let newval =
+            type_expect env snewval (mk_expected (instance ty))
+          in
+          let (path_self, _) =
+            Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env
+          in
+          rue {
+            exp_desc = Texp_setinstvar(path_self, path, lab, newval);
+            exp_loc = loc; exp_extra = [];
+            exp_type = instance Predef.type_unit;
+            exp_attributes = sexp.pexp_attributes;
+            exp_env = env }
+      | _ ->
+          raise(Error(loc, env, Instance_variable_not_mutable lab.txt))
+    end
+  | Pexp_override lst ->
+      let _ =
+       List.fold_right
+        (fun (lab, _) l ->
+           if List.exists (fun l -> l.txt = lab.txt) l then
+             raise(Error(loc, env,
+                         Value_multiply_overridden lab.txt));
+           lab::l)
+        lst
+        [] in
+      begin match
+        try
+          Env.find_value_by_name (Longident.Lident "selfpat-*") env,
+          Env.find_value_by_name (Longident.Lident "self-*") env
+        with Not_found ->
+          raise(Error(loc, env, Outside_class))
+      with
+        (_, {val_type = self_ty; val_kind = Val_self (_, vars, _, _)}),
+        (path_self, _) ->
+          let type_override (lab, snewval) =
+            begin try
+              let (id, _, _, ty) = Vars.find lab.txt !vars in
+              (Path.Pident id, lab,
+               type_expect env snewval (mk_expected (instance ty)))
+            with
+              Not_found ->
+                let vars = Vars.fold (fun var _ li -> var::li) !vars [] in
+                raise(Error(loc, env,
+                            Unbound_instance_variable (lab.txt, vars)))
+            end
+          in
+          let modifs = List.map type_override lst in
+          rue {
+            exp_desc = Texp_override(path_self, modifs);
+            exp_loc = loc; exp_extra = [];
+            exp_type = self_ty;
+            exp_attributes = sexp.pexp_attributes;
+            exp_env = env }
+      | _ ->
+          assert false
+      end
+  | Pexp_letmodule(name, smodl, sbody) ->
+      let ty = newvar() in
+      (* remember original level *)
+      begin_def ();
+      let context = Typetexp.narrow () in
+      let modl = !type_module env smodl in
+      Mtype.lower_nongen ty.level modl.mod_type;
+      let pres =
+        match modl.mod_type with
+        | Mty_alias _ -> Mp_absent
+        | _ -> Mp_present
+      in
+      let scope = create_scope () in
+      let md =
+        { md_type = modl.mod_type; md_attributes = []; md_loc = name.loc;
+          md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); }
+      in
+      let (id, new_env) =
+        match name.txt with
+        | None -> None, env
+        | Some name ->
+          let id, env = Env.enter_module_declaration ~scope name pres md env in
+          Some id, env
+      in
+      Typetexp.widen context;
+      (* ideally, we should catch Expr_type_clash errors
+         in type_expect triggered by escaping identifiers from the local module
+         and refine them into Scoping_let_module errors
+      *)
+      let body = type_expect new_env sbody ty_expected_explained in
+      (* go back to original level *)
+      end_def ();
+      Ctype.unify_var new_env ty body.exp_type;
+      re {
+        exp_desc = Texp_letmodule(id, name, pres, modl, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = ty;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_letexception(cd, sbody) ->
+      let (cd, newenv) = Typedecl.transl_exception env cd in
+      let body = type_expect newenv sbody ty_expected_explained in
+      re {
+        exp_desc = Texp_letexception(cd, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = body.exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+
+  | Pexp_assert (e) ->
+      let cond = type_expect env e
+          (mk_expected ~explanation:Assert_condition Predef.type_bool) in
+      let exp_type =
+        match cond.exp_desc with
+        | Texp_construct(_, {cstr_name="false"}, _) ->
+            instance ty_expected
+        | _ ->
+            instance Predef.type_unit
+      in
+      rue {
+        exp_desc = Texp_assert cond;
+        exp_loc = loc; exp_extra = [];
+        exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env;
+      }
+  | Pexp_lazy e ->
+      let ty = newgenvar () in
+      let to_unify = Predef.type_lazy_t ty in
+      with_explanation (fun () ->
+        unify_exp_types loc env to_unify (generic_instance ty_expected));
+      let arg = type_expect env e (mk_expected ty) in
+      re {
+        exp_desc = Texp_lazy arg;
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance ty_expected;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env;
+      }
+  | Pexp_object s ->
+      let desc, sign, meths = !type_object env loc s in
+      rue {
+        exp_desc = Texp_object (desc, (*sign,*) meths);
+        exp_loc = loc; exp_extra = [];
+        exp_type = sign.csig_self;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env;
+      }
+  | Pexp_poly(sbody, sty) ->
+      if !Clflags.principal then begin_def ();
+      let ty, cty =
+        match sty with None -> repr ty_expected, None
+        | Some sty ->
+            let sty = Ast_helper.Typ.force_poly sty in
+            let cty = Typetexp.transl_simple_type env false sty in
+            repr cty.ctyp_type, Some cty
+      in
+      if !Clflags.principal then begin
+        end_def ();
+        generalize_structure ty
+      end;
+      if sty <> None then
+        with_explanation (fun () ->
+          unify_exp_types loc env (instance ty) (instance ty_expected));
+      let exp =
+        match (expand_head env ty).desc with
+          Tpoly (ty', []) ->
+            let exp = type_expect env sbody (mk_expected ty') in
+            { exp with exp_type = instance ty }
+        | Tpoly (ty', tl) ->
+            (* One more level to generalize locally *)
+            begin_def ();
+            if !Clflags.principal then begin_def ();
+            let vars, ty'' = instance_poly true tl ty' in
+            if !Clflags.principal then begin
+              end_def ();
+              generalize_structure ty''
+            end;
+            let exp = type_expect env sbody (mk_expected ty'') in
+            end_def ();
+            generalize_and_check_univars env "method" exp ty_expected vars;
+            { exp with exp_type = instance ty }
+        | Tvar _ ->
+            let exp = type_exp env sbody in
+            let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in
+            unify_exp env exp ty;
+            exp
+        | _ -> assert false
+      in
+      re { exp with exp_extra =
+             (Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra }
+  | Pexp_newtype({txt=name}, sbody) ->
+      let ty =
+        if Typetexp.valid_tyvar_name name then
+          newvar ~name ()
+        else
+          newvar ()
+      in
+      (* remember original level *)
+      begin_def ();
+      (* Create a fake abstract type declaration for name. *)
+      let decl = {
+        type_params = [];
+        type_arity = 0;
+        type_kind = Type_abstract;
+        type_private = Public;
+        type_manifest = None;
+        type_variance = [];
+        type_separability = [];
+        type_is_newtype = true;
+        type_expansion_scope = Btype.lowest_level;
+        type_loc = loc;
+        type_attributes = [];
+        type_immediate = Unknown;
+        type_unboxed = unboxed_false_default_false;
+        type_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+      }
+      in
+      let scope = create_scope () in
+      let (id, new_env) = Env.enter_type ~scope name decl env in
+
+      let body = type_exp new_env sbody in
+      (* Replace every instance of this type constructor in the resulting
+         type. *)
+      let seen = Hashtbl.create 8 in
+      let rec replace t =
+        if Hashtbl.mem seen t.id then ()
+        else begin
+          Hashtbl.add seen t.id ();
+          match t.desc with
+          | Tconstr (Path.Pident id', _, _) when id == id' -> link_type t ty
+          | _ -> Btype.iter_type_expr replace t
+        end
+      in
+      let ety = Subst.type_expr Subst.identity body.exp_type in
+      replace ety;
+      (* back to original level *)
+      end_def ();
+      (* lower the levels of the result type *)
+      (* unify_var env ty ety; *)
+
+      (* non-expansive if the body is non-expansive, so we don't introduce
+         any new extra node in the typed AST. *)
+      rue { body with exp_loc = loc; exp_type = ety;
+            exp_extra =
+            (Texp_newtype name, loc, sexp.pexp_attributes) :: body.exp_extra }
+  | Pexp_pack m ->
+      let (p, nl) =
+        match Ctype.expand_head env (instance ty_expected) with
+          {desc = Tpackage (p, nl, _tl)} ->
+            if !Clflags.principal &&
+              (Ctype.expand_head env ty_expected).level < Btype.generic_level
+            then
+              Location.prerr_warning loc
+                (Warnings.Not_principal "this module packing");
+            (p, nl)
+        | {desc = Tvar _} ->
+            raise (Error (loc, env, Cannot_infer_signature))
+        | _ ->
+            raise (Error (loc, env, Not_a_packed_module ty_expected))
+      in
+      let (modl, tl') = !type_package env m p nl in
+      rue {
+        exp_desc = Texp_pack modl;
+        exp_loc = loc; exp_extra = [];
+        exp_type = newty (Tpackage (p, nl, tl'));
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_open (od, e) ->
+      let tv = newvar () in
+      let (od, _, newenv) = !type_open_decl env od in
+      let exp = type_expect newenv e ty_expected_explained in
+      (* Force the return type to be well-formed in the original
+         environment. *)
+      unify_var newenv tv exp.exp_type;
+      re {
+        exp_desc = Texp_open (od, exp);
+        exp_type = exp.exp_type;
+        exp_loc = loc;
+        exp_extra = [];
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env;
+      }
+  | Pexp_letop{ let_ = slet; ands = sands; body = sbody } ->
+      let rec loop spat_acc ty_acc sands =
+        match sands with
+        | [] -> spat_acc, ty_acc
+        | { pbop_pat = spat; _} :: rest ->
+            let ty = newvar () in
+            let loc = { slet.pbop_op.loc with Location.loc_ghost = true } in
+            let spat_acc = Ast_helper.Pat.tuple ~loc [spat_acc; spat] in
+            let ty_acc = newty (Ttuple [ty_acc; ty]) in
+            loop spat_acc ty_acc rest
+      in
+      if !Clflags.principal then begin_def ();
+      let let_loc = slet.pbop_op.loc in
+      let op_path, op_desc = type_binding_op_ident env slet.pbop_op in
+      let op_type = instance op_desc.val_type in
+      let spat_params, ty_params = loop slet.pbop_pat (newvar ()) sands in
+      let ty_func_result = newvar () in
+      let ty_func = newty (Tarrow(Nolabel, ty_params, ty_func_result, Cok)) in
+      let ty_result = newvar () in
+      let ty_andops = newvar () in
+      let ty_op =
+        newty (Tarrow(Nolabel, ty_andops,
+          newty (Tarrow(Nolabel, ty_func, ty_result, Cok)), Cok))
+      in
+      begin try
+        unify env op_type ty_op
+      with Unify trace ->
+        raise(Error(let_loc, env, Letop_type_clash(slet.pbop_op.txt, trace)))
+      end;
+      if !Clflags.principal then begin
+        end_def ();
+        generalize_structure ty_andops;
+        generalize_structure ty_params;
+        generalize_structure ty_func_result;
+        generalize_structure ty_result
+      end;
+      let exp, ands = type_andops env slet.pbop_exp sands ty_andops in
+      let scase = Ast_helper.Exp.case spat_params sbody in
+      let cases, partial =
+        type_cases Value env
+          ty_params (mk_expected ty_func_result) true loc [scase]
+      in
+      let body =
+        match cases with
+        | [case] -> case
+        | _ -> assert false
+      in
+      let param = name_cases "param" cases in
+      let let_ =
+        { bop_op_name = slet.pbop_op;
+          bop_op_path = op_path;
+          bop_op_val = op_desc;
+          bop_op_type = op_type;
+          bop_exp = exp;
+          bop_loc = slet.pbop_loc; }
+      in
+      let desc =
+        Texp_letop{let_; ands; param; body; partial}
+      in
+      rue { exp_desc = desc;
+            exp_loc = sexp.pexp_loc;
+            exp_extra = [];
+            exp_type = instance ty_result;
+            exp_env = env;
+            exp_attributes = sexp.pexp_attributes; }
+
+  | Pexp_extension ({ txt = ("ocaml.extension_constructor"
+                             |"extension_constructor"); _ },
+                    payload) ->
+      begin match payload with
+      | PStr [ { pstr_desc =
+                   Pstr_eval ({ pexp_desc = Pexp_construct (lid, None); _ }, _)
+               } ] ->
+          let path =
+            let cd =
+              Env.lookup_constructor Env.Positive ~loc:lid.loc lid.txt env
+            in
+            match cd.cstr_tag with
+            | Cstr_extension (path, _) -> path
+            | _ -> raise (Error (lid.loc, env, Not_an_extension_constructor))
+          in
+          rue {
+            exp_desc = Texp_extension_constructor (lid, path);
+            exp_loc = loc; exp_extra = [];
+            exp_type = instance Predef.type_extension_constructor;
+            exp_attributes = sexp.pexp_attributes;
+            exp_env = env }
+      | _ ->
+          raise (Error (loc, env, Invalid_extension_constructor_payload))
+      end
+  | Pexp_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+  | Pexp_unreachable ->
+      re { exp_desc = Texp_unreachable;
+           exp_loc = loc; exp_extra = [];
+           exp_type = instance ty_expected;
+           exp_attributes = sexp.pexp_attributes;
+           exp_env = env }
+
+and type_ident env ?(recarg=Rejected) lid =
+  let (path, desc) = Env.lookup_value ~loc:lid.loc lid.txt env in
+  let is_recarg =
+    match (repr desc.val_type).desc with
+    | Tconstr(p, _, _) -> Path.is_constructor_typath p
+    | _ -> false
+  in
+  begin match is_recarg, recarg, (repr desc.val_type).desc with
+  | _, Allowed, _
+  | true, Required, _
+  | false, Rejected, _ -> ()
+  | true, Rejected, _
+  | false, Required, (Tvar _ | Tconstr _) ->
+      raise (Error (lid.loc, env, Inlined_record_escape))
+  | false, Required, _  -> () (* will fail later *)
+  end;
+  path, desc
+
+and type_binding_op_ident env s =
+  let loc = s.loc in
+  let lid = Location.mkloc (Longident.Lident s.txt) loc in
+  let path, desc = type_ident env lid in
+  let path =
+    match desc.val_kind with
+    | Val_ivar _ ->
+        fatal_error "Illegal name for instance variable"
+    | Val_self (_, _, cl_num, _) ->
+        let path, _ =
+          Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env
+        in
+        path
+    | _ -> path
+  in
+  path, desc
+
+and type_function ?in_function loc attrs env ty_expected_explained l caselist =
+  let { ty = ty_expected; explanation } = ty_expected_explained in
+  let (loc_fun, ty_fun) =
+    match in_function with Some p -> p
+    | None -> (loc, instance ty_expected)
+  in
+  let separate = !Clflags.principal || Env.has_local_constraints env in
+  if separate then begin_def ();
+  let (ty_arg, ty_res) =
+    try filter_arrow env (instance ty_expected) l
+    with Unify _ ->
+      match expand_head env ty_expected with
+        {desc = Tarrow _} as ty ->
+          raise(Error(loc, env, Abstract_wrong_label(l, ty, explanation)))
+      | _ ->
+          raise(Error(loc_fun, env,
+                      Too_many_arguments (in_function <> None,
+                                          ty_fun,
+                                          explanation)))
+  in
+  let ty_arg =
+    if is_optional l then
+      let tv = newvar() in
+      begin
+        try unify env ty_arg (type_option tv)
+        with Unify _ -> assert false
+      end;
+      type_option tv
+    else ty_arg
+  in
+  if separate then begin
+    end_def ();
+    generalize_structure ty_arg;
+    generalize_structure ty_res
+  end;
+  let cases, partial =
+    type_cases Value ~in_function:(loc_fun,ty_fun) env
+      ty_arg (mk_expected ty_res) true loc caselist in
+  let not_nolabel_function ty =
+    let ls, tvar = list_labels env ty in
+    List.for_all ((<>) Nolabel) ls && not tvar
+  in
+  if is_optional l && not_nolabel_function ty_res then
+    Location.prerr_warning (List.hd cases).c_lhs.pat_loc
+      Warnings.Unerasable_optional_argument;
+  let param = name_cases "param" cases in
+  re {
+    exp_desc = Texp_function { arg_label = l; param; cases; partial; };
+    exp_loc = loc; exp_extra = [];
+    exp_type = instance (newgenty (Tarrow(l, ty_arg, ty_res, Cok)));
+    exp_attributes = attrs;
+    exp_env = env }
+
+
+and type_label_access env srecord lid =
+  if !Clflags.principal then begin_def ();
+  let record = type_exp ~recarg:Allowed env srecord in
+  if !Clflags.principal then begin
+    end_def ();
+    generalize_structure record.exp_type
+  end;
+  let ty_exp = record.exp_type in
+  let expected_type =
+    try
+      let (p0, p,_) = extract_concrete_record env ty_exp in
+      Some(p0, p, (repr ty_exp).level = generic_level || not !Clflags.principal)
+    with Not_found -> None
+  in
+  let labels = Env.lookup_all_labels ~loc:lid.loc lid.txt env in
+  let label =
+    wrap_disambiguate "This expression has" (mk_expected ty_exp)
+      (Label.disambiguate () lid env expected_type) labels in
+  (record, label, expected_type)
+
+(* Typing format strings for printing or reading.
+   These formats are used by functions in modules Printf, Format, and Scanf.
+   (Handling of * modifiers contributed by Thorsten Ohl.) *)
+
+and type_format loc str env =
+  let loc = {loc with Location.loc_ghost = true} in
+  try
+    CamlinternalFormatBasics.(CamlinternalFormat.(
+      let mk_exp_loc pexp_desc = {
+        pexp_desc = pexp_desc;
+        pexp_loc = loc;
+        pexp_loc_stack = [];
+        pexp_attributes = [];
+      } and mk_lid_loc lid = {
+        txt = lid;
+        loc = loc;
+      } in
+      let mk_constr name args =
+        let lid = Longident.(Ldot(Lident "CamlinternalFormatBasics", name)) in
+        let arg = match args with
+          | []          -> None
+          | [ e ]       -> Some e
+          | _ :: _ :: _ -> Some (mk_exp_loc (Pexp_tuple args)) in
+        mk_exp_loc (Pexp_construct (mk_lid_loc lid, arg)) in
+      let mk_cst cst = mk_exp_loc (Pexp_constant cst) in
+      let mk_int n = mk_cst (Pconst_integer (Int.to_string n, None))
+      and mk_string str = mk_cst (Pconst_string (str, loc, None))
+      and mk_char chr = mk_cst (Pconst_char chr) in
+      let rec mk_formatting_lit fmting = match fmting with
+        | Close_box ->
+          mk_constr "Close_box" []
+        | Close_tag ->
+          mk_constr "Close_tag" []
+        | Break (org, ns, ni) ->
+          mk_constr "Break" [ mk_string org; mk_int ns; mk_int ni ]
+        | FFlush ->
+          mk_constr "FFlush" []
+        | Force_newline ->
+          mk_constr "Force_newline" []
+        | Flush_newline ->
+          mk_constr "Flush_newline" []
+        | Magic_size (org, sz) ->
+          mk_constr "Magic_size" [ mk_string org; mk_int sz ]
+        | Escaped_at ->
+          mk_constr "Escaped_at" []
+        | Escaped_percent ->
+          mk_constr "Escaped_percent" []
+        | Scan_indic c ->
+          mk_constr "Scan_indic" [ mk_char c ]
+      and mk_formatting_gen : type a b c d e f .
+          (a, b, c, d, e, f) formatting_gen -> Parsetree.expression =
+        fun fmting -> match fmting with
+        | Open_tag (Format (fmt', str')) ->
+          mk_constr "Open_tag" [ mk_format fmt' str' ]
+        | Open_box (Format (fmt', str')) ->
+          mk_constr "Open_box" [ mk_format fmt' str' ]
+      and mk_format : type a b c d e f .
+          (a, b, c, d, e, f) CamlinternalFormatBasics.fmt -> string ->
+          Parsetree.expression = fun fmt str ->
+        mk_constr "Format" [ mk_fmt fmt; mk_string str ]
+      and mk_side side = match side with
+        | Left  -> mk_constr "Left"  []
+        | Right -> mk_constr "Right" []
+        | Zeros -> mk_constr "Zeros" []
+      and mk_iconv iconv = match iconv with
+        | Int_d  -> mk_constr "Int_d"  [] | Int_pd -> mk_constr "Int_pd" []
+        | Int_sd -> mk_constr "Int_sd" [] | Int_i  -> mk_constr "Int_i"  []
+        | Int_pi -> mk_constr "Int_pi" [] | Int_si -> mk_constr "Int_si" []
+        | Int_x  -> mk_constr "Int_x"  [] | Int_Cx -> mk_constr "Int_Cx" []
+        | Int_X  -> mk_constr "Int_X"  [] | Int_CX -> mk_constr "Int_CX" []
+        | Int_o  -> mk_constr "Int_o"  [] | Int_Co -> mk_constr "Int_Co" []
+        | Int_u  -> mk_constr "Int_u"  [] | Int_Cd -> mk_constr "Int_Cd" []
+        | Int_Ci -> mk_constr "Int_Ci" [] | Int_Cu -> mk_constr "Int_Cu" []
+      and mk_fconv fconv =
+        let flag = match fst fconv with
+        | Float_flag_ -> mk_constr "Float_flag_" []
+        | Float_flag_p -> mk_constr "Float_flag_p" []
+        | Float_flag_s -> mk_constr "Float_flag_s" [] in
+        let kind = match snd fconv with
+        | Float_f  -> mk_constr "Float_f"  []
+        | Float_e  -> mk_constr "Float_e"  []
+        | Float_E  -> mk_constr "Float_E"  []
+        | Float_g  -> mk_constr "Float_g"  []
+        | Float_G  -> mk_constr "Float_G"  []
+        | Float_h  -> mk_constr "Float_h"  []
+        | Float_H  -> mk_constr "Float_H"  []
+        | Float_F  -> mk_constr "Float_F"  []
+        | Float_CF -> mk_constr "Float_CF" [] in
+        mk_exp_loc (Pexp_tuple [flag; kind])
+      and mk_counter cnt = match cnt with
+        | Line_counter  -> mk_constr "Line_counter"  []
+        | Char_counter  -> mk_constr "Char_counter"  []
+        | Token_counter -> mk_constr "Token_counter" []
+      and mk_int_opt n_opt = match n_opt with
+        | None ->
+          let lid_loc = mk_lid_loc (Longident.Lident "None") in
+          mk_exp_loc (Pexp_construct (lid_loc, None))
+        | Some n ->
+          let lid_loc = mk_lid_loc (Longident.Lident "Some") in
+          mk_exp_loc (Pexp_construct (lid_loc, Some (mk_int n)))
+      and mk_fmtty : type a b c d e f g h i j k l .
+          (a, b, c, d, e, f, g, h, i, j, k, l) fmtty_rel -> Parsetree.expression
+          =
+      fun fmtty -> match fmtty with
+        | Char_ty rest      -> mk_constr "Char_ty"      [ mk_fmtty rest ]
+        | String_ty rest    -> mk_constr "String_ty"    [ mk_fmtty rest ]
+        | Int_ty rest       -> mk_constr "Int_ty"       [ mk_fmtty rest ]
+        | Int32_ty rest     -> mk_constr "Int32_ty"     [ mk_fmtty rest ]
+        | Nativeint_ty rest -> mk_constr "Nativeint_ty" [ mk_fmtty rest ]
+        | Int64_ty rest     -> mk_constr "Int64_ty"     [ mk_fmtty rest ]
+        | Float_ty rest     -> mk_constr "Float_ty"     [ mk_fmtty rest ]
+        | Bool_ty rest      -> mk_constr "Bool_ty"      [ mk_fmtty rest ]
+        | Alpha_ty rest     -> mk_constr "Alpha_ty"     [ mk_fmtty rest ]
+        | Theta_ty rest     -> mk_constr "Theta_ty"     [ mk_fmtty rest ]
+        | Any_ty rest       -> mk_constr "Any_ty"       [ mk_fmtty rest ]
+        | Reader_ty rest    -> mk_constr "Reader_ty"    [ mk_fmtty rest ]
+        | Ignored_reader_ty rest ->
+          mk_constr "Ignored_reader_ty" [ mk_fmtty rest ]
+        | Format_arg_ty (sub_fmtty, rest) ->
+          mk_constr "Format_arg_ty" [ mk_fmtty sub_fmtty; mk_fmtty rest ]
+        | Format_subst_ty (sub_fmtty1, sub_fmtty2, rest) ->
+          mk_constr "Format_subst_ty"
+            [ mk_fmtty sub_fmtty1; mk_fmtty sub_fmtty2; mk_fmtty rest ]
+        | End_of_fmtty -> mk_constr "End_of_fmtty" []
+      and mk_ignored : type a b c d e f .
+          (a, b, c, d, e, f) ignored -> Parsetree.expression =
+      fun ign -> match ign with
+        | Ignored_char ->
+          mk_constr "Ignored_char" []
+        | Ignored_caml_char ->
+          mk_constr "Ignored_caml_char" []
+        | Ignored_string pad_opt ->
+          mk_constr "Ignored_string" [ mk_int_opt pad_opt ]
+        | Ignored_caml_string pad_opt ->
+          mk_constr "Ignored_caml_string" [ mk_int_opt pad_opt ]
+        | Ignored_int (iconv, pad_opt) ->
+          mk_constr "Ignored_int" [ mk_iconv iconv; mk_int_opt pad_opt ]
+        | Ignored_int32 (iconv, pad_opt) ->
+          mk_constr "Ignored_int32" [ mk_iconv iconv; mk_int_opt pad_opt ]
+        | Ignored_nativeint (iconv, pad_opt) ->
+          mk_constr "Ignored_nativeint" [ mk_iconv iconv; mk_int_opt pad_opt ]
+        | Ignored_int64 (iconv, pad_opt) ->
+          mk_constr "Ignored_int64" [ mk_iconv iconv; mk_int_opt pad_opt ]
+        | Ignored_float (pad_opt, prec_opt) ->
+          mk_constr "Ignored_float" [ mk_int_opt pad_opt; mk_int_opt prec_opt ]
+        | Ignored_bool pad_opt ->
+          mk_constr "Ignored_bool" [ mk_int_opt pad_opt ]
+        | Ignored_format_arg (pad_opt, fmtty) ->
+          mk_constr "Ignored_format_arg" [ mk_int_opt pad_opt; mk_fmtty fmtty ]
+        | Ignored_format_subst (pad_opt, fmtty) ->
+          mk_constr "Ignored_format_subst" [
+            mk_int_opt pad_opt; mk_fmtty fmtty ]
+        | Ignored_reader ->
+          mk_constr "Ignored_reader" []
+        | Ignored_scan_char_set (width_opt, char_set) ->
+          mk_constr "Ignored_scan_char_set" [
+            mk_int_opt width_opt; mk_string char_set ]
+        | Ignored_scan_get_counter counter ->
+          mk_constr "Ignored_scan_get_counter" [
+            mk_counter counter
+          ]
+        | Ignored_scan_next_char ->
+          mk_constr "Ignored_scan_next_char" []
+      and mk_padding : type x y . (x, y) padding -> Parsetree.expression =
+      fun pad -> match pad with
+        | No_padding         -> mk_constr "No_padding" []
+        | Lit_padding (s, w) -> mk_constr "Lit_padding" [ mk_side s; mk_int w ]
+        | Arg_padding s      -> mk_constr "Arg_padding" [ mk_side s ]
+      and mk_precision : type x y . (x, y) precision -> Parsetree.expression =
+      fun prec -> match prec with
+        | No_precision    -> mk_constr "No_precision" []
+        | Lit_precision w -> mk_constr "Lit_precision" [ mk_int w ]
+        | Arg_precision   -> mk_constr "Arg_precision" []
+      and mk_fmt : type a b c d e f .
+          (a, b, c, d, e, f) fmt -> Parsetree.expression =
+      fun fmt -> match fmt with
+        | Char rest ->
+          mk_constr "Char" [ mk_fmt rest ]
+        | Caml_char rest ->
+          mk_constr "Caml_char" [ mk_fmt rest ]
+        | String (pad, rest) ->
+          mk_constr "String" [ mk_padding pad; mk_fmt rest ]
+        | Caml_string (pad, rest) ->
+          mk_constr "Caml_string" [ mk_padding pad; mk_fmt rest ]
+        | Int (iconv, pad, prec, rest) ->
+          mk_constr "Int" [
+            mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
+        | Int32 (iconv, pad, prec, rest) ->
+          mk_constr "Int32" [
+            mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
+        | Nativeint (iconv, pad, prec, rest) ->
+          mk_constr "Nativeint" [
+            mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
+        | Int64 (iconv, pad, prec, rest) ->
+          mk_constr "Int64" [
+            mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
+        | Float (fconv, pad, prec, rest) ->
+          mk_constr "Float" [
+            mk_fconv fconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
+        | Bool (pad, rest) ->
+          mk_constr "Bool" [ mk_padding pad; mk_fmt rest ]
+        | Flush rest ->
+          mk_constr "Flush" [ mk_fmt rest ]
+        | String_literal (s, rest) ->
+          mk_constr "String_literal" [ mk_string s; mk_fmt rest ]
+        | Char_literal (c, rest) ->
+          mk_constr "Char_literal" [ mk_char c; mk_fmt rest ]
+        | Format_arg (pad_opt, fmtty, rest) ->
+          mk_constr "Format_arg" [
+            mk_int_opt pad_opt; mk_fmtty fmtty; mk_fmt rest ]
+        | Format_subst (pad_opt, fmtty, rest) ->
+          mk_constr "Format_subst" [
+            mk_int_opt pad_opt; mk_fmtty fmtty; mk_fmt rest ]
+        | Alpha rest ->
+          mk_constr "Alpha" [ mk_fmt rest ]
+        | Theta rest ->
+          mk_constr "Theta" [ mk_fmt rest ]
+        | Formatting_lit (fmting, rest) ->
+          mk_constr "Formatting_lit" [ mk_formatting_lit fmting; mk_fmt rest ]
+        | Formatting_gen (fmting, rest) ->
+          mk_constr "Formatting_gen" [ mk_formatting_gen fmting; mk_fmt rest ]
+        | Reader rest ->
+          mk_constr "Reader" [ mk_fmt rest ]
+        | Scan_char_set (width_opt, char_set, rest) ->
+          mk_constr "Scan_char_set" [
+            mk_int_opt width_opt; mk_string char_set; mk_fmt rest ]
+        | Scan_get_counter (cnt, rest) ->
+          mk_constr "Scan_get_counter" [ mk_counter cnt; mk_fmt rest ]
+        | Scan_next_char rest ->
+          mk_constr "Scan_next_char" [ mk_fmt rest ]
+        | Ignored_param (ign, rest) ->
+          mk_constr "Ignored_param" [ mk_ignored ign; mk_fmt rest ]
+        | End_of_format ->
+          mk_constr "End_of_format" []
+        | Custom _ ->
+          (* Custom formatters have no syntax so they will never appear
+             in formats parsed from strings. *)
+          assert false
+      in
+      let legacy_behavior = not !Clflags.strict_formats in
+      let Fmt_EBB fmt = fmt_ebb_of_string ~legacy_behavior str in
+      mk_constr "Format" [ mk_fmt fmt; mk_string str ]
+    ))
+  with Failure msg ->
+    raise (Error (loc, env, Invalid_format msg))
+
+and type_label_exp create env loc ty_expected
+          (lid, label, sarg) =
+  (* Here also ty_expected may be at generic_level *)
+  begin_def ();
+  let separate = !Clflags.principal || Env.has_local_constraints env in
+  if separate then (begin_def (); begin_def ());
+  let (vars, ty_arg, ty_res) = instance_label true label in
+  if separate then begin
+    end_def ();
+    (* Generalize label information *)
+    generalize_structure ty_arg;
+    generalize_structure ty_res
+  end;
+  begin try
+    unify env (instance ty_res) (instance ty_expected)
+  with Unify trace ->
+    raise (Error(lid.loc, env, Label_mismatch(lid.txt, trace)))
+  end;
+  (* Instantiate so that we can generalize internal nodes *)
+  let ty_arg = instance ty_arg in
+  if separate then begin
+    end_def ();
+    (* Generalize information merged from ty_expected *)
+    generalize_structure ty_arg
+  end;
+  if label.lbl_private = Private then
+    if create then
+      raise (Error(loc, env, Private_type ty_expected))
+    else
+      raise (Error(lid.loc, env, Private_label(lid.txt, ty_expected)));
+  let arg =
+    let snap = if vars = [] then None else Some (Btype.snapshot ()) in
+    let arg = type_argument env sarg ty_arg (instance ty_arg) in
+    end_def ();
+    try
+      if (vars = []) then arg
+      else begin
+        if maybe_expansive arg then
+          lower_contravariant env arg.exp_type;
+        generalize_and_check_univars env "field value" arg label.lbl_arg vars;
+        {arg with exp_type = instance arg.exp_type}
+      end
+    with exn when maybe_expansive arg -> try
+      (* Try to retype without propagating ty_arg, cf PR#4862 *)
+      Option.iter Btype.backtrack snap;
+      begin_def ();
+      let arg = type_exp env sarg in
+      end_def ();
+      lower_contravariant env arg.exp_type;
+      begin_def ();
+      let arg = {arg with exp_type = instance arg.exp_type} in
+      unify_exp env arg (instance ty_arg);
+      end_def ();
+      generalize_and_check_univars env "field value" arg label.lbl_arg vars;
+      {arg with exp_type = instance arg.exp_type}
+    with Error (_, _, Less_general _) as e -> raise e
+    | _ -> raise exn    (* In case of failure return the first error *)
+  in
+  (lid, label, arg)
+
+and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected =
+  (* ty_expected' may be generic *)
+  let no_labels ty =
+    let ls, tvar = list_labels env ty in
+    not tvar && List.for_all ((=) Nolabel) ls
+  in
+  let rec is_inferred sexp =
+    match sexp.pexp_desc with
+      Pexp_ident _ | Pexp_apply _ | Pexp_field _ | Pexp_constraint _
+    | Pexp_coerce _ | Pexp_send _ | Pexp_new _ -> true
+    | Pexp_sequence (_, e) | Pexp_open (_, e) -> is_inferred e
+    | Pexp_ifthenelse (_, e1, Some e2) -> is_inferred e1 && is_inferred e2
+    | _ -> false
+  in
+  match expand_head env ty_expected' with
+    {desc = Tarrow(Nolabel,ty_arg,ty_res,_); level = lv}
+    when is_inferred sarg ->
+      (* apply optional arguments when expected type is "" *)
+      (* we must be very careful about not breaking the semantics *)
+      if !Clflags.principal then begin_def ();
+      let texp = type_exp env sarg in
+      if !Clflags.principal then begin
+        end_def ();
+        generalize_structure texp.exp_type
+      end;
+      let rec make_args args ty_fun =
+        match (expand_head env ty_fun).desc with
+        | Tarrow (l,ty_arg,ty_fun,_) when is_optional l ->
+            let ty = option_none env (instance ty_arg) sarg.pexp_loc in
+            make_args ((l, Some ty) :: args) ty_fun
+        | Tarrow (l,_,ty_res',_) when l = Nolabel || !Clflags.classic ->
+            List.rev args, ty_fun, no_labels ty_res'
+        | Tvar _ ->  List.rev args, ty_fun, false
+        |  _ -> [], texp.exp_type, false
+      in
+      let args, ty_fun', simple_res = make_args [] texp.exp_type in
+      let warn = !Clflags.principal &&
+        (lv <> generic_level || (repr ty_fun').level <> generic_level)
+      and texp = {texp with exp_type = instance texp.exp_type}
+      and ty_fun = instance ty_fun' in
+      if not (simple_res || no_labels ty_res) then begin
+        unify_exp env texp ty_expected;
+        texp
+      end else begin
+      unify_exp env {texp with exp_type = ty_fun} ty_expected;
+      if args = [] then texp else
+      (* eta-expand to avoid side effects *)
+      let var_pair name ty =
+        let id = Ident.create_local name in
+        let desc =
+          { val_type = ty; val_kind = Val_reg;
+            val_attributes = [];
+            val_loc = Location.none;
+            val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+          }
+        in
+        let exp_env = Env.add_value id desc env in
+        {pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[];
+         pat_attributes = [];
+         pat_loc = Location.none; pat_env = env},
+        {exp_type = ty; exp_loc = Location.none; exp_env = exp_env;
+         exp_extra = []; exp_attributes = [];
+         exp_desc =
+         Texp_ident(Path.Pident id, mknoloc (Longident.Lident name), desc)}
+      in
+      let eta_pat, eta_var = var_pair "eta" ty_arg in
+      let func texp =
+        let e =
+          {texp with exp_type = ty_res; exp_desc =
+           Texp_apply
+             (texp,
+              args @ [Nolabel, Some eta_var])}
+        in
+        let cases = [case eta_pat e] in
+        let param = name_cases "param" cases in
+        { texp with exp_type = ty_fun; exp_desc =
+          Texp_function { arg_label = Nolabel; param; cases;
+            partial = Total; } }
+      in
+      Location.prerr_warning texp.exp_loc
+        (Warnings.Eliminated_optional_arguments
+           (List.map (fun (l, _) -> Printtyp.string_of_label l) args));
+      if warn then Location.prerr_warning texp.exp_loc
+          (Warnings.Non_principal_labels "eliminated optional argument");
+      (* let-expand to have side effects *)
+      let let_pat, let_var = var_pair "arg" texp.exp_type in
+      re { texp with exp_type = ty_fun; exp_desc =
+           Texp_let (Nonrecursive,
+                     [{vb_pat=let_pat; vb_expr=texp; vb_attributes=[];
+                       vb_loc=Location.none;
+                      }],
+                     func let_var) }
+      end
+  | _ ->
+      let texp = type_expect ?recarg env sarg
+        (mk_expected ?explanation ty_expected') in
+      unify_exp env texp ty_expected;
+      texp
+
+and type_application env funct sargs =
+  (* funct.exp_type may be generic *)
+  let result_type omitted ty_fun =
+    List.fold_left
+      (fun ty_fun (l,ty,lv) -> newty2 lv (Tarrow(l,ty,ty_fun,Cok)))
+      ty_fun omitted
+  in
+  let has_label l ty_fun =
+    let ls, tvar = list_labels env ty_fun in
+    tvar || List.mem l ls
+  in
+  let eliminated_optional_arguments = ref [] in
+  let omitted_parameters = ref [] in
+  let type_unknown_arg (ty_fun, typed_args) (lbl, sarg) =
+    let (ty_arg, ty_res) =
+      let ty_fun = expand_head env ty_fun in
+      match ty_fun.desc with
+      | Tvar _ ->
+          let t1 = newvar () and t2 = newvar () in
+          if ty_fun.level >= t1.level &&
+             not (is_prim ~name:"%identity" funct)
+          then
+            Location.prerr_warning sarg.pexp_loc
+              Warnings.Ignored_extra_argument;
+          unify env ty_fun (newty (Tarrow(lbl,t1,t2,Clink(ref Cunknown))));
+          (t1, t2)
+      | Tarrow (l,t1,t2,_) when l = lbl
+        || !Clflags.classic && lbl = Nolabel && not (is_optional l) ->
+          (t1, t2)
+      | td ->
+          let ty_fun = match td with Tarrow _ -> newty td | _ -> ty_fun in
+          let ty_res =
+            result_type (!omitted_parameters @ !eliminated_optional_arguments)
+              ty_fun
+          in
+          match ty_res.desc with
+          | Tarrow _ ->
+              if !Clflags.classic || not (has_label lbl ty_fun) then
+                raise (Error(sarg.pexp_loc, env,
+                             Apply_wrong_label(lbl, ty_res, false)))
+              else
+                raise (Error(funct.exp_loc, env, Incoherent_label_order))
+          | _ ->
+              raise(Error(funct.exp_loc, env, Apply_non_function
+                            (expand_head env funct.exp_type)))
+    in
+    let arg () =
+      let arg = type_expect env sarg (mk_expected ty_arg) in
+      if is_optional lbl then
+        unify_exp env arg (type_option(newvar()));
+      arg
+    in
+    (ty_res, (lbl, Some arg) :: typed_args)
+  in
+  let ignore_labels =
+    !Clflags.classic ||
+    begin
+      let ls, tvar = list_labels env funct.exp_type in
+      not tvar &&
+      let labels = List.filter (fun l -> not (is_optional l)) ls in
+      List.length labels = List.length sargs &&
+      List.for_all (fun (l,_) -> l = Nolabel) sargs &&
+      List.exists (fun l -> l <> Nolabel) labels &&
+      (Location.prerr_warning
+         funct.exp_loc
+         (Warnings.Labels_omitted
+            (List.map Printtyp.string_of_label
+                      (List.filter ((<>) Nolabel) labels)));
+       true)
+    end
+  in
+  let warned = ref false in
+  let rec type_args args ty_fun ty_fun0 sargs =
+    match expand_head env ty_fun, expand_head env ty_fun0 with
+    | {desc=Tarrow (l, ty, ty_fun, com); level=lv} as ty_fun',
+      {desc=Tarrow (_, ty0, ty_fun0, _)}
+      when sargs <> [] && commu_repr com = Cok ->
+        let may_warn loc w =
+          if not !warned && !Clflags.principal && lv <> generic_level
+          then begin
+            warned := true;
+            Location.prerr_warning loc w
+          end
+        in
+        let name = label_name l
+        and optional = is_optional l in
+        let use_arg sarg l' =
+          Some (
+            if not optional || is_optional l' then
+              (fun () -> type_argument env sarg ty ty0)
+            else begin
+              may_warn sarg.pexp_loc
+                (Warnings.Not_principal "using an optional argument here");
+              (fun () -> option_some env (type_argument env sarg
+                                            (extract_option_type env ty)
+                                            (extract_option_type env ty0)))
+            end
+          )
+        in
+        let eliminate_optional_arg () =
+          may_warn funct.exp_loc
+            (Warnings.Non_principal_labels "eliminated optional argument");
+          eliminated_optional_arguments :=
+            (l,ty,lv) :: !eliminated_optional_arguments;
+          Some (fun () -> option_none env (instance ty) Location.none)
+        in
+        let remaining_sargs, arg =
+          if ignore_labels then begin
+            (* No reordering is allowed, process arguments in order *)
+            match sargs with
+            | [] -> assert false
+            | (l', sarg) :: remaining_sargs ->
+                if name = label_name l' || (not optional && l' = Nolabel) then
+                  (remaining_sargs, use_arg sarg l')
+                else if
+                  optional &&
+                  not (List.exists (fun (l, _) -> name = label_name l)
+                         remaining_sargs) &&
+                  List.exists (function (Nolabel, _) -> true | _ -> false)
+                    sargs
+                then
+                  (sargs, eliminate_optional_arg ())
+                else
+                  raise(Error(sarg.pexp_loc, env,
+                              Apply_wrong_label(l', ty_fun', optional)))
+          end else
+            (* Arguments can be commuted, try to fetch the argument
+               corresponding to the first parameter. *)
+            match extract_label name sargs with
+            | Some (l', sarg, commuted, remaining_sargs) ->
+                if commuted then begin
+                  may_warn sarg.pexp_loc
+                    (Warnings.Not_principal "commuting this argument")
+                end;
+                if not optional && is_optional l' then
+                  Location.prerr_warning sarg.pexp_loc
+                    (Warnings.Nonoptional_label (Printtyp.string_of_label l));
+                remaining_sargs, use_arg sarg l'
+            | None ->
+                sargs,
+                if optional && List.mem_assoc Nolabel sargs then
+                  eliminate_optional_arg ()
+                else begin
+                  (* No argument was given for this parameter, we abstract over
+                     it. *)
+                  may_warn funct.exp_loc
+                    (Warnings.Non_principal_labels "commuted an argument");
+                  omitted_parameters := (l,ty,lv) :: !omitted_parameters;
+                  None
+                end
+        in
+        type_args ((l,arg)::args) ty_fun ty_fun0 remaining_sargs
+    | _ ->
+        (* We're not looking at a *known* function type anymore, or there are no
+           arguments left. *)
+        let ty_fun, typed_args =
+          List.fold_left type_unknown_arg (ty_fun0, args) sargs
+        in
+        let args =
+          (* Force typing of arguments.
+             Careful: the order matters here. Using [List.rev_map] would be
+             incorrect. *)
+          List.map
+            (function
+              | l, None -> l, None
+              | l, Some f -> l, Some (f ()))
+            (List.rev typed_args)
+        in
+        let result_ty = instance (result_type !omitted_parameters ty_fun) in
+        args, result_ty
+  in
+  let is_ignore funct =
+    is_prim ~name:"%ignore" funct &&
+    (try ignore (filter_arrow env (instance funct.exp_type) Nolabel); true
+     with Unify _ -> false)
+  in
+  match sargs with
+  | (* Special case for ignore: avoid discarding warning *)
+    [Nolabel, sarg] when is_ignore funct ->
+      let ty_arg, ty_res = filter_arrow env (instance funct.exp_type) Nolabel in
+      let exp = type_expect env sarg (mk_expected ty_arg) in
+      check_partial_application false exp;
+      ([Nolabel, Some exp], ty_res)
+  | _ ->
+    let ty = funct.exp_type in
+    type_args [] ty (instance ty) sargs
+
+and type_construct env loc lid sarg ty_expected_explained attrs =
+  let { ty = ty_expected; explanation } = ty_expected_explained in
+  let expected_type =
+    try
+      let (p0, p,_) = extract_concrete_variant env ty_expected in
+      let principal =
+        (repr ty_expected).level = generic_level || not !Clflags.principal
+      in
+      Some(p0, p, principal)
+    with Not_found -> None
+  in
+  let constrs =
+    Env.lookup_all_constructors ~loc:lid.loc Env.Positive lid.txt env
+  in
+  let constr =
+    wrap_disambiguate "This variant expression is expected to have"
+      ty_expected_explained
+      (Constructor.disambiguate Env.Positive lid env expected_type) constrs
+  in
+  let sargs =
+    match sarg with
+      None -> []
+    | Some {pexp_desc = Pexp_tuple sel} when
+        constr.cstr_arity > 1 || Builtin_attributes.explicit_arity attrs
+      -> sel
+    | Some se -> [se] in
+  if List.length sargs <> constr.cstr_arity then
+    raise(Error(loc, env, Constructor_arity_mismatch
+                            (lid.txt, constr.cstr_arity, List.length sargs)));
+  let separate = !Clflags.principal || Env.has_local_constraints env in
+  if separate then (begin_def (); begin_def ());
+  let (ty_args, ty_res) = instance_constructor constr in
+  let texp =
+    re {
+      exp_desc = Texp_construct(lid, constr, []);
+      exp_loc = loc; exp_extra = [];
+      exp_type = ty_res;
+      exp_attributes = attrs;
+      exp_env = env } in
+  if separate then begin
+    end_def ();
+    generalize_structure ty_res;
+    with_explanation explanation (fun () ->
+      unify_exp env {texp with exp_type = instance ty_res}
+        (instance ty_expected));
+    end_def ();
+    List.iter generalize_structure ty_args;
+    generalize_structure ty_res;
+  end;
+  let ty_args0, ty_res =
+    match instance_list (ty_res :: ty_args) with
+      t :: tl -> tl, t
+    | _ -> assert false
+  in
+  let texp = {texp with exp_type = ty_res} in
+  if not separate then unify_exp env texp (instance ty_expected);
+  let recarg =
+    match constr.cstr_inlined with
+    | None -> Rejected
+    | Some _ ->
+      begin match sargs with
+      | [{pexp_desc =
+            Pexp_ident _ |
+            Pexp_record (_, (Some {pexp_desc = Pexp_ident _}| None))}] ->
+        Required
+      | _ ->
+        raise (Error(loc, env, Inlined_record_expected))
+      end
+  in
+  let args =
+    List.map2 (fun e (t,t0) -> type_argument ~recarg env e t t0) sargs
+      (List.combine ty_args ty_args0) in
+  if constr.cstr_private = Private then
+    begin match constr.cstr_tag with
+    | Cstr_extension _ ->
+        raise(Error(loc, env, Private_constructor (constr, ty_res)))
+    | Cstr_constant _ | Cstr_block _ | Cstr_unboxed ->
+        raise (Error(loc, env, Private_type ty_res));
+    end;
+  (* NOTE: shouldn't we call "re" on this final expression? -- AF *)
+  { texp with
+    exp_desc = Texp_construct(lid, constr, args) }
+
+(* Typing of statements (expressions whose values are discarded) *)
+
+and type_statement ?explanation env sexp =
+  begin_def();
+  let exp = type_exp env sexp in
+  end_def();
+  let ty = expand_head env exp.exp_type and tv = newvar() in
+  if is_Tvar ty && ty.level > tv.level then
+    Location.prerr_warning
+      (final_subexpression exp).exp_loc
+      Warnings.Nonreturning_statement;
+  if !Clflags.strict_sequence then
+    let expected_ty = instance Predef.type_unit in
+    with_explanation explanation (fun () ->
+      unify_exp env exp expected_ty);
+    exp
+  else begin
+    check_partial_application true exp;
+    unify_var env tv ty;
+    exp
+  end
+
+and type_unpacks ?in_function env unpacks sbody expected_ty =
+  let ty = newvar() in
+  (* remember original level *)
+  let extended_env, tunpacks =
+    List.fold_left (fun (env, unpacks) (name, loc, uid) ->
+      begin_def ();
+      let context = Typetexp.narrow () in
+      let modl =
+        !type_module env
+          Ast_helper.(
+            Mod.unpack ~loc
+              (Exp.ident ~loc:name.loc (mkloc (Longident.Lident name.txt)
+                                          name.loc)))
+      in
+      Mtype.lower_nongen ty.level modl.mod_type;
+      let pres =
+        match modl.mod_type with
+        | Mty_alias _ -> Mp_absent
+        | _ -> Mp_present
+      in
+      let scope = create_scope () in
+      let md =
+        { md_type = modl.mod_type; md_attributes = []; md_loc = name.loc;
+          md_uid = uid; }
+      in
+      let (id, env) =
+        Env.enter_module_declaration ~scope name.txt pres md env
+      in
+      Typetexp.widen context;
+      env, (id, name, pres, modl) :: unpacks
+    ) (env, []) unpacks
+  in
+  (* ideally, we should catch Expr_type_clash errors
+     in type_expect triggered by escaping identifiers from the local module
+     and refine them into Scoping_let_module errors
+  *)
+  let body = type_expect ?in_function extended_env sbody expected_ty in
+  let exp_loc = { body.exp_loc with loc_ghost = true } in
+  let exp_attributes = [Ast_helper.Attr.mk (mknoloc "#modulepat") (PStr [])] in
+  List.fold_left (fun body (id, name, pres, modl) ->
+    (* go back to parent level *)
+    end_def ();
+    Ctype.unify_var extended_env ty body.exp_type;
+    re {
+      exp_desc = Texp_letmodule(Some id, { name with txt = Some name.txt },
+                                pres, modl, body);
+      exp_loc;
+      exp_attributes;
+      exp_extra = [];
+      exp_type = ty;
+      exp_env = env }
+  ) body tunpacks
+
+(* Typing of match cases *)
+and type_cases
+    : type k . k pattern_category ->
+           ?in_function:_ -> _ -> _ -> _ -> _ -> _ -> Parsetree.case list ->
+           k case list * partial
+  = fun category ?in_function env
+        ty_arg ty_res_explained partial_flag loc caselist ->
+  (* ty_arg is _fully_ generalized *)
+  let { ty = ty_res; explanation } = ty_res_explained in
+  let patterns = List.map (fun {pc_lhs=p} -> p) caselist in
+  let contains_polyvars = List.exists contains_polymorphic_variant patterns in
+  let erase_either = contains_polyvars && contains_variant_either ty_arg in
+  let may_contain_gadts = List.exists may_contain_gadts patterns in
+  let ty_arg =
+    if (may_contain_gadts || erase_either) && not !Clflags.principal
+    then correct_levels ty_arg else ty_arg
+  in
+  let rec is_var spat =
+    match spat.ppat_desc with
+      Ppat_any | Ppat_var _ -> true
+    | Ppat_alias (spat, _) -> is_var spat
+    | _ -> false in
+  let needs_exhaust_check =
+    match caselist with
+      [{pc_rhs = {pexp_desc = Pexp_unreachable}}] -> true
+    | [{pc_lhs}] when is_var pc_lhs -> false
+    | _ -> true
+  in
+  let outer_level = get_current_level () in
+  let lev =
+    if may_contain_gadts then begin_def ();
+    get_current_level ()
+  in
+  let take_partial_instance =
+    if erase_either
+    then Some false else None
+  in
+  begin_def (); (* propagation of the argument *)
+  let pattern_force = ref [] in
+(*  Format.printf "@[%i %i@ %a@]@." lev (get_current_level())
+    Printtyp.raw_type_expr ty_arg; *)
+  let half_typed_cases =
+    List.map
+      (fun ({pc_lhs; pc_guard = _; pc_rhs = _} as case) ->
+        if !Clflags.principal then begin_def (); (* propagation of pattern *)
+        begin_def ();
+        let ty_arg = instance ?partial:take_partial_instance ty_arg in
+        end_def ();
+        generalize_structure ty_arg;
+        let (pat, ext_env, force, pvs, unpacks) =
+          type_pattern category ~lev env pc_lhs ty_arg
+        in
+        pattern_force := force @ !pattern_force;
+        let pat =
+          if !Clflags.principal then begin
+            end_def ();
+            iter_pattern_variables_type generalize_structure pvs;
+            { pat with pat_type = instance pat.pat_type }
+          end else pat
+        in
+        (* Ensure that no ambivalent pattern type escapes its branch *)
+        check_scope_escape pat.pat_loc env outer_level ty_arg;
+        { typed_pat = pat;
+          pat_type_for_unif = ty_arg;
+          untyped_case = case;
+          branch_env = ext_env;
+          pat_vars = pvs;
+          unpacks;
+          contains_gadt = contains_gadt (as_comp_pattern category pat); }
+        )
+      caselist in
+  let patl = List.map (fun { typed_pat; _ } -> typed_pat) half_typed_cases in
+  let does_contain_gadt =
+    List.exists (fun { contains_gadt; _ } -> contains_gadt) half_typed_cases
+  in
+  let ty_res, do_copy_types =
+    if does_contain_gadt && not !Clflags.principal then
+      correct_levels ty_res, Env.make_copy_of_types env
+    else ty_res, (fun env -> env)
+  in
+  (* Unify all cases (delayed to keep it order-free) *)
+  let ty_arg' = newvar () in
+  let unify_pats ty =
+    List.iter (fun { typed_pat = pat; pat_type_for_unif = pat_ty; _ } ->
+      unify_pat_types pat.pat_loc (ref env) pat_ty ty
+    ) half_typed_cases
+  in
+  unify_pats ty_arg';
+  (* Check for polymorphic variants to close *)
+  if List.exists has_variants patl then begin
+      Parmatch.pressure_variants_in_computation_pattern env
+        (List.map (as_comp_pattern category) patl);
+      List.iter finalize_variants patl
+  end;
+  (* `Contaminating' unifications start here *)
+  List.iter (fun f -> f()) !pattern_force;
+  (* Post-processing and generalization *)
+  if take_partial_instance <> None then unify_pats (instance ty_arg);
+  List.iter (fun { pat_vars; _ } ->
+    iter_pattern_variables_type (fun t -> unify_var env (newvar()) t) pat_vars
+  ) half_typed_cases;
+  end_def ();
+  generalize ty_arg';
+  List.iter (fun { pat_vars; _ } ->
+    iter_pattern_variables_type generalize pat_vars
+  ) half_typed_cases;
+  (* type bodies *)
+  let in_function = if List.length caselist = 1 then in_function else None in
+  let cases =
+    List.map
+      (fun { typed_pat = pat; branch_env = ext_env; pat_vars = pvs; unpacks;
+             untyped_case = {pc_lhs = _; pc_guard; pc_rhs};
+             contains_gadt; _ }  ->
+        let ext_env =
+          if contains_gadt then
+            do_copy_types ext_env
+          else
+            ext_env
+        in
+        let ext_env =
+          add_pattern_variables ext_env pvs
+            ~check:(fun s -> Warnings.Unused_var_strict s)
+            ~check_as:(fun s -> Warnings.Unused_var s)
+        in
+        let unpacks =
+          List.map (fun (name, loc) ->
+            name, loc, Uid.mk ~current_unit:(Env.get_unit_name ())
+          ) unpacks
+        in
+        let ty_res' =
+          if !Clflags.principal then begin
+            begin_def ();
+            let ty = instance ~partial:true ty_res in
+            end_def ();
+            generalize_structure ty; ty
+          end
+          else if contains_gadt then
+            (* allow propagation from preceding branches *)
+            correct_levels ty_res
+          else ty_res in
+        let guard =
+          match pc_guard with
+          | None -> None
+          | Some scond ->
+              Some
+                (type_unpacks ext_env unpacks scond
+                   (mk_expected ~explanation:When_guard Predef.type_bool))
+        in
+        let exp =
+          type_unpacks ?in_function ext_env
+            unpacks pc_rhs (mk_expected ?explanation ty_res')
+        in
+        {
+         c_lhs = pat;
+         c_guard = guard;
+         c_rhs = {exp with exp_type = instance ty_res'}
+        }
+      )
+      half_typed_cases
+  in
+  if !Clflags.principal || does_contain_gadt then begin
+    let ty_res' = instance ty_res in
+    List.iter (fun c -> unify_exp env c.c_rhs ty_res') cases
+  end;
+  let do_init = may_contain_gadts || needs_exhaust_check in
+  let ty_arg_check =
+    if do_init then
+      (* Hack: use for_saving to copy variables too *)
+      Subst.type_expr (Subst.for_saving Subst.identity) ty_arg'
+    else ty_arg'
+  in
+  let val_cases, exn_cases =
+    match category with
+      | Value -> (cases : value case list), []
+      | Computation -> split_cases env cases in
+  if val_cases = [] && exn_cases <> [] then
+    raise (Error (loc, env, No_value_clauses));
+  let partial =
+    if partial_flag then
+      check_partial ~lev env ty_arg_check loc val_cases
+    else
+      Partial
+  in
+  let unused_check delayed =
+    List.iter (fun { typed_pat; branch_env; _ } ->
+      check_absent_variant branch_env (as_comp_pattern category typed_pat)
+    ) half_typed_cases;
+    if delayed then (begin_def (); init_def lev);
+    check_unused ~lev env ty_arg_check val_cases ;
+    check_unused ~lev env Predef.type_exn exn_cases ;
+    if delayed then end_def ();
+    Parmatch.check_ambiguous_bindings val_cases ;
+    Parmatch.check_ambiguous_bindings exn_cases
+  in
+  if contains_polyvars then
+    add_delayed_check (fun () -> unused_check true)
+  else
+    (* Check for unused cases, do not delay because of gadts *)
+    unused_check false;
+  if may_contain_gadts then begin
+    end_def ();
+    (* Ensure that existential types do not escape *)
+    unify_exp_types loc env (instance ty_res) (newvar ()) ;
+  end;
+  cases, partial
+
+(* Typing of let bindings *)
+
+and type_let
+    ?(check = fun s -> Warnings.Unused_var s)
+    ?(check_strict = fun s -> Warnings.Unused_var_strict s)
+    existential_context
+    env rec_flag spat_sexp_list allow =
+  let open Ast_helper in
+  begin_def();
+  if !Clflags.principal then begin_def ();
+
+  let is_fake_let =
+    match spat_sexp_list with
+    | [{pvb_expr={pexp_desc=Pexp_match(
+           {pexp_desc=Pexp_ident({ txt = Longident.Lident "*opt*"})},_)}}] ->
+        true (* the fake let-declaration introduced by fun ?(x = e) -> ... *)
+    | _ ->
+        false
+  in
+  let check = if is_fake_let then check_strict else check in
+
+  let spatl =
+    List.map
+      (fun {pvb_pat=spat; pvb_expr=sexp; pvb_attributes=attrs} ->
+        attrs,
+        match spat.ppat_desc, sexp.pexp_desc with
+          (Ppat_any | Ppat_constraint _), _ -> spat
+        | _, Pexp_coerce (_, _, sty)
+        | _, Pexp_constraint (_, sty) when !Clflags.principal ->
+            (* propagate type annotation to pattern,
+               to allow it to be generalized in -principal mode *)
+            Pat.constraint_
+              ~loc:{spat.ppat_loc with Location.loc_ghost=true}
+              spat
+              sty
+        | _ -> spat)
+      spat_sexp_list in
+  let nvs = List.map (fun _ -> newvar ()) spatl in
+  let (pat_list, new_env, force, pvs, unpacks) =
+    type_pattern_list Value existential_context env spatl nvs allow in
+  let attrs_list = List.map fst spatl in
+  let is_recursive = (rec_flag = Recursive) in
+  (* If recursive, first unify with an approximation of the expression *)
+  if is_recursive then
+    List.iter2
+      (fun pat binding ->
+        let pat =
+          match pat.pat_type.desc with
+          | Tpoly (ty, tl) ->
+              {pat with pat_type =
+               snd (instance_poly ~keep_names:true false tl ty)}
+          | _ -> pat
+        in unify_pat (ref env) pat (type_approx env binding.pvb_expr))
+      pat_list spat_sexp_list;
+  (* Polymorphic variant processing *)
+  List.iter
+    (fun pat ->
+      if has_variants pat then begin
+        Parmatch.pressure_variants env [pat];
+        finalize_variants pat
+      end)
+    pat_list;
+  (* Generalize the structure *)
+  let pat_list =
+    if !Clflags.principal then begin
+      end_def ();
+      iter_pattern_variables_type generalize_structure pvs;
+      List.map (fun pat ->
+        generalize_structure pat.pat_type;
+        {pat with pat_type = instance pat.pat_type}
+      ) pat_list
+    end else
+      pat_list
+  in
+  (* Only bind pattern variables after generalizing *)
+  List.iter (fun f -> f()) force;
+  let sexp_is_fun { pvb_expr = sexp; _ } =
+    match sexp.pexp_desc with
+    | Pexp_fun _ | Pexp_function _ -> true
+    | _ -> false
+  in
+  let exp_env =
+    if is_recursive then new_env
+    else if List.for_all sexp_is_fun spat_sexp_list
+    then begin
+      (* Add ghost bindings to help detecting missing "rec" keywords.
+
+         We only add those if the body of the definition is obviously a
+         function. The rationale is that, in other cases, the hint is probably
+         wrong (and the user is using "advanced features" anyway (lazy,
+         recursive values...)).
+
+         [pvb_loc] (below) is the location of the first let-binding (in case of
+         a let .. and ..), and is where the missing "rec" hint suggests to add a
+         "rec" keyword. *)
+      match spat_sexp_list with
+      | {pvb_loc; _} :: _ -> maybe_add_pattern_variables_ghost pvb_loc env pvs
+      | _ -> assert false
+    end
+    else env in
+
+  let current_slot = ref None in
+  let rec_needed = ref false in
+  let warn_about_unused_bindings =
+    List.exists
+      (fun attrs ->
+         Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () ->
+           Warnings.is_active (check "") || Warnings.is_active (check_strict "")
+           || (is_recursive && (Warnings.is_active Warnings.Unused_rec_flag))))
+      attrs_list
+  in
+  let pat_slot_list =
+    (* Algorithm to detect unused declarations in recursive bindings:
+       - During type checking of the definitions, we capture the 'value_used'
+         events on the bound identifiers and record them in a slot corresponding
+         to the current definition (!current_slot).
+         In effect, this creates a dependency graph between definitions.
+
+       - After type checking the definition (!current_slot = None),
+         when one of the bound identifier is effectively used, we trigger
+         again all the events recorded in the corresponding slot.
+         The effect is to traverse the transitive closure of the graph created
+         in the first step.
+
+       We also keep track of whether *all* variables in a given pattern
+       are unused. If this is the case, for local declarations, the issued
+       warning is 26, not 27.
+     *)
+    List.map2
+      (fun attrs pat ->
+         Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () ->
+           if not warn_about_unused_bindings then pat, None
+           else
+             let some_used = ref false in
+             (* has one of the identifier of this pattern been used? *)
+             let slot = ref [] in
+             List.iter
+               (fun id ->
+                  let vd = Env.find_value (Path.Pident id) new_env in
+                  (* note: Env.find_value does not trigger the value_used
+                           event *)
+                  let name = Ident.name id in
+                  let used = ref false in
+                  if not (name = "" || name.[0] = '_' || name.[0] = '#') then
+                    add_delayed_check
+                      (fun () ->
+                         if not !used then
+                           Location.prerr_warning vd.Types.val_loc
+                             ((if !some_used then check_strict else check) name)
+                      );
+                  Env.set_value_used_callback
+                    vd
+                    (fun () ->
+                       match !current_slot with
+                       | Some slot ->
+                         slot := vd.val_uid :: !slot; rec_needed := true
+                       | None ->
+                         List.iter Env.mark_value_used (get_ref slot);
+                         used := true;
+                         some_used := true
+                    )
+               )
+               (Typedtree.pat_bound_idents pat);
+             pat, Some slot
+         ))
+      attrs_list
+      pat_list
+  in
+  let exp_list =
+    List.map2
+      (fun {pvb_expr=sexp; pvb_attributes; _} (pat, slot) ->
+        if is_recursive then current_slot := slot;
+        match pat.pat_type.desc with
+        | Tpoly (ty, tl) ->
+            if !Clflags.principal then begin_def ();
+            let vars, ty' = instance_poly ~keep_names:true true tl ty in
+            if !Clflags.principal then begin
+              end_def ();
+              generalize_structure ty'
+            end;
+            let exp =
+              Builtin_attributes.warning_scope pvb_attributes (fun () ->
+                if rec_flag = Recursive then
+                  type_unpacks exp_env unpacks sexp (mk_expected ty')
+                else
+                  type_expect exp_env sexp (mk_expected ty')
+              )
+            in
+            exp, Some vars
+        | _ ->
+            let exp =
+              Builtin_attributes.warning_scope pvb_attributes (fun () ->
+                  if rec_flag = Recursive then
+                    type_unpacks exp_env unpacks sexp (mk_expected pat.pat_type)
+                  else
+                    type_expect exp_env sexp (mk_expected pat.pat_type))
+            in
+            exp, None)
+      spat_sexp_list pat_slot_list in
+  current_slot := None;
+  if is_recursive && not !rec_needed then begin
+    let {pvb_pat; pvb_attributes} = List.hd spat_sexp_list in
+    (* See PR#6677 *)
+    Builtin_attributes.warning_scope ~ppwarning:false pvb_attributes
+      (fun () ->
+         Location.prerr_warning pvb_pat.ppat_loc Warnings.Unused_rec_flag
+      )
+  end;
+  List.iter2
+    (fun pat (attrs, exp) ->
+       Builtin_attributes.warning_scope ~ppwarning:false attrs
+         (fun () ->
+            ignore(check_partial env pat.pat_type pat.pat_loc
+                     [case pat exp])
+         )
+    )
+    pat_list
+    (List.map2 (fun (attrs, _) (e, _) -> attrs, e) spatl exp_list);
+  let pvs = List.map (fun pv -> { pv with pv_type = instance pv.pv_type}) pvs in
+  end_def();
+  List.iter2
+    (fun pat (exp, _) ->
+       if maybe_expansive exp then
+         lower_contravariant env pat.pat_type)
+    pat_list exp_list;
+  iter_pattern_variables_type generalize pvs;
+  List.iter2
+    (fun pat (exp, vars) ->
+       match vars with
+       | None ->
+         (* We generalize expressions even if they are not bound to a variable
+            and do not have an expliclit polymorphic type annotation.  This is
+            not needed in general, however those types may be shown by the
+            interactive toplevel, for example:
+            {[
+              let _ = Array.get;;
+              - : 'a array -> int -> 'a = <fun>
+            ]}
+            so we do it anyway. *)
+         generalize exp.exp_type
+       | Some vars ->
+           if maybe_expansive exp then
+             lower_contravariant env exp.exp_type;
+           generalize_and_check_univars env "definition" exp pat.pat_type vars)
+    pat_list exp_list;
+  let l = List.combine pat_list exp_list in
+  let l =
+    List.map2
+      (fun (p, (e, _)) pvb ->
+        {vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes;
+         vb_loc=pvb.pvb_loc;
+        })
+      l spat_sexp_list
+  in
+  if is_recursive then
+    List.iter
+      (fun {vb_pat=pat} -> match pat.pat_desc with
+           Tpat_var _ -> ()
+         | Tpat_alias ({pat_desc=Tpat_any}, _, _) -> ()
+         | _ -> raise(Error(pat.pat_loc, env, Illegal_letrec_pat)))
+      l;
+  List.iter (function
+      | {vb_pat = {pat_desc = Tpat_any; pat_extra; _}; vb_expr; _} ->
+          if not (List.exists (function (Tpat_constraint _, _, _) -> true
+                                      | _ -> false) pat_extra) then
+            check_partial_application false vb_expr
+      | _ -> ()) l;
+  (l, new_env, unpacks)
+
+and type_andops env sarg sands expected_ty =
+  let rec loop env let_sarg rev_sands expected_ty =
+    match rev_sands with
+    | [] -> type_expect env let_sarg (mk_expected expected_ty), []
+    | { pbop_op = sop; pbop_exp = sexp; pbop_loc = loc; _ } :: rest ->
+        if !Clflags.principal then begin_def ();
+        let op_path, op_desc = type_binding_op_ident env sop in
+        let op_type = instance op_desc.val_type in
+        let ty_arg = newvar () in
+        let ty_rest = newvar () in
+        let ty_result = newvar() in
+        let ty_rest_fun = newty (Tarrow(Nolabel, ty_arg, ty_result, Cok)) in
+        let ty_op = newty (Tarrow(Nolabel, ty_rest, ty_rest_fun, Cok)) in
+        begin try
+          unify env op_type ty_op
+        with Unify trace ->
+          raise(Error(sop.loc, env, Andop_type_clash(sop.txt, trace)))
+        end;
+        if !Clflags.principal then begin
+          end_def ();
+          generalize_structure ty_rest;
+          generalize_structure ty_arg;
+          generalize_structure ty_result
+        end;
+        let let_arg, rest = loop env let_sarg rest ty_rest in
+        let exp = type_expect env sexp (mk_expected ty_arg) in
+        begin try
+          unify env (instance ty_result) (instance expected_ty)
+        with Unify trace ->
+          raise(Error(loc, env, Bindings_type_clash(trace)))
+        end;
+        let andop =
+          { bop_op_name = sop;
+            bop_op_path = op_path;
+            bop_op_val = op_desc;
+            bop_op_type = op_type;
+            bop_exp = exp;
+            bop_loc = loc }
+        in
+        let_arg, andop :: rest
+  in
+  let let_arg, rev_ands = loop env sarg (List.rev sands) expected_ty in
+  let_arg, List.rev rev_ands
+
+(* Typing of toplevel bindings *)
+
+let type_binding env rec_flag spat_sexp_list =
+  Typetexp.reset_type_variables();
+  let (pat_exp_list, new_env, _unpacks) =
+    type_let
+      ~check:(fun s -> Warnings.Unused_value_declaration s)
+      ~check_strict:(fun s -> Warnings.Unused_value_declaration s)
+      At_toplevel
+      env rec_flag spat_sexp_list false
+  in
+  (pat_exp_list, new_env)
+
+let type_let existential_ctx env rec_flag spat_sexp_list =
+  let (pat_exp_list, new_env, _unpacks) =
+    type_let existential_ctx env rec_flag spat_sexp_list false in
+  (pat_exp_list, new_env)
+
+(* Typing of toplevel expressions *)
+
+let type_expression env sexp =
+  Typetexp.reset_type_variables();
+  begin_def();
+  let exp = type_exp env sexp in
+  end_def();
+  if maybe_expansive exp then lower_contravariant env exp.exp_type;
+  generalize exp.exp_type;
+  match sexp.pexp_desc with
+    Pexp_ident lid ->
+      let loc = sexp.pexp_loc in
+      (* Special case for keeping type variables when looking-up a variable *)
+      let (_path, desc) = Env.lookup_value ~use:false ~loc lid.txt env in
+      {exp with exp_type = desc.val_type}
+  | _ -> exp
+
+(* Error report *)
+
+let spellcheck ppf unbound_name valid_names =
+  Misc.did_you_mean ppf (fun () ->
+    Misc.spellcheck valid_names unbound_name
+  )
+
+let spellcheck_idents ppf unbound valid_idents =
+  spellcheck ppf (Ident.name unbound) (List.map Ident.name valid_idents)
+
+open Format
+
+let longident = Printtyp.longident
+
+(* Returns the first diff of the trace *)
+let type_clash_of_trace trace =
+  Ctype.Unification_trace.(explain trace (fun ~prev:_ -> function
+    | Diff diff -> Some diff
+    | _ -> None
+  ))
+
+(* Hint on type error on integer literals
+   To avoid confusion, it is disabled on float literals
+   and when the expected type is `int` *)
+let report_literal_type_constraint expected_type const =
+  let const_str = match const with
+    | Const_int n -> Some (Int.to_string n)
+    | Const_int32 n -> Some (Int32.to_string n)
+    | Const_int64 n -> Some (Int64.to_string n)
+    | Const_nativeint n -> Some (Nativeint.to_string n)
+    | _ -> None
+  in
+  let suffix =
+    if Path.same expected_type Predef.path_int32 then
+      Some 'l'
+    else if Path.same expected_type Predef.path_int64 then
+      Some 'L'
+    else if Path.same expected_type Predef.path_nativeint then
+      Some 'n'
+    else if Path.same expected_type Predef.path_float then
+      Some '.'
+    else None
+  in
+  match const_str, suffix with
+  | Some c, Some s -> [ Location.msg "@[Hint: Did you mean `%s%c'?@]" c s ]
+  | _, _ -> []
+
+let report_literal_type_constraint const = function
+  | Some Unification_trace.
+    { expected = { t = { desc = Tconstr (typ, [], _) } } } ->
+      report_literal_type_constraint typ const
+  | Some _ | None -> []
+
+let report_expr_type_clash_hints exp diff =
+  match exp with
+  | Some (Texp_constant const) -> report_literal_type_constraint const diff
+  | _ -> []
+
+let report_pattern_type_clash_hints
+      (type k) (pat : k pattern_desc option) diff =
+  match pat with
+  | Some (Tpat_constant const) -> report_literal_type_constraint const diff
+  | _ -> []
+
+let report_type_expected_explanation expl ppf =
+  let because expl_str = fprintf ppf "@ because it is in %s" expl_str in
+  match expl with
+  | If_conditional ->
+      because "the condition of an if-statement"
+  | If_no_else_branch ->
+      because "the result of a conditional with no else branch"
+  | While_loop_conditional ->
+      because "the condition of a while-loop"
+  | While_loop_body ->
+      because "the body of a while-loop"
+  | For_loop_start_index ->
+      because "a for-loop start index"
+  | For_loop_stop_index ->
+      because "a for-loop stop index"
+  | For_loop_body ->
+      because "the body of a for-loop"
+  | Assert_condition ->
+      because "the condition of an assertion"
+  | Sequence_left_hand_side ->
+      because "the left-hand side of a sequence"
+  | When_guard ->
+      because "a when-guard"
+
+let report_type_expected_explanation_opt expl ppf =
+  match expl with
+  | None -> ()
+  | Some expl -> report_type_expected_explanation expl ppf
+
+let report_unification_error ~loc ?sub env trace
+    ?type_expected_explanation txt1 txt2 =
+  Location.error_of_printer ~loc ?sub (fun ppf () ->
+    Printtyp.report_unification_error ppf env trace
+      ?type_expected_explanation txt1 txt2
+  ) ()
+
+let report_error ~loc env = function
+  | Constructor_arity_mismatch(lid, expected, provided) ->
+      Location.errorf ~loc
+       "@[The constructor %a@ expects %i argument(s),@ \
+        but is applied here to %i argument(s)@]"
+       longident lid expected provided
+  | Label_mismatch(lid, trace) ->
+      report_unification_error ~loc env trace
+        (function ppf ->
+           fprintf ppf "The record field %a@ belongs to the type"
+                   longident lid)
+        (function ppf ->
+           fprintf ppf "but is mixed here with fields of type")
+  | Pattern_type_clash (trace, pat) ->
+      let diff = type_clash_of_trace trace in
+      let sub = report_pattern_type_clash_hints pat diff in
+      Location.error_of_printer ~loc ~sub (fun ppf () ->
+        Printtyp.report_unification_error ppf env trace
+          (function ppf ->
+            fprintf ppf "This pattern matches values of type")
+          (function ppf ->
+            fprintf ppf "but a pattern was expected which matches values of \
+                         type");
+      ) ()
+  | Or_pattern_type_clash (id, trace) ->
+      report_unification_error ~loc env trace
+        (function ppf ->
+          fprintf ppf "The variable %s on the left-hand side of this \
+                       or-pattern has type" (Ident.name id))
+        (function ppf ->
+          fprintf ppf "but on the right-hand side it has type")
+  | Multiply_bound_variable name ->
+      Location.errorf ~loc
+        "Variable %s is bound several times in this matching"
+        name
+  | Orpat_vars (id, valid_idents) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        fprintf ppf
+          "Variable %s must occur on both sides of this | pattern"
+          (Ident.name id);
+        spellcheck_idents ppf id valid_idents
+      ) ()
+  | Expr_type_clash (trace, explanation, exp) ->
+      let diff = type_clash_of_trace trace in
+      let sub = report_expr_type_clash_hints exp diff in
+      Location.error_of_printer ~loc ~sub (fun ppf () ->
+        Printtyp.report_unification_error ppf env trace
+          ~type_expected_explanation:
+            (report_type_expected_explanation_opt explanation)
+          (function ppf ->
+             fprintf ppf "This expression has type")
+          (function ppf ->
+             fprintf ppf "but an expression was expected of type");
+      ) ()
+  | Apply_non_function typ ->
+      begin match (repr typ).desc with
+        Tarrow _ ->
+          Location.errorf ~loc
+            "@[<v>@[<2>This function has type@ %a@]\
+             @ @[It is applied to too many arguments;@ %s@]@]"
+            Printtyp.type_expr typ "maybe you forgot a `;'.";
+      | _ ->
+          Location.errorf ~loc "@[<v>@[<2>This expression has type@ %a@]@ %s@]"
+            Printtyp.type_expr typ
+            "This is not a function; it cannot be applied."
+      end
+  | Apply_wrong_label (l, ty, extra_info) ->
+      let print_label ppf = function
+        | Nolabel -> fprintf ppf "without label"
+        | l -> fprintf ppf "with label %s" (prefixed_label_name l)
+      in
+      let extra_info =
+        if not extra_info then
+          []
+        else
+          [ Location.msg
+              "Since OCaml 4.11, optional arguments do not commute when \
+               -nolabels is given" ]
+      in
+      Location.errorf ~loc ~sub:extra_info
+        "@[<v>@[<2>The function applied to this argument has type@ %a@]@.\
+         This argument cannot be applied %a@]"
+        Printtyp.type_expr ty print_label l
+  | Label_multiply_defined s ->
+      Location.errorf ~loc "The record field label %s is defined several times"
+        s
+  | Label_missing labels ->
+      let print_labels ppf =
+        List.iter (fun lbl -> fprintf ppf "@ %s" (Ident.name lbl)) in
+      Location.errorf ~loc "@[<hov>Some record fields are undefined:%a@]"
+        print_labels labels
+  | Label_not_mutable lid ->
+      Location.errorf ~loc "The record field %a is not mutable" longident lid
+  | Wrong_name (eorp, ty_expected, { type_path; kind; name; valid_names; }) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        Printtyp.wrap_printing_env ~error:true env (fun () ->
+          let { ty; explanation } = ty_expected in
+          if Path.is_constructor_typath type_path then begin
+            fprintf ppf
+              "@[The field %s is not part of the record \
+               argument for the %a constructor@]"
+              name.txt
+              Printtyp.type_path type_path;
+          end else begin
+            fprintf ppf
+              "@[@[<2>%s type@ %a%t@]@ \
+               The %s %s does not belong to type %a@]"
+              eorp Printtyp.type_expr ty
+              (report_type_expected_explanation_opt explanation)
+              (Datatype_kind.label_name kind)
+              name.txt (*kind*) Printtyp.type_path type_path;
+          end;
+          spellcheck ppf name.txt valid_names
+      )) ()
+  | Name_type_mismatch (kind, lid, tp, tpl) ->
+      let type_name = Datatype_kind.type_name kind in
+      let name = Datatype_kind.label_name kind in
+      Location.error_of_printer ~loc (fun ppf () ->
+        Printtyp.report_ambiguous_type_error ppf env tp tpl
+          (function ppf ->
+             fprintf ppf "The %s %a@ belongs to the %s type"
+               name longident lid type_name)
+          (function ppf ->
+             fprintf ppf "The %s %a@ belongs to one of the following %s types:"
+               name longident lid type_name)
+          (function ppf ->
+             fprintf ppf "but a %s was expected belonging to the %s type"
+               name type_name)
+      ) ()
+  | Invalid_format msg ->
+      Location.errorf ~loc "%s" msg
+  | Undefined_method (ty, me, valid_methods) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        Printtyp.wrap_printing_env ~error:true env (fun () ->
+          fprintf ppf
+            "@[<v>@[This expression has type@;<1 2>%a@]@,\
+             It has no method %s@]" Printtyp.type_expr ty me;
+          begin match valid_methods with
+            | None -> ()
+            | Some valid_methods -> spellcheck ppf me valid_methods
+          end
+      )) ()
+  | Undefined_inherited_method (me, valid_methods) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        fprintf ppf "This expression has no method %s" me;
+        spellcheck ppf me valid_methods;
+      ) ()
+  | Virtual_class cl ->
+      Location.errorf ~loc "Cannot instantiate the virtual class %a"
+        longident cl
+  | Unbound_instance_variable (var, valid_vars) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        fprintf ppf "Unbound instance variable %s" var;
+        spellcheck ppf var valid_vars;
+      ) ()
+  | Instance_variable_not_mutable v ->
+      Location.errorf ~loc "The instance variable %s is not mutable" v
+  | Not_subtype(tr1, tr2) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        Printtyp.report_subtyping_error ppf env tr1 "is not a subtype of" tr2
+      ) ()
+  | Outside_class ->
+      Location.errorf ~loc
+        "This object duplication occurs outside a method definition"
+  | Value_multiply_overridden v ->
+      Location.errorf ~loc
+        "The instance variable %s is overridden several times"
+        v
+  | Coercion_failure (ty, ty', trace, b) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        Printtyp.report_unification_error ppf env trace
+          (function ppf ->
+             let ty, ty' = Printtyp.prepare_expansion (ty, ty') in
+             fprintf ppf "This expression cannot be coerced to type@;<1 2>%a;@ \
+                          it has type"
+             (Printtyp.type_expansion ty) ty')
+          (function ppf ->
+             fprintf ppf "but is here used with type");
+        if b then
+          fprintf ppf ".@.@[<hov>%s@ %s@ %s@]"
+            "This simple coercion was not fully general."
+            "Hint: Consider using a fully explicit coercion"
+            "of the form: `(foo : ty1 :> ty2)'."
+      ) ()
+  | Too_many_arguments (in_function, ty, explanation) ->
+      if in_function then begin
+        Location.errorf ~loc
+          "This function expects too many arguments,@ \
+           it should have type@ %a%t"
+          Printtyp.type_expr ty
+          (report_type_expected_explanation_opt explanation)
+      end else begin
+        Location.errorf ~loc
+          "This expression should not be a function,@ \
+           the expected type is@ %a%t"
+          Printtyp.type_expr ty
+          (report_type_expected_explanation_opt explanation)
+      end
+  | Abstract_wrong_label (l, ty, explanation) ->
+      let label_mark = function
+        | Nolabel -> "but its first argument is not labelled"
+        | l -> sprintf "but its first argument is labelled %s"
+                       (prefixed_label_name l) in
+      Location.errorf ~loc
+        "@[<v>@[<2>This function should have type@ %a%t@]@,%s@]"
+        Printtyp.type_expr ty
+        (report_type_expected_explanation_opt explanation)
+        (label_mark l)
+  | Scoping_let_module(id, ty) ->
+      Location.errorf ~loc
+        "This `let module' expression has type@ %a@ \
+         In this type, the locally bound module name %s escapes its scope"
+        Printtyp.type_expr ty id
+  | Private_type ty ->
+      Location.errorf ~loc "Cannot create values of the private type %a"
+        Printtyp.type_expr ty
+  | Private_label (lid, ty) ->
+      Location.errorf ~loc "Cannot assign field %a of the private type %a"
+        longident lid Printtyp.type_expr ty
+  | Private_constructor (constr, ty) ->
+      Location.errorf ~loc
+        "Cannot use private constructor %s to create values of type %a"
+        constr.cstr_name Printtyp.type_expr ty
+  | Not_a_variant_type lid ->
+      Location.errorf ~loc "The type %a@ is not a variant type" longident lid
+  | Incoherent_label_order ->
+      Location.errorf ~loc
+        "This function is applied to arguments@ \
+        in an order different from other calls.@ \
+        This is only allowed when the real type is known."
+  | Less_general (kind, trace) ->
+      report_unification_error ~loc env trace
+        (fun ppf -> fprintf ppf "This %s has type" kind)
+        (fun ppf -> fprintf ppf "which is less general than")
+  | Modules_not_allowed ->
+      Location.errorf ~loc "Modules are not allowed in this pattern."
+  | Cannot_infer_signature ->
+      Location.errorf ~loc
+        "The signature for this packaged module couldn't be inferred."
+  | Not_a_packed_module ty ->
+      Location.errorf ~loc
+        "This expression is packed module, but the expected type is@ %a"
+        Printtyp.type_expr ty
+  | Unexpected_existential (reason, name, types) ->
+      let reason_str =
+        match reason with
+        | In_class_args ->
+            "Existential types are not allowed in class arguments"
+        | In_class_def ->
+            "Existential types are not allowed in bindings inside \
+             class definition"
+        | In_self_pattern ->
+            "Existential types are not allowed in self patterns"
+        | At_toplevel ->
+            "Existential types are not allowed in toplevel bindings"
+        | In_group ->
+            "Existential types are not allowed in \"let ... and ...\" bindings"
+        | In_rec ->
+            "Existential types are not allowed in recursive bindings"
+        | With_attributes ->
+            "Existential types are not allowed in presence of attributes"
+      in
+      begin match List.find (fun ty -> ty <> "$" ^ name) types with
+      | example ->
+          Location.errorf ~loc
+            "%s,@ but this pattern introduces the existential type %s."
+            reason_str example
+      | exception Not_found ->
+          Location.errorf ~loc
+            "%s,@ but the constructor %s introduces existential types."
+            reason_str name
+      end
+  | Invalid_interval ->
+      Location.errorf ~loc
+        "@[Only character intervals are supported in patterns.@]"
+  | Invalid_for_loop_index ->
+      Location.errorf ~loc
+        "@[Invalid for-loop index: only variables and _ are allowed.@]"
+  | No_value_clauses ->
+      Location.errorf ~loc
+        "None of the patterns in this 'match' expression match values."
+  | Exception_pattern_disallowed ->
+      Location.errorf ~loc
+        "@[Exception patterns are not allowed in this position.@]"
+  | Mixed_value_and_exception_patterns_under_guard ->
+      Location.errorf ~loc
+        "@[Mixing value and exception patterns under when-guards is not \
+         supported.@]"
+  | Inlined_record_escape ->
+      Location.errorf ~loc
+        "@[This form is not allowed as the type of the inlined record could \
+         escape.@]"
+  | Inlined_record_expected ->
+      Location.errorf ~loc
+        "@[This constructor expects an inlined record argument.@]"
+  | Unrefuted_pattern pat ->
+      Location.errorf ~loc
+        "@[%s@ %s@ %a@]"
+        "This match case could not be refuted."
+        "Here is an example of a value that would reach it:"
+        Printpat.top_pretty pat
+  | Invalid_extension_constructor_payload ->
+      Location.errorf ~loc
+        "Invalid [%%extension_constructor] payload, a constructor is expected."
+  | Not_an_extension_constructor ->
+      Location.errorf ~loc
+        "This constructor is not an extension constructor."
+  | Literal_overflow ty ->
+      Location.errorf ~loc
+        "Integer literal exceeds the range of representable integers of type %s"
+        ty
+  | Unknown_literal (n, m) ->
+      Location.errorf ~loc "Unknown modifier '%c' for literal %s%c" m n m
+  | Illegal_letrec_pat ->
+      Location.errorf ~loc
+        "Only variables are allowed as left-hand side of `let rec'"
+  | Illegal_letrec_expr ->
+      Location.errorf ~loc
+        "This kind of expression is not allowed as right-hand side of `let rec'"
+  | Illegal_class_expr ->
+      Location.errorf ~loc
+        "This kind of recursive class expression is not allowed"
+  | Letop_type_clash(name, trace) ->
+      report_unification_error ~loc env trace
+        (function ppf ->
+          fprintf ppf "The operator %s has type" name)
+        (function ppf ->
+          fprintf ppf "but it was expected to have type")
+  | Andop_type_clash(name, trace) ->
+      report_unification_error ~loc env trace
+        (function ppf ->
+          fprintf ppf "The operator %s has type" name)
+        (function ppf ->
+          fprintf ppf "but it was expected to have type")
+  | Bindings_type_clash(trace) ->
+      report_unification_error ~loc env trace
+        (function ppf ->
+          fprintf ppf "These bindings have type")
+        (function ppf ->
+          fprintf ppf "but bindings were expected of type")
+
+let report_error ~loc env err =
+  Printtyp.wrap_printing_env ~error:true env
+    (fun () -> report_error ~loc env err)
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, env, err) ->
+        Some (report_error ~loc env err)
+      | Error_forward err ->
+        Some err
+      | _ ->
+        None
+    )
+
+let () =
+  Persistent_env.add_delayed_check_forward := add_delayed_check;
+  Env.add_delayed_check_forward := add_delayed_check;
+  ()
+
+(* drop ?recarg argument from the external API *)
+let type_expect ?in_function env e ty = type_expect ?in_function env e ty
+let type_exp env e = type_exp env e
+let type_argument env e t1 t2 = type_argument env e t1 t2
diff --git a/upstream/ocaml_412/typing/typecore.mli b/upstream/ocaml_412/typing/typecore.mli
new file mode 100644
index 0000000..bfaab73
--- /dev/null
+++ b/upstream/ocaml_412/typing/typecore.mli
@@ -0,0 +1,224 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Type inference for the core language *)
+
+open Asttypes
+open Types
+
+(* This variant is used to print improved error messages, and does not affect
+   the behavior of the typechecker itself.
+
+   It describes possible explanation for types enforced by a keyword of the
+   language; e.g. "if" requires the condition to be of type bool, and the
+   then-branch to be of type unit if there is no else branch; "for" requires
+   indices to be of type int, and the body to be of type unit.
+*)
+type type_forcing_context =
+  | If_conditional
+  | If_no_else_branch
+  | While_loop_conditional
+  | While_loop_body
+  | For_loop_start_index
+  | For_loop_stop_index
+  | For_loop_body
+  | Assert_condition
+  | Sequence_left_hand_side
+  | When_guard
+
+(* The combination of a type and a "type forcing context". The intent is that it
+   describes a type that is "expected" (required) by the context. If unifying
+   with such a type fails, then the "explanation" field explains why it was
+   required, in order to display a more enlightening error message.
+*)
+type type_expected = private {
+  ty: type_expr;
+  explanation: type_forcing_context option;
+}
+
+val mk_expected:
+  ?explanation:type_forcing_context ->
+  type_expr ->
+  type_expected
+
+val is_nonexpansive: Typedtree.expression -> bool
+
+module Datatype_kind : sig
+  type t = Record | Variant
+  val type_name : t -> string
+  val label_name : t -> string
+end
+
+type wrong_name = {
+  type_path: Path.t;
+  kind: Datatype_kind.t;
+  name: string loc;
+  valid_names: string list;
+}
+
+type existential_restriction =
+  | At_toplevel (** no existential types at the toplevel *)
+  | In_group (** nor with [let ... and ...] *)
+  | In_rec (** or recursive definition *)
+  | With_attributes (** or [let[@any_attribute] = ...] *)
+  | In_class_args (** or in class arguments [class c (...) = ...] *)
+  | In_class_def (** or in [class c = let ... in ...] *)
+  | In_self_pattern (** or in self pattern *)
+
+val type_binding:
+        Env.t -> rec_flag ->
+          Parsetree.value_binding list ->
+          Typedtree.value_binding list * Env.t
+val type_let:
+        existential_restriction -> Env.t -> rec_flag ->
+          Parsetree.value_binding list ->
+          Typedtree.value_binding list * Env.t
+val type_expression:
+        Env.t -> Parsetree.expression -> Typedtree.expression
+val type_class_arg_pattern:
+        string -> Env.t -> Env.t -> arg_label -> Parsetree.pattern ->
+        Typedtree.pattern *
+        (Ident.t * Ident.t * type_expr) list *
+        Env.t * Env.t
+val type_self_pattern:
+        string -> type_expr -> Env.t -> Env.t -> Env.t -> Parsetree.pattern ->
+        Typedtree.pattern *
+        (Ident.t * type_expr) Meths.t ref *
+        (Ident.t * Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr)
+            Vars.t ref *
+        Env.t * Env.t * Env.t
+val check_partial:
+        ?lev:int -> Env.t -> type_expr ->
+        Location.t -> Typedtree.value Typedtree.case list -> Typedtree.partial
+val type_expect:
+        ?in_function:(Location.t * type_expr) ->
+        Env.t -> Parsetree.expression -> type_expected -> Typedtree.expression
+val type_exp:
+        Env.t -> Parsetree.expression -> Typedtree.expression
+val type_approx:
+        Env.t -> Parsetree.expression -> type_expr
+val type_argument:
+        Env.t -> Parsetree.expression ->
+        type_expr -> type_expr -> Typedtree.expression
+
+val option_some: Env.t -> Typedtree.expression -> Typedtree.expression
+val option_none: Env.t -> type_expr -> Location.t -> Typedtree.expression
+val extract_option_type: Env.t -> type_expr -> type_expr
+val generalizable: int -> type_expr -> bool
+val reset_delayed_checks: unit -> unit
+val force_delayed_checks: unit -> unit
+
+val name_pattern : string -> Typedtree.pattern list -> Ident.t
+val name_cases : string -> Typedtree.value Typedtree.case list -> Ident.t
+
+val self_coercion : (Path.t * Location.t list ref) list ref
+
+type error =
+  | Constructor_arity_mismatch of Longident.t * int * int
+  | Label_mismatch of Longident.t * Ctype.Unification_trace.t
+  | Pattern_type_clash :
+      Ctype.Unification_trace.t * _ Typedtree.pattern_desc option -> error
+  | Or_pattern_type_clash of Ident.t * Ctype.Unification_trace.t
+  | Multiply_bound_variable of string
+  | Orpat_vars of Ident.t * Ident.t list
+  | Expr_type_clash of
+      Ctype.Unification_trace.t * type_forcing_context option
+      * Typedtree.expression_desc option
+  | Apply_non_function of type_expr
+  | Apply_wrong_label of arg_label * type_expr * bool
+  | Label_multiply_defined of string
+  | Label_missing of Ident.t list
+  | Label_not_mutable of Longident.t
+  | Wrong_name of string * type_expected * wrong_name
+  | Name_type_mismatch of
+      Datatype_kind.t * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list
+  | Invalid_format of string
+  | Undefined_method of type_expr * string * string list option
+  | Undefined_inherited_method of string * string list
+  | Virtual_class of Longident.t
+  | Private_type of type_expr
+  | Private_label of Longident.t * type_expr
+  | Private_constructor of constructor_description * type_expr
+  | Unbound_instance_variable of string * string list
+  | Instance_variable_not_mutable of string
+  | Not_subtype of Ctype.Unification_trace.t * Ctype.Unification_trace.t
+  | Outside_class
+  | Value_multiply_overridden of string
+  | Coercion_failure of
+      type_expr * type_expr * Ctype.Unification_trace.t * bool
+  | Too_many_arguments of bool * type_expr * type_forcing_context option
+  | Abstract_wrong_label of arg_label * type_expr * type_forcing_context option
+  | Scoping_let_module of string * type_expr
+  | Not_a_variant_type of Longident.t
+  | Incoherent_label_order
+  | Less_general of string * Ctype.Unification_trace.t
+  | Modules_not_allowed
+  | Cannot_infer_signature
+  | Not_a_packed_module of type_expr
+  | Unexpected_existential of existential_restriction * string * string list
+  | Invalid_interval
+  | Invalid_for_loop_index
+  | No_value_clauses
+  | Exception_pattern_disallowed
+  | Mixed_value_and_exception_patterns_under_guard
+  | Inlined_record_escape
+  | Inlined_record_expected
+  | Unrefuted_pattern of Typedtree.pattern
+  | Invalid_extension_constructor_payload
+  | Not_an_extension_constructor
+  | Literal_overflow of string
+  | Unknown_literal of string * char
+  | Illegal_letrec_pat
+  | Illegal_letrec_expr
+  | Illegal_class_expr
+  | Letop_type_clash of string * Ctype.Unification_trace.t
+  | Andop_type_clash of string * Ctype.Unification_trace.t
+  | Bindings_type_clash of Ctype.Unification_trace.t
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+val report_error: loc:Location.t -> Env.t -> error -> Location.error
+ (** @deprecated.  Use {!Location.error_of_exn}, {!Location.print_report}. *)
+
+(* Forward declaration, to be filled in by Typemod.type_module *)
+val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref
+(* Forward declaration, to be filled in by Typemod.type_open *)
+val type_open:
+  (?used_slot:bool ref -> override_flag -> Env.t -> Location.t ->
+   Longident.t loc -> Path.t * Env.t)
+    ref
+(* Forward declaration, to be filled in by Typemod.type_open_decl *)
+val type_open_decl:
+  (?used_slot:bool ref -> Env.t -> Parsetree.open_declaration ->
+   Typedtree.open_declaration * Types.signature * Env.t)
+    ref
+(* Forward declaration, to be filled in by Typeclass.class_structure *)
+val type_object:
+  (Env.t -> Location.t -> Parsetree.class_structure ->
+   Typedtree.class_structure * Types.class_signature * string list) ref
+val type_package:
+  (Env.t -> Parsetree.module_expr -> Path.t -> Longident.t list ->
+  Typedtree.module_expr * type_expr list) ref
+
+val create_package_type : Location.t -> Env.t ->
+  Longident.t * (Longident.t * Parsetree.core_type) list ->
+  Path.t * (Longident.t * Typedtree.core_type) list * Types.type_expr
+
+val constant: Parsetree.constant -> (Asttypes.constant, error) result
+
+val check_recursive_bindings : Env.t -> Typedtree.value_binding list -> unit
+val check_recursive_class_bindings :
+  Env.t -> Ident.t list -> Typedtree.class_expr list -> unit
diff --git a/upstream/ocaml_412/typing/typedecl.ml b/upstream/ocaml_412/typing/typedecl.ml
new file mode 100644
index 0000000..b9bb074
--- /dev/null
+++ b/upstream/ocaml_412/typing/typedecl.ml
@@ -0,0 +1,1882 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(**** Typing of type definitions ****)
+
+open Misc
+open Asttypes
+open Parsetree
+open Primitive
+open Types
+open Typetexp
+
+module String = Misc.Stdlib.String
+
+type native_repr_kind = Unboxed | Untagged
+
+type error =
+    Repeated_parameter
+  | Duplicate_constructor of string
+  | Too_many_constructors
+  | Duplicate_label of string
+  | Recursive_abbrev of string
+  | Cycle_in_def of string * type_expr
+  | Definition_mismatch of type_expr * Includecore.type_mismatch option
+  | Constraint_failed of type_expr * type_expr
+  | Inconsistent_constraint of Env.t * Ctype.Unification_trace.t
+  | Type_clash of Env.t * Ctype.Unification_trace.t
+  | Non_regular of {
+      definition: Path.t;
+      used_as: type_expr;
+      defined_as: type_expr;
+      expansions: (type_expr * type_expr) list;
+    }
+  | Null_arity_external
+  | Missing_native_external
+  | Unbound_type_var of type_expr * type_declaration
+  | Cannot_extend_private_type of Path.t
+  | Not_extensible_type of Path.t
+  | Extension_mismatch of Path.t * Includecore.type_mismatch
+  | Rebind_wrong_type of Longident.t * Env.t * Ctype.Unification_trace.t
+  | Rebind_mismatch of Longident.t * Path.t * Path.t
+  | Rebind_private of Longident.t
+  | Variance of Typedecl_variance.error
+  | Unavailable_type_constructor of Path.t
+  | Bad_fixed_type of string
+  | Unbound_type_var_ext of type_expr * extension_constructor
+  | Val_in_structure
+  | Multiple_native_repr_attributes
+  | Cannot_unbox_or_untag_type of native_repr_kind
+  | Deep_unbox_or_untag_attribute of native_repr_kind
+  | Immediacy of Typedecl_immediacy.error
+  | Separability of Typedecl_separability.error
+  | Bad_unboxed_attribute of string
+  | Boxed_and_unboxed
+  | Nonrec_gadt
+
+open Typedtree
+
+exception Error of Location.t * error
+
+(* Note: do not factor the branches in the following pattern-matching:
+   the records must be constants for the compiler to do sharing on them.
+*)
+let get_unboxed_from_attributes sdecl =
+  let unboxed = Builtin_attributes.has_unboxed sdecl.ptype_attributes in
+  let boxed = Builtin_attributes.has_boxed sdecl.ptype_attributes in
+  match boxed, unboxed, !Clflags.unboxed_types with
+  | true, true, _ -> raise (Error(sdecl.ptype_loc, Boxed_and_unboxed))
+  | true, false, _ -> unboxed_false_default_false
+  | false, true, _ -> unboxed_true_default_false
+  | false, false, false -> unboxed_false_default_true
+  | false, false, true -> unboxed_true_default_true
+
+(* Enter all declared types in the environment as abstract types *)
+
+let add_type ~check id decl env =
+  Builtin_attributes.warning_scope ~ppwarning:false decl.type_attributes
+    (fun () -> Env.add_type ~check id decl env)
+
+let enter_type rec_flag env sdecl (id, uid) =
+  let needed =
+    match rec_flag with
+    | Asttypes.Nonrecursive ->
+        begin match sdecl.ptype_kind with
+        | Ptype_variant scds ->
+            List.iter (fun cd ->
+              if cd.pcd_res <> None then raise (Error(cd.pcd_loc, Nonrec_gadt)))
+              scds
+        | _ -> ()
+        end;
+        Btype.is_row_name (Ident.name id)
+    | Asttypes.Recursive -> true
+  in
+  let arity = List.length sdecl.ptype_params in
+  if not needed then env else
+  let decl =
+    { type_params =
+        List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params;
+      type_arity = arity;
+      type_kind = Type_abstract;
+      type_private = sdecl.ptype_private;
+      type_manifest =
+        begin match sdecl.ptype_manifest with None -> None
+        | Some _ -> Some(Ctype.newvar ()) end;
+      type_variance = Variance.unknown_signature ~injective:false ~arity;
+      type_separability = Types.Separability.default_signature ~arity;
+      type_is_newtype = false;
+      type_expansion_scope = Btype.lowest_level;
+      type_loc = sdecl.ptype_loc;
+      type_attributes = sdecl.ptype_attributes;
+      type_immediate = Unknown;
+      type_unboxed = unboxed_false_default_false;
+      type_uid = uid;
+    }
+  in
+  add_type ~check:true id decl env
+
+let update_type temp_env env id loc =
+  let path = Path.Pident id in
+  let decl = Env.find_type path temp_env in
+  match decl.type_manifest with None -> ()
+  | Some ty ->
+      let params = List.map (fun _ -> Ctype.newvar ()) decl.type_params in
+      try Ctype.unify env (Ctype.newconstr path params) ty
+      with Ctype.Unify trace ->
+        raise (Error(loc, Type_clash (env, trace)))
+
+let get_unboxed_type_representation env ty =
+  match Typedecl_unboxed.get_unboxed_type_representation env ty with
+  | Typedecl_unboxed.This x -> Some x
+  | _ -> None
+
+(* Determine if a type's values are represented by floats at run-time. *)
+let is_float env ty =
+  match get_unboxed_type_representation env ty with
+    Some {desc = Tconstr(p, _, _); _} -> Path.same p Predef.path_float
+  | _ -> false
+
+(* Determine if a type definition defines a fixed type. (PW) *)
+let is_fixed_type sd =
+  let rec has_row_var sty =
+    match sty.ptyp_desc with
+      Ptyp_alias (sty, _) -> has_row_var sty
+    | Ptyp_class _
+    | Ptyp_object (_, Open)
+    | Ptyp_variant (_, Open, _)
+    | Ptyp_variant (_, Closed, Some _) -> true
+    | _ -> false
+  in
+  match sd.ptype_manifest with
+    None -> false
+  | Some sty ->
+      sd.ptype_kind = Ptype_abstract &&
+      sd.ptype_private = Private &&
+      has_row_var sty
+
+(* Set the row variable in a fixed type *)
+let set_fixed_row env loc p decl =
+  let tm =
+    match decl.type_manifest with
+      None -> assert false
+    | Some t -> Ctype.expand_head env t
+  in
+  let rv =
+    match tm.desc with
+      Tvariant row ->
+        let row = Btype.row_repr row in
+        tm.desc <- Tvariant {row with row_fixed = Some Fixed_private};
+        if Btype.static_row row then Btype.newgenty Tnil
+        else row.row_more
+    | Tobject (ty, _) ->
+        snd (Ctype.flatten_fields ty)
+    | _ ->
+        raise (Error (loc, Bad_fixed_type "is not an object or variant"))
+  in
+  if not (Btype.is_Tvar rv) then
+    raise (Error (loc, Bad_fixed_type "has no row variable"));
+  rv.desc <- Tconstr (p, decl.type_params, ref Mnil)
+
+(* Translate one type declaration *)
+
+let make_params env params =
+  let make_param (sty, v) =
+    try
+      (transl_type_param env sty, v)
+    with Already_bound ->
+      raise(Error(sty.ptyp_loc, Repeated_parameter))
+  in
+    List.map make_param params
+
+let transl_labels env closed lbls =
+  assert (lbls <> []);
+  let all_labels = ref String.Set.empty in
+  List.iter
+    (fun {pld_name = {txt=name; loc}} ->
+       if String.Set.mem name !all_labels then
+         raise(Error(loc, Duplicate_label name));
+       all_labels := String.Set.add name !all_labels)
+    lbls;
+  let mk {pld_name=name;pld_mutable=mut;pld_type=arg;pld_loc=loc;
+          pld_attributes=attrs} =
+    Builtin_attributes.warning_scope attrs
+      (fun () ->
+         let arg = Ast_helper.Typ.force_poly arg in
+         let cty = transl_simple_type env closed arg in
+         {ld_id = Ident.create_local name.txt;
+          ld_name = name; ld_mutable = mut;
+          ld_type = cty; ld_loc = loc; ld_attributes = attrs}
+      )
+  in
+  let lbls = List.map mk lbls in
+  let lbls' =
+    List.map
+      (fun ld ->
+         let ty = ld.ld_type.ctyp_type in
+         let ty = match ty.desc with Tpoly(t,[]) -> t | _ -> ty in
+         {Types.ld_id = ld.ld_id;
+          ld_mutable = ld.ld_mutable;
+          ld_type = ty;
+          ld_loc = ld.ld_loc;
+          ld_attributes = ld.ld_attributes;
+          ld_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+         }
+      )
+      lbls in
+  lbls, lbls'
+
+let transl_constructor_arguments env closed = function
+  | Pcstr_tuple l ->
+      let l = List.map (transl_simple_type env closed) l in
+      Types.Cstr_tuple (List.map (fun t -> t.ctyp_type) l),
+      Cstr_tuple l
+  | Pcstr_record l ->
+      let lbls, lbls' = transl_labels env closed l in
+      Types.Cstr_record lbls',
+      Cstr_record lbls
+
+let make_constructor env type_path type_params sargs sret_type =
+  match sret_type with
+  | None ->
+      let args, targs =
+        transl_constructor_arguments env true sargs
+      in
+        targs, None, args, None
+  | Some sret_type ->
+      (* if it's a generalized constructor we must first narrow and
+         then widen so as to not introduce any new constraints *)
+      let z = narrow () in
+      reset_type_variables ();
+      let args, targs =
+        transl_constructor_arguments env false sargs
+      in
+      let tret_type = transl_simple_type env false sret_type in
+      let ret_type = tret_type.ctyp_type in
+      (* TODO add back type_path as a parameter ? *)
+      begin match (Ctype.repr ret_type).desc with
+        | Tconstr (p', _, _) when Path.same type_path p' -> ()
+        | _ ->
+            raise (Error (sret_type.ptyp_loc, Constraint_failed
+                            (ret_type, Ctype.newconstr type_path type_params)))
+      end;
+      widen z;
+      targs, Some tret_type, args, Some ret_type
+
+let transl_declaration env sdecl (id, uid) =
+  (* Bind type parameters *)
+  reset_type_variables();
+  Ctype.begin_def ();
+  let tparams = make_params env sdecl.ptype_params in
+  let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in
+  let cstrs = List.map
+    (fun (sty, sty', loc) ->
+      transl_simple_type env false sty,
+      transl_simple_type env false sty', loc)
+    sdecl.ptype_cstrs
+  in
+  let raw_status = get_unboxed_from_attributes sdecl in
+  if raw_status.unboxed && not raw_status.default then begin
+    let bad msg = raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute msg)) in
+    match sdecl.ptype_kind with
+    | Ptype_abstract    -> bad "it is abstract"
+    | Ptype_open        -> bad "extensible variant types cannot be unboxed"
+    | Ptype_record fields -> begin match fields with
+        | [] -> bad "it has no fields"
+        | _::_::_ -> bad "it has more than one field"
+        | [{pld_mutable = Mutable}] -> bad "it is mutable"
+        | [{pld_mutable = Immutable}] -> ()
+      end
+    | Ptype_variant constructors -> begin match constructors with
+        | [] -> bad "it has no constructor"
+        | (_::_::_) -> bad "it has more than one constructor"
+        | [c] -> begin match c.pcd_args with
+            | Pcstr_tuple [] ->
+                bad "its constructor has no argument"
+            | Pcstr_tuple (_::_::_) ->
+                bad "its constructor has more than one argument"
+            | Pcstr_tuple [_]  ->
+                ()
+            | Pcstr_record [] ->
+                bad "its constructor has no fields"
+            | Pcstr_record (_::_::_) ->
+                bad "its constructor has more than one field"
+            | Pcstr_record [{pld_mutable = Mutable}] ->
+                bad "it is mutable"
+            | Pcstr_record [{pld_mutable = Immutable}] ->
+                ()
+          end
+      end
+  end;
+  let unboxed_status =
+    match sdecl.ptype_kind with
+    | Ptype_variant [{pcd_args = Pcstr_tuple [_]; _}]
+    | Ptype_variant [{pcd_args = Pcstr_record [{pld_mutable=Immutable; _}]; _}]
+    | Ptype_record [{pld_mutable=Immutable; _}] -> raw_status
+    | _ -> unboxed_false_default_false (* Not unboxable, mark as boxed *)
+  in
+  let unbox = unboxed_status.unboxed in
+  let (tkind, kind) =
+    match sdecl.ptype_kind with
+      | Ptype_abstract -> Ttype_abstract, Type_abstract
+      | Ptype_variant scstrs ->
+        if List.exists (fun cstr -> cstr.pcd_res <> None) scstrs then begin
+          match cstrs with
+            [] -> ()
+          | (_,_,loc)::_ ->
+              Location.prerr_warning loc Warnings.Constraint_on_gadt
+        end;
+        let all_constrs = ref String.Set.empty in
+        List.iter
+          (fun {pcd_name = {txt = name}} ->
+            if String.Set.mem name !all_constrs then
+              raise(Error(sdecl.ptype_loc, Duplicate_constructor name));
+            all_constrs := String.Set.add name !all_constrs)
+          scstrs;
+        if List.length
+            (List.filter (fun cd -> cd.pcd_args <> Pcstr_tuple []) scstrs)
+           > (Config.max_tag + 1) then
+          raise(Error(sdecl.ptype_loc, Too_many_constructors));
+        let make_cstr scstr =
+          let name = Ident.create_local scstr.pcd_name.txt in
+          let targs, tret_type, args, ret_type =
+            make_constructor env (Path.Pident id) params
+                             scstr.pcd_args scstr.pcd_res
+          in
+          let tcstr =
+            { cd_id = name;
+              cd_name = scstr.pcd_name;
+              cd_args = targs;
+              cd_res = tret_type;
+              cd_loc = scstr.pcd_loc;
+              cd_attributes = scstr.pcd_attributes }
+          in
+          let cstr =
+            { Types.cd_id = name;
+              cd_args = args;
+              cd_res = ret_type;
+              cd_loc = scstr.pcd_loc;
+              cd_attributes = scstr.pcd_attributes;
+              cd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) }
+          in
+            tcstr, cstr
+        in
+        let make_cstr scstr =
+          Builtin_attributes.warning_scope scstr.pcd_attributes
+            (fun () -> make_cstr scstr)
+        in
+        let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in
+          Ttype_variant tcstrs, Type_variant cstrs
+      | Ptype_record lbls ->
+          let lbls, lbls' = transl_labels env true lbls in
+          let rep =
+            if unbox then Record_unboxed false
+            else if List.for_all (fun l -> is_float env l.Types.ld_type) lbls'
+            then Record_float
+            else Record_regular
+          in
+          Ttype_record lbls, Type_record(lbls', rep)
+      | Ptype_open -> Ttype_open, Type_open
+      in
+    let (tman, man) = match sdecl.ptype_manifest with
+        None -> None, None
+      | Some sty ->
+        let no_row = not (is_fixed_type sdecl) in
+        let cty = transl_simple_type env no_row sty in
+        Some cty, Some cty.ctyp_type
+    in
+    let arity = List.length params in
+    let decl =
+      { type_params = params;
+        type_arity = arity;
+        type_kind = kind;
+        type_private = sdecl.ptype_private;
+        type_manifest = man;
+        type_variance = Variance.unknown_signature ~injective:false ~arity;
+        type_separability = Types.Separability.default_signature ~arity;
+        type_is_newtype = false;
+        type_expansion_scope = Btype.lowest_level;
+        type_loc = sdecl.ptype_loc;
+        type_attributes = sdecl.ptype_attributes;
+        type_immediate = Unknown;
+        type_unboxed = unboxed_status;
+        type_uid = uid;
+      } in
+
+  (* Check constraints *)
+    List.iter
+      (fun (cty, cty', loc) ->
+        let ty = cty.ctyp_type in
+        let ty' = cty'.ctyp_type in
+        try Ctype.unify env ty ty' with Ctype.Unify tr ->
+          raise(Error(loc, Inconsistent_constraint (env, tr))))
+      cstrs;
+    Ctype.end_def ();
+  (* Add abstract row *)
+    if is_fixed_type sdecl then begin
+      let p, _ =
+        try Env.find_type_by_name
+              (Longident.Lident(Ident.name id ^ "#row")) env
+        with Not_found -> assert false
+      in
+      set_fixed_row env sdecl.ptype_loc p decl
+    end;
+  (* Check for cyclic abbreviations *)
+    begin match decl.type_manifest with None -> ()
+      | Some ty ->
+        if Ctype.cyclic_abbrev env id ty then
+          raise(Error(sdecl.ptype_loc, Recursive_abbrev sdecl.ptype_name.txt));
+    end;
+    {
+      typ_id = id;
+      typ_name = sdecl.ptype_name;
+      typ_params = tparams;
+      typ_type = decl;
+      typ_cstrs = cstrs;
+      typ_loc = sdecl.ptype_loc;
+      typ_manifest = tman;
+      typ_kind = tkind;
+      typ_private = sdecl.ptype_private;
+      typ_attributes = sdecl.ptype_attributes;
+    }
+
+(* Generalize a type declaration *)
+
+let generalize_decl decl =
+  List.iter Ctype.generalize decl.type_params;
+  Btype.iter_type_expr_kind Ctype.generalize decl.type_kind;
+  begin match decl.type_manifest with
+  | None    -> ()
+  | Some ty -> Ctype.generalize ty
+  end
+
+(* Check that all constraints are enforced *)
+
+module TypeSet = Btype.TypeSet
+module TypeMap = Btype.TypeMap
+
+let rec check_constraints_rec env loc visited ty =
+  let ty = Ctype.repr ty in
+  if TypeSet.mem ty !visited then () else begin
+  visited := TypeSet.add ty !visited;
+  match ty.desc with
+  | Tconstr (path, args, _) ->
+      let args' = List.map (fun _ -> Ctype.newvar ()) args in
+      let ty' = Ctype.newconstr path args' in
+      begin try Ctype.enforce_constraints env ty'
+      with Ctype.Unify _ -> assert false
+      | Not_found -> raise (Error(loc, Unavailable_type_constructor path))
+      end;
+      if not (Ctype.matches env ty ty') then
+        raise (Error(loc, Constraint_failed (ty, ty')));
+      List.iter (check_constraints_rec env loc visited) args
+  | Tpoly (ty, tl) ->
+      let _, ty = Ctype.instance_poly false tl ty in
+      check_constraints_rec env loc visited ty
+  | _ ->
+      Btype.iter_type_expr (check_constraints_rec env loc visited) ty
+  end
+
+let check_constraints_labels env visited l pl =
+  let rec get_loc name = function
+      [] -> assert false
+    | pld :: tl ->
+        if name = pld.pld_name.txt then pld.pld_type.ptyp_loc
+        else get_loc name tl
+  in
+  List.iter
+    (fun {Types.ld_id=name; ld_type=ty} ->
+       check_constraints_rec env (get_loc (Ident.name name) pl) visited ty)
+    l
+
+let check_constraints env sdecl (_, decl) =
+  let visited = ref TypeSet.empty in
+  List.iter2
+    (fun (sty, _) ty -> check_constraints_rec env sty.ptyp_loc visited ty)
+    sdecl.ptype_params decl.type_params;
+  begin match decl.type_kind with
+  | Type_abstract -> ()
+  | Type_variant l ->
+      let find_pl = function
+          Ptype_variant pl -> pl
+        | Ptype_record _ | Ptype_abstract | Ptype_open -> assert false
+      in
+      let pl = find_pl sdecl.ptype_kind in
+      let pl_index =
+        let foldf acc x =
+          String.Map.add x.pcd_name.txt x acc
+        in
+        List.fold_left foldf String.Map.empty pl
+      in
+      List.iter
+        (fun {Types.cd_id=name; cd_args; cd_res} ->
+          let {pcd_args; pcd_res; _} =
+            try String.Map.find (Ident.name name) pl_index
+            with Not_found -> assert false in
+          begin match cd_args, pcd_args with
+          | Cstr_tuple tyl, Pcstr_tuple styl ->
+              List.iter2
+                (fun sty ty ->
+                   check_constraints_rec env sty.ptyp_loc visited ty)
+                styl tyl
+          | Cstr_record tyl, Pcstr_record styl ->
+              check_constraints_labels env visited tyl styl
+          | _ -> assert false
+          end;
+          match pcd_res, cd_res with
+          | Some sr, Some r ->
+              check_constraints_rec env sr.ptyp_loc visited r
+          | _ ->
+              () )
+        l
+  | Type_record (l, _) ->
+      let find_pl = function
+          Ptype_record pl -> pl
+        | Ptype_variant _ | Ptype_abstract | Ptype_open -> assert false
+      in
+      let pl = find_pl sdecl.ptype_kind in
+      check_constraints_labels env visited l pl
+  | Type_open -> ()
+  end;
+  begin match decl.type_manifest with
+  | None -> ()
+  | Some ty ->
+      let sty =
+        match sdecl.ptype_manifest with Some sty -> sty | _ -> assert false
+      in
+      check_constraints_rec env sty.ptyp_loc visited ty
+  end
+
+(*
+   If both a variant/record definition and a type equation are given,
+   need to check that the equation refers to a type of the same kind
+   with the same constructors and labels.
+*)
+let check_coherence env loc dpath decl =
+  match decl with
+    { type_kind = (Type_variant _ | Type_record _| Type_open);
+      type_manifest = Some ty } ->
+      begin match (Ctype.repr ty).desc with
+        Tconstr(path, args, _) ->
+          begin try
+            let decl' = Env.find_type path env in
+            let err =
+              if List.length args <> List.length decl.type_params
+              then Some Includecore.Arity
+              else if not (Ctype.equal env false args decl.type_params)
+              then Some Includecore.Constraint
+              else
+                Includecore.type_declarations ~loc ~equality:true env
+                  ~mark:true
+                  (Path.last path)
+                  decl'
+                  dpath
+                  (Subst.type_declaration
+                     (Subst.add_type_path dpath path Subst.identity) decl)
+            in
+            if err <> None then
+              raise(Error(loc, Definition_mismatch (ty, err)))
+          with Not_found ->
+            raise(Error(loc, Unavailable_type_constructor path))
+          end
+      | _ -> raise(Error(loc, Definition_mismatch (ty, None)))
+      end
+  | _ -> ()
+
+let check_abbrev env sdecl (id, decl) =
+  check_coherence env sdecl.ptype_loc (Path.Pident id) decl
+
+(* Check that recursion is well-founded *)
+
+let check_well_founded env loc path to_check ty =
+  let visited = ref TypeMap.empty in
+  let rec check ty0 parents ty =
+    let ty = Btype.repr ty in
+    if TypeSet.mem ty parents then begin
+      (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*)
+      if match ty0.desc with
+      | Tconstr (p, _, _) -> Path.same p path
+      | _ -> false
+      then raise (Error (loc, Recursive_abbrev (Path.name path)))
+      else raise (Error (loc, Cycle_in_def (Path.name path, ty0)))
+    end;
+    let (fini, parents) =
+      try
+        let prev = TypeMap.find ty !visited in
+        if TypeSet.subset parents prev then (true, parents) else
+        (false, TypeSet.union parents prev)
+      with Not_found ->
+        (false, parents)
+    in
+    if fini then () else
+    let rec_ok =
+      match ty.desc with
+        Tconstr(p,_,_) ->
+          !Clflags.recursive_types && Ctype.is_contractive env p
+      | Tobject _ | Tvariant _ -> true
+      | _ -> !Clflags.recursive_types
+    in
+    let visited' = TypeMap.add ty parents !visited in
+    let arg_exn =
+      try
+        visited := visited';
+        let parents =
+          if rec_ok then TypeSet.empty else TypeSet.add ty parents in
+        Btype.iter_type_expr (check ty0 parents) ty;
+        None
+      with e ->
+        visited := visited'; Some e
+    in
+    match ty.desc with
+    | Tconstr(p, _, _) when arg_exn <> None || to_check p ->
+        if to_check p then Option.iter raise arg_exn
+        else Btype.iter_type_expr (check ty0 TypeSet.empty) ty;
+        begin try
+          let ty' = Ctype.try_expand_once_opt env ty in
+          let ty0 = if TypeSet.is_empty parents then ty else ty0 in
+          check ty0 (TypeSet.add ty parents) ty'
+        with
+          Ctype.Cannot_expand -> Option.iter raise arg_exn
+        end
+    | _ -> Option.iter raise arg_exn
+  in
+  let snap = Btype.snapshot () in
+  try Ctype.wrap_trace_gadt_instances env (check ty TypeSet.empty) ty
+  with Ctype.Unify _ ->
+    (* Will be detected by check_recursion *)
+    Btype.backtrack snap
+
+let check_well_founded_manifest env loc path decl =
+  if decl.type_manifest = None then () else
+  let args = List.map (fun _ -> Ctype.newvar()) decl.type_params in
+  check_well_founded env loc path (Path.same path) (Ctype.newconstr path args)
+
+let check_well_founded_decl env loc path decl to_check =
+  let open Btype in
+  let it =
+    {type_iterators with
+     it_type_expr = (fun _ -> check_well_founded env loc path to_check)} in
+  it.it_type_declaration it (Ctype.generic_instance_declaration decl)
+
+(* Check for ill-defined abbrevs *)
+
+let check_recursion ~orig_env env loc path decl to_check =
+  (* to_check is true for potentially mutually recursive paths.
+     (path, decl) is the type declaration to be checked. *)
+
+  if decl.type_params = [] then () else
+
+  let visited = ref [] in
+
+  let rec check_regular cpath args prev_exp prev_expansions ty =
+    let ty = Ctype.repr ty in
+    if not (List.memq ty !visited) then begin
+      visited := ty :: !visited;
+      match ty.desc with
+      | Tconstr(path', args', _) ->
+          if Path.same path path' then begin
+            if not (Ctype.equal orig_env false args args') then
+              raise (Error(loc,
+                     Non_regular {
+                       definition=path;
+                       used_as=ty;
+                       defined_as=Ctype.newconstr path args;
+                       expansions=List.rev prev_expansions;
+                     }))
+          end
+          (* Attempt to expand a type abbreviation if:
+              1- [to_check path'] holds
+                 (otherwise the expansion cannot involve [path]);
+              2- we haven't expanded this type constructor before
+                 (otherwise we could loop if [path'] is itself
+                 a non-regular abbreviation). *)
+          else if to_check path' && not (List.mem path' prev_exp) then begin
+            try
+              (* Attempt expansion *)
+              let (params0, body0, _) = Env.find_type_expansion path' env in
+              let (params, body) =
+                Ctype.instance_parameterized_type params0 body0 in
+              begin
+                try List.iter2 (Ctype.unify orig_env) params args'
+                with Ctype.Unify _ ->
+                  raise (Error(loc, Constraint_failed
+                                 (ty, Ctype.newconstr path' params0)));
+              end;
+              check_regular path' args
+                (path' :: prev_exp) ((ty,body) :: prev_expansions)
+                body
+            with Not_found -> ()
+          end;
+          List.iter (check_regular cpath args prev_exp prev_expansions) args'
+      | Tpoly (ty, tl) ->
+          let (_, ty) = Ctype.instance_poly ~keep_names:true false tl ty in
+          check_regular cpath args prev_exp prev_expansions ty
+      | _ ->
+          Btype.iter_type_expr
+            (check_regular cpath args prev_exp prev_expansions) ty
+    end in
+
+  Option.iter
+    (fun body ->
+      let (args, body) =
+        Ctype.instance_parameterized_type
+          ~keep_names:true decl.type_params body in
+      List.iter (check_regular path args [] []) args;
+      check_regular path args [] [] body)
+    decl.type_manifest
+
+let check_abbrev_recursion ~orig_env env id_loc_list to_check tdecl =
+  let decl = tdecl.typ_type in
+  let id = tdecl.typ_id in
+  check_recursion ~orig_env env (List.assoc id id_loc_list) (Path.Pident id)
+    decl to_check
+
+let check_duplicates sdecl_list =
+  let labels = Hashtbl.create 7 and constrs = Hashtbl.create 7 in
+  List.iter
+    (fun sdecl -> match sdecl.ptype_kind with
+      Ptype_variant cl ->
+        List.iter
+          (fun pcd ->
+            try
+              let name' = Hashtbl.find constrs pcd.pcd_name.txt in
+              Location.prerr_warning pcd.pcd_loc
+                (Warnings.Duplicate_definitions
+                   ("constructor", pcd.pcd_name.txt, name',
+                    sdecl.ptype_name.txt))
+            with Not_found ->
+              Hashtbl.add constrs pcd.pcd_name.txt sdecl.ptype_name.txt)
+          cl
+    | Ptype_record fl ->
+        List.iter
+          (fun {pld_name=cname;pld_loc=loc} ->
+            try
+              let name' = Hashtbl.find labels cname.txt in
+              Location.prerr_warning loc
+                (Warnings.Duplicate_definitions
+                   ("label", cname.txt, name', sdecl.ptype_name.txt))
+            with Not_found -> Hashtbl.add labels cname.txt sdecl.ptype_name.txt)
+          fl
+    | Ptype_abstract -> ()
+    | Ptype_open -> ())
+    sdecl_list
+
+(* Force recursion to go through id for private types*)
+let name_recursion sdecl id decl =
+  match decl with
+  | { type_kind = Type_abstract;
+      type_manifest = Some ty;
+      type_private = Private; } when is_fixed_type sdecl ->
+    let ty = Ctype.repr ty in
+    let ty' = Btype.newty2 ty.level ty.desc in
+    if Ctype.deep_occur ty ty' then
+      let td = Tconstr(Path.Pident id, decl.type_params, ref Mnil) in
+      Btype.link_type ty (Btype.newty2 ty.level td);
+      {decl with type_manifest = Some ty'}
+    else decl
+  | _ -> decl
+
+let name_recursion_decls sdecls decls =
+  List.map2 (fun sdecl (id, decl) -> (id, name_recursion sdecl id decl))
+    sdecls decls
+
+(* Warn on definitions of type "type foo = ()" which redefine a different unit
+   type and are likely a mistake. *)
+let check_redefined_unit (td: Parsetree.type_declaration) =
+  let open Parsetree in
+  let is_unit_constructor cd = cd.pcd_name.txt = "()" in
+  match td with
+  | { ptype_name = { txt = name };
+      ptype_manifest = None;
+      ptype_kind = Ptype_variant [ cd ] }
+    when is_unit_constructor cd ->
+      Location.prerr_warning td.ptype_loc (Warnings.Redefining_unit name)
+  | _ ->
+      ()
+
+let add_types_to_env decls env =
+  List.fold_right
+    (fun (id, decl) env -> add_type ~check:true id decl env)
+    decls env
+
+(* Translate a set of type declarations, mutually recursive or not *)
+let transl_type_decl env rec_flag sdecl_list =
+  List.iter check_redefined_unit sdecl_list;
+  (* Add dummy types for fixed rows *)
+  let fixed_types = List.filter is_fixed_type sdecl_list in
+  let sdecl_list =
+    List.map
+      (fun sdecl ->
+         let ptype_name =
+           let loc = { sdecl.ptype_name.loc with Location.loc_ghost = true } in
+           mkloc (sdecl.ptype_name.txt ^"#row") loc
+         in
+         let ptype_kind = Ptype_abstract in
+         let ptype_manifest = None in
+         let ptype_loc = { sdecl.ptype_loc with Location.loc_ghost = true } in
+        {sdecl with
+           ptype_name; ptype_kind; ptype_manifest; ptype_loc })
+      fixed_types
+    @ sdecl_list
+  in
+
+  (* Create identifiers. *)
+  let scope = Ctype.create_scope () in
+  let ids_list =
+    List.map (fun sdecl ->
+      Ident.create_scoped ~scope sdecl.ptype_name.txt,
+      Uid.mk ~current_unit:(Env.get_unit_name ())
+    ) sdecl_list
+  in
+  Ctype.begin_def();
+  (* Enter types. *)
+  let temp_env =
+    List.fold_left2 (enter_type rec_flag) env sdecl_list ids_list in
+  (* Translate each declaration. *)
+  let current_slot = ref None in
+  let warn_unused = Warnings.is_active (Warnings.Unused_type_declaration "") in
+  let ids_slots (id, _uid as ids) =
+    match rec_flag with
+    | Asttypes.Recursive when warn_unused ->
+        (* See typecore.ml for a description of the algorithm used
+             to detect unused declarations in a set of recursive definitions. *)
+        let slot = ref [] in
+        let td = Env.find_type (Path.Pident id) temp_env in
+        Env.set_type_used_callback
+          td
+          (fun old_callback ->
+             match !current_slot with
+             | Some slot -> slot := td.type_uid :: !slot
+             | None ->
+                 List.iter Env.mark_type_used (get_ref slot);
+                 old_callback ()
+          );
+        ids, Some slot
+    | Asttypes.Recursive | Asttypes.Nonrecursive ->
+        ids, None
+  in
+  let transl_declaration name_sdecl (id, slot) =
+    current_slot := slot;
+    Builtin_attributes.warning_scope
+      name_sdecl.ptype_attributes
+      (fun () -> transl_declaration temp_env name_sdecl id)
+  in
+  let tdecls =
+    List.map2 transl_declaration sdecl_list (List.map ids_slots ids_list) in
+  let decls =
+    List.map (fun tdecl -> (tdecl.typ_id, tdecl.typ_type)) tdecls in
+  current_slot := None;
+  (* Check for duplicates *)
+  check_duplicates sdecl_list;
+  (* Build the final env. *)
+  let new_env = add_types_to_env decls env in
+  (* Update stubs *)
+  begin match rec_flag with
+    | Asttypes.Nonrecursive -> ()
+    | Asttypes.Recursive ->
+      List.iter2
+        (fun (id, _) sdecl -> update_type temp_env new_env id sdecl.ptype_loc)
+        ids_list sdecl_list
+  end;
+  (* Generalize type declarations. *)
+  Ctype.end_def();
+  List.iter (fun (_, decl) -> generalize_decl decl) decls;
+  (* Check for ill-formed abbrevs *)
+  let id_loc_list =
+    List.map2 (fun (id, _) sdecl -> (id, sdecl.ptype_loc))
+      ids_list sdecl_list
+  in
+  List.iter (fun (id, decl) ->
+    check_well_founded_manifest new_env (List.assoc id id_loc_list)
+      (Path.Pident id) decl)
+    decls;
+  let to_check =
+    function Path.Pident id -> List.mem_assoc id id_loc_list | _ -> false in
+  List.iter (fun (id, decl) ->
+    check_well_founded_decl new_env (List.assoc id id_loc_list) (Path.Pident id)
+      decl to_check)
+    decls;
+  List.iter
+    (check_abbrev_recursion ~orig_env:env new_env id_loc_list to_check) tdecls;
+  (* Check that all type variables are closed *)
+  List.iter2
+    (fun sdecl tdecl ->
+      let decl = tdecl.typ_type in
+       match Ctype.closed_type_decl decl with
+         Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl)))
+       | None   -> ())
+    sdecl_list tdecls;
+  (* Check that constraints are enforced *)
+  List.iter2 (check_constraints new_env) sdecl_list decls;
+  (* Add type properties to declarations *)
+  let decls =
+    try
+      decls
+      |> name_recursion_decls sdecl_list
+      |> Typedecl_variance.update_decls env sdecl_list
+      |> Typedecl_immediacy.update_decls env
+      |> Typedecl_separability.update_decls env
+    with
+    | Typedecl_variance.Error (loc, err) ->
+        raise (Error (loc, Variance err))
+    | Typedecl_immediacy.Error (loc, err) ->
+        raise (Error (loc, Immediacy err))
+    | Typedecl_separability.Error (loc, err) ->
+        raise (Error (loc, Separability err))
+  in
+  (* Compute the final environment with variance and immediacy *)
+  let final_env = add_types_to_env decls env in
+  (* Check re-exportation *)
+  List.iter2 (check_abbrev final_env) sdecl_list decls;
+  (* Keep original declaration *)
+  let final_decls =
+    List.map2
+      (fun tdecl (_id2, decl) ->
+        { tdecl with typ_type = decl }
+      ) tdecls decls
+  in
+  (* Done *)
+  (final_decls, final_env)
+
+(* Translating type extensions *)
+
+let transl_extension_constructor ~scope env type_path type_params
+                                 typext_params priv sext =
+  let id = Ident.create_scoped ~scope sext.pext_name.txt in
+  let args, ret_type, kind =
+    match sext.pext_kind with
+      Pext_decl(sargs, sret_type) ->
+        let targs, tret_type, args, ret_type =
+          make_constructor env type_path typext_params
+            sargs sret_type
+        in
+          args, ret_type, Text_decl(targs, tret_type)
+    | Pext_rebind lid ->
+        let usage = if priv = Public then Env.Positive else Env.Privatize in
+        let cdescr = Env.lookup_constructor ~loc:lid.loc usage lid.txt env in
+        let (args, cstr_res) = Ctype.instance_constructor cdescr in
+        let res, ret_type =
+          if cdescr.cstr_generalized then
+            let params = Ctype.instance_list type_params in
+            let res = Ctype.newconstr type_path params in
+            let ret_type = Some (Ctype.newconstr type_path params) in
+              res, ret_type
+          else (Ctype.newconstr type_path typext_params), None
+        in
+        begin
+          try
+            Ctype.unify env cstr_res res
+          with Ctype.Unify trace ->
+            raise (Error(lid.loc,
+                     Rebind_wrong_type(lid.txt, env, trace)))
+        end;
+        (* Remove "_" names from parameters used in the constructor *)
+        if not cdescr.cstr_generalized then begin
+          let vars =
+            Ctype.free_variables (Btype.newgenty (Ttuple args))
+          in
+            List.iter
+              (function {desc = Tvar (Some "_")} as ty ->
+                          if List.memq ty vars then ty.desc <- Tvar None
+                        | _ -> ())
+              typext_params
+        end;
+        (* Ensure that constructor's type matches the type being extended *)
+        let cstr_type_path, cstr_type_params =
+          match cdescr.cstr_res.desc with
+            Tconstr (p, _, _) ->
+              let decl = Env.find_type p env in
+                p, decl.type_params
+          | _ -> assert false
+        in
+        let cstr_types =
+          (Btype.newgenty
+             (Tconstr(cstr_type_path, cstr_type_params, ref Mnil)))
+          :: cstr_type_params
+        in
+        let ext_types =
+          (Btype.newgenty
+             (Tconstr(type_path, type_params, ref Mnil)))
+          :: type_params
+        in
+        if not (Ctype.equal env true cstr_types ext_types) then
+          raise (Error(lid.loc,
+                       Rebind_mismatch(lid.txt, cstr_type_path, type_path)));
+        (* Disallow rebinding private constructors to non-private *)
+        begin
+          match cdescr.cstr_private, priv with
+            Private, Public ->
+              raise (Error(lid.loc, Rebind_private lid.txt))
+          | _ -> ()
+        end;
+        let path =
+          match cdescr.cstr_tag with
+            Cstr_extension(path, _) -> path
+          | _ -> assert false
+        in
+        let args =
+          match cdescr.cstr_inlined with
+          | None ->
+              Types.Cstr_tuple args
+          | Some decl ->
+              let tl =
+                match args with
+                | [ {desc=Tconstr(_, tl, _)} ] -> tl
+                | _ -> assert false
+              in
+              let decl = Ctype.instance_declaration decl in
+              assert (List.length decl.type_params = List.length tl);
+              List.iter2 (Ctype.unify env) decl.type_params tl;
+              let lbls =
+                match decl.type_kind with
+                | Type_record (lbls, Record_extension _) -> lbls
+                | _ -> assert false
+              in
+              Types.Cstr_record lbls
+        in
+        args, ret_type, Text_rebind(path, lid)
+  in
+  let ext =
+    { ext_type_path = type_path;
+      ext_type_params = typext_params;
+      ext_args = args;
+      ext_ret_type = ret_type;
+      ext_private = priv;
+      Types.ext_loc = sext.pext_loc;
+      Types.ext_attributes = sext.pext_attributes;
+      ext_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+    }
+  in
+    { ext_id = id;
+      ext_name = sext.pext_name;
+      ext_type = ext;
+      ext_kind = kind;
+      Typedtree.ext_loc = sext.pext_loc;
+      Typedtree.ext_attributes = sext.pext_attributes; }
+
+let transl_extension_constructor ~scope env type_path type_params
+    typext_params priv sext =
+  Builtin_attributes.warning_scope sext.pext_attributes
+    (fun () -> transl_extension_constructor ~scope env type_path type_params
+        typext_params priv sext)
+
+let is_rebind ext =
+  match ext.ext_kind with
+  | Text_rebind _ -> true
+  | Text_decl _ -> false
+
+let transl_type_extension extend env loc styext =
+  (* Note: it would be incorrect to call [create_scope] *after*
+     [reset_type_variables] or after [begin_def] (see #10010). *)
+  let scope = Ctype.create_scope () in
+  reset_type_variables();
+  Ctype.begin_def();
+  let type_path, type_decl =
+    let lid = styext.ptyext_path in
+    Env.lookup_type ~loc:lid.loc lid.txt env
+  in
+  begin
+    match type_decl.type_kind with
+    | Type_open -> begin
+        match type_decl.type_private with
+        | Private when extend -> begin
+            match
+              List.find
+                (function {pext_kind = Pext_decl _} -> true
+                        | {pext_kind = Pext_rebind _} -> false)
+                styext.ptyext_constructors
+            with
+            | {pext_loc} ->
+                raise (Error(pext_loc, Cannot_extend_private_type type_path))
+            | exception Not_found -> ()
+          end
+        | _ -> ()
+      end
+    | _ ->
+        raise (Error(loc, Not_extensible_type type_path))
+  end;
+  let type_variance =
+    List.map (fun v ->
+                let (co, cn) = Variance.get_upper v in
+                  (not cn, not co, false))
+             type_decl.type_variance
+  in
+  let err =
+    if type_decl.type_arity <> List.length styext.ptyext_params then
+      Some Includecore.Arity
+    else
+      if List.for_all2
+           (fun (c1, n1, _) (c2, n2, _) -> (not c2 || c1) && (not n2 || n1))
+           type_variance
+           (Typedecl_variance.variance_of_params styext.ptyext_params)
+      then None else Some Includecore.Variance
+  in
+  begin match err with
+  | None -> ()
+  | Some err -> raise (Error(loc, Extension_mismatch (type_path, err)))
+  end;
+  let ttype_params = make_params env styext.ptyext_params in
+  let type_params = List.map (fun (cty, _) -> cty.ctyp_type) ttype_params in
+  List.iter2 (Ctype.unify_var env)
+    (Ctype.instance_list type_decl.type_params)
+    type_params;
+  let constructors =
+    List.map (transl_extension_constructor ~scope env type_path
+               type_decl.type_params type_params styext.ptyext_private)
+      styext.ptyext_constructors
+  in
+  Ctype.end_def();
+  (* Generalize types *)
+  List.iter Ctype.generalize type_params;
+  List.iter
+    (fun ext ->
+       Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args;
+       Option.iter Ctype.generalize ext.ext_type.ext_ret_type)
+    constructors;
+  (* Check that all type variables are closed *)
+  List.iter
+    (fun ext ->
+       match Ctype.closed_extension_constructor ext.ext_type with
+         Some ty ->
+           raise(Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type)))
+       | None -> ())
+    constructors;
+  (* Check variances are correct *)
+  List.iter
+    (fun ext->
+       (* Note that [loc] here is distinct from [type_decl.type_loc], which
+          makes the [loc] parameter to this function useful. [loc] is the
+          location of the extension, while [type_decl] points to the original
+          type declaration being extended. *)
+       try Typedecl_variance.check_variance_extension
+             env type_decl ext (type_variance, loc)
+       with Typedecl_variance.Error (loc, err) ->
+         raise (Error (loc, Variance err)))
+    constructors;
+  (* Add extension constructors to the environment *)
+  let newenv =
+    List.fold_left
+      (fun env ext ->
+         let rebind = is_rebind ext in
+         Env.add_extension ~check:true ~rebind ext.ext_id ext.ext_type env)
+      env constructors
+  in
+  let tyext =
+    { tyext_path = type_path;
+      tyext_txt = styext.ptyext_path;
+      tyext_params = ttype_params;
+      tyext_constructors = constructors;
+      tyext_private = styext.ptyext_private;
+      tyext_loc = styext.ptyext_loc;
+      tyext_attributes = styext.ptyext_attributes; }
+  in
+    (tyext, newenv)
+
+let transl_type_extension extend env loc styext =
+  Builtin_attributes.warning_scope styext.ptyext_attributes
+    (fun () -> transl_type_extension extend env loc styext)
+
+let transl_exception env sext =
+  let scope = Ctype.create_scope () in
+  reset_type_variables();
+  Ctype.begin_def();
+  let ext =
+    transl_extension_constructor ~scope env
+      Predef.path_exn [] [] Asttypes.Public sext
+  in
+  Ctype.end_def();
+  (* Generalize types *)
+  Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args;
+  Option.iter Ctype.generalize ext.ext_type.ext_ret_type;
+  (* Check that all type variables are closed *)
+  begin match Ctype.closed_extension_constructor ext.ext_type with
+    Some ty ->
+      raise (Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type)))
+  | None -> ()
+  end;
+  let rebind = is_rebind ext in
+  let newenv =
+    Env.add_extension ~check:true ~rebind ext.ext_id ext.ext_type env
+  in
+  ext, newenv
+
+let transl_type_exception env t =
+  Builtin_attributes.check_no_alert t.ptyexn_attributes;
+  let contructor, newenv =
+    Builtin_attributes.warning_scope t.ptyexn_attributes
+      (fun () ->
+         transl_exception env t.ptyexn_constructor
+      )
+  in
+  {tyexn_constructor = contructor;
+   tyexn_loc = t.ptyexn_loc;
+   tyexn_attributes = t.ptyexn_attributes}, newenv
+
+
+type native_repr_attribute =
+  | Native_repr_attr_absent
+  | Native_repr_attr_present of native_repr_kind
+
+let get_native_repr_attribute attrs ~global_repr =
+  match
+    Attr_helper.get_no_payload_attribute ["unboxed"; "ocaml.unboxed"]  attrs,
+    Attr_helper.get_no_payload_attribute ["untagged"; "ocaml.untagged"] attrs,
+    global_repr
+  with
+  | None, None, None -> Native_repr_attr_absent
+  | None, None, Some repr -> Native_repr_attr_present repr
+  | Some _, None, None -> Native_repr_attr_present Unboxed
+  | None, Some _, None -> Native_repr_attr_present Untagged
+  | Some { Location.loc }, _, _
+  | _, Some { Location.loc }, _ ->
+    raise (Error (loc, Multiple_native_repr_attributes))
+
+let native_repr_of_type env kind ty =
+  match kind, (Ctype.expand_head_opt env ty).desc with
+  | Untagged, Tconstr (path, _, _) when Path.same path Predef.path_int ->
+    Some Untagged_int
+  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_float ->
+    Some Unboxed_float
+  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int32 ->
+    Some (Unboxed_integer Pint32)
+  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int64 ->
+    Some (Unboxed_integer Pint64)
+  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_nativeint ->
+    Some (Unboxed_integer Pnativeint)
+  | _ ->
+    None
+
+(* Raises an error when [core_type] contains an [@unboxed] or [@untagged]
+   attribute in a strict sub-term. *)
+let error_if_has_deep_native_repr_attributes core_type =
+  let open Ast_iterator in
+  let this_iterator =
+    { default_iterator with typ = fun iterator core_type ->
+      begin
+        match
+          get_native_repr_attribute core_type.ptyp_attributes ~global_repr:None
+        with
+        | Native_repr_attr_present kind ->
+           raise (Error (core_type.ptyp_loc,
+                         Deep_unbox_or_untag_attribute kind))
+        | Native_repr_attr_absent -> ()
+      end;
+      default_iterator.typ iterator core_type }
+  in
+  default_iterator.typ this_iterator core_type
+
+let make_native_repr env core_type ty ~global_repr =
+  error_if_has_deep_native_repr_attributes core_type;
+  match get_native_repr_attribute core_type.ptyp_attributes ~global_repr with
+  | Native_repr_attr_absent ->
+    Same_as_ocaml_repr
+  | Native_repr_attr_present kind ->
+    begin match native_repr_of_type env kind ty with
+    | None ->
+      raise (Error (core_type.ptyp_loc, Cannot_unbox_or_untag_type kind))
+    | Some repr -> repr
+    end
+
+let rec parse_native_repr_attributes env core_type ty ~global_repr =
+  match core_type.ptyp_desc, (Ctype.repr ty).desc,
+    get_native_repr_attribute core_type.ptyp_attributes ~global_repr:None
+  with
+  | Ptyp_arrow _, Tarrow _, Native_repr_attr_present kind  ->
+    raise (Error (core_type.ptyp_loc, Cannot_unbox_or_untag_type kind))
+  | Ptyp_arrow (_, ct1, ct2), Tarrow (_, t1, t2, _), _ ->
+    let repr_arg = make_native_repr env ct1 t1 ~global_repr in
+    let repr_args, repr_res =
+      parse_native_repr_attributes env ct2 t2 ~global_repr
+    in
+    (repr_arg :: repr_args, repr_res)
+  | Ptyp_arrow _, _, _ | _, Tarrow _, _ -> assert false
+  | _ -> ([], make_native_repr env core_type ty ~global_repr)
+
+
+let check_unboxable env loc ty =
+  let check_type acc ty : Path.Set.t =
+    let ty = Ctype.repr (Ctype.expand_head_opt env ty) in
+    try match ty.desc with
+      | Tconstr (p, _, _) ->
+        let tydecl = Env.find_type p env in
+        if tydecl.type_unboxed.default then
+          Path.Set.add p acc
+        else acc
+      | _ -> acc
+    with Not_found -> acc
+  in
+  let all_unboxable_types = Btype.fold_type_expr check_type Path.Set.empty ty in
+  Path.Set.fold
+    (fun p () ->
+       Location.prerr_warning loc
+         (Warnings.Unboxable_type_in_prim_decl (Path.name p))
+    )
+    all_unboxable_types
+    ()
+
+(* Translate a value declaration *)
+let transl_value_decl env loc valdecl =
+  let cty = Typetexp.transl_type_scheme env valdecl.pval_type in
+  let ty = cty.ctyp_type in
+  let v =
+  match valdecl.pval_prim with
+    [] when Env.is_in_signature env ->
+      { val_type = ty; val_kind = Val_reg; Types.val_loc = loc;
+        val_attributes = valdecl.pval_attributes;
+        val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+      }
+  | [] ->
+      raise (Error(valdecl.pval_loc, Val_in_structure))
+  | _ ->
+      let global_repr =
+        match
+          get_native_repr_attribute valdecl.pval_attributes ~global_repr:None
+        with
+        | Native_repr_attr_present repr -> Some repr
+        | Native_repr_attr_absent -> None
+      in
+      let native_repr_args, native_repr_res =
+        parse_native_repr_attributes env valdecl.pval_type ty ~global_repr
+      in
+      let prim =
+        Primitive.parse_declaration valdecl
+          ~native_repr_args
+          ~native_repr_res
+      in
+      if prim.prim_arity = 0 &&
+         (prim.prim_name = "" || prim.prim_name.[0] <> '%') then
+        raise(Error(valdecl.pval_type.ptyp_loc, Null_arity_external));
+      if !Clflags.native_code
+      && prim.prim_arity > 5
+      && prim.prim_native_name = ""
+      then raise(Error(valdecl.pval_type.ptyp_loc, Missing_native_external));
+      check_unboxable env loc ty;
+      { val_type = ty; val_kind = Val_prim prim; Types.val_loc = loc;
+        val_attributes = valdecl.pval_attributes;
+        val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+      }
+  in
+  let (id, newenv) =
+    Env.enter_value valdecl.pval_name.txt v env
+      ~check:(fun s -> Warnings.Unused_value_declaration s)
+  in
+  let desc =
+    {
+     val_id = id;
+     val_name = valdecl.pval_name;
+     val_desc = cty; val_val = v;
+     val_prim = valdecl.pval_prim;
+     val_loc = valdecl.pval_loc;
+     val_attributes = valdecl.pval_attributes;
+    }
+  in
+  desc, newenv
+
+let transl_value_decl env loc valdecl =
+  Builtin_attributes.warning_scope valdecl.pval_attributes
+    (fun () -> transl_value_decl env loc valdecl)
+
+(* Translate a "with" constraint -- much simplified version of
+   transl_type_decl. For a constraint [Sig with t = sdecl],
+   there are two declarations of interest in two environments:
+   - [sig_decl] is the declaration of [t] in [Sig],
+     in the environment [sig_env] (containing the declarations
+     of [Sig] before [t])
+   - [sdecl] is the new syntactic declaration, to be type-checked
+     in the current, outer environment [with_env].
+
+   In particular, note that [sig_env] is an extension of
+   [outer_env].
+*)
+let transl_with_constraint id row_path ~sig_env ~sig_decl ~outer_env sdecl =
+  Env.mark_type_used sig_decl.type_uid;
+  reset_type_variables();
+  Ctype.begin_def();
+  (* In the first part of this function, we typecheck the syntactic
+     declaration [sdecl] in the outer environment [outer_env]. *)
+  let env = outer_env in
+  let loc = sdecl.ptype_loc in
+  let tparams = make_params env sdecl.ptype_params in
+  let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in
+  let arity = List.length params in
+  let constraints =
+    List.map (fun (ty, ty', loc) ->
+      let cty = transl_simple_type env false ty in
+      let cty' = transl_simple_type env false ty' in
+      (* Note: We delay the unification of those constraints
+         after the unification of parameters, so that clashing
+         constraints report an error on the constraint location
+         rather than the parameter location. *)
+      (cty, cty', loc)
+    ) sdecl.ptype_cstrs
+  in
+  let no_row = not (is_fixed_type sdecl) in
+  let (tman, man) =  match sdecl.ptype_manifest with
+      None -> None, None
+    | Some sty ->
+        let cty = transl_simple_type env no_row sty in
+        Some cty, Some cty.ctyp_type
+  in
+  (* In the second part, we check the consistency between the two
+     declarations and compute a "merged" declaration; we now need to
+     work in the larger signature environment [sig_env], because
+     [sig_decl.type_params] and [sig_decl.type_kind] are only valid
+     there. *)
+  let env = sig_env in
+  let sig_decl = Ctype.instance_declaration sig_decl in
+  let arity_ok = arity = sig_decl.type_arity in
+  if arity_ok then
+    List.iter2 (fun (cty, _) tparam ->
+      try Ctype.unify_var env cty.ctyp_type tparam
+      with Ctype.Unify tr ->
+        raise(Error(cty.ctyp_loc, Inconsistent_constraint (env, tr)))
+    ) tparams sig_decl.type_params;
+  List.iter (fun (cty, cty', loc) ->
+    (* Note: constraints must also be enforced in [sig_env] because
+       they may contain parameter variables from [tparams]
+       that have now be unified in [sig_env]. *)
+    try Ctype.unify env cty.ctyp_type cty'.ctyp_type
+    with Ctype.Unify tr ->
+      raise(Error(loc, Inconsistent_constraint (env, tr)))
+  ) constraints;
+  let priv =
+    if sdecl.ptype_private = Private then Private else
+    if arity_ok && sig_decl.type_kind <> Type_abstract
+    then sig_decl.type_private else sdecl.ptype_private
+  in
+  if arity_ok && sig_decl.type_kind <> Type_abstract
+  && sdecl.ptype_private = Private then
+    Location.deprecated loc "spurious use of private";
+  let type_kind, type_unboxed =
+    if arity_ok && man <> None then
+      sig_decl.type_kind, sig_decl.type_unboxed
+    else
+      Type_abstract, unboxed_false_default_false
+  in
+  let new_sig_decl =
+    { type_params = params;
+      type_arity = arity;
+      type_kind;
+      type_private = priv;
+      type_manifest = man;
+      type_variance = [];
+      type_separability = Types.Separability.default_signature ~arity;
+      type_is_newtype = false;
+      type_expansion_scope = Btype.lowest_level;
+      type_loc = loc;
+      type_attributes = sdecl.ptype_attributes;
+      type_immediate = Unknown;
+      type_unboxed;
+      type_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+    }
+  in
+  begin match row_path with None -> ()
+  | Some p -> set_fixed_row env loc p new_sig_decl
+  end;
+  begin match Ctype.closed_type_decl new_sig_decl with None -> ()
+  | Some ty -> raise(Error(loc, Unbound_type_var(ty, new_sig_decl)))
+  end;
+  let new_sig_decl = name_recursion sdecl id new_sig_decl in
+  let new_type_variance =
+    let required = Typedecl_variance.variance_of_sdecl sdecl in
+    try
+      Typedecl_variance.compute_decl env ~check:true new_sig_decl required
+    with Typedecl_variance.Error (loc, err) ->
+      raise (Error (loc, Variance err)) in
+  let new_type_immediate =
+    (* Typedecl_immediacy.compute_decl never raises *)
+    Typedecl_immediacy.compute_decl env new_sig_decl in
+  let new_type_separability =
+    try Typedecl_separability.compute_decl env new_sig_decl
+    with Typedecl_separability.Error (loc, err) ->
+      raise (Error (loc, Separability err)) in
+  let new_sig_decl =
+    (* we intentionally write this without a fragile { decl with ... }
+       to ensure that people adding new fields to type declarations
+       consider whether they need to recompute it here; for an example
+       of bug caused by the previous approach, see #9607 *)
+    {
+      type_params = new_sig_decl.type_params;
+      type_arity = new_sig_decl.type_arity;
+      type_kind = new_sig_decl.type_kind;
+      type_private = new_sig_decl.type_private;
+      type_manifest = new_sig_decl.type_manifest;
+      type_unboxed = new_sig_decl.type_unboxed;
+      type_is_newtype = new_sig_decl.type_is_newtype;
+      type_expansion_scope = new_sig_decl.type_expansion_scope;
+      type_loc = new_sig_decl.type_loc;
+      type_attributes = new_sig_decl.type_attributes;
+      type_uid = new_sig_decl.type_uid;
+
+      type_variance = new_type_variance;
+      type_immediate = new_type_immediate;
+      type_separability = new_type_separability;
+    } in
+  Ctype.end_def();
+  generalize_decl new_sig_decl;
+  {
+    typ_id = id;
+    typ_name = sdecl.ptype_name;
+    typ_params = tparams;
+    typ_type = new_sig_decl;
+    typ_cstrs = constraints;
+    typ_loc = loc;
+    typ_manifest = tman;
+    typ_kind = Ttype_abstract;
+    typ_private = sdecl.ptype_private;
+    typ_attributes = sdecl.ptype_attributes;
+  }
+
+(* Approximate a type declaration: just make all types abstract *)
+
+let abstract_type_decl ~injective arity =
+  let rec make_params n =
+    if n <= 0 then [] else Ctype.newvar() :: make_params (n-1) in
+  Ctype.begin_def();
+  let decl =
+    { type_params = make_params arity;
+      type_arity = arity;
+      type_kind = Type_abstract;
+      type_private = Public;
+      type_manifest = None;
+      type_variance = Variance.unknown_signature ~injective ~arity;
+      type_separability = Types.Separability.default_signature ~arity;
+      type_is_newtype = false;
+      type_expansion_scope = Btype.lowest_level;
+      type_loc = Location.none;
+      type_attributes = [];
+      type_immediate = Unknown;
+      type_unboxed = unboxed_false_default_false;
+      type_uid = Uid.internal_not_actually_unique;
+     } in
+  Ctype.end_def();
+  generalize_decl decl;
+  decl
+
+let approx_type_decl sdecl_list =
+  let scope = Ctype.create_scope () in
+  List.map
+    (fun sdecl ->
+      let injective = sdecl.ptype_kind <> Ptype_abstract in
+      (Ident.create_scoped ~scope sdecl.ptype_name.txt,
+       abstract_type_decl ~injective (List.length sdecl.ptype_params)))
+    sdecl_list
+
+(* Variant of check_abbrev_recursion to check the well-formedness
+   conditions on type abbreviations defined within recursive modules. *)
+
+let check_recmod_typedecl env loc recmod_ids path decl =
+  (* recmod_ids is the list of recursively-defined module idents.
+     (path, decl) is the type declaration to be checked. *)
+  let to_check path = Path.exists_free recmod_ids path in
+  check_well_founded_decl env loc path decl to_check;
+  check_recursion ~orig_env:env env loc path decl to_check;
+  (* additionally check coherece, as one might build an incoherent signature,
+     and use it to build an incoherent module, cf. #7851 *)
+  check_coherence env loc path decl
+
+
+(**** Error report ****)
+
+open Format
+
+let explain_unbound_gen ppf tv tl typ kwd pr =
+  try
+    let ti = List.find (fun ti -> Ctype.deep_occur tv (typ ti)) tl in
+    let ty0 = (* Hack to force aliasing when needed *)
+      Btype.newgenty (Tobject(tv, ref None)) in
+    Printtyp.reset_and_mark_loops_list [typ ti; ty0];
+    fprintf ppf
+      ".@.@[<hov2>In %s@ %a@;<1 -2>the variable %a is unbound@]"
+      kwd pr ti Printtyp.marked_type_expr tv
+  with Not_found -> ()
+
+let explain_unbound ppf tv tl typ kwd lab =
+  explain_unbound_gen ppf tv tl typ kwd
+    (fun ppf ti ->
+       fprintf ppf "%s%a" (lab ti) Printtyp.marked_type_expr (typ ti)
+    )
+
+let explain_unbound_single ppf tv ty =
+  let trivial ty =
+    explain_unbound ppf tv [ty] (fun t -> t) "type" (fun _ -> "") in
+  match (Ctype.repr ty).desc with
+    Tobject(fi,_) ->
+      let (tl, rv) = Ctype.flatten_fields fi in
+      if rv == tv then trivial ty else
+      explain_unbound ppf tv tl (fun (_,_,t) -> t)
+        "method" (fun (lab,_,_) -> lab ^ ": ")
+  | Tvariant row ->
+      let row = Btype.row_repr row in
+      if row.row_more == tv then trivial ty else
+      explain_unbound ppf tv row.row_fields
+        (fun (_l,f) -> match Btype.row_field_repr f with
+          Rpresent (Some t) -> t
+        | Reither (_,[t],_,_) -> t
+        | Reither (_,tl,_,_) -> Btype.newgenty (Ttuple tl)
+        | _ -> Btype.newgenty (Ttuple[]))
+        "case" (fun (lab,_) -> "`" ^ lab ^ " of ")
+  | _ -> trivial ty
+
+
+let tys_of_constr_args = function
+  | Types.Cstr_tuple tl -> tl
+  | Types.Cstr_record lbls -> List.map (fun l -> l.Types.ld_type) lbls
+
+let report_error ppf = function
+  | Repeated_parameter ->
+      fprintf ppf "A type parameter occurs several times"
+  | Duplicate_constructor s ->
+      fprintf ppf "Two constructors are named %s" s
+  | Too_many_constructors ->
+      fprintf ppf
+        "@[Too many non-constant constructors@ -- maximum is %i %s@]"
+        (Config.max_tag + 1) "non-constant constructors"
+  | Duplicate_label s ->
+      fprintf ppf "Two labels are named %s" s
+  | Recursive_abbrev s ->
+      fprintf ppf "The type abbreviation %s is cyclic" s
+  | Cycle_in_def (s, ty) ->
+      fprintf ppf "@[<v>The definition of %s contains a cycle:@ %a@]"
+        s Printtyp.type_expr ty
+  | Definition_mismatch (ty, None) ->
+      fprintf ppf "@[<v>@[<hov>%s@ %s@;<1 2>%a@]@]"
+        "This variant or record definition" "does not match that of type"
+        Printtyp.type_expr ty
+  | Definition_mismatch (ty, Some err) ->
+      fprintf ppf "@[<v>@[<hov>%s@ %s@;<1 2>%a@]%a@]"
+        "This variant or record definition" "does not match that of type"
+        Printtyp.type_expr ty
+        (Includecore.report_type_mismatch "the original" "this" "definition")
+        err
+  | Constraint_failed (ty, ty') ->
+      Printtyp.reset_and_mark_loops ty;
+      Printtyp.mark_loops ty';
+      Printtyp.Naming_context.reset ();
+      fprintf ppf "@[%s@ @[<hv>Type@ %a@ should be an instance of@ %a@]@]"
+        "Constraints are not satisfied in this type."
+        !Oprint.out_type (Printtyp.tree_of_typexp false ty)
+        !Oprint.out_type (Printtyp.tree_of_typexp false ty')
+  | Non_regular { definition; used_as; defined_as; expansions } ->
+      let pp_expansion ppf (ty,body) =
+        Format.fprintf ppf "%a = %a"
+          Printtyp.type_expr ty
+          Printtyp.type_expr body in
+      let comma ppf () = Format.fprintf ppf ",@;<1 2>" in
+      let pp_expansions ppf expansions =
+        Format.(pp_print_list ~pp_sep:comma pp_expansion) ppf expansions in
+      Printtyp.reset_and_mark_loops used_as;
+      Printtyp.mark_loops defined_as;
+      Printtyp.Naming_context.reset ();
+      begin match expansions with
+      | [] ->
+          fprintf ppf
+            "@[<hv>This recursive type is not regular.@ \
+             The type constructor %s is defined as@;<1 2>type %a@ \
+             but it is used as@;<1 2>%a.@ \
+             All uses need to match the definition for the recursive type \
+             to be regular.@]"
+            (Path.name definition)
+            !Oprint.out_type (Printtyp.tree_of_typexp false defined_as)
+            !Oprint.out_type (Printtyp.tree_of_typexp false used_as)
+      | _ :: _ ->
+          fprintf ppf
+            "@[<hv>This recursive type is not regular.@ \
+             The type constructor %s is defined as@;<1 2>type %a@ \
+             but it is used as@;<1 2>%a@ \
+             after the following expansion(s):@;<1 2>%a@ \
+             All uses need to match the definition for the recursive type \
+             to be regular.@]"
+            (Path.name definition)
+            !Oprint.out_type (Printtyp.tree_of_typexp false defined_as)
+            !Oprint.out_type (Printtyp.tree_of_typexp false used_as)
+            pp_expansions expansions
+      end
+  | Inconsistent_constraint (env, trace) ->
+      fprintf ppf "The type constraints are not consistent.@.";
+      Printtyp.report_unification_error ppf env trace
+        (fun ppf -> fprintf ppf "Type")
+        (fun ppf -> fprintf ppf "is not compatible with type")
+  | Type_clash (env, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "This type constructor expands to type")
+        (function ppf ->
+           fprintf ppf "but is used here with type")
+  | Null_arity_external ->
+      fprintf ppf "External identifiers must be functions"
+  | Missing_native_external ->
+      fprintf ppf "@[<hv>An external function with more than 5 arguments \
+                   requires a second stub function@ \
+                   for native-code compilation@]"
+  | Unbound_type_var (ty, decl) ->
+      fprintf ppf "A type variable is unbound in this type declaration";
+      let ty = Ctype.repr ty in
+      begin match decl.type_kind, decl.type_manifest with
+      | Type_variant tl, _ ->
+          explain_unbound_gen ppf ty tl (fun c ->
+              let tl = tys_of_constr_args c.Types.cd_args in
+              Btype.newgenty (Ttuple tl)
+            )
+            "case" (fun ppf c ->
+                fprintf ppf
+                  "%a of %a" Printtyp.ident c.Types.cd_id
+                  Printtyp.constructor_arguments c.Types.cd_args)
+      | Type_record (tl, _), _ ->
+          explain_unbound ppf ty tl (fun l -> l.Types.ld_type)
+            "field" (fun l -> Ident.name l.Types.ld_id ^ ": ")
+      | Type_abstract, Some ty' ->
+          explain_unbound_single ppf ty ty'
+      | _ -> ()
+      end
+  | Unbound_type_var_ext (ty, ext) ->
+      fprintf ppf "A type variable is unbound in this extension constructor";
+      let args = tys_of_constr_args ext.ext_args in
+      explain_unbound ppf ty args (fun c -> c) "type" (fun _ -> "")
+  | Cannot_extend_private_type path ->
+      fprintf ppf "@[%s@ %a@]"
+        "Cannot extend private type definition"
+        Printtyp.path path
+  | Not_extensible_type path ->
+      fprintf ppf "@[%s@ %a@ %s@]"
+        "Type definition"
+        Printtyp.path path
+        "is not extensible"
+  | Extension_mismatch (path, err) ->
+      fprintf ppf "@[<v>@[<hov>%s@ %s@;<1 2>%s@]%a@]"
+        "This extension" "does not match the definition of type"
+        (Path.name path)
+        (Includecore.report_type_mismatch
+           "the type" "this extension" "definition")
+        err
+  | Rebind_wrong_type (lid, env, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "The constructor %a@ has type"
+             Printtyp.longident lid)
+        (function ppf ->
+           fprintf ppf "but was expected to be of type")
+  | Rebind_mismatch (lid, p, p') ->
+      fprintf ppf
+        "@[%s@ %a@ %s@ %s@ %s@ %s@ %s@]"
+        "The constructor" Printtyp.longident lid
+        "extends type" (Path.name p)
+        "whose declaration does not match"
+        "the declaration of type" (Path.name p')
+  | Rebind_private lid ->
+      fprintf ppf "@[%s@ %a@ %s@]"
+        "The constructor"
+        Printtyp.longident lid
+        "is private"
+  | Variance (Typedecl_variance.Bad_variance (n, v1, v2)) ->
+      let variance (p,n,i) =
+        let inj = if i then "injective " else "" in
+        match p, n with
+          true,  true  -> inj ^ "invariant"
+        | true,  false -> inj ^ "covariant"
+        | false, true  -> inj ^ "contravariant"
+        | false, false -> if inj = "" then "unrestricted" else inj
+      in
+      let suffix n =
+        let teen = (n mod 100)/10 = 1 in
+        match n mod 10 with
+        | 1 when not teen -> "st"
+        | 2 when not teen -> "nd"
+        | 3 when not teen -> "rd"
+        | _ -> "th"
+      in
+      (match n with
+       | Variance_not_reflected ->
+           fprintf ppf "@[%s@ %s@ It"
+             "In this definition, a type variable has a variance that"
+             "is not reflected by its occurrence in type parameters."
+       | No_variable ->
+           fprintf ppf "@[%s@ %s@]"
+             "In this definition, a type variable cannot be deduced"
+             "from the type parameters."
+       | Variance_not_deducible ->
+           fprintf ppf "@[%s@ %s@ It"
+             "In this definition, a type variable has a variance that"
+             "cannot be deduced from the type parameters."
+       | Variance_not_satisfied n ->
+           fprintf ppf "@[%s@ %s@ The %d%s type parameter"
+             "In this definition, expected parameter"
+             "variances are not satisfied."
+             n (suffix n));
+      (match n with
+       | No_variable -> ()
+       | _ ->
+           fprintf ppf " was expected to be %s,@ but it is %s.@]"
+             (variance v2) (variance v1))
+  | Unavailable_type_constructor p ->
+      fprintf ppf "The definition of type %a@ is unavailable" Printtyp.path p
+  | Bad_fixed_type r ->
+      fprintf ppf "This fixed type %s" r
+  | Variance Typedecl_variance.Varying_anonymous ->
+      fprintf ppf "@[%s@ %s@ %s@]"
+        "In this GADT definition," "the variance of some parameter"
+        "cannot be checked"
+  | Val_in_structure ->
+      fprintf ppf "Value declarations are only allowed in signatures"
+  | Multiple_native_repr_attributes ->
+      fprintf ppf "Too many [@@unboxed]/[@@untagged] attributes"
+  | Cannot_unbox_or_untag_type Unboxed ->
+      fprintf ppf "@[Don't know how to unbox this type.@ \
+                   Only float, int32, int64 and nativeint can be unboxed.@]"
+  | Cannot_unbox_or_untag_type Untagged ->
+      fprintf ppf "@[Don't know how to untag this type.@ \
+                   Only int can be untagged.@]"
+  | Deep_unbox_or_untag_attribute kind ->
+      fprintf ppf
+        "@[The attribute '%s' should be attached to@ \
+         a direct argument or result of the primitive,@ \
+         it should not occur deeply into its type.@]"
+        (match kind with Unboxed -> "@unboxed" | Untagged -> "@untagged")
+  | Immediacy (Typedecl_immediacy.Bad_immediacy_attribute violation) ->
+      fprintf ppf "@[%a@]" Format.pp_print_text
+        (match violation with
+         | Type_immediacy.Violation.Not_always_immediate ->
+             "Types marked with the immediate attribute must be \
+              non-pointer types like int or bool."
+         | Type_immediacy.Violation.Not_always_immediate_on_64bits ->
+             "Types marked with the immediate64 attribute must be \
+              produced using the Stdlib.Sys.Immediate64.Make functor.")
+  | Bad_unboxed_attribute msg ->
+      fprintf ppf "@[This type cannot be unboxed because@ %s.@]" msg
+  | Separability (Typedecl_separability.Non_separable_evar evar) ->
+      let pp_evar ppf = function
+        | None ->
+            fprintf ppf "an unnamed existential variable"
+        | Some str ->
+            fprintf ppf "the existential variable %a"
+              Pprintast.tyvar str in
+      fprintf ppf "@[This type cannot be unboxed because@ \
+                   it might contain both float and non-float values,@ \
+                   depending on the instantiation of %a.@ \
+                   You should annotate it with [%@%@ocaml.boxed].@]"
+        pp_evar evar
+  | Boxed_and_unboxed ->
+      fprintf ppf "@[A type cannot be boxed and unboxed at the same time.@]"
+  | Nonrec_gadt ->
+      fprintf ppf
+        "@[GADT case syntax cannot be used in a 'nonrec' block.@]"
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, err) ->
+        Some (Location.error_of_printer ~loc report_error err)
+      | _ ->
+        None
+    )
diff --git a/upstream/ocaml_412/typing/typedecl.mli b/upstream/ocaml_412/typing/typedecl.mli
new file mode 100644
index 0000000..fec0bd6
--- /dev/null
+++ b/upstream/ocaml_412/typing/typedecl.mli
@@ -0,0 +1,106 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Typing of type definitions and primitive definitions *)
+
+open Types
+open Format
+
+val transl_type_decl:
+    Env.t -> Asttypes.rec_flag -> Parsetree.type_declaration list ->
+    Typedtree.type_declaration list * Env.t
+
+val transl_exception:
+    Env.t -> Parsetree.extension_constructor ->
+    Typedtree.extension_constructor * Env.t
+
+val transl_type_exception:
+    Env.t ->
+    Parsetree.type_exception -> Typedtree.type_exception * Env.t
+
+val transl_type_extension:
+    bool -> Env.t -> Location.t -> Parsetree.type_extension ->
+    Typedtree.type_extension * Env.t
+
+val transl_value_decl:
+    Env.t -> Location.t ->
+    Parsetree.value_description -> Typedtree.value_description * Env.t
+
+val transl_with_constraint:
+    Ident.t -> Path.t option ->
+    sig_env:Env.t -> sig_decl:Types.type_declaration ->
+    outer_env:Env.t -> Parsetree.type_declaration ->
+    Typedtree.type_declaration
+
+val abstract_type_decl: injective:bool -> int -> type_declaration
+val approx_type_decl:
+    Parsetree.type_declaration list ->
+                                  (Ident.t * type_declaration) list
+val check_recmod_typedecl:
+    Env.t -> Location.t -> Ident.t list -> Path.t -> type_declaration -> unit
+val check_coherence:
+    Env.t -> Location.t -> Path.t -> type_declaration -> unit
+
+(* for fixed types *)
+val is_fixed_type : Parsetree.type_declaration -> bool
+
+(* for typeopt.ml *)
+val get_unboxed_type_representation: Env.t -> type_expr -> type_expr option
+
+type native_repr_kind = Unboxed | Untagged
+
+type error =
+    Repeated_parameter
+  | Duplicate_constructor of string
+  | Too_many_constructors
+  | Duplicate_label of string
+  | Recursive_abbrev of string
+  | Cycle_in_def of string * type_expr
+  | Definition_mismatch of type_expr * Includecore.type_mismatch option
+  | Constraint_failed of type_expr * type_expr
+  | Inconsistent_constraint of Env.t * Ctype.Unification_trace.t
+  | Type_clash of Env.t * Ctype.Unification_trace.t
+  | Non_regular of {
+      definition: Path.t;
+      used_as: type_expr;
+      defined_as: type_expr;
+      expansions: (type_expr * type_expr) list;
+    }
+  | Null_arity_external
+  | Missing_native_external
+  | Unbound_type_var of type_expr * type_declaration
+  | Cannot_extend_private_type of Path.t
+  | Not_extensible_type of Path.t
+  | Extension_mismatch of Path.t * Includecore.type_mismatch
+  | Rebind_wrong_type of Longident.t * Env.t * Ctype.Unification_trace.t
+  | Rebind_mismatch of Longident.t * Path.t * Path.t
+  | Rebind_private of Longident.t
+  | Variance of Typedecl_variance.error
+  | Unavailable_type_constructor of Path.t
+  | Bad_fixed_type of string
+  | Unbound_type_var_ext of type_expr * extension_constructor
+  | Val_in_structure
+  | Multiple_native_repr_attributes
+  | Cannot_unbox_or_untag_type of native_repr_kind
+  | Deep_unbox_or_untag_attribute of native_repr_kind
+  | Immediacy of Typedecl_immediacy.error
+  | Separability of Typedecl_separability.error
+  | Bad_unboxed_attribute of string
+  | Boxed_and_unboxed
+  | Nonrec_gadt
+
+exception Error of Location.t * error
+
+val report_error: formatter -> error -> unit
diff --git a/upstream/ocaml_412/typing/typedecl_immediacy.ml b/upstream/ocaml_412/typing/typedecl_immediacy.ml
new file mode 100644
index 0000000..ccd09e8
--- /dev/null
+++ b/upstream/ocaml_412/typing/typedecl_immediacy.ml
@@ -0,0 +1,71 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Types
+
+type error = Bad_immediacy_attribute of Type_immediacy.Violation.t
+exception Error of Location.t * error
+
+let compute_decl env tdecl =
+  match (tdecl.type_kind, tdecl.type_manifest) with
+  | (Type_variant [{cd_args = Cstr_tuple [arg]; _}], _)
+    | (Type_variant [{cd_args = Cstr_record [{ld_type = arg; _}]; _}], _)
+    | (Type_record ([{ld_type = arg; _}], _), _)
+  when tdecl.type_unboxed.unboxed ->
+    begin match Typedecl_unboxed.get_unboxed_type_representation env arg with
+    | Typedecl_unboxed.Unavailable -> Type_immediacy.Unknown
+    | Typedecl_unboxed.This argrepr -> Ctype.immediacy env argrepr
+    | Typedecl_unboxed.Only_on_64_bits argrepr ->
+        match Ctype.immediacy env argrepr with
+        | Type_immediacy.Always -> Type_immediacy.Always_on_64bits
+        | Type_immediacy.Always_on_64bits | Type_immediacy.Unknown as x -> x
+    end
+  | (Type_variant (_ :: _ as cstrs), _) ->
+    if not (List.exists (fun c -> c.Types.cd_args <> Types.Cstr_tuple []) cstrs)
+    then
+      Type_immediacy.Always
+    else
+      Type_immediacy.Unknown
+  | (Type_abstract, Some(typ)) -> Ctype.immediacy env typ
+  | (Type_abstract, None) -> Type_immediacy.of_attributes tdecl.type_attributes
+  | _ -> Type_immediacy.Unknown
+
+let property : (Type_immediacy.t, unit) Typedecl_properties.property =
+  let open Typedecl_properties in
+  let eq = (=) in
+  let merge ~prop:_ ~new_prop = new_prop in
+  let default _decl = Type_immediacy.Unknown in
+  let compute env decl () = compute_decl env decl in
+  let update_decl decl immediacy = { decl with type_immediate = immediacy } in
+  let check _env _id decl () =
+    let written_by_user = Type_immediacy.of_attributes decl.type_attributes in
+    match Type_immediacy.coerce decl.type_immediate ~as_:written_by_user with
+    | Ok () -> ()
+    | Error violation ->
+        raise (Error (decl.type_loc,
+                      Bad_immediacy_attribute violation))
+  in
+  {
+    eq;
+    merge;
+    default;
+    compute;
+    update_decl;
+    check;
+  }
+
+let update_decls env decls =
+  Typedecl_properties.compute_property_noreq property env decls
diff --git a/upstream/ocaml_412/typing/typedecl_immediacy.mli b/upstream/ocaml_412/typing/typedecl_immediacy.mli
new file mode 100644
index 0000000..17fb985
--- /dev/null
+++ b/upstream/ocaml_412/typing/typedecl_immediacy.mli
@@ -0,0 +1,27 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type error = Bad_immediacy_attribute of Type_immediacy.Violation.t
+exception Error of Location.t * error
+
+val compute_decl : Env.t -> Types.type_declaration -> Type_immediacy.t
+
+val property : (Type_immediacy.t, unit) Typedecl_properties.property
+
+val update_decls :
+  Env.t ->
+  (Ident.t * Typedecl_properties.decl) list ->
+  (Ident.t * Typedecl_properties.decl) list
diff --git a/upstream/ocaml_412/typing/typedecl_properties.ml b/upstream/ocaml_412/typing/typedecl_properties.ml
new file mode 100644
index 0000000..28a1bb6
--- /dev/null
+++ b/upstream/ocaml_412/typing/typedecl_properties.ml
@@ -0,0 +1,73 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type decl = Types.type_declaration
+
+type ('prop, 'req) property = {
+  eq : 'prop -> 'prop -> bool;
+  merge : prop:'prop -> new_prop:'prop -> 'prop;
+
+  default : decl -> 'prop;
+  compute : Env.t -> decl -> 'req -> 'prop;
+  update_decl : decl -> 'prop -> decl;
+
+  check : Env.t -> Ident.t -> decl -> 'req -> unit;
+}
+
+let add_type ~check id decl env =
+  let open Types in
+  Builtin_attributes.warning_scope ~ppwarning:false decl.type_attributes
+    (fun () -> Env.add_type ~check id decl env)
+
+let add_types_to_env decls env =
+  List.fold_right
+    (fun (id, decl) env -> add_type ~check:true id decl env)
+    decls env
+
+let compute_property
+: ('prop, 'req) property -> Env.t ->
+  (Ident.t * decl) list -> 'req list -> (Ident.t * decl) list
+= fun property env decls required ->
+  (* [decls] and [required] must be lists of the same size,
+     with [required] containing the requirement for the corresponding
+     declaration in [decls]. *)
+  let props = List.map (fun (_id, decl) -> property.default decl) decls in
+  let rec compute_fixpoint props =
+    let new_decls =
+      List.map2 (fun (id, decl) prop ->
+          (id, property.update_decl decl prop))
+        decls props in
+    let new_env = add_types_to_env new_decls env in
+    let new_props =
+      List.map2
+        (fun (_id, decl) (prop, req) ->
+           let new_prop = property.compute new_env decl req in
+           property.merge ~prop ~new_prop)
+        new_decls (List.combine props required) in
+    if not (List.for_all2 property.eq props new_props)
+    then compute_fixpoint new_props
+    else begin
+      List.iter2
+        (fun (id, decl) req -> property.check new_env id decl req)
+        new_decls required;
+      new_decls
+    end
+  in
+  compute_fixpoint props
+
+let compute_property_noreq property env decls =
+  let req = List.map (fun _ -> ()) decls in
+  compute_property property env decls req
diff --git a/upstream/ocaml_412/typing/typedecl_properties.mli b/upstream/ocaml_412/typing/typedecl_properties.mli
new file mode 100644
index 0000000..153c3f7
--- /dev/null
+++ b/upstream/ocaml_412/typing/typedecl_properties.mli
@@ -0,0 +1,55 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type decl = Types.type_declaration
+
+(** An abstract interface for properties of type definitions, such as
+   variance and immediacy, that are computed by a fixpoint on
+   mutually-recursive type declarations. This interface contains all
+   the operations needed to initialize and run the fixpoint
+   computation, and then (optionally) check that the result is
+   consistent with the declaration or user expectations. *)
+
+type ('prop, 'req) property = {
+  eq : 'prop -> 'prop -> bool;
+  merge : prop:'prop -> new_prop:'prop -> 'prop;
+
+  default : decl -> 'prop;
+  compute : Env.t -> decl -> 'req -> 'prop;
+  update_decl : decl -> 'prop -> decl;
+
+  check : Env.t -> Ident.t -> decl -> 'req -> unit;
+}
+(** ['prop] represents the type of property values
+    ({!Types.Variance.t}, just 'bool' for immediacy, etc).
+
+    ['req] represents the property value required by the author of the
+    declaration, if they gave an expectation: [type +'a t = ...].
+
+    Some properties have no natural notion of user requirement, or
+    their requirement is global, or already stored in
+    [type_declaration]; they can just use [unit] as ['req] parameter. *)
+
+
+(** [compute_property prop env decls req] performs a fixpoint computation
+    to determine the final values of a property on a set of mutually-recursive
+    type declarations. The [req] argument must be a list of the same size as
+    [decls], providing the user requirement for each declaration. *)
+val compute_property : ('prop, 'req) property -> Env.t ->
+  (Ident.t * decl) list -> 'req list -> (Ident.t * decl) list
+
+val compute_property_noreq : ('prop, unit) property -> Env.t ->
+  (Ident.t * decl) list -> (Ident.t * decl) list
diff --git a/upstream/ocaml_412/typing/typedecl_separability.ml b/upstream/ocaml_412/typing/typedecl_separability.ml
new file mode 100644
index 0000000..32e3422
--- /dev/null
+++ b/upstream/ocaml_412/typing/typedecl_separability.ml
@@ -0,0 +1,731 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Types
+
+type type_definition = type_declaration
+(* We should use 'declaration' for interfaces, and 'definition' for
+   implementations. The name type_declaration in types.ml is improper
+   for our usage -- although for OCaml types the declaration and
+   definition languages are the same. *)
+
+(** assuming that a datatype has a single constructor/label with
+   a single argument, [argument_to_unbox] represents the
+   information we need to check the argument for separability. *)
+type argument_to_unbox = {
+  kind: parameter_kind; (* for error messages *)
+  mutability: Asttypes.mutable_flag;
+  argument_type: type_expr;
+  result_type_parameter_instances: type_expr list;
+  (** result_type_parameter_instances represents the domain of the
+     constructor; usually it is just a list of the datatype parameter
+     ('a, 'b, ...), but when using GADTs or constraints it could
+     contain arbitrary type expressions.
+
+     For example, [type 'a t = 'b constraint 'a = 'b * int] has
+     [['b * int]] as [result_type_parameter_instances], and so does
+     [type _ t = T : 'b -> ('b * int) t]. *)
+  location : Location.t;
+}
+and parameter_kind =
+  | Record_field
+  | Constructor_parameter
+  | Constructor_field (** inlined records *)
+
+(** ['a multiplicity] counts the number of ['a] in
+    a structure in which expect to see only one ['a]. *)
+type 'a multiplicity =
+  | Zero
+  | One of 'a
+  | Several
+
+type arity = argument_to_unbox multiplicity (**how many parameters?*)
+
+type branching = arity multiplicity (**how many constructors?*)
+
+(** Summarize the right-hand-side of a type declaration,
+    for separability-checking purposes. See {!structure} below. *)
+type type_structure =
+  | Synonym of type_expr
+  | Abstract
+  | Open
+  | Algebraic of branching
+
+let demultiply_list
+  : type a b. a list -> (a -> b) -> b multiplicity
+  = fun li f -> match li with
+  | [] -> Zero
+  | [v] -> One (f v)
+  | _::_::_ -> Several
+
+let structure : type_definition -> type_structure = fun def ->
+  match def.type_kind with
+  | Type_open -> Open
+  | Type_abstract ->
+      begin match def.type_manifest with
+      | None -> Abstract
+      | Some type_expr -> Synonym type_expr
+      end
+  | Type_record (labels, _) ->
+      Algebraic (One (
+        demultiply_list labels @@ fun ld -> {
+          location = ld.ld_loc;
+          kind = Record_field;
+          mutability = ld.ld_mutable;
+          argument_type = ld.ld_type;
+          result_type_parameter_instances = def.type_params;
+        }
+      ))
+  | Type_variant constructors ->
+      Algebraic (demultiply_list constructors @@ fun cd ->
+        let result_type_parameter_instances =
+          match cd.cd_res with
+          (* cd_res is the optional return type (in a GADT);
+             if None, just use the type parameters *)
+          | None -> def.type_params
+          | Some ret_type ->
+              begin match Ctype.repr ret_type with
+              | {desc=Tconstr (_, tyl, _)} ->
+                  List.map Ctype.repr tyl
+              | _ -> assert false
+              end
+        in
+        begin match cd.cd_args with
+        | Cstr_tuple tys ->
+            demultiply_list tys @@ fun argument_type -> {
+              location = cd.cd_loc;
+              kind = Constructor_parameter;
+              mutability = Asttypes.Immutable;
+              argument_type;
+              result_type_parameter_instances;
+            }
+        | Cstr_record labels ->
+            demultiply_list labels @@ fun ld ->
+              let argument_type = ld.ld_type in
+              {
+                location = ld.ld_loc;
+                kind = Constructor_field;
+                mutability = ld.ld_mutable;
+                argument_type;
+                result_type_parameter_instances;
+              }
+        end)
+
+
+type error =
+  | Non_separable_evar of string option
+
+exception Error of Location.t * error
+
+(* see the .mli file for explanations on the modes *)
+module Sep = Types.Separability
+type mode = Sep.t = Ind | Sep | Deepsep
+
+let rank = Sep.rank
+let max_mode = Sep.max
+
+(** If the type context [e(_)] imposes the mode [m] on its hole [_],
+    and the type context [e'(_)] imposes the mode [m'] on its hole [_],
+    then the mode on [_] imposed by the context composition [e(e'(_))]
+    is [compose m m'].
+
+    This operation differs from [max_mode]: [max_mode Ind Sep] is [Sep],
+    but [compose Ind Sep] is [Ind]. *)
+let compose
+  : mode -> mode -> mode
+  = fun m1 m2 ->
+  match m1 with
+  | Deepsep -> Deepsep
+  | Sep -> m2
+  | Ind -> Ind
+
+type type_var = {
+  text: string option; (** the user name of the type variable, None for '_' *)
+  id: int; (** the identifier of the type node (type_expr.id) of the variable *)
+}
+
+module TVarMap = Map.Make(struct
+    type t = type_var
+    let compare v1 v2 = compare v1.id v2.id
+  end)
+type context = mode TVarMap.t
+let (++) = TVarMap.union (fun _ m1 m2 -> Some(max_mode m1 m2))
+let empty = TVarMap.empty
+
+
+(** [immediate_subtypes ty] returns the list of all the
+   immediate sub-type-expressions of [ty]. They represent the biggest
+   sub-components that may be extracted using a constraint. For
+   example, the immediate sub-type-expressions of [int * (bool * 'a)]
+   are [int] and [bool * 'a].
+
+   Smaller components are extracted recursively in [check_type]. *)
+let rec immediate_subtypes : type_expr -> type_expr list = fun ty ->
+  (* Note: Btype.fold_type_expr is not suitable here:
+     - it does not do the right thing on Tpoly, iterating on type
+       parameters as well as the subtype
+     - it performs a shallow traversal of object types,
+       while our implementation collects all method types *)
+  match (Ctype.repr ty).desc with
+  (* these are the important cases,
+     on which immediate_subtypes is called from [check_type] *)
+  | Tarrow(_,ty1,ty2,_) ->
+      [ty1; ty2]
+  | Ttuple(tys)
+  | Tpackage(_,_,tys) ->
+      tys
+  | Tobject(row,class_ty) ->
+      let class_subtys =
+        match !class_ty with
+        | None        -> []
+        | Some(_,tys) -> tys
+      in
+      immediate_subtypes_object_row class_subtys row
+  | Tvariant(row) ->
+      immediate_subtypes_variant_row [] row
+
+  (* the cases below are not called from [check_type],
+     they are here for completeness *)
+  | Tnil | Tfield _ ->
+      (* these should only occur under Tobject and not at the toplevel,
+         but "better safe than sorry" *)
+      immediate_subtypes_object_row [] ty
+  | Tlink _ | Tsubst _ -> assert false (* impossible due to Ctype.repr *)
+  | Tvar _ | Tunivar _ -> []
+  | Tpoly (pty, _) -> [pty]
+  | Tconstr (_path, tys, _) -> tys
+
+and immediate_subtypes_object_row acc ty = match (Ctype.repr ty).desc with
+  | Tnil -> acc
+  | Tfield (_label, _kind, ty, rest) ->
+      let acc = ty :: acc in
+      immediate_subtypes_object_row acc rest
+  | _ -> ty :: acc
+
+and immediate_subtypes_variant_row acc desc =
+  let add_subtypes acc =
+    let add_subtype acc (_l, rf) =
+      immediate_subtypes_variant_row_field acc rf in
+    List.fold_left add_subtype acc desc.row_fields in
+  let add_row acc =
+    let row = Ctype.repr desc.row_more in
+    match row.desc with
+    | Tvariant more -> immediate_subtypes_variant_row acc more
+    | _ -> row :: acc
+  in
+  add_row (add_subtypes acc)
+
+and immediate_subtypes_variant_row_field acc = function
+  | Rpresent(None)
+  | Rabsent            -> acc
+  | Rpresent(Some(ty)) -> ty :: acc
+  | Reither(_,field_types,_,r) ->
+      let acc = List.rev_append field_types acc in
+      begin match !r with
+      | None -> acc
+      | Some rf -> immediate_subtypes_variant_row_field acc rf
+      end
+
+let free_variables ty =
+  Ctype.free_variables (Ctype.repr ty)
+  |> List.map (fun {desc; id; _} ->
+      match desc with
+      | Tvar text -> {text; id}
+      | _ ->
+          (* Ctype.free_variables only returns Tvar nodes *)
+          assert false)
+
+(** Coinductive hypotheses to handle equi-recursive types
+
+    OCaml allows infinite/cyclic types, such as
+      (int * 'a) as 'a
+    whose infinite unfolding is (int * (int * (int * (int * ...)))).
+
+    Remark: this specific type is only accepted if the -rectypes option
+    is passed, but such "equi-recursive types" are accepted by
+    default if the cycle goes through an object type or polymorphic
+    variant type:
+      [ `int | `other of 'a ] as 'a
+      < head : int; rest : 'a > as 'a
+
+    We have to take those infinite types in account in our
+    separability-checking program: a naive implementation would loop
+    infinitely when trying to prove that one of them is Deepsep.
+
+    After type-checking, the cycle-introducing form (... as 'a) does
+    not appear explicitly in the syntax of types: types are graphs/trees
+    with cycles in them, and we have to use the type_expr.id field,
+    an identifier for each node in the graph/tree, to detect cycles.
+
+    We avoid looping by remembering the set of separability queries
+    that we have already asked ourselves (in the current
+    search branch). For example, if we are asked to check
+
+      (int * 'a) : Deepsep
+
+    our algorithm will check both (int : Deepsep) and ('a : Deepsep),
+    but it will remember in these sub-checks that it is in the process
+    of checking (int * 'a) : Deepsep, adding it to a list of "active
+    goals", or "coinductive hypotheses".
+
+    Each new sub-query will start by checking whether the query
+    already appears as a coinductive hypothesis; in our example, this
+    can happen if 'a and (int * 'a) are in fact the same node in the
+    cyclic tree. In that case, we return immediately (instead of looping):
+    we reason that, assuming that 'a is indeed Deepsep, then it is
+    the case that (int * 'a) is also Deepsep.
+
+    This kind of cyclic reasoning can be dangerous: it would be wrong
+    to argue that an arbitrary 'a type is Deepsep by saying:
+    "assuming that 'a is Deepsep, then it is the case that 'a is
+    also Deepsep". In the first case, we made an assumption on 'a,
+    and used it on a type (int * 'a) which has 'a as a strict sub-component;
+    in the second, we use it on the same type 'a directly, which is invalid.
+
+    Now consider a type of the form (('a t) as 'a): while 'a is a sub-component
+    of ('a t), it may still be wrong to reason coinductively about it,
+    as ('a t) may be defined as (type 'a t = 'a).
+
+    When moving from (int * 'a) to a subcomponent (int) or ('a), we
+    say that the coinductive hypothesis on (int * 'a : m) is "safe":
+    it can be used immediately to prove the subcomponents, because we
+    made progress moving to a strict subcomponent (we are guarded
+    under a computational type constructor). On the other hand, when
+    moving from ('a t) to ('a), we say that the coinductive hypothesis
+    ('a t : m) is "unsafe" for the subgoal, as we don't know whether
+    we have made strict progress. In the general case, we keep track
+    of a set of safe and unsafe hypotheses made in the past, and we
+    use them to terminate checking if we encounter them again,
+    ensuring termination.
+
+    If we encounter a (ty : m) goal that is exactly a safe hypothesis,
+    we terminate with a success. In fact, we can use mode subtyping here:
+    if (ty : m') appears as a hypothesis with (m' >= m), then we would
+    succeed for (ty : m'), so (ty : m) should succeed as well.
+
+    On the other hand, if we encounter a (ty : m) goal that is an
+    *unsafe* hypothesis, we terminate the check with a failure. In this case,
+    we cannot work modulo mode subtyping: if (ty : m') appears with
+    (m' >= m), then the check (ty : m') would have failed, but it is still
+    possible that the weaker current query (ty : m) would succeed.
+
+    In usual coinductive-reasoning systems, unsafe hypotheses are turned
+    into safe hypotheses each time strict progress is made (for each
+    guarded sub-goal). Consider ((int * 'a) t as 'a : deepsep) for example:
+    the idea is that the ((int * 'a) t : deepsep) hypothesis would be
+    unsafe when checking ((int * 'a) : deepsep), but that the progress
+    step from (int * 'a : deepsep) to ('a : deepsep) would turn all
+    past unsafe hypotheses into safe hypotheses. There is a problem
+    with this, though, due to constraints: what if (_ t) is defined as
+
+      type 'b t = 'a constraint 'b = (int * 'a)
+
+    ?
+
+    In that case, then 'a is precisely the one-step unfolding
+    of the ((int * 'a) t) definition, and it would be an invalid,
+    cyclic reasoning to prove ('a : deepsep) from the now-safe
+    hypothesis ((int * 'a) t : deepsep).
+
+    Surprisingly-fortunately, we have exactly the information we need
+    to know whether (_ t) may or may not pull a constraint trick of
+    this nature: we can look at its mode signature, where constraints
+    are marked by a Deepsep mode. If we see Deepsep, we know that a
+    constraint exists, but we don't know what the constraint is:
+    we cannot tell at which point, when decomposing the parameter type,
+    a sub-component can be considered safe again. To model this,
+    we add a third category of co-inductive hypotheses: to "safe" and
+    "unsafe" we add the category of "poison" hypotheses, which remain
+    poisonous during the remaining of the type decomposition,
+    even in presence of safe, computational types constructors:
+
+    - when going under a computational constructor,
+      "unsafe" hypotheses become "safe"
+    - when going under a constraining type (more precisely, under
+      a type parameter that is marked Deepsep in the mode signature),
+      "unsafe" hypotheses become "poison"
+
+    The mode signature tells us even a bit more: if a parameter
+    is marked "Ind", we know that the type constructor cannot unfold
+    to this parameter (otherwise it would be Sep), so going under
+    this parameter can be considered a safe/guarded move: if
+    we have to check (foo t : m) with ((_ : Ind) t) in the signature,
+    we can recursively check (foo : Ind) with (foo t : m) marked
+    as "safe", rather than "unsafe".
+*)
+module TypeMap = Btype.TypeMap
+module ModeSet = Set.Make(Types.Separability)
+
+type coinductive_hyps = {
+  safe: ModeSet.t TypeMap.t;
+  unsafe: ModeSet.t TypeMap.t;
+  poison: ModeSet.t TypeMap.t;
+}
+
+module Hyps : sig
+  type t = coinductive_hyps
+  val empty : t
+  val add : type_expr -> mode -> t -> t
+  val guard : t -> t
+  val poison : t -> t
+  val safe : type_expr -> mode -> t -> bool
+  val unsafe : type_expr -> mode -> t -> bool
+end = struct
+  type t = coinductive_hyps
+
+  let empty = {
+    safe = TypeMap.empty;
+    unsafe = TypeMap.empty;
+    poison = TypeMap.empty;
+  }
+
+  let of_opt = function
+    | Some ms -> ms
+    | None -> ModeSet.empty
+
+  let merge map1 map2 =
+    TypeMap.merge (fun _k ms1 ms2 ->
+        Some (ModeSet.union (of_opt ms1) (of_opt ms2))
+      ) map1 map2
+
+  let guard {safe; unsafe; poison;} = {
+    safe = merge safe unsafe;
+    unsafe = TypeMap.empty;
+    poison;
+  }
+
+  let poison {safe; unsafe; poison;} = {
+    safe;
+    unsafe = TypeMap.empty;
+    poison = merge poison unsafe;
+  }
+
+  let add ty m hyps =
+    let m_map = TypeMap.singleton ty (ModeSet.singleton m) in
+    { hyps with unsafe = merge m_map hyps.unsafe; }
+
+  let find ty map = try TypeMap.find ty map with Not_found -> ModeSet.empty
+
+  let safe ty m hyps =
+    match ModeSet.max_elt_opt (find ty hyps.safe) with
+    | None -> false
+    | Some best_safe -> rank best_safe >= rank m
+
+  let unsafe ty m {safe = _; unsafe; poison} =
+    let in_map s = ModeSet.mem m (find ty s) in
+    List.exists in_map [unsafe; poison]
+end
+
+(** For a type expression [ty] (without constraints and existentials),
+    any mode checking [ty : m] is satisfied in the "worse case" context
+    that maps all free variables of [ty] to the most demanding mode,
+    Deepsep. *)
+let worst_case ty =
+  let add ctx tvar = TVarMap.add tvar Deepsep ctx in
+  List.fold_left add TVarMap.empty (free_variables ty)
+
+
+(** [check_type env sigma ty m] returns the most permissive context [gamma]
+    such that [ty] is separable at mode [m] in [gamma], under
+    the signature [sigma]. *)
+let check_type
+  : Env.t -> type_expr -> mode -> context
+  = fun env ty m ->
+  let rec check_type hyps ty m =
+    let ty = Ctype.repr ty in
+    if Hyps.safe ty m hyps then empty
+    else if Hyps.unsafe ty m hyps then worst_case ty
+    else
+    let hyps = Hyps.add ty m hyps in
+    match (ty.desc, m) with
+    (* Impossible case due to the call to [Ctype.repr]. *)
+    | (Tlink _            , _      ) -> assert false
+    (* Impossible case (according to comment in [typing/types.mli]. *)
+    | (Tsubst(_)          , _      ) -> assert false
+    (* "Indifferent" case, the empty context is sufficient. *)
+    | (_                  , Ind    ) -> empty
+    (* Variable case, add constraint. *)
+    | (Tvar(alpha)        , m      ) ->
+        TVarMap.singleton {text = alpha; id = ty.Types.id} m
+    (* "Separable" case for constructors with known memory representation. *)
+    | (Tarrow _           , Sep    )
+    | (Ttuple _           , Sep    )
+    | (Tvariant(_)        , Sep    )
+    | (Tobject(_,_)       , Sep    )
+    | ((Tnil | Tfield _)  , Sep    )
+    | (Tpackage(_,_,_)    , Sep    ) -> empty
+    (* "Deeply separable" case for these same constructors. *)
+    | (Tarrow _           , Deepsep)
+    | (Ttuple _           , Deepsep)
+    | (Tvariant(_)        , Deepsep)
+    | (Tobject(_,_)       , Deepsep)
+    | ((Tnil | Tfield _)  , Deepsep)
+    | (Tpackage(_,_,_)    , Deepsep) ->
+        let tys = immediate_subtypes ty in
+        let on_subtype context ty =
+          context ++ check_type (Hyps.guard hyps) ty Deepsep in
+        List.fold_left on_subtype empty tys
+    (* Polymorphic type, and corresponding polymorphic variable.
+
+       In theory, [Tpoly] (forall alpha. tau) would add a new variable
+       (alpha) in scope, check its body (tau) recursively, and then
+       remove the new variable from the resulting context. Because the
+       rule accepts any mode for this variable, the removal never
+       fails.
+
+       In practice the implementation is simplified by ignoring the
+       new variable, and always returning the [empty] context
+       (instead of (alpha : m) in the [Tunivar] case: the constraint
+       on the variable is removed/ignored at the variable occurrence
+       site, rather than at the variable-introduction site. *)
+    (* Note: that we are semantically incomplete in the Deepsep case
+       (following the syntactic typing rules): the semantics only
+       requires that *closed* sub-type-expressions be (deeply)
+       separable; sub-type-expressions containing the quantified
+       variable cannot be extracted by constraints (this would be
+       a scope violation), so they could be ignored if they occur
+       under a separating type constructor. *)
+    | (Tpoly(pty,_)       , m      ) ->
+        check_type hyps pty m
+    | (Tunivar(_)         , _      ) -> empty
+    (* Type constructor case. *)
+    | (Tconstr(path,tys,_), m      ) ->
+        let msig = (Env.find_type path env).type_separability in
+        let on_param context (ty, m_param) =
+          let hyps = match m_param with
+            | Ind -> Hyps.guard hyps
+            | Sep -> hyps
+            | Deepsep -> Hyps.poison hyps in
+          context ++ check_type hyps ty (compose m m_param) in
+        List.fold_left on_param empty (List.combine tys msig)
+  in
+  check_type Hyps.empty ty m
+
+let best_msig decl = List.map (fun _ -> Ind) decl.type_params
+let worst_msig decl = List.map (fun _ -> Deepsep) decl.type_params
+
+(** [msig_of_external_type decl] infers the mode signature of an
+    abstract/external type. We must assume the worst, namely that this
+    type may be defined as an unboxed algebraic datatype imposing deep
+    separability of its parameters.
+
+    One exception is when the type is marked "immediate", which
+    guarantees that its representation is only integers.  Immediate
+    types are always separable, so [Ind] suffices for their
+    parameters.
+
+    Note: this differs from {!Types.Separability.default_signature},
+    which does not have access to the declaration and its immediacy. *)
+let msig_of_external_type decl =
+  match decl.type_immediate with
+  | Always | Always_on_64bits -> best_msig decl
+  | Unknown -> worst_msig decl
+
+(** [msig_of_context ~decl_loc constructor context] returns the
+   separability signature of a single-constructor type whose
+   definition is valid in the mode context [context].
+
+   Note: A GADT constructor introduces existential type variables, and
+   may also introduce some equalities between its return type
+   parameters and type expressions containing universal and
+   existential variables. In other words, it introduces new type
+   variables in scope, and restricts existing variables by adding
+   equality constraints.
+
+   [msig_of_context] performs the reverse transformation: the context
+   [ctx] computed from the argument of the constructor mentions
+   existential variables, and the function returns a context over the
+   (universal) type parameters only. (Type constraints do not
+   introduce existential variables, but they do introduce equalities;
+   they are handled as GADTs equalities by this function.)
+
+   The transformation is separability-preserving in the following
+   sense: for any valid instance of the result mode signature
+   (replacing the universal type parameters with ground types
+   respecting the variable's separability mode), any possible
+   extension of this context instance with ground instances for the
+   existential variables of [parameter] that respects the equation
+   constraints will validate the separability requirements of the
+   modes in the input context [ctx].
+
+   Sometimes no such universal context exists, as an existential type
+   cannot be safely introduced, then this function raises an [Error]
+   exception with a [Non_separable_evar] payload.  *)
+let msig_of_context : decl_loc:Location.t -> parameters:type_expr list
+    -> context -> Sep.signature =
+  fun ~decl_loc ~parameters context ->
+    let handle_equation (acc, context) param_instance =
+      (* In the theory, GADT equations are of the form
+           ('a = <ty>)
+         for each type parameter 'a of the type constructor. For each
+         such equation, we should "strengthen" the current context in
+         the following way:
+         - if <ty> is another variable 'b,
+           the mode of 'a is set to the mode of 'b,
+           and 'b is set to Ind
+         - if <ty> is a type expression whose variables are all Ind,
+           set 'a to Ind and discard the equation
+         - otherwise (one of the variable of 'b is not Ind),
+           set 'a to Deepsep and set all variables of <ty> to Ind
+
+         In practice, type parameters are determined by their position
+         in a list, they do not necessarily have a corresponding type variable.
+         Instead of "setting 'a" in the context as in the description above,
+         we build a list of modes by repeated consing into
+         an accumulator variable [acc], setting existential variables
+         to Ind as we go. *)
+      let param_instance = Ctype.repr param_instance in
+      let get context var =
+        try TVarMap.find var context with Not_found -> Ind in
+      let set_ind context var =
+        TVarMap.add var Ind context in
+      let is_ind context var = match get context var with
+        | Ind -> true
+        | Sep | Deepsep -> false in
+      match param_instance.desc with
+      | Tvar text ->
+          let var = {text; id = param_instance.Types.id} in
+          (get context var) :: acc, (set_ind context var)
+      | _ ->
+          let instance_exis = free_variables param_instance in
+          if List.for_all (is_ind context) instance_exis then
+            Ind :: acc, context
+          else
+            Deepsep :: acc, List.fold_left set_ind context instance_exis
+    in
+    let mode_signature, context =
+      let (mode_signature_rev, ctx) =
+        List.fold_left handle_equation ([], context) parameters in
+      (* Note: our inference system is not principal, because the
+         inference result depends on the order in which those
+         equations are processed. (To our knowledge this is the only
+         source of non-principality.) If two parameters ('a, 'b) are
+         forced to be equal to each other, and also separable, then
+         either modes (Sep, Ind) and (Ind, Sep) are correct, allow
+         more declarations than (Sep, Sep), but (Ind, Ind) would be
+         unsound.
+
+         Such a non-principal example is the following:
+
+           type ('a, 'b) almost_eq =
+             | Almost_refl : 'c -> ('c, 'c) almost_eq
+
+         (This example looks strange: GADT equations are typically
+         either on only one parameter, or on two parameters that are
+         not used to classify constructor arguments. Indeed, we have
+         not found non-principal declarations in real-world code.)
+
+         In a non-principal system, it is important the our choice of
+         non-unique solution be at least predictable. We find it more
+         natural, when either ('a : Sep, 'b : Ind) and ('a : Ind,
+         'b : Sep) are correct because 'a = 'b, to choose to make the
+         first/leftmost parameter more constrained. We read this as
+         saying that 'a must be Sep, and 'b = 'a so 'b can be
+         Ind. (We define the second parameter as equal of the first,
+         already-seen parameter; instead of saying that the first
+         parameter is equal to the not-yet-seen second one.)
+
+         This is achieved by processing the equations from left to
+         right with List.fold_left, instead of using
+         List.fold_right. The code is slightly more awkward as it
+         needs a List.rev on the accumulated modes, but it gives
+         a more predictable/natural (non-principal) behavior.
+  *)
+      (List.rev mode_signature_rev, ctx) in
+    (* After all variables determined by the parameters have been set to Ind
+       by [handle_equation], all variables remaining in the context are
+       purely existential and should not require a stronger mode than Ind. *)
+    let check_existential evar mode =
+      if rank mode > rank Ind then
+        raise (Error (decl_loc, Non_separable_evar evar.text))
+    in
+    TVarMap.iter check_existential context;
+    mode_signature
+
+(** [check_def env def] returns the signature required
+    for the type definition [def] in the typing environment [env].
+
+    The exception [Error] is raised if we discover that
+    no such signature exists -- the definition will always be invalid.
+    This only happens when the definition is marked to be unboxed. *)
+
+let check_def
+  : Env.t -> type_definition -> Sep.signature
+  = fun env def ->
+  let boxed = not def.type_unboxed.unboxed in
+  match structure def with
+  | Abstract ->
+      assert boxed;
+      msig_of_external_type def
+  | Synonym type_expr ->
+      check_type env type_expr Sep
+      |> msig_of_context ~decl_loc:def.type_loc ~parameters:def.type_params
+  | Open | Algebraic (Zero | Several | One (Zero | Several)) ->
+      assert boxed;
+      best_msig def
+  | Algebraic (One (One constructor)) ->
+    if boxed then best_msig def
+    else
+      check_type env constructor.argument_type Sep
+      |> msig_of_context ~decl_loc:def.type_loc
+           ~parameters:constructor.result_type_parameter_instances
+
+let compute_decl env decl =
+  if Config.flat_float_array then check_def env decl
+  else
+    (* Hack: in -no-flat-float-array mode, instead of always returning
+       [best_msig], we first compute the separability signature --
+       falling back to [best_msig] if it fails.
+
+       This discipline is conservative: it never
+       rejects -no-flat-float-array programs. At the same time it
+       guarantees that, for any program that is also accepted
+       in -flat-float-array mode, the same separability will be
+       inferred in the two modes. In particular, the same .cmi files
+       and digests will be produced.
+
+       Before we introduced this hack, the production of different
+       .cmi files would break the build system of the compiler itself,
+       when trying to build a -no-flat-float-array system from
+       a bootstrap compiler itself using -flat-float-array. See #9291.
+       *)
+    try check_def env decl with
+    | Error _ ->
+       (* It could be nice to emit a warning here, so that users know
+          that their definition would be rejected in -flat-float-array mode *)
+       best_msig decl
+
+(** Separability as a generic property *)
+type prop = Types.Separability.signature
+
+let property : (prop, unit) Typedecl_properties.property =
+  let open Typedecl_properties in
+  let eq ts1 ts2 =
+    List.length ts1 = List.length ts2
+    && List.for_all2 Sep.eq ts1 ts2 in
+  let merge ~prop:_ ~new_prop =
+    (* the update function is monotonous: ~new_prop is always
+       more informative than ~prop, which can be ignored *)
+    new_prop in
+  let default decl = best_msig decl in
+  let compute env decl () = compute_decl env decl in
+  let update_decl decl type_separability = { decl with type_separability } in
+  let check _env _id _decl () = () in (* FIXME run final check? *)
+  { eq; merge; default; compute; update_decl; check; }
+
+(* Definition using the fixpoint infrastructure. *)
+let update_decls env decls =
+  Typedecl_properties.compute_property_noreq property env decls
diff --git a/upstream/ocaml_412/typing/typedecl_separability.mli b/upstream/ocaml_412/typing/typedecl_separability.mli
new file mode 100644
index 0000000..079e640
--- /dev/null
+++ b/upstream/ocaml_412/typing/typedecl_separability.mli
@@ -0,0 +1,132 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** The OCaml runtime assumes for type-directed optimizations that all types
+    are "separable". A type is "separable" if either all its inhabitants
+    (the values of this type) are floating-point numbers, or none of them are.
+
+    (Note: This assumption is required for the dynamic float array optimization;
+    it is only made if Config.flat_float_array is set,
+    otherwise the code in this module becomes trivial
+    -- see {!compute_decl}.)
+
+    This soundness requirement could be broken by type declarations mixing
+    existentials and the "[@@unboxed]" annotation. Consider the declaration
+
+    {[
+       type any = Any : 'a -> any [@@unboxed]
+    ]}
+
+   which corresponds to the existential type "exists a. a". If this type is
+   allowed to be unboxed, then it is inhabited by both [float] values
+   and non-[float] values. On the contrary, if unboxing is disallowed, the
+   inhabitants are all blocks with the [Any] constructors pointing to its
+   parameter: they may point to a float, but they are not floats.
+
+   The present module contains a static analysis ensuring that declarations
+   annotated with "[@@unboxed]" can be safely unboxed. The idea is to check
+   the "separability" (in the above sense) of the argument type that would
+   be unboxed, and reject the unboxed declaration if it would create a
+   non-separable type.
+
+   Checking mutually-recursive type declarations is a bit subtle.
+   Consider, for example, the following declarations.
+
+   {[
+      type foo = Foo : 'a t -> foo   [@@unboxed]
+      and 'a t = ...
+   ]}
+
+   Deciding whether the type [foo] should be accepted requires inspecting
+   the declaration of ['a t], which may itself refer to [foo] in turn.
+   In general, the analysis performs a fixpoint computation. It is somewhat
+   similar to what is done for inferring the variance of type parameters.
+
+   Our analysis is defined using inference rules for our judgment
+   [Def; Gamma |- t : m], in which a type expression [t] is checked
+   against a "mode" [m]. This "mode" describes the separability
+   requirement on the type expression (see below for
+   more details). The mode [Gamma] maps type variables to modes and
+   [Def] records the "mode signature" of the mutually-recursive type
+   declarations that are being checked.
+
+   The "mode signature" of a type with parameters [('a, 'b) t] is of the
+   form [('a : m1, 'b : m2) t], where [m1] and [m2] are modes. Its meaning
+   is the following: a concrete instance [(foo, bar) t] of the type is
+   separable if [foo] has mode [m1] and [bar] has mode [m2]. *)
+
+type error =
+  | Non_separable_evar of string option
+exception Error of Location.t * error
+(** Exception raised when a type declaration is not separable, or when its
+    separability cannot be established. *)
+
+type mode = Types.Separability.t = Ind | Sep | Deepsep
+(** The mode [Sep] ("separable") characterizes types that are indeed separable:
+    either they only contain floating-point values, or none of the values
+    at this type are floating-point values.
+    On a type parameter, it indicates that this parameter must be
+    separable for the whole type definition to be separable. For
+    example, the mode signature for the type declaration [type 'a
+    t = 'a] is [('a : Sep) t]. For the right-hand side to be
+    separable, the parameter ['a] must be separable.
+
+    The mode [Ind] ("indifferent") characterizes any type -- separable
+    or not.
+    On a type parameter, it indicates that this parameter needs not be
+    separable for the whole type definition to be separable. For
+    example, [type 'a t = 'a * bool] does not require its parameter
+    ['a] to be separable as ['a * bool] can never contain [float]
+    values. Its mode signature is thus [('a : Ind) t].
+
+    Finally, the mode [Deepsep] ("deeply separable") characterizes
+    types that are separable, and whose type sub-expressions are also
+    separable. This advanced feature is only used in the presence of
+    constraints.
+    For example, [type 'a t = 'b   constraint 'a = 'b * bool]
+    may not be separable even if ['a] is (its separately depends on 'b,
+    a fragment of 'a), so its mode signature is [('a : Deepsep) t].
+
+    The different modes are ordered as [Ind < Sep < Deepsep] (from the least
+    demanding to the most demanding). *)
+
+val compute_decl : Env.t -> Types.type_declaration -> mode list
+(** [compute_decl env def] returns the signature required
+    for the type definition [def] in the typing environment [env]
+    -- including signatures for the current recursive block.
+
+    The {!Error} exception is raised if no such signature exists
+    -- the definition will always be invalid. This only happens
+    when the definition is marked to be unboxed.
+
+    Variant (or record) declarations that are not marked with the
+    "[@@unboxed]" annotation, including those that contain several variants
+    (or labels), are always separable. In particular, their mode signatures
+    do not require anything of their type parameters, which are marked [Ind].
+
+    Finally, if {!Config.flat_float_array} is not set, then separability
+    is not required anymore; we just use [Ind] as the mode of each parameter
+    without any check.
+*)
+
+(** Property interface (see {!Typedecl_properties}). These functions
+    rely on {!compute_decl} and raise the {!Error} exception on error. *)
+type prop = Types.Separability.signature
+val property : (prop, unit) Typedecl_properties.property
+val update_decls :
+  Env.t ->
+  (Ident.t * Typedecl_properties.decl) list ->
+  (Ident.t * Typedecl_properties.decl) list
diff --git a/upstream/ocaml_412/typing/typedecl_unboxed.ml b/upstream/ocaml_412/typing/typedecl_unboxed.ml
new file mode 100644
index 0000000..e2d29a8
--- /dev/null
+++ b/upstream/ocaml_412/typing/typedecl_unboxed.ml
@@ -0,0 +1,57 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Types
+
+type t =
+  | Unavailable
+  | This of type_expr
+  | Only_on_64_bits of type_expr
+
+(* We use the Ctype.expand_head_opt version of expand_head to get access
+   to the manifest type of private abbreviations. *)
+let rec get_unboxed_type_representation env ty fuel =
+  if fuel < 0 then Unavailable else
+  let ty = Ctype.repr (Ctype.expand_head_opt env ty) in
+  match ty.desc with
+  | Tconstr (p, args, _) ->
+    begin match Env.find_type p env with
+    | exception Not_found -> This ty
+    | {type_immediate = Always; _} ->
+        This Predef.type_int
+    | {type_immediate = Always_on_64bits; _} ->
+        Only_on_64_bits Predef.type_int
+    | {type_unboxed = {unboxed = false}} -> This ty
+    | {type_params; type_kind =
+         Type_record ([{ld_type = ty2; _}], _)
+       | Type_variant [{cd_args = Cstr_tuple [ty2]; _}]
+       | Type_variant [{cd_args = Cstr_record [{ld_type = ty2; _}]; _}]}
+
+      ->
+        let ty2 = match ty2.desc with Tpoly (t, _) -> t | _ -> ty2 in
+        get_unboxed_type_representation env
+          (Ctype.apply env type_params ty2 args) (fuel - 1)
+    | {type_kind=Type_abstract} -> Unavailable
+          (* This case can occur when checking a recursive unboxed type
+             declaration. *)
+    | _ -> assert false (* only the above can be unboxed *)
+    end
+  | _ -> This ty
+
+let get_unboxed_type_representation env ty =
+  (* Do not give too much fuel: PR#7424 *)
+  get_unboxed_type_representation env ty 100
+;;
diff --git a/upstream/ocaml_412/typing/typedecl_unboxed.mli b/upstream/ocaml_412/typing/typedecl_unboxed.mli
new file mode 100644
index 0000000..9afd38e
--- /dev/null
+++ b/upstream/ocaml_412/typing/typedecl_unboxed.mli
@@ -0,0 +1,25 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Types
+
+type t =
+  | Unavailable
+  | This of type_expr
+  | Only_on_64_bits of type_expr
+
+(* for typeopt.ml *)
+val get_unboxed_type_representation: Env.t -> type_expr -> t
diff --git a/upstream/ocaml_412/typing/typedecl_variance.ml b/upstream/ocaml_412/typing/typedecl_variance.ml
new file mode 100644
index 0000000..26f5e0e
--- /dev/null
+++ b/upstream/ocaml_412/typing/typedecl_variance.ml
@@ -0,0 +1,422 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Types
+
+module TypeSet = Btype.TypeSet
+module TypeMap = Btype.TypeMap
+
+type surface_variance = bool * bool * bool
+
+type variance_error =
+| Variance_not_satisfied of int
+| No_variable
+| Variance_not_reflected
+| Variance_not_deducible
+
+type error =
+| Bad_variance of variance_error * surface_variance * surface_variance
+| Varying_anonymous
+
+
+exception Error of Location.t * error
+
+(* Compute variance *)
+
+let get_variance ty visited =
+  try TypeMap.find ty !visited with Not_found -> Variance.null
+
+let compute_variance env visited vari ty =
+  let rec compute_variance_rec vari ty =
+    (* Format.eprintf "%a: %x@." Printtyp.type_expr ty (Obj.magic vari); *)
+    let ty = Ctype.repr ty in
+    let vari' = get_variance ty visited in
+    if Variance.subset vari vari' then () else
+    let vari = Variance.union vari vari' in
+    visited := TypeMap.add ty vari !visited;
+    let compute_same = compute_variance_rec vari in
+    match ty.desc with
+      Tarrow (_, ty1, ty2, _) ->
+        let open Variance in
+        let v = conjugate vari in
+        let v1 =
+          if mem May_pos v || mem May_neg v
+          then set May_weak true v else v
+        in
+        compute_variance_rec v1 ty1;
+        compute_same ty2
+    | Ttuple tl ->
+        List.iter compute_same tl
+    | Tconstr (path, tl, _) ->
+        let open Variance in
+        if tl = [] then () else begin
+          try
+            let decl = Env.find_type path env in
+            let cvari f = mem f vari in
+            List.iter2
+              (fun ty v ->
+                let cv f = mem f v in
+                let strict =
+                  cvari Inv && cv Inj || (cvari Pos || cvari Neg) && cv Inv
+                in
+                if strict then compute_variance_rec full ty else
+                let p1 = inter v vari
+                and n1 = inter v (conjugate vari) in
+                let v1 =
+                  union (inter covariant (union p1 (conjugate p1)))
+                    (inter (conjugate covariant) (union n1 (conjugate n1)))
+                and weak =
+                  cvari May_weak && (cv May_pos || cv May_neg) ||
+                  (cvari May_pos || cvari May_neg) && cv May_weak
+                in
+                let v2 = set May_weak weak v1 in
+                compute_variance_rec v2 ty)
+              tl decl.type_variance
+          with Not_found ->
+            List.iter (compute_variance_rec unknown) tl
+        end
+    | Tobject (ty, _) ->
+        compute_same ty
+    | Tfield (_, _, ty1, ty2) ->
+        compute_same ty1;
+        compute_same ty2
+    | Tsubst ty ->
+        compute_same ty
+    | Tvariant row ->
+        let row = Btype.row_repr row in
+        List.iter
+          (fun (_,f) ->
+            match Btype.row_field_repr f with
+              Rpresent (Some ty) ->
+                compute_same ty
+            | Reither (_, tyl, _, _) ->
+                let open Variance in
+                let upper =
+                  List.fold_left (fun s f -> set f true s)
+                    null [May_pos; May_neg; May_weak]
+                in
+                let v = inter vari upper in
+                (* cf PR#7269:
+                   if List.length tyl > 1 then upper else inter vari upper *)
+                List.iter (compute_variance_rec v) tyl
+            | _ -> ())
+          row.row_fields;
+        compute_same row.row_more
+    | Tpoly (ty, _) ->
+        compute_same ty
+    | Tvar _ | Tnil | Tlink _ | Tunivar _ -> ()
+    | Tpackage (_, _, tyl) ->
+        let v =
+          Variance.(if mem Pos vari || mem Neg vari then full else unknown)
+        in
+        List.iter (compute_variance_rec v) tyl
+  in
+  compute_variance_rec vari ty
+
+let make p n i =
+  let open Variance in
+  set May_pos p (set May_neg n (set May_weak n (set Inj i null)))
+
+let injective = Variance.(set Inj true null)
+
+let compute_variance_type env ~check (required, loc) decl tyl =
+  (* Requirements *)
+  let check_injectivity = decl.type_kind = Type_abstract in
+  let required =
+    List.map
+      (fun (c,n,i) ->
+        let i = if check_injectivity then i else false in
+        if c || n then (c,n,i) else (true,true,i))
+      required
+  in
+  (* Prepare *)
+  let params = List.map Btype.repr decl.type_params in
+  let tvl = ref TypeMap.empty in
+  (* Compute occurrences in the body *)
+  let open Variance in
+  List.iter
+    (fun (cn,ty) ->
+      compute_variance env tvl (if cn then full else covariant) ty)
+    tyl;
+  (* Infer injectivity of constrained parameters *)
+  if check_injectivity then
+    List.iter
+      (fun ty ->
+        if Btype.is_Tvar ty || mem Inj (get_variance ty tvl) then () else
+        let visited = ref TypeSet.empty in
+        let rec check ty =
+          let ty = Ctype.repr ty in
+          if TypeSet.mem ty !visited then () else begin
+            visited := TypeSet.add ty !visited;
+            if mem Inj (get_variance ty tvl) then () else
+            match ty.desc with
+            | Tvar _ -> raise Exit
+            | Tconstr _ ->
+                let old = !visited in
+                begin try
+                  Btype.iter_type_expr check ty
+                with Exit ->
+                  visited := old;
+                  let ty' = Ctype.expand_head_opt env ty in
+                  if ty == ty' then raise Exit else check ty'
+                end
+            | _ -> Btype.iter_type_expr check ty
+          end
+        in
+        try check ty; compute_variance env tvl injective ty
+        with Exit -> ())
+      params;
+  if check then begin
+    (* Check variance of parameters *)
+    let pos = ref 0 in
+    List.iter2
+      (fun ty (c, n, i) ->
+        incr pos;
+        let var = get_variance ty tvl in
+        let (co,cn) = get_upper var and ij = mem Inj var in
+        if Btype.is_Tvar ty && (co && not c || cn && not n) || not ij && i
+        then raise (Error(loc, Bad_variance
+                                (Variance_not_satisfied !pos,
+                                                        (co,cn,ij),
+                                                        (c,n,i)))))
+      params required;
+    (* Check propagation from constrained parameters *)
+    let args = Btype.newgenty (Ttuple params) in
+    let fvl = Ctype.free_variables args in
+    let fvl = List.filter (fun v -> not (List.memq v params)) fvl in
+    (* If there are no extra variables there is nothing to do *)
+    if fvl = [] then () else
+    let tvl2 = ref TypeMap.empty in
+    List.iter2
+      (fun ty (p,n,_) ->
+        if Btype.is_Tvar ty then () else
+        let v =
+          if p then if n then full else covariant else conjugate covariant in
+        compute_variance env tvl2 v ty)
+      params required;
+    let visited = ref TypeSet.empty in
+    let rec check ty =
+      let ty = Ctype.repr ty in
+      if TypeSet.mem ty !visited then () else
+      let visited' = TypeSet.add ty !visited in
+      visited := visited';
+      let v1 = get_variance ty tvl in
+      let snap = Btype.snapshot () in
+      let v2 =
+        TypeMap.fold
+          (fun t vt v ->
+            if Ctype.equal env false [ty] [t] then union vt v else v)
+          !tvl2 null in
+      Btype.backtrack snap;
+      let (c1,n1) = get_upper v1 and (c2,n2,_,i2) = get_lower v2 in
+      if c1 && not c2 || n1 && not n2 then
+        if List.memq ty fvl then
+          let code = if not i2 then No_variable
+                     else if c2 || n2 then Variance_not_reflected
+                     else Variance_not_deducible in
+          raise (Error (loc, Bad_variance (code, (c1,n1,false), (c2,n2,false))))
+        else
+          Btype.iter_type_expr check ty
+    in
+    List.iter (fun (_,ty) -> check ty) tyl;
+  end;
+  List.map2
+    (fun ty (p, n, i) ->
+      let v = get_variance ty tvl in
+      let tr = decl.type_private in
+      (* Use required variance where relevant *)
+      let concr = decl.type_kind <> Type_abstract (*|| tr = Type_new*) in
+      let (p, n) =
+        if tr = Private || not (Btype.is_Tvar ty) then (p, n) (* set *)
+        else (false, false) (* only check *)
+      and i = concr  || i && tr = Private in
+      let v = union v (make p n i) in
+      let v =
+        if not concr then v else
+        if mem Pos v && mem Neg v then full else
+        if Btype.is_Tvar ty then v else
+        union v
+          (if p then if n then full else covariant else conjugate covariant)
+      in
+      if decl.type_kind = Type_abstract && tr = Public then v else
+      set May_weak (mem May_neg v) v)
+    params required
+
+let add_false = List.map (fun ty -> false, ty)
+
+(* A parameter is constrained if it is either instantiated,
+   or it is a variable appearing in another parameter *)
+let constrained vars ty =
+  match ty.desc with
+  | Tvar _ -> List.exists (fun tl -> List.memq ty tl) vars
+  | _ -> true
+
+let for_constr = function
+  | Types.Cstr_tuple l -> add_false l
+  | Types.Cstr_record l ->
+      List.map
+        (fun {Types.ld_mutable; ld_type} -> (ld_mutable = Mutable, ld_type))
+        l
+
+let compute_variance_gadt env ~check (required, loc as rloc) decl
+    (tl, ret_type_opt) =
+  match ret_type_opt with
+  | None ->
+      compute_variance_type env ~check rloc {decl with type_private = Private}
+        (for_constr tl)
+  | Some ret_type ->
+      match Ctype.repr ret_type with
+      | {desc=Tconstr (_, tyl, _)} ->
+          (* let tyl = List.map (Ctype.expand_head env) tyl in *)
+          let tyl = List.map Ctype.repr tyl in
+          let fvl = List.map (Ctype.free_variables ?env:None) tyl in
+          let _ =
+            List.fold_left2
+              (fun (fv1,fv2) ty (c,n,_) ->
+                match fv2 with [] -> assert false
+                | fv :: fv2 ->
+                    (* fv1 @ fv2 = free_variables of other parameters *)
+                    if (c||n) && constrained (fv1 @ fv2) ty then
+                      raise (Error(loc, Varying_anonymous));
+                    (fv :: fv1, fv2))
+              ([], fvl) tyl required
+          in
+          compute_variance_type env ~check rloc
+            {decl with type_params = tyl; type_private = Private}
+            (for_constr tl)
+      | _ -> assert false
+
+let compute_variance_extension env ~check decl ext rloc =
+  compute_variance_gadt env ~check rloc
+    {decl with type_params = ext.ext_type_params}
+    (ext.ext_args, ext.ext_ret_type)
+
+let compute_variance_decl env ~check decl (required, _ as rloc) =
+  if (decl.type_kind = Type_abstract || decl.type_kind = Type_open)
+       && decl.type_manifest = None then
+    List.map
+      (fun (c, n, i) ->
+        make (not n) (not c) (decl.type_kind <> Type_abstract || i))
+      required
+  else
+  let mn =
+    match decl.type_manifest with
+      None -> []
+    | Some ty -> [false, ty]
+  in
+  match decl.type_kind with
+    Type_abstract | Type_open ->
+      compute_variance_type env ~check rloc decl mn
+  | Type_variant tll ->
+      if List.for_all (fun c -> c.Types.cd_res = None) tll then
+        compute_variance_type env ~check rloc decl
+          (mn @ List.flatten (List.map (fun c -> for_constr c.Types.cd_args)
+                                tll))
+      else begin
+        let mn =
+          List.map (fun (_,ty) -> (Types.Cstr_tuple [ty],None)) mn in
+        let tll =
+          mn @ List.map (fun c -> c.Types.cd_args, c.Types.cd_res) tll in
+        match List.map (compute_variance_gadt env ~check rloc decl) tll with
+        | vari :: rem ->
+            let varl = List.fold_left (List.map2 Variance.union) vari rem in
+            List.map
+              Variance.(fun v -> if mem Pos v && mem Neg v then full else v)
+              varl
+        | _ -> assert false
+      end
+  | Type_record (ftl, _) ->
+      compute_variance_type env ~check rloc decl
+        (mn @ List.map (fun {Types.ld_mutable; ld_type} ->
+             (ld_mutable = Mutable, ld_type)) ftl)
+
+let is_hash id =
+  let s = Ident.name id in
+  String.length s > 0 && s.[0] = '#'
+
+let check_variance_extension env decl ext rloc =
+  (* TODO: refactorize compute_variance_extension *)
+  ignore (compute_variance_extension env ~check:true decl
+    ext.Typedtree.ext_type rloc)
+
+let compute_decl env ~check decl req =
+  compute_variance_decl env ~check decl (req, decl.type_loc)
+
+let check_decl env decl req =
+  ignore (compute_variance_decl env ~check:true decl (req, decl.type_loc))
+
+type prop = Variance.t list
+type req = surface_variance list
+let property : (prop, req) Typedecl_properties.property =
+  let open Typedecl_properties in
+  let eq li1 li2 =
+    try List.for_all2 Variance.eq li1 li2 with _ -> false in
+  let merge ~prop ~new_prop =
+    List.map2 Variance.union prop new_prop in
+  let default decl =
+    List.map (fun _ -> Variance.null) decl.type_params in
+  let compute env decl req =
+    compute_decl env ~check:false decl req in
+  let update_decl decl variance =
+    { decl with type_variance = variance } in
+  let check env id decl req =
+    if is_hash id then () else check_decl env decl req in
+  {
+    eq;
+    merge;
+    default;
+    compute;
+    update_decl;
+    check;
+  }
+
+let transl_variance (v, i) =
+  let co, cn =
+    match v with
+    | Covariant -> (true, false)
+    | Contravariant -> (false, true)
+    | NoVariance -> (false, false)
+  in
+  (co, cn, match i with Injective -> true | NoInjectivity -> false)
+
+let variance_of_params ptype_params =
+  List.map transl_variance (List.map snd ptype_params)
+
+let variance_of_sdecl sdecl =
+  variance_of_params sdecl.Parsetree.ptype_params
+
+let update_decls env sdecls decls =
+  let required = List.map variance_of_sdecl sdecls in
+  Typedecl_properties.compute_property property env decls required
+
+let update_class_decls env cldecls =
+  let decls, required =
+    List.fold_right
+      (fun (obj_id, obj_abbr, _cl_abbr, _clty, _cltydef, ci) (decls, req) ->
+        (obj_id, obj_abbr) :: decls,
+        variance_of_params ci.Typedtree.ci_params :: req)
+      cldecls ([],[])
+  in
+  let decls =
+    Typedecl_properties.compute_property property env decls required in
+  List.map2
+    (fun (_,decl) (_, _, cl_abbr, clty, cltydef, _) ->
+      let variance = decl.type_variance in
+      (decl, {cl_abbr with type_variance = variance},
+       {clty with cty_variance = variance},
+       {cltydef with clty_variance = variance}))
+    decls cldecls
diff --git a/upstream/ocaml_412/typing/typedecl_variance.mli b/upstream/ocaml_412/typing/typedecl_variance.mli
new file mode 100644
index 0000000..941ab99
--- /dev/null
+++ b/upstream/ocaml_412/typing/typedecl_variance.mli
@@ -0,0 +1,63 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Types
+open Typedecl_properties
+
+type surface_variance = bool * bool * bool
+
+val variance_of_params :
+  (Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list ->
+  surface_variance list
+val variance_of_sdecl :
+  Parsetree.type_declaration -> surface_variance list
+
+type prop = Variance.t list
+type req = surface_variance list
+val property : (Variance.t list, req) property
+
+type variance_error =
+| Variance_not_satisfied of int
+| No_variable
+| Variance_not_reflected
+| Variance_not_deducible
+
+type error =
+| Bad_variance of variance_error * surface_variance * surface_variance
+| Varying_anonymous
+
+exception Error of Location.t * error
+
+val check_variance_extension :
+  Env.t -> type_declaration ->
+  Typedtree.extension_constructor -> req * Location.t -> unit
+
+val compute_decl :
+  Env.t -> check:bool -> type_declaration -> req -> prop
+
+val update_decls :
+  Env.t -> Parsetree.type_declaration list ->
+  (Ident.t * type_declaration) list ->
+  (Ident.t * type_declaration) list
+
+val update_class_decls :
+  Env.t ->
+  (Ident.t * Typedecl_properties.decl * Types.type_declaration *
+   Types.class_declaration * Types.class_type_declaration *
+   'a Typedtree.class_infos) list ->
+  (Typedecl_properties.decl * Types.type_declaration *
+   Types.class_declaration * Types.class_type_declaration) list
+(* FIXME: improve this horrible interface *)
diff --git a/upstream/ocaml_412/typing/typedtree.ml b/upstream/ocaml_412/typing/typedtree.ml
new file mode 100644
index 0000000..ca81b0f
--- /dev/null
+++ b/upstream/ocaml_412/typing/typedtree.ml
@@ -0,0 +1,832 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Abstract syntax tree after typing *)
+
+open Asttypes
+open Types
+
+(* Value expressions for the core language *)
+
+type partial = Partial | Total
+
+type attribute = Parsetree.attribute
+type attributes = attribute list
+
+type value = Value_pattern
+type computation = Computation_pattern
+
+type _ pattern_category =
+| Value : value pattern_category
+| Computation : computation pattern_category
+
+type pattern = value general_pattern
+and 'k general_pattern = 'k pattern_desc pattern_data
+
+and 'a pattern_data =
+  { pat_desc: 'a;
+    pat_loc: Location.t;
+    pat_extra : (pat_extra * Location.t * attribute list) list;
+    pat_type: type_expr;
+    pat_env: Env.t;
+    pat_attributes: attribute list;
+   }
+
+and pat_extra =
+  | Tpat_constraint of core_type
+  | Tpat_type of Path.t * Longident.t loc
+  | Tpat_open of Path.t * Longident.t loc * Env.t
+  | Tpat_unpack
+
+and 'k pattern_desc =
+  (* value patterns *)
+  | Tpat_any : value pattern_desc
+  | Tpat_var : Ident.t * string loc -> value pattern_desc
+  | Tpat_alias :
+      value general_pattern * Ident.t * string loc -> value pattern_desc
+  | Tpat_constant : constant -> value pattern_desc
+  | Tpat_tuple : value general_pattern list -> value pattern_desc
+  | Tpat_construct :
+      Longident.t loc * constructor_description * value general_pattern list ->
+      value pattern_desc
+  | Tpat_variant :
+      label * value general_pattern option * row_desc ref ->
+      value pattern_desc
+  | Tpat_record :
+      (Longident.t loc * label_description * value general_pattern) list *
+        closed_flag ->
+      value pattern_desc
+  | Tpat_array : value general_pattern list -> value pattern_desc
+  | Tpat_lazy : value general_pattern -> value pattern_desc
+  (* computation patterns *)
+  | Tpat_value : tpat_value_argument -> computation pattern_desc
+  | Tpat_exception : value general_pattern -> computation pattern_desc
+  (* generic constructions *)
+  | Tpat_or :
+      'k general_pattern * 'k general_pattern * row_desc option ->
+      'k pattern_desc
+
+and tpat_value_argument = value general_pattern
+
+and expression =
+  { exp_desc: expression_desc;
+    exp_loc: Location.t;
+    exp_extra: (exp_extra * Location.t * attribute list) list;
+    exp_type: type_expr;
+    exp_env: Env.t;
+    exp_attributes: attribute list;
+   }
+
+and exp_extra =
+  | Texp_constraint of core_type
+  | Texp_coerce of core_type option * core_type
+  | Texp_poly of core_type option
+  | Texp_newtype of string
+
+and expression_desc =
+    Texp_ident of Path.t * Longident.t loc * Types.value_description
+  | Texp_constant of constant
+  | Texp_let of rec_flag * value_binding list * expression
+  | Texp_function of { arg_label : arg_label; param : Ident.t;
+      cases : value case list; partial : partial; }
+  | Texp_apply of expression * (arg_label * expression option) list
+  | Texp_match of expression * computation case list * partial
+  | Texp_try of expression * value case list
+  | Texp_tuple of expression list
+  | Texp_construct of
+      Longident.t loc * constructor_description * expression list
+  | Texp_variant of label * expression option
+  | Texp_record of {
+      fields : ( Types.label_description * record_label_definition ) array;
+      representation : Types.record_representation;
+      extended_expression : expression option;
+    }
+  | Texp_field of expression * Longident.t loc * label_description
+  | Texp_setfield of
+      expression * Longident.t loc * label_description * expression
+  | Texp_array of expression list
+  | Texp_ifthenelse of expression * expression * expression option
+  | Texp_sequence of expression * expression
+  | Texp_while of expression * expression
+  | Texp_for of
+      Ident.t * Parsetree.pattern * expression * expression * direction_flag *
+        expression
+  | Texp_send of expression * meth * expression option
+  | Texp_new of Path.t * Longident.t loc * Types.class_declaration
+  | Texp_instvar of Path.t * Path.t * string loc
+  | Texp_setinstvar of Path.t * Path.t * string loc * expression
+  | Texp_override of Path.t * (Path.t * string loc * expression) list
+  | Texp_letmodule of
+      Ident.t option * string option loc * Types.module_presence * module_expr *
+        expression
+  | Texp_letexception of extension_constructor * expression
+  | Texp_assert of expression
+  | Texp_lazy of expression
+  | Texp_object of class_structure * string list
+  | Texp_pack of module_expr
+  | Texp_letop of {
+      let_ : binding_op;
+      ands : binding_op list;
+      param : Ident.t;
+      body : value case;
+      partial : partial;
+    }
+  | Texp_unreachable
+  | Texp_extension_constructor of Longident.t loc * Path.t
+  | Texp_open of open_declaration * expression
+
+and meth =
+    Tmeth_name of string
+  | Tmeth_val of Ident.t
+
+and 'k case =
+    {
+     c_lhs: 'k general_pattern;
+     c_guard: expression option;
+     c_rhs: expression;
+    }
+
+and record_label_definition =
+  | Kept of Types.type_expr
+  | Overridden of Longident.t loc * expression
+
+and binding_op =
+  {
+    bop_op_path : Path.t;
+    bop_op_name : string loc;
+    bop_op_val : Types.value_description;
+    bop_op_type : Types.type_expr;
+    bop_exp : expression;
+    bop_loc : Location.t;
+  }
+
+(* Value expressions for the class language *)
+
+and class_expr =
+    {
+     cl_desc: class_expr_desc;
+     cl_loc: Location.t;
+     cl_type: Types.class_type;
+     cl_env: Env.t;
+     cl_attributes: attribute list;
+    }
+
+and class_expr_desc =
+    Tcl_ident of Path.t * Longident.t loc * core_type list
+  | Tcl_structure of class_structure
+  | Tcl_fun of
+      arg_label * pattern * (Ident.t * expression) list
+      * class_expr * partial
+  | Tcl_apply of class_expr * (arg_label * expression option) list
+  | Tcl_let of rec_flag * value_binding list *
+                  (Ident.t * expression) list * class_expr
+  | Tcl_constraint of
+      class_expr * class_type option * string list * string list * Concr.t
+    (* Visible instance variables, methods and concrete methods *)
+  | Tcl_open of open_description * class_expr
+
+and class_structure =
+  {
+   cstr_self: pattern;
+   cstr_fields: class_field list;
+   cstr_type: Types.class_signature;
+   cstr_meths: Ident.t Meths.t;
+  }
+
+and class_field =
+   {
+    cf_desc: class_field_desc;
+    cf_loc: Location.t;
+    cf_attributes: attribute list;
+  }
+
+and class_field_kind =
+  | Tcfk_virtual of core_type
+  | Tcfk_concrete of override_flag * expression
+
+and class_field_desc =
+    Tcf_inherit of
+      override_flag * class_expr * string option * (string * Ident.t) list *
+        (string * Ident.t) list
+    (* Inherited instance variables and concrete methods *)
+  | Tcf_val of string loc * mutable_flag * Ident.t * class_field_kind * bool
+  | Tcf_method of string loc * private_flag * class_field_kind
+  | Tcf_constraint of core_type * core_type
+  | Tcf_initializer of expression
+  | Tcf_attribute of attribute
+
+(* Value expressions for the module language *)
+
+and module_expr =
+  { mod_desc: module_expr_desc;
+    mod_loc: Location.t;
+    mod_type: Types.module_type;
+    mod_env: Env.t;
+    mod_attributes: attribute list;
+   }
+
+and module_type_constraint =
+  Tmodtype_implicit
+| Tmodtype_explicit of module_type
+
+and functor_parameter =
+  | Unit
+  | Named of Ident.t option * string option loc * module_type
+
+and module_expr_desc =
+    Tmod_ident of Path.t * Longident.t loc
+  | Tmod_structure of structure
+  | Tmod_functor of functor_parameter * module_expr
+  | Tmod_apply of module_expr * module_expr * module_coercion
+  | Tmod_constraint of
+      module_expr * Types.module_type * module_type_constraint * module_coercion
+  | Tmod_unpack of expression * Types.module_type
+
+and structure = {
+  str_items : structure_item list;
+  str_type : Types.signature;
+  str_final_env : Env.t;
+}
+
+and structure_item =
+  { str_desc : structure_item_desc;
+    str_loc : Location.t;
+    str_env : Env.t
+  }
+
+and structure_item_desc =
+    Tstr_eval of expression * attributes
+  | Tstr_value of rec_flag * value_binding list
+  | Tstr_primitive of value_description
+  | Tstr_type of rec_flag * type_declaration list
+  | Tstr_typext of type_extension
+  | Tstr_exception of type_exception
+  | Tstr_module of module_binding
+  | Tstr_recmodule of module_binding list
+  | Tstr_modtype of module_type_declaration
+  | Tstr_open of open_declaration
+  | Tstr_class of (class_declaration * string list) list
+  | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list
+  | Tstr_include of include_declaration
+  | Tstr_attribute of attribute
+
+and module_binding =
+    {
+     mb_id: Ident.t option;
+     mb_name: string option loc;
+     mb_presence: module_presence;
+     mb_expr: module_expr;
+     mb_attributes: attribute list;
+     mb_loc: Location.t;
+    }
+
+and value_binding =
+  {
+    vb_pat: pattern;
+    vb_expr: expression;
+    vb_attributes: attributes;
+    vb_loc: Location.t;
+  }
+
+and module_coercion =
+    Tcoerce_none
+  | Tcoerce_structure of (int * module_coercion) list *
+                         (Ident.t * int * module_coercion) list
+  | Tcoerce_functor of module_coercion * module_coercion
+  | Tcoerce_primitive of primitive_coercion
+  | Tcoerce_alias of Env.t * Path.t * module_coercion
+
+and module_type =
+  { mty_desc: module_type_desc;
+    mty_type : Types.module_type;
+    mty_env : Env.t;
+    mty_loc: Location.t;
+    mty_attributes: attribute list;
+   }
+
+and module_type_desc =
+    Tmty_ident of Path.t * Longident.t loc
+  | Tmty_signature of signature
+  | Tmty_functor of functor_parameter * module_type
+  | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list
+  | Tmty_typeof of module_expr
+  | Tmty_alias of Path.t * Longident.t loc
+
+(* Keep primitive type information for type-based lambda-code specialization *)
+and primitive_coercion =
+  {
+    pc_desc: Primitive.description;
+    pc_type: type_expr;
+    pc_env: Env.t;
+    pc_loc : Location.t;
+  }
+
+and signature = {
+  sig_items : signature_item list;
+  sig_type : Types.signature;
+  sig_final_env : Env.t;
+}
+
+and signature_item =
+  { sig_desc: signature_item_desc;
+    sig_env : Env.t; (* BINANNOT ADDED *)
+    sig_loc: Location.t }
+
+and signature_item_desc =
+    Tsig_value of value_description
+  | Tsig_type of rec_flag * type_declaration list
+  | Tsig_typesubst of type_declaration list
+  | Tsig_typext of type_extension
+  | Tsig_exception of type_exception
+  | Tsig_module of module_declaration
+  | Tsig_modsubst of module_substitution
+  | Tsig_recmodule of module_declaration list
+  | Tsig_modtype of module_type_declaration
+  | Tsig_open of open_description
+  | Tsig_include of include_description
+  | Tsig_class of class_description list
+  | Tsig_class_type of class_type_declaration list
+  | Tsig_attribute of attribute
+
+and module_declaration =
+    {
+     md_id: Ident.t option;
+     md_name: string option loc;
+     md_presence: module_presence;
+     md_type: module_type;
+     md_attributes: attribute list;
+     md_loc: Location.t;
+    }
+
+and module_substitution =
+    {
+     ms_id: Ident.t;
+     ms_name: string loc;
+     ms_manifest: Path.t;
+     ms_txt: Longident.t loc;
+     ms_attributes: attributes;
+     ms_loc: Location.t;
+    }
+
+and module_type_declaration =
+    {
+     mtd_id: Ident.t;
+     mtd_name: string loc;
+     mtd_type: module_type option;
+     mtd_attributes: attribute list;
+     mtd_loc: Location.t;
+    }
+
+and 'a open_infos =
+    {
+     open_expr: 'a;
+     open_bound_items: Types.signature;
+     open_override: override_flag;
+     open_env: Env.t;
+     open_loc: Location.t;
+     open_attributes: attribute list;
+    }
+
+and open_description = (Path.t * Longident.t loc) open_infos
+
+and open_declaration = module_expr open_infos
+
+and 'a include_infos =
+    {
+     incl_mod: 'a;
+     incl_type: Types.signature;
+     incl_loc: Location.t;
+     incl_attributes: attribute list;
+    }
+
+and include_description = module_type include_infos
+
+and include_declaration = module_expr include_infos
+
+and with_constraint =
+    Twith_type of type_declaration
+  | Twith_module of Path.t * Longident.t loc
+  | Twith_typesubst of type_declaration
+  | Twith_modsubst of Path.t * Longident.t loc
+
+and core_type =
+(* mutable because of [Typeclass.declare_method] *)
+  { mutable ctyp_desc : core_type_desc;
+    mutable ctyp_type : type_expr;
+    ctyp_env : Env.t; (* BINANNOT ADDED *)
+    ctyp_loc : Location.t;
+    ctyp_attributes: attribute list;
+   }
+
+and core_type_desc =
+    Ttyp_any
+  | Ttyp_var of string
+  | Ttyp_arrow of arg_label * core_type * core_type
+  | Ttyp_tuple of core_type list
+  | Ttyp_constr of Path.t * Longident.t loc * core_type list
+  | Ttyp_object of object_field list * closed_flag
+  | Ttyp_class of Path.t * Longident.t loc * core_type list
+  | Ttyp_alias of core_type * string
+  | Ttyp_variant of row_field list * closed_flag * label list option
+  | Ttyp_poly of string list * core_type
+  | Ttyp_package of package_type
+
+and package_type = {
+  pack_path : Path.t;
+  pack_fields : (Longident.t loc * core_type) list;
+  pack_type : Types.module_type;
+  pack_txt : Longident.t loc;
+}
+
+and row_field = {
+  rf_desc : row_field_desc;
+  rf_loc : Location.t;
+  rf_attributes : attributes;
+}
+
+and row_field_desc =
+    Ttag of string loc * bool * core_type list
+  | Tinherit of core_type
+
+and object_field = {
+  of_desc : object_field_desc;
+  of_loc : Location.t;
+  of_attributes : attributes;
+}
+
+and object_field_desc =
+  | OTtag of string loc * core_type
+  | OTinherit of core_type
+
+and value_description =
+  { val_id: Ident.t;
+    val_name: string loc;
+    val_desc: core_type;
+    val_val: Types.value_description;
+    val_prim: string list;
+    val_loc: Location.t;
+    val_attributes: attribute list;
+    }
+
+and type_declaration =
+  { typ_id: Ident.t;
+    typ_name: string loc;
+    typ_params: (core_type * (variance * injectivity)) list;
+    typ_type: Types.type_declaration;
+    typ_cstrs: (core_type * core_type * Location.t) list;
+    typ_kind: type_kind;
+    typ_private: private_flag;
+    typ_manifest: core_type option;
+    typ_loc: Location.t;
+    typ_attributes: attribute list;
+   }
+
+and type_kind =
+    Ttype_abstract
+  | Ttype_variant of constructor_declaration list
+  | Ttype_record of label_declaration list
+  | Ttype_open
+
+and label_declaration =
+    {
+     ld_id: Ident.t;
+     ld_name: string loc;
+     ld_mutable: mutable_flag;
+     ld_type: core_type;
+     ld_loc: Location.t;
+     ld_attributes: attribute list;
+    }
+
+and constructor_declaration =
+    {
+     cd_id: Ident.t;
+     cd_name: string loc;
+     cd_args: constructor_arguments;
+     cd_res: core_type option;
+     cd_loc: Location.t;
+     cd_attributes: attribute list;
+    }
+
+and constructor_arguments =
+  | Cstr_tuple of core_type list
+  | Cstr_record of label_declaration list
+
+and type_extension =
+  {
+    tyext_path: Path.t;
+    tyext_txt: Longident.t loc;
+    tyext_params: (core_type * (variance * injectivity)) list;
+    tyext_constructors: extension_constructor list;
+    tyext_private: private_flag;
+    tyext_loc: Location.t;
+    tyext_attributes: attribute list;
+  }
+
+and type_exception =
+  {
+    tyexn_constructor: extension_constructor;
+    tyexn_loc: Location.t;
+    tyexn_attributes: attribute list;
+  }
+
+and extension_constructor =
+  {
+    ext_id: Ident.t;
+    ext_name: string loc;
+    ext_type: Types.extension_constructor;
+    ext_kind: extension_constructor_kind;
+    ext_loc: Location.t;
+    ext_attributes: attribute list;
+  }
+
+and extension_constructor_kind =
+    Text_decl of constructor_arguments * core_type option
+  | Text_rebind of Path.t * Longident.t loc
+
+and class_type =
+    {
+     cltyp_desc: class_type_desc;
+     cltyp_type: Types.class_type;
+     cltyp_env: Env.t;
+     cltyp_loc: Location.t;
+     cltyp_attributes: attribute list;
+    }
+
+and class_type_desc =
+    Tcty_constr of Path.t * Longident.t loc * core_type list
+  | Tcty_signature of class_signature
+  | Tcty_arrow of arg_label * core_type * class_type
+  | Tcty_open of open_description * class_type
+
+and class_signature = {
+    csig_self: core_type;
+    csig_fields: class_type_field list;
+    csig_type: Types.class_signature;
+  }
+
+and class_type_field = {
+    ctf_desc: class_type_field_desc;
+    ctf_loc: Location.t;
+    ctf_attributes: attribute list;
+  }
+
+and class_type_field_desc =
+  | Tctf_inherit of class_type
+  | Tctf_val of (string * mutable_flag * virtual_flag * core_type)
+  | Tctf_method of (string * private_flag * virtual_flag * core_type)
+  | Tctf_constraint of (core_type * core_type)
+  | Tctf_attribute of attribute
+
+and class_declaration =
+  class_expr class_infos
+
+and class_description =
+  class_type class_infos
+
+and class_type_declaration =
+  class_type class_infos
+
+and 'a class_infos =
+  { ci_virt: virtual_flag;
+    ci_params: (core_type * (variance * injectivity)) list;
+    ci_id_name: string loc;
+    ci_id_class: Ident.t;
+    ci_id_class_type: Ident.t;
+    ci_id_object: Ident.t;
+    ci_id_typehash: Ident.t;
+    ci_expr: 'a;
+    ci_decl: Types.class_declaration;
+    ci_type_decl: Types.class_type_declaration;
+    ci_loc: Location.t;
+    ci_attributes: attribute list;
+   }
+
+(* Auxiliary functions over the a.s.t. *)
+
+let as_computation_pattern (p : pattern) : computation general_pattern =
+  {
+    pat_desc = Tpat_value p;
+    pat_loc = p.pat_loc;
+    pat_extra = [];
+    pat_type = p.pat_type;
+    pat_env = p.pat_env;
+    pat_attributes = [];
+  }
+
+let rec classify_pattern_desc : type k . k pattern_desc -> k pattern_category =
+  function
+  | Tpat_alias _ -> Value
+  | Tpat_tuple _ -> Value
+  | Tpat_construct _ -> Value
+  | Tpat_variant _ -> Value
+  | Tpat_record _ -> Value
+  | Tpat_array _ -> Value
+  | Tpat_lazy _ -> Value
+  | Tpat_any -> Value
+  | Tpat_var _ -> Value
+  | Tpat_constant _ -> Value
+
+  | Tpat_value _ -> Computation
+  | Tpat_exception _ -> Computation
+
+  | Tpat_or(p1, p2, _) ->
+     begin match classify_pattern p1, classify_pattern p2 with
+     | Value, Value -> Value
+     | Computation, Computation -> Computation
+     end
+
+and classify_pattern
+  : type k . k general_pattern -> k pattern_category
+  = fun pat ->
+  classify_pattern_desc pat.pat_desc
+
+type pattern_action =
+  { f : 'k . 'k general_pattern -> unit }
+let shallow_iter_pattern_desc
+  : type k . pattern_action -> k pattern_desc -> unit
+  = fun f -> function
+  | Tpat_alias(p, _, _) -> f.f p
+  | Tpat_tuple patl -> List.iter f.f patl
+  | Tpat_construct(_, _, patl) -> List.iter f.f patl
+  | Tpat_variant(_, pat, _) -> Option.iter f.f pat
+  | Tpat_record (lbl_pat_list, _) ->
+      List.iter (fun (_, _, pat) -> f.f pat) lbl_pat_list
+  | Tpat_array patl -> List.iter f.f patl
+  | Tpat_lazy p -> f.f p
+  | Tpat_any
+  | Tpat_var _
+  | Tpat_constant _ -> ()
+  | Tpat_value p -> f.f p
+  | Tpat_exception p -> f.f p
+  | Tpat_or(p1, p2, _) -> f.f p1; f.f p2
+
+type pattern_transformation =
+  { f : 'k . 'k general_pattern -> 'k general_pattern }
+let shallow_map_pattern_desc
+  : type k . pattern_transformation -> k pattern_desc -> k pattern_desc
+  = fun f d -> match d with
+  | Tpat_alias (p1, id, s) ->
+      Tpat_alias (f.f p1, id, s)
+  | Tpat_tuple pats ->
+      Tpat_tuple (List.map f.f pats)
+  | Tpat_record (lpats, closed) ->
+      Tpat_record (List.map (fun (lid, l,p) -> lid, l, f.f p) lpats, closed)
+  | Tpat_construct (lid, c,pats) ->
+      Tpat_construct (lid, c, List.map f.f pats)
+  | Tpat_array pats ->
+      Tpat_array (List.map f.f pats)
+  | Tpat_lazy p1 -> Tpat_lazy (f.f p1)
+  | Tpat_variant (x1, Some p1, x2) ->
+      Tpat_variant (x1, Some (f.f p1), x2)
+  | Tpat_var _
+  | Tpat_constant _
+  | Tpat_any
+  | Tpat_variant (_,None,_) -> d
+  | Tpat_value p -> Tpat_value (f.f p)
+  | Tpat_exception p -> Tpat_exception (f.f p)
+  | Tpat_or (p1,p2,path) ->
+      Tpat_or (f.f p1, f.f p2, path)
+
+let rec iter_general_pattern
+  : type k . pattern_action -> k general_pattern -> unit
+  = fun f p ->
+  f.f p;
+  shallow_iter_pattern_desc
+    { f = fun p -> iter_general_pattern f p }
+    p.pat_desc
+
+let iter_pattern (f : pattern -> unit) =
+  iter_general_pattern
+    { f = fun (type k) (p : k general_pattern) ->
+          match classify_pattern p with
+          | Value -> f p
+          | Computation -> () }
+
+type pattern_predicate = { f : 'k . 'k general_pattern -> bool }
+let exists_general_pattern (f : pattern_predicate) p =
+  let exception Found in
+  match
+    iter_general_pattern
+      { f = fun p -> if f.f p then raise Found else () }
+      p
+  with
+  | exception Found -> true
+  | () -> false
+
+let exists_pattern (f : pattern -> bool) =
+  exists_general_pattern
+    { f = fun (type k) (p : k general_pattern) ->
+          match classify_pattern p with
+          | Value -> f p
+          | Computation -> false }
+
+
+(* List the identifiers bound by a pattern or a let *)
+
+let rec iter_bound_idents
+  : type k . _ -> k general_pattern -> _
+  = fun f pat ->
+  match pat.pat_desc with
+  | Tpat_var (id,s) ->
+     f (id,s,pat.pat_type)
+  | Tpat_alias(p, id, s) ->
+      iter_bound_idents f p;
+      f (id,s,pat.pat_type)
+  | Tpat_or(p1, _, _) ->
+      (* Invariant : both arguments bind the same variables *)
+      iter_bound_idents f p1
+  | d ->
+     shallow_iter_pattern_desc
+       { f = fun p -> iter_bound_idents f p }
+       d
+
+let rev_pat_bound_idents_full pat =
+  let idents_full = ref [] in
+  let add id_full = idents_full := id_full :: !idents_full in
+  iter_bound_idents add pat;
+  !idents_full
+
+let rev_only_idents idents_full =
+  List.rev_map (fun (id,_,_) -> id) idents_full
+
+let pat_bound_idents_full pat =
+  List.rev (rev_pat_bound_idents_full pat)
+let pat_bound_idents pat =
+  rev_only_idents (rev_pat_bound_idents_full pat)
+
+let rev_let_bound_idents_full bindings =
+  let idents_full = ref [] in
+  let add id_full = idents_full := id_full :: !idents_full in
+  List.iter (fun vb -> iter_bound_idents add vb.vb_pat) bindings;
+  !idents_full
+
+let let_bound_idents_full bindings =
+  List.rev (rev_let_bound_idents_full bindings)
+let let_bound_idents pat =
+  rev_only_idents (rev_let_bound_idents_full pat)
+
+let alpha_var env id = List.assoc id env
+
+let rec alpha_pat
+  : type k . _ -> k general_pattern -> k general_pattern
+  = fun env p -> match p.pat_desc with
+  | Tpat_var (id, s) -> (* note the ``Not_found'' case *)
+      {p with pat_desc =
+       try Tpat_var (alpha_var env id, s) with
+       | Not_found -> Tpat_any}
+  | Tpat_alias (p1, id, s) ->
+      let new_p =  alpha_pat env p1 in
+      begin try
+        {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s)}
+      with
+      | Not_found -> new_p
+      end
+  | d ->
+     let pat_desc =
+       shallow_map_pattern_desc { f = fun p -> alpha_pat env p } d in
+     {p with pat_desc}
+
+let mkloc = Location.mkloc
+let mknoloc = Location.mknoloc
+
+let split_pattern pat =
+  let combine_opts merge p1 p2 =
+    match p1, p2 with
+    | None, None -> None
+    | Some p, None
+    | None, Some p ->
+        Some p
+    | Some p1, Some p2 ->
+        Some (merge p1 p2)
+  in
+  let into pat p1 p2 =
+    (* The third parameter of [Tpat_or] is [Some _] only for "#typ"
+       patterns, which we do *not* expand. Hence we can put [None] here. *)
+    { pat with pat_desc = Tpat_or (p1, p2, None) } in
+  let rec split_pattern cpat =
+    match cpat.pat_desc with
+    | Tpat_value p ->
+        Some p, None
+    | Tpat_exception p ->
+        None, Some p
+    | Tpat_or (cp1, cp2, _) ->
+        let vals1, exns1 = split_pattern cp1 in
+        let vals2, exns2 = split_pattern cp2 in
+        combine_opts (into cpat) vals1 vals2,
+        (* We could change the pattern type for exception patterns to
+           [Predef.exn], but it doesn't really matter. *)
+        combine_opts (into cpat) exns1 exns2
+  in
+  split_pattern pat
diff --git a/upstream/ocaml_412/typing/typedtree.mli b/upstream/ocaml_412/typing/typedtree.mli
new file mode 100644
index 0000000..1323505
--- /dev/null
+++ b/upstream/ocaml_412/typing/typedtree.mli
@@ -0,0 +1,800 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Abstract syntax tree after typing *)
+
+
+(** By comparison with {!Parsetree}:
+    - Every {!Longindent.t} is accompanied by a resolved {!Path.t}.
+
+*)
+
+open Asttypes
+
+(* Value expressions for the core language *)
+
+type partial = Partial | Total
+
+(** {1 Extension points} *)
+
+type attribute = Parsetree.attribute
+type attributes = attribute list
+
+(** {1 Core language} *)
+
+type value = Value_pattern
+type computation = Computation_pattern
+
+type _ pattern_category =
+| Value : value pattern_category
+| Computation : computation pattern_category
+
+type pattern = value general_pattern
+and 'k general_pattern = 'k pattern_desc pattern_data
+
+and 'a pattern_data =
+  { pat_desc: 'a;
+    pat_loc: Location.t;
+    pat_extra : (pat_extra * Location.t * attributes) list;
+    pat_type: Types.type_expr;
+    pat_env: Env.t;
+    pat_attributes: attributes;
+   }
+
+and pat_extra =
+  | Tpat_constraint of core_type
+        (** P : T          { pat_desc = P
+                           ; pat_extra = (Tpat_constraint T, _, _) :: ... }
+         *)
+  | Tpat_type of Path.t * Longident.t loc
+        (** #tconst        { pat_desc = disjunction
+                           ; pat_extra = (Tpat_type (P, "tconst"), _, _) :: ...}
+
+                           where [disjunction] is a [Tpat_or _] representing the
+                           branches of [tconst].
+         *)
+  | Tpat_open of Path.t * Longident.t loc * Env.t
+  | Tpat_unpack
+        (** (module P)     { pat_desc  = Tpat_var "P"
+                           ; pat_extra = (Tpat_unpack, _, _) :: ... }
+         *)
+
+and 'k pattern_desc =
+  (* value patterns *)
+  | Tpat_any : value pattern_desc
+        (** _ *)
+  | Tpat_var : Ident.t * string loc -> value pattern_desc
+        (** x *)
+  | Tpat_alias :
+      value general_pattern * Ident.t * string loc -> value pattern_desc
+        (** P as a *)
+  | Tpat_constant : constant -> value pattern_desc
+        (** 1, 'a', "true", 1.0, 1l, 1L, 1n *)
+  | Tpat_tuple : value general_pattern list -> value pattern_desc
+        (** (P1, ..., Pn)
+
+            Invariant: n >= 2
+         *)
+  | Tpat_construct :
+      Longident.t loc * Types.constructor_description *
+        value general_pattern list ->
+      value pattern_desc
+        (** C                []
+            C P              [P]
+            C (P1, ..., Pn)  [P1; ...; Pn]
+          *)
+  | Tpat_variant :
+      label * value general_pattern option * Types.row_desc ref ->
+      value pattern_desc
+        (** `A             (None)
+            `A P           (Some P)
+
+            See {!Types.row_desc} for an explanation of the last parameter.
+         *)
+  | Tpat_record :
+      (Longident.t loc * Types.label_description * value general_pattern) list *
+        closed_flag ->
+      value pattern_desc
+        (** { l1=P1; ...; ln=Pn }     (flag = Closed)
+            { l1=P1; ...; ln=Pn; _}   (flag = Open)
+
+            Invariant: n > 0
+         *)
+  | Tpat_array : value general_pattern list -> value pattern_desc
+        (** [| P1; ...; Pn |] *)
+  | Tpat_lazy : value general_pattern -> value pattern_desc
+        (** lazy P *)
+  (* computation patterns *)
+  | Tpat_value : tpat_value_argument -> computation pattern_desc
+        (** P
+
+            Invariant: Tpat_value pattern should not carry
+            pat_attributes or pat_extra metadata coming from user
+            syntax, which must be on the inner pattern node -- to
+            facilitate searching for a certain value pattern
+            constructor with a specific attributed.
+
+            To enforce this restriction, we made the argument of
+            the Tpat_value constructor a private synonym of [pattern],
+            requiring you to use the [as_computation_pattern] function
+            below instead of using the [Tpat_value] constructor directly.
+         *)
+  | Tpat_exception : value general_pattern -> computation pattern_desc
+        (** exception P *)
+  (* generic constructions *)
+  | Tpat_or :
+      'k general_pattern * 'k general_pattern * Types.row_desc option ->
+      'k pattern_desc
+        (** P1 | P2
+
+            [row_desc] = [Some _] when translating [Ppat_type _],
+                         [None] otherwise.
+         *)
+
+and tpat_value_argument = private value general_pattern
+
+and expression =
+  { exp_desc: expression_desc;
+    exp_loc: Location.t;
+    exp_extra: (exp_extra * Location.t * attributes) list;
+    exp_type: Types.type_expr;
+    exp_env: Env.t;
+    exp_attributes: attributes;
+   }
+
+and exp_extra =
+  | Texp_constraint of core_type
+        (** E : T *)
+  | Texp_coerce of core_type option * core_type
+        (** E :> T           [Texp_coerce (None, T)]
+            E : T0 :> T      [Texp_coerce (Some T0, T)]
+         *)
+  | Texp_poly of core_type option
+        (** Used for method bodies. *)
+  | Texp_newtype of string
+        (** fun (type t) ->  *)
+
+and expression_desc =
+    Texp_ident of Path.t * Longident.t loc * Types.value_description
+        (** x
+            M.x
+         *)
+  | Texp_constant of constant
+        (** 1, 'a', "true", 1.0, 1l, 1L, 1n *)
+  | Texp_let of rec_flag * value_binding list * expression
+        (** let P1 = E1 and ... and Pn = EN in E       (flag = Nonrecursive)
+            let rec P1 = E1 and ... and Pn = EN in E   (flag = Recursive)
+         *)
+  | Texp_function of { arg_label : arg_label; param : Ident.t;
+      cases : value case list; partial : partial; }
+        (** [Pexp_fun] and [Pexp_function] both translate to [Texp_function].
+            See {!Parsetree} for more details.
+
+            [param] is the identifier that is to be used to name the
+            parameter of the function.
+
+            partial =
+              [Partial] if the pattern match is partial
+              [Total] otherwise.
+         *)
+  | Texp_apply of expression * (arg_label * expression option) list
+        (** E0 ~l1:E1 ... ~ln:En
+
+            The expression can be None if the expression is abstracted over
+            this argument. It currently appears when a label is applied.
+
+            For example:
+            let f x ~y = x + y in
+            f ~y:3
+
+            The resulting typedtree for the application is:
+            Texp_apply (Texp_ident "f/1037",
+                        [(Nolabel, None);
+                         (Labelled "y", Some (Texp_constant Const_int 3))
+                        ])
+         *)
+  | Texp_match of expression * computation case list * partial
+        (** match E0 with
+            | P1 -> E1
+            | P2 | exception P3 -> E2
+            | exception P4 -> E3
+
+            [Texp_match (E0, [(P1, E1); (P2 | exception P3, E2);
+                              (exception P4, E3)], _)]
+         *)
+  | Texp_try of expression * value case list
+        (** try E with P1 -> E1 | ... | PN -> EN *)
+  | Texp_tuple of expression list
+        (** (E1, ..., EN) *)
+  | Texp_construct of
+      Longident.t loc * Types.constructor_description * expression list
+        (** C                []
+            C E              [E]
+            C (E1, ..., En)  [E1;...;En]
+         *)
+  | Texp_variant of label * expression option
+  | Texp_record of {
+      fields : ( Types.label_description * record_label_definition ) array;
+      representation : Types.record_representation;
+      extended_expression : expression option;
+    }
+        (** { l1=P1; ...; ln=Pn }           (extended_expression = None)
+            { E0 with l1=P1; ...; ln=Pn }   (extended_expression = Some E0)
+
+            Invariant: n > 0
+
+            If the type is { l1: t1; l2: t2 }, the expression
+            { E0 with t2=P2 } is represented as
+            Texp_record
+              { fields = [| l1, Kept t1; l2 Override P2 |]; representation;
+                extended_expression = Some E0 }
+        *)
+  | Texp_field of expression * Longident.t loc * Types.label_description
+  | Texp_setfield of
+      expression * Longident.t loc * Types.label_description * expression
+  | Texp_array of expression list
+  | Texp_ifthenelse of expression * expression * expression option
+  | Texp_sequence of expression * expression
+  | Texp_while of expression * expression
+  | Texp_for of
+      Ident.t * Parsetree.pattern * expression * expression * direction_flag *
+        expression
+  | Texp_send of expression * meth * expression option
+  | Texp_new of Path.t * Longident.t loc * Types.class_declaration
+  | Texp_instvar of Path.t * Path.t * string loc
+  | Texp_setinstvar of Path.t * Path.t * string loc * expression
+  | Texp_override of Path.t * (Path.t * string loc * expression) list
+  | Texp_letmodule of
+      Ident.t option * string option loc * Types.module_presence * module_expr *
+        expression
+  | Texp_letexception of extension_constructor * expression
+  | Texp_assert of expression
+  | Texp_lazy of expression
+  | Texp_object of class_structure * string list
+  | Texp_pack of module_expr
+  | Texp_letop of {
+      let_ : binding_op;
+      ands : binding_op list;
+      param : Ident.t;
+      body : value case;
+      partial : partial;
+    }
+  | Texp_unreachable
+  | Texp_extension_constructor of Longident.t loc * Path.t
+  | Texp_open of open_declaration * expression
+        (** let open[!] M in e *)
+
+and meth =
+    Tmeth_name of string
+  | Tmeth_val of Ident.t
+
+and 'k case =
+    {
+     c_lhs: 'k general_pattern;
+     c_guard: expression option;
+     c_rhs: expression;
+    }
+
+and record_label_definition =
+  | Kept of Types.type_expr
+  | Overridden of Longident.t loc * expression
+
+and binding_op =
+  {
+    bop_op_path : Path.t;
+    bop_op_name : string loc;
+    bop_op_val : Types.value_description;
+    bop_op_type : Types.type_expr;
+    (* This is the type at which the operator was used.
+       It is always an instance of [bop_op_val.val_type] *)
+    bop_exp : expression;
+    bop_loc : Location.t;
+  }
+
+(* Value expressions for the class language *)
+
+and class_expr =
+    {
+     cl_desc: class_expr_desc;
+     cl_loc: Location.t;
+     cl_type: Types.class_type;
+     cl_env: Env.t;
+     cl_attributes: attributes;
+    }
+
+and class_expr_desc =
+    Tcl_ident of Path.t * Longident.t loc * core_type list
+  | Tcl_structure of class_structure
+  | Tcl_fun of
+      arg_label * pattern * (Ident.t * expression) list
+      * class_expr * partial
+  | Tcl_apply of class_expr * (arg_label * expression option) list
+  | Tcl_let of rec_flag * value_binding list *
+                  (Ident.t * expression) list * class_expr
+  | Tcl_constraint of
+      class_expr * class_type option * string list * string list * Types.Concr.t
+  (* Visible instance variables, methods and concrete methods *)
+  | Tcl_open of open_description * class_expr
+
+and class_structure =
+  {
+   cstr_self: pattern;
+   cstr_fields: class_field list;
+   cstr_type: Types.class_signature;
+   cstr_meths: Ident.t Types.Meths.t;
+  }
+
+and class_field =
+   {
+    cf_desc: class_field_desc;
+    cf_loc: Location.t;
+    cf_attributes: attributes;
+  }
+
+and class_field_kind =
+  | Tcfk_virtual of core_type
+  | Tcfk_concrete of override_flag * expression
+
+and class_field_desc =
+    Tcf_inherit of
+      override_flag * class_expr * string option * (string * Ident.t) list *
+        (string * Ident.t) list
+    (* Inherited instance variables and concrete methods *)
+  | Tcf_val of string loc * mutable_flag * Ident.t * class_field_kind * bool
+  | Tcf_method of string loc * private_flag * class_field_kind
+  | Tcf_constraint of core_type * core_type
+  | Tcf_initializer of expression
+  | Tcf_attribute of attribute
+
+(* Value expressions for the module language *)
+
+and module_expr =
+  { mod_desc: module_expr_desc;
+    mod_loc: Location.t;
+    mod_type: Types.module_type;
+    mod_env: Env.t;
+    mod_attributes: attributes;
+   }
+
+(** Annotations for [Tmod_constraint]. *)
+and module_type_constraint =
+  | Tmodtype_implicit
+  (** The module type constraint has been synthesized during typechecking. *)
+  | Tmodtype_explicit of module_type
+  (** The module type was in the source file. *)
+
+and functor_parameter =
+  | Unit
+  | Named of Ident.t option * string option loc * module_type
+
+and module_expr_desc =
+    Tmod_ident of Path.t * Longident.t loc
+  | Tmod_structure of structure
+  | Tmod_functor of functor_parameter * module_expr
+  | Tmod_apply of module_expr * module_expr * module_coercion
+  | Tmod_constraint of
+      module_expr * Types.module_type * module_type_constraint * module_coercion
+    (** ME          (constraint = Tmodtype_implicit)
+        (ME : MT)   (constraint = Tmodtype_explicit MT)
+     *)
+  | Tmod_unpack of expression * Types.module_type
+
+and structure = {
+  str_items : structure_item list;
+  str_type : Types.signature;
+  str_final_env : Env.t;
+}
+
+and structure_item =
+  { str_desc : structure_item_desc;
+    str_loc : Location.t;
+    str_env : Env.t
+  }
+
+and structure_item_desc =
+    Tstr_eval of expression * attributes
+  | Tstr_value of rec_flag * value_binding list
+  | Tstr_primitive of value_description
+  | Tstr_type of rec_flag * type_declaration list
+  | Tstr_typext of type_extension
+  | Tstr_exception of type_exception
+  | Tstr_module of module_binding
+  | Tstr_recmodule of module_binding list
+  | Tstr_modtype of module_type_declaration
+  | Tstr_open of open_declaration
+  | Tstr_class of (class_declaration * string list) list
+  | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list
+  | Tstr_include of include_declaration
+  | Tstr_attribute of attribute
+
+and module_binding =
+    {
+     mb_id: Ident.t option;
+     mb_name: string option loc;
+     mb_presence: Types.module_presence;
+     mb_expr: module_expr;
+     mb_attributes: attributes;
+     mb_loc: Location.t;
+    }
+
+and value_binding =
+  {
+    vb_pat: pattern;
+    vb_expr: expression;
+    vb_attributes: attributes;
+    vb_loc: Location.t;
+  }
+
+and module_coercion =
+    Tcoerce_none
+  | Tcoerce_structure of (int * module_coercion) list *
+                         (Ident.t * int * module_coercion) list
+  | Tcoerce_functor of module_coercion * module_coercion
+  | Tcoerce_primitive of primitive_coercion
+  | Tcoerce_alias of Env.t * Path.t * module_coercion
+
+and module_type =
+  { mty_desc: module_type_desc;
+    mty_type : Types.module_type;
+    mty_env : Env.t;
+    mty_loc: Location.t;
+    mty_attributes: attributes;
+   }
+
+and module_type_desc =
+    Tmty_ident of Path.t * Longident.t loc
+  | Tmty_signature of signature
+  | Tmty_functor of functor_parameter * module_type
+  | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list
+  | Tmty_typeof of module_expr
+  | Tmty_alias of Path.t * Longident.t loc
+
+and primitive_coercion =
+  {
+    pc_desc: Primitive.description;
+    pc_type: Types.type_expr;
+    pc_env: Env.t;
+    pc_loc : Location.t;
+  }
+
+and signature = {
+  sig_items : signature_item list;
+  sig_type : Types.signature;
+  sig_final_env : Env.t;
+}
+
+and signature_item =
+  { sig_desc: signature_item_desc;
+    sig_env : Env.t; (* BINANNOT ADDED *)
+    sig_loc: Location.t }
+
+and signature_item_desc =
+    Tsig_value of value_description
+  | Tsig_type of rec_flag * type_declaration list
+  | Tsig_typesubst of type_declaration list
+  | Tsig_typext of type_extension
+  | Tsig_exception of type_exception
+  | Tsig_module of module_declaration
+  | Tsig_modsubst of module_substitution
+  | Tsig_recmodule of module_declaration list
+  | Tsig_modtype of module_type_declaration
+  | Tsig_open of open_description
+  | Tsig_include of include_description
+  | Tsig_class of class_description list
+  | Tsig_class_type of class_type_declaration list
+  | Tsig_attribute of attribute
+
+and module_declaration =
+    {
+     md_id: Ident.t option;
+     md_name: string option loc;
+     md_presence: Types.module_presence;
+     md_type: module_type;
+     md_attributes: attributes;
+     md_loc: Location.t;
+    }
+
+and module_substitution =
+    {
+     ms_id: Ident.t;
+     ms_name: string loc;
+     ms_manifest: Path.t;
+     ms_txt: Longident.t loc;
+     ms_attributes: attributes;
+     ms_loc: Location.t;
+    }
+
+and module_type_declaration =
+    {
+     mtd_id: Ident.t;
+     mtd_name: string loc;
+     mtd_type: module_type option;
+     mtd_attributes: attributes;
+     mtd_loc: Location.t;
+    }
+
+and 'a open_infos =
+    {
+     open_expr: 'a;
+     open_bound_items: Types.signature;
+     open_override: override_flag;
+     open_env: Env.t;
+     open_loc: Location.t;
+     open_attributes: attribute list;
+    }
+
+and open_description = (Path.t * Longident.t loc) open_infos
+
+and open_declaration = module_expr open_infos
+
+
+and 'a include_infos =
+    {
+     incl_mod: 'a;
+     incl_type: Types.signature;
+     incl_loc: Location.t;
+     incl_attributes: attribute list;
+    }
+
+and include_description = module_type include_infos
+
+and include_declaration = module_expr include_infos
+
+and with_constraint =
+    Twith_type of type_declaration
+  | Twith_module of Path.t * Longident.t loc
+  | Twith_typesubst of type_declaration
+  | Twith_modsubst of Path.t * Longident.t loc
+
+and core_type =
+  { mutable ctyp_desc : core_type_desc;
+      (** mutable because of [Typeclass.declare_method] *)
+    mutable ctyp_type : Types.type_expr;
+      (** mutable because of [Typeclass.declare_method] *)
+    ctyp_env : Env.t; (* BINANNOT ADDED *)
+    ctyp_loc : Location.t;
+    ctyp_attributes: attributes;
+   }
+
+and core_type_desc =
+    Ttyp_any
+  | Ttyp_var of string
+  | Ttyp_arrow of arg_label * core_type * core_type
+  | Ttyp_tuple of core_type list
+  | Ttyp_constr of Path.t * Longident.t loc * core_type list
+  | Ttyp_object of object_field list * closed_flag
+  | Ttyp_class of Path.t * Longident.t loc * core_type list
+  | Ttyp_alias of core_type * string
+  | Ttyp_variant of row_field list * closed_flag * label list option
+  | Ttyp_poly of string list * core_type
+  | Ttyp_package of package_type
+
+and package_type = {
+  pack_path : Path.t;
+  pack_fields : (Longident.t loc * core_type) list;
+  pack_type : Types.module_type;
+  pack_txt : Longident.t loc;
+}
+
+and row_field = {
+  rf_desc : row_field_desc;
+  rf_loc : Location.t;
+  rf_attributes : attributes;
+}
+
+and row_field_desc =
+    Ttag of string loc * bool * core_type list
+  | Tinherit of core_type
+
+and object_field = {
+  of_desc : object_field_desc;
+  of_loc : Location.t;
+  of_attributes : attributes;
+}
+
+and object_field_desc =
+  | OTtag of string loc * core_type
+  | OTinherit of core_type
+
+and value_description =
+  { val_id: Ident.t;
+    val_name: string loc;
+    val_desc: core_type;
+    val_val: Types.value_description;
+    val_prim: string list;
+    val_loc: Location.t;
+    val_attributes: attributes;
+    }
+
+and type_declaration =
+  {
+    typ_id: Ident.t;
+    typ_name: string loc;
+    typ_params: (core_type * (variance * injectivity)) list;
+    typ_type: Types.type_declaration;
+    typ_cstrs: (core_type * core_type * Location.t) list;
+    typ_kind: type_kind;
+    typ_private: private_flag;
+    typ_manifest: core_type option;
+    typ_loc: Location.t;
+    typ_attributes: attributes;
+   }
+
+and type_kind =
+    Ttype_abstract
+  | Ttype_variant of constructor_declaration list
+  | Ttype_record of label_declaration list
+  | Ttype_open
+
+and label_declaration =
+    {
+     ld_id: Ident.t;
+     ld_name: string loc;
+     ld_mutable: mutable_flag;
+     ld_type: core_type;
+     ld_loc: Location.t;
+     ld_attributes: attributes;
+    }
+
+and constructor_declaration =
+    {
+     cd_id: Ident.t;
+     cd_name: string loc;
+     cd_args: constructor_arguments;
+     cd_res: core_type option;
+     cd_loc: Location.t;
+     cd_attributes: attributes;
+    }
+
+and constructor_arguments =
+  | Cstr_tuple of core_type list
+  | Cstr_record of label_declaration list
+
+and type_extension =
+  {
+    tyext_path: Path.t;
+    tyext_txt: Longident.t loc;
+    tyext_params: (core_type * (variance * injectivity)) list;
+    tyext_constructors: extension_constructor list;
+    tyext_private: private_flag;
+    tyext_loc: Location.t;
+    tyext_attributes: attributes;
+  }
+
+and type_exception =
+  {
+    tyexn_constructor: extension_constructor;
+    tyexn_loc: Location.t;
+    tyexn_attributes: attribute list;
+  }
+
+and extension_constructor =
+  {
+    ext_id: Ident.t;
+    ext_name: string loc;
+    ext_type : Types.extension_constructor;
+    ext_kind : extension_constructor_kind;
+    ext_loc : Location.t;
+    ext_attributes: attributes;
+  }
+
+and extension_constructor_kind =
+    Text_decl of constructor_arguments * core_type option
+  | Text_rebind of Path.t * Longident.t loc
+
+and class_type =
+    {
+     cltyp_desc: class_type_desc;
+     cltyp_type: Types.class_type;
+     cltyp_env: Env.t;
+     cltyp_loc: Location.t;
+     cltyp_attributes: attributes;
+    }
+
+and class_type_desc =
+    Tcty_constr of Path.t * Longident.t loc * core_type list
+  | Tcty_signature of class_signature
+  | Tcty_arrow of arg_label * core_type * class_type
+  | Tcty_open of open_description * class_type
+
+and class_signature = {
+    csig_self : core_type;
+    csig_fields : class_type_field list;
+    csig_type : Types.class_signature;
+  }
+
+and class_type_field = {
+    ctf_desc: class_type_field_desc;
+    ctf_loc: Location.t;
+    ctf_attributes: attributes;
+  }
+
+and class_type_field_desc =
+  | Tctf_inherit of class_type
+  | Tctf_val of (string * mutable_flag * virtual_flag * core_type)
+  | Tctf_method of (string * private_flag * virtual_flag * core_type)
+  | Tctf_constraint of (core_type * core_type)
+  | Tctf_attribute of attribute
+
+and class_declaration =
+  class_expr class_infos
+
+and class_description =
+  class_type class_infos
+
+and class_type_declaration =
+  class_type class_infos
+
+and 'a class_infos =
+  { ci_virt: virtual_flag;
+    ci_params: (core_type * (variance * injectivity)) list;
+    ci_id_name : string loc;
+    ci_id_class: Ident.t;
+    ci_id_class_type : Ident.t;
+    ci_id_object : Ident.t;
+    ci_id_typehash : Ident.t;
+    ci_expr: 'a;
+    ci_decl: Types.class_declaration;
+    ci_type_decl : Types.class_type_declaration;
+    ci_loc: Location.t;
+    ci_attributes: attributes;
+   }
+
+(* Auxiliary functions over the a.s.t. *)
+
+(** [as_computation_pattern p] is a computation pattern with description
+    [Tpat_value p], which enforces a correct placement of pat_attributes
+    and pat_extra metadata (on the inner value pattern, rather than on
+    the computation pattern). *)
+val as_computation_pattern: pattern -> computation general_pattern
+
+val classify_pattern_desc: 'k pattern_desc -> 'k pattern_category
+val classify_pattern: 'k general_pattern -> 'k pattern_category
+
+type pattern_action =
+  { f : 'k . 'k general_pattern -> unit }
+val shallow_iter_pattern_desc:
+    pattern_action -> 'k pattern_desc -> unit
+
+type pattern_transformation =
+  { f : 'k . 'k general_pattern -> 'k general_pattern }
+val shallow_map_pattern_desc:
+    pattern_transformation -> 'k pattern_desc -> 'k pattern_desc
+
+val iter_general_pattern: pattern_action -> 'k general_pattern -> unit
+val iter_pattern: (pattern -> unit) -> pattern -> unit
+
+type pattern_predicate = { f : 'k . 'k general_pattern -> bool }
+val exists_general_pattern: pattern_predicate -> 'k general_pattern -> bool
+val exists_pattern: (pattern -> bool) -> pattern -> bool
+
+val let_bound_idents: value_binding list -> Ident.t list
+val let_bound_idents_full:
+    value_binding list -> (Ident.t * string loc * Types.type_expr) list
+
+(** Alpha conversion of patterns *)
+val alpha_pat:
+  (Ident.t * Ident.t) list -> 'k general_pattern -> 'k general_pattern
+
+val mknoloc: 'a -> 'a Asttypes.loc
+val mkloc: 'a -> Location.t -> 'a Asttypes.loc
+
+val pat_bound_idents: 'k general_pattern -> Ident.t list
+val pat_bound_idents_full:
+  'k general_pattern -> (Ident.t * string loc * Types.type_expr) list
+
+(** Splits an or pattern into its value (left) and exception (right) parts. *)
+val split_pattern:
+  computation general_pattern -> pattern option * pattern option
diff --git a/upstream/ocaml_412/typing/typemod.ml b/upstream/ocaml_412/typing/typemod.ml
new file mode 100644
index 0000000..98a5946
--- /dev/null
+++ b/upstream/ocaml_412/typing/typemod.ml
@@ -0,0 +1,2941 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Misc
+open Longident
+open Path
+open Asttypes
+open Parsetree
+open Types
+open Format
+
+module String = Misc.Stdlib.String
+
+module Sig_component_kind = struct
+  type t =
+    | Value
+    | Type
+    | Module
+    | Module_type
+    | Extension_constructor
+    | Class
+    | Class_type
+
+  let to_string = function
+    | Value -> "value"
+    | Type -> "type"
+    | Module -> "module"
+    | Module_type -> "module type"
+    | Extension_constructor -> "extension constructor"
+    | Class -> "class"
+    | Class_type -> "class type"
+
+  (** Whether the name of a component of that kind can appear in a type. *)
+  let can_appear_in_types = function
+    | Value
+    | Extension_constructor ->
+        false
+    | Type
+    | Module
+    | Module_type
+    | Class
+    | Class_type ->
+        true
+end
+
+type hiding_error =
+  | Illegal_shadowing of {
+      shadowed_item_id: Ident.t;
+      shadowed_item_kind: Sig_component_kind.t;
+      shadowed_item_loc: Location.t;
+      shadower_id: Ident.t;
+      user_id: Ident.t;
+      user_kind: Sig_component_kind.t;
+      user_loc: Location.t;
+    }
+  | Appears_in_signature of {
+      opened_item_id: Ident.t;
+      opened_item_kind: Sig_component_kind.t;
+      user_id: Ident.t;
+      user_kind: Sig_component_kind.t;
+      user_loc: Location.t;
+    }
+
+type error =
+    Cannot_apply of module_type
+  | Not_included of Includemod.error list
+  | Cannot_eliminate_dependency of module_type
+  | Signature_expected
+  | Structure_expected of module_type
+  | With_no_component of Longident.t
+  | With_mismatch of Longident.t * Includemod.error list
+  | With_makes_applicative_functor_ill_typed of
+      Longident.t * Path.t * Includemod.error list
+  | With_changes_module_alias of Longident.t * Ident.t * Path.t
+  | With_cannot_remove_constrained_type
+  | Repeated_name of Sig_component_kind.t * string
+  | Non_generalizable of type_expr
+  | Non_generalizable_class of Ident.t * class_declaration
+  | Non_generalizable_module of module_type
+  | Implementation_is_required of string
+  | Interface_not_compiled of string
+  | Not_allowed_in_functor_body
+  | Not_a_packed_module of type_expr
+  | Incomplete_packed_module of type_expr
+  | Scoping_pack of Longident.t * type_expr
+  | Recursive_module_require_explicit_type
+  | Apply_generative
+  | Cannot_scrape_alias of Path.t
+  | Cannot_scrape_package_type of Path.t
+  | Badly_formed_signature of string * Typedecl.error
+  | Cannot_hide_id of hiding_error
+  | Invalid_type_subst_rhs
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+open Typedtree
+
+let rec path_concat head p =
+  match p with
+    Pident tail -> Pdot (Pident head, Ident.name tail)
+  | Pdot (pre, s) -> Pdot (path_concat head pre, s)
+  | Papply _ -> assert false
+
+(* Extract a signature from a module type *)
+
+let extract_sig env loc mty =
+  match Env.scrape_alias env mty with
+    Mty_signature sg -> sg
+  | Mty_alias path ->
+      raise(Error(loc, env, Cannot_scrape_alias path))
+  | _ -> raise(Error(loc, env, Signature_expected))
+
+let extract_sig_open env loc mty =
+  match Env.scrape_alias env mty with
+    Mty_signature sg -> sg
+  | Mty_alias path ->
+      raise(Error(loc, env, Cannot_scrape_alias path))
+  | mty -> raise(Error(loc, env, Structure_expected mty))
+
+(* Compute the environment after opening a module *)
+
+let type_open_ ?used_slot ?toplevel ovf env loc lid =
+  let path = Env.lookup_module_path ~load:true ~loc:lid.loc lid.txt env in
+  match Env.open_signature ~loc ?used_slot ?toplevel ovf path env with
+  | Ok env -> path, env
+  | Error _ ->
+      let md = Env.find_module path env in
+      ignore (extract_sig_open env lid.loc md.md_type);
+      assert false
+
+let initial_env ~loc ~safe_string ~initially_opened_module
+    ~open_implicit_modules =
+  let env =
+    if safe_string then
+      Env.initial_safe_string
+    else
+      Env.initial_unsafe_string
+  in
+  let open_module env m =
+    let open Asttypes in
+    let lexbuf = Lexing.from_string m in
+    let txt =
+      Location.init lexbuf (Printf.sprintf "command line argument: -open %S" m);
+      Parse.simple_module_path lexbuf in
+        snd (type_open_ Override env loc {txt;loc})
+  in
+  let add_units env units =
+    String.Set.fold
+      (fun name env ->
+         Env.add_persistent_structure (Ident.create_persistent name) env)
+      units
+      env
+  in
+  let units =
+    List.map Env.persistent_structures_of_dir (Load_path.get ())
+  in
+  let env, units =
+    match initially_opened_module with
+    | None -> (env, units)
+    | Some m ->
+        (* Locate the directory that contains [m], adds the units it
+           contains to the environment and open [m] in the resulting
+           environment. *)
+        let rec loop before after =
+          match after with
+          | [] -> None
+          | units :: after ->
+              if String.Set.mem m units then
+                Some (units, List.rev_append before after)
+              else
+                loop (units :: before) after
+        in
+        let env, units =
+          match loop [] units with
+          | None ->
+              (env, units)
+          | Some (units_containing_m, other_units) ->
+              (add_units env units_containing_m, other_units)
+        in
+        (open_module env m, units)
+  in
+  let env = List.fold_left add_units env units in
+  List.fold_left open_module env open_implicit_modules
+
+let type_open_descr ?used_slot ?toplevel env sod =
+  let (path, newenv) =
+    Builtin_attributes.warning_scope sod.popen_attributes
+      (fun () ->
+         type_open_ ?used_slot ?toplevel sod.popen_override env sod.popen_loc
+           sod.popen_expr
+      )
+  in
+  let od =
+    {
+      open_expr = (path, sod.popen_expr);
+      open_bound_items = [];
+      open_override = sod.popen_override;
+      open_env = newenv;
+      open_attributes = sod.popen_attributes;
+      open_loc = sod.popen_loc;
+    }
+  in
+  (od, newenv)
+
+(* Forward declaration, to be filled in by type_module_type_of *)
+let type_module_type_of_fwd :
+    (Env.t -> Parsetree.module_expr ->
+      Typedtree.module_expr * Types.module_type) ref
+  = ref (fun _env _m -> assert false)
+
+(* Additional validity checks on type definitions arising from
+   recursive modules *)
+
+let check_recmod_typedecls env decls =
+  let recmod_ids = List.map fst decls in
+  List.iter
+    (fun (id, md) ->
+      List.iter
+        (fun path ->
+          Typedecl.check_recmod_typedecl env md.Types.md_loc recmod_ids
+                                         path (Env.find_type path env))
+        (Mtype.type_paths env (Pident id) md.Types.md_type))
+    decls
+
+(* Merge one "with" constraint in a signature *)
+
+let rec add_rec_types env = function
+    Sig_type(id, decl, Trec_next, _) :: rem ->
+      add_rec_types (Env.add_type ~check:true id decl env) rem
+  | _ -> env
+
+let check_type_decl env loc id row_id newdecl decl rs rem =
+  let env = Env.add_type ~check:true id newdecl env in
+  let env =
+    match row_id with
+    | None -> env
+    | Some id -> Env.add_type ~check:false id newdecl env
+  in
+  let env = if rs = Trec_not then env else add_rec_types env rem in
+  Includemod.type_declarations ~mark:Mark_both ~loc env id newdecl decl;
+  Typedecl.check_coherence env loc (Path.Pident id) newdecl
+
+let update_rec_next rs rem =
+  match rs with
+    Trec_next -> rem
+  | Trec_first | Trec_not ->
+      match rem with
+        Sig_type (id, decl, Trec_next, priv) :: rem ->
+          Sig_type (id, decl, rs, priv) :: rem
+      | Sig_module (id, pres, mty, Trec_next, priv) :: rem ->
+          Sig_module (id, pres, mty, rs, priv) :: rem
+      | _ -> rem
+
+let make_variance p n i =
+  let open Variance in
+  set May_pos p (set May_neg n (set May_weak n (set Inj i null)))
+
+let rec iter_path_apply p ~f =
+  match p with
+  | Pident _ -> ()
+  | Pdot (p, _) -> iter_path_apply p ~f
+  | Papply (p1, p2) ->
+     iter_path_apply p1 ~f;
+     iter_path_apply p2 ~f;
+     f p1 p2 (* after recursing, so we know both paths are well typed *)
+
+let path_is_strict_prefix =
+  let rec list_is_strict_prefix l ~prefix =
+    match l, prefix with
+    | [], [] -> false
+    | _ :: _, [] -> true
+    | [], _ :: _ -> false
+    | s1 :: t1, s2 :: t2 ->
+       String.equal s1 s2 && list_is_strict_prefix t1 ~prefix:t2
+  in
+  fun path ~prefix ->
+    match Path.flatten path, Path.flatten prefix with
+    | `Contains_apply, _ | _, `Contains_apply -> false
+    | `Ok (ident1, l1), `Ok (ident2, l2) ->
+       Ident.same ident1 ident2
+       && list_is_strict_prefix l1 ~prefix:l2
+
+let iterator_with_env env =
+  let env = ref (lazy env) in
+  let super = Btype.type_iterators in
+  env, { super with
+    Btype.it_signature = (fun self sg ->
+      (* add all items to the env before recursing down, to handle recursive
+         definitions *)
+      let env_before = !env in
+      env := lazy (Env.add_signature sg (Lazy.force env_before));
+      super.Btype.it_signature self sg;
+      env := env_before
+    );
+    Btype.it_module_type = (fun self -> function
+    | Mty_functor (param, mty_body) ->
+      let env_before = !env in
+      begin match param with
+      | Unit -> ()
+      | Named (param, mty_arg) ->
+        self.Btype.it_module_type self mty_arg;
+        match param with
+        | None -> ()
+        | Some id ->
+          env := lazy (Env.add_module ~arg:true id Mp_present
+                       mty_arg (Lazy.force env_before))
+      end;
+      self.Btype.it_module_type self mty_body;
+      env := env_before;
+    | mty ->
+      super.Btype.it_module_type self mty
+    )
+  }
+
+let retype_applicative_functor_type ~loc env funct arg =
+  let mty_functor = (Env.find_module funct env).md_type in
+  let mty_arg = (Env.find_module arg env).md_type in
+  let mty_param =
+    match Env.scrape_alias env mty_functor with
+    | Mty_functor (Named (_, mty_param), _) -> mty_param
+    | _ -> assert false (* could trigger due to MPR#7611 *)
+  in
+  Includemod.check_modtype_inclusion ~loc env mty_arg arg mty_param
+
+(* When doing a deep destructive substitution with type M.N.t := .., we change M
+   and M.N and so we have to check that uses of the modules other than just
+   extracting components from them still make sense. There are only two such
+   kinds of uses:
+   - applicative functor types: F(M).t might not be well typed anymore
+   - aliases: module A = M still makes sense but it doesn't mean the same thing
+     anymore, so it's forbidden until it's clear what we should do with it.
+   This function would be called with M.N.t and N.t to check for these uses. *)
+let check_usage_of_path_of_substituted_item paths env signature ~loc ~lid =
+  let iterator =
+    let env, super = iterator_with_env env in
+    { super with
+      Btype.it_signature_item = (fun self -> function
+      | Sig_module (id, _, { md_type = Mty_alias aliased_path; _ }, _, _)
+        when List.exists
+               (fun path -> path_is_strict_prefix path ~prefix:aliased_path)
+               paths
+        ->
+         let e = With_changes_module_alias (lid.txt, id, aliased_path) in
+         raise(Error(loc, Lazy.force !env, e))
+      | sig_item ->
+         super.Btype.it_signature_item self sig_item
+      );
+      Btype.it_path = (fun referenced_path ->
+        iter_path_apply referenced_path ~f:(fun funct arg ->
+          if List.exists
+               (fun path -> path_is_strict_prefix path ~prefix:arg)
+               paths
+          then
+            let env = Lazy.force !env in
+            try retype_applicative_functor_type ~loc env funct arg
+            with Includemod.Error explanation ->
+              raise(Error(loc, env,
+                          With_makes_applicative_functor_ill_typed
+                            (lid.txt, referenced_path, explanation)))
+        )
+      );
+    }
+  in
+  iterator.Btype.it_signature iterator signature;
+  Btype.unmark_iterators.Btype.it_signature Btype.unmark_iterators signature
+
+(* After substitution one also needs to re-check the well-foundedness
+   of type declarations in recursive modules *)
+let rec extract_next_modules = function
+  | Sig_module (id, _, mty, Trec_next, _) :: rem ->
+      let (id_mty_l, rem) = extract_next_modules rem in
+      ((id, mty) :: id_mty_l, rem)
+  | sg -> ([], sg)
+
+let check_well_formed_module env loc context mty =
+  (* Format.eprintf "@[check_well_formed_module@ %a@]@."
+     Printtyp.modtype mty; *)
+  let open Btype in
+  let iterator =
+    let rec check_signature env = function
+      | [] -> ()
+      | Sig_module (id, _, mty, Trec_first, _) :: rem ->
+          let (id_mty_l, rem) = extract_next_modules rem in
+          begin try
+            check_recmod_typedecls (Lazy.force env) ((id, mty) :: id_mty_l)
+          with Typedecl.Error (_, err) ->
+            raise (Error (loc, Lazy.force env,
+                          Badly_formed_signature(context, err)))
+          end;
+          check_signature env rem
+      | _ :: rem ->
+          check_signature env rem
+    in
+    let env, super = iterator_with_env env in
+    { super with
+      it_type_expr = (fun _self _ty -> ());
+      it_signature = (fun self sg ->
+        let env_before = !env in
+        let env = lazy (Env.add_signature sg (Lazy.force env_before)) in
+        check_signature env sg;
+        super.it_signature self sg);
+    }
+  in
+  iterator.it_module_type iterator mty
+
+let () = Env.check_well_formed_module := check_well_formed_module
+
+let type_decl_is_alias sdecl = (* assuming no explicit constraint *)
+  match sdecl.ptype_manifest with
+  | Some {ptyp_desc = Ptyp_constr (lid, stl)}
+       when List.length stl = List.length sdecl.ptype_params ->
+     begin
+       match
+         List.iter2 (fun x (y, _) ->
+             match x, y with
+               {ptyp_desc=Ptyp_var sx}, {ptyp_desc=Ptyp_var sy}
+                  when sx = sy -> ()
+             | _, _ -> raise Exit)
+           stl sdecl.ptype_params;
+       with
+       | exception Exit -> None
+       | () -> Some lid
+     end
+  | _ -> None
+;;
+
+let params_are_constrained =
+  let rec loop = function
+    | [] -> false
+    | hd :: tl ->
+       match (Btype.repr hd).desc with
+       | Tvar _ -> List.memq hd tl || loop tl
+       | _ -> true
+  in
+  loop
+;;
+
+let merge_constraint initial_env remove_aliases loc sg constr =
+  let lid =
+    match constr with
+    | Pwith_type (lid, _) | Pwith_module (lid, _)
+    | Pwith_typesubst (lid, _) | Pwith_modsubst (lid, _) -> lid
+  in
+  let destructive_substitution =
+    match constr with
+    | Pwith_type _ | Pwith_module _ -> false
+    | Pwith_typesubst _ | Pwith_modsubst _ -> true
+  in
+  let real_ids = ref [] in
+  let rec merge sig_env sg namelist row_id =
+    match (sg, namelist, constr) with
+      ([], _, _) ->
+        raise(Error(loc, sig_env, With_no_component lid.txt))
+    | (Sig_type(id, decl, rs, priv) :: rem, [s],
+       Pwith_type (_, ({ptype_kind = Ptype_abstract} as sdecl)))
+      when Ident.name id = s && Typedecl.is_fixed_type sdecl ->
+        let decl_row =
+          let arity = List.length sdecl.ptype_params in
+          {
+            type_params =
+              List.map (fun _ -> Btype.newgenvar()) sdecl.ptype_params;
+            type_arity = arity;
+            type_kind = Type_abstract;
+            type_private = Private;
+            type_manifest = None;
+            type_variance =
+              List.map
+                (fun (_, (v, i)) ->
+                   let (c, n) =
+                     match v with
+                     | Covariant -> true, false
+                     | Contravariant -> false, true
+                     | NoVariance -> false, false
+                   in
+                   make_variance (not n) (not c) (i = Injective)
+                )
+                sdecl.ptype_params;
+            type_separability =
+              Types.Separability.default_signature ~arity;
+            type_loc = sdecl.ptype_loc;
+            type_is_newtype = false;
+            type_expansion_scope = Btype.lowest_level;
+            type_attributes = [];
+            type_immediate = Unknown;
+            type_unboxed = unboxed_false_default_false;
+            type_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+          }
+        and id_row = Ident.create_local (s^"#row") in
+        let initial_env =
+          Env.add_type ~check:false id_row decl_row initial_env
+        in
+        let tdecl =
+          Typedecl.transl_with_constraint id (Some(Pident id_row))
+            ~sig_env ~sig_decl:decl ~outer_env:initial_env sdecl in
+        let newdecl = tdecl.typ_type in
+        check_type_decl sig_env sdecl.ptype_loc id row_id newdecl decl rs rem;
+        let decl_row = {decl_row with type_params = newdecl.type_params} in
+        let rs' = if rs = Trec_first then Trec_not else rs in
+        (Pident id, lid, Twith_type tdecl),
+        Sig_type(id_row, decl_row, rs', priv)
+        :: Sig_type(id, newdecl, rs, priv)
+        :: rem
+    | (Sig_type(id, sig_decl, rs, priv) :: rem , [s],
+       (Pwith_type (_, sdecl) | Pwith_typesubst (_, sdecl) as constr))
+      when Ident.name id = s ->
+        let tdecl =
+          Typedecl.transl_with_constraint id None
+            ~sig_env ~sig_decl ~outer_env:initial_env sdecl in
+        let newdecl = tdecl.typ_type and loc = sdecl.ptype_loc in
+        check_type_decl sig_env loc id row_id newdecl sig_decl rs rem;
+        begin match constr with
+          Pwith_type _ ->
+            (Pident id, lid, Twith_type tdecl),
+            Sig_type(id, newdecl, rs, priv) :: rem
+        | (* Pwith_typesubst *) _ ->
+            real_ids := [Pident id];
+            (Pident id, lid, Twith_typesubst tdecl),
+            update_rec_next rs rem
+        end
+    | (Sig_type(id, _, _, _) :: rem, [s], (Pwith_type _ | Pwith_typesubst _))
+      when Ident.name id = s ^ "#row" ->
+        merge sig_env rem namelist (Some id)
+    | (Sig_module(id, pres, md, rs, priv) :: rem, [s], Pwith_module (_, lid'))
+      when Ident.name id = s ->
+        let path, md' = Env.lookup_module ~loc lid'.txt initial_env in
+        let mty = md'.md_type in
+        let mty = Mtype.scrape_for_type_of ~remove_aliases sig_env mty in
+        let md'' = { md' with md_type = mty } in
+        let newmd = Mtype.strengthen_decl ~aliasable:false sig_env md'' path in
+        ignore(Includemod.modtypes  ~mark:Mark_both ~loc sig_env
+                 newmd.md_type md.md_type);
+        (Pident id, lid, Twith_module (path, lid')),
+        Sig_module(id, pres, newmd, rs, priv) :: rem
+    | (Sig_module(id, _, md, rs, _) :: rem, [s], Pwith_modsubst (_, lid'))
+      when Ident.name id = s ->
+        let path, md' = Env.lookup_module ~loc lid'.txt initial_env in
+        let aliasable = not (Env.is_functor_arg path sig_env) in
+        ignore
+          (Includemod.strengthened_module_decl ~loc ~mark:Mark_both
+             ~aliasable sig_env md' path md);
+        real_ids := [Pident id];
+        (Pident id, lid, Twith_modsubst (path, lid')),
+        update_rec_next rs rem
+    | (Sig_module(id, _, md, rs, priv) as item :: rem, s :: namelist, constr)
+      when Ident.name id = s ->
+        let sg = extract_sig sig_env loc md.md_type in
+        let ((path, _, tcstr), newsg) = merge_signature sig_env sg namelist in
+        let path = path_concat id path in
+        real_ids := path :: !real_ids;
+        let item =
+          match md.md_type, constr with
+            Mty_alias _, (Pwith_module _ | Pwith_type _) ->
+              (* A module alias cannot be refined, so keep it
+                 and just check that the constraint is correct *)
+              item
+          | _ ->
+              let newmd = {md with md_type = Mty_signature newsg} in
+              Sig_module(id, Mp_present, newmd, rs, priv)
+        in
+        (path, lid, tcstr),
+        item :: rem
+    | (item :: rem, _, _) ->
+        let (cstr, items) = merge sig_env rem namelist row_id
+        in
+        cstr, item :: items
+  and merge_signature env sg namelist =
+    let sig_env = Env.add_signature sg env in
+    merge sig_env sg namelist None
+  in
+  try
+    let names = Longident.flatten lid.txt in
+    let (tcstr, sg) = merge_signature initial_env sg names in
+    if destructive_substitution then (
+      match List.rev !real_ids with
+      | [] -> assert false
+      | last :: rest ->
+        (* The last item is the one that's removed. We don't need to check how
+           it's used since it's replaced by a more specific type/module. *)
+        assert (match last with Pident _ -> true | _ -> false);
+        match rest with
+        | [] -> ()
+        | _ :: _ ->
+          check_usage_of_path_of_substituted_item
+            rest initial_env sg ~loc ~lid;
+    );
+    let sg =
+    match tcstr with
+    | (_, _, Twith_typesubst tdecl) ->
+       let how_to_extend_subst =
+         let sdecl =
+           match constr with
+           | Pwith_typesubst (_, sdecl) -> sdecl
+           | _ -> assert false
+         in
+         match type_decl_is_alias sdecl with
+         | Some lid ->
+            let replacement, _ =
+              try Env.find_type_by_name lid.txt initial_env
+              with Not_found -> assert false
+            in
+            fun s path -> Subst.add_type_path path replacement s
+         | None ->
+            let body = Option.get tdecl.typ_type.type_manifest in
+            let params = tdecl.typ_type.type_params in
+            if params_are_constrained params
+            then raise(Error(loc, initial_env,
+                             With_cannot_remove_constrained_type));
+            fun s path -> Subst.add_type_function path ~params ~body s
+       in
+       let sub = List.fold_left how_to_extend_subst Subst.identity !real_ids in
+       (* This signature will not be used directly, it will always be freshened
+          by the caller. So what we do with the scope doesn't really matter. But
+          making it local makes it unlikely that we will ever use the result of
+          this function unfreshened without issue. *)
+       Subst.signature Make_local sub sg
+    | (_, _, Twith_modsubst (real_path, _)) ->
+       let sub =
+         List.fold_left
+           (fun s path -> Subst.add_module_path path real_path s)
+           Subst.identity
+           !real_ids
+       in
+       (* See explanation in the [Twith_typesubst] case above. *)
+       Subst.signature Make_local sub sg
+    | _ ->
+       sg
+    in
+    check_well_formed_module initial_env loc "this instantiated signature"
+      (Mty_signature sg);
+    (tcstr, sg)
+  with Includemod.Error explanation ->
+    raise(Error(loc, initial_env, With_mismatch(lid.txt, explanation)))
+
+(* Add recursion flags on declarations arising from a mutually recursive
+   block. *)
+
+let map_rec fn decls rem =
+  match decls with
+  | [] -> rem
+  | d1 :: dl -> fn Trec_first d1 :: map_end (fn Trec_next) dl rem
+
+let map_rec_type ~rec_flag fn decls rem =
+  match decls with
+  | [] -> rem
+  | d1 :: dl ->
+      let first =
+        match rec_flag with
+        | Recursive -> Trec_first
+        | Nonrecursive -> Trec_not
+      in
+      fn first d1 :: map_end (fn Trec_next) dl rem
+
+let rec map_rec_type_with_row_types ~rec_flag fn decls rem =
+  match decls with
+  | [] -> rem
+  | d1 :: dl ->
+      if Btype.is_row_name (Ident.name d1.typ_id) then
+        fn Trec_not d1 :: map_rec_type_with_row_types ~rec_flag fn dl rem
+      else
+        map_rec_type ~rec_flag fn decls rem
+
+(* Add type extension flags to extension constructors *)
+let map_ext fn exts rem =
+  match exts with
+  | [] -> rem
+  | d1 :: dl -> fn Text_first d1 :: map_end (fn Text_next) dl rem
+
+(* Auxiliary for translating recursively-defined module types.
+   Return a module type that approximates the shape of the given module
+   type AST.  Retain only module, type, and module type
+   components of signatures.  For types, retain only their arity,
+   making them abstract otherwise. *)
+
+let rec approx_modtype env smty =
+  match smty.pmty_desc with
+    Pmty_ident lid ->
+      let (path, _info) =
+        Env.lookup_modtype ~use:false ~loc:smty.pmty_loc lid.txt env
+      in
+      Mty_ident path
+  | Pmty_alias lid ->
+      let path =
+        Env.lookup_module_path ~use:false ~load:false
+          ~loc:smty.pmty_loc lid.txt env
+      in
+      Mty_alias(path)
+  | Pmty_signature ssg ->
+      Mty_signature(approx_sig env ssg)
+  | Pmty_functor(param, sres) ->
+      let (param, newenv) =
+        match param with
+        | Unit -> Types.Unit, env
+        | Named (param, sarg) ->
+          let arg = approx_modtype env sarg in
+          match param.txt with
+          | None -> Types.Named (None, arg), env
+          | Some name ->
+            let rarg = Mtype.scrape_for_functor_arg env arg in
+            let scope = Ctype.create_scope () in
+            let (id, newenv) =
+              Env.enter_module ~scope ~arg:true name Mp_present rarg env
+            in
+            Types.Named (Some id, arg), newenv
+      in
+      let res = approx_modtype newenv sres in
+      Mty_functor(param, res)
+  | Pmty_with(sbody, constraints) ->
+      let body = approx_modtype env sbody in
+      List.iter
+        (fun sdecl ->
+          match sdecl with
+          | Pwith_type _ -> ()
+          | Pwith_typesubst _ -> ()
+          | Pwith_module (_, lid') ->
+              (* Lookup the module to make sure that it is not recursive.
+                 (GPR#1626) *)
+              ignore (Env.lookup_module ~use:false ~loc:lid'.loc lid'.txt env)
+          | Pwith_modsubst (_, lid') ->
+              ignore (Env.lookup_module ~use:false ~loc:lid'.loc lid'.txt env))
+        constraints;
+      body
+  | Pmty_typeof smod ->
+      let (_, mty) = !type_module_type_of_fwd env smod in
+      mty
+  | Pmty_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and approx_module_declaration env pmd =
+  {
+    Types.md_type = approx_modtype env pmd.pmd_type;
+    md_attributes = pmd.pmd_attributes;
+    md_loc = pmd.pmd_loc;
+    md_uid = Uid.internal_not_actually_unique;
+  }
+
+and approx_sig env ssg =
+  match ssg with
+    [] -> []
+  | item :: srem ->
+      match item.psig_desc with
+      | Psig_type (rec_flag, sdecls) ->
+          let decls = Typedecl.approx_type_decl sdecls in
+          let rem = approx_sig env srem in
+          map_rec_type ~rec_flag
+            (fun rs (id, info) -> Sig_type(id, info, rs, Exported)) decls rem
+      | Psig_typesubst _ -> approx_sig env srem
+      | Psig_module { pmd_name = { txt = None; _ }; _ } ->
+          approx_sig env srem
+      | Psig_module pmd ->
+          let scope = Ctype.create_scope () in
+          let md = approx_module_declaration env pmd in
+          let pres =
+            match md.Types.md_type with
+            | Mty_alias _ -> Mp_absent
+            | _ -> Mp_present
+          in
+          let id, newenv =
+            Env.enter_module_declaration ~scope (Option.get pmd.pmd_name.txt)
+              pres md env
+          in
+          Sig_module(id, pres, md, Trec_not, Exported) :: approx_sig newenv srem
+      | Psig_modsubst pms ->
+          let scope = Ctype.create_scope () in
+          let _, md =
+            Env.lookup_module ~use:false ~loc:pms.pms_manifest.loc
+               pms.pms_manifest.txt env
+          in
+          let pres =
+            match md.Types.md_type with
+            | Mty_alias _ -> Mp_absent
+            | _ -> Mp_present
+          in
+          let _, newenv =
+            Env.enter_module_declaration ~scope pms.pms_name.txt pres md env
+          in
+          approx_sig newenv srem
+      | Psig_recmodule sdecls ->
+          let scope = Ctype.create_scope () in
+          let decls =
+            List.filter_map
+              (fun pmd ->
+                 Option.map (fun name ->
+                   Ident.create_scoped ~scope name,
+                   approx_module_declaration env pmd
+                 ) pmd.pmd_name.txt
+              )
+              sdecls
+          in
+          let newenv =
+            List.fold_left
+              (fun env (id, md) -> Env.add_module_declaration ~check:false
+                  id Mp_present md env)
+              env decls
+          in
+          map_rec
+            (fun rs (id, md) -> Sig_module(id, Mp_present, md, rs, Exported))
+            decls
+            (approx_sig newenv srem)
+      | Psig_modtype d ->
+          let info = approx_modtype_info env d in
+          let scope = Ctype.create_scope () in
+          let (id, newenv) =
+            Env.enter_modtype ~scope d.pmtd_name.txt info env
+          in
+          Sig_modtype(id, info, Exported) :: approx_sig newenv srem
+      | Psig_open sod ->
+          let _, env = type_open_descr env sod in
+          approx_sig env srem
+      | Psig_include sincl ->
+          let smty = sincl.pincl_mod in
+          let mty = approx_modtype env smty in
+          let scope = Ctype.create_scope () in
+          let sg, newenv = Env.enter_signature ~scope
+              (extract_sig env smty.pmty_loc mty) env in
+          sg @ approx_sig newenv srem
+      | Psig_class sdecls | Psig_class_type sdecls ->
+          let decls = Typeclass.approx_class_declarations env sdecls in
+          let rem = approx_sig env srem in
+          map_rec (fun rs decl ->
+            let open Typeclass in [
+              Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs,
+                             Exported);
+              Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs, Exported);
+              Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs, Exported);
+            ]
+          ) decls [rem]
+          |> List.flatten
+      | _ ->
+          approx_sig env srem
+
+and approx_modtype_info env sinfo =
+  {
+   mtd_type = Option.map (approx_modtype env) sinfo.pmtd_type;
+   mtd_attributes = sinfo.pmtd_attributes;
+   mtd_loc = sinfo.pmtd_loc;
+   mtd_uid = Uid.internal_not_actually_unique;
+  }
+
+let approx_modtype env smty =
+  Warnings.without_warnings
+    (fun () -> approx_modtype env smty)
+
+(* Auxiliaries for checking the validity of name shadowing in signatures and
+   structures.
+   If a shadowing is valid, we also record some information (its ident,
+   location where it first appears, etc) about the item that gets shadowed. *)
+module Signature_names : sig
+  type t
+
+  type info = [
+    | `Exported
+    | `From_open
+    | `Shadowable of Ident.t * Location.t
+    | `Substituted_away of Subst.t
+  ]
+
+  val create : unit -> t
+
+  val check_value     : ?info:info -> t -> Location.t -> Ident.t -> unit
+  val check_type      : ?info:info -> t -> Location.t -> Ident.t -> unit
+  val check_typext    : ?info:info -> t -> Location.t -> Ident.t -> unit
+  val check_module    : ?info:info -> t -> Location.t -> Ident.t -> unit
+  val check_modtype   : ?info:info -> t -> Location.t -> Ident.t -> unit
+  val check_class     : ?info:info -> t -> Location.t -> Ident.t -> unit
+  val check_class_type: ?info:info -> t -> Location.t -> Ident.t -> unit
+
+  val check_sig_item:
+    ?info:info -> t -> Location.t -> Types.signature_item -> unit
+
+  val simplify: Env.t -> t -> Types.signature -> Types.signature
+end = struct
+
+  type bound_info = [
+    | `Exported
+    | `Shadowable of Ident.t * Location.t
+  ]
+
+  type info = [
+    | `From_open
+    | `Substituted_away of Subst.t
+    | bound_info
+  ]
+
+  type hide_reason =
+    | From_open
+    | Shadowed_by of Ident.t * Location.t
+
+  type to_be_removed = {
+    mutable subst: Subst.t;
+    mutable hide: (Sig_component_kind.t * Location.t * hide_reason) Ident.Map.t;
+  }
+
+  type names_infos = (string, bound_info) Hashtbl.t
+
+  type names = {
+    values: names_infos;
+    types: names_infos;
+    modules: names_infos;
+    modtypes: names_infos;
+    typexts: names_infos;
+    classes: names_infos;
+    class_types: names_infos;
+  }
+
+  let new_names () = {
+    values = Hashtbl.create 16;
+    types = Hashtbl.create 16;
+    modules = Hashtbl.create 16;
+    modtypes = Hashtbl.create 16;
+    typexts = Hashtbl.create 16;
+    classes = Hashtbl.create 16;
+    class_types = Hashtbl.create 16;
+  }
+
+  type t = {
+    bound: names;
+    to_be_removed: to_be_removed;
+  }
+
+  let create () = {
+    bound = new_names ();
+    to_be_removed = {
+      subst = Subst.identity;
+      hide = Ident.Map.empty;
+    };
+  }
+
+  let check cl loc (tbl : names_infos) id (info : info) to_be_removed =
+    match info with
+    | `Substituted_away s ->
+        to_be_removed.subst <- Subst.compose s to_be_removed.subst
+    | `From_open ->
+        to_be_removed.hide <-
+          Ident.Map.add id (cl, loc, From_open) to_be_removed.hide
+    | #bound_info as bound_info ->
+        let name = Ident.name id in
+        match Hashtbl.find_opt tbl name with
+        | None -> Hashtbl.add tbl name bound_info
+        | Some (`Shadowable (shadowed_id, shadowed_loc)) ->
+            Hashtbl.replace tbl name bound_info;
+            let reason = Shadowed_by (id, loc) in
+            to_be_removed.hide <-
+              Ident.Map.add shadowed_id (cl, shadowed_loc, reason)
+                to_be_removed.hide
+        | Some `Exported ->
+            raise(Error(loc, Env.empty, Repeated_name(cl, name)))
+
+  let check_value ?info t loc id =
+    let info =
+      match info with
+      | Some i -> i
+      | None -> `Shadowable (id, loc)
+    in
+    check Sig_component_kind.Value loc t.bound.values id info t.to_be_removed
+  let check_type ?(info=`Exported) t loc id =
+    check Sig_component_kind.Type loc t.bound.types id info t.to_be_removed
+  let check_module ?(info=`Exported) t loc id =
+    check Sig_component_kind.Module loc t.bound.modules id info t.to_be_removed
+  let check_modtype ?(info=`Exported) t loc id =
+    check Sig_component_kind.Module_type loc t.bound.modtypes id info
+      t.to_be_removed
+  let check_typext ?(info=`Exported) t loc id =
+    check Sig_component_kind.Extension_constructor loc t.bound.typexts id info
+      t.to_be_removed
+  let check_class ?(info=`Exported) t loc id =
+    check Sig_component_kind.Class loc t.bound.classes id info t.to_be_removed
+  let check_class_type ?(info=`Exported) t loc id =
+    check Sig_component_kind.Class_type loc t.bound.class_types id info
+      t.to_be_removed
+
+  let check_sig_item ?info names loc component =
+    let info id loc =
+      match info with
+      | None -> `Shadowable (id, loc)
+      | Some i -> i
+    in
+    match component with
+    | Sig_type(id, _, _, _) ->
+        check_type names loc id ~info:(info id loc)
+    | Sig_module(id, _, _, _, _) ->
+        check_module names loc id ~info:(info id loc)
+    | Sig_modtype(id, _, _) ->
+        check_modtype names loc id ~info:(info id loc)
+    | Sig_typext(id, _, _, _) ->
+        check_typext names loc id ~info:(info id loc)
+    | Sig_value (id, _, _) ->
+        check_value names loc id ~info:(info id loc)
+    | Sig_class (id, _, _, _) ->
+        check_class names loc id ~info:(info id loc)
+    | Sig_class_type (id, _, _, _) ->
+        check_class_type names loc id ~info:(info id loc)
+
+  (* We usually require name uniqueness of signature components (e.g. types,
+     modules, etc), however in some situation reusing the name is allowed: if
+     the component is a value or an extension, or if the name is introduced by
+     an include.
+     When there are multiple specifications of a component with the same name,
+     we try to keep only the last (rightmost) one, removing all references to
+     the previous ones from the signature.
+     If some reference cannot be removed, then we error out with
+     [Cannot_hide_id].
+  *)
+
+  let simplify env t sg =
+    let to_remove = t.to_be_removed in
+    let ids_to_remove =
+      Ident.Map.fold (fun id (kind,  _, _) lst ->
+        if Sig_component_kind.can_appear_in_types kind then
+          id :: lst
+        else
+          lst
+      ) to_remove.hide []
+    in
+    let aux component sg =
+      let user_kind, user_id, user_loc =
+        let open Sig_component_kind in
+        match component with
+        | Sig_value(id, v, _) -> Value, id, v.val_loc
+        | Sig_type (id, td, _, _) -> Type, id, td.type_loc
+        | Sig_typext (id, te, _, _) -> Extension_constructor, id, te.ext_loc
+        | Sig_module (id, _, md, _, _) -> Module, id, md.md_loc
+        | Sig_modtype (id, mtd, _) -> Module_type, id, mtd.mtd_loc
+        | Sig_class (id, c, _, _) -> Class, id, c.cty_loc
+        | Sig_class_type (id, ct, _, _) -> Class_type, id, ct.clty_loc
+      in
+      if Ident.Map.mem user_id to_remove.hide then
+        sg
+      else begin
+        let component =
+          if to_remove.subst == Subst.identity then
+            component
+          else
+            Subst.signature_item Keep to_remove.subst component
+        in
+        let component =
+          match ids_to_remove with
+          | [] -> component
+          | ids ->
+            try Mtype.nondep_sig_item env ids component with
+            | Ctype.Nondep_cannot_erase removed_item_id ->
+              let (removed_item_kind, removed_item_loc, reason) =
+                Ident.Map.find removed_item_id to_remove.hide
+              in
+              let err_loc, hiding_error =
+                match reason with
+                | From_open ->
+                  removed_item_loc,
+                  Appears_in_signature {
+                    opened_item_kind = removed_item_kind;
+                    opened_item_id = removed_item_id;
+                    user_id;
+                    user_kind;
+                    user_loc;
+                  }
+                | Shadowed_by (shadower_id, shadower_loc) ->
+                  shadower_loc,
+                  Illegal_shadowing {
+                    shadowed_item_kind = removed_item_kind;
+                    shadowed_item_id = removed_item_id;
+                    shadowed_item_loc = removed_item_loc;
+                    shadower_id;
+                    user_id;
+                    user_kind;
+                    user_loc;
+                  }
+              in
+              raise (Error(err_loc, env, Cannot_hide_id hiding_error))
+        in
+        component :: sg
+      end
+    in
+    List.fold_right aux sg []
+end
+
+let has_remove_aliases_attribute attr =
+  let remove_aliases =
+    Attr_helper.get_no_payload_attribute
+      ["remove_aliases"; "ocaml.remove_aliases"] attr
+  in
+  match remove_aliases with
+  | None -> false
+  | Some _ -> true
+
+(* Check and translate a module type expression *)
+
+let transl_modtype_longident loc env lid =
+  let (path, _info) = Env.lookup_modtype ~loc lid env in
+  path
+
+let transl_module_alias loc env lid =
+  Env.lookup_module_path ~load:false ~loc lid env
+
+let mkmty desc typ env loc attrs =
+  let mty = {
+    mty_desc = desc;
+    mty_type = typ;
+    mty_loc = loc;
+    mty_env = env;
+    mty_attributes = attrs;
+    } in
+  Cmt_format.add_saved_type (Cmt_format.Partial_module_type mty);
+  mty
+
+let mksig desc env loc =
+  let sg = { sig_desc = desc; sig_loc = loc; sig_env = env } in
+  Cmt_format.add_saved_type (Cmt_format.Partial_signature_item sg);
+  sg
+
+(* let signature sg = List.map (fun item -> item.sig_type) sg *)
+
+let rec transl_modtype env smty =
+  Builtin_attributes.warning_scope smty.pmty_attributes
+    (fun () -> transl_modtype_aux env smty)
+
+and transl_modtype_functor_arg env sarg =
+  let mty = transl_modtype env sarg in
+  {mty with mty_type = Mtype.scrape_for_functor_arg env mty.mty_type}
+
+and transl_modtype_aux env smty =
+  let loc = smty.pmty_loc in
+  match smty.pmty_desc with
+    Pmty_ident lid ->
+      let path = transl_modtype_longident loc env lid.txt in
+      mkmty (Tmty_ident (path, lid)) (Mty_ident path) env loc
+        smty.pmty_attributes
+  | Pmty_alias lid ->
+      let path = transl_module_alias loc env lid.txt in
+      mkmty (Tmty_alias (path, lid)) (Mty_alias path) env loc
+        smty.pmty_attributes
+  | Pmty_signature ssg ->
+      let sg = transl_signature env ssg in
+      mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc
+        smty.pmty_attributes
+  | Pmty_functor(sarg_opt, sres) ->
+      let t_arg, ty_arg, newenv =
+        match sarg_opt with
+        | Unit -> Unit, Types.Unit, env
+        | Named (param, sarg) ->
+          let arg = transl_modtype_functor_arg env sarg in
+          let (id, newenv) =
+            match param.txt with
+            | None -> None, env
+            | Some name ->
+              let scope = Ctype.create_scope () in
+              let id, newenv =
+                let arg_md =
+                  { md_type = arg.mty_type;
+                    md_attributes = [];
+                    md_loc = param.loc;
+                    md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+                  }
+                in
+                Env.enter_module_declaration ~scope ~arg:true name Mp_present
+                  arg_md env
+              in
+              Some id, newenv
+          in
+          Named (id, param, arg), Types.Named (id, arg.mty_type), newenv
+      in
+      let res = transl_modtype newenv sres in
+      mkmty (Tmty_functor (t_arg, res))
+        (Mty_functor(ty_arg, res.mty_type)) env loc
+        smty.pmty_attributes
+  | Pmty_with(sbody, constraints) ->
+      let body = transl_modtype env sbody in
+      let init_sg = extract_sig env sbody.pmty_loc body.mty_type in
+      let remove_aliases = has_remove_aliases_attribute smty.pmty_attributes in
+      let (rev_tcstrs, final_sg) =
+        List.fold_left
+          (fun (rev_tcstrs,sg) sdecl ->
+            let (tcstr, sg) =
+              merge_constraint env remove_aliases smty.pmty_loc sg sdecl
+            in
+            (tcstr :: rev_tcstrs, sg)
+        )
+        ([],init_sg) constraints in
+      let scope = Ctype.create_scope () in
+      mkmty (Tmty_with ( body, List.rev rev_tcstrs))
+        (Mtype.freshen ~scope (Mty_signature final_sg)) env loc
+        smty.pmty_attributes
+  | Pmty_typeof smod ->
+      let env = Env.in_signature false env in
+      let tmty, mty = !type_module_type_of_fwd env smod in
+      mkmty (Tmty_typeof tmty) mty env loc smty.pmty_attributes
+  | Pmty_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and transl_signature env sg =
+  let names = Signature_names.create () in
+  let rec transl_sig env sg =
+    match sg with
+      [] -> [], [], env
+    | item :: srem ->
+        let loc = item.psig_loc in
+        match item.psig_desc with
+        | Psig_value sdesc ->
+            let (tdesc, newenv) =
+              Typedecl.transl_value_decl env item.psig_loc sdesc
+            in
+            Signature_names.check_value names tdesc.val_loc tdesc.val_id;
+            let (trem,rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_value tdesc) env loc :: trem,
+            Sig_value(tdesc.val_id, tdesc.val_val, Exported) :: rem,
+              final_env
+        | Psig_type (rec_flag, sdecls) ->
+            let (decls, newenv) =
+              Typedecl.transl_type_decl env rec_flag sdecls
+            in
+            List.iter (fun td ->
+              Signature_names.check_type names td.typ_loc td.typ_id
+            ) decls;
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            let sg =
+              map_rec_type_with_row_types ~rec_flag
+                (fun rs td -> Sig_type(td.typ_id, td.typ_type, rs, Exported))
+                decls rem
+            in
+            mksig (Tsig_type (rec_flag, decls)) env loc :: trem,
+            sg,
+            final_env
+        | Psig_typesubst sdecls ->
+            let (decls, newenv) =
+              Typedecl.transl_type_decl env Nonrecursive sdecls
+            in
+            List.iter (fun td ->
+              if td.typ_kind <> Ttype_abstract || td.typ_manifest = None ||
+                 td.typ_private = Private
+              then
+                raise (Error (td.typ_loc, env, Invalid_type_subst_rhs));
+              let params = td.typ_type.type_params in
+              if params_are_constrained params
+              then raise(Error(loc, env, With_cannot_remove_constrained_type));
+              let info =
+                  let subst =
+                    Subst.add_type_function (Pident td.typ_id)
+                      ~params
+                      ~body:(Option.get td.typ_type.type_manifest)
+                      Subst.identity
+                  in
+                  Some (`Substituted_away subst)
+              in
+              Signature_names.check_type ?info names td.typ_loc td.typ_id
+            ) decls;
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            let sg = rem
+            in
+            mksig (Tsig_typesubst decls) env loc :: trem,
+            sg,
+            final_env
+        | Psig_typext styext ->
+            let (tyext, newenv) =
+              Typedecl.transl_type_extension false env item.psig_loc styext
+            in
+            let constructors = tyext.tyext_constructors in
+            List.iter (fun ext ->
+              Signature_names.check_typext names ext.ext_loc ext.ext_id
+            ) constructors;
+            let (trem, rem, final_env) = transl_sig newenv srem in
+              mksig (Tsig_typext tyext) env loc :: trem,
+              map_ext (fun es ext ->
+                Sig_typext(ext.ext_id, ext.ext_type, es, Exported)
+              ) constructors rem,
+              final_env
+        | Psig_exception sext ->
+            let (ext, newenv) = Typedecl.transl_type_exception env sext in
+            let constructor = ext.tyexn_constructor in
+            Signature_names.check_typext names constructor.ext_loc
+              constructor.ext_id;
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_exception ext) env loc :: trem,
+            Sig_typext(constructor.ext_id,
+                       constructor.ext_type,
+                       Text_exception,
+                       Exported) :: rem,
+            final_env
+        | Psig_module pmd ->
+            let scope = Ctype.create_scope () in
+            let tmty =
+              Builtin_attributes.warning_scope pmd.pmd_attributes
+                (fun () -> transl_modtype env pmd.pmd_type)
+            in
+            let pres =
+              match tmty.mty_type with
+              | Mty_alias _ -> Mp_absent
+              | _ -> Mp_present
+            in
+            let md = {
+              md_type=tmty.mty_type;
+              md_attributes=pmd.pmd_attributes;
+              md_loc=pmd.pmd_loc;
+              md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+            }
+            in
+            let id, newenv =
+              match pmd.pmd_name.txt with
+              | None -> None, env
+              | Some name ->
+                let id, newenv =
+                  Env.enter_module_declaration ~scope name pres md env
+                in
+                Signature_names.check_module names pmd.pmd_name.loc id;
+                Some id, newenv
+            in
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_module {md_id=id; md_name=pmd.pmd_name;
+                                md_presence=pres; md_type=tmty;
+                                md_loc=pmd.pmd_loc;
+                                md_attributes=pmd.pmd_attributes})
+              env loc :: trem,
+            (match id with
+             | None -> rem
+             | Some id -> Sig_module(id, pres, md, Trec_not, Exported) :: rem),
+            final_env
+        | Psig_modsubst pms ->
+            let scope = Ctype.create_scope () in
+            let path, md =
+              Env.lookup_module ~loc:pms.pms_manifest.loc
+                pms.pms_manifest.txt env
+            in
+            let aliasable = not (Env.is_functor_arg path env) in
+            let md =
+              if not aliasable then
+                md
+              else
+                { md_type = Mty_alias path;
+                  md_attributes = pms.pms_attributes;
+                  md_loc = pms.pms_loc;
+                  md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+                }
+            in
+            let pres =
+              match md.md_type with
+              | Mty_alias _ -> Mp_absent
+              | _ -> Mp_present
+            in
+            let id, newenv =
+              Env.enter_module_declaration ~scope pms.pms_name.txt pres md env
+            in
+            let info =
+              `Substituted_away (Subst.add_module id path Subst.identity)
+            in
+            Signature_names.check_module ~info names pms.pms_name.loc id;
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_modsubst {ms_id=id; ms_name=pms.pms_name;
+                                  ms_manifest=path; ms_txt=pms.pms_manifest;
+                                  ms_loc=pms.pms_loc;
+                                  ms_attributes=pms.pms_attributes})
+              env loc :: trem,
+            rem,
+            final_env
+        | Psig_recmodule sdecls ->
+            let (tdecls, newenv) =
+              transl_recmodule_modtypes env sdecls in
+            let decls =
+              List.filter_map (fun (md, uid) ->
+                match md.md_id with
+                | None -> None
+                | Some id -> Some (id, md, uid)
+              ) tdecls
+            in
+            List.iter (fun (id, md, _) ->
+              Signature_names.check_module names md.md_loc id
+            ) decls;
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_recmodule (List.map fst tdecls)) env loc :: trem,
+            map_rec (fun rs (id, md, uid) ->
+                let d = {Types.md_type = md.md_type.mty_type;
+                         md_attributes = md.md_attributes;
+                         md_loc = md.md_loc;
+                         md_uid = uid;
+                        } in
+                Sig_module(id, Mp_present, d, rs, Exported))
+              decls rem,
+            final_env
+        | Psig_modtype pmtd ->
+            let newenv, mtd, sg = transl_modtype_decl names env pmtd in
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_modtype mtd) env loc :: trem,
+            sg :: rem,
+            final_env
+        | Psig_open sod ->
+            let (od, newenv) = type_open_descr env sod in
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_open od) env loc :: trem,
+            rem, final_env
+        | Psig_include sincl ->
+            let smty = sincl.pincl_mod in
+            let tmty =
+              Builtin_attributes.warning_scope sincl.pincl_attributes
+                (fun () -> transl_modtype env smty)
+            in
+            let mty = tmty.mty_type in
+            let scope = Ctype.create_scope () in
+            let sg, newenv = Env.enter_signature ~scope
+                       (extract_sig env smty.pmty_loc mty) env in
+            List.iter (Signature_names.check_sig_item names item.psig_loc) sg;
+            let incl =
+              { incl_mod = tmty;
+                incl_type = sg;
+                incl_attributes = sincl.pincl_attributes;
+                incl_loc = sincl.pincl_loc;
+              }
+            in
+            let (trem, rem, final_env) = transl_sig newenv srem  in
+            mksig (Tsig_include incl) env loc :: trem,
+            sg @ rem,
+            final_env
+        | Psig_class cl ->
+            let (classes, newenv) = Typeclass.class_descriptions env cl in
+            List.iter (fun cls ->
+              let open Typeclass in
+              let loc = cls.cls_id_loc.Location.loc in
+              Signature_names.check_type names loc cls.cls_obj_id;
+              Signature_names.check_class names loc cls.cls_id;
+              Signature_names.check_class_type names loc cls.cls_ty_id;
+              Signature_names.check_type names loc cls.cls_typesharp_id;
+            ) classes;
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            let sg =
+              map_rec (fun rs cls ->
+                let open Typeclass in
+                [Sig_class(cls.cls_id, cls.cls_decl, rs, Exported);
+                 Sig_class_type(cls.cls_ty_id, cls.cls_ty_decl, rs, Exported);
+                 Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs, Exported);
+                 Sig_type(cls.cls_typesharp_id, cls.cls_abbr, rs, Exported)]
+              ) classes [rem]
+              |> List.flatten
+            in
+            let typedtree =
+              mksig (Tsig_class
+                       (List.map (fun decr ->
+                          decr.Typeclass.cls_info) classes)) env loc
+              :: trem
+            in
+            typedtree, sg, final_env
+        | Psig_class_type cl ->
+            let (classes, newenv) = Typeclass.class_type_declarations env cl in
+            List.iter (fun decl ->
+              let open Typeclass in
+              let loc = decl.clsty_id_loc.Location.loc in
+              Signature_names.check_class_type names loc decl.clsty_ty_id;
+              Signature_names.check_type names loc decl.clsty_obj_id;
+              Signature_names.check_type names loc decl.clsty_typesharp_id;
+            ) classes;
+            let (trem,rem, final_env) = transl_sig newenv srem in
+            let sg =
+              map_rec (fun rs decl ->
+                let open Typeclass in
+                [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs,
+                                Exported);
+                 Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs, Exported);
+                 Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs,
+                          Exported)
+                ]
+              ) classes [rem]
+              |> List.flatten
+            in
+            let typedtree =
+              mksig
+                (Tsig_class_type
+                   (List.map (fun decl -> decl.Typeclass.clsty_info) classes))
+                env loc
+              :: trem
+            in
+            typedtree, sg, final_env
+        | Psig_attribute x ->
+            Builtin_attributes.warning_attribute x;
+            let (trem,rem, final_env) = transl_sig env srem in
+            mksig (Tsig_attribute x) env loc :: trem, rem, final_env
+        | Psig_extension (ext, _attrs) ->
+            raise (Error_forward (Builtin_attributes.error_of_extension ext))
+  in
+  let previous_saved_types = Cmt_format.get_saved_types () in
+  Builtin_attributes.warning_scope []
+    (fun () ->
+       let (trem, rem, final_env) = transl_sig (Env.in_signature true env) sg in
+       let rem = Signature_names.simplify final_env names rem in
+       let sg =
+         { sig_items = trem; sig_type = rem; sig_final_env = final_env }
+       in
+       Cmt_format.set_saved_types
+         ((Cmt_format.Partial_signature sg) :: previous_saved_types);
+       sg
+    )
+
+and transl_modtype_decl names env pmtd =
+  Builtin_attributes.warning_scope pmtd.pmtd_attributes
+    (fun () -> transl_modtype_decl_aux names env pmtd)
+
+and transl_modtype_decl_aux names env
+    {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} =
+  let tmty =
+    Option.map (transl_modtype (Env.in_signature true env)) pmtd_type
+  in
+  let decl =
+    {
+     Types.mtd_type=Option.map (fun t -> t.mty_type) tmty;
+     mtd_attributes=pmtd_attributes;
+     mtd_loc=pmtd_loc;
+     mtd_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+    }
+  in
+  let scope = Ctype.create_scope () in
+  let (id, newenv) = Env.enter_modtype ~scope pmtd_name.txt decl env in
+  Signature_names.check_modtype names pmtd_loc id;
+  let mtd =
+    {
+     mtd_id=id;
+     mtd_name=pmtd_name;
+     mtd_type=tmty;
+     mtd_attributes=pmtd_attributes;
+     mtd_loc=pmtd_loc;
+    }
+  in
+  newenv, mtd, Sig_modtype(id, decl, Exported)
+
+and transl_recmodule_modtypes env sdecls =
+  let make_env curr =
+    List.fold_left
+      (fun env (id, _, md, _) ->
+         Option.fold ~none:env
+           ~some:(fun id -> Env.add_module_declaration ~check:true ~arg:true
+                              id Mp_present md env) id)
+      env curr in
+  let transition env_c curr =
+    List.map2
+      (fun pmd (id, id_loc, md, _) ->
+        let tmty =
+          Builtin_attributes.warning_scope pmd.pmd_attributes
+            (fun () -> transl_modtype env_c pmd.pmd_type)
+        in
+        let md = { md with Types.md_type = tmty.mty_type } in
+        (id, id_loc, md, tmty))
+      sdecls curr in
+  let map_mtys curr =
+    List.filter_map
+      (fun (id, _, md, _) -> Option.map (fun id -> (id, md)) id)
+      curr
+  in
+  let scope = Ctype.create_scope () in
+  let ids =
+    List.map (fun x -> Option.map (Ident.create_scoped ~scope) x.pmd_name.txt)
+      sdecls
+  in
+  let approx_env =
+    List.fold_left
+      (fun env ->
+         Option.fold ~none:env ~some:(fun id -> (* cf #5965 *)
+           Env.enter_unbound_module (Ident.name id)
+             Mod_unbound_illegal_recursion env
+         ))
+      env ids
+  in
+  let init =
+    List.map2
+      (fun id pmd ->
+         let md =
+           { md_type = approx_modtype approx_env pmd.pmd_type;
+             md_loc = pmd.pmd_loc;
+             md_attributes = pmd.pmd_attributes;
+             md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) }
+         in
+        (id, pmd.pmd_name, md, ()))
+      ids sdecls
+  in
+  let env0 = make_env init in
+  let dcl1 =
+    Warnings.without_warnings
+      (fun () -> transition env0 init)
+  in
+  let env1 = make_env dcl1 in
+  check_recmod_typedecls env1 (map_mtys dcl1);
+  let dcl2 = transition env1 dcl1 in
+(*
+  List.iter
+    (fun (id, mty) ->
+      Format.printf "%a: %a@." Printtyp.ident id Printtyp.modtype mty)
+    dcl2;
+*)
+  let env2 = make_env dcl2 in
+  check_recmod_typedecls env2 (map_mtys dcl2);
+  let dcl2 =
+    List.map2 (fun pmd (id, id_loc, md, mty) ->
+      let tmd =
+        {md_id=id; md_name=id_loc; md_type=mty;
+         md_presence=Mp_present;
+         md_loc=pmd.pmd_loc;
+         md_attributes=pmd.pmd_attributes}
+      in
+      tmd, md.md_uid
+    ) sdecls dcl2
+  in
+  (dcl2, env2)
+
+(* Try to convert a module expression to a module path. *)
+
+exception Not_a_path
+
+let rec path_of_module mexp =
+  match mexp.mod_desc with
+  | Tmod_ident (p,_) -> p
+  | Tmod_apply(funct, arg, _coercion) when !Clflags.applicative_functors ->
+      Papply(path_of_module funct, path_of_module arg)
+  | Tmod_constraint (mexp, _, _, _) ->
+      path_of_module mexp
+  | _ -> raise Not_a_path
+
+let path_of_module mexp =
+ try Some (path_of_module mexp) with Not_a_path -> None
+
+(* Check that all core type schemes in a structure are closed *)
+
+let rec closed_modtype env = function
+    Mty_ident _ -> true
+  | Mty_alias _ -> true
+  | Mty_signature sg ->
+      let env = Env.add_signature sg env in
+      List.for_all (closed_signature_item env) sg
+  | Mty_functor(arg_opt, body) ->
+      let env =
+        match arg_opt with
+        | Unit
+        | Named (None, _) -> env
+        | Named (Some id, param) ->
+            Env.add_module ~arg:true id Mp_present param env
+      in
+      closed_modtype env body
+
+and closed_signature_item env = function
+    Sig_value(_id, desc, _) -> Ctype.closed_schema env desc.val_type
+  | Sig_module(_id, _, md, _, _) -> closed_modtype env md.md_type
+  | _ -> true
+
+let check_nongen_scheme env sig_item =
+  match sig_item with
+    Sig_value(_id, vd, _) ->
+      if not (Ctype.closed_schema env vd.val_type) then
+        raise (Error (vd.val_loc, env, Non_generalizable vd.val_type))
+  | Sig_module (_id, _, md, _, _) ->
+      if not (closed_modtype env md.md_type) then
+        raise(Error(md.md_loc, env, Non_generalizable_module md.md_type))
+  | _ -> ()
+
+let check_nongen_schemes env sg =
+  List.iter (check_nongen_scheme env) sg
+
+(* Helpers for typing recursive modules *)
+
+let anchor_submodule name anchor =
+  match anchor, name with
+  | None, _
+  | _, None ->
+      None
+  | Some p, Some name ->
+      Some(Pdot(p, name))
+
+let anchor_recmodule = Option.map (fun id -> Pident id)
+
+let enrich_type_decls anchor decls oldenv newenv =
+  match anchor with
+    None -> newenv
+  | Some p ->
+      List.fold_left
+        (fun e info ->
+          let id = info.typ_id in
+          let info' =
+            Mtype.enrich_typedecl oldenv (Pdot(p, Ident.name id))
+              id info.typ_type
+          in
+            Env.add_type ~check:true id info' e)
+        oldenv decls
+
+let enrich_module_type anchor name mty env =
+  match anchor, name with
+  | None, _
+  | _, None ->
+      mty
+  | Some p, Some name ->
+      Mtype.enrich_modtype env (Pdot(p, name)) mty
+
+let check_recmodule_inclusion env bindings =
+  (* PR#4450, PR#4470: consider
+        module rec X : DECL = MOD  where MOD has inferred type ACTUAL
+     The "natural" typing condition
+        E, X: ACTUAL |- ACTUAL <: DECL
+     leads to circularities through manifest types.
+     Instead, we "unroll away" the potential circularities a finite number
+     of times.  The (weaker) condition we implement is:
+        E, X: DECL,
+           X1: ACTUAL,
+           X2: ACTUAL{X <- X1}/X1
+           ...
+           Xn: ACTUAL{X <- X(n-1)}/X(n-1)
+        |- ACTUAL{X <- Xn}/Xn <: DECL{X <- Xn}
+     so that manifest types rooted at X(n+1) are expanded in terms of X(n),
+     avoiding circularities.  The strengthenings ensure that
+     Xn.t = X(n-1).t = ... = X2.t = X1.t.
+     N can be chosen arbitrarily; larger values of N result in more
+     recursive definitions being accepted.  A good choice appears to be
+     the number of mutually recursive declarations. *)
+
+  let subst_and_strengthen env scope s id mty =
+    let mty = Subst.modtype (Rescope scope) s mty in
+    match id with
+    | None -> mty
+    | Some id ->
+        Mtype.strengthen ~aliasable:false env mty
+          (Subst.module_path s (Pident id))
+  in
+
+  let rec check_incl first_time n env s =
+    let scope = Ctype.create_scope () in
+    if n > 0 then begin
+      (* Generate fresh names Y_i for the rec. bound module idents X_i *)
+      let bindings1 =
+        List.map
+          (fun (id, _name, _mty_decl, _modl, mty_actual, _attrs, _loc, _uid) ->
+             let ids =
+               Option.map
+                 (fun id -> (id, Ident.create_scoped ~scope (Ident.name id))) id
+             in
+             (ids, mty_actual))
+          bindings in
+      (* Enter the Y_i in the environment with their actual types substituted
+         by the input substitution s *)
+      let env' =
+        List.fold_left
+          (fun env (ids, mty_actual) ->
+             match ids with
+             | None -> env
+             | Some (id, id') ->
+               let mty_actual' =
+                 if first_time
+                 then mty_actual
+                 else subst_and_strengthen env scope s (Some id) mty_actual
+               in
+               Env.add_module ~arg:false id' Mp_present mty_actual' env)
+          env bindings1 in
+      (* Build the output substitution Y_i <- X_i *)
+      let s' =
+        List.fold_left
+          (fun s (ids, _mty_actual) ->
+             match ids with
+             | None -> s
+             | Some (id, id') -> Subst.add_module id (Pident id') s)
+          Subst.identity bindings1 in
+      (* Recurse with env' and s' *)
+      check_incl false (n-1) env' s'
+    end else begin
+      (* Base case: check inclusion of s(mty_actual) in s(mty_decl)
+         and insert coercion if needed *)
+      let check_inclusion
+            (id, name, mty_decl, modl, mty_actual, attrs, loc, uid) =
+        let mty_decl' = Subst.modtype (Rescope scope) s mty_decl.mty_type
+        and mty_actual' = subst_and_strengthen env scope s id mty_actual in
+        let coercion =
+          try
+            Includemod.modtypes ~loc:modl.mod_loc ~mark:Mark_both env
+              mty_actual' mty_decl'
+          with Includemod.Error msg ->
+            raise(Error(modl.mod_loc, env, Not_included msg)) in
+        let modl' =
+            { mod_desc = Tmod_constraint(modl, mty_decl.mty_type,
+                Tmodtype_explicit mty_decl, coercion);
+              mod_type = mty_decl.mty_type;
+              mod_env = env;
+              mod_loc = modl.mod_loc;
+              mod_attributes = [];
+             } in
+        let mb =
+          {
+            mb_id = id;
+            mb_name = name;
+            mb_presence = Mp_present;
+            mb_expr = modl';
+            mb_attributes = attrs;
+            mb_loc = loc;
+          }
+        in
+        mb, uid
+      in
+      List.map check_inclusion bindings
+    end
+  in check_incl true (List.length bindings) env Subst.identity
+
+(* Helper for unpack *)
+
+let rec package_constraints_sig env loc sg constrs =
+  List.map
+    (function
+      | Sig_type (id, ({type_params=[]} as td), rs, priv)
+        when List.mem_assoc [Ident.name id] constrs ->
+          let ty = List.assoc [Ident.name id] constrs in
+          Sig_type (id, {td with type_manifest = Some ty}, rs, priv)
+      | Sig_module (id, pres, md, rs, priv) ->
+          let rec aux = function
+            | (m :: ((_ :: _) as l), t) :: rest when m = Ident.name id ->
+                (l, t) :: aux rest
+            | _ :: rest -> aux rest
+            | [] -> []
+          in
+          let md =
+            {md with
+             md_type = package_constraints env loc md.md_type (aux constrs)
+            }
+          in
+          Sig_module (id, pres, md, rs, priv)
+      | item -> item
+    )
+    sg
+
+and package_constraints env loc mty constrs =
+  if constrs = [] then mty
+  else begin
+    match Mtype.scrape env mty with
+    | Mty_signature sg ->
+        Mty_signature (package_constraints_sig env loc sg constrs)
+    | Mty_functor _ | Mty_alias _ -> assert false
+    | Mty_ident p -> raise(Error(loc, env, Cannot_scrape_package_type p))
+  end
+
+let modtype_of_package env loc p nl tl =
+  package_constraints env loc (Mty_ident p)
+    (List.combine (List.map Longident.flatten nl) tl)
+
+let package_subtype env p1 nl1 tl1 p2 nl2 tl2 =
+  let mkmty p nl tl =
+    let ntl =
+      List.filter (fun (_n,t) -> Ctype.free_variables t = [])
+        (List.combine nl tl) in
+    let (nl, tl) = List.split ntl in
+    modtype_of_package env Location.none p nl tl
+  in
+  match mkmty p1 nl1 tl1, mkmty p2 nl2 tl2 with
+  | exception Error(_, _, Cannot_scrape_package_type _) -> false
+  | mty1, mty2 ->
+    let loc = Location.none in
+    match Includemod.modtypes ~loc ~mark:Mark_both env mty1 mty2 with
+    | Tcoerce_none -> true
+    | _ | exception Includemod.Error _ -> false
+
+let () = Ctype.package_subtype := package_subtype
+
+let wrap_constraint env mark arg mty explicit =
+  let mark = if mark then Includemod.Mark_both else Includemod.Mark_neither in
+  let coercion =
+    try
+      Includemod.modtypes ~loc:arg.mod_loc env ~mark arg.mod_type mty
+    with Includemod.Error msg ->
+      raise(Error(arg.mod_loc, env, Not_included msg)) in
+  { mod_desc = Tmod_constraint(arg, mty, explicit, coercion);
+    mod_type = mty;
+    mod_env = env;
+    mod_attributes = [];
+    mod_loc = arg.mod_loc }
+
+(* Type a module value expression *)
+
+let rec type_module ?(alias=false) sttn funct_body anchor env smod =
+  Builtin_attributes.warning_scope smod.pmod_attributes
+    (fun () -> type_module_aux ~alias sttn funct_body anchor env smod)
+
+and type_module_aux ~alias sttn funct_body anchor env smod =
+  match smod.pmod_desc with
+    Pmod_ident lid ->
+      let path =
+        Env.lookup_module_path ~load:(not alias) ~loc:smod.pmod_loc lid.txt env
+      in
+      let md = { mod_desc = Tmod_ident (path, lid);
+                 mod_type = Mty_alias path;
+                 mod_env = env;
+                 mod_attributes = smod.pmod_attributes;
+                 mod_loc = smod.pmod_loc } in
+      let aliasable = not (Env.is_functor_arg path env) in
+      let md =
+        if alias && aliasable then
+          (Env.add_required_global (Path.head path); md)
+        else match (Env.find_module path env).md_type with
+        | Mty_alias p1 when not alias ->
+            let p1 = Env.normalize_module_path (Some smod.pmod_loc) env p1 in
+            let mty = Includemod.expand_module_alias env [] p1 in
+            { md with
+              mod_desc =
+                Tmod_constraint (md, mty, Tmodtype_implicit,
+                                 Tcoerce_alias (env, path, Tcoerce_none));
+              mod_type =
+                if sttn then Mtype.strengthen ~aliasable:true env mty p1
+                else mty }
+        | mty ->
+            let mty =
+              if sttn then Mtype.strengthen ~aliasable env mty path
+              else mty
+            in
+            { md with mod_type = mty }
+      in md
+  | Pmod_structure sstr ->
+      let (str, sg, names, _finalenv) =
+        type_structure funct_body anchor env sstr in
+      let md =
+        { mod_desc = Tmod_structure str;
+          mod_type = Mty_signature sg;
+          mod_env = env;
+          mod_attributes = smod.pmod_attributes;
+          mod_loc = smod.pmod_loc }
+      in
+      let sg' = Signature_names.simplify _finalenv names sg in
+      if List.length sg' = List.length sg then md else
+      wrap_constraint env false md (Mty_signature sg')
+        Tmodtype_implicit
+  | Pmod_functor(arg_opt, sbody) ->
+      let t_arg, ty_arg, newenv, funct_body =
+        match arg_opt with
+        | Unit -> Unit, Types.Unit, env, false
+        | Named (param, smty) ->
+          let mty = transl_modtype_functor_arg env smty in
+          let scope = Ctype.create_scope () in
+          let (id, newenv) =
+            match param.txt with
+            | None -> None, env
+            | Some name ->
+              let arg_md =
+                { md_type = mty.mty_type;
+                  md_attributes = [];
+                  md_loc = param.loc;
+                  md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+                }
+              in
+              let id, newenv =
+                Env.enter_module_declaration ~scope ~arg:true name Mp_present
+                  arg_md env
+              in
+              Some id, newenv
+          in
+          Named (id, param, mty), Types.Named (id, mty.mty_type), newenv, true
+      in
+      let body = type_module sttn funct_body None newenv sbody in
+      { mod_desc = Tmod_functor(t_arg, body);
+        mod_type = Mty_functor(ty_arg, body.mod_type);
+        mod_env = env;
+        mod_attributes = smod.pmod_attributes;
+        mod_loc = smod.pmod_loc }
+  | Pmod_apply(sfunct, sarg) ->
+      let arg = type_module true funct_body None env sarg in
+      let path = path_of_module arg in
+      let funct =
+        type_module (sttn && path <> None) funct_body None env sfunct in
+      begin match Env.scrape_alias env funct.mod_type with
+      | Mty_functor (Unit, mty_res) ->
+          if sarg.pmod_desc <> Pmod_structure [] then
+            raise (Error (sfunct.pmod_loc, env, Apply_generative));
+          if funct_body && Mtype.contains_type env funct.mod_type then
+            raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
+          { mod_desc = Tmod_apply(funct, arg, Tcoerce_none);
+            mod_type = mty_res;
+            mod_env = env;
+            mod_attributes = smod.pmod_attributes;
+            mod_loc = smod.pmod_loc }
+      | Mty_functor (Named (param, mty_param), mty_res) as mty_functor ->
+          let coercion =
+            try
+              Includemod.modtypes ~loc:sarg.pmod_loc ~mark:Mark_both env
+                arg.mod_type mty_param
+            with Includemod.Error msg ->
+              raise(Error(sarg.pmod_loc, env, Not_included msg)) in
+          let mty_appl =
+            match path with
+            | Some path ->
+                let scope = Ctype.create_scope () in
+                let subst =
+                  match param with
+                  | None -> Subst.identity
+                  | Some p -> Subst.add_module p path Subst.identity
+                in
+                Subst.modtype (Rescope scope) subst mty_res
+            | None ->
+                let env, nondep_mty =
+                  match param with
+                  | None -> env, mty_res
+                  | Some param ->
+                      let env =
+                        Env.add_module ~arg:true param Mp_present arg.mod_type
+                          env
+                      in
+                      check_well_formed_module env smod.pmod_loc
+                        "the signature of this functor application" mty_res;
+                      try env, Mtype.nondep_supertype env [param] mty_res
+                      with Ctype.Nondep_cannot_erase _ ->
+                        raise(Error(smod.pmod_loc, env,
+                                    Cannot_eliminate_dependency mty_functor))
+                in
+                begin match
+                  Includemod.modtypes ~mark:Mark_neither
+                    ~loc:smod.pmod_loc env mty_res nondep_mty
+                with
+                | Tcoerce_none -> ()
+                | _ ->
+                  fatal_error
+                    "unexpected coercion from original module type to \
+                     nondep_supertype one"
+                | exception Includemod.Error _ ->
+                  fatal_error
+                    "nondep_supertype not included in original module type"
+                end;
+                nondep_mty
+          in
+          check_well_formed_module env smod.pmod_loc
+            "the signature of this functor application" mty_appl;
+          { mod_desc = Tmod_apply(funct, arg, coercion);
+            mod_type = mty_appl;
+            mod_env = env;
+            mod_attributes = smod.pmod_attributes;
+            mod_loc = smod.pmod_loc }
+      | Mty_alias path ->
+          raise(Error(sfunct.pmod_loc, env, Cannot_scrape_alias path))
+      | _ ->
+          raise(Error(sfunct.pmod_loc, env, Cannot_apply funct.mod_type))
+      end
+  | Pmod_constraint(sarg, smty) ->
+      let arg = type_module ~alias true funct_body anchor env sarg in
+      let mty = transl_modtype env smty in
+      let md =
+        wrap_constraint env true arg mty.mty_type (Tmodtype_explicit mty)
+      in
+      { md with
+        mod_loc = smod.pmod_loc;
+        mod_attributes = smod.pmod_attributes;
+      }
+
+  | Pmod_unpack sexp ->
+      if !Clflags.principal then Ctype.begin_def ();
+      let exp = Typecore.type_exp env sexp in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        Ctype.generalize_structure exp.exp_type
+      end;
+      let mty =
+        match Ctype.expand_head env exp.exp_type with
+          {desc = Tpackage (p, nl, tl)} ->
+            if List.exists (fun t -> Ctype.free_variables t <> []) tl then
+              raise (Error (smod.pmod_loc, env,
+                            Incomplete_packed_module exp.exp_type));
+            if !Clflags.principal &&
+              not (Typecore.generalizable (Btype.generic_level-1) exp.exp_type)
+            then
+              Location.prerr_warning smod.pmod_loc
+                (Warnings.Not_principal "this module unpacking");
+            modtype_of_package env smod.pmod_loc p nl tl
+        | {desc = Tvar _} ->
+            raise (Typecore.Error
+                     (smod.pmod_loc, env, Typecore.Cannot_infer_signature))
+        | _ ->
+            raise (Error(smod.pmod_loc, env, Not_a_packed_module exp.exp_type))
+      in
+      if funct_body && Mtype.contains_type env mty then
+        raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
+      { mod_desc = Tmod_unpack(exp, mty);
+        mod_type = mty;
+        mod_env = env;
+        mod_attributes = smod.pmod_attributes;
+        mod_loc = smod.pmod_loc }
+  | Pmod_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and type_open_decl ?used_slot ?toplevel funct_body names env sod =
+  Builtin_attributes.warning_scope sod.popen_attributes
+    (fun () ->
+       type_open_decl_aux ?used_slot ?toplevel funct_body names env sod
+    )
+
+and type_open_decl_aux ?used_slot ?toplevel funct_body names env od =
+  let loc = od.popen_loc in
+  match od.popen_expr.pmod_desc with
+  | Pmod_ident lid ->
+    let path, newenv =
+      type_open_ ?used_slot ?toplevel od.popen_override env loc lid
+    in
+    let md = { mod_desc = Tmod_ident (path, lid);
+               mod_type = Mty_alias path;
+               mod_env = env;
+               mod_attributes = od.popen_expr.pmod_attributes;
+               mod_loc = od.popen_expr.pmod_loc }
+    in
+    let open_descr = {
+      open_expr = md;
+      open_bound_items = [];
+      open_override = od.popen_override;
+      open_env = newenv;
+      open_loc = loc;
+      open_attributes = od.popen_attributes
+    } in
+    open_descr, [], newenv
+  | _ ->
+    let md = type_module true funct_body None env od.popen_expr in
+    let scope = Ctype.create_scope () in
+    let sg, newenv =
+      Env.enter_signature ~scope (extract_sig_open env md.mod_loc md.mod_type)
+        env
+    in
+    let info, visibility =
+      match toplevel with
+      | Some false | None -> Some `From_open, Hidden
+      | Some true -> None, Exported
+    in
+    List.iter (Signature_names.check_sig_item ?info names loc) sg;
+    let sg =
+      List.map (function
+        | Sig_value(id, vd, _) -> Sig_value(id, vd, visibility)
+        | Sig_type(id, td, rs, _) -> Sig_type(id, td, rs, visibility)
+        | Sig_typext(id, ec, et, _) -> Sig_typext(id, ec, et, visibility)
+        | Sig_module(id, mp, md, rs, _) ->
+            Sig_module(id, mp, md, rs, visibility)
+        | Sig_modtype(id, mtd, _) -> Sig_modtype(id, mtd, visibility)
+        | Sig_class(id, cd, rs, _) -> Sig_class(id, cd, rs, visibility)
+        | Sig_class_type(id, ctd, rs, _) ->
+            Sig_class_type(id, ctd, rs, visibility)
+      ) sg
+    in
+    let open_descr = {
+      open_expr = md;
+      open_bound_items = sg;
+      open_override = od.popen_override;
+      open_env = newenv;
+      open_loc = loc;
+      open_attributes = od.popen_attributes
+    } in
+    open_descr, sg, newenv
+
+and type_structure ?(toplevel = false) funct_body anchor env sstr =
+  let names = Signature_names.create () in
+
+  let type_str_item env {pstr_loc = loc; pstr_desc = desc} =
+    match desc with
+    | Pstr_eval (sexpr, attrs) ->
+        let expr =
+          Builtin_attributes.warning_scope attrs
+            (fun () -> Typecore.type_expression env sexpr)
+        in
+        Tstr_eval (expr, attrs), [], env
+    | Pstr_value(rec_flag, sdefs) ->
+        let (defs, newenv) =
+          Typecore.type_binding env rec_flag sdefs in
+        let () = if rec_flag = Recursive then
+          Typecore.check_recursive_bindings env defs
+        in
+        (* Note: Env.find_value does not trigger the value_used event. Values
+           will be marked as being used during the signature inclusion test. *)
+        Tstr_value(rec_flag, defs),
+        List.map (fun (id, { Asttypes.loc; _ }, _typ)->
+          Signature_names.check_value names loc id;
+          Sig_value(id, Env.find_value (Pident id) newenv, Exported)
+        ) (let_bound_idents_full defs),
+        newenv
+    | Pstr_primitive sdesc ->
+        let (desc, newenv) = Typedecl.transl_value_decl env loc sdesc in
+        Signature_names.check_value names desc.val_loc desc.val_id;
+        Tstr_primitive desc,
+        [Sig_value(desc.val_id, desc.val_val, Exported)],
+        newenv
+    | Pstr_type (rec_flag, sdecls) ->
+        let (decls, newenv) = Typedecl.transl_type_decl env rec_flag sdecls in
+        List.iter
+          Signature_names.(fun td -> check_type names td.typ_loc td.typ_id)
+          decls;
+        Tstr_type (rec_flag, decls),
+        map_rec_type_with_row_types ~rec_flag
+          (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs, Exported))
+          decls [],
+        enrich_type_decls anchor decls env newenv
+    | Pstr_typext styext ->
+        let (tyext, newenv) =
+          Typedecl.transl_type_extension true env loc styext
+        in
+        let constructors = tyext.tyext_constructors in
+        List.iter
+          Signature_names.(fun ext -> check_typext names ext.ext_loc ext.ext_id)
+          constructors;
+        (Tstr_typext tyext,
+         map_ext
+           (fun es ext -> Sig_typext(ext.ext_id, ext.ext_type, es, Exported))
+           constructors [],
+         newenv)
+    | Pstr_exception sext ->
+        let (ext, newenv) = Typedecl.transl_type_exception env sext in
+        let constructor = ext.tyexn_constructor in
+        Signature_names.check_typext names constructor.ext_loc
+          constructor.ext_id;
+        Tstr_exception ext,
+        [Sig_typext(constructor.ext_id,
+                    constructor.ext_type,
+                    Text_exception,
+                    Exported)],
+        newenv
+    | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs;
+                   pmb_loc;
+                  } ->
+        let outer_scope = Ctype.get_current_level () in
+        let scope = Ctype.create_scope () in
+        let modl =
+          Builtin_attributes.warning_scope attrs
+            (fun () ->
+               type_module ~alias:true true funct_body
+                 (anchor_submodule name.txt anchor) env smodl
+            )
+        in
+        let pres =
+          match modl.mod_type with
+          | Mty_alias _ -> Mp_absent
+          | _ -> Mp_present
+        in
+        let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in
+        let md =
+          { md_type = enrich_module_type anchor name.txt modl.mod_type env;
+            md_attributes = attrs;
+            md_loc = pmb_loc;
+            md_uid;
+          }
+        in
+        (*prerr_endline (Ident.unique_toplevel_name id);*)
+        Mtype.lower_nongen outer_scope md.md_type;
+        let id, newenv, sg =
+          match name.txt with
+          | None -> None, env, []
+          | Some name ->
+            let id, e = Env.enter_module_declaration ~scope name pres md env in
+            Signature_names.check_module names pmb_loc id;
+            Some id, e,
+            [Sig_module(id, pres,
+                        {md_type = modl.mod_type;
+                         md_attributes = attrs;
+                         md_loc = pmb_loc;
+                         md_uid;
+                        }, Trec_not, Exported)]
+        in
+        Tstr_module {mb_id=id; mb_name=name; mb_expr=modl;
+                     mb_presence=pres; mb_attributes=attrs;  mb_loc=pmb_loc; },
+        sg,
+        newenv
+    | Pstr_recmodule sbind ->
+        let sbind =
+          List.map
+            (function
+              | {pmb_name = name;
+                 pmb_expr = {pmod_desc=Pmod_constraint(expr, typ)};
+                 pmb_attributes = attrs;
+                 pmb_loc = loc;
+                } ->
+                  name, typ, expr, attrs, loc
+              | mb ->
+                  raise (Error (mb.pmb_expr.pmod_loc, env,
+                                Recursive_module_require_explicit_type))
+            )
+            sbind
+        in
+        let (decls, newenv) =
+          transl_recmodule_modtypes env
+            (List.map (fun (name, smty, _smodl, attrs, loc) ->
+                 {pmd_name=name; pmd_type=smty;
+                  pmd_attributes=attrs; pmd_loc=loc}) sbind
+            ) in
+        List.iter
+          (fun (md, _) ->
+            Option.iter Signature_names.(check_module names md.md_loc) md.md_id)
+          decls;
+        let bindings1 =
+          List.map2
+            (fun ({md_id=id; md_type=mty}, uid) (name, _, smodl, attrs, loc) ->
+               let modl =
+                 Builtin_attributes.warning_scope attrs
+                   (fun () ->
+                      type_module true funct_body (anchor_recmodule id)
+                        newenv smodl
+                   )
+               in
+               let mty' =
+                 enrich_module_type anchor name.txt modl.mod_type newenv
+               in
+               (id, name, mty, modl, mty', attrs, loc, uid))
+            decls sbind in
+        let newenv = (* allow aliasing recursive modules from outside *)
+          List.fold_left
+            (fun env (md, uid) ->
+               match md.md_id with
+               | None -> env
+               | Some id ->
+                   let mdecl =
+                     {
+                       md_type = md.md_type.mty_type;
+                       md_attributes = md.md_attributes;
+                       md_loc = md.md_loc;
+                       md_uid = uid;
+                     }
+                   in
+                   Env.add_module_declaration ~check:true
+                     id Mp_present mdecl env
+            )
+            env decls
+        in
+        let bindings2 =
+          check_recmodule_inclusion newenv bindings1 in
+        let mbs =
+          List.filter_map (fun (mb, uid) ->
+            Option.map (fun id -> id, mb, uid)  mb.mb_id
+          ) bindings2
+        in
+        Tstr_recmodule (List.map fst bindings2),
+        map_rec (fun rs (id, mb, uid) ->
+            Sig_module(id, Mp_present, {
+                md_type=mb.mb_expr.mod_type;
+                md_attributes=mb.mb_attributes;
+                md_loc=mb.mb_loc;
+                md_uid = uid;
+              }, rs, Exported))
+           mbs [],
+        newenv
+    | Pstr_modtype pmtd ->
+        (* check that it is non-abstract *)
+        let newenv, mtd, sg = transl_modtype_decl names env pmtd in
+        Tstr_modtype mtd, [sg], newenv
+    | Pstr_open sod ->
+        let (od, sg, newenv) =
+          type_open_decl ~toplevel funct_body names env sod
+        in
+        Tstr_open od, sg, newenv
+    | Pstr_class cl ->
+        let (classes, new_env) = Typeclass.class_declarations env cl in
+        List.iter (fun cls ->
+          let open Typeclass in
+          let loc = cls.cls_id_loc.Location.loc in
+          Signature_names.check_class names loc cls.cls_id;
+          Signature_names.check_class_type names loc cls.cls_ty_id;
+          Signature_names.check_type names loc cls.cls_obj_id;
+          Signature_names.check_type names loc cls.cls_typesharp_id;
+        ) classes;
+        Tstr_class
+          (List.map (fun cls ->
+               (cls.Typeclass.cls_info,
+                cls.Typeclass.cls_pub_methods)) classes),
+(* TODO: check with Jacques why this is here
+      Tstr_class_type
+          (List.map (fun (_,_, i, d, _,_,_,_,_,_,c) -> (i, c)) classes) ::
+      Tstr_type
+          (List.map (fun (_,_,_,_, i, d, _,_,_,_,_) -> (i, d)) classes) ::
+      Tstr_type
+          (List.map (fun (_,_,_,_,_,_, i, d, _,_,_) -> (i, d)) classes) ::
+*)
+        List.flatten
+          (map_rec
+            (fun rs cls ->
+              let open Typeclass in
+              [Sig_class(cls.cls_id, cls.cls_decl, rs, Exported);
+               Sig_class_type(cls.cls_ty_id, cls.cls_ty_decl, rs, Exported);
+               Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs, Exported);
+               Sig_type(cls.cls_typesharp_id, cls.cls_abbr, rs, Exported)])
+             classes []),
+        new_env
+    | Pstr_class_type cl ->
+        let (classes, new_env) = Typeclass.class_type_declarations env cl in
+        List.iter (fun decl ->
+          let open Typeclass in
+          let loc = decl.clsty_id_loc.Location.loc in
+          Signature_names.check_class_type names loc decl.clsty_ty_id;
+          Signature_names.check_type names loc decl.clsty_obj_id;
+          Signature_names.check_type names loc decl.clsty_typesharp_id;
+        ) classes;
+        Tstr_class_type
+          (List.map (fun cl ->
+               (cl.Typeclass.clsty_ty_id,
+                cl.Typeclass.clsty_id_loc,
+                cl.Typeclass.clsty_info)) classes),
+(*  TODO: check with Jacques why this is here
+           Tstr_type
+             (List.map (fun (_, _, i, d, _, _) -> (i, d)) classes) ::
+           Tstr_type
+             (List.map (fun (_, _, _, _, i, d) -> (i, d)) classes) :: *)
+        List.flatten
+          (map_rec
+             (fun rs decl ->
+                let open Typeclass in
+                [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs,
+                                Exported);
+                 Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs, Exported);
+                 Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs,
+                          Exported)
+                ])
+             classes []),
+        new_env
+    | Pstr_include sincl ->
+        let smodl = sincl.pincl_mod in
+        let modl =
+          Builtin_attributes.warning_scope sincl.pincl_attributes
+            (fun () -> type_module true funct_body None env smodl)
+        in
+        let scope = Ctype.create_scope () in
+        (* Rename all identifiers bound by this signature to avoid clashes *)
+        let sg, new_env = Env.enter_signature ~scope
+            (extract_sig_open env smodl.pmod_loc modl.mod_type) env in
+        List.iter (Signature_names.check_sig_item names loc) sg;
+        let incl =
+          { incl_mod = modl;
+            incl_type = sg;
+            incl_attributes = sincl.pincl_attributes;
+            incl_loc = sincl.pincl_loc;
+          }
+        in
+        Tstr_include incl, sg, new_env
+    | Pstr_extension (ext, _attrs) ->
+        raise (Error_forward (Builtin_attributes.error_of_extension ext))
+    | Pstr_attribute x ->
+        Builtin_attributes.warning_attribute x;
+        Tstr_attribute x, [], env
+  in
+  let rec type_struct env sstr =
+    match sstr with
+    | [] -> ([], [], env)
+    | pstr :: srem ->
+        let previous_saved_types = Cmt_format.get_saved_types () in
+        let desc, sg, new_env = type_str_item env pstr in
+        let str = { str_desc = desc; str_loc = pstr.pstr_loc; str_env = env } in
+        Cmt_format.set_saved_types (Cmt_format.Partial_structure_item str
+                                    :: previous_saved_types);
+        let (str_rem, sig_rem, final_env) = type_struct new_env srem in
+        (str :: str_rem, sg @ sig_rem, final_env)
+  in
+  let previous_saved_types = Cmt_format.get_saved_types () in
+  let run () =
+    let (items, sg, final_env) = type_struct env sstr in
+    let str = { str_items = items; str_type = sg; str_final_env = final_env } in
+    Cmt_format.set_saved_types
+      (Cmt_format.Partial_structure str :: previous_saved_types);
+    str, sg, names, final_env
+  in
+  if toplevel then run ()
+  else Builtin_attributes.warning_scope [] run
+
+let type_toplevel_phrase env s =
+  Env.reset_required_globals ();
+  let (str, sg, to_remove_from_sg, env) =
+    type_structure ~toplevel:true false None env s in
+  (str, sg, to_remove_from_sg, env)
+
+let type_module_alias = type_module ~alias:true true false None
+let type_module = type_module true false None
+let type_structure = type_structure false None
+
+(* Normalize types in a signature *)
+
+let rec normalize_modtype = function
+    Mty_ident _
+  | Mty_alias _ -> ()
+  | Mty_signature sg -> normalize_signature sg
+  | Mty_functor(_param, body) -> normalize_modtype body
+
+and normalize_signature sg = List.iter normalize_signature_item sg
+
+and normalize_signature_item = function
+    Sig_value(_id, desc, _) -> Ctype.normalize_type desc.val_type
+  | Sig_module(_id, _, md, _, _) -> normalize_modtype md.md_type
+  | _ -> ()
+
+(* Extract the module type of a module expression *)
+
+let type_module_type_of env smod =
+  let remove_aliases = has_remove_aliases_attribute smod.pmod_attributes in
+  let tmty =
+    match smod.pmod_desc with
+    | Pmod_ident lid -> (* turn off strengthening in this case *)
+        let path, md = Env.lookup_module ~loc:smod.pmod_loc lid.txt env in
+          { mod_desc = Tmod_ident (path, lid);
+            mod_type = md.md_type;
+            mod_env = env;
+            mod_attributes = smod.pmod_attributes;
+            mod_loc = smod.pmod_loc }
+    | _ -> type_module env smod
+  in
+  let mty = Mtype.scrape_for_type_of ~remove_aliases env tmty.mod_type in
+  (* PR#5036: must not contain non-generalized type variables *)
+  if not (closed_modtype env mty) then
+    raise(Error(smod.pmod_loc, env, Non_generalizable_module mty));
+  tmty, mty
+
+(* For Typecore *)
+
+(* Graft a longident onto a path *)
+let rec extend_path path =
+  fun lid ->
+    match lid with
+    | Lident name -> Pdot(path, name)
+    | Ldot(m, name) -> Pdot(extend_path path m, name)
+    | Lapply _ -> assert false
+
+(* Lookup a type's longident within a signature *)
+let lookup_type_in_sig sg =
+  let types, modules =
+    List.fold_left
+      (fun acc item ->
+         match item with
+         | Sig_type(id, _, _, _) ->
+             let types, modules = acc in
+             let types = String.Map.add (Ident.name id) id types in
+             types, modules
+         | Sig_module(id, _, _, _, _) ->
+             let types, modules = acc in
+             let modules = String.Map.add (Ident.name id) id modules in
+             types, modules
+         | _ -> acc)
+      (String.Map.empty, String.Map.empty) sg
+  in
+  let rec module_path = function
+    | Lident name -> Pident (String.Map.find name modules)
+    | Ldot(m, name) -> Pdot(module_path m, name)
+    | Lapply _ -> assert false
+  in
+  fun lid ->
+    match lid with
+    | Lident name -> Pident (String.Map.find name types)
+    | Ldot(m, name) -> Pdot(module_path m, name)
+    | Lapply _ -> assert false
+
+let type_package env m p nl =
+  (* Same as Pexp_letmodule *)
+  (* remember original level *)
+  Ctype.begin_def ();
+  let context = Typetexp.narrow () in
+  let modl = type_module env m in
+  let scope = Ctype.create_scope () in
+  Typetexp.widen context;
+  let nl', tl', env =
+    match nl with
+    | [] -> [], [], env
+    | nl ->
+      let type_path, env =
+        match modl.mod_desc with
+        | Tmod_ident (mp,_)
+        | Tmod_constraint
+            ({mod_desc=Tmod_ident (mp,_)}, _, Tmodtype_implicit, _) ->
+          (* We special case these because interactions between
+             strengthening of module types and packages can cause
+             spurious escape errors. See examples from PR#6982 in the
+             testsuite. This can be removed when such issues are
+             fixed. *)
+          extend_path mp, env
+        | _ ->
+          let sg = extract_sig_open env modl.mod_loc modl.mod_type in
+          let sg, env = Env.enter_signature ~scope sg env in
+          lookup_type_in_sig sg, env
+      in
+      let nl', tl' =
+        List.fold_right
+          (fun lid (nl, tl) ->
+             match type_path lid with
+             | exception Not_found -> (nl, tl)
+             | path -> begin
+                 match Env.find_type path env with
+                 | exception Not_found -> (nl, tl)
+                 | decl ->
+                     if decl.type_arity > 0 then begin
+                       (nl, tl)
+                     end else begin
+                       let t = Btype.newgenty (Tconstr (path,[],ref Mnil)) in
+                       (lid :: nl, t :: tl)
+                     end
+               end)
+          nl ([], [])
+      in
+      nl', tl', env
+  in
+  (* go back to original level *)
+  Ctype.end_def ();
+  let mty =
+    if nl = [] then (Mty_ident p)
+    else modtype_of_package env modl.mod_loc p nl' tl'
+  in
+  List.iter2
+    (fun n ty ->
+      try Ctype.unify env ty (Ctype.newvar ())
+      with Ctype.Unify _ ->
+        raise (Error(modl.mod_loc, env, Scoping_pack (n,ty))))
+    nl' tl';
+  let modl = wrap_constraint env true modl mty Tmodtype_implicit in
+  (* Dropped exports should have produced an error above *)
+  assert (List.length nl = List.length tl');
+  modl, tl'
+
+(* Fill in the forward declarations *)
+
+let type_open_decl ?used_slot env od =
+  type_open_decl ?used_slot ?toplevel:None false (Signature_names.create ()) env
+    od
+
+let type_open_descr ?used_slot env od =
+  type_open_descr ?used_slot ?toplevel:None env od
+
+let () =
+  Typecore.type_module := type_module_alias;
+  Typetexp.transl_modtype_longident := transl_modtype_longident;
+  Typetexp.transl_modtype := transl_modtype;
+  Typecore.type_open := type_open_ ?toplevel:None;
+  Typecore.type_open_decl := type_open_decl;
+  Typecore.type_package := type_package;
+  Typeclass.type_open_descr := type_open_descr;
+  type_module_type_of_fwd := type_module_type_of
+
+
+(* Typecheck an implementation file *)
+
+let gen_annot outputprefix sourcefile annots =
+  Cmt2annot.gen_annot (Some (outputprefix ^ ".annot"))
+    ~sourcefile:(Some sourcefile) ~use_summaries:false annots
+
+let type_implementation sourcefile outputprefix modulename initial_env ast =
+  Cmt_format.clear ();
+  Misc.try_finally (fun () ->
+      Typecore.reset_delayed_checks ();
+      Env.reset_required_globals ();
+      if !Clflags.print_types then (* #7656 *)
+        Warnings.parse_options false "-32-34-37-38-60";
+      let (str, sg, names, finalenv) =
+        type_structure initial_env ast in
+      let simple_sg = Signature_names.simplify finalenv names sg in
+      if !Clflags.print_types then begin
+        Typecore.force_delayed_checks ();
+        Printtyp.wrap_printing_env ~error:false initial_env
+          (fun () -> fprintf std_formatter "%a@."
+              (Printtyp.printed_signature sourcefile) simple_sg
+          );
+        gen_annot outputprefix sourcefile (Cmt_format.Implementation str);
+        (str, Tcoerce_none)   (* result is ignored by Compile.implementation *)
+      end else begin
+        let sourceintf =
+          Filename.remove_extension sourcefile ^ !Config.interface_suffix in
+        if Sys.file_exists sourceintf then begin
+          let intf_file =
+            try
+              Load_path.find_uncap (modulename ^ ".cmi")
+            with Not_found ->
+              raise(Error(Location.in_file sourcefile, Env.empty,
+                          Interface_not_compiled sourceintf)) in
+          let dclsig = Env.read_signature modulename intf_file in
+          let coercion =
+            Includemod.compunit initial_env ~mark:Mark_positive
+              sourcefile sg intf_file dclsig
+          in
+          Typecore.force_delayed_checks ();
+          (* It is important to run these checks after the inclusion test above,
+             so that value declarations which are not used internally but
+             exported are not reported as being unused. *)
+          let annots = Cmt_format.Implementation str in
+          Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename
+            annots (Some sourcefile) initial_env None;
+          gen_annot outputprefix sourcefile annots;
+          (str, coercion)
+        end else begin
+          let coercion =
+            Includemod.compunit initial_env ~mark:Mark_positive
+              sourcefile sg "(inferred signature)" simple_sg
+          in
+          check_nongen_schemes finalenv simple_sg;
+          normalize_signature simple_sg;
+          Typecore.force_delayed_checks ();
+          (* See comment above. Here the target signature contains all
+             the value being exported. We can still capture unused
+             declarations like "let x = true;; let x = 1;;", because in this
+             case, the inferred signature contains only the last declaration. *)
+          if not !Clflags.dont_write_files then begin
+            let alerts = Builtin_attributes.alerts_of_str ast in
+            let cmi =
+              Env.save_signature ~alerts
+                simple_sg modulename (outputprefix ^ ".cmi")
+            in
+            let annots = Cmt_format.Implementation str in
+            Cmt_format.save_cmt  (outputprefix ^ ".cmt") modulename
+              annots (Some sourcefile) initial_env (Some cmi);
+            gen_annot outputprefix sourcefile annots
+          end;
+          (str, coercion)
+        end
+      end
+    )
+    ~exceptionally:(fun () ->
+        let annots =
+          Cmt_format.Partial_implementation
+            (Array.of_list (Cmt_format.get_saved_types ()))
+        in
+        Cmt_format.save_cmt  (outputprefix ^ ".cmt") modulename
+          annots (Some sourcefile) initial_env None;
+        gen_annot outputprefix sourcefile annots
+      )
+
+let save_signature modname tsg outputprefix source_file initial_env cmi =
+  Cmt_format.save_cmt  (outputprefix ^ ".cmti") modname
+    (Cmt_format.Interface tsg) (Some source_file) initial_env (Some cmi)
+
+let type_interface env ast =
+  transl_signature env ast
+
+(* "Packaging" of several compilation units into one unit
+   having them as sub-modules.  *)
+
+let package_signatures units =
+  let units_with_ids =
+    List.map
+      (fun (name, sg) ->
+        let oldid = Ident.create_persistent name in
+        let newid = Ident.create_local name in
+        (oldid, newid, sg))
+      units
+  in
+  let subst =
+    List.fold_left
+      (fun acc (oldid, newid, _) ->
+        Subst.add_module oldid (Pident newid) acc)
+      Subst.identity units_with_ids
+  in
+  List.map
+    (fun (_, newid, sg) ->
+      (* This signature won't be used for anything, it'll just be saved in a cmi
+         and cmt. *)
+      let sg = Subst.signature Make_local subst sg in
+      let md =
+        { md_type=Mty_signature sg;
+          md_attributes=[];
+          md_loc=Location.none;
+          md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+        }
+      in
+      Sig_module(newid, Mp_present, md, Trec_not, Exported))
+    units_with_ids
+
+let package_units initial_env objfiles cmifile modulename =
+  (* Read the signatures of the units *)
+  let units =
+    List.map
+      (fun f ->
+         let pref = chop_extensions f in
+         let modname = String.capitalize_ascii(Filename.basename pref) in
+         let sg = Env.read_signature modname (pref ^ ".cmi") in
+         if Filename.check_suffix f ".cmi" &&
+            not(Mtype.no_code_needed_sig Env.initial_safe_string sg)
+         then raise(Error(Location.none, Env.empty,
+                          Implementation_is_required f));
+         (modname, Env.read_signature modname (pref ^ ".cmi")))
+      objfiles in
+  (* Compute signature of packaged unit *)
+  Ident.reinit();
+  let sg = package_signatures units in
+  (* See if explicit interface is provided *)
+  let prefix = Filename.remove_extension cmifile in
+  let mlifile = prefix ^ !Config.interface_suffix in
+  if Sys.file_exists mlifile then begin
+    if not (Sys.file_exists cmifile) then begin
+      raise(Error(Location.in_file mlifile, Env.empty,
+                  Interface_not_compiled mlifile))
+    end;
+    let dclsig = Env.read_signature modulename cmifile in
+    Cmt_format.save_cmt  (prefix ^ ".cmt") modulename
+      (Cmt_format.Packed (sg, objfiles)) None initial_env  None ;
+    Includemod.compunit initial_env ~mark:Mark_both
+      "(obtained by packing)" sg mlifile dclsig
+  end else begin
+    (* Determine imports *)
+    let unit_names = List.map fst units in
+    let imports =
+      List.filter
+        (fun (name, _crc) -> not (List.mem name unit_names))
+        (Env.imports()) in
+    (* Write packaged signature *)
+    if not !Clflags.dont_write_files then begin
+      let cmi =
+        Env.save_signature_with_imports ~alerts:Misc.Stdlib.String.Map.empty
+          sg modulename
+          (prefix ^ ".cmi") imports
+      in
+      Cmt_format.save_cmt (prefix ^ ".cmt")  modulename
+        (Cmt_format.Packed (cmi.Cmi_format.cmi_sign, objfiles)) None initial_env
+        (Some cmi)
+    end;
+    Tcoerce_none
+  end
+
+(* Error report *)
+
+open Printtyp
+
+let report_error ppf = function
+    Cannot_apply mty ->
+      fprintf ppf
+        "@[This module is not a functor; it has type@ %a@]" modtype mty
+  | Not_included errs ->
+      fprintf ppf
+        "@[<v>Signature mismatch:@ %a@]" Includemod.report_error errs
+  | Cannot_eliminate_dependency mty ->
+      fprintf ppf
+        "@[This functor has type@ %a@ \
+           The parameter cannot be eliminated in the result type.@ \
+           Please bind the argument to a module identifier.@]" modtype mty
+  | Signature_expected -> fprintf ppf "This module type is not a signature"
+  | Structure_expected mty ->
+      fprintf ppf
+        "@[This module is not a structure; it has type@ %a" modtype mty
+  | With_no_component lid ->
+      fprintf ppf
+        "@[The signature constrained by `with' has no component named %a@]"
+        longident lid
+  | With_mismatch(lid, explanation) ->
+      fprintf ppf
+        "@[<v>\
+           @[In this `with' constraint, the new definition of %a@ \
+             does not match its original definition@ \
+             in the constrained signature:@]@ \
+           %a@]"
+        longident lid Includemod.report_error explanation
+  | With_makes_applicative_functor_ill_typed(lid, path, explanation) ->
+      fprintf ppf
+        "@[<v>\
+           @[This `with' constraint on %a makes the applicative functor @ \
+             type %s ill-typed in the constrained signature:@]@ \
+           %a@]"
+        longident lid (Path.name path) Includemod.report_error explanation
+  | With_changes_module_alias(lid, id, path) ->
+      fprintf ppf
+        "@[<v>\
+           @[This `with' constraint on %a changes %s, which is aliased @ \
+             in the constrained signature (as %s)@].@]"
+        longident lid (Path.name path) (Ident.name id)
+  | With_cannot_remove_constrained_type ->
+      fprintf ppf
+        "@[<v>Destructive substitutions are not supported for constrained @ \
+              types (other than when replacing a type constructor with @ \
+              a type constructor with the same arguments).@]"
+  | Repeated_name(kind, name) ->
+      fprintf ppf
+        "@[Multiple definition of the %s name %s.@ \
+         Names must be unique in a given structure or signature.@]"
+        (Sig_component_kind.to_string kind) name
+  | Non_generalizable typ ->
+      fprintf ppf
+        "@[The type of this expression,@ %a,@ \
+           contains type variables that cannot be generalized@]" type_scheme typ
+  | Non_generalizable_class (id, desc) ->
+      fprintf ppf
+        "@[The type of this class,@ %a,@ \
+           contains type variables that cannot be generalized@]"
+        (class_declaration id) desc
+  | Non_generalizable_module mty ->
+      fprintf ppf
+        "@[The type of this module,@ %a,@ \
+           contains type variables that cannot be generalized@]" modtype mty
+  | Implementation_is_required intf_name ->
+      fprintf ppf
+        "@[The interface %a@ declares values, not just types.@ \
+           An implementation must be provided.@]"
+        Location.print_filename intf_name
+  | Interface_not_compiled intf_name ->
+      fprintf ppf
+        "@[Could not find the .cmi file for interface@ %a.@]"
+        Location.print_filename intf_name
+  | Not_allowed_in_functor_body ->
+      fprintf ppf
+        "@[This expression creates fresh types.@ %s@]"
+        "It is not allowed inside applicative functors."
+  | Not_a_packed_module ty ->
+      fprintf ppf
+        "This expression is not a packed module. It has type@ %a"
+        type_expr ty
+  | Incomplete_packed_module ty ->
+      fprintf ppf
+        "The type of this packed module contains variables:@ %a"
+        type_expr ty
+  | Scoping_pack (lid, ty) ->
+      fprintf ppf
+        "The type %a in this module cannot be exported.@ " longident lid;
+      fprintf ppf
+        "Its type contains local dependencies:@ %a" type_expr ty
+  | Recursive_module_require_explicit_type ->
+      fprintf ppf "Recursive modules require an explicit module type."
+  | Apply_generative ->
+      fprintf ppf "This is a generative functor. It can only be applied to ()"
+  | Cannot_scrape_alias p ->
+      fprintf ppf
+        "This is an alias for module %a, which is missing"
+        path p
+  | Cannot_scrape_package_type p ->
+      fprintf ppf
+        "The type of this packed module refers to %a, which is missing"
+        path p
+  | Badly_formed_signature (context, err) ->
+      fprintf ppf "@[In %s:@ %a@]" context Typedecl.report_error err
+  | Cannot_hide_id Illegal_shadowing
+      { shadowed_item_kind; shadowed_item_id; shadowed_item_loc;
+        shadower_id; user_id; user_kind; user_loc } ->
+      let shadowed_item_kind= Sig_component_kind.to_string shadowed_item_kind in
+      fprintf ppf
+        "@[<v>Illegal shadowing of included %s %a by %a@ \
+         %a:@;<1 2>%s %a came from this include@ \
+         %a:@;<1 2>The %s %s has no valid type if %a is shadowed@]"
+        shadowed_item_kind Ident.print shadowed_item_id Ident.print shadower_id
+        Location.print_loc shadowed_item_loc
+        (String.capitalize_ascii shadowed_item_kind)
+        Ident.print shadowed_item_id
+        Location.print_loc user_loc
+        (Sig_component_kind.to_string user_kind) (Ident.name user_id)
+        Ident.print shadowed_item_id
+  | Cannot_hide_id Appears_in_signature
+      { opened_item_kind; opened_item_id; user_id; user_kind; user_loc } ->
+      let opened_item_kind= Sig_component_kind.to_string opened_item_kind in
+      fprintf ppf
+        "@[<v>The %s %a introduced by this open appears in the signature@ \
+         %a:@;<1 2>The %s %s has no valid type if %a is hidden@]"
+        opened_item_kind Ident.print opened_item_id
+        Location.print_loc user_loc
+        (Sig_component_kind.to_string user_kind) (Ident.name user_id)
+        Ident.print opened_item_id
+  | Invalid_type_subst_rhs ->
+      fprintf ppf "Only type synonyms are allowed on the right of :="
+
+let report_error env ppf err =
+  Printtyp.wrap_printing_env ~error:true env (fun () -> report_error ppf err)
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, env, err) ->
+        Some (Location.error_of_printer ~loc (report_error env) err)
+      | Error_forward err ->
+        Some err
+      | _ ->
+        None
+    )
diff --git a/upstream/ocaml_412/typing/typemod.mli b/upstream/ocaml_412/typing/typemod.mli
new file mode 100644
index 0000000..c24aa5e
--- /dev/null
+++ b/upstream/ocaml_412/typing/typemod.mli
@@ -0,0 +1,138 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Type-checking of the module language and typed ast hooks
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Types
+open Format
+
+module Signature_names : sig
+  type t
+
+  val simplify: Env.t -> t -> signature -> signature
+end
+
+val type_module:
+        Env.t -> Parsetree.module_expr -> Typedtree.module_expr
+val type_structure:
+  Env.t -> Parsetree.structure ->
+  Typedtree.structure * Types.signature * Signature_names.t * Env.t
+val type_toplevel_phrase:
+  Env.t -> Parsetree.structure ->
+  Typedtree.structure * Types.signature * Signature_names.t * Env.t
+val type_implementation:
+  string -> string -> string -> Env.t -> Parsetree.structure ->
+  Typedtree.structure * Typedtree.module_coercion
+val type_interface:
+        Env.t -> Parsetree.signature -> Typedtree.signature
+val transl_signature:
+        Env.t -> Parsetree.signature -> Typedtree.signature
+val check_nongen_schemes:
+        Env.t -> Types.signature -> unit
+        (*
+val type_open_:
+        ?used_slot:bool ref -> ?toplevel:bool ->
+        Asttypes.override_flag ->
+        Env.t -> Location.t -> Longident.t Asttypes.loc -> Path.t * Env.t
+        *)
+val modtype_of_package:
+        Env.t -> Location.t ->
+        Path.t -> Longident.t list -> type_expr list -> module_type
+
+val path_of_module : Typedtree.module_expr -> Path.t option
+
+val save_signature:
+  string -> Typedtree.signature -> string -> string ->
+  Env.t -> Cmi_format.cmi_infos -> unit
+
+val package_units:
+  Env.t -> string list -> string -> string -> Typedtree.module_coercion
+
+(* Should be in Envaux, but it breaks the build of the debugger *)
+val initial_env:
+  loc:Location.t -> safe_string:bool ->
+  initially_opened_module:string option ->
+  open_implicit_modules:string list -> Env.t
+
+module Sig_component_kind : sig
+  type t =
+    | Value
+    | Type
+    | Module
+    | Module_type
+    | Extension_constructor
+    | Class
+    | Class_type
+
+  val to_string : t -> string
+end
+
+type hiding_error =
+  | Illegal_shadowing of {
+      shadowed_item_id: Ident.t;
+      shadowed_item_kind: Sig_component_kind.t;
+      shadowed_item_loc: Location.t;
+      shadower_id: Ident.t;
+      user_id: Ident.t;
+      user_kind: Sig_component_kind.t;
+      user_loc: Location.t;
+    }
+  | Appears_in_signature of {
+      opened_item_id: Ident.t;
+      opened_item_kind: Sig_component_kind.t;
+      user_id: Ident.t;
+      user_kind: Sig_component_kind.t;
+      user_loc: Location.t;
+    }
+
+type error =
+    Cannot_apply of module_type
+  | Not_included of Includemod.error list
+  | Cannot_eliminate_dependency of module_type
+  | Signature_expected
+  | Structure_expected of module_type
+  | With_no_component of Longident.t
+  | With_mismatch of Longident.t * Includemod.error list
+  | With_makes_applicative_functor_ill_typed of
+      Longident.t * Path.t * Includemod.error list
+  | With_changes_module_alias of Longident.t * Ident.t * Path.t
+  | With_cannot_remove_constrained_type
+  | Repeated_name of Sig_component_kind.t * string
+  | Non_generalizable of type_expr
+  | Non_generalizable_class of Ident.t * class_declaration
+  | Non_generalizable_module of module_type
+  | Implementation_is_required of string
+  | Interface_not_compiled of string
+  | Not_allowed_in_functor_body
+  | Not_a_packed_module of type_expr
+  | Incomplete_packed_module of type_expr
+  | Scoping_pack of Longident.t * type_expr
+  | Recursive_module_require_explicit_type
+  | Apply_generative
+  | Cannot_scrape_alias of Path.t
+  | Cannot_scrape_package_type of Path.t
+  | Badly_formed_signature of string * Typedecl.error
+  | Cannot_hide_id of hiding_error
+  | Invalid_type_subst_rhs
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+val report_error: Env.t -> formatter -> error -> unit
diff --git a/upstream/ocaml_412/typing/typeopt.ml b/upstream/ocaml_412/typing/typeopt.ml
new file mode 100644
index 0000000..8ca209a
--- /dev/null
+++ b/upstream/ocaml_412/typing/typeopt.ml
@@ -0,0 +1,215 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Auxiliaries for type-based optimizations, e.g. array kinds *)
+
+open Path
+open Types
+open Asttypes
+open Typedtree
+open Lambda
+
+let scrape_ty env ty =
+  let ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in
+  match ty.desc with
+  | Tconstr (p, _, _) ->
+      begin match Env.find_type p env with
+      | {type_unboxed = {unboxed = true; _}; _} ->
+        begin match Typedecl.get_unboxed_type_representation env ty with
+        | None -> ty
+        | Some ty2 -> ty2
+        end
+      | _ -> ty
+      | exception Not_found -> ty
+      end
+  | _ -> ty
+
+let scrape env ty =
+  (scrape_ty env ty).desc
+
+let is_function_type env ty =
+  match scrape env ty with
+  | Tarrow (_, lhs, rhs, _) -> Some (lhs, rhs)
+  | _ -> None
+
+let is_base_type env ty base_ty_path =
+  match scrape env ty with
+  | Tconstr(p, _, _) -> Path.same p base_ty_path
+  | _ -> false
+
+let maybe_pointer_type env ty =
+  let ty = scrape_ty env ty in
+  if Ctype.maybe_pointer_type env ty then
+    Pointer
+  else
+    Immediate
+
+let maybe_pointer exp = maybe_pointer_type exp.exp_env exp.exp_type
+
+type classification =
+  | Int
+  | Float
+  | Lazy
+  | Addr  (* anything except a float or a lazy *)
+  | Any
+
+let classify env ty =
+  let ty = scrape_ty env ty in
+  if maybe_pointer_type env ty = Immediate then Int
+  else match ty.desc with
+  | Tvar _ | Tunivar _ ->
+      Any
+  | Tconstr (p, _args, _abbrev) ->
+      if Path.same p Predef.path_float then Float
+      else if Path.same p Predef.path_lazy_t then Lazy
+      else if Path.same p Predef.path_string
+           || Path.same p Predef.path_bytes
+           || Path.same p Predef.path_array
+           || Path.same p Predef.path_nativeint
+           || Path.same p Predef.path_int32
+           || Path.same p Predef.path_int64 then Addr
+      else begin
+        try
+          match (Env.find_type p env).type_kind with
+          | Type_abstract ->
+              Any
+          | Type_record _ | Type_variant _ | Type_open ->
+              Addr
+        with Not_found ->
+          (* This can happen due to e.g. missing -I options,
+             causing some .cmi files to be unavailable.
+             Maybe we should emit a warning. *)
+          Any
+      end
+  | Tarrow _ | Ttuple _ | Tpackage _ | Tobject _ | Tnil | Tvariant _ ->
+      Addr
+  | Tlink _ | Tsubst _ | Tpoly _ | Tfield _ ->
+      assert false
+
+let array_type_kind env ty =
+  match scrape env ty with
+  | Tconstr(p, [elt_ty], _) | Tpoly({desc = Tconstr(p, [elt_ty], _)}, _)
+    when Path.same p Predef.path_array ->
+      begin match classify env elt_ty with
+      | Any -> if Config.flat_float_array then Pgenarray else Paddrarray
+      | Float -> if Config.flat_float_array then Pfloatarray else Paddrarray
+      | Addr | Lazy -> Paddrarray
+      | Int -> Pintarray
+      end
+  | Tconstr(p, [], _) | Tpoly({desc = Tconstr(p, [], _)}, _)
+    when Path.same p Predef.path_floatarray ->
+      Pfloatarray
+  | _ ->
+      (* This can happen with e.g. Obj.field *)
+      Pgenarray
+
+let array_kind exp = array_type_kind exp.exp_env exp.exp_type
+
+let array_pattern_kind pat = array_type_kind pat.pat_env pat.pat_type
+
+let bigarray_decode_type env ty tbl dfl =
+  match scrape env ty with
+  | Tconstr(Pdot(Pident mod_id, type_name), [], _)
+    when Ident.name mod_id = "Stdlib__bigarray" ->
+      begin try List.assoc type_name tbl with Not_found -> dfl end
+  | _ ->
+      dfl
+
+let kind_table =
+  ["float32_elt", Pbigarray_float32;
+   "float64_elt", Pbigarray_float64;
+   "int8_signed_elt", Pbigarray_sint8;
+   "int8_unsigned_elt", Pbigarray_uint8;
+   "int16_signed_elt", Pbigarray_sint16;
+   "int16_unsigned_elt", Pbigarray_uint16;
+   "int32_elt", Pbigarray_int32;
+   "int64_elt", Pbigarray_int64;
+   "int_elt", Pbigarray_caml_int;
+   "nativeint_elt", Pbigarray_native_int;
+   "complex32_elt", Pbigarray_complex32;
+   "complex64_elt", Pbigarray_complex64]
+
+let layout_table =
+  ["c_layout", Pbigarray_c_layout;
+   "fortran_layout", Pbigarray_fortran_layout]
+
+let bigarray_type_kind_and_layout env typ =
+  match scrape env typ with
+  | Tconstr(_p, [_caml_type; elt_type; layout_type], _abbrev) ->
+      (bigarray_decode_type env elt_type kind_table Pbigarray_unknown,
+       bigarray_decode_type env layout_type layout_table
+                            Pbigarray_unknown_layout)
+  | _ ->
+      (Pbigarray_unknown, Pbigarray_unknown_layout)
+
+let value_kind env ty =
+  match scrape env ty with
+  | Tconstr(p, _, _) when Path.same p Predef.path_int ->
+      Pintval
+  | Tconstr(p, _, _) when Path.same p Predef.path_char ->
+      Pintval
+  | Tconstr(p, _, _) when Path.same p Predef.path_float ->
+      Pfloatval
+  | Tconstr(p, _, _) when Path.same p Predef.path_int32 ->
+      Pboxedintval Pint32
+  | Tconstr(p, _, _) when Path.same p Predef.path_int64 ->
+      Pboxedintval Pint64
+  | Tconstr(p, _, _) when Path.same p Predef.path_nativeint ->
+      Pboxedintval Pnativeint
+  | _ ->
+      Pgenval
+
+let function_return_value_kind env ty =
+  match is_function_type env ty with
+  | Some (_lhs, rhs) -> value_kind env rhs
+  | None -> Pgenval
+
+(** Whether a forward block is needed for a lazy thunk on a value, i.e.
+    if the value can be represented as a float/forward/lazy *)
+let lazy_val_requires_forward env ty =
+  match classify env ty with
+  | Any | Lazy -> true
+  | Float -> Config.flat_float_array
+  | Addr | Int -> false
+
+(** The compilation of the expression [lazy e] depends on the form of e:
+    constants, floats and identifiers are optimized.  The optimization must be
+    taken into account when determining whether a recursive binding is safe. *)
+let classify_lazy_argument : Typedtree.expression ->
+                             [`Constant_or_function
+                             |`Float_that_cannot_be_shortcut
+                             |`Identifier of [`Forward_value|`Other]
+                             |`Other] =
+  fun e -> match e.exp_desc with
+    | Texp_constant
+        ( Const_int _ | Const_char _ | Const_string _
+        | Const_int32 _ | Const_int64 _ | Const_nativeint _ )
+    | Texp_function _
+    | Texp_construct (_, {cstr_arity = 0}, _) ->
+       `Constant_or_function
+    | Texp_constant(Const_float _) ->
+       if Config.flat_float_array
+       then `Float_that_cannot_be_shortcut
+       else `Constant_or_function
+    | Texp_ident _ when lazy_val_requires_forward e.exp_env e.exp_type ->
+       `Identifier `Forward_value
+    | Texp_ident _ ->
+       `Identifier `Other
+    | _ ->
+       `Other
+
+let value_kind_union k1 k2 =
+  if k1 = k2 then k1
+  else Pgenval
diff --git a/upstream/ocaml_412/typing/typeopt.mli b/upstream/ocaml_412/typing/typeopt.mli
new file mode 100644
index 0000000..0f6b9f3
--- /dev/null
+++ b/upstream/ocaml_412/typing/typeopt.mli
@@ -0,0 +1,43 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Auxiliaries for type-based optimizations, e.g. array kinds *)
+
+val is_function_type :
+      Env.t -> Types.type_expr -> (Types.type_expr * Types.type_expr) option
+val is_base_type : Env.t -> Types.type_expr -> Path.t -> bool
+
+val maybe_pointer_type : Env.t -> Types.type_expr
+  -> Lambda.immediate_or_pointer
+val maybe_pointer : Typedtree.expression -> Lambda.immediate_or_pointer
+
+val array_type_kind : Env.t -> Types.type_expr -> Lambda.array_kind
+val array_kind : Typedtree.expression -> Lambda.array_kind
+val array_pattern_kind : Typedtree.pattern -> Lambda.array_kind
+val bigarray_type_kind_and_layout :
+      Env.t -> Types.type_expr -> Lambda.bigarray_kind * Lambda.bigarray_layout
+val value_kind : Env.t -> Types.type_expr -> Lambda.value_kind
+val function_return_value_kind : Env.t -> Types.type_expr -> Lambda.value_kind
+
+val classify_lazy_argument : Typedtree.expression ->
+                             [ `Constant_or_function
+                             | `Float_that_cannot_be_shortcut
+                             | `Identifier of [`Forward_value | `Other]
+                             | `Other]
+
+val value_kind_union :
+      Lambda.value_kind -> Lambda.value_kind -> Lambda.value_kind
+  (** [value_kind_union k1 k2] is a value_kind at least as general as
+      [k1] and [k2] *)
diff --git a/upstream/ocaml_412/typing/types.ml b/upstream/ocaml_412/typing/types.ml
new file mode 100644
index 0000000..d723a30
--- /dev/null
+++ b/upstream/ocaml_412/typing/types.ml
@@ -0,0 +1,473 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Representation of types and declarations *)
+
+open Asttypes
+
+(* Type expressions for the core language *)
+
+type type_expr =
+  { mutable desc: type_desc;
+    mutable level: int;
+    mutable scope: int;
+    id: int }
+
+and type_desc =
+    Tvar of string option
+  | Tarrow of arg_label * type_expr * type_expr * commutable
+  | Ttuple of type_expr list
+  | Tconstr of Path.t * type_expr list * abbrev_memo ref
+  | Tobject of type_expr * (Path.t * type_expr list) option ref
+  | Tfield of string * field_kind * type_expr * type_expr
+  | Tnil
+  | Tlink of type_expr
+  | Tsubst of type_expr         (* for copying *)
+  | Tvariant of row_desc
+  | Tunivar of string option
+  | Tpoly of type_expr * type_expr list
+  | Tpackage of Path.t * Longident.t list * type_expr list
+
+and row_desc =
+    { row_fields: (label * row_field) list;
+      row_more: type_expr;
+      row_bound: unit;
+      row_closed: bool;
+      row_fixed: fixed_explanation option;
+      row_name: (Path.t * type_expr list) option }
+and fixed_explanation =
+  | Univar of type_expr | Fixed_private | Reified of Path.t | Rigid
+and row_field =
+    Rpresent of type_expr option
+  | Reither of bool * type_expr list * bool * row_field option ref
+        (* 1st true denotes a constant constructor *)
+        (* 2nd true denotes a tag in a pattern matching, and
+           is erased later *)
+  | Rabsent
+
+and abbrev_memo =
+    Mnil
+  | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo
+  | Mlink of abbrev_memo ref
+
+and field_kind =
+    Fvar of field_kind option ref
+  | Fpresent
+  | Fabsent
+
+and commutable =
+    Cok
+  | Cunknown
+  | Clink of commutable ref
+
+module TypeOps = struct
+  type t = type_expr
+  let compare t1 t2 = t1.id - t2.id
+  let hash t = t.id
+  let equal t1 t2 = t1 == t2
+end
+
+(* *)
+
+module Uid = struct
+  type t =
+    | Compilation_unit of string
+    | Item of { comp_unit: string; id: int }
+    | Internal
+    | Predef of string
+
+  include Identifiable.Make(struct
+    type nonrec t = t
+
+    let equal (x : t) y = x = y
+    let compare (x : t) y = compare x y
+    let hash (x : t) = Hashtbl.hash x
+
+    let print fmt = function
+      | Internal -> Format.pp_print_string fmt "<internal>"
+      | Predef name -> Format.fprintf fmt "<predef:%s>" name
+      | Compilation_unit s -> Format.pp_print_string fmt s
+      | Item { comp_unit; id } -> Format.fprintf fmt "%s.%d" comp_unit id
+
+    let output oc t =
+      let fmt = Format.formatter_of_out_channel oc in
+      print fmt t
+  end)
+
+  let id = ref (-1)
+
+  let reinit () = id := (-1)
+
+  let mk  ~current_unit =
+      incr id;
+      Item { comp_unit = current_unit; id = !id }
+
+  let of_compilation_unit_id id =
+    if not (Ident.persistent id) then
+      Misc.fatal_errorf "Types.Uid.of_compilation_unit_id %S" (Ident.name id);
+    Compilation_unit (Ident.name id)
+
+  let of_predef_id id =
+    if not (Ident.is_predef id) then
+      Misc.fatal_errorf "Types.Uid.of_predef_id %S" (Ident.name id);
+    Predef (Ident.name id)
+
+  let internal_not_actually_unique = Internal
+
+  let for_actual_declaration = function
+    | Item _ -> true
+    | _ -> false
+end
+
+(* Maps of methods and instance variables *)
+
+module Meths = Misc.Stdlib.String.Map
+module Vars = Meths
+
+(* Value descriptions *)
+
+type value_description =
+  { val_type: type_expr;                (* Type of the value *)
+    val_kind: value_kind;
+    val_loc: Location.t;
+    val_attributes: Parsetree.attributes;
+    val_uid: Uid.t;
+  }
+
+and value_kind =
+    Val_reg                             (* Regular value *)
+  | Val_prim of Primitive.description   (* Primitive *)
+  | Val_ivar of mutable_flag * string   (* Instance variable (mutable ?) *)
+  | Val_self of (Ident.t * type_expr) Meths.t ref *
+                (Ident.t * Asttypes.mutable_flag *
+                 Asttypes.virtual_flag * type_expr) Vars.t ref *
+                string * type_expr
+                                        (* Self *)
+  | Val_anc of (string * Ident.t) list * string
+                                        (* Ancestor *)
+
+(* Variance *)
+
+module Variance = struct
+  type t = int
+  type f = May_pos | May_neg | May_weak | Inj | Pos | Neg | Inv
+  let single = function
+    | May_pos -> 1
+    | May_neg -> 2
+    | May_weak -> 4
+    | Inj -> 8
+    | Pos -> 16
+    | Neg -> 32
+    | Inv -> 64
+  let union v1 v2 = v1 lor v2
+  let inter v1 v2 = v1 land v2
+  let subset v1 v2 = (v1 land v2 = v1)
+  let eq (v1 : t) v2 = (v1 = v2)
+  let set x b v =
+    if b then v lor single x else  v land (lnot (single x))
+  let mem x = subset (single x)
+  let null = 0
+  let unknown = 7
+  let full = 127
+  let covariant = single May_pos lor single Pos lor single Inj
+  let swap f1 f2 v =
+    let v' = set f1 (mem f2 v) v in set f2 (mem f1 v) v'
+  let conjugate v = swap May_pos May_neg (swap Pos Neg v)
+  let get_upper v = (mem May_pos v, mem May_neg v)
+  let get_lower v = (mem Pos v, mem Neg v, mem Inv v, mem Inj v)
+  let unknown_signature ~injective ~arity =
+    let v = if injective then set Inj true unknown else unknown in
+    Misc.replicate_list v arity
+end
+
+module Separability = struct
+  type t = Ind | Sep | Deepsep
+  type signature = t list
+  let eq (m1 : t) m2 = (m1 = m2)
+  let rank = function
+    | Ind -> 0
+    | Sep -> 1
+    | Deepsep -> 2
+  let compare m1 m2 = compare (rank m1) (rank m2)
+  let max m1 m2 = if rank m1 >= rank m2 then m1 else m2
+
+  let print ppf = function
+    | Ind -> Format.fprintf ppf "Ind"
+    | Sep -> Format.fprintf ppf "Sep"
+    | Deepsep -> Format.fprintf ppf "Deepsep"
+
+  let print_signature ppf modes =
+    let pp_sep ppf () = Format.fprintf ppf ",@," in
+    Format.fprintf ppf "@[(%a)@]"
+      (Format.pp_print_list ~pp_sep print) modes
+
+  let default_signature ~arity =
+    let default_mode = if Config.flat_float_array then Deepsep else Ind in
+    Misc.replicate_list default_mode arity
+end
+
+(* Type definitions *)
+
+type type_declaration =
+  { type_params: type_expr list;
+    type_arity: int;
+    type_kind: type_kind;
+    type_private: private_flag;
+    type_manifest: type_expr option;
+    type_variance: Variance.t list;
+    type_separability: Separability.t list;
+    type_is_newtype: bool;
+    type_expansion_scope: int;
+    type_loc: Location.t;
+    type_attributes: Parsetree.attributes;
+    type_immediate: Type_immediacy.t;
+    type_unboxed: unboxed_status;
+    type_uid: Uid.t;
+ }
+
+and type_kind =
+    Type_abstract
+  | Type_record of label_declaration list  * record_representation
+  | Type_variant of constructor_declaration list
+  | Type_open
+
+and record_representation =
+    Record_regular                      (* All fields are boxed / tagged *)
+  | Record_float                        (* All fields are floats *)
+  | Record_unboxed of bool    (* Unboxed single-field record, inlined or not *)
+  | Record_inlined of int               (* Inlined record *)
+  | Record_extension of Path.t          (* Inlined record under extension *)
+
+and label_declaration =
+  {
+    ld_id: Ident.t;
+    ld_mutable: mutable_flag;
+    ld_type: type_expr;
+    ld_loc: Location.t;
+    ld_attributes: Parsetree.attributes;
+    ld_uid: Uid.t;
+  }
+
+and constructor_declaration =
+  {
+    cd_id: Ident.t;
+    cd_args: constructor_arguments;
+    cd_res: type_expr option;
+    cd_loc: Location.t;
+    cd_attributes: Parsetree.attributes;
+    cd_uid: Uid.t;
+  }
+
+and constructor_arguments =
+  | Cstr_tuple of type_expr list
+  | Cstr_record of label_declaration list
+
+and unboxed_status =
+  {
+    unboxed: bool;
+    default: bool; (* False if the unboxed field was set from an attribute. *)
+  }
+
+let unboxed_false_default_false = {unboxed = false; default = false}
+let unboxed_false_default_true = {unboxed = false; default = true}
+let unboxed_true_default_false = {unboxed = true; default = false}
+let unboxed_true_default_true = {unboxed = true; default = true}
+
+type extension_constructor =
+  { ext_type_path: Path.t;
+    ext_type_params: type_expr list;
+    ext_args: constructor_arguments;
+    ext_ret_type: type_expr option;
+    ext_private: private_flag;
+    ext_loc: Location.t;
+    ext_attributes: Parsetree.attributes;
+    ext_uid: Uid.t;
+  }
+
+and type_transparence =
+    Type_public      (* unrestricted expansion *)
+  | Type_new         (* "new" type *)
+  | Type_private     (* private type *)
+
+(* Type expressions for the class language *)
+
+module Concr = Misc.Stdlib.String.Set
+
+type class_type =
+    Cty_constr of Path.t * type_expr list * class_type
+  | Cty_signature of class_signature
+  | Cty_arrow of arg_label * type_expr * class_type
+
+and class_signature =
+  { csig_self: type_expr;
+    csig_vars:
+      (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
+    csig_concr: Concr.t;
+    csig_inher: (Path.t * type_expr list) list }
+
+type class_declaration =
+  { cty_params: type_expr list;
+    mutable cty_type: class_type;
+    cty_path: Path.t;
+    cty_new: type_expr option;
+    cty_variance: Variance.t list;
+    cty_loc: Location.t;
+    cty_attributes: Parsetree.attributes;
+    cty_uid: Uid.t;
+ }
+
+type class_type_declaration =
+  { clty_params: type_expr list;
+    clty_type: class_type;
+    clty_path: Path.t;
+    clty_variance: Variance.t list;
+    clty_loc: Location.t;
+    clty_attributes: Parsetree.attributes;
+    clty_uid: Uid.t;
+  }
+
+(* Type expressions for the module language *)
+
+type visibility =
+  | Exported
+  | Hidden
+
+type module_type =
+    Mty_ident of Path.t
+  | Mty_signature of signature
+  | Mty_functor of functor_parameter * module_type
+  | Mty_alias of Path.t
+
+and functor_parameter =
+  | Unit
+  | Named of Ident.t option * module_type
+
+and module_presence =
+  | Mp_present
+  | Mp_absent
+
+and signature = signature_item list
+
+and signature_item =
+    Sig_value of Ident.t * value_description * visibility
+  | Sig_type of Ident.t * type_declaration * rec_status * visibility
+  | Sig_typext of Ident.t * extension_constructor * ext_status * visibility
+  | Sig_module of
+      Ident.t * module_presence * module_declaration * rec_status * visibility
+  | Sig_modtype of Ident.t * modtype_declaration * visibility
+  | Sig_class of Ident.t * class_declaration * rec_status * visibility
+  | Sig_class_type of Ident.t * class_type_declaration * rec_status * visibility
+
+and module_declaration =
+  {
+    md_type: module_type;
+    md_attributes: Parsetree.attributes;
+    md_loc: Location.t;
+    md_uid: Uid.t;
+  }
+
+and modtype_declaration =
+  {
+    mtd_type: module_type option;  (* Note: abstract *)
+    mtd_attributes: Parsetree.attributes;
+    mtd_loc: Location.t;
+    mtd_uid: Uid.t;
+  }
+
+and rec_status =
+    Trec_not                   (* first in a nonrecursive group *)
+  | Trec_first                 (* first in a recursive group *)
+  | Trec_next                  (* not first in a recursive/nonrecursive group *)
+
+and ext_status =
+    Text_first                     (* first constructor of an extension *)
+  | Text_next                      (* not first constructor of an extension *)
+  | Text_exception                 (* an exception *)
+
+
+(* Constructor and record label descriptions inserted held in typing
+   environments *)
+
+type constructor_description =
+  { cstr_name: string;                  (* Constructor name *)
+    cstr_res: type_expr;                (* Type of the result *)
+    cstr_existentials: type_expr list;  (* list of existentials *)
+    cstr_args: type_expr list;          (* Type of the arguments *)
+    cstr_arity: int;                    (* Number of arguments *)
+    cstr_tag: constructor_tag;          (* Tag for heap blocks *)
+    cstr_consts: int;                   (* Number of constant constructors *)
+    cstr_nonconsts: int;                (* Number of non-const constructors *)
+    cstr_normal: int;                   (* Number of non generalized constrs *)
+    cstr_generalized: bool;             (* Constrained return type? *)
+    cstr_private: private_flag;         (* Read-only constructor? *)
+    cstr_loc: Location.t;
+    cstr_attributes: Parsetree.attributes;
+    cstr_inlined: type_declaration option;
+    cstr_uid: Uid.t;
+   }
+
+and constructor_tag =
+    Cstr_constant of int                (* Constant constructor (an int) *)
+  | Cstr_block of int                   (* Regular constructor (a block) *)
+  | Cstr_unboxed                        (* Constructor of an unboxed type *)
+  | Cstr_extension of Path.t * bool     (* Extension constructor
+                                           true if a constant false if a block*)
+
+let equal_tag t1 t2 =
+  match (t1, t2) with
+  | Cstr_constant i1, Cstr_constant i2 -> i2 = i1
+  | Cstr_block i1, Cstr_block i2 -> i2 = i1
+  | Cstr_unboxed, Cstr_unboxed -> true
+  | Cstr_extension (path1, b1), Cstr_extension (path2, b2) ->
+      Path.same path1 path2 && b1 = b2
+  | (Cstr_constant _|Cstr_block _|Cstr_unboxed|Cstr_extension _), _ -> false
+
+let may_equal_constr c1 c2 = match c1.cstr_tag,c2.cstr_tag with
+| Cstr_extension _,Cstr_extension _ -> c1.cstr_arity = c2.cstr_arity
+| tag1,tag2 -> equal_tag tag1 tag2
+
+type label_description =
+  { lbl_name: string;                   (* Short name *)
+    lbl_res: type_expr;                 (* Type of the result *)
+    lbl_arg: type_expr;                 (* Type of the argument *)
+    lbl_mut: mutable_flag;              (* Is this a mutable field? *)
+    lbl_pos: int;                       (* Position in block *)
+    lbl_all: label_description array;   (* All the labels in this type *)
+    lbl_repres: record_representation;  (* Representation for this record *)
+    lbl_private: private_flag;          (* Read-only field? *)
+    lbl_loc: Location.t;
+    lbl_attributes: Parsetree.attributes;
+    lbl_uid: Uid.t;
+   }
+
+let rec bound_value_identifiers = function
+    [] -> []
+  | Sig_value(id, {val_kind = Val_reg}, _) :: rem ->
+      id :: bound_value_identifiers rem
+  | Sig_typext(id, _, _, _) :: rem -> id :: bound_value_identifiers rem
+  | Sig_module(id, Mp_present, _, _, _) :: rem ->
+      id :: bound_value_identifiers rem
+  | Sig_class(id, _, _, _) :: rem -> id :: bound_value_identifiers rem
+  | _ :: rem -> bound_value_identifiers rem
+
+let signature_item_id = function
+  | Sig_value (id, _, _)
+  | Sig_type (id, _, _, _)
+  | Sig_typext (id, _, _, _)
+  | Sig_module (id, _, _, _, _)
+  | Sig_modtype (id, _, _)
+  | Sig_class (id, _, _, _)
+  | Sig_class_type (id, _, _, _)
+    -> id
diff --git a/upstream/ocaml_412/typing/types.mli b/upstream/ocaml_412/typing/types.mli
new file mode 100644
index 0000000..98bd408
--- /dev/null
+++ b/upstream/ocaml_412/typing/types.mli
@@ -0,0 +1,586 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** {0 Representation of types and declarations} *)
+
+(** [Types] defines the representation of types and declarations (that is, the
+    content of module signatures).
+
+    CMI files are made of marshalled types.
+*)
+
+(** Asttypes exposes basic definitions shared both by Parsetree and Types. *)
+open Asttypes
+
+(** Type expressions for the core language.
+
+    The [type_desc] variant defines all the possible type expressions one can
+    find in OCaml. [type_expr] wraps this with some annotations.
+
+    The [level] field tracks the level of polymorphism associated to a type,
+    guiding the generalization algorithm.
+    Put shortly, when referring to a type in a given environment, both the type
+    and the environment have a level. If the type has an higher level, then it
+    can be considered fully polymorphic (type variables will be printed as
+    ['a]), otherwise it'll be weakly polymorphic, or non generalized (type
+    variables printed as ['_a]).
+    See [http://okmij.org/ftp/ML/generalization.html] for more information.
+
+    Note about [type_declaration]: one should not make the confusion between
+    [type_expr] and [type_declaration].
+
+    [type_declaration] refers specifically to the [type] construct in OCaml
+    language, where you create and name a new type or type alias.
+
+    [type_expr] is used when you refer to existing types, e.g. when annotating
+    the expected type of a value.
+
+    Also, as the type system of OCaml is generative, a [type_declaration] can
+    have the side-effect of introducing a new type constructor, different from
+    all other known types.
+    Whereas [type_expr] is a pure construct which allows referring to existing
+    types.
+
+    Note on mutability: TBD.
+ *)
+type type_expr =
+  { mutable desc: type_desc;
+    mutable level: int;
+    mutable scope: int;
+    id: int }
+
+and type_desc =
+  | Tvar of string option
+  (** [Tvar (Some "a")] ==> ['a] or ['_a]
+      [Tvar None]       ==> [_] *)
+
+  | Tarrow of arg_label * type_expr * type_expr * commutable
+  (** [Tarrow (Nolabel,      e1, e2, c)] ==> [e1    -> e2]
+      [Tarrow (Labelled "l", e1, e2, c)] ==> [l:e1  -> e2]
+      [Tarrow (Optional "l", e1, e2, c)] ==> [?l:e1 -> e2]
+
+      See [commutable] for the last argument. *)
+
+  | Ttuple of type_expr list
+  (** [Ttuple [t1;...;tn]] ==> [(t1 * ... * tn)] *)
+
+  | Tconstr of Path.t * type_expr list * abbrev_memo ref
+  (** [Tconstr (`A.B.t', [t1;...;tn], _)] ==> [(t1,...,tn) A.B.t]
+      The last parameter keep tracks of known expansions, see [abbrev_memo]. *)
+
+  | Tobject of type_expr * (Path.t * type_expr list) option ref
+  (** [Tobject (`f1:t1;...;fn: tn', `None')] ==> [< f1: t1; ...; fn: tn >]
+      f1, fn are represented as a linked list of types using Tfield and Tnil
+      constructors.
+
+      [Tobject (_, `Some (`A.ct', [t1;...;tn]')] ==> [(t1, ..., tn) A.ct].
+      where A.ct is the type of some class.
+
+      There are also special cases for so-called "class-types", cf. [Typeclass]
+      and [Ctype.set_object_name]:
+
+        [Tobject (Tfield(_,_,...(Tfield(_,_,rv)...),
+                         Some(`A.#ct`, [rv;t1;...;tn])]
+             ==> [(t1, ..., tn) #A.ct]
+        [Tobject (_, Some(`A.#ct`, [Tnil;t1;...;tn])] ==> [(t1, ..., tn) A.ct]
+
+      where [rv] is the hidden row variable.
+  *)
+
+  | Tfield of string * field_kind * type_expr * type_expr
+  (** [Tfield ("foo", Fpresent, t, ts)] ==> [<...; foo : t; ts>] *)
+
+  | Tnil
+  (** [Tnil] ==> [<...; >] *)
+
+  | Tlink of type_expr
+  (** Indirection used by unification engine. *)
+
+  | Tsubst of type_expr         (* for copying *)
+  (** [Tsubst] is used temporarily to store information in low-level
+      functions manipulating representation of types, such as
+      instantiation or copy.
+      This constructor should not appear outside of these cases. *)
+
+  | Tvariant of row_desc
+  (** Representation of polymorphic variants, see [row_desc]. *)
+
+  | Tunivar of string option
+  (** Occurrence of a type variable introduced by a
+      forall quantifier / [Tpoly]. *)
+
+  | Tpoly of type_expr * type_expr list
+  (** [Tpoly (ty,tyl)] ==> ['a1... 'an. ty],
+      where 'a1 ... 'an are names given to types in tyl
+      and occurrences of those types in ty. *)
+
+  | Tpackage of Path.t * Longident.t list * type_expr list
+  (** Type of a first-class module (a.k.a package). *)
+
+(** [  `X | `Y ]       (row_closed = true)
+    [< `X | `Y ]       (row_closed = true)
+    [> `X | `Y ]       (row_closed = false)
+    [< `X | `Y > `X ]  (row_closed = true)
+
+    type t = [> `X ] as 'a      (row_more = Tvar a)
+    type t = private [> `X ]    (row_more = Tconstr (t#row, [], ref Mnil))
+
+    And for:
+
+        let f = function `X -> `X -> | `Y -> `X
+
+    the type of "f" will be a [Tarrow] whose lhs will (basically) be:
+
+        Tvariant { row_fields = [("X", _)];
+                   row_more   =
+                     Tvariant { row_fields = [("Y", _)];
+                                row_more   =
+                                  Tvariant { row_fields = [];
+                                             row_more   = _;
+                                             _ };
+                                _ };
+                   _
+                 }
+
+*)
+and row_desc =
+    { row_fields: (label * row_field) list;
+      row_more: type_expr;
+      row_bound: unit; (* kept for compatibility *)
+      row_closed: bool;
+      row_fixed: fixed_explanation option;
+      row_name: (Path.t * type_expr list) option }
+and fixed_explanation =
+  | Univar of type_expr (** The row type was bound to an univar *)
+  | Fixed_private (** The row type is private *)
+  | Reified of Path.t (** The row was reified *)
+  | Rigid (** The row type was made rigid during constraint verification *)
+and row_field =
+    Rpresent of type_expr option
+  | Reither of bool * type_expr list * bool * row_field option ref
+        (* 1st true denotes a constant constructor *)
+        (* 2nd true denotes a tag in a pattern matching, and
+           is erased later *)
+  | Rabsent
+
+(** [abbrev_memo] allows one to keep track of different expansions of a type
+    alias. This is done for performance purposes.
+
+    For instance, when defining [type 'a pair = 'a * 'a], when one refers to an
+    ['a pair], it is just a shortcut for the ['a * 'a] type.
+    This expansion will be stored in the [abbrev_memo] of the corresponding
+    [Tconstr] node.
+
+    In practice, [abbrev_memo] behaves like list of expansions with a mutable
+    tail.
+
+    Note on marshalling: [abbrev_memo] must not appear in saved types.
+    [Btype], with [cleanup_abbrev] and [memo], takes care of tracking and
+    removing abbreviations.
+*)
+and abbrev_memo =
+  | Mnil (** No known abbreviation *)
+
+  | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo
+  (** Found one abbreviation.
+      A valid abbreviation should be at least as visible and reachable by the
+      same path.
+      The first expression is the abbreviation and the second the expansion. *)
+
+  | Mlink of abbrev_memo ref
+  (** Abbreviations can be found after this indirection *)
+
+and field_kind =
+    Fvar of field_kind option ref
+  | Fpresent
+  | Fabsent
+
+(** [commutable] is a flag appended to every arrow type.
+
+    When typing an application, if the type of the functional is
+    known, its type is instantiated with [Cok] arrows, otherwise as
+    [Clink (ref Cunknown)].
+
+    When the type is not known, the application will be used to infer
+    the actual type.  This is fragile in presence of labels where
+    there is no principal type.
+
+    Two incompatible applications relying on [Cunknown] arrows will
+    trigger an error.
+
+    let f g =
+      g ~a:() ~b:();
+      g ~b:() ~a:();
+
+    Error: This function is applied to arguments
+    in an order different from other calls.
+    This is only allowed when the real type is known.
+*)
+and commutable =
+    Cok
+  | Cunknown
+  | Clink of commutable ref
+
+module TypeOps : sig
+  type t = type_expr
+  val compare : t -> t -> int
+  val equal : t -> t -> bool
+  val hash : t -> int
+end
+
+(* *)
+
+module Uid : sig
+  type t
+
+  val reinit : unit -> unit
+
+  val mk : current_unit:string -> t
+  val of_compilation_unit_id : Ident.t -> t
+  val of_predef_id : Ident.t -> t
+  val internal_not_actually_unique : t
+
+  val for_actual_declaration : t -> bool
+
+  include Identifiable.S with type t := t
+end
+
+(* Maps of methods and instance variables *)
+
+module Meths : Map.S with type key = string
+module Vars  : Map.S with type key = string
+
+(* Value descriptions *)
+
+type value_description =
+  { val_type: type_expr;                (* Type of the value *)
+    val_kind: value_kind;
+    val_loc: Location.t;
+    val_attributes: Parsetree.attributes;
+    val_uid: Uid.t;
+  }
+
+and value_kind =
+    Val_reg                             (* Regular value *)
+  | Val_prim of Primitive.description   (* Primitive *)
+  | Val_ivar of mutable_flag * string   (* Instance variable (mutable ?) *)
+  | Val_self of (Ident.t * type_expr) Meths.t ref *
+                (Ident.t * mutable_flag * virtual_flag * type_expr) Vars.t ref *
+                string * type_expr
+                                        (* Self *)
+  | Val_anc of (string * Ident.t) list * string
+                                        (* Ancestor *)
+
+(* Variance *)
+
+module Variance : sig
+  type t
+  type f =
+      May_pos                (* allow positive occurrences *)
+    | May_neg                (* allow negative occurrences *)
+    | May_weak               (* allow occurrences under a negative position *)
+    | Inj                    (* type is injective in this parameter *)
+    | Pos                    (* there is a positive occurrence *)
+    | Neg                    (* there is a negative occurrence *)
+    | Inv                    (* both negative and positive occurrences *)
+  val null : t               (* no occurrence *)
+  val full : t               (* strictly invariant (all flags) *)
+  val covariant : t          (* strictly covariant (May_pos, Pos and Inj) *)
+  val unknown : t            (* allow everything, guarantee nothing *)
+  val union  : t -> t -> t
+  val inter  : t -> t -> t
+  val subset : t -> t -> bool
+  val eq : t -> t -> bool
+  val set : f -> bool -> t -> t
+  val mem : f -> t -> bool
+  val conjugate : t -> t                (* exchange positive and negative *)
+  val get_upper : t -> bool * bool                  (* may_pos, may_neg   *)
+  val get_lower : t -> bool * bool * bool * bool    (* pos, neg, inv, inj *)
+  val unknown_signature : injective:bool -> arity:int -> t list
+  (** The most pessimistic variance for a completely unknown type. *)
+end
+
+module Separability : sig
+  (** see {!Typedecl_separability} for an explanation of separability
+      and separability modes.*)
+
+  type t = Ind | Sep | Deepsep
+  val eq : t -> t -> bool
+  val print : Format.formatter -> t -> unit
+
+  val rank : t -> int
+  (** Modes are ordered from the least to the most demanding:
+      Ind < Sep < Deepsep.
+      'rank' maps them to integers in an order-respecting way:
+      m1 < m2  <=>  rank m1 < rank m2 *)
+
+  val compare : t -> t -> int
+  (** Compare two mode according to their mode ordering. *)
+
+  val max : t -> t -> t
+  (** [max_mode m1 m2] returns the most demanding mode. It is used to
+      express the conjunction of two parameter mode constraints. *)
+
+  type signature = t list
+  (** The 'separability signature' of a type assigns a mode for
+      each of its parameters. [('a, 'b) t] has mode [(m1, m2)] if
+      [(t1, t2) t] is separable whenever [t1, t2] have mode [m1, m2]. *)
+
+  val print_signature : Format.formatter -> signature -> unit
+
+  val default_signature : arity:int -> signature
+  (** The most pessimistic separability for a completely unknown type. *)
+end
+
+(* Type definitions *)
+
+type type_declaration =
+  { type_params: type_expr list;
+    type_arity: int;
+    type_kind: type_kind;
+    type_private: private_flag;
+    type_manifest: type_expr option;
+    type_variance: Variance.t list;
+    (* covariant, contravariant, weakly contravariant, injective *)
+    type_separability: Separability.t list;
+    type_is_newtype: bool;
+    type_expansion_scope: int;
+    type_loc: Location.t;
+    type_attributes: Parsetree.attributes;
+    type_immediate: Type_immediacy.t;
+    type_unboxed: unboxed_status;
+    type_uid: Uid.t;
+  }
+
+and type_kind =
+    Type_abstract
+  | Type_record of label_declaration list  * record_representation
+  | Type_variant of constructor_declaration list
+  | Type_open
+
+and record_representation =
+    Record_regular                      (* All fields are boxed / tagged *)
+  | Record_float                        (* All fields are floats *)
+  | Record_unboxed of bool    (* Unboxed single-field record, inlined or not *)
+  | Record_inlined of int               (* Inlined record *)
+  | Record_extension of Path.t          (* Inlined record under extension *)
+
+and label_declaration =
+  {
+    ld_id: Ident.t;
+    ld_mutable: mutable_flag;
+    ld_type: type_expr;
+    ld_loc: Location.t;
+    ld_attributes: Parsetree.attributes;
+    ld_uid: Uid.t;
+  }
+
+and constructor_declaration =
+  {
+    cd_id: Ident.t;
+    cd_args: constructor_arguments;
+    cd_res: type_expr option;
+    cd_loc: Location.t;
+    cd_attributes: Parsetree.attributes;
+    cd_uid: Uid.t;
+  }
+
+and constructor_arguments =
+  | Cstr_tuple of type_expr list
+  | Cstr_record of label_declaration list
+
+and unboxed_status = private
+  (* This type must be private in order to ensure perfect sharing of the
+     four possible values. Otherwise, ocamlc.byte and ocamlc.opt produce
+     different executables. *)
+  {
+    unboxed: bool;
+    default: bool; (* True for unannotated unboxable types. *)
+  }
+
+val unboxed_false_default_false : unboxed_status
+val unboxed_false_default_true : unboxed_status
+val unboxed_true_default_false : unboxed_status
+val unboxed_true_default_true : unboxed_status
+
+type extension_constructor =
+  {
+    ext_type_path: Path.t;
+    ext_type_params: type_expr list;
+    ext_args: constructor_arguments;
+    ext_ret_type: type_expr option;
+    ext_private: private_flag;
+    ext_loc: Location.t;
+    ext_attributes: Parsetree.attributes;
+    ext_uid: Uid.t;
+  }
+
+and type_transparence =
+    Type_public      (* unrestricted expansion *)
+  | Type_new         (* "new" type *)
+  | Type_private     (* private type *)
+
+(* Type expressions for the class language *)
+
+module Concr : Set.S with type elt = string
+
+type class_type =
+    Cty_constr of Path.t * type_expr list * class_type
+  | Cty_signature of class_signature
+  | Cty_arrow of arg_label * type_expr * class_type
+
+and class_signature =
+  { csig_self: type_expr;
+    csig_vars:
+      (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
+    csig_concr: Concr.t;
+    csig_inher: (Path.t * type_expr list) list }
+
+type class_declaration =
+  { cty_params: type_expr list;
+    mutable cty_type: class_type;
+    cty_path: Path.t;
+    cty_new: type_expr option;
+    cty_variance: Variance.t list;
+    cty_loc: Location.t;
+    cty_attributes: Parsetree.attributes;
+    cty_uid: Uid.t;
+  }
+
+type class_type_declaration =
+  { clty_params: type_expr list;
+    clty_type: class_type;
+    clty_path: Path.t;
+    clty_variance: Variance.t list;
+    clty_loc: Location.t;
+    clty_attributes: Parsetree.attributes;
+    clty_uid: Uid.t;
+  }
+
+(* Type expressions for the module language *)
+
+type visibility =
+  | Exported
+  | Hidden
+
+type module_type =
+    Mty_ident of Path.t
+  | Mty_signature of signature
+  | Mty_functor of functor_parameter * module_type
+  | Mty_alias of Path.t
+
+and functor_parameter =
+  | Unit
+  | Named of Ident.t option * module_type
+
+and module_presence =
+  | Mp_present
+  | Mp_absent
+
+and signature = signature_item list
+
+and signature_item =
+    Sig_value of Ident.t * value_description * visibility
+  | Sig_type of Ident.t * type_declaration * rec_status * visibility
+  | Sig_typext of Ident.t * extension_constructor * ext_status * visibility
+  | Sig_module of
+      Ident.t * module_presence * module_declaration * rec_status * visibility
+  | Sig_modtype of Ident.t * modtype_declaration * visibility
+  | Sig_class of Ident.t * class_declaration * rec_status * visibility
+  | Sig_class_type of Ident.t * class_type_declaration * rec_status * visibility
+
+and module_declaration =
+  {
+    md_type: module_type;
+    md_attributes: Parsetree.attributes;
+    md_loc: Location.t;
+    md_uid: Uid.t;
+  }
+
+and modtype_declaration =
+  {
+    mtd_type: module_type option;  (* None: abstract *)
+    mtd_attributes: Parsetree.attributes;
+    mtd_loc: Location.t;
+    mtd_uid: Uid.t;
+  }
+
+and rec_status =
+    Trec_not                   (* first in a nonrecursive group *)
+  | Trec_first                 (* first in a recursive group *)
+  | Trec_next                  (* not first in a recursive/nonrecursive group *)
+
+and ext_status =
+    Text_first                     (* first constructor in an extension *)
+  | Text_next                      (* not first constructor in an extension *)
+  | Text_exception
+
+
+(* Constructor and record label descriptions inserted held in typing
+   environments *)
+
+type constructor_description =
+  { cstr_name: string;                  (* Constructor name *)
+    cstr_res: type_expr;                (* Type of the result *)
+    cstr_existentials: type_expr list;  (* list of existentials *)
+    cstr_args: type_expr list;          (* Type of the arguments *)
+    cstr_arity: int;                    (* Number of arguments *)
+    cstr_tag: constructor_tag;          (* Tag for heap blocks *)
+    cstr_consts: int;                   (* Number of constant constructors *)
+    cstr_nonconsts: int;                (* Number of non-const constructors *)
+    cstr_normal: int;                   (* Number of non generalized constrs *)
+    cstr_generalized: bool;             (* Constrained return type? *)
+    cstr_private: private_flag;         (* Read-only constructor? *)
+    cstr_loc: Location.t;
+    cstr_attributes: Parsetree.attributes;
+    cstr_inlined: type_declaration option;
+    cstr_uid: Uid.t;
+   }
+
+and constructor_tag =
+    Cstr_constant of int                (* Constant constructor (an int) *)
+  | Cstr_block of int                   (* Regular constructor (a block) *)
+  | Cstr_unboxed                        (* Constructor of an unboxed type *)
+  | Cstr_extension of Path.t * bool     (* Extension constructor
+                                           true if a constant false if a block*)
+
+(* Constructors are the same *)
+val equal_tag :  constructor_tag -> constructor_tag -> bool
+
+(* Constructors may be the same, given potential rebinding *)
+val may_equal_constr :
+    constructor_description ->  constructor_description -> bool
+
+type label_description =
+  { lbl_name: string;                   (* Short name *)
+    lbl_res: type_expr;                 (* Type of the result *)
+    lbl_arg: type_expr;                 (* Type of the argument *)
+    lbl_mut: mutable_flag;              (* Is this a mutable field? *)
+    lbl_pos: int;                       (* Position in block *)
+    lbl_all: label_description array;   (* All the labels in this type *)
+    lbl_repres: record_representation;  (* Representation for this record *)
+    lbl_private: private_flag;          (* Read-only field? *)
+    lbl_loc: Location.t;
+    lbl_attributes: Parsetree.attributes;
+    lbl_uid: Uid.t;
+  }
+
+(** Extracts the list of "value" identifiers bound by a signature.
+    "Value" identifiers are identifiers for signature components that
+    correspond to a run-time value: values, extensions, modules, classes.
+    Note: manifest primitives do not correspond to a run-time value! *)
+val bound_value_identifiers: signature -> Ident.t list
+
+val signature_item_id : signature_item -> Ident.t
diff --git a/upstream/ocaml_412/typing/typetexp.ml b/upstream/ocaml_412/typing/typetexp.ml
new file mode 100644
index 0000000..84c5de3
--- /dev/null
+++ b/upstream/ocaml_412/typing/typetexp.ml
@@ -0,0 +1,814 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* typetexp.ml,v 1.34.4.9 2002/01/07 08:39:16 garrigue Exp *)
+
+(* Typechecking of type expressions for the core language *)
+
+open Asttypes
+open Misc
+open Parsetree
+open Typedtree
+open Types
+open Ctype
+
+exception Already_bound
+
+type error =
+    Unbound_type_variable of string
+  | Undefined_type_constructor of Path.t
+  | Type_arity_mismatch of Longident.t * int * int
+  | Bound_type_variable of string
+  | Recursive_type
+  | Unbound_row_variable of Longident.t
+  | Type_mismatch of Ctype.Unification_trace.t
+  | Alias_type_mismatch of Ctype.Unification_trace.t
+  | Present_has_conjunction of string
+  | Present_has_no_type of string
+  | Constructor_mismatch of type_expr * type_expr
+  | Not_a_variant of type_expr
+  | Variant_tags of string * string
+  | Invalid_variable_name of string
+  | Cannot_quantify of string * type_expr
+  | Multiple_constraints_on_type of Longident.t
+  | Method_mismatch of string * type_expr * type_expr
+  | Opened_object of Path.t option
+  | Not_an_object of type_expr
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+(** Map indexed by type variable names. *)
+module TyVarMap = Misc.Stdlib.String.Map
+
+type variable_context = int * type_expr TyVarMap.t
+
+(* Support for first-class modules. *)
+
+let transl_modtype_longident = ref (fun _ -> assert false)
+let transl_modtype = ref (fun _ -> assert false)
+
+let create_package_mty fake loc env (p, l) =
+  let l =
+    List.sort
+      (fun (s1, _t1) (s2, _t2) ->
+         if s1.txt = s2.txt then
+           raise (Error (loc, env, Multiple_constraints_on_type s1.txt));
+         compare s1.txt s2.txt)
+      l
+  in
+  l,
+  List.fold_left
+    (fun mty (s, t) ->
+      let d = {ptype_name = mkloc (Longident.last s.txt) s.loc;
+               ptype_params = [];
+               ptype_cstrs = [];
+               ptype_kind = Ptype_abstract;
+               ptype_private = Asttypes.Public;
+               ptype_manifest = if fake then None else Some t;
+               ptype_attributes = [];
+               ptype_loc = loc} in
+      Ast_helper.Mty.mk ~loc
+        (Pmty_with (mty, [ Pwith_type ({ txt = s.txt; loc }, d) ]))
+    )
+    (Ast_helper.Mty.mk ~loc (Pmty_ident p))
+    l
+
+(* Translation of type expressions *)
+
+let type_variables = ref (TyVarMap.empty : type_expr TyVarMap.t)
+let univars        = ref ([] : (string * type_expr) list)
+let pre_univars    = ref ([] : type_expr list)
+let used_variables = ref (TyVarMap.empty : (type_expr * Location.t) TyVarMap.t)
+
+let reset_type_variables () =
+  reset_global_level ();
+  Ctype.reset_reified_var_counter ();
+  type_variables := TyVarMap.empty
+
+let narrow () =
+  (increase_global_level (), !type_variables)
+
+let widen (gl, tv) =
+  restore_global_level gl;
+  type_variables := tv
+
+let strict_ident c = (c = '_' || c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z')
+
+let validate_name = function
+    None -> None
+  | Some name as s ->
+      if name <> "" && strict_ident name.[0] then s else None
+
+let new_global_var ?name () =
+  new_global_var ?name:(validate_name name) ()
+let newvar ?name () =
+  newvar ?name:(validate_name name) ()
+
+let type_variable loc name =
+  try
+    TyVarMap.find name !type_variables
+  with Not_found ->
+    raise(Error(loc, Env.empty, Unbound_type_variable ("'" ^ name)))
+
+let valid_tyvar_name name =
+  name <> "" && name.[0] <> '_'
+
+let transl_type_param env styp =
+  let loc = styp.ptyp_loc in
+  match styp.ptyp_desc with
+    Ptyp_any ->
+      let ty = new_global_var ~name:"_" () in
+        { ctyp_desc = Ttyp_any; ctyp_type = ty; ctyp_env = env;
+          ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; }
+  | Ptyp_var name ->
+      let ty =
+        try
+          if not (valid_tyvar_name name) then
+            raise (Error (loc, Env.empty, Invalid_variable_name ("'" ^ name)));
+          ignore (TyVarMap.find name !type_variables);
+          raise Already_bound
+        with Not_found ->
+          let v = new_global_var ~name () in
+            type_variables := TyVarMap.add name v !type_variables;
+            v
+      in
+        { ctyp_desc = Ttyp_var name; ctyp_type = ty; ctyp_env = env;
+          ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; }
+  | _ -> assert false
+
+let transl_type_param env styp =
+  (* Currently useless, since type parameters cannot hold attributes
+     (but this could easily be lifted in the future). *)
+  Builtin_attributes.warning_scope styp.ptyp_attributes
+    (fun () -> transl_type_param env styp)
+
+
+let new_pre_univar ?name () =
+  let v = newvar ?name () in pre_univars := v :: !pre_univars; v
+
+type policy = Fixed | Extensible | Univars
+
+let rec transl_type env policy styp =
+  Builtin_attributes.warning_scope styp.ptyp_attributes
+    (fun () -> transl_type_aux env policy styp)
+
+and transl_type_aux env policy styp =
+  let loc = styp.ptyp_loc in
+  let ctyp ctyp_desc ctyp_type =
+    { ctyp_desc; ctyp_type; ctyp_env = env;
+      ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes }
+  in
+  match styp.ptyp_desc with
+    Ptyp_any ->
+      let ty =
+        if policy = Univars then new_pre_univar () else
+          if policy = Fixed then
+            raise (Error (styp.ptyp_loc, env, Unbound_type_variable "_"))
+          else newvar ()
+      in
+      ctyp Ttyp_any ty
+  | Ptyp_var name ->
+    let ty =
+      if not (valid_tyvar_name name) then
+        raise (Error (styp.ptyp_loc, env, Invalid_variable_name ("'" ^ name)));
+      begin try
+        instance (List.assoc name !univars)
+      with Not_found -> try
+        instance (fst (TyVarMap.find name !used_variables))
+      with Not_found ->
+        let v =
+          if policy = Univars then new_pre_univar ~name () else newvar ~name ()
+        in
+        used_variables := TyVarMap.add name (v, styp.ptyp_loc) !used_variables;
+        v
+      end
+    in
+    ctyp (Ttyp_var name) ty
+  | Ptyp_arrow(l, st1, st2) ->
+    let cty1 = transl_type env policy st1 in
+    let cty2 = transl_type env policy st2 in
+    let ty1 = cty1.ctyp_type in
+    let ty1 =
+      if Btype.is_optional l
+      then newty (Tconstr(Predef.path_option,[ty1], ref Mnil))
+      else ty1 in
+    let ty = newty (Tarrow(l, ty1, cty2.ctyp_type, Cok)) in
+    ctyp (Ttyp_arrow (l, cty1, cty2)) ty
+  | Ptyp_tuple stl ->
+    assert (List.length stl >= 2);
+    let ctys = List.map (transl_type env policy) stl in
+    let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in
+    ctyp (Ttyp_tuple ctys) ty
+  | Ptyp_constr(lid, stl) ->
+      let (path, decl) = Env.lookup_type ~loc:lid.loc lid.txt env in
+      let stl =
+        match stl with
+        | [ {ptyp_desc=Ptyp_any} as t ] when decl.type_arity > 1 ->
+            List.map (fun _ -> t) decl.type_params
+        | _ -> stl
+      in
+      if List.length stl <> decl.type_arity then
+        raise(Error(styp.ptyp_loc, env,
+                    Type_arity_mismatch(lid.txt, decl.type_arity,
+                                        List.length stl)));
+      let args = List.map (transl_type env policy) stl in
+      let params = instance_list decl.type_params in
+      let unify_param =
+        match decl.type_manifest with
+          None -> unify_var
+        | Some ty ->
+            if (repr ty).level = Btype.generic_level then unify_var else unify
+      in
+      List.iter2
+        (fun (sty, cty) ty' ->
+           try unify_param env ty' cty.ctyp_type with Unify trace ->
+             let trace = Unification_trace.swap trace in
+             raise (Error(sty.ptyp_loc, env, Type_mismatch trace))
+        )
+        (List.combine stl args) params;
+      let constr =
+        newconstr path (List.map (fun ctyp -> ctyp.ctyp_type) args) in
+      begin try
+        Ctype.enforce_constraints env constr
+      with Unify trace ->
+        raise (Error(styp.ptyp_loc, env, Type_mismatch trace))
+      end;
+      ctyp (Ttyp_constr (path, lid, args)) constr
+  | Ptyp_object (fields, o) ->
+      let ty, fields = transl_fields env policy o fields in
+      ctyp (Ttyp_object (fields, o)) (newobj ty)
+  | Ptyp_class(lid, stl) ->
+      let (path, decl, _is_variant) =
+        try
+          let path, decl = Env.find_type_by_name lid.txt env in
+          let rec check decl =
+            match decl.type_manifest with
+              None -> raise Not_found
+            | Some ty ->
+                match (repr ty).desc with
+                  Tvariant row when Btype.static_row row -> ()
+                | Tconstr (path, _, _) ->
+                    check (Env.find_type path env)
+                | _ -> raise Not_found
+          in check decl;
+          Location.deprecated styp.ptyp_loc
+            "old syntax for polymorphic variant type";
+          ignore(Env.lookup_type ~loc:lid.loc lid.txt env);
+          (path, decl,true)
+        with Not_found -> try
+          let lid2 =
+            match lid.txt with
+              Longident.Lident s     -> Longident.Lident ("#" ^ s)
+            | Longident.Ldot(r, s)   -> Longident.Ldot (r, "#" ^ s)
+            | Longident.Lapply(_, _) -> fatal_error "Typetexp.transl_type"
+          in
+          let path, decl = Env.find_type_by_name lid2 env in
+          ignore(Env.lookup_cltype ~loc:lid.loc lid.txt env);
+          (path, decl, false)
+        with Not_found ->
+          ignore (Env.lookup_cltype ~loc:lid.loc lid.txt env); assert false
+      in
+      if List.length stl <> decl.type_arity then
+        raise(Error(styp.ptyp_loc, env,
+                    Type_arity_mismatch(lid.txt, decl.type_arity,
+                                        List.length stl)));
+      let args = List.map (transl_type env policy) stl in
+      let params = instance_list decl.type_params in
+      List.iter2
+        (fun (sty, cty) ty' ->
+           try unify_var env ty' cty.ctyp_type with Unify trace ->
+             let trace = Unification_trace.swap trace in
+             raise (Error(sty.ptyp_loc, env, Type_mismatch trace))
+        )
+        (List.combine stl args) params;
+        let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in
+      let ty =
+        try Ctype.expand_head env (newconstr path ty_args)
+        with Unify trace ->
+          raise (Error(styp.ptyp_loc, env, Type_mismatch trace))
+      in
+      let ty = match ty.desc with
+        Tvariant row ->
+          let row = Btype.row_repr row in
+          let fields =
+            List.map
+              (fun (l,f) -> l,
+                match Btype.row_field_repr f with
+                | Rpresent (Some ty) ->
+                    Reither(false, [ty], false, ref None)
+                | Rpresent None ->
+                    Reither (true, [], false, ref None)
+                | _ -> f)
+              row.row_fields
+          in
+          let row = { row_closed = true; row_fields = fields;
+                      row_bound = (); row_name = Some (path, ty_args);
+                      row_fixed = None; row_more = newvar () } in
+          let static = Btype.static_row row in
+          let row =
+            if static then { row with row_more = newty Tnil }
+            else if policy <> Univars then row
+            else { row with row_more = new_pre_univar () }
+          in
+          newty (Tvariant row)
+      | Tobject (fi, _) ->
+          let _, tv = flatten_fields fi in
+          if policy = Univars then pre_univars := tv :: !pre_univars;
+          ty
+      | _ ->
+          assert false
+      in
+      ctyp (Ttyp_class (path, lid, args)) ty
+  | Ptyp_alias(st, alias) ->
+      let cty =
+        try
+          let t =
+            try List.assoc alias !univars
+            with Not_found ->
+              instance (fst(TyVarMap.find alias !used_variables))
+          in
+          let ty = transl_type env policy st in
+          begin try unify_var env t ty.ctyp_type with Unify trace ->
+            let trace = Unification_trace.swap trace in
+            raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace))
+          end;
+          ty
+        with Not_found ->
+          if !Clflags.principal then begin_def ();
+          let t = newvar () in
+          used_variables :=
+            TyVarMap.add alias (t, styp.ptyp_loc) !used_variables;
+          let ty = transl_type env policy st in
+          begin try unify_var env t ty.ctyp_type with Unify trace ->
+            let trace = Unification_trace.swap trace in
+            raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace))
+          end;
+          if !Clflags.principal then begin
+            end_def ();
+            generalize_structure t;
+          end;
+          let t = instance t in
+          let px = Btype.proxy t in
+          begin match px.desc with
+          | Tvar None -> Btype.set_type_desc px (Tvar (Some alias))
+          | Tunivar None -> Btype.set_type_desc px (Tunivar (Some alias))
+          | _ -> ()
+          end;
+          { ty with ctyp_type = t }
+      in
+      ctyp (Ttyp_alias (cty, alias)) cty.ctyp_type
+  | Ptyp_variant(fields, closed, present) ->
+      let name = ref None in
+      let mkfield l f =
+        newty (Tvariant {row_fields=[l,f]; row_more=newvar();
+                         row_bound=(); row_closed=true;
+                         row_fixed=None; row_name=None}) in
+      let hfields = Hashtbl.create 17 in
+      let add_typed_field loc l f =
+        let h = Btype.hash_variant l in
+        try
+          let (l',f') = Hashtbl.find hfields h in
+          (* Check for tag conflicts *)
+          if l <> l' then raise(Error(styp.ptyp_loc, env, Variant_tags(l, l')));
+          let ty = mkfield l f and ty' = mkfield l f' in
+          if equal env false [ty] [ty'] then () else
+          try unify env ty ty'
+          with Unify _trace ->
+            raise(Error(loc, env, Constructor_mismatch (ty,ty')))
+        with Not_found ->
+          Hashtbl.add hfields h (l,f)
+      in
+      let add_field field =
+        let rf_loc = field.prf_loc in
+        let rf_attributes = field.prf_attributes in
+        let rf_desc = match field.prf_desc with
+        | Rtag (l, c, stl) ->
+            name := None;
+            let tl =
+              Builtin_attributes.warning_scope rf_attributes
+                (fun () -> List.map (transl_type env policy) stl)
+            in
+            let f = match present with
+              Some present when not (List.mem l.txt present) ->
+                let ty_tl = List.map (fun cty -> cty.ctyp_type) tl in
+                Reither(c, ty_tl, false, ref None)
+            | _ ->
+                if List.length stl > 1 || c && stl <> [] then
+                  raise(Error(styp.ptyp_loc, env,
+                              Present_has_conjunction l.txt));
+                match tl with [] -> Rpresent None
+                | st :: _ ->
+                      Rpresent (Some st.ctyp_type)
+            in
+            add_typed_field styp.ptyp_loc l.txt f;
+              Ttag (l,c,tl)
+        | Rinherit sty ->
+            let cty = transl_type env policy sty in
+            let ty = cty.ctyp_type in
+            let nm =
+              match repr cty.ctyp_type with
+                {desc=Tconstr(p, tl, _)} -> Some(p, tl)
+              | _                        -> None
+            in
+            name := if Hashtbl.length hfields <> 0 then None else nm;
+            let fl = match expand_head env cty.ctyp_type, nm with
+              {desc=Tvariant row}, _ when Btype.static_row row ->
+                let row = Btype.row_repr row in
+                row.row_fields
+            | {desc=Tvar _}, Some(p, _) ->
+                raise(Error(sty.ptyp_loc, env, Undefined_type_constructor p))
+            | _ ->
+                raise(Error(sty.ptyp_loc, env, Not_a_variant ty))
+            in
+            List.iter
+              (fun (l, f) ->
+                let f = match present with
+                  Some present when not (List.mem l present) ->
+                    begin match f with
+                      Rpresent(Some ty) ->
+                        Reither(false, [ty], false, ref None)
+                    | Rpresent None ->
+                        Reither(true, [], false, ref None)
+                    | _ ->
+                        assert false
+                    end
+                | _ -> f
+                in
+                add_typed_field sty.ptyp_loc l f)
+              fl;
+              Tinherit cty
+        in
+        { rf_desc; rf_loc; rf_attributes; }
+      in
+      let tfields = List.map add_field fields in
+      let fields = Hashtbl.fold (fun _ p l -> p :: l) hfields [] in
+      begin match present with None -> ()
+      | Some present ->
+          List.iter
+            (fun l -> if not (List.mem_assoc l fields) then
+              raise(Error(styp.ptyp_loc, env, Present_has_no_type l)))
+            present
+      end;
+      let row =
+        { row_fields = List.rev fields; row_more = newvar ();
+          row_bound = (); row_closed = (closed = Closed);
+          row_fixed = None; row_name = !name } in
+      let static = Btype.static_row row in
+      let row =
+        if static then { row with row_more = newty Tnil }
+        else if policy <> Univars then row
+        else { row with row_more = new_pre_univar () }
+      in
+      let ty = newty (Tvariant row) in
+      ctyp (Ttyp_variant (tfields, closed, present)) ty
+  | Ptyp_poly(vars, st) ->
+      let vars = List.map (fun v -> v.txt) vars in
+      begin_def();
+      let new_univars = List.map (fun name -> name, newvar ~name ()) vars in
+      let old_univars = !univars in
+      univars := new_univars @ !univars;
+      let cty = transl_type env policy st in
+      let ty = cty.ctyp_type in
+      univars := old_univars;
+      end_def();
+      generalize ty;
+      let ty_list =
+        List.fold_left
+          (fun tyl (name, ty1) ->
+            let v = Btype.proxy ty1 in
+            if deep_occur v ty then begin
+              match v.desc with
+                Tvar name when v.level = Btype.generic_level ->
+                  v.desc <- Tunivar name;
+                  v :: tyl
+              | _ ->
+                raise (Error (styp.ptyp_loc, env, Cannot_quantify (name, v)))
+            end else tyl)
+          [] new_univars
+      in
+      let ty' = Btype.newgenty (Tpoly(ty, List.rev ty_list)) in
+      unify_var env (newvar()) ty';
+      ctyp (Ttyp_poly (vars, cty)) ty'
+  | Ptyp_package (p, l) ->
+      let l, mty = create_package_mty true styp.ptyp_loc env (p, l) in
+      let z = narrow () in
+      let mty = !transl_modtype env mty in
+      widen z;
+      let ptys = List.map (fun (s, pty) ->
+                             s, transl_type env policy pty
+                          ) l in
+      let path = !transl_modtype_longident styp.ptyp_loc env p.txt in
+      let ty = newty (Tpackage (path,
+                       List.map (fun (s, _pty) -> s.txt) l,
+                       List.map (fun (_,cty) -> cty.ctyp_type) ptys))
+      in
+      ctyp (Ttyp_package {
+            pack_path = path;
+            pack_type = mty.mty_type;
+            pack_fields = ptys;
+            pack_txt = p;
+           }) ty
+  | Ptyp_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and transl_poly_type env policy t =
+  transl_type env policy (Ast_helper.Typ.force_poly t)
+
+and transl_fields env policy o fields =
+  let hfields = Hashtbl.create 17 in
+  let add_typed_field loc l ty =
+    try
+      let ty' = Hashtbl.find hfields l in
+      if equal env false [ty] [ty'] then () else
+        try unify env ty ty'
+        with Unify _trace ->
+          raise(Error(loc, env, Method_mismatch (l, ty, ty')))
+    with Not_found ->
+      Hashtbl.add hfields l ty in
+  let add_field {pof_desc; pof_loc; pof_attributes;} =
+    let of_loc = pof_loc in
+    let of_attributes = pof_attributes in
+    let of_desc = match pof_desc with
+    | Otag (s, ty1) -> begin
+        let ty1 =
+          Builtin_attributes.warning_scope of_attributes
+            (fun () -> transl_poly_type env policy ty1)
+        in
+        let field = OTtag (s, ty1) in
+        add_typed_field ty1.ctyp_loc s.txt ty1.ctyp_type;
+        field
+      end
+    | Oinherit sty -> begin
+        let cty = transl_type env policy sty in
+        let nm =
+          match repr cty.ctyp_type with
+            {desc=Tconstr(p, _, _)} -> Some p
+          | _                        -> None in
+        let t = expand_head env cty.ctyp_type in
+        match t, nm with
+          {desc=Tobject ({desc=(Tfield _ | Tnil) as tf}, _)}, _ -> begin
+            if opened_object t then
+              raise (Error (sty.ptyp_loc, env, Opened_object nm));
+            let rec iter_add = function
+              | Tfield (s, _k, ty1, ty2) -> begin
+                  add_typed_field sty.ptyp_loc s ty1;
+                  iter_add ty2.desc
+                end
+              | Tnil -> ()
+              | _ -> assert false in
+            iter_add tf;
+            OTinherit cty
+            end
+        | {desc=Tvar _}, Some p ->
+            raise (Error (sty.ptyp_loc, env, Undefined_type_constructor p))
+        | _ -> raise (Error (sty.ptyp_loc, env, Not_an_object t))
+      end in
+    { of_desc; of_loc; of_attributes; }
+  in
+  let object_fields = List.map add_field fields in
+  let fields = Hashtbl.fold (fun s ty l -> (s, ty) :: l) hfields [] in
+  let ty_init =
+     match o, policy with
+     | Closed, _ -> newty Tnil
+     | Open, Univars -> new_pre_univar ()
+     | Open, _ -> newvar () in
+  let ty = List.fold_left (fun ty (s, ty') ->
+      newty (Tfield (s, Fpresent, ty', ty))) ty_init fields in
+  ty, object_fields
+
+
+(* Make the rows "fixed" in this type, to make universal check easier *)
+let rec make_fixed_univars ty =
+  let ty = repr ty in
+  if ty.level >= Btype.lowest_level then begin
+    Btype.mark_type_node ty;
+    match ty.desc with
+    | Tvariant row ->
+        let row = Btype.row_repr row in
+        let more = Btype.row_more row in
+        if Btype.is_Tunivar more then
+          ty.desc <- Tvariant
+              {row with row_fixed=Some(Univar more);
+               row_fields = List.map
+                 (fun (s,f as p) -> match Btype.row_field_repr f with
+                   Reither (c, tl, _m, r) -> s, Reither (c, tl, true, r)
+                 | _ -> p)
+                 row.row_fields};
+        Btype.iter_row make_fixed_univars row
+    | _ ->
+        Btype.iter_type_expr make_fixed_univars ty
+  end
+
+let make_fixed_univars ty =
+  make_fixed_univars ty;
+  Btype.unmark_type ty
+
+let create_package_mty = create_package_mty false
+
+let globalize_used_variables env fixed =
+  let r = ref [] in
+  TyVarMap.iter
+    (fun name (ty, loc) ->
+      let v = new_global_var () in
+      let snap = Btype.snapshot () in
+      if try unify env v ty; true with _ -> Btype.backtrack snap; false
+      then try
+        r := (loc, v,  TyVarMap.find name !type_variables) :: !r
+      with Not_found ->
+        if fixed && Btype.is_Tvar (repr ty) then
+          raise(Error(loc, env, Unbound_type_variable ("'"^name)));
+        let v2 = new_global_var () in
+        r := (loc, v, v2) :: !r;
+        type_variables := TyVarMap.add name v2 !type_variables)
+    !used_variables;
+  used_variables := TyVarMap.empty;
+  fun () ->
+    List.iter
+      (function (loc, t1, t2) ->
+        try unify env t1 t2 with Unify trace ->
+          raise (Error(loc, env, Type_mismatch trace)))
+      !r
+
+let transl_simple_type env fixed styp =
+  univars := []; used_variables := TyVarMap.empty;
+  let typ = transl_type env (if fixed then Fixed else Extensible) styp in
+  globalize_used_variables env fixed ();
+  make_fixed_univars typ.ctyp_type;
+  typ
+
+let transl_simple_type_univars env styp =
+  univars := []; used_variables := TyVarMap.empty; pre_univars := [];
+  begin_def ();
+  let typ = transl_type env Univars styp in
+  (* Only keep already global variables in used_variables *)
+  let new_variables = !used_variables in
+  used_variables := TyVarMap.empty;
+  TyVarMap.iter
+    (fun name p ->
+      if TyVarMap.mem name !type_variables then
+        used_variables := TyVarMap.add name p !used_variables)
+    new_variables;
+  globalize_used_variables env false ();
+  end_def ();
+  generalize typ.ctyp_type;
+  let univs =
+    List.fold_left
+      (fun acc v ->
+        let v = repr v in
+        match v.desc with
+          Tvar name when v.level = Btype.generic_level ->
+            v.desc <- Tunivar name; v :: acc
+        | _ -> acc)
+      [] !pre_univars
+  in
+  make_fixed_univars typ.ctyp_type;
+    { typ with ctyp_type =
+        instance (Btype.newgenty (Tpoly (typ.ctyp_type, univs))) }
+
+let transl_simple_type_delayed env styp =
+  univars := []; used_variables := TyVarMap.empty;
+  begin_def ();
+  let typ = transl_type env Extensible styp in
+  end_def ();
+  make_fixed_univars typ.ctyp_type;
+  (* This brings the used variables to the global level, but doesn't link them
+     to their other occurrences just yet. This will be done when [force] is
+     called. *)
+  let force = globalize_used_variables env false in
+  (* Generalizes everything except the variables that were just globalized. *)
+  generalize typ.ctyp_type;
+  (typ, instance typ.ctyp_type, force)
+
+let transl_type_scheme env styp =
+  reset_type_variables();
+  begin_def();
+  let typ = transl_simple_type env false styp in
+  end_def();
+  generalize typ.ctyp_type;
+  typ
+
+
+(* Error report *)
+
+open Format
+open Printtyp
+
+let report_error env ppf = function
+  | Unbound_type_variable name ->
+      let add_name name _ l = if name = "_" then l else ("'" ^ name) :: l in
+      let names = TyVarMap.fold add_name !type_variables [] in
+    fprintf ppf "The type variable %s is unbound in this type declaration.@ %a"
+      name
+      did_you_mean (fun () -> Misc.spellcheck names name )
+  | Undefined_type_constructor p ->
+    fprintf ppf "The type constructor@ %a@ is not yet completely defined"
+      path p
+  | Type_arity_mismatch(lid, expected, provided) ->
+    fprintf ppf
+      "@[The type constructor %a@ expects %i argument(s),@ \
+        but is here applied to %i argument(s)@]"
+      longident lid expected provided
+  | Bound_type_variable name ->
+    fprintf ppf "Already bound type parameter %a" Pprintast.tyvar name
+  | Recursive_type ->
+    fprintf ppf "This type is recursive"
+  | Unbound_row_variable lid ->
+      (* we don't use "spellcheck" here: this error is not raised
+         anywhere so it's unclear how it should be handled *)
+      fprintf ppf "Unbound row variable in #%a" longident lid
+  | Type_mismatch trace ->
+      Printtyp.report_unification_error ppf Env.empty trace
+        (function ppf ->
+           fprintf ppf "This type")
+        (function ppf ->
+           fprintf ppf "should be an instance of type")
+  | Alias_type_mismatch trace ->
+      Printtyp.report_unification_error ppf Env.empty trace
+        (function ppf ->
+           fprintf ppf "This alias is bound to type")
+        (function ppf ->
+           fprintf ppf "but is used as an instance of type")
+  | Present_has_conjunction l ->
+      fprintf ppf "The present constructor %s has a conjunctive type" l
+  | Present_has_no_type l ->
+      fprintf ppf
+        "@[<v>@[The constructor %s is missing from the upper bound@ \
+         (between '<'@ and '>')@ of this polymorphic variant@ \
+         but is present in@ its lower bound (after '>').@]@,\
+         @[Hint: Either add `%s in the upper bound,@ \
+         or remove it@ from the lower bound.@]@]"
+         l l
+  | Constructor_mismatch (ty, ty') ->
+      wrap_printing_env ~error:true env (fun ()  ->
+        Printtyp.reset_and_mark_loops_list [ty; ty'];
+        fprintf ppf "@[<hov>%s %a@ %s@ %a@]"
+          "This variant type contains a constructor"
+          !Oprint.out_type (tree_of_typexp false ty)
+          "which should be"
+           !Oprint.out_type (tree_of_typexp false ty'))
+  | Not_a_variant ty ->
+      fprintf ppf
+        "@[The type %a@ does not expand to a polymorphic variant type@]"
+        Printtyp.type_expr ty;
+      begin match ty.desc with
+        | Tvar (Some s) ->
+           (* PR#7012: help the user that wrote 'Foo instead of `Foo *)
+           Misc.did_you_mean ppf (fun () -> ["`" ^ s])
+        | _ -> ()
+      end
+  | Variant_tags (lab1, lab2) ->
+      fprintf ppf
+        "@[Variant tags `%s@ and `%s have the same hash value.@ %s@]"
+        lab1 lab2 "Change one of them."
+  | Invalid_variable_name name ->
+      fprintf ppf "The type variable name %s is not allowed in programs" name
+  | Cannot_quantify (name, v) ->
+      fprintf ppf
+        "@[<hov>The universal type variable %a cannot be generalized:@ "
+        Pprintast.tyvar name;
+      if Btype.is_Tvar v then
+        fprintf ppf "it escapes its scope"
+      else if Btype.is_Tunivar v then
+        fprintf ppf "it is already bound to another variable"
+      else
+        fprintf ppf "it is bound to@ %a" Printtyp.type_expr v;
+      fprintf ppf ".@]";
+  | Multiple_constraints_on_type s ->
+      fprintf ppf "Multiple constraints for type %a" longident s
+  | Method_mismatch (l, ty, ty') ->
+      wrap_printing_env ~error:true env (fun ()  ->
+        fprintf ppf "@[<hov>Method '%s' has type %a,@ which should be %a@]"
+          l Printtyp.type_expr ty Printtyp.type_expr ty')
+  | Opened_object nm ->
+      fprintf ppf
+        "Illegal open object type%a"
+        (fun ppf -> function
+             Some p -> fprintf ppf "@ %a" path p
+           | None -> fprintf ppf "") nm
+  | Not_an_object ty ->
+      fprintf ppf "@[The type %a@ is not an object type@]"
+        Printtyp.type_expr ty
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, env, err) ->
+        Some (Location.error_of_printer ~loc (report_error env) err)
+      | Error_forward err ->
+        Some err
+      | _ ->
+        None
+    )
diff --git a/upstream/ocaml_412/typing/typetexp.mli b/upstream/ocaml_412/typing/typetexp.mli
new file mode 100644
index 0000000..602b7c7
--- /dev/null
+++ b/upstream/ocaml_412/typing/typetexp.mli
@@ -0,0 +1,79 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Typechecking of type expressions for the core language *)
+
+open Types
+
+val valid_tyvar_name : string -> bool
+
+val transl_simple_type:
+        Env.t -> bool -> Parsetree.core_type -> Typedtree.core_type
+val transl_simple_type_univars:
+        Env.t -> Parsetree.core_type -> Typedtree.core_type
+val transl_simple_type_delayed
+  :  Env.t
+  -> Parsetree.core_type
+  -> Typedtree.core_type * type_expr * (unit -> unit)
+        (* Translate a type, but leave type variables unbound. Returns
+           the type, an instance of the corresponding type_expr, and a
+           function that binds the type variable. *)
+val transl_type_scheme:
+        Env.t -> Parsetree.core_type -> Typedtree.core_type
+val reset_type_variables: unit -> unit
+val type_variable: Location.t -> string -> type_expr
+val transl_type_param:
+  Env.t -> Parsetree.core_type -> Typedtree.core_type
+
+type variable_context
+val narrow: unit -> variable_context
+val widen: variable_context -> unit
+
+exception Already_bound
+
+type error =
+    Unbound_type_variable of string
+  | Undefined_type_constructor of Path.t
+  | Type_arity_mismatch of Longident.t * int * int
+  | Bound_type_variable of string
+  | Recursive_type
+  | Unbound_row_variable of Longident.t
+  | Type_mismatch of Ctype.Unification_trace.t
+  | Alias_type_mismatch of Ctype.Unification_trace.t
+  | Present_has_conjunction of string
+  | Present_has_no_type of string
+  | Constructor_mismatch of type_expr * type_expr
+  | Not_a_variant of type_expr
+  | Variant_tags of string * string
+  | Invalid_variable_name of string
+  | Cannot_quantify of string * type_expr
+  | Multiple_constraints_on_type of Longident.t
+  | Method_mismatch of string * type_expr * type_expr
+  | Opened_object of Path.t option
+  | Not_an_object of type_expr
+
+exception Error of Location.t * Env.t * error
+
+val report_error: Env.t -> Format.formatter -> error -> unit
+
+(* Support for first-class modules. *)
+val transl_modtype_longident:  (* from Typemod *)
+    (Location.t -> Env.t -> Longident.t -> Path.t) ref
+val transl_modtype: (* from Typemod *)
+    (Env.t -> Parsetree.module_type -> Typedtree.module_type) ref
+val create_package_mty:
+    Location.t -> Env.t -> Parsetree.package_type ->
+    (Longident.t Asttypes.loc * Parsetree.core_type) list *
+      Parsetree.module_type
diff --git a/upstream/ocaml_412/typing/untypeast.ml b/upstream/ocaml_412/typing/untypeast.ml
new file mode 100644
index 0000000..dc36aaf
--- /dev/null
+++ b/upstream/ocaml_412/typing/untypeast.ml
@@ -0,0 +1,895 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*    Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay)     *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Longident
+open Asttypes
+open Parsetree
+open Ast_helper
+
+module T = Typedtree
+
+type mapper = {
+  attribute: mapper -> T.attribute -> attribute;
+  attributes: mapper -> T.attribute list -> attribute list;
+  binding_op: mapper -> T.binding_op -> T.pattern -> binding_op;
+  case: 'k . mapper -> 'k T.case -> case;
+  class_declaration: mapper -> T.class_declaration -> class_declaration;
+  class_description: mapper -> T.class_description -> class_description;
+  class_expr: mapper -> T.class_expr -> class_expr;
+  class_field: mapper -> T.class_field -> class_field;
+  class_signature: mapper -> T.class_signature -> class_signature;
+  class_structure: mapper -> T.class_structure -> class_structure;
+  class_type: mapper -> T.class_type -> class_type;
+  class_type_declaration: mapper -> T.class_type_declaration
+                          -> class_type_declaration;
+  class_type_field: mapper -> T.class_type_field -> class_type_field;
+  constructor_declaration: mapper -> T.constructor_declaration
+                           -> constructor_declaration;
+  expr: mapper -> T.expression -> expression;
+  extension_constructor: mapper -> T.extension_constructor
+                         -> extension_constructor;
+  include_declaration: mapper -> T.include_declaration -> include_declaration;
+  include_description: mapper -> T.include_description -> include_description;
+  label_declaration: mapper -> T.label_declaration -> label_declaration;
+  location: mapper -> Location.t -> Location.t;
+  module_binding: mapper -> T.module_binding -> module_binding;
+  module_declaration: mapper -> T.module_declaration -> module_declaration;
+  module_substitution: mapper -> T.module_substitution -> module_substitution;
+  module_expr: mapper -> T.module_expr -> module_expr;
+  module_type: mapper -> T.module_type -> module_type;
+  module_type_declaration:
+    mapper -> T.module_type_declaration -> module_type_declaration;
+  package_type: mapper -> T.package_type -> package_type;
+  open_declaration: mapper -> T.open_declaration -> open_declaration;
+  open_description: mapper -> T.open_description -> open_description;
+  pat: 'k . mapper -> 'k T.general_pattern -> pattern;
+  row_field: mapper -> T.row_field -> row_field;
+  object_field: mapper -> T.object_field -> object_field;
+  signature: mapper -> T.signature -> signature;
+  signature_item: mapper -> T.signature_item -> signature_item;
+  structure: mapper -> T.structure -> structure;
+  structure_item: mapper -> T.structure_item -> structure_item;
+  typ: mapper -> T.core_type -> core_type;
+  type_declaration: mapper -> T.type_declaration -> type_declaration;
+  type_extension: mapper -> T.type_extension -> type_extension;
+  type_exception: mapper -> T.type_exception -> type_exception;
+  type_kind: mapper -> T.type_kind -> type_kind;
+  value_binding: mapper -> T.value_binding -> value_binding;
+  value_description: mapper -> T.value_description -> value_description;
+  with_constraint:
+    mapper -> (Path.t * Longident.t Location.loc * T.with_constraint)
+    -> with_constraint;
+}
+
+open T
+
+(*
+Some notes:
+
+   * For Pexp_function, we cannot go back to the exact original version
+   when there is a default argument, because the default argument is
+   translated in the typer. The code, if printed, will not be parsable because
+   new generated identifiers are not correct.
+
+   * For Pexp_apply, it is unclear whether arguments are reordered, especially
+    when there are optional arguments.
+
+*)
+
+
+(** Utility functions. *)
+
+let string_is_prefix sub str =
+  let sublen = String.length sub in
+  String.length str >= sublen && String.sub str 0 sublen = sub
+
+let rec lident_of_path = function
+  | Path.Pident id -> Longident.Lident (Ident.name id)
+  | Path.Pdot (p, s) -> Longident.Ldot (lident_of_path p, s)
+  | Path.Papply (p1, p2) ->
+      Longident.Lapply (lident_of_path p1, lident_of_path p2)
+
+let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}
+
+(** Try a name [$name$0], check if it's free, if not, increment and repeat. *)
+let fresh_name s env =
+  let rec aux i =
+    let name = s ^ Int.to_string i in
+    if Env.bound_value name env then aux (i+1)
+    else name
+  in
+  aux 0
+
+(** Extract the [n] patterns from the case of a letop *)
+let rec extract_letop_patterns n pat =
+  if n = 0 then pat, []
+  else begin
+    match pat.pat_desc with
+    | Tpat_tuple([first; rest]) ->
+        let next, others = extract_letop_patterns (n-1) rest in
+        first, next :: others
+    | _ ->
+      let rec anys n =
+        if n = 0 then []
+        else { pat with pat_desc = Tpat_any } :: anys (n-1)
+      in
+      { pat with pat_desc = Tpat_any }, anys (n-1)
+  end
+
+(** Mapping functions. *)
+
+let constant = function
+  | Const_char c -> Pconst_char c
+  | Const_string (s,loc,d) -> Pconst_string (s,loc,d)
+  | Const_int i -> Pconst_integer (Int.to_string i, None)
+  | Const_int32 i -> Pconst_integer (Int32.to_string i, Some 'l')
+  | Const_int64 i -> Pconst_integer (Int64.to_string i, Some 'L')
+  | Const_nativeint i -> Pconst_integer (Nativeint.to_string i, Some 'n')
+  | Const_float f -> Pconst_float (f,None)
+
+let attribute sub a = {
+    attr_name = map_loc sub a.attr_name;
+    attr_payload = a.attr_payload;
+    attr_loc = a.attr_loc
+  }
+
+let attributes sub l = List.map (sub.attribute sub) l
+
+let structure sub str =
+  List.map (sub.structure_item sub) str.str_items
+
+let open_description sub od =
+  let loc = sub.location sub od.open_loc in
+  let attrs = sub.attributes sub od.open_attributes in
+  Opn.mk ~loc ~attrs
+    ~override:od.open_override
+    (snd od.open_expr)
+
+let open_declaration sub od =
+  let loc = sub.location sub od.open_loc in
+  let attrs = sub.attributes sub od.open_attributes in
+  Opn.mk ~loc ~attrs
+    ~override:od.open_override
+    (sub.module_expr sub od.open_expr)
+
+let structure_item sub item =
+  let loc = sub.location sub item.str_loc in
+  let desc =
+    match item.str_desc with
+      Tstr_eval (exp, attrs) -> Pstr_eval (sub.expr sub exp, attrs)
+    | Tstr_value (rec_flag, list) ->
+        Pstr_value (rec_flag, List.map (sub.value_binding sub) list)
+    | Tstr_primitive vd ->
+        Pstr_primitive (sub.value_description sub vd)
+    | Tstr_type (rec_flag, list) ->
+        Pstr_type (rec_flag, List.map (sub.type_declaration sub) list)
+    | Tstr_typext tyext ->
+        Pstr_typext (sub.type_extension sub tyext)
+    | Tstr_exception ext ->
+        Pstr_exception (sub.type_exception sub ext)
+    | Tstr_module mb ->
+        Pstr_module (sub.module_binding sub mb)
+    | Tstr_recmodule list ->
+        Pstr_recmodule (List.map (sub.module_binding sub) list)
+    | Tstr_modtype mtd ->
+        Pstr_modtype (sub.module_type_declaration sub mtd)
+    | Tstr_open od ->
+        Pstr_open (sub.open_declaration sub od)
+    | Tstr_class list ->
+        Pstr_class
+          (List.map
+             (fun (ci, _) -> sub.class_declaration sub ci)
+             list)
+    | Tstr_class_type list ->
+        Pstr_class_type
+          (List.map
+             (fun (_id, _name, ct) -> sub.class_type_declaration sub ct)
+             list)
+    | Tstr_include incl ->
+        Pstr_include (sub.include_declaration sub incl)
+    | Tstr_attribute x ->
+        Pstr_attribute x
+  in
+  Str.mk ~loc desc
+
+let value_description sub v =
+  let loc = sub.location sub v.val_loc in
+  let attrs = sub.attributes sub v.val_attributes in
+  Val.mk ~loc ~attrs
+    ~prim:v.val_prim
+    (map_loc sub v.val_name)
+    (sub.typ sub v.val_desc)
+
+let module_binding sub mb =
+  let loc = sub.location sub mb.mb_loc in
+  let attrs = sub.attributes sub mb.mb_attributes in
+  Mb.mk ~loc ~attrs
+    (map_loc sub mb.mb_name)
+    (sub.module_expr sub mb.mb_expr)
+
+let type_parameter sub (ct, v) = (sub.typ sub ct, v)
+
+let type_declaration sub decl =
+  let loc = sub.location sub decl.typ_loc in
+  let attrs = sub.attributes sub decl.typ_attributes in
+  Type.mk ~loc ~attrs
+    ~params:(List.map (type_parameter sub) decl.typ_params)
+    ~cstrs:(
+      List.map
+        (fun (ct1, ct2, loc) ->
+           (sub.typ sub ct1, sub.typ sub ct2, sub.location sub loc))
+        decl.typ_cstrs)
+    ~kind:(sub.type_kind sub decl.typ_kind)
+    ~priv:decl.typ_private
+    ?manifest:(Option.map (sub.typ sub) decl.typ_manifest)
+    (map_loc sub decl.typ_name)
+
+let type_kind sub tk = match tk with
+  | Ttype_abstract -> Ptype_abstract
+  | Ttype_variant list ->
+      Ptype_variant (List.map (sub.constructor_declaration sub) list)
+  | Ttype_record list ->
+      Ptype_record (List.map (sub.label_declaration sub) list)
+  | Ttype_open -> Ptype_open
+
+let constructor_arguments sub = function
+   | Cstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l)
+   | Cstr_record l -> Pcstr_record (List.map (sub.label_declaration sub) l)
+
+let constructor_declaration sub cd =
+  let loc = sub.location sub cd.cd_loc in
+  let attrs = sub.attributes sub cd.cd_attributes in
+  Type.constructor ~loc ~attrs
+    ~args:(constructor_arguments sub cd.cd_args)
+    ?res:(Option.map (sub.typ sub) cd.cd_res)
+    (map_loc sub cd.cd_name)
+
+let label_declaration sub ld =
+  let loc = sub.location sub ld.ld_loc in
+  let attrs = sub.attributes sub ld.ld_attributes in
+  Type.field ~loc ~attrs
+    ~mut:ld.ld_mutable
+    (map_loc sub ld.ld_name)
+    (sub.typ sub ld.ld_type)
+
+let type_extension sub tyext =
+  let attrs = sub.attributes sub tyext.tyext_attributes in
+  Te.mk ~attrs
+    ~params:(List.map (type_parameter sub) tyext.tyext_params)
+    ~priv:tyext.tyext_private
+    (map_loc sub tyext.tyext_txt)
+    (List.map (sub.extension_constructor sub) tyext.tyext_constructors)
+
+let type_exception sub tyexn =
+  let attrs = sub.attributes sub tyexn.tyexn_attributes in
+  Te.mk_exception ~attrs
+    (sub.extension_constructor sub tyexn.tyexn_constructor)
+
+let extension_constructor sub ext =
+  let loc = sub.location sub ext.ext_loc in
+  let attrs = sub.attributes sub ext.ext_attributes in
+  Te.constructor ~loc ~attrs
+    (map_loc sub ext.ext_name)
+    (match ext.ext_kind with
+      | Text_decl (args, ret) ->
+          Pext_decl (constructor_arguments sub args,
+                     Option.map (sub.typ sub) ret)
+      | Text_rebind (_p, lid) -> Pext_rebind (map_loc sub lid)
+    )
+
+let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat ->
+  let loc = sub.location sub pat.pat_loc in
+  (* todo: fix attributes on extras *)
+  let attrs = sub.attributes sub pat.pat_attributes in
+  let desc =
+  match pat with
+      { pat_extra=[Tpat_unpack, loc, _attrs]; pat_desc = Tpat_any; _ } ->
+        Ppat_unpack { txt = None; loc  }
+    | { pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } ->
+        Ppat_unpack { name with txt = Some name.txt }
+    | { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } ->
+        Ppat_type (map_loc sub lid)
+    | { pat_extra= (Tpat_constraint ct, _, _attrs) :: rem; _ } ->
+        Ppat_constraint (sub.pat sub { pat with pat_extra=rem },
+                         sub.typ sub ct)
+    | _ ->
+    match pat.pat_desc with
+      Tpat_any -> Ppat_any
+    | Tpat_var (id, name) ->
+        begin
+          match (Ident.name id).[0] with
+            'A'..'Z' ->
+              Ppat_unpack { name with txt = Some name.txt}
+          | _ ->
+              Ppat_var name
+        end
+
+    (* We transform (_ as x) in x if _ and x have the same location.
+       The compiler transforms (x:t) into (_ as x : t).
+       This avoids transforming a warning 27 into a 26.
+     *)
+    | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name)
+         when pat_loc = pat.pat_loc ->
+       Ppat_var name
+
+    | Tpat_alias (pat, _id, name) ->
+        Ppat_alias (sub.pat sub pat, name)
+    | Tpat_constant cst -> Ppat_constant (constant cst)
+    | Tpat_tuple list ->
+        Ppat_tuple (List.map (sub.pat sub) list)
+    | Tpat_construct (lid, _, args) ->
+        Ppat_construct (map_loc sub lid,
+          (match args with
+              [] -> None
+            | [arg] -> Some (sub.pat sub arg)
+            | args ->
+                Some
+                  (Pat.tuple ~loc
+                     (List.map (sub.pat sub) args)
+                  )
+          ))
+    | Tpat_variant (label, pato, _) ->
+        Ppat_variant (label, Option.map (sub.pat sub) pato)
+    | Tpat_record (list, closed) ->
+        Ppat_record (List.map (fun (lid, _, pat) ->
+            map_loc sub lid, sub.pat sub pat) list, closed)
+    | Tpat_array list -> Ppat_array (List.map (sub.pat sub) list)
+    | Tpat_lazy p -> Ppat_lazy (sub.pat sub p)
+
+    | Tpat_exception p -> Ppat_exception (sub.pat sub p)
+    | Tpat_value p -> (sub.pat sub (p :> pattern)).ppat_desc
+    | Tpat_or (p1, p2, _) -> Ppat_or (sub.pat sub p1, sub.pat sub p2)
+  in
+  Pat.mk ~loc ~attrs desc
+
+let exp_extra sub (extra, loc, attrs) sexp =
+  let loc = sub.location sub loc in
+  let attrs = sub.attributes sub attrs in
+  let desc =
+    match extra with
+      Texp_coerce (cty1, cty2) ->
+        Pexp_coerce (sexp,
+                     Option.map (sub.typ sub) cty1,
+                     sub.typ sub cty2)
+    | Texp_constraint cty ->
+        Pexp_constraint (sexp, sub.typ sub cty)
+    | Texp_poly cto -> Pexp_poly (sexp, Option.map (sub.typ sub) cto)
+    | Texp_newtype s -> Pexp_newtype (mkloc s loc, sexp)
+  in
+  Exp.mk ~loc ~attrs desc
+
+let case : type k . mapper -> k case -> _ = fun sub {c_lhs; c_guard; c_rhs} ->
+  {
+   pc_lhs = sub.pat sub c_lhs;
+   pc_guard = Option.map (sub.expr sub) c_guard;
+   pc_rhs = sub.expr sub c_rhs;
+  }
+
+let value_binding sub vb =
+  let loc = sub.location sub vb.vb_loc in
+  let attrs = sub.attributes sub vb.vb_attributes in
+  Vb.mk ~loc ~attrs
+    (sub.pat sub vb.vb_pat)
+    (sub.expr sub vb.vb_expr)
+
+let expression sub exp =
+  let loc = sub.location sub exp.exp_loc in
+  let attrs = sub.attributes sub exp.exp_attributes in
+  let desc =
+    match exp.exp_desc with
+      Texp_ident (_path, lid, _) -> Pexp_ident (map_loc sub lid)
+    | Texp_constant cst -> Pexp_constant (constant cst)
+    | Texp_let (rec_flag, list, exp) ->
+        Pexp_let (rec_flag,
+          List.map (sub.value_binding sub) list,
+          sub.expr sub exp)
+
+    (* Pexp_function can't have a label, so we split in 3 cases. *)
+    (* One case, no guard: It's a fun. *)
+    | Texp_function { arg_label; cases = [{c_lhs=p; c_guard=None; c_rhs=e}];
+          _ } ->
+        Pexp_fun (arg_label, None, sub.pat sub p, sub.expr sub e)
+    (* No label: it's a function. *)
+    | Texp_function { arg_label = Nolabel; cases; _; } ->
+        Pexp_function (List.map (sub.case sub) cases)
+    (* Mix of both, we generate `fun ~label:$name$ -> match $name$ with ...` *)
+    | Texp_function { arg_label = Labelled s | Optional s as label; cases;
+          _ } ->
+        let name = fresh_name s exp.exp_env in
+        Pexp_fun (label, None, Pat.var ~loc {loc;txt = name },
+          Exp.match_ ~loc (Exp.ident ~loc {loc;txt= Lident name})
+                          (List.map (sub.case sub) cases))
+    | Texp_apply (exp, list) ->
+        Pexp_apply (sub.expr sub exp,
+          List.fold_right (fun (label, expo) list ->
+              match expo with
+                None -> list
+              | Some exp -> (label, sub.expr sub exp) :: list
+          ) list [])
+    | Texp_match (exp, cases, _) ->
+      Pexp_match (sub.expr sub exp, List.map (sub.case sub) cases)
+    | Texp_try (exp, cases) ->
+        Pexp_try (sub.expr sub exp, List.map (sub.case sub) cases)
+    | Texp_tuple list ->
+        Pexp_tuple (List.map (sub.expr sub) list)
+    | Texp_construct (lid, _, args) ->
+        Pexp_construct (map_loc sub lid,
+          (match args with
+              [] -> None
+          | [ arg ] -> Some (sub.expr sub arg)
+          | args ->
+              Some
+                (Exp.tuple ~loc (List.map (sub.expr sub) args))
+          ))
+    | Texp_variant (label, expo) ->
+        Pexp_variant (label, Option.map (sub.expr sub) expo)
+    | Texp_record { fields; extended_expression; _ } ->
+        let list = Array.fold_left (fun l -> function
+            | _, Kept _ -> l
+            | _, Overridden (lid, exp) -> (lid, sub.expr sub exp) :: l)
+            [] fields
+        in
+        Pexp_record (list, Option.map (sub.expr sub) extended_expression)
+    | Texp_field (exp, lid, _label) ->
+        Pexp_field (sub.expr sub exp, map_loc sub lid)
+    | Texp_setfield (exp1, lid, _label, exp2) ->
+        Pexp_setfield (sub.expr sub exp1, map_loc sub lid,
+          sub.expr sub exp2)
+    | Texp_array list ->
+        Pexp_array (List.map (sub.expr sub) list)
+    | Texp_ifthenelse (exp1, exp2, expo) ->
+        Pexp_ifthenelse (sub.expr sub exp1,
+          sub.expr sub exp2,
+          Option.map (sub.expr sub) expo)
+    | Texp_sequence (exp1, exp2) ->
+        Pexp_sequence (sub.expr sub exp1, sub.expr sub exp2)
+    | Texp_while (exp1, exp2) ->
+        Pexp_while (sub.expr sub exp1, sub.expr sub exp2)
+    | Texp_for (_id, name, exp1, exp2, dir, exp3) ->
+        Pexp_for (name,
+          sub.expr sub exp1, sub.expr sub exp2,
+          dir, sub.expr sub exp3)
+    | Texp_send (exp, meth, _) ->
+        Pexp_send (sub.expr sub exp, match meth with
+            Tmeth_name name -> mkloc name loc
+          | Tmeth_val id -> mkloc (Ident.name id) loc)
+    | Texp_new (_path, lid, _) -> Pexp_new (map_loc sub lid)
+    | Texp_instvar (_, path, name) ->
+      Pexp_ident ({loc = sub.location sub name.loc ; txt = lident_of_path path})
+    | Texp_setinstvar (_, _path, lid, exp) ->
+        Pexp_setinstvar (map_loc sub lid, sub.expr sub exp)
+    | Texp_override (_, list) ->
+        Pexp_override (List.map (fun (_path, lid, exp) ->
+              (map_loc sub lid, sub.expr sub exp)
+          ) list)
+    | Texp_letmodule (_id, name, _pres, mexpr, exp) ->
+        Pexp_letmodule (name, sub.module_expr sub mexpr,
+          sub.expr sub exp)
+    | Texp_letexception (ext, exp) ->
+        Pexp_letexception (sub.extension_constructor sub ext,
+                           sub.expr sub exp)
+    | Texp_assert exp -> Pexp_assert (sub.expr sub exp)
+    | Texp_lazy exp -> Pexp_lazy (sub.expr sub exp)
+    | Texp_object (cl, _) ->
+        Pexp_object (sub.class_structure sub cl)
+    | Texp_pack (mexpr) ->
+        Pexp_pack (sub.module_expr sub mexpr)
+    | Texp_letop {let_; ands; body; _} ->
+        let pat, and_pats =
+          extract_letop_patterns (List.length ands) body.c_lhs
+        in
+        let let_ = sub.binding_op sub let_ pat in
+        let ands = List.map2 (sub.binding_op sub) ands and_pats in
+        let body = sub.expr sub body.c_rhs in
+        Pexp_letop {let_; ands; body }
+    | Texp_unreachable ->
+        Pexp_unreachable
+    | Texp_extension_constructor (lid, _) ->
+        Pexp_extension ({ txt = "ocaml.extension_constructor"; loc },
+                        PStr [ Str.eval ~loc
+                                 (Exp.construct ~loc (map_loc sub lid) None)
+                             ])
+    | Texp_open (od, exp) ->
+        Pexp_open (sub.open_declaration sub od, sub.expr sub exp)
+  in
+  List.fold_right (exp_extra sub) exp.exp_extra
+    (Exp.mk ~loc ~attrs desc)
+
+let binding_op sub bop pat =
+  let pbop_op = bop.bop_op_name in
+  let pbop_pat = sub.pat sub pat in
+  let pbop_exp = sub.expr sub bop.bop_exp in
+  let pbop_loc = bop.bop_loc in
+  {pbop_op; pbop_pat; pbop_exp; pbop_loc}
+
+let package_type sub pack =
+  (map_loc sub pack.pack_txt,
+    List.map (fun (s, ct) ->
+        (s, sub.typ sub ct)) pack.pack_fields)
+
+let module_type_declaration sub mtd =
+  let loc = sub.location sub mtd.mtd_loc in
+  let attrs = sub.attributes sub mtd.mtd_attributes in
+  Mtd.mk ~loc ~attrs
+    ?typ:(Option.map (sub.module_type sub) mtd.mtd_type)
+    (map_loc sub mtd.mtd_name)
+
+let signature sub sg =
+  List.map (sub.signature_item sub) sg.sig_items
+
+let signature_item sub item =
+  let loc = sub.location sub item.sig_loc in
+  let desc =
+    match item.sig_desc with
+      Tsig_value v ->
+        Psig_value (sub.value_description sub v)
+    | Tsig_type (rec_flag, list) ->
+        Psig_type (rec_flag, List.map (sub.type_declaration sub) list)
+    | Tsig_typesubst list ->
+        Psig_typesubst (List.map (sub.type_declaration sub) list)
+    | Tsig_typext tyext ->
+        Psig_typext (sub.type_extension sub tyext)
+    | Tsig_exception ext ->
+        Psig_exception (sub.type_exception sub ext)
+    | Tsig_module md ->
+        Psig_module (sub.module_declaration sub md)
+    | Tsig_modsubst ms ->
+        Psig_modsubst (sub.module_substitution sub ms)
+    | Tsig_recmodule list ->
+        Psig_recmodule (List.map (sub.module_declaration sub) list)
+    | Tsig_modtype mtd ->
+        Psig_modtype (sub.module_type_declaration sub mtd)
+    | Tsig_open od ->
+        Psig_open (sub.open_description sub od)
+    | Tsig_include incl ->
+        Psig_include (sub.include_description sub incl)
+    | Tsig_class list ->
+        Psig_class (List.map (sub.class_description sub) list)
+    | Tsig_class_type list ->
+        Psig_class_type (List.map (sub.class_type_declaration sub) list)
+    | Tsig_attribute x ->
+        Psig_attribute x
+  in
+  Sig.mk ~loc desc
+
+let module_declaration sub md =
+  let loc = sub.location sub md.md_loc in
+  let attrs = sub.attributes sub md.md_attributes in
+  Md.mk ~loc ~attrs
+    (map_loc sub md.md_name)
+    (sub.module_type sub md.md_type)
+
+let module_substitution sub ms =
+  let loc = sub.location sub ms.ms_loc in
+  let attrs = sub.attributes sub ms.ms_attributes in
+  Ms.mk ~loc ~attrs
+    (map_loc sub ms.ms_name)
+    (map_loc sub ms.ms_txt)
+
+let include_infos f sub incl =
+  let loc = sub.location sub incl.incl_loc in
+  let attrs = sub.attributes sub incl.incl_attributes in
+  Incl.mk ~loc ~attrs
+    (f sub incl.incl_mod)
+
+let include_declaration sub = include_infos sub.module_expr sub
+let include_description sub = include_infos sub.module_type sub
+
+let class_infos f sub ci =
+  let loc = sub.location sub ci.ci_loc in
+  let attrs = sub.attributes sub ci.ci_attributes in
+  Ci.mk ~loc ~attrs
+    ~virt:ci.ci_virt
+    ~params:(List.map (type_parameter sub) ci.ci_params)
+    (map_loc sub ci.ci_id_name)
+    (f sub ci.ci_expr)
+
+let class_declaration sub = class_infos sub.class_expr sub
+let class_description sub = class_infos sub.class_type sub
+let class_type_declaration sub = class_infos sub.class_type sub
+
+let functor_parameter sub : functor_parameter -> Parsetree.functor_parameter =
+  function
+  | Unit -> Unit
+  | Named (_, name, mtype) -> Named (name, sub.module_type sub mtype)
+
+let module_type sub mty =
+  let loc = sub.location sub mty.mty_loc in
+  let attrs = sub.attributes sub mty.mty_attributes in
+  let desc = match mty.mty_desc with
+      Tmty_ident (_path, lid) -> Pmty_ident (map_loc sub lid)
+    | Tmty_alias (_path, lid) -> Pmty_alias (map_loc sub lid)
+    | Tmty_signature sg -> Pmty_signature (sub.signature sub sg)
+    | Tmty_functor (arg, mtype2) ->
+        Pmty_functor (functor_parameter sub arg, sub.module_type sub mtype2)
+    | Tmty_with (mtype, list) ->
+        Pmty_with (sub.module_type sub mtype,
+          List.map (sub.with_constraint sub) list)
+    | Tmty_typeof mexpr ->
+        Pmty_typeof (sub.module_expr sub mexpr)
+  in
+  Mty.mk ~loc ~attrs desc
+
+let with_constraint sub (_path, lid, cstr) =
+  match cstr with
+  | Twith_type decl ->
+      Pwith_type (map_loc sub lid, sub.type_declaration sub decl)
+  | Twith_module (_path, lid2) ->
+      Pwith_module (map_loc sub lid, map_loc sub lid2)
+  | Twith_typesubst decl ->
+     Pwith_typesubst (map_loc sub lid, sub.type_declaration sub decl)
+  | Twith_modsubst (_path, lid2) ->
+      Pwith_modsubst (map_loc sub lid, map_loc sub lid2)
+
+let module_expr sub mexpr =
+  let loc = sub.location sub mexpr.mod_loc in
+  let attrs = sub.attributes sub mexpr.mod_attributes in
+  match mexpr.mod_desc with
+      Tmod_constraint (m, _, Tmodtype_implicit, _ ) ->
+        sub.module_expr sub m
+    | _ ->
+        let desc = match mexpr.mod_desc with
+            Tmod_ident (_p, lid) -> Pmod_ident (map_loc sub lid)
+          | Tmod_structure st -> Pmod_structure (sub.structure sub st)
+          | Tmod_functor (arg, mexpr) ->
+              Pmod_functor
+                (functor_parameter sub arg, sub.module_expr sub mexpr)
+          | Tmod_apply (mexp1, mexp2, _) ->
+              Pmod_apply (sub.module_expr sub mexp1, sub.module_expr sub mexp2)
+          | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) ->
+              Pmod_constraint (sub.module_expr sub mexpr,
+                sub.module_type sub mtype)
+          | Tmod_constraint (_mexpr, _, Tmodtype_implicit, _) ->
+              assert false
+          | Tmod_unpack (exp, _pack) ->
+              Pmod_unpack (sub.expr sub exp)
+              (* TODO , sub.package_type sub pack) *)
+        in
+        Mod.mk ~loc ~attrs desc
+
+let class_expr sub cexpr =
+  let loc = sub.location sub cexpr.cl_loc in
+  let attrs = sub.attributes sub cexpr.cl_attributes in
+  let desc = match cexpr.cl_desc with
+    | Tcl_constraint ( { cl_desc = Tcl_ident (_path, lid, tyl); _ },
+                       None, _, _, _ ) ->
+        Pcl_constr (map_loc sub lid,
+          List.map (sub.typ sub) tyl)
+    | Tcl_structure clstr -> Pcl_structure (sub.class_structure sub clstr)
+
+    | Tcl_fun (label, pat, _pv, cl, _partial) ->
+        Pcl_fun (label, None, sub.pat sub pat, sub.class_expr sub cl)
+
+    | Tcl_apply (cl, args) ->
+        Pcl_apply (sub.class_expr sub cl,
+          List.fold_right (fun (label, expo) list ->
+              match expo with
+                None -> list
+              | Some exp -> (label, sub.expr sub exp) :: list
+          ) args [])
+
+    | Tcl_let (rec_flat, bindings, _ivars, cl) ->
+        Pcl_let (rec_flat,
+          List.map (sub.value_binding sub) bindings,
+          sub.class_expr sub cl)
+
+    | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) ->
+        Pcl_constraint (sub.class_expr sub cl,  sub.class_type sub clty)
+
+    | Tcl_open (od, e) ->
+        Pcl_open (sub.open_description sub od, sub.class_expr sub e)
+
+    | Tcl_ident _ -> assert false
+    | Tcl_constraint (_, None, _, _, _) -> assert false
+  in
+  Cl.mk ~loc ~attrs desc
+
+let class_type sub ct =
+  let loc = sub.location sub ct.cltyp_loc in
+  let attrs = sub.attributes sub ct.cltyp_attributes in
+  let desc = match ct.cltyp_desc with
+      Tcty_signature csg -> Pcty_signature (sub.class_signature sub csg)
+    | Tcty_constr (_path, lid, list) ->
+        Pcty_constr (map_loc sub lid, List.map (sub.typ sub) list)
+    | Tcty_arrow (label, ct, cl) ->
+        Pcty_arrow (label, sub.typ sub ct, sub.class_type sub cl)
+    | Tcty_open (od, e) ->
+        Pcty_open (sub.open_description sub od, sub.class_type sub e)
+  in
+  Cty.mk ~loc ~attrs desc
+
+let class_signature sub cs =
+  {
+    pcsig_self = sub.typ sub cs.csig_self;
+    pcsig_fields = List.map (sub.class_type_field sub) cs.csig_fields;
+  }
+
+let class_type_field sub ctf =
+  let loc = sub.location sub ctf.ctf_loc in
+  let attrs = sub.attributes sub ctf.ctf_attributes in
+  let desc = match ctf.ctf_desc with
+      Tctf_inherit ct -> Pctf_inherit (sub.class_type sub ct)
+    | Tctf_val (s, mut, virt, ct) ->
+        Pctf_val (mkloc s loc, mut, virt, sub.typ sub ct)
+    | Tctf_method  (s, priv, virt, ct) ->
+        Pctf_method  (mkloc s loc, priv, virt, sub.typ sub ct)
+    | Tctf_constraint  (ct1, ct2) ->
+        Pctf_constraint (sub.typ sub ct1, sub.typ sub ct2)
+    | Tctf_attribute x -> Pctf_attribute x
+  in
+  Ctf.mk ~loc ~attrs desc
+
+let core_type sub ct =
+  let loc = sub.location sub ct.ctyp_loc in
+  let attrs = sub.attributes sub ct.ctyp_attributes in
+  let desc = match ct.ctyp_desc with
+      Ttyp_any -> Ptyp_any
+    | Ttyp_var s -> Ptyp_var s
+    | Ttyp_arrow (label, ct1, ct2) ->
+        Ptyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2)
+    | Ttyp_tuple list -> Ptyp_tuple (List.map (sub.typ sub) list)
+    | Ttyp_constr (_path, lid, list) ->
+        Ptyp_constr (map_loc sub lid,
+          List.map (sub.typ sub) list)
+    | Ttyp_object (list, o) ->
+        Ptyp_object
+          (List.map (sub.object_field sub) list, o)
+    | Ttyp_class (_path, lid, list) ->
+        Ptyp_class (map_loc sub lid, List.map (sub.typ sub) list)
+    | Ttyp_alias (ct, s) ->
+        Ptyp_alias (sub.typ sub ct, s)
+    | Ttyp_variant (list, bool, labels) ->
+        Ptyp_variant (List.map (sub.row_field sub) list, bool, labels)
+    | Ttyp_poly (list, ct) ->
+        let list = List.map (fun v -> mkloc v loc) list in
+        Ptyp_poly (list, sub.typ sub ct)
+    | Ttyp_package pack -> Ptyp_package (sub.package_type sub pack)
+  in
+  Typ.mk ~loc ~attrs desc
+
+let class_structure sub cs =
+  let rec remove_self = function
+    | { pat_desc = Tpat_alias (p, id, _s) }
+      when string_is_prefix "selfpat-" (Ident.name id) ->
+        remove_self p
+    | p -> p
+  in
+  { pcstr_self = sub.pat sub (remove_self cs.cstr_self);
+    pcstr_fields = List.map (sub.class_field sub) cs.cstr_fields;
+  }
+
+let row_field sub {rf_loc; rf_desc; rf_attributes;} =
+  let loc = sub.location sub rf_loc in
+  let attrs = sub.attributes sub rf_attributes in
+  let desc = match rf_desc with
+    | Ttag (label, bool, list) ->
+        Rtag (label, bool, List.map (sub.typ sub) list)
+    | Tinherit ct -> Rinherit (sub.typ sub ct)
+  in
+  Rf.mk ~loc ~attrs desc
+
+let object_field sub {of_loc; of_desc; of_attributes;} =
+  let loc = sub.location sub of_loc in
+  let attrs = sub.attributes sub of_attributes in
+  let desc = match of_desc with
+    | OTtag (label, ct) ->
+        Otag (label, sub.typ sub ct)
+    | OTinherit ct -> Oinherit (sub.typ sub ct)
+  in
+  Of.mk ~loc ~attrs desc
+
+and is_self_pat = function
+  | { pat_desc = Tpat_alias(_pat, id, _) } ->
+      string_is_prefix "self-" (Ident.name id)
+  | _ -> false
+
+let class_field sub cf =
+  let loc = sub.location sub cf.cf_loc in
+  let attrs = sub.attributes sub cf.cf_attributes in
+  let desc = match cf.cf_desc with
+      Tcf_inherit (ovf, cl, super, _vals, _meths) ->
+        Pcf_inherit (ovf, sub.class_expr sub cl,
+                     Option.map (fun v -> mkloc v loc) super)
+    | Tcf_constraint (cty, cty') ->
+        Pcf_constraint (sub.typ sub cty, sub.typ sub cty')
+    | Tcf_val (lab, mut, _, Tcfk_virtual cty, _) ->
+        Pcf_val (lab, mut, Cfk_virtual (sub.typ sub cty))
+    | Tcf_val (lab, mut, _, Tcfk_concrete (o, exp), _) ->
+        Pcf_val (lab, mut, Cfk_concrete (o, sub.expr sub exp))
+    | Tcf_method (lab, priv, Tcfk_virtual cty) ->
+        Pcf_method (lab, priv, Cfk_virtual (sub.typ sub cty))
+    | Tcf_method (lab, priv, Tcfk_concrete (o, exp)) ->
+        let remove_fun_self = function
+          | { exp_desc =
+              Texp_function { arg_label = Nolabel; cases = [case]; _ } }
+            when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs
+          | e -> e
+        in
+        let exp = remove_fun_self exp in
+        Pcf_method (lab, priv, Cfk_concrete (o, sub.expr sub exp))
+    | Tcf_initializer exp ->
+        let remove_fun_self = function
+          | { exp_desc =
+              Texp_function { arg_label = Nolabel; cases = [case]; _ } }
+            when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs
+          | e -> e
+        in
+        let exp = remove_fun_self exp in
+        Pcf_initializer (sub.expr sub exp)
+    | Tcf_attribute x -> Pcf_attribute x
+  in
+  Cf.mk ~loc ~attrs desc
+
+let location _sub l = l
+
+let default_mapper =
+  {
+    attribute = attribute;
+    attributes = attributes;
+    binding_op = binding_op;
+    structure = structure;
+    structure_item = structure_item;
+    module_expr = module_expr;
+    signature = signature;
+    signature_item = signature_item;
+    module_type = module_type;
+    with_constraint = with_constraint;
+    class_declaration = class_declaration;
+    class_expr = class_expr;
+    class_field = class_field;
+    class_structure = class_structure;
+    class_type = class_type;
+    class_type_field = class_type_field;
+    class_signature = class_signature;
+    class_type_declaration = class_type_declaration;
+    class_description = class_description;
+    type_declaration = type_declaration;
+    type_kind = type_kind;
+    typ = core_type;
+    type_extension = type_extension;
+    type_exception = type_exception;
+    extension_constructor = extension_constructor;
+    value_description = value_description;
+    pat = pattern;
+    expr = expression;
+    module_declaration = module_declaration;
+    module_substitution = module_substitution;
+    module_type_declaration = module_type_declaration;
+    module_binding = module_binding;
+    package_type = package_type ;
+    open_declaration = open_declaration;
+    open_description = open_description;
+    include_description = include_description;
+    include_declaration = include_declaration;
+    value_binding = value_binding;
+    constructor_declaration = constructor_declaration;
+    label_declaration = label_declaration;
+    case = case;
+    location = location;
+    row_field = row_field ;
+    object_field = object_field ;
+  }
+
+let untype_structure ?(mapper=default_mapper) structure =
+  mapper.structure mapper structure
+
+let untype_signature ?(mapper=default_mapper) signature =
+  mapper.signature mapper signature
+
+let untype_expression ?(mapper=default_mapper) expression =
+  mapper.expr mapper expression
+
+let untype_pattern ?(mapper=default_mapper) pattern =
+  mapper.pat mapper pattern
diff --git a/upstream/ocaml_412/typing/untypeast.mli b/upstream/ocaml_412/typing/untypeast.mli
new file mode 100644
index 0000000..809df9a
--- /dev/null
+++ b/upstream/ocaml_412/typing/untypeast.mli
@@ -0,0 +1,87 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*      Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay)   *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Parsetree
+
+val lident_of_path : Path.t -> Longident.t
+
+type mapper = {
+  attribute: mapper -> Typedtree.attribute -> attribute;
+  attributes: mapper -> Typedtree.attribute list -> attribute list;
+  binding_op:
+    mapper ->
+    Typedtree.binding_op -> Typedtree.pattern -> binding_op;
+  case: 'k . mapper -> 'k Typedtree.case -> case;
+  class_declaration: mapper -> Typedtree.class_declaration -> class_declaration;
+  class_description: mapper -> Typedtree.class_description -> class_description;
+  class_expr: mapper -> Typedtree.class_expr -> class_expr;
+  class_field: mapper -> Typedtree.class_field -> class_field;
+  class_signature: mapper -> Typedtree.class_signature -> class_signature;
+  class_structure: mapper -> Typedtree.class_structure -> class_structure;
+  class_type: mapper -> Typedtree.class_type -> class_type;
+  class_type_declaration: mapper -> Typedtree.class_type_declaration
+                          -> class_type_declaration;
+  class_type_field: mapper -> Typedtree.class_type_field -> class_type_field;
+  constructor_declaration: mapper -> Typedtree.constructor_declaration
+                           -> constructor_declaration;
+  expr: mapper -> Typedtree.expression -> expression;
+  extension_constructor: mapper -> Typedtree.extension_constructor
+                         -> extension_constructor;
+  include_declaration:
+    mapper -> Typedtree.include_declaration -> include_declaration;
+  include_description:
+    mapper -> Typedtree.include_description -> include_description;
+  label_declaration:
+    mapper -> Typedtree.label_declaration -> label_declaration;
+  location: mapper -> Location.t -> Location.t;
+  module_binding: mapper -> Typedtree.module_binding -> module_binding;
+  module_declaration:
+    mapper -> Typedtree.module_declaration -> module_declaration;
+  module_substitution:
+    mapper -> Typedtree.module_substitution -> module_substitution;
+  module_expr: mapper -> Typedtree.module_expr -> module_expr;
+  module_type: mapper -> Typedtree.module_type -> module_type;
+  module_type_declaration:
+    mapper -> Typedtree.module_type_declaration -> module_type_declaration;
+  package_type: mapper -> Typedtree.package_type -> package_type;
+  open_declaration: mapper -> Typedtree.open_declaration -> open_declaration;
+  open_description: mapper -> Typedtree.open_description -> open_description;
+  pat: 'k . mapper -> 'k Typedtree.general_pattern -> pattern;
+  row_field: mapper -> Typedtree.row_field -> row_field;
+  object_field: mapper -> Typedtree.object_field -> object_field;
+  signature: mapper -> Typedtree.signature -> signature;
+  signature_item: mapper -> Typedtree.signature_item -> signature_item;
+  structure: mapper -> Typedtree.structure -> structure;
+  structure_item: mapper -> Typedtree.structure_item -> structure_item;
+  typ: mapper -> Typedtree.core_type -> core_type;
+  type_declaration: mapper -> Typedtree.type_declaration -> type_declaration;
+  type_extension: mapper -> Typedtree.type_extension -> type_extension;
+  type_exception: mapper -> Typedtree.type_exception -> type_exception;
+  type_kind: mapper -> Typedtree.type_kind -> type_kind;
+  value_binding: mapper -> Typedtree.value_binding -> value_binding;
+  value_description: mapper -> Typedtree.value_description -> value_description;
+  with_constraint:
+    mapper -> (Path.t * Longident.t Location.loc * Typedtree.with_constraint)
+    -> with_constraint;
+}
+
+val default_mapper : mapper
+
+val untype_structure : ?mapper:mapper -> Typedtree.structure -> structure
+val untype_signature : ?mapper:mapper -> Typedtree.signature -> signature
+val untype_expression : ?mapper:mapper -> Typedtree.expression -> expression
+val untype_pattern : ?mapper:mapper -> _ Typedtree.general_pattern -> pattern
+
+val constant : Asttypes.constant -> Parsetree.constant
diff --git a/upstream/ocaml_412/utils/arg_helper.ml b/upstream/ocaml_412/utils/arg_helper.ml
new file mode 100644
index 0000000..fa80007
--- /dev/null
+++ b/upstream/ocaml_412/utils/arg_helper.ml
@@ -0,0 +1,127 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2015--2016 OCamlPro SAS                                    *)
+(*   Copyright 2015--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+let fatal err =
+  prerr_endline err;
+  exit 2
+
+module Make (S : sig
+  module Key : sig
+    type t
+    val of_string : string -> t
+    module Map : Map.S with type key = t
+  end
+
+  module Value : sig
+    type t
+    val of_string : string -> t
+  end
+end) = struct
+  type parsed = {
+    base_default : S.Value.t;
+    base_override : S.Value.t S.Key.Map.t;
+    user_default : S.Value.t option;
+    user_override : S.Value.t S.Key.Map.t;
+  }
+
+  let default v =
+    { base_default = v;
+      base_override = S.Key.Map.empty;
+      user_default = None;
+      user_override = S.Key.Map.empty; }
+
+  let set_base_default value t =
+    { t with base_default = value }
+
+  let add_base_override key value t =
+    { t with base_override = S.Key.Map.add key value t.base_override }
+
+  let reset_base_overrides t =
+    { t with base_override = S.Key.Map.empty }
+
+  let set_user_default value t =
+    { t with user_default = Some value }
+
+  let add_user_override key value t =
+    { t with user_override = S.Key.Map.add key value t.user_override }
+
+  exception Parse_failure of exn
+
+  let parse_exn str ~update =
+    (* Is the removal of empty chunks really relevant here? *)
+    (* (It has been added to mimic the old Misc.String.split.) *)
+    let values = String.split_on_char ',' str |> List.filter ((<>) "") in
+    let parsed =
+      List.fold_left (fun acc value ->
+          match String.index value '=' with
+          | exception Not_found ->
+            begin match S.Value.of_string value with
+            | value -> set_user_default value acc
+            | exception exn -> raise (Parse_failure exn)
+            end
+          | equals ->
+            let key_value_pair = value in
+            let length = String.length key_value_pair in
+            assert (equals >= 0 && equals < length);
+            if equals = 0 then begin
+              raise (Parse_failure (
+                Failure "Missing key in argument specification"))
+            end;
+            let key =
+              let key = String.sub key_value_pair 0 equals in
+              try S.Key.of_string key
+              with exn -> raise (Parse_failure exn)
+            in
+            let value =
+              let value =
+                String.sub key_value_pair (equals + 1) (length - equals - 1)
+              in
+              try S.Value.of_string value
+              with exn -> raise (Parse_failure exn)
+            in
+            add_user_override key value acc)
+        !update
+        values
+    in
+    update := parsed
+
+  let parse str help_text update =
+    match parse_exn str ~update with
+    | () -> ()
+    | exception (Parse_failure exn) ->
+      fatal (Printf.sprintf "%s: %s" (Printexc.to_string exn) help_text)
+
+  type parse_result =
+    | Ok
+    | Parse_failed of exn
+
+  let parse_no_error str update =
+    match parse_exn str ~update with
+    | () -> Ok
+    | exception (Parse_failure exn) -> Parse_failed exn
+
+  let get ~key parsed =
+    match S.Key.Map.find key parsed.user_override with
+    | value -> value
+    | exception Not_found ->
+      match parsed.user_default with
+      | Some value -> value
+      | None ->
+        match S.Key.Map.find key parsed.base_override with
+        | value -> value
+        | exception Not_found -> parsed.base_default
+
+end
diff --git a/upstream/ocaml_412/utils/arg_helper.mli b/upstream/ocaml_412/utils/arg_helper.mli
new file mode 100644
index 0000000..18f60fe
--- /dev/null
+++ b/upstream/ocaml_412/utils/arg_helper.mli
@@ -0,0 +1,68 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2015--2016 OCamlPro SAS                                    *)
+(*   Copyright 2015--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Decipher command line arguments of the form
+        <value> | <key>=<value>[,...]
+
+    (as used for example for the specification of inlining parameters
+    varying by simplification round).
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+module Make (S : sig
+  module Key : sig
+    type t
+
+    (** The textual representation of a key must not contain '=' or ','. *)
+    val of_string : string -> t
+
+    module Map : Map.S with type key = t
+  end
+
+  module Value : sig
+    type t
+
+    (** The textual representation of a value must not contain ','. *)
+    val of_string : string -> t
+  end
+end) : sig
+  type parsed
+
+  val default : S.Value.t -> parsed
+
+  val set_base_default : S.Value.t -> parsed -> parsed
+
+  val add_base_override : S.Key.t -> S.Value.t -> parsed -> parsed
+
+  val reset_base_overrides : parsed -> parsed
+
+  val set_user_default : S.Value.t -> parsed -> parsed
+
+  val add_user_override : S.Key.t -> S.Value.t -> parsed -> parsed
+
+  val parse : string -> string -> parsed ref -> unit
+
+  type parse_result =
+    | Ok
+    | Parse_failed of exn
+
+  val parse_no_error : string -> parsed ref -> parse_result
+
+  val get : key:S.Key.t -> parsed -> S.Value.t
+end
diff --git a/upstream/ocaml_412/utils/build_path_prefix_map.ml b/upstream/ocaml_412/utils/build_path_prefix_map.ml
new file mode 100644
index 0000000..c204d3a
--- /dev/null
+++ b/upstream/ocaml_412/utils/build_path_prefix_map.ml
@@ -0,0 +1,119 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*            Gabriel Scherer, projet Parsifal, INRIA Saclay              *)
+(*                                                                        *)
+(*   Copyright 2017 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type path = string
+type path_prefix = string
+type error_message = string
+
+let errorf fmt = Printf.kprintf (fun err -> Error err) fmt
+
+let encode_prefix str =
+  let buf = Buffer.create (String.length str) in
+  let push_char = function
+    | '%' -> Buffer.add_string buf "%#"
+    | '=' -> Buffer.add_string buf "%+"
+    | ':' -> Buffer.add_string buf "%."
+    | c -> Buffer.add_char buf c
+  in
+  String.iter push_char str;
+  Buffer.contents buf
+
+let decode_prefix str =
+  let buf = Buffer.create (String.length str) in
+  let rec loop i =
+    if i >= String.length str
+    then Ok (Buffer.contents buf)
+    else match str.[i] with
+      | ('=' | ':') as c ->
+        errorf "invalid character '%c' in key or value" c
+      | '%' ->
+        let push c = Buffer.add_char buf c; loop (i + 2) in
+        if i + 1 = String.length str then
+          errorf "invalid encoded string %S (trailing '%%')" str
+        else begin match str.[i + 1] with
+            | '#' -> push '%'
+            | '+' -> push '='
+            | '.' -> push ':'
+            | c -> errorf "invalid %%-escaped character '%c'" c
+        end
+      | c ->
+        Buffer.add_char buf c;
+        loop (i + 1)
+  in loop 0
+
+type pair = { target: path_prefix; source : path_prefix }
+
+let encode_pair { target; source } =
+  String.concat "=" [encode_prefix target; encode_prefix source]
+
+let decode_pair str =
+  match String.index str '=' with
+  | exception Not_found ->
+    errorf "invalid key/value pair %S, no '=' separator" str
+  | equal_pos ->
+    let encoded_target = String.sub str 0 equal_pos in
+    let encoded_source =
+      String.sub str (equal_pos + 1) (String.length str - equal_pos - 1) in
+    match decode_prefix encoded_target, decode_prefix encoded_source with
+    | Ok target, Ok source -> Ok { target; source }
+    | ((Error _ as err), _) | (_, (Error _ as err)) -> err
+
+type map = pair option list
+
+let encode_map map =
+  let encode_elem = function
+    | None -> ""
+    | Some pair -> encode_pair pair
+  in
+  List.map encode_elem map
+  |> String.concat ":"
+
+let decode_map str =
+  let exception Shortcut of error_message in
+  let decode_or_empty = function
+    | "" -> None
+    | pair ->
+      begin match decode_pair pair with
+        | Ok str -> Some str
+        | Error err -> raise (Shortcut err)
+      end
+  in
+  let pairs = String.split_on_char ':' str in
+  match List.map decode_or_empty pairs with
+  | exception (Shortcut err) -> Error err
+  | map -> Ok map
+
+let rewrite_opt prefix_map path =
+  let is_prefix = function
+    | None -> false
+    | Some { target = _; source } ->
+      String.length source <= String.length path
+      && String.equal source (String.sub path 0 (String.length source))
+  in
+  match
+    List.find is_prefix
+      (* read key/value pairs from right to left, as the spec demands *)
+      (List.rev prefix_map)
+  with
+  | exception Not_found -> None
+  | None -> None
+  | Some { source; target } ->
+      Some (target ^ (String.sub path (String.length source)
+                       (String.length path - String.length source)))
+
+let rewrite prefix_map path =
+  match rewrite_opt prefix_map path with
+  | None -> path
+  | Some path -> path
diff --git a/upstream/ocaml_412/utils/build_path_prefix_map.mli b/upstream/ocaml_412/utils/build_path_prefix_map.mli
new file mode 100644
index 0000000..dbcc8dc
--- /dev/null
+++ b/upstream/ocaml_412/utils/build_path_prefix_map.mli
@@ -0,0 +1,47 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*            Gabriel Scherer, projet Parsifal, INRIA Saclay              *)
+(*                                                                        *)
+(*   Copyright 2017 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Rewrite paths for reproducible builds
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+
+type path = string
+type path_prefix = string
+type error_message = string
+
+val encode_prefix : path_prefix -> string
+val decode_prefix : string -> (path_prefix, error_message) result
+
+type pair = { target: path_prefix; source : path_prefix }
+
+val encode_pair : pair -> string
+val decode_pair : string -> (pair, error_message) result
+
+type map = pair option list
+
+val encode_map : map -> string
+val decode_map : string -> (map, error_message) result
+
+val rewrite_opt : map -> path -> path option
+(** [rewrite_opt map path] tries to find a source in [map]
+    that is a prefix of the input [path]. If it succeeds,
+    it replaces this prefix with the corresponding target.
+    If it fails, it just returns [None]. *)
+
+val rewrite : map -> path -> path
diff --git a/upstream/ocaml_412/utils/ccomp.ml b/upstream/ocaml_412/utils/ccomp.ml
new file mode 100644
index 0000000..22b60a8
--- /dev/null
+++ b/upstream/ocaml_412/utils/ccomp.ml
@@ -0,0 +1,214 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Compiling C files and building C libraries *)
+
+let command cmdline =
+  if !Clflags.verbose then begin
+    prerr_string "+ ";
+    prerr_string cmdline;
+    prerr_newline()
+  end;
+  let res = Sys.command cmdline in
+  if res = 127 then raise (Sys_error cmdline);
+  res
+
+let run_command cmdline = ignore(command cmdline)
+
+(* Build @responsefile to work around OS limitations on
+   command-line length.
+   Under Windows, the max length is 8187 minus the length of the
+   COMSPEC variable (or 7 if it's not set).  To be on the safe side,
+   we'll use a response file if we need to pass 4096 or more bytes of
+   arguments.
+   For Unix-like systems, the threshold is 2^16 (64 KiB), which is
+   within the lowest observed limits (2^17 per argument under Linux;
+   between 70000 and 80000 for macOS).
+*)
+
+let build_diversion lst =
+  let (responsefile, oc) = Filename.open_temp_file "camlresp" "" in
+  List.iter (fun f -> Printf.fprintf oc "%s\n" f) lst;
+  close_out oc;
+  at_exit (fun () -> Misc.remove_file responsefile);
+  "@" ^ responsefile
+
+let quote_files lst =
+  let lst = List.filter (fun f -> f <> "") lst in
+  let quoted = List.map Filename.quote lst in
+  let s = String.concat " " quoted in
+  if String.length s >= 65536
+  || (String.length s >= 4096 && Sys.os_type = "Win32")
+  then build_diversion quoted
+  else s
+
+let quote_prefixed pr lst =
+  let lst = List.filter (fun f -> f <> "") lst in
+  let lst = List.map (fun f -> pr ^ f) lst in
+  quote_files lst
+
+let quote_optfile = function
+  | None -> ""
+  | Some f -> Filename.quote f
+
+let display_msvc_output file name =
+  let c = open_in file in
+  try
+    let first = input_line c in
+    if first <> Filename.basename name then
+      print_endline first;
+    while true do
+      print_endline (input_line c)
+    done
+  with _ ->
+    close_in c;
+    Sys.remove file
+
+let compile_file ?output ?(opt="") ?stable_name name =
+  let (pipe, file) =
+    if Config.ccomp_type = "msvc" && not !Clflags.verbose then
+      try
+        let (t, c) = Filename.open_temp_file "msvc" "stdout" in
+        close_out c;
+        (Printf.sprintf " > %s" (Filename.quote t), t)
+      with _ ->
+        ("", "")
+    else
+      ("", "") in
+  let debug_prefix_map =
+    match stable_name with
+    | Some stable when Config.c_has_debug_prefix_map ->
+      Printf.sprintf " -fdebug-prefix-map=%s=%s" name stable
+    | Some _ | None -> "" in
+  let exit =
+    command
+      (Printf.sprintf
+         "%s%s %s %s -c %s %s %s %s %s%s"
+         (match !Clflags.c_compiler with
+          | Some cc -> cc
+          | None ->
+              (* #7678: ocamlopt only calls the C compiler to process .c files
+                 from the command line, and the behaviour between
+                 ocamlc/ocamlopt should be identical. *)
+              (String.concat " " [Config.c_compiler;
+                                  Config.ocamlc_cflags;
+                                  Config.ocamlc_cppflags]))
+         debug_prefix_map
+         (match output with
+          | None -> ""
+          | Some o -> Printf.sprintf "%s%s" Config.c_output_obj o)
+         opt
+         (if !Clflags.debug && Config.ccomp_type <> "msvc" then "-g" else "")
+         (String.concat " " (List.rev !Clflags.all_ccopts))
+         (quote_prefixed "-I"
+            (List.map (Misc.expand_directory Config.standard_library)
+               (List.rev !Clflags.include_dirs)))
+         (Clflags.std_include_flag "-I")
+         (Filename.quote name)
+         (* cl tediously includes the name of the C file as the first thing it
+            outputs (in fairness, the tedious thing is that there's no switch to
+            disable this behaviour). In the absence of the Unix module, use
+            a temporary file to filter the output (cannot pipe the output to a
+            filter because this removes the exit status of cl, which is wanted.
+          *)
+         pipe) in
+  if pipe <> ""
+  then display_msvc_output file name;
+  exit
+
+let create_archive archive file_list =
+  Misc.remove_file archive;
+  let quoted_archive = Filename.quote archive in
+  if file_list = [] then
+    0 (* Don't call the archiver: #6550/#1094/#9011 *)
+  else
+    match Config.ccomp_type with
+      "msvc" ->
+        command(Printf.sprintf "link /lib /nologo /out:%s %s"
+                               quoted_archive (quote_files file_list))
+    | _ ->
+        assert(String.length Config.ar > 0);
+        let r1 =
+          command(Printf.sprintf "%s rc %s %s"
+                  Config.ar quoted_archive (quote_files file_list)) in
+        if r1 <> 0 || String.length Config.ranlib = 0
+        then r1
+        else command(Config.ranlib ^ " " ^ quoted_archive)
+
+let expand_libname name =
+  if String.length name < 2 || String.sub name 0 2 <> "-l"
+  then name
+  else begin
+    let libname =
+      "lib" ^ String.sub name 2 (String.length name - 2) ^ Config.ext_lib in
+    try
+      Load_path.find libname
+    with Not_found ->
+      libname
+  end
+
+type link_mode =
+  | Exe
+  | Dll
+  | MainDll
+  | Partial
+
+let remove_Wl cclibs =
+  cclibs |> List.map (fun cclib ->
+    (* -Wl,-foo,bar -> -foo bar *)
+    if String.length cclib >= 4 && "-Wl," = String.sub cclib 0 4 then
+      String.map (function ',' -> ' ' | c -> c)
+                 (String.sub cclib 4 (String.length cclib - 4))
+    else cclib)
+
+let call_linker mode output_name files extra =
+  Profile.record_call "c-linker" (fun () ->
+    let cmd =
+      if mode = Partial then
+        let l_prefix =
+          match Config.ccomp_type with
+          | "msvc" -> "/libpath:"
+          | _ -> "-L"
+        in
+        Printf.sprintf "%s%s %s %s %s"
+          Config.native_pack_linker
+          (Filename.quote output_name)
+          (quote_prefixed l_prefix (Load_path.get_paths ()))
+          (quote_files (remove_Wl files))
+          extra
+      else
+        Printf.sprintf "%s -o %s %s %s %s %s %s"
+          (match !Clflags.c_compiler, mode with
+          | Some cc, _ -> cc
+          | None, Exe -> Config.mkexe
+          | None, Dll -> Config.mkdll
+          | None, MainDll -> Config.mkmaindll
+          | None, Partial -> assert false
+          )
+          (Filename.quote output_name)
+          ""  (*(Clflags.std_include_flag "-I")*)
+          (quote_prefixed "-L" (Load_path.get_paths ()))
+          (String.concat " " (List.rev !Clflags.all_ccopts))
+          (quote_files files)
+          extra
+    in
+    command cmd
+  )
+
+let linker_is_flexlink =
+  (* Config.mkexe, Config.mkdll and Config.mkmaindll are all flexlink
+     invocations for the native Windows ports and for Cygwin, if shared library
+     support is enabled. *)
+  Sys.win32 || Config.supports_shared_libraries && Sys.cygwin
diff --git a/upstream/ocaml_412/utils/ccomp.mli b/upstream/ocaml_412/utils/ccomp.mli
new file mode 100644
index 0000000..fb520e2
--- /dev/null
+++ b/upstream/ocaml_412/utils/ccomp.mli
@@ -0,0 +1,41 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Compiling C files and building C libraries
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+val command: string -> int
+val run_command: string -> unit
+val compile_file:
+  ?output:string -> ?opt:string -> ?stable_name:string -> string -> int
+val create_archive: string -> string list -> int
+val expand_libname: string -> string
+val quote_files: string list -> string
+val quote_optfile: string option -> string
+(*val make_link_options: string list -> string*)
+
+type link_mode =
+  | Exe
+  | Dll
+  | MainDll
+  | Partial
+
+val call_linker: link_mode -> string -> string list -> string -> int
+
+val linker_is_flexlink : bool
diff --git a/upstream/ocaml_412/utils/clflags.ml b/upstream/ocaml_412/utils/clflags.ml
new file mode 100644
index 0000000..a193d53
--- /dev/null
+++ b/upstream/ocaml_412/utils/clflags.ml
@@ -0,0 +1,583 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Command-line parameters *)
+
+module Int_arg_helper = Arg_helper.Make (struct
+  module Key = struct
+    include Numbers.Int
+    let of_string = int_of_string
+  end
+
+  module Value = struct
+    include Numbers.Int
+    let of_string = int_of_string
+  end
+end)
+module Float_arg_helper = Arg_helper.Make (struct
+  module Key = struct
+    include Numbers.Int
+    let of_string = int_of_string
+  end
+
+  module Value = struct
+    include Numbers.Float
+    let of_string = float_of_string
+  end
+end)
+
+let objfiles = ref ([] : string list)   (* .cmo and .cma files *)
+and ccobjs = ref ([] : string list)     (* .o, .a, .so and -cclib -lxxx *)
+and dllibs = ref ([] : string list)     (* .so and -dllib -lxxx *)
+
+let compile_only = ref false            (* -c *)
+and output_name = ref (None : string option) (* -o *)
+and include_dirs = ref ([] : string list)(* -I *)
+and no_std_include = ref false          (* -nostdlib *)
+and print_types = ref false             (* -i *)
+and make_archive = ref false            (* -a *)
+and debug = ref false                   (* -g *)
+and debug_full = ref false              (* For full DWARF support *)
+and unsafe = ref false                  (* -unsafe *)
+and use_linscan = ref false             (* -linscan *)
+and link_everything = ref false         (* -linkall *)
+and custom_runtime = ref false          (* -custom *)
+and no_check_prims = ref false          (* -no-check-prims *)
+and bytecode_compatible_32 = ref false  (* -compat-32 *)
+and output_c_object = ref false         (* -output-obj *)
+and output_complete_object = ref false  (* -output-complete-obj *)
+and output_complete_executable = ref false  (* -output-complete-exe *)
+and all_ccopts = ref ([] : string list)     (* -ccopt *)
+and classic = ref false                 (* -nolabels *)
+and nopervasives = ref false            (* -nopervasives *)
+and match_context_rows = ref 32         (* -match-context-rows *)
+and preprocessor = ref(None : string option) (* -pp *)
+and all_ppx = ref ([] : string list)        (* -ppx *)
+let absname = ref false                 (* -absname *)
+let annotations = ref false             (* -annot *)
+let binary_annotations = ref false      (* -annot *)
+and use_threads = ref false             (* -thread *)
+and noassert = ref false                (* -noassert *)
+and verbose = ref false                 (* -verbose *)
+and noversion = ref false               (* -no-version *)
+and noprompt = ref false                (* -noprompt *)
+and nopromptcont = ref false            (* -nopromptcont *)
+and init_file = ref (None : string option)   (* -init *)
+and noinit = ref false                  (* -noinit *)
+and open_modules = ref []               (* -open *)
+and use_prims = ref ""                  (* -use-prims ... *)
+and use_runtime = ref ""                (* -use-runtime ... *)
+and plugin = ref false                  (* -plugin ... *)
+and principal = ref false               (* -principal *)
+and real_paths = ref true               (* -short-paths *)
+and recursive_types = ref false         (* -rectypes *)
+and strict_sequence = ref false         (* -strict-sequence *)
+and strict_formats = ref false          (* -strict-formats *)
+and applicative_functors = ref true     (* -no-app-funct *)
+and make_runtime = ref false            (* -make-runtime *)
+and c_compiler = ref (None: string option) (* -cc *)
+and no_auto_link = ref false            (* -noautolink *)
+and dllpaths = ref ([] : string list)   (* -dllpath *)
+and make_package = ref false            (* -pack *)
+and for_package = ref (None: string option) (* -for-pack *)
+and error_size = ref 500                (* -error-size *)
+and float_const_prop = ref true         (* -no-float-const-prop *)
+and transparent_modules = ref false     (* -trans-mod *)
+let unique_ids = ref true               (* -d(no-)unique-ds *)
+let locations = ref true                (* -d(no-)locations *)
+let dump_source = ref false             (* -dsource *)
+let dump_parsetree = ref false          (* -dparsetree *)
+and dump_typedtree = ref false          (* -dtypedtree *)
+and dump_rawlambda = ref false          (* -drawlambda *)
+and dump_lambda = ref false             (* -dlambda *)
+and dump_rawclambda = ref false         (* -drawclambda *)
+and dump_clambda = ref false            (* -dclambda *)
+and dump_rawflambda = ref false            (* -drawflambda *)
+and dump_flambda = ref false            (* -dflambda *)
+and dump_flambda_let = ref (None : int option) (* -dflambda-let=... *)
+and dump_flambda_verbose = ref false    (* -dflambda-verbose *)
+and dump_instr = ref false              (* -dinstr *)
+and keep_camlprimc_file = ref false     (* -dcamlprimc *)
+
+let keep_asm_file = ref false           (* -S *)
+let optimize_for_speed = ref true       (* -compact *)
+and opaque = ref false                  (* -opaque *)
+
+and dump_cmm = ref false                (* -dcmm *)
+let dump_selection = ref false          (* -dsel *)
+let dump_cse = ref false                (* -dcse *)
+let dump_live = ref false               (* -dlive *)
+let dump_avail = ref false              (* -davail *)
+let dump_spill = ref false              (* -dspill *)
+let dump_split = ref false              (* -dsplit *)
+let dump_interf = ref false             (* -dinterf *)
+let dump_prefer = ref false             (* -dprefer *)
+let dump_regalloc = ref false           (* -dalloc *)
+let dump_reload = ref false             (* -dreload *)
+let dump_scheduling = ref false         (* -dscheduling *)
+let dump_linear = ref false             (* -dlinear *)
+let dump_interval = ref false           (* -dinterval *)
+let keep_startup_file = ref false       (* -dstartup *)
+let dump_combine = ref false            (* -dcombine *)
+let profile_columns : Profile.column list ref = ref [] (* -dprofile/-dtimings *)
+
+let debug_runavail = ref false          (* -drunavail *)
+
+let native_code = ref false             (* set to true under ocamlopt *)
+
+let force_slash = ref false             (* for ocamldep *)
+let clambda_checks = ref false          (* -clambda-checks *)
+
+let flambda_invariant_checks =
+  ref Config.with_flambda_invariants    (* -flambda-(no-)invariants *)
+
+let dont_write_files = ref false        (* set to true under ocamldoc *)
+
+let insn_sched_default = true
+let insn_sched = ref insn_sched_default (* -[no-]insn-sched *)
+
+let std_include_flag prefix =
+  if !no_std_include then ""
+  else (prefix ^ (Filename.quote Config.standard_library))
+;;
+
+let std_include_dir () =
+  if !no_std_include then [] else [Config.standard_library]
+;;
+
+let shared = ref false (* -shared *)
+let dlcode = ref true (* not -nodynlink *)
+
+let pic_code = ref (match Config.architecture with (* -fPIC *)
+                     | "amd64" -> true
+                     | _       -> false)
+
+let runtime_variant = ref "";;      (* -runtime-variant *)
+let with_runtime = ref true;;         (* -with-runtime *)
+
+let keep_docs = ref false              (* -keep-docs *)
+let keep_locs = ref true               (* -keep-locs *)
+let unsafe_string =
+  if Config.safe_string then ref false
+  else ref (not Config.default_safe_string)
+                                   (* -safe-string / -unsafe-string *)
+
+let classic_inlining = ref false       (* -Oclassic *)
+let inlining_report = ref false    (* -inlining-report *)
+
+let afl_instrument = ref Config.afl_instrument (* -afl-instrument *)
+let afl_inst_ratio = ref 100           (* -afl-inst-ratio *)
+
+let function_sections = ref false      (* -function-sections *)
+
+let simplify_rounds = ref None        (* -rounds *)
+let default_simplify_rounds = ref 1        (* -rounds *)
+let rounds () =
+  match !simplify_rounds with
+  | None -> !default_simplify_rounds
+  | Some r -> r
+
+let default_inline_threshold = if Config.flambda then 10. else 10. /. 8.
+let inline_toplevel_multiplier = 16
+let default_inline_toplevel_threshold =
+  int_of_float ((float inline_toplevel_multiplier) *. default_inline_threshold)
+let default_inline_call_cost = 5
+let default_inline_alloc_cost = 7
+let default_inline_prim_cost = 3
+let default_inline_branch_cost = 5
+let default_inline_indirect_cost = 4
+let default_inline_branch_factor = 0.1
+let default_inline_lifting_benefit = 1300
+let default_inline_max_unroll = 0
+let default_inline_max_depth = 1
+
+let inline_threshold = ref (Float_arg_helper.default default_inline_threshold)
+let inline_toplevel_threshold =
+  ref (Int_arg_helper.default default_inline_toplevel_threshold)
+let inline_call_cost = ref (Int_arg_helper.default default_inline_call_cost)
+let inline_alloc_cost = ref (Int_arg_helper.default default_inline_alloc_cost)
+let inline_prim_cost = ref (Int_arg_helper.default default_inline_prim_cost)
+let inline_branch_cost =
+  ref (Int_arg_helper.default default_inline_branch_cost)
+let inline_indirect_cost =
+  ref (Int_arg_helper.default default_inline_indirect_cost)
+let inline_branch_factor =
+  ref (Float_arg_helper.default default_inline_branch_factor)
+let inline_lifting_benefit =
+  ref (Int_arg_helper.default default_inline_lifting_benefit)
+let inline_max_unroll =
+  ref (Int_arg_helper.default default_inline_max_unroll)
+let inline_max_depth =
+  ref (Int_arg_helper.default default_inline_max_depth)
+
+
+let unbox_specialised_args = ref true   (* -no-unbox-specialised-args *)
+let unbox_free_vars_of_closures = ref true
+let unbox_closures = ref false          (* -unbox-closures *)
+let default_unbox_closures_factor = 10
+let unbox_closures_factor =
+  ref default_unbox_closures_factor      (* -unbox-closures-factor *)
+let remove_unused_arguments = ref false (* -remove-unused-arguments *)
+
+type inlining_arguments = {
+  inline_call_cost : int option;
+  inline_alloc_cost : int option;
+  inline_prim_cost : int option;
+  inline_branch_cost : int option;
+  inline_indirect_cost : int option;
+  inline_lifting_benefit : int option;
+  inline_branch_factor : float option;
+  inline_max_depth : int option;
+  inline_max_unroll : int option;
+  inline_threshold : float option;
+  inline_toplevel_threshold : int option;
+}
+
+let set_int_arg round (arg:Int_arg_helper.parsed ref) default value =
+  let value : int =
+    match value with
+    | None -> default
+    | Some value -> value
+  in
+  match round with
+  | None ->
+    arg := Int_arg_helper.set_base_default value
+             (Int_arg_helper.reset_base_overrides !arg)
+  | Some round ->
+    arg := Int_arg_helper.add_base_override round value !arg
+
+let set_float_arg round (arg:Float_arg_helper.parsed ref) default value =
+  let value =
+    match value with
+    | None -> default
+    | Some value -> value
+  in
+  match round with
+  | None ->
+    arg := Float_arg_helper.set_base_default value
+             (Float_arg_helper.reset_base_overrides !arg)
+  | Some round ->
+    arg := Float_arg_helper.add_base_override round value !arg
+
+let use_inlining_arguments_set ?round (arg:inlining_arguments) =
+  let set_int = set_int_arg round in
+  let set_float = set_float_arg round in
+  set_int inline_call_cost default_inline_call_cost arg.inline_call_cost;
+  set_int inline_alloc_cost default_inline_alloc_cost arg.inline_alloc_cost;
+  set_int inline_prim_cost default_inline_prim_cost arg.inline_prim_cost;
+  set_int inline_branch_cost
+    default_inline_branch_cost arg.inline_branch_cost;
+  set_int inline_indirect_cost
+    default_inline_indirect_cost arg.inline_indirect_cost;
+  set_int inline_lifting_benefit
+    default_inline_lifting_benefit arg.inline_lifting_benefit;
+  set_float inline_branch_factor
+    default_inline_branch_factor arg.inline_branch_factor;
+  set_int inline_max_depth
+    default_inline_max_depth arg.inline_max_depth;
+  set_int inline_max_unroll
+    default_inline_max_unroll arg.inline_max_unroll;
+  set_float inline_threshold
+    default_inline_threshold arg.inline_threshold;
+  set_int inline_toplevel_threshold
+    default_inline_toplevel_threshold arg.inline_toplevel_threshold
+
+(* o1 is the default *)
+let o1_arguments = {
+  inline_call_cost = None;
+  inline_alloc_cost = None;
+  inline_prim_cost = None;
+  inline_branch_cost = None;
+  inline_indirect_cost = None;
+  inline_lifting_benefit = None;
+  inline_branch_factor = None;
+  inline_max_depth = None;
+  inline_max_unroll = None;
+  inline_threshold = None;
+  inline_toplevel_threshold = None;
+}
+
+let classic_arguments = {
+  inline_call_cost = None;
+  inline_alloc_cost = None;
+  inline_prim_cost = None;
+  inline_branch_cost = None;
+  inline_indirect_cost = None;
+  inline_lifting_benefit = None;
+  inline_branch_factor = None;
+  inline_max_depth = None;
+  inline_max_unroll = None;
+  (* [inline_threshold] matches the current compiler's default.
+     Note that this particular fraction can be expressed exactly in
+     floating point. *)
+  inline_threshold = Some (10. /. 8.);
+  (* [inline_toplevel_threshold] is not used in classic mode. *)
+  inline_toplevel_threshold = Some 1;
+}
+
+let o2_arguments = {
+  inline_call_cost = Some (2 * default_inline_call_cost);
+  inline_alloc_cost = Some (2 * default_inline_alloc_cost);
+  inline_prim_cost = Some (2 * default_inline_prim_cost);
+  inline_branch_cost = Some (2 * default_inline_branch_cost);
+  inline_indirect_cost = Some (2 * default_inline_indirect_cost);
+  inline_lifting_benefit = None;
+  inline_branch_factor = None;
+  inline_max_depth = Some 2;
+  inline_max_unroll = None;
+  inline_threshold = Some 25.;
+  inline_toplevel_threshold = Some (25 * inline_toplevel_multiplier);
+}
+
+let o3_arguments = {
+  inline_call_cost = Some (3 * default_inline_call_cost);
+  inline_alloc_cost = Some (3 * default_inline_alloc_cost);
+  inline_prim_cost = Some (3 * default_inline_prim_cost);
+  inline_branch_cost = Some (3 * default_inline_branch_cost);
+  inline_indirect_cost = Some (3 * default_inline_indirect_cost);
+  inline_lifting_benefit = None;
+  inline_branch_factor = Some 0.;
+  inline_max_depth = Some 3;
+  inline_max_unroll = Some 1;
+  inline_threshold = Some 50.;
+  inline_toplevel_threshold = Some (50 * inline_toplevel_multiplier);
+}
+
+let all_passes = ref []
+let dumped_passes_list = ref []
+let dumped_pass s =
+  assert(List.mem s !all_passes);
+  List.mem s !dumped_passes_list
+
+let set_dumped_pass s enabled =
+  if (List.mem s !all_passes) then begin
+    let passes_without_s = List.filter ((<>) s) !dumped_passes_list in
+    let dumped_passes =
+      if enabled then
+        s :: passes_without_s
+      else
+        passes_without_s
+    in
+    dumped_passes_list := dumped_passes
+  end
+
+let dump_into_file = ref false (* -dump-into-file *)
+
+type 'a env_reader = {
+  parse : string -> 'a option;
+  print : 'a -> string;
+  usage : string;
+  env_var : string;
+}
+
+let color = ref None (* -color *)
+
+let color_reader = {
+  parse = (function
+    | "auto" -> Some Misc.Color.Auto
+    | "always" -> Some Misc.Color.Always
+    | "never" -> Some Misc.Color.Never
+    | _ -> None);
+  print = (function
+    | Misc.Color.Auto -> "auto"
+    | Misc.Color.Always -> "always"
+    | Misc.Color.Never -> "never");
+  usage = "expected \"auto\", \"always\" or \"never\"";
+  env_var = "OCAML_COLOR";
+}
+
+let error_style = ref None (* -error-style *)
+
+let error_style_reader = {
+  parse = (function
+    | "contextual" -> Some Misc.Error_style.Contextual
+    | "short" -> Some Misc.Error_style.Short
+    | _ -> None);
+  print = (function
+    | Misc.Error_style.Contextual -> "contextual"
+    | Misc.Error_style.Short -> "short");
+  usage = "expected \"contextual\" or \"short\"";
+  env_var = "OCAML_ERROR_STYLE";
+}
+
+let unboxed_types = ref false
+
+(* This is used by the -save-ir-after option. *)
+module Compiler_ir = struct
+  type t = Linear
+
+  let all = [
+    Linear;
+  ]
+
+  let extension t =
+    let ext =
+    match t with
+      | Linear -> "linear"
+    in
+    ".cmir-" ^ ext
+
+  (** [extract_extension_with_pass filename] returns the IR whose extension
+      is a prefix of the extension of [filename], and the suffix,
+      which can be used to distinguish different passes on the same IR.
+      For example, [extract_extension_with_pass "foo.cmir-linear123"]
+      returns [Some (Linear, "123")]. *)
+  let extract_extension_with_pass filename =
+    let ext = Filename.extension filename in
+    let ext_len = String.length ext in
+    if ext_len <= 0 then None
+    else begin
+      let is_prefix ir =
+        let s = extension ir in
+        let s_len = String.length s in
+        s_len <= ext_len && s = String.sub ext 0 s_len
+      in
+      let drop_prefix ir =
+        let s = extension ir in
+        let s_len = String.length s in
+        String.sub ext s_len (ext_len - s_len)
+      in
+      let ir = List.find_opt is_prefix all in
+      match ir with
+      | None -> None
+      | Some ir -> Some (ir, drop_prefix ir)
+    end
+end
+
+(* This is used by the -stop-after option. *)
+module Compiler_pass = struct
+  (* If you add a new pass, the following must be updated:
+     - the variable `passes` below
+     - the manpages in man/ocaml{c,opt}.m
+     - the manual manual/manual/cmds/unified-options.etex
+  *)
+  type t = Parsing | Typing | Scheduling | Emit
+
+  let to_string = function
+    | Parsing -> "parsing"
+    | Typing -> "typing"
+    | Scheduling -> "scheduling"
+    | Emit -> "emit"
+
+  let of_string = function
+    | "parsing" -> Some Parsing
+    | "typing" -> Some Typing
+    | "scheduling" -> Some Scheduling
+    | "emit" -> Some Emit
+    | _ -> None
+
+  let rank = function
+    | Parsing -> 0
+    | Typing -> 1
+    | Scheduling -> 50
+    | Emit -> 60
+
+  let passes = [
+    Parsing;
+    Typing;
+    Scheduling;
+    Emit;
+  ]
+  let is_compilation_pass _ = true
+  let is_native_only = function
+    | Scheduling -> true
+    | Emit -> true
+    | _ -> false
+
+  let enabled is_native t = not (is_native_only t) || is_native
+  let can_save_ir_after = function
+    | Scheduling -> true
+    | _ -> false
+
+  let available_pass_names ~filter ~native =
+    passes
+    |> List.filter (enabled native)
+    |> List.filter filter
+    |> List.map to_string
+
+  let compare a b =
+    compare (rank a) (rank b)
+
+  let to_output_filename t ~prefix =
+    match t with
+    | Scheduling -> prefix ^ Compiler_ir.(extension Linear)
+    | _ -> Misc.fatal_error "Not supported"
+
+  let of_input_filename name =
+    match Compiler_ir.extract_extension_with_pass name with
+    | Some (Linear, _) -> Some Emit
+    | None -> None
+end
+
+let stop_after = ref None (* -stop-after *)
+
+let should_stop_after pass =
+  if Compiler_pass.(rank Typing <= rank pass) && !print_types then true
+  else
+    match !stop_after with
+    | None -> false
+    | Some stop -> Compiler_pass.rank stop <= Compiler_pass.rank pass
+
+let save_ir_after = ref []
+
+let should_save_ir_after pass =
+  List.mem pass !save_ir_after
+
+let set_save_ir_after pass enabled =
+  let other_passes = List.filter ((<>) pass) !save_ir_after in
+  let new_passes =
+    if enabled then
+      pass :: other_passes
+    else
+      other_passes
+  in
+  save_ir_after := new_passes
+
+module String = Misc.Stdlib.String
+
+let arg_spec = ref []
+let arg_names = ref String.Map.empty
+
+let reset_arguments () =
+  arg_spec := [];
+  arg_names := String.Map.empty
+
+let add_arguments loc args =
+  List.iter (function (arg_name, _, _) as arg ->
+    try
+      let loc2 = String.Map.find arg_name !arg_names in
+      Printf.eprintf
+        "Warning: compiler argument %s is already defined:\n" arg_name;
+      Printf.eprintf "   First definition: %s\n" loc2;
+      Printf.eprintf "   New definition: %s\n" loc;
+    with Not_found ->
+      arg_spec := !arg_spec @ [ arg ];
+      arg_names := String.Map.add arg_name loc !arg_names
+  ) args
+
+let print_arguments usage =
+  Arg.usage !arg_spec usage
+
+(* This function is almost the same as [Arg.parse_expand], except
+   that [Arg.parse_expand] could not be used because it does not take a
+   reference for [arg_spec].*)
+let parse_arguments argv f msg =
+  try
+    let argv = ref argv in
+    let current = ref 0 in
+    Arg.parse_and_expand_argv_dynamic current argv arg_spec f msg
+  with
+  | Arg.Bad msg -> Printf.eprintf "%s" msg; exit 2
+  | Arg.Help msg -> Printf.printf "%s" msg; exit 0
diff --git a/upstream/ocaml_412/utils/clflags.mli b/upstream/ocaml_412/utils/clflags.mli
new file mode 100644
index 0000000..645ff4a
--- /dev/null
+++ b/upstream/ocaml_412/utils/clflags.mli
@@ -0,0 +1,272 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2005 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Command line flags *)
+
+(** Optimization parameters represented as ints indexed by round number. *)
+module Int_arg_helper : sig
+  type parsed
+
+  val parse : string -> string -> parsed ref -> unit
+
+  type parse_result =
+    | Ok
+    | Parse_failed of exn
+  val parse_no_error : string -> parsed ref -> parse_result
+
+  val get : key:int -> parsed -> int
+end
+
+(** Optimization parameters represented as floats indexed by round number. *)
+module Float_arg_helper : sig
+  type parsed
+
+  val parse : string -> string -> parsed ref -> unit
+
+  type parse_result =
+    | Ok
+    | Parse_failed of exn
+  val parse_no_error : string -> parsed ref -> parse_result
+
+  val get : key:int -> parsed -> float
+end
+
+type inlining_arguments = {
+  inline_call_cost : int option;
+  inline_alloc_cost : int option;
+  inline_prim_cost : int option;
+  inline_branch_cost : int option;
+  inline_indirect_cost : int option;
+  inline_lifting_benefit : int option;
+  inline_branch_factor : float option;
+  inline_max_depth : int option;
+  inline_max_unroll : int option;
+  inline_threshold : float option;
+  inline_toplevel_threshold : int option;
+}
+
+val classic_arguments : inlining_arguments
+val o1_arguments : inlining_arguments
+val o2_arguments : inlining_arguments
+val o3_arguments : inlining_arguments
+
+(** Set all the inlining arguments for a round.
+    The default is set if no round is provided. *)
+val use_inlining_arguments_set : ?round:int -> inlining_arguments -> unit
+
+val objfiles : string list ref
+val ccobjs : string list ref
+val dllibs : string list ref
+val compile_only : bool ref
+val output_name : string option ref
+val include_dirs : string list ref
+val no_std_include : bool ref
+val print_types : bool ref
+val make_archive : bool ref
+val debug : bool ref
+val debug_full : bool ref
+val unsafe : bool ref
+val use_linscan : bool ref
+val link_everything : bool ref
+val custom_runtime : bool ref
+val no_check_prims : bool ref
+val bytecode_compatible_32 : bool ref
+val output_c_object : bool ref
+val output_complete_object : bool ref
+val output_complete_executable : bool ref
+val all_ccopts : string list ref
+val classic : bool ref
+val nopervasives : bool ref
+val match_context_rows : int ref
+val open_modules : string list ref
+val preprocessor : string option ref
+val all_ppx : string list ref
+val absname : bool ref
+val annotations : bool ref
+val binary_annotations : bool ref
+val use_threads : bool ref
+val noassert : bool ref
+val verbose : bool ref
+val noprompt : bool ref
+val nopromptcont : bool ref
+val init_file : string option ref
+val noinit : bool ref
+val noversion : bool ref
+val use_prims : string ref
+val use_runtime : string ref
+val plugin : bool ref
+val principal : bool ref
+val real_paths : bool ref
+val recursive_types : bool ref
+val strict_sequence : bool ref
+val strict_formats : bool ref
+val applicative_functors : bool ref
+val make_runtime : bool ref
+val c_compiler : string option ref
+val no_auto_link : bool ref
+val dllpaths : string list ref
+val make_package : bool ref
+val for_package : string option ref
+val error_size : int ref
+val float_const_prop : bool ref
+val transparent_modules : bool ref
+val unique_ids : bool ref
+val locations : bool ref
+val dump_source : bool ref
+val dump_parsetree : bool ref
+val dump_typedtree : bool ref
+val dump_rawlambda : bool ref
+val dump_lambda : bool ref
+val dump_rawclambda : bool ref
+val dump_clambda : bool ref
+val dump_rawflambda : bool ref
+val dump_flambda : bool ref
+val dump_flambda_let : int option ref
+val dump_instr : bool ref
+val keep_camlprimc_file : bool ref
+val keep_asm_file : bool ref
+val optimize_for_speed : bool ref
+val dump_cmm : bool ref
+val dump_selection : bool ref
+val dump_cse : bool ref
+val dump_live : bool ref
+val dump_avail : bool ref
+val debug_runavail : bool ref
+val dump_spill : bool ref
+val dump_split : bool ref
+val dump_interf : bool ref
+val dump_prefer : bool ref
+val dump_regalloc : bool ref
+val dump_reload : bool ref
+val dump_scheduling : bool ref
+val dump_linear : bool ref
+val dump_interval : bool ref
+val keep_startup_file : bool ref
+val dump_combine : bool ref
+val native_code : bool ref
+val default_inline_threshold : float
+val inline_threshold : Float_arg_helper.parsed ref
+val inlining_report : bool ref
+val simplify_rounds : int option ref
+val default_simplify_rounds : int ref
+val rounds : unit -> int
+val default_inline_max_unroll : int
+val inline_max_unroll : Int_arg_helper.parsed ref
+val default_inline_toplevel_threshold : int
+val inline_toplevel_threshold : Int_arg_helper.parsed ref
+val default_inline_call_cost : int
+val default_inline_alloc_cost : int
+val default_inline_prim_cost : int
+val default_inline_branch_cost : int
+val default_inline_indirect_cost : int
+val default_inline_lifting_benefit : int
+val inline_call_cost : Int_arg_helper.parsed ref
+val inline_alloc_cost : Int_arg_helper.parsed ref
+val inline_prim_cost : Int_arg_helper.parsed ref
+val inline_branch_cost : Int_arg_helper.parsed ref
+val inline_indirect_cost : Int_arg_helper.parsed ref
+val inline_lifting_benefit : Int_arg_helper.parsed ref
+val default_inline_branch_factor : float
+val inline_branch_factor : Float_arg_helper.parsed ref
+val dont_write_files : bool ref
+val std_include_flag : string -> string
+val std_include_dir : unit -> string list
+val shared : bool ref
+val dlcode : bool ref
+val pic_code : bool ref
+val runtime_variant : string ref
+val with_runtime : bool ref
+val force_slash : bool ref
+val keep_docs : bool ref
+val keep_locs : bool ref
+val unsafe_string : bool ref
+val opaque : bool ref
+val profile_columns : Profile.column list ref
+val flambda_invariant_checks : bool ref
+val unbox_closures : bool ref
+val unbox_closures_factor : int ref
+val default_unbox_closures_factor : int
+val unbox_free_vars_of_closures : bool ref
+val unbox_specialised_args : bool ref
+val clambda_checks : bool ref
+val default_inline_max_depth : int
+val inline_max_depth : Int_arg_helper.parsed ref
+val remove_unused_arguments : bool ref
+val dump_flambda_verbose : bool ref
+val classic_inlining : bool ref
+val afl_instrument : bool ref
+val afl_inst_ratio : int ref
+val function_sections : bool ref
+
+val all_passes : string list ref
+val dumped_pass : string -> bool
+val set_dumped_pass : string -> bool -> unit
+
+val dump_into_file : bool ref
+
+(* Support for flags that can also be set from an environment variable *)
+type 'a env_reader = {
+  parse : string -> 'a option;
+  print : 'a -> string;
+  usage : string;
+  env_var : string;
+}
+
+val color : Misc.Color.setting option ref
+val color_reader : Misc.Color.setting env_reader
+
+val error_style : Misc.Error_style.setting option ref
+val error_style_reader : Misc.Error_style.setting env_reader
+
+val unboxed_types : bool ref
+
+val insn_sched : bool ref
+val insn_sched_default : bool
+
+module Compiler_pass : sig
+  type t = Parsing | Typing | Scheduling | Emit
+  val of_string : string -> t option
+  val to_string : t -> string
+  val is_compilation_pass : t -> bool
+  val available_pass_names : filter:(t -> bool) -> native:bool -> string list
+  val can_save_ir_after : t -> bool
+  val compare : t -> t -> int
+  val to_output_filename: t -> prefix:string -> string
+  val of_input_filename: string -> t option
+end
+val stop_after : Compiler_pass.t option ref
+val should_stop_after : Compiler_pass.t -> bool
+val set_save_ir_after : Compiler_pass.t -> bool -> unit
+val should_save_ir_after : Compiler_pass.t -> bool
+
+val arg_spec : (string * Arg.spec * string) list ref
+
+(* [add_arguments __LOC__ args] will add the arguments from [args] at
+   the end of [arg_spec], checking that they have not already been
+   added by [add_arguments] before. A warning is printed showing the
+   locations of the function from which the argument was previously
+   added. *)
+val add_arguments : string -> (string * Arg.spec * string) list -> unit
+
+(* [parse_arguments argv anon_arg usage] will parse the arguments, using
+  the arguments provided in [Clflags.arg_spec].
+*)
+val parse_arguments : string array -> Arg.anon_fun -> string -> unit
+
+(* [print_arguments usage] print the standard usage message *)
+val print_arguments : string -> unit
+
+(* [reset_arguments ()] clear all declared arguments *)
+val reset_arguments : unit -> unit
diff --git a/upstream/ocaml_412/utils/config.mli b/upstream/ocaml_412/utils/config.mli
new file mode 100644
index 0000000..1b73eed
--- /dev/null
+++ b/upstream/ocaml_412/utils/config.mli
@@ -0,0 +1,252 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** System configuration
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+val version: string
+(** The current version number of the system *)
+
+val standard_library: string
+(** The directory containing the standard libraries *)
+
+val ccomp_type: string
+(** The "kind" of the C compiler, assembler and linker used: one of
+    "cc" (for Unix-style C compilers)
+    "msvc" (for Microsoft Visual C++ and MASM) *)
+
+val c_compiler: string
+(** The compiler to use for compiling C files *)
+
+val c_output_obj: string
+(** Name of the option of the C compiler for specifying the output
+    file *)
+
+val c_has_debug_prefix_map : bool
+(** Whether the C compiler supports -fdebug-prefix-map *)
+
+val as_has_debug_prefix_map : bool
+(** Whether the assembler supports --debug-prefix-map *)
+
+val ocamlc_cflags : string
+(** The flags ocamlc should pass to the C compiler *)
+
+val ocamlc_cppflags : string
+(** The flags ocamlc should pass to the C preprocessor *)
+
+val ocamlopt_cflags : string
+  [@@ocaml.deprecated "Use ocamlc_cflags instead."]
+(** @deprecated {!ocamlc_cflags} should be used instead.
+    The flags ocamlopt should pass to the C compiler *)
+
+val ocamlopt_cppflags : string
+  [@@ocaml.deprecated "Use ocamlc_cppflags instead."]
+(** @deprecated {!ocamlc_cppflags} should be used instead.
+    The flags ocamlopt should pass to the C preprocessor *)
+
+val bytecomp_c_libraries: string
+(** The C libraries to link with custom runtimes *)
+
+val native_c_libraries: string
+(** The C libraries to link with native-code programs *)
+
+val native_pack_linker: string
+(** The linker to use for packaging (ocamlopt -pack) and for partial
+    links (ocamlopt -output-obj). *)
+
+val mkdll: string
+(** The linker command line to build dynamic libraries. *)
+
+val mkexe: string
+(** The linker command line to build executables. *)
+
+val mkmaindll: string
+(** The linker command line to build main programs as dlls. *)
+
+val ranlib: string
+(** Command to randomize a library, or "" if not needed *)
+
+val ar: string
+(** Name of the ar command, or "" if not needed  (MSVC) *)
+
+val interface_suffix: string ref
+(** Suffix for interface file names *)
+
+val exec_magic_number: string
+(** Magic number for bytecode executable files *)
+
+val cmi_magic_number: string
+(** Magic number for compiled interface files *)
+
+val cmo_magic_number: string
+(** Magic number for object bytecode files *)
+
+val cma_magic_number: string
+(** Magic number for archive files *)
+
+val cmx_magic_number: string
+(** Magic number for compilation unit descriptions *)
+
+val cmxa_magic_number: string
+(** Magic number for libraries of compilation unit descriptions *)
+
+val ast_intf_magic_number: string
+(** Magic number for file holding an interface syntax tree *)
+
+val ast_impl_magic_number: string
+(** Magic number for file holding an implementation syntax tree *)
+
+val cmxs_magic_number: string
+(** Magic number for dynamically-loadable plugins *)
+
+val cmt_magic_number: string
+(** Magic number for compiled interface files *)
+
+val linear_magic_number: string
+(** Magic number for Linear internal representation files *)
+
+val max_tag: int
+(** Biggest tag that can be stored in the header of a regular block. *)
+
+val lazy_tag : int
+(** Normally the same as Obj.lazy_tag.  Separate definition because
+    of technical reasons for bootstrapping. *)
+
+val max_young_wosize: int
+(** Maximal size of arrays that are directly allocated in the
+    minor heap *)
+
+val stack_threshold: int
+(** Size in words of safe area at bottom of VM stack,
+    see runtime/caml/config.h *)
+
+val stack_safety_margin: int
+(** Size in words of the safety margin between the bottom of
+    the stack and the stack pointer. This margin can be used by
+    intermediate computations of some instructions, or the event
+    handler. *)
+
+val architecture: string
+(** Name of processor type for the native-code compiler *)
+
+val model: string
+(** Name of processor submodel for the native-code compiler *)
+
+val system: string
+(** Name of operating system for the native-code compiler *)
+
+val asm: string
+(** The assembler (and flags) to use for assembling
+    ocamlopt-generated code. *)
+
+val asm_cfi_supported: bool
+(** Whether assembler understands CFI directives *)
+
+val with_frame_pointers : bool
+(** Whether assembler should maintain frame pointers *)
+
+val ext_obj: string
+(** Extension for object files, e.g. [.o] under Unix. *)
+
+val ext_asm: string
+(** Extension for assembler files, e.g. [.s] under Unix. *)
+
+val ext_lib: string
+(** Extension for library files, e.g. [.a] under Unix. *)
+
+val ext_dll: string
+(** Extension for dynamically-loaded libraries, e.g. [.so] under Unix.*)
+
+val ext_exe: string
+(** Extension for executable programs, e.g. [.exe] under Windows.
+
+    @since 4.12.0 *)
+
+val default_executable_name: string
+(** Name of executable produced by linking if none is given with -o,
+    e.g. [a.out] under Unix. *)
+
+val systhread_supported : bool
+(** Whether the system thread library is implemented *)
+
+val flexdll_dirs : string list
+(** Directories needed for the FlexDLL objects *)
+
+val host : string
+(** Whether the compiler is a cross-compiler *)
+
+val target : string
+(** Whether the compiler is a cross-compiler *)
+
+val flambda : bool
+(** Whether the compiler was configured for flambda *)
+
+val with_flambda_invariants : bool
+(** Whether the invariants checks for flambda are enabled *)
+
+val profinfo : bool
+(** Whether the compiler was configured for profiling *)
+
+val profinfo_width : int
+(** How many bits are to be used in values' headers for profiling
+    information *)
+
+val safe_string: bool
+(** Whether the compiler was configured with -force-safe-string;
+    in that case, the -unsafe-string compile-time option is unavailable
+
+    @since 4.05.0 *)
+
+val default_safe_string: bool
+(** Whether the compiler was configured to use the -safe-string
+    or -unsafe-string compile-time option by default.
+
+    @since 4.06.0 *)
+
+val flat_float_array : bool
+(** Whether the compiler and runtime automagically flatten float
+    arrays *)
+
+val function_sections : bool
+(** Whether the compiler was configured to generate
+    each function in a separate section *)
+
+val windows_unicode: bool
+(** Whether Windows Unicode runtime is enabled *)
+
+val supports_shared_libraries: bool
+(** Whether shared libraries are supported
+
+    @since 4.08.0 *)
+
+val afl_instrument : bool
+(** Whether afl-fuzz instrumentation is generated by default *)
+
+
+(** Access to configuration values *)
+val print_config : out_channel -> unit
+
+val config_var : string -> string option
+(** the configuration value of a variable, if it exists *)
+
+(**/**)
+
+val merlin : bool
+
+(**/**)
diff --git a/upstream/ocaml_412/utils/config.mlp b/upstream/ocaml_412/utils/config.mlp
new file mode 100644
index 0000000..10df2bd
--- /dev/null
+++ b/upstream/ocaml_412/utils/config.mlp
@@ -0,0 +1,241 @@
+#2 "utils/config.mlp"
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* The main OCaml version string has moved to ../VERSION *)
+let version = Sys.ocaml_version
+
+let standard_library_default = "%%LIBDIR%%"
+
+let standard_library =
+  try
+    Sys.getenv "OCAMLLIB"
+  with Not_found ->
+  try
+    Sys.getenv "CAMLLIB"
+  with Not_found ->
+    standard_library_default
+
+let ccomp_type = "%%CCOMPTYPE%%"
+let c_compiler = "%%CC%%"
+let c_output_obj = "%%OUTPUTOBJ%%"
+let c_has_debug_prefix_map = %%CC_HAS_DEBUG_PREFIX_MAP%%
+let as_has_debug_prefix_map = %%AS_HAS_DEBUG_PREFIX_MAP%%
+let ocamlc_cflags = "%%OCAMLC_CFLAGS%%"
+let ocamlc_cppflags = "%%OCAMLC_CPPFLAGS%%"
+(* #7678: ocamlopt uses these only to compile .c files, and the behaviour for
+          the two drivers should be identical. *)
+let ocamlopt_cflags = "%%OCAMLC_CFLAGS%%"
+let ocamlopt_cppflags = "%%OCAMLOPT_CPPFLAGS%%"
+let bytecomp_c_libraries = "%%BYTECCLIBS%%"
+(* bytecomp_c_compiler and native_c_compiler have been supported for a
+   long time and are retained for backwards compatibility.
+   For programs that don't need compatibility with older OCaml releases
+   the recommended approach is to use the constituent variables
+   c_compiler, ocamlc_cflags, ocamlc_cppflags etc., directly.
+*)
+let bytecomp_c_compiler =
+  c_compiler ^ " " ^ ocamlc_cflags ^ " " ^ ocamlc_cppflags
+let native_c_compiler =
+  c_compiler ^ " " ^ ocamlopt_cflags ^ " " ^ ocamlopt_cppflags
+let native_c_libraries = "%%NATIVECCLIBS%%"
+let native_pack_linker = "%%PACKLD%%"
+let ranlib = "%%RANLIBCMD%%"
+let ar = "%%ARCMD%%"
+let mkdll, mkexe, mkmaindll =
+  (* @@DRA Cygwin - but only if shared libraries are enabled, which we
+     should be able to detect? *)
+  if Sys.os_type = "Win32" then
+    try
+      let flexlink =
+        let flexlink = Sys.getenv "OCAML_FLEXLINK" in
+        let f i =
+          let c = flexlink.[i] in
+          if c = '/' then '\\' else c in
+        (String.init (String.length flexlink) f) ^ " %%FLEXLINK_FLAGS%%" in
+      flexlink,
+      flexlink ^ " -exe%%FLEXLINK_LDFLAGS%%",
+      flexlink ^ " -maindll"
+    with Not_found ->
+      "%%MKDLL%%", "%%MKEXE%%", "%%MKMAINDLL%%"
+  else
+    "%%MKDLL%%", "%%MKEXE%%", "%%MKMAINDLL%%"
+
+let flambda = %%FLAMBDA%%
+let with_flambda_invariants = %%WITH_FLAMBDA_INVARIANTS%%
+let safe_string = %%FORCE_SAFE_STRING%%
+let default_safe_string = %%DEFAULT_SAFE_STRING%%
+let windows_unicode = %%WINDOWS_UNICODE%% != 0
+let supports_shared_libraries = %%SUPPORTS_SHARED_LIBRARIES%%
+
+let flat_float_array = %%FLAT_FLOAT_ARRAY%%
+
+let function_sections = %%FUNCTION_SECTIONS%%
+let afl_instrument = %%AFL_INSTRUMENT%%
+
+let exec_magic_number = "Caml1999X029"
+    (* exec_magic_number is duplicated in runtime/caml/exec.h *)
+and cmi_magic_number = "Caml1999I029"
+and cmo_magic_number = "Caml1999O029"
+and cma_magic_number = "Caml1999A029"
+and cmx_magic_number =
+  if flambda then
+    "Caml1999y029"
+  else
+    "Caml1999Y029"
+and cmxa_magic_number =
+  if flambda then
+    "Caml1999z029"
+  else
+    "Caml1999Z029"
+and ast_impl_magic_number = "Caml1999M029"
+and ast_intf_magic_number = "Caml1999N029"
+and cmxs_magic_number = "Caml1999D029"
+and cmt_magic_number = "Caml1999T029"
+and linear_magic_number = "Caml1999L029"
+
+let interface_suffix = ref ".mli"
+
+let max_tag = 245
+(* This is normally the same as in obj.ml, but we have to define it
+   separately because it can differ when we're in the middle of a
+   bootstrapping phase. *)
+let lazy_tag = 246
+
+let max_young_wosize = 256
+let stack_threshold = 256 (* see runtime/caml/config.h *)
+let stack_safety_margin = 60
+
+let architecture = "%%ARCH%%"
+let model = "%%MODEL%%"
+let system = "%%SYSTEM%%"
+
+let asm = "%%ASM%%"
+let asm_cfi_supported = %%ASM_CFI_SUPPORTED%%
+let with_frame_pointers = %%WITH_FRAME_POINTERS%%
+let profinfo = %%WITH_PROFINFO%%
+let profinfo_width = %%PROFINFO_WIDTH%%
+
+let ext_exe = "%%EXE%%"
+let ext_obj = "%%EXT_OBJ%%"
+let ext_asm = "%%EXT_ASM%%"
+let ext_lib = "%%EXT_LIB%%"
+let ext_dll = "%%EXT_DLL%%"
+
+let host = "%%HOST%%"
+let target = "%%TARGET%%"
+
+let default_executable_name =
+  match Sys.os_type with
+    "Unix" -> "a.out"
+  | "Win32" | "Cygwin" -> "camlprog.exe"
+  | _ -> "camlprog"
+
+let systhread_supported = %%SYSTHREAD_SUPPORT%%;;
+
+let flexdll_dirs = [%%FLEXDLL_DIR%%];;
+
+type configuration_value =
+  | String of string
+  | Int of int
+  | Bool of bool
+
+let configuration_variables =
+  let p x v = (x, String v) in
+  let p_int x v = (x, Int v) in
+  let p_bool x v = (x, Bool v) in
+[
+  p "version" version;
+  p "standard_library_default" standard_library_default;
+  p "standard_library" standard_library;
+  p "ccomp_type" ccomp_type;
+  p "c_compiler" c_compiler;
+  p "ocamlc_cflags" ocamlc_cflags;
+  p "ocamlc_cppflags" ocamlc_cppflags;
+  p "ocamlopt_cflags" ocamlopt_cflags;
+  p "ocamlopt_cppflags" ocamlopt_cppflags;
+  p "bytecomp_c_compiler" bytecomp_c_compiler;
+  p "native_c_compiler" native_c_compiler;
+  p "bytecomp_c_libraries" bytecomp_c_libraries;
+  p "native_c_libraries" native_c_libraries;
+  p "native_pack_linker" native_pack_linker;
+  p "ranlib" ranlib;
+  p "architecture" architecture;
+  p "model" model;
+  p_int "int_size" Sys.int_size;
+  p_int "word_size" Sys.word_size;
+  p "system" system;
+  p "asm" asm;
+  p_bool "asm_cfi_supported" asm_cfi_supported;
+  p_bool "with_frame_pointers" with_frame_pointers;
+  p "ext_exe" ext_exe;
+  p "ext_obj" ext_obj;
+  p "ext_asm" ext_asm;
+  p "ext_lib" ext_lib;
+  p "ext_dll" ext_dll;
+  p "os_type" Sys.os_type;
+  p "default_executable_name" default_executable_name;
+  p_bool "systhread_supported" systhread_supported;
+  p "host" host;
+  p "target" target;
+  p_bool "flambda" flambda;
+  p_bool "safe_string" safe_string;
+  p_bool "default_safe_string" default_safe_string;
+  p_bool "flat_float_array" flat_float_array;
+  p_bool "function_sections" function_sections;
+  p_bool "afl_instrument" afl_instrument;
+  p_bool "windows_unicode" windows_unicode;
+  p_bool "supports_shared_libraries" supports_shared_libraries;
+
+  p "exec_magic_number" exec_magic_number;
+  p "cmi_magic_number" cmi_magic_number;
+  p "cmo_magic_number" cmo_magic_number;
+  p "cma_magic_number" cma_magic_number;
+  p "cmx_magic_number" cmx_magic_number;
+  p "cmxa_magic_number" cmxa_magic_number;
+  p "ast_impl_magic_number" ast_impl_magic_number;
+  p "ast_intf_magic_number" ast_intf_magic_number;
+  p "cmxs_magic_number" cmxs_magic_number;
+  p "cmt_magic_number" cmt_magic_number;
+  p "linear_magic_number" linear_magic_number;
+]
+
+let print_config_value oc = function
+  | String s ->
+      Printf.fprintf oc "%s" s
+  | Int n ->
+      Printf.fprintf oc "%d" n
+  | Bool p ->
+      Printf.fprintf oc "%B" p
+
+let print_config oc =
+  let print (x, v) =
+    Printf.fprintf oc "%s: %a\n" x print_config_value v in
+  List.iter print configuration_variables;
+  flush oc;
+;;
+
+let config_var x =
+  match List.assoc_opt x configuration_variables with
+  | None -> None
+  | Some v ->
+      let s = match v with
+        | String s -> s
+        | Int n -> Int.to_string n
+        | Bool b -> string_of_bool b
+      in
+      Some s
+
+let merlin = false
diff --git a/upstream/ocaml_412/utils/consistbl.ml b/upstream/ocaml_412/utils/consistbl.ml
new file mode 100644
index 0000000..b329911
--- /dev/null
+++ b/upstream/ocaml_412/utils/consistbl.ml
@@ -0,0 +1,97 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Consistency tables: for checking consistency of module CRCs *)
+
+open Misc
+
+module Make (Module_name : sig
+  type t
+  module Set : Set.S with type elt = t
+  module Map : Map.S with type key = t
+  module Tbl : Hashtbl.S with type key = t
+  val compare : t -> t -> int
+end) = struct
+  type t = (Digest.t * filepath) Module_name.Tbl.t
+
+  let create () = Module_name.Tbl.create 13
+
+  let clear = Module_name.Tbl.clear
+
+  exception Inconsistency of {
+    unit_name : Module_name.t;
+    inconsistent_source : string;
+    original_source : string;
+  }
+
+  exception Not_available of Module_name.t
+
+  let check_ tbl name crc source =
+    let (old_crc, old_source) = Module_name.Tbl.find tbl name in
+    if crc <> old_crc then raise(Inconsistency {
+        unit_name = name;
+        inconsistent_source = source;
+        original_source = old_source;
+      })
+
+  let check tbl name crc source =
+    try check_ tbl name crc source
+    with Not_found ->
+      Module_name.Tbl.add tbl name (crc, source)
+
+  let check_noadd tbl name crc source =
+    try check_ tbl name crc source
+    with Not_found ->
+      raise (Not_available name)
+
+  let set tbl name crc source = Module_name.Tbl.add tbl name (crc, source)
+
+  let source tbl name = snd (Module_name.Tbl.find tbl name)
+
+  let extract l tbl =
+    let l = List.sort_uniq Module_name.compare l in
+    List.fold_left
+      (fun assc name ->
+         try
+           let (crc, _) = Module_name.Tbl.find tbl name in
+             (name, Some crc) :: assc
+         with Not_found ->
+           (name, None) :: assc)
+      [] l
+
+  let extract_map mod_names tbl =
+    Module_name.Set.fold
+      (fun name result ->
+         try
+           let (crc, _) = Module_name.Tbl.find tbl name in
+           Module_name.Map.add name (Some crc) result
+         with Not_found ->
+           Module_name.Map.add name None result)
+      mod_names
+      Module_name.Map.empty
+
+  let filter p tbl =
+    let to_remove = ref [] in
+    Module_name.Tbl.iter
+      (fun name _ ->
+        if not (p name) then to_remove := name :: !to_remove)
+      tbl;
+    List.iter
+      (fun name ->
+         while Module_name.Tbl.mem tbl name do
+           Module_name.Tbl.remove tbl name
+         done)
+      !to_remove
+end
diff --git a/upstream/ocaml_412/utils/consistbl.mli b/upstream/ocaml_412/utils/consistbl.mli
new file mode 100644
index 0000000..5067add
--- /dev/null
+++ b/upstream/ocaml_412/utils/consistbl.mli
@@ -0,0 +1,82 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Consistency tables: for checking consistency of module CRCs
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Misc
+
+module Make (Module_name : sig
+  type t
+  module Set : Set.S with type elt = t
+  module Map : Map.S with type key = t
+  module Tbl : Hashtbl.S with type key = t
+  val compare : t -> t -> int
+end) : sig
+  type t
+
+  val create: unit -> t
+
+  val clear: t -> unit
+
+  val check: t -> Module_name.t -> Digest.t -> filepath -> unit
+        (* [check tbl name crc source]
+             checks consistency of ([name], [crc]) with infos previously
+             stored in [tbl].  If no CRC was previously associated with
+             [name], record ([name], [crc]) in [tbl].
+             [source] is the name of the file from which the information
+             comes from.  This is used for error reporting. *)
+
+  val check_noadd: t -> Module_name.t -> Digest.t -> filepath -> unit
+        (* Same as [check], but raise [Not_available] if no CRC was previously
+             associated with [name]. *)
+
+  val set: t -> Module_name.t -> Digest.t -> filepath -> unit
+        (* [set tbl name crc source] forcefully associates [name] with
+           [crc] in [tbl], even if [name] already had a different CRC
+           associated with [name] in [tbl]. *)
+
+  val source: t -> Module_name.t -> filepath
+        (* [source tbl name] returns the file name associated with [name]
+           if the latter has an associated CRC in [tbl].
+           Raise [Not_found] otherwise. *)
+
+  val extract: Module_name.t list -> t -> (Module_name.t * Digest.t option) list
+        (* [extract tbl names] returns an associative list mapping each string
+           in [names] to the CRC associated with it in [tbl]. If no CRC is
+           associated with a name then it is mapped to [None]. *)
+
+  val extract_map : Module_name.Set.t -> t -> Digest.t option Module_name.Map.t
+        (* Like [extract] but with a more sophisticated type. *)
+
+  val filter: (Module_name.t -> bool) -> t -> unit
+        (* [filter pred tbl] removes from [tbl] table all (name, CRC) pairs
+           such that [pred name] is [false]. *)
+
+  exception Inconsistency of {
+    unit_name : Module_name.t;
+    inconsistent_source : string;
+    original_source : string;
+  }
+  (* Raised by [check] when a CRC mismatch is detected. *)
+
+  exception Not_available of Module_name.t
+        (* Raised by [check_noadd] when a name doesn't have an associated
+           CRC. *)
+end
diff --git a/upstream/ocaml_412/utils/identifiable.ml b/upstream/ocaml_412/utils/identifiable.ml
new file mode 100644
index 0000000..9bbfb65
--- /dev/null
+++ b/upstream/ocaml_412/utils/identifiable.ml
@@ -0,0 +1,249 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+module type Thing = sig
+  type t
+
+  include Hashtbl.HashedType with type t := t
+  include Map.OrderedType with type t := t
+
+  val output : out_channel -> t -> unit
+  val print : Format.formatter -> t -> unit
+end
+
+module type Set = sig
+  module T : Set.OrderedType
+  include Set.S
+    with type elt = T.t
+     and type t = Set.Make (T).t
+
+  val output : out_channel -> t -> unit
+  val print : Format.formatter -> t -> unit
+  val to_string : t -> string
+  val of_list : elt list -> t
+  val map : (elt -> elt) -> t -> t
+end
+
+module type Map = sig
+  module T : Map.OrderedType
+  include Map.S
+    with type key = T.t
+     and type 'a t = 'a Map.Make (T).t
+
+  val of_list : (key * 'a) list -> 'a t
+
+  val disjoint_union :
+    ?eq:('a -> 'a -> bool) -> ?print:(Format.formatter -> 'a -> unit) -> 'a t ->
+    'a t -> 'a t
+
+  val union_right : 'a t -> 'a t -> 'a t
+
+  val union_left : 'a t -> 'a t -> 'a t
+
+  val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
+  val rename : key t -> key -> key
+  val map_keys : (key -> key) -> 'a t -> 'a t
+  val keys : 'a t -> Set.Make(T).t
+  val data : 'a t -> 'a list
+  val of_set : (key -> 'a) -> Set.Make(T).t -> 'a t
+  val transpose_keys_and_data : key t -> key t
+  val transpose_keys_and_data_set : key t -> Set.Make(T).t t
+  val print :
+    (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
+end
+
+module type Tbl = sig
+  module T : sig
+    type t
+    include Map.OrderedType with type t := t
+    include Hashtbl.HashedType with type t := t
+  end
+  include Hashtbl.S
+    with type key = T.t
+     and type 'a t = 'a Hashtbl.Make (T).t
+
+  val to_list : 'a t -> (T.t * 'a) list
+  val of_list : (T.t * 'a) list -> 'a t
+
+  val to_map : 'a t -> 'a Map.Make(T).t
+  val of_map : 'a Map.Make(T).t -> 'a t
+  val memoize : 'a t -> (key -> 'a) -> key -> 'a
+  val map : 'a t -> ('a -> 'b) -> 'b t
+end
+
+module Pair (A : Thing) (B : Thing) : Thing with type t = A.t * B.t = struct
+  type t = A.t * B.t
+
+  let compare (a1, b1) (a2, b2) =
+    let c = A.compare a1 a2 in
+    if c <> 0 then c
+    else B.compare b1 b2
+
+  let output oc (a, b) = Printf.fprintf oc " (%a, %a)" A.output a B.output b
+  let hash (a, b) = Hashtbl.hash (A.hash a, B.hash b)
+  let equal (a1, b1) (a2, b2) = A.equal a1 a2 && B.equal b1 b2
+  let print ppf (a, b) = Format.fprintf ppf " (%a, @ %a)" A.print a B.print b
+end
+
+module Make_map (T : Thing) = struct
+  include Map.Make (T)
+
+  let of_list l =
+    List.fold_left (fun map (id, v) -> add id v map) empty l
+
+  let disjoint_union ?eq ?print m1 m2 =
+    union (fun id v1 v2 ->
+        let ok = match eq with
+          | None -> false
+          | Some eq -> eq v1 v2
+        in
+        if not ok then
+          let err =
+            match print with
+            | None ->
+              Format.asprintf "Map.disjoint_union %a" T.print id
+            | Some print ->
+              Format.asprintf "Map.disjoint_union %a => %a <> %a"
+                T.print id print v1 print v2
+          in
+          Misc.fatal_error err
+        else Some v1)
+      m1 m2
+
+  let union_right m1 m2 =
+    merge (fun _id x y -> match x, y with
+        | None, None -> None
+        | None, Some v
+        | Some v, None
+        | Some _, Some v -> Some v)
+      m1 m2
+
+  let union_left m1 m2 = union_right m2 m1
+
+  let union_merge f m1 m2 =
+    let aux _ m1 m2 =
+      match m1, m2 with
+      | None, m | m, None -> m
+      | Some m1, Some m2 -> Some (f m1 m2)
+    in
+    merge aux m1 m2
+
+  let rename m v =
+    try find v m
+    with Not_found -> v
+
+  let map_keys f m =
+    of_list (List.map (fun (k, v) -> f k, v) (bindings m))
+
+  let print f ppf s =
+    let elts ppf s = iter (fun id v ->
+        Format.fprintf ppf "@ (@[%a@ %a@])" T.print id f v) s in
+    Format.fprintf ppf "@[<1>{@[%a@ @]}@]" elts s
+
+  module T_set = Set.Make (T)
+
+  let keys map = fold (fun k _ set -> T_set.add k set) map T_set.empty
+
+  let data t = List.map snd (bindings t)
+
+  let of_set f set = T_set.fold (fun e map -> add e (f e) map) set empty
+
+  let transpose_keys_and_data map = fold (fun k v m -> add v k m) map empty
+  let transpose_keys_and_data_set map =
+    fold (fun k v m ->
+        let set =
+          match find v m with
+          | exception Not_found ->
+            T_set.singleton k
+          | set ->
+            T_set.add k set
+        in
+        add v set m)
+      map empty
+end
+
+module Make_set (T : Thing) = struct
+  include Set.Make (T)
+
+  let output oc s =
+    Printf.fprintf oc " ( ";
+    iter (fun v -> Printf.fprintf oc "%a " T.output v) s;
+    Printf.fprintf oc ")"
+
+  let print ppf s =
+    let elts ppf s = iter (fun e -> Format.fprintf ppf "@ %a" T.print e) s in
+    Format.fprintf ppf "@[<1>{@[%a@ @]}@]" elts s
+
+  let to_string s = Format.asprintf "%a" print s
+
+  let of_list l = match l with
+    | [] -> empty
+    | [t] -> singleton t
+    | t :: q -> List.fold_left (fun acc e -> add e acc) (singleton t) q
+
+  let map f s = of_list (List.map f (elements s))
+end
+
+module Make_tbl (T : Thing) = struct
+  include Hashtbl.Make (T)
+
+  module T_map = Make_map (T)
+
+  let to_list t =
+    fold (fun key datum elts -> (key, datum)::elts) t []
+
+  let of_list elts =
+    let t = create 42 in
+    List.iter (fun (key, datum) -> add t key datum) elts;
+    t
+
+  let to_map v = fold T_map.add v T_map.empty
+
+  let of_map m =
+    let t = create (T_map.cardinal m) in
+    T_map.iter (fun k v -> add t k v) m;
+    t
+
+  let memoize t f = fun key ->
+    try find t key with
+    | Not_found ->
+      let r = f key in
+      add t key r;
+      r
+
+  let map t f =
+    of_map (T_map.map f (to_map t))
+end
+
+module type S = sig
+  type t
+
+  module T : Thing with type t = t
+  include Thing with type t := T.t
+
+  module Set : Set with module T := T
+  module Map : Map with module T := T
+  module Tbl : Tbl with module T := T
+end
+
+module Make (T : Thing) = struct
+  module T = T
+  include T
+
+  module Set = Make_set (T)
+  module Map = Make_map (T)
+  module Tbl = Make_tbl (T)
+end
diff --git a/upstream/ocaml_412/utils/identifiable.mli b/upstream/ocaml_412/utils/identifiable.mli
new file mode 100644
index 0000000..0da5a66
--- /dev/null
+++ b/upstream/ocaml_412/utils/identifiable.mli
@@ -0,0 +1,113 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Uniform interface for common data structures over various things.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+module type Thing = sig
+  type t
+
+  include Hashtbl.HashedType with type t := t
+  include Map.OrderedType with type t := t
+
+  val output : out_channel -> t -> unit
+  val print : Format.formatter -> t -> unit
+end
+
+module Pair : functor (A : Thing) (B : Thing) -> Thing with type t = A.t * B.t
+
+module type Set = sig
+  module T : Set.OrderedType
+  include Set.S
+    with type elt = T.t
+     and type t = Set.Make (T).t
+
+  val output : out_channel -> t -> unit
+  val print : Format.formatter -> t -> unit
+  val to_string : t -> string
+  val of_list : elt list -> t
+  val map : (elt -> elt) -> t -> t
+end
+
+module type Map = sig
+  module T : Map.OrderedType
+  include Map.S
+    with type key = T.t
+     and type 'a t = 'a Map.Make (T).t
+
+  val of_list : (key * 'a) list -> 'a t
+
+  (** [disjoint_union m1 m2] contains all bindings from [m1] and
+      [m2]. If some binding is present in both and the associated
+      value is not equal, a Fatal_error is raised *)
+  val disjoint_union :
+    ?eq:('a -> 'a -> bool) -> ?print:(Format.formatter -> 'a -> unit) -> 'a t ->
+    'a t -> 'a t
+
+  (** [union_right m1 m2] contains all bindings from [m1] and [m2]. If
+      some binding is present in both, the one from [m2] is taken *)
+  val union_right : 'a t -> 'a t -> 'a t
+
+  (** [union_left m1 m2 = union_right m2 m1] *)
+  val union_left : 'a t -> 'a t -> 'a t
+
+  val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
+  val rename : key t -> key -> key
+  val map_keys : (key -> key) -> 'a t -> 'a t
+  val keys : 'a t -> Set.Make(T).t
+  val data : 'a t -> 'a list
+  val of_set : (key -> 'a) -> Set.Make(T).t -> 'a t
+  val transpose_keys_and_data : key t -> key t
+  val transpose_keys_and_data_set : key t -> Set.Make(T).t t
+  val print :
+    (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
+end
+
+module type Tbl = sig
+  module T : sig
+    type t
+    include Map.OrderedType with type t := t
+    include Hashtbl.HashedType with type t := t
+  end
+  include Hashtbl.S
+    with type key = T.t
+     and type 'a t = 'a Hashtbl.Make (T).t
+
+  val to_list : 'a t -> (T.t * 'a) list
+  val of_list : (T.t * 'a) list -> 'a t
+
+  val to_map : 'a t -> 'a Map.Make(T).t
+  val of_map : 'a Map.Make(T).t -> 'a t
+  val memoize : 'a t -> (key -> 'a) -> key -> 'a
+  val map : 'a t -> ('a -> 'b) -> 'b t
+end
+
+module type S = sig
+  type t
+
+  module T : Thing with type t = t
+  include Thing with type t := T.t
+
+  module Set : Set with module T := T
+  module Map : Map with module T := T
+  module Tbl : Tbl with module T := T
+end
+
+module Make (T : Thing) : S with type t := T.t
diff --git a/upstream/ocaml_412/utils/int_replace_polymorphic_compare.ml b/upstream/ocaml_412/utils/int_replace_polymorphic_compare.ml
new file mode 100644
index 0000000..7cd6bf1
--- /dev/null
+++ b/upstream/ocaml_412/utils/int_replace_polymorphic_compare.ml
@@ -0,0 +1,8 @@
+let ( = )   : int -> int -> bool = Stdlib.( = )
+let ( <> )  : int -> int -> bool = Stdlib.( <> )
+let ( < )   : int -> int -> bool = Stdlib.( < )
+let ( > )   : int -> int -> bool = Stdlib.( > )
+let ( <= )  : int -> int -> bool = Stdlib.( <= )
+let ( >= )  : int -> int -> bool = Stdlib.( >= )
+
+let compare : int -> int -> int  = Stdlib.compare
diff --git a/upstream/ocaml_412/utils/int_replace_polymorphic_compare.mli b/upstream/ocaml_412/utils/int_replace_polymorphic_compare.mli
new file mode 100644
index 0000000..689e741
--- /dev/null
+++ b/upstream/ocaml_412/utils/int_replace_polymorphic_compare.mli
@@ -0,0 +1,8 @@
+val ( = )   : int -> int -> bool
+val ( <> )  : int -> int -> bool
+val ( < )   : int -> int -> bool
+val ( > )   : int -> int -> bool
+val ( <= )  : int -> int -> bool
+val ( >= )  : int -> int -> bool
+
+val compare : int -> int -> int
diff --git a/upstream/ocaml_412/utils/load_path.ml b/upstream/ocaml_412/utils/load_path.ml
new file mode 100644
index 0000000..41eb22e
--- /dev/null
+++ b/upstream/ocaml_412/utils/load_path.ml
@@ -0,0 +1,122 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2018 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Local_store
+
+module SMap = Misc.Stdlib.String.Map
+
+(* Mapping from basenames to full filenames *)
+type registry = string SMap.t ref
+
+let files : registry = s_ref SMap.empty
+let files_uncap : registry = s_ref SMap.empty
+
+module Dir = struct
+  type t = {
+    path : string;
+    files : string list;
+  }
+
+  let path t = t.path
+  let files t = t.files
+
+  (* For backward compatibility reason, simulate the behavior of
+     [Misc.find_in_path]: silently ignore directories that don't exist
+     + treat [""] as the current directory. *)
+  let readdir_compat dir =
+    try
+      Sys.readdir (if dir = "" then Filename.current_dir_name else dir)
+    with Sys_error _ ->
+      [||]
+
+  let create path =
+    { path; files = Array.to_list (readdir_compat path) }
+end
+
+let dirs = s_ref []
+
+let reset () =
+  assert (not Config.merlin || Local_store.is_bound ());
+  files := SMap.empty;
+  files_uncap := SMap.empty;
+  dirs := []
+
+let get () = List.rev !dirs
+let get_paths () = List.rev_map Dir.path !dirs
+
+let add_to_maps fn basenames files files_uncap =
+  List.fold_left (fun (files, files_uncap) base ->
+      let fn = fn base in
+      SMap.add base fn files,
+      SMap.add (String.uncapitalize_ascii base) fn files_uncap
+    ) (files, files_uncap) basenames
+
+(* Optimized version of [add] below, for use in [init] and [remove_dir]: since
+   we are starting from an empty cache, we can avoid checking whether a unit
+   name already exists in the cache simply by adding entries in reverse
+   order. *)
+let add dir =
+  assert (not Config.merlin || Local_store.is_bound ());
+  let new_files, new_files_uncap =
+    add_to_maps (Filename.concat dir.Dir.path)
+      dir.Dir.files !files !files_uncap
+  in
+  files := new_files;
+  files_uncap := new_files_uncap
+
+let init l =
+  reset ();
+  dirs := List.rev_map Dir.create l;
+  List.iter add !dirs
+
+let remove_dir dir =
+  assert (not Config.merlin || Local_store.is_bound ());
+  let new_dirs = List.filter (fun d -> Dir.path d <> dir) !dirs in
+  if List.compare_lengths new_dirs !dirs <> 0 then begin
+    reset ();
+    List.iter add new_dirs;
+    dirs := new_dirs
+  end
+
+(* General purpose version of function to add a new entry to load path: We only
+   add a basename to the cache if it is not already present in the cache, in
+   order to enforce left-to-right precedence. *)
+let add dir =
+  assert (not Config.merlin || Local_store.is_bound ());
+  let new_files, new_files_uncap =
+    add_to_maps (Filename.concat dir.Dir.path) dir.Dir.files
+      SMap.empty SMap.empty
+  in
+  let first _ fn _ = Some fn in
+  files := SMap.union first !files new_files;
+  files_uncap := SMap.union first !files_uncap new_files_uncap;
+  dirs := dir :: !dirs
+
+let add_dir dir = add (Dir.create dir)
+
+let is_basename fn = Filename.basename fn = fn
+
+let find fn =
+  assert (not Config.merlin || Local_store.is_bound ());
+  if is_basename fn then
+    SMap.find fn !files
+  else
+    Misc.find_in_path (get_paths ()) fn
+
+let find_uncap fn =
+  assert (not Config.merlin || Local_store.is_bound ());
+  if is_basename fn then
+    SMap.find (String.uncapitalize_ascii fn) !files_uncap
+  else
+    Misc.find_in_path_uncap (get_paths ()) fn
diff --git a/upstream/ocaml_412/utils/load_path.mli b/upstream/ocaml_412/utils/load_path.mli
new file mode 100644
index 0000000..ea9fe3d
--- /dev/null
+++ b/upstream/ocaml_412/utils/load_path.mli
@@ -0,0 +1,66 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2018 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Management of include directories.
+
+    This module offers a high level interface to locating files in the
+    load path, which is constructed from [-I] command line flags and a few
+    other parameters.
+
+    It makes the assumption that the contents of include directories
+    doesn't change during the execution of the compiler.
+*)
+
+val add_dir : string -> unit
+(** Add a directory to the load path *)
+
+val remove_dir : string -> unit
+(** Remove a directory from the load path *)
+
+val reset : unit -> unit
+(** Remove all directories *)
+
+val init : string list -> unit
+(** [init l] is the same as [reset (); List.iter add_dir (List.rev l)] *)
+
+val get_paths : unit -> string list
+(** Return the list of directories passed to [add_dir] so far. *)
+
+val find : string -> string
+(** Locate a file in the load path. Raise [Not_found] if the file
+    cannot be found. This function is optimized for the case where the
+    filename is a basename, i.e. doesn't contain a directory
+    separator. *)
+
+val find_uncap : string -> string
+(** Same as [find], but search also for uncapitalized name, i.e.  if
+    name is Foo.ml, allow /path/Foo.ml and /path/foo.ml to match. *)
+
+module Dir : sig
+  type t
+  (** Represent one directory in the load path. *)
+
+  val create : string -> t
+
+  val path : t -> string
+
+  val files : t -> string list
+  (** All the files in that directory. This doesn't include files in
+      sub-directories of this directory. *)
+end
+
+val add : Dir.t -> unit
+
+val get : unit -> Dir.t list
+(** Same as [get_paths ()], except that it returns a [Dir.t list]. *)
diff --git a/upstream/ocaml_412/utils/local_store.ml b/upstream/ocaml_412/utils/local_store.ml
new file mode 100644
index 0000000..4babf61
--- /dev/null
+++ b/upstream/ocaml_412/utils/local_store.ml
@@ -0,0 +1,74 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                        Frederic Bour, Tarides                          *)
+(*                         Thomas Refis, Tarides                          *)
+(*                                                                        *)
+(*   Copyright 2020 Tarides                                               *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type ref_and_reset =
+  | Table : { ref: 'a ref; init: unit -> 'a } -> ref_and_reset
+  | Ref : { ref: 'a ref; mutable snapshot: 'a } -> ref_and_reset
+
+type bindings = {
+  mutable refs: ref_and_reset list;
+  mutable frozen : bool;
+  mutable is_bound: bool;
+}
+
+let global_bindings =
+  { refs = []; is_bound = false; frozen = false }
+
+let is_bound () = global_bindings.is_bound
+
+let reset () =
+  assert (is_bound ());
+  List.iter (function
+    | Table { ref; init } -> ref := init ()
+    | Ref { ref; snapshot } -> ref := snapshot
+  ) global_bindings.refs
+
+let s_table create size =
+  let init () = create size in
+  let ref = ref (init ()) in
+  assert (not global_bindings.frozen);
+  global_bindings.refs <- (Table { ref; init }) :: global_bindings.refs;
+  ref
+
+let s_ref k =
+  let ref = ref k in
+  assert (not global_bindings.frozen);
+  global_bindings.refs <-
+    (Ref { ref; snapshot = k }) :: global_bindings.refs;
+  ref
+
+type slot = Slot : { ref : 'a ref; mutable value : 'a } -> slot
+type store = slot list
+
+let fresh () =
+  let slots =
+    List.map (function
+      | Table { ref; init } -> Slot {ref; value = init ()}
+      | Ref r ->
+          if not global_bindings.frozen then r.snapshot <- !(r.ref);
+          Slot { ref = r.ref; value = r.snapshot }
+    ) global_bindings.refs
+  in
+  global_bindings.frozen <- true;
+  slots
+
+let with_store slots f =
+  assert (not global_bindings.is_bound);
+  global_bindings.is_bound <- true;
+  List.iter (fun (Slot {ref;value}) -> ref := value) slots;
+  Fun.protect f ~finally:(fun () ->
+    List.iter (fun (Slot s) -> s.value <- !(s.ref)) slots;
+    global_bindings.is_bound <- false;
+  )
diff --git a/upstream/ocaml_412/utils/local_store.mli b/upstream/ocaml_412/utils/local_store.mli
new file mode 100644
index 0000000..f39cd12
--- /dev/null
+++ b/upstream/ocaml_412/utils/local_store.mli
@@ -0,0 +1,66 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                        Frederic Bour, Tarides                          *)
+(*                         Thomas Refis, Tarides                          *)
+(*                                                                        *)
+(*   Copyright 2020 Tarides                                               *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** This module provides some facilities for creating references (and hash
+    tables) which can easily be snapshoted and restored to an arbitrary version.
+
+    It is used throughout the frontend (read: typechecker), to register all
+    (well, hopefully) the global state. Thus making it easy for tools like
+    Merlin to go back and forth typechecking different files. *)
+
+(** {1 Creators} *)
+
+val s_ref : 'a -> 'a ref
+(** Similar to {!ref}, except the allocated reference is registered into the
+    store. *)
+
+val s_table : ('a -> 'b) -> 'a -> 'b ref
+(** Used to register hash tables. Those also need to be placed into refs to be
+    easily swapped out, but one can't just "snapshot" the initial value to
+    create fresh instances, so instead an initializer is required.
+
+    Use it like this:
+    {[
+      let my_table = s_table Hashtbl.create 42
+    ]}
+*)
+
+(** {1 State management}
+
+    Note: all the following functions are currently unused inside the compiler
+    codebase. Merlin is their only user at the moment. *)
+
+type store
+
+val fresh : unit -> store
+(** Returns a fresh instance of the store.
+
+    The first time this function is called, it snapshots the value of all the
+    registered references, later calls to [fresh] will return instances
+    initialized to those values. *)
+
+val with_store : store -> (unit -> 'a) -> 'a
+(** [with_scope s f] resets all the registered references to the value they have
+    in [s] for the run of [f].
+    If [f] updates any of the registered refs, [s] is updated to remember those
+    changes. *)
+
+val reset : unit -> unit
+(** Resets all the references to the initial snapshot (i.e. to the same values
+    that new instances start with). *)
+
+val is_bound : unit -> bool
+(** Returns [true] when a scope is active (i.e. when called from the callback
+    passed to {!with_scope}), [false] otherwise. *)
diff --git a/upstream/ocaml_412/utils/misc.ml b/upstream/ocaml_412/utils/misc.ml
new file mode 100644
index 0000000..4097903
--- /dev/null
+++ b/upstream/ocaml_412/utils/misc.ml
@@ -0,0 +1,1187 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Errors *)
+
+exception Fatal_error
+
+let fatal_errorf fmt =
+  Format.kfprintf
+    (fun _ -> raise Fatal_error)
+    Format.err_formatter
+    ("@?>> Fatal error: " ^^ fmt ^^ "@.")
+
+let fatal_error msg = fatal_errorf "%s" msg
+
+(* Exceptions *)
+
+let try_finally ?(always=(fun () -> ())) ?(exceptionally=(fun () -> ())) work =
+  match work () with
+    | result ->
+      begin match always () with
+        | () -> result
+        | exception always_exn ->
+          let always_bt = Printexc.get_raw_backtrace () in
+          exceptionally ();
+          Printexc.raise_with_backtrace always_exn always_bt
+      end
+    | exception work_exn ->
+      let work_bt = Printexc.get_raw_backtrace () in
+      begin match always () with
+        | () ->
+          exceptionally ();
+          Printexc.raise_with_backtrace work_exn work_bt
+        | exception always_exn ->
+          let always_bt = Printexc.get_raw_backtrace () in
+          exceptionally ();
+          Printexc.raise_with_backtrace always_exn always_bt
+      end
+
+let reraise_preserving_backtrace e f =
+  let bt = Printexc.get_raw_backtrace () in
+  f ();
+  Printexc.raise_with_backtrace e bt
+
+type ref_and_value = R : 'a ref * 'a -> ref_and_value
+
+let protect_refs =
+  let set_refs l = List.iter (fun (R (r, v)) -> r := v) l in
+  fun refs f ->
+    let backup = List.map (fun (R (r, _)) -> R (r, !r)) refs in
+    set_refs refs;
+    Fun.protect ~finally:(fun () -> set_refs backup) f
+
+(* List functions *)
+
+let rec map_end f l1 l2 =
+  match l1 with
+    [] -> l2
+  | hd::tl -> f hd :: map_end f tl l2
+
+let rec map_left_right f = function
+    [] -> []
+  | hd::tl -> let res = f hd in res :: map_left_right f tl
+
+let rec for_all2 pred l1 l2 =
+  match (l1, l2) with
+    ([], []) -> true
+  | (hd1::tl1, hd2::tl2) -> pred hd1 hd2 && for_all2 pred tl1 tl2
+  | (_, _) -> false
+
+let rec replicate_list elem n =
+  if n <= 0 then [] else elem :: replicate_list elem (n-1)
+
+let rec list_remove x = function
+    [] -> []
+  | hd :: tl ->
+      if hd = x then tl else hd :: list_remove x tl
+
+let rec split_last = function
+    [] -> assert false
+  | [x] -> ([], x)
+  | hd :: tl ->
+      let (lst, last) = split_last tl in
+      (hd :: lst, last)
+
+module Stdlib = struct
+  module List = struct
+    type 'a t = 'a list
+
+    let rec compare cmp l1 l2 =
+      match l1, l2 with
+      | [], [] -> 0
+      | [], _::_ -> -1
+      | _::_, [] -> 1
+      | h1::t1, h2::t2 ->
+        let c = cmp h1 h2 in
+        if c <> 0 then c
+        else compare cmp t1 t2
+
+    let rec equal eq l1 l2 =
+      match l1, l2 with
+      | ([], []) -> true
+      | (hd1 :: tl1, hd2 :: tl2) -> eq hd1 hd2 && equal eq tl1 tl2
+      | (_, _) -> false
+
+    let map2_prefix f l1 l2 =
+      let rec aux acc l1 l2 =
+        match l1, l2 with
+        | [], _ -> (List.rev acc, l2)
+        | _ :: _, [] -> raise (Invalid_argument "map2_prefix")
+        | h1::t1, h2::t2 ->
+          let h = f h1 h2 in
+          aux (h :: acc) t1 t2
+      in
+      aux [] l1 l2
+
+    let some_if_all_elements_are_some l =
+      let rec aux acc l =
+        match l with
+        | [] -> Some (List.rev acc)
+        | None :: _ -> None
+        | Some h :: t -> aux (h :: acc) t
+      in
+      aux [] l
+
+    let split_at n l =
+      let rec aux n acc l =
+        if n = 0
+        then List.rev acc, l
+        else
+          match l with
+          | [] -> raise (Invalid_argument "split_at")
+          | t::q -> aux (n-1) (t::acc) q
+      in
+      aux n [] l
+
+    let rec is_prefix ~equal t ~of_ =
+      match t, of_ with
+      | [], [] -> true
+      | _::_, [] -> false
+      | [], _::_ -> true
+      | x1::t, x2::of_ -> equal x1 x2 && is_prefix ~equal t ~of_
+
+    type 'a longest_common_prefix_result = {
+      longest_common_prefix : 'a list;
+      first_without_longest_common_prefix : 'a list;
+      second_without_longest_common_prefix : 'a list;
+    }
+
+    let find_and_chop_longest_common_prefix ~equal ~first ~second =
+      let rec find_prefix ~longest_common_prefix_rev l1 l2 =
+        match l1, l2 with
+        | elt1 :: l1, elt2 :: l2 when equal elt1 elt2 ->
+          let longest_common_prefix_rev = elt1 :: longest_common_prefix_rev in
+          find_prefix ~longest_common_prefix_rev l1 l2
+        | l1, l2 ->
+          { longest_common_prefix = List.rev longest_common_prefix_rev;
+            first_without_longest_common_prefix = l1;
+            second_without_longest_common_prefix = l2;
+          }
+      in
+      find_prefix ~longest_common_prefix_rev:[] first second
+  end
+
+  module Option = struct
+    type 'a t = 'a option
+
+    let print print_contents ppf t =
+      match t with
+      | None -> Format.pp_print_string ppf "None"
+      | Some contents ->
+        Format.fprintf ppf "@[(Some@ %a)@]" print_contents contents
+  end
+
+  module Array = struct
+    let exists2 p a1 a2 =
+      let n = Array.length a1 in
+      if Array.length a2 <> n then invalid_arg "Misc.Stdlib.Array.exists2";
+      let rec loop i =
+        if i = n then false
+        else if p (Array.unsafe_get a1 i) (Array.unsafe_get a2 i) then true
+        else loop (succ i) in
+      loop 0
+
+    let for_alli p a =
+      let n = Array.length a in
+      let rec loop i =
+        if i = n then true
+        else if p i (Array.unsafe_get a i) then loop (succ i)
+        else false in
+      loop 0
+
+    let all_somes a =
+      try
+        Some (Array.map (function None -> raise_notrace Exit | Some x -> x) a)
+      with
+      | Exit -> None
+  end
+
+  module String = struct
+    include String
+    module Set = Set.Make(String)
+    module Map = Map.Make(String)
+    module Tbl = Hashtbl.Make(struct
+      include String
+      let hash = Hashtbl.hash
+    end)
+
+    let for_all f t =
+      let len = String.length t in
+      let rec loop i =
+        i = len || (f t.[i] && loop (i + 1))
+      in
+      loop 0
+
+    let print ppf t =
+      Format.pp_print_string ppf t
+  end
+
+  external compare : 'a -> 'a -> int = "%compare"
+end
+
+(* File functions *)
+
+let find_in_path path name =
+  if not (Filename.is_implicit name) then
+    if Sys.file_exists name then name else raise Not_found
+  else begin
+    let rec try_dir = function
+      [] -> raise Not_found
+    | dir::rem ->
+        let fullname = Filename.concat dir name in
+        if Sys.file_exists fullname then fullname else try_dir rem
+    in try_dir path
+  end
+
+let find_in_path_rel path name =
+  let rec simplify s =
+    let open Filename in
+    let base = basename s in
+    let dir = dirname s in
+    if dir = s then dir
+    else if base = current_dir_name then simplify dir
+    else concat (simplify dir) base
+  in
+  let rec try_dir = function
+    [] -> raise Not_found
+  | dir::rem ->
+      let fullname = simplify (Filename.concat dir name) in
+      if Sys.file_exists fullname then fullname else try_dir rem
+  in try_dir path
+
+let find_in_path_uncap path name =
+  let uname = String.uncapitalize_ascii name in
+  let rec try_dir = function
+    [] -> raise Not_found
+  | dir::rem ->
+      let fullname = Filename.concat dir name
+      and ufullname = Filename.concat dir uname in
+      if Sys.file_exists ufullname then ufullname
+      else if Sys.file_exists fullname then fullname
+      else try_dir rem
+  in try_dir path
+
+let remove_file filename =
+  try
+    if Sys.file_exists filename
+    then Sys.remove filename
+  with Sys_error _msg ->
+    ()
+
+(* Expand a -I option: if it starts with +, make it relative to the standard
+   library directory *)
+
+let expand_directory alt s =
+  if String.length s > 0 && s.[0] = '+'
+  then Filename.concat alt
+                       (String.sub s 1 (String.length s - 1))
+  else s
+
+let path_separator =
+  match Sys.os_type with
+  | "Win32" -> ';'
+  | _ -> ':'
+
+let split_path_contents ?(sep = path_separator) = function
+  | "" -> []
+  | s -> String.split_on_char sep s
+
+(* Hashtable functions *)
+
+let create_hashtable size init =
+  let tbl = Hashtbl.create size in
+  List.iter (fun (key, data) -> Hashtbl.add tbl key data) init;
+  tbl
+
+(* File copy *)
+
+let copy_file ic oc =
+  let buff = Bytes.create 0x1000 in
+  let rec copy () =
+    let n = input ic buff 0 0x1000 in
+    if n = 0 then () else (output oc buff 0 n; copy())
+  in copy()
+
+let copy_file_chunk ic oc len =
+  let buff = Bytes.create 0x1000 in
+  let rec copy n =
+    if n <= 0 then () else begin
+      let r = input ic buff 0 (min n 0x1000) in
+      if r = 0 then raise End_of_file else (output oc buff 0 r; copy(n-r))
+    end
+  in copy len
+
+let string_of_file ic =
+  let b = Buffer.create 0x10000 in
+  let buff = Bytes.create 0x1000 in
+  let rec copy () =
+    let n = input ic buff 0 0x1000 in
+    if n = 0 then Buffer.contents b else
+      (Buffer.add_subbytes b buff 0 n; copy())
+  in copy()
+
+let output_to_file_via_temporary ?(mode = [Open_text]) filename fn =
+  let (temp_filename, oc) =
+    Filename.open_temp_file
+       ~mode ~perms:0o666 ~temp_dir:(Filename.dirname filename)
+       (Filename.basename filename) ".tmp" in
+    (* The 0o666 permissions will be modified by the umask.  It's just
+       like what [open_out] and [open_out_bin] do.
+       With temp_dir = dirname filename, we ensure that the returned
+       temp file is in the same directory as filename itself, making
+       it safe to rename temp_filename to filename later.
+       With prefix = basename filename, we are almost certain that
+       the first generated name will be unique.  A fixed prefix
+       would work too but might generate more collisions if many
+       files are being produced simultaneously in the same directory. *)
+  match fn temp_filename oc with
+  | res ->
+      close_out oc;
+      begin try
+        Sys.rename temp_filename filename; res
+      with exn ->
+        remove_file temp_filename; raise exn
+      end
+  | exception exn ->
+      close_out oc; remove_file temp_filename; raise exn
+
+let protect_writing_to_file ~filename ~f =
+  let outchan = open_out_bin filename in
+  try_finally ~always:(fun () -> close_out outchan)
+    ~exceptionally:(fun () -> remove_file filename)
+    (fun () -> f outchan)
+
+(* Integer operations *)
+
+let rec log2 n =
+  if n <= 1 then 0 else 1 + log2(n asr 1)
+
+let align n a =
+  if n >= 0 then (n + a - 1) land (-a) else n land (-a)
+
+let no_overflow_add a b = (a lxor b) lor (a lxor (lnot (a+b))) < 0
+
+let no_overflow_sub a b = (a lxor (lnot b)) lor (b lxor (a-b)) < 0
+
+(* Taken from Hacker's Delight, chapter "Overflow Detection" *)
+let no_overflow_mul a b =
+  not ((a = min_int && b < 0) || (b <> 0 && (a * b) / b <> a))
+
+let no_overflow_lsl a k =
+  0 <= k && k < Sys.word_size - 1 && min_int asr k <= a && a <= max_int asr k
+
+module Int_literal_converter = struct
+  (* To convert integer literals, allowing max_int + 1 (PR#4210) *)
+  let cvt_int_aux str neg of_string =
+    if String.length str = 0 || str.[0]= '-'
+    then of_string str
+    else neg (of_string ("-" ^ str))
+  let int s = cvt_int_aux s (~-) int_of_string
+  let int32 s = cvt_int_aux s Int32.neg Int32.of_string
+  let int64 s = cvt_int_aux s Int64.neg Int64.of_string
+  let nativeint s = cvt_int_aux s Nativeint.neg Nativeint.of_string
+end
+
+(* String operations *)
+
+let chop_extensions file =
+  let dirname = Filename.dirname file and basename = Filename.basename file in
+  try
+    let pos = String.index basename '.' in
+    let basename = String.sub basename 0 pos in
+    if Filename.is_implicit file && dirname = Filename.current_dir_name then
+      basename
+    else
+      Filename.concat dirname basename
+  with Not_found -> file
+
+let search_substring pat str start =
+  let rec search i j =
+    if j >= String.length pat then i
+    else if i + j >= String.length str then raise Not_found
+    else if str.[i + j] = pat.[j] then search i (j+1)
+    else search (i+1) 0
+  in search start 0
+
+let replace_substring ~before ~after str =
+  let rec search acc curr =
+    match search_substring before str curr with
+      | next ->
+         let prefix = String.sub str curr (next - curr) in
+         search (prefix :: acc) (next + String.length before)
+      | exception Not_found ->
+        let suffix = String.sub str curr (String.length str - curr) in
+        List.rev (suffix :: acc)
+  in String.concat after (search [] 0)
+
+let rev_split_words s =
+  let rec split1 res i =
+    if i >= String.length s then res else begin
+      match s.[i] with
+        ' ' | '\t' | '\r' | '\n' -> split1 res (i+1)
+      | _ -> split2 res i (i+1)
+    end
+  and split2 res i j =
+    if j >= String.length s then String.sub s i (j-i) :: res else begin
+      match s.[j] with
+        ' ' | '\t' | '\r' | '\n' -> split1 (String.sub s i (j-i) :: res) (j+1)
+      | _ -> split2 res i (j+1)
+    end
+  in split1 [] 0
+
+let get_ref r =
+  let v = !r in
+  r := []; v
+
+let set_or_ignore f opt x =
+  match f x with
+  | None -> ()
+  | Some y -> opt := Some y
+
+let fst3 (x, _, _) = x
+let snd3 (_,x,_) = x
+let thd3 (_,_,x) = x
+
+let fst4 (x, _, _, _) = x
+let snd4 (_,x,_, _) = x
+let thd4 (_,_,x,_) = x
+let for4 (_,_,_,x) = x
+
+
+module LongString = struct
+  type t = bytes array
+
+  let create str_size =
+    let tbl_size = str_size / Sys.max_string_length + 1 in
+    let tbl = Array.make tbl_size Bytes.empty in
+    for i = 0 to tbl_size - 2 do
+      tbl.(i) <- Bytes.create Sys.max_string_length;
+    done;
+    tbl.(tbl_size - 1) <- Bytes.create (str_size mod Sys.max_string_length);
+    tbl
+
+  let length tbl =
+    let tbl_size = Array.length tbl in
+    Sys.max_string_length * (tbl_size - 1) + Bytes.length tbl.(tbl_size - 1)
+
+  let get tbl ind =
+    Bytes.get tbl.(ind / Sys.max_string_length) (ind mod Sys.max_string_length)
+
+  let set tbl ind c =
+    Bytes.set tbl.(ind / Sys.max_string_length) (ind mod Sys.max_string_length)
+              c
+
+  let blit src srcoff dst dstoff len =
+    for i = 0 to len - 1 do
+      set dst (dstoff + i) (get src (srcoff + i))
+    done
+
+  let blit_string src srcoff dst dstoff len =
+    for i = 0 to len - 1 do
+      set dst (dstoff + i) (String.get src (srcoff + i))
+    done
+
+  let output oc tbl pos len =
+    for i = pos to pos + len - 1 do
+      output_char oc (get tbl i)
+    done
+
+  let input_bytes_into tbl ic len =
+    let count = ref len in
+    Array.iter (fun str ->
+      let chunk = min !count (Bytes.length str) in
+      really_input ic str 0 chunk;
+      count := !count - chunk) tbl
+
+  let input_bytes ic len =
+    let tbl = create len in
+    input_bytes_into tbl ic len;
+    tbl
+end
+
+
+let edit_distance a b cutoff =
+  let la, lb = String.length a, String.length b in
+  let cutoff =
+    (* using max_int for cutoff would cause overflows in (i + cutoff + 1);
+       we bring it back to the (max la lb) worstcase *)
+    min (max la lb) cutoff in
+  if abs (la - lb) > cutoff then None
+  else begin
+    (* initialize with 'cutoff + 1' so that not-yet-written-to cases have
+       the worst possible cost; this is useful when computing the cost of
+       a case just at the boundary of the cutoff diagonal. *)
+    let m = Array.make_matrix (la + 1) (lb + 1) (cutoff + 1) in
+    m.(0).(0) <- 0;
+    for i = 1 to la do
+      m.(i).(0) <- i;
+    done;
+    for j = 1 to lb do
+      m.(0).(j) <- j;
+    done;
+    for i = 1 to la do
+      for j = max 1 (i - cutoff - 1) to min lb (i + cutoff + 1) do
+        let cost = if a.[i-1] = b.[j-1] then 0 else 1 in
+        let best =
+          (* insert, delete or substitute *)
+          min (1 + min m.(i-1).(j) m.(i).(j-1)) (m.(i-1).(j-1) + cost)
+        in
+        let best =
+          (* swap two adjacent letters; we use "cost" again in case of
+             a swap between two identical letters; this is slightly
+             redundant as this is a double-substitution case, but it
+             was done this way in most online implementations and
+             imitation has its virtues *)
+          if not (i > 1 && j > 1 && a.[i-1] = b.[j-2] && a.[i-2] = b.[j-1])
+          then best
+          else min best (m.(i-2).(j-2) + cost)
+        in
+        m.(i).(j) <- best
+      done;
+    done;
+    let result = m.(la).(lb) in
+    if result > cutoff
+    then None
+    else Some result
+  end
+
+let spellcheck env name =
+  let cutoff =
+    match String.length name with
+      | 1 | 2 -> 0
+      | 3 | 4 -> 1
+      | 5 | 6 -> 2
+      | _ -> 3
+  in
+  let compare target acc head =
+    match edit_distance target head cutoff with
+      | None -> acc
+      | Some dist ->
+         let (best_choice, best_dist) = acc in
+         if dist < best_dist then ([head], dist)
+         else if dist = best_dist then (head :: best_choice, dist)
+         else acc
+  in
+  let env = List.sort_uniq (fun s1 s2 -> String.compare s2 s1) env in
+  fst (List.fold_left (compare name) ([], max_int) env)
+
+let did_you_mean ppf get_choices =
+  (* flush now to get the error report early, in the (unheard of) case
+     where the search in the get_choices function would take a bit of
+     time; in the worst case, the user has seen the error, she can
+     interrupt the process before the spell-checking terminates. *)
+  Format.fprintf ppf "@?";
+  match get_choices () with
+  | [] -> ()
+  | choices ->
+     let rest, last = split_last choices in
+     Format.fprintf ppf "@\nHint: Did you mean %s%s%s?@?"
+       (String.concat ", " rest)
+       (if rest = [] then "" else " or ")
+       last
+
+let cut_at s c =
+  let pos = String.index s c in
+  String.sub s 0 pos, String.sub s (pos+1) (String.length s - pos - 1)
+
+(* Color handling *)
+module Color = struct
+  (* use ANSI color codes, see https://en.wikipedia.org/wiki/ANSI_escape_code *)
+  type color =
+    | Black
+    | Red
+    | Green
+    | Yellow
+    | Blue
+    | Magenta
+    | Cyan
+    | White
+  ;;
+
+  type style =
+    | FG of color (* foreground *)
+    | BG of color (* background *)
+    | Bold
+    | Reset
+
+  let ansi_of_color = function
+    | Black -> "0"
+    | Red -> "1"
+    | Green -> "2"
+    | Yellow -> "3"
+    | Blue -> "4"
+    | Magenta -> "5"
+    | Cyan -> "6"
+    | White -> "7"
+
+  let code_of_style = function
+    | FG c -> "3" ^ ansi_of_color c
+    | BG c -> "4" ^ ansi_of_color c
+    | Bold -> "1"
+    | Reset -> "0"
+
+  let ansi_of_style_l l =
+    let s = match l with
+      | [] -> code_of_style Reset
+      | [s] -> code_of_style s
+      | _ -> String.concat ";" (List.map code_of_style l)
+    in
+    "\x1b[" ^ s ^ "m"
+
+  type styles = {
+    error: style list;
+    warning: style list;
+    loc: style list;
+  }
+
+  let default_styles = {
+    warning = [Bold; FG Magenta];
+    error = [Bold; FG Red];
+    loc = [Bold];
+  }
+
+  let cur_styles = ref default_styles
+  let get_styles () = !cur_styles
+  let set_styles s = cur_styles := s
+
+  (* map a tag to a style, if the tag is known.
+     @raise Not_found otherwise *)
+  let style_of_tag s = match s with
+    | Format.String_tag "error" -> (!cur_styles).error
+    | Format.String_tag "warning" -> (!cur_styles).warning
+    | Format.String_tag "loc" -> (!cur_styles).loc
+    | _ -> raise Not_found
+
+  let color_enabled = ref true
+
+  (* either prints the tag of [s] or delegates to [or_else] *)
+  let mark_open_tag ~or_else s =
+    try
+      let style = style_of_tag s in
+      if !color_enabled then ansi_of_style_l style else ""
+    with Not_found -> or_else s
+
+  let mark_close_tag ~or_else s =
+    try
+      let _ = style_of_tag s in
+      if !color_enabled then ansi_of_style_l [Reset] else ""
+    with Not_found -> or_else s
+
+  (* add color handling to formatter [ppf] *)
+  let set_color_tag_handling ppf =
+    let open Format in
+    let functions = pp_get_formatter_stag_functions ppf () in
+    let functions' = {functions with
+      mark_open_stag=(mark_open_tag ~or_else:functions.mark_open_stag);
+      mark_close_stag=(mark_close_tag ~or_else:functions.mark_close_stag);
+    } in
+    pp_set_mark_tags ppf true; (* enable tags *)
+    pp_set_formatter_stag_functions ppf functions';
+    ()
+
+  external isatty : out_channel -> bool = "caml_sys_isatty"
+
+  (* reasonable heuristic on whether colors should be enabled *)
+  let should_enable_color () =
+    let term = try Sys.getenv "TERM" with Not_found -> "" in
+    term <> "dumb"
+    && term <> ""
+    && isatty stderr
+
+  type setting = Auto | Always | Never
+
+  let default_setting = Auto
+
+  let setup =
+    let first = ref true in (* initialize only once *)
+    let formatter_l =
+      [Format.std_formatter; Format.err_formatter; Format.str_formatter]
+    in
+    let enable_color = function
+      | Auto -> should_enable_color ()
+      | Always -> true
+      | Never -> false
+    in
+    fun o ->
+      if !first then (
+        first := false;
+        Format.set_mark_tags true;
+        List.iter set_color_tag_handling formatter_l;
+        color_enabled := (match o with
+          | Some s -> enable_color s
+          | None -> enable_color default_setting)
+      );
+      ()
+end
+
+module Error_style = struct
+  type setting =
+    | Contextual
+    | Short
+
+  let default_setting = Contextual
+end
+
+let normalise_eol s =
+  let b = Buffer.create 80 in
+    for i = 0 to String.length s - 1 do
+      if s.[i] <> '\r' then Buffer.add_char b s.[i]
+    done;
+    Buffer.contents b
+
+let delete_eol_spaces src =
+  let len_src = String.length src in
+  let dst = Bytes.create len_src in
+  let rec loop i_src i_dst =
+    if i_src = len_src then
+      i_dst
+    else
+      match src.[i_src] with
+      | ' ' | '\t' ->
+        loop_spaces 1 (i_src + 1) i_dst
+      | c ->
+        Bytes.set dst i_dst c;
+        loop (i_src + 1) (i_dst + 1)
+  and loop_spaces spaces i_src i_dst =
+    if i_src = len_src then
+      i_dst
+    else
+      match src.[i_src] with
+      | ' ' | '\t' ->
+        loop_spaces (spaces + 1) (i_src + 1) i_dst
+      | '\n' ->
+        Bytes.set dst i_dst '\n';
+        loop (i_src + 1) (i_dst + 1)
+      | _ ->
+        for n = 0 to spaces do
+          Bytes.set dst (i_dst + n) src.[i_src - spaces + n]
+        done;
+        loop (i_src + 1) (i_dst + spaces + 1)
+  in
+  let stop = loop 0 0 in
+  Bytes.sub_string dst 0 stop
+
+let pp_two_columns ?(sep = "|") ?max_lines ppf (lines: (string * string) list) =
+  let left_column_size =
+    List.fold_left (fun acc (s, _) -> max acc (String.length s)) 0 lines in
+  let lines_nb = List.length lines in
+  let ellipsed_first, ellipsed_last =
+    match max_lines with
+    | Some max_lines when lines_nb > max_lines ->
+        let printed_lines = max_lines - 1 in (* the ellipsis uses one line *)
+        let lines_before = printed_lines / 2 + printed_lines mod 2 in
+        let lines_after = printed_lines / 2 in
+        (lines_before, lines_nb - lines_after - 1)
+    | _ -> (-1, -1)
+  in
+  Format.fprintf ppf "@[<v>";
+  List.iteri (fun k (line_l, line_r) ->
+    if k = ellipsed_first then Format.fprintf ppf "...@,";
+    if ellipsed_first <= k && k <= ellipsed_last then ()
+    else Format.fprintf ppf "%*s %s %s@," left_column_size line_l sep line_r
+  ) lines;
+  Format.fprintf ppf "@]"
+
+(* showing configuration and configuration variables *)
+let show_config_and_exit () =
+  Config.print_config stdout;
+  exit 0
+
+let show_config_variable_and_exit x =
+  match Config.config_var x with
+  | Some v ->
+      (* we intentionally don't print a newline to avoid Windows \r
+         issues: bash only strips the trailing \n when using a command
+         substitution $(ocamlc -config-var foo), so a trailing \r would
+         remain if printing a newline under Windows and scripts would
+         have to use $(ocamlc -config-var foo | tr -d '\r')
+         for portability. Ugh. *)
+      print_string v;
+      exit 0
+  | None ->
+      exit 2
+
+let get_build_path_prefix_map =
+  let init = ref false in
+  let map_cache = ref None in
+  fun () ->
+    if not !init then begin
+      init := true;
+      match Sys.getenv "BUILD_PATH_PREFIX_MAP" with
+      | exception Not_found -> ()
+      | encoded_map ->
+        match Build_path_prefix_map.decode_map encoded_map with
+          | Error err ->
+              fatal_errorf
+                "Invalid value for the environment variable \
+                 BUILD_PATH_PREFIX_MAP: %s" err
+          | Ok map -> map_cache := Some map
+    end;
+    !map_cache
+
+let debug_prefix_map_flags () =
+  if not Config.as_has_debug_prefix_map then
+    []
+  else begin
+    match get_build_path_prefix_map () with
+    | None -> []
+    | Some map ->
+      List.fold_right
+        (fun map_elem acc ->
+           match map_elem with
+           | None -> acc
+           | Some { Build_path_prefix_map.target; source; } ->
+             (Printf.sprintf "--debug-prefix-map %s=%s"
+                (Filename.quote source)
+                (Filename.quote target)) :: acc)
+        map
+        []
+  end
+
+let print_if ppf flag printer arg =
+  if !flag then Format.fprintf ppf "%a@." printer arg;
+  arg
+
+
+type filepath = string
+type modname = string
+type crcs = (modname * Digest.t option) list
+
+type alerts = string Stdlib.String.Map.t
+
+
+module EnvLazy = struct
+  type ('a,'b) t = ('a,'b) eval ref
+
+  and ('a,'b) eval =
+    | Done of 'b
+    | Raise of exn
+    | Thunk of 'a
+
+  type undo =
+    | Nil
+    | Cons : ('a, 'b) t * 'a * undo -> undo
+
+  type log = undo ref
+
+  let force f x =
+    match !x with
+    | Done x -> x
+    | Raise e -> raise e
+    | Thunk e ->
+        match f e with
+        | y ->
+          x := Done y;
+          y
+        | exception e ->
+          x := Raise e;
+          raise e
+
+  let get_arg x =
+    match !x with Thunk a -> Some a | _ -> None
+
+  let create x =
+    ref (Thunk x)
+
+  let create_forced y =
+    ref (Done y)
+
+  let create_failed e =
+    ref (Raise e)
+
+  let log () =
+    ref Nil
+
+  let force_logged log f x =
+    match !x with
+    | Done x -> x
+    | Raise e -> raise e
+    | Thunk e ->
+      match f e with
+      | (Error _ as err : _ result) ->
+          x := Done err;
+          log := Cons(x, e, !log);
+          err
+      | Ok _ as res ->
+          x := Done res;
+          res
+      | exception e ->
+          x := Raise e;
+          raise e
+
+  let backtrack log =
+    let rec loop = function
+      | Nil -> ()
+      | Cons(x, e, rest) ->
+          x := Thunk e;
+          loop rest
+    in
+    loop !log
+
+end
+
+
+module Magic_number = struct
+  type native_obj_config = {
+    flambda : bool;
+  }
+  let native_obj_config = {
+    flambda = Config.flambda;
+  }
+
+  type version = int
+
+  type kind =
+    | Exec
+    | Cmi | Cmo | Cma
+    | Cmx of native_obj_config | Cmxa of native_obj_config
+    | Cmxs
+    | Cmt
+    | Ast_impl | Ast_intf
+
+  (* please keep up-to-date, this is used for sanity checking *)
+  let all_native_obj_configs = [
+      {flambda = true};
+      {flambda = false};
+    ]
+  let all_kinds = [
+    Exec;
+    Cmi; Cmo; Cma;
+  ]
+  @ List.map (fun conf -> Cmx conf) all_native_obj_configs
+  @ List.map (fun conf -> Cmxa conf) all_native_obj_configs
+  @ [
+    Cmt;
+    Ast_impl; Ast_intf;
+  ]
+
+  type raw = string
+  type info = {
+    kind: kind;
+    version: version;
+  }
+
+  type raw_kind = string
+
+  let parse_kind : raw_kind -> kind option = function
+    | "Caml1999X" -> Some Exec
+    | "Caml1999I" -> Some Cmi
+    | "Caml1999O" -> Some Cmo
+    | "Caml1999A" -> Some Cma
+    | "Caml1999y" -> Some (Cmx {flambda = true})
+    | "Caml1999Y" -> Some (Cmx {flambda = false})
+    | "Caml1999z" -> Some (Cmxa {flambda = true})
+    | "Caml1999Z" -> Some (Cmxa {flambda = false})
+
+    (* Caml2007D and Caml2012T were used instead of the common Caml1999 prefix
+       between the introduction of those magic numbers and October 2017
+       (8ba70ff194b66c0a50ffb97d41fe9c4bdf9362d6).
+
+       We accept them here, but will always produce/show kind prefixes
+       that follow the current convention, Caml1999{D,T}. *)
+    | "Caml2007D" | "Caml1999D" -> Some Cmxs
+    | "Caml2012T" | "Caml1999T" -> Some Cmt
+
+    | "Caml1999M" -> Some Ast_impl
+    | "Caml1999N" -> Some Ast_intf
+    | _ -> None
+
+  (* note: over time the magic kind number has changed for certain kinds;
+     this function returns them as they are produced by the current compiler,
+     but [parse_kind] accepts older formats as well. *)
+  let raw_kind : kind -> raw = function
+    | Exec -> "Caml1999X"
+    | Cmi -> "Caml1999I"
+    | Cmo -> "Caml1999O"
+    | Cma -> "Caml1999A"
+    | Cmx config ->
+       if config.flambda
+       then "Caml1999y"
+       else "Caml1999Y"
+    | Cmxa config ->
+       if config.flambda
+       then "Caml1999z"
+       else "Caml1999Z"
+    | Cmxs -> "Caml1999D"
+    | Cmt -> "Caml1999T"
+    | Ast_impl -> "Caml1999M"
+    | Ast_intf -> "Caml1999N"
+
+  let string_of_kind : kind -> string = function
+    | Exec -> "exec"
+    | Cmi -> "cmi"
+    | Cmo -> "cmo"
+    | Cma -> "cma"
+    | Cmx _ -> "cmx"
+    | Cmxa _ -> "cmxa"
+    | Cmxs -> "cmxs"
+    | Cmt -> "cmt"
+    | Ast_impl -> "ast_impl"
+    | Ast_intf -> "ast_intf"
+
+  let human_description_of_native_obj_config : native_obj_config -> string =
+    fun[@warning "+9"] {flambda} ->
+      if flambda then "flambda" else "non flambda"
+
+  let human_name_of_kind : kind -> string = function
+    | Exec -> "executable"
+    | Cmi -> "compiled interface file"
+    | Cmo -> "bytecode object file"
+    | Cma -> "bytecode library"
+    | Cmx config ->
+       Printf.sprintf "native compilation unit description (%s)"
+         (human_description_of_native_obj_config config)
+    | Cmxa config ->
+       Printf.sprintf "static native library (%s)"
+         (human_description_of_native_obj_config config)
+    | Cmxs -> "dynamic native library"
+    | Cmt -> "compiled typedtree file"
+    | Ast_impl -> "serialized implementation AST"
+    | Ast_intf -> "serialized interface AST"
+
+  let kind_length = 9
+  let version_length = 3
+  let magic_length =
+    kind_length + version_length
+
+  type parse_error =
+    | Truncated of string
+    | Not_a_magic_number of string
+
+  let explain_parse_error kind_opt error =
+       Printf.sprintf
+         "We expected a valid %s, but the file %s."
+         (Option.fold ~none:"object file" ~some:human_name_of_kind kind_opt)
+         (match error with
+            | Truncated "" -> "is empty"
+            | Truncated _ -> "is truncated"
+            | Not_a_magic_number _ -> "has a different format")
+
+  let parse s : (info, parse_error) result =
+    if String.length s = magic_length then begin
+      let raw_kind = String.sub s 0 kind_length in
+      let raw_version = String.sub s kind_length version_length in
+      match parse_kind raw_kind with
+      | None -> Error (Not_a_magic_number s)
+      | Some kind ->
+          begin match int_of_string raw_version with
+          | exception _ -> Error (Truncated s)
+          | version -> Ok { kind; version }
+          end
+    end
+    else begin
+      (* a header is "truncated" if it starts like a valid magic number,
+         that is if its longest segment of length at most [kind_length]
+         is a prefix of [raw_kind kind] for some kind [kind] *)
+      let sub_length = min kind_length (String.length s) in
+      let starts_as kind =
+        String.sub s 0 sub_length = String.sub (raw_kind kind) 0 sub_length
+      in
+      if List.exists starts_as all_kinds then Error (Truncated s)
+      else Error (Not_a_magic_number s)
+    end
+
+  let read_info ic =
+    let header = Buffer.create magic_length in
+    begin
+      try Buffer.add_channel header ic magic_length
+      with End_of_file -> ()
+    end;
+    parse (Buffer.contents header)
+
+  let raw { kind; version; } =
+    Printf.sprintf "%s%03d" (raw_kind kind) version
+
+  let current_raw kind =
+    let open Config in
+    match[@warning "+9"] kind with
+      | Exec -> exec_magic_number
+      | Cmi -> cmi_magic_number
+      | Cmo -> cmo_magic_number
+      | Cma -> cma_magic_number
+      | Cmx config ->
+         (* the 'if' guarantees that in the common case
+            we return the "trusted" value from Config. *)
+         let reference = cmx_magic_number in
+         if config = native_obj_config then reference
+         else
+           (* otherwise we stitch together the magic number
+              for a different configuration by concatenating
+              the right magic kind at this configuration
+              and the rest of the current raw number for our configuration. *)
+           let raw_kind = raw_kind kind in
+           let len = String.length raw_kind in
+           raw_kind ^ String.sub reference len (String.length reference - len)
+      | Cmxa config ->
+         let reference = cmxa_magic_number in
+         if config = native_obj_config then reference
+         else
+           let raw_kind = raw_kind kind in
+           let len = String.length raw_kind in
+           raw_kind ^ String.sub reference len (String.length reference - len)
+      | Cmxs -> cmxs_magic_number
+      | Cmt -> cmt_magic_number
+      | Ast_intf -> ast_intf_magic_number
+      | Ast_impl -> ast_impl_magic_number
+
+  (* it would seem more direct to define current_version with the
+     correct numbers and current_raw on top of it, but for now we
+     consider the Config.foo values to be ground truth, and don't want
+     to trust the present module instead. *)
+  let current_version kind =
+    let raw = current_raw kind in
+    try int_of_string (String.sub raw kind_length version_length)
+    with _ -> assert false
+
+  type 'a unexpected = { expected : 'a; actual : 'a }
+  type unexpected_error =
+    | Kind of kind unexpected
+    | Version of kind * version unexpected
+
+  let explain_unexpected_error = function
+    | Kind { actual; expected } ->
+        Printf.sprintf "We expected a %s (%s) but got a %s (%s) instead."
+          (human_name_of_kind expected) (string_of_kind expected)
+          (human_name_of_kind actual) (string_of_kind actual)
+    | Version (kind, { actual; expected }) ->
+        Printf.sprintf "This seems to be a %s (%s) for %s version of OCaml."
+          (human_name_of_kind kind) (string_of_kind kind)
+          (if actual < expected then "an older" else "a newer")
+
+  let check_current expected_kind { kind; version } : _ result =
+    if kind <> expected_kind then begin
+      let actual, expected = kind, expected_kind in
+      Error (Kind { actual; expected })
+    end else begin
+      let actual, expected = version, current_version kind in
+      if actual <> expected
+      then Error (Version (kind, { actual; expected }))
+      else Ok ()
+    end
+
+  type error =
+    | Parse_error of parse_error
+    | Unexpected_error of unexpected_error
+
+  let read_current_info ~expected_kind ic =
+    match read_info ic with
+      | Error err -> Error (Parse_error err)
+      | Ok info ->
+         let kind = Option.value ~default:info.kind expected_kind in
+         match check_current kind info with
+           | Error err -> Error (Unexpected_error err)
+           | Ok () -> Ok info
+end
diff --git a/upstream/ocaml_412/utils/misc.mli b/upstream/ocaml_412/utils/misc.mli
new file mode 100644
index 0000000..a2fdb57
--- /dev/null
+++ b/upstream/ocaml_412/utils/misc.mli
@@ -0,0 +1,688 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Miscellaneous useful types and functions
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+val fatal_error: string -> 'a
+val fatal_errorf: ('a, Format.formatter, unit, 'b) format4 -> 'a
+exception Fatal_error
+
+val try_finally :
+  ?always:(unit -> unit) ->
+  ?exceptionally:(unit -> unit) ->
+  (unit -> 'a) -> 'a
+(** [try_finally work ~always ~exceptionally] is designed to run code
+    in [work] that may fail with an exception, and has two kind of
+    cleanup routines: [always], that must be run after any execution
+    of the function (typically, freeing system resources), and
+    [exceptionally], that should be run only if [work] or [always]
+    failed with an exception (typically, undoing user-visible state
+    changes that would only make sense if the function completes
+    correctly). For example:
+
+    {[
+      let objfile = outputprefix ^ ".cmo" in
+      let oc = open_out_bin objfile in
+      Misc.try_finally
+        (fun () ->
+           bytecode
+           ++ Timings.(accumulate_time (Generate sourcefile))
+               (Emitcode.to_file oc modulename objfile);
+           Warnings.check_fatal ())
+        ~always:(fun () -> close_out oc)
+        ~exceptionally:(fun _exn -> remove_file objfile);
+    ]}
+
+    If [exceptionally] fail with an exception, it is propagated as
+    usual.
+
+    If [always] or [exceptionally] use exceptions internally for
+    control-flow but do not raise, then [try_finally] is careful to
+    preserve any exception backtrace coming from [work] or [always]
+    for easier debugging.
+*)
+
+val reraise_preserving_backtrace : exn -> (unit -> unit) -> 'a
+(** [reraise_preserving_backtrace e f] is (f (); raise e) except that the
+    current backtrace is preserved, even if [f] uses exceptions internally. *)
+
+
+val map_end: ('a -> 'b) -> 'a list -> 'b list -> 'b list
+        (* [map_end f l t] is [map f l @ t], just more efficient. *)
+val map_left_right: ('a -> 'b) -> 'a list -> 'b list
+        (* Like [List.map], with guaranteed left-to-right evaluation order *)
+val for_all2: ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+        (* Same as [List.for_all] but for a binary predicate.
+           In addition, this [for_all2] never fails: given two lists
+           with different lengths, it returns false. *)
+val replicate_list: 'a -> int -> 'a list
+        (* [replicate_list elem n] is the list with [n] elements
+           all identical to [elem]. *)
+val list_remove: 'a -> 'a list -> 'a list
+        (* [list_remove x l] returns a copy of [l] with the first
+           element equal to [x] removed. *)
+val split_last: 'a list -> 'a list * 'a
+        (* Return the last element and the other elements of the given list. *)
+
+type ref_and_value = R : 'a ref * 'a -> ref_and_value
+
+val protect_refs : ref_and_value list -> (unit -> 'a) -> 'a
+(** [protect_refs l f] temporarily sets [r] to [v] for each [R (r, v)] in [l]
+    while executing [f]. The previous contents of the references is restored
+    even if [f] raises an exception, without altering the exception backtrace.
+*)
+
+module Stdlib : sig
+  module List : sig
+    type 'a t = 'a list
+
+    val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
+    (** The lexicographic order supported by the provided order.
+        There is no constraint on the relative lengths of the lists. *)
+
+    val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+    (** Returns [true] iff the given lists have the same length and content
+        with respect to the given equality function. *)
+
+    val some_if_all_elements_are_some : 'a option t -> 'a t option
+    (** If all elements of the given list are [Some _] then [Some xs]
+        is returned with the [xs] being the contents of those [Some]s, with
+        order preserved.  Otherwise return [None]. *)
+
+    val map2_prefix : ('a -> 'b -> 'c) -> 'a t -> 'b t -> ('c t * 'b t)
+    (** [let r1, r2 = map2_prefix f l1 l2]
+        If [l1] is of length n and [l2 = h2 @ t2] with h2 of length n,
+        r1 is [List.map2 f l1 h1] and r2 is t2. *)
+
+    val split_at : int -> 'a t -> 'a t * 'a t
+    (** [split_at n l] returns the pair [before, after] where [before] is
+        the [n] first elements of [l] and [after] the remaining ones.
+        If [l] has less than [n] elements, raises Invalid_argument. *)
+
+    val is_prefix
+       : equal:('a -> 'a -> bool)
+      -> 'a list
+      -> of_:'a list
+      -> bool
+    (** Returns [true] iff the given list, with respect to the given equality
+        function on list members, is a prefix of the list [of_]. *)
+
+    type 'a longest_common_prefix_result = private {
+      longest_common_prefix : 'a list;
+      first_without_longest_common_prefix : 'a list;
+      second_without_longest_common_prefix : 'a list;
+    }
+
+    val find_and_chop_longest_common_prefix
+       : equal:('a -> 'a -> bool)
+      -> first:'a list
+      -> second:'a list
+      -> 'a longest_common_prefix_result
+    (** Returns the longest list that, with respect to the provided equality
+        function, is a prefix of both of the given lists.  The input lists,
+        each with such longest common prefix removed, are also returned. *)
+  end
+
+  module Option : sig
+    type 'a t = 'a option
+
+    val print
+       : (Format.formatter -> 'a -> unit)
+      -> Format.formatter
+      -> 'a t
+      -> unit
+  end
+
+  module Array : sig
+    val exists2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
+    (* Same as [Array.exists], but for a two-argument predicate. Raise
+       Invalid_argument if the two arrays are determined to have
+       different lengths. *)
+
+    val for_alli : (int -> 'a -> bool) -> 'a array -> bool
+    (** Same as {!Array.for_all}, but the
+        function is applied with the index of the element as first argument,
+        and the element itself as second argument. *)
+
+    val all_somes : 'a option array -> 'a array option
+  end
+
+  module String : sig
+    include module type of String
+    module Set : Set.S with type elt = string
+    module Map : Map.S with type key = string
+    module Tbl : Hashtbl.S with type key = string
+
+    val print : Format.formatter -> t -> unit
+
+    val for_all : (char -> bool) -> t -> bool
+  end
+
+  external compare : 'a -> 'a -> int = "%compare"
+end
+
+val find_in_path: string list -> string -> string
+        (* Search a file in a list of directories. *)
+val find_in_path_rel: string list -> string -> string
+        (* Search a relative file in a list of directories. *)
+val find_in_path_uncap: string list -> string -> string
+        (* Same, but search also for uncapitalized name, i.e.
+           if name is Foo.ml, allow /path/Foo.ml and /path/foo.ml
+           to match. *)
+val remove_file: string -> unit
+        (* Delete the given file if it exists. Never raise an error. *)
+val expand_directory: string -> string -> string
+        (* [expand_directory alt file] eventually expands a [+] at the
+           beginning of file into [alt] (an alternate root directory) *)
+
+val split_path_contents: ?sep:char -> string -> string list
+(* [split_path_contents ?sep s] interprets [s] as the value of a "PATH"-like
+   variable and returns the corresponding list of directories. [s] is split
+   using the platform-specific delimiter, or [~sep] if it is passed.
+
+   Returns the empty list if [s] is empty. *)
+
+val create_hashtable: int -> ('a * 'b) list -> ('a, 'b) Hashtbl.t
+        (* Create a hashtable of the given size and fills it with the
+           given bindings. *)
+
+val copy_file: in_channel -> out_channel -> unit
+        (* [copy_file ic oc] reads the contents of file [ic] and copies
+           them to [oc]. It stops when encountering EOF on [ic]. *)
+val copy_file_chunk: in_channel -> out_channel -> int -> unit
+        (* [copy_file_chunk ic oc n] reads [n] bytes from [ic] and copies
+           them to [oc]. It raises [End_of_file] when encountering
+           EOF on [ic]. *)
+val string_of_file: in_channel -> string
+        (* [string_of_file ic] reads the contents of file [ic] and copies
+           them to a string. It stops when encountering EOF on [ic]. *)
+val output_to_file_via_temporary:
+      ?mode:open_flag list -> string -> (string -> out_channel -> 'a) -> 'a
+        (* Produce output in temporary file, then rename it
+           (as atomically as possible) to the desired output file name.
+           [output_to_file_via_temporary filename fn] opens a temporary file
+           which is passed to [fn] (name + output channel).  When [fn] returns,
+           the channel is closed and the temporary file is renamed to
+           [filename]. *)
+
+(** Open the given [filename] for writing (in binary mode), pass the
+    [out_channel] to the given function, then close the channel. If the function
+    raises an exception then [filename] will be removed. *)
+val protect_writing_to_file
+   : filename:string
+  -> f:(out_channel -> 'a)
+  -> 'a
+
+val log2: int -> int
+        (* [log2 n] returns [s] such that [n = 1 lsl s]
+           if [n] is a power of 2*)
+val align: int -> int -> int
+        (* [align n a] rounds [n] upwards to a multiple of [a]
+           (a power of 2). *)
+val no_overflow_add: int -> int -> bool
+        (* [no_overflow_add n1 n2] returns [true] if the computation of
+           [n1 + n2] does not overflow. *)
+val no_overflow_sub: int -> int -> bool
+        (* [no_overflow_sub n1 n2] returns [true] if the computation of
+           [n1 - n2] does not overflow. *)
+val no_overflow_mul: int -> int -> bool
+        (* [no_overflow_mul n1 n2] returns [true] if the computation of
+           [n1 * n2] does not overflow. *)
+val no_overflow_lsl: int -> int -> bool
+        (* [no_overflow_lsl n k] returns [true] if the computation of
+           [n lsl k] does not overflow. *)
+
+module Int_literal_converter : sig
+  val int : string -> int
+  val int32 : string -> int32
+  val int64 : string -> int64
+  val nativeint : string -> nativeint
+end
+
+val chop_extensions: string -> string
+        (* Return the given file name without its extensions. The extensions
+           is the longest suffix starting with a period and not including
+           a directory separator, [.xyz.uvw] for instance.
+
+           Return the given name if it does not contain an extension. *)
+
+val search_substring: string -> string -> int -> int
+        (* [search_substring pat str start] returns the position of the first
+           occurrence of string [pat] in string [str].  Search starts
+           at offset [start] in [str].  Raise [Not_found] if [pat]
+           does not occur. *)
+
+val replace_substring: before:string -> after:string -> string -> string
+        (* [replace_substring ~before ~after str] replaces all
+           occurrences of [before] with [after] in [str] and returns
+           the resulting string. *)
+
+val rev_split_words: string -> string list
+        (* [rev_split_words s] splits [s] in blank-separated words, and returns
+           the list of words in reverse order. *)
+
+val get_ref: 'a list ref -> 'a list
+        (* [get_ref lr] returns the content of the list reference [lr] and reset
+           its content to the empty list. *)
+
+val set_or_ignore : ('a -> 'b option) -> 'b option ref -> 'a -> unit
+        (* [set_or_ignore f opt x] sets [opt] to [f x] if it returns [Some _],
+           or leaves it unmodified if it returns [None]. *)
+
+val fst3: 'a * 'b * 'c -> 'a
+val snd3: 'a * 'b * 'c -> 'b
+val thd3: 'a * 'b * 'c -> 'c
+
+val fst4: 'a * 'b * 'c * 'd -> 'a
+val snd4: 'a * 'b * 'c * 'd -> 'b
+val thd4: 'a * 'b * 'c * 'd -> 'c
+val for4: 'a * 'b * 'c * 'd -> 'd
+
+module LongString :
+  sig
+    type t = bytes array
+    val create : int -> t
+    val length : t -> int
+    val get : t -> int -> char
+    val set : t -> int -> char -> unit
+    val blit : t -> int -> t -> int -> int -> unit
+    val blit_string : string -> int -> t -> int -> int -> unit
+    val output : out_channel -> t -> int -> int -> unit
+    val input_bytes_into : t -> in_channel -> int -> unit
+    val input_bytes : in_channel -> int -> t
+  end
+
+val edit_distance : string -> string -> int -> int option
+(** [edit_distance a b cutoff] computes the edit distance between
+    strings [a] and [b]. To help efficiency, it uses a cutoff: if the
+    distance [d] is smaller than [cutoff], it returns [Some d], else
+    [None].
+
+    The distance algorithm currently used is Damerau-Levenshtein: it
+    computes the number of insertion, deletion, substitution of
+    letters, or swapping of adjacent letters to go from one word to the
+    other. The particular algorithm may change in the future.
+*)
+
+val spellcheck : string list -> string -> string list
+(** [spellcheck env name] takes a list of names [env] that exist in
+    the current environment and an erroneous [name], and returns a
+    list of suggestions taken from [env], that are close enough to
+    [name] that it may be a typo for one of them. *)
+
+val did_you_mean : Format.formatter -> (unit -> string list) -> unit
+(** [did_you_mean ppf get_choices] hints that the user may have meant
+    one of the option returned by calling [get_choices]. It does nothing
+    if the returned list is empty.
+
+    The [unit -> ...] thunking is meant to delay any potentially-slow
+    computation (typically computing edit-distance with many things
+    from the current environment) to when the hint message is to be
+    printed. You should print an understandable error message before
+    calling [did_you_mean], so that users get a clear notification of
+    the failure even if producing the hint is slow.
+*)
+
+val cut_at : string -> char -> string * string
+(** [String.cut_at s c] returns a pair containing the sub-string before
+   the first occurrence of [c] in [s], and the sub-string after the
+   first occurrence of [c] in [s].
+   [let (before, after) = String.cut_at s c in
+    before ^ String.make 1 c ^ after] is the identity if [s] contains [c].
+
+   Raise [Not_found] if the character does not appear in the string
+   @since 4.01
+*)
+
+(* Color handling *)
+module Color : sig
+  type color =
+    | Black
+    | Red
+    | Green
+    | Yellow
+    | Blue
+    | Magenta
+    | Cyan
+    | White
+  ;;
+
+  type style =
+    | FG of color (* foreground *)
+    | BG of color (* background *)
+    | Bold
+    | Reset
+
+  val ansi_of_style_l : style list -> string
+  (* ANSI escape sequence for the given style *)
+
+  type styles = {
+    error: style list;
+    warning: style list;
+    loc: style list;
+  }
+
+  val default_styles: styles
+  val get_styles: unit -> styles
+  val set_styles: styles -> unit
+
+  type setting = Auto | Always | Never
+
+  val default_setting : setting
+
+  val setup : setting option -> unit
+  (* [setup opt] will enable or disable color handling on standard formatters
+     according to the value of color setting [opt].
+     Only the first call to this function has an effect. *)
+
+  val set_color_tag_handling : Format.formatter -> unit
+  (* adds functions to support color tags to the given formatter. *)
+end
+
+(* See the -error-style option *)
+module Error_style : sig
+  type setting =
+    | Contextual
+    | Short
+
+  val default_setting : setting
+end
+
+val normalise_eol : string -> string
+(** [normalise_eol s] returns a fresh copy of [s] with any '\r' characters
+   removed. Intended for pre-processing text which will subsequently be printed
+   on a channel which performs EOL transformations (i.e. Windows) *)
+
+val delete_eol_spaces : string -> string
+(** [delete_eol_spaces s] returns a fresh copy of [s] with any end of
+   line spaces removed. Intended to normalize the output of the
+   toplevel for tests. *)
+
+val pp_two_columns :
+  ?sep:string -> ?max_lines:int ->
+  Format.formatter -> (string * string) list -> unit
+(** [pp_two_columns ?sep ?max_lines ppf l] prints the lines in [l] as two
+   columns separated by [sep] ("|" by default). [max_lines] can be used to
+   indicate a maximum number of lines to print -- an ellipsis gets inserted at
+   the middle if the input has too many lines.
+
+   Example:
+
+    {v pp_two_columns ~max_lines:3 Format.std_formatter [
+      "abc", "hello";
+      "def", "zzz";
+      "a"  , "bllbl";
+      "bb" , "dddddd";
+    ] v}
+
+    prints
+
+    {v
+    abc | hello
+    ...
+    bb  | dddddd
+    v}
+*)
+
+(** configuration variables *)
+val show_config_and_exit : unit -> unit
+val show_config_variable_and_exit : string -> unit
+
+val get_build_path_prefix_map: unit -> Build_path_prefix_map.map option
+(** Returns the map encoded in the [BUILD_PATH_PREFIX_MAP] environment
+    variable. *)
+
+val debug_prefix_map_flags: unit -> string list
+(** Returns the list of [--debug-prefix-map] flags to be passed to the
+    assembler, built from the [BUILD_PATH_PREFIX_MAP] environment variable. *)
+
+val print_if :
+  Format.formatter -> bool ref -> (Format.formatter -> 'a -> unit) -> 'a -> 'a
+(** [print_if ppf flag fmt x] prints [x] with [fmt] on [ppf] if [b] is true. *)
+
+
+type filepath = string
+type modname = string
+type crcs = (modname * Digest.t option) list
+
+type alerts = string Stdlib.String.Map.t
+
+
+module EnvLazy: sig
+  type ('a,'b) t
+
+  type log
+
+  val force : ('a -> 'b) -> ('a,'b) t -> 'b
+  val create : 'a -> ('a,'b) t
+  val get_arg : ('a,'b) t -> 'a option
+  val create_forced : 'b -> ('a, 'b) t
+  val create_failed : exn -> ('a, 'b) t
+
+  (* [force_logged log f t] is equivalent to [force f t] but if [f]
+     returns [Error _] then [t] is recorded in [log]. [backtrack log]
+     will then reset all the recorded [t]s back to their original
+     state. *)
+  val log : unit -> log
+  val force_logged :
+    log -> ('a -> ('b, 'c) result) -> ('a,('b, 'c) result) t -> ('b, 'c) result
+  val backtrack : log -> unit
+
+end
+
+
+module Magic_number : sig
+  (** a typical magic number is "Caml1999I011"; it is formed of an
+      alphanumeric prefix, here Caml1990I, followed by a version,
+      here 011. The prefix identifies the kind of the versioned data:
+      here the I indicates that it is the magic number for .cmi files.
+
+      All magic numbers have the same byte length, [magic_length], and
+      this is important for users as it gives them the number of bytes
+      to read to obtain the byte sequence that should be a magic
+      number. Typical user code will look like:
+      {[
+        let ic = open_in_bin path in
+        let magic =
+          try really_input_string ic Magic_number.magic_length
+          with End_of_file -> ... in
+        match Magic_number.parse magic with
+        | Error parse_error -> ...
+        | Ok info -> ...
+      ]}
+
+      A given compiler version expects one specific version for each
+      kind of object file, and will fail if given an unsupported
+      version. Because versions grow monotonically, you can compare
+      the parsed version with the expected "current version" for
+      a kind, to tell whether the wrong-magic object file comes from
+      the past or from the future.
+
+      An example of code block that expects the "currently supported version"
+      of a given kind of magic numbers, here [Cmxa], is as follows:
+      {[
+        let ic = open_in_bin path in
+        begin
+          try Magic_number.(expect_current Cmxa (get_info ic)) with
+          | Parse_error error -> ...
+          | Unexpected error -> ...
+        end;
+        ...
+      ]}
+
+      Parse errors distinguish inputs that are [Not_a_magic_number str],
+      which are likely to come from the file being completely
+      different, and [Truncated str], raised by headers that are the
+      (possibly empty) prefix of a valid magic number.
+
+      Unexpected errors correspond to valid magic numbers that are not
+      the one expected, either because it corresponds to a different
+      kind, or to a newer or older version.
+
+      The helper functions [explain_parse_error] and [explain_unexpected_error]
+      will generate a textual explanation of each error,
+      for use in error messages.
+
+      @since 4.11.0
+  *)
+
+  type native_obj_config = {
+    flambda : bool;
+  }
+  (** native object files have a format and magic number that depend
+     on certain native-compiler configuration parameters. This
+     configuration space is expressed by the [native_obj_config]
+     type. *)
+
+  val native_obj_config : native_obj_config
+  (** the native object file configuration of the active/configured compiler. *)
+
+  type version = int
+
+  type kind =
+    | Exec
+    | Cmi | Cmo | Cma
+    | Cmx of native_obj_config | Cmxa of native_obj_config
+    | Cmxs
+    | Cmt | Ast_impl | Ast_intf
+
+  type info = {
+    kind: kind;
+    version: version;
+    (** Note: some versions of the compiler use the same [version] suffix
+        for all kinds, but others use different versions counters for different
+        kinds. We may only assume that versions are growing monotonically
+        (not necessarily always by one) between compiler versions. *)
+  }
+
+  type raw = string
+  (** the type of raw magic numbers,
+      such as "Caml1999A027" for the .cma files of OCaml 4.10 *)
+
+  (** {3 Parsing magic numbers} *)
+
+  type parse_error =
+    | Truncated of string
+    | Not_a_magic_number of string
+
+  val explain_parse_error : kind option -> parse_error -> string
+  (** Produces an explanation for a parse error. If no kind is provided,
+      we use an unspecific formulation suggesting that any compiler-produced
+      object file would have been satisfying. *)
+
+  val parse : raw -> (info, parse_error) result
+  (** Parses a raw magic number *)
+
+  val read_info : in_channel -> (info, parse_error) result
+  (** Read a raw magic number from an input channel.
+
+      If the data read [str] is not a valid magic number, it can be
+      recovered from the [Truncated str | Not_a_magic_number str]
+      payload of the [Error parse_error] case.
+
+      If parsing succeeds with an [Ok info] result, we know that
+      exactly [magic_length] bytes have been consumed from the
+      input_channel.
+
+      If you also wish to enforce that the magic number
+      is at the current version, see {!read_current_info} below.
+   *)
+
+  val magic_length : int
+  (** all magic numbers take the same number of bytes *)
+
+
+  (** {3 Checking that magic numbers are current} *)
+
+  type 'a unexpected = { expected : 'a; actual : 'a }
+  type unexpected_error =
+    | Kind of kind unexpected
+    | Version of kind * version unexpected
+
+  val check_current : kind -> info -> (unit, unexpected_error) result
+  (** [check_current kind info] checks that the provided magic [info]
+      is the current version of [kind]'s magic header. *)
+
+  val explain_unexpected_error : unexpected_error -> string
+  (** Provides an explanation of the [unexpected_error]. *)
+
+  type error =
+    | Parse_error of parse_error
+    | Unexpected_error of unexpected_error
+
+  val read_current_info :
+    expected_kind:kind option -> in_channel -> (info, error) result
+  (** Read a magic number as [read_info],
+      and check that it is the current version as its kind.
+      If the [expected_kind] argument is [None], any kind is accepted. *)
+
+
+  (** {3 Information on magic numbers} *)
+
+  val string_of_kind : kind -> string
+  (** a user-printable string for a kind, eg. "exec" or "cmo", to use
+      in error messages. *)
+
+  val human_name_of_kind : kind -> string
+  (** a user-meaningful name for a kind, eg. "executable file" or
+      "bytecode object file", to use in error messages. *)
+
+  val current_raw : kind -> raw
+  (** the current magic number of each kind *)
+
+  val current_version : kind -> version
+  (** the current version of each kind *)
+
+
+  (** {3 Raw representations}
+
+      Mainly for internal usage and testing. *)
+
+  type raw_kind = string
+  (** the type of raw magic numbers kinds,
+      such as "Caml1999A" for .cma files *)
+
+  val parse_kind : raw_kind -> kind option
+  (** parse a raw kind into a kind *)
+
+  val raw_kind : kind -> raw_kind
+  (** the current raw representation of a kind.
+
+      In some cases the raw representation of a kind has changed
+      over compiler versions, so other files of the same kind
+      may have different raw kinds.
+      Note that all currently known cases are parsed correctly by [parse_kind].
+  *)
+
+  val raw : info -> raw
+  (** A valid raw representation of the magic number.
+
+      Due to past and future changes in the string representation of
+      magic numbers, we cannot guarantee that the raw strings returned
+      for past and future versions actually match the expectations of
+      those compilers. The representation is accurate for current
+      versions, and it is correctly parsed back into the desired
+      version by the parsing functions above.
+   *)
+
+  (**/**)
+
+  val all_kinds : kind list
+end
diff --git a/upstream/ocaml_412/utils/numbers.ml b/upstream/ocaml_412/utils/numbers.ml
new file mode 100644
index 0000000..1680675
--- /dev/null
+++ b/upstream/ocaml_412/utils/numbers.ml
@@ -0,0 +1,88 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Int_base = Identifiable.Make (struct
+  type t = int
+
+  let compare x y = x - y
+  let output oc x = Printf.fprintf oc "%i" x
+  let hash i = i
+  let equal (i : int) j = i = j
+  let print = Format.pp_print_int
+end)
+
+module Int = struct
+  type t = int
+
+  include Int_base
+
+  let rec zero_to_n n =
+    if n < 0 then Set.empty else Set.add n (zero_to_n (n-1))
+
+  let to_string n = Int.to_string n
+end
+
+module Int8 = struct
+  type t = int
+
+  let zero = 0
+  let one = 1
+
+  let of_int_exn i =
+    if i < -(1 lsl 7) || i > ((1 lsl 7) - 1) then
+      Misc.fatal_errorf "Int8.of_int_exn: %d is out of range" i
+    else
+      i
+
+  let to_int i = i
+end
+
+module Int16 = struct
+  type t = int
+
+  let of_int_exn i =
+    if i < -(1 lsl 15) || i > ((1 lsl 15) - 1) then
+      Misc.fatal_errorf "Int16.of_int_exn: %d is out of range" i
+    else
+      i
+
+  let lower_int64 = Int64.neg (Int64.shift_left Int64.one 15)
+  let upper_int64 = Int64.sub (Int64.shift_left Int64.one 15) Int64.one
+
+  let of_int64_exn i =
+    if Int64.compare i lower_int64 < 0
+        || Int64.compare i upper_int64 > 0
+    then
+      Misc.fatal_errorf "Int16.of_int64_exn: %Ld is out of range" i
+    else
+      Int64.to_int i
+
+  let to_int t = t
+end
+
+module Float = struct
+  type t = float
+
+  include Identifiable.Make (struct
+    type t = float
+
+    let compare x y = Stdlib.compare x y
+    let output oc x = Printf.fprintf oc "%f" x
+    let hash f = Hashtbl.hash f
+    let equal (i : float) j = i = j
+    let print = Format.pp_print_float
+  end)
+end
diff --git a/upstream/ocaml_412/utils/numbers.mli b/upstream/ocaml_412/utils/numbers.mli
new file mode 100644
index 0000000..fa565e6
--- /dev/null
+++ b/upstream/ocaml_412/utils/numbers.mli
@@ -0,0 +1,51 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Modules about numbers, some of which satisfy {!Identifiable.S}.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+module Int : sig
+  include Identifiable.S with type t = int
+
+  (** [zero_to_n n] is the set of numbers \{0, ..., n\} (inclusive). *)
+  val zero_to_n : int -> Set.t
+  val to_string : int -> string
+end
+
+module Int8 : sig
+  type t
+
+  val zero : t
+  val one : t
+
+  val of_int_exn : int -> t
+  val to_int : t -> int
+end
+
+module Int16 : sig
+  type t
+
+  val of_int_exn : int -> t
+  val of_int64_exn : Int64.t -> t
+
+  val to_int : t -> int
+end
+
+module Float : Identifiable.S with type t = float
diff --git a/upstream/ocaml_412/utils/profile.ml b/upstream/ocaml_412/utils/profile.ml
new file mode 100644
index 0000000..02e3a16
--- /dev/null
+++ b/upstream/ocaml_412/utils/profile.ml
@@ -0,0 +1,335 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Pierre Chambart, OCamlPro                         *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-18-40-42-48"]
+
+type file = string
+
+external time_include_children: bool -> float = "caml_sys_time_include_children"
+let cpu_time () = time_include_children true
+
+module Measure = struct
+  type t = {
+    time : float;
+    allocated_words : float;
+    top_heap_words : int;
+  }
+  let create () =
+    let stat = Gc.quick_stat () in
+    {
+      time = cpu_time ();
+      allocated_words = stat.minor_words +. stat.major_words;
+      top_heap_words = stat.top_heap_words;
+    }
+  let zero = { time = 0.; allocated_words = 0.; top_heap_words = 0 }
+end
+
+module Measure_diff = struct
+  let timestamp = let r = ref (-1) in fun () -> incr r; !r
+  type t = {
+    timestamp : int;
+    duration : float;
+    allocated_words : float;
+    top_heap_words_increase : int;
+  }
+  let zero () = {
+    timestamp = timestamp ();
+    duration = 0.;
+    allocated_words = 0.;
+    top_heap_words_increase = 0;
+  }
+  let accumulate t (m1 : Measure.t) (m2 : Measure.t) = {
+    timestamp = t.timestamp;
+    duration = t.duration +. (m2.time -. m1.time);
+    allocated_words =
+      t.allocated_words +. (m2.allocated_words -. m1.allocated_words);
+    top_heap_words_increase =
+      t.top_heap_words_increase + (m2.top_heap_words - m1.top_heap_words);
+  }
+  let of_diff m1 m2 =
+    accumulate (zero ()) m1 m2
+end
+
+type hierarchy =
+  | E of (string, Measure_diff.t * hierarchy) Hashtbl.t
+[@@unboxed]
+
+let create () = E (Hashtbl.create 2)
+let hierarchy = ref (create ())
+let initial_measure = ref None
+let reset () = hierarchy := create (); initial_measure := None
+
+let record_call ?(accumulate = false) name f =
+  let E prev_hierarchy = !hierarchy in
+  let start_measure = Measure.create () in
+  if !initial_measure = None then initial_measure := Some start_measure;
+  let this_measure_diff, this_table =
+    (* We allow the recording of multiple categories by the same name, for tools
+       like ocamldoc that use the compiler libs but don't care about profile
+       information, and so may record, say, "parsing" multiple times. *)
+    if accumulate
+    then
+      match Hashtbl.find prev_hierarchy name with
+      | exception Not_found -> Measure_diff.zero (), Hashtbl.create 2
+      | measure_diff, E table ->
+        Hashtbl.remove prev_hierarchy name;
+        measure_diff, table
+    else Measure_diff.zero (), Hashtbl.create 2
+  in
+  hierarchy := E this_table;
+  Misc.try_finally f
+    ~always:(fun () ->
+        hierarchy := E prev_hierarchy;
+        let end_measure = Measure.create () in
+        let measure_diff =
+          Measure_diff.accumulate this_measure_diff start_measure end_measure in
+        Hashtbl.add prev_hierarchy name (measure_diff, E this_table))
+
+let record ?accumulate pass f x = record_call ?accumulate pass (fun () -> f x)
+
+type display = {
+  to_string : max:float -> width:int -> string;
+  worth_displaying : max:float -> bool;
+}
+
+let time_display v : display =
+  (* Because indentation is meaningful, and because the durations are
+     the first element of each row, we can't pad them with spaces. *)
+  let to_string_without_unit v ~width = Printf.sprintf "%0*.03f" width v in
+  let to_string ~max:_ ~width =
+    to_string_without_unit v ~width:(width - 1) ^ "s" in
+  let worth_displaying ~max:_ =
+    float_of_string (to_string_without_unit v ~width:0) <> 0. in
+  { to_string; worth_displaying }
+
+let memory_word_display =
+  (* To make memory numbers easily comparable across rows, we choose a single
+     scale for an entire column. To keep the display compact and not overly
+     precise (no one cares about the exact number of bytes), we pick the largest
+     scale we can and we only show 3 digits. Avoiding showing tiny numbers also
+     allows us to avoid displaying passes that barely allocate compared to the
+     rest of the compiler.  *)
+  let bytes_of_words words = words *. float_of_int (Sys.word_size / 8) in
+  let to_string_without_unit v ~width scale =
+    let precision = 3 and precision_power = 1e3 in
+    let v_rescaled = bytes_of_words v /. scale in
+    let v_rounded =
+      floor (v_rescaled *. precision_power +. 0.5) /. precision_power in
+    let v_str = Printf.sprintf "%.*f" precision v_rounded in
+    let index_of_dot = String.index v_str '.' in
+    let v_str_truncated =
+      String.sub v_str 0
+        (if index_of_dot >= precision
+         then index_of_dot
+         else precision + 1)
+    in
+    Printf.sprintf "%*s" width v_str_truncated
+  in
+  let choose_memory_scale =
+    let units = [|"B"; "kB"; "MB"; "GB"|] in
+    fun words ->
+      let bytes = bytes_of_words words in
+      let scale = ref (Array.length units - 1) in
+      while !scale > 0 && bytes < 1024. ** float_of_int !scale do
+        decr scale
+      done;
+      1024. ** float_of_int !scale, units.(!scale)
+  in
+  fun ?previous v : display ->
+    let to_string ~max ~width =
+      let scale, scale_str = choose_memory_scale max in
+      let width = width - String.length scale_str in
+      to_string_without_unit v ~width scale ^ scale_str
+    in
+    let worth_displaying ~max =
+      let scale, _ = choose_memory_scale max in
+      float_of_string (to_string_without_unit v ~width:0 scale) <> 0.
+      && match previous with
+      | None -> true
+      | Some p ->
+         (* This branch is for numbers that represent absolute quantity, rather
+            than differences. It allows us to skip displaying the same absolute
+            quantity many times in a row. *)
+         to_string_without_unit p ~width:0 scale
+         <> to_string_without_unit v ~width:0 scale
+    in
+    { to_string; worth_displaying }
+
+let profile_list (E table) =
+  let l = Hashtbl.fold (fun k d l -> (k, d) :: l) table [] in
+  List.sort (fun (_, (p1, _)) (_, (p2, _)) ->
+    compare p1.Measure_diff.timestamp p2.Measure_diff.timestamp) l
+
+let compute_other_category (E table : hierarchy) (total : Measure_diff.t) =
+  let r = ref total in
+  Hashtbl.iter (fun _pass ((p2 : Measure_diff.t), _) ->
+    let p1 = !r in
+    r := {
+      timestamp = p1.timestamp;
+      duration = p1.duration -. p2.duration;
+      allocated_words = p1.allocated_words -. p2.allocated_words;
+      top_heap_words_increase =
+        p1.top_heap_words_increase - p2.top_heap_words_increase;
+    }
+  ) table;
+  !r
+
+type row = R of string * (float * display) list * row list
+type column = [ `Time | `Alloc | `Top_heap | `Abs_top_heap ]
+
+let rec rows_of_hierarchy ~nesting make_row name measure_diff hierarchy env =
+  let rows =
+    rows_of_hierarchy_list
+      ~nesting:(nesting + 1) make_row hierarchy measure_diff env in
+  let values, env =
+    make_row env measure_diff ~toplevel_other:(nesting = 0 && name = "other") in
+  R (name, values, rows), env
+
+and rows_of_hierarchy_list ~nesting make_row hierarchy total env =
+  let list = profile_list hierarchy in
+  let list =
+    if list <> [] || nesting = 0
+    then list @ [ "other", (compute_other_category hierarchy total, create ()) ]
+    else []
+  in
+  let env = ref env in
+  List.map (fun (name, (measure_diff, hierarchy)) ->
+    let a, env' =
+      rows_of_hierarchy ~nesting make_row name measure_diff hierarchy !env in
+    env := env';
+    a
+  ) list
+
+let rows_of_hierarchy hierarchy measure_diff initial_measure columns =
+  (* Computing top heap size is a bit complicated: if the compiler applies a
+     list of passes n times (rather than applying pass1 n times, then pass2 n
+     times etc), we only show one row for that pass but what does "top heap
+     size at the end of that pass" even mean?
+     It seems the only sensible answer is to pretend the compiler applied pass1
+     n times, pass2 n times by accumulating all the heap size increases that
+     happened during each pass, and then compute what the heap size would have
+     been. So that's what we do.
+     There's a bit of extra complication, which is that the heap can increase in
+     between measurements. So the heap sizes can be a bit off until the "other"
+     rows account for what's missing. We special case the toplevel "other" row
+     so that any increases that happened before the start of the compilation is
+     correctly reported, as a lot of code may run before the start of the
+     compilation (eg functor applications). *)
+    let make_row prev_top_heap_words (p : Measure_diff.t) ~toplevel_other =
+      let top_heap_words =
+        prev_top_heap_words
+        + p.top_heap_words_increase
+        - if toplevel_other
+          then initial_measure.Measure.top_heap_words
+          else 0
+      in
+      let make value ~f = value, f value in
+      List.map (function
+        | `Time ->
+          make p.duration ~f:time_display
+        | `Alloc ->
+          make p.allocated_words ~f:memory_word_display
+        | `Top_heap ->
+          make (float_of_int p.top_heap_words_increase) ~f:memory_word_display
+        | `Abs_top_heap ->
+          make (float_of_int top_heap_words)
+           ~f:(memory_word_display ~previous:(float_of_int prev_top_heap_words))
+      ) columns,
+      top_heap_words
+  in
+  rows_of_hierarchy_list ~nesting:0 make_row hierarchy measure_diff
+    initial_measure.top_heap_words
+
+let max_by_column ~n_columns rows =
+  let a = Array.make n_columns 0. in
+  let rec loop (R (_, values, rows)) =
+    List.iteri (fun i (v, _) -> a.(i) <- max a.(i) v) values;
+    List.iter loop rows
+  in
+  List.iter loop rows;
+  a
+
+let width_by_column ~n_columns ~display_cell rows =
+  let a = Array.make n_columns 1 in
+  let rec loop (R (_, values, rows)) =
+    List.iteri (fun i cell ->
+      let _, str = display_cell i cell ~width:0 in
+      a.(i) <- max a.(i) (String.length str)
+    ) values;
+    List.iter loop rows;
+  in
+  List.iter loop rows;
+  a
+
+let display_rows ppf rows =
+  let n_columns =
+    match rows with
+    | [] -> 0
+    | R (_, values, _) :: _ -> List.length values
+  in
+  let maxs = max_by_column ~n_columns rows in
+  let display_cell i (_, c) ~width =
+    let display_cell = c.worth_displaying ~max:maxs.(i) in
+    display_cell, if display_cell
+                  then c.to_string ~max:maxs.(i) ~width
+                  else String.make width '-'
+  in
+  let widths = width_by_column ~n_columns ~display_cell rows in
+  let rec loop (R (name, values, rows)) ~indentation =
+    let worth_displaying, cell_strings =
+      values
+      |> List.mapi (fun i cell -> display_cell i cell ~width:widths.(i))
+      |> List.split
+    in
+    if List.exists (fun b -> b) worth_displaying then
+      Format.fprintf ppf "%s%s %s@\n"
+        indentation (String.concat " " cell_strings) name;
+    List.iter (loop ~indentation:("  " ^ indentation)) rows;
+  in
+  List.iter (loop ~indentation:"") rows
+
+let print ppf columns =
+  match columns with
+  | [] -> ()
+  | _ :: _ ->
+     let initial_measure =
+       match !initial_measure with
+       | Some v -> v
+       | None -> Measure.zero
+     in
+     let total = Measure_diff.of_diff Measure.zero (Measure.create ()) in
+     display_rows ppf
+       (rows_of_hierarchy !hierarchy total initial_measure columns)
+
+let column_mapping = [
+  "time", `Time;
+  "alloc", `Alloc;
+  "top-heap", `Top_heap;
+  "absolute-top-heap", `Abs_top_heap;
+]
+
+let column_names = List.map fst column_mapping
+
+let options_doc =
+  Printf.sprintf
+    " Print performance information for each pass\
+   \n    The columns are: %s."
+    (String.concat " " column_names)
+
+let all_columns = List.map snd column_mapping
+
+let generate = "generate"
+let transl = "transl"
+let typing = "typing"
diff --git a/upstream/ocaml_412/utils/profile.mli b/upstream/ocaml_412/utils/profile.mli
new file mode 100644
index 0000000..7eff695
--- /dev/null
+++ b/upstream/ocaml_412/utils/profile.mli
@@ -0,0 +1,49 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Pierre Chambart, OCamlPro                         *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Compiler performance recording
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type file = string
+
+val reset : unit -> unit
+(** erase all recorded profile information *)
+
+val record_call : ?accumulate:bool -> string -> (unit -> 'a) -> 'a
+(** [record_call pass f] calls [f] and records its profile information. *)
+
+val record : ?accumulate:bool -> string -> ('a -> 'b) -> 'a -> 'b
+(** [record pass f arg] records the profile information of [f arg] *)
+
+type column = [ `Time | `Alloc | `Top_heap | `Abs_top_heap ]
+
+val print : Format.formatter -> column list -> unit
+(** Prints the selected recorded profiling information to the formatter. *)
+
+(** Command line flags *)
+
+val options_doc : string
+val all_columns : column list
+
+(** A few pass names that are needed in several places, and shared to
+    avoid typos. *)
+
+val generate : string
+val transl : string
+val typing : string
diff --git a/upstream/ocaml_412/utils/strongly_connected_components.ml b/upstream/ocaml_412/utils/strongly_connected_components.ml
new file mode 100644
index 0000000..a11f698
--- /dev/null
+++ b/upstream/ocaml_412/utils/strongly_connected_components.ml
@@ -0,0 +1,200 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Int = Numbers.Int
+
+module Kosaraju : sig
+  type component_graph =
+    { sorted_connected_components : int list array;
+      component_edges : int list array;
+    }
+
+  val component_graph : int list array -> component_graph
+end = struct
+  let transpose graph =
+    let size = Array.length graph in
+    let transposed = Array.make size [] in
+    let add src dst = transposed.(src) <- dst :: transposed.(src) in
+    Array.iteri (fun src dsts -> List.iter (fun dst -> add dst src) dsts)
+      graph;
+    transposed
+
+  let depth_first_order (graph : int list array) : int array =
+    let size = Array.length graph in
+    let marked = Array.make size false in
+    let stack = Array.make size ~-1 in
+    let pos = ref 0 in
+    let push i =
+      stack.(!pos) <- i;
+      incr pos
+    in
+    let rec aux node =
+      if not marked.(node)
+      then begin
+        marked.(node) <- true;
+        List.iter aux graph.(node);
+        push node
+      end
+    in
+    for i = 0 to size - 1 do
+      aux i
+    done;
+    stack
+
+  let mark order graph =
+    let size = Array.length graph in
+    let graph = transpose graph in
+    let marked = Array.make size false in
+    let id = Array.make size ~-1 in
+    let count = ref 0 in
+    let rec aux node =
+      if not marked.(node)
+      then begin
+        marked.(node) <- true;
+        id.(node) <- !count;
+        List.iter aux graph.(node)
+      end
+    in
+    for i = size - 1 downto 0 do
+      let node = order.(i) in
+      if not marked.(node)
+      then begin
+        aux order.(i);
+        incr count
+      end
+    done;
+    id, !count
+
+  let kosaraju graph =
+    let dfo = depth_first_order graph in
+    let components, ncomponents = mark dfo graph in
+    ncomponents, components
+
+  type component_graph =
+    { sorted_connected_components : int list array;
+      component_edges : int list array;
+    }
+
+  let component_graph graph =
+    let ncomponents, components = kosaraju graph in
+    let id_scc = Array.make ncomponents [] in
+    let component_graph = Array.make ncomponents Int.Set.empty in
+    let add_component_dep node set =
+      let node_deps = graph.(node) in
+      List.fold_left (fun set dep -> Int.Set.add components.(dep) set)
+        set node_deps
+    in
+    Array.iteri (fun node component ->
+        id_scc.(component) <- node :: id_scc.(component);
+        component_graph.(component) <-
+          add_component_dep node (component_graph.(component)))
+      components;
+    { sorted_connected_components = id_scc;
+      component_edges = Array.map Int.Set.elements component_graph;
+    }
+end
+
+module type S = sig
+  module Id : Identifiable.S
+
+  type directed_graph = Id.Set.t Id.Map.t
+
+  type component =
+    | Has_loop of Id.t list
+    | No_loop of Id.t
+
+  val connected_components_sorted_from_roots_to_leaf
+     : directed_graph
+    -> component array
+
+  val component_graph : directed_graph -> (component * int list) array
+end
+
+module Make (Id : Identifiable.S) = struct
+  type directed_graph = Id.Set.t Id.Map.t
+
+  type component =
+    | Has_loop of Id.t list
+    | No_loop of Id.t
+
+  (* Ensure that the dependency graph does not have external dependencies. *)
+  (* Note: this function is currently not used. *)
+  let _check dependencies =
+    Id.Map.iter (fun id set ->
+        Id.Set.iter (fun v ->
+            if not (Id.Map.mem v dependencies)
+            then
+              Misc.fatal_errorf "Strongly_connected_components.check: the \
+                  graph has external dependencies (%a -> %a)"
+               Id.print id Id.print v)
+          set)
+      dependencies
+
+  type numbering = {
+    back : int Id.Map.t;
+    forth : Id.t array;
+  }
+
+  let number graph =
+    let size = Id.Map.cardinal graph in
+    let bindings = Id.Map.bindings graph in
+    let a = Array.of_list bindings in
+    let forth = Array.map fst a in
+    let back =
+      let back = ref Id.Map.empty in
+      for i = 0 to size - 1 do
+        back := Id.Map.add forth.(i) i !back;
+      done;
+      !back
+    in
+    let integer_graph =
+      Array.init size (fun i ->
+        let _, dests = a.(i) in
+        Id.Set.fold (fun dest acc ->
+            let v =
+              try Id.Map.find dest back
+              with Not_found ->
+                Misc.fatal_errorf
+                  "Strongly_connected_components: missing dependency %a"
+                  Id.print dest
+            in
+            v :: acc)
+          dests [])
+    in
+    { back; forth }, integer_graph
+
+  let component_graph graph =
+    let numbering, integer_graph = number graph in
+    let { Kosaraju. sorted_connected_components;
+          component_edges } =
+      Kosaraju.component_graph integer_graph
+    in
+    Array.mapi (fun component nodes ->
+        match nodes with
+        | [] -> assert false
+        | [node] ->
+          (if List.mem node integer_graph.(node)
+           then Has_loop [numbering.forth.(node)]
+           else No_loop numbering.forth.(node)),
+            component_edges.(component)
+        | _::_ ->
+          (Has_loop (List.map (fun node -> numbering.forth.(node)) nodes)),
+            component_edges.(component))
+      sorted_connected_components
+
+  let connected_components_sorted_from_roots_to_leaf graph =
+    Array.map fst (component_graph graph)
+end
diff --git a/upstream/ocaml_412/utils/strongly_connected_components.mli b/upstream/ocaml_412/utils/strongly_connected_components.mli
new file mode 100644
index 0000000..e700952
--- /dev/null
+++ b/upstream/ocaml_412/utils/strongly_connected_components.mli
@@ -0,0 +1,43 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Kosaraju's algorithm for strongly connected components.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+module type S = sig
+  module Id : Identifiable.S
+
+  type directed_graph = Id.Set.t Id.Map.t
+  (** If (a -> set) belongs to the map, it means that there are edges
+      from [a] to every element of [set].  It is assumed that no edge
+      points to a vertex not represented in the map. *)
+
+  type component =
+    | Has_loop of Id.t list
+    | No_loop of Id.t
+
+  val connected_components_sorted_from_roots_to_leaf
+     : directed_graph
+    -> component array
+
+  val component_graph : directed_graph -> (component * int list) array
+end
+
+module Make (Id : Identifiable.S) : S with module Id := Id
diff --git a/upstream/ocaml_412/utils/targetint.ml b/upstream/ocaml_412/utils/targetint.ml
new file mode 100644
index 0000000..9d15a2f
--- /dev/null
+++ b/upstream/ocaml_412/utils/targetint.ml
@@ -0,0 +1,104 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                        Nicolas Ojeda Bar, LexiFi                       *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type repr =
+  | Int32 of int32
+  | Int64 of int64
+
+module type S = sig
+  type t
+  val zero : t
+  val one : t
+  val minus_one : t
+  val neg : t -> t
+  val add : t -> t -> t
+  val sub : t -> t -> t
+  val mul : t -> t -> t
+  val div : t -> t -> t
+  val unsigned_div : t -> t -> t
+  val rem : t -> t -> t
+  val unsigned_rem : t -> t -> t
+  val succ : t -> t
+  val pred : t -> t
+  val abs : t -> t
+  val max_int : t
+  val min_int : t
+  val logand : t -> t -> t
+  val logor : t -> t -> t
+  val logxor : t -> t -> t
+  val lognot : t -> t
+  val shift_left : t -> int -> t
+  val shift_right : t -> int -> t
+  val shift_right_logical : t -> int -> t
+  val of_int : int -> t
+  val of_int_exn : int -> t
+  val to_int : t -> int
+  val of_float : float -> t
+  val to_float : t -> float
+  val of_int32 : int32 -> t
+  val to_int32 : t -> int32
+  val of_int64 : int64 -> t
+  val to_int64 : t -> int64
+  val of_string : string -> t
+  val to_string : t -> string
+  val compare: t -> t -> int
+  val unsigned_compare : t -> t -> int
+  val equal: t -> t -> bool
+  val repr: t -> repr
+  val print : Format.formatter -> t -> unit
+end
+
+let size = Sys.word_size
+(* Later, this will be set by the configure script
+   in order to support cross-compilation. *)
+
+module Int32 = struct
+  include Int32
+  let of_int_exn =
+    match Sys.word_size with (* size of [int] *)
+    | 32 ->
+        Int32.of_int
+    | 64 ->
+        fun n ->
+          if n < Int32.(to_int min_int) || n > Int32.(to_int max_int) then
+            Misc.fatal_errorf "Targetint.of_int_exn: 0x%x out of range" n
+          else
+            Int32.of_int n
+    | _ ->
+        assert false
+  let of_int32 x = x
+  let to_int32 x = x
+  let of_int64 = Int64.to_int32
+  let to_int64 = Int64.of_int32
+  let repr x = Int32 x
+  let print ppf t = Format.fprintf ppf "%ld" t
+end
+
+module Int64 = struct
+  include Int64
+  let of_int_exn = Int64.of_int
+  let of_int64 x = x
+  let to_int64 x = x
+  let repr x = Int64 x
+  let print ppf t = Format.fprintf ppf "%Ld" t
+end
+
+include (val
+          (match size with
+           | 32 -> (module Int32)
+           | 64 -> (module Int64)
+           | _ -> assert false
+          ) : S)
diff --git a/upstream/ocaml_412/utils/targetint.mli b/upstream/ocaml_412/utils/targetint.mli
new file mode 100644
index 0000000..72d464d
--- /dev/null
+++ b/upstream/ocaml_412/utils/targetint.mli
@@ -0,0 +1,207 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                        Nicolas Ojeda Bar, LexiFi                       *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Target processor-native integers.
+
+   This module provides operations on the type of
+   signed 32-bit integers (on 32-bit target platforms) or
+   signed 64-bit integers (on 64-bit target platforms).
+   This integer type has exactly the same width as that of a
+   pointer type in the C compiler.  All arithmetic operations over
+   are taken modulo 2{^32} or 2{^64} depending
+   on the word size of the target architecture.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type t
+(** The type of target integers. *)
+
+val zero : t
+(** The target integer 0.*)
+
+val one : t
+(** The target integer 1.*)
+
+val minus_one : t
+(** The target integer -1.*)
+
+val neg : t -> t
+(** Unary negation. *)
+
+val add : t -> t -> t
+(** Addition. *)
+
+val sub : t -> t -> t
+(** Subtraction. *)
+
+val mul : t -> t -> t
+(** Multiplication. *)
+
+val div : t -> t -> t
+(** Integer division.  Raise [Division_by_zero] if the second
+   argument is zero.  This division rounds the real quotient of
+   its arguments towards zero, as specified for {!Stdlib.(/)}. *)
+
+val unsigned_div : t -> t -> t
+(** Same as {!div}, except that arguments and result are interpreted as {e
+    unsigned} integers. *)
+
+val rem : t -> t -> t
+(** Integer remainder.  If [y] is not zero, the result
+   of [Targetint.rem x y] satisfies the following properties:
+   [Targetint.zero <= Nativeint.rem x y < Targetint.abs y] and
+   [x = Targetint.add (Targetint.mul (Targetint.div x y) y)
+                      (Targetint.rem x y)].
+   If [y = 0], [Targetint.rem x y] raises [Division_by_zero]. *)
+
+val unsigned_rem : t -> t -> t
+(** Same as {!rem}, except that arguments and result are interpreted as {e
+    unsigned} integers. *)
+
+val succ : t -> t
+(** Successor.
+   [Targetint.succ x] is [Targetint.add x Targetint.one]. *)
+
+val pred : t -> t
+(** Predecessor.
+   [Targetint.pred x] is [Targetint.sub x Targetint.one]. *)
+
+val abs : t -> t
+(** Return the absolute value of its argument. *)
+
+val size : int
+(** The size in bits of a target native integer. *)
+
+val max_int : t
+(** The greatest representable target integer,
+    either 2{^31} - 1 on a 32-bit platform,
+    or 2{^63} - 1 on a 64-bit platform. *)
+
+val min_int : t
+(** The smallest representable target integer,
+   either -2{^31} on a 32-bit platform,
+   or -2{^63} on a 64-bit platform. *)
+
+val logand : t -> t -> t
+(** Bitwise logical and. *)
+
+val logor : t -> t -> t
+(** Bitwise logical or. *)
+
+val logxor : t -> t -> t
+(** Bitwise logical exclusive or. *)
+
+val lognot : t -> t
+(** Bitwise logical negation. *)
+
+val shift_left : t -> int -> t
+(** [Targetint.shift_left x y] shifts [x] to the left by [y] bits.
+    The result is unspecified if [y < 0] or [y >= bitsize],
+    where [bitsize] is [32] on a 32-bit platform and
+    [64] on a 64-bit platform. *)
+
+val shift_right : t -> int -> t
+(** [Targetint.shift_right x y] shifts [x] to the right by [y] bits.
+    This is an arithmetic shift: the sign bit of [x] is replicated
+    and inserted in the vacated bits.
+    The result is unspecified if [y < 0] or [y >= bitsize]. *)
+
+val shift_right_logical : t -> int -> t
+(** [Targetint.shift_right_logical x y] shifts [x] to the right
+    by [y] bits.
+    This is a logical shift: zeroes are inserted in the vacated bits
+    regardless of the sign of [x].
+    The result is unspecified if [y < 0] or [y >= bitsize]. *)
+
+val of_int : int -> t
+(** Convert the given integer (type [int]) to a target integer
+    (type [t]), module the target word size. *)
+
+val of_int_exn : int -> t
+(** Convert the given integer (type [int]) to a target integer
+    (type [t]).  Raises a fatal error if the conversion is not exact. *)
+
+val to_int : t -> int
+(** Convert the given target integer (type [t]) to an
+    integer (type [int]).  The high-order bit is lost during
+    the conversion. *)
+
+val of_float : float -> t
+(** Convert the given floating-point number to a target integer,
+   discarding the fractional part (truncate towards 0).
+   The result of the conversion is undefined if, after truncation,
+   the number is outside the range
+   \[{!Targetint.min_int}, {!Targetint.max_int}\]. *)
+
+val to_float : t -> float
+(** Convert the given target integer to a floating-point number. *)
+
+val of_int32 : int32 -> t
+(** Convert the given 32-bit integer (type [int32])
+    to a target integer. *)
+
+val to_int32 : t -> int32
+(** Convert the given target integer to a
+    32-bit integer (type [int32]).  On 64-bit platforms,
+    the 64-bit native integer is taken modulo 2{^32},
+    i.e. the top 32 bits are lost.  On 32-bit platforms,
+    the conversion is exact. *)
+
+val of_int64 : int64 -> t
+(** Convert the given 64-bit integer (type [int64])
+    to a target integer. *)
+
+val to_int64 : t -> int64
+(** Convert the given target integer to a
+    64-bit integer (type [int64]). *)
+
+val of_string : string -> t
+(** Convert the given string to a target integer.
+    The string is read in decimal (by default) or in hexadecimal,
+    octal or binary if the string begins with [0x], [0o] or [0b]
+    respectively.
+    Raise [Failure "int_of_string"] if the given string is not
+    a valid representation of an integer, or if the integer represented
+    exceeds the range of integers representable in type [nativeint]. *)
+
+val to_string : t -> string
+(** Return the string representation of its argument, in decimal. *)
+
+val compare: t -> t -> int
+(** The comparison function for target integers, with the same specification as
+    {!Stdlib.compare}.  Along with the type [t], this function [compare]
+    allows the module [Targetint] to be passed as argument to the functors
+    {!Set.Make} and {!Map.Make}. *)
+
+val unsigned_compare: t -> t -> int
+(** Same as {!compare}, except that arguments are interpreted as {e unsigned}
+    integers. *)
+
+val equal: t -> t -> bool
+(** The equal function for target ints. *)
+
+type repr =
+  | Int32 of int32
+  | Int64 of int64
+
+val repr : t -> repr
+(** The concrete representation of a native integer. *)
+
+val print : Format.formatter -> t -> unit
+(** Print a target integer to a formatter. *)
diff --git a/upstream/ocaml_412/utils/terminfo.ml b/upstream/ocaml_412/utils/terminfo.ml
new file mode 100644
index 0000000..1b4a357
--- /dev/null
+++ b/upstream/ocaml_412/utils/terminfo.ml
@@ -0,0 +1,45 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Paris                  *)
+(*                                                                        *)
+(*   Copyright 2017 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Printf
+
+external isatty : out_channel -> bool = "caml_sys_isatty"
+external terminfo_rows: out_channel -> int = "caml_terminfo_rows"
+
+type status =
+  | Uninitialised
+  | Bad_term
+  | Good_term
+
+let setup oc =
+  let term = try Sys.getenv "TERM" with Not_found -> "" in
+  (* Same heuristics as in Misc.Color.should_enable_color *)
+  if term <> "" && term <> "dumb" && isatty oc
+  then Good_term
+  else Bad_term
+
+let num_lines oc =
+  let rows = terminfo_rows oc in
+  if rows > 0 then rows else 24
+    (* 24 is a reasonable default for an ANSI-style terminal *)
+
+let backup oc n =
+  if n >= 1 then fprintf oc "\027[%dA%!" n
+
+let resume oc n =
+  if n >= 1 then fprintf oc "\027[%dB%!" n
+
+let standout oc b =
+  output_string oc (if b then "\027[4m" else "\027[0m"); flush oc
diff --git a/upstream/ocaml_412/utils/terminfo.mli b/upstream/ocaml_412/utils/terminfo.mli
new file mode 100644
index 0000000..10f5f54
--- /dev/null
+++ b/upstream/ocaml_412/utils/terminfo.mli
@@ -0,0 +1,32 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Basic interface to the terminfo database
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type status =
+  | Uninitialised
+  | Bad_term
+  | Good_term
+
+val setup : out_channel -> status
+val num_lines : out_channel -> int
+val backup : out_channel -> int -> unit
+val standout : out_channel -> bool -> unit
+val resume : out_channel -> int -> unit
diff --git a/upstream/ocaml_412/utils/warnings.ml b/upstream/ocaml_412/utils/warnings.ml
new file mode 100644
index 0000000..df2bb30
--- /dev/null
+++ b/upstream/ocaml_412/utils/warnings.ml
@@ -0,0 +1,914 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Pierre Weis && Damien Doligez, INRIA Rocquencourt          *)
+(*                                                                        *)
+(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* When you change this, you need to update:
+   - the list 'description' at the bottom of this file
+   - man/ocamlc.m
+*)
+
+type loc = {
+  loc_start: Lexing.position;
+  loc_end: Lexing.position;
+  loc_ghost: bool;
+}
+
+type t =
+  | Comment_start                           (*  1 *)
+  | Comment_not_end                         (*  2 *)
+(*| Deprecated --> alert "deprecated" *)    (*  3 *)
+  | Fragile_match of string                 (*  4 *)
+  | Ignored_partial_application             (*  5 *)
+  | Labels_omitted of string list           (*  6 *)
+  | Method_override of string list          (*  7 *)
+  | Partial_match of string                 (*  8 *)
+  | Missing_record_field_pattern of string  (*  9 *)
+  | Non_unit_statement                      (* 10 *)
+  | Redundant_case                          (* 11 *)
+  | Redundant_subpat                        (* 12 *)
+  | Instance_variable_override of string list (* 13 *)
+  | Illegal_backslash                       (* 14 *)
+  | Implicit_public_methods of string list  (* 15 *)
+  | Unerasable_optional_argument            (* 16 *)
+  | Undeclared_virtual_method of string     (* 17 *)
+  | Not_principal of string                 (* 18 *)
+  | Non_principal_labels of string          (* 19 *)
+  | Ignored_extra_argument                  (* 20 *)
+  | Nonreturning_statement                  (* 21 *)
+  | Preprocessor of string                  (* 22 *)
+  | Useless_record_with                     (* 23 *)
+  | Bad_module_name of string               (* 24 *)
+  | All_clauses_guarded                     (* 8, used to be 25 *)
+  | Unused_var of string                    (* 26 *)
+  | Unused_var_strict of string             (* 27 *)
+  | Wildcard_arg_to_constant_constr         (* 28 *)
+  | Eol_in_string                           (* 29 *)
+  | Duplicate_definitions of string * string * string * string (*30 *)
+  | Module_linked_twice of string * string * string (* 31 *)
+  | Unused_value_declaration of string      (* 32 *)
+  | Unused_open of string                   (* 33 *)
+  | Unused_type_declaration of string       (* 34 *)
+  | Unused_for_index of string              (* 35 *)
+  | Unused_ancestor of string               (* 36 *)
+  | Unused_constructor of string * bool * bool  (* 37 *)
+  | Unused_extension of string * bool * bool * bool (* 38 *)
+  | Unused_rec_flag                         (* 39 *)
+  | Name_out_of_scope of string * string list * bool (* 40 *)
+  | Ambiguous_name of string list * string list *  bool * string (* 41 *)
+  | Disambiguated_name of string            (* 42 *)
+  | Nonoptional_label of string             (* 43 *)
+  | Open_shadow_identifier of string * string (* 44 *)
+  | Open_shadow_label_constructor of string * string (* 45 *)
+  | Bad_env_variable of string * string     (* 46 *)
+  | Attribute_payload of string * string    (* 47 *)
+  | Eliminated_optional_arguments of string list (* 48 *)
+  | No_cmi_file of string * string option   (* 49 *)
+  | Unexpected_docstring of bool            (* 50 *)
+  | Wrong_tailcall_expectation of bool      (* 51 *)
+  | Fragile_literal_pattern                 (* 52 *)
+  | Misplaced_attribute of string           (* 53 *)
+  | Duplicated_attribute of string          (* 54 *)
+  | Inlining_impossible of string           (* 55 *)
+  | Unreachable_case                        (* 56 *)
+  | Ambiguous_var_in_pattern_guard of string list (* 57 *)
+  | No_cmx_file of string                   (* 58 *)
+  | Flambda_assignment_to_non_mutable_value (* 59 *)
+  | Unused_module of string                 (* 60 *)
+  | Unboxable_type_in_prim_decl of string   (* 61 *)
+  | Constraint_on_gadt                      (* 62 *)
+  | Erroneous_printed_signature of string   (* 63 *)
+  | Unsafe_array_syntax_without_parsing     (* 64 *)
+  | Redefining_unit of string               (* 65 *)
+  | Unused_open_bang of string              (* 66 *)
+  | Unused_functor_parameter of string      (* 67 *)
+  | Match_on_mutable_state_prevent_uncurry  (* 68 *)
+;;
+
+(* If you remove a warning, leave a hole in the numbering.  NEVER change
+   the numbers of existing warnings.
+   If you add a new warning, add it at the end with a new number;
+   do NOT reuse one of the holes.
+*)
+
+type alert = {kind:string; message:string; def:loc; use:loc}
+
+let number = function
+  | Comment_start -> 1
+  | Comment_not_end -> 2
+  | Fragile_match _ -> 4
+  | Ignored_partial_application -> 5
+  | Labels_omitted _ -> 6
+  | Method_override _ -> 7
+  | Partial_match _ -> 8
+  | Missing_record_field_pattern _ -> 9
+  | Non_unit_statement -> 10
+  | Redundant_case -> 11
+  | Redundant_subpat -> 12
+  | Instance_variable_override _ -> 13
+  | Illegal_backslash -> 14
+  | Implicit_public_methods _ -> 15
+  | Unerasable_optional_argument -> 16
+  | Undeclared_virtual_method _ -> 17
+  | Not_principal _ -> 18
+  | Non_principal_labels _ -> 19
+  | Ignored_extra_argument -> 20
+  | Nonreturning_statement -> 21
+  | Preprocessor _ -> 22
+  | Useless_record_with -> 23
+  | Bad_module_name _ -> 24
+  | All_clauses_guarded -> 8 (* used to be 25 *)
+  | Unused_var _ -> 26
+  | Unused_var_strict _ -> 27
+  | Wildcard_arg_to_constant_constr -> 28
+  | Eol_in_string -> 29
+  | Duplicate_definitions _ -> 30
+  | Module_linked_twice _ -> 31
+  | Unused_value_declaration _ -> 32
+  | Unused_open _ -> 33
+  | Unused_type_declaration _ -> 34
+  | Unused_for_index _ -> 35
+  | Unused_ancestor _ -> 36
+  | Unused_constructor _ -> 37
+  | Unused_extension _ -> 38
+  | Unused_rec_flag -> 39
+  | Name_out_of_scope _ -> 40
+  | Ambiguous_name _ -> 41
+  | Disambiguated_name _ -> 42
+  | Nonoptional_label _ -> 43
+  | Open_shadow_identifier _ -> 44
+  | Open_shadow_label_constructor _ -> 45
+  | Bad_env_variable _ -> 46
+  | Attribute_payload _ -> 47
+  | Eliminated_optional_arguments _ -> 48
+  | No_cmi_file _ -> 49
+  | Unexpected_docstring _ -> 50
+  | Wrong_tailcall_expectation _ -> 51
+  | Fragile_literal_pattern -> 52
+  | Misplaced_attribute _ -> 53
+  | Duplicated_attribute _ -> 54
+  | Inlining_impossible _ -> 55
+  | Unreachable_case -> 56
+  | Ambiguous_var_in_pattern_guard _ -> 57
+  | No_cmx_file _ -> 58
+  | Flambda_assignment_to_non_mutable_value -> 59
+  | Unused_module _ -> 60
+  | Unboxable_type_in_prim_decl _ -> 61
+  | Constraint_on_gadt -> 62
+  | Erroneous_printed_signature _ -> 63
+  | Unsafe_array_syntax_without_parsing -> 64
+  | Redefining_unit _ -> 65
+  | Unused_open_bang _ -> 66
+  | Unused_functor_parameter _ -> 67
+  | Match_on_mutable_state_prevent_uncurry -> 68
+;;
+
+let last_warning_number = 68
+;;
+
+(* Third component of each tuple is the list of names for each warning. The
+   first element of the list is the current name, any following ones are
+   deprecated. The current name should always be derived mechanically from the
+   constructor name. *)
+
+let descriptions =
+  [
+    1, "Suspicious-looking start-of-comment mark.",
+    ["comment-start"];
+    2, "Suspicious-looking end-of-comment mark.",
+    ["comment-not-end"];
+    3, "Deprecated synonym for the 'deprecated' alert.",
+    [];
+    4, "Fragile pattern matching: matching that will remain complete even\n\
+       \    if additional constructors are added to one of the variant types\n\
+       \    matched.",
+    ["fragile-match"];
+    5, "Partially applied function: expression whose result has function\n\
+       \    type and is ignored.",
+    ["ignored-partial-application"];
+    6, "Label omitted in function application.",
+    ["labels-omitted"];
+    7, "Method overridden.",
+    ["method-override"];
+    8, "Partial match: missing cases in pattern-matching.",
+    ["partial-match"];
+    9, "Missing fields in a record pattern.",
+    ["missing-record-field-pattern"];
+    10,
+    "Expression on the left-hand side of a sequence that doesn't have type\n\
+    \    \"unit\" (and that is not a function, see warning number 5).",
+    ["non-unit-statement"];
+    11, "Redundant case in a pattern matching (unused match case).",
+    ["redundant-case"];
+    12, "Redundant sub-pattern in a pattern-matching.",
+    ["redundant-subpat"];
+    13, "Instance variable overridden.",
+    ["instance-variable-override"];
+    14, "Illegal backslash escape in a string constant.",
+    ["illegal-backslash"];
+    15, "Private method made public implicitly.",
+    ["implicit-public-methods"];
+    16, "Unerasable optional argument.",
+    ["unerasable-optional-argument"];
+    17, "Undeclared virtual method.",
+    ["undeclared-virtual-method"];
+    18, "Non-principal type.",
+    ["not-principal"];
+    19, "Type without principality.",
+    ["non-principal-labels"];
+    20, "Unused function argument.",
+    ["ignored-extra-argument"];
+    21, "Non-returning statement.",
+    ["nonreturning-statement"];
+    22, "Preprocessor warning.",
+    ["preprocessor"];
+    23, "Useless record \"with\" clause.",
+    ["useless-record-with"];
+    24,
+    "Bad module name: the source file name is not a valid OCaml module name.",
+    ["bad-module-name"];
+    25, "Ignored: now part of warning 8.",
+    [];
+    26,
+    "Suspicious unused variable: unused variable that is bound\n\
+    \    with \"let\" or \"as\", and doesn't start with an underscore (\"_\")\n\
+    \    character.",
+    ["unused-var"];
+    27, "Innocuous unused variable: unused variable that is not bound with\n\
+        \    \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\
+        \    character.",
+    ["unused-var-strict"];
+    28, "Wildcard pattern given as argument to a constant constructor.",
+    ["wildcard-arg-to-constant-constr"];
+    29, "Unescaped end-of-line in a string constant (non-portable code).",
+    ["eol-in-string"];
+    30, "Two labels or constructors of the same name are defined in two\n\
+        \    mutually recursive types.",
+    ["duplicate-definitions"];
+    31, "A module is linked twice in the same executable.",
+    ["module-linked-twice"];
+    32, "Unused value declaration.",
+    ["unused-value-declaration"];
+    33, "Unused open statement.",
+    ["unused-open"];
+    34, "Unused type declaration.",
+    ["unused-type-declaration"];
+    35, "Unused for-loop index.",
+    ["unused-for-index"];
+    36, "Unused ancestor variable.",
+    ["unused-ancestor"];
+    37, "Unused constructor.",
+    ["unused-constructor"];
+    38, "Unused extension constructor.",
+    ["unused-extension"];
+    39, "Unused rec flag.",
+    ["unused-rec-flag"];
+    40, "Constructor or label name used out of scope.",
+    ["name-out-of-scope"];
+    41, "Ambiguous constructor or label name.",
+    ["ambiguous-name"];
+    42, "Disambiguated constructor or label name (compatibility warning).",
+    ["disambiguated-name"];
+    43, "Nonoptional label applied as optional.",
+    ["nonoptional-label"];
+    44, "Open statement shadows an already defined identifier.",
+    ["open-shadow-identifier"];
+    45, "Open statement shadows an already defined label or constructor.",
+    ["open-shadow-label-constructor"];
+    46, "Error in environment variable.",
+    ["bad-env-variable"];
+    47, "Illegal attribute payload.",
+    ["attribute-payload"];
+    48, "Implicit elimination of optional arguments.",
+    ["eliminated-optional-arguments"];
+    49, "Absent cmi file when looking up module alias.",
+    ["no-cmi-file"];
+    50, "Unexpected documentation comment.",
+    ["unexpected-docstring"];
+    51, "Function call annotated with an incorrect @tailcall attribute",
+    ["wrong-tailcall-expectation"];
+    52, "Fragile constant pattern.",
+    ["fragile-literal-pattern"];
+    53, "Attribute cannot appear in this context.",
+    ["misplaced-attribute"];
+    54, "Attribute used more than once on an expression.",
+    ["duplicated-attribute"];
+    55, "Inlining impossible.",
+    ["inlining-impossible"];
+    56, "Unreachable case in a pattern-matching (based on type information).",
+    ["unreachable-case"];
+    57, "Ambiguous or-pattern variables under guard.",
+    ["ambiguous-var-in-pattern-guard"];
+    58, "Missing cmx file.",
+    ["no-cmx-file"];
+    59, "Assignment to non-mutable value.",
+    ["flambda-assignment-to-non-mutable-value"];
+    60, "Unused module declaration.",
+    ["unused-module"];
+    61, "Unboxable type in primitive declaration.",
+    ["unboxable-type-in-prim-decl"];
+    62, "Type constraint on GADT type declaration.",
+    ["constraint-on-gadt"];
+    63, "Erroneous printed signature.",
+    ["erroneous-printed-signature"];
+    64, "-unsafe used with a preprocessor returning a syntax tree.",
+    ["unsafe-array-syntax-without-parsing"];
+    65, "Type declaration defining a new '()' constructor.",
+    ["redefining-unit"];
+    66, "Unused open! statement.",
+    ["unused-open-bang"];
+    67, "Unused functor parameter.",
+    ["unused-functor-parameter"];
+    68, "Pattern-matching depending on mutable state prevents the remaining \
+         arguments from being uncurried.",
+    ["match-on-mutable-state-prevent-uncurry"];
+  ]
+;;
+
+let name_to_number =
+  let h = Hashtbl.create last_warning_number in
+  List.iter (fun (num, _, names) ->
+      List.iter (fun name -> Hashtbl.add h name num) names
+    ) descriptions;
+  fun s -> Hashtbl.find_opt h s
+;;
+
+(* Must be the max number returned by the [number] function. *)
+
+let letter = function
+  | 'a' ->
+     let rec loop i = if i = 0 then [] else i :: loop (i - 1) in
+     loop last_warning_number
+  | 'b' -> []
+  | 'c' -> [1; 2]
+  | 'd' -> [3]
+  | 'e' -> [4]
+  | 'f' -> [5]
+  | 'g' -> []
+  | 'h' -> []
+  | 'i' -> []
+  | 'j' -> []
+  | 'k' -> [32; 33; 34; 35; 36; 37; 38; 39]
+  | 'l' -> [6]
+  | 'm' -> [7]
+  | 'n' -> []
+  | 'o' -> []
+  | 'p' -> [8]
+  | 'q' -> []
+  | 'r' -> [9]
+  | 's' -> [10]
+  | 't' -> []
+  | 'u' -> [11; 12]
+  | 'v' -> [13]
+  | 'w' -> []
+  | 'x' -> [14; 15; 16; 17; 18; 19; 20; 21; 22; 23; 24; 30]
+  | 'y' -> [26]
+  | 'z' -> [27]
+  | _ -> assert false
+;;
+
+type state =
+  {
+    active: bool array;
+    error: bool array;
+    alerts: (Misc.Stdlib.String.Set.t * bool); (* false:set complement *)
+    alert_errors: (Misc.Stdlib.String.Set.t * bool); (* false:set complement *)
+  }
+
+let current =
+  ref
+    {
+      active = Array.make (last_warning_number + 1) true;
+      error = Array.make (last_warning_number + 1) false;
+      alerts = (Misc.Stdlib.String.Set.empty, false); (* all enabled *)
+      alert_errors = (Misc.Stdlib.String.Set.empty, true); (* all soft *)
+    }
+
+let disabled = ref false
+
+let without_warnings f =
+  Misc.protect_refs [Misc.R(disabled, true)] f
+
+let backup () = !current
+
+let restore x = current := x
+
+let is_active x =
+  not !disabled && (!current).active.(number x)
+
+let is_error x =
+  not !disabled && (!current).error.(number x)
+
+let alert_is_active {kind; _} =
+  not !disabled &&
+  let (set, pos) = (!current).alerts in
+  Misc.Stdlib.String.Set.mem kind set = pos
+
+let alert_is_error {kind; _} =
+  not !disabled &&
+  let (set, pos) = (!current).alert_errors in
+  Misc.Stdlib.String.Set.mem kind set = pos
+
+let mk_lazy f =
+  let state = backup () in
+  lazy
+    (
+      let prev = backup () in
+      restore state;
+      try
+        let r = f () in
+        restore prev;
+        r
+      with exn ->
+        restore prev;
+        raise exn
+    )
+
+let set_alert ~error ~enable s =
+  let upd =
+    match s with
+    | "all" ->
+        (Misc.Stdlib.String.Set.empty, not enable)
+    | s ->
+        let (set, pos) =
+          if error then (!current).alert_errors else (!current).alerts
+        in
+        let f =
+          if enable = pos
+          then Misc.Stdlib.String.Set.add
+          else Misc.Stdlib.String.Set.remove
+        in
+        (f s set, pos)
+  in
+  if error then
+    current := {(!current) with alert_errors=upd}
+  else
+    current := {(!current) with alerts=upd}
+
+let parse_alert_option s =
+  let n = String.length s in
+  let id_char = function
+    | 'a'..'z' | 'A'..'Z' | '_' | '\'' | '0'..'9' -> true
+    | _ -> false
+  in
+  let rec parse_id i =
+    if i < n && id_char s.[i] then parse_id (i + 1) else i
+  in
+  let rec scan i =
+    if i = n then ()
+    else if i + 1 = n then raise (Arg.Bad "Ill-formed list of alert settings")
+    else match s.[i], s.[i+1] with
+      | '+', '+' -> id (set_alert ~error:true ~enable:true) (i + 2)
+      | '+', _ -> id (set_alert ~error:false ~enable:true) (i + 1)
+      | '-', '-' -> id (set_alert ~error:true ~enable:false) (i + 2)
+      | '-', _ -> id (set_alert ~error:false ~enable:false) (i + 1)
+      | '@', _ ->
+          id (fun s ->
+              set_alert ~error:true ~enable:true s;
+              set_alert ~error:false ~enable:true s)
+            (i + 1)
+      | _ -> raise (Arg.Bad "Ill-formed list of alert settings")
+  and id f i =
+    let j = parse_id i in
+    if j = i then raise (Arg.Bad "Ill-formed list of alert settings");
+    let id = String.sub s i (j - i) in
+    f id;
+    scan j
+  in
+  scan 0
+
+let parse_opt error active errflag s =
+  let flags = if errflag then error else active in
+  let set i =
+    if i = 3 then set_alert ~error:errflag ~enable:true "deprecated"
+    else flags.(i) <- true
+  in
+  let clear i =
+    if i = 3 then set_alert ~error:errflag ~enable:false "deprecated"
+    else flags.(i) <- false
+  in
+  let set_all i =
+    if i = 3 then begin
+      set_alert ~error:false ~enable:true "deprecated";
+      set_alert ~error:true ~enable:true "deprecated"
+    end
+    else begin
+      active.(i) <- true;
+      error.(i) <- true
+    end
+  in
+  let error () = raise (Arg.Bad "Ill-formed list of warnings") in
+  let rec get_num n i =
+    if i >= String.length s then i, n
+    else match s.[i] with
+    | '0'..'9' -> get_num (10 * n + Char.code s.[i] - Char.code '0') (i + 1)
+    | _ -> i, n
+  in
+  let get_range i =
+    let i, n1 = get_num 0 i in
+    if i + 2 < String.length s && s.[i] = '.' && s.[i + 1] = '.' then
+      let i, n2 = get_num 0 (i + 2) in
+      if n2 < n1 then error ();
+      i, n1, n2
+    else
+      i, n1, n1
+  in
+  let rec loop i =
+    if i >= String.length s then () else
+    match s.[i] with
+    | 'A' .. 'Z' ->
+       List.iter set (letter (Char.lowercase_ascii s.[i]));
+       loop (i+1)
+    | 'a' .. 'z' ->
+       List.iter clear (letter s.[i]);
+       loop (i+1)
+    | '+' -> loop_letter_num set (i+1)
+    | '-' -> loop_letter_num clear (i+1)
+    | '@' -> loop_letter_num set_all (i+1)
+    | _ -> error ()
+  and loop_letter_num myset i =
+    if i >= String.length s then error () else
+    match s.[i] with
+    | '0' .. '9' ->
+        let i, n1, n2 = get_range i in
+        for n = n1 to min n2 last_warning_number do myset n done;
+        loop i
+    | 'A' .. 'Z' ->
+       List.iter myset (letter (Char.lowercase_ascii s.[i]));
+       loop (i+1)
+    | 'a' .. 'z' ->
+       List.iter myset (letter s.[i]);
+       loop (i+1)
+    | _ -> error ()
+  in
+  match name_to_number s with
+  | Some n -> set n
+  | None ->
+      if s = "" then loop 0
+      else begin
+        let rest = String.sub s 1 (String.length s - 1) in
+        match s.[0], name_to_number rest with
+        | '+', Some n -> set n
+        | '-', Some n -> clear n
+        | '@', Some n -> set_all n
+        | _ -> loop 0
+      end
+;;
+
+let parse_options errflag s =
+  let error = Array.copy (!current).error in
+  let active = Array.copy (!current).active in
+  parse_opt error active errflag s;
+  current := {(!current) with error; active}
+
+(* If you change these, don't forget to change them in man/ocamlc.m *)
+let defaults_w = "+a-4-6-7-9-27-29-30-32..42-44-45-48-50-60-66-67-68";;
+let defaults_warn_error = "-a+31";;
+
+let () = parse_options false defaults_w;;
+let () = parse_options true defaults_warn_error;;
+
+let ref_manual_explanation () =
+  (* manual references are checked a posteriori by the manual
+     cross-reference consistency check in manual/tests*)
+  let[@manual.ref "s:comp-warnings"] chapter, section = 9, 5 in
+  Printf.sprintf "(See manual section %d.%d)" chapter section
+
+let message = function
+  | Comment_start ->
+      "this `(*' is the start of a comment.\n\
+       Hint: Did you forget spaces when writing the infix operator `( * )'?"
+  | Comment_not_end -> "this is not the end of a comment."
+  | Fragile_match "" ->
+      "this pattern-matching is fragile."
+  | Fragile_match s ->
+      "this pattern-matching is fragile.\n\
+       It will remain exhaustive when constructors are added to type " ^ s ^ "."
+  | Ignored_partial_application ->
+      "this function application is partial,\n\
+       maybe some arguments are missing."
+  | Labels_omitted [] -> assert false
+  | Labels_omitted [l] ->
+     "label " ^ l ^ " was omitted in the application of this function."
+  | Labels_omitted ls ->
+     "labels " ^ String.concat ", " ls ^
+       " were omitted in the application of this function."
+  | Method_override [lab] ->
+      "the method " ^ lab ^ " is overridden."
+  | Method_override (cname :: slist) ->
+      String.concat " "
+        ("the following methods are overridden by the class"
+         :: cname  :: ":\n " :: slist)
+  | Method_override [] -> assert false
+  | Partial_match "" -> "this pattern-matching is not exhaustive."
+  | Partial_match s ->
+      "this pattern-matching is not exhaustive.\n\
+       Here is an example of a case that is not matched:\n" ^ s
+  | Missing_record_field_pattern s ->
+      "the following labels are not bound in this record pattern:\n" ^ s ^
+      "\nEither bind these labels explicitly or add '; _' to the pattern."
+  | Non_unit_statement ->
+      "this expression should have type unit."
+  | Redundant_case -> "this match case is unused."
+  | Redundant_subpat -> "this sub-pattern is unused."
+  | Instance_variable_override [lab] ->
+      "the instance variable " ^ lab ^ " is overridden.\n" ^
+      "The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)"
+  | Instance_variable_override (cname :: slist) ->
+      String.concat " "
+        ("the following instance variables are overridden by the class"
+         :: cname  :: ":\n " :: slist) ^
+      "\nThe behaviour changed in ocaml 3.10 (previous behaviour was hiding.)"
+  | Instance_variable_override [] -> assert false
+  | Illegal_backslash -> "illegal backslash escape in string."
+  | Implicit_public_methods l ->
+      "the following private methods were made public implicitly:\n "
+      ^ String.concat " " l ^ "."
+  | Unerasable_optional_argument -> "this optional argument cannot be erased."
+  | Undeclared_virtual_method m -> "the virtual method "^m^" is not declared."
+  | Not_principal s -> s^" is not principal."
+  | Non_principal_labels s -> s^" without principality."
+  | Ignored_extra_argument -> "this argument will not be used by the function."
+  | Nonreturning_statement ->
+      "this statement never returns (or has an unsound type.)"
+  | Preprocessor s -> s
+  | Useless_record_with ->
+      "all the fields are explicitly listed in this record:\n\
+       the 'with' clause is useless."
+  | Bad_module_name (modname) ->
+      "bad source file name: \"" ^ modname ^ "\" is not a valid module name."
+  | All_clauses_guarded ->
+      "this pattern-matching is not exhaustive.\n\
+       All clauses in this pattern-matching are guarded."
+  | Unused_var v | Unused_var_strict v -> "unused variable " ^ v ^ "."
+  | Wildcard_arg_to_constant_constr ->
+     "wildcard pattern given as argument to a constant constructor"
+  | Eol_in_string ->
+     "unescaped end-of-line in a string constant (non-portable code)"
+  | Duplicate_definitions (kind, cname, tc1, tc2) ->
+      Printf.sprintf "the %s %s is defined in both types %s and %s."
+        kind cname tc1 tc2
+  | Module_linked_twice(modname, file1, file2) ->
+      Printf.sprintf
+        "files %s and %s both define a module named %s"
+        file1 file2 modname
+  | Unused_value_declaration v -> "unused value " ^ v ^ "."
+  | Unused_open s -> "unused open " ^ s ^ "."
+  | Unused_open_bang s -> "unused open! " ^ s ^ "."
+  | Unused_type_declaration s -> "unused type " ^ s ^ "."
+  | Unused_for_index s -> "unused for-loop index " ^ s ^ "."
+  | Unused_ancestor s -> "unused ancestor variable " ^ s ^ "."
+  | Unused_constructor (s, false, false) -> "unused constructor " ^ s ^ "."
+  | Unused_constructor (s, true, _) ->
+      "constructor " ^ s ^
+      " is never used to build values.\n\
+        (However, this constructor appears in patterns.)"
+  | Unused_constructor (s, false, true) ->
+      "constructor " ^ s ^
+      " is never used to build values.\n\
+        Its type is exported as a private type."
+  | Unused_extension (s, is_exception, cu_pattern, cu_privatize) ->
+     let kind =
+       if is_exception then "exception" else "extension constructor" in
+     let name = kind ^ " " ^ s in
+     begin match cu_pattern, cu_privatize with
+       | false, false -> "unused " ^ name
+       | true, _ ->
+          name ^
+          " is never used to build values.\n\
+           (However, this constructor appears in patterns.)"
+       | false, true ->
+          name ^
+          " is never used to build values.\n\
+            It is exported or rebound as a private extension."
+     end
+  | Unused_rec_flag ->
+      "unused rec flag."
+  | Name_out_of_scope (ty, [nm], false) ->
+      nm ^ " was selected from type " ^ ty ^
+      ".\nIt is not visible in the current scope, and will not \n\
+       be selected if the type becomes unknown."
+  | Name_out_of_scope (_, _, false) -> assert false
+  | Name_out_of_scope (ty, slist, true) ->
+      "this record of type "^ ty ^" contains fields that are \n\
+       not visible in the current scope: "
+      ^ String.concat " " slist ^ ".\n\
+       They will not be selected if the type becomes unknown."
+  | Ambiguous_name ([s], tl, false, expansion) ->
+      s ^ " belongs to several types: " ^ String.concat " " tl ^
+      "\nThe first one was selected. Please disambiguate if this is wrong."
+      ^ expansion
+  | Ambiguous_name (_, _, false, _ ) -> assert false
+  | Ambiguous_name (_slist, tl, true, expansion) ->
+      "these field labels belong to several types: " ^
+      String.concat " " tl ^
+      "\nThe first one was selected. Please disambiguate if this is wrong."
+      ^ expansion
+  | Disambiguated_name s ->
+      "this use of " ^ s ^ " relies on type-directed disambiguation,\n\
+       it will not compile with OCaml 4.00 or earlier."
+  | Nonoptional_label s ->
+      "the label " ^ s ^ " is not optional."
+  | Open_shadow_identifier (kind, s) ->
+      Printf.sprintf
+        "this open statement shadows the %s identifier %s (which is later used)"
+        kind s
+  | Open_shadow_label_constructor (kind, s) ->
+      Printf.sprintf
+        "this open statement shadows the %s %s (which is later used)"
+        kind s
+  | Bad_env_variable (var, s) ->
+      Printf.sprintf "illegal environment variable %s : %s" var s
+  | Attribute_payload (a, s) ->
+      Printf.sprintf "illegal payload for attribute '%s'.\n%s" a s
+  | Eliminated_optional_arguments sl ->
+      Printf.sprintf "implicit elimination of optional argument%s %s"
+        (if List.length sl = 1 then "" else "s")
+        (String.concat ", " sl)
+  | No_cmi_file(name, None) ->
+      "no cmi file was found in path for module " ^ name
+  | No_cmi_file(name, Some msg) ->
+      Printf.sprintf
+        "no valid cmi file was found in path for module %s. %s"
+        name msg
+  | Unexpected_docstring unattached ->
+      if unattached then "unattached documentation comment (ignored)"
+      else "ambiguous documentation comment"
+  | Wrong_tailcall_expectation b ->
+      Printf.sprintf "expected %s"
+        (if b then "tailcall" else "non-tailcall")
+  | Fragile_literal_pattern ->
+      Printf.sprintf
+        "Code should not depend on the actual values of\n\
+         this constructor's arguments. They are only for information\n\
+         and may change in future versions. %t" ref_manual_explanation
+  | Unreachable_case ->
+      "this match case is unreachable.\n\
+       Consider replacing it with a refutation case '<pat> -> .'"
+  | Misplaced_attribute attr_name ->
+      Printf.sprintf "the %S attribute cannot appear in this context" attr_name
+  | Duplicated_attribute attr_name ->
+      Printf.sprintf "the %S attribute is used more than once on this \
+          expression"
+        attr_name
+  | Inlining_impossible reason ->
+      Printf.sprintf "Cannot inline: %s" reason
+  | Ambiguous_var_in_pattern_guard vars ->
+      let msg =
+        let vars = List.sort String.compare vars in
+        match vars with
+        | [] -> assert false
+        | [x] -> "variable " ^ x
+        | _::_ ->
+            "variables " ^ String.concat "," vars in
+      Printf.sprintf
+        "Ambiguous or-pattern variables under guard;\n\
+         %s may match different arguments. %t"
+        msg ref_manual_explanation
+  | No_cmx_file name ->
+      Printf.sprintf
+        "no cmx file was found in path for module %s, \
+         and its interface was not compiled with -opaque" name
+  | Flambda_assignment_to_non_mutable_value ->
+      "A potential assignment to a non-mutable value was detected \n\
+        in this source file.  Such assignments may generate incorrect code \n\
+        when using Flambda."
+  | Unused_module s -> "unused module " ^ s ^ "."
+  | Unboxable_type_in_prim_decl t ->
+      Printf.sprintf
+        "This primitive declaration uses type %s, whose representation\n\
+         may be either boxed or unboxed. Without an annotation to indicate\n\
+         which representation is intended, the boxed representation has been\n\
+         selected by default. This default choice may change in future\n\
+         versions of the compiler, breaking the primitive implementation.\n\
+         You should explicitly annotate the declaration of %s\n\
+         with [@@boxed] or [@@unboxed], so that its external interface\n\
+         remains stable in the future." t t
+  | Constraint_on_gadt ->
+      "Type constraints do not apply to GADT cases of variant types."
+  | Erroneous_printed_signature s ->
+      "The printed interface differs from the inferred interface.\n\
+       The inferred interface contained items which could not be printed\n\
+       properly due to name collisions between identifiers."
+     ^ s
+     ^ "\nBeware that this warning is purely informational and will not catch\n\
+        all instances of erroneous printed interface."
+  | Unsafe_array_syntax_without_parsing ->
+     "option -unsafe used with a preprocessor returning a syntax tree"
+  | Redefining_unit name ->
+      Printf.sprintf
+        "This type declaration is defining a new '()' constructor\n\
+         which shadows the existing one.\n\
+         Hint: Did you mean 'type %s = unit'?" name
+  | Unused_functor_parameter s -> "unused functor parameter " ^ s ^ "."
+  | Match_on_mutable_state_prevent_uncurry ->
+    "This pattern depends on mutable state.\n\
+     It prevents the remaining arguments from being uncurried, which will \
+     cause additional closure allocations."
+;;
+
+let nerrors = ref 0;;
+
+type reporting_information =
+  { id : string
+  ; message : string
+  ; is_error : bool
+  ; sub_locs : (loc * string) list;
+  }
+
+let id_name w =
+  let n = number w in
+  match List.find_opt (fun (m, _, _) -> m = n) descriptions with
+  | Some (_, _, s :: _) ->
+      Printf.sprintf "%d [%s]" n s
+  | _ ->
+      string_of_int n
+
+let report w =
+  match is_active w with
+  | false -> `Inactive
+  | true ->
+     if is_error w then incr nerrors;
+     `Active
+       { id = id_name w;
+         message = message w;
+         is_error = is_error w;
+         sub_locs = [];
+       }
+
+let report_alert (alert : alert) =
+  match alert_is_active alert with
+  | false -> `Inactive
+  | true ->
+      let is_error = alert_is_error alert in
+      if is_error then incr nerrors;
+      let message = Misc.normalise_eol alert.message in
+       (* Reduce \r\n to \n:
+           - Prevents any \r characters being printed on Unix when processing
+             Windows sources
+           - Prevents \r\r\n being generated on Windows, which affects the
+             testsuite
+       *)
+      let sub_locs =
+        if not alert.def.loc_ghost && not alert.use.loc_ghost then
+          [
+            alert.def, "Definition";
+            alert.use, "Expected signature";
+          ]
+        else
+          []
+      in
+      `Active
+        {
+          id = alert.kind;
+          message;
+          is_error;
+          sub_locs;
+        }
+
+exception Errors;;
+
+let reset_fatal () =
+  nerrors := 0
+
+let check_fatal () =
+  if !nerrors > 0 then begin
+    nerrors := 0;
+    raise Errors;
+  end;
+;;
+
+let help_warnings () =
+  List.iter
+    (fun (i, s, names) ->
+       let name =
+         match names with
+         | s :: _ -> " [" ^ s ^ "]"
+         | [] -> ""
+       in
+       Printf.printf "%3i%s %s\n" i name s)
+    descriptions;
+  print_endline "  A all warnings";
+  for i = Char.code 'b' to Char.code 'z' do
+    let c = Char.chr i in
+    match letter c with
+    | [] -> ()
+    | [n] ->
+        Printf.printf "  %c Alias for warning %i.\n" (Char.uppercase_ascii c) n
+    | l ->
+        Printf.printf "  %c warnings %s.\n"
+          (Char.uppercase_ascii c)
+          (String.concat ", " (List.map Int.to_string l))
+  done;
+  exit 0
+;;
diff --git a/upstream/ocaml_412/utils/warnings.mli b/upstream/ocaml_412/utils/warnings.mli
new file mode 100644
index 0000000..c94ea72
--- /dev/null
+++ b/upstream/ocaml_412/utils/warnings.mli
@@ -0,0 +1,141 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Pierre Weis && Damien Doligez, INRIA Rocquencourt          *)
+(*                                                                        *)
+(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Warning definitions
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type loc = {
+  loc_start: Lexing.position;
+  loc_end: Lexing.position;
+  loc_ghost: bool;
+}
+
+type t =
+  | Comment_start                           (*  1 *)
+  | Comment_not_end                         (*  2 *)
+(*| Deprecated --> alert "deprecated" *)    (*  3 *)
+  | Fragile_match of string                 (*  4 *)
+  | Ignored_partial_application             (*  5 *)
+  | Labels_omitted of string list           (*  6 *)
+  | Method_override of string list          (*  7 *)
+  | Partial_match of string                 (*  8 *)
+  | Missing_record_field_pattern of string  (*  9 *)
+  | Non_unit_statement                      (* 10 *)
+  | Redundant_case                          (* 11 *)
+  | Redundant_subpat                        (* 12 *)
+  | Instance_variable_override of string list (* 13 *)
+  | Illegal_backslash                       (* 14 *)
+  | Implicit_public_methods of string list  (* 15 *)
+  | Unerasable_optional_argument            (* 16 *)
+  | Undeclared_virtual_method of string     (* 17 *)
+  | Not_principal of string                 (* 18 *)
+  | Non_principal_labels of string          (* 19 *)
+  | Ignored_extra_argument                  (* 20 *)
+  | Nonreturning_statement                  (* 21 *)
+  | Preprocessor of string                  (* 22 *)
+  | Useless_record_with                     (* 23 *)
+  | Bad_module_name of string               (* 24 *)
+  | All_clauses_guarded                     (* 8, used to be 25 *)
+  | Unused_var of string                    (* 26 *)
+  | Unused_var_strict of string             (* 27 *)
+  | Wildcard_arg_to_constant_constr         (* 28 *)
+  | Eol_in_string                           (* 29 *)
+  | Duplicate_definitions of string * string * string * string (* 30 *)
+  | Module_linked_twice of string * string * string (* 31 *)
+  | Unused_value_declaration of string      (* 32 *)
+  | Unused_open of string                   (* 33 *)
+  | Unused_type_declaration of string       (* 34 *)
+  | Unused_for_index of string              (* 35 *)
+  | Unused_ancestor of string               (* 36 *)
+  | Unused_constructor of string * bool * bool (* 37 *)
+  | Unused_extension of string * bool * bool * bool (* 38 *)
+  | Unused_rec_flag                         (* 39 *)
+  | Name_out_of_scope of string * string list * bool   (* 40 *)
+  | Ambiguous_name of string list * string list * bool * string (* 41 *)
+  | Disambiguated_name of string            (* 42 *)
+  | Nonoptional_label of string             (* 43 *)
+  | Open_shadow_identifier of string * string (* 44 *)
+  | Open_shadow_label_constructor of string * string (* 45 *)
+  | Bad_env_variable of string * string     (* 46 *)
+  | Attribute_payload of string * string    (* 47 *)
+  | Eliminated_optional_arguments of string list (* 48 *)
+  | No_cmi_file of string * string option   (* 49 *)
+  | Unexpected_docstring of bool            (* 50 *)
+  | Wrong_tailcall_expectation of bool      (* 51 *)
+  | Fragile_literal_pattern                 (* 52 *)
+  | Misplaced_attribute of string           (* 53 *)
+  | Duplicated_attribute of string          (* 54 *)
+  | Inlining_impossible of string           (* 55 *)
+  | Unreachable_case                        (* 56 *)
+  | Ambiguous_var_in_pattern_guard of string list (* 57 *)
+  | No_cmx_file of string                   (* 58 *)
+  | Flambda_assignment_to_non_mutable_value (* 59 *)
+  | Unused_module of string                 (* 60 *)
+  | Unboxable_type_in_prim_decl of string   (* 61 *)
+  | Constraint_on_gadt                      (* 62 *)
+  | Erroneous_printed_signature of string   (* 63 *)
+  | Unsafe_array_syntax_without_parsing     (* 64 *)
+  | Redefining_unit of string               (* 65 *)
+  | Unused_open_bang of string              (* 66 *)
+  | Unused_functor_parameter of string      (* 67 *)
+  | Match_on_mutable_state_prevent_uncurry  (* 68 *)
+;;
+
+type alert = {kind:string; message:string; def:loc; use:loc}
+
+val parse_options : bool -> string -> unit;;
+
+val parse_alert_option: string -> unit
+  (** Disable/enable alerts based on the parameter to the -alert
+      command-line option.  Raises [Arg.Bad] if the string is not a
+      valid specification.
+  *)
+
+val without_warnings : (unit -> 'a) -> 'a
+  (** Run the thunk with all warnings and alerts disabled. *)
+
+val is_active : t -> bool;;
+val is_error : t -> bool;;
+
+val defaults_w : string;;
+val defaults_warn_error : string;;
+
+type reporting_information =
+  { id : string
+  ; message : string
+  ; is_error : bool
+  ; sub_locs : (loc * string) list;
+  }
+
+val report : t -> [ `Active of reporting_information | `Inactive ]
+val report_alert : alert -> [ `Active of reporting_information | `Inactive ]
+
+exception Errors;;
+
+val check_fatal : unit -> unit;;
+val reset_fatal: unit -> unit
+
+val help_warnings: unit -> unit
+
+type state
+val backup: unit -> state
+val restore: state -> unit
+val mk_lazy: (unit -> 'a) -> 'a Lazy.t
+    (** Like [Lazy.of_fun], but the function is applied with
+        the warning/alert settings at the time [mk_lazy] is called. *)
diff --git a/upstream/ocaml_413/base-rev.txt b/upstream/ocaml_413/base-rev.txt
new file mode 100644
index 0000000..d9edb88
--- /dev/null
+++ b/upstream/ocaml_413/base-rev.txt
@@ -0,0 +1 @@
+d94fc6055b1b3f501282b95c90f16f20d2e0f5fb
diff --git a/upstream/ocaml_413/file_formats/cmi_format.ml b/upstream/ocaml_413/file_formats/cmi_format.ml
new file mode 100644
index 0000000..eadf676
--- /dev/null
+++ b/upstream/ocaml_413/file_formats/cmi_format.ml
@@ -0,0 +1,118 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Misc
+
+type pers_flags =
+  | Rectypes
+  | Alerts of alerts
+  | Opaque
+  | Unsafe_string
+
+type error =
+  | Not_an_interface of filepath
+  | Wrong_version_interface of filepath * string
+  | Corrupted_interface of filepath
+
+exception Error of error
+
+(* these type abbreviations are not exported;
+   they are used to provide consistency across
+   input_value and output_value usage. *)
+type signature = Types.signature_item list
+type flags = pers_flags list
+type header = modname * signature
+
+type cmi_infos = {
+    cmi_name : modname;
+    cmi_sign : signature;
+    cmi_crcs : crcs;
+    cmi_flags : flags;
+}
+
+let input_cmi ic =
+  let (name, sign) = (input_value ic : header) in
+  let crcs = (input_value ic : crcs) in
+  let flags = (input_value ic : flags) in
+  {
+      cmi_name = name;
+      cmi_sign = sign;
+      cmi_crcs = crcs;
+      cmi_flags = flags;
+    }
+
+let read_cmi filename =
+  let ic = open_in_bin filename in
+  try
+    let buffer =
+      really_input_string ic (String.length Config.cmi_magic_number)
+    in
+    if buffer <> Config.cmi_magic_number then begin
+      close_in ic;
+      let pre_len = String.length Config.cmi_magic_number - 3 in
+      if String.sub buffer 0 pre_len
+          = String.sub Config.cmi_magic_number 0 pre_len then
+      begin
+        let msg =
+          if buffer < Config.cmi_magic_number then "an older" else "a newer" in
+        raise (Error (Wrong_version_interface (filename, msg)))
+      end else begin
+        raise(Error(Not_an_interface filename))
+      end
+    end;
+    let cmi = input_cmi ic in
+    close_in ic;
+    cmi
+  with End_of_file | Failure _ ->
+      close_in ic;
+      raise(Error(Corrupted_interface(filename)))
+    | Error e ->
+      close_in ic;
+      raise (Error e)
+
+let output_cmi filename oc cmi =
+(* beware: the provided signature must have been substituted for saving *)
+  output_string oc Config.cmi_magic_number;
+  output_value oc ((cmi.cmi_name, cmi.cmi_sign) : header);
+  flush oc;
+  let crc = Digest.file filename in
+  let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in
+  output_value oc (crcs : crcs);
+  output_value oc (cmi.cmi_flags : flags);
+  crc
+
+(* Error report *)
+
+open Format
+
+let report_error ppf = function
+  | Not_an_interface filename ->
+      fprintf ppf "%a@ is not a compiled interface"
+        Location.print_filename filename
+  | Wrong_version_interface (filename, older_newer) ->
+      fprintf ppf
+        "%a@ is not a compiled interface for this version of OCaml.@.\
+         It seems to be for %s version of OCaml."
+        Location.print_filename filename older_newer
+  | Corrupted_interface filename ->
+      fprintf ppf "Corrupted compiled interface@ %a"
+        Location.print_filename filename
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )
diff --git a/upstream/ocaml_413/file_formats/cmi_format.mli b/upstream/ocaml_413/file_formats/cmi_format.mli
new file mode 100644
index 0000000..d4d665f
--- /dev/null
+++ b/upstream/ocaml_413/file_formats/cmi_format.mli
@@ -0,0 +1,51 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Misc
+
+type pers_flags =
+  | Rectypes
+  | Alerts of alerts
+  | Opaque
+  | Unsafe_string
+
+type cmi_infos = {
+    cmi_name : modname;
+    cmi_sign : Types.signature_item list;
+    cmi_crcs : crcs;
+    cmi_flags : pers_flags list;
+}
+
+(* write the magic + the cmi information *)
+val output_cmi : string -> out_channel -> cmi_infos -> Digest.t
+
+(* read the cmi information (the magic is supposed to have already been read) *)
+val input_cmi : in_channel -> cmi_infos
+
+(* read a cmi from a filename, checking the magic *)
+val read_cmi : string -> cmi_infos
+
+(* Error report *)
+
+type error =
+  | Not_an_interface of filepath
+  | Wrong_version_interface of filepath * string
+  | Corrupted_interface of filepath
+
+exception Error of error
+
+open Format
+
+val report_error: formatter -> error -> unit
diff --git a/upstream/ocaml_413/file_formats/cmo_format.mli b/upstream/ocaml_413/file_formats/cmo_format.mli
new file mode 100644
index 0000000..0952157
--- /dev/null
+++ b/upstream/ocaml_413/file_formats/cmo_format.mli
@@ -0,0 +1,68 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2006 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Symbol table information for .cmo and .cma files *)
+
+open Misc
+
+(* Relocation information *)
+
+type reloc_info =
+    Reloc_literal of Lambda.structured_constant    (* structured constant *)
+  | Reloc_getglobal of Ident.t              (* reference to a global *)
+  | Reloc_setglobal of Ident.t              (* definition of a global *)
+  | Reloc_primitive of string               (* C primitive number *)
+
+(* Descriptor for compilation units *)
+
+type compilation_unit =
+  { cu_name: modname;                   (* Name of compilation unit *)
+    mutable cu_pos: int;                (* Absolute position in file *)
+    cu_codesize: int;                   (* Size of code block *)
+    cu_reloc: (reloc_info * int) list;  (* Relocation information *)
+    cu_imports: crcs;                   (* Names and CRC of intfs imported *)
+    cu_required_globals: Ident.t list;  (* Compilation units whose
+                                           initialization side effects
+                                           must occur before this one. *)
+    cu_primitives: string list;         (* Primitives declared inside *)
+    mutable cu_force_link: bool;        (* Must be linked even if unref'ed *)
+    mutable cu_debug: int;              (* Position of debugging info, or 0 *)
+    cu_debugsize: int }                 (* Length of debugging info *)
+
+(* Format of a .cmo file:
+     magic number (Config.cmo_magic_number)
+     absolute offset of compilation unit descriptor
+     block of relocatable bytecode
+     debugging information if any
+     compilation unit descriptor *)
+
+(* Descriptor for libraries *)
+
+type library =
+  { lib_units: compilation_unit list;   (* List of compilation units *)
+    lib_custom: bool;                   (* Requires custom mode linking? *)
+    (* In the following fields the lists are reversed with respect to
+       how they end up being used on the command line. *)
+    lib_ccobjs: string list;            (* C object files needed for -custom *)
+    lib_ccopts: string list;            (* Extra opts to C compiler *)
+    lib_dllibs: string list }           (* DLLs needed *)
+
+(* Format of a .cma file:
+     magic number (Config.cma_magic_number)
+     absolute offset of library descriptor
+     object code for first library member
+     ...
+     object code for last library member
+     library descriptor *)
diff --git a/upstream/ocaml_413/file_formats/cmt_format.ml b/upstream/ocaml_413/file_formats/cmt_format.ml
new file mode 100644
index 0000000..709509a
--- /dev/null
+++ b/upstream/ocaml_413/file_formats/cmt_format.ml
@@ -0,0 +1,194 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Cmi_format
+open Typedtree
+
+(* Note that in Typerex, there is an awful hack to save a cmt file
+   together with the interface file that was generated by ocaml (this
+   is because the installed version of ocaml might differ from the one
+   integrated in Typerex).
+*)
+
+
+
+let read_magic_number ic =
+  let len_magic_number = String.length Config.cmt_magic_number in
+  really_input_string ic len_magic_number
+
+type binary_annots =
+  | Packed of Types.signature * string list
+  | Implementation of structure
+  | Interface of signature
+  | Partial_implementation of binary_part array
+  | Partial_interface of binary_part array
+
+and binary_part =
+| Partial_structure of structure
+| Partial_structure_item of structure_item
+| Partial_expression of expression
+| Partial_pattern : 'k pattern_category * 'k general_pattern -> binary_part
+| Partial_class_expr of class_expr
+| Partial_signature of signature
+| Partial_signature_item of signature_item
+| Partial_module_type of module_type
+
+type cmt_infos = {
+  cmt_modname : string;
+  cmt_annots : binary_annots;
+  cmt_value_dependencies :
+    (Types.value_description * Types.value_description) list;
+  cmt_comments : (string * Location.t) list;
+  cmt_args : string array;
+  cmt_sourcefile : string option;
+  cmt_builddir : string;
+  cmt_loadpath : string list;
+  cmt_source_digest : Digest.t option;
+  cmt_initial_env : Env.t;
+  cmt_imports : (string * Digest.t option) list;
+  cmt_interface_digest : Digest.t option;
+  cmt_use_summaries : bool;
+}
+
+type error =
+    Not_a_typedtree of string
+
+let need_to_clear_env =
+  try ignore (Sys.getenv "OCAML_BINANNOT_WITHENV"); false
+  with Not_found -> true
+
+let keep_only_summary = Env.keep_only_summary
+
+open Tast_mapper
+
+let cenv =
+  {Tast_mapper.default with env = fun _sub env -> keep_only_summary env}
+
+let clear_part = function
+  | Partial_structure s -> Partial_structure (cenv.structure cenv s)
+  | Partial_structure_item s ->
+      Partial_structure_item (cenv.structure_item cenv s)
+  | Partial_expression e -> Partial_expression (cenv.expr cenv e)
+  | Partial_pattern (category, p) -> Partial_pattern (category, cenv.pat cenv p)
+  | Partial_class_expr ce -> Partial_class_expr (cenv.class_expr cenv ce)
+  | Partial_signature s -> Partial_signature (cenv.signature cenv s)
+  | Partial_signature_item s ->
+      Partial_signature_item (cenv.signature_item cenv s)
+  | Partial_module_type s -> Partial_module_type (cenv.module_type cenv s)
+
+let clear_env binary_annots =
+  if need_to_clear_env then
+    match binary_annots with
+    | Implementation s -> Implementation (cenv.structure cenv s)
+    | Interface s -> Interface (cenv.signature cenv s)
+    | Packed _ -> binary_annots
+    | Partial_implementation array ->
+        Partial_implementation (Array.map clear_part array)
+    | Partial_interface array ->
+        Partial_interface (Array.map clear_part array)
+
+  else binary_annots
+
+exception Error of error
+
+let input_cmt ic = (input_value ic : cmt_infos)
+
+let output_cmt oc cmt =
+  output_string oc Config.cmt_magic_number;
+  output_value oc (cmt : cmt_infos)
+
+let read filename =
+(*  Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *)
+  let ic = open_in_bin filename in
+  Misc.try_finally
+    ~always:(fun () -> close_in ic)
+    (fun () ->
+       let magic_number = read_magic_number ic in
+       let cmi, cmt =
+         if magic_number = Config.cmt_magic_number then
+           None, Some (input_cmt ic)
+         else if magic_number = Config.cmi_magic_number then
+           let cmi = Cmi_format.input_cmi ic in
+           let cmt = try
+               let magic_number = read_magic_number ic in
+               if magic_number = Config.cmt_magic_number then
+                 let cmt = input_cmt ic in
+                 Some cmt
+               else None
+             with _ -> None
+           in
+           Some cmi, cmt
+         else
+           raise(Cmi_format.Error(Cmi_format.Not_an_interface filename))
+       in
+       cmi, cmt
+    )
+
+let read_cmt filename =
+  match read filename with
+      _, None -> raise (Error (Not_a_typedtree filename))
+    | _, Some cmt -> cmt
+
+let read_cmi filename =
+  match read filename with
+      None, _ ->
+        raise (Cmi_format.Error (Cmi_format.Not_an_interface filename))
+    | Some cmi, _ -> cmi
+
+let saved_types = ref []
+let value_deps = ref []
+
+let clear () =
+  saved_types := [];
+  value_deps := []
+
+let add_saved_type b = saved_types := b :: !saved_types
+let get_saved_types () = !saved_types
+let set_saved_types l = saved_types := l
+
+let record_value_dependency vd1 vd2 =
+  if vd1.Types.val_loc <> vd2.Types.val_loc then
+    value_deps := (vd1, vd2) :: !value_deps
+
+let save_cmt filename modname binary_annots sourcefile initial_env cmi =
+  if !Clflags.binary_annotations && not !Clflags.print_types then begin
+    Misc.output_to_file_via_temporary
+       ~mode:[Open_binary] filename
+       (fun temp_file_name oc ->
+         let this_crc =
+           match cmi with
+           | None -> None
+           | Some cmi -> Some (output_cmi temp_file_name oc cmi)
+         in
+         let source_digest = Option.map Digest.file sourcefile in
+         let cmt = {
+           cmt_modname = modname;
+           cmt_annots = clear_env binary_annots;
+           cmt_value_dependencies = !value_deps;
+           cmt_comments = Lexer.comments ();
+           cmt_args = Sys.argv;
+           cmt_sourcefile = sourcefile;
+           cmt_builddir = Location.rewrite_absolute_path (Sys.getcwd ());
+           cmt_loadpath = Load_path.get_paths ();
+           cmt_source_digest = source_digest;
+           cmt_initial_env = if need_to_clear_env then
+               keep_only_summary initial_env else initial_env;
+           cmt_imports = List.sort compare (Env.imports ());
+           cmt_interface_digest = this_crc;
+           cmt_use_summaries = need_to_clear_env;
+         } in
+         output_cmt oc cmt)
+  end;
+  clear ()
diff --git a/upstream/ocaml_413/file_formats/cmt_format.mli b/upstream/ocaml_413/file_formats/cmt_format.mli
new file mode 100644
index 0000000..8a52c4b
--- /dev/null
+++ b/upstream/ocaml_413/file_formats/cmt_format.mli
@@ -0,0 +1,123 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** cmt and cmti files format. *)
+
+open Misc
+
+(** The layout of a cmt file is as follows:
+      <cmt> := \{<cmi>\} <cmt magic> \{cmt infos\} \{<source info>\}
+    where <cmi> is the cmi file format:
+      <cmi> := <cmi magic> <cmi info>.
+    More precisely, the optional <cmi> part must be present if and only if
+    the file is:
+    - a cmti, or
+    - a cmt, for a ml file which has no corresponding mli (hence no
+    corresponding cmti).
+
+    Thus, we provide a common reading function for cmi and cmt(i)
+    files which returns an option for each of the three parts: cmi
+    info, cmt info, source info. *)
+
+open Typedtree
+
+type binary_annots =
+  | Packed of Types.signature * string list
+  | Implementation of structure
+  | Interface of signature
+  | Partial_implementation of binary_part array
+  | Partial_interface of binary_part array
+
+and binary_part =
+  | Partial_structure of structure
+  | Partial_structure_item of structure_item
+  | Partial_expression of expression
+  | Partial_pattern : 'k pattern_category * 'k general_pattern -> binary_part
+  | Partial_class_expr of class_expr
+  | Partial_signature of signature
+  | Partial_signature_item of signature_item
+  | Partial_module_type of module_type
+
+type cmt_infos = {
+  cmt_modname : modname;
+  cmt_annots : binary_annots;
+  cmt_value_dependencies :
+    (Types.value_description * Types.value_description) list;
+  cmt_comments : (string * Location.t) list;
+  cmt_args : string array;
+  cmt_sourcefile : string option;
+  cmt_builddir : string;
+  cmt_loadpath : string list;
+  cmt_source_digest : string option;
+  cmt_initial_env : Env.t;
+  cmt_imports : crcs;
+  cmt_interface_digest : Digest.t option;
+  cmt_use_summaries : bool;
+}
+
+type error =
+    Not_a_typedtree of string
+
+exception Error of error
+
+(** [read filename] opens filename, and extract both the cmi_infos, if
+    it exists, and the cmt_infos, if it exists. Thus, it can be used
+    with .cmi, .cmt and .cmti files.
+
+    .cmti files always contain a cmi_infos at the beginning. .cmt files
+    only contain a cmi_infos at the beginning if there is no associated
+    .cmti file.
+*)
+val read : string -> Cmi_format.cmi_infos option * cmt_infos option
+
+val read_cmt : string -> cmt_infos
+val read_cmi : string -> Cmi_format.cmi_infos
+
+(** [save_cmt filename modname binary_annots sourcefile initial_env cmi]
+    writes a cmt(i) file.  *)
+val save_cmt :
+  string ->  (* filename.cmt to generate *)
+  string ->  (* module name *)
+  binary_annots ->
+  string option ->  (* source file *)
+  Env.t -> (* initial env *)
+  Cmi_format.cmi_infos option -> (* if a .cmi was generated *)
+  unit
+
+(* Miscellaneous functions *)
+
+val read_magic_number : in_channel -> string
+
+val clear: unit -> unit
+
+val add_saved_type : binary_part -> unit
+val get_saved_types : unit -> binary_part list
+val set_saved_types : binary_part list -> unit
+
+val record_value_dependency:
+  Types.value_description -> Types.value_description -> unit
+
+
+(*
+
+  val is_magic_number : string -> bool
+  val read : in_channel -> Env.cmi_infos option * t
+  val write_magic_number : out_channel -> unit
+  val write : out_channel -> t -> unit
+
+  val find : string list -> string -> string
+  val read_signature : 'a -> string -> Types.signature * 'b list * 'c list
+
+*)
diff --git a/upstream/ocaml_413/file_formats/cmx_format.mli b/upstream/ocaml_413/file_formats/cmx_format.mli
new file mode 100644
index 0000000..91ad2d1
--- /dev/null
+++ b/upstream/ocaml_413/file_formats/cmx_format.mli
@@ -0,0 +1,58 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2010 Institut National de Recherche en Informatique et     *)
+(*     en Automatique                                                     *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Format of .cmx, .cmxa and .cmxs files *)
+
+open Misc
+
+(* Each .o file has a matching .cmx file that provides the following infos
+   on the compilation unit:
+     - list of other units imported, with MD5s of their .cmx files
+     - approximation of the structure implemented
+       (includes descriptions of known functions: arity and direct entry
+        points)
+     - list of currying functions and application functions needed
+   The .cmx file contains these infos (as an externed record) plus a MD5
+   of these infos *)
+
+type export_info =
+  | Clambda of Clambda.value_approximation
+  | Flambda of Export_info.t
+
+type unit_infos =
+  { mutable ui_name: modname;             (* Name of unit implemented *)
+    mutable ui_symbol: string;            (* Prefix for symbols *)
+    mutable ui_defines: string list;      (* Unit and sub-units implemented *)
+    mutable ui_imports_cmi: crcs;         (* Interfaces imported *)
+    mutable ui_imports_cmx: crcs;         (* Infos imported *)
+    mutable ui_curry_fun: int list;       (* Currying functions needed *)
+    mutable ui_apply_fun: int list;       (* Apply functions needed *)
+    mutable ui_send_fun: int list;        (* Send functions needed *)
+    mutable ui_export_info: export_info;
+    mutable ui_force_link: bool }         (* Always linked *)
+
+(* Each .a library has a matching .cmxa file that provides the following
+   infos on the library: *)
+
+type library_infos =
+  { lib_units: (unit_infos * Digest.t) list;  (* List of unit infos w/ MD5s *)
+    (* In the following fields the lists are reversed with respect to
+       how they end up being used on the command line. *)
+    lib_ccobjs: string list;            (* C object files needed *)
+    lib_ccopts: string list }           (* Extra opts to C compiler *)
diff --git a/upstream/ocaml_413/file_formats/cmxs_format.mli b/upstream/ocaml_413/file_formats/cmxs_format.mli
new file mode 100644
index 0000000..c670024
--- /dev/null
+++ b/upstream/ocaml_413/file_formats/cmxs_format.mli
@@ -0,0 +1,35 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2010 Institut National de Recherche en Informatique et     *)
+(*     en Automatique                                                     *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Format of .cmxs files *)
+
+open Misc
+
+(* Each .cmxs dynamically-loaded plugin contains a symbol
+   "caml_plugin_header" containing the following info
+   (as an externed record) *)
+
+type dynunit = {
+  dynu_name: modname;
+  dynu_crc: Digest.t;
+  dynu_imports_cmi: crcs;
+  dynu_imports_cmx: crcs;
+  dynu_defines: string list;
+}
+
+type dynheader = {
+  dynu_magic: string;
+  dynu_units: dynunit list;
+}
diff --git a/upstream/ocaml_413/file_formats/linear_format.ml b/upstream/ocaml_413/file_formats/linear_format.ml
new file mode 100644
index 0000000..5525a69
--- /dev/null
+++ b/upstream/ocaml_413/file_formats/linear_format.ml
@@ -0,0 +1,101 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                    Greta Yorsh, Jane Street Europe                     *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*   Copyright 2019 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Marshal and unmarshal a compilation unit in linear format *)
+type linear_item_info =
+  | Func of Linear.fundecl
+  | Data of Cmm.data_item list
+
+type linear_unit_info =
+  {
+    mutable unit_name : string;
+    mutable items : linear_item_info list;
+    mutable for_pack : string option
+  }
+
+type error =
+  | Wrong_format of string
+  | Wrong_version of string
+  | Corrupted of string
+  | Marshal_failed of string
+
+exception Error of error
+
+let save filename linear_unit_info =
+  let ch = open_out_bin filename in
+  Misc.try_finally (fun () ->
+    output_string ch Config.linear_magic_number;
+    output_value ch linear_unit_info;
+    (* Saved because Linearize and Emit depend on Cmm.label. *)
+    output_value ch (Cmm.cur_label ());
+    (* Compute digest of the contents and append it to the file. *)
+    flush ch;
+    let crc = Digest.file filename in
+    output_value ch crc
+  )
+    ~always:(fun () -> close_out ch)
+    ~exceptionally:(fun () -> raise (Error (Marshal_failed filename)))
+
+let restore filename =
+  let ic = open_in_bin filename in
+  Misc.try_finally
+    (fun () ->
+       let magic = Config.linear_magic_number in
+       let buffer = really_input_string ic (String.length magic) in
+       if String.equal buffer magic then begin
+         try
+           let linear_unit_info = (input_value ic : linear_unit_info) in
+           let last_label = (input_value ic : Cmm.label) in
+           Cmm.reset ();
+           Cmm.set_label last_label;
+           let crc = (input_value ic : Digest.t) in
+           linear_unit_info, crc
+         with End_of_file | Failure _ -> raise (Error (Corrupted filename))
+            | Error e -> raise (Error e)
+       end
+       else if String.sub buffer 0 9 = String.sub magic 0 9 then
+         raise (Error (Wrong_version filename))
+       else
+         raise (Error (Wrong_format filename))
+    )
+    ~always:(fun () -> close_in ic)
+
+(* Error report *)
+
+open Format
+
+let report_error ppf = function
+  | Wrong_format filename ->
+      fprintf ppf "Expected Linear format. Incompatible file %a"
+        Location.print_filename filename
+  | Wrong_version filename ->
+      fprintf ppf
+        "%a@ is not compatible with this version of OCaml"
+        Location.print_filename filename
+  | Corrupted filename ->
+      fprintf ppf "Corrupted format@ %a"
+        Location.print_filename filename
+  | Marshal_failed filename ->
+      fprintf ppf "Failed to marshal Linear to file@ %a"
+        Location.print_filename filename
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )
diff --git a/upstream/ocaml_413/file_formats/linear_format.mli b/upstream/ocaml_413/file_formats/linear_format.mli
new file mode 100644
index 0000000..766db5d
--- /dev/null
+++ b/upstream/ocaml_413/file_formats/linear_format.mli
@@ -0,0 +1,38 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                    Greta Yorsh, Jane Street Europe                     *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*   Copyright 2019 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Format of .cmir-linear files *)
+
+(* Compiler can optionally save Linear representation of a compilation unit,
+   along with other information required to emit assembly. *)
+type linear_item_info =
+  | Func of Linear.fundecl
+  | Data of Cmm.data_item list
+
+type linear_unit_info =
+  {
+    mutable unit_name : string;
+    mutable items : linear_item_info list;
+    mutable for_pack : string option
+  }
+
+(* Marshal and unmarshal a compilation unit in Linear format.
+   It includes saving and restoring global state required for Emit,
+   that currently consists of Cmm.label_counter.
+*)
+val save : string -> linear_unit_info -> unit
+val restore : string -> linear_unit_info * Digest.t
diff --git a/upstream/ocaml_413/parsing/CONFLICTS.md b/upstream/ocaml_413/parsing/CONFLICTS.md
new file mode 100644
index 0000000..b2a84fc
--- /dev/null
+++ b/upstream/ocaml_413/parsing/CONFLICTS.md
@@ -0,0 +1,54 @@
+# Conflicts
+
+Some of the conflicts and issues in the grammar are documented here.
+
+## A variant type that lists a single atomic type
+
+Why can't `[t]` be considered a valid atomic type? (A variant type.)
+
+(This is related to MPR #3835.)
+
+A class type that begins with `[t] foo` could continue as follows:
+
+```
+  [t] foo -> <class_type>
+```
+
+Here `t` is understood as a variant type,
+and is used as an actual parameter of the parameterized type `'a foo`.
+
+Or it could continue as follows:
+
+```
+  [t] foo
+```
+
+Here `t` is a type (there is no variant type)
+and is used as an actual parameter of the class `['a] foo`.
+
+After we have read the closing bracket and are looking ahead at `foo`,
+we need to decide which of the above two situations we have. (The first
+situation requires a reduction; the second situation requires shifting.)
+But we cannot decide yet; we would need to look at the arrow `->` beyond
+`foo` in order to decide. In this example LR(2) is required; in general,
+`foo` could be replaced with an arbitrary qualified name, so unbounded
+lookahead is required.
+
+As a result of this issue, we must abandon the idea that `[t]` could be
+a well-formed variant type. In the syntax of atomic types, instead of:
+
+```
+  atomic_type: LBRACKET row_field RBRACKET
+```
+
+we must use the more restricted form:
+
+```
+  atomic_type: LBRACKET tag_field RBRACKET
+```
+
+In other words, we rule out exactly the following:
+
+```
+  atomic_type: LBRACKET atomic_type RBRACKET
+```
diff --git a/upstream/ocaml_413/parsing/HACKING.adoc b/upstream/ocaml_413/parsing/HACKING.adoc
new file mode 100644
index 0000000..0566c01
--- /dev/null
+++ b/upstream/ocaml_413/parsing/HACKING.adoc
@@ -0,0 +1,76 @@
+link:parsetree.mli[Parsetree] and link:asttypes.mli[Asttypes]::
+Parsetree is an Abstract Syntax Tree (AST) representation of OCaml
+source code. It is well annotated with examples and is a recommended
+read before any further exploration of the compiler.
+
+link:location.mli[Location]:: This module contains utilities
+related to locations and error handling. In particular, it contains
+handlers that are used for all the error reporting in the compiler.
+
+link:parser.mly[parser.mly]:: This file contains the grammar used to
+generated the parser -- using the
+link:http://gallium.inria.fr/~fpottier/menhir/[menhir] parser
+generator, which is an external tool that you need to install if you
+wish to modify the parser.
+
+=== Working on the parser grammar
+
+To avoid depending on an external tool, the compiler build system does
+not rebuild the parser from the source grammar link:parser.mly[] each
+time. It works from a versioned copy of the generated parser stored
+in the `boot/menhir` subdirectory.
+
+If you change link:parser.mly[], you need to run the `promote-menhir`
+target of the root Makefile to rebuild the compiler parser. See
+link:../Makefile.menhir[] for the details of the various
+Menhir-related targets and their use.
+
+==== Testing the grammar
+
+The root Makefile contains a `build-all-asts` target that will build,
+for each source `.ml` or `.mli` file in the repository, a `.ml.ast` or
+`.mli.ast` file describing the parsed abstract syntax tree (AST) in
+`-dparsetree` format.
+This rule is rather slow to run, and can safely be run in parallel, so
+we recommend using `-j` (without a number) to maximize parallelism:
+
+----
+make -j build-all-asts
+----
+
+Finally, the 'list-all-asts' target lists all such '.ast' files.
+
+This is intended to be used to test parser changes, in particular
+those that should not modify the parsed AST at all:
+
+1. Before performing any changes, build all AST files and add them to
+   the git index (`make list-all-asts | xargs git add`).
+
+2. Perform any parser change of interest.
+
+3. To test your changes, build AST files again; `git diff` will show
+   any change to an AST file.
+
+4. Before committing any change, remember to remove the `.ast` files
+   from your index (using `git reset HEAD`), and maybe remove them
+   completely (unless you plan to check further changes).
+
+----
+# save pre-change ASTs
+make -j build-all-asts
+make list-all-asts | xargs git add
+
+# do your parser changes
+# ...
+make promote-menhir
+
+# compare new ASTs
+make -j build-all-asts
+git diff # shows any .ml.ast difference
+
+# remove AST files from the index
+make list-all-asts | xargs git reset HEAD
+
+# remove the files (if no further parser change planned)
+make list-all-asts | xargs rm
+----
diff --git a/upstream/ocaml_413/parsing/VIPs.md b/upstream/ocaml_413/parsing/VIPs.md
new file mode 100644
index 0000000..baae024
--- /dev/null
+++ b/upstream/ocaml_413/parsing/VIPs.md
@@ -0,0 +1,20 @@
+# VIPs
+
+A VIP is a common syntax error, for which a good error message should be
+given.
+
+## Structures versus signatures
+
+Everything that is allowed in a structure but forbidden in a signature,
+or vice-versa, is a VIP. For instance, writing:
+
+```
+  exception A = B
+```
+
+is allowed in a structure, but forbidden in a signature. (Here, we might
+wish to make the error message depend on the lookahead token; the token
+`=` suggests that the user confuses a structure and a signature.)
+
+Similarly, writing `struct` where `sig` is expected, or vice-versa, is
+probably a common mistake.
diff --git a/upstream/ocaml_413/parsing/ast_helper.ml b/upstream/ocaml_413/parsing/ast_helper.ml
new file mode 100644
index 0000000..41f5fb9
--- /dev/null
+++ b/upstream/ocaml_413/parsing/ast_helper.ml
@@ -0,0 +1,643 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Helpers to produce Parsetree fragments *)
+
+open Asttypes
+open Parsetree
+open Docstrings
+
+type 'a with_loc = 'a Location.loc
+type loc = Location.t
+
+type lid = Longident.t with_loc
+type str = string with_loc
+type str_opt = string option with_loc
+type attrs = attribute list
+
+let default_loc = ref Location.none
+
+let with_default_loc l f =
+  Misc.protect_refs [Misc.R (default_loc, l)] f
+
+module Const = struct
+  let integer ?suffix i = Pconst_integer (i, suffix)
+  let int ?suffix i = integer ?suffix (Int.to_string i)
+  let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i)
+  let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i)
+  let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i)
+  let float ?suffix f = Pconst_float (f, suffix)
+  let char c = Pconst_char c
+  let string ?quotation_delimiter ?(loc= !default_loc) s =
+    Pconst_string (s, loc, quotation_delimiter)
+end
+
+module Attr = struct
+  let mk ?(loc= !default_loc) name payload =
+    { attr_name = name;
+      attr_payload = payload;
+      attr_loc = loc }
+end
+
+module Typ = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {ptyp_desc = d;
+     ptyp_loc = loc;
+     ptyp_loc_stack = [];
+     ptyp_attributes = attrs}
+
+  let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]}
+
+  let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any
+  let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a)
+  let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c))
+  let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a)
+  let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b))
+  let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b))
+  let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b))
+  let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b))
+  let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c))
+  let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b))
+  let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b))
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a)
+
+  let force_poly t =
+    match t.ptyp_desc with
+    | Ptyp_poly _ -> t
+    | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *)
+
+  let varify_constructors var_names t =
+    let check_variable vl loc v =
+      if List.mem v vl then
+        raise Syntaxerr.(Error(Variable_in_scope(loc,v))) in
+    let var_names = List.map (fun v -> v.txt) var_names in
+    let rec loop t =
+      let desc =
+        match t.ptyp_desc with
+        | Ptyp_any -> Ptyp_any
+        | Ptyp_var x ->
+            check_variable var_names t.ptyp_loc x;
+            Ptyp_var x
+        | Ptyp_arrow (label,core_type,core_type') ->
+            Ptyp_arrow(label, loop core_type, loop core_type')
+        | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst)
+        | Ptyp_constr( { txt = Longident.Lident s }, [])
+          when List.mem s var_names ->
+            Ptyp_var s
+        | Ptyp_constr(longident, lst) ->
+            Ptyp_constr(longident, List.map loop lst)
+        | Ptyp_object (lst, o) ->
+            Ptyp_object (List.map loop_object_field lst, o)
+        | Ptyp_class (longident, lst) ->
+            Ptyp_class (longident, List.map loop lst)
+        | Ptyp_alias(core_type, string) ->
+            check_variable var_names t.ptyp_loc string;
+            Ptyp_alias(loop core_type, string)
+        | Ptyp_variant(row_field_list, flag, lbl_lst_option) ->
+            Ptyp_variant(List.map loop_row_field row_field_list,
+                         flag, lbl_lst_option)
+        | Ptyp_poly(string_lst, core_type) ->
+          List.iter (fun v ->
+            check_variable var_names t.ptyp_loc v.txt) string_lst;
+            Ptyp_poly(string_lst, loop core_type)
+        | Ptyp_package(longident,lst) ->
+            Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst)
+        | Ptyp_extension (s, arg) ->
+            Ptyp_extension (s, arg)
+      in
+      {t with ptyp_desc = desc}
+    and loop_row_field field =
+      let prf_desc = match field.prf_desc with
+        | Rtag(label,flag,lst) ->
+            Rtag(label,flag,List.map loop lst)
+        | Rinherit t ->
+            Rinherit (loop t)
+      in
+      { field with prf_desc; }
+    and loop_object_field field =
+      let pof_desc = match field.pof_desc with
+        | Otag(label, t) ->
+            Otag(label, loop t)
+        | Oinherit t ->
+            Oinherit (loop t)
+      in
+      { field with pof_desc; }
+    in
+    loop t
+
+end
+
+module Pat = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {ppat_desc = d;
+     ppat_loc = loc;
+     ppat_loc_stack = [];
+     ppat_attributes = attrs}
+  let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]}
+
+  let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any
+  let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a)
+  let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b))
+  let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a)
+  let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b))
+  let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a)
+  let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b))
+  let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b))
+  let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b))
+  let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a)
+  let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b))
+  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b))
+  let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a)
+  let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a)
+  let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a)
+  let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b))
+  let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a)
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a)
+end
+
+module Exp = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {pexp_desc = d;
+     pexp_loc = loc;
+     pexp_loc_stack = [];
+     pexp_attributes = attrs}
+  let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]}
+
+  let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a)
+  let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a)
+  let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c))
+  let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d))
+  let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a)
+  let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b))
+  let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b))
+  let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b))
+  let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a)
+  let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b))
+  let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b))
+  let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b))
+  let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b))
+  let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c))
+  let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a)
+  let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c))
+  let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b))
+  let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b))
+  let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e))
+  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b))
+  let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c))
+  let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b))
+  let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a)
+  let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b))
+  let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a)
+  let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c))
+  let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b))
+  let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a)
+  let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a)
+  let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b))
+  let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a)
+  let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b))
+  let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a)
+  let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_open (a, b))
+  let letop ?loc ?attrs let_ ands body =
+    mk ?loc ?attrs (Pexp_letop {let_; ands; body})
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a)
+  let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable
+
+  let case lhs ?guard rhs =
+    {
+     pc_lhs = lhs;
+     pc_guard = guard;
+     pc_rhs = rhs;
+    }
+
+  let binding_op op pat exp loc =
+    {
+      pbop_op = op;
+      pbop_pat = pat;
+      pbop_exp = exp;
+      pbop_loc = loc;
+    }
+end
+
+module Mty = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs}
+  let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]}
+
+  let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a)
+  let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a)
+  let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a)
+  let functor_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_functor (a, b))
+  let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b))
+  let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a)
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a)
+end
+
+module Mod = struct
+let mk ?(loc = !default_loc) ?(attrs = []) d =
+  {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs}
+  let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]}
+
+  let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x)
+  let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x)
+  let functor_ ?loc ?attrs arg body =
+    mk ?loc ?attrs (Pmod_functor (arg, body))
+  let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2))
+  let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty))
+  let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e)
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a)
+end
+
+module Sig = struct
+  let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc}
+
+  let value ?loc a = mk ?loc (Psig_value a)
+  let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a))
+  let type_subst ?loc a = mk ?loc (Psig_typesubst a)
+  let type_extension ?loc a = mk ?loc (Psig_typext a)
+  let exception_ ?loc a = mk ?loc (Psig_exception a)
+  let module_ ?loc a = mk ?loc (Psig_module a)
+  let mod_subst ?loc a = mk ?loc (Psig_modsubst a)
+  let rec_module ?loc a = mk ?loc (Psig_recmodule a)
+  let modtype ?loc a = mk ?loc (Psig_modtype a)
+  let modtype_subst ?loc a = mk ?loc (Psig_modtypesubst a)
+  let open_ ?loc a = mk ?loc (Psig_open a)
+  let include_ ?loc a = mk ?loc (Psig_include a)
+  let class_ ?loc a = mk ?loc (Psig_class a)
+  let class_type ?loc a = mk ?loc (Psig_class_type a)
+  let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs))
+  let attribute ?loc a = mk ?loc (Psig_attribute a)
+  let text txt =
+    let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
+    List.map
+      (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
+      f_txt
+end
+
+module Str = struct
+  let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc}
+
+  let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs))
+  let value ?loc a b = mk ?loc (Pstr_value (a, b))
+  let primitive ?loc a = mk ?loc (Pstr_primitive a)
+  let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a))
+  let type_extension ?loc a = mk ?loc (Pstr_typext a)
+  let exception_ ?loc a = mk ?loc (Pstr_exception a)
+  let module_ ?loc a = mk ?loc (Pstr_module a)
+  let rec_module ?loc a = mk ?loc (Pstr_recmodule a)
+  let modtype ?loc a = mk ?loc (Pstr_modtype a)
+  let open_ ?loc a = mk ?loc (Pstr_open a)
+  let class_ ?loc a = mk ?loc (Pstr_class a)
+  let class_type ?loc a = mk ?loc (Pstr_class_type a)
+  let include_ ?loc a = mk ?loc (Pstr_include a)
+  let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs))
+  let attribute ?loc a = mk ?loc (Pstr_attribute a)
+  let text txt =
+    let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
+    List.map
+      (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
+      f_txt
+end
+
+module Cl = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {
+     pcl_desc = d;
+     pcl_loc = loc;
+     pcl_attributes = attrs;
+    }
+  let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]}
+
+  let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b))
+  let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a)
+  let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d))
+  let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b))
+  let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c))
+  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b))
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a)
+  let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_open (a, b))
+end
+
+module Cty = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {
+     pcty_desc = d;
+     pcty_loc = loc;
+     pcty_attributes = attrs;
+    }
+  let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]}
+
+  let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b))
+  let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a)
+  let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c))
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a)
+  let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcty_open (a, b))
+end
+
+module Ctf = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+           ?(docs = empty_docs) d =
+    {
+     pctf_desc = d;
+     pctf_loc = loc;
+     pctf_attributes = add_docs_attrs docs attrs;
+    }
+
+  let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a)
+  let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d))
+  let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d))
+  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b))
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a)
+  let attribute ?loc a = mk ?loc (Pctf_attribute a)
+  let text txt =
+   let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
+     List.map
+      (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
+      f_txt
+
+  let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]}
+
+end
+
+module Cf = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) d =
+    {
+     pcf_desc = d;
+     pcf_loc = loc;
+     pcf_attributes = add_docs_attrs docs attrs;
+    }
+
+  let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c))
+  let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c))
+  let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c))
+  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b))
+  let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a)
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a)
+  let attribute ?loc a = mk ?loc (Pcf_attribute a)
+  let text txt =
+    let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
+    List.map
+      (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
+      f_txt
+
+  let virtual_ ct = Cfk_virtual ct
+  let concrete o e = Cfk_concrete (o, e)
+
+  let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]}
+
+end
+
+module Val = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+        ?(prim = []) name typ =
+    {
+     pval_name = name;
+     pval_type = typ;
+     pval_attributes = add_docs_attrs docs attrs;
+     pval_loc = loc;
+     pval_prim = prim;
+    }
+end
+
+module Md = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = []) name typ =
+    {
+     pmd_name = name;
+     pmd_type = typ;
+     pmd_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pmd_loc = loc;
+    }
+end
+
+module Ms = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = []) name syn =
+    {
+     pms_name = name;
+     pms_manifest = syn;
+     pms_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pms_loc = loc;
+    }
+end
+
+module Mtd = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = []) ?typ name =
+    {
+     pmtd_name = name;
+     pmtd_type = typ;
+     pmtd_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pmtd_loc = loc;
+    }
+end
+
+module Mb = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = []) name expr =
+    {
+     pmb_name = name;
+     pmb_expr = expr;
+     pmb_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pmb_loc = loc;
+    }
+end
+
+module Opn = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+        ?(override = Fresh) expr =
+    {
+     popen_expr = expr;
+     popen_override = override;
+     popen_loc = loc;
+     popen_attributes = add_docs_attrs docs attrs;
+    }
+end
+
+module Incl = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr =
+    {
+     pincl_mod = mexpr;
+     pincl_loc = loc;
+     pincl_attributes = add_docs_attrs docs attrs;
+    }
+
+end
+
+module Vb = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+        ?(text = []) pat expr =
+    {
+     pvb_pat = pat;
+     pvb_expr = expr;
+     pvb_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pvb_loc = loc;
+    }
+end
+
+module Ci = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = [])
+        ?(virt = Concrete) ?(params = []) name expr =
+    {
+     pci_virt = virt;
+     pci_params = params;
+     pci_name = name;
+     pci_expr = expr;
+     pci_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pci_loc = loc;
+    }
+end
+
+module Type = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = [])
+      ?(params = [])
+      ?(cstrs = [])
+      ?(kind = Ptype_abstract)
+      ?(priv = Public)
+      ?manifest
+      name =
+    {
+     ptype_name = name;
+     ptype_params = params;
+     ptype_cstrs = cstrs;
+     ptype_kind = kind;
+     ptype_private = priv;
+     ptype_manifest = manifest;
+     ptype_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     ptype_loc = loc;
+    }
+
+  let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info)
+        ?(args = Pcstr_tuple []) ?res name =
+    {
+     pcd_name = name;
+     pcd_args = args;
+     pcd_res = res;
+     pcd_loc = loc;
+     pcd_attributes = add_info_attrs info attrs;
+    }
+
+  let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info)
+        ?(mut = Immutable) name typ =
+    {
+     pld_name = name;
+     pld_mutable = mut;
+     pld_type = typ;
+     pld_loc = loc;
+     pld_attributes = add_info_attrs info attrs;
+    }
+
+end
+
+(** Type extensions *)
+module Te = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+        ?(params = []) ?(priv = Public) path constructors =
+    {
+     ptyext_path = path;
+     ptyext_params = params;
+     ptyext_constructors = constructors;
+     ptyext_private = priv;
+     ptyext_loc = loc;
+     ptyext_attributes = add_docs_attrs docs attrs;
+    }
+
+  let mk_exception ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+      constructor =
+    {
+     ptyexn_constructor = constructor;
+     ptyexn_loc = loc;
+     ptyexn_attributes = add_docs_attrs docs attrs;
+    }
+
+  let constructor ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(info = empty_info) name kind =
+    {
+     pext_name = name;
+     pext_kind = kind;
+     pext_loc = loc;
+     pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
+    }
+
+  let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+             ?(info = empty_info) ?(args = Pcstr_tuple []) ?res name =
+    {
+     pext_name = name;
+     pext_kind = Pext_decl(args, res);
+     pext_loc = loc;
+     pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
+    }
+
+  let rebind ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(info = empty_info) name lid =
+    {
+     pext_name = name;
+     pext_kind = Pext_rebind lid;
+     pext_loc = loc;
+     pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
+    }
+
+end
+
+module Csig = struct
+  let mk self fields =
+    {
+     pcsig_self = self;
+     pcsig_fields = fields;
+    }
+end
+
+module Cstr = struct
+  let mk self fields =
+    {
+     pcstr_self = self;
+     pcstr_fields = fields;
+    }
+end
+
+(** Row fields *)
+module Rf = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) desc = {
+    prf_desc = desc;
+    prf_loc = loc;
+    prf_attributes = attrs;
+  }
+  let tag ?loc ?attrs label const tys =
+    mk ?loc ?attrs (Rtag (label, const, tys))
+  let inherit_?loc ty =
+    mk ?loc (Rinherit ty)
+end
+
+(** Object fields *)
+module Of = struct
+  let mk ?(loc = !default_loc) ?(attrs=[]) desc = {
+    pof_desc = desc;
+    pof_loc = loc;
+    pof_attributes = attrs;
+  }
+  let tag ?loc ?attrs label ty =
+    mk ?loc ?attrs (Otag (label, ty))
+  let inherit_ ?loc ty =
+    mk ?loc (Oinherit ty)
+end
diff --git a/upstream/ocaml_413/parsing/ast_helper.mli b/upstream/ocaml_413/parsing/ast_helper.mli
new file mode 100644
index 0000000..42ce9e2
--- /dev/null
+++ b/upstream/ocaml_413/parsing/ast_helper.mli
@@ -0,0 +1,493 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Helpers to produce Parsetree fragments
+
+  {b Warning} This module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Asttypes
+open Docstrings
+open Parsetree
+
+type 'a with_loc = 'a Location.loc
+type loc = Location.t
+
+type lid = Longident.t with_loc
+type str = string with_loc
+type str_opt = string option with_loc
+type attrs = attribute list
+
+(** {1 Default locations} *)
+
+val default_loc: loc ref
+    (** Default value for all optional location arguments. *)
+
+val with_default_loc: loc -> (unit -> 'a) -> 'a
+    (** Set the [default_loc] within the scope of the execution
+        of the provided function. *)
+
+(** {1 Constants} *)
+
+module Const : sig
+  val char : char -> constant
+  val string :
+    ?quotation_delimiter:string -> ?loc:Location.t -> string -> constant
+  val integer : ?suffix:char -> string -> constant
+  val int : ?suffix:char -> int -> constant
+  val int32 : ?suffix:char -> int32 -> constant
+  val int64 : ?suffix:char -> int64 -> constant
+  val nativeint : ?suffix:char -> nativeint -> constant
+  val float : ?suffix:char -> string -> constant
+end
+
+(** {1 Attributes} *)
+module Attr : sig
+  val mk: ?loc:loc -> str -> payload -> attribute
+end
+
+(** {1 Core language} *)
+
+(** Type expressions *)
+module Typ :
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type
+    val attr: core_type -> attribute -> core_type
+
+    val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type
+    val var: ?loc:loc -> ?attrs:attrs -> string -> core_type
+    val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type
+               -> core_type
+    val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type
+    val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
+    val object_: ?loc:loc -> ?attrs:attrs -> object_field list
+                   -> closed_flag -> core_type
+    val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
+    val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type
+    val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag
+                 -> label list option -> core_type
+    val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type
+    val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list
+                 -> core_type
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type
+
+    val force_poly: core_type -> core_type
+
+    val varify_constructors: str list -> core_type -> core_type
+    (** [varify_constructors newtypes te] is type expression [te], of which
+        any of nullary type constructor [tc] is replaced by type variable of
+        the same name, if [tc]'s name appears in [newtypes].
+        Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te]
+        appears in [newtypes].
+        @since 4.05
+     *)
+  end
+
+(** Patterns *)
+module Pat:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern
+    val attr:pattern -> attribute -> pattern
+
+    val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern
+    val var: ?loc:loc -> ?attrs:attrs -> str -> pattern
+    val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern
+    val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern
+    val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern
+    val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern
+    val construct: ?loc:loc -> ?attrs:attrs ->
+      lid -> (str list * pattern) option -> pattern
+    val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern
+    val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag
+                -> pattern
+    val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern
+    val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern
+    val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern
+    val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern
+    val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern
+    val unpack: ?loc:loc -> ?attrs:attrs -> str_opt -> pattern
+    val open_: ?loc:loc -> ?attrs:attrs  -> lid -> pattern -> pattern
+    val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern
+  end
+
+(** Expressions *)
+module Exp:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression
+    val attr: expression -> attribute -> expression
+
+    val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression
+    val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression
+    val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list
+              -> expression -> expression
+    val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option
+              -> pattern -> expression -> expression
+    val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression
+    val apply: ?loc:loc -> ?attrs:attrs -> expression
+               -> (arg_label * expression) list -> expression
+    val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list
+                -> expression
+    val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression
+    val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression
+    val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option
+                   -> expression
+    val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option
+                 -> expression
+    val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list
+                -> expression option -> expression
+    val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression
+    val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression
+                  -> expression
+    val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression
+    val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression
+                    -> expression option -> expression
+    val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression
+                  -> expression
+    val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression
+                -> expression
+    val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression
+              -> direction_flag -> expression -> expression
+    val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option
+                -> core_type -> expression
+    val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type
+                     -> expression
+    val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression
+    val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression
+    val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression
+    val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list
+                  -> expression
+    val letmodule: ?loc:loc -> ?attrs:attrs -> str_opt -> module_expr
+                   -> expression -> expression
+    val letexception:
+      ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression
+      -> expression
+    val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression
+    val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression
+    val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option
+              -> expression
+    val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression
+    val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression
+    val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression
+    val open_: ?loc:loc -> ?attrs:attrs -> open_declaration -> expression
+               -> expression
+    val letop: ?loc:loc -> ?attrs:attrs -> binding_op
+               -> binding_op list -> expression -> expression
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression
+    val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression
+
+    val case: pattern -> ?guard:expression -> expression -> case
+    val binding_op: str -> pattern -> expression -> loc -> binding_op
+  end
+
+(** Value declarations *)
+module Val:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
+      ?prim:string list -> str -> core_type -> value_description
+  end
+
+(** Type declarations *)
+module Type:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      ?params:(core_type * (variance * injectivity)) list ->
+      ?cstrs:(core_type * core_type * loc) list ->
+      ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str ->
+      type_declaration
+
+    val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info ->
+      ?args:constructor_arguments -> ?res:core_type -> str ->
+      constructor_declaration
+    val field: ?loc:loc -> ?attrs:attrs -> ?info:info ->
+      ?mut:mutable_flag -> str -> core_type -> label_declaration
+  end
+
+(** Type extensions *)
+module Te:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
+      ?params:(core_type * (variance * injectivity)) list ->
+      ?priv:private_flag -> lid -> extension_constructor list -> type_extension
+
+    val mk_exception: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
+      extension_constructor -> type_exception
+
+    val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
+      str -> extension_constructor_kind -> extension_constructor
+
+    val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
+      ?args:constructor_arguments -> ?res:core_type -> str ->
+      extension_constructor
+    val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
+      str -> lid -> extension_constructor
+  end
+
+(** {1 Module language} *)
+
+(** Module type expressions *)
+module Mty:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type
+    val attr: module_type -> attribute -> module_type
+
+    val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type
+    val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type
+    val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type
+    val functor_: ?loc:loc -> ?attrs:attrs ->
+      functor_parameter -> module_type -> module_type
+    val with_: ?loc:loc -> ?attrs:attrs -> module_type ->
+      with_constraint list -> module_type
+    val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type
+  end
+
+(** Module expressions *)
+module Mod:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr
+    val attr: module_expr -> attribute -> module_expr
+
+    val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr
+    val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr
+    val functor_: ?loc:loc -> ?attrs:attrs ->
+      functor_parameter -> module_expr -> module_expr
+    val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr ->
+      module_expr
+    val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type ->
+      module_expr
+    val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr
+  end
+
+(** Signature items *)
+module Sig:
+  sig
+    val mk: ?loc:loc -> signature_item_desc -> signature_item
+
+    val value: ?loc:loc -> value_description -> signature_item
+    val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item
+    val type_subst: ?loc:loc -> type_declaration list -> signature_item
+    val type_extension: ?loc:loc -> type_extension -> signature_item
+    val exception_: ?loc:loc -> type_exception -> signature_item
+    val module_: ?loc:loc -> module_declaration -> signature_item
+    val mod_subst: ?loc:loc -> module_substitution -> signature_item
+    val rec_module: ?loc:loc -> module_declaration list -> signature_item
+    val modtype: ?loc:loc -> module_type_declaration -> signature_item
+    val modtype_subst: ?loc:loc -> module_type_declaration -> signature_item
+    val open_: ?loc:loc -> open_description -> signature_item
+    val include_: ?loc:loc -> include_description -> signature_item
+    val class_: ?loc:loc -> class_description list -> signature_item
+    val class_type: ?loc:loc -> class_type_declaration list -> signature_item
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item
+    val attribute: ?loc:loc -> attribute -> signature_item
+    val text: text -> signature_item list
+  end
+
+(** Structure items *)
+module Str:
+  sig
+    val mk: ?loc:loc -> structure_item_desc -> structure_item
+
+    val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item
+    val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item
+    val primitive: ?loc:loc -> value_description -> structure_item
+    val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item
+    val type_extension: ?loc:loc -> type_extension -> structure_item
+    val exception_: ?loc:loc -> type_exception -> structure_item
+    val module_: ?loc:loc -> module_binding -> structure_item
+    val rec_module: ?loc:loc -> module_binding list -> structure_item
+    val modtype: ?loc:loc -> module_type_declaration -> structure_item
+    val open_: ?loc:loc -> open_declaration -> structure_item
+    val class_: ?loc:loc -> class_declaration list -> structure_item
+    val class_type: ?loc:loc -> class_type_declaration list -> structure_item
+    val include_: ?loc:loc -> include_declaration -> structure_item
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item
+    val attribute: ?loc:loc -> attribute -> structure_item
+    val text: text -> structure_item list
+  end
+
+(** Module declarations *)
+module Md:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      str_opt -> module_type -> module_declaration
+  end
+
+(** Module substitutions *)
+module Ms:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      str -> lid -> module_substitution
+  end
+
+(** Module type declarations *)
+module Mtd:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      ?typ:module_type -> str -> module_type_declaration
+  end
+
+(** Module bindings *)
+module Mb:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      str_opt -> module_expr -> module_binding
+  end
+
+(** Opens *)
+module Opn:
+  sig
+    val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs ->
+      ?override:override_flag -> 'a -> 'a open_infos
+  end
+
+(** Includes *)
+module Incl:
+  sig
+    val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos
+  end
+
+(** Value bindings *)
+module Vb:
+  sig
+    val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      pattern -> expression -> value_binding
+  end
+
+
+(** {1 Class language} *)
+
+(** Class type expressions *)
+module Cty:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type
+    val attr: class_type -> attribute -> class_type
+
+    val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type
+    val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type
+    val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type ->
+      class_type -> class_type
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type
+    val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_type
+               -> class_type
+  end
+
+(** Class type fields *)
+module Ctf:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
+      class_type_field_desc -> class_type_field
+    val attr: class_type_field -> attribute -> class_type_field
+
+    val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field
+    val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag ->
+      virtual_flag -> core_type -> class_type_field
+    val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag ->
+      virtual_flag -> core_type -> class_type_field
+    val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type ->
+      class_type_field
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field
+    val attribute: ?loc:loc -> attribute -> class_type_field
+    val text: text -> class_type_field list
+  end
+
+(** Class expressions *)
+module Cl:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr
+    val attr: class_expr -> attribute -> class_expr
+
+    val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr
+    val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr
+    val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option ->
+      pattern -> class_expr -> class_expr
+    val apply: ?loc:loc -> ?attrs:attrs -> class_expr ->
+      (arg_label * expression) list -> class_expr
+    val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list ->
+      class_expr -> class_expr
+    val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type ->
+      class_expr
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr
+    val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_expr
+               -> class_expr
+  end
+
+(** Class fields *)
+module Cf:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc ->
+      class_field
+    val attr: class_field -> attribute -> class_field
+
+    val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr ->
+      str option -> class_field
+    val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag ->
+      class_field_kind -> class_field
+    val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag ->
+      class_field_kind -> class_field
+    val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type ->
+      class_field
+    val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field
+    val attribute: ?loc:loc -> attribute -> class_field
+    val text: text -> class_field list
+
+    val virtual_: core_type -> class_field_kind
+    val concrete: override_flag -> expression -> class_field_kind
+
+  end
+
+(** Classes *)
+module Ci:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      ?virt:virtual_flag ->
+      ?params:(core_type * (variance * injectivity)) list ->
+      str -> 'a -> 'a class_infos
+  end
+
+(** Class signatures *)
+module Csig:
+  sig
+    val mk: core_type -> class_type_field list -> class_signature
+  end
+
+(** Class structures *)
+module Cstr:
+  sig
+    val mk: pattern -> class_field list -> class_structure
+  end
+
+(** Row fields *)
+module Rf:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> row_field_desc -> row_field
+    val tag: ?loc:loc -> ?attrs:attrs ->
+      label with_loc -> bool -> core_type list -> row_field
+    val inherit_: ?loc:loc -> core_type -> row_field
+  end
+
+(** Object fields *)
+module Of:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs ->
+      object_field_desc -> object_field
+    val tag: ?loc:loc -> ?attrs:attrs ->
+      label with_loc -> core_type -> object_field
+    val inherit_: ?loc:loc -> core_type -> object_field
+  end
diff --git a/upstream/ocaml_413/parsing/ast_invariants.ml b/upstream/ocaml_413/parsing/ast_invariants.ml
new file mode 100644
index 0000000..d9b83c0
--- /dev/null
+++ b/upstream/ocaml_413/parsing/ast_invariants.ml
@@ -0,0 +1,191 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2015 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Parsetree
+open Ast_iterator
+
+let err = Syntaxerr.ill_formed_ast
+
+let empty_record loc = err loc "Records cannot be empty."
+let invalid_tuple loc = err loc "Tuples must have at least 2 components."
+let no_args loc = err loc "Function application with no argument."
+let empty_let loc = err loc "Let with no bindings."
+let empty_type loc = err loc "Type declarations cannot be empty."
+let complex_id loc = err loc "Functor application not allowed here."
+let module_type_substitution_missing_rhs loc =
+  err loc "Module type substitution with no right hand side"
+
+let simple_longident id =
+  let rec is_simple = function
+    | Longident.Lident _ -> true
+    | Longident.Ldot (id, _) -> is_simple id
+    | Longident.Lapply _ -> false
+  in
+  if not (is_simple id.txt) then complex_id id.loc
+
+let iterator =
+  let super = Ast_iterator.default_iterator in
+  let type_declaration self td =
+    super.type_declaration self td;
+    let loc = td.ptype_loc in
+    match td.ptype_kind with
+    | Ptype_record [] -> empty_record loc
+    | _ -> ()
+  in
+  let typ self ty =
+    super.typ self ty;
+    let loc = ty.ptyp_loc in
+    match ty.ptyp_desc with
+    | Ptyp_tuple ([] | [_]) -> invalid_tuple loc
+    | Ptyp_package (_, cstrs) ->
+      List.iter (fun (id, _) -> simple_longident id) cstrs
+    | _ -> ()
+  in
+  let pat self pat =
+    begin match pat.ppat_desc with
+    | Ppat_construct (_, Some (_, ({ppat_desc = Ppat_tuple _} as p)))
+      when Builtin_attributes.explicit_arity pat.ppat_attributes ->
+        super.pat self p (* allow unary tuple, see GPR#523. *)
+    | _ ->
+        super.pat self pat
+    end;
+    let loc = pat.ppat_loc in
+    match pat.ppat_desc with
+    | Ppat_tuple ([] | [_]) -> invalid_tuple loc
+    | Ppat_record ([], _) -> empty_record loc
+    | Ppat_construct (id, _) -> simple_longident id
+    | Ppat_record (fields, _) ->
+      List.iter (fun (id, _) -> simple_longident id) fields
+    | _ -> ()
+  in
+  let expr self exp =
+    begin match exp.pexp_desc with
+    | Pexp_construct (_, Some ({pexp_desc = Pexp_tuple _} as e))
+      when Builtin_attributes.explicit_arity exp.pexp_attributes ->
+        super.expr self e (* allow unary tuple, see GPR#523. *)
+    | _ ->
+        super.expr self exp
+    end;
+    let loc = exp.pexp_loc in
+    match exp.pexp_desc with
+    | Pexp_tuple ([] | [_]) -> invalid_tuple loc
+    | Pexp_record ([], _) -> empty_record loc
+    | Pexp_apply (_, []) -> no_args loc
+    | Pexp_let (_, [], _) -> empty_let loc
+    | Pexp_ident id
+    | Pexp_construct (id, _)
+    | Pexp_field (_, id)
+    | Pexp_setfield (_, id, _)
+    | Pexp_new id -> simple_longident id
+    | Pexp_record (fields, _) ->
+      List.iter (fun (id, _) -> simple_longident id) fields
+    | _ -> ()
+  in
+  let extension_constructor self ec =
+    super.extension_constructor self ec;
+    match ec.pext_kind with
+    | Pext_rebind id -> simple_longident id
+    | _ -> ()
+  in
+  let class_expr self ce =
+    super.class_expr self ce;
+    let loc = ce.pcl_loc in
+    match ce.pcl_desc with
+    | Pcl_apply (_, []) -> no_args loc
+    | Pcl_constr (id, _) -> simple_longident id
+    | _ -> ()
+  in
+  let module_type self mty =
+    super.module_type self mty;
+    match mty.pmty_desc with
+    | Pmty_alias id -> simple_longident id
+    | _ -> ()
+  in
+  let open_description self opn =
+    super.open_description self opn
+  in
+  let with_constraint self wc =
+    super.with_constraint self wc;
+    match wc with
+    | Pwith_type (id, _)
+    | Pwith_module (id, _) -> simple_longident id
+    | _ -> ()
+  in
+  let module_expr self me =
+    super.module_expr self me;
+    match me.pmod_desc with
+    | Pmod_ident id -> simple_longident id
+    | _ -> ()
+  in
+  let structure_item self st =
+    super.structure_item self st;
+    let loc = st.pstr_loc in
+    match st.pstr_desc with
+    | Pstr_type (_, []) -> empty_type loc
+    | Pstr_value (_, []) -> empty_let loc
+    | _ -> ()
+  in
+  let signature_item self sg =
+    super.signature_item self sg;
+    let loc = sg.psig_loc in
+    match sg.psig_desc with
+    | Psig_type (_, []) -> empty_type loc
+    | Psig_modtypesubst {pmtd_type=None; _ } ->
+        module_type_substitution_missing_rhs loc
+    | _ -> ()
+  in
+  let row_field self field =
+    super.row_field self field;
+    let loc = field.prf_loc in
+    match field.prf_desc with
+    | Rtag _ -> ()
+    | Rinherit _ ->
+      if field.prf_attributes = []
+      then ()
+      else err loc
+          "In variant types, attaching attributes to inherited \
+           subtypes is not allowed."
+  in
+  let object_field self field =
+    super.object_field self field;
+    let loc = field.pof_loc in
+    match field.pof_desc with
+    | Otag _ -> ()
+    | Oinherit _ ->
+      if field.pof_attributes = []
+      then ()
+      else err loc
+          "In object types, attaching attributes to inherited \
+           subtypes is not allowed."
+  in
+  { super with
+    type_declaration
+  ; typ
+  ; pat
+  ; expr
+  ; extension_constructor
+  ; class_expr
+  ; module_expr
+  ; module_type
+  ; open_description
+  ; with_constraint
+  ; structure_item
+  ; signature_item
+  ; row_field
+  ; object_field
+  }
+
+let structure st = iterator.structure iterator st
+let signature sg = iterator.signature iterator sg
diff --git a/upstream/ocaml_413/parsing/ast_invariants.mli b/upstream/ocaml_413/parsing/ast_invariants.mli
new file mode 100644
index 0000000..fdb56aa
--- /dev/null
+++ b/upstream/ocaml_413/parsing/ast_invariants.mli
@@ -0,0 +1,23 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2015 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Check AST invariants
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+val structure : Parsetree.structure -> unit
+val signature : Parsetree.signature -> unit
diff --git a/upstream/ocaml_413/parsing/ast_iterator.ml b/upstream/ocaml_413/parsing/ast_iterator.ml
new file mode 100644
index 0000000..0b88be7
--- /dev/null
+++ b/upstream/ocaml_413/parsing/ast_iterator.ml
@@ -0,0 +1,682 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Nicolas Ojeda Bar, LexiFi                         *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* A generic Parsetree mapping class *)
+
+(*
+[@@@ocaml.warning "+9"]
+  (* Ensure that record patterns don't miss any field. *)
+*)
+
+
+open Parsetree
+open Location
+
+type iterator = {
+  attribute: iterator -> attribute -> unit;
+  attributes: iterator -> attribute list -> unit;
+  binding_op: iterator -> binding_op -> unit;
+  case: iterator -> case -> unit;
+  cases: iterator -> case list -> unit;
+  class_declaration: iterator -> class_declaration -> unit;
+  class_description: iterator -> class_description -> unit;
+  class_expr: iterator -> class_expr -> unit;
+  class_field: iterator -> class_field -> unit;
+  class_signature: iterator -> class_signature -> unit;
+  class_structure: iterator -> class_structure -> unit;
+  class_type: iterator -> class_type -> unit;
+  class_type_declaration: iterator -> class_type_declaration -> unit;
+  class_type_field: iterator -> class_type_field -> unit;
+  constructor_declaration: iterator -> constructor_declaration -> unit;
+  expr: iterator -> expression -> unit;
+  extension: iterator -> extension -> unit;
+  extension_constructor: iterator -> extension_constructor -> unit;
+  include_declaration: iterator -> include_declaration -> unit;
+  include_description: iterator -> include_description -> unit;
+  label_declaration: iterator -> label_declaration -> unit;
+  location: iterator -> Location.t -> unit;
+  module_binding: iterator -> module_binding -> unit;
+  module_declaration: iterator -> module_declaration -> unit;
+  module_substitution: iterator -> module_substitution -> unit;
+  module_expr: iterator -> module_expr -> unit;
+  module_type: iterator -> module_type -> unit;
+  module_type_declaration: iterator -> module_type_declaration -> unit;
+  open_declaration: iterator -> open_declaration -> unit;
+  open_description: iterator -> open_description -> unit;
+  pat: iterator -> pattern -> unit;
+  payload: iterator -> payload -> unit;
+  signature: iterator -> signature -> unit;
+  signature_item: iterator -> signature_item -> unit;
+  structure: iterator -> structure -> unit;
+  structure_item: iterator -> structure_item -> unit;
+  typ: iterator -> core_type -> unit;
+  row_field: iterator -> row_field -> unit;
+  object_field: iterator -> object_field -> unit;
+  type_declaration: iterator -> type_declaration -> unit;
+  type_extension: iterator -> type_extension -> unit;
+  type_exception: iterator -> type_exception -> unit;
+  type_kind: iterator -> type_kind -> unit;
+  value_binding: iterator -> value_binding -> unit;
+  value_description: iterator -> value_description -> unit;
+  with_constraint: iterator -> with_constraint -> unit;
+}
+(** A [iterator] record implements one "method" per syntactic category,
+    using an open recursion style: each method takes as its first
+    argument the iterator to be applied to children in the syntax
+    tree. *)
+
+let iter_fst f (x, _) = f x
+let iter_snd f (_, y) = f y
+let iter_tuple f1 f2 (x, y) = f1 x; f2 y
+let iter_tuple3 f1 f2 f3 (x, y, z) = f1 x; f2 y; f3 z
+let iter_opt f = function None -> () | Some x -> f x
+
+let iter_loc sub {loc; txt = _} = sub.location sub loc
+
+module T = struct
+  (* Type expressions for the core language *)
+
+  let row_field sub {
+      prf_desc;
+      prf_loc;
+      prf_attributes;
+    } =
+    sub.location sub prf_loc;
+    sub.attributes sub prf_attributes;
+    match prf_desc with
+    | Rtag (_, _, tl) -> List.iter (sub.typ sub) tl
+    | Rinherit t -> sub.typ sub t
+
+  let object_field sub {
+      pof_desc;
+      pof_loc;
+      pof_attributes;
+    } =
+    sub.location sub pof_loc;
+    sub.attributes sub pof_attributes;
+    match pof_desc with
+    | Otag (_, t) -> sub.typ sub t
+    | Oinherit t -> sub.typ sub t
+
+  let iter sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Ptyp_any
+    | Ptyp_var _ -> ()
+    | Ptyp_arrow (_lab, t1, t2) ->
+        sub.typ sub t1; sub.typ sub t2
+    | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl
+    | Ptyp_constr (lid, tl) ->
+        iter_loc sub lid; List.iter (sub.typ sub) tl
+    | Ptyp_object (ol, _o) ->
+        List.iter (object_field sub) ol
+    | Ptyp_class (lid, tl) ->
+        iter_loc sub lid; List.iter (sub.typ sub) tl
+    | Ptyp_alias (t, _) -> sub.typ sub t
+    | Ptyp_variant (rl, _b, _ll) ->
+        List.iter (row_field sub) rl
+    | Ptyp_poly (_, t) -> sub.typ sub t
+    | Ptyp_package (lid, l) ->
+        iter_loc sub lid;
+        List.iter (iter_tuple (iter_loc sub) (sub.typ sub)) l
+    | Ptyp_extension x -> sub.extension sub x
+
+  let iter_type_declaration sub
+      {ptype_name; ptype_params; ptype_cstrs;
+       ptype_kind;
+       ptype_private = _;
+       ptype_manifest;
+       ptype_attributes;
+       ptype_loc} =
+    iter_loc sub ptype_name;
+    List.iter (iter_fst (sub.typ sub)) ptype_params;
+    List.iter
+      (iter_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub))
+      ptype_cstrs;
+    sub.type_kind sub ptype_kind;
+    iter_opt (sub.typ sub) ptype_manifest;
+    sub.location sub ptype_loc;
+    sub.attributes sub ptype_attributes
+
+  let iter_type_kind sub = function
+    | Ptype_abstract -> ()
+    | Ptype_variant l ->
+        List.iter (sub.constructor_declaration sub) l
+    | Ptype_record l -> List.iter (sub.label_declaration sub) l
+    | Ptype_open -> ()
+
+  let iter_constructor_arguments sub = function
+    | Pcstr_tuple l -> List.iter (sub.typ sub) l
+    | Pcstr_record l ->
+        List.iter (sub.label_declaration sub) l
+
+  let iter_type_extension sub
+      {ptyext_path; ptyext_params;
+       ptyext_constructors;
+       ptyext_private = _;
+       ptyext_loc;
+       ptyext_attributes} =
+    iter_loc sub ptyext_path;
+    List.iter (sub.extension_constructor sub) ptyext_constructors;
+    List.iter (iter_fst (sub.typ sub)) ptyext_params;
+    sub.location sub ptyext_loc;
+    sub.attributes sub ptyext_attributes
+
+  let iter_type_exception sub
+      {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} =
+    sub.extension_constructor sub ptyexn_constructor;
+    sub.location sub ptyexn_loc;
+    sub.attributes sub ptyexn_attributes
+
+  let iter_extension_constructor_kind sub = function
+      Pext_decl(ctl, cto) ->
+        iter_constructor_arguments sub ctl; iter_opt (sub.typ sub) cto
+    | Pext_rebind li ->
+        iter_loc sub li
+
+  let iter_extension_constructor sub
+      {pext_name;
+       pext_kind;
+       pext_loc;
+       pext_attributes} =
+    iter_loc sub pext_name;
+    iter_extension_constructor_kind sub pext_kind;
+    sub.location sub pext_loc;
+    sub.attributes sub pext_attributes
+
+end
+
+module CT = struct
+  (* Type expressions for the class language *)
+
+  let iter sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pcty_constr (lid, tys) ->
+        iter_loc sub lid; List.iter (sub.typ sub) tys
+    | Pcty_signature x -> sub.class_signature sub x
+    | Pcty_arrow (_lab, t, ct) ->
+        sub.typ sub t; sub.class_type sub ct
+    | Pcty_extension x -> sub.extension sub x
+    | Pcty_open (o, e) ->
+        sub.open_description sub o; sub.class_type sub e
+
+  let iter_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
+    =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pctf_inherit ct -> sub.class_type sub ct
+    | Pctf_val (_s, _m, _v, t) -> sub.typ sub t
+    | Pctf_method (_s, _p, _v, t) -> sub.typ sub t
+    | Pctf_constraint (t1, t2) ->
+        sub.typ sub t1; sub.typ sub t2
+    | Pctf_attribute x -> sub.attribute sub x
+    | Pctf_extension x -> sub.extension sub x
+
+  let iter_signature sub {pcsig_self; pcsig_fields} =
+    sub.typ sub pcsig_self;
+    List.iter (sub.class_type_field sub) pcsig_fields
+end
+
+let iter_functor_param sub = function
+  | Unit -> ()
+  | Named (name, mty) ->
+    iter_loc sub name;
+    sub.module_type sub mty
+
+module MT = struct
+  (* Type expressions for the module language *)
+
+  let iter sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pmty_ident s -> iter_loc sub s
+    | Pmty_alias s -> iter_loc sub s
+    | Pmty_signature sg -> sub.signature sub sg
+    | Pmty_functor (param, mt2) ->
+        iter_functor_param sub param;
+        sub.module_type sub mt2
+    | Pmty_with (mt, l) ->
+        sub.module_type sub mt;
+        List.iter (sub.with_constraint sub) l
+    | Pmty_typeof me -> sub.module_expr sub me
+    | Pmty_extension x -> sub.extension sub x
+
+  let iter_with_constraint sub = function
+    | Pwith_type (lid, d) ->
+        iter_loc sub lid; sub.type_declaration sub d
+    | Pwith_module (lid, lid2) ->
+        iter_loc sub lid; iter_loc sub lid2
+    | Pwith_modtype (lid, mty) ->
+        iter_loc sub lid; sub.module_type sub mty
+    | Pwith_typesubst (lid, d) ->
+        iter_loc sub lid; sub.type_declaration sub d
+    | Pwith_modsubst (s, lid) ->
+        iter_loc sub s; iter_loc sub lid
+    | Pwith_modtypesubst (lid, mty) ->
+        iter_loc sub lid; sub.module_type sub mty
+
+  let iter_signature_item sub {psig_desc = desc; psig_loc = loc} =
+    sub.location sub loc;
+    match desc with
+    | Psig_value vd -> sub.value_description sub vd
+    | Psig_type (_, l)
+    | Psig_typesubst l ->
+      List.iter (sub.type_declaration sub) l
+    | Psig_typext te -> sub.type_extension sub te
+    | Psig_exception ed -> sub.type_exception sub ed
+    | Psig_module x -> sub.module_declaration sub x
+    | Psig_modsubst x -> sub.module_substitution sub x
+    | Psig_recmodule l ->
+        List.iter (sub.module_declaration sub) l
+    | Psig_modtype x | Psig_modtypesubst x -> sub.module_type_declaration sub x
+    | Psig_open x -> sub.open_description sub x
+    | Psig_include x -> sub.include_description sub x
+    | Psig_class l -> List.iter (sub.class_description sub) l
+    | Psig_class_type l ->
+        List.iter (sub.class_type_declaration sub) l
+    | Psig_extension (x, attrs) ->
+        sub.attributes sub attrs;
+        sub.extension sub x
+    | Psig_attribute x -> sub.attribute sub x
+end
+
+
+module M = struct
+  (* Value expressions for the module language *)
+
+  let iter sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pmod_ident x -> iter_loc sub x
+    | Pmod_structure str -> sub.structure sub str
+    | Pmod_functor (param, body) ->
+        iter_functor_param sub param;
+        sub.module_expr sub body
+    | Pmod_apply (m1, m2) ->
+        sub.module_expr sub m1; sub.module_expr sub m2
+    | Pmod_constraint (m, mty) ->
+        sub.module_expr sub m; sub.module_type sub mty
+    | Pmod_unpack e -> sub.expr sub e
+    | Pmod_extension x -> sub.extension sub x
+
+  let iter_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
+    sub.location sub loc;
+    match desc with
+    | Pstr_eval (x, attrs) ->
+        sub.attributes sub attrs; sub.expr sub x
+    | Pstr_value (_r, vbs) -> List.iter (sub.value_binding sub) vbs
+    | Pstr_primitive vd -> sub.value_description sub vd
+    | Pstr_type (_rf, l) -> List.iter (sub.type_declaration sub) l
+    | Pstr_typext te -> sub.type_extension sub te
+    | Pstr_exception ed -> sub.type_exception sub ed
+    | Pstr_module x -> sub.module_binding sub x
+    | Pstr_recmodule l -> List.iter (sub.module_binding sub) l
+    | Pstr_modtype x -> sub.module_type_declaration sub x
+    | Pstr_open x -> sub.open_declaration sub x
+    | Pstr_class l -> List.iter (sub.class_declaration sub) l
+    | Pstr_class_type l ->
+        List.iter (sub.class_type_declaration sub) l
+    | Pstr_include x -> sub.include_declaration sub x
+    | Pstr_extension (x, attrs) ->
+        sub.attributes sub attrs; sub.extension sub x
+    | Pstr_attribute x -> sub.attribute sub x
+end
+
+module E = struct
+  (* Value expressions for the core language *)
+
+  let iter sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pexp_ident x -> iter_loc sub x
+    | Pexp_constant _ -> ()
+    | Pexp_let (_r, vbs, e) ->
+        List.iter (sub.value_binding sub) vbs;
+        sub.expr sub e
+    | Pexp_fun (_lab, def, p, e) ->
+        iter_opt (sub.expr sub) def;
+        sub.pat sub p;
+        sub.expr sub e
+    | Pexp_function pel -> sub.cases sub pel
+    | Pexp_apply (e, l) ->
+        sub.expr sub e; List.iter (iter_snd (sub.expr sub)) l
+    | Pexp_match (e, pel) ->
+        sub.expr sub e; sub.cases sub pel
+    | Pexp_try (e, pel) -> sub.expr sub e; sub.cases sub pel
+    | Pexp_tuple el -> List.iter (sub.expr sub) el
+    | Pexp_construct (lid, arg) ->
+        iter_loc sub lid; iter_opt (sub.expr sub) arg
+    | Pexp_variant (_lab, eo) ->
+        iter_opt (sub.expr sub) eo
+    | Pexp_record (l, eo) ->
+        List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) l;
+        iter_opt (sub.expr sub) eo
+    | Pexp_field (e, lid) ->
+        sub.expr sub e; iter_loc sub lid
+    | Pexp_setfield (e1, lid, e2) ->
+        sub.expr sub e1; iter_loc sub lid;
+        sub.expr sub e2
+    | Pexp_array el -> List.iter (sub.expr sub) el
+    | Pexp_ifthenelse (e1, e2, e3) ->
+        sub.expr sub e1; sub.expr sub e2;
+        iter_opt (sub.expr sub) e3
+    | Pexp_sequence (e1, e2) ->
+        sub.expr sub e1; sub.expr sub e2
+    | Pexp_while (e1, e2) ->
+        sub.expr sub e1; sub.expr sub e2
+    | Pexp_for (p, e1, e2, _d, e3) ->
+        sub.pat sub p; sub.expr sub e1; sub.expr sub e2;
+        sub.expr sub e3
+    | Pexp_coerce (e, t1, t2) ->
+        sub.expr sub e; iter_opt (sub.typ sub) t1;
+        sub.typ sub t2
+    | Pexp_constraint (e, t) ->
+        sub.expr sub e; sub.typ sub t
+    | Pexp_send (e, _s) -> sub.expr sub e
+    | Pexp_new lid -> iter_loc sub lid
+    | Pexp_setinstvar (s, e) ->
+        iter_loc sub s; sub.expr sub e
+    | Pexp_override sel ->
+        List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) sel
+    | Pexp_letmodule (s, me, e) ->
+        iter_loc sub s; sub.module_expr sub me;
+        sub.expr sub e
+    | Pexp_letexception (cd, e) ->
+        sub.extension_constructor sub cd;
+        sub.expr sub e
+    | Pexp_assert e -> sub.expr sub e
+    | Pexp_lazy e -> sub.expr sub e
+    | Pexp_poly (e, t) ->
+        sub.expr sub e; iter_opt (sub.typ sub) t
+    | Pexp_object cls -> sub.class_structure sub cls
+    | Pexp_newtype (_s, e) -> sub.expr sub e
+    | Pexp_pack me -> sub.module_expr sub me
+    | Pexp_open (o, e) ->
+        sub.open_declaration sub o; sub.expr sub e
+    | Pexp_letop {let_; ands; body} ->
+        sub.binding_op sub let_;
+        List.iter (sub.binding_op sub) ands;
+        sub.expr sub body
+    | Pexp_extension x -> sub.extension sub x
+    | Pexp_unreachable -> ()
+
+  let iter_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} =
+    iter_loc sub pbop_op;
+    sub.pat sub pbop_pat;
+    sub.expr sub pbop_exp;
+    sub.location sub pbop_loc
+
+end
+
+module P = struct
+  (* Patterns *)
+
+  let iter sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Ppat_any -> ()
+    | Ppat_var s -> iter_loc sub s
+    | Ppat_alias (p, s) -> sub.pat sub p; iter_loc sub s
+    | Ppat_constant _ -> ()
+    | Ppat_interval _ -> ()
+    | Ppat_tuple pl -> List.iter (sub.pat sub) pl
+    | Ppat_construct (l, p) ->
+        iter_loc sub l;
+        iter_opt
+          (fun (vl,p) ->
+            List.iter (iter_loc sub) vl;
+            sub.pat sub p)
+          p
+    | Ppat_variant (_l, p) -> iter_opt (sub.pat sub) p
+    | Ppat_record (lpl, _cf) ->
+        List.iter (iter_tuple (iter_loc sub) (sub.pat sub)) lpl
+    | Ppat_array pl -> List.iter (sub.pat sub) pl
+    | Ppat_or (p1, p2) -> sub.pat sub p1; sub.pat sub p2
+    | Ppat_constraint (p, t) ->
+        sub.pat sub p; sub.typ sub t
+    | Ppat_type s -> iter_loc sub s
+    | Ppat_lazy p -> sub.pat sub p
+    | Ppat_unpack s -> iter_loc sub s
+    | Ppat_exception p -> sub.pat sub p
+    | Ppat_extension x -> sub.extension sub x
+    | Ppat_open (lid, p) ->
+        iter_loc sub lid; sub.pat sub p
+
+end
+
+module CE = struct
+  (* Value expressions for the class language *)
+
+  let iter sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pcl_constr (lid, tys) ->
+        iter_loc sub lid; List.iter (sub.typ sub) tys
+    | Pcl_structure s ->
+        sub.class_structure sub s
+    | Pcl_fun (_lab, e, p, ce) ->
+        iter_opt (sub.expr sub) e;
+        sub.pat sub p;
+        sub.class_expr sub ce
+    | Pcl_apply (ce, l) ->
+        sub.class_expr sub ce;
+        List.iter (iter_snd (sub.expr sub)) l
+    | Pcl_let (_r, vbs, ce) ->
+        List.iter (sub.value_binding sub) vbs;
+        sub.class_expr sub ce
+    | Pcl_constraint (ce, ct) ->
+        sub.class_expr sub ce; sub.class_type sub ct
+    | Pcl_extension x -> sub.extension sub x
+    | Pcl_open (o, e) ->
+        sub.open_description sub o; sub.class_expr sub e
+
+  let iter_kind sub = function
+    | Cfk_concrete (_o, e) -> sub.expr sub e
+    | Cfk_virtual t -> sub.typ sub t
+
+  let iter_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pcf_inherit (_o, ce, _s) -> sub.class_expr sub ce
+    | Pcf_val (s, _m, k) -> iter_loc sub s; iter_kind sub k
+    | Pcf_method (s, _p, k) ->
+        iter_loc sub s; iter_kind sub k
+    | Pcf_constraint (t1, t2) ->
+        sub.typ sub t1; sub.typ sub t2
+    | Pcf_initializer e -> sub.expr sub e
+    | Pcf_attribute x -> sub.attribute sub x
+    | Pcf_extension x -> sub.extension sub x
+
+  let iter_structure sub {pcstr_self; pcstr_fields} =
+    sub.pat sub pcstr_self;
+    List.iter (sub.class_field sub) pcstr_fields
+
+  let class_infos sub f {pci_virt = _; pci_params = pl; pci_name; pci_expr;
+                         pci_loc; pci_attributes} =
+    List.iter (iter_fst (sub.typ sub)) pl;
+    iter_loc sub pci_name;
+    f pci_expr;
+    sub.location sub pci_loc;
+    sub.attributes sub pci_attributes
+end
+
+(* Now, a generic AST mapper, to be extended to cover all kinds and
+   cases of the OCaml grammar.  The default behavior of the mapper is
+   the identity. *)
+
+let default_iterator =
+  {
+    structure = (fun this l -> List.iter (this.structure_item this) l);
+    structure_item = M.iter_structure_item;
+    module_expr = M.iter;
+    signature = (fun this l -> List.iter (this.signature_item this) l);
+    signature_item = MT.iter_signature_item;
+    module_type = MT.iter;
+    with_constraint = MT.iter_with_constraint;
+    class_declaration =
+      (fun this -> CE.class_infos this (this.class_expr this));
+    class_expr = CE.iter;
+    class_field = CE.iter_field;
+    class_structure = CE.iter_structure;
+    class_type = CT.iter;
+    class_type_field = CT.iter_field;
+    class_signature = CT.iter_signature;
+    class_type_declaration =
+      (fun this -> CE.class_infos this (this.class_type this));
+    class_description =
+      (fun this -> CE.class_infos this (this.class_type this));
+    type_declaration = T.iter_type_declaration;
+    type_kind = T.iter_type_kind;
+    typ = T.iter;
+    row_field = T.row_field;
+    object_field = T.object_field;
+    type_extension = T.iter_type_extension;
+    type_exception = T.iter_type_exception;
+    extension_constructor = T.iter_extension_constructor;
+    value_description =
+      (fun this {pval_name; pval_type; pval_prim = _; pval_loc;
+                 pval_attributes} ->
+        iter_loc this pval_name;
+        this.typ this pval_type;
+        this.location this pval_loc;
+        this.attributes this pval_attributes;
+      );
+
+    pat = P.iter;
+    expr = E.iter;
+    binding_op = E.iter_binding_op;
+
+    module_declaration =
+      (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} ->
+         iter_loc this pmd_name;
+         this.module_type this pmd_type;
+         this.location this pmd_loc;
+         this.attributes this pmd_attributes;
+      );
+
+    module_substitution =
+      (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} ->
+         iter_loc this pms_name;
+         iter_loc this pms_manifest;
+         this.location this pms_loc;
+         this.attributes this pms_attributes;
+      );
+
+    module_type_declaration =
+      (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} ->
+         iter_loc this pmtd_name;
+         iter_opt (this.module_type this) pmtd_type;
+         this.location this pmtd_loc;
+         this.attributes this pmtd_attributes;
+      );
+
+    module_binding =
+      (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} ->
+         iter_loc this pmb_name; this.module_expr this pmb_expr;
+         this.location this pmb_loc;
+         this.attributes this pmb_attributes;
+      );
+
+    open_declaration =
+      (fun this {popen_expr; popen_override = _; popen_attributes; popen_loc} ->
+         this.module_expr this popen_expr;
+         this.location this popen_loc;
+         this.attributes this popen_attributes
+      );
+
+    open_description =
+      (fun this {popen_expr; popen_override = _; popen_attributes; popen_loc} ->
+         iter_loc this popen_expr;
+         this.location this popen_loc;
+         this.attributes this popen_attributes
+      );
+
+
+    include_description =
+      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+         this.module_type this pincl_mod;
+         this.location this pincl_loc;
+         this.attributes this pincl_attributes
+      );
+
+    include_declaration =
+      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+         this.module_expr this pincl_mod;
+         this.location this pincl_loc;
+         this.attributes this pincl_attributes
+      );
+
+
+    value_binding =
+      (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} ->
+         this.pat this pvb_pat;
+         this.expr this pvb_expr;
+         this.location this pvb_loc;
+         this.attributes this pvb_attributes
+      );
+
+
+    constructor_declaration =
+      (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} ->
+         iter_loc this pcd_name;
+         T.iter_constructor_arguments this pcd_args;
+         iter_opt (this.typ this) pcd_res;
+         this.location this pcd_loc;
+         this.attributes this pcd_attributes
+      );
+
+    label_declaration =
+      (fun this {pld_name; pld_type; pld_loc; pld_mutable = _; pld_attributes}->
+         iter_loc this pld_name;
+         this.typ this pld_type;
+         this.location this pld_loc;
+         this.attributes this pld_attributes
+      );
+
+    cases = (fun this l -> List.iter (this.case this) l);
+    case =
+      (fun this {pc_lhs; pc_guard; pc_rhs} ->
+         this.pat this pc_lhs;
+         iter_opt (this.expr this) pc_guard;
+         this.expr this pc_rhs
+      );
+
+    location = (fun _this _l -> ());
+
+    extension = (fun this (s, e) -> iter_loc this s; this.payload this e);
+    attribute = (fun this a ->
+      iter_loc this a.attr_name;
+      this.payload this a.attr_payload;
+      this.location this a.attr_loc
+    );
+    attributes = (fun this l -> List.iter (this.attribute this) l);
+    payload =
+      (fun this -> function
+         | PStr x -> this.structure this x
+         | PSig x -> this.signature this x
+         | PTyp x -> this.typ this x
+         | PPat (x, g) -> this.pat this x; iter_opt (this.expr this) g
+      );
+  }
diff --git a/upstream/ocaml_413/parsing/ast_iterator.mli b/upstream/ocaml_413/parsing/ast_iterator.mli
new file mode 100644
index 0000000..26308d2
--- /dev/null
+++ b/upstream/ocaml_413/parsing/ast_iterator.mli
@@ -0,0 +1,83 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Nicolas Ojeda Bar, LexiFi                         *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** {!iterator} enables AST inspection using open recursion.  A
+    typical mapper would be based on {!default_iterator}, a trivial iterator,
+    and will fall back on it for handling the syntax it does not modify.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Parsetree
+
+(** {1 A generic Parsetree iterator} *)
+
+type iterator = {
+  attribute: iterator -> attribute -> unit;
+  attributes: iterator -> attribute list -> unit;
+  binding_op: iterator -> binding_op -> unit;
+  case: iterator -> case -> unit;
+  cases: iterator -> case list -> unit;
+  class_declaration: iterator -> class_declaration -> unit;
+  class_description: iterator -> class_description -> unit;
+  class_expr: iterator -> class_expr -> unit;
+  class_field: iterator -> class_field -> unit;
+  class_signature: iterator -> class_signature -> unit;
+  class_structure: iterator -> class_structure -> unit;
+  class_type: iterator -> class_type -> unit;
+  class_type_declaration: iterator -> class_type_declaration -> unit;
+  class_type_field: iterator -> class_type_field -> unit;
+  constructor_declaration: iterator -> constructor_declaration -> unit;
+  expr: iterator -> expression -> unit;
+  extension: iterator -> extension -> unit;
+  extension_constructor: iterator -> extension_constructor -> unit;
+  include_declaration: iterator -> include_declaration -> unit;
+  include_description: iterator -> include_description -> unit;
+  label_declaration: iterator -> label_declaration -> unit;
+  location: iterator -> Location.t -> unit;
+  module_binding: iterator -> module_binding -> unit;
+  module_declaration: iterator -> module_declaration -> unit;
+  module_substitution: iterator -> module_substitution -> unit;
+  module_expr: iterator -> module_expr -> unit;
+  module_type: iterator -> module_type -> unit;
+  module_type_declaration: iterator -> module_type_declaration -> unit;
+  open_declaration: iterator -> open_declaration -> unit;
+  open_description: iterator -> open_description -> unit;
+  pat: iterator -> pattern -> unit;
+  payload: iterator -> payload -> unit;
+  signature: iterator -> signature -> unit;
+  signature_item: iterator -> signature_item -> unit;
+  structure: iterator -> structure -> unit;
+  structure_item: iterator -> structure_item -> unit;
+  typ: iterator -> core_type -> unit;
+  row_field: iterator -> row_field -> unit;
+  object_field: iterator -> object_field -> unit;
+  type_declaration: iterator -> type_declaration -> unit;
+  type_extension: iterator -> type_extension -> unit;
+  type_exception: iterator -> type_exception -> unit;
+  type_kind: iterator -> type_kind -> unit;
+  value_binding: iterator -> value_binding -> unit;
+  value_description: iterator -> value_description -> unit;
+  with_constraint: iterator -> with_constraint -> unit;
+}
+(** A [iterator] record implements one "method" per syntactic category,
+    using an open recursion style: each method takes as its first
+    argument the iterator to be applied to children in the syntax
+    tree. *)
+
+val default_iterator: iterator
+(** A default iterator, which implements a "do not do anything" mapping. *)
diff --git a/upstream/ocaml_413/parsing/ast_mapper.ml b/upstream/ocaml_413/parsing/ast_mapper.ml
new file mode 100644
index 0000000..f23325b
--- /dev/null
+++ b/upstream/ocaml_413/parsing/ast_mapper.ml
@@ -0,0 +1,1078 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* A generic Parsetree mapping class *)
+
+(*
+[@@@ocaml.warning "+9"]
+  (* Ensure that record patterns don't miss any field. *)
+*)
+
+open Parsetree
+open Ast_helper
+open Location
+
+module String = Misc.Stdlib.String
+
+type mapper = {
+  attribute: mapper -> attribute -> attribute;
+  attributes: mapper -> attribute list -> attribute list;
+  binding_op: mapper -> binding_op -> binding_op;
+  case: mapper -> case -> case;
+  cases: mapper -> case list -> case list;
+  class_declaration: mapper -> class_declaration -> class_declaration;
+  class_description: mapper -> class_description -> class_description;
+  class_expr: mapper -> class_expr -> class_expr;
+  class_field: mapper -> class_field -> class_field;
+  class_signature: mapper -> class_signature -> class_signature;
+  class_structure: mapper -> class_structure -> class_structure;
+  class_type: mapper -> class_type -> class_type;
+  class_type_declaration: mapper -> class_type_declaration
+                          -> class_type_declaration;
+  class_type_field: mapper -> class_type_field -> class_type_field;
+  constant: mapper -> constant -> constant;
+  constructor_declaration: mapper -> constructor_declaration
+                           -> constructor_declaration;
+  expr: mapper -> expression -> expression;
+  extension: mapper -> extension -> extension;
+  extension_constructor: mapper -> extension_constructor
+                         -> extension_constructor;
+  include_declaration: mapper -> include_declaration -> include_declaration;
+  include_description: mapper -> include_description -> include_description;
+  label_declaration: mapper -> label_declaration -> label_declaration;
+  location: mapper -> Location.t -> Location.t;
+  module_binding: mapper -> module_binding -> module_binding;
+  module_declaration: mapper -> module_declaration -> module_declaration;
+  module_substitution: mapper -> module_substitution -> module_substitution;
+  module_expr: mapper -> module_expr -> module_expr;
+  module_type: mapper -> module_type -> module_type;
+  module_type_declaration: mapper -> module_type_declaration
+                           -> module_type_declaration;
+  open_declaration: mapper -> open_declaration -> open_declaration;
+  open_description: mapper -> open_description -> open_description;
+  pat: mapper -> pattern -> pattern;
+  payload: mapper -> payload -> payload;
+  signature: mapper -> signature -> signature;
+  signature_item: mapper -> signature_item -> signature_item;
+  structure: mapper -> structure -> structure;
+  structure_item: mapper -> structure_item -> structure_item;
+  typ: mapper -> core_type -> core_type;
+  type_declaration: mapper -> type_declaration -> type_declaration;
+  type_extension: mapper -> type_extension -> type_extension;
+  type_exception: mapper -> type_exception -> type_exception;
+  type_kind: mapper -> type_kind -> type_kind;
+  value_binding: mapper -> value_binding -> value_binding;
+  value_description: mapper -> value_description -> value_description;
+  with_constraint: mapper -> with_constraint -> with_constraint;
+}
+
+let map_fst f (x, y) = (f x, y)
+let map_snd f (x, y) = (x, f y)
+let map_tuple f1 f2 (x, y) = (f1 x, f2 y)
+let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
+let map_opt f = function None -> None | Some x -> Some (f x)
+
+let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}
+
+module C = struct
+  (* Constants *)
+
+  let map sub c = match c with
+    | Pconst_integer _
+    | Pconst_char _
+    | Pconst_float _
+      -> c
+    | Pconst_string (s, loc, quotation_delimiter) ->
+        let loc = sub.location sub loc in
+        Const.string ~loc ?quotation_delimiter s
+end
+
+module T = struct
+  (* Type expressions for the core language *)
+
+  let row_field sub {
+      prf_desc;
+      prf_loc;
+      prf_attributes;
+    } =
+    let loc = sub.location sub prf_loc in
+    let attrs = sub.attributes sub prf_attributes in
+    let desc = match prf_desc with
+      | Rtag (l, b, tl) -> Rtag (map_loc sub l, b, List.map (sub.typ sub) tl)
+      | Rinherit t -> Rinherit (sub.typ sub t)
+    in
+    Rf.mk ~loc ~attrs desc
+
+  let object_field sub {
+      pof_desc;
+      pof_loc;
+      pof_attributes;
+    } =
+    let loc = sub.location sub pof_loc in
+    let attrs = sub.attributes sub pof_attributes in
+    let desc = match pof_desc with
+      | Otag (l, t) -> Otag (map_loc sub l, sub.typ sub t)
+      | Oinherit t -> Oinherit (sub.typ sub t)
+    in
+    Of.mk ~loc ~attrs desc
+
+  let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
+    let open Typ in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Ptyp_any -> any ~loc ~attrs ()
+    | Ptyp_var s -> var ~loc ~attrs s
+    | Ptyp_arrow (lab, t1, t2) ->
+        arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2)
+    | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
+    | Ptyp_constr (lid, tl) ->
+        constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
+    | Ptyp_object (l, o) ->
+        object_ ~loc ~attrs (List.map (object_field sub) l) o
+    | Ptyp_class (lid, tl) ->
+        class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
+    | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s
+    | Ptyp_variant (rl, b, ll) ->
+        variant ~loc ~attrs (List.map (row_field sub) rl) b ll
+    | Ptyp_poly (sl, t) -> poly ~loc ~attrs
+                             (List.map (map_loc sub) sl) (sub.typ sub t)
+    | Ptyp_package (lid, l) ->
+        package ~loc ~attrs (map_loc sub lid)
+          (List.map (map_tuple (map_loc sub) (sub.typ sub)) l)
+    | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_type_declaration sub
+      {ptype_name; ptype_params; ptype_cstrs;
+       ptype_kind;
+       ptype_private;
+       ptype_manifest;
+       ptype_attributes;
+       ptype_loc} =
+    let loc = sub.location sub ptype_loc in
+    let attrs = sub.attributes sub ptype_attributes in
+    Type.mk ~loc ~attrs (map_loc sub ptype_name)
+      ~params:(List.map (map_fst (sub.typ sub)) ptype_params)
+      ~priv:ptype_private
+      ~cstrs:(List.map
+                (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub))
+                ptype_cstrs)
+      ~kind:(sub.type_kind sub ptype_kind)
+      ?manifest:(map_opt (sub.typ sub) ptype_manifest)
+
+  let map_type_kind sub = function
+    | Ptype_abstract -> Ptype_abstract
+    | Ptype_variant l ->
+        Ptype_variant (List.map (sub.constructor_declaration sub) l)
+    | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l)
+    | Ptype_open -> Ptype_open
+
+  let map_constructor_arguments sub = function
+    | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l)
+    | Pcstr_record l ->
+        Pcstr_record (List.map (sub.label_declaration sub) l)
+
+  let map_type_extension sub
+      {ptyext_path; ptyext_params;
+       ptyext_constructors;
+       ptyext_private;
+       ptyext_loc;
+       ptyext_attributes} =
+    let loc = sub.location sub ptyext_loc in
+    let attrs = sub.attributes sub ptyext_attributes in
+    Te.mk ~loc ~attrs
+      (map_loc sub ptyext_path)
+      (List.map (sub.extension_constructor sub) ptyext_constructors)
+      ~params:(List.map (map_fst (sub.typ sub)) ptyext_params)
+      ~priv:ptyext_private
+
+  let map_type_exception sub
+      {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} =
+    let loc = sub.location sub ptyexn_loc in
+    let attrs = sub.attributes sub ptyexn_attributes in
+    Te.mk_exception ~loc ~attrs
+      (sub.extension_constructor sub ptyexn_constructor)
+
+  let map_extension_constructor_kind sub = function
+      Pext_decl(ctl, cto) ->
+        Pext_decl(map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto)
+    | Pext_rebind li ->
+        Pext_rebind (map_loc sub li)
+
+  let map_extension_constructor sub
+      {pext_name;
+       pext_kind;
+       pext_loc;
+       pext_attributes} =
+    let loc = sub.location sub pext_loc in
+    let attrs = sub.attributes sub pext_attributes in
+    Te.constructor ~loc ~attrs
+      (map_loc sub pext_name)
+      (map_extension_constructor_kind sub pext_kind)
+
+end
+
+module CT = struct
+  (* Type expressions for the class language *)
+
+  let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} =
+    let open Cty in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pcty_constr (lid, tys) ->
+        constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
+    | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x)
+    | Pcty_arrow (lab, t, ct) ->
+        arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct)
+    | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x)
+    | Pcty_open (o, ct) ->
+        open_ ~loc ~attrs (sub.open_description sub o) (sub.class_type sub ct)
+
+  let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
+    =
+    let open Ctf in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct)
+    | Pctf_val (s, m, v, t) ->
+        val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t)
+    | Pctf_method (s, p, v, t) ->
+        method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t)
+    | Pctf_constraint (t1, t2) ->
+        constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
+    | Pctf_attribute x -> attribute ~loc (sub.attribute sub x)
+    | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_signature sub {pcsig_self; pcsig_fields} =
+    Csig.mk
+      (sub.typ sub pcsig_self)
+      (List.map (sub.class_type_field sub) pcsig_fields)
+end
+
+let map_functor_param sub = function
+  | Unit -> Unit
+  | Named (s, mt) -> Named (map_loc sub s, sub.module_type sub mt)
+
+module MT = struct
+  (* Type expressions for the module language *)
+
+  let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} =
+    let open Mty in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s)
+    | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s)
+    | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg)
+    | Pmty_functor (param, mt) ->
+        functor_ ~loc ~attrs
+          (map_functor_param sub param)
+          (sub.module_type sub mt)
+    | Pmty_with (mt, l) ->
+        with_ ~loc ~attrs (sub.module_type sub mt)
+          (List.map (sub.with_constraint sub) l)
+    | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me)
+    | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_with_constraint sub = function
+    | Pwith_type (lid, d) ->
+        Pwith_type (map_loc sub lid, sub.type_declaration sub d)
+    | Pwith_module (lid, lid2) ->
+        Pwith_module (map_loc sub lid, map_loc sub lid2)
+    | Pwith_modtype (lid, mty) ->
+        Pwith_modtype (map_loc sub lid, sub.module_type sub mty)
+    | Pwith_typesubst (lid, d) ->
+        Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d)
+    | Pwith_modsubst (s, lid) ->
+        Pwith_modsubst (map_loc sub s, map_loc sub lid)
+    | Pwith_modtypesubst (lid, mty) ->
+        Pwith_modtypesubst (map_loc sub lid, sub.module_type sub mty)
+
+  let map_signature_item sub {psig_desc = desc; psig_loc = loc} =
+    let open Sig in
+    let loc = sub.location sub loc in
+    match desc with
+    | Psig_value vd -> value ~loc (sub.value_description sub vd)
+    | Psig_type (rf, l) ->
+        type_ ~loc rf (List.map (sub.type_declaration sub) l)
+    | Psig_typesubst l ->
+        type_subst ~loc (List.map (sub.type_declaration sub) l)
+    | Psig_typext te -> type_extension ~loc (sub.type_extension sub te)
+    | Psig_exception ed -> exception_ ~loc (sub.type_exception sub ed)
+    | Psig_module x -> module_ ~loc (sub.module_declaration sub x)
+    | Psig_modsubst x -> mod_subst ~loc (sub.module_substitution sub x)
+    | Psig_recmodule l ->
+        rec_module ~loc (List.map (sub.module_declaration sub) l)
+    | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
+    | Psig_modtypesubst x ->
+        modtype_subst ~loc (sub.module_type_declaration sub x)
+    | Psig_open x -> open_ ~loc (sub.open_description sub x)
+    | Psig_include x -> include_ ~loc (sub.include_description sub x)
+    | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l)
+    | Psig_class_type l ->
+        class_type ~loc (List.map (sub.class_type_declaration sub) l)
+    | Psig_extension (x, attrs) ->
+        let attrs = sub.attributes sub attrs in
+        extension ~loc ~attrs (sub.extension sub x)
+    | Psig_attribute x -> attribute ~loc (sub.attribute sub x)
+end
+
+
+module M = struct
+  (* Value expressions for the module language *)
+
+  let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} =
+    let open Mod in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x)
+    | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str)
+    | Pmod_functor (param, body) ->
+        functor_ ~loc ~attrs
+          (map_functor_param sub param)
+          (sub.module_expr sub body)
+    | Pmod_apply (m1, m2) ->
+        apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2)
+    | Pmod_constraint (m, mty) ->
+        constraint_ ~loc ~attrs (sub.module_expr sub m)
+                    (sub.module_type sub mty)
+    | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e)
+    | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
+    let open Str in
+    let loc = sub.location sub loc in
+    match desc with
+    | Pstr_eval (x, attrs) ->
+        let attrs = sub.attributes sub attrs in
+        eval ~loc ~attrs (sub.expr sub x)
+    | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs)
+    | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd)
+    | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l)
+    | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te)
+    | Pstr_exception ed -> exception_ ~loc (sub.type_exception sub ed)
+    | Pstr_module x -> module_ ~loc (sub.module_binding sub x)
+    | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l)
+    | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
+    | Pstr_open x -> open_ ~loc (sub.open_declaration sub x)
+    | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l)
+    | Pstr_class_type l ->
+        class_type ~loc (List.map (sub.class_type_declaration sub) l)
+    | Pstr_include x -> include_ ~loc (sub.include_declaration sub x)
+    | Pstr_extension (x, attrs) ->
+        let attrs = sub.attributes sub attrs in
+        extension ~loc ~attrs (sub.extension sub x)
+    | Pstr_attribute x -> attribute ~loc (sub.attribute sub x)
+end
+
+module E = struct
+  (* Value expressions for the core language *)
+
+  let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} =
+    let open Exp in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x)
+    | Pexp_constant x -> constant ~loc ~attrs (sub.constant sub x)
+    | Pexp_let (r, vbs, e) ->
+        let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
+          (sub.expr sub e)
+    | Pexp_fun (lab, def, p, e) ->
+        fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p)
+          (sub.expr sub e)
+    | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel)
+    | Pexp_apply (e, l) ->
+        apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l)
+    | Pexp_match (e, pel) ->
+        match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
+    | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
+    | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el)
+    | Pexp_construct (lid, arg) ->
+        construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg)
+    | Pexp_variant (lab, eo) ->
+        variant ~loc ~attrs lab (map_opt (sub.expr sub) eo)
+    | Pexp_record (l, eo) ->
+        record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l)
+          (map_opt (sub.expr sub) eo)
+    | Pexp_field (e, lid) ->
+        field ~loc ~attrs (sub.expr sub e) (map_loc sub lid)
+    | Pexp_setfield (e1, lid, e2) ->
+        setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid)
+          (sub.expr sub e2)
+    | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el)
+    | Pexp_ifthenelse (e1, e2, e3) ->
+        ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
+          (map_opt (sub.expr sub) e3)
+    | Pexp_sequence (e1, e2) ->
+        sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
+    | Pexp_while (e1, e2) ->
+        while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
+    | Pexp_for (p, e1, e2, d, e3) ->
+        for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d
+          (sub.expr sub e3)
+    | Pexp_coerce (e, t1, t2) ->
+        coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1)
+          (sub.typ sub t2)
+    | Pexp_constraint (e, t) ->
+        constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t)
+    | Pexp_send (e, s) ->
+        send ~loc ~attrs (sub.expr sub e) (map_loc sub s)
+    | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid)
+    | Pexp_setinstvar (s, e) ->
+        setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e)
+    | Pexp_override sel ->
+        override ~loc ~attrs
+          (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel)
+    | Pexp_letmodule (s, me, e) ->
+        letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me)
+          (sub.expr sub e)
+    | Pexp_letexception (cd, e) ->
+        letexception ~loc ~attrs
+          (sub.extension_constructor sub cd)
+          (sub.expr sub e)
+    | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e)
+    | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e)
+    | Pexp_poly (e, t) ->
+        poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t)
+    | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls)
+    | Pexp_newtype (s, e) ->
+        newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e)
+    | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me)
+    | Pexp_open (o, e) ->
+        open_ ~loc ~attrs (sub.open_declaration sub o) (sub.expr sub e)
+    | Pexp_letop {let_; ands; body} ->
+        letop ~loc ~attrs (sub.binding_op sub let_)
+          (List.map (sub.binding_op sub) ands) (sub.expr sub body)
+    | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x)
+    | Pexp_unreachable -> unreachable ~loc ~attrs ()
+
+  let map_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} =
+    let open Exp in
+    let op = map_loc sub pbop_op in
+    let pat = sub.pat sub pbop_pat in
+    let exp = sub.expr sub pbop_exp in
+    let loc = sub.location sub pbop_loc in
+    binding_op op pat exp loc
+
+end
+
+module P = struct
+  (* Patterns *)
+
+  let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} =
+    let open Pat in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Ppat_any -> any ~loc ~attrs ()
+    | Ppat_var s -> var ~loc ~attrs (map_loc sub s)
+    | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s)
+    | Ppat_constant c -> constant ~loc ~attrs (sub.constant sub c)
+    | Ppat_interval (c1, c2) ->
+        interval ~loc ~attrs (sub.constant sub c1) (sub.constant sub c2)
+    | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl)
+    | Ppat_construct (l, p) ->
+        construct ~loc ~attrs (map_loc sub l)
+          (map_opt
+             (fun (vl, p) -> List.map (map_loc sub) vl, sub.pat sub p)
+             p)
+    | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p)
+    | Ppat_record (lpl, cf) ->
+        record ~loc ~attrs
+               (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf
+    | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl)
+    | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2)
+    | Ppat_constraint (p, t) ->
+        constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t)
+    | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s)
+    | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p)
+    | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s)
+    | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p)
+    | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p)
+    | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x)
+end
+
+module CE = struct
+  (* Value expressions for the class language *)
+
+  let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} =
+    let open Cl in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pcl_constr (lid, tys) ->
+        constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
+    | Pcl_structure s ->
+        structure ~loc ~attrs (sub.class_structure sub s)
+    | Pcl_fun (lab, e, p, ce) ->
+        fun_ ~loc ~attrs lab
+          (map_opt (sub.expr sub) e)
+          (sub.pat sub p)
+          (sub.class_expr sub ce)
+    | Pcl_apply (ce, l) ->
+        apply ~loc ~attrs (sub.class_expr sub ce)
+          (List.map (map_snd (sub.expr sub)) l)
+    | Pcl_let (r, vbs, ce) ->
+        let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
+          (sub.class_expr sub ce)
+    | Pcl_constraint (ce, ct) ->
+        constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct)
+    | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x)
+    | Pcl_open (o, ce) ->
+        open_ ~loc ~attrs (sub.open_description sub o) (sub.class_expr sub ce)
+
+  let map_kind sub = function
+    | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e)
+    | Cfk_virtual t -> Cfk_virtual (sub.typ sub t)
+
+  let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} =
+    let open Cf in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pcf_inherit (o, ce, s) ->
+        inherit_ ~loc ~attrs o (sub.class_expr sub ce)
+          (map_opt (map_loc sub) s)
+    | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k)
+    | Pcf_method (s, p, k) ->
+        method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k)
+    | Pcf_constraint (t1, t2) ->
+        constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
+    | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e)
+    | Pcf_attribute x -> attribute ~loc (sub.attribute sub x)
+    | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_structure sub {pcstr_self; pcstr_fields} =
+    {
+      pcstr_self = sub.pat sub pcstr_self;
+      pcstr_fields = List.map (sub.class_field sub) pcstr_fields;
+    }
+
+  let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr;
+                         pci_loc; pci_attributes} =
+    let loc = sub.location sub pci_loc in
+    let attrs = sub.attributes sub pci_attributes in
+    Ci.mk ~loc ~attrs
+     ~virt:pci_virt
+     ~params:(List.map (map_fst (sub.typ sub)) pl)
+      (map_loc sub pci_name)
+      (f pci_expr)
+end
+
+(* Now, a generic AST mapper, to be extended to cover all kinds and
+   cases of the OCaml grammar.  The default behavior of the mapper is
+   the identity. *)
+
+let default_mapper =
+  {
+    constant = C.map;
+    structure = (fun this l -> List.map (this.structure_item this) l);
+    structure_item = M.map_structure_item;
+    module_expr = M.map;
+    signature = (fun this l -> List.map (this.signature_item this) l);
+    signature_item = MT.map_signature_item;
+    module_type = MT.map;
+    with_constraint = MT.map_with_constraint;
+    class_declaration =
+      (fun this -> CE.class_infos this (this.class_expr this));
+    class_expr = CE.map;
+    class_field = CE.map_field;
+    class_structure = CE.map_structure;
+    class_type = CT.map;
+    class_type_field = CT.map_field;
+    class_signature = CT.map_signature;
+    class_type_declaration =
+      (fun this -> CE.class_infos this (this.class_type this));
+    class_description =
+      (fun this -> CE.class_infos this (this.class_type this));
+    type_declaration = T.map_type_declaration;
+    type_kind = T.map_type_kind;
+    typ = T.map;
+    type_extension = T.map_type_extension;
+    type_exception = T.map_type_exception;
+    extension_constructor = T.map_extension_constructor;
+    value_description =
+      (fun this {pval_name; pval_type; pval_prim; pval_loc;
+                 pval_attributes} ->
+        Val.mk
+          (map_loc this pval_name)
+          (this.typ this pval_type)
+          ~attrs:(this.attributes this pval_attributes)
+          ~loc:(this.location this pval_loc)
+          ~prim:pval_prim
+      );
+
+    pat = P.map;
+    expr = E.map;
+    binding_op = E.map_binding_op;
+
+    module_declaration =
+      (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} ->
+         Md.mk
+           (map_loc this pmd_name)
+           (this.module_type this pmd_type)
+           ~attrs:(this.attributes this pmd_attributes)
+           ~loc:(this.location this pmd_loc)
+      );
+
+    module_substitution =
+      (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} ->
+         Ms.mk
+           (map_loc this pms_name)
+           (map_loc this pms_manifest)
+           ~attrs:(this.attributes this pms_attributes)
+           ~loc:(this.location this pms_loc)
+      );
+
+    module_type_declaration =
+      (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} ->
+         Mtd.mk
+           (map_loc this pmtd_name)
+           ?typ:(map_opt (this.module_type this) pmtd_type)
+           ~attrs:(this.attributes this pmtd_attributes)
+           ~loc:(this.location this pmtd_loc)
+      );
+
+    module_binding =
+      (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} ->
+         Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr)
+           ~attrs:(this.attributes this pmb_attributes)
+           ~loc:(this.location this pmb_loc)
+      );
+
+
+    open_declaration =
+      (fun this {popen_expr; popen_override; popen_attributes; popen_loc} ->
+         Opn.mk (this.module_expr this popen_expr)
+           ~override:popen_override
+           ~loc:(this.location this popen_loc)
+           ~attrs:(this.attributes this popen_attributes)
+      );
+
+    open_description =
+      (fun this {popen_expr; popen_override; popen_attributes; popen_loc} ->
+         Opn.mk (map_loc this popen_expr)
+           ~override:popen_override
+           ~loc:(this.location this popen_loc)
+           ~attrs:(this.attributes this popen_attributes)
+      );
+
+    include_description =
+      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+         Incl.mk (this.module_type this pincl_mod)
+           ~loc:(this.location this pincl_loc)
+           ~attrs:(this.attributes this pincl_attributes)
+      );
+
+    include_declaration =
+      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+         Incl.mk (this.module_expr this pincl_mod)
+           ~loc:(this.location this pincl_loc)
+           ~attrs:(this.attributes this pincl_attributes)
+      );
+
+
+    value_binding =
+      (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} ->
+         Vb.mk
+           (this.pat this pvb_pat)
+           (this.expr this pvb_expr)
+           ~loc:(this.location this pvb_loc)
+           ~attrs:(this.attributes this pvb_attributes)
+      );
+
+
+    constructor_declaration =
+      (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} ->
+        Type.constructor
+          (map_loc this pcd_name)
+          ~args:(T.map_constructor_arguments this pcd_args)
+          ?res:(map_opt (this.typ this) pcd_res)
+          ~loc:(this.location this pcd_loc)
+          ~attrs:(this.attributes this pcd_attributes)
+      );
+
+    label_declaration =
+      (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} ->
+         Type.field
+           (map_loc this pld_name)
+           (this.typ this pld_type)
+           ~mut:pld_mutable
+           ~loc:(this.location this pld_loc)
+           ~attrs:(this.attributes this pld_attributes)
+      );
+
+    cases = (fun this l -> List.map (this.case this) l);
+    case =
+      (fun this {pc_lhs; pc_guard; pc_rhs} ->
+         {
+           pc_lhs = this.pat this pc_lhs;
+           pc_guard = map_opt (this.expr this) pc_guard;
+           pc_rhs = this.expr this pc_rhs;
+         }
+      );
+
+
+
+    location = (fun _this l -> l);
+
+    extension = (fun this (s, e) -> (map_loc this s, this.payload this e));
+    attribute = (fun this a ->
+      {
+        attr_name = map_loc this a.attr_name;
+        attr_payload = this.payload this a.attr_payload;
+        attr_loc = this.location this a.attr_loc
+      }
+    );
+    attributes = (fun this l -> List.map (this.attribute this) l);
+    payload =
+      (fun this -> function
+         | PStr x -> PStr (this.structure this x)
+         | PSig x -> PSig (this.signature this x)
+         | PTyp x -> PTyp (this.typ this x)
+         | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g)
+      );
+  }
+
+let extension_of_error {kind; main; sub} =
+  if kind <> Location.Report_error then
+    raise (Invalid_argument "extension_of_error: expected kind Report_error");
+  let str_of_pp pp_msg = Format.asprintf "%t" pp_msg in
+  let extension_of_sub sub =
+    { loc = sub.loc; txt = "ocaml.error" },
+    PStr ([Str.eval (Exp.constant
+                       (Pconst_string (str_of_pp sub.txt, sub.loc, None)))])
+  in
+  { loc = main.loc; txt = "ocaml.error" },
+  PStr (Str.eval (Exp.constant
+                    (Pconst_string (str_of_pp main.txt, main.loc, None))) ::
+        List.map (fun msg -> Str.extension (extension_of_sub msg)) sub)
+
+let attribute_of_warning loc s =
+  Attr.mk
+    {loc; txt = "ocaml.ppwarning" }
+    (PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, loc, None)))]))
+
+let cookies = ref String.Map.empty
+
+let get_cookie k =
+  try Some (String.Map.find k !cookies)
+  with Not_found -> None
+
+let set_cookie k v =
+  cookies := String.Map.add k v !cookies
+
+let tool_name_ref = ref "_none_"
+
+let tool_name () = !tool_name_ref
+
+
+module PpxContext = struct
+  open Longident
+  open Asttypes
+  open Ast_helper
+
+  let lid name = { txt = Lident name; loc = Location.none }
+
+  let make_string s = Exp.constant (Const.string s)
+
+  let make_bool x =
+    if x
+    then Exp.construct (lid "true") None
+    else Exp.construct (lid "false") None
+
+  let rec make_list f lst =
+    match lst with
+    | x :: rest ->
+      Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest]))
+    | [] ->
+      Exp.construct (lid "[]") None
+
+  let make_pair f1 f2 (x1, x2) =
+    Exp.tuple [f1 x1; f2 x2]
+
+  let make_option f opt =
+    match opt with
+    | Some x -> Exp.construct (lid "Some") (Some (f x))
+    | None   -> Exp.construct (lid "None") None
+
+  let get_cookies () =
+    lid "cookies",
+    make_list (make_pair make_string (fun x -> x))
+      (String.Map.bindings !cookies)
+
+  let mk fields =
+    {
+      attr_name = { txt = "ocaml.ppx.context"; loc = Location.none };
+      attr_payload = Parsetree.PStr [Str.eval (Exp.record fields None)];
+      attr_loc = Location.none
+    }
+
+  let make ~tool_name () =
+    let fields =
+      [
+        lid "tool_name",    make_string tool_name;
+        lid "include_dirs", make_list make_string !Clflags.include_dirs;
+        lid "load_path",    make_list make_string (Load_path.get_paths ());
+        lid "open_modules", make_list make_string !Clflags.open_modules;
+        lid "for_package",  make_option make_string !Clflags.for_package;
+        lid "debug",        make_bool !Clflags.debug;
+        lid "use_threads",  make_bool !Clflags.use_threads;
+        lid "use_vmthreads", make_bool false;
+        lid "recursive_types", make_bool !Clflags.recursive_types;
+        lid "principal", make_bool !Clflags.principal;
+        lid "transparent_modules", make_bool !Clflags.transparent_modules;
+        lid "unboxed_types", make_bool !Clflags.unboxed_types;
+        lid "unsafe_string", make_bool !Clflags.unsafe_string;
+        get_cookies ()
+      ]
+    in
+    mk fields
+
+  let get_fields = function
+    | PStr [{pstr_desc = Pstr_eval
+                 ({ pexp_desc = Pexp_record (fields, None) }, [])}] ->
+        fields
+    | _ ->
+        raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax"
+
+  let restore fields =
+    let field name payload =
+      let rec get_string = function
+        | { pexp_desc = Pexp_constant (Pconst_string (str, _, None)) } -> str
+        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
+                             { %s }] string syntax" name
+      and get_bool pexp =
+        match pexp with
+        | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"},
+                                       None)} ->
+            true
+        | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"},
+                                       None)} ->
+            false
+        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
+                             { %s }] bool syntax" name
+      and get_list elem = function
+        | {pexp_desc =
+             Pexp_construct ({txt = Longident.Lident "::"},
+                             Some {pexp_desc = Pexp_tuple [exp; rest]}) } ->
+            elem exp :: get_list elem rest
+        | {pexp_desc =
+             Pexp_construct ({txt = Longident.Lident "[]"}, None)} ->
+            []
+        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
+                             { %s }] list syntax" name
+      and get_pair f1 f2 = function
+        | {pexp_desc = Pexp_tuple [e1; e2]} ->
+            (f1 e1, f2 e2)
+        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
+                             { %s }] pair syntax" name
+      and get_option elem = function
+        | { pexp_desc =
+              Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } ->
+            Some (elem exp)
+        | { pexp_desc =
+              Pexp_construct ({ txt = Longident.Lident "None" }, None) } ->
+            None
+        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
+                             { %s }] option syntax" name
+      in
+      match name with
+      | "tool_name" ->
+          tool_name_ref := get_string payload
+      | "include_dirs" ->
+          Clflags.include_dirs := get_list get_string payload
+      | "load_path" ->
+          Load_path.init (get_list get_string payload)
+      | "open_modules" ->
+          Clflags.open_modules := get_list get_string payload
+      | "for_package" ->
+          Clflags.for_package := get_option get_string payload
+      | "debug" ->
+          Clflags.debug := get_bool payload
+      | "use_threads" ->
+          Clflags.use_threads := get_bool payload
+      | "use_vmthreads" ->
+          if get_bool payload then
+            raise_errorf "Internal error: vmthreads not supported after 4.09.0"
+      | "recursive_types" ->
+          Clflags.recursive_types := get_bool payload
+      | "principal" ->
+          Clflags.principal := get_bool payload
+      | "transparent_modules" ->
+          Clflags.transparent_modules := get_bool payload
+      | "unboxed_types" ->
+          Clflags.unboxed_types := get_bool payload
+      | "unsafe_string" ->
+          Clflags.unsafe_string := get_bool payload
+      | "cookies" ->
+          let l = get_list (get_pair get_string (fun x -> x)) payload in
+          cookies :=
+            List.fold_left
+              (fun s (k, v) -> String.Map.add k v s) String.Map.empty
+              l
+      | _ ->
+          ()
+    in
+    List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields
+
+  let update_cookies fields =
+    let fields =
+      List.filter
+        (function ({txt=Lident "cookies"}, _) -> false | _ -> true)
+        fields
+    in
+    fields @ [get_cookies ()]
+end
+
+let ppx_context = PpxContext.make
+
+let extension_of_exn exn =
+  match error_of_exn exn with
+  | Some (`Ok error) -> extension_of_error error
+  | Some `Already_displayed ->
+      { loc = Location.none; txt = "ocaml.error" }, PStr []
+  | None -> raise exn
+
+
+let apply_lazy ~source ~target mapper =
+  let implem ast =
+    let fields, ast =
+      match ast with
+      | {pstr_desc = Pstr_attribute ({attr_name = {txt = "ocaml.ppx.context"};
+                                      attr_payload = x})} :: l ->
+          PpxContext.get_fields x, l
+      | _ -> [], ast
+    in
+    PpxContext.restore fields;
+    let ast =
+      try
+        let mapper = mapper () in
+        mapper.structure mapper ast
+      with exn ->
+        [{pstr_desc = Pstr_extension (extension_of_exn exn, []);
+          pstr_loc  = Location.none}]
+    in
+    let fields = PpxContext.update_cookies fields in
+    Str.attribute (PpxContext.mk fields) :: ast
+  in
+  let iface ast =
+    let fields, ast =
+      match ast with
+      | {psig_desc = Psig_attribute ({attr_name = {txt = "ocaml.ppx.context"};
+                                      attr_payload = x;
+                                      attr_loc = _})} :: l ->
+          PpxContext.get_fields x, l
+      | _ -> [], ast
+    in
+    PpxContext.restore fields;
+    let ast =
+      try
+        let mapper = mapper () in
+        mapper.signature mapper ast
+      with exn ->
+        [{psig_desc = Psig_extension (extension_of_exn exn, []);
+          psig_loc  = Location.none}]
+    in
+    let fields = PpxContext.update_cookies fields in
+    Sig.attribute (PpxContext.mk fields) :: ast
+  in
+
+  let ic = open_in_bin source in
+  let magic =
+    really_input_string ic (String.length Config.ast_impl_magic_number)
+  in
+
+  let rewrite transform =
+    Location.input_name := input_value ic;
+    let ast = input_value ic in
+    close_in ic;
+    let ast = transform ast in
+    let oc = open_out_bin target in
+    output_string oc magic;
+    output_value oc !Location.input_name;
+    output_value oc ast;
+    close_out oc
+  and fail () =
+    close_in ic;
+    failwith "Ast_mapper: OCaml version mismatch or malformed input";
+  in
+
+  if magic = Config.ast_impl_magic_number then
+    rewrite (implem : structure -> structure)
+  else if magic = Config.ast_intf_magic_number then
+    rewrite (iface : signature -> signature)
+  else fail ()
+
+let drop_ppx_context_str ~restore = function
+  | {pstr_desc = Pstr_attribute
+                   {attr_name = {Location.txt = "ocaml.ppx.context"};
+                    attr_payload = a;
+                    attr_loc = _}}
+    :: items ->
+      if restore then
+        PpxContext.restore (PpxContext.get_fields a);
+      items
+  | items -> items
+
+let drop_ppx_context_sig ~restore = function
+  | {psig_desc = Psig_attribute
+                   {attr_name = {Location.txt = "ocaml.ppx.context"};
+                    attr_payload = a;
+                    attr_loc = _}}
+    :: items ->
+      if restore then
+        PpxContext.restore (PpxContext.get_fields a);
+      items
+  | items -> items
+
+let add_ppx_context_str ~tool_name ast =
+  Ast_helper.Str.attribute (ppx_context ~tool_name ()) :: ast
+
+let add_ppx_context_sig ~tool_name ast =
+  Ast_helper.Sig.attribute (ppx_context ~tool_name ()) :: ast
+
+
+let apply ~source ~target mapper =
+  apply_lazy ~source ~target (fun () -> mapper)
+
+let run_main mapper =
+  try
+    let a = Sys.argv in
+    let n = Array.length a in
+    if n > 2 then
+      let mapper () =
+        try mapper (Array.to_list (Array.sub a 1 (n - 3)))
+        with exn ->
+          (* PR#6463 *)
+          let f _ _ = raise exn in
+          {default_mapper with structure = f; signature = f}
+      in
+      apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) mapper
+    else begin
+      Printf.eprintf "Usage: %s [extra_args] <infile> <outfile>\n%!"
+                     Sys.executable_name;
+      exit 2
+    end
+  with exn ->
+    prerr_endline (Printexc.to_string exn);
+    exit 2
+
+let register_function = ref (fun _name f -> run_main f)
+let register name f = !register_function name f
diff --git a/upstream/ocaml_413/parsing/ast_mapper.mli b/upstream/ocaml_413/parsing/ast_mapper.mli
new file mode 100644
index 0000000..69f6b01
--- /dev/null
+++ b/upstream/ocaml_413/parsing/ast_mapper.mli
@@ -0,0 +1,208 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** The interface of a -ppx rewriter
+
+  A -ppx rewriter is a program that accepts a serialized abstract syntax
+  tree and outputs another, possibly modified, abstract syntax tree.
+  This module encapsulates the interface between the compiler and
+  the -ppx rewriters, handling such details as the serialization format,
+  forwarding of command-line flags, and storing state.
+
+  {!mapper} enables AST rewriting using open recursion.
+  A typical mapper would be based on {!default_mapper}, a deep
+  identity mapper, and will fall back on it for handling the syntax it
+  does not modify. For example:
+
+  {[
+open Asttypes
+open Parsetree
+open Ast_mapper
+
+let test_mapper argv =
+  { default_mapper with
+    expr = fun mapper expr ->
+      match expr with
+      | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} ->
+        Ast_helper.Exp.constant (Const_int 42)
+      | other -> default_mapper.expr mapper other; }
+
+let () =
+  register "ppx_test" test_mapper]}
+
+  This -ppx rewriter, which replaces [[%test]] in expressions with
+  the constant [42], can be compiled using
+  [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml].
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+  *)
+
+open Parsetree
+
+(** {1 A generic Parsetree mapper} *)
+
+type mapper = {
+  attribute: mapper -> attribute -> attribute;
+  attributes: mapper -> attribute list -> attribute list;
+  binding_op: mapper -> binding_op -> binding_op;
+  case: mapper -> case -> case;
+  cases: mapper -> case list -> case list;
+  class_declaration: mapper -> class_declaration -> class_declaration;
+  class_description: mapper -> class_description -> class_description;
+  class_expr: mapper -> class_expr -> class_expr;
+  class_field: mapper -> class_field -> class_field;
+  class_signature: mapper -> class_signature -> class_signature;
+  class_structure: mapper -> class_structure -> class_structure;
+  class_type: mapper -> class_type -> class_type;
+  class_type_declaration: mapper -> class_type_declaration
+                          -> class_type_declaration;
+  class_type_field: mapper -> class_type_field -> class_type_field;
+  constant: mapper -> constant -> constant;
+  constructor_declaration: mapper -> constructor_declaration
+                           -> constructor_declaration;
+  expr: mapper -> expression -> expression;
+  extension: mapper -> extension -> extension;
+  extension_constructor: mapper -> extension_constructor
+                         -> extension_constructor;
+  include_declaration: mapper -> include_declaration -> include_declaration;
+  include_description: mapper -> include_description -> include_description;
+  label_declaration: mapper -> label_declaration -> label_declaration;
+  location: mapper -> Location.t -> Location.t;
+  module_binding: mapper -> module_binding -> module_binding;
+  module_declaration: mapper -> module_declaration -> module_declaration;
+  module_substitution: mapper -> module_substitution -> module_substitution;
+  module_expr: mapper -> module_expr -> module_expr;
+  module_type: mapper -> module_type -> module_type;
+  module_type_declaration: mapper -> module_type_declaration
+                           -> module_type_declaration;
+  open_declaration: mapper -> open_declaration -> open_declaration;
+  open_description: mapper -> open_description -> open_description;
+  pat: mapper -> pattern -> pattern;
+  payload: mapper -> payload -> payload;
+  signature: mapper -> signature -> signature;
+  signature_item: mapper -> signature_item -> signature_item;
+  structure: mapper -> structure -> structure;
+  structure_item: mapper -> structure_item -> structure_item;
+  typ: mapper -> core_type -> core_type;
+  type_declaration: mapper -> type_declaration -> type_declaration;
+  type_extension: mapper -> type_extension -> type_extension;
+  type_exception: mapper -> type_exception -> type_exception;
+  type_kind: mapper -> type_kind -> type_kind;
+  value_binding: mapper -> value_binding -> value_binding;
+  value_description: mapper -> value_description -> value_description;
+  with_constraint: mapper -> with_constraint -> with_constraint;
+}
+(** A mapper record implements one "method" per syntactic category,
+    using an open recursion style: each method takes as its first
+    argument the mapper to be applied to children in the syntax
+    tree. *)
+
+val default_mapper: mapper
+(** A default mapper, which implements a "deep identity" mapping. *)
+
+(** {1 Apply mappers to compilation units} *)
+
+val tool_name: unit -> string
+(** Can be used within a ppx preprocessor to know which tool is
+    calling it ["ocamlc"], ["ocamlopt"], ["ocamldoc"], ["ocamldep"],
+    ["ocaml"], ...  Some global variables that reflect command-line
+    options are automatically synchronized between the calling tool
+    and the ppx preprocessor: {!Clflags.include_dirs},
+    {!Load_path}, {!Clflags.open_modules}, {!Clflags.for_package},
+    {!Clflags.debug}. *)
+
+
+val apply: source:string -> target:string -> mapper -> unit
+(** Apply a mapper (parametrized by the unit name) to a dumped
+    parsetree found in the [source] file and put the result in the
+    [target] file. The [structure] or [signature] field of the mapper
+    is applied to the implementation or interface.  *)
+
+val run_main: (string list -> mapper) -> unit
+(** Entry point to call to implement a standalone -ppx rewriter from a
+    mapper, parametrized by the command line arguments.  The current
+    unit name can be obtained from {!Location.input_name}.  This
+    function implements proper error reporting for uncaught
+    exceptions. *)
+
+(** {1 Registration API} *)
+
+val register_function: (string -> (string list -> mapper) -> unit) ref
+
+val register: string -> (string list -> mapper) -> unit
+(** Apply the [register_function].  The default behavior is to run the
+    mapper immediately, taking arguments from the process command
+    line.  This is to support a scenario where a mapper is linked as a
+    stand-alone executable.
+
+    It is possible to overwrite the [register_function] to define
+    "-ppx drivers", which combine several mappers in a single process.
+    Typically, a driver starts by defining [register_function] to a
+    custom implementation, then lets ppx rewriters (linked statically
+    or dynamically) register themselves, and then run all or some of
+    them.  It is also possible to have -ppx drivers apply rewriters to
+    only specific parts of an AST.
+
+    The first argument to [register] is a symbolic name to be used by
+    the ppx driver.  *)
+
+
+(** {1 Convenience functions to write mappers} *)
+
+val map_opt: ('a -> 'b) -> 'a option -> 'b option
+
+val extension_of_error: Location.error -> extension
+(** Encode an error into an 'ocaml.error' extension node which can be
+    inserted in a generated Parsetree.  The compiler will be
+    responsible for reporting the error. *)
+
+val attribute_of_warning: Location.t -> string -> attribute
+(** Encode a warning message into an 'ocaml.ppwarning' attribute which can be
+    inserted in a generated Parsetree.  The compiler will be
+    responsible for reporting the warning. *)
+
+(** {1 Helper functions to call external mappers} *)
+
+val add_ppx_context_str:
+    tool_name:string -> Parsetree.structure -> Parsetree.structure
+(** Extract information from the current environment and encode it
+    into an attribute which is prepended to the list of structure
+    items in order to pass the information to an external
+    processor. *)
+
+val add_ppx_context_sig:
+    tool_name:string -> Parsetree.signature -> Parsetree.signature
+(** Same as [add_ppx_context_str], but for signatures. *)
+
+val drop_ppx_context_str:
+    restore:bool -> Parsetree.structure -> Parsetree.structure
+(** Drop the ocaml.ppx.context attribute from a structure.  If
+    [restore] is true, also restore the associated data in the current
+    process. *)
+
+val drop_ppx_context_sig:
+    restore:bool -> Parsetree.signature -> Parsetree.signature
+(** Same as [drop_ppx_context_str], but for signatures. *)
+
+(** {1 Cookies} *)
+
+(** Cookies are used to pass information from a ppx processor to
+    a further invocation of itself, when called from the OCaml
+    toplevel (or other tools that support cookies). *)
+
+val set_cookie: string -> Parsetree.expression -> unit
+val get_cookie: string -> Parsetree.expression option
diff --git a/upstream/ocaml_413/parsing/asttypes.mli b/upstream/ocaml_413/parsing/asttypes.mli
new file mode 100644
index 0000000..f4745fb
--- /dev/null
+++ b/upstream/ocaml_413/parsing/asttypes.mli
@@ -0,0 +1,67 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Auxiliary AST types used by parsetree and typedtree.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type constant =
+    Const_int of int
+  | Const_char of char
+  | Const_string of string * Location.t * string option
+  | Const_float of string
+  | Const_int32 of int32
+  | Const_int64 of int64
+  | Const_nativeint of nativeint
+
+type rec_flag = Nonrecursive | Recursive
+
+type direction_flag = Upto | Downto
+
+(* Order matters, used in polymorphic comparison *)
+type private_flag = Private | Public
+
+type mutable_flag = Immutable | Mutable
+
+type virtual_flag = Virtual | Concrete
+
+type override_flag = Override | Fresh
+
+type closed_flag = Closed | Open
+
+type label = string
+
+type arg_label =
+    Nolabel
+  | Labelled of string (*  label:T -> ... *)
+  | Optional of string (* ?label:T -> ... *)
+
+type 'a loc = 'a Location.loc = {
+  txt : 'a;
+  loc : Location.t;
+}
+
+
+type variance =
+  | Covariant
+  | Contravariant
+  | NoVariance
+
+type injectivity =
+  | Injective
+  | NoInjectivity
diff --git a/upstream/ocaml_413/parsing/attr_helper.ml b/upstream/ocaml_413/parsing/attr_helper.ml
new file mode 100644
index 0000000..0a616cd
--- /dev/null
+++ b/upstream/ocaml_413/parsing/attr_helper.ml
@@ -0,0 +1,54 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                  Jeremie Dimino, Jane Street Europe                    *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Parsetree
+
+type error =
+  | Multiple_attributes of string
+  | No_payload_expected of string
+
+exception Error of Location.t * error
+
+let get_no_payload_attribute alt_names attrs =
+  match List.filter (fun a -> List.mem a.attr_name.txt alt_names) attrs with
+  | [] -> None
+  | [ {attr_name = name; attr_payload = PStr []; attr_loc = _} ] -> Some name
+  | [ {attr_name = name; _} ] ->
+    raise (Error (name.loc, No_payload_expected name.txt))
+  | _ :: {attr_name = name; _} :: _ ->
+    raise (Error (name.loc, Multiple_attributes name.txt))
+
+let has_no_payload_attribute alt_names attrs =
+  match get_no_payload_attribute alt_names attrs with
+  | None   -> false
+  | Some _ -> true
+
+open Format
+
+let report_error ppf = function
+  | Multiple_attributes name ->
+    fprintf ppf "Too many `%s' attributes" name
+  | No_payload_expected name ->
+    fprintf ppf "Attribute `%s' does not accept a payload" name
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, err) ->
+        Some (Location.error_of_printer ~loc report_error err)
+      | _ ->
+        None
+    )
diff --git a/upstream/ocaml_413/parsing/attr_helper.mli b/upstream/ocaml_413/parsing/attr_helper.mli
new file mode 100644
index 0000000..a3ddc0c
--- /dev/null
+++ b/upstream/ocaml_413/parsing/attr_helper.mli
@@ -0,0 +1,41 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                  Jeremie Dimino, Jane Street Europe                    *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Helpers for attributes
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Asttypes
+open Parsetree
+
+type error =
+  | Multiple_attributes of string
+  | No_payload_expected of string
+
+(** The [string list] argument of the following functions is a list of
+    alternative names for the attribute we are looking for. For instance:
+
+    {[
+      ["foo"; "ocaml.foo"]
+    ]} *)
+val get_no_payload_attribute : string list -> attributes -> string loc option
+val has_no_payload_attribute : string list -> attributes -> bool
+
+exception Error of Location.t * error
+
+val report_error: Format.formatter -> error -> unit
diff --git a/upstream/ocaml_413/parsing/builtin_attributes.ml b/upstream/ocaml_413/parsing/builtin_attributes.ml
new file mode 100644
index 0000000..c905425
--- /dev/null
+++ b/upstream/ocaml_413/parsing/builtin_attributes.ml
@@ -0,0 +1,289 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Parsetree
+
+let string_of_cst = function
+  | Pconst_string(s, _, _) -> Some s
+  | _ -> None
+
+let string_of_payload = function
+  | PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant c},_)}] ->
+      string_of_cst c
+  | _ -> None
+
+let string_of_opt_payload p =
+  match string_of_payload p with
+  | Some s -> s
+  | None -> ""
+
+let error_of_extension ext =
+  let submessage_from main_loc main_txt = function
+    | {pstr_desc=Pstr_extension
+           (({txt = ("ocaml.error"|"error"); loc}, p), _)} ->
+        begin match p with
+        | PStr([{pstr_desc=Pstr_eval
+                     ({pexp_desc=Pexp_constant(Pconst_string(msg,_,_))}, _)}
+               ]) ->
+            { Location.loc; txt = fun ppf -> Format.pp_print_text ppf msg }
+        | _ ->
+            { Location.loc; txt = fun ppf ->
+                Format.fprintf ppf
+                  "Invalid syntax for sub-message of extension '%s'." main_txt }
+        end
+    | {pstr_desc=Pstr_extension (({txt; loc}, _), _)} ->
+        { Location.loc; txt = fun ppf ->
+            Format.fprintf ppf "Uninterpreted extension '%s'." txt }
+    | _ ->
+        { Location.loc = main_loc; txt = fun ppf ->
+            Format.fprintf ppf
+              "Invalid syntax for sub-message of extension '%s'." main_txt }
+  in
+  match ext with
+  | ({txt = ("ocaml.error"|"error") as txt; loc}, p) ->
+      begin match p with
+      | PStr [] -> raise Location.Already_displayed_error
+      | PStr({pstr_desc=Pstr_eval
+                  ({pexp_desc=Pexp_constant(Pconst_string(msg,_,_))}, _)}::
+             inner) ->
+          let sub = List.map (submessage_from loc txt) inner in
+          Location.error_of_printer ~loc ~sub Format.pp_print_text msg
+      | _ ->
+          Location.errorf ~loc "Invalid syntax for extension '%s'." txt
+      end
+  | ({txt; loc}, _) ->
+      Location.errorf ~loc "Uninterpreted extension '%s'." txt
+
+let kind_and_message = function
+  | PStr[
+      {pstr_desc=
+         Pstr_eval
+           ({pexp_desc=Pexp_apply
+                 ({pexp_desc=Pexp_ident{txt=Longident.Lident id}},
+                  [Nolabel,{pexp_desc=Pexp_constant (Pconst_string(s,_,_))}])
+            },_)}] ->
+      Some (id, s)
+  | PStr[
+      {pstr_desc=
+         Pstr_eval
+           ({pexp_desc=Pexp_ident{txt=Longident.Lident id}},_)}] ->
+      Some (id, "")
+  | _ -> None
+
+let cat s1 s2 =
+  if s2 = "" then s1 else s1 ^ "\n" ^ s2
+
+let alert_attr x =
+  match x.attr_name.txt with
+  | "ocaml.deprecated"|"deprecated" ->
+      Some (x, "deprecated", string_of_opt_payload x.attr_payload)
+  | "ocaml.alert"|"alert" ->
+      begin match kind_and_message x.attr_payload with
+      | Some (kind, message) -> Some (x, kind, message)
+      | None -> None (* note: bad payloads detected by warning_attribute *)
+      end
+  | _ -> None
+
+let alert_attrs l =
+  List.filter_map alert_attr l
+
+let alerts_of_attrs l =
+  List.fold_left
+    (fun acc (_, kind, message) ->
+       let upd = function
+         | None | Some "" -> Some message
+         | Some s -> Some (cat s message)
+       in
+       Misc.Stdlib.String.Map.update kind upd acc
+    )
+    Misc.Stdlib.String.Map.empty
+    (alert_attrs l)
+
+let check_alerts loc attrs s =
+  Misc.Stdlib.String.Map.iter
+    (fun kind message -> Location.alert loc ~kind (cat s message))
+    (alerts_of_attrs attrs)
+
+let check_alerts_inclusion ~def ~use loc attrs1 attrs2 s =
+  let m2 = alerts_of_attrs attrs2 in
+  Misc.Stdlib.String.Map.iter
+    (fun kind msg ->
+       if not (Misc.Stdlib.String.Map.mem kind m2) then
+         Location.alert ~def ~use ~kind loc (cat s msg)
+    )
+    (alerts_of_attrs attrs1)
+
+let rec deprecated_mutable_of_attrs = function
+  | [] -> None
+  | {attr_name =  {txt = "ocaml.deprecated_mutable"|"deprecated_mutable"; _};
+     attr_payload = p} :: _ ->
+     Some (string_of_opt_payload p)
+  | _ :: tl -> deprecated_mutable_of_attrs tl
+
+let check_deprecated_mutable loc attrs s =
+  match deprecated_mutable_of_attrs attrs with
+  | None -> ()
+  | Some txt ->
+      Location.deprecated loc (Printf.sprintf "mutating field %s" (cat s txt))
+
+let check_deprecated_mutable_inclusion ~def ~use loc attrs1 attrs2 s =
+  match deprecated_mutable_of_attrs attrs1,
+        deprecated_mutable_of_attrs attrs2
+  with
+  | None, _ | Some _, Some _ -> ()
+  | Some txt, None ->
+      Location.deprecated ~def ~use loc
+        (Printf.sprintf "mutating field %s" (cat s txt))
+
+let rec attrs_of_sig = function
+  | {psig_desc = Psig_attribute a} :: tl ->
+      a :: attrs_of_sig tl
+  | _ ->
+      []
+
+let alerts_of_sig sg = alerts_of_attrs (attrs_of_sig sg)
+
+let rec attrs_of_str = function
+  | {pstr_desc = Pstr_attribute a} :: tl ->
+      a :: attrs_of_str tl
+  | _ ->
+      []
+
+let alerts_of_str str = alerts_of_attrs (attrs_of_str str)
+
+let check_no_alert attrs =
+  List.iter
+    (fun (a, _, _) ->
+       Location.prerr_warning a.attr_loc
+         (Warnings.Misplaced_attribute a.attr_name.txt)
+    )
+    (alert_attrs attrs)
+
+let warn_payload loc txt msg =
+  Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg))
+
+let warning_attribute ?(ppwarning = true) =
+  let process loc txt errflag payload =
+    match string_of_payload payload with
+    | Some s ->
+        begin try
+          Option.iter (Location.prerr_alert loc)
+            (Warnings.parse_options errflag s)
+        with Arg.Bad msg -> warn_payload loc txt msg
+        end
+    | None ->
+        warn_payload loc txt "A single string literal is expected"
+  in
+  let process_alert loc txt = function
+    | PStr[{pstr_desc=
+              Pstr_eval(
+                {pexp_desc=Pexp_constant(Pconst_string(s,_,_))},
+                _)
+           }] ->
+        begin try Warnings.parse_alert_option s
+        with Arg.Bad msg -> warn_payload loc txt msg
+        end
+    | k ->
+        match kind_and_message k with
+        | Some ("all", _) ->
+            warn_payload loc txt "The alert name 'all' is reserved"
+        | Some _ -> ()
+        | None -> warn_payload loc txt "Invalid payload"
+  in
+  function
+  | {attr_name = {txt = ("ocaml.warning"|"warning") as txt; _};
+     attr_loc;
+     attr_payload;
+     } ->
+      process attr_loc txt false attr_payload
+  | {attr_name = {txt = ("ocaml.warnerror"|"warnerror") as txt; _};
+     attr_loc;
+     attr_payload
+    } ->
+      process attr_loc txt true attr_payload
+  | {attr_name = {txt="ocaml.ppwarning"|"ppwarning"; _};
+     attr_loc = _;
+     attr_payload =
+       PStr [
+         { pstr_desc=
+             Pstr_eval({pexp_desc=Pexp_constant (Pconst_string (s, _, _))},_);
+           pstr_loc }
+       ];
+    } when ppwarning ->
+     Location.prerr_warning pstr_loc (Warnings.Preprocessor s)
+  | {attr_name = {txt = ("ocaml.alert"|"alert") as txt; _};
+     attr_loc;
+     attr_payload;
+     } ->
+      process_alert attr_loc txt attr_payload
+  | _ ->
+     ()
+
+let warning_scope ?ppwarning attrs f =
+  let prev = Warnings.backup () in
+  try
+    List.iter (warning_attribute ?ppwarning) (List.rev attrs);
+    let ret = f () in
+    Warnings.restore prev;
+    ret
+  with exn ->
+    Warnings.restore prev;
+    raise exn
+
+
+let warn_on_literal_pattern =
+  List.exists
+    (fun a -> match a.attr_name.txt with
+       | "ocaml.warn_on_literal_pattern"|"warn_on_literal_pattern" -> true
+       | _ -> false
+    )
+
+let explicit_arity =
+  List.exists
+    (fun a -> match a.attr_name.txt with
+       | "ocaml.explicit_arity"|"explicit_arity" -> true
+       | _ -> false
+    )
+
+let immediate =
+  List.exists
+    (fun a -> match a.attr_name.txt with
+       | "ocaml.immediate"|"immediate" -> true
+       | _ -> false
+    )
+
+let immediate64 =
+  List.exists
+    (fun a -> match a.attr_name.txt with
+       | "ocaml.immediate64"|"immediate64" -> true
+       | _ -> false
+    )
+
+(* The "ocaml.boxed (default)" and "ocaml.unboxed (default)"
+   attributes cannot be input by the user, they are added by the
+   compiler when applying the default setting. This is done to record
+   in the .cmi the default used by the compiler when compiling the
+   source file because the default can change between compiler
+   invocations. *)
+
+let check l a = List.mem a.attr_name.txt l
+
+let has_unboxed attr =
+  List.exists (check ["ocaml.unboxed"; "unboxed"])
+    attr
+
+let has_boxed attr =
+  List.exists (check ["ocaml.boxed"; "boxed"]) attr
diff --git a/upstream/ocaml_413/parsing/builtin_attributes.mli b/upstream/ocaml_413/parsing/builtin_attributes.mli
new file mode 100644
index 0000000..6200fd7
--- /dev/null
+++ b/upstream/ocaml_413/parsing/builtin_attributes.mli
@@ -0,0 +1,84 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Support for some of the builtin attributes
+
+    - ocaml.deprecated
+    - ocaml.alert
+    - ocaml.error
+    - ocaml.ppwarning
+    - ocaml.warning
+    - ocaml.warnerror
+    - ocaml.explicit_arity (for camlp4/camlp5)
+    - ocaml.warn_on_literal_pattern
+    - ocaml.deprecated_mutable
+    - ocaml.immediate
+    - ocaml.immediate64
+    - ocaml.boxed / ocaml.unboxed
+
+    {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+val check_alerts: Location.t -> Parsetree.attributes -> string -> unit
+val check_alerts_inclusion:
+  def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes ->
+  Parsetree.attributes -> string -> unit
+val alerts_of_attrs: Parsetree.attributes -> Misc.alerts
+val alerts_of_sig: Parsetree.signature -> Misc.alerts
+val alerts_of_str: Parsetree.structure -> Misc.alerts
+
+val check_deprecated_mutable:
+    Location.t -> Parsetree.attributes -> string -> unit
+val check_deprecated_mutable_inclusion:
+  def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes ->
+  Parsetree.attributes -> string -> unit
+
+val check_no_alert: Parsetree.attributes -> unit
+
+val error_of_extension: Parsetree.extension -> Location.error
+
+val warning_attribute: ?ppwarning:bool -> Parsetree.attribute -> unit
+  (** Apply warning settings from the specified attribute.
+      "ocaml.warning"/"ocaml.warnerror" (and variants without the prefix)
+      are processed and other attributes are ignored.
+
+      Also implement ocaml.ppwarning (unless ~ppwarning:false is
+      passed).
+  *)
+
+val warning_scope:
+  ?ppwarning:bool ->
+  Parsetree.attributes -> (unit -> 'a) -> 'a
+  (** Execute a function in a new scope for warning settings.  This
+      means that the effect of any call to [warning_attribute] during
+      the execution of this function will be discarded after
+      execution.
+
+      The function also takes a list of attributes which are processed
+      with [warning_attribute] in the fresh scope before the function
+      is executed.
+  *)
+
+val warn_on_literal_pattern: Parsetree.attributes -> bool
+val explicit_arity: Parsetree.attributes -> bool
+
+
+val immediate: Parsetree.attributes -> bool
+val immediate64: Parsetree.attributes -> bool
+
+val has_unboxed: Parsetree.attributes -> bool
+val has_boxed: Parsetree.attributes -> bool
diff --git a/upstream/ocaml_413/parsing/depend.ml b/upstream/ocaml_413/parsing/depend.ml
new file mode 100644
index 0000000..d2ebb81
--- /dev/null
+++ b/upstream/ocaml_413/parsing/depend.ml
@@ -0,0 +1,594 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Location
+open Longident
+open Parsetree
+module String = Misc.Stdlib.String
+
+let pp_deps = ref []
+
+(* Module resolution map *)
+(* Node (set of imports for this path, map for submodules) *)
+type map_tree = Node of String.Set.t * bound_map
+and  bound_map = map_tree String.Map.t
+let bound = Node (String.Set.empty, String.Map.empty)
+
+(*let get_free (Node (s, _m)) = s*)
+let get_map (Node (_s, m)) = m
+let make_leaf s = Node (String.Set.singleton s, String.Map.empty)
+let make_node m =  Node (String.Set.empty, m)
+let rec weaken_map s (Node(s0,m0)) =
+  Node (String.Set.union s s0, String.Map.map (weaken_map s) m0)
+let rec collect_free (Node (s, m)) =
+  String.Map.fold (fun _ n -> String.Set.union (collect_free n)) m s
+
+(* Returns the imports required to access the structure at path p *)
+(* Only raises Not_found if the head of p is not in the toplevel map *)
+let rec lookup_free p m =
+  match p with
+    [] -> raise Not_found
+  | s::p ->
+      let Node (f, m') = String.Map.find s m  in
+      try lookup_free p m' with Not_found -> f
+
+(* Returns the node corresponding to the structure at path p *)
+let rec lookup_map lid m =
+  match lid with
+    Lident s    -> String.Map.find s m
+  | Ldot (l, s) -> String.Map.find s (get_map (lookup_map l m))
+  | Lapply _    -> raise Not_found
+
+(* Collect free module identifiers in the a.s.t. *)
+
+let free_structure_names = ref String.Set.empty
+
+let add_names s =
+  free_structure_names := String.Set.union s !free_structure_names
+
+let rec add_path bv ?(p=[]) = function
+  | Lident s ->
+      let free =
+        try lookup_free (s::p) bv with Not_found -> String.Set.singleton s
+      in
+      (*String.Set.iter (fun s -> Printf.eprintf "%s " s) free;
+        prerr_endline "";*)
+      add_names free
+  | Ldot(l, s) -> add_path bv ~p:(s::p) l
+  | Lapply(l1, l2) -> add_path bv l1; add_path bv l2
+
+let open_module bv lid =
+  match lookup_map lid bv with
+  | Node (s, m) ->
+      add_names s;
+      String.Map.fold String.Map.add m bv
+  | exception Not_found ->
+      add_path bv lid; bv
+
+let add_parent bv lid =
+  match lid.txt with
+    Ldot(l, _s) -> add_path bv l
+  | _ -> ()
+
+let add = add_parent
+
+let add_module_path bv lid = add_path bv lid.txt
+
+let handle_extension ext =
+  match (fst ext).txt with
+  | "error" | "ocaml.error" ->
+    raise (Location.Error
+             (Builtin_attributes.error_of_extension ext))
+  | _ ->
+    ()
+
+let rec add_type bv ty =
+  match ty.ptyp_desc with
+    Ptyp_any -> ()
+  | Ptyp_var _ -> ()
+  | Ptyp_arrow(_, t1, t2) -> add_type bv t1; add_type bv t2
+  | Ptyp_tuple tl -> List.iter (add_type bv) tl
+  | Ptyp_constr(c, tl) -> add bv c; List.iter (add_type bv) tl
+  | Ptyp_object (fl, _) ->
+      List.iter
+       (fun {pof_desc; _} -> match pof_desc with
+         | Otag (_, t) -> add_type bv t
+         | Oinherit t -> add_type bv t) fl
+  | Ptyp_class(c, tl) -> add bv c; List.iter (add_type bv) tl
+  | Ptyp_alias(t, _) -> add_type bv t
+  | Ptyp_variant(fl, _, _) ->
+      List.iter
+        (fun {prf_desc; _} -> match prf_desc with
+          | Rtag(_, _, stl) -> List.iter (add_type bv) stl
+          | Rinherit sty -> add_type bv sty)
+        fl
+  | Ptyp_poly(_, t) -> add_type bv t
+  | Ptyp_package pt -> add_package_type bv pt
+  | Ptyp_extension e -> handle_extension e
+
+and add_package_type bv (lid, l) =
+  add bv lid;
+  List.iter (add_type bv) (List.map (fun (_, e) -> e) l)
+
+let add_opt add_fn bv = function
+    None -> ()
+  | Some x -> add_fn bv x
+
+let add_constructor_arguments bv = function
+  | Pcstr_tuple l -> List.iter (add_type bv) l
+  | Pcstr_record l -> List.iter (fun l -> add_type bv l.pld_type) l
+
+let add_constructor_decl bv pcd =
+  add_constructor_arguments bv pcd.pcd_args;
+  Option.iter (add_type bv) pcd.pcd_res
+
+let add_type_declaration bv td =
+  List.iter
+    (fun (ty1, ty2, _) -> add_type bv ty1; add_type bv ty2)
+    td.ptype_cstrs;
+  add_opt add_type bv td.ptype_manifest;
+  let add_tkind = function
+    Ptype_abstract -> ()
+  | Ptype_variant cstrs ->
+      List.iter (add_constructor_decl bv) cstrs
+  | Ptype_record lbls ->
+      List.iter (fun pld -> add_type bv pld.pld_type) lbls
+  | Ptype_open -> () in
+  add_tkind td.ptype_kind
+
+let add_extension_constructor bv ext =
+  match ext.pext_kind with
+    Pext_decl(args, rty) ->
+      add_constructor_arguments bv args;
+      Option.iter (add_type bv) rty
+  | Pext_rebind lid -> add bv lid
+
+let add_type_extension bv te =
+  add bv te.ptyext_path;
+  List.iter (add_extension_constructor bv) te.ptyext_constructors
+
+let add_type_exception bv te =
+  add_extension_constructor bv te.ptyexn_constructor
+
+let pattern_bv = ref String.Map.empty
+
+let rec add_pattern bv pat =
+  match pat.ppat_desc with
+    Ppat_any -> ()
+  | Ppat_var _ -> ()
+  | Ppat_alias(p, _) -> add_pattern bv p
+  | Ppat_interval _
+  | Ppat_constant _ -> ()
+  | Ppat_tuple pl -> List.iter (add_pattern bv) pl
+  | Ppat_construct(c, opt) ->
+      add bv c;
+      add_opt
+        (fun bv (_,p) -> add_pattern bv p)
+        bv opt
+  | Ppat_record(pl, _) ->
+      List.iter (fun (lbl, p) -> add bv lbl; add_pattern bv p) pl
+  | Ppat_array pl -> List.iter (add_pattern bv) pl
+  | Ppat_or(p1, p2) -> add_pattern bv p1; add_pattern bv p2
+  | Ppat_constraint(p, ty) -> add_pattern bv p; add_type bv ty
+  | Ppat_variant(_, op) -> add_opt add_pattern bv op
+  | Ppat_type li -> add bv li
+  | Ppat_lazy p -> add_pattern bv p
+  | Ppat_unpack id ->
+      Option.iter
+        (fun name -> pattern_bv := String.Map.add name bound !pattern_bv) id.txt
+  | Ppat_open ( m, p) -> let bv = open_module bv m.txt in add_pattern bv p
+  | Ppat_exception p -> add_pattern bv p
+  | Ppat_extension e -> handle_extension e
+
+let add_pattern bv pat =
+  pattern_bv := bv;
+  add_pattern bv pat;
+  !pattern_bv
+
+let rec add_expr bv exp =
+  match exp.pexp_desc with
+    Pexp_ident l -> add bv l
+  | Pexp_constant _ -> ()
+  | Pexp_let(rf, pel, e) ->
+      let bv = add_bindings rf bv pel in add_expr bv e
+  | Pexp_fun (_, opte, p, e) ->
+      add_opt add_expr bv opte; add_expr (add_pattern bv p) e
+  | Pexp_function pel ->
+      add_cases bv pel
+  | Pexp_apply(e, el) ->
+      add_expr bv e; List.iter (fun (_,e) -> add_expr bv e) el
+  | Pexp_match(e, pel) -> add_expr bv e; add_cases bv pel
+  | Pexp_try(e, pel) -> add_expr bv e; add_cases bv pel
+  | Pexp_tuple el -> List.iter (add_expr bv) el
+  | Pexp_construct(c, opte) -> add bv c; add_opt add_expr bv opte
+  | Pexp_variant(_, opte) -> add_opt add_expr bv opte
+  | Pexp_record(lblel, opte) ->
+      List.iter (fun (lbl, e) -> add bv lbl; add_expr bv e) lblel;
+      add_opt add_expr bv opte
+  | Pexp_field(e, fld) -> add_expr bv e; add bv fld
+  | Pexp_setfield(e1, fld, e2) -> add_expr bv e1; add bv fld; add_expr bv e2
+  | Pexp_array el -> List.iter (add_expr bv) el
+  | Pexp_ifthenelse(e1, e2, opte3) ->
+      add_expr bv e1; add_expr bv e2; add_opt add_expr bv opte3
+  | Pexp_sequence(e1, e2) -> add_expr bv e1; add_expr bv e2
+  | Pexp_while(e1, e2) -> add_expr bv e1; add_expr bv e2
+  | Pexp_for( _, e1, e2, _, e3) ->
+      add_expr bv e1; add_expr bv e2; add_expr bv e3
+  | Pexp_coerce(e1, oty2, ty3) ->
+      add_expr bv e1;
+      add_opt add_type bv oty2;
+      add_type bv ty3
+  | Pexp_constraint(e1, ty2) ->
+      add_expr bv e1;
+      add_type bv ty2
+  | Pexp_send(e, _m) -> add_expr bv e
+  | Pexp_new li -> add bv li
+  | Pexp_setinstvar(_v, e) -> add_expr bv e
+  | Pexp_override sel -> List.iter (fun (_s, e) -> add_expr bv e) sel
+  | Pexp_letmodule(id, m, e) ->
+      let b = add_module_binding bv m in
+      let bv =
+        match id.txt with
+        | None -> bv
+        | Some id -> String.Map.add id b bv
+      in
+      add_expr bv e
+  | Pexp_letexception(_, e) -> add_expr bv e
+  | Pexp_assert (e) -> add_expr bv e
+  | Pexp_lazy (e) -> add_expr bv e
+  | Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t
+  | Pexp_object { pcstr_self = pat; pcstr_fields = fieldl } ->
+      let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl
+  | Pexp_newtype (_, e) -> add_expr bv e
+  | Pexp_pack m -> add_module_expr bv m
+  | Pexp_open (o, e) ->
+      let bv = open_declaration bv o in
+      add_expr bv e
+  | Pexp_letop {let_; ands; body} ->
+      let bv' = add_binding_op bv bv let_ in
+      let bv' = List.fold_left (add_binding_op bv) bv' ands in
+      add_expr bv' body
+  | Pexp_extension (({ txt = ("ocaml.extension_constructor"|
+                              "extension_constructor"); _ },
+                     PStr [item]) as e) ->
+      begin match item.pstr_desc with
+      | Pstr_eval ({ pexp_desc = Pexp_construct (c, None) }, _) -> add bv c
+      | _ -> handle_extension e
+      end
+  | Pexp_extension e -> handle_extension e
+  | Pexp_unreachable -> ()
+
+and add_cases bv cases =
+  List.iter (add_case bv) cases
+
+and add_case bv {pc_lhs; pc_guard; pc_rhs} =
+  let bv = add_pattern bv pc_lhs in
+  add_opt add_expr bv pc_guard;
+  add_expr bv pc_rhs
+
+and add_bindings recf bv pel =
+  let bv' = List.fold_left (fun bv x -> add_pattern bv x.pvb_pat) bv pel in
+  let bv = if recf = Recursive then bv' else bv in
+  List.iter (fun x -> add_expr bv x.pvb_expr) pel;
+  bv'
+
+and add_binding_op bv bv' pbop =
+  add_expr bv pbop.pbop_exp;
+  add_pattern bv' pbop.pbop_pat
+
+and add_modtype bv mty =
+  match mty.pmty_desc with
+    Pmty_ident l -> add bv l
+  | Pmty_alias l -> add_module_path bv l
+  | Pmty_signature s -> add_signature bv s
+  | Pmty_functor(param, mty2) ->
+      let bv =
+        match param with
+        | Unit -> bv
+        | Named (id, mty1) ->
+          add_modtype bv mty1;
+          match id.txt with
+          | None -> bv
+          | Some name -> String.Map.add name bound bv
+      in
+      add_modtype bv mty2
+  | Pmty_with(mty, cstrl) ->
+      add_modtype bv mty;
+      List.iter
+        (function
+          | Pwith_type (_, td) -> add_type_declaration bv td
+          | Pwith_module (_, lid) -> add_module_path bv lid
+          | Pwith_modtype (_, mty) -> add_modtype bv mty
+          | Pwith_typesubst (_, td) -> add_type_declaration bv td
+          | Pwith_modsubst (_, lid) -> add_module_path bv lid
+          | Pwith_modtypesubst (_, mty) -> add_modtype bv mty
+        )
+        cstrl
+  | Pmty_typeof m -> add_module_expr bv m
+  | Pmty_extension e -> handle_extension e
+
+and add_module_alias bv l =
+  (* If we are in delayed dependencies mode, we delay the dependencies
+       induced by "Lident s" *)
+  (if !Clflags.transparent_modules then add_parent else add_module_path) bv l;
+  try
+    lookup_map l.txt bv
+  with Not_found ->
+    match l.txt with
+      Lident s -> make_leaf s
+    | _ -> add_module_path bv l; bound (* cannot delay *)
+
+and add_modtype_binding bv mty =
+  match mty.pmty_desc with
+    Pmty_alias l ->
+      add_module_alias bv l
+  | Pmty_signature s ->
+      make_node (add_signature_binding bv s)
+  | Pmty_typeof modl ->
+      add_module_binding bv modl
+  | _ ->
+      add_modtype bv mty; bound
+
+and add_signature bv sg =
+  ignore (add_signature_binding bv sg)
+
+and add_signature_binding bv sg =
+  snd (List.fold_left add_sig_item (bv, String.Map.empty) sg)
+
+and add_sig_item (bv, m) item =
+  match item.psig_desc with
+    Psig_value vd ->
+      add_type bv vd.pval_type; (bv, m)
+  | Psig_type (_, dcls)
+  | Psig_typesubst dcls->
+      List.iter (add_type_declaration bv) dcls; (bv, m)
+  | Psig_typext te ->
+      add_type_extension bv te; (bv, m)
+  | Psig_exception te ->
+      add_type_exception bv te; (bv, m)
+  | Psig_module pmd ->
+      let m' = add_modtype_binding bv pmd.pmd_type in
+      let add map =
+        match pmd.pmd_name.txt with
+        | None -> map
+        | Some name -> String.Map.add name m' map
+      in
+      (add bv, add m)
+  | Psig_modsubst pms ->
+      let m' = add_module_alias bv pms.pms_manifest in
+      let add = String.Map.add pms.pms_name.txt m' in
+      (add bv, add m)
+  | Psig_recmodule decls ->
+      let add =
+        List.fold_right (fun pmd map ->
+          match pmd.pmd_name.txt with
+          | None -> map
+          | Some name -> String.Map.add name bound map
+        ) decls
+      in
+      let bv' = add bv and m' = add m in
+      List.iter (fun pmd -> add_modtype bv' pmd.pmd_type) decls;
+      (bv', m')
+  | Psig_modtype x | Psig_modtypesubst x->
+      begin match x.pmtd_type with
+        None -> ()
+      | Some mty -> add_modtype bv mty
+      end;
+      (bv, m)
+  | Psig_open od ->
+      (open_description bv od, m)
+  | Psig_include incl ->
+      let Node (s, m') = add_modtype_binding bv incl.pincl_mod in
+      add_names s;
+      let add = String.Map.fold String.Map.add m' in
+      (add bv, add m)
+  | Psig_class cdl ->
+      List.iter (add_class_description bv) cdl; (bv, m)
+  | Psig_class_type cdtl ->
+      List.iter (add_class_type_declaration bv) cdtl; (bv, m)
+  | Psig_attribute _ -> (bv, m)
+  | Psig_extension (e, _) ->
+      handle_extension e;
+      (bv, m)
+
+and open_description bv od =
+  let Node(s, m) = add_module_alias bv od.popen_expr in
+  add_names s;
+  String.Map.fold String.Map.add m bv
+
+and open_declaration bv od =
+  let Node (s, m) = add_module_binding bv od.popen_expr in
+  add_names s;
+  String.Map.fold String.Map.add m bv
+
+and add_module_binding bv modl =
+  match modl.pmod_desc with
+    Pmod_ident l -> add_module_alias bv l
+  | Pmod_structure s ->
+     make_node (snd @@ add_structure_binding bv s)
+  | _ -> add_module_expr bv modl; bound
+
+and add_module_expr bv modl =
+  match modl.pmod_desc with
+    Pmod_ident l -> add_module_path bv l
+  | Pmod_structure s -> ignore (add_structure bv s)
+  | Pmod_functor(param, modl) ->
+      let bv =
+        match param with
+        | Unit -> bv
+        | Named (id, mty) ->
+          add_modtype bv mty;
+          match id.txt with
+          | None -> bv
+          | Some name -> String.Map.add name bound bv
+      in
+      add_module_expr bv modl
+  | Pmod_apply(mod1, mod2) ->
+      add_module_expr bv mod1; add_module_expr bv mod2
+  | Pmod_constraint(modl, mty) ->
+      add_module_expr bv modl; add_modtype bv mty
+  | Pmod_unpack(e) ->
+      add_expr bv e
+  | Pmod_extension e ->
+      handle_extension e
+
+and add_class_type bv cty =
+  match cty.pcty_desc with
+    Pcty_constr(l, tyl) ->
+      add bv l; List.iter (add_type bv) tyl
+  | Pcty_signature { pcsig_self = ty; pcsig_fields = fieldl } ->
+      add_type bv ty;
+      List.iter (add_class_type_field bv) fieldl
+  | Pcty_arrow(_, ty1, cty2) ->
+      add_type bv ty1; add_class_type bv cty2
+  | Pcty_extension e -> handle_extension e
+  | Pcty_open (o, e) ->
+      let bv = open_description bv o in
+      add_class_type bv e
+
+and add_class_type_field bv pctf =
+  match pctf.pctf_desc with
+    Pctf_inherit cty -> add_class_type bv cty
+  | Pctf_val(_, _, _, ty) -> add_type bv ty
+  | Pctf_method(_, _, _, ty) -> add_type bv ty
+  | Pctf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2
+  | Pctf_attribute _ -> ()
+  | Pctf_extension e -> handle_extension e
+
+and add_class_description bv infos =
+  add_class_type bv infos.pci_expr
+
+and add_class_type_declaration bv infos = add_class_description bv infos
+
+and add_structure bv item_list =
+  let (bv, m) = add_structure_binding bv item_list in
+  add_names (collect_free (make_node m));
+  bv
+
+and add_structure_binding bv item_list =
+  List.fold_left add_struct_item (bv, String.Map.empty) item_list
+
+and add_struct_item (bv, m) item : _ String.Map.t * _ String.Map.t =
+  match item.pstr_desc with
+    Pstr_eval (e, _attrs) ->
+      add_expr bv e; (bv, m)
+  | Pstr_value(rf, pel) ->
+      let bv = add_bindings rf bv pel in (bv, m)
+  | Pstr_primitive vd ->
+      add_type bv vd.pval_type; (bv, m)
+  | Pstr_type (_, dcls) ->
+      List.iter (add_type_declaration bv) dcls; (bv, m)
+  | Pstr_typext te ->
+      add_type_extension bv te;
+      (bv, m)
+  | Pstr_exception te ->
+      add_type_exception bv te;
+      (bv, m)
+  | Pstr_module x ->
+      let b = add_module_binding bv x.pmb_expr in
+      let add map =
+        match x.pmb_name.txt with
+        | None -> map
+        | Some name -> String.Map.add name b map
+      in
+      (add bv, add m)
+  | Pstr_recmodule bindings ->
+      let add =
+        List.fold_right (fun x map ->
+          match x.pmb_name.txt with
+          | None -> map
+          | Some name -> String.Map.add name bound map
+        ) bindings
+      in
+      let bv' = add bv and m = add m in
+      List.iter
+        (fun x -> add_module_expr bv' x.pmb_expr)
+        bindings;
+      (bv', m)
+  | Pstr_modtype x ->
+      begin match x.pmtd_type with
+        None -> ()
+      | Some mty -> add_modtype bv mty
+      end;
+      (bv, m)
+  | Pstr_open od ->
+      (open_declaration bv od, m)
+  | Pstr_class cdl ->
+      List.iter (add_class_declaration bv) cdl; (bv, m)
+  | Pstr_class_type cdtl ->
+      List.iter (add_class_type_declaration bv) cdtl; (bv, m)
+  | Pstr_include incl ->
+      let Node (s, m') as n = add_module_binding bv incl.pincl_mod in
+      if !Clflags.transparent_modules then
+        add_names s
+      else
+        (* If we are not in the delayed dependency mode, we need to
+           collect all delayed dependencies imported by the include statement *)
+        add_names (collect_free n);
+      let add = String.Map.fold String.Map.add m' in
+      (add bv, add m)
+  | Pstr_attribute _ -> (bv, m)
+  | Pstr_extension (e, _) ->
+      handle_extension e;
+      (bv, m)
+
+and add_use_file bv top_phrs =
+  ignore (List.fold_left add_top_phrase bv top_phrs)
+
+and add_implementation bv l =
+    ignore (add_structure_binding bv l)
+
+and add_implementation_binding bv l =
+  snd (add_structure_binding bv l)
+
+and add_top_phrase bv = function
+  | Ptop_def str -> add_structure bv str
+  | Ptop_dir _ -> bv
+
+and add_class_expr bv ce =
+  match ce.pcl_desc with
+    Pcl_constr(l, tyl) ->
+      add bv l; List.iter (add_type bv) tyl
+  | Pcl_structure { pcstr_self = pat; pcstr_fields = fieldl } ->
+      let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl
+  | Pcl_fun(_, opte, pat, ce) ->
+      add_opt add_expr bv opte;
+      let bv = add_pattern bv pat in add_class_expr bv ce
+  | Pcl_apply(ce, exprl) ->
+      add_class_expr bv ce; List.iter (fun (_,e) -> add_expr bv e) exprl
+  | Pcl_let(rf, pel, ce) ->
+      let bv = add_bindings rf bv pel in add_class_expr bv ce
+  | Pcl_constraint(ce, ct) ->
+      add_class_expr bv ce; add_class_type bv ct
+  | Pcl_extension e -> handle_extension e
+  | Pcl_open (o, e) ->
+      let bv = open_description bv o in
+      add_class_expr bv e
+
+and add_class_field bv pcf =
+  match pcf.pcf_desc with
+    Pcf_inherit(_, ce, _) -> add_class_expr bv ce
+  | Pcf_val(_, _, Cfk_concrete (_, e))
+  | Pcf_method(_, _, Cfk_concrete (_, e)) -> add_expr bv e
+  | Pcf_val(_, _, Cfk_virtual ty)
+  | Pcf_method(_, _, Cfk_virtual ty) -> add_type bv ty
+  | Pcf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2
+  | Pcf_initializer e -> add_expr bv e
+  | Pcf_attribute _ -> ()
+  | Pcf_extension e -> handle_extension e
+
+and add_class_declaration bv decl =
+  add_class_expr bv decl.pci_expr
diff --git a/upstream/ocaml_413/parsing/depend.mli b/upstream/ocaml_413/parsing/depend.mli
new file mode 100644
index 0000000..74c095f
--- /dev/null
+++ b/upstream/ocaml_413/parsing/depend.mli
@@ -0,0 +1,45 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Module dependencies.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+module String = Misc.Stdlib.String
+
+type map_tree = Node of String.Set.t * bound_map
+and  bound_map = map_tree String.Map.t
+val make_leaf : string -> map_tree
+val make_node : bound_map -> map_tree
+val weaken_map : String.Set.t -> map_tree -> map_tree
+
+val free_structure_names : String.Set.t ref
+
+(** dependencies found by preprocessing tools *)
+val pp_deps : string list ref
+
+val open_module : bound_map -> Longident.t -> bound_map
+
+val add_use_file : bound_map -> Parsetree.toplevel_phrase list -> unit
+
+val add_signature : bound_map -> Parsetree.signature -> unit
+
+val add_implementation : bound_map -> Parsetree.structure -> unit
+
+val add_implementation_binding : bound_map -> Parsetree.structure -> bound_map
+val add_signature_binding : bound_map -> Parsetree.signature -> bound_map
diff --git a/upstream/ocaml_413/parsing/docstrings.ml b/upstream/ocaml_413/parsing/docstrings.ml
new file mode 100644
index 0000000..a39f75d
--- /dev/null
+++ b/upstream/ocaml_413/parsing/docstrings.ml
@@ -0,0 +1,425 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                               Leo White                                *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Location
+
+(* Docstrings *)
+
+(* A docstring is "attached" if it has been inserted in the AST. This
+   is used for generating unexpected docstring warnings. *)
+type ds_attached =
+  | Unattached   (* Not yet attached anything.*)
+  | Info         (* Attached to a field or constructor. *)
+  | Docs         (* Attached to an item or as floating text. *)
+
+(* A docstring is "associated" with an item if there are no blank lines between
+   them. This is used for generating docstring ambiguity warnings. *)
+type ds_associated =
+  | Zero             (* Not associated with an item *)
+  | One              (* Associated with one item *)
+  | Many             (* Associated with multiple items (ambiguity) *)
+
+type docstring =
+  { ds_body: string;
+    ds_loc: Location.t;
+    mutable ds_attached: ds_attached;
+    mutable ds_associated: ds_associated; }
+
+(* List of docstrings *)
+
+let docstrings : docstring list ref = ref []
+
+(* Warn for unused and ambiguous docstrings *)
+
+let warn_bad_docstrings () =
+  if Warnings.is_active (Warnings.Unexpected_docstring true) then begin
+    List.iter
+      (fun ds ->
+         match ds.ds_attached with
+         | Info -> ()
+         | Unattached ->
+           prerr_warning ds.ds_loc (Warnings.Unexpected_docstring true)
+         | Docs ->
+             match ds.ds_associated with
+             | Zero | One -> ()
+             | Many ->
+               prerr_warning ds.ds_loc (Warnings.Unexpected_docstring false))
+      (List.rev !docstrings)
+end
+
+(* Docstring constructors and destructors *)
+
+let docstring body loc =
+  let ds =
+    { ds_body = body;
+      ds_loc = loc;
+      ds_attached = Unattached;
+      ds_associated = Zero; }
+  in
+  ds
+
+let register ds =
+  docstrings := ds :: !docstrings
+
+let docstring_body ds = ds.ds_body
+
+let docstring_loc ds = ds.ds_loc
+
+(* Docstrings attached to items *)
+
+type docs =
+  { docs_pre: docstring option;
+    docs_post: docstring option; }
+
+let empty_docs = { docs_pre = None; docs_post = None }
+
+let doc_loc = {txt = "ocaml.doc"; loc = Location.none}
+
+let docs_attr ds =
+  let open Parsetree in
+  let body = ds.ds_body in
+  let loc = ds.ds_loc in
+  let exp =
+    { pexp_desc = Pexp_constant (Pconst_string(body, loc, None));
+      pexp_loc = loc;
+      pexp_loc_stack = [];
+      pexp_attributes = []; }
+  in
+  let item =
+    { pstr_desc = Pstr_eval (exp, []); pstr_loc = loc }
+  in
+  { attr_name = doc_loc;
+    attr_payload = PStr [item];
+    attr_loc = loc }
+
+let add_docs_attrs docs attrs =
+  let attrs =
+    match docs.docs_pre with
+    | None | Some { ds_body=""; _ } -> attrs
+    | Some ds -> docs_attr ds :: attrs
+  in
+  let attrs =
+    match docs.docs_post with
+    | None | Some { ds_body=""; _ } -> attrs
+    | Some ds -> attrs @ [docs_attr ds]
+  in
+  attrs
+
+(* Docstrings attached to constructors or fields *)
+
+type info = docstring option
+
+let empty_info = None
+
+let info_attr = docs_attr
+
+let add_info_attrs info attrs =
+  match info with
+  | None | Some {ds_body=""; _} -> attrs
+  | Some ds -> attrs @ [info_attr ds]
+
+(* Docstrings not attached to a specific item *)
+
+type text = docstring list
+
+let empty_text = []
+let empty_text_lazy = lazy []
+
+let text_loc = {txt = "ocaml.text"; loc = Location.none}
+
+let text_attr ds =
+  let open Parsetree in
+  let body = ds.ds_body in
+  let loc = ds.ds_loc in
+  let exp =
+    { pexp_desc = Pexp_constant (Pconst_string(body, loc, None));
+      pexp_loc = loc;
+      pexp_loc_stack = [];
+      pexp_attributes = []; }
+  in
+  let item =
+    { pstr_desc = Pstr_eval (exp, []); pstr_loc = loc }
+  in
+  { attr_name = text_loc;
+    attr_payload = PStr [item];
+    attr_loc = loc }
+
+let add_text_attrs dsl attrs =
+  let fdsl = List.filter (function {ds_body=""} -> false| _ ->true) dsl in
+  (List.map text_attr fdsl) @ attrs
+
+(* Find the first non-info docstring in a list, attach it and return it *)
+let get_docstring ~info dsl =
+  let rec loop = function
+    | [] -> None
+    | {ds_attached = Info; _} :: rest -> loop rest
+    | ds :: _ ->
+        ds.ds_attached <- if info then Info else Docs;
+        Some ds
+  in
+  loop dsl
+
+(* Find all the non-info docstrings in a list, attach them and return them *)
+let get_docstrings dsl =
+  let rec loop acc = function
+    | [] -> List.rev acc
+    | {ds_attached = Info; _} :: rest -> loop acc rest
+    | ds :: rest ->
+        ds.ds_attached <- Docs;
+        loop (ds :: acc) rest
+  in
+    loop [] dsl
+
+(* "Associate" all the docstrings in a list *)
+let associate_docstrings dsl =
+  List.iter
+    (fun ds ->
+       match ds.ds_associated with
+       | Zero -> ds.ds_associated <- One
+       | (One | Many) -> ds.ds_associated <- Many)
+    dsl
+
+(* Map from positions to pre docstrings *)
+
+let pre_table : (Lexing.position, docstring list) Hashtbl.t =
+  Hashtbl.create 50
+
+let set_pre_docstrings pos dsl =
+  if dsl <> [] then Hashtbl.add pre_table pos dsl
+
+let get_pre_docs pos =
+  try
+    let dsl = Hashtbl.find pre_table pos in
+      associate_docstrings dsl;
+      get_docstring ~info:false dsl
+  with Not_found -> None
+
+let mark_pre_docs pos =
+  try
+    let dsl = Hashtbl.find pre_table pos in
+      associate_docstrings dsl
+  with Not_found -> ()
+
+(* Map from positions to post docstrings *)
+
+let post_table : (Lexing.position, docstring list) Hashtbl.t =
+  Hashtbl.create 50
+
+let set_post_docstrings pos dsl =
+  if dsl <> [] then Hashtbl.add post_table pos dsl
+
+let get_post_docs pos =
+  try
+    let dsl = Hashtbl.find post_table pos in
+      associate_docstrings dsl;
+      get_docstring ~info:false dsl
+  with Not_found -> None
+
+let mark_post_docs pos =
+  try
+    let dsl = Hashtbl.find post_table pos in
+      associate_docstrings dsl
+  with Not_found -> ()
+
+let get_info pos =
+  try
+    let dsl = Hashtbl.find post_table pos in
+      get_docstring ~info:true dsl
+  with Not_found -> None
+
+(* Map from positions to floating docstrings *)
+
+let floating_table : (Lexing.position, docstring list) Hashtbl.t =
+  Hashtbl.create 50
+
+let set_floating_docstrings pos dsl =
+  if dsl <> [] then Hashtbl.add floating_table pos dsl
+
+let get_text pos =
+  try
+    let dsl = Hashtbl.find floating_table pos in
+      get_docstrings dsl
+  with Not_found -> []
+
+let get_post_text pos =
+  try
+    let dsl = Hashtbl.find post_table pos in
+      get_docstrings dsl
+  with Not_found -> []
+
+(* Maps from positions to extra docstrings *)
+
+let pre_extra_table : (Lexing.position, docstring list) Hashtbl.t =
+  Hashtbl.create 50
+
+let set_pre_extra_docstrings pos dsl =
+  if dsl <> [] then Hashtbl.add pre_extra_table pos dsl
+
+let get_pre_extra_text pos =
+  try
+    let dsl = Hashtbl.find pre_extra_table pos in
+      get_docstrings dsl
+  with Not_found -> []
+
+let post_extra_table : (Lexing.position, docstring list) Hashtbl.t =
+  Hashtbl.create 50
+
+let set_post_extra_docstrings pos dsl =
+  if dsl <> [] then Hashtbl.add post_extra_table pos dsl
+
+let get_post_extra_text pos =
+  try
+    let dsl = Hashtbl.find post_extra_table pos in
+      get_docstrings dsl
+  with Not_found -> []
+
+(* Docstrings from parser actions *)
+module WithParsing = struct
+let symbol_docs () =
+  { docs_pre = get_pre_docs (Parsing.symbol_start_pos ());
+    docs_post = get_post_docs (Parsing.symbol_end_pos ()); }
+
+let symbol_docs_lazy () =
+  let p1 = Parsing.symbol_start_pos () in
+  let p2 = Parsing.symbol_end_pos () in
+    lazy { docs_pre = get_pre_docs p1;
+           docs_post = get_post_docs p2; }
+
+let rhs_docs pos1 pos2 =
+  { docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1);
+    docs_post = get_post_docs (Parsing.rhs_end_pos pos2); }
+
+let rhs_docs_lazy pos1 pos2 =
+  let p1 = Parsing.rhs_start_pos pos1 in
+  let p2 = Parsing.rhs_end_pos pos2 in
+    lazy { docs_pre = get_pre_docs p1;
+           docs_post = get_post_docs p2; }
+
+let mark_symbol_docs () =
+  mark_pre_docs (Parsing.symbol_start_pos ());
+  mark_post_docs (Parsing.symbol_end_pos ())
+
+let mark_rhs_docs pos1 pos2 =
+  mark_pre_docs (Parsing.rhs_start_pos pos1);
+  mark_post_docs (Parsing.rhs_end_pos pos2)
+
+let symbol_info () =
+  get_info (Parsing.symbol_end_pos ())
+
+let rhs_info pos =
+  get_info (Parsing.rhs_end_pos pos)
+
+let symbol_text () =
+  get_text (Parsing.symbol_start_pos ())
+
+let symbol_text_lazy () =
+  let pos = Parsing.symbol_start_pos () in
+    lazy (get_text pos)
+
+let rhs_text pos =
+  get_text (Parsing.rhs_start_pos pos)
+
+let rhs_post_text pos =
+  get_post_text (Parsing.rhs_end_pos pos)
+
+let rhs_text_lazy pos =
+  let pos = Parsing.rhs_start_pos pos in
+    lazy (get_text pos)
+
+let symbol_pre_extra_text () =
+  get_pre_extra_text (Parsing.symbol_start_pos ())
+
+let symbol_post_extra_text () =
+  get_post_extra_text (Parsing.symbol_end_pos ())
+
+let rhs_pre_extra_text pos =
+  get_pre_extra_text (Parsing.rhs_start_pos pos)
+
+let rhs_post_extra_text pos =
+  get_post_extra_text (Parsing.rhs_end_pos pos)
+end
+
+include WithParsing
+
+module WithMenhir = struct
+let symbol_docs (startpos, endpos) =
+  { docs_pre = get_pre_docs startpos;
+    docs_post = get_post_docs endpos; }
+
+let symbol_docs_lazy (p1, p2) =
+  lazy { docs_pre = get_pre_docs p1;
+         docs_post = get_post_docs p2; }
+
+let rhs_docs pos1 pos2 =
+  { docs_pre = get_pre_docs pos1;
+    docs_post = get_post_docs pos2; }
+
+let rhs_docs_lazy p1 p2 =
+    lazy { docs_pre = get_pre_docs p1;
+           docs_post = get_post_docs p2; }
+
+let mark_symbol_docs (startpos, endpos) =
+  mark_pre_docs startpos;
+  mark_post_docs endpos;
+  ()
+
+let mark_rhs_docs pos1 pos2 =
+  mark_pre_docs pos1;
+  mark_post_docs pos2;
+  ()
+
+let symbol_info endpos =
+  get_info endpos
+
+let rhs_info endpos =
+  get_info endpos
+
+let symbol_text startpos =
+  get_text startpos
+
+let symbol_text_lazy startpos =
+  lazy (get_text startpos)
+
+let rhs_text pos =
+  get_text pos
+
+let rhs_post_text pos =
+  get_post_text pos
+
+let rhs_text_lazy pos =
+  lazy (get_text pos)
+
+let symbol_pre_extra_text startpos =
+  get_pre_extra_text startpos
+
+let symbol_post_extra_text endpos =
+  get_post_extra_text endpos
+
+let rhs_pre_extra_text pos =
+  get_pre_extra_text pos
+
+let rhs_post_extra_text pos =
+  get_post_extra_text pos
+end
+
+(* (Re)Initialise all comment state *)
+
+let init () =
+  docstrings := [];
+  Hashtbl.reset pre_table;
+  Hashtbl.reset post_table;
+  Hashtbl.reset floating_table;
+  Hashtbl.reset pre_extra_table;
+  Hashtbl.reset post_extra_table
diff --git a/upstream/ocaml_413/parsing/docstrings.mli b/upstream/ocaml_413/parsing/docstrings.mli
new file mode 100644
index 0000000..bf2508f
--- /dev/null
+++ b/upstream/ocaml_413/parsing/docstrings.mli
@@ -0,0 +1,223 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                               Leo White                                *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Documentation comments
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+(** (Re)Initialise all docstring state *)
+val init : unit -> unit
+
+(** Emit warnings for unattached and ambiguous docstrings *)
+val warn_bad_docstrings : unit -> unit
+
+(** {2 Docstrings} *)
+
+(** Documentation comments *)
+type docstring
+
+(** Create a docstring *)
+val docstring : string -> Location.t -> docstring
+
+(** Register a docstring *)
+val register : docstring -> unit
+
+(** Get the text of a docstring *)
+val docstring_body : docstring -> string
+
+(** Get the location of a docstring *)
+val docstring_loc : docstring -> Location.t
+
+(** {2 Set functions}
+
+   These functions are used by the lexer to associate docstrings to
+   the locations of tokens. *)
+
+(** Docstrings immediately preceding a token *)
+val set_pre_docstrings : Lexing.position -> docstring list -> unit
+
+(** Docstrings immediately following a token *)
+val set_post_docstrings : Lexing.position -> docstring list -> unit
+
+(** Docstrings not immediately adjacent to a token *)
+val set_floating_docstrings : Lexing.position -> docstring list -> unit
+
+(** Docstrings immediately following the token which precedes this one *)
+val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit
+
+(** Docstrings immediately preceding the token which follows this one *)
+val set_post_extra_docstrings : Lexing.position -> docstring list -> unit
+
+(** {2 Items}
+
+    The {!docs} type represents documentation attached to an item. *)
+
+type docs =
+  { docs_pre: docstring option;
+    docs_post: docstring option; }
+
+val empty_docs : docs
+
+val docs_attr : docstring -> Parsetree.attribute
+
+(** Convert item documentation to attributes and add them to an
+    attribute list *)
+val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes
+
+(** Fetch the item documentation for the current symbol. This also
+    marks this documentation (for ambiguity warnings). *)
+val symbol_docs : unit -> docs
+val symbol_docs_lazy : unit -> docs Lazy.t
+
+(** Fetch the item documentation for the symbols between two
+    positions. This also marks this documentation (for ambiguity
+    warnings). *)
+val rhs_docs : int -> int -> docs
+val rhs_docs_lazy : int -> int -> docs Lazy.t
+
+(** Mark the item documentation for the current symbol (for ambiguity
+    warnings). *)
+val mark_symbol_docs : unit -> unit
+
+(** Mark as associated the item documentation for the symbols between
+    two positions (for ambiguity warnings) *)
+val mark_rhs_docs : int -> int -> unit
+
+(** {2 Fields and constructors}
+
+    The {!info} type represents documentation attached to a field or
+    constructor. *)
+
+type info = docstring option
+
+val empty_info : info
+
+val info_attr : docstring -> Parsetree.attribute
+
+(** Convert field info to attributes and add them to an
+    attribute list *)
+val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes
+
+(** Fetch the field info for the current symbol. *)
+val symbol_info : unit -> info
+
+(** Fetch the field info following the symbol at a given position. *)
+val rhs_info : int -> info
+
+(** {2 Unattached comments}
+
+    The {!text} type represents documentation which is not attached to
+    anything. *)
+
+type text = docstring list
+
+val empty_text : text
+val empty_text_lazy : text Lazy.t
+
+val text_attr : docstring -> Parsetree.attribute
+
+(** Convert text to attributes and add them to an attribute list *)
+val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes
+
+(** Fetch the text preceding the current symbol. *)
+val symbol_text : unit -> text
+val symbol_text_lazy : unit -> text Lazy.t
+
+(** Fetch the text preceding the symbol at the given position. *)
+val rhs_text : int -> text
+val rhs_text_lazy : int -> text Lazy.t
+
+(** {2 Extra text}
+
+    There may be additional text attached to the delimiters of a block
+    (e.g. [struct] and [end]). This is fetched by the following
+    functions, which are applied to the contents of the block rather
+    than the delimiters. *)
+
+(** Fetch additional text preceding the current symbol *)
+val symbol_pre_extra_text : unit -> text
+
+(** Fetch additional text following the current symbol *)
+val symbol_post_extra_text : unit -> text
+
+(** Fetch additional text preceding the symbol at the given position *)
+val rhs_pre_extra_text : int -> text
+
+(** Fetch additional text following the symbol at the given position *)
+val rhs_post_extra_text : int -> text
+
+(** Fetch text following the symbol at the given position *)
+val rhs_post_text : int -> text
+
+module WithMenhir: sig
+(** Fetch the item documentation for the current symbol. This also
+    marks this documentation (for ambiguity warnings). *)
+val symbol_docs : Lexing.position * Lexing.position -> docs
+val symbol_docs_lazy : Lexing.position * Lexing.position -> docs Lazy.t
+
+(** Fetch the item documentation for the symbols between two
+    positions. This also marks this documentation (for ambiguity
+    warnings). *)
+val rhs_docs : Lexing.position -> Lexing.position -> docs
+val rhs_docs_lazy : Lexing.position -> Lexing.position -> docs Lazy.t
+
+(** Mark the item documentation for the current symbol (for ambiguity
+    warnings). *)
+val mark_symbol_docs : Lexing.position * Lexing.position -> unit
+
+(** Mark as associated the item documentation for the symbols between
+    two positions (for ambiguity warnings) *)
+val mark_rhs_docs : Lexing.position -> Lexing.position -> unit
+
+(** Fetch the field info for the current symbol. *)
+val symbol_info : Lexing.position -> info
+
+(** Fetch the field info following the symbol at a given position. *)
+val rhs_info : Lexing.position -> info
+
+(** Fetch the text preceding the current symbol. *)
+val symbol_text : Lexing.position -> text
+val symbol_text_lazy : Lexing.position -> text Lazy.t
+
+(** Fetch the text preceding the symbol at the given position. *)
+val rhs_text : Lexing.position -> text
+val rhs_text_lazy : Lexing.position -> text Lazy.t
+
+(** {3 Extra text}
+
+    There may be additional text attached to the delimiters of a block
+    (e.g. [struct] and [end]). This is fetched by the following
+    functions, which are applied to the contents of the block rather
+    than the delimiters. *)
+
+(** Fetch additional text preceding the current symbol *)
+val symbol_pre_extra_text : Lexing.position -> text
+
+(** Fetch additional text following the current symbol *)
+val symbol_post_extra_text : Lexing.position -> text
+
+(** Fetch additional text preceding the symbol at the given position *)
+val rhs_pre_extra_text : Lexing.position -> text
+
+(** Fetch additional text following the symbol at the given position *)
+val rhs_post_extra_text : Lexing.position -> text
+
+(** Fetch text following the symbol at the given position *)
+val rhs_post_text : Lexing.position -> text
+
+end
diff --git a/upstream/ocaml_413/parsing/lexer.mli b/upstream/ocaml_413/parsing/lexer.mli
new file mode 100644
index 0000000..85b85a8
--- /dev/null
+++ b/upstream/ocaml_413/parsing/lexer.mli
@@ -0,0 +1,65 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** The lexical analyzer
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+val init : unit -> unit
+val token: Lexing.lexbuf -> Parser.token
+val skip_hash_bang: Lexing.lexbuf -> unit
+
+type error =
+  | Illegal_character of char
+  | Illegal_escape of string * string option
+  | Reserved_sequence of string * string option
+  | Unterminated_comment of Location.t
+  | Unterminated_string
+  | Unterminated_string_in_comment of Location.t * Location.t
+  | Empty_character_literal
+  | Keyword_as_label of string
+  | Invalid_literal of string
+  | Invalid_directive of string * string option
+;;
+
+exception Error of error * Location.t
+
+val in_comment : unit -> bool;;
+val in_string : unit -> bool;;
+
+
+val print_warnings : bool ref
+val handle_docstrings: bool ref
+val comments : unit -> (string * Location.t) list
+val token_with_comments : Lexing.lexbuf -> Parser.token
+
+(*
+  [set_preprocessor init preprocessor] registers [init] as the function
+to call to initialize the preprocessor when the lexer is initialized,
+and [preprocessor] a function that is called when a new token is needed
+by the parser, as [preprocessor lexer lexbuf] where [lexer] is the
+lexing function.
+
+When a preprocessor is configured by calling [set_preprocessor], the lexer
+changes its behavior to accept backslash-newline as a token-separating blank.
+*)
+
+val set_preprocessor :
+  (unit -> unit) ->
+  ((Lexing.lexbuf -> Parser.token) -> Lexing.lexbuf -> Parser.token) ->
+  unit
diff --git a/upstream/ocaml_413/parsing/lexer.mll b/upstream/ocaml_413/parsing/lexer.mll
new file mode 100644
index 0000000..89d6876
--- /dev/null
+++ b/upstream/ocaml_413/parsing/lexer.mll
@@ -0,0 +1,871 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* The lexer definition *)
+
+{
+open Lexing
+open Misc
+open Parser
+
+type error =
+  | Illegal_character of char
+  | Illegal_escape of string * string option
+  | Reserved_sequence of string * string option
+  | Unterminated_comment of Location.t
+  | Unterminated_string
+  | Unterminated_string_in_comment of Location.t * Location.t
+  | Empty_character_literal
+  | Keyword_as_label of string
+  | Invalid_literal of string
+  | Invalid_directive of string * string option
+;;
+
+exception Error of error * Location.t;;
+
+(* The table of keywords *)
+
+let keyword_table =
+  create_hashtable 149 [
+    "and", AND;
+    "as", AS;
+    "assert", ASSERT;
+    "begin", BEGIN;
+    "class", CLASS;
+    "constraint", CONSTRAINT;
+    "do", DO;
+    "done", DONE;
+    "downto", DOWNTO;
+    "else", ELSE;
+    "end", END;
+    "exception", EXCEPTION;
+    "external", EXTERNAL;
+    "false", FALSE;
+    "for", FOR;
+    "fun", FUN;
+    "function", FUNCTION;
+    "functor", FUNCTOR;
+    "if", IF;
+    "in", IN;
+    "include", INCLUDE;
+    "inherit", INHERIT;
+    "initializer", INITIALIZER;
+    "lazy", LAZY;
+    "let", LET;
+    "match", MATCH;
+    "method", METHOD;
+    "module", MODULE;
+    "mutable", MUTABLE;
+    "new", NEW;
+    "nonrec", NONREC;
+    "object", OBJECT;
+    "of", OF;
+    "open", OPEN;
+    "or", OR;
+(*  "parser", PARSER; *)
+    "private", PRIVATE;
+    "rec", REC;
+    "sig", SIG;
+    "struct", STRUCT;
+    "then", THEN;
+    "to", TO;
+    "true", TRUE;
+    "try", TRY;
+    "type", TYPE;
+    "val", VAL;
+    "virtual", VIRTUAL;
+    "when", WHEN;
+    "while", WHILE;
+    "with", WITH;
+
+    "lor", INFIXOP3("lor"); (* Should be INFIXOP2 *)
+    "lxor", INFIXOP3("lxor"); (* Should be INFIXOP2 *)
+    "mod", INFIXOP3("mod");
+    "land", INFIXOP3("land");
+    "lsl", INFIXOP4("lsl");
+    "lsr", INFIXOP4("lsr");
+    "asr", INFIXOP4("asr")
+]
+
+(* To buffer string literals *)
+
+let string_buffer = Buffer.create 256
+let reset_string_buffer () = Buffer.reset string_buffer
+let get_stored_string () = Buffer.contents string_buffer
+
+let store_string_char c = Buffer.add_char string_buffer c
+let store_string_utf_8_uchar u = Buffer.add_utf_8_uchar string_buffer u
+let store_string s = Buffer.add_string string_buffer s
+let store_lexeme lexbuf = store_string (Lexing.lexeme lexbuf)
+
+(* To store the position of the beginning of a string and comment *)
+let string_start_loc = ref Location.none;;
+let comment_start_loc = ref [];;
+let in_comment () = !comment_start_loc <> [];;
+let is_in_string = ref false
+let in_string () = !is_in_string
+let print_warnings = ref true
+
+(* Escaped chars are interpreted in strings unless they are in comments. *)
+let store_escaped_char lexbuf c =
+  if in_comment () then store_lexeme lexbuf else store_string_char c
+
+let store_escaped_uchar lexbuf u =
+  if in_comment () then store_lexeme lexbuf else store_string_utf_8_uchar u
+
+let compute_quoted_string_idloc {Location.loc_start = orig_loc } shift id =
+  let id_start_pos = orig_loc.Lexing.pos_cnum + shift in
+  let loc_start =
+    Lexing.{orig_loc with pos_cnum = id_start_pos }
+  in
+  let loc_end =
+    Lexing.{orig_loc with pos_cnum = id_start_pos + String.length id}
+  in
+  {Location. loc_start ; loc_end ; loc_ghost = false }
+
+let wrap_string_lexer f lexbuf =
+  let loc_start = lexbuf.lex_curr_p in
+  reset_string_buffer();
+  is_in_string := true;
+  let string_start = lexbuf.lex_start_p in
+  string_start_loc := Location.curr lexbuf;
+  let loc_end = f lexbuf in
+  is_in_string := false;
+  lexbuf.lex_start_p <- string_start;
+  let loc = Location.{loc_ghost= false; loc_start; loc_end} in
+  get_stored_string (), loc
+
+let wrap_comment_lexer comment lexbuf =
+  let start_loc = Location.curr lexbuf  in
+  comment_start_loc := [start_loc];
+  reset_string_buffer ();
+  let end_loc = comment lexbuf in
+  let s = get_stored_string () in
+  reset_string_buffer ();
+  s,
+  { start_loc with Location.loc_end = end_loc.Location.loc_end }
+
+let error lexbuf e = raise (Error(e, Location.curr lexbuf))
+let error_loc loc e = raise (Error(e, loc))
+
+(* to translate escape sequences *)
+
+let digit_value c =
+  match c with
+  | 'a' .. 'f' -> 10 + Char.code c - Char.code 'a'
+  | 'A' .. 'F' -> 10 + Char.code c - Char.code 'A'
+  | '0' .. '9' -> Char.code c - Char.code '0'
+  | _ -> assert false
+
+let num_value lexbuf ~base ~first ~last =
+  let c = ref 0 in
+  for i = first to last do
+    let v = digit_value (Lexing.lexeme_char lexbuf i) in
+    assert(v < base);
+    c := (base * !c) + v
+  done;
+  !c
+
+let char_for_backslash = function
+  | 'n' -> '\010'
+  | 'r' -> '\013'
+  | 'b' -> '\008'
+  | 't' -> '\009'
+  | c   -> c
+
+let illegal_escape lexbuf reason =
+  let error = Illegal_escape (Lexing.lexeme lexbuf, Some reason) in
+  raise (Error (error, Location.curr lexbuf))
+
+let char_for_decimal_code lexbuf i =
+  let c = num_value lexbuf ~base:10 ~first:i ~last:(i+2) in
+  if (c < 0 || c > 255) then
+    if in_comment ()
+    then 'x'
+    else
+      illegal_escape lexbuf
+        (Printf.sprintf
+          "%d is outside the range of legal characters (0-255)." c)
+  else Char.chr c
+
+let char_for_octal_code lexbuf i =
+  let c = num_value lexbuf ~base:8 ~first:i ~last:(i+2) in
+  if (c < 0 || c > 255) then
+    if in_comment ()
+    then 'x'
+    else
+      illegal_escape lexbuf
+        (Printf.sprintf
+          "o%o (=%d) is outside the range of legal characters (0-255)." c c)
+  else Char.chr c
+
+let char_for_hexadecimal_code lexbuf i =
+  Char.chr (num_value lexbuf ~base:16 ~first:i ~last:(i+1))
+
+let uchar_for_uchar_escape lexbuf =
+  let len = Lexing.lexeme_end lexbuf - Lexing.lexeme_start lexbuf in
+  let first = 3 (* skip opening \u{ *) in
+  let last = len - 2 (* skip closing } *) in
+  let digit_count = last - first + 1 in
+  match digit_count > 6 with
+  | true ->
+      illegal_escape lexbuf
+        "too many digits, expected 1 to 6 hexadecimal digits"
+  | false ->
+      let cp = num_value lexbuf ~base:16 ~first ~last in
+      if Uchar.is_valid cp then Uchar.unsafe_of_int cp else
+      illegal_escape lexbuf
+        (Printf.sprintf "%X is not a Unicode scalar value" cp)
+
+let is_keyword name = Hashtbl.mem keyword_table name
+
+let check_label_name lexbuf name =
+  if is_keyword name then error lexbuf (Keyword_as_label name)
+
+(* Update the current location with file name and line number. *)
+
+let update_loc lexbuf file line absolute chars =
+  let pos = lexbuf.lex_curr_p in
+  let new_file = match file with
+                 | None -> pos.pos_fname
+                 | Some s -> s
+  in
+  lexbuf.lex_curr_p <- { pos with
+    pos_fname = new_file;
+    pos_lnum = if absolute then line else pos.pos_lnum + line;
+    pos_bol = pos.pos_cnum - chars;
+  }
+;;
+
+let preprocessor = ref None
+
+let escaped_newlines = ref false
+
+(* Warn about Latin-1 characters used in idents *)
+
+let warn_latin1 lexbuf =
+  Location.deprecated
+    (Location.curr lexbuf)
+    "ISO-Latin1 characters in identifiers"
+
+let handle_docstrings = ref true
+let comment_list = ref []
+
+let add_comment com =
+  comment_list := com :: !comment_list
+
+let add_docstring_comment ds =
+  let com =
+    ("*" ^ Docstrings.docstring_body ds, Docstrings.docstring_loc ds)
+  in
+    add_comment com
+
+let comments () = List.rev !comment_list
+
+(* Error report *)
+
+open Format
+
+let prepare_error loc = function
+  | Illegal_character c ->
+      Location.errorf ~loc "Illegal character (%s)" (Char.escaped c)
+  | Illegal_escape (s, explanation) ->
+      Location.errorf ~loc
+        "Illegal backslash escape in string or character (%s)%t" s
+        (fun ppf -> match explanation with
+           | None -> ()
+           | Some expl -> fprintf ppf ": %s" expl)
+  | Reserved_sequence (s, explanation) ->
+      Location.errorf ~loc
+        "Reserved character sequence: %s%t" s
+        (fun ppf -> match explanation with
+           | None -> ()
+           | Some expl -> fprintf ppf " %s" expl)
+  | Unterminated_comment _ ->
+      Location.errorf ~loc "Comment not terminated"
+  | Unterminated_string ->
+      Location.errorf ~loc "String literal not terminated"
+  | Unterminated_string_in_comment (_, literal_loc) ->
+      Location.errorf ~loc
+        "This comment contains an unterminated string literal"
+        ~sub:[Location.msg ~loc:literal_loc "String literal begins here"]
+  | Empty_character_literal ->
+      let msg = "Illegal empty character literal ''" in
+      let sub =
+        [Location.msg
+           "Hint: Did you mean ' ' or a type variable 'a?"] in
+      Location.error ~loc ~sub msg
+  | Keyword_as_label kwd ->
+      Location.errorf ~loc
+        "`%s' is a keyword, it cannot be used as label name" kwd
+  | Invalid_literal s ->
+      Location.errorf ~loc "Invalid literal %s" s
+  | Invalid_directive (dir, explanation) ->
+      Location.errorf ~loc "Invalid lexer directive %S%t" dir
+        (fun ppf -> match explanation with
+           | None -> ()
+           | Some expl -> fprintf ppf ": %s" expl)
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (err, loc) ->
+          Some (prepare_error loc err)
+      | _ ->
+          None
+    )
+
+}
+
+let newline = ('\013'* '\010')
+let blank = [' ' '\009' '\012']
+let lowercase = ['a'-'z' '_']
+let uppercase = ['A'-'Z']
+let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9']
+let lowercase_latin1 = ['a'-'z' '\223'-'\246' '\248'-'\255' '_']
+let uppercase_latin1 = ['A'-'Z' '\192'-'\214' '\216'-'\222']
+let identchar_latin1 =
+  ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
+(* This should be kept in sync with the [is_identchar] function in [env.ml] *)
+
+let symbolchar =
+  ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
+let dotsymbolchar =
+  ['!' '$' '%' '&' '*' '+' '-' '/' ':' '=' '>' '?' '@' '^' '|']
+let symbolchar_or_hash =
+  symbolchar | '#'
+let kwdopchar =
+  ['$' '&' '*' '+' '-' '/' '<' '=' '>' '@' '^' '|']
+
+let ident = (lowercase | uppercase) identchar*
+let extattrident = ident ('.' ident)*
+
+let decimal_literal =
+  ['0'-'9'] ['0'-'9' '_']*
+let hex_digit =
+  ['0'-'9' 'A'-'F' 'a'-'f']
+let hex_literal =
+  '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']['0'-'9' 'A'-'F' 'a'-'f' '_']*
+let oct_literal =
+  '0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']*
+let bin_literal =
+  '0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']*
+let int_literal =
+  decimal_literal | hex_literal | oct_literal | bin_literal
+let float_literal =
+  ['0'-'9'] ['0'-'9' '_']*
+  ('.' ['0'-'9' '_']* )?
+  (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )?
+let hex_float_literal =
+  '0' ['x' 'X']
+  ['0'-'9' 'A'-'F' 'a'-'f'] ['0'-'9' 'A'-'F' 'a'-'f' '_']*
+  ('.' ['0'-'9' 'A'-'F' 'a'-'f' '_']* )?
+  (['p' 'P'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )?
+let literal_modifier = ['G'-'Z' 'g'-'z']
+
+rule token = parse
+  | ('\\' as bs) newline {
+      if not !escaped_newlines then error lexbuf (Illegal_character bs);
+      update_loc lexbuf None 1 false 0;
+      token lexbuf }
+  | newline
+      { update_loc lexbuf None 1 false 0;
+        EOL }
+  | blank +
+      { token lexbuf }
+  | "_"
+      { UNDERSCORE }
+  | "~"
+      { TILDE }
+  | ".~"
+      { error lexbuf
+          (Reserved_sequence (".~", Some "is reserved for use in MetaOCaml")) }
+  | "~" (lowercase identchar * as name) ':'
+      { check_label_name lexbuf name;
+        LABEL name }
+  | "~" (lowercase_latin1 identchar_latin1 * as name) ':'
+      { warn_latin1 lexbuf;
+        LABEL name }
+  | "?"
+      { QUESTION }
+  | "?" (lowercase identchar * as name) ':'
+      { check_label_name lexbuf name;
+        OPTLABEL name }
+  | "?" (lowercase_latin1 identchar_latin1 * as name) ':'
+      { warn_latin1 lexbuf;
+        OPTLABEL name }
+  | lowercase identchar * as name
+      { try Hashtbl.find keyword_table name
+        with Not_found -> LIDENT name }
+  | lowercase_latin1 identchar_latin1 * as name
+      { warn_latin1 lexbuf; LIDENT name }
+  | uppercase identchar * as name
+      { UIDENT name } (* No capitalized keywords *)
+  | uppercase_latin1 identchar_latin1 * as name
+      { warn_latin1 lexbuf; UIDENT name }
+  | int_literal as lit { INT (lit, None) }
+  | (int_literal as lit) (literal_modifier as modif)
+      { INT (lit, Some modif) }
+  | float_literal | hex_float_literal as lit
+      { FLOAT (lit, None) }
+  | (float_literal | hex_float_literal as lit) (literal_modifier as modif)
+      { FLOAT (lit, Some modif) }
+  | (float_literal | hex_float_literal | int_literal) identchar+ as invalid
+      { error lexbuf (Invalid_literal invalid) }
+  | "\""
+      { let s, loc = wrap_string_lexer string lexbuf in
+        STRING (s, loc, None) }
+  | "{" (lowercase* as delim) "|"
+      { let s, loc = wrap_string_lexer (quoted_string delim) lexbuf in
+        STRING (s, loc, Some delim) }
+  | "{%" (extattrident as id) "|"
+      { let orig_loc = Location.curr lexbuf in
+        let s, loc = wrap_string_lexer (quoted_string "") lexbuf in
+        let idloc = compute_quoted_string_idloc orig_loc 2 id in
+        QUOTED_STRING_EXPR (id, idloc, s, loc, Some "") }
+  | "{%" (extattrident as id) blank+ (lowercase* as delim) "|"
+      { let orig_loc = Location.curr lexbuf in
+        let s, loc = wrap_string_lexer (quoted_string delim) lexbuf in
+        let idloc = compute_quoted_string_idloc orig_loc 2 id in
+        QUOTED_STRING_EXPR (id, idloc, s, loc, Some delim) }
+  | "{%%" (extattrident as id) "|"
+      { let orig_loc = Location.curr lexbuf in
+        let s, loc = wrap_string_lexer (quoted_string "") lexbuf in
+        let idloc = compute_quoted_string_idloc orig_loc 3 id in
+        QUOTED_STRING_ITEM (id, idloc, s, loc, Some "") }
+  | "{%%" (extattrident as id) blank+ (lowercase* as delim) "|"
+      { let orig_loc = Location.curr lexbuf in
+        let s, loc = wrap_string_lexer (quoted_string delim) lexbuf in
+        let idloc = compute_quoted_string_idloc orig_loc 3 id in
+        QUOTED_STRING_ITEM (id, idloc, s, loc, Some delim) }
+  | "\'" newline "\'"
+      { update_loc lexbuf None 1 false 1;
+        (* newline is ('\013'* '\010') *)
+        CHAR '\n' }
+  | "\'" ([^ '\\' '\'' '\010' '\013'] as c) "\'"
+      { CHAR c }
+  | "\'\\" (['\\' '\'' '\"' 'n' 't' 'b' 'r' ' '] as c) "\'"
+      { CHAR (char_for_backslash c) }
+  | "\'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "\'"
+      { CHAR(char_for_decimal_code lexbuf 2) }
+  | "\'\\" 'o' ['0'-'7'] ['0'-'7'] ['0'-'7'] "\'"
+      { CHAR(char_for_octal_code lexbuf 3) }
+  | "\'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "\'"
+      { CHAR(char_for_hexadecimal_code lexbuf 3) }
+  | "\'" ("\\" _ as esc)
+      { error lexbuf (Illegal_escape (esc, None)) }
+  | "\'\'"
+      { error lexbuf Empty_character_literal }
+  | "(*"
+      { let s, loc = wrap_comment_lexer comment lexbuf in
+        COMMENT (s, loc) }
+  | "(**"
+      { let s, loc = wrap_comment_lexer comment lexbuf in
+        if !handle_docstrings then
+          DOCSTRING (Docstrings.docstring s loc)
+        else
+          COMMENT ("*" ^ s, loc)
+      }
+  | "(**" (('*'+) as stars)
+      { let s, loc =
+          wrap_comment_lexer
+            (fun lexbuf ->
+               store_string ("*" ^ stars);
+               comment lexbuf)
+            lexbuf
+        in
+        COMMENT (s, loc) }
+  | "(*)"
+      { if !print_warnings then
+          Location.prerr_warning (Location.curr lexbuf) Warnings.Comment_start;
+        let s, loc = wrap_comment_lexer comment lexbuf in
+        COMMENT (s, loc) }
+  | "(*" (('*'*) as stars) "*)"
+      { if !handle_docstrings && stars="" then
+         (* (**) is an empty docstring *)
+          DOCSTRING(Docstrings.docstring "" (Location.curr lexbuf))
+        else
+          COMMENT (stars, Location.curr lexbuf) }
+  | "*)"
+      { let loc = Location.curr lexbuf in
+        Location.prerr_warning loc Warnings.Comment_not_end;
+        lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1;
+        let curpos = lexbuf.lex_curr_p in
+        lexbuf.lex_curr_p <- { curpos with pos_cnum = curpos.pos_cnum - 1 };
+        STAR
+      }
+  | "#"
+      { let at_beginning_of_line pos = (pos.pos_cnum = pos.pos_bol) in
+        if not (at_beginning_of_line lexbuf.lex_start_p)
+        then HASH
+        else try directive lexbuf with Failure _ -> HASH
+      }
+  | "&"  { AMPERSAND }
+  | "&&" { AMPERAMPER }
+  | "`"  { BACKQUOTE }
+  | "\'" { QUOTE }
+  | "("  { LPAREN }
+  | ")"  { RPAREN }
+  | "*"  { STAR }
+  | ","  { COMMA }
+  | "->" { MINUSGREATER }
+  | "."  { DOT }
+  | ".." { DOTDOT }
+  | "." (dotsymbolchar symbolchar* as op) { DOTOP op }
+  | ":"  { COLON }
+  | "::" { COLONCOLON }
+  | ":=" { COLONEQUAL }
+  | ":>" { COLONGREATER }
+  | ";"  { SEMI }
+  | ";;" { SEMISEMI }
+  | "<"  { LESS }
+  | "<-" { LESSMINUS }
+  | "="  { EQUAL }
+  | "["  { LBRACKET }
+  | "[|" { LBRACKETBAR }
+  | "[<" { LBRACKETLESS }
+  | "[>" { LBRACKETGREATER }
+  | "]"  { RBRACKET }
+  | "{"  { LBRACE }
+  | "{<" { LBRACELESS }
+  | "|"  { BAR }
+  | "||" { BARBAR }
+  | "|]" { BARRBRACKET }
+  | ">"  { GREATER }
+  | ">]" { GREATERRBRACKET }
+  | "}"  { RBRACE }
+  | ">}" { GREATERRBRACE }
+  | "[@" { LBRACKETAT }
+  | "[@@"  { LBRACKETATAT }
+  | "[@@@" { LBRACKETATATAT }
+  | "[%"   { LBRACKETPERCENT }
+  | "[%%"  { LBRACKETPERCENTPERCENT }
+  | "!"  { BANG }
+  | "!=" { INFIXOP0 "!=" }
+  | "+"  { PLUS }
+  | "+." { PLUSDOT }
+  | "+=" { PLUSEQ }
+  | "-"  { MINUS }
+  | "-." { MINUSDOT }
+
+  | "!" symbolchar_or_hash + as op
+            { PREFIXOP op }
+  | ['~' '?'] symbolchar_or_hash + as op
+            { PREFIXOP op }
+  | ['=' '<' '>' '|' '&' '$'] symbolchar * as op
+            { INFIXOP0 op }
+  | ['@' '^'] symbolchar * as op
+            { INFIXOP1 op }
+  | ['+' '-'] symbolchar * as op
+            { INFIXOP2 op }
+  | "**" symbolchar * as op
+            { INFIXOP4 op }
+  | '%'     { PERCENT }
+  | ['*' '/' '%'] symbolchar * as op
+            { INFIXOP3 op }
+  | '#' symbolchar_or_hash + as op
+            { HASHOP op }
+  | "let" kwdopchar dotsymbolchar * as op
+            { LETOP op }
+  | "and" kwdopchar dotsymbolchar * as op
+            { ANDOP op }
+  | eof { EOF }
+  | (_ as illegal_char)
+      { error lexbuf (Illegal_character illegal_char) }
+
+and directive = parse
+  | ([' ' '\t']* (['0'-'9']+ as num) [' ' '\t']*
+        ("\"" ([^ '\010' '\013' '\"' ] * as name) "\"") as directive)
+        [^ '\010' '\013'] *
+      {
+        match int_of_string num with
+        | exception _ ->
+            (* PR#7165 *)
+            let explanation = "line number out of range" in
+            error lexbuf (Invalid_directive ("#" ^ directive, Some explanation))
+        | line_num ->
+           (* Documentation says that the line number should be
+              positive, but we have never guarded against this and it
+              might have useful hackish uses. *)
+            update_loc lexbuf (Some name) (line_num - 1) true 0;
+            token lexbuf
+      }
+and comment = parse
+    "(*"
+      { comment_start_loc := (Location.curr lexbuf) :: !comment_start_loc;
+        store_lexeme lexbuf;
+        comment lexbuf
+      }
+  | "*)"
+      { match !comment_start_loc with
+        | [] -> assert false
+        | [_] -> comment_start_loc := []; Location.curr lexbuf
+        | _ :: l -> comment_start_loc := l;
+                  store_lexeme lexbuf;
+                  comment lexbuf
+       }
+  | "\""
+      {
+        string_start_loc := Location.curr lexbuf;
+        store_string_char '\"';
+        is_in_string := true;
+        let _loc = try string lexbuf
+        with Error (Unterminated_string, str_start) ->
+          match !comment_start_loc with
+          | [] -> assert false
+          | loc :: _ ->
+            let start = List.hd (List.rev !comment_start_loc) in
+            comment_start_loc := [];
+            error_loc loc (Unterminated_string_in_comment (start, str_start))
+        in
+        is_in_string := false;
+        store_string_char '\"';
+        comment lexbuf }
+  | "{" ('%' '%'? extattrident blank*)? (lowercase* as delim) "|"
+      {
+        string_start_loc := Location.curr lexbuf;
+        store_lexeme lexbuf;
+        is_in_string := true;
+        let _loc = try quoted_string delim lexbuf
+        with Error (Unterminated_string, str_start) ->
+          match !comment_start_loc with
+          | [] -> assert false
+          | loc :: _ ->
+            let start = List.hd (List.rev !comment_start_loc) in
+            comment_start_loc := [];
+            error_loc loc (Unterminated_string_in_comment (start, str_start))
+        in
+        is_in_string := false;
+        store_string_char '|';
+        store_string delim;
+        store_string_char '}';
+        comment lexbuf }
+  | "\'\'"
+      { store_lexeme lexbuf; comment lexbuf }
+  | "\'" newline "\'"
+      { update_loc lexbuf None 1 false 1;
+        store_lexeme lexbuf;
+        comment lexbuf
+      }
+  | "\'" [^ '\\' '\'' '\010' '\013' ] "\'"
+      { store_lexeme lexbuf; comment lexbuf }
+  | "\'\\" ['\\' '\"' '\'' 'n' 't' 'b' 'r' ' '] "\'"
+      { store_lexeme lexbuf; comment lexbuf }
+  | "\'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "\'"
+      { store_lexeme lexbuf; comment lexbuf }
+  | "\'\\" 'o' ['0'-'3'] ['0'-'7'] ['0'-'7'] "\'"
+      { store_lexeme lexbuf; comment lexbuf }
+  | "\'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "\'"
+      { store_lexeme lexbuf; comment lexbuf }
+  | eof
+      { match !comment_start_loc with
+        | [] -> assert false
+        | loc :: _ ->
+          let start = List.hd (List.rev !comment_start_loc) in
+          comment_start_loc := [];
+          error_loc loc (Unterminated_comment start)
+      }
+  | newline
+      { update_loc lexbuf None 1 false 0;
+        store_lexeme lexbuf;
+        comment lexbuf
+      }
+  | ident
+      { store_lexeme lexbuf; comment lexbuf }
+  | _
+      { store_lexeme lexbuf; comment lexbuf }
+
+and string = parse
+    '\"'
+      { lexbuf.lex_start_p }
+  | '\\' newline ([' ' '\t'] * as space)
+      { update_loc lexbuf None 1 false (String.length space);
+        if in_comment () then store_lexeme lexbuf;
+        string lexbuf
+      }
+  | '\\' (['\\' '\'' '\"' 'n' 't' 'b' 'r' ' '] as c)
+      { store_escaped_char lexbuf (char_for_backslash c);
+        string lexbuf }
+  | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9']
+      { store_escaped_char lexbuf (char_for_decimal_code lexbuf 1);
+         string lexbuf }
+  | '\\' 'o' ['0'-'7'] ['0'-'7'] ['0'-'7']
+      { store_escaped_char lexbuf (char_for_octal_code lexbuf 2);
+         string lexbuf }
+  | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F']
+      { store_escaped_char lexbuf (char_for_hexadecimal_code lexbuf 2);
+         string lexbuf }
+  | '\\' 'u' '{' hex_digit+ '}'
+        { store_escaped_uchar lexbuf (uchar_for_uchar_escape lexbuf);
+          string lexbuf }
+  | '\\' _
+      { if not (in_comment ()) then begin
+(*  Should be an error, but we are very lax.
+          error lexbuf (Illegal_escape (Lexing.lexeme lexbuf, None))
+*)
+          let loc = Location.curr lexbuf in
+          Location.prerr_warning loc Warnings.Illegal_backslash;
+        end;
+        store_lexeme lexbuf;
+        string lexbuf
+      }
+  | newline
+      { if not (in_comment ()) then
+          Location.prerr_warning (Location.curr lexbuf) Warnings.Eol_in_string;
+        update_loc lexbuf None 1 false 0;
+        store_lexeme lexbuf;
+        string lexbuf
+      }
+  | eof
+      { is_in_string := false;
+        error_loc !string_start_loc Unterminated_string }
+  | (_ as c)
+      { store_string_char c;
+        string lexbuf }
+
+and quoted_string delim = parse
+  | newline
+      { update_loc lexbuf None 1 false 0;
+        store_lexeme lexbuf;
+        quoted_string delim lexbuf
+      }
+  | eof
+      { is_in_string := false;
+        error_loc !string_start_loc Unterminated_string }
+  | "|" (lowercase* as edelim) "}"
+      {
+        if delim = edelim then lexbuf.lex_start_p
+        else (store_lexeme lexbuf; quoted_string delim lexbuf)
+      }
+  | (_ as c)
+      { store_string_char c;
+        quoted_string delim lexbuf }
+
+and skip_hash_bang = parse
+  | "#!" [^ '\n']* '\n' [^ '\n']* "\n!#\n"
+      { update_loc lexbuf None 3 false 0 }
+  | "#!" [^ '\n']* '\n'
+      { update_loc lexbuf None 1 false 0 }
+  | "" { () }
+
+{
+
+  let token_with_comments lexbuf =
+    match !preprocessor with
+    | None -> token lexbuf
+    | Some (_init, preprocess) -> preprocess token lexbuf
+
+  type newline_state =
+    | NoLine (* There have been no blank lines yet. *)
+    | NewLine
+        (* There have been no blank lines, and the previous
+           token was a newline. *)
+    | BlankLine (* There have been blank lines. *)
+
+  type doc_state =
+    | Initial  (* There have been no docstrings yet *)
+    | After of docstring list
+        (* There have been docstrings, none of which were
+           preceded by a blank line *)
+    | Before of docstring list * docstring list * docstring list
+        (* There have been docstrings, some of which were
+           preceded by a blank line *)
+
+  and docstring = Docstrings.docstring
+
+  let token lexbuf =
+    let post_pos = lexeme_end_p lexbuf in
+    let attach lines docs pre_pos =
+      let open Docstrings in
+        match docs, lines with
+        | Initial, _ -> ()
+        | After a, (NoLine | NewLine) ->
+            set_post_docstrings post_pos (List.rev a);
+            set_pre_docstrings pre_pos a;
+        | After a, BlankLine ->
+            set_post_docstrings post_pos (List.rev a);
+            set_pre_extra_docstrings pre_pos (List.rev a)
+        | Before(a, f, b), (NoLine | NewLine) ->
+            set_post_docstrings post_pos (List.rev a);
+            set_post_extra_docstrings post_pos
+              (List.rev_append f (List.rev b));
+            set_floating_docstrings pre_pos (List.rev f);
+            set_pre_extra_docstrings pre_pos (List.rev a);
+            set_pre_docstrings pre_pos b
+        | Before(a, f, b), BlankLine ->
+            set_post_docstrings post_pos (List.rev a);
+            set_post_extra_docstrings post_pos
+              (List.rev_append f (List.rev b));
+            set_floating_docstrings pre_pos
+              (List.rev_append f (List.rev b));
+            set_pre_extra_docstrings pre_pos (List.rev a)
+    in
+    let rec loop lines docs lexbuf =
+      match token_with_comments lexbuf with
+      | COMMENT (s, loc) ->
+          add_comment (s, loc);
+          let lines' =
+            match lines with
+            | NoLine -> NoLine
+            | NewLine -> NoLine
+            | BlankLine -> BlankLine
+          in
+          loop lines' docs lexbuf
+      | EOL ->
+          let lines' =
+            match lines with
+            | NoLine -> NewLine
+            | NewLine -> BlankLine
+            | BlankLine -> BlankLine
+          in
+          loop lines' docs lexbuf
+      | DOCSTRING doc ->
+          Docstrings.register doc;
+          add_docstring_comment doc;
+          let docs' =
+            if Docstrings.docstring_body doc = "/*" then
+              match docs with
+              | Initial -> Before([], [doc], [])
+              | After a -> Before (a, [doc], [])
+              | Before(a, f, b) -> Before(a, doc :: b @ f, [])
+            else
+              match docs, lines with
+              | Initial, (NoLine | NewLine) -> After [doc]
+              | Initial, BlankLine -> Before([], [], [doc])
+              | After a, (NoLine | NewLine) -> After (doc :: a)
+              | After a, BlankLine -> Before (a, [], [doc])
+              | Before(a, f, b), (NoLine | NewLine) -> Before(a, f, doc :: b)
+              | Before(a, f, b), BlankLine -> Before(a, b @ f, [doc])
+          in
+          loop NoLine docs' lexbuf
+      | tok ->
+          attach lines docs (lexeme_start_p lexbuf);
+          tok
+    in
+      loop NoLine Initial lexbuf
+
+  let init () =
+    is_in_string := false;
+    comment_start_loc := [];
+    comment_list := [];
+    match !preprocessor with
+    | None -> ()
+    | Some (init, _preprocess) -> init ()
+
+  let set_preprocessor init preprocess =
+    escaped_newlines := true;
+    preprocessor := Some (init, preprocess)
+
+}
diff --git a/upstream/ocaml_413/parsing/location.ml b/upstream/ocaml_413/parsing/location.ml
new file mode 100644
index 0000000..26a6601
--- /dev/null
+++ b/upstream/ocaml_413/parsing/location.ml
@@ -0,0 +1,949 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Lexing
+
+type t = Warnings.loc =
+  { loc_start: position; loc_end: position; loc_ghost: bool };;
+
+let in_file name =
+  let loc = { dummy_pos with pos_fname = name } in
+  { loc_start = loc; loc_end = loc; loc_ghost = true }
+;;
+
+let none = in_file "_none_";;
+let is_none l = (l = none);;
+
+let curr lexbuf = {
+  loc_start = lexbuf.lex_start_p;
+  loc_end = lexbuf.lex_curr_p;
+  loc_ghost = false
+};;
+
+let init lexbuf fname =
+  lexbuf.lex_curr_p <- {
+    pos_fname = fname;
+    pos_lnum = 1;
+    pos_bol = 0;
+    pos_cnum = 0;
+  }
+;;
+
+let symbol_rloc () = {
+  loc_start = Parsing.symbol_start_pos ();
+  loc_end = Parsing.symbol_end_pos ();
+  loc_ghost = false;
+};;
+
+let symbol_gloc () = {
+  loc_start = Parsing.symbol_start_pos ();
+  loc_end = Parsing.symbol_end_pos ();
+  loc_ghost = true;
+};;
+
+let rhs_loc n = {
+  loc_start = Parsing.rhs_start_pos n;
+  loc_end = Parsing.rhs_end_pos n;
+  loc_ghost = false;
+};;
+
+let rhs_interval m n = {
+  loc_start = Parsing.rhs_start_pos m;
+  loc_end = Parsing.rhs_end_pos n;
+  loc_ghost = false;
+};;
+
+(* return file, line, char from the given position *)
+let get_pos_info pos =
+  (pos.pos_fname, pos.pos_lnum, pos.pos_cnum - pos.pos_bol)
+;;
+
+type 'a loc = {
+  txt : 'a;
+  loc : t;
+}
+
+let mkloc txt loc = { txt ; loc }
+let mknoloc txt = mkloc txt none
+
+(******************************************************************************)
+(* Input info *)
+
+let input_name = ref "_none_"
+let input_lexbuf = ref (None : lexbuf option)
+let input_phrase_buffer = ref (None : Buffer.t option)
+
+(******************************************************************************)
+(* Terminal info *)
+
+let status = ref Terminfo.Uninitialised
+
+let setup_terminal () =
+  if !status = Terminfo.Uninitialised then
+    status := Terminfo.setup stdout
+
+(* The number of lines already printed after input.
+
+   This is used by [highlight_terminfo] to identify the current position of the
+   input in the terminal. This would not be possible without this information,
+   since printing several warnings/errors adds text between the user input and
+   the bottom of the terminal.
+*)
+let num_loc_lines = ref 0
+
+(* This is used by the toplevel to reset [num_loc_lines] before each phrase *)
+let reset () =
+  num_loc_lines := 0
+
+(* This is used by the toplevel *)
+let echo_eof () =
+  print_newline ();
+  incr num_loc_lines
+
+(* Code printing errors and warnings must be wrapped using this function, in
+   order to update [num_loc_lines].
+
+   [print_updating_num_loc_lines ppf f arg] is equivalent to calling [f ppf
+   arg], and additionally updates [num_loc_lines]. *)
+let print_updating_num_loc_lines ppf f arg =
+  let open Format in
+  let out_functions = pp_get_formatter_out_functions ppf () in
+  let out_string str start len =
+    let rec count i c =
+      if i = start + len then c
+      else if String.get str i = '\n' then count (succ i) (succ c)
+      else count (succ i) c in
+    num_loc_lines := !num_loc_lines + count start 0 ;
+    out_functions.out_string str start len in
+  pp_set_formatter_out_functions ppf
+    { out_functions with out_string } ;
+  f ppf arg ;
+  pp_print_flush ppf ();
+  pp_set_formatter_out_functions ppf out_functions
+
+let setup_colors () =
+  Misc.Color.setup !Clflags.color
+
+(******************************************************************************)
+(* Printing locations, e.g. 'File "foo.ml", line 3, characters 10-12' *)
+
+let rewrite_absolute_path path =
+  match Misc.get_build_path_prefix_map () with
+  | None -> path
+  | Some map -> Build_path_prefix_map.rewrite map path
+
+let absolute_path s = (* This function could go into Filename *)
+  let open Filename in
+  let s =
+    if not (is_relative s) then s
+    else (rewrite_absolute_path (concat (Sys.getcwd ()) s))
+  in
+  (* Now simplify . and .. components *)
+  let rec aux s =
+    let base = basename s in
+    let dir = dirname s in
+    if dir = s then dir
+    else if base = current_dir_name then aux dir
+    else if base = parent_dir_name then dirname (aux dir)
+    else concat (aux dir) base
+  in
+  aux s
+
+let show_filename file =
+  if !Clflags.absname then absolute_path file else file
+
+let print_filename ppf file =
+  Format.pp_print_string ppf (show_filename file)
+
+(* Best-effort printing of the text describing a location, of the form
+   'File "foo.ml", line 3, characters 10-12'.
+
+   Some of the information (filename, line number or characters numbers) in the
+   location might be invalid; in which case we do not print it.
+ *)
+let print_loc ppf loc =
+  setup_colors ();
+  let file_valid = function
+    | "_none_" ->
+        (* This is a dummy placeholder, but we print it anyway to please editors
+           that parse locations in error messages (e.g. Emacs). *)
+        true
+    | "" | "//toplevel//" -> false
+    | _ -> true
+  in
+  let line_valid line = line > 0 in
+  let chars_valid ~startchar ~endchar = startchar <> -1 && endchar <> -1 in
+
+  let file =
+    (* According to the comment in location.mli, if [pos_fname] is "", we must
+       use [!input_name]. *)
+    if loc.loc_start.pos_fname = "" then !input_name
+    else loc.loc_start.pos_fname
+  in
+  let startline = loc.loc_start.pos_lnum in
+  let endline = loc.loc_end.pos_lnum in
+  let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in
+  let endchar = loc.loc_end.pos_cnum - loc.loc_end.pos_bol in
+
+  let first = ref true in
+  let capitalize s =
+    if !first then (first := false; String.capitalize_ascii s)
+    else s in
+  let comma () =
+    if !first then () else Format.fprintf ppf ", " in
+
+  Format.fprintf ppf "@{<loc>";
+
+  if file_valid file then
+    Format.fprintf ppf "%s \"%a\"" (capitalize "file") print_filename file;
+
+  (* Print "line 1" in the case of a dummy line number. This is to please the
+     existing setup of editors that parse locations in error messages (e.g.
+     Emacs). *)
+  comma ();
+  let startline = if line_valid startline then startline else 1 in
+  let endline = if line_valid endline then endline else startline in
+  begin if startline = endline then
+    Format.fprintf ppf "%s %i" (capitalize "line") startline
+  else
+    Format.fprintf ppf "%s %i-%i" (capitalize "lines") startline endline
+  end;
+
+  if chars_valid ~startchar ~endchar then (
+    comma ();
+    Format.fprintf ppf "%s %i-%i" (capitalize "characters") startchar endchar
+  );
+
+  Format.fprintf ppf "@}"
+
+(* Print a comma-separated list of locations *)
+let print_locs ppf locs =
+  Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ")
+    print_loc ppf locs
+
+(******************************************************************************)
+(* An interval set structure; additionally, it stores user-provided information
+   at interval boundaries.
+
+   The implementation provided here is naive and assumes the number of intervals
+   to be small, but the interface would allow for a more efficient
+   implementation if needed.
+
+   Note: the structure only stores maximal intervals (that therefore do not
+   overlap).
+*)
+
+module ISet : sig
+  type 'a bound = 'a * int
+  type 'a t
+  (* bounds are included *)
+  val of_intervals : ('a bound * 'a bound) list -> 'a t
+
+  val mem : 'a t -> pos:int -> bool
+  val find_bound_in : 'a t -> range:(int * int) -> 'a bound option
+
+  val is_start : 'a t -> pos:int -> 'a option
+  val is_end : 'a t -> pos:int -> 'a option
+
+  val extrema : 'a t -> ('a bound * 'a bound) option
+end
+=
+struct
+  type 'a bound = 'a * int
+
+  (* non overlapping intervals *)
+  type 'a t = ('a bound * 'a bound) list
+
+  let of_intervals intervals =
+    let pos =
+      List.map (fun ((a, x), (b, y)) ->
+        if x > y then [] else [((a, x), `S); ((b, y), `E)]
+      ) intervals
+      |> List.flatten
+      |> List.sort (fun ((_, x), k) ((_, y), k') ->
+        (* Make `S come before `E so that consecutive intervals get merged
+           together in the fold below *)
+        let kn = function `S -> 0 | `E -> 1 in
+        compare (x, kn k) (y, kn k'))
+    in
+    let nesting, acc =
+      List.fold_left (fun (nesting, acc) (a, kind) ->
+        match kind, nesting with
+        | `S, `Outside -> `Inside (a, 0), acc
+        | `S, `Inside (s, n) -> `Inside (s, n+1), acc
+        | `E, `Outside -> assert false
+        | `E, `Inside (s, 0) -> `Outside, ((s, a) :: acc)
+        | `E, `Inside (s, n) -> `Inside (s, n-1), acc
+      ) (`Outside, []) pos in
+    assert (nesting = `Outside);
+    List.rev acc
+
+  let mem iset ~pos =
+    List.exists (fun ((_, s), (_, e)) -> s <= pos && pos <= e) iset
+
+  let find_bound_in iset ~range:(start, end_)  =
+    List.find_map (fun ((a, x), (b, y)) ->
+      if start <= x && x <= end_ then Some (a, x)
+      else if start <= y && y <= end_ then Some (b, y)
+      else None
+    ) iset
+
+  let is_start iset ~pos =
+    List.find_map (fun ((a, x), _) ->
+      if pos = x then Some a else None
+    ) iset
+
+  let is_end iset ~pos =
+    List.find_map (fun (_, (b, y)) ->
+      if pos = y then Some b else None
+    ) iset
+
+  let extrema iset =
+    if iset = [] then None
+    else Some (fst (List.hd iset), snd (List.hd (List.rev iset)))
+end
+
+(******************************************************************************)
+(* Toplevel: highlighting and quoting locations *)
+
+(* Highlight the locations using standout mode.
+
+   If [locs] is empty, this function is a no-op.
+*)
+let highlight_terminfo lb ppf locs =
+  Format.pp_print_flush ppf ();  (* avoid mixing Format and normal output *)
+  (* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *)
+  let pos0 = -lb.lex_abs_pos in
+  (* Do nothing if the buffer does not contain the whole phrase. *)
+  if pos0 < 0 then raise Exit;
+  (* Count number of lines in phrase *)
+  let lines = ref !num_loc_lines in
+  for i = pos0 to lb.lex_buffer_len - 1 do
+    if Bytes.get lb.lex_buffer i = '\n' then incr lines
+  done;
+  (* If too many lines, give up *)
+  if !lines >= Terminfo.num_lines stdout - 2 then raise Exit;
+  (* Move cursor up that number of lines *)
+  flush stdout; Terminfo.backup stdout !lines;
+  (* Print the input, switching to standout for the location *)
+  let bol = ref false in
+  print_string "# ";
+  for pos = 0 to lb.lex_buffer_len - pos0 - 1 do
+    if !bol then (print_string "  "; bol := false);
+    if List.exists (fun loc -> pos = loc.loc_start.pos_cnum) locs then
+      Terminfo.standout stdout true;
+    if List.exists (fun loc -> pos = loc.loc_end.pos_cnum) locs then
+      Terminfo.standout stdout false;
+    let c = Bytes.get lb.lex_buffer (pos + pos0) in
+    print_char c;
+    bol := (c = '\n')
+  done;
+  (* Make sure standout mode is over *)
+  Terminfo.standout stdout false;
+  (* Position cursor back to original location *)
+  Terminfo.resume stdout !num_loc_lines;
+  flush stdout
+
+let highlight_terminfo lb ppf locs =
+  try highlight_terminfo lb ppf locs
+  with Exit -> ()
+
+(* Highlight the location by printing it again.
+
+   There are two different styles for highlighting errors in "dumb" mode,
+   depending if the error fits on a single line or spans across several lines.
+
+   For single-line errors,
+
+     foo the_error bar
+
+   gets displayed as follows, where X is the line number:
+
+     X | foo the_error bar
+             ^^^^^^^^^
+
+
+   For multi-line errors,
+
+     foo the_
+     error bar
+
+   gets displayed as:
+
+     X1 | ....the_
+     X2 | error....
+
+   An ellipsis hides the middle lines of the multi-line error if it has more
+   than [max_lines] lines.
+
+   If [locs] is empty then this function is a no-op.
+*)
+
+type input_line = {
+  text : string;
+  start_pos : int;
+}
+
+(* Takes a list of lines with possibly missing line numbers.
+
+   If the line numbers that are present are consistent with the number of lines
+   between them, then infer the intermediate line numbers.
+
+   This is not always the case, typically if lexer line directives are
+   involved... *)
+let infer_line_numbers
+    (lines: (int option * input_line) list):
+  (int option * input_line) list
+  =
+  let (_, offset, consistent) =
+    List.fold_left (fun (i, offset, consistent) (lnum, _) ->
+      match lnum, offset with
+      | None, _ -> (i+1, offset, consistent)
+      | Some n, None -> (i+1, Some (n - i), consistent)
+      | Some n, Some m -> (i+1, offset, consistent && n = m + i)
+    ) (0, None, true) lines
+  in
+  match offset, consistent with
+  | Some m, true ->
+      List.mapi (fun i (_, line) -> (Some (m + i), line)) lines
+  | _, _ ->
+      lines
+
+(* [get_lines] must return the lines to highlight, given starting and ending
+   positions.
+
+   See [lines_around_from_current_input] below for an instantiation of
+   [get_lines] that reads from the current input.
+*)
+let highlight_quote ppf
+    ~(get_lines: start_pos:position -> end_pos:position -> input_line list)
+    ?(max_lines = 10)
+    highlight_tag
+    locs
+  =
+  let iset = ISet.of_intervals @@ List.filter_map (fun loc ->
+    let s, e = loc.loc_start, loc.loc_end in
+    if s.pos_cnum = -1 || e.pos_cnum = -1 then None
+    else Some ((s, s.pos_cnum), (e, e.pos_cnum - 1))
+  ) locs in
+  match ISet.extrema iset with
+  | None -> ()
+  | Some ((leftmost, _), (rightmost, _)) ->
+      let lines =
+        get_lines ~start_pos:leftmost ~end_pos:rightmost
+        |> List.map (fun ({ text; start_pos } as line) ->
+          let end_pos = start_pos + String.length text - 1 in
+          let line_nb =
+            match ISet.find_bound_in iset ~range:(start_pos, end_pos) with
+            | None -> None
+            | Some (p, _) -> Some p.pos_lnum
+          in
+          (line_nb, line))
+        |> infer_line_numbers
+        |> List.map (fun (lnum, { text; start_pos }) ->
+          (text,
+           Option.fold ~some:Int.to_string ~none:"" lnum,
+           start_pos))
+      in
+    Format.fprintf ppf "@[<v>";
+    begin match lines with
+    | [] | [("", _, _)] -> ()
+    | [(line, line_nb, line_start_cnum)] ->
+        (* Single-line error *)
+        Format.fprintf ppf "%s | %s@," line_nb line;
+        Format.fprintf ppf "%*s   " (String.length line_nb) "";
+        for pos = line_start_cnum to rightmost.pos_cnum - 1 do
+          if ISet.is_start iset ~pos <> None then
+            Format.fprintf ppf "@{<%s>" highlight_tag;
+          if ISet.mem iset ~pos then Format.pp_print_char ppf '^'
+          else Format.pp_print_char ppf ' ';
+          if ISet.is_end iset ~pos <> None then
+            Format.fprintf ppf "@}"
+        done;
+        Format.fprintf ppf "@}@,"
+    | _ ->
+        (* Multi-line error *)
+        Misc.pp_two_columns ~sep:"|" ~max_lines ppf
+        @@ List.map (fun (line, line_nb, line_start_cnum) ->
+          let line = String.mapi (fun i car ->
+            if ISet.mem iset ~pos:(line_start_cnum + i) then car else '.'
+          ) line in
+          (line_nb, line)
+        ) lines
+    end;
+    Format.fprintf ppf "@]"
+
+
+
+let lines_around
+    ~(start_pos: position) ~(end_pos: position)
+    ~(seek: int -> unit)
+    ~(read_char: unit -> char option):
+  input_line list
+  =
+  seek start_pos.pos_bol;
+  let lines = ref [] in
+  let bol = ref start_pos.pos_bol in
+  let cur = ref start_pos.pos_bol in
+  let b = Buffer.create 80 in
+  let add_line () =
+    if !bol < !cur then begin
+      let text = Buffer.contents b in
+      Buffer.clear b;
+      lines := { text; start_pos = !bol } :: !lines;
+      bol := !cur
+    end
+  in
+  let rec loop () =
+    if !bol >= end_pos.pos_cnum then ()
+    else begin
+      match read_char () with
+      | None ->
+          (* end of input *)
+          add_line ()
+      | Some c ->
+          incr cur;
+          match c with
+          | '\r' -> loop ()
+          | '\n' -> add_line (); loop ()
+          | _ -> Buffer.add_char b c; loop ()
+    end
+  in
+  loop ();
+  List.rev !lines
+
+(* Try to get lines from a lexbuf *)
+let lines_around_from_lexbuf
+    ~(start_pos: position) ~(end_pos: position)
+    (lb: lexbuf):
+  input_line list
+  =
+  (* Converts a global position to one that is relative to the lexing buffer *)
+  let rel n = n - lb.lex_abs_pos in
+  if rel start_pos.pos_bol < 0 then begin
+    (* Do nothing if the buffer does not contain the input (because it has been
+       refilled while lexing it) *)
+    []
+  end else begin
+    let pos = ref 0 in (* relative position *)
+    let seek n = pos := rel n in
+    let read_char () =
+      if !pos >= lb.lex_buffer_len then (* end of buffer *) None
+      else
+        let c = Bytes.get lb.lex_buffer !pos in
+        incr pos; Some c
+    in
+    lines_around ~start_pos ~end_pos ~seek ~read_char
+  end
+
+(* Attempt to get lines from the phrase buffer *)
+let lines_around_from_phrasebuf
+    ~(start_pos: position) ~(end_pos: position)
+    (pb: Buffer.t):
+  input_line list
+  =
+  let pos = ref 0 in
+  let seek n = pos := n in
+  let read_char () =
+    if !pos >= Buffer.length pb then None
+    else begin
+      let c = Buffer.nth pb !pos in
+      incr pos; Some c
+    end
+  in
+  lines_around ~start_pos ~end_pos ~seek ~read_char
+
+(* Get lines from a file *)
+let lines_around_from_file
+    ~(start_pos: position) ~(end_pos: position)
+    (filename: string):
+  input_line list
+  =
+  try
+    let cin = open_in_bin filename in
+    let read_char () =
+      try Some (input_char cin) with End_of_file -> None
+    in
+    let lines =
+      lines_around ~start_pos ~end_pos ~seek:(seek_in cin) ~read_char
+    in
+    close_in cin;
+    lines
+  with Sys_error _ -> []
+
+(* A [get_lines] function for [highlight_quote] that reads from the current
+   input.
+
+   It first tries to read from [!input_lexbuf], then if that fails (because the
+   lexbuf no longer contains the input we want), it reads from [!input_name]
+   directly *)
+let lines_around_from_current_input ~start_pos ~end_pos =
+  (* Be a bit defensive, and do not try to open one of the possible
+     [!input_name] values that we know do not denote valid filenames. *)
+  let file_valid = function
+    | "//toplevel//" | "_none_" | "" -> false
+    | _ -> true
+  in
+  let from_file () =
+    if file_valid !input_name then
+      lines_around_from_file !input_name ~start_pos ~end_pos
+    else
+      []
+  in
+  match !input_lexbuf, !input_phrase_buffer, !input_name with
+  | _, Some pb, "//toplevel//" ->
+      begin match lines_around_from_phrasebuf pb ~start_pos ~end_pos with
+      | [] -> (* Could not read the input from the phrase buffer. This is likely
+                 a sign that we were given a buggy location. *)
+          []
+      | lines ->
+          lines
+      end
+  | Some lb, _, _ ->
+      begin match lines_around_from_lexbuf lb ~start_pos ~end_pos with
+      | [] -> (* The input is likely not in the lexbuf anymore *)
+          from_file ()
+      | lines ->
+          lines
+      end
+  | None, _, _ ->
+      from_file ()
+
+(******************************************************************************)
+(* Reporting errors and warnings *)
+
+type msg = (Format.formatter -> unit) loc
+
+let msg ?(loc = none) fmt =
+  Format.kdprintf (fun txt -> { loc; txt }) fmt
+
+type report_kind =
+  | Report_error
+  | Report_warning of string
+  | Report_warning_as_error of string
+  | Report_alert of string
+  | Report_alert_as_error of string
+
+type report = {
+  kind : report_kind;
+  main : msg;
+  sub : msg list;
+}
+
+type report_printer = {
+  (* The entry point *)
+  pp : report_printer ->
+    Format.formatter -> report -> unit;
+
+  pp_report_kind : report_printer -> report ->
+    Format.formatter -> report_kind -> unit;
+  pp_main_loc : report_printer -> report ->
+    Format.formatter -> t -> unit;
+  pp_main_txt : report_printer -> report ->
+    Format.formatter -> (Format.formatter -> unit) -> unit;
+  pp_submsgs : report_printer -> report ->
+    Format.formatter -> msg list -> unit;
+  pp_submsg : report_printer -> report ->
+    Format.formatter -> msg -> unit;
+  pp_submsg_loc : report_printer -> report ->
+    Format.formatter -> t -> unit;
+  pp_submsg_txt : report_printer -> report ->
+    Format.formatter -> (Format.formatter -> unit) -> unit;
+}
+
+let is_dummy_loc loc =
+  (* Fixme: this should be just [loc.loc_ghost] and the function should be
+     inlined below. However, currently, the compiler emits in some places ghost
+     locations with valid ranges that should still be printed. These locations
+     should be made non-ghost -- in the meantime we just check if the ranges are
+     valid. *)
+  loc.loc_start.pos_cnum = -1 || loc.loc_end.pos_cnum = -1
+
+(* It only makes sense to highlight (i.e. quote or underline the corresponding
+   source code) locations that originate from the current input.
+
+   As of now, this should only happen in the following cases:
+
+   - if dummy locs or ghost locs leak out of the compiler or a buggy ppx;
+
+   - more generally, if some code uses the compiler-libs API and feeds it
+   locations that do not match the current values of [!Location.input_name],
+   [!Location.input_lexbuf];
+
+   - when calling the compiler on a .ml file that contains lexer line directives
+   indicating an other file. This should happen relatively rarely in practice --
+   in particular this is not what happens when using -pp or -ppx or a ppx
+   driver.
+*)
+let is_quotable_loc loc =
+  not (is_dummy_loc loc)
+  && loc.loc_start.pos_fname = !input_name
+  && loc.loc_end.pos_fname = !input_name
+
+let error_style () =
+  match !Clflags.error_style with
+  | Some setting -> setting
+  | None -> Misc.Error_style.default_setting
+
+let batch_mode_printer : report_printer =
+  let pp_loc _self report ppf loc =
+    let tag = match report.kind with
+      | Report_warning_as_error _
+      | Report_alert_as_error _
+      | Report_error -> "error"
+      | Report_warning _
+      | Report_alert _ -> "warning"
+    in
+    let highlight ppf loc =
+      match error_style () with
+      | Misc.Error_style.Contextual ->
+          if is_quotable_loc loc then
+            highlight_quote ppf
+              ~get_lines:lines_around_from_current_input
+              tag [loc]
+      | Misc.Error_style.Short ->
+          ()
+    in
+    Format.fprintf ppf "@[<v>%a:@ %a@]" print_loc loc highlight loc
+  in
+  let pp_txt ppf txt = Format.fprintf ppf "@[%t@]" txt in
+  let pp self ppf report =
+    setup_colors ();
+    (* Make sure we keep [num_loc_lines] updated.
+       The tabulation box is here to give submessage the option
+       to be aligned with the main message box
+    *)
+    print_updating_num_loc_lines ppf (fun ppf () ->
+      Format.fprintf ppf "@[<v>%a%a%a: %a%a%a%a@]@."
+      Format.pp_open_tbox ()
+      (self.pp_main_loc self report) report.main.loc
+      (self.pp_report_kind self report) report.kind
+      Format.pp_set_tab ()
+      (self.pp_main_txt self report) report.main.txt
+      (self.pp_submsgs self report) report.sub
+      Format.pp_close_tbox ()
+    ) ()
+  in
+  let pp_report_kind _self _ ppf = function
+    | Report_error -> Format.fprintf ppf "@{<error>Error@}"
+    | Report_warning w -> Format.fprintf ppf "@{<warning>Warning@} %s" w
+    | Report_warning_as_error w ->
+        Format.fprintf ppf "@{<error>Error@} (warning %s)" w
+    | Report_alert w -> Format.fprintf ppf "@{<warning>Alert@} %s" w
+    | Report_alert_as_error w ->
+        Format.fprintf ppf "@{<error>Error@} (alert %s)" w
+  in
+  let pp_main_loc self report ppf loc =
+    pp_loc self report ppf loc
+  in
+  let pp_main_txt _self _ ppf txt =
+    pp_txt ppf txt
+  in
+  let pp_submsgs self report ppf msgs =
+    List.iter (fun msg ->
+      Format.fprintf ppf "@,%a" (self.pp_submsg self report) msg
+    ) msgs
+  in
+  let pp_submsg self report ppf { loc; txt } =
+    Format.fprintf ppf "@[%a  %a@]"
+      (self.pp_submsg_loc self report) loc
+      (self.pp_submsg_txt self report) txt
+  in
+  let pp_submsg_loc self report ppf loc =
+    if not loc.loc_ghost then
+      pp_loc self report ppf loc
+  in
+  let pp_submsg_txt _self _ ppf loc =
+    pp_txt ppf loc
+  in
+  { pp; pp_report_kind; pp_main_loc; pp_main_txt;
+    pp_submsgs; pp_submsg; pp_submsg_loc; pp_submsg_txt }
+
+let terminfo_toplevel_printer (lb: lexbuf): report_printer =
+  let pp self ppf err =
+    setup_colors ();
+    (* Highlight all toplevel locations of the report, instead of displaying
+       the main location. Do it now instead of in [pp_main_loc], to avoid
+       messing with Format boxes. *)
+    let sub_locs = List.map (fun { loc; _ } -> loc) err.sub in
+    let all_locs = err.main.loc :: sub_locs in
+    let locs_highlighted = List.filter is_quotable_loc all_locs in
+    highlight_terminfo lb ppf locs_highlighted;
+    batch_mode_printer.pp self ppf err
+  in
+  let pp_main_loc _ _ _ _ = () in
+  let pp_submsg_loc _ _ ppf loc =
+    if not loc.loc_ghost then
+      Format.fprintf ppf "%a:@ " print_loc loc in
+  { batch_mode_printer with pp; pp_main_loc; pp_submsg_loc }
+
+let best_toplevel_printer () =
+  setup_terminal ();
+  match !status, !input_lexbuf with
+  | Terminfo.Good_term, Some lb ->
+      terminfo_toplevel_printer lb
+  | _, _ ->
+      batch_mode_printer
+
+(* Creates a printer for the current input *)
+let default_report_printer () : report_printer =
+  if !input_name = "//toplevel//" then
+    best_toplevel_printer ()
+  else
+    batch_mode_printer
+
+let report_printer = ref default_report_printer
+
+let print_report ppf report =
+  let printer = !report_printer () in
+  printer.pp printer ppf report
+
+(******************************************************************************)
+(* Reporting errors *)
+
+type error = report
+
+let report_error ppf err =
+  print_report ppf err
+
+let mkerror loc sub txt =
+  { kind = Report_error; main = { loc; txt }; sub }
+
+let errorf ?(loc = none) ?(sub = []) =
+  Format.kdprintf (mkerror loc sub)
+
+let error ?(loc = none) ?(sub = []) msg_str =
+  mkerror loc sub (fun ppf -> Format.pp_print_string ppf msg_str)
+
+let error_of_printer ?(loc = none) ?(sub = []) pp x =
+  mkerror loc sub (fun ppf -> pp ppf x)
+
+let error_of_printer_file print x =
+  error_of_printer ~loc:(in_file !input_name) print x
+
+(******************************************************************************)
+(* Reporting warnings: generating a report from a warning number using the
+   information in [Warnings] + convenience functions. *)
+
+let default_warning_alert_reporter report mk (loc: t) w : report option =
+  match report w with
+  | `Inactive -> None
+  | `Active { Warnings.id; message; is_error; sub_locs } ->
+      let msg_of_str str = fun ppf -> Format.pp_print_string ppf str in
+      let kind = mk is_error id in
+      let main = { loc; txt = msg_of_str message } in
+      let sub = List.map (fun (loc, sub_message) ->
+        { loc; txt = msg_of_str sub_message }
+      ) sub_locs in
+      Some { kind; main; sub }
+
+
+let default_warning_reporter =
+  default_warning_alert_reporter
+    Warnings.report
+    (fun is_error id ->
+       if is_error then Report_warning_as_error id
+       else Report_warning id
+    )
+
+let warning_reporter = ref default_warning_reporter
+let report_warning loc w = !warning_reporter loc w
+
+let formatter_for_warnings = ref Format.err_formatter
+
+let print_warning loc ppf w =
+  match report_warning loc w with
+  | None -> ()
+  | Some report -> print_report ppf report
+
+let prerr_warning loc w = print_warning loc !formatter_for_warnings w
+
+let default_alert_reporter =
+  default_warning_alert_reporter
+    Warnings.report_alert
+    (fun is_error id ->
+       if is_error then Report_alert_as_error id
+       else Report_alert id
+    )
+
+let alert_reporter = ref default_alert_reporter
+let report_alert loc w = !alert_reporter loc w
+
+let print_alert loc ppf w =
+  match report_alert loc w with
+  | None -> ()
+  | Some report -> print_report ppf report
+
+let prerr_alert loc w = print_alert loc !formatter_for_warnings w
+
+let alert ?(def = none) ?(use = none) ~kind loc message =
+  prerr_alert loc {Warnings.kind; message; def; use}
+
+let deprecated ?def ?use loc message =
+  alert ?def ?use ~kind:"deprecated" loc message
+
+(******************************************************************************)
+(* Reporting errors on exceptions *)
+
+let error_of_exn : (exn -> error option) list ref = ref []
+
+let register_error_of_exn f = error_of_exn := f :: !error_of_exn
+
+exception Already_displayed_error = Warnings.Errors
+
+let error_of_exn exn =
+  match exn with
+  | Already_displayed_error -> Some `Already_displayed
+  | _ ->
+     let rec loop = function
+       | [] -> None
+       | f :: rest ->
+          match f exn with
+          | Some error -> Some (`Ok error)
+          | None -> loop rest
+     in
+     loop !error_of_exn
+
+let () =
+  register_error_of_exn
+    (function
+      | Sys_error msg ->
+          Some (errorf ~loc:(in_file !input_name) "I/O error: %s" msg)
+      | _ -> None
+    )
+
+external reraise : exn -> 'a = "%reraise"
+
+let report_exception ppf exn =
+  let rec loop n exn =
+    match error_of_exn exn with
+    | None -> reraise exn
+    | Some `Already_displayed -> ()
+    | Some (`Ok err) -> report_error ppf err
+    | exception exn when n > 0 -> loop (n-1) exn
+  in
+  loop 5 exn
+
+exception Error of error
+
+let () =
+  register_error_of_exn
+    (function
+      | Error e -> Some e
+      | _ -> None
+    )
+
+let raise_errorf ?(loc = none) ?(sub = []) =
+  Format.kdprintf (fun txt -> raise (Error (mkerror loc sub txt)))
diff --git a/upstream/ocaml_413/parsing/location.mli b/upstream/ocaml_413/parsing/location.mli
new file mode 100644
index 0000000..5ba80b0
--- /dev/null
+++ b/upstream/ocaml_413/parsing/location.mli
@@ -0,0 +1,287 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Source code locations (ranges of positions), used in parsetree.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Format
+
+type t = Warnings.loc = {
+  loc_start: Lexing.position;
+  loc_end: Lexing.position;
+  loc_ghost: bool;
+}
+
+(** Note on the use of Lexing.position in this module.
+   If [pos_fname = ""], then use [!input_name] instead.
+   If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and
+     re-parse the file to get the line and character numbers.
+   Else all fields are correct.
+*)
+
+val none : t
+(** An arbitrary value of type [t]; describes an empty ghost range. *)
+
+val is_none : t -> bool
+(** True for [Location.none], false any other location *)
+
+val in_file : string -> t
+(** Return an empty ghost range located in a given file. *)
+
+val init : Lexing.lexbuf -> string -> unit
+(** Set the file name and line number of the [lexbuf] to be the start
+    of the named file. *)
+
+val curr : Lexing.lexbuf -> t
+(** Get the location of the current token from the [lexbuf]. *)
+
+val symbol_rloc: unit -> t
+val symbol_gloc: unit -> t
+
+(** [rhs_loc n] returns the location of the symbol at position [n], starting
+  at 1, in the current parser rule. *)
+val rhs_loc: int -> t
+
+val rhs_interval: int -> int -> t
+
+val get_pos_info: Lexing.position -> string * int * int
+(** file, line, char *)
+
+type 'a loc = {
+  txt : 'a;
+  loc : t;
+}
+
+val mknoloc : 'a -> 'a loc
+val mkloc : 'a -> t -> 'a loc
+
+
+(** {1 Input info} *)
+
+val input_name: string ref
+val input_lexbuf: Lexing.lexbuf option ref
+
+(* This is used for reporting errors coming from the toplevel.
+
+   When running a toplevel session (i.e. when [!input_name] is "//toplevel//"),
+   [!input_phrase_buffer] should be [Some buf] where [buf] contains the last
+   toplevel phrase. *)
+val input_phrase_buffer: Buffer.t option ref
+
+
+(** {1 Toplevel-specific functions} *)
+
+val echo_eof: unit -> unit
+val reset: unit -> unit
+
+
+(** {1 Printing locations} *)
+
+val rewrite_absolute_path: string -> string
+    (** rewrite absolute path to honor the BUILD_PATH_PREFIX_MAP
+        variable (https://reproducible-builds.org/specs/build-path-prefix-map/)
+        if it is set. *)
+
+val absolute_path: string -> string
+
+val show_filename: string -> string
+    (** In -absname mode, return the absolute path for this filename.
+        Otherwise, returns the filename unchanged. *)
+
+val print_filename: formatter -> string -> unit
+
+val print_loc: formatter -> t -> unit
+val print_locs: formatter -> t list -> unit
+
+
+(** {1 Toplevel-specific location highlighting} *)
+
+val highlight_terminfo:
+  Lexing.lexbuf -> formatter -> t list -> unit
+
+
+(** {1 Reporting errors and warnings} *)
+
+(** {2 The type of reports and report printers} *)
+
+type msg = (Format.formatter -> unit) loc
+
+val msg: ?loc:t -> ('a, Format.formatter, unit, msg) format4 -> 'a
+
+type report_kind =
+  | Report_error
+  | Report_warning of string
+  | Report_warning_as_error of string
+  | Report_alert of string
+  | Report_alert_as_error of string
+
+type report = {
+  kind : report_kind;
+  main : msg;
+  sub : msg list;
+}
+
+type report_printer = {
+  (* The entry point *)
+  pp : report_printer ->
+    Format.formatter -> report -> unit;
+
+  pp_report_kind : report_printer -> report ->
+    Format.formatter -> report_kind -> unit;
+  pp_main_loc : report_printer -> report ->
+    Format.formatter -> t -> unit;
+  pp_main_txt : report_printer -> report ->
+    Format.formatter -> (Format.formatter -> unit) -> unit;
+  pp_submsgs : report_printer -> report ->
+    Format.formatter -> msg list -> unit;
+  pp_submsg : report_printer -> report ->
+    Format.formatter -> msg -> unit;
+  pp_submsg_loc : report_printer -> report ->
+    Format.formatter -> t -> unit;
+  pp_submsg_txt : report_printer -> report ->
+    Format.formatter -> (Format.formatter -> unit) -> unit;
+}
+(** A printer for [report]s, defined using open-recursion.
+    The goal is to make it easy to define new printers by re-using code from
+    existing ones.
+*)
+
+(** {2 Report printers used in the compiler} *)
+
+val batch_mode_printer: report_printer
+
+val terminfo_toplevel_printer: Lexing.lexbuf -> report_printer
+
+val best_toplevel_printer: unit -> report_printer
+(** Detects the terminal capabilities and selects an adequate printer *)
+
+(** {2 Printing a [report]} *)
+
+val print_report: formatter -> report -> unit
+(** Display an error or warning report. *)
+
+val report_printer: (unit -> report_printer) ref
+(** Hook for redefining the printer of reports.
+
+    The hook is a [unit -> report_printer] and not simply a [report_printer]:
+    this is useful so that it can detect the type of the output (a file, a
+    terminal, ...) and select a printer accordingly. *)
+
+val default_report_printer: unit -> report_printer
+(** Original report printer for use in hooks. *)
+
+
+(** {1 Reporting warnings} *)
+
+(** {2 Converting a [Warnings.t] into a [report]} *)
+
+val report_warning: t -> Warnings.t -> report option
+(** [report_warning loc w] produces a report for the given warning [w], or
+   [None] if the warning is not to be printed. *)
+
+val warning_reporter: (t -> Warnings.t -> report option) ref
+(** Hook for intercepting warnings. *)
+
+val default_warning_reporter: t -> Warnings.t -> report option
+(** Original warning reporter for use in hooks. *)
+
+(** {2 Printing warnings} *)
+
+val formatter_for_warnings : formatter ref
+
+val print_warning: t -> formatter -> Warnings.t -> unit
+(** Prints a warning. This is simply the composition of [report_warning] and
+   [print_report]. *)
+
+val prerr_warning: t -> Warnings.t -> unit
+(** Same as [print_warning], but uses [!formatter_for_warnings] as output
+   formatter. *)
+
+(** {1 Reporting alerts} *)
+
+(** {2 Converting an [Alert.t] into a [report]} *)
+
+val report_alert: t -> Warnings.alert -> report option
+(** [report_alert loc w] produces a report for the given alert [w], or
+   [None] if the alert is not to be printed. *)
+
+val alert_reporter: (t -> Warnings.alert -> report option) ref
+(** Hook for intercepting alerts. *)
+
+val default_alert_reporter: t -> Warnings.alert -> report option
+(** Original alert reporter for use in hooks. *)
+
+(** {2 Printing alerts} *)
+
+val print_alert: t -> formatter -> Warnings.alert -> unit
+(** Prints an alert. This is simply the composition of [report_alert] and
+   [print_report]. *)
+
+val prerr_alert: t -> Warnings.alert -> unit
+(** Same as [print_alert], but uses [!formatter_for_warnings] as output
+   formatter. *)
+
+val deprecated: ?def:t -> ?use:t -> t -> string -> unit
+(** Prints a deprecation alert. *)
+
+val alert: ?def:t -> ?use:t -> kind:string -> t -> string -> unit
+(** Prints an arbitrary alert. *)
+
+
+(** {1 Reporting errors} *)
+
+type error = report
+(** An [error] is a [report] which [report_kind] must be [Report_error]. *)
+
+val error: ?loc:t -> ?sub:msg list -> string -> error
+
+val errorf: ?loc:t -> ?sub:msg list ->
+  ('a, Format.formatter, unit, error) format4 -> 'a
+
+val error_of_printer: ?loc:t -> ?sub:msg list ->
+  (formatter -> 'a -> unit) -> 'a -> error
+
+val error_of_printer_file: (formatter -> 'a -> unit) -> 'a -> error
+
+
+(** {1 Automatically reporting errors for raised exceptions} *)
+
+val register_error_of_exn: (exn -> error option) -> unit
+(** Each compiler module which defines a custom type of exception
+    which can surface as a user-visible error should register
+    a "printer" for this exception using [register_error_of_exn].
+    The result of the printer is an [error] value containing
+    a location, a message, and optionally sub-messages (each of them
+    being located as well). *)
+
+val error_of_exn: exn -> [ `Ok of error | `Already_displayed ] option
+
+exception Error of error
+(** Raising [Error e] signals an error [e]; the exception will be caught and the
+   error will be printed. *)
+
+exception Already_displayed_error
+(** Raising [Already_displayed_error] signals an error which has already been
+   printed. The exception will be caught, but nothing will be printed *)
+
+val raise_errorf: ?loc:t -> ?sub:msg list ->
+  ('a, Format.formatter, unit, 'b) format4 -> 'a
+
+val report_exception: formatter -> exn -> unit
+(** Reraise the exception if it is unknown. *)
diff --git a/upstream/ocaml_413/parsing/longident.ml b/upstream/ocaml_413/parsing/longident.ml
new file mode 100644
index 0000000..eaafb02
--- /dev/null
+++ b/upstream/ocaml_413/parsing/longident.ml
@@ -0,0 +1,50 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t =
+    Lident of string
+  | Ldot of t * string
+  | Lapply of t * t
+
+let rec flat accu = function
+    Lident s -> s :: accu
+  | Ldot(lid, s) -> flat (s :: accu) lid
+  | Lapply(_, _) -> Misc.fatal_error "Longident.flat"
+
+let flatten lid = flat [] lid
+
+let last = function
+    Lident s -> s
+  | Ldot(_, s) -> s
+  | Lapply(_, _) -> Misc.fatal_error "Longident.last"
+
+
+let rec split_at_dots s pos =
+  try
+    let dot = String.index_from s pos '.' in
+    String.sub s pos (dot - pos) :: split_at_dots s (dot + 1)
+  with Not_found ->
+    [String.sub s pos (String.length s - pos)]
+
+let unflatten l =
+  match l with
+  | [] -> None
+  | hd :: tl -> Some (List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl)
+
+let parse s =
+  match unflatten (split_at_dots s 0) with
+  | None -> Lident ""  (* should not happen, but don't put assert false
+                          so as not to crash the toplevel (see Genprintval) *)
+  | Some v -> v
diff --git a/upstream/ocaml_413/parsing/longident.mli b/upstream/ocaml_413/parsing/longident.mli
new file mode 100644
index 0000000..8704a77
--- /dev/null
+++ b/upstream/ocaml_413/parsing/longident.mli
@@ -0,0 +1,58 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Long identifiers, used in parsetree.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+  To print a longident, see {!Pprintast.longident}, using
+    {!Format.asprintf} to convert to a string.
+
+*)
+
+type t =
+    Lident of string
+  | Ldot of t * string
+  | Lapply of t * t
+
+val flatten: t -> string list
+val unflatten: string list -> t option
+(** For a non-empty list [l], [unflatten l] is [Some lid] where [lid] is
+    the long identifier created by concatenating the elements of [l]
+    with [Ldot].
+    [unflatten []] is [None].
+*)
+
+val last: t -> string
+val parse: string -> t
+[@@deprecated "this function may misparse its input,\n\
+use \"Parse.longident\" or \"Longident.unflatten\""]
+(**
+
+   This function is broken on identifiers that are not just "Word.Word.word";
+   for example, it returns incorrect results on infix operators
+   and extended module paths.
+
+   If you want to generate long identifiers that are a list of
+   dot-separated identifiers, the function {!unflatten} is safer and faster.
+   {!unflatten} is available since OCaml 4.06.0.
+
+   If you want to parse any identifier correctly, use the long-identifiers
+   functions from the {!Parse} module, in particular {!Parse.longident}.
+   They are available since OCaml 4.11, and also provide proper
+   input-location support.
+
+*)
diff --git a/upstream/ocaml_413/parsing/parse.ml b/upstream/ocaml_413/parsing/parse.ml
new file mode 100644
index 0000000..05bc9fc
--- /dev/null
+++ b/upstream/ocaml_413/parsing/parse.ml
@@ -0,0 +1,147 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Entry points in the parser *)
+
+(* Skip tokens to the end of the phrase *)
+
+let last_token = ref Parser.EOF
+
+let token lexbuf =
+  let token = Lexer.token lexbuf in
+  last_token := token;
+  token
+
+let rec skip_phrase lexbuf =
+  match token lexbuf with
+  | Parser.SEMISEMI | Parser.EOF -> ()
+  | _ -> skip_phrase lexbuf
+  | exception (Lexer.Error (Lexer.Unterminated_comment _, _)
+              | Lexer.Error (Lexer.Unterminated_string, _)
+              | Lexer.Error (Lexer.Reserved_sequence _, _)
+              | Lexer.Error (Lexer.Unterminated_string_in_comment _, _)
+              | Lexer.Error (Lexer.Illegal_character _, _)) ->
+      skip_phrase lexbuf
+
+let maybe_skip_phrase lexbuf =
+  match !last_token with
+  | Parser.SEMISEMI | Parser.EOF -> ()
+  | _ -> skip_phrase lexbuf
+
+type 'a parser =
+  (Lexing.lexbuf -> Parser.token) -> Lexing.lexbuf -> 'a
+
+let wrap (parser : 'a parser) lexbuf : 'a =
+  try
+    Docstrings.init ();
+    Lexer.init ();
+    let ast = parser token lexbuf in
+    Parsing.clear_parser();
+    Docstrings.warn_bad_docstrings ();
+    last_token := Parser.EOF;
+    ast
+  with
+  | Lexer.Error(Lexer.Illegal_character _, _) as err
+    when !Location.input_name = "//toplevel//"->
+      skip_phrase lexbuf;
+      raise err
+  | Syntaxerr.Error _ as err
+    when !Location.input_name = "//toplevel//" ->
+      maybe_skip_phrase lexbuf;
+      raise err
+  | Parsing.Parse_error | Syntaxerr.Escape_error ->
+      let loc = Location.curr lexbuf in
+      if !Location.input_name = "//toplevel//"
+      then maybe_skip_phrase lexbuf;
+      raise(Syntaxerr.Error(Syntaxerr.Other loc))
+
+(* We pass [--strategy simplified] to Menhir, which means that we wish to use
+   its "simplified" strategy for handling errors. When a syntax error occurs,
+   the current token is replaced with an [error] token. The parser then
+   continues shifting and reducing, as far as possible. After (possibly)
+   shifting the [error] token, though, the parser remains in error-handling
+   mode, and does not request the next token, so the current token remains
+   [error].
+
+   In OCaml's grammar, the [error] token always appears at the end of a
+   production, and this production always raises an exception. In such
+   a situation, the strategy described above means that:
+
+   - either the parser will not be able to shift [error],
+     and will raise [Parser.Error];
+
+   - or it will be able to shift [error] and will then reduce
+     a production whose semantic action raises an exception.
+
+   In either case, the parser will not attempt to read one token past
+   the syntax error. *)
+
+let implementation = wrap Parser.implementation
+and interface = wrap Parser.interface
+and toplevel_phrase = wrap Parser.toplevel_phrase
+and use_file = wrap Parser.use_file
+and core_type = wrap Parser.parse_core_type
+and expression = wrap Parser.parse_expression
+and pattern = wrap Parser.parse_pattern
+
+let longident = wrap Parser.parse_any_longident
+let val_ident = wrap Parser.parse_val_longident
+let constr_ident= wrap Parser.parse_constr_longident
+let extended_module_path = wrap Parser.parse_mod_ext_longident
+let simple_module_path = wrap Parser.parse_mod_longident
+let type_ident = wrap Parser.parse_mty_longident
+
+(* Error reporting for Syntaxerr *)
+(* The code has been moved here so that one can reuse Pprintast.tyvar *)
+
+let prepare_error err =
+  let open Syntaxerr in
+  match err with
+  | Unclosed(opening_loc, opening, closing_loc, closing) ->
+      Location.errorf
+        ~loc:closing_loc
+        ~sub:[
+          Location.msg ~loc:opening_loc
+            "This '%s' might be unmatched" opening
+        ]
+        "Syntax error: '%s' expected" closing
+
+  | Expecting (loc, nonterm) ->
+      Location.errorf ~loc "Syntax error: %s expected." nonterm
+  | Not_expecting (loc, nonterm) ->
+      Location.errorf ~loc "Syntax error: %s not expected." nonterm
+  | Applicative_path loc ->
+      Location.errorf ~loc
+        "Syntax error: applicative paths of the form F(X).t \
+         are not supported when the option -no-app-func is set."
+  | Variable_in_scope (loc, var) ->
+      Location.errorf ~loc
+        "In this scoped type, variable %a \
+         is reserved for the local type %s."
+        Pprintast.tyvar var var
+  | Other loc ->
+      Location.errorf ~loc "Syntax error"
+  | Ill_formed_ast (loc, s) ->
+      Location.errorf ~loc
+        "broken invariant in parsetree: %s" s
+  | Invalid_package_type (loc, s) ->
+      Location.errorf ~loc "invalid package type: %s" s
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Syntaxerr.Error err -> Some (prepare_error err)
+      | _ -> None
+    )
diff --git a/upstream/ocaml_413/parsing/parse.mli b/upstream/ocaml_413/parsing/parse.mli
new file mode 100644
index 0000000..8669a4b
--- /dev/null
+++ b/upstream/ocaml_413/parsing/parse.mli
@@ -0,0 +1,108 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Entry points in the parser
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+val implementation : Lexing.lexbuf -> Parsetree.structure
+val interface : Lexing.lexbuf -> Parsetree.signature
+val toplevel_phrase : Lexing.lexbuf -> Parsetree.toplevel_phrase
+val use_file : Lexing.lexbuf -> Parsetree.toplevel_phrase list
+val core_type : Lexing.lexbuf -> Parsetree.core_type
+val expression : Lexing.lexbuf -> Parsetree.expression
+val pattern : Lexing.lexbuf -> Parsetree.pattern
+
+(** The functions below can be used to parse Longident safely. *)
+
+val longident: Lexing.lexbuf -> Longident.t
+(**
+   The function [longident] is guaranteed to parse all subclasses
+   of {!Longident.t} used in OCaml: values, constructors, simple or extended
+   module paths, and types or module types.
+
+   However, this function accepts inputs which are not accepted by the
+   compiler, because they combine functor applications and infix operators.
+   In valid OCaml syntax, only value-level identifiers may end with infix
+   operators [Foo.( + )].
+   Moreover, in value-level identifiers the module path [Foo] must be simple
+   ([M.N] rather than [F(X)]): functor applications may only appear in
+   type-level identifiers.
+   As a consequence, a path such as [F(X).( + )] is not a valid OCaml
+   identifier; but it is accepted by this function.
+*)
+
+(** The next functions are specialized to a subclass of {!Longident.t} *)
+
+val val_ident: Lexing.lexbuf -> Longident.t
+(**
+   This function parses a syntactically valid path for a value. For instance,
+   [x], [M.x], and [(+.)] are valid. Contrarily, [M.A], [F(X).x], and [true]
+   are rejected.
+
+   Longident for OCaml's value cannot contain functor application.
+   The last component of the {!Longident.t} is not capitalized,
+   but can be an operator [A.Path.To.(.%.%.(;..)<-)]
+*)
+
+val constr_ident: Lexing.lexbuf -> Longident.t
+(**
+   This function parses a syntactically valid path for a variant constructor.
+   For instance, [A], [M.A] and [M.(::)] are valid, but both [M.a]
+   and [F(X).A] are rejected.
+
+   Longident for OCaml's variant constructors cannot contain functor
+   application.
+   The last component of the {!Longident.t} is capitalized,
+   or it may be one the special constructors: [true],[false],[()],[[]],[(::)].
+   Among those special constructors, only [(::)] can be prefixed by a module
+   path ([A.B.C.(::)]).
+*)
+
+
+val simple_module_path: Lexing.lexbuf -> Longident.t
+(**
+   This function parses a syntactically valid path for a module.
+   For instance, [A], and [M.A] are valid, but both [M.a]
+   and [F(X).A] are rejected.
+
+   Longident for OCaml's module cannot contain functor application.
+   The last component of the {!Longident.t} is capitalized.
+*)
+
+
+val extended_module_path: Lexing.lexbuf -> Longident.t
+(**
+   This function parse syntactically valid path for an extended module.
+   For instance, [A.B] and [F(A).B] are valid. Contrarily,
+   [(.%())] or [[]] are both rejected.
+
+   The last component of the {!Longident.t} is capitalized.
+
+*)
+
+val type_ident: Lexing.lexbuf -> Longident.t
+(**
+   This function parse syntactically valid path for a type or a module type.
+   For instance, [A], [t], [M.t] and [F(X).t] are valid. Contrarily,
+   [(.%())] or [[]] are both rejected.
+
+   In path for type and module types, only operators and special constructors
+   are rejected.
+
+*)
diff --git a/upstream/ocaml_413/parsing/parser.mly b/upstream/ocaml_413/parsing/parser.mly
new file mode 100644
index 0000000..bb1319d
--- /dev/null
+++ b/upstream/ocaml_413/parsing/parser.mly
@@ -0,0 +1,3867 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 1996 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* The parser definition */
+
+/* The commands [make list-parse-errors] and [make generate-parse-errors]
+   run Menhir on a modified copy of the parser where every block of
+   text comprised between the markers [BEGIN AVOID] and -----------
+   [END AVOID] has been removed. This file should be formatted in
+   such a way that this results in a clean removal of certain
+   symbols, productions, or declarations. */
+
+%{
+
+open Asttypes
+open Longident
+open Parsetree
+open Ast_helper
+open Docstrings
+open Docstrings.WithMenhir
+
+let mkloc = Location.mkloc
+let mknoloc = Location.mknoloc
+
+let make_loc (startpos, endpos) = {
+  Location.loc_start = startpos;
+  Location.loc_end = endpos;
+  Location.loc_ghost = false;
+}
+
+let ghost_loc (startpos, endpos) = {
+  Location.loc_start = startpos;
+  Location.loc_end = endpos;
+  Location.loc_ghost = true;
+}
+
+let mktyp ~loc ?attrs d = Typ.mk ~loc:(make_loc loc) ?attrs d
+let mkpat ~loc d = Pat.mk ~loc:(make_loc loc) d
+let mkexp ~loc d = Exp.mk ~loc:(make_loc loc) d
+let mkmty ~loc ?attrs d = Mty.mk ~loc:(make_loc loc) ?attrs d
+let mksig ~loc d = Sig.mk ~loc:(make_loc loc) d
+let mkmod ~loc ?attrs d = Mod.mk ~loc:(make_loc loc) ?attrs d
+let mkstr ~loc d = Str.mk ~loc:(make_loc loc) d
+let mkclass ~loc ?attrs d = Cl.mk ~loc:(make_loc loc) ?attrs d
+let mkcty ~loc ?attrs d = Cty.mk ~loc:(make_loc loc) ?attrs d
+
+let pstr_typext (te, ext) =
+  (Pstr_typext te, ext)
+let pstr_primitive (vd, ext) =
+  (Pstr_primitive vd, ext)
+let pstr_type ((nr, ext), tys) =
+  (Pstr_type (nr, tys), ext)
+let pstr_exception (te, ext) =
+  (Pstr_exception te, ext)
+let pstr_include (body, ext) =
+  (Pstr_include body, ext)
+let pstr_recmodule (ext, bindings) =
+  (Pstr_recmodule bindings, ext)
+
+let psig_typext (te, ext) =
+  (Psig_typext te, ext)
+let psig_value (vd, ext) =
+  (Psig_value vd, ext)
+let psig_type ((nr, ext), tys) =
+  (Psig_type (nr, tys), ext)
+let psig_typesubst ((nr, ext), tys) =
+  assert (nr = Recursive); (* see [no_nonrec_flag] *)
+  (Psig_typesubst tys, ext)
+let psig_exception (te, ext) =
+  (Psig_exception te, ext)
+let psig_include (body, ext) =
+  (Psig_include body, ext)
+
+let mkctf ~loc ?attrs ?docs d =
+  Ctf.mk ~loc:(make_loc loc) ?attrs ?docs d
+let mkcf ~loc ?attrs ?docs d =
+  Cf.mk ~loc:(make_loc loc) ?attrs ?docs d
+
+let mkrhs rhs loc = mkloc rhs (make_loc loc)
+let ghrhs rhs loc = mkloc rhs (ghost_loc loc)
+
+let push_loc x acc =
+  if x.Location.loc_ghost
+  then acc
+  else x :: acc
+
+let reloc_pat ~loc x =
+  { x with ppat_loc = make_loc loc;
+           ppat_loc_stack = push_loc x.ppat_loc x.ppat_loc_stack };;
+let reloc_exp ~loc x =
+  { x with pexp_loc = make_loc loc;
+           pexp_loc_stack = push_loc x.pexp_loc x.pexp_loc_stack };;
+let reloc_typ ~loc x =
+  { x with ptyp_loc = make_loc loc;
+           ptyp_loc_stack = push_loc x.ptyp_loc x.ptyp_loc_stack };;
+
+let mkexpvar ~loc (name : string) =
+  mkexp ~loc (Pexp_ident(mkrhs (Lident name) loc))
+
+let mkoperator =
+  mkexpvar
+
+let mkpatvar ~loc name =
+  mkpat ~loc (Ppat_var (mkrhs name loc))
+
+(*
+  Ghost expressions and patterns:
+  expressions and patterns that do not appear explicitly in the
+  source file they have the loc_ghost flag set to true.
+  Then the profiler will not try to instrument them and the
+  -annot option will not try to display their type.
+
+  Every grammar rule that generates an element with a location must
+  make at most one non-ghost element, the topmost one.
+
+  How to tell whether your location must be ghost:
+  A location corresponds to a range of characters in the source file.
+  If the location contains a piece of code that is syntactically
+  valid (according to the documentation), and corresponds to the
+  AST node, then the location must be real; in all other cases,
+  it must be ghost.
+*)
+let ghexp ~loc d = Exp.mk ~loc:(ghost_loc loc) d
+let ghpat ~loc d = Pat.mk ~loc:(ghost_loc loc) d
+let ghtyp ~loc d = Typ.mk ~loc:(ghost_loc loc) d
+let ghloc ~loc d = { txt = d; loc = ghost_loc loc }
+let ghstr ~loc d = Str.mk ~loc:(ghost_loc loc) d
+let ghsig ~loc d = Sig.mk ~loc:(ghost_loc loc) d
+
+let mkinfix arg1 op arg2 =
+  Pexp_apply(op, [Nolabel, arg1; Nolabel, arg2])
+
+let neg_string f =
+  if String.length f > 0 && f.[0] = '-'
+  then String.sub f 1 (String.length f - 1)
+  else "-" ^ f
+
+let mkuminus ~oploc name arg =
+  match name, arg.pexp_desc with
+  | "-", Pexp_constant(Pconst_integer (n,m)) ->
+      Pexp_constant(Pconst_integer(neg_string n,m))
+  | ("-" | "-."), Pexp_constant(Pconst_float (f, m)) ->
+      Pexp_constant(Pconst_float(neg_string f, m))
+  | _ ->
+      Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg])
+
+let mkuplus ~oploc name arg =
+  let desc = arg.pexp_desc in
+  match name, desc with
+  | "+", Pexp_constant(Pconst_integer _)
+  | ("+" | "+."), Pexp_constant(Pconst_float _) -> desc
+  | _ ->
+      Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg])
+
+(* TODO define an abstraction boundary between locations-as-pairs
+   and locations-as-Location.t; it should be clear when we move from
+   one world to the other *)
+
+let mkexp_cons_desc consloc args =
+  Pexp_construct(mkrhs (Lident "::") consloc, Some args)
+let mkexp_cons ~loc consloc args =
+  mkexp ~loc (mkexp_cons_desc consloc args)
+
+let mkpat_cons_desc consloc args =
+  Ppat_construct(mkrhs (Lident "::") consloc, Some ([], args))
+let mkpat_cons ~loc consloc args =
+  mkpat ~loc (mkpat_cons_desc consloc args)
+
+let ghexp_cons_desc consloc args =
+  Pexp_construct(ghrhs (Lident "::") consloc, Some args)
+let ghpat_cons_desc consloc args =
+  Ppat_construct(ghrhs (Lident "::") consloc, Some ([], args))
+
+let rec mktailexp nilloc = let open Location in function
+    [] ->
+      let nil = ghloc ~loc:nilloc (Lident "[]") in
+      Pexp_construct (nil, None), nilloc
+  | e1 :: el ->
+      let exp_el, el_loc = mktailexp nilloc el in
+      let loc = (e1.pexp_loc.loc_start, snd el_loc) in
+      let arg = ghexp ~loc (Pexp_tuple [e1; ghexp ~loc:el_loc exp_el]) in
+      ghexp_cons_desc loc arg, loc
+
+let rec mktailpat nilloc = let open Location in function
+    [] ->
+      let nil = ghloc ~loc:nilloc (Lident "[]") in
+      Ppat_construct (nil, None), nilloc
+  | p1 :: pl ->
+      let pat_pl, el_loc = mktailpat nilloc pl in
+      let loc = (p1.ppat_loc.loc_start, snd el_loc) in
+      let arg = ghpat ~loc (Ppat_tuple [p1; ghpat ~loc:el_loc pat_pl]) in
+      ghpat_cons_desc loc arg, loc
+
+let mkstrexp e attrs =
+  { pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc }
+
+let mkexp_constraint ~loc e (t1, t2) =
+  match t1, t2 with
+  | Some t, None -> ghexp ~loc (Pexp_constraint(e, t))
+  | _, Some t -> ghexp ~loc (Pexp_coerce(e, t1, t))
+  | None, None -> assert false
+
+let mkexp_opt_constraint ~loc e = function
+  | None -> e
+  | Some constraint_ -> mkexp_constraint ~loc e constraint_
+
+let mkpat_opt_constraint ~loc p = function
+  | None -> p
+  | Some typ -> ghpat ~loc (Ppat_constraint(p, typ))
+
+let syntax_error () =
+  raise Syntaxerr.Escape_error
+
+let unclosed opening_name opening_loc closing_name closing_loc =
+  raise(Syntaxerr.Error(Syntaxerr.Unclosed(make_loc opening_loc, opening_name,
+                                           make_loc closing_loc, closing_name)))
+
+let expecting loc nonterm =
+    raise Syntaxerr.(Error(Expecting(make_loc loc, nonterm)))
+
+(* Using the function [not_expecting] in a semantic action means that this
+   syntactic form is recognized by the parser but is in fact incorrect. This
+   idiom is used in a few places to produce ad hoc syntax error messages. *)
+
+(* This idiom should be used as little as possible, because it confuses the
+   analyses performed by Menhir. Because Menhir views the semantic action as
+   opaque, it believes that this syntactic form is correct. This can lead
+   [make generate-parse-errors] to produce sentences that cause an early
+   (unexpected) syntax error and do not achieve the desired effect. This could
+   also lead a completion system to propose completions which in fact are
+   incorrect. In order to avoid these problems, the productions that use
+   [not_expecting] should be marked with AVOID. *)
+
+let not_expecting loc nonterm =
+    raise Syntaxerr.(Error(Not_expecting(make_loc loc, nonterm)))
+
+(* Helper functions for desugaring array indexing operators *)
+type paren_kind = Paren | Brace | Bracket
+
+(* We classify the dimension of indices: Bigarray distinguishes
+   indices of dimension 1,2,3, or more. Similarly, user-defined
+   indexing operator behave differently for indices of dimension 1
+   or more.
+*)
+type index_dim =
+  | One
+  | Two
+  | Three
+  | Many
+type ('dot,'index) array_family = {
+
+  name:
+    Lexing.position * Lexing.position -> 'dot -> assign:bool -> paren_kind
+  -> index_dim -> Longident.t Location.loc
+  (*
+    This functions computes the name of the explicit indexing operator
+    associated with a sugared array indexing expression.
+
+    For instance, for builtin arrays, if Clflags.unsafe is set,
+    * [ a.[index] ]     =>  [String.unsafe_get]
+    * [ a.{x,y} <- 1 ]  =>  [ Bigarray.Array2.unsafe_set]
+
+    User-defined indexing operator follows a more local convention:
+    * [ a .%(index)]     => [ (.%()) ]
+    * [ a.![1;2] <- 0 ]  => [(.![;..]<-)]
+    * [ a.My.Map.?(0) => [My.Map.(.?())]
+  *);
+
+  index:
+    Lexing.position * Lexing.position -> paren_kind -> 'index
+    -> index_dim * (arg_label * expression) list
+   (*
+     [index (start,stop) paren index] computes the dimension of the
+     index argument and how it should be desugared when transformed
+     to a list of arguments for the indexing operator.
+     In particular, in both the Bigarray case and the user-defined case,
+     beyond a certain dimension, multiple indices are packed into a single
+     array argument:
+     * [ a.(x) ]       => [ [One, [Nolabel, <<x>>] ]
+     * [ a.{1,2} ]     => [ [Two, [Nolabel, <<1>>; Nolabel, <<2>>] ]
+     * [ a.{1,2,3,4} ] => [ [Many, [Nolabel, <<[|1;2;3;4|]>>] ] ]
+   *);
+
+}
+
+let bigarray_untuplify = function
+    { pexp_desc = Pexp_tuple explist; pexp_loc = _ } -> explist
+  | exp -> [exp]
+
+let builtin_arraylike_name loc _ ~assign paren_kind n =
+  let opname = if assign then "set" else "get" in
+  let opname = if !Clflags.unsafe then "unsafe_" ^ opname else opname in
+  let prefix = match paren_kind with
+    | Paren -> Lident "Array"
+    | Bracket -> Lident "String"
+    | Brace ->
+       let submodule_name = match n with
+         | One -> "Array1"
+         | Two -> "Array2"
+         | Three -> "Array3"
+         | Many -> "Genarray" in
+       Ldot(Lident "Bigarray", submodule_name) in
+   ghloc ~loc (Ldot(prefix,opname))
+
+let builtin_arraylike_index loc paren_kind index = match paren_kind with
+    | Paren | Bracket -> One, [Nolabel, index]
+    | Brace ->
+       (* Multi-indices for bigarray are comma-separated ([a.{1,2,3,4}]) *)
+       match bigarray_untuplify index with
+     | [x] -> One, [Nolabel, x]
+     | [x;y] -> Two, [Nolabel, x; Nolabel, y]
+     | [x;y;z] -> Three, [Nolabel, x; Nolabel, y; Nolabel, z]
+     | coords -> Many, [Nolabel, ghexp ~loc (Pexp_array coords)]
+
+let builtin_indexing_operators : (unit, expression) array_family  =
+  { index = builtin_arraylike_index; name = builtin_arraylike_name }
+
+let paren_to_strings = function
+  | Paren -> "(", ")"
+  | Bracket -> "[", "]"
+  | Brace -> "{", "}"
+
+let user_indexing_operator_name loc (prefix,ext) ~assign paren_kind n =
+  let name =
+    let assign = if assign then "<-" else "" in
+    let mid = match n with
+        | Many | Three | Two  -> ";.."
+        | One -> "" in
+    let left, right = paren_to_strings paren_kind in
+    String.concat "" ["."; ext; left; mid; right; assign] in
+  let lid = match prefix with
+    | None -> Lident name
+    | Some p -> Ldot(p,name) in
+  ghloc ~loc lid
+
+let user_index loc _ index =
+  (* Multi-indices for user-defined operators are semicolon-separated
+     ([a.%[1;2;3;4]]) *)
+  match index with
+    | [a] -> One, [Nolabel, a]
+    | l -> Many, [Nolabel, mkexp ~loc (Pexp_array l)]
+
+let user_indexing_operators:
+      (Longident.t option * string, expression list) array_family
+  = { index = user_index; name = user_indexing_operator_name }
+
+let mk_indexop_expr array_indexing_operator ~loc
+      (array,dot,paren,index,set_expr) =
+  let assign = match set_expr with None -> false | Some _ -> true in
+  let n, index = array_indexing_operator.index loc paren index in
+  let fn = array_indexing_operator.name loc dot ~assign paren n in
+  let set_arg = match set_expr with
+    | None -> []
+    | Some expr -> [Nolabel, expr] in
+  let args = (Nolabel,array) :: index @ set_arg in
+  mkexp ~loc (Pexp_apply(ghexp ~loc (Pexp_ident fn), args))
+
+let indexop_unclosed_error loc_s s loc_e =
+  let left, right = paren_to_strings s in
+  unclosed left loc_s right loc_e
+
+let lapply ~loc p1 p2 =
+  if !Clflags.applicative_functors
+  then Lapply(p1, p2)
+  else raise (Syntaxerr.Error(
+                  Syntaxerr.Applicative_path (make_loc loc)))
+
+(* [loc_map] could be [Location.map]. *)
+let loc_map (f : 'a -> 'b) (x : 'a Location.loc) : 'b Location.loc =
+  { x with txt = f x.txt }
+
+let make_ghost x = { x with loc = { x.loc with loc_ghost = true }}
+
+let loc_last (id : Longident.t Location.loc) : string Location.loc =
+  loc_map Longident.last id
+
+let loc_lident (id : string Location.loc) : Longident.t Location.loc =
+  loc_map (fun x -> Lident x) id
+
+let exp_of_longident ~loc lid =
+  let lid = make_ghost (loc_map (fun id -> Lident (Longident.last id)) lid) in
+  ghexp ~loc (Pexp_ident lid)
+
+let exp_of_label ~loc lbl =
+  mkexp ~loc (Pexp_ident (loc_lident lbl))
+
+let pat_of_label lbl =
+  Pat.mk ~loc:lbl.loc  (Ppat_var (loc_last lbl))
+
+let mk_newtypes ~loc newtypes exp =
+  let mkexp = mkexp ~loc in
+  List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp)))
+    newtypes exp
+
+let wrap_type_annotation ~loc newtypes core_type body =
+  let mkexp, ghtyp = mkexp ~loc, ghtyp ~loc in
+  let mk_newtypes = mk_newtypes ~loc in
+  let exp = mkexp(Pexp_constraint(body,core_type)) in
+  let exp = mk_newtypes newtypes exp in
+  (exp, ghtyp(Ptyp_poly(newtypes, Typ.varify_constructors newtypes core_type)))
+
+let wrap_exp_attrs ~loc body (ext, attrs) =
+  let ghexp = ghexp ~loc in
+  (* todo: keep exact location for the entire attribute *)
+  let body = {body with pexp_attributes = attrs @ body.pexp_attributes} in
+  match ext with
+  | None -> body
+  | Some id -> ghexp(Pexp_extension (id, PStr [mkstrexp body []]))
+
+let mkexp_attrs ~loc d attrs =
+  wrap_exp_attrs ~loc (mkexp ~loc d) attrs
+
+let wrap_typ_attrs ~loc typ (ext, attrs) =
+  (* todo: keep exact location for the entire attribute *)
+  let typ = {typ with ptyp_attributes = attrs @ typ.ptyp_attributes} in
+  match ext with
+  | None -> typ
+  | Some id -> ghtyp ~loc (Ptyp_extension (id, PTyp typ))
+
+let wrap_pat_attrs ~loc pat (ext, attrs) =
+  (* todo: keep exact location for the entire attribute *)
+  let pat = {pat with ppat_attributes = attrs @ pat.ppat_attributes} in
+  match ext with
+  | None -> pat
+  | Some id -> ghpat ~loc (Ppat_extension (id, PPat (pat, None)))
+
+let mkpat_attrs ~loc d attrs =
+  wrap_pat_attrs ~loc (mkpat ~loc d) attrs
+
+let wrap_class_attrs ~loc:_ body attrs =
+  {body with pcl_attributes = attrs @ body.pcl_attributes}
+let wrap_mod_attrs ~loc:_ attrs body =
+  {body with pmod_attributes = attrs @ body.pmod_attributes}
+let wrap_mty_attrs ~loc:_ attrs body =
+  {body with pmty_attributes = attrs @ body.pmty_attributes}
+
+let wrap_str_ext ~loc body ext =
+  match ext with
+  | None -> body
+  | Some id -> ghstr ~loc (Pstr_extension ((id, PStr [body]), []))
+
+let wrap_mkstr_ext ~loc (item, ext) =
+  wrap_str_ext ~loc (mkstr ~loc item) ext
+
+let wrap_sig_ext ~loc body ext =
+  match ext with
+  | None -> body
+  | Some id -> ghsig ~loc (Psig_extension ((id, PSig [body]), []))
+
+let wrap_mksig_ext ~loc (item, ext) =
+  wrap_sig_ext ~loc (mksig ~loc item) ext
+
+let mk_quotedext ~loc (id, idloc, str, strloc, delim) =
+  let exp_id = mkloc id idloc in
+  let e = ghexp ~loc (Pexp_constant (Pconst_string (str, strloc, delim))) in
+  (exp_id, PStr [mkstrexp e []])
+
+let text_str pos = Str.text (rhs_text pos)
+let text_sig pos = Sig.text (rhs_text pos)
+let text_cstr pos = Cf.text (rhs_text pos)
+let text_csig pos = Ctf.text (rhs_text pos)
+let text_def pos =
+  List.map (fun def -> Ptop_def [def]) (Str.text (rhs_text pos))
+
+let extra_text startpos endpos text items =
+  match items with
+  | [] ->
+      let post = rhs_post_text endpos in
+      let post_extras = rhs_post_extra_text endpos in
+      text post @ text post_extras
+  | _ :: _ ->
+      let pre_extras = rhs_pre_extra_text startpos in
+      let post_extras = rhs_post_extra_text endpos in
+        text pre_extras @ items @ text post_extras
+
+let extra_str p1 p2 items = extra_text p1 p2 Str.text items
+let extra_sig p1 p2 items = extra_text p1 p2 Sig.text items
+let extra_cstr p1 p2 items = extra_text p1 p2 Cf.text items
+let extra_csig p1 p2 items = extra_text p1 p2 Ctf.text  items
+let extra_def p1 p2 items =
+  extra_text p1 p2
+    (fun txt -> List.map (fun def -> Ptop_def [def]) (Str.text txt))
+    items
+
+let extra_rhs_core_type ct ~pos =
+  let docs = rhs_info pos in
+  { ct with ptyp_attributes = add_info_attrs docs ct.ptyp_attributes }
+
+type let_binding =
+  { lb_pattern: pattern;
+    lb_expression: expression;
+    lb_is_pun: bool;
+    lb_attributes: attributes;
+    lb_docs: docs Lazy.t;
+    lb_text: text Lazy.t;
+    lb_loc: Location.t; }
+
+type let_bindings =
+  { lbs_bindings: let_binding list;
+    lbs_rec: rec_flag;
+    lbs_extension: string Asttypes.loc option }
+
+let mklb first ~loc (p, e, is_pun) attrs =
+  {
+    lb_pattern = p;
+    lb_expression = e;
+    lb_is_pun = is_pun;
+    lb_attributes = attrs;
+    lb_docs = symbol_docs_lazy loc;
+    lb_text = (if first then empty_text_lazy
+               else symbol_text_lazy (fst loc));
+    lb_loc = make_loc loc;
+  }
+
+let addlb lbs lb =
+  if lb.lb_is_pun && lbs.lbs_extension = None then syntax_error ();
+  { lbs with lbs_bindings = lb :: lbs.lbs_bindings }
+
+let mklbs ext rf lb =
+  let lbs = {
+    lbs_bindings = [];
+    lbs_rec = rf;
+    lbs_extension = ext;
+  } in
+  addlb lbs lb
+
+let val_of_let_bindings ~loc lbs =
+  let bindings =
+    List.map
+      (fun lb ->
+         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
+           ~docs:(Lazy.force lb.lb_docs)
+           ~text:(Lazy.force lb.lb_text)
+           lb.lb_pattern lb.lb_expression)
+      lbs.lbs_bindings
+  in
+  let str = mkstr ~loc (Pstr_value(lbs.lbs_rec, List.rev bindings)) in
+  match lbs.lbs_extension with
+  | None -> str
+  | Some id -> ghstr ~loc (Pstr_extension((id, PStr [str]), []))
+
+let expr_of_let_bindings ~loc lbs body =
+  let bindings =
+    List.map
+      (fun lb ->
+         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
+           lb.lb_pattern lb.lb_expression)
+      lbs.lbs_bindings
+  in
+    mkexp_attrs ~loc (Pexp_let(lbs.lbs_rec, List.rev bindings, body))
+      (lbs.lbs_extension, [])
+
+let class_of_let_bindings ~loc lbs body =
+  let bindings =
+    List.map
+      (fun lb ->
+         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
+           lb.lb_pattern lb.lb_expression)
+      lbs.lbs_bindings
+  in
+    (* Our use of let_bindings(no_ext) guarantees the following: *)
+    assert (lbs.lbs_extension = None);
+    mkclass ~loc (Pcl_let (lbs.lbs_rec, List.rev bindings, body))
+
+(* Alternatively, we could keep the generic module type in the Parsetree
+   and extract the package type during type-checking. In that case,
+   the assertions below should be turned into explicit checks. *)
+let package_type_of_module_type pmty =
+  let err loc s =
+    raise (Syntaxerr.Error (Syntaxerr.Invalid_package_type (loc, s)))
+  in
+  let map_cstr = function
+    | Pwith_type (lid, ptyp) ->
+        let loc = ptyp.ptype_loc in
+        if ptyp.ptype_params <> [] then
+          err loc "parametrized types are not supported";
+        if ptyp.ptype_cstrs <> [] then
+          err loc "constrained types are not supported";
+        if ptyp.ptype_private <> Public then
+          err loc "private types are not supported";
+
+        (* restrictions below are checked by the 'with_constraint' rule *)
+        assert (ptyp.ptype_kind = Ptype_abstract);
+        assert (ptyp.ptype_attributes = []);
+        let ty =
+          match ptyp.ptype_manifest with
+          | Some ty -> ty
+          | None -> assert false
+        in
+        (lid, ty)
+    | _ ->
+        err pmty.pmty_loc "only 'with type t =' constraints are supported"
+  in
+  match pmty with
+  | {pmty_desc = Pmty_ident lid} -> (lid, [], pmty.pmty_attributes)
+  | {pmty_desc = Pmty_with({pmty_desc = Pmty_ident lid}, cstrs)} ->
+      (lid, List.map map_cstr cstrs, pmty.pmty_attributes)
+  | _ ->
+      err pmty.pmty_loc
+        "only module type identifier and 'with type' constraints are supported"
+
+let mk_directive_arg ~loc k =
+  { pdira_desc = k;
+    pdira_loc = make_loc loc;
+  }
+
+let mk_directive ~loc name arg =
+  Ptop_dir {
+      pdir_name = name;
+      pdir_arg = arg;
+      pdir_loc = make_loc loc;
+    }
+
+%}
+
+/* Tokens */
+
+/* The alias that follows each token is used by Menhir when it needs to
+   produce a sentence (that is, a sequence of tokens) in concrete syntax. */
+
+/* Some tokens represent multiple concrete strings. In most cases, an
+   arbitrary concrete string can be chosen. In a few cases, one must
+   be careful: e.g., in PREFIXOP and INFIXOP2, one must choose a concrete
+   string that will not trigger a syntax error; see how [not_expecting]
+   is used in the definition of [type_variance]. */
+
+%token AMPERAMPER             "&&"
+%token AMPERSAND              "&"
+%token AND                    "and"
+%token AS                     "as"
+%token ASSERT                 "assert"
+%token BACKQUOTE              "`"
+%token BANG                   "!"
+%token BAR                    "|"
+%token BARBAR                 "||"
+%token BARRBRACKET            "|]"
+%token BEGIN                  "begin"
+%token <char> CHAR            "'a'" (* just an example *)
+%token CLASS                  "class"
+%token COLON                  ":"
+%token COLONCOLON             "::"
+%token COLONEQUAL             ":="
+%token COLONGREATER           ":>"
+%token COMMA                  ","
+%token CONSTRAINT             "constraint"
+%token DO                     "do"
+%token DONE                   "done"
+%token DOT                    "."
+%token DOTDOT                 ".."
+%token DOWNTO                 "downto"
+%token ELSE                   "else"
+%token END                    "end"
+%token EOF                    ""
+%token EQUAL                  "="
+%token EXCEPTION              "exception"
+%token EXTERNAL               "external"
+%token FALSE                  "false"
+%token <string * char option> FLOAT "42.0" (* just an example *)
+%token FOR                    "for"
+%token FUN                    "fun"
+%token FUNCTION               "function"
+%token FUNCTOR                "functor"
+%token GREATER                ">"
+%token GREATERRBRACE          ">}"
+%token GREATERRBRACKET        ">]"
+%token IF                     "if"
+%token IN                     "in"
+%token INCLUDE                "include"
+%token <string> INFIXOP0      "!="   (* just an example *)
+%token <string> INFIXOP1      "@"    (* just an example *)
+%token <string> INFIXOP2      "+!"   (* chosen with care; see above *)
+%token <string> INFIXOP3      "land" (* just an example *)
+%token <string> INFIXOP4      "**"   (* just an example *)
+%token <string> DOTOP         ".+"
+%token <string> LETOP         "let*" (* just an example *)
+%token <string> ANDOP         "and*" (* just an example *)
+%token INHERIT                "inherit"
+%token INITIALIZER            "initializer"
+%token <string * char option> INT "42"  (* just an example *)
+%token <string> LABEL         "~label:" (* just an example *)
+%token LAZY                   "lazy"
+%token LBRACE                 "{"
+%token LBRACELESS             "{<"
+%token LBRACKET               "["
+%token LBRACKETBAR            "[|"
+%token LBRACKETLESS           "[<"
+%token LBRACKETGREATER        "[>"
+%token LBRACKETPERCENT        "[%"
+%token LBRACKETPERCENTPERCENT "[%%"
+%token LESS                   "<"
+%token LESSMINUS              "<-"
+%token LET                    "let"
+%token <string> LIDENT        "lident" (* just an example *)
+%token LPAREN                 "("
+%token LBRACKETAT             "[@"
+%token LBRACKETATAT           "[@@"
+%token LBRACKETATATAT         "[@@@"
+%token MATCH                  "match"
+%token METHOD                 "method"
+%token MINUS                  "-"
+%token MINUSDOT               "-."
+%token MINUSGREATER           "->"
+%token MODULE                 "module"
+%token MUTABLE                "mutable"
+%token NEW                    "new"
+%token NONREC                 "nonrec"
+%token OBJECT                 "object"
+%token OF                     "of"
+%token OPEN                   "open"
+%token <string> OPTLABEL      "?label:" (* just an example *)
+%token OR                     "or"
+/* %token PARSER              "parser" */
+%token PERCENT                "%"
+%token PLUS                   "+"
+%token PLUSDOT                "+."
+%token PLUSEQ                 "+="
+%token <string> PREFIXOP      "!+" (* chosen with care; see above *)
+%token PRIVATE                "private"
+%token QUESTION               "?"
+%token QUOTE                  "'"
+%token RBRACE                 "}"
+%token RBRACKET               "]"
+%token REC                    "rec"
+%token RPAREN                 ")"
+%token SEMI                   ";"
+%token SEMISEMI               ";;"
+%token HASH                   "#"
+%token <string> HASHOP        "##" (* just an example *)
+%token SIG                    "sig"
+%token STAR                   "*"
+%token <string * Location.t * string option>
+       STRING                 "\"hello\"" (* just an example *)
+%token <string * Location.t * string * Location.t * string option>
+       QUOTED_STRING_EXPR     "{%hello|world|}"  (* just an example *)
+%token <string * Location.t * string * Location.t * string option>
+       QUOTED_STRING_ITEM     "{%%hello|world|}" (* just an example *)
+%token STRUCT                 "struct"
+%token THEN                   "then"
+%token TILDE                  "~"
+%token TO                     "to"
+%token TRUE                   "true"
+%token TRY                    "try"
+%token TYPE                   "type"
+%token <string> UIDENT        "UIdent" (* just an example *)
+%token UNDERSCORE             "_"
+%token VAL                    "val"
+%token VIRTUAL                "virtual"
+%token WHEN                   "when"
+%token WHILE                  "while"
+%token WITH                   "with"
+%token <string * Location.t> COMMENT    "(* comment *)"
+%token <Docstrings.docstring> DOCSTRING "(** documentation *)"
+
+%token EOL                    "\\n"      (* not great, but EOL is unused *)
+
+/* Precedences and associativities.
+
+Tokens and rules have precedences.  A reduce/reduce conflict is resolved
+in favor of the first rule (in source file order).  A shift/reduce conflict
+is resolved by comparing the precedence and associativity of the token to
+be shifted with those of the rule to be reduced.
+
+By default, a rule has the precedence of its rightmost terminal (if any).
+
+When there is a shift/reduce conflict between a rule and a token that
+have the same precedence, it is resolved using the associativity:
+if the token is left-associative, the parser will reduce; if
+right-associative, the parser will shift; if non-associative,
+the parser will declare a syntax error.
+
+We will only use associativities with operators of the kind  x * x -> x
+for example, in the rules of the form    expr: expr BINOP expr
+in all other cases, we define two precedences if needed to resolve
+conflicts.
+
+The precedences must be listed from low to high.
+*/
+
+%nonassoc IN
+%nonassoc below_SEMI
+%nonassoc SEMI                          /* below EQUAL ({lbl=...; lbl=...}) */
+%nonassoc LET                           /* above SEMI ( ...; let ... in ...) */
+%nonassoc below_WITH
+%nonassoc FUNCTION WITH                 /* below BAR  (match ... with ...) */
+%nonassoc AND             /* above WITH (module rec A: SIG with ... and ...) */
+%nonassoc THEN                          /* below ELSE (if ... then ...) */
+%nonassoc ELSE                          /* (if ... then ... else ...) */
+%nonassoc LESSMINUS                     /* below COLONEQUAL (lbl <- x := e) */
+%right    COLONEQUAL                    /* expr (e := e := e) */
+%nonassoc AS
+%left     BAR                           /* pattern (p|p|p) */
+%nonassoc below_COMMA
+%left     COMMA                         /* expr/expr_comma_list (e,e,e) */
+%right    MINUSGREATER                  /* function_type (t -> t -> t) */
+%right    OR BARBAR                     /* expr (e || e || e) */
+%right    AMPERSAND AMPERAMPER          /* expr (e && e && e) */
+%nonassoc below_EQUAL
+%left     INFIXOP0 EQUAL LESS GREATER   /* expr (e OP e OP e) */
+%right    INFIXOP1                      /* expr (e OP e OP e) */
+%nonassoc below_LBRACKETAT
+%nonassoc LBRACKETAT
+%right    COLONCOLON                    /* expr (e :: e :: e) */
+%left     INFIXOP2 PLUS PLUSDOT MINUS MINUSDOT PLUSEQ /* expr (e OP e OP e) */
+%left     PERCENT INFIXOP3 STAR                 /* expr (e OP e OP e) */
+%right    INFIXOP4                      /* expr (e OP e OP e) */
+%nonassoc prec_unary_minus prec_unary_plus /* unary - */
+%nonassoc prec_constant_constructor     /* cf. simple_expr (C versus C x) */
+%nonassoc prec_constr_appl              /* above AS BAR COLONCOLON COMMA */
+%nonassoc below_HASH
+%nonassoc HASH                         /* simple_expr/toplevel_directive */
+%left     HASHOP
+%nonassoc below_DOT
+%nonassoc DOT DOTOP
+/* Finally, the first tokens of simple_expr are above everything else. */
+%nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT INT
+          LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN
+          NEW PREFIXOP STRING TRUE UIDENT
+          LBRACKETPERCENT QUOTED_STRING_EXPR
+
+
+/* Entry points */
+
+/* Several start symbols are marked with AVOID so that they are not used by
+   [make generate-parse-errors]. The three start symbols that we keep are
+   [implementation], [use_file], and [toplevel_phrase]. The latter two are
+   of marginal importance; only [implementation] really matters, since most
+   states in the automaton are reachable from it. */
+
+%start implementation                   /* for implementation files */
+%type <Parsetree.structure> implementation
+/* BEGIN AVOID */
+%start interface                        /* for interface files */
+%type <Parsetree.signature> interface
+/* END AVOID */
+%start toplevel_phrase                  /* for interactive use */
+%type <Parsetree.toplevel_phrase> toplevel_phrase
+%start use_file                         /* for the #use directive */
+%type <Parsetree.toplevel_phrase list> use_file
+/* BEGIN AVOID */
+%start parse_core_type
+%type <Parsetree.core_type> parse_core_type
+%start parse_expression
+%type <Parsetree.expression> parse_expression
+%start parse_pattern
+%type <Parsetree.pattern> parse_pattern
+%start parse_constr_longident
+%type <Longident.t> parse_constr_longident
+%start parse_val_longident
+%type <Longident.t> parse_val_longident
+%start parse_mty_longident
+%type <Longident.t> parse_mty_longident
+%start parse_mod_ext_longident
+%type <Longident.t> parse_mod_ext_longident
+%start parse_mod_longident
+%type <Longident.t> parse_mod_longident
+%start parse_any_longident
+%type <Longident.t> parse_any_longident
+/* END AVOID */
+
+%%
+
+/* macros */
+%inline extra_str(symb): symb { extra_str $startpos $endpos $1 };
+%inline extra_sig(symb): symb { extra_sig $startpos $endpos $1 };
+%inline extra_cstr(symb): symb { extra_cstr $startpos $endpos $1 };
+%inline extra_csig(symb): symb { extra_csig $startpos $endpos $1 };
+%inline extra_def(symb): symb { extra_def $startpos $endpos $1 };
+%inline extra_text(symb): symb { extra_text $startpos $endpos $1 };
+%inline extra_rhs(symb): symb { extra_rhs_core_type $1 ~pos:$endpos($1) };
+%inline mkrhs(symb): symb
+    { mkrhs $1 $sloc }
+;
+
+%inline text_str(symb): symb
+  { text_str $startpos @ [$1] }
+%inline text_str_SEMISEMI: SEMISEMI
+  { text_str $startpos }
+%inline text_sig(symb): symb
+  { text_sig $startpos @ [$1] }
+%inline text_sig_SEMISEMI: SEMISEMI
+  { text_sig $startpos }
+%inline text_def(symb): symb
+  { text_def $startpos @ [$1] }
+%inline top_def(symb): symb
+  { Ptop_def [$1] }
+%inline text_cstr(symb): symb
+  { text_cstr $startpos @ [$1] }
+%inline text_csig(symb): symb
+  { text_csig $startpos @ [$1] }
+
+(* Using this %inline definition means that we do not control precisely
+   when [mark_rhs_docs] is called, but I don't think this matters. *)
+%inline mark_rhs_docs(symb): symb
+  { mark_rhs_docs $startpos $endpos;
+    $1 }
+
+%inline op(symb): symb
+   { mkoperator ~loc:$sloc $1 }
+
+%inline mkloc(symb): symb
+    { mkloc $1 (make_loc $sloc) }
+
+%inline mkexp(symb): symb
+    { mkexp ~loc:$sloc $1 }
+%inline mkpat(symb): symb
+    { mkpat ~loc:$sloc $1 }
+%inline mktyp(symb): symb
+    { mktyp ~loc:$sloc $1 }
+%inline mkstr(symb): symb
+    { mkstr ~loc:$sloc $1 }
+%inline mksig(symb): symb
+    { mksig ~loc:$sloc $1 }
+%inline mkmod(symb): symb
+    { mkmod ~loc:$sloc $1 }
+%inline mkmty(symb): symb
+    { mkmty ~loc:$sloc $1 }
+%inline mkcty(symb): symb
+    { mkcty ~loc:$sloc $1 }
+%inline mkctf(symb): symb
+    { mkctf ~loc:$sloc $1 }
+%inline mkcf(symb): symb
+    { mkcf ~loc:$sloc $1 }
+%inline mkclass(symb): symb
+    { mkclass ~loc:$sloc $1 }
+
+%inline wrap_mkstr_ext(symb): symb
+    { wrap_mkstr_ext ~loc:$sloc $1 }
+%inline wrap_mksig_ext(symb): symb
+    { wrap_mksig_ext ~loc:$sloc $1 }
+
+%inline mk_directive_arg(symb): symb
+    { mk_directive_arg ~loc:$sloc $1 }
+
+/* Generic definitions */
+
+(* [iloption(X)] recognizes either nothing or [X]. Assuming [X] produces
+   an OCaml list, it produces an OCaml list, too. *)
+
+%inline iloption(X):
+  /* nothing */
+    { [] }
+| x = X
+    { x }
+
+(* [llist(X)] recognizes a possibly empty list of [X]s. It is left-recursive. *)
+
+reversed_llist(X):
+  /* empty */
+    { [] }
+| xs = reversed_llist(X) x = X
+    { x :: xs }
+
+%inline llist(X):
+  xs = rev(reversed_llist(X))
+    { xs }
+
+(* [reversed_nonempty_llist(X)] recognizes a nonempty list of [X]s, and produces
+   an OCaml list in reverse order -- that is, the last element in the input text
+   appears first in this list. Its definition is left-recursive. *)
+
+reversed_nonempty_llist(X):
+  x = X
+    { [ x ] }
+| xs = reversed_nonempty_llist(X) x = X
+    { x :: xs }
+
+(* [nonempty_llist(X)] recognizes a nonempty list of [X]s, and produces an OCaml
+   list in direct order -- that is, the first element in the input text appears
+   first in this list. *)
+
+%inline nonempty_llist(X):
+  xs = rev(reversed_nonempty_llist(X))
+    { xs }
+
+(* [reversed_separated_nonempty_llist(separator, X)] recognizes a nonempty list
+   of [X]s, separated with [separator]s, and produces an OCaml list in reverse
+   order -- that is, the last element in the input text appears first in this
+   list. Its definition is left-recursive. *)
+
+(* [inline_reversed_separated_nonempty_llist(separator, X)] is semantically
+   equivalent to [reversed_separated_nonempty_llist(separator, X)], but is
+   marked %inline, which means that the case of a list of length one and
+   the case of a list of length more than one will be distinguished at the
+   use site, and will give rise there to two productions. This can be used
+   to avoid certain conflicts. *)
+
+%inline inline_reversed_separated_nonempty_llist(separator, X):
+  x = X
+    { [ x ] }
+| xs = reversed_separated_nonempty_llist(separator, X)
+  separator
+  x = X
+    { x :: xs }
+
+reversed_separated_nonempty_llist(separator, X):
+  xs = inline_reversed_separated_nonempty_llist(separator, X)
+    { xs }
+
+(* [separated_nonempty_llist(separator, X)] recognizes a nonempty list of [X]s,
+   separated with [separator]s, and produces an OCaml list in direct order --
+   that is, the first element in the input text appears first in this list. *)
+
+%inline separated_nonempty_llist(separator, X):
+  xs = rev(reversed_separated_nonempty_llist(separator, X))
+    { xs }
+
+%inline inline_separated_nonempty_llist(separator, X):
+  xs = rev(inline_reversed_separated_nonempty_llist(separator, X))
+    { xs }
+
+(* [reversed_separated_nontrivial_llist(separator, X)] recognizes a list of at
+   least two [X]s, separated with [separator]s, and produces an OCaml list in
+   reverse order -- that is, the last element in the input text appears first
+   in this list. Its definition is left-recursive. *)
+
+reversed_separated_nontrivial_llist(separator, X):
+  xs = reversed_separated_nontrivial_llist(separator, X)
+  separator
+  x = X
+    { x :: xs }
+| x1 = X
+  separator
+  x2 = X
+    { [ x2; x1 ] }
+
+(* [separated_nontrivial_llist(separator, X)] recognizes a list of at least
+   two [X]s, separated with [separator]s, and produces an OCaml list in direct
+   order -- that is, the first element in the input text appears first in this
+   list. *)
+
+%inline separated_nontrivial_llist(separator, X):
+  xs = rev(reversed_separated_nontrivial_llist(separator, X))
+    { xs }
+
+(* [separated_or_terminated_nonempty_list(delimiter, X)] recognizes a nonempty
+   list of [X]s, separated with [delimiter]s, and optionally terminated with a
+   final [delimiter]. Its definition is right-recursive. *)
+
+separated_or_terminated_nonempty_list(delimiter, X):
+  x = X ioption(delimiter)
+    { [x] }
+| x = X
+  delimiter
+  xs = separated_or_terminated_nonempty_list(delimiter, X)
+    { x :: xs }
+
+(* [reversed_preceded_or_separated_nonempty_llist(delimiter, X)] recognizes a
+   nonempty list of [X]s, separated with [delimiter]s, and optionally preceded
+   with a leading [delimiter]. It produces an OCaml list in reverse order. Its
+   definition is left-recursive. *)
+
+reversed_preceded_or_separated_nonempty_llist(delimiter, X):
+  ioption(delimiter) x = X
+    { [x] }
+| xs = reversed_preceded_or_separated_nonempty_llist(delimiter, X)
+  delimiter
+  x = X
+    { x :: xs }
+
+(* [preceded_or_separated_nonempty_llist(delimiter, X)] recognizes a nonempty
+   list of [X]s, separated with [delimiter]s, and optionally preceded with a
+   leading [delimiter]. It produces an OCaml list in direct order. *)
+
+%inline preceded_or_separated_nonempty_llist(delimiter, X):
+  xs = rev(reversed_preceded_or_separated_nonempty_llist(delimiter, X))
+    { xs }
+
+(* [bar_llist(X)] recognizes a nonempty list of [X]'s, separated with BARs,
+   with an optional leading BAR. We assume that [X] is itself parameterized
+   with an opening symbol, which can be [epsilon] or [BAR]. *)
+
+(* This construction may seem needlessly complicated: one might think that
+   using [preceded_or_separated_nonempty_llist(BAR, X)], where [X] is *not*
+   itself parameterized, would be sufficient. Indeed, this simpler approach
+   would recognize the same language. However, the two approaches differ in
+   the footprint of [X]. We want the start location of [X] to include [BAR]
+   when present. In the future, we might consider switching to the simpler
+   definition, at the cost of producing slightly different locations. TODO *)
+
+reversed_bar_llist(X):
+    (* An [X] without a leading BAR. *)
+    x = X(epsilon)
+      { [x] }
+  | (* An [X] with a leading BAR. *)
+    x = X(BAR)
+      { [x] }
+  | (* An initial list, followed with a BAR and an [X]. *)
+    xs = reversed_bar_llist(X)
+    x = X(BAR)
+      { x :: xs }
+
+%inline bar_llist(X):
+  xs = reversed_bar_llist(X)
+    { List.rev xs }
+
+(* [xlist(A, B)] recognizes [AB*]. We assume that the semantic value for [A]
+   is a pair [x, b], while the semantic value for [B*] is a list [bs].
+   We return the pair [x, b :: bs]. *)
+
+%inline xlist(A, B):
+  a = A bs = B*
+    { let (x, b) = a in x, b :: bs }
+
+(* [listx(delimiter, X, Y)] recognizes a nonempty list of [X]s, optionally
+   followed with a [Y], separated-or-terminated with [delimiter]s. The
+   semantic value is a pair of a list of [X]s and an optional [Y]. *)
+
+listx(delimiter, X, Y):
+| x = X ioption(delimiter)
+    { [x], None }
+| x = X delimiter y = Y delimiter?
+    { [x], Some y }
+| x = X
+  delimiter
+  tail = listx(delimiter, X, Y)
+    { let xs, y = tail in
+      x :: xs, y }
+
+(* -------------------------------------------------------------------------- *)
+
+(* Entry points. *)
+
+(* An .ml file. *)
+implementation:
+  structure EOF
+    { $1 }
+;
+
+/* BEGIN AVOID */
+(* An .mli file. *)
+interface:
+  signature EOF
+    { $1 }
+;
+/* END AVOID */
+
+(* A toplevel phrase. *)
+toplevel_phrase:
+  (* An expression with attributes, ended by a double semicolon. *)
+  extra_str(text_str(str_exp))
+  SEMISEMI
+    { Ptop_def $1 }
+| (* A list of structure items, ended by a double semicolon. *)
+  extra_str(flatten(text_str(structure_item)*))
+  SEMISEMI
+    { Ptop_def $1 }
+| (* A directive, ended by a double semicolon. *)
+  toplevel_directive
+  SEMISEMI
+    { $1 }
+| (* End of input. *)
+  EOF
+    { raise End_of_file }
+;
+
+(* An .ml file that is read by #use. *)
+use_file:
+  (* An optional standalone expression,
+     followed with a series of elements,
+     followed with EOF. *)
+  extra_def(append(
+    optional_use_file_standalone_expression,
+    flatten(use_file_element*)
+  ))
+  EOF
+    { $1 }
+;
+
+(* An optional standalone expression is just an expression with attributes
+   (str_exp), with extra wrapping. *)
+%inline optional_use_file_standalone_expression:
+  iloption(text_def(top_def(str_exp)))
+    { $1 }
+;
+
+(* An element in a #used file is one of the following:
+   - a double semicolon followed with an optional standalone expression;
+   - a structure item;
+   - a toplevel directive.
+ *)
+%inline use_file_element:
+  preceded(SEMISEMI, optional_use_file_standalone_expression)
+| text_def(top_def(structure_item))
+| text_def(mark_rhs_docs(toplevel_directive))
+      { $1 }
+;
+
+/* BEGIN AVOID */
+parse_core_type:
+  core_type EOF
+    { $1 }
+;
+
+parse_expression:
+  seq_expr EOF
+    { $1 }
+;
+
+parse_pattern:
+  pattern EOF
+    { $1 }
+;
+
+parse_mty_longident:
+  mty_longident EOF
+    { $1 }
+;
+
+parse_val_longident:
+  val_longident EOF
+    { $1 }
+;
+
+parse_constr_longident:
+  constr_longident EOF
+    { $1 }
+;
+
+parse_mod_ext_longident:
+  mod_ext_longident EOF
+    { $1 }
+;
+
+parse_mod_longident:
+  mod_longident EOF
+    { $1 }
+;
+
+parse_any_longident:
+  any_longident EOF
+    { $1 }
+;
+/* END AVOID */
+
+(* -------------------------------------------------------------------------- *)
+
+(* Functor arguments appear in module expressions and module types. *)
+
+%inline functor_args:
+  reversed_nonempty_llist(functor_arg)
+    { $1 }
+    (* Produce a reversed list on purpose;
+       later processed using [fold_left]. *)
+;
+
+functor_arg:
+    (* An anonymous and untyped argument. *)
+    LPAREN RPAREN
+      { $startpos, Unit }
+  | (* An argument accompanied with an explicit type. *)
+    LPAREN x = mkrhs(module_name) COLON mty = module_type RPAREN
+      { $startpos, Named (x, mty) }
+;
+
+module_name:
+    (* A named argument. *)
+    x = UIDENT
+      { Some x }
+  | (* An anonymous argument. *)
+    UNDERSCORE
+      { None }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+(* Module expressions. *)
+
+(* The syntax of module expressions is not properly stratified. The cases of
+   functors, functor applications, and attributes interact and cause conflicts,
+   which are resolved by precedence declarations. This is concise but fragile.
+   Perhaps in the future an explicit stratification could be used. *)
+
+module_expr:
+  | STRUCT attrs = attributes s = structure END
+      { mkmod ~loc:$sloc ~attrs (Pmod_structure s) }
+  | STRUCT attributes structure error
+      { unclosed "struct" $loc($1) "end" $loc($4) }
+  | FUNCTOR attrs = attributes args = functor_args MINUSGREATER me = module_expr
+      { wrap_mod_attrs ~loc:$sloc attrs (
+          List.fold_left (fun acc (startpos, arg) ->
+            mkmod ~loc:(startpos, $endpos) (Pmod_functor (arg, acc))
+          ) me args
+        ) }
+  | me = paren_module_expr
+      { me }
+  | me = module_expr attr = attribute
+      { Mod.attr me attr }
+  | mkmod(
+      (* A module identifier. *)
+      x = mkrhs(mod_longident)
+        { Pmod_ident x }
+    | (* In a functor application, the actual argument must be parenthesized. *)
+      me1 = module_expr me2 = paren_module_expr
+        { Pmod_apply(me1, me2) }
+    | (* Application to unit is sugar for application to an empty structure. *)
+      me1 = module_expr LPAREN RPAREN
+        { (* TODO review mkmod location *)
+          Pmod_apply(me1, mkmod ~loc:$sloc (Pmod_structure [])) }
+    | (* An extension. *)
+      ex = extension
+        { Pmod_extension ex }
+    )
+    { $1 }
+;
+
+(* A parenthesized module expression is a module expression that begins
+   and ends with parentheses. *)
+
+paren_module_expr:
+    (* A module expression annotated with a module type. *)
+    LPAREN me = module_expr COLON mty = module_type RPAREN
+      { mkmod ~loc:$sloc (Pmod_constraint(me, mty)) }
+  | LPAREN module_expr COLON module_type error
+      { unclosed "(" $loc($1) ")" $loc($5) }
+  | (* A module expression within parentheses. *)
+    LPAREN me = module_expr RPAREN
+      { me (* TODO consider reloc *) }
+  | LPAREN module_expr error
+      { unclosed "(" $loc($1) ")" $loc($3) }
+  | (* A core language expression that produces a first-class module.
+       This expression can be annotated in various ways. *)
+    LPAREN VAL attrs = attributes e = expr_colon_package_type RPAREN
+      { mkmod ~loc:$sloc ~attrs (Pmod_unpack e) }
+  | LPAREN VAL attributes expr COLON error
+      { unclosed "(" $loc($1) ")" $loc($6) }
+  | LPAREN VAL attributes expr COLONGREATER error
+      { unclosed "(" $loc($1) ")" $loc($6) }
+  | LPAREN VAL attributes expr error
+      { unclosed "(" $loc($1) ")" $loc($5) }
+;
+
+(* The various ways of annotating a core language expression that
+   produces a first-class module that we wish to unpack. *)
+%inline expr_colon_package_type:
+    e = expr
+      { e }
+  | e = expr COLON ty = package_type
+      { ghexp ~loc:$loc (Pexp_constraint (e, ty)) }
+  | e = expr COLON ty1 = package_type COLONGREATER ty2 = package_type
+      { ghexp ~loc:$loc (Pexp_coerce (e, Some ty1, ty2)) }
+  | e = expr COLONGREATER ty2 = package_type
+      { ghexp ~loc:$loc (Pexp_coerce (e, None, ty2)) }
+;
+
+(* A structure, which appears between STRUCT and END (among other places),
+   begins with an optional standalone expression, and continues with a list
+   of structure elements. *)
+structure:
+  extra_str(append(
+    optional_structure_standalone_expression,
+    flatten(structure_element*)
+  ))
+  { $1 }
+;
+
+(* An optional standalone expression is just an expression with attributes
+   (str_exp), with extra wrapping. *)
+%inline optional_structure_standalone_expression:
+  items = iloption(mark_rhs_docs(text_str(str_exp)))
+    { items }
+;
+
+(* An expression with attributes, wrapped as a structure item. *)
+%inline str_exp:
+  e = seq_expr
+  attrs = post_item_attributes
+    { mkstrexp e attrs }
+;
+
+(* A structure element is one of the following:
+   - a double semicolon followed with an optional standalone expression;
+   - a structure item. *)
+%inline structure_element:
+    append(text_str_SEMISEMI, optional_structure_standalone_expression)
+  | text_str(structure_item)
+      { $1 }
+;
+
+(* A structure item. *)
+structure_item:
+    let_bindings(ext)
+      { val_of_let_bindings ~loc:$sloc $1 }
+  | mkstr(
+      item_extension post_item_attributes
+        { let docs = symbol_docs $sloc in
+          Pstr_extension ($1, add_docs_attrs docs $2) }
+    | floating_attribute
+        { Pstr_attribute $1 }
+    )
+  | wrap_mkstr_ext(
+      primitive_declaration
+        { pstr_primitive $1 }
+    | value_description
+        { pstr_primitive $1 }
+    | type_declarations
+        { pstr_type $1 }
+    | str_type_extension
+        { pstr_typext $1 }
+    | str_exception_declaration
+        { pstr_exception $1 }
+    | module_binding
+        { $1 }
+    | rec_module_bindings
+        { pstr_recmodule $1 }
+    | module_type_declaration
+        { let (body, ext) = $1 in (Pstr_modtype body, ext) }
+    | open_declaration
+        { let (body, ext) = $1 in (Pstr_open body, ext) }
+    | class_declarations
+        { let (ext, l) = $1 in (Pstr_class l, ext) }
+    | class_type_declarations
+        { let (ext, l) = $1 in (Pstr_class_type l, ext) }
+    | include_statement(module_expr)
+        { pstr_include $1 }
+    )
+    { $1 }
+;
+
+(* A single module binding. *)
+%inline module_binding:
+  MODULE
+  ext = ext attrs1 = attributes
+  name = mkrhs(module_name)
+  body = module_binding_body
+  attrs2 = post_item_attributes
+    { let docs = symbol_docs $sloc in
+      let loc = make_loc $sloc in
+      let attrs = attrs1 @ attrs2 in
+      let body = Mb.mk name body ~attrs ~loc ~docs in
+      Pstr_module body, ext }
+;
+
+(* The body (right-hand side) of a module binding. *)
+module_binding_body:
+    EQUAL me = module_expr
+      { me }
+  | mkmod(
+      COLON mty = module_type EQUAL me = module_expr
+        { Pmod_constraint(me, mty) }
+    | arg_and_pos = functor_arg body = module_binding_body
+        { let (_, arg) = arg_and_pos in
+          Pmod_functor(arg, body) }
+  ) { $1 }
+;
+
+(* A group of recursive module bindings. *)
+%inline rec_module_bindings:
+  xlist(rec_module_binding, and_module_binding)
+    { $1 }
+;
+
+(* The first binding in a group of recursive module bindings. *)
+%inline rec_module_binding:
+  MODULE
+  ext = ext
+  attrs1 = attributes
+  REC
+  name = mkrhs(module_name)
+  body = module_binding_body
+  attrs2 = post_item_attributes
+  {
+    let loc = make_loc $sloc in
+    let attrs = attrs1 @ attrs2 in
+    let docs = symbol_docs $sloc in
+    ext,
+    Mb.mk name body ~attrs ~loc ~docs
+  }
+;
+
+(* The following bindings in a group of recursive module bindings. *)
+%inline and_module_binding:
+  AND
+  attrs1 = attributes
+  name = mkrhs(module_name)
+  body = module_binding_body
+  attrs2 = post_item_attributes
+  {
+    let loc = make_loc $sloc in
+    let attrs = attrs1 @ attrs2 in
+    let docs = symbol_docs $sloc in
+    let text = symbol_text $symbolstartpos in
+    Mb.mk name body ~attrs ~loc ~text ~docs
+  }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+(* Shared material between structures and signatures. *)
+
+(* An [include] statement can appear in a structure or in a signature,
+   which is why this definition is parameterized. *)
+%inline include_statement(thing):
+  INCLUDE
+  ext = ext
+  attrs1 = attributes
+  thing = thing
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Incl.mk thing ~attrs ~loc ~docs, ext
+  }
+;
+
+(* A module type declaration. *)
+module_type_declaration:
+  MODULE TYPE
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(ident)
+  typ = preceded(EQUAL, module_type)?
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Mtd.mk id ?typ ~attrs ~loc ~docs, ext
+  }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+(* Opens. *)
+
+open_declaration:
+  OPEN
+  override = override_flag
+  ext = ext
+  attrs1 = attributes
+  me = module_expr
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Opn.mk me ~override ~attrs ~loc ~docs, ext
+  }
+;
+
+open_description:
+  OPEN
+  override = override_flag
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(mod_ext_longident)
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Opn.mk id ~override ~attrs ~loc ~docs, ext
+  }
+;
+
+%inline open_dot_declaration: mkrhs(mod_longident)
+  { let loc = make_loc $loc($1) in
+    let me = Mod.ident ~loc $1 in
+    Opn.mk ~loc me }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+/* Module types */
+
+module_type:
+  | SIG attrs = attributes s = signature END
+      { mkmty ~loc:$sloc ~attrs (Pmty_signature s) }
+  | SIG attributes signature error
+      { unclosed "sig" $loc($1) "end" $loc($4) }
+  | FUNCTOR attrs = attributes args = functor_args
+    MINUSGREATER mty = module_type
+      %prec below_WITH
+      { wrap_mty_attrs ~loc:$sloc attrs (
+          List.fold_left (fun acc (startpos, arg) ->
+            mkmty ~loc:(startpos, $endpos) (Pmty_functor (arg, acc))
+          ) mty args
+        ) }
+  | MODULE TYPE OF attributes module_expr %prec below_LBRACKETAT
+      { mkmty ~loc:$sloc ~attrs:$4 (Pmty_typeof $5) }
+  | LPAREN module_type RPAREN
+      { $2 }
+  | LPAREN module_type error
+      { unclosed "(" $loc($1) ")" $loc($3) }
+  | module_type attribute
+      { Mty.attr $1 $2 }
+  | mkmty(
+      mkrhs(mty_longident)
+        { Pmty_ident $1 }
+    | module_type MINUSGREATER module_type
+        %prec below_WITH
+        { Pmty_functor(Named (mknoloc None, $1), $3) }
+    | module_type WITH separated_nonempty_llist(AND, with_constraint)
+        { Pmty_with($1, $3) }
+/*  | LPAREN MODULE mkrhs(mod_longident) RPAREN
+        { Pmty_alias $3 } */
+    | extension
+        { Pmty_extension $1 }
+    )
+    { $1 }
+;
+(* A signature, which appears between SIG and END (among other places),
+   is a list of signature elements. *)
+signature:
+  extra_sig(flatten(signature_element*))
+    { $1 }
+;
+
+(* A signature element is one of the following:
+   - a double semicolon;
+   - a signature item. *)
+%inline signature_element:
+    text_sig_SEMISEMI
+  | text_sig(signature_item)
+      { $1 }
+;
+
+(* A signature item. *)
+signature_item:
+  | item_extension post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mksig ~loc:$sloc (Psig_extension ($1, (add_docs_attrs docs $2))) }
+  | mksig(
+      floating_attribute
+        { Psig_attribute $1 }
+    )
+    { $1 }
+  | wrap_mksig_ext(
+      value_description
+        { psig_value $1 }
+    | primitive_declaration
+        { psig_value $1 }
+    | type_declarations
+        { psig_type $1 }
+    | type_subst_declarations
+        { psig_typesubst $1 }
+    | sig_type_extension
+        { psig_typext $1 }
+    | sig_exception_declaration
+        { psig_exception $1 }
+    | module_declaration
+        { let (body, ext) = $1 in (Psig_module body, ext) }
+    | module_alias
+        { let (body, ext) = $1 in (Psig_module body, ext) }
+    | module_subst
+        { let (body, ext) = $1 in (Psig_modsubst body, ext) }
+    | rec_module_declarations
+        { let (ext, l) = $1 in (Psig_recmodule l, ext) }
+    | module_type_declaration
+        { let (body, ext) = $1 in (Psig_modtype body, ext) }
+    | module_type_subst
+        { let (body, ext) = $1 in (Psig_modtypesubst body, ext) }
+    | open_description
+        { let (body, ext) = $1 in (Psig_open body, ext) }
+    | include_statement(module_type)
+        { psig_include $1 }
+    | class_descriptions
+        { let (ext, l) = $1 in (Psig_class l, ext) }
+    | class_type_declarations
+        { let (ext, l) = $1 in (Psig_class_type l, ext) }
+    )
+    { $1 }
+
+(* A module declaration. *)
+%inline module_declaration:
+  MODULE
+  ext = ext attrs1 = attributes
+  name = mkrhs(module_name)
+  body = module_declaration_body
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Md.mk name body ~attrs ~loc ~docs, ext
+  }
+;
+
+(* The body (right-hand side) of a module declaration. *)
+module_declaration_body:
+    COLON mty = module_type
+      { mty }
+  | mkmty(
+      arg_and_pos = functor_arg body = module_declaration_body
+        { let (_, arg) = arg_and_pos in
+          Pmty_functor(arg, body) }
+    )
+    { $1 }
+;
+
+(* A module alias declaration (in a signature). *)
+%inline module_alias:
+  MODULE
+  ext = ext attrs1 = attributes
+  name = mkrhs(module_name)
+  EQUAL
+  body = module_expr_alias
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Md.mk name body ~attrs ~loc ~docs, ext
+  }
+;
+%inline module_expr_alias:
+  id = mkrhs(mod_longident)
+    { Mty.alias ~loc:(make_loc $sloc) id }
+;
+(* A module substitution (in a signature). *)
+module_subst:
+  MODULE
+  ext = ext attrs1 = attributes
+  uid = mkrhs(UIDENT)
+  COLONEQUAL
+  body = mkrhs(mod_ext_longident)
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Ms.mk uid body ~attrs ~loc ~docs, ext
+  }
+| MODULE ext attributes mkrhs(UIDENT) COLONEQUAL error
+    { expecting $loc($6) "module path" }
+;
+
+(* A group of recursive module declarations. *)
+%inline rec_module_declarations:
+  xlist(rec_module_declaration, and_module_declaration)
+    { $1 }
+;
+%inline rec_module_declaration:
+  MODULE
+  ext = ext
+  attrs1 = attributes
+  REC
+  name = mkrhs(module_name)
+  COLON
+  mty = module_type
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    ext, Md.mk name mty ~attrs ~loc ~docs
+  }
+;
+%inline and_module_declaration:
+  AND
+  attrs1 = attributes
+  name = mkrhs(module_name)
+  COLON
+  mty = module_type
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let docs = symbol_docs $sloc in
+    let loc = make_loc $sloc in
+    let text = symbol_text $symbolstartpos in
+    Md.mk name mty ~attrs ~loc ~text ~docs
+  }
+;
+
+(* A module type substitution *)
+module_type_subst:
+  MODULE TYPE
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(ident)
+  COLONEQUAL
+  typ=module_type
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Mtd.mk id ~typ ~attrs ~loc ~docs, ext
+  }
+
+
+(* -------------------------------------------------------------------------- *)
+
+(* Class declarations. *)
+
+%inline class_declarations:
+  xlist(class_declaration, and_class_declaration)
+    { $1 }
+;
+%inline class_declaration:
+  CLASS
+  ext = ext
+  attrs1 = attributes
+  virt = virtual_flag
+  params = formal_class_parameters
+  id = mkrhs(LIDENT)
+  body = class_fun_binding
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    ext,
+    Ci.mk id body ~virt ~params ~attrs ~loc ~docs
+  }
+;
+%inline and_class_declaration:
+  AND
+  attrs1 = attributes
+  virt = virtual_flag
+  params = formal_class_parameters
+  id = mkrhs(LIDENT)
+  body = class_fun_binding
+  attrs2 = post_item_attributes
+  {
+    let attrs = attrs1 @ attrs2 in
+    let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    let text = symbol_text $symbolstartpos in
+    Ci.mk id body ~virt ~params ~attrs ~loc ~text ~docs
+  }
+;
+
+class_fun_binding:
+    EQUAL class_expr
+      { $2 }
+  | mkclass(
+      COLON class_type EQUAL class_expr
+        { Pcl_constraint($4, $2) }
+    | labeled_simple_pattern class_fun_binding
+      { let (l,o,p) = $1 in Pcl_fun(l, o, p, $2) }
+    ) { $1 }
+;
+
+formal_class_parameters:
+  params = class_parameters(type_parameter)
+    { params }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+(* Class expressions. *)
+
+class_expr:
+    class_simple_expr
+      { $1 }
+  | FUN attributes class_fun_def
+      { wrap_class_attrs ~loc:$sloc $3 $2 }
+  | let_bindings(no_ext) IN class_expr
+      { class_of_let_bindings ~loc:$sloc $1 $3 }
+  | LET OPEN override_flag attributes mkrhs(mod_longident) IN class_expr
+      { let loc = ($startpos($2), $endpos($5)) in
+        let od = Opn.mk ~override:$3 ~loc:(make_loc loc) $5 in
+        mkclass ~loc:$sloc ~attrs:$4 (Pcl_open(od, $7)) }
+  | class_expr attribute
+      { Cl.attr $1 $2 }
+  | mkclass(
+      class_simple_expr nonempty_llist(labeled_simple_expr)
+        { Pcl_apply($1, $2) }
+    | extension
+        { Pcl_extension $1 }
+    ) { $1 }
+;
+class_simple_expr:
+  | LPAREN class_expr RPAREN
+      { $2 }
+  | LPAREN class_expr error
+      { unclosed "(" $loc($1) ")" $loc($3) }
+  | mkclass(
+      tys = actual_class_parameters cid = mkrhs(class_longident)
+        { Pcl_constr(cid, tys) }
+    | OBJECT attributes class_structure error
+        { unclosed "object" $loc($1) "end" $loc($4) }
+    | LPAREN class_expr COLON class_type RPAREN
+        { Pcl_constraint($2, $4) }
+    | LPAREN class_expr COLON class_type error
+        { unclosed "(" $loc($1) ")" $loc($5) }
+    ) { $1 }
+  | OBJECT attributes class_structure END
+    { mkclass ~loc:$sloc ~attrs:$2 (Pcl_structure $3) }
+;
+
+class_fun_def:
+  mkclass(
+    labeled_simple_pattern MINUSGREATER e = class_expr
+  | labeled_simple_pattern e = class_fun_def
+      { let (l,o,p) = $1 in Pcl_fun(l, o, p, e) }
+  ) { $1 }
+;
+%inline class_structure:
+  |  class_self_pattern extra_cstr(class_fields)
+       { Cstr.mk $1 $2 }
+;
+class_self_pattern:
+    LPAREN pattern RPAREN
+      { reloc_pat ~loc:$sloc $2 }
+  | mkpat(LPAREN pattern COLON core_type RPAREN
+      { Ppat_constraint($2, $4) })
+      { $1 }
+  | /* empty */
+      { ghpat ~loc:$sloc Ppat_any }
+;
+%inline class_fields:
+  flatten(text_cstr(class_field)*)
+    { $1 }
+;
+class_field:
+  | INHERIT override_flag attributes class_expr
+    self = preceded(AS, mkrhs(LIDENT))?
+    post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkcf ~loc:$sloc (Pcf_inherit ($2, $4, self)) ~attrs:($3@$6) ~docs }
+  | VAL value post_item_attributes
+      { let v, attrs = $2 in
+        let docs = symbol_docs $sloc in
+        mkcf ~loc:$sloc (Pcf_val v) ~attrs:(attrs@$3) ~docs }
+  | METHOD method_ post_item_attributes
+      { let meth, attrs = $2 in
+        let docs = symbol_docs $sloc in
+        mkcf ~loc:$sloc (Pcf_method meth) ~attrs:(attrs@$3) ~docs }
+  | CONSTRAINT attributes constrain_field post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkcf ~loc:$sloc (Pcf_constraint $3) ~attrs:($2@$4) ~docs }
+  | INITIALIZER attributes seq_expr post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkcf ~loc:$sloc (Pcf_initializer $3) ~attrs:($2@$4) ~docs }
+  | item_extension post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkcf ~loc:$sloc (Pcf_extension $1) ~attrs:$2 ~docs }
+  | mkcf(floating_attribute
+      { Pcf_attribute $1 })
+      { $1 }
+;
+value:
+    no_override_flag
+    attrs = attributes
+    mutable_ = virtual_with_mutable_flag
+    label = mkrhs(label) COLON ty = core_type
+      { (label, mutable_, Cfk_virtual ty), attrs }
+  | override_flag attributes mutable_flag mkrhs(label) EQUAL seq_expr
+      { ($4, $3, Cfk_concrete ($1, $6)), $2 }
+  | override_flag attributes mutable_flag mkrhs(label) type_constraint
+    EQUAL seq_expr
+      { let e = mkexp_constraint ~loc:$sloc $7 $5 in
+        ($4, $3, Cfk_concrete ($1, e)), $2
+      }
+;
+method_:
+    no_override_flag
+    attrs = attributes
+    private_ = virtual_with_private_flag
+    label = mkrhs(label) COLON ty = poly_type
+      { (label, private_, Cfk_virtual ty), attrs }
+  | override_flag attributes private_flag mkrhs(label) strict_binding
+      { let e = $5 in
+        let loc = Location.(e.pexp_loc.loc_start, e.pexp_loc.loc_end) in
+        ($4, $3,
+        Cfk_concrete ($1, ghexp ~loc (Pexp_poly (e, None)))), $2 }
+  | override_flag attributes private_flag mkrhs(label)
+    COLON poly_type EQUAL seq_expr
+      { let poly_exp =
+          let loc = ($startpos($6), $endpos($8)) in
+          ghexp ~loc (Pexp_poly($8, Some $6)) in
+        ($4, $3, Cfk_concrete ($1, poly_exp)), $2 }
+  | override_flag attributes private_flag mkrhs(label) COLON TYPE lident_list
+    DOT core_type EQUAL seq_expr
+      { let poly_exp_loc = ($startpos($7), $endpos($11)) in
+        let poly_exp =
+          let exp, poly =
+            (* it seems odd to use the global ~loc here while poly_exp_loc
+               is tighter, but this is what ocamlyacc does;
+               TODO improve parser.mly *)
+            wrap_type_annotation ~loc:$sloc $7 $9 $11 in
+          ghexp ~loc:poly_exp_loc (Pexp_poly(exp, Some poly)) in
+        ($4, $3,
+        Cfk_concrete ($1, poly_exp)), $2 }
+;
+
+/* Class types */
+
+class_type:
+    class_signature
+      { $1 }
+  | mkcty(
+      label = arg_label
+      domain = tuple_type
+      MINUSGREATER
+      codomain = class_type
+        { Pcty_arrow(label, domain, codomain) }
+    ) { $1 }
+ ;
+class_signature:
+    mkcty(
+      tys = actual_class_parameters cid = mkrhs(clty_longident)
+        { Pcty_constr (cid, tys) }
+    | extension
+        { Pcty_extension $1 }
+    ) { $1 }
+  | OBJECT attributes class_sig_body END
+      { mkcty ~loc:$sloc ~attrs:$2 (Pcty_signature $3) }
+  | OBJECT attributes class_sig_body error
+      { unclosed "object" $loc($1) "end" $loc($4) }
+  | class_signature attribute
+      { Cty.attr $1 $2 }
+  | LET OPEN override_flag attributes mkrhs(mod_longident) IN class_signature
+      { let loc = ($startpos($2), $endpos($5)) in
+        let od = Opn.mk ~override:$3 ~loc:(make_loc loc) $5 in
+        mkcty ~loc:$sloc ~attrs:$4 (Pcty_open(od, $7)) }
+;
+%inline class_parameters(parameter):
+  | /* empty */
+      { [] }
+  | LBRACKET params = separated_nonempty_llist(COMMA, parameter) RBRACKET
+      { params }
+;
+%inline actual_class_parameters:
+  tys = class_parameters(core_type)
+    { tys }
+;
+%inline class_sig_body:
+    class_self_type extra_csig(class_sig_fields)
+      { Csig.mk $1 $2 }
+;
+class_self_type:
+    LPAREN core_type RPAREN
+      { $2 }
+  | mktyp((* empty *) { Ptyp_any })
+      { $1 }
+;
+%inline class_sig_fields:
+  flatten(text_csig(class_sig_field)*)
+    { $1 }
+;
+class_sig_field:
+    INHERIT attributes class_signature post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkctf ~loc:$sloc (Pctf_inherit $3) ~attrs:($2@$4) ~docs }
+  | VAL attributes value_type post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkctf ~loc:$sloc (Pctf_val $3) ~attrs:($2@$4) ~docs }
+  | METHOD attributes private_virtual_flags mkrhs(label) COLON poly_type
+    post_item_attributes
+      { let (p, v) = $3 in
+        let docs = symbol_docs $sloc in
+        mkctf ~loc:$sloc (Pctf_method ($4, p, v, $6)) ~attrs:($2@$7) ~docs }
+  | CONSTRAINT attributes constrain_field post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkctf ~loc:$sloc (Pctf_constraint $3) ~attrs:($2@$4) ~docs }
+  | item_extension post_item_attributes
+      { let docs = symbol_docs $sloc in
+        mkctf ~loc:$sloc (Pctf_extension $1) ~attrs:$2 ~docs }
+  | mkctf(floating_attribute
+      { Pctf_attribute $1 })
+      { $1 }
+;
+%inline value_type:
+  flags = mutable_virtual_flags
+  label = mkrhs(label)
+  COLON
+  ty = core_type
+  {
+    let mut, virt = flags in
+    label, mut, virt, ty
+  }
+;
+%inline constrain:
+    core_type EQUAL core_type
+    { $1, $3, make_loc $sloc }
+;
+constrain_field:
+  core_type EQUAL core_type
+    { $1, $3 }
+;
+(* A group of class descriptions. *)
+%inline class_descriptions:
+  xlist(class_description, and_class_description)
+    { $1 }
+;
+%inline class_description:
+  CLASS
+  ext = ext
+  attrs1 = attributes
+  virt = virtual_flag
+  params = formal_class_parameters
+  id = mkrhs(LIDENT)
+  COLON
+  cty = class_type
+  attrs2 = post_item_attributes
+    {
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let docs = symbol_docs $sloc in
+      ext,
+      Ci.mk id cty ~virt ~params ~attrs ~loc ~docs
+    }
+;
+%inline and_class_description:
+  AND
+  attrs1 = attributes
+  virt = virtual_flag
+  params = formal_class_parameters
+  id = mkrhs(LIDENT)
+  COLON
+  cty = class_type
+  attrs2 = post_item_attributes
+    {
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let docs = symbol_docs $sloc in
+      let text = symbol_text $symbolstartpos in
+      Ci.mk id cty ~virt ~params ~attrs ~loc ~text ~docs
+    }
+;
+class_type_declarations:
+  xlist(class_type_declaration, and_class_type_declaration)
+    { $1 }
+;
+%inline class_type_declaration:
+  CLASS TYPE
+  ext = ext
+  attrs1 = attributes
+  virt = virtual_flag
+  params = formal_class_parameters
+  id = mkrhs(LIDENT)
+  EQUAL
+  csig = class_signature
+  attrs2 = post_item_attributes
+    {
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let docs = symbol_docs $sloc in
+      ext,
+      Ci.mk id csig ~virt ~params ~attrs ~loc ~docs
+    }
+;
+%inline and_class_type_declaration:
+  AND
+  attrs1 = attributes
+  virt = virtual_flag
+  params = formal_class_parameters
+  id = mkrhs(LIDENT)
+  EQUAL
+  csig = class_signature
+  attrs2 = post_item_attributes
+    {
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let docs = symbol_docs $sloc in
+      let text = symbol_text $symbolstartpos in
+      Ci.mk id csig ~virt ~params ~attrs ~loc ~text ~docs
+    }
+;
+
+/* Core expressions */
+
+seq_expr:
+  | expr        %prec below_SEMI  { $1 }
+  | expr SEMI                     { $1 }
+  | mkexp(expr SEMI seq_expr
+    { Pexp_sequence($1, $3) })
+    { $1 }
+  | expr SEMI PERCENT attr_id seq_expr
+    { let seq = mkexp ~loc:$sloc (Pexp_sequence ($1, $5)) in
+      let payload = PStr [mkstrexp seq []] in
+      mkexp ~loc:$sloc (Pexp_extension ($4, payload)) }
+;
+labeled_simple_pattern:
+    QUESTION LPAREN label_let_pattern opt_default RPAREN
+      { (Optional (fst $3), $4, snd $3) }
+  | QUESTION label_var
+      { (Optional (fst $2), None, snd $2) }
+  | OPTLABEL LPAREN let_pattern opt_default RPAREN
+      { (Optional $1, $4, $3) }
+  | OPTLABEL pattern_var
+      { (Optional $1, None, $2) }
+  | TILDE LPAREN label_let_pattern RPAREN
+      { (Labelled (fst $3), None, snd $3) }
+  | TILDE label_var
+      { (Labelled (fst $2), None, snd $2) }
+  | LABEL simple_pattern
+      { (Labelled $1, None, $2) }
+  | simple_pattern
+      { (Nolabel, None, $1) }
+;
+
+pattern_var:
+  mkpat(
+      mkrhs(LIDENT)     { Ppat_var $1 }
+    | UNDERSCORE        { Ppat_any }
+  ) { $1 }
+;
+
+%inline opt_default:
+  preceded(EQUAL, seq_expr)?
+    { $1 }
+;
+label_let_pattern:
+    x = label_var
+      { x }
+  | x = label_var COLON cty = core_type
+      { let lab, pat = x in
+        lab,
+        mkpat ~loc:$sloc (Ppat_constraint (pat, cty)) }
+;
+%inline label_var:
+    mkrhs(LIDENT)
+      { ($1.Location.txt, mkpat ~loc:$sloc (Ppat_var $1)) }
+;
+let_pattern:
+    pattern
+      { $1 }
+  | mkpat(pattern COLON core_type
+      { Ppat_constraint($1, $3) })
+      { $1 }
+;
+
+%inline indexop_expr(dot, index, right):
+  | array=simple_expr d=dot LPAREN i=index RPAREN r=right
+    { array, d, Paren,   i, r }
+  | array=simple_expr d=dot LBRACE i=index RBRACE r=right
+    { array, d, Brace,   i, r }
+  | array=simple_expr d=dot LBRACKET i=index RBRACKET r=right
+    { array, d, Bracket, i, r }
+;
+
+%inline indexop_error(dot, index):
+  | simple_expr dot _p=LPAREN index  _e=error
+    { indexop_unclosed_error $loc(_p)  Paren $loc(_e) }
+  | simple_expr dot _p=LBRACE index  _e=error
+    { indexop_unclosed_error $loc(_p) Brace $loc(_e) }
+  | simple_expr dot _p=LBRACKET index  _e=error
+    { indexop_unclosed_error $loc(_p) Bracket $loc(_e) }
+;
+
+%inline qualified_dotop: ioption(DOT mod_longident {$2}) DOTOP { $1, $2 };
+
+expr:
+    simple_expr %prec below_HASH
+      { $1 }
+  | expr_attrs
+      { let desc, attrs = $1 in
+        mkexp_attrs ~loc:$sloc desc attrs }
+  | mkexp(expr_)
+      { $1 }
+  | let_bindings(ext) IN seq_expr
+      { expr_of_let_bindings ~loc:$sloc $1 $3 }
+  | pbop_op = mkrhs(LETOP) bindings = letop_bindings IN body = seq_expr
+      { let (pbop_pat, pbop_exp, rev_ands) = bindings in
+        let ands = List.rev rev_ands in
+        let pbop_loc = make_loc $sloc in
+        let let_ = {pbop_op; pbop_pat; pbop_exp; pbop_loc} in
+        mkexp ~loc:$sloc (Pexp_letop{ let_; ands; body}) }
+  | expr COLONCOLON expr
+      { mkexp_cons ~loc:$sloc $loc($2) (ghexp ~loc:$sloc (Pexp_tuple[$1;$3])) }
+  | mkrhs(label) LESSMINUS expr
+      { mkexp ~loc:$sloc (Pexp_setinstvar($1, $3)) }
+  | simple_expr DOT mkrhs(label_longident) LESSMINUS expr
+      { mkexp ~loc:$sloc (Pexp_setfield($1, $3, $5)) }
+  | indexop_expr(DOT, seq_expr, LESSMINUS v=expr {Some v})
+    { mk_indexop_expr builtin_indexing_operators ~loc:$sloc $1 }
+  | indexop_expr(qualified_dotop, expr_semi_list, LESSMINUS v=expr {Some v})
+    { mk_indexop_expr user_indexing_operators ~loc:$sloc $1 }
+  | expr attribute
+      { Exp.attr $1 $2 }
+/* BEGIN AVOID */
+  | UNDERSCORE
+     { not_expecting $loc($1) "wildcard \"_\"" }
+/* END AVOID */
+;
+%inline expr_attrs:
+  | LET MODULE ext_attributes mkrhs(module_name) module_binding_body IN seq_expr
+      { Pexp_letmodule($4, $5, $7), $3 }
+  | LET EXCEPTION ext_attributes let_exception_declaration IN seq_expr
+      { Pexp_letexception($4, $6), $3 }
+  | LET OPEN override_flag ext_attributes module_expr IN seq_expr
+      { let open_loc = make_loc ($startpos($2), $endpos($5)) in
+        let od = Opn.mk $5 ~override:$3 ~loc:open_loc in
+        Pexp_open(od, $7), $4 }
+  | FUNCTION ext_attributes match_cases
+      { Pexp_function $3, $2 }
+  | FUN ext_attributes labeled_simple_pattern fun_def
+      { let (l,o,p) = $3 in
+        Pexp_fun(l, o, p, $4), $2 }
+  | FUN ext_attributes LPAREN TYPE lident_list RPAREN fun_def
+      { (mk_newtypes ~loc:$sloc $5 $7).pexp_desc, $2 }
+  | MATCH ext_attributes seq_expr WITH match_cases
+      { Pexp_match($3, $5), $2 }
+  | TRY ext_attributes seq_expr WITH match_cases
+      { Pexp_try($3, $5), $2 }
+  | TRY ext_attributes seq_expr WITH error
+      { syntax_error() }
+  | IF ext_attributes seq_expr THEN expr ELSE expr
+      { Pexp_ifthenelse($3, $5, Some $7), $2 }
+  | IF ext_attributes seq_expr THEN expr
+      { Pexp_ifthenelse($3, $5, None), $2 }
+  | WHILE ext_attributes seq_expr DO seq_expr DONE
+      { Pexp_while($3, $5), $2 }
+  | FOR ext_attributes pattern EQUAL seq_expr direction_flag seq_expr DO
+    seq_expr DONE
+      { Pexp_for($3, $5, $7, $6, $9), $2 }
+  | ASSERT ext_attributes simple_expr %prec below_HASH
+      { Pexp_assert $3, $2 }
+  | LAZY ext_attributes simple_expr %prec below_HASH
+      { Pexp_lazy $3, $2 }
+  | OBJECT ext_attributes class_structure END
+      { Pexp_object $3, $2 }
+  | OBJECT ext_attributes class_structure error
+      { unclosed "object" $loc($1) "end" $loc($4) }
+;
+%inline expr_:
+  | simple_expr nonempty_llist(labeled_simple_expr)
+      { Pexp_apply($1, $2) }
+  | expr_comma_list %prec below_COMMA
+      { Pexp_tuple($1) }
+  | mkrhs(constr_longident) simple_expr %prec below_HASH
+      { Pexp_construct($1, Some $2) }
+  | name_tag simple_expr %prec below_HASH
+      { Pexp_variant($1, Some $2) }
+  | e1 = expr op = op(infix_operator) e2 = expr
+      { mkinfix e1 op e2 }
+  | subtractive expr %prec prec_unary_minus
+      { mkuminus ~oploc:$loc($1) $1 $2 }
+  | additive expr %prec prec_unary_plus
+      { mkuplus ~oploc:$loc($1) $1 $2 }
+;
+
+simple_expr:
+  | LPAREN seq_expr RPAREN
+      { reloc_exp ~loc:$sloc $2 }
+  | LPAREN seq_expr error
+      { unclosed "(" $loc($1) ")" $loc($3) }
+  | LPAREN seq_expr type_constraint RPAREN
+      { mkexp_constraint ~loc:$sloc $2 $3 }
+  | indexop_expr(DOT, seq_expr, { None })
+      { mk_indexop_expr builtin_indexing_operators ~loc:$sloc $1 }
+  | indexop_expr(qualified_dotop, expr_semi_list, { None })
+      { mk_indexop_expr user_indexing_operators ~loc:$sloc $1 }
+  | indexop_error (DOT, seq_expr) { $1 }
+  | indexop_error (qualified_dotop, expr_semi_list) { $1 }
+  | simple_expr_attrs
+    { let desc, attrs = $1 in
+      mkexp_attrs ~loc:$sloc desc attrs }
+  | mkexp(simple_expr_)
+      { $1 }
+;
+%inline simple_expr_attrs:
+  | BEGIN ext = ext attrs = attributes e = seq_expr END
+      { e.pexp_desc, (ext, attrs @ e.pexp_attributes) }
+  | BEGIN ext_attributes END
+      { Pexp_construct (mkloc (Lident "()") (make_loc $sloc), None), $2 }
+  | BEGIN ext_attributes seq_expr error
+      { unclosed "begin" $loc($1) "end" $loc($4) }
+  | NEW ext_attributes mkrhs(class_longident)
+      { Pexp_new($3), $2 }
+  | LPAREN MODULE ext_attributes module_expr RPAREN
+      { Pexp_pack $4, $3 }
+  | LPAREN MODULE ext_attributes module_expr COLON package_type RPAREN
+      { Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $4), $6), $3 }
+  | LPAREN MODULE ext_attributes module_expr COLON error
+      { unclosed "(" $loc($1) ")" $loc($6) }
+;
+%inline simple_expr_:
+  | mkrhs(val_longident)
+      { Pexp_ident ($1) }
+  | constant
+      { Pexp_constant $1 }
+  | mkrhs(constr_longident) %prec prec_constant_constructor
+      { Pexp_construct($1, None) }
+  | name_tag %prec prec_constant_constructor
+      { Pexp_variant($1, None) }
+  | op(PREFIXOP) simple_expr
+      { Pexp_apply($1, [Nolabel,$2]) }
+  | op(BANG {"!"}) simple_expr
+      { Pexp_apply($1, [Nolabel,$2]) }
+  | LBRACELESS object_expr_content GREATERRBRACE
+      { Pexp_override $2 }
+  | LBRACELESS object_expr_content error
+      { unclosed "{<" $loc($1) ">}" $loc($3) }
+  | LBRACELESS GREATERRBRACE
+      { Pexp_override [] }
+  | simple_expr DOT mkrhs(label_longident)
+      { Pexp_field($1, $3) }
+  | od=open_dot_declaration DOT LPAREN seq_expr RPAREN
+      { Pexp_open(od, $4) }
+  | od=open_dot_declaration DOT LBRACELESS object_expr_content GREATERRBRACE
+      { (* TODO: review the location of Pexp_override *)
+        Pexp_open(od, mkexp ~loc:$sloc (Pexp_override $4)) }
+  | mod_longident DOT LBRACELESS object_expr_content error
+      { unclosed "{<" $loc($3) ">}" $loc($5) }
+  | simple_expr HASH mkrhs(label)
+      { Pexp_send($1, $3) }
+  | simple_expr op(HASHOP) simple_expr
+      { mkinfix $1 $2 $3 }
+  | extension
+      { Pexp_extension $1 }
+  | od=open_dot_declaration DOT mkrhs(LPAREN RPAREN {Lident "()"})
+      { Pexp_open(od, mkexp ~loc:($loc($3)) (Pexp_construct($3, None))) }
+  | mod_longident DOT LPAREN seq_expr error
+      { unclosed "(" $loc($3) ")" $loc($5) }
+  | LBRACE record_expr_content RBRACE
+      { let (exten, fields) = $2 in
+        Pexp_record(fields, exten) }
+  | LBRACE record_expr_content error
+      { unclosed "{" $loc($1) "}" $loc($3) }
+  | od=open_dot_declaration DOT LBRACE record_expr_content RBRACE
+      { let (exten, fields) = $4 in
+        Pexp_open(od, mkexp ~loc:($startpos($3), $endpos)
+                        (Pexp_record(fields, exten))) }
+  | mod_longident DOT LBRACE record_expr_content error
+      { unclosed "{" $loc($3) "}" $loc($5) }
+  | LBRACKETBAR expr_semi_list BARRBRACKET
+      { Pexp_array($2) }
+  | LBRACKETBAR expr_semi_list error
+      { unclosed "[|" $loc($1) "|]" $loc($3) }
+  | LBRACKETBAR BARRBRACKET
+      { Pexp_array [] }
+  | od=open_dot_declaration DOT LBRACKETBAR expr_semi_list BARRBRACKET
+      { Pexp_open(od, mkexp ~loc:($startpos($3), $endpos) (Pexp_array($4))) }
+  | od=open_dot_declaration DOT LBRACKETBAR BARRBRACKET
+      { (* TODO: review the location of Pexp_array *)
+        Pexp_open(od, mkexp ~loc:($startpos($3), $endpos) (Pexp_array [])) }
+  | mod_longident DOT
+    LBRACKETBAR expr_semi_list error
+      { unclosed "[|" $loc($3) "|]" $loc($5) }
+  | LBRACKET expr_semi_list RBRACKET
+      { fst (mktailexp $loc($3) $2) }
+  | LBRACKET expr_semi_list error
+      { unclosed "[" $loc($1) "]" $loc($3) }
+  | od=open_dot_declaration DOT LBRACKET expr_semi_list RBRACKET
+      { let list_exp =
+          (* TODO: review the location of list_exp *)
+          let tail_exp, _tail_loc = mktailexp $loc($5) $4 in
+          mkexp ~loc:($startpos($3), $endpos) tail_exp in
+        Pexp_open(od, list_exp) }
+  | od=open_dot_declaration DOT mkrhs(LBRACKET RBRACKET {Lident "[]"})
+      { Pexp_open(od, mkexp ~loc:$loc($3) (Pexp_construct($3, None))) }
+  | mod_longident DOT
+    LBRACKET expr_semi_list error
+      { unclosed "[" $loc($3) "]" $loc($5) }
+  | od=open_dot_declaration DOT LPAREN MODULE ext_attributes module_expr COLON
+    package_type RPAREN
+      { let modexp =
+          mkexp_attrs ~loc:($startpos($3), $endpos)
+            (Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $6), $8)) $5 in
+        Pexp_open(od, modexp) }
+  | mod_longident DOT
+    LPAREN MODULE ext_attributes module_expr COLON error
+      { unclosed "(" $loc($3) ")" $loc($8) }
+;
+labeled_simple_expr:
+    simple_expr %prec below_HASH
+      { (Nolabel, $1) }
+  | LABEL simple_expr %prec below_HASH
+      { (Labelled $1, $2) }
+  | TILDE label = LIDENT
+      { let loc = $loc(label) in
+        (Labelled label, mkexpvar ~loc label) }
+  | QUESTION label = LIDENT
+      { let loc = $loc(label) in
+        (Optional label, mkexpvar ~loc label) }
+  | OPTLABEL simple_expr %prec below_HASH
+      { (Optional $1, $2) }
+;
+%inline lident_list:
+  xs = mkrhs(LIDENT)+
+    { xs }
+;
+%inline let_ident:
+    val_ident { mkpatvar ~loc:$sloc $1 }
+;
+let_binding_body_no_punning:
+    let_ident strict_binding
+      { ($1, $2) }
+  | let_ident type_constraint EQUAL seq_expr
+      { let v = $1 in (* PR#7344 *)
+        let t =
+          match $2 with
+            Some t, None -> t
+          | _, Some t -> t
+          | _ -> assert false
+        in
+        let loc = Location.(t.ptyp_loc.loc_start, t.ptyp_loc.loc_end) in
+        let typ = ghtyp ~loc (Ptyp_poly([],t)) in
+        let patloc = ($startpos($1), $endpos($2)) in
+        (ghpat ~loc:patloc (Ppat_constraint(v, typ)),
+         mkexp_constraint ~loc:$sloc $4 $2) }
+  | let_ident COLON typevar_list DOT core_type EQUAL seq_expr
+      (* TODO: could replace [typevar_list DOT core_type]
+               with [mktyp(poly(core_type))]
+               and simplify the semantic action? *)
+      { let typloc = ($startpos($3), $endpos($5)) in
+        let patloc = ($startpos($1), $endpos($5)) in
+        (ghpat ~loc:patloc
+           (Ppat_constraint($1, ghtyp ~loc:typloc (Ptyp_poly($3,$5)))),
+         $7) }
+  | let_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr
+      { let exp, poly =
+          wrap_type_annotation ~loc:$sloc $4 $6 $8 in
+        let loc = ($startpos($1), $endpos($6)) in
+        (ghpat ~loc (Ppat_constraint($1, poly)), exp) }
+  | pattern_no_exn EQUAL seq_expr
+      { ($1, $3) }
+  | simple_pattern_not_ident COLON core_type EQUAL seq_expr
+      { let loc = ($startpos($1), $endpos($3)) in
+        (ghpat ~loc (Ppat_constraint($1, $3)), $5) }
+;
+let_binding_body:
+  | let_binding_body_no_punning
+      { let p,e = $1 in (p,e,false) }
+/* BEGIN AVOID */
+  | val_ident %prec below_HASH
+      { (mkpatvar ~loc:$loc $1, mkexpvar ~loc:$loc $1, true) }
+  (* The production that allows puns is marked so that [make list-parse-errors]
+     does not attempt to exploit it. That would be problematic because it
+     would then generate bindings such as [let x], which are rejected by the
+     auxiliary function [addlb] via a call to [syntax_error]. *)
+/* END AVOID */
+;
+(* The formal parameter EXT can be instantiated with ext or no_ext
+   so as to indicate whether an extension is allowed or disallowed. *)
+let_bindings(EXT):
+    let_binding(EXT)                            { $1 }
+  | let_bindings(EXT) and_let_binding           { addlb $1 $2 }
+;
+%inline let_binding(EXT):
+  LET
+  ext = EXT
+  attrs1 = attributes
+  rec_flag = rec_flag
+  body = let_binding_body
+  attrs2 = post_item_attributes
+    {
+      let attrs = attrs1 @ attrs2 in
+      mklbs ext rec_flag (mklb ~loc:$sloc true body attrs)
+    }
+;
+and_let_binding:
+  AND
+  attrs1 = attributes
+  body = let_binding_body
+  attrs2 = post_item_attributes
+    {
+      let attrs = attrs1 @ attrs2 in
+      mklb ~loc:$sloc false body attrs
+    }
+;
+letop_binding_body:
+    pat = let_ident exp = strict_binding
+      { (pat, exp) }
+  | val_ident
+      (* Let-punning *)
+      { (mkpatvar ~loc:$loc $1, mkexpvar ~loc:$loc $1) }
+  | pat = simple_pattern COLON typ = core_type EQUAL exp = seq_expr
+      { let loc = ($startpos(pat), $endpos(typ)) in
+        (ghpat ~loc (Ppat_constraint(pat, typ)), exp) }
+  | pat = pattern_no_exn EQUAL exp = seq_expr
+      { (pat, exp) }
+;
+letop_bindings:
+    body = letop_binding_body
+      { let let_pat, let_exp = body in
+        let_pat, let_exp, [] }
+  | bindings = letop_bindings pbop_op = mkrhs(ANDOP) body = letop_binding_body
+      { let let_pat, let_exp, rev_ands = bindings in
+        let pbop_pat, pbop_exp = body in
+        let pbop_loc = make_loc $sloc in
+        let and_ = {pbop_op; pbop_pat; pbop_exp; pbop_loc} in
+        let_pat, let_exp, and_ :: rev_ands }
+;
+fun_binding:
+    strict_binding
+      { $1 }
+  | type_constraint EQUAL seq_expr
+      { mkexp_constraint ~loc:$sloc $3 $1 }
+;
+strict_binding:
+    EQUAL seq_expr
+      { $2 }
+  | labeled_simple_pattern fun_binding
+      { let (l, o, p) = $1 in ghexp ~loc:$sloc (Pexp_fun(l, o, p, $2)) }
+  | LPAREN TYPE lident_list RPAREN fun_binding
+      { mk_newtypes ~loc:$sloc $3 $5 }
+;
+%inline match_cases:
+  xs = preceded_or_separated_nonempty_llist(BAR, match_case)
+    { xs }
+;
+match_case:
+    pattern MINUSGREATER seq_expr
+      { Exp.case $1 $3 }
+  | pattern WHEN seq_expr MINUSGREATER seq_expr
+      { Exp.case $1 ~guard:$3 $5 }
+  | pattern MINUSGREATER DOT
+      { Exp.case $1 (Exp.unreachable ~loc:(make_loc $loc($3)) ()) }
+;
+fun_def:
+    MINUSGREATER seq_expr
+      { $2 }
+  | mkexp(COLON atomic_type MINUSGREATER seq_expr
+      { Pexp_constraint ($4, $2) })
+      { $1 }
+/* Cf #5939: we used to accept (fun p when e0 -> e) */
+  | labeled_simple_pattern fun_def
+      {
+       let (l,o,p) = $1 in
+       ghexp ~loc:$sloc (Pexp_fun(l, o, p, $2))
+      }
+  | LPAREN TYPE lident_list RPAREN fun_def
+      { mk_newtypes ~loc:$sloc $3 $5 }
+;
+%inline expr_comma_list:
+  es = separated_nontrivial_llist(COMMA, expr)
+    { es }
+;
+record_expr_content:
+  eo = ioption(terminated(simple_expr, WITH))
+  fields = separated_or_terminated_nonempty_list(SEMI, record_expr_field)
+    { eo, fields }
+;
+%inline record_expr_field:
+  | label = mkrhs(label_longident)
+    c = type_constraint?
+    eo = preceded(EQUAL, expr)?
+      { let e =
+          match eo with
+          | None ->
+              (* No pattern; this is a pun. Desugar it. *)
+              exp_of_longident ~loc:$sloc label
+          | Some e ->
+              e
+        in
+        label, mkexp_opt_constraint ~loc:$sloc e c }
+;
+%inline object_expr_content:
+  xs = separated_or_terminated_nonempty_list(SEMI, object_expr_field)
+    { xs }
+;
+%inline object_expr_field:
+    label = mkrhs(label)
+    oe = preceded(EQUAL, expr)?
+      { let e =
+          match oe with
+          | None ->
+              (* No expression; this is a pun. Desugar it. *)
+              exp_of_label ~loc:$sloc label
+          | Some e ->
+              e
+        in
+        label, e }
+;
+%inline expr_semi_list:
+  es = separated_or_terminated_nonempty_list(SEMI, expr)
+    { es }
+;
+type_constraint:
+    COLON core_type                             { (Some $2, None) }
+  | COLON core_type COLONGREATER core_type      { (Some $2, Some $4) }
+  | COLONGREATER core_type                      { (None, Some $2) }
+  | COLON error                                 { syntax_error() }
+  | COLONGREATER error                          { syntax_error() }
+;
+
+/* Patterns */
+
+(* Whereas [pattern] is an arbitrary pattern, [pattern_no_exn] is a pattern
+   that does not begin with the [EXCEPTION] keyword. Thus, [pattern_no_exn]
+   is the intersection of the context-free language [pattern] with the
+   regular language [^EXCEPTION .*].
+
+   Ideally, we would like to use [pattern] everywhere and check in a later
+   phase that EXCEPTION patterns are used only where they are allowed (there
+   is code in typing/typecore.ml to this end). Unfortunately, in the
+   definition of [let_binding_body], we cannot allow [pattern]. That would
+   create a shift/reduce conflict: upon seeing LET EXCEPTION ..., the parser
+   wouldn't know whether this is the beginning of a LET EXCEPTION construct or
+   the beginning of a LET construct whose pattern happens to begin with
+   EXCEPTION. The conflict is avoided there by using [pattern_no_exn] in the
+   definition of [let_binding_body].
+
+   In order to avoid duplication between the definitions of [pattern] and
+   [pattern_no_exn], we create a parameterized definition [pattern_(self)]
+   and instantiate it twice. *)
+
+pattern:
+    pattern_(pattern)
+      { $1 }
+  | EXCEPTION ext_attributes pattern %prec prec_constr_appl
+      { mkpat_attrs ~loc:$sloc (Ppat_exception $3) $2}
+;
+
+pattern_no_exn:
+    pattern_(pattern_no_exn)
+      { $1 }
+;
+
+%inline pattern_(self):
+  | self COLONCOLON pattern
+      { mkpat_cons ~loc:$sloc $loc($2) (ghpat ~loc:$sloc (Ppat_tuple[$1;$3])) }
+  | self attribute
+      { Pat.attr $1 $2 }
+  | pattern_gen
+      { $1 }
+  | mkpat(
+      self AS mkrhs(val_ident)
+        { Ppat_alias($1, $3) }
+    | self AS error
+        { expecting $loc($3) "identifier" }
+    | pattern_comma_list(self) %prec below_COMMA
+        { Ppat_tuple(List.rev $1) }
+    | self COLONCOLON error
+        { expecting $loc($3) "pattern" }
+    | self BAR pattern
+        { Ppat_or($1, $3) }
+    | self BAR error
+        { expecting $loc($3) "pattern" }
+  ) { $1 }
+;
+
+pattern_gen:
+    simple_pattern
+      { $1 }
+  | mkpat(
+      mkrhs(constr_longident) pattern %prec prec_constr_appl
+        { Ppat_construct($1, Some ([], $2)) }
+    | constr=mkrhs(constr_longident) LPAREN TYPE newtypes=lident_list RPAREN
+        pat=simple_pattern
+        { Ppat_construct(constr, Some (newtypes, pat)) }
+    | name_tag pattern %prec prec_constr_appl
+        { Ppat_variant($1, Some $2) }
+    ) { $1 }
+  | LAZY ext_attributes simple_pattern
+      { mkpat_attrs ~loc:$sloc (Ppat_lazy $3) $2}
+;
+simple_pattern:
+    mkpat(mkrhs(val_ident) %prec below_EQUAL
+      { Ppat_var ($1) })
+      { $1 }
+  | simple_pattern_not_ident { $1 }
+;
+
+simple_pattern_not_ident:
+  | LPAREN pattern RPAREN
+      { reloc_pat ~loc:$sloc $2 }
+  | simple_delimited_pattern
+      { $1 }
+  | LPAREN MODULE ext_attributes mkrhs(module_name) RPAREN
+      { mkpat_attrs ~loc:$sloc (Ppat_unpack $4) $3 }
+  | LPAREN MODULE ext_attributes mkrhs(module_name) COLON package_type RPAREN
+      { mkpat_attrs ~loc:$sloc
+          (Ppat_constraint(mkpat ~loc:$loc($4) (Ppat_unpack $4), $6))
+          $3 }
+  | mkpat(simple_pattern_not_ident_)
+      { $1 }
+;
+%inline simple_pattern_not_ident_:
+  | UNDERSCORE
+      { Ppat_any }
+  | signed_constant
+      { Ppat_constant $1 }
+  | signed_constant DOTDOT signed_constant
+      { Ppat_interval ($1, $3) }
+  | mkrhs(constr_longident)
+      { Ppat_construct($1, None) }
+  | name_tag
+      { Ppat_variant($1, None) }
+  | HASH mkrhs(type_longident)
+      { Ppat_type ($2) }
+  | mkrhs(mod_longident) DOT simple_delimited_pattern
+      { Ppat_open($1, $3) }
+  | mkrhs(mod_longident) DOT mkrhs(LBRACKET RBRACKET {Lident "[]"})
+    { Ppat_open($1, mkpat ~loc:$sloc (Ppat_construct($3, None))) }
+  | mkrhs(mod_longident) DOT mkrhs(LPAREN RPAREN {Lident "()"})
+    { Ppat_open($1, mkpat ~loc:$sloc (Ppat_construct($3, None))) }
+  | mkrhs(mod_longident) DOT LPAREN pattern RPAREN
+      { Ppat_open ($1, $4) }
+  | mod_longident DOT LPAREN pattern error
+      { unclosed "(" $loc($3) ")" $loc($5)  }
+  | mod_longident DOT LPAREN error
+      { expecting $loc($4) "pattern" }
+  | LPAREN pattern error
+      { unclosed "(" $loc($1) ")" $loc($3) }
+  | LPAREN pattern COLON core_type RPAREN
+      { Ppat_constraint($2, $4) }
+  | LPAREN pattern COLON core_type error
+      { unclosed "(" $loc($1) ")" $loc($5) }
+  | LPAREN pattern COLON error
+      { expecting $loc($4) "type" }
+  | LPAREN MODULE ext_attributes module_name COLON package_type
+    error
+      { unclosed "(" $loc($1) ")" $loc($7) }
+  | extension
+      { Ppat_extension $1 }
+;
+
+simple_delimited_pattern:
+  mkpat(
+      LBRACE record_pat_content RBRACE
+      { let (fields, closed) = $2 in
+        Ppat_record(fields, closed) }
+    | LBRACE record_pat_content error
+      { unclosed "{" $loc($1) "}" $loc($3) }
+    | LBRACKET pattern_semi_list RBRACKET
+      { fst (mktailpat $loc($3) $2) }
+    | LBRACKET pattern_semi_list error
+      { unclosed "[" $loc($1) "]" $loc($3) }
+    | LBRACKETBAR pattern_semi_list BARRBRACKET
+      { Ppat_array $2 }
+    | LBRACKETBAR BARRBRACKET
+      { Ppat_array [] }
+    | LBRACKETBAR pattern_semi_list error
+      { unclosed "[|" $loc($1) "|]" $loc($3) }
+  ) { $1 }
+
+pattern_comma_list(self):
+    pattern_comma_list(self) COMMA pattern      { $3 :: $1 }
+  | self COMMA pattern                          { [$3; $1] }
+  | self COMMA error                            { expecting $loc($3) "pattern" }
+;
+%inline pattern_semi_list:
+  ps = separated_or_terminated_nonempty_list(SEMI, pattern)
+    { ps }
+;
+(* A label-pattern list is a nonempty list of label-pattern pairs, optionally
+   followed with an UNDERSCORE, separated-or-terminated with semicolons. *)
+%inline record_pat_content:
+  listx(SEMI, record_pat_field, UNDERSCORE)
+    { let fields, closed = $1 in
+      let closed = match closed with Some () -> Open | None -> Closed in
+      fields, closed }
+;
+%inline record_pat_field:
+  label = mkrhs(label_longident)
+  octy = preceded(COLON, core_type)?
+  opat = preceded(EQUAL, pattern)?
+    { let label, pat =
+        match opat with
+        | None ->
+            (* No pattern; this is a pun. Desugar it.
+               But that the pattern was there and the label reconstructed (which
+               piece of AST is marked as ghost is important for warning
+               emission). *)
+            make_ghost label, pat_of_label label
+        | Some pat ->
+            label, pat
+      in
+      label, mkpat_opt_constraint ~loc:$sloc pat octy
+    }
+;
+
+/* Value descriptions */
+
+value_description:
+  VAL
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(val_ident)
+  COLON
+  ty = core_type
+  attrs2 = post_item_attributes
+    { let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let docs = symbol_docs $sloc in
+      Val.mk id ty ~attrs ~loc ~docs,
+      ext }
+;
+
+/* Primitive declarations */
+
+primitive_declaration:
+  EXTERNAL
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(val_ident)
+  COLON
+  ty = core_type
+  EQUAL
+  prim = raw_string+
+  attrs2 = post_item_attributes
+    { let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let docs = symbol_docs $sloc in
+      Val.mk id ty ~prim ~attrs ~loc ~docs,
+      ext }
+;
+
+(* Type declarations and type substitutions. *)
+
+(* Type declarations [type t = u] and type substitutions [type t := u] are very
+   similar, so we view them as instances of [generic_type_declarations]. In the
+   case of a type declaration, the use of [nonrec_flag] means that [NONREC] may
+   be absent or present, whereas in the case of a type substitution, the use of
+   [no_nonrec_flag] means that [NONREC] must be absent. The use of [type_kind]
+   versus [type_subst_kind] means that in the first case, we expect an [EQUAL]
+   sign, whereas in the second case, we expect [COLONEQUAL]. *)
+
+%inline type_declarations:
+  generic_type_declarations(nonrec_flag, type_kind)
+    { $1 }
+;
+
+%inline type_subst_declarations:
+  generic_type_declarations(no_nonrec_flag, type_subst_kind)
+    { $1 }
+;
+
+(* A set of type declarations or substitutions begins with a
+   [generic_type_declaration] and continues with a possibly empty list of
+   [generic_and_type_declaration]s. *)
+
+%inline generic_type_declarations(flag, kind):
+  xlist(
+    generic_type_declaration(flag, kind),
+    generic_and_type_declaration(kind)
+  )
+  { $1 }
+;
+
+(* [generic_type_declaration] and [generic_and_type_declaration] look similar,
+   but are in reality different enough that it is difficult to share anything
+   between them. *)
+
+generic_type_declaration(flag, kind):
+  TYPE
+  ext = ext
+  attrs1 = attributes
+  flag = flag
+  params = type_parameters
+  id = mkrhs(LIDENT)
+  kind_priv_manifest = kind
+  cstrs = constraints
+  attrs2 = post_item_attributes
+    {
+      let (kind, priv, manifest) = kind_priv_manifest in
+      let docs = symbol_docs $sloc in
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      (flag, ext),
+      Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs
+    }
+;
+%inline generic_and_type_declaration(kind):
+  AND
+  attrs1 = attributes
+  params = type_parameters
+  id = mkrhs(LIDENT)
+  kind_priv_manifest = kind
+  cstrs = constraints
+  attrs2 = post_item_attributes
+    {
+      let (kind, priv, manifest) = kind_priv_manifest in
+      let docs = symbol_docs $sloc in
+      let attrs = attrs1 @ attrs2 in
+      let loc = make_loc $sloc in
+      let text = symbol_text $symbolstartpos in
+      Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ~text
+    }
+;
+%inline constraints:
+  llist(preceded(CONSTRAINT, constrain))
+    { $1 }
+;
+(* Lots of %inline expansion are required for [nonempty_type_kind] to be
+   LR(1). At the cost of some manual expansion, it would be possible to give a
+   definition that leads to a smaller grammar (after expansion) and therefore
+   a smaller automaton. *)
+nonempty_type_kind:
+  | priv = inline_private_flag
+    ty = core_type
+      { (Ptype_abstract, priv, Some ty) }
+  | oty = type_synonym
+    priv = inline_private_flag
+    cs = constructor_declarations
+      { (Ptype_variant cs, priv, oty) }
+  | oty = type_synonym
+    priv = inline_private_flag
+    DOTDOT
+      { (Ptype_open, priv, oty) }
+  | oty = type_synonym
+    priv = inline_private_flag
+    LBRACE ls = label_declarations RBRACE
+      { (Ptype_record ls, priv, oty) }
+;
+%inline type_synonym:
+  ioption(terminated(core_type, EQUAL))
+    { $1 }
+;
+type_kind:
+    /*empty*/
+      { (Ptype_abstract, Public, None) }
+  | EQUAL nonempty_type_kind
+      { $2 }
+;
+%inline type_subst_kind:
+    COLONEQUAL nonempty_type_kind
+      { $2 }
+;
+type_parameters:
+    /* empty */
+      { [] }
+  | p = type_parameter
+      { [p] }
+  | LPAREN ps = separated_nonempty_llist(COMMA, type_parameter) RPAREN
+      { ps }
+;
+type_parameter:
+    type_variance type_variable        { $2, $1 }
+;
+type_variable:
+  mktyp(
+    QUOTE tyvar = ident
+      { Ptyp_var tyvar }
+  | UNDERSCORE
+      { Ptyp_any }
+  ) { $1 }
+;
+
+type_variance:
+    /* empty */                             { NoVariance, NoInjectivity }
+  | PLUS                                    { Covariant, NoInjectivity }
+  | MINUS                                   { Contravariant, NoInjectivity }
+  | BANG                                    { NoVariance, Injective }
+  | PLUS BANG | BANG PLUS                   { Covariant, Injective }
+  | MINUS BANG | BANG MINUS                 { Contravariant, Injective }
+  | INFIXOP2
+      { if $1 = "+!" then Covariant, Injective else
+        if $1 = "-!" then Contravariant, Injective else
+        expecting $loc($1) "type_variance" }
+  | PREFIXOP
+      { if $1 = "!+" then Covariant, Injective else
+        if $1 = "!-" then Contravariant, Injective else
+        expecting $loc($1) "type_variance" }
+;
+
+(* A sequence of constructor declarations is either a single BAR, which
+   means that the list is empty, or a nonempty BAR-separated list of
+   declarations, with an optional leading BAR. *)
+constructor_declarations:
+  | BAR
+      { [] }
+  | cs = bar_llist(constructor_declaration)
+      { cs }
+;
+(* A constructor declaration begins with an opening symbol, which can
+   be either epsilon or BAR. Note that this opening symbol is included
+   in the footprint $sloc. *)
+(* Because [constructor_declaration] and [extension_constructor_declaration]
+   are identical except for their semantic actions, we introduce the symbol
+   [generic_constructor_declaration], whose semantic action is neutral -- it
+   merely returns a tuple. *)
+generic_constructor_declaration(opening):
+  opening
+  cid = mkrhs(constr_ident)
+  args_res = generalized_constructor_arguments
+  attrs = attributes
+    {
+      let args, res = args_res in
+      let info = symbol_info $endpos in
+      let loc = make_loc $sloc in
+      cid, args, res, attrs, loc, info
+    }
+;
+%inline constructor_declaration(opening):
+  d = generic_constructor_declaration(opening)
+    {
+      let cid, args, res, attrs, loc, info = d in
+      Type.constructor cid ~args ?res ~attrs ~loc ~info
+    }
+;
+str_exception_declaration:
+  sig_exception_declaration
+    { $1 }
+| EXCEPTION
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(constr_ident)
+  EQUAL
+  lid = mkrhs(constr_longident)
+  attrs2 = attributes
+  attrs = post_item_attributes
+  { let loc = make_loc $sloc in
+    let docs = symbol_docs $sloc in
+    Te.mk_exception ~attrs
+      (Te.rebind id lid ~attrs:(attrs1 @ attrs2) ~loc ~docs)
+    , ext }
+;
+sig_exception_declaration:
+  EXCEPTION
+  ext = ext
+  attrs1 = attributes
+  id = mkrhs(constr_ident)
+  args_res = generalized_constructor_arguments
+  attrs2 = attributes
+  attrs = post_item_attributes
+    { let args, res = args_res in
+      let loc = make_loc ($startpos, $endpos(attrs2)) in
+      let docs = symbol_docs $sloc in
+      Te.mk_exception ~attrs
+        (Te.decl id ~args ?res ~attrs:(attrs1 @ attrs2) ~loc ~docs)
+      , ext }
+;
+%inline let_exception_declaration:
+    mkrhs(constr_ident) generalized_constructor_arguments attributes
+      { let args, res = $2 in
+        Te.decl $1 ~args ?res ~attrs:$3 ~loc:(make_loc $sloc) }
+;
+generalized_constructor_arguments:
+    /*empty*/                     { (Pcstr_tuple [],None) }
+  | OF constructor_arguments      { ($2,None) }
+  | COLON constructor_arguments MINUSGREATER atomic_type %prec below_HASH
+                                  { ($2,Some $4) }
+  | COLON atomic_type %prec below_HASH
+                                  { (Pcstr_tuple [],Some $2) }
+;
+
+constructor_arguments:
+  | tys = inline_separated_nonempty_llist(STAR, atomic_type)
+    %prec below_HASH
+      { Pcstr_tuple tys }
+  | LBRACE label_declarations RBRACE
+      { Pcstr_record $2 }
+;
+label_declarations:
+    label_declaration                           { [$1] }
+  | label_declaration_semi                      { [$1] }
+  | label_declaration_semi label_declarations   { $1 :: $2 }
+;
+label_declaration:
+    mutable_flag mkrhs(label) COLON poly_type_no_attr attributes
+      { let info = symbol_info $endpos in
+        Type.field $2 $4 ~mut:$1 ~attrs:$5 ~loc:(make_loc $sloc) ~info }
+;
+label_declaration_semi:
+    mutable_flag mkrhs(label) COLON poly_type_no_attr attributes SEMI attributes
+      { let info =
+          match rhs_info $endpos($5) with
+          | Some _ as info_before_semi -> info_before_semi
+          | None -> symbol_info $endpos
+       in
+       Type.field $2 $4 ~mut:$1 ~attrs:($5 @ $7) ~loc:(make_loc $sloc) ~info }
+;
+
+/* Type Extensions */
+
+%inline str_type_extension:
+  type_extension(extension_constructor)
+    { $1 }
+;
+%inline sig_type_extension:
+  type_extension(extension_constructor_declaration)
+    { $1 }
+;
+%inline type_extension(declaration):
+  TYPE
+  ext = ext
+  attrs1 = attributes
+  no_nonrec_flag
+  params = type_parameters
+  tid = mkrhs(type_longident)
+  PLUSEQ
+  priv = private_flag
+  cs = bar_llist(declaration)
+  attrs2 = post_item_attributes
+    { let docs = symbol_docs $sloc in
+      let attrs = attrs1 @ attrs2 in
+      Te.mk tid cs ~params ~priv ~attrs ~docs,
+      ext }
+;
+%inline extension_constructor(opening):
+    extension_constructor_declaration(opening)
+      { $1 }
+  | extension_constructor_rebind(opening)
+      { $1 }
+;
+%inline extension_constructor_declaration(opening):
+  d = generic_constructor_declaration(opening)
+    {
+      let cid, args, res, attrs, loc, info = d in
+      Te.decl cid ~args ?res ~attrs ~loc ~info
+    }
+;
+extension_constructor_rebind(opening):
+  opening
+  cid = mkrhs(constr_ident)
+  EQUAL
+  lid = mkrhs(constr_longident)
+  attrs = attributes
+      { let info = symbol_info $endpos in
+        Te.rebind cid lid ~attrs ~loc:(make_loc $sloc) ~info }
+;
+
+/* "with" constraints (additional type equations over signature components) */
+
+with_constraint:
+    TYPE type_parameters mkrhs(label_longident) with_type_binder
+    core_type_no_attr constraints
+      { let lident = loc_last $3 in
+        Pwith_type
+          ($3,
+           (Type.mk lident
+              ~params:$2
+              ~cstrs:$6
+              ~manifest:$5
+              ~priv:$4
+              ~loc:(make_loc $sloc))) }
+    /* used label_longident instead of type_longident to disallow
+       functor applications in type path */
+  | TYPE type_parameters mkrhs(label_longident)
+    COLONEQUAL core_type_no_attr
+      { let lident = loc_last $3 in
+        Pwith_typesubst
+         ($3,
+           (Type.mk lident
+              ~params:$2
+              ~manifest:$5
+              ~loc:(make_loc $sloc))) }
+  | MODULE mkrhs(mod_longident) EQUAL mkrhs(mod_ext_longident)
+      { Pwith_module ($2, $4) }
+  | MODULE mkrhs(mod_longident) COLONEQUAL mkrhs(mod_ext_longident)
+      { Pwith_modsubst ($2, $4) }
+  | MODULE TYPE l=mkrhs(mty_longident) EQUAL rhs=module_type
+      { Pwith_modtype (l, rhs) }
+  | MODULE TYPE l=mkrhs(mty_longident) COLONEQUAL rhs=module_type
+      { Pwith_modtypesubst (l, rhs) }
+;
+with_type_binder:
+    EQUAL          { Public }
+  | EQUAL PRIVATE  { Private }
+;
+
+/* Polymorphic types */
+
+%inline typevar:
+  QUOTE mkrhs(ident)
+    { $2 }
+;
+%inline typevar_list:
+  nonempty_llist(typevar)
+    { $1 }
+;
+%inline poly(X):
+  typevar_list DOT X
+    { Ptyp_poly($1, $3) }
+;
+possibly_poly(X):
+  X
+    { $1 }
+| mktyp(poly(X))
+    { $1 }
+;
+%inline poly_type:
+  possibly_poly(core_type)
+    { $1 }
+;
+%inline poly_type_no_attr:
+  possibly_poly(core_type_no_attr)
+    { $1 }
+;
+
+(* -------------------------------------------------------------------------- *)
+
+(* Core language types. *)
+
+(* A core type (core_type) is a core type without attributes (core_type_no_attr)
+   followed with a list of attributes. *)
+core_type:
+    core_type_no_attr
+      { $1 }
+  | core_type attribute
+      { Typ.attr $1 $2 }
+;
+
+(* A core type without attributes is currently defined as an alias type, but
+   this could change in the future if new forms of types are introduced. From
+   the outside, one should use core_type_no_attr. *)
+%inline core_type_no_attr:
+  alias_type
+    { $1 }
+;
+
+(* Alias types include:
+   - function types (see below);
+   - proper alias types:                  'a -> int as 'a
+ *)
+alias_type:
+    function_type
+      { $1 }
+  | mktyp(
+      ty = alias_type AS QUOTE tyvar = ident
+        { Ptyp_alias(ty, tyvar) }
+    )
+    { $1 }
+;
+
+(* Function types include:
+   - tuple types (see below);
+   - proper function types:               int -> int
+                                          foo: int -> int
+                                          ?foo: int -> int
+ *)
+function_type:
+  | ty = tuple_type
+    %prec MINUSGREATER
+      { ty }
+  | mktyp(
+      label = arg_label
+      domain = extra_rhs(tuple_type)
+      MINUSGREATER
+      codomain = function_type
+        { Ptyp_arrow(label, domain, codomain) }
+    )
+    { $1 }
+;
+%inline arg_label:
+  | label = optlabel
+      { Optional label }
+  | label = LIDENT COLON
+      { Labelled label }
+  | /* empty */
+      { Nolabel }
+;
+(* Tuple types include:
+   - atomic types (see below);
+   - proper tuple types:                  int * int * int list
+   A proper tuple type is a star-separated list of at least two atomic types.
+ *)
+tuple_type:
+  | ty = atomic_type
+    %prec below_HASH
+      { ty }
+  | mktyp(
+      tys = separated_nontrivial_llist(STAR, atomic_type)
+        { Ptyp_tuple tys }
+    )
+    { $1 }
+;
+
+(* Atomic types are the most basic level in the syntax of types.
+   Atomic types include:
+   - types between parentheses:           (int -> int)
+   - first-class module types:            (module S)
+   - type variables:                      'a
+   - applications of type constructors:   int, int list, int option list
+   - variant types:                       [`A]
+ *)
+atomic_type:
+  | LPAREN core_type RPAREN
+      { $2 }
+  | LPAREN MODULE ext_attributes package_type RPAREN
+      { wrap_typ_attrs ~loc:$sloc (reloc_typ ~loc:$sloc $4) $3 }
+  | mktyp( /* begin mktyp group */
+      QUOTE ident
+        { Ptyp_var $2 }
+    | UNDERSCORE
+        { Ptyp_any }
+    | tys = actual_type_parameters
+      tid = mkrhs(type_longident)
+        { Ptyp_constr(tid, tys) }
+    | LESS meth_list GREATER
+        { let (f, c) = $2 in Ptyp_object (f, c) }
+    | LESS GREATER
+        { Ptyp_object ([], Closed) }
+    | tys = actual_type_parameters
+      HASH
+      cid = mkrhs(clty_longident)
+        { Ptyp_class(cid, tys) }
+    | LBRACKET tag_field RBRACKET
+        (* not row_field; see CONFLICTS *)
+        { Ptyp_variant([$2], Closed, None) }
+    | LBRACKET BAR row_field_list RBRACKET
+        { Ptyp_variant($3, Closed, None) }
+    | LBRACKET row_field BAR row_field_list RBRACKET
+        { Ptyp_variant($2 :: $4, Closed, None) }
+    | LBRACKETGREATER BAR? row_field_list RBRACKET
+        { Ptyp_variant($3, Open, None) }
+    | LBRACKETGREATER RBRACKET
+        { Ptyp_variant([], Open, None) }
+    | LBRACKETLESS BAR? row_field_list RBRACKET
+        { Ptyp_variant($3, Closed, Some []) }
+    | LBRACKETLESS BAR? row_field_list GREATER name_tag_list RBRACKET
+        { Ptyp_variant($3, Closed, Some $5) }
+    | extension
+        { Ptyp_extension $1 }
+  )
+  { $1 } /* end mktyp group */
+;
+
+(* This is the syntax of the actual type parameters in an application of
+   a type constructor, such as int, int list, or (int, bool) Hashtbl.t.
+   We allow one of the following:
+   - zero parameters;
+   - one parameter:
+     an atomic type;
+     among other things, this can be an arbitrary type between parentheses;
+   - two or more parameters:
+     arbitrary types, between parentheses, separated with commas.
+ *)
+%inline actual_type_parameters:
+  | /* empty */
+      { [] }
+  | ty = atomic_type
+      { [ty] }
+  | LPAREN tys = separated_nontrivial_llist(COMMA, core_type) RPAREN
+      { tys }
+;
+
+%inline package_type: module_type
+      { let (lid, cstrs, attrs) = package_type_of_module_type $1 in
+        let descr = Ptyp_package (lid, cstrs) in
+        mktyp ~loc:$sloc ~attrs descr }
+;
+%inline row_field_list:
+  separated_nonempty_llist(BAR, row_field)
+    { $1 }
+;
+row_field:
+    tag_field
+      { $1 }
+  | core_type
+      { Rf.inherit_ ~loc:(make_loc $sloc) $1 }
+;
+tag_field:
+    mkrhs(name_tag) OF opt_ampersand amper_type_list attributes
+      { let info = symbol_info $endpos in
+        let attrs = add_info_attrs info $5 in
+        Rf.tag ~loc:(make_loc $sloc) ~attrs $1 $3 $4 }
+  | mkrhs(name_tag) attributes
+      { let info = symbol_info $endpos in
+        let attrs = add_info_attrs info $2 in
+        Rf.tag ~loc:(make_loc $sloc) ~attrs $1 true [] }
+;
+opt_ampersand:
+    AMPERSAND                                   { true }
+  | /* empty */                                 { false }
+;
+%inline amper_type_list:
+  separated_nonempty_llist(AMPERSAND, core_type_no_attr)
+    { $1 }
+;
+%inline name_tag_list:
+  nonempty_llist(name_tag)
+    { $1 }
+;
+(* A method list (in an object type). *)
+meth_list:
+    head = field_semi         tail = meth_list
+  | head = inherit_field SEMI tail = meth_list
+      { let (f, c) = tail in (head :: f, c) }
+  | head = field_semi
+  | head = inherit_field SEMI
+      { [head], Closed }
+  | head = field
+  | head = inherit_field
+      { [head], Closed }
+  | DOTDOT
+      { [], Open }
+;
+%inline field:
+  mkrhs(label) COLON poly_type_no_attr attributes
+    { let info = symbol_info $endpos in
+      let attrs = add_info_attrs info $4 in
+      Of.tag ~loc:(make_loc $sloc) ~attrs $1 $3 }
+;
+
+%inline field_semi:
+  mkrhs(label) COLON poly_type_no_attr attributes SEMI attributes
+    { let info =
+        match rhs_info $endpos($4) with
+        | Some _ as info_before_semi -> info_before_semi
+        | None -> symbol_info $endpos
+      in
+      let attrs = add_info_attrs info ($4 @ $6) in
+      Of.tag ~loc:(make_loc $sloc) ~attrs $1 $3 }
+;
+
+%inline inherit_field:
+  ty = atomic_type
+    { Of.inherit_ ~loc:(make_loc $sloc) ty }
+;
+
+%inline label:
+    LIDENT                                      { $1 }
+;
+
+/* Constants */
+
+constant:
+  | INT          { let (n, m) = $1 in Pconst_integer (n, m) }
+  | CHAR         { Pconst_char $1 }
+  | STRING       { let (s, strloc, d) = $1 in Pconst_string (s, strloc, d) }
+  | FLOAT        { let (f, m) = $1 in Pconst_float (f, m) }
+;
+signed_constant:
+    constant     { $1 }
+  | MINUS INT    { let (n, m) = $2 in Pconst_integer("-" ^ n, m) }
+  | MINUS FLOAT  { let (f, m) = $2 in Pconst_float("-" ^ f, m) }
+  | PLUS INT     { let (n, m) = $2 in Pconst_integer (n, m) }
+  | PLUS FLOAT   { let (f, m) = $2 in Pconst_float(f, m) }
+;
+
+/* Identifiers and long identifiers */
+
+ident:
+    UIDENT                    { $1 }
+  | LIDENT                    { $1 }
+;
+val_extra_ident:
+  | LPAREN operator RPAREN    { $2 }
+  | LPAREN operator error     { unclosed "(" $loc($1) ")" $loc($3) }
+  | LPAREN error              { expecting $loc($2) "operator" }
+  | LPAREN MODULE error       { expecting $loc($3) "module-expr" }
+;
+val_ident:
+    LIDENT                    { $1 }
+  | val_extra_ident           { $1 }
+;
+operator:
+    PREFIXOP                                    { $1 }
+  | LETOP                                       { $1 }
+  | ANDOP                                       { $1 }
+  | DOTOP LPAREN index_mod RPAREN               { "."^ $1 ^"(" ^ $3 ^ ")" }
+  | DOTOP LPAREN index_mod RPAREN LESSMINUS     { "."^ $1 ^ "(" ^ $3 ^ ")<-" }
+  | DOTOP LBRACKET index_mod RBRACKET           { "."^ $1 ^"[" ^ $3 ^ "]" }
+  | DOTOP LBRACKET index_mod RBRACKET LESSMINUS { "."^ $1 ^ "[" ^ $3 ^ "]<-" }
+  | DOTOP LBRACE index_mod RBRACE               { "."^ $1 ^"{" ^ $3 ^ "}" }
+  | DOTOP LBRACE index_mod RBRACE LESSMINUS     { "."^ $1 ^ "{" ^ $3 ^ "}<-" }
+  | HASHOP                                      { $1 }
+  | BANG                                        { "!" }
+  | infix_operator                              { $1 }
+;
+%inline infix_operator:
+  | op = INFIXOP0 { op }
+  | op = INFIXOP1 { op }
+  | op = INFIXOP2 { op }
+  | op = INFIXOP3 { op }
+  | op = INFIXOP4 { op }
+  | PLUS           {"+"}
+  | PLUSDOT       {"+."}
+  | PLUSEQ        {"+="}
+  | MINUS          {"-"}
+  | MINUSDOT      {"-."}
+  | STAR           {"*"}
+  | PERCENT        {"%"}
+  | EQUAL          {"="}
+  | LESS           {"<"}
+  | GREATER        {">"}
+  | OR            {"or"}
+  | BARBAR        {"||"}
+  | AMPERSAND      {"&"}
+  | AMPERAMPER    {"&&"}
+  | COLONEQUAL    {":="}
+;
+index_mod:
+| { "" }
+| SEMI DOTDOT { ";.." }
+;
+
+%inline constr_extra_ident:
+  | LPAREN COLONCOLON RPAREN                    { "::" }
+;
+constr_extra_nonprefix_ident:
+  | LBRACKET RBRACKET                           { "[]" }
+  | LPAREN RPAREN                               { "()" }
+  | FALSE                                       { "false" }
+  | TRUE                                        { "true" }
+;
+constr_ident:
+    UIDENT                                      { $1 }
+  | constr_extra_ident                          { $1 }
+  | constr_extra_nonprefix_ident                { $1 }
+;
+constr_longident:
+    mod_longident       %prec below_DOT  { $1 } /* A.B.x vs (A).B.x */
+  | mod_longident DOT constr_extra_ident { Ldot($1,$3) }
+  | constr_extra_ident                   { Lident $1 }
+  | constr_extra_nonprefix_ident         { Lident $1 }
+;
+mk_longident(prefix,final):
+   | final            { Lident $1 }
+   | prefix DOT final { Ldot($1,$3) }
+;
+val_longident:
+    mk_longident(mod_longident, val_ident) { $1 }
+;
+label_longident:
+    mk_longident(mod_longident, LIDENT) { $1 }
+;
+type_longident:
+    mk_longident(mod_ext_longident, LIDENT)  { $1 }
+;
+mod_longident:
+    mk_longident(mod_longident, UIDENT)  { $1 }
+;
+mod_ext_longident:
+    mk_longident(mod_ext_longident, UIDENT) { $1 }
+  | mod_ext_longident LPAREN mod_ext_longident RPAREN
+      { lapply ~loc:$sloc $1 $3 }
+  | mod_ext_longident LPAREN error
+      { expecting $loc($3) "module path" }
+;
+mty_longident:
+    mk_longident(mod_ext_longident,ident) { $1 }
+;
+clty_longident:
+    mk_longident(mod_ext_longident,LIDENT) { $1 }
+;
+class_longident:
+   mk_longident(mod_longident,LIDENT) { $1 }
+;
+
+/* BEGIN AVOID */
+/* For compiler-libs: parse all valid longidents and a little more:
+   final identifiers which are value specific are accepted even when
+   the path prefix is only valid for types: (e.g. F(X).(::)) */
+any_longident:
+  | mk_longident (mod_ext_longident,
+     ident | constr_extra_ident | val_extra_ident { $1 }
+    ) { $1 }
+  | constr_extra_nonprefix_ident { Lident $1 }
+;
+/* END AVOID */
+
+/* Toplevel directives */
+
+toplevel_directive:
+  HASH dir = mkrhs(ident)
+  arg = ioption(mk_directive_arg(toplevel_directive_argument))
+    { mk_directive ~loc:$sloc dir arg }
+;
+
+%inline toplevel_directive_argument:
+  | STRING        { let (s, _, _) = $1 in Pdir_string s }
+  | INT           { let (n, m) = $1 in Pdir_int (n ,m) }
+  | val_longident { Pdir_ident $1 }
+  | mod_longident { Pdir_ident $1 }
+  | FALSE         { Pdir_bool false }
+  | TRUE          { Pdir_bool true }
+;
+
+/* Miscellaneous */
+
+(* The symbol epsilon can be used instead of an /* empty */ comment. *)
+%inline epsilon:
+  /* empty */
+    { () }
+;
+
+%inline raw_string:
+  s = STRING
+    { let body, _, _ = s in body }
+;
+
+name_tag:
+    BACKQUOTE ident                             { $2 }
+;
+rec_flag:
+    /* empty */                                 { Nonrecursive }
+  | REC                                         { Recursive }
+;
+%inline nonrec_flag:
+    /* empty */                                 { Recursive }
+  | NONREC                                      { Nonrecursive }
+;
+%inline no_nonrec_flag:
+    /* empty */ { Recursive }
+/* BEGIN AVOID */
+  | NONREC      { not_expecting $loc "nonrec flag" }
+/* END AVOID */
+;
+direction_flag:
+    TO                                          { Upto }
+  | DOWNTO                                      { Downto }
+;
+private_flag:
+  inline_private_flag
+    { $1 }
+;
+%inline inline_private_flag:
+    /* empty */                                 { Public }
+  | PRIVATE                                     { Private }
+;
+mutable_flag:
+    /* empty */                                 { Immutable }
+  | MUTABLE                                     { Mutable }
+;
+virtual_flag:
+    /* empty */                                 { Concrete }
+  | VIRTUAL                                     { Virtual }
+;
+mutable_virtual_flags:
+    /* empty */
+      { Immutable, Concrete }
+  | MUTABLE
+      { Mutable, Concrete }
+  | VIRTUAL
+      { Immutable, Virtual }
+  | MUTABLE VIRTUAL
+  | VIRTUAL MUTABLE
+      { Mutable, Virtual }
+;
+private_virtual_flags:
+    /* empty */  { Public, Concrete }
+  | PRIVATE { Private, Concrete }
+  | VIRTUAL { Public, Virtual }
+  | PRIVATE VIRTUAL { Private, Virtual }
+  | VIRTUAL PRIVATE { Private, Virtual }
+;
+(* This nonterminal symbol indicates the definite presence of a VIRTUAL
+   keyword and the possible presence of a MUTABLE keyword. *)
+virtual_with_mutable_flag:
+  | VIRTUAL { Immutable }
+  | MUTABLE VIRTUAL { Mutable }
+  | VIRTUAL MUTABLE { Mutable }
+;
+(* This nonterminal symbol indicates the definite presence of a VIRTUAL
+   keyword and the possible presence of a PRIVATE keyword. *)
+virtual_with_private_flag:
+  | VIRTUAL { Public }
+  | PRIVATE VIRTUAL { Private }
+  | VIRTUAL PRIVATE { Private }
+;
+%inline no_override_flag:
+    /* empty */                                 { Fresh }
+;
+%inline override_flag:
+    /* empty */                                 { Fresh }
+  | BANG                                        { Override }
+;
+subtractive:
+  | MINUS                                       { "-" }
+  | MINUSDOT                                    { "-." }
+;
+additive:
+  | PLUS                                        { "+" }
+  | PLUSDOT                                     { "+." }
+;
+optlabel:
+   | OPTLABEL                                   { $1 }
+   | QUESTION LIDENT COLON                      { $2 }
+;
+
+/* Attributes and extensions */
+
+single_attr_id:
+    LIDENT { $1 }
+  | UIDENT { $1 }
+  | AND { "and" }
+  | AS { "as" }
+  | ASSERT { "assert" }
+  | BEGIN { "begin" }
+  | CLASS { "class" }
+  | CONSTRAINT { "constraint" }
+  | DO { "do" }
+  | DONE { "done" }
+  | DOWNTO { "downto" }
+  | ELSE { "else" }
+  | END { "end" }
+  | EXCEPTION { "exception" }
+  | EXTERNAL { "external" }
+  | FALSE { "false" }
+  | FOR { "for" }
+  | FUN { "fun" }
+  | FUNCTION { "function" }
+  | FUNCTOR { "functor" }
+  | IF { "if" }
+  | IN { "in" }
+  | INCLUDE { "include" }
+  | INHERIT { "inherit" }
+  | INITIALIZER { "initializer" }
+  | LAZY { "lazy" }
+  | LET { "let" }
+  | MATCH { "match" }
+  | METHOD { "method" }
+  | MODULE { "module" }
+  | MUTABLE { "mutable" }
+  | NEW { "new" }
+  | NONREC { "nonrec" }
+  | OBJECT { "object" }
+  | OF { "of" }
+  | OPEN { "open" }
+  | OR { "or" }
+  | PRIVATE { "private" }
+  | REC { "rec" }
+  | SIG { "sig" }
+  | STRUCT { "struct" }
+  | THEN { "then" }
+  | TO { "to" }
+  | TRUE { "true" }
+  | TRY { "try" }
+  | TYPE { "type" }
+  | VAL { "val" }
+  | VIRTUAL { "virtual" }
+  | WHEN { "when" }
+  | WHILE { "while" }
+  | WITH { "with" }
+/* mod/land/lor/lxor/lsl/lsr/asr are not supported for now */
+;
+
+attr_id:
+  mkloc(
+      single_attr_id { $1 }
+    | single_attr_id DOT attr_id { $1 ^ "." ^ $3.txt }
+  ) { $1 }
+;
+attribute:
+  LBRACKETAT attr_id payload RBRACKET
+    { Attr.mk ~loc:(make_loc $sloc) $2 $3 }
+;
+post_item_attribute:
+  LBRACKETATAT attr_id payload RBRACKET
+    { Attr.mk ~loc:(make_loc $sloc) $2 $3 }
+;
+floating_attribute:
+  LBRACKETATATAT attr_id payload RBRACKET
+    { mark_symbol_docs $sloc;
+      Attr.mk ~loc:(make_loc $sloc) $2 $3 }
+;
+%inline post_item_attributes:
+  post_item_attribute*
+    { $1 }
+;
+%inline attributes:
+  attribute*
+    { $1 }
+;
+ext:
+  | /* empty */     { None }
+  | PERCENT attr_id { Some $2 }
+;
+%inline no_ext:
+  | /* empty */     { None }
+/* BEGIN AVOID */
+  | PERCENT attr_id { not_expecting $loc "extension" }
+/* END AVOID */
+;
+%inline ext_attributes:
+  ext attributes    { $1, $2 }
+;
+extension:
+  | LBRACKETPERCENT attr_id payload RBRACKET { ($2, $3) }
+  | QUOTED_STRING_EXPR
+    { mk_quotedext ~loc:$sloc $1 }
+;
+item_extension:
+  | LBRACKETPERCENTPERCENT attr_id payload RBRACKET { ($2, $3) }
+  | QUOTED_STRING_ITEM
+    { mk_quotedext ~loc:$sloc $1 }
+;
+payload:
+    structure { PStr $1 }
+  | COLON signature { PSig $2 }
+  | COLON core_type { PTyp $2 }
+  | QUESTION pattern { PPat ($2, None) }
+  | QUESTION pattern WHEN seq_expr { PPat ($2, Some $4) }
+;
+%%
diff --git a/upstream/ocaml_413/parsing/parsetree.mli b/upstream/ocaml_413/parsing/parsetree.mli
new file mode 100644
index 0000000..0508d04
--- /dev/null
+++ b/upstream/ocaml_413/parsing/parsetree.mli
@@ -0,0 +1,978 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Abstract syntax tree produced by parsing
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Asttypes
+
+type constant =
+    Pconst_integer of string * char option
+  (* 3 3l 3L 3n
+
+     Suffixes [g-z][G-Z] are accepted by the parser.
+     Suffixes except 'l', 'L' and 'n' are rejected by the typechecker
+  *)
+  | Pconst_char of char
+  (* 'c' *)
+  | Pconst_string of string * Location.t * string option
+  (* "constant"
+     {delim|other constant|delim}
+
+     The location span the content of the string, without the delimiters.
+  *)
+  | Pconst_float of string * char option
+  (* 3.4 2e5 1.4e-4
+
+     Suffixes [g-z][G-Z] are accepted by the parser.
+     Suffixes are rejected by the typechecker.
+  *)
+
+type location_stack = Location.t list
+
+(** {1 Extension points} *)
+
+type attribute = {
+    attr_name : string loc;
+    attr_payload : payload;
+    attr_loc : Location.t;
+  }
+       (* [@id ARG]
+          [@@id ARG]
+
+          Metadata containers passed around within the AST.
+          The compiler ignores unknown attributes.
+       *)
+
+and extension = string loc * payload
+      (* [%id ARG]
+         [%%id ARG]
+
+         Sub-language placeholder -- rejected by the typechecker.
+      *)
+
+and attributes = attribute list
+
+and payload =
+  | PStr of structure
+  | PSig of signature (* : SIG *)
+  | PTyp of core_type  (* : T *)
+  | PPat of pattern * expression option  (* ? P  or  ? P when E *)
+
+(** {1 Core language} *)
+
+(* Type expressions *)
+
+and core_type =
+    {
+     ptyp_desc: core_type_desc;
+     ptyp_loc: Location.t;
+     ptyp_loc_stack: location_stack;
+     ptyp_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and core_type_desc =
+  | Ptyp_any
+        (*  _ *)
+  | Ptyp_var of string
+        (* 'a *)
+  | Ptyp_arrow of arg_label * core_type * core_type
+        (* T1 -> T2       Simple
+           ~l:T1 -> T2    Labelled
+           ?l:T1 -> T2    Optional
+         *)
+  | Ptyp_tuple of core_type list
+        (* T1 * ... * Tn
+
+           Invariant: n >= 2
+        *)
+  | Ptyp_constr of Longident.t loc * core_type list
+        (* tconstr
+           T tconstr
+           (T1, ..., Tn) tconstr
+         *)
+  | Ptyp_object of object_field list * closed_flag
+        (* < l1:T1; ...; ln:Tn >     (flag = Closed)
+           < l1:T1; ...; ln:Tn; .. > (flag = Open)
+         *)
+  | Ptyp_class of Longident.t loc * core_type list
+        (* #tconstr
+           T #tconstr
+           (T1, ..., Tn) #tconstr
+         *)
+  | Ptyp_alias of core_type * string
+        (* T as 'a *)
+  | Ptyp_variant of row_field list * closed_flag * label list option
+        (* [ `A|`B ]         (flag = Closed; labels = None)
+           [> `A|`B ]        (flag = Open;   labels = None)
+           [< `A|`B ]        (flag = Closed; labels = Some [])
+           [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"])
+         *)
+  | Ptyp_poly of string loc list * core_type
+        (* 'a1 ... 'an. T
+
+           Can only appear in the following context:
+
+           - As the core_type of a Ppat_constraint node corresponding
+             to a constraint on a let-binding: let x : 'a1 ... 'an. T
+             = e ...
+
+           - Under Cfk_virtual for methods (not values).
+
+           - As the core_type of a Pctf_method node.
+
+           - As the core_type of a Pexp_poly node.
+
+           - As the pld_type field of a label_declaration.
+
+           - As a core_type of a Ptyp_object node.
+         *)
+
+  | Ptyp_package of package_type
+        (* (module S) *)
+  | Ptyp_extension of extension
+        (* [%id] *)
+
+and package_type = Longident.t loc * (Longident.t loc * core_type) list
+      (*
+        (module S)
+        (module S with type t1 = T1 and ... and tn = Tn)
+       *)
+
+and row_field = {
+  prf_desc : row_field_desc;
+  prf_loc : Location.t;
+  prf_attributes : attributes;
+}
+
+and row_field_desc =
+  | Rtag of label loc * bool * core_type list
+        (* [`A]                   ( true,  [] )
+           [`A of T]              ( false, [T] )
+           [`A of T1 & .. & Tn]   ( false, [T1;...Tn] )
+           [`A of & T1 & .. & Tn] ( true,  [T1;...Tn] )
+
+          - The 'bool' field is true if the tag contains a
+            constant (empty) constructor.
+          - '&' occurs when several types are used for the same constructor
+            (see 4.2 in the manual)
+        *)
+  | Rinherit of core_type
+        (* [ | t ] *)
+
+and object_field = {
+  pof_desc : object_field_desc;
+  pof_loc : Location.t;
+  pof_attributes : attributes;
+}
+
+and object_field_desc =
+  | Otag of label loc * core_type
+  | Oinherit of core_type
+
+(* Patterns *)
+
+and pattern =
+    {
+     ppat_desc: pattern_desc;
+     ppat_loc: Location.t;
+     ppat_loc_stack: location_stack;
+     ppat_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and pattern_desc =
+  | Ppat_any
+        (* _ *)
+  | Ppat_var of string loc
+        (* x *)
+  | Ppat_alias of pattern * string loc
+        (* P as 'a *)
+  | Ppat_constant of constant
+        (* 1, 'a', "true", 1.0, 1l, 1L, 1n *)
+  | Ppat_interval of constant * constant
+        (* 'a'..'z'
+
+           Other forms of interval are recognized by the parser
+           but rejected by the type-checker. *)
+  | Ppat_tuple of pattern list
+        (* (P1, ..., Pn)
+
+           Invariant: n >= 2
+        *)
+  | Ppat_construct of
+      Longident.t loc * (string loc list * pattern) option
+        (* C                    None
+           C P                  Some ([], P)
+           C (P1, ..., Pn)      Some ([], Ppat_tuple [P1; ...; Pn])
+           C (type a b) P       Some ([a; b], P)
+         *)
+  | Ppat_variant of label * pattern option
+        (* `A             (None)
+           `A P           (Some P)
+         *)
+  | Ppat_record of (Longident.t loc * pattern) list * closed_flag
+        (* { l1=P1; ...; ln=Pn }     (flag = Closed)
+           { l1=P1; ...; ln=Pn; _}   (flag = Open)
+
+           Invariant: n > 0
+         *)
+  | Ppat_array of pattern list
+        (* [| P1; ...; Pn |] *)
+  | Ppat_or of pattern * pattern
+        (* P1 | P2 *)
+  | Ppat_constraint of pattern * core_type
+        (* (P : T) *)
+  | Ppat_type of Longident.t loc
+        (* #tconst *)
+  | Ppat_lazy of pattern
+        (* lazy P *)
+  | Ppat_unpack of string option loc
+        (* (module P)        Some "P"
+           (module _)        None
+
+           Note: (module P : S) is represented as
+           Ppat_constraint(Ppat_unpack, Ptyp_package)
+         *)
+  | Ppat_exception of pattern
+        (* exception P *)
+  | Ppat_extension of extension
+        (* [%id] *)
+  | Ppat_open of Longident.t loc * pattern
+        (* M.(P) *)
+
+(* Value expressions *)
+
+and expression =
+    {
+     pexp_desc: expression_desc;
+     pexp_loc: Location.t;
+     pexp_loc_stack: location_stack;
+     pexp_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and expression_desc =
+  | Pexp_ident of Longident.t loc
+        (* x
+           M.x
+         *)
+  | Pexp_constant of constant
+        (* 1, 'a', "true", 1.0, 1l, 1L, 1n *)
+  | Pexp_let of rec_flag * value_binding list * expression
+        (* let P1 = E1 and ... and Pn = EN in E       (flag = Nonrecursive)
+           let rec P1 = E1 and ... and Pn = EN in E   (flag = Recursive)
+         *)
+  | Pexp_function of case list
+        (* function P1 -> E1 | ... | Pn -> En *)
+  | Pexp_fun of arg_label * expression option * pattern * expression
+        (* fun P -> E1                          (Simple, None)
+           fun ~l:P -> E1                       (Labelled l, None)
+           fun ?l:P -> E1                       (Optional l, None)
+           fun ?l:(P = E0) -> E1                (Optional l, Some E0)
+
+           Notes:
+           - If E0 is provided, only Optional is allowed.
+           - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun.
+           - "let f P = E" is represented using Pexp_fun.
+         *)
+  | Pexp_apply of expression * (arg_label * expression) list
+        (* E0 ~l1:E1 ... ~ln:En
+           li can be empty (non labeled argument) or start with '?'
+           (optional argument).
+
+           Invariant: n > 0
+         *)
+  | Pexp_match of expression * case list
+        (* match E0 with P1 -> E1 | ... | Pn -> En *)
+  | Pexp_try of expression * case list
+        (* try E0 with P1 -> E1 | ... | Pn -> En *)
+  | Pexp_tuple of expression list
+        (* (E1, ..., En)
+
+           Invariant: n >= 2
+        *)
+  | Pexp_construct of Longident.t loc * expression option
+        (* C                None
+           C E              Some E
+           C (E1, ..., En)  Some (Pexp_tuple[E1;...;En])
+        *)
+  | Pexp_variant of label * expression option
+        (* `A             (None)
+           `A E           (Some E)
+         *)
+  | Pexp_record of (Longident.t loc * expression) list * expression option
+        (* { l1=P1; ...; ln=Pn }     (None)
+           { E0 with l1=P1; ...; ln=Pn }   (Some E0)
+
+           Invariant: n > 0
+         *)
+  | Pexp_field of expression * Longident.t loc
+        (* E.l *)
+  | Pexp_setfield of expression * Longident.t loc * expression
+        (* E1.l <- E2 *)
+  | Pexp_array of expression list
+        (* [| E1; ...; En |] *)
+  | Pexp_ifthenelse of expression * expression * expression option
+        (* if E1 then E2 else E3 *)
+  | Pexp_sequence of expression * expression
+        (* E1; E2 *)
+  | Pexp_while of expression * expression
+        (* while E1 do E2 done *)
+  | Pexp_for of
+      pattern *  expression * expression * direction_flag * expression
+        (* for i = E1 to E2 do E3 done      (flag = Upto)
+           for i = E1 downto E2 do E3 done  (flag = Downto)
+         *)
+  | Pexp_constraint of expression * core_type
+        (* (E : T) *)
+  | Pexp_coerce of expression * core_type option * core_type
+        (* (E :> T)        (None, T)
+           (E : T0 :> T)   (Some T0, T)
+         *)
+  | Pexp_send of expression * label loc
+        (*  E # m *)
+  | Pexp_new of Longident.t loc
+        (* new M.c *)
+  | Pexp_setinstvar of label loc * expression
+        (* x <- 2 *)
+  | Pexp_override of (label loc * expression) list
+        (* {< x1 = E1; ...; Xn = En >} *)
+  | Pexp_letmodule of string option loc * module_expr * expression
+        (* let module M = ME in E *)
+  | Pexp_letexception of extension_constructor * expression
+        (* let exception C in E *)
+  | Pexp_assert of expression
+        (* assert E
+           Note: "assert false" is treated in a special way by the
+           type-checker. *)
+  | Pexp_lazy of expression
+        (* lazy E *)
+  | Pexp_poly of expression * core_type option
+        (* Used for method bodies.
+
+           Can only be used as the expression under Cfk_concrete
+           for methods (not values). *)
+  | Pexp_object of class_structure
+        (* object ... end *)
+  | Pexp_newtype of string loc * expression
+        (* fun (type t) -> E *)
+  | Pexp_pack of module_expr
+        (* (module ME)
+
+           (module ME : S) is represented as
+           Pexp_constraint(Pexp_pack, Ptyp_package S) *)
+  | Pexp_open of open_declaration * expression
+        (* M.(E)
+           let open M in E
+           let! open M in E *)
+  | Pexp_letop of letop
+        (* let* P = E in E
+           let* P = E and* P = E in E *)
+  | Pexp_extension of extension
+        (* [%id] *)
+  | Pexp_unreachable
+        (* . *)
+
+and case =   (* (P -> E) or (P when E0 -> E) *)
+    {
+     pc_lhs: pattern;
+     pc_guard: expression option;
+     pc_rhs: expression;
+   }
+
+and letop =
+  {
+    let_ : binding_op;
+    ands : binding_op list;
+    body : expression;
+  }
+
+and binding_op =
+  {
+    pbop_op : string loc;
+    pbop_pat : pattern;
+    pbop_exp : expression;
+    pbop_loc : Location.t;
+  }
+
+(* Value descriptions *)
+
+and value_description =
+    {
+     pval_name: string loc;
+     pval_type: core_type;
+     pval_prim: string list;
+     pval_attributes: attributes;  (* ... [@@id1] [@@id2] *)
+     pval_loc: Location.t;
+    }
+
+(*
+  val x: T                            (prim = [])
+  external x: T = "s1" ... "sn"       (prim = ["s1";..."sn"])
+*)
+
+(* Type declarations *)
+
+and type_declaration =
+    {
+     ptype_name: string loc;
+     ptype_params: (core_type * (variance * injectivity)) list;
+           (* ('a1,...'an) t; None represents  _*)
+     ptype_cstrs: (core_type * core_type * Location.t) list;
+           (* ... constraint T1=T1'  ... constraint Tn=Tn' *)
+     ptype_kind: type_kind;
+     ptype_private: private_flag;   (* = private ... *)
+     ptype_manifest: core_type option;  (* = T *)
+     ptype_attributes: attributes;   (* ... [@@id1] [@@id2] *)
+     ptype_loc: Location.t;
+    }
+
+(*
+  type t                     (abstract, no manifest)
+  type t = T0                (abstract, manifest=T0)
+  type t = C of T | ...      (variant,  no manifest)
+  type t = T0 = C of T | ... (variant,  manifest=T0)
+  type t = {l: T; ...}       (record,   no manifest)
+  type t = T0 = {l : T; ...} (record,   manifest=T0)
+  type t = ..                (open,     no manifest)
+*)
+
+and type_kind =
+  | Ptype_abstract
+  | Ptype_variant of constructor_declaration list
+  | Ptype_record of label_declaration list
+        (* Invariant: non-empty list *)
+  | Ptype_open
+
+and label_declaration =
+    {
+     pld_name: string loc;
+     pld_mutable: mutable_flag;
+     pld_type: core_type;
+     pld_loc: Location.t;
+     pld_attributes: attributes; (* l : T [@id1] [@id2] *)
+    }
+
+(*  { ...; l: T; ... }            (mutable=Immutable)
+    { ...; mutable l: T; ... }    (mutable=Mutable)
+
+    Note: T can be a Ptyp_poly.
+*)
+
+and constructor_declaration =
+    {
+     pcd_name: string loc;
+     pcd_args: constructor_arguments;
+     pcd_res: core_type option;
+     pcd_loc: Location.t;
+     pcd_attributes: attributes; (* C of ... [@id1] [@id2] *)
+    }
+
+and constructor_arguments =
+  | Pcstr_tuple of core_type list
+  | Pcstr_record of label_declaration list
+
+(*
+  | C of T1 * ... * Tn     (res = None,    args = Pcstr_tuple [])
+  | C: T0                  (res = Some T0, args = [])
+  | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple)
+  | C of {...}             (res = None,    args = Pcstr_record)
+  | C: {...} -> T0         (res = Some T0, args = Pcstr_record)
+  | C of {...} as t        (res = None,    args = Pcstr_record)
+*)
+
+and type_extension =
+    {
+     ptyext_path: Longident.t loc;
+     ptyext_params: (core_type * (variance * injectivity)) list;
+     ptyext_constructors: extension_constructor list;
+     ptyext_private: private_flag;
+     ptyext_loc: Location.t;
+     ptyext_attributes: attributes;   (* ... [@@id1] [@@id2] *)
+    }
+(*
+  type t += ...
+*)
+
+and extension_constructor =
+    {
+     pext_name: string loc;
+     pext_kind : extension_constructor_kind;
+     pext_loc : Location.t;
+     pext_attributes: attributes; (* C of ... [@id1] [@id2] *)
+   }
+
+(* exception E *)
+and type_exception =
+  {
+    ptyexn_constructor: extension_constructor;
+    ptyexn_loc: Location.t;
+    ptyexn_attributes: attributes; (* ... [@@id1] [@@id2] *)
+  }
+
+and extension_constructor_kind =
+    Pext_decl of constructor_arguments * core_type option
+      (*
+         | C of T1 * ... * Tn     ([T1; ...; Tn], None)
+         | C: T0                  ([], Some T0)
+         | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0)
+       *)
+  | Pext_rebind of Longident.t loc
+      (*
+         | C = D
+       *)
+
+(** {1 Class language} *)
+
+(* Type expressions for the class language *)
+
+and class_type =
+    {
+     pcty_desc: class_type_desc;
+     pcty_loc: Location.t;
+     pcty_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and class_type_desc =
+  | Pcty_constr of Longident.t loc * core_type list
+        (* c
+           ['a1, ..., 'an] c *)
+  | Pcty_signature of class_signature
+        (* object ... end *)
+  | Pcty_arrow of arg_label * core_type * class_type
+        (* T -> CT       Simple
+           ~l:T -> CT    Labelled l
+           ?l:T -> CT    Optional l
+         *)
+  | Pcty_extension of extension
+        (* [%id] *)
+  | Pcty_open of open_description * class_type
+        (* let open M in CT *)
+
+and class_signature =
+    {
+     pcsig_self: core_type;
+     pcsig_fields: class_type_field list;
+    }
+(* object('selfpat) ... end
+   object ... end             (self = Ptyp_any)
+ *)
+
+and class_type_field =
+    {
+     pctf_desc: class_type_field_desc;
+     pctf_loc: Location.t;
+     pctf_attributes: attributes; (* ... [@@id1] [@@id2] *)
+    }
+
+and class_type_field_desc =
+  | Pctf_inherit of class_type
+        (* inherit CT *)
+  | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type)
+        (* val x: T *)
+  | Pctf_method  of (label loc * private_flag * virtual_flag * core_type)
+        (* method x: T
+
+           Note: T can be a Ptyp_poly.
+         *)
+  | Pctf_constraint  of (core_type * core_type)
+        (* constraint T1 = T2 *)
+  | Pctf_attribute of attribute
+        (* [@@@id] *)
+  | Pctf_extension of extension
+        (* [%%id] *)
+
+and 'a class_infos =
+    {
+     pci_virt: virtual_flag;
+     pci_params: (core_type * (variance * injectivity)) list;
+     pci_name: string loc;
+     pci_expr: 'a;
+     pci_loc: Location.t;
+     pci_attributes: attributes;  (* ... [@@id1] [@@id2] *)
+    }
+(* class c = ...
+   class ['a1,...,'an] c = ...
+   class virtual c = ...
+
+   Also used for "class type" declaration.
+*)
+
+and class_description = class_type class_infos
+
+and class_type_declaration = class_type class_infos
+
+(* Value expressions for the class language *)
+
+and class_expr =
+    {
+     pcl_desc: class_expr_desc;
+     pcl_loc: Location.t;
+     pcl_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and class_expr_desc =
+  | Pcl_constr of Longident.t loc * core_type list
+        (* c
+           ['a1, ..., 'an] c *)
+  | Pcl_structure of class_structure
+        (* object ... end *)
+  | Pcl_fun of arg_label * expression option * pattern * class_expr
+        (* fun P -> CE                          (Simple, None)
+           fun ~l:P -> CE                       (Labelled l, None)
+           fun ?l:P -> CE                       (Optional l, None)
+           fun ?l:(P = E0) -> CE                (Optional l, Some E0)
+         *)
+  | Pcl_apply of class_expr * (arg_label * expression) list
+        (* CE ~l1:E1 ... ~ln:En
+           li can be empty (non labeled argument) or start with '?'
+           (optional argument).
+
+           Invariant: n > 0
+         *)
+  | Pcl_let of rec_flag * value_binding list * class_expr
+        (* let P1 = E1 and ... and Pn = EN in CE      (flag = Nonrecursive)
+           let rec P1 = E1 and ... and Pn = EN in CE  (flag = Recursive)
+         *)
+  | Pcl_constraint of class_expr * class_type
+        (* (CE : CT) *)
+  | Pcl_extension of extension
+  (* [%id] *)
+  | Pcl_open of open_description * class_expr
+  (* let open M in CE *)
+
+
+and class_structure =
+    {
+     pcstr_self: pattern;
+     pcstr_fields: class_field list;
+    }
+(* object(selfpat) ... end
+   object ... end           (self = Ppat_any)
+ *)
+
+and class_field =
+    {
+     pcf_desc: class_field_desc;
+     pcf_loc: Location.t;
+     pcf_attributes: attributes; (* ... [@@id1] [@@id2] *)
+    }
+
+and class_field_desc =
+  | Pcf_inherit of override_flag * class_expr * string loc option
+        (* inherit CE
+           inherit CE as x
+           inherit! CE
+           inherit! CE as x
+         *)
+  | Pcf_val of (label loc * mutable_flag * class_field_kind)
+        (* val x = E
+           val virtual x: T
+         *)
+  | Pcf_method of (label loc * private_flag * class_field_kind)
+        (* method x = E            (E can be a Pexp_poly)
+           method virtual x: T     (T can be a Ptyp_poly)
+         *)
+  | Pcf_constraint of (core_type * core_type)
+        (* constraint T1 = T2 *)
+  | Pcf_initializer of expression
+        (* initializer E *)
+  | Pcf_attribute of attribute
+        (* [@@@id] *)
+  | Pcf_extension of extension
+        (* [%%id] *)
+
+and class_field_kind =
+  | Cfk_virtual of core_type
+  | Cfk_concrete of override_flag * expression
+
+and class_declaration = class_expr class_infos
+
+(** {1 Module language} *)
+
+(* Type expressions for the module language *)
+
+and module_type =
+    {
+     pmty_desc: module_type_desc;
+     pmty_loc: Location.t;
+     pmty_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and module_type_desc =
+  | Pmty_ident of Longident.t loc
+        (* S *)
+  | Pmty_signature of signature
+        (* sig ... end *)
+  | Pmty_functor of functor_parameter * module_type
+        (* functor(X : MT1) -> MT2 *)
+  | Pmty_with of module_type * with_constraint list
+        (* MT with ... *)
+  | Pmty_typeof of module_expr
+        (* module type of ME *)
+  | Pmty_extension of extension
+        (* [%id] *)
+  | Pmty_alias of Longident.t loc
+        (* (module M) *)
+
+and functor_parameter =
+  | Unit
+        (* () *)
+  | Named of string option loc * module_type
+        (* (X : MT)          Some X, MT
+           (_ : MT)          None, MT *)
+
+and signature = signature_item list
+
+and signature_item =
+    {
+     psig_desc: signature_item_desc;
+     psig_loc: Location.t;
+    }
+
+and signature_item_desc =
+  | Psig_value of value_description
+        (*
+          val x: T
+          external x: T = "s1" ... "sn"
+         *)
+  | Psig_type of rec_flag * type_declaration list
+        (* type t1 = ... and ... and tn  = ... *)
+  | Psig_typesubst of type_declaration list
+        (* type t1 := ... and ... and tn := ...  *)
+  | Psig_typext of type_extension
+        (* type t1 += ... *)
+  | Psig_exception of type_exception
+        (* exception C of T *)
+  | Psig_module of module_declaration
+        (* module X = M
+           module X : MT *)
+  | Psig_modsubst of module_substitution
+        (* module X := M *)
+  | Psig_recmodule of module_declaration list
+        (* module rec X1 : MT1 and ... and Xn : MTn *)
+  | Psig_modtype of module_type_declaration
+        (* module type S = MT
+           module type S *)
+  | Psig_modtypesubst of module_type_declaration
+        (* module type S :=  ...  *)
+  | Psig_open of open_description
+        (* open X *)
+  | Psig_include of include_description
+        (* include MT *)
+  | Psig_class of class_description list
+        (* class c1 : ... and ... and cn : ... *)
+  | Psig_class_type of class_type_declaration list
+        (* class type ct1 = ... and ... and ctn = ... *)
+  | Psig_attribute of attribute
+        (* [@@@id] *)
+  | Psig_extension of extension * attributes
+        (* [%%id] *)
+
+and module_declaration =
+    {
+     pmd_name: string option loc;
+     pmd_type: module_type;
+     pmd_attributes: attributes; (* ... [@@id1] [@@id2] *)
+     pmd_loc: Location.t;
+    }
+(* S : MT *)
+
+and module_substitution =
+    {
+     pms_name: string loc;
+     pms_manifest: Longident.t loc;
+     pms_attributes: attributes; (* ... [@@id1] [@@id2] *)
+     pms_loc: Location.t;
+    }
+
+and module_type_declaration =
+    {
+     pmtd_name: string loc;
+     pmtd_type: module_type option;
+     pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *)
+     pmtd_loc: Location.t;
+    }
+(* S = MT
+   S       (abstract module type declaration, pmtd_type = None)
+*)
+
+and 'a open_infos =
+    {
+     popen_expr: 'a;
+     popen_override: override_flag;
+     popen_loc: Location.t;
+     popen_attributes: attributes;
+    }
+(* open! X - popen_override = Override (silences the 'used identifier
+                              shadowing' warning)
+   open  X - popen_override = Fresh
+ *)
+
+and open_description = Longident.t loc open_infos
+(* open M.N
+   open M(N).O *)
+
+and open_declaration = module_expr open_infos
+(* open M.N
+   open M(N).O
+   open struct ... end *)
+
+and 'a include_infos =
+    {
+     pincl_mod: 'a;
+     pincl_loc: Location.t;
+     pincl_attributes: attributes;
+    }
+
+and include_description = module_type include_infos
+(* include MT *)
+
+and include_declaration = module_expr include_infos
+(* include ME *)
+
+and with_constraint =
+  | Pwith_type of Longident.t loc * type_declaration
+        (* with type X.t = ...
+
+           Note: the last component of the longident must match
+           the name of the type_declaration. *)
+  | Pwith_module of Longident.t loc * Longident.t loc
+        (* with module X.Y = Z *)
+  | Pwith_modtype of Longident.t loc * module_type
+        (* with module type X.Y = Z *)
+  | Pwith_modtypesubst of Longident.t loc * module_type
+        (* with module type X.Y := sig end *)
+  | Pwith_typesubst of Longident.t loc * type_declaration
+        (* with type X.t := ..., same format as [Pwith_type] *)
+  | Pwith_modsubst of Longident.t loc * Longident.t loc
+        (* with module X.Y := Z *)
+
+(* Value expressions for the module language *)
+
+and module_expr =
+    {
+     pmod_desc: module_expr_desc;
+     pmod_loc: Location.t;
+     pmod_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and module_expr_desc =
+  | Pmod_ident of Longident.t loc
+        (* X *)
+  | Pmod_structure of structure
+        (* struct ... end *)
+  | Pmod_functor of functor_parameter * module_expr
+        (* functor(X : MT1) -> ME *)
+  | Pmod_apply of module_expr * module_expr
+        (* ME1(ME2) *)
+  | Pmod_constraint of module_expr * module_type
+        (* (ME : MT) *)
+  | Pmod_unpack of expression
+        (* (val E) *)
+  | Pmod_extension of extension
+        (* [%id] *)
+
+and structure = structure_item list
+
+and structure_item =
+    {
+     pstr_desc: structure_item_desc;
+     pstr_loc: Location.t;
+    }
+
+and structure_item_desc =
+  | Pstr_eval of expression * attributes
+        (* E *)
+  | Pstr_value of rec_flag * value_binding list
+        (* let P1 = E1 and ... and Pn = EN       (flag = Nonrecursive)
+           let rec P1 = E1 and ... and Pn = EN   (flag = Recursive)
+         *)
+  | Pstr_primitive of value_description
+        (*  val x: T
+            external x: T = "s1" ... "sn" *)
+  | Pstr_type of rec_flag * type_declaration list
+        (* type t1 = ... and ... and tn = ... *)
+  | Pstr_typext of type_extension
+        (* type t1 += ... *)
+  | Pstr_exception of type_exception
+        (* exception C of T
+           exception C = M.X *)
+  | Pstr_module of module_binding
+        (* module X = ME *)
+  | Pstr_recmodule of module_binding list
+        (* module rec X1 = ME1 and ... and Xn = MEn *)
+  | Pstr_modtype of module_type_declaration
+        (* module type S = MT *)
+  | Pstr_open of open_declaration
+        (* open X *)
+  | Pstr_class of class_declaration list
+        (* class c1 = ... and ... and cn = ... *)
+  | Pstr_class_type of class_type_declaration list
+        (* class type ct1 = ... and ... and ctn = ... *)
+  | Pstr_include of include_declaration
+        (* include ME *)
+  | Pstr_attribute of attribute
+        (* [@@@id] *)
+  | Pstr_extension of extension * attributes
+        (* [%%id] *)
+
+and value_binding =
+  {
+    pvb_pat: pattern;
+    pvb_expr: expression;
+    pvb_attributes: attributes;
+    pvb_loc: Location.t;
+  }
+
+and module_binding =
+    {
+     pmb_name: string option loc;
+     pmb_expr: module_expr;
+     pmb_attributes: attributes;
+     pmb_loc: Location.t;
+    }
+(* X = ME *)
+
+(** {1 Toplevel} *)
+
+(* Toplevel phrases *)
+
+type toplevel_phrase =
+  | Ptop_def of structure
+  | Ptop_dir of toplevel_directive
+     (* #use, #load ... *)
+
+and toplevel_directive =
+  {
+    pdir_name : string loc;
+    pdir_arg : directive_argument option;
+    pdir_loc : Location.t;
+  }
+
+and directive_argument =
+  {
+    pdira_desc : directive_argument_desc;
+    pdira_loc : Location.t;
+  }
+
+and directive_argument_desc =
+  | Pdir_string of string
+  | Pdir_int of string * char option
+  | Pdir_ident of Longident.t
+  | Pdir_bool of bool
diff --git a/upstream/ocaml_413/parsing/pprintast.ml b/upstream/ocaml_413/parsing/pprintast.ml
new file mode 100644
index 0000000..b8a320c
--- /dev/null
+++ b/upstream/ocaml_413/parsing/pprintast.ml
@@ -0,0 +1,1700 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Thomas Gazagnaire, OCamlPro                       *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*               Hongbo Zhang, University of Pennsylvania                 *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Original Code from Ber-metaocaml, modified for 3.12.0 and fixed *)
+(* Printing code expressions *)
+(* Authors:  Ed Pizzi, Fabrice Le Fessant *)
+(* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *)
+(* TODO more fine-grained precedence pretty-printing *)
+
+open Asttypes
+open Format
+open Location
+open Longident
+open Parsetree
+open Ast_helper
+
+let prefix_symbols  = [ '!'; '?'; '~' ] ;;
+let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/';
+                      '$'; '%'; '#' ]
+
+(* type fixity = Infix| Prefix  *)
+let special_infix_strings =
+  ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ]
+
+let letop s =
+  String.length s > 3
+  && s.[0] = 'l'
+  && s.[1] = 'e'
+  && s.[2] = 't'
+  && List.mem s.[3] infix_symbols
+
+let andop s =
+  String.length s > 3
+  && s.[0] = 'a'
+  && s.[1] = 'n'
+  && s.[2] = 'd'
+  && List.mem s.[3] infix_symbols
+
+(* determines if the string is an infix string.
+   checks backwards, first allowing a renaming postfix ("_102") which
+   may have resulted from Pexp -> Texp -> Pexp translation, then checking
+   if all the characters in the beginning of the string are valid infix
+   characters. *)
+let fixity_of_string  = function
+  | "" -> `Normal
+  | s when List.mem s special_infix_strings -> `Infix s
+  | s when List.mem s.[0] infix_symbols -> `Infix s
+  | s when List.mem s.[0] prefix_symbols -> `Prefix s
+  | s when s.[0] = '.' -> `Mixfix s
+  | s when letop s -> `Letop s
+  | s when andop s -> `Andop s
+  | _ -> `Normal
+
+let view_fixity_of_exp = function
+  | {pexp_desc = Pexp_ident {txt=Lident l;_}; pexp_attributes = []} ->
+      fixity_of_string l
+  | _ -> `Normal
+
+let is_infix  = function `Infix _ -> true | _  -> false
+let is_mixfix = function `Mixfix _ -> true | _ -> false
+let is_kwdop = function `Letop _ | `Andop _ -> true | _ -> false
+
+let first_is c str =
+  str <> "" && str.[0] = c
+let last_is c str =
+  str <> "" && str.[String.length str - 1] = c
+
+let first_is_in cs str =
+  str <> "" && List.mem str.[0] cs
+
+(* which identifiers are in fact operators needing parentheses *)
+let needs_parens txt =
+  let fix = fixity_of_string txt in
+  is_infix fix
+  || is_mixfix fix
+  || is_kwdop fix
+  || first_is_in prefix_symbols txt
+
+(* some infixes need spaces around parens to avoid clashes with comment
+   syntax *)
+let needs_spaces txt =
+  first_is '*' txt || last_is '*' txt
+
+let string_loc ppf x = fprintf ppf "%s" x.txt
+
+(* add parentheses to binders when they are in fact infix or prefix operators *)
+let protect_ident ppf txt =
+  let format : (_, _, _) format =
+    if not (needs_parens txt) then "%s"
+    else if needs_spaces txt then "(@;%s@;)"
+    else "(%s)"
+  in fprintf ppf format txt
+
+let protect_longident ppf print_longident longprefix txt =
+  let format : (_, _, _) format =
+    if not (needs_parens txt) then "%a.%s"
+    else if needs_spaces txt then  "%a.(@;%s@;)"
+    else "%a.(%s)" in
+  fprintf ppf format print_longident longprefix txt
+
+type space_formatter = (unit, Format.formatter, unit) format
+
+let override = function
+  | Override -> "!"
+  | Fresh -> ""
+
+(* variance encoding: need to sync up with the [parser.mly] *)
+let type_variance = function
+  | NoVariance -> ""
+  | Covariant -> "+"
+  | Contravariant -> "-"
+
+let type_injectivity = function
+  | NoInjectivity -> ""
+  | Injective -> "!"
+
+type construct =
+  [ `cons of expression list
+  | `list of expression list
+  | `nil
+  | `normal
+  | `simple of Longident.t
+  | `tuple ]
+
+let view_expr x =
+  match x.pexp_desc with
+  | Pexp_construct ( {txt= Lident "()"; _},_) -> `tuple
+  | Pexp_construct ( {txt= Lident "[]";_},_) -> `nil
+  | Pexp_construct ( {txt= Lident"::";_},Some _) ->
+      let rec loop exp acc = match exp with
+          | {pexp_desc=Pexp_construct ({txt=Lident "[]";_},_);
+             pexp_attributes = []} ->
+              (List.rev acc,true)
+          | {pexp_desc=
+             Pexp_construct ({txt=Lident "::";_},
+                             Some ({pexp_desc= Pexp_tuple([e1;e2]);
+                                    pexp_attributes = []}));
+             pexp_attributes = []}
+            ->
+              loop e2 (e1::acc)
+          | e -> (List.rev (e::acc),false) in
+      let (ls,b) = loop x []  in
+      if b then
+        `list ls
+      else `cons ls
+  | Pexp_construct (x,None) -> `simple (x.txt)
+  | _ -> `normal
+
+let is_simple_construct :construct -> bool = function
+  | `nil | `tuple | `list _ | `simple _  -> true
+  | `cons _ | `normal -> false
+
+let pp = fprintf
+
+type ctxt = {
+  pipe : bool;
+  semi : bool;
+  ifthenelse : bool;
+}
+
+let reset_ctxt = { pipe=false; semi=false; ifthenelse=false }
+let under_pipe ctxt = { ctxt with pipe=true }
+let under_semi ctxt = { ctxt with semi=true }
+let under_ifthenelse ctxt = { ctxt with ifthenelse=true }
+(*
+let reset_semi ctxt = { ctxt with semi=false }
+let reset_ifthenelse ctxt = { ctxt with ifthenelse=false }
+let reset_pipe ctxt = { ctxt with pipe=false }
+*)
+
+let list : 'a . ?sep:space_formatter -> ?first:space_formatter ->
+  ?last:space_formatter -> (Format.formatter -> 'a -> unit) ->
+  Format.formatter -> 'a list -> unit
+  = fun ?sep ?first ?last fu f xs ->
+    let first = match first with Some x -> x |None -> ("": _ format6)
+    and last = match last with Some x -> x |None -> ("": _ format6)
+    and sep = match sep with Some x -> x |None -> ("@ ": _ format6) in
+    let aux f = function
+      | [] -> ()
+      | [x] -> fu f x
+      | xs ->
+          let rec loop  f = function
+            | [x] -> fu f x
+            | x::xs ->  fu f x; pp f sep; loop f xs;
+            | _ -> assert false in begin
+            pp f first; loop f xs; pp f last;
+          end in
+    aux f xs
+
+let option : 'a. ?first:space_formatter -> ?last:space_formatter ->
+  (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit
+  = fun  ?first  ?last fu f a ->
+    let first = match first with Some x -> x | None -> ("": _ format6)
+    and last = match last with Some x -> x | None -> ("": _ format6) in
+    match a with
+    | None -> ()
+    | Some x -> pp f first; fu f x; pp f last
+
+let paren: 'a . ?first:space_formatter -> ?last:space_formatter ->
+  bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit
+  = fun  ?(first=("": _ format6)) ?(last=("": _ format6)) b fu f x ->
+    if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")")
+    else fu f x
+
+let rec longident f = function
+  | Lident s -> protect_ident f s
+  | Ldot(y,s) -> protect_longident f longident y s
+  | Lapply (y,s) ->
+      pp f "%a(%a)" longident y longident s
+
+let longident_loc f x = pp f "%a" longident x.txt
+
+let constant f = function
+  | Pconst_char i ->
+      pp f "%C"  i
+  | Pconst_string (i, _, None) ->
+      pp f "%S" i
+  | Pconst_string (i, _, Some delim) ->
+      pp f "{%s|%s|%s}" delim i delim
+  | Pconst_integer (i, None) ->
+      paren (first_is '-' i) (fun f -> pp f "%s") f i
+  | Pconst_integer (i, Some m) ->
+      paren (first_is '-' i) (fun f (i, m) -> pp f "%s%c" i m) f (i,m)
+  | Pconst_float (i, None) ->
+      paren (first_is '-' i) (fun f -> pp f "%s") f i
+  | Pconst_float (i, Some m) ->
+      paren (first_is '-' i) (fun f (i,m) -> pp f "%s%c" i m) f (i,m)
+
+(* trailing space*)
+let mutable_flag f = function
+  | Immutable -> ()
+  | Mutable -> pp f "mutable@;"
+let virtual_flag f  = function
+  | Concrete -> ()
+  | Virtual -> pp f "virtual@;"
+
+(* trailing space added *)
+let rec_flag f rf =
+  match rf with
+  | Nonrecursive -> ()
+  | Recursive -> pp f "rec "
+let nonrec_flag f rf =
+  match rf with
+  | Nonrecursive -> pp f "nonrec "
+  | Recursive -> ()
+let direction_flag f = function
+  | Upto -> pp f "to@ "
+  | Downto -> pp f "downto@ "
+let private_flag f = function
+  | Public -> ()
+  | Private -> pp f "private@ "
+
+let iter_loc f ctxt {txt; loc = _} = f ctxt txt
+
+let constant_string f s = pp f "%S" s
+
+let tyvar ppf s =
+  if String.length s >= 2 && s.[1] = '\'' then
+    (* without the space, this would be parsed as
+       a character literal *)
+    Format.fprintf ppf "' %s" s
+  else
+    Format.fprintf ppf "'%s" s
+
+let tyvar_loc f str = tyvar f str.txt
+let string_quot f x = pp f "`%s" x
+
+(* c ['a,'b] *)
+let rec class_params_def ctxt f =  function
+  | [] -> ()
+  | l ->
+      pp f "[%a] " (* space *)
+        (list (type_param ctxt) ~sep:",") l
+
+and type_with_label ctxt f (label, c) =
+  match label with
+  | Nolabel    -> core_type1 ctxt f c (* otherwise parenthesize *)
+  | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c
+  | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c
+
+and core_type ctxt f x =
+  if x.ptyp_attributes <> [] then begin
+    pp f "((%a)%a)" (core_type ctxt) {x with ptyp_attributes=[]}
+      (attributes ctxt) x.ptyp_attributes
+  end
+  else match x.ptyp_desc with
+    | Ptyp_arrow (l, ct1, ct2) ->
+        pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
+          (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2
+    | Ptyp_alias (ct, s) ->
+        pp f "@[<2>%a@;as@;%a@]" (core_type1 ctxt) ct tyvar s
+    | Ptyp_poly ([], ct) ->
+        core_type ctxt f ct
+    | Ptyp_poly (sl, ct) ->
+        pp f "@[<2>%a%a@]"
+          (fun f l ->
+             pp f "%a"
+               (fun f l -> match l with
+                  | [] -> ()
+                  | _ ->
+                      pp f "%a@;.@;"
+                        (list tyvar_loc ~sep:"@;")  l)
+               l)
+          sl (core_type ctxt) ct
+    | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x
+
+and core_type1 ctxt f x =
+  if x.ptyp_attributes <> [] then core_type ctxt f x
+  else match x.ptyp_desc with
+    | Ptyp_any -> pp f "_";
+    | Ptyp_var s -> tyvar f  s;
+    | Ptyp_tuple l ->  pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l
+    | Ptyp_constr (li, l) ->
+        pp f (* "%a%a@;" *) "%a%a"
+          (fun f l -> match l with
+             |[] -> ()
+             |[x]-> pp f "%a@;" (core_type1 ctxt)  x
+             | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l)
+          l longident_loc li
+    | Ptyp_variant (l, closed, low) ->
+        let first_is_inherit = match l with
+          | {Parsetree.prf_desc = Rinherit _}::_ -> true
+          | _ -> false in
+        let type_variant_helper f x =
+          match x.prf_desc with
+          | Rtag (l, _, ctl) ->
+              pp f "@[<2>%a%a@;%a@]" (iter_loc string_quot) l
+                (fun f l -> match l with
+                   |[] -> ()
+                   | _ -> pp f "@;of@;%a"
+                            (list (core_type ctxt) ~sep:"&")  ctl) ctl
+                (attributes ctxt) x.prf_attributes
+          | Rinherit ct -> core_type ctxt f ct in
+        pp f "@[<2>[%a%a]@]"
+          (fun f l ->
+             match l, closed with
+             | [], Closed -> ()
+             | [], Open -> pp f ">" (* Cf #7200: print [>] correctly *)
+             | _ ->
+                 pp f "%s@;%a"
+                   (match (closed,low) with
+                    | (Closed,None) -> if first_is_inherit then " |" else ""
+                    | (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*)
+                    | (Open,_) -> ">")
+                   (list type_variant_helper ~sep:"@;<1 -2>| ") l) l
+          (fun f low -> match low with
+             |Some [] |None -> ()
+             |Some xs ->
+                 pp f ">@ %a"
+                   (list string_quot) xs) low
+    | Ptyp_object (l, o) ->
+        let core_field_type f x = match x.pof_desc with
+          | Otag (l, ct) ->
+            (* Cf #7200 *)
+            pp f "@[<hov2>%s: %a@ %a@ @]" l.txt
+              (core_type ctxt) ct (attributes ctxt) x.pof_attributes
+          | Oinherit ct ->
+            pp f "@[<hov2>%a@ @]" (core_type ctxt) ct
+        in
+        let field_var f = function
+          | Asttypes.Closed -> ()
+          | Asttypes.Open ->
+              match l with
+              | [] -> pp f ".."
+              | _ -> pp f " ;.."
+        in
+        pp f "@[<hov2><@ %a%a@ > @]"
+          (list core_field_type ~sep:";") l
+          field_var o (* Cf #7200 *)
+    | Ptyp_class (li, l) ->   (*FIXME*)
+        pp f "@[<hov2>%a#%a@]"
+          (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") l
+          longident_loc li
+    | Ptyp_package (lid, cstrs) ->
+        let aux f (s, ct) =
+          pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct  in
+        (match cstrs with
+         |[] -> pp f "@[<hov2>(module@ %a)@]" longident_loc lid
+         |_ ->
+             pp f "@[<hov2>(module@ %a@ with@ %a)@]" longident_loc lid
+               (list aux  ~sep:"@ and@ ")  cstrs)
+    | Ptyp_extension e -> extension ctxt f e
+    | _ -> paren true (core_type ctxt) f x
+
+(********************pattern********************)
+(* be cautious when use [pattern], [pattern1] is preferred *)
+and pattern ctxt f x =
+  if x.ppat_attributes <> [] then begin
+    pp f "((%a)%a)" (pattern ctxt) {x with ppat_attributes=[]}
+      (attributes ctxt) x.ppat_attributes
+  end
+  else match x.ppat_desc with
+    | Ppat_alias (p, s) ->
+        pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt
+    | _ -> pattern_or ctxt f x
+
+and pattern_or ctxt f x =
+  let rec left_associative x acc = match x with
+    | {ppat_desc=Ppat_or (p1,p2); ppat_attributes = []} ->
+        left_associative p1 (p2 :: acc)
+    | x -> x :: acc
+  in
+  match left_associative x [] with
+  | [] -> assert false
+  | [x] -> pattern1 ctxt f x
+  | orpats ->
+      pp f "@[<hov0>%a@]" (list ~sep:"@ | " (pattern1 ctxt)) orpats
+
+and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit =
+  let rec pattern_list_helper f = function
+    | {ppat_desc =
+         Ppat_construct
+           ({ txt = Lident("::") ;_},
+            Some ([], {ppat_desc = Ppat_tuple([pat1; pat2]);_}));
+       ppat_attributes = []}
+
+      ->
+        pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*)
+    | p -> pattern1 ctxt f p
+  in
+  if x.ppat_attributes <> [] then pattern ctxt f x
+  else match x.ppat_desc with
+    | Ppat_variant (l, Some p) ->
+        pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) p
+    | Ppat_construct (({txt=Lident("()"|"[]");_}), _) ->
+        simple_pattern ctxt f x
+    | Ppat_construct (({txt;_} as li), po) ->
+        (* FIXME The third field always false *)
+        if txt = Lident "::" then
+          pp f "%a" pattern_list_helper x
+        else
+          (match po with
+           | Some ([], x) ->
+               pp f "%a@;%a"  longident_loc li (simple_pattern ctxt) x
+           | Some (vl, x) ->
+               pp f "%a@ (type %a)@;%a" longident_loc li
+                 (list ~sep:"@ " string_loc) vl
+                 (simple_pattern ctxt) x
+           | None -> pp f "%a" longident_loc li)
+    | _ -> simple_pattern ctxt f x
+
+and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit =
+  if x.ppat_attributes <> [] then pattern ctxt f x
+  else match x.ppat_desc with
+    | Ppat_construct (({txt=Lident ("()"|"[]" as x);_}), None) ->
+        pp f  "%s" x
+    | Ppat_any -> pp f "_";
+    | Ppat_var ({txt = txt;_}) -> protect_ident f txt
+    | Ppat_array l ->
+        pp f "@[<2>[|%a|]@]"  (list (pattern1 ctxt) ~sep:";") l
+    | Ppat_unpack { txt = None } ->
+        pp f "(module@ _)@ "
+    | Ppat_unpack { txt = Some s } ->
+        pp f "(module@ %s)@ " s
+    | Ppat_type li ->
+        pp f "#%a" longident_loc li
+    | Ppat_record (l, closed) ->
+        let longident_x_pattern f (li, p) =
+          match (li,p) with
+          | ({txt=Lident s;_ },
+             {ppat_desc=Ppat_var {txt;_};
+              ppat_attributes=[]; _})
+            when s = txt ->
+              pp f "@[<2>%a@]"  longident_loc li
+          | _ ->
+              pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p
+        in
+        begin match closed with
+        | Closed ->
+            pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l
+        | _ ->
+            pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l
+        end
+    | Ppat_tuple l ->
+        pp f "@[<1>(%a)@]" (list  ~sep:",@;" (pattern1 ctxt))  l (* level1*)
+    | Ppat_constant (c) -> pp f "%a" constant c
+    | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2
+    | Ppat_variant (l,None) ->  pp f "`%s" l
+    | Ppat_constraint (p, ct) ->
+        pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct
+    | Ppat_lazy p ->
+        pp f "@[<2>(lazy@;%a)@]" (simple_pattern ctxt) p
+    | Ppat_exception p ->
+        pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p
+    | Ppat_extension e -> extension ctxt f e
+    | Ppat_open (lid, p) ->
+        let with_paren =
+        match p.ppat_desc with
+        | Ppat_array _ | Ppat_record _
+        | Ppat_construct (({txt=Lident ("()"|"[]");_}), None) -> false
+        | _ -> true in
+        pp f "@[<2>%a.%a @]" longident_loc lid
+          (paren with_paren @@ pattern1 ctxt) p
+    | _ -> paren true (pattern ctxt) f x
+
+and label_exp ctxt f (l,opt,p) =
+  match l with
+  | Nolabel ->
+      (* single case pattern parens needed here *)
+      pp f "%a@ " (simple_pattern ctxt) p
+  | Optional rest ->
+      begin match p with
+      | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []}
+        when txt = rest ->
+          (match opt with
+           | Some o -> pp f "?(%s=@;%a)@;" rest  (expression ctxt) o
+           | None -> pp f "?%s@ " rest)
+      | _ ->
+          (match opt with
+           | Some o ->
+               pp f "?%s:(%a=@;%a)@;"
+                 rest (pattern1 ctxt) p (expression ctxt) o
+           | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p)
+      end
+  | Labelled l -> match p with
+    | {ppat_desc  = Ppat_var {txt;_}; ppat_attributes = []}
+      when txt = l ->
+        pp f "~%s@;" l
+    | _ ->  pp f "~%s:%a@;" l (simple_pattern ctxt) p
+
+and sugar_expr ctxt f e =
+  if e.pexp_attributes <> [] then false
+  else match e.pexp_desc with
+  | Pexp_apply ({ pexp_desc = Pexp_ident {txt = id; _};
+                  pexp_attributes=[]; _}, args)
+    when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin
+      let print_indexop a path_prefix assign left sep right print_index indices
+          rem_args =
+        let print_path ppf = function
+          | None -> ()
+          | Some m -> pp ppf ".%a" longident m in
+        match assign, rem_args with
+            | false, [] ->
+              pp f "@[%a%a%s%a%s@]"
+                (simple_expr ctxt) a print_path path_prefix
+                left (list ~sep print_index) indices right; true
+            | true, [v] ->
+              pp f "@[%a%a%s%a%s@ <-@;<1 2>%a@]"
+                (simple_expr ctxt) a print_path path_prefix
+                left (list ~sep print_index) indices right
+                (simple_expr ctxt) v; true
+            | _ -> false in
+      match id, List.map snd args with
+      | Lident "!", [e] ->
+        pp f "@[<hov>!%a@]" (simple_expr ctxt) e; true
+      | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin
+          let assign = func = "set" in
+          let print = print_indexop a None assign in
+          match path, other_args with
+          | Lident "Array", i :: rest ->
+            print ".(" "" ")" (expression ctxt) [i] rest
+          | Lident "String", i :: rest ->
+            print ".[" "" "]" (expression ctxt) [i] rest
+          | Ldot (Lident "Bigarray", "Array1"), i1 :: rest ->
+            print ".{" "," "}" (simple_expr ctxt) [i1] rest
+          | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest ->
+            print ".{" "," "}" (simple_expr ctxt) [i1; i2] rest
+          | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest ->
+            print ".{" "," "}" (simple_expr ctxt) [i1; i2; i3] rest
+          | Ldot (Lident "Bigarray", "Genarray"),
+            {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest ->
+              print ".{" "," "}" (simple_expr ctxt) indexes rest
+          | _ -> false
+        end
+      | (Lident s | Ldot(_,s)) , a :: i :: rest
+        when first_is '.' s ->
+          (* extract operator:
+             assignment operators end with [right_bracket ^ "<-"],
+             access operators end with [right_bracket] directly
+          *)
+          let multi_indices = String.contains s ';' in
+          let i =
+              match i.pexp_desc with
+                | Pexp_array l when multi_indices -> l
+                | _ -> [ i ] in
+          let assign = last_is '-' s in
+          let kind =
+            (* extract the right end bracket *)
+            let n = String.length s in
+            if assign then s.[n - 3] else s.[n - 1] in
+          let left, right = match kind with
+            | ')' -> '(', ")"
+            | ']' -> '[', "]"
+            | '}' -> '{', "}"
+            | _ -> assert false in
+          let path_prefix = match id with
+            | Ldot(m,_) -> Some m
+            | _ -> None in
+          let left = String.sub s 0 (1+String.index s left) in
+          print_indexop a path_prefix assign left ";" right
+            (if multi_indices then expression ctxt else simple_expr ctxt)
+            i rest
+      | _ -> false
+    end
+  | _ -> false
+
+and expression ctxt f x =
+  if x.pexp_attributes <> [] then
+    pp f "((%a)@,%a)" (expression ctxt) {x with pexp_attributes=[]}
+      (attributes ctxt) x.pexp_attributes
+  else match x.pexp_desc with
+    | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _
+    | Pexp_newtype _
+      when ctxt.pipe || ctxt.semi ->
+        paren true (expression reset_ctxt) f x
+    | Pexp_ifthenelse _ | Pexp_sequence _ when ctxt.ifthenelse ->
+        paren true (expression reset_ctxt) f x
+    | Pexp_let _ | Pexp_letmodule _ | Pexp_open _
+      | Pexp_letexception _ | Pexp_letop _
+        when ctxt.semi ->
+        paren true (expression reset_ctxt) f x
+    | Pexp_fun (l, e0, p, e) ->
+        pp f "@[<2>fun@;%a->@;%a@]"
+          (label_exp ctxt) (l, e0, p)
+          (expression ctxt) e
+    | Pexp_newtype (lid, e) ->
+        pp f "@[<2>fun@;(type@;%s)@;->@;%a@]" lid.txt
+          (expression ctxt) e
+    | Pexp_function l ->
+        pp f "@[<hv>function%a@]" (case_list ctxt) l
+    | Pexp_match (e, l) ->
+        pp f "@[<hv0>@[<hv0>@[<2>match %a@]@ with@]%a@]"
+          (expression reset_ctxt) e (case_list ctxt) l
+
+    | Pexp_try (e, l) ->
+        pp f "@[<0>@[<hv2>try@ %a@]@ @[<0>with%a@]@]"
+             (* "try@;@[<2>%a@]@\nwith@\n%a"*)
+          (expression reset_ctxt) e  (case_list ctxt) l
+    | Pexp_let (rf, l, e) ->
+        (* pp f "@[<2>let %a%a in@;<1 -2>%a@]"
+           (*no indentation here, a new line*) *)
+        (*   rec_flag rf *)
+        pp f "@[<2>%a in@;<1 -2>%a@]"
+          (bindings reset_ctxt) (rf,l)
+          (expression ctxt) e
+    | Pexp_apply (e, l) ->
+        begin if not (sugar_expr ctxt f x) then
+            match view_fixity_of_exp e with
+            | `Infix s ->
+                begin match l with
+                | [ (Nolabel, _) as arg1; (Nolabel, _) as arg2 ] ->
+                    (* FIXME associativity label_x_expression_param *)
+                    pp f "@[<2>%a@;%s@;%a@]"
+                      (label_x_expression_param reset_ctxt) arg1 s
+                      (label_x_expression_param ctxt) arg2
+                | _ ->
+                    pp f "@[<2>%a %a@]"
+                      (simple_expr ctxt) e
+                      (list (label_x_expression_param ctxt)) l
+                end
+            | `Prefix s ->
+                let s =
+                  if List.mem s ["~+";"~-";"~+.";"~-."] &&
+                   (match l with
+                    (* See #7200: avoid turning (~- 1) into (- 1) which is
+                       parsed as an int literal *)
+                    |[(_,{pexp_desc=Pexp_constant _})] -> false
+                    | _ -> true)
+                  then String.sub s 1 (String.length s -1)
+                  else s in
+                begin match l with
+                | [(Nolabel, x)] ->
+                  pp f "@[<2>%s@;%a@]" s (simple_expr ctxt) x
+                | _   ->
+                  pp f "@[<2>%a %a@]" (simple_expr ctxt) e
+                    (list (label_x_expression_param ctxt)) l
+                end
+            | _ ->
+                pp f "@[<hov2>%a@]" begin fun f (e,l) ->
+                  pp f "%a@ %a" (expression2 ctxt) e
+                    (list (label_x_expression_param reset_ctxt))  l
+                    (* reset here only because [function,match,try,sequence]
+                       are lower priority *)
+                end (e,l)
+        end
+
+    | Pexp_construct (li, Some eo)
+      when not (is_simple_construct (view_expr x))-> (* Not efficient FIXME*)
+        (match view_expr x with
+         | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;"
+         | `normal ->
+             pp f "@[<2>%a@;%a@]" longident_loc li
+               (simple_expr ctxt) eo
+         | _ -> assert false)
+    | Pexp_setfield (e1, li, e2) ->
+        pp f "@[<2>%a.%a@ <-@ %a@]"
+          (simple_expr ctxt) e1 longident_loc li (simple_expr ctxt) e2
+    | Pexp_ifthenelse (e1, e2, eo) ->
+        (* @;@[<2>else@ %a@]@] *)
+        let fmt:(_,_,_)format ="@[<hv0>@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" in
+        let expression_under_ifthenelse = expression (under_ifthenelse ctxt) in
+        pp f fmt expression_under_ifthenelse e1 expression_under_ifthenelse e2
+          (fun f eo -> match eo with
+             | Some x ->
+                 pp f "@;@[<2>else@;%a@]" (expression (under_semi ctxt)) x
+             | None -> () (* pp f "()" *)) eo
+    | Pexp_sequence _ ->
+        let rec sequence_helper acc = function
+          | {pexp_desc=Pexp_sequence(e1,e2); pexp_attributes = []} ->
+              sequence_helper (e1::acc) e2
+          | v -> List.rev (v::acc) in
+        let lst = sequence_helper [] x in
+        pp f "@[<hv>%a@]"
+          (list (expression (under_semi ctxt)) ~sep:";@;") lst
+    | Pexp_new (li) ->
+        pp f "@[<hov2>new@ %a@]" longident_loc li;
+    | Pexp_setinstvar (s, e) ->
+        pp f "@[<hov2>%s@ <-@ %a@]" s.txt (expression ctxt) e
+    | Pexp_override l -> (* FIXME *)
+        let string_x_expression f (s, e) =
+          pp f "@[<hov2>%s@ =@ %a@]" s.txt (expression ctxt) e in
+        pp f "@[<hov2>{<%a>}@]"
+          (list string_x_expression  ~sep:";"  )  l;
+    | Pexp_letmodule (s, me, e) ->
+        pp f "@[<hov2>let@ module@ %s@ =@ %a@ in@ %a@]"
+          (Option.value s.txt ~default:"_")
+          (module_expr reset_ctxt) me (expression ctxt) e
+    | Pexp_letexception (cd, e) ->
+        pp f "@[<hov2>let@ exception@ %a@ in@ %a@]"
+          (extension_constructor ctxt) cd
+          (expression ctxt) e
+    | Pexp_assert e ->
+        pp f "@[<hov2>assert@ %a@]" (simple_expr ctxt) e
+    | Pexp_lazy (e) ->
+        pp f "@[<hov2>lazy@ %a@]" (simple_expr ctxt) e
+    (* Pexp_poly: impossible but we should print it anyway, rather than
+       assert false *)
+    | Pexp_poly (e, None) ->
+        pp f "@[<hov2>!poly!@ %a@]" (simple_expr ctxt) e
+    | Pexp_poly (e, Some ct) ->
+        pp f "@[<hov2>(!poly!@ %a@ : %a)@]"
+          (simple_expr ctxt) e (core_type ctxt) ct
+    | Pexp_open (o, e) ->
+        pp f "@[<2>let open%s %a in@;%a@]"
+          (override o.popen_override) (module_expr ctxt) o.popen_expr
+          (expression ctxt) e
+    | Pexp_variant (l,Some eo) ->
+        pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo
+    | Pexp_letop {let_; ands; body} ->
+        pp f "@[<2>@[<v>%a@,%a@] in@;<1 -2>%a@]"
+          (binding_op ctxt) let_
+          (list ~sep:"@," (binding_op ctxt)) ands
+          (expression ctxt) body
+    | Pexp_extension e -> extension ctxt f e
+    | Pexp_unreachable -> pp f "."
+    | _ -> expression1 ctxt f x
+
+and expression1 ctxt f x =
+  if x.pexp_attributes <> [] then expression ctxt f x
+  else match x.pexp_desc with
+    | Pexp_object cs -> pp f "%a" (class_structure ctxt) cs
+    | _ -> expression2 ctxt f x
+(* used in [Pexp_apply] *)
+
+and expression2 ctxt f x =
+  if x.pexp_attributes <> [] then expression ctxt f x
+  else match x.pexp_desc with
+    | Pexp_field (e, li) ->
+        pp f "@[<hov2>%a.%a@]" (simple_expr ctxt) e longident_loc li
+    | Pexp_send (e, s) -> pp f "@[<hov2>%a#%s@]" (simple_expr ctxt) e s.txt
+
+    | _ -> simple_expr ctxt f x
+
+and simple_expr ctxt f x =
+  if x.pexp_attributes <> [] then expression ctxt f x
+  else match x.pexp_desc with
+    | Pexp_construct _  when is_simple_construct (view_expr x) ->
+        (match view_expr x with
+         | `nil -> pp f "[]"
+         | `tuple -> pp f "()"
+         | `list xs ->
+             pp f "@[<hv0>[%a]@]"
+               (list (expression (under_semi ctxt)) ~sep:";@;") xs
+         | `simple x -> longident f x
+         | _ -> assert false)
+    | Pexp_ident li ->
+        longident_loc f li
+    (* (match view_fixity_of_exp x with *)
+    (* |`Normal -> longident_loc f li *)
+    (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *)
+    | Pexp_constant c -> constant f c;
+    | Pexp_pack me ->
+        pp f "(module@;%a)" (module_expr ctxt) me
+    | Pexp_tuple l ->
+        pp f "@[<hov2>(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l
+    | Pexp_constraint (e, ct) ->
+        pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct
+    | Pexp_coerce (e, cto1, ct) ->
+        pp f "(%a%a :> %a)" (expression ctxt) e
+          (option (core_type ctxt) ~first:" : " ~last:" ") cto1 (* no sep hint*)
+          (core_type ctxt) ct
+    | Pexp_variant (l, None) -> pp f "`%s" l
+    | Pexp_record (l, eo) ->
+        let longident_x_expression f ( li, e) =
+          match e with
+          |  {pexp_desc=Pexp_ident {txt;_};
+              pexp_attributes=[]; _} when li.txt = txt ->
+              pp f "@[<hov2>%a@]" longident_loc li
+          | _ ->
+              pp f "@[<hov2>%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e
+        in
+        pp f "@[<hv0>@[<hv2>{@;%a%a@]@;}@]"(* "@[<hov2>{%a%a}@]" *)
+          (option ~last:" with@;" (simple_expr ctxt)) eo
+          (list longident_x_expression ~sep:";@;") l
+    | Pexp_array (l) ->
+        pp f "@[<0>@[<2>[|%a|]@]@]"
+          (list (simple_expr (under_semi ctxt)) ~sep:";") l
+    | Pexp_while (e1, e2) ->
+        let fmt : (_,_,_) format = "@[<2>while@;%a@;do@;%a@;done@]" in
+        pp f fmt (expression ctxt) e1 (expression ctxt) e2
+    | Pexp_for (s, e1, e2, df, e3) ->
+        let fmt:(_,_,_)format =
+          "@[<hv0>@[<hv2>@[<2>for %a =@;%a@;%a%a@;do@]@;%a@]@;done@]" in
+        let expression = expression ctxt in
+        pp f fmt (pattern ctxt) s expression e1 direction_flag
+          df expression e2 expression e3
+    | _ ->  paren true (expression ctxt) f x
+
+and attributes ctxt f l =
+  List.iter (attribute ctxt f) l
+
+and item_attributes ctxt f l =
+  List.iter (item_attribute ctxt f) l
+
+and attribute ctxt f a =
+  pp f "@[<2>[@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload
+
+and item_attribute ctxt f a =
+  pp f "@[<2>[@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload
+
+and floating_attribute ctxt f a =
+  pp f "@[<2>[@@@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload
+
+and value_description ctxt f x =
+  (* note: value_description has an attribute field,
+           but they're already printed by the callers this method *)
+  pp f "@[<hov2>%a%a@]" (core_type ctxt) x.pval_type
+    (fun f x ->
+       if x.pval_prim <> []
+       then pp f "@ =@ %a" (list constant_string) x.pval_prim
+    ) x
+
+and extension ctxt f (s, e) =
+  pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e
+
+and item_extension ctxt f (s, e) =
+  pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e
+
+and exception_declaration ctxt f x =
+  pp f "@[<hov2>exception@ %a@]%a"
+    (extension_constructor ctxt) x.ptyexn_constructor
+    (item_attributes ctxt) x.ptyexn_attributes
+
+and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} =
+  let class_type_field f x =
+    match x.pctf_desc with
+    | Pctf_inherit (ct) ->
+        pp f "@[<2>inherit@ %a@]%a" (class_type ctxt) ct
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_val (s, mf, vf, ct) ->
+        pp f "@[<2>val @ %a%a%s@ :@ %a@]%a"
+          mutable_flag mf virtual_flag vf s.txt (core_type ctxt) ct
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_method (s, pf, vf, ct) ->
+        pp f "@[<2>method %a %a%s :@;%a@]%a"
+          private_flag pf virtual_flag vf s.txt (core_type ctxt) ct
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_constraint (ct1, ct2) ->
+        pp f "@[<2>constraint@ %a@ =@ %a@]%a"
+          (core_type ctxt) ct1 (core_type ctxt) ct2
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_attribute a -> floating_attribute ctxt f a
+    | Pctf_extension e ->
+        item_extension ctxt f e;
+        item_attributes ctxt f x.pctf_attributes
+  in
+  pp f "@[<hv0>@[<hv2>object@[<1>%a@]@ %a@]@ end@]"
+    (fun f -> function
+         {ptyp_desc=Ptyp_any; ptyp_attributes=[]; _} -> ()
+       | ct -> pp f " (%a)" (core_type ctxt) ct) ct
+    (list class_type_field ~sep:"@;") l
+
+(* call [class_signature] called by [class_signature] *)
+and class_type ctxt f x =
+  match x.pcty_desc with
+  | Pcty_signature cs ->
+      class_signature ctxt f cs;
+      attributes ctxt f x.pcty_attributes
+  | Pcty_constr (li, l) ->
+      pp f "%a%a%a"
+        (fun f l -> match l with
+           | [] -> ()
+           | _  -> pp f "[%a]@ " (list (core_type ctxt) ~sep:"," ) l) l
+        longident_loc li
+        (attributes ctxt) x.pcty_attributes
+  | Pcty_arrow (l, co, cl) ->
+      pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
+        (type_with_label ctxt) (l,co)
+        (class_type ctxt) cl
+  | Pcty_extension e ->
+      extension ctxt f e;
+      attributes ctxt f x.pcty_attributes
+  | Pcty_open (o, e) ->
+      pp f "@[<2>let open%s %a in@;%a@]"
+        (override o.popen_override) longident_loc o.popen_expr
+        (class_type ctxt) e
+
+(* [class type a = object end] *)
+and class_type_declaration_list ctxt f l =
+  let class_type_declaration kwd f x =
+    let { pci_params=ls; pci_name={ txt; _ }; _ } = x in
+    pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd
+      virtual_flag x.pci_virt
+      (class_params_def ctxt) ls txt
+      (class_type ctxt) x.pci_expr
+      (item_attributes ctxt) x.pci_attributes
+  in
+  match l with
+  | [] -> ()
+  | [x] -> class_type_declaration "class type" f x
+  | x :: xs ->
+      pp f "@[<v>%a@,%a@]"
+        (class_type_declaration "class type") x
+        (list ~sep:"@," (class_type_declaration "and")) xs
+
+and class_field ctxt f x =
+  match x.pcf_desc with
+  | Pcf_inherit (ovf, ce, so) ->
+      pp f "@[<2>inherit@ %s@ %a%a@]%a" (override ovf)
+        (class_expr ctxt) ce
+        (fun f so -> match so with
+           | None -> ();
+           | Some (s) -> pp f "@ as %s" s.txt ) so
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_val (s, mf, Cfk_concrete (ovf, e)) ->
+      pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf)
+        mutable_flag mf s.txt
+        (expression ctxt) e
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_method (s, pf, Cfk_virtual ct) ->
+      pp f "@[<2>method virtual %a %s :@;%a@]%a"
+        private_flag pf s.txt
+        (core_type ctxt) ct
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_val (s, mf, Cfk_virtual ct) ->
+      pp f "@[<2>val virtual %a%s :@ %a@]%a"
+        mutable_flag mf s.txt
+        (core_type ctxt) ct
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_method (s, pf, Cfk_concrete (ovf, e)) ->
+      let bind e =
+        binding ctxt f
+          {pvb_pat=
+             {ppat_desc=Ppat_var s;
+              ppat_loc=Location.none;
+              ppat_loc_stack=[];
+              ppat_attributes=[]};
+           pvb_expr=e;
+           pvb_attributes=[];
+           pvb_loc=Location.none;
+          }
+      in
+      pp f "@[<2>method%s %a%a@]%a"
+        (override ovf)
+        private_flag pf
+        (fun f -> function
+           | {pexp_desc=Pexp_poly (e, Some ct); pexp_attributes=[]; _} ->
+               pp f "%s :@;%a=@;%a"
+                 s.txt (core_type ctxt) ct (expression ctxt) e
+           | {pexp_desc=Pexp_poly (e, None); pexp_attributes=[]; _} ->
+               bind e
+           | _ -> bind e) e
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_constraint (ct1, ct2) ->
+      pp f "@[<2>constraint %a =@;%a@]%a"
+        (core_type ctxt) ct1
+        (core_type ctxt) ct2
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_initializer (e) ->
+      pp f "@[<2>initializer@ %a@]%a"
+        (expression ctxt) e
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_attribute a -> floating_attribute ctxt f a
+  | Pcf_extension e ->
+      item_extension ctxt f e;
+      item_attributes ctxt f x.pcf_attributes
+
+and class_structure ctxt f { pcstr_self = p; pcstr_fields =  l } =
+  pp f "@[<hv0>@[<hv2>object%a@;%a@]@;end@]"
+    (fun f p -> match p.ppat_desc with
+       | Ppat_any -> ()
+       | Ppat_constraint _ -> pp f " %a" (pattern ctxt) p
+       | _ -> pp f " (%a)" (pattern ctxt) p) p
+    (list (class_field ctxt)) l
+
+and class_expr ctxt f x =
+  if x.pcl_attributes <> [] then begin
+    pp f "((%a)%a)" (class_expr ctxt) {x with pcl_attributes=[]}
+      (attributes ctxt) x.pcl_attributes
+  end else
+    match x.pcl_desc with
+    | Pcl_structure (cs) -> class_structure ctxt f cs
+    | Pcl_fun (l, eo, p, e) ->
+        pp f "fun@ %a@ ->@ %a"
+          (label_exp ctxt) (l,eo,p)
+          (class_expr ctxt) e
+    | Pcl_let (rf, l, ce) ->
+        pp f "%a@ in@ %a"
+          (bindings ctxt) (rf,l)
+          (class_expr ctxt) ce
+    | Pcl_apply (ce, l) ->
+        pp f "((%a)@ %a)" (* Cf: #7200 *)
+          (class_expr ctxt) ce
+          (list (label_x_expression_param ctxt)) l
+    | Pcl_constr (li, l) ->
+        pp f "%a%a"
+          (fun f l-> if l <>[] then
+              pp f "[%a]@ "
+                (list (core_type ctxt) ~sep:",") l) l
+          longident_loc li
+    | Pcl_constraint (ce, ct) ->
+        pp f "(%a@ :@ %a)"
+          (class_expr ctxt) ce
+          (class_type ctxt) ct
+    | Pcl_extension e -> extension ctxt f e
+    | Pcl_open (o, e) ->
+        pp f "@[<2>let open%s %a in@;%a@]"
+          (override o.popen_override) longident_loc o.popen_expr
+          (class_expr ctxt) e
+
+and module_type ctxt f x =
+  if x.pmty_attributes <> [] then begin
+    pp f "((%a)%a)" (module_type ctxt) {x with pmty_attributes=[]}
+      (attributes ctxt) x.pmty_attributes
+  end else
+    match x.pmty_desc with
+    | Pmty_functor (Unit, mt2) ->
+        pp f "@[<hov2>functor () ->@ %a@]" (module_type ctxt) mt2
+    | Pmty_functor (Named (s, mt1), mt2) ->
+        begin match s.txt with
+        | None ->
+            pp f "@[<hov2>%a@ ->@ %a@]"
+              (module_type1 ctxt) mt1 (module_type ctxt) mt2
+        | Some name ->
+            pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" name
+              (module_type ctxt) mt1 (module_type ctxt) mt2
+        end
+    | Pmty_with (mt, []) -> module_type ctxt f mt
+    | Pmty_with (mt, l) ->
+        pp f "@[<hov2>%a@ with@ %a@]"
+          (module_type1 ctxt) mt
+          (list (with_constraint ctxt) ~sep:"@ and@ ") l
+    | _ -> module_type1 ctxt f x
+
+and with_constraint ctxt f = function
+  | Pwith_type (li, ({ptype_params= ls ;_} as td)) ->
+      let ls = List.map fst ls in
+      pp f "type@ %a %a =@ %a"
+        (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")")
+        ls longident_loc li (type_declaration ctxt) td
+  | Pwith_module (li, li2) ->
+      pp f "module %a =@ %a" longident_loc li longident_loc li2;
+  | Pwith_modtype (li, mty) ->
+      pp f "module type %a =@ %a" longident_loc li (module_type ctxt) mty;
+  | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) ->
+      let ls = List.map fst ls in
+      pp f "type@ %a %a :=@ %a"
+        (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")")
+        ls longident_loc li
+        (type_declaration ctxt) td
+  | Pwith_modsubst (li, li2) ->
+      pp f "module %a :=@ %a" longident_loc li longident_loc li2
+  | Pwith_modtypesubst (li, mty) ->
+      pp f "module type %a :=@ %a" longident_loc li (module_type ctxt) mty;
+
+
+and module_type1 ctxt f x =
+  if x.pmty_attributes <> [] then module_type ctxt f x
+  else match x.pmty_desc with
+    | Pmty_ident li ->
+        pp f "%a" longident_loc li;
+    | Pmty_alias li ->
+        pp f "(module %a)" longident_loc li;
+    | Pmty_signature (s) ->
+        pp f "@[<hv0>@[<hv2>sig@ %a@]@ end@]" (* "@[<hov>sig@ %a@ end@]" *)
+          (list (signature_item ctxt)) s (* FIXME wrong indentation*)
+    | Pmty_typeof me ->
+        pp f "@[<hov2>module@ type@ of@ %a@]" (module_expr ctxt) me
+    | Pmty_extension e -> extension ctxt f e
+    | _ -> paren true (module_type ctxt) f x
+
+and signature ctxt f x =  list ~sep:"@\n" (signature_item ctxt) f x
+
+and signature_item ctxt f x : unit =
+  match x.psig_desc with
+  | Psig_type (rf, l) ->
+      type_def_list ctxt f (rf, true, l)
+  | Psig_typesubst l ->
+      (* Psig_typesubst is never recursive, but we specify [Recursive] here to
+         avoid printing a [nonrec] flag, which would be rejected by the parser.
+      *)
+      type_def_list ctxt f (Recursive, false, l)
+  | Psig_value vd ->
+      let intro = if vd.pval_prim = [] then "val" else "external" in
+      pp f "@[<2>%s@ %a@ :@ %a@]%a" intro
+        protect_ident vd.pval_name.txt
+        (value_description ctxt) vd
+        (item_attributes ctxt) vd.pval_attributes
+  | Psig_typext te ->
+      type_extension ctxt f te
+  | Psig_exception ed ->
+      exception_declaration ctxt f ed
+  | Psig_class l ->
+      let class_description kwd f ({pci_params=ls;pci_name={txt;_};_} as x) =
+        pp f "@[<2>%s %a%a%s@;:@;%a@]%a" kwd
+          virtual_flag x.pci_virt
+          (class_params_def ctxt) ls txt
+          (class_type ctxt) x.pci_expr
+          (item_attributes ctxt) x.pci_attributes
+      in begin
+        match l with
+        | [] -> ()
+        | [x] -> class_description "class" f x
+        | x :: xs ->
+            pp f "@[<v>%a@,%a@]"
+              (class_description "class") x
+              (list ~sep:"@," (class_description "and")) xs
+      end
+  | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias;
+                            pmty_attributes=[]; _};_} as pmd) ->
+      pp f "@[<hov>module@ %s@ =@ %a@]%a"
+        (Option.value pmd.pmd_name.txt ~default:"_")
+        longident_loc alias
+        (item_attributes ctxt) pmd.pmd_attributes
+  | Psig_module pmd ->
+      pp f "@[<hov>module@ %s@ :@ %a@]%a"
+        (Option.value pmd.pmd_name.txt ~default:"_")
+        (module_type ctxt) pmd.pmd_type
+        (item_attributes ctxt) pmd.pmd_attributes
+  | Psig_modsubst pms ->
+      pp f "@[<hov>module@ %s@ :=@ %a@]%a" pms.pms_name.txt
+        longident_loc pms.pms_manifest
+        (item_attributes ctxt) pms.pms_attributes
+  | Psig_open od ->
+      pp f "@[<hov2>open%s@ %a@]%a"
+        (override od.popen_override)
+        longident_loc od.popen_expr
+        (item_attributes ctxt) od.popen_attributes
+  | Psig_include incl ->
+      pp f "@[<hov2>include@ %a@]%a"
+        (module_type ctxt) incl.pincl_mod
+        (item_attributes ctxt) incl.pincl_attributes
+  | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
+      pp f "@[<hov2>module@ type@ %s%a@]%a"
+        s.txt
+        (fun f md -> match md with
+           | None -> ()
+           | Some mt ->
+               pp_print_space f () ;
+               pp f "@ =@ %a" (module_type ctxt) mt
+        ) md
+        (item_attributes ctxt) attrs
+  | Psig_modtypesubst {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
+      let md = match md with
+        | None -> assert false (* ast invariant *)
+        | Some mt -> mt in
+      pp f "@[<hov2>module@ type@ %s@ :=@ %a@]%a"
+        s.txt (module_type ctxt) md
+        (item_attributes ctxt) attrs
+  | Psig_class_type (l) -> class_type_declaration_list ctxt f l
+  | Psig_recmodule decls ->
+      let rec  string_x_module_type_list f ?(first=true) l =
+        match l with
+        | [] -> () ;
+        | pmd :: tl ->
+            if not first then
+              pp f "@ @[<hov2>and@ %s:@ %a@]%a"
+                (Option.value pmd.pmd_name.txt ~default:"_")
+                (module_type1 ctxt) pmd.pmd_type
+                (item_attributes ctxt) pmd.pmd_attributes
+            else
+              pp f "@[<hov2>module@ rec@ %s:@ %a@]%a"
+                (Option.value pmd.pmd_name.txt ~default:"_")
+                (module_type1 ctxt) pmd.pmd_type
+                (item_attributes ctxt) pmd.pmd_attributes;
+            string_x_module_type_list f ~first:false tl
+      in
+      string_x_module_type_list f decls
+  | Psig_attribute a -> floating_attribute ctxt f a
+  | Psig_extension(e, a) ->
+      item_extension ctxt f e;
+      item_attributes ctxt f a
+
+and module_expr ctxt f x =
+  if x.pmod_attributes <> [] then
+    pp f "((%a)%a)" (module_expr ctxt) {x with pmod_attributes=[]}
+      (attributes ctxt) x.pmod_attributes
+  else match x.pmod_desc with
+    | Pmod_structure (s) ->
+        pp f "@[<hv2>struct@;@[<0>%a@]@;<1 -2>end@]"
+          (list (structure_item ctxt) ~sep:"@\n") s;
+    | Pmod_constraint (me, mt) ->
+        pp f "@[<hov2>(%a@ :@ %a)@]"
+          (module_expr ctxt) me
+          (module_type ctxt) mt
+    | Pmod_ident (li) ->
+        pp f "%a" longident_loc li;
+    | Pmod_functor (Unit, me) ->
+        pp f "functor ()@;->@;%a" (module_expr ctxt) me
+    | Pmod_functor (Named (s, mt), me) ->
+        pp f "functor@ (%s@ :@ %a)@;->@;%a"
+          (Option.value s.txt ~default:"_")
+          (module_type ctxt) mt (module_expr ctxt) me
+    | Pmod_apply (me1, me2) ->
+        pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2
+        (* Cf: #7200 *)
+    | Pmod_unpack e ->
+        pp f "(val@ %a)" (expression ctxt) e
+    | Pmod_extension e -> extension ctxt f e
+
+and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x
+
+and payload ctxt f = function
+  | PStr [{pstr_desc = Pstr_eval (e, attrs)}] ->
+      pp f "@[<2>%a@]%a"
+        (expression ctxt) e
+        (item_attributes ctxt) attrs
+  | PStr x -> structure ctxt f x
+  | PTyp x -> pp f ":@ "; core_type ctxt f x
+  | PSig x -> pp f ":@ "; signature ctxt f x
+  | PPat (x, None) -> pp f "?@ "; pattern ctxt f x
+  | PPat (x, Some e) ->
+      pp f "?@ "; pattern ctxt f x;
+      pp f " when "; expression ctxt f e
+
+(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *)
+and binding ctxt f {pvb_pat=p; pvb_expr=x; _} =
+  (* .pvb_attributes have already been printed by the caller, #bindings *)
+  let rec pp_print_pexp_function f x =
+    if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x
+    else match x.pexp_desc with
+      | Pexp_fun (label, eo, p, e) ->
+          if label=Nolabel then
+            pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e
+          else
+            pp f "%a@ %a"
+              (label_exp ctxt) (label,eo,p) pp_print_pexp_function e
+      | Pexp_newtype (str,e) ->
+          pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e
+      | _ -> pp f "=@;%a" (expression ctxt) x
+  in
+  let tyvars_str tyvars = List.map (fun v -> v.txt) tyvars in
+  let is_desugared_gadt p e =
+    let gadt_pattern =
+      match p with
+      | {ppat_desc=Ppat_constraint({ppat_desc=Ppat_var _} as pat,
+                                   {ptyp_desc=Ptyp_poly (args_tyvars, rt)});
+         ppat_attributes=[]}->
+          Some (pat, args_tyvars, rt)
+      | _ -> None in
+    let rec gadt_exp tyvars e =
+      match e with
+      | {pexp_desc=Pexp_newtype (tyvar, e); pexp_attributes=[]} ->
+          gadt_exp (tyvar :: tyvars) e
+      | {pexp_desc=Pexp_constraint (e, ct); pexp_attributes=[]} ->
+          Some (List.rev tyvars, e, ct)
+      | _ -> None in
+    let gadt_exp = gadt_exp [] e in
+    match gadt_pattern, gadt_exp with
+    | Some (p, pt_tyvars, pt_ct), Some (e_tyvars, e, e_ct)
+      when tyvars_str pt_tyvars = tyvars_str e_tyvars ->
+      let ety = Typ.varify_constructors e_tyvars e_ct in
+      if ety = pt_ct then
+      Some (p, pt_tyvars, e_ct, e) else None
+    | _ -> None in
+  if x.pexp_attributes <> []
+  then
+    match p with
+    | {ppat_desc=Ppat_constraint({ppat_desc=Ppat_var _; _} as pat,
+                                 ({ptyp_desc=Ptyp_poly _; _} as typ));
+       ppat_attributes=[]; _} ->
+        pp f "%a@;: %a@;=@;%a"
+          (simple_pattern ctxt) pat (core_type ctxt) typ (expression ctxt) x
+    | _ ->
+        pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x
+  else
+  match is_desugared_gadt p x with
+  | Some (p, [], ct, e) ->
+      pp f "%a@;: %a@;=@;%a"
+        (simple_pattern ctxt) p (core_type ctxt) ct (expression ctxt) e
+  | Some (p, tyvars, ct, e) -> begin
+    pp f "%a@;: type@;%a.@;%a@;=@;%a"
+    (simple_pattern ctxt) p (list pp_print_string ~sep:"@;")
+    (tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e
+    end
+  | None -> begin
+      match p with
+      | {ppat_desc=Ppat_constraint(p ,ty);
+         ppat_attributes=[]} -> (* special case for the first*)
+          begin match ty with
+          | {ptyp_desc=Ptyp_poly _; ptyp_attributes=[]} ->
+              pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p
+                (core_type ctxt) ty (expression ctxt) x
+          | _ ->
+              pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p
+                (core_type ctxt) ty (expression ctxt) x
+          end
+      | {ppat_desc=Ppat_var _; ppat_attributes=[]} ->
+          pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x
+      | _ ->
+          pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x
+    end
+
+(* [in] is not printed *)
+and bindings ctxt f (rf,l) =
+  let binding kwd rf f x =
+    pp f "@[<2>%s %a%a@]%a" kwd rec_flag rf
+      (binding ctxt) x (item_attributes ctxt) x.pvb_attributes
+  in
+  match l with
+  | [] -> ()
+  | [x] -> binding "let" rf f x
+  | x::xs ->
+      pp f "@[<v>%a@,%a@]"
+        (binding "let" rf) x
+        (list ~sep:"@," (binding "and" Nonrecursive)) xs
+
+and binding_op ctxt f x =
+  match x.pbop_pat, x.pbop_exp with
+  | {ppat_desc = Ppat_var { txt=pvar; _ }; ppat_attributes = []; _},
+    {pexp_desc = Pexp_ident { txt=Lident evar; _}; pexp_attributes = []; _}
+       when pvar = evar ->
+     pp f "@[<2>%s %s@]" x.pbop_op.txt evar
+  | pat, exp ->
+     pp f "@[<2>%s %a@;=@;%a@]"
+       x.pbop_op.txt (pattern ctxt) pat (expression ctxt) exp
+
+and structure_item ctxt f x =
+  match x.pstr_desc with
+  | Pstr_eval (e, attrs) ->
+      pp f "@[<hov2>;;%a@]%a"
+        (expression ctxt) e
+        (item_attributes ctxt) attrs
+  | Pstr_type (_, []) -> assert false
+  | Pstr_type (rf, l)  -> type_def_list ctxt f (rf, true, l)
+  | Pstr_value (rf, l) ->
+      (* pp f "@[<hov2>let %a%a@]"  rec_flag rf bindings l *)
+      pp f "@[<2>%a@]" (bindings ctxt) (rf,l)
+  | Pstr_typext te -> type_extension ctxt f te
+  | Pstr_exception ed -> exception_declaration ctxt f ed
+  | Pstr_module x ->
+      let rec module_helper = function
+        | {pmod_desc=Pmod_functor(arg_opt,me'); pmod_attributes = []} ->
+            begin match arg_opt with
+            | Unit -> pp f "()"
+            | Named (s, mt) ->
+              pp f "(%s:%a)" (Option.value s.txt ~default:"_")
+                (module_type ctxt) mt
+            end;
+            module_helper me'
+        | me -> me
+      in
+      pp f "@[<hov2>module %s%a@]%a"
+        (Option.value x.pmb_name.txt ~default:"_")
+        (fun f me ->
+           let me = module_helper me in
+           match me with
+           | {pmod_desc=
+                Pmod_constraint
+                  (me',
+                   ({pmty_desc=(Pmty_ident (_)
+                               | Pmty_signature (_));_} as mt));
+              pmod_attributes = []} ->
+               pp f " :@;%a@;=@;%a@;"
+                 (module_type ctxt) mt (module_expr ctxt) me'
+           | _ -> pp f " =@ %a" (module_expr ctxt) me
+        ) x.pmb_expr
+        (item_attributes ctxt) x.pmb_attributes
+  | Pstr_open od ->
+      pp f "@[<2>open%s@;%a@]%a"
+        (override od.popen_override)
+        (module_expr ctxt) od.popen_expr
+        (item_attributes ctxt) od.popen_attributes
+  | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
+      pp f "@[<hov2>module@ type@ %s%a@]%a"
+        s.txt
+        (fun f md -> match md with
+           | None -> ()
+           | Some mt ->
+               pp_print_space f () ;
+               pp f "@ =@ %a" (module_type ctxt) mt
+        ) md
+        (item_attributes ctxt) attrs
+  | Pstr_class l ->
+      let extract_class_args cl =
+        let rec loop acc = function
+          | {pcl_desc=Pcl_fun (l, eo, p, cl'); pcl_attributes = []} ->
+              loop ((l,eo,p) :: acc) cl'
+          | cl -> List.rev acc, cl
+        in
+        let args, cl = loop [] cl in
+        let constr, cl =
+          match cl with
+          | {pcl_desc=Pcl_constraint (cl', ct); pcl_attributes = []} ->
+              Some ct, cl'
+          | _ -> None, cl
+        in
+        args, constr, cl
+      in
+      let class_constraint f ct = pp f ": @[%a@] " (class_type ctxt) ct in
+      let class_declaration kwd f
+          ({pci_params=ls; pci_name={txt;_}; _} as x) =
+        let args, constr, cl = extract_class_args x.pci_expr in
+        pp f "@[<2>%s %a%a%s %a%a=@;%a@]%a" kwd
+          virtual_flag x.pci_virt
+          (class_params_def ctxt) ls txt
+          (list (label_exp ctxt)) args
+          (option class_constraint) constr
+          (class_expr ctxt) cl
+          (item_attributes ctxt) x.pci_attributes
+      in begin
+        match l with
+        | [] -> ()
+        | [x] -> class_declaration "class" f x
+        | x :: xs ->
+            pp f "@[<v>%a@,%a@]"
+              (class_declaration "class") x
+              (list ~sep:"@," (class_declaration "and")) xs
+      end
+  | Pstr_class_type l -> class_type_declaration_list ctxt f l
+  | Pstr_primitive vd ->
+      pp f "@[<hov2>external@ %a@ :@ %a@]%a"
+        protect_ident vd.pval_name.txt
+        (value_description ctxt) vd
+        (item_attributes ctxt) vd.pval_attributes
+  | Pstr_include incl ->
+      pp f "@[<hov2>include@ %a@]%a"
+        (module_expr ctxt) incl.pincl_mod
+        (item_attributes ctxt) incl.pincl_attributes
+  | Pstr_recmodule decls -> (* 3.07 *)
+      let aux f = function
+        | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) ->
+            pp f "@[<hov2>@ and@ %s:%a@ =@ %a@]%a"
+              (Option.value pmb.pmb_name.txt ~default:"_")
+              (module_type ctxt) typ
+              (module_expr ctxt) expr
+              (item_attributes ctxt) pmb.pmb_attributes
+        | pmb ->
+            pp f "@[<hov2>@ and@ %s@ =@ %a@]%a"
+              (Option.value pmb.pmb_name.txt ~default:"_")
+              (module_expr ctxt) pmb.pmb_expr
+              (item_attributes ctxt) pmb.pmb_attributes
+      in
+      begin match decls with
+      | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 ->
+          pp f "@[<hv>@[<hov2>module@ rec@ %s:%a@ =@ %a@]%a@ %a@]"
+            (Option.value pmb.pmb_name.txt ~default:"_")
+            (module_type ctxt) typ
+            (module_expr ctxt) expr
+            (item_attributes ctxt) pmb.pmb_attributes
+            (fun f l2 -> List.iter (aux f) l2) l2
+      | pmb :: l2 ->
+          pp f "@[<hv>@[<hov2>module@ rec@ %s@ =@ %a@]%a@ %a@]"
+            (Option.value pmb.pmb_name.txt ~default:"_")
+            (module_expr ctxt) pmb.pmb_expr
+            (item_attributes ctxt) pmb.pmb_attributes
+            (fun f l2 -> List.iter (aux f) l2) l2
+      | _ -> assert false
+      end
+  | Pstr_attribute a -> floating_attribute ctxt f a
+  | Pstr_extension(e, a) ->
+      item_extension ctxt f e;
+      item_attributes ctxt f a
+
+and type_param ctxt f (ct, (a,b)) =
+  pp f "%s%s%a" (type_variance a) (type_injectivity b) (core_type ctxt) ct
+
+and type_params ctxt f = function
+  | [] -> ()
+  | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l
+
+and type_def_list ctxt f (rf, exported, l) =
+  let type_decl kwd rf f x =
+    let eq =
+      if (x.ptype_kind = Ptype_abstract)
+         && (x.ptype_manifest = None) then ""
+      else if exported then " ="
+      else " :="
+    in
+    pp f "@[<2>%s %a%a%s%s%a@]%a" kwd
+      nonrec_flag rf
+      (type_params ctxt) x.ptype_params
+      x.ptype_name.txt eq
+      (type_declaration ctxt) x
+      (item_attributes ctxt) x.ptype_attributes
+  in
+  match l with
+  | [] -> assert false
+  | [x] -> type_decl "type" rf f x
+  | x :: xs -> pp f "@[<v>%a@,%a@]"
+                 (type_decl "type" rf) x
+                 (list ~sep:"@," (type_decl "and" Recursive)) xs
+
+and record_declaration ctxt f lbls =
+  let type_record_field f pld =
+    pp f "@[<2>%a%s:@;%a@;%a@]"
+      mutable_flag pld.pld_mutable
+      pld.pld_name.txt
+      (core_type ctxt) pld.pld_type
+      (attributes ctxt) pld.pld_attributes
+  in
+  pp f "{@\n%a}"
+    (list type_record_field ~sep:";@\n" )  lbls
+
+and type_declaration ctxt f x =
+  (* type_declaration has an attribute field,
+     but it's been printed by the caller of this method *)
+  let priv f =
+    match x.ptype_private with
+    | Public -> ()
+    | Private -> pp f "@;private"
+  in
+  let manifest f =
+    match x.ptype_manifest with
+    | None -> ()
+    | Some y ->
+        if x.ptype_kind = Ptype_abstract then
+          pp f "%t@;%a" priv (core_type ctxt) y
+        else
+          pp f "@;%a" (core_type ctxt) y
+  in
+  let constructor_declaration f pcd =
+    pp f "|@;";
+    constructor_declaration ctxt f
+      (pcd.pcd_name.txt, pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes)
+  in
+  let repr f =
+    let intro f =
+      if x.ptype_manifest = None then ()
+      else pp f "@;="
+    in
+    match x.ptype_kind with
+    | Ptype_variant xs ->
+      let variants fmt xs =
+        if xs = [] then pp fmt " |" else
+          pp fmt "@\n%a" (list ~sep:"@\n" constructor_declaration) xs
+      in pp f "%t%t%a" intro priv variants xs
+    | Ptype_abstract -> ()
+    | Ptype_record l ->
+        pp f "%t%t@;%a" intro priv (record_declaration ctxt) l
+    | Ptype_open -> pp f "%t%t@;.." intro priv
+  in
+  let constraints f =
+    List.iter
+      (fun (ct1,ct2,_) ->
+         pp f "@[<hov2>@ constraint@ %a@ =@ %a@]"
+           (core_type ctxt) ct1 (core_type ctxt) ct2)
+      x.ptype_cstrs
+  in
+  pp f "%t%t%t" manifest repr constraints
+
+and type_extension ctxt f x =
+  let extension_constructor f x =
+    pp f "@\n|@;%a" (extension_constructor ctxt) x
+  in
+  pp f "@[<2>type %a%a += %a@ %a@]%a"
+    (fun f -> function
+       | [] -> ()
+       | l ->
+           pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l)
+    x.ptyext_params
+    longident_loc x.ptyext_path
+    private_flag x.ptyext_private (* Cf: #7200 *)
+    (list ~sep:"" extension_constructor)
+    x.ptyext_constructors
+    (item_attributes ctxt) x.ptyext_attributes
+
+and constructor_declaration ctxt f (name, args, res, attrs) =
+  let name =
+    match name with
+    | "::" -> "(::)"
+    | s -> s in
+  match res with
+  | None ->
+      pp f "%s%a@;%a" name
+        (fun f -> function
+           | Pcstr_tuple [] -> ()
+           | Pcstr_tuple l ->
+             pp f "@;of@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l
+           | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l
+        ) args
+        (attributes ctxt) attrs
+  | Some r ->
+      pp f "%s:@;%a@;%a" name
+        (fun f -> function
+           | Pcstr_tuple [] -> core_type1 ctxt f r
+           | Pcstr_tuple l -> pp f "%a@;->@;%a"
+                                (list (core_type1 ctxt) ~sep:"@;*@;") l
+                                (core_type1 ctxt) r
+           | Pcstr_record l ->
+               pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r
+        )
+        args
+        (attributes ctxt) attrs
+
+and extension_constructor ctxt f x =
+  (* Cf: #7200 *)
+  match x.pext_kind with
+  | Pext_decl(l, r) ->
+      constructor_declaration ctxt f (x.pext_name.txt, l, r, x.pext_attributes)
+  | Pext_rebind li ->
+      pp f "%s@;=@;%a%a" x.pext_name.txt
+        longident_loc li
+        (attributes ctxt) x.pext_attributes
+
+and case_list ctxt f l : unit =
+  let aux f {pc_lhs; pc_guard; pc_rhs} =
+    pp f "@;| @[<2>%a%a@;->@;%a@]"
+      (pattern ctxt) pc_lhs (option (expression ctxt) ~first:"@;when@;")
+      pc_guard (expression (under_pipe ctxt)) pc_rhs
+  in
+  list aux f l ~sep:""
+
+and label_x_expression_param ctxt f (l,e) =
+  let simple_name = match e with
+    | {pexp_desc=Pexp_ident {txt=Lident l;_};
+       pexp_attributes=[]} -> Some l
+    | _ -> None
+  in match l with
+  | Nolabel  -> expression2 ctxt f e (* level 2*)
+  | Optional str ->
+      if Some str = simple_name then
+        pp f "?%s" str
+      else
+        pp f "?%s:%a" str (simple_expr ctxt) e
+  | Labelled lbl ->
+      if Some lbl = simple_name then
+        pp f "~%s" lbl
+      else
+        pp f "~%s:%a" lbl (simple_expr ctxt) e
+
+and directive_argument f x =
+  match x.pdira_desc with
+  | Pdir_string (s) -> pp f "@ %S" s
+  | Pdir_int (n, None) -> pp f "@ %s" n
+  | Pdir_int (n, Some m) -> pp f "@ %s%c" n m
+  | Pdir_ident (li) -> pp f "@ %a" longident li
+  | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b)
+
+let toplevel_phrase f x =
+  match x with
+  | Ptop_def (s) ->pp f "@[<hov0>%a@]"  (list (structure_item reset_ctxt)) s
+   (* pp_open_hvbox f 0; *)
+   (* pp_print_list structure_item f s ; *)
+   (* pp_close_box f (); *)
+  | Ptop_dir {pdir_name; pdir_arg = None; _} ->
+   pp f "@[<hov2>#%s@]" pdir_name.txt
+  | Ptop_dir {pdir_name; pdir_arg = Some pdir_arg; _} ->
+   pp f "@[<hov2>#%s@ %a@]" pdir_name.txt directive_argument pdir_arg
+
+let expression f x =
+  pp f "@[%a@]" (expression reset_ctxt) x
+
+let string_of_expression x =
+  ignore (flush_str_formatter ()) ;
+  let f = str_formatter in
+  expression f x;
+  flush_str_formatter ()
+
+let string_of_structure x =
+  ignore (flush_str_formatter ());
+  let f = str_formatter in
+  structure reset_ctxt f x;
+  flush_str_formatter ()
+
+let top_phrase f x =
+  pp_print_newline f ();
+  toplevel_phrase f x;
+  pp f ";;";
+  pp_print_newline f ()
+
+let core_type = core_type reset_ctxt
+let pattern = pattern reset_ctxt
+let signature = signature reset_ctxt
+let structure = structure reset_ctxt
+let module_expr = module_expr reset_ctxt
diff --git a/upstream/ocaml_413/parsing/pprintast.mli b/upstream/ocaml_413/parsing/pprintast.mli
new file mode 100644
index 0000000..6c7022c
--- /dev/null
+++ b/upstream/ocaml_413/parsing/pprintast.mli
@@ -0,0 +1,46 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Hongbo Zhang (University of Pennsylvania)                  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+
+(** Pretty-printers for {!Parsetree}
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type space_formatter = (unit, Format.formatter, unit) format
+
+val longident : Format.formatter -> Longident.t -> unit
+val expression : Format.formatter -> Parsetree.expression -> unit
+val string_of_expression : Parsetree.expression -> string
+
+val pattern: Format.formatter -> Parsetree.pattern -> unit
+
+val core_type: Format.formatter -> Parsetree.core_type -> unit
+
+val signature: Format.formatter -> Parsetree.signature -> unit
+val structure: Format.formatter -> Parsetree.structure -> unit
+val string_of_structure: Parsetree.structure -> string
+
+val module_expr: Format.formatter -> Parsetree.module_expr -> unit
+
+val toplevel_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit
+val top_phrase: Format.formatter -> Parsetree.toplevel_phrase -> unit
+
+
+val tyvar: Format.formatter -> string -> unit
+  (** Print a type variable name, taking care of the special treatment
+      required for the single quote character in second position. *)
diff --git a/upstream/ocaml_413/parsing/printast.ml b/upstream/ocaml_413/parsing/printast.ml
new file mode 100644
index 0000000..647dfe9
--- /dev/null
+++ b/upstream/ocaml_413/parsing/printast.ml
@@ -0,0 +1,981 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*              Damien Doligez, projet Para, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes;;
+open Format;;
+open Lexing;;
+open Location;;
+open Parsetree;;
+
+let fmt_position with_name f l =
+  let fname = if with_name then l.pos_fname else "" in
+  if l.pos_lnum = -1
+  then fprintf f "%s[%d]" fname l.pos_cnum
+  else fprintf f "%s[%d,%d+%d]" fname l.pos_lnum l.pos_bol
+               (l.pos_cnum - l.pos_bol)
+;;
+
+let fmt_location f loc =
+  if not !Clflags.locations then ()
+  else begin
+    let p_2nd_name = loc.loc_start.pos_fname <> loc.loc_end.pos_fname in
+    fprintf f "(%a..%a)" (fmt_position true) loc.loc_start
+                         (fmt_position p_2nd_name) loc.loc_end;
+    if loc.loc_ghost then fprintf f " ghost";
+  end
+;;
+
+let rec fmt_longident_aux f x =
+  match x with
+  | Longident.Lident (s) -> fprintf f "%s" s;
+  | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s;
+  | Longident.Lapply (y, z) ->
+      fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z;
+;;
+
+let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x;;
+
+let fmt_longident_loc f (x : Longident.t loc) =
+  fprintf f "\"%a\" %a" fmt_longident_aux x.txt fmt_location x.loc;
+;;
+
+let fmt_string_loc f (x : string loc) =
+  fprintf f "\"%s\" %a" x.txt fmt_location x.loc;
+;;
+
+let fmt_str_opt_loc f (x : string option loc) =
+  fprintf f "\"%s\" %a" (Option.value x.txt ~default:"_") fmt_location x.loc;
+;;
+
+let fmt_char_option f = function
+  | None -> fprintf f "None"
+  | Some c -> fprintf f "Some %c" c
+
+let fmt_constant f x =
+  match x with
+  | Pconst_integer (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m;
+  | Pconst_char (c) -> fprintf f "PConst_char %02x" (Char.code c);
+  | Pconst_string (s, strloc, None) ->
+      fprintf f "PConst_string(%S,%a,None)" s fmt_location strloc ;
+  | Pconst_string (s, strloc, Some delim) ->
+      fprintf f "PConst_string (%S,%a,Some %S)" s fmt_location strloc delim;
+  | Pconst_float (s,m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m;
+;;
+
+let fmt_mutable_flag f x =
+  match x with
+  | Immutable -> fprintf f "Immutable";
+  | Mutable -> fprintf f "Mutable";
+;;
+
+let fmt_virtual_flag f x =
+  match x with
+  | Virtual -> fprintf f "Virtual";
+  | Concrete -> fprintf f "Concrete";
+;;
+
+let fmt_override_flag f x =
+  match x with
+  | Override -> fprintf f "Override";
+  | Fresh -> fprintf f "Fresh";
+;;
+
+let fmt_closed_flag f x =
+  match x with
+  | Closed -> fprintf f "Closed"
+  | Open -> fprintf f "Open"
+
+let fmt_rec_flag f x =
+  match x with
+  | Nonrecursive -> fprintf f "Nonrec";
+  | Recursive -> fprintf f "Rec";
+;;
+
+let fmt_direction_flag f x =
+  match x with
+  | Upto -> fprintf f "Up";
+  | Downto -> fprintf f "Down";
+;;
+
+let fmt_private_flag f x =
+  match x with
+  | Public -> fprintf f "Public";
+  | Private -> fprintf f "Private";
+;;
+
+let line i f s (*...*) =
+  fprintf f "%s" (String.make ((2*i) mod 72) ' ');
+  fprintf f s (*...*)
+;;
+
+let list i f ppf l =
+  match l with
+  | [] -> line i ppf "[]\n";
+  | _ :: _ ->
+     line i ppf "[\n";
+     List.iter (f (i+1) ppf) l;
+     line i ppf "]\n";
+;;
+
+let option i f ppf x =
+  match x with
+  | None -> line i ppf "None\n";
+  | Some x ->
+      line i ppf "Some\n";
+      f (i+1) ppf x;
+;;
+
+let longident_loc i ppf li = line i ppf "%a\n" fmt_longident_loc li;;
+let string i ppf s = line i ppf "\"%s\"\n" s;;
+let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s;;
+let str_opt_loc i ppf s = line i ppf "%a\n" fmt_str_opt_loc s;;
+let arg_label i ppf = function
+  | Nolabel -> line i ppf "Nolabel\n"
+  | Optional s -> line i ppf "Optional \"%s\"\n" s
+  | Labelled s -> line i ppf "Labelled \"%s\"\n" s
+;;
+
+let rec core_type i ppf x =
+  line i ppf "core_type %a\n" fmt_location x.ptyp_loc;
+  attributes i ppf x.ptyp_attributes;
+  let i = i+1 in
+  match x.ptyp_desc with
+  | Ptyp_any -> line i ppf "Ptyp_any\n";
+  | Ptyp_var (s) -> line i ppf "Ptyp_var %s\n" s;
+  | Ptyp_arrow (l, ct1, ct2) ->
+      line i ppf "Ptyp_arrow\n";
+      arg_label i ppf l;
+      core_type i ppf ct1;
+      core_type i ppf ct2;
+  | Ptyp_tuple l ->
+      line i ppf "Ptyp_tuple\n";
+      list i core_type ppf l;
+  | Ptyp_constr (li, l) ->
+      line i ppf "Ptyp_constr %a\n" fmt_longident_loc li;
+      list i core_type ppf l;
+  | Ptyp_variant (l, closed, low) ->
+      line i ppf "Ptyp_variant closed=%a\n" fmt_closed_flag closed;
+      list i label_x_bool_x_core_type_list ppf l;
+      option i (fun i -> list i string) ppf low
+  | Ptyp_object (l, c) ->
+      line i ppf "Ptyp_object %a\n" fmt_closed_flag c;
+      let i = i + 1 in
+      List.iter (fun field ->
+        match field.pof_desc with
+          | Otag (l, t) ->
+            line i ppf "method %s\n" l.txt;
+            attributes i ppf field.pof_attributes;
+            core_type (i + 1) ppf t
+          | Oinherit ct ->
+              line i ppf "Oinherit\n";
+              core_type (i + 1) ppf ct
+      ) l
+  | Ptyp_class (li, l) ->
+      line i ppf "Ptyp_class %a\n" fmt_longident_loc li;
+      list i core_type ppf l
+  | Ptyp_alias (ct, s) ->
+      line i ppf "Ptyp_alias \"%s\"\n" s;
+      core_type i ppf ct;
+  | Ptyp_poly (sl, ct) ->
+      line i ppf "Ptyp_poly%a\n"
+        (fun ppf ->
+           List.iter (fun x -> fprintf ppf " %a" Pprintast.tyvar x.txt)
+        )
+        sl;
+      core_type i ppf ct;
+  | Ptyp_package (s, l) ->
+      line i ppf "Ptyp_package %a\n" fmt_longident_loc s;
+      list i package_with ppf l;
+  | Ptyp_extension (s, arg) ->
+      line i ppf "Ptyp_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and package_with i ppf (s, t) =
+  line i ppf "with type %a\n" fmt_longident_loc s;
+  core_type i ppf t
+
+and pattern i ppf x =
+  line i ppf "pattern %a\n" fmt_location x.ppat_loc;
+  attributes i ppf x.ppat_attributes;
+  let i = i+1 in
+  match x.ppat_desc with
+  | Ppat_any -> line i ppf "Ppat_any\n";
+  | Ppat_var (s) -> line i ppf "Ppat_var %a\n" fmt_string_loc s;
+  | Ppat_alias (p, s) ->
+      line i ppf "Ppat_alias %a\n" fmt_string_loc s;
+      pattern i ppf p;
+  | Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c;
+  | Ppat_interval (c1, c2) ->
+      line i ppf "Ppat_interval %a..%a\n" fmt_constant c1 fmt_constant c2;
+  | Ppat_tuple (l) ->
+      line i ppf "Ppat_tuple\n";
+      list i pattern ppf l;
+  | Ppat_construct (li, po) ->
+      line i ppf "Ppat_construct %a\n" fmt_longident_loc li;
+      option i
+        (fun i ppf (vl, p) ->
+          list i string_loc ppf vl;
+          pattern i ppf p)
+        ppf po
+  | Ppat_variant (l, po) ->
+      line i ppf "Ppat_variant \"%s\"\n" l;
+      option i pattern ppf po;
+  | Ppat_record (l, c) ->
+      line i ppf "Ppat_record %a\n" fmt_closed_flag c;
+      list i longident_x_pattern ppf l;
+  | Ppat_array (l) ->
+      line i ppf "Ppat_array\n";
+      list i pattern ppf l;
+  | Ppat_or (p1, p2) ->
+      line i ppf "Ppat_or\n";
+      pattern i ppf p1;
+      pattern i ppf p2;
+  | Ppat_lazy p ->
+      line i ppf "Ppat_lazy\n";
+      pattern i ppf p;
+  | Ppat_constraint (p, ct) ->
+      line i ppf "Ppat_constraint\n";
+      pattern i ppf p;
+      core_type i ppf ct;
+  | Ppat_type (li) ->
+      line i ppf "Ppat_type\n";
+      longident_loc i ppf li
+  | Ppat_unpack s ->
+      line i ppf "Ppat_unpack %a\n" fmt_str_opt_loc s;
+  | Ppat_exception p ->
+      line i ppf "Ppat_exception\n";
+      pattern i ppf p
+  | Ppat_open (m,p) ->
+      line i ppf "Ppat_open \"%a\"\n" fmt_longident_loc m;
+      pattern i ppf p
+  | Ppat_extension (s, arg) ->
+      line i ppf "Ppat_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and expression i ppf x =
+  line i ppf "expression %a\n" fmt_location x.pexp_loc;
+  attributes i ppf x.pexp_attributes;
+  let i = i+1 in
+  match x.pexp_desc with
+  | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li;
+  | Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c;
+  | Pexp_let (rf, l, e) ->
+      line i ppf "Pexp_let %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l;
+      expression i ppf e;
+  | Pexp_function l ->
+      line i ppf "Pexp_function\n";
+      list i case ppf l;
+  | Pexp_fun (l, eo, p, e) ->
+      line i ppf "Pexp_fun\n";
+      arg_label i ppf l;
+      option i expression ppf eo;
+      pattern i ppf p;
+      expression i ppf e;
+  | Pexp_apply (e, l) ->
+      line i ppf "Pexp_apply\n";
+      expression i ppf e;
+      list i label_x_expression ppf l;
+  | Pexp_match (e, l) ->
+      line i ppf "Pexp_match\n";
+      expression i ppf e;
+      list i case ppf l;
+  | Pexp_try (e, l) ->
+      line i ppf "Pexp_try\n";
+      expression i ppf e;
+      list i case ppf l;
+  | Pexp_tuple (l) ->
+      line i ppf "Pexp_tuple\n";
+      list i expression ppf l;
+  | Pexp_construct (li, eo) ->
+      line i ppf "Pexp_construct %a\n" fmt_longident_loc li;
+      option i expression ppf eo;
+  | Pexp_variant (l, eo) ->
+      line i ppf "Pexp_variant \"%s\"\n" l;
+      option i expression ppf eo;
+  | Pexp_record (l, eo) ->
+      line i ppf "Pexp_record\n";
+      list i longident_x_expression ppf l;
+      option i expression ppf eo;
+  | Pexp_field (e, li) ->
+      line i ppf "Pexp_field\n";
+      expression i ppf e;
+      longident_loc i ppf li;
+  | Pexp_setfield (e1, li, e2) ->
+      line i ppf "Pexp_setfield\n";
+      expression i ppf e1;
+      longident_loc i ppf li;
+      expression i ppf e2;
+  | Pexp_array (l) ->
+      line i ppf "Pexp_array\n";
+      list i expression ppf l;
+  | Pexp_ifthenelse (e1, e2, eo) ->
+      line i ppf "Pexp_ifthenelse\n";
+      expression i ppf e1;
+      expression i ppf e2;
+      option i expression ppf eo;
+  | Pexp_sequence (e1, e2) ->
+      line i ppf "Pexp_sequence\n";
+      expression i ppf e1;
+      expression i ppf e2;
+  | Pexp_while (e1, e2) ->
+      line i ppf "Pexp_while\n";
+      expression i ppf e1;
+      expression i ppf e2;
+  | Pexp_for (p, e1, e2, df, e3) ->
+      line i ppf "Pexp_for %a\n" fmt_direction_flag df;
+      pattern i ppf p;
+      expression i ppf e1;
+      expression i ppf e2;
+      expression i ppf e3;
+  | Pexp_constraint (e, ct) ->
+      line i ppf "Pexp_constraint\n";
+      expression i ppf e;
+      core_type i ppf ct;
+  | Pexp_coerce (e, cto1, cto2) ->
+      line i ppf "Pexp_coerce\n";
+      expression i ppf e;
+      option i core_type ppf cto1;
+      core_type i ppf cto2;
+  | Pexp_send (e, s) ->
+      line i ppf "Pexp_send \"%s\"\n" s.txt;
+      expression i ppf e;
+  | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident_loc li;
+  | Pexp_setinstvar (s, e) ->
+      line i ppf "Pexp_setinstvar %a\n" fmt_string_loc s;
+      expression i ppf e;
+  | Pexp_override (l) ->
+      line i ppf "Pexp_override\n";
+      list i string_x_expression ppf l;
+  | Pexp_letmodule (s, me, e) ->
+      line i ppf "Pexp_letmodule %a\n" fmt_str_opt_loc s;
+      module_expr i ppf me;
+      expression i ppf e;
+  | Pexp_letexception (cd, e) ->
+      line i ppf "Pexp_letexception\n";
+      extension_constructor i ppf cd;
+      expression i ppf e;
+  | Pexp_assert (e) ->
+      line i ppf "Pexp_assert\n";
+      expression i ppf e;
+  | Pexp_lazy (e) ->
+      line i ppf "Pexp_lazy\n";
+      expression i ppf e;
+  | Pexp_poly (e, cto) ->
+      line i ppf "Pexp_poly\n";
+      expression i ppf e;
+      option i core_type ppf cto;
+  | Pexp_object s ->
+      line i ppf "Pexp_object\n";
+      class_structure i ppf s
+  | Pexp_newtype (s, e) ->
+      line i ppf "Pexp_newtype \"%s\"\n" s.txt;
+      expression i ppf e
+  | Pexp_pack me ->
+      line i ppf "Pexp_pack\n";
+      module_expr i ppf me
+  | Pexp_open (o, e) ->
+      line i ppf "Pexp_open %a\n" fmt_override_flag o.popen_override;
+      module_expr i ppf o.popen_expr;
+      expression i ppf e
+  | Pexp_letop {let_; ands; body} ->
+      line i ppf "Pexp_letop\n";
+      binding_op i ppf let_;
+      list i binding_op ppf ands;
+      expression i ppf body
+  | Pexp_extension (s, arg) ->
+      line i ppf "Pexp_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+  | Pexp_unreachable ->
+      line i ppf "Pexp_unreachable"
+
+and value_description i ppf x =
+  line i ppf "value_description %a %a\n" fmt_string_loc
+       x.pval_name fmt_location x.pval_loc;
+  attributes i ppf x.pval_attributes;
+  core_type (i+1) ppf x.pval_type;
+  list (i+1) string ppf x.pval_prim
+
+and type_parameter i ppf (x, _variance) = core_type i ppf x
+
+and type_declaration i ppf x =
+  line i ppf "type_declaration %a %a\n" fmt_string_loc x.ptype_name
+       fmt_location x.ptype_loc;
+  attributes i ppf x.ptype_attributes;
+  let i = i+1 in
+  line i ppf "ptype_params =\n";
+  list (i+1) type_parameter ppf x.ptype_params;
+  line i ppf "ptype_cstrs =\n";
+  list (i+1) core_type_x_core_type_x_location ppf x.ptype_cstrs;
+  line i ppf "ptype_kind =\n";
+  type_kind (i+1) ppf x.ptype_kind;
+  line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private;
+  line i ppf "ptype_manifest =\n";
+  option (i+1) core_type ppf x.ptype_manifest
+
+and attribute i ppf k a =
+  line i ppf "%s \"%s\"\n" k a.attr_name.txt;
+  payload i ppf a.attr_payload;
+
+and attributes i ppf l =
+  let i = i + 1 in
+  List.iter (fun a ->
+    line i ppf "attribute \"%s\"\n" a.attr_name.txt;
+    payload (i + 1) ppf a.attr_payload;
+  ) l;
+
+and payload i ppf = function
+  | PStr x -> structure i ppf x
+  | PSig x -> signature i ppf x
+  | PTyp x -> core_type i ppf x
+  | PPat (x, None) -> pattern i ppf x
+  | PPat (x, Some g) ->
+    pattern i ppf x;
+    line i ppf "<when>\n";
+    expression (i + 1) ppf g
+
+
+and type_kind i ppf x =
+  match x with
+  | Ptype_abstract ->
+      line i ppf "Ptype_abstract\n"
+  | Ptype_variant l ->
+      line i ppf "Ptype_variant\n";
+      list (i+1) constructor_decl ppf l;
+  | Ptype_record l ->
+      line i ppf "Ptype_record\n";
+      list (i+1) label_decl ppf l;
+  | Ptype_open ->
+      line i ppf "Ptype_open\n";
+
+and type_extension i ppf x =
+  line i ppf "type_extension\n";
+  attributes i ppf x.ptyext_attributes;
+  let i = i+1 in
+  line i ppf "ptyext_path = %a\n" fmt_longident_loc x.ptyext_path;
+  line i ppf "ptyext_params =\n";
+  list (i+1) type_parameter ppf x.ptyext_params;
+  line i ppf "ptyext_constructors =\n";
+  list (i+1) extension_constructor ppf x.ptyext_constructors;
+  line i ppf "ptyext_private = %a\n" fmt_private_flag x.ptyext_private;
+
+and type_exception i ppf x =
+  line i ppf "type_exception\n";
+  attributes i ppf x.ptyexn_attributes;
+  let i = i+1 in
+  line i ppf "ptyext_constructor =\n";
+  let i = i+1 in
+  extension_constructor i ppf x.ptyexn_constructor
+
+and extension_constructor i ppf x =
+  line i ppf "extension_constructor %a\n" fmt_location x.pext_loc;
+  attributes i ppf x.pext_attributes;
+  let i = i + 1 in
+  line i ppf "pext_name = \"%s\"\n" x.pext_name.txt;
+  line i ppf "pext_kind =\n";
+  extension_constructor_kind (i + 1) ppf x.pext_kind;
+
+and extension_constructor_kind i ppf x =
+  match x with
+      Pext_decl(a, r) ->
+        line i ppf "Pext_decl\n";
+        constructor_arguments (i+1) ppf a;
+        option (i+1) core_type ppf r;
+    | Pext_rebind li ->
+        line i ppf "Pext_rebind\n";
+        line (i+1) ppf "%a\n" fmt_longident_loc li;
+
+and class_type i ppf x =
+  line i ppf "class_type %a\n" fmt_location x.pcty_loc;
+  attributes i ppf x.pcty_attributes;
+  let i = i+1 in
+  match x.pcty_desc with
+  | Pcty_constr (li, l) ->
+      line i ppf "Pcty_constr %a\n" fmt_longident_loc li;
+      list i core_type ppf l;
+  | Pcty_signature (cs) ->
+      line i ppf "Pcty_signature\n";
+      class_signature i ppf cs;
+  | Pcty_arrow (l, co, cl) ->
+      line i ppf "Pcty_arrow\n";
+      arg_label i ppf l;
+      core_type i ppf co;
+      class_type i ppf cl;
+  | Pcty_extension (s, arg) ->
+      line i ppf "Pcty_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+  | Pcty_open (o, e) ->
+      line i ppf "Pcty_open %a %a\n" fmt_override_flag o.popen_override
+        fmt_longident_loc o.popen_expr;
+      class_type i ppf e
+
+and class_signature i ppf cs =
+  line i ppf "class_signature\n";
+  core_type (i+1) ppf cs.pcsig_self;
+  list (i+1) class_type_field ppf cs.pcsig_fields;
+
+and class_type_field i ppf x =
+  line i ppf "class_type_field %a\n" fmt_location x.pctf_loc;
+  let i = i+1 in
+  attributes i ppf x.pctf_attributes;
+  match x.pctf_desc with
+  | Pctf_inherit (ct) ->
+      line i ppf "Pctf_inherit\n";
+      class_type i ppf ct;
+  | Pctf_val (s, mf, vf, ct) ->
+      line i ppf "Pctf_val \"%s\" %a %a\n" s.txt fmt_mutable_flag mf
+           fmt_virtual_flag vf;
+      core_type (i+1) ppf ct;
+  | Pctf_method (s, pf, vf, ct) ->
+      line i ppf "Pctf_method \"%s\" %a %a\n" s.txt fmt_private_flag pf
+           fmt_virtual_flag vf;
+      core_type (i+1) ppf ct;
+  | Pctf_constraint (ct1, ct2) ->
+      line i ppf "Pctf_constraint\n";
+      core_type (i+1) ppf ct1;
+      core_type (i+1) ppf ct2;
+  | Pctf_attribute a ->
+      attribute i ppf "Pctf_attribute" a
+  | Pctf_extension (s, arg) ->
+      line i ppf "Pctf_extension \"%s\"\n" s.txt;
+     payload i ppf arg
+
+and class_description i ppf x =
+  line i ppf "class_description %a\n" fmt_location x.pci_loc;
+  attributes i ppf x.pci_attributes;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.pci_params;
+  line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
+  line i ppf "pci_expr =\n";
+  class_type (i+1) ppf x.pci_expr;
+
+and class_type_declaration i ppf x =
+  line i ppf "class_type_declaration %a\n" fmt_location x.pci_loc;
+  attributes i ppf x.pci_attributes;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.pci_params;
+  line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
+  line i ppf "pci_expr =\n";
+  class_type (i+1) ppf x.pci_expr;
+
+and class_expr i ppf x =
+  line i ppf "class_expr %a\n" fmt_location x.pcl_loc;
+  attributes i ppf x.pcl_attributes;
+  let i = i+1 in
+  match x.pcl_desc with
+  | Pcl_constr (li, l) ->
+      line i ppf "Pcl_constr %a\n" fmt_longident_loc li;
+      list i core_type ppf l;
+  | Pcl_structure (cs) ->
+      line i ppf "Pcl_structure\n";
+      class_structure i ppf cs;
+  | Pcl_fun (l, eo, p, e) ->
+      line i ppf "Pcl_fun\n";
+      arg_label i ppf l;
+      option i expression ppf eo;
+      pattern i ppf p;
+      class_expr i ppf e;
+  | Pcl_apply (ce, l) ->
+      line i ppf "Pcl_apply\n";
+      class_expr i ppf ce;
+      list i label_x_expression ppf l;
+  | Pcl_let (rf, l, ce) ->
+      line i ppf "Pcl_let %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l;
+      class_expr i ppf ce;
+  | Pcl_constraint (ce, ct) ->
+      line i ppf "Pcl_constraint\n";
+      class_expr i ppf ce;
+      class_type i ppf ct;
+  | Pcl_extension (s, arg) ->
+      line i ppf "Pcl_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+  | Pcl_open (o, e) ->
+      line i ppf "Pcl_open %a %a\n" fmt_override_flag o.popen_override
+        fmt_longident_loc o.popen_expr;
+      class_expr i ppf e
+
+and class_structure i ppf { pcstr_self = p; pcstr_fields = l } =
+  line i ppf "class_structure\n";
+  pattern (i+1) ppf p;
+  list (i+1) class_field ppf l;
+
+and class_field i ppf x =
+  line i ppf "class_field %a\n" fmt_location x.pcf_loc;
+  let i = i + 1 in
+  attributes i ppf x.pcf_attributes;
+  match x.pcf_desc with
+  | Pcf_inherit (ovf, ce, so) ->
+      line i ppf "Pcf_inherit %a\n" fmt_override_flag ovf;
+      class_expr (i+1) ppf ce;
+      option (i+1) string_loc ppf so;
+  | Pcf_val (s, mf, k) ->
+      line i ppf "Pcf_val %a\n" fmt_mutable_flag mf;
+      line (i+1) ppf "%a\n" fmt_string_loc s;
+      class_field_kind (i+1) ppf k
+  | Pcf_method (s, pf, k) ->
+      line i ppf "Pcf_method %a\n" fmt_private_flag pf;
+      line (i+1) ppf "%a\n" fmt_string_loc s;
+      class_field_kind (i+1) ppf k
+  | Pcf_constraint (ct1, ct2) ->
+      line i ppf "Pcf_constraint\n";
+      core_type (i+1) ppf ct1;
+      core_type (i+1) ppf ct2;
+  | Pcf_initializer (e) ->
+      line i ppf "Pcf_initializer\n";
+      expression (i+1) ppf e;
+  | Pcf_attribute a ->
+      attribute i ppf "Pcf_attribute" a
+  | Pcf_extension (s, arg) ->
+      line i ppf "Pcf_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and class_field_kind i ppf = function
+  | Cfk_concrete (o, e) ->
+      line i ppf "Concrete %a\n" fmt_override_flag o;
+      expression i ppf e
+  | Cfk_virtual t ->
+      line i ppf "Virtual\n";
+      core_type i ppf t
+
+and class_declaration i ppf x =
+  line i ppf "class_declaration %a\n" fmt_location x.pci_loc;
+  attributes i ppf x.pci_attributes;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.pci_params;
+  line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
+  line i ppf "pci_expr =\n";
+  class_expr (i+1) ppf x.pci_expr;
+
+and module_type i ppf x =
+  line i ppf "module_type %a\n" fmt_location x.pmty_loc;
+  attributes i ppf x.pmty_attributes;
+  let i = i+1 in
+  match x.pmty_desc with
+  | Pmty_ident li -> line i ppf "Pmty_ident %a\n" fmt_longident_loc li;
+  | Pmty_alias li -> line i ppf "Pmty_alias %a\n" fmt_longident_loc li;
+  | Pmty_signature (s) ->
+      line i ppf "Pmty_signature\n";
+      signature i ppf s;
+  | Pmty_functor (Unit, mt2) ->
+      line i ppf "Pmty_functor ()\n";
+      module_type i ppf mt2;
+  | Pmty_functor (Named (s, mt1), mt2) ->
+      line i ppf "Pmty_functor %a\n" fmt_str_opt_loc s;
+      module_type i ppf mt1;
+      module_type i ppf mt2;
+  | Pmty_with (mt, l) ->
+      line i ppf "Pmty_with\n";
+      module_type i ppf mt;
+      list i with_constraint ppf l;
+  | Pmty_typeof m ->
+      line i ppf "Pmty_typeof\n";
+      module_expr i ppf m;
+  | Pmty_extension (s, arg) ->
+      line i ppf "Pmod_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and signature i ppf x = list i signature_item ppf x
+
+and signature_item i ppf x =
+  line i ppf "signature_item %a\n" fmt_location x.psig_loc;
+  let i = i+1 in
+  match x.psig_desc with
+  | Psig_value vd ->
+      line i ppf "Psig_value\n";
+      value_description i ppf vd;
+  | Psig_type (rf, l) ->
+      line i ppf "Psig_type %a\n" fmt_rec_flag rf;
+      list i type_declaration ppf l;
+  | Psig_typesubst l ->
+      line i ppf "Psig_typesubst\n";
+      list i type_declaration ppf l;
+  | Psig_typext te ->
+      line i ppf "Psig_typext\n";
+      type_extension i ppf te
+  | Psig_exception te ->
+      line i ppf "Psig_exception\n";
+      type_exception i ppf te
+  | Psig_module pmd ->
+      line i ppf "Psig_module %a\n" fmt_str_opt_loc pmd.pmd_name;
+      attributes i ppf pmd.pmd_attributes;
+      module_type i ppf pmd.pmd_type
+  | Psig_modsubst pms ->
+      line i ppf "Psig_modsubst %a = %a\n"
+        fmt_string_loc pms.pms_name
+        fmt_longident_loc pms.pms_manifest;
+      attributes i ppf pms.pms_attributes;
+  | Psig_recmodule decls ->
+      line i ppf "Psig_recmodule\n";
+      list i module_declaration ppf decls;
+  | Psig_modtype x ->
+      line i ppf "Psig_modtype %a\n" fmt_string_loc x.pmtd_name;
+      attributes i ppf x.pmtd_attributes;
+      modtype_declaration i ppf x.pmtd_type
+  | Psig_modtypesubst x ->
+      line i ppf "Psig_modtypesubst %a\n" fmt_string_loc x.pmtd_name;
+      attributes i ppf x.pmtd_attributes;
+      modtype_declaration i ppf x.pmtd_type
+  | Psig_open od ->
+      line i ppf "Psig_open %a %a\n" fmt_override_flag od.popen_override
+        fmt_longident_loc od.popen_expr;
+      attributes i ppf od.popen_attributes
+  | Psig_include incl ->
+      line i ppf "Psig_include\n";
+      module_type i ppf incl.pincl_mod;
+      attributes i ppf incl.pincl_attributes
+  | Psig_class (l) ->
+      line i ppf "Psig_class\n";
+      list i class_description ppf l;
+  | Psig_class_type (l) ->
+      line i ppf "Psig_class_type\n";
+      list i class_type_declaration ppf l;
+  | Psig_extension ((s, arg), attrs) ->
+      line i ppf "Psig_extension \"%s\"\n" s.txt;
+      attributes i ppf attrs;
+      payload i ppf arg
+  | Psig_attribute a ->
+      attribute i ppf "Psig_attribute" a
+
+and modtype_declaration i ppf = function
+  | None -> line i ppf "#abstract"
+  | Some mt -> module_type (i+1) ppf mt
+
+and with_constraint i ppf x =
+  match x with
+  | Pwith_type (lid, td) ->
+      line i ppf "Pwith_type %a\n" fmt_longident_loc lid;
+      type_declaration (i+1) ppf td;
+  | Pwith_typesubst (lid, td) ->
+      line i ppf "Pwith_typesubst %a\n" fmt_longident_loc lid;
+      type_declaration (i+1) ppf td;
+  | Pwith_module (lid1, lid2) ->
+      line i ppf "Pwith_module %a = %a\n"
+        fmt_longident_loc lid1
+        fmt_longident_loc lid2;
+  | Pwith_modsubst (lid1, lid2) ->
+      line i ppf "Pwith_modsubst %a = %a\n"
+        fmt_longident_loc lid1
+        fmt_longident_loc lid2;
+  | Pwith_modtype (lid1, mty) ->
+      line i ppf "Pwith_modtype %a\n"
+        fmt_longident_loc lid1;
+      module_type (i+1) ppf mty
+  | Pwith_modtypesubst (lid1, mty) ->
+     line i ppf "Pwith_modtypesubst %a\n"
+        fmt_longident_loc lid1;
+      module_type (i+1) ppf mty
+
+and module_expr i ppf x =
+  line i ppf "module_expr %a\n" fmt_location x.pmod_loc;
+  attributes i ppf x.pmod_attributes;
+  let i = i+1 in
+  match x.pmod_desc with
+  | Pmod_ident (li) -> line i ppf "Pmod_ident %a\n" fmt_longident_loc li;
+  | Pmod_structure (s) ->
+      line i ppf "Pmod_structure\n";
+      structure i ppf s;
+  | Pmod_functor (Unit, me) ->
+      line i ppf "Pmod_functor ()\n";
+      module_expr i ppf me;
+  | Pmod_functor (Named (s, mt), me) ->
+      line i ppf "Pmod_functor %a\n" fmt_str_opt_loc s;
+      module_type i ppf mt;
+      module_expr i ppf me;
+  | Pmod_apply (me1, me2) ->
+      line i ppf "Pmod_apply\n";
+      module_expr i ppf me1;
+      module_expr i ppf me2;
+  | Pmod_constraint (me, mt) ->
+      line i ppf "Pmod_constraint\n";
+      module_expr i ppf me;
+      module_type i ppf mt;
+  | Pmod_unpack (e) ->
+      line i ppf "Pmod_unpack\n";
+      expression i ppf e;
+  | Pmod_extension (s, arg) ->
+      line i ppf "Pmod_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and structure i ppf x = list i structure_item ppf x
+
+and structure_item i ppf x =
+  line i ppf "structure_item %a\n" fmt_location x.pstr_loc;
+  let i = i+1 in
+  match x.pstr_desc with
+  | Pstr_eval (e, attrs) ->
+      line i ppf "Pstr_eval\n";
+      attributes i ppf attrs;
+      expression i ppf e;
+  | Pstr_value (rf, l) ->
+      line i ppf "Pstr_value %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l;
+  | Pstr_primitive vd ->
+      line i ppf "Pstr_primitive\n";
+      value_description i ppf vd;
+  | Pstr_type (rf, l) ->
+      line i ppf "Pstr_type %a\n" fmt_rec_flag rf;
+      list i type_declaration ppf l;
+  | Pstr_typext te ->
+      line i ppf "Pstr_typext\n";
+      type_extension i ppf te
+  | Pstr_exception te ->
+      line i ppf "Pstr_exception\n";
+      type_exception i ppf te
+  | Pstr_module x ->
+      line i ppf "Pstr_module\n";
+      module_binding i ppf x
+  | Pstr_recmodule bindings ->
+      line i ppf "Pstr_recmodule\n";
+      list i module_binding ppf bindings;
+  | Pstr_modtype x ->
+      line i ppf "Pstr_modtype %a\n" fmt_string_loc x.pmtd_name;
+      attributes i ppf x.pmtd_attributes;
+      modtype_declaration i ppf x.pmtd_type
+  | Pstr_open od ->
+      line i ppf "Pstr_open %a\n" fmt_override_flag od.popen_override;
+      module_expr i ppf od.popen_expr;
+      attributes i ppf od.popen_attributes
+  | Pstr_class (l) ->
+      line i ppf "Pstr_class\n";
+      list i class_declaration ppf l;
+  | Pstr_class_type (l) ->
+      line i ppf "Pstr_class_type\n";
+      list i class_type_declaration ppf l;
+  | Pstr_include incl ->
+      line i ppf "Pstr_include";
+      attributes i ppf incl.pincl_attributes;
+      module_expr i ppf incl.pincl_mod
+  | Pstr_extension ((s, arg), attrs) ->
+      line i ppf "Pstr_extension \"%s\"\n" s.txt;
+      attributes i ppf attrs;
+      payload i ppf arg
+  | Pstr_attribute a ->
+      attribute i ppf "Pstr_attribute" a
+
+and module_declaration i ppf pmd =
+  str_opt_loc i ppf pmd.pmd_name;
+  attributes i ppf pmd.pmd_attributes;
+  module_type (i+1) ppf pmd.pmd_type;
+
+and module_binding i ppf x =
+  str_opt_loc i ppf x.pmb_name;
+  attributes i ppf x.pmb_attributes;
+  module_expr (i+1) ppf x.pmb_expr
+
+and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
+  line i ppf "<constraint> %a\n" fmt_location l;
+  core_type (i+1) ppf ct1;
+  core_type (i+1) ppf ct2;
+
+and constructor_decl i ppf
+                     {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} =
+  line i ppf "%a\n" fmt_location pcd_loc;
+  line (i+1) ppf "%a\n" fmt_string_loc pcd_name;
+  attributes i ppf pcd_attributes;
+  constructor_arguments (i+1) ppf pcd_args;
+  option (i+1) core_type ppf pcd_res
+
+and constructor_arguments i ppf = function
+  | Pcstr_tuple l -> list i core_type ppf l
+  | Pcstr_record l -> list i label_decl ppf l
+
+and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes}=
+  line i ppf "%a\n" fmt_location pld_loc;
+  attributes i ppf pld_attributes;
+  line (i+1) ppf "%a\n" fmt_mutable_flag pld_mutable;
+  line (i+1) ppf "%a" fmt_string_loc pld_name;
+  core_type (i+1) ppf pld_type
+
+and longident_x_pattern i ppf (li, p) =
+  line i ppf "%a\n" fmt_longident_loc li;
+  pattern (i+1) ppf p;
+
+and case i ppf {pc_lhs; pc_guard; pc_rhs} =
+  line i ppf "<case>\n";
+  pattern (i+1) ppf pc_lhs;
+  begin match pc_guard with
+  | None -> ()
+  | Some g -> line (i+1) ppf "<when>\n"; expression (i + 2) ppf g
+  end;
+  expression (i+1) ppf pc_rhs;
+
+and value_binding i ppf x =
+  line i ppf "<def>\n";
+  attributes (i+1) ppf x.pvb_attributes;
+  pattern (i+1) ppf x.pvb_pat;
+  expression (i+1) ppf x.pvb_expr
+
+and binding_op i ppf x =
+  line i ppf "<binding_op> %a %a"
+    fmt_string_loc x.pbop_op fmt_location x.pbop_loc;
+  pattern (i+1) ppf x.pbop_pat;
+  expression (i+1) ppf x.pbop_exp;
+
+and string_x_expression i ppf (s, e) =
+  line i ppf "<override> %a\n" fmt_string_loc s;
+  expression (i+1) ppf e;
+
+and longident_x_expression i ppf (li, e) =
+  line i ppf "%a\n" fmt_longident_loc li;
+  expression (i+1) ppf e;
+
+and label_x_expression i ppf (l,e) =
+  line i ppf "<arg>\n";
+  arg_label i ppf l;
+  expression (i+1) ppf e;
+
+and label_x_bool_x_core_type_list i ppf x =
+  match x.prf_desc with
+    Rtag (l, b, ctl) ->
+      line i ppf "Rtag \"%s\" %s\n" l.txt (string_of_bool b);
+      attributes (i+1) ppf x.prf_attributes;
+      list (i+1) core_type ppf ctl
+  | Rinherit (ct) ->
+      line i ppf "Rinherit\n";
+      core_type (i+1) ppf ct
+;;
+
+let rec toplevel_phrase i ppf x =
+  match x with
+  | Ptop_def (s) ->
+      line i ppf "Ptop_def\n";
+      structure (i+1) ppf s;
+  | Ptop_dir {pdir_name; pdir_arg; _} ->
+      line i ppf "Ptop_dir \"%s\"\n" pdir_name.txt;
+      match pdir_arg with
+      | None -> ()
+      | Some da -> directive_argument i ppf da;
+
+and directive_argument i ppf x =
+  match x.pdira_desc with
+  | Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s;
+  | Pdir_int (n, None) -> line i ppf "Pdir_int %s\n" n;
+  | Pdir_int (n, Some m) -> line i ppf "Pdir_int %s%c\n" n m;
+  | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident li;
+  | Pdir_bool (b) -> line i ppf "Pdir_bool %s\n" (string_of_bool b);
+;;
+
+let interface ppf x = list 0 signature_item ppf x;;
+
+let implementation ppf x = list 0 structure_item ppf x;;
+
+let top_phrase ppf x = toplevel_phrase 0 ppf x;;
diff --git a/upstream/ocaml_413/parsing/printast.mli b/upstream/ocaml_413/parsing/printast.mli
new file mode 100644
index 0000000..8215654
--- /dev/null
+++ b/upstream/ocaml_413/parsing/printast.mli
@@ -0,0 +1,32 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*              Damien Doligez, projet Para, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Raw printer for {!Parsetree}
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Parsetree;;
+open Format;;
+
+val interface : formatter -> signature_item list -> unit;;
+val implementation : formatter -> structure_item list -> unit;;
+val top_phrase : formatter -> toplevel_phrase -> unit;;
+
+val expression: int -> formatter -> expression -> unit
+val structure: int -> formatter -> structure -> unit
+val payload: int -> formatter -> payload -> unit
diff --git a/upstream/ocaml_413/parsing/syntaxerr.ml b/upstream/ocaml_413/parsing/syntaxerr.ml
new file mode 100644
index 0000000..49372b9
--- /dev/null
+++ b/upstream/ocaml_413/parsing/syntaxerr.ml
@@ -0,0 +1,43 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Auxiliary type for reporting syntax errors *)
+
+type error =
+    Unclosed of Location.t * string * Location.t * string
+  | Expecting of Location.t * string
+  | Not_expecting of Location.t * string
+  | Applicative_path of Location.t
+  | Variable_in_scope of Location.t * string
+  | Other of Location.t
+  | Ill_formed_ast of Location.t * string
+  | Invalid_package_type of Location.t * string
+
+exception Error of error
+exception Escape_error
+
+let location_of_error = function
+  | Unclosed(l,_,_,_)
+  | Applicative_path l
+  | Variable_in_scope(l,_)
+  | Other l
+  | Not_expecting (l, _)
+  | Ill_formed_ast (l, _)
+  | Invalid_package_type (l, _)
+  | Expecting (l, _) -> l
+
+
+let ill_formed_ast loc s =
+  raise (Error (Ill_formed_ast (loc, s)))
diff --git a/upstream/ocaml_413/parsing/syntaxerr.mli b/upstream/ocaml_413/parsing/syntaxerr.mli
new file mode 100644
index 0000000..26ba712
--- /dev/null
+++ b/upstream/ocaml_413/parsing/syntaxerr.mli
@@ -0,0 +1,37 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Auxiliary type for reporting syntax errors
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type error =
+    Unclosed of Location.t * string * Location.t * string
+  | Expecting of Location.t * string
+  | Not_expecting of Location.t * string
+  | Applicative_path of Location.t
+  | Variable_in_scope of Location.t * string
+  | Other of Location.t
+  | Ill_formed_ast of Location.t * string
+  | Invalid_package_type of Location.t * string
+
+exception Error of error
+exception Escape_error
+
+val location_of_error: error -> Location.t
+val ill_formed_ast: Location.t -> string -> 'a
diff --git a/upstream/ocaml_413/typing/HACKING.adoc b/upstream/ocaml_413/typing/HACKING.adoc
new file mode 100644
index 0000000..8633ef5
--- /dev/null
+++ b/upstream/ocaml_413/typing/HACKING.adoc
@@ -0,0 +1,58 @@
+The implementation of the OCaml typechecker is complex. Modifying it
+will need a good understanding of the OCaml type system and type
+inference. Here is a reading list to ease your discovery of the
+typechecker:
+
+http://caml.inria.fr/pub/docs/u3-ocaml/index.html[Using, Understanding, and Unraveling the OCaml Language by Didier R&eacute;my] ::
+This book provides (among other things) a formal description of parts
+of the core OCaml language, starting with a simple Core ML.
+
+http://okmij.org/ftp/ML/generalization.html[Efficient and Insightful Generalization by Oleg Kiselyov] ::
+This article describes the basis of the type inference algorithm used
+by the OCaml type checker. It is a recommended read if you want to
+understand the type-checker codebase, in particular its handling of
+polymorphism/generalization.
+
+After that, it is best to dive right in. There is no real "entry
+point", but an understanding of both the parsetree and the typedtree
+is necessary.
+
+The datastructures ::
+link:types.mli[Types] and link:typedtree.mli[Typedtree]
+are the two main datastructures in the typechecker. They correspond to
+the source code annotated with all the information needed for type
+checking and type inference. link:env.mli[Env] contains all the
+environments that are used in the typechecker. Each node in the
+typedtree is annotated with the local environment in which it was
+type-checked.
+
+Core utilities ::
+link:btype.mli[Btype] and link:ctype.mli[Ctype] contain
+the various low-level function needed for typing, in particular
+related to levels, unification and
+backtracking. link:mtype.mli[Mtype] contains utilities related
+to modules.
+
+Inference and checking::
+The `Type..` modules are related to inference and typechecking, each
+for a different part of the language:
+link:typetexp.mli[Typetexp] for type expressions,
+link:typecore.mli[Typecore] for the core language,
+link:typemod.mli[Typemod] for modules,
+link:typedecl.mli[Typedecl] for type declarations and finally
+link:typeclass.mli[Typeclass] for the object system.
+
+Inclusion/Module subtyping::
+Handling of inclusion relations are separated in the `Include...`
+modules: link:includecore.ml[Includecore] for the type and
+value declarations, link:includemod.mli[Includemod] for modules
+and finally link:includeclass.mli[Includeclass] for the object
+system.
+
+Dependencies between modules::
+Most of the modules presented above are inter-dependent. Since OCaml
+does not permit circular dependencies between files, the
+implementation uses forward declarations, implemented with references
+to functions that are filled later on. An example can be seen in
+link:typecore.ml[Typecore.type_module], which is filled in
+link:typemod.ml[Typemod].
diff --git a/upstream/ocaml_413/typing/TODO.md b/upstream/ocaml_413/typing/TODO.md
new file mode 100644
index 0000000..c115116
--- /dev/null
+++ b/upstream/ocaml_413/typing/TODO.md
@@ -0,0 +1,101 @@
+TODO for the OCaml typechecker implementation
+=============================================
+
+There is a consensus that the current implementation of the OCaml
+typechecker is overly complex and fragile.  A big rewriting "from
+scratch" might be possible or desirable at some point, or not, but
+incremental cleanup steps are certainly accessible and could bring the
+current implementation in a better shape at a relatively small cost
+and in a reasonably distant future.
+
+Goals of the cleanup:
+
+ - Make the implementation more maintainable and less fragile.
+
+ - Allow new contributors, or people involved in bigger rewriting
+   projects, to get familiar with the code base more easily.
+
+ - Pave the way for future extensions or bigger structural changes to
+   the implementation.
+
+This file collects specific cleanup ideas which have been discussed
+amongst maintainers.  Having the list committed in the repo allows for
+everyone to get an idea of planned tasks, refine them through Pull
+Requests, suggest more cleanups, or even start working on specific
+tasks (ideally after discussing it first with maintainers).
+
+# Code smells
+
+- global mutable state
+- poor data representation
+- avoid constructing a parsetree locally
+  (methods build a piece of AST with a self argument
+   with a *-using name to avoid conflicts; #row, etc.)
+- avoid magic string literals
+
+# TODO List
+
+Not all ideas have been thoroughly discussed, and there might not be a
+consensus for all of them.
+
+- Make the level generator be part of `Env.t` instead of being global.
+
+- Introduce an abstraction boundary between "the type algebra" and
+  "the type checker" (at first between Ctype and Typecore) so that the
+  type checker is forced to go through a proper API to access/mutate
+  type nodes.  This would make it impossible to "forget" a call
+  to `repr` and will allow further changes on the internal representation.
+
+- Tidy up Typeclass (use records instead of 14-tuples, avoid
+  "#"-encoding, etc).
+
+- Collect all global state of the type checker in a single place,
+  possibly a single reference to a persistent data structure
+  (e.g. maps instead of hashtables).
+
+- Get rid of Tsubst.  With the unique ids on each type node, copying
+  can be implemented rather efficiently with a map.
+
+- Document row_desc, get rid of row_bound.
+
+- Implement union-find with a more abstract/persistent datastructure
+  (be careful about memory leaks with the naive approach of representing
+  links with a persistent heap).
+
+  Modest version of the proposal: have an explicit indirection layer
+    (type_expr Unode.t)
+  for nodes in the union-find structure. Efficiency cost?
+
+- Make the logic for record/constructor disambiguation more readable.
+
+  (Jacques should write a specification, and then we could try
+  to make the implementation easier for others to understand.)
+
+- Tidy up destructive substitution.
+
+- Get rid of syntactic encodings (generating Parsetree fragments
+  during type-checking, cf optional arguments or classes).
+
+- Track "string literals" in the type-checker, which often act as
+  magic "internal" names which should be avoided.
+
+- Consider storing warning settings (+other context) as part of `Env.t`?
+
+- Parse attributes understood (e.g. the deprecated attribute) by the
+  compiler into a structured representation during type-checking.
+
+- Introduce a notion of syntactic "path-like location" to point to
+  allow pointing to AST fragments, and use that to implement "unused"
+  warnings in a less invasive and less imperative way.
+  (See Thomas' PR)
+
+- Deprecate -nolabels, or even get rid of it?
+  (We could even stop supporting unlabeled full applications.
+   First turn on the warning by default.)
+
+- Using e.g. bisect_ppx, monitor coverage of the typechecker
+  implementation while running the testsuite, and expand the testsuite
+  and/or kill dead code in the typechecker to increase coverage ratio.
+  (Partially done by Oxana's Outreachy internship.
+   See PR#8874.
+   Ask Florian Angeletti and Sebastien Hinderer about the current state.)
diff --git a/upstream/ocaml_413/typing/annot.mli b/upstream/ocaml_413/typing/annot.mli
new file mode 100644
index 0000000..3cae8f2
--- /dev/null
+++ b/upstream/ocaml_413/typing/annot.mli
@@ -0,0 +1,24 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Data types for annotations (Stypes.ml) *)
+
+type call = Tail | Stack | Inline;;
+
+type ident =
+  | Iref_internal of Location.t (* defining occurrence *)
+  | Iref_external
+  | Idef of Location.t          (* scope *)
+;;
diff --git a/upstream/ocaml_413/typing/btype.ml b/upstream/ocaml_413/typing/btype.ml
new file mode 100644
index 0000000..a18f53d
--- /dev/null
+++ b/upstream/ocaml_413/typing/btype.ml
@@ -0,0 +1,828 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Basic operations on core types *)
+
+open Asttypes
+open Types
+
+open Local_store
+
+(**** Sets, maps and hashtables of types ****)
+
+module TypeSet = Set.Make(TypeOps)
+module TypeMap = Map.Make (TypeOps)
+module TypeHash = Hashtbl.Make(TypeOps)
+
+(**** Forward declarations ****)
+
+let print_raw =
+  ref (fun _ -> assert false : Format.formatter -> type_expr -> unit)
+
+(**** Type level management ****)
+
+let generic_level = Ident.highest_scope
+
+(* Used to mark a type during a traversal. *)
+let lowest_level = Ident.lowest_scope
+let pivot_level = 2 * lowest_level - 1
+    (* pivot_level - lowest_level < lowest_level *)
+
+(**** Some type creators ****)
+
+let new_id = s_ref (-1)
+
+let newty2 level desc  =
+  incr new_id;
+  Private_type_expr.create desc ~level ~scope:lowest_level ~id:!new_id
+let newgenty desc      = newty2 generic_level desc
+let newgenvar ?name () = newgenty (Tvar name)
+(*
+let newmarkedvar level =
+  incr new_id; { desc = Tvar; level = pivot_level - level; id = !new_id }
+let newmarkedgenvar () =
+  incr new_id;
+  { desc = Tvar; level = pivot_level - generic_level; id = !new_id }
+*)
+
+(**** Check some types ****)
+
+let is_Tvar = function {desc=Tvar _} -> true | _ -> false
+let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false
+let is_Tconstr = function {desc=Tconstr _} -> true | _ -> false
+
+let dummy_method = "*dummy method*"
+
+(**** Definitions for backtracking ****)
+
+type change =
+    Ctype of type_expr * type_desc
+  | Ccompress of type_expr * type_desc * type_desc
+  | Clevel of type_expr * int
+  | Cscope of type_expr * int
+  | Cname of
+      (Path.t * type_expr list) option ref * (Path.t * type_expr list) option
+  | Crow of row_field option ref * row_field option
+  | Ckind of field_kind option ref * field_kind option
+  | Ccommu of commutable ref * commutable
+  | Cuniv of type_expr option ref * type_expr option
+
+type changes =
+    Change of change * changes ref
+  | Unchanged
+  | Invalid
+
+let trail = s_table ref Unchanged
+
+let log_change ch =
+  let r' = ref Unchanged in
+  !trail := Change (ch, r');
+  trail := r'
+
+(**** Representative of a type ****)
+
+let rec field_kind_repr =
+  function
+    Fvar {contents = Some kind} -> field_kind_repr kind
+  | kind                        -> kind
+
+let rec repr_link compress (t : type_expr) d : type_expr -> type_expr =
+ function
+   {desc = Tlink t' as d'} ->
+     repr_link true t d' t'
+ | {desc = Tfield (_, k, _, t') as d'} when field_kind_repr k = Fabsent ->
+     repr_link true t d' t'
+ | t' ->
+     if compress then begin
+       log_change (Ccompress (t, t.desc, d)); Private_type_expr.set_desc t d
+     end;
+     t'
+
+let repr (t : type_expr) =
+  match t.desc with
+   Tlink t' as d ->
+     repr_link false t d t'
+ | Tfield (_, k, _, t') as d when field_kind_repr k = Fabsent ->
+     repr_link false t d t'
+ | _ -> t
+
+let rec commu_repr = function
+    Clink r when !r <> Cunknown -> commu_repr !r
+  | c -> c
+
+let rec row_field_repr_aux tl = function
+    Reither(_, tl', _, {contents = Some fi}) ->
+      row_field_repr_aux (tl@tl') fi
+  | Reither(c, tl', m, r) ->
+      Reither(c, tl@tl', m, r)
+  | Rpresent (Some _) when tl <> [] ->
+      Rpresent (Some (List.hd tl))
+  | fi -> fi
+
+let row_field_repr fi = row_field_repr_aux [] fi
+
+let rec rev_concat l ll =
+  match ll with
+    [] -> l
+  | l'::ll -> rev_concat (l'@l) ll
+
+let rec row_repr_aux ll row =
+  match (repr row.row_more).desc with
+  | Tvariant row' ->
+      let f = row.row_fields in
+      row_repr_aux (if f = [] then ll else f::ll) row'
+  | _ ->
+      if ll = [] then row else
+      {row with row_fields = rev_concat row.row_fields ll}
+
+let row_repr row = row_repr_aux [] row
+
+let rec row_field tag row =
+  let rec find = function
+    | (tag',f) :: fields ->
+        if tag = tag' then row_field_repr f else find fields
+    | [] ->
+        match repr row.row_more with
+        | {desc=Tvariant row'} -> row_field tag row'
+        | _ -> Rabsent
+  in find row.row_fields
+
+let rec row_more row =
+  match repr row.row_more with
+  | {desc=Tvariant row'} -> row_more row'
+  | ty -> ty
+
+let merge_fixed_explanation fixed1 fixed2 =
+  match fixed1, fixed2 with
+  | Some Univar _ as x, _ | _, (Some Univar _ as x) -> x
+  | Some Fixed_private as x, _ | _, (Some Fixed_private as x) -> x
+  | Some Reified _ as x, _ | _, (Some Reified _ as x) -> x
+  | Some Rigid as x, _ | _, (Some Rigid as x) -> x
+  | None, None -> None
+
+
+let fixed_explanation row =
+  let row = row_repr row in
+  match row.row_fixed with
+  | Some _ as x -> x
+  | None ->
+      let more = repr row.row_more in
+      match more.desc with
+      | Tvar _ | Tnil -> None
+      | Tunivar _ -> Some (Univar more)
+      | Tconstr (p,_,_) -> Some (Reified p)
+      | _ -> assert false
+
+let is_fixed row = match row.row_fixed with
+  | None -> false
+  | Some _ -> true
+
+let row_fixed row = fixed_explanation row <> None
+
+
+let static_row row =
+  let row = row_repr row in
+  row.row_closed &&
+  List.for_all
+    (fun (_,f) -> match row_field_repr f with Reither _ -> false | _ -> true)
+    row.row_fields
+
+let hash_variant s =
+  let accu = ref 0 in
+  for i = 0 to String.length s - 1 do
+    accu := 223 * !accu + Char.code s.[i]
+  done;
+  (* reduce to 31 bits *)
+  accu := !accu land (1 lsl 31 - 1);
+  (* make it signed for 64 bits architectures *)
+  if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu
+
+let proxy ty =
+  let ty0 = repr ty in
+  match ty0.desc with
+  | Tvariant row when not (static_row row) ->
+      row_more row
+  | Tobject (ty, _) ->
+      let rec proxy_obj ty =
+        match ty.desc with
+          Tfield (_, _, _, ty) | Tlink ty -> proxy_obj ty
+        | Tvar _ | Tunivar _ | Tconstr _ -> ty
+        | Tnil -> ty0
+        | _ -> assert false
+      in proxy_obj ty
+  | _ -> ty0
+
+(**** Utilities for fixed row private types ****)
+
+let row_of_type t =
+  match (repr t).desc with
+    Tobject(t,_) ->
+      let rec get_row t =
+        let t = repr t in
+        match t.desc with
+          Tfield(_,_,_,t) -> get_row t
+        | _ -> t
+      in get_row t
+  | Tvariant row ->
+      row_more row
+  | _ ->
+      t
+
+let has_constr_row t =
+  not (is_Tconstr t) && is_Tconstr (row_of_type t)
+
+let is_row_name s =
+  let l = String.length s in
+  (* PR#10661: when l=4 and s is "#row", this is not a row name
+     but the valid #-type name of a class named "row". *)
+  l > 4 && String.sub s (l-4) 4 = "#row"
+
+let is_constr_row ~allow_ident t =
+  match t.desc with
+    Tconstr (Path.Pident id, _, _) when allow_ident ->
+      is_row_name (Ident.name id)
+  | Tconstr (Path.Pdot (_, s), _, _) -> is_row_name s
+  | _ -> false
+
+(* TODO: where should this really be *)
+(* Set row_name in Env, cf. GPR#1204/1329 *)
+let set_row_name decl path =
+  match decl.type_manifest with
+    None -> ()
+  | Some ty ->
+      let ty = repr ty in
+      match ty.desc with
+        Tvariant row when static_row row ->
+          let row = {(row_repr row) with
+                     row_name = Some (path, decl.type_params)} in
+          Private_type_expr.set_desc ty (Tvariant row)
+      | _ -> ()
+
+
+                  (**********************************)
+                  (*  Utilities for type traversal  *)
+                  (**********************************)
+
+let rec fold_row f init row =
+  let result =
+    List.fold_left
+      (fun init (_, fi) ->
+         match row_field_repr fi with
+         | Rpresent(Some ty) -> f init ty
+         | Reither(_, tl, _, _) -> List.fold_left f init tl
+         | _ -> init)
+      init
+      row.row_fields
+  in
+  match (repr row.row_more).desc with
+    Tvariant row -> fold_row f result row
+  | Tvar _ | Tunivar _ | Tsubst _ | Tconstr _ | Tnil ->
+    begin match
+      Option.map (fun (_,l) -> List.fold_left f result l) row.row_name
+    with
+    | None -> result
+    | Some result -> result
+    end
+  | _ -> assert false
+
+let iter_row f row =
+  fold_row (fun () v -> f v) () row
+
+let rec fold_type_expr f init ty =
+  match ty.desc with
+    Tvar _              -> init
+  | Tarrow (_, ty1, ty2, _) ->
+    let result = f init ty1 in
+    f result ty2
+  | Ttuple l            -> List.fold_left f init l
+  | Tconstr (_, l, _)   -> List.fold_left f init l
+  | Tobject(ty, {contents = Some (_, p)})
+    ->
+    let result = f init ty in
+    List.fold_left f result p
+  | Tobject (ty, _)     -> f init ty
+  | Tvariant row        ->
+    let result = fold_row f init row in
+    f result (row_more row)
+  | Tfield (_, _, ty1, ty2) ->
+    let result = f init ty1 in
+    f result ty2
+  | Tnil                -> init
+  | Tlink ty            -> fold_type_expr f init ty
+  | Tsubst _            -> assert false
+  | Tunivar _           -> init
+  | Tpoly (ty, tyl)     ->
+    let result = f init ty in
+    List.fold_left f result tyl
+  | Tpackage (_, fl)  ->
+    List.fold_left (fun result (_n, ty) -> f result ty) init fl
+
+let iter_type_expr f ty =
+  fold_type_expr (fun () v -> f v) () ty
+
+let rec iter_abbrev f = function
+    Mnil                   -> ()
+  | Mcons(_, _, ty, ty', rem) -> f ty; f ty'; iter_abbrev f rem
+  | Mlink rem              -> iter_abbrev f !rem
+
+type type_iterators =
+  { it_signature: type_iterators -> signature -> unit;
+    it_signature_item: type_iterators -> signature_item -> unit;
+    it_value_description: type_iterators -> value_description -> unit;
+    it_type_declaration: type_iterators -> type_declaration -> unit;
+    it_extension_constructor: type_iterators -> extension_constructor -> unit;
+    it_module_declaration: type_iterators -> module_declaration -> unit;
+    it_modtype_declaration: type_iterators -> modtype_declaration -> unit;
+    it_class_declaration: type_iterators -> class_declaration -> unit;
+    it_class_type_declaration: type_iterators -> class_type_declaration -> unit;
+    it_functor_param: type_iterators -> functor_parameter -> unit;
+    it_module_type: type_iterators -> module_type -> unit;
+    it_class_type: type_iterators -> class_type -> unit;
+    it_type_kind: type_iterators -> type_decl_kind -> unit;
+    it_do_type_expr: type_iterators -> type_expr -> unit;
+    it_type_expr: type_iterators -> type_expr -> unit;
+    it_path: Path.t -> unit; }
+
+let iter_type_expr_cstr_args f = function
+  | Cstr_tuple tl -> List.iter f tl
+  | Cstr_record lbls -> List.iter (fun d -> f d.ld_type) lbls
+
+let map_type_expr_cstr_args f = function
+  | Cstr_tuple tl -> Cstr_tuple (List.map f tl)
+  | Cstr_record lbls ->
+      Cstr_record (List.map (fun d -> {d with ld_type=f d.ld_type}) lbls)
+
+let iter_type_expr_kind f = function
+  | Type_abstract -> ()
+  | Type_variant (cstrs, _) ->
+      List.iter
+        (fun cd ->
+           iter_type_expr_cstr_args f cd.cd_args;
+           Option.iter f cd.cd_res
+        )
+        cstrs
+  | Type_record(lbls, _) ->
+      List.iter (fun d -> f d.ld_type) lbls
+  | Type_open ->
+      ()
+
+
+let type_iterators =
+  let it_signature it =
+    List.iter (it.it_signature_item it)
+  and it_signature_item it = function
+      Sig_value (_, vd, _)          -> it.it_value_description it vd
+    | Sig_type (_, td, _, _)        -> it.it_type_declaration it td
+    | Sig_typext (_, td, _, _)      -> it.it_extension_constructor it td
+    | Sig_module (_, _, md, _, _)   -> it.it_module_declaration it md
+    | Sig_modtype (_, mtd, _)       -> it.it_modtype_declaration it mtd
+    | Sig_class (_, cd, _, _)       -> it.it_class_declaration it cd
+    | Sig_class_type (_, ctd, _, _) -> it.it_class_type_declaration it ctd
+  and it_value_description it vd =
+    it.it_type_expr it vd.val_type
+  and it_type_declaration it td =
+    List.iter (it.it_type_expr it) td.type_params;
+    Option.iter (it.it_type_expr it) td.type_manifest;
+    it.it_type_kind it td.type_kind
+  and it_extension_constructor it td =
+    it.it_path td.ext_type_path;
+    List.iter (it.it_type_expr it) td.ext_type_params;
+    iter_type_expr_cstr_args (it.it_type_expr it) td.ext_args;
+    Option.iter (it.it_type_expr it) td.ext_ret_type
+  and it_module_declaration it md =
+    it.it_module_type it md.md_type
+  and it_modtype_declaration it mtd =
+    Option.iter (it.it_module_type it) mtd.mtd_type
+  and it_class_declaration it cd =
+    List.iter (it.it_type_expr it) cd.cty_params;
+    it.it_class_type it cd.cty_type;
+    Option.iter (it.it_type_expr it) cd.cty_new;
+    it.it_path cd.cty_path
+  and it_class_type_declaration it ctd =
+    List.iter (it.it_type_expr it) ctd.clty_params;
+    it.it_class_type it ctd.clty_type;
+    it.it_path ctd.clty_path
+  and it_functor_param it = function
+    | Unit -> ()
+    | Named (_, mt) -> it.it_module_type it mt
+  and it_module_type it = function
+      Mty_ident p
+    | Mty_alias p -> it.it_path p
+    | Mty_signature sg -> it.it_signature it sg
+    | Mty_functor (p, mt) ->
+        it.it_functor_param it p;
+        it.it_module_type it mt
+  and it_class_type it = function
+      Cty_constr (p, tyl, cty) ->
+        it.it_path p;
+        List.iter (it.it_type_expr it) tyl;
+        it.it_class_type it cty
+    | Cty_signature cs ->
+        it.it_type_expr it cs.csig_self;
+        Vars.iter (fun _ (_,_,ty) -> it.it_type_expr it ty) cs.csig_vars;
+        List.iter
+          (fun (p, tl) -> it.it_path p; List.iter (it.it_type_expr it) tl)
+          cs.csig_inher
+    | Cty_arrow  (_, ty, cty) ->
+        it.it_type_expr it ty;
+        it.it_class_type it cty
+  and it_type_kind it kind =
+    iter_type_expr_kind (it.it_type_expr it) kind
+  and it_do_type_expr it ty =
+    iter_type_expr (it.it_type_expr it) ty;
+    match ty.desc with
+      Tconstr (p, _, _)
+    | Tobject (_, {contents=Some (p, _)})
+    | Tpackage (p, _) ->
+        it.it_path p
+    | Tvariant row ->
+        Option.iter (fun (p,_) -> it.it_path p) (row_repr row).row_name
+    | _ -> ()
+  and it_path _p = ()
+  in
+  { it_path; it_type_expr = it_do_type_expr; it_do_type_expr;
+    it_type_kind; it_class_type; it_functor_param; it_module_type;
+    it_signature; it_class_type_declaration; it_class_declaration;
+    it_modtype_declaration; it_module_declaration; it_extension_constructor;
+    it_type_declaration; it_value_description; it_signature_item; }
+
+let copy_row f fixed row keep more =
+  let fields = List.map
+      (fun (l, fi) -> l,
+        match row_field_repr fi with
+        | Rpresent(Some ty) -> Rpresent(Some(f ty))
+        | Reither(c, tl, m, e) ->
+            let e = if keep then e else ref None in
+            let m = if is_fixed row then fixed else m in
+            let tl = List.map f tl in
+            Reither(c, tl, m, e)
+        | _ -> fi)
+      row.row_fields in
+  let name =
+    match row.row_name with
+    | None -> None
+    | Some (path, tl) -> Some (path, List.map f tl) in
+  let row_fixed = if fixed then row.row_fixed else None in
+  { row_fields = fields; row_more = more;
+    row_bound = (); row_fixed;
+    row_closed = row.row_closed; row_name = name; }
+
+let rec copy_kind = function
+    Fvar{contents = Some k} -> copy_kind k
+  | Fvar _   -> Fvar (ref None)
+  | Fpresent -> Fpresent
+  | Fabsent  -> assert false
+
+let copy_commu c =
+  if commu_repr c = Cok then Cok else Clink (ref Cunknown)
+
+let rec copy_type_desc ?(keep_names=false) f = function
+    Tvar _ as ty        -> if keep_names then ty else Tvar None
+  | Tarrow (p, ty1, ty2, c)-> Tarrow (p, f ty1, f ty2, copy_commu c)
+  | Ttuple l            -> Ttuple (List.map f l)
+  | Tconstr (p, l, _)   -> Tconstr (p, List.map f l, ref Mnil)
+  | Tobject(ty, {contents = Some (p, tl)})
+                        -> Tobject (f ty, ref (Some(p, List.map f tl)))
+  | Tobject (ty, _)     -> Tobject (f ty, ref None)
+  | Tvariant _          -> assert false (* too ambiguous *)
+  | Tfield (p, k, ty1, ty2) -> (* the kind is kept shared *)
+      Tfield (p, field_kind_repr k, f ty1, f ty2)
+  | Tnil                -> Tnil
+  | Tlink ty            -> copy_type_desc f ty.desc
+  | Tsubst _            -> assert false
+  | Tunivar _ as ty     -> ty (* always keep the name *)
+  | Tpoly (ty, tyl)     ->
+      let tyl = List.map f tyl in
+      Tpoly (f ty, tyl)
+  | Tpackage (p, fl)  -> Tpackage (p, List.map (fun (n, ty) -> (n, f ty)) fl)
+
+(* Utilities for copying *)
+
+module For_copy : sig
+  type copy_scope
+
+  val save_desc: copy_scope -> type_expr -> type_desc -> unit
+
+  val dup_kind: copy_scope -> field_kind option ref -> unit
+
+  val with_scope: (copy_scope -> 'a) -> 'a
+end = struct
+  type copy_scope = {
+    mutable saved_desc : (type_expr * type_desc) list;
+    (* Save association of generic nodes with their description. *)
+
+    mutable saved_kinds: field_kind option ref list;
+    (* duplicated kind variables *)
+
+    mutable new_kinds  : field_kind option ref list;
+    (* new kind variables *)
+  }
+
+  let save_desc copy_scope ty desc =
+    copy_scope.saved_desc <- (ty, desc) :: copy_scope.saved_desc
+
+  let dup_kind copy_scope r =
+    assert (Option.is_none !r);
+    if not (List.memq r copy_scope.new_kinds) then begin
+      copy_scope.saved_kinds <- r :: copy_scope.saved_kinds;
+      let r' = ref None in
+      copy_scope.new_kinds <- r' :: copy_scope.new_kinds;
+      r := Some (Fvar r')
+    end
+
+  (* Restore type descriptions. *)
+  let cleanup { saved_desc; saved_kinds; _ } =
+    List.iter (fun (ty, desc) -> Private_type_expr.set_desc ty desc) saved_desc;
+    List.iter (fun r -> r := None) saved_kinds
+
+  let with_scope f =
+    let scope = { saved_desc = []; saved_kinds = []; new_kinds = [] } in
+    let res = f scope in
+    cleanup scope;
+    res
+end
+
+
+                  (*******************************************)
+                  (*  Memorization of abbreviation expansion *)
+                  (*******************************************)
+
+(* Search whether the expansion has been memorized. *)
+
+let lte_public p1 p2 =  (* Private <= Public *)
+  match p1, p2 with
+  | Private, _ | _, Public -> true
+  | Public, Private -> false
+
+let rec find_expans priv p1 = function
+    Mnil -> None
+  | Mcons (priv', p2, _ty0, ty, _)
+    when lte_public priv priv' && Path.same p1 p2 -> Some ty
+  | Mcons (_, _, _, _, rem)   -> find_expans priv p1 rem
+  | Mlink {contents = rem} -> find_expans priv p1 rem
+
+(* debug: check for cycles in abbreviation. only works with -principal
+let rec check_expans visited ty =
+  let ty = repr ty in
+  assert (not (List.memq ty visited));
+  match ty.desc with
+    Tconstr (path, args, abbrev) ->
+      begin match find_expans path !abbrev with
+        Some ty' -> check_expans (ty :: visited) ty'
+      | None -> ()
+      end
+  | _ -> ()
+*)
+
+let memo = s_ref []
+        (* Contains the list of saved abbreviation expansions. *)
+
+let cleanup_abbrev () =
+        (* Remove all memorized abbreviation expansions. *)
+  List.iter (fun abbr -> abbr := Mnil) !memo;
+  memo := []
+
+let memorize_abbrev mem priv path v v' =
+        (* Memorize the expansion of an abbreviation. *)
+  mem := Mcons (priv, path, v, v', !mem);
+  (* check_expans [] v; *)
+  memo := mem :: !memo
+
+let rec forget_abbrev_rec mem path =
+  match mem with
+    Mnil ->
+      mem
+  | Mcons (_, path', _, _, rem) when Path.same path path' ->
+      rem
+  | Mcons (priv, path', v, v', rem) ->
+      Mcons (priv, path', v, v', forget_abbrev_rec rem path)
+  | Mlink mem' ->
+      mem' := forget_abbrev_rec !mem' path;
+      raise Exit
+
+let forget_abbrev mem path =
+  try mem := forget_abbrev_rec !mem path with Exit -> ()
+
+(* debug: check for invalid abbreviations
+let rec check_abbrev_rec = function
+    Mnil -> true
+  | Mcons (_, ty1, ty2, rem) ->
+      repr ty1 != repr ty2
+  | Mlink mem' ->
+      check_abbrev_rec !mem'
+
+let check_memorized_abbrevs () =
+  List.for_all (fun mem -> check_abbrev_rec !mem) !memo
+*)
+
+                  (**********************************)
+                  (*  Utilities for labels          *)
+                  (**********************************)
+
+let is_optional = function Optional _ -> true | _ -> false
+
+let label_name = function
+    Nolabel -> ""
+  | Labelled s
+  | Optional s -> s
+
+let prefixed_label_name = function
+    Nolabel -> ""
+  | Labelled s -> "~" ^ s
+  | Optional s -> "?" ^ s
+
+let rec extract_label_aux hd l = function
+  | [] -> None
+  | (l',t as p) :: ls ->
+      if label_name l' = l then
+        Some (l', t, hd <> [], List.rev_append hd ls)
+      else
+        extract_label_aux (p::hd) l ls
+
+let extract_label l ls = extract_label_aux [] l ls
+
+
+                  (**********************************)
+                  (*  Utilities for backtracking    *)
+                  (**********************************)
+
+let undo_change = function
+    Ctype  (ty, desc) -> Private_type_expr.set_desc ty desc
+  | Ccompress  (ty, desc, _) -> Private_type_expr.set_desc ty desc
+  | Clevel (ty, level) -> Private_type_expr.set_level ty level
+  | Cscope (ty, scope) -> Private_type_expr.set_scope ty scope
+  | Cname  (r, v) -> r := v
+  | Crow   (r, v) -> r := v
+  | Ckind  (r, v) -> r := v
+  | Ccommu (r, v) -> r := v
+  | Cuniv  (r, v) -> r := v
+
+type snapshot = changes ref * int
+let last_snapshot = s_ref 0
+
+let log_type ty =
+  if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc))
+let link_type ty ty' =
+  log_type ty;
+  let desc = ty.desc in
+  Private_type_expr.set_desc ty (Tlink ty');
+  (* Name is a user-supplied name for this unification variable (obtained
+   * through a type annotation for instance). *)
+  match desc, ty'.desc with
+    Tvar name, Tvar name' ->
+      begin match name, name' with
+      | Some _, None -> log_type ty'; Private_type_expr.set_desc ty' (Tvar name)
+      | None, Some _ -> ()
+      | Some _, Some _ ->
+          if ty.level < ty'.level then
+            (log_type ty'; Private_type_expr.set_desc ty' (Tvar name))
+      | None, None   -> ()
+      end
+  | _ -> ()
+  (* ; assert (check_memorized_abbrevs ()) *)
+  (*  ; check_expans [] ty' *)
+(* TODO: consider eliminating set_type_desc, replacing it with link types *)
+let set_type_desc ty td =
+  if td != ty.desc then begin
+    log_type ty;
+    Private_type_expr.set_desc ty td
+  end
+(* TODO: separate set_level into two specific functions: *)
+(*  set_lower_level and set_generic_level *)
+ let set_level ty level =
+  if level <> ty.level then begin
+    if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level));
+    Private_type_expr.set_level ty level
+  end
+(* TODO: introduce a guard and rename it to set_higher_scope? *)
+let set_scope ty scope =
+  if scope <> ty.scope then begin
+    if ty.id <= !last_snapshot then log_change (Cscope (ty, ty.scope));
+    Private_type_expr.set_scope ty scope
+  end
+let set_univar rty ty =
+  log_change (Cuniv (rty, !rty)); rty := Some ty
+let set_name nm v =
+  log_change (Cname (nm, !nm)); nm := v
+let set_row_field e v =
+  log_change (Crow (e, !e)); e := Some v
+let set_kind rk k =
+  log_change (Ckind (rk, !rk)); rk := Some k
+let set_commu rc c =
+  log_change (Ccommu (rc, !rc)); rc := c
+
+let snapshot () =
+  let old = !last_snapshot in
+  last_snapshot := !new_id;
+  (!trail, old)
+
+let rec rev_log accu = function
+    Unchanged -> accu
+  | Invalid -> assert false
+  | Change (ch, next) ->
+      let d = !next in
+      next := Invalid;
+      rev_log (ch::accu) d
+
+let backtrack (changes, old) =
+  match !changes with
+    Unchanged -> last_snapshot := old
+  | Invalid -> failwith "Btype.backtrack"
+  | Change _ as change ->
+      cleanup_abbrev ();
+      let backlog = rev_log [] change in
+      List.iter undo_change backlog;
+      changes := Unchanged;
+      last_snapshot := old;
+      trail := changes
+
+let rec rev_compress_log log r =
+  match !r with
+    Unchanged | Invalid ->
+      log
+  | Change (Ccompress _, next) ->
+      rev_compress_log (r::log) next
+  | Change (_, next) ->
+      rev_compress_log log next
+
+let undo_compress (changes, _old) =
+  match !changes with
+    Unchanged
+  | Invalid -> ()
+  | Change _ ->
+      let log = rev_compress_log [] changes in
+      List.iter
+        (fun r -> match !r with
+          Change (Ccompress (ty, desc, d), next) when ty.desc == d ->
+            Private_type_expr.set_desc ty desc; r := !next
+        | _ -> ())
+        log
+
+(* Mark a type. *)
+
+let not_marked_node ty = ty.level >= lowest_level
+    (* type nodes with negative levels are "marked" *)
+
+let flip_mark_node ty = Private_type_expr.set_level ty (pivot_level - ty.level)
+let logged_mark_node ty = set_level ty (pivot_level - ty.level)
+
+let try_mark_node ty = not_marked_node ty && (flip_mark_node ty; true)
+let try_logged_mark_node ty = not_marked_node ty && (logged_mark_node ty; true)
+
+let rec mark_type ty =
+  let ty = repr ty in
+  if not_marked_node ty then begin
+    flip_mark_node ty;
+    iter_type_expr mark_type ty
+  end
+
+let mark_type_params ty =
+  iter_type_expr mark_type ty
+
+let type_iterators =
+  let it_type_expr it ty =
+    let ty = repr ty in
+    if try_mark_node ty then it.it_do_type_expr it ty
+  in
+  {type_iterators with it_type_expr}
+
+
+(* Remove marks from a type. *)
+let rec unmark_type ty =
+  let ty = repr ty in
+  if ty.level < lowest_level then begin
+    (* flip back the marked level *)
+    flip_mark_node ty;
+    iter_type_expr unmark_type ty
+  end
+
+let unmark_iterators =
+  let it_type_expr _it ty = unmark_type ty in
+  {type_iterators with it_type_expr}
+
+let unmark_type_decl decl =
+  unmark_iterators.it_type_declaration unmark_iterators decl
+
+let unmark_extension_constructor ext =
+  List.iter unmark_type ext.ext_type_params;
+  iter_type_expr_cstr_args unmark_type ext.ext_args;
+  Option.iter unmark_type ext.ext_ret_type
+
+let unmark_class_signature sign =
+  unmark_type sign.csig_self;
+  Vars.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_vars
+
+let unmark_class_type cty =
+  unmark_iterators.it_class_type unmark_iterators cty
diff --git a/upstream/ocaml_413/typing/btype.mli b/upstream/ocaml_413/typing/btype.mli
new file mode 100644
index 0000000..f16a359
--- /dev/null
+++ b/upstream/ocaml_413/typing/btype.mli
@@ -0,0 +1,276 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Basic operations on core types *)
+
+open Asttypes
+open Types
+
+(**** Sets, maps and hashtables of types ****)
+
+module TypeSet  : Set.S with type elt = type_expr
+module TypeMap  : Map.S with type key = type_expr
+module TypeHash : Hashtbl.S with type key = type_expr
+
+(**** Levels ****)
+
+val generic_level: int
+
+val newty2: int -> type_desc -> type_expr
+        (* Create a type *)
+val newgenty: type_desc -> type_expr
+        (* Create a generic type *)
+val newgenvar: ?name:string -> unit -> type_expr
+        (* Return a fresh generic variable *)
+
+(* Use Tsubst instead
+val newmarkedvar: int -> type_expr
+        (* Return a fresh marked variable *)
+val newmarkedgenvar: unit -> type_expr
+        (* Return a fresh marked generic variable *)
+*)
+
+(**** Types ****)
+
+val is_Tvar: type_expr -> bool
+val is_Tunivar: type_expr -> bool
+val is_Tconstr: type_expr -> bool
+val dummy_method: label
+
+val repr: type_expr -> type_expr
+        (* Return the canonical representative of a type. *)
+
+val field_kind_repr: field_kind -> field_kind
+        (* Return the canonical representative of an object field
+           kind. *)
+
+val commu_repr: commutable -> commutable
+        (* Return the canonical representative of a commutation lock *)
+
+(**** polymorphic variants ****)
+
+val row_repr: row_desc -> row_desc
+        (* Return the canonical representative of a row description *)
+val row_field_repr: row_field -> row_field
+val row_field: label -> row_desc -> row_field
+        (* Return the canonical representative of a row field *)
+val row_more: row_desc -> type_expr
+        (* Return the extension variable of the row *)
+
+val is_fixed: row_desc -> bool
+(* Return whether the row is directly marked as fixed or not *)
+
+val row_fixed: row_desc -> bool
+(* Return whether the row should be treated as fixed or not.
+   In particular, [is_fixed row] implies [row_fixed row].
+*)
+
+val fixed_explanation: row_desc -> fixed_explanation option
+(* Return the potential explanation for the fixed row *)
+
+val merge_fixed_explanation:
+  fixed_explanation option -> fixed_explanation option
+  -> fixed_explanation option
+(* Merge two explanations for a fixed row *)
+
+val static_row: row_desc -> bool
+        (* Return whether the row is static or not *)
+val hash_variant: label -> int
+        (* Hash function for variant tags *)
+
+val proxy: type_expr -> type_expr
+        (* Return the proxy representative of the type: either itself
+           or a row variable *)
+
+(**** Utilities for private abbreviations with fixed rows ****)
+val row_of_type: type_expr -> type_expr
+val has_constr_row: type_expr -> bool
+val is_row_name: string -> bool
+val is_constr_row: allow_ident:bool -> type_expr -> bool
+
+(* Set the polymorphic variant row_name field *)
+val set_row_name : type_declaration -> Path.t -> unit
+
+(**** Utilities for type traversal ****)
+
+val iter_type_expr: (type_expr -> unit) -> type_expr -> unit
+        (* Iteration on types *)
+val fold_type_expr: ('a -> type_expr -> 'a) -> 'a -> type_expr -> 'a
+val iter_row: (type_expr -> unit) -> row_desc -> unit
+        (* Iteration on types in a row *)
+val fold_row: ('a -> type_expr -> 'a) -> 'a -> row_desc -> 'a
+val iter_abbrev: (type_expr -> unit) -> abbrev_memo -> unit
+        (* Iteration on types in an abbreviation list *)
+
+type type_iterators =
+  { it_signature: type_iterators -> signature -> unit;
+    it_signature_item: type_iterators -> signature_item -> unit;
+    it_value_description: type_iterators -> value_description -> unit;
+    it_type_declaration: type_iterators -> type_declaration -> unit;
+    it_extension_constructor: type_iterators -> extension_constructor -> unit;
+    it_module_declaration: type_iterators -> module_declaration -> unit;
+    it_modtype_declaration: type_iterators -> modtype_declaration -> unit;
+    it_class_declaration: type_iterators -> class_declaration -> unit;
+    it_class_type_declaration: type_iterators -> class_type_declaration -> unit;
+    it_functor_param: type_iterators -> functor_parameter -> unit;
+    it_module_type: type_iterators -> module_type -> unit;
+    it_class_type: type_iterators -> class_type -> unit;
+    it_type_kind: type_iterators -> type_decl_kind -> unit;
+    it_do_type_expr: type_iterators -> type_expr -> unit;
+    it_type_expr: type_iterators -> type_expr -> unit;
+    it_path: Path.t -> unit; }
+val type_iterators: type_iterators
+        (* Iteration on arbitrary type information.
+           [it_type_expr] calls [mark_node] to avoid loops. *)
+val unmark_iterators: type_iterators
+        (* Unmark any structure containing types. See [unmark_type] below. *)
+
+val copy_type_desc:
+    ?keep_names:bool -> (type_expr -> type_expr) -> type_desc -> type_desc
+        (* Copy on types *)
+val copy_row:
+    (type_expr -> type_expr) ->
+    bool -> row_desc -> bool -> type_expr -> row_desc
+val copy_kind: field_kind -> field_kind
+
+module For_copy : sig
+
+  type copy_scope
+        (* The private state that the primitives below are mutating, it should
+           remain scoped within a single [with_scope] call.
+
+           While it is possible to circumvent that discipline in various
+           ways, you should NOT do that. *)
+
+  val save_desc: copy_scope -> type_expr -> type_desc -> unit
+        (* Save a type description *)
+
+  val dup_kind: copy_scope -> field_kind option ref -> unit
+        (* Save a None field_kind, and make it point to a fresh Fvar *)
+
+  val with_scope: (copy_scope -> 'a) -> 'a
+        (* [with_scope f] calls [f] and restores saved type descriptions
+           before returning its result. *)
+end
+
+val lowest_level: int
+        (* Marked type: ty.level < lowest_level *)
+
+val not_marked_node: type_expr -> bool
+        (* Return true if a type node is not yet marked *)
+
+val logged_mark_node: type_expr -> unit
+        (* Mark a type node, logging the marking so it can be backtracked.
+           No [repr]'ing *)
+val try_logged_mark_node: type_expr -> bool
+        (* Mark a type node if it is not yet marked, logging the marking so it
+           can be backtracked.
+           Return false if it was already marked *)
+
+val flip_mark_node: type_expr -> unit
+        (* Mark a type node. No [repr]'ing.
+           The marking is not logged and will have to be manually undone using
+           one of the various [unmark]'ing functions below. *)
+val try_mark_node: type_expr -> bool
+        (* Mark a type node if it is not yet marked.
+           The marking is not logged and will have to be manually undone using
+           one of the various [unmark]'ing functions below.
+
+           Return false if it was already marked *)
+val mark_type: type_expr -> unit
+        (* Mark a type recursively *)
+val mark_type_params: type_expr -> unit
+        (* Mark the sons of a type node recursively *)
+
+val unmark_type: type_expr -> unit
+val unmark_type_decl: type_declaration -> unit
+val unmark_extension_constructor: extension_constructor -> unit
+val unmark_class_type: class_type -> unit
+val unmark_class_signature: class_signature -> unit
+        (* Remove marks from a type *)
+
+(**** Memorization of abbreviation expansion ****)
+
+val find_expans: private_flag -> Path.t -> abbrev_memo -> type_expr option
+        (* Look up a memorized abbreviation *)
+val cleanup_abbrev: unit -> unit
+        (* Flush the cache of abbreviation expansions.
+           When some types are saved (using [output_value]), this
+           function MUST be called just before. *)
+val memorize_abbrev:
+        abbrev_memo ref ->
+        private_flag -> Path.t -> type_expr -> type_expr -> unit
+        (* Add an expansion in the cache *)
+val forget_abbrev:
+        abbrev_memo ref -> Path.t -> unit
+        (* Remove an abbreviation from the cache *)
+
+(**** Utilities for labels ****)
+
+val is_optional : arg_label -> bool
+val label_name : arg_label -> label
+
+(* Returns the label name with first character '?' or '~' as appropriate. *)
+val prefixed_label_name : arg_label -> label
+
+val extract_label :
+    label -> (arg_label * 'a) list ->
+    (arg_label * 'a * bool * (arg_label * 'a) list) option
+(* actual label,
+   value,
+   whether (label, value) was at the head of the list,
+   list without the extracted (label, value) *)
+
+(**** Utilities for backtracking ****)
+
+type snapshot
+        (* A snapshot for backtracking *)
+val snapshot: unit -> snapshot
+        (* Make a snapshot for later backtracking. Costs nothing *)
+val backtrack: snapshot -> unit
+        (* Backtrack to a given snapshot. Only possible if you have
+           not already backtracked to a previous snapshot.
+           Calls [cleanup_abbrev] internally *)
+val undo_compress: snapshot -> unit
+        (* Backtrack only path compression. Only meaningful if you have
+           not already backtracked to a previous snapshot.
+           Does not call [cleanup_abbrev] *)
+
+(* Functions to use when modifying a type (only Ctype?) *)
+val link_type: type_expr -> type_expr -> unit
+        (* Set the desc field of [t1] to [Tlink t2], logging the old
+           value if there is an active snapshot *)
+val set_type_desc: type_expr -> type_desc -> unit
+        (* Set directly the desc field, without sharing *)
+val set_level: type_expr -> int -> unit
+val set_scope: type_expr -> int -> unit
+val set_name:
+    (Path.t * type_expr list) option ref ->
+    (Path.t * type_expr list) option -> unit
+val set_row_field: row_field option ref -> row_field -> unit
+val set_univar: type_expr option ref -> type_expr -> unit
+val set_kind: field_kind option ref -> field_kind -> unit
+val set_commu: commutable ref -> commutable -> unit
+        (* Set references, logging the old value *)
+
+(**** Forward declarations ****)
+val print_raw: (Format.formatter -> type_expr -> unit) ref
+
+val iter_type_expr_kind: (type_expr -> unit) -> (type_decl_kind -> unit)
+
+val iter_type_expr_cstr_args: (type_expr -> unit) ->
+  (constructor_arguments -> unit)
+val map_type_expr_cstr_args: (type_expr -> type_expr) ->
+  (constructor_arguments -> constructor_arguments)
diff --git a/upstream/ocaml_413/typing/cmt2annot.ml b/upstream/ocaml_413/typing/cmt2annot.ml
new file mode 100644
index 0000000..40ee752
--- /dev/null
+++ b/upstream/ocaml_413/typing/cmt2annot.ml
@@ -0,0 +1,184 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Generate an .annot file from a .cmt file. *)
+
+open Asttypes
+open Typedtree
+open Tast_iterator
+
+let variables_iterator scope =
+  let super = default_iterator in
+  let pat sub (type k) (p : k general_pattern) =
+    begin match p.pat_desc with
+    | Tpat_var (id, _) | Tpat_alias (_, id, _) ->
+        Stypes.record (Stypes.An_ident (p.pat_loc,
+                                        Ident.name id,
+                                        Annot.Idef scope))
+    | _ -> ()
+    end;
+    super.pat sub p
+  in
+  {super with pat}
+
+let bind_variables scope =
+  let iter = variables_iterator scope in
+  fun p -> iter.pat iter p
+
+let bind_bindings scope bindings =
+  let o = bind_variables scope in
+  List.iter (fun x -> o x.vb_pat) bindings
+
+let bind_cases l =
+  List.iter
+    (fun {c_lhs; c_guard; c_rhs} ->
+      let loc =
+        let open Location in
+        match c_guard with
+        | None -> c_rhs.exp_loc
+        | Some g -> {c_rhs.exp_loc with loc_start=g.exp_loc.loc_start}
+      in
+      bind_variables loc c_lhs
+    )
+    l
+
+let record_module_binding scope mb =
+  Stypes.record (Stypes.An_ident
+                   (mb.mb_name.loc,
+                    Option.value mb.mb_name.txt ~default:"_",
+                    Annot.Idef scope))
+
+let rec iterator ~scope rebuild_env =
+  let super = default_iterator in
+  let class_expr sub node =
+    Stypes.record (Stypes.Ti_class node);
+    super.class_expr sub node
+
+  and module_expr _sub node =
+    Stypes.record (Stypes.Ti_mod node);
+    super.module_expr (iterator ~scope:node.mod_loc rebuild_env) node
+
+  and expr sub exp =
+    begin match exp.exp_desc with
+    | Texp_ident (path, _, _) ->
+        let full_name = Path.name ~paren:Oprint.parenthesized_ident path in
+        let env =
+          if rebuild_env then
+            Env.env_of_only_summary Envaux.env_from_summary exp.exp_env
+          else
+            exp.exp_env
+        in
+        let annot =
+          try
+            let desc = Env.find_value path env in
+            let dloc = desc.Types.val_loc in
+            if dloc.Location.loc_ghost then Annot.Iref_external
+            else Annot.Iref_internal dloc
+          with Not_found ->
+            Annot.Iref_external
+        in
+        Stypes.record
+          (Stypes.An_ident (exp.exp_loc, full_name , annot))
+    | Texp_let (Recursive, bindings, _) ->
+        bind_bindings exp.exp_loc bindings
+    | Texp_let (Nonrecursive, bindings, body) ->
+        bind_bindings body.exp_loc bindings
+    | Texp_match (_, f1, _) ->
+        bind_cases f1
+    | Texp_function { cases = f; }
+    | Texp_try (_, f) ->
+        bind_cases f
+    | Texp_letmodule (_, modname, _, _, body ) ->
+        Stypes.record (Stypes.An_ident
+                         (modname.loc,Option.value ~default:"_" modname.txt,
+                          Annot.Idef body.exp_loc))
+    | _ -> ()
+    end;
+    Stypes.record (Stypes.Ti_expr exp);
+    super.expr sub exp
+
+  and pat sub (type k) (p : k general_pattern) =
+    Stypes.record (Stypes.Ti_pat (classify_pattern p, p));
+    super.pat sub p
+  in
+
+  let structure_item_rem sub str rem =
+    let open Location in
+    let loc = str.str_loc in
+    begin match str.str_desc with
+    | Tstr_value (rec_flag, bindings) ->
+        let doit loc_start = bind_bindings {scope with loc_start} bindings in
+        begin match rec_flag, rem with
+        | Recursive, _ -> doit loc.loc_start
+        | Nonrecursive, [] -> doit loc.loc_end
+        | Nonrecursive,  {str_loc = loc2} :: _ -> doit loc2.loc_start
+        end
+    | Tstr_module mb ->
+        record_module_binding
+          { scope with Location.loc_start = loc.loc_end } mb
+    | Tstr_recmodule mbs ->
+        List.iter (record_module_binding
+                   { scope with Location.loc_start = loc.loc_start }) mbs
+    | _ ->
+        ()
+    end;
+    Stypes.record_phrase loc;
+    super.structure_item sub str
+  in
+  let structure_item sub s =
+    (* This will be used for Partial_structure_item.
+       We don't have here the location of the "next" item,
+       this will give a slightly different scope for the non-recursive
+       binding case. *)
+    structure_item_rem sub s []
+  in
+  let structure sub l =
+    let rec loop = function
+      | str :: rem -> structure_item_rem sub str rem; loop rem
+      | [] -> ()
+    in
+    loop l.str_items
+  in
+  {super with class_expr; module_expr; expr; pat; structure_item; structure}
+
+let binary_part iter x =
+  let open Cmt_format in
+  match x with
+  | Partial_structure x -> iter.structure iter x
+  | Partial_structure_item x -> iter.structure_item iter x
+  | Partial_expression x -> iter.expr iter x
+  | Partial_pattern (_, x) -> iter.pat iter x
+  | Partial_class_expr x -> iter.class_expr iter x
+  | Partial_signature x -> iter.signature iter x
+  | Partial_signature_item x -> iter.signature_item iter x
+  | Partial_module_type x -> iter.module_type iter x
+
+let gen_annot target_filename ~sourcefile ~use_summaries annots =
+  let open Cmt_format in
+  let scope =
+    match sourcefile with
+    | None -> Location.none
+    | Some s -> Location.in_file s
+  in
+  let iter = iterator ~scope use_summaries in
+  match annots with
+  | Implementation typedtree ->
+      iter.structure iter typedtree;
+      Stypes.dump target_filename
+  | Partial_implementation parts ->
+      Array.iter (binary_part iter) parts;
+      Stypes.dump target_filename
+  | Interface _ | Packed _ | Partial_interface _ ->
+      ()
diff --git a/upstream/ocaml_413/typing/ctype.ml b/upstream/ocaml_413/typing/ctype.ml
new file mode 100644
index 0000000..5d1d247
--- /dev/null
+++ b/upstream/ocaml_413/typing/ctype.ml
@@ -0,0 +1,5027 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Operations on core types *)
+
+open Misc
+open Asttypes
+open Types
+open Btype
+open Errortrace
+
+open Local_store
+
+(*
+   Type manipulation after type inference
+   ======================================
+   If one wants to manipulate a type after type inference (for
+   instance, during code generation or in the debugger), one must
+   first make sure that the type levels are correct, using the
+   function [correct_levels]. Then, this type can be correctly
+   manipulated by [apply], [expand_head] and [moregeneral].
+*)
+
+(*
+   General notes
+   =============
+   - As much sharing as possible should be kept : it makes types
+     smaller and better abbreviated.
+     When necessary, some sharing can be lost. Types will still be
+     printed correctly (+++ TO DO...), and abbreviations defined by a
+     class do not depend on sharing thanks to constrained
+     abbreviations. (Of course, even if some sharing is lost, typing
+     will still be correct.)
+   - All nodes of a type have a level : that way, one know whether a
+     node need to be duplicated or not when instantiating a type.
+   - Levels of a type are decreasing (generic level being considered
+     as greatest).
+   - The level of a type constructor is superior to the binding
+     time of its path.
+   - Recursive types without limitation should be handled (even if
+     there is still an occur check). This avoid treating specially the
+     case for objects, for instance. Furthermore, the occur check
+     policy can then be easily changed.
+*)
+
+(**** Errors ****)
+
+exception Unify of unification Errortrace.t
+exception Equality of comparison Errortrace.t
+exception Moregen of comparison Errortrace.t
+exception Subtype of Errortrace.Subtype.t * unification Errortrace.t
+
+exception Escape of desc Errortrace.escape
+
+(* For local use: throw the appropriate exception.  Can be passed into local
+   functions as a parameter *)
+type _ trace_exn =
+| Unify    : unification trace_exn
+| Moregen  : comparison  trace_exn
+| Equality : comparison  trace_exn
+
+let raise_trace_for
+      (type variant)
+      (tr_exn : variant trace_exn)
+      (tr     : variant Errortrace.t) : 'a =
+  match tr_exn with
+  | Unify    -> raise (Unify    tr)
+  | Equality -> raise (Equality tr)
+  | Moregen  -> raise (Moregen  tr)
+
+(* Uses of this function are a bit suspicious, as we usually want to maintain
+   trace information; sometimes it makes sense, however, since we're maintaining
+   the trace at an outer exception handler. *)
+let raise_unexplained_for tr_exn =
+  raise_trace_for tr_exn []
+
+let raise_for tr_exn e =
+  raise_trace_for tr_exn [e]
+
+(* Thrown from [moregen_kind] *)
+exception Public_method_to_private_method
+
+let escape kind = {kind; context = None}
+let escape_exn kind = Escape (escape kind)
+let scope_escape_exn ty = escape_exn (Equation (short ty))
+let raise_escape_exn kind = raise (escape_exn kind)
+let raise_scope_escape_exn ty = raise (scope_escape_exn ty)
+
+exception Tags of label * label
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Tags (l, l') ->
+          Some
+            Location.
+              (errorf ~loc:(in_file !input_name)
+                 "In this program,@ variant constructors@ `%s and `%s@ \
+                  have the same hash value.@ Change one of them." l l'
+              )
+      | _ -> None
+    )
+
+exception Cannot_expand
+
+exception Cannot_apply
+
+exception Cannot_subst
+
+exception Cannot_unify_universal_variables
+
+exception Matches_failure of Env.t * unification Errortrace.t
+
+exception Incompatible
+
+(**** Type level management ****)
+
+let current_level = s_ref 0
+let nongen_level = s_ref 0
+let global_level = s_ref 1
+let saved_level = s_ref []
+
+type levels =
+    { current_level: int; nongen_level: int; global_level: int;
+      saved_level: (int * int) list; }
+let save_levels () =
+  { current_level = !current_level;
+    nongen_level = !nongen_level;
+    global_level = !global_level;
+    saved_level = !saved_level }
+let set_levels l =
+  current_level := l.current_level;
+  nongen_level := l.nongen_level;
+  global_level := l.global_level;
+  saved_level := l.saved_level
+
+let get_current_level () = !current_level
+let init_def level = current_level := level; nongen_level := level
+let begin_def () =
+  saved_level := (!current_level, !nongen_level) :: !saved_level;
+  incr current_level; nongen_level := !current_level
+let begin_class_def () =
+  saved_level := (!current_level, !nongen_level) :: !saved_level;
+  incr current_level
+let raise_nongen_level () =
+  saved_level := (!current_level, !nongen_level) :: !saved_level;
+  nongen_level := !current_level
+let end_def () =
+  let (cl, nl) = List.hd !saved_level in
+  saved_level := List.tl !saved_level;
+  current_level := cl; nongen_level := nl
+let create_scope () =
+  init_def (!current_level + 1);
+  !current_level
+
+let reset_global_level () =
+  global_level := !current_level + 1
+let increase_global_level () =
+  let gl = !global_level in
+  global_level := !current_level;
+  gl
+let restore_global_level gl =
+  global_level := gl
+
+(**** Whether a path points to an object type (with hidden row variable) ****)
+let is_object_type path =
+  let name =
+    match path with Path.Pident id -> Ident.name id
+    | Path.Pdot(_, s) -> s
+    | Path.Papply _ -> assert false
+  in name.[0] = '#'
+
+(**** Control tracing of GADT instances *)
+
+let trace_gadt_instances = ref false
+let check_trace_gadt_instances env =
+  not !trace_gadt_instances && Env.has_local_constraints env &&
+  (trace_gadt_instances := true; cleanup_abbrev (); true)
+
+let reset_trace_gadt_instances b =
+  if b then trace_gadt_instances := false
+
+let wrap_trace_gadt_instances env f x =
+  let b = check_trace_gadt_instances env in
+  let y = f x in
+  reset_trace_gadt_instances b;
+  y
+
+(**** Abbreviations without parameters ****)
+(* Shall reset after generalizing *)
+
+let simple_abbrevs = ref Mnil
+
+let proper_abbrevs path tl abbrev =
+  if tl <> [] || !trace_gadt_instances || !Clflags.principal ||
+     is_object_type path
+  then abbrev
+  else simple_abbrevs
+
+(**** Some type creators ****)
+
+(* Re-export generic type creators *)
+
+let newty2             = Btype.newty2
+let newty desc         = newty2 !current_level desc
+
+let newvar ?name ()         = newty2 !current_level (Tvar name)
+let newvar2 ?name level     = newty2 level (Tvar name)
+let new_global_var ?name () = newty2 !global_level (Tvar name)
+
+let newobj fields      = newty (Tobject (fields, ref None))
+
+let newconstr path tyl = newty (Tconstr (path, tyl, ref Mnil))
+
+let none = newty (Ttuple [])                (* Clearly ill-formed type *)
+
+(**** Representative of a type ****)
+
+(* Re-export repr *)
+let repr = repr
+
+(**** Type maps ****)
+
+module TypePairs =
+  Hashtbl.Make (struct
+    type t = type_expr * type_expr
+    let equal (t1, t1') (t2, t2') = (t1 == t2) && (t1' == t2')
+    let hash (t, t') = t.id + 93 * t'.id
+ end)
+
+
+(**** unification mode ****)
+
+type unification_mode =
+  | Expression (* unification in expression *)
+  | Pattern (* unification in pattern which may add local constraints *)
+
+type equations_generation =
+  | Forbidden
+  | Allowed of { equated_types : unit TypePairs.t }
+
+let umode = ref Expression
+let equations_generation = ref Forbidden
+let assume_injective = ref false
+let allow_recursive_equation = ref false
+
+let can_generate_equations () =
+  match !equations_generation with
+  | Forbidden -> false
+  | _ -> true
+
+let set_mode_pattern ~generate ~injective ~allow_recursive f =
+  Misc.protect_refs
+    [ Misc.R (umode, Pattern);
+      Misc.R (equations_generation, generate);
+      Misc.R (assume_injective, injective);
+      Misc.R (allow_recursive_equation, allow_recursive);
+    ] f
+
+(*** Checks for type definitions ***)
+
+let in_current_module = function
+  | Path.Pident _ -> true
+  | Path.Pdot _ | Path.Papply _ -> false
+
+let in_pervasives p =
+  in_current_module p &&
+  try ignore (Env.find_type p Env.initial_safe_string); true
+  with Not_found -> false
+
+let is_datatype decl=
+  match decl.type_kind with
+    Type_record _ | Type_variant _ | Type_open -> true
+  | Type_abstract -> false
+
+
+                  (**********************************************)
+                  (*  Miscellaneous operations on object types  *)
+                  (**********************************************)
+
+(* Note:
+   We need to maintain some invariants:
+   * cty_self must be a Tobject
+   * ...
+*)
+
+(**** Object field manipulation. ****)
+
+let object_fields ty =
+  match (repr ty).desc with
+    Tobject (fields, _) -> fields
+  | _                   -> assert false
+
+let flatten_fields ty =
+  let rec flatten l ty =
+    let ty = repr ty in
+    match ty.desc with
+      Tfield(s, k, ty1, ty2) ->
+        flatten ((s, k, ty1)::l) ty2
+    | _ ->
+        (l, ty)
+  in
+    let (l, r) = flatten [] ty in
+    (List.sort (fun (n, _, _) (n', _, _) -> compare n n') l, r)
+
+let build_fields level =
+  List.fold_right
+    (fun (s, k, ty1) ty2 -> newty2 level (Tfield(s, k, ty1, ty2)))
+
+let associate_fields fields1 fields2 =
+  let rec associate p s s' =
+    function
+      (l, []) ->
+        (List.rev p, (List.rev s) @ l, List.rev s')
+    | ([], l') ->
+        (List.rev p, List.rev s, (List.rev s') @ l')
+    | ((n, k, t)::r, (n', k', t')::r') when n = n' ->
+        associate ((n, k, t, k', t')::p) s s' (r, r')
+    | ((n, k, t)::r, ((n', _k', _t')::_ as l')) when n < n' ->
+        associate p ((n, k, t)::s) s' (r, l')
+    | (((_n, _k, _t)::_ as l), (n', k', t')::r') (* when n > n' *) ->
+        associate p s ((n', k', t')::s') (l, r')
+  in
+  associate [] [] [] (fields1, fields2)
+
+let rec has_dummy_method ty =
+  match repr ty with
+    {desc = Tfield (m, _, _, ty2)} ->
+      m = dummy_method || has_dummy_method ty2
+  | _ -> false
+
+let is_self_type = function
+  | Tobject (ty, _) -> has_dummy_method ty
+  | _ -> false
+
+(**** Check whether an object is open ****)
+
+(* +++ The abbreviation should eventually be expanded *)
+let rec object_row ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tobject (t, _)     -> object_row t
+  | Tfield(_, _, _, t) -> object_row t
+  | _ -> ty
+
+let opened_object ty =
+  match (object_row ty).desc with
+  | Tvar _  | Tunivar _ | Tconstr _ -> true
+  | _                               -> false
+
+let concrete_object ty =
+  match (object_row ty).desc with
+  | Tvar _             -> false
+  | _                  -> true
+
+(**** Close an object ****)
+
+let close_object ty =
+  let rec close ty =
+    let ty = repr ty in
+    match ty.desc with
+      Tvar _ ->
+        link_type ty (newty2 ty.level Tnil); true
+    | Tfield(lab, _, _, _) when lab = dummy_method ->
+        false
+    | Tfield(_, _, _, ty') -> close ty'
+    | _                    -> assert false
+  in
+  match (repr ty).desc with
+    Tobject (ty, _)   -> close ty
+  | _                 -> assert false
+
+(**** Row variable of an object type ****)
+
+let row_variable ty =
+  let rec find ty =
+    let ty = repr ty in
+    match ty.desc with
+      Tfield (_, _, _, ty) -> find ty
+    | Tvar _               -> ty
+    | _                    -> assert false
+  in
+  match (repr ty).desc with
+    Tobject (fi, _) -> find fi
+  | _               -> assert false
+
+(**** Object name manipulation ****)
+(* +++ Bientot obsolete *)
+
+let set_object_name id rv params ty =
+  match (repr ty).desc with
+    Tobject (_fi, nm) ->
+      set_name nm (Some (Path.Pident id, rv::params))
+  | _ ->
+      assert false
+
+let remove_object_name ty =
+  match (repr ty).desc with
+    Tobject (_, nm)   -> set_name nm None
+  | Tconstr (_, _, _) -> ()
+  | _                 -> fatal_error "Ctype.remove_object_name"
+
+(**** Hiding of private methods ****)
+
+let hide_private_methods ty =
+  match (repr ty).desc with
+    Tobject (fi, nm) ->
+      nm := None;
+      let (fl, _) = flatten_fields fi in
+      List.iter
+        (function (_, k, _) ->
+          match field_kind_repr k with
+            Fvar r -> set_kind r Fabsent
+          | _      -> ())
+        fl
+  | _ ->
+      assert false
+
+
+                              (*******************************)
+                              (*  Operations on class types  *)
+                              (*******************************)
+
+
+let rec signature_of_class_type =
+  function
+    Cty_constr (_, _, cty) -> signature_of_class_type cty
+  | Cty_signature sign     -> sign
+  | Cty_arrow (_, _, cty)   -> signature_of_class_type cty
+
+let self_type cty =
+  repr (signature_of_class_type cty).csig_self
+
+let rec class_type_arity =
+  function
+    Cty_constr (_, _, cty) ->  class_type_arity cty
+  | Cty_signature _        ->  0
+  | Cty_arrow (_, _, cty)    ->  1 + class_type_arity cty
+
+
+                  (*******************************************)
+                  (*  Miscellaneous operations on row types  *)
+                  (*******************************************)
+
+let sort_row_fields = List.sort (fun (p,_) (q,_) -> compare p q)
+
+let rec merge_rf r1 r2 pairs fi1 fi2 =
+  match fi1, fi2 with
+    (l1,f1 as p1)::fi1', (l2,f2 as p2)::fi2' ->
+      if l1 = l2 then merge_rf r1 r2 ((l1,f1,f2)::pairs) fi1' fi2' else
+      if l1 < l2 then merge_rf (p1::r1) r2 pairs fi1' fi2 else
+      merge_rf r1 (p2::r2) pairs fi1 fi2'
+  | [], _ -> (List.rev r1, List.rev_append r2 fi2, pairs)
+  | _, [] -> (List.rev_append r1 fi1, List.rev r2, pairs)
+
+let merge_row_fields fi1 fi2 =
+  match fi1, fi2 with
+    [], _ | _, [] -> (fi1, fi2, [])
+  | [p1], _ when not (List.mem_assoc (fst p1) fi2) -> (fi1, fi2, [])
+  | _, [p2] when not (List.mem_assoc (fst p2) fi1) -> (fi1, fi2, [])
+  | _ -> merge_rf [] [] [] (sort_row_fields fi1) (sort_row_fields fi2)
+
+let rec filter_row_fields erase = function
+    [] -> []
+  | (_l,f as p)::fi ->
+      let fi = filter_row_fields erase fi in
+      match row_field_repr f with
+        Rabsent -> fi
+      | Reither(_,_,false,e) when erase -> set_row_field e Rabsent; fi
+      | _ -> p :: fi
+
+                    (**************************************)
+                    (*  Check genericity of type schemes  *)
+                    (**************************************)
+
+
+exception Non_closed of type_expr * bool
+
+let free_variables = ref []
+let really_closed = ref None
+
+(* [free_vars_rec] collects the variables of the input type
+   expression into the [free_variables] reference. It is used for
+   several different things in the type-checker, with the following
+   bells and whistles:
+   - If [really_closed] is Some typing environment, types in the environment
+     are expanded to check whether the apparently-free variable would vanish
+     during expansion.
+   - We collect both type variables and row variables, paired with a boolean
+     that is [true] if we have a row variable.
+   - We do not count "virtual" free variables -- free variables stored in
+     the abbreviation of an object type that has been expanded (we store
+     the abbreviations for use when displaying the type).
+
+   The functions [free_vars] and [free_variables] below receive
+   a typing environment as an optional [?env] parameter and
+   set [really_closed] accordingly.
+   [free_vars] returns a [(variable * bool) list], while
+   [free_variables] drops the type/row information
+   and only returns a [variable list].
+ *)
+let rec free_vars_rec real ty =
+  let ty = repr ty in
+  if try_mark_node ty then
+    match ty.desc, !really_closed with
+      Tvar _, _ ->
+        free_variables := (ty, real) :: !free_variables
+    | Tconstr (path, tl, _), Some env ->
+        begin try
+          let (_, body, _) = Env.find_type_expansion path env in
+          if (repr body).level <> generic_level then
+            free_variables := (ty, real) :: !free_variables
+        with Not_found -> ()
+        end;
+        List.iter (free_vars_rec true) tl
+(* Do not count "virtual" free variables
+    | Tobject(ty, {contents = Some (_, p)}) ->
+        free_vars_rec false ty; List.iter (free_vars_rec true) p
+*)
+    | Tobject (ty, _), _ ->
+        free_vars_rec false ty
+    | Tfield (_, _, ty1, ty2), _ ->
+        free_vars_rec true ty1; free_vars_rec false ty2
+    | Tvariant row, _ ->
+        let row = row_repr row in
+        iter_row (free_vars_rec true) row;
+        if not (static_row row) then free_vars_rec false row.row_more
+    | _    ->
+        iter_type_expr (free_vars_rec true) ty
+
+let free_vars ?env ty =
+  free_variables := [];
+  really_closed := env;
+  free_vars_rec true ty;
+  let res = !free_variables in
+  free_variables := [];
+  really_closed := None;
+  res
+
+let free_variables ?env ty =
+  let tl = List.map fst (free_vars ?env ty) in
+  unmark_type ty;
+  tl
+
+let closed_type ty =
+  match free_vars ty with
+      []           -> ()
+  | (v, real) :: _ -> raise (Non_closed (v, real))
+
+let closed_parameterized_type params ty =
+  List.iter mark_type params;
+  let ok =
+    try closed_type ty; true with Non_closed _ -> false in
+  List.iter unmark_type params;
+  unmark_type ty;
+  ok
+
+let closed_type_decl decl =
+  try
+    List.iter mark_type decl.type_params;
+    begin match decl.type_kind with
+      Type_abstract ->
+        ()
+    | Type_variant (v, _rep) ->
+        List.iter
+          (fun {cd_args; cd_res; _} ->
+            match cd_res with
+            | Some _ -> ()
+            | None ->
+                match cd_args with
+                | Cstr_tuple l ->  List.iter closed_type l
+                | Cstr_record l -> List.iter (fun l -> closed_type l.ld_type) l
+          )
+          v
+    | Type_record(r, _rep) ->
+        List.iter (fun l -> closed_type l.ld_type) r
+    | Type_open -> ()
+    end;
+    begin match decl.type_manifest with
+      None    -> ()
+    | Some ty -> closed_type ty
+    end;
+    unmark_type_decl decl;
+    None
+  with Non_closed (ty, _) ->
+    unmark_type_decl decl;
+    Some ty
+
+let closed_extension_constructor ext =
+  try
+    List.iter mark_type ext.ext_type_params;
+    begin match ext.ext_ret_type with
+    | Some _ -> ()
+    | None -> iter_type_expr_cstr_args closed_type ext.ext_args
+    end;
+    unmark_extension_constructor ext;
+    None
+  with Non_closed (ty, _) ->
+    unmark_extension_constructor ext;
+    Some ty
+
+type closed_class_failure =
+    CC_Method of type_expr * bool * string * type_expr
+  | CC_Value of type_expr * bool * string * type_expr
+
+exception CCFailure of closed_class_failure
+
+let closed_class params sign =
+  let ty = object_fields (repr sign.csig_self) in
+  let (fields, rest) = flatten_fields ty in
+  List.iter mark_type params;
+  mark_type rest;
+  List.iter
+    (fun (lab, _, ty) -> if lab = dummy_method then mark_type ty)
+    fields;
+  try
+    ignore (try_mark_node (repr sign.csig_self));
+    List.iter
+      (fun (lab, kind, ty) ->
+        if field_kind_repr kind = Fpresent then
+        try closed_type ty with Non_closed (ty0, real) ->
+          raise (CCFailure (CC_Method (ty0, real, lab, ty))))
+      fields;
+    mark_type_params (repr sign.csig_self);
+    List.iter unmark_type params;
+    unmark_class_signature sign;
+    None
+  with CCFailure reason ->
+    mark_type_params (repr sign.csig_self);
+    List.iter unmark_type params;
+    unmark_class_signature sign;
+    Some reason
+
+
+                            (**********************)
+                            (*  Type duplication  *)
+                            (**********************)
+
+
+(* Duplicate a type, preserving only type variables *)
+let duplicate_type ty =
+  Subst.type_expr Subst.identity ty
+
+(* Same, for class types *)
+let duplicate_class_type ty =
+  Subst.class_type Subst.identity ty
+
+
+                         (*****************************)
+                         (*  Type level manipulation  *)
+                         (*****************************)
+
+(*
+   It would be a bit more efficient to remove abbreviation expansions
+   rather than generalizing them: these expansions will usually not be
+   used anymore. However, this is not possible in the general case, as
+   [expand_abbrev] (via [subst]) requires these expansions to be
+   preserved. Does it worth duplicating this code ?
+*)
+let rec generalize ty =
+  let ty = repr ty in
+  if (ty.level > !current_level) && (ty.level <> generic_level) then begin
+    set_level ty generic_level;
+    (* recur into abbrev for the speed *)
+    begin match ty.desc with
+      Tconstr (_, _, abbrev) ->
+        iter_abbrev generalize !abbrev
+    | _ -> ()
+    end;
+    iter_type_expr generalize ty
+  end
+
+let generalize ty =
+  simple_abbrevs := Mnil;
+  generalize ty
+
+(* Generalize the structure and lower the variables *)
+
+let rec generalize_structure ty =
+  let ty = repr ty in
+  if ty.level <> generic_level then begin
+    if is_Tvar ty && ty.level > !current_level then
+      set_level ty !current_level
+    else if
+      ty.level > !current_level &&
+      match ty.desc with
+        Tconstr (p, _, abbrev) ->
+          not (is_object_type p) && (abbrev := Mnil; true)
+      | _ -> true
+    then begin
+      set_level ty generic_level;
+      iter_type_expr generalize_structure ty
+    end
+  end
+
+let generalize_structure ty =
+  simple_abbrevs := Mnil;
+  generalize_structure ty
+
+(* Generalize the spine of a function, if the level >= !current_level *)
+
+let rec generalize_spine ty =
+  let ty = repr ty in
+  if ty.level < !current_level || ty.level = generic_level then () else
+  match ty.desc with
+    Tarrow (_, ty1, ty2, _) ->
+      set_level ty generic_level;
+      generalize_spine ty1;
+      generalize_spine ty2;
+  | Tpoly (ty', _) ->
+      set_level ty generic_level;
+      generalize_spine ty'
+  | Ttuple tyl ->
+      set_level ty generic_level;
+      List.iter generalize_spine tyl
+  | Tpackage (_, fl) ->
+      set_level ty generic_level;
+      List.iter (fun (_n, ty) -> generalize_spine ty) fl
+  | Tconstr (p, tyl, memo) when not (is_object_type p) ->
+      set_level ty generic_level;
+      memo := Mnil;
+      List.iter generalize_spine tyl
+  | _ -> ()
+
+let forward_try_expand_safe = (* Forward declaration *)
+  ref (fun _env _ty -> assert false)
+
+(*
+   Lower the levels of a type (assume [level] is not
+   [generic_level]).
+*)
+
+let rec normalize_package_path env p =
+  let t =
+    try (Env.find_modtype p env).mtd_type
+    with Not_found -> None
+  in
+  match t with
+  | Some (Mty_ident p) -> normalize_package_path env p
+  | Some (Mty_signature _ | Mty_functor _ | Mty_alias _) | None ->
+      match p with
+        Path.Pdot (p1, s) ->
+          (* For module aliases *)
+          let p1' = Env.normalize_module_path None env p1 in
+          if Path.same p1 p1' then p else
+          normalize_package_path env (Path.Pdot (p1', s))
+      | _ -> p
+
+let rec check_scope_escape env level ty =
+  let ty = repr ty in
+  let orig_level = ty.level in
+  if try_logged_mark_node ty then begin
+    if level < ty.scope then
+      raise_scope_escape_exn ty;
+    begin match ty.desc with
+    | Tconstr (p, _, _) when level < Path.scope p ->
+        begin match !forward_try_expand_safe env ty with
+        | ty' ->
+            check_scope_escape env level ty'
+        | exception Cannot_expand ->
+            raise_escape_exn (Constructor p)
+        end
+    | Tpackage (p, fl) when level < Path.scope p ->
+        let p' = normalize_package_path env p in
+        if Path.same p p' then raise_escape_exn (Module_type p);
+        check_scope_escape env level
+          (Btype.newty2 orig_level (Tpackage (p', fl)))
+    | _ ->
+      iter_type_expr (check_scope_escape env level) ty
+    end;
+  end
+
+let check_scope_escape env level ty =
+  let snap = snapshot () in
+  try check_scope_escape env level ty; backtrack snap
+  with Escape e ->
+    backtrack snap;
+    raise (Escape { e with context = Some ty })
+
+let rec update_scope scope ty =
+  let ty = repr ty in
+  if ty.scope < scope then begin
+    if ty.level < scope then raise_scope_escape_exn ty;
+    set_scope ty scope;
+    (* Only recurse in principal mode as this is not necessary for soundness *)
+    if !Clflags.principal then iter_type_expr (update_scope scope) ty
+  end
+
+let update_scope_for tr_exn scope ty =
+  try
+    update_scope scope ty
+  with Escape e -> raise_for tr_exn (Escape e)
+
+(* Note: the level of a type constructor must be greater than its binding
+    time. That way, a type constructor cannot escape the scope of its
+    definition, as would be the case in
+      let x = ref []
+      module M = struct type t let _ = (x : t list ref) end
+    (without this constraint, the type system would actually be unsound.)
+*)
+
+let rec update_level env level expand ty =
+  let ty = repr ty in
+  if ty.level > level then begin
+    if level < ty.scope then raise_scope_escape_exn ty;
+    match ty.desc with
+      Tconstr(p, _tl, _abbrev) when level < Path.scope p ->
+        (* Try first to replace an abbreviation by its expansion. *)
+        begin try
+          link_type ty (!forward_try_expand_safe env ty);
+          update_level env level expand ty
+        with Cannot_expand ->
+          raise_escape_exn (Constructor p)
+        end
+    | Tconstr(p, (_ :: _ as tl), _) ->
+        let variance =
+          try (Env.find_type p env).type_variance
+          with Not_found -> List.map (fun _ -> Variance.unknown) tl in
+        let needs_expand =
+          expand ||
+          List.exists2
+            (fun var ty -> var = Variance.null && (repr ty).level > level)
+            variance tl
+        in
+        begin try
+          if not needs_expand then raise Cannot_expand;
+          link_type ty (!forward_try_expand_safe env ty);
+          update_level env level expand ty
+        with Cannot_expand ->
+          set_level ty level;
+          iter_type_expr (update_level env level expand) ty
+        end
+    | Tpackage (p, fl) when level < Path.scope p ->
+        let p' = normalize_package_path env p in
+        if Path.same p p' then raise_escape_exn (Module_type p);
+        set_type_desc ty (Tpackage (p', fl));
+        update_level env level expand ty
+    | Tobject(_, ({contents=Some(p, _tl)} as nm))
+      when level < Path.scope p ->
+        set_name nm None;
+        update_level env level expand ty
+    | Tvariant row ->
+        let row = row_repr row in
+        begin match row.row_name with
+        | Some (p, _tl) when level < Path.scope p ->
+            set_type_desc ty (Tvariant {row with row_name = None})
+        | _ -> ()
+        end;
+        set_level ty level;
+        iter_type_expr (update_level env level expand) ty
+    | Tfield(lab, _, ty1, _)
+      when lab = dummy_method && (repr ty1).level > level ->
+        raise_escape_exn Self
+    | _ ->
+        set_level ty level;
+        (* XXX what about abbreviations in Tconstr ? *)
+        iter_type_expr (update_level env level expand) ty
+  end
+
+(* First try without expanding, then expand everything,
+   to avoid combinatorial blow-up *)
+let update_level env level ty =
+  let ty = repr ty in
+  if ty.level > level then begin
+    let snap = snapshot () in
+    try
+      update_level env level false ty
+    with Escape _ ->
+      backtrack snap;
+      update_level env level true ty
+  end
+
+let update_level_for tr_exn env level ty =
+  try
+    update_level env level ty
+  with Escape e -> raise_for tr_exn (Escape e)
+
+(* Lower level of type variables inside contravariant branches *)
+
+let rec lower_contravariant env var_level visited contra ty =
+  let ty = repr ty in
+  let must_visit =
+    ty.level > var_level &&
+    match Hashtbl.find visited ty.id with
+    | done_contra -> contra && not done_contra
+    | exception Not_found -> true
+  in
+  if must_visit then begin
+    Hashtbl.add visited ty.id contra;
+    let lower_rec = lower_contravariant env var_level visited in
+    match ty.desc with
+      Tvar _ -> if contra then set_level ty var_level
+    | Tconstr (_, [], _) -> ()
+    | Tconstr (path, tyl, _abbrev) ->
+       let variance, maybe_expand =
+         try
+           let typ = Env.find_type path env in
+           typ.type_variance,
+           typ.type_kind = Type_abstract
+          with Not_found ->
+            (* See testsuite/tests/typing-missing-cmi-2 for an example *)
+            List.map (fun _ -> Variance.unknown) tyl,
+            false
+        in
+        if List.for_all ((=) Variance.null) variance then () else
+          let not_expanded () =
+            List.iter2
+              (fun v t ->
+                if v = Variance.null then () else
+                  if Variance.(mem May_weak v)
+                  then lower_rec true t
+                  else lower_rec contra t)
+              variance tyl in
+          if maybe_expand then (* we expand cautiously to avoid missing cmis *)
+            match !forward_try_expand_safe env ty with
+            | ty -> lower_rec contra ty
+            | exception Cannot_expand -> not_expanded ()
+          else not_expanded ()
+    | Tpackage (_, fl) ->
+        List.iter (fun (_n, ty) -> lower_rec true ty) fl
+    | Tarrow (_, t1, t2, _) ->
+        lower_rec true t1;
+        lower_rec contra t2
+    | _ ->
+        iter_type_expr (lower_rec contra) ty
+  end
+
+let lower_contravariant env ty =
+  simple_abbrevs := Mnil;
+  lower_contravariant env !nongen_level (Hashtbl.create 7) false ty
+
+(* Correct the levels of type [ty]. *)
+let correct_levels ty =
+  duplicate_type ty
+
+(* Only generalize the type ty0 in ty *)
+let limited_generalize ty0 ty =
+  let ty0 = repr ty0 in
+
+  let graph = Hashtbl.create 17 in
+  let idx = ref lowest_level in
+  let roots = ref [] in
+
+  let rec inverse pty ty =
+    let ty = repr ty in
+    if (ty.level > !current_level) || (ty.level = generic_level) then begin
+      decr idx;
+      Hashtbl.add graph !idx (ty, ref pty);
+      if (ty.level = generic_level) || (ty == ty0) then
+        roots := ty :: !roots;
+      set_level ty !idx;
+      iter_type_expr (inverse [ty]) ty
+    end else if ty.level < lowest_level then begin
+      let (_, parents) = Hashtbl.find graph ty.level in
+      parents := pty @ !parents
+    end
+
+  and generalize_parents ty =
+    let idx = ty.level in
+    if idx <> generic_level then begin
+      set_level ty generic_level;
+      List.iter generalize_parents !(snd (Hashtbl.find graph idx));
+      (* Special case for rows: must generalize the row variable *)
+      match ty.desc with
+        Tvariant row ->
+          let more = row_more row in
+          let lv = more.level in
+          if (lv < lowest_level || lv > !current_level)
+          && lv <> generic_level then set_level more generic_level
+      | _ -> ()
+    end
+  in
+
+  inverse [] ty;
+  if ty0.level < lowest_level then
+    iter_type_expr (inverse []) ty0;
+  List.iter generalize_parents !roots;
+  Hashtbl.iter
+    (fun _ (ty, _) ->
+       if ty.level <> generic_level then set_level ty !current_level)
+    graph
+
+
+(* Compute statically the free univars of all nodes in a type *)
+(* This avoids doing it repeatedly during instantiation *)
+
+type inv_type_expr =
+    { inv_type : type_expr;
+      mutable inv_parents : inv_type_expr list }
+
+let rec inv_type hash pty ty =
+  let ty = repr ty in
+  try
+    let inv = TypeHash.find hash ty in
+    inv.inv_parents <- pty @ inv.inv_parents
+  with Not_found ->
+    let inv = { inv_type = ty; inv_parents = pty } in
+    TypeHash.add hash ty inv;
+    iter_type_expr (inv_type hash [inv]) ty
+
+let compute_univars ty =
+  let inverted = TypeHash.create 17 in
+  inv_type inverted [] ty;
+  let node_univars = TypeHash.create 17 in
+  let rec add_univar univ inv =
+    match inv.inv_type.desc with
+      Tpoly (_ty, tl) when List.memq univ (List.map repr tl) -> ()
+    | _ ->
+        try
+          let univs = TypeHash.find node_univars inv.inv_type in
+          if not (TypeSet.mem univ !univs) then begin
+            univs := TypeSet.add univ !univs;
+            List.iter (add_univar univ) inv.inv_parents
+          end
+        with Not_found ->
+          TypeHash.add node_univars inv.inv_type (ref(TypeSet.singleton univ));
+          List.iter (add_univar univ) inv.inv_parents
+  in
+  TypeHash.iter (fun ty inv -> if is_Tunivar ty then add_univar ty inv)
+    inverted;
+  fun ty ->
+    try !(TypeHash.find node_univars ty) with Not_found -> TypeSet.empty
+
+
+let fully_generic ty =
+  let rec aux ty =
+    let ty = repr ty in
+    if not_marked_node ty then
+      if ty.level = generic_level then
+        (flip_mark_node ty; iter_type_expr aux ty)
+      else raise Exit
+  in
+  let res = try aux ty; true with Exit -> false in
+  unmark_type ty;
+  res
+
+
+                              (*******************)
+                              (*  Instantiation  *)
+                              (*******************)
+
+
+let rec find_repr p1 =
+  function
+    Mnil ->
+      None
+  | Mcons (Public, p2, ty, _, _) when Path.same p1 p2 ->
+      Some ty
+  | Mcons (_, _, _, _, rem) ->
+      find_repr p1 rem
+  | Mlink {contents = rem} ->
+      find_repr p1 rem
+
+(*
+   Generic nodes are duplicated, while non-generic nodes are left
+   as-is.
+   During instantiation, the description of a generic node is first
+   replaced by a link to a stub ([Tsubst (newvar ())]). Once the
+   copy is made, it replaces the stub.
+   After instantiation, the description of generic node, which was
+   stored by [save_desc], must be put back, using [cleanup_types].
+*)
+
+let abbreviations = ref (ref Mnil)
+  (* Abbreviation memorized. *)
+
+(* partial: we may not wish to copy the non generic types
+   before we call type_pat *)
+let rec copy ?partial ?keep_names scope ty =
+  let copy = copy ?partial ?keep_names scope in
+  let ty = repr ty in
+  match ty.desc with
+    Tsubst (ty, _) -> ty
+  | _ ->
+    if ty.level <> generic_level && partial = None then ty else
+    (* We only forget types that are non generic and do not contain
+       free univars *)
+    let forget =
+      if ty.level = generic_level then generic_level else
+      match partial with
+        None -> assert false
+      | Some (free_univars, keep) ->
+          if TypeSet.is_empty (free_univars ty) then
+            if keep then ty.level else !current_level
+          else generic_level
+    in
+    if forget <> generic_level then newty2 forget (Tvar None) else
+    let desc = ty.desc in
+    For_copy.save_desc scope ty desc;
+    let t = newvar() in          (* Stub *)
+    set_scope t ty.scope;
+    Private_type_expr.set_desc ty (Tsubst (t, None));
+    Private_type_expr.set_desc t
+      begin match desc with
+      | Tconstr (p, tl, _) ->
+          let abbrevs = proper_abbrevs p tl !abbreviations in
+          begin match find_repr p !abbrevs with
+            Some ty when repr ty != t ->
+              Tlink ty
+          | _ ->
+          (*
+             One must allocate a new reference, so that abbrevia-
+             tions belonging to different branches of a type are
+             independent.
+             Moreover, a reference containing a [Mcons] must be
+             shared, so that the memorized expansion of an abbrevi-
+             ation can be released by changing the content of just
+             one reference.
+          *)
+              Tconstr (p, List.map copy tl,
+                       ref (match !(!abbreviations) with
+                              Mcons _ -> Mlink !abbreviations
+                            | abbrev  -> abbrev))
+          end
+      | Tvariant row0 ->
+          let row = row_repr row0 in
+          let more = repr row.row_more in
+          (* We must substitute in a subtle way *)
+          (* Tsubst takes a tuple containing the row var and the variant *)
+          begin match more.desc with
+            Tsubst (_, Some ty2) ->
+              (* This variant type has been already copied *)
+              Private_type_expr.set_desc ty (Tsubst (ty2, None));
+              (* avoid Tlink in the new type *)
+              Tlink ty2
+          | _ ->
+              (* If the row variable is not generic, we must keep it *)
+              let keep = more.level <> generic_level && partial = None in
+              let more' =
+                match more.desc with
+                  Tsubst (ty, None) -> ty
+                  (* TODO: is this case possible?
+                     possibly an interaction with (copy more) below? *)
+                | Tconstr _ | Tnil ->
+                    For_copy.save_desc scope more more.desc;
+                    copy more
+                | Tvar _ | Tunivar _ ->
+                    For_copy.save_desc scope more more.desc;
+                    if keep then more else newty more.desc
+                |  _ -> assert false
+              in
+              let row =
+                match repr more' with (* PR#6163 *)
+                  {desc=Tconstr (x,_,_)} when not (is_fixed row) ->
+                    {row with row_fixed = Some (Reified x)}
+                | _ -> row
+              in
+              (* Open row if partial for pattern and contains Reither *)
+              let more', row =
+                match partial with
+                  Some (free_univars, false) ->
+                    let more' =
+                      if more.id <> more'.id then
+                        more' (* we've already made a copy *)
+                      else
+                        newvar ()
+                    in
+                    let not_reither (_, f) =
+                      match row_field_repr f with
+                        Reither _ -> false
+                      | _ -> true
+                    in
+                    if row.row_closed && not (is_fixed row)
+                    && TypeSet.is_empty (free_univars ty)
+                    && not (List.for_all not_reither row.row_fields) then
+                      (more',
+                       {row_fields = List.filter not_reither row.row_fields;
+                        row_more = more'; row_bound = ();
+                        row_closed = false; row_fixed = None; row_name = None})
+                    else (more', row)
+                | _ -> (more', row)
+              in
+              (* Register new type first for recursion *)
+              Private_type_expr.set_desc
+                more (Tsubst (more', Some t));
+              (* Return a new copy *)
+              Tvariant (copy_row copy true row keep more')
+          end
+      | Tfield (_p, k, _ty1, ty2) ->
+          begin match field_kind_repr k with
+            Fabsent  -> Tlink (copy ty2)
+          | Fpresent -> copy_type_desc copy desc
+          | Fvar r ->
+              For_copy.dup_kind scope r;
+              copy_type_desc copy desc
+          end
+      | Tobject (ty1, _) when partial <> None ->
+          Tobject (copy ty1, ref None)
+      | _ -> copy_type_desc ?keep_names copy desc
+      end;
+    t
+
+(**** Variants of instantiations ****)
+
+let instance ?partial sch =
+  let partial =
+    match partial with
+      None -> None
+    | Some keep -> Some (compute_univars sch, keep)
+  in
+  For_copy.with_scope (fun scope -> copy ?partial scope sch)
+
+let generic_instance sch =
+  let old = !current_level in
+  current_level := generic_level;
+  let ty = instance sch in
+  current_level := old;
+  ty
+
+let instance_list schl =
+  For_copy.with_scope (fun scope -> List.map (fun t -> copy scope t) schl)
+
+let reified_var_counter = ref Vars.empty
+let reset_reified_var_counter () =
+  reified_var_counter := Vars.empty
+
+(* names given to new type constructors.
+   Used for existential types and
+   local constraints *)
+let get_new_abstract_name s =
+  let index =
+    try Vars.find s !reified_var_counter + 1
+    with Not_found -> 0 in
+  reified_var_counter := Vars.add s index !reified_var_counter;
+  if index = 0 && s <> "" && s.[String.length s - 1] <> '$' then s else
+  Printf.sprintf "%s%d" s index
+
+let new_local_type ?(loc = Location.none) ?manifest_and_scope () =
+  let manifest, expansion_scope =
+    match manifest_and_scope with
+      None -> None, Btype.lowest_level
+    | Some (ty, scope) -> Some ty, scope
+  in
+  {
+    type_params = [];
+    type_arity = 0;
+    type_kind = Type_abstract;
+    type_private = Public;
+    type_manifest = manifest;
+    type_variance = [];
+    type_separability = [];
+    type_is_newtype = true;
+    type_expansion_scope = expansion_scope;
+    type_loc = loc;
+    type_attributes = [];
+    type_immediate = Unknown;
+    type_unboxed_default = false;
+    type_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+  }
+
+let existential_name cstr ty = match repr ty with
+  | {desc = Tvar (Some name)} -> "$" ^ cstr.cstr_name ^ "_'" ^ name
+  | _ -> "$" ^ cstr.cstr_name
+
+let instance_constructor ?in_pattern cstr =
+  For_copy.with_scope (fun scope ->
+    begin match in_pattern with
+    | None -> ()
+    | Some (env, fresh_constr_scope) ->
+        let process existential =
+          let decl = new_local_type () in
+          let name = existential_name cstr existential in
+          let (id, new_env) =
+            Env.enter_type (get_new_abstract_name name) decl !env
+              ~scope:fresh_constr_scope in
+          env := new_env;
+          let to_unify = newty (Tconstr (Path.Pident id,[],ref Mnil)) in
+          let tv = copy scope existential in
+          assert (is_Tvar tv);
+          link_type tv to_unify
+        in
+        List.iter process cstr.cstr_existentials
+    end;
+    let ty_res = copy scope cstr.cstr_res in
+    let ty_args = List.map (copy scope) cstr.cstr_args in
+    let ty_ex = List.map (copy scope) cstr.cstr_existentials in
+    (ty_args, ty_res, ty_ex)
+  )
+
+let instance_parameterized_type ?keep_names sch_args sch =
+  For_copy.with_scope (fun scope ->
+    let ty_args = List.map (fun t -> copy ?keep_names scope t) sch_args in
+    let ty = copy scope sch in
+    (ty_args, ty)
+  )
+
+let instance_parameterized_type_2 sch_args sch_lst sch =
+  For_copy.with_scope (fun scope ->
+    let ty_args = List.map (copy scope) sch_args in
+    let ty_lst = List.map (copy scope) sch_lst in
+    let ty = copy scope sch in
+    (ty_args, ty_lst, ty)
+  )
+
+let map_kind f = function
+  | Type_abstract -> Type_abstract
+  | Type_open -> Type_open
+  | Type_variant (cl, rep) ->
+      Type_variant (
+        List.map
+          (fun c ->
+             {c with
+              cd_args = map_type_expr_cstr_args f c.cd_args;
+              cd_res = Option.map f c.cd_res
+             })
+          cl, rep)
+  | Type_record (fl, rr) ->
+      Type_record (
+        List.map
+          (fun l ->
+             {l with ld_type = f l.ld_type}
+          ) fl, rr)
+
+
+let instance_declaration decl =
+  For_copy.with_scope (fun scope ->
+    {decl with type_params = List.map (copy scope) decl.type_params;
+     type_manifest = Option.map (copy scope) decl.type_manifest;
+     type_kind = map_kind (copy scope) decl.type_kind;
+    }
+  )
+
+let generic_instance_declaration decl =
+  let old = !current_level in
+  current_level := generic_level;
+  let decl = instance_declaration decl in
+  current_level := old;
+  decl
+
+let instance_class params cty =
+  let rec copy_class_type scope = function
+    | Cty_constr (path, tyl, cty) ->
+        let tyl' = List.map (copy scope) tyl in
+        let cty' = copy_class_type scope cty in
+        Cty_constr (path, tyl', cty')
+    | Cty_signature sign ->
+        Cty_signature
+          {csig_self = copy scope sign.csig_self;
+           csig_vars =
+             Vars.map (function (m, v, ty) -> (m, v, copy scope ty))
+               sign.csig_vars;
+           csig_concr = sign.csig_concr;
+           csig_inher =
+             List.map (fun (p,tl) -> (p, List.map (copy scope) tl))
+               sign.csig_inher}
+    | Cty_arrow (l, ty, cty) ->
+        Cty_arrow (l, copy scope ty, copy_class_type scope cty)
+  in
+  For_copy.with_scope (fun scope ->
+    let params' = List.map (copy scope) params in
+    let cty' = copy_class_type scope cty in
+    (params', cty')
+  )
+
+(**** Instantiation for types with free universal variables ****)
+
+let rec diff_list l1 l2 =
+  if l1 == l2 then [] else
+  match l1 with [] -> invalid_arg "Ctype.diff_list"
+  | a :: l1 -> a :: diff_list l1 l2
+
+let conflicts free bound =
+  let bound = List.map repr bound in
+  TypeSet.exists (fun t -> List.memq (repr t) bound) free
+
+let delayed_copy = ref []
+    (* copying to do later *)
+
+(* Copy without sharing until there are no free univars left *)
+(* all free univars must be included in [visited]            *)
+let rec copy_sep cleanup_scope fixed free bound visited ty =
+  let ty = repr ty in
+  let univars = free ty in
+  if TypeSet.is_empty univars then
+    if ty.level <> generic_level then ty else
+    let t = newvar () in
+    delayed_copy :=
+      lazy (Private_type_expr.set_desc t (Tlink (copy cleanup_scope ty)))
+      :: !delayed_copy;
+    t
+  else try
+    let t, bound_t = List.assq ty visited in
+    let dl = if is_Tunivar ty then [] else diff_list bound bound_t in
+    if dl <> [] && conflicts univars dl then raise Not_found;
+    t
+  with Not_found -> begin
+    let t = newvar() in          (* Stub *)
+    let visited =
+      match ty.desc with
+        Tarrow _ | Ttuple _ | Tvariant _ | Tconstr _ | Tobject _ | Tpackage _ ->
+          (ty,(t,bound)) :: visited
+      | Tvar _ | Tfield _ | Tnil | Tpoly _ | Tunivar _ ->
+          visited
+      | Tlink _ | Tsubst _ ->
+          assert false
+    in
+    let copy_rec = copy_sep cleanup_scope fixed free bound visited in
+    Private_type_expr.set_desc t
+      begin match ty.desc with
+      | Tvariant row0 ->
+          let row = row_repr row0 in
+          let more = repr row.row_more in
+          (* We shall really check the level on the row variable *)
+          let keep = is_Tvar more && more.level <> generic_level in
+          let more' = copy_rec more in
+          let fixed' = fixed && (is_Tvar more || is_Tunivar more) in
+          let row = copy_row copy_rec fixed' row keep more' in
+          Tvariant row
+      | Tpoly (t1, tl) ->
+          let tl = List.map repr tl in
+          let tl' = List.map (fun t -> newty t.desc) tl in
+          let bound = tl @ bound in
+          let visited =
+            List.map2 (fun ty t -> ty,(t,bound)) tl tl' @ visited in
+          Tpoly (copy_sep cleanup_scope fixed free bound visited t1, tl')
+      | _ -> copy_type_desc copy_rec ty.desc
+      end;
+    t
+  end
+
+let instance_poly' cleanup_scope ~keep_names fixed univars sch =
+  (* In order to compute univars below, [sch] schould not contain [Tsubst] *)
+  let univars = List.map repr univars in
+  let copy_var ty =
+    match ty.desc with
+      Tunivar name -> if keep_names then newty (Tvar name) else newvar ()
+    | _ -> assert false
+  in
+  let vars = List.map copy_var univars in
+  let pairs = List.map2 (fun u v -> u, (v, [])) univars vars in
+  delayed_copy := [];
+  let ty = copy_sep cleanup_scope fixed (compute_univars sch) [] pairs sch in
+  List.iter Lazy.force !delayed_copy;
+  delayed_copy := [];
+  vars, ty
+
+let instance_poly ?(keep_names=false) fixed univars sch =
+  For_copy.with_scope (fun cleanup_scope ->
+    instance_poly' cleanup_scope ~keep_names fixed univars sch
+  )
+
+let instance_label fixed lbl =
+  For_copy.with_scope (fun scope ->
+    let vars, ty_arg =
+      match repr lbl.lbl_arg with
+        {desc = Tpoly (ty, tl)} ->
+          instance_poly' scope ~keep_names:false fixed tl ty
+      | _ ->
+          [], copy scope lbl.lbl_arg
+    in
+    (* call [copy] after [instance_poly] to avoid introducing [Tsubst] *)
+    let ty_res = copy scope lbl.lbl_res in
+    (vars, ty_arg, ty_res)
+  )
+
+(**** Instantiation with parameter substitution ****)
+
+let unify' = (* Forward declaration *)
+  ref (fun _env _ty1 _ty2 -> assert false)
+
+
+let subst env level priv abbrev ty params args body =
+  if List.length params <> List.length args then raise Cannot_subst;
+  let old_level = !current_level in
+  current_level := level;
+  let body0 = newvar () in          (* Stub *)
+  let undo_abbrev =
+    match ty with
+    | None -> fun () -> () (* No abbreviation added *)
+    | Some ({desc = Tconstr (path, tl, _)} as ty) ->
+        let abbrev = proper_abbrevs path tl abbrev in
+        memorize_abbrev abbrev priv path ty body0;
+        fun () -> forget_abbrev abbrev path
+    | _ ->
+        assert false
+  in
+  abbreviations := abbrev;
+  let (params', body') = instance_parameterized_type params body in
+  abbreviations := ref Mnil;
+  try
+    !unify' env body0 body';
+    List.iter2 (!unify' env) params' args;
+    current_level := old_level;
+    body'
+  with Unify _ ->
+    current_level := old_level;
+    undo_abbrev ();
+    raise Cannot_subst
+
+(*
+   Only the shape of the type matters, not whether it is generic or
+   not. [generic_level] might be somewhat slower, but it ensures
+   invariants on types are enforced (decreasing levels), and we don't
+   care about efficiency here.
+*)
+let apply env params body args =
+  try
+    subst env generic_level Public (ref Mnil) None params args body
+  with
+    Cannot_subst -> raise Cannot_apply
+
+let () = Subst.ctype_apply_env_empty := apply Env.empty
+
+                              (****************************)
+                              (*  Abbreviation expansion  *)
+                              (****************************)
+
+(*
+   If the environment has changed, memorized expansions might not
+   be correct anymore, and so we flush the cache. This is safe but
+   quite pessimistic: it would be enough to flush the cache when a
+   type or module definition is overridden in the environment.
+*)
+let previous_env = ref Env.empty
+(*let string_of_kind = function Public -> "public" | Private -> "private"*)
+let check_abbrev_env env =
+  if env != !previous_env then begin
+    (* prerr_endline "cleanup expansion cache"; *)
+    cleanup_abbrev ();
+    previous_env := env
+  end
+
+
+(* Expand an abbreviation. The expansion is memorized. *)
+(*
+   Assume the level is greater than the path binding time of the
+   expanded abbreviation.
+*)
+(*
+   An abbreviation expansion will fail in either of these cases:
+   1. The type constructor does not correspond to a manifest type.
+   2. The type constructor is defined in an external file, and this
+      file is not in the path (missing -I options).
+   3. The type constructor is not in the "local" environment. This can
+      happens when a non-generic type variable has been instantiated
+      afterwards to the not yet defined type constructor. (Actually,
+      this cannot happen at the moment due to the strong constraints
+      between type levels and constructor binding time.)
+   4. The expansion requires the expansion of another abbreviation,
+      and this other expansion fails.
+*)
+let expand_abbrev_gen kind find_type_expansion env ty =
+  check_abbrev_env env;
+  match ty with
+    {desc = Tconstr (path, args, abbrev); level = level; scope} ->
+      let lookup_abbrev = proper_abbrevs path args abbrev in
+      begin match find_expans kind path !lookup_abbrev with
+        Some ty' ->
+          (* prerr_endline
+            ("found a "^string_of_kind kind^" expansion for "^Path.name path);*)
+          if level <> generic_level then
+            begin try
+              update_level env level ty'
+            with Escape _ ->
+              (* XXX This should not happen.
+                 However, levels are not correctly restored after a
+                 typing error *)
+              ()
+            end;
+          begin try
+            update_scope scope ty';
+          with Escape _ ->
+            (* XXX This should not happen.
+               However, levels are not correctly restored after a
+               typing error *)
+            ()
+          end;
+          let ty' = repr ty' in
+          (* assert (ty != ty'); *) (* PR#7324 *)
+          ty'
+      | None ->
+          match find_type_expansion path env with
+          | exception Not_found ->
+            (* another way to expand is to normalize the path itself *)
+            let path' = Env.normalize_type_path None env path in
+            if Path.same path path' then raise Cannot_expand
+            else newty2 level (Tconstr (path', args, abbrev))
+          | (params, body, lv) ->
+            (* prerr_endline
+              ("add a "^string_of_kind kind^" expansion for "^Path.name path);*)
+            let ty' =
+              try
+                subst env level kind abbrev (Some ty) params args body
+              with Cannot_subst -> raise_escape_exn Constraint
+            in
+            (* For gadts, remember type as non exportable *)
+            (* The ambiguous level registered for ty' should be the highest *)
+            (* if !trace_gadt_instances then begin *)
+            let scope = Int.max lv ty.scope in
+            update_scope scope ty;
+            update_scope scope ty';
+            ty'
+      end
+  | _ ->
+      assert false
+
+(* Expand respecting privacy *)
+let expand_abbrev env ty =
+  expand_abbrev_gen Public Env.find_type_expansion env ty
+
+(* Expand once the head of a type *)
+let expand_head_once env ty =
+  try
+    expand_abbrev env (repr ty)
+  with Cannot_expand | Escape _ -> assert false
+
+(* Check whether a type can be expanded *)
+let safe_abbrev env ty =
+  let snap = Btype.snapshot () in
+  try ignore (expand_abbrev env ty); true with
+    Cannot_expand ->
+      Btype.backtrack snap;
+      false
+  | Escape _ ->
+      Btype.backtrack snap;
+      cleanup_abbrev ();
+      false
+
+(* Expand the head of a type once.
+   Raise Cannot_expand if the type cannot be expanded.
+   May raise Escape, if a recursion was hidden in the type. *)
+let try_expand_once env ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tconstr _ -> repr (expand_abbrev env ty)
+  | _ -> raise Cannot_expand
+
+(* This one only raises Cannot_expand *)
+let try_expand_safe env ty =
+  let snap = Btype.snapshot () in
+  try try_expand_once env ty
+  with Escape _ ->
+    Btype.backtrack snap; cleanup_abbrev (); raise Cannot_expand
+
+(* Fully expand the head of a type. *)
+let rec try_expand_head try_once env ty =
+  let ty' = try_once env ty in
+  try try_expand_head try_once env ty'
+  with Cannot_expand -> ty'
+
+(* Unsafe full expansion, may raise [Unify [Escape _]]. *)
+let expand_head_unif env ty =
+  try
+    try_expand_head try_expand_once env ty
+  with
+  | Cannot_expand -> repr ty
+  | Escape e -> raise_for Unify (Escape e)
+
+(* Safe version of expand_head, never fails *)
+let expand_head env ty =
+  try try_expand_head try_expand_safe env ty with Cannot_expand -> repr ty
+
+let _ = forward_try_expand_safe := try_expand_safe
+
+
+(* Expand until we find a non-abstract type declaration,
+   use try_expand_safe to avoid raising "Unify _" when
+   called on recursive types
+ *)
+
+let rec extract_concrete_typedecl env ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tconstr (p, _, _) ->
+      let decl = Env.find_type p env in
+      if decl.type_kind <> Type_abstract then (p, p, decl) else
+      let ty =
+        try try_expand_safe env ty with Cannot_expand -> raise Not_found
+      in
+      let (_, p', decl) = extract_concrete_typedecl env ty in
+        (p, p', decl)
+  | _ -> raise Not_found
+
+(* Implementing function [expand_head_opt], the compiler's own version of
+   [expand_head] used for type-based optimisations.
+   [expand_head_opt] uses [Env.find_type_expansion_opt] to access the
+   manifest type information of private abstract data types which is
+   normally hidden to the type-checker out of the implementation module of
+   the private abbreviation. *)
+
+let expand_abbrev_opt env ty =
+  expand_abbrev_gen Private Env.find_type_expansion_opt env ty
+
+let safe_abbrev_opt env ty =
+  let snap = Btype.snapshot () in
+  try ignore (expand_abbrev_opt env ty); true
+  with Cannot_expand | Escape _ ->
+    Btype.backtrack snap;
+    false
+
+let try_expand_once_opt env ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tconstr _ -> repr (expand_abbrev_opt env ty)
+  | _ -> raise Cannot_expand
+
+let try_expand_safe_opt env ty =
+  let snap = Btype.snapshot () in
+  try try_expand_once_opt env ty
+  with Escape _ ->
+    Btype.backtrack snap; raise Cannot_expand
+
+let expand_head_opt env ty =
+  try try_expand_head try_expand_safe_opt env ty with Cannot_expand -> repr ty
+
+(* Recursively expand the head of a type.
+   Also expand #-types.
+
+   Error printing relies on [full_expand] returning exactly its input (i.e., a
+   physically equal type) when nothing changes. *)
+let full_expand ~may_forget_scope env ty =
+  let ty =
+    if may_forget_scope then
+      let ty = repr ty in
+      try expand_head_unif env ty with Unify _ ->
+        (* #10277: forget scopes when printing trace *)
+        begin_def ();
+        init_def ty.level;
+        let ty =
+          (* The same as [expand_head], except in the failing case we return the
+             *original* type, not [correct_levels ty].*)
+          try try_expand_head try_expand_safe env (correct_levels ty) with
+          | Cannot_expand -> repr ty
+        in
+        end_def ();
+        ty
+    else expand_head env ty
+  in
+  let ty = repr ty in
+  match ty.desc with
+    Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar (repr v) ->
+      newty2 ty.level (Tobject (fi, ref None))
+  | _ ->
+      ty
+
+(*
+   Check whether the abbreviation expands to a well-defined type.
+   During the typing of a class, abbreviations for correspondings
+   types expand to non-generic types.
+*)
+let generic_abbrev env path =
+  try
+    let (_, body, _) = Env.find_type_expansion path env in
+    (repr body).level = generic_level
+  with
+    Not_found ->
+      false
+
+let generic_private_abbrev env path =
+  try
+    match Env.find_type path env with
+      {type_kind = Type_abstract;
+       type_private = Private;
+       type_manifest = Some body} ->
+         (repr body).level = generic_level
+    | _ -> false
+  with Not_found -> false
+
+let is_contractive env p =
+  try
+    let decl = Env.find_type p env in
+    in_pervasives p && decl.type_manifest = None || is_datatype decl
+  with Not_found -> false
+
+
+                              (*****************)
+                              (*  Occur check  *)
+                              (*****************)
+
+
+exception Occur
+
+let rec occur_rec env allow_recursive visited ty0 = function
+  | {desc=Tlink ty} ->
+      occur_rec env allow_recursive visited ty0 ty
+  | ty ->
+  if ty == ty0  then raise Occur;
+  match ty.desc with
+    Tconstr(p, _tl, _abbrev) ->
+      if allow_recursive && is_contractive env p then () else
+      begin try
+        if TypeSet.mem ty visited then raise Occur;
+        let visited = TypeSet.add ty visited in
+        iter_type_expr (occur_rec env allow_recursive visited ty0) ty
+      with Occur -> try
+        let ty' = try_expand_head try_expand_once env ty in
+        (* This call used to be inlined, but there seems no reason for it.
+           Message was referring to change in rev. 1.58 of the CVS repo. *)
+        occur_rec env allow_recursive visited ty0 ty'
+      with Cannot_expand ->
+        raise Occur
+      end
+  | Tobject _ | Tvariant _ ->
+      ()
+  | _ ->
+      if allow_recursive ||  TypeSet.mem ty visited then () else begin
+        let visited = TypeSet.add ty visited in
+        iter_type_expr (occur_rec env allow_recursive visited ty0) ty
+      end
+
+let type_changed = ref false (* trace possible changes to the studied type *)
+
+let merge r b = if b then r := true
+
+let occur env ty0 ty =
+  let allow_recursive =
+    !Clflags.recursive_types || !umode = Pattern && !allow_recursive_equation in
+  let old = !type_changed in
+  try
+    while
+      type_changed := false;
+      occur_rec env allow_recursive TypeSet.empty ty0 ty;
+      !type_changed
+    do () (* prerr_endline "changed" *) done;
+    merge type_changed old
+  with exn ->
+    merge type_changed old;
+    raise exn
+
+let occur_for tr_exn env t1 t2 =
+  try
+    occur env t1 t2
+  with Occur -> raise_for tr_exn (Rec_occur(t1, t2))
+
+let occur_in env ty0 t =
+  try occur env ty0 t; false with Occur -> true
+
+(* Check that a local constraint is well-founded *)
+(* PR#6405: not needed since we allow recursion and work on normalized types *)
+(* PR#6992: we actually need it for contractiveness *)
+(* This is a simplified version of occur, only for the rectypes case *)
+
+let rec local_non_recursive_abbrev ~allow_rec strict visited env p ty =
+  (*Format.eprintf "@[Check %s =@ %a@]@." (Path.name p) !Btype.print_raw ty;*)
+  let ty = repr ty in
+  if not (List.memq ty visited) then begin
+    match ty.desc with
+      Tconstr(p', args, _abbrev) ->
+        if Path.same p p' then raise Occur;
+        if allow_rec && not strict && is_contractive env p' then () else
+        let visited = ty :: visited in
+        begin try
+          (* try expanding, since [p] could be hidden *)
+          local_non_recursive_abbrev ~allow_rec strict visited env p
+            (try_expand_head try_expand_safe_opt env ty)
+        with Cannot_expand ->
+          let params =
+            try (Env.find_type p' env).type_params
+            with Not_found -> args
+          in
+          List.iter2
+            (fun tv ty ->
+              let strict = strict || not (is_Tvar (repr tv)) in
+              local_non_recursive_abbrev ~allow_rec strict visited env p ty)
+            params args
+        end
+    | Tobject _ | Tvariant _ when not strict ->
+        ()
+    | _ ->
+        if strict || not allow_rec then (* PR#7374 *)
+          let visited = ty :: visited in
+          iter_type_expr
+            (local_non_recursive_abbrev ~allow_rec true visited env p) ty
+  end
+
+let local_non_recursive_abbrev env p ty =
+  let allow_rec =
+    !Clflags.recursive_types || !umode = Pattern && !allow_recursive_equation in
+  try (* PR#7397: need to check trace_gadt_instances *)
+    wrap_trace_gadt_instances env
+      (local_non_recursive_abbrev ~allow_rec false [] env p) ty;
+    true
+  with Occur -> false
+
+
+                   (*****************************)
+                   (*  Polymorphic Unification  *)
+                   (*****************************)
+
+(* Since we cannot duplicate universal variables, unification must
+   be done at meta-level, using bindings in univar_pairs *)
+(* TODO: use find_opt *)
+let rec unify_univar t1 t2 = function
+    (cl1, cl2) :: rem ->
+      let find_univ t cl =
+        try
+          let (_, r) = List.find (fun (t',_) -> t == repr t') cl in
+          Some r
+        with Not_found -> None
+      in
+      begin match find_univ t1 cl1, find_univ t2 cl2 with
+        Some {contents=Some t'2}, Some _ when t2 == repr t'2 ->
+          ()
+      | Some({contents=None} as r1), Some({contents=None} as r2) ->
+          set_univar r1 t2; set_univar r2 t1
+      | None, None ->
+          unify_univar t1 t2 rem
+      | _ ->
+          raise Cannot_unify_universal_variables
+      end
+  | [] -> raise Cannot_unify_universal_variables
+
+(* The same as [unify_univar], but raises the appropriate exception instead of
+   [Cannot_unify_universal_variables] *)
+let unify_univar_for tr_exn t1 t2 univar_pairs =
+  try unify_univar t1 t2 univar_pairs
+  with Cannot_unify_universal_variables -> raise_unexplained_for tr_exn
+
+(* Test the occurrence of free univars in a type *)
+(* That's way too expensive. Must do some kind of caching *)
+(* If [inj_only=true], only check injective positions *)
+let occur_univar ?(inj_only=false) env ty =
+  let visited = ref TypeMap.empty in
+  let rec occur_rec bound ty =
+    let ty = repr ty in
+    if not_marked_node ty then
+      if TypeSet.is_empty bound then
+        (flip_mark_node ty; occur_desc bound ty)
+      else try
+        let bound' = TypeMap.find ty !visited in
+        if not (TypeSet.subset bound' bound) then begin
+          visited := TypeMap.add ty (TypeSet.inter bound bound') !visited;
+          occur_desc bound ty
+        end
+      with Not_found ->
+        visited := TypeMap.add ty bound !visited;
+        occur_desc bound ty
+  and occur_desc bound ty =
+      match ty.desc with
+        Tunivar _ ->
+          if not (TypeSet.mem ty bound) then
+            raise_escape_exn (Univ ty)
+      | Tpoly (ty, tyl) ->
+          let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in
+          occur_rec bound  ty
+      | Tconstr (_, [], _) -> ()
+      | Tconstr (p, tl, _) ->
+          begin try
+            let td = Env.find_type p env in
+            List.iter2
+              (fun t v ->
+                (* The null variance only occurs in type abbreviations and
+                   corresponds to type variables that do not occur in the
+                   definition (expansion would erase them completely).
+                   The type-checker consistently ignores type expressions
+                   in this position. Physical expansion, as done in `occur`,
+                   would be costly here, since we need to check inside
+                   object and variant types too. *)
+                if Variance.(if inj_only then mem Inj v else not (eq v null))
+                then occur_rec bound t)
+              tl td.type_variance
+          with Not_found ->
+            if not inj_only then List.iter (occur_rec bound) tl
+          end
+      | _ -> iter_type_expr (occur_rec bound) ty
+  in
+  Misc.try_finally (fun () ->
+      occur_rec TypeSet.empty ty
+    )
+    ~always:(fun () -> unmark_type ty)
+
+let has_free_univars env ty =
+  try occur_univar ~inj_only:false env ty; false with Escape _ -> true
+let has_injective_univars env ty =
+  try occur_univar ~inj_only:true env ty; false with Escape _ -> true
+
+let occur_univar_for tr_exn env ty =
+  try
+    occur_univar env ty
+  with Escape e -> raise_for tr_exn (Escape e)
+
+(* Grouping univars by families according to their binders *)
+let add_univars =
+  List.fold_left (fun s (t,_) -> TypeSet.add (repr t) s)
+
+let get_univar_family univar_pairs univars =
+  if univars = [] then TypeSet.empty else
+  let insert s = function
+      cl1, (_::_ as cl2) ->
+        if List.exists (fun (t1,_) -> TypeSet.mem (repr t1) s) cl1 then
+          add_univars s cl2
+        else s
+    | _ -> s
+  in
+  let s = List.fold_right TypeSet.add univars TypeSet.empty in
+  List.fold_left insert s univar_pairs
+
+(* Whether a family of univars escapes from a type *)
+let univars_escape env univar_pairs vl ty =
+  let family = get_univar_family univar_pairs vl in
+  let visited = ref TypeSet.empty in
+  let rec occur t =
+    let t = repr t in
+    if TypeSet.mem t !visited then () else begin
+      visited := TypeSet.add t !visited;
+      match t.desc with
+        Tpoly (t, tl) ->
+          if List.exists (fun t -> TypeSet.mem (repr t) family) tl then ()
+          else occur t
+      | Tunivar _ -> if TypeSet.mem t family then raise_escape_exn (Univ t)
+      | Tconstr (_, [], _) -> ()
+      | Tconstr (p, tl, _) ->
+          begin try
+            let td = Env.find_type p env in
+            List.iter2
+              (* see occur_univar *)
+              (fun t v -> if not Variance.(eq v null) then occur t)
+              tl td.type_variance
+          with Not_found ->
+            List.iter occur tl
+          end
+      | _ ->
+          iter_type_expr occur t
+    end
+  in
+  occur ty
+
+(* Wrapper checking that no variable escapes and updating univar_pairs *)
+let enter_poly env univar_pairs t1 tl1 t2 tl2 f =
+  let old_univars = !univar_pairs in
+  let known_univars =
+    List.fold_left (fun s (cl,_) -> add_univars s cl)
+      TypeSet.empty old_univars
+  in
+  let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
+  if List.exists (fun t -> TypeSet.mem t known_univars) tl1 then
+     univars_escape env old_univars tl1 (newty(Tpoly(t2,tl2)));
+  if List.exists (fun t -> TypeSet.mem t known_univars) tl2 then
+    univars_escape env old_univars tl2 (newty(Tpoly(t1,tl1)));
+  let cl1 = List.map (fun t -> t, ref None) tl1
+  and cl2 = List.map (fun t -> t, ref None) tl2 in
+  univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars;
+  Misc.try_finally (fun () -> f t1 t2)
+    ~always:(fun () -> univar_pairs := old_univars)
+
+let enter_poly_for tr_exn env univar_pairs t1 tl1 t2 tl2 f =
+  try
+    enter_poly env univar_pairs t1 tl1 t2 tl2 f
+  with Escape e -> raise_for tr_exn (Escape e)
+
+let univar_pairs = ref []
+
+(**** Instantiate a generic type into a poly type ***)
+
+let polyfy env ty vars =
+  let subst_univar scope ty =
+    let ty = repr ty in
+    match ty.desc with
+    | Tvar name when ty.level = generic_level ->
+        For_copy.save_desc scope ty ty.desc;
+        let t = newty (Tunivar name) in
+        Private_type_expr.set_desc ty (Tsubst (t, None));
+        Some t
+    | _ -> None
+  in
+  (* need to expand twice? cf. Ctype.unify2 *)
+  let vars = List.map (expand_head env) vars in
+  let vars = List.map (expand_head env) vars in
+  For_copy.with_scope (fun scope ->
+    let vars' = List.filter_map (subst_univar scope) vars in
+    let ty = copy scope ty in
+    let ty = newty2 ty.level (Tpoly(repr ty, vars')) in
+    let complete = List.length vars = List.length vars' in
+    ty, complete
+  )
+
+(* assumption: [ty] is fully generalized. *)
+let reify_univars env ty =
+  let vars = free_variables ty in
+  let ty, _ = polyfy env ty vars in
+  ty
+
+                              (*****************)
+                              (*  Unification  *)
+                              (*****************)
+
+
+
+let rec has_cached_expansion p abbrev =
+  match abbrev with
+    Mnil                   -> false
+  | Mcons(_, p', _, _, rem)   -> Path.same p p' || has_cached_expansion p rem
+  | Mlink rem              -> has_cached_expansion p !rem
+
+(**** Transform error trace ****)
+(* +++ Move it to some other place ? *)
+
+let expand_any_trace map env trace =
+  let expand_desc x = match x.Errortrace.expanded with
+    | None ->
+      let expanded = full_expand ~may_forget_scope:true env x.t in
+      Errortrace.{ t = repr x.t; expanded = Some expanded }
+    | Some _ -> x in
+  map expand_desc trace
+
+let expand_trace env trace =
+  expand_any_trace Errortrace.map env trace
+
+let expand_subtype_trace env trace =
+  expand_any_trace Subtype.map env trace
+
+(**** Unification ****)
+
+(* Return whether [t0] occurs in [ty]. Objects are also traversed. *)
+let deep_occur t0 ty =
+  let rec occur_rec ty =
+    let ty = repr ty in
+    if ty.level >= t0.level && try_mark_node ty then begin
+      if ty == t0 then raise Occur;
+      iter_type_expr occur_rec ty
+    end
+  in
+  try
+    occur_rec ty; unmark_type ty; false
+  with Occur ->
+    unmark_type ty; true
+
+let gadt_equations_level = ref None
+
+let get_gadt_equations_level () =
+  match !gadt_equations_level with
+  | None -> assert false
+  | Some x -> x
+
+
+(* a local constraint can be added only if the rhs
+   of the constraint does not contain any Tvars.
+   They need to be removed using this function *)
+let reify env t =
+  let fresh_constr_scope = get_gadt_equations_level () in
+  let create_fresh_constr lev name =
+    let name = match name with Some s -> "$'"^s | _ -> "$" in
+    let decl = new_local_type () in
+    let (id, new_env) =
+      Env.enter_type (get_new_abstract_name name) decl !env
+        ~scope:fresh_constr_scope in
+    let path = Path.Pident id in
+    let t = newty2 lev (Tconstr (path,[],ref Mnil))  in
+    env := new_env;
+    path, t
+  in
+  let visited = ref TypeSet.empty in
+  let rec iterator ty =
+    let ty = repr ty in
+    if TypeSet.mem ty !visited then () else begin
+      visited := TypeSet.add ty !visited;
+      match ty.desc with
+        Tvar o ->
+          let path, t = create_fresh_constr ty.level o in
+          link_type ty t;
+          if ty.level < fresh_constr_scope then
+            raise_for Unify (Escape (escape (Constructor path)))
+      | Tvariant r ->
+          let r = row_repr r in
+          if not (static_row r) then begin
+            if is_fixed r then iterator (row_more r) else
+            let m = r.row_more in
+            match m.desc with
+              Tvar o ->
+                let path, t = create_fresh_constr m.level o in
+                let row =
+                  let row_fixed = Some (Reified path) in
+                  {r with row_fields=[]; row_fixed; row_more = t} in
+                link_type m (newty2 m.level (Tvariant row));
+                if m.level < fresh_constr_scope then
+                  raise_for Unify (Escape (escape (Constructor path)))
+            | _ -> assert false
+          end;
+          iter_row iterator r
+      | Tconstr (p, _, _) when is_object_type p ->
+          iter_type_expr iterator (full_expand ~may_forget_scope:false !env ty)
+      | _ ->
+          iter_type_expr iterator ty
+    end
+  in
+  iterator t
+
+let is_newtype env p =
+  try
+    let decl = Env.find_type p env in
+    decl.type_expansion_scope <> Btype.lowest_level &&
+    decl.type_kind = Type_abstract &&
+    decl.type_private = Public
+  with Not_found -> false
+
+let non_aliasable p decl =
+  (* in_pervasives p ||  (subsumed by in_current_module) *)
+  in_current_module p && not decl.type_is_newtype
+
+let is_instantiable env p =
+  try
+    let decl = Env.find_type p env in
+    decl.type_kind = Type_abstract &&
+    decl.type_private = Public &&
+    decl.type_arity = 0 &&
+    decl.type_manifest = None &&
+    not (non_aliasable p decl)
+  with Not_found -> false
+
+
+(* PR#7113: -safe-string should be a global property *)
+let compatible_paths p1 p2 =
+  let open Predef in
+  Path.same p1 p2 ||
+  Path.same p1 path_bytes && Path.same p2 path_string ||
+  Path.same p1 path_string && Path.same p2 path_bytes
+
+(* Check for datatypes carefully; see PR#6348 *)
+let rec expands_to_datatype env ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tconstr (p, _, _) ->
+      begin try
+        is_datatype (Env.find_type p env) ||
+        expands_to_datatype env (try_expand_safe env ty)
+      with Not_found | Cannot_expand -> false
+      end
+  | _ -> false
+
+(* [mcomp] tests if two types are "compatible" -- i.e., if they could ever
+   unify.  (This is distinct from [eqtype], which checks if two types *are*
+   exactly the same.)  This is used to decide whether GADT cases are
+   unreachable.  It is broadly part of unification. *)
+
+(* mcomp type_pairs subst env t1 t2 does not raise an
+   exception if it is possible that t1 and t2 are actually
+   equal, assuming the types in type_pairs are equal and
+   that the mapping subst holds.
+   Assumes that both t1 and t2 do not contain any tvars
+   and that both their objects and variants are closed
+ *)
+
+let rec mcomp type_pairs env t1 t2 =
+  if t1 == t2 then () else
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if t1 == t2 then () else
+  match (t1.desc, t2.desc) with
+  | (Tvar _, _)
+  | (_, Tvar _)  ->
+      ()
+  | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
+      ()
+  | _ ->
+      let t1' = expand_head_opt env t1 in
+      let t2' = expand_head_opt env t2 in
+      (* Expansion may have changed the representative of the types... *)
+      let t1' = repr t1' and t2' = repr t2' in
+      if t1' == t2' then () else
+      begin try TypePairs.find type_pairs (t1', t2')
+      with Not_found ->
+        TypePairs.add type_pairs (t1', t2') ();
+        match (t1'.desc, t2'.desc) with
+        | (Tvar _, _)
+        | (_, Tvar _)  ->
+            ()
+        | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _))
+          when l1 = l2 || not (is_optional l1 || is_optional l2) ->
+            mcomp type_pairs env t1 t2;
+            mcomp type_pairs env u1 u2;
+        | (Ttuple tl1, Ttuple tl2) ->
+            mcomp_list type_pairs env tl1 tl2
+        | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) ->
+            mcomp_type_decl type_pairs env p1 p2 tl1 tl2
+        | (Tconstr (_, [], _), _) when has_injective_univars env t2' ->
+            raise (Unify [])
+        | (_, Tconstr (_, [], _)) when has_injective_univars env t1' ->
+            raise (Unify [])
+        | (Tconstr (p, _, _), _) | (_, Tconstr (p, _, _)) ->
+            begin try
+              let decl = Env.find_type p env in
+              if non_aliasable p decl || is_datatype decl then
+                raise Incompatible
+            with Not_found -> ()
+            end
+        (*
+        | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) when n1 = n2 ->
+            mcomp_list type_pairs env tl1 tl2
+        *)
+        | (Tpackage _, Tpackage _) -> ()
+        | (Tvariant row1, Tvariant row2) ->
+            mcomp_row type_pairs env row1 row2
+        | (Tobject (fi1, _), Tobject (fi2, _)) ->
+            mcomp_fields type_pairs env fi1 fi2
+        | (Tfield _, Tfield _) ->       (* Actually unused *)
+            mcomp_fields type_pairs env t1' t2'
+        | (Tnil, Tnil) ->
+            ()
+        | (Tpoly (t1, []), Tpoly (t2, [])) ->
+            mcomp type_pairs env t1 t2
+        | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+            (try
+               enter_poly env univar_pairs
+                 t1 tl1 t2 tl2 (mcomp type_pairs env)
+             with Escape _ -> raise Incompatible)
+        | (Tunivar _, Tunivar _) ->
+            (try unify_univar t1' t2' !univar_pairs
+             with Cannot_unify_universal_variables -> raise Incompatible)
+        | (_, _) ->
+            raise Incompatible
+      end
+
+and mcomp_list type_pairs env tl1 tl2 =
+  if List.length tl1 <> List.length tl2 then
+    raise Incompatible;
+  List.iter2 (mcomp type_pairs env) tl1 tl2
+
+and mcomp_fields type_pairs env ty1 ty2 =
+  if not (concrete_object ty1 && concrete_object ty2) then assert false;
+  let (fields2, rest2) = flatten_fields ty2 in
+  let (fields1, rest1) = flatten_fields ty1 in
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  let has_present =
+    List.exists (fun (_, k, _) -> field_kind_repr k = Fpresent) in
+  mcomp type_pairs env rest1 rest2;
+  if has_present miss1  && (object_row ty2).desc = Tnil
+  || has_present miss2  && (object_row ty1).desc = Tnil then raise Incompatible;
+  List.iter
+    (function (_n, k1, t1, k2, t2) ->
+       mcomp_kind k1 k2;
+       mcomp type_pairs env t1 t2)
+    pairs
+
+and mcomp_kind k1 k2 =
+  let k1 = field_kind_repr k1 in
+  let k2 = field_kind_repr k2 in
+  match k1, k2 with
+    (Fpresent, Fabsent)
+  | (Fabsent, Fpresent) -> raise Incompatible
+  | _                   -> ()
+
+and mcomp_row type_pairs env row1 row2 =
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
+  let cannot_erase (_,f) =
+    match row_field_repr f with
+      Rpresent _ -> true
+    | Rabsent | Reither _ -> false
+  in
+  if row1.row_closed && List.exists cannot_erase r2
+  || row2.row_closed && List.exists cannot_erase r1 then raise Incompatible;
+  List.iter
+    (fun (_,f1,f2) ->
+      match row_field_repr f1, row_field_repr f2 with
+      | Rpresent None, (Rpresent (Some _) | Reither (_, _::_, _, _) | Rabsent)
+      | Rpresent (Some _), (Rpresent None | Reither (true, _, _, _) | Rabsent)
+      | (Reither (_, _::_, _, _) | Rabsent), Rpresent None
+      | (Reither (true, _, _, _) | Rabsent), Rpresent (Some _) ->
+          raise Incompatible
+      | Rpresent(Some t1), Rpresent(Some t2) ->
+          mcomp type_pairs env t1 t2
+      | Rpresent(Some t1), Reither(false, tl2, _, _) ->
+          List.iter (mcomp type_pairs env t1) tl2
+      | Reither(false, tl1, _, _), Rpresent(Some t2) ->
+          List.iter (mcomp type_pairs env t2) tl1
+      | _ -> ())
+    pairs
+
+and mcomp_type_decl type_pairs env p1 p2 tl1 tl2 =
+  try
+    let decl = Env.find_type p1 env in
+    let decl' = Env.find_type p2 env in
+    if compatible_paths p1 p2 then begin
+      let inj =
+        try List.map Variance.(mem Inj) (Env.find_type p1 env).type_variance
+        with Not_found -> List.map (fun _ -> false) tl1
+      in
+      List.iter2
+        (fun i (t1,t2) -> if i then mcomp type_pairs env t1 t2)
+        inj (List.combine tl1 tl2)
+    end else if non_aliasable p1 decl && non_aliasable p2 decl' then
+      raise Incompatible
+    else
+      match decl.type_kind, decl'.type_kind with
+      | Type_record (lst,r), Type_record (lst',r') when r = r' ->
+          mcomp_list type_pairs env tl1 tl2;
+          mcomp_record_description type_pairs env lst lst'
+      | Type_variant (v1,r), Type_variant (v2,r') when r = r' ->
+          mcomp_list type_pairs env tl1 tl2;
+          mcomp_variant_description type_pairs env v1 v2
+      | Type_open, Type_open ->
+          mcomp_list type_pairs env tl1 tl2
+      | Type_abstract, Type_abstract -> ()
+      | Type_abstract, _ when not (non_aliasable p1 decl)-> ()
+      | _, Type_abstract when not (non_aliasable p2 decl') -> ()
+      | _ -> raise Incompatible
+  with Not_found -> ()
+
+and mcomp_type_option type_pairs env t t' =
+  match t, t' with
+    None, None -> ()
+  | Some t, Some t' -> mcomp type_pairs env t t'
+  | _ -> raise Incompatible
+
+and mcomp_variant_description type_pairs env xs ys =
+  let rec iter = fun x y ->
+    match x, y with
+    | c1 :: xs, c2 :: ys   ->
+      mcomp_type_option type_pairs env c1.cd_res c2.cd_res;
+      begin match c1.cd_args, c2.cd_args with
+      | Cstr_tuple l1, Cstr_tuple l2 -> mcomp_list type_pairs env l1 l2
+      | Cstr_record l1, Cstr_record l2 ->
+          mcomp_record_description type_pairs env l1 l2
+      | _ -> raise Incompatible
+      end;
+     if Ident.name c1.cd_id = Ident.name c2.cd_id
+      then iter xs ys
+      else raise Incompatible
+    | [],[] -> ()
+    | _ -> raise Incompatible
+  in
+  iter xs ys
+
+and mcomp_record_description type_pairs env =
+  let rec iter x y =
+    match x, y with
+    | l1 :: xs, l2 :: ys ->
+        mcomp type_pairs env l1.ld_type l2.ld_type;
+        if Ident.name l1.ld_id = Ident.name l2.ld_id &&
+           l1.ld_mutable = l2.ld_mutable
+        then iter xs ys
+        else raise Incompatible
+    | [], [] -> ()
+    | _ -> raise Incompatible
+  in
+  iter
+
+let mcomp env t1 t2 =
+  mcomp (TypePairs.create 4) env t1 t2
+
+let mcomp_for tr_exn env t1 t2 =
+  try
+    mcomp env t1 t2
+  with Incompatible -> raise_unexplained_for tr_exn
+
+(* Real unification *)
+
+let find_lowest_level ty =
+  let lowest = ref generic_level in
+  let rec find ty =
+    let ty = repr ty in
+    if not_marked_node ty then begin
+      if ty.level < !lowest then lowest := ty.level;
+      flip_mark_node ty;
+      iter_type_expr find ty
+    end
+  in find ty; unmark_type ty; !lowest
+
+let find_expansion_scope env path =
+  (Env.find_type path env).type_expansion_scope
+
+let add_gadt_equation env source destination =
+  (* Format.eprintf "@[add_gadt_equation %s %a@]@."
+    (Path.name source) !Btype.print_raw destination; *)
+  if has_free_univars !env destination then
+    occur_univar ~inj_only:true !env destination
+  else if local_non_recursive_abbrev !env source destination then begin
+    let destination = duplicate_type destination in
+    let expansion_scope =
+      Int.max (Path.scope source) (get_gadt_equations_level ())
+    in
+    let decl =
+      new_local_type ~manifest_and_scope:(destination, expansion_scope) () in
+    env := Env.add_local_type source decl !env;
+    cleanup_abbrev ()
+  end
+
+let unify_eq_set = TypePairs.create 11
+
+let order_type_pair t1 t2 =
+  if t1.id <= t2.id then (t1, t2) else (t2, t1)
+
+let add_type_equality t1 t2 =
+  TypePairs.add unify_eq_set (order_type_pair t1 t2) ()
+
+let eq_package_path env p1 p2 =
+  Path.same p1 p2 ||
+  Path.same (normalize_package_path env p1) (normalize_package_path env p2)
+
+let nondep_type' = ref (fun _ _ _ -> assert false)
+let package_subtype = ref (fun _ _ _ _ _ -> assert false)
+
+exception Nondep_cannot_erase of Ident.t
+
+let rec concat_longident lid1 =
+  let open Longident in
+  function
+    Lident s -> Ldot (lid1, s)
+  | Ldot (lid2, s) -> Ldot (concat_longident lid1 lid2, s)
+  | Lapply (lid2, lid) -> Lapply (concat_longident lid1 lid2, lid)
+
+let nondep_instance env level id ty =
+  let ty = !nondep_type' env [id] ty in
+  if level = generic_level then duplicate_type ty else
+  let old = !current_level in
+  current_level := level;
+  let ty = instance ty in
+  current_level := old;
+  ty
+
+(* Find the type paths nl1 in the module type mty2, and add them to the
+   list (nl2, tl2). raise Not_found if impossible *)
+let complete_type_list ?(allow_absent=false) env fl1 lv2 mty2 fl2 =
+  (* This is morally WRONG: we're adding a (dummy) module without a scope in the
+     environment. However no operation which cares about levels/scopes is going
+     to happen while this module exists.
+     The only operations that happen are:
+     - Env.find_type_by_name
+     - nondep_instance
+     None of which check the scope.
+
+     It'd be nice if we avoided creating such temporary dummy modules and broken
+     environments though. *)
+  let id2 = Ident.create_local "Pkg" in
+  let env' = Env.add_module id2 Mp_present mty2 env in
+  let rec complete fl1 fl2 =
+    match fl1, fl2 with
+      [], _ -> fl2
+    | (n, _) :: nl, (n2, _ as nt2) :: ntl' when n >= n2 ->
+        nt2 :: complete (if n = n2 then nl else fl1) ntl'
+    | (n, _) :: nl, _ ->
+        let lid = concat_longident (Longident.Lident "Pkg") n in
+        match Env.find_type_by_name lid env' with
+        | (_, {type_arity = 0; type_kind = Type_abstract;
+               type_private = Public; type_manifest = Some t2}) ->
+            begin match nondep_instance env' lv2 id2 t2 with
+            | t -> (n, t) :: complete nl fl2
+            | exception Nondep_cannot_erase _ ->
+                if allow_absent then
+                  complete nl fl2
+                else
+                  raise Exit
+            end
+        | (_, {type_arity = 0; type_kind = Type_abstract;
+               type_private = Public; type_manifest = None})
+          when allow_absent ->
+            complete nl fl2
+        | _ -> raise Exit
+        | exception Not_found when allow_absent->
+            complete nl fl2
+  in
+  match complete fl1 fl2 with
+  | res -> res
+  | exception Exit -> raise Not_found
+
+(* raise Not_found rather than Unify if the module types are incompatible *)
+let unify_package env unify_list lv1 p1 fl1 lv2 p2 fl2 =
+  let ntl2 = complete_type_list env fl1 lv2 (Mty_ident p2) fl2
+  and ntl1 = complete_type_list env fl2 lv1 (Mty_ident p1) fl1 in
+  unify_list (List.map snd ntl1) (List.map snd ntl2);
+  if eq_package_path env p1 p2
+  || !package_subtype env p1 fl1 p2 fl2
+  && !package_subtype env p2 fl2 p1 fl1 then () else raise Not_found
+
+
+(* force unification in Reither when one side has a non-conjunctive type *)
+let rigid_variants = ref false
+
+let unify_eq t1 t2 =
+  t1 == t2 ||
+  match !umode with
+  | Expression -> false
+  | Pattern ->
+      try TypePairs.find unify_eq_set (order_type_pair t1 t2); true
+      with Not_found -> false
+
+let unify1_var env t1 t2 =
+  assert (is_Tvar t1);
+  occur_for Unify env t1 t2;
+  match occur_univar_for Unify env t2 with
+  | () ->
+      begin
+        try
+          update_level env t1.level t2;
+          update_scope t1.scope t2
+        with Escape e ->
+          raise_for Unify (Escape e)
+      end;
+      link_type t1 t2;
+      true
+  | exception Unify _ when !umode = Pattern ->
+      false
+
+(* Can only be called when generate_equations is true *)
+let record_equation t1 t2 =
+  match !equations_generation with
+  | Forbidden -> assert false
+  | Allowed { equated_types } -> TypePairs.add equated_types (t1, t2) ()
+
+(* Called from unify3 *)
+let unify3_var env t1' t2 t2' =
+  occur_for Unify !env t1' t2;
+  match occur_univar_for Unify !env t2 with
+  | () -> link_type t1' t2
+  | exception Unify _ when !umode = Pattern ->
+      reify env t1';
+      reify env t2';
+      if can_generate_equations () then begin
+        occur_univar ~inj_only:true !env t2';
+        record_equation t1' t2';
+      end
+
+(*
+   1. When unifying two non-abbreviated types, one type is made a link
+      to the other. When unifying an abbreviated type with a
+      non-abbreviated type, the non-abbreviated type is made a link to
+      the other one. When unifying to abbreviated types, these two
+      types are kept distincts, but they are made to (temporally)
+      expand to the same type.
+   2. Abbreviations with at least one parameter are systematically
+      expanded. The overhead does not seem too high, and that way
+      abbreviations where some parameters does not appear in the
+      expansion, such as ['a t = int], are correctly handled. In
+      particular, for this example, unifying ['a t] with ['b t] keeps
+      ['a] and ['b] distincts. (Is it really important ?)
+   3. Unifying an abbreviation ['a t = 'a] with ['a] should not yield
+      ['a t as 'a]. Indeed, the type variable would otherwise be lost.
+      This problem occurs for abbreviations expanding to a type
+      variable, but also to many other constrained abbreviations (for
+      instance, [(< x : 'a > -> unit) t = <x : 'a>]). The solution is
+      that, if an abbreviation is unified with some subpart of its
+      parameters, then the parameter actually does not get
+      abbreviated.  It would be possible to check whether some
+      information is indeed lost, but it probably does not worth it.
+*)
+
+let rec unify (env:Env.t ref) t1 t2 =
+  (* First step: special cases (optimizations) *)
+  if t1 == t2 then () else
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if unify_eq t1 t2 then () else
+  let reset_tracing = check_trace_gadt_instances !env in
+
+  try
+    type_changed := true;
+    begin match (t1.desc, t2.desc) with
+      (Tvar _, Tconstr _) when deep_occur t1 t2 ->
+        unify2 env t1 t2
+    | (Tconstr _, Tvar _) when deep_occur t2 t1 ->
+        unify2 env t1 t2
+    | (Tvar _, _) ->
+        if unify1_var !env t1 t2 then () else unify2 env t1 t2
+    | (_, Tvar _) ->
+        if unify1_var !env t2 t1 then () else unify2 env t1 t2
+    | (Tunivar _, Tunivar _) ->
+        unify_univar_for Unify t1 t2 !univar_pairs;
+        update_level_for Unify !env t1.level t2;
+        update_scope_for Unify t1.scope t2;
+        link_type t1 t2
+    | (Tconstr (p1, [], a1), Tconstr (p2, [], a2))
+          when Path.same p1 p2 (* && actual_mode !env = Old *)
+            (* This optimization assumes that t1 does not expand to t2
+               (and conversely), so we fall back to the general case
+               when any of the types has a cached expansion. *)
+            && not (has_cached_expansion p1 !a1
+                 || has_cached_expansion p2 !a2) ->
+        update_level_for Unify !env t1.level t2;
+        update_scope_for Unify t1.scope t2;
+        link_type t1 t2
+    | (Tconstr (p1, [], _), Tconstr (p2, [], _))
+      when Env.has_local_constraints !env
+      && is_newtype !env p1 && is_newtype !env p2 ->
+        (* Do not use local constraints more than necessary *)
+        begin try
+          if find_expansion_scope !env p1 > find_expansion_scope !env p2 then
+            unify env t1 (try_expand_safe !env t2)
+          else
+            unify env (try_expand_safe !env t1) t2
+        with Cannot_expand ->
+          unify2 env t1 t2
+        end
+    | _ ->
+        unify2 env t1 t2
+    end;
+    reset_trace_gadt_instances reset_tracing;
+  with Unify trace ->
+    reset_trace_gadt_instances reset_tracing;
+    raise( Unify (Errortrace.diff t1 t2 :: trace) )
+
+and unify2 env t1 t2 =
+  (* Second step: expansion of abbreviations *)
+  (* Expansion may change the representative of the types. *)
+  ignore (expand_head_unif !env t1);
+  ignore (expand_head_unif !env t2);
+  let t1' = expand_head_unif !env t1 in
+  let t2' = expand_head_unif !env t2 in
+  let lv = Int.min t1'.level t2'.level in
+  let scope = Int.max t1'.scope t2'.scope in
+  update_level_for Unify !env lv t2;
+  update_level_for Unify !env lv t1;
+  update_scope_for Unify scope t2;
+  update_scope_for Unify scope t1;
+  if unify_eq t1' t2' then () else
+
+  let t1 = repr t1 and t2 = repr t2 in
+  let t1, t2 =
+    if !Clflags.principal
+    && (find_lowest_level t1' < lv || find_lowest_level t2' < lv) then
+      (* Expand abbreviations hiding a lower level *)
+      (* Should also do it for parameterized types, after unification... *)
+      (match t1.desc with Tconstr (_, [], _) -> t1' | _ -> t1),
+      (match t2.desc with Tconstr (_, [], _) -> t2' | _ -> t2)
+    else (t1, t2)
+  in
+  if unify_eq t1 t1' || not (unify_eq t2 t2') then
+    unify3 env t1 t1' t2 t2'
+  else
+    try unify3 env t2 t2' t1 t1' with Unify trace ->
+      raise_trace_for Unify (swap_trace trace)
+
+and unify3 env t1 t1' t2 t2' =
+  (* Third step: truly unification *)
+  (* Assumes either [t1 == t1'] or [t2 != t2'] *)
+  let d1 = t1'.desc and d2 = t2'.desc in
+  let create_recursion = (t2 != t2') && (deep_occur t1' t2) in
+
+  begin match (d1, d2) with (* handle vars and univars specially *)
+    (Tunivar _, Tunivar _) ->
+      unify_univar_for Unify t1' t2' !univar_pairs;
+      link_type t1' t2'
+  | (Tvar _, _) ->
+      unify3_var env t1' t2 t2'
+  | (_, Tvar _) ->
+      unify3_var env t2' t1 t1'
+  | (Tfield _, Tfield _) -> (* special case for GADTs *)
+      unify_fields env t1' t2'
+  | _ ->
+    begin match !umode with
+    | Expression ->
+        occur_for Unify !env t1' t2';
+        if is_self_type d1 (* PR#7711: do not abbreviate self type *)
+        then link_type t1' t2'
+        else link_type t1' t2
+    | Pattern ->
+        add_type_equality t1' t2'
+    end;
+    try
+      begin match (d1, d2) with
+        (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2 ||
+        (!Clflags.classic || !umode = Pattern) &&
+        not (is_optional l1 || is_optional l2) ->
+          unify  env t1 t2; unify env  u1 u2;
+          begin match commu_repr c1, commu_repr c2 with
+            Clink r, c2 -> set_commu r c2
+          | c1, Clink r -> set_commu r c1
+          | _ -> ()
+          end
+      | (Ttuple tl1, Ttuple tl2) ->
+          unify_list env tl1 tl2
+      | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 ->
+          if !umode = Expression || !equations_generation = Forbidden then
+            unify_list env tl1 tl2
+          else if !assume_injective then
+            set_mode_pattern ~generate:!equations_generation ~injective:false
+              ~allow_recursive:!allow_recursive_equation
+              (fun () -> unify_list env tl1 tl2)
+          else if in_current_module p1 (* || in_pervasives p1 *)
+               || List.exists (expands_to_datatype !env) [t1'; t1; t2]
+          then
+            unify_list env tl1 tl2
+          else
+            let inj =
+              try List.map Variance.(mem Inj)
+                    (Env.find_type p1 !env).type_variance
+              with Not_found -> List.map (fun _ -> false) tl1
+            in
+            List.iter2
+              (fun i (t1, t2) ->
+                if i then unify env t1 t2 else
+                set_mode_pattern ~generate:Forbidden ~injective:false
+                  ~allow_recursive:!allow_recursive_equation
+                  begin fun () ->
+                    let snap = snapshot () in
+                    try unify env t1 t2 with Unify _ ->
+                      backtrack snap;
+                      reify env t1;
+                      reify env t2
+                  end)
+              inj (List.combine tl1 tl2)
+      | (Tconstr (path,[],_),
+         Tconstr (path',[],_))
+        when is_instantiable !env path && is_instantiable !env path'
+        && can_generate_equations () ->
+          let source, destination =
+            if Path.scope path > Path.scope path'
+            then  path , t2'
+            else  path', t1'
+          in
+          record_equation t1' t2';
+          add_gadt_equation env source destination
+      | (Tconstr (path,[],_), _)
+        when is_instantiable !env path && can_generate_equations () ->
+          reify env t2';
+          record_equation t1' t2';
+          add_gadt_equation env path t2'
+      | (_, Tconstr (path,[],_))
+        when is_instantiable !env path && can_generate_equations () ->
+          reify env t1';
+          record_equation t1' t2';
+          add_gadt_equation env path t1'
+      | (Tconstr (_,_,_), _) | (_, Tconstr (_,_,_)) when !umode = Pattern ->
+          reify env t1';
+          reify env t2';
+          if can_generate_equations () then (
+            mcomp_for Unify !env t1' t2';
+            record_equation t1' t2'
+          )
+      | (Tobject (fi1, nm1), Tobject (fi2, _)) ->
+          unify_fields env fi1 fi2;
+          (* Type [t2'] may have been instantiated by [unify_fields] *)
+          (* XXX One should do some kind of unification... *)
+          begin match (repr t2').desc with
+            Tobject (_, {contents = Some (_, va::_)}) when
+              (match (repr va).desc with
+                Tvar _|Tunivar _|Tnil -> true | _ -> false) -> ()
+          | Tobject (_, nm2) -> set_name nm2 !nm1
+          | _ -> ()
+          end
+      | (Tvariant row1, Tvariant row2) ->
+          if !umode = Expression then
+            unify_row env row1 row2
+          else begin
+            let snap = snapshot () in
+            try unify_row env row1 row2
+            with Unify _ ->
+              backtrack snap;
+              reify env t1';
+              reify env t2';
+              if can_generate_equations () then (
+                mcomp_for Unify !env t1' t2';
+                record_equation t1' t2'
+              )
+          end
+      | (Tfield(f,kind,_,rem), Tnil) | (Tnil, Tfield(f,kind,_,rem)) ->
+          begin match field_kind_repr kind with
+            Fvar r when f <> dummy_method ->
+              set_kind r Fabsent;
+              if d2 = Tnil then unify env rem t2'
+              else unify env (newty2 rem.level Tnil) rem
+          | _      ->
+              if f = dummy_method then
+                raise_for Unify (Obj Self_cannot_be_closed)
+              else if d1 = Tnil then
+                raise_for Unify (Obj (Missing_field(First, f)))
+              else
+                raise_for Unify (Obj (Missing_field(Second, f)))
+          end
+      | (Tnil, Tnil) ->
+          ()
+      | (Tpoly (t1, []), Tpoly (t2, [])) ->
+          unify env t1 t2
+      | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+          enter_poly_for Unify !env univar_pairs t1 tl1 t2 tl2 (unify env)
+      | (Tpackage (p1, fl1), Tpackage (p2, fl2)) ->
+          begin try
+            unify_package !env (unify_list env)
+              t1.level p1 fl1 t2.level p2 fl2
+          with Not_found ->
+            if !umode = Expression then raise_unexplained_for Unify;
+            List.iter (fun (_n, ty) -> reify env ty) (fl1 @ fl2);
+            (* if !generate_equations then List.iter2 (mcomp !env) tl1 tl2 *)
+          end
+      | (Tnil,  Tconstr _ ) ->
+          raise (Unify Errortrace.[Obj(Abstract_row Second)])
+      | (Tconstr _,  Tnil ) ->
+          raise (Unify Errortrace.[Obj(Abstract_row First)])
+      | (_, _) -> raise_unexplained_for Unify
+      end;
+      (* XXX Commentaires + changer "create_recursion"
+         ||| Comments + change "create_recursion" *)
+      if create_recursion then
+        match t2.desc with
+          Tconstr (p, tl, abbrev) ->
+            forget_abbrev abbrev p;
+            let t2'' = expand_head_unif !env t2 in
+            if not (closed_parameterized_type tl t2'') then
+              link_type (repr t2) (repr t2')
+        | _ ->
+            () (* t2 has already been expanded by update_level *)
+    with Unify trace ->
+      Private_type_expr.set_desc t1' d1;
+      raise_trace_for Unify trace
+  end
+
+and unify_list env tl1 tl2 =
+  if List.length tl1 <> List.length tl2 then
+    raise_unexplained_for Unify;
+  List.iter2 (unify env) tl1 tl2
+
+(* Build a fresh row variable for unification *)
+and make_rowvar level use1 rest1 use2 rest2  =
+  let set_name ty name =
+    match ty.desc with
+      Tvar None -> set_type_desc ty (Tvar name)
+    | _ -> ()
+  in
+  let name =
+    match rest1.desc, rest2.desc with
+      Tvar (Some _ as name1), Tvar (Some _ as name2) ->
+        if rest1.level <= rest2.level then name1 else name2
+    | Tvar (Some _ as name), _ ->
+        if use2 then set_name rest2 name; name
+    | _, Tvar (Some _ as name) ->
+        if use1 then set_name rest2 name; name
+    | _ -> None
+  in
+  if use1 then rest1 else
+  if use2 then rest2 else newvar2 ?name level
+
+and unify_fields env ty1 ty2 =          (* Optimization *)
+  let (fields1, rest1) = flatten_fields ty1
+  and (fields2, rest2) = flatten_fields ty2 in
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  let l1 = (repr ty1).level and l2 = (repr ty2).level in
+  let va = make_rowvar (Int.min l1 l2) (miss2=[]) rest1 (miss1=[]) rest2 in
+  let d1 = rest1.desc and d2 = rest2.desc in
+  try
+    unify env (build_fields l1 miss1 va) rest2;
+    unify env rest1 (build_fields l2 miss2 va);
+    List.iter
+      (fun (n, k1, t1, k2, t2) ->
+        unify_kind k1 k2;
+        try
+          if !trace_gadt_instances then begin
+            update_level_for Unify !env va.level t1;
+            update_scope_for Unify va.scope t1
+          end;
+          unify env t1 t2
+        with Unify trace ->
+          raise( Unify (Errortrace.incompatible_fields n t1 t2 :: trace) )
+      )
+      pairs
+  with exn ->
+    set_type_desc rest1 d1;
+    set_type_desc rest2 d2;
+    raise exn
+
+and unify_kind k1 k2 =
+  let k1 = field_kind_repr k1 in
+  let k2 = field_kind_repr k2 in
+  if k1 == k2 then () else
+  match k1, k2 with
+    (Fvar r, (Fvar _ | Fpresent)) -> set_kind r k2
+  | (Fpresent, Fvar r)            -> set_kind r k1
+  | (Fpresent, Fpresent)          -> ()
+  | _                             -> assert false
+
+and unify_row env row1 row2 =
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let rm1 = row_more row1 and rm2 = row_more row2 in
+  if unify_eq rm1 rm2 then () else
+  let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
+  if r1 <> [] && r2 <> [] then begin
+    let ht = Hashtbl.create (List.length r1) in
+    List.iter (fun (l,_) -> Hashtbl.add ht (hash_variant l) l) r1;
+    List.iter
+      (fun (l,_) ->
+        try raise (Tags(l, Hashtbl.find ht (hash_variant l)))
+        with Not_found -> ())
+      r2
+  end;
+  let fixed1 = fixed_explanation row1 and fixed2 = fixed_explanation row2 in
+  let more = match fixed1, fixed2 with
+    | Some _, Some _ -> if rm2.level < rm1.level then rm2 else rm1
+    | Some _, None -> rm1
+    | None, Some _ -> rm2
+    | None, None -> newty2 (Int.min rm1.level rm2.level) (Tvar None)
+  in
+  let fixed = merge_fixed_explanation fixed1 fixed2
+  and closed = row1.row_closed || row2.row_closed in
+  let keep switch =
+    List.for_all
+      (fun (_,f1,f2) ->
+        let f1, f2 = switch f1 f2 in
+        row_field_repr f1 = Rabsent || row_field_repr f2 <> Rabsent)
+      pairs
+  in
+  let empty fields =
+    List.for_all (fun (_,f) -> row_field_repr f = Rabsent) fields in
+  (* Check whether we are going to build an empty type *)
+  if closed && (empty r1 || row2.row_closed) && (empty r2 || row1.row_closed)
+  && List.for_all
+      (fun (_,f1,f2) ->
+        row_field_repr f1 = Rabsent || row_field_repr f2 = Rabsent)
+      pairs
+  then raise_for Unify (Variant No_intersection);
+  let name =
+    if row1.row_name <> None && (row1.row_closed || empty r2) &&
+      (not row2.row_closed || keep (fun f1 f2 -> f1, f2) && empty r1)
+    then row1.row_name
+    else if row2.row_name <> None && (row2.row_closed || empty r1) &&
+      (not row1.row_closed || keep (fun f1 f2 -> f2, f1) && empty r2)
+    then row2.row_name
+    else None
+  in
+  let row0 = {row_fields = []; row_more = more; row_bound = ();
+              row_closed = closed; row_fixed = fixed; row_name = name} in
+  let set_more row rest =
+    let rest =
+      if closed then
+        filter_row_fields row.row_closed rest
+      else rest in
+    begin match fixed_explanation row with
+      | None ->
+          if rest <> [] && row.row_closed then
+            let pos = if row == row1 then First else Second in
+            raise_for Unify (Variant (No_tags(pos,rest)))
+      | Some fixed ->
+          let pos = if row == row1 then First else Second in
+          if closed && not row.row_closed then
+            raise_for Unify (Variant (Fixed_row(pos,Cannot_be_closed,fixed)))
+          else if rest <> [] then
+            let case = Cannot_add_tags (List.map fst rest) in
+            raise_for Unify (Variant (Fixed_row(pos,case,fixed)))
+    end;
+    (* The following test is not principal... should rather use Tnil *)
+    let rm = row_more row in
+    (*if !trace_gadt_instances && rm.desc = Tnil then () else*)
+    if !trace_gadt_instances then
+      update_level_for Unify !env rm.level (newgenty (Tvariant row));
+    if row_fixed row then
+      if more == rm then () else
+      if is_Tvar rm then link_type rm more else unify env rm more
+    else
+      let ty = newgenty (Tvariant {row0 with row_fields = rest}) in
+      update_level_for Unify !env rm.level ty;
+      update_scope_for Unify rm.scope ty;
+      link_type rm ty
+  in
+  let md1 = rm1.desc and md2 = rm2.desc in
+  begin try
+    set_more row2 r1;
+    set_more row1 r2;
+    List.iter
+      (fun (l,f1,f2) ->
+        try unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2
+        with Unify trace ->
+          raise_trace_for Unify (Variant (Incompatible_types_for l) :: trace)
+      )
+      pairs;
+    if static_row row1 then begin
+      let rm = row_more row1 in
+      if is_Tvar rm then link_type rm (newty2 rm.level Tnil)
+    end
+  with exn ->
+    set_type_desc rm1 md1; set_type_desc rm2 md2; raise exn
+  end
+
+and unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 =
+  let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
+  let if_not_fixed (pos,fixed) f =
+    match fixed with
+    | None -> f ()
+    | Some fix ->
+        let tr = [Variant(Fixed_row(pos,Cannot_add_tags [l],fix))] in
+        raise_trace_for Unify tr in
+  let first = First, fixed1 and second = Second, fixed2 in
+  let either_fixed = match fixed1, fixed2 with
+    | None, None -> false
+    | _ -> true in
+  if f1 == f2 then () else
+  match f1, f2 with
+    Rpresent(Some t1), Rpresent(Some t2) -> unify env t1 t2
+  | Rpresent None, Rpresent None -> ()
+  | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) ->
+      if e1 == e2 then () else
+      if either_fixed && not (c1 || c2)
+      && List.length tl1 = List.length tl2 then begin
+        (* PR#7496 *)
+        let f = Reither (c1 || c2, [], m1 || m2, ref None) in
+        set_row_field e1 f; set_row_field e2 f;
+        List.iter2 (unify env) tl1 tl2
+      end
+      else let redo =
+        (m1 || m2 || either_fixed ||
+         !rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) &&
+        begin match tl1 @ tl2 with [] -> false
+        | t1 :: tl ->
+            if c1 || c2 then raise_unexplained_for Unify;
+            List.iter (unify env t1) tl;
+            !e1 <> None || !e2 <> None
+        end in
+      if redo then unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 else
+      let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
+      let rec remq tl = function [] -> []
+        | ty :: tl' ->
+            if List.memq ty tl then remq tl tl' else ty :: remq tl tl'
+      in
+      let tl1' = remq tl2 tl1 and tl2' = remq tl1 tl2 in
+      (* PR#6744 *)
+      let (tlu1,tl1') = List.partition (has_free_univars !env) tl1'
+      and (tlu2,tl2') = List.partition (has_free_univars !env) tl2' in
+      begin match tlu1, tlu2 with
+        [], [] -> ()
+      | (tu1::tlu1), _ :: _ ->
+          (* Attempt to merge all the types containing univars *)
+          List.iter (unify env tu1) (tlu1@tlu2)
+      | (tu::_, []) | ([], tu::_) ->
+          occur_univar_for Unify !env tu
+      end;
+      (* Is this handling of levels really principal? *)
+      List.iter (fun ty ->
+        let rm = repr rm2 in
+        update_level_for Unify !env rm.level ty;
+        update_scope_for Unify rm.scope ty;
+      ) tl1';
+      List.iter (fun ty ->
+        let rm = repr rm1 in
+        update_level_for Unify !env rm.level ty;
+        update_scope_for Unify rm.scope ty;
+      ) tl2';
+      let e = ref None in
+      let f1' = Reither(c1 || c2, tl2', m1 || m2, e)
+      and f2' = Reither(c1 || c2, tl1', m1 || m2, e) in
+      set_row_field e1 f1'; set_row_field e2 f2';
+  | Reither(_, _, false, e1), Rabsent ->
+      if_not_fixed first (fun () -> set_row_field e1 f2)
+  | Rabsent, Reither(_, _, false, e2) ->
+      if_not_fixed second (fun () -> set_row_field e2 f1)
+  | Rabsent, Rabsent -> ()
+  | Reither(false, tl, _, e1), Rpresent(Some t2) ->
+      if_not_fixed first (fun () ->
+          set_row_field e1 f2;
+          let rm = repr rm1 in
+          update_level_for Unify !env rm.level t2;
+          update_scope_for Unify rm.scope t2;
+          (try List.iter (fun t1 -> unify env t1 t2) tl
+           with exn -> e1 := None; raise exn)
+        )
+  | Rpresent(Some t1), Reither(false, tl, _, e2) ->
+      if_not_fixed second (fun () ->
+          set_row_field e2 f1;
+          let rm = repr rm2 in
+          update_level_for Unify !env rm.level t1;
+          update_scope_for Unify rm.scope t1;
+          (try List.iter (unify env t1) tl
+           with exn -> e2 := None; raise exn)
+        )
+  | Reither(true, [], _, e1), Rpresent None ->
+      if_not_fixed first (fun () -> set_row_field e1 f2)
+  | Rpresent None, Reither(true, [], _, e2) ->
+      if_not_fixed second (fun () -> set_row_field e2 f1)
+  | _ -> raise_unexplained_for Unify
+
+let unify env ty1 ty2 =
+  let snap = Btype.snapshot () in
+  try
+    unify env ty1 ty2
+  with
+    Unify trace ->
+      undo_compress snap;
+      raise (Unify (expand_trace !env trace))
+
+let unify_gadt ~equations_level:lev ~allow_recursive (env:Env.t ref) ty1 ty2 =
+  try
+    univar_pairs := [];
+    gadt_equations_level := Some lev;
+    let equated_types = TypePairs.create 0 in
+    set_mode_pattern
+      ~generate:(Allowed { equated_types })
+      ~injective:true
+      ~allow_recursive
+      (fun () -> unify env ty1 ty2);
+    gadt_equations_level := None;
+    TypePairs.clear unify_eq_set;
+    equated_types
+  with e ->
+    gadt_equations_level := None;
+    TypePairs.clear unify_eq_set;
+    raise e
+
+let unify_var env t1 t2 =
+  let t1 = repr t1 and t2 = repr t2 in
+  if t1 == t2 then () else
+  match t1.desc, t2.desc with
+    Tvar _, Tconstr _ when deep_occur t1 t2 ->
+      unify (ref env) t1 t2
+  | Tvar _, _ ->
+      let reset_tracing = check_trace_gadt_instances env in
+      begin try
+        occur_for Unify env t1 t2;
+        update_level_for Unify env t1.level t2;
+        update_scope_for Unify t1.scope t2;
+        link_type t1 t2;
+        reset_trace_gadt_instances reset_tracing;
+      with Unify trace ->
+        reset_trace_gadt_instances reset_tracing;
+        let expanded_trace =
+          expand_trace env @@ Errortrace.diff t1 t2 :: trace
+        in
+        raise_trace_for Unify expanded_trace
+      end
+  | _ ->
+      unify (ref env) t1 t2
+
+let _ = unify' := unify_var
+
+let unify_pairs env ty1 ty2 pairs =
+  univar_pairs := pairs;
+  unify env ty1 ty2
+
+let unify env ty1 ty2 =
+  unify_pairs (ref env) ty1 ty2 []
+
+
+
+(**** Special cases of unification ****)
+
+let expand_head_trace env t =
+  let reset_tracing = check_trace_gadt_instances env in
+  let t = expand_head_unif env t in
+  reset_trace_gadt_instances reset_tracing;
+  t
+
+(*
+   Unify [t] and [l:'a -> 'b]. Return ['a] and ['b].
+   In [-nolabels] mode, label mismatch is accepted when
+   (1) the requested label is ""
+   (2) the original label is not optional
+*)
+
+let filter_arrow env t l =
+  let t = expand_head_trace env t in
+  match t.desc with
+    Tvar _ ->
+      let lv = t.level in
+      let t1 = newvar2 lv and t2 = newvar2 lv in
+      let t' = newty2 lv (Tarrow (l, t1, t2, Cok)) in
+      link_type t t';
+      (t1, t2)
+  | Tarrow(l', t1, t2, _)
+    when l = l' || !Clflags.classic && l = Nolabel && not (is_optional l') ->
+      (t1, t2)
+  | _ ->
+      raise_unexplained_for Unify
+
+(* Used by [filter_method]. *)
+let rec filter_method_field env name priv ty =
+  let ty = expand_head_trace env ty in
+  match ty.desc with
+    Tvar _ ->
+      let level = ty.level in
+      let ty1 = newvar2 level and ty2 = newvar2 level in
+      let ty' = newty2 level (Tfield (name,
+                                      begin match priv with
+                                        Private -> Fvar (ref None)
+                                      | Public  -> Fpresent
+                                      end,
+                                      ty1, ty2))
+      in
+      link_type ty ty';
+      ty1
+  | Tfield(n, kind, ty1, ty2) ->
+      let kind = field_kind_repr kind in
+      if (n = name) && (kind <> Fabsent) then begin
+        if priv = Public then
+          unify_kind kind Fpresent;
+        ty1
+      end else
+        filter_method_field env name priv ty2
+  | _ ->
+      raise_unexplained_for Unify
+
+(* Unify [ty] and [< name : 'a; .. >]. Return ['a]. *)
+let filter_method env name priv ty =
+  let ty = expand_head_trace env ty in
+  match ty.desc with
+    Tvar _ ->
+      let ty1 = newvar () in
+      let ty' = newobj ty1 in
+      update_level_for Unify env ty.level ty';
+      update_scope_for Unify ty.scope ty';
+      link_type ty ty';
+      filter_method_field env name priv ty1
+  | Tobject(f, _) ->
+      filter_method_field env name priv f
+  | _ ->
+      raise_unexplained_for Unify
+
+let check_filter_method env name priv ty =
+  ignore(filter_method env name priv ty)
+
+let filter_self_method env lab priv meths ty =
+  let ty' = filter_method env lab priv ty in
+  try
+    Meths.find lab !meths
+  with Not_found ->
+    let pair = (Ident.create_local lab, ty') in
+    meths := Meths.add lab pair !meths;
+    pair
+
+
+                        (***********************************)
+                        (*  Matching between type schemes  *)
+                        (***********************************)
+
+(*
+   Update the level of [ty]. First check that the levels of generic
+   variables from the subject are not lowered.
+*)
+let moregen_occur env level ty =
+  let rec occur ty =
+    let ty = repr ty in
+    if ty.level <= level then () else
+    if is_Tvar ty && ty.level >= generic_level - 1 then raise Occur else
+    if try_mark_node ty then iter_type_expr occur ty
+  in
+  begin try
+    occur ty; unmark_type ty
+  with Occur ->
+    unmark_type ty; raise_unexplained_for Moregen
+  end;
+  (* also check for free univars *)
+  occur_univar_for Moregen env ty;
+  update_level_for Moregen env level ty
+
+let may_instantiate inst_nongen t1 =
+  if inst_nongen then t1.level <> generic_level - 1
+                 else t1.level =  generic_level
+
+let rec moregen inst_nongen type_pairs env t1 t2 =
+  if t1 == t2 then () else
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if t1 == t2 then () else
+  try
+    match (t1.desc, t2.desc) with
+    | (Tvar _, _) when may_instantiate inst_nongen t1 ->
+        moregen_occur env t1.level t2;
+        update_scope_for Moregen t1.scope t2;
+        occur_for Moregen env t1 t2;
+        link_type t1 t2
+    | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
+        ()
+    | _ ->
+        let t1' = expand_head env t1 in
+        let t2' = expand_head env t2 in
+        (* Expansion may have changed the representative of the types... *)
+        let t1' = repr t1' and t2' = repr t2' in
+        if t1' == t2' then () else
+        begin try
+          TypePairs.find type_pairs (t1', t2')
+        with Not_found ->
+          TypePairs.add type_pairs (t1', t2') ();
+          match (t1'.desc, t2'.desc) with
+            (Tvar _, _) when may_instantiate inst_nongen t1' ->
+              moregen_occur env t1'.level t2;
+              update_scope_for Moregen t1'.scope t2;
+              link_type t1' t2
+          | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2
+            || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
+              moregen inst_nongen type_pairs env t1 t2;
+              moregen inst_nongen type_pairs env u1 u2
+          | (Ttuple tl1, Ttuple tl2) ->
+              moregen_list inst_nongen type_pairs env tl1 tl2
+          | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
+                when Path.same p1 p2 ->
+              moregen_list inst_nongen type_pairs env tl1 tl2
+          | (Tpackage (p1, fl1), Tpackage (p2, fl2)) ->
+              begin try
+                unify_package env (moregen_list inst_nongen type_pairs env)
+                  t1'.level p1 fl1 t2'.level p2 fl2
+              with Not_found -> raise_unexplained_for Moregen
+              end
+          | (Tnil,  Tconstr _ ) -> raise_for Moregen (Obj (Abstract_row Second))
+          | (Tconstr _,  Tnil ) -> raise_for Moregen (Obj (Abstract_row First))
+          | (Tvariant row1, Tvariant row2) ->
+              moregen_row inst_nongen type_pairs env row1 row2
+          | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) ->
+              moregen_fields inst_nongen type_pairs env fi1 fi2
+          | (Tfield _, Tfield _) ->           (* Actually unused *)
+              moregen_fields inst_nongen type_pairs env t1' t2'
+          | (Tnil, Tnil) ->
+              ()
+          | (Tpoly (t1, []), Tpoly (t2, [])) ->
+              moregen inst_nongen type_pairs env t1 t2
+          | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+              enter_poly_for Moregen env univar_pairs t1 tl1 t2 tl2
+                (moregen inst_nongen type_pairs env)
+          | (Tunivar _, Tunivar _) ->
+              unify_univar_for Moregen t1' t2' !univar_pairs
+          | (_, _) ->
+              raise_unexplained_for Moregen
+        end
+  with Moregen trace -> raise ( Moregen ( Errortrace.diff t1 t2 :: trace ) );
+
+
+and moregen_list inst_nongen type_pairs env tl1 tl2 =
+  if List.length tl1 <> List.length tl2 then
+    raise_unexplained_for Moregen;
+  List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2
+
+and moregen_fields inst_nongen type_pairs env ty1 ty2 =
+  let (fields1, rest1) = flatten_fields ty1
+  and (fields2, rest2) = flatten_fields ty2 in
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  begin
+    match miss1 with
+    | (n, _, _) :: _ -> raise_for Moregen (Obj (Missing_field (Second, n)))
+    | [] -> ()
+  end;
+  moregen inst_nongen type_pairs env rest1
+    (build_fields (repr ty2).level miss2 rest2);
+
+  List.iter
+    (fun (n, k1, t1, k2, t2) ->
+       (* The below call should never throw [Public_method_to_private_method] *)
+       moregen_kind k1 k2;
+       try moregen inst_nongen type_pairs env t1 t2 with Moregen trace ->
+         raise( Moregen ( Errortrace.incompatible_fields n t1 t2 :: trace ) )
+    )
+    pairs
+
+and moregen_kind k1 k2 =
+  let k1 = field_kind_repr k1 in
+  let k2 = field_kind_repr k2 in
+  if k1 == k2 then () else
+  match k1, k2 with
+    (Fvar r, (Fvar _ | Fpresent))  -> set_kind r k2
+  | (Fpresent, Fpresent)           -> ()
+  | (Fpresent, Fvar _)             -> raise Public_method_to_private_method
+  | (Fabsent, _) | (_, Fabsent)    -> assert false
+
+and moregen_row inst_nongen type_pairs env row1 row2 =
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let rm1 = repr row1.row_more and rm2 = repr row2.row_more in
+  if rm1 == rm2 then () else
+  let may_inst =
+    is_Tvar rm1 && may_instantiate inst_nongen rm1 || rm1.desc = Tnil in
+  let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
+  let r1, r2 =
+    if row2.row_closed then
+      filter_row_fields may_inst r1, filter_row_fields false r2
+    else r1, r2
+  in
+  begin
+    if r1 <> [] then raise_for Moregen (Variant (No_tags (Second, r1)))
+  end;
+  if row1.row_closed then begin
+    match row2.row_closed, r2 with
+    | false, _ -> raise_for Moregen (Variant (Openness Second))
+    | _, _ :: _ -> raise_for Moregen (Variant (No_tags (First, r2)))
+    | _, [] -> ()
+  end;
+  begin match rm1.desc, rm2.desc with
+    Tunivar _, Tunivar _ ->
+      unify_univar_for Moregen rm1 rm2 !univar_pairs
+  | Tunivar _, _ | _, Tunivar _ ->
+      raise_unexplained_for Moregen
+  | _ when static_row row1 -> ()
+  | _ when may_inst ->
+      let ext =
+        newgenty (Tvariant {row2 with row_fields = r2; row_name = None})
+      in
+      moregen_occur env rm1.level ext;
+      update_scope_for Moregen rm1.scope ext;
+      link_type rm1 ext
+  | Tconstr _, Tconstr _ ->
+      moregen inst_nongen type_pairs env rm1 rm2
+  | _ -> raise_unexplained_for Moregen
+  end;
+  List.iter
+    (fun (l,f1,f2) ->
+       try
+         let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
+         if f1 == f2 then () else
+         match f1, f2 with
+         | Rpresent(Some t1), Rpresent(Some t2) ->
+             moregen inst_nongen type_pairs env t1 t2
+         | Rpresent None, Rpresent None -> ()
+         | Reither(false, tl1, _, e1), Rpresent(Some t2) when may_inst ->
+             set_row_field e1 f2;
+             List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1
+         | Reither(c1, tl1, _, e1), Reither(c2, tl2, m2, e2) ->
+             if e1 != e2 then begin
+               if c1 && not c2 then raise_unexplained_for Moregen;
+               set_row_field e1 (Reither (c2, [], m2, e2));
+               if List.length tl1 = List.length tl2 then
+                 List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2
+               else match tl2 with
+                 | t2 :: _ ->
+                     List.iter
+                       (fun t1 -> moregen inst_nongen type_pairs env t1 t2)
+                       tl1
+                 | [] -> if tl1 <> [] then raise_unexplained_for Moregen
+             end
+         | Reither(true, [], _, e1), Rpresent None when may_inst ->
+             set_row_field e1 f2
+         | Reither(_, _, _, e1), Rabsent when may_inst -> set_row_field e1 f2
+         | Rabsent, Rabsent -> ()
+         | Rpresent (Some _), Rpresent None -> raise_unexplained_for Moregen
+         | Rpresent None, Rpresent (Some _) -> raise_unexplained_for Moregen
+         | Rpresent _, Reither _ -> raise_unexplained_for Moregen
+         | _ -> raise_unexplained_for Moregen
+       with Moregen err ->
+         raise (Moregen (Variant (Incompatible_types_for l) :: err)))
+    pairs
+
+(* Must empty univar_pairs first *)
+let moregen inst_nongen type_pairs env patt subj =
+  univar_pairs := [];
+  moregen inst_nongen type_pairs env patt subj
+
+(*
+   Non-generic variable can be instantiated only if [inst_nongen] is
+   true. So, [inst_nongen] should be set to false if the subject might
+   contain non-generic variables (and we do not want them to be
+   instantiated).
+   Usually, the subject is given by the user, and the pattern
+   is unimportant.  So, no need to propagate abbreviations.
+*)
+let moregeneral env inst_nongen pat_sch subj_sch =
+  let old_level = !current_level in
+  current_level := generic_level - 1;
+  (*
+     Generic variables are first duplicated with [instance].  So,
+     their levels are lowered to [generic_level - 1].  The subject is
+     then copied with [duplicate_type].  That way, its levels won't be
+     changed.
+  *)
+  let subj = duplicate_type (instance subj_sch) in
+  current_level := generic_level;
+  (* Duplicate generic variables *)
+  let patt = instance pat_sch in
+
+  Misc.try_finally
+    (fun () -> moregen inst_nongen (TypePairs.create 13) env patt subj)
+    ~always:(fun () -> current_level := old_level)
+
+let is_moregeneral env inst_nongen pat_sch subj_sch =
+  match moregeneral env inst_nongen pat_sch subj_sch with
+  | () -> true
+  | exception Moregen _ -> false
+
+(* Alternative approach: "rigidify" a type scheme,
+   and check validity after unification *)
+(* Simpler, no? *)
+
+let rec rigidify_rec vars ty =
+  let ty = repr ty in
+  if try_mark_node ty then
+    begin match ty.desc with
+    | Tvar _ ->
+        if not (List.memq ty !vars) then vars := ty :: !vars
+    | Tvariant row ->
+        let row = row_repr row in
+        let more = repr row.row_more in
+        if is_Tvar more && not (row_fixed row) then begin
+          let more' = newty2 more.level more.desc in
+          let row' =
+            {row with row_fixed=Some Rigid; row_fields=[]; row_more=more'}
+          in link_type more (newty2 ty.level (Tvariant row'))
+        end;
+        iter_row (rigidify_rec vars) row;
+        (* only consider the row variable if the variant is not static *)
+        if not (static_row row) then rigidify_rec vars (row_more row)
+    | _ ->
+        iter_type_expr (rigidify_rec vars) ty
+    end
+
+let rigidify ty =
+  let vars = ref [] in
+  rigidify_rec vars ty;
+  unmark_type ty;
+  !vars
+
+let all_distinct_vars env vars =
+  let tyl = ref [] in
+  List.for_all
+    (fun ty ->
+      let ty = expand_head env ty in
+      if List.memq ty !tyl then false else
+      (tyl := ty :: !tyl; is_Tvar ty))
+    vars
+
+let matches env ty ty' =
+  let snap = snapshot () in
+  let vars = rigidify ty in
+  cleanup_abbrev ();
+  match unify env ty ty' with
+  | () ->
+      if not (all_distinct_vars env vars) then begin
+        backtrack snap;
+        raise (Matches_failure (env, [Errortrace.diff ty ty']))
+      end;
+      backtrack snap
+  | exception Unify trace ->
+      backtrack snap;
+      raise (Matches_failure (env, trace))
+
+let does_match env ty ty' =
+  match matches env ty ty' with
+  | () -> true
+  | exception Matches_failure (_, _) -> false
+
+                 (*********************************************)
+                 (*  Equivalence between parameterized types  *)
+                 (*********************************************)
+
+let expand_head_rigid env ty =
+  let old = !rigid_variants in
+  rigid_variants := true;
+  let ty' = expand_head env ty in
+  rigid_variants := old; ty'
+
+let normalize_subst subst =
+  if List.exists
+      (function {desc=Tlink _}, _ | _, {desc=Tlink _} -> true | _ -> false)
+      !subst
+  then subst := List.map (fun (t1,t2) -> repr t1, repr t2) !subst
+
+let rec eqtype rename type_pairs subst env t1 t2 =
+  if t1 == t2 then () else
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if t1 == t2 then () else
+
+  try
+    match (t1.desc, t2.desc) with
+    | (Tvar _, Tvar _) when rename ->
+        begin try
+          normalize_subst subst;
+          if List.assq t1 !subst != t2 then raise_unexplained_for Equality
+        with Not_found ->
+          if List.exists (fun (_, t) -> t == t2) !subst then
+            raise_unexplained_for Equality;
+          subst := (t1, t2) :: !subst
+        end
+    | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
+        ()
+    | _ ->
+        let t1' = expand_head_rigid env t1 in
+        let t2' = expand_head_rigid env t2 in
+        (* Expansion may have changed the representative of the types... *)
+        let t1' = repr t1' and t2' = repr t2' in
+        if t1' == t2' then () else
+        begin try
+          TypePairs.find type_pairs (t1', t2')
+        with Not_found ->
+          TypePairs.add type_pairs (t1', t2') ();
+          match (t1'.desc, t2'.desc) with
+          | (Tvar _, Tvar _) when rename ->
+              begin try
+                normalize_subst subst;
+                if List.assq t1' !subst != t2' then
+                  raise_unexplained_for Equality
+              with Not_found ->
+                if List.exists (fun (_, t) -> t == t2') !subst then
+                  raise_unexplained_for Equality;
+                subst := (t1', t2') :: !subst
+              end
+          | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2
+            || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
+              eqtype rename type_pairs subst env t1 t2;
+              eqtype rename type_pairs subst env u1 u2;
+          | (Ttuple tl1, Ttuple tl2) ->
+              eqtype_list rename type_pairs subst env tl1 tl2
+          | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
+                when Path.same p1 p2 ->
+              eqtype_list rename type_pairs subst env tl1 tl2
+          | (Tpackage (p1, fl1), Tpackage (p2, fl2)) ->
+              begin try
+                unify_package env (eqtype_list rename type_pairs subst env)
+                  t1'.level p1 fl1 t2'.level p2 fl2
+              with Not_found -> raise_unexplained_for Equality
+              end
+          | (Tnil,  Tconstr _ ) ->
+              raise_for Equality (Obj (Abstract_row Second))
+          | (Tconstr _,  Tnil ) ->
+              raise_for Equality (Obj (Abstract_row First))
+          | (Tvariant row1, Tvariant row2) ->
+              eqtype_row rename type_pairs subst env row1 row2
+          | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) ->
+              eqtype_fields rename type_pairs subst env fi1 fi2
+          | (Tfield _, Tfield _) ->       (* Actually unused *)
+              eqtype_fields rename type_pairs subst env t1' t2'
+          | (Tnil, Tnil) ->
+              ()
+          | (Tpoly (t1, []), Tpoly (t2, [])) ->
+              eqtype rename type_pairs subst env t1 t2
+          | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+              enter_poly_for Equality env univar_pairs t1 tl1 t2 tl2
+                (eqtype rename type_pairs subst env)
+          | (Tunivar _, Tunivar _) ->
+              unify_univar_for Equality t1' t2' !univar_pairs
+          | (_, _) ->
+              raise_unexplained_for Equality
+        end
+  with Equality trace ->  raise ( Equality (Errortrace.diff t1 t2 :: trace) )
+
+and eqtype_list rename type_pairs subst env tl1 tl2 =
+  if List.length tl1 <> List.length tl2 then
+    raise_unexplained_for Equality;
+  List.iter2 (eqtype rename type_pairs subst env) tl1 tl2
+
+and eqtype_fields rename type_pairs subst env ty1 ty2 =
+  let (fields1, rest1) = flatten_fields ty1 in
+  let (fields2, rest2) = flatten_fields ty2 in
+  (* First check if same row => already equal *)
+  let same_row =
+    rest1 == rest2 || TypePairs.mem type_pairs (rest1,rest2) ||
+    (rename && List.mem (rest1, rest2) !subst)
+  in
+  if same_row then () else
+  (* Try expansion, needed when called from Includecore.type_manifest *)
+  match expand_head_rigid env rest2 with
+    {desc=Tobject(ty2,_)} -> eqtype_fields rename type_pairs subst env ty1 ty2
+  | _ ->
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  eqtype rename type_pairs subst env rest1 rest2;
+  match miss1, miss2 with
+  | ((n, _, _)::_, _) -> raise_for Equality (Obj (Missing_field (Second, n)))
+  | (_, (n, _, _)::_) -> raise_for Equality (Obj (Missing_field (First, n)))
+  | [], [] ->
+      List.iter
+        (function (n, k1, t1, k2, t2) ->
+           eqtype_kind k1 k2;
+           try
+             eqtype rename type_pairs subst env t1 t2;
+           with Equality trace ->
+             raise (Equality (Errortrace.incompatible_fields n t1 t2 :: trace)))
+        pairs
+
+and eqtype_kind k1 k2 =
+  let k1 = field_kind_repr k1 in
+  let k2 = field_kind_repr k2 in
+  match k1, k2 with
+  | (Fvar _, Fvar _)
+  | (Fpresent, Fpresent) -> ()
+  | _                    -> raise_unexplained_for Equality
+
+and eqtype_row rename type_pairs subst env row1 row2 =
+  (* Try expansion, needed when called from Includecore.type_manifest *)
+  match expand_head_rigid env (row_more row2) with
+    {desc=Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2
+  | _ ->
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
+  if row1.row_closed <> row2.row_closed then begin
+    raise_for Equality
+      (Variant (Openness (if row2.row_closed then First else Second)))
+  end;
+  if not row1.row_closed then begin
+    match r1, r2 with
+    | _::_, _ -> raise_for Equality (Variant (No_tags (Second, r1)))
+    | _, _::_ -> raise_for Equality (Variant (No_tags (First,  r2)))
+    | _, _ -> ()
+  end;
+  begin
+    match filter_row_fields false r1 with
+    | [] -> ();
+    | _ :: _ as r1 -> raise_for Equality (Variant (No_tags (Second, r1)))
+  end;
+  begin
+    match filter_row_fields false r2 with
+    | [] -> ()
+    | _ :: _ as r2 -> raise_for Equality (Variant (No_tags (First, r2)))
+  end;
+  if not (static_row row1) then
+    eqtype rename type_pairs subst env row1.row_more row2.row_more;
+  List.iter
+    (fun (l,f1,f2) ->
+       try
+         match row_field_repr f1, row_field_repr f2 with
+         | Rpresent(Some t1), Rpresent(Some t2) ->
+             eqtype rename type_pairs subst env t1 t2
+         | Reither(c1, [], _, _), Reither(c2, [], _, _) when c1 = c2 -> ()
+         | Reither(c1, t1::tl1, _, _), Reither(c2, t2::tl2, _, _)
+           when c1 = c2 ->
+             eqtype rename type_pairs subst env t1 t2;
+             if List.length tl1 = List.length tl2 then
+               (* if same length allow different types (meaning?) *)
+               List.iter2 (eqtype rename type_pairs subst env) tl1 tl2
+             else begin
+               (* otherwise everything must be equal *)
+               List.iter (eqtype rename type_pairs subst env t1) tl2;
+               List.iter
+                 (fun t1 -> eqtype rename type_pairs subst env t1 t2) tl1
+             end
+         | Rpresent None, Rpresent None -> ()
+         | Rabsent, Rabsent -> ()
+         | Rpresent (Some _), Rpresent None -> raise_unexplained_for Equality
+         | Rpresent None, Rpresent (Some _) -> raise_unexplained_for Equality
+         | Rpresent _, Reither _ -> raise_unexplained_for Equality
+         | Reither _, Rpresent _ -> raise_unexplained_for Equality
+         | _ -> raise_unexplained_for Equality
+       with Equality err ->
+         raise (Equality (Variant (Incompatible_types_for l):: err)))
+    pairs
+
+(* Must empty univar_pairs first *)
+let eqtype_list rename type_pairs subst env tl1 tl2 =
+  univar_pairs := [];
+  let snap = Btype.snapshot () in
+  Misc.try_finally
+    ~always:(fun () -> backtrack snap)
+    (fun () -> eqtype_list rename type_pairs subst env tl1 tl2)
+
+let eqtype rename type_pairs subst env t1 t2 =
+  eqtype_list rename type_pairs subst env [t1] [t2]
+
+(* Two modes: with or without renaming of variables *)
+let equal env rename tyl1 tyl2 =
+  eqtype_list rename (TypePairs.create 11) (ref []) env tyl1 tyl2
+
+let is_equal env rename tyl1 tyl2 =
+  match equal env rename tyl1 tyl2 with
+  | () -> true
+  | exception Equality _ -> false
+
+let rec equal_private env params1 ty1 params2 ty2 =
+  match equal env true (params1 @ [ty1]) (params2 @ [ty2]) with
+  | () -> ()
+  | exception (Equality _ as err) ->
+      match try_expand_safe_opt env (expand_head env ty1) with
+      | ty1' -> equal_private env params1 ty1' params2 ty2
+      | exception Cannot_expand -> raise err
+
+                          (*************************)
+                          (*  Class type matching  *)
+                          (*************************)
+
+type class_match_failure_trace_type =
+  | CM_Equality
+  | CM_Moregen
+
+type class_match_failure =
+    CM_Virtual_class
+  | CM_Parameter_arity_mismatch of int * int
+  | CM_Type_parameter_mismatch of Env.t * comparison Errortrace.t (* Equality *)
+  | CM_Class_type_mismatch of Env.t * class_type * class_type
+  | CM_Parameter_mismatch of Env.t * comparison Errortrace.t (* Moregen *)
+  | CM_Val_type_mismatch of
+      class_match_failure_trace_type * string * Env.t * comparison Errortrace.t
+  | CM_Meth_type_mismatch of
+      class_match_failure_trace_type * string * Env.t * comparison Errortrace.t
+  | CM_Non_mutable_value of string
+  | CM_Non_concrete_value of string
+  | CM_Missing_value of string
+  | CM_Missing_method of string
+  | CM_Hide_public of string
+  | CM_Hide_virtual of string * string
+  | CM_Public_method of string
+  | CM_Private_method of string
+  | CM_Virtual_method of string
+
+exception Failure of class_match_failure list
+
+let rec moregen_clty trace type_pairs env cty1 cty2 =
+  try
+    match cty1, cty2 with
+      Cty_constr (_, _, cty1), _ ->
+        moregen_clty true type_pairs env cty1 cty2
+    | _, Cty_constr (_, _, cty2) ->
+        moregen_clty true type_pairs env cty1 cty2
+    | Cty_arrow (l1, ty1, cty1'), Cty_arrow (l2, ty2, cty2') when l1 = l2 ->
+        begin try moregen true type_pairs env ty1 ty2 with Moregen trace ->
+          raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)])
+        end;
+        moregen_clty false type_pairs env cty1' cty2'
+    | Cty_signature sign1, Cty_signature sign2 ->
+        let ty1 = object_fields (repr sign1.csig_self) in
+        let ty2 = object_fields (repr sign2.csig_self) in
+        let (fields1, _rest1) = flatten_fields ty1
+        and (fields2, _rest2) = flatten_fields ty2 in
+        let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in
+        List.iter
+          (fun (lab, _k1, t1, _k2, t2) ->
+            try moregen true type_pairs env t1 t2 with Moregen trace ->
+              raise (Failure [
+                CM_Meth_type_mismatch
+                  (CM_Moregen, lab, env, expand_trace env trace)]))
+          pairs;
+      Vars.iter
+        (fun lab (_mut, _v, ty) ->
+           let (_mut', _v', ty') = Vars.find lab sign1.csig_vars in
+           try moregen true type_pairs env ty' ty with Moregen trace ->
+             raise (Failure [
+               CM_Val_type_mismatch
+                 (CM_Moregen, lab, env, expand_trace env trace)]))
+        sign2.csig_vars
+  | _ ->
+      raise (Failure [])
+  with
+    Failure error when trace || error = [] ->
+      raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error))
+
+let match_class_types ?(trace=true) env pat_sch subj_sch =
+  let type_pairs = TypePairs.create 53 in
+  let old_level = !current_level in
+  current_level := generic_level - 1;
+  (*
+     Generic variables are first duplicated with [instance].  So,
+     their levels are lowered to [generic_level - 1].  The subject is
+     then copied with [duplicate_type].  That way, its levels won't be
+     changed.
+  *)
+  let (_, subj_inst) = instance_class [] subj_sch in
+  let subj = duplicate_class_type subj_inst in
+  current_level := generic_level;
+  (* Duplicate generic variables *)
+  let (_, patt) = instance_class [] pat_sch in
+  let res =
+    let sign1 = signature_of_class_type patt in
+    let sign2 = signature_of_class_type subj in
+    let t1 = repr sign1.csig_self in
+    let t2 = repr sign2.csig_self in
+    TypePairs.add type_pairs (t1, t2) ();
+    let (fields1, rest1) = flatten_fields (object_fields t1)
+    and (fields2, rest2) = flatten_fields (object_fields t2) in
+    let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+    let error =
+      List.fold_right
+        (fun (lab, k, _) err ->
+           let err =
+             let k = field_kind_repr k in
+             begin match k with
+               Fvar r -> set_kind r Fabsent; err
+             | _      -> CM_Hide_public lab::err
+             end
+           in
+           if lab = dummy_method || Concr.mem lab sign1.csig_concr then err
+           else CM_Hide_virtual ("method", lab) :: err)
+        miss1 []
+    in
+    let missing_method = List.map (fun (m, _, _) -> m) miss2 in
+    let error =
+      (List.map (fun m -> CM_Missing_method m) missing_method) @ error
+    in
+    (* Always succeeds *)
+    moregen true type_pairs env rest1 rest2;
+    let error =
+      List.fold_right
+        (fun (lab, k1, _t1, k2, _t2) err ->
+           match moregen_kind k1 k2 with
+           | () -> err
+           | exception Public_method_to_private_method ->
+               CM_Public_method lab :: err)
+        pairs error
+    in
+    let error =
+      Vars.fold
+        (fun lab (mut, vr, _ty) err ->
+          try
+            let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in
+            if mut = Mutable && mut' <> Mutable then
+              CM_Non_mutable_value lab::err
+            else if vr = Concrete && vr' <> Concrete then
+              CM_Non_concrete_value lab::err
+            else
+              err
+          with Not_found ->
+            CM_Missing_value lab::err)
+        sign2.csig_vars error
+    in
+    let error =
+      Vars.fold
+        (fun lab (_,vr,_) err ->
+          if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then
+            CM_Hide_virtual ("instance variable", lab) :: err
+          else err)
+        sign1.csig_vars error
+    in
+    let error =
+      List.fold_right
+        (fun e l ->
+           if List.mem e missing_method then l else CM_Virtual_method e::l)
+        (Concr.elements (Concr.diff sign2.csig_concr sign1.csig_concr))
+        error
+    in
+    match error with
+      [] ->
+        begin try
+          moregen_clty trace type_pairs env patt subj;
+          []
+        with
+          Failure r -> r
+        end
+    | error ->
+        CM_Class_type_mismatch (env, patt, subj)::error
+  in
+  current_level := old_level;
+  res
+
+let equal_clsig trace type_pairs subst env sign1 sign2 =
+  try
+    let ty1 = object_fields (repr sign1.csig_self) in
+    let ty2 = object_fields (repr sign2.csig_self) in
+    let (fields1, _rest1) = flatten_fields ty1
+    and (fields2, _rest2) = flatten_fields ty2 in
+    let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in
+    List.iter
+      (fun (lab, _k1, t1, _k2, t2) ->
+         begin try eqtype true type_pairs subst env t1 t2 with
+           Equality trace ->
+           raise (Failure [CM_Meth_type_mismatch
+                             (CM_Equality, lab, env, expand_trace env trace)])
+         end)
+      pairs;
+    Vars.iter
+      (fun lab (_, _, ty) ->
+         let (_, _, ty') = Vars.find lab sign1.csig_vars in
+         try eqtype true type_pairs subst env ty' ty with Equality trace ->
+           raise (Failure [CM_Val_type_mismatch
+                             (CM_Equality, lab, env, expand_trace env trace)]))
+      sign2.csig_vars
+  with
+    Failure error when trace ->
+      raise (Failure (CM_Class_type_mismatch
+                        (env, Cty_signature sign1, Cty_signature sign2)::error))
+
+let match_class_declarations env patt_params patt_type subj_params subj_type =
+  let type_pairs = TypePairs.create 53 in
+  let subst = ref [] in
+  let sign1 = signature_of_class_type patt_type in
+  let sign2 = signature_of_class_type subj_type in
+  let t1 = repr sign1.csig_self in
+  let t2 = repr sign2.csig_self in
+  TypePairs.add type_pairs (t1, t2) ();
+  let (fields1, rest1) = flatten_fields (object_fields t1)
+  and (fields2, rest2) = flatten_fields (object_fields t2) in
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  let error =
+    List.fold_right
+      (fun (lab, k, _) err ->
+        let err =
+          let k = field_kind_repr k in
+          begin match k with
+            Fvar _ -> err
+          | _      -> CM_Hide_public lab::err
+          end
+        in
+        if Concr.mem lab sign1.csig_concr then err
+        else CM_Hide_virtual ("method", lab) :: err)
+      miss1 []
+  in
+  let missing_method = List.map (fun (m, _, _) -> m) miss2 in
+  let error =
+    (List.map (fun m -> CM_Missing_method m) missing_method) @ error
+  in
+  (* Always succeeds *)
+  eqtype true type_pairs subst env rest1 rest2;
+  let error =
+    List.fold_right
+      (fun (lab, k1, _t1, k2, _t2) err ->
+        let k1 = field_kind_repr k1 in
+        let k2 = field_kind_repr k2 in
+        match k1, k2 with
+          (Fvar _, Fvar _)
+        | (Fpresent, Fpresent) -> err
+        | (Fvar _, Fpresent)   -> CM_Private_method lab::err
+        | (Fpresent, Fvar _)  -> CM_Public_method lab::err
+        | _                    -> assert false)
+      pairs error
+  in
+  let error =
+    Vars.fold
+      (fun lab (mut, vr, _ty) err ->
+         try
+           let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in
+           if mut = Mutable && mut' <> Mutable then
+             CM_Non_mutable_value lab::err
+           else if vr = Concrete && vr' <> Concrete then
+             CM_Non_concrete_value lab::err
+           else
+             err
+         with Not_found ->
+           CM_Missing_value lab::err)
+      sign2.csig_vars error
+  in
+  let error =
+    Vars.fold
+      (fun lab (_,vr,_) err ->
+        if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then
+          CM_Hide_virtual ("instance variable", lab) :: err
+        else err)
+      sign1.csig_vars error
+  in
+  let error =
+    List.fold_right
+      (fun e l ->
+        if List.mem e missing_method then l else CM_Virtual_method e::l)
+      (Concr.elements (Concr.diff sign2.csig_concr sign1.csig_concr))
+      error
+  in
+  match error with
+    [] ->
+      begin try
+        let lp = List.length patt_params in
+        let ls = List.length subj_params in
+        if lp  <> ls then
+          raise (Failure [CM_Parameter_arity_mismatch (lp, ls)]);
+        List.iter2 (fun p s ->
+          try eqtype true type_pairs subst env p s with Equality trace ->
+            raise (Failure [CM_Type_parameter_mismatch
+                               (env, expand_trace env trace)]))
+          patt_params subj_params;
+     (* old code: equal_clty false type_pairs subst env patt_type subj_type; *)
+        equal_clsig false type_pairs subst env sign1 sign2;
+        (* Use moregeneral for class parameters, need to recheck everything to
+           keeps relationships (PR#4824) *)
+        let clty_params =
+          List.fold_right (fun ty cty -> Cty_arrow (Labelled "*",ty,cty)) in
+        match_class_types ~trace:false env
+          (clty_params patt_params patt_type)
+          (clty_params subj_params subj_type)
+      with
+        Failure r -> r
+      end
+  | error ->
+      error
+
+
+                              (***************)
+                              (*  Subtyping  *)
+                              (***************)
+
+
+(**** Build a subtype of a given type. ****)
+
+(* build_subtype:
+   [visited] traces traversed object and variant types
+   [loops] is a mapping from variables to variables, to reproduce
+     positive loops in a class type
+   [posi] true if the current variance is positive
+   [level] number of expansions/enlargement allowed on this branch *)
+
+let warn = ref false  (* whether double coercion might do better *)
+let pred_expand n = if n mod 2 = 0 && n > 0 then pred n else n
+let pred_enlarge n = if n mod 2 = 1 then pred n else n
+
+type change = Unchanged | Equiv | Changed
+let max_change c1 c2 =
+  match c1, c2 with
+  | _, Changed | Changed, _ -> Changed
+  | Equiv, _ | _, Equiv -> Equiv
+  | _ -> Unchanged
+
+let collect l = List.fold_left (fun c1 (_, c2) -> max_change c1 c2) Unchanged l
+
+let rec filter_visited = function
+    [] -> []
+  | {desc=Tobject _|Tvariant _} :: _ as l -> l
+  | _ :: l -> filter_visited l
+
+let memq_warn t visited =
+  if List.memq t visited then (warn := true; true) else false
+
+let find_cltype_for_path env p =
+  let cl_abbr = Env.find_hash_type p env in
+  match cl_abbr.type_manifest with
+    Some ty ->
+      begin match (repr ty).desc with
+        Tobject(_,{contents=Some(p',_)}) when Path.same p p' -> cl_abbr, ty
+      | _ -> raise Not_found
+      end
+  | None -> assert false
+
+let has_constr_row' env t =
+  has_constr_row (expand_abbrev env t)
+
+let rec build_subtype env visited loops posi level t =
+  let t = repr t in
+  match t.desc with
+    Tvar _ ->
+      if posi then
+        try
+          let t' = List.assq t loops in
+          warn := true;
+          (t', Equiv)
+        with Not_found ->
+          (t, Unchanged)
+      else
+        (t, Unchanged)
+  | Tarrow(l, t1, t2, _) ->
+      if memq_warn t visited then (t, Unchanged) else
+      let visited = t :: visited in
+      let (t1', c1) = build_subtype env visited loops (not posi) level t1 in
+      let (t2', c2) = build_subtype env visited loops posi level t2 in
+      let c = max_change c1 c2 in
+      if c > Unchanged then (newty (Tarrow(l, t1', t2', Cok)), c)
+      else (t, Unchanged)
+  | Ttuple tlist ->
+      if memq_warn t visited then (t, Unchanged) else
+      let visited = t :: visited in
+      let tlist' =
+        List.map (build_subtype env visited loops posi level) tlist
+      in
+      let c = collect tlist' in
+      if c > Unchanged then (newty (Ttuple (List.map fst tlist')), c)
+      else (t, Unchanged)
+  | Tconstr(p, tl, abbrev)
+    when level > 0 && generic_abbrev env p && safe_abbrev env t
+    && not (has_constr_row' env t) ->
+      let t' = repr (expand_abbrev env t) in
+      let level' = pred_expand level in
+      begin try match t'.desc with
+        Tobject _ when posi && not (opened_object t') ->
+          let cl_abbr, body = find_cltype_for_path env p in
+          let ty =
+            try
+              subst env !current_level Public abbrev None
+                cl_abbr.type_params tl body
+            with Cannot_subst -> assert false in
+          let ty = repr ty in
+          let ty1, tl1 =
+            match ty.desc with
+              Tobject(ty1,{contents=Some(p',tl1)}) when Path.same p p' ->
+                ty1, tl1
+            | _ -> raise Not_found
+          in
+          (* Fix PR#4505: do not set ty to Tvar when it appears in tl1,
+             as this occurrence might break the occur check.
+             XXX not clear whether this correct anyway... *)
+          if List.exists (deep_occur ty) tl1 then raise Not_found;
+          set_type_desc ty (Tvar None);
+          let t'' = newvar () in
+          let loops = (ty, t'') :: loops in
+          (* May discard [visited] as level is going down *)
+          let (ty1', c) =
+            build_subtype env [t'] loops posi (pred_enlarge level') ty1 in
+          assert (is_Tvar t'');
+          let nm =
+            if c > Equiv || deep_occur ty ty1' then None else Some(p,tl1) in
+          set_type_desc t'' (Tobject (ty1', ref nm));
+          (try unify_var env ty t with Unify _ -> assert false);
+          (t'', Changed)
+      | _ -> raise Not_found
+      with Not_found ->
+        let (t'',c) = build_subtype env visited loops posi level' t' in
+        if c > Unchanged then (t'',c)
+        else (t, Unchanged)
+      end
+  | Tconstr(p, tl, _abbrev) ->
+      (* Must check recursion on constructors, since we do not always
+         expand them *)
+      if memq_warn t visited then (t, Unchanged) else
+      let visited = t :: visited in
+      begin try
+        let decl = Env.find_type p env in
+        if level = 0 && generic_abbrev env p && safe_abbrev env t
+        && not (has_constr_row' env t)
+        then warn := true;
+        let tl' =
+          List.map2
+            (fun v t ->
+              let (co,cn) = Variance.get_upper v in
+              if cn then
+                if co then (t, Unchanged)
+                else build_subtype env visited loops (not posi) level t
+              else
+                if co then build_subtype env visited loops posi level t
+                else (newvar(), Changed))
+            decl.type_variance tl
+        in
+        let c = collect tl' in
+        if c > Unchanged then (newconstr p (List.map fst tl'), c)
+        else (t, Unchanged)
+      with Not_found ->
+        (t, Unchanged)
+      end
+  | Tvariant row ->
+      let row = row_repr row in
+      if memq_warn t visited || not (static_row row) then (t, Unchanged) else
+      let level' = pred_enlarge level in
+      let visited =
+        t :: if level' < level then [] else filter_visited visited in
+      let fields = filter_row_fields false row.row_fields in
+      let fields =
+        List.map
+          (fun (l,f as orig) -> match row_field_repr f with
+            Rpresent None ->
+              if posi then
+                (l, Reither(true, [], false, ref None)), Unchanged
+              else
+                orig, Unchanged
+          | Rpresent(Some t) ->
+              let (t', c) = build_subtype env visited loops posi level' t in
+              let f =
+                if posi && level > 0
+                then Reither(false, [t'], false, ref None)
+                else Rpresent(Some t')
+              in (l, f), c
+          | _ -> assert false)
+          fields
+      in
+      let c = collect fields in
+      let row =
+        { row_fields = List.map fst fields; row_more = newvar();
+          row_bound = (); row_closed = posi; row_fixed = None;
+          row_name = if c > Unchanged then None else row.row_name }
+      in
+      (newty (Tvariant row), Changed)
+  | Tobject (t1, _) ->
+      if memq_warn t visited || opened_object t1 then (t, Unchanged) else
+      let level' = pred_enlarge level in
+      let visited =
+        t :: if level' < level then [] else filter_visited visited in
+      let (t1', c) = build_subtype env visited loops posi level' t1 in
+      if c > Unchanged then (newty (Tobject (t1', ref None)), c)
+      else (t, Unchanged)
+  | Tfield(s, _, t1, t2) (* Always present *) ->
+      let (t1', c1) = build_subtype env visited loops posi level t1 in
+      let (t2', c2) = build_subtype env visited loops posi level t2 in
+      let c = max_change c1 c2 in
+      if c > Unchanged then (newty (Tfield(s, Fpresent, t1', t2')), c)
+      else (t, Unchanged)
+  | Tnil ->
+      if posi then
+        let v = newvar () in
+        (v, Changed)
+      else begin
+        warn := true;
+        (t, Unchanged)
+      end
+  | Tsubst _ | Tlink _ ->
+      assert false
+  | Tpoly(t1, tl) ->
+      let (t1', c) = build_subtype env visited loops posi level t1 in
+      if c > Unchanged then (newty (Tpoly(t1', tl)), c)
+      else (t, Unchanged)
+  | Tunivar _ | Tpackage _ ->
+      (t, Unchanged)
+
+let enlarge_type env ty =
+  warn := false;
+  (* [level = 4] allows 2 expansions involving objects/variants *)
+  let (ty', _) = build_subtype env [] [] true 4 ty in
+  (ty', !warn)
+
+(**** Check whether a type is a subtype of another type. ****)
+
+(*
+    During the traversal, a trace of visited types is maintained. It
+    is printed in case of error.
+    Constraints (pairs of types that must be equals) are accumulated
+    rather than being enforced straight. Indeed, the result would
+    otherwise depend on the order in which these constraints are
+    enforced.
+    A function enforcing these constraints is returned. That way, type
+    variables can be bound to their actual values before this function
+    is called (see Typecore).
+    Only well-defined abbreviations are expanded (hence the tests
+    [generic_abbrev ...]).
+*)
+
+let subtypes = TypePairs.create 17
+
+let subtype_error env trace =
+  raise (Subtype (expand_subtype_trace env (List.rev trace), []))
+
+let rec subtype_rec env trace t1 t2 cstrs =
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if t1 == t2 then cstrs else
+
+  begin try
+    TypePairs.find subtypes (t1, t2);
+    cstrs
+  with Not_found ->
+    TypePairs.add subtypes (t1, t2) ();
+    match (t1.desc, t2.desc) with
+      (Tvar _, _) | (_, Tvar _) ->
+        (trace, t1, t2, !univar_pairs)::cstrs
+    | (Tarrow(l1, t1, u1, _), Tarrow(l2, t2, u2, _)) when l1 = l2
+      || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
+        let cstrs = subtype_rec env (Subtype.diff t2 t1::trace) t2 t1 cstrs in
+        subtype_rec env (Subtype.diff u1 u2::trace) u1 u2 cstrs
+    | (Ttuple tl1, Ttuple tl2) ->
+        subtype_list env trace tl1 tl2 cstrs
+    | (Tconstr(p1, [], _), Tconstr(p2, [], _)) when Path.same p1 p2 ->
+        cstrs
+    | (Tconstr(p1, _tl1, _abbrev1), _)
+      when generic_abbrev env p1 && safe_abbrev env t1 ->
+        subtype_rec env trace (expand_abbrev env t1) t2 cstrs
+    | (_, Tconstr(p2, _tl2, _abbrev2))
+      when generic_abbrev env p2 && safe_abbrev env t2 ->
+        subtype_rec env trace t1 (expand_abbrev env t2) cstrs
+    | (Tconstr(p1, tl1, _), Tconstr(p2, tl2, _)) when Path.same p1 p2 ->
+        begin try
+          let decl = Env.find_type p1 env in
+          List.fold_left2
+            (fun cstrs v (t1, t2) ->
+              let (co, cn) = Variance.get_upper v in
+              if co then
+                if cn then
+                  (trace, newty2 t1.level (Ttuple[t1]),
+                   newty2 t2.level (Ttuple[t2]), !univar_pairs) :: cstrs
+                else subtype_rec env (Subtype.diff t1 t2::trace) t1 t2 cstrs
+              else
+                if cn
+                then subtype_rec env (Subtype.diff t2 t1::trace) t2 t1 cstrs
+                else cstrs)
+            cstrs decl.type_variance (List.combine tl1 tl2)
+        with Not_found ->
+          (trace, t1, t2, !univar_pairs)::cstrs
+        end
+    | (Tconstr(p1, _, _), _)
+      when generic_private_abbrev env p1 && safe_abbrev_opt env t1 ->
+        subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs
+(*  | (_, Tconstr(p2, _, _)) when generic_private_abbrev false env p2 ->
+        subtype_rec env trace t1 (expand_abbrev_opt env t2) cstrs *)
+    | (Tobject (f1, _), Tobject (f2, _))
+      when is_Tvar (object_row f1) && is_Tvar (object_row f2) ->
+        (* Same row variable implies same object. *)
+        (trace, t1, t2, !univar_pairs)::cstrs
+    | (Tobject (f1, _), Tobject (f2, _)) ->
+        subtype_fields env trace f1 f2 cstrs
+    | (Tvariant row1, Tvariant row2) ->
+        begin try
+          subtype_row env trace row1 row2 cstrs
+        with Exit ->
+          (trace, t1, t2, !univar_pairs)::cstrs
+        end
+    | (Tpoly (u1, []), Tpoly (u2, [])) ->
+        subtype_rec env trace u1 u2 cstrs
+    | (Tpoly (u1, tl1), Tpoly (u2, [])) ->
+        let _, u1' = instance_poly false tl1 u1 in
+        subtype_rec env trace u1' u2 cstrs
+    | (Tpoly (u1, tl1), Tpoly (u2,tl2)) ->
+        begin try
+          enter_poly env univar_pairs u1 tl1 u2 tl2
+            (fun t1 t2 -> subtype_rec env trace t1 t2 cstrs)
+        with Escape _ ->
+          (trace, t1, t2, !univar_pairs)::cstrs
+        end
+    | (Tpackage (p1, fl1), Tpackage (p2, fl2)) ->
+        begin try
+          let ntl1 = complete_type_list env fl2 t1.level (Mty_ident p1) fl1
+          and ntl2 = complete_type_list env fl1 t2.level (Mty_ident p2) fl2
+              ~allow_absent:true in
+          let cstrs' =
+            List.map
+              (fun (n2,t2) -> (trace, List.assoc n2 ntl1, t2, !univar_pairs))
+              ntl2
+          in
+          if eq_package_path env p1 p2 then cstrs' @ cstrs
+          else begin
+            (* need to check module subtyping *)
+            let snap = Btype.snapshot () in
+            match List.iter (fun (_, t1, t2, _) -> unify env t1 t2) cstrs' with
+            | () when !package_subtype env p1 fl1 p2 fl2 ->
+              Btype.backtrack snap; cstrs' @ cstrs
+            | () | exception Unify _ ->
+              Btype.backtrack snap; raise Not_found
+          end
+        with Not_found ->
+          (trace, t1, t2, !univar_pairs)::cstrs
+        end
+    | (_, _) ->
+        (trace, t1, t2, !univar_pairs)::cstrs
+  end
+
+and subtype_list env trace tl1 tl2 cstrs =
+  if List.length tl1 <> List.length tl2 then
+    subtype_error env trace;
+  List.fold_left2
+    (fun cstrs t1 t2 -> subtype_rec env (Subtype.diff t1 t2::trace) t1 t2 cstrs)
+    cstrs tl1 tl2
+
+and subtype_fields env trace ty1 ty2 cstrs =
+  (* Assume that either rest1 or rest2 is not Tvar *)
+  let (fields1, rest1) = flatten_fields ty1 in
+  let (fields2, rest2) = flatten_fields ty2 in
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  let cstrs =
+    if rest2.desc = Tnil then cstrs else
+    if miss1 = [] then
+      subtype_rec env (Subtype.diff rest1 rest2::trace) rest1 rest2 cstrs
+    else
+      (trace, build_fields (repr ty1).level miss1 rest1, rest2,
+       !univar_pairs) :: cstrs
+  in
+  let cstrs =
+    if miss2 = [] then cstrs else
+    (trace, rest1, build_fields (repr ty2).level miss2 (newvar ()),
+     !univar_pairs) :: cstrs
+  in
+  List.fold_left
+    (fun cstrs (_, _k1, t1, _k2, t2) ->
+      (* These fields are always present *)
+      subtype_rec env (Subtype.diff t1 t2::trace) t1 t2 cstrs)
+    cstrs pairs
+
+and subtype_row env trace row1 row2 cstrs =
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let r1, r2, pairs =
+    merge_row_fields row1.row_fields row2.row_fields in
+  let r1 = if row2.row_closed then filter_row_fields false r1 else r1 in
+  let r2 = if row1.row_closed then filter_row_fields false r2 else r2 in
+  let more1 = repr row1.row_more
+  and more2 = repr row2.row_more in
+  match more1.desc, more2.desc with
+    Tconstr(p1,_,_), Tconstr(p2,_,_) when Path.same p1 p2 ->
+      subtype_rec env (Subtype.diff more1 more2::trace) more1 more2 cstrs
+  | (Tvar _|Tconstr _|Tnil), (Tvar _|Tconstr _|Tnil)
+    when row1.row_closed && r1 = [] ->
+      List.fold_left
+        (fun cstrs (_,f1,f2) ->
+          match row_field_repr f1, row_field_repr f2 with
+            (Rpresent None|Reither(true,_,_,_)), Rpresent None ->
+              cstrs
+          | Rpresent(Some t1), Rpresent(Some t2) ->
+              subtype_rec env (Subtype.diff t1 t2::trace) t1 t2 cstrs
+          | Reither(false, t1::_, _, _), Rpresent(Some t2) ->
+              subtype_rec env (Subtype.diff t1 t2::trace) t1 t2 cstrs
+          | Rabsent, _ -> cstrs
+          | _ -> raise Exit)
+        cstrs pairs
+  | Tunivar _, Tunivar _
+    when row1.row_closed = row2.row_closed && r1 = [] && r2 = [] ->
+      let cstrs =
+        subtype_rec env (Subtype.diff more1 more2::trace) more1 more2 cstrs in
+      List.fold_left
+        (fun cstrs (_,f1,f2) ->
+          match row_field_repr f1, row_field_repr f2 with
+            Rpresent None, Rpresent None
+          | Reither(true,[],_,_), Reither(true,[],_,_)
+          | Rabsent, Rabsent ->
+              cstrs
+          | Rpresent(Some t1), Rpresent(Some t2)
+          | Reither(false,[t1],_,_), Reither(false,[t2],_,_) ->
+              subtype_rec env (Subtype.diff t1 t2::trace) t1 t2 cstrs
+          | _ -> raise Exit)
+        cstrs pairs
+  | _ ->
+      raise Exit
+
+let subtype env ty1 ty2 =
+  TypePairs.clear subtypes;
+  univar_pairs := [];
+  (* Build constraint set. *)
+  let cstrs = subtype_rec env [Subtype.diff ty1 ty2] ty1 ty2 [] in
+  TypePairs.clear subtypes;
+  (* Enforce constraints. *)
+  function () ->
+    List.iter
+      (function (trace0, t1, t2, pairs) ->
+         try unify_pairs (ref env) t1 t2 pairs with Unify trace ->
+           raise (Subtype (expand_subtype_trace env (List.rev trace0),
+                           List.tl trace)))
+      (List.rev cstrs)
+
+                              (*******************)
+                              (*  Miscellaneous  *)
+                              (*******************)
+
+(* Utility for printing. The resulting type is not used in computation. *)
+let rec unalias_object ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tfield (s, k, t1, t2) ->
+      newty2 ty.level (Tfield (s, k, t1, unalias_object t2))
+  | Tvar _ | Tnil ->
+      newty2 ty.level ty.desc
+  | Tunivar _ ->
+      ty
+  | Tconstr _ ->
+      newvar2 ty.level
+  | _ ->
+      assert false
+
+let unalias ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tvar _ | Tunivar _ ->
+      ty
+  | Tvariant row ->
+      let row = row_repr row in
+      let more = row.row_more in
+      newty2 ty.level
+        (Tvariant {row with row_more = newty2 more.level more.desc})
+  | Tobject (ty, nm) ->
+      newty2 ty.level (Tobject (unalias_object ty, nm))
+  | _ ->
+      newty2 ty.level ty.desc
+
+(* Return the arity (as for curried functions) of the given type. *)
+let rec arity ty =
+  match (repr ty).desc with
+    Tarrow(_, _t1, t2, _) -> 1 + arity t2
+  | _ -> 0
+
+(* Check for non-generalizable type variables *)
+exception Non_closed0
+let visited = ref TypeSet.empty
+
+let rec closed_schema_rec env ty =
+  let ty = repr ty in
+  if TypeSet.mem ty !visited then () else begin
+    visited := TypeSet.add ty !visited;
+    match ty.desc with
+      Tvar _ when ty.level <> generic_level ->
+        raise Non_closed0
+    | Tconstr _ ->
+        let old = !visited in
+        begin try iter_type_expr (closed_schema_rec env) ty
+        with Non_closed0 -> try
+          visited := old;
+          closed_schema_rec env (try_expand_head try_expand_safe env ty)
+        with Cannot_expand ->
+          raise Non_closed0
+        end
+    | Tfield(_, kind, t1, t2) ->
+        if field_kind_repr kind = Fpresent then
+          closed_schema_rec env t1;
+        closed_schema_rec env t2
+    | Tvariant row ->
+        let row = row_repr row in
+        iter_row (closed_schema_rec env) row;
+        if not (static_row row) then closed_schema_rec env row.row_more
+    | _ ->
+        iter_type_expr (closed_schema_rec env) ty
+  end
+
+(* Return whether all variables of type [ty] are generic. *)
+let closed_schema env ty =
+  visited := TypeSet.empty;
+  try
+    closed_schema_rec env ty;
+    visited := TypeSet.empty;
+    true
+  with Non_closed0 ->
+    visited := TypeSet.empty;
+    false
+
+(* Normalize a type before printing, saving... *)
+(* Cannot use mark_type because deep_occur uses it too *)
+let rec normalize_type_rec visited ty =
+  let ty = repr ty in
+  if not (TypeSet.mem ty !visited) then begin
+    visited := TypeSet.add ty !visited;
+    let tm = row_of_type ty in
+    begin if not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm then
+      match tm.desc with (* PR#7348 *)
+        Tconstr (Path.Pdot(m,i), tl, _abbrev) ->
+          let i' = String.sub i 0 (String.length i - 4) in
+          set_type_desc ty (Tconstr(Path.Pdot(m,i'), tl, ref Mnil))
+      | _ -> assert false
+    else match ty.desc with
+    | Tvariant row ->
+      let row = row_repr row in
+      let fields = List.map
+          (fun (l,f0) ->
+            let f = row_field_repr f0 in l,
+            match f with Reither(b, ty::(_::_ as tyl), m, e) ->
+              let tyl' =
+                List.fold_left
+                  (fun tyl ty ->
+                    if List.exists
+                          (fun ty' ->
+                             match equal Env.empty false [ty] [ty'] with
+                             | () -> true
+                             | exception Equality _ -> false)
+                          tyl
+                     then tyl else ty::tyl)
+                  [ty] tyl
+              in
+              if f != f0 || List.length tyl' < List.length tyl then
+                Reither(b, List.rev tyl', m, e)
+              else f
+            | _ -> f)
+          row.row_fields in
+      let fields =
+        List.sort (fun (p,_) (q,_) -> compare p q)
+          (List.filter (fun (_,fi) -> fi <> Rabsent) fields) in
+      set_type_desc ty (Tvariant {row with row_fields = fields})
+    | Tobject (fi, nm) ->
+        begin match !nm with
+        | None -> ()
+        | Some (n, v :: l) ->
+            if deep_occur ty (newgenty (Ttuple l)) then
+              (* The abbreviation may be hiding something, so remove it *)
+              set_name nm None
+            else let v' = repr v in
+            begin match v'.desc with
+            | Tvar _ | Tunivar _ ->
+                if v' != v then set_name nm (Some (n, v' :: l))
+            | Tnil ->
+                set_type_desc ty (Tconstr (n, l, ref Mnil))
+            | _ -> set_name nm None
+            end
+        | _ ->
+            fatal_error "Ctype.normalize_type_rec"
+        end;
+        let fi = repr fi in
+        if fi.level < lowest_level then () else
+        let fields, row = flatten_fields fi in
+        let fi' = build_fields fi.level fields row in
+        set_type_desc fi fi'.desc
+    | _ -> ()
+    end;
+    iter_type_expr (normalize_type_rec visited) ty
+  end
+
+let normalize_type ty =
+  normalize_type_rec (ref TypeSet.empty) ty
+
+
+                              (*************************)
+                              (*  Remove dependencies  *)
+                              (*************************)
+
+
+(*
+   Variables are left unchanged. Other type nodes are duplicated, with
+   levels set to generic level.
+   We cannot use Tsubst here, because unification may be called by
+   expand_abbrev.
+*)
+
+let nondep_hash     = TypeHash.create 47
+let nondep_variants = TypeHash.create 17
+let clear_hash ()   =
+  TypeHash.clear nondep_hash; TypeHash.clear nondep_variants
+
+let rec nondep_type_rec ?(expand_private=false) env ids ty =
+  let try_expand env t =
+    if expand_private then try_expand_safe_opt env t
+    else try_expand_safe env t
+  in
+  match ty.desc with
+    Tvar _ | Tunivar _ -> ty
+  | Tlink ty -> nondep_type_rec env ids ty
+  | _ -> try TypeHash.find nondep_hash ty
+  with Not_found ->
+    let ty' = newgenvar () in        (* Stub *)
+    TypeHash.add nondep_hash ty ty';
+    set_type_desc ty'
+      begin match ty.desc with
+      | Tconstr(p, tl, _abbrev) ->
+          begin try
+            (* First, try keeping the same type constructor p *)
+            match Path.find_free_opt ids p with
+            | Some id ->
+               raise (Nondep_cannot_erase id)
+            | None ->
+               Tconstr(p, List.map (nondep_type_rec env ids) tl, ref Mnil)
+          with (Nondep_cannot_erase _) as exn ->
+            (* If that doesn't work, try expanding abbrevs *)
+            try Tlink (nondep_type_rec ~expand_private env ids
+                       (try_expand env (newty2 ty.level ty.desc)))
+              (*
+                 The [Tlink] is important. The expanded type may be a
+                 variable, or may not be completely copied yet
+                 (recursive type), so one cannot just take its
+                 description.
+               *)
+            with Cannot_expand -> raise exn
+          end
+      | Tpackage(p, fl) when Path.exists_free ids p ->
+          let p' = normalize_package_path env p in
+          begin match Path.find_free_opt ids p' with
+          | Some id -> raise (Nondep_cannot_erase id)
+          | None ->
+            let nondep_field_rec (n, ty) = (n, nondep_type_rec env ids ty) in
+            Tpackage (p', List.map nondep_field_rec fl)
+          end
+      | Tobject (t1, name) ->
+          Tobject (nondep_type_rec env ids t1,
+                 ref (match !name with
+                        None -> None
+                      | Some (p, tl) ->
+                          if Path.exists_free ids p then None
+                          else Some (p, List.map (nondep_type_rec env ids) tl)))
+      | Tvariant row ->
+          let row = row_repr row in
+          let more = repr row.row_more in
+          (* We must keep sharing according to the row variable *)
+          begin try
+            let ty2 = TypeHash.find nondep_variants more in
+            (* This variant type has been already copied *)
+            TypeHash.add nondep_hash ty ty2;
+            Tlink ty2
+          with Not_found ->
+            (* Register new type first for recursion *)
+            TypeHash.add nondep_variants more ty';
+            let static = static_row row in
+            let more' =
+              if static then newgenty Tnil else nondep_type_rec env ids more
+            in
+            (* Return a new copy *)
+            let row =
+              copy_row (nondep_type_rec env ids) true row true more' in
+            match row.row_name with
+              Some (p, _tl) when Path.exists_free ids p ->
+                Tvariant {row with row_name = None}
+            | _ -> Tvariant row
+          end
+      | _ -> copy_type_desc (nondep_type_rec env ids) ty.desc
+      end;
+    ty'
+
+let nondep_type env id ty =
+  try
+    let ty' = nondep_type_rec env id ty in
+    clear_hash ();
+    ty'
+  with Nondep_cannot_erase _ as exn ->
+    clear_hash ();
+    raise exn
+
+let () = nondep_type' := nondep_type
+
+(* Preserve sharing inside type declarations. *)
+let nondep_type_decl env mid is_covariant decl =
+  try
+    let params = List.map (nondep_type_rec env mid) decl.type_params in
+    let tk =
+      try map_kind (nondep_type_rec env mid) decl.type_kind
+      with Nondep_cannot_erase _ when is_covariant -> Type_abstract
+    and tm, priv =
+      match decl.type_manifest with
+      | None -> None, decl.type_private
+      | Some ty ->
+          try Some (nondep_type_rec env mid ty), decl.type_private
+          with Nondep_cannot_erase _ when is_covariant ->
+            clear_hash ();
+            try Some (nondep_type_rec ~expand_private:true env mid ty),
+                Private
+            with Nondep_cannot_erase _ ->
+              None, decl.type_private
+    in
+    clear_hash ();
+    let priv =
+      match tm with
+      | Some ty when Btype.has_constr_row ty -> Private
+      | _ -> priv
+    in
+    { type_params = params;
+      type_arity = decl.type_arity;
+      type_kind = tk;
+      type_manifest = tm;
+      type_private = priv;
+      type_variance = decl.type_variance;
+      type_separability = decl.type_separability;
+      type_is_newtype = false;
+      type_expansion_scope = Btype.lowest_level;
+      type_loc = decl.type_loc;
+      type_attributes = decl.type_attributes;
+      type_immediate = decl.type_immediate;
+      type_unboxed_default = decl.type_unboxed_default;
+      type_uid = decl.type_uid;
+    }
+  with Nondep_cannot_erase _ as exn ->
+    clear_hash ();
+    raise exn
+
+(* Preserve sharing inside extension constructors. *)
+let nondep_extension_constructor env ids ext =
+  try
+    let type_path, type_params =
+      match Path.find_free_opt ids ext.ext_type_path with
+      | Some id ->
+        begin
+          let ty =
+            newgenty (Tconstr(ext.ext_type_path, ext.ext_type_params, ref Mnil))
+          in
+          let ty' = nondep_type_rec env ids ty in
+            match (repr ty').desc with
+                Tconstr(p, tl, _) -> p, tl
+              | _ -> raise (Nondep_cannot_erase id)
+        end
+      | None ->
+        let type_params =
+          List.map (nondep_type_rec env ids) ext.ext_type_params
+        in
+          ext.ext_type_path, type_params
+    in
+    let args = map_type_expr_cstr_args (nondep_type_rec env ids) ext.ext_args in
+    let ret_type = Option.map (nondep_type_rec env ids) ext.ext_ret_type in
+      clear_hash ();
+      { ext_type_path = type_path;
+        ext_type_params = type_params;
+        ext_args = args;
+        ext_ret_type = ret_type;
+        ext_private = ext.ext_private;
+        ext_attributes = ext.ext_attributes;
+        ext_loc = ext.ext_loc;
+        ext_uid = ext.ext_uid;
+      }
+  with Nondep_cannot_erase _ as exn ->
+    clear_hash ();
+    raise exn
+
+
+(* Preserve sharing inside class types. *)
+let nondep_class_signature env id sign =
+  { csig_self = nondep_type_rec env id sign.csig_self;
+    csig_vars =
+      Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t))
+        sign.csig_vars;
+    csig_concr = sign.csig_concr;
+    csig_inher =
+      List.map (fun (p,tl) -> (p, List.map (nondep_type_rec env id) tl))
+        sign.csig_inher }
+
+let rec nondep_class_type env ids =
+  function
+    Cty_constr (p, _, cty) when Path.exists_free ids p ->
+      nondep_class_type env ids cty
+  | Cty_constr (p, tyl, cty) ->
+      Cty_constr (p, List.map (nondep_type_rec env ids) tyl,
+                   nondep_class_type env ids cty)
+  | Cty_signature sign ->
+      Cty_signature (nondep_class_signature env ids sign)
+  | Cty_arrow (l, ty, cty) ->
+      Cty_arrow (l, nondep_type_rec env ids ty, nondep_class_type env ids cty)
+
+let nondep_class_declaration env ids decl =
+  assert (not (Path.exists_free ids decl.cty_path));
+  let decl =
+    { cty_params = List.map (nondep_type_rec env ids) decl.cty_params;
+      cty_variance = decl.cty_variance;
+      cty_type = nondep_class_type env ids decl.cty_type;
+      cty_path = decl.cty_path;
+      cty_new =
+        begin match decl.cty_new with
+          None    -> None
+        | Some ty -> Some (nondep_type_rec env ids ty)
+        end;
+      cty_loc = decl.cty_loc;
+      cty_attributes = decl.cty_attributes;
+      cty_uid = decl.cty_uid;
+    }
+  in
+  clear_hash ();
+  decl
+
+let nondep_cltype_declaration env ids decl =
+  assert (not (Path.exists_free ids decl.clty_path));
+  let decl =
+    { clty_params = List.map (nondep_type_rec env ids) decl.clty_params;
+      clty_variance = decl.clty_variance;
+      clty_type = nondep_class_type env ids decl.clty_type;
+      clty_path = decl.clty_path;
+      clty_loc = decl.clty_loc;
+      clty_attributes = decl.clty_attributes;
+      clty_uid = decl.clty_uid;
+    }
+  in
+  clear_hash ();
+  decl
+
+(* collapse conjunctive types in class parameters *)
+let rec collapse_conj env visited ty =
+  let ty = repr ty in
+  if List.memq ty visited then () else
+  let visited = ty :: visited in
+  match ty.desc with
+    Tvariant row ->
+      let row = row_repr row in
+      List.iter
+        (fun (_l,fi) ->
+          match row_field_repr fi with
+            Reither (c, t1::(_::_ as tl), m, e) ->
+              List.iter (unify env t1) tl;
+              set_row_field e (Reither (c, [t1], m, ref None))
+          | _ ->
+              ())
+        row.row_fields;
+      iter_row (collapse_conj env visited) row
+  | _ ->
+      iter_type_expr (collapse_conj env visited) ty
+
+let collapse_conj_params env params =
+  List.iter (collapse_conj env []) params
+
+let same_constr env t1 t2 =
+  let t1 = expand_head env t1 in
+  let t2 = expand_head env t2 in
+  match t1.desc, t2.desc with
+  | Tconstr (p1, _, _), Tconstr (p2, _, _) -> Path.same p1 p2
+  | _ -> false
+
+let () =
+  Env.same_constr := same_constr
+
+let is_immediate = function
+  | Type_immediacy.Unknown -> false
+  | Type_immediacy.Always -> true
+  | Type_immediacy.Always_on_64bits ->
+      (* In bytecode, we don't know at compile time whether we are
+         targeting 32 or 64 bits. *)
+      !Clflags.native_code && Sys.word_size = 64
+
+let immediacy env typ =
+   match (repr typ).desc with
+  | Tconstr(p, _args, _abbrev) ->
+    begin try
+      let type_decl = Env.find_type p env in
+      type_decl.type_immediate
+    with Not_found -> Type_immediacy.Unknown
+    (* This can happen due to e.g. missing -I options,
+       causing some .cmi files to be unavailable.
+       Maybe we should emit a warning. *)
+    end
+  | Tvariant row ->
+      let row = Btype.row_repr row in
+      (* if all labels are devoid of arguments, not a pointer *)
+      if
+        not row.row_closed
+        || List.exists
+          (function
+            | _, (Rpresent (Some _) | Reither (false, _, _, _)) -> true
+            | _ -> false)
+          row.row_fields
+      then
+        Type_immediacy.Unknown
+      else
+        Type_immediacy.Always
+  | _ -> Type_immediacy.Unknown
+
+let maybe_pointer_type env typ = not (is_immediate (immediacy env typ))
diff --git a/upstream/ocaml_413/typing/ctype.mli b/upstream/ocaml_413/typing/ctype.mli
new file mode 100644
index 0000000..7185cdb
--- /dev/null
+++ b/upstream/ocaml_413/typing/ctype.mli
@@ -0,0 +1,354 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Operations on core types *)
+
+open Asttypes
+open Types
+
+module TypePairs : Hashtbl.S with type key = type_expr * type_expr
+
+exception Unify of Errortrace.unification Errortrace.t
+exception Equality of Errortrace.comparison Errortrace.t
+exception Moregen of Errortrace.comparison Errortrace.t
+exception Subtype of Errortrace.Subtype.t * Errortrace.unification Errortrace.t
+exception Escape of Errortrace.desc Errortrace.escape
+
+exception Tags of label * label
+exception Cannot_expand
+exception Cannot_apply
+exception Matches_failure of Env.t * Errortrace.unification Errortrace.t
+  (* Raised from [matches], hence the odd name *)
+exception Incompatible
+  (* Raised from [mcomp] *)
+
+val init_def: int -> unit
+        (* Set the initial variable level *)
+val begin_def: unit -> unit
+        (* Raise the variable level by one at the beginning of a definition. *)
+val end_def: unit -> unit
+        (* Lower the variable level by one at the end of a definition *)
+val begin_class_def: unit -> unit
+val raise_nongen_level: unit -> unit
+val reset_global_level: unit -> unit
+        (* Reset the global level before typing an expression *)
+val increase_global_level: unit -> int
+val restore_global_level: int -> unit
+        (* This pair of functions is only used in Typetexp *)
+type levels =
+    { current_level: int; nongen_level: int; global_level: int;
+      saved_level: (int * int) list; }
+val save_levels: unit -> levels
+val set_levels: levels -> unit
+
+val create_scope : unit -> int
+
+val newty: type_desc -> type_expr
+val newvar: ?name:string -> unit -> type_expr
+val newvar2: ?name:string -> int -> type_expr
+        (* Return a fresh variable *)
+val new_global_var: ?name:string -> unit -> type_expr
+        (* Return a fresh variable, bound at toplevel
+           (as type variables ['a] in type constraints). *)
+val newobj: type_expr -> type_expr
+val newconstr: Path.t -> type_expr list -> type_expr
+val none: type_expr
+        (* A dummy type expression *)
+
+val repr: type_expr -> type_expr
+        (* Return the canonical representative of a type. *)
+
+val object_fields: type_expr -> type_expr
+val flatten_fields:
+        type_expr -> (string * field_kind * type_expr) list * type_expr
+(** Transform a field type into a list of pairs label-type.
+    The fields are sorted.
+
+    Beware of the interaction with GADTs:
+
+    Due to the introduction of object indexes for GADTs, the row variable of
+    an object may now be an expansible type abbreviation.
+    A first consequence is that [flatten_fields] will not completely flatten
+    the object, since the type abbreviation will not be expanded
+    ([flatten_fields] does not receive the current environment).
+    Another consequence is that various functions may be called with the
+    expansion of this type abbreviation, which is a Tfield, e.g. during
+    printing.
+
+    Concrete problems have been fixed, but new bugs may appear in the
+    future. (Test cases were added to typing-gadts/test.ml)
+*)
+
+val associate_fields:
+        (string * field_kind * type_expr) list ->
+        (string * field_kind * type_expr) list ->
+        (string * field_kind * type_expr * field_kind * type_expr) list *
+        (string * field_kind * type_expr) list *
+        (string * field_kind * type_expr) list
+val opened_object: type_expr -> bool
+val close_object: type_expr -> bool
+val row_variable: type_expr -> type_expr
+        (* Return the row variable of an open object type *)
+val set_object_name:
+        Ident.t -> type_expr -> type_expr list -> type_expr -> unit
+val remove_object_name: type_expr -> unit
+val hide_private_methods: type_expr -> unit
+val find_cltype_for_path: Env.t -> Path.t -> type_declaration * type_expr
+
+val sort_row_fields: (label * row_field) list -> (label * row_field) list
+val merge_row_fields:
+        (label * row_field) list -> (label * row_field) list ->
+        (label * row_field) list * (label * row_field) list *
+        (label * row_field * row_field) list
+val filter_row_fields:
+        bool -> (label * row_field) list -> (label * row_field) list
+
+val generalize: type_expr -> unit
+        (* Generalize in-place the given type *)
+val lower_contravariant: Env.t -> type_expr -> unit
+        (* Lower level of type variables inside contravariant branches;
+           to be used before generalize for expansive expressions *)
+val generalize_structure: type_expr -> unit
+        (* Generalize the structure of a type, lowering variables
+           to !current_level *)
+val generalize_spine: type_expr -> unit
+        (* Special function to generalize a method during inference *)
+val correct_levels: type_expr -> type_expr
+        (* Returns a copy with decreasing levels *)
+val limited_generalize: type_expr -> type_expr -> unit
+        (* Only generalize some part of the type
+           Make the remaining of the type non-generalizable *)
+
+val fully_generic: type_expr -> bool
+
+val check_scope_escape : Env.t -> int -> type_expr -> unit
+        (* [check_scope_escape env lvl ty] ensures that [ty] could be raised
+           to the level [lvl] without any scope escape.
+           Raises [Escape] otherwise *)
+
+val instance: ?partial:bool -> type_expr -> type_expr
+        (* Take an instance of a type scheme *)
+        (* partial=None  -> normal
+           partial=false -> newvar() for non generic subterms
+           partial=true  -> newty2 ty.level Tvar for non generic subterms *)
+val generic_instance: type_expr -> type_expr
+        (* Same as instance, but new nodes at generic_level *)
+val instance_list: type_expr list -> type_expr list
+        (* Take an instance of a list of type schemes *)
+val new_local_type:
+        ?loc:Location.t ->
+        ?manifest_and_scope:(type_expr * int) -> unit -> type_declaration
+val existential_name: constructor_description -> type_expr -> string
+val instance_constructor:
+        ?in_pattern:Env.t ref * int ->
+        constructor_description -> type_expr list * type_expr * type_expr list
+        (* Same, for a constructor. Also returns existentials. *)
+val instance_parameterized_type:
+        ?keep_names:bool ->
+        type_expr list -> type_expr -> type_expr list * type_expr
+val instance_parameterized_type_2:
+        type_expr list -> type_expr list -> type_expr ->
+        type_expr list * type_expr list * type_expr
+val instance_declaration: type_declaration -> type_declaration
+val generic_instance_declaration: type_declaration -> type_declaration
+        (* Same as instance_declaration, but new nodes at generic_level *)
+val instance_class:
+        type_expr list -> class_type -> type_expr list * class_type
+val instance_poly:
+        ?keep_names:bool ->
+        bool -> type_expr list -> type_expr -> type_expr list * type_expr
+        (* Take an instance of a type scheme containing free univars *)
+val polyfy: Env.t -> type_expr -> type_expr list -> type_expr * bool
+val instance_label:
+        bool -> label_description -> type_expr list * type_expr * type_expr
+        (* Same, for a label *)
+val apply:
+        Env.t -> type_expr list -> type_expr -> type_expr list -> type_expr
+        (* [apply [p1...pN] t [a1...aN]] match the arguments [ai] to
+        the parameters [pi] and returns the corresponding instance of
+        [t]. Exception [Cannot_apply] is raised in case of failure. *)
+
+val try_expand_once_opt: Env.t -> type_expr -> type_expr
+val try_expand_safe_opt: Env.t -> type_expr -> type_expr
+
+val expand_head_once: Env.t -> type_expr -> type_expr
+val expand_head: Env.t -> type_expr -> type_expr
+val expand_head_opt: Env.t -> type_expr -> type_expr
+(** The compiler's own version of [expand_head] necessary for type-based
+    optimisations. *)
+
+val full_expand: may_forget_scope:bool -> Env.t -> type_expr -> type_expr
+val extract_concrete_typedecl:
+        Env.t -> type_expr -> Path.t * Path.t * type_declaration
+        (* Return the original path of the types, and the first concrete
+           type declaration found expanding it.
+           Raise [Not_found] if none appears or not a type constructor. *)
+
+val unify: Env.t -> type_expr -> type_expr -> unit
+        (* Unify the two types given. Raise [Unify] if not possible. *)
+val unify_gadt:
+        equations_level:int -> allow_recursive:bool ->
+        Env.t ref -> type_expr -> type_expr -> unit TypePairs.t
+        (* Unify the two types given and update the environment with the
+           local constraints. Raise [Unify] if not possible.
+           Returns the pairs of types that have been equated.  *)
+val unify_var: Env.t -> type_expr -> type_expr -> unit
+        (* Same as [unify], but allow free univars when first type
+           is a variable. *)
+val filter_arrow: Env.t -> type_expr -> arg_label -> type_expr * type_expr
+        (* A special case of unification (with l:'a -> 'b). *)
+val filter_method: Env.t -> string -> private_flag -> type_expr -> type_expr
+        (* A special case of unification (with {m : 'a; 'b}). *)
+val check_filter_method: Env.t -> string -> private_flag -> type_expr -> unit
+        (* A special case of unification (with {m : 'a; 'b}), returning unit. *)
+val occur_in: Env.t -> type_expr -> type_expr -> bool
+val deep_occur: type_expr -> type_expr -> bool
+val filter_self_method:
+        Env.t -> string -> private_flag -> (Ident.t * type_expr) Meths.t ref ->
+        type_expr -> Ident.t * type_expr
+val moregeneral: Env.t -> bool -> type_expr -> type_expr -> unit
+        (* Check if the first type scheme is more general than the second. *)
+val is_moregeneral: Env.t -> bool -> type_expr -> type_expr -> bool
+val rigidify: type_expr -> type_expr list
+        (* "Rigidify" a type and return its type variable *)
+val all_distinct_vars: Env.t -> type_expr list -> bool
+        (* Check those types are all distinct type variables *)
+val matches: Env.t -> type_expr -> type_expr -> unit
+        (* Same as [moregeneral false], implemented using the two above
+           functions and backtracking. Ignore levels *)
+val does_match: Env.t -> type_expr -> type_expr -> bool
+        (* Same as [matches], but returns a [bool] *)
+
+val reify_univars : Env.t -> Types.type_expr -> Types.type_expr
+        (* Replaces all the variables of a type by a univar. *)
+
+type class_match_failure_trace_type =
+  | CM_Equality
+  | CM_Moregen
+
+type class_match_failure =
+    CM_Virtual_class
+  | CM_Parameter_arity_mismatch of int * int
+  | CM_Type_parameter_mismatch of Env.t * Errortrace.comparison Errortrace.t
+  | CM_Class_type_mismatch of Env.t * class_type * class_type
+  | CM_Parameter_mismatch of Env.t * Errortrace.comparison Errortrace.t
+  | CM_Val_type_mismatch of
+      class_match_failure_trace_type *
+      string * Env.t * Errortrace.comparison Errortrace.t
+  | CM_Meth_type_mismatch of
+      class_match_failure_trace_type *
+      string * Env.t * Errortrace.comparison Errortrace.t
+  | CM_Non_mutable_value of string
+  | CM_Non_concrete_value of string
+  | CM_Missing_value of string
+  | CM_Missing_method of string
+  | CM_Hide_public of string
+  | CM_Hide_virtual of string * string
+  | CM_Public_method of string
+  | CM_Private_method of string
+  | CM_Virtual_method of string
+val match_class_types:
+    ?trace:bool -> Env.t -> class_type -> class_type -> class_match_failure list
+        (* Check if the first class type is more general than the second. *)
+val equal: Env.t -> bool -> type_expr list -> type_expr list -> unit
+        (* [equal env [x1...xn] tau [y1...yn] sigma]
+           checks whether the parameterized types
+           [/\x1.../\xn.tau] and [/\y1.../\yn.sigma] are equivalent. *)
+val is_equal : Env.t -> bool -> type_expr list -> type_expr list -> bool
+val equal_private :
+        Env.t -> type_expr list -> type_expr ->
+        type_expr list -> type_expr -> unit
+(* [equal_private env t1 params1 t2 params2] checks that [t1::params1]
+   equals [t2::params2] but it is allowed to expand [t1] if it is a
+   private abbreviations. *)
+
+val match_class_declarations:
+        Env.t -> type_expr list -> class_type -> type_expr list ->
+        class_type -> class_match_failure list
+        (* Check if the first class type is more general than the second. *)
+
+val enlarge_type: Env.t -> type_expr -> type_expr * bool
+        (* Make a type larger, flag is true if some pruning had to be done *)
+val subtype: Env.t -> type_expr -> type_expr -> unit -> unit
+        (* [subtype env t1 t2] checks that [t1] is a subtype of [t2].
+           It accumulates the constraints the type variables must
+           enforce and returns a function that enforces this
+           constraints. *)
+
+exception Nondep_cannot_erase of Ident.t
+
+val nondep_type: Env.t -> Ident.t list -> type_expr -> type_expr
+        (* Return a type equivalent to the given type but without
+           references to any of the given identifiers.
+           Raise [Nondep_cannot_erase id] if no such type exists because [id],
+           in particular, could not be erased. *)
+val nondep_type_decl:
+        Env.t -> Ident.t list -> bool -> type_declaration -> type_declaration
+        (* Same for type declarations. *)
+val nondep_extension_constructor:
+        Env.t -> Ident.t list -> extension_constructor ->
+        extension_constructor
+          (* Same for extension constructor *)
+val nondep_class_declaration:
+        Env.t -> Ident.t list -> class_declaration -> class_declaration
+        (* Same for class declarations. *)
+val nondep_cltype_declaration:
+  Env.t -> Ident.t list -> class_type_declaration -> class_type_declaration
+        (* Same for class type declarations. *)
+(*val correct_abbrev: Env.t -> Path.t -> type_expr list -> type_expr -> unit*)
+val is_contractive: Env.t -> Path.t -> bool
+val normalize_type: type_expr -> unit
+
+val closed_schema: Env.t -> type_expr -> bool
+        (* Check whether the given type scheme contains no non-generic
+           type variables *)
+
+val free_variables: ?env:Env.t -> type_expr -> type_expr list
+        (* If env present, then check for incomplete definitions too *)
+val closed_type_decl: type_declaration -> type_expr option
+val closed_extension_constructor: extension_constructor -> type_expr option
+type closed_class_failure =
+    CC_Method of type_expr * bool * string * type_expr
+  | CC_Value of type_expr * bool * string * type_expr
+val closed_class:
+        type_expr list -> class_signature -> closed_class_failure option
+        (* Check whether all type variables are bound *)
+
+val unalias: type_expr -> type_expr
+val signature_of_class_type: class_type -> class_signature
+val self_type: class_type -> type_expr
+val class_type_arity: class_type -> int
+val arity: type_expr -> int
+        (* Return the arity (as for curried functions) of the given type. *)
+
+val collapse_conj_params: Env.t -> type_expr list -> unit
+        (* Collapse conjunctive types in class parameters *)
+
+val get_current_level: unit -> int
+val wrap_trace_gadt_instances: Env.t -> ('a -> 'b) -> 'a -> 'b
+val reset_reified_var_counter: unit -> unit
+
+val immediacy : Env.t -> type_expr -> Type_immediacy.t
+
+val maybe_pointer_type : Env.t -> type_expr -> bool
+       (* True if type is possibly pointer, false if definitely not a pointer *)
+
+(* Stubs *)
+val package_subtype :
+    (Env.t -> Path.t -> (Longident.t * type_expr) list ->
+      Path.t -> (Longident.t * type_expr) list -> bool) ref
+
+(* Raises [Incompatible] *)
+val mcomp : Env.t -> type_expr -> type_expr -> unit
diff --git a/upstream/ocaml_413/typing/datarepr.ml b/upstream/ocaml_413/typing/datarepr.ml
new file mode 100644
index 0000000..8ec47a9
--- /dev/null
+++ b/upstream/ocaml_413/typing/datarepr.ml
@@ -0,0 +1,242 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Compute constructor and label descriptions from type declarations,
+   determining their representation. *)
+
+open Asttypes
+open Types
+open Btype
+
+(* Simplified version of Ctype.free_vars *)
+let free_vars ?(param=false) ty =
+  let ret = ref TypeSet.empty in
+  let rec loop ty =
+    let ty = repr ty in
+    if try_mark_node ty then
+      match ty.desc with
+      | Tvar _ ->
+          ret := TypeSet.add ty !ret
+      | Tvariant row ->
+          let row = row_repr row in
+          iter_row loop row;
+          if not (static_row row) then begin
+            match row.row_more.desc with
+            | Tvar _ when param -> ret := TypeSet.add ty !ret
+            | _ -> loop row.row_more
+          end
+      (* XXX: What about Tobject ? *)
+      | _ ->
+          iter_type_expr loop ty
+  in
+  loop ty;
+  unmark_type ty;
+  !ret
+
+let newgenconstr path tyl = newgenty (Tconstr (path, tyl, ref Mnil))
+
+let constructor_existentials cd_args cd_res =
+  let tyl =
+    match cd_args with
+    | Cstr_tuple l -> l
+    | Cstr_record l -> List.map (fun l -> l.ld_type) l
+  in
+  let existentials =
+    match cd_res with
+    | None -> []
+    | Some type_ret ->
+        let arg_vars_set = free_vars (newgenty (Ttuple tyl)) in
+        let res_vars = free_vars type_ret in
+        TypeSet.elements (TypeSet.diff arg_vars_set res_vars)
+  in
+  (tyl, existentials)
+
+let constructor_args ~current_unit priv cd_args cd_res path rep =
+  let tyl, existentials = constructor_existentials cd_args cd_res in
+  match cd_args with
+  | Cstr_tuple l -> existentials, l, None
+  | Cstr_record lbls ->
+      let arg_vars_set = free_vars ~param:true (newgenty (Ttuple tyl)) in
+      let type_params = TypeSet.elements arg_vars_set in
+      let arity = List.length type_params in
+      let tdecl =
+        {
+          type_params;
+          type_arity = arity;
+          type_kind = Type_record (lbls, rep);
+          type_private = priv;
+          type_manifest = None;
+          type_variance = Variance.unknown_signature ~injective:true ~arity;
+          type_separability = Types.Separability.default_signature ~arity;
+          type_is_newtype = false;
+          type_expansion_scope = Btype.lowest_level;
+          type_loc = Location.none;
+          type_attributes = [];
+          type_immediate = Unknown;
+          type_unboxed_default = false;
+          type_uid = Uid.mk ~current_unit;
+        }
+      in
+      existentials,
+      [ newgenconstr path type_params ],
+      Some tdecl
+
+let constructor_descrs ~current_unit ty_path decl cstrs rep =
+  let ty_res = newgenconstr ty_path decl.type_params in
+  let num_consts = ref 0 and num_nonconsts = ref 0  and num_normal = ref 0 in
+  List.iter
+    (fun {cd_args; cd_res; _} ->
+      if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts;
+      if cd_res = None then incr num_normal)
+    cstrs;
+  let rec describe_constructors idx_const idx_nonconst = function
+      [] -> []
+    | {cd_id; cd_args; cd_res; cd_loc; cd_attributes; cd_uid} :: rem ->
+        let ty_res =
+          match cd_res with
+          | Some ty_res' -> ty_res'
+          | None -> ty_res
+        in
+        let (tag, descr_rem) =
+          match cd_args, rep with
+          | _, Variant_unboxed ->
+            assert (rem = []);
+            (Cstr_unboxed, [])
+          | Cstr_tuple [], Variant_regular ->
+             (Cstr_constant idx_const,
+              describe_constructors (idx_const+1) idx_nonconst rem)
+          | _, Variant_regular  ->
+             (Cstr_block idx_nonconst,
+              describe_constructors idx_const (idx_nonconst+1) rem) in
+        let cstr_name = Ident.name cd_id in
+        let existentials, cstr_args, cstr_inlined =
+          let representation =
+            match rep with
+            | Variant_unboxed -> Record_unboxed true
+            | Variant_regular -> Record_inlined idx_nonconst
+          in
+          constructor_args ~current_unit decl.type_private cd_args cd_res
+            (Path.Pdot (ty_path, cstr_name)) representation
+        in
+        let cstr =
+          { cstr_name;
+            cstr_res = ty_res;
+            cstr_existentials = existentials;
+            cstr_args;
+            cstr_arity = List.length cstr_args;
+            cstr_tag = tag;
+            cstr_consts = !num_consts;
+            cstr_nonconsts = !num_nonconsts;
+            cstr_normal = !num_normal;
+            cstr_private = decl.type_private;
+            cstr_generalized = cd_res <> None;
+            cstr_loc = cd_loc;
+            cstr_attributes = cd_attributes;
+            cstr_inlined;
+            cstr_uid = cd_uid;
+          } in
+        (cd_id, cstr) :: descr_rem in
+  describe_constructors 0 0 cstrs
+
+let extension_descr ~current_unit path_ext ext =
+  let ty_res =
+    match ext.ext_ret_type with
+        Some type_ret -> type_ret
+      | None -> newgenconstr ext.ext_type_path ext.ext_type_params
+  in
+  let existentials, cstr_args, cstr_inlined =
+    constructor_args ~current_unit ext.ext_private ext.ext_args ext.ext_ret_type
+      path_ext (Record_extension path_ext)
+  in
+    { cstr_name = Path.last path_ext;
+      cstr_res = ty_res;
+      cstr_existentials = existentials;
+      cstr_args;
+      cstr_arity = List.length cstr_args;
+      cstr_tag = Cstr_extension(path_ext, cstr_args = []);
+      cstr_consts = -1;
+      cstr_nonconsts = -1;
+      cstr_private = ext.ext_private;
+      cstr_normal = -1;
+      cstr_generalized = ext.ext_ret_type <> None;
+      cstr_loc = ext.ext_loc;
+      cstr_attributes = ext.ext_attributes;
+      cstr_inlined;
+      cstr_uid = ext.ext_uid;
+    }
+
+let none = Private_type_expr.create (Ttuple [])
+    ~level:(-1) ~scope:Btype.generic_level ~id:(-1)
+                                        (* Clearly ill-formed type *)
+let dummy_label =
+  { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable;
+    lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular;
+    lbl_private = Public;
+    lbl_loc = Location.none;
+    lbl_attributes = [];
+    lbl_uid = Uid.internal_not_actually_unique;
+  }
+
+let label_descrs ty_res lbls repres priv =
+  let all_labels = Array.make (List.length lbls) dummy_label in
+  let rec describe_labels num = function
+      [] -> []
+    | l :: rest ->
+        let lbl =
+          { lbl_name = Ident.name l.ld_id;
+            lbl_res = ty_res;
+            lbl_arg = l.ld_type;
+            lbl_mut = l.ld_mutable;
+            lbl_pos = num;
+            lbl_all = all_labels;
+            lbl_repres = repres;
+            lbl_private = priv;
+            lbl_loc = l.ld_loc;
+            lbl_attributes = l.ld_attributes;
+            lbl_uid = l.ld_uid;
+          } in
+        all_labels.(num) <- lbl;
+        (l.ld_id, lbl) :: describe_labels (num+1) rest in
+  describe_labels 0 lbls
+
+exception Constr_not_found
+
+let rec find_constr tag num_const num_nonconst = function
+    [] ->
+      raise Constr_not_found
+  | {cd_args = Cstr_tuple []; _} as c  :: rem ->
+      if tag = Cstr_constant num_const
+      then c
+      else find_constr tag (num_const + 1) num_nonconst rem
+  | c :: rem ->
+      if tag = Cstr_block num_nonconst || tag = Cstr_unboxed
+      then c
+      else find_constr tag num_const (num_nonconst + 1) rem
+
+let find_constr_by_tag tag cstrlist =
+  find_constr tag 0 0 cstrlist
+
+let constructors_of_type ~current_unit ty_path decl =
+  match decl.type_kind with
+  | Type_variant (cstrs,rep) ->
+     constructor_descrs ~current_unit ty_path decl cstrs rep
+  | Type_record _ | Type_abstract | Type_open -> []
+
+let labels_of_type ty_path decl =
+  match decl.type_kind with
+  | Type_record(labels, rep) ->
+      label_descrs (newgenconstr ty_path decl.type_params)
+        labels rep decl.type_private
+  | Type_variant _ | Type_abstract | Type_open -> []
diff --git a/upstream/ocaml_413/typing/datarepr.mli b/upstream/ocaml_413/typing/datarepr.mli
new file mode 100644
index 0000000..38f05f7
--- /dev/null
+++ b/upstream/ocaml_413/typing/datarepr.mli
@@ -0,0 +1,45 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Compute constructor and label descriptions from type declarations,
+   determining their representation. *)
+
+open Types
+
+val extension_descr:
+  current_unit:string -> Path.t -> extension_constructor ->
+  constructor_description
+
+val labels_of_type:
+  Path.t -> type_declaration ->
+  (Ident.t * label_description) list
+val constructors_of_type:
+  current_unit:string -> Path.t -> type_declaration ->
+  (Ident.t * constructor_description) list
+
+
+exception Constr_not_found
+
+val find_constr_by_tag:
+  constructor_tag -> constructor_declaration list ->
+    constructor_declaration
+
+val constructor_existentials :
+    constructor_arguments -> type_expr option -> type_expr list * type_expr list
+(** Takes [cd_args] and [cd_res] from a [constructor_declaration] and
+    returns:
+    - the types of the constructor's arguments
+    - the existential variables introduced by the constructor
+ *)
diff --git a/upstream/ocaml_413/typing/env.ml b/upstream/ocaml_413/typing/env.ml
new file mode 100644
index 0000000..545c6ff
--- /dev/null
+++ b/upstream/ocaml_413/typing/env.ml
@@ -0,0 +1,3481 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Environment handling *)
+
+open Cmi_format
+open Misc
+open Asttypes
+open Longident
+open Path
+open Types
+open Btype
+
+open Local_store
+
+module String = Misc.Stdlib.String
+
+let add_delayed_check_forward = ref (fun _ -> assert false)
+
+type 'a usage_tbl = ('a -> unit) Types.Uid.Tbl.t
+(** This table is used to track usage of value declarations.
+    A declaration is identified by its uid.
+    The callback attached to a declaration is called whenever the value (or
+    type, or ...) is used explicitly (lookup_value, ...) or implicitly
+    (inclusion test between signatures, cf Includemod.value_descriptions, ...).
+*)
+
+let value_declarations  : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16
+let type_declarations   : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16
+let module_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16
+
+type constructor_usage = Positive | Pattern | Exported_private | Exported
+type constructor_usages =
+  {
+    mutable cu_positive: bool;
+    mutable cu_pattern: bool;
+    mutable cu_exported_private: bool;
+  }
+let add_constructor_usage cu usage =
+  match usage with
+  | Positive -> cu.cu_positive <- true
+  | Pattern -> cu.cu_pattern <- true
+  | Exported_private -> cu.cu_exported_private <- true
+  | Exported ->
+    cu.cu_positive <- true;
+    cu.cu_pattern <- true;
+    cu.cu_exported_private <- true
+
+let constructor_usages () =
+  {cu_positive = false; cu_pattern = false; cu_exported_private = false}
+
+let constructor_usage_complaint ~rebind priv cu
+  : Warnings.constructor_usage_warning option =
+  match priv, rebind with
+  | Asttypes.Private, _ | _, true ->
+      if cu.cu_positive || cu.cu_pattern || cu.cu_exported_private then None
+      else Some Unused
+  | Asttypes.Public, false -> begin
+      match cu.cu_positive, cu.cu_pattern, cu.cu_exported_private with
+      | true, _, _ -> None
+      | false, false, false -> Some Unused
+      | false, true, _ -> Some Not_constructed
+      | false, false, true -> Some Only_exported_private
+    end
+
+let used_constructors : constructor_usage usage_tbl ref =
+  s_table Types.Uid.Tbl.create 16
+
+type label_usage =
+    Projection | Mutation | Construct | Exported_private | Exported
+type label_usages =
+    {
+     mutable lu_projection: bool;
+     mutable lu_mutation: bool;
+     mutable lu_construct: bool;
+    }
+let add_label_usage lu usage =
+  match usage with
+  | Projection -> lu.lu_projection <- true;
+  | Mutation -> lu.lu_mutation <- true
+  | Construct -> lu.lu_construct <- true
+  | Exported_private ->
+    lu.lu_projection <- true
+  | Exported ->
+    lu.lu_projection <- true;
+    lu.lu_mutation <- true;
+    lu.lu_construct <- true
+
+let label_usages () =
+  {lu_projection = false; lu_mutation = false; lu_construct = false}
+
+let label_usage_complaint priv mut lu
+  : Warnings.field_usage_warning option =
+  match priv, mut with
+  | Asttypes.Private, _ ->
+      if lu.lu_projection then None
+      else Some Unused
+  | Asttypes.Public, Asttypes.Immutable -> begin
+      match lu.lu_projection, lu.lu_construct with
+      | true, _ -> None
+      | false, false -> Some Unused
+      | false, true -> Some Not_read
+    end
+  | Asttypes.Public, Asttypes.Mutable -> begin
+      match lu.lu_projection, lu.lu_mutation, lu.lu_construct with
+      | true, true, _ -> None
+      | false, false, false -> Some Unused
+      | false, _, _ -> Some Not_read
+      | true, false, _ -> Some Not_mutated
+    end
+
+let used_labels : label_usage usage_tbl ref =
+  s_table Types.Uid.Tbl.create 16
+
+(** Map indexed by the name of module components. *)
+module NameMap = String.Map
+
+type value_unbound_reason =
+  | Val_unbound_instance_variable
+  | Val_unbound_self
+  | Val_unbound_ancestor
+  | Val_unbound_ghost_recursive of Location.t
+
+type module_unbound_reason =
+  | Mod_unbound_illegal_recursion
+
+type summary =
+    Env_empty
+  | Env_value of summary * Ident.t * value_description
+  | Env_type of summary * Ident.t * type_declaration
+  | Env_extension of summary * Ident.t * extension_constructor
+  | Env_module of summary * Ident.t * module_presence * module_declaration
+  | Env_modtype of summary * Ident.t * modtype_declaration
+  | Env_class of summary * Ident.t * class_declaration
+  | Env_cltype of summary * Ident.t * class_type_declaration
+  | Env_open of summary * Path.t
+  | Env_functor_arg of summary * Ident.t
+  | Env_constraints of summary * type_declaration Path.Map.t
+  | Env_copy_types of summary
+  | Env_persistent of summary * Ident.t
+  | Env_value_unbound of summary * string * value_unbound_reason
+  | Env_module_unbound of summary * string * module_unbound_reason
+
+let map_summary f = function
+    Env_empty -> Env_empty
+  | Env_value (s, id, d) -> Env_value (f s, id, d)
+  | Env_type (s, id, d) -> Env_type (f s, id, d)
+  | Env_extension (s, id, d) -> Env_extension (f s, id, d)
+  | Env_module (s, id, p, d) -> Env_module (f s, id, p, d)
+  | Env_modtype (s, id, d) -> Env_modtype (f s, id, d)
+  | Env_class (s, id, d) -> Env_class (f s, id, d)
+  | Env_cltype (s, id, d) -> Env_cltype (f s, id, d)
+  | Env_open (s, p) -> Env_open (f s, p)
+  | Env_functor_arg (s, id) -> Env_functor_arg (f s, id)
+  | Env_constraints (s, m) -> Env_constraints (f s, m)
+  | Env_copy_types s -> Env_copy_types (f s)
+  | Env_persistent (s, id) -> Env_persistent (f s, id)
+  | Env_value_unbound (s, u, r) -> Env_value_unbound (f s, u, r)
+  | Env_module_unbound (s, u, r) -> Env_module_unbound (f s, u, r)
+
+type address =
+  | Aident of Ident.t
+  | Adot of address * int
+
+module TycompTbl =
+  struct
+    (** This module is used to store components of types (i.e. labels
+        and constructors).  We keep a representation of each nested
+        "open" and the set of local bindings between each of them. *)
+
+    type 'a t = {
+      current: 'a Ident.tbl;
+      (** Local bindings since the last open. *)
+
+      opened: 'a opened option;
+      (** Symbolic representation of the last (innermost) open, if any. *)
+    }
+
+    and 'a opened = {
+      components: ('a list) NameMap.t;
+      (** Components from the opened module. We keep a list of
+          bindings for each name, as in comp_labels and
+          comp_constrs. *)
+
+      root: Path.t;
+      (** Only used to check removal of open *)
+
+      using: (string -> ('a * 'a) option -> unit) option;
+      (** A callback to be applied when a component is used from this
+          "open".  This is used to detect unused "opens".  The
+          arguments are used to detect shadowing. *)
+
+      next: 'a t;
+      (** The table before opening the module. *)
+    }
+
+    let empty = { current = Ident.empty; opened = None }
+
+    let add id x tbl =
+      {tbl with current = Ident.add id x tbl.current}
+
+    let add_open slot wrap root components next =
+      let using =
+        match slot with
+        | None -> None
+        | Some f -> Some (fun s x -> f s (wrap x))
+      in
+      {
+        current = Ident.empty;
+        opened = Some {using; components; root; next};
+      }
+
+    let remove_last_open rt tbl =
+      match tbl.opened with
+      | Some {root; next; _} when Path.same rt root ->
+          { next with current =
+            Ident.fold_all Ident.add tbl.current next.current }
+      | _ ->
+          assert false
+
+    let rec find_same id tbl =
+      try Ident.find_same id tbl.current
+      with Not_found as exn ->
+        begin match tbl.opened with
+        | Some {next; _} -> find_same id next
+        | None -> raise exn
+        end
+
+    let nothing = fun () -> ()
+
+    let mk_callback rest name desc using =
+      match using with
+      | None -> nothing
+      | Some f ->
+          (fun () ->
+             match rest with
+             | [] -> f name None
+             | (hidden, _) :: _ -> f name (Some (desc, hidden)))
+
+    let rec find_all ~mark name tbl =
+      List.map (fun (_id, desc) -> desc, nothing)
+        (Ident.find_all name tbl.current) @
+      match tbl.opened with
+      | None -> []
+      | Some {using; next; components; root = _} ->
+          let rest = find_all ~mark name next in
+          let using = if mark then using else None in
+          match NameMap.find name components with
+          | exception Not_found -> rest
+          | opened ->
+              List.map
+                (fun desc -> desc, mk_callback rest name desc using)
+                opened
+              @ rest
+
+    let rec fold_name f tbl acc =
+      let acc = Ident.fold_name (fun _id d -> f d) tbl.current acc in
+      match tbl.opened with
+      | Some {using = _; next; components; root = _} ->
+          acc
+          |> NameMap.fold
+            (fun _name -> List.fold_right f)
+            components
+          |> fold_name f next
+      | None ->
+          acc
+
+    let rec local_keys tbl acc =
+      let acc = Ident.fold_all (fun k _ accu -> k::accu) tbl.current acc in
+      match tbl.opened with
+      | Some o -> local_keys o.next acc
+      | None -> acc
+
+    let diff_keys is_local tbl1 tbl2 =
+      let keys2 = local_keys tbl2 [] in
+      List.filter
+        (fun id ->
+           is_local (find_same id tbl2) &&
+           try ignore (find_same id tbl1); false
+           with Not_found -> true)
+        keys2
+
+  end
+
+
+module IdTbl =
+  struct
+    (** This module is used to store all kinds of components except
+        (labels and constructors) in environments.  We keep a
+        representation of each nested "open" and the set of local
+        bindings between each of them. *)
+
+
+    type ('a, 'b) t = {
+      current: 'a Ident.tbl;
+      (** Local bindings since the last open *)
+
+      layer: ('a, 'b) layer;
+      (** Symbolic representation of the last (innermost) open, if any. *)
+    }
+
+    and ('a, 'b) layer =
+      | Open of {
+          root: Path.t;
+          (** The path of the opened module, to be prefixed in front of
+              its local names to produce a valid path in the current
+              environment. *)
+
+          components: 'b NameMap.t;
+          (** Components from the opened module. *)
+
+          using: (string -> ('a * 'a) option -> unit) option;
+          (** A callback to be applied when a component is used from this
+              "open".  This is used to detect unused "opens".  The
+              arguments are used to detect shadowing. *)
+
+          next: ('a, 'b) t;
+          (** The table before opening the module. *)
+        }
+
+      | Map of {
+          f: ('a -> 'a);
+          next: ('a, 'b) t;
+        }
+
+      | Nothing
+
+    let empty = { current = Ident.empty; layer = Nothing }
+
+    let add id x tbl =
+      {tbl with current = Ident.add id x tbl.current}
+
+    let remove id tbl =
+      {tbl with current = Ident.remove id tbl.current}
+
+    let add_open slot wrap root components next =
+      let using =
+        match slot with
+        | None -> None
+        | Some f -> Some (fun s x -> f s (wrap x))
+      in
+      {
+        current = Ident.empty;
+        layer = Open {using; root; components; next};
+      }
+
+    let remove_last_open rt tbl =
+      match tbl.layer with
+      | Open {root; next; _} when Path.same rt root ->
+          { next with current =
+            Ident.fold_all Ident.add tbl.current next.current }
+      | _ ->
+          assert false
+
+    let map f next =
+      {
+        current = Ident.empty;
+        layer = Map {f; next}
+      }
+
+    let rec find_same id tbl =
+      try Ident.find_same id tbl.current
+      with Not_found as exn ->
+        begin match tbl.layer with
+        | Open {next; _} -> find_same id next
+        | Map {f; next} -> f (find_same id next)
+        | Nothing -> raise exn
+        end
+
+    let rec find_name wrap ~mark name tbl =
+      try
+        let (id, desc) = Ident.find_name name tbl.current in
+        Pident id, desc
+      with Not_found as exn ->
+        begin match tbl.layer with
+        | Open {using; root; next; components} ->
+            begin try
+              let descr = wrap (NameMap.find name components) in
+              let res = Pdot (root, name), descr in
+              if mark then begin match using with
+              | None -> ()
+              | Some f -> begin
+                  match find_name wrap ~mark:false name next with
+                  | exception Not_found -> f name None
+                  | _, descr' -> f name (Some (descr', descr))
+                end
+              end;
+              res
+            with Not_found ->
+              find_name wrap ~mark name next
+            end
+        | Map {f; next} ->
+            let (p, desc) =  find_name wrap ~mark name next in
+            p, f desc
+        | Nothing ->
+            raise exn
+        end
+
+    let rec find_all wrap name tbl =
+      List.map
+        (fun (id, desc) -> Pident id, desc)
+        (Ident.find_all name tbl.current) @
+      match tbl.layer with
+      | Nothing -> []
+      | Open {root; using = _; next; components} ->
+          begin try
+            let desc = wrap (NameMap.find name components) in
+            (Pdot (root, name), desc) :: find_all wrap name next
+          with Not_found ->
+            find_all wrap name next
+          end
+      | Map {f; next} ->
+          List.map (fun (p, desc) -> (p, f desc))
+            (find_all wrap name next)
+
+    let rec fold_name wrap f tbl acc =
+      let acc =
+        Ident.fold_name
+          (fun id d -> f (Ident.name id) (Pident id, d))
+          tbl.current acc
+      in
+      match tbl.layer with
+      | Open {root; using = _; next; components} ->
+          acc
+          |> NameMap.fold
+            (fun name desc -> f name (Pdot (root, name), wrap desc))
+            components
+          |> fold_name wrap f next
+      | Nothing ->
+          acc
+      | Map {f=g; next} ->
+          acc
+          |> fold_name wrap
+               (fun name (path, desc) -> f name (path, g desc))
+               next
+
+    let rec local_keys tbl acc =
+      let acc = Ident.fold_all (fun k _ accu -> k::accu) tbl.current acc in
+      match tbl.layer with
+      | Open {next; _ } | Map {next; _} -> local_keys next acc
+      | Nothing -> acc
+
+
+    let rec iter wrap f tbl =
+      Ident.iter (fun id desc -> f id (Pident id, desc)) tbl.current;
+      match tbl.layer with
+      | Open {root; using = _; next; components} ->
+          NameMap.iter
+            (fun s x ->
+               let root_scope = Path.scope root in
+              f (Ident.create_scoped ~scope:root_scope s)
+                (Pdot (root, s), wrap x))
+            components;
+          iter wrap f next
+      | Map {f=g; next} ->
+          iter wrap (fun id (path, desc) -> f id (path, g desc)) next
+      | Nothing -> ()
+
+    let diff_keys tbl1 tbl2 =
+      let keys2 = local_keys tbl2 [] in
+      List.filter
+        (fun id ->
+           try ignore (find_same id tbl1); false
+           with Not_found -> true)
+        keys2
+
+
+  end
+
+type type_descr_kind =
+  (label_description, constructor_description) type_kind
+
+type type_descriptions = type_descr_kind
+
+let in_signature_flag = 0x01
+
+type t = {
+  values: (value_entry, value_data) IdTbl.t;
+  constrs: constructor_data TycompTbl.t;
+  labels: label_data TycompTbl.t;
+  types: (type_data, type_data) IdTbl.t;
+  modules: (module_entry, module_data) IdTbl.t;
+  modtypes: (modtype_data, modtype_data) IdTbl.t;
+  classes: (class_data, class_data) IdTbl.t;
+  cltypes: (cltype_data, cltype_data) IdTbl.t;
+  functor_args: unit Ident.tbl;
+  summary: summary;
+  local_constraints: type_declaration Path.Map.t;
+  flags: int;
+}
+
+and module_declaration_lazy =
+  (Subst.t * Subst.scoping * module_declaration, module_declaration)
+    Lazy_backtrack.t
+
+and module_components =
+  {
+    alerts: alerts;
+    uid: Uid.t;
+    comps:
+      (components_maker,
+       (module_components_repr, module_components_failure) result)
+        Lazy_backtrack.t;
+  }
+
+and components_maker = {
+  cm_env: t;
+  cm_freshening_subst: Subst.t option;
+  cm_prefixing_subst: Subst.t;
+  cm_path: Path.t;
+  cm_addr: address_lazy;
+  cm_mty: Types.module_type;
+}
+
+and module_components_repr =
+    Structure_comps of structure_components
+  | Functor_comps of functor_components
+
+and module_components_failure =
+  | No_components_abstract
+  | No_components_alias of Path.t
+
+and structure_components = {
+  mutable comp_values: value_data NameMap.t;
+  mutable comp_constrs: constructor_data list NameMap.t;
+  mutable comp_labels: label_data list NameMap.t;
+  mutable comp_types: type_data NameMap.t;
+  mutable comp_modules: module_data NameMap.t;
+  mutable comp_modtypes: modtype_data NameMap.t;
+  mutable comp_classes: class_data NameMap.t;
+  mutable comp_cltypes: cltype_data NameMap.t;
+}
+
+and functor_components = {
+  fcomp_arg: functor_parameter;
+  (* Formal parameter and argument signature *)
+  fcomp_res: module_type;               (* Result signature *)
+  fcomp_cache: (Path.t, module_components) Hashtbl.t;  (* For memoization *)
+  fcomp_subst_cache: (Path.t, module_type) Hashtbl.t
+}
+
+and address_unforced =
+  | Projection of { parent : address_lazy; pos : int; }
+  | ModAlias of { env : t; path : Path.t; }
+
+and address_lazy = (address_unforced, address) Lazy_backtrack.t
+
+and value_data =
+  { vda_description : value_description;
+    vda_address : address_lazy }
+
+and value_entry =
+  | Val_bound of value_data
+  | Val_unbound of value_unbound_reason
+
+and constructor_data =
+  { cda_description : constructor_description;
+    cda_address : address_lazy option; }
+
+and label_data = label_description
+
+and type_data =
+  { tda_declaration : type_declaration;
+    tda_descriptions : type_descriptions; }
+
+and module_data =
+  { mda_declaration : module_declaration_lazy;
+    mda_components : module_components;
+    mda_address : address_lazy; }
+
+and module_entry =
+  | Mod_local of module_data
+  | Mod_persistent
+  | Mod_unbound of module_unbound_reason
+
+and modtype_data = modtype_declaration
+
+and class_data =
+  { clda_declaration : class_declaration;
+    clda_address : address_lazy }
+
+and cltype_data = class_type_declaration
+
+let empty_structure =
+  Structure_comps {
+    comp_values = NameMap.empty;
+    comp_constrs = NameMap.empty;
+    comp_labels = NameMap.empty;
+    comp_types = NameMap.empty;
+    comp_modules = NameMap.empty; comp_modtypes = NameMap.empty;
+    comp_classes = NameMap.empty;
+    comp_cltypes = NameMap.empty }
+
+type unbound_value_hint =
+  | No_hint
+  | Missing_rec of Location.t
+
+type lookup_error =
+  | Unbound_value of Longident.t * unbound_value_hint
+  | Unbound_type of Longident.t
+  | Unbound_constructor of Longident.t
+  | Unbound_label of Longident.t
+  | Unbound_module of Longident.t
+  | Unbound_class of Longident.t
+  | Unbound_modtype of Longident.t
+  | Unbound_cltype of Longident.t
+  | Unbound_instance_variable of string
+  | Not_an_instance_variable of string
+  | Masked_instance_variable of Longident.t
+  | Masked_self_variable of Longident.t
+  | Masked_ancestor_variable of Longident.t
+  | Structure_used_as_functor of Longident.t
+  | Abstract_used_as_functor of Longident.t
+  | Functor_used_as_structure of Longident.t
+  | Abstract_used_as_structure of Longident.t
+  | Generative_used_as_applicative of Longident.t
+  | Illegal_reference_to_recursive_module
+  | Cannot_scrape_alias of Longident.t * Path.t
+
+type error =
+  | Missing_module of Location.t * Path.t * Path.t
+  | Illegal_value_name of Location.t * string
+  | Lookup_error of Location.t * t * lookup_error
+
+exception Error of error
+
+let error err = raise (Error err)
+
+let lookup_error loc env err =
+  error (Lookup_error(loc, env, err))
+
+let same_constr = ref (fun _ _ _ -> assert false)
+
+let check_well_formed_module = ref (fun _ -> assert false)
+
+(* Helper to decide whether to report an identifier shadowing
+   by some 'open'. For labels and constructors, we do not report
+   if the two elements are from the same re-exported declaration.
+
+   Later, one could also interpret some attributes on value and
+   type declarations to silence the shadowing warnings. *)
+
+let check_shadowing env = function
+  | `Constructor (Some (cda1, cda2))
+    when not (!same_constr env
+                cda1.cda_description.cstr_res
+                cda2.cda_description.cstr_res) ->
+      Some "constructor"
+  | `Label (Some (l1, l2))
+    when not (!same_constr env l1.lbl_res l2.lbl_res) ->
+      Some "label"
+  | `Value (Some _) -> Some "value"
+  | `Type (Some _) -> Some "type"
+  | `Module (Some _) | `Component (Some _) -> Some "module"
+  | `Module_type (Some _) -> Some "module type"
+  | `Class (Some _) -> Some "class"
+  | `Class_type (Some _) -> Some "class type"
+  | `Constructor _ | `Label _
+  | `Value None | `Type None | `Module None | `Module_type None
+  | `Class None | `Class_type None | `Component None ->
+      None
+
+let subst_modtype_maker (subst, scoping, md) =
+  {md with md_type = Subst.modtype scoping subst md.md_type}
+
+let empty = {
+  values = IdTbl.empty; constrs = TycompTbl.empty;
+  labels = TycompTbl.empty; types = IdTbl.empty;
+  modules = IdTbl.empty; modtypes = IdTbl.empty;
+  classes = IdTbl.empty; cltypes = IdTbl.empty;
+  summary = Env_empty; local_constraints = Path.Map.empty;
+  flags = 0;
+  functor_args = Ident.empty;
+ }
+
+let in_signature b env =
+  let flags =
+    if b then env.flags lor in_signature_flag
+    else env.flags land (lnot in_signature_flag)
+  in
+  {env with flags}
+
+let is_in_signature env = env.flags land in_signature_flag <> 0
+
+let has_local_constraints env =
+  not (Path.Map.is_empty env.local_constraints)
+
+let is_ident = function
+    Pident _ -> true
+  | Pdot _ | Papply _ -> false
+
+let is_ext cda =
+  match cda.cda_description with
+  | {cstr_tag = Cstr_extension _} -> true
+  | _ -> false
+
+let is_local_ext cda =
+  match cda.cda_description with
+  | {cstr_tag = Cstr_extension(p, _)} -> is_ident p
+  | _ -> false
+
+let diff env1 env2 =
+  IdTbl.diff_keys env1.values env2.values @
+  TycompTbl.diff_keys is_local_ext env1.constrs env2.constrs @
+  IdTbl.diff_keys env1.modules env2.modules @
+  IdTbl.diff_keys env1.classes env2.classes
+
+(* Functions for use in "wrap" parameters in IdTbl *)
+let wrap_identity x = x
+let wrap_value vda = Val_bound vda
+let wrap_module mda = Mod_local mda
+
+(* Forward declarations *)
+
+let components_of_module_maker' =
+  ref ((fun _ -> assert false) :
+          components_maker ->
+            (module_components_repr, module_components_failure) result)
+
+let components_of_functor_appl' =
+  ref ((fun ~loc:_ ~f_path:_ ~f_comp:_ ~arg:_ _env -> assert false) :
+          loc:Location.t -> f_path:Path.t -> f_comp:functor_components ->
+            arg:Path.t -> t -> module_components)
+let check_functor_application =
+  (* to be filled by Includemod *)
+  ref ((fun ~errors:_ ~loc:_
+         ~lid_whole_app:_  ~f0_path:_ ~args:_
+         ~arg_path:_ ~arg_mty:_ ~param_mty:_
+         _env
+         -> assert false) :
+         errors:bool -> loc:Location.t ->
+       lid_whole_app:Longident.t ->
+       f0_path:Path.t -> args:(Path.t * Types.module_type) list ->
+       arg_path:Path.t -> arg_mty:module_type -> param_mty:module_type ->
+       t -> unit)
+let strengthen =
+  (* to be filled with Mtype.strengthen *)
+  ref ((fun ~aliasable:_ _env _mty _path -> assert false) :
+         aliasable:bool -> t -> module_type -> Path.t -> module_type)
+
+let md md_type =
+  {md_type; md_attributes=[]; md_loc=Location.none
+  ;md_uid = Uid.internal_not_actually_unique}
+
+(* Print addresses *)
+
+let rec print_address ppf = function
+  | Aident id -> Format.fprintf ppf "%s" (Ident.name id)
+  | Adot(a, pos) -> Format.fprintf ppf "%a.[%i]" print_address a pos
+
+(* The name of the compilation unit currently compiled.
+   "" if outside a compilation unit. *)
+module Current_unit_name : sig
+  val get : unit -> modname
+  val set : modname -> unit
+  val is : modname -> bool
+  val is_ident : Ident.t -> bool
+  val is_path : Path.t -> bool
+end = struct
+  let current_unit =
+    ref ""
+  let get () =
+    !current_unit
+  let set name =
+    current_unit := name
+  let is name =
+    !current_unit = name
+  let is_ident id =
+    Ident.persistent id && is (Ident.name id)
+  let is_path = function
+  | Pident id -> is_ident id
+  | Pdot _ | Papply _ -> false
+end
+
+let set_unit_name = Current_unit_name.set
+let get_unit_name = Current_unit_name.get
+
+let find_same_module id tbl =
+  match IdTbl.find_same id tbl with
+  | x -> x
+  | exception Not_found
+    when Ident.persistent id && not (Current_unit_name.is_ident id) ->
+      Mod_persistent
+
+let find_name_module ~mark name tbl =
+  match IdTbl.find_name wrap_module ~mark name tbl with
+  | x -> x
+  | exception Not_found when not (Current_unit_name.is name) ->
+      let path = Pident(Ident.create_persistent name) in
+      path, Mod_persistent
+
+let add_persistent_structure id env =
+  if not (Ident.persistent id) then invalid_arg "Env.add_persistent_structure";
+  if Current_unit_name.is_ident id then env
+  else begin
+    let material =
+      (* This addition only observably changes the environment if it shadows a
+         non-persistent module already in the environment.
+         (See PR#9345) *)
+      match
+        IdTbl.find_name wrap_module ~mark:false (Ident.name id) env.modules
+      with
+      | exception Not_found | _, Mod_persistent -> false
+      | _ -> true
+    in
+    let summary =
+      if material then Env_persistent (env.summary, id)
+      else env.summary
+    in
+    let modules =
+      (* With [-no-alias-deps], non-material additions should not
+         affect the environment at all. We should only observe the
+         existence of a cmi when accessing components of the module.
+         (See #9991). *)
+      if material || not !Clflags.transparent_modules then
+        IdTbl.add id Mod_persistent env.modules
+      else
+        env.modules
+    in
+    { env with modules; summary }
+  end
+
+let components_of_module ~alerts ~uid env fs ps path addr mty =
+  {
+    alerts;
+    uid;
+    comps = Lazy_backtrack.create {
+      cm_env = env;
+      cm_freshening_subst = fs;
+      cm_prefixing_subst = ps;
+      cm_path = path;
+      cm_addr = addr;
+      cm_mty = mty
+    }
+  }
+
+let sign_of_cmi ~freshen { Persistent_env.Persistent_signature.cmi; _ } =
+  let name = cmi.cmi_name in
+  let sign = cmi.cmi_sign in
+  let flags = cmi.cmi_flags in
+  let id = Ident.create_persistent name in
+  let path = Pident id in
+  let alerts =
+    List.fold_left (fun acc -> function Alerts s -> s | _ -> acc)
+      Misc.Stdlib.String.Map.empty
+      flags
+  in
+  let md =
+    { md_type =  Mty_signature sign;
+      md_loc = Location.none;
+      md_attributes = [];
+      md_uid = Uid.of_compilation_unit_id id;
+    }
+  in
+  let mda_address = Lazy_backtrack.create_forced (Aident id) in
+  let mda_declaration =
+    Lazy_backtrack.create (Subst.identity, Subst.Make_local, md)
+  in
+  let mda_components =
+    let freshening_subst =
+      if freshen then (Some Subst.identity) else None
+    in
+    components_of_module ~alerts ~uid:md.md_uid
+      empty freshening_subst Subst.identity
+      path mda_address (Mty_signature sign)
+  in
+  {
+    mda_declaration;
+    mda_components;
+    mda_address;
+  }
+
+let read_sign_of_cmi = sign_of_cmi ~freshen:true
+
+let save_sign_of_cmi = sign_of_cmi ~freshen:false
+
+let persistent_env : module_data Persistent_env.t ref =
+  s_table Persistent_env.empty ()
+
+let without_cmis f x =
+  Persistent_env.without_cmis !persistent_env f x
+
+let imports () = Persistent_env.imports !persistent_env
+
+let import_crcs ~source crcs =
+  Persistent_env.import_crcs !persistent_env ~source crcs
+
+let read_pers_mod modname filename =
+  Persistent_env.read !persistent_env read_sign_of_cmi modname filename
+
+let find_pers_mod name =
+  Persistent_env.find !persistent_env read_sign_of_cmi name
+
+let check_pers_mod ~loc name =
+  Persistent_env.check !persistent_env read_sign_of_cmi ~loc name
+
+let crc_of_unit name =
+  Persistent_env.crc_of_unit !persistent_env read_sign_of_cmi name
+
+let is_imported_opaque modname =
+  Persistent_env.is_imported_opaque !persistent_env modname
+
+let register_import_as_opaque modname =
+  Persistent_env.register_import_as_opaque !persistent_env modname
+
+let reset_declaration_caches () =
+  Types.Uid.Tbl.clear !value_declarations;
+  Types.Uid.Tbl.clear !type_declarations;
+  Types.Uid.Tbl.clear !module_declarations;
+  Types.Uid.Tbl.clear !used_constructors;
+  Types.Uid.Tbl.clear !used_labels;
+  ()
+
+let reset_cache () =
+  Current_unit_name.set "";
+  Persistent_env.clear !persistent_env;
+  reset_declaration_caches ();
+  ()
+
+let reset_cache_toplevel () =
+  Persistent_env.clear_missing !persistent_env;
+  reset_declaration_caches ();
+  ()
+
+(* get_components *)
+
+let get_components_res c =
+  match Persistent_env.can_load_cmis !persistent_env with
+  | Persistent_env.Can_load_cmis ->
+    Lazy_backtrack.force !components_of_module_maker' c.comps
+  | Persistent_env.Cannot_load_cmis log ->
+    Lazy_backtrack.force_logged log !components_of_module_maker' c.comps
+
+let get_components c =
+  match get_components_res c with
+  | Error _ -> empty_structure
+  | Ok c -> c
+
+(* Module type of functor application *)
+
+let modtype_of_functor_appl fcomp p1 p2 =
+  match fcomp.fcomp_res with
+  | Mty_alias _ as mty -> mty
+  | mty ->
+      try
+        Hashtbl.find fcomp.fcomp_subst_cache p2
+      with Not_found ->
+        let scope = Path.scope (Papply(p1, p2)) in
+        let mty =
+          let subst =
+            match fcomp.fcomp_arg with
+            | Unit
+            | Named (None, _) -> Subst.identity
+            | Named (Some param, _) -> Subst.add_module param p2 Subst.identity
+          in
+          Subst.modtype (Rescope scope) subst mty
+        in
+        Hashtbl.add fcomp.fcomp_subst_cache p2 mty;
+        mty
+
+let check_functor_appl
+    ~errors ~loc ~lid_whole_app ~f0_path ~args
+    ~f_comp
+    ~arg_path ~arg_mty ~param_mty
+    env =
+  if not (Hashtbl.mem f_comp.fcomp_cache arg_path) then
+    !check_functor_application
+      ~errors ~loc ~lid_whole_app ~f0_path ~args
+      ~arg_path ~arg_mty ~param_mty
+      env
+
+(* Lookup by identifier *)
+
+let find_ident_module id env =
+  match find_same_module id env.modules with
+  | Mod_local data -> data
+  | Mod_unbound _ -> raise Not_found
+  | Mod_persistent -> find_pers_mod (Ident.name id)
+
+let rec find_module_components path env =
+  match path with
+  | Pident id -> (find_ident_module id env).mda_components
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      (NameMap.find s sc.comp_modules).mda_components
+  | Papply(f_path, arg) ->
+      let f_comp = find_functor_components f_path env in
+      let loc = Location.(in_file !input_name) in
+      !components_of_functor_appl' ~loc ~f_path ~f_comp ~arg env
+
+and find_structure_components path env =
+  match get_components (find_module_components path env) with
+  | Structure_comps c -> c
+  | Functor_comps _ -> raise Not_found
+
+and find_functor_components path env =
+  match get_components (find_module_components path env) with
+  | Functor_comps f -> f
+  | Structure_comps _ -> raise Not_found
+
+let find_module ~alias path env =
+  match path with
+  | Pident id ->
+      let data = find_ident_module id env in
+      Lazy_backtrack.force subst_modtype_maker data.mda_declaration
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      let data = NameMap.find s sc.comp_modules in
+      Lazy_backtrack.force subst_modtype_maker data.mda_declaration
+  | Papply(p1, p2) ->
+      let fc = find_functor_components p1 env in
+      if alias then md (fc.fcomp_res)
+      else md (modtype_of_functor_appl fc p1 p2)
+
+let find_value_full path env =
+  match path with
+  | Pident id -> begin
+      match IdTbl.find_same id env.values with
+      | Val_bound data -> data
+      | Val_unbound _ -> raise Not_found
+    end
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      NameMap.find s sc.comp_values
+  | Papply _ -> raise Not_found
+
+let find_type_full path env =
+  match path with
+  | Pident id -> IdTbl.find_same id env.types
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      NameMap.find s sc.comp_types
+  | Papply _ -> raise Not_found
+
+let find_modtype path env =
+  match path with
+  | Pident id -> IdTbl.find_same id env.modtypes
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      NameMap.find s sc.comp_modtypes
+  | Papply _ -> raise Not_found
+
+let find_class_full path env =
+  match path with
+  | Pident id -> IdTbl.find_same id env.classes
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      NameMap.find s sc.comp_classes
+  | Papply _ -> raise Not_found
+
+let find_cltype path env =
+  match path with
+  | Pident id -> IdTbl.find_same id env.cltypes
+  | Pdot(p, s) ->
+      let sc = find_structure_components p env in
+      NameMap.find s sc.comp_cltypes
+  | Papply _ -> raise Not_found
+
+let find_value path env =
+  (find_value_full path env).vda_description
+
+let find_class path env =
+  (find_class_full path env).clda_declaration
+
+let find_ident_constructor id env =
+  (TycompTbl.find_same id env.constrs).cda_description
+
+let find_ident_label id env =
+  TycompTbl.find_same id env.labels
+
+let type_of_cstr path = function
+  | {cstr_inlined = Some decl; _} ->
+      let labels =
+        List.map snd (Datarepr.labels_of_type path decl)
+      in
+      begin match decl.type_kind with
+      | Type_record (_, repr) ->
+        {
+          tda_declaration = decl;
+          tda_descriptions = Type_record (labels, repr);
+        }
+      | _ -> assert false
+      end
+  | _ -> assert false
+
+let find_type_data path env =
+  match Path.constructor_typath path with
+  | Regular p -> begin
+      match Path.Map.find p env.local_constraints with
+      | decl ->
+          { tda_declaration = decl; tda_descriptions = Type_abstract }
+      | exception Not_found -> find_type_full p env
+    end
+  | Cstr (ty_path, s) ->
+      (* This case corresponds to an inlined record *)
+      let tda =
+        try find_type_full ty_path env
+        with Not_found -> assert false
+      in
+      let cstr =
+        begin match tda.tda_descriptions with
+        | Type_variant (cstrs, _) -> begin
+            try
+              List.find (fun cstr -> cstr.cstr_name = s) cstrs
+            with Not_found -> assert false
+          end
+        | Type_record _ | Type_abstract | Type_open -> assert false
+        end
+      in
+      type_of_cstr path cstr
+  | LocalExt id ->
+      let cstr =
+        try (TycompTbl.find_same id env.constrs).cda_description
+        with Not_found -> assert false
+      in
+      type_of_cstr path cstr
+  | Ext (mod_path, s) ->
+      let comps =
+        try find_structure_components mod_path env
+        with Not_found -> assert false
+      in
+      let cstrs =
+        try NameMap.find s comps.comp_constrs
+        with Not_found -> assert false
+      in
+      let exts = List.filter is_ext cstrs in
+      match exts with
+      | [cda] -> type_of_cstr path cda.cda_description
+      | _ -> assert false
+
+let find_type p env =
+  (find_type_data p env).tda_declaration
+let find_type_descrs p env =
+  (find_type_data p env).tda_descriptions
+
+let rec find_module_address path env =
+  match path with
+  | Pident id -> get_address (find_ident_module id env).mda_address
+  | Pdot(p, s) ->
+      let c = find_structure_components p env in
+      get_address (NameMap.find s c.comp_modules).mda_address
+  | Papply _ -> raise Not_found
+
+and force_address = function
+  | Projection { parent; pos } -> Adot(get_address parent, pos)
+  | ModAlias { env; path } -> find_module_address path env
+
+and get_address a =
+  Lazy_backtrack.force force_address a
+
+let find_value_address path env =
+  get_address (find_value_full path env).vda_address
+
+let find_class_address path env =
+  get_address (find_class_full path env).clda_address
+
+let rec get_constrs_address = function
+  | [] -> raise Not_found
+  | cda :: rest ->
+    match cda.cda_address with
+    | None -> get_constrs_address rest
+    | Some a -> get_address a
+
+let find_constructor_address path env =
+  match path with
+  | Pident id -> begin
+      let cda = TycompTbl.find_same id env.constrs in
+      match cda.cda_address with
+      | None -> raise Not_found
+      | Some addr -> get_address addr
+    end
+  | Pdot(p, s) ->
+      let c = find_structure_components p env in
+      get_constrs_address (NameMap.find s c.comp_constrs)
+  | Papply _ ->
+      raise Not_found
+
+let find_hash_type path env =
+  match path with
+  | Pident id ->
+      let name = "#" ^ Ident.name id in
+      let _, tda =
+        IdTbl.find_name wrap_identity ~mark:false name env.types
+      in
+      tda.tda_declaration
+  | Pdot(p, s) ->
+      let c = find_structure_components p env in
+      let name = "#" ^ s in
+      let tda = NameMap.find name c.comp_types in
+      tda.tda_declaration
+  | Papply _ ->
+      raise Not_found
+
+let required_globals = s_ref []
+let reset_required_globals () = required_globals := []
+let get_required_globals () = !required_globals
+let add_required_global id =
+  if Ident.global id && not !Clflags.transparent_modules
+  && not (List.exists (Ident.same id) !required_globals)
+  then required_globals := id :: !required_globals
+
+let rec normalize_module_path lax env = function
+  | Pident id as path when lax && Ident.persistent id ->
+      path (* fast path (avoids lookup) *)
+  | Pdot (p, s) as path ->
+      let p' = normalize_module_path lax env p in
+      if p == p' then expand_module_path lax env path
+      else expand_module_path lax env (Pdot(p', s))
+  | Papply (p1, p2) as path ->
+      let p1' = normalize_module_path lax env p1 in
+      let p2' = normalize_module_path true env p2 in
+      if p1 == p1' && p2 == p2' then expand_module_path lax env path
+      else expand_module_path lax env (Papply(p1', p2'))
+  | Pident _ as path ->
+      expand_module_path lax env path
+
+and expand_module_path lax env path =
+  try match find_module ~alias:true path env with
+    {md_type=Mty_alias path1} ->
+      let path' = normalize_module_path lax env path1 in
+      if lax || !Clflags.transparent_modules then path' else
+      let id = Path.head path in
+      if Ident.global id && not (Ident.same id (Path.head path'))
+      then add_required_global id;
+      path'
+  | _ -> path
+  with Not_found when lax
+  || (match path with Pident id -> not (Ident.persistent id) | _ -> true) ->
+      path
+
+let normalize_module_path oloc env path =
+  try normalize_module_path (oloc = None) env path
+  with Not_found ->
+    match oloc with None -> assert false
+    | Some loc ->
+        error (Missing_module(loc, path,
+                              normalize_module_path true env path))
+
+let normalize_path_prefix oloc env path =
+  match path with
+    Pdot(p, s) ->
+      let p2 = normalize_module_path oloc env p in
+      if p == p2 then path else Pdot(p2, s)
+  | Pident _ ->
+      path
+  | Papply _ ->
+      assert false
+
+let normalize_type_path oloc env path =
+  (* Inlined version of Path.is_constructor_typath:
+     constructor type paths (i.e. path pointing to an inline
+     record argument of a constructpr) are built as a regular
+     type path followed by a capitalized constructor name. *)
+  match path with
+  | Pident _ ->
+      path
+  | Pdot(p, s) ->
+      let p2 =
+        if Path.is_uident s && not (Path.is_uident (Path.last p)) then
+          (* Cstr M.t.C *)
+          normalize_path_prefix oloc env p
+        else
+          (* Regular M.t, Ext M.C *)
+          normalize_module_path oloc env p
+      in
+      if p == p2 then path else Pdot (p2, s)
+  | Papply _ ->
+      assert false
+
+let rec normalize_modtype_path env path =
+  let path = normalize_path_prefix None env path in
+  expand_modtype_path env path
+
+and expand_modtype_path env path =
+  match (find_modtype path env).mtd_type with
+  | Some (Mty_ident path) -> normalize_modtype_path env path
+  | _ | exception Not_found -> path
+
+let find_module path env =
+  find_module ~alias:false path env
+
+(* Find the manifest type associated to a type when appropriate:
+   - the type should be public or should have a private row,
+   - the type should have an associated manifest type. *)
+let find_type_expansion path env =
+  let decl = find_type path env in
+  match decl.type_manifest with
+  | Some body when decl.type_private = Public
+              || decl.type_kind <> Type_abstract
+              || Btype.has_constr_row body ->
+      (decl.type_params, body, decl.type_expansion_scope)
+  (* The manifest type of Private abstract data types without
+     private row are still considered unknown to the type system.
+     Hence, this case is caught by the following clause that also handles
+     purely abstract data types without manifest type definition. *)
+  | _ -> raise Not_found
+
+(* Find the manifest type information associated to a type, i.e.
+   the necessary information for the compiler's type-based optimisations.
+   In particular, the manifest type associated to a private abstract type
+   is revealed for the sake of compiler's type-based optimisations. *)
+let find_type_expansion_opt path env =
+  let decl = find_type path env in
+  match decl.type_manifest with
+  (* The manifest type of Private abstract data types can still get
+     an approximation using their manifest type. *)
+  | Some body ->
+      (decl.type_params, body, decl.type_expansion_scope)
+  | _ -> raise Not_found
+
+let find_modtype_expansion path env =
+  match (find_modtype path env).mtd_type with
+  | None -> raise Not_found
+  | Some mty -> mty
+
+let rec is_functor_arg path env =
+  match path with
+    Pident id ->
+      begin try Ident.find_same id env.functor_args; true
+      with Not_found -> false
+      end
+  | Pdot (p, _s) -> is_functor_arg p env
+  | Papply _ -> true
+
+(* Copying types associated with values *)
+
+let make_copy_of_types env0 =
+  let memo = Hashtbl.create 16 in
+  let copy t =
+    try
+      Hashtbl.find memo t.id
+    with Not_found ->
+      let t2 = Subst.type_expr Subst.identity t in
+      Hashtbl.add memo t.id t2;
+      t2
+  in
+  let f = function
+    | Val_unbound _ as entry -> entry
+    | Val_bound vda ->
+        let desc = vda.vda_description in
+        let desc = { desc with val_type = copy desc.val_type } in
+        Val_bound { vda with vda_description = desc }
+  in
+  let values =
+    IdTbl.map f env0.values
+  in
+  (fun env ->
+     (*if env.values != env0.values then fatal_error "Env.make_copy_of_types";*)
+     {env with values; summary = Env_copy_types env.summary}
+  )
+
+(* Helper to handle optional substitutions. *)
+
+let may_subst subst_f sub x =
+  match sub with
+  | None -> x
+  | Some sub -> subst_f sub x
+
+(* Iter on an environment (ignoring the body of functors and
+   not yet evaluated structures) *)
+
+type iter_cont = unit -> unit
+let iter_env_cont = ref []
+
+let rec scrape_alias_for_visit env (sub : Subst.t option) mty =
+  match mty with
+  | Mty_alias path ->
+      begin match may_subst Subst.module_path sub path with
+      | Pident id
+        when Ident.persistent id
+          && not (Persistent_env.looked_up !persistent_env (Ident.name id)) ->
+          false
+      | path -> (* PR#6600: find_module may raise Not_found *)
+          try scrape_alias_for_visit env sub (find_module path env).md_type
+          with Not_found -> false
+      end
+  | _ -> true
+
+let iter_env wrap proj1 proj2 f env () =
+  IdTbl.iter wrap (fun id x -> f (Pident id) x) (proj1 env);
+  let rec iter_components path path' mcomps =
+    let cont () =
+      let visit =
+        match Lazy_backtrack.get_arg mcomps.comps with
+        | None -> true
+        | Some { cm_mty; cm_freshening_subst; _ } ->
+            scrape_alias_for_visit env cm_freshening_subst cm_mty
+      in
+      if not visit then () else
+      match get_components mcomps with
+        Structure_comps comps ->
+          NameMap.iter
+            (fun s d -> f (Pdot (path, s)) (Pdot (path', s), d))
+            (proj2 comps);
+          NameMap.iter
+            (fun s mda ->
+              iter_components
+                (Pdot (path, s)) (Pdot (path', s)) mda.mda_components)
+            comps.comp_modules
+      | Functor_comps _ -> ()
+    in iter_env_cont := (path, cont) :: !iter_env_cont
+  in
+  IdTbl.iter wrap_module
+    (fun id (path, entry) ->
+       match entry with
+       | Mod_unbound _ -> ()
+       | Mod_local data ->
+           iter_components (Pident id) path data.mda_components
+       | Mod_persistent ->
+           let modname = Ident.name id in
+           match Persistent_env.find_in_cache !persistent_env modname with
+           | None -> ()
+           | Some data ->
+               iter_components (Pident id) path data.mda_components)
+    env.modules
+
+let run_iter_cont l =
+  iter_env_cont := [];
+  List.iter (fun c -> c ()) l;
+  let cont = List.rev !iter_env_cont in
+  iter_env_cont := [];
+  cont
+
+let iter_types f =
+  iter_env wrap_identity (fun env -> env.types) (fun sc -> sc.comp_types)
+    (fun p1 (p2, tda) -> f p1 (p2, tda.tda_declaration))
+
+let same_types env1 env2 =
+  env1.types == env2.types && env1.modules == env2.modules
+
+let used_persistent () =
+  Persistent_env.fold !persistent_env
+    (fun s _m r -> Concr.add s r)
+    Concr.empty
+
+let find_all_comps wrap proj s (p, mda) =
+  match get_components mda.mda_components with
+    Functor_comps _ -> []
+  | Structure_comps comps ->
+      try
+        let c = NameMap.find s (proj comps) in
+        [Pdot(p,s), wrap c]
+      with Not_found -> []
+
+let rec find_shadowed_comps path env =
+  match path with
+  | Pident id ->
+      List.filter_map
+        (fun (p, data) ->
+           match data with
+           | Mod_local x -> Some (p, x)
+           | Mod_unbound _ | Mod_persistent -> None)
+        (IdTbl.find_all wrap_module (Ident.name id) env.modules)
+  | Pdot (p, s) ->
+      let l = find_shadowed_comps p env in
+      let l' =
+        List.map
+          (find_all_comps wrap_identity
+             (fun comps -> comps.comp_modules) s) l
+      in
+      List.flatten l'
+  | Papply _ -> []
+
+let find_shadowed wrap proj1 proj2 path env =
+  match path with
+    Pident id ->
+      IdTbl.find_all wrap (Ident.name id) (proj1 env)
+  | Pdot (p, s) ->
+      let l = find_shadowed_comps p env in
+      let l' = List.map (find_all_comps wrap proj2 s) l in
+      List.flatten l'
+  | Papply _ -> []
+
+let find_shadowed_types path env =
+  List.map fst
+    (find_shadowed wrap_identity
+       (fun env -> env.types) (fun comps -> comps.comp_types) path env)
+
+(* Expand manifest module type names at the top of the given module type *)
+
+let rec scrape_alias env sub ?path mty =
+  match mty, path with
+    Mty_ident _, _ ->
+      let p =
+        match may_subst (Subst.modtype Keep) sub mty with
+        | Mty_ident p -> p
+        | _ -> assert false (* only [Mty_ident]s in [sub] *)
+      in
+      begin try
+        scrape_alias env sub (find_modtype_expansion p env) ?path
+      with Not_found ->
+        mty
+      end
+  | Mty_alias path, _ ->
+      let path = may_subst Subst.module_path sub path in
+      begin try
+        scrape_alias env sub (find_module path env).md_type ~path
+      with Not_found ->
+        (*Location.prerr_warning Location.none
+          (Warnings.No_cmi_file (Path.name path));*)
+        mty
+      end
+  | mty, Some path ->
+      !strengthen ~aliasable:true env mty path
+  | _ -> mty
+
+(* Given a signature and a root path, prefix all idents in the signature
+   by the root path and build the corresponding substitution. *)
+
+let prefix_idents root freshening_sub prefixing_sub sg =
+  let refresh id add_fn = function
+    | None -> id, None
+    | Some sub ->
+      let id' = Ident.rename id in
+      id', Some (add_fn id (Pident id') sub)
+  in
+  let rec prefix_idents root items_and_paths freshening_sub prefixing_sub =
+    function
+    | [] -> (List.rev items_and_paths, freshening_sub, prefixing_sub)
+    | Sig_value(id, _, _) as item :: rem ->
+      let p = Pdot(root, Ident.name id) in
+      prefix_idents root
+        ((item, p) :: items_and_paths) freshening_sub prefixing_sub rem
+    | Sig_type(id, td, rs, vis) :: rem ->
+      let p = Pdot(root, Ident.name id) in
+      let id', freshening_sub = refresh id Subst.add_type freshening_sub in
+      prefix_idents root
+        ((Sig_type(id', td, rs, vis), p) :: items_and_paths)
+        freshening_sub
+        (Subst.add_type id' p prefixing_sub)
+        rem
+    | Sig_typext(id, ec, es, vis) :: rem ->
+      let p = Pdot(root, Ident.name id) in
+      let id', freshening_sub = refresh id Subst.add_type freshening_sub in
+      (* we extend the substitution in case of an inlined record *)
+      prefix_idents root
+        ((Sig_typext(id', ec, es, vis), p) :: items_and_paths)
+        freshening_sub
+        (Subst.add_type id' p prefixing_sub)
+        rem
+    | Sig_module(id, pres, md, rs, vis) :: rem ->
+      let p = Pdot(root, Ident.name id) in
+      let id', freshening_sub = refresh id Subst.add_module freshening_sub in
+      prefix_idents root
+        ((Sig_module(id', pres, md, rs, vis), p) :: items_and_paths)
+        freshening_sub
+        (Subst.add_module id' p prefixing_sub)
+        rem
+    | Sig_modtype(id, mtd, vis) :: rem ->
+      let p = Pdot(root, Ident.name id) in
+      let id', freshening_sub =
+        refresh id (fun i p s -> Subst.add_modtype i (Mty_ident p) s)
+          freshening_sub
+      in
+      prefix_idents root
+        ((Sig_modtype(id', mtd, vis), p) :: items_and_paths)
+        freshening_sub
+        (Subst.add_modtype id' (Mty_ident p) prefixing_sub)
+        rem
+    | Sig_class(id, cd, rs, vis) :: rem ->
+      (* pretend this is a type, cf. PR#6650 *)
+      let p = Pdot(root, Ident.name id) in
+      let id', freshening_sub = refresh id Subst.add_type freshening_sub in
+      prefix_idents root
+        ((Sig_class(id', cd, rs, vis), p) :: items_and_paths)
+        freshening_sub
+        (Subst.add_type id' p prefixing_sub)
+        rem
+    | Sig_class_type(id, ctd, rs, vis) :: rem ->
+      let p = Pdot(root, Ident.name id) in
+      let id', freshening_sub = refresh id Subst.add_type freshening_sub in
+      prefix_idents root
+        ((Sig_class_type(id', ctd, rs, vis), p) :: items_and_paths)
+        freshening_sub
+        (Subst.add_type id' p prefixing_sub)
+        rem
+  in
+  prefix_idents root [] freshening_sub prefixing_sub sg
+
+(* Compute structure descriptions *)
+
+let add_to_tbl id decl tbl =
+  let decls = try NameMap.find id tbl with Not_found -> [] in
+  NameMap.add id (decl :: decls) tbl
+
+let value_declaration_address (_ : t) id decl =
+  match decl.val_kind with
+  | Val_prim _ -> Lazy_backtrack.create_failed Not_found
+  | _ -> Lazy_backtrack.create_forced (Aident id)
+
+let extension_declaration_address (_ : t) id (_ : extension_constructor) =
+  Lazy_backtrack.create_forced (Aident id)
+
+let class_declaration_address (_ : t) id (_ : class_declaration) =
+  Lazy_backtrack.create_forced (Aident id)
+
+let module_declaration_address env id presence md =
+  match presence with
+  | Mp_absent -> begin
+      match md.md_type with
+      | Mty_alias path -> Lazy_backtrack.create (ModAlias {env; path})
+      | _ -> assert false
+    end
+  | Mp_present ->
+      Lazy_backtrack.create_forced (Aident id)
+
+let is_identchar c =
+  (* This should be kept in sync with the [identchar_latin1] character class
+     in [lexer.mll] *)
+  match c with
+  | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214'
+  | '\216'..'\246' | '\248'..'\255' | '\'' | '0'..'9' ->
+    true
+  | _ ->
+    false
+
+let rec components_of_module_maker
+          {cm_env; cm_freshening_subst; cm_prefixing_subst;
+           cm_path; cm_addr; cm_mty} : _ result =
+  match scrape_alias cm_env cm_freshening_subst cm_mty with
+    Mty_signature sg ->
+      let c =
+        { comp_values = NameMap.empty;
+          comp_constrs = NameMap.empty;
+          comp_labels = NameMap.empty; comp_types = NameMap.empty;
+          comp_modules = NameMap.empty; comp_modtypes = NameMap.empty;
+          comp_classes = NameMap.empty; comp_cltypes = NameMap.empty }
+      in
+      let items_and_paths, freshening_sub, prefixing_sub =
+        prefix_idents cm_path cm_freshening_subst cm_prefixing_subst sg
+      in
+      let env = ref cm_env in
+      let pos = ref 0 in
+      let next_address () =
+        let addr : address_unforced =
+          Projection { parent = cm_addr; pos = !pos }
+        in
+        incr pos;
+        Lazy_backtrack.create addr
+      in
+      let sub = may_subst Subst.compose freshening_sub prefixing_sub in
+      List.iter (fun (item, path) ->
+        match item with
+          Sig_value(id, decl, _) ->
+            let decl' = Subst.value_description sub decl in
+            let addr =
+              match decl.val_kind with
+              | Val_prim _ -> Lazy_backtrack.create_failed Not_found
+              | _ -> next_address ()
+            in
+            let vda = { vda_description = decl'; vda_address = addr } in
+            c.comp_values <- NameMap.add (Ident.name id) vda c.comp_values;
+        | Sig_type(id, decl, _, _) ->
+            let fresh_decl =
+              may_subst Subst.type_declaration freshening_sub decl
+            in
+            let final_decl = Subst.type_declaration prefixing_sub fresh_decl in
+            Btype.set_row_name final_decl
+              (Subst.type_path prefixing_sub (Path.Pident id));
+            let descrs =
+              match decl.type_kind with
+              | Type_variant (_,repr) ->
+                  let cstrs = List.map snd
+                    (Datarepr.constructors_of_type path final_decl
+                        ~current_unit:(get_unit_name ()))
+                  in
+                  List.iter
+                    (fun descr ->
+                      let cda = {
+                        cda_description = descr;
+                        cda_address = None }
+                      in
+                      c.comp_constrs <-
+                        add_to_tbl descr.cstr_name cda c.comp_constrs
+                    ) cstrs;
+                 Type_variant (cstrs, repr)
+              | Type_record (_, repr) ->
+                  let lbls = List.map snd
+                    (Datarepr.labels_of_type path final_decl)
+                  in
+                  List.iter
+                    (fun descr ->
+                      c.comp_labels <-
+                        add_to_tbl descr.lbl_name descr c.comp_labels)
+                    lbls;
+                  Type_record (lbls, repr)
+              | Type_abstract -> Type_abstract
+              | Type_open -> Type_open
+            in
+            let tda =
+              { tda_declaration = final_decl;
+                tda_descriptions = descrs; }
+            in
+            c.comp_types <- NameMap.add (Ident.name id) tda c.comp_types;
+            env := store_type_infos id fresh_decl !env
+        | Sig_typext(id, ext, _, _) ->
+            let ext' = Subst.extension_constructor sub ext in
+            let descr =
+              Datarepr.extension_descr ~current_unit:(get_unit_name ()) path
+                ext'
+            in
+            let addr = next_address () in
+            let cda = { cda_description = descr; cda_address = Some addr } in
+            c.comp_constrs <- add_to_tbl (Ident.name id) cda c.comp_constrs
+        | Sig_module(id, pres, md, _, _) ->
+            let md' =
+              (* The prefixed items get the same scope as [cm_path], which is
+                 the prefix. *)
+              Lazy_backtrack.create
+                (sub, Subst.Rescope (Path.scope cm_path), md)
+            in
+            let addr =
+              match pres with
+              | Mp_absent -> begin
+                  match md.md_type with
+                  | Mty_alias p ->
+                      let path = may_subst Subst.module_path freshening_sub p in
+                      Lazy_backtrack.create (ModAlias {env = !env; path})
+                  | _ -> assert false
+                end
+              | Mp_present -> next_address ()
+            in
+            let alerts =
+              Builtin_attributes.alerts_of_attrs md.md_attributes
+            in
+            let comps =
+              components_of_module ~alerts ~uid:md.md_uid !env freshening_sub
+                prefixing_sub path addr md.md_type
+            in
+            let mda =
+              { mda_declaration = md';
+                mda_components = comps;
+                mda_address = addr }
+            in
+            c.comp_modules <-
+              NameMap.add (Ident.name id) mda c.comp_modules;
+            env :=
+              store_module ~freshening_sub ~check:None id addr pres md !env
+        | Sig_modtype(id, decl, _) ->
+            let fresh_decl =
+              (* the fresh_decl is only going in the local temporary env, and
+                 shouldn't be used for anything. So we make the items local. *)
+              may_subst (Subst.modtype_declaration Make_local) freshening_sub
+                decl
+            in
+            let final_decl =
+              (* The prefixed items get the same scope as [cm_path], which is
+                 the prefix. *)
+              Subst.modtype_declaration (Rescope (Path.scope cm_path))
+                prefixing_sub fresh_decl
+            in
+            c.comp_modtypes <-
+              NameMap.add (Ident.name id) final_decl c.comp_modtypes;
+            env := store_modtype id fresh_decl !env
+        | Sig_class(id, decl, _, _) ->
+            let decl' = Subst.class_declaration sub decl in
+            let addr = next_address () in
+            let clda = { clda_declaration = decl'; clda_address = addr } in
+            c.comp_classes <- NameMap.add (Ident.name id) clda c.comp_classes
+        | Sig_class_type(id, decl, _, _) ->
+            let decl' = Subst.cltype_declaration sub decl in
+            c.comp_cltypes <-
+              NameMap.add (Ident.name id) decl' c.comp_cltypes)
+        items_and_paths;
+        Ok (Structure_comps c)
+  | Mty_functor(arg, ty_res) ->
+      let sub =
+        may_subst Subst.compose cm_freshening_subst cm_prefixing_subst
+      in
+      let scoping = Subst.Rescope (Path.scope cm_path) in
+        Ok (Functor_comps {
+          (* fcomp_arg and fcomp_res must be prefixed eagerly, because
+             they are interpreted in the outer environment *)
+          fcomp_arg =
+            (match arg with
+            | Unit -> Unit
+            | Named (param, ty_arg) ->
+              Named (param, Subst.modtype scoping sub ty_arg));
+          fcomp_res = Subst.modtype scoping sub ty_res;
+          fcomp_cache = Hashtbl.create 17;
+          fcomp_subst_cache = Hashtbl.create 17 })
+  | Mty_ident _ -> Error No_components_abstract
+  | Mty_alias p -> Error (No_components_alias p)
+
+(* Insertion of bindings by identifier + path *)
+
+and check_usage loc id uid warn tbl =
+  if not loc.Location.loc_ghost &&
+     Uid.for_actual_declaration uid &&
+     Warnings.is_active (warn "")
+  then begin
+    let name = Ident.name id in
+    if Types.Uid.Tbl.mem tbl uid then ()
+    else let used = ref false in
+    Types.Uid.Tbl.add tbl uid (fun () -> used := true);
+    if not (name = "" || name.[0] = '_' || name.[0] = '#')
+    then
+      !add_delayed_check_forward
+        (fun () -> if not !used then Location.prerr_warning loc (warn name))
+  end;
+
+and check_value_name name loc =
+  (* Note: we could also check here general validity of the
+     identifier, to protect against bad identifiers forged by -pp or
+     -ppx preprocessors. *)
+  if String.length name > 0 && not (is_identchar name.[0]) then
+    for i = 1 to String.length name - 1 do
+      if name.[i] = '#' then
+        error (Illegal_value_name(loc, name))
+    done
+
+and store_value ?check id addr decl env =
+  check_value_name (Ident.name id) decl.val_loc;
+  Option.iter
+    (fun f -> check_usage decl.val_loc id decl.val_uid f !value_declarations)
+    check;
+  let vda = { vda_description = decl; vda_address = addr } in
+  { env with
+    values = IdTbl.add id (Val_bound vda) env.values;
+    summary = Env_value(env.summary, id, decl) }
+
+and store_constructor ~check type_decl type_id cstr_id cstr env =
+  if check && not type_decl.type_loc.Location.loc_ghost
+     && Warnings.is_active (Warnings.Unused_constructor ("", Unused))
+  then begin
+    let ty_name = Ident.name type_id in
+    let name = cstr.cstr_name in
+    let loc = cstr.cstr_loc in
+    let k = cstr.cstr_uid in
+    let priv = type_decl.type_private in
+    if not (Types.Uid.Tbl.mem !used_constructors k) then begin
+      let used = constructor_usages () in
+      Types.Uid.Tbl.add !used_constructors k
+        (add_constructor_usage used);
+      if not (ty_name = "" || ty_name.[0] = '_')
+      then
+        !add_delayed_check_forward
+          (fun () ->
+            Option.iter
+              (fun complaint ->
+                 if not (is_in_signature env) then
+                   Location.prerr_warning loc
+                     (Warnings.Unused_constructor(name, complaint)))
+              (constructor_usage_complaint ~rebind:false priv used));
+    end;
+  end;
+  { env with
+    constrs =
+      TycompTbl.add cstr_id
+        { cda_description = cstr; cda_address = None } env.constrs;
+  }
+
+and store_label ~check type_decl type_id lbl_id lbl env =
+  if check && not type_decl.type_loc.Location.loc_ghost
+     && Warnings.is_active (Warnings.Unused_field ("", Unused))
+  then begin
+    let ty_name = Ident.name type_id in
+    let priv = type_decl.type_private in
+    let name = lbl.lbl_name in
+    let loc = lbl.lbl_loc in
+    let mut = lbl.lbl_mut in
+    let k = lbl.lbl_uid in
+    if not (Types.Uid.Tbl.mem !used_labels k) then
+      let used = label_usages () in
+      Types.Uid.Tbl.add !used_labels k
+        (add_label_usage used);
+      if not (ty_name = "" || ty_name.[0] = '_' || name.[0] = '_')
+      then !add_delayed_check_forward
+          (fun () ->
+            Option.iter
+              (fun complaint ->
+                 if not (is_in_signature env) then
+                   Location.prerr_warning
+                     loc (Warnings.Unused_field(name, complaint)))
+              (label_usage_complaint priv mut used))
+  end;
+  { env with
+    labels = TycompTbl.add lbl_id lbl env.labels;
+  }
+
+and store_type ~check id info env =
+  let loc = info.type_loc in
+  if check then
+    check_usage loc id info.type_uid
+      (fun s -> Warnings.Unused_type_declaration s)
+      !type_declarations;
+  let descrs, env =
+    let path = Pident id in
+    match info.type_kind with
+    | Type_variant (_,repr) ->
+        let constructors = Datarepr.constructors_of_type path info
+                            ~current_unit:(get_unit_name ())
+        in
+        Type_variant (List.map snd constructors, repr),
+        List.fold_left
+          (fun env (cstr_id, cstr) ->
+            store_constructor ~check info id cstr_id cstr env)
+          env constructors
+    | Type_record (_, repr) ->
+        let labels = Datarepr.labels_of_type path info in
+        Type_record (List.map snd labels, repr),
+        List.fold_left
+          (fun env (lbl_id, lbl) ->
+            store_label ~check info id lbl_id lbl env)
+          env labels
+    | Type_abstract -> Type_abstract, env
+    | Type_open -> Type_open, env
+  in
+  let tda = { tda_declaration = info; tda_descriptions = descrs } in
+  { env with
+    types = IdTbl.add id tda env.types;
+    summary = Env_type(env.summary, id, info) }
+
+and store_type_infos id info env =
+  (* Simplified version of store_type that doesn't compute and store
+     constructor and label infos, but simply record the arity and
+     manifest-ness of the type.  Used in components_of_module to
+     keep track of type abbreviations (e.g. type t = float) in the
+     computation of label representations. *)
+  let tda = { tda_declaration = info; tda_descriptions = Type_abstract } in
+  { env with
+    types = IdTbl.add id tda env.types;
+    summary = Env_type(env.summary, id, info) }
+
+and store_extension ~check ~rebind id addr ext env =
+  let loc = ext.ext_loc in
+  let cstr =
+    Datarepr.extension_descr ~current_unit:(get_unit_name ()) (Pident id) ext
+  in
+  let cda = { cda_description = cstr; cda_address = Some addr } in
+  if check && not loc.Location.loc_ghost &&
+    Warnings.is_active (Warnings.Unused_extension ("", false, Unused))
+  then begin
+    let priv = ext.ext_private in
+    let is_exception = Path.same ext.ext_type_path Predef.path_exn in
+    let name = cstr.cstr_name in
+    let k = cstr.cstr_uid in
+    if not (Types.Uid.Tbl.mem !used_constructors k) then begin
+      let used = constructor_usages () in
+      Types.Uid.Tbl.add !used_constructors k
+        (add_constructor_usage used);
+      !add_delayed_check_forward
+         (fun () ->
+           Option.iter
+             (fun complaint ->
+                if not (is_in_signature env) then
+                  Location.prerr_warning loc
+                    (Warnings.Unused_extension
+                       (name, is_exception, complaint)))
+             (constructor_usage_complaint ~rebind priv used))
+    end;
+  end;
+  { env with
+    constrs = TycompTbl.add id cda env.constrs;
+    summary = Env_extension(env.summary, id, ext) }
+
+and store_module ~check ~freshening_sub id addr presence md env =
+  let loc = md.md_loc in
+  Option.iter
+    (fun f -> check_usage loc id md.md_uid f !module_declarations) check;
+  let alerts = Builtin_attributes.alerts_of_attrs md.md_attributes in
+  let module_decl_lazy =
+    match freshening_sub with
+    | None -> Lazy_backtrack.create_forced md
+    | Some s -> Lazy_backtrack.create (s, Subst.Rescope (Ident.scope id), md)
+  in
+  let comps =
+    components_of_module ~alerts ~uid:md.md_uid
+      env freshening_sub Subst.identity (Pident id) addr md.md_type
+  in
+  let mda =
+    { mda_declaration = module_decl_lazy;
+      mda_components = comps;
+      mda_address = addr }
+  in
+  { env with
+    modules = IdTbl.add id (Mod_local mda) env.modules;
+    summary = Env_module(env.summary, id, presence, md) }
+
+and store_modtype id info env =
+  { env with
+    modtypes = IdTbl.add id info env.modtypes;
+    summary = Env_modtype(env.summary, id, info) }
+
+and store_class id addr desc env =
+  let clda = { clda_declaration = desc; clda_address = addr } in
+  { env with
+    classes = IdTbl.add id clda env.classes;
+    summary = Env_class(env.summary, id, desc) }
+
+and store_cltype id desc env =
+  { env with
+    cltypes = IdTbl.add id desc env.cltypes;
+    summary = Env_cltype(env.summary, id, desc) }
+
+let scrape_alias env mty = scrape_alias env None mty
+
+(* Compute the components of a functor application in a path. *)
+
+let components_of_functor_appl ~loc ~f_path ~f_comp ~arg env =
+  try
+    let c = Hashtbl.find f_comp.fcomp_cache arg in
+    c
+  with Not_found ->
+    let p = Papply(f_path, arg) in
+    let sub =
+      match f_comp.fcomp_arg with
+      | Unit
+      | Named (None, _) -> Subst.identity
+      | Named (Some param, _) -> Subst.add_module param arg Subst.identity
+    in
+    (* we have to apply eagerly instead of passing sub to [components_of_module]
+       because of the call to [check_well_formed_module]. *)
+    let mty = Subst.modtype (Rescope (Path.scope p)) sub f_comp.fcomp_res in
+    let addr = Lazy_backtrack.create_failed Not_found in
+    !check_well_formed_module env loc
+      ("the signature of " ^ Path.name p) mty;
+    let comps =
+      components_of_module ~alerts:Misc.Stdlib.String.Map.empty
+        ~uid:Uid.internal_not_actually_unique
+        (*???*)
+        env None Subst.identity p addr mty
+    in
+    Hashtbl.add f_comp.fcomp_cache arg comps;
+    comps
+
+(* Define forward functions *)
+
+let _ =
+  components_of_functor_appl' := components_of_functor_appl;
+  components_of_module_maker' := components_of_module_maker
+
+(* Insertion of bindings by identifier *)
+
+let add_functor_arg id env =
+  {env with
+   functor_args = Ident.add id () env.functor_args;
+   summary = Env_functor_arg (env.summary, id)}
+
+let add_value ?check id desc env =
+  let addr = value_declaration_address env id desc in
+  store_value ?check id addr desc env
+
+let add_type ~check id info env =
+  store_type ~check id info env
+
+and add_extension ~check ~rebind id ext env =
+  let addr = extension_declaration_address env id ext in
+  store_extension ~check ~rebind id addr ext env
+
+and add_module_declaration ?(arg=false) ~check id presence md env =
+  let check =
+    if not check then
+      None
+    else if arg && is_in_signature env then
+      Some (fun s -> Warnings.Unused_functor_parameter s)
+    else
+      Some (fun s -> Warnings.Unused_module s)
+  in
+  let addr = module_declaration_address env id presence md in
+  let env = store_module ~freshening_sub:None ~check id addr presence md env in
+  if arg then add_functor_arg id env else env
+
+and add_modtype id info env =
+  store_modtype id info env
+
+and add_class id ty env =
+  let addr = class_declaration_address env id ty in
+  store_class id addr ty env
+
+and add_cltype id ty env =
+  store_cltype id ty env
+
+let add_module ?arg id presence mty env =
+  add_module_declaration ~check:false ?arg id presence (md mty) env
+
+let add_local_type path info env =
+  { env with
+    local_constraints = Path.Map.add path info env.local_constraints }
+
+
+(* Insertion of bindings by name *)
+
+let enter_value ?check name desc env =
+  let id = Ident.create_local name in
+  let addr = value_declaration_address env id desc in
+  let env = store_value ?check id addr desc env in
+  (id, env)
+
+let enter_type ~scope name info env =
+  let id = Ident.create_scoped ~scope name in
+  let env = store_type ~check:true id info env in
+  (id, env)
+
+let enter_extension ~scope ~rebind name ext env =
+  let id = Ident.create_scoped ~scope name in
+  let addr = extension_declaration_address env id ext in
+  let env = store_extension ~check:true ~rebind id addr ext env in
+  (id, env)
+
+let enter_module_declaration ~scope ?arg s presence md env =
+  let id = Ident.create_scoped ~scope s in
+  (id, add_module_declaration ?arg ~check:true id presence md env)
+
+let enter_modtype ~scope name mtd env =
+  let id = Ident.create_scoped ~scope name in
+  let env = store_modtype id mtd env in
+  (id, env)
+
+let enter_class ~scope name desc env =
+  let id = Ident.create_scoped ~scope name in
+  let addr = class_declaration_address env id desc in
+  let env = store_class id addr desc env in
+  (id, env)
+
+let enter_cltype ~scope name desc env =
+  let id = Ident.create_scoped ~scope name in
+  let env = store_cltype id desc env in
+  (id, env)
+
+let enter_module ~scope ?arg s presence mty env =
+  enter_module_declaration ~scope ?arg s presence (md mty) env
+
+(* Insertion of all components of a signature *)
+
+let add_item comp env =
+  match comp with
+    Sig_value(id, decl, _)    -> add_value id decl env
+  | Sig_type(id, decl, _, _)  -> add_type ~check:false id decl env
+  | Sig_typext(id, ext, _, _) ->
+      add_extension ~check:false ~rebind:false id ext env
+  | Sig_module(id, presence, md, _, _) ->
+      add_module_declaration ~check:false id presence md env
+  | Sig_modtype(id, decl, _)  -> add_modtype id decl env
+  | Sig_class(id, decl, _, _) -> add_class id decl env
+  | Sig_class_type(id, decl, _, _) -> add_cltype id decl env
+
+let rec add_signature sg env =
+  match sg with
+    [] -> env
+  | comp :: rem -> add_signature rem (add_item comp env)
+
+let enter_signature ~scope sg env =
+  let sg = Subst.signature (Rescope scope) Subst.identity sg in
+  sg, add_signature sg env
+
+(* Add "unbound" bindings *)
+
+let enter_unbound_value name reason env =
+  let id = Ident.create_local name in
+  { env with
+    values = IdTbl.add id (Val_unbound reason) env.values;
+    summary = Env_value_unbound(env.summary, name, reason) }
+
+let enter_unbound_module name reason env =
+  let id = Ident.create_local name in
+  { env with
+    modules = IdTbl.add id (Mod_unbound reason) env.modules;
+    summary = Env_module_unbound(env.summary, name, reason) }
+
+(* Open a signature path *)
+
+let add_components slot root env0 comps =
+  let add_l w comps env0 =
+    TycompTbl.add_open slot w root comps env0
+  in
+  let add w comps env0 = IdTbl.add_open slot w root comps env0 in
+  let constrs =
+    add_l (fun x -> `Constructor x) comps.comp_constrs env0.constrs
+  in
+  let labels =
+    add_l (fun x -> `Label x) comps.comp_labels env0.labels
+  in
+  let values =
+    add (fun x -> `Value x) comps.comp_values env0.values
+  in
+  let types =
+    add (fun x -> `Type x) comps.comp_types env0.types
+  in
+  let modtypes =
+    add (fun x -> `Module_type x) comps.comp_modtypes env0.modtypes
+  in
+  let classes =
+    add (fun x -> `Class x) comps.comp_classes env0.classes
+  in
+  let cltypes =
+    add (fun x -> `Class_type x) comps.comp_cltypes env0.cltypes
+  in
+  let modules =
+    add (fun x -> `Module x) comps.comp_modules env0.modules
+  in
+  { env0 with
+    summary = Env_open(env0.summary, root);
+    constrs;
+    labels;
+    values;
+    types;
+    modtypes;
+    classes;
+    cltypes;
+    modules;
+  }
+
+let open_signature slot root env0 : (_,_) result =
+  match get_components_res (find_module_components root env0) with
+  | Error _ -> Error `Not_found
+  | exception Not_found -> Error `Not_found
+  | Ok (Functor_comps _) -> Error `Functor
+  | Ok (Structure_comps comps) ->
+    Ok (add_components slot root env0 comps)
+
+let remove_last_open root env0 =
+  let rec filter_summary summary =
+    match summary with
+      Env_empty -> raise Exit
+    | Env_open (s, p) ->
+        if Path.same p root then s else raise Exit
+    | Env_value _
+    | Env_type _
+    | Env_extension _
+    | Env_module _
+    | Env_modtype _
+    | Env_class _
+    | Env_cltype _
+    | Env_functor_arg _
+    | Env_constraints _
+    | Env_persistent _
+    | Env_copy_types _
+    | Env_value_unbound _
+    | Env_module_unbound _ ->
+        map_summary filter_summary summary
+  in
+  match filter_summary env0.summary with
+  | summary ->
+      let rem_l tbl = TycompTbl.remove_last_open root tbl
+      and rem tbl = IdTbl.remove_last_open root tbl in
+      Some { env0 with
+             summary;
+             constrs = rem_l env0.constrs;
+             labels = rem_l env0.labels;
+             values = rem env0.values;
+             types = rem env0.types;
+             modtypes = rem env0.modtypes;
+             classes = rem env0.classes;
+             cltypes = rem env0.cltypes;
+             modules = rem env0.modules; }
+  | exception Exit ->
+      None
+
+(* Open a signature from a file *)
+
+let open_pers_signature name env =
+  match open_signature None (Pident(Ident.create_persistent name)) env with
+  | (Ok _ | Error `Not_found as res) -> res
+  | Error `Functor -> assert false
+        (* a compilation unit cannot refer to a functor *)
+
+let open_signature
+    ?(used_slot = ref false)
+    ?(loc = Location.none) ?(toplevel = false)
+    ovf root env =
+  let unused =
+    match ovf with
+    | Asttypes.Fresh -> Warnings.Unused_open (Path.name root)
+    | Asttypes.Override -> Warnings.Unused_open_bang (Path.name root)
+  in
+  let warn_unused =
+    Warnings.is_active unused
+  and warn_shadow_id =
+    Warnings.is_active (Warnings.Open_shadow_identifier ("", ""))
+  and warn_shadow_lc =
+    Warnings.is_active (Warnings.Open_shadow_label_constructor ("",""))
+  in
+  if not toplevel && not loc.Location.loc_ghost
+     && (warn_unused || warn_shadow_id || warn_shadow_lc)
+  then begin
+    let used = used_slot in
+    if warn_unused then
+      !add_delayed_check_forward
+        (fun () ->
+           if not !used then begin
+             used := true;
+             Location.prerr_warning loc unused
+           end
+        );
+    let shadowed = ref [] in
+    let slot s b =
+      begin match check_shadowing env b with
+      | Some kind when
+          ovf = Asttypes.Fresh && not (List.mem (kind, s) !shadowed) ->
+          shadowed := (kind, s) :: !shadowed;
+          let w =
+            match kind with
+            | "label" | "constructor" ->
+                Warnings.Open_shadow_label_constructor (kind, s)
+            | _ -> Warnings.Open_shadow_identifier (kind, s)
+          in
+          Location.prerr_warning loc w
+      | _ -> ()
+      end;
+      used := true
+    in
+    open_signature (Some slot) root env
+  end
+  else open_signature None root env
+
+(* Read a signature from a file *)
+let read_signature modname filename =
+  let mda = read_pers_mod modname filename in
+  let md = Lazy_backtrack.force subst_modtype_maker mda.mda_declaration in
+  match md.md_type with
+  | Mty_signature sg -> sg
+  | Mty_ident _ | Mty_functor _ | Mty_alias _ -> assert false
+
+let is_identchar_latin1 = function
+  | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214' | '\216'..'\246'
+  | '\248'..'\255' | '\'' | '0'..'9' -> true
+  | _ -> false
+
+let unit_name_of_filename fn =
+  match Filename.extension fn with
+  | ".cmi" -> begin
+      let unit =
+        String.capitalize_ascii (Filename.remove_extension fn)
+      in
+      if String.for_all is_identchar_latin1 unit then
+        Some unit
+      else
+        None
+    end
+  | _ -> None
+
+let persistent_structures_of_dir dir =
+  Load_path.Dir.files dir
+  |> List.to_seq
+  |> Seq.filter_map unit_name_of_filename
+  |> String.Set.of_seq
+
+(* Save a signature to a file *)
+let save_signature_with_transform cmi_transform ~alerts sg modname filename =
+  Btype.cleanup_abbrev ();
+  Subst.reset_for_saving ();
+  let sg = Subst.signature Make_local (Subst.for_saving Subst.identity) sg in
+  let cmi =
+    Persistent_env.make_cmi !persistent_env modname sg alerts
+    |> cmi_transform in
+  let pm = save_sign_of_cmi
+      { Persistent_env.Persistent_signature.cmi; filename } in
+  Persistent_env.save_cmi !persistent_env
+    { Persistent_env.Persistent_signature.filename; cmi } pm;
+  cmi
+
+let save_signature ~alerts sg modname filename =
+  save_signature_with_transform (fun cmi -> cmi)
+    ~alerts sg modname filename
+
+let save_signature_with_imports ~alerts sg modname filename imports =
+  let with_imports cmi = { cmi with cmi_crcs = imports } in
+  save_signature_with_transform with_imports
+    ~alerts sg modname filename
+
+(* Make the initial environment *)
+let (initial_safe_string, initial_unsafe_string) =
+  Predef.build_initial_env
+    (add_type ~check:false)
+    (add_extension ~check:false ~rebind:false)
+    empty
+
+(* Tracking usage *)
+
+let mark_module_used uid =
+  match Types.Uid.Tbl.find !module_declarations uid with
+  | mark -> mark ()
+  | exception Not_found -> ()
+
+let mark_modtype_used _uid = ()
+
+let mark_value_used uid =
+  match Types.Uid.Tbl.find !value_declarations uid with
+  | mark -> mark ()
+  | exception Not_found -> ()
+
+let mark_type_used uid =
+  match Types.Uid.Tbl.find !type_declarations uid with
+  | mark -> mark ()
+  | exception Not_found -> ()
+
+let mark_type_path_used env path =
+  match find_type path env with
+  | decl -> mark_type_used decl.type_uid
+  | exception Not_found -> ()
+
+let mark_constructor_used usage cd =
+  match Types.Uid.Tbl.find !used_constructors cd.cd_uid with
+  | mark -> mark usage
+  | exception Not_found -> ()
+
+let mark_extension_used usage ext =
+  match Types.Uid.Tbl.find !used_constructors ext.ext_uid with
+  | mark -> mark usage
+  | exception Not_found -> ()
+
+let mark_label_used usage ld =
+  match Types.Uid.Tbl.find !used_labels ld.ld_uid with
+  | mark -> mark usage
+  | exception Not_found -> ()
+
+let mark_constructor_description_used usage env cstr =
+  let ty_path =
+    match repr cstr.cstr_res with
+    | {desc=Tconstr(path, _, _)} -> path
+    | _ -> assert false
+  in
+  mark_type_path_used env ty_path;
+  match Types.Uid.Tbl.find !used_constructors cstr.cstr_uid with
+  | mark -> mark usage
+  | exception Not_found -> ()
+
+let mark_label_description_used usage env lbl =
+  let ty_path =
+    match repr lbl.lbl_res with
+    | {desc=Tconstr(path, _, _)} -> path
+    | _ -> assert false
+  in
+  mark_type_path_used env ty_path;
+  match Types.Uid.Tbl.find !used_labels lbl.lbl_uid with
+  | mark -> mark usage
+  | exception Not_found -> ()
+
+let mark_class_used uid =
+  match Types.Uid.Tbl.find !type_declarations uid with
+  | mark -> mark ()
+  | exception Not_found -> ()
+
+let mark_cltype_used uid =
+  match Types.Uid.Tbl.find !type_declarations uid with
+  | mark -> mark ()
+  | exception Not_found -> ()
+
+let set_value_used_callback vd callback =
+  Types.Uid.Tbl.add !value_declarations vd.val_uid callback
+
+let set_type_used_callback td callback =
+  if Uid.for_actual_declaration td.type_uid then
+    let old =
+      try Types.Uid.Tbl.find !type_declarations td.type_uid
+      with Not_found -> ignore
+    in
+    Types.Uid.Tbl.replace !type_declarations td.type_uid
+      (fun () -> callback old)
+
+(* Lookup by name *)
+
+let may_lookup_error report_errors loc env err =
+  if report_errors then lookup_error loc env err
+  else raise Not_found
+
+let report_module_unbound ~errors ~loc env reason =
+  match reason with
+  | Mod_unbound_illegal_recursion ->
+      (* see #5965 *)
+    may_lookup_error errors loc env Illegal_reference_to_recursive_module
+
+let report_value_unbound ~errors ~loc env reason lid =
+  match reason with
+  | Val_unbound_instance_variable ->
+      may_lookup_error errors loc env (Masked_instance_variable lid)
+  | Val_unbound_self ->
+      may_lookup_error errors loc env (Masked_self_variable lid)
+  | Val_unbound_ancestor ->
+      may_lookup_error errors loc env (Masked_ancestor_variable lid)
+  | Val_unbound_ghost_recursive rloc ->
+      let show_hint =
+        (* Only display the "missing rec" hint for non-ghost code *)
+        not loc.Location.loc_ghost
+        && not rloc.Location.loc_ghost
+      in
+      let hint =
+        if show_hint then Missing_rec rloc else No_hint
+      in
+      may_lookup_error errors loc env (Unbound_value(lid, hint))
+
+let use_module ~use ~loc path mda =
+  if use then begin
+    let comps = mda.mda_components in
+    mark_module_used comps.uid;
+    Misc.Stdlib.String.Map.iter
+      (fun kind message ->
+         let message = if message = "" then "" else "\n" ^ message in
+         Location.alert ~kind loc
+           (Printf.sprintf "module %s%s" (Path.name path) message)
+      )
+      comps.alerts
+  end
+
+let use_value ~use ~loc path vda =
+  if use then begin
+    let desc = vda.vda_description in
+    mark_value_used desc.val_uid;
+    Builtin_attributes.check_alerts loc desc.val_attributes
+      (Path.name path)
+  end
+
+let use_type ~use ~loc path tda =
+  if use then begin
+    let decl = tda.tda_declaration in
+    mark_type_used decl.type_uid;
+    Builtin_attributes.check_alerts loc decl.type_attributes
+      (Path.name path)
+  end
+
+let use_modtype ~use ~loc path desc =
+  if use then begin
+    mark_modtype_used desc.mtd_uid;
+    Builtin_attributes.check_alerts loc desc.mtd_attributes
+      (Path.name path)
+  end
+
+let use_class ~use ~loc path clda =
+  if use then begin
+    let desc = clda.clda_declaration in
+    mark_class_used desc.cty_uid;
+    Builtin_attributes.check_alerts loc desc.cty_attributes
+      (Path.name path)
+  end
+
+let use_cltype ~use ~loc path desc =
+  if use then begin
+    mark_cltype_used desc.clty_uid;
+    Builtin_attributes.check_alerts loc desc.clty_attributes
+      (Path.name path)
+  end
+
+let use_label ~use ~loc usage env lbl =
+  if use then begin
+    mark_label_description_used usage env lbl;
+    Builtin_attributes.check_alerts loc lbl.lbl_attributes lbl.lbl_name
+  end
+
+let use_constructor_desc ~use ~loc usage env cstr =
+  if use then begin
+    mark_constructor_description_used usage env cstr;
+    Builtin_attributes.check_alerts loc cstr.cstr_attributes cstr.cstr_name
+  end
+
+let use_constructor ~use ~loc usage env cda =
+  use_constructor_desc ~use ~loc usage env cda.cda_description
+
+type _ load =
+  | Load : module_data load
+  | Don't_load : unit load
+
+let lookup_ident_module (type a) (load : a load) ~errors ~use ~loc s env =
+  let path, data =
+    match find_name_module ~mark:use s env.modules with
+    | res -> res
+    | exception Not_found ->
+        may_lookup_error errors loc env (Unbound_module (Lident s))
+  in
+  match data with
+  | Mod_local mda -> begin
+      use_module ~use ~loc path mda;
+      match load with
+      | Load -> path, (mda : a)
+      | Don't_load -> path, (() : a)
+    end
+  | Mod_unbound reason ->
+      report_module_unbound ~errors ~loc env reason
+  | Mod_persistent -> begin
+      match load with
+      | Don't_load ->
+          check_pers_mod ~loc s;
+          path, (() : a)
+      | Load -> begin
+          match find_pers_mod s with
+          | mda ->
+              use_module ~use ~loc path mda;
+              path, (mda : a)
+          | exception Not_found ->
+              may_lookup_error errors loc env (Unbound_module (Lident s))
+        end
+    end
+
+let lookup_ident_value ~errors ~use ~loc name env =
+  match IdTbl.find_name wrap_value ~mark:use name env.values with
+  | (path, Val_bound vda) ->
+      use_value ~use ~loc path vda;
+      path, vda.vda_description
+  | (_, Val_unbound reason) ->
+      report_value_unbound ~errors ~loc env reason (Lident name)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_value (Lident name, No_hint))
+
+let lookup_ident_type ~errors ~use ~loc s env =
+  match IdTbl.find_name wrap_identity ~mark:use s env.types with
+  | (path, data) as res ->
+      use_type ~use ~loc path data;
+      res
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_type (Lident s))
+
+let lookup_ident_modtype ~errors ~use ~loc s env =
+  match IdTbl.find_name wrap_identity ~mark:use s env.modtypes with
+  | (path, data) as res ->
+      use_modtype ~use ~loc path data;
+      res
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_modtype (Lident s))
+
+let lookup_ident_class ~errors ~use ~loc s env =
+  match IdTbl.find_name wrap_identity ~mark:use s env.classes with
+  | (path, clda) ->
+      use_class ~use ~loc path clda;
+      path, clda.clda_declaration
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_class (Lident s))
+
+let lookup_ident_cltype ~errors ~use ~loc s env =
+  match IdTbl.find_name wrap_identity ~mark:use s env.cltypes with
+  | (path, data) as res ->
+      use_cltype ~use ~loc path data;
+      res
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_cltype (Lident s))
+
+let lookup_all_ident_labels ~errors ~use ~loc usage s env =
+  match TycompTbl.find_all ~mark:use s env.labels with
+  | [] -> may_lookup_error errors loc env (Unbound_label (Lident s))
+  | lbls -> begin
+      List.map
+        (fun (lbl, use_fn) ->
+           let use_fn () =
+             use_label ~use ~loc usage env lbl;
+             use_fn ()
+           in
+           (lbl, use_fn))
+        lbls
+    end
+
+let lookup_all_ident_constructors ~errors ~use ~loc usage s env =
+  match TycompTbl.find_all ~mark:use s env.constrs with
+  | [] -> may_lookup_error errors loc env (Unbound_constructor (Lident s))
+  | cstrs ->
+      List.map
+        (fun (cda, use_fn) ->
+           let use_fn () =
+             use_constructor ~use ~loc usage env cda;
+             use_fn ()
+           in
+           (cda.cda_description, use_fn))
+        cstrs
+
+let rec lookup_module_components ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s ->
+      let path, data = lookup_ident_module Load ~errors ~use ~loc s env in
+      path, data.mda_components
+  | Ldot(l, s) ->
+      let path, data = lookup_dot_module ~errors ~use ~loc l s env in
+      path, data.mda_components
+  | Lapply _ as lid ->
+      let f_path, f_comp, arg = lookup_apply ~errors ~use ~loc lid env in
+      let comps =
+        !components_of_functor_appl' ~loc ~f_path ~f_comp ~arg env in
+      Papply (f_path, arg), comps
+
+and lookup_structure_components ~errors ~use ~loc lid env =
+  let path, comps = lookup_module_components ~errors ~use ~loc lid env in
+  match get_components_res comps with
+  | Ok (Structure_comps comps) -> path, comps
+  | Ok (Functor_comps _) ->
+      may_lookup_error errors loc env (Functor_used_as_structure lid)
+  | Error No_components_abstract ->
+      may_lookup_error errors loc env (Abstract_used_as_structure lid)
+  | Error (No_components_alias p) ->
+      may_lookup_error errors loc env (Cannot_scrape_alias(lid, p))
+
+and get_functor_components ~errors ~loc lid env comps =
+  match get_components_res comps with
+  | Ok (Functor_comps fcomps) -> begin
+      match fcomps.fcomp_arg with
+      | Unit -> (* PR#7611 *)
+          may_lookup_error errors loc env (Generative_used_as_applicative lid)
+      | Named (_, arg) -> fcomps, arg
+    end
+  | Ok (Structure_comps _) ->
+      may_lookup_error errors loc env (Structure_used_as_functor lid)
+  | Error No_components_abstract ->
+      may_lookup_error errors loc env (Abstract_used_as_functor lid)
+  | Error (No_components_alias p) ->
+      may_lookup_error errors loc env (Cannot_scrape_alias(lid, p))
+
+and lookup_all_args ~errors ~use ~loc lid0 env =
+  let rec loop_lid_arg args = function
+    | Lident _ | Ldot _ as f_lid ->
+        (f_lid, args)
+    | Lapply (f_lid, arg_lid) ->
+        let arg_path, arg_md = lookup_module ~errors ~use ~loc arg_lid env in
+        loop_lid_arg ((f_lid,arg_path,arg_md.md_type)::args) f_lid
+  in
+  loop_lid_arg [] lid0
+
+and lookup_apply ~errors ~use ~loc lid0 env =
+  let f0_lid, args0 = lookup_all_args ~errors ~use ~loc lid0 env in
+  let args_for_errors = List.map (fun (_,p,mty) -> (p,mty)) args0 in
+  let f0_path, f0_comp =
+    lookup_module_components ~errors ~use ~loc f0_lid env
+  in
+  let check_one_apply ~errors ~loc ~f_lid ~f_comp ~arg_path ~arg_mty env =
+    let f_comp, param_mty =
+      get_functor_components ~errors ~loc f_lid env f_comp
+    in
+    check_functor_appl
+      ~errors ~loc ~lid_whole_app:lid0
+      ~f0_path ~args:args_for_errors ~f_comp
+      ~arg_path ~arg_mty ~param_mty
+      env;
+    arg_path, f_comp
+  in
+  let rec check_apply ~path:f_path ~comp:f_comp = function
+    | [] -> invalid_arg "Env.lookup_apply: empty argument list"
+    | [ f_lid, arg_path, arg_mty ] ->
+        let arg_path, comps =
+          check_one_apply ~errors ~loc ~f_lid ~f_comp
+            ~arg_path ~arg_mty env
+        in
+        f_path, comps, arg_path
+    | (f_lid, arg_path, arg_mty) :: args ->
+        let arg_path, f_comp =
+          check_one_apply ~errors ~loc ~f_lid ~f_comp
+            ~arg_path ~arg_mty env
+        in
+        let comp =
+          !components_of_functor_appl' ~loc ~f_path ~f_comp ~arg:arg_path env
+        in
+        let path = Papply (f_path, arg_path) in
+        check_apply ~path ~comp args
+  in
+  check_apply ~path:f0_path ~comp:f0_comp args0
+
+and lookup_module ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s ->
+      let path, data = lookup_ident_module Load ~errors ~use ~loc s env in
+      let md = Lazy_backtrack.force subst_modtype_maker data.mda_declaration in
+      path, md
+  | Ldot(l, s) ->
+      let path, data = lookup_dot_module ~errors ~use ~loc l s env in
+      let md = Lazy_backtrack.force subst_modtype_maker data.mda_declaration in
+      path, md
+  | Lapply _ as lid ->
+      let path_f, comp_f, path_arg = lookup_apply ~errors ~use ~loc lid env in
+      let md = md (modtype_of_functor_appl comp_f path_f path_arg) in
+      Papply(path_f, path_arg), md
+
+and lookup_dot_module ~errors ~use ~loc l s env =
+  let p, comps = lookup_structure_components ~errors ~use ~loc l env in
+  match NameMap.find s comps.comp_modules with
+  | mda ->
+      let path = Pdot(p, s) in
+      use_module ~use ~loc path mda;
+      (path, mda)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_module (Ldot(l, s)))
+
+let lookup_dot_value ~errors ~use ~loc l s env =
+  let (path, comps) =
+    lookup_structure_components ~errors ~use ~loc l env
+  in
+  match NameMap.find s comps.comp_values with
+  | vda ->
+      let path = Pdot(path, s) in
+      use_value ~use ~loc path vda;
+      (path, vda.vda_description)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_value (Ldot(l, s), No_hint))
+
+let lookup_dot_type ~errors ~use ~loc l s env =
+  let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in
+  match NameMap.find s comps.comp_types with
+  | tda ->
+      let path = Pdot(p, s) in
+      use_type ~use ~loc path tda;
+      (path, tda)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_type (Ldot(l, s)))
+
+let lookup_dot_modtype ~errors ~use ~loc l s env =
+  let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in
+  match NameMap.find s comps.comp_modtypes with
+  | desc ->
+      let path = Pdot(p, s) in
+      use_modtype ~use ~loc path desc;
+      (path, desc)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_modtype (Ldot(l, s)))
+
+let lookup_dot_class ~errors ~use ~loc l s env =
+  let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in
+  match NameMap.find s comps.comp_classes with
+  | clda ->
+      let path = Pdot(p, s) in
+      use_class ~use ~loc path clda;
+      (path, clda.clda_declaration)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_class (Ldot(l, s)))
+
+let lookup_dot_cltype ~errors ~use ~loc l s env =
+  let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in
+  match NameMap.find s comps.comp_cltypes with
+  | desc ->
+      let path = Pdot(p, s) in
+      use_cltype ~use ~loc path desc;
+      (path, desc)
+  | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_cltype (Ldot(l, s)))
+
+let lookup_all_dot_labels ~errors ~use ~loc usage l s env =
+  let (_, comps) = lookup_structure_components ~errors ~use ~loc l env in
+  match NameMap.find s comps.comp_labels with
+  | [] | exception Not_found ->
+      may_lookup_error errors loc env (Unbound_label (Ldot(l, s)))
+  | lbls ->
+      List.map
+        (fun lbl ->
+           let use_fun () = use_label ~use ~loc usage env lbl in
+           (lbl, use_fun))
+        lbls
+
+let lookup_all_dot_constructors ~errors ~use ~loc usage l s env =
+  match l with
+  | Longident.Lident "*predef*" ->
+      (* Hack to support compilation of default arguments *)
+      lookup_all_ident_constructors
+        ~errors ~use ~loc usage s initial_safe_string
+  | _ ->
+      let (_, comps) = lookup_structure_components ~errors ~use ~loc l env in
+      match NameMap.find s comps.comp_constrs with
+      | [] | exception Not_found ->
+          may_lookup_error errors loc env (Unbound_constructor (Ldot(l, s)))
+      | cstrs ->
+          List.map
+            (fun cda ->
+               let use_fun () = use_constructor ~use ~loc usage env cda in
+               (cda.cda_description, use_fun))
+            cstrs
+
+(* General forms of the lookup functions *)
+
+let lookup_module_path ~errors ~use ~loc ~load lid env : Path.t =
+  match lid with
+  | Lident s ->
+      if !Clflags.transparent_modules && not load then
+        fst (lookup_ident_module Don't_load ~errors ~use ~loc s env)
+      else
+        fst (lookup_ident_module Load ~errors ~use ~loc s env)
+  | Ldot(l, s) -> fst (lookup_dot_module ~errors ~use ~loc l s env)
+  | Lapply _ as lid ->
+      let path_f, _comp_f, path_arg = lookup_apply ~errors ~use ~loc lid env in
+      Papply(path_f, path_arg)
+
+let lookup_value ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s -> lookup_ident_value ~errors ~use ~loc s env
+  | Ldot(l, s) -> lookup_dot_value ~errors ~use ~loc l s env
+  | Lapply _ -> assert false
+
+let lookup_type_full ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s -> lookup_ident_type ~errors ~use ~loc s env
+  | Ldot(l, s) -> lookup_dot_type ~errors ~use ~loc l s env
+  | Lapply _ -> assert false
+
+let lookup_type ~errors ~use ~loc lid env =
+  let (path, tda) = lookup_type_full ~errors ~use ~loc lid env in
+  path, tda.tda_declaration
+
+let lookup_modtype ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s -> lookup_ident_modtype ~errors ~use ~loc s env
+  | Ldot(l, s) -> lookup_dot_modtype ~errors ~use ~loc l s env
+  | Lapply _ -> assert false
+
+let lookup_class ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s -> lookup_ident_class ~errors ~use ~loc s env
+  | Ldot(l, s) -> lookup_dot_class ~errors ~use ~loc l s env
+  | Lapply _ -> assert false
+
+let lookup_cltype ~errors ~use ~loc lid env =
+  match lid with
+  | Lident s -> lookup_ident_cltype ~errors ~use ~loc s env
+  | Ldot(l, s) -> lookup_dot_cltype ~errors ~use ~loc l s env
+  | Lapply _ -> assert false
+
+let lookup_all_labels ~errors ~use ~loc usage lid env =
+  match lid with
+  | Lident s -> lookup_all_ident_labels ~errors ~use ~loc usage s env
+  | Ldot(l, s) -> lookup_all_dot_labels ~errors ~use ~loc usage l s env
+  | Lapply _ -> assert false
+
+let lookup_label ~errors ~use ~loc usage lid env =
+  match lookup_all_labels ~errors ~use ~loc usage lid env with
+  | [] -> assert false
+  | (desc, use) :: _ -> use (); desc
+
+let lookup_all_labels_from_type ~use ~loc usage ty_path env =
+  match find_type_descrs ty_path env with
+  | exception Not_found -> []
+  | Type_variant _ | Type_abstract | Type_open -> []
+  | Type_record (lbls, _) ->
+      List.map
+        (fun lbl ->
+           let use_fun () = use_label ~use ~loc usage env lbl in
+           (lbl, use_fun))
+        lbls
+
+let lookup_all_constructors ~errors ~use ~loc usage lid env =
+  match lid with
+  | Lident s -> lookup_all_ident_constructors ~errors ~use ~loc usage s env
+  | Ldot(l, s) -> lookup_all_dot_constructors ~errors ~use ~loc usage l s env
+  | Lapply _ -> assert false
+
+let lookup_constructor ~errors ~use ~loc usage lid env =
+  match lookup_all_constructors ~errors ~use ~loc usage lid env with
+  | [] -> assert false
+  | (desc, use) :: _ -> use (); desc
+
+let lookup_all_constructors_from_type ~use ~loc usage ty_path env =
+  match find_type_descrs ty_path env with
+  | exception Not_found -> []
+  | Type_record _ | Type_abstract | Type_open -> []
+  | Type_variant (cstrs, _) ->
+      List.map
+        (fun cstr ->
+           let use_fun () =
+             use_constructor_desc ~use ~loc usage env cstr
+           in
+           (cstr, use_fun))
+        cstrs
+
+(* Lookup functions that do not mark the item as used or
+   warn if it has alerts, and raise [Not_found] rather
+   than report errors *)
+
+let find_module_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_module ~errors:false ~use:false ~loc lid env
+
+let find_value_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_value ~errors:false ~use:false ~loc lid env
+
+let find_type_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_type ~errors:false ~use:false ~loc lid env
+
+let find_modtype_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_modtype ~errors:false ~use:false ~loc lid env
+
+let find_class_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_class ~errors:false ~use:false ~loc lid env
+
+let find_cltype_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_cltype ~errors:false ~use:false ~loc lid env
+
+let find_constructor_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_constructor ~errors:false ~use:false ~loc Positive lid env
+
+let find_label_by_name lid env =
+  let loc = Location.(in_file !input_name) in
+  lookup_label ~errors:false ~use:false ~loc Projection lid env
+
+(* Ordinary lookup functions *)
+
+let lookup_module_path ?(use=true) ~loc ~load lid env =
+  lookup_module_path ~errors:true ~use ~loc ~load lid env
+
+let lookup_module ?(use=true) ~loc lid env =
+  lookup_module ~errors:true ~use ~loc lid env
+
+let lookup_value ?(use=true) ~loc lid env =
+  check_value_name (Longident.last lid) loc;
+  lookup_value ~errors:true ~use ~loc lid env
+
+let lookup_type ?(use=true) ~loc lid env =
+  lookup_type ~errors:true ~use ~loc lid env
+
+let lookup_modtype ?(use=true) ~loc lid env =
+  lookup_modtype ~errors:true ~use ~loc lid env
+
+let lookup_class ?(use=true) ~loc lid env =
+  lookup_class ~errors:true ~use ~loc lid env
+
+let lookup_cltype ?(use=true) ~loc lid env =
+  lookup_cltype ~errors:true ~use ~loc lid env
+
+let lookup_all_constructors ?(use=true) ~loc usage lid env =
+  match lookup_all_constructors ~errors:true ~use ~loc usage lid env with
+  | exception Error(Lookup_error(loc', env', err)) ->
+      (Error(loc', env', err) : _ result)
+  | cstrs -> Ok cstrs
+
+let lookup_constructor ?(use=true) ~loc lid env =
+  lookup_constructor ~errors:true ~use ~loc lid env
+
+let lookup_all_constructors_from_type ?(use=true) ~loc usage ty_path env =
+  lookup_all_constructors_from_type ~use ~loc usage ty_path env
+
+let lookup_all_labels ?(use=true) ~loc usage lid env =
+  match lookup_all_labels ~errors:true ~use ~loc usage lid env with
+  | exception Error(Lookup_error(loc', env', err)) ->
+      (Error(loc', env', err) : _ result)
+  | lbls -> Ok lbls
+
+let lookup_label ?(use=true) ~loc lid env =
+  lookup_label ~errors:true ~use ~loc lid env
+
+let lookup_all_labels_from_type ?(use=true) ~loc usage ty_path env =
+  lookup_all_labels_from_type ~use ~loc usage ty_path env
+
+let lookup_instance_variable ?(use=true) ~loc name env =
+  match IdTbl.find_name wrap_value ~mark:use name env.values with
+  | (path, Val_bound vda) -> begin
+      let desc = vda.vda_description in
+      match desc.val_kind with
+      | Val_ivar(mut, cl_num) ->
+          use_value ~use ~loc path vda;
+          path, mut, cl_num, desc.val_type
+      | _ ->
+          lookup_error loc env (Not_an_instance_variable name)
+    end
+  | (_, Val_unbound Val_unbound_instance_variable) ->
+      lookup_error loc env (Masked_instance_variable (Lident name))
+  | (_, Val_unbound Val_unbound_self) ->
+      lookup_error loc env (Not_an_instance_variable name)
+  | (_, Val_unbound Val_unbound_ancestor) ->
+      lookup_error loc env (Not_an_instance_variable name)
+  | (_, Val_unbound Val_unbound_ghost_recursive _) ->
+      lookup_error loc env (Unbound_instance_variable name)
+  | exception Not_found ->
+      lookup_error loc env (Unbound_instance_variable name)
+
+(* Checking if a name is bound *)
+
+let bound_module name env =
+  match IdTbl.find_name wrap_module ~mark:false name env.modules with
+  | _ -> true
+  | exception Not_found ->
+      if Current_unit_name.is name then false
+      else begin
+        match find_pers_mod name with
+        | _ -> true
+        | exception Not_found -> false
+      end
+
+let bound wrap proj name env =
+  match IdTbl.find_name wrap ~mark:false name (proj env) with
+  | _ -> true
+  | exception Not_found -> false
+
+let bound_value name env =
+  bound wrap_value (fun env -> env.values) name env
+
+let bound_type name env =
+  bound wrap_identity (fun env -> env.types) name env
+
+let bound_modtype name env =
+  bound wrap_identity (fun env -> env.modtypes) name env
+
+let bound_class name env =
+  bound wrap_identity (fun env -> env.classes) name env
+
+let bound_cltype name env =
+  bound wrap_identity (fun env -> env.cltypes) name env
+
+(* Folding on environments *)
+
+let find_all wrap proj1 proj2 f lid env acc =
+  match lid with
+  | None ->
+      IdTbl.fold_name wrap
+        (fun name (p, data) acc -> f name p data acc)
+        (proj1 env) acc
+  | Some l ->
+      let p, desc =
+        lookup_module_components
+          ~errors:false ~use:false ~loc:Location.none l env
+      in
+      begin match get_components desc with
+      | Structure_comps c ->
+          NameMap.fold
+            (fun s data acc -> f s (Pdot (p, s)) (wrap data) acc)
+            (proj2 c) acc
+      | Functor_comps _ ->
+          acc
+      end
+
+let find_all_simple_list proj1 proj2 f lid env acc =
+  match lid with
+  | None ->
+      TycompTbl.fold_name
+        (fun data acc -> f data acc)
+        (proj1 env) acc
+  | Some l ->
+      let (_p, desc) =
+        lookup_module_components
+          ~errors:false ~use:false ~loc:Location.none l env
+      in
+      begin match get_components desc with
+      | Structure_comps c ->
+          NameMap.fold
+            (fun _s comps acc ->
+               match comps with
+               | [] -> acc
+               | data :: _ -> f data acc)
+            (proj2 c) acc
+      | Functor_comps _ ->
+          acc
+      end
+
+let fold_modules f lid env acc =
+  match lid with
+  | None ->
+      IdTbl.fold_name wrap_module
+        (fun name (p, entry) acc ->
+           match entry with
+           | Mod_unbound _ -> acc
+           | Mod_local mda ->
+               let md =
+                 Lazy_backtrack.force subst_modtype_maker mda.mda_declaration
+               in
+               f name p md acc
+           | Mod_persistent ->
+               match Persistent_env.find_in_cache !persistent_env name with
+               | None -> acc
+               | Some mda ->
+                   let md =
+                     Lazy_backtrack.force subst_modtype_maker
+                       mda.mda_declaration
+                   in
+                   f name p md acc)
+        env.modules
+        acc
+  | Some l ->
+      let p, desc =
+        lookup_module_components
+          ~errors:false ~use:false ~loc:Location.none l env
+      in
+      begin match get_components desc with
+      | Structure_comps c ->
+          NameMap.fold
+            (fun s mda acc ->
+               let md =
+                 Lazy_backtrack.force subst_modtype_maker mda.mda_declaration
+               in
+               f s (Pdot (p, s)) md acc)
+            c.comp_modules
+            acc
+      | Functor_comps _ ->
+          acc
+      end
+
+let fold_values f =
+  find_all wrap_value (fun env -> env.values) (fun sc -> sc.comp_values)
+    (fun k p ve acc ->
+       match ve with
+       | Val_unbound _ -> acc
+       | Val_bound vda -> f k p vda.vda_description acc)
+and fold_constructors f =
+  find_all_simple_list (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
+    (fun cda acc -> f cda.cda_description acc)
+and fold_labels f =
+  find_all_simple_list (fun env -> env.labels) (fun sc -> sc.comp_labels) f
+and fold_types f =
+  find_all wrap_identity
+    (fun env -> env.types) (fun sc -> sc.comp_types)
+    (fun k p tda acc -> f k p tda.tda_declaration acc)
+and fold_modtypes f =
+  find_all wrap_identity
+    (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) f
+and fold_classes f =
+  find_all wrap_identity (fun env -> env.classes) (fun sc -> sc.comp_classes)
+    (fun k p clda acc -> f k p clda.clda_declaration acc)
+and fold_cltypes f =
+  find_all wrap_identity
+    (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) f
+
+let filter_non_loaded_persistent f env =
+  let to_remove =
+    IdTbl.fold_name wrap_module
+      (fun name (_, entry) acc ->
+         match entry with
+         | Mod_local _ -> acc
+         | Mod_unbound _ -> acc
+         | Mod_persistent ->
+             match Persistent_env.find_in_cache !persistent_env name with
+             | Some _ -> acc
+             | None ->
+                 if f (Ident.create_persistent name) then
+                   acc
+                 else
+                   String.Set.add name acc)
+      env.modules
+      String.Set.empty
+  in
+  let remove_ids tbl ids =
+    String.Set.fold
+      (fun name tbl -> IdTbl.remove (Ident.create_persistent name) tbl)
+      ids
+      tbl
+  in
+  let rec filter_summary summary ids =
+    if String.Set.is_empty ids then
+      summary
+    else
+      match summary with
+        Env_persistent (s, id) when String.Set.mem (Ident.name id) ids ->
+          filter_summary s (String.Set.remove (Ident.name id) ids)
+      | Env_empty
+      | Env_value _
+      | Env_type _
+      | Env_extension _
+      | Env_module _
+      | Env_modtype _
+      | Env_class _
+      | Env_cltype _
+      | Env_open _
+      | Env_functor_arg _
+      | Env_constraints _
+      | Env_copy_types _
+      | Env_persistent _
+      | Env_value_unbound _
+      | Env_module_unbound _ ->
+          map_summary (fun s -> filter_summary s ids) summary
+  in
+  { env with
+    modules = remove_ids env.modules to_remove;
+    summary = filter_summary env.summary to_remove;
+  }
+
+(* Return the environment summary *)
+
+let summary env =
+  if Path.Map.is_empty env.local_constraints then env.summary
+  else Env_constraints (env.summary, env.local_constraints)
+
+let last_env = s_ref empty
+let last_reduced_env = s_ref empty
+
+let keep_only_summary env =
+  if !last_env == env then !last_reduced_env
+  else begin
+    let new_env =
+      {
+       empty with
+       summary = env.summary;
+       local_constraints = env.local_constraints;
+       flags = env.flags;
+      }
+    in
+    last_env := env;
+    last_reduced_env := new_env;
+    new_env
+  end
+
+
+let env_of_only_summary env_from_summary env =
+  let new_env = env_from_summary env.summary Subst.identity in
+  { new_env with
+    local_constraints = env.local_constraints;
+    flags = env.flags;
+  }
+
+(* Error report *)
+
+open Format
+
+(* Forward declarations *)
+
+let print_longident =
+  ref ((fun _ _ -> assert false) : formatter -> Longident.t -> unit)
+
+let print_path =
+  ref ((fun _ _ -> assert false) : formatter -> Path.t -> unit)
+
+let spellcheck ppf extract env lid =
+  let choices ~path name = Misc.spellcheck (extract path env) name in
+  match lid with
+    | Longident.Lapply _ -> ()
+    | Longident.Lident s ->
+       Misc.did_you_mean ppf (fun () -> choices ~path:None s)
+    | Longident.Ldot (r, s) ->
+       Misc.did_you_mean ppf (fun () -> choices ~path:(Some r) s)
+
+let spellcheck_name ppf extract env name =
+  Misc.did_you_mean ppf
+    (fun () -> Misc.spellcheck (extract env) name)
+
+let extract_values path env =
+  fold_values (fun name _ _ acc -> name :: acc) path env []
+let extract_types path env =
+  fold_types (fun name _ _ acc -> name :: acc) path env []
+let extract_modules path env =
+  fold_modules (fun name _ _ acc -> name :: acc) path env []
+let extract_constructors path env =
+  fold_constructors (fun desc acc -> desc.cstr_name :: acc) path env []
+let extract_labels path env =
+  fold_labels (fun desc acc -> desc.lbl_name :: acc) path env []
+let extract_classes path env =
+  fold_classes (fun name _ _ acc -> name :: acc) path env []
+let extract_modtypes path env =
+  fold_modtypes (fun name _ _ acc -> name :: acc) path env []
+let extract_cltypes path env =
+  fold_cltypes (fun name _ _ acc -> name :: acc) path env []
+let extract_instance_variables env =
+  fold_values
+    (fun name _ descr acc ->
+       match descr.val_kind with
+       | Val_ivar _ -> name :: acc
+       | _ -> acc) None env []
+
+let report_lookup_error _loc env ppf = function
+  | Unbound_value(lid, hint) -> begin
+      fprintf ppf "Unbound value %a" !print_longident lid;
+      spellcheck ppf extract_values env lid;
+      match hint with
+      | No_hint -> ()
+      | Missing_rec def_loc ->
+          let (_, line, _) =
+            Location.get_pos_info def_loc.Location.loc_start
+          in
+          fprintf ppf
+            "@.@[%s@ %s %i@]"
+            "Hint: If this is a recursive definition,"
+            "you should add the 'rec' keyword on line"
+            line
+    end
+  | Unbound_type lid ->
+      fprintf ppf "Unbound type constructor %a" !print_longident lid;
+      spellcheck ppf extract_types env lid;
+  | Unbound_module lid -> begin
+      fprintf ppf "Unbound module %a" !print_longident lid;
+       match find_modtype_by_name lid env with
+      | exception Not_found -> spellcheck ppf extract_modules env lid;
+      | _ ->
+         fprintf ppf
+           "@.@[%s %a, %s@]"
+           "Hint: There is a module type named"
+           !print_longident lid
+           "but module types are not modules"
+    end
+  | Unbound_constructor lid ->
+      fprintf ppf "Unbound constructor %a" !print_longident lid;
+      spellcheck ppf extract_constructors env lid;
+  | Unbound_label lid ->
+      fprintf ppf "Unbound record field %a" !print_longident lid;
+      spellcheck ppf extract_labels env lid;
+  | Unbound_class lid -> begin
+      fprintf ppf "Unbound class %a" !print_longident lid;
+      match find_cltype_by_name lid env with
+      | exception Not_found -> spellcheck ppf extract_classes env lid;
+      | _ ->
+         fprintf ppf
+           "@.@[%s %a, %s@]"
+           "Hint: There is a class type named"
+           !print_longident lid
+           "but classes are not class types"
+    end
+  | Unbound_modtype lid -> begin
+      fprintf ppf "Unbound module type %a" !print_longident lid;
+      match find_module_by_name lid env with
+      | exception Not_found -> spellcheck ppf extract_modtypes env lid;
+      | _ ->
+         fprintf ppf
+           "@.@[%s %a, %s@]"
+           "Hint: There is a module named"
+           !print_longident lid
+           "but modules are not module types"
+    end
+  | Unbound_cltype lid ->
+      fprintf ppf "Unbound class type %a" !print_longident lid;
+      spellcheck ppf extract_cltypes env lid;
+  | Unbound_instance_variable s ->
+      fprintf ppf "Unbound instance variable %s" s;
+      spellcheck_name ppf extract_instance_variables env s;
+  | Not_an_instance_variable s ->
+      fprintf ppf "The value %s is not an instance variable" s;
+      spellcheck_name ppf extract_instance_variables env s;
+  | Masked_instance_variable lid ->
+      fprintf ppf
+        "The instance variable %a@ \
+         cannot be accessed from the definition of another instance variable"
+        !print_longident lid
+  | Masked_self_variable lid ->
+      fprintf ppf
+        "The self variable %a@ \
+         cannot be accessed from the definition of an instance variable"
+        !print_longident lid
+  | Masked_ancestor_variable lid ->
+      fprintf ppf
+        "The ancestor variable %a@ \
+         cannot be accessed from the definition of an instance variable"
+        !print_longident lid
+  | Illegal_reference_to_recursive_module ->
+     fprintf ppf "Illegal recursive module reference"
+  | Structure_used_as_functor lid ->
+      fprintf ppf "@[The module %a is a structure, it cannot be applied@]"
+        !print_longident lid
+  | Abstract_used_as_functor lid ->
+      fprintf ppf "@[The module %a is abstract, it cannot be applied@]"
+        !print_longident lid
+  | Functor_used_as_structure lid ->
+      fprintf ppf "@[The module %a is a functor, \
+                   it cannot have any components@]" !print_longident lid
+  | Abstract_used_as_structure lid ->
+      fprintf ppf "@[The module %a is abstract, \
+                   it cannot have any components@]" !print_longident lid
+  | Generative_used_as_applicative lid ->
+      fprintf ppf "@[The functor %a is generative,@ it@ cannot@ be@ \
+                   applied@ in@ type@ expressions@]" !print_longident lid
+  | Cannot_scrape_alias(lid, p) ->
+      let cause =
+        if Current_unit_name.is_path p then "is the current compilation unit"
+        else "is missing"
+      in
+      fprintf ppf
+        "The module %a is an alias for module %a, which %s"
+        !print_longident lid !print_path p cause
+
+let report_error ppf = function
+  | Missing_module(_, path1, path2) ->
+      fprintf ppf "@[@[<hov>";
+      if Path.same path1 path2 then
+        fprintf ppf "Internal path@ %s@ is dangling." (Path.name path1)
+      else
+        fprintf ppf "Internal path@ %s@ expands to@ %s@ which is dangling."
+          (Path.name path1) (Path.name path2);
+      fprintf ppf "@]@ @[%s@ %s@ %s.@]@]"
+        "The compiled interface for module" (Ident.name (Path.head path2))
+        "was not found"
+  | Illegal_value_name(_loc, name) ->
+      fprintf ppf "'%s' is not a valid value identifier."
+        name
+  | Lookup_error(loc, t, err) -> report_lookup_error loc t ppf err
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err ->
+          let loc =
+            match err with
+            | Missing_module (loc, _, _)
+            | Illegal_value_name (loc, _)
+            | Lookup_error(loc, _, _) -> loc
+          in
+          let error_of_printer =
+            if loc = Location.none
+            then Location.error_of_printer_file
+            else Location.error_of_printer ~loc ?sub:None
+          in
+          Some (error_of_printer report_error err)
+      | _ ->
+          None
+    )
diff --git a/upstream/ocaml_413/typing/env.mli b/upstream/ocaml_413/typing/env.mli
new file mode 100644
index 0000000..0536f3b
--- /dev/null
+++ b/upstream/ocaml_413/typing/env.mli
@@ -0,0 +1,485 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Environment handling *)
+
+open Types
+open Misc
+
+type value_unbound_reason =
+  | Val_unbound_instance_variable
+  | Val_unbound_self
+  | Val_unbound_ancestor
+  | Val_unbound_ghost_recursive of Location.t
+
+type module_unbound_reason =
+  | Mod_unbound_illegal_recursion
+
+type summary =
+    Env_empty
+  | Env_value of summary * Ident.t * value_description
+  | Env_type of summary * Ident.t * type_declaration
+  | Env_extension of summary * Ident.t * extension_constructor
+  | Env_module of summary * Ident.t * module_presence * module_declaration
+  | Env_modtype of summary * Ident.t * modtype_declaration
+  | Env_class of summary * Ident.t * class_declaration
+  | Env_cltype of summary * Ident.t * class_type_declaration
+  | Env_open of summary * Path.t
+  (** The string set argument of [Env_open] represents a list of module names
+      to skip, i.e. that won't be imported in the toplevel namespace. *)
+  | Env_functor_arg of summary * Ident.t
+  | Env_constraints of summary * type_declaration Path.Map.t
+  | Env_copy_types of summary
+  | Env_persistent of summary * Ident.t
+  | Env_value_unbound of summary * string * value_unbound_reason
+  | Env_module_unbound of summary * string * module_unbound_reason
+
+type address =
+  | Aident of Ident.t
+  | Adot of address * int
+
+type t
+
+val empty: t
+val initial_safe_string: t
+val initial_unsafe_string: t
+val diff: t -> t -> Ident.t list
+
+type type_descr_kind =
+  (label_description, constructor_description) type_kind
+
+  (* alias for compatibility *)
+type type_descriptions = type_descr_kind
+
+(* For short-paths *)
+type iter_cont
+val iter_types:
+    (Path.t -> Path.t * type_declaration -> unit) ->
+    t -> iter_cont
+val run_iter_cont: iter_cont list -> (Path.t * iter_cont) list
+val same_types: t -> t -> bool
+val used_persistent: unit -> Concr.t
+val find_shadowed_types: Path.t -> t -> Path.t list
+val without_cmis: ('a -> 'b) -> 'a -> 'b
+(* [without_cmis f arg] applies [f] to [arg], but does not
+   allow opening cmis during its execution *)
+
+(* Lookup by paths *)
+
+val find_value: Path.t -> t -> value_description
+val find_type: Path.t -> t -> type_declaration
+val find_type_descrs: Path.t -> t -> type_descriptions
+val find_module: Path.t -> t -> module_declaration
+val find_modtype: Path.t -> t -> modtype_declaration
+val find_class: Path.t -> t -> class_declaration
+val find_cltype: Path.t -> t -> class_type_declaration
+
+val find_ident_constructor: Ident.t -> t -> constructor_description
+val find_ident_label: Ident.t -> t -> label_description
+
+val find_type_expansion:
+    Path.t -> t -> type_expr list * type_expr * int
+val find_type_expansion_opt:
+    Path.t -> t -> type_expr list * type_expr * int
+(* Find the manifest type information associated to a type for the sake
+   of the compiler's type-based optimisations. *)
+val find_modtype_expansion: Path.t -> t -> module_type
+
+val find_hash_type: Path.t -> t -> type_declaration
+(* Find the "#t" type given the path for "t" *)
+
+val find_value_address: Path.t -> t -> address
+val find_module_address: Path.t -> t -> address
+val find_class_address: Path.t -> t -> address
+val find_constructor_address: Path.t -> t -> address
+
+val add_functor_arg: Ident.t -> t -> t
+val is_functor_arg: Path.t -> t -> bool
+
+val normalize_module_path: Location.t option -> t -> Path.t -> Path.t
+(* Normalize the path to a concrete module.
+   If the option is None, allow returning dangling paths.
+   Otherwise raise a Missing_module error, and may add forgotten
+   head as required global. *)
+
+val normalize_type_path: Location.t option -> t -> Path.t -> Path.t
+(* Normalize the prefix part of the type path *)
+
+val normalize_path_prefix: Location.t option -> t -> Path.t -> Path.t
+(* Normalize the prefix part of other kinds of paths
+   (value/modtype/etc) *)
+
+val normalize_modtype_path: t -> Path.t -> Path.t
+(* Normalize a module type path *)
+
+val reset_required_globals: unit -> unit
+val get_required_globals: unit -> Ident.t list
+val add_required_global: Ident.t -> unit
+
+val has_local_constraints: t -> bool
+
+(* Mark definitions as used *)
+val mark_value_used: Uid.t -> unit
+val mark_module_used: Uid.t -> unit
+val mark_type_used: Uid.t -> unit
+
+type constructor_usage = Positive | Pattern | Exported_private | Exported
+val mark_constructor_used:
+    constructor_usage -> constructor_declaration -> unit
+val mark_extension_used:
+    constructor_usage -> extension_constructor -> unit
+
+type label_usage =
+    Projection | Mutation | Construct | Exported_private | Exported
+val mark_label_used:
+    label_usage -> label_declaration -> unit
+
+(* Lookup by long identifiers *)
+
+(* Lookup errors *)
+
+type unbound_value_hint =
+  | No_hint
+  | Missing_rec of Location.t
+
+type lookup_error =
+  | Unbound_value of Longident.t * unbound_value_hint
+  | Unbound_type of Longident.t
+  | Unbound_constructor of Longident.t
+  | Unbound_label of Longident.t
+  | Unbound_module of Longident.t
+  | Unbound_class of Longident.t
+  | Unbound_modtype of Longident.t
+  | Unbound_cltype of Longident.t
+  | Unbound_instance_variable of string
+  | Not_an_instance_variable of string
+  | Masked_instance_variable of Longident.t
+  | Masked_self_variable of Longident.t
+  | Masked_ancestor_variable of Longident.t
+  | Structure_used_as_functor of Longident.t
+  | Abstract_used_as_functor of Longident.t
+  | Functor_used_as_structure of Longident.t
+  | Abstract_used_as_structure of Longident.t
+  | Generative_used_as_applicative of Longident.t
+  | Illegal_reference_to_recursive_module
+  | Cannot_scrape_alias of Longident.t * Path.t
+
+val lookup_error: Location.t -> t -> lookup_error -> 'a
+
+(* The [lookup_foo] functions will emit proper error messages (by
+   raising [Error]) if the identifier cannot be found, whereas the
+   [find_foo_by_name] functions will raise [Not_found] instead.
+
+   The [~use] parameters of the [lookup_foo] functions control
+   whether this lookup should be counted as a use for usage
+   warnings and alerts.
+
+   [Longident.t]s in the program source should be looked up using
+   [lookup_foo ~use:true] exactly one time -- otherwise warnings may be
+   emitted the wrong number of times. *)
+
+val lookup_value:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  Path.t * value_description
+val lookup_type:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  Path.t * type_declaration
+val lookup_module:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  Path.t * module_declaration
+val lookup_modtype:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  Path.t * modtype_declaration
+val lookup_class:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  Path.t * class_declaration
+val lookup_cltype:
+  ?use:bool -> loc:Location.t -> Longident.t -> t ->
+  Path.t * class_type_declaration
+
+val lookup_module_path:
+  ?use:bool -> loc:Location.t -> load:bool -> Longident.t -> t -> Path.t
+
+val lookup_constructor:
+  ?use:bool -> loc:Location.t -> constructor_usage -> Longident.t -> t ->
+  constructor_description
+val lookup_all_constructors:
+  ?use:bool -> loc:Location.t -> constructor_usage -> Longident.t -> t ->
+  ((constructor_description * (unit -> unit)) list,
+   Location.t * t * lookup_error) result
+val lookup_all_constructors_from_type:
+  ?use:bool -> loc:Location.t -> constructor_usage -> Path.t -> t ->
+  (constructor_description * (unit -> unit)) list
+
+val lookup_label:
+  ?use:bool -> loc:Location.t -> label_usage -> Longident.t -> t ->
+  label_description
+val lookup_all_labels:
+  ?use:bool -> loc:Location.t -> label_usage -> Longident.t -> t ->
+  ((label_description * (unit -> unit)) list,
+   Location.t * t * lookup_error) result
+val lookup_all_labels_from_type:
+  ?use:bool -> loc:Location.t -> label_usage -> Path.t -> t ->
+  (label_description * (unit -> unit)) list
+
+val lookup_instance_variable:
+  ?use:bool -> loc:Location.t -> string -> t ->
+  Path.t * Asttypes.mutable_flag * string * type_expr
+
+val find_value_by_name:
+  Longident.t -> t -> Path.t * value_description
+val find_type_by_name:
+  Longident.t -> t -> Path.t * type_declaration
+val find_module_by_name:
+  Longident.t -> t -> Path.t * module_declaration
+val find_modtype_by_name:
+  Longident.t -> t -> Path.t * modtype_declaration
+val find_class_by_name:
+  Longident.t -> t -> Path.t * class_declaration
+val find_cltype_by_name:
+  Longident.t -> t -> Path.t * class_type_declaration
+
+val find_constructor_by_name:
+  Longident.t -> t -> constructor_description
+val find_label_by_name:
+  Longident.t -> t -> label_description
+
+(* Check if a name is bound *)
+
+val bound_value: string -> t -> bool
+val bound_module: string -> t -> bool
+val bound_type: string -> t -> bool
+val bound_modtype: string -> t -> bool
+val bound_class: string -> t -> bool
+val bound_cltype: string -> t -> bool
+
+val make_copy_of_types: t -> (t -> t)
+
+(* Insertion by identifier *)
+
+val add_value:
+    ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t
+val add_type: check:bool -> Ident.t -> type_declaration -> t -> t
+val add_extension:
+  check:bool -> rebind:bool -> Ident.t -> extension_constructor -> t -> t
+val add_module:
+  ?arg:bool -> Ident.t -> module_presence -> module_type -> t -> t
+val add_module_declaration: ?arg:bool -> check:bool -> Ident.t ->
+  module_presence -> module_declaration -> t -> t
+val add_modtype: Ident.t -> modtype_declaration -> t -> t
+val add_class: Ident.t -> class_declaration -> t -> t
+val add_cltype: Ident.t -> class_type_declaration -> t -> t
+val add_local_type: Path.t -> type_declaration -> t -> t
+
+(* Insertion of persistent signatures *)
+
+(* [add_persistent_structure id env] is an environment such that
+   module [id] points to the persistent structure contained in the
+   external compilation unit with the same name.
+
+   The compilation unit itself is looked up in the load path when the
+   contents of the module is accessed. *)
+val add_persistent_structure : Ident.t -> t -> t
+
+(* Returns the set of persistent structures found in the given
+   directory. *)
+val persistent_structures_of_dir : Load_path.Dir.t -> Misc.Stdlib.String.Set.t
+
+(* [filter_non_loaded_persistent f env] removes all the persistent
+   structures that are not yet loaded and for which [f] returns
+   [false]. *)
+val filter_non_loaded_persistent : (Ident.t -> bool) -> t -> t
+
+(* Insertion of all fields of a signature. *)
+
+val add_item: signature_item -> t -> t
+val add_signature: signature -> t -> t
+
+(* Insertion of all fields of a signature, relative to the given path.
+   Used to implement open. Returns None if the path refers to a functor,
+   not a structure. *)
+val open_signature:
+    ?used_slot:bool ref ->
+    ?loc:Location.t -> ?toplevel:bool ->
+    Asttypes.override_flag -> Path.t ->
+    t -> (t, [`Not_found | `Functor]) result
+
+val open_pers_signature: string -> t -> (t, [`Not_found]) result
+
+val remove_last_open: Path.t -> t -> t option
+
+(* Insertion by name *)
+
+val enter_value:
+    ?check:(string -> Warnings.t) ->
+    string -> value_description -> t -> Ident.t * t
+val enter_type: scope:int -> string -> type_declaration -> t -> Ident.t * t
+val enter_extension:
+  scope:int -> rebind:bool -> string ->
+  extension_constructor -> t -> Ident.t * t
+val enter_module:
+  scope:int -> ?arg:bool -> string -> module_presence ->
+  module_type -> t -> Ident.t * t
+val enter_module_declaration:
+  scope:int -> ?arg:bool -> string -> module_presence ->
+  module_declaration -> t -> Ident.t * t
+val enter_modtype:
+  scope:int -> string -> modtype_declaration -> t -> Ident.t * t
+val enter_class: scope:int -> string -> class_declaration -> t -> Ident.t * t
+val enter_cltype:
+  scope:int -> string -> class_type_declaration -> t -> Ident.t * t
+
+(* Same as [add_signature] but refreshes (new stamp) and rescopes bound idents
+   in the process. *)
+val enter_signature: scope:int -> signature -> t -> signature * t
+
+val enter_unbound_value : string -> value_unbound_reason -> t -> t
+
+val enter_unbound_module : string -> module_unbound_reason -> t -> t
+
+(* Initialize the cache of in-core module interfaces. *)
+val reset_cache: unit -> unit
+
+(* To be called before each toplevel phrase. *)
+val reset_cache_toplevel: unit -> unit
+
+(* Remember the name of the current compilation unit. *)
+val set_unit_name: string -> unit
+val get_unit_name: unit -> string
+
+(* Read, save a signature to/from a file *)
+val read_signature: modname -> filepath -> signature
+        (* Arguments: module name, file name. Results: signature. *)
+val save_signature:
+  alerts:alerts -> signature -> modname -> filepath
+  -> Cmi_format.cmi_infos
+        (* Arguments: signature, module name, file name. *)
+val save_signature_with_imports:
+  alerts:alerts -> signature -> modname -> filepath -> crcs
+  -> Cmi_format.cmi_infos
+        (* Arguments: signature, module name, file name,
+           imported units with their CRCs. *)
+
+(* Return the CRC of the interface of the given compilation unit *)
+val crc_of_unit: modname -> Digest.t
+
+(* Return the set of compilation units imported, with their CRC *)
+val imports: unit -> crcs
+
+(* may raise Persistent_env.Consistbl.Inconsistency *)
+val import_crcs: source:string -> crcs -> unit
+
+(* [is_imported_opaque md] returns true if [md] is an opaque imported module *)
+val is_imported_opaque: modname -> bool
+
+(* [register_import_as_opaque md] registers [md] as an opaque imported module *)
+val register_import_as_opaque: modname -> unit
+
+(* Summaries -- compact representation of an environment, to be
+   exported in debugging information. *)
+
+val summary: t -> summary
+
+(* Return an equivalent environment where all fields have been reset,
+   except the summary. The initial environment can be rebuilt from the
+   summary, using Envaux.env_of_only_summary. *)
+
+val keep_only_summary : t -> t
+val env_of_only_summary : (summary -> Subst.t -> t) -> t -> t
+
+(* Error report *)
+
+type error =
+  | Missing_module of Location.t * Path.t * Path.t
+  | Illegal_value_name of Location.t * string
+  | Lookup_error of Location.t * t * lookup_error
+
+exception Error of error
+
+open Format
+
+val report_error: formatter -> error -> unit
+
+val report_lookup_error: Location.t -> t -> formatter -> lookup_error -> unit
+
+val in_signature: bool -> t -> t
+
+val is_in_signature: t -> bool
+
+val set_value_used_callback:
+    value_description -> (unit -> unit) -> unit
+val set_type_used_callback:
+    type_declaration -> ((unit -> unit) -> unit) -> unit
+
+(* Forward declaration to break mutual recursion with Includemod. *)
+val check_functor_application:
+  (errors:bool -> loc:Location.t ->
+   lid_whole_app:Longident.t ->
+   f0_path:Path.t -> args:(Path.t * Types.module_type) list ->
+   arg_path:Path.t -> arg_mty:Types.module_type ->
+   param_mty:Types.module_type ->
+   t -> unit) ref
+(* Forward declaration to break mutual recursion with Typemod. *)
+val check_well_formed_module:
+    (t -> Location.t -> string -> module_type -> unit) ref
+(* Forward declaration to break mutual recursion with Typecore. *)
+val add_delayed_check_forward: ((unit -> unit) -> unit) ref
+(* Forward declaration to break mutual recursion with Mtype. *)
+val strengthen:
+    (aliasable:bool -> t -> module_type -> Path.t -> module_type) ref
+(* Forward declaration to break mutual recursion with Ctype. *)
+val same_constr: (t -> type_expr -> type_expr -> bool) ref
+(* Forward declaration to break mutual recursion with Printtyp. *)
+val print_longident: (Format.formatter -> Longident.t -> unit) ref
+(* Forward declaration to break mutual recursion with Printtyp. *)
+val print_path: (Format.formatter -> Path.t -> unit) ref
+
+
+(** Folds *)
+
+val fold_values:
+  (string -> Path.t -> value_description -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+val fold_types:
+  (string -> Path.t -> type_declaration -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+val fold_constructors:
+  (constructor_description -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+val fold_labels:
+  (label_description -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+
+(** Persistent structures are only traversed if they are already loaded. *)
+val fold_modules:
+  (string -> Path.t -> module_declaration -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+
+val fold_modtypes:
+  (string -> Path.t -> modtype_declaration -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+val fold_classes:
+  (string -> Path.t -> class_declaration -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+val fold_cltypes:
+  (string -> Path.t -> class_type_declaration -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+
+
+(** Utilities *)
+val scrape_alias: t -> module_type -> module_type
+val check_value_name: string -> Location.t -> unit
+
+val print_address : Format.formatter -> address -> unit
diff --git a/upstream/ocaml_413/typing/envaux.ml b/upstream/ocaml_413/typing/envaux.ml
new file mode 100644
index 0000000..a0bbbc2
--- /dev/null
+++ b/upstream/ocaml_413/typing/envaux.ml
@@ -0,0 +1,115 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Jerome Vouillon, projet Cristal, INRIA Rocquencourt          *)
+(*           OCaml port by John Malecki and Xavier Leroy                  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Env
+
+type error =
+    Module_not_found of Path.t
+
+exception Error of error
+
+let env_cache =
+  (Hashtbl.create 59 : ((Env.summary * Subst.t), Env.t) Hashtbl.t)
+
+let reset_cache () =
+  Hashtbl.clear env_cache;
+  Env.reset_cache()
+
+let rec env_from_summary sum subst =
+  try
+    Hashtbl.find env_cache (sum, subst)
+  with Not_found ->
+    let env =
+      match sum with
+        Env_empty ->
+          Env.empty
+      | Env_value(s, id, desc) ->
+          Env.add_value id (Subst.value_description subst desc)
+                        (env_from_summary s subst)
+      | Env_type(s, id, desc) ->
+          Env.add_type ~check:false id
+            (Subst.type_declaration subst desc)
+            (env_from_summary s subst)
+      | Env_extension(s, id, desc) ->
+          Env.add_extension ~check:false ~rebind:false id
+            (Subst.extension_constructor subst desc)
+            (env_from_summary s subst)
+      | Env_module(s, id, pres, desc) ->
+          Env.add_module_declaration ~check:false id pres
+            (Subst.module_declaration Keep subst desc)
+            (env_from_summary s subst)
+      | Env_modtype(s, id, desc) ->
+          Env.add_modtype id (Subst.modtype_declaration Keep subst desc)
+                          (env_from_summary s subst)
+      | Env_class(s, id, desc) ->
+          Env.add_class id (Subst.class_declaration subst desc)
+                        (env_from_summary s subst)
+      | Env_cltype (s, id, desc) ->
+          Env.add_cltype id (Subst.cltype_declaration subst desc)
+                         (env_from_summary s subst)
+      | Env_open(s, path) ->
+          let env = env_from_summary s subst in
+          let path' = Subst.module_path subst path in
+          begin match Env.open_signature Asttypes.Override path' env with
+          | Ok env -> env
+          | Error `Functor -> assert false
+          | Error `Not_found -> raise (Error (Module_not_found path'))
+          end
+      | Env_functor_arg(Env_module(s, id, pres, desc), id')
+            when Ident.same id id' ->
+          Env.add_module_declaration ~check:false
+            id pres (Subst.module_declaration Keep subst desc)
+            ~arg:true (env_from_summary s subst)
+      | Env_functor_arg _ -> assert false
+      | Env_constraints(s, map) ->
+          Path.Map.fold
+            (fun path info ->
+              Env.add_local_type (Subst.type_path subst path)
+                (Subst.type_declaration subst info))
+            map (env_from_summary s subst)
+      | Env_copy_types s ->
+          let env = env_from_summary s subst in
+          Env.make_copy_of_types env env
+      | Env_persistent (s, id) ->
+          let env = env_from_summary s subst in
+          Env.add_persistent_structure id env
+      | Env_value_unbound (s, str, reason) ->
+          let env = env_from_summary s subst in
+          Env.enter_unbound_value str reason env
+      | Env_module_unbound (s, str, reason) ->
+          let env = env_from_summary s subst in
+          Env.enter_unbound_module str reason env
+    in
+      Hashtbl.add env_cache (sum, subst) env;
+      env
+
+let env_of_only_summary env =
+  Env.env_of_only_summary env_from_summary env
+
+(* Error report *)
+
+open Format
+
+let report_error ppf = function
+  | Module_not_found p ->
+      fprintf ppf "@[Cannot find module %a@].@." Printtyp.path p
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )
diff --git a/upstream/ocaml_413/typing/envaux.mli b/upstream/ocaml_413/typing/envaux.mli
new file mode 100644
index 0000000..2869890
--- /dev/null
+++ b/upstream/ocaml_413/typing/envaux.mli
@@ -0,0 +1,36 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Jerome Vouillon, projet Cristal, INRIA Rocquencourt          *)
+(*           OCaml port by John Malecki and Xavier Leroy                  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Format
+
+(* Convert environment summaries to environments *)
+
+val env_from_summary : Env.summary -> Subst.t -> Env.t
+
+(* Empty the environment caches. To be called when load_path changes. *)
+
+val reset_cache: unit -> unit
+
+val env_of_only_summary : Env.t -> Env.t
+
+(* Error report *)
+
+type error =
+    Module_not_found of Path.t
+
+exception Error of error
+
+val report_error: formatter -> error -> unit
diff --git a/upstream/ocaml_413/typing/errortrace.ml b/upstream/ocaml_413/typing/errortrace.ml
new file mode 100644
index 0000000..eca7408
--- /dev/null
+++ b/upstream/ocaml_413/typing/errortrace.ml
@@ -0,0 +1,158 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Florian Angeletti, projet Cambium, Inria Paris             *)
+(*              Antal Spector-Zabusky, Jane Street, New York              *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*   Copyright 2021 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Types
+open Format
+
+type position = First | Second
+
+let swap_position = function
+  | First -> Second
+  | Second -> First
+
+let print_pos ppf = function
+  | First -> fprintf ppf "first"
+  | Second -> fprintf ppf "second"
+
+type desc = { t: type_expr; expanded: type_expr option }
+type 'a diff = { got: 'a; expected: 'a}
+
+let short t = { t; expanded = None }
+let map_diff f r =
+  (* ordering is often meaningful when dealing with type_expr *)
+  let got = f r.got in
+  let expected = f r.expected in
+  { got; expected}
+
+let flatten_desc f x = match x.expanded with
+  | None -> f x.t x.t
+  | Some expanded -> f x.t expanded
+
+let swap_diff x = { got = x.expected; expected = x.got }
+
+type 'a escape_kind =
+  | Constructor of Path.t
+  | Univ of type_expr
+  (* The type_expr argument of [Univ] is always a [Tunivar _],
+     we keep a [type_expr] to track renaming in {!Printtyp} *)
+  | Self
+  | Module_type of Path.t
+  | Equation of 'a
+  | Constraint
+
+type 'a escape =
+  { kind : 'a escape_kind;
+    context : type_expr option }
+
+let explain trace f =
+  let rec explain = function
+    | [] -> None
+    | [h] -> f ~prev:None h
+    | h :: (prev :: _ as rem) ->
+      match f ~prev:(Some prev) h with
+      | Some _ as m -> m
+      | None -> explain rem in
+  explain (List.rev trace)
+
+(* Type indices *)
+type unification = private Unification
+type comparison  = private Comparison
+
+type fixed_row_case =
+  | Cannot_be_closed
+  | Cannot_add_tags of string list
+
+type 'variety variant =
+  (* Common *)
+  | Incompatible_types_for : string -> _ variant
+  | No_tags : position * (Asttypes.label * row_field) list -> _ variant
+  (* Unification *)
+  | No_intersection : unification variant
+  | Fixed_row :
+      position * fixed_row_case * fixed_explanation -> unification variant
+  (* Equality & Moregen *)
+  | Openness : position (* Always [Second] for Moregen *) -> comparison variant
+
+type 'variety obj =
+  (* Common *)
+  | Missing_field : position * string -> _ obj
+  | Abstract_row : position -> _ obj
+  (* Unification *)
+  | Self_cannot_be_closed : unification obj
+
+type ('a, 'variety) elt =
+  (* Common *)
+  | Diff : 'a diff -> ('a, _) elt
+  | Variant : 'variety variant -> ('a, 'variety) elt
+  | Obj : 'variety obj -> ('a, 'variety) elt
+  | Escape : 'a escape -> ('a, _) elt
+  | Incompatible_fields : { name:string; diff: type_expr diff } -> ('a, _) elt
+      (* Could move [Incompatible_fields] into [obj] *)
+  (* Unification & Moregen; included in Equality for simplicity *)
+  | Rec_occur : type_expr * type_expr -> ('a, _) elt
+
+type 'variety t =
+  (desc, 'variety) elt list
+
+let diff got expected = Diff (map_diff short { got; expected })
+
+let map_elt (type variety) f : ('a, variety) elt -> ('b, variety) elt = function
+  | Diff x -> Diff (map_diff f x)
+  | Escape {kind = Equation x; context} ->
+      Escape { kind = Equation (f x); context }
+  | Escape {kind = (Univ _ | Self | Constructor _ | Module_type _ | Constraint);
+            _}
+  | Variant _ | Obj _ | Incompatible_fields _ | Rec_occur (_, _) as x -> x
+
+let map f t = List.map (map_elt f) t
+
+(* Convert desc to type_expr * type_expr *)
+let flatten f = map (flatten_desc f)
+
+let incompatible_fields name got expected =
+  Incompatible_fields { name; diff={got; expected} }
+
+
+let swap_elt (type variety) : ('a, variety) elt -> ('a, variety) elt = function
+  | Diff x -> Diff (swap_diff x)
+  | Incompatible_fields { name; diff } ->
+    Incompatible_fields { name; diff = swap_diff diff}
+  | Obj (Missing_field(pos,s)) -> Obj (Missing_field(swap_position pos,s))
+  | Obj (Abstract_row pos) -> Obj (Abstract_row (swap_position pos))
+  | Variant (Fixed_row(pos,k,f)) ->
+    Variant (Fixed_row(swap_position pos,k,f))
+  | Variant (No_tags(pos,f)) ->
+    Variant (No_tags(swap_position pos,f))
+  | x -> x
+
+let swap_trace e = List.map swap_elt e
+
+module Subtype = struct
+  type 'a elt =
+    | Diff of 'a diff
+
+  type t = desc elt list
+
+  let diff got expected = Diff (map_diff short {got;expected})
+
+  let map_elt f = function
+    | Diff x -> Diff (map_diff f x)
+
+  let map f t = List.map (map_elt f) t
+
+  let flatten f t = map (flatten_desc f) t
+end
diff --git a/upstream/ocaml_413/typing/errortrace.mli b/upstream/ocaml_413/typing/errortrace.mli
new file mode 100644
index 0000000..be6000e
--- /dev/null
+++ b/upstream/ocaml_413/typing/errortrace.mli
@@ -0,0 +1,116 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Florian Angeletti, projet Cambium, Inria Paris             *)
+(*              Antal Spector-Zabusky, Jane Street, New York              *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*   Copyright 2021 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Types
+
+type position = First | Second
+
+val swap_position : position -> position
+val print_pos : Format.formatter -> position -> unit
+
+type desc = { t: type_expr; expanded: type_expr option }
+type 'a diff = { got: 'a; expected: 'a}
+
+(** [map_diff f {expected;got}] is [{expected=f expected; got=f got}] *)
+val map_diff: ('a -> 'b) -> 'a diff -> 'b diff
+
+(** Scope escape related errors *)
+type 'a escape_kind =
+  | Constructor of Path.t
+  | Univ of type_expr
+  (* The type_expr argument of [Univ] is always a [Tunivar _],
+     we keep a [type_expr] to track renaming in {!Printtyp} *)
+  | Self
+  | Module_type of Path.t
+  | Equation of 'a
+  | Constraint
+
+type 'a escape =
+  { kind : 'a escape_kind;
+    context : type_expr option }
+
+val short : type_expr -> desc
+
+val explain: 'a list ->
+  (prev:'a option -> 'a -> 'b option) ->
+  'b option
+
+(* Type indices *)
+type unification = private Unification
+type comparison  = private Comparison
+
+type fixed_row_case =
+  | Cannot_be_closed
+  | Cannot_add_tags of string list
+
+type 'variety variant =
+  (* Common *)
+  | Incompatible_types_for : string -> _ variant
+  | No_tags : position * (Asttypes.label * row_field) list -> _ variant
+  (* Unification *)
+  | No_intersection : unification variant
+  | Fixed_row :
+      position * fixed_row_case * fixed_explanation -> unification variant
+  (* Equality & Moregen *)
+  | Openness : position (* Always [Second] for Moregen *) -> comparison variant
+
+type 'variety obj =
+  (* Common *)
+  | Missing_field : position * string -> _ obj
+  | Abstract_row : position -> _ obj
+  (* Unification *)
+  | Self_cannot_be_closed : unification obj
+
+type ('a, 'variety) elt =
+  (* Common *)
+  | Diff : 'a diff -> ('a, _) elt
+  | Variant : 'variety variant -> ('a, 'variety) elt
+  | Obj : 'variety obj -> ('a, 'variety) elt
+  | Escape : 'a escape -> ('a, _) elt
+  | Incompatible_fields : { name:string; diff: type_expr diff } -> ('a, _) elt
+  (* Unification & Moregen; included in Equality for simplicity *)
+  | Rec_occur : type_expr * type_expr -> ('a, _) elt
+
+type 'variety t =
+  (desc, 'variety) elt list
+
+val diff : type_expr -> type_expr -> (desc, _) elt
+
+(** [flatten f trace] flattens all elements of type {!desc} in
+    [trace] to either [f x.t expanded] if [x.expanded=Some expanded]
+    or [f x.t x.t] otherwise *)
+val flatten :
+  (type_expr -> type_expr -> 'a) -> 'variety t -> ('a, 'variety) elt list
+
+val map : ('a -> 'b) -> ('a, 'variety) elt list -> ('b, 'variety) elt list
+
+val incompatible_fields : string -> type_expr -> type_expr -> (desc, _) elt
+
+val swap_trace : 'variety t -> 'variety t
+
+module Subtype : sig
+  type 'a elt =
+    | Diff of 'a diff
+
+  type t = desc elt list
+
+  val diff: type_expr -> type_expr -> desc elt
+
+  val flatten : (type_expr -> type_expr -> 'a) -> t -> 'a elt list
+
+  val map : (desc -> desc) -> desc elt list -> desc elt list
+end
diff --git a/upstream/ocaml_413/typing/ident.ml b/upstream/ocaml_413/typing/ident.ml
new file mode 100644
index 0000000..feb590d
--- /dev/null
+++ b/upstream/ocaml_413/typing/ident.ml
@@ -0,0 +1,360 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Local_store
+
+let lowest_scope  = 0
+let highest_scope = 100000000
+
+type t =
+  | Local of { name: string; stamp: int }
+  | Scoped of { name: string; stamp: int; scope: int }
+  | Global of string
+  | Predef of { name: string; stamp: int }
+      (* the stamp is here only for fast comparison, but the name of
+         predefined identifiers is always unique. *)
+
+(* A stamp of 0 denotes a persistent identifier *)
+
+let currentstamp = s_ref 0
+let predefstamp = s_ref 0
+
+let create_scoped ~scope s =
+  incr currentstamp;
+  Scoped { name = s; stamp = !currentstamp; scope }
+
+let create_local s =
+  incr currentstamp;
+  Local { name = s; stamp = !currentstamp }
+
+let create_predef s =
+  incr predefstamp;
+  Predef { name = s; stamp = !predefstamp }
+
+let create_persistent s =
+  Global s
+
+let name = function
+  | Local { name; _ }
+  | Scoped { name; _ }
+  | Global name
+  | Predef { name; _ } -> name
+
+let rename = function
+  | Local { name; stamp = _ }
+  | Scoped { name; stamp = _; scope = _ } ->
+      incr currentstamp;
+      Local { name; stamp = !currentstamp }
+  | id ->
+      Misc.fatal_errorf "Ident.rename %s" (name id)
+
+let unique_name = function
+  | Local { name; stamp }
+  | Scoped { name; stamp } -> name ^ "_" ^ Int.to_string stamp
+  | Global name ->
+      (* we're adding a fake stamp, because someone could have named his unit
+         [Foo_123] and since we're using unique_name to produce symbol names,
+         we might clash with an ident [Local { "Foo"; 123 }]. *)
+      name ^ "_0"
+  | Predef { name; _ } ->
+      (* we know that none of the predef names (currently) finishes in
+         "_<some number>", and that their name is unique. *)
+      name
+
+let unique_toplevel_name = function
+  | Local { name; stamp }
+  | Scoped { name; stamp } -> name ^ "/" ^ Int.to_string stamp
+  | Global name
+  | Predef { name; _ } -> name
+
+let persistent = function
+  | Global _ -> true
+  | _ -> false
+
+let equal i1 i2 =
+  match i1, i2 with
+  | Local { name = name1; _ }, Local { name = name2; _ }
+  | Scoped { name = name1; _ }, Scoped { name = name2; _ }
+  | Global name1, Global name2 ->
+      name1 = name2
+  | Predef { stamp = s1; _ }, Predef { stamp = s2 } ->
+      (* if they don't have the same stamp, they don't have the same name *)
+      s1 = s2
+  | _ ->
+      false
+
+let same i1 i2 =
+  match i1, i2 with
+  | Local { stamp = s1; _ }, Local { stamp = s2; _ }
+  | Scoped { stamp = s1; _ }, Scoped { stamp = s2; _ }
+  | Predef { stamp = s1; _ }, Predef { stamp = s2 } ->
+      s1 = s2
+  | Global name1, Global name2 ->
+      name1 = name2
+  | _ ->
+      false
+
+let stamp = function
+  | Local { stamp; _ }
+  | Scoped { stamp; _ } -> stamp
+  | _ -> 0
+
+let scope = function
+  | Scoped { scope; _ } -> scope
+  | Local _ -> highest_scope
+  | Global _ | Predef _ -> lowest_scope
+
+let reinit_level = ref (-1)
+
+let reinit () =
+  if !reinit_level < 0
+  then reinit_level := !currentstamp
+  else currentstamp := !reinit_level
+
+let global = function
+  | Local _
+  | Scoped _ -> false
+  | Global _
+  | Predef _ -> true
+
+let is_predef = function
+  | Predef _ -> true
+  | _ -> false
+
+let print ~with_scope ppf =
+  let open Format in
+  function
+  | Global name -> fprintf ppf "%s!" name
+  | Predef { name; stamp = n } ->
+      fprintf ppf "%s%s!" name
+        (if !Clflags.unique_ids then sprintf "/%i" n else "")
+  | Local { name; stamp = n } ->
+      fprintf ppf "%s%s" name
+        (if !Clflags.unique_ids then sprintf "/%i" n else "")
+  | Scoped { name; stamp = n; scope } ->
+      fprintf ppf "%s%s%s" name
+        (if !Clflags.unique_ids then sprintf "/%i" n else "")
+        (if with_scope then sprintf "[%i]" scope else "")
+
+let print_with_scope ppf id = print ~with_scope:true ppf id
+
+let print ppf id = print ~with_scope:false ppf id
+
+type 'a tbl =
+    Empty
+  | Node of 'a tbl * 'a data * 'a tbl * int
+
+and 'a data =
+  { ident: t;
+    data: 'a;
+    previous: 'a data option }
+
+let empty = Empty
+
+(* Inline expansion of height for better speed
+ * let height = function
+ *     Empty -> 0
+ *   | Node(_,_,_,h) -> h
+ *)
+
+let mknode l d r =
+  let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h
+  and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+  Node(l, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+let balance l d r =
+  let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h
+  and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+  if hl > hr + 1 then
+    match l with
+    | Node (ll, ld, lr, _)
+      when (match ll with Empty -> 0 | Node(_,_,_,h) -> h) >=
+           (match lr with Empty -> 0 | Node(_,_,_,h) -> h) ->
+        mknode ll ld (mknode lr d r)
+    | Node (ll, ld, Node(lrl, lrd, lrr, _), _) ->
+        mknode (mknode ll ld lrl) lrd (mknode lrr d r)
+    | _ -> assert false
+  else if hr > hl + 1 then
+    match r with
+    | Node (rl, rd, rr, _)
+      when (match rr with Empty -> 0 | Node(_,_,_,h) -> h) >=
+           (match rl with Empty -> 0 | Node(_,_,_,h) -> h) ->
+        mknode (mknode l d rl) rd rr
+    | Node (Node (rll, rld, rlr, _), rd, rr, _) ->
+        mknode (mknode l d rll) rld (mknode rlr rd rr)
+    | _ -> assert false
+  else
+    mknode l d r
+
+let rec add id data = function
+    Empty ->
+      Node(Empty, {ident = id; data = data; previous = None}, Empty, 1)
+  | Node(l, k, r, h) ->
+      let c = String.compare (name id) (name k.ident) in
+      if c = 0 then
+        Node(l, {ident = id; data = data; previous = Some k}, r, h)
+      else if c < 0 then
+        balance (add id data l) k r
+      else
+        balance l k (add id data r)
+
+let rec min_binding = function
+    Empty -> raise Not_found
+  | Node (Empty, d, _, _) -> d
+  | Node (l, _, _, _) -> min_binding l
+
+let rec remove_min_binding = function
+    Empty -> invalid_arg "Map.remove_min_elt"
+  | Node (Empty, _, r, _) -> r
+  | Node (l, d, r, _) -> balance (remove_min_binding l) d r
+
+let merge t1 t2 =
+  match (t1, t2) with
+    (Empty, t) -> t
+  | (t, Empty) -> t
+  | (_, _) ->
+      let d = min_binding t2 in
+      balance t1 d (remove_min_binding t2)
+
+let rec remove id = function
+    Empty ->
+      Empty
+  | (Node (l, k, r, h) as m) ->
+      let c = String.compare (name id) (name k.ident) in
+      if c = 0 then
+        match k.previous with
+        | None -> merge l r
+        | Some k -> Node (l, k, r, h)
+      else if c < 0 then
+        let ll = remove id l in if l == ll then m else balance ll k r
+      else
+        let rr = remove id r in if r == rr then m else balance l k rr
+
+let rec find_previous id = function
+    None ->
+      raise Not_found
+  | Some k ->
+      if same id k.ident then k.data else find_previous id k.previous
+
+let rec find_same id = function
+    Empty ->
+      raise Not_found
+  | Node(l, k, r, _) ->
+      let c = String.compare (name id) (name k.ident) in
+      if c = 0 then
+        if same id k.ident
+        then k.data
+        else find_previous id k.previous
+      else
+        find_same id (if c < 0 then l else r)
+
+let rec find_name n = function
+    Empty ->
+      raise Not_found
+  | Node(l, k, r, _) ->
+      let c = String.compare n (name k.ident) in
+      if c = 0 then
+        k.ident, k.data
+      else
+        find_name n (if c < 0 then l else r)
+
+let rec get_all = function
+  | None -> []
+  | Some k -> (k.ident, k.data) :: get_all k.previous
+
+let rec find_all n = function
+    Empty ->
+      []
+  | Node(l, k, r, _) ->
+      let c = String.compare n (name k.ident) in
+      if c = 0 then
+        (k.ident, k.data) :: get_all k.previous
+      else
+        find_all n (if c < 0 then l else r)
+
+let rec fold_aux f stack accu = function
+    Empty ->
+      begin match stack with
+        [] -> accu
+      | a :: l -> fold_aux f l accu a
+      end
+  | Node(l, k, r, _) ->
+      fold_aux f (l :: stack) (f k accu) r
+
+let fold_name f tbl accu = fold_aux (fun k -> f k.ident k.data) [] accu tbl
+
+let rec fold_data f d accu =
+  match d with
+    None -> accu
+  | Some k -> f k.ident k.data (fold_data f k.previous accu)
+
+let fold_all f tbl accu =
+  fold_aux (fun k -> fold_data f (Some k)) [] accu tbl
+
+(* let keys tbl = fold_name (fun k _ accu -> k::accu) tbl [] *)
+
+let rec iter f = function
+    Empty -> ()
+  | Node(l, k, r, _) ->
+      iter f l; f k.ident k.data; iter f r
+
+(* Idents for sharing keys *)
+
+(* They should be 'totally fresh' -> neg numbers *)
+let key_name = ""
+
+let make_key_generator () =
+  let c = ref 1 in
+  function
+  | Local _
+  | Scoped _ ->
+      let stamp = !c in
+      decr c ;
+      Local { name = key_name; stamp = stamp }
+  | global_id ->
+      Misc.fatal_errorf "Ident.make_key_generator () %s" (name global_id)
+
+let compare x y =
+  match x, y with
+  | Local x, Local y ->
+      let c = x.stamp - y.stamp in
+      if c <> 0 then c
+      else compare x.name y.name
+  | Local _, _ -> 1
+  | _, Local _ -> (-1)
+  | Scoped x, Scoped y ->
+      let c = x.stamp - y.stamp in
+      if c <> 0 then c
+      else compare x.name y.name
+  | Scoped _, _ -> 1
+  | _, Scoped _ -> (-1)
+  | Global x, Global y -> compare x y
+  | Global _, _ -> 1
+  | _, Global _ -> (-1)
+  | Predef { stamp = s1; _ }, Predef { stamp = s2; _ } -> compare s1 s2
+
+let output oc id = output_string oc (unique_name id)
+let hash i = (Char.code (name i).[0]) lxor (stamp i)
+
+let original_equal = equal
+include Identifiable.Make (struct
+  type nonrec t = t
+  let compare = compare
+  let output = output
+  let print = print
+  let hash = hash
+  let equal = same
+end)
+let equal = original_equal
diff --git a/upstream/ocaml_413/typing/ident.mli b/upstream/ocaml_413/typing/ident.mli
new file mode 100644
index 0000000..ff48efb
--- /dev/null
+++ b/upstream/ocaml_413/typing/ident.mli
@@ -0,0 +1,80 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Identifiers (unique names) *)
+
+type t
+
+include Identifiable.S with type t := t
+(* Notes:
+   - [equal] compares identifiers by name
+   - [compare x y] is 0 if [same x y] is true.
+   - [compare] compares identifiers by binding location
+*)
+
+val print_with_scope : Format.formatter -> t -> unit
+        (** Same as {!print} except that it will also add a "[n]" suffix
+            if the scope of the argument is [n]. *)
+
+
+val create_scoped: scope:int -> string -> t
+val create_local: string -> t
+val create_persistent: string -> t
+val create_predef: string -> t
+
+val rename: t -> t
+        (** Creates an identifier with the same name as the input, a fresh
+            stamp, and no scope.
+            @raise [Fatal_error] if called on a persistent / predef ident. *)
+
+val name: t -> string
+val unique_name: t -> string
+val unique_toplevel_name: t -> string
+val persistent: t -> bool
+val same: t -> t -> bool
+        (** Compare identifiers by binding location.
+            Two identifiers are the same either if they are both
+            non-persistent and have been created by the same call to
+            [create_*], or if they are both persistent and have the same
+            name. *)
+
+val compare: t -> t -> int
+
+val global: t -> bool
+val is_predef: t -> bool
+
+val scope: t -> int
+
+val lowest_scope : int
+val highest_scope: int
+
+val reinit: unit -> unit
+
+type 'a tbl
+        (* Association tables from identifiers to type 'a. *)
+
+val empty: 'a tbl
+val add: t -> 'a -> 'a tbl -> 'a tbl
+val find_same: t -> 'a tbl -> 'a
+val find_name: string -> 'a tbl -> t * 'a
+val find_all: string -> 'a tbl -> (t * 'a) list
+val fold_name: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b
+val fold_all: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b
+val iter: (t -> 'a -> unit) -> 'a tbl -> unit
+val remove: t -> 'a tbl -> 'a tbl
+
+(* Idents for sharing keys *)
+
+val make_key_generator : unit -> (t -> t)
diff --git a/upstream/ocaml_413/typing/includeclass.ml b/upstream/ocaml_413/typing/includeclass.ml
new file mode 100644
index 0000000..2f0c057
--- /dev/null
+++ b/upstream/ocaml_413/typing/includeclass.ml
@@ -0,0 +1,120 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Jerome Vouillon, projet Cristal, INRIA Rocquencourt          *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the class language *)
+
+open Types
+
+let class_types env cty1 cty2 =
+  Ctype.match_class_types env cty1 cty2
+
+let class_type_declarations ~loc env cty1 cty2 =
+  Builtin_attributes.check_alerts_inclusion
+    ~def:cty1.clty_loc
+    ~use:cty2.clty_loc
+    loc
+    cty1.clty_attributes cty2.clty_attributes
+    (Path.last cty1.clty_path);
+  Ctype.match_class_declarations env
+    cty1.clty_params cty1.clty_type
+    cty2.clty_params cty2.clty_type
+
+let class_declarations env cty1 cty2 =
+  match cty1.cty_new, cty2.cty_new with
+    None, Some _ ->
+      [Ctype.CM_Virtual_class]
+  | _ ->
+      Ctype.match_class_declarations env
+        cty1.cty_params cty1.cty_type
+        cty2.cty_params cty2.cty_type
+
+open Format
+open Ctype
+
+(*
+let rec hide_params = function
+    Tcty_arrow ("*", _, cty) -> hide_params cty
+  | cty -> cty
+*)
+
+let report_error_for = function
+  | CM_Equality -> Printtyp.report_equality_error
+  | CM_Moregen  -> Printtyp.report_moregen_error
+
+let include_err ppf =
+  function
+  | CM_Virtual_class ->
+      fprintf ppf "A class cannot be changed from virtual to concrete"
+  | CM_Parameter_arity_mismatch _ ->
+      fprintf ppf
+        "The classes do not have the same number of type parameters"
+  | CM_Type_parameter_mismatch (env, trace) ->
+      Printtyp.report_equality_error ppf env trace
+        (function ppf ->
+          fprintf ppf "A type parameter has type")
+        (function ppf ->
+          fprintf ppf "but is expected to have type")
+  | CM_Class_type_mismatch (env, cty1, cty2) ->
+      Printtyp.wrap_printing_env ~error:true env (fun () ->
+        fprintf ppf
+          "@[The class type@;<1 2>%a@ %s@;<1 2>%a@]"
+          Printtyp.class_type cty1
+          "is not matched by the class type"
+          Printtyp.class_type cty2)
+  | CM_Parameter_mismatch (env, trace) ->
+      Printtyp.report_moregen_error ppf env trace
+        (function ppf ->
+          fprintf ppf "A parameter has type")
+        (function ppf ->
+          fprintf ppf "but is expected to have type")
+  | CM_Val_type_mismatch (trace_type, lab, env, trace) ->
+      report_error_for trace_type ppf env trace
+        (function ppf ->
+          fprintf ppf "The instance variable %s@ has type" lab)
+        (function ppf ->
+          fprintf ppf "but is expected to have type")
+  | CM_Meth_type_mismatch (trace_type, lab, env, trace) ->
+      report_error_for trace_type  ppf env trace
+        (function ppf ->
+          fprintf ppf "The method %s@ has type" lab)
+        (function ppf ->
+          fprintf ppf "but is expected to have type")
+  | CM_Non_mutable_value lab ->
+      fprintf ppf
+       "@[The non-mutable instance variable %s cannot become mutable@]" lab
+  | CM_Non_concrete_value lab ->
+      fprintf ppf
+       "@[The virtual instance variable %s cannot become concrete@]" lab
+  | CM_Missing_value lab ->
+      fprintf ppf "@[The first class type has no instance variable %s@]" lab
+  | CM_Missing_method lab ->
+      fprintf ppf "@[The first class type has no method %s@]" lab
+  | CM_Hide_public lab ->
+     fprintf ppf "@[The public method %s cannot be hidden@]" lab
+  | CM_Hide_virtual (k, lab) ->
+      fprintf ppf "@[The virtual %s %s cannot be hidden@]" k lab
+  | CM_Public_method lab ->
+      fprintf ppf "@[The public method %s cannot become private@]" lab
+  | CM_Virtual_method lab ->
+      fprintf ppf "@[The virtual method %s cannot become concrete@]" lab
+  | CM_Private_method lab ->
+      fprintf ppf "@[The private method %s cannot become public@]" lab
+
+let report_error ppf = function
+  |  [] -> ()
+  | err :: errs ->
+      let print_errs ppf errs =
+         List.iter (fun err -> fprintf ppf "@ %a" include_err err) errs in
+      fprintf ppf "@[<v>%a%a@]" include_err err print_errs errs
diff --git a/upstream/ocaml_413/typing/includeclass.mli b/upstream/ocaml_413/typing/includeclass.mli
new file mode 100644
index 0000000..ebfa978
--- /dev/null
+++ b/upstream/ocaml_413/typing/includeclass.mli
@@ -0,0 +1,32 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Jerome Vouillon, projet Cristal, INRIA Rocquencourt          *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the class language *)
+
+open Types
+open Ctype
+open Format
+
+val class_types:
+        Env.t -> class_type -> class_type -> class_match_failure list
+val class_type_declarations:
+  loc:Location.t ->
+  Env.t -> class_type_declaration -> class_type_declaration ->
+  class_match_failure list
+val class_declarations:
+  Env.t -> class_declaration -> class_declaration ->
+  class_match_failure list
+
+val report_error: formatter -> class_match_failure list -> unit
diff --git a/upstream/ocaml_413/typing/includecore.ml b/upstream/ocaml_413/typing/includecore.ml
new file mode 100644
index 0000000..d712fae
--- /dev/null
+++ b/upstream/ocaml_413/typing/includecore.ml
@@ -0,0 +1,685 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the core language *)
+
+open Asttypes
+open Path
+open Types
+open Typedtree
+
+type position = Errortrace.position = First | Second
+
+(* Inclusion between value descriptions *)
+
+type primitive_mismatch =
+  | Name
+  | Arity
+  | No_alloc of position
+  | Native_name
+  | Result_repr
+  | Argument_repr of int
+
+let native_repr_args nra1 nra2 =
+  let rec loop i nra1 nra2 =
+    match nra1, nra2 with
+    | [], [] -> None
+    | [], _ :: _ -> assert false
+    | _ :: _, [] -> assert false
+    | nr1 :: nra1, nr2 :: nra2 ->
+      if not (Primitive.equal_native_repr nr1 nr2) then Some (Argument_repr i)
+      else loop (i+1) nra1 nra2
+  in
+  loop 1 nra1 nra2
+
+let primitive_descriptions pd1 pd2 =
+  let open Primitive in
+  if not (String.equal pd1.prim_name pd2.prim_name) then
+    Some Name
+  else if not (Int.equal pd1.prim_arity pd2.prim_arity) then
+    Some Arity
+  else if (not pd1.prim_alloc) && pd2.prim_alloc then
+    Some (No_alloc First)
+  else if pd1.prim_alloc && (not pd2.prim_alloc) then
+    Some (No_alloc Second)
+  else if not (String.equal pd1.prim_native_name pd2.prim_native_name) then
+    Some Native_name
+  else if not
+    (Primitive.equal_native_repr
+       pd1.prim_native_repr_res pd2.prim_native_repr_res) then
+    Some Result_repr
+  else
+    native_repr_args pd1.prim_native_repr_args pd2.prim_native_repr_args
+
+type value_mismatch =
+  | Primitive_mismatch of primitive_mismatch
+  | Not_a_primitive
+  | Type of Env.t * Errortrace.comparison Errortrace.t
+
+exception Dont_match of value_mismatch
+
+let value_descriptions ~loc env name
+    (vd1 : Types.value_description)
+    (vd2 : Types.value_description) =
+  Builtin_attributes.check_alerts_inclusion
+    ~def:vd1.val_loc
+    ~use:vd2.val_loc
+    loc
+    vd1.val_attributes vd2.val_attributes
+    name;
+  match Ctype.moregeneral env true vd1.val_type vd2.val_type with
+  | exception Ctype.Moregen trace -> raise (Dont_match (Type (env, trace)))
+  | () -> begin
+      match (vd1.val_kind, vd2.val_kind) with
+      | (Val_prim p1, Val_prim p2) -> begin
+          match primitive_descriptions p1 p2 with
+          | None -> Tcoerce_none
+          | Some err -> raise (Dont_match (Primitive_mismatch err))
+        end
+      | (Val_prim p, _) ->
+          let pc =
+            { pc_desc = p; pc_type = vd2.Types.val_type;
+              pc_env = env; pc_loc = vd1.Types.val_loc; }
+          in
+          Tcoerce_primitive pc
+      | (_, Val_prim _) -> raise (Dont_match Not_a_primitive)
+      | (_, _) -> Tcoerce_none
+    end
+
+(* Inclusion between "private" annotations *)
+
+let private_flags decl1 decl2 =
+  match decl1.type_private, decl2.type_private with
+  | Private, Public ->
+      decl2.type_kind = Type_abstract &&
+      (decl2.type_manifest = None || decl1.type_kind <> Type_abstract)
+  | _, _ -> true
+
+(* Inclusion between manifest types (particularly for private row types) *)
+
+let is_absrow env ty =
+  match ty.desc with
+  | Tconstr(Pident _, _, _) -> begin
+      match Ctype.expand_head env ty with
+      | {desc=Tobject _|Tvariant _} -> true
+      | _ -> false
+      end
+  | _ -> false
+
+(* Inclusion between type declarations *)
+
+let choose ord first second =
+  match ord with
+  | First -> first
+  | Second -> second
+
+let choose_other ord first second =
+  match ord with
+  | First -> choose Second first second
+  | Second -> choose First first second
+
+type label_mismatch =
+  | Type of Env.t * Errortrace.comparison Errortrace.t
+  | Mutability of position
+
+type record_mismatch =
+  | Label_mismatch of Types.label_declaration
+                      * Types.label_declaration
+                      * label_mismatch
+  | Label_names of int * Ident.t * Ident.t
+  | Label_missing of position * Ident.t
+  | Unboxed_float_representation of position
+
+type constructor_mismatch =
+  | Type of Env.t * Errortrace.comparison Errortrace.t
+  | Arity
+  | Inline_record of record_mismatch
+  | Kind of position
+  | Explicit_return_type of position
+
+type variant_mismatch =
+  | Constructor_mismatch of Types.constructor_declaration
+                            * Types.constructor_declaration
+                            * constructor_mismatch
+  | Constructor_names of int * Ident.t * Ident.t
+  | Constructor_missing of position * Ident.t
+
+type extension_constructor_mismatch =
+  | Constructor_privacy
+  | Constructor_mismatch of Ident.t
+                            * Types.extension_constructor
+                            * Types.extension_constructor
+                            * constructor_mismatch
+
+type private_variant_mismatch =
+  | Openness
+  | Missing of position * string
+  | Presence of string
+  | Incompatible_types_for of string
+  | Types of Env.t * Errortrace.comparison Errortrace.t
+
+type private_object_mismatch =
+  | Missing of string
+  | Types of Env.t * Errortrace.comparison Errortrace.t
+
+type type_mismatch =
+  | Arity
+  | Privacy
+  | Kind
+  | Constraint of Env.t * Errortrace.comparison Errortrace.t
+  | Manifest of Env.t * Errortrace.comparison Errortrace.t
+  | Private_variant of type_expr * type_expr * private_variant_mismatch
+  | Private_object of type_expr * type_expr * private_object_mismatch
+  | Variance
+  | Record_mismatch of record_mismatch
+  | Variant_mismatch of variant_mismatch
+  | Unboxed_representation of position
+  | Immediate of Type_immediacy.Violation.t
+
+let report_label_mismatch first second ppf err =
+  let pr fmt = Format.fprintf ppf fmt in
+  match (err : label_mismatch) with
+  | Type _ -> pr "The types are not equal."
+  | Mutability ord ->
+      pr "%s is mutable and %s is not."
+        (String.capitalize_ascii  (choose ord first second))
+        (choose_other ord first second)
+
+let report_record_mismatch first second decl ppf err =
+  let pr fmt = Format.fprintf ppf fmt in
+  match err with
+  | Label_mismatch (l1, l2, err) ->
+      pr
+        "@[<hv>Fields do not match:@;<1 2>%a@ is not compatible with:\
+         @;<1 2>%a@ %a@]"
+        Printtyp.label l1
+        Printtyp.label l2
+        (report_label_mismatch first second) err
+  | Label_names (n, name1, name2) ->
+      pr "@[<hv>Fields number %i have different names, %s and %s.@]"
+        n (Ident.name name1) (Ident.name name2)
+  | Label_missing (ord, s) ->
+      pr "@[<hv>The field %s is only present in %s %s.@]"
+        (Ident.name s) (choose ord first second) decl
+  | Unboxed_float_representation ord ->
+      pr "@[<hv>Their internal representations differ:@ %s %s %s.@]"
+        (choose ord first second) decl
+        "uses unboxed float representation"
+
+let report_constructor_mismatch first second decl ppf err =
+  let pr fmt  = Format.fprintf ppf fmt in
+  match (err : constructor_mismatch) with
+  | Type _ -> pr "The types are not equal."
+  | Arity -> pr "They have different arities."
+  | Inline_record err -> report_record_mismatch first second decl ppf err
+  | Kind ord ->
+      pr "%s uses inline records and %s doesn't."
+        (String.capitalize_ascii (choose ord first second))
+        (choose_other ord first second)
+  | Explicit_return_type ord ->
+      pr "%s has explicit return type and %s doesn't."
+        (String.capitalize_ascii (choose ord first second))
+        (choose_other ord first second)
+
+let report_variant_mismatch first second decl ppf err =
+  let pr fmt = Format.fprintf ppf fmt in
+  match (err : variant_mismatch) with
+  | Constructor_mismatch (c1, c2, err) ->
+      pr
+        "@[<hv>Constructors do not match:@;<1 2>%a@ is not compatible with:\
+         @;<1 2>%a@ %a@]"
+        Printtyp.constructor c1
+        Printtyp.constructor c2
+        (report_constructor_mismatch first second decl) err
+  | Constructor_names (n, name1, name2) ->
+      pr "Constructors number %i have different names, %s and %s."
+        n (Ident.name name1) (Ident.name name2)
+  | Constructor_missing (ord, s) ->
+      pr "The constructor %s is only present in %s %s."
+        (Ident.name s) (choose ord first second) decl
+
+let report_extension_constructor_mismatch first second decl ppf err =
+  let pr fmt = Format.fprintf ppf fmt in
+  match (err : extension_constructor_mismatch) with
+  | Constructor_privacy -> pr "A private type would be revealed."
+  | Constructor_mismatch (id, ext1, ext2, err) ->
+      pr "@[<hv>Constructors do not match:@;<1 2>%a@ is not compatible with:\
+          @;<1 2>%a@ %a@]"
+        (Printtyp.extension_only_constructor id) ext1
+        (Printtyp.extension_only_constructor id) ext2
+        (report_constructor_mismatch first second decl) err
+
+let report_type_mismatch0 first second decl ppf err =
+  let pr fmt = Format.fprintf ppf fmt in
+  match err with
+  | Arity -> pr "They have different arities."
+  | Privacy -> pr "A private type would be revealed."
+  | Kind -> pr "Their kinds differ."
+  | Constraint _ -> pr "Their constraints differ."
+  | Manifest _ -> ()
+  | Private_variant _ -> ()
+  | Private_object _ -> ()
+  | Variance -> pr "Their variances do not agree."
+  | Record_mismatch err -> report_record_mismatch first second decl ppf err
+  | Variant_mismatch err -> report_variant_mismatch first second decl ppf err
+  | Unboxed_representation ord ->
+      pr "Their internal representations differ:@ %s %s %s."
+         (choose ord first second) decl
+         "uses unboxed representation"
+  | Immediate violation ->
+      let first = StringLabels.capitalize_ascii first in
+      match violation with
+      | Type_immediacy.Violation.Not_always_immediate ->
+          pr "%s is not an immediate type." first
+      | Type_immediacy.Violation.Not_always_immediate_on_64bits ->
+          pr "%s is not a type that is always immediate on 64 bit platforms."
+            first
+
+let report_type_mismatch first second decl ppf err =
+  match err with
+  | Manifest _ -> ()
+  | Private_variant _ -> ()
+  | Private_object _ -> ()
+  | _ -> Format.fprintf ppf "@ %a" (report_type_mismatch0 first second decl) err
+
+let rec compare_constructor_arguments ~loc env params1 params2 arg1 arg2 =
+  match arg1, arg2 with
+  | Types.Cstr_tuple arg1, Types.Cstr_tuple arg2 ->
+      if List.length arg1 <> List.length arg2 then
+        Some (Arity : constructor_mismatch)
+      else begin
+        (* Ctype.equal must be called on all arguments at once, cf. PR#7378 *)
+        match Ctype.equal env true (params1 @ arg1) (params2 @ arg2) with
+        | exception Ctype.Equality trace -> Some (Type (env, trace))
+        | () -> None
+      end
+  | Types.Cstr_record l1, Types.Cstr_record l2 ->
+      Option.map
+        (fun rec_err -> Inline_record rec_err)
+        (compare_records env ~loc params1 params2 0 l1 l2)
+  | Types.Cstr_record _, _ -> Some (Kind First : constructor_mismatch)
+  | _, Types.Cstr_record _ -> Some (Kind Second : constructor_mismatch)
+
+and compare_constructors ~loc env params1 params2 res1 res2 args1 args2 =
+  match res1, res2 with
+  | Some r1, Some r2 -> begin
+      match Ctype.equal env true [r1] [r2] with
+      | exception Ctype.Equality trace -> Some (Type (env, trace))
+      | () -> compare_constructor_arguments ~loc env [r1] [r2] args1 args2
+    end
+  | Some _, None -> Some (Explicit_return_type First)
+  | None, Some _ -> Some (Explicit_return_type Second)
+  | None, None ->
+      compare_constructor_arguments ~loc env params1 params2 args1 args2
+
+and compare_variants ~loc env params1 params2 n
+    (cstrs1 : Types.constructor_declaration list)
+    (cstrs2 : Types.constructor_declaration list) =
+  match cstrs1, cstrs2 with
+  | [], []   -> None
+  | [], c::_ -> Some (Constructor_missing (Second, c.Types.cd_id))
+  | c::_, [] -> Some (Constructor_missing (First, c.Types.cd_id))
+  | cd1::rem1, cd2::rem2 ->
+      if Ident.name cd1.cd_id <> Ident.name cd2.cd_id then
+        Some (Constructor_names (n, cd1.cd_id, cd2.cd_id))
+      else begin
+        Builtin_attributes.check_alerts_inclusion
+          ~def:cd1.cd_loc
+          ~use:cd2.cd_loc
+          loc
+          cd1.cd_attributes cd2.cd_attributes
+          (Ident.name cd1.cd_id);
+        match compare_constructors ~loc env params1 params2
+                cd1.cd_res cd2.cd_res cd1.cd_args cd2.cd_args with
+        | Some r ->
+            Some ((Constructor_mismatch (cd1, cd2, r)) : variant_mismatch)
+        | None -> compare_variants ~loc env params1 params2 (n+1) rem1 rem2
+      end
+
+and compare_variants_with_representation ~loc env params1 params2 n
+      cstrs1 cstrs2 rep1 rep2
+  =
+  let err = compare_variants ~loc env params1 params2 n cstrs1 cstrs2 in
+  match err, rep1, rep2 with
+  | None, Variant_regular, Variant_regular
+  | None, Variant_unboxed, Variant_unboxed ->
+     None
+  | Some err, _, _ ->
+     Some (Variant_mismatch err)
+  | None, Variant_unboxed, Variant_regular ->
+     Some (Unboxed_representation First)
+  | None, Variant_regular, Variant_unboxed ->
+     Some (Unboxed_representation Second)
+
+and compare_labels env params1 params2
+      (ld1 : Types.label_declaration) (ld2 : Types.label_declaration) =
+  if ld1.ld_mutable <> ld2.ld_mutable then begin
+    let ord = if ld1.ld_mutable = Asttypes.Mutable then First else Second in
+    Some (Mutability  ord)
+  end else begin
+    let tl1 = params1 @ [ld1.ld_type] in
+    let tl2 = params2 @ [ld2.ld_type] in
+    match Ctype.equal env true tl1 tl2 with
+    | exception Ctype.Equality trace ->
+        Some (Type (env, trace) : label_mismatch)
+    | () -> None
+  end
+
+and compare_records ~loc env params1 params2 n
+    (labels1 : Types.label_declaration list)
+    (labels2 : Types.label_declaration list) =
+  match labels1, labels2 with
+  | [], []           -> None
+  | [], l::_ -> Some (Label_missing (Second, l.Types.ld_id))
+  | l::_, [] -> Some (Label_missing (First, l.Types.ld_id))
+  | ld1::rem1, ld2::rem2 ->
+      if Ident.name ld1.ld_id <> Ident.name ld2.ld_id
+      then Some (Label_names (n, ld1.ld_id, ld2.ld_id))
+      else begin
+        Builtin_attributes.check_deprecated_mutable_inclusion
+          ~def:ld1.ld_loc
+          ~use:ld2.ld_loc
+          loc
+          ld1.ld_attributes ld2.ld_attributes
+          (Ident.name ld1.ld_id);
+        match compare_labels env params1 params2 ld1 ld2 with
+        | Some r -> Some (Label_mismatch (ld1, ld2, r))
+        (* add arguments to the parameters, cf. PR#7378 *)
+        | None -> compare_records ~loc env
+                    (ld1.ld_type::params1) (ld2.ld_type::params2)
+                    (n+1)
+                    rem1 rem2
+      end
+
+let compare_records_with_representation ~loc env params1 params2 n
+      labels1 labels2 rep1 rep2
+  =
+  match compare_records ~loc env params1 params2 n labels1 labels2 with
+  | Some err -> Some (Record_mismatch err)
+  | None ->
+     match rep1, rep2 with
+     | Record_unboxed _, Record_unboxed _ -> None
+     | Record_unboxed _, _ -> Some (Unboxed_representation First)
+     | _, Record_unboxed _ -> Some (Unboxed_representation Second)
+
+     | Record_float, Record_float -> None
+     | Record_float, _ ->
+        Some (Record_mismatch (Unboxed_float_representation First))
+     | _, Record_float ->
+        Some (Record_mismatch (Unboxed_float_representation Second))
+
+     | Record_regular, Record_regular
+     | Record_inlined _, Record_inlined _
+     | Record_extension _, Record_extension _ -> None
+     | (Record_regular|Record_inlined _|Record_extension _),
+       (Record_regular|Record_inlined _|Record_extension _) ->
+        assert false
+
+let private_variant env row1 params1 row2 params2 =
+    let r1, r2, pairs =
+      Ctype.merge_row_fields row1.row_fields row2.row_fields
+    in
+    let err =
+      if row2.row_closed && not row1.row_closed then Some Openness
+      else begin
+        match row2.row_closed, Ctype.filter_row_fields false r1 with
+        | true, (s, _) :: _ ->
+            Some (Missing (Second, s) : private_variant_mismatch)
+        | _, _ -> None
+      end
+    in
+    if err <> None then err else
+    let err =
+      let missing =
+        List.find_opt
+          (fun (_,f) ->
+             match Btype.row_field_repr f with
+             | Rabsent | Reither _ -> false
+             | Rpresent _ -> true)
+          r2
+      in
+      match missing with
+      | None -> None
+      | Some (s, _) -> Some (Missing (First, s) : private_variant_mismatch)
+    in
+    if err <> None then err else
+    let rec loop tl1 tl2 pairs =
+      match pairs with
+      | [] -> begin
+          match Ctype.equal env true tl1 tl2 with
+          | exception Ctype.Equality trace ->
+              Some (Types (env, trace) : private_variant_mismatch)
+          | () -> None
+        end
+      | (s, f1, f2) :: pairs -> begin
+          match Btype.row_field_repr f1, Btype.row_field_repr f2 with
+          | Rpresent to1, Rpresent to2 -> begin
+              match to1, to2 with
+              | Some t1, Some t2 ->
+                  loop (t1 :: tl1) (t2 :: tl2) pairs
+              | None, None ->
+                  loop tl1 tl2 pairs
+              | Some _, None | None, Some _ ->
+                  Some (Incompatible_types_for s)
+            end
+          | Rpresent to1, Reither(const2, ts2, _, _) -> begin
+              match to1, const2, ts2 with
+              | Some t1, false, [t2] -> loop (t1 :: tl1) (t2 :: tl2) pairs
+              | None, true, [] -> loop tl1 tl2 pairs
+              | _, _, _ -> Some (Incompatible_types_for s)
+            end
+          | Rpresent _, Rabsent ->
+              Some (Missing (Second, s) : private_variant_mismatch)
+          | Reither(const1, ts1, _, _), Reither(const2, ts2, _, _) ->
+              if const1 = const2 && List.length ts1 = List.length ts2 then
+                loop (ts1 @ tl1) (ts2 @ tl2) pairs
+              else
+                Some (Incompatible_types_for s)
+          | Reither _, Rpresent _ ->
+              Some (Presence s)
+          | Reither _, Rabsent ->
+              Some (Missing (Second, s) : private_variant_mismatch)
+          | Rabsent, (Reither _ | Rabsent) ->
+              loop tl1 tl2 pairs
+          | Rabsent, Rpresent _ ->
+              Some (Missing (First, s) : private_variant_mismatch)
+        end
+    in
+    loop params1 params2 pairs
+
+let private_object env fields1 params1 fields2 params2 =
+  let pairs, _miss1, miss2 = Ctype.associate_fields fields1 fields2 in
+  let err =
+    match miss2 with
+    | [] -> None
+    | (f, _, _) :: _ -> Some (Missing f)
+  in
+  if err <> None then err else
+  let tl1, tl2 =
+    List.split (List.map (fun (_,_,t1,_,t2) -> t1, t2) pairs)
+  in
+  begin
+    match Ctype.equal env true (params1 @ tl1) (params2 @ tl2) with
+    | exception Ctype.Equality trace -> Some (Types (env, trace))
+    | () -> None
+  end
+
+let type_manifest env ty1 params1 ty2 params2 priv2 =
+  let ty1' = Ctype.expand_head env ty1 and ty2' = Ctype.expand_head env ty2 in
+  match ty1'.desc, ty2'.desc with
+  | Tvariant row1, Tvariant row2
+    when is_absrow env (Btype.row_more row2) -> begin
+      let row1 = Btype.row_repr row1 and row2 = Btype.row_repr row2 in
+      assert (Ctype.is_equal env true (ty1::params1) (row2.row_more::params2));
+      match private_variant env row1 params1 row2 params2 with
+      | None -> None
+      | Some err -> Some (Private_variant(ty1, ty2, err))
+    end
+  | Tobject (fi1, _), Tobject (fi2, _)
+    when is_absrow env (snd (Ctype.flatten_fields fi2)) -> begin
+      let (fields2,rest2) = Ctype.flatten_fields fi2 in
+      let (fields1,_) = Ctype.flatten_fields fi1 in
+      assert (Ctype.is_equal env true (ty1::params1) (rest2::params2));
+      match private_object env fields1 params1 fields2 params2 with
+      | None -> None
+      | Some err -> Some (Private_object(ty1, ty2, err))
+    end
+  | _ -> begin
+    match
+      match priv2 with
+      | Private -> Ctype.equal_private env params1 ty1 params2 ty2
+      | Public -> Ctype.equal env true (params1 @ [ty1]) (params2 @ [ty2])
+    with
+    | exception Ctype.Equality trace -> Some (Manifest (env, trace))
+    | () -> None
+  end
+
+let type_declarations ?(equality = false) ~loc env ~mark name
+      decl1 path decl2 =
+  Builtin_attributes.check_alerts_inclusion
+    ~def:decl1.type_loc
+    ~use:decl2.type_loc
+    loc
+    decl1.type_attributes decl2.type_attributes
+    name;
+  if decl1.type_arity <> decl2.type_arity then Some Arity else
+  if not (private_flags decl1 decl2) then Some Privacy else
+  let err = match (decl1.type_manifest, decl2.type_manifest) with
+      (_, None) ->
+        begin
+          match Ctype.equal env true decl1.type_params decl2.type_params with
+          | exception Ctype.Equality trace -> Some (Constraint(env, trace))
+          | () -> None
+        end
+    | (Some ty1, Some ty2) ->
+         type_manifest env ty1 decl1.type_params ty2 decl2.type_params
+           decl2.type_private
+    | (None, Some ty2) ->
+        let ty1 =
+          Btype.newgenty (Tconstr(path, decl2.type_params, ref Mnil))
+        in
+        match Ctype.equal env true decl1.type_params decl2.type_params with
+        | exception Ctype.Equality trace -> Some (Constraint(env, trace))
+        | () ->
+          match Ctype.equal env false [ty1] [ty2] with
+          | exception Ctype.Equality trace -> Some (Manifest(env, trace))
+          | () -> None
+  in
+  if err <> None then err else
+  let err = match (decl1.type_kind, decl2.type_kind) with
+      (_, Type_abstract) -> None
+    | (Type_variant (cstrs1, rep1), Type_variant (cstrs2, rep2)) ->
+        if mark then begin
+          let mark usage cstrs =
+            List.iter (Env.mark_constructor_used usage) cstrs
+          in
+          let usage : Env.constructor_usage =
+            if decl2.type_private = Public then Env.Exported
+            else Env.Exported_private
+          in
+          mark usage cstrs1;
+          if equality then mark Env.Exported cstrs2
+        end;
+        compare_variants_with_representation ~loc env
+          decl1.type_params decl2.type_params 1
+          cstrs1 cstrs2
+          rep1 rep2
+    | (Type_record(labels1,rep1), Type_record(labels2,rep2)) ->
+        if mark then begin
+          let mark usage lbls =
+            List.iter (Env.mark_label_used usage) lbls
+          in
+          let usage : Env.label_usage =
+            if decl2.type_private = Public then Env.Exported
+            else Env.Exported_private
+          in
+          mark usage labels1;
+          if equality then mark Env.Exported labels2
+        end;
+        compare_records_with_representation ~loc env
+          decl1.type_params decl2.type_params 1
+          labels1 labels2
+          rep1 rep2
+    | (Type_open, Type_open) -> None
+    | (_, _) -> Some Kind
+  in
+  if err <> None then err else
+  let abstr = decl2.type_kind = Type_abstract && decl2.type_manifest = None in
+  (* If attempt to assign a non-immediate type (e.g. string) to a type that
+   * must be immediate, then we error *)
+  let err =
+    if not abstr then
+      None
+    else
+      match
+        Type_immediacy.coerce decl1.type_immediate ~as_:decl2.type_immediate
+      with
+      | Ok () -> None
+      | Error violation -> Some (Immediate violation)
+  in
+  if err <> None then err else
+  let need_variance =
+    abstr || decl1.type_private = Private || decl1.type_kind = Type_open in
+  if not need_variance then None else
+  let abstr = abstr || decl2.type_private = Private in
+  let opn = decl2.type_kind = Type_open && decl2.type_manifest = None in
+  let constrained ty = not (Btype.(is_Tvar (repr ty))) in
+  if List.for_all2
+      (fun ty (v1,v2) ->
+        let open Variance in
+        let imp a b = not a || b in
+        let (co1,cn1) = get_upper v1 and (co2,cn2) = get_upper v2 in
+        (if abstr then (imp co1 co2 && imp cn1 cn2)
+         else if opn || constrained ty then (co1 = co2 && cn1 = cn2)
+         else true) &&
+        let (p1,n1,i1,j1) = get_lower v1 and (p2,n2,i2,j2) = get_lower v2 in
+        imp abstr (imp p2 p1 && imp n2 n1 && imp i2 i1 && imp j2 j1))
+      decl2.type_params (List.combine decl1.type_variance decl2.type_variance)
+  then None else Some Variance
+
+(* Inclusion between extension constructors *)
+
+let extension_constructors ~loc env ~mark id ext1 ext2 =
+  if mark then begin
+    let usage : Env.constructor_usage =
+      if ext2.ext_private = Public then Env.Exported
+      else Env.Exported_private
+    in
+    Env.mark_extension_used usage ext1
+  end;
+  let ty1 =
+    Btype.newgenty (Tconstr(ext1.ext_type_path, ext1.ext_type_params, ref Mnil))
+  in
+  let ty2 =
+    Btype.newgenty (Tconstr(ext2.ext_type_path, ext2.ext_type_params, ref Mnil))
+  in
+  let tl1 = ty1 :: ext1.ext_type_params in
+  let tl2 = ty2 :: ext2.ext_type_params in
+  match Ctype.equal env true tl1 tl2 with
+  | exception Ctype.Equality trace ->
+      Some (Constructor_mismatch (id, ext1, ext2, Type(env, trace)))
+  | () ->
+    let r =
+      compare_constructors ~loc env
+        ext1.ext_type_params ext2.ext_type_params
+        ext1.ext_ret_type ext2.ext_ret_type
+        ext1.ext_args ext2.ext_args
+    in
+    match r with
+    | Some r -> Some (Constructor_mismatch (id, ext1, ext2, r))
+    | None ->
+      match ext1.ext_private, ext2.ext_private with
+      | Private, Public -> Some Constructor_privacy
+      | _, _ -> None
diff --git a/upstream/ocaml_413/typing/includecore.mli b/upstream/ocaml_413/typing/includecore.mli
new file mode 100644
index 0000000..95bcbb2
--- /dev/null
+++ b/upstream/ocaml_413/typing/includecore.mli
@@ -0,0 +1,116 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the core language *)
+
+open Typedtree
+open Types
+
+type position = Errortrace.position = First | Second
+
+type primitive_mismatch =
+  | Name
+  | Arity
+  | No_alloc of position
+  | Native_name
+  | Result_repr
+  | Argument_repr of int
+
+type value_mismatch =
+  | Primitive_mismatch of primitive_mismatch
+  | Not_a_primitive
+  | Type of Env.t * Errortrace.comparison Errortrace.t
+
+exception Dont_match of value_mismatch
+
+type label_mismatch =
+  | Type of Env.t * Errortrace.comparison Errortrace.t
+  | Mutability of position
+
+type record_mismatch =
+  | Label_mismatch of label_declaration * label_declaration * label_mismatch
+  | Label_names of int * Ident.t * Ident.t
+  | Label_missing of position * Ident.t
+  | Unboxed_float_representation of position
+
+type constructor_mismatch =
+  | Type of Env.t * Errortrace.comparison Errortrace.t
+  | Arity
+  | Inline_record of record_mismatch
+  | Kind of position
+  | Explicit_return_type of position
+
+type variant_mismatch =
+  | Constructor_mismatch of constructor_declaration
+                            * constructor_declaration
+                            * constructor_mismatch
+  | Constructor_names of int * Ident.t * Ident.t
+  | Constructor_missing of position * Ident.t
+
+type extension_constructor_mismatch =
+  | Constructor_privacy
+  | Constructor_mismatch of Ident.t
+                            * extension_constructor
+                            * extension_constructor
+                            * constructor_mismatch
+
+type private_variant_mismatch =
+  | Openness
+  | Missing of position * string
+  | Presence of string
+  | Incompatible_types_for of string
+  | Types of Env.t * Errortrace.comparison Errortrace.t
+
+type private_object_mismatch =
+  | Missing of string
+  | Types of Env.t * Errortrace.comparison Errortrace.t
+
+type type_mismatch =
+  | Arity
+  | Privacy
+  | Kind
+  | Constraint of Env.t * Errortrace.comparison Errortrace.t
+  | Manifest of Env.t * Errortrace.comparison Errortrace.t
+  | Private_variant of type_expr * type_expr * private_variant_mismatch
+  | Private_object of type_expr * type_expr * private_object_mismatch
+  | Variance
+  | Record_mismatch of record_mismatch
+  | Variant_mismatch of variant_mismatch
+  | Unboxed_representation of position
+  | Immediate of Type_immediacy.Violation.t
+
+val value_descriptions:
+  loc:Location.t -> Env.t -> string ->
+  value_description -> value_description -> module_coercion
+
+val type_declarations:
+  ?equality:bool ->
+  loc:Location.t ->
+  Env.t -> mark:bool -> string ->
+  type_declaration -> Path.t -> type_declaration -> type_mismatch option
+
+val extension_constructors:
+  loc:Location.t -> Env.t -> mark:bool -> Ident.t ->
+  extension_constructor -> extension_constructor ->
+  extension_constructor_mismatch option
+(*
+val class_types:
+        Env.t -> class_type -> class_type -> bool
+*)
+
+val report_type_mismatch:
+    string -> string -> string -> Format.formatter -> type_mismatch -> unit
+val report_extension_constructor_mismatch: string -> string -> string ->
+  Format.formatter -> extension_constructor_mismatch -> unit
diff --git a/upstream/ocaml_413/typing/includemod.ml b/upstream/ocaml_413/typing/includemod.ml
new file mode 100644
index 0000000..1b542d5
--- /dev/null
+++ b/upstream/ocaml_413/typing/includemod.ml
@@ -0,0 +1,1024 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the module language *)
+
+open Misc
+open Typedtree
+open Types
+
+type symptom =
+    Missing_field of Ident.t * Location.t * string (* kind *)
+  | Value_descriptions of Ident.t * value_description * value_description
+                          * Includecore.value_mismatch
+  | Type_declarations of Ident.t * type_declaration
+        * type_declaration * Includecore.type_mismatch
+  | Extension_constructors of Ident.t * extension_constructor
+        * extension_constructor * Includecore.extension_constructor_mismatch
+  | Module_types of module_type * module_type
+  | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration
+  | Modtype_permutation of Types.module_type * Typedtree.module_coercion
+  | Interface_mismatch of string * string
+  | Class_type_declarations of
+      Ident.t * class_type_declaration * class_type_declaration *
+      Ctype.class_match_failure list
+  | Class_declarations of
+      Ident.t * class_declaration * class_declaration *
+      Ctype.class_match_failure list
+  | Unbound_module_path of Path.t
+  | Invalid_module_alias of Path.t
+
+type pos =
+  | Module of Ident.t
+  | Modtype of Ident.t
+  | Arg of functor_parameter
+  | Body of functor_parameter
+
+
+module Error = struct
+
+  type functor_arg_descr =
+    | Anonymous
+    | Named of Path.t
+    | Unit
+
+  type ('a,'b) diff = {got:'a; expected:'a; symptom:'b}
+  type 'a core_diff =('a,unit) diff
+  let diff x y s = {got=x;expected=y; symptom=s}
+  let sdiff x y = {got=x; expected=y; symptom=()}
+
+  type core_sigitem_symptom =
+    | Value_descriptions of value_description core_diff
+    | Type_declarations of (type_declaration, Includecore.type_mismatch) diff
+    | Extension_constructors of
+        (extension_constructor, Includecore.extension_constructor_mismatch) diff
+    | Class_type_declarations of
+        (class_type_declaration, Ctype.class_match_failure list) diff
+    | Class_declarations of
+        (class_declaration, Ctype.class_match_failure list) diff
+
+  type core_module_type_symptom =
+    | Not_an_alias
+    | Not_an_identifier
+    | Incompatible_aliases
+    | Abstract_module_type
+    | Unbound_module_path of Path.t
+
+  type module_type_symptom =
+    | Mt_core of core_module_type_symptom
+    | Signature of signature_symptom
+    | Functor of functor_symptom
+    | Invalid_module_alias of Path.t
+    | After_alias_expansion of module_type_diff
+
+
+  and module_type_diff = (module_type, module_type_symptom) diff
+
+  and functor_symptom =
+    | Params of functor_params_diff
+    | Result of module_type_diff
+
+  and ('arg,'path) functor_param_symptom =
+    | Incompatible_params of 'arg * functor_parameter
+    | Mismatch of module_type_diff
+
+  and arg_functor_param_symptom =
+    (functor_parameter, Ident.t) functor_param_symptom
+
+  and functor_params_diff = (functor_parameter list * module_type) core_diff
+
+  and signature_symptom = {
+    env: Env.t;
+    missings: signature_item list;
+    incompatibles: (Ident.t * sigitem_symptom) list;
+    oks: (int * module_coercion) list;
+  }
+  and sigitem_symptom =
+    | Core of core_sigitem_symptom
+    | Module_type_declaration of
+        (modtype_declaration, module_type_declaration_symptom) diff
+    | Module_type of module_type_diff
+
+  and module_type_declaration_symptom =
+    | Illegal_permutation of Typedtree.module_coercion
+    | Not_greater_than of module_type_diff
+    | Not_less_than of module_type_diff
+    | Incomparable of
+        {less_than:module_type_diff; greater_than: module_type_diff}
+
+
+  type all =
+    | In_Compilation_unit of (string, signature_symptom) diff
+    | In_Signature of signature_symptom
+    | In_Module_type of module_type_diff
+    | In_Module_type_substitution of
+        Ident.t * (Types.module_type,module_type_declaration_symptom) diff
+    | In_Type_declaration of Ident.t * core_sigitem_symptom
+    | In_Expansion of core_module_type_symptom
+
+end
+
+type mark =
+  | Mark_both
+  | Mark_positive
+  | Mark_negative
+  | Mark_neither
+
+let negate_mark = function
+  | Mark_both -> Mark_both
+  | Mark_positive -> Mark_negative
+  | Mark_negative -> Mark_positive
+  | Mark_neither -> Mark_neither
+
+let mark_positive = function
+  | Mark_both | Mark_positive -> true
+  | Mark_negative | Mark_neither -> false
+
+(* All functions "blah env x1 x2" check that x1 is included in x2,
+   i.e. that x1 is the type of an implementation that fulfills the
+   specification x2. If not, Error is raised with a backtrace of the error. *)
+
+(* Inclusion between value descriptions *)
+
+let value_descriptions ~loc env ~mark subst id vd1 vd2 =
+  Cmt_format.record_value_dependency vd1 vd2;
+  if mark_positive mark then
+    Env.mark_value_used vd1.val_uid;
+  let vd2 = Subst.value_description subst vd2 in
+  try
+    Ok (Includecore.value_descriptions ~loc env (Ident.name id) vd1 vd2)
+  with Includecore.Dont_match _err ->
+    Error Error.(Core (Value_descriptions (sdiff vd1 vd2)))
+
+(* Inclusion between type declarations *)
+
+let type_declarations ~loc env ~mark ?old_env:_ subst id decl1 decl2 =
+  let mark = mark_positive mark in
+  if mark then
+    Env.mark_type_used decl1.type_uid;
+  let decl2 = Subst.type_declaration subst decl2 in
+  match
+    Includecore.type_declarations ~loc env ~mark
+      (Ident.name id) decl1 (Path.Pident id) decl2
+  with
+  | None -> Ok Tcoerce_none
+  | Some err ->
+      Error Error.(Core(Type_declarations (diff decl1 decl2 err)))
+
+(* Inclusion between extension constructors *)
+
+let extension_constructors ~loc env ~mark  subst id ext1 ext2 =
+  let mark = mark_positive mark in
+  let ext2 = Subst.extension_constructor subst ext2 in
+  match Includecore.extension_constructors ~loc env ~mark id ext1 ext2 with
+  | None -> Ok Tcoerce_none
+  | Some err ->
+      Error Error.(Core(Extension_constructors(diff ext1 ext2 err)))
+
+(* Inclusion between class declarations *)
+
+let class_type_declarations ~loc ~old_env:_ env  subst decl1 decl2 =
+  let decl2 = Subst.cltype_declaration subst decl2 in
+  match Includeclass.class_type_declarations ~loc env decl1 decl2 with
+    []     -> Ok Tcoerce_none
+  | reason ->
+      Error Error.(Core(Class_type_declarations(diff decl1 decl2 reason)))
+
+let class_declarations ~old_env:_ env  subst decl1 decl2 =
+  let decl2 = Subst.class_declaration subst decl2 in
+  match Includeclass.class_declarations env decl1 decl2 with
+    []     -> Ok Tcoerce_none
+  | reason ->
+     Error Error.(Core(Class_declarations(diff decl1 decl2 reason)))
+
+(* Expand a module type identifier when possible *)
+
+let expand_modtype_path env path =
+   match Env.find_modtype_expansion path env with
+     | exception Not_found -> None
+     | x -> Some x
+
+let expand_module_alias env path =
+  match (Env.find_module path env).md_type with
+  | x -> Ok x
+  | exception Not_found -> Error (Error.Unbound_module_path path)
+
+(* Extract name, kind and ident from a signature item *)
+
+type field_kind =
+  | Field_value
+  | Field_type
+  | Field_exception
+  | Field_typext
+  | Field_module
+  | Field_modtype
+  | Field_class
+  | Field_classtype
+
+
+
+type field_desc = { name: string; kind: field_kind }
+
+let kind_of_field_desc fd = match fd.kind with
+  | Field_value -> "value"
+  | Field_type -> "type"
+  | Field_exception -> "exception"
+  | Field_typext -> "extension constructor"
+  | Field_module -> "module"
+  | Field_modtype -> "module type"
+  | Field_class -> "class"
+  | Field_classtype -> "class type"
+
+let field_desc kind id = { kind; name = Ident.name id }
+
+(** Map indexed by both field types and names.
+    This avoids name clashes between different sorts of fields
+    such as values and types. *)
+module FieldMap = Map.Make(struct
+    type t = field_desc
+    let compare = Stdlib.compare
+  end)
+
+let item_ident_name = function
+    Sig_value(id, d, _) -> (id, d.val_loc, field_desc Field_value id)
+  | Sig_type(id, d, _, _) -> (id, d.type_loc, field_desc Field_type  id )
+  | Sig_typext(id, d, _, _) ->
+      let kind =
+        if Path.same d.ext_type_path Predef.path_exn
+        then Field_exception
+        else Field_typext
+      in
+      (id, d.ext_loc, field_desc kind id)
+  | Sig_module(id, _, d, _, _) -> (id, d.md_loc, field_desc Field_module id)
+  | Sig_modtype(id, d, _) -> (id, d.mtd_loc, field_desc Field_modtype id)
+  | Sig_class(id, d, _, _) -> (id, d.cty_loc, field_desc Field_class id)
+  | Sig_class_type(id, d, _, _) ->
+      (id, d.clty_loc, field_desc Field_classtype id)
+
+let is_runtime_component = function
+  | Sig_value(_,{val_kind = Val_prim _}, _)
+  | Sig_type(_,_,_,_)
+  | Sig_module(_,Mp_absent,_,_,_)
+  | Sig_modtype(_,_,_)
+  | Sig_class_type(_,_,_,_) -> false
+  | Sig_value(_,_,_)
+  | Sig_typext(_,_,_,_)
+  | Sig_module(_,Mp_present,_,_,_)
+  | Sig_class(_,_,_,_) -> true
+
+(* Print a coercion *)
+
+let rec print_list pr ppf = function
+    [] -> ()
+  | [a] -> pr ppf a
+  | a :: l -> pr ppf a; Format.fprintf ppf ";@ "; print_list pr ppf l
+let print_list pr ppf l =
+  Format.fprintf ppf "[@[%a@]]" (print_list pr) l
+
+let rec print_coercion ppf c =
+  let pr fmt = Format.fprintf ppf fmt in
+  match c with
+    Tcoerce_none -> pr "id"
+  | Tcoerce_structure (fl, nl) ->
+      pr "@[<2>struct@ %a@ %a@]"
+        (print_list print_coercion2) fl
+        (print_list print_coercion3) nl
+  | Tcoerce_functor (inp, out) ->
+      pr "@[<2>functor@ (%a)@ (%a)@]"
+        print_coercion inp
+        print_coercion out
+  | Tcoerce_primitive {pc_desc; pc_env = _; pc_type}  ->
+      pr "prim %s@ (%a)" pc_desc.Primitive.prim_name
+        Printtyp.raw_type_expr pc_type
+  | Tcoerce_alias (_, p, c) ->
+      pr "@[<2>alias %a@ (%a)@]"
+        Printtyp.path p
+        print_coercion c
+and print_coercion2 ppf (n, c) =
+  Format.fprintf ppf "@[%d,@ %a@]" n print_coercion c
+and print_coercion3 ppf (i, n, c) =
+  Format.fprintf ppf "@[%s, %d,@ %a@]"
+    (Ident.unique_name i) n print_coercion c
+
+(* Simplify a structure coercion *)
+
+let equal_module_paths env p1 subst p2 =
+  Path.same p1 p2
+  || Path.same (Env.normalize_module_path None env p1)
+       (Env.normalize_module_path None env
+          (Subst.module_path subst p2))
+
+let equal_modtype_paths env p1 subst p2 =
+  Path.same p1 p2
+  || Path.same (Env.normalize_modtype_path env p1)
+       (Env.normalize_modtype_path env
+          (Subst.modtype_path subst p2))
+
+let simplify_structure_coercion cc id_pos_list =
+  let rec is_identity_coercion pos = function
+  | [] ->
+      true
+  | (n, c) :: rem ->
+      n = pos && c = Tcoerce_none && is_identity_coercion (pos + 1) rem in
+  if is_identity_coercion 0 cc
+  then Tcoerce_none
+  else Tcoerce_structure (cc, id_pos_list)
+
+let retrieve_functor_params env mty =
+  let rec retrieve_functor_params before env =
+    function
+    | Mty_ident p as res ->
+        begin match expand_modtype_path env p with
+        | Some mty -> retrieve_functor_params before env mty
+        | None -> List.rev before, res
+        end
+    | Mty_alias p as res ->
+        begin match expand_module_alias env p with
+        | Ok mty ->  retrieve_functor_params before env mty
+        | Error _ -> List.rev before, res
+        end
+    | Mty_functor (p, res) -> retrieve_functor_params (p :: before) env res
+    | Mty_signature _ as res -> List.rev before, res
+  in
+  retrieve_functor_params [] env mty
+
+(* Inclusion between module types.
+   Return the restriction that transforms a value of the smaller type
+   into a value of the bigger type. *)
+
+let rec modtypes ~loc env ~mark subst mty1 mty2 =
+  match try_modtypes ~loc env ~mark subst mty1 mty2 with
+  | Ok _ as ok -> ok
+  | Error reason ->
+    let mty2 = Subst.modtype Make_local subst mty2 in
+    Error Error.(diff mty1 mty2 reason)
+
+and try_modtypes ~loc env ~mark subst mty1 mty2 =
+  match mty1, mty2 with
+  | (Mty_alias p1, Mty_alias p2) ->
+      if Env.is_functor_arg p2 env then
+        Error (Error.Invalid_module_alias p2)
+      else if not (equal_module_paths env p1 subst p2) then
+          Error Error.(Mt_core Incompatible_aliases)
+      else Ok Tcoerce_none
+  | (Mty_alias p1, _) -> begin
+      match
+        Env.normalize_module_path (Some Location.none) env p1
+      with
+      | exception Env.Error (Env.Missing_module (_, _, path)) ->
+          Error Error.(Mt_core(Unbound_module_path path))
+      | p1 ->
+          begin match expand_module_alias env  p1 with
+          | Error e -> Error (Error.Mt_core e)
+          | Ok mty1 ->
+              match strengthened_modtypes ~loc ~aliasable:true env ~mark
+                      subst mty1 p1 mty2
+              with
+              | Ok _ as x -> x
+              | Error reason -> Error (Error.After_alias_expansion reason)
+          end
+    end
+  | (Mty_ident p1, Mty_ident p2) ->
+      let p1 = Env.normalize_modtype_path env p1 in
+      let p2 = Env.normalize_modtype_path env (Subst.modtype_path subst p2) in
+      if Path.same p1 p2 then Ok Tcoerce_none
+      else
+        begin match expand_modtype_path env p1, expand_modtype_path env p2 with
+        | Some mty1, Some mty2 ->
+            try_modtypes ~loc env ~mark subst mty1 mty2
+        | None, _  | _, None -> Error (Error.Mt_core Abstract_module_type)
+        end
+  | (Mty_ident p1, _) ->
+      let p1 = Env.normalize_modtype_path env p1 in
+      begin match expand_modtype_path env p1 with
+      | Some p1 ->
+          try_modtypes ~loc env ~mark subst p1 mty2
+      | None -> Error (Error.Mt_core Abstract_module_type)
+      end
+  | (_, Mty_ident p2) ->
+      let p2 = Env.normalize_modtype_path env (Subst.modtype_path subst p2) in
+      begin match expand_modtype_path env p2 with
+      | Some p2 -> try_modtypes ~loc env ~mark subst mty1 p2
+      | None ->
+          begin match mty1 with
+          | Mty_functor _ ->
+              let params1 = retrieve_functor_params env mty1 in
+              let d = Error.sdiff params1 ([],mty2) in
+              Error Error.(Functor (Params d))
+          | _ -> Error Error.(Mt_core Not_an_identifier)
+          end
+      end
+  | (Mty_signature sig1, Mty_signature sig2) ->
+      begin match signatures ~loc env ~mark subst sig1 sig2 with
+      | Ok _ as ok -> ok
+      | Error e -> Error (Error.Signature e)
+      end
+  | Mty_functor (param1, res1), Mty_functor (param2, res2) ->
+      let cc_arg, env, subst =
+        functor_param ~loc env ~mark:(negate_mark mark) subst param1 param2
+      in
+      let cc_res = modtypes ~loc env ~mark subst res1 res2 in
+      begin match cc_arg, cc_res with
+      | Ok Tcoerce_none, Ok Tcoerce_none -> Ok Tcoerce_none
+      | Ok cc_arg, Ok cc_res -> Ok (Tcoerce_functor(cc_arg, cc_res))
+      | _, Error {Error.symptom = Error.Functor Error.Params res; _} ->
+          let got_params, got_res = res.got in
+          let expected_params, expected_res = res.expected in
+          let d = Error.sdiff
+              (param1::got_params, got_res)
+              (param2::expected_params, expected_res) in
+          Error Error.(Functor (Params d))
+      | Error _, _ ->
+          let params1, res1 = retrieve_functor_params env res1 in
+          let params2, res2 = retrieve_functor_params env res2 in
+          let d = Error.sdiff (param1::params1, res1) (param2::params2, res2) in
+          Error Error.(Functor (Params d))
+      | Ok _, Error res ->
+          Error Error.(Functor (Result res))
+      end
+  | Mty_functor _, _
+  | _, Mty_functor _ ->
+      let params1 = retrieve_functor_params env mty1 in
+      let params2 = retrieve_functor_params env mty2 in
+      let d = Error.sdiff params1 params2 in
+      Error Error.(Functor (Params d))
+  | _, Mty_alias _ ->
+      Error (Error.Mt_core Error.Not_an_alias)
+
+(* Functor parameters *)
+
+and functor_param ~loc env ~mark subst param1 param2 = match param1, param2 with
+  | Unit, Unit ->
+      Ok Tcoerce_none, env, subst
+  | Named (name1, arg1), Named (name2, arg2) ->
+      let arg2' = Subst.modtype Keep subst arg2 in
+      let cc_arg =
+        match modtypes ~loc env ~mark Subst.identity arg2' arg1 with
+        | Ok cc -> Ok cc
+        | Error err -> Error (Error.Mismatch err)
+      in
+      let env, subst =
+        match name1, name2 with
+        | Some id1, Some id2 ->
+            Env.add_module id1 Mp_present arg2' env,
+            Subst.add_module id2 (Path.Pident id1) subst
+        | None, Some id2 ->
+            Env.add_module id2 Mp_present arg2' env, subst
+        | Some id1, None ->
+            Env.add_module id1 Mp_present arg2' env, subst
+        | None, None ->
+            env, subst
+      in
+      cc_arg, env, subst
+  | _, _ ->
+      Error (Error.Incompatible_params (param1, param2)), env, subst
+
+and strengthened_modtypes ~loc ~aliasable env ~mark subst mty1 path1 mty2 =
+  match mty1, mty2 with
+  | Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 ->
+      Ok Tcoerce_none
+  | _, _ ->
+      let mty1 = Mtype.strengthen ~aliasable env mty1 path1 in
+      modtypes ~loc env ~mark subst mty1 mty2
+
+and strengthened_module_decl ~loc ~aliasable env ~mark subst md1 path1 md2 =
+  match md1.md_type, md2.md_type with
+  | Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 ->
+      Ok Tcoerce_none
+  | _, _ ->
+      let md1 = Mtype.strengthen_decl ~aliasable env md1 path1 in
+      modtypes ~loc env ~mark subst md1.md_type md2.md_type
+
+(* Inclusion between signatures *)
+
+and signatures ~loc env ~mark subst sig1 sig2 =
+  (* Environment used to check inclusion of components *)
+  let new_env =
+    Env.add_signature sig1 (Env.in_signature true env) in
+  (* Keep ids for module aliases *)
+  let (id_pos_list,_) =
+    List.fold_left
+      (fun (l,pos) -> function
+          Sig_module (id, Mp_present, _, _, _) ->
+            ((id,pos,Tcoerce_none)::l , pos+1)
+        | item -> (l, if is_runtime_component item then pos+1 else pos))
+      ([], 0) sig1 in
+  (* Build a table of the components of sig1, along with their positions.
+     The table is indexed by kind and name of component *)
+  let rec build_component_table pos tbl = function
+      [] -> pos, tbl
+    | (Sig_value (_, _, Hidden)
+      |Sig_type (_, _, _, Hidden)
+      |Sig_typext (_, _, _, Hidden)
+      |Sig_module (_, _, _, _, Hidden)
+      |Sig_modtype (_, _, Hidden)
+      |Sig_class (_, _, _, Hidden)
+      |Sig_class_type (_, _, _, Hidden)
+      ) as item :: rem ->
+        let pos = if is_runtime_component item then pos + 1 else pos in
+        build_component_table pos tbl rem (* do not pair private items. *)
+    | item :: rem ->
+        let (id, _loc, name) = item_ident_name item in
+        let pos, nextpos =
+          if is_runtime_component item then pos, pos + 1
+          else -1, pos
+        in
+        build_component_table nextpos
+                              (FieldMap.add name (id, item, pos) tbl) rem in
+  let len1, comps1 =
+    build_component_table 0 FieldMap.empty sig1 in
+  let len2 =
+    List.fold_left
+      (fun n i -> if is_runtime_component i then n + 1 else n)
+      0
+      sig2
+  in
+  (* Pair each component of sig2 with a component of sig1,
+     identifying the names along the way.
+     Return a coercion list indicating, for all run-time components
+     of sig2, the position of the matching run-time components of sig1
+     and the coercion to be applied to it. *)
+  let rec pair_components subst paired unpaired = function
+      [] ->
+        let oks, errors =
+          signature_components ~loc env ~mark new_env subst (List.rev paired) in
+        begin match unpaired, errors, oks with
+            | [], [], cc ->
+                if len1 = len2 then (* see PR#5098 *)
+                  Ok (simplify_structure_coercion cc id_pos_list)
+                else
+                  Ok (Tcoerce_structure (cc, id_pos_list))
+            | missings, incompatibles, cc ->
+                Error { env=new_env; Error.missings; incompatibles; oks=cc }
+        end
+    | item2 :: rem ->
+        let (id2, _loc, name2) = item_ident_name item2 in
+        let name2, report =
+          match item2, name2 with
+            Sig_type (_, {type_manifest=None}, _, _), {name=s; kind=Field_type}
+            when Btype.is_row_name s ->
+              (* Do not report in case of failure,
+                 as the main type will generate an error *)
+              { kind=Field_type; name=String.sub s 0 (String.length s - 4) },
+              false
+          | _ -> name2, true
+        in
+        begin try
+          let (id1, item1, pos1) = FieldMap.find name2 comps1 in
+          let new_subst =
+            match item2 with
+              Sig_type _ ->
+                Subst.add_type id2 (Path.Pident id1) subst
+            | Sig_module _ ->
+                Subst.add_module id2 (Path.Pident id1) subst
+            | Sig_modtype _ ->
+                Subst.add_modtype id2 (Mty_ident (Path.Pident id1)) subst
+            | Sig_value _ | Sig_typext _
+            | Sig_class _ | Sig_class_type _ ->
+                subst
+          in
+          pair_components new_subst
+            ((item1, item2, pos1) :: paired) unpaired rem
+        with Not_found ->
+          let unpaired =
+            if report then
+              item2 :: unpaired
+            else unpaired in
+          pair_components subst paired unpaired rem
+        end in
+  (* Do the pairing and checking, and return the final coercion *)
+  pair_components subst [] [] sig2
+
+(* Inclusion between signature components *)
+
+and signature_components ~loc old_env ~mark env subst paired =
+  match paired with
+  | [] -> [], []
+  | (sigi1, sigi2, pos) :: rem ->
+      let id, item, present_at_runtime =
+        match sigi1, sigi2 with
+        | Sig_value(id1, valdecl1, _) ,Sig_value(_id2, valdecl2, _) ->
+            let item =
+              value_descriptions ~loc env ~mark subst id1 valdecl1 valdecl2
+            in
+            let present_at_runtime = match valdecl2.val_kind with
+              | Val_prim _ -> false
+              | _ -> true
+            in
+            id1, item, present_at_runtime
+        | Sig_type(id1, tydec1, _, _), Sig_type(_id2, tydec2, _, _) ->
+            let item =
+              type_declarations ~loc ~old_env env ~mark subst id1 tydec1 tydec2
+            in
+            id1, item, false
+        | Sig_typext(id1, ext1, _, _), Sig_typext(_id2, ext2, _, _) ->
+            let item =
+              extension_constructors ~loc env ~mark  subst id1 ext1 ext2
+            in
+            id1, item, true
+        | Sig_module(id1, pres1, mty1, _, _), Sig_module(_, pres2, mty2, _, _)
+          -> begin
+              let item =
+                module_declarations ~loc env ~mark subst id1 mty1 mty2
+              in
+              let item =
+                Result.map_error (fun diff -> Error.Module_type diff) item
+              in
+              let present_at_runtime, item =
+                match pres1, pres2, mty1.md_type with
+                | Mp_present, Mp_present, _ -> true, item
+                | _, Mp_absent, _ -> false, item
+                | Mp_absent, Mp_present, Mty_alias p1 ->
+                    true, Result.map (fun i -> Tcoerce_alias (env, p1, i)) item
+                | Mp_absent, Mp_present, _ -> assert false
+              in
+              id1, item, present_at_runtime
+            end
+        | Sig_modtype(id1, info1, _), Sig_modtype(_id2, info2, _) ->
+            let item =
+              modtype_infos ~loc env ~mark  subst id1 info1 info2
+            in
+            id1, item, false
+        | Sig_class(id1, decl1, _, _), Sig_class(_id2, decl2, _, _) ->
+            let item =
+              class_declarations ~old_env env subst decl1 decl2
+            in
+            id1, item, true
+        | Sig_class_type(id1, info1, _, _), Sig_class_type(_id2, info2, _, _) ->
+            let item =
+              class_type_declarations ~loc ~old_env env subst info1 info2
+            in
+            id1, item, false
+        | _ ->
+            assert false
+      in
+      let oks, errors =
+        signature_components ~loc old_env ~mark env subst rem
+      in
+      match item with
+      | Ok x when present_at_runtime -> (pos,x) :: oks, errors
+      | Ok _ -> oks, errors
+      | Error y -> oks , (id,y) :: errors
+
+and module_declarations ~loc env ~mark  subst id1 md1 md2 =
+  Builtin_attributes.check_alerts_inclusion
+    ~def:md1.md_loc
+    ~use:md2.md_loc
+    loc
+    md1.md_attributes md2.md_attributes
+    (Ident.name id1);
+  let p1 = Path.Pident id1 in
+  if mark_positive mark then
+    Env.mark_module_used md1.md_uid;
+  strengthened_modtypes ~loc ~aliasable:true env ~mark subst
+    md1.md_type p1 md2.md_type
+
+(* Inclusion between module type specifications *)
+
+and modtype_infos ~loc env ~mark subst id info1 info2 =
+  Builtin_attributes.check_alerts_inclusion
+    ~def:info1.mtd_loc
+    ~use:info2.mtd_loc
+    loc
+    info1.mtd_attributes info2.mtd_attributes
+    (Ident.name id);
+  let info2 = Subst.modtype_declaration Keep subst info2 in
+  let r =
+    match (info1.mtd_type, info2.mtd_type) with
+      (None, None) -> Ok Tcoerce_none
+    | (Some _, None) -> Ok Tcoerce_none
+    | (Some mty1, Some mty2) ->
+        check_modtype_equiv ~loc env ~mark mty1 mty2
+    | (None, Some mty2) ->
+        check_modtype_equiv ~loc env ~mark (Mty_ident(Path.Pident id)) mty2 in
+  match r with
+  | Ok _ as ok -> ok
+  | Error e -> Error Error.(Module_type_declaration (diff info1 info2 e))
+
+and check_modtype_equiv ~loc env ~mark mty1 mty2 =
+  match
+    (modtypes ~loc env ~mark Subst.identity mty1 mty2,
+     modtypes ~loc env ~mark:(negate_mark mark) Subst.identity mty2 mty1)
+  with
+    (Ok Tcoerce_none, Ok Tcoerce_none) -> Ok Tcoerce_none
+  | (Ok c1, Ok _c2) ->
+      (* Format.eprintf "@[c1 = %a@ c2 = %a@]@."
+        print_coercion _c1 print_coercion _c2; *)
+      Error Error.(Illegal_permutation c1)
+  | Ok _, Error e -> Error Error.(Not_greater_than e)
+  | Error e, Ok _ -> Error Error.(Not_less_than e)
+  | Error less_than, Error greater_than ->
+      Error Error.(Incomparable {less_than; greater_than})
+
+
+(* Simplified inclusion check between module types (for Env) *)
+
+let can_alias env path =
+  let rec no_apply = function
+    | Path.Pident _ -> true
+    | Path.Pdot(p, _) -> no_apply p
+    | Path.Papply _ -> false
+  in
+  no_apply path && not (Env.is_functor_arg path env)
+
+
+
+type explanation = Env.t * Error.all
+exception Error of explanation
+
+exception Apply_error of {
+    loc : Location.t ;
+    env : Env.t ;
+    lid_app : Longident.t option ;
+    mty_f : module_type ;
+    args : (Error.functor_arg_descr * module_type) list ;
+  }
+
+let check_modtype_inclusion_raw ~loc env mty1 path1 mty2 =
+  let aliasable = can_alias env path1 in
+  strengthened_modtypes ~loc ~aliasable env ~mark:Mark_both
+    Subst.identity mty1 path1 mty2
+
+let check_modtype_inclusion ~loc env mty1 path1 mty2 =
+  match check_modtype_inclusion_raw ~loc env mty1 path1 mty2 with
+  | Ok _ -> None
+  | Error e -> Some (env, Error.In_Module_type e)
+
+let check_functor_application_in_path
+    ~errors ~loc ~lid_whole_app ~f0_path ~args
+    ~arg_path ~arg_mty ~param_mty env =
+  match check_modtype_inclusion_raw ~loc env arg_mty arg_path param_mty with
+  | Ok _ -> ()
+  | Error _errs ->
+      if errors then
+        let prepare_arg (arg_path, arg_mty) =
+          let aliasable = can_alias env arg_path in
+          let smd = Mtype.strengthen ~aliasable env arg_mty arg_path in
+          (Error.Named arg_path, smd)
+        in
+        let mty_f = (Env.find_module f0_path env).md_type in
+        let args = List.map prepare_arg args in
+        let lid_app = Some lid_whole_app in
+        raise (Apply_error {loc; env; lid_app; mty_f; args})
+      else
+        raise Not_found
+
+let () =
+  Env.check_functor_application := check_functor_application_in_path
+
+
+(* Check that an implementation of a compilation unit meets its
+   interface. *)
+
+let compunit env ~mark impl_name impl_sig intf_name intf_sig =
+  match
+    signatures ~loc:(Location.in_file impl_name) env ~mark Subst.identity
+      impl_sig intf_sig
+  with Result.Error reasons ->
+    let cdiff =
+      Error.In_Compilation_unit(Error.diff impl_name intf_name reasons) in
+    raise(Error(env, cdiff))
+  | Ok x -> x
+
+(* Functor diffing computation:
+   The diffing computation uses the internal typing function
+ *)
+
+module Functor_inclusion_diff = struct
+  open Diffing
+
+  let param_name = function
+      | Named(x,_) -> x
+      | Unit -> None
+
+  let weight = function
+    | Insert _ -> 10
+    | Delete _ -> 10
+    | Change _ -> 10
+    | Keep (param1, param2, _) -> begin
+        match param_name param1, param_name param2 with
+        | None, None
+          -> 0
+        | Some n1, Some n2
+          when String.equal (Ident.name n1) (Ident.name n2)
+          -> 0
+        | Some _, Some _ -> 1
+        | Some _,  None | None, Some _ -> 1
+      end
+
+  type state = {
+    res: module_type option;
+    env: Env.t;
+    subst: Subst.t;
+  }
+
+  let keep_expansible_param = function
+    | Mty_ident _ | Mty_alias _ as mty -> Some mty
+    | Mty_signature _ | Mty_functor _ -> None
+
+  let lookup_expansion { env ; res ; _ } = match res with
+    | None -> None
+    | Some res ->
+        match retrieve_functor_params env res with
+        | [], _ -> None
+        | params, res ->
+            let more = Array.of_list params  in
+            Some (keep_expansible_param res, more)
+
+  let expand_params state  =
+    match lookup_expansion state with
+    | None -> state, [||]
+    | Some (res, expansion) -> { state with res }, expansion
+
+  let update d st = match d with
+    | Insert (Unit | Named (None,_))
+    | Delete (Unit | Named (None,_))
+    | Keep (Unit,_,_)
+    | Keep (_,Unit,_)
+    | Change (_,(Unit | Named (None,_)), _) ->
+        st, [||]
+    | Insert (Named (Some id, arg))
+    | Delete (Named (Some id, arg))
+    | Change (Unit, Named (Some id, arg), _) ->
+        let arg' = Subst.modtype Keep st.subst arg in
+        let env = Env.add_module id Mp_present arg' st.env in
+        expand_params { st with env }
+    | Keep (Named (name1, _), Named (name2, arg2), _)
+    | Change (Named (name1, _), Named (name2, arg2), _) -> begin
+        let arg' = Subst.modtype Keep st.subst arg2 in
+        match name1, name2 with
+        | Some id1, Some id2 ->
+            let env = Env.add_module id1 Mp_present arg' st.env in
+            let subst = Subst.add_module id2 (Path.Pident id1) st.subst in
+            expand_params { st with env; subst }
+        | None, Some id2 ->
+            let env = Env.add_module id2 Mp_present arg' st.env in
+            { st with env }, [||]
+        | Some id1, None ->
+            let env = Env.add_module id1 Mp_present arg' st.env in
+            expand_params { st with env }
+        | None, None ->
+            st, [||]
+      end
+
+  let diff env (l1,res1) (l2,_) =
+    let update = Diffing.With_left_extensions update in
+    let test st mty1 mty2 =
+      let loc = Location.none in
+      let res, _, _ =
+        functor_param ~loc st.env ~mark:Mark_neither st.subst mty1 mty2
+      in
+      res
+    in
+    let param1 = Array.of_list l1 in
+    let param2 = Array.of_list l2 in
+    let state =
+      { env; subst = Subst.identity; res = keep_expansible_param res1}
+    in
+    Diffing.variadic_diff ~weight ~test ~update state param1 param2
+
+end
+
+module Functor_app_diff = struct
+  module I = Functor_inclusion_diff
+  open Diffing
+
+  let weight = function
+    | Insert _ -> 10
+    | Delete _ -> 10
+    | Change _ -> 10
+    | Keep (param1, param2, _) ->
+        (* We assign a small penalty to named arguments with
+           non-matching names *)
+        begin
+          let desc1 : Error.functor_arg_descr = fst param1 in
+          match desc1, I.param_name param2 with
+          | (Unit | Anonymous) , None
+            -> 0
+          | Named (Path.Pident n1), Some n2
+            when String.equal (Ident.name n1) (Ident.name n2)
+            -> 0
+          | Named _, Some _ -> 1
+          | Named _,  None | (Unit | Anonymous), Some _ -> 1
+        end
+
+  let update (d: (_,Types.functor_parameter,_,_) change) (st:I.state) =
+    let open Error in
+    match d with
+    | Insert _
+    | Delete _
+    | Keep ((Unit,_),_,_)
+    | Keep (_,Unit,_)
+    | Change (_,(Unit | Named (None,_)), _ )
+    | Change ((Unit,_), Named (Some _, _), _) ->
+        st, [||]
+    | Keep ((Named arg,  _mty) , Named (param_name, _param), _)
+    | Change ((Named arg, _mty), Named (param_name, _param), _) ->
+        begin match param_name with
+        | Some param ->
+            let res =
+              Option.map (fun res ->
+                  let scope = Ctype.create_scope () in
+                  let subst = Subst.add_module param arg Subst.identity in
+                  Subst.modtype (Rescope scope) subst res
+                )
+                st.res
+            in
+            let subst = Subst.add_module param arg st.subst in
+            I.expand_params { st with subst; res }
+        | None ->
+            st, [||]
+        end
+    | Keep ((Anonymous, mty) , Named (param_name, _param), _)
+    | Change ((Anonymous, mty), Named (param_name, _param), _) -> begin
+        begin match param_name with
+        | Some param ->
+            let mty' = Subst.modtype Keep st.subst mty in
+            let env =
+              Env.add_module ~arg:true param Mp_present mty' st.env in
+            let res =
+              Option.map (Mtype.nondep_supertype env [param]) st.res in
+            I.expand_params { st with env; res}
+        | None ->
+            st, [||]
+        end
+      end
+
+  let diff env ~f ~args =
+    let params, res = retrieve_functor_params env f in
+    let update = Diffing.With_right_extensions update in
+    let test (state:I.state) (arg,arg_mty) param =
+      let loc = Location.none in
+      let res = match (arg:Error.functor_arg_descr), param with
+        | Unit, Unit -> Ok Tcoerce_none
+        | Unit, Named _ | (Anonymous | Named _), Unit ->
+            Result.Error (Error.Incompatible_params(arg,param))
+        | ( Anonymous | Named _ ) , Named (_, param) ->
+            match
+              modtypes ~loc state.env ~mark:Mark_neither state.subst
+                arg_mty param
+            with
+            | Error mty -> Result.Error (Error.Mismatch mty)
+            | Ok _ as x -> x
+      in
+      res
+    in
+    let args = Array.of_list args in
+    let params = Array.of_list params in
+    let state : I.state =
+      { env; subst = Subst.identity; res = I.keep_expansible_param res }
+    in
+    Diffing.variadic_diff ~weight ~test ~update state args params
+
+end
+
+(* Hide the context and substitution parameters to the outside world *)
+
+let modtypes ~loc env ~mark mty1 mty2 =
+  match modtypes ~loc env ~mark Subst.identity mty1 mty2 with
+  | Ok x -> x
+  | Error reason -> raise (Error (env, Error.(In_Module_type reason)))
+let signatures env ~mark sig1 sig2 =
+  match signatures ~loc:Location.none env ~mark Subst.identity sig1 sig2 with
+  | Ok x -> x
+  | Error reason -> raise (Error(env,Error.(In_Signature reason)))
+
+let type_declarations ~loc env ~mark id decl1 decl2 =
+  match type_declarations ~loc env ~mark Subst.identity id decl1 decl2 with
+  | Ok _ -> ()
+  | Error (Error.Core reason) ->
+      raise (Error(env,Error.(In_Type_declaration(id,reason))))
+  | Error _ -> assert false
+
+let strengthened_module_decl ~loc ~aliasable env ~mark md1 path1 md2 =
+  match strengthened_module_decl ~loc ~aliasable env ~mark Subst.identity
+    md1 path1 md2 with
+  | Ok x -> x
+  | Error mdiff ->
+      raise (Error(env,Error.(In_Module_type mdiff)))
+
+let expand_module_alias env path =
+  match expand_module_alias env path with
+  | Ok x -> x
+  | Result.Error _ ->
+      raise (Error(env,In_Expansion(Error.Unbound_module_path path)))
+
+let check_modtype_equiv ~loc env id mty1 mty2 =
+  match check_modtype_equiv ~loc env ~mark:Mark_both mty1 mty2 with
+  | Ok _ -> ()
+  | Error e ->
+      raise (Error(env,
+                   Error.(In_Module_type_substitution (id,diff mty1 mty2 e)))
+            )
diff --git a/upstream/ocaml_413/typing/includemod.mli b/upstream/ocaml_413/typing/includemod.mli
new file mode 100644
index 0000000..f4bd3a6
--- /dev/null
+++ b/upstream/ocaml_413/typing/includemod.mli
@@ -0,0 +1,237 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the module language *)
+
+open Typedtree
+open Types
+
+(** Type describing which arguments of an inclusion to consider as used
+    for the usage warnings. [Mark_both] is the default. *)
+type mark =
+  | Mark_both
+      (** Mark definitions used from both arguments *)
+  | Mark_positive
+      (** Mark definitions used from the positive (first) argument *)
+  | Mark_negative
+      (** Mark definitions used from the negative (second) argument *)
+  | Mark_neither
+      (** Do not mark definitions used from either argument *)
+
+module Error: sig
+
+  type ('elt,'explanation) diff = {
+    got:'elt;
+    expected:'elt;
+    symptom:'explanation
+  }
+  type 'elt core_diff =('elt,unit) diff
+
+  type functor_arg_descr =
+    | Anonymous
+    | Named of Path.t
+    | Unit
+
+  type core_sigitem_symptom =
+    | Value_descriptions of Types.value_description core_diff
+    | Type_declarations of
+        (Types.type_declaration, Includecore.type_mismatch) diff
+    | Extension_constructors of
+        (Types.extension_constructor,
+         Includecore.extension_constructor_mismatch) diff
+    | Class_type_declarations of
+        (Types.class_type_declaration, Ctype.class_match_failure list) diff
+    | Class_declarations of
+        (Types.class_declaration, Ctype.class_match_failure list) diff
+
+  type core_module_type_symptom =
+    | Not_an_alias
+    | Not_an_identifier
+    | Incompatible_aliases
+    | Abstract_module_type
+    | Unbound_module_path of Path.t
+
+  type module_type_symptom =
+    | Mt_core of core_module_type_symptom
+    | Signature of signature_symptom
+    | Functor of functor_symptom
+    | Invalid_module_alias of Path.t
+    | After_alias_expansion of module_type_diff
+
+
+  and module_type_diff = (Types.module_type, module_type_symptom) diff
+
+  and functor_symptom =
+    | Params of functor_params_diff
+    | Result of module_type_diff
+
+  and ('arg,'path) functor_param_symptom =
+    | Incompatible_params of 'arg * Types.functor_parameter
+    | Mismatch of module_type_diff
+
+  and arg_functor_param_symptom =
+    (Types.functor_parameter, Ident.t) functor_param_symptom
+
+  and functor_params_diff =
+    (Types.functor_parameter list * Types.module_type) core_diff
+
+  and signature_symptom = {
+    env: Env.t;
+    missings: Types.signature_item list;
+    incompatibles: (Ident.t * sigitem_symptom) list;
+    oks: (int * Typedtree.module_coercion) list;
+  }
+  and sigitem_symptom =
+    | Core of core_sigitem_symptom
+    | Module_type_declaration of
+        (Types.modtype_declaration, module_type_declaration_symptom) diff
+    | Module_type of module_type_diff
+
+  and module_type_declaration_symptom =
+    | Illegal_permutation of Typedtree.module_coercion
+    | Not_greater_than of module_type_diff
+    | Not_less_than of module_type_diff
+    | Incomparable of
+        {less_than:module_type_diff; greater_than: module_type_diff}
+
+
+  type all =
+    | In_Compilation_unit of (string, signature_symptom) diff
+    | In_Signature of signature_symptom
+    | In_Module_type of module_type_diff
+    | In_Module_type_substitution of
+        Ident.t * (Types.module_type,module_type_declaration_symptom) diff
+    | In_Type_declaration of Ident.t * core_sigitem_symptom
+    | In_Expansion of core_module_type_symptom
+end
+type explanation = Env.t * Error.all
+
+(* Extract name, kind and ident from a signature item *)
+type field_kind =
+  | Field_value
+  | Field_type
+  | Field_exception
+  | Field_typext
+  | Field_module
+  | Field_modtype
+  | Field_class
+  | Field_classtype
+
+type field_desc = { name: string; kind: field_kind }
+
+val kind_of_field_desc: field_desc -> string
+val field_desc: field_kind -> Ident.t -> field_desc
+
+(** Map indexed by both field types and names.
+    This avoids name clashes between different sorts of fields
+    such as values and types. *)
+module FieldMap: Map.S with type key = field_desc
+
+val item_ident_name: Types.signature_item -> Ident.t * Location.t * field_desc
+val is_runtime_component: Types.signature_item -> bool
+
+
+(* Typechecking *)
+
+val modtypes:
+  loc:Location.t -> Env.t -> mark:mark ->
+  module_type -> module_type -> module_coercion
+
+val strengthened_module_decl:
+  loc:Location.t -> aliasable:bool -> Env.t -> mark:mark ->
+  module_declaration -> Path.t -> module_declaration -> module_coercion
+
+val check_modtype_inclusion :
+  loc:Location.t -> Env.t -> Types.module_type -> Path.t -> Types.module_type ->
+  explanation option
+(** [check_modtype_inclusion ~loc env mty1 path1 mty2] checks that the
+    functor application F(M) is well typed, where mty2 is the type of
+    the argument of F and path1/mty1 is the path/unstrenghened type of M. *)
+
+val check_modtype_equiv:
+  loc:Location.t -> Env.t -> Ident.t -> module_type -> module_type -> unit
+
+val signatures: Env.t -> mark:mark ->
+  signature -> signature -> module_coercion
+
+val compunit:
+      Env.t -> mark:mark -> string -> signature ->
+      string -> signature -> module_coercion
+
+val type_declarations:
+  loc:Location.t -> Env.t -> mark:mark ->
+  Ident.t -> type_declaration -> type_declaration -> unit
+
+val print_coercion: Format.formatter -> module_coercion -> unit
+
+type symptom =
+    Missing_field of Ident.t * Location.t * string (* kind *)
+  | Value_descriptions of
+      Ident.t * value_description * value_description
+      * Includecore.value_mismatch
+  | Type_declarations of Ident.t * type_declaration
+        * type_declaration * Includecore.type_mismatch
+  | Extension_constructors of Ident.t * extension_constructor
+        * extension_constructor * Includecore.extension_constructor_mismatch
+  | Module_types of module_type * module_type
+  | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration
+  | Modtype_permutation of Types.module_type * Typedtree.module_coercion
+  | Interface_mismatch of string * string
+  | Class_type_declarations of
+      Ident.t * class_type_declaration * class_type_declaration *
+      Ctype.class_match_failure list
+  | Class_declarations of
+      Ident.t * class_declaration * class_declaration *
+      Ctype.class_match_failure list
+  | Unbound_module_path of Path.t
+  | Invalid_module_alias of Path.t
+
+type pos =
+  | Module of Ident.t
+  | Modtype of Ident.t
+  | Arg of functor_parameter
+  | Body of functor_parameter
+
+exception Error of explanation
+exception Apply_error of {
+    loc : Location.t ;
+    env : Env.t ;
+    lid_app : Longident.t option ;
+    mty_f : module_type ;
+    args : (Error.functor_arg_descr * Types.module_type)  list ;
+  }
+
+val expand_module_alias: Env.t -> Path.t -> Types.module_type
+
+module Functor_inclusion_diff: sig
+  val diff: Env.t ->
+           Types.functor_parameter list * Types.module_type ->
+           Types.functor_parameter list * Types.module_type ->
+           (Types.functor_parameter, Types.functor_parameter,
+            Typedtree.module_coercion,
+            (Types.functor_parameter, 'c) Error.functor_param_symptom)
+           Diffing.patch
+end
+
+module Functor_app_diff: sig
+  val diff:
+    Env.t ->
+    f:Types.module_type ->
+    args:(Error.functor_arg_descr * Types.module_type) list ->
+    (Error.functor_arg_descr * Types.module_type,
+     Types.functor_parameter, Typedtree.module_coercion,
+     (Error.functor_arg_descr, 'a) Error.functor_param_symptom)
+      Diffing.patch
+end
diff --git a/upstream/ocaml_413/typing/includemod_errorprinter.ml b/upstream/ocaml_413/typing/includemod_errorprinter.ml
new file mode 100644
index 0000000..013275b
--- /dev/null
+++ b/upstream/ocaml_413/typing/includemod_errorprinter.ml
@@ -0,0 +1,932 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Florian Angeletti, projet Cambium, Inria Paris             *)
+(*                                                                        *)
+(*   Copyright 2021 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+
+module Context = struct
+  type pos =
+    | Module of Ident.t
+    | Modtype of Ident.t
+    | Arg of Types.functor_parameter
+    | Body of Types.functor_parameter
+
+  let path_of_context = function
+      Module id :: rem ->
+        let rec subm path = function
+          | [] -> path
+          | Module id :: rem -> subm (Path.Pdot (path, Ident.name id)) rem
+          | _ -> assert false
+        in subm (Path.Pident id) rem
+    | _ -> assert false
+
+
+  let rec context ppf = function
+      Module id :: rem ->
+        Format.fprintf ppf "@[<2>module %a%a@]" Printtyp.ident id args rem
+    | Modtype id :: rem ->
+        Format.fprintf ppf "@[<2>module type %a =@ %a@]"
+          Printtyp.ident id context_mty rem
+    | Body x :: rem ->
+        Format.fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem
+    | Arg x :: rem ->
+        Format.fprintf ppf "functor (%s : %a) -> ..."
+          (argname x) context_mty rem
+    | [] ->
+        Format.fprintf ppf "<here>"
+  and context_mty ppf = function
+      (Module _ | Modtype _) :: _ as rem ->
+        Format.fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem
+    | cxt -> context ppf cxt
+  and args ppf = function
+      Body x :: rem ->
+        Format.fprintf ppf "(%s)%a" (argname x) args rem
+    | Arg x :: rem ->
+        Format.fprintf ppf "(%s :@ %a) : ..." (argname  x) context_mty rem
+    | cxt ->
+        Format.fprintf ppf " :@ %a" context_mty cxt
+  and argname = function
+    | Types.Unit -> ""
+    | Types.Named (None, _) -> "_"
+    | Types.Named (Some id, _) -> Ident.name id
+
+  let alt_pp ppf cxt =
+    if cxt = [] then () else
+    if List.for_all (function Module _ -> true | _ -> false) cxt then
+      Format.fprintf ppf "in module %a," Printtyp.path (path_of_context cxt)
+    else
+      Format.fprintf ppf "@[<hv 2>at position@ %a,@]" context cxt
+
+  let pp ppf cxt =
+    if cxt = [] then () else
+    if List.for_all (function Module _ -> true | _ -> false) cxt then
+      Format.fprintf ppf "In module %a:@ " Printtyp.path (path_of_context cxt)
+    else
+      Format.fprintf ppf "@[<hv 2>At position@ %a@]@ " context cxt
+end
+
+module Illegal_permutation = struct
+  (** Extraction of information in case of illegal permutation
+      in a module type *)
+
+  (** When examining coercions, we only have runtime component indices,
+      we use thus a limited version of {!pos}. *)
+  type coerce_pos =
+    | Item of int
+    | InArg
+    | InBody
+
+  let either f x g y = match f x with
+    | None -> g y
+    | Some _ as v -> v
+
+  (** We extract a lone transposition from a full tree of permutations. *)
+  let rec transposition_under path (coerc:Typedtree.module_coercion) =
+    match coerc with
+    | Tcoerce_structure(c,_) ->
+        either
+          (not_fixpoint path 0) c
+          (first_non_id path 0) c
+    | Tcoerce_functor(arg,res) ->
+        either
+          (transposition_under (InArg::path)) arg
+          (transposition_under (InBody::path)) res
+    | Tcoerce_none -> None
+    | Tcoerce_alias _ | Tcoerce_primitive _ ->
+        (* these coercions are not inversible, and raise an error earlier when
+           checking for module type equivalence *)
+        assert false
+  (* we search the first point which is not invariant at the current level *)
+  and not_fixpoint path pos = function
+    | [] -> None
+    | (n, _) :: q ->
+        if n = pos then
+          not_fixpoint path (pos+1) q
+        else
+          Some(List.rev path, pos, n)
+  (* we search the first item with a non-identity inner coercion *)
+  and first_non_id path pos = function
+    | [] -> None
+    | (_, Typedtree.Tcoerce_none) :: q -> first_non_id path (pos + 1) q
+    | (_,c) :: q ->
+        either
+          (transposition_under (Item pos :: path)) c
+          (first_non_id path (pos + 1)) q
+
+  let transposition c =
+    match transposition_under [] c with
+    | None -> raise Not_found
+    | Some x -> x
+
+  let rec runtime_item k = function
+    | [] -> raise Not_found
+    | item :: q ->
+        if not(Includemod.is_runtime_component item) then
+          runtime_item k q
+        else if k = 0 then
+          item
+        else
+          runtime_item (k-1) q
+
+  (* Find module type at position [path] and convert the [coerce_pos] path to
+     a [pos] path *)
+  let rec find env ctx path (mt:Types.module_type) = match mt, path with
+    | (Mty_ident p | Mty_alias p), _ ->
+        begin match (Env.find_modtype p env).mtd_type with
+        | None -> raise Not_found
+        | Some mt -> find env ctx path mt
+        end
+    | Mty_signature s , [] -> List.rev ctx, s
+    | Mty_signature s, Item k :: q ->
+        begin match runtime_item k s with
+        | Sig_module (id, _, md,_,_) ->
+            find env (Context.Module id :: ctx) q md.md_type
+        | _ -> raise Not_found
+        end
+    | Mty_functor(Named (_,mt) as arg,_), InArg :: q ->
+        find env (Context.Arg arg :: ctx) q mt
+    | Mty_functor(arg, mt), InBody :: q ->
+        find env (Context.Body arg :: ctx) q mt
+    | _ -> raise Not_found
+
+  let find env path mt = find env [] path mt
+  let item mt k = Includemod.item_ident_name (runtime_item k mt)
+
+  let pp_item ppf (id,_,kind) =
+    Format.fprintf ppf "%s %S"
+      (Includemod.kind_of_field_desc kind)
+      (Ident.name id)
+
+  let pp ctx_printer env ppf (mty,c) =
+    try
+      let p, k, l = transposition c in
+      let ctx, mt = find env p mty in
+      Format.fprintf ppf
+        "@[<hv 2>Illegal permutation of runtime components in a module type.@ \
+         @[For example,@ %a@]@ @[the %a@ and the %a are not in the same order@ \
+         in the expected and actual module types.@]@]"
+        ctx_printer ctx pp_item (item mt k) pp_item (item mt l)
+    with Not_found -> (* this should not happen *)
+      Format.fprintf ppf
+        "Illegal permutation of runtime components in a module type."
+
+end
+
+
+
+module Err = Includemod.Error
+
+let buffer = ref Bytes.empty
+let is_big obj =
+  let size = !Clflags.error_size in
+  size > 0 &&
+  begin
+    if Bytes.length !buffer < size then buffer := Bytes.create size;
+    try ignore (Marshal.to_buffer !buffer 0 size obj []); false
+    with _ -> true
+  end
+
+let show_loc msg ppf loc =
+  let pos = loc.Location.loc_start in
+  if List.mem pos.Lexing.pos_fname [""; "_none_"; "//toplevel//"] then ()
+  else Format.fprintf ppf "@\n@[<2>%a:@ %s@]" Location.print_loc loc msg
+
+let show_locs ppf (loc1, loc2) =
+  show_loc "Expected declaration" ppf loc2;
+  show_loc "Actual declaration" ppf loc1
+
+
+let dmodtype mty =
+  let tmty = Printtyp.tree_of_modtype mty in
+  Format.dprintf "%a" !Oprint.out_module_type tmty
+
+let space ppf () = Format.fprintf ppf "@ "
+
+(**
+   In order to display a list of functor arguments in a compact format,
+   we introduce a notion of shorthand for functor arguments.
+   The aim is to first present the lists of actual and expected types with
+   shorthands:
+
+     (X: $S1) (Y: $S2) (Z: An_existing_module_type) ...
+   does not match
+     (X: $T1) (Y: A_real_path) (Z: $T3) ...
+
+   and delay the full display of the module types corresponding to $S1, $S2,
+   $T1, and $T3 to the suberror message.
+
+*)
+module With_shorthand = struct
+
+  (** A item with a potential shorthand name *)
+  type 'a named = {
+    item: 'a;
+    name : string;
+  }
+
+  type 'a t =
+    | Original of 'a (** The shorthand has been discarded *)
+    | Synthetic of 'a named
+    (** The shorthand is potentially useful *)
+
+  type functor_param =
+    | Unit
+    | Named of (Ident.t option * Types.module_type t)
+
+  (** Shorthand generation *)
+  type kind =
+    | Got
+    | Expected
+    | Unneeded
+
+  type variant =
+    | App
+    | Inclusion
+
+  let elide_if_app ctx s = match ctx with
+    | App -> Unneeded
+    | Inclusion -> s
+
+  let make side pos =
+    match side with
+    | Got -> Format.sprintf "$S%d" pos
+    | Expected -> Format.sprintf "$T%d" pos
+    | Unneeded -> "..."
+
+  (** Add shorthands to a patch *)
+  let patch ctx p =
+    let add_shorthand side pos mty =
+      {name = (make side pos); item = mty }
+    in
+    let aux i d =
+      let pos = i + 1 in
+      let d = match d with
+        | Diffing.Insert mty ->
+            Diffing.Insert (add_shorthand Expected pos mty)
+        | Diffing.Delete mty ->
+            Diffing.Delete (add_shorthand (elide_if_app ctx Got) pos mty)
+        | Diffing.Change (g, e, p) ->
+            Diffing.Change
+              (add_shorthand Got pos g,
+               add_shorthand Expected pos e, p)
+        | Diffing.Keep (g, e, p) ->
+            Diffing.Keep (add_shorthand Got pos g,
+                          add_shorthand (elide_if_app ctx Expected) pos e, p)
+      in
+      pos, d
+    in
+    List.mapi aux p
+
+  (** Shorthand computation from named item *)
+  let modtype (r : _ named) = match r.item with
+    | Types.Mty_ident _
+    | Types.Mty_alias _
+    | Types.Mty_signature []
+      -> Original r.item
+    | Types.Mty_signature _ | Types.Mty_functor _
+      -> Synthetic r
+
+  let functor_param (ua : _ named) = match ua.item with
+    | Types.Unit -> Unit
+    | Types.Named (from, mty) ->
+        Named (from, modtype { ua with item = mty })
+
+  (** Printing of arguments with shorthands *)
+  let pp ppx = function
+    | Original x -> ppx x
+    | Synthetic s -> Format.dprintf "%s" s.name
+
+  let pp_orig ppx = function
+    | Original x | Synthetic { item=x; _ } -> ppx x
+
+  let definition x = match functor_param x with
+    | Unit -> Format.dprintf "()"
+    | Named(_,short_mty) ->
+        match short_mty with
+        | Original mty -> dmodtype mty
+        | Synthetic {name; item = mty} ->
+            Format.dprintf
+              "%s@ =@ %t" name (dmodtype mty)
+
+  let param x = match functor_param x with
+    | Unit -> Format.dprintf "()"
+    | Named (_, short_mty) ->
+        pp dmodtype short_mty
+
+  let qualified_param x = match functor_param x with
+    | Unit -> Format.dprintf "()"
+    | Named (None, Original (Mty_signature []) ) ->
+        Format.dprintf "(sig end)"
+    | Named (None, short_mty) ->
+        pp dmodtype short_mty
+    | Named (Some p, short_mty) ->
+        Format.dprintf "(%s : %t)"
+          (Ident.name p) (pp dmodtype short_mty)
+
+  let definition_of_argument ua =
+    let arg, mty = ua.item in
+    match (arg: Err.functor_arg_descr) with
+    | Unit -> Format.dprintf "()"
+    | Named p ->
+        let mty = modtype { ua with item = mty } in
+        Format.dprintf
+          "%a@ :@ %t"
+          Printtyp.path p
+          (pp_orig dmodtype mty)
+    | Anonymous ->
+        let short_mty = modtype { ua with item = mty } in
+        begin match short_mty with
+        | Original mty -> dmodtype mty
+        | Synthetic {name; item=mty} ->
+            Format.dprintf "%s@ :@ %t" name (dmodtype mty)
+        end
+
+  let arg ua =
+    let arg, mty = ua.item in
+    match (arg: Err.functor_arg_descr) with
+    | Unit -> Format.dprintf "()"
+    | Named p -> fun ppf -> Printtyp.path ppf p
+    | Anonymous ->
+        let short_mty = modtype { ua with item=mty } in
+        pp dmodtype short_mty
+
+end
+
+
+module Functor_suberror = struct
+  open Err
+
+  let style = function
+    | Diffing.Keep _ -> Misc.Color.[ FG Green ]
+    | Diffing.Delete _ -> Misc.Color.[ FG Red; Bold]
+    | Diffing.Insert _ -> Misc.Color.[ FG Red; Bold]
+    | Diffing.Change _ -> Misc.Color.[ FG Magenta; Bold]
+
+  let prefix ppf (pos, p) =
+    let sty = style p in
+    Format.pp_open_stag ppf (Misc.Color.Style sty);
+    Format.fprintf ppf "%i." pos;
+    Format.pp_close_stag ppf ()
+
+  let param_id x = match x.With_shorthand.item with
+    | Types.Named (Some _ as x,_) -> x
+    | Types.(Unit | Named(None,_)) -> None
+
+  (** Print the list of params with style *)
+  let pretty_params sep proj printer patch =
+    let elt (x,param) =
+      let sty = style x in
+      Format.dprintf "%a%t%a"
+        Format.pp_open_stag (Misc.Color.Style sty)
+        (printer param)
+        Format.pp_close_stag ()
+    in
+    let params = List.filter_map proj @@ List.map snd patch in
+    Printtyp.functor_parameters ~sep elt params
+
+  let expected d =
+    let extract = function
+      | Diffing.Insert mty
+      | Diffing.Keep(_,mty,_)
+      | Diffing.Change (_,mty,_) as x ->
+          Some (param_id mty,(x, mty))
+      | Diffing.Delete _ -> None
+    in
+    pretty_params space extract With_shorthand.qualified_param d
+
+  let drop_inserted_suffix patch =
+    let rec drop = function
+      | Diffing.Insert _ :: q -> drop q
+      | rest -> List.rev rest in
+    drop (List.rev patch)
+
+  let prepare_patch ~drop ~ctx patch =
+    let drop_suffix x = if drop then drop_inserted_suffix x else x in
+    patch |> drop_suffix |> With_shorthand.patch ctx
+
+
+  module Inclusion = struct
+
+    let got d =
+      let extract = function
+      | Diffing.Delete mty
+      | Diffing.Keep (mty,_,_)
+      | Diffing.Change (mty,_,_) as x ->
+          Some (param_id mty,(x,mty))
+      | Diffing.Insert _ -> None
+      in
+      pretty_params space extract With_shorthand.qualified_param d
+
+    let insert mty =
+      Format.dprintf
+        "An argument appears to be missing with module type@;<1 2>@[%t@]"
+        (With_shorthand.definition mty)
+
+    let delete mty =
+      Format.dprintf
+        "An extra argument is provided of module type@;<1 2>@[%t@]"
+        (With_shorthand.definition mty)
+
+      let ok x y =
+        Format.dprintf
+          "Module types %t and %t match"
+          (With_shorthand.param x)
+          (With_shorthand.param y)
+
+      let diff g e more =
+        let g = With_shorthand.definition g in
+        let e = With_shorthand.definition e in
+        Format.dprintf
+          "Module types do not match:@ @[%t@]@;<1 -2>does not include@ \
+           @[%t@]%t"
+          g e (more ())
+
+      let incompatible = function
+        | Types.Unit ->
+            Format.dprintf
+              "The functor was expected to be applicative at this position"
+        | Types.Named _ ->
+            Format.dprintf
+              "The functor was expected to be generative at this position"
+
+      let patch env got expected =
+        Includemod.Functor_inclusion_diff.diff env got expected
+        |> prepare_patch ~drop:false ~ctx:Inclusion
+
+    end
+
+  module App = struct
+
+    let patch env ~f ~args =
+      Includemod.Functor_app_diff.diff env ~f ~args
+      |> prepare_patch ~drop:true ~ctx:App
+
+    let got d =
+      let extract = function
+        | Diffing.Delete mty
+        | Diffing.Keep (mty,_,_)
+        | Diffing.Change (mty,_,_) as x ->
+            Some (None,(x,mty))
+        | Diffing.Insert _ -> None
+      in
+      pretty_params space extract With_shorthand.arg d
+
+    let delete mty =
+      Format.dprintf
+        "The following extra argument is provided@;<1 2>@[%t@]"
+        (With_shorthand.definition_of_argument mty)
+
+    let insert = Inclusion.insert
+
+    let ok x y =
+      let pp_orig_name = match With_shorthand.functor_param y with
+        | With_shorthand.Named (_, Original mty) ->
+            Format.dprintf " %t" (dmodtype mty)
+        | _ -> ignore
+      in
+      Format.dprintf
+        "Module %t matches the expected module type%t"
+        (With_shorthand.arg x)
+        pp_orig_name
+
+    let diff g e more =
+      let g = With_shorthand.definition_of_argument g in
+      let e = With_shorthand.definition e in
+      Format.dprintf
+        "Modules do not match:@ @[%t@]@;<1 -2>\
+         is not included in@ @[%t@]%t"
+        g e (more ())
+
+    (** Specialized to avoid introducing shorthand names
+        for single change difference
+    *)
+    let single_diff g e more =
+      let _arg, mty = g.With_shorthand.item in
+      let e = match e.With_shorthand.item with
+        | Types.Unit -> Format.dprintf "()"
+        | Types.Named(_, mty) -> dmodtype mty
+      in
+      Format.dprintf
+        "Modules do not match:@ @[%t@]@;<1 -2>\
+         is not included in@ @[%t@]%t"
+        (dmodtype mty) e (more ())
+
+
+    let incompatible = function
+      | Unit ->
+          Format.dprintf
+            "The functor was expected to be applicative at this position"
+      | Named _ | Anonymous ->
+          Format.dprintf
+            "The functor was expected to be generative at this position"
+
+  end
+
+  let subcase sub ~expansion_token env (pos, diff) =
+    Location.msg "%a%a%a %a@[<hv 2>%t@]%a"
+      Format.pp_print_tab ()
+      Format.pp_open_tbox ()
+      prefix (pos, diff)
+      Format.pp_set_tab ()
+      (Printtyp.wrap_printing_env env ~error:true
+         (fun () -> sub ~expansion_token env diff)
+      )
+     Format.pp_close_tbox ()
+
+  let onlycase sub ~expansion_token env (_, diff) =
+    Location.msg "%a@[<hv 2>%t@]"
+      Format.pp_print_tab ()
+      (Printtyp.wrap_printing_env env ~error:true
+         (fun () -> sub ~expansion_token env diff)
+      )
+
+  let params sub ~expansion_token env l =
+    let rec aux subcases = function
+      | [] -> subcases
+      | (_, Diffing.Keep _) as a :: q ->
+          aux (subcase sub ~expansion_token env a :: subcases) q
+      | a :: q ->
+          List.fold_left (fun acc x ->
+            (subcase sub ~expansion_token:false env x) :: acc
+            )
+            (subcase sub ~expansion_token env a :: subcases)
+            q
+    in
+    match l with
+    | [a] -> [onlycase sub ~expansion_token env a]
+    | l -> aux [] l
+end
+
+
+(** Construct a linear presentation of the error tree *)
+
+open Err
+
+(* Context helper functions *)
+let with_context ?loc ctx printer diff =
+  Location.msg ?loc "%a%a" Context.pp (List.rev ctx)
+    printer diff
+
+let dwith_context ?loc ctx printer =
+  Location.msg ?loc "%a%t" Context.pp (List.rev ctx) printer
+
+let dwith_context_and_elision ?loc ctx printer diff =
+  if is_big (diff.got,diff.expected) then
+    Location.msg ?loc "..."
+  else
+    dwith_context ?loc ctx (printer diff)
+
+(* Merge sub msgs into one printer *)
+let coalesce msgs =
+  match List.rev msgs with
+  | [] -> ignore
+  | before ->
+      let ctx ppf =
+        Format.pp_print_list ~pp_sep:space
+          (fun ppf x -> x.Location.txt ppf)
+          ppf before in
+      ctx
+
+let subcase_list l ppf = match l with
+  | [] -> ()
+  | _ :: _ ->
+      Format.fprintf ppf "@;<1 -2>@[%a@]"
+        (Format.pp_print_list ~pp_sep:space
+           (fun ppf f -> f.Location.txt ppf)
+        )
+        (List.rev l)
+
+(* Printers for leaves *)
+let core id x =
+  match x with
+  | Err.Value_descriptions diff ->
+      let t1 = Printtyp.tree_of_value_description id diff.got in
+      let t2 = Printtyp.tree_of_value_description id diff.expected in
+      Format.dprintf
+        "@[<hv 2>Values do not match:@ %a@;<1 -2>is not included in@ %a@]%a%t"
+        !Oprint.out_sig_item t1
+        !Oprint.out_sig_item t2
+        show_locs (diff.got.val_loc, diff.expected.val_loc)
+        Printtyp.Conflicts.print_explanations
+  | Err.Type_declarations diff ->
+      Format.dprintf "@[<v>@[<hv>%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a%t@]"
+        "Type declarations do not match"
+        !Oprint.out_sig_item
+        (Printtyp.tree_of_type_declaration id diff.got Trec_first)
+        "is not included in"
+        !Oprint.out_sig_item
+        (Printtyp.tree_of_type_declaration id diff.expected Trec_first)
+        (Includecore.report_type_mismatch
+           "the first" "the second" "declaration") diff.symptom
+        show_locs (diff.got.type_loc, diff.expected.type_loc)
+        Printtyp.Conflicts.print_explanations
+  | Err.Extension_constructors diff ->
+      Format.dprintf "@[<v>@[<hv>%s:@;<1 2>%a@ %s@;<1 2>%a@]@ %a%a%t@]"
+        "Extension declarations do not match"
+        !Oprint.out_sig_item
+        (Printtyp.tree_of_extension_constructor id diff.got Text_first)
+        "is not included in"
+        !Oprint.out_sig_item
+        (Printtyp.tree_of_extension_constructor id diff.expected Text_first)
+        (Includecore.report_extension_constructor_mismatch
+           "the first" "the second" "declaration") diff.symptom
+        show_locs (diff.got.ext_loc, diff.expected.ext_loc)
+        Printtyp.Conflicts.print_explanations
+  | Err.Class_type_declarations diff ->
+      Format.dprintf
+        "@[<hv 2>Class type declarations do not match:@ \
+         %a@;<1 -2>does not match@ %a@]@ %a%t"
+        !Oprint.out_sig_item
+        (Printtyp.tree_of_cltype_declaration id diff.got Trec_first)
+        !Oprint.out_sig_item
+        (Printtyp.tree_of_cltype_declaration id diff.expected Trec_first)
+        Includeclass.report_error diff.symptom
+        Printtyp.Conflicts.print_explanations
+  | Err.Class_declarations {got;expected;symptom} ->
+      let t1 = Printtyp.tree_of_class_declaration id got Trec_first in
+      let t2 = Printtyp.tree_of_class_declaration id expected Trec_first in
+      Format.dprintf
+        "@[<hv 2>Class declarations do not match:@ \
+         %a@;<1 -2>does not match@ %a@]@ %a%t"
+        !Oprint.out_sig_item t1
+        !Oprint.out_sig_item t2
+        Includeclass.report_error symptom
+        Printtyp.Conflicts.print_explanations
+
+let missing_field ppf item =
+  let id, loc, kind =  Includemod.item_ident_name item in
+  Format.fprintf ppf "The %s `%a' is required but not provided%a"
+    (Includemod.kind_of_field_desc kind) Printtyp.ident id
+    (show_loc "Expected declaration") loc
+
+let module_types {Err.got=mty1; expected=mty2} =
+  Format.dprintf
+    "@[<hv 2>Modules do not match:@ \
+     %a@;<1 -2>is not included in@ %a@]"
+    !Oprint.out_module_type (Printtyp.tree_of_modtype mty1)
+    !Oprint.out_module_type (Printtyp.tree_of_modtype mty2)
+
+let eq_module_types {Err.got=mty1; expected=mty2} =
+  Format.dprintf
+    "@[<hv 2>Module types do not match:@ \
+     %a@;<1 -2>is not equal to@ %a@]"
+    !Oprint.out_module_type (Printtyp.tree_of_modtype mty1)
+    !Oprint.out_module_type (Printtyp.tree_of_modtype mty2)
+
+let module_type_declarations id {Err.got=d1 ; expected=d2} =
+  Format.dprintf
+    "@[<hv 2>Module type declarations do not match:@ \
+     %a@;<1 -2>does not match@ %a@]"
+    !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d1)
+    !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d2)
+
+let interface_mismatch ppf (diff: _ Err.diff) =
+  Format.fprintf ppf
+    "The implementation %s@ does not match the interface %s:@ "
+    diff.got diff.expected
+
+let core_module_type_symptom (x:Err.core_module_type_symptom)  =
+  match x with
+  | Not_an_alias | Not_an_identifier | Abstract_module_type
+  | Incompatible_aliases ->
+      if Printtyp.Conflicts.exists () then
+        Some Printtyp.Conflicts.print_explanations
+      else None
+  | Unbound_module_path path ->
+      Some(Format.dprintf "Unbound module %a" Printtyp.path path)
+
+(* Construct a linearized error message from the error tree *)
+
+let rec module_type ~expansion_token ~eqmode ~env ~before ~ctx diff =
+  match diff.symptom with
+  | Invalid_module_alias _ (* the difference is non-informative here *)
+  | After_alias_expansion _ (* we print only the expanded module types *) ->
+      module_type_symptom ~eqmode ~expansion_token ~env ~before ~ctx
+        diff.symptom
+  | Functor Params d -> (* We jump directly to the functor param error *)
+      functor_params ~expansion_token ~env ~before ~ctx d
+  | _ ->
+      let inner = if eqmode then eq_module_types else module_types in
+      let next = dwith_context_and_elision ctx inner diff in
+      let before = next :: before in
+      module_type_symptom ~eqmode ~expansion_token ~env ~before ~ctx
+        diff.symptom
+
+and module_type_symptom ~eqmode ~expansion_token ~env ~before ~ctx = function
+  | Mt_core core ->
+      begin match core_module_type_symptom core with
+      | None -> before
+      | Some msg -> Location.msg "%t" msg :: before
+      end
+  | Signature s -> signature ~expansion_token ~env ~before ~ctx s
+  | Functor f -> functor_symptom ~expansion_token ~env ~before ~ctx f
+  | After_alias_expansion diff ->
+      module_type ~eqmode ~expansion_token ~env ~before ~ctx diff
+  | Invalid_module_alias path ->
+      let printer =
+        Format.dprintf "Module %a cannot be aliased" Printtyp.path path
+      in
+      dwith_context ctx printer :: before
+
+and functor_params ~expansion_token ~env ~before ~ctx {got;expected;_} =
+  let d = Functor_suberror.Inclusion.patch env got expected in
+  let actual = Functor_suberror.Inclusion.got d in
+  let expected = Functor_suberror.expected d in
+  let main =
+    Format.dprintf
+      "@[<hv 2>Modules do not match:@ \
+       @[functor@ %t@ -> ...@]@;<1 -2>is not included in@ \
+       @[functor@ %t@ -> ...@]@]"
+      actual expected
+  in
+  let msgs = dwith_context ctx main :: before in
+  let functor_suberrors =
+    if expansion_token then
+      Functor_suberror.params functor_arg_diff ~expansion_token env d
+    else []
+  in
+  functor_suberrors @ msgs
+
+and functor_symptom ~expansion_token ~env ~before ~ctx = function
+  | Result res ->
+      module_type ~expansion_token ~eqmode:false ~env ~before ~ctx res
+  | Params d -> functor_params ~expansion_token ~env ~before ~ctx d
+
+and signature ~expansion_token ~env:_ ~before ~ctx sgs =
+  Printtyp.wrap_printing_env ~error:true sgs.env (fun () ->
+      match sgs.missings, sgs.incompatibles with
+      | a :: l , _ ->
+          if expansion_token then
+            with_context ctx missing_field a
+            :: List.map (Location.msg "%a" missing_field) l
+            @ before
+          else
+            before
+      | [], a :: _ -> sigitem ~expansion_token ~env:sgs.env ~before ~ctx a
+      | [], [] -> assert false
+    )
+and sigitem ~expansion_token ~env ~before ~ctx (name,s) = match s with
+  | Core c ->
+      dwith_context ctx (core name c):: before
+  | Module_type diff ->
+      module_type ~expansion_token ~eqmode:false ~env ~before
+        ~ctx:(Context.Module name :: ctx) diff
+  | Module_type_declaration diff ->
+      module_type_decl ~expansion_token ~env ~before ~ctx name diff
+and module_type_decl ~expansion_token ~env ~before ~ctx id diff =
+  let next =
+    dwith_context_and_elision ctx (module_type_declarations id) diff in
+  let before = next :: before in
+  match diff.symptom with
+  | Not_less_than mts ->
+      let before =
+        Location.msg "The first module type is not included in the second"
+        :: before
+      in
+      module_type ~expansion_token ~eqmode:true ~before ~env
+        ~ctx:(Context.Modtype id :: ctx) mts
+  | Not_greater_than mts ->
+      let before =
+        Location.msg "The second module type is not included in the first"
+        :: before in
+      module_type ~expansion_token ~eqmode:true ~before ~env
+        ~ctx:(Context.Modtype id :: ctx) mts
+  | Incomparable mts ->
+      module_type ~expansion_token ~eqmode:true ~env ~before
+        ~ctx:(Context.Modtype id :: ctx) mts.less_than
+  | Illegal_permutation c ->
+      begin match diff.got.Types.mtd_type with
+      | None -> assert false
+      | Some mty ->
+          with_context (Modtype id::ctx)
+            (Illegal_permutation.pp Context.alt_pp env) (mty,c)
+          :: before
+      end
+
+and functor_arg_diff ~expansion_token env = function
+  | Diffing.Insert mty -> Functor_suberror.Inclusion.insert mty
+  | Diffing.Delete mty -> Functor_suberror.Inclusion.delete mty
+  | Diffing.Keep (x, y, _) ->  Functor_suberror.Inclusion.ok x y
+  | Diffing.Change (_, _, Err.Incompatible_params (i,_)) ->
+      Functor_suberror.Inclusion.incompatible i
+  | Diffing.Change (g, e,  Err.Mismatch mty_diff) ->
+      let more () =
+        subcase_list @@
+        module_type_symptom ~eqmode:false ~expansion_token ~env ~before:[]
+          ~ctx:[] mty_diff.symptom
+      in
+      Functor_suberror.Inclusion.diff g e more
+
+let functor_app_diff ~expansion_token env = function
+  | Diffing.Insert mty ->  Functor_suberror.App.insert mty
+  | Diffing.Delete mty ->  Functor_suberror.App.delete mty
+  | Diffing.Keep (x, y, _) ->  Functor_suberror.App.ok x y
+  | Diffing.Change (_, _, Err.Incompatible_params (i,_)) ->
+      Functor_suberror.App.incompatible i
+  | Diffing.Change (g, e,  Err.Mismatch mty_diff) ->
+      let more () =
+        subcase_list @@
+        module_type_symptom ~eqmode:false ~expansion_token ~env ~before:[]
+          ~ctx:[] mty_diff.symptom
+      in
+      Functor_suberror.App.diff g e more
+
+let module_type_subst ~env id diff =
+  match diff.symptom with
+  | Not_less_than mts ->
+      module_type ~expansion_token:true ~eqmode:true ~before:[] ~env
+        ~ctx:[Modtype id] mts
+  | Not_greater_than mts ->
+      module_type ~expansion_token:true ~eqmode:true ~before:[] ~env
+        ~ctx:[Modtype id] mts
+  | Incomparable mts ->
+      module_type ~expansion_token:true ~eqmode:true ~env ~before:[]
+        ~ctx:[Modtype id] mts.less_than
+  | Illegal_permutation c ->
+      let mty = diff.got in
+      let main =
+        with_context [Modtype id]
+          (Illegal_permutation.pp Context.alt_pp env) (mty,c) in
+      [main]
+
+let all env = function
+  | In_Compilation_unit diff ->
+      let first = Location.msg "%a" interface_mismatch diff in
+      signature ~expansion_token:true ~env ~before:[first] ~ctx:[] diff.symptom
+  | In_Type_declaration (id,reason) ->
+      [Location.msg "%t" (core id reason)]
+  | In_Module_type diff ->
+      module_type ~expansion_token:true ~eqmode:false ~before:[] ~env ~ctx:[]
+        diff
+  | In_Module_type_substitution (id,diff) ->
+      module_type_subst ~env id diff
+  | In_Signature diff ->
+      signature ~expansion_token:true ~before:[] ~env ~ctx:[] diff
+  | In_Expansion cmts ->
+      match core_module_type_symptom cmts with
+      | None -> assert false
+      | Some main -> [Location.msg "%t" main]
+
+(* General error reporting *)
+
+let err_msgs (env, err) =
+  Printtyp.Conflicts.reset();
+  Printtyp.wrap_printing_env ~error:true env
+    (fun () -> coalesce @@ all env err)
+
+let report_error err =
+  let main = err_msgs err in
+  Location.errorf ~loc:Location.(in_file !input_name) "%t" main
+
+let report_apply_error ~loc env (lid_app, mty_f, args) =
+  let may_print_app ppf = match lid_app with
+    | None -> ()
+    | Some lid -> Format.fprintf ppf "%a " Printtyp.longident lid
+  in
+  let d = Functor_suberror.App.patch env ~f:mty_f ~args in
+  match d with
+  (* We specialize the one change and one argument case to remove the
+     presentation of the functor arguments *)
+  | [ _,  Diffing.Change (_, _, Err.Incompatible_params (i,_)) ] ->
+      Location.errorf ~loc "%t" (Functor_suberror.App.incompatible i)
+  | [ _, Diffing.Change (g, e,  Err.Mismatch mty_diff) ] ->
+      let more () =
+        subcase_list @@
+        module_type_symptom ~eqmode:false ~expansion_token:true ~env ~before:[]
+          ~ctx:[] mty_diff.symptom
+      in
+      Location.errorf ~loc "%t" (Functor_suberror.App.single_diff g e more)
+  | _ ->
+      let actual = Functor_suberror.App.got d in
+      let expected = Functor_suberror.expected d in
+      let sub =
+        List.rev @@
+        Functor_suberror.params functor_app_diff env ~expansion_token:true d
+      in
+      Location.errorf ~loc ~sub
+        "@[<hv>The functor application %tis ill-typed.@ \
+         These arguments:@;<1 2>\
+         @[%t@]@ do not match these parameters:@;<1 2>@[functor@ %t@ -> ...@]@]"
+        may_print_app
+        actual expected
+
+let register () =
+  Location.register_error_of_exn
+    (function
+      | Includemod.Error err -> Some (report_error err)
+      | Includemod.Apply_error {loc; env; lid_app; mty_f; args} ->
+          Some (Printtyp.wrap_printing_env env ~error:true (fun () ->
+              report_apply_error ~loc env (lid_app, mty_f, args))
+            )
+      | _ -> None
+    )
diff --git a/upstream/ocaml_413/typing/includemod_errorprinter.mli b/upstream/ocaml_413/typing/includemod_errorprinter.mli
new file mode 100644
index 0000000..12ea216
--- /dev/null
+++ b/upstream/ocaml_413/typing/includemod_errorprinter.mli
@@ -0,0 +1,17 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Florian Angeletti, projet Cambium, Inria Paris             *)
+(*                                                                        *)
+(*   Copyright 2021 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+val err_msgs: Includemod.explanation -> Format.formatter -> unit
+val register: unit -> unit
diff --git a/upstream/ocaml_413/typing/mtype.ml b/upstream/ocaml_413/typing/mtype.ml
new file mode 100644
index 0000000..3af072e
--- /dev/null
+++ b/upstream/ocaml_413/typing/mtype.ml
@@ -0,0 +1,530 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Operations on module types *)
+
+open Asttypes
+open Path
+open Types
+
+
+let rec scrape env mty =
+  match mty with
+    Mty_ident p ->
+      begin try
+        scrape env (Env.find_modtype_expansion p env)
+      with Not_found ->
+        mty
+      end
+  | _ -> mty
+
+let freshen ~scope mty =
+  Subst.modtype (Rescope scope) Subst.identity mty
+
+let rec strengthen ~aliasable env mty p =
+  match scrape env mty with
+    Mty_signature sg ->
+      Mty_signature(strengthen_sig ~aliasable env sg p)
+  | Mty_functor(Named (Some param, arg), res)
+    when !Clflags.applicative_functors ->
+      Mty_functor(Named (Some param, arg),
+        strengthen ~aliasable:false env res (Papply(p, Pident param)))
+  | Mty_functor(Named (None, arg), res)
+    when !Clflags.applicative_functors ->
+      let param = Ident.create_scoped ~scope:(Path.scope p) "Arg" in
+      Mty_functor(Named (Some param, arg),
+        strengthen ~aliasable:false env res (Papply(p, Pident param)))
+  | mty ->
+      mty
+
+and strengthen_sig ~aliasable env sg p =
+  match sg with
+    [] -> []
+  | (Sig_value(_, _, _) as sigelt) :: rem ->
+      sigelt :: strengthen_sig ~aliasable env rem p
+  | Sig_type(id, {type_kind=Type_abstract}, _, _) :: rem
+    when Btype.is_row_name (Ident.name id) ->
+      strengthen_sig ~aliasable env rem p
+  | Sig_type(id, decl, rs, vis) :: rem ->
+      let newdecl =
+        match decl.type_manifest, decl.type_private, decl.type_kind with
+          Some _, Public, _ -> decl
+        | Some _, Private, (Type_record _ | Type_variant _) -> decl
+        | _ ->
+            let manif =
+              Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id),
+                                          decl.type_params, ref Mnil))) in
+            if decl.type_kind = Type_abstract then
+              { decl with type_private = Public; type_manifest = manif }
+            else
+              { decl with type_manifest = manif }
+      in
+      Sig_type(id, newdecl, rs, vis) :: strengthen_sig ~aliasable env rem p
+  | (Sig_typext _ as sigelt) :: rem ->
+      sigelt :: strengthen_sig ~aliasable env rem p
+  | Sig_module(id, pres, md, rs, vis) :: rem ->
+      let str =
+        strengthen_decl ~aliasable env md (Pdot(p, Ident.name id))
+      in
+      Sig_module(id, pres, str, rs, vis)
+      :: strengthen_sig ~aliasable
+        (Env.add_module_declaration ~check:false id pres md env) rem p
+      (* Need to add the module in case it defines manifest module types *)
+  | Sig_modtype(id, decl, vis) :: rem ->
+      let newdecl =
+        match decl.mtd_type with
+          None ->
+            {decl with mtd_type = Some(Mty_ident(Pdot(p,Ident.name id)))}
+        | Some _ ->
+            decl
+      in
+      Sig_modtype(id, newdecl, vis) ::
+      strengthen_sig ~aliasable (Env.add_modtype id decl env) rem p
+      (* Need to add the module type in case it is manifest *)
+  | (Sig_class _ as sigelt) :: rem ->
+      sigelt :: strengthen_sig ~aliasable env rem p
+  | (Sig_class_type _ as sigelt) :: rem ->
+      sigelt :: strengthen_sig ~aliasable env rem p
+
+and strengthen_decl ~aliasable env md p =
+  match md.md_type with
+  | Mty_alias _ -> md
+  | _ when aliasable -> {md with md_type = Mty_alias p}
+  | mty -> {md with md_type = strengthen ~aliasable env mty p}
+
+let () = Env.strengthen := strengthen
+
+let rec make_aliases_absent pres mty =
+  match mty with
+  | Mty_alias _ -> Mp_absent, mty
+  | Mty_signature sg ->
+      pres, Mty_signature(make_aliases_absent_sig sg)
+  | Mty_functor(arg, res) ->
+      let _, res = make_aliases_absent Mp_present res in
+      pres, Mty_functor(arg, res)
+  | mty ->
+      pres, mty
+
+and make_aliases_absent_sig sg =
+  match sg with
+    [] -> []
+  | Sig_module(id, pres, md, rs, priv) :: rem ->
+      let pres, md_type = make_aliases_absent pres md.md_type in
+      let md = { md with md_type } in
+      Sig_module(id, pres, md, rs, priv) :: make_aliases_absent_sig rem
+  | sigelt :: rem ->
+      sigelt :: make_aliases_absent_sig rem
+
+let scrape_for_type_of env pres mty =
+  let rec loop env path mty =
+    match mty, path with
+    | Mty_alias path, _ -> begin
+        try
+          let md = Env.find_module path env in
+          loop env (Some path) md.md_type
+        with Not_found -> mty
+      end
+    | mty, Some path ->
+        strengthen ~aliasable:false env mty path
+    | _ -> mty
+  in
+  make_aliases_absent pres (loop env None mty)
+
+(* In nondep_supertype, env is only used for the type it assigns to id.
+   Hence there is no need to keep env up-to-date by adding the bindings
+   traversed. *)
+
+type variance = Co | Contra | Strict
+
+let rec nondep_mty_with_presence env va ids pres mty =
+  match mty with
+    Mty_ident p ->
+      begin match Path.find_free_opt ids p with
+      | Some id ->
+          let expansion =
+            try Env.find_modtype_expansion p env
+            with Not_found ->
+              raise (Ctype.Nondep_cannot_erase id)
+          in
+          nondep_mty_with_presence env va ids pres expansion
+      | None -> pres, mty
+      end
+  | Mty_alias p ->
+      begin match Path.find_free_opt ids p with
+      | Some id ->
+          let expansion =
+            try Env.find_module p env
+            with Not_found ->
+              raise (Ctype.Nondep_cannot_erase id)
+          in
+          nondep_mty_with_presence env va ids Mp_present expansion.md_type
+      | None -> pres, mty
+      end
+  | Mty_signature sg ->
+      let mty = Mty_signature(nondep_sig env va ids sg) in
+      pres, mty
+  | Mty_functor(Unit, res) ->
+      pres, Mty_functor(Unit, nondep_mty env va ids res)
+  | Mty_functor(Named (param, arg), res) ->
+      let var_inv =
+        match va with Co -> Contra | Contra -> Co | Strict -> Strict in
+      let res_env =
+        match param with
+        | None -> env
+        | Some param -> Env.add_module ~arg:true param Mp_present arg env
+      in
+      let mty =
+        Mty_functor(Named (param, nondep_mty env var_inv ids arg),
+                    nondep_mty res_env va ids res)
+      in
+      pres, mty
+
+and nondep_mty env va ids mty =
+  snd (nondep_mty_with_presence env va ids Mp_present mty)
+
+and nondep_sig_item env va ids = function
+  | Sig_value(id, d, vis) ->
+      Sig_value(id,
+                {d with val_type = Ctype.nondep_type env ids d.val_type},
+                vis)
+  | Sig_type(id, d, rs, vis) ->
+      Sig_type(id, Ctype.nondep_type_decl env ids (va = Co) d, rs, vis)
+  | Sig_typext(id, ext, es, vis) ->
+      Sig_typext(id, Ctype.nondep_extension_constructor env ids ext, es, vis)
+  | Sig_module(id, pres, md, rs, vis) ->
+      let pres, mty = nondep_mty_with_presence env va ids pres md.md_type in
+      Sig_module(id, pres, {md with md_type = mty}, rs, vis)
+  | Sig_modtype(id, d, vis) ->
+      begin try
+        Sig_modtype(id, nondep_modtype_decl env ids d, vis)
+      with Ctype.Nondep_cannot_erase _ as exn ->
+        match va with
+          Co -> Sig_modtype(id, {mtd_type=None; mtd_loc=Location.none;
+                                 mtd_attributes=[]; mtd_uid = d.mtd_uid}, vis)
+        | _  -> raise exn
+      end
+  | Sig_class(id, d, rs, vis) ->
+      Sig_class(id, Ctype.nondep_class_declaration env ids d, rs, vis)
+  | Sig_class_type(id, d, rs, vis) ->
+      Sig_class_type(id, Ctype.nondep_cltype_declaration env ids d, rs, vis)
+
+and nondep_sig env va ids sg =
+  let scope = Ctype.create_scope () in
+  let sg, env = Env.enter_signature ~scope sg env in
+  List.map (nondep_sig_item env va ids) sg
+
+and nondep_modtype_decl env ids mtd =
+  {mtd with mtd_type = Option.map (nondep_mty env Strict ids) mtd.mtd_type}
+
+let nondep_supertype env ids = nondep_mty env Co ids
+let nondep_sig_item env ids = nondep_sig_item env Co ids
+
+let enrich_typedecl env p id decl =
+  match decl.type_manifest with
+    Some _ -> decl
+  | None ->
+    match Env.find_type p env with
+    | exception Not_found -> decl
+        (* Type which was not present in the signature, so we don't have
+           anything to do. *)
+    | orig_decl ->
+        if decl.type_arity <> orig_decl.type_arity then
+          decl
+        else begin
+          let orig_ty =
+            Ctype.reify_univars env
+              (Btype.newgenty(Tconstr(p, orig_decl.type_params, ref Mnil)))
+          in
+          let new_ty =
+            Ctype.reify_univars env
+              (Btype.newgenty(Tconstr(Pident id, decl.type_params, ref Mnil)))
+          in
+          let env = Env.add_type ~check:false id decl env in
+          match Ctype.mcomp env orig_ty new_ty with
+          | exception Ctype.Incompatible -> decl
+              (* The current declaration is not compatible with the one we got
+                 from the signature. We should just fail now, but then, we could
+                 also have failed if the arities of the two decls were
+                 different, which we didn't. *)
+          | () ->
+              let orig_ty =
+                Btype.newgenty(Tconstr(p, decl.type_params, ref Mnil))
+              in
+              {decl with type_manifest = Some orig_ty}
+        end
+
+let rec enrich_modtype env p mty =
+  match mty with
+    Mty_signature sg ->
+      Mty_signature(List.map (enrich_item env p) sg)
+  | _ ->
+      mty
+
+and enrich_item env p = function
+    Sig_type(id, decl, rs, priv) ->
+      Sig_type(id,
+                enrich_typedecl env (Pdot(p, Ident.name id)) id decl, rs, priv)
+  | Sig_module(id, pres, md, rs, priv) ->
+      Sig_module(id, pres,
+                  {md with
+                   md_type = enrich_modtype env
+                       (Pdot(p, Ident.name id)) md.md_type},
+                 rs,
+                 priv)
+  | item -> item
+
+let rec type_paths env p mty =
+  match scrape env mty with
+    Mty_ident _ -> []
+  | Mty_alias _ -> []
+  | Mty_signature sg -> type_paths_sig env p sg
+  | Mty_functor _ -> []
+
+and type_paths_sig env p sg =
+  match sg with
+    [] -> []
+  | Sig_type(id, _decl, _, _) :: rem ->
+      Pdot(p, Ident.name id) :: type_paths_sig env p rem
+  | Sig_module(id, pres, md, _, _) :: rem ->
+      type_paths env (Pdot(p, Ident.name id)) md.md_type @
+      type_paths_sig (Env.add_module_declaration ~check:false id pres md env)
+        p rem
+  | Sig_modtype(id, decl, _) :: rem ->
+      type_paths_sig (Env.add_modtype id decl env) p rem
+  | (Sig_value _ | Sig_typext _ | Sig_class _ | Sig_class_type _) :: rem ->
+      type_paths_sig env p rem
+
+
+let rec no_code_needed_mod env pres mty =
+  match pres with
+  | Mp_absent -> true
+  | Mp_present -> begin
+      match scrape env mty with
+        Mty_ident _ -> false
+      | Mty_signature sg -> no_code_needed_sig env sg
+      | Mty_functor _ -> false
+      | Mty_alias _ -> false
+    end
+
+and no_code_needed_sig env sg =
+  match sg with
+    [] -> true
+  | Sig_value(_id, decl, _) :: rem ->
+      begin match decl.val_kind with
+      | Val_prim _ -> no_code_needed_sig env rem
+      | _ -> false
+      end
+  | Sig_module(id, pres, md, _, _) :: rem ->
+      no_code_needed_mod env pres md.md_type &&
+      no_code_needed_sig
+        (Env.add_module_declaration ~check:false id pres md env) rem
+  | (Sig_type _ | Sig_modtype _ | Sig_class_type _) :: rem ->
+      no_code_needed_sig env rem
+  | (Sig_typext _ | Sig_class _) :: _ ->
+      false
+
+let no_code_needed env mty = no_code_needed_mod env Mp_present mty
+
+(* Check whether a module type may return types *)
+
+let rec contains_type env = function
+    Mty_ident path ->
+      begin try match (Env.find_modtype path env).mtd_type with
+      | None -> raise Exit (* PR#6427 *)
+      | Some mty -> contains_type env mty
+      with Not_found -> raise Exit
+      end
+  | Mty_signature sg ->
+      contains_type_sig env sg
+  | Mty_functor (_, body) ->
+      contains_type env body
+  | Mty_alias _ ->
+      ()
+
+and contains_type_sig env = List.iter (contains_type_item env)
+
+and contains_type_item env = function
+    Sig_type (_,({type_manifest = None} |
+                 {type_kind = Type_abstract; type_private = Private}),_, _)
+  | Sig_modtype _
+  | Sig_typext (_, {ext_args = Cstr_record _}, _, _) ->
+      (* We consider that extension constructors with an inlined
+         record create a type (the inlined record), even though
+         it would be technically safe to ignore that considering
+         the current constraints which guarantee that this type
+         is kept local to expressions.  *)
+      raise Exit
+  | Sig_module (_, _, {md_type = mty}, _, _) ->
+      contains_type env mty
+  | Sig_value _
+  | Sig_type _
+  | Sig_typext _
+  | Sig_class _
+  | Sig_class_type _ ->
+      ()
+
+let contains_type env mty =
+  try contains_type env mty; false with Exit -> true
+
+
+(* Remove module aliases from a signature *)
+
+let rec get_prefixes = function
+  | Pident _ -> Path.Set.empty
+  | Pdot (p, _)
+  | Papply (p, _) -> Path.Set.add p (get_prefixes p)
+
+let rec get_arg_paths = function
+  | Pident _ -> Path.Set.empty
+  | Pdot (p, _) -> get_arg_paths p
+  | Papply (p1, p2) ->
+      Path.Set.add p2
+        (Path.Set.union (get_prefixes p2)
+           (Path.Set.union (get_arg_paths p1) (get_arg_paths p2)))
+
+let rec rollback_path subst p =
+  try Pident (Path.Map.find p subst)
+  with Not_found ->
+    match p with
+      Pident _ | Papply _ -> p
+    | Pdot (p1, s) ->
+        let p1' = rollback_path subst p1 in
+        if Path.same p1 p1' then p else rollback_path subst (Pdot (p1', s))
+
+let rec collect_ids subst bindings p =
+    begin match rollback_path subst p with
+      Pident id ->
+        let ids =
+          try collect_ids subst bindings (Ident.find_same id bindings)
+          with Not_found -> Ident.Set.empty
+        in
+        Ident.Set.add id ids
+    | _ -> Ident.Set.empty
+    end
+
+let collect_arg_paths mty =
+  let open Btype in
+  let paths = ref Path.Set.empty
+  and subst = ref Path.Map.empty
+  and bindings = ref Ident.empty in
+  (* let rt = Ident.create "Root" in
+     and prefix = ref (Path.Pident rt) in *)
+  let it_path p = paths := Path.Set.union (get_arg_paths p) !paths
+  and it_signature_item it si =
+    type_iterators.it_signature_item it si;
+    match si with
+    | Sig_module (id, _, {md_type=Mty_alias p}, _, _) ->
+        bindings := Ident.add id p !bindings
+    | Sig_module (id, _, {md_type=Mty_signature sg}, _, _) ->
+        List.iter
+          (function Sig_module (id', _, _, _, _) ->
+              subst :=
+                Path.Map.add (Pdot (Pident id, Ident.name id')) id' !subst
+            | _ -> ())
+          sg
+    | _ -> ()
+  in
+  let it = {type_iterators with it_path; it_signature_item} in
+  it.it_module_type it mty;
+  it.it_module_type unmark_iterators mty;
+  Path.Set.fold (fun p -> Ident.Set.union (collect_ids !subst !bindings p))
+    !paths Ident.Set.empty
+
+type remove_alias_args =
+    { mutable modified: bool;
+      exclude: Ident.t -> Path.t -> bool;
+      scrape: Env.t -> module_type -> module_type }
+
+let rec remove_aliases_mty env args pres mty =
+  let args' = {args with modified = false} in
+  let res =
+    match args.scrape env mty with
+      Mty_signature sg ->
+        Mp_present, Mty_signature (remove_aliases_sig env args' sg)
+    | Mty_alias _ ->
+        let mty' = Env.scrape_alias env mty in
+        if mty' = mty then begin
+          pres, mty
+        end else begin
+          args'.modified <- true;
+          remove_aliases_mty env args' Mp_present mty'
+        end
+    | mty ->
+        Mp_present, mty
+  in
+  if args'.modified then begin
+    args.modified <- true;
+    res
+  end else begin
+    pres, mty
+  end
+
+and remove_aliases_sig env args sg =
+  match sg with
+    [] -> []
+  | Sig_module(id, pres, md, rs, priv) :: rem  ->
+      let pres, mty =
+        match md.md_type with
+          Mty_alias p when args.exclude id p ->
+            pres, md.md_type
+        | mty ->
+            remove_aliases_mty env args pres mty
+      in
+      Sig_module(id, pres, {md with md_type = mty} , rs, priv) ::
+      remove_aliases_sig (Env.add_module id pres mty env) args rem
+  | Sig_modtype(id, mtd, priv) :: rem ->
+      Sig_modtype(id, mtd, priv) ::
+      remove_aliases_sig (Env.add_modtype id mtd env) args rem
+  | it :: rem ->
+      it :: remove_aliases_sig env args rem
+
+let scrape_for_functor_arg env mty =
+  let exclude _id p =
+    try ignore (Env.find_module p env); true with Not_found -> false
+  in
+  let _, mty =
+    remove_aliases_mty env {modified=false; exclude; scrape} Mp_present mty
+  in
+  mty
+
+let scrape_for_type_of ~remove_aliases env mty =
+  if remove_aliases then begin
+    let excl = collect_arg_paths mty in
+    let exclude id _p = Ident.Set.mem id excl in
+    let scrape _ mty = mty in
+    let _, mty =
+      remove_aliases_mty env {modified=false; exclude; scrape} Mp_present mty
+    in
+    mty
+  end else begin
+    let _, mty = scrape_for_type_of env Mp_present mty in
+    mty
+  end
+
+(* Lower non-generalizable type variables *)
+
+let lower_nongen nglev mty =
+  let open Btype in
+  let it_type_expr it ty =
+    let ty = repr ty in
+    match ty with
+      {desc=Tvar _; level} ->
+        if level < generic_level && level > nglev then set_level ty nglev
+    | _ ->
+        type_iterators.it_type_expr it ty
+  in
+  let it = {type_iterators with it_type_expr} in
+  it.it_module_type it mty;
+  it.it_module_type unmark_iterators mty
diff --git a/upstream/ocaml_413/typing/mtype.mli b/upstream/ocaml_413/typing/mtype.mli
new file mode 100644
index 0000000..68d290b
--- /dev/null
+++ b/upstream/ocaml_413/typing/mtype.mli
@@ -0,0 +1,55 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Operations on module types *)
+
+open Types
+
+val scrape: Env.t -> module_type -> module_type
+        (* Expand toplevel module type abbreviations
+           till hitting a "hard" module type (signature, functor,
+           or abstract module type ident. *)
+val scrape_for_functor_arg: Env.t -> module_type -> module_type
+        (* Remove aliases in a functor argument type *)
+val scrape_for_type_of:
+  remove_aliases:bool -> Env.t -> module_type -> module_type
+        (* Process type for module type of *)
+val freshen: scope:int -> module_type -> module_type
+        (* Return an alpha-equivalent copy of the given module type
+           where bound identifiers are fresh. *)
+val strengthen: aliasable:bool -> Env.t -> module_type -> Path.t -> module_type
+        (* Strengthen abstract type components relative to the
+           given path. *)
+val strengthen_decl:
+  aliasable:bool -> Env.t -> module_declaration -> Path.t -> module_declaration
+val nondep_supertype: Env.t -> Ident.t list -> module_type -> module_type
+        (* Return the smallest supertype of the given type
+           in which none of the given idents appears.
+           @raise [Ctype.Nondep_cannot_erase] if no such type exists. *)
+val nondep_sig_item: Env.t -> Ident.t list -> signature_item -> signature_item
+        (* Returns the signature item with its type updated
+           to be the smallest supertype of its initial type
+           in which none of the given idents appears.
+           @raise [Ctype.Nondep_cannot_erase] if no such type exists. *)
+val no_code_needed: Env.t -> module_type -> bool
+val no_code_needed_sig: Env.t -> signature -> bool
+        (* Determine whether a module needs no implementation code,
+           i.e. consists only of type definitions. *)
+val enrich_modtype: Env.t -> Path.t -> module_type -> module_type
+val enrich_typedecl: Env.t -> Path.t -> Ident.t -> type_declaration ->
+  type_declaration
+val type_paths: Env.t -> Path.t -> module_type -> Path.t list
+val contains_type: Env.t -> module_type -> bool
+val lower_nongen: int -> module_type -> unit
diff --git a/upstream/ocaml_413/typing/oprint.ml b/upstream/ocaml_413/typing/oprint.ml
new file mode 100644
index 0000000..7a47cab
--- /dev/null
+++ b/upstream/ocaml_413/typing/oprint.ml
@@ -0,0 +1,832 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Projet Cristal, INRIA Rocquencourt                   *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Format
+open Outcometree
+
+exception Ellipsis
+
+let cautious f ppf arg =
+  try f ppf arg with
+    Ellipsis -> fprintf ppf "..."
+
+let print_lident ppf = function
+  | "::" -> pp_print_string ppf "(::)"
+  | s -> pp_print_string ppf s
+
+let rec print_ident ppf =
+  function
+    Oide_ident s -> print_lident ppf s.printed_name
+  | Oide_dot (id, s) ->
+      print_ident ppf id; pp_print_char ppf '.'; print_lident ppf s
+  | Oide_apply (id1, id2) ->
+      fprintf ppf "%a(%a)" print_ident id1 print_ident id2
+
+let out_ident = ref print_ident
+
+(* Check a character matches the [identchar_latin1] class from the lexer *)
+let is_ident_char c =
+  match c with
+  | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214' | '\216'..'\246'
+  | '\248'..'\255' | '\'' | '0'..'9' -> true
+  | _ -> false
+
+let all_ident_chars s =
+  let rec loop s len i =
+    if i < len then begin
+      if is_ident_char s.[i] then loop s len (i+1)
+      else false
+    end else begin
+      true
+    end
+  in
+  let len = String.length s in
+  loop s len 0
+
+let parenthesized_ident name =
+  (List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"])
+  || not (all_ident_chars name)
+
+let value_ident ppf name =
+  if parenthesized_ident name then
+    fprintf ppf "( %s )" name
+  else
+    pp_print_string ppf name
+
+(* Values *)
+
+let valid_float_lexeme s =
+  let l = String.length s in
+  let rec loop i =
+    if i >= l then s ^ "." else
+    match s.[i] with
+    | '0' .. '9' | '-' -> loop (i+1)
+    | _ -> s
+  in loop 0
+
+let float_repres f =
+  match classify_float f with
+    FP_nan -> "nan"
+  | FP_infinite ->
+      if f < 0.0 then "neg_infinity" else "infinity"
+  | _ ->
+      let float_val =
+        let s1 = Printf.sprintf "%.12g" f in
+        if f = float_of_string s1 then s1 else
+        let s2 = Printf.sprintf "%.15g" f in
+        if f = float_of_string s2 then s2 else
+        Printf.sprintf "%.18g" f
+      in valid_float_lexeme float_val
+
+let parenthesize_if_neg ppf fmt v isneg =
+  if isneg then pp_print_char ppf '(';
+  fprintf ppf fmt v;
+  if isneg then pp_print_char ppf ')'
+
+let escape_string s =
+  (* Escape only C0 control characters (bytes <= 0x1F), DEL(0x7F), '\\'
+     and '"' *)
+   let n = ref 0 in
+  for i = 0 to String.length s - 1 do
+    n := !n +
+      (match String.unsafe_get s i with
+       | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2
+       | '\x00' .. '\x1F'
+       | '\x7F' -> 4
+       | _ -> 1)
+  done;
+  if !n = String.length s then s else begin
+    let s' = Bytes.create !n in
+    n := 0;
+    for i = 0 to String.length s - 1 do
+      begin match String.unsafe_get s i with
+      | ('\"' | '\\') as c ->
+          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n c
+      | '\n' ->
+          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'n'
+      | '\t' ->
+          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 't'
+      | '\r' ->
+          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'r'
+      | '\b' ->
+          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'b'
+      | '\x00' .. '\x1F' | '\x7F' as c ->
+          let a = Char.code c in
+          Bytes.unsafe_set s' !n '\\';
+          incr n;
+          Bytes.unsafe_set s' !n (Char.chr (48 + a / 100));
+          incr n;
+          Bytes.unsafe_set s' !n (Char.chr (48 + (a / 10) mod 10));
+          incr n;
+          Bytes.unsafe_set s' !n (Char.chr (48 + a mod 10));
+      | c -> Bytes.unsafe_set s' !n c
+      end;
+      incr n
+    done;
+    Bytes.to_string s'
+  end
+
+
+let print_out_string ppf s =
+  let not_escaped =
+    (* let the user dynamically choose if strings should be escaped: *)
+    match Sys.getenv_opt "OCAMLTOP_UTF_8" with
+    | None -> true
+    | Some x ->
+        match bool_of_string_opt x with
+        | None -> true
+        | Some f -> f in
+  if not_escaped then
+    fprintf ppf "\"%s\"" (escape_string s)
+  else
+    fprintf ppf "%S" s
+
+let print_out_value ppf tree =
+  let rec print_tree_1 ppf =
+    function
+    | Oval_constr (name, [param]) ->
+        fprintf ppf "@[<1>%a@ %a@]" print_ident name print_constr_param param
+    | Oval_constr (name, (_ :: _ as params)) ->
+        fprintf ppf "@[<1>%a@ (%a)@]" print_ident name
+          (print_tree_list print_tree_1 ",") params
+    | Oval_variant (name, Some param) ->
+        fprintf ppf "@[<2>`%s@ %a@]" name print_constr_param param
+    | tree -> print_simple_tree ppf tree
+  and print_constr_param ppf = function
+    | Oval_int i -> parenthesize_if_neg ppf "%i" i (i < 0)
+    | Oval_int32 i -> parenthesize_if_neg ppf "%lil" i (i < 0l)
+    | Oval_int64 i -> parenthesize_if_neg ppf "%LiL" i (i < 0L)
+    | Oval_nativeint i -> parenthesize_if_neg ppf "%nin" i (i < 0n)
+    | Oval_float f ->
+        parenthesize_if_neg ppf "%s" (float_repres f)
+                                     (f < 0.0 || 1. /. f = neg_infinity)
+    | Oval_string (_,_, Ostr_bytes) as tree ->
+      pp_print_char ppf '(';
+      print_simple_tree ppf tree;
+      pp_print_char ppf ')';
+    | tree -> print_simple_tree ppf tree
+  and print_simple_tree ppf =
+    function
+      Oval_int i -> fprintf ppf "%i" i
+    | Oval_int32 i -> fprintf ppf "%lil" i
+    | Oval_int64 i -> fprintf ppf "%LiL" i
+    | Oval_nativeint i -> fprintf ppf "%nin" i
+    | Oval_float f -> pp_print_string ppf (float_repres f)
+    | Oval_char c -> fprintf ppf "%C" c
+    | Oval_string (s, maxlen, kind) ->
+       begin try
+         let len = String.length s in
+         let s = if len > maxlen then String.sub s 0 maxlen else s in
+         begin match kind with
+         | Ostr_bytes -> fprintf ppf "Bytes.of_string %S" s
+         | Ostr_string -> print_out_string ppf s
+         end;
+         (if len > maxlen then
+            fprintf ppf
+              "... (* string length %d; truncated *)" len
+         )
+          with
+          Invalid_argument _ (* "String.create" *)-> fprintf ppf "<huge string>"
+        end
+    | Oval_list tl ->
+        fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ";") tl
+    | Oval_array tl ->
+        fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ";") tl
+    | Oval_constr (name, []) -> print_ident ppf name
+    | Oval_variant (name, None) -> fprintf ppf "`%s" name
+    | Oval_stuff s -> pp_print_string ppf s
+    | Oval_record fel ->
+        fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel
+    | Oval_ellipsis -> raise Ellipsis
+    | Oval_printer f -> f ppf
+    | Oval_tuple tree_list ->
+        fprintf ppf "@[<1>(%a)@]" (print_tree_list print_tree_1 ",") tree_list
+    | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree_1) tree
+  and print_fields first ppf =
+    function
+      [] -> ()
+    | (name, tree) :: fields ->
+        if not first then fprintf ppf ";@ ";
+        fprintf ppf "@[<1>%a@ =@ %a@]" print_ident name (cautious print_tree_1)
+          tree;
+        print_fields false ppf fields
+  and print_tree_list print_item sep ppf tree_list =
+    let rec print_list first ppf =
+      function
+        [] -> ()
+      | tree :: tree_list ->
+          if not first then fprintf ppf "%s@ " sep;
+          print_item ppf tree;
+          print_list false ppf tree_list
+    in
+    cautious (print_list true) ppf tree_list
+  in
+  cautious print_tree_1 ppf tree
+
+let out_value = ref print_out_value
+
+(* Types *)
+
+let rec print_list_init pr sep ppf =
+  function
+    [] -> ()
+  | a :: l -> sep ppf; pr ppf a; print_list_init pr sep ppf l
+
+let rec print_list pr sep ppf =
+  function
+    [] -> ()
+  | [a] -> pr ppf a
+  | a :: l -> pr ppf a; sep ppf; print_list pr sep ppf l
+
+let pr_present =
+  print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ")
+
+let pr_var = Pprintast.tyvar
+
+let pr_vars =
+  print_list pr_var (fun ppf -> fprintf ppf "@ ")
+
+let rec print_out_type ppf =
+  function
+  | Otyp_alias (ty, s) ->
+      fprintf ppf "@[%a@ as %a@]" print_out_type ty pr_var s
+  | Otyp_poly (sl, ty) ->
+      fprintf ppf "@[<hov 2>%a.@ %a@]"
+        pr_vars sl
+        print_out_type ty
+  | ty ->
+      print_out_type_1 ppf ty
+
+and print_out_type_1 ppf =
+  function
+    Otyp_arrow (lab, ty1, ty2) ->
+      pp_open_box ppf 0;
+      if lab <> "" then (pp_print_string ppf lab; pp_print_char ppf ':');
+      print_out_type_2 ppf ty1;
+      pp_print_string ppf " ->";
+      pp_print_space ppf ();
+      print_out_type_1 ppf ty2;
+      pp_close_box ppf ()
+  | ty -> print_out_type_2 ppf ty
+and print_out_type_2 ppf =
+  function
+    Otyp_tuple tyl ->
+      fprintf ppf "@[<0>%a@]" (print_typlist print_simple_out_type " *") tyl
+  | ty -> print_simple_out_type ppf ty
+and print_simple_out_type ppf =
+  function
+    Otyp_class (ng, id, tyl) ->
+      fprintf ppf "@[%a%s#%a@]" print_typargs tyl (if ng then "_" else "")
+        print_ident id
+  | Otyp_constr (id, tyl) ->
+      pp_open_box ppf 0;
+      print_typargs ppf tyl;
+      print_ident ppf id;
+      pp_close_box ppf ()
+  | Otyp_object (fields, rest) ->
+      fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields
+  | Otyp_stuff s -> pp_print_string ppf s
+  | Otyp_var (ng, s) -> pr_var ppf (if ng then "_" ^ s else s)
+  | Otyp_variant (non_gen, row_fields, closed, tags) ->
+      let print_present ppf =
+        function
+          None | Some [] -> ()
+        | Some l -> fprintf ppf "@;<1 -2>> @[<hov>%a@]" pr_present l
+      in
+      let print_fields ppf =
+        function
+          Ovar_fields fields ->
+            print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ")
+              ppf fields
+        | Ovar_typ typ ->
+           print_simple_out_type ppf typ
+      in
+      fprintf ppf "%s@[<hov>[%s@[<hv>@[<hv>%a@]%a@]@ ]@]"
+        (if non_gen then "_" else "")
+        (if closed then if tags = None then " " else "< "
+         else if tags = None then "> " else "? ")
+        print_fields row_fields
+        print_present tags
+  | Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty ->
+      pp_open_box ppf 1;
+      pp_print_char ppf '(';
+      print_out_type ppf ty;
+      pp_print_char ppf ')';
+      pp_close_box ppf ()
+  | Otyp_abstract | Otyp_open
+  | Otyp_sum _ | Otyp_manifest (_, _) -> ()
+  | Otyp_record lbls -> print_record_decl ppf lbls
+  | Otyp_module (p, fl) ->
+      fprintf ppf "@[<1>(module %a" print_ident p;
+      let first = ref true in
+      List.iter
+        (fun (s, t) ->
+          let sep = if !first then (first := false; "with") else "and" in
+          fprintf ppf " %s type %s = %a" sep s print_out_type t
+        )
+        fl;
+      fprintf ppf ")@]"
+  | Otyp_attribute (t, attr) ->
+      fprintf ppf "@[<1>(%a [@@%s])@]" print_out_type t attr.oattr_name
+and print_record_decl ppf lbls =
+  fprintf ppf "{%a@;<1 -2>}"
+    (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls
+and print_fields rest ppf =
+  function
+    [] ->
+      begin match rest with
+        Some non_gen -> fprintf ppf "%s.." (if non_gen then "_" else "")
+      | None -> ()
+      end
+  | [s, t] ->
+      fprintf ppf "%s : %a" s print_out_type t;
+      begin match rest with
+        Some _ -> fprintf ppf ";@ "
+      | None -> ()
+      end;
+      print_fields rest ppf []
+  | (s, t) :: l ->
+      fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l
+and print_row_field ppf (l, opt_amp, tyl) =
+  let pr_of ppf =
+    if opt_amp then fprintf ppf " of@ &@ "
+    else if tyl <> [] then fprintf ppf " of@ "
+    else fprintf ppf ""
+  in
+  fprintf ppf "@[<hv 2>`%s%t%a@]" l pr_of (print_typlist print_out_type " &")
+    tyl
+and print_typlist print_elem sep ppf =
+  function
+    [] -> ()
+  | [ty] -> print_elem ppf ty
+  | ty :: tyl ->
+      print_elem ppf ty;
+      pp_print_string ppf sep;
+      pp_print_space ppf ();
+      print_typlist print_elem sep ppf tyl
+and print_typargs ppf =
+  function
+    [] -> ()
+  | [ty1] -> print_simple_out_type ppf ty1; pp_print_space ppf ()
+  | tyl ->
+      pp_open_box ppf 1;
+      pp_print_char ppf '(';
+      print_typlist print_out_type "," ppf tyl;
+      pp_print_char ppf ')';
+      pp_close_box ppf ();
+      pp_print_space ppf ()
+and print_out_label ppf (name, mut, arg) =
+  fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name
+    print_out_type arg
+
+let out_label = ref print_out_label
+
+let out_type = ref print_out_type
+
+(* Class types *)
+
+let print_type_parameter ppf s =
+  if s = "_" then fprintf ppf "_" else pr_var ppf s
+
+let type_parameter ppf (ty, (var, inj)) =
+  let open Asttypes in
+  fprintf ppf "%s%s%a"
+    (match var with Covariant -> "+" | Contravariant -> "-" | NoVariance ->  "")
+    (match inj with Injective -> "!" | NoInjectivity -> "")
+    print_type_parameter ty
+
+let print_out_class_params ppf =
+  function
+    [] -> ()
+  | tyl ->
+      fprintf ppf "@[<1>[%a]@]@ "
+        (print_list type_parameter (fun ppf -> fprintf ppf ", "))
+        tyl
+
+let rec print_out_class_type ppf =
+  function
+    Octy_constr (id, tyl) ->
+      let pr_tyl ppf =
+        function
+          [] -> ()
+        | tyl ->
+            fprintf ppf "@[<1>[%a]@]@ " (print_typlist !out_type ",") tyl
+      in
+      fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id
+  | Octy_arrow (lab, ty, cty) ->
+      fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "")
+        print_out_type_2 ty print_out_class_type cty
+  | Octy_signature (self_ty, csil) ->
+      let pr_param ppf =
+        function
+          Some ty -> fprintf ppf "@ @[(%a)@]" !out_type ty
+        | None -> ()
+      in
+      fprintf ppf "@[<hv 2>@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty
+        (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ "))
+        csil
+and print_out_class_sig_item ppf =
+  function
+    Ocsg_constraint (ty1, ty2) ->
+      fprintf ppf "@[<2>constraint %a =@ %a@]" !out_type ty1
+        !out_type ty2
+  | Ocsg_method (name, priv, virt, ty) ->
+      fprintf ppf "@[<2>method %s%s%s :@ %a@]"
+        (if priv then "private " else "") (if virt then "virtual " else "")
+        name !out_type ty
+  | Ocsg_value (name, mut, vr, ty) ->
+      fprintf ppf "@[<2>val %s%s%s :@ %a@]"
+        (if mut then "mutable " else "")
+        (if vr then "virtual " else "")
+        name !out_type ty
+
+let out_class_type = ref print_out_class_type
+
+(* Signature *)
+
+let out_module_type = ref (fun _ -> failwith "Oprint.out_module_type")
+let out_sig_item = ref (fun _ -> failwith "Oprint.out_sig_item")
+let out_signature = ref (fun _ -> failwith "Oprint.out_signature")
+let out_type_extension = ref (fun _ -> failwith "Oprint.out_type_extension")
+let out_functor_parameters =
+  ref (fun _ -> failwith "Oprint.out_functor_parameters")
+
+(* For anonymous functor arguments, the logic to choose between
+   the long-form
+     functor (_ : S) -> ...
+   and the short-form
+     S -> ...
+   is as follows: if we are already printing long-form functor arguments,
+   we use the long form unless all remaining functor arguments can use
+   the short form. (Otherwise use the short form.)
+
+   For example,
+     functor (X : S1) (_ : S2) (Y : S3) (_ : S4) (_ : S5) -> sig end
+   will get printed as
+     functor (X : S1) (_ : S2) (Y : S3) -> S4 -> S5 -> sig end
+
+   but
+     functor (_ : S1) (_ : S2) (Y : S3) (_ : S4) (_ : S5) -> sig end
+   gets printed as
+     S1 -> S2 -> functor (Y : S3) -> S4 -> S5 -> sig end
+*)
+
+(* take a module type that may be a functor type,
+   and return the longest prefix list of arguments
+   that should be printed in long form. *)
+
+let rec collect_functor_args acc = function
+  | Omty_functor (param, mty_res) ->
+      collect_functor_args (param :: acc) mty_res
+  | non_functor -> (acc, non_functor)
+let collect_functor_args mty =
+  let l, rest = collect_functor_args [] mty in
+  List.rev l, rest
+
+let split_anon_functor_arguments params =
+  let rec uncollect_anonymous_suffix acc rest = match acc with
+    | Some (None, mty_arg) :: acc ->
+        uncollect_anonymous_suffix acc
+          (Some (None, mty_arg) :: rest)
+    | _ :: _ | [] ->
+        (acc, rest)
+  in
+  let (acc, rest) = uncollect_anonymous_suffix (List.rev params) [] in
+  (List.rev acc, rest)
+
+let rec print_out_module_type ppf mty =
+  print_out_functor ppf mty
+
+and print_out_functor_parameters ppf l =
+  let print_nonanon_arg ppf = function
+    | None ->
+        fprintf ppf "()"
+    | Some (param, mty) ->
+        fprintf ppf "(%s : %a)"
+          (Option.value param ~default:"_")
+          print_out_module_type mty
+  in
+  let rec print_args ppf = function
+    | [] -> ()
+    | Some (None, mty_arg) :: l ->
+        fprintf ppf "%a ->@ %a"
+          print_simple_out_module_type mty_arg
+          print_args l
+    | _ :: _ as non_anonymous_functor ->
+        let args, anons = split_anon_functor_arguments non_anonymous_functor in
+        fprintf ppf "@[<2>functor@ %a@]@ ->@ %a"
+          (pp_print_list ~pp_sep:pp_print_space print_nonanon_arg) args
+          print_args anons
+  in
+  print_args ppf l
+
+and print_out_functor ppf t =
+  let params, non_functor = collect_functor_args t in
+  fprintf ppf "@[<2>%a%a@]"
+    print_out_functor_parameters params
+    print_simple_out_module_type non_functor
+and print_simple_out_module_type ppf =
+  function
+    Omty_abstract -> ()
+  | Omty_ident id -> fprintf ppf "%a" print_ident id
+  | Omty_signature sg ->
+     begin match sg with
+       | [] -> fprintf ppf "sig end"
+       | sg ->
+          fprintf ppf "@[<hv 2>sig@ %a@;<1 -2>end@]" print_out_signature sg
+     end
+  | Omty_alias id -> fprintf ppf "(module %a)" print_ident id
+  | Omty_functor _ as non_simple ->
+     fprintf ppf "(%a)" print_out_module_type non_simple
+and print_out_signature ppf =
+  function
+    [] -> ()
+  | [item] -> !out_sig_item ppf item
+  | Osig_typext(ext, Oext_first) :: items ->
+      (* Gather together the extension constructors *)
+      let rec gather_extensions acc items =
+        match items with
+            Osig_typext(ext, Oext_next) :: items ->
+              gather_extensions
+                ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc)
+                items
+          | _ -> (List.rev acc, items)
+      in
+      let exts, items =
+        gather_extensions
+          [(ext.oext_name, ext.oext_args, ext.oext_ret_type)]
+          items
+      in
+      let te =
+        { otyext_name = ext.oext_type_name;
+          otyext_params = ext.oext_type_params;
+          otyext_constructors = exts;
+          otyext_private = ext.oext_private }
+      in
+        fprintf ppf "%a@ %a" !out_type_extension te print_out_signature items
+  | item :: items ->
+      fprintf ppf "%a@ %a" !out_sig_item item print_out_signature items
+and print_out_sig_item ppf =
+  function
+    Osig_class (vir_flag, name, params, clt, rs) ->
+      fprintf ppf "@[<2>%s%s@ %a%s@ :@ %a@]"
+        (if rs = Orec_next then "and" else "class")
+        (if vir_flag then " virtual" else "") print_out_class_params params
+        name !out_class_type clt
+  | Osig_class_type (vir_flag, name, params, clt, rs) ->
+      fprintf ppf "@[<2>%s%s@ %a%s@ =@ %a@]"
+        (if rs = Orec_next then "and" else "class type")
+        (if vir_flag then " virtual" else "") print_out_class_params params
+        name !out_class_type clt
+  | Osig_typext (ext, Oext_exception) ->
+      fprintf ppf "@[<2>exception %a@]"
+        print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type)
+  | Osig_typext (ext, _es) ->
+      print_out_extension_constructor ppf ext
+  | Osig_modtype (name, Omty_abstract) ->
+      fprintf ppf "@[<2>module type %s@]" name
+  | Osig_modtype (name, mty) ->
+      fprintf ppf "@[<2>module type %s =@ %a@]" name !out_module_type mty
+  | Osig_module (name, Omty_alias id, _) ->
+      fprintf ppf "@[<2>module %s =@ %a@]" name print_ident id
+  | Osig_module (name, mty, rs) ->
+      fprintf ppf "@[<2>%s %s :@ %a@]"
+        (match rs with Orec_not -> "module"
+                     | Orec_first -> "module rec"
+                     | Orec_next -> "and")
+        name !out_module_type mty
+  | Osig_type(td, rs) ->
+        print_out_type_decl
+          (match rs with
+           | Orec_not   -> "type nonrec"
+           | Orec_first -> "type"
+           | Orec_next  -> "and")
+          ppf td
+  | Osig_value vd ->
+      let kwd = if vd.oval_prims = [] then "val" else "external" in
+      let pr_prims ppf =
+        function
+          [] -> ()
+        | s :: sl ->
+            fprintf ppf "@ = \"%s\"" s;
+            List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl
+      in
+      fprintf ppf "@[<2>%s %a :@ %a%a%a@]" kwd value_ident vd.oval_name
+        !out_type vd.oval_type pr_prims vd.oval_prims
+        (fun ppf -> List.iter (fun a -> fprintf ppf "@ [@@@@%s]" a.oattr_name))
+        vd.oval_attributes
+  | Osig_ellipsis ->
+      fprintf ppf "..."
+
+and print_out_type_decl kwd ppf td =
+  let print_constraints ppf =
+    List.iter
+      (fun (ty1, ty2) ->
+         fprintf ppf "@ @[<2>constraint %a =@ %a@]" !out_type ty1
+           !out_type ty2)
+      td.otype_cstrs
+  in
+  let type_defined ppf =
+    match td.otype_params with
+      [] -> pp_print_string ppf td.otype_name
+    | [param] -> fprintf ppf "@[%a@ %s@]" type_parameter param td.otype_name
+    | _ ->
+        fprintf ppf "@[(@[%a)@]@ %s@]"
+          (print_list type_parameter (fun ppf -> fprintf ppf ",@ "))
+          td.otype_params
+          td.otype_name
+  in
+  let print_manifest ppf =
+    function
+      Otyp_manifest (ty, _) -> fprintf ppf " =@ %a" !out_type ty
+    | _ -> ()
+  in
+  let print_name_params ppf =
+    fprintf ppf "%s %t%a" kwd type_defined print_manifest td.otype_type
+  in
+  let ty =
+    match td.otype_type with
+      Otyp_manifest (_, ty) -> ty
+    | _ -> td.otype_type
+  in
+  let print_private ppf = function
+    Asttypes.Private -> fprintf ppf " private"
+  | Asttypes.Public -> ()
+  in
+  let print_immediate ppf =
+    match td.otype_immediate with
+    | Unknown -> ()
+    | Always -> fprintf ppf " [%@%@immediate]"
+    | Always_on_64bits -> fprintf ppf " [%@%@immediate64]"
+  in
+  let print_unboxed ppf =
+    if td.otype_unboxed then fprintf ppf " [%@%@unboxed]" else ()
+  in
+  let print_out_tkind ppf = function
+  | Otyp_abstract -> ()
+  | Otyp_record lbls ->
+      fprintf ppf " =%a %a"
+        print_private td.otype_private
+        print_record_decl lbls
+  | Otyp_sum constrs ->
+      let variants fmt constrs =
+        if constrs = [] then fprintf fmt "|" else
+        fprintf fmt "%a" (print_list print_out_constr
+          (fun ppf -> fprintf ppf "@ | ")) constrs in
+      fprintf ppf " =%a@;<1 2>%a"
+        print_private td.otype_private variants constrs
+  | Otyp_open ->
+      fprintf ppf " =%a .."
+        print_private td.otype_private
+  | ty ->
+      fprintf ppf " =%a@;<1 2>%a"
+        print_private td.otype_private
+        !out_type ty
+  in
+  fprintf ppf "@[<2>@[<hv 2>%t%a@]%t%t%t@]"
+    print_name_params
+    print_out_tkind ty
+    print_constraints
+    print_immediate
+    print_unboxed
+
+and print_out_constr ppf (name, tyl,ret_type_opt) =
+  let name =
+    match name with
+    | "::" -> "(::)"   (* #7200 *)
+    | s -> s
+  in
+  match ret_type_opt with
+  | None ->
+      begin match tyl with
+      | [] ->
+          pp_print_string ppf name
+      | _ ->
+          fprintf ppf "@[<2>%s of@ %a@]" name
+            (print_typlist print_simple_out_type " *") tyl
+      end
+  | Some ret_type ->
+      begin match tyl with
+      | [] ->
+          fprintf ppf "@[<2>%s :@ %a@]" name print_simple_out_type  ret_type
+      | _ ->
+          fprintf ppf "@[<2>%s :@ %a -> %a@]" name
+            (print_typlist print_simple_out_type " *")
+            tyl print_simple_out_type ret_type
+      end
+
+and print_out_extension_constructor ppf ext =
+  let print_extended_type ppf =
+      match ext.oext_type_params with
+        [] -> fprintf ppf "%s" ext.oext_type_name
+      | [ty_param] ->
+        fprintf ppf "@[%a@ %s@]"
+          print_type_parameter
+          ty_param
+          ext.oext_type_name
+      | _ ->
+        fprintf ppf "@[(@[%a)@]@ %s@]"
+          (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ "))
+          ext.oext_type_params
+          ext.oext_type_name
+  in
+  fprintf ppf "@[<hv 2>type %t +=%s@;<1 2>%a@]"
+    print_extended_type
+    (if ext.oext_private = Asttypes.Private then " private" else "")
+    print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type)
+
+and print_out_type_extension ppf te =
+  let print_extended_type ppf =
+    match te.otyext_params with
+      [] -> fprintf ppf "%s" te.otyext_name
+    | [param] ->
+      fprintf ppf "@[%a@ %s@]"
+        print_type_parameter param
+        te.otyext_name
+    | _ ->
+        fprintf ppf "@[(@[%a)@]@ %s@]"
+          (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ "))
+          te.otyext_params
+          te.otyext_name
+  in
+  fprintf ppf "@[<hv 2>type %t +=%s@;<1 2>%a@]"
+    print_extended_type
+    (if te.otyext_private = Asttypes.Private then " private" else "")
+    (print_list print_out_constr (fun ppf -> fprintf ppf "@ | "))
+    te.otyext_constructors
+
+let out_constr = ref print_out_constr
+let _ = out_module_type := print_out_module_type
+let _ = out_signature := print_out_signature
+let _ = out_sig_item := print_out_sig_item
+let _ = out_type_extension := print_out_type_extension
+let _ = out_functor_parameters := print_out_functor_parameters
+
+(* Phrases *)
+
+let print_out_exception ppf exn outv =
+  match exn with
+    Sys.Break -> fprintf ppf "Interrupted.@."
+  | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@."
+  | Stack_overflow ->
+      fprintf ppf "Stack overflow during evaluation (looping recursion?).@."
+  | _ -> match Printexc.use_printers exn with
+        | None -> fprintf ppf "@[Exception:@ %a.@]@." !out_value outv
+        | Some s -> fprintf ppf "@[Exception:@ %s@]@." s
+
+let rec print_items ppf =
+  function
+    [] -> ()
+  | (Osig_typext(ext, Oext_first), None) :: items ->
+      (* Gather together extension constructors *)
+      let rec gather_extensions acc items =
+        match items with
+            (Osig_typext(ext, Oext_next), None) :: items ->
+              gather_extensions
+                ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc)
+                items
+          | _ -> (List.rev acc, items)
+      in
+      let exts, items =
+        gather_extensions
+          [(ext.oext_name, ext.oext_args, ext.oext_ret_type)]
+          items
+      in
+      let te =
+        { otyext_name = ext.oext_type_name;
+          otyext_params = ext.oext_type_params;
+          otyext_constructors = exts;
+          otyext_private = ext.oext_private }
+      in
+        fprintf ppf "@[%a@]" !out_type_extension te;
+        if items <> [] then fprintf ppf "@ %a" print_items items
+  | (tree, valopt) :: items ->
+      begin match valopt with
+        Some v ->
+          fprintf ppf "@[<2>%a =@ %a@]" !out_sig_item tree
+            !out_value v
+      | None -> fprintf ppf "@[%a@]" !out_sig_item tree
+      end;
+      if items <> [] then fprintf ppf "@ %a" print_items items
+
+let print_out_phrase ppf =
+  function
+    Ophr_eval (outv, ty) ->
+      fprintf ppf "@[- : %a@ =@ %a@]@." !out_type ty !out_value outv
+  | Ophr_signature [] -> ()
+  | Ophr_signature items -> fprintf ppf "@[<v>%a@]@." print_items items
+  | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv
+
+let out_phrase = ref print_out_phrase
diff --git a/upstream/ocaml_413/typing/oprint.mli b/upstream/ocaml_413/typing/oprint.mli
new file mode 100644
index 0000000..bafd17c
--- /dev/null
+++ b/upstream/ocaml_413/typing/oprint.mli
@@ -0,0 +1,36 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Projet Cristal, INRIA Rocquencourt                   *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Format
+open Outcometree
+
+val out_ident : (formatter -> out_ident -> unit) ref
+val out_value : (formatter -> out_value -> unit) ref
+val out_label : (formatter -> string * bool * out_type -> unit) ref
+val out_type : (formatter -> out_type -> unit) ref
+val out_constr :
+  (formatter -> string * out_type list * out_type option -> unit) ref
+val out_class_type : (formatter -> out_class_type -> unit) ref
+val out_module_type : (formatter -> out_module_type -> unit) ref
+val out_sig_item : (formatter -> out_sig_item -> unit) ref
+val out_signature : (formatter -> out_sig_item list -> unit) ref
+val out_functor_parameters :
+  (formatter ->
+   (string option * Outcometree.out_module_type) option list -> unit)
+    ref
+val out_type_extension : (formatter -> out_type_extension -> unit) ref
+val out_phrase : (formatter -> out_phrase -> unit) ref
+
+val parenthesized_ident : string -> bool
diff --git a/upstream/ocaml_413/typing/outcometree.mli b/upstream/ocaml_413/typing/outcometree.mli
new file mode 100644
index 0000000..d9b4f04
--- /dev/null
+++ b/upstream/ocaml_413/typing/outcometree.mli
@@ -0,0 +1,150 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*      Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt          *)
+(*                                                                        *)
+(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Module [Outcometree]: results displayed by the toplevel *)
+
+(* These types represent messages that the toplevel displays as normal
+   results or errors. The real displaying is customisable using the hooks:
+      [Toploop.print_out_value]
+      [Toploop.print_out_type]
+      [Toploop.print_out_sig_item]
+      [Toploop.print_out_phrase] *)
+
+(** An [out_name] is a string representation of an identifier which can be
+    rewritten on the fly to avoid name collisions *)
+type out_name = { mutable printed_name: string }
+
+type out_ident =
+  | Oide_apply of out_ident * out_ident
+  | Oide_dot of out_ident * string
+  | Oide_ident of out_name
+
+type out_string =
+  | Ostr_string
+  | Ostr_bytes
+
+type out_attribute =
+  { oattr_name: string }
+
+type out_value =
+  | Oval_array of out_value list
+  | Oval_char of char
+  | Oval_constr of out_ident * out_value list
+  | Oval_ellipsis
+  | Oval_float of float
+  | Oval_int of int
+  | Oval_int32 of int32
+  | Oval_int64 of int64
+  | Oval_nativeint of nativeint
+  | Oval_list of out_value list
+  | Oval_printer of (Format.formatter -> unit)
+  | Oval_record of (out_ident * out_value) list
+  | Oval_string of string * int * out_string (* string, size-to-print, kind *)
+  | Oval_stuff of string
+  | Oval_tuple of out_value list
+  | Oval_variant of string * out_value option
+
+type out_type_param = string * (Asttypes.variance * Asttypes.injectivity)
+
+type out_type =
+  | Otyp_abstract
+  | Otyp_open
+  | Otyp_alias of out_type * string
+  | Otyp_arrow of string * out_type * out_type
+  | Otyp_class of bool * out_ident * out_type list
+  | Otyp_constr of out_ident * out_type list
+  | Otyp_manifest of out_type * out_type
+  | Otyp_object of (string * out_type) list * bool option
+  | Otyp_record of (string * bool * out_type) list
+  | Otyp_stuff of string
+  | Otyp_sum of (string * out_type list * out_type option) list
+  | Otyp_tuple of out_type list
+  | Otyp_var of bool * string
+  | Otyp_variant of
+      bool * out_variant * bool * (string list) option
+  | Otyp_poly of string list * out_type
+  | Otyp_module of out_ident * (string * out_type) list
+  | Otyp_attribute of out_type * out_attribute
+
+and out_variant =
+  | Ovar_fields of (string * bool * out_type list) list
+  | Ovar_typ of out_type
+
+type out_class_type =
+  | Octy_constr of out_ident * out_type list
+  | Octy_arrow of string * out_type * out_class_type
+  | Octy_signature of out_type option * out_class_sig_item list
+and out_class_sig_item =
+  | Ocsg_constraint of out_type * out_type
+  | Ocsg_method of string * bool * bool * out_type
+  | Ocsg_value of string * bool * bool * out_type
+
+type out_module_type =
+  | Omty_abstract
+  | Omty_functor of (string option * out_module_type) option * out_module_type
+  | Omty_ident of out_ident
+  | Omty_signature of out_sig_item list
+  | Omty_alias of out_ident
+and out_sig_item =
+  | Osig_class of
+      bool * string * out_type_param list * out_class_type *
+        out_rec_status
+  | Osig_class_type of
+      bool * string * out_type_param list * out_class_type *
+        out_rec_status
+  | Osig_typext of out_extension_constructor * out_ext_status
+  | Osig_modtype of string * out_module_type
+  | Osig_module of string * out_module_type * out_rec_status
+  | Osig_type of out_type_decl * out_rec_status
+  | Osig_value of out_val_decl
+  | Osig_ellipsis
+and out_type_decl =
+  { otype_name: string;
+    otype_params: out_type_param list;
+    otype_type: out_type;
+    otype_private: Asttypes.private_flag;
+    otype_immediate: Type_immediacy.t;
+    otype_unboxed: bool;
+    otype_cstrs: (out_type * out_type) list }
+and out_extension_constructor =
+  { oext_name: string;
+    oext_type_name: string;
+    oext_type_params: string list;
+    oext_args: out_type list;
+    oext_ret_type: out_type option;
+    oext_private: Asttypes.private_flag }
+and out_type_extension =
+  { otyext_name: string;
+    otyext_params: string list;
+    otyext_constructors: (string * out_type list * out_type option) list;
+    otyext_private: Asttypes.private_flag }
+and out_val_decl =
+  { oval_name: string;
+    oval_type: out_type;
+    oval_prims: string list;
+    oval_attributes: out_attribute list }
+and out_rec_status =
+  | Orec_not
+  | Orec_first
+  | Orec_next
+and out_ext_status =
+  | Oext_first
+  | Oext_next
+  | Oext_exception
+
+type out_phrase =
+  | Ophr_eval of out_value * out_type
+  | Ophr_signature of (out_sig_item * out_value option) list
+  | Ophr_exception of (exn * out_value)
diff --git a/upstream/ocaml_413/typing/parmatch.ml b/upstream/ocaml_413/typing/parmatch.ml
new file mode 100644
index 0000000..c179155
--- /dev/null
+++ b/upstream/ocaml_413/typing/parmatch.ml
@@ -0,0 +1,2479 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Detection of partial matches and unused match cases. *)
+
+open Misc
+open Asttypes
+open Types
+open Typedtree
+
+
+(*************************************)
+(* Utilities for building patterns   *)
+(*************************************)
+
+let make_pat desc ty tenv =
+  {pat_desc = desc; pat_loc = Location.none; pat_extra = [];
+   pat_type = ty ; pat_env = tenv;
+   pat_attributes = [];
+  }
+
+let omega = Patterns.omega
+let omegas = Patterns.omegas
+let omega_list = Patterns.omega_list
+
+let extra_pat =
+  make_pat
+    (Tpat_var (Ident.create_local "+", mknoloc "+"))
+    Ctype.none Env.empty
+
+
+(*******************)
+(* Coherence check *)
+(*******************)
+
+(* For some of the operations we do in this module, we would like (because it
+   simplifies matters) to assume that patterns appearing on a given column in a
+   pattern matrix are /coherent/ (think "of the same type").
+   Unfortunately that is not always true.
+
+   Consider the following (well-typed) example:
+   {[
+     type _ t = S : string t | U : unit t
+
+     let f (type a) (t1 : a t) (t2 : a t) (a : a) =
+       match t1, t2, a with
+       | U, _, () -> ()
+       | _, S, "" -> ()
+   ]}
+
+   Clearly the 3rd column contains incoherent patterns.
+
+   On the example above, most of the algorithms will explore the pattern matrix
+   as illustrated by the following tree:
+
+   {v
+                                                   S
+                                                -------> | "" |
+                             U     | S, "" | __/         | () |
+                         --------> | _, () |   \ not S
+        | U, _, () | __/                        -------> | () |
+        | _, S, "" |   \
+                        ---------> | S, "" | ----------> | "" |
+                          not U                    S
+   v}
+
+   where following an edge labelled by a pattern P means "assuming the value I
+   am matching on is filtered by [P] on the column I am currently looking at,
+   then the following submatrix is still reachable".
+
+   Notice that at any point of that tree, if the first column of a matrix is
+   incoherent, then the branch leading to it can only be taken if the scrutinee
+   is ill-typed.
+   In the example above the only case where we have a matrix with an incoherent
+   first column is when we consider [t1, t2, a] to be [U, S, ...]. However such
+   a value would be ill-typed, so we can never actually get there.
+
+   Checking the first column at each step of the recursion and making the
+   conscious decision of "aborting" the algorithm whenever the first column
+   becomes incoherent, allows us to retain the initial assumption in later
+   stages of the algorithms.
+
+   ---
+
+   N.B. two patterns can be considered coherent even though they might not be of
+   the same type.
+
+   That's in part because we only care about the "head" of patterns and leave
+   checking coherence of subpatterns for the next steps of the algorithm:
+   ('a', 'b') and (1, ()) will be deemed coherent because they are both a tuples
+   of arity 2 (we'll notice at a later stage the incoherence of 'a' and 1).
+
+   But also because it can be hard/costly to determine exactly whether two
+   patterns are of the same type or not (eg. in the example above with _ and S,
+   but see also the module [Coherence_illustration] in
+   testsuite/tests/basic-more/robustmatch.ml).
+
+   For the moment our weak, loosely-syntactic, coherence check seems to be
+   enough and we leave it to each user to consider (and document!) what happens
+   when an "incoherence" is not detected by this check.
+*)
+
+(* Given the first column of a simplified matrix, this function first looks for
+   a "discriminating" pattern on that column (i.e. a non-omega one) and then
+   check that every other head pattern in the column is coherent with that one.
+*)
+let all_coherent column =
+  let open Patterns.Head in
+  let coherent_heads hp1 hp2 =
+    match hp1.pat_desc, hp2.pat_desc with
+    | Construct c, Construct c' ->
+      c.cstr_consts = c'.cstr_consts
+      && c.cstr_nonconsts = c'.cstr_nonconsts
+    | Constant c1, Constant c2 -> begin
+        match c1, c2 with
+        | Const_char _, Const_char _
+        | Const_int _, Const_int _
+        | Const_int32 _, Const_int32 _
+        | Const_int64 _, Const_int64 _
+        | Const_nativeint _, Const_nativeint _
+        | Const_float _, Const_float _
+        | Const_string _, Const_string _ -> true
+        | ( Const_char _
+          | Const_int _
+          | Const_int32 _
+          | Const_int64 _
+          | Const_nativeint _
+          | Const_float _
+          | Const_string _), _ -> false
+      end
+    | Tuple l1, Tuple l2 -> l1 = l2
+    | Record (lbl1 :: _), Record (lbl2 :: _) ->
+      Array.length lbl1.lbl_all = Array.length lbl2.lbl_all
+    | Any, _
+    | _, Any
+    | Record [], Record []
+    | Variant _, Variant _
+    | Array _, Array _
+    | Lazy, Lazy -> true
+    | _, _ -> false
+  in
+  match
+    List.find
+      (function
+       | { pat_desc = Any } -> false
+       | _ -> true)
+      column
+  with
+  | exception Not_found ->
+    (* only omegas on the column: the column is coherent. *)
+    true
+  | discr_pat ->
+    List.for_all (coherent_heads discr_pat) column
+
+let first_column simplified_matrix =
+  List.map (fun ((head, _args), _rest) -> head) simplified_matrix
+
+(***********************)
+(* Compatibility check *)
+(***********************)
+
+(* Patterns p and q compatible means:
+   there exists value V that matches both, However....
+
+  The case of extension types is dubious, as constructor rebind permits
+  that different constructors are the same (and are thus compatible).
+
+  Compilation must take this into account, consider:
+
+  type t = ..
+  type t += A|B
+  type t += C=A
+
+  let f x y = match x,y with
+  | true,A  -> '1'
+  | _,C     -> '2'
+  | false,A -> '3'
+  | _,_     -> '_'
+
+  As C is bound to A the value of f false A is '2' (and not '3' as it would
+  be in the absence of rebinding).
+
+  Not considering rebinding, patterns "false,A" and "_,C" are incompatible
+  and the compiler can swap the second and third clause, resulting in the
+  (more efficiently compiled) matching
+
+  match x,y with
+  | true,A  -> '1'
+  | false,A -> '3'
+  | _,C     -> '2'
+  | _,_     -> '_'
+
+  This is not correct: when C is bound to A, "f false A" returns '2' (not '3')
+
+
+  However, diagnostics do not take constructor rebinding into account.
+  Notice, that due to module abstraction constructor rebinding is hidden.
+
+  module X : sig type t = .. type t += A|B end = struct
+    type t = ..
+    type t += A
+    type t += B=A
+  end
+
+  open X
+
+  let f x = match x with
+  | A -> '1'
+  | B -> '2'
+  | _ -> '_'
+
+  The second clause above will NOT (and cannot) be flagged as useless.
+
+  Finally, there are two compatibility functions:
+   compat p q      ---> 'syntactic compatibility, used for diagnostics.
+   may_compat p q --->   a safe approximation of possible compat,
+                         for compilation
+
+*)
+
+
+let is_absent tag row = Btype.row_field tag !row = Rabsent
+
+let is_absent_pat d =
+  match d.pat_desc with
+  | Patterns.Head.Variant { tag; cstr_row; _ } -> is_absent tag cstr_row
+  | _ -> false
+
+let const_compare x y =
+  match x,y with
+  | Const_float f1, Const_float f2 ->
+      Stdlib.compare (float_of_string f1) (float_of_string f2)
+  | Const_string (s1, _, _), Const_string (s2, _, _) ->
+      String.compare s1 s2
+  | (Const_int _
+    |Const_char _
+    |Const_string (_, _, _)
+    |Const_float _
+    |Const_int32 _
+    |Const_int64 _
+    |Const_nativeint _
+    ), _ -> Stdlib.compare x y
+
+let records_args l1 l2 =
+  (* Invariant: fields are already sorted by Typecore.type_label_a_list *)
+  let rec combine r1 r2 l1 l2 = match l1,l2 with
+  | [],[] -> List.rev r1, List.rev r2
+  | [],(_,_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2
+  | (_,_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 []
+  | (_,lbl1,p1)::rem1, ( _,lbl2,p2)::rem2 ->
+      if lbl1.lbl_pos < lbl2.lbl_pos then
+        combine (p1::r1) (omega::r2) rem1 l2
+      else if lbl1.lbl_pos > lbl2.lbl_pos then
+        combine (omega::r1) (p2::r2) l1 rem2
+      else (* same label on both sides *)
+        combine (p1::r1) (p2::r2) rem1 rem2 in
+  combine [] [] l1 l2
+
+
+
+module Compat
+    (Constr:sig
+      val equal :
+          Types.constructor_description ->
+            Types.constructor_description ->
+              bool
+    end) = struct
+
+  let rec compat p q = match p.pat_desc,q.pat_desc with
+(* Variables match any value *)
+  | ((Tpat_any|Tpat_var _),_)
+  | (_,(Tpat_any|Tpat_var _)) -> true
+(* Structural induction *)
+  | Tpat_alias (p,_,_),_      -> compat p q
+  | _,Tpat_alias (q,_,_)      -> compat p q
+  | Tpat_or (p1,p2,_),_ ->
+      (compat p1 q || compat p2 q)
+  | _,Tpat_or (q1,q2,_) ->
+      (compat p q1 || compat p q2)
+(* Constructors, with special case for extension *)
+  | Tpat_construct (_, c1, ps1, _), Tpat_construct (_, c2, ps2, _) ->
+      Constr.equal c1 c2 && compats ps1 ps2
+(* More standard stuff *)
+  | Tpat_variant(l1,op1, _), Tpat_variant(l2,op2,_) ->
+      l1=l2 && ocompat op1 op2
+  | Tpat_constant c1, Tpat_constant c2 ->
+      const_compare c1 c2 = 0
+  | Tpat_tuple ps, Tpat_tuple qs -> compats ps qs
+  | Tpat_lazy p, Tpat_lazy q -> compat p q
+  | Tpat_record (l1,_),Tpat_record (l2,_) ->
+      let ps,qs = records_args l1 l2 in
+      compats ps qs
+  | Tpat_array ps, Tpat_array qs ->
+      List.length ps = List.length qs &&
+      compats ps qs
+  | _,_  -> false
+
+  and ocompat op oq = match op,oq with
+  | None,None -> true
+  | Some p,Some q -> compat p q
+  | (None,Some _)|(Some _,None) -> false
+
+  and compats ps qs = match ps,qs with
+  | [], [] -> true
+  | p::ps, q::qs -> compat p q && compats ps qs
+  | _,_    -> false
+
+end
+
+module SyntacticCompat =
+  Compat
+    (struct
+      let equal c1 c2 =  Types.equal_tag c1.cstr_tag c2.cstr_tag
+    end)
+
+let compat =  SyntacticCompat.compat
+and compats = SyntacticCompat.compats
+
+(* Due to (potential) rebinding, two extension constructors
+   of the same arity type may equal *)
+
+exception Empty (* Empty pattern *)
+
+(****************************************)
+(* Utilities for retrieving type paths  *)
+(****************************************)
+
+(* May need a clean copy, cf. PR#4745 *)
+let clean_copy ty =
+  if ty.level = Btype.generic_level then ty
+  else Subst.type_expr Subst.identity ty
+
+let get_constructor_type_path ty tenv =
+  let ty = Ctype.repr (Ctype.expand_head tenv (clean_copy ty)) in
+  match ty.desc with
+  | Tconstr (path,_,_) -> path
+  | _ -> assert false
+
+(****************************)
+(* Utilities for matching   *)
+(****************************)
+
+(* Check top matching *)
+let simple_match d h =
+  let open Patterns.Head in
+  match d.pat_desc, h.pat_desc with
+  | Construct c1, Construct c2 ->
+      Types.equal_tag c1.cstr_tag c2.cstr_tag
+  | Variant { tag = t1; _ }, Variant { tag = t2 } ->
+      t1 = t2
+  | Constant c1, Constant c2 -> const_compare c1 c2 = 0
+  | Lazy, Lazy -> true
+  | Record _, Record _ -> true
+  | Tuple len1, Tuple len2
+  | Array len1, Array len2 -> len1 = len2
+  | _, Any -> true
+  | _, _ -> false
+
+
+
+(* extract record fields as a whole *)
+let record_arg ph =
+  let open Patterns.Head in
+  match ph.pat_desc with
+  | Any -> []
+  | Record args -> args
+  | _ -> fatal_error "Parmatch.as_record"
+
+
+let extract_fields lbls arg =
+  let get_field pos arg =
+    match List.find (fun (lbl,_) -> pos = lbl.lbl_pos) arg with
+    | _, p -> p
+    | exception Not_found -> omega
+  in
+  List.map (fun lbl -> get_field lbl.lbl_pos arg) lbls
+
+(* Build argument list when p2 >= p1, where p1 is a simple pattern *)
+let simple_match_args discr head args =
+  let open Patterns.Head in
+  match head.pat_desc with
+  | Constant _ -> []
+  | Construct _
+  | Variant _
+  | Tuple _
+  | Array _
+  | Lazy -> args
+  | Record lbls ->  extract_fields (record_arg discr) (List.combine lbls args)
+  | Any ->
+      begin match discr.pat_desc with
+      | Construct cstr -> Patterns.omegas cstr.cstr_arity
+      | Variant { has_arg = true }
+      | Lazy -> [Patterns.omega]
+      | Record lbls ->  omega_list lbls
+      | Array len
+      | Tuple len -> Patterns.omegas len
+      | Variant { has_arg = false }
+      | Any
+      | Constant _ -> []
+      end
+
+(* Consider a pattern matrix whose first column has been simplified to contain
+   only _ or a head constructor
+     | p1, r1...
+     | p2, r2...
+     | p3, r3...
+     | ...
+
+   We build a normalized /discriminating/ pattern from a pattern [q] by folding
+   over the first column of the matrix, "refining" [q] as we go:
+
+   - when we encounter a row starting with [Tuple] or [Lazy] then we
+   can stop and return that head, as we cannot refine any further. Indeed,
+   these constructors are alone in their signature, so they will subsume
+   whatever other head we might find, as well as the head we're threading
+   along.
+
+   - when we find a [Record] then it is a bit more involved: it is also alone
+   in its signature, however it might only be matching a subset of the
+   record fields. We use these fields to refine our accumulator and keep going
+   as another row might match on different fields.
+
+   - rows starting with a wildcard do not bring any information, so we ignore
+   them and keep going
+
+   - if we encounter anything else (i.e. any other constructor), then we just
+   stop and return our accumulator.
+*)
+let discr_pat q pss =
+  let open Patterns.Head in
+  let rec refine_pat acc = function
+    | [] -> acc
+    | ((head, _), _) :: rows ->
+      match head.pat_desc with
+      | Any -> refine_pat acc rows
+      | Tuple _ | Lazy -> head
+      | Record lbls ->
+        (* N.B. we could make this case "simpler" by refining the record case
+           using [all_record_args].
+           In which case we wouldn't need to fold over the first column for
+           records.
+           However it makes the witness we generate for the exhaustivity warning
+           less pretty. *)
+        let fields =
+          List.fold_right (fun lbl r ->
+            if List.exists (fun l -> l.lbl_pos = lbl.lbl_pos) r then
+              r
+            else
+              lbl :: r
+          ) lbls (record_arg acc)
+        in
+        let d = { head with pat_desc = Record fields } in
+        refine_pat d rows
+      | _ -> acc
+  in
+  let q, _ = deconstruct q in
+  match q.pat_desc with
+  (* short-circuiting: clearly if we have anything other than [Record] or
+     [Any] to start with, we're not going to be able refine at all. So
+     there's no point going over the matrix. *)
+  | Any | Record _ -> refine_pat q pss
+  | _ -> q
+
+(*
+   In case a matching value is found, set actual arguments
+   of the matching pattern.
+*)
+
+let rec read_args xs r = match xs,r with
+| [],_ -> [],r
+| _::xs, arg::rest ->
+   let args,rest = read_args xs rest in
+   arg::args,rest
+| _,_ ->
+    fatal_error "Parmatch.read_args"
+
+let do_set_args ~erase_mutable q r = match q with
+| {pat_desc = Tpat_tuple omegas} ->
+    let args,rest = read_args omegas r in
+    make_pat (Tpat_tuple args) q.pat_type q.pat_env::rest
+| {pat_desc = Tpat_record (omegas,closed)} ->
+    let args,rest = read_args omegas r in
+    make_pat
+      (Tpat_record
+         (List.map2 (fun (lid, lbl,_) arg ->
+           if
+             erase_mutable &&
+             (match lbl.lbl_mut with
+             | Mutable -> true | Immutable -> false)
+           then
+             lid, lbl, omega
+           else
+             lid, lbl, arg)
+            omegas args, closed))
+      q.pat_type q.pat_env::
+    rest
+| {pat_desc = Tpat_construct (lid, c, omegas, _)} ->
+    let args,rest = read_args omegas r in
+    make_pat
+      (Tpat_construct (lid, c, args, None))
+      q.pat_type q.pat_env::
+    rest
+| {pat_desc = Tpat_variant (l, omega, row)} ->
+    let arg, rest =
+      match omega, r with
+        Some _, a::r -> Some a, r
+      | None, r -> None, r
+      | _ -> assert false
+    in
+    make_pat
+      (Tpat_variant (l, arg, row)) q.pat_type q.pat_env::
+    rest
+| {pat_desc = Tpat_lazy _omega} ->
+    begin match r with
+      arg::rest ->
+        make_pat (Tpat_lazy arg) q.pat_type q.pat_env::rest
+    | _ -> fatal_error "Parmatch.do_set_args (lazy)"
+    end
+| {pat_desc = Tpat_array omegas} ->
+    let args,rest = read_args omegas r in
+    make_pat
+      (Tpat_array args) q.pat_type q.pat_env::
+    rest
+| {pat_desc=Tpat_constant _|Tpat_any} ->
+    q::r (* case any is used in matching.ml *)
+| _ -> fatal_error "Parmatch.set_args"
+
+let set_args q r = do_set_args ~erase_mutable:false q r
+and set_args_erase_mutable q r = do_set_args ~erase_mutable:true q r
+
+(* Given a matrix of non-empty rows
+   p1 :: r1...
+   p2 :: r2...
+   p3 :: r3...
+
+   Simplify the first column [p1 p2 p3] by splitting all or-patterns.
+   The result is a list of pairs
+     ((pattern head, arguments), rest of row)
+
+   For example,
+     x :: r1
+     (Some _) as y :: r2
+     (None as x) as y :: r3
+     (Some x | (None as x)) :: r4
+   becomes
+     ((   _ , [ ] ), r1)
+     (( Some, [_] ), r2)
+     (( None, [ ] ), r3)
+     (( Some, [x] ), r4)
+     (( None, [ ] ), r4)
+ *)
+let simplify_head_pat ~add_column p ps k =
+  let rec simplify_head_pat p ps k =
+    match Patterns.General.(view p |> strip_vars).pat_desc with
+    | `Or (p1,p2,_) -> simplify_head_pat p1 ps (simplify_head_pat p2 ps k)
+    | #Patterns.Simple.view as view ->
+       add_column (Patterns.Head.deconstruct { p with pat_desc = view }) ps k
+  in simplify_head_pat p ps k
+
+let rec simplify_first_col = function
+  | [] -> []
+  | [] :: _ -> assert false (* the rows are non-empty! *)
+  | (p::ps) :: rows ->
+      let add_column p ps k = (p, ps) :: k in
+      simplify_head_pat ~add_column p ps (simplify_first_col rows)
+
+
+(* Builds the specialized matrix of [pss] according to the discriminating
+   pattern head [d].
+   See section 3.1 of http://moscova.inria.fr/~maranget/papers/warn/warn.pdf
+
+   NOTES:
+   - we are polymorphic on the type of matrices we work on, in particular a row
+   might not simply be a [pattern list]. That's why we have the [extend_row]
+   parameter.
+*)
+let build_specialized_submatrix ~extend_row discr pss =
+  let rec filter_rec = function
+    | ((head, args), ps) :: pss ->
+        if simple_match discr head
+        then extend_row (simple_match_args discr head args) ps :: filter_rec pss
+        else filter_rec pss
+    | _ -> [] in
+  filter_rec pss
+
+(* The "default" and "specialized" matrices of a given matrix.
+   See section 3.1 of http://moscova.inria.fr/~maranget/papers/warn/warn.pdf .
+*)
+type 'matrix specialized_matrices = {
+  default : 'matrix;
+  constrs : (Patterns.Head.t * 'matrix) list;
+}
+
+(* Consider a pattern matrix whose first column has been simplified
+   to contain only _ or a head constructor
+     | p1, r1...
+     | p2, r2...
+     | p3, r3...
+     | ...
+
+   We split this matrix into a list of /specialized/ sub-matrices, one for
+   each head constructor appearing in the first column. For each row whose
+   first column starts with a head constructor, remove this head
+   column, prepend one column for each argument of the constructor,
+   and add the resulting row in the sub-matrix corresponding to this
+   head constructor.
+
+   Rows whose left column is omega (the Any pattern _) may match any
+   head constructor, so they are added to all sub-matrices.
+
+   In the case where all the rows in the matrix have an omega on their first
+   column, then there is only one /specialized/ sub-matrix, formed of all these
+   omega rows.
+   This matrix is also called the /default/ matrix.
+
+   See the documentation of [build_specialized_submatrix] for an explanation of
+   the [extend_row] parameter.
+*)
+let build_specialized_submatrices ~extend_row discr rows =
+  let extend_group discr p args r rs =
+    let r = extend_row (simple_match_args discr p args) r in
+    (discr, r :: rs)
+  in
+
+  (* insert a row of head [p] and rest [r] into the right group
+
+     Note: with this implementation, the order of the groups
+     is the order of their first row in the source order.
+     This is a nice property to get exhaustivity counter-examples
+     in source order.
+  *)
+  let rec insert_constr head args r = function
+    | [] ->
+      (* if no group matched this row, it has a head constructor that
+         was never seen before; add a new sub-matrix for this head *)
+      [extend_group head head args r []]
+    | (q0,rs) as bd::env ->
+      if simple_match q0 head
+      then extend_group q0 head args r rs :: env
+      else bd :: insert_constr head args r env
+  in
+
+  (* insert a row of head omega into all groups *)
+  let insert_omega r env =
+    List.map (fun (q0,rs) -> extend_group q0 Patterns.Head.omega [] r rs) env
+  in
+
+  let rec form_groups constr_groups omega_tails = function
+    | [] -> (constr_groups, omega_tails)
+    | ((head, args), tail) :: rest ->
+        match head.pat_desc with
+        | Patterns.Head.Any ->
+            (* note that calling insert_omega here would be wrong
+               as some groups may not have been formed yet, if the
+               first row with this head pattern comes after in the list *)
+            form_groups constr_groups (tail :: omega_tails) rest
+        | _ ->
+            form_groups
+              (insert_constr head args tail constr_groups) omega_tails rest
+  in
+
+  let constr_groups, omega_tails =
+    let initial_constr_group =
+      let open Patterns.Head in
+      match discr.pat_desc with
+      | Record _ | Tuple _ | Lazy ->
+        (* [discr] comes from [discr_pat], and in this case subsumes any of the
+           patterns we could find on the first column of [rows]. So it is better
+           to use it for our initial environment than any of the normalized
+           pattern we might obtain from the first column. *)
+        [discr,[]]
+      | _ -> []
+    in
+    form_groups initial_constr_group [] rows
+  in
+
+  (* groups are accumulated in reverse order;
+     we restore the order of rows in the source code *)
+  let default = List.rev omega_tails in
+  let constrs =
+    List.fold_right insert_omega omega_tails constr_groups
+    |> List.map (fun (discr, rs) -> (discr, List.rev rs))
+  in
+  { default; constrs; }
+
+(* Variant related functions *)
+
+let set_last a =
+  let rec loop = function
+    | [] -> assert false
+    | [_] -> [Patterns.General.erase a]
+    | x::l -> x :: loop l
+  in
+  function
+  | (_, []) -> (Patterns.Head.deconstruct a, [])
+  | (first, row) -> (first, loop row)
+
+(* mark constructor lines for failure when they are incomplete *)
+let mark_partial =
+  let zero = make_pat (`Constant (Const_int 0)) Ctype.none Env.empty in
+  List.map (fun ((hp, _), _ as ps) ->
+    match hp.pat_desc with
+    | Patterns.Head.Any -> ps
+    | _ -> set_last zero ps
+  )
+
+let close_variant env row =
+  let row = Btype.row_repr row in
+  let nm =
+    List.fold_left
+      (fun nm (_tag,f) ->
+        match Btype.row_field_repr f with
+        | Reither(_, _, false, e) ->
+            (* m=false means that this tag is not explicitly matched *)
+            Btype.set_row_field e Rabsent;
+            None
+        | Rabsent | Reither (_, _, true, _) | Rpresent _ -> nm)
+      row.row_name row.row_fields in
+  if not row.row_closed || nm != row.row_name then begin
+    (* this unification cannot fail *)
+    Ctype.unify env row.row_more
+      (Btype.newgenty
+         (Tvariant {row with row_fields = []; row_more = Btype.newgenvar();
+                    row_closed = true; row_name = nm}))
+  end
+
+(*
+  Check whether the first column of env makes up a complete signature or
+  not. We work on the discriminating pattern heads of each sub-matrix: they
+  are not omega/Any.
+*)
+let full_match closing env =  match env with
+| [] -> false
+| (discr, _) :: _ ->
+  let open Patterns.Head in
+  match discr.pat_desc with
+  | Any -> assert false
+  | Construct { cstr_tag = Cstr_extension _ ; _ } -> false
+  | Construct c -> List.length env = c.cstr_consts + c.cstr_nonconsts
+  | Variant { type_row; _ } ->
+      let fields =
+        List.map
+          (fun (d, _) ->
+            match d.pat_desc with
+            | Variant { tag } -> tag
+            | _ -> assert false)
+          env
+      in
+      let row = type_row () in
+      if closing && not (Btype.row_fixed row) then
+        (* closing=true, we are considering the variant as closed *)
+        List.for_all
+          (fun (tag,f) ->
+            match Btype.row_field_repr f with
+              Rabsent | Reither(_, _, false, _) -> true
+            | Reither (_, _, true, _)
+                (* m=true, do not discard matched tags, rather warn *)
+            | Rpresent _ -> List.mem tag fields)
+          row.row_fields
+      else
+        row.row_closed &&
+        List.for_all
+          (fun (tag,f) ->
+            Btype.row_field_repr f = Rabsent || List.mem tag fields)
+          row.row_fields
+  | Constant Const_char _ ->
+      List.length env = 256
+  | Constant _
+  | Array _ -> false
+  | Tuple _
+  | Record _
+  | Lazy -> true
+
+(* Written as a non-fragile matching, PR#7451 originated from a fragile matching
+   below. *)
+let should_extend ext env = match ext with
+| None -> false
+| Some ext -> begin match env with
+  | [] -> assert false
+  | (p,_)::_ ->
+      let open Patterns.Head in
+      begin match p.pat_desc with
+      | Construct {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)} ->
+          let path = get_constructor_type_path p.pat_type p.pat_env in
+          Path.same path ext
+      | Construct {cstr_tag=(Cstr_extension _)} -> false
+      | Constant _ | Tuple _ | Variant _ | Record _ | Array _ | Lazy -> false
+      | Any -> assert false
+      end
+end
+
+(* build a pattern from a constructor description *)
+let pat_of_constr ex_pat cstr =
+  {ex_pat with pat_desc =
+   Tpat_construct (mknoloc (Longident.Lident cstr.cstr_name),
+                   cstr, omegas cstr.cstr_arity, None)}
+
+let orify x y = make_pat (Tpat_or (x, y, None)) x.pat_type x.pat_env
+
+let rec orify_many = function
+| [] -> assert false
+| [x] -> x
+| x :: xs -> orify x (orify_many xs)
+
+(* build an or-pattern from a constructor list *)
+let pat_of_constrs ex_pat cstrs =
+  let ex_pat = Patterns.Head.to_omega_pattern ex_pat in
+  if cstrs = [] then raise Empty else
+  orify_many (List.map (pat_of_constr ex_pat) cstrs)
+
+let pats_of_type ?(always=false) env ty =
+  let ty' = Ctype.expand_head env ty in
+  match ty'.desc with
+  | Tconstr (path, _, _) ->
+      begin match Env.find_type_descrs path env with
+      | exception Not_found -> [omega]
+      | Type_variant (cstrs,_) when always || List.length cstrs <= 1 ||
+        (* Only explode when all constructors are GADTs *)
+        List.for_all (fun cd -> cd.cstr_generalized) cstrs ->
+          List.map (pat_of_constr (make_pat Tpat_any ty env)) cstrs
+      | Type_record (labels, _) ->
+          let fields =
+            List.map (fun ld ->
+              mknoloc (Longident.Lident ld.lbl_name), ld, omega)
+              labels
+          in
+          [make_pat (Tpat_record (fields, Closed)) ty env]
+      | Type_variant _ | Type_abstract | Type_open -> [omega]
+      end
+  | Ttuple tl ->
+      [make_pat (Tpat_tuple (omegas (List.length tl))) ty env]
+  | _ -> [omega]
+
+let rec get_variant_constructors env ty =
+  match (Ctype.repr ty).desc with
+  | Tconstr (path,_,_) -> begin
+      try match Env.find_type path env, Env.find_type_descrs path env with
+      | _, Type_variant (cstrs,_) -> cstrs
+      | {type_manifest = Some _}, _ ->
+          get_variant_constructors env
+            (Ctype.expand_head_once env (clean_copy ty))
+      | _ -> fatal_error "Parmatch.get_variant_constructors"
+      with Not_found ->
+        fatal_error "Parmatch.get_variant_constructors"
+    end
+  | _ -> fatal_error "Parmatch.get_variant_constructors"
+
+module ConstructorSet = Set.Make(struct
+  type t = constructor_description
+  let compare c1 c2 = String.compare c1.cstr_name c2.cstr_name
+end)
+
+(* Sends back a pattern that complements the given constructors used_constrs *)
+let complete_constrs constr used_constrs =
+  let c = constr.pat_desc in
+  let constrs = get_variant_constructors constr.pat_env c.cstr_res in
+  let used_constrs = ConstructorSet.of_list used_constrs in
+  let others =
+    List.filter
+      (fun cnstr -> not (ConstructorSet.mem cnstr used_constrs))
+      constrs in
+  (* Split constructors to put constant ones first *)
+  let const, nonconst =
+    List.partition (fun cnstr -> cnstr.cstr_arity = 0) others in
+  const @ nonconst
+
+let build_other_constrs env p =
+  let open Patterns.Head in
+  match p.pat_desc with
+  | Construct ({ cstr_tag = Cstr_extension _ }) -> extra_pat
+  | Construct
+      ({ cstr_tag = Cstr_constant _ | Cstr_block _ | Cstr_unboxed } as c) ->
+        let constr = { p with pat_desc = c } in
+        let get_constr q =
+          match q.pat_desc with
+          | Construct c -> c
+          | _ -> fatal_error "Parmatch.get_constr" in
+        let used_constrs =  List.map (fun (p,_) -> get_constr p) env in
+        pat_of_constrs p (complete_constrs constr used_constrs)
+  | _ -> extra_pat
+
+(* Auxiliary for build_other *)
+
+let build_other_constant proj make first next p env =
+  let all = List.map (fun (p, _) -> proj p.pat_desc) env in
+  let rec try_const i =
+    if List.mem i all
+    then try_const (next i)
+    else make_pat (make i) p.pat_type p.pat_env
+  in try_const first
+
+(*
+  Builds a pattern that is incompatible with all patterns in
+  the first column of env
+*)
+
+let some_private_tag = "<some private tag>"
+
+let build_other ext env =
+  match env with
+  | [] -> omega
+  | (d, _) :: _ ->
+      let open Patterns.Head in
+      match d.pat_desc with
+      | Construct { cstr_tag = Cstr_extension _ } ->
+          (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *)
+          make_pat
+            (Tpat_var (Ident.create_local "*extension*",
+                       {txt="*extension*"; loc = d.pat_loc}))
+            Ctype.none Env.empty
+      | Construct _ ->
+          begin match ext with
+          | Some ext ->
+              if Path.same ext (get_constructor_type_path d.pat_type d.pat_env)
+              then
+                extra_pat
+              else
+                build_other_constrs env d
+          | _ ->
+              build_other_constrs env d
+          end
+      | Variant { cstr_row; type_row } ->
+          let tags =
+            List.map
+              (fun (d, _) ->
+                match d.pat_desc with
+                | Variant { tag } -> tag
+                | _ -> assert false)
+              env
+            in
+            let make_other_pat tag const =
+              let arg = if const then None else Some Patterns.omega in
+              make_pat (Tpat_variant(tag, arg, cstr_row)) d.pat_type d.pat_env
+            in
+            let row = type_row () in
+            begin match
+              List.fold_left
+                (fun others (tag,f) ->
+                  if List.mem tag tags then others else
+                  match Btype.row_field_repr f with
+                    Rabsent (* | Reither _ *) -> others
+                  (* This one is called after erasing pattern info *)
+                  | Reither (c, _, _, _) -> make_other_pat tag c :: others
+                  | Rpresent arg -> make_other_pat tag (arg = None) :: others)
+                [] row.row_fields
+            with
+              [] ->
+                let tag =
+                  if Btype.row_fixed row then some_private_tag else
+                  let rec mktag tag =
+                    if List.mem tag tags then mktag (tag ^ "'") else tag in
+                  mktag "AnyOtherTag"
+                in make_other_pat tag true
+            | pat::other_pats ->
+                List.fold_left
+                  (fun p_res pat ->
+                    make_pat (Tpat_or (pat, p_res, None)) d.pat_type d.pat_env)
+                  pat other_pats
+            end
+      | Constant Const_char _ ->
+          let all_chars =
+            List.map
+              (fun (p,_) -> match p.pat_desc with
+              | Constant (Const_char c) -> c
+              | _ -> assert false)
+              env
+          in
+          let rec find_other i imax =
+            if i > imax then raise Not_found
+            else
+              let ci = Char.chr i in
+              if List.mem ci all_chars then
+                find_other (i+1) imax
+              else
+                make_pat (Tpat_constant (Const_char ci)) d.pat_type d.pat_env
+          in
+          let rec try_chars = function
+            | [] -> Patterns.omega
+            | (c1,c2) :: rest ->
+                try
+                  find_other (Char.code c1) (Char.code c2)
+                with
+                | Not_found -> try_chars rest
+          in
+          try_chars
+            [ 'a', 'z' ; 'A', 'Z' ; '0', '9' ;
+              ' ', '~' ; Char.chr 0 , Char.chr 255]
+      | Constant Const_int _ ->
+          build_other_constant
+            (function Constant(Const_int i) -> i | _ -> assert false)
+            (function i -> Tpat_constant(Const_int i))
+            0 succ d env
+      | Constant Const_int32 _ ->
+          build_other_constant
+            (function Constant(Const_int32 i) -> i | _ -> assert false)
+            (function i -> Tpat_constant(Const_int32 i))
+            0l Int32.succ d env
+      | Constant Const_int64 _ ->
+          build_other_constant
+            (function Constant(Const_int64 i) -> i | _ -> assert false)
+            (function i -> Tpat_constant(Const_int64 i))
+            0L Int64.succ d env
+      | Constant Const_nativeint _ ->
+          build_other_constant
+            (function Constant(Const_nativeint i) -> i | _ -> assert false)
+            (function i -> Tpat_constant(Const_nativeint i))
+            0n Nativeint.succ d env
+      | Constant Const_string _ ->
+          build_other_constant
+            (function Constant(Const_string (s, _, _)) -> String.length s
+                    | _ -> assert false)
+            (function i ->
+               Tpat_constant
+                 (Const_string(String.make i '*',Location.none,None)))
+            0 succ d env
+      | Constant Const_float _ ->
+          build_other_constant
+            (function Constant(Const_float f) -> float_of_string f
+                    | _ -> assert false)
+            (function f -> Tpat_constant(Const_float (string_of_float f)))
+            0.0 (fun f -> f +. 1.0) d env
+      | Array _ ->
+          let all_lengths =
+            List.map
+              (fun (p,_) -> match p.pat_desc with
+              | Array len -> len
+              | _ -> assert false)
+              env in
+          let rec try_arrays l =
+            if List.mem l all_lengths then try_arrays (l+1)
+            else
+              make_pat (Tpat_array (omegas l)) d.pat_type d.pat_env in
+          try_arrays 0
+      | _ -> Patterns.omega
+
+let rec has_instance p = match p.pat_desc with
+  | Tpat_variant (l,_,r) when is_absent l r -> false
+  | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true
+  | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) -> has_instance p
+  | Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2
+  | Tpat_construct (_,_,ps,_) | Tpat_tuple ps | Tpat_array ps ->
+      has_instances ps
+  | Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,x) -> x) lps)
+  | Tpat_lazy p
+    -> has_instance p
+
+and has_instances = function
+  | [] -> true
+  | q::rem -> has_instance q && has_instances rem
+
+(*
+  Core function :
+  Is the last row of pattern matrix pss + qs satisfiable ?
+  That is :
+    Does there exists at least one value vector, es such that :
+     1- for all ps in pss ps # es (ps and es are not compatible)
+     2- qs <= es                  (es matches qs)
+
+   ---
+
+   In two places in the following function, we check the coherence of the first
+   column of (pss + qs).
+   If it is incoherent, then we exit early saying that (pss + qs) is not
+   satisfiable (which is equivalent to saying "oh, we shouldn't have considered
+   that branch, no good result came come from here").
+
+   But what happens if we have a coherent but ill-typed column?
+   - we might end up returning [false], which is equivalent to noticing the
+   incompatibility: clearly this is fine.
+   - if we end up returning [true] then we're saying that [qs] is useful while
+   it is not. This is sad but not the end of the world, we're just allowing dead
+   code to survive.
+*)
+let rec satisfiable pss qs = match pss with
+| [] -> has_instances qs
+| _  ->
+    match qs with
+    | [] -> false
+    | q::qs ->
+       match Patterns.General.(view q |> strip_vars).pat_desc with
+       | `Or(q1,q2,_) ->
+          satisfiable pss (q1::qs) || satisfiable pss (q2::qs)
+       | `Any ->
+          let pss = simplify_first_col pss in
+          if not (all_coherent (first_column pss)) then
+            false
+          else begin
+            let { default; constrs } =
+              let q0 = discr_pat Patterns.Simple.omega pss in
+              build_specialized_submatrices ~extend_row:(@) q0 pss in
+            if not (full_match false constrs) then
+              satisfiable default qs
+            else
+              List.exists
+                (fun (p,pss) ->
+                   not (is_absent_pat p) &&
+                   satisfiable pss
+                     (simple_match_args p Patterns.Head.omega [] @ qs))
+                constrs
+          end
+       | `Variant (l,_,r) when is_absent l r -> false
+       | #Patterns.Simple.view as view ->
+          let q = { q with pat_desc = view } in
+          let pss = simplify_first_col pss in
+          let hq, qargs = Patterns.Head.deconstruct q in
+          if not (all_coherent (hq :: first_column pss)) then
+            false
+          else begin
+              let q0 = discr_pat q pss in
+              satisfiable (build_specialized_submatrix ~extend_row:(@) q0 pss)
+                (simple_match_args q0 hq qargs @ qs)
+            end
+
+(* While [satisfiable] only checks whether the last row of [pss + qs] is
+   satisfiable, this function returns the (possibly empty) list of vectors [es]
+   which verify:
+     1- for all ps in pss, ps # es (ps and es are not compatible)
+     2- qs <= es                   (es matches qs)
+
+   This is done to enable GADT handling
+
+   For considerations regarding the coherence check, see the comment on
+   [satisfiable] above.  *)
+let rec list_satisfying_vectors pss qs =
+  match pss with
+  | [] -> if has_instances qs then [qs] else []
+  | _  ->
+      match qs with
+      | [] -> []
+      | q :: qs ->
+         match Patterns.General.(view q |> strip_vars).pat_desc with
+         | `Or(q1,q2,_) ->
+            list_satisfying_vectors pss (q1::qs) @
+            list_satisfying_vectors pss (q2::qs)
+         | `Any ->
+            let pss = simplify_first_col pss in
+            if not (all_coherent (first_column pss)) then
+              []
+            else begin
+              let q0 = discr_pat Patterns.Simple.omega pss in
+              let wild default_matrix p =
+                List.map (fun qs -> p::qs)
+                  (list_satisfying_vectors default_matrix qs)
+              in
+              match build_specialized_submatrices ~extend_row:(@) q0 pss with
+              | { default; constrs = [] } ->
+                  (* first column of pss is made of variables only *)
+                  wild default omega
+              | { default; constrs = ((p,_)::_ as constrs) } ->
+                  let for_constrs () =
+                    List.flatten (
+                      List.map (fun (p,pss) ->
+                        if is_absent_pat p then
+                          []
+                        else
+                          let witnesses =
+                            list_satisfying_vectors pss
+                              (simple_match_args p Patterns.Head.omega [] @ qs)
+                          in
+                          let p = Patterns.Head.to_omega_pattern p in
+                          List.map (set_args p) witnesses
+                      ) constrs
+                    )
+                  in
+                  if full_match false constrs then for_constrs () else
+                  begin match p.pat_desc with
+                  | Construct _ ->
+                      (* activate this code
+                         for checking non-gadt constructors *)
+                      wild default (build_other_constrs constrs p)
+                      @ for_constrs ()
+                  | _ ->
+                      wild default Patterns.omega
+                  end
+          end
+      | `Variant (l, _, r) when is_absent l r -> []
+      | #Patterns.Simple.view as view ->
+          let q = { q with pat_desc = view } in
+          let hq, qargs = Patterns.Head.deconstruct q in
+          let pss = simplify_first_col pss in
+          if not (all_coherent (hq :: first_column pss)) then
+            []
+          else begin
+            let q0 = discr_pat q pss in
+            List.map (set_args (Patterns.Head.to_omega_pattern q0))
+              (list_satisfying_vectors
+                 (build_specialized_submatrix ~extend_row:(@) q0 pss)
+                 (simple_match_args q0 hq qargs @ qs))
+          end
+
+(******************************************)
+(* Look for a row that matches some value *)
+(******************************************)
+
+(*
+  Useful for seeing if the example of
+  non-matched value can indeed be matched
+  (by a guarded clause)
+*)
+
+let rec do_match pss qs = match qs with
+| [] ->
+    begin match pss  with
+    | []::_ -> true
+    | _ -> false
+    end
+| q::qs -> match Patterns.General.(view q |> strip_vars).pat_desc with
+  | `Or (q1,q2,_) ->
+      do_match pss (q1::qs) || do_match pss (q2::qs)
+  | `Any ->
+      let rec remove_first_column = function
+        | (_::ps)::rem -> ps::remove_first_column rem
+        | _ -> []
+      in
+      do_match (remove_first_column pss) qs
+  | #Patterns.Simple.view as view ->
+      let q = { q with pat_desc = view } in
+      let q0, qargs = Patterns.Head.deconstruct q in
+      let pss = simplify_first_col pss in
+      (* [pss] will (or won't) match [q0 :: qs] regardless of the coherence of
+         its first column. *)
+      do_match
+        (build_specialized_submatrix ~extend_row:(@) q0 pss)
+        (qargs @ qs)
+
+(*
+let print_pat pat =
+  let rec string_of_pat pat =
+    match pat.pat_desc with
+        Tpat_var _ -> "v"
+      | Tpat_any -> "_"
+      | Tpat_alias (p, x) -> Printf.sprintf "(%s) as ?"  (string_of_pat p)
+      | Tpat_constant n -> "0"
+      | Tpat_construct (_, lid, _) ->
+        Printf.sprintf "%s" (String.concat "." (Longident.flatten lid.txt))
+      | Tpat_lazy p ->
+        Printf.sprintf "(lazy %s)" (string_of_pat p)
+      | Tpat_or (p1,p2,_) ->
+        Printf.sprintf "(%s | %s)" (string_of_pat p1) (string_of_pat p2)
+      | Tpat_tuple list ->
+        Printf.sprintf "(%s)" (String.concat "," (List.map string_of_pat list))
+      | Tpat_variant (_, _, _) -> "variant"
+      | Tpat_record (_, _) -> "record"
+      | Tpat_array _ -> "array"
+  in
+  Printf.fprintf stderr "PAT[%s]\n%!" (string_of_pat pat)
+*)
+
+(*
+  Now another satisfiable function that additionally
+  supplies an example of a matching value.
+
+  This function should be called for exhaustiveness check only.
+*)
+let rec exhaust (ext:Path.t option) pss n = match pss with
+| []    ->  Seq.return (omegas n)
+| []::_ ->  Seq.empty
+| [(p :: ps)] -> exhaust_single_row ext p ps n
+| pss   -> specialize_and_exhaust ext pss n
+
+and exhaust_single_row ext p ps n =
+  (* Shortcut: in the single-row case p :: ps we know that all
+     counter-examples are either of the form
+       counter-example(p) :: omegas
+     or
+       p :: counter-examples(ps)
+
+     This is very interesting in the case where p contains
+     or-patterns, as the non-shortcut path below would do a separate
+     search for each constructor of the or-pattern, which can lead to
+     an exponential blowup on examples such as
+
+       | (A|B), (A|B), (A|B), (A|B) -> foo
+
+     Note that this shortcut also applies to examples such as
+
+       | A, A, A, A -> foo | (A|B), (A|B), (A|B), (A|B) -> bar
+
+     thanks to the [get_mins] preprocessing step which will drop the
+     first row (subsumed by the second). Code with this shape does
+     occur naturally when people want to avoid fragile pattern
+     matches: if A and B are the only two constructors, this is the
+     best way to make a non-fragile distinction between "all As" and
+     "at least one B".
+  *)
+  List.to_seq [Some p; None] |> Seq.flat_map
+    (function
+      | Some p ->
+          let sub_witnesses = exhaust ext [ps] (n - 1) in
+          Seq.map (fun row -> p :: row) sub_witnesses
+      | None ->
+          (* note: calling [exhaust] recursively of p would
+             result in an infinite loop in the case n=1 *)
+          let p_witnesses = specialize_and_exhaust ext [[p]] 1 in
+          Seq.map (fun p_row -> p_row @ omegas (n - 1)) p_witnesses
+    )
+
+and specialize_and_exhaust ext pss n =
+  let pss = simplify_first_col pss in
+  if not (all_coherent (first_column pss)) then
+    (* We're considering an ill-typed branch, we won't actually be able to
+       produce a well typed value taking that branch. *)
+    Seq.empty
+  else begin
+    (* Assuming the first column is ill-typed but considered coherent, we
+       might end up producing an ill-typed witness of non-exhaustivity
+       corresponding to the current branch.
+
+       If [exhaust] has been called by [do_check_partial], then the witnesses
+       produced get typechecked and the ill-typed ones are discarded.
+
+       If [exhaust] has been called by [do_check_fragile], then it is possible
+       we might fail to warn the user that the matching is fragile. See for
+       example testsuite/tests/warnings/w04_failure.ml. *)
+    let q0 = discr_pat Patterns.Simple.omega pss in
+    match build_specialized_submatrices ~extend_row:(@) q0 pss with
+    | { default; constrs = [] } ->
+        (* first column of pss is made of variables only *)
+        let sub_witnesses = exhaust ext default (n-1) in
+        let q0 = Patterns.Head.to_omega_pattern q0 in
+        Seq.map (fun row -> q0::row) sub_witnesses
+    | { default; constrs } ->
+        let try_non_omega (p,pss) =
+          if is_absent_pat p then
+            Seq.empty
+          else
+            let sub_witnesses =
+              exhaust
+                ext pss
+                (List.length (simple_match_args p Patterns.Head.omega [])
+                 + n - 1)
+            in
+            let p = Patterns.Head.to_omega_pattern p in
+            Seq.map (set_args p) sub_witnesses
+        in
+        let try_omega () =
+          if full_match false constrs && not (should_extend ext constrs) then
+            Seq.empty
+          else
+            let sub_witnesses = exhaust ext default (n-1) in
+            match build_other ext constrs with
+            | exception Empty ->
+                (* cannot occur, since constructors don't make
+                   a full signature *)
+                fatal_error "Parmatch.exhaust"
+            | p ->
+                Seq.map (fun tail -> p :: tail) sub_witnesses
+        in
+        (* Lazily compute witnesses for all constructor submatrices
+           (Some constr_mat) then the wildcard/default submatrix (None).
+           Note that the call to [try_omega ()] is delayed to after
+           all constructor matrices have been traversed. *)
+        List.map (fun constr_mat -> Some constr_mat) constrs @ [None]
+        |> List.to_seq
+        |> Seq.flat_map
+          (function
+            | Some constr_mat -> try_non_omega constr_mat
+            | None -> try_omega ())
+  end
+
+let exhaust ext pss n =
+  exhaust ext pss n
+  |> Seq.map (function
+     | [x] -> x
+     | _ -> assert false)
+
+(*
+   Another exhaustiveness check, enforcing variant typing.
+   Note that it does not check exact exhaustiveness, but whether a
+   matching could be made exhaustive by closing all variant types.
+   When this is true of all other columns, the current column is left
+   open (even if it means that the whole matching is not exhaustive as
+   a result).
+   When this is false for the matrix minus the current column, and the
+   current column is composed of variant tags, we close the variant
+   (even if it doesn't help in making the matching exhaustive).
+*)
+
+let rec pressure_variants tdefs = function
+  | []    -> false
+  | []::_ -> true
+  | pss   ->
+      let pss = simplify_first_col pss in
+      if not (all_coherent (first_column pss)) then
+        true
+      else begin
+        let q0 = discr_pat Patterns.Simple.omega pss in
+        match build_specialized_submatrices ~extend_row:(@) q0 pss with
+        | { default; constrs = [] } -> pressure_variants tdefs default
+        | { default; constrs } ->
+            let rec try_non_omega = function
+              | (_p,pss) :: rem ->
+                  let ok = pressure_variants tdefs pss in
+                  (* The order below matters : we want [pressure_variants] to be
+                    called on all the specialized submatrices because we might
+                    close some variant in any of them regardless of whether [ok]
+                    is true for [pss] or not *)
+                  try_non_omega rem && ok
+              | [] -> true
+            in
+            if full_match (tdefs=None) constrs then
+              try_non_omega constrs
+            else if tdefs = None then
+              pressure_variants None default
+            else
+              let full = full_match true constrs in
+              let ok =
+                if full then
+                  try_non_omega constrs
+                else begin
+                  let { constrs = partial_constrs; _ } =
+                    build_specialized_submatrices ~extend_row:(@) q0
+                      (mark_partial pss)
+                  in
+                  try_non_omega partial_constrs
+                end
+              in
+              begin match constrs, tdefs with
+              | [], _
+              | _, None -> ()
+              | (d, _) :: _, Some env ->
+                match d.pat_desc with
+                | Variant { type_row; _ } ->
+                  let row = type_row () in
+                  if Btype.row_fixed row
+                  || pressure_variants None default then ()
+                  else close_variant env row
+                | _ -> ()
+              end;
+              ok
+      end
+
+
+(* Yet another satisfiable function *)
+
+(*
+   This time every_satisfiable pss qs checks the
+   utility of every expansion of qs.
+   Expansion means expansion of or-patterns inside qs
+*)
+
+type answer =
+  | Used                                (* Useful pattern *)
+  | Unused                              (* Useless pattern *)
+  | Upartial of Typedtree.pattern list  (* Mixed, with list of useless ones *)
+
+
+
+(* this row type enable column processing inside the matrix
+    - left  ->  elements not to be processed,
+    - right ->  elements to be processed
+*)
+type usefulness_row =
+  {no_ors : pattern list ; ors : pattern list ; active : pattern list}
+
+(*
+let pretty_row {ors=ors ; no_ors=no_ors; active=active} =
+  pretty_line ors ; prerr_string " *" ;
+  pretty_line no_ors ; prerr_string " *" ;
+  pretty_line active
+
+let pretty_rows rs =
+  prerr_endline "begin matrix" ;
+  List.iter
+    (fun r ->
+      pretty_row r ;
+      prerr_endline "")
+    rs ;
+  prerr_endline "end matrix"
+*)
+
+(* Initial build *)
+let make_row ps = {ors=[] ; no_ors=[]; active=ps}
+
+let make_rows pss = List.map make_row pss
+
+
+(* Useful to detect and expand or pats inside as pats *)
+let is_var p = match Patterns.General.(view p |> strip_vars).pat_desc with
+| `Any -> true
+| _    -> false
+
+let is_var_column rs =
+  List.for_all
+    (fun r -> match r.active with
+    | p::_ -> is_var p
+    | []   -> assert false)
+    rs
+
+(* Standard or-args for left-to-right matching *)
+let rec or_args p = match p.pat_desc with
+| Tpat_or (p1,p2,_) -> p1,p2
+| Tpat_alias (p,_,_)  -> or_args p
+| _                 -> assert false
+
+(* Just remove current column *)
+let remove r = match r.active with
+| _::rem -> {r with active=rem}
+| []     -> assert false
+
+let remove_column rs = List.map remove rs
+
+(* Current column has been processed *)
+let push_no_or r = match r.active with
+| p::rem -> { r with no_ors = p::r.no_ors ; active=rem}
+| [] -> assert false
+
+let push_or r = match r.active with
+| p::rem -> { r with ors = p::r.ors ; active=rem}
+| [] -> assert false
+
+let push_or_column rs = List.map push_or rs
+and push_no_or_column rs = List.map push_no_or rs
+
+let rec simplify_first_usefulness_col = function
+  | [] -> []
+  | row :: rows ->
+    match row.active with
+    | [] -> assert false (* the rows are non-empty! *)
+    | p :: ps ->
+      let add_column p ps k =
+        (p, { row with active = ps }) :: k in
+      simplify_head_pat ~add_column p ps
+        (simplify_first_usefulness_col rows)
+
+(* Back to normal matrices *)
+let make_vector r = List.rev r.no_ors
+
+let make_matrix rs = List.map make_vector rs
+
+
+(* Standard union on answers *)
+let union_res r1 r2 = match r1, r2 with
+| (Unused,_)
+| (_, Unused) -> Unused
+| Used,_    -> r2
+| _, Used   -> r1
+| Upartial u1, Upartial u2 -> Upartial (u1@u2)
+
+(* propose or pats for expansion *)
+let extract_elements qs =
+  let rec do_rec seen = function
+    | [] -> []
+    | q::rem ->
+        {no_ors= List.rev_append seen rem @ qs.no_ors ;
+        ors=[] ;
+        active = [q]}::
+        do_rec (q::seen) rem in
+  do_rec [] qs.ors
+
+(* idem for matrices *)
+let transpose rs = match rs with
+| [] -> assert false
+| r::rem ->
+    let i = List.map (fun x -> [x]) r in
+    List.fold_left
+      (List.map2 (fun r x -> x::r))
+      i rem
+
+let extract_columns pss qs = match pss with
+| [] -> List.map (fun _ -> []) qs.ors
+| _  ->
+  let rows = List.map extract_elements pss in
+  transpose rows
+
+(* Core function
+   The idea is to first look for or patterns (recursive case), then
+   check or-patterns argument usefulness (terminal case)
+*)
+
+let rec every_satisfiables pss qs = match qs.active with
+| []     ->
+    (* qs is now partitionned,  check usefulness *)
+    begin match qs.ors with
+    | [] -> (* no or-patterns *)
+        if satisfiable (make_matrix pss) (make_vector qs) then
+          Used
+        else
+          Unused
+    | _  -> (* n or-patterns -> 2n expansions *)
+        List.fold_right2
+          (fun pss qs r -> match r with
+          | Unused -> Unused
+          | _ ->
+              match qs.active with
+              | [q] ->
+                  let q1,q2 = or_args q in
+                  let r_loc = every_both pss qs q1 q2 in
+                  union_res r r_loc
+              | _   -> assert false)
+          (extract_columns pss qs) (extract_elements qs)
+          Used
+    end
+| q::rem ->
+    begin match Patterns.General.(view q |> strip_vars).pat_desc with
+    | `Any ->
+        if is_var_column pss then
+          (* forget about ``all-variable''  columns now *)
+          every_satisfiables (remove_column pss) (remove qs)
+        else
+          (* otherwise this is direct food for satisfiable *)
+          every_satisfiables (push_no_or_column pss) (push_no_or qs)
+    | `Or (q1,q2,_) ->
+        if
+          q1.pat_loc.Location.loc_ghost &&
+          q2.pat_loc.Location.loc_ghost
+        then
+          (* syntactically generated or-pats should not be expanded *)
+          every_satisfiables (push_no_or_column pss) (push_no_or qs)
+        else
+          (* this is a real or-pattern *)
+          every_satisfiables (push_or_column pss) (push_or qs)
+    | `Variant (l,_,r) when is_absent l r -> (* Ah Jacques... *)
+        Unused
+    | #Patterns.Simple.view as view ->
+        let q = { q with pat_desc = view } in
+        (* standard case, filter matrix *)
+        let pss = simplify_first_usefulness_col pss in
+        let hq, args = Patterns.Head.deconstruct q in
+        (* The handling of incoherent matrices is kept in line with
+           [satisfiable] *)
+        if not (all_coherent (hq :: first_column pss)) then
+          Unused
+        else begin
+          let q0 = discr_pat q pss in
+          every_satisfiables
+            (build_specialized_submatrix q0 pss
+              ~extend_row:(fun ps r -> { r with active = ps @ r.active }))
+            {qs with active=simple_match_args q0 hq args @ rem}
+        end
+    end
+
+(*
+  This function ``every_both'' performs the usefulness check
+  of or-pat q1|q2.
+  The trick is to call every_satisfied twice with
+  current active columns restricted to q1 and q2,
+  That way,
+  - others orpats in qs.ors will not get expanded.
+  - all matching work performed on qs.no_ors is not performed again.
+  *)
+and every_both pss qs q1 q2 =
+  let qs1 = {qs with active=[q1]}
+  and qs2 =  {qs with active=[q2]} in
+  let r1 = every_satisfiables pss qs1
+  and r2 =  every_satisfiables (if compat q1 q2 then qs1::pss else pss) qs2 in
+  match r1 with
+  | Unused ->
+      begin match r2 with
+      | Unused -> Unused
+      | Used   -> Upartial [q1]
+      | Upartial u2 -> Upartial (q1::u2)
+      end
+  | Used ->
+      begin match r2 with
+      | Unused -> Upartial [q2]
+      | _      -> r2
+      end
+  | Upartial u1 ->
+      begin match r2 with
+      | Unused -> Upartial (u1@[q2])
+      | Used   -> r1
+      | Upartial u2 -> Upartial (u1 @ u2)
+      end
+
+
+
+
+(* le_pat p q  means, forall V,  V matches q implies V matches p *)
+let rec le_pat p q =
+  match (p.pat_desc, q.pat_desc) with
+  | (Tpat_var _|Tpat_any),_ -> true
+  | Tpat_alias(p,_,_), _ -> le_pat p q
+  | _, Tpat_alias(q,_,_) -> le_pat p q
+  | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0
+  | Tpat_construct(_,c1,ps,_), Tpat_construct(_,c2,qs,_) ->
+      Types.equal_tag c1.cstr_tag c2.cstr_tag && le_pats ps qs
+  | Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) ->
+      (l1 = l2 && le_pat p1 p2)
+  | Tpat_variant(l1,None,_r1), Tpat_variant(l2,None,_) ->
+      l1 = l2
+  | Tpat_variant(_,_,_), Tpat_variant(_,_,_) -> false
+  | Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs
+  | Tpat_lazy p, Tpat_lazy q -> le_pat p q
+  | Tpat_record (l1,_), Tpat_record (l2,_) ->
+      let ps,qs = records_args l1 l2 in
+      le_pats ps qs
+  | Tpat_array(ps), Tpat_array(qs) ->
+      List.length ps = List.length qs && le_pats ps qs
+(* In all other cases, enumeration is performed *)
+  | _,_  -> not (satisfiable [[p]] [q])
+
+and le_pats ps qs =
+  match ps,qs with
+    p::ps, q::qs -> le_pat p q && le_pats ps qs
+  | _, _         -> true
+
+let get_mins le ps =
+  let rec select_rec r = function
+      [] -> r
+    | p::ps ->
+        if List.exists (fun p0 -> le p0 p) ps
+        then select_rec r ps
+        else select_rec (p::r) ps in
+  select_rec [] (select_rec [] ps)
+
+(*
+  lub p q is a pattern that matches all values matched by p and q
+  may raise Empty, when p and q are not compatible
+*)
+
+let rec lub p q = match p.pat_desc,q.pat_desc with
+| Tpat_alias (p,_,_),_      -> lub p q
+| _,Tpat_alias (q,_,_)      -> lub p q
+| (Tpat_any|Tpat_var _),_ -> q
+| _,(Tpat_any|Tpat_var _) -> p
+| Tpat_or (p1,p2,_),_     -> orlub p1 p2 q
+| _,Tpat_or (q1,q2,_)     -> orlub q1 q2 p (* Thanks god, lub is commutative *)
+| Tpat_constant c1, Tpat_constant c2 when const_compare c1 c2 = 0 -> p
+| Tpat_tuple ps, Tpat_tuple qs ->
+    let rs = lubs ps qs in
+    make_pat (Tpat_tuple rs) p.pat_type p.pat_env
+| Tpat_lazy p, Tpat_lazy q ->
+    let r = lub p q in
+    make_pat (Tpat_lazy r) p.pat_type p.pat_env
+| Tpat_construct (lid,c1,ps1,_), Tpat_construct (_,c2,ps2,_)
+      when  Types.equal_tag c1.cstr_tag c2.cstr_tag  ->
+        let rs = lubs ps1 ps2 in
+        make_pat (Tpat_construct (lid, c1, rs, None))
+          p.pat_type p.pat_env
+| Tpat_variant(l1,Some p1,row), Tpat_variant(l2,Some p2,_)
+          when  l1=l2 ->
+            let r=lub p1 p2 in
+            make_pat (Tpat_variant (l1,Some r,row)) p.pat_type p.pat_env
+| Tpat_variant (l1,None,_row), Tpat_variant(l2,None,_)
+              when l1 = l2 -> p
+| Tpat_record (l1,closed),Tpat_record (l2,_) ->
+    let rs = record_lubs l1 l2 in
+    make_pat (Tpat_record (rs, closed)) p.pat_type p.pat_env
+| Tpat_array ps, Tpat_array qs
+      when List.length ps = List.length qs ->
+        let rs = lubs ps qs in
+        make_pat (Tpat_array rs) p.pat_type p.pat_env
+| _,_  ->
+    raise Empty
+
+and orlub p1 p2 q =
+  try
+    let r1 = lub p1 q in
+    try
+      {q with pat_desc=(Tpat_or (r1,lub p2 q,None))}
+  with
+  | Empty -> r1
+with
+| Empty -> lub p2 q
+
+and record_lubs l1 l2 =
+  let rec lub_rec l1 l2 = match l1,l2 with
+  | [],_ -> l2
+  | _,[] -> l1
+  | (lid1, lbl1,p1)::rem1, (lid2, lbl2,p2)::rem2 ->
+      if lbl1.lbl_pos < lbl2.lbl_pos then
+        (lid1, lbl1,p1)::lub_rec rem1 l2
+      else if lbl2.lbl_pos < lbl1.lbl_pos  then
+        (lid2, lbl2,p2)::lub_rec l1 rem2
+      else
+        (lid1, lbl1,lub p1 p2)::lub_rec rem1 rem2 in
+  lub_rec l1 l2
+
+and lubs ps qs = match ps,qs with
+| p::ps, q::qs -> lub p q :: lubs ps qs
+| _,_ -> []
+
+
+(******************************)
+(* Exported variant closing   *)
+(******************************)
+
+(* Apply pressure to variants *)
+
+let pressure_variants tdefs patl =
+  ignore (pressure_variants
+            (Some tdefs)
+            (List.map (fun p -> [p; omega]) patl))
+
+let pressure_variants_in_computation_pattern tdefs patl =
+  let add_row pss p_opt =
+    match p_opt with
+    | None -> pss
+    | Some p -> p :: pss
+  in
+  let val_pss, exn_pss =
+    List.fold_right (fun pat (vpss, epss)->
+      let (vp, ep) = split_pattern pat in
+      add_row vpss vp, add_row epss ep
+    ) patl ([], [])
+  in
+  pressure_variants tdefs val_pss;
+  pressure_variants tdefs exn_pss
+
+(*****************************)
+(* Utilities for diagnostics *)
+(*****************************)
+
+(*
+  Build up a working pattern matrix by forgetting
+  about guarded patterns
+*)
+
+let rec initial_matrix = function
+    [] -> []
+  | {c_guard=Some _} :: rem -> initial_matrix rem
+  | {c_guard=None; c_lhs=p} :: rem -> [p] :: initial_matrix rem
+
+(*
+   Build up a working pattern matrix by keeping
+   only the patterns which are guarded
+*)
+let rec initial_only_guarded = function
+  | [] -> []
+  | { c_guard = None; _} :: rem ->
+      initial_only_guarded rem
+  | { c_lhs = pat; _ } :: rem ->
+      [pat] :: initial_only_guarded rem
+
+
+(************************)
+(* Exhaustiveness check *)
+(************************)
+
+(* conversion from Typedtree.pattern to Parsetree.pattern list *)
+module Conv = struct
+  open Parsetree
+  let mkpat desc = Ast_helper.Pat.mk desc
+
+  let name_counter = ref 0
+  let fresh name =
+    let current = !name_counter in
+    name_counter := !name_counter + 1;
+    "#$" ^ name ^ Int.to_string current
+
+  let conv typed =
+    let constrs = Hashtbl.create 7 in
+    let labels = Hashtbl.create 7 in
+    let rec loop pat =
+      match pat.pat_desc with
+        Tpat_or (pa,pb,_) ->
+          mkpat (Ppat_or (loop pa, loop pb))
+      | Tpat_var (_, ({txt="*extension*"} as nm)) -> (* PR#7330 *)
+          mkpat (Ppat_var nm)
+      | Tpat_any
+      | Tpat_var _ ->
+          mkpat Ppat_any
+      | Tpat_constant c ->
+          mkpat (Ppat_constant (Untypeast.constant c))
+      | Tpat_alias (p,_,_) -> loop p
+      | Tpat_tuple lst ->
+          mkpat (Ppat_tuple (List.map loop lst))
+      | Tpat_construct (cstr_lid, cstr, lst, _) ->
+          let id = fresh cstr.cstr_name in
+          let lid = { cstr_lid with txt = Longident.Lident id } in
+          Hashtbl.add constrs id cstr;
+          let arg =
+            match List.map loop lst with
+            | []  -> None
+            | [p] -> Some ([], p)
+            | lst -> Some ([], mkpat (Ppat_tuple lst))
+          in
+          mkpat (Ppat_construct(lid, arg))
+      | Tpat_variant(label,p_opt,_row_desc) ->
+          let arg = Option.map loop p_opt in
+          mkpat (Ppat_variant(label, arg))
+      | Tpat_record (subpatterns, _closed_flag) ->
+          let fields =
+            List.map
+              (fun (_, lbl, p) ->
+                let id = fresh lbl.lbl_name in
+                Hashtbl.add labels id lbl;
+                (mknoloc (Longident.Lident id), loop p))
+              subpatterns
+          in
+          mkpat (Ppat_record (fields, Open))
+      | Tpat_array lst ->
+          mkpat (Ppat_array (List.map loop lst))
+      | Tpat_lazy p ->
+          mkpat (Ppat_lazy (loop p))
+    in
+    let ps = loop typed in
+    (ps, constrs, labels)
+end
+
+
+(* Whether the counter-example contains an extension pattern *)
+let contains_extension pat =
+  exists_pattern
+    (function
+     | {pat_desc=Tpat_var (_, {txt="*extension*"})} -> true
+     | _ -> false)
+    pat
+
+(* Build a pattern from its expected type *)
+type pat_explosion = PE_single | PE_gadt_cases
+type ppat_of_type =
+  | PT_empty
+  | PT_any
+  | PT_pattern of
+      pat_explosion *
+      Parsetree.pattern *
+      (string, constructor_description) Hashtbl.t *
+      (string, label_description) Hashtbl.t
+
+let ppat_of_type env ty =
+  match pats_of_type env ty with
+  | [] -> PT_empty
+  | [{pat_desc = Tpat_any}] -> PT_any
+  | [pat] ->
+      let (ppat, constrs, labels) = Conv.conv pat in
+      PT_pattern (PE_single, ppat, constrs, labels)
+  | pats ->
+      let (ppat, constrs, labels) = Conv.conv (orify_many pats) in
+      PT_pattern (PE_gadt_cases, ppat, constrs, labels)
+
+let typecheck ~pred p =
+  let (pattern,constrs,labels) = Conv.conv p in
+  pred constrs labels pattern
+
+let do_check_partial ~pred loc casel pss = match pss with
+| [] ->
+        (*
+          This can occur
+          - For empty matches generated by ocamlp4 (no warning)
+          - when all patterns have guards (then, casel <> [])
+          (specific warning)
+          Then match MUST be considered non-exhaustive,
+          otherwise compilation of PM is broken.
+          *)
+    begin match casel with
+    | [] -> ()
+    | _  ->
+      if Warnings.is_active Warnings.All_clauses_guarded then
+        Location.prerr_warning loc Warnings.All_clauses_guarded
+    end ;
+    Partial
+| ps::_  ->
+    let counter_examples =
+      exhaust None pss (List.length ps)
+      |> Seq.filter_map (typecheck ~pred) in
+    match counter_examples () with
+    | Seq.Nil -> Total
+    | Seq.Cons (v, _rest) ->
+      if Warnings.is_active (Warnings.Partial_match "") then begin
+        let errmsg =
+          try
+            let buf = Buffer.create 16 in
+            let fmt = Format.formatter_of_buffer buf in
+            Printpat.top_pretty fmt v;
+            if do_match (initial_only_guarded casel) [v] then
+              Buffer.add_string buf
+                "\n(However, some guarded clause may match this value.)";
+            if contains_extension v then
+              Buffer.add_string buf
+                "\nMatching over values of extensible variant types \
+                   (the *extension* above)\n\
+              must include a wild card pattern in order to be exhaustive."
+            ;
+            Buffer.contents buf
+          with _ ->
+            ""
+        in
+        Location.prerr_warning loc (Warnings.Partial_match errmsg)
+      end;
+      Partial
+
+(*****************)
+(* Fragile check *)
+(*****************)
+
+(* Collect all data types in a pattern *)
+
+let rec add_path path = function
+  | [] -> [path]
+  | x::rem as paths ->
+      if Path.same path x then paths
+      else x::add_path path rem
+
+let extendable_path path =
+  not
+    (Path.same path Predef.path_bool ||
+    Path.same path Predef.path_list ||
+    Path.same path Predef.path_unit ||
+    Path.same path Predef.path_option)
+
+let rec collect_paths_from_pat r p = match p.pat_desc with
+| Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)},
+                 ps, _) ->
+    let path = get_constructor_type_path p.pat_type p.pat_env in
+    List.fold_left
+      collect_paths_from_pat
+      (if extendable_path path then add_path path r else r)
+      ps
+| Tpat_any|Tpat_var _|Tpat_constant _| Tpat_variant (_,None,_) -> r
+| Tpat_tuple ps | Tpat_array ps
+| Tpat_construct (_, {cstr_tag=Cstr_extension _}, ps, _)->
+    List.fold_left collect_paths_from_pat r ps
+| Tpat_record (lps,_) ->
+    List.fold_left
+      (fun r (_, _, p) -> collect_paths_from_pat r p)
+      r lps
+| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_) -> collect_paths_from_pat r p
+| Tpat_or (p1,p2,_) ->
+    collect_paths_from_pat (collect_paths_from_pat r p1) p2
+| Tpat_lazy p
+    ->
+    collect_paths_from_pat r p
+
+
+(*
+  Actual fragile check
+   1. Collect data types in the patterns of the match.
+   2. One exhaustivity check per datatype, considering that
+      the type is extended.
+*)
+
+let do_check_fragile loc casel pss =
+  let exts =
+    List.fold_left
+      (fun r c -> collect_paths_from_pat r c.c_lhs)
+      [] casel in
+  match exts with
+  | [] -> ()
+  | _ -> match pss with
+    | [] -> ()
+    | ps::_ ->
+        List.iter
+          (fun ext ->
+            let witnesses = exhaust (Some ext) pss (List.length ps) in
+            match witnesses () with
+            | Seq.Nil ->
+                Location.prerr_warning
+                  loc
+                  (Warnings.Fragile_match (Path.name ext))
+            | Seq.Cons _ -> ())
+          exts
+
+(********************************)
+(* Exported unused clause check *)
+(********************************)
+
+let check_unused pred casel =
+  if Warnings.is_active Warnings.Redundant_case
+  || List.exists (fun c -> c.c_rhs.exp_desc = Texp_unreachable) casel then
+    let rec do_rec pref = function
+      | [] -> ()
+      | {c_lhs=q; c_guard; c_rhs} :: rem ->
+          let qs = [q] in
+            begin try
+              let pss =
+                (* prev was accumulated in reverse order;
+                   restore source order to get ordered counter-examples *)
+                List.rev pref
+                |> List.filter (compats qs)
+                |> get_mins le_pats in
+              (* First look for redundant or partially redundant patterns *)
+              let r = every_satisfiables (make_rows pss) (make_row qs) in
+              let refute = (c_rhs.exp_desc = Texp_unreachable) in
+              (* Do not warn for unused [pat -> .] *)
+              if r = Unused && refute then () else
+              let r =
+                (* Do not refine if either:
+                   - we already know the clause is unused
+                   - the clause under consideration is not a refutation clause
+                     and either:
+                     + there are no other lines
+                     + we do not care whether the types prevent this clause to
+                       be reached.
+                     If the clause under consideration *is* a refutation clause
+                     then we do need to check more carefully whether it can be
+                     refuted or not.  *)
+                let skip =
+                  r = Unused || (not refute && pref = []) ||
+                  not(refute || Warnings.is_active Warnings.Unreachable_case) in
+                if skip then r else
+                (* Then look for empty patterns *)
+                let sfs = list_satisfying_vectors pss qs in
+                if sfs = [] then Unused else
+                let sfs =
+                  List.map (function [u] -> u | _ -> assert false) sfs in
+                let u = orify_many sfs in
+                (*Format.eprintf "%a@." pretty_val u;*)
+                let (pattern,constrs,labels) = Conv.conv u in
+                let pattern = {pattern with Parsetree.ppat_loc = q.pat_loc} in
+                match pred refute constrs labels pattern with
+                  None when not refute ->
+                    Location.prerr_warning q.pat_loc Warnings.Unreachable_case;
+                    Used
+                | _ -> r
+              in
+              match r with
+              | Unused ->
+                  Location.prerr_warning
+                    q.pat_loc Warnings.Redundant_case
+              | Upartial ps ->
+                  List.iter
+                    (fun p ->
+                      Location.prerr_warning
+                        p.pat_loc Warnings.Redundant_subpat)
+                    ps
+              | Used -> ()
+            with Empty | Not_found -> assert false
+            end ;
+
+          if c_guard <> None then
+            do_rec pref rem
+          else
+            do_rec ([q]::pref) rem in
+
+    do_rec [] casel
+
+(*********************************)
+(* Exported irrefutability tests *)
+(*********************************)
+
+let irrefutable pat = le_pat pat omega
+
+let inactive ~partial pat =
+  match partial with
+  | Partial -> false
+  | Total -> begin
+      let rec loop pat =
+        match pat.pat_desc with
+        | Tpat_lazy _ | Tpat_array _ ->
+          false
+        | Tpat_any | Tpat_var _ | Tpat_variant (_, None, _) ->
+            true
+        | Tpat_constant c -> begin
+            match c with
+            | Const_string _ -> Config.safe_string
+            | Const_int _ | Const_char _ | Const_float _
+            | Const_int32 _ | Const_int64 _ | Const_nativeint _ -> true
+          end
+        | Tpat_tuple ps | Tpat_construct (_, _, ps, _) ->
+            List.for_all (fun p -> loop p) ps
+        | Tpat_alias (p,_,_) | Tpat_variant (_, Some p, _) ->
+            loop p
+        | Tpat_record (ldps,_) ->
+            List.for_all
+              (fun (_, lbl, p) -> lbl.lbl_mut = Immutable && loop p)
+              ldps
+        | Tpat_or (p,q,_) ->
+            loop p && loop q
+      in
+      loop pat
+  end
+
+
+
+
+
+
+
+(*********************************)
+(* Exported exhaustiveness check *)
+(*********************************)
+
+(*
+   Fragile check is performed when required and
+   on exhaustive matches only.
+*)
+
+let check_partial pred loc casel =
+  let pss = initial_matrix casel in
+  let pss = get_mins le_pats pss in
+  let total = do_check_partial ~pred loc casel pss in
+  if
+    total = Total && Warnings.is_active (Warnings.Fragile_match "")
+  then begin
+    do_check_fragile loc casel pss
+  end ;
+  total
+
+(*************************************)
+(* Ambiguous variable in or-patterns *)
+(*************************************)
+
+(* Specification: ambiguous variables in or-patterns.
+
+   The semantics of or-patterns in OCaml is specified with
+   a left-to-right bias: a value [v] matches the pattern [p | q] if it
+   matches [p] or [q], but if it matches both, the environment
+   captured by the match is the environment captured by [p], never the
+   one captured by [q].
+
+   While this property is generally well-understood, one specific case
+   where users expect a different semantics is when a pattern is
+   followed by a when-guard: [| p when g -> e]. Consider for example:
+
+     | ((Const x, _) | (_, Const x)) when is_neutral x -> branch
+
+   The semantics is clear: match the scrutinee against the pattern, if
+   it matches, test the guard, and if the guard passes, take the
+   branch.
+
+   However, consider the input [(Const a, Const b)], where [a] fails
+   the test [is_neutral f], while [b] passes the test [is_neutral
+   b]. With the left-to-right semantics, the clause above is *not*
+   taken by its input: matching [(Const a, Const b)] against the
+   or-pattern succeeds in the left branch, it returns the environment
+   [x -> a], and then the guard [is_neutral a] is tested and fails,
+   the branch is not taken. Most users, however, intuitively expect
+   that any pair that has one side passing the test will take the
+   branch. They assume it is equivalent to the following:
+
+     | (Const x, _) when is_neutral x -> branch
+     | (_, Const x) when is_neutral x -> branch
+
+   while it is not.
+
+   The code below is dedicated to finding these confusing cases: the
+   cases where a guard uses "ambiguous" variables, that are bound to
+   different parts of the scrutinees by different sides of
+   a or-pattern. In other words, it finds the cases where the
+   specified left-to-right semantics is not equivalent to
+   a non-deterministic semantics (any branch can be taken) relatively
+   to a specific guard.
+*)
+
+let pattern_vars p = Ident.Set.of_list (Typedtree.pat_bound_idents p)
+
+(* Row for ambiguous variable search,
+   row is the traditional pattern row,
+   varsets contain a list of head variable sets (varsets)
+
+   A given varset contains all the variables that appeared at the head
+   of a pattern in the row at some point during traversal: they would
+   all be bound to the same value at matching time. On the contrary,
+   two variables of different varsets appeared at different places in
+   the pattern and may be bound to distinct sub-parts of the matched
+   value.
+
+   All rows of a (sub)matrix have rows of the same length,
+   but also varsets of the same length.
+
+   Varsets are populated when simplifying the first column
+   -- the variables of the head pattern are collected in a new varset.
+   For example,
+     { row = x :: r1; varsets = s1 }
+     { row = (Some _) as y :: r2; varsets  = s2 }
+     { row = (None as x) as y :: r3; varsets = s3 }
+     { row = (Some x | (None as x)) :: r4 with varsets = s4 }
+   becomes
+     (_, { row = r1; varsets = {x} :: s1 })
+     (Some _, { row = r2; varsets = {y} :: s2 })
+     (None, { row = r3; varsets = {x, y} :: s3 })
+     (Some x, { row = r4; varsets = {} :: s4 })
+     (None, { row = r4; varsets = {x} :: s4 })
+*)
+type amb_row = { row : pattern list ; varsets : Ident.Set.t list; }
+
+let simplify_head_amb_pat head_bound_variables varsets ~add_column p ps k =
+  let rec simpl head_bound_variables varsets p ps k =
+    match (Patterns.General.view p).pat_desc with
+    | `Alias (p,x,_) ->
+      simpl (Ident.Set.add x head_bound_variables) varsets p ps k
+    | `Var (x, _) ->
+      simpl (Ident.Set.add x head_bound_variables) varsets Patterns.omega ps k
+    | `Or (p1,p2,_) ->
+      simpl head_bound_variables varsets p1 ps
+        (simpl head_bound_variables varsets p2 ps k)
+    | #Patterns.Simple.view as view ->
+      add_column (Patterns.Head.deconstruct { p with pat_desc = view })
+        { row = ps; varsets = head_bound_variables :: varsets; } k
+  in simpl head_bound_variables varsets p ps k
+
+(*
+   To accurately report ambiguous variables, one must consider
+   that previous clauses have already matched some values.
+   Consider for example:
+
+     | (Foo x, Foo y) -> ...
+     | ((Foo x, _) | (_, Foo x)) when bar x -> ...
+
+   The second line taken in isolation uses an unstable variable,
+   but the discriminating values, of the shape [(Foo v1, Foo v2)],
+   would all be filtered by the line above.
+
+   To track this information, the matrices we analyze contain both
+   *positive* rows, that describe the rows currently being analyzed
+   (of type Varsets.row, so that their varsets are tracked) and
+   *negative rows*, that describe the cases already matched against.
+
+   The values matched by a signed matrix are the values matched by
+   some of the positive rows but none of the negative rows. In
+   particular, a variable is stable if, for any value not matched by
+   any of the negative rows, the environment captured by any of the
+   matching positive rows is identical.
+*)
+type ('a, 'b) signed = Positive of 'a | Negative of 'b
+
+let rec simplify_first_amb_col = function
+  | [] -> []
+  | (Negative [] | Positive { row = []; _ }) :: _  -> assert false
+  | Negative (n :: ns) :: rem ->
+      let add_column n ns k = (n, Negative ns) :: k in
+      simplify_head_pat
+        ~add_column n ns (simplify_first_amb_col rem)
+  | Positive { row = p::ps; varsets; }::rem ->
+      let add_column p ps k = (p, Positive ps) :: k in
+      simplify_head_amb_pat
+        Ident.Set.empty varsets
+        ~add_column p ps (simplify_first_amb_col rem)
+
+(* Compute stable bindings *)
+
+type stable_vars =
+  | All
+  | Vars of Ident.Set.t
+
+let stable_inter sv1 sv2 = match sv1, sv2 with
+  | All, sv | sv, All -> sv
+  | Vars s1, Vars s2 -> Vars (Ident.Set.inter s1 s2)
+
+let reduce f = function
+| [] -> invalid_arg "reduce"
+| x::xs -> List.fold_left f x xs
+
+let rec matrix_stable_vars m = match m with
+  | [] -> All
+  | ((Positive {row = []; _} | Negative []) :: _) as empty_rows ->
+      let exception Negative_empty_row in
+      (* if at least one empty row is negative, the matrix matches no value *)
+      let get_varsets = function
+        | Negative n ->
+            (* All rows have the same number of columns;
+               if the first row is empty, they all are. *)
+            assert (n = []);
+            raise Negative_empty_row
+        | Positive p ->
+            assert (p.row = []);
+            p.varsets in
+      begin match List.map get_varsets empty_rows with
+      | exception Negative_empty_row -> All
+      | rows_varsets ->
+          let stables_in_varsets =
+            reduce (List.map2 Ident.Set.inter) rows_varsets in
+          (* The stable variables are those stable at any position *)
+          Vars
+            (List.fold_left Ident.Set.union Ident.Set.empty stables_in_varsets)
+      end
+  | m ->
+      let is_negative = function
+        | Negative _ -> true
+        | Positive _ -> false in
+      if List.for_all is_negative m then
+        (* optimization: quit early if there are no positive rows.
+           This may happen often when the initial matrix has many
+           negative cases and few positive cases (a small guarded
+           clause after a long list of clauses) *)
+        All
+      else begin
+        let m = simplify_first_amb_col m in
+        if not (all_coherent (first_column m)) then
+          All
+        else begin
+          (* If the column is ill-typed but deemed coherent, we might
+             spuriously warn about some variables being unstable.
+             As sad as that might be, the warning can be silenced by
+             splitting the or-pattern...  *)
+          let submatrices =
+            let extend_row columns = function
+              | Negative r -> Negative (columns @ r)
+              | Positive r -> Positive { r with row = columns @ r.row } in
+            let q0 = discr_pat Patterns.Simple.omega m in
+            let { default; constrs } =
+              build_specialized_submatrices ~extend_row q0 m in
+            let non_default = List.map snd constrs in
+            if full_match false constrs
+            then non_default
+            else default :: non_default in
+          (* A stable variable must be stable in each submatrix. *)
+          let submat_stable = List.map matrix_stable_vars submatrices in
+          List.fold_left stable_inter All submat_stable
+        end
+      end
+
+let pattern_stable_vars ns p =
+  matrix_stable_vars
+    (List.fold_left (fun m n -> Negative n :: m)
+       [Positive {varsets = []; row = [p]}] ns)
+
+(* All identifier paths that appear in an expression that occurs
+   as a clause right hand side or guard.
+
+  The function is rather complex due to the compilation of
+  unpack patterns by introducing code in rhs expressions
+  and **guards**.
+
+  For pattern (module M:S)  -> e the code is
+  let module M_mod = unpack M .. in e
+
+  Hence M is "free" in e iff M_mod is free in e.
+
+  Not doing so will yield excessive  warning in
+  (module (M:S) } ...) when true -> ....
+  as M is always present in
+  let module M_mod = unpack M .. in true
+*)
+
+let all_rhs_idents exp =
+  let ids = ref Ident.Set.empty in
+(* Very hackish, detect unpack pattern  compilation
+   and perform "indirect check for them" *)
+  let is_unpack exp =
+      List.exists
+        (fun attr -> attr.Parsetree.attr_name.txt = "#modulepat")
+        exp.exp_attributes in
+  let open Tast_iterator in
+  let expr_iter iter exp =
+    (match exp.exp_desc with
+      | Texp_ident (path, _lid, _descr) ->
+        List.iter (fun id -> ids := Ident.Set.add id !ids) (Path.heads path)
+      (* Use default iterator methods for rest of match.*)
+      | _ -> Tast_iterator.default_iterator.expr iter exp);
+
+    if is_unpack exp then begin match exp.exp_desc with
+    | Texp_letmodule
+        (id_mod,_,_,
+         {mod_desc=
+          Tmod_unpack ({exp_desc=Texp_ident (Path.Pident id_exp,_,_)},_)},
+         _) ->
+           assert (Ident.Set.mem id_exp !ids) ;
+           begin match id_mod with
+           | Some id_mod when not (Ident.Set.mem id_mod !ids) ->
+             ids := Ident.Set.remove id_exp !ids
+           | _ -> ()
+           end
+    | _ -> assert false
+    end
+  in
+  let iterator = {Tast_iterator.default_iterator with expr = expr_iter} in
+  iterator.expr iterator exp;
+  !ids
+
+let check_ambiguous_bindings =
+  let open Warnings in
+  let warn0 = Ambiguous_var_in_pattern_guard [] in
+  fun cases ->
+    if is_active warn0 then
+      let check_case ns case = match case with
+        | { c_lhs = p; c_guard=None ; _} -> [p]::ns
+        | { c_lhs=p; c_guard=Some g; _} ->
+            let all =
+              Ident.Set.inter (pattern_vars p) (all_rhs_idents g) in
+            if not (Ident.Set.is_empty all) then begin
+              match pattern_stable_vars ns p with
+              | All -> ()
+              | Vars stable ->
+                  let ambiguous = Ident.Set.diff all stable in
+                  if not (Ident.Set.is_empty ambiguous) then begin
+                    let pps =
+                      Ident.Set.elements ambiguous |> List.map Ident.name in
+                    let warn = Ambiguous_var_in_pattern_guard pps in
+                    Location.prerr_warning p.pat_loc warn
+                  end
+            end;
+            ns
+      in
+      ignore (List.fold_left check_case [] cases)
diff --git a/upstream/ocaml_413/typing/parmatch.mli b/upstream/ocaml_413/typing/parmatch.mli
new file mode 100644
index 0000000..fc81476
--- /dev/null
+++ b/upstream/ocaml_413/typing/parmatch.mli
@@ -0,0 +1,134 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Detection of partial matches and unused match cases. *)
+
+open Asttypes
+open Typedtree
+open Types
+
+val const_compare : constant -> constant -> int
+(** [const_compare c1 c2] compares the actual values represented by [c1] and
+    [c2], while simply using [Stdlib.compare] would compare the
+    representations.
+
+    cf. MPR#5758 *)
+
+val le_pat : pattern -> pattern -> bool
+(** [le_pat p q]  means: forall V,  V matches q implies V matches p *)
+
+val le_pats : pattern list -> pattern list -> bool
+(** [le_pats (p1 .. pm) (q1 .. qn)] means: forall i <= m, [le_pat pi qi] *)
+
+(** Exported compatibility functor, abstracted over constructor equality *)
+module Compat :
+  functor
+    (_ : sig
+      val equal :
+          Types.constructor_description ->
+            Types.constructor_description ->
+              bool
+     end) -> sig
+       val compat : pattern -> pattern -> bool
+       val compats : pattern list -> pattern list -> bool
+     end
+
+exception Empty
+
+val lub : pattern -> pattern -> pattern
+(** [lub p q] is a pattern that matches all values matched by [p] and [q].
+    May raise [Empty], when [p] and [q] are not compatible. *)
+
+val lubs : pattern list -> pattern list -> pattern list
+(** [lubs [p1; ...; pn] [q1; ...; qk]], where [n < k], is
+    [[lub p1 q1; ...; lub pk qk]].  *)
+
+val get_mins : ('a -> 'a -> bool) -> 'a list -> 'a list
+
+(** Those two functions recombine one pattern and its arguments:
+    For instance:
+      (_,_)::p1::p2::rem -> (p1, p2)::rem
+    The second one will replace mutable arguments by '_'
+*)
+val set_args : pattern -> pattern list -> pattern list
+val set_args_erase_mutable : pattern -> pattern list -> pattern list
+
+val pat_of_constr : pattern -> constructor_description -> pattern
+val complete_constrs :
+    constructor_description pattern_data ->
+    constructor_description list ->
+    constructor_description list
+
+(** [ppat_of_type] builds an untyped pattern from its expected type,
+    for explosion of wildcard patterns in Typecore.type_pat.
+
+    There are four interesting cases:
+    - the type is empty ([PT_empty])
+    - no further explosion is necessary ([PT_any])
+    - a single pattern is generated, from a record or tuple type
+      or a single-variant type ([PE_single])
+    - an or-pattern is generated, in the case that all branches
+      are GADT constructors ([PE_gadt_cases]).
+ *)
+type pat_explosion = PE_single | PE_gadt_cases
+type ppat_of_type =
+  | PT_empty
+  | PT_any
+  | PT_pattern of
+      pat_explosion *
+      Parsetree.pattern *
+      (string, constructor_description) Hashtbl.t *
+      (string, label_description) Hashtbl.t
+
+val ppat_of_type: Env.t -> type_expr -> ppat_of_type
+
+val pressure_variants:
+  Env.t -> pattern list -> unit
+val pressure_variants_in_computation_pattern:
+  Env.t -> computation general_pattern list -> unit
+
+(** [check_partial pred loc caselist] and [check_unused refute pred caselist]
+    are called with a function [pred] which will be given counter-example
+    candidates: they may be partially ill-typed, and have to be type-checked
+    to extract a valid counter-example.
+    [pred] returns a valid counter-example or [None].
+    [refute] indicates that [check_unused] was called on a refutation clause.
+ *)
+val check_partial:
+    ((string, constructor_description) Hashtbl.t ->
+     (string, label_description) Hashtbl.t ->
+     Parsetree.pattern -> pattern option) ->
+    Location.t -> value case list -> partial
+val check_unused:
+    (bool ->
+     (string, constructor_description) Hashtbl.t ->
+     (string, label_description) Hashtbl.t ->
+     Parsetree.pattern -> pattern option) ->
+    value case list -> unit
+
+(* Irrefutability tests *)
+val irrefutable : pattern -> bool
+
+(** An inactive pattern is a pattern, matching against which can be duplicated,
+    erased or delayed without change in observable behavior of the program.
+    Patterns containing (lazy _) subpatterns or reads of mutable fields are
+    active. *)
+val inactive : partial:partial -> pattern -> bool
+
+(* Ambiguous bindings *)
+val check_ambiguous_bindings : value case list -> unit
+
+(* The tag used for open polymorphic variant types with an abstract row *)
+val some_private_tag : label
diff --git a/upstream/ocaml_413/typing/path.ml b/upstream/ocaml_413/typing/path.ml
new file mode 100644
index 0000000..4190c27
--- /dev/null
+++ b/upstream/ocaml_413/typing/path.ml
@@ -0,0 +1,129 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t =
+    Pident of Ident.t
+  | Pdot of t * string
+  | Papply of t * t
+
+let rec same p1 p2 =
+  p1 == p2
+  || match (p1, p2) with
+    (Pident id1, Pident id2) -> Ident.same id1 id2
+  | (Pdot(p1, s1), Pdot(p2, s2)) -> s1 = s2 && same p1 p2
+  | (Papply(fun1, arg1), Papply(fun2, arg2)) ->
+       same fun1 fun2 && same arg1 arg2
+  | (_, _) -> false
+
+let rec compare p1 p2 =
+  if p1 == p2 then 0
+  else match (p1, p2) with
+    (Pident id1, Pident id2) -> Ident.compare id1 id2
+  | (Pdot(p1, s1), Pdot(p2, s2)) ->
+      let h = compare p1 p2 in
+      if h <> 0 then h else String.compare s1 s2
+  | (Papply(fun1, arg1), Papply(fun2, arg2)) ->
+      let h = compare fun1 fun2 in
+      if h <> 0 then h else compare arg1 arg2
+  | ((Pident _ | Pdot _), (Pdot _ | Papply _)) -> -1
+  | ((Pdot _ | Papply _), (Pident _ | Pdot _)) -> 1
+
+let rec find_free_opt ids = function
+    Pident id -> List.find_opt (Ident.same id) ids
+  | Pdot(p, _s) -> find_free_opt ids p
+  | Papply(p1, p2) ->
+      match find_free_opt ids p1 with
+      | None -> find_free_opt ids p2
+      | Some _ as res -> res
+
+let exists_free ids p =
+  match find_free_opt ids p with
+  | None -> false
+  | _ -> true
+
+let rec scope = function
+    Pident id -> Ident.scope id
+  | Pdot(p, _s) -> scope p
+  | Papply(p1, p2) -> Int.max (scope p1) (scope p2)
+
+let kfalse _ = false
+
+let rec name ?(paren=kfalse) = function
+    Pident id -> Ident.name id
+  | Pdot(p, s) ->
+      name ~paren p ^ if paren s then ".( " ^ s ^ " )" else "." ^ s
+  | Papply(p1, p2) -> name ~paren p1 ^ "(" ^ name ~paren p2 ^ ")"
+
+let rec print ppf = function
+  | Pident id -> Ident.print_with_scope ppf id
+  | Pdot(p, s) -> Format.fprintf ppf "%a.%s" print p s
+  | Papply(p1, p2) -> Format.fprintf ppf "%a(%a)" print p1 print p2
+
+let rec head = function
+    Pident id -> id
+  | Pdot(p, _s) -> head p
+  | Papply _ -> assert false
+
+let flatten =
+  let rec flatten acc = function
+    | Pident id -> `Ok (id, acc)
+    | Pdot (p, s) -> flatten (s :: acc) p
+    | Papply _ -> `Contains_apply
+  in
+  fun t -> flatten [] t
+
+let heads p =
+  let rec heads p acc = match p with
+    | Pident id -> id :: acc
+    | Pdot (p, _s) -> heads p acc
+    | Papply(p1, p2) ->
+        heads p1 (heads p2 acc)
+  in heads p []
+
+let rec last = function
+  | Pident id -> Ident.name id
+  | Pdot(_, s) -> s
+  | Papply(_, p) -> last p
+
+let is_uident s =
+  assert (s <> "");
+  match s.[0] with
+  | 'A'..'Z' -> true
+  | _ -> false
+
+type typath =
+  | Regular of t
+  | Ext of t * string
+  | LocalExt of Ident.t
+  | Cstr of t * string
+
+let constructor_typath = function
+  | Pident id when is_uident (Ident.name id) -> LocalExt id
+  | Pdot(ty_path, s) when is_uident s ->
+      if is_uident (last ty_path) then Ext (ty_path, s)
+      else Cstr (ty_path, s)
+  | p -> Regular p
+
+let is_constructor_typath p =
+  match constructor_typath p with
+  | Regular _ -> false
+  | _ -> true
+
+module T = struct
+  type nonrec t = t
+  let compare = compare
+end
+module Set = Set.Make(T)
+module Map = Map.Make(T)
diff --git a/upstream/ocaml_413/typing/path.mli b/upstream/ocaml_413/typing/path.mli
new file mode 100644
index 0000000..bddf9d6
--- /dev/null
+++ b/upstream/ocaml_413/typing/path.mli
@@ -0,0 +1,52 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Access paths *)
+
+type t =
+    Pident of Ident.t
+  | Pdot of t * string
+  | Papply of t * t
+
+val same: t -> t -> bool
+val compare: t -> t -> int
+val find_free_opt: Ident.t list -> t -> Ident.t option
+val exists_free: Ident.t list -> t -> bool
+val scope: t -> int
+val flatten : t -> [ `Contains_apply | `Ok of Ident.t * string list ]
+
+val name: ?paren:(string -> bool) -> t -> string
+    (* [paren] tells whether a path suffix needs parentheses *)
+val head: t -> Ident.t
+
+val print: Format.formatter -> t -> unit
+
+val heads: t -> Ident.t list
+
+val last: t -> string
+
+val is_uident: string -> bool
+
+type typath =
+  | Regular of t
+  | Ext of t * string
+  | LocalExt of Ident.t
+  | Cstr of t * string
+
+val constructor_typath: t -> typath
+val is_constructor_typath: t -> bool
+
+module Map : Map.S with type key = t
+module Set : Set.S with type elt = t
diff --git a/upstream/ocaml_413/typing/patterns.ml b/upstream/ocaml_413/typing/patterns.ml
new file mode 100644
index 0000000..8580329
--- /dev/null
+++ b/upstream/ocaml_413/typing/patterns.ml
@@ -0,0 +1,254 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Gabriel Scherer, projet Partout, INRIA Paris-Saclay           *)
+(*          Thomas Refis, Jane Street Europe                              *)
+(*                                                                        *)
+(*   Copyright 2019 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Types
+open Typedtree
+
+(* useful pattern auxiliary functions *)
+
+let omega = {
+  pat_desc = Tpat_any;
+  pat_loc = Location.none;
+  pat_extra = [];
+  pat_type = Ctype.none;
+  pat_env = Env.empty;
+  pat_attributes = [];
+}
+
+let rec omegas i =
+  if i <= 0 then [] else omega :: omegas (i-1)
+
+let omega_list l = List.map (fun _ -> omega) l
+
+module Non_empty_row = struct
+  type 'a t = 'a * Typedtree.pattern list
+
+  let of_initial = function
+    | [] -> assert false
+    | pat :: patl -> (pat, patl)
+
+  let map_first f (p, patl) = (f p, patl)
+end
+
+(* "views" on patterns are polymorphic variants
+   that allow to restrict the set of pattern constructors
+   statically allowed at a particular place *)
+
+module Simple = struct
+  type view = [
+    | `Any
+    | `Constant of constant
+    | `Tuple of pattern list
+    | `Construct of
+        Longident.t loc * constructor_description * pattern list
+    | `Variant of label * pattern option * row_desc ref
+    | `Record of
+        (Longident.t loc * label_description * pattern) list * closed_flag
+    | `Array of pattern list
+    | `Lazy of pattern
+  ]
+
+  type pattern = view pattern_data
+
+  let omega = { omega with pat_desc = `Any }
+end
+
+module Half_simple = struct
+  type view = [
+    | Simple.view
+    | `Or of pattern * pattern * row_desc option
+  ]
+
+  type pattern = view pattern_data
+end
+
+module General = struct
+  type view = [
+    | Half_simple.view
+    | `Var of Ident.t * string loc
+    | `Alias of pattern * Ident.t * string loc
+  ]
+  type pattern = view pattern_data
+
+  let view_desc = function
+    | Tpat_any ->
+       `Any
+    | Tpat_var (id, str) ->
+       `Var (id, str)
+    | Tpat_alias (p, id, str) ->
+       `Alias (p, id, str)
+    | Tpat_constant cst ->
+       `Constant cst
+    | Tpat_tuple ps ->
+       `Tuple ps
+    | Tpat_construct (cstr, cstr_descr, args, _) ->
+       `Construct (cstr, cstr_descr, args)
+    | Tpat_variant (cstr, arg, row_desc) ->
+       `Variant (cstr, arg, row_desc)
+    | Tpat_record (fields, closed) ->
+       `Record (fields, closed)
+    | Tpat_array ps -> `Array ps
+    | Tpat_or (p, q, row_desc) -> `Or (p, q, row_desc)
+    | Tpat_lazy p -> `Lazy p
+
+  let view p : pattern =
+    { p with pat_desc = view_desc p.pat_desc }
+
+  let erase_desc = function
+    | `Any -> Tpat_any
+    | `Var (id, str) -> Tpat_var (id, str)
+    | `Alias (p, id, str) -> Tpat_alias (p, id, str)
+    | `Constant cst -> Tpat_constant cst
+    | `Tuple ps -> Tpat_tuple ps
+    | `Construct (cstr, cst_descr, args) ->
+       Tpat_construct (cstr, cst_descr, args, None)
+    | `Variant (cstr, arg, row_desc) ->
+       Tpat_variant (cstr, arg, row_desc)
+    | `Record (fields, closed) ->
+       Tpat_record (fields, closed)
+    | `Array ps -> Tpat_array ps
+    | `Or (p, q, row_desc) -> Tpat_or (p, q, row_desc)
+    | `Lazy p -> Tpat_lazy p
+
+  let erase p : Typedtree.pattern =
+    { p with pat_desc = erase_desc p.pat_desc }
+
+  let rec strip_vars (p : pattern) : Half_simple.pattern =
+    match p.pat_desc with
+    | `Alias (p, _, _) -> strip_vars (view p)
+    | `Var _ -> { p with pat_desc = `Any }
+    | #Half_simple.view as view -> { p with pat_desc = view }
+end
+
+(* the head constructor of a simple pattern *)
+
+module Head : sig
+  type desc =
+    | Any
+    | Construct of constructor_description
+    | Constant of constant
+    | Tuple of int
+    | Record of label_description list
+    | Variant of
+        { tag: label; has_arg: bool;
+          cstr_row: row_desc ref;
+          type_row : unit -> row_desc; }
+    | Array of int
+    | Lazy
+
+  type t = desc pattern_data
+
+  val arity : t -> int
+
+  (** [deconstruct p] returns the head of [p] and the list of sub patterns. *)
+  val deconstruct : Simple.pattern -> t * pattern list
+
+  (** reconstructs a pattern, putting wildcards as sub-patterns. *)
+  val to_omega_pattern : t -> pattern
+
+  val omega : t
+end = struct
+  type desc =
+    | Any
+    | Construct of constructor_description
+    | Constant of constant
+    | Tuple of int
+    | Record of label_description list
+    | Variant of
+        { tag: label; has_arg: bool;
+          cstr_row: row_desc ref;
+          type_row : unit -> row_desc; }
+          (* the row of the type may evolve if [close_variant] is called,
+             hence the (unit -> ...) delay *)
+    | Array of int
+    | Lazy
+
+  type t = desc pattern_data
+
+  let deconstruct (q : Simple.pattern) =
+    let deconstruct_desc = function
+      | `Any -> Any, []
+      | `Constant c -> Constant c, []
+      | `Tuple args ->
+          Tuple (List.length args), args
+      | `Construct (_, c, args) ->
+          Construct c, args
+      | `Variant (tag, arg, cstr_row) ->
+          let has_arg, pats =
+            match arg with
+            | None -> false, []
+            | Some a -> true, [a]
+          in
+          let type_row () =
+            match Ctype.expand_head q.pat_env q.pat_type with
+              | {desc = Tvariant type_row} -> Btype.row_repr type_row
+              | _ -> assert false
+          in
+          Variant {tag; has_arg; cstr_row; type_row}, pats
+      | `Array args ->
+          Array (List.length args), args
+      | `Record (largs, _) ->
+          let lbls = List.map (fun (_,lbl,_) -> lbl) largs in
+          let pats = List.map (fun (_,_,pat) -> pat) largs in
+          Record lbls, pats
+      | `Lazy p ->
+          Lazy, [p]
+    in
+    let desc, pats = deconstruct_desc q.pat_desc in
+    { q with pat_desc = desc }, pats
+
+  let arity t =
+    match t.pat_desc with
+      | Any -> 0
+      | Constant _ -> 0
+      | Construct c -> c.cstr_arity
+      | Tuple n | Array n -> n
+      | Record l -> List.length l
+      | Variant { has_arg; _ } -> if has_arg then 1 else 0
+      | Lazy -> 1
+
+  let to_omega_pattern t =
+    let pat_desc =
+      let mkloc x = Location.mkloc x t.pat_loc in
+      match t.pat_desc with
+      | Any -> Tpat_any
+      | Lazy -> Tpat_lazy omega
+      | Constant c -> Tpat_constant c
+      | Tuple n -> Tpat_tuple (omegas n)
+      | Array n -> Tpat_array (omegas n)
+      | Construct c ->
+          let lid_loc = mkloc (Longident.Lident c.cstr_name) in
+          Tpat_construct (lid_loc, c, omegas c.cstr_arity, None)
+      | Variant { tag; has_arg; cstr_row } ->
+          let arg_opt = if has_arg then Some omega else None in
+          Tpat_variant (tag, arg_opt, cstr_row)
+      | Record lbls ->
+          let lst =
+            List.map (fun lbl ->
+              let lid_loc = mkloc (Longident.Lident lbl.lbl_name) in
+              (lid_loc, lbl, omega)
+            ) lbls
+          in
+          Tpat_record (lst, Closed)
+    in
+    { t with
+      pat_desc;
+      pat_extra = [];
+    }
+
+  let omega = { omega with pat_desc = Any }
+end
diff --git a/upstream/ocaml_413/typing/patterns.mli b/upstream/ocaml_413/typing/patterns.mli
new file mode 100644
index 0000000..66dd2d0
--- /dev/null
+++ b/upstream/ocaml_413/typing/patterns.mli
@@ -0,0 +1,109 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Gabriel Scherer, projet Partout, INRIA Paris-Saclay           *)
+(*          Thomas Refis, Jane Street Europe                              *)
+(*                                                                        *)
+(*   Copyright 2019 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Typedtree
+open Types
+
+val omega : pattern
+(** aka. "Tpat_any" or "_"  *)
+
+val omegas : int -> pattern list
+(** [List.init (fun _ -> omega)] *)
+
+val omega_list : 'a list -> pattern list
+(** [List.map (fun _ -> omega)] *)
+
+module Non_empty_row : sig
+  type 'a t = 'a * Typedtree.pattern list
+
+  val of_initial : Typedtree.pattern list -> Typedtree.pattern t
+  (** 'assert false' on empty rows *)
+
+  val map_first : ('a -> 'b) -> 'a t -> 'b t
+end
+
+module Simple : sig
+  type view = [
+    | `Any
+    | `Constant of constant
+    | `Tuple of pattern list
+    | `Construct of
+        Longident.t loc * constructor_description * pattern list
+    | `Variant of label * pattern option * row_desc ref
+    | `Record of
+        (Longident.t loc * label_description * pattern) list * closed_flag
+    | `Array of pattern list
+    | `Lazy of pattern
+  ]
+  type pattern = view pattern_data
+
+  val omega : [> view ] pattern_data
+end
+
+module Half_simple : sig
+  type view = [
+    | Simple.view
+    | `Or of pattern * pattern * row_desc option
+  ]
+  type pattern = view pattern_data
+end
+
+module General : sig
+  type view = [
+    | Half_simple.view
+    | `Var of Ident.t * string loc
+    | `Alias of pattern * Ident.t * string loc
+  ]
+  type pattern = view pattern_data
+
+  val view : Typedtree.pattern -> pattern
+  val erase : [< view ] pattern_data -> Typedtree.pattern
+
+  val strip_vars : pattern -> Half_simple.pattern
+end
+
+module Head : sig
+  type desc =
+    | Any
+    | Construct of constructor_description
+    | Constant of constant
+    | Tuple of int
+    | Record of label_description list
+    | Variant of
+        { tag: label; has_arg: bool;
+          cstr_row: row_desc ref;
+          type_row : unit -> row_desc; }
+          (* the row of the type may evolve if [close_variant] is called,
+             hence the (unit -> ...) delay *)
+    | Array of int
+    | Lazy
+
+  type t = desc pattern_data
+
+  val arity : t -> int
+
+  (** [deconstruct p] returns the head of [p] and the list of sub patterns.
+
+      @raise [Invalid_arg _] if [p] is an or- or an exception-pattern.  *)
+  val deconstruct : Simple.pattern -> t * pattern list
+
+  (** reconstructs a pattern, putting wildcards as sub-patterns. *)
+  val to_omega_pattern : t -> pattern
+
+  val omega : t
+
+end
diff --git a/upstream/ocaml_413/typing/persistent_env.ml b/upstream/ocaml_413/typing/persistent_env.ml
new file mode 100644
index 0000000..65f6066
--- /dev/null
+++ b/upstream/ocaml_413/typing/persistent_env.ml
@@ -0,0 +1,373 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Xavier Leroy, projet Gallium, INRIA Rocquencourt                     *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*                                                                        *)
+(*   Copyright 2019 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Persistent structure descriptions *)
+
+open Misc
+open Cmi_format
+
+module Consistbl = Consistbl.Make (Misc.Stdlib.String)
+
+let add_delayed_check_forward = ref (fun _ -> assert false)
+
+type error =
+  | Illegal_renaming of modname * modname * filepath
+  | Inconsistent_import of modname * filepath * filepath
+  | Need_recursive_types of modname
+  | Depend_on_unsafe_string_unit of modname
+
+exception Error of error
+let error err = raise (Error err)
+
+module Persistent_signature = struct
+  type t =
+    { filename : string;
+      cmi : Cmi_format.cmi_infos }
+
+  let load = ref (fun ~unit_name ->
+      match Load_path.find_uncap (unit_name ^ ".cmi") with
+      | filename -> Some { filename; cmi = read_cmi filename }
+      | exception Not_found -> None)
+end
+
+type can_load_cmis =
+  | Can_load_cmis
+  | Cannot_load_cmis of Lazy_backtrack.log
+
+type pers_struct = {
+  ps_name: string;
+  ps_crcs: (string * Digest.t option) list;
+  ps_filename: string;
+  ps_flags: pers_flags list;
+}
+
+module String = Misc.Stdlib.String
+
+(* If a .cmi file is missing (or invalid), we
+   store it as Missing in the cache. *)
+type 'a pers_struct_info =
+  | Missing
+  | Found of pers_struct * 'a
+
+type 'a t = {
+  persistent_structures : (string, 'a pers_struct_info) Hashtbl.t;
+  imported_units: String.Set.t ref;
+  imported_opaque_units: String.Set.t ref;
+  crc_units: Consistbl.t;
+  can_load_cmis: can_load_cmis ref;
+}
+
+let empty () = {
+  persistent_structures = Hashtbl.create 17;
+  imported_units = ref String.Set.empty;
+  imported_opaque_units = ref String.Set.empty;
+  crc_units = Consistbl.create ();
+  can_load_cmis = ref Can_load_cmis;
+}
+
+let clear penv =
+  let {
+    persistent_structures;
+    imported_units;
+    imported_opaque_units;
+    crc_units;
+    can_load_cmis;
+  } = penv in
+  Hashtbl.clear persistent_structures;
+  imported_units := String.Set.empty;
+  imported_opaque_units := String.Set.empty;
+  Consistbl.clear crc_units;
+  can_load_cmis := Can_load_cmis;
+  ()
+
+let clear_missing {persistent_structures; _} =
+  let missing_entries =
+    Hashtbl.fold
+      (fun name r acc -> if r = Missing then name :: acc else acc)
+      persistent_structures []
+  in
+  List.iter (Hashtbl.remove persistent_structures) missing_entries
+
+let add_import {imported_units; _} s =
+  imported_units := String.Set.add s !imported_units
+
+let register_import_as_opaque {imported_opaque_units; _} s =
+  imported_opaque_units := String.Set.add s !imported_opaque_units
+
+let find_in_cache {persistent_structures; _} s =
+  match Hashtbl.find persistent_structures s with
+  | exception Not_found -> None
+  | Missing -> None
+  | Found (_ps, pm) -> Some pm
+
+let import_crcs penv ~source crcs =
+  let {crc_units; _} = penv in
+  let import_crc (name, crco) =
+    match crco with
+    | None -> ()
+    | Some crc ->
+        add_import penv name;
+        Consistbl.check crc_units name crc source
+  in List.iter import_crc crcs
+
+let check_consistency penv ps =
+  try import_crcs penv ~source:ps.ps_filename ps.ps_crcs
+  with Consistbl.Inconsistency {
+      unit_name = name;
+      inconsistent_source = source;
+      original_source = auth;
+    } ->
+    error (Inconsistent_import(name, auth, source))
+
+let can_load_cmis penv =
+  !(penv.can_load_cmis)
+let set_can_load_cmis penv setting =
+  penv.can_load_cmis := setting
+
+let without_cmis penv f x =
+  let log = Lazy_backtrack.log () in
+  let res =
+    Misc.(protect_refs
+            [R (penv.can_load_cmis, Cannot_load_cmis log)]
+            (fun () -> f x))
+  in
+  Lazy_backtrack.backtrack log;
+  res
+
+let fold {persistent_structures; _} f x =
+  Hashtbl.fold (fun modname pso x -> match pso with
+      | Missing -> x
+      | Found (_, pm) -> f modname pm x)
+    persistent_structures x
+
+(* Reading persistent structures from .cmi files *)
+
+let save_pers_struct penv crc ps pm =
+  let {persistent_structures; crc_units; _} = penv in
+  let modname = ps.ps_name in
+  Hashtbl.add persistent_structures modname (Found (ps, pm));
+  List.iter
+    (function
+        | Rectypes -> ()
+        | Alerts _ -> ()
+        | Unsafe_string -> ()
+        | Opaque -> register_import_as_opaque penv modname)
+    ps.ps_flags;
+  Consistbl.set crc_units modname crc ps.ps_filename;
+  add_import penv modname
+
+let acknowledge_pers_struct penv check modname pers_sig pm =
+  let { Persistent_signature.filename; cmi } = pers_sig in
+  let name = cmi.cmi_name in
+  let crcs = cmi.cmi_crcs in
+  let flags = cmi.cmi_flags in
+  let ps = { ps_name = name;
+             ps_crcs = crcs;
+             ps_filename = filename;
+             ps_flags = flags;
+           } in
+  if ps.ps_name <> modname then
+    error (Illegal_renaming(modname, ps.ps_name, filename));
+  List.iter
+    (function
+        | Rectypes ->
+            if not !Clflags.recursive_types then
+              error (Need_recursive_types(ps.ps_name))
+        | Unsafe_string ->
+            if Config.safe_string then
+              error (Depend_on_unsafe_string_unit(ps.ps_name));
+        | Alerts _ -> ()
+        | Opaque -> register_import_as_opaque penv modname)
+    ps.ps_flags;
+  if check then check_consistency penv ps;
+  let {persistent_structures; _} = penv in
+  Hashtbl.add persistent_structures modname (Found (ps, pm));
+  ps
+
+let read_pers_struct penv val_of_pers_sig check modname filename =
+  add_import penv modname;
+  let cmi = read_cmi filename in
+  let pers_sig = { Persistent_signature.filename; cmi } in
+  let pm = val_of_pers_sig pers_sig in
+  let ps = acknowledge_pers_struct penv check modname pers_sig pm in
+  (ps, pm)
+
+let find_pers_struct penv val_of_pers_sig check name =
+  let {persistent_structures; _} = penv in
+  if name = "*predef*" then raise Not_found;
+  match Hashtbl.find persistent_structures name with
+  | Found (ps, pm) -> (ps, pm)
+  | Missing -> raise Not_found
+  | exception Not_found ->
+    match can_load_cmis penv with
+    | Cannot_load_cmis _ -> raise Not_found
+    | Can_load_cmis ->
+        let psig =
+          match !Persistent_signature.load ~unit_name:name with
+          | Some psig -> psig
+          | None ->
+            Hashtbl.add persistent_structures name Missing;
+            raise Not_found
+        in
+        add_import penv name;
+        let pm = val_of_pers_sig psig in
+        let ps = acknowledge_pers_struct penv check name psig pm in
+        (ps, pm)
+
+(* Emits a warning if there is no valid cmi for name *)
+let check_pers_struct penv f ~loc name =
+  try
+    ignore (find_pers_struct penv f false name)
+  with
+  | Not_found ->
+      let warn = Warnings.No_cmi_file(name, None) in
+        Location.prerr_warning loc warn
+  | Cmi_format.Error err ->
+      let msg = Format.asprintf "%a" Cmi_format.report_error err in
+      let warn = Warnings.No_cmi_file(name, Some msg) in
+        Location.prerr_warning loc warn
+  | Error err ->
+      let msg =
+        match err with
+        | Illegal_renaming(name, ps_name, filename) ->
+            Format.asprintf
+              " %a@ contains the compiled interface for @ \
+               %s when %s was expected"
+              Location.print_filename filename ps_name name
+        | Inconsistent_import _ -> assert false
+        | Need_recursive_types name ->
+            Format.sprintf
+              "%s uses recursive types"
+              name
+        | Depend_on_unsafe_string_unit name ->
+            Printf.sprintf "%s uses -unsafe-string"
+              name
+      in
+      let warn = Warnings.No_cmi_file(name, Some msg) in
+        Location.prerr_warning loc warn
+
+let read penv f modname filename =
+  snd (read_pers_struct penv f true modname filename)
+
+let find penv f name =
+  snd (find_pers_struct penv f true name)
+
+let check penv f ~loc name =
+  let {persistent_structures; _} = penv in
+  if not (Hashtbl.mem persistent_structures name) then begin
+    (* PR#6843: record the weak dependency ([add_import]) regardless of
+       whether the check succeeds, to help make builds more
+       deterministic. *)
+    add_import penv name;
+    if (Warnings.is_active (Warnings.No_cmi_file("", None))) then
+      !add_delayed_check_forward
+        (fun () -> check_pers_struct penv f ~loc name)
+  end
+
+let crc_of_unit penv f name =
+  let (ps, _pm) = find_pers_struct penv f true name in
+  let crco =
+    try
+      List.assoc name ps.ps_crcs
+    with Not_found ->
+      assert false
+  in
+    match crco with
+      None -> assert false
+    | Some crc -> crc
+
+let imports {imported_units; crc_units; _} =
+  Consistbl.extract (String.Set.elements !imported_units) crc_units
+
+let looked_up {persistent_structures; _} modname =
+  Hashtbl.mem persistent_structures modname
+
+let is_imported {imported_units; _} s =
+  String.Set.mem s !imported_units
+
+let is_imported_opaque {imported_opaque_units; _} s =
+  String.Set.mem s !imported_opaque_units
+
+let make_cmi penv modname sign alerts =
+  let flags =
+    List.concat [
+      if !Clflags.recursive_types then [Cmi_format.Rectypes] else [];
+      if !Clflags.opaque then [Cmi_format.Opaque] else [];
+      (if !Clflags.unsafe_string then [Cmi_format.Unsafe_string] else []);
+      [Alerts alerts];
+    ]
+  in
+  let crcs = imports penv in
+  {
+    cmi_name = modname;
+    cmi_sign = sign;
+    cmi_crcs = crcs;
+    cmi_flags = flags
+  }
+
+let save_cmi penv psig pm =
+  let { Persistent_signature.filename; cmi } = psig in
+  Misc.try_finally (fun () ->
+      let {
+        cmi_name = modname;
+        cmi_sign = _;
+        cmi_crcs = imports;
+        cmi_flags = flags;
+      } = cmi in
+      let crc =
+        output_to_file_via_temporary (* see MPR#7472, MPR#4991 *)
+          ~mode: [Open_binary] filename
+          (fun temp_filename oc -> output_cmi temp_filename oc cmi) in
+      (* Enter signature in persistent table so that imports()
+         will also return its crc *)
+      let ps =
+        { ps_name = modname;
+          ps_crcs = (cmi.cmi_name, Some crc) :: imports;
+          ps_filename = filename;
+          ps_flags = flags;
+        } in
+      save_pers_struct penv crc ps pm
+    )
+    ~exceptionally:(fun () -> remove_file filename)
+
+let report_error ppf =
+  let open Format in
+  function
+  | Illegal_renaming(modname, ps_name, filename) -> fprintf ppf
+      "Wrong file naming: %a@ contains the compiled interface for@ \
+       %s when %s was expected"
+      Location.print_filename filename ps_name modname
+  | Inconsistent_import(name, source1, source2) -> fprintf ppf
+      "@[<hov>The files %a@ and %a@ \
+              make inconsistent assumptions@ over interface %s@]"
+      Location.print_filename source1 Location.print_filename source2 name
+  | Need_recursive_types(import) ->
+      fprintf ppf
+        "@[<hov>Invalid import of %s, which uses recursive types.@ %s@]"
+        import "The compilation flag -rectypes is required"
+  | Depend_on_unsafe_string_unit(import) ->
+      fprintf ppf
+        "@[<hov>Invalid import of %s, compiled with -unsafe-string.@ %s@]"
+        import "This compiler has been configured in strict \
+                                  safe-string mode (-force-safe-string)"
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err ->
+          Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )
diff --git a/upstream/ocaml_413/typing/persistent_env.mli b/upstream/ocaml_413/typing/persistent_env.mli
new file mode 100644
index 0000000..b2e1393
--- /dev/null
+++ b/upstream/ocaml_413/typing/persistent_env.mli
@@ -0,0 +1,105 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Xavier Leroy, projet Gallium, INRIA Rocquencourt                     *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*                                                                        *)
+(*   Copyright 2019 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Misc
+
+module Consistbl : module type of struct
+  include Consistbl.Make (Misc.Stdlib.String)
+end
+
+type error =
+  | Illegal_renaming of modname * modname * filepath
+  | Inconsistent_import of modname * filepath * filepath
+  | Need_recursive_types of modname
+  | Depend_on_unsafe_string_unit of modname
+
+exception Error of error
+
+val report_error: Format.formatter -> error -> unit
+
+module Persistent_signature : sig
+  type t =
+    { filename : string; (** Name of the file containing the signature. *)
+      cmi : Cmi_format.cmi_infos }
+
+  (** Function used to load a persistent signature. The default is to look for
+      the .cmi file in the load path. This function can be overridden to load
+      it from memory, for instance to build a self-contained toplevel. *)
+  val load : (unit_name:string -> t option) ref
+end
+
+type can_load_cmis =
+  | Can_load_cmis
+  | Cannot_load_cmis of Lazy_backtrack.log
+
+type 'a t
+
+val empty : unit -> 'a t
+
+val clear : 'a t -> unit
+val clear_missing : 'a t -> unit
+
+val fold : 'a t -> (modname -> 'a -> 'b -> 'b) -> 'b -> 'b
+
+val read : 'a t -> (Persistent_signature.t -> 'a)
+  -> modname -> filepath -> 'a
+val find : 'a t -> (Persistent_signature.t -> 'a)
+  -> modname -> 'a
+
+val find_in_cache : 'a t -> modname -> 'a option
+
+val check : 'a t -> (Persistent_signature.t -> 'a)
+  -> loc:Location.t -> modname -> unit
+
+(* [looked_up penv md] checks if one has already tried
+   to read the signature for [md] in the environment
+   [penv] (it may have failed) *)
+val looked_up : 'a t -> modname -> bool
+
+(* [is_imported penv md] checks if [md] has been successfully
+   imported in the environment [penv] *)
+val is_imported : 'a t -> modname -> bool
+
+(* [is_imported_opaque penv md] checks if [md] has been imported
+   in [penv] as an opaque module *)
+val is_imported_opaque : 'a t -> modname -> bool
+
+(* [register_import_as_opaque penv md] registers [md] in [penv] as an
+   opaque module *)
+val register_import_as_opaque : 'a t -> modname -> unit
+
+val make_cmi : 'a t -> modname -> Types.signature -> alerts
+  -> Cmi_format.cmi_infos
+
+val save_cmi : 'a t -> Persistent_signature.t -> 'a -> unit
+
+val can_load_cmis : 'a t -> can_load_cmis
+val set_can_load_cmis : 'a t -> can_load_cmis -> unit
+val without_cmis : 'a t -> ('b -> 'c) -> 'b -> 'c
+(* [without_cmis penv f arg] applies [f] to [arg], but does not
+    allow [penv] to openi cmis during its execution *)
+
+(* may raise Consistbl.Inconsistency *)
+val import_crcs : 'a t -> source:filepath -> crcs -> unit
+
+(* Return the set of compilation units imported, with their CRC *)
+val imports : 'a t -> crcs
+
+(* Return the CRC of the interface of the given compilation unit *)
+val crc_of_unit: 'a t -> (Persistent_signature.t -> 'a) -> modname -> Digest.t
+
+(* Forward declaration to break mutual recursion with Typecore. *)
+val add_delayed_check_forward: ((unit -> unit) -> unit) ref
diff --git a/upstream/ocaml_413/typing/predef.ml b/upstream/ocaml_413/typing/predef.ml
new file mode 100644
index 0000000..671df81
--- /dev/null
+++ b/upstream/ocaml_413/typing/predef.ml
@@ -0,0 +1,253 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Predefined type constructors (with special typing rules in typecore) *)
+
+open Path
+open Types
+open Btype
+
+let builtin_idents = ref []
+
+let wrap create s =
+  let id = create s in
+  builtin_idents := (s, id) :: !builtin_idents;
+  id
+
+let ident_create = wrap Ident.create_predef
+
+let ident_int = ident_create "int"
+and ident_char = ident_create "char"
+and ident_bytes = ident_create "bytes"
+and ident_float = ident_create "float"
+and ident_bool = ident_create "bool"
+and ident_unit = ident_create "unit"
+and ident_exn = ident_create "exn"
+and ident_array = ident_create "array"
+and ident_list = ident_create "list"
+and ident_option = ident_create "option"
+and ident_nativeint = ident_create "nativeint"
+and ident_int32 = ident_create "int32"
+and ident_int64 = ident_create "int64"
+and ident_lazy_t = ident_create "lazy_t"
+and ident_string = ident_create "string"
+and ident_extension_constructor = ident_create "extension_constructor"
+and ident_floatarray = ident_create "floatarray"
+
+let path_int = Pident ident_int
+and path_char = Pident ident_char
+and path_bytes = Pident ident_bytes
+and path_float = Pident ident_float
+and path_bool = Pident ident_bool
+and path_unit = Pident ident_unit
+and path_exn = Pident ident_exn
+and path_array = Pident ident_array
+and path_list = Pident ident_list
+and path_option = Pident ident_option
+and path_nativeint = Pident ident_nativeint
+and path_int32 = Pident ident_int32
+and path_int64 = Pident ident_int64
+and path_lazy_t = Pident ident_lazy_t
+and path_string = Pident ident_string
+and path_extension_constructor = Pident ident_extension_constructor
+and path_floatarray = Pident ident_floatarray
+
+let type_int = newgenty (Tconstr(path_int, [], ref Mnil))
+and type_char = newgenty (Tconstr(path_char, [], ref Mnil))
+and type_bytes = newgenty (Tconstr(path_bytes, [], ref Mnil))
+and type_float = newgenty (Tconstr(path_float, [], ref Mnil))
+and type_bool = newgenty (Tconstr(path_bool, [], ref Mnil))
+and type_unit = newgenty (Tconstr(path_unit, [], ref Mnil))
+and type_exn = newgenty (Tconstr(path_exn, [], ref Mnil))
+and type_array t = newgenty (Tconstr(path_array, [t], ref Mnil))
+and type_list t = newgenty (Tconstr(path_list, [t], ref Mnil))
+and type_option t = newgenty (Tconstr(path_option, [t], ref Mnil))
+and type_nativeint = newgenty (Tconstr(path_nativeint, [], ref Mnil))
+and type_int32 = newgenty (Tconstr(path_int32, [], ref Mnil))
+and type_int64 = newgenty (Tconstr(path_int64, [], ref Mnil))
+and type_lazy_t t = newgenty (Tconstr(path_lazy_t, [t], ref Mnil))
+and type_string = newgenty (Tconstr(path_string, [], ref Mnil))
+and type_extension_constructor =
+      newgenty (Tconstr(path_extension_constructor, [], ref Mnil))
+and type_floatarray = newgenty (Tconstr(path_floatarray, [], ref Mnil))
+
+let ident_match_failure = ident_create "Match_failure"
+and ident_out_of_memory = ident_create "Out_of_memory"
+and ident_invalid_argument = ident_create "Invalid_argument"
+and ident_failure = ident_create "Failure"
+and ident_not_found = ident_create "Not_found"
+and ident_sys_error = ident_create "Sys_error"
+and ident_end_of_file = ident_create "End_of_file"
+and ident_division_by_zero = ident_create "Division_by_zero"
+and ident_stack_overflow = ident_create "Stack_overflow"
+and ident_sys_blocked_io = ident_create "Sys_blocked_io"
+and ident_assert_failure = ident_create "Assert_failure"
+and ident_undefined_recursive_module =
+        ident_create "Undefined_recursive_module"
+
+let all_predef_exns = [
+  ident_match_failure;
+  ident_out_of_memory;
+  ident_invalid_argument;
+  ident_failure;
+  ident_not_found;
+  ident_sys_error;
+  ident_end_of_file;
+  ident_division_by_zero;
+  ident_stack_overflow;
+  ident_sys_blocked_io;
+  ident_assert_failure;
+  ident_undefined_recursive_module;
+]
+
+let path_match_failure = Pident ident_match_failure
+and path_assert_failure = Pident ident_assert_failure
+and path_undefined_recursive_module = Pident ident_undefined_recursive_module
+
+let cstr id args =
+  {
+    cd_id = id;
+    cd_args = Cstr_tuple args;
+    cd_res = None;
+    cd_loc = Location.none;
+    cd_attributes = [];
+    cd_uid = Uid.of_predef_id id;
+  }
+
+let ident_false = ident_create "false"
+and ident_true = ident_create "true"
+and ident_void = ident_create "()"
+and ident_nil = ident_create "[]"
+and ident_cons = ident_create "::"
+and ident_none = ident_create "None"
+and ident_some = ident_create "Some"
+
+let mk_add_type add_type type_ident
+      ?manifest ?(immediate=Type_immediacy.Unknown) ?(kind=Type_abstract) env =
+  let decl =
+    {type_params = [];
+     type_arity = 0;
+     type_kind = kind;
+     type_loc = Location.none;
+     type_private = Asttypes.Public;
+     type_manifest = manifest;
+     type_variance = [];
+     type_separability = [];
+     type_is_newtype = false;
+     type_expansion_scope = lowest_level;
+     type_attributes = [];
+     type_immediate = immediate;
+     type_unboxed_default = false;
+     type_uid = Uid.of_predef_id type_ident;
+    }
+  in
+  add_type type_ident decl env
+
+let common_initial_env add_type add_extension empty_env =
+  let add_type = mk_add_type add_type
+  and add_type1 type_ident
+      ~variance ~separability ?(kind=fun _ -> Type_abstract) env =
+    let param = newgenvar () in
+    let decl =
+      {type_params = [param];
+       type_arity = 1;
+       type_kind = kind param;
+       type_loc = Location.none;
+       type_private = Asttypes.Public;
+       type_manifest = None;
+       type_variance = [variance];
+       type_separability = [separability];
+       type_is_newtype = false;
+       type_expansion_scope = lowest_level;
+       type_attributes = [];
+       type_immediate = Unknown;
+       type_unboxed_default = false;
+       type_uid = Uid.of_predef_id type_ident;
+      }
+    in
+    add_type type_ident decl env
+  in
+  let add_extension id l =
+    add_extension id
+      { ext_type_path = path_exn;
+        ext_type_params = [];
+        ext_args = Cstr_tuple l;
+        ext_ret_type = None;
+        ext_private = Asttypes.Public;
+        ext_loc = Location.none;
+        ext_attributes = [Ast_helper.Attr.mk
+                            (Location.mknoloc "ocaml.warn_on_literal_pattern")
+                            (Parsetree.PStr [])];
+        ext_uid = Uid.of_predef_id id;
+      }
+  in
+  add_extension ident_match_failure
+                         [newgenty (Ttuple[type_string; type_int; type_int])] (
+  add_extension ident_out_of_memory [] (
+  add_extension ident_stack_overflow [] (
+  add_extension ident_invalid_argument [type_string] (
+  add_extension ident_failure [type_string] (
+  add_extension ident_not_found [] (
+  add_extension ident_sys_blocked_io [] (
+  add_extension ident_sys_error [type_string] (
+  add_extension ident_end_of_file [] (
+  add_extension ident_division_by_zero [] (
+  add_extension ident_assert_failure
+                         [newgenty (Ttuple[type_string; type_int; type_int])] (
+  add_extension ident_undefined_recursive_module
+                         [newgenty (Ttuple[type_string; type_int; type_int])] (
+  add_type ident_int64 (
+  add_type ident_int32 (
+  add_type ident_nativeint (
+  add_type1 ident_lazy_t ~variance:Variance.covariant
+    ~separability:Separability.Ind (
+  add_type1 ident_option ~variance:Variance.covariant
+    ~separability:Separability.Ind
+    ~kind:(fun tvar ->
+      Type_variant([cstr ident_none []; cstr ident_some [tvar]],
+                   Variant_regular)
+    ) (
+  add_type1 ident_list ~variance:Variance.covariant
+    ~separability:Separability.Ind
+    ~kind:(fun tvar ->
+      Type_variant([cstr ident_nil []; cstr ident_cons [tvar; type_list tvar]],
+                   Variant_regular)
+    ) (
+  add_type1 ident_array ~variance:Variance.full ~separability:Separability.Ind (
+  add_type ident_exn ~kind:Type_open (
+  add_type ident_unit ~immediate:Always
+    ~kind:(Type_variant([cstr ident_void []], Variant_regular)) (
+  add_type ident_bool ~immediate:Always
+    ~kind:(Type_variant([cstr ident_false []; cstr ident_true []],
+                        Variant_regular)) (
+  add_type ident_float (
+  add_type ident_string (
+  add_type ident_char ~immediate:Always (
+  add_type ident_int ~immediate:Always (
+  add_type ident_extension_constructor (
+  add_type ident_floatarray (
+    empty_env))))))))))))))))))))))))))))
+
+let build_initial_env add_type add_exception empty_env =
+  let common = common_initial_env add_type add_exception empty_env in
+  let add_type = mk_add_type add_type in
+  let safe_string = add_type ident_bytes common in
+  let unsafe_string = add_type ident_bytes ~manifest:type_string common in
+  (safe_string, unsafe_string)
+
+let builtin_values =
+  List.map (fun id -> (Ident.name id, id)) all_predef_exns
+
+let builtin_idents = List.rev !builtin_idents
diff --git a/upstream/ocaml_413/typing/predef.mli b/upstream/ocaml_413/typing/predef.mli
new file mode 100644
index 0000000..962a276
--- /dev/null
+++ b/upstream/ocaml_413/typing/predef.mli
@@ -0,0 +1,87 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Predefined type constructors (with special typing rules in typecore) *)
+
+open Types
+
+val type_int: type_expr
+val type_char: type_expr
+val type_string: type_expr
+val type_bytes: type_expr
+val type_float: type_expr
+val type_bool: type_expr
+val type_unit: type_expr
+val type_exn: type_expr
+val type_array: type_expr -> type_expr
+val type_list: type_expr -> type_expr
+val type_option: type_expr -> type_expr
+val type_nativeint: type_expr
+val type_int32: type_expr
+val type_int64: type_expr
+val type_lazy_t: type_expr -> type_expr
+val type_extension_constructor:type_expr
+val type_floatarray:type_expr
+
+val path_int: Path.t
+val path_char: Path.t
+val path_string: Path.t
+val path_bytes: Path.t
+val path_float: Path.t
+val path_bool: Path.t
+val path_unit: Path.t
+val path_exn: Path.t
+val path_array: Path.t
+val path_list: Path.t
+val path_option: Path.t
+val path_nativeint: Path.t
+val path_int32: Path.t
+val path_int64: Path.t
+val path_lazy_t: Path.t
+val path_extension_constructor: Path.t
+val path_floatarray: Path.t
+
+val path_match_failure: Path.t
+val path_assert_failure : Path.t
+val path_undefined_recursive_module : Path.t
+
+val ident_false : Ident.t
+val ident_true : Ident.t
+val ident_void : Ident.t
+val ident_nil : Ident.t
+val ident_cons : Ident.t
+val ident_none : Ident.t
+val ident_some : Ident.t
+
+(* To build the initial environment. Since there is a nasty mutual
+   recursion between predef and env, we break it by parameterizing
+   over Env.t, Env.add_type and Env.add_extension. *)
+
+val build_initial_env:
+  (Ident.t -> type_declaration -> 'a -> 'a) ->
+  (Ident.t -> extension_constructor -> 'a -> 'a) ->
+  'a -> 'a * 'a
+
+(* To initialize linker tables *)
+
+val builtin_values: (string * Ident.t) list
+val builtin_idents: (string * Ident.t) list
+
+(** All predefined exceptions, exposed as [Ident.t] for flambda (for
+    building value approximations).
+    The [Ident.t] for division by zero is also exported explicitly
+    so flambda can generate code to raise it. *)
+val ident_division_by_zero: Ident.t
+val all_predef_exns : Ident.t list
diff --git a/upstream/ocaml_413/typing/primitive.ml b/upstream/ocaml_413/typing/primitive.ml
new file mode 100644
index 0000000..bf4fe83
--- /dev/null
+++ b/upstream/ocaml_413/typing/primitive.ml
@@ -0,0 +1,251 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Description of primitive functions *)
+
+open Misc
+open Parsetree
+
+type boxed_integer = Pnativeint | Pint32 | Pint64
+
+type native_repr =
+  | Same_as_ocaml_repr
+  | Unboxed_float
+  | Unboxed_integer of boxed_integer
+  | Untagged_int
+
+type description =
+  { prim_name: string;         (* Name of primitive  or C function *)
+    prim_arity: int;           (* Number of arguments *)
+    prim_alloc: bool;          (* Does it allocates or raise? *)
+    prim_native_name: string;  (* Name of C function for the nat. code gen. *)
+    prim_native_repr_args: native_repr list;
+    prim_native_repr_res: native_repr }
+
+type error =
+  | Old_style_float_with_native_repr_attribute
+  | Old_style_noalloc_with_noalloc_attribute
+  | No_native_primitive_with_repr_attribute
+
+exception Error of Location.t * error
+
+let is_ocaml_repr = function
+  | Same_as_ocaml_repr -> true
+  | Unboxed_float
+  | Unboxed_integer _
+  | Untagged_int -> false
+
+let is_unboxed = function
+  | Same_as_ocaml_repr
+  | Untagged_int -> false
+  | Unboxed_float
+  | Unboxed_integer _ -> true
+
+let is_untagged = function
+  | Untagged_int -> true
+  | Same_as_ocaml_repr
+  | Unboxed_float
+  | Unboxed_integer _ -> false
+
+let rec make_native_repr_args arity x =
+  if arity = 0 then
+    []
+  else
+    x :: make_native_repr_args (arity - 1) x
+
+let simple ~name ~arity ~alloc =
+  {prim_name = name;
+   prim_arity = arity;
+   prim_alloc = alloc;
+   prim_native_name = "";
+   prim_native_repr_args = make_native_repr_args arity Same_as_ocaml_repr;
+   prim_native_repr_res = Same_as_ocaml_repr}
+
+let make ~name ~alloc ~native_name ~native_repr_args ~native_repr_res =
+  {prim_name = name;
+   prim_arity = List.length native_repr_args;
+   prim_alloc = alloc;
+   prim_native_name = native_name;
+   prim_native_repr_args = native_repr_args;
+   prim_native_repr_res = native_repr_res}
+
+let parse_declaration valdecl ~native_repr_args ~native_repr_res =
+  let arity = List.length native_repr_args in
+  let name, native_name, old_style_noalloc, old_style_float =
+    match valdecl.pval_prim with
+    | name :: "noalloc" :: name2 :: "float" :: _ -> (name, name2, true, true)
+    | name :: "noalloc" :: name2 :: _ -> (name, name2, true, false)
+    | name :: name2 :: "float" :: _ -> (name, name2, false, true)
+    | name :: "noalloc" :: _ -> (name, "", true, false)
+    | name :: name2 :: _ -> (name, name2, false, false)
+    | name :: _ -> (name, "", false, false)
+    | [] ->
+        fatal_error "Primitive.parse_declaration"
+  in
+  let noalloc_attribute =
+    Attr_helper.has_no_payload_attribute ["noalloc"; "ocaml.noalloc"]
+      valdecl.pval_attributes
+  in
+  if old_style_float &&
+     not (List.for_all is_ocaml_repr native_repr_args &&
+          is_ocaml_repr native_repr_res) then
+    raise (Error (valdecl.pval_loc,
+                  Old_style_float_with_native_repr_attribute));
+  if old_style_noalloc && noalloc_attribute then
+    raise (Error (valdecl.pval_loc,
+                  Old_style_noalloc_with_noalloc_attribute));
+  (* The compiler used to assume "noalloc" with "float", we just make this
+     explicit now (GPR#167): *)
+  let old_style_noalloc = old_style_noalloc || old_style_float in
+  if old_style_float then
+    Location.deprecated valdecl.pval_loc
+      "[@@unboxed] + [@@noalloc] should be used\n\
+       instead of \"float\""
+  else if old_style_noalloc then
+    Location.deprecated valdecl.pval_loc
+      "[@@noalloc] should be used instead of \"noalloc\"";
+  if native_name = "" &&
+     not (List.for_all is_ocaml_repr native_repr_args &&
+          is_ocaml_repr native_repr_res) then
+    raise (Error (valdecl.pval_loc,
+                  No_native_primitive_with_repr_attribute));
+  let noalloc = old_style_noalloc || noalloc_attribute in
+  let native_repr_args, native_repr_res =
+    if old_style_float then
+      (make_native_repr_args arity Unboxed_float, Unboxed_float)
+    else
+      (native_repr_args, native_repr_res)
+  in
+  {prim_name = name;
+   prim_arity = arity;
+   prim_alloc = not noalloc;
+   prim_native_name = native_name;
+   prim_native_repr_args = native_repr_args;
+   prim_native_repr_res = native_repr_res}
+
+open Outcometree
+
+let rec add_native_repr_attributes ty attrs =
+  match ty, attrs with
+  | Otyp_arrow (label, a, b), attr_opt :: rest ->
+    let b = add_native_repr_attributes b rest in
+    let a =
+      match attr_opt with
+      | None -> a
+      | Some attr -> Otyp_attribute (a, attr)
+    in
+    Otyp_arrow (label, a, b)
+  | _, [Some attr] -> Otyp_attribute (ty, attr)
+  | _ ->
+    assert (List.for_all (fun x -> x = None) attrs);
+    ty
+
+let oattr_unboxed = { oattr_name = "unboxed" }
+let oattr_untagged = { oattr_name = "untagged" }
+let oattr_noalloc = { oattr_name = "noalloc" }
+
+let print p osig_val_decl =
+  let prims =
+    if p.prim_native_name <> "" then
+      [p.prim_name; p.prim_native_name]
+    else
+      [p.prim_name]
+  in
+  let for_all f =
+    List.for_all f p.prim_native_repr_args && f p.prim_native_repr_res
+  in
+  let all_unboxed = for_all is_unboxed in
+  let all_untagged = for_all is_untagged in
+  let attrs = if p.prim_alloc then [] else [oattr_noalloc] in
+  let attrs =
+    if all_unboxed then
+      oattr_unboxed :: attrs
+    else if all_untagged then
+      oattr_untagged :: attrs
+    else
+      attrs
+  in
+  let attr_of_native_repr = function
+    | Same_as_ocaml_repr -> None
+    | Unboxed_float
+    | Unboxed_integer _ -> if all_unboxed then None else Some oattr_unboxed
+    | Untagged_int -> if all_untagged then None else Some oattr_untagged
+  in
+  let type_attrs =
+    List.map attr_of_native_repr p.prim_native_repr_args @
+    [attr_of_native_repr p.prim_native_repr_res]
+  in
+  { osig_val_decl with
+    oval_prims = prims;
+    oval_type = add_native_repr_attributes osig_val_decl.oval_type type_attrs;
+    oval_attributes = attrs }
+
+let native_name p =
+  if p.prim_native_name <> ""
+  then p.prim_native_name
+  else p.prim_name
+
+let byte_name p =
+  p.prim_name
+
+let equal_boxed_integer bi1 bi2 =
+  match bi1, bi2 with
+  | Pnativeint, Pnativeint
+  | Pint32, Pint32
+  | Pint64, Pint64 ->
+    true
+  | (Pnativeint | Pint32 | Pint64), _ ->
+    false
+
+let equal_native_repr nr1 nr2 =
+  match nr1, nr2 with
+  | Same_as_ocaml_repr, Same_as_ocaml_repr -> true
+  | Same_as_ocaml_repr,
+    (Unboxed_float | Unboxed_integer _ | Untagged_int) -> false
+  | Unboxed_float, Unboxed_float -> true
+  | Unboxed_float,
+    (Same_as_ocaml_repr | Unboxed_integer _ | Untagged_int) -> false
+  | Unboxed_integer bi1, Unboxed_integer bi2 -> equal_boxed_integer bi1 bi2
+  | Unboxed_integer _,
+    (Same_as_ocaml_repr | Unboxed_float | Untagged_int) -> false
+  | Untagged_int, Untagged_int -> true
+  | Untagged_int,
+    (Same_as_ocaml_repr | Unboxed_float | Unboxed_integer _) -> false
+
+let native_name_is_external p =
+  let nat_name = native_name p in
+  nat_name <> "" && nat_name.[0] <> '%'
+
+let report_error ppf err =
+  match err with
+  | Old_style_float_with_native_repr_attribute ->
+    Format.fprintf ppf "Cannot use \"float\" in conjunction with \
+                        [%@unboxed]/[%@untagged]."
+  | Old_style_noalloc_with_noalloc_attribute ->
+    Format.fprintf ppf "Cannot use \"noalloc\" in conjunction with \
+                        [%@%@noalloc]."
+  | No_native_primitive_with_repr_attribute ->
+    Format.fprintf ppf
+      "[@The native code version of the primitive is mandatory@ \
+       when attributes [%@untagged] or [%@unboxed] are present.@]"
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, err) ->
+        Some (Location.error_of_printer ~loc report_error err)
+      | _ ->
+        None
+    )
diff --git a/upstream/ocaml_413/typing/primitive.mli b/upstream/ocaml_413/typing/primitive.mli
new file mode 100644
index 0000000..e8376ad
--- /dev/null
+++ b/upstream/ocaml_413/typing/primitive.mli
@@ -0,0 +1,79 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Description of primitive functions *)
+
+type boxed_integer = Pnativeint | Pint32 | Pint64
+
+(* Representation of arguments/result for the native code version
+   of a primitive *)
+type native_repr =
+  | Same_as_ocaml_repr
+  | Unboxed_float
+  | Unboxed_integer of boxed_integer
+  | Untagged_int
+
+type description = private
+  { prim_name: string;         (* Name of primitive  or C function *)
+    prim_arity: int;           (* Number of arguments *)
+    prim_alloc: bool;          (* Does it allocates or raise? *)
+    prim_native_name: string;  (* Name of C function for the nat. code gen. *)
+    prim_native_repr_args: native_repr list;
+    prim_native_repr_res: native_repr }
+
+(* Invariant [List.length d.prim_native_repr_args = d.prim_arity] *)
+
+val simple
+  :  name:string
+  -> arity:int
+  -> alloc:bool
+  -> description
+
+val make
+  :  name:string
+  -> alloc:bool
+  -> native_name:string
+  -> native_repr_args: native_repr list
+  -> native_repr_res: native_repr
+  -> description
+
+val parse_declaration
+  :  Parsetree.value_description
+  -> native_repr_args:native_repr list
+  -> native_repr_res:native_repr
+  -> description
+
+val print
+  :  description
+  -> Outcometree.out_val_decl
+  -> Outcometree.out_val_decl
+
+val native_name: description -> string
+val byte_name: description -> string
+
+val equal_boxed_integer : boxed_integer -> boxed_integer -> bool
+val equal_native_repr : native_repr -> native_repr -> bool
+
+(** [native_name_is_externa] returns [true] iff the [native_name] for the
+    given primitive identifies that the primitive is not implemented in the
+    compiler itself. *)
+val native_name_is_external : description -> bool
+
+type error =
+  | Old_style_float_with_native_repr_attribute
+  | Old_style_noalloc_with_noalloc_attribute
+  | No_native_primitive_with_repr_attribute
+
+exception Error of Location.t * error
diff --git a/upstream/ocaml_413/typing/printpat.ml b/upstream/ocaml_413/typing/printpat.ml
new file mode 100644
index 0000000..64094b6
--- /dev/null
+++ b/upstream/ocaml_413/typing/printpat.ml
@@ -0,0 +1,169 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Values as patterns pretty printer *)
+
+open Asttypes
+open Typedtree
+open Types
+open Format
+
+let is_cons = function
+| {cstr_name = "::"} -> true
+| _ -> false
+
+let pretty_const c = match c with
+| Const_int i -> Printf.sprintf "%d" i
+| Const_char c -> Printf.sprintf "%C" c
+| Const_string (s, _, _) -> Printf.sprintf "%S" s
+| Const_float f -> Printf.sprintf "%s" f
+| Const_int32 i -> Printf.sprintf "%ldl" i
+| Const_int64 i -> Printf.sprintf "%LdL" i
+| Const_nativeint i -> Printf.sprintf "%ndn" i
+
+let pretty_extra ppf (cstr, _loc, _attrs) pretty_rest rest =
+  match cstr with
+  | Tpat_unpack ->
+     fprintf ppf "@[(module %a)@]" pretty_rest rest
+  | Tpat_constraint _ ->
+     fprintf ppf "@[(%a : _)@]" pretty_rest rest
+  | Tpat_type _ ->
+     fprintf ppf "@[(# %a)@]" pretty_rest rest
+  | Tpat_open _ ->
+     fprintf ppf "@[(# %a)@]" pretty_rest rest
+
+let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v ->
+  match v.pat_extra with
+    | extra :: rem ->
+       pretty_extra ppf extra
+         pretty_val { v with pat_extra = rem }
+    | [] ->
+  match v.pat_desc with
+  | Tpat_any -> fprintf ppf "_"
+  | Tpat_var (x,_) -> fprintf ppf "%s" (Ident.name x)
+  | Tpat_constant c -> fprintf ppf "%s" (pretty_const c)
+  | Tpat_tuple vs ->
+      fprintf ppf "@[(%a)@]" (pretty_vals ",") vs
+  | Tpat_construct (_, cstr, [], _) ->
+      fprintf ppf "%s" cstr.cstr_name
+  | Tpat_construct (_, cstr, [w], None) ->
+      fprintf ppf "@[<2>%s@ %a@]" cstr.cstr_name pretty_arg w
+  | Tpat_construct (_, cstr, vs, vto) ->
+      let name = cstr.cstr_name in
+      begin match (name, vs, vto) with
+        ("::", [v1;v2], None) ->
+          fprintf ppf "@[%a::@,%a@]" pretty_car v1 pretty_cdr v2
+      | (_, _, None) ->
+          fprintf ppf "@[<2>%s@ @[(%a)@]@]" name (pretty_vals ",") vs
+      | (_, _, Some ([], _t)) ->
+          fprintf ppf "@[<2>%s@ @[(%a : _)@]@]" name (pretty_vals ",") vs
+      | (_, _, Some (vl, _t)) ->
+          let vars = List.map (fun x -> Ident.name x.txt) vl in
+          fprintf ppf "@[<2>%s@ (type %s)@ @[(%a : _)@]@]"
+            name (String.concat " " vars) (pretty_vals ",") vs
+      end
+  | Tpat_variant (l, None, _) ->
+      fprintf ppf "`%s" l
+  | Tpat_variant (l, Some w, _) ->
+      fprintf ppf "@[<2>`%s@ %a@]" l pretty_arg w
+  | Tpat_record (lvs,_) ->
+      let filtered_lvs = List.filter
+          (function
+            | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
+            | _ -> true) lvs in
+      begin match filtered_lvs with
+      | [] -> fprintf ppf "_"
+      | (_, lbl, _) :: q ->
+          let elision_mark ppf =
+            (* we assume that there is no label repetitions here *)
+             if Array.length lbl.lbl_all > 1 + List.length q then
+               fprintf ppf ";@ _@ "
+             else () in
+          fprintf ppf "@[{%a%t}@]"
+            pretty_lvals filtered_lvs elision_mark
+      end
+  | Tpat_array vs ->
+      fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
+  | Tpat_lazy v ->
+      fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v
+  | Tpat_alias (v, x,_) ->
+      fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x
+  | Tpat_value v ->
+      fprintf ppf "%a" pretty_val (v :> pattern)
+  | Tpat_exception v ->
+      fprintf ppf "@[<2>exception@ %a@]" pretty_arg v
+  | Tpat_or _ ->
+      fprintf ppf "@[(%a)@]" pretty_or v
+
+and pretty_car ppf v = match v.pat_desc with
+| Tpat_construct (_,cstr, [_ ; _], None)
+    when is_cons cstr ->
+      fprintf ppf "(%a)" pretty_val v
+| _ -> pretty_val ppf v
+
+and pretty_cdr ppf v = match v.pat_desc with
+| Tpat_construct (_,cstr, [v1 ; v2], None)
+    when is_cons cstr ->
+      fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2
+| _ -> pretty_val ppf v
+
+and pretty_arg ppf v = match v.pat_desc with
+| Tpat_construct (_,_,_::_,None)
+| Tpat_variant (_, Some _, _) -> fprintf ppf "(%a)" pretty_val v
+|  _ -> pretty_val ppf v
+
+and pretty_or : type k . _ -> k general_pattern -> _ = fun ppf v ->
+  match v.pat_desc with
+  | Tpat_or (v,w,_) ->
+      fprintf ppf "%a|@,%a" pretty_or v pretty_or w
+  | _ -> pretty_val ppf v
+
+and pretty_vals sep ppf = function
+  | [] -> ()
+  | [v] -> pretty_val ppf v
+  | v::vs ->
+      fprintf ppf "%a%s@ %a" pretty_val v sep (pretty_vals sep) vs
+
+and pretty_lvals ppf = function
+  | [] -> ()
+  | [_,lbl,v] ->
+      fprintf ppf "%s=%a" lbl.lbl_name pretty_val v
+  | (_, lbl,v)::rest ->
+      fprintf ppf "%s=%a;@ %a"
+        lbl.lbl_name pretty_val v pretty_lvals rest
+
+let top_pretty ppf v =
+  fprintf ppf "@[%a@]@?" pretty_val v
+
+let pretty_pat p =
+  top_pretty Format.str_formatter p ;
+  prerr_string (Format.flush_str_formatter ())
+
+type 'k matrix = 'k general_pattern list list
+
+let pretty_line fmt =
+  List.iter (fun p ->
+    Format.fprintf fmt " <";
+    top_pretty fmt p;
+    Format.fprintf fmt ">";
+  )
+
+let pretty_matrix fmt (pss : 'k matrix) =
+  Format.fprintf fmt "begin matrix\n" ;
+  List.iter (fun ps ->
+    pretty_line fmt ps ;
+    Format.fprintf fmt "\n"
+  ) pss;
+  Format.fprintf fmt "end matrix\n%!"
diff --git a/upstream/ocaml_413/typing/printpat.mli b/upstream/ocaml_413/typing/printpat.mli
new file mode 100644
index 0000000..1865a2a
--- /dev/null
+++ b/upstream/ocaml_413/typing/printpat.mli
@@ -0,0 +1,27 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+
+
+val pretty_const
+    : Asttypes.constant -> string
+val top_pretty
+    : Format.formatter -> 'k Typedtree.general_pattern -> unit
+val pretty_pat
+    : 'k Typedtree.general_pattern -> unit
+val pretty_line
+    : Format.formatter -> 'k Typedtree.general_pattern list -> unit
+val pretty_matrix
+    : Format.formatter -> 'k Typedtree.general_pattern list list -> unit
diff --git a/upstream/ocaml_413/typing/printtyp.ml b/upstream/ocaml_413/typing/printtyp.ml
new file mode 100644
index 0000000..dd7d8aa
--- /dev/null
+++ b/upstream/ocaml_413/typing/printtyp.ml
@@ -0,0 +1,2373 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Printing functions *)
+
+open Misc
+open Ctype
+open Format
+open Longident
+open Path
+open Asttypes
+open Types
+open Btype
+open Outcometree
+
+module String = Misc.Stdlib.String
+
+(* Print a long identifier *)
+
+let rec longident ppf = function
+  | Lident s -> pp_print_string ppf s
+  | Ldot(p, s) -> fprintf ppf "%a.%s" longident p s
+  | Lapply(p1, p2) -> fprintf ppf "%a(%a)" longident p1 longident p2
+
+let () = Env.print_longident := longident
+
+(* Print an identifier avoiding name collisions *)
+
+module Out_name = struct
+  let create x = { printed_name = x }
+  let print x = x.printed_name
+  let set out_name x = out_name.printed_name <- x
+end
+
+(** Some identifiers may require hiding when printing *)
+type bound_ident = { hide:bool; ident:Ident.t }
+
+(* printing environment for path shortening and naming *)
+let printing_env = ref Env.empty
+
+(* When printing, it is important to only observe the
+   current printing environment, without reading any new
+   cmi present on the file system *)
+let in_printing_env f = Env.without_cmis f !printing_env
+
+let human_unique n id = Printf.sprintf "%s/%d" (Ident.name id) n
+
+type namespace =
+  | Type
+  | Module
+  | Module_type
+  | Class
+  | Class_type
+  | Other (** Other bypasses the unique name identifier mechanism *)
+
+module Namespace = struct
+
+  let id = function
+    | Type -> 0
+    | Module -> 1
+    | Module_type -> 2
+    | Class -> 3
+    | Class_type -> 4
+    | Other -> 5
+
+  let size = 1 + id Other
+
+  let show =
+    function
+    | Type -> "type"
+    | Module -> "module"
+    | Module_type -> "module type"
+    | Class -> "class"
+    | Class_type -> "class type"
+    | Other -> ""
+
+  let pp ppf x = Format.pp_print_string ppf (show x)
+
+  (** The two functions below should never access the filesystem,
+      and thus use {!in_printing_env} rather than directly
+      accessing the printing environment *)
+  let lookup =
+    let to_lookup f lid = fst @@ in_printing_env (f (Lident lid)) in
+    function
+    | Type -> to_lookup Env.find_type_by_name
+    | Module -> to_lookup Env.find_module_by_name
+    | Module_type -> to_lookup Env.find_modtype_by_name
+    | Class -> to_lookup Env.find_class_by_name
+    | Class_type -> to_lookup Env.find_cltype_by_name
+    | Other -> fun _ -> raise Not_found
+
+  let location namespace id =
+    let path = Path.Pident id in
+    try Some (
+        match namespace with
+        | Type -> (in_printing_env @@ Env.find_type path).type_loc
+        | Module -> (in_printing_env @@ Env.find_module path).md_loc
+        | Module_type -> (in_printing_env @@ Env.find_modtype path).mtd_loc
+        | Class -> (in_printing_env @@ Env.find_class path).cty_loc
+        | Class_type -> (in_printing_env @@ Env.find_cltype path).clty_loc
+        | Other -> Location.none
+      ) with Not_found -> None
+
+  let best_class_namespace = function
+    | Papply _ | Pdot _ -> Module
+    | Pident c ->
+        match location Class c with
+        | Some _ -> Class
+        | None -> Class_type
+
+end
+
+(** {2 Conflicts printing}
+    Conflicts arise when multiple items are attributed the same name,
+    the following module stores the global conflict references and
+    provides the printing functions for explaining the source of
+    the conflicts.
+*)
+module Conflicts = struct
+  module M = String.Map
+  type explanation =
+    { kind: namespace; name:string; root_name:string; location:Location.t}
+  let explanations = ref M.empty
+  let collect_explanation namespace n id =
+    let name = human_unique n id in
+    let root_name = Ident.name id in
+    if not (M.mem name !explanations) then
+      match Namespace.location namespace id with
+      | None -> ()
+      | Some location ->
+          let explanation = { kind = namespace; location; name; root_name } in
+          explanations := M.add name explanation !explanations
+
+  let pp_explanation ppf r=
+    Format.fprintf ppf "@[<v 2>%a:@,Definition of %s %s@]"
+      Location.print_loc r.location (Namespace.show r.kind) r.name
+
+  let print_located_explanations ppf l =
+    Format.fprintf ppf "@[<v>%a@]" (Format.pp_print_list pp_explanation) l
+
+  let reset () = explanations := M.empty
+  let list_explanations () =
+    let c = !explanations in
+    reset ();
+    c |> M.bindings |> List.map snd |> List.sort Stdlib.compare
+
+
+  let print_toplevel_hint ppf l =
+    let conj ppf () = Format.fprintf ppf " and@ " in
+    let pp_namespace_plural ppf n = Format.fprintf ppf "%as" Namespace.pp n in
+    let root_names = List.map (fun r -> r.kind, r.root_name) l in
+    let unique_root_names = List.sort_uniq Stdlib.compare root_names in
+    let submsgs = Array.make Namespace.size [] in
+    let () = List.iter (fun (n,_ as x) ->
+        submsgs.(Namespace.id n) <- x :: submsgs.(Namespace.id n)
+      )  unique_root_names in
+    let pp_submsg ppf names =
+      match names with
+      | [] -> ()
+      | [namespace, a] ->
+          Format.fprintf ppf
+        "@ \
+         @[<2>Hint: The %a %s has been defined multiple times@ \
+         in@ this@ toplevel@ session.@ \
+         Some toplevel values still refer to@ old@ versions@ of@ this@ %a.\
+         @ Did you try to redefine them?@]"
+        Namespace.pp namespace a Namespace.pp namespace
+      | (namespace, _) :: _ :: _ ->
+      Format.fprintf ppf
+        "@ \
+         @[<2>Hint: The %a %a have been defined multiple times@ \
+         in@ this@ toplevel@ session.@ \
+         Some toplevel values still refer to@ old@ versions@ of@ those@ %a.\
+         @ Did you try to redefine them?@]"
+        pp_namespace_plural namespace
+        Format.(pp_print_list ~pp_sep:conj pp_print_string) (List.map snd names)
+        pp_namespace_plural namespace in
+    Array.iter (pp_submsg ppf) submsgs
+
+  let print_explanations ppf =
+    let ltop, l =
+      (* isolate toplevel locations, since they are too imprecise *)
+      let from_toplevel a =
+        a.location.Location.loc_start.Lexing.pos_fname = "//toplevel//" in
+      List.partition from_toplevel (list_explanations ())
+    in
+    begin match l with
+    | [] -> ()
+    | l -> Format.fprintf ppf "@,%a" print_located_explanations l
+    end;
+    (* if there are name collisions in a toplevel session,
+       display at least one generic hint by namespace *)
+    print_toplevel_hint ppf ltop
+
+  let exists () = M.cardinal !explanations >0
+end
+
+module Naming_context = struct
+
+module M = String.Map
+module S = String.Set
+
+let enabled = ref true
+let enable b = enabled := b
+
+(** Name mapping *)
+type mapping =
+  | Need_unique_name of int Ident.Map.t
+  (** The same name has already been attributed to multiple types.
+      The [map] argument contains the specific binding time attributed to each
+      types.
+  *)
+  | Uniquely_associated_to of Ident.t * out_name
+    (** For now, the name [Ident.name id] has been attributed to [id],
+        [out_name] is used to expand this name if a conflict arises
+        at a later point
+    *)
+  | Associated_to_pervasives of out_name
+  (** [Associated_to_pervasives out_name] is used when the item
+      [Stdlib.$name] has been associated to the name [$name].
+      Upon a conflict, this name will be expanded to ["Stdlib." ^ name ] *)
+
+let hid_start = 0
+
+let add_hid_id id map =
+  let new_id = 1 + Ident.Map.fold (fun _ -> Int.max) map hid_start in
+  new_id, Ident.Map.add id new_id  map
+
+let find_hid id map =
+  try Ident.Map.find id map, map with
+  Not_found -> add_hid_id id map
+
+let pervasives name = "Stdlib." ^ name
+
+let map = Array.make Namespace.size M.empty
+let get namespace = map.(Namespace.id namespace)
+let set namespace x = map.(Namespace.id namespace) <- x
+
+(* Names used in recursive definitions are not considered when determining
+   if a name is already attributed in the current environment.
+   This is a complementary version of hidden_rec_items used by short-path. *)
+let protected = ref S.empty
+
+(* When dealing with functor arguments, identity becomes fuzzy because the same
+   syntactic argument may be represented by different identifers during the
+   error processing, we are thus disabling disambiguation on the argument name
+*)
+let fuzzy = ref S.empty
+let with_arg id f =
+  protect_refs [ R(fuzzy, S.add (Ident.name id) !fuzzy) ] f
+let fuzzy_id namespace id = namespace = Module && S.mem (Ident.name id) !fuzzy
+
+let with_hidden ids f =
+  let update m id = S.add (Ident.name id.ident) m in
+  protect_refs [ R(protected, List.fold_left update !protected ids)] f
+
+let pervasives_name namespace name =
+  if not !enabled then Out_name.create name else
+  match M.find name (get namespace) with
+  | Associated_to_pervasives r -> r
+  | Need_unique_name _ -> Out_name.create (pervasives name)
+  | Uniquely_associated_to (id',r) ->
+      let hid, map = add_hid_id id' Ident.Map.empty in
+      Out_name.set r (human_unique hid id');
+      Conflicts.collect_explanation namespace hid id';
+      set namespace @@ M.add name (Need_unique_name map) (get namespace);
+      Out_name.create (pervasives name)
+  | exception Not_found ->
+      let r = Out_name.create name in
+      set namespace @@ M.add name (Associated_to_pervasives r) (get namespace);
+      r
+
+(** Lookup for preexisting named item within the current {!printing_env} *)
+let env_ident namespace name =
+  if S.mem name !protected then None else
+  match Namespace.lookup namespace name with
+  | Pident id -> Some id
+  | _ -> None
+  | exception Not_found -> None
+
+(** Associate a name to the identifier [id] within [namespace] *)
+let ident_name_simple namespace id =
+  if not !enabled || fuzzy_id namespace id then
+    Out_name.create (Ident.name id)
+  else
+  let name = Ident.name id in
+  match M.find name (get namespace) with
+  | Uniquely_associated_to (id',r) when Ident.same id id' ->
+      r
+  | Need_unique_name map ->
+      let hid, m = find_hid id map in
+      Conflicts.collect_explanation namespace hid id;
+      set namespace @@ M.add name (Need_unique_name m) (get namespace);
+      Out_name.create (human_unique hid id)
+  | Uniquely_associated_to (id',r) ->
+      let hid', m = find_hid id' Ident.Map.empty in
+      let hid, m = find_hid id m in
+      Out_name.set r (human_unique hid' id');
+      List.iter (fun (id,hid) -> Conflicts.collect_explanation namespace hid id)
+        [id, hid; id', hid' ];
+      set namespace @@ M.add name (Need_unique_name m) (get namespace);
+      Out_name.create (human_unique hid id)
+  | Associated_to_pervasives r ->
+      Out_name.set r ("Stdlib." ^ Out_name.print r);
+      let hid, m = find_hid id Ident.Map.empty in
+      set namespace @@ M.add name (Need_unique_name m) (get namespace);
+      Out_name.create (human_unique hid id)
+  | exception Not_found ->
+      let r = Out_name.create name in
+      set namespace
+      @@ M.add name (Uniquely_associated_to (id,r) ) (get namespace);
+      r
+
+(** Same as {!ident_name_simple} but lookup to existing named identifiers
+    in the current {!printing_env} *)
+let ident_name namespace id =
+  begin match env_ident namespace (Ident.name id) with
+  | Some id' -> ignore (ident_name_simple namespace id')
+  | None -> ()
+  end;
+  ident_name_simple namespace id
+
+let reset () =
+  Array.iteri ( fun i _ -> map.(i) <- M.empty ) map
+
+let with_ctx f =
+  let old = Array.copy map in
+  try_finally f
+    ~always:(fun () -> Array.blit old 0 map 0 (Array.length map))
+
+end
+let ident_name = Naming_context.ident_name
+let reset_naming_context = Naming_context.reset
+
+let ident ppf id = pp_print_string ppf
+    (Out_name.print (Naming_context.ident_name_simple Other id))
+
+(* Print a path *)
+
+let ident_stdlib = Ident.create_persistent "Stdlib"
+
+let non_shadowed_pervasive = function
+  | Pdot(Pident id, s) as path ->
+      Ident.same id ident_stdlib &&
+      (match in_printing_env (Env.find_type_by_name (Lident s)) with
+       | (path', _) -> Path.same path path'
+       | exception Not_found -> true)
+  | _ -> false
+
+let find_double_underscore s =
+  let len = String.length s in
+  let rec loop i =
+    if i + 1 >= len then
+      None
+    else if s.[i] = '_' && s.[i + 1] = '_' then
+      Some i
+    else
+      loop (i + 1)
+  in
+  loop 0
+
+let rec module_path_is_an_alias_of env path ~alias_of =
+  match Env.find_module path env with
+  | { md_type = Mty_alias path'; _ } ->
+    Path.same path' alias_of ||
+    module_path_is_an_alias_of env path' ~alias_of
+  | _ -> false
+  | exception Not_found -> false
+
+(* Simple heuristic to print Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias
+   for Foo__bar. This pattern is used by the stdlib. *)
+let rec rewrite_double_underscore_paths env p =
+  match p with
+  | Pdot (p, s) ->
+    Pdot (rewrite_double_underscore_paths env p, s)
+  | Papply (a, b) ->
+    Papply (rewrite_double_underscore_paths env a,
+            rewrite_double_underscore_paths env b)
+  | Pident id ->
+    let name = Ident.name id in
+    match find_double_underscore name with
+    | None -> p
+    | Some i ->
+      let better_lid =
+        Ldot
+          (Lident (String.sub name 0 i),
+           String.capitalize_ascii
+             (String.sub name (i + 2) (String.length name - i - 2)))
+      in
+      match Env.find_module_by_name better_lid env with
+      | exception Not_found -> p
+      | p', _ ->
+          if module_path_is_an_alias_of env p' ~alias_of:p then
+            p'
+          else
+          p
+
+let rewrite_double_underscore_paths env p =
+  if env == Env.empty then
+    p
+  else
+    rewrite_double_underscore_paths env p
+
+let rec tree_of_path namespace = function
+  | Pident id ->
+      Oide_ident (ident_name namespace id)
+  | Pdot(_, s) as path when non_shadowed_pervasive path ->
+      Oide_ident (Naming_context.pervasives_name namespace s)
+  | Pdot(Pident t, s)
+    when namespace=Type && not (Path.is_uident (Ident.name t)) ->
+      (* [t.A]: inline record of the constructor [A] from type [t] *)
+      Oide_dot (Oide_ident (ident_name Type t), s)
+  | Pdot(p, s) ->
+      Oide_dot (tree_of_path Module p, s)
+  | Papply(p1, p2) ->
+      Oide_apply (tree_of_path Module p1, tree_of_path Module p2)
+
+let tree_of_path namespace p =
+  tree_of_path namespace (rewrite_double_underscore_paths !printing_env p)
+
+let path ppf p =
+  !Oprint.out_ident ppf (tree_of_path Other p)
+
+let string_of_path p =
+  Format.asprintf "%a" path p
+
+let strings_of_paths namespace p =
+  reset_naming_context ();
+  let trees = List.map (tree_of_path namespace) p in
+  List.map (Format.asprintf "%a" !Oprint.out_ident) trees
+
+let () = Env.print_path := path
+
+(* Print a recursive annotation *)
+
+let tree_of_rec = function
+  | Trec_not -> Orec_not
+  | Trec_first -> Orec_first
+  | Trec_next -> Orec_next
+
+(* Print a raw type expression, with sharing *)
+
+let raw_list pr ppf = function
+    [] -> fprintf ppf "[]"
+  | a :: l ->
+      fprintf ppf "@[<1>[%a%t]@]" pr a
+        (fun ppf -> List.iter (fun x -> fprintf ppf ";@,%a" pr x) l)
+
+let kind_vars = ref []
+let kind_count = ref 0
+
+let rec safe_kind_repr v = function
+    Fvar {contents=Some k}  ->
+      if List.memq k v then "Fvar loop" else
+      safe_kind_repr (k::v) k
+  | Fvar r ->
+      let vid =
+        try List.assq r !kind_vars
+        with Not_found ->
+          let c = incr kind_count; !kind_count in
+          kind_vars := (r,c) :: !kind_vars;
+          c
+      in
+      Printf.sprintf "Fvar {None}@%d" vid
+  | Fpresent -> "Fpresent"
+  | Fabsent -> "Fabsent"
+
+let rec safe_commu_repr v = function
+    Cok -> "Cok"
+  | Cunknown -> "Cunknown"
+  | Clink r ->
+      if List.memq r v then "Clink loop" else
+      safe_commu_repr (r::v) !r
+
+let rec safe_repr v = function
+    {desc = Tlink t} when not (List.memq t v) ->
+      safe_repr (t::v) t
+  | t -> t
+
+let rec list_of_memo = function
+    Mnil -> []
+  | Mcons (_priv, p, _t1, _t2, rem) -> p :: list_of_memo rem
+  | Mlink rem -> list_of_memo !rem
+
+let print_name ppf = function
+    None -> fprintf ppf "None"
+  | Some name -> fprintf ppf "\"%s\"" name
+
+let string_of_label = function
+    Nolabel -> ""
+  | Labelled s -> s
+  | Optional s -> "?"^s
+
+let visited = ref []
+let rec raw_type ppf ty =
+  let ty = safe_repr [] ty in
+  if List.memq ty !visited then fprintf ppf "{id=%d}" ty.id else begin
+    visited := ty :: !visited;
+    fprintf ppf "@[<1>{id=%d;level=%d;scope=%d;desc=@,%a}@]" ty.id ty.level
+      ty.scope raw_type_desc ty.desc
+  end
+and raw_type_list tl = raw_list raw_type tl
+and raw_type_desc ppf = function
+    Tvar name -> fprintf ppf "Tvar %a" print_name name
+  | Tarrow(l,t1,t2,c) ->
+      fprintf ppf "@[<hov1>Tarrow(\"%s\",@,%a,@,%a,@,%s)@]"
+        (string_of_label l) raw_type t1 raw_type t2
+        (safe_commu_repr [] c)
+  | Ttuple tl ->
+      fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl
+  | Tconstr (p, tl, abbrev) ->
+      fprintf ppf "@[<hov1>Tconstr(@,%a,@,%a,@,%a)@]" path p
+        raw_type_list tl
+        (raw_list path) (list_of_memo !abbrev)
+  | Tobject (t, nm) ->
+      fprintf ppf "@[<hov1>Tobject(@,%a,@,@[<1>ref%t@])@]" raw_type t
+        (fun ppf ->
+          match !nm with None -> fprintf ppf " None"
+          | Some(p,tl) ->
+              fprintf ppf "(Some(@,%a,@,%a))" path p raw_type_list tl)
+  | Tfield (f, k, t1, t2) ->
+      fprintf ppf "@[<hov1>Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f
+        (safe_kind_repr [] k)
+        raw_type t1 raw_type t2
+  | Tnil -> fprintf ppf "Tnil"
+  | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t
+  | Tsubst (t, None) -> fprintf ppf "@[<1>Tsubst@,(%a,None)@]" raw_type t
+  | Tsubst (t, Some t') ->
+      fprintf ppf "@[<1>Tsubst@,(%a,@ Some%a)@]" raw_type t raw_type t'
+  | Tunivar name -> fprintf ppf "Tunivar %a" print_name name
+  | Tpoly (t, tl) ->
+      fprintf ppf "@[<hov1>Tpoly(@,%a,@,%a)@]"
+        raw_type t
+        raw_type_list tl
+  | Tvariant row ->
+      fprintf ppf
+        "@[<hov1>{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%B;@ %s%a;@ @[<1>%s%t@]}@]"
+        "row_fields="
+        (raw_list (fun ppf (l, f) ->
+          fprintf ppf "@[%s,@ %a@]" l raw_field f))
+        row.row_fields
+        "row_more=" raw_type row.row_more
+        "row_closed=" row.row_closed
+        "row_fixed=" raw_row_fixed row.row_fixed
+        "row_name="
+        (fun ppf ->
+          match row.row_name with None -> fprintf ppf "None"
+          | Some(p,tl) ->
+              fprintf ppf "Some(@,%a,@,%a)" path p raw_type_list tl)
+  | Tpackage (p, fl) ->
+      fprintf ppf "@[<hov1>Tpackage(@,%a@,%a)@]" path p
+        raw_type_list (List.map snd fl)
+and raw_row_fixed ppf = function
+| None -> fprintf ppf "None"
+| Some Types.Fixed_private -> fprintf ppf "Some Fixed_private"
+| Some Types.Rigid -> fprintf ppf "Some Rigid"
+| Some Types.Univar t -> fprintf ppf "Some(Univar(%a))" raw_type t
+| Some Types.Reified p -> fprintf ppf "Some(Reified(%a))" path p
+
+and raw_field ppf = function
+    Rpresent None -> fprintf ppf "Rpresent None"
+  | Rpresent (Some t) -> fprintf ppf "@[<1>Rpresent(Some@,%a)@]" raw_type t
+  | Reither (c,tl,m,e) ->
+      fprintf ppf "@[<hov1>Reither(%B,@,%a,@,%B,@,@[<1>ref%t@])@]" c
+        raw_type_list tl m
+        (fun ppf ->
+          match !e with None -> fprintf ppf " None"
+          | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f)
+  | Rabsent -> fprintf ppf "Rabsent"
+
+let raw_type_expr ppf t =
+  visited := []; kind_vars := []; kind_count := 0;
+  raw_type ppf t;
+  visited := []; kind_vars := []
+
+let () = Btype.print_raw := raw_type_expr
+
+(* Normalize paths *)
+
+type param_subst = Id | Nth of int | Map of int list
+
+let is_nth = function
+    Nth _ -> true
+  | _ -> false
+
+let compose l1 = function
+  | Id -> Map l1
+  | Map l2 -> Map (List.map (List.nth l1) l2)
+  | Nth n  -> Nth (List.nth l1 n)
+
+let apply_subst s1 tyl =
+  if tyl = [] then []
+  (* cf. PR#7543: Typemod.type_package doesn't respect type constructor arity *)
+  else
+    match s1 with
+      Nth n1 -> [List.nth tyl n1]
+    | Map l1 -> List.map (List.nth tyl) l1
+    | Id -> tyl
+
+type best_path = Paths of Path.t list | Best of Path.t
+
+(** Short-paths cache: the five mutable variables below implement a one-slot
+    cache for short-paths
+ *)
+let printing_old = ref Env.empty
+let printing_pers = ref Concr.empty
+(** {!printing_old} and  {!printing_pers} are the keys of the one-slot cache *)
+
+let printing_depth = ref 0
+let printing_cont = ref ([] : Env.iter_cont list)
+let printing_map = ref Path.Map.empty
+(**
+   - {!printing_map} is the main value stored in the cache.
+   Note that it is evaluated lazily and its value is updated during printing.
+   - {!printing_dep} is the current exploration depth of the environment,
+   it is used to determine whenever the {!printing_map} should be evaluated
+   further before completing a request.
+   - {!printing_cont} is the list of continuations needed to evaluate
+   the {!printing_map} one level further (see also {!Env.run_iter_cont})
+*)
+
+let same_type t t' = repr t == repr t'
+
+let rec index l x =
+  match l with
+    [] -> raise Not_found
+  | a :: l -> if x == a then 0 else 1 + index l x
+
+let rec uniq = function
+    [] -> true
+  | a :: l -> not (List.memq a l) && uniq l
+
+let rec normalize_type_path ?(cache=false) env p =
+  try
+    let (params, ty, _) = Env.find_type_expansion p env in
+    let params = List.map repr params in
+    match repr ty with
+      {desc = Tconstr (p1, tyl, _)} ->
+        let tyl = List.map repr tyl in
+        if List.length params = List.length tyl
+        && List.for_all2 (==) params tyl
+        then normalize_type_path ~cache env p1
+        else if cache || List.length params <= List.length tyl
+             || not (uniq tyl) then (p, Id)
+        else
+          let l1 = List.map (index params) tyl in
+          let (p2, s2) = normalize_type_path ~cache env p1 in
+          (p2, compose l1 s2)
+    | ty ->
+        (p, Nth (index params ty))
+  with
+    Not_found ->
+      (Env.normalize_type_path None env p, Id)
+
+let penalty s =
+  if s <> "" && s.[0] = '_' then
+    10
+  else
+    match find_double_underscore s with
+    | None -> 1
+    | Some _ -> 10
+
+let rec path_size = function
+    Pident id ->
+      penalty (Ident.name id), -Ident.scope id
+  | Pdot (p, _) ->
+      let (l, b) = path_size p in (1+l, b)
+  | Papply (p1, p2) ->
+      let (l, b) = path_size p1 in
+      (l + fst (path_size p2), b)
+
+let same_printing_env env =
+  let used_pers = Env.used_persistent () in
+  Env.same_types !printing_old env && Concr.equal !printing_pers used_pers
+
+let set_printing_env env =
+  printing_env := env;
+  if !Clflags.real_paths ||
+     !printing_env == Env.empty ||
+     same_printing_env env then
+    ()
+  else begin
+    (* printf "Reset printing_map@."; *)
+    printing_old := env;
+    printing_pers := Env.used_persistent ();
+    printing_map := Path.Map.empty;
+    printing_depth := 0;
+    (* printf "Recompute printing_map.@."; *)
+    let cont =
+      Env.iter_types
+        (fun p (p', _decl) ->
+          let (p1, s1) = normalize_type_path env p' ~cache:true in
+          (* Format.eprintf "%a -> %a = %a@." path p path p' path p1 *)
+          if s1 = Id then
+          try
+            let r = Path.Map.find p1 !printing_map in
+            match !r with
+              Paths l -> r := Paths (p :: l)
+            | Best p' -> r := Paths [p; p'] (* assert false *)
+          with Not_found ->
+            printing_map := Path.Map.add p1 (ref (Paths [p])) !printing_map)
+        env in
+    printing_cont := [cont];
+  end
+
+let wrap_printing_env env f =
+  set_printing_env env; reset_naming_context ();
+  try_finally f ~always:(fun () -> set_printing_env Env.empty)
+
+let wrap_printing_env ~error env f =
+  if error then Env.without_cmis (wrap_printing_env env) f
+  else wrap_printing_env env f
+
+let rec lid_of_path = function
+    Path.Pident id ->
+      Longident.Lident (Ident.name id)
+  | Path.Pdot (p1, s) ->
+      Longident.Ldot (lid_of_path p1, s)
+  | Path.Papply (p1, p2) ->
+      Longident.Lapply (lid_of_path p1, lid_of_path p2)
+
+let is_unambiguous path env =
+  let l = Env.find_shadowed_types path env in
+  List.exists (Path.same path) l || (* concrete paths are ok *)
+  match l with
+    [] -> true
+  | p :: rem ->
+      (* allow also coherent paths:  *)
+      let normalize p = fst (normalize_type_path ~cache:true env p) in
+      let p' = normalize p in
+      List.for_all (fun p -> Path.same (normalize p) p') rem ||
+      (* also allow repeatedly defining and opening (for toplevel) *)
+      let id = lid_of_path p in
+      List.for_all (fun p -> lid_of_path p = id) rem &&
+      Path.same p (fst (Env.find_type_by_name id env))
+
+let rec get_best_path r =
+  match !r with
+    Best p' -> p'
+  | Paths [] -> raise Not_found
+  | Paths l ->
+      r := Paths [];
+      List.iter
+        (fun p ->
+          (* Format.eprintf "evaluating %a@." path p; *)
+          match !r with
+            Best p' when path_size p >= path_size p' -> ()
+          | _ -> if is_unambiguous p !printing_env then r := Best p)
+              (* else Format.eprintf "%a ignored as ambiguous@." path p *)
+        l;
+      get_best_path r
+
+let best_type_path p =
+  if !printing_env == Env.empty
+  then (p, Id)
+  else if !Clflags.real_paths
+  then (p, Id)
+  else
+    let (p', s) = normalize_type_path !printing_env p in
+    let get_path () = get_best_path (Path.Map.find  p' !printing_map) in
+    while !printing_cont <> [] &&
+      try fst (path_size (get_path ())) > !printing_depth with Not_found -> true
+    do
+      printing_cont := List.map snd (Env.run_iter_cont !printing_cont);
+      incr printing_depth;
+    done;
+    let p'' = try get_path () with Not_found -> p' in
+    (* Format.eprintf "%a = %a -> %a@." path p path p' path p''; *)
+    (p'', s)
+
+(* Print a type expression *)
+
+let names = ref ([] : (type_expr * string) list)
+let name_counter = ref 0
+let named_vars = ref ([] : string list)
+
+let weak_counter = ref 1
+let weak_var_map = ref TypeMap.empty
+let named_weak_vars = ref String.Set.empty
+
+let reset_names () = names := []; name_counter := 0; named_vars := []
+let add_named_var ty =
+  match ty.desc with
+    Tvar (Some name) | Tunivar (Some name) ->
+      if List.mem name !named_vars then () else
+      named_vars := name :: !named_vars
+  | _ -> ()
+
+let name_is_already_used name =
+  List.mem name !named_vars
+  || List.exists (fun (_, name') -> name = name') !names
+  || String.Set.mem name !named_weak_vars
+
+let rec new_name () =
+  let name =
+    if !name_counter < 26
+    then String.make 1 (Char.chr(97 + !name_counter))
+    else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^
+           Int.to_string(!name_counter / 26) in
+  incr name_counter;
+  if name_is_already_used name then new_name () else name
+
+let rec new_weak_name ty () =
+  let name = "weak" ^ Int.to_string !weak_counter in
+  incr weak_counter;
+  if name_is_already_used name then new_weak_name ty ()
+  else begin
+      named_weak_vars := String.Set.add name !named_weak_vars;
+      weak_var_map := TypeMap.add ty name !weak_var_map;
+      name
+    end
+
+let name_of_type name_generator t =
+  (* We've already been through repr at this stage, so t is our representative
+     of the union-find class. *)
+  try List.assq t !names with Not_found ->
+    try TypeMap.find t !weak_var_map with Not_found ->
+    let name =
+      match t.desc with
+        Tvar (Some name) | Tunivar (Some name) ->
+          (* Some part of the type we've already printed has assigned another
+           * unification variable to that name. We want to keep the name, so try
+           * adding a number until we find a name that's not taken. *)
+          let current_name = ref name in
+          let i = ref 0 in
+          while List.exists (fun (_, name') -> !current_name = name') !names do
+            current_name := name ^ (Int.to_string !i);
+            i := !i + 1;
+          done;
+          !current_name
+      | _ ->
+          (* No name available, create a new one *)
+          name_generator ()
+    in
+    (* Exception for type declarations *)
+    if name <> "_" then names := (t, name) :: !names;
+    name
+
+let check_name_of_type t = ignore(name_of_type new_name t)
+
+let remove_names tyl =
+  let tyl = List.map repr tyl in
+  names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names
+
+let visited_objects = ref ([] : type_expr list)
+let aliased = ref ([] : type_expr list)
+let delayed = ref ([] : type_expr list)
+
+let add_delayed t =
+  if not (List.memq t !delayed) then delayed := t :: !delayed
+
+let is_aliased ty = List.memq (proxy ty) !aliased
+let add_alias ty =
+  let px = proxy ty in
+  if not (is_aliased px) then begin
+    aliased := px :: !aliased;
+    add_named_var px
+  end
+
+let aliasable ty =
+  match ty.desc with
+    Tvar _ | Tunivar _ | Tpoly _ -> false
+  | Tconstr (p, _, _) ->
+      not (is_nth (snd (best_type_path p)))
+  | _ -> true
+
+let namable_row row =
+  row.row_name <> None &&
+  List.for_all
+    (fun (_, f) ->
+       match row_field_repr f with
+       | Reither(c, l, _, _) ->
+           row.row_closed && if c then l = [] else List.length l = 1
+       | _ -> true)
+    row.row_fields
+
+let rec mark_loops_rec visited ty =
+  let ty = repr ty in
+  let px = proxy ty in
+  if List.memq px visited && aliasable ty then add_alias px else
+    let visited = px :: visited in
+    match ty.desc with
+    | Tvar _ -> add_named_var ty
+    | Tarrow(_, ty1, ty2, _) ->
+        mark_loops_rec visited ty1; mark_loops_rec visited ty2
+    | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl
+    | Tconstr(p, tyl, _) ->
+        let (_p', s) = best_type_path p in
+        List.iter (mark_loops_rec visited) (apply_subst s tyl)
+    | Tpackage (_, fl) ->
+        List.iter (fun (_n, ty) -> mark_loops_rec visited ty) fl
+    | Tvariant row ->
+        if List.memq px !visited_objects then add_alias px else
+         begin
+          let row = row_repr row in
+          if not (static_row row) then
+            visited_objects := px :: !visited_objects;
+          match row.row_name with
+          | Some(_p, tyl) when namable_row row ->
+              List.iter (mark_loops_rec visited) tyl
+          | _ ->
+              iter_row (mark_loops_rec visited) row
+         end
+    | Tobject (fi, nm) ->
+        if List.memq px !visited_objects then add_alias px else
+         begin
+          if opened_object ty then
+            visited_objects := px :: !visited_objects;
+          begin match !nm with
+          | None ->
+              let fields, _ = flatten_fields fi in
+              List.iter
+                (fun (_, kind, ty) ->
+                  if field_kind_repr kind = Fpresent then
+                    mark_loops_rec visited ty)
+                fields
+          | Some (_, l) ->
+              List.iter (mark_loops_rec visited) (List.tl l)
+          end
+        end
+    | Tfield(_, kind, ty1, ty2) when field_kind_repr kind = Fpresent ->
+        mark_loops_rec visited ty1; mark_loops_rec visited ty2
+    | Tfield(_, _, _, ty2) ->
+        mark_loops_rec visited ty2
+    | Tnil -> ()
+    | Tsubst _ -> ()  (* we do not print arguments *)
+    | Tlink _ -> fatal_error "Printtyp.mark_loops_rec (2)"
+    | Tpoly (ty, tyl) ->
+        List.iter (fun t -> add_alias t) tyl;
+        mark_loops_rec visited ty
+    | Tunivar _ -> add_named_var ty
+
+let mark_loops ty =
+  normalize_type ty;
+  mark_loops_rec [] ty;;
+
+let reset_loop_marks () =
+  visited_objects := []; aliased := []; delayed := []
+
+let reset_except_context () =
+  reset_names (); reset_loop_marks ()
+
+let reset () =
+  reset_naming_context (); Conflicts.reset ();
+  reset_except_context ()
+
+let reset_and_mark_loops ty =
+  reset_except_context (); mark_loops ty
+
+let reset_and_mark_loops_list tyl =
+  reset_except_context (); List.iter mark_loops tyl
+
+(* Disabled in classic mode when printing an unification error *)
+let print_labels = ref true
+
+let rec tree_of_typexp sch ty =
+  let ty = repr ty in
+  let px = proxy ty in
+  if List.mem_assq px !names && not (List.memq px !delayed) then
+   let mark = is_non_gen sch ty in
+   let name = name_of_type (if mark then new_weak_name ty else new_name) px in
+   Otyp_var (mark, name) else
+
+  let pr_typ () =
+    match ty.desc with
+    | Tvar _ ->
+        (*let lev =
+          if is_non_gen sch ty then "/" ^ Int.to_string ty.level else "" in*)
+        let non_gen = is_non_gen sch ty in
+        let name_gen = if non_gen then new_weak_name ty else new_name in
+        Otyp_var (non_gen, name_of_type name_gen ty)
+    | Tarrow(l, ty1, ty2, _) ->
+        let lab =
+          if !print_labels || is_optional l then string_of_label l else ""
+        in
+        let t1 =
+          if is_optional l then
+            match (repr ty1).desc with
+            | Tconstr(path, [ty], _)
+              when Path.same path Predef.path_option ->
+                tree_of_typexp sch ty
+            | _ -> Otyp_stuff "<hidden>"
+          else tree_of_typexp sch ty1 in
+        Otyp_arrow (lab, t1, tree_of_typexp sch ty2)
+    | Ttuple tyl ->
+        Otyp_tuple (tree_of_typlist sch tyl)
+    | Tconstr(p, tyl, _abbrev) ->
+        let p', s = best_type_path p in
+        let tyl' = apply_subst s tyl in
+        if is_nth s && not (tyl'=[]) then tree_of_typexp sch (List.hd tyl') else
+        Otyp_constr (tree_of_path Type p', tree_of_typlist sch tyl')
+    | Tvariant row ->
+        let row = row_repr row in
+        let fields =
+          if row.row_closed then
+            List.filter (fun (_, f) -> row_field_repr f <> Rabsent)
+              row.row_fields
+          else row.row_fields in
+        let present =
+          List.filter
+            (fun (_, f) ->
+               match row_field_repr f with
+               | Rpresent _ -> true
+               | _ -> false)
+            fields in
+        let all_present = List.length present = List.length fields in
+        begin match row.row_name with
+        | Some(p, tyl) when namable_row row ->
+            let (p', s) = best_type_path p in
+            let id = tree_of_path Type p' in
+            let args = tree_of_typlist sch (apply_subst s tyl) in
+            let out_variant =
+              if is_nth s then List.hd args else Otyp_constr (id, args) in
+            if row.row_closed && all_present then
+              out_variant
+            else
+              let non_gen = is_non_gen sch px in
+              let tags =
+                if all_present then None else Some (List.map fst present) in
+              Otyp_variant (non_gen, Ovar_typ out_variant, row.row_closed, tags)
+        | _ ->
+            let non_gen =
+              not (row.row_closed && all_present) && is_non_gen sch px in
+            let fields = List.map (tree_of_row_field sch) fields in
+            let tags =
+              if all_present then None else Some (List.map fst present) in
+            Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags)
+        end
+    | Tobject (fi, nm) ->
+        tree_of_typobject sch fi !nm
+    | Tnil | Tfield _ ->
+        tree_of_typobject sch ty None
+    | Tsubst _ ->
+        (* This case should only happen when debugging the compiler *)
+        Otyp_stuff "<Tsubst>"
+    | Tlink _ ->
+        fatal_error "Printtyp.tree_of_typexp"
+    | Tpoly (ty, []) ->
+        tree_of_typexp sch ty
+    | Tpoly (ty, tyl) ->
+        (*let print_names () =
+          List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names;
+          prerr_string "; " in *)
+        let tyl = List.map repr tyl in
+        if tyl = [] then tree_of_typexp sch ty else begin
+          let old_delayed = !delayed in
+          (* Make the names delayed, so that the real type is
+             printed once when used as proxy *)
+          List.iter add_delayed tyl;
+          let tl = List.map (name_of_type new_name) tyl in
+          let tr = Otyp_poly (tl, tree_of_typexp sch ty) in
+          (* Forget names when we leave scope *)
+          remove_names tyl;
+          delayed := old_delayed; tr
+        end
+    | Tunivar _ ->
+        Otyp_var (false, name_of_type new_name ty)
+    | Tpackage (p, fl) ->
+        let fl =
+          List.map
+            (fun (li, ty) -> (
+              String.concat "." (Longident.flatten li),
+              tree_of_typexp sch ty
+            )) fl in
+        Otyp_module (tree_of_path Module_type p, fl)
+  in
+  if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed;
+  if is_aliased px && aliasable ty then begin
+    check_name_of_type px;
+    Otyp_alias (pr_typ (), name_of_type new_name px) end
+  else pr_typ ()
+
+and tree_of_row_field sch (l, f) =
+  match row_field_repr f with
+  | Rpresent None | Reither(true, [], _, _) -> (l, false, [])
+  | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty])
+  | Reither(c, tyl, _, _) ->
+      if c (* contradiction: constant constructor with an argument *)
+      then (l, true, tree_of_typlist sch tyl)
+      else (l, false, tree_of_typlist sch tyl)
+  | Rabsent -> (l, false, [] (* actually, an error *))
+
+and tree_of_typlist sch tyl =
+  List.map (tree_of_typexp sch) tyl
+
+and tree_of_typobject sch fi nm =
+  begin match nm with
+  | None ->
+      let pr_fields fi =
+        let (fields, rest) = flatten_fields fi in
+        let present_fields =
+          List.fold_right
+            (fun (n, k, t) l ->
+               match field_kind_repr k with
+               | Fpresent -> (n, t) :: l
+               | _ -> l)
+            fields [] in
+        let sorted_fields =
+          List.sort
+            (fun (n, _) (n', _) -> String.compare n n') present_fields in
+        tree_of_typfields sch rest sorted_fields in
+      let (fields, rest) = pr_fields fi in
+      Otyp_object (fields, rest)
+  | Some (p, ty :: tyl) ->
+      let non_gen = is_non_gen sch (repr ty) in
+      let args = tree_of_typlist sch tyl in
+      let (p', s) = best_type_path p in
+      assert (s = Id);
+      Otyp_class (non_gen, tree_of_path Type p', args)
+  | _ ->
+      fatal_error "Printtyp.tree_of_typobject"
+  end
+
+and is_non_gen sch ty =
+    sch && is_Tvar ty && ty.level <> generic_level
+
+and tree_of_typfields sch rest = function
+  | [] ->
+      let rest =
+        match rest.desc with
+        | Tvar _ | Tunivar _ -> Some (is_non_gen sch rest)
+        | Tconstr _ -> Some false
+        | Tnil -> None
+        | _ -> fatal_error "typfields (1)"
+      in
+      ([], rest)
+  | (s, t) :: l ->
+      let field = (s, tree_of_typexp sch t) in
+      let (fields, rest) = tree_of_typfields sch rest l in
+      (field :: fields, rest)
+
+let typexp sch ppf ty =
+  !Oprint.out_type ppf (tree_of_typexp sch ty)
+
+let marked_type_expr ppf ty = typexp false ppf ty
+
+let type_expr ppf ty =
+  (* [type_expr] is used directly by error message printers,
+     we mark eventual loops ourself to avoid any misuse and stack overflow *)
+  reset_and_mark_loops ty;
+  marked_type_expr ppf ty
+
+and type_sch ppf ty = typexp true ppf ty
+
+and type_scheme ppf ty = reset_and_mark_loops ty; typexp true ppf ty
+
+let type_path ppf p =
+  let (p', s) = best_type_path p in
+  let p = if (s = Id) then p' else p in
+  let t = tree_of_path Type p in
+  !Oprint.out_ident ppf t
+
+(* Maxence *)
+let type_scheme_max ?(b_reset_names=true) ppf ty =
+  if b_reset_names then reset_names () ;
+  typexp true ppf ty
+(* End Maxence *)
+
+let tree_of_type_scheme ty = reset_and_mark_loops ty; tree_of_typexp true ty
+
+(* Print one type declaration *)
+
+let tree_of_constraints params =
+  List.fold_right
+    (fun ty list ->
+       let ty' = unalias ty in
+       if proxy ty != proxy ty' then
+         let tr = tree_of_typexp true ty in
+         (tr, tree_of_typexp true ty') :: list
+       else list)
+    params []
+
+let filter_params tyl =
+  let params =
+    List.fold_left
+      (fun tyl ty ->
+        let ty = repr ty in
+        if List.memq ty tyl then Btype.newgenty (Ttuple [ty]) :: tyl
+        else ty :: tyl)
+      (* Two parameters might be identical due to a constraint but we need to
+         print them differently in order to make the output syntactically valid.
+         We use [Ttuple [ty]] because it is printed as [ty]. *)
+      (* Replacing fold_left by fold_right does not work! *)
+      [] tyl
+  in List.rev params
+
+let mark_loops_constructor_arguments = function
+  | Cstr_tuple l -> List.iter mark_loops l
+  | Cstr_record l -> List.iter (fun l -> mark_loops l.ld_type) l
+
+let rec tree_of_type_decl id decl =
+
+  reset_except_context();
+
+  let params = filter_params decl.type_params in
+
+  begin match decl.type_manifest with
+  | Some ty ->
+      let vars = free_variables ty in
+      List.iter
+        (function {desc = Tvar (Some "_")} as ty ->
+            if List.memq ty vars then set_type_desc ty (Tvar None)
+          | _ -> ())
+        params
+  | None -> ()
+  end;
+
+  List.iter add_alias params;
+  List.iter mark_loops params;
+  List.iter check_name_of_type (List.map proxy params);
+  let ty_manifest =
+    match decl.type_manifest with
+    | None -> None
+    | Some ty ->
+        let ty =
+          (* Special hack to hide variant name *)
+          match repr ty with {desc=Tvariant row} ->
+            let row = row_repr row in
+            begin match row.row_name with
+              Some (Pident id', _) when Ident.same id id' ->
+                newgenty (Tvariant {row with row_name = None})
+            | _ -> ty
+            end
+          | _ -> ty
+        in
+        mark_loops ty;
+        Some ty
+  in
+  begin match decl.type_kind with
+  | Type_abstract -> ()
+  | Type_variant (cstrs, _rep) ->
+      List.iter
+        (fun c ->
+           mark_loops_constructor_arguments c.cd_args;
+           Option.iter mark_loops c.cd_res)
+        cstrs
+  | Type_record(l, _rep) ->
+      List.iter (fun l -> mark_loops l.ld_type) l
+  | Type_open -> ()
+  end;
+
+  let type_param =
+    function
+    | Otyp_var (_, id) -> id
+    | _ -> "?"
+  in
+  let type_defined decl =
+    let abstr =
+      match decl.type_kind with
+        Type_abstract ->
+          decl.type_manifest = None || decl.type_private = Private
+      | Type_record _ ->
+          decl.type_private = Private
+      | Type_variant (tll, _rep) ->
+          decl.type_private = Private ||
+          List.exists (fun cd -> cd.cd_res <> None) tll
+      | Type_open ->
+          decl.type_manifest = None
+    in
+    let vari =
+      List.map2
+        (fun ty v ->
+          let is_var = is_Tvar (repr ty) in
+          if abstr || not is_var then
+            let inj =
+              decl.type_kind = Type_abstract && Variance.mem Inj v &&
+              match decl.type_manifest with
+              | None -> true
+              | Some ty -> (* only abstract or private row types *)
+                  decl.type_private = Private &&
+                  Btype.is_constr_row ~allow_ident:true (Btype.row_of_type ty)
+            and (co, cn) = Variance.get_upper v in
+            (if not cn then Covariant else
+             if not co then Contravariant else NoVariance),
+            (if inj then Injective else NoInjectivity)
+          else (NoVariance, NoInjectivity))
+        decl.type_params decl.type_variance
+    in
+    (Ident.name id,
+     List.map2 (fun ty cocn -> type_param (tree_of_typexp false ty), cocn)
+       params vari)
+  in
+  let tree_of_manifest ty1 =
+    match ty_manifest with
+    | None -> ty1
+    | Some ty -> Otyp_manifest (tree_of_typexp false ty, ty1)
+  in
+  let (name, args) = type_defined decl in
+  let constraints = tree_of_constraints params in
+  let ty, priv, unboxed =
+    match decl.type_kind with
+    | Type_abstract ->
+        begin match ty_manifest with
+        | None -> (Otyp_abstract, Public, false)
+        | Some ty ->
+            tree_of_typexp false ty, decl.type_private, false
+        end
+    | Type_variant (cstrs, rep) ->
+        tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)),
+        decl.type_private,
+        (rep = Variant_unboxed)
+    | Type_record(lbls, rep) ->
+        tree_of_manifest (Otyp_record (List.map tree_of_label lbls)),
+        decl.type_private,
+        (match rep with Record_unboxed _ -> true | _ -> false)
+    | Type_open ->
+        tree_of_manifest Otyp_open,
+        decl.type_private,
+        false
+  in
+    { otype_name = name;
+      otype_params = args;
+      otype_type = ty;
+      otype_private = priv;
+      otype_immediate = Type_immediacy.of_attributes decl.type_attributes;
+      otype_unboxed = unboxed;
+      otype_cstrs = constraints }
+
+and tree_of_constructor_arguments = function
+  | Cstr_tuple l -> tree_of_typlist false l
+  | Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ]
+
+and tree_of_constructor cd =
+  let name = Ident.name cd.cd_id in
+  let arg () = tree_of_constructor_arguments cd.cd_args in
+  match cd.cd_res with
+  | None -> (name, arg (), None)
+  | Some res ->
+      let nm = !names in
+      names := [];
+      let ret = tree_of_typexp false res in
+      let args = arg () in
+      names := nm;
+      (name, args, Some ret)
+
+and tree_of_label l =
+  (Ident.name l.ld_id, l.ld_mutable = Mutable, tree_of_typexp false l.ld_type)
+
+let constructor ppf c =
+  reset_except_context ();
+  !Oprint.out_constr ppf (tree_of_constructor c)
+
+let label ppf l =
+  reset_except_context ();
+  !Oprint.out_label ppf (tree_of_label l)
+
+let tree_of_type_declaration id decl rs =
+  Osig_type (tree_of_type_decl id decl, tree_of_rec rs)
+
+let type_declaration id ppf decl =
+  !Oprint.out_sig_item ppf (tree_of_type_declaration id decl Trec_first)
+
+let constructor_arguments ppf a =
+  let tys = tree_of_constructor_arguments a in
+  !Oprint.out_type ppf (Otyp_tuple tys)
+
+(* Print an extension declaration *)
+
+let extension_constructor_args_and_ret_type_subtree ext_args ext_ret_type =
+  match ext_ret_type with
+  | None -> (tree_of_constructor_arguments ext_args, None)
+  | Some res ->
+    let nm = !names in
+    names := [];
+    let ret = tree_of_typexp false res in
+    let args = tree_of_constructor_arguments ext_args in
+    names := nm;
+    (args, Some ret)
+
+let tree_of_extension_constructor id ext es =
+  reset_except_context ();
+  let ty_name = Path.name ext.ext_type_path in
+  let ty_params = filter_params ext.ext_type_params in
+  List.iter add_alias ty_params;
+  List.iter mark_loops ty_params;
+  List.iter check_name_of_type (List.map proxy ty_params);
+  mark_loops_constructor_arguments ext.ext_args;
+  Option.iter mark_loops ext.ext_ret_type;
+  let type_param =
+    function
+    | Otyp_var (_, id) -> id
+    | _ -> "?"
+  in
+  let ty_params =
+    List.map (fun ty -> type_param (tree_of_typexp false ty)) ty_params
+  in
+  let name = Ident.name id in
+  let args, ret =
+    extension_constructor_args_and_ret_type_subtree
+      ext.ext_args
+      ext.ext_ret_type
+  in
+  let ext =
+    { oext_name = name;
+      oext_type_name = ty_name;
+      oext_type_params = ty_params;
+      oext_args = args;
+      oext_ret_type = ret;
+      oext_private = ext.ext_private }
+  in
+  let es =
+    match es with
+        Text_first -> Oext_first
+      | Text_next -> Oext_next
+      | Text_exception -> Oext_exception
+  in
+    Osig_typext (ext, es)
+
+let extension_constructor id ppf ext =
+  !Oprint.out_sig_item ppf (tree_of_extension_constructor id ext Text_first)
+
+let extension_only_constructor id ppf ext =
+  reset_except_context ();
+  let name = Ident.name id in
+  let args, ret =
+    extension_constructor_args_and_ret_type_subtree
+      ext.ext_args
+      ext.ext_ret_type
+  in
+  Format.fprintf ppf "@[<hv>%a@]"
+    !Oprint.out_constr (name, args, ret)
+
+(* Print a value declaration *)
+
+let tree_of_value_description id decl =
+  (* Format.eprintf "@[%a@]@." raw_type_expr decl.val_type; *)
+  let id = Ident.name id in
+  let ty = tree_of_type_scheme decl.val_type in
+  let vd =
+    { oval_name = id;
+      oval_type = ty;
+      oval_prims = [];
+      oval_attributes = [] }
+  in
+  let vd =
+    match decl.val_kind with
+    | Val_prim p -> Primitive.print p vd
+    | _ -> vd
+  in
+  Osig_value vd
+
+let value_description id ppf decl =
+  !Oprint.out_sig_item ppf (tree_of_value_description id decl)
+
+(* Print a class type *)
+
+let method_type (_, kind, ty) =
+  match field_kind_repr kind, repr ty with
+    Fpresent, {desc=Tpoly(ty, tyl)} -> (ty, tyl)
+  | _       , ty                    -> (ty, [])
+
+let tree_of_metho sch concrete csil (lab, kind, ty) =
+  if lab <> dummy_method then begin
+    let kind = field_kind_repr kind in
+    let priv = kind <> Fpresent in
+    let virt = not (Concr.mem lab concrete) in
+    let (ty, tyl) = method_type (lab, kind, ty) in
+    let tty = tree_of_typexp sch ty in
+    remove_names tyl;
+    Ocsg_method (lab, priv, virt, tty) :: csil
+  end
+  else csil
+
+let rec prepare_class_type params = function
+  | Cty_constr (_p, tyl, cty) ->
+      let sty = Ctype.self_type cty in
+      if List.memq (proxy sty) !visited_objects
+      || not (List.for_all is_Tvar params)
+      || List.exists (deep_occur sty) tyl
+      then prepare_class_type params cty
+      else List.iter mark_loops tyl
+  | Cty_signature sign ->
+      let sty = repr sign.csig_self in
+      (* Self may have a name *)
+      let px = proxy sty in
+      if List.memq px !visited_objects then add_alias sty
+      else visited_objects := px :: !visited_objects;
+      let (fields, _) =
+        Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
+      in
+      List.iter (fun met -> mark_loops (fst (method_type met))) fields;
+      Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.csig_vars
+  | Cty_arrow (_, ty, cty) ->
+      mark_loops ty;
+      prepare_class_type params cty
+
+let rec tree_of_class_type sch params =
+  function
+  | Cty_constr (p', tyl, cty) ->
+      let sty = Ctype.self_type cty in
+      if List.memq (proxy sty) !visited_objects
+      || not (List.for_all is_Tvar params)
+      then
+        tree_of_class_type sch params cty
+      else
+        let namespace = Namespace.best_class_namespace p' in
+        Octy_constr (tree_of_path namespace p', tree_of_typlist true tyl)
+  | Cty_signature sign ->
+      let sty = repr sign.csig_self in
+      let self_ty =
+        if is_aliased sty then
+          Some (Otyp_var (false, name_of_type new_name (proxy sty)))
+        else None
+      in
+      let (fields, _) =
+        Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
+      in
+      let csil = [] in
+      let csil =
+        List.fold_left
+          (fun csil (ty1, ty2) -> Ocsg_constraint (ty1, ty2) :: csil)
+          csil (tree_of_constraints params)
+      in
+      let all_vars =
+        Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.csig_vars []
+      in
+      (* Consequence of PR#3607: order of Map.fold has changed! *)
+      let all_vars = List.rev all_vars in
+      let csil =
+        List.fold_left
+          (fun csil (l, m, v, t) ->
+            Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp sch t)
+            :: csil)
+          csil all_vars
+      in
+      let csil =
+        List.fold_left (tree_of_metho sch sign.csig_concr) csil fields
+      in
+      Octy_signature (self_ty, List.rev csil)
+  | Cty_arrow (l, ty, cty) ->
+      let lab =
+        if !print_labels || is_optional l then string_of_label l else ""
+      in
+      let tr =
+       if is_optional l then
+         match (repr ty).desc with
+         | Tconstr(path, [ty], _) when Path.same path Predef.path_option ->
+             tree_of_typexp sch ty
+         | _ -> Otyp_stuff "<hidden>"
+       else tree_of_typexp sch ty in
+      Octy_arrow (lab, tr, tree_of_class_type sch params cty)
+
+let class_type ppf cty =
+  reset ();
+  prepare_class_type [] cty;
+  !Oprint.out_class_type ppf (tree_of_class_type false [] cty)
+
+let tree_of_class_param param variance =
+  (match tree_of_typexp true param with
+    Otyp_var (_, s) -> s
+  | _ -> "?"),
+  if is_Tvar (repr param) then Asttypes.(NoVariance, NoInjectivity)
+                          else variance
+
+let class_variance =
+  let open Variance in let open Asttypes in
+  List.map (fun v ->
+    (if not (mem May_pos v) then Contravariant else
+     if not (mem May_neg v) then Covariant else NoVariance),
+    NoInjectivity)
+
+let tree_of_class_declaration id cl rs =
+  let params = filter_params cl.cty_params in
+
+  reset_except_context ();
+  List.iter add_alias params;
+  prepare_class_type params cl.cty_type;
+  let sty = Ctype.self_type cl.cty_type in
+  List.iter mark_loops params;
+
+  List.iter check_name_of_type (List.map proxy params);
+  if is_aliased sty then check_name_of_type (proxy sty);
+
+  let vir_flag = cl.cty_new = None in
+  Osig_class
+    (vir_flag, Ident.name id,
+     List.map2 tree_of_class_param params (class_variance cl.cty_variance),
+     tree_of_class_type true params cl.cty_type,
+     tree_of_rec rs)
+
+let class_declaration id ppf cl =
+  !Oprint.out_sig_item ppf (tree_of_class_declaration id cl Trec_first)
+
+let tree_of_cltype_declaration id cl rs =
+  let params = List.map repr cl.clty_params in
+
+  reset_except_context ();
+  List.iter add_alias params;
+  prepare_class_type params cl.clty_type;
+  let sty = Ctype.self_type cl.clty_type in
+  List.iter mark_loops params;
+
+  List.iter check_name_of_type (List.map proxy params);
+  if is_aliased sty then check_name_of_type (proxy sty);
+
+  let sign = Ctype.signature_of_class_type cl.clty_type in
+
+  let virt =
+    let (fields, _) =
+      Ctype.flatten_fields (Ctype.object_fields sign.csig_self) in
+    List.exists
+      (fun (lab, _, _) ->
+         not (lab = dummy_method || Concr.mem lab sign.csig_concr))
+      fields
+    || Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.csig_vars false
+  in
+
+  Osig_class_type
+    (virt, Ident.name id,
+     List.map2 tree_of_class_param params (class_variance cl.clty_variance),
+     tree_of_class_type true params cl.clty_type,
+     tree_of_rec rs)
+
+let cltype_declaration id ppf cl =
+  !Oprint.out_sig_item ppf (tree_of_cltype_declaration id cl Trec_first)
+
+(* Print a module type *)
+
+let wrap_env fenv ftree arg =
+  (* We save the current value of the short-path cache *)
+  (* From keys *)
+  let env = !printing_env in
+  let old_pers = !printing_pers in
+  (* to data *)
+  let old_map = !printing_map in
+  let old_depth = !printing_depth in
+  let old_cont = !printing_cont in
+  set_printing_env (fenv env);
+  let tree = ftree arg in
+  if !Clflags.real_paths
+     || same_printing_env env then ()
+   (* our cached key is still live in the cache, and we want to keep all
+      progress made on the computation of the [printing_map] *)
+  else begin
+    (* we restore the snapshotted cache before calling set_printing_env *)
+    printing_old := env;
+    printing_pers := old_pers;
+    printing_depth := old_depth;
+    printing_cont := old_cont;
+    printing_map := old_map
+  end;
+  set_printing_env env;
+  tree
+
+let dummy =
+  {
+    type_params = [];
+    type_arity = 0;
+    type_kind = Type_abstract;
+    type_private = Public;
+    type_manifest = None;
+    type_variance = [];
+    type_separability = [];
+    type_is_newtype = false;
+    type_expansion_scope = Btype.lowest_level;
+    type_loc = Location.none;
+    type_attributes = [];
+    type_immediate = Unknown;
+    type_unboxed_default = false;
+    type_uid = Uid.internal_not_actually_unique;
+  }
+
+(** we hide items being defined from short-path to avoid shortening
+    [type t = Path.To.t] into [type t = t].
+*)
+
+let ident_sigitem = function
+  | Types.Sig_type(ident,_,_,_) ->  {hide=true;ident}
+  | Types.Sig_class(ident,_,_,_)
+  | Types.Sig_class_type (ident,_,_,_)
+  | Types.Sig_module(ident,_, _,_,_)
+  | Types.Sig_value (ident,_,_)
+  | Types.Sig_modtype (ident,_,_)
+  | Types.Sig_typext (ident,_,_,_)   ->  {hide=false; ident }
+
+let hide ids env =
+  let hide_id id env =
+    (* Global idents cannot be renamed *)
+    if id.hide && not (Ident.global id.ident) then
+      Env.add_type ~check:false (Ident.rename id.ident) dummy env
+    else env
+  in
+  List.fold_right hide_id ids env
+
+let with_hidden_items ids f =
+  let with_hidden_in_printing_env ids f =
+    wrap_env (hide ids) (Naming_context.with_hidden ids) f
+  in
+  if not !Clflags.real_paths then
+    with_hidden_in_printing_env ids f
+  else
+    Naming_context.with_hidden ids f
+
+
+let add_sigitem env x =
+  Env.add_signature (Signature_group.flatten x) env
+
+let rec tree_of_modtype ?(ellipsis=false) = function
+  | Mty_ident p ->
+      Omty_ident (tree_of_path Module_type p)
+  | Mty_signature sg ->
+      Omty_signature (if ellipsis then [Osig_ellipsis]
+                      else tree_of_signature sg)
+  | Mty_functor(param, ty_res) ->
+      let param, env =
+        tree_of_functor_parameter param
+      in
+      let res = wrap_env env (tree_of_modtype ~ellipsis) ty_res in
+      Omty_functor (param, res)
+  | Mty_alias p ->
+      Omty_alias (tree_of_path Module p)
+
+and tree_of_functor_parameter = function
+  | Unit ->
+      None, fun k -> k
+  | Named (param, ty_arg) ->
+      let name, env =
+        match param with
+        | None -> None, fun env -> env
+        | Some id ->
+            Some (Ident.name id),
+            Env.add_module ~arg:true id Mp_present ty_arg
+      in
+      Some (name, tree_of_modtype ~ellipsis:false ty_arg), env
+
+and tree_of_signature sg =
+  wrap_env (fun env -> env)(fun sg ->
+      let tree_groups = tree_of_signature_rec !printing_env sg in
+      List.concat_map (fun (_env,l) -> List.map snd l) tree_groups
+    ) sg
+
+and tree_of_signature_rec env' sg =
+  let structured = List.of_seq (Signature_group.seq sg) in
+  let collect_trees_of_rec_group group =
+    let env = !printing_env in
+    let env', group_trees =
+      Naming_context.with_ctx
+        (fun () -> trees_of_recursive_sigitem_group env group)
+    in
+    set_printing_env env';
+    (env, group_trees) in
+  set_printing_env env';
+  List.map collect_trees_of_rec_group structured
+
+and trees_of_recursive_sigitem_group env
+    (syntactic_group: Signature_group.rec_group) =
+  let display (x:Signature_group.sig_item) = x.src, tree_of_sigitem x.src in
+  let env = Env.add_signature syntactic_group.pre_ghosts env in
+  match syntactic_group.group with
+  | Not_rec x -> add_sigitem env x, [display x]
+  | Rec_group items ->
+      let ids = List.map (fun x -> ident_sigitem x.Signature_group.src) items in
+      List.fold_left add_sigitem env items,
+      with_hidden_items ids (fun () -> List.map display items)
+
+and tree_of_sigitem = function
+  | Sig_value(id, decl, _) ->
+      tree_of_value_description id decl
+  | Sig_type(id, decl, rs, _) ->
+      tree_of_type_declaration id decl rs
+  | Sig_typext(id, ext, es, _) ->
+      tree_of_extension_constructor id ext es
+  | Sig_module(id, _, md, rs, _) ->
+      let ellipsis =
+        List.exists (function
+          | Parsetree.{attr_name = {txt="..."}; attr_payload = PStr []} -> true
+          | _ -> false)
+          md.md_attributes in
+      tree_of_module id md.md_type rs ~ellipsis
+  | Sig_modtype(id, decl, _) ->
+      tree_of_modtype_declaration id decl
+  | Sig_class(id, decl, rs, _) ->
+      tree_of_class_declaration id decl rs
+  | Sig_class_type(id, decl, rs, _) ->
+      tree_of_cltype_declaration id decl rs
+
+and tree_of_modtype_declaration id decl =
+  let mty =
+    match decl.mtd_type with
+    | None -> Omty_abstract
+    | Some mty -> tree_of_modtype mty
+  in
+  Osig_modtype (Ident.name id, mty)
+
+and tree_of_module id ?ellipsis mty rs =
+  Osig_module (Ident.name id, tree_of_modtype ?ellipsis mty, tree_of_rec rs)
+
+let rec functor_parameters ~sep custom_printer = function
+  | [] -> ignore
+  | [id,param] ->
+      Format.dprintf "%t%t"
+        (custom_printer param)
+        (functor_param ~sep ~custom_printer id [])
+  | (id,param) :: q ->
+      Format.dprintf "%t%a%t"
+        (custom_printer param)
+        sep ()
+        (functor_param ~sep ~custom_printer id q)
+and functor_param ~sep ~custom_printer id q =
+  match id with
+  | None -> functor_parameters ~sep custom_printer q
+  | Some id ->
+      Naming_context.with_arg id
+        (fun () -> functor_parameters ~sep custom_printer q)
+
+
+
+let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty)
+let modtype_declaration id ppf decl =
+  !Oprint.out_sig_item ppf (tree_of_modtype_declaration id decl)
+
+(* For the toplevel: merge with tree_of_signature? *)
+
+(* Refresh weak variable map in the toplevel *)
+let refresh_weak () =
+  let refresh t name (m,s) =
+    if is_non_gen true (repr t) then
+      begin
+        TypeMap.add t name m,
+        String.Set.add name s
+      end
+    else m, s in
+  let m, s =
+    TypeMap.fold refresh !weak_var_map (TypeMap.empty ,String.Set.empty)  in
+  named_weak_vars := s;
+  weak_var_map := m
+
+let print_items showval env x =
+  refresh_weak();
+  reset_naming_context ();
+  Conflicts.reset ();
+  let extend_val env (sigitem,outcome) = outcome, showval env sigitem in
+  let post_process (env,l) = List.map (extend_val env) l in
+  List.concat_map post_process @@ tree_of_signature_rec env x
+
+(* Print a signature body (used by -i when compiling a .ml) *)
+
+let print_signature ppf tree =
+  fprintf ppf "@[<v>%a@]" !Oprint.out_signature tree
+
+let signature ppf sg =
+  fprintf ppf "%a" print_signature (tree_of_signature sg)
+
+(* Print a signature body (used by -i when compiling a .ml) *)
+let printed_signature sourcefile ppf sg =
+  (* we are tracking any collision event for warning 63 *)
+  Conflicts.reset ();
+  reset_naming_context ();
+  let t = tree_of_signature sg in
+  if Warnings.(is_active @@ Erroneous_printed_signature "")
+  && Conflicts.exists ()
+  then begin
+    let conflicts = Format.asprintf "%t" Conflicts.print_explanations in
+    Location.prerr_warning (Location.in_file sourcefile)
+      (Warnings.Erroneous_printed_signature conflicts);
+    Warnings.check_fatal ()
+  end;
+  fprintf ppf "%a" print_signature t
+
+(* Print an unification error *)
+
+let same_path t t' =
+  let t = repr t and t' = repr t' in
+  t == t' ||
+  match t.desc, t'.desc with
+    Tconstr(p,tl,_), Tconstr(p',tl',_) ->
+      let (p1, s1) = best_type_path p and (p2, s2)  = best_type_path p' in
+      begin match s1, s2 with
+        Nth n1, Nth n2 when n1 = n2 -> true
+      | (Id | Map _), (Id | Map _) when Path.same p1 p2 ->
+          let tl = apply_subst s1 tl and tl' = apply_subst s2 tl' in
+          List.length tl = List.length tl' &&
+          List.for_all2 same_type tl tl'
+      | _ -> false
+      end
+  | _ ->
+      false
+
+type 'a diff = Same of 'a | Diff of 'a * 'a
+
+let trees_of_type_expansion (t,t') =
+  if same_path t t'
+  then begin add_delayed (proxy t); Same (tree_of_typexp false t) end
+  else
+    let t' = if proxy t == proxy t' then unalias t' else t' in
+    (* beware order matter due to side effect,
+       e.g. when printing object types *)
+    let first = tree_of_typexp false t in
+    let second = tree_of_typexp false t' in
+    if first = second then Same first
+    else Diff(first,second)
+
+let type_expansion ppf = function
+  | Same t -> !Oprint.out_type ppf t
+  | Diff(t,t') ->
+      fprintf ppf "@[<2>%a@ =@ %a@]"  !Oprint.out_type t  !Oprint.out_type t'
+
+let trees_of_trace = List.map (Errortrace.map_diff trees_of_type_expansion)
+
+let trees_of_type_path_expansion (tp,tp') =
+  if Path.same tp tp' then Same(tree_of_path Type tp) else
+    Diff(tree_of_path Type tp, tree_of_path Type tp')
+
+let type_path_expansion ppf = function
+  | Same p -> !Oprint.out_ident ppf p
+  | Diff(p,p') ->
+      fprintf ppf "@[<2>%a@ =@ %a@]"
+        !Oprint.out_ident p
+        !Oprint.out_ident p'
+
+let rec trace fst txt ppf = function
+  | {Errortrace.got; expected} :: rem ->
+      if not fst then fprintf ppf "@,";
+      fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@] %a"
+       type_expansion got txt type_expansion expected
+       (trace false txt) rem
+  | _ -> ()
+
+type printing_status =
+  | Discard
+  | Keep
+  | Optional_refinement
+  (** An [Optional_refinement] printing status is attributed to trace
+      elements that are focusing on a new subpart of a structural type.
+      Since the whole type should have been printed earlier in the trace,
+      we only print those elements if they are the last printed element
+      of a trace, and there is no explicit explanation for the
+      type error.
+  *)
+
+let diff_printing_status { Errortrace.got=t1, t1'; expected=t2, t2'} =
+  if  is_constr_row ~allow_ident:true t1'
+   || is_constr_row ~allow_ident:true t2'
+  then Discard
+  else if same_path t1 t1' && same_path t2 t2' then Optional_refinement
+  else Keep
+
+(* A configuration type that controls which trace we print.  This could be
+   exposed, but we instead expose three separate
+   [report_{unification,equality,moregen}_error] functions.  This also lets us
+   give the unification case an extra optional argument without adding it to the
+   equality and moregen cases. *)
+type 'variety trace_format =
+  | Unification : Errortrace.unification trace_format
+  | Equality    : Errortrace.comparison  trace_format
+  | Moregen     : Errortrace.comparison  trace_format
+
+let incompatibility_phrase (type variety) : variety trace_format -> string =
+  function
+  | Unification -> "is not compatible with type"
+  | Equality    -> "is not equal to type"
+  | Moregen     -> "is not compatible with type"
+
+let printing_status = function
+  | Errortrace.Diff d -> diff_printing_status d
+  | Errortrace.Escape {kind = Constraint} -> Keep
+  | _ -> Keep
+
+(** Flatten the trace and remove elements that are always discarded
+    during printing *)
+
+(* Takes [printing_status] to change behavior for [Subtype] *)
+let prepare_any_trace printing_status tr =
+  let clean_trace x l = match printing_status x with
+    | Keep -> x :: l
+    | Optional_refinement when l = [] -> [x]
+    | Optional_refinement | Discard -> l
+  in
+  match tr with
+  | [] -> []
+  | elt :: rem -> elt :: List.fold_right clean_trace rem []
+
+let prepare_trace f tr =
+  prepare_any_trace printing_status (Errortrace.flatten f tr)
+
+(** Keep elements that are not [Diff _ ] and take the decision
+    for the last element, require a prepared trace *)
+let rec filter_trace trace_format keep_last = function
+  | [] -> []
+  | [Errortrace.Diff d as elt]
+    when printing_status elt = Optional_refinement ->
+    if keep_last then [d] else []
+  | Errortrace.Diff d :: rem -> d :: filter_trace trace_format keep_last rem
+  | _ :: rem -> filter_trace trace_format keep_last rem
+
+let type_path_list =
+  Format.pp_print_list ~pp_sep:(fun ppf () -> Format.pp_print_break ppf 2 0)
+    type_path_expansion
+
+(* Hide variant name and var, to force printing the expanded type *)
+let hide_variant_name t =
+  match repr t with
+  | {desc = Tvariant row} as t when (row_repr row).row_name <> None ->
+      newty2 t.level
+        (Tvariant {(row_repr row) with row_name = None;
+                   row_more = newvar2 (row_more row).level})
+  | _ -> t
+
+let prepare_expansion (t, t') =
+  let t' = hide_variant_name t' in
+  mark_loops t;
+  if not (same_path t t') then mark_loops t';
+  (t, t')
+
+let may_prepare_expansion compact (t, t') =
+  match (repr t').desc with
+    Tvariant _ | Tobject _ when compact ->
+      mark_loops t; (t, t)
+  | _ -> prepare_expansion (t, t')
+
+let print_path p = Format.dprintf "%a" !Oprint.out_ident (tree_of_path Type p)
+
+let print_tag ppf = fprintf ppf "`%s"
+
+let print_tags =
+  let comma ppf () = Format.fprintf ppf ",@ " in
+  Format.pp_print_list ~pp_sep:comma print_tag
+
+let is_unit env ty =
+  match (Ctype.expand_head env ty).desc with
+  | Tconstr (p, _, _) -> Path.same p Predef.path_unit
+  | _ -> false
+
+let unifiable env ty1 ty2 =
+  let snap = Btype.snapshot () in
+  let res =
+    try Ctype.unify env ty1 ty2; true
+    with Unify _ -> false
+  in
+  Btype.backtrack snap;
+  res
+
+let explanation_diff env t3 t4 : (Format.formatter -> unit) option =
+  match t3.desc, t4.desc with
+  | Tarrow (_, ty1, ty2, _), _
+    when is_unit env ty1 && unifiable env ty2 t4 ->
+      Some (fun ppf ->
+        fprintf ppf
+          "@,@[Hint: Did you forget to provide `()' as argument?@]")
+  | _, Tarrow (_, ty1, ty2, _)
+    when is_unit env ty1 && unifiable env t3 ty2 ->
+      Some (fun ppf ->
+        fprintf ppf
+          "@,@[Hint: Did you forget to wrap the expression using \
+           `fun () ->'?@]")
+  | _ ->
+      None
+
+let explain_fixed_row_case ppf = function
+  | Errortrace.Cannot_be_closed ->
+      fprintf ppf "it cannot be closed"
+  | Errortrace.Cannot_add_tags tags ->
+      fprintf ppf "it may not allow the tag(s) %a" print_tags tags
+
+let explain_fixed_row pos expl = match expl with
+  | Fixed_private ->
+    dprintf "The %a variant type is private" Errortrace.print_pos pos
+  | Univar x ->
+    dprintf "The %a variant type is bound to the universal type variable %a"
+      Errortrace.print_pos pos type_expr x
+  | Reified p ->
+    dprintf "The %a variant type is bound to %t"
+      Errortrace.print_pos pos (print_path p)
+  | Rigid -> ignore
+
+let explain_variant (type variety) : variety Errortrace.variant -> _ = function
+  (* Common *)
+  | Errortrace.Incompatible_types_for s ->
+      Some(dprintf "@,Types for tag `%s are incompatible" s)
+  (* Unification *)
+  | Errortrace.No_intersection ->
+      Some(dprintf "@,These two variant types have no intersection")
+  | Errortrace.No_tags(pos,fields) -> Some(
+      dprintf
+        "@,@[The %a variant type does not allow tag(s)@ @[<hov>%a@]@]"
+        Errortrace.print_pos pos
+        print_tags (List.map fst fields)
+    )
+  | Errortrace.Fixed_row (pos,
+                          k,
+                          (Univar _ | Reified _ | Fixed_private as e)) ->
+      Some (
+        dprintf "@,@[%t,@ %a@]" (explain_fixed_row pos e)
+          explain_fixed_row_case k
+      )
+  | Errortrace.Fixed_row (_,_, Rigid) ->
+      (* this case never happens *)
+      None
+  (* Equality & Moregen *)
+  | Errortrace.Openness pos ->
+    Some(dprintf "@,The %a variant type is open and the %a is not"
+           Errortrace.print_pos pos
+           Errortrace.print_pos (Errortrace.swap_position pos))
+
+let explain_escape pre = function
+  | Errortrace.Univ u -> Some(
+      dprintf "%t@,The universal variable %a would escape its scope"
+        pre type_expr u)
+  | Errortrace.Constructor p -> Some(
+      dprintf
+        "%t@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
+        pre path p
+    )
+  | Errortrace.Module_type p -> Some(
+      dprintf
+        "%t@,@[The module type@;<1 2>%a@ would escape its scope@]"
+        pre path p
+    )
+  | Errortrace.Equation (_,t) -> Some(
+      dprintf "%t @,@[<hov>This instance of %a is ambiguous:@ %s@]"
+        pre type_expr t
+        "it would escape the scope of its equation"
+    )
+  | Errortrace.Self ->
+      Some (dprintf "%t@,Self type cannot escape its class" pre)
+  | Errortrace.Constraint ->
+      None
+
+let explain_object (type variety) : variety Errortrace.obj -> _ = function
+  | Errortrace.Missing_field (pos,f) -> Some(
+      dprintf "@,@[The %a object type has no method %s@]"
+        Errortrace.print_pos pos f
+    )
+  | Errortrace.Abstract_row pos -> Some(
+      dprintf
+        "@,@[The %a object type has an abstract row, it cannot be closed@]"
+        Errortrace.print_pos pos
+    )
+  | Errortrace.Self_cannot_be_closed ->
+      Some (dprintf "@,Self type cannot be unified with a closed object type")
+
+let explanation (type variety) intro prev env
+  : ('a, variety) Errortrace.elt -> _ = function
+  | Errortrace.Diff { Errortrace.got = _,s; expected = _,t } ->
+    explanation_diff env s t
+  | Errortrace.Escape {kind;context} ->
+    let pre =
+      match context, kind, prev with
+      | Some ctx, _, _ ->
+        dprintf "@[%t@;<1 2>%a@]" intro type_expr ctx
+      | None, Univ _, Some(Errortrace.Incompatible_fields {name; diff}) ->
+        dprintf "@,@[The method %s has type@ %a,@ \
+                 but the expected method type was@ %a@]"
+          name type_expr diff.got type_expr diff.expected
+      | _ -> ignore
+    in
+    explain_escape pre kind
+  | Errortrace.Incompatible_fields { name; _ } ->
+    Some(dprintf "@,Types for method %s are incompatible" name)
+  | Errortrace.Variant v ->
+    explain_variant v
+  | Errortrace.Obj o ->
+    explain_object o
+  | Errortrace.Rec_occur(x,y) ->
+    reset_and_mark_loops y;
+    begin match x.desc with
+    | Tvar _ | Tunivar _  ->
+        Some(dprintf "@,@[<hov>The type variable %a occurs inside@ %a@]"
+               type_expr x type_expr y)
+    | _ ->
+        (* We had a delayed unification of the type variable with
+           a non-variable after the occur check. *)
+        Some ignore
+        (* There is no need to search further for an explanation, but
+           we don't want to print a message of the form:
+             {[ The type int occurs inside int list -> 'a |}
+        *)
+    end
+
+let mismatch intro env trace =
+  Errortrace.explain trace (fun ~prev h -> explanation intro prev env h)
+
+let explain mis ppf =
+  match mis with
+  | None -> ()
+  | Some explain -> explain ppf
+
+let warn_on_missing_def env ppf t =
+  match t.desc with
+  | Tconstr (p,_,_) ->
+    begin
+      try
+        ignore(Env.find_type p env : Types.type_declaration)
+      with Not_found ->
+        fprintf ppf
+          "@,@[%a is abstract because no corresponding cmi file was found \
+           in path.@]" path p
+    end
+  | _ -> ()
+
+let prepare_expansion_head empty_tr = function
+  | Errortrace.Diff d ->
+      Some (Errortrace.map_diff (may_prepare_expansion empty_tr) d)
+  | _ -> None
+
+let head_error_printer txt_got txt_but = function
+  | None -> ignore
+  | Some d ->
+      let d = Errortrace.map_diff trees_of_type_expansion d in
+      dprintf "%t@;<1 2>%a@ %t@;<1 2>%a"
+        txt_got type_expansion d.Errortrace.got
+        txt_but type_expansion d.Errortrace.expected
+
+let warn_on_missing_defs env ppf = function
+  | None -> ()
+  | Some {Errortrace.got=te1,_; expected=te2,_ } ->
+      warn_on_missing_def env ppf te1;
+      warn_on_missing_def env ppf te2
+
+let error trace_format env tr txt1 ppf txt2 ty_expect_explanation =
+  reset ();
+  let tr = prepare_trace (fun t t' -> t, hide_variant_name t') tr in
+  let mis = mismatch txt1 env tr in
+  match tr with
+  | [] -> assert false
+  | elt :: tr ->
+    try
+      print_labels := not !Clflags.classic;
+      let tr = filter_trace trace_format (mis = None) tr in
+      let head = prepare_expansion_head (tr=[]) elt in
+      let tr = List.map (Errortrace.map_diff prepare_expansion) tr in
+      let head_error = head_error_printer txt1 txt2 head in
+      let tr = trees_of_trace tr in
+      fprintf ppf
+        "@[<v>\
+          @[%t%t@]%a%t\
+         @]"
+        head_error
+        ty_expect_explanation
+        (trace false (incompatibility_phrase trace_format)) tr
+        (explain mis);
+      if env <> Env.empty
+      then warn_on_missing_defs env ppf head;
+      Conflicts.print_explanations ppf;
+      print_labels := true
+    with exn ->
+      print_labels := true;
+      raise exn
+
+let report_error trace_format ppf env tr
+      ?(type_expected_explanation = fun _ -> ())
+      txt1 txt2 =
+  wrap_printing_env env (fun () -> error trace_format env tr txt1 ppf txt2
+                                     type_expected_explanation)
+    ~error:true
+
+let report_unification_error =
+  report_error Unification
+let report_equality_error =
+  report_error Equality ?type_expected_explanation:None
+let report_moregen_error =
+  report_error Moregen ?type_expected_explanation:None
+
+module Subtype = struct
+  (* There's a frustrating amount of code duplication between this module and
+     the outside code, particularly in [prepare_trace] and [filter_trace].
+     Unfortunately, [Subtype] is *just* similar enough to have code duplication,
+     while being *just* different enough (it's only [Diff]) for the abstraction
+     to be nonobvious.  Someday, perhaps... *)
+
+  let printing_status = function
+    | Errortrace.Subtype.Diff d -> diff_printing_status d
+
+  let prepare_unification_trace = prepare_trace
+
+  let prepare_trace f tr =
+    prepare_any_trace printing_status (Errortrace.Subtype.flatten f tr)
+
+  let trace filter_trace get_diff fst keep_last txt ppf tr =
+    print_labels := not !Clflags.classic;
+    try match tr with
+      | elt :: tr' ->
+        let diffed_elt = get_diff elt in
+        let tr =
+          trees_of_trace
+          @@ List.map (Errortrace.map_diff prepare_expansion)
+          @@ filter_trace keep_last tr' in
+        let tr =
+          match fst, diffed_elt with
+          | true, Some elt -> elt :: tr
+          | _, _ -> tr
+        in
+        trace fst txt ppf tr;
+        print_labels := true
+      | _ -> ()
+    with exn ->
+      print_labels := true;
+      raise exn
+
+  let filter_unification_trace = filter_trace Unification
+
+  let rec filter_subtype_trace keep_last = function
+    | [] -> []
+    | [Errortrace.Subtype.Diff d as elt]
+      when printing_status elt = Optional_refinement ->
+        if keep_last then [d] else []
+    | Errortrace.Subtype.Diff d :: rem ->
+        d :: filter_subtype_trace keep_last rem
+
+  let unification_get_diff = function
+    | Errortrace.Diff diff ->
+        Some (Errortrace.map_diff trees_of_type_expansion diff)
+    | _ -> None
+
+  let subtype_get_diff = function
+    | Errortrace.Subtype.Diff diff ->
+        Some (Errortrace.map_diff trees_of_type_expansion diff)
+
+  let report_error ppf env tr1 txt1 tr2 =
+    wrap_printing_env ~error:true env (fun () ->
+      reset ();
+      let tr1 =
+        prepare_trace (fun t t' -> prepare_expansion (t, t')) tr1
+      in
+      let tr2 =
+        prepare_unification_trace (fun t t' -> prepare_expansion (t, t')) tr2
+      in
+      let keep_first = match tr2 with
+        | [Obj _ | Variant _ | Escape _ ] | [] -> true
+        | _ -> false in
+      fprintf ppf "@[<v>%a"
+        (trace filter_subtype_trace subtype_get_diff true keep_first txt1) tr1;
+      if tr2 = [] then fprintf ppf "@]" else
+        let mis = mismatch (dprintf "Within this type") env tr2 in
+        fprintf ppf "%a%t%t@]"
+          (trace filter_unification_trace unification_get_diff false
+             (mis = None) "is not compatible with type") tr2
+          (explain mis)
+          Conflicts.print_explanations
+    )
+end
+
+let report_ambiguous_type_error ppf env tp0 tpl txt1 txt2 txt3 =
+  wrap_printing_env ~error:true env (fun () ->
+    reset ();
+    let tp0 = trees_of_type_path_expansion tp0 in
+      match tpl with
+      [] -> assert false
+    | [tp] ->
+        fprintf ppf
+          "@[%t@;<1 2>%a@ \
+             %t@;<1 2>%a\
+           @]"
+          txt1 type_path_expansion (trees_of_type_path_expansion tp)
+          txt3 type_path_expansion tp0
+    | _ ->
+        fprintf ppf
+          "@[%t@;<1 2>@[<hv>%a@]\
+             @ %t@;<1 2>%a\
+           @]"
+          txt2 type_path_list (List.map trees_of_type_path_expansion tpl)
+          txt3 type_path_expansion tp0)
+
+(* Adapt functions to exposed interface *)
+let tree_of_path = tree_of_path Other
+let tree_of_modtype = tree_of_modtype ~ellipsis:false
+let type_expansion ty ppf ty' =
+  type_expansion ppf (trees_of_type_expansion (ty,ty'))
+let tree_of_type_declaration ident td rs =
+  with_hidden_items [{hide=true; ident}]
+    (fun () -> tree_of_type_declaration ident td rs)
diff --git a/upstream/ocaml_413/typing/printtyp.mli b/upstream/ocaml_413/typing/printtyp.mli
new file mode 100644
index 0000000..01c76c8
--- /dev/null
+++ b/upstream/ocaml_413/typing/printtyp.mli
@@ -0,0 +1,219 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Printing functions *)
+
+open Format
+open Types
+open Outcometree
+
+val longident: formatter -> Longident.t -> unit
+val ident: formatter -> Ident.t -> unit
+val tree_of_path: Path.t -> out_ident
+val path: formatter -> Path.t -> unit
+val string_of_path: Path.t -> string
+
+val type_path: formatter -> Path.t -> unit
+(** Print a type path taking account of [-short-paths].
+    Calls should be within [wrap_printing_env]. *)
+
+module Out_name: sig
+  val create: string -> out_name
+  val print: out_name -> string
+end
+
+type namespace =
+  | Type
+  | Module
+  | Module_type
+  | Class
+  | Class_type
+  | Other (** Other bypasses the unique name for identifier mechanism *)
+
+val strings_of_paths: namespace -> Path.t list -> string list
+    (** Print a list of paths, using the same naming context to
+        avoid name collisions *)
+
+val raw_type_expr: formatter -> type_expr -> unit
+val string_of_label: Asttypes.arg_label -> string
+
+val wrap_printing_env: error:bool -> Env.t -> (unit -> 'a) -> 'a
+    (* Call the function using the environment for type path shortening *)
+    (* This affects all the printing functions below *)
+    (* Also, if [~error:true], then disable the loading of cmis *)
+
+module Naming_context: sig
+  val enable: bool -> unit
+  (** When contextual names are enabled, the mapping between identifiers
+      and names is ensured to be one-to-one. *)
+
+  val reset: unit -> unit
+  (** Reset the naming context *)
+end
+
+(** The [Conflicts] module keeps track of conflicts arising when attributing
+    names to identifiers and provides functions that can print explanations
+    for these conflict in error messages *)
+module Conflicts: sig
+  val exists: unit -> bool
+  (** [exists()] returns true if the current naming context renamed
+        an identifier to avoid a name collision *)
+
+  type explanation =
+    { kind: namespace;
+      name:string;
+      root_name:string;
+      location:Location.t
+    }
+
+  val list_explanations: unit -> explanation list
+(** [list_explanations()] return the list of conflict explanations
+    collected up to this point, and reset the list of collected
+    explanations *)
+
+  val print_located_explanations:
+    Format.formatter -> explanation list -> unit
+
+  val print_explanations: Format.formatter -> unit
+  (** Print all conflict explanations collected up to this point *)
+
+  val reset: unit -> unit
+end
+
+val reset: unit -> unit
+val mark_loops: type_expr -> unit
+val reset_and_mark_loops: type_expr -> unit
+val reset_and_mark_loops_list: type_expr list -> unit
+
+val type_expr: formatter -> type_expr -> unit
+val marked_type_expr: formatter -> type_expr -> unit
+(** The function [type_expr] is the safe version of the pair
+    [(typed_expr, marked_type_expr)]:
+    it takes care of marking loops in the type expression and resetting
+    type variable names before printing.
+      Contrarily, the function [marked_type_expr] should only be called on
+    type expressions whose loops have been marked or it may stackoverflow
+    (see #8860 for examples).
+ *)
+
+val constructor_arguments: formatter -> constructor_arguments -> unit
+val tree_of_type_scheme: type_expr -> out_type
+val type_sch : formatter -> type_expr -> unit
+val type_scheme: formatter -> type_expr -> unit
+(* Maxence *)
+val reset_names: unit -> unit
+val type_scheme_max: ?b_reset_names: bool ->
+        formatter -> type_expr -> unit
+(* End Maxence *)
+val tree_of_value_description: Ident.t -> value_description -> out_sig_item
+val value_description: Ident.t -> formatter -> value_description -> unit
+val label : formatter -> label_declaration -> unit
+val constructor : formatter -> constructor_declaration -> unit
+val tree_of_type_declaration:
+    Ident.t -> type_declaration -> rec_status -> out_sig_item
+val type_declaration: Ident.t -> formatter -> type_declaration -> unit
+val tree_of_extension_constructor:
+    Ident.t -> extension_constructor -> ext_status -> out_sig_item
+val extension_constructor:
+    Ident.t -> formatter -> extension_constructor -> unit
+(* Prints extension constructor with the type signature:
+     type ('a, 'b) bar += A of float
+*)
+
+val extension_only_constructor:
+    Ident.t -> formatter -> extension_constructor -> unit
+(* Prints only extension constructor without type signature:
+     A of float
+*)
+
+val tree_of_module:
+    Ident.t -> ?ellipsis:bool -> module_type -> rec_status -> out_sig_item
+val modtype: formatter -> module_type -> unit
+val signature: formatter -> signature -> unit
+val tree_of_modtype: module_type -> out_module_type
+val tree_of_modtype_declaration:
+    Ident.t -> modtype_declaration -> out_sig_item
+
+(** Print a list of functor parameters while adjusting the printing environment
+    for each functor argument.
+
+    Currently, we are disabling disambiguation for functor argument name to
+    avoid the need to track the moving association between identifiers and
+    syntactic names in situation like:
+
+    got: (X: sig module type T end) (Y:X.T) (X:sig module type T end) (Z:X.T)
+    expect: (_: sig end) (Y:X.T) (_:sig end) (Z:X.T)
+*)
+val functor_parameters:
+  sep:(Format.formatter -> unit -> unit) ->
+  ('b -> Format.formatter -> unit) ->
+  (Ident.t option * 'b) list -> Format.formatter -> unit
+
+val tree_of_signature: Types.signature -> out_sig_item list
+val tree_of_typexp: bool -> type_expr -> out_type
+val modtype_declaration: Ident.t -> formatter -> modtype_declaration -> unit
+val class_type: formatter -> class_type -> unit
+val tree_of_class_declaration:
+    Ident.t -> class_declaration -> rec_status -> out_sig_item
+val class_declaration: Ident.t -> formatter -> class_declaration -> unit
+val tree_of_cltype_declaration:
+    Ident.t -> class_type_declaration -> rec_status -> out_sig_item
+val cltype_declaration: Ident.t -> formatter -> class_type_declaration -> unit
+val type_expansion: type_expr -> Format.formatter -> type_expr -> unit
+val prepare_expansion: type_expr * type_expr -> type_expr * type_expr
+val report_ambiguous_type_error:
+    formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list ->
+    (formatter -> unit) -> (formatter -> unit) -> (formatter -> unit) -> unit
+
+val report_unification_error :
+  formatter -> Env.t ->
+  Errortrace.unification Errortrace.t ->
+  ?type_expected_explanation:(formatter -> unit) ->
+  (formatter -> unit) -> (formatter -> unit) ->
+  unit
+
+val report_equality_error :
+  formatter -> Env.t ->
+  Errortrace.comparison Errortrace.t ->
+  (formatter -> unit) -> (formatter -> unit) ->
+  unit
+
+val report_moregen_error :
+  formatter -> Env.t ->
+  Errortrace.comparison Errortrace.t ->
+  (formatter -> unit) -> (formatter -> unit) ->
+  unit
+
+module Subtype : sig
+  val report_error :
+    formatter ->
+    Env.t ->
+    Errortrace.Subtype.t ->
+    string ->
+    Errortrace.unification Errortrace.t ->
+    unit
+end
+
+(* for toploop *)
+val print_items: (Env.t -> signature_item -> 'a option) ->
+  Env.t -> signature_item list -> (out_sig_item * 'a option) list
+
+(* Simple heuristic to rewrite Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias
+   for Foo__bar. This pattern is used by the stdlib. *)
+val rewrite_double_underscore_paths: Env.t -> Path.t -> Path.t
+
+(** [printed_signature sourcefile ppf sg] print the signature [sg] of
+    [sourcefile] with potential warnings for name collisions *)
+val printed_signature: string -> formatter -> signature -> unit
diff --git a/upstream/ocaml_413/typing/printtyped.ml b/upstream/ocaml_413/typing/printtyped.ml
new file mode 100644
index 0000000..3457e08
--- /dev/null
+++ b/upstream/ocaml_413/typing/printtyped.ml
@@ -0,0 +1,962 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes;;
+open Format;;
+open Lexing;;
+open Location;;
+open Typedtree;;
+
+let fmt_position f l =
+  if l.pos_lnum = -1
+  then fprintf f "%s[%d]" l.pos_fname l.pos_cnum
+  else fprintf f "%s[%d,%d+%d]" l.pos_fname l.pos_lnum l.pos_bol
+               (l.pos_cnum - l.pos_bol)
+;;
+
+let fmt_location f loc =
+  if not !Clflags.locations then ()
+  else begin
+    fprintf f "(%a..%a)" fmt_position loc.loc_start fmt_position loc.loc_end;
+    if loc.loc_ghost then fprintf f " ghost";
+  end
+;;
+
+let rec fmt_longident_aux f x =
+  match x with
+  | Longident.Lident (s) -> fprintf f "%s" s;
+  | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s;
+  | Longident.Lapply (y, z) ->
+      fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z;
+;;
+
+let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x.txt;;
+
+let fmt_ident = Ident.print
+
+let fmt_modname f = function
+  | None -> fprintf f "_";
+  | Some id -> Ident.print f id
+
+let rec fmt_path_aux f x =
+  match x with
+  | Path.Pident (s) -> fprintf f "%a" fmt_ident s;
+  | Path.Pdot (y, s) -> fprintf f "%a.%s" fmt_path_aux y s;
+  | Path.Papply (y, z) ->
+      fprintf f "%a(%a)" fmt_path_aux y fmt_path_aux z;
+;;
+
+let fmt_path f x = fprintf f "\"%a\"" fmt_path_aux x;;
+
+let fmt_constant f x =
+  match x with
+  | Const_int (i) -> fprintf f "Const_int %d" i;
+  | Const_char (c) -> fprintf f "Const_char %02x" (Char.code c);
+  | Const_string (s, strloc, None) ->
+      fprintf f "Const_string(%S,%a,None)" s fmt_location strloc;
+  | Const_string (s, strloc, Some delim) ->
+      fprintf f "Const_string (%S,%a,Some %S)" s fmt_location strloc delim;
+  | Const_float (s) -> fprintf f "Const_float %s" s;
+  | Const_int32 (i) -> fprintf f "Const_int32 %ld" i;
+  | Const_int64 (i) -> fprintf f "Const_int64 %Ld" i;
+  | Const_nativeint (i) -> fprintf f "Const_nativeint %nd" i;
+;;
+
+let fmt_mutable_flag f x =
+  match x with
+  | Immutable -> fprintf f "Immutable";
+  | Mutable -> fprintf f "Mutable";
+;;
+
+let fmt_virtual_flag f x =
+  match x with
+  | Virtual -> fprintf f "Virtual";
+  | Concrete -> fprintf f "Concrete";
+;;
+
+let fmt_override_flag f x =
+  match x with
+  | Override -> fprintf f "Override";
+  | Fresh -> fprintf f "Fresh";
+;;
+
+let fmt_closed_flag f x =
+  match x with
+  | Closed -> fprintf f "Closed"
+  | Open -> fprintf f "Open"
+
+let fmt_rec_flag f x =
+  match x with
+  | Nonrecursive -> fprintf f "Nonrec";
+  | Recursive -> fprintf f "Rec";
+;;
+
+let fmt_direction_flag f x =
+  match x with
+  | Upto -> fprintf f "Up";
+  | Downto -> fprintf f "Down";
+;;
+
+let fmt_private_flag f x =
+  match x with
+  | Public -> fprintf f "Public";
+  | Private -> fprintf f "Private";
+;;
+
+let line i f s (*...*) =
+  fprintf f "%s" (String.make (2*i) ' ');
+  fprintf f s (*...*)
+;;
+
+let list i f ppf l =
+  match l with
+  | [] -> line i ppf "[]\n";
+  | _ :: _ ->
+     line i ppf "[\n";
+     List.iter (f (i+1) ppf) l;
+     line i ppf "]\n";
+;;
+
+let array i f ppf a =
+  if Array.length a = 0 then
+    line i ppf "[]\n"
+  else begin
+    line i ppf "[\n";
+    Array.iter (f (i+1) ppf) a;
+    line i ppf "]\n"
+  end
+;;
+
+let option i f ppf x =
+  match x with
+  | None -> line i ppf "None\n";
+  | Some x ->
+      line i ppf "Some\n";
+      f (i+1) ppf x;
+;;
+
+let longident i ppf li = line i ppf "%a\n" fmt_longident li;;
+let string i ppf s = line i ppf "\"%s\"\n" s;;
+let arg_label i ppf = function
+  | Nolabel -> line i ppf "Nolabel\n"
+  | Optional s -> line i ppf "Optional \"%s\"\n" s
+  | Labelled s -> line i ppf "Labelled \"%s\"\n" s
+;;
+
+let record_representation i ppf = let open Types in function
+  | Record_regular -> line i ppf "Record_regular\n"
+  | Record_float -> line i ppf "Record_float\n"
+  | Record_unboxed b -> line i ppf "Record_unboxed %b\n" b
+  | Record_inlined i -> line i ppf "Record_inlined %d\n" i
+  | Record_extension p -> line i ppf "Record_extension %a\n" fmt_path p
+
+let attribute i ppf k a =
+  line i ppf "%s \"%s\"\n" k a.Parsetree.attr_name.txt;
+  Printast.payload i ppf a.Parsetree.attr_payload
+
+let attributes i ppf l =
+  let i = i + 1 in
+  List.iter (fun a ->
+    line i ppf "attribute \"%s\"\n" a.Parsetree.attr_name.txt;
+    Printast.payload (i + 1) ppf a.Parsetree.attr_payload
+  ) l
+
+let rec core_type i ppf x =
+  line i ppf "core_type %a\n" fmt_location x.ctyp_loc;
+  attributes i ppf x.ctyp_attributes;
+  let i = i+1 in
+  match x.ctyp_desc with
+  | Ttyp_any -> line i ppf "Ttyp_any\n";
+  | Ttyp_var (s) -> line i ppf "Ttyp_var %s\n" s;
+  | Ttyp_arrow (l, ct1, ct2) ->
+      line i ppf "Ttyp_arrow\n";
+      arg_label i ppf l;
+      core_type i ppf ct1;
+      core_type i ppf ct2;
+  | Ttyp_tuple l ->
+      line i ppf "Ttyp_tuple\n";
+      list i core_type ppf l;
+  | Ttyp_constr (li, _, l) ->
+      line i ppf "Ttyp_constr %a\n" fmt_path li;
+      list i core_type ppf l;
+  | Ttyp_variant (l, closed, low) ->
+      line i ppf "Ttyp_variant closed=%a\n" fmt_closed_flag closed;
+      list i label_x_bool_x_core_type_list ppf l;
+      option i (fun i -> list i string) ppf low
+  | Ttyp_object (l, c) ->
+      line i ppf "Ttyp_object %a\n" fmt_closed_flag c;
+      let i = i + 1 in
+      List.iter (fun {of_desc; of_attributes; _} ->
+        match of_desc with
+        | OTtag (s, t) ->
+            line i ppf "method %s\n" s.txt;
+            attributes i ppf of_attributes;
+            core_type (i + 1) ppf t
+        | OTinherit ct ->
+            line i ppf "OTinherit\n";
+            core_type (i + 1) ppf ct
+        ) l
+  | Ttyp_class (li, _, l) ->
+      line i ppf "Ttyp_class %a\n" fmt_path li;
+      list i core_type ppf l;
+  | Ttyp_alias (ct, s) ->
+      line i ppf "Ttyp_alias \"%s\"\n" s;
+      core_type i ppf ct;
+  | Ttyp_poly (sl, ct) ->
+      line i ppf "Ttyp_poly%a\n"
+        (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x)) sl;
+      core_type i ppf ct;
+  | Ttyp_package { pack_path = s; pack_fields = l } ->
+      line i ppf "Ttyp_package %a\n" fmt_path s;
+      list i package_with ppf l;
+
+and package_with i ppf (s, t) =
+  line i ppf "with type %a\n" fmt_longident s;
+  core_type i ppf t
+
+and pattern : type k . _ -> _ -> k general_pattern -> unit = fun i ppf x ->
+  line i ppf "pattern %a\n" fmt_location x.pat_loc;
+  attributes i ppf x.pat_attributes;
+  let i = i+1 in
+  match x.pat_extra with
+    | extra :: rem ->
+        pattern_extra i ppf extra;
+        pattern i ppf { x with pat_extra = rem }
+    | [] ->
+  match x.pat_desc with
+  | Tpat_any -> line i ppf "Tpat_any\n";
+  | Tpat_var (s,_) -> line i ppf "Tpat_var \"%a\"\n" fmt_ident s;
+  | Tpat_alias (p, s,_) ->
+      line i ppf "Tpat_alias \"%a\"\n" fmt_ident s;
+      pattern i ppf p;
+  | Tpat_constant (c) -> line i ppf "Tpat_constant %a\n" fmt_constant c;
+  | Tpat_tuple (l) ->
+      line i ppf "Tpat_tuple\n";
+      list i pattern ppf l;
+  | Tpat_construct (li, _, po, vto) ->
+      line i ppf "Tpat_construct %a\n" fmt_longident li;
+      list i pattern ppf po;
+      option i
+        (fun i ppf (vl,ct) ->
+          let names = List.map (fun {txt} -> "\""^Ident.name txt^"\"") vl in
+          line i ppf "[%s]\n" (String.concat "; " names);
+          core_type i ppf ct)
+        ppf vto
+  | Tpat_variant (l, po, _) ->
+      line i ppf "Tpat_variant \"%s\"\n" l;
+      option i pattern ppf po;
+  | Tpat_record (l, _c) ->
+      line i ppf "Tpat_record\n";
+      list i longident_x_pattern ppf l;
+  | Tpat_array (l) ->
+      line i ppf "Tpat_array\n";
+      list i pattern ppf l;
+  | Tpat_lazy p ->
+      line i ppf "Tpat_lazy\n";
+      pattern i ppf p;
+  | Tpat_exception p ->
+      line i ppf "Tpat_exception\n";
+      pattern i ppf p;
+  | Tpat_value p ->
+      line i ppf "Tpat_value\n";
+      pattern i ppf (p :> pattern);
+  | Tpat_or (p1, p2, _) ->
+      line i ppf "Tpat_or\n";
+      pattern i ppf p1;
+      pattern i ppf p2;
+
+and pattern_extra i ppf (extra_pat, _, attrs) =
+  match extra_pat with
+  | Tpat_unpack ->
+     line i ppf "Tpat_extra_unpack\n";
+     attributes i ppf attrs;
+  | Tpat_constraint cty ->
+     line i ppf "Tpat_extra_constraint\n";
+     attributes i ppf attrs;
+     core_type i ppf cty;
+  | Tpat_type (id, _) ->
+     line i ppf "Tpat_extra_type %a\n" fmt_path id;
+     attributes i ppf attrs;
+  | Tpat_open (id,_,_) ->
+     line i ppf "Tpat_extra_open \"%a\"\n" fmt_path id;
+     attributes i ppf attrs;
+
+and expression_extra i ppf x attrs =
+  match x with
+  | Texp_constraint ct ->
+      line i ppf "Texp_constraint\n";
+      attributes i ppf attrs;
+      core_type i ppf ct;
+  | Texp_coerce (cto1, cto2) ->
+      line i ppf "Texp_coerce\n";
+      attributes i ppf attrs;
+      option i core_type ppf cto1;
+      core_type i ppf cto2;
+  | Texp_poly cto ->
+      line i ppf "Texp_poly\n";
+      attributes i ppf attrs;
+      option i core_type ppf cto;
+  | Texp_newtype s ->
+      line i ppf "Texp_newtype \"%s\"\n" s;
+      attributes i ppf attrs;
+
+and expression i ppf x =
+  line i ppf "expression %a\n" fmt_location x.exp_loc;
+  attributes i ppf x.exp_attributes;
+  let i =
+    List.fold_left (fun i (extra,_,attrs) ->
+                      expression_extra i ppf extra attrs; i+1)
+      (i+1) x.exp_extra
+  in
+  match x.exp_desc with
+  | Texp_ident (li,_,_) -> line i ppf "Texp_ident %a\n" fmt_path li;
+  | Texp_instvar (_, li,_) -> line i ppf "Texp_instvar %a\n" fmt_path li;
+  | Texp_constant (c) -> line i ppf "Texp_constant %a\n" fmt_constant c;
+  | Texp_let (rf, l, e) ->
+      line i ppf "Texp_let %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l;
+      expression i ppf e;
+  | Texp_function { arg_label = p; param = _; cases; partial = _; } ->
+      line i ppf "Texp_function\n";
+      arg_label i ppf p;
+      list i case ppf cases;
+  | Texp_apply (e, l) ->
+      line i ppf "Texp_apply\n";
+      expression i ppf e;
+      list i label_x_expression ppf l;
+  | Texp_match (e, l, _partial) ->
+      line i ppf "Texp_match\n";
+      expression i ppf e;
+      list i case ppf l;
+  | Texp_try (e, l) ->
+      line i ppf "Texp_try\n";
+      expression i ppf e;
+      list i case ppf l;
+  | Texp_tuple (l) ->
+      line i ppf "Texp_tuple\n";
+      list i expression ppf l;
+  | Texp_construct (li, _, eo) ->
+      line i ppf "Texp_construct %a\n" fmt_longident li;
+      list i expression ppf eo;
+  | Texp_variant (l, eo) ->
+      line i ppf "Texp_variant \"%s\"\n" l;
+      option i expression ppf eo;
+  | Texp_record { fields; representation; extended_expression } ->
+      line i ppf "Texp_record\n";
+      let i = i+1 in
+      line i ppf "fields =\n";
+      array (i+1) record_field ppf fields;
+      line i ppf "representation =\n";
+      record_representation (i+1) ppf representation;
+      line i ppf "extended_expression =\n";
+      option (i+1) expression ppf extended_expression;
+  | Texp_field (e, li, _) ->
+      line i ppf "Texp_field\n";
+      expression i ppf e;
+      longident i ppf li;
+  | Texp_setfield (e1, li, _, e2) ->
+      line i ppf "Texp_setfield\n";
+      expression i ppf e1;
+      longident i ppf li;
+      expression i ppf e2;
+  | Texp_array (l) ->
+      line i ppf "Texp_array\n";
+      list i expression ppf l;
+  | Texp_ifthenelse (e1, e2, eo) ->
+      line i ppf "Texp_ifthenelse\n";
+      expression i ppf e1;
+      expression i ppf e2;
+      option i expression ppf eo;
+  | Texp_sequence (e1, e2) ->
+      line i ppf "Texp_sequence\n";
+      expression i ppf e1;
+      expression i ppf e2;
+  | Texp_while (e1, e2) ->
+      line i ppf "Texp_while\n";
+      expression i ppf e1;
+      expression i ppf e2;
+  | Texp_for (s, _, e1, e2, df, e3) ->
+      line i ppf "Texp_for \"%a\" %a\n" fmt_ident s fmt_direction_flag df;
+      expression i ppf e1;
+      expression i ppf e2;
+      expression i ppf e3;
+  | Texp_send (e, Tmeth_name s, eo) ->
+      line i ppf "Texp_send \"%s\"\n" s;
+      expression i ppf e;
+      option i expression ppf eo
+  | Texp_send (e, Tmeth_val s, eo) ->
+      line i ppf "Texp_send \"%a\"\n" fmt_ident s;
+      expression i ppf e;
+      option i expression ppf eo
+  | Texp_new (li, _, _) -> line i ppf "Texp_new %a\n" fmt_path li;
+  | Texp_setinstvar (_, s, _, e) ->
+      line i ppf "Texp_setinstvar \"%a\"\n" fmt_path s;
+      expression i ppf e;
+  | Texp_override (_, l) ->
+      line i ppf "Texp_override\n";
+      list i string_x_expression ppf l;
+  | Texp_letmodule (s, _, _, me, e) ->
+      line i ppf "Texp_letmodule \"%a\"\n" fmt_modname s;
+      module_expr i ppf me;
+      expression i ppf e;
+  | Texp_letexception (cd, e) ->
+      line i ppf "Texp_letexception\n";
+      extension_constructor i ppf cd;
+      expression i ppf e;
+  | Texp_assert (e) ->
+      line i ppf "Texp_assert";
+      expression i ppf e;
+  | Texp_lazy (e) ->
+      line i ppf "Texp_lazy";
+      expression i ppf e;
+  | Texp_object (s, _) ->
+      line i ppf "Texp_object";
+      class_structure i ppf s
+  | Texp_pack me ->
+      line i ppf "Texp_pack";
+      module_expr i ppf me
+  | Texp_letop {let_; ands; param = _; body; partial = _} ->
+      line i ppf "Texp_letop";
+      binding_op (i+1) ppf let_;
+      list (i+1) binding_op ppf ands;
+      case i ppf body
+  | Texp_unreachable ->
+      line i ppf "Texp_unreachable"
+  | Texp_extension_constructor (li, _) ->
+      line i ppf "Texp_extension_constructor %a" fmt_longident li
+  | Texp_open (o, e) ->
+      line i ppf "Texp_open %a\n"
+        fmt_override_flag o.open_override;
+      module_expr i ppf o.open_expr;
+      attributes i ppf o.open_attributes;
+      expression i ppf e;
+
+and value_description i ppf x =
+  line i ppf "value_description %a %a\n" fmt_ident x.val_id fmt_location
+       x.val_loc;
+  attributes i ppf x.val_attributes;
+  core_type (i+1) ppf x.val_desc;
+  list (i+1) string ppf x.val_prim;
+
+and binding_op i ppf x =
+  line i ppf "binding_op %a %a\n" fmt_path x.bop_op_path
+    fmt_location x.bop_loc;
+  expression i ppf x.bop_exp
+
+and type_parameter i ppf (x, _variance) = core_type i ppf x
+
+and type_declaration i ppf x =
+  line i ppf "type_declaration %a %a\n" fmt_ident x.typ_id fmt_location
+       x.typ_loc;
+  attributes i ppf x.typ_attributes;
+  let i = i+1 in
+  line i ppf "ptype_params =\n";
+  list (i+1) type_parameter ppf x.typ_params;
+  line i ppf "ptype_cstrs =\n";
+  list (i+1) core_type_x_core_type_x_location ppf x.typ_cstrs;
+  line i ppf "ptype_kind =\n";
+  type_kind (i+1) ppf x.typ_kind;
+  line i ppf "ptype_private = %a\n" fmt_private_flag x.typ_private;
+  line i ppf "ptype_manifest =\n";
+  option (i+1) core_type ppf x.typ_manifest;
+
+and type_kind i ppf x =
+  match x with
+  | Ttype_abstract ->
+      line i ppf "Ttype_abstract\n"
+  | Ttype_variant l ->
+      line i ppf "Ttype_variant\n";
+      list (i+1) constructor_decl ppf l;
+  | Ttype_record l ->
+      line i ppf "Ttype_record\n";
+      list (i+1) label_decl ppf l;
+  | Ttype_open ->
+      line i ppf "Ttype_open\n"
+
+and type_extension i ppf x =
+  line i ppf "type_extension\n";
+  attributes i ppf x.tyext_attributes;
+  let i = i+1 in
+  line i ppf "ptyext_path = %a\n" fmt_path x.tyext_path;
+  line i ppf "ptyext_params =\n";
+  list (i+1) type_parameter ppf x.tyext_params;
+  line i ppf "ptyext_constructors =\n";
+  list (i+1) extension_constructor ppf x.tyext_constructors;
+  line i ppf "ptyext_private = %a\n" fmt_private_flag x.tyext_private;
+
+and type_exception i ppf x =
+  line i ppf "type_exception\n";
+  attributes i ppf x.tyexn_attributes;
+  let i = i+1 in
+  line i ppf "ptyext_constructor =\n";
+  let i = i+1 in
+  extension_constructor i ppf x.tyexn_constructor
+
+and extension_constructor i ppf x =
+  line i ppf "extension_constructor %a\n" fmt_location x.ext_loc;
+  attributes i ppf x.ext_attributes;
+  let i = i + 1 in
+  line i ppf "pext_name = \"%a\"\n" fmt_ident x.ext_id;
+  line i ppf "pext_kind =\n";
+  extension_constructor_kind (i + 1) ppf x.ext_kind;
+
+and extension_constructor_kind i ppf x =
+  match x with
+      Text_decl(a, r) ->
+        line i ppf "Text_decl\n";
+        constructor_arguments (i+1) ppf a;
+        option (i+1) core_type ppf r;
+    | Text_rebind(p, _) ->
+        line i ppf "Text_rebind\n";
+        line (i+1) ppf "%a\n" fmt_path p;
+
+and class_type i ppf x =
+  line i ppf "class_type %a\n" fmt_location x.cltyp_loc;
+  attributes i ppf x.cltyp_attributes;
+  let i = i+1 in
+  match x.cltyp_desc with
+  | Tcty_constr (li, _, l) ->
+      line i ppf "Tcty_constr %a\n" fmt_path li;
+      list i core_type ppf l;
+  | Tcty_signature (cs) ->
+      line i ppf "Tcty_signature\n";
+      class_signature i ppf cs;
+  | Tcty_arrow (l, co, cl) ->
+      line i ppf "Tcty_arrow\n";
+      arg_label i ppf l;
+      core_type i ppf co;
+      class_type i ppf cl;
+  | Tcty_open (o, e) ->
+      line i ppf "Tcty_open %a %a\n"
+        fmt_override_flag o.open_override
+        fmt_path (fst o.open_expr);
+      class_type i ppf e
+
+and class_signature i ppf { csig_self = ct; csig_fields = l } =
+  line i ppf "class_signature\n";
+  core_type (i+1) ppf ct;
+  list (i+1) class_type_field ppf l;
+
+and class_type_field i ppf x =
+  line i ppf "class_type_field %a\n" fmt_location x.ctf_loc;
+  let i = i+1 in
+  attributes i ppf x.ctf_attributes;
+  match x.ctf_desc with
+  | Tctf_inherit (ct) ->
+      line i ppf "Tctf_inherit\n";
+      class_type i ppf ct;
+  | Tctf_val (s, mf, vf, ct) ->
+      line i ppf "Tctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf
+           fmt_virtual_flag vf;
+      core_type (i+1) ppf ct;
+  | Tctf_method (s, pf, vf, ct) ->
+      line i ppf "Tctf_method \"%s\" %a %a\n" s fmt_private_flag pf
+           fmt_virtual_flag vf;
+      core_type (i+1) ppf ct;
+  | Tctf_constraint (ct1, ct2) ->
+      line i ppf "Tctf_constraint\n";
+      core_type (i+1) ppf ct1;
+      core_type (i+1) ppf ct2;
+  | Tctf_attribute a ->
+      attribute i ppf "Tctf_attribute" a
+
+and class_description i ppf x =
+  line i ppf "class_description %a\n" fmt_location x.ci_loc;
+  attributes i ppf x.ci_attributes;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.ci_params;
+  line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt;
+  line i ppf "pci_expr =\n";
+  class_type (i+1) ppf x.ci_expr;
+
+and class_type_declaration i ppf x =
+  line i ppf "class_type_declaration %a\n" fmt_location x.ci_loc;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.ci_params;
+  line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt;
+  line i ppf "pci_expr =\n";
+  class_type (i+1) ppf x.ci_expr;
+
+and class_expr i ppf x =
+  line i ppf "class_expr %a\n" fmt_location x.cl_loc;
+  attributes i ppf x.cl_attributes;
+  let i = i+1 in
+  match x.cl_desc with
+  | Tcl_ident (li, _, l) ->
+      line i ppf "Tcl_ident %a\n" fmt_path li;
+      list i core_type ppf l;
+  | Tcl_structure (cs) ->
+      line i ppf "Tcl_structure\n";
+      class_structure i ppf cs;
+  | Tcl_fun (l, p, _, ce, _) ->
+      line i ppf "Tcl_fun\n";
+      arg_label i ppf l;
+      pattern i ppf p;
+      class_expr i ppf ce
+  | Tcl_apply (ce, l) ->
+      line i ppf "Tcl_apply\n";
+      class_expr i ppf ce;
+      list i label_x_expression ppf l;
+  | Tcl_let (rf, l1, l2, ce) ->
+      line i ppf "Tcl_let %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l1;
+      list i ident_x_expression_def ppf l2;
+      class_expr i ppf ce;
+  | Tcl_constraint (ce, Some ct, _, _, _) ->
+      line i ppf "Tcl_constraint\n";
+      class_expr i ppf ce;
+      class_type i ppf ct
+  | Tcl_constraint (ce, None, _, _, _) -> class_expr i ppf ce
+  | Tcl_open (o, e) ->
+      line i ppf "Tcl_open %a %a\n"
+        fmt_override_flag o.open_override
+        fmt_path (fst o.open_expr);
+      class_expr i ppf e
+
+and class_structure i ppf { cstr_self = p; cstr_fields = l } =
+  line i ppf "class_structure\n";
+  pattern (i+1) ppf p;
+  list (i+1) class_field ppf l;
+
+and class_field i ppf x =
+  line i ppf "class_field %a\n" fmt_location x.cf_loc;
+  let i = i + 1 in
+  attributes i ppf x.cf_attributes;
+  match x.cf_desc with
+  | Tcf_inherit (ovf, ce, so, _, _) ->
+      line i ppf "Tcf_inherit %a\n" fmt_override_flag ovf;
+      class_expr (i+1) ppf ce;
+      option (i+1) string ppf so;
+  | Tcf_val (s, mf, _, k, _) ->
+      line i ppf "Tcf_val \"%s\" %a\n" s.txt fmt_mutable_flag mf;
+      class_field_kind (i+1) ppf k
+  | Tcf_method (s, pf, k) ->
+      line i ppf "Tcf_method \"%s\" %a\n" s.txt fmt_private_flag pf;
+      class_field_kind (i+1) ppf k
+  | Tcf_constraint (ct1, ct2) ->
+      line i ppf "Tcf_constraint\n";
+      core_type (i+1) ppf ct1;
+      core_type (i+1) ppf ct2;
+  | Tcf_initializer (e) ->
+      line i ppf "Tcf_initializer\n";
+      expression (i+1) ppf e;
+  | Tcf_attribute a ->
+      attribute i ppf "Tcf_attribute" a
+
+and class_field_kind i ppf = function
+  | Tcfk_concrete (o, e) ->
+      line i ppf "Concrete %a\n" fmt_override_flag o;
+      expression i ppf e
+  | Tcfk_virtual t ->
+      line i ppf "Virtual\n";
+      core_type i ppf t
+
+and class_declaration i ppf x =
+  line i ppf "class_declaration %a\n" fmt_location x.ci_loc;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.ci_params;
+  line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt;
+  line i ppf "pci_expr =\n";
+  class_expr (i+1) ppf x.ci_expr;
+
+and module_type i ppf x =
+  line i ppf "module_type %a\n" fmt_location x.mty_loc;
+  attributes i ppf x.mty_attributes;
+  let i = i+1 in
+  match x.mty_desc with
+  | Tmty_ident (li,_) -> line i ppf "Tmty_ident %a\n" fmt_path li;
+  | Tmty_alias (li,_) -> line i ppf "Tmty_alias %a\n" fmt_path li;
+  | Tmty_signature (s) ->
+      line i ppf "Tmty_signature\n";
+      signature i ppf s;
+  | Tmty_functor (Unit, mt2) ->
+      line i ppf "Tmty_functor ()\n";
+      module_type i ppf mt2;
+  | Tmty_functor (Named (s, _, mt1), mt2) ->
+      line i ppf "Tmty_functor \"%a\"\n" fmt_modname s;
+      module_type i ppf mt1;
+      module_type i ppf mt2;
+  | Tmty_with (mt, l) ->
+      line i ppf "Tmty_with\n";
+      module_type i ppf mt;
+      list i longident_x_with_constraint ppf l;
+  | Tmty_typeof m ->
+      line i ppf "Tmty_typeof\n";
+      module_expr i ppf m;
+
+and signature i ppf x = list i signature_item ppf x.sig_items
+
+and signature_item i ppf x =
+  line i ppf "signature_item %a\n" fmt_location x.sig_loc;
+  let i = i+1 in
+  match x.sig_desc with
+  | Tsig_value vd ->
+      line i ppf "Tsig_value\n";
+      value_description i ppf vd;
+  | Tsig_type (rf, l) ->
+      line i ppf "Tsig_type %a\n" fmt_rec_flag rf;
+      list i type_declaration ppf l;
+  | Tsig_typesubst l ->
+      line i ppf "Tsig_typesubst\n";
+      list i type_declaration ppf l;
+  | Tsig_typext e ->
+      line i ppf "Tsig_typext\n";
+      type_extension i ppf e;
+  | Tsig_exception ext ->
+      line i ppf "Tsig_exception\n";
+      type_exception i ppf ext
+  | Tsig_module md ->
+      line i ppf "Tsig_module \"%a\"\n" fmt_modname md.md_id;
+      attributes i ppf md.md_attributes;
+      module_type i ppf md.md_type
+  | Tsig_modsubst ms ->
+      line i ppf "Tsig_modsubst \"%a\" = %a\n"
+        fmt_ident ms.ms_id fmt_path ms.ms_manifest;
+      attributes i ppf ms.ms_attributes;
+  | Tsig_recmodule decls ->
+      line i ppf "Tsig_recmodule\n";
+      list i module_declaration ppf decls;
+  | Tsig_modtype x ->
+      line i ppf "Tsig_modtype \"%a\"\n" fmt_ident x.mtd_id;
+      attributes i ppf x.mtd_attributes;
+      modtype_declaration i ppf x.mtd_type
+  | Tsig_modtypesubst x ->
+      line i ppf "Tsig_modtypesubst \"%a\"\n" fmt_ident x.mtd_id;
+      attributes i ppf x.mtd_attributes;
+      modtype_declaration i ppf x.mtd_type
+  | Tsig_open od ->
+      line i ppf "Tsig_open %a %a\n"
+        fmt_override_flag od.open_override
+        fmt_path (fst od.open_expr);
+      attributes i ppf od.open_attributes
+  | Tsig_include incl ->
+      line i ppf "Tsig_include\n";
+      attributes i ppf incl.incl_attributes;
+      module_type i ppf incl.incl_mod
+  | Tsig_class (l) ->
+      line i ppf "Tsig_class\n";
+      list i class_description ppf l;
+  | Tsig_class_type (l) ->
+      line i ppf "Tsig_class_type\n";
+      list i class_type_declaration ppf l;
+  | Tsig_attribute a ->
+      attribute i ppf "Tsig_attribute" a
+
+and module_declaration i ppf md =
+  line i ppf "%a" fmt_modname md.md_id;
+  attributes i ppf md.md_attributes;
+  module_type (i+1) ppf md.md_type;
+
+and module_binding i ppf x =
+  line i ppf "%a\n" fmt_modname x.mb_id;
+  attributes i ppf x.mb_attributes;
+  module_expr (i+1) ppf x.mb_expr
+
+and modtype_declaration i ppf = function
+  | None -> line i ppf "#abstract"
+  | Some mt -> module_type (i + 1) ppf mt
+
+and with_constraint i ppf x =
+  match x with
+  | Twith_type (td) ->
+      line i ppf "Twith_type\n";
+      type_declaration (i+1) ppf td;
+  | Twith_typesubst (td) ->
+      line i ppf "Twith_typesubst\n";
+      type_declaration (i+1) ppf td;
+  | Twith_module (li,_) -> line i ppf "Twith_module %a\n" fmt_path li;
+  | Twith_modsubst (li,_) -> line i ppf "Twith_modsubst %a\n" fmt_path li;
+  | Twith_modtype mty ->
+      line i ppf "Twith_modtype\n";
+      module_type (i+1) ppf mty
+  | Twith_modtypesubst mty ->
+      line i ppf "Twith_modtype\n";
+      module_type (i+1) ppf mty
+
+and module_expr i ppf x =
+  line i ppf "module_expr %a\n" fmt_location x.mod_loc;
+  attributes i ppf x.mod_attributes;
+  let i = i+1 in
+  match x.mod_desc with
+  | Tmod_ident (li,_) -> line i ppf "Tmod_ident %a\n" fmt_path li;
+  | Tmod_structure (s) ->
+      line i ppf "Tmod_structure\n";
+      structure i ppf s;
+  | Tmod_functor (Unit, me) ->
+      line i ppf "Tmod_functor ()\n";
+      module_expr i ppf me;
+  | Tmod_functor (Named (s, _, mt), me) ->
+      line i ppf "Tmod_functor \"%a\"\n" fmt_modname s;
+      module_type i ppf mt;
+      module_expr i ppf me;
+  | Tmod_apply (me1, me2, _) ->
+      line i ppf "Tmod_apply\n";
+      module_expr i ppf me1;
+      module_expr i ppf me2;
+  | Tmod_constraint (me, _, Tmodtype_explicit mt, _) ->
+      line i ppf "Tmod_constraint\n";
+      module_expr i ppf me;
+      module_type i ppf mt;
+  | Tmod_constraint (me, _, Tmodtype_implicit, _) -> module_expr i ppf me
+  | Tmod_unpack (e, _) ->
+      line i ppf "Tmod_unpack\n";
+      expression i ppf e;
+
+and structure i ppf x = list i structure_item ppf x.str_items
+
+and structure_item i ppf x =
+  line i ppf "structure_item %a\n" fmt_location x.str_loc;
+  let i = i+1 in
+  match x.str_desc with
+  | Tstr_eval (e, attrs) ->
+      line i ppf "Tstr_eval\n";
+      attributes i ppf attrs;
+      expression i ppf e;
+  | Tstr_value (rf, l) ->
+      line i ppf "Tstr_value %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l;
+  | Tstr_primitive vd ->
+      line i ppf "Tstr_primitive\n";
+      value_description i ppf vd;
+  | Tstr_type (rf, l) ->
+      line i ppf "Tstr_type %a\n" fmt_rec_flag rf;
+      list i type_declaration ppf l;
+  | Tstr_typext te ->
+      line i ppf "Tstr_typext\n";
+      type_extension i ppf te
+  | Tstr_exception ext ->
+      line i ppf "Tstr_exception\n";
+      type_exception i ppf ext;
+  | Tstr_module x ->
+      line i ppf "Tstr_module\n";
+      module_binding i ppf x
+  | Tstr_recmodule bindings ->
+      line i ppf "Tstr_recmodule\n";
+      list i module_binding ppf bindings
+  | Tstr_modtype x ->
+      line i ppf "Tstr_modtype \"%a\"\n" fmt_ident x.mtd_id;
+      attributes i ppf x.mtd_attributes;
+      modtype_declaration i ppf x.mtd_type
+  | Tstr_open od ->
+      line i ppf "Tstr_open %a\n"
+        fmt_override_flag od.open_override;
+      module_expr i ppf od.open_expr;
+      attributes i ppf od.open_attributes
+  | Tstr_class (l) ->
+      line i ppf "Tstr_class\n";
+      list i class_declaration ppf (List.map (fun (cl, _) -> cl) l);
+  | Tstr_class_type (l) ->
+      line i ppf "Tstr_class_type\n";
+      list i class_type_declaration ppf (List.map (fun (_, _, cl) -> cl) l);
+  | Tstr_include incl ->
+      line i ppf "Tstr_include";
+      attributes i ppf incl.incl_attributes;
+      module_expr i ppf incl.incl_mod;
+  | Tstr_attribute a ->
+      attribute i ppf "Tstr_attribute" a
+
+and longident_x_with_constraint i ppf (li, _, wc) =
+  line i ppf "%a\n" fmt_path li;
+  with_constraint (i+1) ppf wc;
+
+and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
+  line i ppf "<constraint> %a\n" fmt_location l;
+  core_type (i+1) ppf ct1;
+  core_type (i+1) ppf ct2;
+
+and constructor_decl i ppf {cd_id; cd_name = _; cd_args; cd_res; cd_loc;
+                            cd_attributes} =
+  line i ppf "%a\n" fmt_location cd_loc;
+  line (i+1) ppf "%a\n" fmt_ident cd_id;
+  attributes i ppf cd_attributes;
+  constructor_arguments (i+1) ppf cd_args;
+  option (i+1) core_type ppf cd_res
+
+and constructor_arguments i ppf = function
+  | Cstr_tuple l -> list i core_type ppf l
+  | Cstr_record l -> list i label_decl ppf l
+
+and label_decl i ppf {ld_id; ld_name = _; ld_mutable; ld_type; ld_loc;
+                      ld_attributes} =
+  line i ppf "%a\n" fmt_location ld_loc;
+  attributes i ppf ld_attributes;
+  line (i+1) ppf "%a\n" fmt_mutable_flag ld_mutable;
+  line (i+1) ppf "%a" fmt_ident ld_id;
+  core_type (i+1) ppf ld_type
+
+and longident_x_pattern i ppf (li, _, p) =
+  line i ppf "%a\n" fmt_longident li;
+  pattern (i+1) ppf p;
+
+and case
+    : type k . _ -> _ -> k case -> unit
+  = fun i ppf {c_lhs; c_guard; c_rhs} ->
+  line i ppf "<case>\n";
+  pattern (i+1) ppf c_lhs;
+  begin match c_guard with
+  | None -> ()
+  | Some g -> line (i+1) ppf "<when>\n"; expression (i + 2) ppf g
+  end;
+  expression (i+1) ppf c_rhs;
+
+and value_binding i ppf x =
+  line i ppf "<def>\n";
+  attributes (i+1) ppf x.vb_attributes;
+  pattern (i+1) ppf x.vb_pat;
+  expression (i+1) ppf x.vb_expr
+
+and string_x_expression i ppf (s, _, e) =
+  line i ppf "<override> \"%a\"\n" fmt_path s;
+  expression (i+1) ppf e;
+
+and record_field i ppf = function
+  | _, Overridden (li, e) ->
+      line i ppf "%a\n" fmt_longident li;
+      expression (i+1) ppf e;
+  | _, Kept _ ->
+      line i ppf "<kept>"
+
+and label_x_expression i ppf (l, e) =
+  line i ppf "<arg>\n";
+  arg_label (i+1) ppf l;
+  (match e with None -> () | Some e -> expression (i+1) ppf e)
+
+and ident_x_expression_def i ppf (l, e) =
+  line i ppf "<def> \"%a\"\n" fmt_ident l;
+  expression (i+1) ppf e;
+
+and label_x_bool_x_core_type_list i ppf x =
+  match x.rf_desc with
+  | Ttag (l, b, ctl) ->
+      line i ppf "Ttag \"%s\" %s\n" l.txt (string_of_bool b);
+      attributes (i+1) ppf x.rf_attributes;
+      list (i+1) core_type ppf ctl
+  | Tinherit (ct) ->
+      line i ppf "Tinherit\n";
+      core_type (i+1) ppf ct
+;;
+
+let interface ppf x = list 0 signature_item ppf x.sig_items;;
+
+let implementation ppf x = list 0 structure_item ppf x.str_items;;
+
+let implementation_with_coercion ppf Typedtree.{structure; _} =
+  implementation ppf structure
diff --git a/upstream/ocaml_413/typing/printtyped.mli b/upstream/ocaml_413/typing/printtyped.mli
new file mode 100644
index 0000000..538a3fa
--- /dev/null
+++ b/upstream/ocaml_413/typing/printtyped.mli
@@ -0,0 +1,23 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*              Damien Doligez, projet Para, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Typedtree;;
+open Format;;
+
+val interface : formatter -> signature -> unit;;
+val implementation : formatter -> structure -> unit;;
+
+val implementation_with_coercion :
+  formatter -> Typedtree.implementation -> unit;;
diff --git a/upstream/ocaml_413/typing/rec_check.ml b/upstream/ocaml_413/typing/rec_check.ml
new file mode 100644
index 0000000..7509149
--- /dev/null
+++ b/upstream/ocaml_413/typing/rec_check.ml
@@ -0,0 +1,1258 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*               Jeremy Yallop, University of Cambridge                   *)
+(*               Gabriel Scherer, Project Parsifal, INRIA Saclay          *)
+(*               Alban Reynaud, ENS Lyon                                  *)
+(*                                                                        *)
+(*   Copyright 2017 Jeremy Yallop                                         *)
+(*   Copyright 2018 Alban Reynaud                                         *)
+(*   Copyright 2018 INRIA                                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Static checking of recursive declarations
+
+Some recursive definitions are meaningful
+{[
+  let rec factorial = function 0 -> 1 | n -> n * factorial (n - 1)
+  let rec infinite_list = 0 :: infinite_list
+]}
+but some other are meaningless
+{[
+  let rec x = x
+  let rec x = x+1
+|}
+
+Intuitively, a recursive definition makes sense when the body of the
+definition can be evaluated without fully knowing what the recursive
+name is yet.
+
+In the [factorial] example, the name [factorial] refers to a function,
+evaluating the function definition [function ...] can be done
+immediately and will not force a recursive call to [factorial] -- this
+will only happen later, when [factorial] is called with an argument.
+
+In the [infinite_list] example, we can evaluate [0 :: infinite_list]
+without knowing the full content of [infinite_list], but with just its
+address. This is a case of productive/guarded recursion.
+
+On the contrary, [let rec x = x] is unguarded recursion (the meaning
+is undetermined), and [let rec x = x+1] would need the value of [x]
+while evaluating its definition [x+1].
+
+This file implements a static check to decide which definitions are
+known to be meaningful, and which may be meaningless. In the general
+case, we handle a set of mutually-recursive definitions
+{[
+let rec x1 = e1
+and x2 = e2
+...
+and xn = en
+]}
+
+
+Our check (see function [is_valid_recursive_expression] is defined
+using two criteria:
+
+Usage of recursive variables: how does each of the [e1 .. en] use the
+ recursive variables [x1 .. xn]?
+
+Static or dynamic size: for which of the [ei] can we compute the
+  in-memory size of the value without evaluating [ei] (so that we can
+  pre-allocate it, and thus know its final address before evaluation).
+
+The "static or dynamic size" is decided by the classify_* functions below.
+
+The "variable usage" question is decided by a static analysis looking
+very much like a type system. The idea is to assign "access modes" to
+variables, where an "access mode" [m] is defined as either
+
+    m ::= Ignore (* the value is not used at all *)
+        | Delay (* the value is not needed at definition time *)
+        | Guard (* the value is stored under a data constructor *)
+        | Return (* the value result is directly returned *)
+        | Dereference (* full access and inspection of the value *)
+
+The access modes of an expression [e] are represented by a "context"
+[G], which is simply a mapping from variables (the variables used in
+[e]) to access modes.
+
+The core notion of the static check is a type-system-like judgment of
+the form [G |- e : m], which can be interpreted as meaning either of:
+
+- If we are allowed to use the variables of [e] at the modes in [G]
+  (but not more), then it is safe to use [e] at the mode [m].
+
+- If we want to use [e] at the mode [m], then its variables are
+  used at the modes in [G].
+
+In practice, for a given expression [e], our implementation takes the
+desired mode of use [m] as *input*, and returns a context [G] as
+*output*, which is (uniquely determined as) the most permissive choice
+of modes [G] for the variables of [e] such that [G |- e : m] holds.
+*)
+
+open Asttypes
+open Typedtree
+open Types
+
+exception Illegal_expr
+
+(** {1 Static or dynamic size} *)
+
+type sd = Static | Dynamic
+
+let is_ref : Types.value_description -> bool = function
+  | { Types.val_kind =
+        Types.Val_prim { Primitive.prim_name = "%makemutable";
+                          prim_arity = 1 } } ->
+        true
+  | _ -> false
+
+(* See the note on abstracted arguments in the documentation for
+    Typedtree.Texp_apply *)
+let is_abstracted_arg : arg_label * expression option -> bool = function
+  | (_, None) -> true
+  | (_, Some _) -> false
+
+let classify_expression : Typedtree.expression -> sd =
+  (* We need to keep track of the size of expressions
+      bound by local declarations, to be able to predict
+      the size of variables. Compare:
+
+        let rec r =
+          let y = fun () -> r ()
+          in y
+
+      and
+
+        let rec r =
+          let y = if Random.bool () then ignore else fun () -> r ()
+          in y
+
+    In both cases the final address of `r` must be known before `y` is compiled,
+    and this is only possible if `r` has a statically-known size.
+
+    The first definition can be allowed (`y` has a statically-known
+    size) but the second one is unsound (`y` has no statically-known size).
+  *)
+  let rec classify_expression env e = match e.exp_desc with
+    (* binding and variable cases *)
+    | Texp_let (rec_flag, vb, e) ->
+        let env = classify_value_bindings rec_flag env vb in
+        classify_expression env e
+    | Texp_ident (path, _, _) ->
+        classify_path env path
+
+    (* non-binding cases *)
+    | Texp_open (_, e)
+    | Texp_letmodule (_, _, _, _, e)
+    | Texp_sequence (_, e)
+    | Texp_letexception (_, e) ->
+        classify_expression env e
+
+    | Texp_construct (_, {cstr_tag = Cstr_unboxed}, [e]) ->
+        classify_expression env e
+    | Texp_construct _ ->
+        Static
+
+    | Texp_record { representation = Record_unboxed _;
+                    fields = [| _, Overridden (_,e) |] } ->
+        classify_expression env e
+    | Texp_record _ ->
+        Static
+
+    | Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, _)
+      when is_ref vd ->
+        Static
+    | Texp_apply (_,args)
+      when List.exists is_abstracted_arg args ->
+        Static
+    | Texp_apply _ ->
+        Dynamic
+
+    | Texp_for _
+    | Texp_constant _
+    | Texp_new _
+    | Texp_instvar _
+    | Texp_tuple _
+    | Texp_array _
+    | Texp_variant _
+    | Texp_setfield _
+    | Texp_while _
+    | Texp_setinstvar _
+    | Texp_pack _
+    | Texp_object _
+    | Texp_function _
+    | Texp_lazy _
+    | Texp_unreachable
+    | Texp_extension_constructor _ ->
+        Static
+
+    | Texp_match _
+    | Texp_ifthenelse _
+    | Texp_send _
+    | Texp_field _
+    | Texp_assert _
+    | Texp_try _
+    | Texp_override _
+    | Texp_letop _ ->
+        Dynamic
+  and classify_value_bindings rec_flag env bindings =
+    (* We use a non-recursive classification, classifying each
+        binding with respect to the old environment
+        (before all definitions), even if the bindings are recursive.
+
+        Note: computing a fixpoint in some way would be more
+        precise, as the following could be allowed:
+
+          let rec topdef =
+            let rec x = y and y = fun () -> topdef ()
+            in x
+    *)
+    ignore rec_flag;
+    let old_env = env in
+    let add_value_binding env vb =
+      match vb.vb_pat.pat_desc with
+      | Tpat_var (id, _loc) ->
+          let size = classify_expression old_env vb.vb_expr in
+          Ident.add id size env
+      | _ ->
+          (* Note: we don't try to compute any size for complex patterns *)
+          env
+    in
+    List.fold_left add_value_binding env bindings
+  and classify_path env = function
+    | Path.Pident x ->
+        begin
+          try Ident.find_same x env
+          with Not_found ->
+            (* an identifier will be missing from the map if either:
+                - it is a non-local identifier
+                  (bound outside the letrec-binding we are analyzing)
+                - or it is bound by a complex (let p = e in ...) local binding
+                - or it is bound within a module (let module M = ... in ...)
+                  that we are not traversing for size computation
+
+                For non-local identifiers it might be reasonable (although
+                not completely clear) to consider them Static (they have
+                already been evaluated), but for the others we must
+                under-approximate with Dynamic.
+
+                This could be fixed by a more complete implementation.
+            *)
+            Dynamic
+        end
+    | Path.Pdot _ | Path.Papply _ ->
+        (* local modules could have such paths to local definitions;
+            classify_expression could be extend to compute module
+            shapes more precisely *)
+        Dynamic
+  in classify_expression Ident.empty
+
+
+(** {1 Usage of recursive variables} *)
+
+module Mode = struct
+  (** For an expression in a program, its "usage mode" represents
+      static information about how the value produced by the expression
+      will be used by the context around it. *)
+  type t =
+    | Ignore
+    (** [Ignore] is for subexpressions that are not used at all during
+       the evaluation of the whole program. This is the mode of
+       a variable in an expression in which it does not occur. *)
+
+    | Delay
+    (** A [Delay] context can be fully evaluated without evaluating its argument
+        , which will only be needed at a later point of program execution. For
+        example, [fun x -> ?] or [lazy ?] are [Delay] contexts. *)
+
+    | Guard
+    (** A [Guard] context returns the value as a member of a data structure,
+        for example a variant constructor or record. The value can safely be
+        defined mutually-recursively with their context, for example in
+        [let rec li = 1 :: li].
+        When these subexpressions participate in a cyclic definition,
+        this definition is productive/guarded.
+
+        The [Guard] mode is also used when a value is not dereferenced,
+        it is returned by a sub-expression, but the result of this
+        sub-expression is discarded instead of being returned.
+        For example, the subterm [?] is in a [Guard] context
+        in [let _ = ? in e] and in [?; e].
+        When these subexpressions participate in a cyclic definition,
+        they cannot create a self-loop.
+    *)
+
+    | Return
+    (** A [Return] context returns its value without further inspection.
+        This value cannot be defined mutually-recursively with its context,
+        as there is a risk of self-loop: in [let rec x = y and y = x], the
+        two definitions use a single variable in [Return] context. *)
+
+    | Dereference
+    (** A [Dereference] context consumes, inspects and uses the value
+        in arbitrary ways. Such a value must be fully defined at the point
+        of usage, it cannot be defined mutually-recursively with its context. *)
+
+  let equal = ((=) : t -> t -> bool)
+
+  (* Lower-ranked modes demand/use less of the variable/expression they qualify
+     -- so they allow more recursive definitions.
+
+     Ignore < Delay < Guard < Return < Dereference
+  *)
+  let rank = function
+    | Ignore -> 0
+    | Delay -> 1
+    | Guard -> 2
+    | Return -> 3
+    | Dereference -> 4
+
+  (* Returns the more conservative (highest-ranking) mode of the two
+     arguments.
+
+     In judgments we write (m + m') for (join m m').
+  *)
+  let join m m' =
+    if rank m >= rank m' then m else m'
+
+  (* If x is used with the mode m in e[x], and e[x] is used with mode
+     m' in e'[e[x]], then x is used with mode m'[m] (our notation for
+     "compose m' m") in e'[e[x]].
+
+     Return is neutral for composition: m[Return] = m = Return[m].
+
+     Composition is associative and [Ignore] is a zero/annihilator for
+     it: (compose Ignore m) and (compose m Ignore) are both Ignore. *)
+  let compose m' m = match m', m with
+    | Ignore, _ | _, Ignore -> Ignore
+    | Dereference, _ -> Dereference
+    | Delay, _ -> Delay
+    | Guard, Return -> Guard
+    | Guard, ((Dereference | Guard | Delay) as m) -> m
+    | Return, Return -> Return
+    | Return, ((Dereference | Guard | Delay) as m) -> m
+end
+
+type mode = Mode.t = Ignore | Delay | Guard | Return | Dereference
+
+module Env :
+sig
+  type t
+
+  val single : Ident.t -> Mode.t -> t
+  (** Create an environment with a single identifier used with a given mode.
+  *)
+
+  val empty : t
+  (** An environment with no used identifiers. *)
+
+  val find : Ident.t -> t -> Mode.t
+  (** Find the mode of an identifier in an environment.  The default mode is
+      Ignore. *)
+
+  val unguarded : t -> Ident.t list -> Ident.t list
+  (** unguarded e l: the list of all identifiers in l that are dereferenced or
+      returned in the environment e. *)
+
+  val dependent : t -> Ident.t list -> Ident.t list
+  (** dependent e l: the list of all identifiers in l that are used in e
+      (not ignored). *)
+
+  val join : t -> t -> t
+  val join_list : t list -> t
+  (** Environments can be joined pointwise (variable per variable) *)
+
+  val compose : Mode.t -> t -> t
+  (** Environment composition m[G] extends mode composition m1[m2]
+      by composing each mode in G pointwise *)
+
+  val remove : Ident.t -> t -> t
+  (** Remove an identifier from an environment. *)
+
+  val take: Ident.t -> t -> Mode.t * t
+  (** Remove an identifier from an environment, and return its mode *)
+
+  val remove_list : Ident.t list -> t -> t
+  (** Remove all the identifiers of a list from an environment. *)
+
+  val equal : t -> t -> bool
+end = struct
+  module M = Map.Make(Ident)
+
+  (** A "t" maps each rec-bound variable to an access status *)
+  type t = Mode.t M.t
+
+  let equal = M.equal Mode.equal
+
+  let find (id: Ident.t) (tbl: t) =
+    try M.find id tbl with Not_found -> Ignore
+
+  let empty = M.empty
+
+  let join (x: t) (y: t) =
+    M.fold
+      (fun (id: Ident.t) (v: Mode.t) (tbl: t) ->
+         let v' = find id tbl in
+         M.add id (Mode.join v v') tbl)
+      x y
+
+  let join_list li = List.fold_left join empty li
+
+  let compose m env =
+    M.map (Mode.compose m) env
+
+  let single id mode = M.add id mode empty
+
+  let unguarded env li =
+    List.filter (fun id -> Mode.rank (find id env) > Mode.rank Guard) li
+
+  let dependent env li =
+    List.filter (fun id -> Mode.rank (find id env) > Mode.rank Ignore) li
+
+  let remove = M.remove
+
+  let take id env = (find id env, remove id env)
+
+  let remove_list l env =
+    List.fold_left (fun env id -> M.remove id env) env l
+end
+
+let remove_pat pat env =
+  Env.remove_list (pat_bound_idents pat) env
+
+let remove_patlist pats env =
+  List.fold_right remove_pat pats env
+
+(* Usage mode judgments.
+
+   There are two main groups of judgment functions:
+
+   - Judgments of the form "G |- ... : m"
+     compute the environment G of a subterm ... from its mode m, so
+     the corresponding function has type [... -> Mode.t -> Env.t].
+
+     We write [... -> term_judg] in this case.
+
+   - Judgments of the form "G |- ... : m -| G'"
+
+     correspond to binding constructs (for example "let x = e" in the
+     term "let x = e in body") that have both an exterior environment
+     G (the environment of the whole term "let x = e in body") and an
+     interior environment G' (the environment at the "in", after the
+     binding construct has introduced new names in scope).
+
+     For example, let-binding could be given the following rule:
+
+       G |- e : m + m'
+       -----------------------------------
+       G+G' |- (let x = e) : m -| x:m', G'
+
+     Checking the whole term composes this judgment
+     with the "G |- e : m" form for the let body:
+
+       G  |- (let x = e) : m -| G'
+       G' |- body : m
+       -------------------------------
+       G |- let x = e in body : m
+
+     To this judgment "G |- e : m -| G'" our implementation gives the
+     type [... -> Mode.t -> Env.t -> Env.t]: it takes the mode and
+     interior environment as inputs, and returns the exterior
+     environment.
+
+     We write [... -> bind_judg] in this case.
+*)
+type term_judg = Mode.t -> Env.t
+type bind_judg = Mode.t -> Env.t -> Env.t
+
+let option : 'a. ('a -> term_judg) -> 'a option -> term_judg =
+  fun f o m -> match o with
+    | None -> Env.empty
+    | Some v -> f v m
+let list : 'a. ('a -> term_judg) -> 'a list -> term_judg =
+  fun f li m ->
+    List.fold_left (fun env item -> Env.join env (f item m)) Env.empty li
+let array : 'a. ('a -> term_judg) -> 'a array -> term_judg =
+  fun f ar m ->
+    Array.fold_left (fun env item -> Env.join env (f item m)) Env.empty ar
+
+let single : Ident.t -> term_judg = Env.single
+let remove_id : Ident.t -> term_judg -> term_judg =
+  fun id f m -> Env.remove id (f m)
+let remove_ids : Ident.t list -> term_judg -> term_judg =
+  fun ids f m -> Env.remove_list ids (f m)
+
+let join : term_judg list -> term_judg =
+  fun li m -> Env.join_list (List.map (fun f -> f m) li)
+
+let empty = fun _ -> Env.empty
+
+(* A judgment [judg] takes a mode from the context as input, and
+   returns an environment. The judgment [judg << m], given a mode [m']
+   from the context, evaluates [judg] in the composed mode [m'[m]]. *)
+let (<<) : term_judg -> Mode.t -> term_judg =
+  fun f inner_mode -> fun outer_mode -> f (Mode.compose outer_mode inner_mode)
+
+(* A binding judgment [binder] expects a mode and an inner environment,
+   and returns an outer environment. [binder >> judg] computes
+   the inner environment as the environment returned by [judg]
+   in the ambient mode. *)
+let (>>) : bind_judg -> term_judg -> term_judg =
+  fun binder term mode -> binder mode (term mode)
+
+(* Expression judgment:
+     G |- e : m
+   where (m) is an input of the code and (G) is an output;
+   in the Prolog mode notation, this is (+G |- -e : -m).
+*)
+let rec expression : Typedtree.expression -> term_judg =
+  fun exp -> match exp.exp_desc with
+    | Texp_ident (pth, _, _) ->
+      path pth
+    | Texp_let (rec_flag, bindings, body) ->
+      (*
+         G  |- <bindings> : m -| G'
+         G' |- body : m
+         -------------------------------
+         G |- let <bindings> in body : m
+      *)
+      value_bindings rec_flag bindings >> expression body
+    | Texp_letmodule (x, _, _, mexp, e) ->
+      module_binding (x, mexp) >> expression e
+    | Texp_match (e, cases, _) ->
+      (*
+         (Gi; mi |- pi -> ei : m)^i
+         G |- e : sum(mi)^i
+         ----------------------------------------------
+         G + sum(Gi)^i |- match e with (pi -> ei)^i : m
+       *)
+      (fun mode ->
+        let pat_envs, pat_modes =
+          List.split (List.map (fun c -> case c mode) cases) in
+        let env_e = expression e (List.fold_left Mode.join Ignore pat_modes) in
+        Env.join_list (env_e :: pat_envs))
+    | Texp_for (_, _, low, high, _, body) ->
+      (*
+        G1 |- low: m[Dereference]
+        G2 |- high: m[Dereference]
+        G3 |- body: m[Guard]
+        ---
+        G1 + G2 + G3 |- for _ = low to high do body done: m
+      *)
+      join [
+        expression low << Dereference;
+        expression high << Dereference;
+        expression body << Guard;
+      ]
+    | Texp_constant _ ->
+      empty
+    | Texp_new (pth, _, _) ->
+      (*
+        G |- c: m[Dereference]
+        -----------------------
+        G |- new c: m
+      *)
+      path pth << Dereference
+    | Texp_instvar (self_path, pth, _inst_var) ->
+        join [path self_path << Dereference; path pth]
+    | Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, [_, Some arg])
+      when is_ref vd ->
+      (*
+        G |- e: m[Guard]
+        ------------------
+        G |- ref e: m
+      *)
+      expression arg << Guard
+    | Texp_apply (e, args)  ->
+        let arg (_, eo) = option expression eo in
+        let app_mode = if List.exists is_abstracted_arg args
+          then (* see the comment on Texp_apply in typedtree.mli;
+                  the non-abstracted arguments are bound to local
+                  variables, which corresponds to a Guard mode. *)
+            Guard
+          else Dereference
+        in
+        join [expression e; list arg args] << app_mode
+    | Texp_tuple exprs ->
+      list expression exprs << Guard
+    | Texp_array exprs ->
+      let array_mode = match Typeopt.array_kind exp with
+        | Lambda.Pfloatarray ->
+            (* (flat) float arrays unbox their elements *)
+            Dereference
+        | Lambda.Pgenarray ->
+            (* This is counted as a use, because constructing a generic array
+               involves inspecting to decide whether to unbox (PR#6939). *)
+            Dereference
+        | Lambda.Paddrarray | Lambda.Pintarray ->
+            (* non-generic, non-float arrays act as constructors *)
+            Guard
+      in
+      list expression exprs << array_mode
+    | Texp_construct (_, desc, exprs) ->
+      let access_constructor =
+        match desc.cstr_tag with
+        | Cstr_extension (pth, _) ->
+          path pth << Dereference
+        | _ -> empty
+      in
+      let m' = match desc.cstr_tag with
+        | Cstr_unboxed ->
+          Return
+        | Cstr_constant _ | Cstr_block _ | Cstr_extension _ ->
+          Guard
+      in
+      join [
+        access_constructor;
+        list expression exprs << m'
+      ]
+    | Texp_variant (_, eo) ->
+      (*
+        G |- e: m[Guard]
+        ------------------   -----------
+        G |- `A e: m         [] |- `A: m
+      *)
+      option expression eo << Guard
+    | Texp_record { fields = es; extended_expression = eo;
+                    representation = rep } ->
+        let field_mode = match rep with
+          | Record_float -> Dereference
+          | Record_unboxed _ -> Return
+          | Record_regular | Record_inlined _
+          | Record_extension _ -> Guard
+        in
+        let field (_label, field_def) = match field_def with
+            Kept _ -> empty
+          | Overridden (_, e) -> expression e
+        in
+        join [
+          array field es << field_mode;
+          option expression eo << Dereference
+        ]
+    | Texp_ifthenelse (cond, ifso, ifnot) ->
+      (*
+        Gc |- c: m[Dereference]
+        G1 |- e1: m
+        G2 |- e2: m
+        ---
+        Gc + G1 + G2 |- if c then e1 else e2: m
+
+      Note: `if c then e1 else e2` is treated in the same way as
+      `match c with true -> e1 | false -> e2`
+      *)
+      join [
+        expression cond << Dereference;
+        expression ifso;
+        option expression ifnot;
+      ]
+    | Texp_setfield (e1, _, _, e2) ->
+      (*
+        G1 |- e1: m[Dereference]
+        G2 |- e2: m[Dereference]
+        ---
+        G1 + G2 |- e1.x <- e2: m
+
+        Note: e2 is dereferenced in the case of a field assignment to
+        a record of unboxed floats in that case, e2 evaluates to
+        a boxed float and it is unboxed on assignment.
+      *)
+      join [
+        expression e1 << Dereference;
+        expression e2 << Dereference;
+      ]
+    | Texp_sequence (e1, e2) ->
+      (*
+        G1 |- e1: m[Guard]
+        G2 |- e2: m
+        --------------------
+        G1 + G2 |- e1; e2: m
+
+        Note: `e1; e2` is treated in the same way as `let _ = e1 in e2`
+      *)
+      join [
+        expression e1 << Guard;
+        expression e2;
+      ]
+    | Texp_while (cond, body) ->
+      (*
+        G1 |- cond: m[Dereference]
+        G2 |- body: m[Guard]
+        ---------------------------------
+        G1 + G2 |- while cond do body done: m
+      *)
+      join [
+        expression cond << Dereference;
+        expression body << Guard;
+      ]
+    | Texp_send (e1, _, eo) ->
+      (*
+        G |- e: m[Dereference]
+        ---------------------- (plus weird 'eo' option)
+        G |- e#x: m
+      *)
+      join [
+        expression e1 << Dereference;
+        option expression eo << Dereference;
+      ]
+    | Texp_field (e, _, _) ->
+      (*
+        G |- e: m[Dereference]
+        -----------------------
+        G |- e.x: m
+      *)
+      expression e << Dereference
+    | Texp_setinstvar (pth,_,_,e) ->
+      (*
+        G |- e: m[Dereference]
+        ----------------------
+        G |- x <- e: m
+      *)
+      join [
+        path pth << Dereference;
+        expression e << Dereference;
+      ]
+    | Texp_letexception ({ext_id}, e) ->
+      (* G |- e: m
+         ----------------------------
+         G |- let exception A in e: m
+      *)
+      remove_id ext_id (expression e)
+    | Texp_assert e ->
+      (*
+        G |- e: m[Dereference]
+        -----------------------
+        G |- assert e: m
+
+        Note: `assert e` is treated just as if `assert` was a function.
+      *)
+      expression e << Dereference
+    | Texp_pack mexp ->
+      (*
+        G |- M: m
+        ----------------
+        G |- module M: m
+      *)
+      modexp mexp
+    | Texp_object (clsstrct, _) ->
+      class_structure clsstrct
+    | Texp_try (e, cases) ->
+      (*
+        G |- e: m      (Gi; _ |- pi -> ei : m)^i
+        --------------------------------------------
+        G + sum(Gi)^i |- try e with (pi -> ei)^i : m
+
+        Contrarily to match, the patterns p do not inspect
+        the value of e, so their mode does not influence the
+        mode of e.
+      *)
+      let case_env c m = fst (case c m) in
+      join [
+        expression e;
+        list case_env cases;
+      ]
+    | Texp_override (pth, fields) ->
+      (*
+         G |- pth : m   (Gi |- ei : m[Dereference])^i
+         ----------------------------------------------------
+         G + sum(Gi)^i |- {< (xi = ei)^i >} (at path pth) : m
+
+         Note: {< .. >} is desugared to a function application, but
+         the function implementation might still use its arguments in
+         a guarded way only -- intuitively it should behave as a constructor.
+         We could possibly refine the arguments' Dereference into Guard here.
+      *)
+      let field (_, _, arg) = expression arg in
+      join [
+        path pth << Dereference;
+        list field fields << Dereference;
+      ]
+    | Texp_function { cases } ->
+      (*
+         (Gi; _ |- pi -> ei : m[Delay])^i
+         --------------------------------------
+         sum(Gi)^i |- function (pi -> ei)^i : m
+
+         Contrarily to match, the value that is pattern-matched
+         is bound locally, so the pattern modes do not influence
+         the final environment.
+      *)
+      let case_env c m = fst (case c m) in
+      list case_env cases << Delay
+    | Texp_lazy e ->
+      (*
+        G |- e: m[Delay]
+        ----------------  (modulo some subtle compiler optimizations)
+        G |- lazy e: m
+      *)
+      let lazy_mode = match Typeopt.classify_lazy_argument e with
+        | `Constant_or_function
+        | `Identifier _
+        | `Float_that_cannot_be_shortcut ->
+          Return
+        | `Other ->
+          Delay
+      in
+      expression e << lazy_mode
+    | Texp_letop{let_; ands; body; _} ->
+        let case_env c m = fst (case c m) in
+        join [
+          list binding_op (let_ :: ands) << Dereference;
+          case_env body << Delay
+        ]
+    | Texp_unreachable ->
+      (*
+        ----------
+        [] |- .: m
+      *)
+      empty
+    | Texp_extension_constructor (_lid, pth) ->
+      path pth << Dereference
+    | Texp_open (od, e) ->
+      open_declaration od >> expression e
+
+and binding_op : Typedtree.binding_op -> term_judg =
+  fun bop ->
+    join [path bop.bop_op_path; expression bop.bop_exp]
+
+and class_structure : Typedtree.class_structure -> term_judg =
+  fun cs -> list class_field cs.cstr_fields
+
+and class_field : Typedtree.class_field -> term_judg =
+  fun cf -> match cf.cf_desc with
+    | Tcf_inherit (_, ce, _super, _inh_vars, _inh_meths) ->
+      class_expr ce << Dereference
+    | Tcf_val (_lab, _mut, _, cfk, _) ->
+      class_field_kind cfk
+    | Tcf_method (_, _, cfk) ->
+      class_field_kind cfk
+    | Tcf_constraint _ ->
+      empty
+    | Tcf_initializer e ->
+      expression e << Dereference
+    | Tcf_attribute _ ->
+      empty
+
+and class_field_kind : Typedtree.class_field_kind -> term_judg =
+  fun cfk -> match cfk with
+    | Tcfk_virtual _ ->
+      empty
+    | Tcfk_concrete (_, e) ->
+      expression e << Dereference
+
+and modexp : Typedtree.module_expr -> term_judg =
+  fun mexp -> match mexp.mod_desc with
+    | Tmod_ident (pth, _) ->
+      path pth
+    | Tmod_structure s ->
+      structure s
+    | Tmod_functor (_, e) ->
+      modexp e << Delay
+    | Tmod_apply (f, p, _) ->
+      join [
+        modexp f << Dereference;
+        modexp p << Dereference;
+      ]
+    | Tmod_constraint (mexp, _, _, coe) ->
+      let rec coercion coe k = match coe with
+        | Tcoerce_none ->
+          k Return
+        | Tcoerce_structure _
+        | Tcoerce_functor _ ->
+          (* These coercions perform a shallow copy of the input module,
+             by creating a new module with fields obtained by accessing
+             the same fields in the input module. *)
+           k Dereference
+        | Tcoerce_primitive _ ->
+          (* This corresponds to 'external' declarations,
+             and the coercion ignores its argument *)
+          k Ignore
+        | Tcoerce_alias (_, pth, coe) ->
+          (* Alias coercions ignore their arguments, but they evaluate
+             their alias module 'pth' under another coercion. *)
+          coercion coe (fun m -> path pth << m)
+      in
+      coercion coe (fun m -> modexp mexp << m)
+    | Tmod_unpack (e, _) ->
+      expression e
+
+
+(* G |- pth : m *)
+and path : Path.t -> term_judg =
+  (*
+    ------------
+    x: m |- x: m
+
+    G |- A: m[Dereference]
+    -----------------------
+    G |- A.x: m
+
+    G1 |- A: m[Dereference]
+    G2 |- B: m[Dereference]
+    ------------------------ (as for term application)
+    G1 + G2 |- A(B): m
+  *)
+  fun pth -> match pth with
+    | Path.Pident x ->
+        single x
+    | Path.Pdot (t, _) ->
+        path t << Dereference
+    | Path.Papply (f, p) ->
+        join [
+          path f << Dereference;
+          path p << Dereference;
+        ]
+
+(* G |- struct ... end : m *)
+and structure : Typedtree.structure -> term_judg =
+  (*
+    G1, {x: _, x in vars(G1)} |- item1: G2 + ... + Gn in m
+    G2, {x: _, x in vars(G2)} |- item2: G3 + ... + Gn in m
+    ...
+    Gn, {x: _, x in vars(Gn)} |- itemn: [] in m
+    ---
+    (G1 + ... + Gn) - V |- struct item1 ... itemn end: m
+  *)
+  fun s m ->
+    List.fold_right (fun it env -> structure_item it m env)
+      s.str_items Env.empty
+
+(* G |- <structure item> : m -| G'
+   where G is an output and m, G' are inputs *)
+and structure_item : Typedtree.structure_item -> bind_judg =
+  fun s m env -> match s.str_desc with
+    | Tstr_eval (e, _) ->
+      (*
+        Ge |- e: m[Guard]
+        G |- items: m -| G'
+        ---------------------------------
+        Ge + G |- (e;; items): m -| G'
+
+        The expression `e` is treated in the same way as let _ = e
+      *)
+      let judg_e = expression e << Guard in
+      Env.join (judg_e m) env
+    | Tstr_value (rec_flag, bindings) ->
+      value_bindings rec_flag bindings m env
+    | Tstr_module {mb_id; mb_expr} ->
+      module_binding (mb_id, mb_expr) m env
+    | Tstr_recmodule mbs ->
+      let bindings = List.map (fun {mb_id; mb_expr} -> (mb_id, mb_expr)) mbs in
+      recursive_module_bindings bindings m env
+    | Tstr_primitive _ ->
+      env
+    | Tstr_type _ ->
+      (*
+        -------------------
+        G |- type t: m -| G
+      *)
+      env
+    | Tstr_typext {tyext_constructors = exts; _} ->
+      let ext_ids = List.map (fun {ext_id = id; _} -> id) exts in
+      Env.join
+        (list extension_constructor exts m)
+        (Env.remove_list ext_ids env)
+    | Tstr_exception {tyexn_constructor = ext; _} ->
+      Env.join
+        (extension_constructor ext m)
+        (Env.remove ext.ext_id env)
+    | Tstr_modtype _
+    | Tstr_class_type _
+    | Tstr_attribute _ ->
+      env
+    | Tstr_open od ->
+      open_declaration od m env
+    | Tstr_class classes ->
+        let class_ids =
+          let class_id ({ci_id_class = id; _}, _) = id in
+          List.map class_id classes in
+        let class_declaration ({ci_expr; _}, _) m =
+          Env.remove_list class_ids (class_expr ci_expr m) in
+        Env.join
+          (list class_declaration classes m)
+          (Env.remove_list class_ids env)
+    | Tstr_include { incl_mod = mexp; incl_type = mty; _ } ->
+      let included_ids = List.map Types.signature_item_id mty in
+      Env.join (modexp mexp m) (Env.remove_list included_ids env)
+
+(* G |- module M = E : m -| G *)
+and module_binding : (Ident.t option * Typedtree.module_expr) -> bind_judg =
+  fun (id, mexp) m env ->
+      (*
+        GE |- E: m[mM + Guard]
+        -------------------------------------
+        GE + G |- module M = E : m -| M:mM, G
+      *)
+      let judg_E, env =
+        match id with
+        | None -> modexp mexp << Guard, env
+        | Some id ->
+          let mM, env = Env.take id env in
+          let judg_E = modexp mexp << (Mode.join mM Guard) in
+          judg_E, env
+      in
+      Env.join (judg_E m) env
+
+and open_declaration : Typedtree.open_declaration -> bind_judg =
+  fun { open_expr = mexp; open_bound_items = sg; _ } m env ->
+      let judg_E = modexp mexp in
+      let bound_ids = List.map Types.signature_item_id sg in
+      Env.join (judg_E m) (Env.remove_list bound_ids env)
+
+and recursive_module_bindings
+  : (Ident.t option * Typedtree.module_expr) list -> bind_judg =
+  fun m_bindings m env ->
+    let mids = List.filter_map fst m_bindings in
+    let binding (mid, mexp) m =
+      let judg_E =
+        match mid with
+        | None -> modexp mexp << Guard
+        | Some mid ->
+          let mM = Env.find mid env in
+          modexp mexp << (Mode.join mM Guard)
+      in
+      Env.remove_list mids (judg_E m)
+    in
+    Env.join (list binding m_bindings m) (Env.remove_list mids env)
+
+and class_expr : Typedtree.class_expr -> term_judg =
+  fun ce -> match ce.cl_desc with
+    | Tcl_ident (pth, _, _) ->
+        path pth << Dereference
+    | Tcl_structure cs ->
+        class_structure cs
+    | Tcl_fun (_, _, args, ce, _) ->
+        let ids = List.map fst args in
+        remove_ids ids (class_expr ce << Delay)
+    | Tcl_apply (ce, args) ->
+        let arg (_label, eo) = option expression eo in
+        join [
+          class_expr ce << Dereference;
+          list arg args << Dereference;
+        ]
+    | Tcl_let (rec_flag, bindings, _, ce) ->
+      value_bindings rec_flag bindings >> class_expr ce
+    | Tcl_constraint (ce, _, _, _, _) ->
+        class_expr ce
+    | Tcl_open (_, ce) ->
+        class_expr ce
+
+and extension_constructor : Typedtree.extension_constructor -> term_judg =
+  fun ec -> match ec.ext_kind with
+    | Text_decl _ ->
+      empty
+    | Text_rebind (pth, _lid) ->
+      path pth
+
+(* G |- let (rec?) (pi = ei)^i : m -| G' *)
+and value_bindings : rec_flag -> Typedtree.value_binding list -> bind_judg =
+  fun rec_flag bindings mode bound_env ->
+    let all_bound_pats = List.map (fun vb -> vb.vb_pat) bindings in
+    let outer_env = remove_patlist all_bound_pats bound_env in
+    let bindings_env =
+      match rec_flag with
+      | Nonrecursive ->
+        (*
+           (Gi, pi:_ |- ei : m[mbody_i])^i   (pi : mbody_i -| D)^i
+           ------------------------------------------------------------
+           Sum(Gi) + (D - (pi)^i) |- let (pi=ei)^i : m -| D
+        *)
+          let binding_env {vb_pat; vb_expr; _} m =
+            let m' = Mode.compose m (pattern vb_pat bound_env) in
+            remove_pat vb_pat (expression vb_expr m') in
+          list binding_env bindings mode
+      | Recursive ->
+        (*
+           (Gi, (xj : mdef_ij)^j |- ei : m[mbody_i])^i   (xi : mbody_i -| D)^i
+           G'i = Gi + mdef_ij[G'j]
+           -------------------------------------------------------------------
+           Sum(G'i) + (D - (pi)^i) |- let rec (xi=ei)^i : m -| D
+
+           The (mdef_ij)^i,j are a family of modes over two indices:
+           mdef_ij represents the mode of use, within e_i the definition of x_i,
+           of the mutually-recursive variable x_j.
+
+           The (G'i)^i are defined from the (Gi)^i as a family of equations,
+           whose smallest solution is computed as a least fixpoint.
+
+           The (Gi)^i are the "immediate" dependencies of each (ei)^i
+           on the outer context (excluding the mutually-defined
+           variables).
+           The (G'i)^i contain the "transitive" dependencies as well:
+           if ei depends on xj, then the dependencies of G'i of xi
+           must contain the dependencies of G'j, composed by
+           the mode mdef_ij of use of xj in ei.
+
+           For example, consider:
+
+             let rec z =
+               let rec x = ref y
+               and y = ref z
+               in f x
+
+           this definition should be rejected as the body [f x]
+           dereferences [x], which can be used to access the
+           yet-unitialized value [z]. This requires realizing that [x]
+           depends on [z] through [y], which requires the transitive
+           closure computation.
+
+           An earlier version of our check would take only the (Gi)^i
+           instead of the (G'i)^i, which is incorrect and would accept
+           the example above.
+        *)
+          (* [binding_env] takes a binding (x_i = e_i)
+             and computes (Gi, (mdef_ij)^j). *)
+          let binding_env {vb_pat = x_i; vb_expr = e_i; _} =
+            let mbody_i = pattern x_i bound_env in
+            (* Gi, (x_j:mdef_ij)^j  *)
+            let rhs_env_i = expression e_i (Mode.compose mode mbody_i) in
+            (* (mdef_ij)^j (for a fixed i) *)
+            let mutual_modes =
+              let mdef_ij {vb_pat = x_j; _} = pattern x_j rhs_env_i in
+              List.map mdef_ij bindings in
+            (* Gi *)
+            let env_i = remove_patlist all_bound_pats rhs_env_i in
+            (* (Gi, (mdef_ij)^j) *)
+            (env_i, mutual_modes) in
+          let env, mdef =
+            List.split (List.map binding_env bindings) in
+          let rec transitive_closure env =
+            let transitive_deps env_i mdef_i =
+              (* Gi, (mdef_ij)^j => Gi + Sum_j mdef_ij[Gj] *)
+              Env.join env_i
+                (Env.join_list (List.map2 Env.compose mdef_i env)) in
+            let env' = List.map2 transitive_deps env mdef in
+            if List.for_all2 Env.equal env env'
+            then env'
+            else transitive_closure env'
+          in
+          let env'_i = transitive_closure env in
+          Env.join_list env'_i
+    in Env.join bindings_env outer_env
+
+(* G; m' |- (p -> e) : m
+   with outputs G, m' and input m
+
+   m' is the mode under which the scrutinee of p
+   (the value matched against p) is placed.
+*)
+and case
+    : 'k . 'k Typedtree.case -> mode -> Env.t * mode
+  = fun { Typedtree.c_lhs; c_guard; c_rhs } ->
+    (*
+       Ge |- e : m    Gg |- g : m[Dereference]
+       G := Ge+Gg     p : mp -| G
+       ----------------------------------------
+       G - p; m[mp] |- (p (when g)? -> e) : m
+    *)
+    let judg = join [
+        option expression c_guard << Dereference;
+        expression c_rhs;
+      ] in
+    (fun m ->
+       let env = judg m in
+       (remove_pat c_lhs env), Mode.compose m (pattern c_lhs env))
+
+(* p : m -| G
+   with output m and input G
+
+   m is the mode under which the scrutinee of p is placed.
+*)
+and pattern : type k . k general_pattern -> Env.t -> mode = fun pat env ->
+  (*
+    mp := | Dereference if p is destructuring
+          | Guard       otherwise
+    me := sum{G(x), x in vars(p)}
+    --------------------------------------------
+    p : (mp + me) -| G
+  *)
+  let m_pat = if is_destructuring_pattern pat
+              then Dereference
+              else Guard
+  in
+  let m_env =
+    pat_bound_idents pat
+    |> List.map (fun id -> Env.find id env)
+    |> List.fold_left Mode.join Ignore
+  in
+  Mode.join m_pat m_env
+
+and is_destructuring_pattern : type k . k general_pattern -> bool =
+  fun pat -> match pat.pat_desc with
+    | Tpat_any -> false
+    | Tpat_var (_, _) -> false
+    | Tpat_alias (pat, _, _) -> is_destructuring_pattern pat
+    | Tpat_constant _ -> true
+    | Tpat_tuple _ -> true
+    | Tpat_construct _ -> true
+    | Tpat_variant _ -> true
+    | Tpat_record (_, _) -> true
+    | Tpat_array _ -> true
+    | Tpat_lazy _ -> true
+    | Tpat_value pat -> is_destructuring_pattern (pat :> pattern)
+    | Tpat_exception _ -> false
+    | Tpat_or (l,r,_) ->
+        is_destructuring_pattern l || is_destructuring_pattern r
+
+let is_valid_recursive_expression idlist expr =
+  let ty = expression expr Return in
+  match Env.unguarded ty idlist, Env.dependent ty idlist,
+        classify_expression expr with
+  | _ :: _, _, _ (* The expression inspects rec-bound variables *)
+  | [], _ :: _, Dynamic -> (* The expression depends on rec-bound variables
+                              and its size is unknown *)
+      false
+  | [], _, Static (* The expression has known size *)
+  | [], [], Dynamic -> (* The expression has unknown size,
+                          but does not depend on rec-bound variables *)
+      true
+
+(* A class declaration may contain let-bindings. If they are recursive,
+   their validity will already be checked by [is_valid_recursive_expression]
+   during type-checking. This function here prevents a different kind of
+   invalid recursion, which is the unsafe creations of objects of this class
+   in the let-binding. For example,
+   {|class a = let x = new a in object ... end|}
+   is forbidden, but
+   {|class a = let x () = new a in object ... end|}
+   is allowed.
+*)
+let is_valid_class_expr idlist ce =
+  let rec class_expr : mode -> Typedtree.class_expr -> Env.t =
+    fun mode ce -> match ce.cl_desc with
+      | Tcl_ident (_, _, _) ->
+        (*
+          ----------
+          [] |- a: m
+        *)
+        Env.empty
+      | Tcl_structure _ ->
+        (*
+          -----------------------
+          [] |- struct ... end: m
+        *)
+        Env.empty
+      | Tcl_fun (_, _, _, _, _) -> Env.empty
+        (*
+          ---------------------------
+          [] |- fun x1 ... xn -> C: m
+        *)
+      | Tcl_apply (_, _) -> Env.empty
+      | Tcl_let (rec_flag, bindings, _, ce) ->
+        value_bindings rec_flag bindings mode (class_expr mode ce)
+      | Tcl_constraint (ce, _, _, _, _) ->
+        class_expr mode ce
+      | Tcl_open (_, ce) ->
+        class_expr mode ce
+  in
+  match Env.unguarded (class_expr Return ce) idlist with
+  | [] -> true
+  | _ :: _ -> false
diff --git a/upstream/ocaml_413/typing/rec_check.mli b/upstream/ocaml_413/typing/rec_check.mli
new file mode 100644
index 0000000..aa5c1ca
--- /dev/null
+++ b/upstream/ocaml_413/typing/rec_check.mli
@@ -0,0 +1,19 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*               Jeremy Yallop, University of Cambridge                   *)
+(*                                                                        *)
+(*   Copyright 2017 Jeremy Yallop                                         *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+exception Illegal_expr
+
+val is_valid_recursive_expression : Ident.t list -> Typedtree.expression -> bool
+
+val is_valid_class_expr : Ident.t list -> Typedtree.class_expr -> bool
diff --git a/upstream/ocaml_413/typing/signature_group.ml b/upstream/ocaml_413/typing/signature_group.ml
new file mode 100644
index 0000000..7395961
--- /dev/null
+++ b/upstream/ocaml_413/typing/signature_group.ml
@@ -0,0 +1,155 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*  Florian Angeletti, projet Cambium, Inria Paris                        *)
+(*                                                                        *)
+(*   Copyright 2021 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Fold on a signature by syntactic group of items *)
+
+(** Classes and class types generate ghosts signature items, we group them
+    together before printing *)
+type sig_item =
+  {
+    src: Types.signature_item;
+    post_ghosts: Types.signature_item list
+    (** ghost classes types are post-declared *);
+  }
+let flatten x = x.src :: x.post_ghosts
+
+type core_rec_group =
+  | Not_rec of sig_item
+  | Rec_group of sig_item list
+
+let rec_items = function
+  | Not_rec x -> [x]
+  | Rec_group x -> x
+
+(** Private row types are manifested as a sequence of definitions
+    preceding a recursive group, we collect them and separate them from the
+    syntatic recursive group. *)
+type rec_group =
+  { pre_ghosts: Types.signature_item list; group:core_rec_group }
+
+let next_group = function
+  | [] -> None
+  | src :: q ->
+      let ghosts, q =
+        match src with
+        | Types.Sig_class _ ->
+            (* a class declaration for [c] is followed by the ghost
+               declarations of class type [c], and types [c] and [#c] *)
+            begin match q with
+            | ct::t::ht::q -> [ct;t;ht], q
+            | _ -> assert false
+            end
+        | Types.Sig_class_type _  ->
+            (* a class type declaration for [ct] is followed by the ghost
+               declarations of types [ct] and [#ct] *)
+           begin match q with
+            | t::ht::q -> [t;ht], q
+            | _ -> assert false
+           end
+        | Types.(Sig_module _ | Sig_value _ | Sig_type _ | Sig_typext _
+                | Sig_modtype _) ->
+            [],q
+      in
+      Some({src; post_ghosts=ghosts}, q)
+
+let recursive_sigitem = function
+  | Types.Sig_type(ident, _, rs, _)
+  | Types.Sig_class(ident,_,rs,_)
+  | Types.Sig_class_type (ident,_,rs,_)
+  | Types.Sig_module(ident, _, _, rs, _) -> Some (ident,rs)
+  | Types.(Sig_value _ | Sig_modtype _ | Sig_typext _ )  -> None
+
+let next x =
+  let cons_group pre group q =
+    let group = Rec_group (List.rev group) in
+    Some({ pre_ghosts=List.rev pre; group },q)
+  in
+  let rec not_in_group pre l = match next_group l with
+    | None ->
+        assert (pre=[]);
+        None
+    | Some(elt, q)  ->
+        match recursive_sigitem elt.src with
+        | Some (id, _) when Btype.is_row_name (Ident.name id) ->
+            not_in_group (elt.src::pre) q
+        | None | Some (_, Types.Trec_not) ->
+            let sgroup = { pre_ghosts=List.rev pre; group=Not_rec elt } in
+            Some (sgroup,q)
+        | Some (id, Types.(Trec_first | Trec_next) )  ->
+            in_group ~pre ~ids:[id] ~group:[elt] q
+  and in_group ~pre ~ids ~group rem = match next_group rem with
+    | None -> cons_group pre group []
+    | Some (elt,next) ->
+        match recursive_sigitem elt.src with
+        | Some (id, Types.Trec_next) ->
+            in_group ~pre ~ids:(id::ids) ~group:(elt::group) next
+        | None | Some (_, Types.(Trec_not|Trec_first)) ->
+            cons_group pre group rem
+  in
+  not_in_group [] x
+
+let seq l = Seq.unfold next l
+let iter f l = Seq.iter f (seq l)
+let fold f acc l = Seq.fold_left f acc (seq l)
+
+let update_rec_next rs rem =
+  match rs with
+  | Types.Trec_next -> rem
+  | Types.(Trec_first | Trec_not) ->
+      match rem with
+      | Types.Sig_type (id, decl, Trec_next, priv) :: rem ->
+          Types.Sig_type (id, decl, rs, priv) :: rem
+      | Types.Sig_module (id, pres, mty, Trec_next, priv) :: rem ->
+          Types.Sig_module (id, pres, mty, rs, priv) :: rem
+      | _ -> rem
+
+type in_place_patch = {
+  ghosts: Types.signature;
+  replace_by: Types.signature_item option;
+}
+
+
+let replace_in_place f sg =
+  let rec next_group f before signature =
+    match next signature with
+    | None -> None
+    | Some(item,sg) ->
+        core_group f ~before ~ghosts:item.pre_ghosts ~before_group:[]
+          (rec_items item.group) ~sg
+  and core_group f ~before ~ghosts ~before_group current ~sg =
+    let commit ghosts = before_group @ List.rev_append ghosts before in
+    match current with
+    | [] -> next_group f (commit ghosts) sg
+    | a :: q ->
+        match f ~rec_group:q ~ghosts a.src with
+        | Some (info, {ghosts; replace_by}) ->
+            let after = List.concat_map flatten q @ sg in
+            let after = match recursive_sigitem a.src, replace_by with
+              | None, _ | _, Some _ -> after
+              | Some (_,rs), None -> update_rec_next rs after
+            in
+            let before = match replace_by with
+              | None -> commit ghosts
+              | Some x -> x :: commit ghosts
+            in
+            let sg = List.rev_append before after in
+            Some(info, sg)
+        | None ->
+            let before_group =
+              List.rev_append a.post_ghosts (a.src :: before_group)
+            in
+            core_group f ~before ~ghosts ~before_group q ~sg
+  in
+  next_group f [] sg
diff --git a/upstream/ocaml_413/typing/signature_group.mli b/upstream/ocaml_413/typing/signature_group.mli
new file mode 100644
index 0000000..e6e0dbd
--- /dev/null
+++ b/upstream/ocaml_413/typing/signature_group.mli
@@ -0,0 +1,85 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*  Florian Angeletti, projet Cambium, Inria Paris                        *)
+(*                                                                        *)
+(*   Copyright 2021 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Iterate on signature by syntactic group of items
+
+    Classes, class types and private row types adds ghost components to
+    the signature where they are defined.
+
+    When editing or printing a signature it is therefore important to
+    identify those ghost components.
+
+    This module provides type grouping together ghost components
+    with the corresponding core item (or recursive group) and
+    the corresponding iterators.
+*)
+
+(** Classes and class types generate ghosts signature items, we group them
+    together before printing *)
+type sig_item =
+  {
+    src: Types.signature_item (** the syntactic item *)
+;
+    post_ghosts: Types.signature_item list
+    (** ghost classes types are post-declared *);
+  }
+
+(** [flatten sig_item] is [x.src :: x.post_ghosts] *)
+val flatten: sig_item -> Types.signature
+
+(** A group of mutually recursive definition *)
+type core_rec_group =
+  | Not_rec of sig_item
+  | Rec_group of sig_item list
+
+(** [rec_items group] is the list of sig_items in the group *)
+val rec_items: core_rec_group -> sig_item list
+
+(** Private #row types are manifested as a sequence of definitions
+    preceding a recursive group, we collect them and separate them from the
+    syntatic recursive group. *)
+type rec_group =
+  { pre_ghosts: Types.signature_item list; group:core_rec_group }
+
+(** The sequence [seq signature] iterates over [signature] {!rec_group} by
+    {!rec_group}.
+    The second element of the tuple in the {!full_seq} case is the not-yet
+    traversed part of the signature.
+*)
+val next: Types.signature -> (rec_group * Types.signature) option
+val seq: Types.signature -> rec_group Seq.t
+
+val iter: (rec_group -> unit) -> Types.signature -> unit
+val fold: ('acc -> rec_group -> 'acc) -> 'acc -> Types.signature -> 'acc
+
+(** Describe how to amend one element of a signature *)
+type in_place_patch = {
+  ghosts: Types.signature; (** updated list of ghost items *)
+  replace_by: Types.signature_item option;
+  (** replacement for the selected item *)
+}
+
+(**
+  [!replace_in_place patch sg] replaces the first element of the signature
+   for which [patch ~rec_group ~ghosts component] returns [Some (value,patch)].
+   The [rec_group] argument is the remaining part of the mutually
+   recursive group of [component].
+   The [ghosts] list is the current prefix of ghost components associated to
+   [component]
+*)
+val replace_in_place:
+  ( rec_group:sig_item list -> ghosts:Types.signature -> Types.signature_item
+    -> ('a * in_place_patch) option )
+  -> Types.signature -> ('a * Types.signature) option
diff --git a/upstream/ocaml_413/typing/stypes.ml b/upstream/ocaml_413/typing/stypes.ml
new file mode 100644
index 0000000..dfbcc99
--- /dev/null
+++ b/upstream/ocaml_413/typing/stypes.ml
@@ -0,0 +1,210 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Damien Doligez, projet Moscova, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2003 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Recording and dumping (partial) type information *)
+
+(*
+  We record all types in a list as they are created.
+  This means we can dump type information even if type inference fails,
+  which is extremely important, since type information is most
+  interesting in case of errors.
+*)
+
+open Annot;;
+open Lexing;;
+open Location;;
+open Typedtree;;
+
+let output_int oc i = output_string oc (Int.to_string i)
+
+type annotation =
+  | Ti_pat : 'k pattern_category * 'k general_pattern -> annotation
+  | Ti_expr  of expression
+  | Ti_class of class_expr
+  | Ti_mod   of module_expr
+  | An_call of Location.t * Annot.call
+  | An_ident of Location.t * string * Annot.ident
+;;
+
+let get_location ti =
+  match ti with
+  | Ti_pat (_, p)   -> p.pat_loc
+  | Ti_expr e  -> e.exp_loc
+  | Ti_class c -> c.cl_loc
+  | Ti_mod m   -> m.mod_loc
+  | An_call (l, _k) -> l
+  | An_ident (l, _s, _k) -> l
+;;
+
+let annotations = ref ([] : annotation list);;
+let phrases = ref ([] : Location.t list);;
+
+let record ti =
+  if !Clflags.annotations && not (get_location ti).Location.loc_ghost then
+    annotations := ti :: !annotations
+;;
+
+let record_phrase loc =
+  if !Clflags.annotations then phrases := loc :: !phrases;
+;;
+
+(* comparison order:
+   the intervals are sorted by order of increasing upper bound
+   same upper bound -> sorted by decreasing lower bound
+*)
+let cmp_loc_inner_first loc1 loc2 =
+  match compare loc1.loc_end.pos_cnum loc2.loc_end.pos_cnum with
+  | 0 -> compare loc2.loc_start.pos_cnum loc1.loc_start.pos_cnum
+  | x -> x
+;;
+let cmp_ti_inner_first ti1 ti2 =
+  cmp_loc_inner_first (get_location ti1) (get_location ti2)
+;;
+
+let print_position pp pos =
+  if pos = dummy_pos then
+    output_string pp "--"
+  else begin
+    output_char pp '\"';
+    output_string pp (String.escaped pos.pos_fname);
+    output_string pp "\" ";
+    output_int pp pos.pos_lnum;
+    output_char pp ' ';
+    output_int pp pos.pos_bol;
+    output_char pp ' ';
+    output_int pp pos.pos_cnum;
+  end
+;;
+
+let print_location pp loc =
+  print_position pp loc.loc_start;
+  output_char pp ' ';
+  print_position pp loc.loc_end;
+;;
+
+let sort_filter_phrases () =
+  let ph = List.sort (fun x y -> cmp_loc_inner_first y x) !phrases in
+  let rec loop accu cur l =
+    match l with
+    | [] -> accu
+    | loc :: t ->
+       if cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum
+          && cur.loc_end.pos_cnum >= loc.loc_end.pos_cnum
+       then loop accu cur t
+       else loop (loc :: accu) loc t
+  in
+  phrases := loop [] Location.none ph;
+;;
+
+let rec printtyp_reset_maybe loc =
+  match !phrases with
+  | cur :: t when cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum ->
+     Printtyp.reset ();
+     phrases := t;
+     printtyp_reset_maybe loc;
+  | _ -> ()
+;;
+
+let call_kind_string k =
+  match k with
+  | Tail -> "tail"
+  | Stack -> "stack"
+  | Inline -> "inline"
+;;
+
+let print_ident_annot pp str k =
+  match k with
+  | Idef l ->
+      output_string pp "def ";
+      output_string pp str;
+      output_char pp ' ';
+      print_location pp l;
+      output_char pp '\n'
+  | Iref_internal l ->
+      output_string pp "int_ref ";
+      output_string pp str;
+      output_char pp ' ';
+      print_location pp l;
+      output_char pp '\n'
+  | Iref_external ->
+      output_string pp "ext_ref ";
+      output_string pp str;
+      output_char pp '\n'
+;;
+
+(* The format of the annotation file is documented in emacs/caml-types.el. *)
+
+let print_info pp prev_loc ti =
+  match ti with
+  | Ti_class _ | Ti_mod _ -> prev_loc
+  | Ti_pat  (_, {pat_loc = loc; pat_type = typ; pat_env = env})
+  | Ti_expr     {exp_loc = loc; exp_type = typ; exp_env = env} ->
+      if loc <> prev_loc then begin
+        print_location pp loc;
+        output_char pp '\n'
+      end;
+      output_string pp "type(\n";
+      printtyp_reset_maybe loc;
+      Printtyp.mark_loops typ;
+      Format.pp_print_string Format.str_formatter "  ";
+      Printtyp.wrap_printing_env ~error:false env
+                       (fun () -> Printtyp.type_sch Format.str_formatter typ);
+      Format.pp_print_newline Format.str_formatter ();
+      let s = Format.flush_str_formatter () in
+      output_string pp s;
+      output_string pp ")\n";
+      loc
+  | An_call (loc, k) ->
+      if loc <> prev_loc then begin
+        print_location pp loc;
+        output_char pp '\n'
+      end;
+      output_string pp "call(\n  ";
+      output_string pp (call_kind_string k);
+      output_string pp "\n)\n";
+      loc
+  | An_ident (loc, str, k) ->
+      if loc <> prev_loc then begin
+        print_location pp loc;
+        output_char pp '\n'
+      end;
+      output_string pp "ident(\n  ";
+      print_ident_annot pp str k;
+      output_string pp ")\n";
+      loc
+;;
+
+let get_info () =
+  let info = List.fast_sort cmp_ti_inner_first !annotations in
+  annotations := [];
+  info
+;;
+
+let dump filename =
+  if !Clflags.annotations then begin
+    let do_dump _temp_filename pp =
+      let info = get_info () in
+      sort_filter_phrases ();
+      ignore (List.fold_left (print_info pp) Location.none info) in
+    begin match filename with
+    | None -> do_dump "" stdout
+    | Some filename ->
+        Misc.output_to_file_via_temporary ~mode:[Open_text] filename do_dump
+    end;
+    phrases := [];
+  end else begin
+    annotations := [];
+  end;
+;;
diff --git a/upstream/ocaml_413/typing/stypes.mli b/upstream/ocaml_413/typing/stypes.mli
new file mode 100644
index 0000000..fda575f
--- /dev/null
+++ b/upstream/ocaml_413/typing/stypes.mli
@@ -0,0 +1,36 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Damien Doligez, projet Moscova, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2003 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Recording and dumping (partial) type information *)
+
+(* Clflags.save_types must be true *)
+
+open Typedtree;;
+
+type annotation =
+  | Ti_pat : 'k pattern_category * 'k general_pattern -> annotation
+  | Ti_expr  of expression
+  | Ti_class of class_expr
+  | Ti_mod   of module_expr
+  | An_call of Location.t * Annot.call
+  | An_ident of Location.t * string * Annot.ident
+;;
+
+val record : annotation -> unit;;
+val record_phrase : Location.t -> unit;;
+val dump : string option -> unit;;
+
+val get_location : annotation -> Location.t;;
+val get_info : unit -> annotation list;;
diff --git a/upstream/ocaml_413/typing/subst.ml b/upstream/ocaml_413/typing/subst.ml
new file mode 100644
index 0000000..6ad01b9
--- /dev/null
+++ b/upstream/ocaml_413/typing/subst.ml
@@ -0,0 +1,580 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Substitutions *)
+
+open Misc
+open Path
+open Types
+open Btype
+
+open Local_store
+
+type type_replacement =
+  | Path of Path.t
+  | Type_function of { params : type_expr list; body : type_expr }
+
+type t =
+  { types: type_replacement Path.Map.t;
+    modules: Path.t Path.Map.t;
+    modtypes: module_type Path.Map.t;
+    for_saving: bool;
+    loc: Location.t option;
+  }
+
+let identity =
+  { types = Path.Map.empty;
+    modules = Path.Map.empty;
+    modtypes = Path.Map.empty;
+    for_saving = false;
+    loc = None;
+  }
+
+let add_type_path id p s = { s with types = Path.Map.add id (Path p) s.types }
+let add_type id p s = add_type_path (Pident id) p s
+
+let add_type_function id ~params ~body s =
+  { s with types = Path.Map.add id (Type_function { params; body }) s.types }
+
+let add_module_path id p s = { s with modules = Path.Map.add id p s.modules }
+let add_module id p s = add_module_path (Pident id) p s
+
+let add_modtype_path p ty s = { s with modtypes = Path.Map.add p ty s.modtypes }
+let add_modtype id ty s = add_modtype_path (Pident id) ty s
+
+let for_saving s = { s with for_saving = true }
+
+let change_locs s loc = { s with loc = Some loc }
+
+let loc s x =
+  match s.loc with
+  | Some l -> l
+  | None ->
+    if s.for_saving && not !Clflags.keep_locs then Location.none else x
+
+let remove_loc =
+  let open Ast_mapper in
+  {default_mapper with location = (fun _this _loc -> Location.none)}
+
+let is_not_doc = function
+  | {Parsetree.attr_name = {Location.txt = "ocaml.doc"}; _} -> false
+  | {Parsetree.attr_name = {Location.txt = "ocaml.text"}; _} -> false
+  | {Parsetree.attr_name = {Location.txt = "doc"}; _} -> false
+  | {Parsetree.attr_name = {Location.txt = "text"}; _} -> false
+  | _ -> true
+
+let attrs s x =
+  let x =
+    if s.for_saving && not !Clflags.keep_docs then
+      List.filter is_not_doc x
+    else x
+  in
+    if s.for_saving && not !Clflags.keep_locs
+    then remove_loc.Ast_mapper.attributes remove_loc x
+    else x
+
+let rec module_path s path =
+  try Path.Map.find path s.modules
+  with Not_found ->
+    match path with
+    | Pident _ -> path
+    | Pdot(p, n) ->
+       Pdot(module_path s p, n)
+    | Papply(p1, p2) ->
+       Papply(module_path s p1, module_path s p2)
+
+let modtype_path s path =
+      match Path.Map.find path s.modtypes with
+      | Mty_ident p -> p
+      | Mty_alias _ | Mty_signature _ | Mty_functor _ ->
+         fatal_error "Subst.modtype_path"
+      | exception Not_found ->
+         match path with
+         | Pdot(p, n) ->
+            Pdot(module_path s p, n)
+         | Papply _ ->
+            fatal_error "Subst.modtype_path"
+         | Pident _ -> path
+
+let type_path s path =
+  match Path.Map.find path s.types with
+  | Path p -> p
+  | Type_function _ -> assert false
+  | exception Not_found ->
+     match path with
+     | Pident _ -> path
+     | Pdot(p, n) ->
+        Pdot(module_path s p, n)
+     | Papply _ ->
+        fatal_error "Subst.type_path"
+
+let type_path s p =
+  match Path.constructor_typath p with
+  | Regular p -> type_path s p
+  | Cstr (ty_path, cstr) -> Pdot(type_path s ty_path, cstr)
+  | LocalExt _ -> type_path s p
+  | Ext (p, cstr) -> Pdot(module_path s p, cstr)
+
+let to_subst_by_type_function s p =
+  match Path.Map.find p s.types with
+  | Path _ -> false
+  | Type_function _ -> true
+  | exception Not_found -> false
+
+(* Special type ids for saved signatures *)
+
+let new_id = s_ref (-1)
+let reset_for_saving () = new_id := -1
+
+let newpersty desc =
+  decr new_id;
+  Private_type_expr.create
+    desc ~level:generic_level ~scope:Btype.lowest_level ~id:!new_id
+
+(* ensure that all occurrences of 'Tvar None' are physically shared *)
+let tvar_none = Tvar None
+let tunivar_none = Tunivar None
+let norm = function
+  | Tvar None -> tvar_none
+  | Tunivar None -> tunivar_none
+  | d -> d
+
+let ctype_apply_env_empty = ref (fun _ -> assert false)
+
+(* Similar to [Ctype.nondep_type_rec]. *)
+let rec typexp copy_scope s ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tvar _ | Tunivar _ as desc ->
+      if s.for_saving || ty.id < 0 then
+        let ty' =
+          if s.for_saving then newpersty (norm desc)
+          else newty2 ty.level desc
+        in
+        For_copy.save_desc copy_scope ty desc;
+        Private_type_expr.set_desc ty (Tsubst (ty', None));
+        (* TODO: move this line to btype.ml
+           there is a similar problem also in ctype.ml *)
+        ty'
+      else ty
+  | Tsubst (ty, _) ->
+      ty
+  | Tfield (m, k, _t1, _t2) when not s.for_saving && m = dummy_method
+      && field_kind_repr k <> Fabsent && (repr ty).level < generic_level ->
+      (* do not copy the type of self when it is not generalized *)
+      ty
+(* cannot do it, since it would omit substitution
+  | Tvariant row when not (static_row row) ->
+      ty
+*)
+  | _ ->
+    let desc = ty.desc in
+    For_copy.save_desc copy_scope ty desc;
+    let tm = row_of_type ty in
+    let has_fixed_row =
+      not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm in
+    (* Make a stub *)
+    let ty' = if s.for_saving then newpersty (Tvar None) else newgenvar () in
+    Private_type_expr.set_scope ty' ty.scope;
+    Private_type_expr.set_desc ty (Tsubst (ty', None));
+    Private_type_expr.set_desc ty'
+      begin if has_fixed_row then
+        match tm.desc with (* PR#7348 *)
+          Tconstr (Pdot(m,i), tl, _abbrev) ->
+            let i' = String.sub i 0 (String.length i - 4) in
+            Tconstr(type_path s (Pdot(m,i')), tl, ref Mnil)
+        | _ -> assert false
+      else match desc with
+      | Tconstr (p, args, _abbrev) ->
+         let args = List.map (typexp copy_scope s) args in
+         begin match Path.Map.find p s.types with
+         | exception Not_found -> Tconstr(type_path s p, args, ref Mnil)
+         | Path _ -> Tconstr(type_path s p, args, ref Mnil)
+         | Type_function { params; body } ->
+            Tlink (!ctype_apply_env_empty params body args)
+         end
+      | Tpackage(p, fl) ->
+          Tpackage(modtype_path s p,
+                    List.map (fun (n, ty) -> (n, typexp copy_scope s ty)) fl)
+      | Tobject (t1, name) ->
+          let t1' = typexp copy_scope s t1 in
+          let name' =
+            match !name with
+            | None -> None
+            | Some (p, tl) ->
+                if to_subst_by_type_function s p
+                then None
+                else Some (type_path s p, List.map (typexp copy_scope s) tl)
+          in
+          Tobject (t1', ref name')
+      | Tvariant row ->
+          let row = row_repr row in
+          let more = repr row.row_more in
+          (* We must substitute in a subtle way *)
+          (* Tsubst takes a tuple containing the row var and the variant *)
+          begin match more.desc with
+            Tsubst (_, Some ty2) ->
+              (* This variant type has been already copied *)
+              Private_type_expr.set_desc ty (Tsubst (ty2, None));
+              (* avoid Tlink in the new type *)
+              Tlink ty2
+          | _ ->
+              let dup =
+                s.for_saving || more.level = generic_level || static_row row ||
+                match more.desc with Tconstr _ -> true | _ -> false in
+              (* Various cases for the row variable *)
+              let more' =
+                match more.desc with
+                  Tsubst (ty, None) -> ty
+                | Tconstr _ | Tnil -> typexp copy_scope s more
+                | Tunivar _ | Tvar _ ->
+                    For_copy.save_desc copy_scope more more.desc;
+                    if s.for_saving then newpersty (norm more.desc) else
+                    if dup && is_Tvar more then newgenty more.desc else more
+                | _ -> assert false
+              in
+              (* Register new type first for recursion *)
+              Private_type_expr.set_desc more
+                (Tsubst (more', Some ty'));
+              (* TODO: check if more' can be eliminated *)
+              (* Return a new copy *)
+              let row =
+                copy_row (typexp copy_scope s) true row (not dup) more' in
+              match row.row_name with
+              | Some (p, tl) ->
+                 Tvariant {row with row_name =
+                                      if to_subst_by_type_function s p
+                                      then None
+                                      else Some (type_path s p, tl)}
+              | None ->
+                  Tvariant row
+          end
+      | Tfield(_label, kind, _t1, t2) when field_kind_repr kind = Fabsent ->
+          Tlink (typexp copy_scope s t2)
+      | _ -> copy_type_desc (typexp copy_scope s) desc
+      end;
+    ty'
+
+(*
+   Always make a copy of the type. If this is not done, type levels
+   might not be correct.
+*)
+let type_expr s ty =
+  For_copy.with_scope (fun copy_scope -> typexp copy_scope s ty)
+
+let label_declaration copy_scope s l =
+  {
+    ld_id = l.ld_id;
+    ld_mutable = l.ld_mutable;
+    ld_type = typexp copy_scope s l.ld_type;
+    ld_loc = loc s l.ld_loc;
+    ld_attributes = attrs s l.ld_attributes;
+    ld_uid = l.ld_uid;
+  }
+
+let constructor_arguments copy_scope s = function
+  | Cstr_tuple l ->
+      Cstr_tuple (List.map (typexp copy_scope s) l)
+  | Cstr_record l ->
+      Cstr_record (List.map (label_declaration copy_scope s) l)
+
+let constructor_declaration copy_scope s c =
+  {
+    cd_id = c.cd_id;
+    cd_args = constructor_arguments copy_scope s c.cd_args;
+    cd_res = Option.map (typexp copy_scope s) c.cd_res;
+    cd_loc = loc s c.cd_loc;
+    cd_attributes = attrs s c.cd_attributes;
+    cd_uid = c.cd_uid;
+  }
+
+let type_declaration' copy_scope s decl =
+  { type_params = List.map (typexp copy_scope s) decl.type_params;
+    type_arity = decl.type_arity;
+    type_kind =
+      begin match decl.type_kind with
+        Type_abstract -> Type_abstract
+      | Type_variant (cstrs, rep) ->
+          Type_variant (List.map (constructor_declaration copy_scope s) cstrs,
+                        rep)
+      | Type_record(lbls, rep) ->
+          Type_record (List.map (label_declaration copy_scope s) lbls, rep)
+      | Type_open -> Type_open
+      end;
+    type_manifest =
+      begin
+        match decl.type_manifest with
+          None -> None
+        | Some ty -> Some(typexp copy_scope s ty)
+      end;
+    type_private = decl.type_private;
+    type_variance = decl.type_variance;
+    type_separability = decl.type_separability;
+    type_is_newtype = false;
+    type_expansion_scope = Btype.lowest_level;
+    type_loc = loc s decl.type_loc;
+    type_attributes = attrs s decl.type_attributes;
+    type_immediate = decl.type_immediate;
+    type_unboxed_default = decl.type_unboxed_default;
+    type_uid = decl.type_uid;
+  }
+
+let type_declaration s decl =
+  For_copy.with_scope (fun copy_scope -> type_declaration' copy_scope s decl)
+
+let class_signature copy_scope s sign =
+  { csig_self = typexp copy_scope s sign.csig_self;
+    csig_vars =
+      Vars.map
+        (function (m, v, t) -> (m, v, typexp copy_scope s t)) sign.csig_vars;
+    csig_concr = sign.csig_concr;
+    csig_inher =
+      List.map
+        (fun (p, tl) -> (type_path s p, List.map (typexp copy_scope s) tl))
+        sign.csig_inher;
+  }
+
+let rec class_type copy_scope s = function
+  | Cty_constr (p, tyl, cty) ->
+      let p' = type_path s p in
+      let tyl' = List.map (typexp copy_scope s) tyl in
+      let cty' = class_type copy_scope s cty in
+      Cty_constr (p', tyl', cty')
+  | Cty_signature sign ->
+      Cty_signature (class_signature copy_scope s sign)
+  | Cty_arrow (l, ty, cty) ->
+      Cty_arrow (l, typexp copy_scope s ty, class_type copy_scope s cty)
+
+let class_declaration' copy_scope s decl =
+  { cty_params = List.map (typexp copy_scope s) decl.cty_params;
+    cty_variance = decl.cty_variance;
+    cty_type = class_type copy_scope s decl.cty_type;
+    cty_path = type_path s decl.cty_path;
+    cty_new =
+      begin match decl.cty_new with
+      | None    -> None
+      | Some ty -> Some (typexp copy_scope s ty)
+      end;
+    cty_loc = loc s decl.cty_loc;
+    cty_attributes = attrs s decl.cty_attributes;
+    cty_uid = decl.cty_uid;
+  }
+
+let class_declaration s decl =
+  For_copy.with_scope (fun copy_scope -> class_declaration' copy_scope s decl)
+
+let cltype_declaration' copy_scope s decl =
+  { clty_params = List.map (typexp copy_scope s) decl.clty_params;
+    clty_variance = decl.clty_variance;
+    clty_type = class_type copy_scope s decl.clty_type;
+    clty_path = type_path s decl.clty_path;
+    clty_loc = loc s decl.clty_loc;
+    clty_attributes = attrs s decl.clty_attributes;
+    clty_uid = decl.clty_uid;
+  }
+
+let cltype_declaration s decl =
+  For_copy.with_scope (fun copy_scope -> cltype_declaration' copy_scope s decl)
+
+let class_type s cty =
+  For_copy.with_scope (fun copy_scope -> class_type copy_scope s cty)
+
+let value_description' copy_scope s descr =
+  { val_type = typexp copy_scope s descr.val_type;
+    val_kind = descr.val_kind;
+    val_loc = loc s descr.val_loc;
+    val_attributes = attrs s descr.val_attributes;
+    val_uid = descr.val_uid;
+   }
+
+let value_description s descr =
+  For_copy.with_scope (fun copy_scope -> value_description' copy_scope s descr)
+
+let extension_constructor' copy_scope s ext =
+  { ext_type_path = type_path s ext.ext_type_path;
+    ext_type_params = List.map (typexp copy_scope s) ext.ext_type_params;
+    ext_args = constructor_arguments copy_scope s ext.ext_args;
+    ext_ret_type = Option.map (typexp copy_scope s) ext.ext_ret_type;
+    ext_private = ext.ext_private;
+    ext_attributes = attrs s ext.ext_attributes;
+    ext_loc = if s.for_saving then Location.none else ext.ext_loc;
+    ext_uid = ext.ext_uid;
+  }
+
+let extension_constructor s ext =
+  For_copy.with_scope
+    (fun copy_scope -> extension_constructor' copy_scope s ext)
+
+type scoping =
+  | Keep
+  | Make_local
+  | Rescope of int
+
+let rename_bound_idents scoping s sg =
+  let rename =
+    let open Ident in
+    match scoping with
+    | Keep -> (fun id -> create_scoped ~scope:(scope id) (name id))
+    | Make_local -> Ident.rename
+    | Rescope scope -> (fun id -> create_scoped ~scope (name id))
+  in
+  let rec rename_bound_idents s sg = function
+    | [] -> sg, s
+    | Sig_type(id, td, rs, vis) :: rest ->
+        let id' = rename id in
+        rename_bound_idents
+          (add_type id (Pident id') s)
+          (Sig_type(id', td, rs, vis) :: sg)
+          rest
+    | Sig_module(id, pres, md, rs, vis) :: rest ->
+        let id' = rename id in
+        rename_bound_idents
+          (add_module id (Pident id') s)
+          (Sig_module (id', pres, md, rs, vis) :: sg)
+          rest
+    | Sig_modtype(id, mtd, vis) :: rest ->
+        let id' = rename id in
+        rename_bound_idents
+          (add_modtype id (Mty_ident(Pident id')) s)
+          (Sig_modtype(id', mtd, vis) :: sg)
+          rest
+    | Sig_class(id, cd, rs, vis) :: rest ->
+        (* cheat and pretend they are types cf. PR#6650 *)
+        let id' = rename id in
+        rename_bound_idents
+          (add_type id (Pident id') s)
+          (Sig_class(id', cd, rs, vis) :: sg)
+          rest
+    | Sig_class_type(id, ctd, rs, vis) :: rest ->
+        (* cheat and pretend they are types cf. PR#6650 *)
+        let id' = rename id in
+        rename_bound_idents
+          (add_type id (Pident id') s)
+          (Sig_class_type(id', ctd, rs, vis) :: sg)
+          rest
+    | Sig_value(id, vd, vis) :: rest ->
+        (* scope doesn't matter for value identifiers. *)
+        let id' = Ident.rename id in
+        rename_bound_idents s (Sig_value(id', vd, vis) :: sg) rest
+    | Sig_typext(id, ec, es, vis) :: rest ->
+        let id' = rename id in
+        rename_bound_idents s (Sig_typext(id',ec,es,vis) :: sg) rest
+  in
+  rename_bound_idents s [] sg
+
+let rec modtype scoping s = function
+    Mty_ident p as mty ->
+      begin match Path.Map.find p s.modtypes with
+       | mty -> mty
+       | exception Not_found ->
+          begin match p with
+          | Pident _ -> mty
+          | Pdot(p, n) ->
+             Mty_ident(Pdot(module_path s p, n))
+          | Papply _ ->
+             fatal_error "Subst.modtype"
+          end
+      end
+  | Mty_signature sg ->
+      Mty_signature(signature scoping s sg)
+  | Mty_functor(Unit, res) ->
+      Mty_functor(Unit, modtype scoping s res)
+  | Mty_functor(Named (None, arg), res) ->
+      Mty_functor(Named (None, (modtype scoping s) arg), modtype scoping s res)
+  | Mty_functor(Named (Some id, arg), res) ->
+      let id' = Ident.rename id in
+      Mty_functor(Named (Some id', (modtype scoping s) arg),
+                  modtype scoping (add_module id (Pident id') s) res)
+  | Mty_alias p ->
+      Mty_alias (module_path s p)
+
+and signature scoping s sg =
+  (* Components of signature may be mutually recursive (e.g. type declarations
+     or class and type declarations), so first build global renaming
+     substitution... *)
+  let (sg', s') = rename_bound_idents scoping s sg in
+  (* ... then apply it to each signature component in turn *)
+  For_copy.with_scope (fun copy_scope ->
+    List.rev_map (signature_item' copy_scope scoping s') sg'
+  )
+
+
+and signature_item' copy_scope scoping s comp =
+  match comp with
+    Sig_value(id, d, vis) ->
+      Sig_value(id, value_description' copy_scope s d, vis)
+  | Sig_type(id, d, rs, vis) ->
+      Sig_type(id, type_declaration' copy_scope s d, rs, vis)
+  | Sig_typext(id, ext, es, vis) ->
+      Sig_typext(id, extension_constructor' copy_scope s ext, es, vis)
+  | Sig_module(id, pres, d, rs, vis) ->
+      Sig_module(id, pres, module_declaration scoping s d, rs, vis)
+  | Sig_modtype(id, d, vis) ->
+      Sig_modtype(id, modtype_declaration scoping s d, vis)
+  | Sig_class(id, d, rs, vis) ->
+      Sig_class(id, class_declaration' copy_scope s d, rs, vis)
+  | Sig_class_type(id, d, rs, vis) ->
+      Sig_class_type(id, cltype_declaration' copy_scope s d, rs, vis)
+
+and signature_item scoping s comp =
+  For_copy.with_scope
+    (fun copy_scope -> signature_item' copy_scope scoping s comp)
+
+and module_declaration scoping s decl =
+  {
+    md_type = modtype scoping s decl.md_type;
+    md_attributes = attrs s decl.md_attributes;
+    md_loc = loc s decl.md_loc;
+    md_uid = decl.md_uid;
+  }
+
+and modtype_declaration scoping s decl  =
+  {
+    mtd_type = Option.map (modtype scoping s) decl.mtd_type;
+    mtd_attributes = attrs s decl.mtd_attributes;
+    mtd_loc = loc s decl.mtd_loc;
+    mtd_uid = decl.mtd_uid;
+  }
+
+
+(* For every binding k |-> d of m1, add k |-> f d to m2
+   and return resulting merged map. *)
+
+let merge_path_maps f m1 m2 =
+  Path.Map.fold (fun k d accu -> Path.Map.add k (f d) accu) m1 m2
+
+let keep_latest_loc l1 l2 =
+  match l2 with
+  | None -> l1
+  | Some _ -> l2
+
+let type_replacement s = function
+  | Path p -> Path (type_path s p)
+  | Type_function { params; body } ->
+    For_copy.with_scope (fun copy_scope ->
+     let params = List.map (typexp copy_scope s) params in
+     let body = typexp copy_scope s body in
+     Type_function { params; body })
+
+(* Composition of substitutions:
+     apply (compose s1 s2) x = apply s2 (apply s1 x) *)
+
+let compose s1 s2 =
+  { types = merge_path_maps (type_replacement s2) s1.types s2.types;
+    modules = merge_path_maps (module_path s2) s1.modules s2.modules;
+    modtypes = merge_path_maps (modtype Keep s2) s1.modtypes s2.modtypes;
+    for_saving = s1.for_saving || s2.for_saving;
+    loc = keep_latest_loc s1.loc s2.loc;
+  }
diff --git a/upstream/ocaml_413/typing/subst.mli b/upstream/ocaml_413/typing/subst.mli
new file mode 100644
index 0000000..4ae8e13
--- /dev/null
+++ b/upstream/ocaml_413/typing/subst.mli
@@ -0,0 +1,89 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Substitutions *)
+
+open Types
+
+type t
+
+(*
+   Substitutions are used to translate a type from one context to
+   another.  This requires substituting paths for identifiers, and
+   possibly also lowering the level of non-generic variables so that
+   they are inferior to the maximum level of the new context.
+
+   Substitutions can also be used to create a "clean" copy of a type.
+   Indeed, non-variable node of a type are duplicated, with their
+   levels set to generic level.  That way, the resulting type is
+   well-formed (decreasing levels), even if the original one was not.
+*)
+
+val identity: t
+
+val add_type: Ident.t -> Path.t -> t -> t
+val add_type_path: Path.t -> Path.t -> t -> t
+val add_type_function:
+  Path.t -> params:type_expr list -> body:type_expr -> t -> t
+val add_module: Ident.t -> Path.t -> t -> t
+val add_module_path: Path.t -> Path.t -> t -> t
+val add_modtype: Ident.t -> module_type -> t -> t
+val add_modtype_path: Path.t -> module_type -> t -> t
+
+val for_saving: t -> t
+val reset_for_saving: unit -> unit
+val change_locs: t -> Location.t -> t
+
+val module_path: t -> Path.t -> Path.t
+val type_path: t -> Path.t -> Path.t
+val modtype_path: t -> Path.t -> Path.t
+
+val type_expr: t -> type_expr -> type_expr
+val class_type: t -> class_type -> class_type
+val value_description: t -> value_description -> value_description
+val type_declaration: t -> type_declaration -> type_declaration
+val extension_constructor:
+        t -> extension_constructor -> extension_constructor
+val class_declaration: t -> class_declaration -> class_declaration
+val cltype_declaration: t -> class_type_declaration -> class_type_declaration
+
+(*
+   When applied to a signature item, a substitution not only modifies the types
+   present in its declaration, but also refreshes the identifier of the item.
+   Effectively this creates new declarations, and so one should decide what the
+   scope of this new declaration should be.
+
+   This is decided by the [scoping] argument passed to the following functions.
+*)
+
+type scoping =
+  | Keep
+  | Make_local
+  | Rescope of int
+
+val modtype: scoping -> t -> module_type -> module_type
+val signature: scoping -> t -> signature -> signature
+val signature_item: scoping -> t -> signature_item -> signature_item
+val modtype_declaration:
+  scoping -> t -> modtype_declaration -> modtype_declaration
+val module_declaration: scoping -> t -> module_declaration -> module_declaration
+
+(* Composition of substitutions:
+     apply (compose s1 s2) x = apply s2 (apply s1 x) *)
+val compose: t -> t -> t
+
+(* A forward reference to be filled in ctype.ml. *)
+val ctype_apply_env_empty:
+  (type_expr list -> type_expr -> type_expr list -> type_expr) ref
diff --git a/upstream/ocaml_413/typing/tast_iterator.ml b/upstream/ocaml_413/typing/tast_iterator.ml
new file mode 100644
index 0000000..bdb8d74
--- /dev/null
+++ b/upstream/ocaml_413/typing/tast_iterator.ml
@@ -0,0 +1,516 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                          Isaac "Izzy" Avram                            *)
+(*                                                                        *)
+(*   Copyright 2019 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Typedtree
+
+type iterator =
+  {
+    binding_op: iterator -> binding_op -> unit;
+    case: 'k . iterator -> 'k case -> unit;
+    class_declaration: iterator -> class_declaration -> unit;
+    class_description: iterator -> class_description -> unit;
+    class_expr: iterator -> class_expr -> unit;
+    class_field: iterator -> class_field -> unit;
+    class_signature: iterator -> class_signature -> unit;
+    class_structure: iterator -> class_structure -> unit;
+    class_type: iterator -> class_type -> unit;
+    class_type_declaration: iterator -> class_type_declaration -> unit;
+    class_type_field: iterator -> class_type_field -> unit;
+    env: iterator -> Env.t -> unit;
+    expr: iterator -> expression -> unit;
+    extension_constructor: iterator -> extension_constructor -> unit;
+    module_binding: iterator -> module_binding -> unit;
+    module_coercion: iterator -> module_coercion -> unit;
+    module_declaration: iterator -> module_declaration -> unit;
+    module_substitution: iterator -> module_substitution -> unit;
+    module_expr: iterator -> module_expr -> unit;
+    module_type: iterator -> module_type -> unit;
+    module_type_declaration: iterator -> module_type_declaration -> unit;
+    package_type: iterator -> package_type -> unit;
+    pat: 'k . iterator -> 'k general_pattern -> unit;
+    row_field: iterator -> row_field -> unit;
+    object_field: iterator -> object_field -> unit;
+    open_declaration: iterator -> open_declaration -> unit;
+    open_description: iterator -> open_description -> unit;
+    signature: iterator -> signature -> unit;
+    signature_item: iterator -> signature_item -> unit;
+    structure: iterator -> structure -> unit;
+    structure_item: iterator -> structure_item -> unit;
+    typ: iterator -> core_type -> unit;
+    type_declaration: iterator -> type_declaration -> unit;
+    type_declarations: iterator -> (rec_flag * type_declaration list) -> unit;
+    type_extension: iterator -> type_extension -> unit;
+    type_exception: iterator -> type_exception -> unit;
+    type_kind: iterator -> type_kind -> unit;
+    value_binding: iterator -> value_binding -> unit;
+    value_bindings: iterator -> (rec_flag * value_binding list) -> unit;
+    value_description: iterator -> value_description -> unit;
+    with_constraint: iterator -> with_constraint -> unit;
+  }
+
+let structure sub {str_items; str_final_env; _} =
+  List.iter (sub.structure_item sub) str_items;
+  sub.env sub str_final_env
+
+let class_infos sub f x =
+  List.iter (fun (ct, _) -> sub.typ sub ct) x.ci_params;
+  f x.ci_expr
+
+let module_type_declaration sub {mtd_type; _} =
+  Option.iter (sub.module_type sub) mtd_type
+
+let module_declaration sub {md_type; _} =
+  sub.module_type sub md_type
+let module_substitution _ _ = ()
+
+let include_infos f {incl_mod; _} = f incl_mod
+
+let class_type_declaration sub x =
+  class_infos sub (sub.class_type sub) x
+
+let class_declaration sub x =
+  class_infos sub (sub.class_expr sub) x
+
+let structure_item sub {str_desc; str_env; _} =
+  sub.env sub str_env;
+  match str_desc with
+  | Tstr_eval   (exp, _) -> sub.expr sub exp
+  | Tstr_value  (rec_flag, list) -> sub.value_bindings sub (rec_flag, list)
+  | Tstr_primitive v -> sub.value_description sub v
+  | Tstr_type (rec_flag, list) -> sub.type_declarations sub (rec_flag, list)
+  | Tstr_typext te -> sub.type_extension sub te
+  | Tstr_exception ext -> sub.type_exception sub ext
+  | Tstr_module mb -> sub.module_binding sub mb
+  | Tstr_recmodule list -> List.iter (sub.module_binding sub) list
+  | Tstr_modtype x -> sub.module_type_declaration sub x
+  | Tstr_class list ->
+      List.iter (fun (cls,_) -> sub.class_declaration sub cls) list
+  | Tstr_class_type list ->
+      List.iter (fun (_, _, cltd) -> sub.class_type_declaration sub cltd) list
+  | Tstr_include incl -> include_infos (sub.module_expr sub) incl
+  | Tstr_open od -> sub.open_declaration sub od
+  | Tstr_attribute _ -> ()
+
+let value_description sub x = sub.typ sub x.val_desc
+
+let label_decl sub {ld_type; _} = sub.typ sub ld_type
+
+let constructor_args sub = function
+  | Cstr_tuple l -> List.iter (sub.typ sub) l
+  | Cstr_record l -> List.iter (label_decl sub) l
+
+let constructor_decl sub {cd_args; cd_res; _} =
+  constructor_args sub cd_args;
+  Option.iter (sub.typ sub) cd_res
+
+let type_kind sub = function
+  | Ttype_abstract -> ()
+  | Ttype_variant list -> List.iter (constructor_decl sub) list
+  | Ttype_record list -> List.iter (label_decl sub) list
+  | Ttype_open -> ()
+
+let type_declaration sub {typ_cstrs; typ_kind; typ_manifest; typ_params; _} =
+  List.iter
+    (fun (c1, c2, _) ->
+      sub.typ sub c1;
+      sub.typ sub c2)
+    typ_cstrs;
+  sub.type_kind sub typ_kind;
+  Option.iter (sub.typ sub) typ_manifest;
+  List.iter (fun (c, _) -> sub.typ sub c) typ_params
+
+let type_declarations sub (_, list) = List.iter (sub.type_declaration sub) list
+
+let type_extension sub {tyext_constructors; tyext_params; _} =
+  List.iter (fun (c, _) -> sub.typ sub c) tyext_params;
+  List.iter (sub.extension_constructor sub) tyext_constructors
+
+let type_exception sub {tyexn_constructor; _} =
+  sub.extension_constructor sub tyexn_constructor
+
+let extension_constructor sub {ext_kind; _} =
+  match ext_kind with
+  | Text_decl (ctl, cto) ->
+      constructor_args sub ctl;
+      Option.iter (sub.typ sub) cto
+  | Text_rebind _ -> ()
+
+let pat_extra sub (e, _loc, _attrs) = match e with
+  | Tpat_type _ -> ()
+  | Tpat_unpack -> ()
+  | Tpat_open (_, _, env) -> sub.env sub env
+  | Tpat_constraint ct -> sub.typ sub ct
+
+let pat
+  : type k . iterator -> k general_pattern -> unit
+  = fun sub {pat_extra = extra; pat_desc; pat_env; _} ->
+  sub.env sub pat_env;
+  List.iter (pat_extra sub) extra;
+  match pat_desc with
+  | Tpat_any  -> ()
+  | Tpat_var _ -> ()
+  | Tpat_constant _ -> ()
+  | Tpat_tuple l -> List.iter (sub.pat sub) l
+  | Tpat_construct (_, _, l, vto) ->
+      List.iter (sub.pat sub) l;
+      Option.iter (fun (_ids, ct) -> sub.typ sub ct) vto
+  | Tpat_variant (_, po, _) -> Option.iter (sub.pat sub) po
+  | Tpat_record (l, _) -> List.iter (fun (_, _, i) -> sub.pat sub i) l
+  | Tpat_array l -> List.iter (sub.pat sub) l
+  | Tpat_alias (p, _, _) -> sub.pat sub p
+  | Tpat_lazy p -> sub.pat sub p
+  | Tpat_value p -> sub.pat sub (p :> pattern)
+  | Tpat_exception p -> sub.pat sub p
+  | Tpat_or (p1, p2, _) ->
+      sub.pat sub p1;
+      sub.pat sub p2
+
+let expr sub {exp_extra; exp_desc; exp_env; _} =
+  let extra = function
+    | Texp_constraint cty -> sub.typ sub cty
+    | Texp_coerce (cty1, cty2) ->
+        Option.iter (sub.typ sub) cty1;
+        sub.typ sub cty2
+    | Texp_newtype _ -> ()
+    | Texp_poly cto -> Option.iter (sub.typ sub) cto
+  in
+  List.iter (fun (e, _, _) -> extra e) exp_extra;
+  sub.env sub exp_env;
+  match exp_desc with
+  | Texp_ident _  -> ()
+  | Texp_constant _ -> ()
+  | Texp_let (rec_flag, list, exp) ->
+      sub.value_bindings sub (rec_flag, list);
+      sub.expr sub exp
+  | Texp_function {cases; _} ->
+     List.iter (sub.case sub) cases
+  | Texp_apply (exp, list) ->
+      sub.expr sub exp;
+      List.iter (fun (_, o) -> Option.iter (sub.expr sub) o) list
+  | Texp_match (exp, cases, _) ->
+      sub.expr sub exp;
+      List.iter (sub.case sub) cases
+  | Texp_try (exp, cases) ->
+      sub.expr sub exp;
+      List.iter (sub.case sub) cases
+  | Texp_tuple list -> List.iter (sub.expr sub) list
+  | Texp_construct (_, _, args) -> List.iter (sub.expr sub) args
+  | Texp_variant (_, expo) -> Option.iter (sub.expr sub) expo
+  | Texp_record { fields; extended_expression; _} ->
+      Array.iter (function
+        | _, Kept _ -> ()
+        | _, Overridden (_, exp) -> sub.expr sub exp)
+        fields;
+      Option.iter (sub.expr sub) extended_expression;
+  | Texp_field (exp, _, _) -> sub.expr sub exp
+  | Texp_setfield (exp1, _, _, exp2) ->
+      sub.expr sub exp1;
+      sub.expr sub exp2
+  | Texp_array list -> List.iter (sub.expr sub) list
+  | Texp_ifthenelse (exp1, exp2, expo) ->
+      sub.expr sub exp1;
+      sub.expr sub exp2;
+      Option.iter (sub.expr sub) expo
+  | Texp_sequence (exp1, exp2) ->
+      sub.expr sub exp1;
+      sub.expr sub exp2
+  | Texp_while (exp1, exp2) ->
+      sub.expr sub exp1;
+      sub.expr sub exp2
+  | Texp_for (_, _, exp1, exp2, _, exp3) ->
+      sub.expr sub exp1;
+      sub.expr sub exp2;
+      sub.expr sub exp3
+  | Texp_send (exp, _, expo) ->
+      sub.expr sub exp;
+      Option.iter (sub.expr sub) expo
+  | Texp_new _ -> ()
+  | Texp_instvar _ -> ()
+  | Texp_setinstvar (_, _, _, exp) ->sub.expr sub exp
+  | Texp_override (_, list) ->
+      List.iter (fun (_, _, e) -> sub.expr sub e) list
+  | Texp_letmodule (_, _, _, mexpr, exp) ->
+      sub.module_expr sub mexpr;
+      sub.expr sub exp
+  | Texp_letexception (cd, exp) ->
+      sub.extension_constructor sub cd;
+      sub.expr sub exp
+  | Texp_assert exp -> sub.expr sub exp
+  | Texp_lazy exp -> sub.expr sub exp
+  | Texp_object (cl, _) -> sub.class_structure sub cl
+  | Texp_pack mexpr -> sub.module_expr sub mexpr
+  | Texp_letop {let_ = l; ands; body; _} ->
+      sub.binding_op sub l;
+      List.iter (sub.binding_op sub) ands;
+      sub.case sub body
+  | Texp_unreachable -> ()
+  | Texp_extension_constructor _ -> ()
+  | Texp_open (od, e) ->
+      sub.open_declaration sub od;
+      sub.expr sub e
+
+
+let package_type sub {pack_fields; _} =
+  List.iter (fun (_, p) -> sub.typ sub p) pack_fields
+
+let binding_op sub {bop_exp; _} = sub.expr sub bop_exp
+
+let signature sub {sig_items; sig_final_env; _} =
+  sub.env sub sig_final_env;
+  List.iter (sub.signature_item sub) sig_items
+
+let signature_item sub {sig_desc; sig_env; _} =
+  sub.env sub sig_env;
+  match sig_desc with
+  | Tsig_value v -> sub.value_description sub v
+  | Tsig_type (rf, tdl)  -> sub.type_declarations sub (rf, tdl)
+  | Tsig_typesubst list -> sub.type_declarations sub (Nonrecursive, list)
+  | Tsig_typext te -> sub.type_extension sub te
+  | Tsig_exception ext -> sub.type_exception sub ext
+  | Tsig_module x -> sub.module_declaration sub x
+  | Tsig_modsubst x -> sub.module_substitution sub x
+  | Tsig_recmodule list -> List.iter (sub.module_declaration sub) list
+  | Tsig_modtype x -> sub.module_type_declaration sub x
+  | Tsig_modtypesubst x -> sub.module_type_declaration sub x
+  | Tsig_include incl -> include_infos (sub.module_type sub) incl
+  | Tsig_class list -> List.iter (sub.class_description sub) list
+  | Tsig_class_type list -> List.iter (sub.class_type_declaration sub) list
+  | Tsig_open od -> sub.open_description sub od
+  | Tsig_attribute _ -> ()
+
+let class_description sub x =
+  class_infos sub (sub.class_type sub) x
+
+let functor_parameter sub = function
+  | Unit -> ()
+  | Named (_, _, mtype) -> sub.module_type sub mtype
+
+let module_type sub {mty_desc; mty_env; _} =
+  sub.env sub mty_env;
+  match mty_desc with
+  | Tmty_ident _      -> ()
+  | Tmty_alias _      -> ()
+  | Tmty_signature sg -> sub.signature sub sg
+  | Tmty_functor (arg, mtype2) ->
+      functor_parameter sub arg;
+      sub.module_type sub mtype2
+  | Tmty_with (mtype, list) ->
+      sub.module_type sub mtype;
+      List.iter (fun (_, _, e) -> sub.with_constraint sub e) list
+  | Tmty_typeof mexpr -> sub.module_expr sub mexpr
+
+let with_constraint sub = function
+  | Twith_type      decl -> sub.type_declaration sub decl
+  | Twith_typesubst decl -> sub.type_declaration sub decl
+  | Twith_module    _    -> ()
+  | Twith_modsubst  _    -> ()
+  | Twith_modtype   _    -> ()
+  | Twith_modtypesubst _ -> ()
+
+
+let open_description sub {open_env; _} = sub.env sub open_env
+
+let open_declaration sub {open_expr; open_env; _} =
+  sub.module_expr sub open_expr;
+  sub.env sub open_env
+
+let module_coercion sub = function
+  | Tcoerce_none -> ()
+  | Tcoerce_functor (c1,c2) ->
+      sub.module_coercion sub c1;
+      sub.module_coercion sub c2
+  | Tcoerce_alias (env, _, c1) ->
+      sub.env sub env;
+      sub.module_coercion sub c1
+  | Tcoerce_structure (l1, l2) ->
+      List.iter (fun (_, c) -> sub.module_coercion sub c) l1;
+      List.iter (fun (_, _ ,c) -> sub.module_coercion sub c) l2
+  | Tcoerce_primitive {pc_env; _} -> sub.env sub pc_env
+
+let module_expr sub {mod_desc; mod_env; _} =
+  sub.env sub mod_env;
+  match mod_desc with
+  | Tmod_ident _      -> ()
+  | Tmod_structure st -> sub.structure sub st
+  | Tmod_functor (arg, mexpr) ->
+      functor_parameter sub arg;
+      sub.module_expr sub mexpr
+  | Tmod_apply (mexp1, mexp2, c) ->
+      sub.module_expr sub mexp1;
+      sub.module_expr sub mexp2;
+      sub.module_coercion sub c
+  | Tmod_constraint (mexpr, _, Tmodtype_implicit, c) ->
+      sub.module_expr sub mexpr;
+      sub.module_coercion sub c
+  | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, c) ->
+      sub.module_expr sub mexpr;
+      sub.module_type sub mtype;
+      sub.module_coercion sub c
+  | Tmod_unpack (exp, _) -> sub.expr sub exp
+
+let module_binding sub {mb_expr; _} = sub.module_expr sub mb_expr
+
+let class_expr sub {cl_desc; cl_env; _} =
+  sub.env sub cl_env;
+  match cl_desc with
+  | Tcl_constraint (cl, clty, _, _, _) ->
+      sub.class_expr sub cl;
+      Option.iter (sub.class_type sub) clty
+  | Tcl_structure clstr -> sub.class_structure sub clstr
+  | Tcl_fun (_, pat, priv, cl, _) ->
+      sub.pat sub pat;
+      List.iter (fun (_, e) -> sub.expr sub e) priv;
+      sub.class_expr sub cl
+  | Tcl_apply (cl, args) ->
+      sub.class_expr sub cl;
+      List.iter (fun (_, e) -> Option.iter (sub.expr sub) e) args
+  | Tcl_let (rec_flag, value_bindings, ivars, cl) ->
+      sub.value_bindings sub (rec_flag, value_bindings);
+      List.iter (fun (_, e) -> sub.expr sub e) ivars;
+      sub.class_expr sub cl
+  | Tcl_ident (_, _, tyl) -> List.iter (sub.typ sub) tyl
+  | Tcl_open (od, e) ->
+      sub.open_description sub od;
+      sub.class_expr sub e
+
+let class_type sub {cltyp_desc; cltyp_env; _} =
+  sub.env sub cltyp_env;
+  match cltyp_desc with
+  | Tcty_signature csg -> sub.class_signature sub csg
+  | Tcty_constr (_, _, list) -> List.iter (sub.typ sub) list
+  | Tcty_arrow (_, ct, cl) ->
+      sub.typ sub ct;
+      sub.class_type sub cl
+  | Tcty_open (od, e) ->
+      sub.open_description sub od;
+      sub.class_type sub e
+
+let class_signature sub {csig_self; csig_fields; _} =
+  sub.typ sub csig_self;
+  List.iter (sub.class_type_field sub) csig_fields
+
+let class_type_field sub {ctf_desc; _} =
+  match ctf_desc with
+  | Tctf_inherit ct -> sub.class_type sub ct
+  | Tctf_val (_, _, _, ct) ->  sub.typ sub ct
+  | Tctf_method (_, _, _, ct) -> sub.typ sub ct
+  | Tctf_constraint  (ct1, ct2) ->
+      sub.typ sub ct1;
+      sub.typ sub ct2
+  | Tctf_attribute _ -> ()
+
+let typ sub {ctyp_desc; ctyp_env; _} =
+  sub.env sub ctyp_env;
+  match ctyp_desc with
+  | Ttyp_any   -> ()
+  | Ttyp_var _ -> ()
+  | Ttyp_arrow (_, ct1, ct2) ->
+      sub.typ sub ct1;
+      sub.typ sub ct2
+  | Ttyp_tuple list -> List.iter (sub.typ sub) list
+  | Ttyp_constr (_, _, list) ->  List.iter (sub.typ sub) list
+  | Ttyp_object (list, _) -> List.iter (sub.object_field sub) list
+  | Ttyp_class (_, _, list) -> List.iter (sub.typ sub) list
+  | Ttyp_alias (ct, _) -> sub.typ sub ct
+  | Ttyp_variant (list, _, _) -> List.iter (sub.row_field sub) list
+  | Ttyp_poly (_, ct) -> sub.typ sub ct
+  | Ttyp_package pack -> sub.package_type sub pack
+
+let class_structure sub {cstr_self; cstr_fields; _} =
+  sub.pat sub cstr_self;
+  List.iter (sub.class_field sub) cstr_fields
+
+let row_field sub {rf_desc; _} =
+  match rf_desc with
+  | Ttag (_, _, list) -> List.iter (sub.typ sub) list
+  | Tinherit ct -> sub.typ sub ct
+
+let object_field sub {of_desc; _} =
+  match of_desc with
+  | OTtag (_, ct) -> sub.typ sub ct
+  | OTinherit ct -> sub.typ sub ct
+
+let class_field_kind sub = function
+  | Tcfk_virtual ct -> sub.typ sub ct
+  | Tcfk_concrete (_, e) -> sub.expr sub e
+
+let class_field sub {cf_desc; _} = match cf_desc with
+  | Tcf_inherit (_, cl, _, _, _) -> sub.class_expr sub cl
+  | Tcf_constraint (cty1, cty2) ->
+      sub.typ sub cty1;
+      sub.typ sub cty2
+  | Tcf_val (_, _, _, k, _) -> class_field_kind sub k
+  | Tcf_method (_, _, k) -> class_field_kind sub k
+  | Tcf_initializer exp -> sub.expr sub exp
+  | Tcf_attribute _ -> ()
+
+let value_bindings sub (_, list) = List.iter (sub.value_binding sub) list
+
+let case sub {c_lhs; c_guard; c_rhs} =
+  sub.pat sub c_lhs;
+  Option.iter (sub.expr sub) c_guard;
+  sub.expr sub c_rhs
+
+let value_binding sub {vb_pat; vb_expr; _} =
+  sub.pat sub vb_pat;
+  sub.expr sub vb_expr
+
+let env _sub _ = ()
+
+let default_iterator =
+  {
+    binding_op;
+    case;
+    class_declaration;
+    class_description;
+    class_expr;
+    class_field;
+    class_signature;
+    class_structure;
+    class_type;
+    class_type_declaration;
+    class_type_field;
+    env;
+    expr;
+    extension_constructor;
+    module_binding;
+    module_coercion;
+    module_declaration;
+    module_substitution;
+    module_expr;
+    module_type;
+    module_type_declaration;
+    package_type;
+    pat;
+    row_field;
+    object_field;
+    open_declaration;
+    open_description;
+    signature;
+    signature_item;
+    structure;
+    structure_item;
+    typ;
+    type_declaration;
+    type_declarations;
+    type_extension;
+    type_exception;
+    type_kind;
+    value_binding;
+    value_bindings;
+    value_description;
+    with_constraint;
+  }
diff --git a/upstream/ocaml_413/typing/tast_iterator.mli b/upstream/ocaml_413/typing/tast_iterator.mli
new file mode 100644
index 0000000..e126128
--- /dev/null
+++ b/upstream/ocaml_413/typing/tast_iterator.mli
@@ -0,0 +1,68 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                           Isaac "Izzy" Avram                           *)
+(*                                                                        *)
+(*   Copyright 2019 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(**
+Allows the implementation of typed tree inspection using open recursion
+*)
+
+open Asttypes
+open Typedtree
+
+type iterator =
+  {
+    binding_op: iterator -> binding_op -> unit;
+    case: 'k . iterator -> 'k case -> unit;
+    class_declaration: iterator -> class_declaration -> unit;
+    class_description: iterator -> class_description -> unit;
+    class_expr: iterator -> class_expr -> unit;
+    class_field: iterator -> class_field -> unit;
+    class_signature: iterator -> class_signature -> unit;
+    class_structure: iterator -> class_structure -> unit;
+    class_type: iterator -> class_type -> unit;
+    class_type_declaration: iterator -> class_type_declaration -> unit;
+    class_type_field: iterator -> class_type_field -> unit;
+    env: iterator -> Env.t -> unit;
+    expr: iterator -> expression -> unit;
+    extension_constructor: iterator -> extension_constructor -> unit;
+    module_binding: iterator -> module_binding -> unit;
+    module_coercion: iterator -> module_coercion -> unit;
+    module_declaration: iterator -> module_declaration -> unit;
+    module_substitution: iterator -> module_substitution -> unit;
+    module_expr: iterator -> module_expr -> unit;
+    module_type: iterator -> module_type -> unit;
+    module_type_declaration: iterator -> module_type_declaration -> unit;
+    package_type: iterator -> package_type -> unit;
+    pat: 'k . iterator -> 'k general_pattern -> unit;
+    row_field: iterator -> row_field -> unit;
+    object_field: iterator -> object_field -> unit;
+    open_declaration: iterator -> open_declaration -> unit;
+    open_description: iterator -> open_description -> unit;
+    signature: iterator -> signature -> unit;
+    signature_item: iterator -> signature_item -> unit;
+    structure: iterator -> structure -> unit;
+    structure_item: iterator -> structure_item -> unit;
+    typ: iterator -> core_type -> unit;
+    type_declaration: iterator -> type_declaration -> unit;
+    type_declarations: iterator -> (rec_flag * type_declaration list) -> unit;
+    type_extension: iterator -> type_extension -> unit;
+    type_exception: iterator -> type_exception -> unit;
+    type_kind: iterator -> type_kind -> unit;
+    value_binding: iterator -> value_binding -> unit;
+    value_bindings: iterator -> (rec_flag * value_binding list) -> unit;
+    value_description: iterator -> value_description -> unit;
+    with_constraint: iterator -> with_constraint -> unit;
+  }
+
+val default_iterator: iterator
diff --git a/upstream/ocaml_413/typing/tast_mapper.ml b/upstream/ocaml_413/typing/tast_mapper.ml
new file mode 100644
index 0000000..4bb43a8
--- /dev/null
+++ b/upstream/ocaml_413/typing/tast_mapper.ml
@@ -0,0 +1,749 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                        Alain Frisch, LexiFi                            *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Typedtree
+
+(* TODO: add 'methods' for location, attribute, extension,
+   include_declaration, include_description *)
+
+type mapper =
+  {
+    binding_op: mapper -> binding_op -> binding_op;
+    case: 'k . mapper -> 'k case -> 'k case;
+    class_declaration: mapper -> class_declaration -> class_declaration;
+    class_description: mapper -> class_description -> class_description;
+    class_expr: mapper -> class_expr -> class_expr;
+    class_field: mapper -> class_field -> class_field;
+    class_signature: mapper -> class_signature -> class_signature;
+    class_structure: mapper -> class_structure -> class_structure;
+    class_type: mapper -> class_type -> class_type;
+    class_type_declaration: mapper -> class_type_declaration ->
+      class_type_declaration;
+    class_type_field: mapper -> class_type_field -> class_type_field;
+    env: mapper -> Env.t -> Env.t;
+    expr: mapper -> expression -> expression;
+    extension_constructor: mapper -> extension_constructor ->
+      extension_constructor;
+    module_binding: mapper -> module_binding -> module_binding;
+    module_coercion: mapper -> module_coercion -> module_coercion;
+    module_declaration: mapper -> module_declaration -> module_declaration;
+    module_substitution: mapper -> module_substitution -> module_substitution;
+    module_expr: mapper -> module_expr -> module_expr;
+    module_type: mapper -> module_type -> module_type;
+    module_type_declaration:
+      mapper -> module_type_declaration -> module_type_declaration;
+    package_type: mapper -> package_type -> package_type;
+    pat: 'k . mapper -> 'k general_pattern -> 'k general_pattern;
+    row_field: mapper -> row_field -> row_field;
+    object_field: mapper -> object_field -> object_field;
+    open_declaration: mapper -> open_declaration -> open_declaration;
+    open_description: mapper -> open_description -> open_description;
+    signature: mapper -> signature -> signature;
+    signature_item: mapper -> signature_item -> signature_item;
+    structure: mapper -> structure -> structure;
+    structure_item: mapper -> structure_item -> structure_item;
+    typ: mapper -> core_type -> core_type;
+    type_declaration: mapper -> type_declaration -> type_declaration;
+    type_declarations: mapper -> (rec_flag * type_declaration list)
+      -> (rec_flag * type_declaration list);
+    type_extension: mapper -> type_extension -> type_extension;
+    type_exception: mapper -> type_exception -> type_exception;
+    type_kind: mapper -> type_kind -> type_kind;
+    value_binding: mapper -> value_binding -> value_binding;
+    value_bindings: mapper -> (rec_flag * value_binding list) ->
+      (rec_flag * value_binding list);
+    value_description: mapper -> value_description -> value_description;
+    with_constraint: mapper -> with_constraint -> with_constraint;
+  }
+
+let id x = x
+let tuple2 f1 f2 (x, y) = (f1 x, f2 y)
+let tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
+
+let structure sub {str_items; str_type; str_final_env} =
+  {
+    str_items = List.map (sub.structure_item sub) str_items;
+    str_final_env = sub.env sub str_final_env;
+    str_type;
+  }
+
+let class_infos sub f x =
+  {x with
+   ci_params = List.map (tuple2 (sub.typ sub) id) x.ci_params;
+   ci_expr = f x.ci_expr;
+  }
+
+let module_type_declaration sub x =
+  let mtd_type = Option.map (sub.module_type sub) x.mtd_type in
+  {x with mtd_type}
+
+let module_declaration sub x =
+  let md_type = sub.module_type sub x.md_type in
+  {x with md_type}
+
+let module_substitution _ x = x
+
+let include_infos f x = {x with incl_mod = f x.incl_mod}
+
+let class_type_declaration sub x =
+  class_infos sub (sub.class_type sub) x
+
+let class_declaration sub x =
+  class_infos sub (sub.class_expr sub) x
+
+let structure_item sub {str_desc; str_loc; str_env} =
+  let str_env = sub.env sub str_env in
+  let str_desc =
+    match str_desc with
+    | Tstr_eval (exp, attrs) -> Tstr_eval (sub.expr sub exp, attrs)
+    | Tstr_value (rec_flag, list) ->
+        let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in
+        Tstr_value (rec_flag, list)
+    | Tstr_primitive v -> Tstr_primitive (sub.value_description sub v)
+    | Tstr_type (rec_flag, list) ->
+        let (rec_flag, list) = sub.type_declarations sub (rec_flag, list) in
+        Tstr_type (rec_flag, list)
+    | Tstr_typext te -> Tstr_typext (sub.type_extension sub te)
+    | Tstr_exception ext -> Tstr_exception (sub.type_exception sub ext)
+    | Tstr_module mb -> Tstr_module (sub.module_binding sub mb)
+    | Tstr_recmodule list ->
+        Tstr_recmodule (List.map (sub.module_binding sub) list)
+    | Tstr_modtype x -> Tstr_modtype (sub.module_type_declaration sub x)
+    | Tstr_class list ->
+        Tstr_class
+          (List.map (tuple2 (sub.class_declaration sub) id) list)
+    | Tstr_class_type list ->
+        Tstr_class_type
+          (List.map (tuple3 id id (sub.class_type_declaration sub)) list)
+    | Tstr_include incl ->
+        Tstr_include (include_infos (sub.module_expr sub) incl)
+    | Tstr_open od -> Tstr_open (sub.open_declaration sub od)
+    | Tstr_attribute _ as d -> d
+  in
+  {str_desc; str_env; str_loc}
+
+let value_description sub x =
+  let val_desc = sub.typ sub x.val_desc in
+  {x with val_desc}
+
+let label_decl sub x =
+  let ld_type = sub.typ sub x.ld_type in
+  {x with ld_type}
+
+let constructor_args sub = function
+  | Cstr_tuple l -> Cstr_tuple (List.map (sub.typ sub) l)
+  | Cstr_record l -> Cstr_record (List.map (label_decl sub) l)
+
+let constructor_decl sub cd =
+  let cd_args = constructor_args sub cd.cd_args in
+  let cd_res = Option.map (sub.typ sub) cd.cd_res in
+  {cd with cd_args; cd_res}
+
+let type_kind sub = function
+  | Ttype_abstract -> Ttype_abstract
+  | Ttype_variant list -> Ttype_variant (List.map (constructor_decl sub) list)
+  | Ttype_record list -> Ttype_record (List.map (label_decl sub) list)
+  | Ttype_open -> Ttype_open
+
+let type_declaration sub x =
+  let typ_cstrs =
+    List.map
+      (tuple3 (sub.typ sub) (sub.typ sub) id)
+      x.typ_cstrs
+  in
+  let typ_kind = sub.type_kind sub x.typ_kind in
+  let typ_manifest = Option.map (sub.typ sub) x.typ_manifest in
+  let typ_params = List.map (tuple2 (sub.typ sub) id) x.typ_params in
+  {x with typ_cstrs; typ_kind; typ_manifest; typ_params}
+
+let type_declarations sub (rec_flag, list) =
+  (rec_flag, List.map (sub.type_declaration sub) list)
+
+let type_extension sub x =
+  let tyext_params = List.map (tuple2 (sub.typ sub) id) x.tyext_params in
+  let tyext_constructors =
+    List.map (sub.extension_constructor sub) x.tyext_constructors
+  in
+  {x with tyext_constructors; tyext_params}
+
+let type_exception sub x =
+  let tyexn_constructor =
+    sub.extension_constructor sub x.tyexn_constructor
+  in
+  {x with tyexn_constructor}
+
+let extension_constructor sub x =
+  let ext_kind =
+    match x.ext_kind with
+      Text_decl(ctl, cto) ->
+        Text_decl(constructor_args sub ctl, Option.map (sub.typ sub) cto)
+    | Text_rebind _ as d -> d
+  in
+  {x with ext_kind}
+
+let pat_extra sub = function
+  | Tpat_type _
+  | Tpat_unpack as d -> d
+  | Tpat_open (path,loc,env) ->  Tpat_open (path, loc, sub.env sub env)
+  | Tpat_constraint ct -> Tpat_constraint (sub.typ sub ct)
+
+let pat
+  : type k . mapper -> k general_pattern -> k general_pattern
+  = fun sub x ->
+  let pat_env = sub.env sub x.pat_env in
+  let pat_extra = List.map (tuple3 (pat_extra sub) id id) x.pat_extra in
+  let pat_desc : k pattern_desc =
+    match x.pat_desc with
+    | Tpat_any
+    | Tpat_var _
+    | Tpat_constant _ -> x.pat_desc
+    | Tpat_tuple l -> Tpat_tuple (List.map (sub.pat sub) l)
+    | Tpat_construct (loc, cd, l, vto) ->
+        let vto = Option.map (fun (vl,cty) -> vl, sub.typ sub cty) vto in
+        Tpat_construct (loc, cd, List.map (sub.pat sub) l, vto)
+    | Tpat_variant (l, po, rd) ->
+        Tpat_variant (l, Option.map (sub.pat sub) po, rd)
+    | Tpat_record (l, closed) ->
+        Tpat_record (List.map (tuple3 id id (sub.pat sub)) l, closed)
+    | Tpat_array l -> Tpat_array (List.map (sub.pat sub) l)
+    | Tpat_alias (p, id, s) -> Tpat_alias (sub.pat sub p, id, s)
+    | Tpat_lazy p -> Tpat_lazy (sub.pat sub p)
+    | Tpat_value p ->
+       (as_computation_pattern (sub.pat sub (p :> pattern))).pat_desc
+    | Tpat_exception p ->
+       Tpat_exception (sub.pat sub p)
+    | Tpat_or (p1, p2, rd) ->
+        Tpat_or (sub.pat sub p1, sub.pat sub p2, rd)
+  in
+  {x with pat_extra; pat_desc; pat_env}
+
+let expr sub x =
+  let extra = function
+    | Texp_constraint cty ->
+        Texp_constraint (sub.typ sub cty)
+    | Texp_coerce (cty1, cty2) ->
+        Texp_coerce (Option.map (sub.typ sub) cty1, sub.typ sub cty2)
+    | Texp_newtype _ as d -> d
+    | Texp_poly cto -> Texp_poly (Option.map (sub.typ sub) cto)
+  in
+  let exp_extra = List.map (tuple3 extra id id) x.exp_extra in
+  let exp_env = sub.env sub x.exp_env in
+  let exp_desc =
+    match x.exp_desc with
+    | Texp_ident _
+    | Texp_constant _ as d -> d
+    | Texp_let (rec_flag, list, exp) ->
+        let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in
+        Texp_let (rec_flag, list, sub.expr sub exp)
+    | Texp_function { arg_label; param; cases; partial; } ->
+        let cases = List.map (sub.case sub) cases in
+        Texp_function { arg_label; param; cases; partial; }
+    | Texp_apply (exp, list) ->
+        Texp_apply (
+          sub.expr sub exp,
+          List.map (tuple2 id (Option.map (sub.expr sub))) list
+        )
+    | Texp_match (exp, cases, p) ->
+        Texp_match (
+          sub.expr sub exp,
+          List.map (sub.case sub) cases,
+          p
+        )
+    | Texp_try (exp, cases) ->
+        Texp_try (
+          sub.expr sub exp,
+          List.map (sub.case sub) cases
+        )
+    | Texp_tuple list ->
+        Texp_tuple (List.map (sub.expr sub) list)
+    | Texp_construct (lid, cd, args) ->
+        Texp_construct (lid, cd, List.map (sub.expr sub) args)
+    | Texp_variant (l, expo) ->
+        Texp_variant (l, Option.map (sub.expr sub) expo)
+    | Texp_record { fields; representation; extended_expression } ->
+        let fields = Array.map (function
+            | label, Kept t -> label, Kept t
+            | label, Overridden (lid, exp) ->
+                label, Overridden (lid, sub.expr sub exp))
+            fields
+        in
+        Texp_record {
+          fields; representation;
+          extended_expression = Option.map (sub.expr sub) extended_expression;
+        }
+    | Texp_field (exp, lid, ld) ->
+        Texp_field (sub.expr sub exp, lid, ld)
+    | Texp_setfield (exp1, lid, ld, exp2) ->
+        Texp_setfield (
+          sub.expr sub exp1,
+          lid,
+          ld,
+          sub.expr sub exp2
+        )
+    | Texp_array list ->
+        Texp_array (List.map (sub.expr sub) list)
+    | Texp_ifthenelse (exp1, exp2, expo) ->
+        Texp_ifthenelse (
+          sub.expr sub exp1,
+          sub.expr sub exp2,
+          Option.map (sub.expr sub) expo
+        )
+    | Texp_sequence (exp1, exp2) ->
+        Texp_sequence (
+          sub.expr sub exp1,
+          sub.expr sub exp2
+        )
+    | Texp_while (exp1, exp2) ->
+        Texp_while (
+          sub.expr sub exp1,
+          sub.expr sub exp2
+        )
+    | Texp_for (id, p, exp1, exp2, dir, exp3) ->
+        Texp_for (
+          id,
+          p,
+          sub.expr sub exp1,
+          sub.expr sub exp2,
+          dir,
+          sub.expr sub exp3
+        )
+    | Texp_send (exp, meth, expo) ->
+        Texp_send
+          (
+            sub.expr sub exp,
+            meth,
+            Option.map (sub.expr sub) expo
+          )
+    | Texp_new _
+    | Texp_instvar _ as d -> d
+    | Texp_setinstvar (path1, path2, id, exp) ->
+        Texp_setinstvar (
+          path1,
+          path2,
+          id,
+          sub.expr sub exp
+        )
+    | Texp_override (path, list) ->
+        Texp_override (
+          path,
+          List.map (tuple3 id id (sub.expr sub)) list
+        )
+    | Texp_letmodule (id, s, pres, mexpr, exp) ->
+        Texp_letmodule (
+          id,
+          s,
+          pres,
+          sub.module_expr sub mexpr,
+          sub.expr sub exp
+        )
+    | Texp_letexception (cd, exp) ->
+        Texp_letexception (
+          sub.extension_constructor sub cd,
+          sub.expr sub exp
+        )
+    | Texp_assert exp ->
+        Texp_assert (sub.expr sub exp)
+    | Texp_lazy exp ->
+        Texp_lazy (sub.expr sub exp)
+    | Texp_object (cl, sl) ->
+        Texp_object (sub.class_structure sub cl, sl)
+    | Texp_pack mexpr ->
+        Texp_pack (sub.module_expr sub mexpr)
+    | Texp_letop {let_; ands; param; body; partial} ->
+        Texp_letop{
+          let_ = sub.binding_op sub let_;
+          ands = List.map (sub.binding_op sub) ands;
+          param;
+          body = sub.case sub body;
+          partial;
+        }
+    | Texp_unreachable ->
+        Texp_unreachable
+    | Texp_extension_constructor _ as e ->
+        e
+    | Texp_open (od, e) ->
+        Texp_open (sub.open_declaration sub od, sub.expr sub e)
+  in
+  {x with exp_extra; exp_desc; exp_env}
+
+
+let package_type sub x =
+  let pack_fields = List.map (tuple2 id (sub.typ sub)) x.pack_fields in
+  {x with pack_fields}
+
+let binding_op sub x =
+  { x with bop_exp = sub.expr sub x.bop_exp }
+
+let signature sub x =
+  let sig_final_env = sub.env sub x.sig_final_env in
+  let sig_items = List.map (sub.signature_item sub) x.sig_items in
+  {x with sig_items; sig_final_env}
+
+let signature_item sub x =
+  let sig_env = sub.env sub x.sig_env in
+  let sig_desc =
+    match x.sig_desc with
+    | Tsig_value v ->
+        Tsig_value (sub.value_description sub v)
+    | Tsig_type (rec_flag, list) ->
+        let (rec_flag, list) = sub.type_declarations sub (rec_flag, list) in
+        Tsig_type (rec_flag, list)
+    | Tsig_typesubst list ->
+        let (_, list) = sub.type_declarations sub (Nonrecursive, list) in
+        Tsig_typesubst list
+    | Tsig_typext te ->
+        Tsig_typext (sub.type_extension sub te)
+    | Tsig_exception ext ->
+        Tsig_exception (sub.type_exception sub ext)
+    | Tsig_module x ->
+        Tsig_module (sub.module_declaration sub x)
+    | Tsig_modsubst x ->
+        Tsig_modsubst (sub.module_substitution sub x)
+    | Tsig_recmodule list ->
+        Tsig_recmodule (List.map (sub.module_declaration sub) list)
+    | Tsig_modtype x ->
+        Tsig_modtype (sub.module_type_declaration sub x)
+   | Tsig_modtypesubst x ->
+        Tsig_modtypesubst (sub.module_type_declaration sub x)
+   | Tsig_include incl ->
+        Tsig_include (include_infos (sub.module_type sub) incl)
+    | Tsig_class list ->
+        Tsig_class (List.map (sub.class_description sub) list)
+    | Tsig_class_type list ->
+        Tsig_class_type
+          (List.map (sub.class_type_declaration sub) list)
+    | Tsig_open od -> Tsig_open (sub.open_description sub od)
+    | Tsig_attribute _ as d -> d
+  in
+  {x with sig_desc; sig_env}
+
+let class_description sub x =
+  class_infos sub (sub.class_type sub) x
+
+let functor_parameter sub = function
+  | Unit -> Unit
+  | Named (id, s, mtype) -> Named (id, s, sub.module_type sub mtype)
+
+let module_type sub x =
+  let mty_env = sub.env sub x.mty_env in
+  let mty_desc =
+    match x.mty_desc with
+    | Tmty_ident _
+    | Tmty_alias _ as d -> d
+    | Tmty_signature sg -> Tmty_signature (sub.signature sub sg)
+    | Tmty_functor (arg, mtype2) ->
+        Tmty_functor (functor_parameter sub arg, sub.module_type sub mtype2)
+    | Tmty_with (mtype, list) ->
+        Tmty_with (
+          sub.module_type sub mtype,
+          List.map (tuple3 id id (sub.with_constraint sub)) list
+        )
+    | Tmty_typeof mexpr ->
+        Tmty_typeof (sub.module_expr sub mexpr)
+  in
+  {x with mty_desc; mty_env}
+
+let with_constraint sub = function
+  | Twith_type decl -> Twith_type (sub.type_declaration sub decl)
+  | Twith_typesubst decl -> Twith_typesubst (sub.type_declaration sub decl)
+  | Twith_module _
+  | Twith_modsubst _
+  | Twith_modtype _
+  | Twith_modtypesubst _ as d -> d
+
+let open_description sub od =
+  {od with open_env = sub.env sub od.open_env}
+
+let open_declaration sub od =
+  {od with open_expr = sub.module_expr sub od.open_expr;
+           open_env = sub.env sub od.open_env}
+
+let module_coercion sub = function
+  | Tcoerce_none -> Tcoerce_none
+  | Tcoerce_functor (c1,c2) ->
+      Tcoerce_functor (sub.module_coercion sub c1, sub.module_coercion sub c2)
+  | Tcoerce_alias (env, p, c1) ->
+      Tcoerce_alias (sub.env sub env, p, sub.module_coercion sub c1)
+  | Tcoerce_structure (l1, l2) ->
+      let l1' = List.map (fun (i,c) -> i, sub.module_coercion sub c) l1 in
+      let l2' =
+        List.map (fun (id,i,c) -> id, i, sub.module_coercion sub c) l2
+      in
+      Tcoerce_structure (l1', l2')
+  | Tcoerce_primitive pc ->
+      Tcoerce_primitive {pc with pc_env = sub.env sub pc.pc_env}
+
+let module_expr sub x =
+  let mod_env = sub.env sub x.mod_env in
+  let mod_desc =
+    match x.mod_desc with
+    | Tmod_ident _ as d -> d
+    | Tmod_structure st -> Tmod_structure (sub.structure sub st)
+    | Tmod_functor (arg, mexpr) ->
+        Tmod_functor (functor_parameter sub arg, sub.module_expr sub mexpr)
+    | Tmod_apply (mexp1, mexp2, c) ->
+        Tmod_apply (
+          sub.module_expr sub mexp1,
+          sub.module_expr sub mexp2,
+          sub.module_coercion sub c
+        )
+    | Tmod_constraint (mexpr, mt, Tmodtype_implicit, c) ->
+        Tmod_constraint (sub.module_expr sub mexpr, mt, Tmodtype_implicit,
+                         sub.module_coercion sub c)
+    | Tmod_constraint (mexpr, mt, Tmodtype_explicit mtype, c) ->
+        Tmod_constraint (
+          sub.module_expr sub mexpr,
+          mt,
+          Tmodtype_explicit (sub.module_type sub mtype),
+          sub.module_coercion sub c
+        )
+    | Tmod_unpack (exp, mty) ->
+        Tmod_unpack
+          (
+            sub.expr sub exp,
+            mty
+          )
+  in
+  {x with mod_desc; mod_env}
+
+let module_binding sub x =
+  let mb_expr = sub.module_expr sub x.mb_expr in
+  {x with mb_expr}
+
+let class_expr sub x =
+  let cl_env = sub.env sub x.cl_env in
+  let cl_desc =
+    match x.cl_desc with
+    | Tcl_constraint (cl, clty, vals, meths, concrs) ->
+        Tcl_constraint (
+          sub.class_expr sub cl,
+          Option.map (sub.class_type sub) clty,
+          vals,
+          meths,
+          concrs
+        )
+    | Tcl_structure clstr ->
+        Tcl_structure (sub.class_structure sub clstr)
+    | Tcl_fun (label, pat, priv, cl, partial) ->
+        Tcl_fun (
+          label,
+          sub.pat sub pat,
+          List.map (tuple2 id (sub.expr sub)) priv,
+          sub.class_expr sub cl,
+          partial
+        )
+    | Tcl_apply (cl, args) ->
+        Tcl_apply (
+          sub.class_expr sub cl,
+          List.map (tuple2 id (Option.map (sub.expr sub))) args
+        )
+    | Tcl_let (rec_flag, value_bindings, ivars, cl) ->
+        let (rec_flag, value_bindings) =
+          sub.value_bindings sub (rec_flag, value_bindings)
+        in
+        Tcl_let (
+          rec_flag,
+          value_bindings,
+          List.map (tuple2 id (sub.expr sub)) ivars,
+          sub.class_expr sub cl
+        )
+    | Tcl_ident (path, lid, tyl) ->
+        Tcl_ident (path, lid, List.map (sub.typ sub) tyl)
+    | Tcl_open (od, e) ->
+        Tcl_open (sub.open_description sub od, sub.class_expr sub e)
+  in
+  {x with cl_desc; cl_env}
+
+let class_type sub x =
+  let cltyp_env = sub.env sub x.cltyp_env in
+  let cltyp_desc =
+    match x.cltyp_desc with
+    | Tcty_signature csg -> Tcty_signature (sub.class_signature sub csg)
+    | Tcty_constr (path, lid, list) ->
+        Tcty_constr (
+          path,
+          lid,
+          List.map (sub.typ sub) list
+        )
+    | Tcty_arrow (label, ct, cl) ->
+        Tcty_arrow
+          (label,
+           sub.typ sub ct,
+           sub.class_type sub cl
+          )
+    | Tcty_open (od, e) ->
+        Tcty_open (sub.open_description sub od, sub.class_type sub e)
+  in
+  {x with cltyp_desc; cltyp_env}
+
+let class_signature sub x =
+  let csig_self = sub.typ sub x.csig_self in
+  let csig_fields = List.map (sub.class_type_field sub) x.csig_fields in
+  {x with csig_self; csig_fields}
+
+let class_type_field sub x =
+  let ctf_desc =
+    match x.ctf_desc with
+    | Tctf_inherit ct ->
+        Tctf_inherit (sub.class_type sub ct)
+    | Tctf_val (s, mut, virt, ct) ->
+        Tctf_val (s, mut, virt, sub.typ sub ct)
+    | Tctf_method (s, priv, virt, ct) ->
+        Tctf_method (s, priv, virt, sub.typ sub ct)
+    | Tctf_constraint  (ct1, ct2) ->
+        Tctf_constraint (sub.typ sub ct1, sub.typ sub ct2)
+    | Tctf_attribute _ as d -> d
+  in
+  {x with ctf_desc}
+
+let typ sub x =
+  let ctyp_env = sub.env sub x.ctyp_env in
+  let ctyp_desc =
+    match x.ctyp_desc with
+    | Ttyp_any
+    | Ttyp_var _ as d -> d
+    | Ttyp_arrow (label, ct1, ct2) ->
+        Ttyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2)
+    | Ttyp_tuple list -> Ttyp_tuple (List.map (sub.typ sub) list)
+    | Ttyp_constr (path, lid, list) ->
+        Ttyp_constr (path, lid, List.map (sub.typ sub) list)
+    | Ttyp_object (list, closed) ->
+        Ttyp_object ((List.map (sub.object_field sub) list), closed)
+    | Ttyp_class (path, lid, list) ->
+        Ttyp_class
+          (path,
+           lid,
+           List.map (sub.typ sub) list
+          )
+    | Ttyp_alias (ct, s) ->
+        Ttyp_alias (sub.typ sub ct, s)
+    | Ttyp_variant (list, closed, labels) ->
+        Ttyp_variant (List.map (sub.row_field sub) list, closed, labels)
+    | Ttyp_poly (sl, ct) ->
+        Ttyp_poly (sl, sub.typ sub ct)
+    | Ttyp_package pack ->
+        Ttyp_package (sub.package_type sub pack)
+  in
+  {x with ctyp_desc; ctyp_env}
+
+let class_structure sub x =
+  let cstr_self = sub.pat sub x.cstr_self in
+  let cstr_fields = List.map (sub.class_field sub) x.cstr_fields in
+  {x with cstr_self; cstr_fields}
+
+let row_field sub x =
+  let rf_desc = match x.rf_desc with
+    | Ttag (label, b, list) ->
+        Ttag (label, b, List.map (sub.typ sub) list)
+    | Tinherit ct -> Tinherit (sub.typ sub ct)
+  in
+  { x with rf_desc; }
+
+let object_field sub x =
+  let of_desc = match x.of_desc with
+    | OTtag (label, ct) ->
+        OTtag (label, (sub.typ sub ct))
+    | OTinherit ct -> OTinherit (sub.typ sub ct)
+  in
+  { x with of_desc; }
+
+let class_field_kind sub = function
+  | Tcfk_virtual ct -> Tcfk_virtual (sub.typ sub ct)
+  | Tcfk_concrete (ovf, e) -> Tcfk_concrete (ovf, sub.expr sub e)
+
+let class_field sub x =
+  let cf_desc =
+    match x.cf_desc with
+    | Tcf_inherit (ovf, cl, super, vals, meths) ->
+        Tcf_inherit (ovf, sub.class_expr sub cl, super, vals, meths)
+    | Tcf_constraint (cty, cty') ->
+        Tcf_constraint (
+          sub.typ sub cty,
+          sub.typ sub cty'
+        )
+    | Tcf_val (s, mf, id, k, b) ->
+        Tcf_val (s, mf, id, class_field_kind sub k, b)
+    | Tcf_method (s, priv, k) ->
+        Tcf_method (s, priv, class_field_kind sub k)
+    | Tcf_initializer exp ->
+        Tcf_initializer (sub.expr sub exp)
+    | Tcf_attribute _ as d -> d
+  in
+  {x with cf_desc}
+
+let value_bindings sub (rec_flag, list) =
+  (rec_flag, List.map (sub.value_binding sub) list)
+
+let case
+  : type k . mapper -> k case -> k case
+  = fun sub {c_lhs; c_guard; c_rhs} ->
+  {
+    c_lhs = sub.pat sub c_lhs;
+    c_guard = Option.map (sub.expr sub) c_guard;
+    c_rhs = sub.expr sub c_rhs;
+  }
+
+let value_binding sub x =
+  let vb_pat = sub.pat sub x.vb_pat in
+  let vb_expr = sub.expr sub x.vb_expr in
+  {x with vb_pat; vb_expr}
+
+let env _sub x = x
+
+let default =
+  {
+    binding_op;
+    case;
+    class_declaration;
+    class_description;
+    class_expr;
+    class_field;
+    class_signature;
+    class_structure;
+    class_type;
+    class_type_declaration;
+    class_type_field;
+    env;
+    expr;
+    extension_constructor;
+    module_binding;
+    module_coercion;
+    module_declaration;
+    module_substitution;
+    module_expr;
+    module_type;
+    module_type_declaration;
+    package_type;
+    pat;
+    row_field;
+    object_field;
+    open_declaration;
+    open_description;
+    signature;
+    signature_item;
+    structure;
+    structure_item;
+    typ;
+    type_declaration;
+    type_declarations;
+    type_extension;
+    type_exception;
+    type_kind;
+    value_binding;
+    value_bindings;
+    value_description;
+    with_constraint;
+  }
diff --git a/upstream/ocaml_413/typing/tast_mapper.mli b/upstream/ocaml_413/typing/tast_mapper.mli
new file mode 100644
index 0000000..ea6543d
--- /dev/null
+++ b/upstream/ocaml_413/typing/tast_mapper.mli
@@ -0,0 +1,72 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                        Alain Frisch, LexiFi                            *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Typedtree
+
+(** {1 A generic Typedtree mapper} *)
+
+type mapper =
+  {
+    binding_op: mapper -> binding_op -> binding_op;
+    case: 'k . mapper -> 'k case -> 'k case;
+    class_declaration: mapper -> class_declaration -> class_declaration;
+    class_description: mapper -> class_description -> class_description;
+    class_expr: mapper -> class_expr -> class_expr;
+    class_field: mapper -> class_field -> class_field;
+    class_signature: mapper -> class_signature -> class_signature;
+    class_structure: mapper -> class_structure -> class_structure;
+    class_type: mapper -> class_type -> class_type;
+    class_type_declaration: mapper -> class_type_declaration ->
+      class_type_declaration;
+    class_type_field: mapper -> class_type_field -> class_type_field;
+    env: mapper -> Env.t -> Env.t;
+    expr: mapper -> expression -> expression;
+    extension_constructor: mapper -> extension_constructor ->
+      extension_constructor;
+    module_binding: mapper -> module_binding -> module_binding;
+    module_coercion: mapper -> module_coercion -> module_coercion;
+    module_declaration: mapper -> module_declaration -> module_declaration;
+    module_substitution: mapper -> module_substitution -> module_substitution;
+    module_expr: mapper -> module_expr -> module_expr;
+    module_type: mapper -> module_type -> module_type;
+    module_type_declaration:
+      mapper -> module_type_declaration -> module_type_declaration;
+    package_type: mapper -> package_type -> package_type;
+    pat: 'k . mapper -> 'k general_pattern -> 'k general_pattern;
+    row_field: mapper -> row_field -> row_field;
+    object_field: mapper -> object_field -> object_field;
+    open_declaration: mapper -> open_declaration -> open_declaration;
+    open_description: mapper -> open_description -> open_description;
+    signature: mapper -> signature -> signature;
+    signature_item: mapper -> signature_item -> signature_item;
+    structure: mapper -> structure -> structure;
+    structure_item: mapper -> structure_item -> structure_item;
+    typ: mapper -> core_type -> core_type;
+    type_declaration: mapper -> type_declaration -> type_declaration;
+    type_declarations: mapper -> (rec_flag * type_declaration list)
+      -> (rec_flag * type_declaration list);
+    type_extension: mapper -> type_extension -> type_extension;
+    type_exception: mapper -> type_exception -> type_exception;
+    type_kind: mapper -> type_kind -> type_kind;
+    value_binding: mapper -> value_binding -> value_binding;
+    value_bindings: mapper -> (rec_flag * value_binding list) ->
+      (rec_flag * value_binding list);
+    value_description: mapper -> value_description -> value_description;
+    with_constraint: mapper -> with_constraint -> with_constraint;
+  }
+
+
+val default: mapper
diff --git a/upstream/ocaml_413/typing/type_immediacy.ml b/upstream/ocaml_413/typing/type_immediacy.ml
new file mode 100644
index 0000000..557ed42
--- /dev/null
+++ b/upstream/ocaml_413/typing/type_immediacy.ml
@@ -0,0 +1,43 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2019 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t =
+  | Unknown
+  | Always
+  | Always_on_64bits
+
+module Violation = struct
+  type t =
+    | Not_always_immediate
+    | Not_always_immediate_on_64bits
+end
+
+let coerce t ~as_ =
+  match t, as_ with
+  | _, Unknown
+  | Always, Always
+  | (Always | Always_on_64bits), Always_on_64bits -> Ok ()
+  | (Unknown | Always_on_64bits), Always ->
+      Error Violation.Not_always_immediate
+  | Unknown, Always_on_64bits ->
+      Error Violation.Not_always_immediate_on_64bits
+
+let of_attributes attrs =
+  match
+    Builtin_attributes.immediate attrs,
+    Builtin_attributes.immediate64 attrs
+  with
+  | true, _ -> Always
+  | false, true -> Always_on_64bits
+  | false, false -> Unknown
diff --git a/upstream/ocaml_413/typing/type_immediacy.mli b/upstream/ocaml_413/typing/type_immediacy.mli
new file mode 100644
index 0000000..3fc2e3b
--- /dev/null
+++ b/upstream/ocaml_413/typing/type_immediacy.mli
@@ -0,0 +1,40 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2019 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Immediacy status of a type *)
+
+type t =
+  | Unknown
+  (** We don't know anything *)
+  | Always
+  (** We know for sure that values of this type are always immediate *)
+  | Always_on_64bits
+  (** We know for sure that values of this type are always immediate
+      on 64 bit platforms. For other platforms, we know nothing. *)
+
+module Violation : sig
+  type t =
+    | Not_always_immediate
+    | Not_always_immediate_on_64bits
+end
+
+(** [coerce t ~as_] returns [Ok ()] iff [t] can be seen as type
+    immediacy [as_]. For instance, [Always] can be seen as
+    [Always_on_64bits] but the opposite is not true. Return [Error _]
+    if the coercion is not possible. *)
+val coerce : t -> as_:t -> (unit, Violation.t) result
+
+(** Return the immediateness of a type as indicated by the user via
+    attributes *)
+val of_attributes : Parsetree.attributes -> t
diff --git a/upstream/ocaml_413/typing/typeclass.ml b/upstream/ocaml_413/typing/typeclass.ml
new file mode 100644
index 0000000..5907cbb
--- /dev/null
+++ b/upstream/ocaml_413/typing/typeclass.ml
@@ -0,0 +1,2063 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Parsetree
+open Asttypes
+open Path
+open Types
+open Typecore
+open Typetexp
+open Format
+
+type 'a class_info = {
+  cls_id : Ident.t;
+  cls_id_loc : string loc;
+  cls_decl : class_declaration;
+  cls_ty_id : Ident.t;
+  cls_ty_decl : class_type_declaration;
+  cls_obj_id : Ident.t;
+  cls_obj_abbr : type_declaration;
+  cls_typesharp_id : Ident.t;
+  cls_abbr : type_declaration;
+  cls_arity : int;
+  cls_pub_methods : string list;
+  cls_info : 'a;
+}
+
+type class_type_info = {
+  clsty_ty_id : Ident.t;
+  clsty_id_loc : string loc;
+  clsty_ty_decl : class_type_declaration;
+  clsty_obj_id : Ident.t;
+  clsty_obj_abbr : type_declaration;
+  clsty_typesharp_id : Ident.t;
+  clsty_abbr : type_declaration;
+  clsty_info : Typedtree.class_type_declaration;
+}
+
+type 'a full_class = {
+  id : Ident.t;
+  id_loc : tag loc;
+  clty: class_declaration;
+  ty_id: Ident.t;
+  cltydef: class_type_declaration;
+  obj_id: Ident.t;
+  obj_abbr: type_declaration;
+  cl_id: Ident.t;
+  cl_abbr: type_declaration;
+  arity: int;
+  pub_meths: string list;
+  coe: Warnings.loc list;
+  req: 'a Typedtree.class_infos;
+}
+
+type class_env = { val_env : Env.t; met_env : Env.t; par_env : Env.t }
+
+type error =
+  | Unconsistent_constraint of Errortrace.unification Errortrace.t
+  | Field_type_mismatch of string * string * Errortrace.unification Errortrace.t
+  | Structure_expected of class_type
+  | Cannot_apply of class_type
+  | Apply_wrong_label of arg_label
+  | Pattern_type_clash of type_expr
+  | Repeated_parameter
+  | Unbound_class_2 of Longident.t
+  | Unbound_class_type_2 of Longident.t
+  | Abbrev_type_clash of type_expr * type_expr * type_expr
+  | Constructor_type_mismatch of string * Errortrace.unification Errortrace.t
+  | Virtual_class of bool * bool * string list * string list
+  | Parameter_arity_mismatch of Longident.t * int * int
+  | Parameter_mismatch of Errortrace.unification Errortrace.t
+  | Bad_parameters of Ident.t * type_expr * type_expr
+  | Class_match_failure of Ctype.class_match_failure list
+  | Unbound_val of string
+  | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure
+  | Non_generalizable_class of Ident.t * Types.class_declaration
+  | Cannot_coerce_self of type_expr
+  | Non_collapsable_conjunction of
+      Ident.t * Types.class_declaration * Errortrace.unification Errortrace.t
+  | Final_self_clash of Errortrace.unification Errortrace.t
+  | Mutability_mismatch of string * mutable_flag
+  | No_overriding of string * string
+  | Duplicate of string * string
+  | Closing_self_type of type_expr
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+open Typedtree
+
+let type_open_descr :
+  (?used_slot:bool ref -> Env.t -> Parsetree.open_description
+   -> open_description * Env.t) ref =
+  ref (fun ?used_slot:_ _ -> assert false)
+
+let ctyp desc typ env loc =
+  { ctyp_desc = desc; ctyp_type = typ; ctyp_loc = loc; ctyp_env = env;
+    ctyp_attributes = [] }
+
+                       (**********************)
+                       (*  Useful constants  *)
+                       (**********************)
+
+
+(*
+   Self type have a dummy private method, thus preventing it to become
+   closed.
+*)
+let dummy_method = Btype.dummy_method
+
+(*
+   Path associated to the temporary class type of a class being typed
+   (its constructor is not available).
+*)
+let unbound_class =
+  Path.Pident (Ident.create_local "*undef*")
+
+
+                (************************************)
+                (*  Some operations on class types  *)
+                (************************************)
+
+
+(* Fully expand the head of a class type *)
+let rec scrape_class_type =
+  function
+    Cty_constr (_, _, cty) -> scrape_class_type cty
+  | cty                     -> cty
+
+(* Generalize a class type *)
+let rec generalize_class_type gen =
+  function
+    Cty_constr (_, params, cty) ->
+      List.iter gen params;
+      generalize_class_type gen cty
+  | Cty_signature {csig_self = sty; csig_vars = vars; csig_inher = inher} ->
+      gen sty;
+      Vars.iter (fun _ (_, _, ty) -> gen ty) vars;
+      List.iter (fun (_,tl) -> List.iter gen tl) inher
+  | Cty_arrow (_, ty, cty) ->
+      gen ty;
+      generalize_class_type gen cty
+
+let generalize_class_type vars =
+  let gen = if vars then Ctype.generalize else Ctype.generalize_structure in
+  generalize_class_type gen
+
+(* Return the virtual methods of a class type *)
+let virtual_methods sign =
+  let (fields, _) =
+    Ctype.flatten_fields (Ctype.object_fields sign.Types.csig_self)
+  in
+  List.fold_left
+    (fun virt (lab, _, _) ->
+       if lab = dummy_method then virt else
+       if Concr.mem lab sign.csig_concr then virt else
+       lab::virt)
+    [] fields
+
+(* Return the constructor type associated to a class type *)
+let rec constructor_type constr cty =
+  match cty with
+    Cty_constr (_, _, cty) ->
+      constructor_type constr cty
+  | Cty_signature _ ->
+      constr
+  | Cty_arrow (l, ty, cty) ->
+      Ctype.newty (Tarrow (l, ty, constructor_type constr cty, Cok))
+
+let rec class_body cty =
+  match cty with
+    Cty_constr _ ->
+      cty (* Only class bodies can be abbreviated *)
+  | Cty_signature _ ->
+      cty
+  | Cty_arrow (_, _, cty) ->
+      class_body cty
+
+let extract_constraints cty =
+  let sign = Ctype.signature_of_class_type cty in
+  (Vars.fold (fun lab _ vars -> lab :: vars) sign.csig_vars [],
+   begin let (fields, _) =
+     Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
+   in
+   List.fold_left
+     (fun meths (lab, _, _) ->
+        if lab = dummy_method then meths else lab::meths)
+     [] fields
+   end,
+   sign.csig_concr)
+
+let rec abbreviate_class_type path params cty =
+  match cty with
+    Cty_constr (_, _, _) | Cty_signature _ ->
+      Cty_constr (path, params, cty)
+  | Cty_arrow (l, ty, cty) ->
+      Cty_arrow (l, ty, abbreviate_class_type path params cty)
+
+(* Check that all type variables are generalizable *)
+(* Use Env.empty to prevent expansion of recursively defined object types;
+   cf. typing-poly/poly.ml *)
+let rec closed_class_type =
+  function
+    Cty_constr (_, params, _) ->
+      List.for_all (Ctype.closed_schema Env.empty) params
+  | Cty_signature sign ->
+      Ctype.closed_schema Env.empty sign.csig_self
+        &&
+      Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema Env.empty ty && cc)
+        sign.csig_vars
+        true
+  | Cty_arrow (_, ty, cty) ->
+      Ctype.closed_schema Env.empty ty
+        &&
+      closed_class_type cty
+
+let closed_class cty =
+  List.for_all (Ctype.closed_schema Env.empty) cty.cty_params
+    &&
+  closed_class_type cty.cty_type
+
+let rec limited_generalize rv =
+  function
+    Cty_constr (_path, params, cty) ->
+      List.iter (Ctype.limited_generalize rv) params;
+      limited_generalize rv cty
+  | Cty_signature sign ->
+      Ctype.limited_generalize rv sign.csig_self;
+      Vars.iter (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty)
+        sign.csig_vars;
+      List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl)
+        sign.csig_inher
+  | Cty_arrow (_, ty, cty) ->
+      Ctype.limited_generalize rv ty;
+      limited_generalize rv cty
+
+(* Record a class type *)
+let rc node =
+  Cmt_format.add_saved_type (Cmt_format.Partial_class_expr node);
+  node
+
+
+                (***********************************)
+                (*  Primitives for typing classes  *)
+                (***********************************)
+
+
+(* Enter a value in the method environment only *)
+let enter_met_env ?check loc lab kind unbound_kind ty class_env =
+  let {val_env; met_env; par_env} = class_env in
+  let val_env = Env.enter_unbound_value lab unbound_kind val_env in
+  let par_env = Env.enter_unbound_value lab unbound_kind par_env in
+  let (id, met_env) =
+    Env.enter_value ?check lab
+      {val_type = ty; val_kind = kind;
+       val_attributes = []; Types.val_loc = loc;
+       val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); } met_env
+  in
+  let class_env = {val_env; met_env; par_env} in
+  (id,class_env )
+
+(* Enter an instance variable in the environment *)
+let enter_val cl_num vars inh lab mut virt ty class_env loc =
+  let val_env = class_env.val_env in
+  let (id, virt) =
+    try
+      let (id, mut', virt', ty') = Vars.find lab !vars in
+      if mut' <> mut then
+        raise (Error(loc, val_env, Mutability_mismatch(lab, mut)));
+      Ctype.unify val_env (Ctype.instance ty) (Ctype.instance ty');
+      (if not inh then Some id else None),
+      (if virt' = Concrete then virt' else virt)
+    with
+      Ctype.Unify tr ->
+        raise (Error(loc, val_env,
+                     Field_type_mismatch("instance variable", lab, tr)))
+    | Not_found -> None, virt
+  in
+  let (id, _) as result =
+    match id with Some id -> (id, class_env)
+    | None ->
+        enter_met_env Location.none lab (Val_ivar (mut, cl_num))
+          Val_unbound_instance_variable ty class_env
+  in
+  vars := Vars.add lab (id, mut, virt, ty) !vars;
+  result
+
+let concr_vals vars =
+  Vars.fold
+    (fun id (_, vf, _) s -> if vf = Virtual then s else Concr.add id s)
+    vars Concr.empty
+
+let inheritance self_type env ovf concr_meths warn_vals loc parent =
+  match scrape_class_type parent with
+    Cty_signature cl_sig ->
+
+      (* Methods *)
+      begin try
+        Ctype.unify env self_type cl_sig.csig_self
+      with Ctype.Unify trace ->
+        match trace with
+        | Diff _ :: Incompatible_fields {name = n; _ } :: rem ->
+            raise(Error(loc, env, Field_type_mismatch ("method", n, rem)))
+        | _ -> assert false
+      end;
+
+      (* Overriding *)
+      let over_meths = Concr.inter cl_sig.csig_concr concr_meths in
+      let concr_vals = concr_vals cl_sig.csig_vars in
+      let over_vals = Concr.inter concr_vals warn_vals in
+      begin match ovf with
+        Some Fresh ->
+          let cname =
+            match parent with
+              Cty_constr (p, _, _) -> Path.name p
+            | _ -> "inherited"
+          in
+          if not (Concr.is_empty over_meths) then
+            Location.prerr_warning loc
+              (Warnings.Method_override (cname :: Concr.elements over_meths));
+          if not (Concr.is_empty over_vals) then
+            Location.prerr_warning loc
+              (Warnings.Instance_variable_override
+                 (cname :: Concr.elements over_vals));
+      | Some Override
+        when Concr.is_empty over_meths && Concr.is_empty over_vals ->
+        raise (Error(loc, env, No_overriding ("","")))
+      | _ -> ()
+      end;
+
+      let concr_meths = Concr.union cl_sig.csig_concr concr_meths
+      and warn_vals = Concr.union concr_vals warn_vals in
+
+      (cl_sig, concr_meths, warn_vals)
+
+  | _ ->
+      raise(Error(loc, env, Structure_expected parent))
+
+let virtual_method val_env meths self_type lab priv sty loc =
+  let (_, ty') =
+     Ctype.filter_self_method val_env lab priv meths self_type
+  in
+  let sty = Ast_helper.Typ.force_poly sty in
+  let cty = transl_simple_type val_env false sty in
+  let ty = cty.ctyp_type in
+  begin
+    try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
+        raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace)));
+  end;
+  cty
+
+let delayed_meth_specs = ref []
+
+let declare_method val_env meths self_type lab priv sty loc =
+  let (_, ty') =
+     Ctype.filter_self_method val_env lab priv meths self_type
+  in
+  let unif ty =
+    try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
+      raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace)))
+  in
+  let sty = Ast_helper.Typ.force_poly sty in
+  match sty.ptyp_desc, priv with
+    Ptyp_poly ([],sty'), Public ->
+(* TODO: we moved the [transl_simple_type_univars] outside of the lazy,
+so that we can get an immediate value. Is that correct ? Ask Jacques. *)
+      let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) val_env loc in
+      delayed_meth_specs :=
+      Warnings.mk_lazy (fun () ->
+            let cty = transl_simple_type_univars val_env sty' in
+            let ty = cty.ctyp_type in
+            unif ty;
+            returned_cty.ctyp_desc <- Ttyp_poly ([], cty);
+            returned_cty.ctyp_type <- ty;
+          ) ::
+      !delayed_meth_specs;
+      returned_cty
+  | _ ->
+      let cty = transl_simple_type val_env false sty in
+      let ty = cty.ctyp_type in
+      unif ty;
+      cty
+
+let type_constraint val_env sty sty' loc =
+  let cty  = transl_simple_type val_env false sty in
+  let ty = cty.ctyp_type in
+  let cty' = transl_simple_type val_env false sty' in
+  let ty' = cty'.ctyp_type in
+  begin
+    try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
+        raise(Error(loc, val_env, Unconsistent_constraint trace));
+  end;
+  (cty, cty')
+
+let make_method loc cl_num expr =
+  let open Ast_helper in
+  let mkid s = mkloc s loc in
+  Exp.fun_ ~loc:expr.pexp_loc Nolabel None
+    (Pat.alias ~loc (Pat.var ~loc (mkid "self-*")) (mkid ("self-" ^ cl_num)))
+    expr
+
+(*******************************)
+
+let add_val lab (mut, virt, ty) val_sig =
+  let virt =
+    try
+      let (_mut', virt', _ty') = Vars.find lab val_sig in
+      if virt' = Concrete then virt' else virt
+    with Not_found -> virt
+  in
+  Vars.add lab (mut, virt, ty) val_sig
+
+let rec class_type_field env self_type meths arg ctf =
+  Builtin_attributes.warning_scope ctf.pctf_attributes
+    (fun () -> class_type_field_aux env self_type meths arg ctf)
+
+and class_type_field_aux env self_type meths
+    (fields, val_sig, concr_meths, inher) ctf =
+
+  let loc = ctf.pctf_loc in
+  let mkctf desc =
+    { ctf_desc = desc; ctf_loc = loc; ctf_attributes = ctf.pctf_attributes }
+  in
+  match ctf.pctf_desc with
+    Pctf_inherit sparent ->
+      let parent = class_type env sparent in
+      let inher =
+        match parent.cltyp_type with
+          Cty_constr (p, tl, _) -> (p, tl) :: inher
+        | _ -> inher
+      in
+      let (cl_sig, concr_meths, _) =
+        inheritance self_type env None concr_meths Concr.empty sparent.pcty_loc
+          parent.cltyp_type
+      in
+      let val_sig =
+        Vars.fold add_val cl_sig.csig_vars val_sig in
+      (mkctf (Tctf_inherit parent) :: fields,
+       val_sig, concr_meths, inher)
+
+  | Pctf_val ({txt=lab}, mut, virt, sty) ->
+      let cty = transl_simple_type env false sty in
+      let ty = cty.ctyp_type in
+      (mkctf (Tctf_val (lab, mut, virt, cty)) :: fields,
+      add_val lab (mut, virt, ty) val_sig, concr_meths, inher)
+
+  | Pctf_method ({txt=lab}, priv, virt, sty)  ->
+      let cty =
+        declare_method env meths self_type lab priv sty  ctf.pctf_loc in
+      let concr_meths =
+        match virt with
+        | Concrete -> Concr.add lab concr_meths
+        | Virtual -> concr_meths
+      in
+      (mkctf (Tctf_method (lab, priv, virt, cty)) :: fields,
+        val_sig, concr_meths, inher)
+
+  | Pctf_constraint (sty, sty') ->
+      let (cty, cty') = type_constraint env sty sty'  ctf.pctf_loc in
+      (mkctf (Tctf_constraint (cty, cty')) :: fields,
+        val_sig, concr_meths, inher)
+
+  | Pctf_attribute x ->
+      Builtin_attributes.warning_attribute x;
+      (mkctf (Tctf_attribute x) :: fields,
+        val_sig, concr_meths, inher)
+
+  | Pctf_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and class_signature env {pcsig_self=sty; pcsig_fields=sign} =
+  let meths = ref Meths.empty in
+  let self_cty = transl_simple_type env false sty in
+  let self_cty = { self_cty with
+    ctyp_type = Ctype.expand_head env self_cty.ctyp_type } in
+  let self_type =  self_cty.ctyp_type in
+
+  (* Check that the binder is a correct type, and introduce a dummy
+     method preventing self type from being closed. *)
+  let dummy_obj = Ctype.newvar () in
+  Ctype.unify env (Ctype.filter_method env dummy_method Private dummy_obj)
+    (Ctype.newty (Ttuple []));
+  begin try
+    Ctype.unify env self_type dummy_obj
+  with Ctype.Unify _ ->
+    raise(Error(sty.ptyp_loc, env, Pattern_type_clash self_type))
+  end;
+
+  (* Class type fields *)
+  let (rev_fields, val_sig, concr_meths, inher) =
+    Builtin_attributes.warning_scope []
+      (fun () ->
+         List.fold_left (class_type_field env self_type meths)
+           ([], Vars.empty, Concr.empty, [])
+           sign
+      )
+  in
+  let cty =   {csig_self = self_type;
+   csig_vars = val_sig;
+   csig_concr = concr_meths;
+   csig_inher = inher}
+  in
+  { csig_self = self_cty;
+    csig_fields = List.rev rev_fields;
+    csig_type = cty;
+  }
+
+and class_type env scty =
+  Builtin_attributes.warning_scope scty.pcty_attributes
+    (fun () -> class_type_aux env scty)
+
+and class_type_aux env scty =
+  let cltyp desc typ =
+    {
+     cltyp_desc = desc;
+     cltyp_type = typ;
+     cltyp_loc = scty.pcty_loc;
+     cltyp_env = env;
+     cltyp_attributes = scty.pcty_attributes;
+    }
+  in
+  match scty.pcty_desc with
+    Pcty_constr (lid, styl) ->
+      let (path, decl) = Env.lookup_cltype ~loc:scty.pcty_loc lid.txt env in
+      if Path.same decl.clty_path unbound_class then
+        raise(Error(scty.pcty_loc, env, Unbound_class_type_2 lid.txt));
+      let (params, clty) =
+        Ctype.instance_class decl.clty_params decl.clty_type
+      in
+      if List.length params <> List.length styl then
+        raise(Error(scty.pcty_loc, env,
+                    Parameter_arity_mismatch (lid.txt, List.length params,
+                                                   List.length styl)));
+      let ctys = List.map2
+        (fun sty ty ->
+          let cty' = transl_simple_type env false sty in
+          let ty' = cty'.ctyp_type in
+          begin
+           try Ctype.unify env ty' ty with Ctype.Unify trace ->
+                  raise(Error(sty.ptyp_loc, env, Parameter_mismatch trace))
+            end;
+            cty'
+        )       styl params
+      in
+      let typ = Cty_constr (path, params, clty) in
+      cltyp (Tcty_constr ( path, lid , ctys)) typ
+
+  | Pcty_signature pcsig ->
+      let clsig = class_signature env pcsig in
+      let typ = Cty_signature clsig.csig_type in
+      cltyp (Tcty_signature clsig) typ
+
+  | Pcty_arrow (l, sty, scty) ->
+      let cty = transl_simple_type env false sty in
+      let ty = cty.ctyp_type in
+      let ty =
+        if Btype.is_optional l
+        then Ctype.newty (Tconstr(Predef.path_option,[ty], ref Mnil))
+        else ty in
+      let clty = class_type env scty in
+      let typ = Cty_arrow (l, ty, clty.cltyp_type) in
+      cltyp (Tcty_arrow (l, cty, clty)) typ
+
+  | Pcty_open (od, e) ->
+      let (od, newenv) = !type_open_descr env od in
+      let clty = class_type newenv e in
+      cltyp (Tcty_open (od, clty)) clty.cltyp_type
+
+  | Pcty_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+let class_type env scty =
+  delayed_meth_specs := [];
+  let cty = class_type env scty in
+  List.iter Lazy.force (List.rev !delayed_meth_specs);
+  delayed_meth_specs := [];
+  cty
+
+(*******************************)
+
+let rec class_field self_loc cl_num self_type meths vars arg cf =
+  Builtin_attributes.warning_scope cf.pcf_attributes
+    (fun () -> class_field_aux self_loc cl_num self_type meths vars arg cf)
+
+and class_field_aux self_loc cl_num self_type meths vars
+    (class_env, fields, concr_meths, warn_vals, inher,
+     local_meths, local_vals) cf =
+  let loc = cf.pcf_loc in
+  let mkcf desc =
+    { cf_desc = desc; cf_loc = loc; cf_attributes = cf.pcf_attributes }
+  in
+  let {val_env; met_env; par_env} = class_env in
+  match cf.pcf_desc with
+    Pcf_inherit (ovf, sparent, super) ->
+      let parent = class_expr cl_num val_env par_env sparent in
+      let inher =
+        match parent.cl_type with
+          Cty_constr (p, tl, _) -> (p, tl) :: inher
+        | _ -> inher
+      in
+      let (cl_sig, concr_meths, warn_vals) =
+        inheritance self_type val_env (Some ovf) concr_meths warn_vals
+          sparent.pcl_loc parent.cl_type
+      in
+      (* Variables *)
+      let (class_env, inh_vars) =
+        Vars.fold
+          (fun lab info (class_env, inh_vars) ->
+             let mut, vr, ty = info in
+             let (id, class_env) =
+                enter_val cl_num vars true lab mut vr ty class_env
+                 sparent.pcl_loc ;
+             in
+             (class_env, (lab, id) :: inh_vars))
+          cl_sig.csig_vars (class_env, [])
+      in
+      (* Inherited concrete methods *)
+      let inh_meths =
+        Concr.fold (fun lab rem -> (lab, Ident.create_local lab)::rem)
+          cl_sig.csig_concr []
+      in
+      (* Super *)
+      let (class_env,super) =
+        match super with
+          None ->
+            (class_env,None)
+        | Some {txt=name} ->
+            let (_id, class_env) =
+              enter_met_env ~check:(fun s -> Warnings.Unused_ancestor s)
+                sparent.pcl_loc name (Val_anc (inh_meths, cl_num))
+                Val_unbound_ancestor self_type class_env
+            in
+            (class_env,Some name)
+      in
+      (class_env,
+       lazy (mkcf (Tcf_inherit (ovf, parent, super, inh_vars, inh_meths)))
+       :: fields,
+       concr_meths, warn_vals, inher, local_meths, local_vals)
+
+  | Pcf_val (lab, mut, Cfk_virtual styp) ->
+      if !Clflags.principal then Ctype.begin_def ();
+      let cty = Typetexp.transl_simple_type val_env false styp in
+      let ty = cty.ctyp_type in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        Ctype.generalize_structure ty
+      end;
+      let (id, class_env') =
+        enter_val cl_num vars false lab.txt mut Virtual ty
+        class_env loc
+      in
+      (class_env',
+       lazy (mkcf (Tcf_val (lab, mut, id, Tcfk_virtual cty,
+                            met_env == class_env'.met_env)))
+             :: fields,
+             concr_meths, warn_vals, inher, local_meths, local_vals)
+
+  | Pcf_val (lab, mut, Cfk_concrete (ovf, sexp)) ->
+      if Concr.mem lab.txt local_vals then
+        raise(Error(loc, val_env, Duplicate ("instance variable", lab.txt)));
+      if Concr.mem lab.txt warn_vals then begin
+        if ovf = Fresh then
+          Location.prerr_warning lab.loc
+            (Warnings.Instance_variable_override[lab.txt])
+      end else begin
+        if ovf = Override then
+          raise(Error(loc, val_env,
+                      No_overriding ("instance variable", lab.txt)))
+      end;
+      if !Clflags.principal then Ctype.begin_def ();
+      let exp = type_exp val_env sexp in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        Ctype.generalize_structure exp.exp_type
+       end;
+      let (id, class_env') =
+        enter_val cl_num vars false lab.txt mut Concrete exp.exp_type
+        class_env loc
+      in
+      (class_env',
+       lazy (mkcf (Tcf_val (lab, mut, id,
+                    Tcfk_concrete (ovf, exp), met_env == class_env'.met_env)))
+       :: fields,
+       concr_meths, Concr.add lab.txt warn_vals, inher, local_meths,
+       Concr.add lab.txt local_vals)
+
+  | Pcf_method (lab, priv, Cfk_virtual sty) ->
+      let cty = virtual_method val_env meths self_type lab.txt priv sty loc in
+      (class_env,
+        lazy (mkcf(Tcf_method (lab, priv, Tcfk_virtual cty)))
+       ::fields,
+        concr_meths, warn_vals, inher, local_meths, local_vals)
+
+  | Pcf_method (lab, priv, Cfk_concrete (ovf, expr))  ->
+      let expr =
+        match expr.pexp_desc with
+        | Pexp_poly _ -> expr
+        | _ -> Ast_helper.Exp.poly ~loc:expr.pexp_loc expr None
+      in
+      if Concr.mem lab.txt local_meths then
+        raise(Error(loc, val_env, Duplicate ("method", lab.txt)));
+      if Concr.mem lab.txt concr_meths then begin
+        if ovf = Fresh then
+          Location.prerr_warning loc (Warnings.Method_override [lab.txt])
+      end else begin
+        if ovf = Override then
+          raise(Error(loc, val_env, No_overriding("method", lab.txt)))
+      end;
+      let (_, ty) =
+        Ctype.filter_self_method val_env lab.txt priv meths self_type
+      in
+      begin try match expr.pexp_desc with
+        Pexp_poly (sbody, sty) ->
+          begin match sty with None -> ()
+                | Some sty ->
+                    let sty = Ast_helper.Typ.force_poly sty in
+                    let cty' = Typetexp.transl_simple_type val_env false sty in
+                    let ty' = cty'.ctyp_type in
+              Ctype.unify val_env ty' ty
+          end;
+          begin match (Ctype.repr ty).desc with
+            Tvar _ ->
+              let ty' = Ctype.newvar () in
+              Ctype.unify val_env (Ctype.newty (Tpoly (ty', []))) ty;
+              Ctype.unify val_env (type_approx val_env sbody) ty'
+          | Tpoly (ty1, tl) ->
+              let _, ty1' = Ctype.instance_poly false tl ty1 in
+              let ty2 = type_approx val_env sbody in
+              Ctype.unify val_env ty2 ty1'
+          | _ -> assert false
+          end
+      | _ -> assert false
+      with Ctype.Unify trace ->
+        raise(Error(loc, val_env,
+                    Field_type_mismatch ("method", lab.txt, trace)))
+      end;
+      let meth_expr = make_method self_loc cl_num expr in
+      (* backup variables for Pexp_override *)
+      let vars_local = !vars in
+
+      let field =
+        Warnings.mk_lazy
+          (fun () ->
+             (* Read the generalized type *)
+             let (_, ty) = Meths.find lab.txt !meths in
+             let meth_type = mk_expected (
+               Btype.newgenty (Tarrow(Nolabel, self_type, ty, Cok))
+             ) in
+             Ctype.raise_nongen_level ();
+             vars := vars_local;
+             let texp = type_expect met_env meth_expr meth_type in
+             Ctype.end_def ();
+             mkcf (Tcf_method (lab, priv, Tcfk_concrete (ovf, texp)))
+          )
+      in
+      (class_env, field::fields,
+       Concr.add lab.txt concr_meths, warn_vals, inher,
+       Concr.add lab.txt local_meths, local_vals)
+
+  | Pcf_constraint (sty, sty') ->
+      let (cty, cty') = type_constraint val_env sty sty' loc in
+      (class_env,
+        lazy (mkcf (Tcf_constraint (cty, cty'))) :: fields,
+        concr_meths, warn_vals, inher, local_meths, local_vals)
+
+  | Pcf_initializer expr ->
+      let expr = make_method self_loc cl_num expr in
+      let vars_local = !vars in
+      let field =
+        lazy begin
+          Ctype.raise_nongen_level ();
+          let meth_type = mk_expected (
+            Ctype.newty
+              (Tarrow (Nolabel, self_type,
+                       Ctype.instance Predef.type_unit, Cok))
+          ) in
+          vars := vars_local;
+          let texp = type_expect met_env expr meth_type in
+          Ctype.end_def ();
+          mkcf (Tcf_initializer texp)
+        end in
+      (class_env, field::fields, concr_meths, warn_vals,
+       inher, local_meths, local_vals)
+  | Pcf_attribute x ->
+      Builtin_attributes.warning_attribute x;
+      (class_env,
+        lazy (mkcf (Tcf_attribute x)) :: fields,
+        concr_meths, warn_vals, inher, local_meths, local_vals)
+  | Pcf_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+(* N.B. the self type of a final object type doesn't contain a dummy method in
+   the beginning.
+   We only explicitly add a dummy method to class definitions (and class (type)
+   declarations)), which are later removed (made absent) by [final_decl].
+
+   If we ever find a dummy method in a final object self type, it means that
+   somehow we've unified the self type of the object with the self type of a not
+   yet finished class.
+   When this happens, we cannot close the object type and must error. *)
+and class_structure cl_num final val_env met_env loc
+  { pcstr_self = spat; pcstr_fields = str } =
+  (* Environment for substructures *)
+  let par_env = met_env in
+
+  (* Location of self. Used for locations of self arguments *)
+  let self_loc = {spat.ppat_loc with Location.loc_ghost = true} in
+
+  let self_type = Ctype.newobj (Ctype.newvar ()) in
+
+  (* Adding a dummy method to the self type prevents it from being closed /
+     escaping.
+     That isn't needed for objects though. *)
+  if not final then
+    Ctype.unify val_env
+      (Ctype.filter_method val_env dummy_method Private self_type)
+      (Ctype.newty (Ttuple []));
+
+  (* Private self is used for private method calls *)
+  let private_self = if final then Ctype.newvar () else self_type in
+
+  (* Self binder *)
+  let (pat, meths, vars, val_env, met_env, par_env) =
+    type_self_pattern cl_num private_self val_env met_env par_env spat
+  in
+  let public_self = pat.pat_type in
+
+  (* Check that the binder has a correct type *)
+  let ty =
+    if final then Ctype.newobj (Ctype.newvar()) else self_type in
+  begin try Ctype.unify val_env public_self ty with
+    Ctype.Unify _ ->
+      raise(Error(spat.ppat_loc, val_env, Pattern_type_clash public_self))
+  end;
+  let get_methods ty =
+    (fst (Ctype.flatten_fields
+            (Ctype.object_fields (Ctype.expand_head val_env ty)))) in
+  if final then begin
+    (* Copy known information to still empty self_type *)
+    List.iter
+      (fun (lab,kind,ty) ->
+        let k =
+          if Btype.field_kind_repr kind = Fpresent then Public else Private in
+        try Ctype.unify val_env ty
+            (Ctype.filter_method val_env lab k self_type)
+        with _ -> assert false)
+      (get_methods public_self)
+  end;
+
+  (* Typing of class fields *)
+  let class_env = {val_env; met_env; par_env} in
+  let (_, fields, concr_meths, _, inher, _local_meths, _local_vals) =
+    Builtin_attributes.warning_scope []
+      (fun () ->
+         List.fold_left (class_field self_loc cl_num self_type meths vars)
+           ( class_env,[], Concr.empty, Concr.empty, [],
+            Concr.empty, Concr.empty)
+           str
+      )
+  in
+  Ctype.unify val_env self_type (Ctype.newvar ()); (* useless ? *)
+  let sign =
+    {csig_self = public_self;
+     csig_vars = Vars.map (fun (_id, mut, vr, ty) -> (mut, vr, ty)) !vars;
+     csig_concr = concr_meths;
+      csig_inher = inher} in
+  let methods = get_methods self_type in
+  let priv_meths =
+    List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind <> Fpresent)
+      methods in
+  (* ensure that inherited methods are listed too *)
+  List.iter (fun (met, _kind, _ty) ->
+      if Meths.mem met !meths then () else
+      ignore (Ctype.filter_self_method val_env met Private meths self_type))
+    methods;
+  if final then begin
+    (* Unify private_self and a copy of self_type. self_type will not
+       be modified after this point *)
+    if not (Ctype.close_object self_type) then
+      raise(Error(loc, val_env, Closing_self_type self_type));
+    let mets = virtual_methods {sign with csig_self = self_type} in
+    let vals =
+      Vars.fold
+        (fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l)
+        sign.csig_vars [] in
+    if mets <> [] || vals <> [] then
+      raise(Error(loc, val_env, Virtual_class(true, final, mets, vals)));
+    let self_methods =
+      List.fold_right
+        (fun (lab,kind,ty) rem ->
+           Ctype.newty(Tfield(lab, Btype.copy_kind kind, ty, rem)))
+        methods (Ctype.newty Tnil) in
+    begin try
+      Ctype.unify val_env private_self
+        (Ctype.newty (Tobject(self_methods, ref None)));
+      Ctype.unify val_env public_self self_type
+    with Ctype.Unify trace -> raise(Error(loc, val_env, Final_self_clash trace))
+    end;
+  end;
+
+  (* Typing of method bodies *)
+  (* if !Clflags.principal then *) begin
+    let ms = !meths in
+    (* Generalize the spine of methods accessed through self *)
+    Meths.iter (fun _ (_,ty) -> Ctype.generalize_spine ty) ms;
+    meths :=
+      Meths.map (fun (id,ty) -> (id, Ctype.generic_instance ty)) ms;
+    (* But keep levels correct on the type of self *)
+    Meths.iter (fun _ (_,ty) -> Ctype.unify val_env ty (Ctype.newvar ())) ms
+  end;
+  let fields = List.map Lazy.force (List.rev fields) in
+  let meths = Meths.map (function (id, _ty) -> id) !meths in
+
+  (* Check for private methods made public *)
+  let pub_meths' =
+    List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind = Fpresent)
+      (get_methods public_self) in
+  let names = List.map (fun (x,_,_) -> x) in
+  let l1 = names priv_meths and l2 = names pub_meths' in
+  let added = List.filter (fun x -> List.mem x l1) l2 in
+  if added <> [] then
+    Location.prerr_warning loc (Warnings.Implicit_public_methods added);
+  let sign = if final then sign else
+      {sign with Types.csig_self = Ctype.expand_head val_env public_self} in
+  {
+    cstr_self = pat;
+    cstr_fields = fields;
+    cstr_type = sign;
+    cstr_meths = meths}, sign (* redondant, since already in cstr_type *)
+
+and class_expr cl_num val_env met_env scl =
+  Builtin_attributes.warning_scope scl.pcl_attributes
+    (fun () -> class_expr_aux cl_num val_env met_env scl)
+
+and class_expr_aux cl_num val_env met_env scl =
+  match scl.pcl_desc with
+    Pcl_constr (lid, styl) ->
+      let (path, decl) = Env.lookup_class ~loc:scl.pcl_loc lid.txt val_env in
+      if Path.same decl.cty_path unbound_class then
+        raise(Error(scl.pcl_loc, val_env, Unbound_class_2 lid.txt));
+      let tyl = List.map
+          (fun sty -> transl_simple_type val_env false sty)
+          styl
+      in
+      let (params, clty) =
+        Ctype.instance_class decl.cty_params decl.cty_type
+      in
+      let clty' = abbreviate_class_type path params clty in
+      if List.length params <> List.length tyl then
+        raise(Error(scl.pcl_loc, val_env,
+                    Parameter_arity_mismatch (lid.txt, List.length params,
+                                                   List.length tyl)));
+      List.iter2
+        (fun cty' ty ->
+          let ty' = cty'.ctyp_type in
+           try Ctype.unify val_env ty' ty with Ctype.Unify trace ->
+             raise(Error(cty'.ctyp_loc, val_env, Parameter_mismatch trace)))
+        tyl params;
+      let cl =
+        rc {cl_desc = Tcl_ident (path, lid, tyl);
+            cl_loc = scl.pcl_loc;
+            cl_type = clty';
+            cl_env = val_env;
+            cl_attributes = scl.pcl_attributes;
+           }
+      in
+      let (vals, meths, concrs) = extract_constraints clty in
+      rc {cl_desc = Tcl_constraint (cl, None, vals, meths, concrs);
+          cl_loc = scl.pcl_loc;
+          cl_type = clty';
+          cl_env = val_env;
+          cl_attributes = []; (* attributes are kept on the inner cl node *)
+         }
+  | Pcl_structure cl_str ->
+      let (desc, ty) =
+        class_structure cl_num false val_env met_env scl.pcl_loc cl_str in
+      rc {cl_desc = Tcl_structure desc;
+          cl_loc = scl.pcl_loc;
+          cl_type = Cty_signature ty;
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_fun (l, Some default, spat, sbody) ->
+      let loc = default.pexp_loc in
+      let open Ast_helper in
+      let scases = [
+        Exp.case
+          (Pat.construct ~loc
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
+             (Some ([], Pat.var ~loc (mknoloc "*sth*"))))
+          (Exp.ident ~loc (mknoloc (Longident.Lident "*sth*")));
+
+        Exp.case
+          (Pat.construct ~loc
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
+             None)
+          default;
+       ]
+      in
+      let smatch =
+        Exp.match_ ~loc (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*")))
+          scases
+      in
+      let sfun =
+        Cl.fun_ ~loc:scl.pcl_loc
+          l None
+          (Pat.var ~loc (mknoloc "*opt*"))
+          (Cl.let_ ~loc:scl.pcl_loc Nonrecursive [Vb.mk spat smatch] sbody)
+          (* Note: we don't put the '#default' attribute, as it
+             is not detected for class-level let bindings.  See #5975.*)
+      in
+      class_expr cl_num val_env met_env sfun
+  | Pcl_fun (l, None, spat, scl') ->
+      if !Clflags.principal then Ctype.begin_def ();
+      let (pat, pv, val_env', met_env) =
+        Typecore.type_class_arg_pattern cl_num val_env met_env l spat
+      in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        let gen {pat_type = ty} = Ctype.generalize_structure ty in
+        iter_pattern gen pat
+      end;
+      let pv =
+        List.map
+          begin fun (id, id', _ty) ->
+            let path = Pident id' in
+            (* do not mark the value as being used *)
+            let vd = Env.find_value path val_env' in
+            (id,
+             {exp_desc =
+              Texp_ident(path, mknoloc (Longident.Lident (Ident.name id)), vd);
+              exp_loc = Location.none; exp_extra = [];
+              exp_type = Ctype.instance vd.val_type;
+              exp_attributes = []; (* check *)
+              exp_env = val_env'})
+          end
+          pv
+      in
+      let rec not_nolabel_function = function
+        | Cty_arrow(Nolabel, _, _) -> false
+        | Cty_arrow(_, _, cty) -> not_nolabel_function cty
+        | _ -> true
+      in
+      let partial =
+        let dummy = type_exp val_env (Ast_helper.Exp.unreachable ()) in
+        Typecore.check_partial val_env pat.pat_type pat.pat_loc
+          [{c_lhs = pat; c_guard = None; c_rhs = dummy}]
+      in
+      Ctype.raise_nongen_level ();
+      let cl = class_expr cl_num val_env' met_env scl' in
+      Ctype.end_def ();
+      if Btype.is_optional l && not_nolabel_function cl.cl_type then
+        Location.prerr_warning pat.pat_loc
+          Warnings.Unerasable_optional_argument;
+      rc {cl_desc = Tcl_fun (l, pat, pv, cl, partial);
+          cl_loc = scl.pcl_loc;
+          cl_type = Cty_arrow
+            (l, Ctype.instance pat.pat_type, cl.cl_type);
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_apply (scl', sargs) ->
+      assert (sargs <> []);
+      if !Clflags.principal then Ctype.begin_def ();
+      let cl = class_expr cl_num val_env met_env scl' in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        generalize_class_type false cl.cl_type;
+      end;
+      let rec nonopt_labels ls ty_fun =
+        match ty_fun with
+        | Cty_arrow (l, _, ty_res) ->
+            if Btype.is_optional l then nonopt_labels ls ty_res
+            else nonopt_labels (l::ls) ty_res
+        | _    -> ls
+      in
+      let ignore_labels =
+        !Clflags.classic ||
+        let labels = nonopt_labels [] cl.cl_type in
+        List.length labels = List.length sargs &&
+        List.for_all (fun (l,_) -> l = Nolabel) sargs &&
+        List.exists (fun l -> l <> Nolabel) labels &&
+        begin
+          Location.prerr_warning
+            cl.cl_loc
+            (Warnings.Labels_omitted
+               (List.map Printtyp.string_of_label
+                         (List.filter ((<>) Nolabel) labels)));
+          true
+        end
+      in
+      let rec type_args args omitted ty_fun ty_fun0 sargs =
+        match ty_fun, ty_fun0 with
+        | Cty_arrow (l, ty, ty_fun), Cty_arrow (_, ty0, ty_fun0)
+          when sargs <> [] ->
+            let name = Btype.label_name l
+            and optional = Btype.is_optional l in
+            let use_arg sarg l' =
+              Some (
+                if not optional || Btype.is_optional l' then
+                  type_argument val_env sarg ty ty0
+                else
+                  let ty' = extract_option_type val_env ty
+                  and ty0' = extract_option_type val_env ty0 in
+                  let arg = type_argument val_env sarg ty' ty0' in
+                  option_some val_env arg
+              )
+            in
+            let eliminate_optional_arg () =
+              Some (option_none val_env ty0 Location.none)
+            in
+            let remaining_sargs, arg =
+              if ignore_labels then begin
+                match sargs with
+                | [] -> assert false
+                | (l', sarg) :: remaining_sargs ->
+                    if name = Btype.label_name l' ||
+                       (not optional && l' = Nolabel)
+                    then
+                      (remaining_sargs, use_arg sarg l')
+                    else if
+                      optional &&
+                      not (List.exists (fun (l, _) -> name = Btype.label_name l)
+                             remaining_sargs)
+                    then
+                      (sargs, eliminate_optional_arg ())
+                    else
+                      raise(Error(sarg.pexp_loc, val_env, Apply_wrong_label l'))
+              end else
+                match Btype.extract_label name sargs with
+                | Some (l', sarg, _, remaining_sargs) ->
+                    if not optional && Btype.is_optional l' then
+                      Location.prerr_warning sarg.pexp_loc
+                        (Warnings.Nonoptional_label
+                           (Printtyp.string_of_label l));
+                    remaining_sargs, use_arg sarg l'
+                | None ->
+                    sargs,
+                    if Btype.is_optional l && List.mem_assoc Nolabel sargs then
+                      eliminate_optional_arg ()
+                    else
+                      None
+            in
+            let omitted = if arg = None then (l,ty0) :: omitted else omitted in
+            type_args ((l,arg)::args) omitted ty_fun ty_fun0 remaining_sargs
+        | _ ->
+            match sargs with
+              (l, sarg0)::_ ->
+                if omitted <> [] then
+                  raise(Error(sarg0.pexp_loc, val_env, Apply_wrong_label l))
+                else
+                  raise(Error(cl.cl_loc, val_env, Cannot_apply cl.cl_type))
+            | [] ->
+                (List.rev args,
+                 List.fold_left
+                   (fun ty_fun (l,ty) -> Cty_arrow(l,ty,ty_fun))
+                   ty_fun0 omitted)
+      in
+      let (args, cty) =
+        let (_, ty_fun0) = Ctype.instance_class [] cl.cl_type in
+        type_args [] [] cl.cl_type ty_fun0 sargs
+      in
+      rc {cl_desc = Tcl_apply (cl, args);
+          cl_loc = scl.pcl_loc;
+          cl_type = cty;
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_let (rec_flag, sdefs, scl') ->
+      let (defs, val_env) =
+        Typecore.type_let In_class_def val_env rec_flag sdefs in
+      let (vals, met_env) =
+        List.fold_right
+          (fun (id, _id_loc, _typ) (vals, met_env) ->
+             let path = Pident id in
+             (* do not mark the value as used *)
+             let vd = Env.find_value path val_env in
+             Ctype.begin_def ();
+             let expr =
+               {exp_desc =
+                Texp_ident(path, mknoloc(Longident.Lident (Ident.name id)),vd);
+                exp_loc = Location.none; exp_extra = [];
+                exp_type = Ctype.instance vd.val_type;
+                exp_attributes = [];
+                exp_env = val_env;
+               }
+             in
+             Ctype.end_def ();
+             Ctype.generalize expr.exp_type;
+             let desc =
+               {val_type = expr.exp_type; val_kind = Val_ivar (Immutable,
+                                                               cl_num);
+                val_attributes = [];
+                Types.val_loc = vd.Types.val_loc;
+                val_uid = vd.val_uid;
+               }
+             in
+             let id' = Ident.create_local (Ident.name id) in
+             ((id', expr)
+              :: vals,
+              Env.add_value id' desc met_env))
+          (let_bound_idents_full defs)
+          ([], met_env)
+      in
+      let cl = class_expr cl_num val_env met_env scl' in
+      let () = if rec_flag = Recursive then
+        check_recursive_bindings val_env defs
+      in
+      rc {cl_desc = Tcl_let (rec_flag, defs, vals, cl);
+          cl_loc = scl.pcl_loc;
+          cl_type = cl.cl_type;
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_constraint (scl', scty) ->
+      Ctype.begin_class_def ();
+      let context = Typetexp.narrow () in
+      let cl = class_expr cl_num val_env met_env scl' in
+      Typetexp.widen context;
+      let context = Typetexp.narrow () in
+      let clty = class_type val_env scty in
+      Typetexp.widen context;
+      Ctype.end_def ();
+
+      limited_generalize (Ctype.row_variable (Ctype.self_type cl.cl_type))
+          cl.cl_type;
+      limited_generalize (Ctype.row_variable (Ctype.self_type clty.cltyp_type))
+        clty.cltyp_type;
+
+      begin match
+        Includeclass.class_types val_env cl.cl_type clty.cltyp_type
+      with
+        []    -> ()
+      | error -> raise(Error(cl.cl_loc, val_env, Class_match_failure error))
+      end;
+      let (vals, meths, concrs) = extract_constraints clty.cltyp_type in
+      rc {cl_desc = Tcl_constraint (cl, Some clty, vals, meths, concrs);
+          cl_loc = scl.pcl_loc;
+          cl_type = snd (Ctype.instance_class [] clty.cltyp_type);
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_open (pod, e) ->
+      let used_slot = ref false in
+      let (od, new_val_env) = !type_open_descr ~used_slot val_env pod in
+      let ( _, new_met_env) = !type_open_descr ~used_slot met_env pod in
+      let cl = class_expr cl_num new_val_env new_met_env e in
+      rc {cl_desc = Tcl_open (od, cl);
+          cl_loc = scl.pcl_loc;
+          cl_type = cl.cl_type;
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+(*******************************)
+
+(* Approximate the type of the constructor to allow recursive use *)
+(* of optional parameters                                         *)
+
+let var_option = Predef.type_option (Btype.newgenvar ())
+
+let rec approx_declaration cl =
+  match cl.pcl_desc with
+    Pcl_fun (l, _, _, cl) ->
+      let arg =
+        if Btype.is_optional l then Ctype.instance var_option
+        else Ctype.newvar () in
+      Ctype.newty (Tarrow (l, arg, approx_declaration cl, Cok))
+  | Pcl_let (_, _, cl) ->
+      approx_declaration cl
+  | Pcl_constraint (cl, _) ->
+      approx_declaration cl
+  | _ -> Ctype.newvar ()
+
+let rec approx_description ct =
+  match ct.pcty_desc with
+    Pcty_arrow (l, _, ct) ->
+      let arg =
+        if Btype.is_optional l then Ctype.instance var_option
+        else Ctype.newvar () in
+      Ctype.newty (Tarrow (l, arg, approx_description ct, Cok))
+  | _ -> Ctype.newvar ()
+
+(*******************************)
+
+let temp_abbrev loc env id arity uid =
+  let params = ref [] in
+  for _i = 1 to arity do
+    params := Ctype.newvar () :: !params
+  done;
+  let ty = Ctype.newobj (Ctype.newvar ()) in
+  let env =
+    Env.add_type ~check:true id
+      {type_params = !params;
+       type_arity = arity;
+       type_kind = Type_abstract;
+       type_private = Public;
+       type_manifest = Some ty;
+       type_variance = Variance.unknown_signature ~injective:false ~arity;
+       type_separability = Types.Separability.default_signature ~arity;
+       type_is_newtype = false;
+       type_expansion_scope = Btype.lowest_level;
+       type_loc = loc;
+       type_attributes = []; (* or keep attrs from the class decl? *)
+       type_immediate = Unknown;
+       type_unboxed_default = false;
+       type_uid = uid;
+      }
+      env
+  in
+  (!params, ty, env)
+
+let initial_env define_class approx
+    (res, env) (cl, id, ty_id, obj_id, cl_id, uid) =
+  (* Temporary abbreviations *)
+  let arity = List.length cl.pci_params in
+  let (obj_params, obj_ty, env) = temp_abbrev cl.pci_loc env obj_id arity uid in
+  let (cl_params, cl_ty, env) = temp_abbrev cl.pci_loc env cl_id arity uid in
+
+  (* Temporary type for the class constructor *)
+  let constr_type = approx cl.pci_expr in
+  if !Clflags.principal then Ctype.generalize_spine constr_type;
+  let dummy_cty =
+    Cty_signature
+      { csig_self = Ctype.newvar ();
+        csig_vars = Vars.empty;
+        csig_concr = Concr.empty;
+        csig_inher = [] }
+  in
+  let dummy_class =
+    {Types.cty_params = [];             (* Dummy value *)
+     cty_variance = [];
+     cty_type = dummy_cty;        (* Dummy value *)
+     cty_path = unbound_class;
+     cty_new =
+       begin match cl.pci_virt with
+       | Virtual  -> None
+       | Concrete -> Some constr_type
+       end;
+     cty_loc = Location.none;
+     cty_attributes = [];
+     cty_uid = uid;
+    }
+  in
+  let env =
+    Env.add_cltype ty_id
+      {clty_params = [];            (* Dummy value *)
+       clty_variance = [];
+       clty_type = dummy_cty;       (* Dummy value *)
+       clty_path = unbound_class;
+       clty_loc = Location.none;
+       clty_attributes = [];
+       clty_uid = uid;
+      }
+      (
+        if define_class then
+          Env.add_class id dummy_class env
+        else
+          env
+      )
+  in
+  ((cl, id, ty_id,
+    obj_id, obj_params, obj_ty,
+    cl_id, cl_params, cl_ty,
+    constr_type, dummy_class)::res,
+   env)
+
+let class_infos define_class kind
+    (cl, id, ty_id,
+     obj_id, obj_params, obj_ty,
+     cl_id, cl_params, cl_ty,
+     constr_type, dummy_class)
+    (res, env) =
+
+  reset_type_variables ();
+  Ctype.begin_class_def ();
+
+  (* Introduce class parameters *)
+  let ci_params =
+    let make_param (sty, v) =
+      try
+          (transl_type_param env sty, v)
+      with Already_bound ->
+        raise(Error(sty.ptyp_loc, env, Repeated_parameter))
+    in
+      List.map make_param cl.pci_params
+  in
+  let params = List.map (fun (cty, _) -> cty.ctyp_type) ci_params in
+
+  (* Allow self coercions (only for class declarations) *)
+  let coercion_locs = ref [] in
+
+  (* Type the class expression *)
+  let (expr, typ) =
+    try
+      Typecore.self_coercion :=
+        (Path.Pident obj_id, coercion_locs) :: !Typecore.self_coercion;
+      let res = kind env cl.pci_expr in
+      Typecore.self_coercion := List.tl !Typecore.self_coercion;
+      res
+    with exn ->
+      Typecore.self_coercion := []; raise exn
+  in
+
+  Ctype.end_def ();
+
+  let sty = Ctype.self_type typ in
+
+  (* First generalize the type of the dummy method (cf PR#6123) *)
+  let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in
+  List.iter (fun (met, _, ty) -> if met = dummy_method then Ctype.generalize ty)
+    fields;
+  (* Generalize the row variable *)
+  let rv = Ctype.row_variable sty in
+  List.iter (Ctype.limited_generalize rv) params;
+  limited_generalize rv typ;
+
+  (* Check the abbreviation for the object type *)
+  let (obj_params', obj_type) = Ctype.instance_class params typ in
+  let constr = Ctype.newconstr (Path.Pident obj_id) obj_params in
+  begin
+    let ty = Ctype.self_type obj_type in
+    Ctype.hide_private_methods ty;
+    if not (Ctype.close_object ty) then
+      raise(Error(cl.pci_loc, env, Closing_self_type ty));
+    begin try
+      List.iter2 (Ctype.unify env) obj_params obj_params'
+    with Ctype.Unify _ ->
+      raise(Error(cl.pci_loc, env,
+            Bad_parameters (obj_id, constr,
+                            Ctype.newconstr (Path.Pident obj_id)
+                                            obj_params')))
+    end;
+    begin try
+      Ctype.unify env ty constr
+    with Ctype.Unify _ ->
+      raise(Error(cl.pci_loc, env,
+        Abbrev_type_clash (constr, ty, Ctype.expand_head env constr)))
+    end
+  end;
+
+  (* Check the other temporary abbreviation (#-type) *)
+  begin
+    let (cl_params', cl_type) = Ctype.instance_class params typ in
+    let ty = Ctype.self_type cl_type in
+    Ctype.hide_private_methods ty;
+    Ctype.set_object_name obj_id (Ctype.row_variable ty) cl_params ty;
+    begin try
+      List.iter2 (Ctype.unify env) cl_params cl_params'
+    with Ctype.Unify _ ->
+      raise(Error(cl.pci_loc, env,
+            Bad_parameters (cl_id,
+                            Ctype.newconstr (Path.Pident cl_id)
+                                            cl_params,
+                            Ctype.newconstr (Path.Pident cl_id)
+                                            cl_params')))
+    end;
+    begin try
+      Ctype.unify env ty cl_ty
+    with Ctype.Unify _ ->
+      let constr = Ctype.newconstr (Path.Pident cl_id) params in
+      raise(Error(cl.pci_loc, env, Abbrev_type_clash (constr, ty, cl_ty)))
+    end
+  end;
+
+  (* Type of the class constructor *)
+  begin try
+    Ctype.unify env
+      (constructor_type constr obj_type)
+      (Ctype.instance constr_type)
+  with Ctype.Unify trace ->
+    raise(Error(cl.pci_loc, env,
+                Constructor_type_mismatch (cl.pci_name.txt, trace)))
+  end;
+
+  (* Class and class type temporary definitions *)
+  let cty_variance =
+    Variance.unknown_signature ~injective:false ~arity:(List.length params) in
+  let cltydef =
+    {clty_params = params; clty_type = class_body typ;
+     clty_variance = cty_variance;
+     clty_path = Path.Pident obj_id;
+     clty_loc = cl.pci_loc;
+     clty_attributes = cl.pci_attributes;
+     clty_uid = dummy_class.cty_uid;
+    }
+  and clty =
+    {cty_params = params; cty_type = typ;
+     cty_variance = cty_variance;
+     cty_path = Path.Pident obj_id;
+     cty_new =
+       begin match cl.pci_virt with
+       | Virtual  -> None
+       | Concrete -> Some constr_type
+       end;
+     cty_loc = cl.pci_loc;
+     cty_attributes = cl.pci_attributes;
+     cty_uid = dummy_class.cty_uid;
+    }
+  in
+  dummy_class.cty_type <- typ;
+  let env =
+    Env.add_cltype ty_id cltydef (
+    if define_class then Env.add_class id clty env else env)
+  in
+
+  if cl.pci_virt = Concrete then begin
+    let sign = Ctype.signature_of_class_type typ in
+    let mets = virtual_methods sign in
+    let vals =
+      Vars.fold
+        (fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l)
+        sign.csig_vars [] in
+    if mets <> []  || vals <> [] then
+      raise(Error(cl.pci_loc, env, Virtual_class(define_class, false, mets,
+                                                 vals)));
+  end;
+
+  (* Misc. *)
+  let arity = Ctype.class_type_arity typ in
+  let pub_meths =
+    let (fields, _) =
+      Ctype.flatten_fields (Ctype.object_fields (Ctype.expand_head env obj_ty))
+    in
+    List.map (function (lab, _, _) -> lab) fields
+  in
+
+  (* Final definitions *)
+  let (params', typ') = Ctype.instance_class params typ in
+  let cltydef =
+    {clty_params = params'; clty_type = class_body typ';
+     clty_variance = cty_variance;
+     clty_path = Path.Pident obj_id;
+     clty_loc = cl.pci_loc;
+     clty_attributes = cl.pci_attributes;
+     clty_uid = dummy_class.cty_uid;
+    }
+  and clty =
+    {cty_params = params'; cty_type = typ';
+     cty_variance = cty_variance;
+     cty_path = Path.Pident obj_id;
+     cty_new =
+       begin match cl.pci_virt with
+       | Virtual  -> None
+       | Concrete -> Some (Ctype.instance constr_type)
+       end;
+     cty_loc = cl.pci_loc;
+     cty_attributes = cl.pci_attributes;
+     cty_uid = dummy_class.cty_uid;
+    }
+  in
+  let obj_abbr =
+    let arity = List.length obj_params in
+    {
+     type_params = obj_params;
+     type_arity = arity;
+     type_kind = Type_abstract;
+     type_private = Public;
+     type_manifest = Some obj_ty;
+     type_variance = Variance.unknown_signature ~injective:false ~arity;
+     type_separability = Types.Separability.default_signature ~arity;
+     type_is_newtype = false;
+     type_expansion_scope = Btype.lowest_level;
+     type_loc = cl.pci_loc;
+     type_attributes = []; (* or keep attrs from cl? *)
+     type_immediate = Unknown;
+     type_unboxed_default = false;
+     type_uid = dummy_class.cty_uid;
+    }
+  in
+  let (cl_params, cl_ty) =
+    Ctype.instance_parameterized_type params (Ctype.self_type typ)
+  in
+  Ctype.hide_private_methods cl_ty;
+  Ctype.set_object_name obj_id (Ctype.row_variable cl_ty) cl_params cl_ty;
+  let cl_abbr =
+    let arity = List.length cl_params in
+    {
+     type_params = cl_params;
+     type_arity = arity;
+     type_kind = Type_abstract;
+     type_private = Public;
+     type_manifest = Some cl_ty;
+     type_variance = Variance.unknown_signature ~injective:false ~arity;
+     type_separability = Types.Separability.default_signature ~arity;
+     type_is_newtype = false;
+     type_expansion_scope = Btype.lowest_level;
+     type_loc = cl.pci_loc;
+     type_attributes = []; (* or keep attrs from cl? *)
+     type_immediate = Unknown;
+     type_unboxed_default = false;
+     type_uid = dummy_class.cty_uid;
+    }
+  in
+  ((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params,
+    arity, pub_meths, List.rev !coercion_locs, expr) :: res,
+   env)
+
+let final_decl env define_class
+    (cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params,
+     arity, pub_meths, coe, expr) =
+
+  begin try Ctype.collapse_conj_params env clty.cty_params
+  with Ctype.Unify trace ->
+    raise(Error(cl.pci_loc, env, Non_collapsable_conjunction (id, clty, trace)))
+  end;
+
+  (* make the dummy method disappear *)
+  begin
+    let self_type = Ctype.self_type clty.cty_type in
+    let methods, _ =
+      Ctype.flatten_fields
+        (Ctype.object_fields (Ctype.expand_head env self_type))
+    in
+    List.iter (fun (lab,kind,_) ->
+      if lab = dummy_method then
+        match Btype.field_kind_repr kind with
+          Fvar r -> Btype.set_kind r Fabsent
+        | _ -> ()
+    ) methods
+  end;
+
+  List.iter Ctype.generalize clty.cty_params;
+  generalize_class_type true clty.cty_type;
+  Option.iter  Ctype.generalize clty.cty_new;
+  List.iter Ctype.generalize obj_abbr.type_params;
+  Option.iter  Ctype.generalize obj_abbr.type_manifest;
+  List.iter Ctype.generalize cl_abbr.type_params;
+  Option.iter  Ctype.generalize cl_abbr.type_manifest;
+
+  if not (closed_class clty) then
+    raise(Error(cl.pci_loc, env, Non_generalizable_class (id, clty)));
+
+  begin match
+    Ctype.closed_class clty.cty_params
+      (Ctype.signature_of_class_type clty.cty_type)
+  with
+    None        -> ()
+  | Some reason ->
+      let printer =
+        if define_class
+        then function ppf -> Printtyp.class_declaration id ppf clty
+        else function ppf -> Printtyp.cltype_declaration id ppf cltydef
+      in
+      raise(Error(cl.pci_loc, env, Unbound_type_var(printer, reason)))
+  end;
+  { id; clty; ty_id; cltydef; obj_id; obj_abbr; cl_id; cl_abbr; arity;
+    pub_meths; coe;
+    id_loc = cl.pci_name;
+    req = { ci_loc = cl.pci_loc;
+            ci_virt = cl.pci_virt;
+            ci_params = ci_params;
+        (* TODO : check that we have the correct use of identifiers *)
+            ci_id_name = cl.pci_name;
+            ci_id_class = id;
+            ci_id_class_type = ty_id;
+            ci_id_object = obj_id;
+            ci_id_typehash = cl_id;
+            ci_expr = expr;
+            ci_decl = clty;
+            ci_type_decl = cltydef;
+            ci_attributes = cl.pci_attributes;
+        }
+  }
+(*   (cl.pci_variance, cl.pci_loc)) *)
+
+let class_infos define_class kind
+    (cl, id, ty_id,
+     obj_id, obj_params, obj_ty,
+     cl_id, cl_params, cl_ty,
+     constr_type, dummy_class)
+    (res, env) =
+  Builtin_attributes.warning_scope cl.pci_attributes
+    (fun () ->
+       class_infos define_class kind
+         (cl, id, ty_id,
+          obj_id, obj_params, obj_ty,
+          cl_id, cl_params, cl_ty,
+          constr_type, dummy_class)
+         (res, env)
+    )
+
+let extract_type_decls { clty; cltydef; obj_id; obj_abbr; cl_abbr; req} decls =
+  (obj_id, obj_abbr, cl_abbr, clty, cltydef, req) :: decls
+
+let merge_type_decls decl (obj_abbr, cl_abbr, clty, cltydef) =
+  {decl with obj_abbr; cl_abbr; clty; cltydef}
+
+let final_env define_class env { id; clty; ty_id; cltydef; obj_id; obj_abbr;
+    cl_id; cl_abbr } =
+  (* Add definitions after cleaning them *)
+  Env.add_type ~check:true obj_id
+    (Subst.type_declaration Subst.identity obj_abbr) (
+  Env.add_type ~check:true cl_id
+    (Subst.type_declaration Subst.identity cl_abbr) (
+  Env.add_cltype ty_id (Subst.cltype_declaration Subst.identity cltydef) (
+  if define_class then
+    Env.add_class id (Subst.class_declaration Subst.identity clty) env
+  else env)))
+
+(* Check that #c is coercible to c if there is a self-coercion *)
+let check_coercions env { id; id_loc; clty; ty_id; cltydef; obj_id; obj_abbr;
+    cl_id; cl_abbr; arity; pub_meths; coe; req } =
+  begin match coe with [] -> ()
+  | loc :: _ ->
+      let cl_ty, obj_ty =
+        match cl_abbr.type_manifest, obj_abbr.type_manifest with
+          Some cl_ab, Some obj_ab ->
+            let cl_params, cl_ty =
+              Ctype.instance_parameterized_type cl_abbr.type_params cl_ab
+            and obj_params, obj_ty =
+              Ctype.instance_parameterized_type obj_abbr.type_params obj_ab
+            in
+            List.iter2 (Ctype.unify env) cl_params obj_params;
+            cl_ty, obj_ty
+        | _ -> assert false
+      in
+      begin try Ctype.subtype env cl_ty obj_ty ()
+      with Ctype.Subtype (tr1, tr2) ->
+        raise(Typecore.Error(loc, env, Typecore.Not_subtype(tr1, tr2)))
+      end;
+      if not (Ctype.opened_object cl_ty) then
+        raise(Error(loc, env, Cannot_coerce_self obj_ty))
+  end;
+  {cls_id = id;
+   cls_id_loc = id_loc;
+   cls_decl = clty;
+   cls_ty_id = ty_id;
+   cls_ty_decl = cltydef;
+   cls_obj_id = obj_id;
+   cls_obj_abbr = obj_abbr;
+   cls_typesharp_id = cl_id;
+   cls_abbr = cl_abbr;
+   cls_arity = arity;
+   cls_pub_methods = pub_meths;
+   cls_info=req}
+
+(*******************************)
+
+let type_classes define_class approx kind env cls =
+  let scope = Ctype.create_scope () in
+  let cls =
+    List.map
+      (function cl ->
+         (cl,
+          Ident.create_scoped ~scope cl.pci_name.txt,
+          Ident.create_scoped ~scope cl.pci_name.txt,
+          Ident.create_scoped ~scope cl.pci_name.txt,
+          Ident.create_scoped ~scope ("#" ^ cl.pci_name.txt),
+          Uid.mk ~current_unit:(Env.get_unit_name ())
+         ))
+      cls
+  in
+  Ctype.begin_class_def ();
+  let (res, env) =
+    List.fold_left (initial_env define_class approx) ([], env) cls
+  in
+  let (res, env) =
+    List.fold_right (class_infos define_class kind) res ([], env)
+  in
+  Ctype.end_def ();
+  let res = List.rev_map (final_decl env define_class) res in
+  let decls = List.fold_right extract_type_decls res [] in
+  let decls =
+    try Typedecl_variance.update_class_decls env decls
+    with Typedecl_variance.Error(loc, err) ->
+      raise (Typedecl.Error(loc, Typedecl.Variance err))
+  in
+  let res = List.map2 merge_type_decls res decls in
+  let env = List.fold_left (final_env define_class) env res in
+  let res = List.map (check_coercions env) res in
+  (res, env)
+
+let class_num = ref 0
+let class_declaration env sexpr =
+  incr class_num;
+  let expr = class_expr (Int.to_string !class_num) env env sexpr in
+  (expr, expr.cl_type)
+
+let class_description env sexpr =
+  let expr = class_type env sexpr in
+  (expr, expr.cltyp_type)
+
+let class_declarations env cls =
+  let info, env =
+    type_classes true approx_declaration class_declaration env cls
+  in
+  let ids, exprs =
+    List.split
+      (List.map
+         (fun ci -> ci.cls_id, ci.cls_info.ci_expr)
+         info)
+  in
+  check_recursive_class_bindings env ids exprs;
+  info, env
+
+let class_descriptions env cls =
+  type_classes true approx_description class_description env cls
+
+let class_type_declarations env cls =
+  let (decls, env) =
+    type_classes false approx_description class_description env cls
+  in
+  (List.map
+     (fun decl ->
+        {clsty_ty_id = decl.cls_ty_id;
+         clsty_id_loc = decl.cls_id_loc;
+         clsty_ty_decl = decl.cls_ty_decl;
+         clsty_obj_id = decl.cls_obj_id;
+         clsty_obj_abbr = decl.cls_obj_abbr;
+         clsty_typesharp_id = decl.cls_typesharp_id;
+         clsty_abbr = decl.cls_abbr;
+         clsty_info = decl.cls_info})
+     decls,
+   env)
+
+let rec unify_parents env ty cl =
+  match cl.cl_desc with
+    Tcl_ident (p, _, _) ->
+      begin try
+        let decl = Env.find_class p env in
+        let _, body = Ctype.find_cltype_for_path env decl.cty_path in
+        Ctype.unify env ty (Ctype.instance body)
+      with
+        Not_found -> ()
+      | _exn -> assert false
+      end
+  | Tcl_structure st -> unify_parents_struct env ty st
+  | Tcl_open (_, cl)
+  | Tcl_fun (_, _, _, cl, _)
+  | Tcl_apply (cl, _)
+  | Tcl_let (_, _, _, cl)
+  | Tcl_constraint (cl, _, _, _, _) -> unify_parents env ty cl
+and unify_parents_struct env ty st =
+  List.iter
+    (function
+      | {cf_desc = Tcf_inherit (_, cl, _, _, _)} ->
+          unify_parents env ty cl
+      | _ -> ())
+    st.cstr_fields
+
+let type_object env loc s =
+  incr class_num;
+  let (desc, sign) =
+    class_structure (Int.to_string !class_num) true env env loc s in
+  let sty = Ctype.expand_head env sign.csig_self in
+  Ctype.hide_private_methods sty;
+  let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in
+  let meths = List.map (fun (s,_,_) -> s) fields in
+  unify_parents_struct env sign.csig_self desc;
+  (desc, sign, meths)
+
+let () =
+  Typecore.type_object := type_object
+
+(*******************************)
+
+(* Approximate the class declaration as class ['params] id = object end *)
+let approx_class sdecl =
+  let open Ast_helper in
+  let self' = Typ.any () in
+  let clty' = Cty.signature ~loc:sdecl.pci_expr.pcty_loc (Csig.mk self' []) in
+  { sdecl with pci_expr = clty' }
+
+let approx_class_declarations env sdecls =
+  fst (class_type_declarations env (List.map approx_class sdecls))
+
+(*******************************)
+
+(* Error report *)
+
+open Format
+
+let report_error env ppf = function
+  | Repeated_parameter ->
+      fprintf ppf "A type parameter occurs several times"
+  | Unconsistent_constraint trace ->
+      fprintf ppf "@[<v>The class constraints are not consistent.@ ";
+      Printtyp.report_unification_error ppf env trace
+        (fun ppf -> fprintf ppf "Type")
+        (fun ppf -> fprintf ppf "is not compatible with type");
+      fprintf ppf "@]"
+  | Field_type_mismatch (k, m, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "The %s %s@ has type" k m)
+        (function ppf ->
+           fprintf ppf "but is expected to have type")
+  | Structure_expected clty ->
+      fprintf ppf
+        "@[This class expression is not a class structure; it has type@ %a@]"
+        Printtyp.class_type clty
+  | Cannot_apply _ ->
+      fprintf ppf
+        "This class expression is not a class function, it cannot be applied"
+  | Apply_wrong_label l ->
+      let mark_label = function
+        | Nolabel -> "out label"
+        |  l -> sprintf " label %s" (Btype.prefixed_label_name l) in
+      fprintf ppf "This argument cannot be applied with%s" (mark_label l)
+  | Pattern_type_clash ty ->
+      (* XXX Trace *)
+      (* XXX Revoir message d'erreur | Improve error message *)
+      fprintf ppf "@[%s@ %a@]"
+        "This pattern cannot match self: it only matches values of type"
+        Printtyp.type_expr ty
+  | Unbound_class_2 cl ->
+      fprintf ppf "@[The class@ %a@ is not yet completely defined@]"
+      Printtyp.longident cl
+  | Unbound_class_type_2 cl ->
+      fprintf ppf "@[The class type@ %a@ is not yet completely defined@]"
+      Printtyp.longident cl
+  | Abbrev_type_clash (abbrev, actual, expected) ->
+      (* XXX Afficher une trace ? | Print a trace? *)
+      Printtyp.reset_and_mark_loops_list [abbrev; actual; expected];
+      fprintf ppf "@[The abbreviation@ %a@ expands to type@ %a@ \
+       but is used with type@ %a@]"
+        !Oprint.out_type (Printtyp.tree_of_typexp false abbrev)
+        !Oprint.out_type (Printtyp.tree_of_typexp false actual)
+        !Oprint.out_type (Printtyp.tree_of_typexp false expected)
+  | Constructor_type_mismatch (c, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "The expression \"new %s\" has type" c)
+        (function ppf ->
+           fprintf ppf "but is used with type")
+  | Virtual_class (cl, imm, mets, vals) ->
+      let print_mets ppf mets =
+        List.iter (function met -> fprintf ppf "@ %s" met) mets in
+      let missings =
+        match mets, vals with
+          [], _ -> "variables"
+        | _, [] -> "methods"
+        | _ -> "methods and variables"
+      in
+      let print_msg ppf =
+        if imm then fprintf ppf "This object has virtual %s" missings
+        else if cl then fprintf ppf "This class should be virtual"
+        else fprintf ppf "This class type should be virtual"
+      in
+      fprintf ppf
+        "@[%t.@ @[<2>The following %s are undefined :%a@]@]"
+        print_msg missings print_mets (mets @ vals)
+  | Parameter_arity_mismatch(lid, expected, provided) ->
+      fprintf ppf
+        "@[The class constructor %a@ expects %i type argument(s),@ \
+           but is here applied to %i type argument(s)@]"
+        Printtyp.longident lid expected provided
+  | Parameter_mismatch trace ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "The type parameter")
+        (function ppf ->
+           fprintf ppf "does not meet its constraint: it should be")
+  | Bad_parameters (id, params, cstrs) ->
+      Printtyp.reset_and_mark_loops_list [params; cstrs];
+      fprintf ppf
+        "@[The abbreviation %a@ is used with parameters@ %a@ \
+           which are incompatible with constraints@ %a@]"
+        Printtyp.ident id
+        !Oprint.out_type (Printtyp.tree_of_typexp false params)
+        !Oprint.out_type (Printtyp.tree_of_typexp false cstrs)
+  | Class_match_failure error ->
+      Includeclass.report_error ppf error
+  | Unbound_val lab ->
+      fprintf ppf "Unbound instance variable %s" lab
+  | Unbound_type_var (printer, reason) ->
+      let print_common ppf kind ty0 real lab ty =
+        let ty1 =
+          if real then ty0 else Btype.newgenty(Tobject(ty0, ref None)) in
+        List.iter Printtyp.mark_loops [ty; ty1];
+        fprintf ppf
+          "The %s %s@ has type@;<1 2>%a@ where@ %a@ is unbound"
+          kind lab
+          !Oprint.out_type (Printtyp.tree_of_typexp false ty)
+          !Oprint.out_type (Printtyp.tree_of_typexp false ty0)
+      in
+      let print_reason ppf = function
+      | Ctype.CC_Method (ty0, real, lab, ty) ->
+          print_common ppf "method" ty0 real lab ty
+      | Ctype.CC_Value (ty0, real, lab, ty) ->
+          print_common ppf "instance variable" ty0 real lab ty
+      in
+      Printtyp.reset ();
+      fprintf ppf
+        "@[<v>@[Some type variables are unbound in this type:@;<1 2>%t@]@ \
+              @[%a@]@]"
+       printer print_reason reason
+  | Non_generalizable_class (id, clty) ->
+      fprintf ppf
+        "@[The type of this class,@ %a,@ \
+           contains type variables that cannot be generalized@]"
+        (Printtyp.class_declaration id) clty
+  | Cannot_coerce_self ty ->
+      fprintf ppf
+        "@[The type of self cannot be coerced to@ \
+           the type of the current class:@ %a.@.\
+           Some occurrences are contravariant@]"
+        Printtyp.type_scheme ty
+  | Non_collapsable_conjunction (id, clty, trace) ->
+      fprintf ppf
+        "@[The type of this class,@ %a,@ \
+           contains non-collapsible conjunctive types in constraints.@ %t@]"
+        (Printtyp.class_declaration id) clty
+        (fun ppf -> Printtyp.report_unification_error ppf env trace
+            (fun ppf -> fprintf ppf "Type")
+            (fun ppf -> fprintf ppf "is not compatible with type")
+        )
+  | Final_self_clash trace ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "This object is expected to have type")
+        (function ppf ->
+           fprintf ppf "but actually has type")
+  | Mutability_mismatch (_lab, mut) ->
+      let mut1, mut2 =
+        if mut = Immutable then "mutable", "immutable"
+        else "immutable", "mutable" in
+      fprintf ppf
+        "@[The instance variable is %s;@ it cannot be redefined as %s@]"
+        mut1 mut2
+  | No_overriding (_, "") ->
+      fprintf ppf "@[This inheritance does not override any method@ %s@]"
+        "instance variable"
+  | No_overriding (kind, name) ->
+      fprintf ppf "@[The %s `%s'@ has no previous definition@]" kind name
+  | Duplicate (kind, name) ->
+      fprintf ppf "@[The %s `%s'@ has multiple definitions in this object@]"
+                    kind name
+  | Closing_self_type self ->
+    fprintf ppf
+      "@[Cannot close type of object literal:@ %a@,\
+       it has been unified with the self type of a class that is not yet@ \
+       completely defined.@]"
+      Printtyp.type_scheme self
+
+let report_error env ppf err =
+  Printtyp.wrap_printing_env ~error:true
+    env (fun () -> report_error env ppf err)
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, env, err) ->
+        Some (Location.error_of_printer ~loc (report_error env) err)
+      | Error_forward err ->
+        Some err
+      | _ ->
+        None
+    )
diff --git a/upstream/ocaml_413/typing/typeclass.mli b/upstream/ocaml_413/typing/typeclass.mli
new file mode 100644
index 0000000..ac8eb06
--- /dev/null
+++ b/upstream/ocaml_413/typing/typeclass.mli
@@ -0,0 +1,130 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Types
+open Format
+
+type 'a class_info = {
+  cls_id : Ident.t;
+  cls_id_loc : string loc;
+  cls_decl : class_declaration;
+  cls_ty_id : Ident.t;
+  cls_ty_decl : class_type_declaration;
+  cls_obj_id : Ident.t;
+  cls_obj_abbr : type_declaration;
+  cls_typesharp_id : Ident.t;
+  cls_abbr : type_declaration;
+  cls_arity : int;
+  cls_pub_methods : string list;
+  cls_info : 'a;
+}
+
+type class_type_info = {
+  clsty_ty_id : Ident.t;
+  clsty_id_loc : string loc;
+  clsty_ty_decl : class_type_declaration;
+  clsty_obj_id : Ident.t;
+  clsty_obj_abbr : type_declaration;
+  clsty_typesharp_id : Ident.t;
+  clsty_abbr : type_declaration;
+  clsty_info : Typedtree.class_type_declaration;
+}
+
+val class_declarations:
+  Env.t -> Parsetree.class_declaration list ->
+  Typedtree.class_declaration class_info list * Env.t
+
+(*
+and class_declaration =
+  (class_expr, Types.class_declaration) class_infos
+*)
+
+val class_descriptions:
+  Env.t -> Parsetree.class_description list ->
+  Typedtree.class_description class_info list * Env.t
+
+(*
+and class_description =
+  (class_type, unit) class_infos
+*)
+
+val class_type_declarations:
+  Env.t -> Parsetree.class_description list -> class_type_info list * Env.t
+
+(*
+and class_type_declaration =
+  (class_type, Types.class_type_declaration) class_infos
+*)
+
+val approx_class_declarations:
+  Env.t -> Parsetree.class_description list -> class_type_info list
+
+val virtual_methods: Types.class_signature -> label list
+
+(*
+val type_classes :
+           bool ->
+           ('a -> Types.type_expr) ->
+           (Env.t -> 'a -> 'b * Types.class_type) ->
+           Env.t ->
+           'a Parsetree.class_infos list ->
+  (  Ident.t * Types.class_declaration *
+     Ident.t * Types.class_type_declaration *
+     Ident.t * Types.type_declaration *
+     Ident.t * Types.type_declaration *
+     int * string list * 'b * 'b Typedtree.class_infos)
+           list * Env.t
+*)
+
+type error =
+  | Unconsistent_constraint of Errortrace.unification Errortrace.t
+  | Field_type_mismatch of string * string * Errortrace.unification Errortrace.t
+  | Structure_expected of class_type
+  | Cannot_apply of class_type
+  | Apply_wrong_label of arg_label
+  | Pattern_type_clash of type_expr
+  | Repeated_parameter
+  | Unbound_class_2 of Longident.t
+  | Unbound_class_type_2 of Longident.t
+  | Abbrev_type_clash of type_expr * type_expr * type_expr
+  | Constructor_type_mismatch of string * Errortrace.unification Errortrace.t
+  | Virtual_class of bool * bool * string list * string list
+  | Parameter_arity_mismatch of Longident.t * int * int
+  | Parameter_mismatch of Errortrace.unification Errortrace.t
+  | Bad_parameters of Ident.t * type_expr * type_expr
+  | Class_match_failure of Ctype.class_match_failure list
+  | Unbound_val of string
+  | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure
+  | Non_generalizable_class of Ident.t * Types.class_declaration
+  | Cannot_coerce_self of type_expr
+  | Non_collapsable_conjunction of
+      Ident.t * Types.class_declaration * Errortrace.unification Errortrace.t
+  | Final_self_clash of Errortrace.unification Errortrace.t
+  | Mutability_mismatch of string * mutable_flag
+  | No_overriding of string * string
+  | Duplicate of string * string
+  | Closing_self_type of type_expr
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+val report_error : Env.t -> formatter -> error -> unit
+
+(* Forward decl filled in by Typemod.type_open_descr *)
+val type_open_descr :
+  (?used_slot:bool ref ->
+   Env.t -> Parsetree.open_description -> Typedtree.open_description * Env.t)
+    ref
diff --git a/upstream/ocaml_413/typing/typecore.ml b/upstream/ocaml_413/typing/typecore.ml
new file mode 100644
index 0000000..87d4a55
--- /dev/null
+++ b/upstream/ocaml_413/typing/typecore.ml
@@ -0,0 +1,5813 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Typechecking for the core language *)
+
+open Misc
+open Asttypes
+open Parsetree
+open Types
+open Typedtree
+open Btype
+open Ctype
+
+type type_forcing_context =
+  | If_conditional
+  | If_no_else_branch
+  | While_loop_conditional
+  | While_loop_body
+  | For_loop_start_index
+  | For_loop_stop_index
+  | For_loop_body
+  | Assert_condition
+  | Sequence_left_hand_side
+  | When_guard
+
+type type_expected = {
+  ty: type_expr;
+  explanation: type_forcing_context option;
+}
+
+type to_unpack = {
+  tu_name: string Location.loc;
+  tu_loc: Location.t;
+  tu_uid: Uid.t
+}
+
+module Datatype_kind = struct
+  type t = Record | Variant
+
+  let type_name = function
+    | Record -> "record"
+    | Variant -> "variant"
+
+  let label_name = function
+    | Record -> "field"
+    | Variant -> "constructor"
+end
+
+type wrong_name = {
+  type_path: Path.t;
+  kind: Datatype_kind.t;
+  name: string loc;
+  valid_names: string list;
+}
+
+type existential_restriction =
+  | At_toplevel (** no existential types at the toplevel *)
+  | In_group (** nor with let ... and ... *)
+  | In_rec (** or recursive definition *)
+  | With_attributes (** or let[@any_attribute] = ... *)
+  | In_class_args (** or in class arguments *)
+  | In_class_def  (** or in [class c = let ... in ...] *)
+  | In_self_pattern (** or in self pattern *)
+
+type error =
+  | Constructor_arity_mismatch of Longident.t * int * int
+  | Label_mismatch of Longident.t * Errortrace.unification Errortrace.t
+  | Pattern_type_clash :
+      Errortrace.unification Errortrace.t * _ pattern_desc option -> error
+  | Or_pattern_type_clash of Ident.t * Errortrace.unification Errortrace.t
+  | Multiply_bound_variable of string
+  | Orpat_vars of Ident.t * Ident.t list
+  | Expr_type_clash of
+      Errortrace.unification Errortrace.t * type_forcing_context option
+      * expression_desc option
+  | Apply_non_function of type_expr
+  | Apply_wrong_label of arg_label * type_expr * bool
+  | Label_multiply_defined of string
+  | Label_missing of Ident.t list
+  | Label_not_mutable of Longident.t
+  | Wrong_name of string * type_expected * wrong_name
+  | Name_type_mismatch of
+      Datatype_kind.t * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list
+  | Invalid_format of string
+  | Undefined_method of type_expr * string * string list option
+  | Undefined_inherited_method of string * string list
+  | Virtual_class of Longident.t
+  | Private_type of type_expr
+  | Private_label of Longident.t * type_expr
+  | Private_constructor of constructor_description * type_expr
+  | Unbound_instance_variable of string * string list
+  | Instance_variable_not_mutable of string
+  | Not_subtype of Errortrace.Subtype.t * Errortrace.unification Errortrace.t
+  | Outside_class
+  | Value_multiply_overridden of string
+  | Coercion_failure of
+      type_expr * type_expr * Errortrace.unification Errortrace.t * bool
+  | Too_many_arguments of bool * type_expr * type_forcing_context option
+  | Abstract_wrong_label of arg_label * type_expr * type_forcing_context option
+  | Scoping_let_module of string * type_expr
+  | Not_a_variant_type of Longident.t
+  | Incoherent_label_order
+  | Less_general of string * Errortrace.unification Errortrace.t
+  | Modules_not_allowed
+  | Cannot_infer_signature
+  | Not_a_packed_module of type_expr
+  | Unexpected_existential of existential_restriction * string * string list
+  | Invalid_interval
+  | Invalid_for_loop_index
+  | No_value_clauses
+  | Exception_pattern_disallowed
+  | Mixed_value_and_exception_patterns_under_guard
+  | Inlined_record_escape
+  | Inlined_record_expected
+  | Unrefuted_pattern of pattern
+  | Invalid_extension_constructor_payload
+  | Not_an_extension_constructor
+  | Literal_overflow of string
+  | Unknown_literal of string * char
+  | Illegal_letrec_pat
+  | Illegal_letrec_expr
+  | Illegal_class_expr
+  | Letop_type_clash of string * Errortrace.unification Errortrace.t
+  | Andop_type_clash of string * Errortrace.unification Errortrace.t
+  | Bindings_type_clash of Errortrace.unification Errortrace.t
+  | Unbound_existential of Ident.t list * type_expr
+  | Missing_type_constraint
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+(* Forward declaration, to be filled in by Typemod.type_module *)
+
+let type_module =
+  ref ((fun _env _md -> assert false) :
+       Env.t -> Parsetree.module_expr -> Typedtree.module_expr)
+
+(* Forward declaration, to be filled in by Typemod.type_open *)
+
+let type_open :
+  (?used_slot:bool ref -> override_flag -> Env.t -> Location.t ->
+   Longident.t loc -> Path.t * Env.t)
+    ref =
+  ref (fun ?used_slot:_ _ -> assert false)
+
+let type_open_decl :
+  (?used_slot:bool ref -> Env.t -> Parsetree.open_declaration
+   -> open_declaration * Types.signature * Env.t)
+    ref =
+  ref (fun ?used_slot:_ _ -> assert false)
+
+(* Forward declaration, to be filled in by Typemod.type_package *)
+
+let type_package =
+  ref (fun _ -> assert false)
+
+(* Forward declaration, to be filled in by Typeclass.class_structure *)
+let type_object =
+  ref (fun _env _s -> assert false :
+       Env.t -> Location.t -> Parsetree.class_structure ->
+         Typedtree.class_structure * Types.class_signature * string list)
+
+(*
+  Saving and outputting type information.
+  We keep these function names short, because they have to be
+  called each time we create a record of type [Typedtree.expression]
+  or [Typedtree.pattern] that will end up in the typed AST.
+*)
+let re node =
+  Cmt_format.add_saved_type (Cmt_format.Partial_expression node);
+  node
+;;
+let rp node =
+  Cmt_format.add_saved_type (Cmt_format.Partial_pattern (Value, node));
+  node
+;;
+let rcp node =
+  Cmt_format.add_saved_type (Cmt_format.Partial_pattern (Computation, node));
+  node
+;;
+
+
+(* Context for inline record arguments; see [type_ident] *)
+
+type recarg =
+  | Allowed
+  | Required
+  | Rejected
+
+
+let mk_expected ?explanation ty = { ty; explanation; }
+
+let case lhs rhs =
+  {c_lhs = lhs; c_guard = None; c_rhs = rhs}
+
+(* Typing of constants *)
+
+let type_constant = function
+    Const_int _ -> instance Predef.type_int
+  | Const_char _ -> instance Predef.type_char
+  | Const_string _ -> instance Predef.type_string
+  | Const_float _ -> instance Predef.type_float
+  | Const_int32 _ -> instance Predef.type_int32
+  | Const_int64 _ -> instance Predef.type_int64
+  | Const_nativeint _ -> instance Predef.type_nativeint
+
+let constant : Parsetree.constant -> (Asttypes.constant, error) result =
+  function
+  | Pconst_integer (i,None) ->
+     begin
+       try Ok (Const_int (Misc.Int_literal_converter.int i))
+       with Failure _ -> Error (Literal_overflow "int")
+     end
+  | Pconst_integer (i,Some 'l') ->
+     begin
+       try Ok (Const_int32 (Misc.Int_literal_converter.int32 i))
+       with Failure _ -> Error (Literal_overflow "int32")
+     end
+  | Pconst_integer (i,Some 'L') ->
+     begin
+       try Ok (Const_int64 (Misc.Int_literal_converter.int64 i))
+       with Failure _ -> Error (Literal_overflow "int64")
+     end
+  | Pconst_integer (i,Some 'n') ->
+     begin
+       try Ok (Const_nativeint (Misc.Int_literal_converter.nativeint i))
+       with Failure _ -> Error (Literal_overflow "nativeint")
+     end
+  | Pconst_integer (i,Some c) -> Error (Unknown_literal (i, c))
+  | Pconst_char c -> Ok (Const_char c)
+  | Pconst_string (s,loc,d) -> Ok (Const_string (s,loc,d))
+  | Pconst_float (f,None)-> Ok (Const_float f)
+  | Pconst_float (f,Some c) -> Error (Unknown_literal (f, c))
+
+let constant_or_raise env loc cst =
+  match constant cst with
+  | Ok c -> c
+  | Error err -> raise (Error (loc, env, err))
+
+(* Specific version of type_option, using newty rather than newgenty *)
+
+let type_option ty =
+  newty (Tconstr(Predef.path_option,[ty], ref Mnil))
+
+let mkexp exp_desc exp_type exp_loc exp_env =
+  { exp_desc; exp_type; exp_loc; exp_env; exp_extra = []; exp_attributes = [] }
+
+let option_none env ty loc =
+  let lid = Longident.Lident "None" in
+  let cnone = Env.find_ident_constructor Predef.ident_none env in
+  mkexp (Texp_construct(mknoloc lid, cnone, [])) ty loc env
+
+let option_some env texp =
+  let lid = Longident.Lident "Some" in
+  let csome = Env.find_ident_constructor Predef.ident_some env in
+  mkexp ( Texp_construct(mknoloc lid , csome, [texp]) )
+    (type_option texp.exp_type) texp.exp_loc texp.exp_env
+
+let extract_option_type env ty =
+  match expand_head env ty with {desc = Tconstr(path, [ty], _)}
+    when Path.same path Predef.path_option -> ty
+  | _ -> assert false
+
+let extract_concrete_record env ty =
+  match extract_concrete_typedecl env ty with
+    (p0, p, {type_kind=Type_record (fields, _)}) -> (p0, p, fields)
+  | _ -> raise Not_found
+
+let extract_concrete_variant env ty =
+  match extract_concrete_typedecl env ty with
+    (p0, p, {type_kind=Type_variant (cstrs, _)}) -> (p0, p, cstrs)
+  | (p0, p, {type_kind=Type_open}) -> (p0, p, [])
+  | _ -> raise Not_found
+
+let extract_label_names env ty =
+  try
+    let (_, _,fields) = extract_concrete_record env ty in
+    List.map (fun l -> l.Types.ld_id) fields
+  with Not_found ->
+    assert false
+
+(* Typing of patterns *)
+
+(* unification inside type_exp and type_expect *)
+let unify_exp_types loc env ty expected_ty =
+  (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type
+    Printtyp.raw_type_expr expected_ty; *)
+  try
+    unify env ty expected_ty
+  with
+    Unify trace ->
+      raise(Error(loc, env, Expr_type_clash(trace, None, None)))
+  | Tags(l1,l2) ->
+      raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2)))
+
+(* level at which to create the local type declarations *)
+let gadt_equations_level = ref None
+let get_gadt_equations_level () =
+  match !gadt_equations_level with
+    Some y -> y
+  | None -> assert false
+
+let nothing_equated = TypePairs.create 0
+
+(* unification inside type_pat*)
+let unify_pat_types_return_equated_pairs ?(refine = None) loc env ty ty' =
+  try
+    match refine with
+    | Some allow_recursive ->
+        unify_gadt ~equations_level:(get_gadt_equations_level ())
+          ~allow_recursive env ty ty'
+    | None ->
+        unify !env ty ty';
+        nothing_equated
+  with
+  | Unify trace ->
+      raise(Error(loc, !env, Pattern_type_clash(trace, None)))
+  | Tags(l1,l2) ->
+      raise(Typetexp.Error(loc, !env, Typetexp.Variant_tags (l1, l2)))
+
+let unify_pat_types ?refine loc env ty ty' =
+  ignore (unify_pat_types_return_equated_pairs ?refine loc env ty ty')
+
+let unify_pat ?refine env pat expected_ty =
+  try unify_pat_types ?refine pat.pat_loc env pat.pat_type expected_ty
+  with Error (loc, env, Pattern_type_clash(trace, None)) ->
+    raise(Error(loc, env, Pattern_type_clash(trace, Some pat.pat_desc)))
+
+(* unification of a type with a Tconstr with freshly created arguments *)
+let unify_head_only ~refine loc env ty constr =
+  let path =
+    match (repr constr.cstr_res).desc with
+    | Tconstr(p, _, _) -> p
+    | _ -> assert false in
+  let decl = Env.find_type path !env in
+  let ty' = Ctype.newconstr path (Ctype.instance_list decl.type_params) in
+  unify_pat_types ~refine loc env ty' ty
+
+(* Creating new conjunctive types is not allowed when typing patterns *)
+(* make all Reither present in open variants *)
+let finalize_variant pat tag opat r =
+  let row =
+    match expand_head pat.pat_env pat.pat_type with
+      {desc = Tvariant row} -> r := row; row_repr row
+    | _ -> assert false
+  in
+  begin match row_field tag row with
+  | Rabsent -> () (* assert false *)
+  | Reither (true, [], _, e) when not row.row_closed ->
+      set_row_field e (Rpresent None)
+  | Reither (false, ty::tl, _, e) when not row.row_closed ->
+      set_row_field e (Rpresent (Some ty));
+      begin match opat with None -> assert false
+      | Some pat ->
+          let env = ref pat.pat_env in List.iter (unify_pat env pat) (ty::tl)
+      end
+  | Reither (c, _l, true, e) when not (row_fixed row) ->
+      set_row_field e (Reither (c, [], false, ref None))
+  | _ -> ()
+  end
+  (* Force check of well-formedness   WHY? *)
+  (* unify_pat pat.pat_env pat
+    (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false;
+                    row_bound=(); row_fixed=false; row_name=None})); *)
+
+let has_variants p =
+  exists_general_pattern
+    { f = fun (type k) (p : k general_pattern) -> match p.pat_desc with
+     | (Tpat_variant _) -> true
+     | _ -> false } p
+
+let finalize_variants p =
+  iter_general_pattern
+    { f = fun (type k) (p : k general_pattern) -> match p.pat_desc with
+     | Tpat_variant(tag, opat, r) ->
+        finalize_variant p tag opat r
+     | _ -> () } p
+
+(* pattern environment *)
+type pattern_variable =
+  {
+    pv_id: Ident.t;
+    pv_type: type_expr;
+    pv_loc: Location.t;
+    pv_as_var: bool;
+    pv_attributes: attributes;
+  }
+
+type module_variable =
+  string loc * Location.t
+
+let pattern_variables = ref ([] : pattern_variable list)
+let pattern_force = ref ([] : (unit -> unit) list)
+let allow_modules = ref false
+let module_variables = ref ([] : module_variable list)
+let reset_pattern allow =
+  pattern_variables := [];
+  pattern_force := [];
+  allow_modules := allow;
+  module_variables := [];
+;;
+
+let maybe_add_pattern_variables_ghost loc_let env pv =
+  List.fold_right
+    (fun {pv_id; _} env ->
+       let name = Ident.name pv_id in
+       if Env.bound_value name env then env
+       else begin
+         Env.enter_unbound_value name
+           (Val_unbound_ghost_recursive loc_let) env
+       end
+    ) pv env
+
+let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty
+    attrs =
+  if List.exists (fun {pv_id; _} -> Ident.name pv_id = name.txt)
+      !pattern_variables
+  then raise(Error(loc, Env.empty, Multiply_bound_variable name.txt));
+  let id = Ident.create_local name.txt in
+  pattern_variables :=
+    {pv_id = id;
+     pv_type = ty;
+     pv_loc = loc;
+     pv_as_var = is_as_variable;
+     pv_attributes = attrs} :: !pattern_variables;
+  if is_module then begin
+    (* Note: unpack patterns enter a variable of the same name *)
+    if not !allow_modules then
+      raise (Error (loc, Env.empty, Modules_not_allowed));
+    module_variables := (name, loc) :: !module_variables
+  end;
+  id
+
+let sort_pattern_variables vs =
+  List.sort
+    (fun {pv_id = x; _} {pv_id = y; _} ->
+      Stdlib.compare (Ident.name x) (Ident.name y))
+    vs
+
+let enter_orpat_variables loc env  p1_vs p2_vs =
+  (* unify_vars operate on sorted lists *)
+
+  let p1_vs = sort_pattern_variables p1_vs
+  and p2_vs = sort_pattern_variables p2_vs in
+
+  let rec unify_vars p1_vs p2_vs =
+    let vars vs = List.map (fun {pv_id; _} -> pv_id) vs in
+    match p1_vs, p2_vs with
+      | {pv_id = x1; pv_type = t1; _}::rem1, {pv_id = x2; pv_type = t2; _}::rem2
+        when Ident.equal x1 x2 ->
+          if x1==x2 then
+            unify_vars rem1 rem2
+          else begin
+            begin try
+              unify_var env (newvar ()) t1;
+              unify env t1 t2
+            with
+            | Unify trace ->
+                raise(Error(loc, env, Or_pattern_type_clash(x1, trace)))
+            end;
+          (x2,x1)::unify_vars rem1 rem2
+          end
+      | [],[] -> []
+      | {pv_id; _}::_, [] | [],{pv_id; _}::_ ->
+          raise (Error (loc, env, Orpat_vars (pv_id, [])))
+      | {pv_id = x; _}::_, {pv_id = y; _}::_ ->
+          let err =
+            if Ident.name x < Ident.name y
+            then Orpat_vars (x, vars p2_vs)
+            else Orpat_vars (y, vars p1_vs) in
+          raise (Error (loc, env, err)) in
+  unify_vars p1_vs p2_vs
+
+let rec build_as_type env p =
+  let as_ty = build_as_type_aux env p in
+  (* Cf. #1655 *)
+  List.fold_left (fun as_ty (extra, _loc, _attrs) ->
+    match extra with
+    | Tpat_type _ | Tpat_open _ | Tpat_unpack -> as_ty
+    | Tpat_constraint cty ->
+      (* [generic_instance] can only be used if the variables of the original
+         type ([cty.ctyp_type] here) are not at [generic_level], which they are
+         here.
+         If we used [generic_instance] we would lose the sharing between
+         [instance ty] and [ty].  *)
+      begin_def ();
+      let ty = instance cty.ctyp_type in
+      end_def ();
+      generalize_structure ty;
+      (* This call to unify can't fail since the pattern is well typed. *)
+      unify !env (instance as_ty) (instance ty);
+      ty
+  ) as_ty p.pat_extra
+
+and build_as_type_aux env p =
+  match p.pat_desc with
+    Tpat_alias(p1,_, _) -> build_as_type env p1
+  | Tpat_tuple pl ->
+      let tyl = List.map (build_as_type env) pl in
+      newty (Ttuple tyl)
+  | Tpat_construct(_, cstr, pl, vto) ->
+      let keep =
+        cstr.cstr_private = Private || cstr.cstr_existentials <> [] ||
+        vto <> None (* be lazy and keep the type for node constraints *) in
+      if keep then p.pat_type else
+      let tyl = List.map (build_as_type env) pl in
+      let ty_args, ty_res, _ = instance_constructor cstr in
+      List.iter2 (fun (p,ty) -> unify_pat env {p with pat_type = ty})
+        (List.combine pl tyl) ty_args;
+      ty_res
+  | Tpat_variant(l, p', _) ->
+      let ty = Option.map (build_as_type env) p' in
+      newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar();
+                      row_bound=(); row_name=None;
+                      row_fixed=None; row_closed=false})
+  | Tpat_record (lpl,_) ->
+      let lbl = snd3 (List.hd lpl) in
+      if lbl.lbl_private = Private then p.pat_type else
+      let ty = newvar () in
+      let ppl = List.map (fun (_, l, p) -> l.lbl_pos, p) lpl in
+      let do_label lbl =
+        let _, ty_arg, ty_res = instance_label false lbl in
+        unify_pat env {p with pat_type = ty} ty_res;
+        let refinable =
+          lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl &&
+          match (repr lbl.lbl_arg).desc with Tpoly _ -> false | _ -> true in
+        if refinable then begin
+          let arg = List.assoc lbl.lbl_pos ppl in
+          unify_pat env {arg with pat_type = build_as_type env arg} ty_arg
+        end else begin
+          let _, ty_arg', ty_res' = instance_label false lbl in
+          unify !env ty_arg ty_arg';
+          unify_pat env p ty_res'
+        end in
+      Array.iter do_label lbl.lbl_all;
+      ty
+  | Tpat_or(p1, p2, row) ->
+      begin match row with
+        None ->
+          let ty1 = build_as_type env p1 and ty2 = build_as_type env p2 in
+          unify_pat env {p2 with pat_type = ty2} ty1;
+          ty1
+      | Some row ->
+          let row = row_repr row in
+          newty (Tvariant{row with row_closed=false; row_more=newvar()})
+      end
+  | Tpat_any | Tpat_var _ | Tpat_constant _
+  | Tpat_array _ | Tpat_lazy _ -> p.pat_type
+
+(* Constraint solving during typing of patterns *)
+
+let solve_Ppat_poly_constraint ~refine env loc sty expected_ty =
+  let cty, ty, force = Typetexp.transl_simple_type_delayed !env sty in
+  unify_pat_types ~refine loc env ty (instance expected_ty);
+  pattern_force := force :: !pattern_force;
+  match ty.desc with
+  | Tpoly (body, tyl) ->
+      begin_def ();
+      init_def generic_level;
+      let _, ty' = instance_poly ~keep_names:true false tyl body in
+      end_def ();
+      (cty, ty, ty')
+  | _ -> assert false
+
+let solve_Ppat_alias env pat =
+  begin_def ();
+  let ty_var = build_as_type env pat in
+  end_def ();
+  generalize ty_var;
+  ty_var
+
+let solve_Ppat_tuple (type a) ~refine loc env (args : a list) expected_ty =
+  let vars = List.map (fun _ -> newgenvar ()) args in
+  let ty = newgenty (Ttuple vars) in
+  let expected_ty = generic_instance expected_ty in
+  unify_pat_types ~refine loc env ty expected_ty;
+  vars
+
+let solve_constructor_annotation env name_list sty ty_args ty_ex =
+  let expansion_scope = get_gadt_equations_level () in
+  let ids =
+    List.map
+      (fun name ->
+        let decl = new_local_type ~loc:name.loc () in
+        let (id, new_env) =
+          Env.enter_type ~scope:expansion_scope name.txt decl !env in
+        env := new_env;
+        {name with txt = id})
+      name_list
+  in
+  begin_def ();
+  let cty, ty, force = Typetexp.transl_simple_type_delayed !env sty in
+  end_def ();
+  generalize_structure ty;
+  pattern_force := force :: !pattern_force;
+  let ty_args =
+    let ty1 = instance ty and ty2 = instance ty in
+    match ty_args with
+      [] -> assert false
+    | [ty_arg] ->
+        unify_pat_types cty.ctyp_loc env ty1 ty_arg;
+        [ty2]
+    | _ ->
+        unify_pat_types cty.ctyp_loc env ty1 (newty (Ttuple ty_args));
+        match repr (expand_head !env ty2) with
+          {desc = Ttuple tyl} -> tyl
+        | _ -> assert false
+  in
+  if ids <> [] then ignore begin
+    let ids = List.map (fun x -> x.txt) ids in
+    let rem =
+      List.fold_left
+        (fun rem tv ->
+          match repr tv with
+            {desc = Tconstr(Path.Pident id, [], _)}
+            when List.mem id rem ->
+              list_remove id rem
+          | _ ->
+              raise (Error (cty.ctyp_loc, !env,
+                            Unbound_existential (ids, ty))))
+        ids ty_ex
+    in
+    if rem <> [] then
+      raise (Error (cty.ctyp_loc, !env,
+                    Unbound_existential (ids, ty)))
+  end;
+  ty_args, Some (ids, cty)
+
+let solve_Ppat_construct ~refine env loc constr no_existentials
+        existential_styp expected_ty =
+  (* if constructor is gadt, we must verify that the expected type has the
+     correct head *)
+  if constr.cstr_generalized then
+    unify_head_only ~refine loc env (instance expected_ty) constr;
+  begin_def ();
+  let expected_ty = instance expected_ty in
+  (* PR#7214: do not use gadt unification for toplevel lets *)
+  let unify_res ty_res =
+    let refine =
+      match refine, no_existentials with
+      | None, None when constr.cstr_generalized -> Some false
+      | _ -> refine
+    in
+    unify_pat_types_return_equated_pairs ~refine loc env ty_res expected_ty
+  in
+  let expansion_scope = get_gadt_equations_level () in
+  let ty_args, ty_res, equated_types, existential_ctyp =
+    match existential_styp with
+      None ->
+        let ty_args, ty_res, _ =
+          instance_constructor ~in_pattern:(env, expansion_scope) constr in
+        ty_args, ty_res, unify_res ty_res, None
+    | Some (name_list, sty) ->
+        let in_pattern =
+          if name_list = [] then Some (env, expansion_scope) else None in
+        let ty_args, ty_res, ty_ex =
+          instance_constructor ?in_pattern constr in
+        let equated_types = unify_res ty_res in
+        let ty_args, existential_ctyp =
+          solve_constructor_annotation env name_list sty ty_args ty_ex in
+        ty_args, ty_res, equated_types, existential_ctyp
+  in
+  end_def ();
+  generalize_structure expected_ty;
+  generalize_structure ty_res;
+  List.iter generalize_structure ty_args;
+  if !Clflags.principal then begin
+    let exception Warn_only_once in
+    try
+      TypePairs.iter
+        (fun (t1, t2) () ->
+          generalize_structure t1;
+          generalize_structure t2;
+          if not (fully_generic t1 && fully_generic t2) then
+            let msg =
+              Format.asprintf
+                "typing this pattern requires considering@ %a@ and@ %a@ as \
+                equal.@,\
+                But the knowledge of these types"
+                    Printtyp.type_expr t1
+                    Printtyp.type_expr t2
+            in
+            Location.prerr_warning loc (Warnings.Not_principal msg);
+            raise Warn_only_once)
+        equated_types
+    with Warn_only_once -> ()
+  end;
+  (ty_args, existential_ctyp)
+
+let solve_Ppat_record_field ~refine loc env label label_lid record_ty =
+  begin_def ();
+  let (_, ty_arg, ty_res) = instance_label false label in
+  begin try
+    unify_pat_types ~refine loc env ty_res (instance record_ty)
+  with Error(_loc, _env, Pattern_type_clash(trace, _)) ->
+    raise(Error(label_lid.loc, !env,
+                Label_mismatch(label_lid.txt, trace)))
+  end;
+  end_def ();
+  generalize_structure ty_res;
+  generalize_structure ty_arg;
+  ty_arg
+
+let solve_Ppat_array ~refine loc env expected_ty =
+  let ty_elt = newgenvar() in
+  let expected_ty = generic_instance expected_ty in
+  unify_pat_types ~refine
+    loc env (Predef.type_array ty_elt) expected_ty;
+  ty_elt
+
+let solve_Ppat_lazy  ~refine loc env expected_ty =
+  let nv = newgenvar () in
+  unify_pat_types ~refine loc env (Predef.type_lazy_t nv)
+    (generic_instance expected_ty);
+  nv
+
+let solve_Ppat_constraint ~refine loc env sty expected_ty =
+  begin_def();
+  let cty, ty, force = Typetexp.transl_simple_type_delayed !env sty in
+  end_def();
+  pattern_force := force :: !pattern_force;
+  generalize_structure ty;
+  let ty, expected_ty' = instance ty, ty in
+  unify_pat_types ~refine loc env ty (instance expected_ty);
+  (cty, ty, expected_ty')
+
+let solve_Ppat_variant ~refine loc env tag constant expected_ty =
+  let arg_type = if constant then [] else [newgenvar()] in
+  let row = { row_fields =
+              [tag, Reither(constant, arg_type, true, ref None)];
+              row_bound = ();
+              row_closed = false;
+              row_more = newgenvar ();
+              row_fixed = None;
+              row_name = None } in
+  let expected_ty = generic_instance expected_ty in
+  (* PR#7404: allow some_private_tag blindly, as it would not unify with
+     the abstract row variable *)
+  if tag <> Parmatch.some_private_tag then
+    unify_pat_types ~refine loc env (newgenty(Tvariant row)) expected_ty;
+  (arg_type, row, instance expected_ty)
+
+(* Building the or-pattern corresponding to a polymorphic variant type *)
+let build_or_pat env loc lid =
+  let path, decl = Env.lookup_type ~loc:lid.loc lid.txt env in
+  let tyl = List.map (fun _ -> newvar()) decl.type_params in
+  let row0 =
+    let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in
+    match ty.desc with
+      Tvariant row when static_row row -> row
+    | _ -> raise(Error(lid.loc, env, Not_a_variant_type lid.txt))
+  in
+  let pats, fields =
+    List.fold_left
+      (fun (pats,fields) (l,f) ->
+        match row_field_repr f with
+          Rpresent None ->
+            (l,None) :: pats,
+            (l, Reither(true,[], true, ref None)) :: fields
+        | Rpresent (Some ty) ->
+            (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env;
+                      pat_type=ty; pat_extra=[]; pat_attributes=[]})
+            :: pats,
+            (l, Reither(false, [ty], true, ref None)) :: fields
+        | _ -> pats, fields)
+      ([],[]) (row_repr row0).row_fields in
+  let row =
+    { row_fields = List.rev fields; row_more = newvar(); row_bound = ();
+      row_closed = false; row_fixed = None; row_name = Some (path, tyl) }
+  in
+  let ty = newty (Tvariant row) in
+  let gloc = {loc with Location.loc_ghost=true} in
+  let row' = ref {row with row_more=newvar()} in
+  let pats =
+    List.map
+      (fun (l,p) ->
+        {pat_desc=Tpat_variant(l,p,row'); pat_loc=gloc;
+         pat_env=env; pat_type=ty; pat_extra=[]; pat_attributes=[]})
+      pats
+  in
+  match pats with
+    [] ->
+      (* empty polymorphic variants: not possible with the concrete language
+         but valid at the ast level *)
+      raise(Error(lid.loc, env, Not_a_variant_type lid.txt))
+  | pat :: pats ->
+      let r =
+        List.fold_left
+          (fun pat pat0 ->
+            {pat_desc=Tpat_or(pat0,pat,Some row0); pat_extra=[];
+             pat_loc=gloc; pat_env=env; pat_type=ty; pat_attributes=[]})
+          pat pats in
+      (path, rp { r with pat_loc = loc })
+
+let split_cases env cases =
+  let add_case lst case = function
+    | None -> lst
+    | Some c_lhs -> { case with c_lhs } :: lst
+  in
+  List.fold_right (fun ({ c_lhs; c_guard } as case) (vals, exns) ->
+    match split_pattern c_lhs with
+    | Some _, Some _ when c_guard <> None ->
+      raise (Error (c_lhs.pat_loc, env,
+                    Mixed_value_and_exception_patterns_under_guard))
+    | vp, ep -> add_case vals case vp, add_case exns case ep
+  ) cases ([], [])
+
+(* Type paths *)
+
+let rec expand_path env p =
+  let decl =
+    try Some (Env.find_type p env) with Not_found -> None
+  in
+  match decl with
+    Some {type_manifest = Some ty} ->
+      begin match repr ty with
+        {desc=Tconstr(p,_,_)} -> expand_path env p
+      | _ -> assert false
+      end
+  | _ ->
+      let p' = Env.normalize_type_path None env p in
+      if Path.same p p' then p else expand_path env p'
+
+let compare_type_path env tpath1 tpath2 =
+  Path.same (expand_path env tpath1) (expand_path env tpath2)
+
+(* Records *)
+exception Wrong_name_disambiguation of Env.t * wrong_name
+
+let get_constr_type_path ty =
+  match (repr ty).desc with
+  | Tconstr(p, _, _) -> p
+  | _ -> assert false
+
+module NameChoice(Name : sig
+  type t
+  type usage
+  val kind: Datatype_kind.t
+  val get_name: t -> string
+  val get_type: t -> type_expr
+  val lookup_all_from_type:
+    Location.t -> usage -> Path.t -> Env.t -> (t * (unit -> unit)) list
+
+  (** Some names (for example the fields of inline records) are not
+      in the typing environment -- they behave as structural labels
+      rather than nominal labels.*)
+  val in_env: t -> bool
+end) = struct
+  open Name
+
+  let get_type_path d = get_constr_type_path (get_type d)
+
+  let lookup_from_type env type_path usage lid =
+    let descrs = lookup_all_from_type lid.loc usage type_path env in
+    match lid.txt with
+    | Longident.Lident name -> begin
+        match
+          List.find (fun (nd, _) -> get_name nd = name) descrs
+        with
+        | descr, use ->
+            use ();
+            descr
+        | exception Not_found ->
+            let valid_names = List.map (fun (nd, _) -> get_name nd) descrs in
+            raise (Wrong_name_disambiguation (env, {
+                    type_path;
+                    name = { lid with txt = name };
+                    kind;
+                    valid_names;
+              }))
+      end
+    | _ -> raise Not_found
+
+  let rec unique eq acc = function
+      [] -> List.rev acc
+    | x :: rem ->
+        if List.exists (eq x) acc then unique eq acc rem
+        else unique eq (x :: acc) rem
+
+  let ambiguous_types env lbl others =
+    let tpath = get_type_path lbl in
+    let others =
+      List.map (fun (lbl, _) -> get_type_path lbl) others in
+    let tpaths = unique (compare_type_path env) [tpath] others in
+    match tpaths with
+      [_] -> []
+    | _ -> let open Printtyp in
+        wrap_printing_env ~error:true env (fun () ->
+            reset(); strings_of_paths Type tpaths)
+
+  let disambiguate_by_type env tpath lbls =
+    match lbls with
+    | (Error _ : _ result) -> raise Not_found
+    | Ok lbls ->
+        let check_type (lbl, _) =
+          let lbl_tpath = get_type_path lbl in
+          compare_type_path env tpath lbl_tpath
+        in
+        List.find check_type lbls
+
+  (* warn if there are several distinct candidates in scope *)
+  let warn_if_ambiguous warn lid env lbl rest =
+    Printtyp.Conflicts.reset ();
+    let paths = ambiguous_types env lbl rest in
+    let expansion =
+      Format.asprintf "%t" Printtyp.Conflicts.print_explanations in
+    if paths <> [] then
+      warn lid.loc
+        (Warnings.Ambiguous_name ([Longident.last lid.txt],
+                                  paths, false, expansion))
+
+  (* a non-principal type was used for disambiguation *)
+  let warn_non_principal warn lid =
+    let name = Datatype_kind.label_name kind in
+    warn lid.loc
+      (Warnings.Not_principal
+         ("this type-based " ^ name ^ " disambiguation"))
+
+  (* we selected a name out of the lexical scope *)
+  let warn_out_of_scope warn lid env tpath =
+    let path_s =
+      Printtyp.wrap_printing_env ~error:true env
+        (fun () -> Printtyp.string_of_path tpath) in
+    warn lid.loc
+      (Warnings.Name_out_of_scope (path_s, [Longident.last lid.txt], false))
+
+  (* warn if the selected name is not the last introduced in scope
+     -- in these cases the resolution is different from pre-disambiguation OCaml
+     (this warning is not enabled by default, it is specifically for people
+      wishing to write backward-compatible code).
+   *)
+  let warn_if_disambiguated_name warn lid lbl scope =
+    match scope with
+    | Ok ((lab1,_) :: _) when lab1 == lbl -> ()
+    | _ ->
+        warn lid.loc
+          (Warnings.Disambiguated_name (get_name lbl))
+
+  let force_error : ('a, _) result -> 'a = function
+    | Ok lbls -> lbls
+    | Error (loc', env', err) ->
+       Env.lookup_error loc' env' err
+
+  type candidate = t * (unit -> unit)
+  type nonempty_candidate_filter =
+    candidate list -> (candidate list, candidate list) result
+  (** This type is used for candidate filtering functions.
+      Filtering typically proceeds in several passes, filtering
+      candidates through increasingly precise conditions.
+
+      We assume that the input list is non-empty, and the output is one of
+      - [Ok result] for a non-empty list [result] of valid candidates
+      - [Error candidates] with there are no valid candidates,
+        and [candidates] is a non-empty subset of the input, typically
+        the result of the last non-empty filtering step.
+   *)
+
+  (** [disambiguate] selects a concrete description for [lid] using
+     some contextual information:
+     - An optional [expected_type].
+     - A list of candidates labels in the current lexical scope,
+       [candidates_in_scope], that is actually at the type
+       [(label_descr list, lookup_error) result] so that the
+       lookup error is only raised when necessary.
+     - A filtering criterion on candidates in scope [filter_candidates],
+       representing extra contextual information that can help
+       candidate selection (see [disambiguate_label_by_ids]).
+   *)
+  let disambiguate
+        ?(warn=Location.prerr_warning)
+        ?(filter : nonempty_candidate_filter = Result.ok)
+        usage lid env
+        expected_type
+        candidates_in_scope =
+    let lbl = match expected_type with
+    | None ->
+        (* no expected type => no disambiguation *)
+        begin match filter (force_error candidates_in_scope) with
+        | Ok [] | Error [] -> assert false
+        | Error((lbl, _use) :: _rest) -> lbl (* will fail later *)
+        | Ok((lbl, use) :: rest) ->
+            use ();
+            warn_if_ambiguous warn lid env lbl rest;
+            lbl
+        end
+    | Some(tpath0, tpath, principal) ->
+       (* If [expected_type] is available, the candidate selected
+          will correspond to the type-based resolution.
+          There are two reasons to still check the lexical scope:
+          - for warning purposes
+          - for extension types, the type environment does not contain
+            a list of constructors, so using only type-based selection
+            would fail.
+        *)
+        (* note that [disambiguate_by_type] does not
+           force [candidates_in_scope]: we just skip this case if there
+           are no candidates in scope *)
+        begin match disambiguate_by_type env tpath candidates_in_scope with
+        | lbl, use ->
+          use ();
+          if not principal then begin
+            (* Check if non-principal type is affecting result *)
+            match (candidates_in_scope : _ result) with
+            | Error _ -> warn_non_principal warn lid
+            | Ok lbls ->
+            match filter lbls with
+            | Error _ -> warn_non_principal warn lid
+            | Ok [] -> assert false
+            | Ok ((lbl', _use') :: rest) ->
+            let lbl_tpath = get_type_path lbl' in
+            (* no principality warning if the non-principal
+               type-based selection corresponds to the last
+               definition in scope *)
+            if not (compare_type_path env tpath lbl_tpath)
+            then warn_non_principal warn lid
+            else warn_if_ambiguous warn lid env lbl rest;
+          end;
+          lbl
+        | exception Not_found ->
+        (* look outside the lexical scope *)
+        match lookup_from_type env tpath usage lid with
+        | lbl ->
+          (* warn only on nominal labels;
+             structural labels cannot be qualified anyway *)
+          if in_env lbl then warn_out_of_scope warn lid env tpath;
+          if not principal then warn_non_principal warn lid;
+          lbl
+        | exception Not_found ->
+        match filter (force_error candidates_in_scope) with
+        | Ok lbls | Error lbls ->
+        let tp = (tpath0, expand_path env tpath) in
+        let tpl =
+          List.map
+            (fun (lbl, _) ->
+               let tp0 = get_type_path lbl in
+               let tp = expand_path env tp0 in
+               (tp0, tp))
+            lbls
+        in
+        raise (Error (lid.loc, env,
+                      Name_type_mismatch (kind, lid.txt, tp, tpl)));
+        end
+    in
+    (* warn only on nominal labels *)
+    if in_env lbl then
+      warn_if_disambiguated_name warn lid lbl candidates_in_scope;
+    lbl
+end
+
+let wrap_disambiguate msg ty f x =
+  try f x with
+  | Wrong_name_disambiguation (env, wrong_name) ->
+    raise (Error (wrong_name.name.loc, env, Wrong_name (msg, ty, wrong_name)))
+
+module Label = NameChoice (struct
+  type t = label_description
+  type usage = Env.label_usage
+  let kind = Datatype_kind.Record
+  let get_name lbl = lbl.lbl_name
+  let get_type lbl = lbl.lbl_res
+  let lookup_all_from_type loc usage path env =
+    Env.lookup_all_labels_from_type ~loc usage path env
+  let in_env lbl =
+    match lbl.lbl_repres with
+    | Record_regular | Record_float | Record_unboxed false -> true
+    | Record_unboxed true | Record_inlined _ | Record_extension _ -> false
+end)
+
+(* In record-construction expressions and patterns, we have many labels
+   at once; find a candidate type in the intersection of the candidates
+   of each label. In the [closed] expression case, this candidate must
+   contain exactly all the labels.
+
+   If our successive refinements result in an empty list,
+   return [Error] with the last non-empty list of candidates
+   for use in error messages.
+*)
+let disambiguate_label_by_ids closed ids labels  : (_, _) result =
+  let check_ids (lbl, _) =
+    let lbls = Hashtbl.create 8 in
+    Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl.lbl_all;
+    List.for_all (Hashtbl.mem lbls) ids
+  and check_closed (lbl, _) =
+    (not closed || List.length ids = Array.length lbl.lbl_all)
+  in
+  match List.filter check_ids labels with
+  | [] -> Error labels
+  | labels ->
+  match List.filter check_closed labels with
+  | [] -> Error labels
+  | labels ->
+  Ok labels
+
+(* Only issue warnings once per record constructor/pattern *)
+let disambiguate_lid_a_list loc closed env usage expected_type lid_a_list =
+  let ids = List.map (fun (lid, _) -> Longident.last lid.txt) lid_a_list in
+  let w_pr = ref false and w_amb = ref []
+  and w_scope = ref [] and w_scope_ty = ref "" in
+  let warn loc msg =
+    let open Warnings in
+    match msg with
+    | Not_principal _ -> w_pr := true
+    | Ambiguous_name([s], l, _, ex) -> w_amb := (s, l, ex) :: !w_amb
+    | Name_out_of_scope(ty, [s], _) ->
+        w_scope := s :: !w_scope; w_scope_ty := ty
+    | _ -> Location.prerr_warning loc msg
+  in
+  let process_label lid =
+    let scope = Env.lookup_all_labels ~loc:lid.loc usage lid.txt env in
+    let filter : Label.nonempty_candidate_filter =
+      disambiguate_label_by_ids closed ids in
+    Label.disambiguate ~warn ~filter usage lid env expected_type scope in
+  let lbl_a_list =
+    List.map (fun (lid,a) -> lid, process_label lid, a) lid_a_list in
+  if !w_pr then
+    Location.prerr_warning loc
+      (Warnings.Not_principal "this type-based record disambiguation")
+  else begin
+    match List.rev !w_amb with
+      (_,types,ex)::_ as amb ->
+        let paths =
+          List.map (fun (_,lbl,_) -> Label.get_type_path lbl) lbl_a_list in
+        let path = List.hd paths in
+        let fst3 (x,_,_) = x in
+        if List.for_all (compare_type_path env path) (List.tl paths) then
+          Location.prerr_warning loc
+            (Warnings.Ambiguous_name (List.map fst3 amb, types, true, ex))
+        else
+          List.iter
+            (fun (s,l,ex) -> Location.prerr_warning loc
+                (Warnings.Ambiguous_name ([s],l,false, ex)))
+            amb
+    | _ -> ()
+  end;
+  if !w_scope <> [] then
+    Location.prerr_warning loc
+      (Warnings.Name_out_of_scope (!w_scope_ty, List.rev !w_scope, true));
+  lbl_a_list
+
+let rec find_record_qual = function
+  | [] -> None
+  | ({ txt = Longident.Ldot (modname, _) }, _) :: _ -> Some modname
+  | _ :: rest -> find_record_qual rest
+
+let map_fold_cont f xs k =
+  List.fold_right (fun x k ys -> f x (fun y -> k (y :: ys)))
+    xs (fun ys -> k (List.rev ys)) []
+
+let type_label_a_list
+      ?labels loc closed env usage type_lbl_a expected_type lid_a_list k =
+  let lbl_a_list =
+    match lid_a_list, labels with
+      ({txt=Longident.Lident s}, _)::_, Some labels when Hashtbl.mem labels s ->
+        (* Special case for rebuilt syntax trees *)
+        List.map
+          (function lid, a -> match lid.txt with
+            Longident.Lident s -> lid, Hashtbl.find labels s, a
+          | _ -> assert false)
+          lid_a_list
+    | _ ->
+        let lid_a_list =
+          match find_record_qual lid_a_list with
+            None -> lid_a_list
+          | Some modname ->
+              List.map
+                (fun (lid, a as lid_a) ->
+                  match lid.txt with Longident.Lident s ->
+                    {lid with txt=Longident.Ldot (modname, s)}, a
+                  | _ -> lid_a)
+                lid_a_list
+        in
+        disambiguate_lid_a_list loc closed env usage expected_type lid_a_list
+  in
+  (* Invariant: records are sorted in the typed tree *)
+  let lbl_a_list =
+    List.sort
+      (fun (_,lbl1,_) (_,lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos)
+      lbl_a_list
+  in
+  map_fold_cont type_lbl_a lbl_a_list k
+;;
+
+(* Checks over the labels mentioned in a record pattern:
+   no duplicate definitions (error); properly closed (warning) *)
+
+let check_recordpat_labels loc lbl_pat_list closed =
+  match lbl_pat_list with
+  | [] -> ()                            (* should not happen *)
+  | (_, label1, _) :: _ ->
+      let all = label1.lbl_all in
+      let defined = Array.make (Array.length all) false in
+      let check_defined (_, label, _) =
+        if defined.(label.lbl_pos)
+        then raise(Error(loc, Env.empty, Label_multiply_defined label.lbl_name))
+        else defined.(label.lbl_pos) <- true in
+      List.iter check_defined lbl_pat_list;
+      if closed = Closed
+      && Warnings.is_active (Warnings.Missing_record_field_pattern "")
+      then begin
+        let undefined = ref [] in
+        for i = 0 to Array.length all - 1 do
+          if not defined.(i) then undefined := all.(i).lbl_name :: !undefined
+        done;
+        if !undefined <> [] then begin
+          let u = String.concat ", " (List.rev !undefined) in
+          Location.prerr_warning loc (Warnings.Missing_record_field_pattern u)
+        end
+      end
+
+(* Constructors *)
+
+module Constructor = NameChoice (struct
+  type t = constructor_description
+  type usage = Env.constructor_usage
+  let kind = Datatype_kind.Variant
+  let get_name cstr = cstr.cstr_name
+  let get_type cstr = cstr.cstr_res
+  let lookup_all_from_type loc usage path env =
+    match Env.lookup_all_constructors_from_type ~loc usage path env with
+    | _ :: _ as x -> x
+    | [] ->
+        match (Env.find_type path env).type_kind with
+        | Type_open ->
+            (* Extension constructors cannot be found by looking at the type
+               declaration.
+               We scan the whole environment to get an accurate spellchecking
+               hint in the subsequent error message *)
+            let filter lbl =
+              compare_type_path env
+                path (get_constr_type_path @@ get_type lbl) in
+            let add_valid x acc = if filter x then (x,ignore)::acc else acc in
+            Env.fold_constructors add_valid None env []
+        | _ -> []
+  let in_env _ = true
+end)
+
+(* Typing of patterns *)
+
+(* "half typed" cases are produced in [type_cases] when we've just typechecked
+   the pattern but haven't type-checked the body yet.
+   At this point we might have added some type equalities to the environment,
+   but haven't yet added identifiers bound by the pattern. *)
+type 'case_pattern half_typed_case =
+  { typed_pat: 'case_pattern;
+    pat_type_for_unif: type_expr;
+    untyped_case: Parsetree.case;
+    branch_env: Env.t;
+    pat_vars: pattern_variable list;
+    unpacks: module_variable list;
+    contains_gadt: bool; }
+
+let rec has_literal_pattern p = match p.ppat_desc with
+  | Ppat_constant _
+  | Ppat_interval _ ->
+     true
+  | Ppat_any
+  | Ppat_variant (_, None)
+  | Ppat_construct (_, None)
+  | Ppat_type _
+  | Ppat_var _
+  | Ppat_unpack _
+  | Ppat_extension _ ->
+     false
+  | Ppat_exception p
+  | Ppat_variant (_, Some p)
+  | Ppat_construct (_, Some (_, p))
+  | Ppat_constraint (p, _)
+  | Ppat_alias (p, _)
+  | Ppat_lazy p
+  | Ppat_open (_, p) ->
+     has_literal_pattern p
+  | Ppat_tuple ps
+  | Ppat_array ps ->
+     List.exists has_literal_pattern ps
+  | Ppat_record (ps, _) ->
+     List.exists (fun (_,p) -> has_literal_pattern p) ps
+  | Ppat_or (p, q) ->
+     has_literal_pattern p || has_literal_pattern q
+
+let check_scope_escape loc env level ty =
+  try Ctype.check_scope_escape env level ty
+  with Escape trace ->
+    raise(Error(loc, env, Pattern_type_clash([Escape trace], None)))
+
+type pattern_checking_mode =
+  | Normal
+  (** We are checking user code. *)
+  | Counter_example of counter_example_checking_info
+  (** In [Counter_example] mode, we are checking a counter-example
+      candidate produced by Parmatch. This is a syntactic pattern that
+      represents a set of values by using or-patterns (p_1 | ... | p_n)
+      to enumerate all alternatives in the counter-example
+      search. These or-patterns occur at every choice point, possibly
+      deep inside the pattern.
+
+      Parmatch does not use type information, so this pattern may
+      exhibit two issues:
+      - some parts of the pattern may be ill-typed due to GADTs, and
+      - some wildcard patterns may not match any values: their type is
+        empty.
+
+      The aim of [type_pat] in the [Counter_example] mode is to refine
+      this syntactic pattern into a well-typed pattern, and ensure
+      that it matches at least one concrete value.
+      - It filters ill-typed branches of or-patterns.
+        (see {!splitting_mode} below)
+      - It tries to check that wildcard patterns are non-empty.
+        (see {!explosion_fuel})
+  *)
+
+and counter_example_checking_info = {
+    explosion_fuel: int;
+    splitting_mode: splitting_mode;
+    constrs: (string, Types.constructor_description) Hashtbl.t;
+    labels: (string, Types.label_description) Hashtbl.t;
+  }
+(**
+    [explosion_fuel] controls the checking of wildcard patterns.  We
+    eliminate potentially-empty wildcard patterns by exploding them
+    into concrete sub-patterns, for example (K1 _ | K2 _) or
+    { l1: _; l2: _ }. [explosion_fuel] is the depth limit on wildcard
+    explosion. Such depth limit is required to avoid non-termination
+    and compilation-time blowups.
+
+    [splitting_mode] controls the handling of or-patterns.  In
+    [Counter_example] mode, we only need to select one branch that
+    leads to a well-typed pattern. Checking all branches is expensive,
+    we use different search strategies (see {!splitting_mode}) to
+    reduce the number of explored alternatives.
+
+    [constrs] and [labels] contain metadata produced by [Parmatch] to
+    type-check the given syntactic pattern. [Parmatch] produces
+    counter-examples by turning typed patterns into
+    [Parsetree.pattern]. In this process, constructor and label paths
+    are lost, and are replaced by generated strings. [constrs] and
+    [labels] map those synthetic names back to the typed descriptions
+    of the original names.
+ *)
+
+(** Due to GADT constraints, an or-pattern produced within
+    a counter-example may have ill-typed branches. Consider for example
+
+    {[
+      type _ tag = Int : int tag | Bool : bool tag
+    ]}
+
+    then [Parmatch] will propose the or-pattern [Int | Bool] whenever
+    a pattern of type [tag] is required to form a counter-example. For
+    example, a function expects a (int tag option) and only [None] is
+    handled by the user-written pattern. [Some (Int | Bool)] is not
+    well-typed in this context, only the sub-pattern [Some Int] is.
+    In this example, the expected type coming from the context
+    suffices to know which or-pattern branch must be chosen.
+
+    In the general case, choosing a branch can have non-local effects
+    on the typability of the term. For example, consider a tuple type
+    ['a tag * ...'a...], where the first component is a GADT.  All
+    constructor choices for this GADT lead to a well-typed branch in
+    isolation (['a] is unconstrained), but choosing one of them adds
+    a constraint on ['a] that may make the other tuple elements
+    ill-typed.
+
+    In general, after choosing each possible branch of the or-pattern,
+    [type_pat] has to check the rest of the pattern to tell if this
+    choice leads to a well-typed term. This may lead to an explosion
+    of typing/search work -- the rest of the term may in turn contain
+    alternatives.
+
+    We use careful strategies to try to limit counterexample-checking
+    time; [splitting_mode] represents those strategies.
+*)
+and splitting_mode =
+  | Backtrack_or
+  (** Always backtrack in or-patterns.
+
+      [Backtrack_or] selects a single alternative from an or-pattern
+      by using backtracking, trying to choose each branch in turn, and
+      to complete it into a valid sub-pattern. We call this
+      "splitting" the or-pattern.
+
+      We use this mode when looking for unused patterns or sub-patterns,
+      in particular to check a refutation clause (p -> .).
+    *)
+  | Refine_or of { inside_nonsplit_or: bool; }
+  (** Only backtrack when needed.
+
+      [Refine_or] tries another approach for refining or-pattern.
+
+      Instead of always splitting each or-pattern, It first attempts to
+      find branches that do not introduce new constraints (because they
+      do not contain GADT constructors). Those branches are such that,
+      if they fail, all other branches will fail.
+
+      If we find one such branch, we attempt to complete the subpattern
+      (checking what's outside the or-pattern), ignoring other
+      branches -- we never consider another branch choice again. If all
+      branches are constrained, it falls back to splitting the
+      or-pattern.
+
+      We use this mode when checking exhaustivity of pattern matching.
+  *)
+
+(** This exception is only used internally within [type_pat_aux], in
+    counter-example mode, to jump back to the parent or-pattern in the
+    [Refine_or] strategy.
+
+    Such a parent exists precisely when [inside_nonsplit_or = true];
+    it's an invariant that we always setup an exception handler for
+    [Need_backtrack] when we set this flag. *)
+exception Need_backtrack
+
+(** This exception is only used internally within [type_pat_aux], in
+    counter-example mode. We use it to discard counter-example candidates
+    that do not match any value. *)
+exception Empty_branch
+
+type abort_reason = Adds_constraints | Empty
+
+(** Remember current typing state for backtracking.
+   No variable information, as we only backtrack on
+   patterns without variables (cf. assert statements). *)
+type state =
+ { snapshot: Btype.snapshot;
+   levels: Ctype.levels;
+   env: Env.t; }
+let save_state env =
+  { snapshot = Btype.snapshot ();
+    levels = Ctype.save_levels ();
+    env = !env; }
+let set_state s env =
+  Btype.backtrack s.snapshot;
+  Ctype.set_levels s.levels;
+  env := s.env
+
+(** Find the first alternative in the tree of or-patterns for which
+   [f] does not raise an error. If all fail, the last error is
+   propagated *)
+let rec find_valid_alternative f pat =
+  match pat.ppat_desc with
+  | Ppat_or(p1,p2) ->
+      (try find_valid_alternative f p1 with
+       | Empty_branch | Error _ -> find_valid_alternative f p2
+      )
+  | _ -> f pat
+
+let no_explosion = function
+  | Normal -> Normal
+  | Counter_example info ->
+     Counter_example { info with explosion_fuel = 0 }
+
+let get_splitting_mode = function
+  | Normal -> None
+  | Counter_example {splitting_mode} -> Some splitting_mode
+
+let enter_nonsplit_or mode = match mode with
+  | Normal -> Normal
+  | Counter_example info ->
+     let splitting_mode = match info.splitting_mode with
+       | Backtrack_or ->
+          (* in Backtrack_or mode, or-patterns are always split *)
+          assert false
+       | Refine_or _ ->
+          Refine_or {inside_nonsplit_or = true}
+     in Counter_example { info with splitting_mode }
+
+(** The typedtree has two distinct syntactic categories for patterns,
+   "value" patterns, matching on values, and "computation" patterns
+   that match on the effect of a computation -- typically, exception
+   patterns (exception p).
+
+   On the other hand, the parsetree has an unstructured representation
+   where all categories of patterns are mixed together. The
+   decomposition according to the value/computation structure has to
+   happen during type-checking.
+
+   We don't want to duplicate the type-checking logic in two different
+   functions, depending on the kind of pattern to be produced. In
+   particular, there are both value and computation or-patterns, and
+   the type-checking logic for or-patterns is horribly complex; having
+   it in two different places would be twice as horirble.
+
+   The solution is to pass a GADT tag to [type_pat] to indicate whether
+   a value or computation pattern is expected. This way, there is a single
+   place where [Ppat_or] nodes are type-checked, the checking logic is shared,
+   and only at the end do we inspect the tag to decide to produce a value
+   or computation pattern.
+*)
+let pure
+  : type k . k pattern_category -> value general_pattern -> k general_pattern
+  = fun category pat ->
+  match category with
+  | Value -> pat
+  | Computation -> as_computation_pattern pat
+
+let only_impure
+  : type k . k pattern_category ->
+             computation general_pattern -> k general_pattern
+  = fun category pat ->
+  match category with
+  | Value ->
+     (* LATER: this exception could be renamed/generalized *)
+     raise (Error (pat.pat_loc, pat.pat_env,
+                   Exception_pattern_disallowed))
+  | Computation -> pat
+
+let as_comp_pattern
+  : type k . k pattern_category ->
+             k general_pattern -> computation general_pattern
+  = fun category pat ->
+  match category with
+  | Value -> as_computation_pattern pat
+  | Computation -> pat
+
+(* type_pat propagates the expected type.
+   Unification may update the typing environment.
+
+   In counter-example mode, [Empty_branch] is raised when the counter-example
+   does not match any value.  *)
+let rec type_pat
+  : type k r . k pattern_category ->
+      no_existentials: existential_restriction option ->
+      mode: pattern_checking_mode -> env: Env.t ref -> Parsetree.pattern ->
+      type_expr -> (k general_pattern -> r) -> r
+  = fun category ~no_existentials ~mode
+        ~env sp expected_ty k ->
+  Builtin_attributes.warning_scope sp.ppat_attributes
+    (fun () ->
+       type_pat_aux category ~no_existentials ~mode
+         ~env sp expected_ty k
+    )
+
+and type_pat_aux
+  : type k r . k pattern_category -> no_existentials:_ -> mode:_ ->
+         env:_ -> _ -> _ -> (k general_pattern -> r) -> r
+  = fun category ~no_existentials ~mode
+      ~env sp expected_ty k ->
+  let type_pat category ?(mode=mode) ?(env=env) =
+    type_pat category ~no_existentials ~mode ~env
+  in
+  let loc = sp.ppat_loc in
+  let refine =
+    match mode with Normal -> None | Counter_example _ -> Some true in
+  let solve_expected (x : pattern) : pattern =
+    unify_pat ~refine env x (instance expected_ty);
+    x
+  in
+  let rp x =
+    let crp (x : k general_pattern) : k general_pattern =
+      match category with
+      | Value -> rp x
+      | Computation -> rcp x in
+    if mode = Normal then crp x else x in
+  let rp k x = k (rp x)
+  and rvp k x = k (rp (pure category x))
+  and rcp k x = k (rp (only_impure category x)) in
+  let construction_not_used_in_counterexamples = (mode = Normal) in
+  let must_backtrack_on_gadt = match get_splitting_mode mode with
+    | None -> false
+    | Some Backtrack_or -> false
+    | Some (Refine_or {inside_nonsplit_or}) -> inside_nonsplit_or
+  in
+  match sp.ppat_desc with
+    Ppat_any ->
+      let k' d = rvp k {
+        pat_desc = d;
+        pat_loc = loc; pat_extra=[];
+        pat_type = instance expected_ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env }
+      in
+      begin match mode with
+      | Normal -> k' Tpat_any
+      | Counter_example {explosion_fuel; _} when explosion_fuel <= 0 ->
+          k' Tpat_any
+      | Counter_example ({explosion_fuel; _} as info) ->
+         let open Parmatch in
+         begin match ppat_of_type !env expected_ty with
+         | PT_empty -> raise Empty_branch
+         | PT_any -> k' Tpat_any
+         | PT_pattern (explosion, sp, constrs, labels) ->
+            let explosion_fuel =
+              match explosion with
+              | PE_single -> explosion_fuel - 1
+              | PE_gadt_cases ->
+                  if must_backtrack_on_gadt then raise Need_backtrack;
+                  explosion_fuel - 5
+            in
+            let mode =
+              Counter_example { info with explosion_fuel; constrs; labels }
+            in
+            type_pat category ~mode sp expected_ty k
+         end
+      end
+  | Ppat_var name ->
+      let ty = instance expected_ty in
+      let id = (* PR#7330 *)
+        if name.txt = "*extension*" then
+          Ident.create_local name.txt
+        else
+          enter_variable loc name ty sp.ppat_attributes
+      in
+      rvp k {
+        pat_desc = Tpat_var (id, name);
+        pat_loc = loc; pat_extra=[];
+        pat_type = ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env }
+  | Ppat_unpack name ->
+      assert construction_not_used_in_counterexamples;
+      let t = instance expected_ty in
+      begin match name.txt with
+      | None ->
+          rvp k {
+            pat_desc = Tpat_any;
+            pat_loc = sp.ppat_loc;
+            pat_extra=[Tpat_unpack, name.loc, sp.ppat_attributes];
+            pat_type = t;
+            pat_attributes = [];
+            pat_env = !env }
+      | Some s ->
+          let v = { name with txt = s } in
+          let id = enter_variable loc v t ~is_module:true sp.ppat_attributes in
+          rvp k {
+            pat_desc = Tpat_var (id, v);
+            pat_loc = sp.ppat_loc;
+            pat_extra=[Tpat_unpack, loc, sp.ppat_attributes];
+            pat_type = t;
+            pat_attributes = [];
+            pat_env = !env }
+      end
+  | Ppat_constraint(
+      {ppat_desc=Ppat_var name; ppat_loc=lloc; ppat_attributes = attrs},
+      ({ptyp_desc=Ptyp_poly _} as sty)) ->
+      (* explicitly polymorphic type *)
+      assert construction_not_used_in_counterexamples;
+      let cty, ty, ty' =
+        solve_Ppat_poly_constraint ~refine env lloc sty expected_ty in
+      let id = enter_variable lloc name ty' attrs in
+      rvp k { pat_desc = Tpat_var (id, name);
+              pat_loc = lloc;
+              pat_extra = [Tpat_constraint cty, loc, sp.ppat_attributes];
+              pat_type = ty;
+              pat_attributes = [];
+              pat_env = !env }
+  | Ppat_alias(sq, name) ->
+      assert construction_not_used_in_counterexamples;
+      type_pat Value sq expected_ty (fun q ->
+        let ty_var = solve_Ppat_alias env q in
+        let id =
+          enter_variable ~is_as_variable:true loc name ty_var sp.ppat_attributes
+        in
+        rvp k {
+          pat_desc = Tpat_alias(q, id, name);
+          pat_loc = loc; pat_extra=[];
+          pat_type = q.pat_type;
+          pat_attributes = sp.ppat_attributes;
+          pat_env = !env })
+  | Ppat_constant cst ->
+      let cst = constant_or_raise !env loc cst in
+      rvp k @@ solve_expected {
+        pat_desc = Tpat_constant cst;
+        pat_loc = loc; pat_extra=[];
+        pat_type = type_constant cst;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env }
+  | Ppat_interval (Pconst_char c1, Pconst_char c2) ->
+      let open Ast_helper.Pat in
+      let gloc = {loc with Location.loc_ghost=true} in
+      let rec loop c1 c2 =
+        if c1 = c2 then constant ~loc:gloc (Pconst_char c1)
+        else
+          or_ ~loc:gloc
+            (constant ~loc:gloc (Pconst_char c1))
+            (loop (Char.chr(Char.code c1 + 1)) c2)
+      in
+      let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in
+      let p = {p with ppat_loc=loc} in
+      type_pat category ~mode:(no_explosion mode) p expected_ty k
+        (* TODO: record 'extra' to remember about interval *)
+  | Ppat_interval _ ->
+      raise (Error (loc, !env, Invalid_interval))
+  | Ppat_tuple spl ->
+      assert (List.length spl >= 2);
+      let expected_tys = solve_Ppat_tuple ~refine loc env spl expected_ty in
+      let spl_ann = List.combine spl expected_tys in
+      map_fold_cont (fun (p,t) -> type_pat Value p t) spl_ann (fun pl ->
+        rvp k {
+        pat_desc = Tpat_tuple pl;
+        pat_loc = loc; pat_extra=[];
+        pat_type = newty (Ttuple(List.map (fun p -> p.pat_type) pl));
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env })
+  | Ppat_construct(lid, sarg) ->
+      let expected_type =
+        try
+          let (p0, p, _) = extract_concrete_variant !env expected_ty in
+          let principal =
+            (repr expected_ty).level = generic_level || not !Clflags.principal
+          in
+            Some (p0, p, principal)
+        with Not_found -> None
+      in
+      let constr =
+        match lid.txt, mode with
+        | Longident.Lident s, Counter_example {constrs; _} ->
+           (* assert: cf. {!counter_example_checking_info} documentation *)
+            assert (Hashtbl.mem constrs s);
+            Hashtbl.find constrs s
+        | _ ->
+        let candidates =
+          Env.lookup_all_constructors Env.Pattern ~loc:lid.loc lid.txt !env in
+        wrap_disambiguate "This variant pattern is expected to have"
+          (mk_expected expected_ty)
+          (Constructor.disambiguate Env.Pattern lid !env expected_type)
+          candidates
+      in
+      if constr.cstr_generalized && must_backtrack_on_gadt then
+        raise Need_backtrack;
+      begin match no_existentials, constr.cstr_existentials with
+      | None, _ | _, [] -> ()
+      | Some r, (_ :: _ as exs)  ->
+          let exs = List.map (Ctype.existential_name constr) exs in
+          let name = constr.cstr_name in
+          raise (Error (loc, !env, Unexpected_existential (r, name, exs)))
+      end;
+      let sarg', existential_styp =
+        match sarg with
+          None -> None, None
+        | Some (vl, {ppat_desc = Ppat_constraint (sp, sty)})
+          when vl <> [] || constr.cstr_arity > 1 ->
+            Some sp, Some (vl, sty)
+        | Some ([], sp) ->
+            Some sp, None
+        | Some (_, sp) ->
+            raise (Error (sp.ppat_loc, !env, Missing_type_constraint))
+      in
+      let sargs =
+        match sarg' with
+          None -> []
+        | Some {ppat_desc = Ppat_tuple spl} when
+            constr.cstr_arity > 1 ||
+            Builtin_attributes.explicit_arity sp.ppat_attributes
+          -> spl
+        | Some({ppat_desc = Ppat_any} as sp) when
+            constr.cstr_arity = 0 && existential_styp = None
+          ->
+            Location.prerr_warning sp.ppat_loc
+              Warnings.Wildcard_arg_to_constant_constr;
+            []
+        | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity > 1 ->
+            replicate_list sp constr.cstr_arity
+        | Some sp -> [sp] in
+      if Builtin_attributes.warn_on_literal_pattern constr.cstr_attributes then
+        begin match List.filter has_literal_pattern sargs with
+        | sp :: _ ->
+           Location.prerr_warning sp.ppat_loc Warnings.Fragile_literal_pattern
+        | _ -> ()
+        end;
+      if List.length sargs <> constr.cstr_arity then
+        raise(Error(loc, !env, Constructor_arity_mismatch(lid.txt,
+                                     constr.cstr_arity, List.length sargs)));
+
+      let (ty_args, existential_ctyp) =
+        solve_Ppat_construct ~refine env loc constr no_existentials
+          existential_styp expected_ty
+      in
+
+      let rec check_non_escaping p =
+        match p.ppat_desc with
+        | Ppat_or (p1, p2) ->
+            check_non_escaping p1;
+            check_non_escaping p2
+        | Ppat_alias (p, _) ->
+            check_non_escaping p
+        | Ppat_constraint _ ->
+            raise (Error (p.ppat_loc, !env, Inlined_record_escape))
+        | _ ->
+            ()
+      in
+      if constr.cstr_inlined <> None then begin
+        List.iter check_non_escaping sargs;
+        Option.iter (fun (_, sarg) -> check_non_escaping sarg) sarg
+      end;
+
+      map_fold_cont
+        (fun (p,t) -> type_pat Value p t)
+        (List.combine sargs ty_args)
+        (fun args ->
+          rvp k {
+            pat_desc=Tpat_construct(lid, constr, args, existential_ctyp);
+            pat_loc = loc; pat_extra=[];
+            pat_type = instance expected_ty;
+            pat_attributes = sp.ppat_attributes;
+            pat_env = !env })
+  | Ppat_variant(tag, sarg) ->
+      if tag = Parmatch.some_private_tag then
+        assert (match mode with Normal -> false | Counter_example _ -> true);
+      let constant = (sarg = None) in
+      let arg_type, row, pat_type =
+        solve_Ppat_variant ~refine loc env tag constant expected_ty in
+      let k arg =
+        rvp k {
+        pat_desc = Tpat_variant(tag, arg, ref {row with row_more = newvar()});
+        pat_loc = loc; pat_extra = [];
+        pat_type = pat_type;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env }
+      in begin
+        (* PR#6235: propagate type information *)
+        match sarg, arg_type with
+          Some p, [ty] -> type_pat Value p ty (fun p -> k (Some p))
+        | _            -> k None
+      end
+  | Ppat_record(lid_sp_list, closed) ->
+      assert (lid_sp_list <> []);
+      let expected_type, record_ty =
+        try
+          let (p0, p,_) = extract_concrete_record !env expected_ty in
+          let ty = generic_instance expected_ty in
+          let principal =
+            (repr expected_ty).level = generic_level || not !Clflags.principal
+          in
+          Some (p0, p, principal), ty
+        with Not_found -> None, newvar ()
+      in
+      let type_label_pat (label_lid, label, sarg) k =
+        let ty_arg =
+          solve_Ppat_record_field ~refine loc env label label_lid record_ty in
+        type_pat Value sarg ty_arg (fun arg ->
+          k (label_lid, label, arg))
+      in
+      let make_record_pat lbl_pat_list =
+        check_recordpat_labels loc lbl_pat_list closed;
+        {
+          pat_desc = Tpat_record (lbl_pat_list, closed);
+          pat_loc = loc; pat_extra=[];
+          pat_type = instance record_ty;
+          pat_attributes = sp.ppat_attributes;
+          pat_env = !env;
+        }
+      in
+      let k' pat = rvp k @@ solve_expected pat in
+      begin match mode with
+      | Normal ->
+          k' (wrap_disambiguate "This record pattern is expected to have"
+               (mk_expected expected_ty)
+               (type_label_a_list loc false !env Env.Projection
+                  type_label_pat expected_type lid_sp_list)
+               make_record_pat)
+      | Counter_example {labels; _} ->
+          type_label_a_list ~labels loc false !env Env.Projection
+            type_label_pat expected_type lid_sp_list
+            (fun lbl_pat_list -> k' (make_record_pat lbl_pat_list))
+      end
+  | Ppat_array spl ->
+      let ty_elt = solve_Ppat_array ~refine loc env expected_ty in
+      map_fold_cont (fun p -> type_pat Value p ty_elt) spl (fun pl ->
+        rvp k {
+        pat_desc = Tpat_array pl;
+        pat_loc = loc; pat_extra=[];
+        pat_type = instance expected_ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env })
+  | Ppat_or(sp1, sp2) ->
+      begin match mode with
+      | Normal ->
+          let initial_pattern_variables = !pattern_variables in
+          let initial_module_variables = !module_variables in
+          let equation_level = !gadt_equations_level in
+          let outter_lev = get_current_level () in
+          (* introduce a new scope *)
+          begin_def ();
+          let lev = get_current_level () in
+          gadt_equations_level := Some lev;
+          let type_pat_rec env sp =
+            type_pat category sp expected_ty ~env (fun x -> x) in
+          let env1 = ref !env in
+          let p1 = type_pat_rec env1 sp1 in
+          let p1_variables = !pattern_variables in
+          let p1_module_variables = !module_variables in
+          pattern_variables := initial_pattern_variables;
+          module_variables := initial_module_variables;
+          let env2 = ref !env in
+          let p2 = type_pat_rec env2 sp2 in
+          end_def ();
+          gadt_equations_level := equation_level;
+          let p2_variables = !pattern_variables in
+          (* Make sure no variable with an ambiguous type gets added to the
+             environment. *)
+          List.iter (fun { pv_type; pv_loc; _ } ->
+            check_scope_escape pv_loc !env1 outter_lev pv_type
+          ) p1_variables;
+          List.iter (fun { pv_type; pv_loc; _ } ->
+            check_scope_escape pv_loc !env2 outter_lev pv_type
+          ) p2_variables;
+          let alpha_env =
+            enter_orpat_variables loc !env p1_variables p2_variables in
+          let p2 = alpha_pat alpha_env p2 in
+          pattern_variables := p1_variables;
+          module_variables := p1_module_variables;
+          rp k { pat_desc = Tpat_or (p1, p2, None);
+                 pat_loc = loc; pat_extra = [];
+                 pat_type = instance expected_ty;
+                 pat_attributes = sp.ppat_attributes;
+                 pat_env = !env }
+      | Counter_example {splitting_mode; _} ->
+          (* We are in counter-example mode, but try to avoid backtracking *)
+          let must_split =
+            match splitting_mode with
+            | Backtrack_or -> true
+            | Refine_or _ -> false in
+          let state = save_state env in
+          let split_or sp =
+            let typ pat = type_pat category pat expected_ty k in
+            find_valid_alternative (fun pat -> set_state state env; typ pat) sp
+          in
+          if must_split then split_or sp else
+          let type_pat_result env sp : (_, abort_reason) result =
+            let mode = enter_nonsplit_or mode in
+            match type_pat category ~mode sp expected_ty ~env (fun x -> x) with
+            | res -> Ok res
+            | exception Need_backtrack -> Error Adds_constraints
+            | exception Empty_branch -> Error Empty
+          in
+          let p1 = type_pat_result (ref !env) sp1 in
+          let p2 = type_pat_result (ref !env) sp2 in
+          match p1, p2 with
+          | Error Empty, Error Empty ->
+              raise Empty_branch
+          | Error Adds_constraints, Error _
+          | Error _, Error Adds_constraints ->
+              let inside_nonsplit_or =
+                match splitting_mode with
+                | Backtrack_or -> false
+                | Refine_or {inside_nonsplit_or} -> inside_nonsplit_or in
+              if inside_nonsplit_or
+              then raise Need_backtrack
+              else split_or sp
+          | Ok p, Error _
+          | Error _, Ok p ->
+              rp k p
+          | Ok p1, Ok p2 ->
+              rp k { pat_desc = Tpat_or (p1, p2, None);
+                     pat_loc = loc; pat_extra = [];
+                     pat_type = instance expected_ty;
+                     pat_attributes = sp.ppat_attributes;
+                     pat_env = !env }
+      end
+  | Ppat_lazy sp1 ->
+      let nv = solve_Ppat_lazy ~refine loc env expected_ty in
+      (* do not explode under lazy: PR#7421 *)
+      type_pat Value ~mode:(no_explosion mode) sp1 nv (fun p1 ->
+        rvp k {
+        pat_desc = Tpat_lazy p1;
+        pat_loc = loc; pat_extra=[];
+        pat_type = instance expected_ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env })
+  | Ppat_constraint(sp, sty) ->
+      assert construction_not_used_in_counterexamples;
+      (* Pretend separate = true *)
+      let cty, ty, expected_ty' =
+        solve_Ppat_constraint ~refine loc env sty expected_ty in
+      type_pat category sp expected_ty' (fun p ->
+        (*Format.printf "%a@.%a@."
+          Printtyp.raw_type_expr ty
+          Printtyp.raw_type_expr p.pat_type;*)
+        let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in
+        let p : k general_pattern =
+          match category, (p : k general_pattern) with
+          | Value, {pat_desc = Tpat_var (id,s); _} ->
+            {p with
+              pat_type = ty;
+              pat_desc =
+                Tpat_alias
+                  ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s);
+              pat_extra = [extra];
+            }
+          | _, p ->
+             { p with pat_type = ty; pat_extra = extra::p.pat_extra }
+        in k p)
+  | Ppat_type lid ->
+      assert construction_not_used_in_counterexamples;
+      let (path, p) = build_or_pat !env loc lid in
+      k @@ pure category @@ solve_expected
+        { p with pat_extra = (Tpat_type (path, lid), loc, sp.ppat_attributes)
+        :: p.pat_extra }
+  | Ppat_open (lid,p) ->
+      assert construction_not_used_in_counterexamples;
+      let path, new_env =
+        !type_open Asttypes.Fresh !env sp.ppat_loc lid in
+      env := new_env;
+      type_pat category ~env p expected_ty ( fun p ->
+        let new_env = !env in
+        begin match Env.remove_last_open path new_env with
+        | None -> assert false
+        | Some closed_env -> env := closed_env
+        end;
+        k { p with pat_extra = (Tpat_open (path,lid,new_env),
+                                loc, sp.ppat_attributes) :: p.pat_extra }
+      )
+  | Ppat_exception p ->
+      type_pat Value p Predef.type_exn (fun p_exn ->
+      rcp k {
+        pat_desc = Tpat_exception p_exn;
+        pat_loc = sp.ppat_loc;
+        pat_extra = [];
+        pat_type = expected_ty;
+        pat_env = !env;
+        pat_attributes = sp.ppat_attributes;
+      })
+  | Ppat_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+let type_pat category ?no_existentials ?(mode=Normal)
+    ?(lev=get_current_level()) env sp expected_ty =
+  Misc.protect_refs [Misc.R (gadt_equations_level, Some lev)] (fun () ->
+        type_pat category ~no_existentials ~mode
+          ~env sp expected_ty (fun x -> x)
+    )
+
+(* this function is passed to Partial.parmatch
+   to type check gadt nonexhaustiveness *)
+let partial_pred ~lev ~splitting_mode ?(explode=0)
+      env expected_ty constrs labels p =
+  let env = ref env in
+  let state = save_state env in
+  let mode =
+    Counter_example {
+        splitting_mode;
+        explosion_fuel = explode;
+        constrs; labels;
+      } in
+  try
+    reset_pattern true;
+    let typed_p = type_pat Value ~lev ~mode env p expected_ty in
+    set_state state env;
+    (* types are invalidated but we don't need them here *)
+    Some typed_p
+  with Error _ | Empty_branch ->
+    set_state state env;
+    None
+
+let check_partial ?(lev=get_current_level ()) env expected_ty loc cases =
+  let explode = match cases with [_] -> 5 | _ -> 0 in
+  let splitting_mode = Refine_or {inside_nonsplit_or = false} in
+  Parmatch.check_partial
+    (partial_pred ~lev ~splitting_mode ~explode env expected_ty) loc cases
+
+let check_unused ?(lev=get_current_level ()) env expected_ty cases =
+  Parmatch.check_unused
+    (fun refute constrs labels spat ->
+      match
+        partial_pred ~lev ~splitting_mode:Backtrack_or ~explode:5
+          env expected_ty constrs labels spat
+      with
+        Some pat when refute ->
+          raise (Error (spat.ppat_loc, env, Unrefuted_pattern pat))
+      | r -> r)
+    cases
+
+let iter_pattern_variables_type f : pattern_variable list -> unit =
+  List.iter (fun {pv_type; _} -> f pv_type)
+
+let add_pattern_variables ?check ?check_as env pv =
+  List.fold_right
+    (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} env ->
+       let check = if pv_as_var then check_as else check in
+       Env.add_value ?check pv_id
+         {val_type = pv_type; val_kind = Val_reg; Types.val_loc = pv_loc;
+          val_attributes = pv_attributes;
+          val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+         } env
+    )
+    pv env
+
+let type_pattern category ~lev env spat expected_ty =
+  reset_pattern true;
+  let new_env = ref env in
+  let pat = type_pat category ~lev new_env spat expected_ty in
+  let pvs = get_ref pattern_variables in
+  let unpacks = get_ref module_variables in
+  (pat, !new_env, get_ref pattern_force, pvs, unpacks)
+
+let type_pattern_list
+    category no_existentials env spatl expected_tys allow
+  =
+  reset_pattern allow;
+  let new_env = ref env in
+  let type_pat (attrs, pat) ty =
+    Builtin_attributes.warning_scope ~ppwarning:false attrs
+      (fun () ->
+         type_pat category ~no_existentials new_env pat ty
+      )
+  in
+  let patl = List.map2 type_pat spatl expected_tys in
+  let pvs = get_ref pattern_variables in
+  let unpacks =
+    List.map (fun (name, loc) ->
+      {tu_name = name; tu_loc = loc;
+       tu_uid = Uid.mk ~current_unit:(Env.get_unit_name ())}
+    ) (get_ref module_variables)
+  in
+  let new_env = add_pattern_variables !new_env pvs in
+  (patl, new_env, get_ref pattern_force, pvs, unpacks)
+
+let type_class_arg_pattern cl_num val_env met_env l spat =
+  reset_pattern false;
+  let nv = newvar () in
+  let pat =
+    type_pat Value ~no_existentials:In_class_args (ref val_env) spat nv in
+  if has_variants pat then begin
+    Parmatch.pressure_variants val_env [pat];
+    finalize_variants pat;
+  end;
+  List.iter (fun f -> f()) (get_ref pattern_force);
+  if is_optional l then unify_pat (ref val_env) pat (type_option (newvar ()));
+  let (pv, val_env, met_env) =
+    List.fold_right
+      (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes}
+        (pv, val_env, met_env) ->
+         let check s =
+           if pv_as_var then Warnings.Unused_var s
+           else Warnings.Unused_var_strict s in
+         let id' = Ident.rename pv_id in
+         let val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in
+         let val_env =
+          Env.add_value pv_id
+            { val_type = pv_type
+            ; val_kind = Val_reg
+            ; val_attributes = pv_attributes
+            ; val_loc = pv_loc
+            ; val_uid
+            }
+            val_env
+         in
+         let met_env =
+          Env.add_value id' ~check
+            { val_type = pv_type
+            ; val_kind = Val_ivar (Immutable, cl_num)
+            ; val_attributes = pv_attributes
+            ; val_loc = pv_loc
+            ; val_uid
+            }
+            met_env
+         in
+         ((id', pv_id, pv_type)::pv, val_env, met_env))
+      !pattern_variables ([], val_env, met_env)
+  in
+  (pat, pv, val_env, met_env)
+
+let type_self_pattern cl_num privty val_env met_env par_env spat =
+  let open Ast_helper in
+  let spat =
+    Pat.mk (Ppat_alias (Pat.mk(Ppat_alias (spat, mknoloc "selfpat-*")),
+                        mknoloc ("selfpat-" ^ cl_num)))
+  in
+  reset_pattern false;
+  let nv = newvar() in
+  let pat =
+    type_pat Value ~no_existentials:In_self_pattern (ref val_env) spat nv in
+  List.iter (fun f -> f()) (get_ref pattern_force);
+  let meths = ref Meths.empty in
+  let vars = ref Vars.empty in
+  let pv = !pattern_variables in
+  pattern_variables := [];
+  let (val_env, met_env, par_env) =
+    List.fold_right
+      (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes}
+           (val_env, met_env, par_env) ->
+         let name = Ident.name pv_id in
+         (Env.enter_unbound_value name Val_unbound_self val_env,
+          Env.add_value pv_id
+            {val_type = pv_type;
+             val_kind = Val_self (meths, vars, cl_num, privty);
+             val_attributes = pv_attributes;
+             val_loc = pv_loc;
+             val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+            }
+            ~check:(fun s -> if pv_as_var then Warnings.Unused_var s
+                             else Warnings.Unused_var_strict s)
+            met_env,
+          Env.enter_unbound_value name Val_unbound_self par_env))
+      pv (val_env, met_env, par_env)
+  in
+  (pat, meths, vars, val_env, met_env, par_env)
+
+let delayed_checks = ref []
+let reset_delayed_checks () = delayed_checks := []
+let add_delayed_check f =
+  delayed_checks := (f, Warnings.backup ()) :: !delayed_checks
+
+let force_delayed_checks () =
+  (* checks may change type levels *)
+  let snap = Btype.snapshot () in
+  let w_old = Warnings.backup () in
+  List.iter
+    (fun (f, w) -> Warnings.restore w; f ())
+    (List.rev !delayed_checks);
+  Warnings.restore w_old;
+  reset_delayed_checks ();
+  Btype.backtrack snap
+
+let rec final_subexpression exp =
+  match exp.exp_desc with
+    Texp_let (_, _, e)
+  | Texp_sequence (_, e)
+  | Texp_try (e, _)
+  | Texp_ifthenelse (_, e, _)
+  | Texp_match (_, {c_rhs=e} :: _, _)
+  | Texp_letmodule (_, _, _, _, e)
+  | Texp_letexception (_, e)
+  | Texp_open (_, e)
+    -> final_subexpression e
+  | _ -> exp
+
+(* Generalization criterion for expressions *)
+
+let rec is_nonexpansive exp =
+  match exp.exp_desc with
+  | Texp_ident _
+  | Texp_constant _
+  | Texp_unreachable
+  | Texp_function _
+  | Texp_array [] -> true
+  | Texp_let(_rec_flag, pat_exp_list, body) ->
+      List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list &&
+      is_nonexpansive body
+  | Texp_apply(e, (_,None)::el) ->
+      is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd el)
+  | Texp_match(e, cases, _) ->
+     (* Not sure this is necessary, if [e] is nonexpansive then we shouldn't
+         care if there are exception patterns. But the previous version enforced
+         that there be none, so... *)
+      let contains_exception_pat pat =
+        exists_general_pattern { f = fun (type k) (p : k general_pattern) ->
+          match p.pat_desc with
+          | Tpat_exception _ -> true
+          | _ -> false } pat
+      in
+      is_nonexpansive e &&
+      List.for_all
+        (fun {c_lhs; c_guard; c_rhs} ->
+           is_nonexpansive_opt c_guard && is_nonexpansive c_rhs
+           && not (contains_exception_pat c_lhs)
+        ) cases
+  | Texp_tuple el ->
+      List.for_all is_nonexpansive el
+  | Texp_construct( _, _, el) ->
+      List.for_all is_nonexpansive el
+  | Texp_variant(_, arg) -> is_nonexpansive_opt arg
+  | Texp_record { fields; extended_expression } ->
+      Array.for_all
+        (fun (lbl, definition) ->
+           match definition with
+           | Overridden (_, exp) ->
+               lbl.lbl_mut = Immutable && is_nonexpansive exp
+           | Kept _ -> true)
+        fields
+      && is_nonexpansive_opt extended_expression
+  | Texp_field(exp, _, _) -> is_nonexpansive exp
+  | Texp_ifthenelse(_cond, ifso, ifnot) ->
+      is_nonexpansive ifso && is_nonexpansive_opt ifnot
+  | Texp_sequence (_e1, e2) -> is_nonexpansive e2  (* PR#4354 *)
+  | Texp_new (_, _, cl_decl) -> Ctype.class_type_arity cl_decl.cty_type > 0
+  (* Note: nonexpansive only means no _observable_ side effects *)
+  | Texp_lazy e -> is_nonexpansive e
+  | Texp_object ({cstr_fields=fields; cstr_type = { csig_vars=vars}}, _) ->
+      let count = ref 0 in
+      List.for_all
+        (fun field -> match field.cf_desc with
+            Tcf_method _ -> true
+          | Tcf_val (_, _, _, Tcfk_concrete (_, e), _) ->
+              incr count; is_nonexpansive e
+          | Tcf_val (_, _, _, Tcfk_virtual _, _) ->
+              incr count; true
+          | Tcf_initializer e -> is_nonexpansive e
+          | Tcf_constraint _ -> true
+          | Tcf_inherit _ -> false
+          | Tcf_attribute _ -> true)
+        fields &&
+      Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable)
+        vars true &&
+      !count = 0
+  | Texp_letmodule (_, _, _, mexp, e)
+  | Texp_open ({ open_expr = mexp; _}, e) ->
+      is_nonexpansive_mod mexp && is_nonexpansive e
+  | Texp_pack mexp ->
+      is_nonexpansive_mod mexp
+  (* Computations which raise exceptions are nonexpansive, since (raise e) is
+     equivalent to (raise e; diverge), and a nonexpansive "diverge" can be
+     produced using lazy values or the relaxed value restriction.
+     See GPR#1142 *)
+  | Texp_assert exp ->
+      is_nonexpansive exp
+  | Texp_apply (
+      { exp_desc = Texp_ident (_, _, {val_kind =
+             Val_prim {Primitive.prim_name =
+                         ("%raise" | "%reraise" | "%raise_notrace")}}) },
+      [Nolabel, Some e]) ->
+     is_nonexpansive e
+  | Texp_array (_ :: _)
+  | Texp_apply _
+  | Texp_try _
+  | Texp_setfield _
+  | Texp_while _
+  | Texp_for _
+  | Texp_send _
+  | Texp_instvar _
+  | Texp_setinstvar _
+  | Texp_override _
+  | Texp_letexception _
+  | Texp_letop _
+  | Texp_extension_constructor _ ->
+    false
+
+and is_nonexpansive_mod mexp =
+  match mexp.mod_desc with
+  | Tmod_ident _
+  | Tmod_functor _ -> true
+  | Tmod_unpack (e, _) -> is_nonexpansive e
+  | Tmod_constraint (m, _, _, _) -> is_nonexpansive_mod m
+  | Tmod_structure str ->
+      List.for_all
+        (fun item -> match item.str_desc with
+          | Tstr_eval _ | Tstr_primitive _ | Tstr_type _
+          | Tstr_modtype _ | Tstr_class_type _  -> true
+          | Tstr_value (_, pat_exp_list) ->
+              List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list
+          | Tstr_module {mb_expr=m;_}
+          | Tstr_open {open_expr=m;_}
+          | Tstr_include {incl_mod=m;_} -> is_nonexpansive_mod m
+          | Tstr_recmodule id_mod_list ->
+              List.for_all (fun {mb_expr=m;_} -> is_nonexpansive_mod m)
+                id_mod_list
+          | Tstr_exception {tyexn_constructor = {ext_kind = Text_decl _}} ->
+              false (* true would be unsound *)
+          | Tstr_exception {tyexn_constructor = {ext_kind = Text_rebind _}} ->
+              true
+          | Tstr_typext te ->
+              List.for_all
+                (function {ext_kind = Text_decl _} -> false
+                        | {ext_kind = Text_rebind _} -> true)
+                te.tyext_constructors
+          | Tstr_class _ -> false (* could be more precise *)
+          | Tstr_attribute _ -> true
+        )
+        str.str_items
+  | Tmod_apply _ -> false
+
+and is_nonexpansive_opt = function
+  | None -> true
+  | Some e -> is_nonexpansive e
+
+let maybe_expansive e = not (is_nonexpansive e)
+
+let check_recursive_bindings env valbinds =
+  let ids = let_bound_idents valbinds in
+  List.iter
+    (fun {vb_expr} ->
+       if not (Rec_check.is_valid_recursive_expression ids vb_expr) then
+         raise(Error(vb_expr.exp_loc, env, Illegal_letrec_expr))
+    )
+    valbinds
+
+let check_recursive_class_bindings env ids exprs =
+  List.iter
+    (fun expr ->
+       if not (Rec_check.is_valid_class_expr ids expr) then
+         raise(Error(expr.cl_loc, env, Illegal_class_expr)))
+    exprs
+
+let is_prim ~name funct =
+  match funct.exp_desc with
+  | Texp_ident (_, _, {val_kind=Val_prim{Primitive.prim_name; _}}) ->
+      prim_name = name
+  | _ -> false
+(* Approximate the type of an expression, for better recursion *)
+
+let rec approx_type env sty =
+  match sty.ptyp_desc with
+    Ptyp_arrow (p, _, sty) ->
+      let ty1 = if is_optional p then type_option (newvar ()) else newvar () in
+      newty (Tarrow (p, ty1, approx_type env sty, Cok))
+  | Ptyp_tuple args ->
+      newty (Ttuple (List.map (approx_type env) args))
+  | Ptyp_constr (lid, ctl) ->
+      let path, decl = Env.lookup_type ~use:false ~loc:lid.loc lid.txt env in
+      if List.length ctl <> decl.type_arity then newvar ()
+      else begin
+        let tyl = List.map (approx_type env) ctl in
+        newconstr path tyl
+      end
+  | Ptyp_poly (_, sty) ->
+      approx_type env sty
+  | _ -> newvar ()
+
+let rec type_approx env sexp =
+  match sexp.pexp_desc with
+    Pexp_let (_, _, e) -> type_approx env e
+  | Pexp_fun (p, _, _, e) ->
+      let ty = if is_optional p then type_option (newvar ()) else newvar () in
+      newty (Tarrow(p, ty, type_approx env e, Cok))
+  | Pexp_function ({pc_rhs=e}::_) ->
+      newty (Tarrow(Nolabel, newvar (), type_approx env e, Cok))
+  | Pexp_match (_, {pc_rhs=e}::_) -> type_approx env e
+  | Pexp_try (e, _) -> type_approx env e
+  | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l))
+  | Pexp_ifthenelse (_,e,_) -> type_approx env e
+  | Pexp_sequence (_,e) -> type_approx env e
+  | Pexp_constraint (e, sty) ->
+      let ty = type_approx env e in
+      let ty1 = approx_type env sty in
+      begin try unify env ty ty1 with Unify trace ->
+        raise(Error(sexp.pexp_loc, env, Expr_type_clash (trace, None, None)))
+      end;
+      ty1
+  | Pexp_coerce (e, sty1, sty2) ->
+      let approx_ty_opt = function
+        | None -> newvar ()
+        | Some sty -> approx_type env sty
+      in
+      let ty = type_approx env e
+      and ty1 = approx_ty_opt sty1
+      and ty2 = approx_type env sty2 in
+      begin try unify env ty ty1 with Unify trace ->
+        raise(Error(sexp.pexp_loc, env, Expr_type_clash (trace, None, None)))
+      end;
+      ty2
+  | _ -> newvar ()
+
+(* List labels in a function type, and whether return type is a variable *)
+let rec list_labels_aux env visited ls ty_fun =
+  let ty = expand_head env ty_fun in
+  if List.memq ty visited then
+    List.rev ls, false
+  else match ty.desc with
+    Tarrow (l, _, ty_res, _) ->
+      list_labels_aux env (ty::visited) (l::ls) ty_res
+  | _ ->
+      List.rev ls, is_Tvar ty
+
+let list_labels env ty =
+  wrap_trace_gadt_instances env (list_labels_aux env [] []) ty
+
+(* Check that all univars are safe in a type. Both exp.exp_type and
+   ty_expected should already be generalized. *)
+let check_univars env kind exp ty_expected vars =
+  let pty = instance ty_expected in
+  begin_def ();
+  let exp_ty, vars =
+    match pty.desc with
+      Tpoly (body, tl) ->
+        (* Enforce scoping for type_let:
+           since body is not generic,  instance_poly only makes
+           copies of nodes that have a Tvar as descendant *)
+        let _, ty' = instance_poly true tl body in
+        let vars, exp_ty = instance_parameterized_type vars exp.exp_type in
+        unify_exp_types exp.exp_loc env exp_ty ty';
+        exp_ty, vars
+    | _ -> assert false
+  in
+  end_def ();
+  generalize exp_ty;
+  List.iter generalize vars;
+  let ty, complete = polyfy env exp_ty vars in
+  if not complete then
+    let ty_expected = instance ty_expected in
+    raise (Error (exp.exp_loc, env,
+                  Less_general(kind, [Errortrace.diff ty ty_expected])))
+
+let generalize_and_check_univars env kind exp ty_expected vars =
+  generalize exp.exp_type;
+  generalize ty_expected;
+  List.iter generalize vars;
+  check_univars env kind exp ty_expected vars
+
+let check_partial_application statement exp =
+  let rec f delay =
+    let ty = (expand_head exp.exp_env exp.exp_type).desc in
+    let check_statement () =
+      match ty with
+      | Tconstr (p, _, _)  when Path.same p Predef.path_unit ->
+          ()
+      | _ ->
+          if statement then
+            let rec loop {exp_loc; exp_desc; exp_extra; _} =
+              match exp_desc with
+              | Texp_let (_, _, e)
+              | Texp_sequence (_, e)
+              | Texp_letexception (_, e)
+              | Texp_letmodule (_, _, _, _, e) ->
+                  loop e
+              | _ ->
+                  let loc =
+                    match List.find_opt (function
+                        | (Texp_constraint _, _, _) -> true
+                        | _ -> false) exp_extra
+                    with
+                    | Some (_, loc, _) -> loc
+                    | None -> exp_loc
+                  in
+                  Location.prerr_warning loc Warnings.Non_unit_statement
+            in
+            loop exp
+    in
+    match ty, exp.exp_desc with
+    | Tarrow _, _ ->
+        let rec check {exp_desc; exp_loc; exp_extra; _} =
+          if List.exists (function
+              | (Texp_constraint _, _, _) -> true
+              | _ -> false) exp_extra then check_statement ()
+          else begin
+            match exp_desc with
+            | Texp_ident _ | Texp_constant _ | Texp_tuple _
+            | Texp_construct _ | Texp_variant _ | Texp_record _
+            | Texp_field _ | Texp_setfield _ | Texp_array _
+            | Texp_while _ | Texp_for _ | Texp_instvar _
+            | Texp_setinstvar _ | Texp_override _ | Texp_assert _
+            | Texp_lazy _ | Texp_object _ | Texp_pack _ | Texp_unreachable
+            | Texp_extension_constructor _ | Texp_ifthenelse (_, _, None)
+            | Texp_function _ ->
+                check_statement ()
+            | Texp_match (_, cases, _) ->
+                List.iter (fun {c_rhs; _} -> check c_rhs) cases
+            | Texp_try (e, cases) ->
+                check e; List.iter (fun {c_rhs; _} -> check c_rhs) cases
+            | Texp_ifthenelse (_, e1, Some e2) ->
+                check e1; check e2
+            | Texp_let (_, _, e) | Texp_sequence (_, e) | Texp_open (_, e)
+            | Texp_letexception (_, e) | Texp_letmodule (_, _, _, _, e) ->
+                check e
+            | Texp_apply _ | Texp_send _ | Texp_new _ | Texp_letop _ ->
+                Location.prerr_warning exp_loc
+                  Warnings.Ignored_partial_application
+          end
+        in
+        check exp
+    | Tvar _, _ ->
+        if delay then add_delayed_check (fun () -> f false)
+    | _ ->
+        check_statement ()
+  in
+  f true
+
+(* Check that a type is generalizable at some level *)
+let generalizable level ty =
+  let rec check ty =
+    let ty = repr ty in
+    if not_marked_node ty then
+      if ty.level <= level then raise Exit else
+      (flip_mark_node ty; iter_type_expr check ty)
+  in
+  try check ty; unmark_type ty; true
+  with Exit -> unmark_type ty; false
+
+(* Hack to allow coercion of self. Will clean-up later. *)
+let self_coercion = ref ([] : (Path.t * Location.t list ref) list)
+
+(* Helpers for type_cases *)
+
+let contains_variant_either ty =
+  let rec loop ty =
+    let ty = repr ty in
+    if try_mark_node ty then
+      begin match ty.desc with
+        Tvariant row ->
+          let row = row_repr row in
+          if not (is_fixed row) then
+            List.iter
+              (fun (_,f) ->
+                match row_field_repr f with Reither _ -> raise Exit | _ -> ())
+              row.row_fields;
+          iter_row loop row
+      | _ ->
+          iter_type_expr loop ty
+      end
+  in
+  try loop ty; unmark_type ty; false
+  with Exit -> unmark_type ty; true
+
+let shallow_iter_ppat f p =
+  match p.ppat_desc with
+  | Ppat_any | Ppat_var _ | Ppat_constant _ | Ppat_interval _
+  | Ppat_construct (_, None)
+  | Ppat_extension _
+  | Ppat_type _ | Ppat_unpack _ -> ()
+  | Ppat_array pats -> List.iter f pats
+  | Ppat_or (p1,p2) -> f p1; f p2
+  | Ppat_variant (_, arg) -> Option.iter f arg
+  | Ppat_tuple lst ->  List.iter f lst
+  | Ppat_construct (_, Some (_, p))
+  | Ppat_exception p | Ppat_alias (p,_)
+  | Ppat_open (_,p)
+  | Ppat_constraint (p,_) | Ppat_lazy p -> f p
+  | Ppat_record (args, _flag) -> List.iter (fun (_,p) -> f p) args
+
+let exists_ppat f p =
+  let exception Found in
+  let rec loop p =
+    if f p then raise Found else ();
+    shallow_iter_ppat loop p in
+  match loop p with
+  | exception Found -> true
+  | () -> false
+
+let contains_polymorphic_variant p =
+  exists_ppat
+    (function
+     | {ppat_desc = (Ppat_variant _ | Ppat_type _)} -> true
+     | _ -> false)
+    p
+
+let contains_gadt p =
+  exists_general_pattern { f = fun (type k) (p : k general_pattern) ->
+     match p.pat_desc with
+     | Tpat_construct (_, cd, _, _) when cd.cstr_generalized -> true
+     | _ -> false } p
+
+(* There are various things that we need to do in presence of GADT constructors
+   that aren't required if there are none.
+   However, because of disambiguation, we can't know for sure whether the
+   patterns contain some GADT constructors. So we conservatively assume that
+   any constructor might be a GADT constructor. *)
+let may_contain_gadts p =
+  exists_ppat
+  (function
+   | {ppat_desc = Ppat_construct _} -> true
+   | _ -> false)
+  p
+
+let check_absent_variant env =
+  iter_general_pattern { f = fun (type k) (pat : k general_pattern) ->
+    match pat.pat_desc with
+    | Tpat_variant (s, arg, row) ->
+      let row = row_repr !row in
+      if List.exists (fun (s',fi) -> s = s' && row_field_repr fi <> Rabsent)
+          row.row_fields
+      || not (is_fixed row) && not (static_row row)  (* same as Ctype.poly *)
+      then () else
+      let ty_arg =
+        match arg with None -> [] | Some p -> [correct_levels p.pat_type] in
+      let row' = {row_fields = [s, Reither(arg=None,ty_arg,true,ref None)];
+                  row_more = newvar (); row_bound = ();
+                  row_closed = false; row_fixed = None; row_name = None} in
+      (* Should fail *)
+      unify_pat (ref env) {pat with pat_type = newty (Tvariant row')}
+                          (correct_levels pat.pat_type)
+    | _ -> () }
+
+(* Getting proper location of already typed expressions.
+
+   Used to avoid confusing locations on type error messages in presence of
+   type constraints.
+   For example:
+
+       (* Before patch *)
+       # let x : string = (5 : int);;
+                           ^
+       (* After patch *)
+       # let x : string = (5 : int);;
+                          ^^^^^^^^^
+*)
+let proper_exp_loc exp =
+  let rec aux = function
+    | [] -> exp.exp_loc
+    | ((Texp_constraint _ | Texp_coerce _), loc, _) :: _ -> loc
+    | _ :: rest -> aux rest
+  in
+  aux exp.exp_extra
+
+(* To find reasonable names for let-bound and lambda-bound idents *)
+
+let rec name_pattern default = function
+    [] -> Ident.create_local default
+  | p :: rem ->
+    match p.pat_desc with
+      Tpat_var (id, _) -> id
+    | Tpat_alias(_, id, _) -> id
+    | _ -> name_pattern default rem
+
+let name_cases default lst =
+  name_pattern default (List.map (fun c -> c.c_lhs) lst)
+
+(* Typing of expressions *)
+
+let unify_exp env exp expected_ty =
+  let loc = proper_exp_loc exp in
+  try
+    unify_exp_types loc env exp.exp_type expected_ty
+  with Error(loc, env, Expr_type_clash(trace, tfc, None)) ->
+    raise (Error(loc, env, Expr_type_clash(trace, tfc, Some exp.exp_desc)))
+
+(* If [is_inferred e] is true, [e] will be typechecked without using
+   the "expected type" provided by the context. *)
+
+let rec is_inferred sexp =
+  match sexp.pexp_desc with
+  | Pexp_ident _ | Pexp_apply _ | Pexp_field _ | Pexp_constraint _
+  | Pexp_coerce _ | Pexp_send _ | Pexp_new _ -> true
+  | Pexp_sequence (_, e) | Pexp_open (_, e) -> is_inferred e
+  | Pexp_ifthenelse (_, e1, Some e2) -> is_inferred e1 && is_inferred e2
+  | _ -> false
+
+(* check if the type of %apply or %revapply matches the type expected by
+   the specialized typing rule for those primitives.
+*)
+type apply_prim =
+  | Apply
+  | Revapply
+let check_apply_prim_type prim typ =
+  match (repr typ).desc with
+  | Tarrow (Nolabel,a,b,_) ->
+      begin match (repr b).desc with
+      | Tarrow(Nolabel,c,d,_) ->
+          let f, x, res =
+            match prim with
+            | Apply -> a, c, d
+            | Revapply -> c, a, d
+          in
+          let f, x, res = repr f, repr x, repr res in
+          begin match f.desc with
+          | Tarrow(Nolabel,fl,fr,_) ->
+              let fl, fr = repr fl, repr fr in
+              is_Tvar fl && is_Tvar fr && is_Tvar x && is_Tvar res
+              && fl == x && fr == res
+          | _ -> false
+          end
+      | _ -> false
+      end
+  | _ -> false
+
+(* Merge explanation to type clash error *)
+
+let with_explanation explanation f =
+  match explanation with
+  | None -> f ()
+  | Some explanation ->
+      try f ()
+      with Error (loc', env', Expr_type_clash(trace', None, exp'))
+        when not loc'.Location.loc_ghost ->
+        let err = Expr_type_clash(trace', Some explanation, exp') in
+        raise (Error (loc', env', err))
+
+let rec type_exp ?recarg env sexp =
+  (* We now delegate everything to type_expect *)
+  type_expect ?recarg env sexp (mk_expected (newvar ()))
+
+(* Typing of an expression with an expected type.
+   This provide better error messages, and allows controlled
+   propagation of return type information.
+   In the principal case, [type_expected'] may be at generic_level.
+ *)
+
+and type_expect ?in_function ?recarg env sexp ty_expected_explained =
+  let previous_saved_types = Cmt_format.get_saved_types () in
+  let exp =
+    Builtin_attributes.warning_scope sexp.pexp_attributes
+      (fun () ->
+         type_expect_ ?in_function ?recarg env sexp ty_expected_explained
+      )
+  in
+  Cmt_format.set_saved_types
+    (Cmt_format.Partial_expression exp :: previous_saved_types);
+  exp
+
+and type_expect_
+    ?in_function ?(recarg=Rejected)
+    env sexp ty_expected_explained =
+  let { ty = ty_expected; explanation } = ty_expected_explained in
+  let loc = sexp.pexp_loc in
+  (* Record the expression type before unifying it with the expected type *)
+  let with_explanation = with_explanation explanation in
+  let rue exp =
+    with_explanation (fun () ->
+      unify_exp env (re exp) (instance ty_expected));
+    exp
+  in
+  match sexp.pexp_desc with
+  | Pexp_ident lid ->
+      let path, desc = type_ident env ~recarg lid in
+      let exp_desc =
+        match desc.val_kind with
+        | Val_ivar (_, cl_num) ->
+            let (self_path, _) =
+              Env.find_value_by_name
+                (Longident.Lident ("self-" ^ cl_num)) env
+            in
+            Texp_instvar(self_path, path,
+                         match lid.txt with
+                             Longident.Lident txt -> { txt; loc = lid.loc }
+                           | _ -> assert false)
+        | Val_self (_, _, cl_num, _) ->
+            let (path, _) =
+              Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env
+            in
+            Texp_ident(path, lid, desc)
+        | _ ->
+            Texp_ident(path, lid, desc)
+      in
+      rue {
+        exp_desc; exp_loc = loc; exp_extra = [];
+        exp_type = instance desc.val_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_constant(Pconst_string (str, _, _) as cst) -> (
+    let cst = constant_or_raise env loc cst in
+    (* Terrible hack for format strings *)
+    let ty_exp = expand_head env ty_expected in
+    let fmt6_path =
+      Path.(Pdot (Pident (Ident.create_persistent "CamlinternalFormatBasics"),
+                  "format6"))
+    in
+    let is_format = match ty_exp.desc with
+      | Tconstr(path, _, _) when Path.same path fmt6_path ->
+        if !Clflags.principal && ty_exp.level <> generic_level then
+          Location.prerr_warning loc
+            (Warnings.Not_principal "this coercion to format6");
+        true
+      | _ -> false
+    in
+    if is_format then
+      let format_parsetree =
+        { (type_format loc str env) with pexp_loc = sexp.pexp_loc }  in
+      type_expect ?in_function env format_parsetree ty_expected_explained
+    else
+      rue {
+        exp_desc = Texp_constant cst;
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance Predef.type_string;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  )
+  | Pexp_constant cst ->
+      let cst = constant_or_raise env loc cst in
+      rue {
+        exp_desc = Texp_constant cst;
+        exp_loc = loc; exp_extra = [];
+        exp_type = type_constant cst;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_let(Nonrecursive,
+             [{pvb_pat=spat; pvb_expr=sval; pvb_attributes=[]}], sbody)
+    when may_contain_gadts spat ->
+    (* TODO: allow non-empty attributes? *)
+      type_expect ?in_function env
+        {sexp with
+         pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody])}
+        ty_expected_explained
+  | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
+      let existential_context =
+        if rec_flag = Recursive then In_rec
+        else if List.compare_length_with spat_sexp_list 1 > 0 then In_group
+        else With_attributes in
+      let (pat_exp_list, new_env, unpacks) =
+        type_let existential_context env rec_flag spat_sexp_list true in
+      let body = type_unpacks new_env unpacks sbody ty_expected_explained in
+      let () =
+        if rec_flag = Recursive then
+          check_recursive_bindings env pat_exp_list
+      in
+      re {
+        exp_desc = Texp_let(rec_flag, pat_exp_list, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = body.exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_fun (l, Some default, spat, sbody) ->
+      assert(is_optional l); (* default allowed only with optional argument *)
+      let open Ast_helper in
+      let default_loc = default.pexp_loc in
+      let scases = [
+        Exp.case
+          (Pat.construct ~loc:default_loc
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
+             (Some ([], Pat.var ~loc:default_loc (mknoloc "*sth*"))))
+          (Exp.ident ~loc:default_loc (mknoloc (Longident.Lident "*sth*")));
+
+        Exp.case
+          (Pat.construct ~loc:default_loc
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
+             None)
+          default;
+       ]
+      in
+      let sloc =
+        { Location.loc_start = spat.ppat_loc.Location.loc_start;
+          loc_end = default_loc.Location.loc_end;
+          loc_ghost = true }
+      in
+      let smatch =
+        Exp.match_ ~loc:sloc
+          (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*")))
+          scases
+      in
+      let pat = Pat.var ~loc:sloc (mknoloc "*opt*") in
+      let body =
+        Exp.let_ ~loc Nonrecursive
+          ~attrs:[Attr.mk (mknoloc "#default") (PStr [])]
+          [Vb.mk spat smatch] sbody
+      in
+      type_function ?in_function loc sexp.pexp_attributes env
+                    ty_expected_explained l [Exp.case pat body]
+  | Pexp_fun (l, None, spat, sbody) ->
+      type_function ?in_function loc sexp.pexp_attributes env
+                    ty_expected_explained l [Ast_helper.Exp.case spat sbody]
+  | Pexp_function caselist ->
+      type_function ?in_function
+        loc sexp.pexp_attributes env ty_expected_explained Nolabel caselist
+  | Pexp_apply(sfunct, sargs) ->
+      assert (sargs <> []);
+      let rec lower_args seen ty_fun =
+        let ty = expand_head env ty_fun in
+        if List.memq ty seen then () else
+          match ty.desc with
+            Tarrow (_l, ty_arg, ty_fun, _com) ->
+              (try unify_var env (newvar()) ty_arg
+               with Unify _ -> assert false);
+              lower_args (ty::seen) ty_fun
+          | _ -> ()
+      in
+      let type_sfunct sfunct =
+        begin_def (); (* one more level for non-returning functions *)
+        if !Clflags.principal then begin_def ();
+        let funct = type_exp env sfunct in
+        if !Clflags.principal then begin
+          end_def ();
+          generalize_structure funct.exp_type
+        end;
+        let ty = instance funct.exp_type in
+        end_def ();
+        wrap_trace_gadt_instances env (lower_args []) ty;
+        funct
+      in
+      let funct, sargs =
+        let funct = type_sfunct sfunct in
+        match funct.exp_desc, sargs with
+        | Texp_ident (_, _,
+                      {val_kind = Val_prim {prim_name="%revapply"}; val_type}),
+          [Nolabel, sarg; Nolabel, actual_sfunct]
+          when is_inferred actual_sfunct
+            && check_apply_prim_type Revapply val_type ->
+            type_sfunct actual_sfunct, [Nolabel, sarg]
+        | Texp_ident (_, _,
+                      {val_kind = Val_prim {prim_name="%apply"}; val_type}),
+          [Nolabel, actual_sfunct; Nolabel, sarg]
+          when check_apply_prim_type Apply val_type ->
+            type_sfunct actual_sfunct, [Nolabel, sarg]
+        | _ ->
+            funct, sargs
+      in
+      begin_def ();
+      let (args, ty_res) = type_application env funct sargs in
+      end_def ();
+      unify_var env (newvar()) funct.exp_type;
+      let exp =
+        { exp_desc = Texp_apply(funct, args);
+          exp_loc = loc; exp_extra = [];
+          exp_type = ty_res;
+          exp_attributes = sexp.pexp_attributes;
+          exp_env = env } in
+      begin
+        try rue exp
+        with Error (_, _, Expr_type_clash _) as err ->
+          Misc.reraise_preserving_backtrace err (fun () ->
+            check_partial_application false exp)
+      end
+  | Pexp_match(sarg, caselist) ->
+      begin_def ();
+      let arg = type_exp env sarg in
+      end_def ();
+      if maybe_expansive arg then lower_contravariant env arg.exp_type;
+      generalize arg.exp_type;
+      let cases, partial =
+        type_cases Computation env
+          arg.exp_type ty_expected_explained true loc caselist in
+      re {
+        exp_desc = Texp_match(arg, cases, partial);
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance ty_expected;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_try(sbody, caselist) ->
+      let body = type_expect env sbody ty_expected_explained in
+      let cases, _ =
+        type_cases Value env
+          Predef.type_exn ty_expected_explained false loc caselist in
+      re {
+        exp_desc = Texp_try(body, cases);
+        exp_loc = loc; exp_extra = [];
+        exp_type = body.exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_tuple sexpl ->
+      assert (List.length sexpl >= 2);
+      let subtypes = List.map (fun _ -> newgenvar ()) sexpl in
+      let to_unify = newgenty (Ttuple subtypes) in
+      with_explanation (fun () ->
+        unify_exp_types loc env to_unify (generic_instance ty_expected));
+      let expl =
+        List.map2 (fun body ty -> type_expect env body (mk_expected ty))
+          sexpl subtypes
+      in
+      re {
+        exp_desc = Texp_tuple expl;
+        exp_loc = loc; exp_extra = [];
+        (* Keep sharing *)
+        exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl));
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_construct(lid, sarg) ->
+      type_construct env loc lid sarg ty_expected_explained sexp.pexp_attributes
+  | Pexp_variant(l, sarg) ->
+      (* Keep sharing *)
+      let ty_expected0 = instance ty_expected in
+      begin try match
+        sarg, expand_head env ty_expected, expand_head env ty_expected0 with
+      | Some sarg, {desc = Tvariant row}, {desc = Tvariant row0} ->
+          let row = row_repr row and row0 = row_repr row0 in
+          begin match row_field_repr (List.assoc l row.row_fields),
+          row_field_repr (List.assoc l row0.row_fields) with
+            Rpresent (Some ty), Rpresent (Some ty0) ->
+              let arg = type_argument env sarg ty ty0 in
+              re { exp_desc = Texp_variant(l, Some arg);
+                   exp_loc = loc; exp_extra = [];
+                   exp_type = ty_expected0;
+                   exp_attributes = sexp.pexp_attributes;
+                   exp_env = env }
+          | _ -> raise Not_found
+          end
+      | _ -> raise Not_found
+      with Not_found ->
+        let arg = Option.map (type_exp env) sarg in
+        let arg_type = Option.map (fun arg -> arg.exp_type) arg in
+        rue {
+          exp_desc = Texp_variant(l, arg);
+          exp_loc = loc; exp_extra = [];
+          exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type];
+                                    row_more = newvar ();
+                                    row_bound = ();
+                                    row_closed = false;
+                                    row_fixed = None;
+                                    row_name = None});
+          exp_attributes = sexp.pexp_attributes;
+          exp_env = env }
+      end
+  | Pexp_record(lid_sexp_list, opt_sexp) ->
+      assert (lid_sexp_list <> []);
+      let opt_exp =
+        match opt_sexp with
+          None -> None
+        | Some sexp ->
+            if !Clflags.principal then begin_def ();
+            let exp = type_exp ~recarg env sexp in
+            if !Clflags.principal then begin
+              end_def ();
+              generalize_structure exp.exp_type
+            end;
+            Some exp
+      in
+      let ty_record, expected_type =
+        let get_path ty =
+          try
+            let (p0, p,_) = extract_concrete_record env ty in
+            let principal =
+              (repr ty).level = generic_level || not !Clflags.principal
+            in
+            Some (p0, p, principal)
+          with Not_found -> None
+        in
+        let opath = get_path ty_expected in
+        match opath with
+          None | Some (_, _, false) ->
+            let ty = if opath = None then newvar () else ty_expected in
+            begin match opt_exp with
+              None -> ty, opath
+            | Some exp ->
+                match get_path exp.exp_type with
+                  None ->
+                    ty, opath
+                | Some (_, p', _) as opath ->
+                    let decl = Env.find_type p' env in
+                    begin_def ();
+                    let ty =
+                      newconstr p' (instance_list decl.type_params) in
+                    end_def ();
+                    generalize_structure ty;
+                    ty, opath
+            end
+        | _ -> ty_expected, opath
+      in
+      let closed = (opt_sexp = None) in
+      let lbl_exp_list =
+        wrap_disambiguate "This record expression is expected to have"
+          (mk_expected ty_record)
+          (type_label_a_list loc closed env Env.Construct
+             (fun e k -> k (type_label_exp true env loc ty_record e))
+             expected_type lid_sexp_list)
+          (fun x -> x)
+      in
+      with_explanation (fun () ->
+        unify_exp_types loc env (instance ty_record) (instance ty_expected));
+
+      (* type_label_a_list returns a list of labels sorted by lbl_pos *)
+      (* note: check_duplicates would better be implemented in
+         type_label_a_list directly *)
+      let rec check_duplicates = function
+        | (_, lbl1, _) :: (_, lbl2, _) :: _ when lbl1.lbl_pos = lbl2.lbl_pos ->
+          raise(Error(loc, env, Label_multiply_defined lbl1.lbl_name))
+        | _ :: rem ->
+            check_duplicates rem
+        | [] -> ()
+      in
+      check_duplicates lbl_exp_list;
+      let opt_exp, label_definitions =
+        let (_lid, lbl, _lbl_exp) = List.hd lbl_exp_list in
+        let matching_label lbl =
+          List.find
+            (fun (_, lbl',_) -> lbl'.lbl_pos = lbl.lbl_pos)
+            lbl_exp_list
+        in
+        match opt_exp with
+          None ->
+            let label_definitions =
+              Array.map (fun lbl ->
+                  match matching_label lbl with
+                  | (lid, _lbl, lbl_exp) ->
+                      Overridden (lid, lbl_exp)
+                  | exception Not_found ->
+                      let present_indices =
+                        List.map (fun (_, lbl, _) -> lbl.lbl_pos) lbl_exp_list
+                      in
+                      let label_names = extract_label_names env ty_expected in
+                      let rec missing_labels n = function
+                          [] -> []
+                        | lbl :: rem ->
+                            if List.mem n present_indices
+                            then missing_labels (n + 1) rem
+                            else lbl :: missing_labels (n + 1) rem
+                      in
+                      let missing = missing_labels 0 label_names in
+                      raise(Error(loc, env, Label_missing missing)))
+                lbl.lbl_all
+            in
+            None, label_definitions
+        | Some exp ->
+            let ty_exp = instance exp.exp_type in
+            let unify_kept lbl =
+              let _, ty_arg1, ty_res1 = instance_label false lbl in
+              unify_exp_types exp.exp_loc env ty_exp ty_res1;
+              match matching_label lbl with
+              | lid, _lbl, lbl_exp ->
+                  (* do not connect result types for overridden labels *)
+                  Overridden (lid, lbl_exp)
+              | exception Not_found -> begin
+                  let _, ty_arg2, ty_res2 = instance_label false lbl in
+                  unify_exp_types loc env ty_arg1 ty_arg2;
+                  with_explanation (fun () ->
+                    unify_exp_types loc env (instance ty_expected) ty_res2);
+                  Kept ty_arg1
+                end
+            in
+            let label_definitions = Array.map unify_kept lbl.lbl_all in
+            Some {exp with exp_type = ty_exp}, label_definitions
+      in
+      let num_fields =
+        match lbl_exp_list with [] -> assert false
+        | (_, lbl,_)::_ -> Array.length lbl.lbl_all in
+      if opt_sexp <> None && List.length lid_sexp_list = num_fields then
+        Location.prerr_warning loc Warnings.Useless_record_with;
+      let label_descriptions, representation =
+        let (_, { lbl_all; lbl_repres }, _) = List.hd lbl_exp_list in
+        lbl_all, lbl_repres
+      in
+      let fields =
+        Array.map2 (fun descr def -> descr, def)
+          label_descriptions label_definitions
+      in
+      re {
+        exp_desc = Texp_record {
+            fields; representation;
+            extended_expression = opt_exp
+          };
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance ty_expected;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_field(srecord, lid) ->
+      let (record, label, _) =
+        type_label_access env srecord Env.Projection lid
+      in
+      let (_, ty_arg, ty_res) = instance_label false label in
+      unify_exp env record ty_res;
+      rue {
+        exp_desc = Texp_field(record, lid, label);
+        exp_loc = loc; exp_extra = [];
+        exp_type = ty_arg;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_setfield(srecord, lid, snewval) ->
+      let (record, label, expected_type) =
+        type_label_access env srecord Env.Mutation lid in
+      let ty_record =
+        if expected_type = None then newvar () else record.exp_type in
+      let (label_loc, label, newval) =
+        type_label_exp false env loc ty_record (lid, label, snewval) in
+      unify_exp env record ty_record;
+      if label.lbl_mut = Immutable then
+        raise(Error(loc, env, Label_not_mutable lid.txt));
+      rue {
+        exp_desc = Texp_setfield(record, label_loc, label, newval);
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance Predef.type_unit;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_array(sargl) ->
+      let ty = newgenvar() in
+      let to_unify = Predef.type_array ty in
+      with_explanation (fun () ->
+        unify_exp_types loc env to_unify (generic_instance ty_expected));
+      let argl =
+        List.map (fun sarg -> type_expect env sarg (mk_expected ty)) sargl in
+      re {
+        exp_desc = Texp_array argl;
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance ty_expected;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_ifthenelse(scond, sifso, sifnot) ->
+      let cond = type_expect env scond
+          (mk_expected ~explanation:If_conditional Predef.type_bool) in
+      begin match sifnot with
+        None ->
+          let ifso = type_expect env sifso
+              (mk_expected ~explanation:If_no_else_branch Predef.type_unit) in
+          rue {
+            exp_desc = Texp_ifthenelse(cond, ifso, None);
+            exp_loc = loc; exp_extra = [];
+            exp_type = ifso.exp_type;
+            exp_attributes = sexp.pexp_attributes;
+            exp_env = env }
+      | Some sifnot ->
+          let ifso = type_expect env sifso ty_expected_explained in
+          let ifnot = type_expect env sifnot ty_expected_explained in
+          (* Keep sharing *)
+          unify_exp env ifnot ifso.exp_type;
+          re {
+            exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot);
+            exp_loc = loc; exp_extra = [];
+            exp_type = ifso.exp_type;
+            exp_attributes = sexp.pexp_attributes;
+            exp_env = env }
+      end
+  | Pexp_sequence(sexp1, sexp2) ->
+      let exp1 = type_statement ~explanation:Sequence_left_hand_side
+          env sexp1 in
+      let exp2 = type_expect env sexp2 ty_expected_explained in
+      re {
+        exp_desc = Texp_sequence(exp1, exp2);
+        exp_loc = loc; exp_extra = [];
+        exp_type = exp2.exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_while(scond, sbody) ->
+      let cond = type_expect env scond
+          (mk_expected ~explanation:While_loop_conditional Predef.type_bool) in
+      let body = type_statement ~explanation:While_loop_body env sbody in
+      rue {
+        exp_desc = Texp_while(cond, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance Predef.type_unit;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_for(param, slow, shigh, dir, sbody) ->
+      let low = type_expect env slow
+          (mk_expected ~explanation:For_loop_start_index Predef.type_int) in
+      let high = type_expect env shigh
+          (mk_expected ~explanation:For_loop_stop_index Predef.type_int) in
+      let id, new_env =
+        match param.ppat_desc with
+        | Ppat_any -> Ident.create_local "_for", env
+        | Ppat_var {txt} ->
+            Env.enter_value txt
+              {val_type = instance Predef.type_int;
+               val_attributes = [];
+               val_kind = Val_reg;
+               val_loc = loc;
+               val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+              } env
+              ~check:(fun s -> Warnings.Unused_for_index s)
+        | _ ->
+            raise (Error (param.ppat_loc, env, Invalid_for_loop_index))
+      in
+      let body = type_statement ~explanation:For_loop_body new_env sbody in
+      rue {
+        exp_desc = Texp_for(id, param, low, high, dir, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance Predef.type_unit;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_constraint (sarg, sty) ->
+      (* Pretend separate = true, 1% slowdown for lablgtk *)
+      begin_def ();
+      let cty = Typetexp.transl_simple_type env false sty in
+      let ty = cty.ctyp_type in
+      end_def ();
+      generalize_structure ty;
+      let (arg, ty') = (type_argument env sarg ty (instance ty), instance ty) in
+      rue {
+        exp_desc = arg.exp_desc;
+        exp_loc = arg.exp_loc;
+        exp_type = ty';
+        exp_attributes = arg.exp_attributes;
+        exp_env = env;
+        exp_extra =
+          (Texp_constraint cty, loc, sexp.pexp_attributes) :: arg.exp_extra;
+      }
+  | Pexp_coerce(sarg, sty, sty') ->
+      (* Pretend separate = true, 1% slowdown for lablgtk *)
+      (* Also see PR#7199 for a problem with the following:
+         let separate = !Clflags.principal || Env.has_local_constraints env in*)
+      let (arg, ty',cty,cty') =
+        match sty with
+        | None ->
+            let (cty', ty', force) =
+              Typetexp.transl_simple_type_delayed env sty'
+            in
+            begin_def ();
+            let arg = type_exp env sarg in
+            end_def ();
+            let tv = newvar () in
+            let gen = generalizable tv.level arg.exp_type in
+            unify_var env tv arg.exp_type;
+            begin match arg.exp_desc, !self_coercion, (repr ty').desc with
+              Texp_ident(_, _, {val_kind=Val_self _}), (path,r) :: _,
+              Tconstr(path',_,_) when Path.same path path' ->
+                (* prerr_endline "self coercion"; *)
+                r := loc :: !r;
+                force ()
+            | _ when free_variables ~env arg.exp_type = []
+                  && free_variables ~env ty' = [] ->
+                if not gen && (* first try a single coercion *)
+                  let snap = snapshot () in
+                  let ty, _b = enlarge_type env ty' in
+                  try
+                    force (); Ctype.unify env arg.exp_type ty; true
+                  with Unify _ ->
+                    backtrack snap; false
+                then ()
+                else begin try
+                  let force' = subtype env arg.exp_type ty' in
+                  force (); force' ();
+                  if not gen && !Clflags.principal then
+                    Location.prerr_warning loc
+                      (Warnings.Not_principal "this ground coercion");
+                with Subtype (tr1, tr2) ->
+                  (* prerr_endline "coercion failed"; *)
+                  raise(Error(loc, env, Not_subtype(tr1, tr2)))
+                end;
+            | _ ->
+                let ty, b = enlarge_type env ty' in
+                force ();
+                begin try Ctype.unify env arg.exp_type ty with Unify trace ->
+                  let expanded = full_expand ~may_forget_scope:true env ty' in
+                  raise(Error(sarg.pexp_loc, env,
+                              Coercion_failure(ty', expanded, trace, b)))
+                end
+            end;
+            (arg, ty', None, cty')
+        | Some sty ->
+            begin_def ();
+            let (cty, ty, force) =
+              Typetexp.transl_simple_type_delayed env sty
+            and (cty', ty', force') =
+              Typetexp.transl_simple_type_delayed env sty'
+            in
+            begin try
+              let force'' = subtype env ty ty' in
+              force (); force' (); force'' ()
+            with Subtype (tr1, tr2) ->
+              raise(Error(loc, env, Not_subtype(tr1, tr2)))
+            end;
+            end_def ();
+            generalize_structure ty;
+            generalize_structure ty';
+            (type_argument env sarg ty (instance ty),
+             instance ty', Some cty, cty')
+      in
+      rue {
+        exp_desc = arg.exp_desc;
+        exp_loc = arg.exp_loc;
+        exp_type = ty';
+        exp_attributes = arg.exp_attributes;
+        exp_env = env;
+        exp_extra = (Texp_coerce (cty, cty'), loc, sexp.pexp_attributes) ::
+                       arg.exp_extra;
+      }
+  | Pexp_send (e, {txt=met}) ->
+      if !Clflags.principal then begin_def ();
+      let obj = type_exp env e in
+      let obj_meths = ref None in
+      begin try
+        let (meth, exp, typ) =
+          match obj.exp_desc with
+            Texp_ident(_path, _, {val_kind = Val_self (meths, _, _, privty)}) ->
+              obj_meths := Some meths;
+              let (id, typ) =
+                filter_self_method env met Private meths privty
+              in
+              if is_Tvar (repr typ) then
+                Location.prerr_warning loc
+                  (Warnings.Undeclared_virtual_method met);
+              (Tmeth_val id, None, typ)
+          | Texp_ident(_path, lid, {val_kind = Val_anc (methods, cl_num)}) ->
+              let method_id =
+                begin try List.assoc met methods with Not_found ->
+                  let valid_methods = List.map fst methods in
+                  raise(Error(e.pexp_loc, env,
+                              Undefined_inherited_method (met, valid_methods)))
+                end
+              in
+              begin match
+                Env.find_value_by_name
+                  (Longident.Lident ("selfpat-" ^ cl_num)) env,
+                Env.find_value_by_name
+                  (Longident.Lident ("self-" ^cl_num)) env
+              with
+              | (_, ({val_kind = Val_self (meths, _, _, privty)} as desc)),
+                (path, _) ->
+                  obj_meths := Some meths;
+                  let (_, typ) =
+                    filter_self_method env met Private meths privty
+                  in
+                  let method_type = newvar () in
+                  let (obj_ty, res_ty) = filter_arrow env method_type Nolabel in
+                  unify env obj_ty desc.val_type;
+                  unify env res_ty (instance typ);
+                  let method_desc =
+                    {val_type = method_type;
+                     val_kind = Val_reg;
+                     val_attributes = [];
+                     val_loc = Location.none;
+                     val_uid = Uid.internal_not_actually_unique;
+                    }
+                  in
+                  let exp_env = Env.add_value method_id method_desc env in
+                  let exp =
+                    Texp_apply({exp_desc =
+                                Texp_ident(Path.Pident method_id,
+                                           lid, method_desc);
+                                exp_loc = loc; exp_extra = [];
+                                exp_type = method_type;
+                                exp_attributes = []; (* check *)
+                                exp_env = exp_env},
+                          [ Nolabel,
+                            Some {exp_desc = Texp_ident(path, lid, desc);
+                                  exp_loc = obj.exp_loc; exp_extra = [];
+                                  exp_type = desc.val_type;
+                                  exp_attributes = []; (* check *)
+                                  exp_env = exp_env}
+                          ])
+                  in
+                  (Tmeth_name met, Some (re {exp_desc = exp;
+                                             exp_loc = loc; exp_extra = [];
+                                             exp_type = typ;
+                                             exp_attributes = []; (* check *)
+                                             exp_env = exp_env}), typ)
+              |  _ ->
+                  assert false
+              end
+          | _ ->
+              (Tmeth_name met, None,
+               filter_method env met Public obj.exp_type)
+        in
+        if !Clflags.principal then begin
+          end_def ();
+          generalize_structure typ;
+        end;
+        let typ =
+          match repr typ with
+            {desc = Tpoly (ty, [])} ->
+              instance ty
+          | {desc = Tpoly (ty, tl); level = l} ->
+              if !Clflags.principal && l <> generic_level then
+                Location.prerr_warning loc
+                  (Warnings.Not_principal "this use of a polymorphic method");
+              snd (instance_poly false tl ty)
+          | {desc = Tvar _} as ty ->
+              let ty' = newvar () in
+              unify env (instance ty) (newty(Tpoly(ty',[])));
+              (* if not !Clflags.nolabels then
+                 Location.prerr_warning loc (Warnings.Unknown_method met); *)
+              ty'
+          | _ ->
+              assert false
+        in
+        rue {
+          exp_desc = Texp_send(obj, meth, exp);
+          exp_loc = loc; exp_extra = [];
+          exp_type = typ;
+          exp_attributes = sexp.pexp_attributes;
+          exp_env = env }
+      with Unify _ ->
+        let valid_methods =
+          match !obj_meths with
+          | Some meths ->
+             Some (Meths.fold (fun meth _meth_ty li -> meth::li) !meths [])
+          | None ->
+             match (expand_head env obj.exp_type).desc with
+             | Tobject (fields, _) ->
+                let (fields, _) = Ctype.flatten_fields fields in
+                let collect_fields li (meth, meth_kind, _meth_ty) =
+                  if meth_kind = Fpresent then meth::li else li in
+                Some (List.fold_left collect_fields [] fields)
+             | _ -> None
+        in
+        raise(Error(e.pexp_loc, env,
+                    Undefined_method (obj.exp_type, met, valid_methods)))
+      end
+  | Pexp_new cl ->
+      let (cl_path, cl_decl) = Env.lookup_class ~loc:cl.loc cl.txt env in
+      begin match cl_decl.cty_new with
+          None ->
+            raise(Error(loc, env, Virtual_class cl.txt))
+        | Some ty ->
+            rue {
+              exp_desc = Texp_new (cl_path, cl, cl_decl);
+              exp_loc = loc; exp_extra = [];
+              exp_type = instance ty;
+              exp_attributes = sexp.pexp_attributes;
+              exp_env = env }
+        end
+  | Pexp_setinstvar (lab, snewval) -> begin
+      let (path, mut, cl_num, ty) =
+        Env.lookup_instance_variable ~loc lab.txt env
+      in
+      match mut with
+      | Mutable ->
+          let newval =
+            type_expect env snewval (mk_expected (instance ty))
+          in
+          let (path_self, _) =
+            Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env
+          in
+          rue {
+            exp_desc = Texp_setinstvar(path_self, path, lab, newval);
+            exp_loc = loc; exp_extra = [];
+            exp_type = instance Predef.type_unit;
+            exp_attributes = sexp.pexp_attributes;
+            exp_env = env }
+      | _ ->
+          raise(Error(loc, env, Instance_variable_not_mutable lab.txt))
+    end
+  | Pexp_override lst ->
+      let _ =
+       List.fold_right
+        (fun (lab, _) l ->
+           if List.exists (fun l -> l.txt = lab.txt) l then
+             raise(Error(loc, env,
+                         Value_multiply_overridden lab.txt));
+           lab::l)
+        lst
+        [] in
+      begin match
+        try
+          Env.find_value_by_name (Longident.Lident "selfpat-*") env,
+          Env.find_value_by_name (Longident.Lident "self-*") env
+        with Not_found ->
+          raise(Error(loc, env, Outside_class))
+      with
+        (_, {val_type = self_ty; val_kind = Val_self (_, vars, _, _)}),
+        (path_self, _) ->
+          let type_override (lab, snewval) =
+            begin try
+              let (id, _, _, ty) = Vars.find lab.txt !vars in
+              (Path.Pident id, lab,
+               type_expect env snewval (mk_expected (instance ty)))
+            with
+              Not_found ->
+                let vars = Vars.fold (fun var _ li -> var::li) !vars [] in
+                raise(Error(loc, env,
+                            Unbound_instance_variable (lab.txt, vars)))
+            end
+          in
+          let modifs = List.map type_override lst in
+          rue {
+            exp_desc = Texp_override(path_self, modifs);
+            exp_loc = loc; exp_extra = [];
+            exp_type = self_ty;
+            exp_attributes = sexp.pexp_attributes;
+            exp_env = env }
+      | _ ->
+          assert false
+      end
+  | Pexp_letmodule(name, smodl, sbody) ->
+      let ty = newvar() in
+      (* remember original level *)
+      begin_def ();
+      let context = Typetexp.narrow () in
+      let modl = !type_module env smodl in
+      Mtype.lower_nongen ty.level modl.mod_type;
+      let pres =
+        match modl.mod_type with
+        | Mty_alias _ -> Mp_absent
+        | _ -> Mp_present
+      in
+      let scope = create_scope () in
+      let md =
+        { md_type = modl.mod_type; md_attributes = []; md_loc = name.loc;
+          md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); }
+      in
+      let (id, new_env) =
+        match name.txt with
+        | None -> None, env
+        | Some name ->
+          let id, env = Env.enter_module_declaration ~scope name pres md env in
+          Some id, env
+      in
+      Typetexp.widen context;
+      (* ideally, we should catch Expr_type_clash errors
+         in type_expect triggered by escaping identifiers from the local module
+         and refine them into Scoping_let_module errors
+      *)
+      let body = type_expect new_env sbody ty_expected_explained in
+      (* go back to original level *)
+      end_def ();
+      Ctype.unify_var new_env ty body.exp_type;
+      re {
+        exp_desc = Texp_letmodule(id, name, pres, modl, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = ty;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_letexception(cd, sbody) ->
+      let (cd, newenv) = Typedecl.transl_exception env cd in
+      let body = type_expect newenv sbody ty_expected_explained in
+      re {
+        exp_desc = Texp_letexception(cd, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = body.exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+
+  | Pexp_assert (e) ->
+      let cond = type_expect env e
+          (mk_expected ~explanation:Assert_condition Predef.type_bool) in
+      let exp_type =
+        match cond.exp_desc with
+        | Texp_construct(_, {cstr_name="false"}, _) ->
+            instance ty_expected
+        | _ ->
+            instance Predef.type_unit
+      in
+      rue {
+        exp_desc = Texp_assert cond;
+        exp_loc = loc; exp_extra = [];
+        exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env;
+      }
+  | Pexp_lazy e ->
+      let ty = newgenvar () in
+      let to_unify = Predef.type_lazy_t ty in
+      with_explanation (fun () ->
+        unify_exp_types loc env to_unify (generic_instance ty_expected));
+      let arg = type_expect env e (mk_expected ty) in
+      re {
+        exp_desc = Texp_lazy arg;
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance ty_expected;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env;
+      }
+  | Pexp_object s ->
+      let desc, sign, meths = !type_object env loc s in
+      rue {
+        exp_desc = Texp_object (desc, (*sign,*) meths);
+        exp_loc = loc; exp_extra = [];
+        exp_type = sign.csig_self;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env;
+      }
+  | Pexp_poly(sbody, sty) ->
+      if !Clflags.principal then begin_def ();
+      let ty, cty =
+        match sty with None -> repr ty_expected, None
+        | Some sty ->
+            let sty = Ast_helper.Typ.force_poly sty in
+            let cty = Typetexp.transl_simple_type env false sty in
+            repr cty.ctyp_type, Some cty
+      in
+      if !Clflags.principal then begin
+        end_def ();
+        generalize_structure ty
+      end;
+      if sty <> None then
+        with_explanation (fun () ->
+          unify_exp_types loc env (instance ty) (instance ty_expected));
+      let exp =
+        match (expand_head env ty).desc with
+          Tpoly (ty', []) ->
+            let exp = type_expect env sbody (mk_expected ty') in
+            { exp with exp_type = instance ty }
+        | Tpoly (ty', tl) ->
+            (* One more level to generalize locally *)
+            begin_def ();
+            if !Clflags.principal then begin_def ();
+            let vars, ty'' = instance_poly true tl ty' in
+            if !Clflags.principal then begin
+              end_def ();
+              generalize_structure ty''
+            end;
+            let exp = type_expect env sbody (mk_expected ty'') in
+            end_def ();
+            generalize_and_check_univars env "method" exp ty_expected vars;
+            { exp with exp_type = instance ty }
+        | Tvar _ ->
+            let exp = type_exp env sbody in
+            let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in
+            unify_exp env exp ty;
+            exp
+        | _ -> assert false
+      in
+      re { exp with exp_extra =
+             (Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra }
+  | Pexp_newtype({txt=name}, sbody) ->
+      let ty =
+        if Typetexp.valid_tyvar_name name then
+          newvar ~name ()
+        else
+          newvar ()
+      in
+      (* remember original level *)
+      begin_def ();
+      (* Create a fake abstract type declaration for name. *)
+      let decl = new_local_type ~loc () in
+      let scope = create_scope () in
+      let (id, new_env) = Env.enter_type ~scope name decl env in
+
+      let body = type_exp new_env sbody in
+      (* Replace every instance of this type constructor in the resulting
+         type. *)
+      let seen = Hashtbl.create 8 in
+      let rec replace t =
+        if Hashtbl.mem seen t.id then ()
+        else begin
+          Hashtbl.add seen t.id ();
+          match t.desc with
+          | Tconstr (Path.Pident id', _, _) when id == id' -> link_type t ty
+          | _ -> Btype.iter_type_expr replace t
+        end
+      in
+      let ety = Subst.type_expr Subst.identity body.exp_type in
+      replace ety;
+      (* back to original level *)
+      end_def ();
+      (* lower the levels of the result type *)
+      (* unify_var env ty ety; *)
+
+      (* non-expansive if the body is non-expansive, so we don't introduce
+         any new extra node in the typed AST. *)
+      rue { body with exp_loc = loc; exp_type = ety;
+            exp_extra =
+            (Texp_newtype name, loc, sexp.pexp_attributes) :: body.exp_extra }
+  | Pexp_pack m ->
+      let (p, fl) =
+        match Ctype.expand_head env (instance ty_expected) with
+          {desc = Tpackage (p, fl)} ->
+            if !Clflags.principal &&
+              (Ctype.expand_head env ty_expected).level < Btype.generic_level
+            then
+              Location.prerr_warning loc
+                (Warnings.Not_principal "this module packing");
+            (p, fl)
+        | {desc = Tvar _} ->
+            raise (Error (loc, env, Cannot_infer_signature))
+        | _ ->
+            raise (Error (loc, env, Not_a_packed_module ty_expected))
+      in
+      let (modl, fl') = !type_package env m p fl in
+      rue {
+        exp_desc = Texp_pack modl;
+        exp_loc = loc; exp_extra = [];
+        exp_type = newty (Tpackage (p, fl'));
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_open (od, e) ->
+      let tv = newvar () in
+      let (od, _, newenv) = !type_open_decl env od in
+      let exp = type_expect newenv e ty_expected_explained in
+      (* Force the return type to be well-formed in the original
+         environment. *)
+      unify_var newenv tv exp.exp_type;
+      re {
+        exp_desc = Texp_open (od, exp);
+        exp_type = exp.exp_type;
+        exp_loc = loc;
+        exp_extra = [];
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env;
+      }
+  | Pexp_letop{ let_ = slet; ands = sands; body = sbody } ->
+      let rec loop spat_acc ty_acc sands =
+        match sands with
+        | [] -> spat_acc, ty_acc
+        | { pbop_pat = spat; _} :: rest ->
+            let ty = newvar () in
+            let loc = { slet.pbop_op.loc with Location.loc_ghost = true } in
+            let spat_acc = Ast_helper.Pat.tuple ~loc [spat_acc; spat] in
+            let ty_acc = newty (Ttuple [ty_acc; ty]) in
+            loop spat_acc ty_acc rest
+      in
+      if !Clflags.principal then begin_def ();
+      let let_loc = slet.pbop_op.loc in
+      let op_path, op_desc = type_binding_op_ident env slet.pbop_op in
+      let op_type = instance op_desc.val_type in
+      let spat_params, ty_params = loop slet.pbop_pat (newvar ()) sands in
+      let ty_func_result = newvar () in
+      let ty_func = newty (Tarrow(Nolabel, ty_params, ty_func_result, Cok)) in
+      let ty_result = newvar () in
+      let ty_andops = newvar () in
+      let ty_op =
+        newty (Tarrow(Nolabel, ty_andops,
+          newty (Tarrow(Nolabel, ty_func, ty_result, Cok)), Cok))
+      in
+      begin try
+        unify env op_type ty_op
+      with Unify trace ->
+        raise(Error(let_loc, env, Letop_type_clash(slet.pbop_op.txt, trace)))
+      end;
+      if !Clflags.principal then begin
+        end_def ();
+        generalize_structure ty_andops;
+        generalize_structure ty_params;
+        generalize_structure ty_func_result;
+        generalize_structure ty_result
+      end;
+      let exp, ands = type_andops env slet.pbop_exp sands ty_andops in
+      let scase = Ast_helper.Exp.case spat_params sbody in
+      let cases, partial =
+        type_cases Value env
+          ty_params (mk_expected ty_func_result) true loc [scase]
+      in
+      let body =
+        match cases with
+        | [case] -> case
+        | _ -> assert false
+      in
+      let param = name_cases "param" cases in
+      let let_ =
+        { bop_op_name = slet.pbop_op;
+          bop_op_path = op_path;
+          bop_op_val = op_desc;
+          bop_op_type = op_type;
+          bop_exp = exp;
+          bop_loc = slet.pbop_loc; }
+      in
+      let desc =
+        Texp_letop{let_; ands; param; body; partial}
+      in
+      rue { exp_desc = desc;
+            exp_loc = sexp.pexp_loc;
+            exp_extra = [];
+            exp_type = instance ty_result;
+            exp_env = env;
+            exp_attributes = sexp.pexp_attributes; }
+
+  | Pexp_extension ({ txt = ("ocaml.extension_constructor"
+                             |"extension_constructor"); _ },
+                    payload) ->
+      begin match payload with
+      | PStr [ { pstr_desc =
+                   Pstr_eval ({ pexp_desc = Pexp_construct (lid, None); _ }, _)
+               } ] ->
+          let path =
+            let cd =
+              Env.lookup_constructor Env.Positive ~loc:lid.loc lid.txt env
+            in
+            match cd.cstr_tag with
+            | Cstr_extension (path, _) -> path
+            | _ -> raise (Error (lid.loc, env, Not_an_extension_constructor))
+          in
+          rue {
+            exp_desc = Texp_extension_constructor (lid, path);
+            exp_loc = loc; exp_extra = [];
+            exp_type = instance Predef.type_extension_constructor;
+            exp_attributes = sexp.pexp_attributes;
+            exp_env = env }
+      | _ ->
+          raise (Error (loc, env, Invalid_extension_constructor_payload))
+      end
+  | Pexp_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+  | Pexp_unreachable ->
+      re { exp_desc = Texp_unreachable;
+           exp_loc = loc; exp_extra = [];
+           exp_type = instance ty_expected;
+           exp_attributes = sexp.pexp_attributes;
+           exp_env = env }
+
+and type_ident env ?(recarg=Rejected) lid =
+  let (path, desc) = Env.lookup_value ~loc:lid.loc lid.txt env in
+  let is_recarg =
+    match (repr desc.val_type).desc with
+    | Tconstr(p, _, _) -> Path.is_constructor_typath p
+    | _ -> false
+  in
+  begin match is_recarg, recarg, (repr desc.val_type).desc with
+  | _, Allowed, _
+  | true, Required, _
+  | false, Rejected, _ -> ()
+  | true, Rejected, _
+  | false, Required, (Tvar _ | Tconstr _) ->
+      raise (Error (lid.loc, env, Inlined_record_escape))
+  | false, Required, _  -> () (* will fail later *)
+  end;
+  path, desc
+
+and type_binding_op_ident env s =
+  let loc = s.loc in
+  let lid = Location.mkloc (Longident.Lident s.txt) loc in
+  let path, desc = type_ident env lid in
+  let path =
+    match desc.val_kind with
+    | Val_ivar _ ->
+        fatal_error "Illegal name for instance variable"
+    | Val_self (_, _, cl_num, _) ->
+        let path, _ =
+          Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env
+        in
+        path
+    | _ -> path
+  in
+  path, desc
+
+and type_function ?(in_function : (Location.t * type_expr) option)
+    loc attrs env ty_expected_explained arg_label caselist =
+  let { ty = ty_expected; explanation } = ty_expected_explained in
+  let (loc_fun, ty_fun) =
+    match in_function with Some p -> p
+    | None -> (loc, instance ty_expected)
+  in
+  let separate = !Clflags.principal || Env.has_local_constraints env in
+  if separate then begin_def ();
+  let (ty_arg, ty_res) =
+    try filter_arrow env (instance ty_expected) arg_label
+    with Unify _ ->
+      match expand_head env ty_expected with
+        {desc = Tarrow _} as ty ->
+          raise(Error(loc, env,
+                      Abstract_wrong_label(arg_label, ty, explanation)))
+      | _ ->
+          raise(Error(loc_fun, env,
+                      Too_many_arguments (in_function <> None,
+                                          ty_fun,
+                                          explanation)))
+  in
+  let ty_arg =
+    if is_optional arg_label then
+      let tv = newvar() in
+      begin
+        try unify env ty_arg (type_option tv)
+        with Unify _ -> assert false
+      end;
+      type_option tv
+    else ty_arg
+  in
+  if separate then begin
+    end_def ();
+    generalize_structure ty_arg;
+    generalize_structure ty_res
+  end;
+  let cases, partial =
+    type_cases Value ~in_function:(loc_fun,ty_fun) env
+      ty_arg (mk_expected ty_res) true loc caselist in
+  let not_nolabel_function ty =
+    let ls, tvar = list_labels env ty in
+    List.for_all ((<>) Nolabel) ls && not tvar
+  in
+  if is_optional arg_label && not_nolabel_function ty_res then
+    Location.prerr_warning (List.hd cases).c_lhs.pat_loc
+      Warnings.Unerasable_optional_argument;
+  let param = name_cases "param" cases in
+  re {
+    exp_desc = Texp_function { arg_label; param; cases; partial; };
+    exp_loc = loc; exp_extra = [];
+    exp_type = instance (newgenty (Tarrow(arg_label, ty_arg, ty_res, Cok)));
+    exp_attributes = attrs;
+    exp_env = env }
+
+
+and type_label_access env srecord usage lid =
+  if !Clflags.principal then begin_def ();
+  let record = type_exp ~recarg:Allowed env srecord in
+  if !Clflags.principal then begin
+    end_def ();
+    generalize_structure record.exp_type
+  end;
+  let ty_exp = record.exp_type in
+  let expected_type =
+    try
+      let (p0, p,_) = extract_concrete_record env ty_exp in
+      Some(p0, p, (repr ty_exp).level = generic_level || not !Clflags.principal)
+    with Not_found -> None
+  in
+  let labels = Env.lookup_all_labels ~loc:lid.loc usage lid.txt env in
+  let label =
+    wrap_disambiguate "This expression has" (mk_expected ty_exp)
+      (Label.disambiguate usage lid env expected_type) labels in
+  (record, label, expected_type)
+
+(* Typing format strings for printing or reading.
+   These formats are used by functions in modules Printf, Format, and Scanf.
+   (Handling of * modifiers contributed by Thorsten Ohl.) *)
+
+and type_format loc str env =
+  let loc = {loc with Location.loc_ghost = true} in
+  try
+    CamlinternalFormatBasics.(CamlinternalFormat.(
+      let mk_exp_loc pexp_desc = {
+        pexp_desc = pexp_desc;
+        pexp_loc = loc;
+        pexp_loc_stack = [];
+        pexp_attributes = [];
+      } and mk_lid_loc lid = {
+        txt = lid;
+        loc = loc;
+      } in
+      let mk_constr name args =
+        let lid = Longident.(Ldot(Lident "CamlinternalFormatBasics", name)) in
+        let arg = match args with
+          | []          -> None
+          | [ e ]       -> Some e
+          | _ :: _ :: _ -> Some (mk_exp_loc (Pexp_tuple args)) in
+        mk_exp_loc (Pexp_construct (mk_lid_loc lid, arg)) in
+      let mk_cst cst = mk_exp_loc (Pexp_constant cst) in
+      let mk_int n = mk_cst (Pconst_integer (Int.to_string n, None))
+      and mk_string str = mk_cst (Pconst_string (str, loc, None))
+      and mk_char chr = mk_cst (Pconst_char chr) in
+      let rec mk_formatting_lit fmting = match fmting with
+        | Close_box ->
+          mk_constr "Close_box" []
+        | Close_tag ->
+          mk_constr "Close_tag" []
+        | Break (org, ns, ni) ->
+          mk_constr "Break" [ mk_string org; mk_int ns; mk_int ni ]
+        | FFlush ->
+          mk_constr "FFlush" []
+        | Force_newline ->
+          mk_constr "Force_newline" []
+        | Flush_newline ->
+          mk_constr "Flush_newline" []
+        | Magic_size (org, sz) ->
+          mk_constr "Magic_size" [ mk_string org; mk_int sz ]
+        | Escaped_at ->
+          mk_constr "Escaped_at" []
+        | Escaped_percent ->
+          mk_constr "Escaped_percent" []
+        | Scan_indic c ->
+          mk_constr "Scan_indic" [ mk_char c ]
+      and mk_formatting_gen : type a b c d e f .
+          (a, b, c, d, e, f) formatting_gen -> Parsetree.expression =
+        fun fmting -> match fmting with
+        | Open_tag (Format (fmt', str')) ->
+          mk_constr "Open_tag" [ mk_format fmt' str' ]
+        | Open_box (Format (fmt', str')) ->
+          mk_constr "Open_box" [ mk_format fmt' str' ]
+      and mk_format : type a b c d e f .
+          (a, b, c, d, e, f) CamlinternalFormatBasics.fmt -> string ->
+          Parsetree.expression = fun fmt str ->
+        mk_constr "Format" [ mk_fmt fmt; mk_string str ]
+      and mk_side side = match side with
+        | Left  -> mk_constr "Left"  []
+        | Right -> mk_constr "Right" []
+        | Zeros -> mk_constr "Zeros" []
+      and mk_iconv iconv = match iconv with
+        | Int_d  -> mk_constr "Int_d"  [] | Int_pd -> mk_constr "Int_pd" []
+        | Int_sd -> mk_constr "Int_sd" [] | Int_i  -> mk_constr "Int_i"  []
+        | Int_pi -> mk_constr "Int_pi" [] | Int_si -> mk_constr "Int_si" []
+        | Int_x  -> mk_constr "Int_x"  [] | Int_Cx -> mk_constr "Int_Cx" []
+        | Int_X  -> mk_constr "Int_X"  [] | Int_CX -> mk_constr "Int_CX" []
+        | Int_o  -> mk_constr "Int_o"  [] | Int_Co -> mk_constr "Int_Co" []
+        | Int_u  -> mk_constr "Int_u"  [] | Int_Cd -> mk_constr "Int_Cd" []
+        | Int_Ci -> mk_constr "Int_Ci" [] | Int_Cu -> mk_constr "Int_Cu" []
+      and mk_fconv fconv =
+        let flag = match fst fconv with
+        | Float_flag_ -> mk_constr "Float_flag_" []
+        | Float_flag_p -> mk_constr "Float_flag_p" []
+        | Float_flag_s -> mk_constr "Float_flag_s" [] in
+        let kind = match snd fconv with
+        | Float_f  -> mk_constr "Float_f"  []
+        | Float_e  -> mk_constr "Float_e"  []
+        | Float_E  -> mk_constr "Float_E"  []
+        | Float_g  -> mk_constr "Float_g"  []
+        | Float_G  -> mk_constr "Float_G"  []
+        | Float_h  -> mk_constr "Float_h"  []
+        | Float_H  -> mk_constr "Float_H"  []
+        | Float_F  -> mk_constr "Float_F"  []
+        | Float_CF -> mk_constr "Float_CF" [] in
+        mk_exp_loc (Pexp_tuple [flag; kind])
+      and mk_counter cnt = match cnt with
+        | Line_counter  -> mk_constr "Line_counter"  []
+        | Char_counter  -> mk_constr "Char_counter"  []
+        | Token_counter -> mk_constr "Token_counter" []
+      and mk_int_opt n_opt = match n_opt with
+        | None ->
+          let lid_loc = mk_lid_loc (Longident.Lident "None") in
+          mk_exp_loc (Pexp_construct (lid_loc, None))
+        | Some n ->
+          let lid_loc = mk_lid_loc (Longident.Lident "Some") in
+          mk_exp_loc (Pexp_construct (lid_loc, Some (mk_int n)))
+      and mk_fmtty : type a b c d e f g h i j k l .
+          (a, b, c, d, e, f, g, h, i, j, k, l) fmtty_rel -> Parsetree.expression
+          =
+      fun fmtty -> match fmtty with
+        | Char_ty rest      -> mk_constr "Char_ty"      [ mk_fmtty rest ]
+        | String_ty rest    -> mk_constr "String_ty"    [ mk_fmtty rest ]
+        | Int_ty rest       -> mk_constr "Int_ty"       [ mk_fmtty rest ]
+        | Int32_ty rest     -> mk_constr "Int32_ty"     [ mk_fmtty rest ]
+        | Nativeint_ty rest -> mk_constr "Nativeint_ty" [ mk_fmtty rest ]
+        | Int64_ty rest     -> mk_constr "Int64_ty"     [ mk_fmtty rest ]
+        | Float_ty rest     -> mk_constr "Float_ty"     [ mk_fmtty rest ]
+        | Bool_ty rest      -> mk_constr "Bool_ty"      [ mk_fmtty rest ]
+        | Alpha_ty rest     -> mk_constr "Alpha_ty"     [ mk_fmtty rest ]
+        | Theta_ty rest     -> mk_constr "Theta_ty"     [ mk_fmtty rest ]
+        | Any_ty rest       -> mk_constr "Any_ty"       [ mk_fmtty rest ]
+        | Reader_ty rest    -> mk_constr "Reader_ty"    [ mk_fmtty rest ]
+        | Ignored_reader_ty rest ->
+          mk_constr "Ignored_reader_ty" [ mk_fmtty rest ]
+        | Format_arg_ty (sub_fmtty, rest) ->
+          mk_constr "Format_arg_ty" [ mk_fmtty sub_fmtty; mk_fmtty rest ]
+        | Format_subst_ty (sub_fmtty1, sub_fmtty2, rest) ->
+          mk_constr "Format_subst_ty"
+            [ mk_fmtty sub_fmtty1; mk_fmtty sub_fmtty2; mk_fmtty rest ]
+        | End_of_fmtty -> mk_constr "End_of_fmtty" []
+      and mk_ignored : type a b c d e f .
+          (a, b, c, d, e, f) ignored -> Parsetree.expression =
+      fun ign -> match ign with
+        | Ignored_char ->
+          mk_constr "Ignored_char" []
+        | Ignored_caml_char ->
+          mk_constr "Ignored_caml_char" []
+        | Ignored_string pad_opt ->
+          mk_constr "Ignored_string" [ mk_int_opt pad_opt ]
+        | Ignored_caml_string pad_opt ->
+          mk_constr "Ignored_caml_string" [ mk_int_opt pad_opt ]
+        | Ignored_int (iconv, pad_opt) ->
+          mk_constr "Ignored_int" [ mk_iconv iconv; mk_int_opt pad_opt ]
+        | Ignored_int32 (iconv, pad_opt) ->
+          mk_constr "Ignored_int32" [ mk_iconv iconv; mk_int_opt pad_opt ]
+        | Ignored_nativeint (iconv, pad_opt) ->
+          mk_constr "Ignored_nativeint" [ mk_iconv iconv; mk_int_opt pad_opt ]
+        | Ignored_int64 (iconv, pad_opt) ->
+          mk_constr "Ignored_int64" [ mk_iconv iconv; mk_int_opt pad_opt ]
+        | Ignored_float (pad_opt, prec_opt) ->
+          mk_constr "Ignored_float" [ mk_int_opt pad_opt; mk_int_opt prec_opt ]
+        | Ignored_bool pad_opt ->
+          mk_constr "Ignored_bool" [ mk_int_opt pad_opt ]
+        | Ignored_format_arg (pad_opt, fmtty) ->
+          mk_constr "Ignored_format_arg" [ mk_int_opt pad_opt; mk_fmtty fmtty ]
+        | Ignored_format_subst (pad_opt, fmtty) ->
+          mk_constr "Ignored_format_subst" [
+            mk_int_opt pad_opt; mk_fmtty fmtty ]
+        | Ignored_reader ->
+          mk_constr "Ignored_reader" []
+        | Ignored_scan_char_set (width_opt, char_set) ->
+          mk_constr "Ignored_scan_char_set" [
+            mk_int_opt width_opt; mk_string char_set ]
+        | Ignored_scan_get_counter counter ->
+          mk_constr "Ignored_scan_get_counter" [
+            mk_counter counter
+          ]
+        | Ignored_scan_next_char ->
+          mk_constr "Ignored_scan_next_char" []
+      and mk_padding : type x y . (x, y) padding -> Parsetree.expression =
+      fun pad -> match pad with
+        | No_padding         -> mk_constr "No_padding" []
+        | Lit_padding (s, w) -> mk_constr "Lit_padding" [ mk_side s; mk_int w ]
+        | Arg_padding s      -> mk_constr "Arg_padding" [ mk_side s ]
+      and mk_precision : type x y . (x, y) precision -> Parsetree.expression =
+      fun prec -> match prec with
+        | No_precision    -> mk_constr "No_precision" []
+        | Lit_precision w -> mk_constr "Lit_precision" [ mk_int w ]
+        | Arg_precision   -> mk_constr "Arg_precision" []
+      and mk_fmt : type a b c d e f .
+          (a, b, c, d, e, f) fmt -> Parsetree.expression =
+      fun fmt -> match fmt with
+        | Char rest ->
+          mk_constr "Char" [ mk_fmt rest ]
+        | Caml_char rest ->
+          mk_constr "Caml_char" [ mk_fmt rest ]
+        | String (pad, rest) ->
+          mk_constr "String" [ mk_padding pad; mk_fmt rest ]
+        | Caml_string (pad, rest) ->
+          mk_constr "Caml_string" [ mk_padding pad; mk_fmt rest ]
+        | Int (iconv, pad, prec, rest) ->
+          mk_constr "Int" [
+            mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
+        | Int32 (iconv, pad, prec, rest) ->
+          mk_constr "Int32" [
+            mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
+        | Nativeint (iconv, pad, prec, rest) ->
+          mk_constr "Nativeint" [
+            mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
+        | Int64 (iconv, pad, prec, rest) ->
+          mk_constr "Int64" [
+            mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
+        | Float (fconv, pad, prec, rest) ->
+          mk_constr "Float" [
+            mk_fconv fconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
+        | Bool (pad, rest) ->
+          mk_constr "Bool" [ mk_padding pad; mk_fmt rest ]
+        | Flush rest ->
+          mk_constr "Flush" [ mk_fmt rest ]
+        | String_literal (s, rest) ->
+          mk_constr "String_literal" [ mk_string s; mk_fmt rest ]
+        | Char_literal (c, rest) ->
+          mk_constr "Char_literal" [ mk_char c; mk_fmt rest ]
+        | Format_arg (pad_opt, fmtty, rest) ->
+          mk_constr "Format_arg" [
+            mk_int_opt pad_opt; mk_fmtty fmtty; mk_fmt rest ]
+        | Format_subst (pad_opt, fmtty, rest) ->
+          mk_constr "Format_subst" [
+            mk_int_opt pad_opt; mk_fmtty fmtty; mk_fmt rest ]
+        | Alpha rest ->
+          mk_constr "Alpha" [ mk_fmt rest ]
+        | Theta rest ->
+          mk_constr "Theta" [ mk_fmt rest ]
+        | Formatting_lit (fmting, rest) ->
+          mk_constr "Formatting_lit" [ mk_formatting_lit fmting; mk_fmt rest ]
+        | Formatting_gen (fmting, rest) ->
+          mk_constr "Formatting_gen" [ mk_formatting_gen fmting; mk_fmt rest ]
+        | Reader rest ->
+          mk_constr "Reader" [ mk_fmt rest ]
+        | Scan_char_set (width_opt, char_set, rest) ->
+          mk_constr "Scan_char_set" [
+            mk_int_opt width_opt; mk_string char_set; mk_fmt rest ]
+        | Scan_get_counter (cnt, rest) ->
+          mk_constr "Scan_get_counter" [ mk_counter cnt; mk_fmt rest ]
+        | Scan_next_char rest ->
+          mk_constr "Scan_next_char" [ mk_fmt rest ]
+        | Ignored_param (ign, rest) ->
+          mk_constr "Ignored_param" [ mk_ignored ign; mk_fmt rest ]
+        | End_of_format ->
+          mk_constr "End_of_format" []
+        | Custom _ ->
+          (* Custom formatters have no syntax so they will never appear
+             in formats parsed from strings. *)
+          assert false
+      in
+      let legacy_behavior = not !Clflags.strict_formats in
+      let Fmt_EBB fmt = fmt_ebb_of_string ~legacy_behavior str in
+      mk_constr "Format" [ mk_fmt fmt; mk_string str ]
+    ))
+  with Failure msg ->
+    raise (Error (loc, env, Invalid_format msg))
+
+and type_label_exp create env loc ty_expected
+          (lid, label, sarg) =
+  (* Here also ty_expected may be at generic_level *)
+  begin_def ();
+  let separate = !Clflags.principal || Env.has_local_constraints env in
+  if separate then (begin_def (); begin_def ());
+  let (vars, ty_arg, ty_res) = instance_label true label in
+  if separate then begin
+    end_def ();
+    (* Generalize label information *)
+    generalize_structure ty_arg;
+    generalize_structure ty_res
+  end;
+  begin try
+    unify env (instance ty_res) (instance ty_expected)
+  with Unify trace ->
+    raise (Error(lid.loc, env, Label_mismatch(lid.txt, trace)))
+  end;
+  (* Instantiate so that we can generalize internal nodes *)
+  let ty_arg = instance ty_arg in
+  if separate then begin
+    end_def ();
+    (* Generalize information merged from ty_expected *)
+    generalize_structure ty_arg
+  end;
+  if label.lbl_private = Private then
+    if create then
+      raise (Error(loc, env, Private_type ty_expected))
+    else
+      raise (Error(lid.loc, env, Private_label(lid.txt, ty_expected)));
+  let arg =
+    let snap = if vars = [] then None else Some (Btype.snapshot ()) in
+    let arg = type_argument env sarg ty_arg (instance ty_arg) in
+    end_def ();
+    try
+      if (vars = []) then arg
+      else begin
+        if maybe_expansive arg then
+          lower_contravariant env arg.exp_type;
+        generalize_and_check_univars env "field value" arg label.lbl_arg vars;
+        {arg with exp_type = instance arg.exp_type}
+      end
+    with exn when maybe_expansive arg -> try
+      (* Try to retype without propagating ty_arg, cf PR#4862 *)
+      Option.iter Btype.backtrack snap;
+      begin_def ();
+      let arg = type_exp env sarg in
+      end_def ();
+      lower_contravariant env arg.exp_type;
+      begin_def ();
+      let arg = {arg with exp_type = instance arg.exp_type} in
+      unify_exp env arg (instance ty_arg);
+      end_def ();
+      generalize_and_check_univars env "field value" arg label.lbl_arg vars;
+      {arg with exp_type = instance arg.exp_type}
+    with Error (_, _, Less_general _) as e -> raise e
+    | _ -> raise exn    (* In case of failure return the first error *)
+  in
+  (lid, label, arg)
+
+and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected =
+  (* ty_expected' may be generic *)
+  let no_labels ty =
+    let ls, tvar = list_labels env ty in
+    not tvar && List.for_all ((=) Nolabel) ls
+  in
+  let may_coerce =
+    if not (is_inferred sarg) then None else
+    let work () =
+      match expand_head env ty_expected' with
+        {desc = Tarrow(Nolabel,_,ty_res0,_); level} ->
+          Some (no_labels ty_res0, level)
+      | _ -> None
+    in
+    (* Need to be careful not to expand local constraints here *)
+    if Env.has_local_constraints env then
+      let snap = Btype.snapshot () in
+      try_finally ~always:(fun () -> Btype.backtrack snap) work
+    else work ()
+  in
+  match may_coerce with
+    Some (safe_expect, lv) ->
+      (* apply optional arguments when expected type is "" *)
+      (* we must be very careful about not breaking the semantics *)
+      if !Clflags.principal then begin_def ();
+      let texp = type_exp env sarg in
+      if !Clflags.principal then begin
+        end_def ();
+        generalize_structure texp.exp_type
+      end;
+      let rec make_args args ty_fun =
+        match (expand_head env ty_fun).desc with
+        | Tarrow (l,ty_arg,ty_fun,_) when is_optional l ->
+            let ty = option_none env (instance ty_arg) sarg.pexp_loc in
+            make_args ((l, Some ty) :: args) ty_fun
+        | Tarrow (l,_,ty_res',_) when l = Nolabel || !Clflags.classic ->
+            List.rev args, ty_fun, no_labels ty_res'
+        | Tvar _ ->  List.rev args, ty_fun, false
+        |  _ -> [], texp.exp_type, false
+      in
+      let args, ty_fun', simple_res = make_args [] texp.exp_type
+      and texp = {texp with exp_type = instance texp.exp_type} in
+      if not (simple_res || safe_expect) then begin
+        unify_exp env texp ty_expected;
+        texp
+      end else begin
+      let warn = !Clflags.principal &&
+        (lv <> generic_level || (repr ty_fun').level <> generic_level)
+      and ty_fun = instance ty_fun' in
+      let ty_arg, ty_res =
+        match expand_head env ty_expected' with
+          {desc = Tarrow(Nolabel,ty_arg,ty_res,_)} -> ty_arg, ty_res
+        | _ -> assert false
+      in
+      unify_exp env {texp with exp_type = ty_fun} ty_expected;
+      if args = [] then texp else
+      (* eta-expand to avoid side effects *)
+      let var_pair name ty =
+        let id = Ident.create_local name in
+        let desc =
+          { val_type = ty; val_kind = Val_reg;
+            val_attributes = [];
+            val_loc = Location.none;
+            val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+          }
+        in
+        let exp_env = Env.add_value id desc env in
+        {pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[];
+         pat_attributes = [];
+         pat_loc = Location.none; pat_env = env},
+        {exp_type = ty; exp_loc = Location.none; exp_env = exp_env;
+         exp_extra = []; exp_attributes = [];
+         exp_desc =
+         Texp_ident(Path.Pident id, mknoloc (Longident.Lident name), desc)}
+      in
+      let eta_pat, eta_var = var_pair "eta" ty_arg in
+      let func texp =
+        let e =
+          {texp with exp_type = ty_res; exp_desc =
+           Texp_apply
+             (texp,
+              args @ [Nolabel, Some eta_var])}
+        in
+        let cases = [case eta_pat e] in
+        let param = name_cases "param" cases in
+        { texp with exp_type = ty_fun; exp_desc =
+          Texp_function { arg_label = Nolabel; param; cases;
+            partial = Total; } }
+      in
+      Location.prerr_warning texp.exp_loc
+        (Warnings.Eliminated_optional_arguments
+           (List.map (fun (l, _) -> Printtyp.string_of_label l) args));
+      if warn then Location.prerr_warning texp.exp_loc
+          (Warnings.Non_principal_labels "eliminated optional argument");
+      (* let-expand to have side effects *)
+      let let_pat, let_var = var_pair "arg" texp.exp_type in
+      re { texp with exp_type = ty_fun; exp_desc =
+           Texp_let (Nonrecursive,
+                     [{vb_pat=let_pat; vb_expr=texp; vb_attributes=[];
+                       vb_loc=Location.none;
+                      }],
+                     func let_var) }
+      end
+  | None ->
+      let texp = type_expect ?recarg env sarg
+        (mk_expected ?explanation ty_expected') in
+      unify_exp env texp ty_expected;
+      texp
+
+and type_application env funct sargs =
+  (* funct.exp_type may be generic *)
+  let result_type omitted ty_fun =
+    List.fold_left
+      (fun ty_fun (l,ty,lv) -> newty2 lv (Tarrow(l,ty,ty_fun,Cok)))
+      ty_fun omitted
+  in
+  let has_label l ty_fun =
+    let ls, tvar = list_labels env ty_fun in
+    tvar || List.mem l ls
+  in
+  let eliminated_optional_arguments = ref [] in
+  let omitted_parameters = ref [] in
+  let type_unknown_arg (ty_fun, typed_args) (lbl, sarg) =
+    let (ty_arg, ty_res) =
+      let ty_fun = expand_head env ty_fun in
+      match ty_fun.desc with
+      | Tvar _ ->
+          let t1 = newvar () and t2 = newvar () in
+          if ty_fun.level >= t1.level &&
+             not (is_prim ~name:"%identity" funct)
+          then
+            Location.prerr_warning sarg.pexp_loc
+              Warnings.Ignored_extra_argument;
+          unify env ty_fun (newty (Tarrow(lbl,t1,t2,Clink(ref Cunknown))));
+          (t1, t2)
+      | Tarrow (l,t1,t2,_) when l = lbl
+        || !Clflags.classic && lbl = Nolabel && not (is_optional l) ->
+          (t1, t2)
+      | td ->
+          let ty_fun = match td with Tarrow _ -> newty td | _ -> ty_fun in
+          let ty_res =
+            result_type (!omitted_parameters @ !eliminated_optional_arguments)
+              ty_fun
+          in
+          match ty_res.desc with
+          | Tarrow _ ->
+              if !Clflags.classic || not (has_label lbl ty_fun) then
+                raise (Error(sarg.pexp_loc, env,
+                             Apply_wrong_label(lbl, ty_res, false)))
+              else
+                raise (Error(funct.exp_loc, env, Incoherent_label_order))
+          | _ ->
+              raise(Error(funct.exp_loc, env, Apply_non_function
+                            (expand_head env funct.exp_type)))
+    in
+    let arg () =
+      let arg = type_expect env sarg (mk_expected ty_arg) in
+      if is_optional lbl then
+        unify_exp env arg (type_option(newvar()));
+      arg
+    in
+    (ty_res, (lbl, Some arg) :: typed_args)
+  in
+  let ignore_labels =
+    !Clflags.classic ||
+    begin
+      let ls, tvar = list_labels env funct.exp_type in
+      not tvar &&
+      let labels = List.filter (fun l -> not (is_optional l)) ls in
+      List.length labels = List.length sargs &&
+      List.for_all (fun (l,_) -> l = Nolabel) sargs &&
+      List.exists (fun l -> l <> Nolabel) labels &&
+      (Location.prerr_warning
+         funct.exp_loc
+         (Warnings.Labels_omitted
+            (List.map Printtyp.string_of_label
+                      (List.filter ((<>) Nolabel) labels)));
+       true)
+    end
+  in
+  let warned = ref false in
+  let rec type_args args ty_fun ty_fun0 sargs =
+    match expand_head env ty_fun, expand_head env ty_fun0 with
+    | {desc=Tarrow (l, ty, ty_fun, com); level=lv} as ty_fun',
+      {desc=Tarrow (_, ty0, ty_fun0, _)}
+      when sargs <> [] && commu_repr com = Cok ->
+        let may_warn loc w =
+          if not !warned && !Clflags.principal && lv <> generic_level
+          then begin
+            warned := true;
+            Location.prerr_warning loc w
+          end
+        in
+        let name = label_name l
+        and optional = is_optional l in
+        let use_arg sarg l' =
+          Some (
+            if not optional || is_optional l' then
+              (fun () -> type_argument env sarg ty ty0)
+            else begin
+              may_warn sarg.pexp_loc
+                (Warnings.Not_principal "using an optional argument here");
+              (fun () -> option_some env (type_argument env sarg
+                                            (extract_option_type env ty)
+                                            (extract_option_type env ty0)))
+            end
+          )
+        in
+        let eliminate_optional_arg () =
+          may_warn funct.exp_loc
+            (Warnings.Non_principal_labels "eliminated optional argument");
+          eliminated_optional_arguments :=
+            (l,ty,lv) :: !eliminated_optional_arguments;
+          Some (fun () -> option_none env (instance ty) Location.none)
+        in
+        let remaining_sargs, arg =
+          if ignore_labels then begin
+            (* No reordering is allowed, process arguments in order *)
+            match sargs with
+            | [] -> assert false
+            | (l', sarg) :: remaining_sargs ->
+                if name = label_name l' || (not optional && l' = Nolabel) then
+                  (remaining_sargs, use_arg sarg l')
+                else if
+                  optional &&
+                  not (List.exists (fun (l, _) -> name = label_name l)
+                         remaining_sargs) &&
+                  List.exists (function (Nolabel, _) -> true | _ -> false)
+                    sargs
+                then
+                  (sargs, eliminate_optional_arg ())
+                else
+                  raise(Error(sarg.pexp_loc, env,
+                              Apply_wrong_label(l', ty_fun', optional)))
+          end else
+            (* Arguments can be commuted, try to fetch the argument
+               corresponding to the first parameter. *)
+            match extract_label name sargs with
+            | Some (l', sarg, commuted, remaining_sargs) ->
+                if commuted then begin
+                  may_warn sarg.pexp_loc
+                    (Warnings.Not_principal "commuting this argument")
+                end;
+                if not optional && is_optional l' then
+                  Location.prerr_warning sarg.pexp_loc
+                    (Warnings.Nonoptional_label (Printtyp.string_of_label l));
+                remaining_sargs, use_arg sarg l'
+            | None ->
+                sargs,
+                if optional && List.mem_assoc Nolabel sargs then
+                  eliminate_optional_arg ()
+                else begin
+                  (* No argument was given for this parameter, we abstract over
+                     it. *)
+                  may_warn funct.exp_loc
+                    (Warnings.Non_principal_labels "commuted an argument");
+                  omitted_parameters := (l,ty,lv) :: !omitted_parameters;
+                  None
+                end
+        in
+        type_args ((l,arg)::args) ty_fun ty_fun0 remaining_sargs
+    | _ ->
+        (* We're not looking at a *known* function type anymore, or there are no
+           arguments left. *)
+        let ty_fun, typed_args =
+          List.fold_left type_unknown_arg (ty_fun0, args) sargs
+        in
+        let args =
+          (* Force typing of arguments.
+             Careful: the order matters here. Using [List.rev_map] would be
+             incorrect. *)
+          List.map
+            (function
+              | l, None -> l, None
+              | l, Some f -> l, Some (f ()))
+            (List.rev typed_args)
+        in
+        let result_ty = instance (result_type !omitted_parameters ty_fun) in
+        args, result_ty
+  in
+  let is_ignore funct =
+    is_prim ~name:"%ignore" funct &&
+    (try ignore (filter_arrow env (instance funct.exp_type) Nolabel); true
+     with Unify _ -> false)
+  in
+  match sargs with
+  | (* Special case for ignore: avoid discarding warning *)
+    [Nolabel, sarg] when is_ignore funct ->
+      let ty_arg, ty_res = filter_arrow env (instance funct.exp_type) Nolabel in
+      let exp = type_expect env sarg (mk_expected ty_arg) in
+      check_partial_application false exp;
+      ([Nolabel, Some exp], ty_res)
+  | _ ->
+    let ty = funct.exp_type in
+    type_args [] ty (instance ty) sargs
+
+and type_construct env loc lid sarg ty_expected_explained attrs =
+  let { ty = ty_expected; explanation } = ty_expected_explained in
+  let expected_type =
+    try
+      let (p0, p,_) = extract_concrete_variant env ty_expected in
+      let principal =
+        (repr ty_expected).level = generic_level || not !Clflags.principal
+      in
+      Some(p0, p, principal)
+    with Not_found -> None
+  in
+  let constrs =
+    Env.lookup_all_constructors ~loc:lid.loc Env.Positive lid.txt env
+  in
+  let constr =
+    wrap_disambiguate "This variant expression is expected to have"
+      ty_expected_explained
+      (Constructor.disambiguate Env.Positive lid env expected_type) constrs
+  in
+  let sargs =
+    match sarg with
+      None -> []
+    | Some {pexp_desc = Pexp_tuple sel} when
+        constr.cstr_arity > 1 || Builtin_attributes.explicit_arity attrs
+      -> sel
+    | Some se -> [se] in
+  if List.length sargs <> constr.cstr_arity then
+    raise(Error(loc, env, Constructor_arity_mismatch
+                            (lid.txt, constr.cstr_arity, List.length sargs)));
+  let separate = !Clflags.principal || Env.has_local_constraints env in
+  if separate then (begin_def (); begin_def ());
+  let (ty_args, ty_res, _) = instance_constructor constr in
+  let texp =
+    re {
+      exp_desc = Texp_construct(lid, constr, []);
+      exp_loc = loc; exp_extra = [];
+      exp_type = ty_res;
+      exp_attributes = attrs;
+      exp_env = env } in
+  if separate then begin
+    end_def ();
+    generalize_structure ty_res;
+    with_explanation explanation (fun () ->
+      unify_exp env {texp with exp_type = instance ty_res}
+        (instance ty_expected));
+    end_def ();
+    List.iter generalize_structure ty_args;
+    generalize_structure ty_res;
+  end;
+  let ty_args0, ty_res =
+    match instance_list (ty_res :: ty_args) with
+      t :: tl -> tl, t
+    | _ -> assert false
+  in
+  let texp = {texp with exp_type = ty_res} in
+  if not separate then unify_exp env texp (instance ty_expected);
+  let recarg =
+    match constr.cstr_inlined with
+    | None -> Rejected
+    | Some _ ->
+      begin match sargs with
+      | [{pexp_desc =
+            Pexp_ident _ |
+            Pexp_record (_, (Some {pexp_desc = Pexp_ident _}| None))}] ->
+        Required
+      | _ ->
+        raise (Error(loc, env, Inlined_record_expected))
+      end
+  in
+  let args =
+    List.map2 (fun e (t,t0) -> type_argument ~recarg env e t t0) sargs
+      (List.combine ty_args ty_args0) in
+  if constr.cstr_private = Private then
+    begin match constr.cstr_tag with
+    | Cstr_extension _ ->
+        raise(Error(loc, env, Private_constructor (constr, ty_res)))
+    | Cstr_constant _ | Cstr_block _ | Cstr_unboxed ->
+        raise (Error(loc, env, Private_type ty_res));
+    end;
+  (* NOTE: shouldn't we call "re" on this final expression? -- AF *)
+  { texp with
+    exp_desc = Texp_construct(lid, constr, args) }
+
+(* Typing of statements (expressions whose values are discarded) *)
+
+and type_statement ?explanation env sexp =
+  begin_def();
+  let exp = type_exp env sexp in
+  end_def();
+  let ty = expand_head env exp.exp_type and tv = newvar() in
+  if is_Tvar ty && ty.level > tv.level then
+    Location.prerr_warning
+      (final_subexpression exp).exp_loc
+      Warnings.Nonreturning_statement;
+  if !Clflags.strict_sequence then
+    let expected_ty = instance Predef.type_unit in
+    with_explanation explanation (fun () ->
+      unify_exp env exp expected_ty);
+    exp
+  else begin
+    check_partial_application true exp;
+    unify_var env tv ty;
+    exp
+  end
+
+and type_unpacks ?(in_function : (Location.t * type_expr) option)
+    env (unpacks : to_unpack list) sbody expected_ty =
+  let ty = newvar() in
+  (* remember original level *)
+  let extended_env, tunpacks =
+    List.fold_left (fun (env, tunpacks) unpack ->
+      begin_def ();
+      let context = Typetexp.narrow () in
+      let modl =
+        !type_module env
+          Ast_helper.(
+            Mod.unpack ~loc:unpack.tu_loc
+              (Exp.ident ~loc:unpack.tu_name.loc
+                 (mkloc (Longident.Lident unpack.tu_name.txt)
+                    unpack.tu_name.loc)))
+      in
+      Mtype.lower_nongen ty.level modl.mod_type;
+      let pres =
+        match modl.mod_type with
+        | Mty_alias _ -> Mp_absent
+        | _ -> Mp_present
+      in
+      let scope = create_scope () in
+      let md =
+        { md_type = modl.mod_type; md_attributes = [];
+          md_loc = unpack.tu_name.loc;
+          md_uid = unpack.tu_uid; }
+      in
+      let (id, env) =
+        Env.enter_module_declaration ~scope unpack.tu_name.txt pres md env
+      in
+      Typetexp.widen context;
+      env, (id, unpack.tu_name, pres, modl) :: tunpacks
+    ) (env, []) unpacks
+  in
+  (* ideally, we should catch Expr_type_clash errors
+     in type_expect triggered by escaping identifiers from the local module
+     and refine them into Scoping_let_module errors
+  *)
+  let body = type_expect ?in_function extended_env sbody expected_ty in
+  let exp_loc = { body.exp_loc with loc_ghost = true } in
+  let exp_attributes = [Ast_helper.Attr.mk (mknoloc "#modulepat") (PStr [])] in
+  List.fold_left (fun body (id, name, pres, modl) ->
+    (* go back to parent level *)
+    end_def ();
+    Ctype.unify_var extended_env ty body.exp_type;
+    re {
+      exp_desc = Texp_letmodule(Some id, { name with txt = Some name.txt },
+                                pres, modl, body);
+      exp_loc;
+      exp_attributes;
+      exp_extra = [];
+      exp_type = ty;
+      exp_env = env }
+  ) body tunpacks
+
+(* Typing of match cases *)
+and type_cases
+    : type k . k pattern_category ->
+           ?in_function:_ -> _ -> _ -> _ -> _ -> _ -> Parsetree.case list ->
+           k case list * partial
+  = fun category ?in_function env
+        ty_arg ty_res_explained partial_flag loc caselist ->
+  (* ty_arg is _fully_ generalized *)
+  let { ty = ty_res; explanation } = ty_res_explained in
+  let patterns = List.map (fun {pc_lhs=p} -> p) caselist in
+  let contains_polyvars = List.exists contains_polymorphic_variant patterns in
+  let erase_either = contains_polyvars && contains_variant_either ty_arg in
+  let may_contain_gadts = List.exists may_contain_gadts patterns in
+  let ty_arg =
+    if (may_contain_gadts || erase_either) && not !Clflags.principal
+    then correct_levels ty_arg else ty_arg
+  in
+  let rec is_var spat =
+    match spat.ppat_desc with
+      Ppat_any | Ppat_var _ -> true
+    | Ppat_alias (spat, _) -> is_var spat
+    | _ -> false in
+  let needs_exhaust_check =
+    match caselist with
+      [{pc_rhs = {pexp_desc = Pexp_unreachable}}] -> true
+    | [{pc_lhs}] when is_var pc_lhs -> false
+    | _ -> true
+  in
+  let outer_level = get_current_level () in
+  let lev =
+    if may_contain_gadts then begin_def ();
+    get_current_level ()
+  in
+  let take_partial_instance =
+    if erase_either
+    then Some false else None
+  in
+  begin_def (); (* propagation of the argument *)
+  let pattern_force = ref [] in
+(*  Format.printf "@[%i %i@ %a@]@." lev (get_current_level())
+    Printtyp.raw_type_expr ty_arg; *)
+  let half_typed_cases =
+    List.map
+      (fun ({pc_lhs; pc_guard = _; pc_rhs = _} as case) ->
+        if !Clflags.principal then begin_def (); (* propagation of pattern *)
+        begin_def ();
+        let ty_arg = instance ?partial:take_partial_instance ty_arg in
+        end_def ();
+        generalize_structure ty_arg;
+        let (pat, ext_env, force, pvs, unpacks) =
+          type_pattern category ~lev env pc_lhs ty_arg
+        in
+        pattern_force := force @ !pattern_force;
+        let pat =
+          if !Clflags.principal then begin
+            end_def ();
+            iter_pattern_variables_type generalize_structure pvs;
+            { pat with pat_type = instance pat.pat_type }
+          end else pat
+        in
+        (* Ensure that no ambivalent pattern type escapes its branch *)
+        check_scope_escape pat.pat_loc env outer_level ty_arg;
+        { typed_pat = pat;
+          pat_type_for_unif = ty_arg;
+          untyped_case = case;
+          branch_env = ext_env;
+          pat_vars = pvs;
+          unpacks;
+          contains_gadt = contains_gadt (as_comp_pattern category pat); }
+        )
+      caselist in
+  let patl = List.map (fun { typed_pat; _ } -> typed_pat) half_typed_cases in
+  let does_contain_gadt =
+    List.exists (fun { contains_gadt; _ } -> contains_gadt) half_typed_cases
+  in
+  let ty_res, do_copy_types =
+    if does_contain_gadt && not !Clflags.principal then
+      correct_levels ty_res, Env.make_copy_of_types env
+    else ty_res, (fun env -> env)
+  in
+  (* Unify all cases (delayed to keep it order-free) *)
+  let ty_arg' = newvar () in
+  let unify_pats ty =
+    List.iter (fun { typed_pat = pat; pat_type_for_unif = pat_ty; _ } ->
+      unify_pat_types pat.pat_loc (ref env) pat_ty ty
+    ) half_typed_cases
+  in
+  unify_pats ty_arg';
+  (* Check for polymorphic variants to close *)
+  if List.exists has_variants patl then begin
+      Parmatch.pressure_variants_in_computation_pattern env
+        (List.map (as_comp_pattern category) patl);
+      List.iter finalize_variants patl
+  end;
+  (* `Contaminating' unifications start here *)
+  List.iter (fun f -> f()) !pattern_force;
+  (* Post-processing and generalization *)
+  if take_partial_instance <> None then unify_pats (instance ty_arg);
+  List.iter (fun { pat_vars; _ } ->
+    iter_pattern_variables_type (fun t -> unify_var env (newvar()) t) pat_vars
+  ) half_typed_cases;
+  end_def ();
+  generalize ty_arg';
+  List.iter (fun { pat_vars; _ } ->
+    iter_pattern_variables_type generalize pat_vars
+  ) half_typed_cases;
+  (* type bodies *)
+  let in_function = if List.length caselist = 1 then in_function else None in
+  let cases =
+    List.map
+      (fun { typed_pat = pat; branch_env = ext_env; pat_vars = pvs; unpacks;
+             untyped_case = {pc_lhs = _; pc_guard; pc_rhs};
+             contains_gadt; _ }  ->
+        let ext_env =
+          if contains_gadt then
+            do_copy_types ext_env
+          else
+            ext_env
+        in
+        let ext_env =
+          add_pattern_variables ext_env pvs
+            ~check:(fun s -> Warnings.Unused_var_strict s)
+            ~check_as:(fun s -> Warnings.Unused_var s)
+        in
+        let unpacks =
+          List.map (fun (name, loc) ->
+            {tu_name = name; tu_loc = loc;
+             tu_uid = Uid.mk ~current_unit:(Env.get_unit_name ())}
+          ) unpacks
+        in
+        let ty_res' =
+          if !Clflags.principal then begin
+            begin_def ();
+            let ty = instance ~partial:true ty_res in
+            end_def ();
+            generalize_structure ty; ty
+          end
+          else if contains_gadt then
+            (* allow propagation from preceding branches *)
+            correct_levels ty_res
+          else ty_res in
+        let guard =
+          match pc_guard with
+          | None -> None
+          | Some scond ->
+              Some
+                (type_unpacks ext_env unpacks scond
+                   (mk_expected ~explanation:When_guard Predef.type_bool))
+        in
+        let exp =
+          type_unpacks ?in_function ext_env
+            unpacks pc_rhs (mk_expected ?explanation ty_res')
+        in
+        {
+         c_lhs = pat;
+         c_guard = guard;
+         c_rhs = {exp with exp_type = instance ty_res'}
+        }
+      )
+      half_typed_cases
+  in
+  if !Clflags.principal || does_contain_gadt then begin
+    let ty_res' = instance ty_res in
+    List.iter (fun c -> unify_exp env c.c_rhs ty_res') cases
+  end;
+  let do_init = may_contain_gadts || needs_exhaust_check in
+  let ty_arg_check =
+    if do_init then
+      (* Hack: use for_saving to copy variables too *)
+      Subst.type_expr (Subst.for_saving Subst.identity) ty_arg'
+    else ty_arg'
+  in
+  let val_cases, exn_cases =
+    match category with
+      | Value -> (cases : value case list), []
+      | Computation -> split_cases env cases in
+  if val_cases = [] && exn_cases <> [] then
+    raise (Error (loc, env, No_value_clauses));
+  let partial =
+    if partial_flag then
+      check_partial ~lev env ty_arg_check loc val_cases
+    else
+      Partial
+  in
+  let unused_check delayed =
+    List.iter (fun { typed_pat; branch_env; _ } ->
+      check_absent_variant branch_env (as_comp_pattern category typed_pat)
+    ) half_typed_cases;
+    if delayed then (begin_def (); init_def lev);
+    check_unused ~lev env ty_arg_check val_cases ;
+    check_unused ~lev env Predef.type_exn exn_cases ;
+    if delayed then end_def ();
+    Parmatch.check_ambiguous_bindings val_cases ;
+    Parmatch.check_ambiguous_bindings exn_cases
+  in
+  if contains_polyvars then
+    add_delayed_check (fun () -> unused_check true)
+  else
+    (* Check for unused cases, do not delay because of gadts *)
+    unused_check false;
+  if may_contain_gadts then begin
+    end_def ();
+    (* Ensure that existential types do not escape *)
+    unify_exp_types loc env (instance ty_res) (newvar ()) ;
+  end;
+  cases, partial
+
+(* Typing of let bindings *)
+
+and type_let
+    ?(check = fun s -> Warnings.Unused_var s)
+    ?(check_strict = fun s -> Warnings.Unused_var_strict s)
+    existential_context
+    env rec_flag spat_sexp_list allow =
+  let open Ast_helper in
+  begin_def();
+  if !Clflags.principal then begin_def ();
+
+  let is_fake_let =
+    match spat_sexp_list with
+    | [{pvb_expr={pexp_desc=Pexp_match(
+           {pexp_desc=Pexp_ident({ txt = Longident.Lident "*opt*"})},_)}}] ->
+        true (* the fake let-declaration introduced by fun ?(x = e) -> ... *)
+    | _ ->
+        false
+  in
+  let check = if is_fake_let then check_strict else check in
+
+  let spatl =
+    List.map
+      (fun {pvb_pat=spat; pvb_expr=sexp; pvb_attributes=attrs} ->
+        attrs,
+        match spat.ppat_desc, sexp.pexp_desc with
+          (Ppat_any | Ppat_constraint _), _ -> spat
+        | _, Pexp_coerce (_, _, sty)
+        | _, Pexp_constraint (_, sty) when !Clflags.principal ->
+            (* propagate type annotation to pattern,
+               to allow it to be generalized in -principal mode *)
+            Pat.constraint_
+              ~loc:{spat.ppat_loc with Location.loc_ghost=true}
+              spat
+              sty
+        | _ -> spat)
+      spat_sexp_list in
+  let nvs = List.map (fun _ -> newvar ()) spatl in
+  let (pat_list, new_env, force, pvs, unpacks) =
+    type_pattern_list Value existential_context env spatl nvs allow in
+  let attrs_list = List.map fst spatl in
+  let is_recursive = (rec_flag = Recursive) in
+  (* If recursive, first unify with an approximation of the expression *)
+  if is_recursive then
+    List.iter2
+      (fun pat binding ->
+        let pat =
+          match pat.pat_type.desc with
+          | Tpoly (ty, tl) ->
+              {pat with pat_type =
+               snd (instance_poly ~keep_names:true false tl ty)}
+          | _ -> pat
+        in unify_pat (ref env) pat (type_approx env binding.pvb_expr))
+      pat_list spat_sexp_list;
+  (* Polymorphic variant processing *)
+  List.iter
+    (fun pat ->
+      if has_variants pat then begin
+        Parmatch.pressure_variants env [pat];
+        finalize_variants pat
+      end)
+    pat_list;
+  (* Generalize the structure *)
+  let pat_list =
+    if !Clflags.principal then begin
+      end_def ();
+      iter_pattern_variables_type generalize_structure pvs;
+      List.map (fun pat ->
+        generalize_structure pat.pat_type;
+        {pat with pat_type = instance pat.pat_type}
+      ) pat_list
+    end else
+      pat_list
+  in
+  (* Only bind pattern variables after generalizing *)
+  List.iter (fun f -> f()) force;
+  let sexp_is_fun { pvb_expr = sexp; _ } =
+    match sexp.pexp_desc with
+    | Pexp_fun _ | Pexp_function _ -> true
+    | _ -> false
+  in
+  let exp_env =
+    if is_recursive then new_env
+    else if List.for_all sexp_is_fun spat_sexp_list
+    then begin
+      (* Add ghost bindings to help detecting missing "rec" keywords.
+
+         We only add those if the body of the definition is obviously a
+         function. The rationale is that, in other cases, the hint is probably
+         wrong (and the user is using "advanced features" anyway (lazy,
+         recursive values...)).
+
+         [pvb_loc] (below) is the location of the first let-binding (in case of
+         a let .. and ..), and is where the missing "rec" hint suggests to add a
+         "rec" keyword. *)
+      match spat_sexp_list with
+      | {pvb_loc; _} :: _ -> maybe_add_pattern_variables_ghost pvb_loc env pvs
+      | _ -> assert false
+    end
+    else env in
+
+  let current_slot = ref None in
+  let rec_needed = ref false in
+  let warn_about_unused_bindings =
+    List.exists
+      (fun attrs ->
+         Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () ->
+           Warnings.is_active (check "") || Warnings.is_active (check_strict "")
+           || (is_recursive && (Warnings.is_active Warnings.Unused_rec_flag))))
+      attrs_list
+  in
+  let pat_slot_list =
+    (* Algorithm to detect unused declarations in recursive bindings:
+       - During type checking of the definitions, we capture the 'value_used'
+         events on the bound identifiers and record them in a slot corresponding
+         to the current definition (!current_slot).
+         In effect, this creates a dependency graph between definitions.
+
+       - After type checking the definition (!current_slot = None),
+         when one of the bound identifier is effectively used, we trigger
+         again all the events recorded in the corresponding slot.
+         The effect is to traverse the transitive closure of the graph created
+         in the first step.
+
+       We also keep track of whether *all* variables in a given pattern
+       are unused. If this is the case, for local declarations, the issued
+       warning is 26, not 27.
+     *)
+    List.map2
+      (fun attrs pat ->
+         Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () ->
+           if not warn_about_unused_bindings then pat, None
+           else
+             let some_used = ref false in
+             (* has one of the identifier of this pattern been used? *)
+             let slot = ref [] in
+             List.iter
+               (fun id ->
+                  let vd = Env.find_value (Path.Pident id) new_env in
+                  (* note: Env.find_value does not trigger the value_used
+                           event *)
+                  let name = Ident.name id in
+                  let used = ref false in
+                  if not (name = "" || name.[0] = '_' || name.[0] = '#') then
+                    add_delayed_check
+                      (fun () ->
+                         if not !used then
+                           Location.prerr_warning vd.Types.val_loc
+                             ((if !some_used then check_strict else check) name)
+                      );
+                  Env.set_value_used_callback
+                    vd
+                    (fun () ->
+                       match !current_slot with
+                       | Some slot ->
+                         slot := vd.val_uid :: !slot; rec_needed := true
+                       | None ->
+                         List.iter Env.mark_value_used (get_ref slot);
+                         used := true;
+                         some_used := true
+                    )
+               )
+               (Typedtree.pat_bound_idents pat);
+             pat, Some slot
+         ))
+      attrs_list
+      pat_list
+  in
+  let exp_list =
+    List.map2
+      (fun {pvb_expr=sexp; pvb_attributes; _} (pat, slot) ->
+        if is_recursive then current_slot := slot;
+        match pat.pat_type.desc with
+        | Tpoly (ty, tl) ->
+            if !Clflags.principal then begin_def ();
+            let vars, ty' = instance_poly ~keep_names:true true tl ty in
+            if !Clflags.principal then begin
+              end_def ();
+              generalize_structure ty'
+            end;
+            let exp =
+              Builtin_attributes.warning_scope pvb_attributes (fun () ->
+                if rec_flag = Recursive then
+                  type_unpacks exp_env unpacks sexp (mk_expected ty')
+                else
+                  type_expect exp_env sexp (mk_expected ty')
+              )
+            in
+            exp, Some vars
+        | _ ->
+            let exp =
+              Builtin_attributes.warning_scope pvb_attributes (fun () ->
+                  if rec_flag = Recursive then
+                    type_unpacks exp_env unpacks sexp (mk_expected pat.pat_type)
+                  else
+                    type_expect exp_env sexp (mk_expected pat.pat_type))
+            in
+            exp, None)
+      spat_sexp_list pat_slot_list in
+  current_slot := None;
+  if is_recursive && not !rec_needed then begin
+    let {pvb_pat; pvb_attributes} = List.hd spat_sexp_list in
+    (* See PR#6677 *)
+    Builtin_attributes.warning_scope ~ppwarning:false pvb_attributes
+      (fun () ->
+         Location.prerr_warning pvb_pat.ppat_loc Warnings.Unused_rec_flag
+      )
+  end;
+  List.iter2
+    (fun pat (attrs, exp) ->
+       Builtin_attributes.warning_scope ~ppwarning:false attrs
+         (fun () ->
+            ignore(check_partial env pat.pat_type pat.pat_loc
+                     [case pat exp])
+         )
+    )
+    pat_list
+    (List.map2 (fun (attrs, _) (e, _) -> attrs, e) spatl exp_list);
+  let pvs = List.map (fun pv -> { pv with pv_type = instance pv.pv_type}) pvs in
+  end_def();
+  List.iter2
+    (fun pat (exp, _) ->
+       if maybe_expansive exp then
+         lower_contravariant env pat.pat_type)
+    pat_list exp_list;
+  iter_pattern_variables_type generalize pvs;
+  List.iter2
+    (fun pat (exp, vars) ->
+       match vars with
+       | None ->
+         (* We generalize expressions even if they are not bound to a variable
+            and do not have an expliclit polymorphic type annotation.  This is
+            not needed in general, however those types may be shown by the
+            interactive toplevel, for example:
+            {[
+              let _ = Array.get;;
+              - : 'a array -> int -> 'a = <fun>
+            ]}
+            so we do it anyway. *)
+         generalize exp.exp_type
+       | Some vars ->
+           if maybe_expansive exp then
+             lower_contravariant env exp.exp_type;
+           generalize_and_check_univars env "definition" exp pat.pat_type vars)
+    pat_list exp_list;
+  let l = List.combine pat_list exp_list in
+  let l =
+    List.map2
+      (fun (p, (e, _)) pvb ->
+        {vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes;
+         vb_loc=pvb.pvb_loc;
+        })
+      l spat_sexp_list
+  in
+  if is_recursive then
+    List.iter
+      (fun {vb_pat=pat} -> match pat.pat_desc with
+           Tpat_var _ -> ()
+         | Tpat_alias ({pat_desc=Tpat_any}, _, _) -> ()
+         | _ -> raise(Error(pat.pat_loc, env, Illegal_letrec_pat)))
+      l;
+  List.iter (function
+      | {vb_pat = {pat_desc = Tpat_any; pat_extra; _}; vb_expr; _} ->
+          if not (List.exists (function (Tpat_constraint _, _, _) -> true
+                                      | _ -> false) pat_extra) then
+            check_partial_application false vb_expr
+      | _ -> ()) l;
+  (l, new_env, unpacks)
+
+and type_andops env sarg sands expected_ty =
+  let rec loop env let_sarg rev_sands expected_ty =
+    match rev_sands with
+    | [] -> type_expect env let_sarg (mk_expected expected_ty), []
+    | { pbop_op = sop; pbop_exp = sexp; pbop_loc = loc; _ } :: rest ->
+        if !Clflags.principal then begin_def ();
+        let op_path, op_desc = type_binding_op_ident env sop in
+        let op_type = instance op_desc.val_type in
+        let ty_arg = newvar () in
+        let ty_rest = newvar () in
+        let ty_result = newvar() in
+        let ty_rest_fun = newty (Tarrow(Nolabel, ty_arg, ty_result, Cok)) in
+        let ty_op = newty (Tarrow(Nolabel, ty_rest, ty_rest_fun, Cok)) in
+        begin try
+          unify env op_type ty_op
+        with Unify trace ->
+          raise(Error(sop.loc, env, Andop_type_clash(sop.txt, trace)))
+        end;
+        if !Clflags.principal then begin
+          end_def ();
+          generalize_structure ty_rest;
+          generalize_structure ty_arg;
+          generalize_structure ty_result
+        end;
+        let let_arg, rest = loop env let_sarg rest ty_rest in
+        let exp = type_expect env sexp (mk_expected ty_arg) in
+        begin try
+          unify env (instance ty_result) (instance expected_ty)
+        with Unify trace ->
+          raise(Error(loc, env, Bindings_type_clash(trace)))
+        end;
+        let andop =
+          { bop_op_name = sop;
+            bop_op_path = op_path;
+            bop_op_val = op_desc;
+            bop_op_type = op_type;
+            bop_exp = exp;
+            bop_loc = loc }
+        in
+        let_arg, andop :: rest
+  in
+  let let_arg, rev_ands = loop env sarg (List.rev sands) expected_ty in
+  let_arg, List.rev rev_ands
+
+(* Typing of toplevel bindings *)
+
+let type_binding env rec_flag spat_sexp_list =
+  Typetexp.reset_type_variables();
+  let (pat_exp_list, new_env, _unpacks) =
+    type_let
+      ~check:(fun s -> Warnings.Unused_value_declaration s)
+      ~check_strict:(fun s -> Warnings.Unused_value_declaration s)
+      At_toplevel
+      env rec_flag spat_sexp_list false
+  in
+  (pat_exp_list, new_env)
+
+let type_let existential_ctx env rec_flag spat_sexp_list =
+  let (pat_exp_list, new_env, _unpacks) =
+    type_let existential_ctx env rec_flag spat_sexp_list false in
+  (pat_exp_list, new_env)
+
+(* Typing of toplevel expressions *)
+
+let type_expression env sexp =
+  Typetexp.reset_type_variables();
+  begin_def();
+  let exp = type_exp env sexp in
+  end_def();
+  if maybe_expansive exp then lower_contravariant env exp.exp_type;
+  generalize exp.exp_type;
+  match sexp.pexp_desc with
+    Pexp_ident lid ->
+      let loc = sexp.pexp_loc in
+      (* Special case for keeping type variables when looking-up a variable *)
+      let (_path, desc) = Env.lookup_value ~use:false ~loc lid.txt env in
+      {exp with exp_type = desc.val_type}
+  | _ -> exp
+
+(* Error report *)
+
+let spellcheck ppf unbound_name valid_names =
+  Misc.did_you_mean ppf (fun () ->
+    Misc.spellcheck valid_names unbound_name
+  )
+
+let spellcheck_idents ppf unbound valid_idents =
+  spellcheck ppf (Ident.name unbound) (List.map Ident.name valid_idents)
+
+open Format
+
+let longident = Printtyp.longident
+
+(* Returns the first diff of the trace *)
+let type_clash_of_trace trace =
+  Errortrace.(explain trace (fun ~prev:_ -> function
+    | Diff diff -> Some diff
+    | _ -> None
+  ))
+
+(* Hint on type error on integer literals
+   To avoid confusion, it is disabled on float literals
+   and when the expected type is `int` *)
+let report_literal_type_constraint expected_type const =
+  let const_str = match const with
+    | Const_int n -> Some (Int.to_string n)
+    | Const_int32 n -> Some (Int32.to_string n)
+    | Const_int64 n -> Some (Int64.to_string n)
+    | Const_nativeint n -> Some (Nativeint.to_string n)
+    | _ -> None
+  in
+  let suffix =
+    if Path.same expected_type Predef.path_int32 then
+      Some 'l'
+    else if Path.same expected_type Predef.path_int64 then
+      Some 'L'
+    else if Path.same expected_type Predef.path_nativeint then
+      Some 'n'
+    else if Path.same expected_type Predef.path_float then
+      Some '.'
+    else None
+  in
+  match const_str, suffix with
+  | Some c, Some s -> [ Location.msg "@[Hint: Did you mean `%s%c'?@]" c s ]
+  | _, _ -> []
+
+let report_literal_type_constraint const = function
+  | Some Errortrace.{ expected = { t = { desc = Tconstr (typ, [], _) } } } ->
+      report_literal_type_constraint typ const
+  | Some _ | None -> []
+
+let report_expr_type_clash_hints exp diff =
+  match exp with
+  | Some (Texp_constant const) -> report_literal_type_constraint const diff
+  | _ -> []
+
+let report_pattern_type_clash_hints
+      (type k) (pat : k pattern_desc option) diff =
+  match pat with
+  | Some (Tpat_constant const) -> report_literal_type_constraint const diff
+  | _ -> []
+
+let report_type_expected_explanation expl ppf =
+  let because expl_str = fprintf ppf "@ because it is in %s" expl_str in
+  match expl with
+  | If_conditional ->
+      because "the condition of an if-statement"
+  | If_no_else_branch ->
+      because "the result of a conditional with no else branch"
+  | While_loop_conditional ->
+      because "the condition of a while-loop"
+  | While_loop_body ->
+      because "the body of a while-loop"
+  | For_loop_start_index ->
+      because "a for-loop start index"
+  | For_loop_stop_index ->
+      because "a for-loop stop index"
+  | For_loop_body ->
+      because "the body of a for-loop"
+  | Assert_condition ->
+      because "the condition of an assertion"
+  | Sequence_left_hand_side ->
+      because "the left-hand side of a sequence"
+  | When_guard ->
+      because "a when-guard"
+
+let report_type_expected_explanation_opt expl ppf =
+  match expl with
+  | None -> ()
+  | Some expl -> report_type_expected_explanation expl ppf
+
+let report_unification_error ~loc ?sub env trace
+    ?type_expected_explanation txt1 txt2 =
+  Location.error_of_printer ~loc ?sub (fun ppf () ->
+    Printtyp.report_unification_error ppf env trace
+      ?type_expected_explanation txt1 txt2
+  ) ()
+
+let report_error ~loc env = function
+  | Constructor_arity_mismatch(lid, expected, provided) ->
+      Location.errorf ~loc
+       "@[The constructor %a@ expects %i argument(s),@ \
+        but is applied here to %i argument(s)@]"
+       longident lid expected provided
+  | Label_mismatch(lid, trace) ->
+      report_unification_error ~loc env trace
+        (function ppf ->
+           fprintf ppf "The record field %a@ belongs to the type"
+                   longident lid)
+        (function ppf ->
+           fprintf ppf "but is mixed here with fields of type")
+  | Pattern_type_clash (trace, pat) ->
+      let diff = type_clash_of_trace trace in
+      let sub = report_pattern_type_clash_hints pat diff in
+      report_unification_error ~loc ~sub env trace
+        (function ppf ->
+          fprintf ppf "This pattern matches values of type")
+        (function ppf ->
+          fprintf ppf "but a pattern was expected which matches values of \
+                       type");
+  | Or_pattern_type_clash (id, trace) ->
+      report_unification_error ~loc env trace
+        (function ppf ->
+          fprintf ppf "The variable %s on the left-hand side of this \
+                       or-pattern has type" (Ident.name id))
+        (function ppf ->
+          fprintf ppf "but on the right-hand side it has type")
+  | Multiply_bound_variable name ->
+      Location.errorf ~loc
+        "Variable %s is bound several times in this matching"
+        name
+  | Orpat_vars (id, valid_idents) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        fprintf ppf
+          "Variable %s must occur on both sides of this | pattern"
+          (Ident.name id);
+        spellcheck_idents ppf id valid_idents
+      ) ()
+  | Expr_type_clash (trace, explanation, exp) ->
+      let diff = type_clash_of_trace trace in
+      let sub = report_expr_type_clash_hints exp diff in
+      report_unification_error ~loc ~sub env trace
+        ~type_expected_explanation:
+          (report_type_expected_explanation_opt explanation)
+        (function ppf ->
+           fprintf ppf "This expression has type")
+        (function ppf ->
+           fprintf ppf "but an expression was expected of type");
+  | Apply_non_function typ ->
+      begin match (repr typ).desc with
+        Tarrow _ ->
+          Location.errorf ~loc
+            "@[<v>@[<2>This function has type@ %a@]\
+             @ @[It is applied to too many arguments;@ %s@]@]"
+            Printtyp.type_expr typ "maybe you forgot a `;'.";
+      | _ ->
+          Location.errorf ~loc "@[<v>@[<2>This expression has type@ %a@]@ %s@]"
+            Printtyp.type_expr typ
+            "This is not a function; it cannot be applied."
+      end
+  | Apply_wrong_label (l, ty, extra_info) ->
+      let print_label ppf = function
+        | Nolabel -> fprintf ppf "without label"
+        | l -> fprintf ppf "with label %s" (prefixed_label_name l)
+      in
+      let extra_info =
+        if not extra_info then
+          []
+        else
+          [ Location.msg
+              "Since OCaml 4.11, optional arguments do not commute when \
+               -nolabels is given" ]
+      in
+      Location.errorf ~loc ~sub:extra_info
+        "@[<v>@[<2>The function applied to this argument has type@ %a@]@.\
+         This argument cannot be applied %a@]"
+        Printtyp.type_expr ty print_label l
+  | Label_multiply_defined s ->
+      Location.errorf ~loc "The record field label %s is defined several times"
+        s
+  | Label_missing labels ->
+      let print_labels ppf =
+        List.iter (fun lbl -> fprintf ppf "@ %s" (Ident.name lbl)) in
+      Location.errorf ~loc "@[<hov>Some record fields are undefined:%a@]"
+        print_labels labels
+  | Label_not_mutable lid ->
+      Location.errorf ~loc "The record field %a is not mutable" longident lid
+  | Wrong_name (eorp, ty_expected, { type_path; kind; name; valid_names; }) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        Printtyp.wrap_printing_env ~error:true env (fun () ->
+          let { ty; explanation } = ty_expected in
+          if Path.is_constructor_typath type_path then begin
+            fprintf ppf
+              "@[The field %s is not part of the record \
+               argument for the %a constructor@]"
+              name.txt
+              Printtyp.type_path type_path;
+          end else begin
+            fprintf ppf
+              "@[@[<2>%s type@ %a%t@]@ \
+               There is no %s %s within type %a@]"
+              eorp Printtyp.type_expr ty
+              (report_type_expected_explanation_opt explanation)
+              (Datatype_kind.label_name kind)
+              name.txt (*kind*) Printtyp.type_path type_path;
+          end;
+          spellcheck ppf name.txt valid_names
+      )) ()
+  | Name_type_mismatch (kind, lid, tp, tpl) ->
+      let type_name = Datatype_kind.type_name kind in
+      let name = Datatype_kind.label_name kind in
+      Location.error_of_printer ~loc (fun ppf () ->
+        Printtyp.report_ambiguous_type_error ppf env tp tpl
+          (function ppf ->
+             fprintf ppf "The %s %a@ belongs to the %s type"
+               name longident lid type_name)
+          (function ppf ->
+             fprintf ppf "The %s %a@ belongs to one of the following %s types:"
+               name longident lid type_name)
+          (function ppf ->
+             fprintf ppf "but a %s was expected belonging to the %s type"
+               name type_name)
+      ) ()
+  | Invalid_format msg ->
+      Location.errorf ~loc "%s" msg
+  | Undefined_method (ty, me, valid_methods) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        Printtyp.wrap_printing_env ~error:true env (fun () ->
+          fprintf ppf
+            "@[<v>@[This expression has type@;<1 2>%a@]@,\
+             It has no method %s@]" Printtyp.type_expr ty me;
+          begin match valid_methods with
+            | None -> ()
+            | Some valid_methods -> spellcheck ppf me valid_methods
+          end
+      )) ()
+  | Undefined_inherited_method (me, valid_methods) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        fprintf ppf "This expression has no method %s" me;
+        spellcheck ppf me valid_methods;
+      ) ()
+  | Virtual_class cl ->
+      Location.errorf ~loc "Cannot instantiate the virtual class %a"
+        longident cl
+  | Unbound_instance_variable (var, valid_vars) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        fprintf ppf "Unbound instance variable %s" var;
+        spellcheck ppf var valid_vars;
+      ) ()
+  | Instance_variable_not_mutable v ->
+      Location.errorf ~loc "The instance variable %s is not mutable" v
+  | Not_subtype(tr1, tr2) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        Printtyp.Subtype.report_error ppf env tr1 "is not a subtype of" tr2
+      ) ()
+  | Outside_class ->
+      Location.errorf ~loc
+        "This object duplication occurs outside a method definition"
+  | Value_multiply_overridden v ->
+      Location.errorf ~loc
+        "The instance variable %s is overridden several times"
+        v
+  | Coercion_failure (ty, ty', trace, b) ->
+      Location.error_of_printer ~loc (fun ppf () ->
+        Printtyp.report_unification_error ppf env trace
+          (function ppf ->
+             let ty, ty' = Printtyp.prepare_expansion (ty, ty') in
+             fprintf ppf "This expression cannot be coerced to type@;<1 2>%a;@ \
+                          it has type"
+             (Printtyp.type_expansion ty) ty')
+          (function ppf ->
+             fprintf ppf "but is here used with type");
+        if b then
+          fprintf ppf ".@.@[<hov>%s@ %s@ %s@]"
+            "This simple coercion was not fully general."
+            "Hint: Consider using a fully explicit coercion"
+            "of the form: `(foo : ty1 :> ty2)'."
+      ) ()
+  | Too_many_arguments (in_function, ty, explanation) ->
+      if in_function then begin
+        Location.errorf ~loc
+          "This function expects too many arguments,@ \
+           it should have type@ %a%t"
+          Printtyp.type_expr ty
+          (report_type_expected_explanation_opt explanation)
+      end else begin
+        Location.errorf ~loc
+          "This expression should not be a function,@ \
+           the expected type is@ %a%t"
+          Printtyp.type_expr ty
+          (report_type_expected_explanation_opt explanation)
+      end
+  | Abstract_wrong_label (l, ty, explanation) ->
+      let label_mark = function
+        | Nolabel -> "but its first argument is not labelled"
+        | l -> sprintf "but its first argument is labelled %s"
+                       (prefixed_label_name l) in
+      Location.errorf ~loc
+        "@[<v>@[<2>This function should have type@ %a%t@]@,%s@]"
+        Printtyp.type_expr ty
+        (report_type_expected_explanation_opt explanation)
+        (label_mark l)
+  | Scoping_let_module(id, ty) ->
+      Location.errorf ~loc
+        "This `let module' expression has type@ %a@ \
+         In this type, the locally bound module name %s escapes its scope"
+        Printtyp.type_expr ty id
+  | Private_type ty ->
+      Location.errorf ~loc "Cannot create values of the private type %a"
+        Printtyp.type_expr ty
+  | Private_label (lid, ty) ->
+      Location.errorf ~loc "Cannot assign field %a of the private type %a"
+        longident lid Printtyp.type_expr ty
+  | Private_constructor (constr, ty) ->
+      Location.errorf ~loc
+        "Cannot use private constructor %s to create values of type %a"
+        constr.cstr_name Printtyp.type_expr ty
+  | Not_a_variant_type lid ->
+      Location.errorf ~loc "The type %a@ is not a variant type" longident lid
+  | Incoherent_label_order ->
+      Location.errorf ~loc
+        "This function is applied to arguments@ \
+        in an order different from other calls.@ \
+        This is only allowed when the real type is known."
+  | Less_general (kind, trace) ->
+      report_unification_error ~loc env trace
+        (fun ppf -> fprintf ppf "This %s has type" kind)
+        (fun ppf -> fprintf ppf "which is less general than")
+  | Modules_not_allowed ->
+      Location.errorf ~loc "Modules are not allowed in this pattern."
+  | Cannot_infer_signature ->
+      Location.errorf ~loc
+        "The signature for this packaged module couldn't be inferred."
+  | Not_a_packed_module ty ->
+      Location.errorf ~loc
+        "This expression is packed module, but the expected type is@ %a"
+        Printtyp.type_expr ty
+  | Unexpected_existential (reason, name, types) ->
+      let reason_str =
+        match reason with
+        | In_class_args ->
+            "Existential types are not allowed in class arguments"
+        | In_class_def ->
+            "Existential types are not allowed in bindings inside \
+             class definition"
+        | In_self_pattern ->
+            "Existential types are not allowed in self patterns"
+        | At_toplevel ->
+            "Existential types are not allowed in toplevel bindings"
+        | In_group ->
+            "Existential types are not allowed in \"let ... and ...\" bindings"
+        | In_rec ->
+            "Existential types are not allowed in recursive bindings"
+        | With_attributes ->
+            "Existential types are not allowed in presence of attributes"
+      in
+      begin match List.find (fun ty -> ty <> "$" ^ name) types with
+      | example ->
+          Location.errorf ~loc
+            "%s,@ but this pattern introduces the existential type %s."
+            reason_str example
+      | exception Not_found ->
+          Location.errorf ~loc
+            "%s,@ but the constructor %s introduces existential types."
+            reason_str name
+      end
+  | Invalid_interval ->
+      Location.errorf ~loc
+        "@[Only character intervals are supported in patterns.@]"
+  | Invalid_for_loop_index ->
+      Location.errorf ~loc
+        "@[Invalid for-loop index: only variables and _ are allowed.@]"
+  | No_value_clauses ->
+      Location.errorf ~loc
+        "None of the patterns in this 'match' expression match values."
+  | Exception_pattern_disallowed ->
+      Location.errorf ~loc
+        "@[Exception patterns are not allowed in this position.@]"
+  | Mixed_value_and_exception_patterns_under_guard ->
+      Location.errorf ~loc
+        "@[Mixing value and exception patterns under when-guards is not \
+         supported.@]"
+  | Inlined_record_escape ->
+      Location.errorf ~loc
+        "@[This form is not allowed as the type of the inlined record could \
+         escape.@]"
+  | Inlined_record_expected ->
+      Location.errorf ~loc
+        "@[This constructor expects an inlined record argument.@]"
+  | Unrefuted_pattern pat ->
+      Location.errorf ~loc
+        "@[%s@ %s@ %a@]"
+        "This match case could not be refuted."
+        "Here is an example of a value that would reach it:"
+        Printpat.top_pretty pat
+  | Invalid_extension_constructor_payload ->
+      Location.errorf ~loc
+        "Invalid [%%extension_constructor] payload, a constructor is expected."
+  | Not_an_extension_constructor ->
+      Location.errorf ~loc
+        "This constructor is not an extension constructor."
+  | Literal_overflow ty ->
+      Location.errorf ~loc
+        "Integer literal exceeds the range of representable integers of type %s"
+        ty
+  | Unknown_literal (n, m) ->
+      Location.errorf ~loc "Unknown modifier '%c' for literal %s%c" m n m
+  | Illegal_letrec_pat ->
+      Location.errorf ~loc
+        "Only variables are allowed as left-hand side of `let rec'"
+  | Illegal_letrec_expr ->
+      Location.errorf ~loc
+        "This kind of expression is not allowed as right-hand side of `let rec'"
+  | Illegal_class_expr ->
+      Location.errorf ~loc
+        "This kind of recursive class expression is not allowed"
+  | Letop_type_clash(name, trace) ->
+      report_unification_error ~loc env trace
+        (function ppf ->
+          fprintf ppf "The operator %s has type" name)
+        (function ppf ->
+          fprintf ppf "but it was expected to have type")
+  | Andop_type_clash(name, trace) ->
+      report_unification_error ~loc env trace
+        (function ppf ->
+          fprintf ppf "The operator %s has type" name)
+        (function ppf ->
+          fprintf ppf "but it was expected to have type")
+  | Bindings_type_clash(trace) ->
+      report_unification_error ~loc env trace
+        (function ppf ->
+          fprintf ppf "These bindings have type")
+        (function ppf ->
+          fprintf ppf "but bindings were expected of type")
+  | Unbound_existential (ids, ty) ->
+      Location.errorf ~loc
+        "@[<2>%s:@ @[type %s.@ %a@]@]"
+        "This type does not bind all existentials in the constructor"
+        (String.concat " " (List.map Ident.name ids))
+        Printtyp.type_expr ty
+  | Missing_type_constraint ->
+      Location.errorf ~loc
+        "@[%s@ %s@]"
+        "Existential types introduced in a constructor pattern"
+        "must be bound by a type constraint on the argument."
+
+let report_error ~loc env err =
+  Printtyp.wrap_printing_env ~error:true env
+    (fun () -> report_error ~loc env err)
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, env, err) ->
+        Some (report_error ~loc env err)
+      | Error_forward err ->
+        Some err
+      | _ ->
+        None
+    )
+
+let () =
+  Persistent_env.add_delayed_check_forward := add_delayed_check;
+  Env.add_delayed_check_forward := add_delayed_check;
+  ()
+
+(* drop ?recarg argument from the external API *)
+let type_expect ?in_function env e ty = type_expect ?in_function env e ty
+let type_exp env e = type_exp env e
+let type_argument env e t1 t2 = type_argument env e t1 t2
diff --git a/upstream/ocaml_413/typing/typecore.mli b/upstream/ocaml_413/typing/typecore.mli
new file mode 100644
index 0000000..4994075
--- /dev/null
+++ b/upstream/ocaml_413/typing/typecore.mli
@@ -0,0 +1,223 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Type inference for the core language *)
+
+open Asttypes
+open Types
+
+(* This variant is used to print improved error messages, and does not affect
+   the behavior of the typechecker itself.
+
+   It describes possible explanation for types enforced by a keyword of the
+   language; e.g. "if" requires the condition to be of type bool, and the
+   then-branch to be of type unit if there is no else branch; "for" requires
+   indices to be of type int, and the body to be of type unit.
+*)
+type type_forcing_context =
+  | If_conditional
+  | If_no_else_branch
+  | While_loop_conditional
+  | While_loop_body
+  | For_loop_start_index
+  | For_loop_stop_index
+  | For_loop_body
+  | Assert_condition
+  | Sequence_left_hand_side
+  | When_guard
+
+(* The combination of a type and a "type forcing context". The intent is that it
+   describes a type that is "expected" (required) by the context. If unifying
+   with such a type fails, then the "explanation" field explains why it was
+   required, in order to display a more enlightening error message.
+*)
+type type_expected = private {
+  ty: type_expr;
+  explanation: type_forcing_context option;
+}
+
+val mk_expected:
+  ?explanation:type_forcing_context ->
+  type_expr ->
+  type_expected
+
+val is_nonexpansive: Typedtree.expression -> bool
+
+module Datatype_kind : sig
+  type t = Record | Variant
+  val type_name : t -> string
+  val label_name : t -> string
+end
+
+type wrong_name = {
+  type_path: Path.t;
+  kind: Datatype_kind.t;
+  name: string loc;
+  valid_names: string list;
+}
+
+type existential_restriction =
+  | At_toplevel (** no existential types at the toplevel *)
+  | In_group (** nor with [let ... and ...] *)
+  | In_rec (** or recursive definition *)
+  | With_attributes (** or [let[@any_attribute] = ...] *)
+  | In_class_args (** or in class arguments [class c (...) = ...] *)
+  | In_class_def (** or in [class c = let ... in ...] *)
+  | In_self_pattern (** or in self pattern *)
+
+val type_binding:
+        Env.t -> rec_flag ->
+          Parsetree.value_binding list ->
+          Typedtree.value_binding list * Env.t
+val type_let:
+        existential_restriction -> Env.t -> rec_flag ->
+          Parsetree.value_binding list ->
+          Typedtree.value_binding list * Env.t
+val type_expression:
+        Env.t -> Parsetree.expression -> Typedtree.expression
+val type_class_arg_pattern:
+        string -> Env.t -> Env.t -> arg_label -> Parsetree.pattern ->
+        Typedtree.pattern *
+        (Ident.t * Ident.t * type_expr) list *
+        Env.t * Env.t
+val type_self_pattern:
+        string -> type_expr -> Env.t -> Env.t -> Env.t -> Parsetree.pattern ->
+        Typedtree.pattern *
+        (Ident.t * type_expr) Meths.t ref *
+        (Ident.t * Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr)
+            Vars.t ref *
+        Env.t * Env.t * Env.t
+val check_partial:
+        ?lev:int -> Env.t -> type_expr ->
+        Location.t -> Typedtree.value Typedtree.case list -> Typedtree.partial
+val type_expect:
+        ?in_function:(Location.t * type_expr) ->
+        Env.t -> Parsetree.expression -> type_expected -> Typedtree.expression
+val type_exp:
+        Env.t -> Parsetree.expression -> Typedtree.expression
+val type_approx:
+        Env.t -> Parsetree.expression -> type_expr
+val type_argument:
+        Env.t -> Parsetree.expression ->
+        type_expr -> type_expr -> Typedtree.expression
+
+val option_some: Env.t -> Typedtree.expression -> Typedtree.expression
+val option_none: Env.t -> type_expr -> Location.t -> Typedtree.expression
+val extract_option_type: Env.t -> type_expr -> type_expr
+val generalizable: int -> type_expr -> bool
+val reset_delayed_checks: unit -> unit
+val force_delayed_checks: unit -> unit
+
+val name_pattern : string -> Typedtree.pattern list -> Ident.t
+val name_cases : string -> Typedtree.value Typedtree.case list -> Ident.t
+
+val self_coercion : (Path.t * Location.t list ref) list ref
+
+type error =
+  | Constructor_arity_mismatch of Longident.t * int * int
+  | Label_mismatch of Longident.t * Errortrace.unification Errortrace.t
+  | Pattern_type_clash :
+      Errortrace.unification Errortrace.t * _ Typedtree.pattern_desc option
+      -> error
+  | Or_pattern_type_clash of Ident.t * Errortrace.unification Errortrace.t
+  | Multiply_bound_variable of string
+  | Orpat_vars of Ident.t * Ident.t list
+  | Expr_type_clash of
+      Errortrace.unification Errortrace.t * type_forcing_context option
+      * Typedtree.expression_desc option
+  | Apply_non_function of type_expr
+  | Apply_wrong_label of arg_label * type_expr * bool
+  | Label_multiply_defined of string
+  | Label_missing of Ident.t list
+  | Label_not_mutable of Longident.t
+  | Wrong_name of string * type_expected * wrong_name
+  | Name_type_mismatch of
+      Datatype_kind.t * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list
+  | Invalid_format of string
+  | Undefined_method of type_expr * string * string list option
+  | Undefined_inherited_method of string * string list
+  | Virtual_class of Longident.t
+  | Private_type of type_expr
+  | Private_label of Longident.t * type_expr
+  | Private_constructor of constructor_description * type_expr
+  | Unbound_instance_variable of string * string list
+  | Instance_variable_not_mutable of string
+  | Not_subtype of Errortrace.Subtype.t * Errortrace.unification Errortrace.t
+  | Outside_class
+  | Value_multiply_overridden of string
+  | Coercion_failure of
+      type_expr * type_expr * Errortrace.unification Errortrace.t * bool
+  | Too_many_arguments of bool * type_expr * type_forcing_context option
+  | Abstract_wrong_label of arg_label * type_expr * type_forcing_context option
+  | Scoping_let_module of string * type_expr
+  | Not_a_variant_type of Longident.t
+  | Incoherent_label_order
+  | Less_general of string * Errortrace.unification Errortrace.t
+  | Modules_not_allowed
+  | Cannot_infer_signature
+  | Not_a_packed_module of type_expr
+  | Unexpected_existential of existential_restriction * string * string list
+  | Invalid_interval
+  | Invalid_for_loop_index
+  | No_value_clauses
+  | Exception_pattern_disallowed
+  | Mixed_value_and_exception_patterns_under_guard
+  | Inlined_record_escape
+  | Inlined_record_expected
+  | Unrefuted_pattern of Typedtree.pattern
+  | Invalid_extension_constructor_payload
+  | Not_an_extension_constructor
+  | Literal_overflow of string
+  | Unknown_literal of string * char
+  | Illegal_letrec_pat
+  | Illegal_letrec_expr
+  | Illegal_class_expr
+  | Letop_type_clash of string * Errortrace.unification Errortrace.t
+  | Andop_type_clash of string * Errortrace.unification Errortrace.t
+  | Bindings_type_clash of Errortrace.unification Errortrace.t
+  | Unbound_existential of Ident.t list * type_expr
+  | Missing_type_constraint
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+val report_error: loc:Location.t -> Env.t -> error -> Location.error
+ (** @deprecated.  Use {!Location.error_of_exn}, {!Location.print_report}. *)
+
+(* Forward declaration, to be filled in by Typemod.type_module *)
+val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref
+(* Forward declaration, to be filled in by Typemod.type_open *)
+val type_open:
+  (?used_slot:bool ref -> override_flag -> Env.t -> Location.t ->
+   Longident.t loc -> Path.t * Env.t)
+    ref
+(* Forward declaration, to be filled in by Typemod.type_open_decl *)
+val type_open_decl:
+  (?used_slot:bool ref -> Env.t -> Parsetree.open_declaration ->
+   Typedtree.open_declaration * Types.signature * Env.t)
+    ref
+(* Forward declaration, to be filled in by Typeclass.class_structure *)
+val type_object:
+  (Env.t -> Location.t -> Parsetree.class_structure ->
+   Typedtree.class_structure * Types.class_signature * string list) ref
+val type_package:
+  (Env.t -> Parsetree.module_expr -> Path.t -> (Longident.t * type_expr) list ->
+  Typedtree.module_expr * (Longident.t * type_expr) list) ref
+
+val constant: Parsetree.constant -> (Asttypes.constant, error) result
+
+val check_recursive_bindings : Env.t -> Typedtree.value_binding list -> unit
+val check_recursive_class_bindings :
+  Env.t -> Ident.t list -> Typedtree.class_expr list -> unit
diff --git a/upstream/ocaml_413/typing/typedecl.ml b/upstream/ocaml_413/typing/typedecl.ml
new file mode 100644
index 0000000..7f6b5d5
--- /dev/null
+++ b/upstream/ocaml_413/typing/typedecl.ml
@@ -0,0 +1,1903 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(**** Typing of type definitions ****)
+
+open Misc
+open Asttypes
+open Parsetree
+open Primitive
+open Types
+open Typetexp
+
+module String = Misc.Stdlib.String
+
+type native_repr_kind = Unboxed | Untagged
+
+type error =
+    Repeated_parameter
+  | Duplicate_constructor of string
+  | Too_many_constructors
+  | Duplicate_label of string
+  | Recursive_abbrev of string
+  | Cycle_in_def of string * type_expr
+  | Definition_mismatch of type_expr * Includecore.type_mismatch option
+  | Constraint_failed of Env.t * Errortrace.unification Errortrace.t
+  | Inconsistent_constraint of Env.t * Errortrace.unification Errortrace.t
+  | Type_clash of Env.t * Errortrace.unification Errortrace.t
+  | Non_regular of {
+      definition: Path.t;
+      used_as: type_expr;
+      defined_as: type_expr;
+      expansions: (type_expr * type_expr) list;
+    }
+  | Null_arity_external
+  | Missing_native_external
+  | Unbound_type_var of type_expr * type_declaration
+  | Cannot_extend_private_type of Path.t
+  | Not_extensible_type of Path.t
+  | Extension_mismatch of Path.t * Includecore.type_mismatch
+  | Rebind_wrong_type of
+      Longident.t * Env.t * Errortrace.unification Errortrace.t
+  | Rebind_mismatch of Longident.t * Path.t * Path.t
+  | Rebind_private of Longident.t
+  | Variance of Typedecl_variance.error
+  | Unavailable_type_constructor of Path.t
+  | Unbound_type_var_ext of type_expr * extension_constructor
+  | Val_in_structure
+  | Multiple_native_repr_attributes
+  | Cannot_unbox_or_untag_type of native_repr_kind
+  | Deep_unbox_or_untag_attribute of native_repr_kind
+  | Immediacy of Typedecl_immediacy.error
+  | Separability of Typedecl_separability.error
+  | Bad_unboxed_attribute of string
+  | Boxed_and_unboxed
+  | Nonrec_gadt
+  | Invalid_private_row_declaration of type_expr
+
+open Typedtree
+
+exception Error of Location.t * error
+
+let get_unboxed_from_attributes sdecl =
+  let unboxed = Builtin_attributes.has_unboxed sdecl.ptype_attributes in
+  let boxed = Builtin_attributes.has_boxed sdecl.ptype_attributes in
+  match boxed, unboxed with
+  | true, true -> raise (Error(sdecl.ptype_loc, Boxed_and_unboxed))
+  | true, false -> Some false
+  | false, true -> Some true
+  | false, false -> None
+
+(* Enter all declared types in the environment as abstract types *)
+
+let add_type ~check id decl env =
+  Builtin_attributes.warning_scope ~ppwarning:false decl.type_attributes
+    (fun () -> Env.add_type ~check id decl env)
+
+let enter_type rec_flag env sdecl (id, uid) =
+  let needed =
+    match rec_flag with
+    | Asttypes.Nonrecursive ->
+        begin match sdecl.ptype_kind with
+        | Ptype_variant scds ->
+            List.iter (fun cd ->
+              if cd.pcd_res <> None then raise (Error(cd.pcd_loc, Nonrec_gadt)))
+              scds
+        | _ -> ()
+        end;
+        Btype.is_row_name (Ident.name id)
+    | Asttypes.Recursive -> true
+  in
+  let arity = List.length sdecl.ptype_params in
+  if not needed then env else
+  let decl =
+    { type_params =
+        List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params;
+      type_arity = arity;
+      type_kind = Type_abstract;
+      type_private = sdecl.ptype_private;
+      type_manifest =
+        begin match sdecl.ptype_manifest with None -> None
+        | Some _ -> Some(Ctype.newvar ()) end;
+      type_variance = Variance.unknown_signature ~injective:false ~arity;
+      type_separability = Types.Separability.default_signature ~arity;
+      type_is_newtype = false;
+      type_expansion_scope = Btype.lowest_level;
+      type_loc = sdecl.ptype_loc;
+      type_attributes = sdecl.ptype_attributes;
+      type_immediate = Unknown;
+      type_unboxed_default = false;
+      type_uid = uid;
+    }
+  in
+  add_type ~check:true id decl env
+
+let update_type temp_env env id loc =
+  let path = Path.Pident id in
+  let decl = Env.find_type path temp_env in
+  match decl.type_manifest with None -> ()
+  | Some ty ->
+      let params = List.map (fun _ -> Ctype.newvar ()) decl.type_params in
+      try Ctype.unify env (Ctype.newconstr path params) ty
+      with Ctype.Unify trace ->
+        raise (Error(loc, Type_clash (env, trace)))
+
+let get_unboxed_type_representation env ty =
+  match Typedecl_unboxed.get_unboxed_type_representation env ty with
+  | Typedecl_unboxed.This x -> Some x
+  | _ -> None
+
+(* Determine if a type's values are represented by floats at run-time. *)
+let is_float env ty =
+  match get_unboxed_type_representation env ty with
+    Some {desc = Tconstr(p, _, _); _} -> Path.same p Predef.path_float
+  | _ -> false
+
+(* Determine if a type definition defines a fixed type. (PW) *)
+let is_fixed_type sd =
+  let rec has_row_var sty =
+    match sty.ptyp_desc with
+      Ptyp_alias (sty, _) -> has_row_var sty
+    | Ptyp_class _
+    | Ptyp_object (_, Open)
+    | Ptyp_variant (_, Open, _)
+    | Ptyp_variant (_, Closed, Some _) -> true
+    | _ -> false
+  in
+  match sd.ptype_manifest with
+    None -> false
+  | Some sty ->
+      sd.ptype_kind = Ptype_abstract &&
+      sd.ptype_private = Private &&
+      has_row_var sty
+
+(* Set the row variable to a fixed type in a private row type declaration.
+   (e.g. [ type t = private [< `A | `B ] ] or [type u = private < .. > ])
+   Require [is_fixed_type decl] as a precondition
+*)
+let set_private_row env loc p decl =
+  let tm =
+    match decl.type_manifest with
+      None -> assert false
+    | Some t -> Ctype.expand_head env t
+  in
+  let rv =
+    match tm.desc with
+      Tvariant row ->
+        let row = Btype.row_repr row in
+        Btype.set_type_desc tm
+          (Tvariant {row with row_fixed = Some Fixed_private});
+        if Btype.static_row row then
+          (* the syntax hinted at the existence of a row variable,
+             but there is in fact no row variable to make private, e.g.
+             [ type t = private [< `A > `A] ] *)
+          raise (Error(loc, Invalid_private_row_declaration tm))
+        else row.row_more
+    | Tobject (ty, _) ->
+        let r = snd (Ctype.flatten_fields ty) in
+        if not (Btype.is_Tvar r) then
+          (* a syntactically open object was closed by a constraint *)
+          raise (Error(loc, Invalid_private_row_declaration tm));
+        r
+    | _ -> assert false
+  in
+  Btype.set_type_desc rv (Tconstr (p, decl.type_params, ref Mnil))
+
+(* Translate one type declaration *)
+
+let make_params env params =
+  let make_param (sty, v) =
+    try
+      (transl_type_param env sty, v)
+    with Already_bound ->
+      raise(Error(sty.ptyp_loc, Repeated_parameter))
+  in
+    List.map make_param params
+
+let transl_labels env closed lbls =
+  assert (lbls <> []);
+  let all_labels = ref String.Set.empty in
+  List.iter
+    (fun {pld_name = {txt=name; loc}} ->
+       if String.Set.mem name !all_labels then
+         raise(Error(loc, Duplicate_label name));
+       all_labels := String.Set.add name !all_labels)
+    lbls;
+  let mk {pld_name=name;pld_mutable=mut;pld_type=arg;pld_loc=loc;
+          pld_attributes=attrs} =
+    Builtin_attributes.warning_scope attrs
+      (fun () ->
+         let arg = Ast_helper.Typ.force_poly arg in
+         let cty = transl_simple_type env closed arg in
+         {ld_id = Ident.create_local name.txt;
+          ld_name = name; ld_mutable = mut;
+          ld_type = cty; ld_loc = loc; ld_attributes = attrs}
+      )
+  in
+  let lbls = List.map mk lbls in
+  let lbls' =
+    List.map
+      (fun ld ->
+         let ty = ld.ld_type.ctyp_type in
+         let ty = match ty.desc with Tpoly(t,[]) -> t | _ -> ty in
+         {Types.ld_id = ld.ld_id;
+          ld_mutable = ld.ld_mutable;
+          ld_type = ty;
+          ld_loc = ld.ld_loc;
+          ld_attributes = ld.ld_attributes;
+          ld_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+         }
+      )
+      lbls in
+  lbls, lbls'
+
+let transl_constructor_arguments env closed = function
+  | Pcstr_tuple l ->
+      let l = List.map (transl_simple_type env closed) l in
+      Types.Cstr_tuple (List.map (fun t -> t.ctyp_type) l),
+      Cstr_tuple l
+  | Pcstr_record l ->
+      let lbls, lbls' = transl_labels env closed l in
+      Types.Cstr_record lbls',
+      Cstr_record lbls
+
+let make_constructor env type_path type_params sargs sret_type =
+  match sret_type with
+  | None ->
+      let args, targs =
+        transl_constructor_arguments env true sargs
+      in
+        targs, None, args, None
+  | Some sret_type ->
+      (* if it's a generalized constructor we must first narrow and
+         then widen so as to not introduce any new constraints *)
+      let z = narrow () in
+      reset_type_variables ();
+      let args, targs =
+        transl_constructor_arguments env false sargs
+      in
+      let tret_type = transl_simple_type env false sret_type in
+      let ret_type = tret_type.ctyp_type in
+      (* TODO add back type_path as a parameter ? *)
+      begin match (Ctype.repr ret_type).desc with
+        | Tconstr (p', _, _) when Path.same type_path p' -> ()
+        | _ ->
+          raise (Error (sret_type.ptyp_loc,
+                        Constraint_failed
+                          (env, [Errortrace.diff
+                                   ret_type
+                                   (Ctype.newconstr type_path type_params)])))
+      end;
+      widen z;
+      targs, Some tret_type, args, Some ret_type
+
+let transl_declaration env sdecl (id, uid) =
+  (* Bind type parameters *)
+  reset_type_variables();
+  Ctype.begin_def ();
+  let tparams = make_params env sdecl.ptype_params in
+  let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in
+  let cstrs = List.map
+    (fun (sty, sty', loc) ->
+      transl_simple_type env false sty,
+      transl_simple_type env false sty', loc)
+    sdecl.ptype_cstrs
+  in
+  let unboxed_attr = get_unboxed_from_attributes sdecl in
+  begin match unboxed_attr with
+  | (None | Some false) -> ()
+  | Some true ->
+    let bad msg = raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute msg)) in
+    match sdecl.ptype_kind with
+    | Ptype_abstract    -> bad "it is abstract"
+    | Ptype_open        -> bad "extensible variant types cannot be unboxed"
+    | Ptype_record fields -> begin match fields with
+        | [] -> bad "it has no fields"
+        | _::_::_ -> bad "it has more than one field"
+        | [{pld_mutable = Mutable}] -> bad "it is mutable"
+        | [{pld_mutable = Immutable}] -> ()
+      end
+    | Ptype_variant constructors -> begin match constructors with
+        | [] -> bad "it has no constructor"
+        | (_::_::_) -> bad "it has more than one constructor"
+        | [c] -> begin match c.pcd_args with
+            | Pcstr_tuple [] ->
+                bad "its constructor has no argument"
+            | Pcstr_tuple (_::_::_) ->
+                bad "its constructor has more than one argument"
+            | Pcstr_tuple [_]  ->
+                ()
+            | Pcstr_record [] ->
+                bad "its constructor has no fields"
+            | Pcstr_record (_::_::_) ->
+                bad "its constructor has more than one field"
+            | Pcstr_record [{pld_mutable = Mutable}] ->
+                bad "it is mutable"
+            | Pcstr_record [{pld_mutable = Immutable}] ->
+                ()
+          end
+      end
+  end;
+  let unbox, unboxed_default =
+    match sdecl.ptype_kind with
+    | Ptype_variant [{pcd_args = Pcstr_tuple [_]; _}]
+    | Ptype_variant [{pcd_args = Pcstr_record [{pld_mutable=Immutable; _}]; _}]
+    | Ptype_record [{pld_mutable=Immutable; _}] ->
+      Option.value unboxed_attr ~default:!Clflags.unboxed_types,
+      Option.is_none unboxed_attr
+    | _ -> false, false (* Not unboxable, mark as boxed *)
+  in
+  let (tkind, kind) =
+    match sdecl.ptype_kind with
+      | Ptype_abstract -> Ttype_abstract, Type_abstract
+      | Ptype_variant scstrs ->
+        if List.exists (fun cstr -> cstr.pcd_res <> None) scstrs then begin
+          match cstrs with
+            [] -> ()
+          | (_,_,loc)::_ ->
+              Location.prerr_warning loc Warnings.Constraint_on_gadt
+        end;
+        let all_constrs = ref String.Set.empty in
+        List.iter
+          (fun {pcd_name = {txt = name}} ->
+            if String.Set.mem name !all_constrs then
+              raise(Error(sdecl.ptype_loc, Duplicate_constructor name));
+            all_constrs := String.Set.add name !all_constrs)
+          scstrs;
+        if List.length
+            (List.filter (fun cd -> cd.pcd_args <> Pcstr_tuple []) scstrs)
+           > (Config.max_tag + 1) then
+          raise(Error(sdecl.ptype_loc, Too_many_constructors));
+        let make_cstr scstr =
+          let name = Ident.create_local scstr.pcd_name.txt in
+          let targs, tret_type, args, ret_type =
+            make_constructor env (Path.Pident id) params
+                             scstr.pcd_args scstr.pcd_res
+          in
+          let tcstr =
+            { cd_id = name;
+              cd_name = scstr.pcd_name;
+              cd_args = targs;
+              cd_res = tret_type;
+              cd_loc = scstr.pcd_loc;
+              cd_attributes = scstr.pcd_attributes }
+          in
+          let cstr =
+            { Types.cd_id = name;
+              cd_args = args;
+              cd_res = ret_type;
+              cd_loc = scstr.pcd_loc;
+              cd_attributes = scstr.pcd_attributes;
+              cd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) }
+          in
+            tcstr, cstr
+        in
+        let make_cstr scstr =
+          Builtin_attributes.warning_scope scstr.pcd_attributes
+            (fun () -> make_cstr scstr)
+        in
+        let rep = if unbox then Variant_unboxed else Variant_regular in
+        let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in
+          Ttype_variant tcstrs, Type_variant (cstrs, rep)
+      | Ptype_record lbls ->
+          let lbls, lbls' = transl_labels env true lbls in
+          let rep =
+            if unbox then Record_unboxed false
+            else if List.for_all (fun l -> is_float env l.Types.ld_type) lbls'
+            then Record_float
+            else Record_regular
+          in
+          Ttype_record lbls, Type_record(lbls', rep)
+      | Ptype_open -> Ttype_open, Type_open
+      in
+    let (tman, man) = match sdecl.ptype_manifest with
+        None -> None, None
+      | Some sty ->
+        let no_row = not (is_fixed_type sdecl) in
+        let cty = transl_simple_type env no_row sty in
+        Some cty, Some cty.ctyp_type
+    in
+    let arity = List.length params in
+    let decl =
+      { type_params = params;
+        type_arity = arity;
+        type_kind = kind;
+        type_private = sdecl.ptype_private;
+        type_manifest = man;
+        type_variance = Variance.unknown_signature ~injective:false ~arity;
+        type_separability = Types.Separability.default_signature ~arity;
+        type_is_newtype = false;
+        type_expansion_scope = Btype.lowest_level;
+        type_loc = sdecl.ptype_loc;
+        type_attributes = sdecl.ptype_attributes;
+        type_immediate = Unknown;
+        type_unboxed_default = unboxed_default;
+        type_uid = uid;
+      } in
+
+  (* Check constraints *)
+    List.iter
+      (fun (cty, cty', loc) ->
+        let ty = cty.ctyp_type in
+        let ty' = cty'.ctyp_type in
+        try Ctype.unify env ty ty' with Ctype.Unify tr ->
+          raise(Error(loc, Inconsistent_constraint (env, tr))))
+      cstrs;
+    Ctype.end_def ();
+  (* Add abstract row *)
+    if is_fixed_type sdecl then begin
+      let p, _ =
+        try Env.find_type_by_name
+              (Longident.Lident(Ident.name id ^ "#row")) env
+        with Not_found -> assert false
+      in
+      set_private_row env sdecl.ptype_loc p decl
+    end;
+    {
+      typ_id = id;
+      typ_name = sdecl.ptype_name;
+      typ_params = tparams;
+      typ_type = decl;
+      typ_cstrs = cstrs;
+      typ_loc = sdecl.ptype_loc;
+      typ_manifest = tman;
+      typ_kind = tkind;
+      typ_private = sdecl.ptype_private;
+      typ_attributes = sdecl.ptype_attributes;
+    }
+
+(* Generalize a type declaration *)
+
+let generalize_decl decl =
+  List.iter Ctype.generalize decl.type_params;
+  Btype.iter_type_expr_kind Ctype.generalize decl.type_kind;
+  begin match decl.type_manifest with
+  | None    -> ()
+  | Some ty -> Ctype.generalize ty
+  end
+
+(* Check that all constraints are enforced *)
+
+module TypeSet = Btype.TypeSet
+module TypeMap = Btype.TypeMap
+
+let rec check_constraints_rec env loc visited ty =
+  let ty = Ctype.repr ty in
+  if TypeSet.mem ty !visited then () else begin
+  visited := TypeSet.add ty !visited;
+  match ty.desc with
+  | Tconstr (path, args, _) ->
+      let decl =
+        try Env.find_type path env
+        with Not_found ->
+          raise (Error(loc, Unavailable_type_constructor path)) in
+      let ty' = Ctype.newconstr path (Ctype.instance_list decl.type_params) in
+      begin
+        try Ctype.matches env ty ty'
+        with Ctype.Matches_failure (env, trace) ->
+          raise (Error(loc, Constraint_failed (env, trace)))
+      end;
+      List.iter (check_constraints_rec env loc visited) args
+  | Tpoly (ty, tl) ->
+      let _, ty = Ctype.instance_poly false tl ty in
+      check_constraints_rec env loc visited ty
+  | _ ->
+      Btype.iter_type_expr (check_constraints_rec env loc visited) ty
+  end
+
+let check_constraints_labels env visited l pl =
+  let rec get_loc name = function
+      [] -> assert false
+    | pld :: tl ->
+        if name = pld.pld_name.txt then pld.pld_type.ptyp_loc
+        else get_loc name tl
+  in
+  List.iter
+    (fun {Types.ld_id=name; ld_type=ty} ->
+       check_constraints_rec env (get_loc (Ident.name name) pl) visited ty)
+    l
+
+let check_constraints env sdecl (_, decl) =
+  let visited = ref TypeSet.empty in
+  List.iter2
+    (fun (sty, _) ty -> check_constraints_rec env sty.ptyp_loc visited ty)
+    sdecl.ptype_params decl.type_params;
+  begin match decl.type_kind with
+  | Type_abstract -> ()
+  | Type_variant (l, _rep) ->
+      let find_pl = function
+          Ptype_variant pl -> pl
+        | Ptype_record _ | Ptype_abstract | Ptype_open -> assert false
+      in
+      let pl = find_pl sdecl.ptype_kind in
+      let pl_index =
+        let foldf acc x =
+          String.Map.add x.pcd_name.txt x acc
+        in
+        List.fold_left foldf String.Map.empty pl
+      in
+      List.iter
+        (fun {Types.cd_id=name; cd_args; cd_res} ->
+          let {pcd_args; pcd_res; _} =
+            try String.Map.find (Ident.name name) pl_index
+            with Not_found -> assert false in
+          begin match cd_args, pcd_args with
+          | Cstr_tuple tyl, Pcstr_tuple styl ->
+              List.iter2
+                (fun sty ty ->
+                   check_constraints_rec env sty.ptyp_loc visited ty)
+                styl tyl
+          | Cstr_record tyl, Pcstr_record styl ->
+              check_constraints_labels env visited tyl styl
+          | _ -> assert false
+          end;
+          match pcd_res, cd_res with
+          | Some sr, Some r ->
+              check_constraints_rec env sr.ptyp_loc visited r
+          | _ ->
+              () )
+        l
+  | Type_record (l, _) ->
+      let find_pl = function
+          Ptype_record pl -> pl
+        | Ptype_variant _ | Ptype_abstract | Ptype_open -> assert false
+      in
+      let pl = find_pl sdecl.ptype_kind in
+      check_constraints_labels env visited l pl
+  | Type_open -> ()
+  end;
+  begin match decl.type_manifest with
+  | None -> ()
+  | Some ty ->
+      let sty =
+        match sdecl.ptype_manifest with Some sty -> sty | _ -> assert false
+      in
+      check_constraints_rec env sty.ptyp_loc visited ty
+  end
+
+(*
+   If both a variant/record definition and a type equation are given,
+   need to check that the equation refers to a type of the same kind
+   with the same constructors and labels.
+*)
+let check_coherence env loc dpath decl =
+  match decl with
+    { type_kind = (Type_variant _ | Type_record _| Type_open);
+      type_manifest = Some ty } ->
+      begin match (Ctype.repr ty).desc with
+        Tconstr(path, args, _) ->
+          begin try
+            let decl' = Env.find_type path env in
+            let err =
+              if List.length args <> List.length decl.type_params
+              then Some Includecore.Arity
+              else begin
+                match Ctype.equal env false args decl.type_params with
+                | exception Ctype.Equality trace ->
+                    Some (Includecore.Constraint (env, trace))
+                | () ->
+                    Includecore.type_declarations ~loc ~equality:true env
+                      ~mark:true
+                      (Path.last path)
+                      decl'
+                      dpath
+                      (Subst.type_declaration
+                         (Subst.add_type_path dpath path Subst.identity) decl)
+              end
+            in
+            if err <> None then
+              raise(Error(loc, Definition_mismatch (ty, err)))
+          with Not_found ->
+            raise(Error(loc, Unavailable_type_constructor path))
+          end
+      | _ -> raise(Error(loc, Definition_mismatch (ty, None)))
+      end
+  | _ -> ()
+
+let check_abbrev env sdecl (id, decl) =
+  check_coherence env sdecl.ptype_loc (Path.Pident id) decl
+
+(* Check that recursion is well-founded *)
+
+let check_well_founded env loc path to_check ty =
+  let visited = ref TypeMap.empty in
+  let rec check ty0 parents ty =
+    let ty = Btype.repr ty in
+    if TypeSet.mem ty parents then begin
+      (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*)
+      if match ty0.desc with
+      | Tconstr (p, _, _) -> Path.same p path
+      | _ -> false
+      then raise (Error (loc, Recursive_abbrev (Path.name path)))
+      else raise (Error (loc, Cycle_in_def (Path.name path, ty0)))
+    end;
+    let (fini, parents) =
+      try
+        let prev = TypeMap.find ty !visited in
+        if TypeSet.subset parents prev then (true, parents) else
+        (false, TypeSet.union parents prev)
+      with Not_found ->
+        (false, parents)
+    in
+    if fini then () else
+    let rec_ok =
+      match ty.desc with
+        Tconstr(p,_,_) ->
+          !Clflags.recursive_types && Ctype.is_contractive env p
+      | Tobject _ | Tvariant _ -> true
+      | _ -> !Clflags.recursive_types
+    in
+    let visited' = TypeMap.add ty parents !visited in
+    let arg_exn =
+      try
+        visited := visited';
+        let parents =
+          if rec_ok then TypeSet.empty else TypeSet.add ty parents in
+        Btype.iter_type_expr (check ty0 parents) ty;
+        None
+      with e ->
+        visited := visited'; Some e
+    in
+    match ty.desc with
+    | Tconstr(p, _, _) when arg_exn <> None || to_check p ->
+        if to_check p then Option.iter raise arg_exn
+        else Btype.iter_type_expr (check ty0 TypeSet.empty) ty;
+        begin try
+          let ty' = Ctype.try_expand_once_opt env ty in
+          let ty0 = if TypeSet.is_empty parents then ty else ty0 in
+          check ty0 (TypeSet.add ty parents) ty'
+        with
+          Ctype.Cannot_expand -> Option.iter raise arg_exn
+        end
+    | _ -> Option.iter raise arg_exn
+  in
+  let snap = Btype.snapshot () in
+  try Ctype.wrap_trace_gadt_instances env (check ty TypeSet.empty) ty
+  with Ctype.Escape _ ->
+    (* Will be detected by check_recursion *)
+    Btype.backtrack snap
+
+let check_well_founded_manifest env loc path decl =
+  if decl.type_manifest = None then () else
+  let args = List.map (fun _ -> Ctype.newvar()) decl.type_params in
+  check_well_founded env loc path (Path.same path) (Ctype.newconstr path args)
+
+let check_well_founded_decl env loc path decl to_check =
+  let open Btype in
+  let it =
+    {type_iterators with
+     it_type_expr = (fun _ -> check_well_founded env loc path to_check)} in
+  it.it_type_declaration it (Ctype.generic_instance_declaration decl)
+
+(* Check for ill-defined abbrevs *)
+
+let check_recursion ~orig_env env loc path decl to_check =
+  (* to_check is true for potentially mutually recursive paths.
+     (path, decl) is the type declaration to be checked. *)
+
+  if decl.type_params = [] then () else
+
+  let visited = ref [] in
+
+  let rec check_regular cpath args prev_exp prev_expansions ty =
+    let ty = Ctype.repr ty in
+    if not (List.memq ty !visited) then begin
+      visited := ty :: !visited;
+      match ty.desc with
+      | Tconstr(path', args', _) ->
+          if Path.same path path' then begin
+            if not (Ctype.is_equal orig_env false args args') then
+              raise (Error(loc,
+                     Non_regular {
+                       definition=path;
+                       used_as=ty;
+                       defined_as=Ctype.newconstr path args;
+                       expansions=List.rev prev_expansions;
+                     }))
+          end
+          (* Attempt to expand a type abbreviation if:
+              1- [to_check path'] holds
+                 (otherwise the expansion cannot involve [path]);
+              2- we haven't expanded this type constructor before
+                 (otherwise we could loop if [path'] is itself
+                 a non-regular abbreviation). *)
+          else if to_check path' && not (List.mem path' prev_exp) then begin
+            try
+              (* Attempt expansion *)
+              let (params0, body0, _) = Env.find_type_expansion path' env in
+              let (params, body) =
+                Ctype.instance_parameterized_type params0 body0 in
+              begin
+                try List.iter2 (Ctype.unify orig_env) params args'
+                with Ctype.Unify trace ->
+                  raise (Error(loc, Constraint_failed (orig_env, trace)));
+              end;
+              check_regular path' args
+                (path' :: prev_exp) ((ty,body) :: prev_expansions)
+                body
+            with Not_found -> ()
+          end;
+          List.iter (check_regular cpath args prev_exp prev_expansions) args'
+      | Tpoly (ty, tl) ->
+          let (_, ty) = Ctype.instance_poly ~keep_names:true false tl ty in
+          check_regular cpath args prev_exp prev_expansions ty
+      | _ ->
+          Btype.iter_type_expr
+            (check_regular cpath args prev_exp prev_expansions) ty
+    end in
+
+  Option.iter
+    (fun body ->
+      let (args, body) =
+        Ctype.instance_parameterized_type
+          ~keep_names:true decl.type_params body in
+      List.iter (check_regular path args [] []) args;
+      check_regular path args [] [] body)
+    decl.type_manifest
+
+let check_abbrev_recursion ~orig_env env id_loc_list to_check tdecl =
+  let decl = tdecl.typ_type in
+  let id = tdecl.typ_id in
+  check_recursion ~orig_env env (List.assoc id id_loc_list) (Path.Pident id)
+    decl to_check
+
+let check_duplicates sdecl_list =
+  let labels = Hashtbl.create 7 and constrs = Hashtbl.create 7 in
+  List.iter
+    (fun sdecl -> match sdecl.ptype_kind with
+      Ptype_variant cl ->
+        List.iter
+          (fun pcd ->
+            try
+              let name' = Hashtbl.find constrs pcd.pcd_name.txt in
+              Location.prerr_warning pcd.pcd_loc
+                (Warnings.Duplicate_definitions
+                   ("constructor", pcd.pcd_name.txt, name',
+                    sdecl.ptype_name.txt))
+            with Not_found ->
+              Hashtbl.add constrs pcd.pcd_name.txt sdecl.ptype_name.txt)
+          cl
+    | Ptype_record fl ->
+        List.iter
+          (fun {pld_name=cname;pld_loc=loc} ->
+            try
+              let name' = Hashtbl.find labels cname.txt in
+              Location.prerr_warning loc
+                (Warnings.Duplicate_definitions
+                   ("label", cname.txt, name', sdecl.ptype_name.txt))
+            with Not_found -> Hashtbl.add labels cname.txt sdecl.ptype_name.txt)
+          fl
+    | Ptype_abstract -> ()
+    | Ptype_open -> ())
+    sdecl_list
+
+(* Force recursion to go through id for private types*)
+let name_recursion sdecl id decl =
+  match decl with
+  | { type_kind = Type_abstract;
+      type_manifest = Some ty;
+      type_private = Private; } when is_fixed_type sdecl ->
+    let ty = Ctype.repr ty in
+    let ty' = Btype.newty2 ty.level ty.desc in
+    if Ctype.deep_occur ty ty' then
+      let td = Tconstr(Path.Pident id, decl.type_params, ref Mnil) in
+      Btype.link_type ty (Btype.newty2 ty.level td);
+      {decl with type_manifest = Some ty'}
+    else decl
+  | _ -> decl
+
+let name_recursion_decls sdecls decls =
+  List.map2 (fun sdecl (id, decl) -> (id, name_recursion sdecl id decl))
+    sdecls decls
+
+(* Warn on definitions of type "type foo = ()" which redefine a different unit
+   type and are likely a mistake. *)
+let check_redefined_unit (td: Parsetree.type_declaration) =
+  let open Parsetree in
+  let is_unit_constructor cd = cd.pcd_name.txt = "()" in
+  match td with
+  | { ptype_name = { txt = name };
+      ptype_manifest = None;
+      ptype_kind = Ptype_variant [ cd ] }
+    when is_unit_constructor cd ->
+      Location.prerr_warning td.ptype_loc (Warnings.Redefining_unit name)
+  | _ ->
+      ()
+
+let add_types_to_env decls env =
+  List.fold_right
+    (fun (id, decl) env -> add_type ~check:true id decl env)
+    decls env
+
+(* Translate a set of type declarations, mutually recursive or not *)
+let transl_type_decl env rec_flag sdecl_list =
+  List.iter check_redefined_unit sdecl_list;
+  (* Add dummy types for fixed rows *)
+  let fixed_types = List.filter is_fixed_type sdecl_list in
+  let sdecl_list =
+    List.map
+      (fun sdecl ->
+         let ptype_name =
+           let loc = { sdecl.ptype_name.loc with Location.loc_ghost = true } in
+           mkloc (sdecl.ptype_name.txt ^"#row") loc
+         in
+         let ptype_kind = Ptype_abstract in
+         let ptype_manifest = None in
+         let ptype_loc = { sdecl.ptype_loc with Location.loc_ghost = true } in
+        {sdecl with
+           ptype_name; ptype_kind; ptype_manifest; ptype_loc })
+      fixed_types
+    @ sdecl_list
+  in
+
+  (* Create identifiers. *)
+  let scope = Ctype.create_scope () in
+  let ids_list =
+    List.map (fun sdecl ->
+      Ident.create_scoped ~scope sdecl.ptype_name.txt,
+      Uid.mk ~current_unit:(Env.get_unit_name ())
+    ) sdecl_list
+  in
+  Ctype.begin_def();
+  (* Enter types. *)
+  let temp_env =
+    List.fold_left2 (enter_type rec_flag) env sdecl_list ids_list in
+  (* Translate each declaration. *)
+  let current_slot = ref None in
+  let warn_unused = Warnings.is_active (Warnings.Unused_type_declaration "") in
+  let ids_slots (id, _uid as ids) =
+    match rec_flag with
+    | Asttypes.Recursive when warn_unused ->
+        (* See typecore.ml for a description of the algorithm used
+             to detect unused declarations in a set of recursive definitions. *)
+        let slot = ref [] in
+        let td = Env.find_type (Path.Pident id) temp_env in
+        Env.set_type_used_callback
+          td
+          (fun old_callback ->
+             match !current_slot with
+             | Some slot -> slot := td.type_uid :: !slot
+             | None ->
+                 List.iter Env.mark_type_used (get_ref slot);
+                 old_callback ()
+          );
+        ids, Some slot
+    | Asttypes.Recursive | Asttypes.Nonrecursive ->
+        ids, None
+  in
+  let transl_declaration name_sdecl (id, slot) =
+    current_slot := slot;
+    Builtin_attributes.warning_scope
+      name_sdecl.ptype_attributes
+      (fun () -> transl_declaration temp_env name_sdecl id)
+  in
+  let tdecls =
+    List.map2 transl_declaration sdecl_list (List.map ids_slots ids_list) in
+  let decls =
+    List.map (fun tdecl -> (tdecl.typ_id, tdecl.typ_type)) tdecls in
+  current_slot := None;
+  (* Check for duplicates *)
+  check_duplicates sdecl_list;
+  (* Build the final env. *)
+  let new_env = add_types_to_env decls env in
+  (* Update stubs *)
+  begin match rec_flag with
+    | Asttypes.Nonrecursive -> ()
+    | Asttypes.Recursive ->
+      List.iter2
+        (fun (id, _) sdecl -> update_type temp_env new_env id sdecl.ptype_loc)
+        ids_list sdecl_list
+  end;
+  (* Generalize type declarations. *)
+  Ctype.end_def();
+  List.iter (fun (_, decl) -> generalize_decl decl) decls;
+  (* Check for ill-formed abbrevs *)
+  let id_loc_list =
+    List.map2 (fun (id, _) sdecl -> (id, sdecl.ptype_loc))
+      ids_list sdecl_list
+  in
+  List.iter (fun (id, decl) ->
+    check_well_founded_manifest new_env (List.assoc id id_loc_list)
+      (Path.Pident id) decl)
+    decls;
+  let to_check =
+    function Path.Pident id -> List.mem_assoc id id_loc_list | _ -> false in
+  List.iter (fun (id, decl) ->
+    check_well_founded_decl new_env (List.assoc id id_loc_list) (Path.Pident id)
+      decl to_check)
+    decls;
+  List.iter
+    (check_abbrev_recursion ~orig_env:env new_env id_loc_list to_check) tdecls;
+  (* Check that all type variables are closed *)
+  List.iter2
+    (fun sdecl tdecl ->
+      let decl = tdecl.typ_type in
+       match Ctype.closed_type_decl decl with
+         Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl)))
+       | None   -> ())
+    sdecl_list tdecls;
+  (* Check that constraints are enforced *)
+  List.iter2 (check_constraints new_env) sdecl_list decls;
+  (* Add type properties to declarations *)
+  let decls =
+    try
+      decls
+      |> name_recursion_decls sdecl_list
+      |> Typedecl_variance.update_decls env sdecl_list
+      |> Typedecl_immediacy.update_decls env
+      |> Typedecl_separability.update_decls env
+    with
+    | Typedecl_variance.Error (loc, err) ->
+        raise (Error (loc, Variance err))
+    | Typedecl_immediacy.Error (loc, err) ->
+        raise (Error (loc, Immediacy err))
+    | Typedecl_separability.Error (loc, err) ->
+        raise (Error (loc, Separability err))
+  in
+  (* Compute the final environment with variance and immediacy *)
+  let final_env = add_types_to_env decls env in
+  (* Check re-exportation *)
+  List.iter2 (check_abbrev final_env) sdecl_list decls;
+  (* Keep original declaration *)
+  let final_decls =
+    List.map2
+      (fun tdecl (_id2, decl) ->
+        { tdecl with typ_type = decl }
+      ) tdecls decls
+  in
+  (* Done *)
+  (final_decls, final_env)
+
+(* Translating type extensions *)
+
+let transl_extension_constructor ~scope env type_path type_params
+                                 typext_params priv sext =
+  let id = Ident.create_scoped ~scope sext.pext_name.txt in
+  let args, ret_type, kind =
+    match sext.pext_kind with
+      Pext_decl(sargs, sret_type) ->
+        let targs, tret_type, args, ret_type =
+          make_constructor env type_path typext_params
+            sargs sret_type
+        in
+          args, ret_type, Text_decl(targs, tret_type)
+    | Pext_rebind lid ->
+        let usage : Env.constructor_usage =
+          if priv = Public then Env.Exported else Env.Exported_private
+        in
+        let cdescr = Env.lookup_constructor ~loc:lid.loc usage lid.txt env in
+        let (args, cstr_res, _ex) = Ctype.instance_constructor cdescr in
+        let res, ret_type =
+          if cdescr.cstr_generalized then
+            let params = Ctype.instance_list type_params in
+            let res = Ctype.newconstr type_path params in
+            let ret_type = Some (Ctype.newconstr type_path params) in
+              res, ret_type
+          else (Ctype.newconstr type_path typext_params), None
+        in
+        begin
+          try
+            Ctype.unify env cstr_res res
+          with Ctype.Unify trace ->
+            raise (Error(lid.loc,
+                     Rebind_wrong_type(lid.txt, env, trace)))
+        end;
+        (* Remove "_" names from parameters used in the constructor *)
+        if not cdescr.cstr_generalized then begin
+          let vars =
+            Ctype.free_variables (Btype.newgenty (Ttuple args))
+          in
+            List.iter
+              (function {desc = Tvar (Some "_")} as ty
+                  when List.memq ty vars ->
+                    Btype.set_type_desc ty (Tvar None)
+                | _ -> ())
+              typext_params
+        end;
+        (* Ensure that constructor's type matches the type being extended *)
+        let cstr_type_path, cstr_type_params =
+          match cdescr.cstr_res.desc with
+            Tconstr (p, _, _) ->
+              let decl = Env.find_type p env in
+                p, decl.type_params
+          | _ -> assert false
+        in
+        let cstr_types =
+          (Btype.newgenty
+             (Tconstr(cstr_type_path, cstr_type_params, ref Mnil)))
+          :: cstr_type_params
+        in
+        let ext_types =
+          (Btype.newgenty
+             (Tconstr(type_path, type_params, ref Mnil)))
+          :: type_params
+        in
+        if not (Ctype.is_equal env true cstr_types ext_types) then
+          raise (Error(lid.loc,
+                       Rebind_mismatch(lid.txt, cstr_type_path, type_path)));
+        (* Disallow rebinding private constructors to non-private *)
+        begin
+          match cdescr.cstr_private, priv with
+            Private, Public ->
+              raise (Error(lid.loc, Rebind_private lid.txt))
+          | _ -> ()
+        end;
+        let path =
+          match cdescr.cstr_tag with
+            Cstr_extension(path, _) -> path
+          | _ -> assert false
+        in
+        let args =
+          match cdescr.cstr_inlined with
+          | None ->
+              Types.Cstr_tuple args
+          | Some decl ->
+              let tl =
+                match args with
+                | [ {desc=Tconstr(_, tl, _)} ] -> tl
+                | _ -> assert false
+              in
+              let decl = Ctype.instance_declaration decl in
+              assert (List.length decl.type_params = List.length tl);
+              List.iter2 (Ctype.unify env) decl.type_params tl;
+              let lbls =
+                match decl.type_kind with
+                | Type_record (lbls, Record_extension _) -> lbls
+                | _ -> assert false
+              in
+              Types.Cstr_record lbls
+        in
+        args, ret_type, Text_rebind(path, lid)
+  in
+  let ext =
+    { ext_type_path = type_path;
+      ext_type_params = typext_params;
+      ext_args = args;
+      ext_ret_type = ret_type;
+      ext_private = priv;
+      Types.ext_loc = sext.pext_loc;
+      Types.ext_attributes = sext.pext_attributes;
+      ext_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+    }
+  in
+    { ext_id = id;
+      ext_name = sext.pext_name;
+      ext_type = ext;
+      ext_kind = kind;
+      Typedtree.ext_loc = sext.pext_loc;
+      Typedtree.ext_attributes = sext.pext_attributes; }
+
+let transl_extension_constructor ~scope env type_path type_params
+    typext_params priv sext =
+  Builtin_attributes.warning_scope sext.pext_attributes
+    (fun () -> transl_extension_constructor ~scope env type_path type_params
+        typext_params priv sext)
+
+let is_rebind ext =
+  match ext.ext_kind with
+  | Text_rebind _ -> true
+  | Text_decl _ -> false
+
+let transl_type_extension extend env loc styext =
+  (* Note: it would be incorrect to call [create_scope] *after*
+     [reset_type_variables] or after [begin_def] (see #10010). *)
+  let scope = Ctype.create_scope () in
+  reset_type_variables();
+  Ctype.begin_def();
+  let type_path, type_decl =
+    let lid = styext.ptyext_path in
+    Env.lookup_type ~loc:lid.loc lid.txt env
+  in
+  begin
+    match type_decl.type_kind with
+    | Type_open -> begin
+        match type_decl.type_private with
+        | Private when extend -> begin
+            match
+              List.find
+                (function {pext_kind = Pext_decl _} -> true
+                        | {pext_kind = Pext_rebind _} -> false)
+                styext.ptyext_constructors
+            with
+            | {pext_loc} ->
+                raise (Error(pext_loc, Cannot_extend_private_type type_path))
+            | exception Not_found -> ()
+          end
+        | _ -> ()
+      end
+    | _ ->
+        raise (Error(loc, Not_extensible_type type_path))
+  end;
+  let type_variance =
+    List.map (fun v ->
+                let (co, cn) = Variance.get_upper v in
+                  (not cn, not co, false))
+             type_decl.type_variance
+  in
+  let err =
+    if type_decl.type_arity <> List.length styext.ptyext_params then
+      Some Includecore.Arity
+    else
+      if List.for_all2
+           (fun (c1, n1, _) (c2, n2, _) -> (not c2 || c1) && (not n2 || n1))
+           type_variance
+           (Typedecl_variance.variance_of_params styext.ptyext_params)
+      then None else Some Includecore.Variance
+  in
+  begin match err with
+  | None -> ()
+  | Some err -> raise (Error(loc, Extension_mismatch (type_path, err)))
+  end;
+  let ttype_params = make_params env styext.ptyext_params in
+  let type_params = List.map (fun (cty, _) -> cty.ctyp_type) ttype_params in
+  List.iter2 (Ctype.unify_var env)
+    (Ctype.instance_list type_decl.type_params)
+    type_params;
+  let constructors =
+    List.map (transl_extension_constructor ~scope env type_path
+               type_decl.type_params type_params styext.ptyext_private)
+      styext.ptyext_constructors
+  in
+  Ctype.end_def();
+  (* Generalize types *)
+  List.iter Ctype.generalize type_params;
+  List.iter
+    (fun ext ->
+       Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args;
+       Option.iter Ctype.generalize ext.ext_type.ext_ret_type)
+    constructors;
+  (* Check that all type variables are closed *)
+  List.iter
+    (fun ext ->
+       match Ctype.closed_extension_constructor ext.ext_type with
+         Some ty ->
+           raise(Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type)))
+       | None -> ())
+    constructors;
+  (* Check variances are correct *)
+  List.iter
+    (fun ext->
+       (* Note that [loc] here is distinct from [type_decl.type_loc], which
+          makes the [loc] parameter to this function useful. [loc] is the
+          location of the extension, while [type_decl] points to the original
+          type declaration being extended. *)
+       try Typedecl_variance.check_variance_extension
+             env type_decl ext (type_variance, loc)
+       with Typedecl_variance.Error (loc, err) ->
+         raise (Error (loc, Variance err)))
+    constructors;
+  (* Add extension constructors to the environment *)
+  let newenv =
+    List.fold_left
+      (fun env ext ->
+         let rebind = is_rebind ext in
+         Env.add_extension ~check:true ~rebind ext.ext_id ext.ext_type env)
+      env constructors
+  in
+  let tyext =
+    { tyext_path = type_path;
+      tyext_txt = styext.ptyext_path;
+      tyext_params = ttype_params;
+      tyext_constructors = constructors;
+      tyext_private = styext.ptyext_private;
+      tyext_loc = styext.ptyext_loc;
+      tyext_attributes = styext.ptyext_attributes; }
+  in
+    (tyext, newenv)
+
+let transl_type_extension extend env loc styext =
+  Builtin_attributes.warning_scope styext.ptyext_attributes
+    (fun () -> transl_type_extension extend env loc styext)
+
+let transl_exception env sext =
+  let scope = Ctype.create_scope () in
+  reset_type_variables();
+  Ctype.begin_def();
+  let ext =
+    transl_extension_constructor ~scope env
+      Predef.path_exn [] [] Asttypes.Public sext
+  in
+  Ctype.end_def();
+  (* Generalize types *)
+  Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args;
+  Option.iter Ctype.generalize ext.ext_type.ext_ret_type;
+  (* Check that all type variables are closed *)
+  begin match Ctype.closed_extension_constructor ext.ext_type with
+    Some ty ->
+      raise (Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type)))
+  | None -> ()
+  end;
+  let rebind = is_rebind ext in
+  let newenv =
+    Env.add_extension ~check:true ~rebind ext.ext_id ext.ext_type env
+  in
+  ext, newenv
+
+let transl_type_exception env t =
+  Builtin_attributes.check_no_alert t.ptyexn_attributes;
+  let contructor, newenv =
+    Builtin_attributes.warning_scope t.ptyexn_attributes
+      (fun () ->
+         transl_exception env t.ptyexn_constructor
+      )
+  in
+  {tyexn_constructor = contructor;
+   tyexn_loc = t.ptyexn_loc;
+   tyexn_attributes = t.ptyexn_attributes}, newenv
+
+
+type native_repr_attribute =
+  | Native_repr_attr_absent
+  | Native_repr_attr_present of native_repr_kind
+
+let get_native_repr_attribute attrs ~global_repr =
+  match
+    Attr_helper.get_no_payload_attribute ["unboxed"; "ocaml.unboxed"]  attrs,
+    Attr_helper.get_no_payload_attribute ["untagged"; "ocaml.untagged"] attrs,
+    global_repr
+  with
+  | None, None, None -> Native_repr_attr_absent
+  | None, None, Some repr -> Native_repr_attr_present repr
+  | Some _, None, None -> Native_repr_attr_present Unboxed
+  | None, Some _, None -> Native_repr_attr_present Untagged
+  | Some { Location.loc }, _, _
+  | _, Some { Location.loc }, _ ->
+    raise (Error (loc, Multiple_native_repr_attributes))
+
+let native_repr_of_type env kind ty =
+  match kind, (Ctype.expand_head_opt env ty).desc with
+  | Untagged, Tconstr (path, _, _) when Path.same path Predef.path_int ->
+    Some Untagged_int
+  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_float ->
+    Some Unboxed_float
+  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int32 ->
+    Some (Unboxed_integer Pint32)
+  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int64 ->
+    Some (Unboxed_integer Pint64)
+  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_nativeint ->
+    Some (Unboxed_integer Pnativeint)
+  | _ ->
+    None
+
+(* Raises an error when [core_type] contains an [@unboxed] or [@untagged]
+   attribute in a strict sub-term. *)
+let error_if_has_deep_native_repr_attributes core_type =
+  let open Ast_iterator in
+  let this_iterator =
+    { default_iterator with typ = fun iterator core_type ->
+      begin
+        match
+          get_native_repr_attribute core_type.ptyp_attributes ~global_repr:None
+        with
+        | Native_repr_attr_present kind ->
+           raise (Error (core_type.ptyp_loc,
+                         Deep_unbox_or_untag_attribute kind))
+        | Native_repr_attr_absent -> ()
+      end;
+      default_iterator.typ iterator core_type }
+  in
+  default_iterator.typ this_iterator core_type
+
+let make_native_repr env core_type ty ~global_repr =
+  error_if_has_deep_native_repr_attributes core_type;
+  match get_native_repr_attribute core_type.ptyp_attributes ~global_repr with
+  | Native_repr_attr_absent ->
+    Same_as_ocaml_repr
+  | Native_repr_attr_present kind ->
+    begin match native_repr_of_type env kind ty with
+    | None ->
+      raise (Error (core_type.ptyp_loc, Cannot_unbox_or_untag_type kind))
+    | Some repr -> repr
+    end
+
+let rec parse_native_repr_attributes env core_type ty ~global_repr =
+  match core_type.ptyp_desc, (Ctype.repr ty).desc,
+    get_native_repr_attribute core_type.ptyp_attributes ~global_repr:None
+  with
+  | Ptyp_arrow _, Tarrow _, Native_repr_attr_present kind  ->
+    raise (Error (core_type.ptyp_loc, Cannot_unbox_or_untag_type kind))
+  | Ptyp_arrow (_, ct1, ct2), Tarrow (_, t1, t2, _), _ ->
+    let repr_arg = make_native_repr env ct1 t1 ~global_repr in
+    let repr_args, repr_res =
+      parse_native_repr_attributes env ct2 t2 ~global_repr
+    in
+    (repr_arg :: repr_args, repr_res)
+  | Ptyp_arrow _, _, _ | _, Tarrow _, _ -> assert false
+  | _ -> ([], make_native_repr env core_type ty ~global_repr)
+
+
+let check_unboxable env loc ty =
+  let check_type acc ty : Path.Set.t =
+    let ty = Ctype.repr (Ctype.expand_head_opt env ty) in
+    try match ty.desc with
+      | Tconstr (p, _, _) ->
+        let tydecl = Env.find_type p env in
+        if tydecl.type_unboxed_default then
+          Path.Set.add p acc
+        else acc
+      | _ -> acc
+    with Not_found -> acc
+  in
+  let all_unboxable_types = Btype.fold_type_expr check_type Path.Set.empty ty in
+  Path.Set.fold
+    (fun p () ->
+       Location.prerr_warning loc
+         (Warnings.Unboxable_type_in_prim_decl (Path.name p))
+    )
+    all_unboxable_types
+    ()
+
+(* Translate a value declaration *)
+let transl_value_decl env loc valdecl =
+  let cty = Typetexp.transl_type_scheme env valdecl.pval_type in
+  let ty = cty.ctyp_type in
+  let v =
+  match valdecl.pval_prim with
+    [] when Env.is_in_signature env ->
+      { val_type = ty; val_kind = Val_reg; Types.val_loc = loc;
+        val_attributes = valdecl.pval_attributes;
+        val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+      }
+  | [] ->
+      raise (Error(valdecl.pval_loc, Val_in_structure))
+  | _ ->
+      let global_repr =
+        match
+          get_native_repr_attribute valdecl.pval_attributes ~global_repr:None
+        with
+        | Native_repr_attr_present repr -> Some repr
+        | Native_repr_attr_absent -> None
+      in
+      let native_repr_args, native_repr_res =
+        parse_native_repr_attributes env valdecl.pval_type ty ~global_repr
+      in
+      let prim =
+        Primitive.parse_declaration valdecl
+          ~native_repr_args
+          ~native_repr_res
+      in
+      if prim.prim_arity = 0 &&
+         (prim.prim_name = "" || prim.prim_name.[0] <> '%') then
+        raise(Error(valdecl.pval_type.ptyp_loc, Null_arity_external));
+      if !Clflags.native_code
+      && prim.prim_arity > 5
+      && prim.prim_native_name = ""
+      then raise(Error(valdecl.pval_type.ptyp_loc, Missing_native_external));
+      check_unboxable env loc ty;
+      { val_type = ty; val_kind = Val_prim prim; Types.val_loc = loc;
+        val_attributes = valdecl.pval_attributes;
+        val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+      }
+  in
+  let (id, newenv) =
+    Env.enter_value valdecl.pval_name.txt v env
+      ~check:(fun s -> Warnings.Unused_value_declaration s)
+  in
+  let desc =
+    {
+     val_id = id;
+     val_name = valdecl.pval_name;
+     val_desc = cty; val_val = v;
+     val_prim = valdecl.pval_prim;
+     val_loc = valdecl.pval_loc;
+     val_attributes = valdecl.pval_attributes;
+    }
+  in
+  desc, newenv
+
+let transl_value_decl env loc valdecl =
+  Builtin_attributes.warning_scope valdecl.pval_attributes
+    (fun () -> transl_value_decl env loc valdecl)
+
+(* Translate a "with" constraint -- much simplified version of
+   transl_type_decl. For a constraint [Sig with t = sdecl],
+   there are two declarations of interest in two environments:
+   - [sig_decl] is the declaration of [t] in [Sig],
+     in the environment [sig_env] (containing the declarations
+     of [Sig] before [t])
+   - [sdecl] is the new syntactic declaration, to be type-checked
+     in the current, outer environment [with_env].
+
+   In particular, note that [sig_env] is an extension of
+   [outer_env].
+*)
+let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env
+    sdecl =
+  Env.mark_type_used sig_decl.type_uid;
+  reset_type_variables();
+  Ctype.begin_def();
+  (* In the first part of this function, we typecheck the syntactic
+     declaration [sdecl] in the outer environment [outer_env]. *)
+  let env = outer_env in
+  let loc = sdecl.ptype_loc in
+  let tparams = make_params env sdecl.ptype_params in
+  let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in
+  let arity = List.length params in
+  let constraints =
+    List.map (fun (ty, ty', loc) ->
+      let cty = transl_simple_type env false ty in
+      let cty' = transl_simple_type env false ty' in
+      (* Note: We delay the unification of those constraints
+         after the unification of parameters, so that clashing
+         constraints report an error on the constraint location
+         rather than the parameter location. *)
+      (cty, cty', loc)
+    ) sdecl.ptype_cstrs
+  in
+  let no_row = not (is_fixed_type sdecl) in
+  let (tman, man) =  match sdecl.ptype_manifest with
+      None -> None, None
+    | Some sty ->
+        let cty = transl_simple_type env no_row sty in
+        Some cty, Some cty.ctyp_type
+  in
+  (* In the second part, we check the consistency between the two
+     declarations and compute a "merged" declaration; we now need to
+     work in the larger signature environment [sig_env], because
+     [sig_decl.type_params] and [sig_decl.type_kind] are only valid
+     there. *)
+  let env = sig_env in
+  let sig_decl = Ctype.instance_declaration sig_decl in
+  let arity_ok = arity = sig_decl.type_arity in
+  if arity_ok then
+    List.iter2 (fun (cty, _) tparam ->
+      try Ctype.unify_var env cty.ctyp_type tparam
+      with Ctype.Unify tr ->
+        raise(Error(cty.ctyp_loc, Inconsistent_constraint (env, tr)))
+    ) tparams sig_decl.type_params;
+  List.iter (fun (cty, cty', loc) ->
+    (* Note: constraints must also be enforced in [sig_env] because
+       they may contain parameter variables from [tparams]
+       that have now be unified in [sig_env]. *)
+    try Ctype.unify env cty.ctyp_type cty'.ctyp_type
+    with Ctype.Unify tr ->
+      raise(Error(loc, Inconsistent_constraint (env, tr)))
+  ) constraints;
+  let priv =
+    if sdecl.ptype_private = Private then Private else
+    if arity_ok && sig_decl.type_kind <> Type_abstract
+    then sig_decl.type_private else sdecl.ptype_private
+  in
+  if arity_ok && sig_decl.type_kind <> Type_abstract
+  && sdecl.ptype_private = Private then
+    Location.deprecated loc "spurious use of private";
+  let type_kind, type_unboxed_default =
+    if arity_ok && man <> None then
+      sig_decl.type_kind, sig_decl.type_unboxed_default
+    else
+      Type_abstract, false
+  in
+  let new_sig_decl =
+    { type_params = params;
+      type_arity = arity;
+      type_kind;
+      type_private = priv;
+      type_manifest = man;
+      type_variance = [];
+      type_separability = Types.Separability.default_signature ~arity;
+      type_is_newtype = false;
+      type_expansion_scope = Btype.lowest_level;
+      type_loc = loc;
+      type_attributes = sdecl.ptype_attributes;
+      type_immediate = Unknown;
+      type_unboxed_default;
+      type_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+    }
+  in
+  Option.iter (fun p -> set_private_row env sdecl.ptype_loc p new_sig_decl)
+    fixed_row_path;
+  begin match Ctype.closed_type_decl new_sig_decl with None -> ()
+  | Some ty -> raise(Error(loc, Unbound_type_var(ty, new_sig_decl)))
+  end;
+  let new_sig_decl = name_recursion sdecl id new_sig_decl in
+  let new_type_variance =
+    let required = Typedecl_variance.variance_of_sdecl sdecl in
+    try
+      Typedecl_variance.compute_decl env ~check:true new_sig_decl required
+    with Typedecl_variance.Error (loc, err) ->
+      raise (Error (loc, Variance err)) in
+  let new_type_immediate =
+    (* Typedecl_immediacy.compute_decl never raises *)
+    Typedecl_immediacy.compute_decl env new_sig_decl in
+  let new_type_separability =
+    try Typedecl_separability.compute_decl env new_sig_decl
+    with Typedecl_separability.Error (loc, err) ->
+      raise (Error (loc, Separability err)) in
+  let new_sig_decl =
+    (* we intentionally write this without a fragile { decl with ... }
+       to ensure that people adding new fields to type declarations
+       consider whether they need to recompute it here; for an example
+       of bug caused by the previous approach, see #9607 *)
+    {
+      type_params = new_sig_decl.type_params;
+      type_arity = new_sig_decl.type_arity;
+      type_kind = new_sig_decl.type_kind;
+      type_private = new_sig_decl.type_private;
+      type_manifest = new_sig_decl.type_manifest;
+      type_unboxed_default = new_sig_decl.type_unboxed_default;
+      type_is_newtype = new_sig_decl.type_is_newtype;
+      type_expansion_scope = new_sig_decl.type_expansion_scope;
+      type_loc = new_sig_decl.type_loc;
+      type_attributes = new_sig_decl.type_attributes;
+      type_uid = new_sig_decl.type_uid;
+
+      type_variance = new_type_variance;
+      type_immediate = new_type_immediate;
+      type_separability = new_type_separability;
+    } in
+  Ctype.end_def();
+  generalize_decl new_sig_decl;
+  {
+    typ_id = id;
+    typ_name = sdecl.ptype_name;
+    typ_params = tparams;
+    typ_type = new_sig_decl;
+    typ_cstrs = constraints;
+    typ_loc = loc;
+    typ_manifest = tman;
+    typ_kind = Ttype_abstract;
+    typ_private = sdecl.ptype_private;
+    typ_attributes = sdecl.ptype_attributes;
+  }
+
+(* Approximate a type declaration: just make all types abstract *)
+
+let abstract_type_decl ~injective arity =
+  let rec make_params n =
+    if n <= 0 then [] else Ctype.newvar() :: make_params (n-1) in
+  Ctype.begin_def();
+  let decl =
+    { type_params = make_params arity;
+      type_arity = arity;
+      type_kind = Type_abstract;
+      type_private = Public;
+      type_manifest = None;
+      type_variance = Variance.unknown_signature ~injective ~arity;
+      type_separability = Types.Separability.default_signature ~arity;
+      type_is_newtype = false;
+      type_expansion_scope = Btype.lowest_level;
+      type_loc = Location.none;
+      type_attributes = [];
+      type_immediate = Unknown;
+      type_unboxed_default = false;
+      type_uid = Uid.internal_not_actually_unique;
+     } in
+  Ctype.end_def();
+  generalize_decl decl;
+  decl
+
+let approx_type_decl sdecl_list =
+  let scope = Ctype.create_scope () in
+  List.map
+    (fun sdecl ->
+      let injective = sdecl.ptype_kind <> Ptype_abstract in
+      (Ident.create_scoped ~scope sdecl.ptype_name.txt,
+       abstract_type_decl ~injective (List.length sdecl.ptype_params)))
+    sdecl_list
+
+(* Variant of check_abbrev_recursion to check the well-formedness
+   conditions on type abbreviations defined within recursive modules. *)
+
+let check_recmod_typedecl env loc recmod_ids path decl =
+  (* recmod_ids is the list of recursively-defined module idents.
+     (path, decl) is the type declaration to be checked. *)
+  let to_check path = Path.exists_free recmod_ids path in
+  check_well_founded_decl env loc path decl to_check;
+  check_recursion ~orig_env:env env loc path decl to_check;
+  (* additionally check coherece, as one might build an incoherent signature,
+     and use it to build an incoherent module, cf. #7851 *)
+  check_coherence env loc path decl
+
+
+(**** Error report ****)
+
+open Format
+
+let explain_unbound_gen ppf tv tl typ kwd pr =
+  try
+    let ti = List.find (fun ti -> Ctype.deep_occur tv (typ ti)) tl in
+    let ty0 = (* Hack to force aliasing when needed *)
+      Btype.newgenty (Tobject(tv, ref None)) in
+    Printtyp.reset_and_mark_loops_list [typ ti; ty0];
+    fprintf ppf
+      ".@ @[<hov2>In %s@ %a@;<1 -2>the variable %a is unbound@]"
+      kwd pr ti Printtyp.marked_type_expr tv
+  with Not_found -> ()
+
+let explain_unbound ppf tv tl typ kwd lab =
+  explain_unbound_gen ppf tv tl typ kwd
+    (fun ppf ti ->
+       fprintf ppf "%s%a" (lab ti) Printtyp.marked_type_expr (typ ti)
+    )
+
+let explain_unbound_single ppf tv ty =
+  let trivial ty =
+    explain_unbound ppf tv [ty] (fun t -> t) "type" (fun _ -> "") in
+  match (Ctype.repr ty).desc with
+    Tobject(fi,_) ->
+      let (tl, rv) = Ctype.flatten_fields fi in
+      if rv == tv then trivial ty else
+      explain_unbound ppf tv tl (fun (_,_,t) -> t)
+        "method" (fun (lab,_,_) -> lab ^ ": ")
+  | Tvariant row ->
+      let row = Btype.row_repr row in
+      if row.row_more == tv then trivial ty else
+      explain_unbound ppf tv row.row_fields
+        (fun (_l,f) -> match Btype.row_field_repr f with
+          Rpresent (Some t) -> t
+        | Reither (_,[t],_,_) -> t
+        | Reither (_,tl,_,_) -> Btype.newgenty (Ttuple tl)
+        | _ -> Btype.newgenty (Ttuple[]))
+        "case" (fun (lab,_) -> "`" ^ lab ^ " of ")
+  | _ -> trivial ty
+
+
+let tys_of_constr_args = function
+  | Types.Cstr_tuple tl -> tl
+  | Types.Cstr_record lbls -> List.map (fun l -> l.Types.ld_type) lbls
+
+let report_error ppf = function
+  | Repeated_parameter ->
+      fprintf ppf "A type parameter occurs several times"
+  | Duplicate_constructor s ->
+      fprintf ppf "Two constructors are named %s" s
+  | Too_many_constructors ->
+      fprintf ppf
+        "@[Too many non-constant constructors@ -- maximum is %i %s@]"
+        (Config.max_tag + 1) "non-constant constructors"
+  | Duplicate_label s ->
+      fprintf ppf "Two labels are named %s" s
+  | Recursive_abbrev s ->
+      fprintf ppf "The type abbreviation %s is cyclic" s
+  | Cycle_in_def (s, ty) ->
+      fprintf ppf "@[<v>The definition of %s contains a cycle:@ %a@]"
+        s Printtyp.type_expr ty
+  | Definition_mismatch (ty, None) ->
+      fprintf ppf "@[<v>@[<hov>%s@ %s@;<1 2>%a@]@]"
+        "This variant or record definition" "does not match that of type"
+        Printtyp.type_expr ty
+  | Definition_mismatch (ty, Some err) ->
+      fprintf ppf "@[<v>@[<hov>%s@ %s@;<1 2>%a@]%a@]"
+        "This variant or record definition" "does not match that of type"
+        Printtyp.type_expr ty
+        (Includecore.report_type_mismatch "the original" "this" "definition")
+        err
+  | Constraint_failed (env, trace) ->
+      fprintf ppf "@[<v>Constraints are not satisfied in this type.@ ";
+      Printtyp.report_unification_error ppf env trace
+        (fun ppf -> fprintf ppf "Type")
+        (fun ppf -> fprintf ppf "should be an instance of");
+      fprintf ppf "@]"
+  | Non_regular { definition; used_as; defined_as; expansions } ->
+      let pp_expansion ppf (ty,body) =
+        Format.fprintf ppf "%a = %a"
+          Printtyp.type_expr ty
+          Printtyp.type_expr body in
+      let comma ppf () = Format.fprintf ppf ",@;<1 2>" in
+      let pp_expansions ppf expansions =
+        Format.(pp_print_list ~pp_sep:comma pp_expansion) ppf expansions in
+      Printtyp.reset_and_mark_loops used_as;
+      Printtyp.mark_loops defined_as;
+      Printtyp.Naming_context.reset ();
+      begin match expansions with
+      | [] ->
+          fprintf ppf
+            "@[<hv>This recursive type is not regular.@ \
+             The type constructor %s is defined as@;<1 2>type %a@ \
+             but it is used as@;<1 2>%a.@ \
+             All uses need to match the definition for the recursive type \
+             to be regular.@]"
+            (Path.name definition)
+            !Oprint.out_type (Printtyp.tree_of_typexp false defined_as)
+            !Oprint.out_type (Printtyp.tree_of_typexp false used_as)
+      | _ :: _ ->
+          fprintf ppf
+            "@[<hv>This recursive type is not regular.@ \
+             The type constructor %s is defined as@;<1 2>type %a@ \
+             but it is used as@;<1 2>%a@ \
+             after the following expansion(s):@;<1 2>%a@ \
+             All uses need to match the definition for the recursive type \
+             to be regular.@]"
+            (Path.name definition)
+            !Oprint.out_type (Printtyp.tree_of_typexp false defined_as)
+            !Oprint.out_type (Printtyp.tree_of_typexp false used_as)
+            pp_expansions expansions
+      end
+  | Inconsistent_constraint (env, trace) ->
+      fprintf ppf "@[<v>The type constraints are not consistent.@ ";
+      Printtyp.report_unification_error ppf env trace
+        (fun ppf -> fprintf ppf "Type")
+        (fun ppf -> fprintf ppf "is not compatible with type");
+      fprintf ppf "@]"
+  | Type_clash (env, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "This type constructor expands to type")
+        (function ppf ->
+           fprintf ppf "but is used here with type")
+  | Null_arity_external ->
+      fprintf ppf "External identifiers must be functions"
+  | Missing_native_external ->
+      fprintf ppf "@[<hv>An external function with more than 5 arguments \
+                   requires a second stub function@ \
+                   for native-code compilation@]"
+  | Unbound_type_var (ty, decl) ->
+      fprintf ppf "@[A type variable is unbound in this type declaration";
+      let ty = Ctype.repr ty in
+      begin match decl.type_kind, decl.type_manifest with
+      | Type_variant (tl, _rep), _ ->
+          explain_unbound_gen ppf ty tl (fun c ->
+              let tl = tys_of_constr_args c.Types.cd_args in
+              Btype.newgenty (Ttuple tl)
+            )
+            "case" (fun ppf c ->
+                fprintf ppf
+                  "%a of %a" Printtyp.ident c.Types.cd_id
+                  Printtyp.constructor_arguments c.Types.cd_args)
+      | Type_record (tl, _), _ ->
+          explain_unbound ppf ty tl (fun l -> l.Types.ld_type)
+            "field" (fun l -> Ident.name l.Types.ld_id ^ ": ")
+      | Type_abstract, Some ty' ->
+          explain_unbound_single ppf ty ty'
+      | _ -> ()
+      end;
+      fprintf ppf "@]"
+  | Unbound_type_var_ext (ty, ext) ->
+      fprintf ppf "@[A type variable is unbound in this extension constructor";
+      let args = tys_of_constr_args ext.ext_args in
+      explain_unbound ppf ty args (fun c -> c) "type" (fun _ -> "");
+      fprintf ppf "@]"
+  | Cannot_extend_private_type path ->
+      fprintf ppf "@[%s@ %a@]"
+        "Cannot extend private type definition"
+        Printtyp.path path
+  | Not_extensible_type path ->
+      fprintf ppf "@[%s@ %a@ %s@]"
+        "Type definition"
+        Printtyp.path path
+        "is not extensible"
+  | Extension_mismatch (path, err) ->
+      fprintf ppf "@[<v>@[<hov>%s@ %s@;<1 2>%s@]%a@]"
+        "This extension" "does not match the definition of type"
+        (Path.name path)
+        (Includecore.report_type_mismatch
+           "the type" "this extension" "definition")
+        err
+  | Rebind_wrong_type (lid, env, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "The constructor %a@ has type"
+             Printtyp.longident lid)
+        (function ppf ->
+           fprintf ppf "but was expected to be of type")
+  | Rebind_mismatch (lid, p, p') ->
+      fprintf ppf
+        "@[%s@ %a@ %s@ %s@ %s@ %s@ %s@]"
+        "The constructor" Printtyp.longident lid
+        "extends type" (Path.name p)
+        "whose declaration does not match"
+        "the declaration of type" (Path.name p')
+  | Rebind_private lid ->
+      fprintf ppf "@[%s@ %a@ %s@]"
+        "The constructor"
+        Printtyp.longident lid
+        "is private"
+  | Variance (Typedecl_variance.Bad_variance (n, v1, v2)) ->
+      let variance (p,n,i) =
+        let inj = if i then "injective " else "" in
+        match p, n with
+          true,  true  -> inj ^ "invariant"
+        | true,  false -> inj ^ "covariant"
+        | false, true  -> inj ^ "contravariant"
+        | false, false -> if inj = "" then "unrestricted" else inj
+      in
+      let suffix n =
+        let teen = (n mod 100)/10 = 1 in
+        match n mod 10 with
+        | 1 when not teen -> "st"
+        | 2 when not teen -> "nd"
+        | 3 when not teen -> "rd"
+        | _ -> "th"
+      in
+      (match n with
+       | Variance_not_reflected ->
+           fprintf ppf "@[%s@ %s@ It"
+             "In this definition, a type variable has a variance that"
+             "is not reflected by its occurrence in type parameters."
+       | No_variable ->
+           fprintf ppf "@[%s@ %s@]"
+             "In this definition, a type variable cannot be deduced"
+             "from the type parameters."
+       | Variance_not_deducible ->
+           fprintf ppf "@[%s@ %s@ It"
+             "In this definition, a type variable has a variance that"
+             "cannot be deduced from the type parameters."
+       | Variance_not_satisfied n ->
+           fprintf ppf "@[%s@ %s@ The %d%s type parameter"
+             "In this definition, expected parameter"
+             "variances are not satisfied."
+             n (suffix n));
+      (match n with
+       | No_variable -> ()
+       | _ ->
+           fprintf ppf " was expected to be %s,@ but it is %s.@]"
+             (variance v2) (variance v1))
+  | Unavailable_type_constructor p ->
+      fprintf ppf "The definition of type %a@ is unavailable" Printtyp.path p
+  | Variance Typedecl_variance.Varying_anonymous ->
+      fprintf ppf "@[%s@ %s@ %s@]"
+        "In this GADT definition," "the variance of some parameter"
+        "cannot be checked"
+  | Val_in_structure ->
+      fprintf ppf "Value declarations are only allowed in signatures"
+  | Multiple_native_repr_attributes ->
+      fprintf ppf "Too many [@@unboxed]/[@@untagged] attributes"
+  | Cannot_unbox_or_untag_type Unboxed ->
+      fprintf ppf "@[Don't know how to unbox this type.@ \
+                   Only float, int32, int64 and nativeint can be unboxed.@]"
+  | Cannot_unbox_or_untag_type Untagged ->
+      fprintf ppf "@[Don't know how to untag this type.@ \
+                   Only int can be untagged.@]"
+  | Deep_unbox_or_untag_attribute kind ->
+      fprintf ppf
+        "@[The attribute '%s' should be attached to@ \
+         a direct argument or result of the primitive,@ \
+         it should not occur deeply into its type.@]"
+        (match kind with Unboxed -> "@unboxed" | Untagged -> "@untagged")
+  | Immediacy (Typedecl_immediacy.Bad_immediacy_attribute violation) ->
+      fprintf ppf "@[%a@]" Format.pp_print_text
+        (match violation with
+         | Type_immediacy.Violation.Not_always_immediate ->
+             "Types marked with the immediate attribute must be \
+              non-pointer types like int or bool."
+         | Type_immediacy.Violation.Not_always_immediate_on_64bits ->
+             "Types marked with the immediate64 attribute must be \
+              produced using the Stdlib.Sys.Immediate64.Make functor.")
+  | Bad_unboxed_attribute msg ->
+      fprintf ppf "@[This type cannot be unboxed because@ %s.@]" msg
+  | Separability (Typedecl_separability.Non_separable_evar evar) ->
+      let pp_evar ppf = function
+        | None ->
+            fprintf ppf "an unnamed existential variable"
+        | Some str ->
+            fprintf ppf "the existential variable %a"
+              Pprintast.tyvar str in
+      fprintf ppf "@[This type cannot be unboxed because@ \
+                   it might contain both float and non-float values,@ \
+                   depending on the instantiation of %a.@ \
+                   You should annotate it with [%@%@ocaml.boxed].@]"
+        pp_evar evar
+  | Boxed_and_unboxed ->
+      fprintf ppf "@[A type cannot be boxed and unboxed at the same time.@]"
+  | Nonrec_gadt ->
+      fprintf ppf
+        "@[GADT case syntax cannot be used in a 'nonrec' block.@]"
+  | Invalid_private_row_declaration ty ->
+      Format.fprintf ppf
+        "@[<hv>This private row type declaration is invalid.@ \
+         The type expression on the right-hand side reduces to@;<1 2>%a@ \
+         which does not have a free row type variable.@]@,\
+         @[<hv>@[Hint: If you intended to define a private type abbreviation,@ \
+         write explicitly@]@;<1 2>private %a@]"
+        Printtyp.type_expr ty Printtyp.type_expr ty
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, err) ->
+        Some (Location.error_of_printer ~loc report_error err)
+      | _ ->
+        None
+    )
diff --git a/upstream/ocaml_413/typing/typedecl.mli b/upstream/ocaml_413/typing/typedecl.mli
new file mode 100644
index 0000000..2ec3fef
--- /dev/null
+++ b/upstream/ocaml_413/typing/typedecl.mli
@@ -0,0 +1,109 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Typing of type definitions and primitive definitions *)
+
+open Types
+open Format
+
+val transl_type_decl:
+    Env.t -> Asttypes.rec_flag -> Parsetree.type_declaration list ->
+    Typedtree.type_declaration list * Env.t
+
+val transl_exception:
+    Env.t -> Parsetree.extension_constructor ->
+    Typedtree.extension_constructor * Env.t
+
+val transl_type_exception:
+    Env.t ->
+    Parsetree.type_exception -> Typedtree.type_exception * Env.t
+
+val transl_type_extension:
+    bool -> Env.t -> Location.t -> Parsetree.type_extension ->
+    Typedtree.type_extension * Env.t
+
+val transl_value_decl:
+    Env.t -> Location.t ->
+    Parsetree.value_description -> Typedtree.value_description * Env.t
+
+(* If the [fixed_row_path] optional argument is provided,
+   the [Parsetree.type_declaration] argument should satisfy [is_fixed_type] *)
+val transl_with_constraint:
+    Ident.t -> ?fixed_row_path:Path.t ->
+    sig_env:Env.t -> sig_decl:Types.type_declaration ->
+    outer_env:Env.t -> Parsetree.type_declaration ->
+    Typedtree.type_declaration
+
+val abstract_type_decl: injective:bool -> int -> type_declaration
+val approx_type_decl:
+    Parsetree.type_declaration list ->
+                                  (Ident.t * type_declaration) list
+val check_recmod_typedecl:
+    Env.t -> Location.t -> Ident.t list -> Path.t -> type_declaration -> unit
+val check_coherence:
+    Env.t -> Location.t -> Path.t -> type_declaration -> unit
+
+(* for fixed types *)
+val is_fixed_type : Parsetree.type_declaration -> bool
+
+(* for typeopt.ml *)
+val get_unboxed_type_representation: Env.t -> type_expr -> type_expr option
+
+type native_repr_kind = Unboxed | Untagged
+
+type error =
+    Repeated_parameter
+  | Duplicate_constructor of string
+  | Too_many_constructors
+  | Duplicate_label of string
+  | Recursive_abbrev of string
+  | Cycle_in_def of string * type_expr
+  | Definition_mismatch of type_expr * Includecore.type_mismatch option
+  | Constraint_failed of Env.t * Errortrace.unification Errortrace.t
+  | Inconsistent_constraint of Env.t * Errortrace.unification Errortrace.t
+  | Type_clash of Env.t * Errortrace.unification Errortrace.t
+  | Non_regular of {
+      definition: Path.t;
+      used_as: type_expr;
+      defined_as: type_expr;
+      expansions: (type_expr * type_expr) list;
+    }
+  | Null_arity_external
+  | Missing_native_external
+  | Unbound_type_var of type_expr * type_declaration
+  | Cannot_extend_private_type of Path.t
+  | Not_extensible_type of Path.t
+  | Extension_mismatch of Path.t * Includecore.type_mismatch
+  | Rebind_wrong_type of
+      Longident.t * Env.t * Errortrace.unification Errortrace.t
+  | Rebind_mismatch of Longident.t * Path.t * Path.t
+  | Rebind_private of Longident.t
+  | Variance of Typedecl_variance.error
+  | Unavailable_type_constructor of Path.t
+  | Unbound_type_var_ext of type_expr * extension_constructor
+  | Val_in_structure
+  | Multiple_native_repr_attributes
+  | Cannot_unbox_or_untag_type of native_repr_kind
+  | Deep_unbox_or_untag_attribute of native_repr_kind
+  | Immediacy of Typedecl_immediacy.error
+  | Separability of Typedecl_separability.error
+  | Bad_unboxed_attribute of string
+  | Boxed_and_unboxed
+  | Nonrec_gadt
+  | Invalid_private_row_declaration of type_expr
+
+exception Error of Location.t * error
+
+val report_error: formatter -> error -> unit
diff --git a/upstream/ocaml_413/typing/typedecl_immediacy.ml b/upstream/ocaml_413/typing/typedecl_immediacy.ml
new file mode 100644
index 0000000..bcc4d34
--- /dev/null
+++ b/upstream/ocaml_413/typing/typedecl_immediacy.ml
@@ -0,0 +1,71 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Types
+
+type error = Bad_immediacy_attribute of Type_immediacy.Violation.t
+exception Error of Location.t * error
+
+let compute_decl env tdecl =
+  match (tdecl.type_kind, tdecl.type_manifest) with
+  | (Type_variant ([{cd_args = Cstr_tuple [arg]
+                            | Cstr_record [{ld_type = arg; _}]; _}],
+                   Variant_unboxed)
+    | Type_record ([{ld_type = arg; _}], Record_unboxed _)), _ ->
+    begin match Typedecl_unboxed.get_unboxed_type_representation env arg with
+    | Typedecl_unboxed.Unavailable -> Type_immediacy.Unknown
+    | Typedecl_unboxed.This argrepr -> Ctype.immediacy env argrepr
+    | Typedecl_unboxed.Only_on_64_bits argrepr ->
+        match Ctype.immediacy env argrepr with
+        | Type_immediacy.Always -> Type_immediacy.Always_on_64bits
+        | Type_immediacy.Always_on_64bits | Type_immediacy.Unknown as x -> x
+    end
+  | (Type_variant (_ :: _ as cstrs, _), _) ->
+    if not (List.exists (fun c -> c.Types.cd_args <> Types.Cstr_tuple []) cstrs)
+    then
+      Type_immediacy.Always
+    else
+      Type_immediacy.Unknown
+  | (Type_abstract, Some(typ)) -> Ctype.immediacy env typ
+  | (Type_abstract, None) -> Type_immediacy.of_attributes tdecl.type_attributes
+  | _ -> Type_immediacy.Unknown
+
+let property : (Type_immediacy.t, unit) Typedecl_properties.property =
+  let open Typedecl_properties in
+  let eq = (=) in
+  let merge ~prop:_ ~new_prop = new_prop in
+  let default _decl = Type_immediacy.Unknown in
+  let compute env decl () = compute_decl env decl in
+  let update_decl decl immediacy = { decl with type_immediate = immediacy } in
+  let check _env _id decl () =
+    let written_by_user = Type_immediacy.of_attributes decl.type_attributes in
+    match Type_immediacy.coerce decl.type_immediate ~as_:written_by_user with
+    | Ok () -> ()
+    | Error violation ->
+        raise (Error (decl.type_loc,
+                      Bad_immediacy_attribute violation))
+  in
+  {
+    eq;
+    merge;
+    default;
+    compute;
+    update_decl;
+    check;
+  }
+
+let update_decls env decls =
+  Typedecl_properties.compute_property_noreq property env decls
diff --git a/upstream/ocaml_413/typing/typedecl_immediacy.mli b/upstream/ocaml_413/typing/typedecl_immediacy.mli
new file mode 100644
index 0000000..17fb985
--- /dev/null
+++ b/upstream/ocaml_413/typing/typedecl_immediacy.mli
@@ -0,0 +1,27 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type error = Bad_immediacy_attribute of Type_immediacy.Violation.t
+exception Error of Location.t * error
+
+val compute_decl : Env.t -> Types.type_declaration -> Type_immediacy.t
+
+val property : (Type_immediacy.t, unit) Typedecl_properties.property
+
+val update_decls :
+  Env.t ->
+  (Ident.t * Typedecl_properties.decl) list ->
+  (Ident.t * Typedecl_properties.decl) list
diff --git a/upstream/ocaml_413/typing/typedecl_properties.ml b/upstream/ocaml_413/typing/typedecl_properties.ml
new file mode 100644
index 0000000..28a1bb6
--- /dev/null
+++ b/upstream/ocaml_413/typing/typedecl_properties.ml
@@ -0,0 +1,73 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type decl = Types.type_declaration
+
+type ('prop, 'req) property = {
+  eq : 'prop -> 'prop -> bool;
+  merge : prop:'prop -> new_prop:'prop -> 'prop;
+
+  default : decl -> 'prop;
+  compute : Env.t -> decl -> 'req -> 'prop;
+  update_decl : decl -> 'prop -> decl;
+
+  check : Env.t -> Ident.t -> decl -> 'req -> unit;
+}
+
+let add_type ~check id decl env =
+  let open Types in
+  Builtin_attributes.warning_scope ~ppwarning:false decl.type_attributes
+    (fun () -> Env.add_type ~check id decl env)
+
+let add_types_to_env decls env =
+  List.fold_right
+    (fun (id, decl) env -> add_type ~check:true id decl env)
+    decls env
+
+let compute_property
+: ('prop, 'req) property -> Env.t ->
+  (Ident.t * decl) list -> 'req list -> (Ident.t * decl) list
+= fun property env decls required ->
+  (* [decls] and [required] must be lists of the same size,
+     with [required] containing the requirement for the corresponding
+     declaration in [decls]. *)
+  let props = List.map (fun (_id, decl) -> property.default decl) decls in
+  let rec compute_fixpoint props =
+    let new_decls =
+      List.map2 (fun (id, decl) prop ->
+          (id, property.update_decl decl prop))
+        decls props in
+    let new_env = add_types_to_env new_decls env in
+    let new_props =
+      List.map2
+        (fun (_id, decl) (prop, req) ->
+           let new_prop = property.compute new_env decl req in
+           property.merge ~prop ~new_prop)
+        new_decls (List.combine props required) in
+    if not (List.for_all2 property.eq props new_props)
+    then compute_fixpoint new_props
+    else begin
+      List.iter2
+        (fun (id, decl) req -> property.check new_env id decl req)
+        new_decls required;
+      new_decls
+    end
+  in
+  compute_fixpoint props
+
+let compute_property_noreq property env decls =
+  let req = List.map (fun _ -> ()) decls in
+  compute_property property env decls req
diff --git a/upstream/ocaml_413/typing/typedecl_properties.mli b/upstream/ocaml_413/typing/typedecl_properties.mli
new file mode 100644
index 0000000..153c3f7
--- /dev/null
+++ b/upstream/ocaml_413/typing/typedecl_properties.mli
@@ -0,0 +1,55 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type decl = Types.type_declaration
+
+(** An abstract interface for properties of type definitions, such as
+   variance and immediacy, that are computed by a fixpoint on
+   mutually-recursive type declarations. This interface contains all
+   the operations needed to initialize and run the fixpoint
+   computation, and then (optionally) check that the result is
+   consistent with the declaration or user expectations. *)
+
+type ('prop, 'req) property = {
+  eq : 'prop -> 'prop -> bool;
+  merge : prop:'prop -> new_prop:'prop -> 'prop;
+
+  default : decl -> 'prop;
+  compute : Env.t -> decl -> 'req -> 'prop;
+  update_decl : decl -> 'prop -> decl;
+
+  check : Env.t -> Ident.t -> decl -> 'req -> unit;
+}
+(** ['prop] represents the type of property values
+    ({!Types.Variance.t}, just 'bool' for immediacy, etc).
+
+    ['req] represents the property value required by the author of the
+    declaration, if they gave an expectation: [type +'a t = ...].
+
+    Some properties have no natural notion of user requirement, or
+    their requirement is global, or already stored in
+    [type_declaration]; they can just use [unit] as ['req] parameter. *)
+
+
+(** [compute_property prop env decls req] performs a fixpoint computation
+    to determine the final values of a property on a set of mutually-recursive
+    type declarations. The [req] argument must be a list of the same size as
+    [decls], providing the user requirement for each declaration. *)
+val compute_property : ('prop, 'req) property -> Env.t ->
+  (Ident.t * decl) list -> 'req list -> (Ident.t * decl) list
+
+val compute_property_noreq : ('prop, unit) property -> Env.t ->
+  (Ident.t * decl) list -> (Ident.t * decl) list
diff --git a/upstream/ocaml_413/typing/typedecl_separability.ml b/upstream/ocaml_413/typing/typedecl_separability.ml
new file mode 100644
index 0000000..0d4efd6
--- /dev/null
+++ b/upstream/ocaml_413/typing/typedecl_separability.ml
@@ -0,0 +1,674 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Types
+
+type type_definition = type_declaration
+(* We should use 'declaration' for interfaces, and 'definition' for
+   implementations. The name type_declaration in types.ml is improper
+   for our usage -- although for OCaml types the declaration and
+   definition languages are the same. *)
+
+(** assuming that a datatype has a single constructor/label with
+   a single argument, [argument_to_unbox] represents the
+   information we need to check the argument for separability. *)
+type argument_to_unbox = {
+  argument_type: type_expr;
+  result_type_parameter_instances: type_expr list;
+  (** result_type_parameter_instances represents the domain of the
+     constructor; usually it is just a list of the datatype parameter
+     ('a, 'b, ...), but when using GADTs or constraints it could
+     contain arbitrary type expressions.
+
+     For example, [type 'a t = 'b constraint 'a = 'b * int] has
+     [['b * int]] as [result_type_parameter_instances], and so does
+     [type _ t = T : 'b -> ('b * int) t]. *)
+}
+
+(** Summarize the right-hand-side of a type declaration,
+    for separability-checking purposes. See {!structure} below. *)
+type type_structure =
+  | Synonym of type_expr
+  | Abstract
+  | Open
+  | Algebraic
+  | Unboxed of argument_to_unbox
+
+let structure : type_definition -> type_structure = fun def ->
+  match def.type_kind with
+  | Type_open -> Open
+  | Type_abstract ->
+      begin match def.type_manifest with
+      | None -> Abstract
+      | Some type_expr -> Synonym type_expr
+      end
+
+  | ( Type_record ([{ld_type = ty; _}], Record_unboxed _)
+    | Type_variant ([{cd_args = Cstr_tuple [ty]; _}], Variant_unboxed)
+    | Type_variant ([{cd_args = Cstr_record [{ld_type = ty; _}]; _}],
+                    Variant_unboxed)) ->
+     let params =
+       match def.type_kind with
+       | Type_variant ([{cd_res = Some ret_type}], _) ->
+          begin match Ctype.repr ret_type with
+          | {desc=Tconstr (_, tyl, _)} ->
+             List.map Ctype.repr tyl
+          | _ -> assert false
+          end
+       | _ -> def.type_params
+     in
+     Unboxed { argument_type = ty; result_type_parameter_instances = params }
+
+  | Type_record _ | Type_variant _ -> Algebraic
+
+type error =
+  | Non_separable_evar of string option
+
+exception Error of Location.t * error
+
+(* see the .mli file for explanations on the modes *)
+module Sep = Types.Separability
+type mode = Sep.t = Ind | Sep | Deepsep
+
+let rank = Sep.rank
+let max_mode = Sep.max
+
+(** If the type context [e(_)] imposes the mode [m] on its hole [_],
+    and the type context [e'(_)] imposes the mode [m'] on its hole [_],
+    then the mode on [_] imposed by the context composition [e(e'(_))]
+    is [compose m m'].
+
+    This operation differs from [max_mode]: [max_mode Ind Sep] is [Sep],
+    but [compose Ind Sep] is [Ind]. *)
+let compose
+  : mode -> mode -> mode
+  = fun m1 m2 ->
+  match m1 with
+  | Deepsep -> Deepsep
+  | Sep -> m2
+  | Ind -> Ind
+
+type type_var = {
+  text: string option; (** the user name of the type variable, None for '_' *)
+  id: int; (** the identifier of the type node (type_expr.id) of the variable *)
+}
+
+module TVarMap = Map.Make(struct
+    type t = type_var
+    let compare v1 v2 = compare v1.id v2.id
+  end)
+type context = mode TVarMap.t
+let (++) = TVarMap.union (fun _ m1 m2 -> Some(max_mode m1 m2))
+let empty = TVarMap.empty
+
+
+(** [immediate_subtypes ty] returns the list of all the
+   immediate sub-type-expressions of [ty]. They represent the biggest
+   sub-components that may be extracted using a constraint. For
+   example, the immediate sub-type-expressions of [int * (bool * 'a)]
+   are [int] and [bool * 'a].
+
+   Smaller components are extracted recursively in [check_type]. *)
+let rec immediate_subtypes : type_expr -> type_expr list = fun ty ->
+  (* Note: Btype.fold_type_expr is not suitable here:
+     - it does not do the right thing on Tpoly, iterating on type
+       parameters as well as the subtype
+     - it performs a shallow traversal of object types,
+       while our implementation collects all method types *)
+  match (Ctype.repr ty).desc with
+  (* these are the important cases,
+     on which immediate_subtypes is called from [check_type] *)
+  | Tarrow(_,ty1,ty2,_) ->
+      [ty1; ty2]
+  | Ttuple(tys) -> tys
+  | Tpackage(_, fl) -> (snd (List.split fl))
+  | Tobject(row,class_ty) ->
+      let class_subtys =
+        match !class_ty with
+        | None        -> []
+        | Some(_,tys) -> tys
+      in
+      immediate_subtypes_object_row class_subtys row
+  | Tvariant(row) ->
+      immediate_subtypes_variant_row [] row
+
+  (* the cases below are not called from [check_type],
+     they are here for completeness *)
+  | Tnil | Tfield _ ->
+      (* these should only occur under Tobject and not at the toplevel,
+         but "better safe than sorry" *)
+      immediate_subtypes_object_row [] ty
+  | Tlink _ | Tsubst _ -> assert false (* impossible due to Ctype.repr *)
+  | Tvar _ | Tunivar _ -> []
+  | Tpoly (pty, _) -> [pty]
+  | Tconstr (_path, tys, _) -> tys
+
+and immediate_subtypes_object_row acc ty = match (Ctype.repr ty).desc with
+  | Tnil -> acc
+  | Tfield (_label, _kind, ty, rest) ->
+      let acc = ty :: acc in
+      immediate_subtypes_object_row acc rest
+  | _ -> ty :: acc
+
+and immediate_subtypes_variant_row acc desc =
+  let add_subtypes acc =
+    let add_subtype acc (_l, rf) =
+      immediate_subtypes_variant_row_field acc rf in
+    List.fold_left add_subtype acc desc.row_fields in
+  let add_row acc =
+    let row = Ctype.repr desc.row_more in
+    match row.desc with
+    | Tvariant more -> immediate_subtypes_variant_row acc more
+    | _ -> row :: acc
+  in
+  add_row (add_subtypes acc)
+
+and immediate_subtypes_variant_row_field acc = function
+  | Rpresent(None)
+  | Rabsent            -> acc
+  | Rpresent(Some(ty)) -> ty :: acc
+  | Reither(_,field_types,_,r) ->
+      let acc = List.rev_append field_types acc in
+      begin match !r with
+      | None -> acc
+      | Some rf -> immediate_subtypes_variant_row_field acc rf
+      end
+
+let free_variables ty =
+  Ctype.free_variables (Ctype.repr ty)
+  |> List.map (fun {desc; id; _} ->
+      match desc with
+      | Tvar text -> {text; id}
+      | _ ->
+          (* Ctype.free_variables only returns Tvar nodes *)
+          assert false)
+
+(** Coinductive hypotheses to handle equi-recursive types
+
+    OCaml allows infinite/cyclic types, such as
+      (int * 'a) as 'a
+    whose infinite unfolding is (int * (int * (int * (int * ...)))).
+
+    Remark: this specific type is only accepted if the -rectypes option
+    is passed, but such "equi-recursive types" are accepted by
+    default if the cycle goes through an object type or polymorphic
+    variant type:
+      [ `int | `other of 'a ] as 'a
+      < head : int; rest : 'a > as 'a
+
+    We have to take those infinite types in account in our
+    separability-checking program: a naive implementation would loop
+    infinitely when trying to prove that one of them is Deepsep.
+
+    After type-checking, the cycle-introducing form (... as 'a) does
+    not appear explicitly in the syntax of types: types are graphs/trees
+    with cycles in them, and we have to use the type_expr.id field,
+    an identifier for each node in the graph/tree, to detect cycles.
+
+    We avoid looping by remembering the set of separability queries
+    that we have already asked ourselves (in the current
+    search branch). For example, if we are asked to check
+
+      (int * 'a) : Deepsep
+
+    our algorithm will check both (int : Deepsep) and ('a : Deepsep),
+    but it will remember in these sub-checks that it is in the process
+    of checking (int * 'a) : Deepsep, adding it to a list of "active
+    goals", or "coinductive hypotheses".
+
+    Each new sub-query will start by checking whether the query
+    already appears as a coinductive hypothesis; in our example, this
+    can happen if 'a and (int * 'a) are in fact the same node in the
+    cyclic tree. In that case, we return immediately (instead of looping):
+    we reason that, assuming that 'a is indeed Deepsep, then it is
+    the case that (int * 'a) is also Deepsep.
+
+    This kind of cyclic reasoning can be dangerous: it would be wrong
+    to argue that an arbitrary 'a type is Deepsep by saying:
+    "assuming that 'a is Deepsep, then it is the case that 'a is
+    also Deepsep". In the first case, we made an assumption on 'a,
+    and used it on a type (int * 'a) which has 'a as a strict sub-component;
+    in the second, we use it on the same type 'a directly, which is invalid.
+
+    Now consider a type of the form (('a t) as 'a): while 'a is a sub-component
+    of ('a t), it may still be wrong to reason coinductively about it,
+    as ('a t) may be defined as (type 'a t = 'a).
+
+    When moving from (int * 'a) to a subcomponent (int) or ('a), we
+    say that the coinductive hypothesis on (int * 'a : m) is "safe":
+    it can be used immediately to prove the subcomponents, because we
+    made progress moving to a strict subcomponent (we are guarded
+    under a computational type constructor). On the other hand, when
+    moving from ('a t) to ('a), we say that the coinductive hypothesis
+    ('a t : m) is "unsafe" for the subgoal, as we don't know whether
+    we have made strict progress. In the general case, we keep track
+    of a set of safe and unsafe hypotheses made in the past, and we
+    use them to terminate checking if we encounter them again,
+    ensuring termination.
+
+    If we encounter a (ty : m) goal that is exactly a safe hypothesis,
+    we terminate with a success. In fact, we can use mode subtyping here:
+    if (ty : m') appears as a hypothesis with (m' >= m), then we would
+    succeed for (ty : m'), so (ty : m) should succeed as well.
+
+    On the other hand, if we encounter a (ty : m) goal that is an
+    *unsafe* hypothesis, we terminate the check with a failure. In this case,
+    we cannot work modulo mode subtyping: if (ty : m') appears with
+    (m' >= m), then the check (ty : m') would have failed, but it is still
+    possible that the weaker current query (ty : m) would succeed.
+
+    In usual coinductive-reasoning systems, unsafe hypotheses are turned
+    into safe hypotheses each time strict progress is made (for each
+    guarded sub-goal). Consider ((int * 'a) t as 'a : deepsep) for example:
+    the idea is that the ((int * 'a) t : deepsep) hypothesis would be
+    unsafe when checking ((int * 'a) : deepsep), but that the progress
+    step from (int * 'a : deepsep) to ('a : deepsep) would turn all
+    past unsafe hypotheses into safe hypotheses. There is a problem
+    with this, though, due to constraints: what if (_ t) is defined as
+
+      type 'b t = 'a constraint 'b = (int * 'a)
+
+    ?
+
+    In that case, then 'a is precisely the one-step unfolding
+    of the ((int * 'a) t) definition, and it would be an invalid,
+    cyclic reasoning to prove ('a : deepsep) from the now-safe
+    hypothesis ((int * 'a) t : deepsep).
+
+    Surprisingly-fortunately, we have exactly the information we need
+    to know whether (_ t) may or may not pull a constraint trick of
+    this nature: we can look at its mode signature, where constraints
+    are marked by a Deepsep mode. If we see Deepsep, we know that a
+    constraint exists, but we don't know what the constraint is:
+    we cannot tell at which point, when decomposing the parameter type,
+    a sub-component can be considered safe again. To model this,
+    we add a third category of co-inductive hypotheses: to "safe" and
+    "unsafe" we add the category of "poison" hypotheses, which remain
+    poisonous during the remaining of the type decomposition,
+    even in presence of safe, computational types constructors:
+
+    - when going under a computational constructor,
+      "unsafe" hypotheses become "safe"
+    - when going under a constraining type (more precisely, under
+      a type parameter that is marked Deepsep in the mode signature),
+      "unsafe" hypotheses become "poison"
+
+    The mode signature tells us even a bit more: if a parameter
+    is marked "Ind", we know that the type constructor cannot unfold
+    to this parameter (otherwise it would be Sep), so going under
+    this parameter can be considered a safe/guarded move: if
+    we have to check (foo t : m) with ((_ : Ind) t) in the signature,
+    we can recursively check (foo : Ind) with (foo t : m) marked
+    as "safe", rather than "unsafe".
+*)
+module TypeMap = Btype.TypeMap
+module ModeSet = Set.Make(Types.Separability)
+
+type coinductive_hyps = {
+  safe: ModeSet.t TypeMap.t;
+  unsafe: ModeSet.t TypeMap.t;
+  poison: ModeSet.t TypeMap.t;
+}
+
+module Hyps : sig
+  type t = coinductive_hyps
+  val empty : t
+  val add : type_expr -> mode -> t -> t
+  val guard : t -> t
+  val poison : t -> t
+  val safe : type_expr -> mode -> t -> bool
+  val unsafe : type_expr -> mode -> t -> bool
+end = struct
+  type t = coinductive_hyps
+
+  let empty = {
+    safe = TypeMap.empty;
+    unsafe = TypeMap.empty;
+    poison = TypeMap.empty;
+  }
+
+  let of_opt = function
+    | Some ms -> ms
+    | None -> ModeSet.empty
+
+  let merge map1 map2 =
+    TypeMap.merge (fun _k ms1 ms2 ->
+        Some (ModeSet.union (of_opt ms1) (of_opt ms2))
+      ) map1 map2
+
+  let guard {safe; unsafe; poison;} = {
+    safe = merge safe unsafe;
+    unsafe = TypeMap.empty;
+    poison;
+  }
+
+  let poison {safe; unsafe; poison;} = {
+    safe;
+    unsafe = TypeMap.empty;
+    poison = merge poison unsafe;
+  }
+
+  let add ty m hyps =
+    let m_map = TypeMap.singleton ty (ModeSet.singleton m) in
+    { hyps with unsafe = merge m_map hyps.unsafe; }
+
+  let find ty map = try TypeMap.find ty map with Not_found -> ModeSet.empty
+
+  let safe ty m hyps =
+    match ModeSet.max_elt_opt (find ty hyps.safe) with
+    | None -> false
+    | Some best_safe -> rank best_safe >= rank m
+
+  let unsafe ty m {safe = _; unsafe; poison} =
+    let in_map s = ModeSet.mem m (find ty s) in
+    List.exists in_map [unsafe; poison]
+end
+
+(** For a type expression [ty] (without constraints and existentials),
+    any mode checking [ty : m] is satisfied in the "worse case" context
+    that maps all free variables of [ty] to the most demanding mode,
+    Deepsep. *)
+let worst_case ty =
+  let add ctx tvar = TVarMap.add tvar Deepsep ctx in
+  List.fold_left add TVarMap.empty (free_variables ty)
+
+
+(** [check_type env sigma ty m] returns the most permissive context [gamma]
+    such that [ty] is separable at mode [m] in [gamma], under
+    the signature [sigma]. *)
+let check_type
+  : Env.t -> type_expr -> mode -> context
+  = fun env ty m ->
+  let rec check_type hyps ty m =
+    let ty = Ctype.repr ty in
+    if Hyps.safe ty m hyps then empty
+    else if Hyps.unsafe ty m hyps then worst_case ty
+    else
+    let hyps = Hyps.add ty m hyps in
+    match (ty.desc, m) with
+    (* Impossible case due to the call to [Ctype.repr]. *)
+    | (Tlink _            , _      ) -> assert false
+    (* Impossible case (according to comment in [typing/types.mli]. *)
+    | (Tsubst(_)          , _      ) -> assert false
+    (* "Indifferent" case, the empty context is sufficient. *)
+    | (_                  , Ind    ) -> empty
+    (* Variable case, add constraint. *)
+    | (Tvar(alpha)        , m      ) ->
+        TVarMap.singleton {text = alpha; id = ty.Types.id} m
+    (* "Separable" case for constructors with known memory representation. *)
+    | (Tarrow _           , Sep    )
+    | (Ttuple _           , Sep    )
+    | (Tvariant(_)        , Sep    )
+    | (Tobject(_,_)       , Sep    )
+    | ((Tnil | Tfield _)  , Sep    )
+    | (Tpackage(_,_)      , Sep    ) -> empty
+    (* "Deeply separable" case for these same constructors. *)
+    | (Tarrow _           , Deepsep)
+    | (Ttuple _           , Deepsep)
+    | (Tvariant(_)        , Deepsep)
+    | (Tobject(_,_)       , Deepsep)
+    | ((Tnil | Tfield _)  , Deepsep)
+    | (Tpackage(_,_)      , Deepsep) ->
+        let tys = immediate_subtypes ty in
+        let on_subtype context ty =
+          context ++ check_type (Hyps.guard hyps) ty Deepsep in
+        List.fold_left on_subtype empty tys
+    (* Polymorphic type, and corresponding polymorphic variable.
+
+       In theory, [Tpoly] (forall alpha. tau) would add a new variable
+       (alpha) in scope, check its body (tau) recursively, and then
+       remove the new variable from the resulting context. Because the
+       rule accepts any mode for this variable, the removal never
+       fails.
+
+       In practice the implementation is simplified by ignoring the
+       new variable, and always returning the [empty] context
+       (instead of (alpha : m) in the [Tunivar] case: the constraint
+       on the variable is removed/ignored at the variable occurrence
+       site, rather than at the variable-introduction site. *)
+    (* Note: that we are semantically incomplete in the Deepsep case
+       (following the syntactic typing rules): the semantics only
+       requires that *closed* sub-type-expressions be (deeply)
+       separable; sub-type-expressions containing the quantified
+       variable cannot be extracted by constraints (this would be
+       a scope violation), so they could be ignored if they occur
+       under a separating type constructor. *)
+    | (Tpoly(pty,_)       , m      ) ->
+        check_type hyps pty m
+    | (Tunivar(_)         , _      ) -> empty
+    (* Type constructor case. *)
+    | (Tconstr(path,tys,_), m      ) ->
+        let msig = (Env.find_type path env).type_separability in
+        let on_param context (ty, m_param) =
+          let hyps = match m_param with
+            | Ind -> Hyps.guard hyps
+            | Sep -> hyps
+            | Deepsep -> Hyps.poison hyps in
+          context ++ check_type hyps ty (compose m m_param) in
+        List.fold_left on_param empty (List.combine tys msig)
+  in
+  check_type Hyps.empty ty m
+
+let best_msig decl = List.map (fun _ -> Ind) decl.type_params
+let worst_msig decl = List.map (fun _ -> Deepsep) decl.type_params
+
+(** [msig_of_external_type decl] infers the mode signature of an
+    abstract/external type. We must assume the worst, namely that this
+    type may be defined as an unboxed algebraic datatype imposing deep
+    separability of its parameters.
+
+    One exception is when the type is marked "immediate", which
+    guarantees that its representation is only integers.  Immediate
+    types are always separable, so [Ind] suffices for their
+    parameters.
+
+    Note: this differs from {!Types.Separability.default_signature},
+    which does not have access to the declaration and its immediacy. *)
+let msig_of_external_type decl =
+  match decl.type_immediate with
+  | Always | Always_on_64bits -> best_msig decl
+  | Unknown -> worst_msig decl
+
+(** [msig_of_context ~decl_loc constructor context] returns the
+   separability signature of a single-constructor type whose
+   definition is valid in the mode context [context].
+
+   Note: A GADT constructor introduces existential type variables, and
+   may also introduce some equalities between its return type
+   parameters and type expressions containing universal and
+   existential variables. In other words, it introduces new type
+   variables in scope, and restricts existing variables by adding
+   equality constraints.
+
+   [msig_of_context] performs the reverse transformation: the context
+   [ctx] computed from the argument of the constructor mentions
+   existential variables, and the function returns a context over the
+   (universal) type parameters only. (Type constraints do not
+   introduce existential variables, but they do introduce equalities;
+   they are handled as GADTs equalities by this function.)
+
+   The transformation is separability-preserving in the following
+   sense: for any valid instance of the result mode signature
+   (replacing the universal type parameters with ground types
+   respecting the variable's separability mode), any possible
+   extension of this context instance with ground instances for the
+   existential variables of [parameter] that respects the equation
+   constraints will validate the separability requirements of the
+   modes in the input context [ctx].
+
+   Sometimes no such universal context exists, as an existential type
+   cannot be safely introduced, then this function raises an [Error]
+   exception with a [Non_separable_evar] payload.  *)
+let msig_of_context : decl_loc:Location.t -> parameters:type_expr list
+    -> context -> Sep.signature =
+  fun ~decl_loc ~parameters context ->
+    let handle_equation (acc, context) param_instance =
+      (* In the theory, GADT equations are of the form
+           ('a = <ty>)
+         for each type parameter 'a of the type constructor. For each
+         such equation, we should "strengthen" the current context in
+         the following way:
+         - if <ty> is another variable 'b,
+           the mode of 'a is set to the mode of 'b,
+           and 'b is set to Ind
+         - if <ty> is a type expression whose variables are all Ind,
+           set 'a to Ind and discard the equation
+         - otherwise (one of the variable of 'b is not Ind),
+           set 'a to Deepsep and set all variables of <ty> to Ind
+
+         In practice, type parameters are determined by their position
+         in a list, they do not necessarily have a corresponding type variable.
+         Instead of "setting 'a" in the context as in the description above,
+         we build a list of modes by repeated consing into
+         an accumulator variable [acc], setting existential variables
+         to Ind as we go. *)
+      let param_instance = Ctype.repr param_instance in
+      let get context var =
+        try TVarMap.find var context with Not_found -> Ind in
+      let set_ind context var =
+        TVarMap.add var Ind context in
+      let is_ind context var = match get context var with
+        | Ind -> true
+        | Sep | Deepsep -> false in
+      match param_instance.desc with
+      | Tvar text ->
+          let var = {text; id = param_instance.Types.id} in
+          (get context var) :: acc, (set_ind context var)
+      | _ ->
+          let instance_exis = free_variables param_instance in
+          if List.for_all (is_ind context) instance_exis then
+            Ind :: acc, context
+          else
+            Deepsep :: acc, List.fold_left set_ind context instance_exis
+    in
+    let mode_signature, context =
+      let (mode_signature_rev, ctx) =
+        List.fold_left handle_equation ([], context) parameters in
+      (* Note: our inference system is not principal, because the
+         inference result depends on the order in which those
+         equations are processed. (To our knowledge this is the only
+         source of non-principality.) If two parameters ('a, 'b) are
+         forced to be equal to each other, and also separable, then
+         either modes (Sep, Ind) and (Ind, Sep) are correct, allow
+         more declarations than (Sep, Sep), but (Ind, Ind) would be
+         unsound.
+
+         Such a non-principal example is the following:
+
+           type ('a, 'b) almost_eq =
+             | Almost_refl : 'c -> ('c, 'c) almost_eq
+
+         (This example looks strange: GADT equations are typically
+         either on only one parameter, or on two parameters that are
+         not used to classify constructor arguments. Indeed, we have
+         not found non-principal declarations in real-world code.)
+
+         In a non-principal system, it is important the our choice of
+         non-unique solution be at least predictable. We find it more
+         natural, when either ('a : Sep, 'b : Ind) and ('a : Ind,
+         'b : Sep) are correct because 'a = 'b, to choose to make the
+         first/leftmost parameter more constrained. We read this as
+         saying that 'a must be Sep, and 'b = 'a so 'b can be
+         Ind. (We define the second parameter as equal of the first,
+         already-seen parameter; instead of saying that the first
+         parameter is equal to the not-yet-seen second one.)
+
+         This is achieved by processing the equations from left to
+         right with List.fold_left, instead of using
+         List.fold_right. The code is slightly more awkward as it
+         needs a List.rev on the accumulated modes, but it gives
+         a more predictable/natural (non-principal) behavior.
+  *)
+      (List.rev mode_signature_rev, ctx) in
+    (* After all variables determined by the parameters have been set to Ind
+       by [handle_equation], all variables remaining in the context are
+       purely existential and should not require a stronger mode than Ind. *)
+    let check_existential evar mode =
+      if rank mode > rank Ind then
+        raise (Error (decl_loc, Non_separable_evar evar.text))
+    in
+    TVarMap.iter check_existential context;
+    mode_signature
+
+(** [check_def env def] returns the signature required
+    for the type definition [def] in the typing environment [env].
+
+    The exception [Error] is raised if we discover that
+    no such signature exists -- the definition will always be invalid.
+    This only happens when the definition is marked to be unboxed. *)
+
+let check_def
+  : Env.t -> type_definition -> Sep.signature
+  = fun env def ->
+  match structure def with
+  | Abstract ->
+      msig_of_external_type def
+  | Synonym type_expr ->
+      check_type env type_expr Sep
+      |> msig_of_context ~decl_loc:def.type_loc ~parameters:def.type_params
+  | Open | Algebraic ->
+      best_msig def
+  | Unboxed constructor ->
+      check_type env constructor.argument_type Sep
+      |> msig_of_context ~decl_loc:def.type_loc
+           ~parameters:constructor.result_type_parameter_instances
+
+let compute_decl env decl =
+  if Config.flat_float_array then check_def env decl
+  else
+    (* Hack: in -no-flat-float-array mode, instead of always returning
+       [best_msig], we first compute the separability signature --
+       falling back to [best_msig] if it fails.
+
+       This discipline is conservative: it never
+       rejects -no-flat-float-array programs. At the same time it
+       guarantees that, for any program that is also accepted
+       in -flat-float-array mode, the same separability will be
+       inferred in the two modes. In particular, the same .cmi files
+       and digests will be produced.
+
+       Before we introduced this hack, the production of different
+       .cmi files would break the build system of the compiler itself,
+       when trying to build a -no-flat-float-array system from
+       a bootstrap compiler itself using -flat-float-array. See #9291.
+       *)
+    try check_def env decl with
+    | Error _ ->
+       (* It could be nice to emit a warning here, so that users know
+          that their definition would be rejected in -flat-float-array mode *)
+       best_msig decl
+
+(** Separability as a generic property *)
+type prop = Types.Separability.signature
+
+let property : (prop, unit) Typedecl_properties.property =
+  let open Typedecl_properties in
+  let eq ts1 ts2 =
+    List.length ts1 = List.length ts2
+    && List.for_all2 Sep.eq ts1 ts2 in
+  let merge ~prop:_ ~new_prop =
+    (* the update function is monotonous: ~new_prop is always
+       more informative than ~prop, which can be ignored *)
+    new_prop in
+  let default decl = best_msig decl in
+  let compute env decl () = compute_decl env decl in
+  let update_decl decl type_separability = { decl with type_separability } in
+  let check _env _id _decl () = () in (* FIXME run final check? *)
+  { eq; merge; default; compute; update_decl; check; }
+
+(* Definition using the fixpoint infrastructure. *)
+let update_decls env decls =
+  Typedecl_properties.compute_property_noreq property env decls
diff --git a/upstream/ocaml_413/typing/typedecl_separability.mli b/upstream/ocaml_413/typing/typedecl_separability.mli
new file mode 100644
index 0000000..079e640
--- /dev/null
+++ b/upstream/ocaml_413/typing/typedecl_separability.mli
@@ -0,0 +1,132 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** The OCaml runtime assumes for type-directed optimizations that all types
+    are "separable". A type is "separable" if either all its inhabitants
+    (the values of this type) are floating-point numbers, or none of them are.
+
+    (Note: This assumption is required for the dynamic float array optimization;
+    it is only made if Config.flat_float_array is set,
+    otherwise the code in this module becomes trivial
+    -- see {!compute_decl}.)
+
+    This soundness requirement could be broken by type declarations mixing
+    existentials and the "[@@unboxed]" annotation. Consider the declaration
+
+    {[
+       type any = Any : 'a -> any [@@unboxed]
+    ]}
+
+   which corresponds to the existential type "exists a. a". If this type is
+   allowed to be unboxed, then it is inhabited by both [float] values
+   and non-[float] values. On the contrary, if unboxing is disallowed, the
+   inhabitants are all blocks with the [Any] constructors pointing to its
+   parameter: they may point to a float, but they are not floats.
+
+   The present module contains a static analysis ensuring that declarations
+   annotated with "[@@unboxed]" can be safely unboxed. The idea is to check
+   the "separability" (in the above sense) of the argument type that would
+   be unboxed, and reject the unboxed declaration if it would create a
+   non-separable type.
+
+   Checking mutually-recursive type declarations is a bit subtle.
+   Consider, for example, the following declarations.
+
+   {[
+      type foo = Foo : 'a t -> foo   [@@unboxed]
+      and 'a t = ...
+   ]}
+
+   Deciding whether the type [foo] should be accepted requires inspecting
+   the declaration of ['a t], which may itself refer to [foo] in turn.
+   In general, the analysis performs a fixpoint computation. It is somewhat
+   similar to what is done for inferring the variance of type parameters.
+
+   Our analysis is defined using inference rules for our judgment
+   [Def; Gamma |- t : m], in which a type expression [t] is checked
+   against a "mode" [m]. This "mode" describes the separability
+   requirement on the type expression (see below for
+   more details). The mode [Gamma] maps type variables to modes and
+   [Def] records the "mode signature" of the mutually-recursive type
+   declarations that are being checked.
+
+   The "mode signature" of a type with parameters [('a, 'b) t] is of the
+   form [('a : m1, 'b : m2) t], where [m1] and [m2] are modes. Its meaning
+   is the following: a concrete instance [(foo, bar) t] of the type is
+   separable if [foo] has mode [m1] and [bar] has mode [m2]. *)
+
+type error =
+  | Non_separable_evar of string option
+exception Error of Location.t * error
+(** Exception raised when a type declaration is not separable, or when its
+    separability cannot be established. *)
+
+type mode = Types.Separability.t = Ind | Sep | Deepsep
+(** The mode [Sep] ("separable") characterizes types that are indeed separable:
+    either they only contain floating-point values, or none of the values
+    at this type are floating-point values.
+    On a type parameter, it indicates that this parameter must be
+    separable for the whole type definition to be separable. For
+    example, the mode signature for the type declaration [type 'a
+    t = 'a] is [('a : Sep) t]. For the right-hand side to be
+    separable, the parameter ['a] must be separable.
+
+    The mode [Ind] ("indifferent") characterizes any type -- separable
+    or not.
+    On a type parameter, it indicates that this parameter needs not be
+    separable for the whole type definition to be separable. For
+    example, [type 'a t = 'a * bool] does not require its parameter
+    ['a] to be separable as ['a * bool] can never contain [float]
+    values. Its mode signature is thus [('a : Ind) t].
+
+    Finally, the mode [Deepsep] ("deeply separable") characterizes
+    types that are separable, and whose type sub-expressions are also
+    separable. This advanced feature is only used in the presence of
+    constraints.
+    For example, [type 'a t = 'b   constraint 'a = 'b * bool]
+    may not be separable even if ['a] is (its separately depends on 'b,
+    a fragment of 'a), so its mode signature is [('a : Deepsep) t].
+
+    The different modes are ordered as [Ind < Sep < Deepsep] (from the least
+    demanding to the most demanding). *)
+
+val compute_decl : Env.t -> Types.type_declaration -> mode list
+(** [compute_decl env def] returns the signature required
+    for the type definition [def] in the typing environment [env]
+    -- including signatures for the current recursive block.
+
+    The {!Error} exception is raised if no such signature exists
+    -- the definition will always be invalid. This only happens
+    when the definition is marked to be unboxed.
+
+    Variant (or record) declarations that are not marked with the
+    "[@@unboxed]" annotation, including those that contain several variants
+    (or labels), are always separable. In particular, their mode signatures
+    do not require anything of their type parameters, which are marked [Ind].
+
+    Finally, if {!Config.flat_float_array} is not set, then separability
+    is not required anymore; we just use [Ind] as the mode of each parameter
+    without any check.
+*)
+
+(** Property interface (see {!Typedecl_properties}). These functions
+    rely on {!compute_decl} and raise the {!Error} exception on error. *)
+type prop = Types.Separability.signature
+val property : (prop, unit) Typedecl_properties.property
+val update_decls :
+  Env.t ->
+  (Ident.t * Typedecl_properties.decl) list ->
+  (Ident.t * Typedecl_properties.decl) list
diff --git a/upstream/ocaml_413/typing/typedecl_unboxed.ml b/upstream/ocaml_413/typing/typedecl_unboxed.ml
new file mode 100644
index 0000000..6e23ab9
--- /dev/null
+++ b/upstream/ocaml_413/typing/typedecl_unboxed.ml
@@ -0,0 +1,53 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Types
+
+type t =
+  | Unavailable
+  | This of type_expr
+  | Only_on_64_bits of type_expr
+
+(* We use the Ctype.expand_head_opt version of expand_head to get access
+   to the manifest type of private abbreviations. *)
+let rec get_unboxed_type_representation env ty fuel =
+  if fuel < 0 then Unavailable else
+  let ty = Ctype.repr (Ctype.expand_head_opt env ty) in
+  match ty.desc with
+  | Tconstr (p, args, _) ->
+    begin match Env.find_type p env with
+    | exception Not_found -> This ty
+    | {type_immediate = Always; _} ->
+        This Predef.type_int
+    | {type_immediate = Always_on_64bits; _} ->
+        Only_on_64_bits Predef.type_int
+    | {type_params; type_kind =
+         Type_record ([{ld_type = ty2; _}], Record_unboxed _)
+       | Type_variant ([{cd_args = Cstr_tuple [ty2]; _}], Variant_unboxed)
+       | Type_variant ([{cd_args = Cstr_record [{ld_type = ty2; _}]; _}],
+                       Variant_unboxed)}
+      ->
+        let ty2 = match ty2.desc with Tpoly (t, _) -> t | _ -> ty2 in
+        get_unboxed_type_representation env
+          (Ctype.apply env type_params ty2 args) (fuel - 1)
+    | _ -> This ty
+    end
+  | _ -> This ty
+
+let get_unboxed_type_representation env ty =
+  (* Do not give too much fuel: PR#7424 *)
+  get_unboxed_type_representation env ty 100
+;;
diff --git a/upstream/ocaml_413/typing/typedecl_unboxed.mli b/upstream/ocaml_413/typing/typedecl_unboxed.mli
new file mode 100644
index 0000000..9afd38e
--- /dev/null
+++ b/upstream/ocaml_413/typing/typedecl_unboxed.mli
@@ -0,0 +1,25 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Types
+
+type t =
+  | Unavailable
+  | This of type_expr
+  | Only_on_64_bits of type_expr
+
+(* for typeopt.ml *)
+val get_unboxed_type_representation: Env.t -> type_expr -> t
diff --git a/upstream/ocaml_413/typing/typedecl_variance.ml b/upstream/ocaml_413/typing/typedecl_variance.ml
new file mode 100644
index 0000000..da5dce2
--- /dev/null
+++ b/upstream/ocaml_413/typing/typedecl_variance.ml
@@ -0,0 +1,422 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Types
+
+module TypeSet = Btype.TypeSet
+module TypeMap = Btype.TypeMap
+
+type surface_variance = bool * bool * bool
+
+type variance_error =
+| Variance_not_satisfied of int
+| No_variable
+| Variance_not_reflected
+| Variance_not_deducible
+
+type error =
+| Bad_variance of variance_error * surface_variance * surface_variance
+| Varying_anonymous
+
+
+exception Error of Location.t * error
+
+(* Compute variance *)
+
+let get_variance ty visited =
+  try TypeMap.find ty !visited with Not_found -> Variance.null
+
+let compute_variance env visited vari ty =
+  let rec compute_variance_rec vari ty =
+    (* Format.eprintf "%a: %x@." Printtyp.type_expr ty (Obj.magic vari); *)
+    let ty = Ctype.repr ty in
+    let vari' = get_variance ty visited in
+    if Variance.subset vari vari' then () else
+    let vari = Variance.union vari vari' in
+    visited := TypeMap.add ty vari !visited;
+    let compute_same = compute_variance_rec vari in
+    match ty.desc with
+      Tarrow (_, ty1, ty2, _) ->
+        let open Variance in
+        let v = conjugate vari in
+        let v1 =
+          if mem May_pos v || mem May_neg v
+          then set May_weak true v else v
+        in
+        compute_variance_rec v1 ty1;
+        compute_same ty2
+    | Ttuple tl ->
+        List.iter compute_same tl
+    | Tconstr (path, tl, _) ->
+        let open Variance in
+        if tl = [] then () else begin
+          try
+            let decl = Env.find_type path env in
+            let cvari f = mem f vari in
+            List.iter2
+              (fun ty v ->
+                let cv f = mem f v in
+                let strict =
+                  cvari Inv && cv Inj || (cvari Pos || cvari Neg) && cv Inv
+                in
+                if strict then compute_variance_rec full ty else
+                let p1 = inter v vari
+                and n1 = inter v (conjugate vari) in
+                let v1 =
+                  union (inter covariant (union p1 (conjugate p1)))
+                    (inter (conjugate covariant) (union n1 (conjugate n1)))
+                and weak =
+                  cvari May_weak && (cv May_pos || cv May_neg) ||
+                  (cvari May_pos || cvari May_neg) && cv May_weak
+                in
+                let v2 = set May_weak weak v1 in
+                compute_variance_rec v2 ty)
+              tl decl.type_variance
+          with Not_found ->
+            List.iter (compute_variance_rec unknown) tl
+        end
+    | Tobject (ty, _) ->
+        compute_same ty
+    | Tfield (_, _, ty1, ty2) ->
+        compute_same ty1;
+        compute_same ty2
+    | Tsubst _ ->
+        assert false
+    | Tvariant row ->
+        let row = Btype.row_repr row in
+        List.iter
+          (fun (_,f) ->
+            match Btype.row_field_repr f with
+              Rpresent (Some ty) ->
+                compute_same ty
+            | Reither (_, tyl, _, _) ->
+                let open Variance in
+                let upper =
+                  List.fold_left (fun s f -> set f true s)
+                    null [May_pos; May_neg; May_weak]
+                in
+                let v = inter vari upper in
+                (* cf PR#7269:
+                   if List.length tyl > 1 then upper else inter vari upper *)
+                List.iter (compute_variance_rec v) tyl
+            | _ -> ())
+          row.row_fields;
+        compute_same row.row_more
+    | Tpoly (ty, _) ->
+        compute_same ty
+    | Tvar _ | Tnil | Tlink _ | Tunivar _ -> ()
+    | Tpackage (_, fl) ->
+        let v =
+          Variance.(if mem Pos vari || mem Neg vari then full else unknown)
+        in
+        List.iter (fun (_, ty) -> compute_variance_rec v ty) fl
+  in
+  compute_variance_rec vari ty
+
+let make p n i =
+  let open Variance in
+  set May_pos p (set May_neg n (set May_weak n (set Inj i null)))
+
+let injective = Variance.(set Inj true null)
+
+let compute_variance_type env ~check (required, loc) decl tyl =
+  (* Requirements *)
+  let check_injectivity = decl.type_kind = Type_abstract in
+  let required =
+    List.map
+      (fun (c,n,i) ->
+        let i = if check_injectivity then i else false in
+        if c || n then (c,n,i) else (true,true,i))
+      required
+  in
+  (* Prepare *)
+  let params = List.map Btype.repr decl.type_params in
+  let tvl = ref TypeMap.empty in
+  (* Compute occurrences in the body *)
+  let open Variance in
+  List.iter
+    (fun (cn,ty) ->
+      compute_variance env tvl (if cn then full else covariant) ty)
+    tyl;
+  (* Infer injectivity of constrained parameters *)
+  if check_injectivity then
+    List.iter
+      (fun ty ->
+        if Btype.is_Tvar ty || mem Inj (get_variance ty tvl) then () else
+        let visited = ref TypeSet.empty in
+        let rec check ty =
+          let ty = Ctype.repr ty in
+          if TypeSet.mem ty !visited then () else begin
+            visited := TypeSet.add ty !visited;
+            if mem Inj (get_variance ty tvl) then () else
+            match ty.desc with
+            | Tvar _ -> raise Exit
+            | Tconstr _ ->
+                let old = !visited in
+                begin try
+                  Btype.iter_type_expr check ty
+                with Exit ->
+                  visited := old;
+                  let ty' = Ctype.expand_head_opt env ty in
+                  if ty == ty' then raise Exit else check ty'
+                end
+            | _ -> Btype.iter_type_expr check ty
+          end
+        in
+        try check ty; compute_variance env tvl injective ty
+        with Exit -> ())
+      params;
+  if check then begin
+    (* Check variance of parameters *)
+    let pos = ref 0 in
+    List.iter2
+      (fun ty (c, n, i) ->
+        incr pos;
+        let var = get_variance ty tvl in
+        let (co,cn) = get_upper var and ij = mem Inj var in
+        if Btype.is_Tvar ty && (co && not c || cn && not n) || not ij && i
+        then raise (Error(loc, Bad_variance
+                                (Variance_not_satisfied !pos,
+                                                        (co,cn,ij),
+                                                        (c,n,i)))))
+      params required;
+    (* Check propagation from constrained parameters *)
+    let args = Btype.newgenty (Ttuple params) in
+    let fvl = Ctype.free_variables args in
+    let fvl = List.filter (fun v -> not (List.memq v params)) fvl in
+    (* If there are no extra variables there is nothing to do *)
+    if fvl = [] then () else
+    let tvl2 = ref TypeMap.empty in
+    List.iter2
+      (fun ty (p,n,_) ->
+        if Btype.is_Tvar ty then () else
+        let v =
+          if p then if n then full else covariant else conjugate covariant in
+        compute_variance env tvl2 v ty)
+      params required;
+    let visited = ref TypeSet.empty in
+    let rec check ty =
+      let ty = Ctype.repr ty in
+      if TypeSet.mem ty !visited then () else
+      let visited' = TypeSet.add ty !visited in
+      visited := visited';
+      let v1 = get_variance ty tvl in
+      let snap = Btype.snapshot () in
+      let v2 =
+        TypeMap.fold
+          (fun t vt v ->
+             if Ctype.is_equal env false [ty] [t] then union vt v else v)
+          !tvl2 null in
+      Btype.backtrack snap;
+      let (c1,n1) = get_upper v1 and (c2,n2,_,i2) = get_lower v2 in
+      if c1 && not c2 || n1 && not n2 then
+        if List.memq ty fvl then
+          let code = if not i2 then No_variable
+                     else if c2 || n2 then Variance_not_reflected
+                     else Variance_not_deducible in
+          raise (Error (loc, Bad_variance (code, (c1,n1,false), (c2,n2,false))))
+        else
+          Btype.iter_type_expr check ty
+    in
+    List.iter (fun (_,ty) -> check ty) tyl;
+  end;
+  List.map2
+    (fun ty (p, n, i) ->
+      let v = get_variance ty tvl in
+      let tr = decl.type_private in
+      (* Use required variance where relevant *)
+      let concr = decl.type_kind <> Type_abstract (*|| tr = Type_new*) in
+      let (p, n) =
+        if tr = Private || not (Btype.is_Tvar ty) then (p, n) (* set *)
+        else (false, false) (* only check *)
+      and i = concr  || i && tr = Private in
+      let v = union v (make p n i) in
+      let v =
+        if not concr then v else
+        if mem Pos v && mem Neg v then full else
+        if Btype.is_Tvar ty then v else
+        union v
+          (if p then if n then full else covariant else conjugate covariant)
+      in
+      if decl.type_kind = Type_abstract && tr = Public then v else
+      set May_weak (mem May_neg v) v)
+    params required
+
+let add_false = List.map (fun ty -> false, ty)
+
+(* A parameter is constrained if it is either instantiated,
+   or it is a variable appearing in another parameter *)
+let constrained vars ty =
+  match ty.desc with
+  | Tvar _ -> List.exists (fun tl -> List.memq ty tl) vars
+  | _ -> true
+
+let for_constr = function
+  | Types.Cstr_tuple l -> add_false l
+  | Types.Cstr_record l ->
+      List.map
+        (fun {Types.ld_mutable; ld_type} -> (ld_mutable = Mutable, ld_type))
+        l
+
+let compute_variance_gadt env ~check (required, loc as rloc) decl
+    (tl, ret_type_opt) =
+  match ret_type_opt with
+  | None ->
+      compute_variance_type env ~check rloc {decl with type_private = Private}
+        (for_constr tl)
+  | Some ret_type ->
+      match Ctype.repr ret_type with
+      | {desc=Tconstr (_, tyl, _)} ->
+          (* let tyl = List.map (Ctype.expand_head env) tyl in *)
+          let tyl = List.map Ctype.repr tyl in
+          let fvl = List.map (Ctype.free_variables ?env:None) tyl in
+          let _ =
+            List.fold_left2
+              (fun (fv1,fv2) ty (c,n,_) ->
+                match fv2 with [] -> assert false
+                | fv :: fv2 ->
+                    (* fv1 @ fv2 = free_variables of other parameters *)
+                    if (c||n) && constrained (fv1 @ fv2) ty then
+                      raise (Error(loc, Varying_anonymous));
+                    (fv :: fv1, fv2))
+              ([], fvl) tyl required
+          in
+          compute_variance_type env ~check rloc
+            {decl with type_params = tyl; type_private = Private}
+            (for_constr tl)
+      | _ -> assert false
+
+let compute_variance_extension env ~check decl ext rloc =
+  compute_variance_gadt env ~check rloc
+    {decl with type_params = ext.ext_type_params}
+    (ext.ext_args, ext.ext_ret_type)
+
+let compute_variance_decl env ~check decl (required, _ as rloc) =
+  if (decl.type_kind = Type_abstract || decl.type_kind = Type_open)
+       && decl.type_manifest = None then
+    List.map
+      (fun (c, n, i) ->
+        make (not n) (not c) (decl.type_kind <> Type_abstract || i))
+      required
+  else
+  let mn =
+    match decl.type_manifest with
+      None -> []
+    | Some ty -> [false, ty]
+  in
+  match decl.type_kind with
+    Type_abstract | Type_open ->
+      compute_variance_type env ~check rloc decl mn
+  | Type_variant (tll,_rep) ->
+      if List.for_all (fun c -> c.Types.cd_res = None) tll then
+        compute_variance_type env ~check rloc decl
+          (mn @ List.flatten (List.map (fun c -> for_constr c.Types.cd_args)
+                                tll))
+      else begin
+        let mn =
+          List.map (fun (_,ty) -> (Types.Cstr_tuple [ty],None)) mn in
+        let tll =
+          mn @ List.map (fun c -> c.Types.cd_args, c.Types.cd_res) tll in
+        match List.map (compute_variance_gadt env ~check rloc decl) tll with
+        | vari :: rem ->
+            let varl = List.fold_left (List.map2 Variance.union) vari rem in
+            List.map
+              Variance.(fun v -> if mem Pos v && mem Neg v then full else v)
+              varl
+        | _ -> assert false
+      end
+  | Type_record (ftl, _) ->
+      compute_variance_type env ~check rloc decl
+        (mn @ List.map (fun {Types.ld_mutable; ld_type} ->
+             (ld_mutable = Mutable, ld_type)) ftl)
+
+let is_hash id =
+  let s = Ident.name id in
+  String.length s > 0 && s.[0] = '#'
+
+let check_variance_extension env decl ext rloc =
+  (* TODO: refactorize compute_variance_extension *)
+  ignore (compute_variance_extension env ~check:true decl
+    ext.Typedtree.ext_type rloc)
+
+let compute_decl env ~check decl req =
+  compute_variance_decl env ~check decl (req, decl.type_loc)
+
+let check_decl env decl req =
+  ignore (compute_variance_decl env ~check:true decl (req, decl.type_loc))
+
+type prop = Variance.t list
+type req = surface_variance list
+let property : (prop, req) Typedecl_properties.property =
+  let open Typedecl_properties in
+  let eq li1 li2 =
+    try List.for_all2 Variance.eq li1 li2 with _ -> false in
+  let merge ~prop ~new_prop =
+    List.map2 Variance.union prop new_prop in
+  let default decl =
+    List.map (fun _ -> Variance.null) decl.type_params in
+  let compute env decl req =
+    compute_decl env ~check:false decl req in
+  let update_decl decl variance =
+    { decl with type_variance = variance } in
+  let check env id decl req =
+    if is_hash id then () else check_decl env decl req in
+  {
+    eq;
+    merge;
+    default;
+    compute;
+    update_decl;
+    check;
+  }
+
+let transl_variance (v, i) =
+  let co, cn =
+    match v with
+    | Covariant -> (true, false)
+    | Contravariant -> (false, true)
+    | NoVariance -> (false, false)
+  in
+  (co, cn, match i with Injective -> true | NoInjectivity -> false)
+
+let variance_of_params ptype_params =
+  List.map transl_variance (List.map snd ptype_params)
+
+let variance_of_sdecl sdecl =
+  variance_of_params sdecl.Parsetree.ptype_params
+
+let update_decls env sdecls decls =
+  let required = List.map variance_of_sdecl sdecls in
+  Typedecl_properties.compute_property property env decls required
+
+let update_class_decls env cldecls =
+  let decls, required =
+    List.fold_right
+      (fun (obj_id, obj_abbr, _cl_abbr, _clty, _cltydef, ci) (decls, req) ->
+        (obj_id, obj_abbr) :: decls,
+        variance_of_params ci.Typedtree.ci_params :: req)
+      cldecls ([],[])
+  in
+  let decls =
+    Typedecl_properties.compute_property property env decls required in
+  List.map2
+    (fun (_,decl) (_, _, cl_abbr, clty, cltydef, _) ->
+      let variance = decl.type_variance in
+      (decl, {cl_abbr with type_variance = variance},
+       {clty with cty_variance = variance},
+       {cltydef with clty_variance = variance}))
+    decls cldecls
diff --git a/upstream/ocaml_413/typing/typedecl_variance.mli b/upstream/ocaml_413/typing/typedecl_variance.mli
new file mode 100644
index 0000000..941ab99
--- /dev/null
+++ b/upstream/ocaml_413/typing/typedecl_variance.mli
@@ -0,0 +1,63 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Gabriel Scherer, projet Parsifal, INRIA Saclay                       *)
+(*   Rodolphe Lepigre, projet Deducteam, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Types
+open Typedecl_properties
+
+type surface_variance = bool * bool * bool
+
+val variance_of_params :
+  (Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list ->
+  surface_variance list
+val variance_of_sdecl :
+  Parsetree.type_declaration -> surface_variance list
+
+type prop = Variance.t list
+type req = surface_variance list
+val property : (Variance.t list, req) property
+
+type variance_error =
+| Variance_not_satisfied of int
+| No_variable
+| Variance_not_reflected
+| Variance_not_deducible
+
+type error =
+| Bad_variance of variance_error * surface_variance * surface_variance
+| Varying_anonymous
+
+exception Error of Location.t * error
+
+val check_variance_extension :
+  Env.t -> type_declaration ->
+  Typedtree.extension_constructor -> req * Location.t -> unit
+
+val compute_decl :
+  Env.t -> check:bool -> type_declaration -> req -> prop
+
+val update_decls :
+  Env.t -> Parsetree.type_declaration list ->
+  (Ident.t * type_declaration) list ->
+  (Ident.t * type_declaration) list
+
+val update_class_decls :
+  Env.t ->
+  (Ident.t * Typedecl_properties.decl * Types.type_declaration *
+   Types.class_declaration * Types.class_type_declaration *
+   'a Typedtree.class_infos) list ->
+  (Typedecl_properties.decl * Types.type_declaration *
+   Types.class_declaration * Types.class_type_declaration) list
+(* FIXME: improve this horrible interface *)
diff --git a/upstream/ocaml_413/typing/typedtree.ml b/upstream/ocaml_413/typing/typedtree.ml
new file mode 100644
index 0000000..5a82ba7
--- /dev/null
+++ b/upstream/ocaml_413/typing/typedtree.ml
@@ -0,0 +1,844 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Abstract syntax tree after typing *)
+
+open Asttypes
+open Types
+
+(* Value expressions for the core language *)
+
+type partial = Partial | Total
+
+type attribute = Parsetree.attribute
+type attributes = attribute list
+
+type value = Value_pattern
+type computation = Computation_pattern
+
+type _ pattern_category =
+| Value : value pattern_category
+| Computation : computation pattern_category
+
+type pattern = value general_pattern
+and 'k general_pattern = 'k pattern_desc pattern_data
+
+and 'a pattern_data =
+  { pat_desc: 'a;
+    pat_loc: Location.t;
+    pat_extra : (pat_extra * Location.t * attribute list) list;
+    pat_type: type_expr;
+    pat_env: Env.t;
+    pat_attributes: attribute list;
+   }
+
+and pat_extra =
+  | Tpat_constraint of core_type
+  | Tpat_type of Path.t * Longident.t loc
+  | Tpat_open of Path.t * Longident.t loc * Env.t
+  | Tpat_unpack
+
+and 'k pattern_desc =
+  (* value patterns *)
+  | Tpat_any : value pattern_desc
+  | Tpat_var : Ident.t * string loc -> value pattern_desc
+  | Tpat_alias :
+      value general_pattern * Ident.t * string loc -> value pattern_desc
+  | Tpat_constant : constant -> value pattern_desc
+  | Tpat_tuple : value general_pattern list -> value pattern_desc
+  | Tpat_construct :
+      Longident.t loc * constructor_description * value general_pattern list
+      * (Ident.t loc list * core_type) option ->
+      value pattern_desc
+  | Tpat_variant :
+      label * value general_pattern option * row_desc ref ->
+      value pattern_desc
+  | Tpat_record :
+      (Longident.t loc * label_description * value general_pattern) list *
+        closed_flag ->
+      value pattern_desc
+  | Tpat_array : value general_pattern list -> value pattern_desc
+  | Tpat_lazy : value general_pattern -> value pattern_desc
+  (* computation patterns *)
+  | Tpat_value : tpat_value_argument -> computation pattern_desc
+  | Tpat_exception : value general_pattern -> computation pattern_desc
+  (* generic constructions *)
+  | Tpat_or :
+      'k general_pattern * 'k general_pattern * row_desc option ->
+      'k pattern_desc
+
+and tpat_value_argument = value general_pattern
+
+and expression =
+  { exp_desc: expression_desc;
+    exp_loc: Location.t;
+    exp_extra: (exp_extra * Location.t * attribute list) list;
+    exp_type: type_expr;
+    exp_env: Env.t;
+    exp_attributes: attribute list;
+   }
+
+and exp_extra =
+  | Texp_constraint of core_type
+  | Texp_coerce of core_type option * core_type
+  | Texp_poly of core_type option
+  | Texp_newtype of string
+
+and expression_desc =
+    Texp_ident of Path.t * Longident.t loc * Types.value_description
+  | Texp_constant of constant
+  | Texp_let of rec_flag * value_binding list * expression
+  | Texp_function of { arg_label : arg_label; param : Ident.t;
+      cases : value case list; partial : partial; }
+  | Texp_apply of expression * (arg_label * expression option) list
+  | Texp_match of expression * computation case list * partial
+  | Texp_try of expression * value case list
+  | Texp_tuple of expression list
+  | Texp_construct of
+      Longident.t loc * constructor_description * expression list
+  | Texp_variant of label * expression option
+  | Texp_record of {
+      fields : ( Types.label_description * record_label_definition ) array;
+      representation : Types.record_representation;
+      extended_expression : expression option;
+    }
+  | Texp_field of expression * Longident.t loc * label_description
+  | Texp_setfield of
+      expression * Longident.t loc * label_description * expression
+  | Texp_array of expression list
+  | Texp_ifthenelse of expression * expression * expression option
+  | Texp_sequence of expression * expression
+  | Texp_while of expression * expression
+  | Texp_for of
+      Ident.t * Parsetree.pattern * expression * expression * direction_flag *
+        expression
+  | Texp_send of expression * meth * expression option
+  | Texp_new of Path.t * Longident.t loc * Types.class_declaration
+  | Texp_instvar of Path.t * Path.t * string loc
+  | Texp_setinstvar of Path.t * Path.t * string loc * expression
+  | Texp_override of Path.t * (Path.t * string loc * expression) list
+  | Texp_letmodule of
+      Ident.t option * string option loc * Types.module_presence * module_expr *
+        expression
+  | Texp_letexception of extension_constructor * expression
+  | Texp_assert of expression
+  | Texp_lazy of expression
+  | Texp_object of class_structure * string list
+  | Texp_pack of module_expr
+  | Texp_letop of {
+      let_ : binding_op;
+      ands : binding_op list;
+      param : Ident.t;
+      body : value case;
+      partial : partial;
+    }
+  | Texp_unreachable
+  | Texp_extension_constructor of Longident.t loc * Path.t
+  | Texp_open of open_declaration * expression
+
+and meth =
+    Tmeth_name of string
+  | Tmeth_val of Ident.t
+
+and 'k case =
+    {
+     c_lhs: 'k general_pattern;
+     c_guard: expression option;
+     c_rhs: expression;
+    }
+
+and record_label_definition =
+  | Kept of Types.type_expr
+  | Overridden of Longident.t loc * expression
+
+and binding_op =
+  {
+    bop_op_path : Path.t;
+    bop_op_name : string loc;
+    bop_op_val : Types.value_description;
+    bop_op_type : Types.type_expr;
+    bop_exp : expression;
+    bop_loc : Location.t;
+  }
+
+(* Value expressions for the class language *)
+
+and class_expr =
+    {
+     cl_desc: class_expr_desc;
+     cl_loc: Location.t;
+     cl_type: Types.class_type;
+     cl_env: Env.t;
+     cl_attributes: attribute list;
+    }
+
+and class_expr_desc =
+    Tcl_ident of Path.t * Longident.t loc * core_type list
+  | Tcl_structure of class_structure
+  | Tcl_fun of
+      arg_label * pattern * (Ident.t * expression) list
+      * class_expr * partial
+  | Tcl_apply of class_expr * (arg_label * expression option) list
+  | Tcl_let of rec_flag * value_binding list *
+                  (Ident.t * expression) list * class_expr
+  | Tcl_constraint of
+      class_expr * class_type option * string list * string list * Concr.t
+    (* Visible instance variables, methods and concrete methods *)
+  | Tcl_open of open_description * class_expr
+
+and class_structure =
+  {
+   cstr_self: pattern;
+   cstr_fields: class_field list;
+   cstr_type: Types.class_signature;
+   cstr_meths: Ident.t Meths.t;
+  }
+
+and class_field =
+   {
+    cf_desc: class_field_desc;
+    cf_loc: Location.t;
+    cf_attributes: attribute list;
+  }
+
+and class_field_kind =
+  | Tcfk_virtual of core_type
+  | Tcfk_concrete of override_flag * expression
+
+and class_field_desc =
+    Tcf_inherit of
+      override_flag * class_expr * string option * (string * Ident.t) list *
+        (string * Ident.t) list
+    (* Inherited instance variables and concrete methods *)
+  | Tcf_val of string loc * mutable_flag * Ident.t * class_field_kind * bool
+  | Tcf_method of string loc * private_flag * class_field_kind
+  | Tcf_constraint of core_type * core_type
+  | Tcf_initializer of expression
+  | Tcf_attribute of attribute
+
+(* Value expressions for the module language *)
+
+and module_expr =
+  { mod_desc: module_expr_desc;
+    mod_loc: Location.t;
+    mod_type: Types.module_type;
+    mod_env: Env.t;
+    mod_attributes: attribute list;
+   }
+
+and module_type_constraint =
+  Tmodtype_implicit
+| Tmodtype_explicit of module_type
+
+and functor_parameter =
+  | Unit
+  | Named of Ident.t option * string option loc * module_type
+
+and module_expr_desc =
+    Tmod_ident of Path.t * Longident.t loc
+  | Tmod_structure of structure
+  | Tmod_functor of functor_parameter * module_expr
+  | Tmod_apply of module_expr * module_expr * module_coercion
+  | Tmod_constraint of
+      module_expr * Types.module_type * module_type_constraint * module_coercion
+  | Tmod_unpack of expression * Types.module_type
+
+and structure = {
+  str_items : structure_item list;
+  str_type : Types.signature;
+  str_final_env : Env.t;
+}
+
+and structure_item =
+  { str_desc : structure_item_desc;
+    str_loc : Location.t;
+    str_env : Env.t
+  }
+
+and structure_item_desc =
+    Tstr_eval of expression * attributes
+  | Tstr_value of rec_flag * value_binding list
+  | Tstr_primitive of value_description
+  | Tstr_type of rec_flag * type_declaration list
+  | Tstr_typext of type_extension
+  | Tstr_exception of type_exception
+  | Tstr_module of module_binding
+  | Tstr_recmodule of module_binding list
+  | Tstr_modtype of module_type_declaration
+  | Tstr_open of open_declaration
+  | Tstr_class of (class_declaration * string list) list
+  | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list
+  | Tstr_include of include_declaration
+  | Tstr_attribute of attribute
+
+and module_binding =
+    {
+     mb_id: Ident.t option;
+     mb_name: string option loc;
+     mb_presence: module_presence;
+     mb_expr: module_expr;
+     mb_attributes: attribute list;
+     mb_loc: Location.t;
+    }
+
+and value_binding =
+  {
+    vb_pat: pattern;
+    vb_expr: expression;
+    vb_attributes: attributes;
+    vb_loc: Location.t;
+  }
+
+and module_coercion =
+    Tcoerce_none
+  | Tcoerce_structure of (int * module_coercion) list *
+                         (Ident.t * int * module_coercion) list
+  | Tcoerce_functor of module_coercion * module_coercion
+  | Tcoerce_primitive of primitive_coercion
+  | Tcoerce_alias of Env.t * Path.t * module_coercion
+
+and module_type =
+  { mty_desc: module_type_desc;
+    mty_type : Types.module_type;
+    mty_env : Env.t;
+    mty_loc: Location.t;
+    mty_attributes: attribute list;
+   }
+
+and module_type_desc =
+    Tmty_ident of Path.t * Longident.t loc
+  | Tmty_signature of signature
+  | Tmty_functor of functor_parameter * module_type
+  | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list
+  | Tmty_typeof of module_expr
+  | Tmty_alias of Path.t * Longident.t loc
+
+(* Keep primitive type information for type-based lambda-code specialization *)
+and primitive_coercion =
+  {
+    pc_desc: Primitive.description;
+    pc_type: type_expr;
+    pc_env: Env.t;
+    pc_loc : Location.t;
+  }
+
+and signature = {
+  sig_items : signature_item list;
+  sig_type : Types.signature;
+  sig_final_env : Env.t;
+}
+
+and signature_item =
+  { sig_desc: signature_item_desc;
+    sig_env : Env.t; (* BINANNOT ADDED *)
+    sig_loc: Location.t }
+
+and signature_item_desc =
+    Tsig_value of value_description
+  | Tsig_type of rec_flag * type_declaration list
+  | Tsig_typesubst of type_declaration list
+  | Tsig_typext of type_extension
+  | Tsig_exception of type_exception
+  | Tsig_module of module_declaration
+  | Tsig_modsubst of module_substitution
+  | Tsig_recmodule of module_declaration list
+  | Tsig_modtype of module_type_declaration
+  | Tsig_modtypesubst of module_type_declaration
+  | Tsig_open of open_description
+  | Tsig_include of include_description
+  | Tsig_class of class_description list
+  | Tsig_class_type of class_type_declaration list
+  | Tsig_attribute of attribute
+
+and module_declaration =
+    {
+     md_id: Ident.t option;
+     md_name: string option loc;
+     md_presence: module_presence;
+     md_type: module_type;
+     md_attributes: attribute list;
+     md_loc: Location.t;
+    }
+
+and module_substitution =
+    {
+     ms_id: Ident.t;
+     ms_name: string loc;
+     ms_manifest: Path.t;
+     ms_txt: Longident.t loc;
+     ms_attributes: attributes;
+     ms_loc: Location.t;
+    }
+
+and module_type_declaration =
+    {
+     mtd_id: Ident.t;
+     mtd_name: string loc;
+     mtd_type: module_type option;
+     mtd_attributes: attribute list;
+     mtd_loc: Location.t;
+    }
+
+and 'a open_infos =
+    {
+     open_expr: 'a;
+     open_bound_items: Types.signature;
+     open_override: override_flag;
+     open_env: Env.t;
+     open_loc: Location.t;
+     open_attributes: attribute list;
+    }
+
+and open_description = (Path.t * Longident.t loc) open_infos
+
+and open_declaration = module_expr open_infos
+
+and 'a include_infos =
+    {
+     incl_mod: 'a;
+     incl_type: Types.signature;
+     incl_loc: Location.t;
+     incl_attributes: attribute list;
+    }
+
+and include_description = module_type include_infos
+
+and include_declaration = module_expr include_infos
+
+and with_constraint =
+    Twith_type of type_declaration
+  | Twith_module of Path.t * Longident.t loc
+  | Twith_modtype of module_type
+  | Twith_typesubst of type_declaration
+  | Twith_modsubst of Path.t * Longident.t loc
+  | Twith_modtypesubst of module_type
+
+
+and core_type =
+(* mutable because of [Typeclass.declare_method] *)
+  { mutable ctyp_desc : core_type_desc;
+    mutable ctyp_type : type_expr;
+    ctyp_env : Env.t; (* BINANNOT ADDED *)
+    ctyp_loc : Location.t;
+    ctyp_attributes: attribute list;
+   }
+
+and core_type_desc =
+    Ttyp_any
+  | Ttyp_var of string
+  | Ttyp_arrow of arg_label * core_type * core_type
+  | Ttyp_tuple of core_type list
+  | Ttyp_constr of Path.t * Longident.t loc * core_type list
+  | Ttyp_object of object_field list * closed_flag
+  | Ttyp_class of Path.t * Longident.t loc * core_type list
+  | Ttyp_alias of core_type * string
+  | Ttyp_variant of row_field list * closed_flag * label list option
+  | Ttyp_poly of string list * core_type
+  | Ttyp_package of package_type
+
+and package_type = {
+  pack_path : Path.t;
+  pack_fields : (Longident.t loc * core_type) list;
+  pack_type : Types.module_type;
+  pack_txt : Longident.t loc;
+}
+
+and row_field = {
+  rf_desc : row_field_desc;
+  rf_loc : Location.t;
+  rf_attributes : attributes;
+}
+
+and row_field_desc =
+    Ttag of string loc * bool * core_type list
+  | Tinherit of core_type
+
+and object_field = {
+  of_desc : object_field_desc;
+  of_loc : Location.t;
+  of_attributes : attributes;
+}
+
+and object_field_desc =
+  | OTtag of string loc * core_type
+  | OTinherit of core_type
+
+and value_description =
+  { val_id: Ident.t;
+    val_name: string loc;
+    val_desc: core_type;
+    val_val: Types.value_description;
+    val_prim: string list;
+    val_loc: Location.t;
+    val_attributes: attribute list;
+    }
+
+and type_declaration =
+  { typ_id: Ident.t;
+    typ_name: string loc;
+    typ_params: (core_type * (variance * injectivity)) list;
+    typ_type: Types.type_declaration;
+    typ_cstrs: (core_type * core_type * Location.t) list;
+    typ_kind: type_kind;
+    typ_private: private_flag;
+    typ_manifest: core_type option;
+    typ_loc: Location.t;
+    typ_attributes: attribute list;
+   }
+
+and type_kind =
+    Ttype_abstract
+  | Ttype_variant of constructor_declaration list
+  | Ttype_record of label_declaration list
+  | Ttype_open
+
+and label_declaration =
+    {
+     ld_id: Ident.t;
+     ld_name: string loc;
+     ld_mutable: mutable_flag;
+     ld_type: core_type;
+     ld_loc: Location.t;
+     ld_attributes: attribute list;
+    }
+
+and constructor_declaration =
+    {
+     cd_id: Ident.t;
+     cd_name: string loc;
+     cd_args: constructor_arguments;
+     cd_res: core_type option;
+     cd_loc: Location.t;
+     cd_attributes: attribute list;
+    }
+
+and constructor_arguments =
+  | Cstr_tuple of core_type list
+  | Cstr_record of label_declaration list
+
+and type_extension =
+  {
+    tyext_path: Path.t;
+    tyext_txt: Longident.t loc;
+    tyext_params: (core_type * (variance * injectivity)) list;
+    tyext_constructors: extension_constructor list;
+    tyext_private: private_flag;
+    tyext_loc: Location.t;
+    tyext_attributes: attribute list;
+  }
+
+and type_exception =
+  {
+    tyexn_constructor: extension_constructor;
+    tyexn_loc: Location.t;
+    tyexn_attributes: attribute list;
+  }
+
+and extension_constructor =
+  {
+    ext_id: Ident.t;
+    ext_name: string loc;
+    ext_type: Types.extension_constructor;
+    ext_kind: extension_constructor_kind;
+    ext_loc: Location.t;
+    ext_attributes: attribute list;
+  }
+
+and extension_constructor_kind =
+    Text_decl of constructor_arguments * core_type option
+  | Text_rebind of Path.t * Longident.t loc
+
+and class_type =
+    {
+     cltyp_desc: class_type_desc;
+     cltyp_type: Types.class_type;
+     cltyp_env: Env.t;
+     cltyp_loc: Location.t;
+     cltyp_attributes: attribute list;
+    }
+
+and class_type_desc =
+    Tcty_constr of Path.t * Longident.t loc * core_type list
+  | Tcty_signature of class_signature
+  | Tcty_arrow of arg_label * core_type * class_type
+  | Tcty_open of open_description * class_type
+
+and class_signature = {
+    csig_self: core_type;
+    csig_fields: class_type_field list;
+    csig_type: Types.class_signature;
+  }
+
+and class_type_field = {
+    ctf_desc: class_type_field_desc;
+    ctf_loc: Location.t;
+    ctf_attributes: attribute list;
+  }
+
+and class_type_field_desc =
+  | Tctf_inherit of class_type
+  | Tctf_val of (string * mutable_flag * virtual_flag * core_type)
+  | Tctf_method of (string * private_flag * virtual_flag * core_type)
+  | Tctf_constraint of (core_type * core_type)
+  | Tctf_attribute of attribute
+
+and class_declaration =
+  class_expr class_infos
+
+and class_description =
+  class_type class_infos
+
+and class_type_declaration =
+  class_type class_infos
+
+and 'a class_infos =
+  { ci_virt: virtual_flag;
+    ci_params: (core_type * (variance * injectivity)) list;
+    ci_id_name: string loc;
+    ci_id_class: Ident.t;
+    ci_id_class_type: Ident.t;
+    ci_id_object: Ident.t;
+    ci_id_typehash: Ident.t;
+    ci_expr: 'a;
+    ci_decl: Types.class_declaration;
+    ci_type_decl: Types.class_type_declaration;
+    ci_loc: Location.t;
+    ci_attributes: attribute list;
+   }
+
+type implementation = {
+  structure: structure;
+  coercion: module_coercion;
+  signature: Types.signature
+}
+
+
+(* Auxiliary functions over the a.s.t. *)
+
+let as_computation_pattern (p : pattern) : computation general_pattern =
+  {
+    pat_desc = Tpat_value p;
+    pat_loc = p.pat_loc;
+    pat_extra = [];
+    pat_type = p.pat_type;
+    pat_env = p.pat_env;
+    pat_attributes = [];
+  }
+
+let rec classify_pattern_desc : type k . k pattern_desc -> k pattern_category =
+  function
+  | Tpat_alias _ -> Value
+  | Tpat_tuple _ -> Value
+  | Tpat_construct _ -> Value
+  | Tpat_variant _ -> Value
+  | Tpat_record _ -> Value
+  | Tpat_array _ -> Value
+  | Tpat_lazy _ -> Value
+  | Tpat_any -> Value
+  | Tpat_var _ -> Value
+  | Tpat_constant _ -> Value
+
+  | Tpat_value _ -> Computation
+  | Tpat_exception _ -> Computation
+
+  | Tpat_or(p1, p2, _) ->
+     begin match classify_pattern p1, classify_pattern p2 with
+     | Value, Value -> Value
+     | Computation, Computation -> Computation
+     end
+
+and classify_pattern
+  : type k . k general_pattern -> k pattern_category
+  = fun pat ->
+  classify_pattern_desc pat.pat_desc
+
+type pattern_action =
+  { f : 'k . 'k general_pattern -> unit }
+let shallow_iter_pattern_desc
+  : type k . pattern_action -> k pattern_desc -> unit
+  = fun f -> function
+  | Tpat_alias(p, _, _) -> f.f p
+  | Tpat_tuple patl -> List.iter f.f patl
+  | Tpat_construct(_, _, patl, _) -> List.iter f.f patl
+  | Tpat_variant(_, pat, _) -> Option.iter f.f pat
+  | Tpat_record (lbl_pat_list, _) ->
+      List.iter (fun (_, _, pat) -> f.f pat) lbl_pat_list
+  | Tpat_array patl -> List.iter f.f patl
+  | Tpat_lazy p -> f.f p
+  | Tpat_any
+  | Tpat_var _
+  | Tpat_constant _ -> ()
+  | Tpat_value p -> f.f p
+  | Tpat_exception p -> f.f p
+  | Tpat_or(p1, p2, _) -> f.f p1; f.f p2
+
+type pattern_transformation =
+  { f : 'k . 'k general_pattern -> 'k general_pattern }
+let shallow_map_pattern_desc
+  : type k . pattern_transformation -> k pattern_desc -> k pattern_desc
+  = fun f d -> match d with
+  | Tpat_alias (p1, id, s) ->
+      Tpat_alias (f.f p1, id, s)
+  | Tpat_tuple pats ->
+      Tpat_tuple (List.map f.f pats)
+  | Tpat_record (lpats, closed) ->
+      Tpat_record (List.map (fun (lid, l,p) -> lid, l, f.f p) lpats, closed)
+  | Tpat_construct (lid, c, pats, ty) ->
+      Tpat_construct (lid, c, List.map f.f pats, ty)
+  | Tpat_array pats ->
+      Tpat_array (List.map f.f pats)
+  | Tpat_lazy p1 -> Tpat_lazy (f.f p1)
+  | Tpat_variant (x1, Some p1, x2) ->
+      Tpat_variant (x1, Some (f.f p1), x2)
+  | Tpat_var _
+  | Tpat_constant _
+  | Tpat_any
+  | Tpat_variant (_,None,_) -> d
+  | Tpat_value p -> Tpat_value (f.f p)
+  | Tpat_exception p -> Tpat_exception (f.f p)
+  | Tpat_or (p1,p2,path) ->
+      Tpat_or (f.f p1, f.f p2, path)
+
+let rec iter_general_pattern
+  : type k . pattern_action -> k general_pattern -> unit
+  = fun f p ->
+  f.f p;
+  shallow_iter_pattern_desc
+    { f = fun p -> iter_general_pattern f p }
+    p.pat_desc
+
+let iter_pattern (f : pattern -> unit) =
+  iter_general_pattern
+    { f = fun (type k) (p : k general_pattern) ->
+          match classify_pattern p with
+          | Value -> f p
+          | Computation -> () }
+
+type pattern_predicate = { f : 'k . 'k general_pattern -> bool }
+let exists_general_pattern (f : pattern_predicate) p =
+  let exception Found in
+  match
+    iter_general_pattern
+      { f = fun p -> if f.f p then raise Found else () }
+      p
+  with
+  | exception Found -> true
+  | () -> false
+
+let exists_pattern (f : pattern -> bool) =
+  exists_general_pattern
+    { f = fun (type k) (p : k general_pattern) ->
+          match classify_pattern p with
+          | Value -> f p
+          | Computation -> false }
+
+
+(* List the identifiers bound by a pattern or a let *)
+
+let rec iter_bound_idents
+  : type k . _ -> k general_pattern -> _
+  = fun f pat ->
+  match pat.pat_desc with
+  | Tpat_var (id,s) ->
+     f (id,s,pat.pat_type)
+  | Tpat_alias(p, id, s) ->
+      iter_bound_idents f p;
+      f (id,s,pat.pat_type)
+  | Tpat_or(p1, _, _) ->
+      (* Invariant : both arguments bind the same variables *)
+      iter_bound_idents f p1
+  | d ->
+     shallow_iter_pattern_desc
+       { f = fun p -> iter_bound_idents f p }
+       d
+
+let rev_pat_bound_idents_full pat =
+  let idents_full = ref [] in
+  let add id_full = idents_full := id_full :: !idents_full in
+  iter_bound_idents add pat;
+  !idents_full
+
+let rev_only_idents idents_full =
+  List.rev_map (fun (id,_,_) -> id) idents_full
+
+let pat_bound_idents_full pat =
+  List.rev (rev_pat_bound_idents_full pat)
+let pat_bound_idents pat =
+  rev_only_idents (rev_pat_bound_idents_full pat)
+
+let rev_let_bound_idents_full bindings =
+  let idents_full = ref [] in
+  let add id_full = idents_full := id_full :: !idents_full in
+  List.iter (fun vb -> iter_bound_idents add vb.vb_pat) bindings;
+  !idents_full
+
+let let_bound_idents_full bindings =
+  List.rev (rev_let_bound_idents_full bindings)
+let let_bound_idents pat =
+  rev_only_idents (rev_let_bound_idents_full pat)
+
+let alpha_var env id = List.assoc id env
+
+let rec alpha_pat
+  : type k . _ -> k general_pattern -> k general_pattern
+  = fun env p -> match p.pat_desc with
+  | Tpat_var (id, s) -> (* note the ``Not_found'' case *)
+      {p with pat_desc =
+       try Tpat_var (alpha_var env id, s) with
+       | Not_found -> Tpat_any}
+  | Tpat_alias (p1, id, s) ->
+      let new_p =  alpha_pat env p1 in
+      begin try
+        {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s)}
+      with
+      | Not_found -> new_p
+      end
+  | d ->
+     let pat_desc =
+       shallow_map_pattern_desc { f = fun p -> alpha_pat env p } d in
+     {p with pat_desc}
+
+let mkloc = Location.mkloc
+let mknoloc = Location.mknoloc
+
+let split_pattern pat =
+  let combine_opts merge p1 p2 =
+    match p1, p2 with
+    | None, None -> None
+    | Some p, None
+    | None, Some p ->
+        Some p
+    | Some p1, Some p2 ->
+        Some (merge p1 p2)
+  in
+  let into pat p1 p2 =
+    (* The third parameter of [Tpat_or] is [Some _] only for "#typ"
+       patterns, which we do *not* expand. Hence we can put [None] here. *)
+    { pat with pat_desc = Tpat_or (p1, p2, None) } in
+  let rec split_pattern cpat =
+    match cpat.pat_desc with
+    | Tpat_value p ->
+        Some p, None
+    | Tpat_exception p ->
+        None, Some p
+    | Tpat_or (cp1, cp2, _) ->
+        let vals1, exns1 = split_pattern cp1 in
+        let vals2, exns2 = split_pattern cp2 in
+        combine_opts (into cpat) vals1 vals2,
+        (* We could change the pattern type for exception patterns to
+           [Predef.exn], but it doesn't really matter. *)
+        combine_opts (into cpat) exns1 exns2
+  in
+  split_pattern pat
diff --git a/upstream/ocaml_413/typing/typedtree.mli b/upstream/ocaml_413/typing/typedtree.mli
new file mode 100644
index 0000000..5515425
--- /dev/null
+++ b/upstream/ocaml_413/typing/typedtree.mli
@@ -0,0 +1,822 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Abstract syntax tree after typing *)
+
+
+(** By comparison with {!Parsetree}:
+    - Every {!Longindent.t} is accompanied by a resolved {!Path.t}.
+
+*)
+
+open Asttypes
+
+(* Value expressions for the core language *)
+
+type partial = Partial | Total
+
+(** {1 Extension points} *)
+
+type attribute = Parsetree.attribute
+type attributes = attribute list
+
+(** {1 Core language} *)
+
+type value = Value_pattern
+type computation = Computation_pattern
+
+type _ pattern_category =
+| Value : value pattern_category
+| Computation : computation pattern_category
+
+type pattern = value general_pattern
+and 'k general_pattern = 'k pattern_desc pattern_data
+
+and 'a pattern_data =
+  { pat_desc: 'a;
+    pat_loc: Location.t;
+    pat_extra : (pat_extra * Location.t * attributes) list;
+    pat_type: Types.type_expr;
+    pat_env: Env.t;
+    pat_attributes: attributes;
+   }
+
+and pat_extra =
+  | Tpat_constraint of core_type
+        (** P : T          { pat_desc = P
+                           ; pat_extra = (Tpat_constraint T, _, _) :: ... }
+         *)
+  | Tpat_type of Path.t * Longident.t loc
+        (** #tconst        { pat_desc = disjunction
+                           ; pat_extra = (Tpat_type (P, "tconst"), _, _) :: ...}
+
+                           where [disjunction] is a [Tpat_or _] representing the
+                           branches of [tconst].
+         *)
+  | Tpat_open of Path.t * Longident.t loc * Env.t
+  | Tpat_unpack
+        (** (module P)     { pat_desc  = Tpat_var "P"
+                           ; pat_extra = (Tpat_unpack, _, _) :: ... }
+         *)
+
+and 'k pattern_desc =
+  (* value patterns *)
+  | Tpat_any : value pattern_desc
+        (** _ *)
+  | Tpat_var : Ident.t * string loc -> value pattern_desc
+        (** x *)
+  | Tpat_alias :
+      value general_pattern * Ident.t * string loc -> value pattern_desc
+        (** P as a *)
+  | Tpat_constant : constant -> value pattern_desc
+        (** 1, 'a', "true", 1.0, 1l, 1L, 1n *)
+  | Tpat_tuple : value general_pattern list -> value pattern_desc
+        (** (P1, ..., Pn)
+
+            Invariant: n >= 2
+         *)
+  | Tpat_construct :
+      Longident.t loc * Types.constructor_description *
+        value general_pattern list * (Ident.t loc list * core_type) option ->
+      value pattern_desc
+        (** C                             ([], None)
+            C P                           ([P], None)
+            C (P1, ..., Pn)               ([P1; ...; Pn], None)
+            C (P : t)                     ([P], Some ([], t))
+            C (P1, ..., Pn : t)           ([P1; ...; Pn], Some ([], t))
+            C (type a) (P : t)            ([P], Some ([a], t))
+            C (type a) (P1, ..., Pn : t)  ([P1; ...; Pn], Some ([a], t))
+          *)
+  | Tpat_variant :
+      label * value general_pattern option * Types.row_desc ref ->
+      value pattern_desc
+        (** `A             (None)
+            `A P           (Some P)
+
+            See {!Types.row_desc} for an explanation of the last parameter.
+         *)
+  | Tpat_record :
+      (Longident.t loc * Types.label_description * value general_pattern) list *
+        closed_flag ->
+      value pattern_desc
+        (** { l1=P1; ...; ln=Pn }     (flag = Closed)
+            { l1=P1; ...; ln=Pn; _}   (flag = Open)
+
+            Invariant: n > 0
+         *)
+  | Tpat_array : value general_pattern list -> value pattern_desc
+        (** [| P1; ...; Pn |] *)
+  | Tpat_lazy : value general_pattern -> value pattern_desc
+        (** lazy P *)
+  (* computation patterns *)
+  | Tpat_value : tpat_value_argument -> computation pattern_desc
+        (** P
+
+            Invariant: Tpat_value pattern should not carry
+            pat_attributes or pat_extra metadata coming from user
+            syntax, which must be on the inner pattern node -- to
+            facilitate searching for a certain value pattern
+            constructor with a specific attributed.
+
+            To enforce this restriction, we made the argument of
+            the Tpat_value constructor a private synonym of [pattern],
+            requiring you to use the [as_computation_pattern] function
+            below instead of using the [Tpat_value] constructor directly.
+         *)
+  | Tpat_exception : value general_pattern -> computation pattern_desc
+        (** exception P *)
+  (* generic constructions *)
+  | Tpat_or :
+      'k general_pattern * 'k general_pattern * Types.row_desc option ->
+      'k pattern_desc
+        (** P1 | P2
+
+            [row_desc] = [Some _] when translating [Ppat_type _],
+                         [None] otherwise.
+         *)
+
+and tpat_value_argument = private value general_pattern
+
+and expression =
+  { exp_desc: expression_desc;
+    exp_loc: Location.t;
+    exp_extra: (exp_extra * Location.t * attributes) list;
+    exp_type: Types.type_expr;
+    exp_env: Env.t;
+    exp_attributes: attributes;
+   }
+
+and exp_extra =
+  | Texp_constraint of core_type
+        (** E : T *)
+  | Texp_coerce of core_type option * core_type
+        (** E :> T           [Texp_coerce (None, T)]
+            E : T0 :> T      [Texp_coerce (Some T0, T)]
+         *)
+  | Texp_poly of core_type option
+        (** Used for method bodies. *)
+  | Texp_newtype of string
+        (** fun (type t) ->  *)
+
+and expression_desc =
+    Texp_ident of Path.t * Longident.t loc * Types.value_description
+        (** x
+            M.x
+         *)
+  | Texp_constant of constant
+        (** 1, 'a', "true", 1.0, 1l, 1L, 1n *)
+  | Texp_let of rec_flag * value_binding list * expression
+        (** let P1 = E1 and ... and Pn = EN in E       (flag = Nonrecursive)
+            let rec P1 = E1 and ... and Pn = EN in E   (flag = Recursive)
+         *)
+  | Texp_function of { arg_label : arg_label; param : Ident.t;
+      cases : value case list; partial : partial; }
+        (** [Pexp_fun] and [Pexp_function] both translate to [Texp_function].
+            See {!Parsetree} for more details.
+
+            [param] is the identifier that is to be used to name the
+            parameter of the function.
+
+            partial =
+              [Partial] if the pattern match is partial
+              [Total] otherwise.
+         *)
+  | Texp_apply of expression * (arg_label * expression option) list
+        (** E0 ~l1:E1 ... ~ln:En
+
+            The expression can be None if the expression is abstracted over
+            this argument. It currently appears when a label is applied.
+
+            For example:
+            let f x ~y = x + y in
+            f ~y:3
+
+            The resulting typedtree for the application is:
+            Texp_apply (Texp_ident "f/1037",
+                        [(Nolabel, None);
+                         (Labelled "y", Some (Texp_constant Const_int 3))
+                        ])
+         *)
+  | Texp_match of expression * computation case list * partial
+        (** match E0 with
+            | P1 -> E1
+            | P2 | exception P3 -> E2
+            | exception P4 -> E3
+
+            [Texp_match (E0, [(P1, E1); (P2 | exception P3, E2);
+                              (exception P4, E3)], _)]
+         *)
+  | Texp_try of expression * value case list
+        (** try E with P1 -> E1 | ... | PN -> EN *)
+  | Texp_tuple of expression list
+        (** (E1, ..., EN) *)
+  | Texp_construct of
+      Longident.t loc * Types.constructor_description * expression list
+        (** C                []
+            C E              [E]
+            C (E1, ..., En)  [E1;...;En]
+         *)
+  | Texp_variant of label * expression option
+  | Texp_record of {
+      fields : ( Types.label_description * record_label_definition ) array;
+      representation : Types.record_representation;
+      extended_expression : expression option;
+    }
+        (** { l1=P1; ...; ln=Pn }           (extended_expression = None)
+            { E0 with l1=P1; ...; ln=Pn }   (extended_expression = Some E0)
+
+            Invariant: n > 0
+
+            If the type is { l1: t1; l2: t2 }, the expression
+            { E0 with t2=P2 } is represented as
+            Texp_record
+              { fields = [| l1, Kept t1; l2 Override P2 |]; representation;
+                extended_expression = Some E0 }
+        *)
+  | Texp_field of expression * Longident.t loc * Types.label_description
+  | Texp_setfield of
+      expression * Longident.t loc * Types.label_description * expression
+  | Texp_array of expression list
+  | Texp_ifthenelse of expression * expression * expression option
+  | Texp_sequence of expression * expression
+  | Texp_while of expression * expression
+  | Texp_for of
+      Ident.t * Parsetree.pattern * expression * expression * direction_flag *
+        expression
+  | Texp_send of expression * meth * expression option
+  | Texp_new of Path.t * Longident.t loc * Types.class_declaration
+  | Texp_instvar of Path.t * Path.t * string loc
+  | Texp_setinstvar of Path.t * Path.t * string loc * expression
+  | Texp_override of Path.t * (Path.t * string loc * expression) list
+  | Texp_letmodule of
+      Ident.t option * string option loc * Types.module_presence * module_expr *
+        expression
+  | Texp_letexception of extension_constructor * expression
+  | Texp_assert of expression
+  | Texp_lazy of expression
+  | Texp_object of class_structure * string list
+  | Texp_pack of module_expr
+  | Texp_letop of {
+      let_ : binding_op;
+      ands : binding_op list;
+      param : Ident.t;
+      body : value case;
+      partial : partial;
+    }
+  | Texp_unreachable
+  | Texp_extension_constructor of Longident.t loc * Path.t
+  | Texp_open of open_declaration * expression
+        (** let open[!] M in e *)
+
+and meth =
+    Tmeth_name of string
+  | Tmeth_val of Ident.t
+
+and 'k case =
+    {
+     c_lhs: 'k general_pattern;
+     c_guard: expression option;
+     c_rhs: expression;
+    }
+
+and record_label_definition =
+  | Kept of Types.type_expr
+  | Overridden of Longident.t loc * expression
+
+and binding_op =
+  {
+    bop_op_path : Path.t;
+    bop_op_name : string loc;
+    bop_op_val : Types.value_description;
+    bop_op_type : Types.type_expr;
+    (* This is the type at which the operator was used.
+       It is always an instance of [bop_op_val.val_type] *)
+    bop_exp : expression;
+    bop_loc : Location.t;
+  }
+
+(* Value expressions for the class language *)
+
+and class_expr =
+    {
+     cl_desc: class_expr_desc;
+     cl_loc: Location.t;
+     cl_type: Types.class_type;
+     cl_env: Env.t;
+     cl_attributes: attributes;
+    }
+
+and class_expr_desc =
+    Tcl_ident of Path.t * Longident.t loc * core_type list
+  | Tcl_structure of class_structure
+  | Tcl_fun of
+      arg_label * pattern * (Ident.t * expression) list
+      * class_expr * partial
+  | Tcl_apply of class_expr * (arg_label * expression option) list
+  | Tcl_let of rec_flag * value_binding list *
+                  (Ident.t * expression) list * class_expr
+  | Tcl_constraint of
+      class_expr * class_type option * string list * string list * Types.Concr.t
+  (* Visible instance variables, methods and concrete methods *)
+  | Tcl_open of open_description * class_expr
+
+and class_structure =
+  {
+   cstr_self: pattern;
+   cstr_fields: class_field list;
+   cstr_type: Types.class_signature;
+   cstr_meths: Ident.t Types.Meths.t;
+  }
+
+and class_field =
+   {
+    cf_desc: class_field_desc;
+    cf_loc: Location.t;
+    cf_attributes: attributes;
+  }
+
+and class_field_kind =
+  | Tcfk_virtual of core_type
+  | Tcfk_concrete of override_flag * expression
+
+and class_field_desc =
+    Tcf_inherit of
+      override_flag * class_expr * string option * (string * Ident.t) list *
+        (string * Ident.t) list
+    (* Inherited instance variables and concrete methods *)
+  | Tcf_val of string loc * mutable_flag * Ident.t * class_field_kind * bool
+  | Tcf_method of string loc * private_flag * class_field_kind
+  | Tcf_constraint of core_type * core_type
+  | Tcf_initializer of expression
+  | Tcf_attribute of attribute
+
+(* Value expressions for the module language *)
+
+and module_expr =
+  { mod_desc: module_expr_desc;
+    mod_loc: Location.t;
+    mod_type: Types.module_type;
+    mod_env: Env.t;
+    mod_attributes: attributes;
+   }
+
+(** Annotations for [Tmod_constraint]. *)
+and module_type_constraint =
+  | Tmodtype_implicit
+  (** The module type constraint has been synthesized during typechecking. *)
+  | Tmodtype_explicit of module_type
+  (** The module type was in the source file. *)
+
+and functor_parameter =
+  | Unit
+  | Named of Ident.t option * string option loc * module_type
+
+and module_expr_desc =
+    Tmod_ident of Path.t * Longident.t loc
+  | Tmod_structure of structure
+  | Tmod_functor of functor_parameter * module_expr
+  | Tmod_apply of module_expr * module_expr * module_coercion
+  | Tmod_constraint of
+      module_expr * Types.module_type * module_type_constraint * module_coercion
+    (** ME          (constraint = Tmodtype_implicit)
+        (ME : MT)   (constraint = Tmodtype_explicit MT)
+     *)
+  | Tmod_unpack of expression * Types.module_type
+
+and structure = {
+  str_items : structure_item list;
+  str_type : Types.signature;
+  str_final_env : Env.t;
+}
+
+and structure_item =
+  { str_desc : structure_item_desc;
+    str_loc : Location.t;
+    str_env : Env.t
+  }
+
+and structure_item_desc =
+    Tstr_eval of expression * attributes
+  | Tstr_value of rec_flag * value_binding list
+  | Tstr_primitive of value_description
+  | Tstr_type of rec_flag * type_declaration list
+  | Tstr_typext of type_extension
+  | Tstr_exception of type_exception
+  | Tstr_module of module_binding
+  | Tstr_recmodule of module_binding list
+  | Tstr_modtype of module_type_declaration
+  | Tstr_open of open_declaration
+  | Tstr_class of (class_declaration * string list) list
+  | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list
+  | Tstr_include of include_declaration
+  | Tstr_attribute of attribute
+
+and module_binding =
+    {
+     mb_id: Ident.t option;
+     mb_name: string option loc;
+     mb_presence: Types.module_presence;
+     mb_expr: module_expr;
+     mb_attributes: attributes;
+     mb_loc: Location.t;
+    }
+
+and value_binding =
+  {
+    vb_pat: pattern;
+    vb_expr: expression;
+    vb_attributes: attributes;
+    vb_loc: Location.t;
+  }
+
+and module_coercion =
+    Tcoerce_none
+  | Tcoerce_structure of (int * module_coercion) list *
+                         (Ident.t * int * module_coercion) list
+  | Tcoerce_functor of module_coercion * module_coercion
+  | Tcoerce_primitive of primitive_coercion
+  | Tcoerce_alias of Env.t * Path.t * module_coercion
+
+and module_type =
+  { mty_desc: module_type_desc;
+    mty_type : Types.module_type;
+    mty_env : Env.t;
+    mty_loc: Location.t;
+    mty_attributes: attributes;
+   }
+
+and module_type_desc =
+    Tmty_ident of Path.t * Longident.t loc
+  | Tmty_signature of signature
+  | Tmty_functor of functor_parameter * module_type
+  | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list
+  | Tmty_typeof of module_expr
+  | Tmty_alias of Path.t * Longident.t loc
+
+and primitive_coercion =
+  {
+    pc_desc: Primitive.description;
+    pc_type: Types.type_expr;
+    pc_env: Env.t;
+    pc_loc : Location.t;
+  }
+
+and signature = {
+  sig_items : signature_item list;
+  sig_type : Types.signature;
+  sig_final_env : Env.t;
+}
+
+and signature_item =
+  { sig_desc: signature_item_desc;
+    sig_env : Env.t; (* BINANNOT ADDED *)
+    sig_loc: Location.t }
+
+and signature_item_desc =
+    Tsig_value of value_description
+  | Tsig_type of rec_flag * type_declaration list
+  | Tsig_typesubst of type_declaration list
+  | Tsig_typext of type_extension
+  | Tsig_exception of type_exception
+  | Tsig_module of module_declaration
+  | Tsig_modsubst of module_substitution
+  | Tsig_recmodule of module_declaration list
+  | Tsig_modtype of module_type_declaration
+  | Tsig_modtypesubst of module_type_declaration
+  | Tsig_open of open_description
+  | Tsig_include of include_description
+  | Tsig_class of class_description list
+  | Tsig_class_type of class_type_declaration list
+  | Tsig_attribute of attribute
+
+and module_declaration =
+    {
+     md_id: Ident.t option;
+     md_name: string option loc;
+     md_presence: Types.module_presence;
+     md_type: module_type;
+     md_attributes: attributes;
+     md_loc: Location.t;
+    }
+
+and module_substitution =
+    {
+     ms_id: Ident.t;
+     ms_name: string loc;
+     ms_manifest: Path.t;
+     ms_txt: Longident.t loc;
+     ms_attributes: attributes;
+     ms_loc: Location.t;
+    }
+
+and module_type_declaration =
+    {
+     mtd_id: Ident.t;
+     mtd_name: string loc;
+     mtd_type: module_type option;
+     mtd_attributes: attributes;
+     mtd_loc: Location.t;
+    }
+
+and 'a open_infos =
+    {
+     open_expr: 'a;
+     open_bound_items: Types.signature;
+     open_override: override_flag;
+     open_env: Env.t;
+     open_loc: Location.t;
+     open_attributes: attribute list;
+    }
+
+and open_description = (Path.t * Longident.t loc) open_infos
+
+and open_declaration = module_expr open_infos
+
+
+and 'a include_infos =
+    {
+     incl_mod: 'a;
+     incl_type: Types.signature;
+     incl_loc: Location.t;
+     incl_attributes: attribute list;
+    }
+
+and include_description = module_type include_infos
+
+and include_declaration = module_expr include_infos
+
+and with_constraint =
+    Twith_type of type_declaration
+  | Twith_module of Path.t * Longident.t loc
+  | Twith_modtype of module_type
+  | Twith_typesubst of type_declaration
+  | Twith_modsubst of Path.t * Longident.t loc
+  | Twith_modtypesubst of module_type
+
+and core_type =
+  { mutable ctyp_desc : core_type_desc;
+      (** mutable because of [Typeclass.declare_method] *)
+    mutable ctyp_type : Types.type_expr;
+      (** mutable because of [Typeclass.declare_method] *)
+    ctyp_env : Env.t; (* BINANNOT ADDED *)
+    ctyp_loc : Location.t;
+    ctyp_attributes: attributes;
+   }
+
+and core_type_desc =
+    Ttyp_any
+  | Ttyp_var of string
+  | Ttyp_arrow of arg_label * core_type * core_type
+  | Ttyp_tuple of core_type list
+  | Ttyp_constr of Path.t * Longident.t loc * core_type list
+  | Ttyp_object of object_field list * closed_flag
+  | Ttyp_class of Path.t * Longident.t loc * core_type list
+  | Ttyp_alias of core_type * string
+  | Ttyp_variant of row_field list * closed_flag * label list option
+  | Ttyp_poly of string list * core_type
+  | Ttyp_package of package_type
+
+and package_type = {
+  pack_path : Path.t;
+  pack_fields : (Longident.t loc * core_type) list;
+  pack_type : Types.module_type;
+  pack_txt : Longident.t loc;
+}
+
+and row_field = {
+  rf_desc : row_field_desc;
+  rf_loc : Location.t;
+  rf_attributes : attributes;
+}
+
+and row_field_desc =
+    Ttag of string loc * bool * core_type list
+  | Tinherit of core_type
+
+and object_field = {
+  of_desc : object_field_desc;
+  of_loc : Location.t;
+  of_attributes : attributes;
+}
+
+and object_field_desc =
+  | OTtag of string loc * core_type
+  | OTinherit of core_type
+
+and value_description =
+  { val_id: Ident.t;
+    val_name: string loc;
+    val_desc: core_type;
+    val_val: Types.value_description;
+    val_prim: string list;
+    val_loc: Location.t;
+    val_attributes: attributes;
+    }
+
+and type_declaration =
+  {
+    typ_id: Ident.t;
+    typ_name: string loc;
+    typ_params: (core_type * (variance * injectivity)) list;
+    typ_type: Types.type_declaration;
+    typ_cstrs: (core_type * core_type * Location.t) list;
+    typ_kind: type_kind;
+    typ_private: private_flag;
+    typ_manifest: core_type option;
+    typ_loc: Location.t;
+    typ_attributes: attributes;
+   }
+
+and type_kind =
+    Ttype_abstract
+  | Ttype_variant of constructor_declaration list
+  | Ttype_record of label_declaration list
+  | Ttype_open
+
+and label_declaration =
+    {
+     ld_id: Ident.t;
+     ld_name: string loc;
+     ld_mutable: mutable_flag;
+     ld_type: core_type;
+     ld_loc: Location.t;
+     ld_attributes: attributes;
+    }
+
+and constructor_declaration =
+    {
+     cd_id: Ident.t;
+     cd_name: string loc;
+     cd_args: constructor_arguments;
+     cd_res: core_type option;
+     cd_loc: Location.t;
+     cd_attributes: attributes;
+    }
+
+and constructor_arguments =
+  | Cstr_tuple of core_type list
+  | Cstr_record of label_declaration list
+
+and type_extension =
+  {
+    tyext_path: Path.t;
+    tyext_txt: Longident.t loc;
+    tyext_params: (core_type * (variance * injectivity)) list;
+    tyext_constructors: extension_constructor list;
+    tyext_private: private_flag;
+    tyext_loc: Location.t;
+    tyext_attributes: attributes;
+  }
+
+and type_exception =
+  {
+    tyexn_constructor: extension_constructor;
+    tyexn_loc: Location.t;
+    tyexn_attributes: attribute list;
+  }
+
+and extension_constructor =
+  {
+    ext_id: Ident.t;
+    ext_name: string loc;
+    ext_type : Types.extension_constructor;
+    ext_kind : extension_constructor_kind;
+    ext_loc : Location.t;
+    ext_attributes: attributes;
+  }
+
+and extension_constructor_kind =
+    Text_decl of constructor_arguments * core_type option
+  | Text_rebind of Path.t * Longident.t loc
+
+and class_type =
+    {
+     cltyp_desc: class_type_desc;
+     cltyp_type: Types.class_type;
+     cltyp_env: Env.t;
+     cltyp_loc: Location.t;
+     cltyp_attributes: attributes;
+    }
+
+and class_type_desc =
+    Tcty_constr of Path.t * Longident.t loc * core_type list
+  | Tcty_signature of class_signature
+  | Tcty_arrow of arg_label * core_type * class_type
+  | Tcty_open of open_description * class_type
+
+and class_signature = {
+    csig_self : core_type;
+    csig_fields : class_type_field list;
+    csig_type : Types.class_signature;
+  }
+
+and class_type_field = {
+    ctf_desc: class_type_field_desc;
+    ctf_loc: Location.t;
+    ctf_attributes: attributes;
+  }
+
+and class_type_field_desc =
+  | Tctf_inherit of class_type
+  | Tctf_val of (string * mutable_flag * virtual_flag * core_type)
+  | Tctf_method of (string * private_flag * virtual_flag * core_type)
+  | Tctf_constraint of (core_type * core_type)
+  | Tctf_attribute of attribute
+
+and class_declaration =
+  class_expr class_infos
+
+and class_description =
+  class_type class_infos
+
+and class_type_declaration =
+  class_type class_infos
+
+and 'a class_infos =
+  { ci_virt: virtual_flag;
+    ci_params: (core_type * (variance * injectivity)) list;
+    ci_id_name : string loc;
+    ci_id_class: Ident.t;
+    ci_id_class_type : Ident.t;
+    ci_id_object : Ident.t;
+    ci_id_typehash : Ident.t;
+    ci_expr: 'a;
+    ci_decl: Types.class_declaration;
+    ci_type_decl : Types.class_type_declaration;
+    ci_loc: Location.t;
+    ci_attributes: attributes;
+   }
+
+type implementation = {
+  structure: structure;
+  coercion: module_coercion;
+  signature: Types.signature
+}
+(** A typechecked implementation including its module structure, its exported
+    signature, and a coercion of the module against that signature.
+
+    If an .mli file is present, the signature will come from that file and be
+    the exported signature of the module.
+
+    If there isn't one, the signature will be inferred from the module
+    structure.
+*)
+
+(* Auxiliary functions over the a.s.t. *)
+
+(** [as_computation_pattern p] is a computation pattern with description
+    [Tpat_value p], which enforces a correct placement of pat_attributes
+    and pat_extra metadata (on the inner value pattern, rather than on
+    the computation pattern). *)
+val as_computation_pattern: pattern -> computation general_pattern
+
+val classify_pattern_desc: 'k pattern_desc -> 'k pattern_category
+val classify_pattern: 'k general_pattern -> 'k pattern_category
+
+type pattern_action =
+  { f : 'k . 'k general_pattern -> unit }
+val shallow_iter_pattern_desc:
+    pattern_action -> 'k pattern_desc -> unit
+
+type pattern_transformation =
+  { f : 'k . 'k general_pattern -> 'k general_pattern }
+val shallow_map_pattern_desc:
+    pattern_transformation -> 'k pattern_desc -> 'k pattern_desc
+
+val iter_general_pattern: pattern_action -> 'k general_pattern -> unit
+val iter_pattern: (pattern -> unit) -> pattern -> unit
+
+type pattern_predicate = { f : 'k . 'k general_pattern -> bool }
+val exists_general_pattern: pattern_predicate -> 'k general_pattern -> bool
+val exists_pattern: (pattern -> bool) -> pattern -> bool
+
+val let_bound_idents: value_binding list -> Ident.t list
+val let_bound_idents_full:
+    value_binding list -> (Ident.t * string loc * Types.type_expr) list
+
+(** Alpha conversion of patterns *)
+val alpha_pat:
+  (Ident.t * Ident.t) list -> 'k general_pattern -> 'k general_pattern
+
+val mknoloc: 'a -> 'a Asttypes.loc
+val mkloc: 'a -> Location.t -> 'a Asttypes.loc
+
+val pat_bound_idents: 'k general_pattern -> Ident.t list
+val pat_bound_idents_full:
+  'k general_pattern -> (Ident.t * string loc * Types.type_expr) list
+
+(** Splits an or pattern into its value (left) and exception (right) parts. *)
+val split_pattern:
+  computation general_pattern -> pattern option * pattern option
diff --git a/upstream/ocaml_413/typing/typemod.ml b/upstream/ocaml_413/typing/typemod.ml
new file mode 100644
index 0000000..3eecba5
--- /dev/null
+++ b/upstream/ocaml_413/typing/typemod.ml
@@ -0,0 +1,3205 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Misc
+open Longident
+open Path
+open Asttypes
+open Parsetree
+open Types
+open Format
+
+let () = Includemod_errorprinter.register ()
+
+module String = Misc.Stdlib.String
+
+module Sig_component_kind = struct
+  type t =
+    | Value
+    | Type
+    | Module
+    | Module_type
+    | Extension_constructor
+    | Class
+    | Class_type
+
+  let to_string = function
+    | Value -> "value"
+    | Type -> "type"
+    | Module -> "module"
+    | Module_type -> "module type"
+    | Extension_constructor -> "extension constructor"
+    | Class -> "class"
+    | Class_type -> "class type"
+
+  (** Whether the name of a component of that kind can appear in a type. *)
+  let can_appear_in_types = function
+    | Value
+    | Extension_constructor ->
+        false
+    | Type
+    | Module
+    | Module_type
+    | Class
+    | Class_type ->
+        true
+end
+
+type hiding_error =
+  | Illegal_shadowing of {
+      shadowed_item_id: Ident.t;
+      shadowed_item_kind: Sig_component_kind.t;
+      shadowed_item_loc: Location.t;
+      shadower_id: Ident.t;
+      user_id: Ident.t;
+      user_kind: Sig_component_kind.t;
+      user_loc: Location.t;
+    }
+  | Appears_in_signature of {
+      opened_item_id: Ident.t;
+      opened_item_kind: Sig_component_kind.t;
+      user_id: Ident.t;
+      user_kind: Sig_component_kind.t;
+      user_loc: Location.t;
+    }
+
+type error =
+    Cannot_apply of module_type
+  | Not_included of Includemod.explanation
+  | Cannot_eliminate_dependency of module_type
+  | Signature_expected
+  | Structure_expected of module_type
+  | With_no_component of Longident.t
+  | With_mismatch of Longident.t * Includemod.explanation
+  | With_makes_applicative_functor_ill_typed of
+      Longident.t * Path.t * Includemod.explanation
+  | With_changes_module_alias of Longident.t * Ident.t * Path.t
+  | With_cannot_remove_constrained_type
+  | Repeated_name of Sig_component_kind.t * string
+  | Non_generalizable of type_expr
+  | Non_generalizable_class of Ident.t * class_declaration
+  | Non_generalizable_module of module_type
+  | Implementation_is_required of string
+  | Interface_not_compiled of string
+  | Not_allowed_in_functor_body
+  | Not_a_packed_module of type_expr
+  | Incomplete_packed_module of type_expr
+  | Scoping_pack of Longident.t * type_expr
+  | Recursive_module_require_explicit_type
+  | Apply_generative
+  | Cannot_scrape_alias of Path.t
+  | Cannot_scrape_package_type of Path.t
+  | Badly_formed_signature of string * Typedecl.error
+  | Cannot_hide_id of hiding_error
+  | Invalid_type_subst_rhs
+  | Unpackable_local_modtype_subst of Path.t
+  | With_cannot_remove_packed_modtype of Path.t * module_type
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+open Typedtree
+
+let rec path_concat head p =
+  match p with
+    Pident tail -> Pdot (Pident head, Ident.name tail)
+  | Pdot (pre, s) -> Pdot (path_concat head pre, s)
+  | Papply _ -> assert false
+
+(* Extract a signature from a module type *)
+
+let extract_sig env loc mty =
+  match Env.scrape_alias env mty with
+    Mty_signature sg -> sg
+  | Mty_alias path ->
+      raise(Error(loc, env, Cannot_scrape_alias path))
+  | _ -> raise(Error(loc, env, Signature_expected))
+
+let extract_sig_open env loc mty =
+  match Env.scrape_alias env mty with
+    Mty_signature sg -> sg
+  | Mty_alias path ->
+      raise(Error(loc, env, Cannot_scrape_alias path))
+  | mty -> raise(Error(loc, env, Structure_expected mty))
+
+(* Compute the environment after opening a module *)
+
+let type_open_ ?used_slot ?toplevel ovf env loc lid =
+  let path = Env.lookup_module_path ~load:true ~loc:lid.loc lid.txt env in
+  match Env.open_signature ~loc ?used_slot ?toplevel ovf path env with
+  | Ok env -> path, env
+  | Error _ ->
+      let md = Env.find_module path env in
+      ignore (extract_sig_open env lid.loc md.md_type);
+      assert false
+
+let initial_env ~loc ~safe_string ~initially_opened_module
+    ~open_implicit_modules =
+  let env =
+    if safe_string then
+      Env.initial_safe_string
+    else
+      Env.initial_unsafe_string
+  in
+  let open_module env m =
+    let open Asttypes in
+    let lexbuf = Lexing.from_string m in
+    let txt =
+      Location.init lexbuf (Printf.sprintf "command line argument: -open %S" m);
+      Parse.simple_module_path lexbuf in
+        snd (type_open_ Override env loc {txt;loc})
+  in
+  let add_units env units =
+    String.Set.fold
+      (fun name env ->
+         Env.add_persistent_structure (Ident.create_persistent name) env)
+      units
+      env
+  in
+  let units =
+    List.map Env.persistent_structures_of_dir (Load_path.get ())
+  in
+  let env, units =
+    match initially_opened_module with
+    | None -> (env, units)
+    | Some m ->
+        (* Locate the directory that contains [m], adds the units it
+           contains to the environment and open [m] in the resulting
+           environment. *)
+        let rec loop before after =
+          match after with
+          | [] -> None
+          | units :: after ->
+              if String.Set.mem m units then
+                Some (units, List.rev_append before after)
+              else
+                loop (units :: before) after
+        in
+        let env, units =
+          match loop [] units with
+          | None ->
+              (env, units)
+          | Some (units_containing_m, other_units) ->
+              (add_units env units_containing_m, other_units)
+        in
+        (open_module env m, units)
+  in
+  let env = List.fold_left add_units env units in
+  List.fold_left open_module env open_implicit_modules
+
+let type_open_descr ?used_slot ?toplevel env sod =
+  let (path, newenv) =
+    Builtin_attributes.warning_scope sod.popen_attributes
+      (fun () ->
+         type_open_ ?used_slot ?toplevel sod.popen_override env sod.popen_loc
+           sod.popen_expr
+      )
+  in
+  let od =
+    {
+      open_expr = (path, sod.popen_expr);
+      open_bound_items = [];
+      open_override = sod.popen_override;
+      open_env = newenv;
+      open_attributes = sod.popen_attributes;
+      open_loc = sod.popen_loc;
+    }
+  in
+  (od, newenv)
+
+(* Forward declaration, to be filled in by type_module_type_of *)
+let type_module_type_of_fwd :
+    (Env.t -> Parsetree.module_expr ->
+      Typedtree.module_expr * Types.module_type) ref
+  = ref (fun _env _m -> assert false)
+
+(* Additional validity checks on type definitions arising from
+   recursive modules *)
+
+let check_recmod_typedecls env decls =
+  let recmod_ids = List.map fst decls in
+  List.iter
+    (fun (id, md) ->
+      List.iter
+        (fun path ->
+          Typedecl.check_recmod_typedecl env md.Types.md_loc recmod_ids
+                                         path (Env.find_type path env))
+        (Mtype.type_paths env (Pident id) md.Types.md_type))
+    decls
+
+(* Merge one "with" constraint in a signature *)
+
+let check_type_decl env loc id row_id newdecl decl rec_group =
+  let env = Env.add_type ~check:true id newdecl env in
+  let env =
+    match row_id with
+    | None -> env
+    | Some id -> Env.add_type ~check:false id newdecl env
+  in
+  let env =
+    let add_sigitem env x =
+      Env.add_signature Signature_group.(x.src :: x.post_ghosts) env
+    in
+    List.fold_left add_sigitem env rec_group in
+  Includemod.type_declarations ~mark:Mark_both ~loc env id newdecl decl;
+  Typedecl.check_coherence env loc (Path.Pident id) newdecl
+
+let make_variance p n i =
+  let open Variance in
+  set May_pos p (set May_neg n (set May_weak n (set Inj i null)))
+
+let rec iter_path_apply p ~f =
+  match p with
+  | Pident _ -> ()
+  | Pdot (p, _) -> iter_path_apply p ~f
+  | Papply (p1, p2) ->
+     iter_path_apply p1 ~f;
+     iter_path_apply p2 ~f;
+     f p1 p2 (* after recursing, so we know both paths are well typed *)
+
+let path_is_strict_prefix =
+  let rec list_is_strict_prefix l ~prefix =
+    match l, prefix with
+    | [], [] -> false
+    | _ :: _, [] -> true
+    | [], _ :: _ -> false
+    | s1 :: t1, s2 :: t2 ->
+       String.equal s1 s2 && list_is_strict_prefix t1 ~prefix:t2
+  in
+  fun path ~prefix ->
+    match Path.flatten path, Path.flatten prefix with
+    | `Contains_apply, _ | _, `Contains_apply -> false
+    | `Ok (ident1, l1), `Ok (ident2, l2) ->
+       Ident.same ident1 ident2
+       && list_is_strict_prefix l1 ~prefix:l2
+
+let iterator_with_env env =
+  let env = ref (lazy env) in
+  let super = Btype.type_iterators in
+  env, { super with
+    Btype.it_signature = (fun self sg ->
+      (* add all items to the env before recursing down, to handle recursive
+         definitions *)
+      let env_before = !env in
+      env := lazy (Env.add_signature sg (Lazy.force env_before));
+      super.Btype.it_signature self sg;
+      env := env_before
+    );
+    Btype.it_module_type = (fun self -> function
+    | Mty_functor (param, mty_body) ->
+      let env_before = !env in
+      begin match param with
+      | Unit -> ()
+      | Named (param, mty_arg) ->
+        self.Btype.it_module_type self mty_arg;
+        match param with
+        | None -> ()
+        | Some id ->
+          env := lazy (Env.add_module ~arg:true id Mp_present
+                       mty_arg (Lazy.force env_before))
+      end;
+      self.Btype.it_module_type self mty_body;
+      env := env_before;
+    | mty ->
+      super.Btype.it_module_type self mty
+    )
+  }
+
+let retype_applicative_functor_type ~loc env funct arg =
+  let mty_functor = (Env.find_module funct env).md_type in
+  let mty_arg = (Env.find_module arg env).md_type in
+  let mty_param =
+    match Env.scrape_alias env mty_functor with
+    | Mty_functor (Named (_, mty_param), _) -> mty_param
+    | _ -> assert false (* could trigger due to MPR#7611 *)
+  in
+  Includemod.check_modtype_inclusion ~loc env mty_arg arg mty_param
+
+(* When doing a deep destructive substitution with type M.N.t := .., we change M
+   and M.N and so we have to check that uses of the modules other than just
+   extracting components from them still make sense. There are only two such
+   kinds of uses:
+   - applicative functor types: F(M).t might not be well typed anymore
+   - aliases: module A = M still makes sense but it doesn't mean the same thing
+     anymore, so it's forbidden until it's clear what we should do with it.
+   This function would be called with M.N.t and N.t to check for these uses. *)
+let check_usage_of_path_of_substituted_item paths ~loc ~lid env super =
+    { super with
+      Btype.it_signature_item = (fun self -> function
+      | Sig_module (id, _, { md_type = Mty_alias aliased_path; _ }, _, _)
+        when List.exists
+               (fun path -> path_is_strict_prefix path ~prefix:aliased_path)
+               paths
+        ->
+         let e = With_changes_module_alias (lid.txt, id, aliased_path) in
+         raise(Error(loc, Lazy.force !env, e))
+      | sig_item ->
+         super.Btype.it_signature_item self sig_item
+      );
+      Btype.it_path = (fun referenced_path ->
+        iter_path_apply referenced_path ~f:(fun funct arg ->
+          if List.exists
+               (fun path -> path_is_strict_prefix path ~prefix:arg)
+               paths
+          then
+            let env = Lazy.force !env in
+            match retype_applicative_functor_type ~loc env funct arg with
+            | None -> ()
+            | Some explanation ->
+                raise(Error(loc, env,
+                            With_makes_applicative_functor_ill_typed
+                            (lid.txt, referenced_path, explanation)))
+        )
+      );
+    }
+
+(* When doing a module type destructive substitution [with module type T = RHS]
+   where RHS is not a module type path, we need to check that the module type
+   T was not used as a path for a packed module
+*)
+let check_usage_of_module_types ~error ~paths ~loc env super =
+  let it_do_type_expr it ty = match ty.desc with
+    | Tpackage (p, _) ->
+       begin match List.find_opt (Path.same p) paths with
+       | Some p -> raise (Error(loc,Lazy.force !env,error p))
+       | _ -> super.Btype.it_do_type_expr it ty
+       end
+    | _ -> super.Btype.it_do_type_expr it ty in
+  { super with Btype.it_do_type_expr }
+
+let do_check_after_substitution env ~loc ~lid paths unpackable_modtype sg =
+  let env, iterator = iterator_with_env env in
+  let last, rest = match List.rev paths with
+    | [] -> assert false
+    | last :: rest -> last, rest
+  in
+  (* The last item is the one that's removed. We don't need to check how
+        it's used since it's replaced by a more specific type/module. *)
+  assert (match last with Pident _ -> true | _ -> false);
+  let iterator = match rest with
+    | [] -> iterator
+    | _ :: _ ->
+        check_usage_of_path_of_substituted_item rest ~loc ~lid env iterator
+  in
+  let iterator = match unpackable_modtype with
+    | None -> iterator
+    | Some mty ->
+       let error p = With_cannot_remove_packed_modtype(p,mty) in
+       check_usage_of_module_types ~error ~paths ~loc env iterator
+  in
+  iterator.Btype.it_signature iterator sg;
+  Btype.(unmark_iterators.it_signature unmark_iterators) sg
+
+let check_usage_after_substitution env ~loc ~lid paths unpackable_modtype sg =
+  match paths, unpackable_modtype with
+  | [_], None -> ()
+  | _ -> do_check_after_substitution env ~loc ~lid paths unpackable_modtype sg
+
+(* After substitution one also needs to re-check the well-foundedness
+   of type declarations in recursive modules *)
+let rec extract_next_modules = function
+  | Sig_module (id, _, mty, Trec_next, _) :: rem ->
+      let (id_mty_l, rem) = extract_next_modules rem in
+      ((id, mty) :: id_mty_l, rem)
+  | sg -> ([], sg)
+
+let check_well_formed_module env loc context mty =
+  (* Format.eprintf "@[check_well_formed_module@ %a@]@."
+     Printtyp.modtype mty; *)
+  let open Btype in
+  let iterator =
+    let rec check_signature env = function
+      | [] -> ()
+      | Sig_module (id, _, mty, Trec_first, _) :: rem ->
+          let (id_mty_l, rem) = extract_next_modules rem in
+          begin try
+            check_recmod_typedecls (Lazy.force env) ((id, mty) :: id_mty_l)
+          with Typedecl.Error (_, err) ->
+            raise (Error (loc, Lazy.force env,
+                          Badly_formed_signature(context, err)))
+          end;
+          check_signature env rem
+      | _ :: rem ->
+          check_signature env rem
+    in
+    let env, super = iterator_with_env env in
+    { super with
+      it_type_expr = (fun _self _ty -> ());
+      it_signature = (fun self sg ->
+        let env_before = !env in
+        let env = lazy (Env.add_signature sg (Lazy.force env_before)) in
+        check_signature env sg;
+        super.it_signature self sg);
+    }
+  in
+  iterator.it_module_type iterator mty
+
+let () = Env.check_well_formed_module := check_well_formed_module
+
+let type_decl_is_alias sdecl = (* assuming no explicit constraint *)
+  match sdecl.ptype_manifest with
+  | Some {ptyp_desc = Ptyp_constr (lid, stl)}
+       when List.length stl = List.length sdecl.ptype_params ->
+     begin
+       match
+         List.iter2 (fun x (y, _) ->
+             match x, y with
+               {ptyp_desc=Ptyp_var sx}, {ptyp_desc=Ptyp_var sy}
+                  when sx = sy -> ()
+             | _, _ -> raise Exit)
+           stl sdecl.ptype_params;
+       with
+       | exception Exit -> None
+       | () -> Some lid
+     end
+  | _ -> None
+;;
+
+let params_are_constrained =
+  let rec loop = function
+    | [] -> false
+    | hd :: tl ->
+       match (Btype.repr hd).desc with
+       | Tvar _ -> List.memq hd tl || loop tl
+       | _ -> true
+  in
+  loop
+;;
+
+type with_info =
+  | With_type of Parsetree.type_declaration
+  | With_typesubst of Parsetree.type_declaration
+  | With_module of {
+        lid:Longident.t loc;
+        path:Path.t;
+        md:Types.module_declaration;
+        remove_aliases:bool
+      }
+  | With_modsubst of Longident.t loc * Path.t * Types.module_declaration
+  | With_modtype of Typedtree.module_type
+  | With_modtypesubst of Typedtree.module_type
+
+let merge_constraint initial_env loc sg lid constr =
+  let destructive_substitution =
+    match constr with
+    | With_type _ | With_module _ | With_modtype _ -> false
+    | With_typesubst _ | With_modsubst _ | With_modtypesubst _  -> true
+  in
+  let real_ids = ref [] in
+  let unpackable_modtype = ref None in
+  let split_row_id s ghosts =
+    let srow = s ^ "#row" in
+    let rec split before = function
+        | Sig_type(id,_,_,_) :: rest when Ident.name id = srow ->
+            before, Some id, rest
+        | a :: rest -> split (a::before) rest
+        | [] -> before, None, []
+    in
+    split [] ghosts
+  in
+  let rec patch_item constr namelist sig_env ~rec_group ~ghosts item =
+    let return ?(ghosts=ghosts) ~replace_by info =
+      Some (info, {Signature_group.ghosts; replace_by})
+    in
+    match item, namelist, constr with
+    | Sig_type(id, decl, rs, priv), [s],
+       With_type ({ptype_kind = Ptype_abstract} as sdecl)
+      when Ident.name id = s && Typedecl.is_fixed_type sdecl ->
+        let decl_row =
+          let arity = List.length sdecl.ptype_params in
+          {
+            type_params =
+              List.map (fun _ -> Btype.newgenvar()) sdecl.ptype_params;
+            type_arity = arity;
+            type_kind = Type_abstract;
+            type_private = Private;
+            type_manifest = None;
+            type_variance =
+              List.map
+                (fun (_, (v, i)) ->
+                   let (c, n) =
+                     match v with
+                     | Covariant -> true, false
+                     | Contravariant -> false, true
+                     | NoVariance -> false, false
+                   in
+                   make_variance (not n) (not c) (i = Injective)
+                )
+                sdecl.ptype_params;
+            type_separability =
+              Types.Separability.default_signature ~arity;
+            type_loc = sdecl.ptype_loc;
+            type_is_newtype = false;
+            type_expansion_scope = Btype.lowest_level;
+            type_attributes = [];
+            type_immediate = Unknown;
+            type_unboxed_default = false;
+            type_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+          }
+        and id_row = Ident.create_local (s^"#row") in
+        let initial_env =
+          Env.add_type ~check:false id_row decl_row initial_env
+        in
+        let tdecl =
+          Typedecl.transl_with_constraint id ~fixed_row_path:(Pident id_row)
+            ~sig_env ~sig_decl:decl ~outer_env:initial_env sdecl in
+        let newdecl = tdecl.typ_type in
+        let before_ghosts, row_id, after_ghosts = split_row_id s ghosts in
+        check_type_decl sig_env sdecl.ptype_loc id row_id newdecl decl
+          rec_group;
+        let decl_row = {decl_row with type_params = newdecl.type_params} in
+        let rs' = if rs = Trec_first then Trec_not else rs in
+        let ghosts =
+          List.rev_append before_ghosts
+            (Sig_type(id_row, decl_row, rs', priv)::after_ghosts)
+        in
+        return ~ghosts
+          ~replace_by:(Some (Sig_type(id, newdecl, rs, priv)))
+          (Pident id, lid, Twith_type tdecl)
+    | Sig_type(id, sig_decl, rs, priv) , [s],
+       (With_type sdecl | With_typesubst sdecl as constr)
+      when Ident.name id = s ->
+        let tdecl =
+          Typedecl.transl_with_constraint id
+            ~sig_env ~sig_decl ~outer_env:initial_env sdecl in
+        let newdecl = tdecl.typ_type and loc = sdecl.ptype_loc in
+        let before_ghosts, row_id, after_ghosts = split_row_id s ghosts in
+        let ghosts = List.rev_append before_ghosts after_ghosts in
+        check_type_decl sig_env loc id row_id newdecl sig_decl rec_group;
+        begin match constr with
+          With_type _ ->
+            return ~ghosts
+              ~replace_by:(Some(Sig_type(id, newdecl, rs, priv)))
+              (Pident id, lid, Twith_type tdecl)
+        | (* With_typesubst *) _ ->
+            real_ids := [Pident id];
+            return ~ghosts ~replace_by:None
+              (Pident id, lid, Twith_typesubst tdecl)
+        end
+    | Sig_modtype(id, mtd, priv), [s],
+      (With_modtype mty | With_modtypesubst mty)
+      when Ident.name id = s ->
+        let () = match mtd.mtd_type with
+          | None -> ()
+          | Some previous_mty ->
+              Includemod.check_modtype_equiv ~loc sig_env
+                id previous_mty mty.mty_type
+        in
+        if not destructive_substitution then
+          let mtd': modtype_declaration =
+            {
+              mtd_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+              mtd_type = Some mty.mty_type;
+              mtd_attributes = [];
+              mtd_loc = loc;
+            }
+          in
+          return
+            ~replace_by:(Some(Sig_modtype(id, mtd', priv)))
+            (Pident id, lid, Twith_modtype mty)
+        else begin
+          let path = Pident id in
+          real_ids := [path];
+          begin match mty.mty_type with
+          | Mty_ident _ -> ()
+          | mty -> unpackable_modtype := Some mty
+          end;
+          return ~replace_by:None (Pident id, lid, Twith_modtypesubst mty)
+        end
+    | Sig_module(id, pres, md, rs, priv), [s],
+      With_module {lid=lid'; md=md'; path; remove_aliases}
+      when Ident.name id = s ->
+        let mty = md'.md_type in
+        let mty = Mtype.scrape_for_type_of ~remove_aliases sig_env mty in
+        let md'' = { md' with md_type = mty } in
+        let newmd = Mtype.strengthen_decl ~aliasable:false sig_env md'' path in
+        ignore(Includemod.modtypes  ~mark:Mark_both ~loc sig_env
+                 newmd.md_type md.md_type);
+        return
+          ~replace_by:(Some(Sig_module(id, pres, newmd, rs, priv)))
+          (Pident id, lid, Twith_module (path, lid'))
+    | Sig_module(id, _, md, _rs, _), [s], With_modsubst (lid',path,md')
+      when Ident.name id = s ->
+        let aliasable = not (Env.is_functor_arg path sig_env) in
+        ignore
+          (Includemod.strengthened_module_decl ~loc ~mark:Mark_both
+             ~aliasable sig_env md' path md);
+        real_ids := [Pident id];
+        return ~replace_by:None (Pident id, lid, Twith_modsubst (path, lid'))
+    | Sig_module(id, _, md, rs, priv) as item, s :: namelist, constr
+      when Ident.name id = s ->
+        let sg = extract_sig sig_env loc md.md_type in
+        let ((path, _, tcstr), newsg) = merge_signature sig_env sg namelist in
+        let path = path_concat id path in
+        real_ids := path :: !real_ids;
+        let item =
+          match md.md_type, constr with
+            Mty_alias _, (With_module _ | With_type _) ->
+              (* A module alias cannot be refined, so keep it
+                 and just check that the constraint is correct *)
+              item
+          | _ ->
+              let newmd = {md with md_type = Mty_signature newsg} in
+              Sig_module(id, Mp_present, newmd, rs, priv)
+        in
+        return ~replace_by:(Some item) (path, lid, tcstr)
+    | _ -> None
+  and merge_signature env sg namelist =
+    let sig_env = Env.add_signature sg env in
+    match
+      Signature_group.replace_in_place (patch_item constr namelist sig_env) sg
+    with
+    | Some (x,sg) -> x, sg
+    | None -> raise(Error(loc, sig_env, With_no_component lid.txt))
+  in
+  try
+    let names = Longident.flatten lid.txt in
+    let (tcstr, sg) = merge_signature initial_env sg names in
+    if destructive_substitution then
+      check_usage_after_substitution ~loc ~lid initial_env !real_ids
+        !unpackable_modtype sg;
+    let sg =
+    match tcstr with
+    | (_, _, Twith_typesubst tdecl) ->
+       let how_to_extend_subst =
+         let sdecl =
+           match constr with
+           | With_typesubst sdecl -> sdecl
+           | _ -> assert false
+         in
+         match type_decl_is_alias sdecl with
+         | Some lid ->
+            let replacement, _ =
+              try Env.find_type_by_name lid.txt initial_env
+              with Not_found -> assert false
+            in
+            fun s path -> Subst.add_type_path path replacement s
+         | None ->
+            let body = Option.get tdecl.typ_type.type_manifest in
+            let params = tdecl.typ_type.type_params in
+            if params_are_constrained params
+            then raise(Error(loc, initial_env,
+                             With_cannot_remove_constrained_type));
+            fun s path -> Subst.add_type_function path ~params ~body s
+       in
+       let sub = Subst.change_locs Subst.identity loc in
+       let sub = List.fold_left how_to_extend_subst sub !real_ids in
+       (* This signature will not be used directly, it will always be freshened
+          by the caller. So what we do with the scope doesn't really matter. But
+          making it local makes it unlikely that we will ever use the result of
+          this function unfreshened without issue. *)
+       Subst.signature Make_local sub sg
+    | (_, _, Twith_modsubst (real_path, _)) ->
+       let sub = Subst.change_locs Subst.identity loc in
+       let sub =
+         List.fold_left
+           (fun s path -> Subst.add_module_path path real_path s)
+           sub
+           !real_ids
+       in
+       (* See explanation in the [Twith_typesubst] case above. *)
+       Subst.signature Make_local sub sg
+    | (_, _, Twith_modtypesubst tmty) ->
+        let add s p = Subst.add_modtype_path p tmty.mty_type s in
+        let sub = Subst.change_locs Subst.identity loc in
+        let sub = List.fold_left add sub !real_ids in
+        Subst.signature Make_local sub sg
+    | _ ->
+       sg
+    in
+    check_well_formed_module initial_env loc "this instantiated signature"
+      (Mty_signature sg);
+    (tcstr, sg)
+  with Includemod.Error explanation ->
+    raise(Error(loc, initial_env, With_mismatch(lid.txt, explanation)))
+
+(* Add recursion flags on declarations arising from a mutually recursive
+   block. *)
+
+let map_rec fn decls rem =
+  match decls with
+  | [] -> rem
+  | d1 :: dl -> fn Trec_first d1 :: map_end (fn Trec_next) dl rem
+
+let map_rec_type ~rec_flag fn decls rem =
+  match decls with
+  | [] -> rem
+  | d1 :: dl ->
+      let first =
+        match rec_flag with
+        | Recursive -> Trec_first
+        | Nonrecursive -> Trec_not
+      in
+      fn first d1 :: map_end (fn Trec_next) dl rem
+
+let rec map_rec_type_with_row_types ~rec_flag fn decls rem =
+  match decls with
+  | [] -> rem
+  | d1 :: dl ->
+      if Btype.is_row_name (Ident.name d1.typ_id) then
+        fn Trec_not d1 :: map_rec_type_with_row_types ~rec_flag fn dl rem
+      else
+        map_rec_type ~rec_flag fn decls rem
+
+(* Add type extension flags to extension constructors *)
+let map_ext fn exts rem =
+  match exts with
+  | [] -> rem
+  | d1 :: dl -> fn Text_first d1 :: map_end (fn Text_next) dl rem
+
+(* Auxiliary for translating recursively-defined module types.
+   Return a module type that approximates the shape of the given module
+   type AST.  Retain only module, type, and module type
+   components of signatures.  For types, retain only their arity,
+   making them abstract otherwise. *)
+
+let rec approx_modtype env smty =
+  match smty.pmty_desc with
+    Pmty_ident lid ->
+      let (path, _info) =
+        Env.lookup_modtype ~use:false ~loc:smty.pmty_loc lid.txt env
+      in
+      Mty_ident path
+  | Pmty_alias lid ->
+      let path =
+        Env.lookup_module_path ~use:false ~load:false
+          ~loc:smty.pmty_loc lid.txt env
+      in
+      Mty_alias(path)
+  | Pmty_signature ssg ->
+      Mty_signature(approx_sig env ssg)
+  | Pmty_functor(param, sres) ->
+      let (param, newenv) =
+        match param with
+        | Unit -> Types.Unit, env
+        | Named (param, sarg) ->
+          let arg = approx_modtype env sarg in
+          match param.txt with
+          | None -> Types.Named (None, arg), env
+          | Some name ->
+            let rarg = Mtype.scrape_for_functor_arg env arg in
+            let scope = Ctype.create_scope () in
+            let (id, newenv) =
+              Env.enter_module ~scope ~arg:true name Mp_present rarg env
+            in
+            Types.Named (Some id, arg), newenv
+      in
+      let res = approx_modtype newenv sres in
+      Mty_functor(param, res)
+  | Pmty_with(sbody, constraints) ->
+      let body = approx_modtype env sbody in
+      List.iter
+        (fun sdecl ->
+          match sdecl with
+          | Pwith_type _
+          | Pwith_typesubst _
+          | Pwith_modtype _
+          | Pwith_modtypesubst _  -> ()
+          | Pwith_module (_, lid') ->
+              (* Lookup the module to make sure that it is not recursive.
+                 (GPR#1626) *)
+              ignore (Env.lookup_module ~use:false ~loc:lid'.loc lid'.txt env)
+          | Pwith_modsubst (_, lid') ->
+              ignore (Env.lookup_module ~use:false ~loc:lid'.loc lid'.txt env))
+        constraints;
+      body
+  | Pmty_typeof smod ->
+      let (_, mty) = !type_module_type_of_fwd env smod in
+      mty
+  | Pmty_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and approx_module_declaration env pmd =
+  {
+    Types.md_type = approx_modtype env pmd.pmd_type;
+    md_attributes = pmd.pmd_attributes;
+    md_loc = pmd.pmd_loc;
+    md_uid = Uid.internal_not_actually_unique;
+  }
+
+and approx_sig env ssg =
+  match ssg with
+    [] -> []
+  | item :: srem ->
+      match item.psig_desc with
+      | Psig_type (rec_flag, sdecls) ->
+          let decls = Typedecl.approx_type_decl sdecls in
+          let rem = approx_sig env srem in
+          map_rec_type ~rec_flag
+            (fun rs (id, info) -> Sig_type(id, info, rs, Exported)) decls rem
+      | Psig_typesubst _ -> approx_sig env srem
+      | Psig_module { pmd_name = { txt = None; _ }; _ } ->
+          approx_sig env srem
+      | Psig_module pmd ->
+          let scope = Ctype.create_scope () in
+          let md = approx_module_declaration env pmd in
+          let pres =
+            match md.Types.md_type with
+            | Mty_alias _ -> Mp_absent
+            | _ -> Mp_present
+          in
+          let id, newenv =
+            Env.enter_module_declaration ~scope (Option.get pmd.pmd_name.txt)
+              pres md env
+          in
+          Sig_module(id, pres, md, Trec_not, Exported) :: approx_sig newenv srem
+      | Psig_modsubst pms ->
+          let scope = Ctype.create_scope () in
+          let _, md =
+            Env.lookup_module ~use:false ~loc:pms.pms_manifest.loc
+               pms.pms_manifest.txt env
+          in
+          let pres =
+            match md.Types.md_type with
+            | Mty_alias _ -> Mp_absent
+            | _ -> Mp_present
+          in
+          let _, newenv =
+            Env.enter_module_declaration ~scope pms.pms_name.txt pres md env
+          in
+          approx_sig newenv srem
+      | Psig_recmodule sdecls ->
+          let scope = Ctype.create_scope () in
+          let decls =
+            List.filter_map
+              (fun pmd ->
+                 Option.map (fun name ->
+                   Ident.create_scoped ~scope name,
+                   approx_module_declaration env pmd
+                 ) pmd.pmd_name.txt
+              )
+              sdecls
+          in
+          let newenv =
+            List.fold_left
+              (fun env (id, md) -> Env.add_module_declaration ~check:false
+                  id Mp_present md env)
+              env decls
+          in
+          map_rec
+            (fun rs (id, md) -> Sig_module(id, Mp_present, md, rs, Exported))
+            decls
+            (approx_sig newenv srem)
+      | Psig_modtype d ->
+          let info = approx_modtype_info env d in
+          let scope = Ctype.create_scope () in
+          let (id, newenv) =
+            Env.enter_modtype ~scope d.pmtd_name.txt info env
+          in
+          Sig_modtype(id, info, Exported) :: approx_sig newenv srem
+      | Psig_modtypesubst d ->
+          let info = approx_modtype_info env d in
+          let scope = Ctype.create_scope () in
+          let (_id, newenv) =
+            Env.enter_modtype ~scope d.pmtd_name.txt info env
+          in
+          approx_sig newenv srem
+      | Psig_open sod ->
+          let _, env = type_open_descr env sod in
+          approx_sig env srem
+      | Psig_include sincl ->
+          let smty = sincl.pincl_mod in
+          let mty = approx_modtype env smty in
+          let scope = Ctype.create_scope () in
+          let sg, newenv = Env.enter_signature ~scope
+              (extract_sig env smty.pmty_loc mty) env in
+          sg @ approx_sig newenv srem
+      | Psig_class sdecls | Psig_class_type sdecls ->
+          let decls = Typeclass.approx_class_declarations env sdecls in
+          let rem = approx_sig env srem in
+          map_rec (fun rs decl ->
+            let open Typeclass in [
+              Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs,
+                             Exported);
+              Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs, Exported);
+              Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs, Exported);
+            ]
+          ) decls [rem]
+          |> List.flatten
+      | _ ->
+          approx_sig env srem
+
+and approx_modtype_info env sinfo =
+  {
+   mtd_type = Option.map (approx_modtype env) sinfo.pmtd_type;
+   mtd_attributes = sinfo.pmtd_attributes;
+   mtd_loc = sinfo.pmtd_loc;
+   mtd_uid = Uid.internal_not_actually_unique;
+  }
+
+let approx_modtype env smty =
+  Warnings.without_warnings
+    (fun () -> approx_modtype env smty)
+
+(* Auxiliaries for checking the validity of name shadowing in signatures and
+   structures.
+   If a shadowing is valid, we also record some information (its ident,
+   location where it first appears, etc) about the item that gets shadowed. *)
+module Signature_names : sig
+  type t
+
+ type shadowable =
+    {
+      self: Ident.t;
+      group: Ident.t list;
+      (** group includes the element itself and all elements
+                that should be removed at the same time
+      *)
+      loc:Location.t;
+    }
+
+  type info = [
+    | `Exported
+    | `From_open
+    | `Shadowable of shadowable
+    | `Substituted_away of Subst.t
+    | `Unpackable_modtype_substituted_away of Ident.t * Subst.t
+  ]
+
+  val create : unit -> t
+
+  val check_value     : ?info:info -> t -> Location.t -> Ident.t -> unit
+  val check_type      : ?info:info -> t -> Location.t -> Ident.t -> unit
+  val check_typext    : ?info:info -> t -> Location.t -> Ident.t -> unit
+  val check_module    : ?info:info -> t -> Location.t -> Ident.t -> unit
+  val check_modtype   : ?info:info -> t -> Location.t -> Ident.t -> unit
+  val check_class     : ?info:info -> t -> Location.t -> Ident.t -> unit
+  val check_class_type: ?info:info -> t -> Location.t -> Ident.t -> unit
+
+  val check_sig_item:
+    ?info:info -> t -> Location.t -> Signature_group.rec_group -> unit
+
+  val simplify: Env.t -> t -> Types.signature -> Types.signature
+end = struct
+
+  type shadowable =
+    {
+      self: Ident.t;
+      group: Ident.t list;
+      (** group includes the element itself and all elements
+                that should be removed at the same time
+      *)
+      loc:Location.t;
+    }
+
+  type bound_info = [
+    | `Exported
+    | `Shadowable of shadowable
+  ]
+
+  type info = [
+    | `From_open
+    | `Substituted_away of Subst.t
+    | `Unpackable_modtype_substituted_away of Ident.t * Subst.t
+    | bound_info
+  ]
+
+  type hide_reason =
+    | From_open
+    | Shadowed_by of Ident.t * Location.t
+
+  type to_be_removed = {
+    mutable subst: Subst.t;
+    mutable hide: (Sig_component_kind.t * Location.t * hide_reason) Ident.Map.t;
+    mutable unpackable_modtypes: Ident.Set.t;
+  }
+
+  type names_infos = (string, bound_info) Hashtbl.t
+
+  type names = {
+    values: names_infos;
+    types: names_infos;
+    modules: names_infos;
+    modtypes: names_infos;
+    typexts: names_infos;
+    classes: names_infos;
+    class_types: names_infos;
+  }
+
+  let new_names () = {
+    values = Hashtbl.create 16;
+    types = Hashtbl.create 16;
+    modules = Hashtbl.create 16;
+    modtypes = Hashtbl.create 16;
+    typexts = Hashtbl.create 16;
+    classes = Hashtbl.create 16;
+    class_types = Hashtbl.create 16;
+  }
+
+  type t = {
+    bound: names;
+    to_be_removed: to_be_removed;
+  }
+
+  let create () = {
+    bound = new_names ();
+    to_be_removed = {
+      subst = Subst.identity;
+      hide = Ident.Map.empty;
+      unpackable_modtypes = Ident.Set.empty;
+    };
+  }
+
+  let table_for component names =
+    let open Sig_component_kind in
+    match component with
+    | Value -> names.values
+    | Type -> names.types
+    | Module -> names.modules
+    | Module_type -> names.modtypes
+    | Extension_constructor -> names.typexts
+    | Class -> names.classes
+    | Class_type -> names.class_types
+
+  let check cl t loc id (info : info) =
+    let to_be_removed = t.to_be_removed in
+    match info with
+    | `Substituted_away s ->
+        to_be_removed.subst <- Subst.compose s to_be_removed.subst;
+    | `Unpackable_modtype_substituted_away (id,s) ->
+        to_be_removed.subst <- Subst.compose s to_be_removed.subst;
+        to_be_removed.unpackable_modtypes <-
+          Ident.Set.add id to_be_removed.unpackable_modtypes
+    | `From_open ->
+        to_be_removed.hide <-
+          Ident.Map.add id (cl, loc, From_open) to_be_removed.hide
+    | #bound_info as bound_info ->
+        let tbl = table_for cl t.bound in
+        let name = Ident.name id in
+        match Hashtbl.find_opt tbl name with
+        | None -> Hashtbl.add tbl name bound_info
+        | Some (`Shadowable s) ->
+            Hashtbl.replace tbl name bound_info;
+            let reason = Shadowed_by (id, loc) in
+            List.iter (fun shadowed_id ->
+            to_be_removed.hide <-
+              Ident.Map.add shadowed_id (cl, s.loc, reason)
+                to_be_removed.hide
+              ) s.group
+        | Some `Exported ->
+            raise(Error(loc, Env.empty, Repeated_name(cl, name)))
+
+  let check_value ?info t loc id =
+    let info =
+      match info with
+      | Some i -> i
+      | None -> `Shadowable {self=id; group=[id]; loc}
+    in
+    check Sig_component_kind.Value t loc id info
+  let check_type ?(info=`Exported) t loc id =
+    check Sig_component_kind.Type t loc id info
+  let check_module ?(info=`Exported) t loc id =
+    check Sig_component_kind.Module t loc id info
+  let check_modtype ?(info=`Exported) t loc id =
+    check Sig_component_kind.Module_type t loc id info
+  let check_typext ?(info=`Exported) t loc id =
+    check Sig_component_kind.Extension_constructor t loc id info
+  let check_class ?(info=`Exported) t loc id =
+    check Sig_component_kind.Class t loc id info
+  let check_class_type ?(info=`Exported) t loc id =
+    check Sig_component_kind.Class_type t loc id info
+
+  let classify =
+    let open Sig_component_kind in
+    function
+    | Sig_type(id, _, _, _) -> Type, id
+    | Sig_module(id, _, _, _, _) -> Module, id
+    | Sig_modtype(id, _, _) -> Module_type, id
+    | Sig_typext(id, _, _, _) -> Extension_constructor, id
+    | Sig_value (id, _, _) -> Value, id
+    | Sig_class (id, _, _, _) -> Class, id
+    | Sig_class_type (id, _, _, _) -> Class_type, id
+
+  let check_item ?info names loc kind id ids =
+    let info =
+      match info with
+      | None -> `Shadowable {self=id; group=ids; loc}
+      | Some i -> i
+    in
+    check kind names loc id info
+
+  let check_sig_item ?info names loc (item:Signature_group.rec_group) =
+    let check ?info names loc item =
+      let all = List.map classify (Signature_group.flatten item) in
+      let group = List.map snd all in
+      List.iter (fun (kind,id) -> check_item ?info names loc kind id group)
+        all
+    in
+    (* we can ignore x.pre_ghosts: they are eliminated by strengthening, and
+       thus never appear in includes *)
+     List.iter (check ?info names loc) (Signature_group.rec_items item.group)
+
+  (*
+    Before applying local module type substitutions where the
+    right-hand side is not a path, we need to check that those module types
+    where never used to pack modules. For instance
+    {[
+    module type T := sig end
+    val x: (module T)
+    ]}
+    should raise an error.
+  *)
+  let check_unpackable_modtypes ~loc ~env to_remove component =
+    if not (Ident.Set.is_empty to_remove.unpackable_modtypes) then begin
+      let iterator =
+        let error p = Unpackable_local_modtype_subst p in
+        let paths =
+          List.map (fun id -> Pident id)
+            (Ident.Set.elements to_remove.unpackable_modtypes)
+        in
+        check_usage_of_module_types ~loc ~error ~paths
+          (ref (lazy env)) Btype.type_iterators
+      in
+      iterator.Btype.it_signature_item iterator component;
+      Btype.(unmark_iterators.it_signature_item unmark_iterators) component
+    end
+
+  (* We usually require name uniqueness of signature components (e.g. types,
+     modules, etc), however in some situation reusing the name is allowed: if
+     the component is a value or an extension, or if the name is introduced by
+     an include.
+     When there are multiple specifications of a component with the same name,
+     we try to keep only the last (rightmost) one, removing all references to
+     the previous ones from the signature.
+     If some reference cannot be removed, then we error out with
+     [Cannot_hide_id].
+  *)
+
+  let simplify env t sg =
+    let to_remove = t.to_be_removed in
+    let ids_to_remove =
+      Ident.Map.fold (fun id (kind,  _, _) lst ->
+        if Sig_component_kind.can_appear_in_types kind then
+          id :: lst
+        else
+          lst
+      ) to_remove.hide []
+    in
+    let simplify_item (component: Types.signature_item) =
+      let user_kind, user_id, user_loc =
+        let open Sig_component_kind in
+        match component with
+        | Sig_value(id, v, _) -> Value, id, v.val_loc
+        | Sig_type (id, td, _, _) -> Type, id, td.type_loc
+        | Sig_typext (id, te, _, _) -> Extension_constructor, id, te.ext_loc
+        | Sig_module (id, _, md, _, _) -> Module, id, md.md_loc
+        | Sig_modtype (id, mtd, _) -> Module_type, id, mtd.mtd_loc
+        | Sig_class (id, c, _, _) -> Class, id, c.cty_loc
+        | Sig_class_type (id, ct, _, _) -> Class_type, id, ct.clty_loc
+      in
+      if Ident.Map.mem user_id to_remove.hide then
+        None
+      else begin
+        let component =
+          if to_remove.subst == Subst.identity then
+            component
+          else
+            begin
+              check_unpackable_modtypes ~loc:user_loc ~env to_remove component;
+              Subst.signature_item Keep to_remove.subst component
+            end
+        in
+        let component =
+          match ids_to_remove with
+          | [] -> component
+          | ids ->
+            try Mtype.nondep_sig_item env ids component with
+            | Ctype.Nondep_cannot_erase removed_item_id ->
+              let (removed_item_kind, removed_item_loc, reason) =
+                Ident.Map.find removed_item_id to_remove.hide
+              in
+              let err_loc, hiding_error =
+                match reason with
+                | From_open ->
+                  removed_item_loc,
+                  Appears_in_signature {
+                    opened_item_kind = removed_item_kind;
+                    opened_item_id = removed_item_id;
+                    user_id;
+                    user_kind;
+                    user_loc;
+                  }
+                | Shadowed_by (shadower_id, shadower_loc) ->
+                  shadower_loc,
+                  Illegal_shadowing {
+                    shadowed_item_kind = removed_item_kind;
+                    shadowed_item_id = removed_item_id;
+                    shadowed_item_loc = removed_item_loc;
+                    shadower_id;
+                    user_id;
+                    user_kind;
+                    user_loc;
+                  }
+              in
+              raise (Error(err_loc, env, Cannot_hide_id hiding_error))
+        in
+        Some component
+      end
+    in
+    List.filter_map simplify_item sg
+end
+
+let has_remove_aliases_attribute attr =
+  let remove_aliases =
+    Attr_helper.get_no_payload_attribute
+      ["remove_aliases"; "ocaml.remove_aliases"] attr
+  in
+  match remove_aliases with
+  | None -> false
+  | Some _ -> true
+
+(* Check and translate a module type expression *)
+
+let transl_modtype_longident loc env lid =
+  let (path, _info) = Env.lookup_modtype ~loc lid env in
+  path
+
+let transl_module_alias loc env lid =
+  Env.lookup_module_path ~load:false ~loc lid env
+
+let mkmty desc typ env loc attrs =
+  let mty = {
+    mty_desc = desc;
+    mty_type = typ;
+    mty_loc = loc;
+    mty_env = env;
+    mty_attributes = attrs;
+    } in
+  Cmt_format.add_saved_type (Cmt_format.Partial_module_type mty);
+  mty
+
+let mksig desc env loc =
+  let sg = { sig_desc = desc; sig_loc = loc; sig_env = env } in
+  Cmt_format.add_saved_type (Cmt_format.Partial_signature_item sg);
+  sg
+
+(* let signature sg = List.map (fun item -> item.sig_type) sg *)
+
+let rec transl_modtype env smty =
+  Builtin_attributes.warning_scope smty.pmty_attributes
+    (fun () -> transl_modtype_aux env smty)
+
+and transl_modtype_functor_arg env sarg =
+  let mty = transl_modtype env sarg in
+  {mty with mty_type = Mtype.scrape_for_functor_arg env mty.mty_type}
+
+and transl_modtype_aux env smty =
+  let loc = smty.pmty_loc in
+  match smty.pmty_desc with
+    Pmty_ident lid ->
+      let path = transl_modtype_longident loc env lid.txt in
+      mkmty (Tmty_ident (path, lid)) (Mty_ident path) env loc
+        smty.pmty_attributes
+  | Pmty_alias lid ->
+      let path = transl_module_alias loc env lid.txt in
+      mkmty (Tmty_alias (path, lid)) (Mty_alias path) env loc
+        smty.pmty_attributes
+  | Pmty_signature ssg ->
+      let sg = transl_signature env ssg in
+      mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc
+        smty.pmty_attributes
+  | Pmty_functor(sarg_opt, sres) ->
+      let t_arg, ty_arg, newenv =
+        match sarg_opt with
+        | Unit -> Unit, Types.Unit, env
+        | Named (param, sarg) ->
+          let arg = transl_modtype_functor_arg env sarg in
+          let (id, newenv) =
+            match param.txt with
+            | None -> None, env
+            | Some name ->
+              let scope = Ctype.create_scope () in
+              let id, newenv =
+                let arg_md =
+                  { md_type = arg.mty_type;
+                    md_attributes = [];
+                    md_loc = param.loc;
+                    md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+                  }
+                in
+                Env.enter_module_declaration ~scope ~arg:true name Mp_present
+                  arg_md env
+              in
+              Some id, newenv
+          in
+          Named (id, param, arg), Types.Named (id, arg.mty_type), newenv
+      in
+      let res = transl_modtype newenv sres in
+      mkmty (Tmty_functor (t_arg, res))
+        (Mty_functor(ty_arg, res.mty_type)) env loc
+        smty.pmty_attributes
+  | Pmty_with(sbody, constraints) ->
+      let body = transl_modtype env sbody in
+      let init_sg = extract_sig env sbody.pmty_loc body.mty_type in
+      let remove_aliases = has_remove_aliases_attribute smty.pmty_attributes in
+      let (rev_tcstrs, final_sg) =
+        List.fold_left (transl_with ~loc:smty.pmty_loc env remove_aliases)
+        ([],init_sg) constraints in
+      let scope = Ctype.create_scope () in
+      mkmty (Tmty_with ( body, List.rev rev_tcstrs))
+        (Mtype.freshen ~scope (Mty_signature final_sg)) env loc
+        smty.pmty_attributes
+  | Pmty_typeof smod ->
+      let env = Env.in_signature false env in
+      let tmty, mty = !type_module_type_of_fwd env smod in
+      mkmty (Tmty_typeof tmty) mty env loc smty.pmty_attributes
+  | Pmty_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and transl_with ~loc env remove_aliases (rev_tcstrs,sg) constr =
+  let lid, with_info = match constr with
+    | Pwith_type (l,decl) ->l , With_type decl
+    | Pwith_typesubst (l,decl) ->l , With_typesubst decl
+    | Pwith_module (l,l') ->
+        let path, md = Env.lookup_module ~loc l'.txt env in
+        l , With_module {lid=l';path;md; remove_aliases}
+    | Pwith_modsubst (l,l') ->
+        let path, md' = Env.lookup_module ~loc l'.txt env in
+        l , With_modsubst (l',path,md')
+    | Pwith_modtype (l,smty) ->
+        let mty = transl_modtype env smty in
+        l, With_modtype mty
+    | Pwith_modtypesubst (l,smty) ->
+        let mty = transl_modtype env smty in
+        l, With_modtypesubst mty
+  in
+  let (tcstr, sg) = merge_constraint env loc sg lid with_info in
+  (tcstr :: rev_tcstrs, sg)
+
+
+
+and transl_signature env sg =
+  let names = Signature_names.create () in
+  let rec transl_sig env sg =
+    match sg with
+      [] -> [], [], env
+    | item :: srem ->
+        let loc = item.psig_loc in
+        match item.psig_desc with
+        | Psig_value sdesc ->
+            let (tdesc, newenv) =
+              Typedecl.transl_value_decl env item.psig_loc sdesc
+            in
+            Signature_names.check_value names tdesc.val_loc tdesc.val_id;
+            let (trem,rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_value tdesc) env loc :: trem,
+            Sig_value(tdesc.val_id, tdesc.val_val, Exported) :: rem,
+              final_env
+        | Psig_type (rec_flag, sdecls) ->
+            let (decls, newenv) =
+              Typedecl.transl_type_decl env rec_flag sdecls
+            in
+            List.iter (fun td ->
+              Signature_names.check_type names td.typ_loc td.typ_id
+            ) decls;
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            let sg =
+              map_rec_type_with_row_types ~rec_flag
+                (fun rs td -> Sig_type(td.typ_id, td.typ_type, rs, Exported))
+                decls rem
+            in
+            mksig (Tsig_type (rec_flag, decls)) env loc :: trem,
+            sg,
+            final_env
+        | Psig_typesubst sdecls ->
+            let (decls, newenv) =
+              Typedecl.transl_type_decl env Nonrecursive sdecls
+            in
+            List.iter (fun td ->
+              if td.typ_kind <> Ttype_abstract || td.typ_manifest = None ||
+                 td.typ_private = Private
+              then
+                raise (Error (td.typ_loc, env, Invalid_type_subst_rhs));
+              let params = td.typ_type.type_params in
+              if params_are_constrained params
+              then raise(Error(loc, env, With_cannot_remove_constrained_type));
+              let info =
+                  let subst =
+                    Subst.add_type_function (Pident td.typ_id)
+                      ~params
+                      ~body:(Option.get td.typ_type.type_manifest)
+                      Subst.identity
+                  in
+                  Some (`Substituted_away subst)
+              in
+              Signature_names.check_type ?info names td.typ_loc td.typ_id
+            ) decls;
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            let sg = rem
+            in
+            mksig (Tsig_typesubst decls) env loc :: trem,
+            sg,
+            final_env
+        | Psig_typext styext ->
+            let (tyext, newenv) =
+              Typedecl.transl_type_extension false env item.psig_loc styext
+            in
+            let constructors = tyext.tyext_constructors in
+            List.iter (fun ext ->
+              Signature_names.check_typext names ext.ext_loc ext.ext_id
+            ) constructors;
+            let (trem, rem, final_env) = transl_sig newenv srem in
+              mksig (Tsig_typext tyext) env loc :: trem,
+              map_ext (fun es ext ->
+                Sig_typext(ext.ext_id, ext.ext_type, es, Exported)
+              ) constructors rem,
+              final_env
+        | Psig_exception sext ->
+            let (ext, newenv) = Typedecl.transl_type_exception env sext in
+            let constructor = ext.tyexn_constructor in
+            Signature_names.check_typext names constructor.ext_loc
+              constructor.ext_id;
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_exception ext) env loc :: trem,
+            Sig_typext(constructor.ext_id,
+                       constructor.ext_type,
+                       Text_exception,
+                       Exported) :: rem,
+            final_env
+        | Psig_module pmd ->
+            let scope = Ctype.create_scope () in
+            let tmty =
+              Builtin_attributes.warning_scope pmd.pmd_attributes
+                (fun () -> transl_modtype env pmd.pmd_type)
+            in
+            let pres =
+              match tmty.mty_type with
+              | Mty_alias _ -> Mp_absent
+              | _ -> Mp_present
+            in
+            let md = {
+              md_type=tmty.mty_type;
+              md_attributes=pmd.pmd_attributes;
+              md_loc=pmd.pmd_loc;
+              md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+            }
+            in
+            let id, newenv =
+              match pmd.pmd_name.txt with
+              | None -> None, env
+              | Some name ->
+                let id, newenv =
+                  Env.enter_module_declaration ~scope name pres md env
+                in
+                Signature_names.check_module names pmd.pmd_name.loc id;
+                Some id, newenv
+            in
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_module {md_id=id; md_name=pmd.pmd_name;
+                                md_presence=pres; md_type=tmty;
+                                md_loc=pmd.pmd_loc;
+                                md_attributes=pmd.pmd_attributes})
+              env loc :: trem,
+            (match id with
+             | None -> rem
+             | Some id -> Sig_module(id, pres, md, Trec_not, Exported) :: rem),
+            final_env
+        | Psig_modsubst pms ->
+            let scope = Ctype.create_scope () in
+            let path, md =
+              Env.lookup_module ~loc:pms.pms_manifest.loc
+                pms.pms_manifest.txt env
+            in
+            let aliasable = not (Env.is_functor_arg path env) in
+            let md =
+              if not aliasable then
+                md
+              else
+                { md_type = Mty_alias path;
+                  md_attributes = pms.pms_attributes;
+                  md_loc = pms.pms_loc;
+                  md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+                }
+            in
+            let pres =
+              match md.md_type with
+              | Mty_alias _ -> Mp_absent
+              | _ -> Mp_present
+            in
+            let id, newenv =
+              Env.enter_module_declaration ~scope pms.pms_name.txt pres md env
+            in
+            let info =
+              `Substituted_away (Subst.add_module id path Subst.identity)
+            in
+            Signature_names.check_module ~info names pms.pms_name.loc id;
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_modsubst {ms_id=id; ms_name=pms.pms_name;
+                                  ms_manifest=path; ms_txt=pms.pms_manifest;
+                                  ms_loc=pms.pms_loc;
+                                  ms_attributes=pms.pms_attributes})
+              env loc :: trem,
+            rem,
+            final_env
+        | Psig_recmodule sdecls ->
+            let (tdecls, newenv) =
+              transl_recmodule_modtypes env sdecls in
+            let decls =
+              List.filter_map (fun (md, uid) ->
+                match md.md_id with
+                | None -> None
+                | Some id -> Some (id, md, uid)
+              ) tdecls
+            in
+            List.iter (fun (id, md, _) ->
+              Signature_names.check_module names md.md_loc id
+            ) decls;
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_recmodule (List.map fst tdecls)) env loc :: trem,
+            map_rec (fun rs (id, md, uid) ->
+                let d = {Types.md_type = md.md_type.mty_type;
+                         md_attributes = md.md_attributes;
+                         md_loc = md.md_loc;
+                         md_uid = uid;
+                        } in
+                Sig_module(id, Mp_present, d, rs, Exported))
+              decls rem,
+            final_env
+        | Psig_modtype pmtd ->
+            let newenv, mtd, sg = transl_modtype_decl env pmtd in
+            Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id;
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_modtype mtd) env loc :: trem,
+            sg :: rem,
+            final_env
+        | Psig_modtypesubst pmtd ->
+            let newenv, mtd, _sg = transl_modtype_decl env pmtd in
+            let info =
+              let mty = match mtd.mtd_type with
+                | Some tmty -> tmty.mty_type
+                | None ->
+                    (* parsetree invariant, see Ast_invariants *)
+                    assert false
+              in
+              let subst = Subst.add_modtype mtd.mtd_id mty Subst.identity in
+              match mty with
+              | Mty_ident _ -> `Substituted_away subst
+              | _ -> `Unpackable_modtype_substituted_away (mtd.mtd_id,subst)
+            in
+            Signature_names.check_modtype ~info names pmtd.pmtd_loc mtd.mtd_id;
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_modtypesubst mtd) env loc :: trem,
+            rem,
+            final_env
+        | Psig_open sod ->
+            let (od, newenv) = type_open_descr env sod in
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_open od) env loc :: trem,
+            rem, final_env
+        | Psig_include sincl ->
+            let smty = sincl.pincl_mod in
+            let tmty =
+              Builtin_attributes.warning_scope sincl.pincl_attributes
+                (fun () -> transl_modtype env smty)
+            in
+            let mty = tmty.mty_type in
+            let scope = Ctype.create_scope () in
+            let sg, newenv = Env.enter_signature ~scope
+                       (extract_sig env smty.pmty_loc mty) env in
+            Signature_group.iter
+              (Signature_names.check_sig_item names item.psig_loc)
+              sg;
+            let incl =
+              { incl_mod = tmty;
+                incl_type = sg;
+                incl_attributes = sincl.pincl_attributes;
+                incl_loc = sincl.pincl_loc;
+              }
+            in
+            let (trem, rem, final_env) = transl_sig newenv srem  in
+            mksig (Tsig_include incl) env loc :: trem,
+            sg @ rem,
+            final_env
+        | Psig_class cl ->
+            let (classes, newenv) = Typeclass.class_descriptions env cl in
+            List.iter (fun cls ->
+              let open Typeclass in
+              let loc = cls.cls_id_loc.Location.loc in
+              Signature_names.check_type names loc cls.cls_obj_id;
+              Signature_names.check_class names loc cls.cls_id;
+              Signature_names.check_class_type names loc cls.cls_ty_id;
+              Signature_names.check_type names loc cls.cls_typesharp_id;
+            ) classes;
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            let sg =
+              map_rec (fun rs cls ->
+                let open Typeclass in
+                [Sig_class(cls.cls_id, cls.cls_decl, rs, Exported);
+                 Sig_class_type(cls.cls_ty_id, cls.cls_ty_decl, rs, Exported);
+                 Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs, Exported);
+                 Sig_type(cls.cls_typesharp_id, cls.cls_abbr, rs, Exported)]
+              ) classes [rem]
+              |> List.flatten
+            in
+            let typedtree =
+              mksig (Tsig_class
+                       (List.map (fun decr ->
+                          decr.Typeclass.cls_info) classes)) env loc
+              :: trem
+            in
+            typedtree, sg, final_env
+        | Psig_class_type cl ->
+            let (classes, newenv) = Typeclass.class_type_declarations env cl in
+            List.iter (fun decl ->
+              let open Typeclass in
+              let loc = decl.clsty_id_loc.Location.loc in
+              Signature_names.check_class_type names loc decl.clsty_ty_id;
+              Signature_names.check_type names loc decl.clsty_obj_id;
+              Signature_names.check_type names loc decl.clsty_typesharp_id;
+            ) classes;
+            let (trem,rem, final_env) = transl_sig newenv srem in
+            let sg =
+              map_rec (fun rs decl ->
+                let open Typeclass in
+                [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs,
+                                Exported);
+                 Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs, Exported);
+                 Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs,
+                          Exported)
+                ]
+              ) classes [rem]
+              |> List.flatten
+            in
+            let typedtree =
+              mksig
+                (Tsig_class_type
+                   (List.map (fun decl -> decl.Typeclass.clsty_info) classes))
+                env loc
+              :: trem
+            in
+            typedtree, sg, final_env
+        | Psig_attribute x ->
+            Builtin_attributes.warning_attribute x;
+            let (trem,rem, final_env) = transl_sig env srem in
+            mksig (Tsig_attribute x) env loc :: trem, rem, final_env
+        | Psig_extension (ext, _attrs) ->
+            raise (Error_forward (Builtin_attributes.error_of_extension ext))
+  in
+  let previous_saved_types = Cmt_format.get_saved_types () in
+  Builtin_attributes.warning_scope []
+    (fun () ->
+       let (trem, rem, final_env) = transl_sig (Env.in_signature true env) sg in
+       let rem = Signature_names.simplify final_env names rem in
+       let sg =
+         { sig_items = trem; sig_type = rem; sig_final_env = final_env }
+       in
+       Cmt_format.set_saved_types
+         ((Cmt_format.Partial_signature sg) :: previous_saved_types);
+       sg
+    )
+
+and transl_modtype_decl env pmtd =
+  Builtin_attributes.warning_scope pmtd.pmtd_attributes
+    (fun () -> transl_modtype_decl_aux env pmtd)
+
+and transl_modtype_decl_aux env
+    {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} =
+  let tmty =
+    Option.map (transl_modtype (Env.in_signature true env)) pmtd_type
+  in
+  let decl =
+    {
+     Types.mtd_type=Option.map (fun t -> t.mty_type) tmty;
+     mtd_attributes=pmtd_attributes;
+     mtd_loc=pmtd_loc;
+     mtd_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+    }
+  in
+  let scope = Ctype.create_scope () in
+  let (id, newenv) = Env.enter_modtype ~scope pmtd_name.txt decl env in
+  let mtd =
+    {
+     mtd_id=id;
+     mtd_name=pmtd_name;
+     mtd_type=tmty;
+     mtd_attributes=pmtd_attributes;
+     mtd_loc=pmtd_loc;
+    }
+  in
+  newenv, mtd, Sig_modtype(id, decl, Exported)
+
+and transl_recmodule_modtypes env sdecls =
+  let make_env curr =
+    List.fold_left
+      (fun env (id, _, md, _) ->
+         Option.fold ~none:env
+           ~some:(fun id -> Env.add_module_declaration ~check:true ~arg:true
+                              id Mp_present md env) id)
+      env curr in
+  let transition env_c curr =
+    List.map2
+      (fun pmd (id, id_loc, md, _) ->
+        let tmty =
+          Builtin_attributes.warning_scope pmd.pmd_attributes
+            (fun () -> transl_modtype env_c pmd.pmd_type)
+        in
+        let md = { md with Types.md_type = tmty.mty_type } in
+        (id, id_loc, md, tmty))
+      sdecls curr in
+  let map_mtys curr =
+    List.filter_map
+      (fun (id, _, md, _) -> Option.map (fun id -> (id, md)) id)
+      curr
+  in
+  let scope = Ctype.create_scope () in
+  let ids =
+    List.map (fun x -> Option.map (Ident.create_scoped ~scope) x.pmd_name.txt)
+      sdecls
+  in
+  let approx_env =
+    List.fold_left
+      (fun env ->
+         Option.fold ~none:env ~some:(fun id -> (* cf #5965 *)
+           Env.enter_unbound_module (Ident.name id)
+             Mod_unbound_illegal_recursion env
+         ))
+      env ids
+  in
+  let init =
+    List.map2
+      (fun id pmd ->
+         let md =
+           { md_type = approx_modtype approx_env pmd.pmd_type;
+             md_loc = pmd.pmd_loc;
+             md_attributes = pmd.pmd_attributes;
+             md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) }
+         in
+        (id, pmd.pmd_name, md, ()))
+      ids sdecls
+  in
+  let env0 = make_env init in
+  let dcl1 =
+    Warnings.without_warnings
+      (fun () -> transition env0 init)
+  in
+  let env1 = make_env dcl1 in
+  check_recmod_typedecls env1 (map_mtys dcl1);
+  let dcl2 = transition env1 dcl1 in
+(*
+  List.iter
+    (fun (id, mty) ->
+      Format.printf "%a: %a@." Printtyp.ident id Printtyp.modtype mty)
+    dcl2;
+*)
+  let env2 = make_env dcl2 in
+  check_recmod_typedecls env2 (map_mtys dcl2);
+  let dcl2 =
+    List.map2 (fun pmd (id, id_loc, md, mty) ->
+      let tmd =
+        {md_id=id; md_name=id_loc; md_type=mty;
+         md_presence=Mp_present;
+         md_loc=pmd.pmd_loc;
+         md_attributes=pmd.pmd_attributes}
+      in
+      tmd, md.md_uid
+    ) sdecls dcl2
+  in
+  (dcl2, env2)
+
+(* Try to convert a module expression to a module path. *)
+
+exception Not_a_path
+
+let rec path_of_module mexp =
+  match mexp.mod_desc with
+  | Tmod_ident (p,_) -> p
+  | Tmod_apply(funct, arg, _coercion) when !Clflags.applicative_functors ->
+      Papply(path_of_module funct, path_of_module arg)
+  | Tmod_constraint (mexp, _, _, _) ->
+      path_of_module mexp
+  | _ -> raise Not_a_path
+
+let path_of_module mexp =
+ try Some (path_of_module mexp) with Not_a_path -> None
+
+(* Check that all core type schemes in a structure are closed *)
+
+let rec closed_modtype env = function
+    Mty_ident _ -> true
+  | Mty_alias _ -> true
+  | Mty_signature sg ->
+      let env = Env.add_signature sg env in
+      List.for_all (closed_signature_item env) sg
+  | Mty_functor(arg_opt, body) ->
+      let env =
+        match arg_opt with
+        | Unit
+        | Named (None, _) -> env
+        | Named (Some id, param) ->
+            Env.add_module ~arg:true id Mp_present param env
+      in
+      closed_modtype env body
+
+and closed_signature_item env = function
+    Sig_value(_id, desc, _) -> Ctype.closed_schema env desc.val_type
+  | Sig_module(_id, _, md, _, _) -> closed_modtype env md.md_type
+  | _ -> true
+
+let check_nongen_scheme env sig_item =
+  match sig_item with
+    Sig_value(_id, vd, _) ->
+      if not (Ctype.closed_schema env vd.val_type) then
+        raise (Error (vd.val_loc, env, Non_generalizable vd.val_type))
+  | Sig_module (_id, _, md, _, _) ->
+      if not (closed_modtype env md.md_type) then
+        raise(Error(md.md_loc, env, Non_generalizable_module md.md_type))
+  | _ -> ()
+
+let check_nongen_schemes env sg =
+  List.iter (check_nongen_scheme env) sg
+
+(* Helpers for typing recursive modules *)
+
+let anchor_submodule name anchor =
+  match anchor, name with
+  | None, _
+  | _, None ->
+      None
+  | Some p, Some name ->
+      Some(Pdot(p, name))
+
+let anchor_recmodule = Option.map (fun id -> Pident id)
+
+let enrich_type_decls anchor decls oldenv newenv =
+  match anchor with
+    None -> newenv
+  | Some p ->
+      List.fold_left
+        (fun e info ->
+          let id = info.typ_id in
+          let info' =
+            Mtype.enrich_typedecl oldenv (Pdot(p, Ident.name id))
+              id info.typ_type
+          in
+            Env.add_type ~check:true id info' e)
+        oldenv decls
+
+let enrich_module_type anchor name mty env =
+  match anchor, name with
+  | None, _
+  | _, None ->
+      mty
+  | Some p, Some name ->
+      Mtype.enrich_modtype env (Pdot(p, name)) mty
+
+let check_recmodule_inclusion env bindings =
+  (* PR#4450, PR#4470: consider
+        module rec X : DECL = MOD  where MOD has inferred type ACTUAL
+     The "natural" typing condition
+        E, X: ACTUAL |- ACTUAL <: DECL
+     leads to circularities through manifest types.
+     Instead, we "unroll away" the potential circularities a finite number
+     of times.  The (weaker) condition we implement is:
+        E, X: DECL,
+           X1: ACTUAL,
+           X2: ACTUAL{X <- X1}/X1
+           ...
+           Xn: ACTUAL{X <- X(n-1)}/X(n-1)
+        |- ACTUAL{X <- Xn}/Xn <: DECL{X <- Xn}
+     so that manifest types rooted at X(n+1) are expanded in terms of X(n),
+     avoiding circularities.  The strengthenings ensure that
+     Xn.t = X(n-1).t = ... = X2.t = X1.t.
+     N can be chosen arbitrarily; larger values of N result in more
+     recursive definitions being accepted.  A good choice appears to be
+     the number of mutually recursive declarations. *)
+
+  let subst_and_strengthen env scope s id mty =
+    let mty = Subst.modtype (Rescope scope) s mty in
+    match id with
+    | None -> mty
+    | Some id ->
+        Mtype.strengthen ~aliasable:false env mty
+          (Subst.module_path s (Pident id))
+  in
+
+  let rec check_incl first_time n env s =
+    let scope = Ctype.create_scope () in
+    if n > 0 then begin
+      (* Generate fresh names Y_i for the rec. bound module idents X_i *)
+      let bindings1 =
+        List.map
+          (fun (id, _name, _mty_decl, _modl, mty_actual, _attrs, _loc, _uid) ->
+             let ids =
+               Option.map
+                 (fun id -> (id, Ident.create_scoped ~scope (Ident.name id))) id
+             in
+             (ids, mty_actual))
+          bindings in
+      (* Enter the Y_i in the environment with their actual types substituted
+         by the input substitution s *)
+      let env' =
+        List.fold_left
+          (fun env (ids, mty_actual) ->
+             match ids with
+             | None -> env
+             | Some (id, id') ->
+               let mty_actual' =
+                 if first_time
+                 then mty_actual
+                 else subst_and_strengthen env scope s (Some id) mty_actual
+               in
+               Env.add_module ~arg:false id' Mp_present mty_actual' env)
+          env bindings1 in
+      (* Build the output substitution Y_i <- X_i *)
+      let s' =
+        List.fold_left
+          (fun s (ids, _mty_actual) ->
+             match ids with
+             | None -> s
+             | Some (id, id') -> Subst.add_module id (Pident id') s)
+          Subst.identity bindings1 in
+      (* Recurse with env' and s' *)
+      check_incl false (n-1) env' s'
+    end else begin
+      (* Base case: check inclusion of s(mty_actual) in s(mty_decl)
+         and insert coercion if needed *)
+      let check_inclusion
+            (id, name, mty_decl, modl, mty_actual, attrs, loc, uid) =
+        let mty_decl' = Subst.modtype (Rescope scope) s mty_decl.mty_type
+        and mty_actual' = subst_and_strengthen env scope s id mty_actual in
+        let coercion =
+          try
+            Includemod.modtypes ~loc:modl.mod_loc ~mark:Mark_both env
+              mty_actual' mty_decl'
+          with Includemod.Error msg ->
+            raise(Error(modl.mod_loc, env, Not_included msg)) in
+        let modl' =
+            { mod_desc = Tmod_constraint(modl, mty_decl.mty_type,
+                Tmodtype_explicit mty_decl, coercion);
+              mod_type = mty_decl.mty_type;
+              mod_env = env;
+              mod_loc = modl.mod_loc;
+              mod_attributes = [];
+             } in
+        let mb =
+          {
+            mb_id = id;
+            mb_name = name;
+            mb_presence = Mp_present;
+            mb_expr = modl';
+            mb_attributes = attrs;
+            mb_loc = loc;
+          }
+        in
+        mb, uid
+      in
+      List.map check_inclusion bindings
+    end
+  in check_incl true (List.length bindings) env Subst.identity
+
+(* Helper for unpack *)
+
+let rec package_constraints_sig env loc sg constrs =
+  List.map
+    (function
+      | Sig_type (id, ({type_params=[]} as td), rs, priv)
+        when List.mem_assoc [Ident.name id] constrs ->
+          let ty = List.assoc [Ident.name id] constrs in
+          Sig_type (id, {td with type_manifest = Some ty}, rs, priv)
+      | Sig_module (id, pres, md, rs, priv) ->
+          let rec aux = function
+            | (m :: ((_ :: _) as l), t) :: rest when m = Ident.name id ->
+                (l, t) :: aux rest
+            | _ :: rest -> aux rest
+            | [] -> []
+          in
+          let md =
+            {md with
+             md_type = package_constraints env loc md.md_type (aux constrs)
+            }
+          in
+          Sig_module (id, pres, md, rs, priv)
+      | item -> item
+    )
+    sg
+
+and package_constraints env loc mty constrs =
+  if constrs = [] then mty
+  else begin
+    match Mtype.scrape env mty with
+    | Mty_signature sg ->
+        Mty_signature (package_constraints_sig env loc sg constrs)
+    | Mty_functor _ | Mty_alias _ -> assert false
+    | Mty_ident p -> raise(Error(loc, env, Cannot_scrape_package_type p))
+  end
+
+let modtype_of_package env loc p fl =
+  package_constraints env loc (Mty_ident p)
+    (List.map (fun (n, t) -> (Longident.flatten n, t)) fl)
+
+let package_subtype env p1 fl1 p2 fl2 =
+  let mkmty p fl =
+    let fl =
+      List.filter (fun (_n,t) -> Ctype.free_variables t = []) fl in
+    modtype_of_package env Location.none p fl
+  in
+  match mkmty p1 fl1, mkmty p2 fl2 with
+  | exception Error(_, _, Cannot_scrape_package_type _) -> false
+  | mty1, mty2 ->
+    let loc = Location.none in
+    match Includemod.modtypes ~loc ~mark:Mark_both env mty1 mty2 with
+    | Tcoerce_none -> true
+    | _ | exception Includemod.Error _ -> false
+
+let () = Ctype.package_subtype := package_subtype
+
+let wrap_constraint env mark arg mty explicit =
+  let mark = if mark then Includemod.Mark_both else Includemod.Mark_neither in
+  let coercion =
+    try
+      Includemod.modtypes ~loc:arg.mod_loc env ~mark arg.mod_type mty
+    with Includemod.Error msg ->
+      raise(Error(arg.mod_loc, env, Not_included msg)) in
+  { mod_desc = Tmod_constraint(arg, mty, explicit, coercion);
+    mod_type = mty;
+    mod_env = env;
+    mod_attributes = [];
+    mod_loc = arg.mod_loc }
+
+(* Type a module value expression *)
+
+
+(* Summary for F(X) *)
+type application_summary = {
+  loc: Location.t;
+  attributes: attributes;
+  f_loc: Location.t; (* loc for F *)
+  arg_is_syntactic_unit: bool;
+  arg: Typedtree.module_expr;
+  arg_path:Path.t option
+}
+
+let simplify_app_summary app_view =
+  let mty = app_view.arg.mod_type in
+  match app_view.arg_is_syntactic_unit , app_view.arg_path with
+  | true,   _ -> Includemod.Error.Unit, mty
+  | false, Some p -> Includemod.Error.Named p, mty
+  | false, None -> Includemod.Error.Anonymous, mty
+
+let rec type_module ?(alias=false) sttn funct_body anchor env smod =
+  Builtin_attributes.warning_scope smod.pmod_attributes
+    (fun () -> type_module_aux ~alias sttn funct_body anchor env smod)
+
+and type_module_aux ~alias sttn funct_body anchor env smod =
+  match smod.pmod_desc with
+    Pmod_ident lid ->
+      let path =
+        Env.lookup_module_path ~load:(not alias) ~loc:smod.pmod_loc lid.txt env
+      in
+      let md = { mod_desc = Tmod_ident (path, lid);
+                 mod_type = Mty_alias path;
+                 mod_env = env;
+                 mod_attributes = smod.pmod_attributes;
+                 mod_loc = smod.pmod_loc } in
+      let aliasable = not (Env.is_functor_arg path env) in
+      let md =
+        if alias && aliasable then
+          (Env.add_required_global (Path.head path); md)
+        else match (Env.find_module path env).md_type with
+        | Mty_alias p1 when not alias ->
+            let p1 = Env.normalize_module_path (Some smod.pmod_loc) env p1 in
+            let mty = Includemod.expand_module_alias env p1 in
+            { md with
+              mod_desc =
+                Tmod_constraint (md, mty, Tmodtype_implicit,
+                                 Tcoerce_alias (env, path, Tcoerce_none));
+              mod_type =
+                if sttn then Mtype.strengthen ~aliasable:true env mty p1
+                else mty }
+        | mty ->
+            let mty =
+              if sttn then Mtype.strengthen ~aliasable env mty path
+              else mty
+            in
+            { md with mod_type = mty }
+      in md
+  | Pmod_structure sstr ->
+      let (str, sg, names, _finalenv) =
+        type_structure funct_body anchor env sstr in
+      let md =
+        { mod_desc = Tmod_structure str;
+          mod_type = Mty_signature sg;
+          mod_env = env;
+          mod_attributes = smod.pmod_attributes;
+          mod_loc = smod.pmod_loc }
+      in
+      let sg' = Signature_names.simplify _finalenv names sg in
+      if List.length sg' = List.length sg then md else
+      wrap_constraint env false md (Mty_signature sg')
+        Tmodtype_implicit
+  | Pmod_functor(arg_opt, sbody) ->
+      let t_arg, ty_arg, newenv, funct_body =
+        match arg_opt with
+        | Unit -> Unit, Types.Unit, env, false
+        | Named (param, smty) ->
+          let mty = transl_modtype_functor_arg env smty in
+          let scope = Ctype.create_scope () in
+          let (id, newenv) =
+            match param.txt with
+            | None -> None, env
+            | Some name ->
+              let arg_md =
+                { md_type = mty.mty_type;
+                  md_attributes = [];
+                  md_loc = param.loc;
+                  md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+                }
+              in
+              let id, newenv =
+                Env.enter_module_declaration ~scope ~arg:true name Mp_present
+                  arg_md env
+              in
+              Some id, newenv
+          in
+          Named (id, param, mty), Types.Named (id, mty.mty_type), newenv, true
+      in
+      let body = type_module true funct_body None newenv sbody in
+      { mod_desc = Tmod_functor(t_arg, body);
+        mod_type = Mty_functor(ty_arg, body.mod_type);
+        mod_env = env;
+        mod_attributes = smod.pmod_attributes;
+        mod_loc = smod.pmod_loc }
+  | Pmod_apply _ ->
+      type_application smod.pmod_loc sttn funct_body env smod
+  | Pmod_constraint(sarg, smty) ->
+      let arg = type_module ~alias true funct_body anchor env sarg in
+      let mty = transl_modtype env smty in
+      let md =
+        wrap_constraint env true arg mty.mty_type (Tmodtype_explicit mty)
+      in
+      { md with
+        mod_loc = smod.pmod_loc;
+        mod_attributes = smod.pmod_attributes;
+      }
+  | Pmod_unpack sexp ->
+      if !Clflags.principal then Ctype.begin_def ();
+      let exp = Typecore.type_exp env sexp in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        Ctype.generalize_structure exp.exp_type
+      end;
+      let mty =
+        match Ctype.expand_head env exp.exp_type with
+          {desc = Tpackage (p, fl)} ->
+            if List.exists (fun (_n, t) -> Ctype.free_variables t <> []) fl then
+              raise (Error (smod.pmod_loc, env,
+                            Incomplete_packed_module exp.exp_type));
+            if !Clflags.principal &&
+              not (Typecore.generalizable (Btype.generic_level-1) exp.exp_type)
+            then
+              Location.prerr_warning smod.pmod_loc
+                (Warnings.Not_principal "this module unpacking");
+            modtype_of_package env smod.pmod_loc p fl
+        | {desc = Tvar _} ->
+            raise (Typecore.Error
+                     (smod.pmod_loc, env, Typecore.Cannot_infer_signature))
+        | _ ->
+            raise (Error(smod.pmod_loc, env, Not_a_packed_module exp.exp_type))
+      in
+      if funct_body && Mtype.contains_type env mty then
+        raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
+      { mod_desc = Tmod_unpack(exp, mty);
+        mod_type = mty;
+        mod_env = env;
+        mod_attributes = smod.pmod_attributes;
+        mod_loc = smod.pmod_loc }
+  | Pmod_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and type_application loc strengthen funct_body env smod =
+  let rec extract_application funct_body env sargs smod =
+    match smod.pmod_desc with
+    | Pmod_apply(f, sarg) ->
+        let arg = type_module true funct_body None env sarg in
+        let summary =
+          { loc=smod.pmod_loc;
+            attributes=smod.pmod_attributes;
+            f_loc = f.pmod_loc;
+            arg_is_syntactic_unit = sarg.pmod_desc = Pmod_structure [];
+            arg;
+            arg_path = path_of_module arg
+          }
+        in
+        extract_application funct_body env (summary::sargs) f
+    | _ -> smod, sargs
+  in
+  let sfunct, args = extract_application funct_body env [] smod in
+  let funct =
+    let strengthen =
+      strengthen && List.for_all (fun {arg_path;_} -> arg_path <> None) args
+    in
+    type_module strengthen funct_body None env sfunct
+  in
+  List.fold_left (type_one_application ~ctx:(loc, funct, args) funct_body env)
+    funct args
+
+and type_one_application ~ctx:(apply_loc,md_f,args) funct_body env funct
+    app_view =
+  match Env.scrape_alias env funct.mod_type with
+  | Mty_functor (Unit, mty_res) ->
+      if not app_view.arg_is_syntactic_unit then
+        raise (Error (app_view.f_loc, env, Apply_generative));
+      if funct_body && Mtype.contains_type env funct.mod_type then
+        raise (Error (apply_loc, env, Not_allowed_in_functor_body));
+      { mod_desc = Tmod_apply(funct, app_view.arg, Tcoerce_none);
+        mod_type = mty_res;
+        mod_env = env;
+        mod_attributes = app_view.attributes;
+        mod_loc = funct.mod_loc }
+  | Mty_functor (Named (param, mty_param), mty_res) as mty_functor ->
+      let coercion =
+        try
+          Includemod.modtypes
+            ~loc:app_view.arg.mod_loc ~mark:Mark_both env
+            app_view.arg.mod_type mty_param
+        with Includemod.Error _ ->
+          let args = List.map simplify_app_summary args in
+          let mty_f = md_f.mod_type in
+          let lid_app = None in
+          raise(Includemod.Apply_error {loc=apply_loc;env;lid_app;mty_f;args})
+      in
+      let mty_appl =
+        match app_view.arg_path with
+        | Some path ->
+            let scope = Ctype.create_scope () in
+            let subst =
+              match param with
+              | None -> Subst.identity
+              | Some p -> Subst.add_module p path Subst.identity
+            in
+            Subst.modtype (Rescope scope) subst mty_res
+        | None ->
+            let env, nondep_mty =
+              match param with
+              | None -> env, mty_res
+              | Some param ->
+                  let env =
+                    Env.add_module ~arg:true param Mp_present
+                      app_view.arg.mod_type env
+                  in
+                  check_well_formed_module env app_view.loc
+                    "the signature of this functor application" mty_res;
+                  try env, Mtype.nondep_supertype env [param] mty_res
+                  with Ctype.Nondep_cannot_erase _ ->
+                    let error = Cannot_eliminate_dependency mty_functor in
+                    raise (Error(app_view.loc, env, error))
+            in
+            begin match
+              Includemod.modtypes
+                ~loc:app_view.loc ~mark:Mark_neither env mty_res nondep_mty
+            with
+            | Tcoerce_none -> ()
+            | _ ->
+                fatal_error
+                  "unexpected coercion from original module type to \
+                   nondep_supertype one"
+            | exception Includemod.Error _ ->
+                fatal_error
+                  "nondep_supertype not included in original module type"
+            end;
+            nondep_mty
+      in
+      check_well_formed_module env apply_loc
+        "the signature of this functor application" mty_appl;
+      { mod_desc = Tmod_apply(funct, app_view.arg, coercion);
+        mod_type = mty_appl;
+        mod_env = env;
+        mod_attributes = app_view.attributes;
+        mod_loc = app_view.loc }
+  | Mty_alias path ->
+      raise(Error(app_view.f_loc, env, Cannot_scrape_alias path))
+  | _ ->
+      let args = List.map simplify_app_summary args in
+      let mty_f = md_f.mod_type in
+      let lid_app = None in
+      raise(Includemod.Apply_error {loc=apply_loc;env;lid_app;mty_f;args})
+
+and type_open_decl ?used_slot ?toplevel funct_body names env sod =
+  Builtin_attributes.warning_scope sod.popen_attributes
+    (fun () ->
+       type_open_decl_aux ?used_slot ?toplevel funct_body names env sod
+    )
+
+and type_open_decl_aux ?used_slot ?toplevel funct_body names env od =
+  let loc = od.popen_loc in
+  match od.popen_expr.pmod_desc with
+  | Pmod_ident lid ->
+    let path, newenv =
+      type_open_ ?used_slot ?toplevel od.popen_override env loc lid
+    in
+    let md = { mod_desc = Tmod_ident (path, lid);
+               mod_type = Mty_alias path;
+               mod_env = env;
+               mod_attributes = od.popen_expr.pmod_attributes;
+               mod_loc = od.popen_expr.pmod_loc }
+    in
+    let open_descr = {
+      open_expr = md;
+      open_bound_items = [];
+      open_override = od.popen_override;
+      open_env = newenv;
+      open_loc = loc;
+      open_attributes = od.popen_attributes
+    } in
+    open_descr, [], newenv
+  | _ ->
+    let md = type_module true funct_body None env od.popen_expr in
+    let scope = Ctype.create_scope () in
+    let sg, newenv =
+      Env.enter_signature ~scope (extract_sig_open env md.mod_loc md.mod_type)
+        env
+    in
+    let info, visibility =
+      match toplevel with
+      | Some false | None -> Some `From_open, Hidden
+      | Some true -> None, Exported
+    in
+    Signature_group.iter (Signature_names.check_sig_item ?info names loc) sg;
+    let sg =
+      List.map (function
+        | Sig_value(id, vd, _) -> Sig_value(id, vd, visibility)
+        | Sig_type(id, td, rs, _) -> Sig_type(id, td, rs, visibility)
+        | Sig_typext(id, ec, et, _) -> Sig_typext(id, ec, et, visibility)
+        | Sig_module(id, mp, md, rs, _) ->
+            Sig_module(id, mp, md, rs, visibility)
+        | Sig_modtype(id, mtd, _) -> Sig_modtype(id, mtd, visibility)
+        | Sig_class(id, cd, rs, _) -> Sig_class(id, cd, rs, visibility)
+        | Sig_class_type(id, ctd, rs, _) ->
+            Sig_class_type(id, ctd, rs, visibility)
+      ) sg
+    in
+    let open_descr = {
+      open_expr = md;
+      open_bound_items = sg;
+      open_override = od.popen_override;
+      open_env = newenv;
+      open_loc = loc;
+      open_attributes = od.popen_attributes
+    } in
+    open_descr, sg, newenv
+
+and type_structure ?(toplevel = false) funct_body anchor env sstr =
+  let names = Signature_names.create () in
+
+  let type_str_item env {pstr_loc = loc; pstr_desc = desc} =
+    match desc with
+    | Pstr_eval (sexpr, attrs) ->
+        let expr =
+          Builtin_attributes.warning_scope attrs
+            (fun () -> Typecore.type_expression env sexpr)
+        in
+        Tstr_eval (expr, attrs), [], env
+    | Pstr_value(rec_flag, sdefs) ->
+        let (defs, newenv) =
+          Typecore.type_binding env rec_flag sdefs in
+        let () = if rec_flag = Recursive then
+          Typecore.check_recursive_bindings env defs
+        in
+        (* Note: Env.find_value does not trigger the value_used event. Values
+           will be marked as being used during the signature inclusion test. *)
+        Tstr_value(rec_flag, defs),
+        List.map (fun (id, { Asttypes.loc; _ }, _typ)->
+          Signature_names.check_value names loc id;
+          Sig_value(id, Env.find_value (Pident id) newenv, Exported)
+        ) (let_bound_idents_full defs),
+        newenv
+    | Pstr_primitive sdesc ->
+        let (desc, newenv) = Typedecl.transl_value_decl env loc sdesc in
+        Signature_names.check_value names desc.val_loc desc.val_id;
+        Tstr_primitive desc,
+        [Sig_value(desc.val_id, desc.val_val, Exported)],
+        newenv
+    | Pstr_type (rec_flag, sdecls) ->
+        let (decls, newenv) = Typedecl.transl_type_decl env rec_flag sdecls in
+        List.iter
+          Signature_names.(fun td -> check_type names td.typ_loc td.typ_id)
+          decls;
+        Tstr_type (rec_flag, decls),
+        map_rec_type_with_row_types ~rec_flag
+          (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs, Exported))
+          decls [],
+        enrich_type_decls anchor decls env newenv
+    | Pstr_typext styext ->
+        let (tyext, newenv) =
+          Typedecl.transl_type_extension true env loc styext
+        in
+        let constructors = tyext.tyext_constructors in
+        List.iter
+          Signature_names.(fun ext -> check_typext names ext.ext_loc ext.ext_id)
+          constructors;
+        (Tstr_typext tyext,
+         map_ext
+           (fun es ext -> Sig_typext(ext.ext_id, ext.ext_type, es, Exported))
+           constructors [],
+         newenv)
+    | Pstr_exception sext ->
+        let (ext, newenv) = Typedecl.transl_type_exception env sext in
+        let constructor = ext.tyexn_constructor in
+        Signature_names.check_typext names constructor.ext_loc
+          constructor.ext_id;
+        Tstr_exception ext,
+        [Sig_typext(constructor.ext_id,
+                    constructor.ext_type,
+                    Text_exception,
+                    Exported)],
+        newenv
+    | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs;
+                   pmb_loc;
+                  } ->
+        let outer_scope = Ctype.get_current_level () in
+        let scope = Ctype.create_scope () in
+        let modl =
+          Builtin_attributes.warning_scope attrs
+            (fun () ->
+               type_module ~alias:true true funct_body
+                 (anchor_submodule name.txt anchor) env smodl
+            )
+        in
+        let pres =
+          match modl.mod_type with
+          | Mty_alias _ -> Mp_absent
+          | _ -> Mp_present
+        in
+        let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in
+        let md =
+          { md_type = enrich_module_type anchor name.txt modl.mod_type env;
+            md_attributes = attrs;
+            md_loc = pmb_loc;
+            md_uid;
+          }
+        in
+        (*prerr_endline (Ident.unique_toplevel_name id);*)
+        Mtype.lower_nongen outer_scope md.md_type;
+        let id, newenv, sg =
+          match name.txt with
+          | None -> None, env, []
+          | Some name ->
+            let id, e = Env.enter_module_declaration ~scope name pres md env in
+            Signature_names.check_module names pmb_loc id;
+            Some id, e,
+            [Sig_module(id, pres,
+                        {md_type = modl.mod_type;
+                         md_attributes = attrs;
+                         md_loc = pmb_loc;
+                         md_uid;
+                        }, Trec_not, Exported)]
+        in
+        Tstr_module {mb_id=id; mb_name=name; mb_expr=modl;
+                     mb_presence=pres; mb_attributes=attrs;  mb_loc=pmb_loc; },
+        sg,
+        newenv
+    | Pstr_recmodule sbind ->
+        let sbind =
+          List.map
+            (function
+              | {pmb_name = name;
+                 pmb_expr = {pmod_desc=Pmod_constraint(expr, typ)};
+                 pmb_attributes = attrs;
+                 pmb_loc = loc;
+                } ->
+                  name, typ, expr, attrs, loc
+              | mb ->
+                  raise (Error (mb.pmb_expr.pmod_loc, env,
+                                Recursive_module_require_explicit_type))
+            )
+            sbind
+        in
+        let (decls, newenv) =
+          transl_recmodule_modtypes env
+            (List.map (fun (name, smty, _smodl, attrs, loc) ->
+                 {pmd_name=name; pmd_type=smty;
+                  pmd_attributes=attrs; pmd_loc=loc}) sbind
+            ) in
+        List.iter
+          (fun (md, _) ->
+            Option.iter Signature_names.(check_module names md.md_loc) md.md_id)
+          decls;
+        let bindings1 =
+          List.map2
+            (fun ({md_id=id; md_type=mty}, uid) (name, _, smodl, attrs, loc) ->
+               let modl =
+                 Builtin_attributes.warning_scope attrs
+                   (fun () ->
+                      type_module true funct_body (anchor_recmodule id)
+                        newenv smodl
+                   )
+               in
+               let mty' =
+                 enrich_module_type anchor name.txt modl.mod_type newenv
+               in
+               (id, name, mty, modl, mty', attrs, loc, uid))
+            decls sbind in
+        let newenv = (* allow aliasing recursive modules from outside *)
+          List.fold_left
+            (fun env (md, uid) ->
+               match md.md_id with
+               | None -> env
+               | Some id ->
+                   let mdecl =
+                     {
+                       md_type = md.md_type.mty_type;
+                       md_attributes = md.md_attributes;
+                       md_loc = md.md_loc;
+                       md_uid = uid;
+                     }
+                   in
+                   Env.add_module_declaration ~check:true
+                     id Mp_present mdecl env
+            )
+            env decls
+        in
+        let bindings2 =
+          check_recmodule_inclusion newenv bindings1 in
+        let mbs =
+          List.filter_map (fun (mb, uid) ->
+            Option.map (fun id -> id, mb, uid)  mb.mb_id
+          ) bindings2
+        in
+        Tstr_recmodule (List.map fst bindings2),
+        map_rec (fun rs (id, mb, uid) ->
+            Sig_module(id, Mp_present, {
+                md_type=mb.mb_expr.mod_type;
+                md_attributes=mb.mb_attributes;
+                md_loc=mb.mb_loc;
+                md_uid = uid;
+              }, rs, Exported))
+           mbs [],
+        newenv
+    | Pstr_modtype pmtd ->
+        (* check that it is non-abstract *)
+        let newenv, mtd, sg = transl_modtype_decl env pmtd in
+        Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id;
+        Tstr_modtype mtd, [sg], newenv
+    | Pstr_open sod ->
+        let (od, sg, newenv) =
+          type_open_decl ~toplevel funct_body names env sod
+        in
+        Tstr_open od, sg, newenv
+    | Pstr_class cl ->
+        let (classes, new_env) = Typeclass.class_declarations env cl in
+        List.iter (fun cls ->
+          let open Typeclass in
+          let loc = cls.cls_id_loc.Location.loc in
+          Signature_names.check_class names loc cls.cls_id;
+          Signature_names.check_class_type names loc cls.cls_ty_id;
+          Signature_names.check_type names loc cls.cls_obj_id;
+          Signature_names.check_type names loc cls.cls_typesharp_id;
+        ) classes;
+        Tstr_class
+          (List.map (fun cls ->
+               (cls.Typeclass.cls_info,
+                cls.Typeclass.cls_pub_methods)) classes),
+        List.flatten
+          (map_rec
+            (fun rs cls ->
+              let open Typeclass in
+              [Sig_class(cls.cls_id, cls.cls_decl, rs, Exported);
+               Sig_class_type(cls.cls_ty_id, cls.cls_ty_decl, rs, Exported);
+               Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs, Exported);
+               Sig_type(cls.cls_typesharp_id, cls.cls_abbr, rs, Exported)])
+             classes []),
+        new_env
+    | Pstr_class_type cl ->
+        let (classes, new_env) = Typeclass.class_type_declarations env cl in
+        List.iter (fun decl ->
+          let open Typeclass in
+          let loc = decl.clsty_id_loc.Location.loc in
+          Signature_names.check_class_type names loc decl.clsty_ty_id;
+          Signature_names.check_type names loc decl.clsty_obj_id;
+          Signature_names.check_type names loc decl.clsty_typesharp_id;
+        ) classes;
+        Tstr_class_type
+          (List.map (fun cl ->
+               (cl.Typeclass.clsty_ty_id,
+                cl.Typeclass.clsty_id_loc,
+                cl.Typeclass.clsty_info)) classes),
+        List.flatten
+          (map_rec
+             (fun rs decl ->
+                let open Typeclass in
+                [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs,
+                                Exported);
+                 Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs, Exported);
+                 Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs,
+                          Exported)
+                ])
+             classes []),
+        new_env
+    | Pstr_include sincl ->
+        let smodl = sincl.pincl_mod in
+        let modl =
+          Builtin_attributes.warning_scope sincl.pincl_attributes
+            (fun () -> type_module true funct_body None env smodl)
+        in
+        let scope = Ctype.create_scope () in
+        (* Rename all identifiers bound by this signature to avoid clashes *)
+        let sg, new_env = Env.enter_signature ~scope
+            (extract_sig_open env smodl.pmod_loc modl.mod_type) env in
+        Signature_group.iter (Signature_names.check_sig_item names loc) sg;
+        let incl =
+          { incl_mod = modl;
+            incl_type = sg;
+            incl_attributes = sincl.pincl_attributes;
+            incl_loc = sincl.pincl_loc;
+          }
+        in
+        Tstr_include incl, sg, new_env
+    | Pstr_extension (ext, _attrs) ->
+        raise (Error_forward (Builtin_attributes.error_of_extension ext))
+    | Pstr_attribute x ->
+        Builtin_attributes.warning_attribute x;
+        Tstr_attribute x, [], env
+  in
+  let rec type_struct env sstr =
+    match sstr with
+    | [] -> ([], [], env)
+    | pstr :: srem ->
+        let previous_saved_types = Cmt_format.get_saved_types () in
+        let desc, sg, new_env = type_str_item env pstr in
+        let str = { str_desc = desc; str_loc = pstr.pstr_loc; str_env = env } in
+        Cmt_format.set_saved_types (Cmt_format.Partial_structure_item str
+                                    :: previous_saved_types);
+        let (str_rem, sig_rem, final_env) = type_struct new_env srem in
+        (str :: str_rem, sg @ sig_rem, final_env)
+  in
+  let previous_saved_types = Cmt_format.get_saved_types () in
+  let run () =
+    let (items, sg, final_env) = type_struct env sstr in
+    let str = { str_items = items; str_type = sg; str_final_env = final_env } in
+    Cmt_format.set_saved_types
+      (Cmt_format.Partial_structure str :: previous_saved_types);
+    str, sg, names, final_env
+  in
+  if toplevel then run ()
+  else Builtin_attributes.warning_scope [] run
+
+let type_toplevel_phrase env s =
+  Env.reset_required_globals ();
+  let (str, sg, to_remove_from_sg, env) =
+    type_structure ~toplevel:true false None env s in
+  (str, sg, to_remove_from_sg, env)
+
+let type_module_alias = type_module ~alias:true true false None
+let type_module = type_module true false None
+let type_structure = type_structure false None
+
+(* Normalize types in a signature *)
+
+let rec normalize_modtype = function
+    Mty_ident _
+  | Mty_alias _ -> ()
+  | Mty_signature sg -> normalize_signature sg
+  | Mty_functor(_param, body) -> normalize_modtype body
+
+and normalize_signature sg = List.iter normalize_signature_item sg
+
+and normalize_signature_item = function
+    Sig_value(_id, desc, _) -> Ctype.normalize_type desc.val_type
+  | Sig_module(_id, _, md, _, _) -> normalize_modtype md.md_type
+  | _ -> ()
+
+(* Extract the module type of a module expression *)
+
+let type_module_type_of env smod =
+  let remove_aliases = has_remove_aliases_attribute smod.pmod_attributes in
+  let tmty =
+    match smod.pmod_desc with
+    | Pmod_ident lid -> (* turn off strengthening in this case *)
+        let path, md = Env.lookup_module ~loc:smod.pmod_loc lid.txt env in
+          { mod_desc = Tmod_ident (path, lid);
+            mod_type = md.md_type;
+            mod_env = env;
+            mod_attributes = smod.pmod_attributes;
+            mod_loc = smod.pmod_loc }
+    | _ -> type_module env smod
+  in
+  let mty = Mtype.scrape_for_type_of ~remove_aliases env tmty.mod_type in
+  (* PR#5036: must not contain non-generalized type variables *)
+  if not (closed_modtype env mty) then
+    raise(Error(smod.pmod_loc, env, Non_generalizable_module mty));
+  tmty, mty
+
+(* For Typecore *)
+
+(* Graft a longident onto a path *)
+let rec extend_path path =
+  fun lid ->
+    match lid with
+    | Lident name -> Pdot(path, name)
+    | Ldot(m, name) -> Pdot(extend_path path m, name)
+    | Lapply _ -> assert false
+
+(* Lookup a type's longident within a signature *)
+let lookup_type_in_sig sg =
+  let types, modules =
+    List.fold_left
+      (fun acc item ->
+         match item with
+         | Sig_type(id, _, _, _) ->
+             let types, modules = acc in
+             let types = String.Map.add (Ident.name id) id types in
+             types, modules
+         | Sig_module(id, _, _, _, _) ->
+             let types, modules = acc in
+             let modules = String.Map.add (Ident.name id) id modules in
+             types, modules
+         | _ -> acc)
+      (String.Map.empty, String.Map.empty) sg
+  in
+  let rec module_path = function
+    | Lident name -> Pident (String.Map.find name modules)
+    | Ldot(m, name) -> Pdot(module_path m, name)
+    | Lapply _ -> assert false
+  in
+  fun lid ->
+    match lid with
+    | Lident name -> Pident (String.Map.find name types)
+    | Ldot(m, name) -> Pdot(module_path m, name)
+    | Lapply _ -> assert false
+
+let type_package env m p fl =
+  (* Same as Pexp_letmodule *)
+  (* remember original level *)
+  Ctype.begin_def ();
+  let context = Typetexp.narrow () in
+  let modl = type_module env m in
+  let scope = Ctype.create_scope () in
+  Typetexp.widen context;
+  let fl', env =
+    match fl with
+    | [] -> [], env
+    | fl ->
+      let type_path, env =
+        match modl.mod_desc with
+        | Tmod_ident (mp,_)
+        | Tmod_constraint
+            ({mod_desc=Tmod_ident (mp,_)}, _, Tmodtype_implicit, _) ->
+          (* We special case these because interactions between
+             strengthening of module types and packages can cause
+             spurious escape errors. See examples from PR#6982 in the
+             testsuite. This can be removed when such issues are
+             fixed. *)
+          extend_path mp, env
+        | _ ->
+          let sg = extract_sig_open env modl.mod_loc modl.mod_type in
+          let sg, env = Env.enter_signature ~scope sg env in
+          lookup_type_in_sig sg, env
+      in
+      let fl' =
+        List.fold_right
+          (fun (lid, _t) fl ->
+             match type_path lid with
+             | exception Not_found -> fl
+             | path -> begin
+                 match Env.find_type path env with
+                 | exception Not_found -> fl
+                 | decl ->
+                     if decl.type_arity > 0 then begin
+                       fl
+                     end else begin
+                       let t = Btype.newgenty (Tconstr (path,[],ref Mnil)) in
+                       (lid, t) :: fl
+                     end
+               end)
+          fl []
+      in
+      fl', env
+  in
+  (* go back to original level *)
+  Ctype.end_def ();
+  let mty =
+    if fl = [] then (Mty_ident p)
+    else modtype_of_package env modl.mod_loc p fl'
+  in
+  List.iter
+    (fun (n, ty) ->
+      try Ctype.unify env ty (Ctype.newvar ())
+      with Ctype.Unify _ ->
+        raise (Error(modl.mod_loc, env, Scoping_pack (n,ty))))
+    fl';
+  let modl = wrap_constraint env true modl mty Tmodtype_implicit in
+  modl, fl'
+
+(* Fill in the forward declarations *)
+
+let type_open_decl ?used_slot env od =
+  type_open_decl ?used_slot ?toplevel:None false (Signature_names.create ()) env
+    od
+
+let type_open_descr ?used_slot env od =
+  type_open_descr ?used_slot ?toplevel:None env od
+
+let () =
+  Typecore.type_module := type_module_alias;
+  Typetexp.transl_modtype_longident := transl_modtype_longident;
+  Typetexp.transl_modtype := transl_modtype;
+  Typecore.type_open := type_open_ ?toplevel:None;
+  Typecore.type_open_decl := type_open_decl;
+  Typecore.type_package := type_package;
+  Typeclass.type_open_descr := type_open_descr;
+  type_module_type_of_fwd := type_module_type_of
+
+
+(* Typecheck an implementation file *)
+
+let gen_annot outputprefix sourcefile annots =
+  Cmt2annot.gen_annot (Some (outputprefix ^ ".annot"))
+    ~sourcefile:(Some sourcefile) ~use_summaries:false annots
+
+let type_implementation sourcefile outputprefix modulename initial_env ast =
+  Cmt_format.clear ();
+  Misc.try_finally (fun () ->
+      Typecore.reset_delayed_checks ();
+      Env.reset_required_globals ();
+      if !Clflags.print_types then (* #7656 *)
+        ignore @@ Warnings.parse_options false "-32-34-37-38-60";
+      let (str, sg, names, finalenv) =
+        type_structure initial_env ast in
+      let simple_sg = Signature_names.simplify finalenv names sg in
+      if !Clflags.print_types then begin
+        Typecore.force_delayed_checks ();
+        Printtyp.wrap_printing_env ~error:false initial_env
+          (fun () -> fprintf std_formatter "%a@."
+              (Printtyp.printed_signature sourcefile) simple_sg
+          );
+        gen_annot outputprefix sourcefile (Cmt_format.Implementation str);
+        { structure = str;
+          coercion = Tcoerce_none;
+          signature = simple_sg
+        } (* result is ignored by Compile.implementation *)
+      end else begin
+        let sourceintf =
+          Filename.remove_extension sourcefile ^ !Config.interface_suffix in
+        if Sys.file_exists sourceintf then begin
+          let intf_file =
+            try
+              Load_path.find_uncap (modulename ^ ".cmi")
+            with Not_found ->
+              raise(Error(Location.in_file sourcefile, Env.empty,
+                          Interface_not_compiled sourceintf)) in
+          let dclsig = Env.read_signature modulename intf_file in
+          let coercion =
+            Includemod.compunit initial_env ~mark:Mark_positive
+              sourcefile sg intf_file dclsig
+          in
+          Typecore.force_delayed_checks ();
+          (* It is important to run these checks after the inclusion test above,
+             so that value declarations which are not used internally but
+             exported are not reported as being unused. *)
+          let annots = Cmt_format.Implementation str in
+          Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename
+            annots (Some sourcefile) initial_env None;
+          gen_annot outputprefix sourcefile annots;
+          { structure = str;
+            coercion;
+            signature = dclsig
+          }
+        end else begin
+          Location.prerr_warning (Location.in_file sourcefile)
+            Warnings.Missing_mli;
+          let coercion =
+            Includemod.compunit initial_env ~mark:Mark_positive
+              sourcefile sg "(inferred signature)" simple_sg
+          in
+          check_nongen_schemes finalenv simple_sg;
+          normalize_signature simple_sg;
+          Typecore.force_delayed_checks ();
+          (* See comment above. Here the target signature contains all
+             the value being exported. We can still capture unused
+             declarations like "let x = true;; let x = 1;;", because in this
+             case, the inferred signature contains only the last declaration. *)
+          if not !Clflags.dont_write_files then begin
+            let alerts = Builtin_attributes.alerts_of_str ast in
+            let cmi =
+              Env.save_signature ~alerts
+                simple_sg modulename (outputprefix ^ ".cmi")
+            in
+            let annots = Cmt_format.Implementation str in
+            Cmt_format.save_cmt  (outputprefix ^ ".cmt") modulename
+              annots (Some sourcefile) initial_env (Some cmi);
+            gen_annot outputprefix sourcefile annots
+          end;
+          { structure = str;
+            coercion;
+            signature = simple_sg
+          }
+        end
+      end
+    )
+    ~exceptionally:(fun () ->
+        let annots =
+          Cmt_format.Partial_implementation
+            (Array.of_list (Cmt_format.get_saved_types ()))
+        in
+        Cmt_format.save_cmt  (outputprefix ^ ".cmt") modulename
+          annots (Some sourcefile) initial_env None;
+        gen_annot outputprefix sourcefile annots
+      )
+
+let save_signature modname tsg outputprefix source_file initial_env cmi =
+  Cmt_format.save_cmt  (outputprefix ^ ".cmti") modname
+    (Cmt_format.Interface tsg) (Some source_file) initial_env (Some cmi)
+
+let type_interface env ast =
+  transl_signature env ast
+
+(* "Packaging" of several compilation units into one unit
+   having them as sub-modules.  *)
+
+let package_signatures units =
+  let units_with_ids =
+    List.map
+      (fun (name, sg) ->
+        let oldid = Ident.create_persistent name in
+        let newid = Ident.create_local name in
+        (oldid, newid, sg))
+      units
+  in
+  let subst =
+    List.fold_left
+      (fun acc (oldid, newid, _) ->
+        Subst.add_module oldid (Pident newid) acc)
+      Subst.identity units_with_ids
+  in
+  List.map
+    (fun (_, newid, sg) ->
+      (* This signature won't be used for anything, it'll just be saved in a cmi
+         and cmt. *)
+      let sg = Subst.signature Make_local subst sg in
+      let md =
+        { md_type=Mty_signature sg;
+          md_attributes=[];
+          md_loc=Location.none;
+          md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+        }
+      in
+      Sig_module(newid, Mp_present, md, Trec_not, Exported))
+    units_with_ids
+
+let package_units initial_env objfiles cmifile modulename =
+  (* Read the signatures of the units *)
+  let units =
+    List.map
+      (fun f ->
+         let pref = chop_extensions f in
+         let modname = String.capitalize_ascii(Filename.basename pref) in
+         let sg = Env.read_signature modname (pref ^ ".cmi") in
+         if Filename.check_suffix f ".cmi" &&
+            not(Mtype.no_code_needed_sig Env.initial_safe_string sg)
+         then raise(Error(Location.none, Env.empty,
+                          Implementation_is_required f));
+         (modname, Env.read_signature modname (pref ^ ".cmi")))
+      objfiles in
+  (* Compute signature of packaged unit *)
+  Ident.reinit();
+  let sg = package_signatures units in
+  (* See if explicit interface is provided *)
+  let prefix = Filename.remove_extension cmifile in
+  let mlifile = prefix ^ !Config.interface_suffix in
+  if Sys.file_exists mlifile then begin
+    if not (Sys.file_exists cmifile) then begin
+      raise(Error(Location.in_file mlifile, Env.empty,
+                  Interface_not_compiled mlifile))
+    end;
+    let dclsig = Env.read_signature modulename cmifile in
+    Cmt_format.save_cmt  (prefix ^ ".cmt") modulename
+      (Cmt_format.Packed (sg, objfiles)) None initial_env  None ;
+    Includemod.compunit initial_env ~mark:Mark_both
+      "(obtained by packing)" sg mlifile dclsig
+  end else begin
+    (* Determine imports *)
+    let unit_names = List.map fst units in
+    let imports =
+      List.filter
+        (fun (name, _crc) -> not (List.mem name unit_names))
+        (Env.imports()) in
+    (* Write packaged signature *)
+    if not !Clflags.dont_write_files then begin
+      let cmi =
+        Env.save_signature_with_imports ~alerts:Misc.Stdlib.String.Map.empty
+          sg modulename
+          (prefix ^ ".cmi") imports
+      in
+      Cmt_format.save_cmt (prefix ^ ".cmt")  modulename
+        (Cmt_format.Packed (cmi.Cmi_format.cmi_sign, objfiles)) None initial_env
+        (Some cmi)
+    end;
+    Tcoerce_none
+  end
+
+
+(* Error report *)
+
+
+open Printtyp
+
+let report_error ~loc _env = function
+    Cannot_apply mty ->
+      Location.errorf ~loc
+        "@[This module is not a functor; it has type@ %a@]" modtype mty
+  | Not_included errs ->
+      let main = Includemod_errorprinter.err_msgs errs in
+      Location.errorf ~loc "@[<v>Signature mismatch:@ %t@]" main
+  | Cannot_eliminate_dependency mty ->
+      Location.errorf ~loc
+        "@[This functor has type@ %a@ \
+           The parameter cannot be eliminated in the result type.@ \
+           Please bind the argument to a module identifier.@]" modtype mty
+  | Signature_expected ->
+      Location.errorf ~loc "This module type is not a signature"
+  | Structure_expected mty ->
+      Location.errorf ~loc
+        "@[This module is not a structure; it has type@ %a" modtype mty
+  | With_no_component lid ->
+      Location.errorf ~loc
+        "@[The signature constrained by `with' has no component named %a@]"
+        longident lid
+  | With_mismatch(lid, explanation) ->
+      let main = Includemod_errorprinter.err_msgs explanation in
+      Location.errorf ~loc
+        "@[<v>\
+           @[In this `with' constraint, the new definition of %a@ \
+             does not match its original definition@ \
+             in the constrained signature:@]@ \
+           %t@]"
+        longident lid main
+  | With_makes_applicative_functor_ill_typed(lid, path, explanation) ->
+      let main = Includemod_errorprinter.err_msgs explanation in
+      Location.errorf ~loc
+        "@[<v>\
+           @[This `with' constraint on %a makes the applicative functor @ \
+             type %s ill-typed in the constrained signature:@]@ \
+           %t@]"
+        longident lid (Path.name path) main
+  | With_changes_module_alias(lid, id, path) ->
+      Location.errorf ~loc
+        "@[<v>\
+           @[This `with' constraint on %a changes %s, which is aliased @ \
+             in the constrained signature (as %s)@].@]"
+        longident lid (Path.name path) (Ident.name id)
+  | With_cannot_remove_constrained_type ->
+      Location.errorf ~loc
+        "@[<v>Destructive substitutions are not supported for constrained @ \
+              types (other than when replacing a type constructor with @ \
+              a type constructor with the same arguments).@]"
+  | With_cannot_remove_packed_modtype (p,mty) ->
+      Location.errorf ~loc
+        "This `with' constraint@ %s := %a@ makes a packed module ill-formed."
+        (Path.name p) Printtyp.modtype mty
+  | Repeated_name(kind, name) ->
+      Location.errorf ~loc
+        "@[Multiple definition of the %s name %s.@ \
+         Names must be unique in a given structure or signature.@]"
+        (Sig_component_kind.to_string kind) name
+  | Non_generalizable typ ->
+      Location.errorf ~loc
+        "@[The type of this expression,@ %a,@ \
+           contains type variables that cannot be generalized@]" type_scheme typ
+  | Non_generalizable_class (id, desc) ->
+      Location.errorf ~loc
+        "@[The type of this class,@ %a,@ \
+           contains type variables that cannot be generalized@]"
+        (class_declaration id) desc
+  | Non_generalizable_module mty ->
+      Location.errorf ~loc
+        "@[The type of this module,@ %a,@ \
+           contains type variables that cannot be generalized@]" modtype mty
+  | Implementation_is_required intf_name ->
+      Location.errorf ~loc
+        "@[The interface %a@ declares values, not just types.@ \
+           An implementation must be provided.@]"
+        Location.print_filename intf_name
+  | Interface_not_compiled intf_name ->
+      Location.errorf ~loc
+        "@[Could not find the .cmi file for interface@ %a.@]"
+        Location.print_filename intf_name
+  | Not_allowed_in_functor_body ->
+      Location.errorf ~loc
+        "@[This expression creates fresh types.@ %s@]"
+        "It is not allowed inside applicative functors."
+  | Not_a_packed_module ty ->
+      Location.errorf ~loc
+        "This expression is not a packed module. It has type@ %a"
+        type_expr ty
+  | Incomplete_packed_module ty ->
+      Location.errorf ~loc
+        "The type of this packed module contains variables:@ %a"
+        type_expr ty
+  | Scoping_pack (lid, ty) ->
+      Location.errorf ~loc
+        "The type %a in this module cannot be exported.@ \
+        Its type contains local dependencies:@ %a" longident lid type_expr ty
+  | Recursive_module_require_explicit_type ->
+      Location.errorf ~loc "Recursive modules require an explicit module type."
+  | Apply_generative ->
+      Location.errorf ~loc
+        "This is a generative functor. It can only be applied to ()"
+  | Cannot_scrape_alias p ->
+      Location.errorf ~loc
+        "This is an alias for module %a, which is missing"
+        path p
+  | Cannot_scrape_package_type p ->
+      Location.errorf ~loc
+        "The type of this packed module refers to %a, which is missing"
+        path p
+  | Badly_formed_signature (context, err) ->
+      Location.errorf ~loc "@[In %s:@ %a@]" context Typedecl.report_error err
+  | Cannot_hide_id Illegal_shadowing
+      { shadowed_item_kind; shadowed_item_id; shadowed_item_loc;
+        shadower_id; user_id; user_kind; user_loc } ->
+      let shadowed_item_kind= Sig_component_kind.to_string shadowed_item_kind in
+      Location.errorf ~loc
+        "@[<v>Illegal shadowing of included %s %a by %a@ \
+         %a:@;<1 2>%s %a came from this include@ \
+         %a:@;<1 2>The %s %s has no valid type if %a is shadowed@]"
+        shadowed_item_kind Ident.print shadowed_item_id Ident.print shadower_id
+        Location.print_loc shadowed_item_loc
+        (String.capitalize_ascii shadowed_item_kind)
+        Ident.print shadowed_item_id
+        Location.print_loc user_loc
+        (Sig_component_kind.to_string user_kind) (Ident.name user_id)
+        Ident.print shadowed_item_id
+  | Cannot_hide_id Appears_in_signature
+      { opened_item_kind; opened_item_id; user_id; user_kind; user_loc } ->
+      let opened_item_kind= Sig_component_kind.to_string opened_item_kind in
+      Location.errorf ~loc
+        "@[<v>The %s %a introduced by this open appears in the signature@ \
+         %a:@;<1 2>The %s %s has no valid type if %a is hidden@]"
+        opened_item_kind Ident.print opened_item_id
+        Location.print_loc user_loc
+        (Sig_component_kind.to_string user_kind) (Ident.name user_id)
+        Ident.print opened_item_id
+  | Invalid_type_subst_rhs ->
+      Location.errorf ~loc "Only type synonyms are allowed on the right of :="
+  | Unpackable_local_modtype_subst p ->
+      Location.errorf ~loc
+        "The module type@ %s@ is not a valid type for a packed module:@ \
+         it is defined as a local substitution for a non-path module type."
+        (Path.name p)
+
+let report_error env ~loc err =
+  Printtyp.wrap_printing_env ~error:true env
+    (fun () -> report_error env ~loc err)
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, env, err) ->
+        Some (report_error ~loc env err)
+      | Error_forward err ->
+        Some err
+      | _ ->
+        None
+    )
diff --git a/upstream/ocaml_413/typing/typemod.mli b/upstream/ocaml_413/typing/typemod.mli
new file mode 100644
index 0000000..7507416
--- /dev/null
+++ b/upstream/ocaml_413/typing/typemod.mli
@@ -0,0 +1,139 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Type-checking of the module language and typed ast hooks
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Types
+
+module Signature_names : sig
+  type t
+
+  val simplify: Env.t -> t -> signature -> signature
+end
+
+val type_module:
+        Env.t -> Parsetree.module_expr -> Typedtree.module_expr
+val type_structure:
+  Env.t -> Parsetree.structure ->
+  Typedtree.structure * Types.signature * Signature_names.t * Env.t
+val type_toplevel_phrase:
+  Env.t -> Parsetree.structure ->
+  Typedtree.structure * Types.signature * Signature_names.t * Env.t
+val type_implementation:
+  string -> string -> string -> Env.t ->
+  Parsetree.structure -> Typedtree.implementation
+val type_interface:
+        Env.t -> Parsetree.signature -> Typedtree.signature
+val transl_signature:
+        Env.t -> Parsetree.signature -> Typedtree.signature
+val check_nongen_schemes:
+        Env.t -> Types.signature -> unit
+        (*
+val type_open_:
+        ?used_slot:bool ref -> ?toplevel:bool ->
+        Asttypes.override_flag ->
+        Env.t -> Location.t -> Longident.t Asttypes.loc -> Path.t * Env.t
+        *)
+val modtype_of_package:
+        Env.t -> Location.t ->
+        Path.t -> (Longident.t * type_expr) list -> module_type
+
+val path_of_module : Typedtree.module_expr -> Path.t option
+
+val save_signature:
+  string -> Typedtree.signature -> string -> string ->
+  Env.t -> Cmi_format.cmi_infos -> unit
+
+val package_units:
+  Env.t -> string list -> string -> string -> Typedtree.module_coercion
+
+(* Should be in Envaux, but it breaks the build of the debugger *)
+val initial_env:
+  loc:Location.t -> safe_string:bool ->
+  initially_opened_module:string option ->
+  open_implicit_modules:string list -> Env.t
+
+module Sig_component_kind : sig
+  type t =
+    | Value
+    | Type
+    | Module
+    | Module_type
+    | Extension_constructor
+    | Class
+    | Class_type
+
+  val to_string : t -> string
+end
+
+type hiding_error =
+  | Illegal_shadowing of {
+      shadowed_item_id: Ident.t;
+      shadowed_item_kind: Sig_component_kind.t;
+      shadowed_item_loc: Location.t;
+      shadower_id: Ident.t;
+      user_id: Ident.t;
+      user_kind: Sig_component_kind.t;
+      user_loc: Location.t;
+    }
+  | Appears_in_signature of {
+      opened_item_id: Ident.t;
+      opened_item_kind: Sig_component_kind.t;
+      user_id: Ident.t;
+      user_kind: Sig_component_kind.t;
+      user_loc: Location.t;
+    }
+
+type error =
+    Cannot_apply of module_type
+  | Not_included of Includemod.explanation
+  | Cannot_eliminate_dependency of module_type
+  | Signature_expected
+  | Structure_expected of module_type
+  | With_no_component of Longident.t
+  | With_mismatch of Longident.t * Includemod.explanation
+  | With_makes_applicative_functor_ill_typed of
+      Longident.t * Path.t * Includemod.explanation
+  | With_changes_module_alias of Longident.t * Ident.t * Path.t
+  | With_cannot_remove_constrained_type
+  | Repeated_name of Sig_component_kind.t * string
+  | Non_generalizable of type_expr
+  | Non_generalizable_class of Ident.t * class_declaration
+  | Non_generalizable_module of module_type
+  | Implementation_is_required of string
+  | Interface_not_compiled of string
+  | Not_allowed_in_functor_body
+  | Not_a_packed_module of type_expr
+  | Incomplete_packed_module of type_expr
+  | Scoping_pack of Longident.t * type_expr
+  | Recursive_module_require_explicit_type
+  | Apply_generative
+  | Cannot_scrape_alias of Path.t
+  | Cannot_scrape_package_type of Path.t
+  | Badly_formed_signature of string * Typedecl.error
+  | Cannot_hide_id of hiding_error
+  | Invalid_type_subst_rhs
+  | Unpackable_local_modtype_subst of Path.t
+  | With_cannot_remove_packed_modtype of Path.t * module_type
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+val report_error: Env.t -> loc:Location.t -> error -> Location.error
diff --git a/upstream/ocaml_413/typing/typeopt.ml b/upstream/ocaml_413/typing/typeopt.ml
new file mode 100644
index 0000000..9ac86c8
--- /dev/null
+++ b/upstream/ocaml_413/typing/typeopt.ml
@@ -0,0 +1,216 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Auxiliaries for type-based optimizations, e.g. array kinds *)
+
+open Path
+open Types
+open Asttypes
+open Typedtree
+open Lambda
+
+let scrape_ty env ty =
+  let ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in
+  match ty.desc with
+  | Tconstr (p, _, _) ->
+      begin match Env.find_type p env with
+      | {type_kind = ( Type_variant (_, Variant_unboxed)
+                     | Type_record (_, Record_unboxed _) ); _} ->
+        begin match Typedecl.get_unboxed_type_representation env ty with
+        | None -> ty
+        | Some ty2 -> ty2
+        end
+      | _ -> ty
+      | exception Not_found -> ty
+      end
+  | _ -> ty
+
+let scrape env ty =
+  (scrape_ty env ty).desc
+
+let is_function_type env ty =
+  match scrape env ty with
+  | Tarrow (_, lhs, rhs, _) -> Some (lhs, rhs)
+  | _ -> None
+
+let is_base_type env ty base_ty_path =
+  match scrape env ty with
+  | Tconstr(p, _, _) -> Path.same p base_ty_path
+  | _ -> false
+
+let maybe_pointer_type env ty =
+  let ty = scrape_ty env ty in
+  if Ctype.maybe_pointer_type env ty then
+    Pointer
+  else
+    Immediate
+
+let maybe_pointer exp = maybe_pointer_type exp.exp_env exp.exp_type
+
+type classification =
+  | Int
+  | Float
+  | Lazy
+  | Addr  (* anything except a float or a lazy *)
+  | Any
+
+let classify env ty =
+  let ty = scrape_ty env ty in
+  if maybe_pointer_type env ty = Immediate then Int
+  else match ty.desc with
+  | Tvar _ | Tunivar _ ->
+      Any
+  | Tconstr (p, _args, _abbrev) ->
+      if Path.same p Predef.path_float then Float
+      else if Path.same p Predef.path_lazy_t then Lazy
+      else if Path.same p Predef.path_string
+           || Path.same p Predef.path_bytes
+           || Path.same p Predef.path_array
+           || Path.same p Predef.path_nativeint
+           || Path.same p Predef.path_int32
+           || Path.same p Predef.path_int64 then Addr
+      else begin
+        try
+          match (Env.find_type p env).type_kind with
+          | Type_abstract ->
+              Any
+          | Type_record _ | Type_variant _ | Type_open ->
+              Addr
+        with Not_found ->
+          (* This can happen due to e.g. missing -I options,
+             causing some .cmi files to be unavailable.
+             Maybe we should emit a warning. *)
+          Any
+      end
+  | Tarrow _ | Ttuple _ | Tpackage _ | Tobject _ | Tnil | Tvariant _ ->
+      Addr
+  | Tlink _ | Tsubst _ | Tpoly _ | Tfield _ ->
+      assert false
+
+let array_type_kind env ty =
+  match scrape env ty with
+  | Tconstr(p, [elt_ty], _) | Tpoly({desc = Tconstr(p, [elt_ty], _)}, _)
+    when Path.same p Predef.path_array ->
+      begin match classify env elt_ty with
+      | Any -> if Config.flat_float_array then Pgenarray else Paddrarray
+      | Float -> if Config.flat_float_array then Pfloatarray else Paddrarray
+      | Addr | Lazy -> Paddrarray
+      | Int -> Pintarray
+      end
+  | Tconstr(p, [], _) | Tpoly({desc = Tconstr(p, [], _)}, _)
+    when Path.same p Predef.path_floatarray ->
+      Pfloatarray
+  | _ ->
+      (* This can happen with e.g. Obj.field *)
+      Pgenarray
+
+let array_kind exp = array_type_kind exp.exp_env exp.exp_type
+
+let array_pattern_kind pat = array_type_kind pat.pat_env pat.pat_type
+
+let bigarray_decode_type env ty tbl dfl =
+  match scrape env ty with
+  | Tconstr(Pdot(Pident mod_id, type_name), [], _)
+    when Ident.name mod_id = "Stdlib__Bigarray" ->
+      begin try List.assoc type_name tbl with Not_found -> dfl end
+  | _ ->
+      dfl
+
+let kind_table =
+  ["float32_elt", Pbigarray_float32;
+   "float64_elt", Pbigarray_float64;
+   "int8_signed_elt", Pbigarray_sint8;
+   "int8_unsigned_elt", Pbigarray_uint8;
+   "int16_signed_elt", Pbigarray_sint16;
+   "int16_unsigned_elt", Pbigarray_uint16;
+   "int32_elt", Pbigarray_int32;
+   "int64_elt", Pbigarray_int64;
+   "int_elt", Pbigarray_caml_int;
+   "nativeint_elt", Pbigarray_native_int;
+   "complex32_elt", Pbigarray_complex32;
+   "complex64_elt", Pbigarray_complex64]
+
+let layout_table =
+  ["c_layout", Pbigarray_c_layout;
+   "fortran_layout", Pbigarray_fortran_layout]
+
+let bigarray_type_kind_and_layout env typ =
+  match scrape env typ with
+  | Tconstr(_p, [_caml_type; elt_type; layout_type], _abbrev) ->
+      (bigarray_decode_type env elt_type kind_table Pbigarray_unknown,
+       bigarray_decode_type env layout_type layout_table
+                            Pbigarray_unknown_layout)
+  | _ ->
+      (Pbigarray_unknown, Pbigarray_unknown_layout)
+
+let value_kind env ty =
+  match scrape env ty with
+  | Tconstr(p, _, _) when Path.same p Predef.path_int ->
+      Pintval
+  | Tconstr(p, _, _) when Path.same p Predef.path_char ->
+      Pintval
+  | Tconstr(p, _, _) when Path.same p Predef.path_float ->
+      Pfloatval
+  | Tconstr(p, _, _) when Path.same p Predef.path_int32 ->
+      Pboxedintval Pint32
+  | Tconstr(p, _, _) when Path.same p Predef.path_int64 ->
+      Pboxedintval Pint64
+  | Tconstr(p, _, _) when Path.same p Predef.path_nativeint ->
+      Pboxedintval Pnativeint
+  | _ ->
+      Pgenval
+
+let function_return_value_kind env ty =
+  match is_function_type env ty with
+  | Some (_lhs, rhs) -> value_kind env rhs
+  | None -> Pgenval
+
+(** Whether a forward block is needed for a lazy thunk on a value, i.e.
+    if the value can be represented as a float/forward/lazy *)
+let lazy_val_requires_forward env ty =
+  match classify env ty with
+  | Any | Lazy -> true
+  | Float -> Config.flat_float_array
+  | Addr | Int -> false
+
+(** The compilation of the expression [lazy e] depends on the form of e:
+    constants, floats and identifiers are optimized.  The optimization must be
+    taken into account when determining whether a recursive binding is safe. *)
+let classify_lazy_argument : Typedtree.expression ->
+                             [`Constant_or_function
+                             |`Float_that_cannot_be_shortcut
+                             |`Identifier of [`Forward_value|`Other]
+                             |`Other] =
+  fun e -> match e.exp_desc with
+    | Texp_constant
+        ( Const_int _ | Const_char _ | Const_string _
+        | Const_int32 _ | Const_int64 _ | Const_nativeint _ )
+    | Texp_function _
+    | Texp_construct (_, {cstr_arity = 0}, _) ->
+       `Constant_or_function
+    | Texp_constant(Const_float _) ->
+       if Config.flat_float_array
+       then `Float_that_cannot_be_shortcut
+       else `Constant_or_function
+    | Texp_ident _ when lazy_val_requires_forward e.exp_env e.exp_type ->
+       `Identifier `Forward_value
+    | Texp_ident _ ->
+       `Identifier `Other
+    | _ ->
+       `Other
+
+let value_kind_union k1 k2 =
+  if k1 = k2 then k1
+  else Pgenval
diff --git a/upstream/ocaml_413/typing/typeopt.mli b/upstream/ocaml_413/typing/typeopt.mli
new file mode 100644
index 0000000..0f6b9f3
--- /dev/null
+++ b/upstream/ocaml_413/typing/typeopt.mli
@@ -0,0 +1,43 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Auxiliaries for type-based optimizations, e.g. array kinds *)
+
+val is_function_type :
+      Env.t -> Types.type_expr -> (Types.type_expr * Types.type_expr) option
+val is_base_type : Env.t -> Types.type_expr -> Path.t -> bool
+
+val maybe_pointer_type : Env.t -> Types.type_expr
+  -> Lambda.immediate_or_pointer
+val maybe_pointer : Typedtree.expression -> Lambda.immediate_or_pointer
+
+val array_type_kind : Env.t -> Types.type_expr -> Lambda.array_kind
+val array_kind : Typedtree.expression -> Lambda.array_kind
+val array_pattern_kind : Typedtree.pattern -> Lambda.array_kind
+val bigarray_type_kind_and_layout :
+      Env.t -> Types.type_expr -> Lambda.bigarray_kind * Lambda.bigarray_layout
+val value_kind : Env.t -> Types.type_expr -> Lambda.value_kind
+val function_return_value_kind : Env.t -> Types.type_expr -> Lambda.value_kind
+
+val classify_lazy_argument : Typedtree.expression ->
+                             [ `Constant_or_function
+                             | `Float_that_cannot_be_shortcut
+                             | `Identifier of [`Forward_value | `Other]
+                             | `Other]
+
+val value_kind_union :
+      Lambda.value_kind -> Lambda.value_kind -> Lambda.value_kind
+  (** [value_kind_union k1 k2] is a value_kind at least as general as
+      [k1] and [k2] *)
diff --git a/upstream/ocaml_413/typing/types.ml b/upstream/ocaml_413/typing/types.ml
new file mode 100644
index 0000000..fa8e452
--- /dev/null
+++ b/upstream/ocaml_413/typing/types.ml
@@ -0,0 +1,479 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Representation of types and declarations *)
+
+open Asttypes
+
+(* Type expressions for the core language *)
+
+type type_expr =
+  { mutable desc: type_desc;
+    mutable level: int;
+    mutable scope: int;
+    id: int }
+
+and type_desc =
+    Tvar of string option
+  | Tarrow of arg_label * type_expr * type_expr * commutable
+  | Ttuple of type_expr list
+  | Tconstr of Path.t * type_expr list * abbrev_memo ref
+  | Tobject of type_expr * (Path.t * type_expr list) option ref
+  | Tfield of string * field_kind * type_expr * type_expr
+  | Tnil
+  | Tlink of type_expr
+  | Tsubst of type_expr * type_expr option
+  | Tvariant of row_desc
+  | Tunivar of string option
+  | Tpoly of type_expr * type_expr list
+  | Tpackage of Path.t * (Longident.t * type_expr) list
+
+and row_desc =
+    { row_fields: (label * row_field) list;
+      row_more: type_expr;
+      row_bound: unit;
+      row_closed: bool;
+      row_fixed: fixed_explanation option;
+      row_name: (Path.t * type_expr list) option }
+and fixed_explanation =
+  | Univar of type_expr | Fixed_private | Reified of Path.t | Rigid
+and row_field =
+    Rpresent of type_expr option
+  | Reither of bool * type_expr list * bool * row_field option ref
+        (* 1st true denotes a constant constructor *)
+        (* 2nd true denotes a tag in a pattern matching, and
+           is erased later *)
+  | Rabsent
+
+and abbrev_memo =
+    Mnil
+  | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo
+  | Mlink of abbrev_memo ref
+
+and field_kind =
+    Fvar of field_kind option ref
+  | Fpresent
+  | Fabsent
+
+and commutable =
+    Cok
+  | Cunknown
+  | Clink of commutable ref
+
+module TypeOps = struct
+  type t = type_expr
+  let compare t1 t2 = t1.id - t2.id
+  let hash t = t.id
+  let equal t1 t2 = t1 == t2
+end
+
+module Private_type_expr = struct
+  let create desc ~level ~scope ~id = {desc; level; scope; id}
+  let set_desc ty d = ty.desc <- d
+  let set_level ty lv = ty.level <- lv
+  let set_scope ty sc = ty.scope <- sc
+end
+(* *)
+
+module Uid = struct
+  type t =
+    | Compilation_unit of string
+    | Item of { comp_unit: string; id: int }
+    | Internal
+    | Predef of string
+
+  include Identifiable.Make(struct
+    type nonrec t = t
+
+    let equal (x : t) y = x = y
+    let compare (x : t) y = compare x y
+    let hash (x : t) = Hashtbl.hash x
+
+    let print fmt = function
+      | Internal -> Format.pp_print_string fmt "<internal>"
+      | Predef name -> Format.fprintf fmt "<predef:%s>" name
+      | Compilation_unit s -> Format.pp_print_string fmt s
+      | Item { comp_unit; id } -> Format.fprintf fmt "%s.%d" comp_unit id
+
+    let output oc t =
+      let fmt = Format.formatter_of_out_channel oc in
+      print fmt t
+  end)
+
+  let id = ref (-1)
+
+  let reinit () = id := (-1)
+
+  let mk  ~current_unit =
+      incr id;
+      Item { comp_unit = current_unit; id = !id }
+
+  let of_compilation_unit_id id =
+    if not (Ident.persistent id) then
+      Misc.fatal_errorf "Types.Uid.of_compilation_unit_id %S" (Ident.name id);
+    Compilation_unit (Ident.name id)
+
+  let of_predef_id id =
+    if not (Ident.is_predef id) then
+      Misc.fatal_errorf "Types.Uid.of_predef_id %S" (Ident.name id);
+    Predef (Ident.name id)
+
+  let internal_not_actually_unique = Internal
+
+  let for_actual_declaration = function
+    | Item _ -> true
+    | _ -> false
+end
+
+(* Maps of methods and instance variables *)
+
+module Meths = Misc.Stdlib.String.Map
+module Vars = Meths
+
+(* Value descriptions *)
+
+type value_description =
+  { val_type: type_expr;                (* Type of the value *)
+    val_kind: value_kind;
+    val_loc: Location.t;
+    val_attributes: Parsetree.attributes;
+    val_uid: Uid.t;
+  }
+
+and value_kind =
+    Val_reg                             (* Regular value *)
+  | Val_prim of Primitive.description   (* Primitive *)
+  | Val_ivar of mutable_flag * string   (* Instance variable (mutable ?) *)
+  | Val_self of (Ident.t * type_expr) Meths.t ref *
+                (Ident.t * Asttypes.mutable_flag *
+                 Asttypes.virtual_flag * type_expr) Vars.t ref *
+                string * type_expr
+                                        (* Self *)
+  | Val_anc of (string * Ident.t) list * string
+                                        (* Ancestor *)
+
+(* Variance *)
+
+module Variance = struct
+  type t = int
+  type f = May_pos | May_neg | May_weak | Inj | Pos | Neg | Inv
+  let single = function
+    | May_pos -> 1
+    | May_neg -> 2
+    | May_weak -> 4
+    | Inj -> 8
+    | Pos -> 16
+    | Neg -> 32
+    | Inv -> 64
+  let union v1 v2 = v1 lor v2
+  let inter v1 v2 = v1 land v2
+  let subset v1 v2 = (v1 land v2 = v1)
+  let eq (v1 : t) v2 = (v1 = v2)
+  let set x b v =
+    if b then v lor single x else  v land (lnot (single x))
+  let mem x = subset (single x)
+  let null = 0
+  let unknown = 7
+  let full = 127
+  let covariant = single May_pos lor single Pos lor single Inj
+  let swap f1 f2 v =
+    let v' = set f1 (mem f2 v) v in set f2 (mem f1 v) v'
+  let conjugate v = swap May_pos May_neg (swap Pos Neg v)
+  let get_upper v = (mem May_pos v, mem May_neg v)
+  let get_lower v = (mem Pos v, mem Neg v, mem Inv v, mem Inj v)
+  let unknown_signature ~injective ~arity =
+    let v = if injective then set Inj true unknown else unknown in
+    Misc.replicate_list v arity
+end
+
+module Separability = struct
+  type t = Ind | Sep | Deepsep
+  type signature = t list
+  let eq (m1 : t) m2 = (m1 = m2)
+  let rank = function
+    | Ind -> 0
+    | Sep -> 1
+    | Deepsep -> 2
+  let compare m1 m2 = compare (rank m1) (rank m2)
+  let max m1 m2 = if rank m1 >= rank m2 then m1 else m2
+
+  let print ppf = function
+    | Ind -> Format.fprintf ppf "Ind"
+    | Sep -> Format.fprintf ppf "Sep"
+    | Deepsep -> Format.fprintf ppf "Deepsep"
+
+  let print_signature ppf modes =
+    let pp_sep ppf () = Format.fprintf ppf ",@," in
+    Format.fprintf ppf "@[(%a)@]"
+      (Format.pp_print_list ~pp_sep print) modes
+
+  let default_signature ~arity =
+    let default_mode = if Config.flat_float_array then Deepsep else Ind in
+    Misc.replicate_list default_mode arity
+end
+
+(* Type definitions *)
+
+type type_declaration =
+  { type_params: type_expr list;
+    type_arity: int;
+    type_kind: type_decl_kind;
+    type_private: private_flag;
+    type_manifest: type_expr option;
+    type_variance: Variance.t list;
+    type_separability: Separability.t list;
+    type_is_newtype: bool;
+    type_expansion_scope: int;
+    type_loc: Location.t;
+    type_attributes: Parsetree.attributes;
+    type_immediate: Type_immediacy.t;
+    type_unboxed_default: bool;
+    type_uid: Uid.t;
+ }
+
+and type_decl_kind = (label_declaration, constructor_declaration) type_kind
+
+and ('lbl, 'cstr) type_kind =
+    Type_abstract
+  | Type_record of 'lbl list * record_representation
+  | Type_variant of 'cstr list * variant_representation
+  | Type_open
+
+and record_representation =
+    Record_regular                      (* All fields are boxed / tagged *)
+  | Record_float                        (* All fields are floats *)
+  | Record_unboxed of bool    (* Unboxed single-field record, inlined or not *)
+  | Record_inlined of int               (* Inlined record *)
+  | Record_extension of Path.t          (* Inlined record under extension *)
+
+and variant_representation =
+    Variant_regular          (* Constant or boxed constructors *)
+  | Variant_unboxed          (* One unboxed single-field constructor *)
+
+and label_declaration =
+  {
+    ld_id: Ident.t;
+    ld_mutable: mutable_flag;
+    ld_type: type_expr;
+    ld_loc: Location.t;
+    ld_attributes: Parsetree.attributes;
+    ld_uid: Uid.t;
+  }
+
+and constructor_declaration =
+  {
+    cd_id: Ident.t;
+    cd_args: constructor_arguments;
+    cd_res: type_expr option;
+    cd_loc: Location.t;
+    cd_attributes: Parsetree.attributes;
+    cd_uid: Uid.t;
+  }
+
+and constructor_arguments =
+  | Cstr_tuple of type_expr list
+  | Cstr_record of label_declaration list
+
+type extension_constructor =
+  { ext_type_path: Path.t;
+    ext_type_params: type_expr list;
+    ext_args: constructor_arguments;
+    ext_ret_type: type_expr option;
+    ext_private: private_flag;
+    ext_loc: Location.t;
+    ext_attributes: Parsetree.attributes;
+    ext_uid: Uid.t;
+  }
+
+and type_transparence =
+    Type_public      (* unrestricted expansion *)
+  | Type_new         (* "new" type *)
+  | Type_private     (* private type *)
+
+(* Type expressions for the class language *)
+
+module Concr = Misc.Stdlib.String.Set
+
+type class_type =
+    Cty_constr of Path.t * type_expr list * class_type
+  | Cty_signature of class_signature
+  | Cty_arrow of arg_label * type_expr * class_type
+
+and class_signature =
+  { csig_self: type_expr;
+    csig_vars:
+      (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
+    csig_concr: Concr.t;
+    csig_inher: (Path.t * type_expr list) list }
+
+type class_declaration =
+  { cty_params: type_expr list;
+    mutable cty_type: class_type;
+    cty_path: Path.t;
+    cty_new: type_expr option;
+    cty_variance: Variance.t list;
+    cty_loc: Location.t;
+    cty_attributes: Parsetree.attributes;
+    cty_uid: Uid.t;
+ }
+
+type class_type_declaration =
+  { clty_params: type_expr list;
+    clty_type: class_type;
+    clty_path: Path.t;
+    clty_variance: Variance.t list;
+    clty_loc: Location.t;
+    clty_attributes: Parsetree.attributes;
+    clty_uid: Uid.t;
+  }
+
+(* Type expressions for the module language *)
+
+type visibility =
+  | Exported
+  | Hidden
+
+type module_type =
+    Mty_ident of Path.t
+  | Mty_signature of signature
+  | Mty_functor of functor_parameter * module_type
+  | Mty_alias of Path.t
+
+and functor_parameter =
+  | Unit
+  | Named of Ident.t option * module_type
+
+and module_presence =
+  | Mp_present
+  | Mp_absent
+
+and signature = signature_item list
+
+and signature_item =
+    Sig_value of Ident.t * value_description * visibility
+  | Sig_type of Ident.t * type_declaration * rec_status * visibility
+  | Sig_typext of Ident.t * extension_constructor * ext_status * visibility
+  | Sig_module of
+      Ident.t * module_presence * module_declaration * rec_status * visibility
+  | Sig_modtype of Ident.t * modtype_declaration * visibility
+  | Sig_class of Ident.t * class_declaration * rec_status * visibility
+  | Sig_class_type of Ident.t * class_type_declaration * rec_status * visibility
+
+and module_declaration =
+  {
+    md_type: module_type;
+    md_attributes: Parsetree.attributes;
+    md_loc: Location.t;
+    md_uid: Uid.t;
+  }
+
+and modtype_declaration =
+  {
+    mtd_type: module_type option;  (* Note: abstract *)
+    mtd_attributes: Parsetree.attributes;
+    mtd_loc: Location.t;
+    mtd_uid: Uid.t;
+  }
+
+and rec_status =
+    Trec_not                   (* first in a nonrecursive group *)
+  | Trec_first                 (* first in a recursive group *)
+  | Trec_next                  (* not first in a recursive/nonrecursive group *)
+
+and ext_status =
+    Text_first                     (* first constructor of an extension *)
+  | Text_next                      (* not first constructor of an extension *)
+  | Text_exception                 (* an exception *)
+
+
+(* Constructor and record label descriptions inserted held in typing
+   environments *)
+
+type constructor_description =
+  { cstr_name: string;                  (* Constructor name *)
+    cstr_res: type_expr;                (* Type of the result *)
+    cstr_existentials: type_expr list;  (* list of existentials *)
+    cstr_args: type_expr list;          (* Type of the arguments *)
+    cstr_arity: int;                    (* Number of arguments *)
+    cstr_tag: constructor_tag;          (* Tag for heap blocks *)
+    cstr_consts: int;                   (* Number of constant constructors *)
+    cstr_nonconsts: int;                (* Number of non-const constructors *)
+    cstr_normal: int;                   (* Number of non generalized constrs *)
+    cstr_generalized: bool;             (* Constrained return type? *)
+    cstr_private: private_flag;         (* Read-only constructor? *)
+    cstr_loc: Location.t;
+    cstr_attributes: Parsetree.attributes;
+    cstr_inlined: type_declaration option;
+    cstr_uid: Uid.t;
+   }
+
+and constructor_tag =
+    Cstr_constant of int                (* Constant constructor (an int) *)
+  | Cstr_block of int                   (* Regular constructor (a block) *)
+  | Cstr_unboxed                        (* Constructor of an unboxed type *)
+  | Cstr_extension of Path.t * bool     (* Extension constructor
+                                           true if a constant false if a block*)
+
+let equal_tag t1 t2 =
+  match (t1, t2) with
+  | Cstr_constant i1, Cstr_constant i2 -> i2 = i1
+  | Cstr_block i1, Cstr_block i2 -> i2 = i1
+  | Cstr_unboxed, Cstr_unboxed -> true
+  | Cstr_extension (path1, b1), Cstr_extension (path2, b2) ->
+      Path.same path1 path2 && b1 = b2
+  | (Cstr_constant _|Cstr_block _|Cstr_unboxed|Cstr_extension _), _ -> false
+
+let may_equal_constr c1 c2 =
+  c1.cstr_arity = c2.cstr_arity
+  && (match c1.cstr_tag,c2.cstr_tag with
+     | Cstr_extension _,Cstr_extension _ ->
+         (* extension constructors may be rebindings of each other *)
+         true
+     | tag1, tag2 ->
+         equal_tag tag1 tag2)
+
+type label_description =
+  { lbl_name: string;                   (* Short name *)
+    lbl_res: type_expr;                 (* Type of the result *)
+    lbl_arg: type_expr;                 (* Type of the argument *)
+    lbl_mut: mutable_flag;              (* Is this a mutable field? *)
+    lbl_pos: int;                       (* Position in block *)
+    lbl_all: label_description array;   (* All the labels in this type *)
+    lbl_repres: record_representation;  (* Representation for this record *)
+    lbl_private: private_flag;          (* Read-only field? *)
+    lbl_loc: Location.t;
+    lbl_attributes: Parsetree.attributes;
+    lbl_uid: Uid.t;
+   }
+
+let rec bound_value_identifiers = function
+    [] -> []
+  | Sig_value(id, {val_kind = Val_reg}, _) :: rem ->
+      id :: bound_value_identifiers rem
+  | Sig_typext(id, _, _, _) :: rem -> id :: bound_value_identifiers rem
+  | Sig_module(id, Mp_present, _, _, _) :: rem ->
+      id :: bound_value_identifiers rem
+  | Sig_class(id, _, _, _) :: rem -> id :: bound_value_identifiers rem
+  | _ :: rem -> bound_value_identifiers rem
+
+let signature_item_id = function
+  | Sig_value (id, _, _)
+  | Sig_type (id, _, _, _)
+  | Sig_typext (id, _, _, _)
+  | Sig_module (id, _, _, _, _)
+  | Sig_modtype (id, _, _)
+  | Sig_class (id, _, _, _)
+  | Sig_class_type (id, _, _, _)
+    -> id
diff --git a/upstream/ocaml_413/typing/types.mli b/upstream/ocaml_413/typing/types.mli
new file mode 100644
index 0000000..1fa3483
--- /dev/null
+++ b/upstream/ocaml_413/typing/types.mli
@@ -0,0 +1,589 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** {0 Representation of types and declarations} *)
+
+(** [Types] defines the representation of types and declarations (that is, the
+    content of module signatures).
+
+    CMI files are made of marshalled types.
+*)
+
+(** Asttypes exposes basic definitions shared both by Parsetree and Types. *)
+open Asttypes
+
+(** Type expressions for the core language.
+
+    The [type_desc] variant defines all the possible type expressions one can
+    find in OCaml. [type_expr] wraps this with some annotations.
+
+    The [level] field tracks the level of polymorphism associated to a type,
+    guiding the generalization algorithm.
+    Put shortly, when referring to a type in a given environment, both the type
+    and the environment have a level. If the type has an higher level, then it
+    can be considered fully polymorphic (type variables will be printed as
+    ['a]), otherwise it'll be weakly polymorphic, or non generalized (type
+    variables printed as ['_a]).
+    See [http://okmij.org/ftp/ML/generalization.html] for more information.
+
+    Note about [type_declaration]: one should not make the confusion between
+    [type_expr] and [type_declaration].
+
+    [type_declaration] refers specifically to the [type] construct in OCaml
+    language, where you create and name a new type or type alias.
+
+    [type_expr] is used when you refer to existing types, e.g. when annotating
+    the expected type of a value.
+
+    Also, as the type system of OCaml is generative, a [type_declaration] can
+    have the side-effect of introducing a new type constructor, different from
+    all other known types.
+    Whereas [type_expr] is a pure construct which allows referring to existing
+    types.
+
+    Note on mutability: TBD.
+ *)
+type type_expr = private
+  { mutable desc: type_desc;
+    mutable level: int;
+    mutable scope: int;
+    id: int }
+
+and type_desc =
+  | Tvar of string option
+  (** [Tvar (Some "a")] ==> ['a] or ['_a]
+      [Tvar None]       ==> [_] *)
+
+  | Tarrow of arg_label * type_expr * type_expr * commutable
+  (** [Tarrow (Nolabel,      e1, e2, c)] ==> [e1    -> e2]
+      [Tarrow (Labelled "l", e1, e2, c)] ==> [l:e1  -> e2]
+      [Tarrow (Optional "l", e1, e2, c)] ==> [?l:e1 -> e2]
+
+      See [commutable] for the last argument. *)
+
+  | Ttuple of type_expr list
+  (** [Ttuple [t1;...;tn]] ==> [(t1 * ... * tn)] *)
+
+  | Tconstr of Path.t * type_expr list * abbrev_memo ref
+  (** [Tconstr (`A.B.t', [t1;...;tn], _)] ==> [(t1,...,tn) A.B.t]
+      The last parameter keep tracks of known expansions, see [abbrev_memo]. *)
+
+  | Tobject of type_expr * (Path.t * type_expr list) option ref
+  (** [Tobject (`f1:t1;...;fn: tn', `None')] ==> [< f1: t1; ...; fn: tn >]
+      f1, fn are represented as a linked list of types using Tfield and Tnil
+      constructors.
+
+      [Tobject (_, `Some (`A.ct', [t1;...;tn]')] ==> [(t1, ..., tn) A.ct].
+      where A.ct is the type of some class.
+
+      There are also special cases for so-called "class-types", cf. [Typeclass]
+      and [Ctype.set_object_name]:
+
+        [Tobject (Tfield(_,_,...(Tfield(_,_,rv)...),
+                         Some(`A.#ct`, [rv;t1;...;tn])]
+             ==> [(t1, ..., tn) #A.ct]
+        [Tobject (_, Some(`A.#ct`, [Tnil;t1;...;tn])] ==> [(t1, ..., tn) A.ct]
+
+      where [rv] is the hidden row variable.
+  *)
+
+  | Tfield of string * field_kind * type_expr * type_expr
+  (** [Tfield ("foo", Fpresent, t, ts)] ==> [<...; foo : t; ts>] *)
+
+  | Tnil
+  (** [Tnil] ==> [<...; >] *)
+
+  | Tlink of type_expr
+  (** Indirection used by unification engine. *)
+
+  | Tsubst of type_expr * type_expr option
+  (** [Tsubst] is used temporarily to store information in low-level
+      functions manipulating representation of types, such as
+      instantiation or copy.
+      The first argument contains a copy of the original node.
+      The second is available only when the first is the row variable of
+      a polymorphic variant.  It then contains a copy of the whole variant.
+      This constructor should not appear outside of these cases. *)
+
+  | Tvariant of row_desc
+  (** Representation of polymorphic variants, see [row_desc]. *)
+
+  | Tunivar of string option
+  (** Occurrence of a type variable introduced by a
+      forall quantifier / [Tpoly]. *)
+
+  | Tpoly of type_expr * type_expr list
+  (** [Tpoly (ty,tyl)] ==> ['a1... 'an. ty],
+      where 'a1 ... 'an are names given to types in tyl
+      and occurrences of those types in ty. *)
+
+  | Tpackage of Path.t * (Longident.t * type_expr) list
+  (** Type of a first-class module (a.k.a package). *)
+
+(** [  `X | `Y ]       (row_closed = true)
+    [< `X | `Y ]       (row_closed = true)
+    [> `X | `Y ]       (row_closed = false)
+    [< `X | `Y > `X ]  (row_closed = true)
+
+    type t = [> `X ] as 'a      (row_more = Tvar a)
+    type t = private [> `X ]    (row_more = Tconstr (t#row, [], ref Mnil))
+
+    And for:
+
+        let f = function `X -> `X -> | `Y -> `X
+
+    the type of "f" will be a [Tarrow] whose lhs will (basically) be:
+
+        Tvariant { row_fields = [("X", _)];
+                   row_more   =
+                     Tvariant { row_fields = [("Y", _)];
+                                row_more   =
+                                  Tvariant { row_fields = [];
+                                             row_more   = _;
+                                             _ };
+                                _ };
+                   _
+                 }
+
+*)
+and row_desc =
+    { row_fields: (label * row_field) list;
+      row_more: type_expr;
+      row_bound: unit; (* kept for compatibility *)
+      row_closed: bool;
+      row_fixed: fixed_explanation option;
+      row_name: (Path.t * type_expr list) option }
+and fixed_explanation =
+  | Univar of type_expr (** The row type was bound to an univar *)
+  | Fixed_private (** The row type is private *)
+  | Reified of Path.t (** The row was reified *)
+  | Rigid (** The row type was made rigid during constraint verification *)
+and row_field =
+    Rpresent of type_expr option
+  | Reither of bool * type_expr list * bool * row_field option ref
+        (* 1st true denotes a constant constructor *)
+        (* 2nd true denotes a tag in a pattern matching, and
+           is erased later *)
+  | Rabsent
+
+(** [abbrev_memo] allows one to keep track of different expansions of a type
+    alias. This is done for performance purposes.
+
+    For instance, when defining [type 'a pair = 'a * 'a], when one refers to an
+    ['a pair], it is just a shortcut for the ['a * 'a] type.
+    This expansion will be stored in the [abbrev_memo] of the corresponding
+    [Tconstr] node.
+
+    In practice, [abbrev_memo] behaves like list of expansions with a mutable
+    tail.
+
+    Note on marshalling: [abbrev_memo] must not appear in saved types.
+    [Btype], with [cleanup_abbrev] and [memo], takes care of tracking and
+    removing abbreviations.
+*)
+and abbrev_memo =
+  | Mnil (** No known abbreviation *)
+
+  | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo
+  (** Found one abbreviation.
+      A valid abbreviation should be at least as visible and reachable by the
+      same path.
+      The first expression is the abbreviation and the second the expansion. *)
+
+  | Mlink of abbrev_memo ref
+  (** Abbreviations can be found after this indirection *)
+
+and field_kind =
+    Fvar of field_kind option ref
+  | Fpresent
+  | Fabsent
+
+(** [commutable] is a flag appended to every arrow type.
+
+    When typing an application, if the type of the functional is
+    known, its type is instantiated with [Cok] arrows, otherwise as
+    [Clink (ref Cunknown)].
+
+    When the type is not known, the application will be used to infer
+    the actual type.  This is fragile in presence of labels where
+    there is no principal type.
+
+    Two incompatible applications relying on [Cunknown] arrows will
+    trigger an error.
+
+    let f g =
+      g ~a:() ~b:();
+      g ~b:() ~a:();
+
+    Error: This function is applied to arguments
+    in an order different from other calls.
+    This is only allowed when the real type is known.
+*)
+and commutable =
+    Cok
+  | Cunknown
+  | Clink of commutable ref
+
+module Private_type_expr : sig
+  val create : type_desc -> level: int -> scope: int -> id: int -> type_expr
+  val set_desc : type_expr -> type_desc -> unit
+  val set_level : type_expr -> int -> unit
+  val set_scope : type_expr -> int -> unit
+end
+
+module TypeOps : sig
+  type t = type_expr
+  val compare : t -> t -> int
+  val equal : t -> t -> bool
+  val hash : t -> int
+end
+
+(* *)
+
+module Uid : sig
+  type t
+
+  val reinit : unit -> unit
+
+  val mk : current_unit:string -> t
+  val of_compilation_unit_id : Ident.t -> t
+  val of_predef_id : Ident.t -> t
+  val internal_not_actually_unique : t
+
+  val for_actual_declaration : t -> bool
+
+  include Identifiable.S with type t := t
+end
+
+(* Maps of methods and instance variables *)
+
+module Meths : Map.S with type key = string
+module Vars  : Map.S with type key = string
+
+(* Value descriptions *)
+
+type value_description =
+  { val_type: type_expr;                (* Type of the value *)
+    val_kind: value_kind;
+    val_loc: Location.t;
+    val_attributes: Parsetree.attributes;
+    val_uid: Uid.t;
+  }
+
+and value_kind =
+    Val_reg                             (* Regular value *)
+  | Val_prim of Primitive.description   (* Primitive *)
+  | Val_ivar of mutable_flag * string   (* Instance variable (mutable ?) *)
+  | Val_self of (Ident.t * type_expr) Meths.t ref *
+                (Ident.t * mutable_flag * virtual_flag * type_expr) Vars.t ref *
+                string * type_expr
+                                        (* Self *)
+  | Val_anc of (string * Ident.t) list * string
+                                        (* Ancestor *)
+
+(* Variance *)
+
+module Variance : sig
+  type t
+  type f =
+      May_pos                (* allow positive occurrences *)
+    | May_neg                (* allow negative occurrences *)
+    | May_weak               (* allow occurrences under a negative position *)
+    | Inj                    (* type is injective in this parameter *)
+    | Pos                    (* there is a positive occurrence *)
+    | Neg                    (* there is a negative occurrence *)
+    | Inv                    (* both negative and positive occurrences *)
+  val null : t               (* no occurrence *)
+  val full : t               (* strictly invariant (all flags) *)
+  val covariant : t          (* strictly covariant (May_pos, Pos and Inj) *)
+  val unknown : t            (* allow everything, guarantee nothing *)
+  val union  : t -> t -> t
+  val inter  : t -> t -> t
+  val subset : t -> t -> bool
+  val eq : t -> t -> bool
+  val set : f -> bool -> t -> t
+  val mem : f -> t -> bool
+  val conjugate : t -> t                (* exchange positive and negative *)
+  val get_upper : t -> bool * bool                  (* may_pos, may_neg   *)
+  val get_lower : t -> bool * bool * bool * bool    (* pos, neg, inv, inj *)
+  val unknown_signature : injective:bool -> arity:int -> t list
+  (** The most pessimistic variance for a completely unknown type. *)
+end
+
+module Separability : sig
+  (** see {!Typedecl_separability} for an explanation of separability
+      and separability modes.*)
+
+  type t = Ind | Sep | Deepsep
+  val eq : t -> t -> bool
+  val print : Format.formatter -> t -> unit
+
+  val rank : t -> int
+  (** Modes are ordered from the least to the most demanding:
+      Ind < Sep < Deepsep.
+      'rank' maps them to integers in an order-respecting way:
+      m1 < m2  <=>  rank m1 < rank m2 *)
+
+  val compare : t -> t -> int
+  (** Compare two mode according to their mode ordering. *)
+
+  val max : t -> t -> t
+  (** [max_mode m1 m2] returns the most demanding mode. It is used to
+      express the conjunction of two parameter mode constraints. *)
+
+  type signature = t list
+  (** The 'separability signature' of a type assigns a mode for
+      each of its parameters. [('a, 'b) t] has mode [(m1, m2)] if
+      [(t1, t2) t] is separable whenever [t1, t2] have mode [m1, m2]. *)
+
+  val print_signature : Format.formatter -> signature -> unit
+
+  val default_signature : arity:int -> signature
+  (** The most pessimistic separability for a completely unknown type. *)
+end
+
+(* Type definitions *)
+
+type type_declaration =
+  { type_params: type_expr list;
+    type_arity: int;
+    type_kind: type_decl_kind;
+    type_private: private_flag;
+    type_manifest: type_expr option;
+    type_variance: Variance.t list;
+    (* covariant, contravariant, weakly contravariant, injective *)
+    type_separability: Separability.t list;
+    type_is_newtype: bool;
+    type_expansion_scope: int;
+    type_loc: Location.t;
+    type_attributes: Parsetree.attributes;
+    type_immediate: Type_immediacy.t;
+    type_unboxed_default: bool;
+    (* true if the unboxed-ness of this type was chosen by a compiler flag *)
+    type_uid: Uid.t;
+  }
+
+and type_decl_kind = (label_declaration, constructor_declaration) type_kind
+
+and ('lbl, 'cstr) type_kind =
+    Type_abstract
+  | Type_record of 'lbl list  * record_representation
+  | Type_variant of 'cstr list * variant_representation
+  | Type_open
+
+and record_representation =
+    Record_regular                      (* All fields are boxed / tagged *)
+  | Record_float                        (* All fields are floats *)
+  | Record_unboxed of bool    (* Unboxed single-field record, inlined or not *)
+  | Record_inlined of int               (* Inlined record *)
+  | Record_extension of Path.t          (* Inlined record under extension *)
+
+and variant_representation =
+    Variant_regular          (* Constant or boxed constructors *)
+  | Variant_unboxed          (* One unboxed single-field constructor *)
+
+and label_declaration =
+  {
+    ld_id: Ident.t;
+    ld_mutable: mutable_flag;
+    ld_type: type_expr;
+    ld_loc: Location.t;
+    ld_attributes: Parsetree.attributes;
+    ld_uid: Uid.t;
+  }
+
+and constructor_declaration =
+  {
+    cd_id: Ident.t;
+    cd_args: constructor_arguments;
+    cd_res: type_expr option;
+    cd_loc: Location.t;
+    cd_attributes: Parsetree.attributes;
+    cd_uid: Uid.t;
+  }
+
+and constructor_arguments =
+  | Cstr_tuple of type_expr list
+  | Cstr_record of label_declaration list
+
+type extension_constructor =
+  {
+    ext_type_path: Path.t;
+    ext_type_params: type_expr list;
+    ext_args: constructor_arguments;
+    ext_ret_type: type_expr option;
+    ext_private: private_flag;
+    ext_loc: Location.t;
+    ext_attributes: Parsetree.attributes;
+    ext_uid: Uid.t;
+  }
+
+and type_transparence =
+    Type_public      (* unrestricted expansion *)
+  | Type_new         (* "new" type *)
+  | Type_private     (* private type *)
+
+(* Type expressions for the class language *)
+
+module Concr : Set.S with type elt = string
+
+type class_type =
+    Cty_constr of Path.t * type_expr list * class_type
+  | Cty_signature of class_signature
+  | Cty_arrow of arg_label * type_expr * class_type
+
+and class_signature =
+  { csig_self: type_expr;
+    csig_vars:
+      (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
+    csig_concr: Concr.t;
+    csig_inher: (Path.t * type_expr list) list }
+
+type class_declaration =
+  { cty_params: type_expr list;
+    mutable cty_type: class_type;
+    cty_path: Path.t;
+    cty_new: type_expr option;
+    cty_variance: Variance.t list;
+    cty_loc: Location.t;
+    cty_attributes: Parsetree.attributes;
+    cty_uid: Uid.t;
+  }
+
+type class_type_declaration =
+  { clty_params: type_expr list;
+    clty_type: class_type;
+    clty_path: Path.t;
+    clty_variance: Variance.t list;
+    clty_loc: Location.t;
+    clty_attributes: Parsetree.attributes;
+    clty_uid: Uid.t;
+  }
+
+(* Type expressions for the module language *)
+
+type visibility =
+  | Exported
+  | Hidden
+
+type module_type =
+    Mty_ident of Path.t
+  | Mty_signature of signature
+  | Mty_functor of functor_parameter * module_type
+  | Mty_alias of Path.t
+
+and functor_parameter =
+  | Unit
+  | Named of Ident.t option * module_type
+
+and module_presence =
+  | Mp_present
+  | Mp_absent
+
+and signature = signature_item list
+
+and signature_item =
+    Sig_value of Ident.t * value_description * visibility
+  | Sig_type of Ident.t * type_declaration * rec_status * visibility
+  | Sig_typext of Ident.t * extension_constructor * ext_status * visibility
+  | Sig_module of
+      Ident.t * module_presence * module_declaration * rec_status * visibility
+  | Sig_modtype of Ident.t * modtype_declaration * visibility
+  | Sig_class of Ident.t * class_declaration * rec_status * visibility
+  | Sig_class_type of Ident.t * class_type_declaration * rec_status * visibility
+
+and module_declaration =
+  {
+    md_type: module_type;
+    md_attributes: Parsetree.attributes;
+    md_loc: Location.t;
+    md_uid: Uid.t;
+  }
+
+and modtype_declaration =
+  {
+    mtd_type: module_type option;  (* None: abstract *)
+    mtd_attributes: Parsetree.attributes;
+    mtd_loc: Location.t;
+    mtd_uid: Uid.t;
+  }
+
+and rec_status =
+    Trec_not                   (* first in a nonrecursive group *)
+  | Trec_first                 (* first in a recursive group *)
+  | Trec_next                  (* not first in a recursive/nonrecursive group *)
+
+and ext_status =
+    Text_first                     (* first constructor in an extension *)
+  | Text_next                      (* not first constructor in an extension *)
+  | Text_exception
+
+
+(* Constructor and record label descriptions inserted held in typing
+   environments *)
+
+type constructor_description =
+  { cstr_name: string;                  (* Constructor name *)
+    cstr_res: type_expr;                (* Type of the result *)
+    cstr_existentials: type_expr list;  (* list of existentials *)
+    cstr_args: type_expr list;          (* Type of the arguments *)
+    cstr_arity: int;                    (* Number of arguments *)
+    cstr_tag: constructor_tag;          (* Tag for heap blocks *)
+    cstr_consts: int;                   (* Number of constant constructors *)
+    cstr_nonconsts: int;                (* Number of non-const constructors *)
+    cstr_normal: int;                   (* Number of non generalized constrs *)
+    cstr_generalized: bool;             (* Constrained return type? *)
+    cstr_private: private_flag;         (* Read-only constructor? *)
+    cstr_loc: Location.t;
+    cstr_attributes: Parsetree.attributes;
+    cstr_inlined: type_declaration option;
+    cstr_uid: Uid.t;
+   }
+
+and constructor_tag =
+    Cstr_constant of int                (* Constant constructor (an int) *)
+  | Cstr_block of int                   (* Regular constructor (a block) *)
+  | Cstr_unboxed                        (* Constructor of an unboxed type *)
+  | Cstr_extension of Path.t * bool     (* Extension constructor
+                                           true if a constant false if a block*)
+
+(* Constructors are the same *)
+val equal_tag :  constructor_tag -> constructor_tag -> bool
+
+(* Constructors may be the same, given potential rebinding *)
+val may_equal_constr :
+    constructor_description ->  constructor_description -> bool
+
+type label_description =
+  { lbl_name: string;                   (* Short name *)
+    lbl_res: type_expr;                 (* Type of the result *)
+    lbl_arg: type_expr;                 (* Type of the argument *)
+    lbl_mut: mutable_flag;              (* Is this a mutable field? *)
+    lbl_pos: int;                       (* Position in block *)
+    lbl_all: label_description array;   (* All the labels in this type *)
+    lbl_repres: record_representation;  (* Representation for this record *)
+    lbl_private: private_flag;          (* Read-only field? *)
+    lbl_loc: Location.t;
+    lbl_attributes: Parsetree.attributes;
+    lbl_uid: Uid.t;
+  }
+
+(** Extracts the list of "value" identifiers bound by a signature.
+    "Value" identifiers are identifiers for signature components that
+    correspond to a run-time value: values, extensions, modules, classes.
+    Note: manifest primitives do not correspond to a run-time value! *)
+val bound_value_identifiers: signature -> Ident.t list
+
+val signature_item_id : signature_item -> Ident.t
diff --git a/upstream/ocaml_413/typing/typetexp.ml b/upstream/ocaml_413/typing/typetexp.ml
new file mode 100644
index 0000000..b1a908a
--- /dev/null
+++ b/upstream/ocaml_413/typing/typetexp.ml
@@ -0,0 +1,808 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* typetexp.ml,v 1.34.4.9 2002/01/07 08:39:16 garrigue Exp *)
+
+(* Typechecking of type expressions for the core language *)
+
+open Asttypes
+open Misc
+open Parsetree
+open Typedtree
+open Types
+open Ctype
+
+exception Already_bound
+
+type error =
+    Unbound_type_variable of string
+  | Undefined_type_constructor of Path.t
+  | Type_arity_mismatch of Longident.t * int * int
+  | Bound_type_variable of string
+  | Recursive_type
+  | Unbound_row_variable of Longident.t
+  | Type_mismatch of Errortrace.unification Errortrace.t
+  | Alias_type_mismatch of Errortrace.unification Errortrace.t
+  | Present_has_conjunction of string
+  | Present_has_no_type of string
+  | Constructor_mismatch of type_expr * type_expr
+  | Not_a_variant of type_expr
+  | Variant_tags of string * string
+  | Invalid_variable_name of string
+  | Cannot_quantify of string * type_expr
+  | Multiple_constraints_on_type of Longident.t
+  | Method_mismatch of string * type_expr * type_expr
+  | Opened_object of Path.t option
+  | Not_an_object of type_expr
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+(** Map indexed by type variable names. *)
+module TyVarMap = Misc.Stdlib.String.Map
+
+type variable_context = int * type_expr TyVarMap.t
+
+(* Support for first-class modules. *)
+
+let transl_modtype_longident = ref (fun _ -> assert false)
+let transl_modtype = ref (fun _ -> assert false)
+
+let create_package_mty fake loc env (p, l) =
+  let l =
+    List.sort
+      (fun (s1, _t1) (s2, _t2) ->
+         if s1.txt = s2.txt then
+           raise (Error (loc, env, Multiple_constraints_on_type s1.txt));
+         compare s1.txt s2.txt)
+      l
+  in
+  l,
+  List.fold_left
+    (fun mty (s, t) ->
+      let d = {ptype_name = mkloc (Longident.last s.txt) s.loc;
+               ptype_params = [];
+               ptype_cstrs = [];
+               ptype_kind = Ptype_abstract;
+               ptype_private = Asttypes.Public;
+               ptype_manifest = if fake then None else Some t;
+               ptype_attributes = [];
+               ptype_loc = loc} in
+      Ast_helper.Mty.mk ~loc
+        (Pmty_with (mty, [ Pwith_type ({ txt = s.txt; loc }, d) ]))
+    )
+    (Ast_helper.Mty.mk ~loc (Pmty_ident p))
+    l
+
+(* Translation of type expressions *)
+
+let type_variables = ref (TyVarMap.empty : type_expr TyVarMap.t)
+let univars        = ref ([] : (string * type_expr) list)
+let pre_univars    = ref ([] : type_expr list)
+let used_variables = ref (TyVarMap.empty : (type_expr * Location.t) TyVarMap.t)
+
+let reset_type_variables () =
+  reset_global_level ();
+  Ctype.reset_reified_var_counter ();
+  type_variables := TyVarMap.empty
+
+let narrow () =
+  (increase_global_level (), !type_variables)
+
+let widen (gl, tv) =
+  restore_global_level gl;
+  type_variables := tv
+
+let strict_ident c = (c = '_' || c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z')
+
+let validate_name = function
+    None -> None
+  | Some name as s ->
+      if name <> "" && strict_ident name.[0] then s else None
+
+let new_global_var ?name () =
+  new_global_var ?name:(validate_name name) ()
+let newvar ?name () =
+  newvar ?name:(validate_name name) ()
+
+let type_variable loc name =
+  try
+    TyVarMap.find name !type_variables
+  with Not_found ->
+    raise(Error(loc, Env.empty, Unbound_type_variable ("'" ^ name)))
+
+let valid_tyvar_name name =
+  name <> "" && name.[0] <> '_'
+
+let transl_type_param env styp =
+  let loc = styp.ptyp_loc in
+  match styp.ptyp_desc with
+    Ptyp_any ->
+      let ty = new_global_var ~name:"_" () in
+        { ctyp_desc = Ttyp_any; ctyp_type = ty; ctyp_env = env;
+          ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; }
+  | Ptyp_var name ->
+      let ty =
+        try
+          if not (valid_tyvar_name name) then
+            raise (Error (loc, Env.empty, Invalid_variable_name ("'" ^ name)));
+          ignore (TyVarMap.find name !type_variables);
+          raise Already_bound
+        with Not_found ->
+          let v = new_global_var ~name () in
+            type_variables := TyVarMap.add name v !type_variables;
+            v
+      in
+        { ctyp_desc = Ttyp_var name; ctyp_type = ty; ctyp_env = env;
+          ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; }
+  | _ -> assert false
+
+let transl_type_param env styp =
+  (* Currently useless, since type parameters cannot hold attributes
+     (but this could easily be lifted in the future). *)
+  Builtin_attributes.warning_scope styp.ptyp_attributes
+    (fun () -> transl_type_param env styp)
+
+
+let new_pre_univar ?name () =
+  let v = newvar ?name () in pre_univars := v :: !pre_univars; v
+
+type policy = Fixed | Extensible | Univars
+
+let rec transl_type env policy styp =
+  Builtin_attributes.warning_scope styp.ptyp_attributes
+    (fun () -> transl_type_aux env policy styp)
+
+and transl_type_aux env policy styp =
+  let loc = styp.ptyp_loc in
+  let ctyp ctyp_desc ctyp_type =
+    { ctyp_desc; ctyp_type; ctyp_env = env;
+      ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes }
+  in
+  match styp.ptyp_desc with
+    Ptyp_any ->
+      let ty =
+        if policy = Univars then new_pre_univar () else
+          if policy = Fixed then
+            raise (Error (styp.ptyp_loc, env, Unbound_type_variable "_"))
+          else newvar ()
+      in
+      ctyp Ttyp_any ty
+  | Ptyp_var name ->
+    let ty =
+      if not (valid_tyvar_name name) then
+        raise (Error (styp.ptyp_loc, env, Invalid_variable_name ("'" ^ name)));
+      begin try
+        instance (List.assoc name !univars)
+      with Not_found -> try
+        instance (fst (TyVarMap.find name !used_variables))
+      with Not_found ->
+        let v =
+          if policy = Univars then new_pre_univar ~name () else newvar ~name ()
+        in
+        used_variables := TyVarMap.add name (v, styp.ptyp_loc) !used_variables;
+        v
+      end
+    in
+    ctyp (Ttyp_var name) ty
+  | Ptyp_arrow(l, st1, st2) ->
+    let cty1 = transl_type env policy st1 in
+    let cty2 = transl_type env policy st2 in
+    let ty1 = cty1.ctyp_type in
+    let ty1 =
+      if Btype.is_optional l
+      then newty (Tconstr(Predef.path_option,[ty1], ref Mnil))
+      else ty1 in
+    let ty = newty (Tarrow(l, ty1, cty2.ctyp_type, Cok)) in
+    ctyp (Ttyp_arrow (l, cty1, cty2)) ty
+  | Ptyp_tuple stl ->
+    assert (List.length stl >= 2);
+    let ctys = List.map (transl_type env policy) stl in
+    let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in
+    ctyp (Ttyp_tuple ctys) ty
+  | Ptyp_constr(lid, stl) ->
+      let (path, decl) = Env.lookup_type ~loc:lid.loc lid.txt env in
+      let stl =
+        match stl with
+        | [ {ptyp_desc=Ptyp_any} as t ] when decl.type_arity > 1 ->
+            List.map (fun _ -> t) decl.type_params
+        | _ -> stl
+      in
+      if List.length stl <> decl.type_arity then
+        raise(Error(styp.ptyp_loc, env,
+                    Type_arity_mismatch(lid.txt, decl.type_arity,
+                                        List.length stl)));
+      let args = List.map (transl_type env policy) stl in
+      let params = instance_list decl.type_params in
+      let unify_param =
+        match decl.type_manifest with
+          None -> unify_var
+        | Some ty ->
+            if (repr ty).level = Btype.generic_level then unify_var else unify
+      in
+      List.iter2
+        (fun (sty, cty) ty' ->
+           try unify_param env ty' cty.ctyp_type with Unify trace ->
+             let trace = Errortrace.swap_trace trace in
+             raise (Error(sty.ptyp_loc, env, Type_mismatch trace))
+        )
+        (List.combine stl args) params;
+      let constr =
+        newconstr path (List.map (fun ctyp -> ctyp.ctyp_type) args) in
+      ctyp (Ttyp_constr (path, lid, args)) constr
+  | Ptyp_object (fields, o) ->
+      let ty, fields = transl_fields env policy o fields in
+      ctyp (Ttyp_object (fields, o)) (newobj ty)
+  | Ptyp_class(lid, stl) ->
+      let (path, decl, _is_variant) =
+        try
+          let path, decl = Env.find_type_by_name lid.txt env in
+          let rec check decl =
+            match decl.type_manifest with
+              None -> raise Not_found
+            | Some ty ->
+                match (repr ty).desc with
+                  Tvariant row when Btype.static_row row -> ()
+                | Tconstr (path, _, _) ->
+                    check (Env.find_type path env)
+                | _ -> raise Not_found
+          in check decl;
+          Location.deprecated styp.ptyp_loc
+            "old syntax for polymorphic variant type";
+          ignore(Env.lookup_type ~loc:lid.loc lid.txt env);
+          (path, decl,true)
+        with Not_found -> try
+          let lid2 =
+            match lid.txt with
+              Longident.Lident s     -> Longident.Lident ("#" ^ s)
+            | Longident.Ldot(r, s)   -> Longident.Ldot (r, "#" ^ s)
+            | Longident.Lapply(_, _) -> fatal_error "Typetexp.transl_type"
+          in
+          let path, decl = Env.find_type_by_name lid2 env in
+          ignore(Env.lookup_cltype ~loc:lid.loc lid.txt env);
+          (path, decl, false)
+        with Not_found ->
+          ignore (Env.lookup_cltype ~loc:lid.loc lid.txt env); assert false
+      in
+      if List.length stl <> decl.type_arity then
+        raise(Error(styp.ptyp_loc, env,
+                    Type_arity_mismatch(lid.txt, decl.type_arity,
+                                        List.length stl)));
+      let args = List.map (transl_type env policy) stl in
+      let params = instance_list decl.type_params in
+      List.iter2
+        (fun (sty, cty) ty' ->
+           try unify_var env ty' cty.ctyp_type with Unify trace ->
+             let trace = Errortrace.swap_trace trace in
+             raise (Error(sty.ptyp_loc, env, Type_mismatch trace))
+        )
+        (List.combine stl args) params;
+        let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in
+      let ty =
+        try Ctype.expand_head env (newconstr path ty_args)
+        with Unify trace ->
+          raise (Error(styp.ptyp_loc, env, Type_mismatch trace))
+      in
+      let ty = match ty.desc with
+        Tvariant row ->
+          let row = Btype.row_repr row in
+          let fields =
+            List.map
+              (fun (l,f) -> l,
+                match Btype.row_field_repr f with
+                | Rpresent (Some ty) ->
+                    Reither(false, [ty], false, ref None)
+                | Rpresent None ->
+                    Reither (true, [], false, ref None)
+                | _ -> f)
+              row.row_fields
+          in
+          let row = { row_closed = true; row_fields = fields;
+                      row_bound = (); row_name = Some (path, ty_args);
+                      row_fixed = None; row_more = newvar () } in
+          let static = Btype.static_row row in
+          let row =
+            if static then { row with row_more = newty Tnil }
+            else if policy <> Univars then row
+            else { row with row_more = new_pre_univar () }
+          in
+          newty (Tvariant row)
+      | Tobject (fi, _) ->
+          let _, tv = flatten_fields fi in
+          if policy = Univars then pre_univars := tv :: !pre_univars;
+          ty
+      | _ ->
+          assert false
+      in
+      ctyp (Ttyp_class (path, lid, args)) ty
+  | Ptyp_alias(st, alias) ->
+      let cty =
+        try
+          let t =
+            try List.assoc alias !univars
+            with Not_found ->
+              instance (fst(TyVarMap.find alias !used_variables))
+          in
+          let ty = transl_type env policy st in
+          begin try unify_var env t ty.ctyp_type with Unify trace ->
+            let trace = Errortrace.swap_trace trace in
+            raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace))
+          end;
+          ty
+        with Not_found ->
+          if !Clflags.principal then begin_def ();
+          let t = newvar () in
+          used_variables :=
+            TyVarMap.add alias (t, styp.ptyp_loc) !used_variables;
+          let ty = transl_type env policy st in
+          begin try unify_var env t ty.ctyp_type with Unify trace ->
+            let trace = Errortrace.swap_trace trace in
+            raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace))
+          end;
+          if !Clflags.principal then begin
+            end_def ();
+            generalize_structure t;
+          end;
+          let t = instance t in
+          let px = Btype.proxy t in
+          begin match px.desc with
+          | Tvar None -> Btype.set_type_desc px (Tvar (Some alias))
+          | Tunivar None -> Btype.set_type_desc px (Tunivar (Some alias))
+          | _ -> ()
+          end;
+          { ty with ctyp_type = t }
+      in
+      ctyp (Ttyp_alias (cty, alias)) cty.ctyp_type
+  | Ptyp_variant(fields, closed, present) ->
+      let name = ref None in
+      let mkfield l f =
+        newty (Tvariant {row_fields=[l,f]; row_more=newvar();
+                         row_bound=(); row_closed=true;
+                         row_fixed=None; row_name=None}) in
+      let hfields = Hashtbl.create 17 in
+      let add_typed_field loc l f =
+        let h = Btype.hash_variant l in
+        try
+          let (l',f') = Hashtbl.find hfields h in
+          (* Check for tag conflicts *)
+          if l <> l' then raise(Error(styp.ptyp_loc, env, Variant_tags(l, l')));
+          let ty = mkfield l f and ty' = mkfield l f' in
+          if is_equal env false [ty] [ty'] then () else
+          try unify env ty ty'
+          with Unify _trace ->
+            raise(Error(loc, env, Constructor_mismatch (ty,ty')))
+        with Not_found ->
+          Hashtbl.add hfields h (l,f)
+      in
+      let add_field field =
+        let rf_loc = field.prf_loc in
+        let rf_attributes = field.prf_attributes in
+        let rf_desc = match field.prf_desc with
+        | Rtag (l, c, stl) ->
+            name := None;
+            let tl =
+              Builtin_attributes.warning_scope rf_attributes
+                (fun () -> List.map (transl_type env policy) stl)
+            in
+            let f = match present with
+              Some present when not (List.mem l.txt present) ->
+                let ty_tl = List.map (fun cty -> cty.ctyp_type) tl in
+                Reither(c, ty_tl, false, ref None)
+            | _ ->
+                if List.length stl > 1 || c && stl <> [] then
+                  raise(Error(styp.ptyp_loc, env,
+                              Present_has_conjunction l.txt));
+                match tl with [] -> Rpresent None
+                | st :: _ ->
+                      Rpresent (Some st.ctyp_type)
+            in
+            add_typed_field styp.ptyp_loc l.txt f;
+              Ttag (l,c,tl)
+        | Rinherit sty ->
+            let cty = transl_type env policy sty in
+            let ty = cty.ctyp_type in
+            let nm =
+              match repr cty.ctyp_type with
+                {desc=Tconstr(p, tl, _)} -> Some(p, tl)
+              | _                        -> None
+            in
+            name := if Hashtbl.length hfields <> 0 then None else nm;
+            let fl = match expand_head env cty.ctyp_type, nm with
+              {desc=Tvariant row}, _ when Btype.static_row row ->
+                let row = Btype.row_repr row in
+                row.row_fields
+            | {desc=Tvar _}, Some(p, _) ->
+                raise(Error(sty.ptyp_loc, env, Undefined_type_constructor p))
+            | _ ->
+                raise(Error(sty.ptyp_loc, env, Not_a_variant ty))
+            in
+            List.iter
+              (fun (l, f) ->
+                let f = match present with
+                  Some present when not (List.mem l present) ->
+                    begin match f with
+                      Rpresent(Some ty) ->
+                        Reither(false, [ty], false, ref None)
+                    | Rpresent None ->
+                        Reither(true, [], false, ref None)
+                    | _ ->
+                        assert false
+                    end
+                | _ -> f
+                in
+                add_typed_field sty.ptyp_loc l f)
+              fl;
+              Tinherit cty
+        in
+        { rf_desc; rf_loc; rf_attributes; }
+      in
+      let tfields = List.map add_field fields in
+      let fields = Hashtbl.fold (fun _ p l -> p :: l) hfields [] in
+      begin match present with None -> ()
+      | Some present ->
+          List.iter
+            (fun l -> if not (List.mem_assoc l fields) then
+              raise(Error(styp.ptyp_loc, env, Present_has_no_type l)))
+            present
+      end;
+      let row =
+        { row_fields = List.rev fields; row_more = newvar ();
+          row_bound = (); row_closed = (closed = Closed);
+          row_fixed = None; row_name = !name } in
+      let static = Btype.static_row row in
+      let row =
+        if static then { row with row_more = newty Tnil }
+        else if policy <> Univars then row
+        else { row with row_more = new_pre_univar () }
+      in
+      let ty = newty (Tvariant row) in
+      ctyp (Ttyp_variant (tfields, closed, present)) ty
+  | Ptyp_poly(vars, st) ->
+      let vars = List.map (fun v -> v.txt) vars in
+      begin_def();
+      let new_univars = List.map (fun name -> name, newvar ~name ()) vars in
+      let old_univars = !univars in
+      univars := new_univars @ !univars;
+      let cty = transl_type env policy st in
+      let ty = cty.ctyp_type in
+      univars := old_univars;
+      end_def();
+      generalize ty;
+      let ty_list =
+        List.fold_left
+          (fun tyl (name, ty1) ->
+            let v = Btype.proxy ty1 in
+            if deep_occur v ty then begin
+              match v.desc with
+                Tvar name when v.level = Btype.generic_level ->
+                  Btype.set_type_desc v (Tunivar name);
+                  v :: tyl
+              | _ ->
+                raise (Error (styp.ptyp_loc, env, Cannot_quantify (name, v)))
+            end else tyl)
+          [] new_univars
+      in
+      let ty' = Btype.newgenty (Tpoly(ty, List.rev ty_list)) in
+      unify_var env (newvar()) ty';
+      ctyp (Ttyp_poly (vars, cty)) ty'
+  | Ptyp_package (p, l) ->
+      let l, mty = create_package_mty true styp.ptyp_loc env (p, l) in
+      let z = narrow () in
+      let mty = !transl_modtype env mty in
+      widen z;
+      let ptys = List.map (fun (s, pty) ->
+                             s, transl_type env policy pty
+                          ) l in
+      let path = !transl_modtype_longident styp.ptyp_loc env p.txt in
+      let ty = newty (Tpackage (path,
+                       List.map (fun (s, cty) -> (s.txt, cty.ctyp_type)) ptys))
+      in
+      ctyp (Ttyp_package {
+            pack_path = path;
+            pack_type = mty.mty_type;
+            pack_fields = ptys;
+            pack_txt = p;
+           }) ty
+  | Ptyp_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and transl_poly_type env policy t =
+  transl_type env policy (Ast_helper.Typ.force_poly t)
+
+and transl_fields env policy o fields =
+  let hfields = Hashtbl.create 17 in
+  let add_typed_field loc l ty =
+    try
+      let ty' = Hashtbl.find hfields l in
+      if is_equal env false [ty] [ty'] then () else
+        try unify env ty ty'
+        with Unify _trace ->
+          raise(Error(loc, env, Method_mismatch (l, ty, ty')))
+    with Not_found ->
+      Hashtbl.add hfields l ty in
+  let add_field {pof_desc; pof_loc; pof_attributes;} =
+    let of_loc = pof_loc in
+    let of_attributes = pof_attributes in
+    let of_desc = match pof_desc with
+    | Otag (s, ty1) -> begin
+        let ty1 =
+          Builtin_attributes.warning_scope of_attributes
+            (fun () -> transl_poly_type env policy ty1)
+        in
+        let field = OTtag (s, ty1) in
+        add_typed_field ty1.ctyp_loc s.txt ty1.ctyp_type;
+        field
+      end
+    | Oinherit sty -> begin
+        let cty = transl_type env policy sty in
+        let nm =
+          match repr cty.ctyp_type with
+            {desc=Tconstr(p, _, _)} -> Some p
+          | _                        -> None in
+        let t = expand_head env cty.ctyp_type in
+        match t, nm with
+          {desc=Tobject ({desc=(Tfield _ | Tnil) as tf}, _)}, _ -> begin
+            if opened_object t then
+              raise (Error (sty.ptyp_loc, env, Opened_object nm));
+            let rec iter_add = function
+              | Tfield (s, _k, ty1, ty2) -> begin
+                  add_typed_field sty.ptyp_loc s ty1;
+                  iter_add ty2.desc
+                end
+              | Tnil -> ()
+              | _ -> assert false in
+            iter_add tf;
+            OTinherit cty
+            end
+        | {desc=Tvar _}, Some p ->
+            raise (Error (sty.ptyp_loc, env, Undefined_type_constructor p))
+        | _ -> raise (Error (sty.ptyp_loc, env, Not_an_object t))
+      end in
+    { of_desc; of_loc; of_attributes; }
+  in
+  let object_fields = List.map add_field fields in
+  let fields = Hashtbl.fold (fun s ty l -> (s, ty) :: l) hfields [] in
+  let ty_init =
+     match o, policy with
+     | Closed, _ -> newty Tnil
+     | Open, Univars -> new_pre_univar ()
+     | Open, _ -> newvar () in
+  let ty = List.fold_left (fun ty (s, ty') ->
+      newty (Tfield (s, Fpresent, ty', ty))) ty_init fields in
+  ty, object_fields
+
+
+(* Make the rows "fixed" in this type, to make universal check easier *)
+let rec make_fixed_univars ty =
+  let ty = repr ty in
+  if Btype.try_mark_node ty then
+    begin match ty.desc with
+    | Tvariant row ->
+        let row = Btype.row_repr row in
+        let more = Btype.row_more row in
+        if Btype.is_Tunivar more then
+          Btype.set_type_desc ty
+            (Tvariant
+               {row with row_fixed=Some(Univar more);
+                row_fields = List.map
+                 (fun (s,f as p) -> match Btype.row_field_repr f with
+                   Reither (c, tl, _m, r) -> s, Reither (c, tl, true, r)
+                 | _ -> p)
+                 row.row_fields});
+        Btype.iter_row make_fixed_univars row
+    | _ ->
+        Btype.iter_type_expr make_fixed_univars ty
+    end
+
+let make_fixed_univars ty =
+  make_fixed_univars ty;
+  Btype.unmark_type ty
+
+let create_package_mty = create_package_mty false
+
+let globalize_used_variables env fixed =
+  let r = ref [] in
+  TyVarMap.iter
+    (fun name (ty, loc) ->
+      let v = new_global_var () in
+      let snap = Btype.snapshot () in
+      if try unify env v ty; true with _ -> Btype.backtrack snap; false
+      then try
+        r := (loc, v,  TyVarMap.find name !type_variables) :: !r
+      with Not_found ->
+        if fixed && Btype.is_Tvar (repr ty) then
+          raise(Error(loc, env, Unbound_type_variable ("'"^name)));
+        let v2 = new_global_var () in
+        r := (loc, v, v2) :: !r;
+        type_variables := TyVarMap.add name v2 !type_variables)
+    !used_variables;
+  used_variables := TyVarMap.empty;
+  fun () ->
+    List.iter
+      (function (loc, t1, t2) ->
+        try unify env t1 t2 with Unify trace ->
+          raise (Error(loc, env, Type_mismatch trace)))
+      !r
+
+let transl_simple_type env fixed styp =
+  univars := []; used_variables := TyVarMap.empty;
+  let typ = transl_type env (if fixed then Fixed else Extensible) styp in
+  globalize_used_variables env fixed ();
+  make_fixed_univars typ.ctyp_type;
+  typ
+
+let transl_simple_type_univars env styp =
+  univars := []; used_variables := TyVarMap.empty; pre_univars := [];
+  begin_def ();
+  let typ = transl_type env Univars styp in
+  (* Only keep already global variables in used_variables *)
+  let new_variables = !used_variables in
+  used_variables := TyVarMap.empty;
+  TyVarMap.iter
+    (fun name p ->
+      if TyVarMap.mem name !type_variables then
+        used_variables := TyVarMap.add name p !used_variables)
+    new_variables;
+  globalize_used_variables env false ();
+  end_def ();
+  generalize typ.ctyp_type;
+  let univs =
+    List.fold_left
+      (fun acc v ->
+        let v = repr v in
+        match v.desc with
+          Tvar name when v.level = Btype.generic_level ->
+            Btype.set_type_desc v (Tunivar name); v :: acc
+        | _ -> acc)
+      [] !pre_univars
+  in
+  make_fixed_univars typ.ctyp_type;
+    { typ with ctyp_type =
+        instance (Btype.newgenty (Tpoly (typ.ctyp_type, univs))) }
+
+let transl_simple_type_delayed env styp =
+  univars := []; used_variables := TyVarMap.empty;
+  begin_def ();
+  let typ = transl_type env Extensible styp in
+  end_def ();
+  make_fixed_univars typ.ctyp_type;
+  (* This brings the used variables to the global level, but doesn't link them
+     to their other occurrences just yet. This will be done when [force] is
+     called. *)
+  let force = globalize_used_variables env false in
+  (* Generalizes everything except the variables that were just globalized. *)
+  generalize typ.ctyp_type;
+  (typ, instance typ.ctyp_type, force)
+
+let transl_type_scheme env styp =
+  reset_type_variables();
+  begin_def();
+  let typ = transl_simple_type env false styp in
+  end_def();
+  generalize typ.ctyp_type;
+  typ
+
+
+(* Error report *)
+
+open Format
+open Printtyp
+
+let report_error env ppf = function
+  | Unbound_type_variable name ->
+      let add_name name _ l = if name = "_" then l else ("'" ^ name) :: l in
+      let names = TyVarMap.fold add_name !type_variables [] in
+    fprintf ppf "The type variable %s is unbound in this type declaration.@ %a"
+      name
+      did_you_mean (fun () -> Misc.spellcheck names name )
+  | Undefined_type_constructor p ->
+    fprintf ppf "The type constructor@ %a@ is not yet completely defined"
+      path p
+  | Type_arity_mismatch(lid, expected, provided) ->
+    fprintf ppf
+      "@[The type constructor %a@ expects %i argument(s),@ \
+        but is here applied to %i argument(s)@]"
+      longident lid expected provided
+  | Bound_type_variable name ->
+    fprintf ppf "Already bound type parameter %a" Pprintast.tyvar name
+  | Recursive_type ->
+    fprintf ppf "This type is recursive"
+  | Unbound_row_variable lid ->
+      (* we don't use "spellcheck" here: this error is not raised
+         anywhere so it's unclear how it should be handled *)
+      fprintf ppf "Unbound row variable in #%a" longident lid
+  | Type_mismatch trace ->
+      Printtyp.report_unification_error ppf Env.empty trace
+        (function ppf ->
+           fprintf ppf "This type")
+        (function ppf ->
+           fprintf ppf "should be an instance of type")
+  | Alias_type_mismatch trace ->
+      Printtyp.report_unification_error ppf Env.empty trace
+        (function ppf ->
+           fprintf ppf "This alias is bound to type")
+        (function ppf ->
+           fprintf ppf "but is used as an instance of type")
+  | Present_has_conjunction l ->
+      fprintf ppf "The present constructor %s has a conjunctive type" l
+  | Present_has_no_type l ->
+      fprintf ppf
+        "@[<v>@[The constructor %s is missing from the upper bound@ \
+         (between '<'@ and '>')@ of this polymorphic variant@ \
+         but is present in@ its lower bound (after '>').@]@,\
+         @[Hint: Either add `%s in the upper bound,@ \
+         or remove it@ from the lower bound.@]@]"
+         l l
+  | Constructor_mismatch (ty, ty') ->
+      wrap_printing_env ~error:true env (fun ()  ->
+        Printtyp.reset_and_mark_loops_list [ty; ty'];
+        fprintf ppf "@[<hov>%s %a@ %s@ %a@]"
+          "This variant type contains a constructor"
+          !Oprint.out_type (tree_of_typexp false ty)
+          "which should be"
+           !Oprint.out_type (tree_of_typexp false ty'))
+  | Not_a_variant ty ->
+      fprintf ppf
+        "@[The type %a@ does not expand to a polymorphic variant type@]"
+        Printtyp.type_expr ty;
+      begin match ty.desc with
+        | Tvar (Some s) ->
+           (* PR#7012: help the user that wrote 'Foo instead of `Foo *)
+           Misc.did_you_mean ppf (fun () -> ["`" ^ s])
+        | _ -> ()
+      end
+  | Variant_tags (lab1, lab2) ->
+      fprintf ppf
+        "@[Variant tags `%s@ and `%s have the same hash value.@ %s@]"
+        lab1 lab2 "Change one of them."
+  | Invalid_variable_name name ->
+      fprintf ppf "The type variable name %s is not allowed in programs" name
+  | Cannot_quantify (name, v) ->
+      fprintf ppf
+        "@[<hov>The universal type variable %a cannot be generalized:@ "
+        Pprintast.tyvar name;
+      if Btype.is_Tvar v then
+        fprintf ppf "it escapes its scope"
+      else if Btype.is_Tunivar v then
+        fprintf ppf "it is already bound to another variable"
+      else
+        fprintf ppf "it is bound to@ %a" Printtyp.type_expr v;
+      fprintf ppf ".@]";
+  | Multiple_constraints_on_type s ->
+      fprintf ppf "Multiple constraints for type %a" longident s
+  | Method_mismatch (l, ty, ty') ->
+      wrap_printing_env ~error:true env (fun ()  ->
+        fprintf ppf "@[<hov>Method '%s' has type %a,@ which should be %a@]"
+          l Printtyp.type_expr ty Printtyp.type_expr ty')
+  | Opened_object nm ->
+      fprintf ppf
+        "Illegal open object type%a"
+        (fun ppf -> function
+             Some p -> fprintf ppf "@ %a" path p
+           | None -> fprintf ppf "") nm
+  | Not_an_object ty ->
+      fprintf ppf "@[The type %a@ is not an object type@]"
+        Printtyp.type_expr ty
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, env, err) ->
+        Some (Location.error_of_printer ~loc (report_error env) err)
+      | Error_forward err ->
+        Some err
+      | _ ->
+        None
+    )
diff --git a/upstream/ocaml_413/typing/typetexp.mli b/upstream/ocaml_413/typing/typetexp.mli
new file mode 100644
index 0000000..609305b
--- /dev/null
+++ b/upstream/ocaml_413/typing/typetexp.mli
@@ -0,0 +1,79 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Typechecking of type expressions for the core language *)
+
+open Types
+
+val valid_tyvar_name : string -> bool
+
+val transl_simple_type:
+        Env.t -> bool -> Parsetree.core_type -> Typedtree.core_type
+val transl_simple_type_univars:
+        Env.t -> Parsetree.core_type -> Typedtree.core_type
+val transl_simple_type_delayed
+  :  Env.t
+  -> Parsetree.core_type
+  -> Typedtree.core_type * type_expr * (unit -> unit)
+        (* Translate a type, but leave type variables unbound. Returns
+           the type, an instance of the corresponding type_expr, and a
+           function that binds the type variable. *)
+val transl_type_scheme:
+        Env.t -> Parsetree.core_type -> Typedtree.core_type
+val reset_type_variables: unit -> unit
+val type_variable: Location.t -> string -> type_expr
+val transl_type_param:
+  Env.t -> Parsetree.core_type -> Typedtree.core_type
+
+type variable_context
+val narrow: unit -> variable_context
+val widen: variable_context -> unit
+
+exception Already_bound
+
+type error =
+    Unbound_type_variable of string
+  | Undefined_type_constructor of Path.t
+  | Type_arity_mismatch of Longident.t * int * int
+  | Bound_type_variable of string
+  | Recursive_type
+  | Unbound_row_variable of Longident.t
+  | Type_mismatch of Errortrace.unification Errortrace.t
+  | Alias_type_mismatch of Errortrace.unification Errortrace.t
+  | Present_has_conjunction of string
+  | Present_has_no_type of string
+  | Constructor_mismatch of type_expr * type_expr
+  | Not_a_variant of type_expr
+  | Variant_tags of string * string
+  | Invalid_variable_name of string
+  | Cannot_quantify of string * type_expr
+  | Multiple_constraints_on_type of Longident.t
+  | Method_mismatch of string * type_expr * type_expr
+  | Opened_object of Path.t option
+  | Not_an_object of type_expr
+
+exception Error of Location.t * Env.t * error
+
+val report_error: Env.t -> Format.formatter -> error -> unit
+
+(* Support for first-class modules. *)
+val transl_modtype_longident:  (* from Typemod *)
+    (Location.t -> Env.t -> Longident.t -> Path.t) ref
+val transl_modtype: (* from Typemod *)
+    (Env.t -> Parsetree.module_type -> Typedtree.module_type) ref
+val create_package_mty:
+    Location.t -> Env.t -> Parsetree.package_type ->
+    (Longident.t Asttypes.loc * Parsetree.core_type) list *
+      Parsetree.module_type
diff --git a/upstream/ocaml_413/typing/untypeast.ml b/upstream/ocaml_413/typing/untypeast.ml
new file mode 100644
index 0000000..6e54cb2
--- /dev/null
+++ b/upstream/ocaml_413/typing/untypeast.ml
@@ -0,0 +1,914 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*    Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay)     *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Longident
+open Asttypes
+open Parsetree
+open Ast_helper
+
+module T = Typedtree
+
+type mapper = {
+  attribute: mapper -> T.attribute -> attribute;
+  attributes: mapper -> T.attribute list -> attribute list;
+  binding_op: mapper -> T.binding_op -> T.pattern -> binding_op;
+  case: 'k . mapper -> 'k T.case -> case;
+  class_declaration: mapper -> T.class_declaration -> class_declaration;
+  class_description: mapper -> T.class_description -> class_description;
+  class_expr: mapper -> T.class_expr -> class_expr;
+  class_field: mapper -> T.class_field -> class_field;
+  class_signature: mapper -> T.class_signature -> class_signature;
+  class_structure: mapper -> T.class_structure -> class_structure;
+  class_type: mapper -> T.class_type -> class_type;
+  class_type_declaration: mapper -> T.class_type_declaration
+                          -> class_type_declaration;
+  class_type_field: mapper -> T.class_type_field -> class_type_field;
+  constructor_declaration: mapper -> T.constructor_declaration
+                           -> constructor_declaration;
+  expr: mapper -> T.expression -> expression;
+  extension_constructor: mapper -> T.extension_constructor
+                         -> extension_constructor;
+  include_declaration: mapper -> T.include_declaration -> include_declaration;
+  include_description: mapper -> T.include_description -> include_description;
+  label_declaration: mapper -> T.label_declaration -> label_declaration;
+  location: mapper -> Location.t -> Location.t;
+  module_binding: mapper -> T.module_binding -> module_binding;
+  module_declaration: mapper -> T.module_declaration -> module_declaration;
+  module_substitution: mapper -> T.module_substitution -> module_substitution;
+  module_expr: mapper -> T.module_expr -> module_expr;
+  module_type: mapper -> T.module_type -> module_type;
+  module_type_declaration:
+    mapper -> T.module_type_declaration -> module_type_declaration;
+  package_type: mapper -> T.package_type -> package_type;
+  open_declaration: mapper -> T.open_declaration -> open_declaration;
+  open_description: mapper -> T.open_description -> open_description;
+  pat: 'k . mapper -> 'k T.general_pattern -> pattern;
+  row_field: mapper -> T.row_field -> row_field;
+  object_field: mapper -> T.object_field -> object_field;
+  signature: mapper -> T.signature -> signature;
+  signature_item: mapper -> T.signature_item -> signature_item;
+  structure: mapper -> T.structure -> structure;
+  structure_item: mapper -> T.structure_item -> structure_item;
+  typ: mapper -> T.core_type -> core_type;
+  type_declaration: mapper -> T.type_declaration -> type_declaration;
+  type_extension: mapper -> T.type_extension -> type_extension;
+  type_exception: mapper -> T.type_exception -> type_exception;
+  type_kind: mapper -> T.type_kind -> type_kind;
+  value_binding: mapper -> T.value_binding -> value_binding;
+  value_description: mapper -> T.value_description -> value_description;
+  with_constraint:
+    mapper -> (Path.t * Longident.t Location.loc * T.with_constraint)
+    -> with_constraint;
+}
+
+open T
+
+(*
+Some notes:
+
+   * For Pexp_function, we cannot go back to the exact original version
+   when there is a default argument, because the default argument is
+   translated in the typer. The code, if printed, will not be parsable because
+   new generated identifiers are not correct.
+
+   * For Pexp_apply, it is unclear whether arguments are reordered, especially
+    when there are optional arguments.
+
+*)
+
+
+(** Utility functions. *)
+
+let string_is_prefix sub str =
+  let sublen = String.length sub in
+  String.length str >= sublen && String.sub str 0 sublen = sub
+
+let rec lident_of_path = function
+  | Path.Pident id -> Longident.Lident (Ident.name id)
+  | Path.Pdot (p, s) -> Longident.Ldot (lident_of_path p, s)
+  | Path.Papply (p1, p2) ->
+      Longident.Lapply (lident_of_path p1, lident_of_path p2)
+
+let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}
+
+(** Try a name [$name$0], check if it's free, if not, increment and repeat. *)
+let fresh_name s env =
+  let rec aux i =
+    let name = s ^ Int.to_string i in
+    if Env.bound_value name env then aux (i+1)
+    else name
+  in
+  aux 0
+
+(** Extract the [n] patterns from the case of a letop *)
+let rec extract_letop_patterns n pat =
+  if n = 0 then pat, []
+  else begin
+    match pat.pat_desc with
+    | Tpat_tuple([first; rest]) ->
+        let next, others = extract_letop_patterns (n-1) rest in
+        first, next :: others
+    | _ ->
+      let rec anys n =
+        if n = 0 then []
+        else { pat with pat_desc = Tpat_any } :: anys (n-1)
+      in
+      { pat with pat_desc = Tpat_any }, anys (n-1)
+  end
+
+(** Mapping functions. *)
+
+let constant = function
+  | Const_char c -> Pconst_char c
+  | Const_string (s,loc,d) -> Pconst_string (s,loc,d)
+  | Const_int i -> Pconst_integer (Int.to_string i, None)
+  | Const_int32 i -> Pconst_integer (Int32.to_string i, Some 'l')
+  | Const_int64 i -> Pconst_integer (Int64.to_string i, Some 'L')
+  | Const_nativeint i -> Pconst_integer (Nativeint.to_string i, Some 'n')
+  | Const_float f -> Pconst_float (f,None)
+
+let attribute sub a = {
+    attr_name = map_loc sub a.attr_name;
+    attr_payload = a.attr_payload;
+    attr_loc = a.attr_loc
+  }
+
+let attributes sub l = List.map (sub.attribute sub) l
+
+let structure sub str =
+  List.map (sub.structure_item sub) str.str_items
+
+let open_description sub od =
+  let loc = sub.location sub od.open_loc in
+  let attrs = sub.attributes sub od.open_attributes in
+  Opn.mk ~loc ~attrs
+    ~override:od.open_override
+    (snd od.open_expr)
+
+let open_declaration sub od =
+  let loc = sub.location sub od.open_loc in
+  let attrs = sub.attributes sub od.open_attributes in
+  Opn.mk ~loc ~attrs
+    ~override:od.open_override
+    (sub.module_expr sub od.open_expr)
+
+let structure_item sub item =
+  let loc = sub.location sub item.str_loc in
+  let desc =
+    match item.str_desc with
+      Tstr_eval (exp, attrs) -> Pstr_eval (sub.expr sub exp, attrs)
+    | Tstr_value (rec_flag, list) ->
+        Pstr_value (rec_flag, List.map (sub.value_binding sub) list)
+    | Tstr_primitive vd ->
+        Pstr_primitive (sub.value_description sub vd)
+    | Tstr_type (rec_flag, list) ->
+        Pstr_type (rec_flag, List.map (sub.type_declaration sub) list)
+    | Tstr_typext tyext ->
+        Pstr_typext (sub.type_extension sub tyext)
+    | Tstr_exception ext ->
+        Pstr_exception (sub.type_exception sub ext)
+    | Tstr_module mb ->
+        Pstr_module (sub.module_binding sub mb)
+    | Tstr_recmodule list ->
+        Pstr_recmodule (List.map (sub.module_binding sub) list)
+    | Tstr_modtype mtd ->
+        Pstr_modtype (sub.module_type_declaration sub mtd)
+    | Tstr_open od ->
+        Pstr_open (sub.open_declaration sub od)
+    | Tstr_class list ->
+        Pstr_class
+          (List.map
+             (fun (ci, _) -> sub.class_declaration sub ci)
+             list)
+    | Tstr_class_type list ->
+        Pstr_class_type
+          (List.map
+             (fun (_id, _name, ct) -> sub.class_type_declaration sub ct)
+             list)
+    | Tstr_include incl ->
+        Pstr_include (sub.include_declaration sub incl)
+    | Tstr_attribute x ->
+        Pstr_attribute x
+  in
+  Str.mk ~loc desc
+
+let value_description sub v =
+  let loc = sub.location sub v.val_loc in
+  let attrs = sub.attributes sub v.val_attributes in
+  Val.mk ~loc ~attrs
+    ~prim:v.val_prim
+    (map_loc sub v.val_name)
+    (sub.typ sub v.val_desc)
+
+let module_binding sub mb =
+  let loc = sub.location sub mb.mb_loc in
+  let attrs = sub.attributes sub mb.mb_attributes in
+  Mb.mk ~loc ~attrs
+    (map_loc sub mb.mb_name)
+    (sub.module_expr sub mb.mb_expr)
+
+let type_parameter sub (ct, v) = (sub.typ sub ct, v)
+
+let type_declaration sub decl =
+  let loc = sub.location sub decl.typ_loc in
+  let attrs = sub.attributes sub decl.typ_attributes in
+  Type.mk ~loc ~attrs
+    ~params:(List.map (type_parameter sub) decl.typ_params)
+    ~cstrs:(
+      List.map
+        (fun (ct1, ct2, loc) ->
+           (sub.typ sub ct1, sub.typ sub ct2, sub.location sub loc))
+        decl.typ_cstrs)
+    ~kind:(sub.type_kind sub decl.typ_kind)
+    ~priv:decl.typ_private
+    ?manifest:(Option.map (sub.typ sub) decl.typ_manifest)
+    (map_loc sub decl.typ_name)
+
+let type_kind sub tk = match tk with
+  | Ttype_abstract -> Ptype_abstract
+  | Ttype_variant list ->
+      Ptype_variant (List.map (sub.constructor_declaration sub) list)
+  | Ttype_record list ->
+      Ptype_record (List.map (sub.label_declaration sub) list)
+  | Ttype_open -> Ptype_open
+
+let constructor_arguments sub = function
+   | Cstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l)
+   | Cstr_record l -> Pcstr_record (List.map (sub.label_declaration sub) l)
+
+let constructor_declaration sub cd =
+  let loc = sub.location sub cd.cd_loc in
+  let attrs = sub.attributes sub cd.cd_attributes in
+  Type.constructor ~loc ~attrs
+    ~args:(constructor_arguments sub cd.cd_args)
+    ?res:(Option.map (sub.typ sub) cd.cd_res)
+    (map_loc sub cd.cd_name)
+
+let label_declaration sub ld =
+  let loc = sub.location sub ld.ld_loc in
+  let attrs = sub.attributes sub ld.ld_attributes in
+  Type.field ~loc ~attrs
+    ~mut:ld.ld_mutable
+    (map_loc sub ld.ld_name)
+    (sub.typ sub ld.ld_type)
+
+let type_extension sub tyext =
+  let attrs = sub.attributes sub tyext.tyext_attributes in
+  Te.mk ~attrs
+    ~params:(List.map (type_parameter sub) tyext.tyext_params)
+    ~priv:tyext.tyext_private
+    (map_loc sub tyext.tyext_txt)
+    (List.map (sub.extension_constructor sub) tyext.tyext_constructors)
+
+let type_exception sub tyexn =
+  let attrs = sub.attributes sub tyexn.tyexn_attributes in
+  Te.mk_exception ~attrs
+    (sub.extension_constructor sub tyexn.tyexn_constructor)
+
+let extension_constructor sub ext =
+  let loc = sub.location sub ext.ext_loc in
+  let attrs = sub.attributes sub ext.ext_attributes in
+  Te.constructor ~loc ~attrs
+    (map_loc sub ext.ext_name)
+    (match ext.ext_kind with
+      | Text_decl (args, ret) ->
+          Pext_decl (constructor_arguments sub args,
+                     Option.map (sub.typ sub) ret)
+      | Text_rebind (_p, lid) -> Pext_rebind (map_loc sub lid)
+    )
+
+let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat ->
+  let loc = sub.location sub pat.pat_loc in
+  (* todo: fix attributes on extras *)
+  let attrs = sub.attributes sub pat.pat_attributes in
+  let desc =
+  match pat with
+      { pat_extra=[Tpat_unpack, loc, _attrs]; pat_desc = Tpat_any; _ } ->
+        Ppat_unpack { txt = None; loc  }
+    | { pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } ->
+        Ppat_unpack { name with txt = Some name.txt }
+    | { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } ->
+        Ppat_type (map_loc sub lid)
+    | { pat_extra= (Tpat_constraint ct, _, _attrs) :: rem; _ } ->
+        Ppat_constraint (sub.pat sub { pat with pat_extra=rem },
+                         sub.typ sub ct)
+    | _ ->
+    match pat.pat_desc with
+      Tpat_any -> Ppat_any
+    | Tpat_var (id, name) ->
+        begin
+          match (Ident.name id).[0] with
+            'A'..'Z' ->
+              Ppat_unpack { name with txt = Some name.txt}
+          | _ ->
+              Ppat_var name
+        end
+
+    (* We transform (_ as x) in x if _ and x have the same location.
+       The compiler transforms (x:t) into (_ as x : t).
+       This avoids transforming a warning 27 into a 26.
+     *)
+    | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name)
+         when pat_loc = pat.pat_loc ->
+       Ppat_var name
+
+    | Tpat_alias (pat, _id, name) ->
+        Ppat_alias (sub.pat sub pat, name)
+    | Tpat_constant cst -> Ppat_constant (constant cst)
+    | Tpat_tuple list ->
+        Ppat_tuple (List.map (sub.pat sub) list)
+    | Tpat_construct (lid, _, args, vto) ->
+        let tyo =
+          match vto with
+            None -> None
+          | Some (vl, ty) ->
+              let vl =
+                List.map (fun x -> {x with txt = Ident.name x.txt}) vl
+              in
+              Some (vl, sub.typ sub ty)
+        in
+        let arg =
+          match args with
+            []    -> None
+          | [arg] -> Some (sub.pat sub arg)
+          | args  -> Some (Pat.tuple ~loc (List.map (sub.pat sub) args))
+        in
+        Ppat_construct (map_loc sub lid,
+          match tyo, arg with
+          | Some (vl, ty), Some arg ->
+              Some (vl, Pat.mk ~loc (Ppat_constraint (arg, ty)))
+          | None, Some arg -> Some ([], arg)
+          | _, None -> None)
+    | Tpat_variant (label, pato, _) ->
+        Ppat_variant (label, Option.map (sub.pat sub) pato)
+    | Tpat_record (list, closed) ->
+        Ppat_record (List.map (fun (lid, _, pat) ->
+            map_loc sub lid, sub.pat sub pat) list, closed)
+    | Tpat_array list -> Ppat_array (List.map (sub.pat sub) list)
+    | Tpat_lazy p -> Ppat_lazy (sub.pat sub p)
+
+    | Tpat_exception p -> Ppat_exception (sub.pat sub p)
+    | Tpat_value p -> (sub.pat sub (p :> pattern)).ppat_desc
+    | Tpat_or (p1, p2, _) -> Ppat_or (sub.pat sub p1, sub.pat sub p2)
+  in
+  Pat.mk ~loc ~attrs desc
+
+let exp_extra sub (extra, loc, attrs) sexp =
+  let loc = sub.location sub loc in
+  let attrs = sub.attributes sub attrs in
+  let desc =
+    match extra with
+      Texp_coerce (cty1, cty2) ->
+        Pexp_coerce (sexp,
+                     Option.map (sub.typ sub) cty1,
+                     sub.typ sub cty2)
+    | Texp_constraint cty ->
+        Pexp_constraint (sexp, sub.typ sub cty)
+    | Texp_poly cto -> Pexp_poly (sexp, Option.map (sub.typ sub) cto)
+    | Texp_newtype s -> Pexp_newtype (mkloc s loc, sexp)
+  in
+  Exp.mk ~loc ~attrs desc
+
+let case : type k . mapper -> k case -> _ = fun sub {c_lhs; c_guard; c_rhs} ->
+  {
+   pc_lhs = sub.pat sub c_lhs;
+   pc_guard = Option.map (sub.expr sub) c_guard;
+   pc_rhs = sub.expr sub c_rhs;
+  }
+
+let value_binding sub vb =
+  let loc = sub.location sub vb.vb_loc in
+  let attrs = sub.attributes sub vb.vb_attributes in
+  Vb.mk ~loc ~attrs
+    (sub.pat sub vb.vb_pat)
+    (sub.expr sub vb.vb_expr)
+
+let expression sub exp =
+  let loc = sub.location sub exp.exp_loc in
+  let attrs = sub.attributes sub exp.exp_attributes in
+  let desc =
+    match exp.exp_desc with
+      Texp_ident (_path, lid, _) -> Pexp_ident (map_loc sub lid)
+    | Texp_constant cst -> Pexp_constant (constant cst)
+    | Texp_let (rec_flag, list, exp) ->
+        Pexp_let (rec_flag,
+          List.map (sub.value_binding sub) list,
+          sub.expr sub exp)
+
+    (* Pexp_function can't have a label, so we split in 3 cases. *)
+    (* One case, no guard: It's a fun. *)
+    | Texp_function { arg_label; cases = [{c_lhs=p; c_guard=None; c_rhs=e}];
+          _ } ->
+        Pexp_fun (arg_label, None, sub.pat sub p, sub.expr sub e)
+    (* No label: it's a function. *)
+    | Texp_function { arg_label = Nolabel; cases; _; } ->
+        Pexp_function (List.map (sub.case sub) cases)
+    (* Mix of both, we generate `fun ~label:$name$ -> match $name$ with ...` *)
+    | Texp_function { arg_label = Labelled s | Optional s as label; cases;
+          _ } ->
+        let name = fresh_name s exp.exp_env in
+        Pexp_fun (label, None, Pat.var ~loc {loc;txt = name },
+          Exp.match_ ~loc (Exp.ident ~loc {loc;txt= Lident name})
+                          (List.map (sub.case sub) cases))
+    | Texp_apply (exp, list) ->
+        Pexp_apply (sub.expr sub exp,
+          List.fold_right (fun (label, expo) list ->
+              match expo with
+                None -> list
+              | Some exp -> (label, sub.expr sub exp) :: list
+          ) list [])
+    | Texp_match (exp, cases, _) ->
+      Pexp_match (sub.expr sub exp, List.map (sub.case sub) cases)
+    | Texp_try (exp, cases) ->
+        Pexp_try (sub.expr sub exp, List.map (sub.case sub) cases)
+    | Texp_tuple list ->
+        Pexp_tuple (List.map (sub.expr sub) list)
+    | Texp_construct (lid, _, args) ->
+        Pexp_construct (map_loc sub lid,
+          (match args with
+              [] -> None
+          | [ arg ] -> Some (sub.expr sub arg)
+          | args ->
+              Some
+                (Exp.tuple ~loc (List.map (sub.expr sub) args))
+          ))
+    | Texp_variant (label, expo) ->
+        Pexp_variant (label, Option.map (sub.expr sub) expo)
+    | Texp_record { fields; extended_expression; _ } ->
+        let list = Array.fold_left (fun l -> function
+            | _, Kept _ -> l
+            | _, Overridden (lid, exp) -> (lid, sub.expr sub exp) :: l)
+            [] fields
+        in
+        Pexp_record (list, Option.map (sub.expr sub) extended_expression)
+    | Texp_field (exp, lid, _label) ->
+        Pexp_field (sub.expr sub exp, map_loc sub lid)
+    | Texp_setfield (exp1, lid, _label, exp2) ->
+        Pexp_setfield (sub.expr sub exp1, map_loc sub lid,
+          sub.expr sub exp2)
+    | Texp_array list ->
+        Pexp_array (List.map (sub.expr sub) list)
+    | Texp_ifthenelse (exp1, exp2, expo) ->
+        Pexp_ifthenelse (sub.expr sub exp1,
+          sub.expr sub exp2,
+          Option.map (sub.expr sub) expo)
+    | Texp_sequence (exp1, exp2) ->
+        Pexp_sequence (sub.expr sub exp1, sub.expr sub exp2)
+    | Texp_while (exp1, exp2) ->
+        Pexp_while (sub.expr sub exp1, sub.expr sub exp2)
+    | Texp_for (_id, name, exp1, exp2, dir, exp3) ->
+        Pexp_for (name,
+          sub.expr sub exp1, sub.expr sub exp2,
+          dir, sub.expr sub exp3)
+    | Texp_send (exp, meth, _) ->
+        Pexp_send (sub.expr sub exp, match meth with
+            Tmeth_name name -> mkloc name loc
+          | Tmeth_val id -> mkloc (Ident.name id) loc)
+    | Texp_new (_path, lid, _) -> Pexp_new (map_loc sub lid)
+    | Texp_instvar (_, path, name) ->
+      Pexp_ident ({loc = sub.location sub name.loc ; txt = lident_of_path path})
+    | Texp_setinstvar (_, _path, lid, exp) ->
+        Pexp_setinstvar (map_loc sub lid, sub.expr sub exp)
+    | Texp_override (_, list) ->
+        Pexp_override (List.map (fun (_path, lid, exp) ->
+              (map_loc sub lid, sub.expr sub exp)
+          ) list)
+    | Texp_letmodule (_id, name, _pres, mexpr, exp) ->
+        Pexp_letmodule (name, sub.module_expr sub mexpr,
+          sub.expr sub exp)
+    | Texp_letexception (ext, exp) ->
+        Pexp_letexception (sub.extension_constructor sub ext,
+                           sub.expr sub exp)
+    | Texp_assert exp -> Pexp_assert (sub.expr sub exp)
+    | Texp_lazy exp -> Pexp_lazy (sub.expr sub exp)
+    | Texp_object (cl, _) ->
+        Pexp_object (sub.class_structure sub cl)
+    | Texp_pack (mexpr) ->
+        Pexp_pack (sub.module_expr sub mexpr)
+    | Texp_letop {let_; ands; body; _} ->
+        let pat, and_pats =
+          extract_letop_patterns (List.length ands) body.c_lhs
+        in
+        let let_ = sub.binding_op sub let_ pat in
+        let ands = List.map2 (sub.binding_op sub) ands and_pats in
+        let body = sub.expr sub body.c_rhs in
+        Pexp_letop {let_; ands; body }
+    | Texp_unreachable ->
+        Pexp_unreachable
+    | Texp_extension_constructor (lid, _) ->
+        Pexp_extension ({ txt = "ocaml.extension_constructor"; loc },
+                        PStr [ Str.eval ~loc
+                                 (Exp.construct ~loc (map_loc sub lid) None)
+                             ])
+    | Texp_open (od, exp) ->
+        Pexp_open (sub.open_declaration sub od, sub.expr sub exp)
+  in
+  List.fold_right (exp_extra sub) exp.exp_extra
+    (Exp.mk ~loc ~attrs desc)
+
+let binding_op sub bop pat =
+  let pbop_op = bop.bop_op_name in
+  let pbop_pat = sub.pat sub pat in
+  let pbop_exp = sub.expr sub bop.bop_exp in
+  let pbop_loc = bop.bop_loc in
+  {pbop_op; pbop_pat; pbop_exp; pbop_loc}
+
+let package_type sub pack =
+  (map_loc sub pack.pack_txt,
+    List.map (fun (s, ct) ->
+        (s, sub.typ sub ct)) pack.pack_fields)
+
+let module_type_declaration sub mtd =
+  let loc = sub.location sub mtd.mtd_loc in
+  let attrs = sub.attributes sub mtd.mtd_attributes in
+  Mtd.mk ~loc ~attrs
+    ?typ:(Option.map (sub.module_type sub) mtd.mtd_type)
+    (map_loc sub mtd.mtd_name)
+
+let signature sub sg =
+  List.map (sub.signature_item sub) sg.sig_items
+
+let signature_item sub item =
+  let loc = sub.location sub item.sig_loc in
+  let desc =
+    match item.sig_desc with
+      Tsig_value v ->
+        Psig_value (sub.value_description sub v)
+    | Tsig_type (rec_flag, list) ->
+        Psig_type (rec_flag, List.map (sub.type_declaration sub) list)
+    | Tsig_typesubst list ->
+        Psig_typesubst (List.map (sub.type_declaration sub) list)
+    | Tsig_typext tyext ->
+        Psig_typext (sub.type_extension sub tyext)
+    | Tsig_exception ext ->
+        Psig_exception (sub.type_exception sub ext)
+    | Tsig_module md ->
+        Psig_module (sub.module_declaration sub md)
+    | Tsig_modsubst ms ->
+        Psig_modsubst (sub.module_substitution sub ms)
+    | Tsig_recmodule list ->
+        Psig_recmodule (List.map (sub.module_declaration sub) list)
+    | Tsig_modtype mtd ->
+        Psig_modtype (sub.module_type_declaration sub mtd)
+    | Tsig_modtypesubst mtd ->
+        Psig_modtypesubst (sub.module_type_declaration sub mtd)
+    | Tsig_open od ->
+        Psig_open (sub.open_description sub od)
+    | Tsig_include incl ->
+        Psig_include (sub.include_description sub incl)
+    | Tsig_class list ->
+        Psig_class (List.map (sub.class_description sub) list)
+    | Tsig_class_type list ->
+        Psig_class_type (List.map (sub.class_type_declaration sub) list)
+    | Tsig_attribute x ->
+        Psig_attribute x
+  in
+  Sig.mk ~loc desc
+
+let module_declaration sub md =
+  let loc = sub.location sub md.md_loc in
+  let attrs = sub.attributes sub md.md_attributes in
+  Md.mk ~loc ~attrs
+    (map_loc sub md.md_name)
+    (sub.module_type sub md.md_type)
+
+let module_substitution sub ms =
+  let loc = sub.location sub ms.ms_loc in
+  let attrs = sub.attributes sub ms.ms_attributes in
+  Ms.mk ~loc ~attrs
+    (map_loc sub ms.ms_name)
+    (map_loc sub ms.ms_txt)
+
+let include_infos f sub incl =
+  let loc = sub.location sub incl.incl_loc in
+  let attrs = sub.attributes sub incl.incl_attributes in
+  Incl.mk ~loc ~attrs
+    (f sub incl.incl_mod)
+
+let include_declaration sub = include_infos sub.module_expr sub
+let include_description sub = include_infos sub.module_type sub
+
+let class_infos f sub ci =
+  let loc = sub.location sub ci.ci_loc in
+  let attrs = sub.attributes sub ci.ci_attributes in
+  Ci.mk ~loc ~attrs
+    ~virt:ci.ci_virt
+    ~params:(List.map (type_parameter sub) ci.ci_params)
+    (map_loc sub ci.ci_id_name)
+    (f sub ci.ci_expr)
+
+let class_declaration sub = class_infos sub.class_expr sub
+let class_description sub = class_infos sub.class_type sub
+let class_type_declaration sub = class_infos sub.class_type sub
+
+let functor_parameter sub : functor_parameter -> Parsetree.functor_parameter =
+  function
+  | Unit -> Unit
+  | Named (_, name, mtype) -> Named (name, sub.module_type sub mtype)
+
+let module_type (sub : mapper) mty =
+  let loc = sub.location sub mty.mty_loc in
+  let attrs = sub.attributes sub mty.mty_attributes in
+  let desc = match mty.mty_desc with
+      Tmty_ident (_path, lid) -> Pmty_ident (map_loc sub lid)
+    | Tmty_alias (_path, lid) -> Pmty_alias (map_loc sub lid)
+    | Tmty_signature sg -> Pmty_signature (sub.signature sub sg)
+    | Tmty_functor (arg, mtype2) ->
+        Pmty_functor (functor_parameter sub arg, sub.module_type sub mtype2)
+    | Tmty_with (mtype, list) ->
+        Pmty_with (sub.module_type sub mtype,
+          List.map (sub.with_constraint sub) list)
+    | Tmty_typeof mexpr ->
+        Pmty_typeof (sub.module_expr sub mexpr)
+  in
+  Mty.mk ~loc ~attrs desc
+
+let with_constraint sub (_path, lid, cstr) =
+  match cstr with
+  | Twith_type decl ->
+      Pwith_type (map_loc sub lid, sub.type_declaration sub decl)
+  | Twith_module (_path, lid2) ->
+      Pwith_module (map_loc sub lid, map_loc sub lid2)
+  | Twith_modtype mty ->
+      let mty = sub.module_type sub mty in
+      Pwith_modtype (map_loc sub lid,mty)
+  | Twith_typesubst decl ->
+     Pwith_typesubst (map_loc sub lid, sub.type_declaration sub decl)
+  | Twith_modsubst (_path, lid2) ->
+      Pwith_modsubst (map_loc sub lid, map_loc sub lid2)
+  | Twith_modtypesubst mty ->
+      let mty = sub.module_type sub mty in
+      Pwith_modtypesubst (map_loc sub lid, mty)
+
+let module_expr (sub : mapper) mexpr =
+  let loc = sub.location sub mexpr.mod_loc in
+  let attrs = sub.attributes sub mexpr.mod_attributes in
+  match mexpr.mod_desc with
+      Tmod_constraint (m, _, Tmodtype_implicit, _ ) ->
+        sub.module_expr sub m
+    | _ ->
+        let desc = match mexpr.mod_desc with
+            Tmod_ident (_p, lid) -> Pmod_ident (map_loc sub lid)
+          | Tmod_structure st -> Pmod_structure (sub.structure sub st)
+          | Tmod_functor (arg, mexpr) ->
+              Pmod_functor
+                (functor_parameter sub arg, sub.module_expr sub mexpr)
+          | Tmod_apply (mexp1, mexp2, _) ->
+              Pmod_apply (sub.module_expr sub mexp1, sub.module_expr sub mexp2)
+          | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) ->
+              Pmod_constraint (sub.module_expr sub mexpr,
+                sub.module_type sub mtype)
+          | Tmod_constraint (_mexpr, _, Tmodtype_implicit, _) ->
+              assert false
+          | Tmod_unpack (exp, _pack) ->
+              Pmod_unpack (sub.expr sub exp)
+              (* TODO , sub.package_type sub pack) *)
+        in
+        Mod.mk ~loc ~attrs desc
+
+let class_expr sub cexpr =
+  let loc = sub.location sub cexpr.cl_loc in
+  let attrs = sub.attributes sub cexpr.cl_attributes in
+  let desc = match cexpr.cl_desc with
+    | Tcl_constraint ( { cl_desc = Tcl_ident (_path, lid, tyl); _ },
+                       None, _, _, _ ) ->
+        Pcl_constr (map_loc sub lid,
+          List.map (sub.typ sub) tyl)
+    | Tcl_structure clstr -> Pcl_structure (sub.class_structure sub clstr)
+
+    | Tcl_fun (label, pat, _pv, cl, _partial) ->
+        Pcl_fun (label, None, sub.pat sub pat, sub.class_expr sub cl)
+
+    | Tcl_apply (cl, args) ->
+        Pcl_apply (sub.class_expr sub cl,
+          List.fold_right (fun (label, expo) list ->
+              match expo with
+                None -> list
+              | Some exp -> (label, sub.expr sub exp) :: list
+          ) args [])
+
+    | Tcl_let (rec_flat, bindings, _ivars, cl) ->
+        Pcl_let (rec_flat,
+          List.map (sub.value_binding sub) bindings,
+          sub.class_expr sub cl)
+
+    | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) ->
+        Pcl_constraint (sub.class_expr sub cl,  sub.class_type sub clty)
+
+    | Tcl_open (od, e) ->
+        Pcl_open (sub.open_description sub od, sub.class_expr sub e)
+
+    | Tcl_ident _ -> assert false
+    | Tcl_constraint (_, None, _, _, _) -> assert false
+  in
+  Cl.mk ~loc ~attrs desc
+
+let class_type sub ct =
+  let loc = sub.location sub ct.cltyp_loc in
+  let attrs = sub.attributes sub ct.cltyp_attributes in
+  let desc = match ct.cltyp_desc with
+      Tcty_signature csg -> Pcty_signature (sub.class_signature sub csg)
+    | Tcty_constr (_path, lid, list) ->
+        Pcty_constr (map_loc sub lid, List.map (sub.typ sub) list)
+    | Tcty_arrow (label, ct, cl) ->
+        Pcty_arrow (label, sub.typ sub ct, sub.class_type sub cl)
+    | Tcty_open (od, e) ->
+        Pcty_open (sub.open_description sub od, sub.class_type sub e)
+  in
+  Cty.mk ~loc ~attrs desc
+
+let class_signature sub cs =
+  {
+    pcsig_self = sub.typ sub cs.csig_self;
+    pcsig_fields = List.map (sub.class_type_field sub) cs.csig_fields;
+  }
+
+let class_type_field sub ctf =
+  let loc = sub.location sub ctf.ctf_loc in
+  let attrs = sub.attributes sub ctf.ctf_attributes in
+  let desc = match ctf.ctf_desc with
+      Tctf_inherit ct -> Pctf_inherit (sub.class_type sub ct)
+    | Tctf_val (s, mut, virt, ct) ->
+        Pctf_val (mkloc s loc, mut, virt, sub.typ sub ct)
+    | Tctf_method  (s, priv, virt, ct) ->
+        Pctf_method  (mkloc s loc, priv, virt, sub.typ sub ct)
+    | Tctf_constraint  (ct1, ct2) ->
+        Pctf_constraint (sub.typ sub ct1, sub.typ sub ct2)
+    | Tctf_attribute x -> Pctf_attribute x
+  in
+  Ctf.mk ~loc ~attrs desc
+
+let core_type sub ct =
+  let loc = sub.location sub ct.ctyp_loc in
+  let attrs = sub.attributes sub ct.ctyp_attributes in
+  let desc = match ct.ctyp_desc with
+      Ttyp_any -> Ptyp_any
+    | Ttyp_var s -> Ptyp_var s
+    | Ttyp_arrow (label, ct1, ct2) ->
+        Ptyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2)
+    | Ttyp_tuple list -> Ptyp_tuple (List.map (sub.typ sub) list)
+    | Ttyp_constr (_path, lid, list) ->
+        Ptyp_constr (map_loc sub lid,
+          List.map (sub.typ sub) list)
+    | Ttyp_object (list, o) ->
+        Ptyp_object
+          (List.map (sub.object_field sub) list, o)
+    | Ttyp_class (_path, lid, list) ->
+        Ptyp_class (map_loc sub lid, List.map (sub.typ sub) list)
+    | Ttyp_alias (ct, s) ->
+        Ptyp_alias (sub.typ sub ct, s)
+    | Ttyp_variant (list, bool, labels) ->
+        Ptyp_variant (List.map (sub.row_field sub) list, bool, labels)
+    | Ttyp_poly (list, ct) ->
+        let list = List.map (fun v -> mkloc v loc) list in
+        Ptyp_poly (list, sub.typ sub ct)
+    | Ttyp_package pack -> Ptyp_package (sub.package_type sub pack)
+  in
+  Typ.mk ~loc ~attrs desc
+
+let class_structure sub cs =
+  let rec remove_self = function
+    | { pat_desc = Tpat_alias (p, id, _s) }
+      when string_is_prefix "selfpat-" (Ident.name id) ->
+        remove_self p
+    | p -> p
+  in
+  { pcstr_self = sub.pat sub (remove_self cs.cstr_self);
+    pcstr_fields = List.map (sub.class_field sub) cs.cstr_fields;
+  }
+
+let row_field sub {rf_loc; rf_desc; rf_attributes;} =
+  let loc = sub.location sub rf_loc in
+  let attrs = sub.attributes sub rf_attributes in
+  let desc = match rf_desc with
+    | Ttag (label, bool, list) ->
+        Rtag (label, bool, List.map (sub.typ sub) list)
+    | Tinherit ct -> Rinherit (sub.typ sub ct)
+  in
+  Rf.mk ~loc ~attrs desc
+
+let object_field sub {of_loc; of_desc; of_attributes;} =
+  let loc = sub.location sub of_loc in
+  let attrs = sub.attributes sub of_attributes in
+  let desc = match of_desc with
+    | OTtag (label, ct) ->
+        Otag (label, sub.typ sub ct)
+    | OTinherit ct -> Oinherit (sub.typ sub ct)
+  in
+  Of.mk ~loc ~attrs desc
+
+and is_self_pat = function
+  | { pat_desc = Tpat_alias(_pat, id, _) } ->
+      string_is_prefix "self-" (Ident.name id)
+  | _ -> false
+
+let class_field sub cf =
+  let loc = sub.location sub cf.cf_loc in
+  let attrs = sub.attributes sub cf.cf_attributes in
+  let desc = match cf.cf_desc with
+      Tcf_inherit (ovf, cl, super, _vals, _meths) ->
+        Pcf_inherit (ovf, sub.class_expr sub cl,
+                     Option.map (fun v -> mkloc v loc) super)
+    | Tcf_constraint (cty, cty') ->
+        Pcf_constraint (sub.typ sub cty, sub.typ sub cty')
+    | Tcf_val (lab, mut, _, Tcfk_virtual cty, _) ->
+        Pcf_val (lab, mut, Cfk_virtual (sub.typ sub cty))
+    | Tcf_val (lab, mut, _, Tcfk_concrete (o, exp), _) ->
+        Pcf_val (lab, mut, Cfk_concrete (o, sub.expr sub exp))
+    | Tcf_method (lab, priv, Tcfk_virtual cty) ->
+        Pcf_method (lab, priv, Cfk_virtual (sub.typ sub cty))
+    | Tcf_method (lab, priv, Tcfk_concrete (o, exp)) ->
+        let remove_fun_self = function
+          | { exp_desc =
+              Texp_function { arg_label = Nolabel; cases = [case]; _ } }
+            when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs
+          | e -> e
+        in
+        let exp = remove_fun_self exp in
+        Pcf_method (lab, priv, Cfk_concrete (o, sub.expr sub exp))
+    | Tcf_initializer exp ->
+        let remove_fun_self = function
+          | { exp_desc =
+              Texp_function { arg_label = Nolabel; cases = [case]; _ } }
+            when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs
+          | e -> e
+        in
+        let exp = remove_fun_self exp in
+        Pcf_initializer (sub.expr sub exp)
+    | Tcf_attribute x -> Pcf_attribute x
+  in
+  Cf.mk ~loc ~attrs desc
+
+let location _sub l = l
+
+let default_mapper =
+  {
+    attribute = attribute;
+    attributes = attributes;
+    binding_op = binding_op;
+    structure = structure;
+    structure_item = structure_item;
+    module_expr = module_expr;
+    signature = signature;
+    signature_item = signature_item;
+    module_type = module_type;
+    with_constraint = with_constraint;
+    class_declaration = class_declaration;
+    class_expr = class_expr;
+    class_field = class_field;
+    class_structure = class_structure;
+    class_type = class_type;
+    class_type_field = class_type_field;
+    class_signature = class_signature;
+    class_type_declaration = class_type_declaration;
+    class_description = class_description;
+    type_declaration = type_declaration;
+    type_kind = type_kind;
+    typ = core_type;
+    type_extension = type_extension;
+    type_exception = type_exception;
+    extension_constructor = extension_constructor;
+    value_description = value_description;
+    pat = pattern;
+    expr = expression;
+    module_declaration = module_declaration;
+    module_substitution = module_substitution;
+    module_type_declaration = module_type_declaration;
+    module_binding = module_binding;
+    package_type = package_type ;
+    open_declaration = open_declaration;
+    open_description = open_description;
+    include_description = include_description;
+    include_declaration = include_declaration;
+    value_binding = value_binding;
+    constructor_declaration = constructor_declaration;
+    label_declaration = label_declaration;
+    case = case;
+    location = location;
+    row_field = row_field ;
+    object_field = object_field ;
+  }
+
+let untype_structure ?(mapper : mapper = default_mapper) structure =
+  mapper.structure mapper structure
+
+let untype_signature ?(mapper : mapper = default_mapper) signature =
+  mapper.signature mapper signature
+
+let untype_expression ?(mapper=default_mapper) expression =
+  mapper.expr mapper expression
+
+let untype_pattern ?(mapper=default_mapper) pattern =
+  mapper.pat mapper pattern
diff --git a/upstream/ocaml_413/typing/untypeast.mli b/upstream/ocaml_413/typing/untypeast.mli
new file mode 100644
index 0000000..809df9a
--- /dev/null
+++ b/upstream/ocaml_413/typing/untypeast.mli
@@ -0,0 +1,87 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*      Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay)   *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Parsetree
+
+val lident_of_path : Path.t -> Longident.t
+
+type mapper = {
+  attribute: mapper -> Typedtree.attribute -> attribute;
+  attributes: mapper -> Typedtree.attribute list -> attribute list;
+  binding_op:
+    mapper ->
+    Typedtree.binding_op -> Typedtree.pattern -> binding_op;
+  case: 'k . mapper -> 'k Typedtree.case -> case;
+  class_declaration: mapper -> Typedtree.class_declaration -> class_declaration;
+  class_description: mapper -> Typedtree.class_description -> class_description;
+  class_expr: mapper -> Typedtree.class_expr -> class_expr;
+  class_field: mapper -> Typedtree.class_field -> class_field;
+  class_signature: mapper -> Typedtree.class_signature -> class_signature;
+  class_structure: mapper -> Typedtree.class_structure -> class_structure;
+  class_type: mapper -> Typedtree.class_type -> class_type;
+  class_type_declaration: mapper -> Typedtree.class_type_declaration
+                          -> class_type_declaration;
+  class_type_field: mapper -> Typedtree.class_type_field -> class_type_field;
+  constructor_declaration: mapper -> Typedtree.constructor_declaration
+                           -> constructor_declaration;
+  expr: mapper -> Typedtree.expression -> expression;
+  extension_constructor: mapper -> Typedtree.extension_constructor
+                         -> extension_constructor;
+  include_declaration:
+    mapper -> Typedtree.include_declaration -> include_declaration;
+  include_description:
+    mapper -> Typedtree.include_description -> include_description;
+  label_declaration:
+    mapper -> Typedtree.label_declaration -> label_declaration;
+  location: mapper -> Location.t -> Location.t;
+  module_binding: mapper -> Typedtree.module_binding -> module_binding;
+  module_declaration:
+    mapper -> Typedtree.module_declaration -> module_declaration;
+  module_substitution:
+    mapper -> Typedtree.module_substitution -> module_substitution;
+  module_expr: mapper -> Typedtree.module_expr -> module_expr;
+  module_type: mapper -> Typedtree.module_type -> module_type;
+  module_type_declaration:
+    mapper -> Typedtree.module_type_declaration -> module_type_declaration;
+  package_type: mapper -> Typedtree.package_type -> package_type;
+  open_declaration: mapper -> Typedtree.open_declaration -> open_declaration;
+  open_description: mapper -> Typedtree.open_description -> open_description;
+  pat: 'k . mapper -> 'k Typedtree.general_pattern -> pattern;
+  row_field: mapper -> Typedtree.row_field -> row_field;
+  object_field: mapper -> Typedtree.object_field -> object_field;
+  signature: mapper -> Typedtree.signature -> signature;
+  signature_item: mapper -> Typedtree.signature_item -> signature_item;
+  structure: mapper -> Typedtree.structure -> structure;
+  structure_item: mapper -> Typedtree.structure_item -> structure_item;
+  typ: mapper -> Typedtree.core_type -> core_type;
+  type_declaration: mapper -> Typedtree.type_declaration -> type_declaration;
+  type_extension: mapper -> Typedtree.type_extension -> type_extension;
+  type_exception: mapper -> Typedtree.type_exception -> type_exception;
+  type_kind: mapper -> Typedtree.type_kind -> type_kind;
+  value_binding: mapper -> Typedtree.value_binding -> value_binding;
+  value_description: mapper -> Typedtree.value_description -> value_description;
+  with_constraint:
+    mapper -> (Path.t * Longident.t Location.loc * Typedtree.with_constraint)
+    -> with_constraint;
+}
+
+val default_mapper : mapper
+
+val untype_structure : ?mapper:mapper -> Typedtree.structure -> structure
+val untype_signature : ?mapper:mapper -> Typedtree.signature -> signature
+val untype_expression : ?mapper:mapper -> Typedtree.expression -> expression
+val untype_pattern : ?mapper:mapper -> _ Typedtree.general_pattern -> pattern
+
+val constant : Asttypes.constant -> Parsetree.constant
diff --git a/upstream/ocaml_413/utils/HACKING.adoc b/upstream/ocaml_413/utils/HACKING.adoc
new file mode 100644
index 0000000..707fdfd
--- /dev/null
+++ b/upstream/ocaml_413/utils/HACKING.adoc
@@ -0,0 +1,50 @@
+== Magic numbers
+
+The magic numbers in `config.mlp` are included in the header of
+compiled files produced by the OCaml compiler. Different kind of files
+(cmi, cmo, cmx, cma, executables, etc.) get different magic numbers,
+and we also change the magic number whenever we change the format of
+the corresponding file.
+
+Note that the `exec_magic_number` value is duplicated as `EXEC_MAGIC`
+in `runtime/caml/exec.h` and they must be kept in sync.
+
+This lets the compiler differentiate files that should be valid files
+of the kind it expects, and files that are passed by mistake, either
+that are not at all valid compiled files, or because they come from
+a different compiler version with an incompatible file format.
+
+We say that we "bump" a magic number when we update its version part
+in config.mlp. To bump all magic numbers is to increment the version
+of every kind of magic number.
+
+=== Updating magic numbers
+
+Previously people tried to update magic numbers as infrequently as
+possible, to maximize the lifetime of tools supporting only a fixed
+version of magic numbers -- so that they would work for as long as the
+underlying representation is compatible.
+
+However, it is more dangerous to forget to update a number than to
+update it too often. If we update too often, at worst tool authors have
+to update their codebase to support more numbers. If we don't update
+often enough, tools break with horrible parsing/deserialization errors
+and their authors can do nothing to prevent it.
+
+We have thus decided to systematically bump all magic numbers on each
+new major release of the compiler. (We don't want to change compiled
+file formats in minor releases, so we shouldn't need to bump magic
+numbers systematically. If a format change was necessary for
+a critical bugfix, then we would still need to bump on a minor
+release.)
+
+This should preferably be done just before the first testing release
+(the first beta, or the first rc if there is no beta) of the new major
+release. We want it to happen after all format-breaking changes have
+been included in the development version, but before the version gets
+tested on a large scale: this is when tool authors may update their
+tools to test the new release, and if you update *after* that you risk
+breaking them again without them noticing.
+
+For example, the magic numbers for 4.13 were updated in
+  dd7927e156b7cb2f9
diff --git a/upstream/ocaml_413/utils/Makefile b/upstream/ocaml_413/utils/Makefile
new file mode 100644
index 0000000..5ff17f6
--- /dev/null
+++ b/upstream/ocaml_413/utils/Makefile
@@ -0,0 +1,119 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            Xavier Leroy, projet Cristal, INRIA Rocquencourt            *
+#*                                                                        *
+#*   Copyright 1999 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# The Makefile for generating the configuration file
+
+ROOTDIR = ..
+
+include $(ROOTDIR)/Makefile.common
+
+ifeq "$(BOOTSTRAPPING_FLEXDLL)" "false"
+  FLEXDLL_DIR =
+else
+  FLEXDLL_DIR = +flexdll
+endif
+
+FLEXLINK_FLAGS ?=
+
+# SUBST_QUOTE does the same as SUBST_STRING, adding OCaml quotes around
+#   non-empty strings (see FLEXDLL_DIR which must empty if FLEXDLL_DIR is empty
+#   but an OCaml string otherwise)
+SUBST_QUOTE2=\
+  -e 's!%%$1%%!$(if $2,$(call SED_ESCAPE,"$(call OCAML_ESCAPE,$2)"))!'
+SUBST_QUOTE=$(call SUBST_QUOTE2,$1,$($1))
+
+FLEXLINK_LDFLAGS=$(if $(OC_LDFLAGS), -link "$(OC_LDFLAGS)")
+FLEXLINK_DLL_LDFLAGS=$(if $(OC_DLL_LDFLAGS), -link "$(OC_DLL_LDFLAGS)")
+
+config.ml: config.mlp $(ROOTDIR)/Makefile.config Makefile
+	sed $(call SUBST,AFL_INSTRUMENT) \
+	    $(call SUBST,ARCH) \
+	    $(call SUBST_STRING,ARCMD) \
+	    $(call SUBST_STRING,ASM) \
+	    $(call SUBST,ASM_CFI_SUPPORTED) \
+	    $(call SUBST_STRING,BYTECCLIBS) \
+	    $(call SUBST_STRING,CC) \
+	    $(call SUBST_STRING,CCOMPTYPE) \
+	    $(call SUBST_STRING,OUTPUTOBJ) \
+	    $(call SUBST_STRING,EXT_ASM) \
+	    $(call SUBST_STRING,EXT_DLL) \
+	    $(call SUBST_STRING,EXE) \
+	    $(call SUBST_STRING,EXT_LIB) \
+	    $(call SUBST_STRING,EXT_OBJ) \
+	    $(call SUBST,FLAMBDA) \
+	    $(call SUBST,WITH_FLAMBDA_INVARIANTS) \
+	    $(call SUBST,WITH_CMM_INVARIANTS) \
+	    $(call SUBST_STRING,FLEXLINK_FLAGS) \
+	    $(call SUBST_QUOTE,FLEXDLL_DIR) \
+	    $(call SUBST,HOST) \
+	    $(call SUBST_STRING,BINDIR) \
+	    $(call SUBST_STRING,LIBDIR) \
+	    $(call SUBST_STRING,MKDLL) \
+	    $(call SUBST_STRING,MKEXE) \
+	    $(call SUBST_STRING,FLEXLINK_LDFLAGS) \
+	    $(call SUBST_STRING,FLEXLINK_DLL_LDFLAGS) \
+	    $(call SUBST_STRING,MKMAINDLL) \
+	    $(call SUBST,MODEL) \
+	    $(call SUBST_STRING,NATIVECCLIBS) \
+	    $(call SUBST_STRING,OCAMLC_CFLAGS) \
+	    $(call SUBST_STRING,OCAMLC_CPPFLAGS) \
+	    $(call SUBST_STRING,OCAMLOPT_CFLAGS) \
+	    $(call SUBST_STRING,OCAMLOPT_CPPFLAGS) \
+	    $(call SUBST_STRING,PACKLD) \
+	    $(call SUBST,PROFINFO_WIDTH) \
+	    $(call SUBST_STRING,RANLIBCMD) \
+	    $(call SUBST_STRING,RPATH) \
+	    $(call SUBST_STRING,MKSHAREDLIBRPATH) \
+	    $(call SUBST,FORCE_SAFE_STRING) \
+	    $(call SUBST,DEFAULT_SAFE_STRING) \
+	    $(call SUBST,WINDOWS_UNICODE) \
+	    $(call SUBST,SUPPORTS_SHARED_LIBRARIES) \
+	    $(call SUBST,SYSTEM) \
+	    $(call SUBST,SYSTHREAD_SUPPORT) \
+	    $(call SUBST,TARGET) \
+	    $(call SUBST,WITH_FRAME_POINTERS) \
+	    $(call SUBST,WITH_PROFINFO) \
+	    $(call SUBST,FLAT_FLOAT_ARRAY) \
+	    $(call SUBST,FUNCTION_SECTIONS) \
+	    $(call SUBST,CC_HAS_DEBUG_PREFIX_MAP) \
+	    $(call SUBST,AS_HAS_DEBUG_PREFIX_MAP) \
+	    $< > $@
+
+# Test for the substitution functions above
+
+ALLCHARS= \
+  !"\#\$\%&'()*+,-./ \
+  0123456789:;<=>? \
+  @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_ \
+  `abcdefghijklmnopqrstuvwxyz{|}~
+
+TMPFILE=testdata.tmp
+TMPSCRIPT=ocamlscript.tmp
+
+test-subst:
+	$(file >$(TMPFILE),$(ALLCHARS))
+	echo '%%ALLCHARS%%' | sed $(call SUBST,ALLCHARS) | cmp $(TMPFILE) -
+	@rm $(TMPFILE)
+	@echo "Test passed"
+
+# This test assumes there is a working OCaml in the path
+
+test-subst-string:
+	$(file >$(TMPFILE),$(ALLCHARS))
+	echo 'print_string "%%ALLCHARS%%"; print_newline();;' \
+        | sed $(call SUBST_STRING,ALLCHARS) > $(TMPSCRIPT) && \
+        ocaml $(TMPSCRIPT) | cmp $(TMPFILE) -
+	@rm $(TMPFILE) $(TMPSCRIPT)
+	@echo "Test passed"
diff --git a/upstream/ocaml_413/utils/arg_helper.ml b/upstream/ocaml_413/utils/arg_helper.ml
new file mode 100644
index 0000000..fa80007
--- /dev/null
+++ b/upstream/ocaml_413/utils/arg_helper.ml
@@ -0,0 +1,127 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2015--2016 OCamlPro SAS                                    *)
+(*   Copyright 2015--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+let fatal err =
+  prerr_endline err;
+  exit 2
+
+module Make (S : sig
+  module Key : sig
+    type t
+    val of_string : string -> t
+    module Map : Map.S with type key = t
+  end
+
+  module Value : sig
+    type t
+    val of_string : string -> t
+  end
+end) = struct
+  type parsed = {
+    base_default : S.Value.t;
+    base_override : S.Value.t S.Key.Map.t;
+    user_default : S.Value.t option;
+    user_override : S.Value.t S.Key.Map.t;
+  }
+
+  let default v =
+    { base_default = v;
+      base_override = S.Key.Map.empty;
+      user_default = None;
+      user_override = S.Key.Map.empty; }
+
+  let set_base_default value t =
+    { t with base_default = value }
+
+  let add_base_override key value t =
+    { t with base_override = S.Key.Map.add key value t.base_override }
+
+  let reset_base_overrides t =
+    { t with base_override = S.Key.Map.empty }
+
+  let set_user_default value t =
+    { t with user_default = Some value }
+
+  let add_user_override key value t =
+    { t with user_override = S.Key.Map.add key value t.user_override }
+
+  exception Parse_failure of exn
+
+  let parse_exn str ~update =
+    (* Is the removal of empty chunks really relevant here? *)
+    (* (It has been added to mimic the old Misc.String.split.) *)
+    let values = String.split_on_char ',' str |> List.filter ((<>) "") in
+    let parsed =
+      List.fold_left (fun acc value ->
+          match String.index value '=' with
+          | exception Not_found ->
+            begin match S.Value.of_string value with
+            | value -> set_user_default value acc
+            | exception exn -> raise (Parse_failure exn)
+            end
+          | equals ->
+            let key_value_pair = value in
+            let length = String.length key_value_pair in
+            assert (equals >= 0 && equals < length);
+            if equals = 0 then begin
+              raise (Parse_failure (
+                Failure "Missing key in argument specification"))
+            end;
+            let key =
+              let key = String.sub key_value_pair 0 equals in
+              try S.Key.of_string key
+              with exn -> raise (Parse_failure exn)
+            in
+            let value =
+              let value =
+                String.sub key_value_pair (equals + 1) (length - equals - 1)
+              in
+              try S.Value.of_string value
+              with exn -> raise (Parse_failure exn)
+            in
+            add_user_override key value acc)
+        !update
+        values
+    in
+    update := parsed
+
+  let parse str help_text update =
+    match parse_exn str ~update with
+    | () -> ()
+    | exception (Parse_failure exn) ->
+      fatal (Printf.sprintf "%s: %s" (Printexc.to_string exn) help_text)
+
+  type parse_result =
+    | Ok
+    | Parse_failed of exn
+
+  let parse_no_error str update =
+    match parse_exn str ~update with
+    | () -> Ok
+    | exception (Parse_failure exn) -> Parse_failed exn
+
+  let get ~key parsed =
+    match S.Key.Map.find key parsed.user_override with
+    | value -> value
+    | exception Not_found ->
+      match parsed.user_default with
+      | Some value -> value
+      | None ->
+        match S.Key.Map.find key parsed.base_override with
+        | value -> value
+        | exception Not_found -> parsed.base_default
+
+end
diff --git a/upstream/ocaml_413/utils/arg_helper.mli b/upstream/ocaml_413/utils/arg_helper.mli
new file mode 100644
index 0000000..18f60fe
--- /dev/null
+++ b/upstream/ocaml_413/utils/arg_helper.mli
@@ -0,0 +1,68 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2015--2016 OCamlPro SAS                                    *)
+(*   Copyright 2015--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Decipher command line arguments of the form
+        <value> | <key>=<value>[,...]
+
+    (as used for example for the specification of inlining parameters
+    varying by simplification round).
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+module Make (S : sig
+  module Key : sig
+    type t
+
+    (** The textual representation of a key must not contain '=' or ','. *)
+    val of_string : string -> t
+
+    module Map : Map.S with type key = t
+  end
+
+  module Value : sig
+    type t
+
+    (** The textual representation of a value must not contain ','. *)
+    val of_string : string -> t
+  end
+end) : sig
+  type parsed
+
+  val default : S.Value.t -> parsed
+
+  val set_base_default : S.Value.t -> parsed -> parsed
+
+  val add_base_override : S.Key.t -> S.Value.t -> parsed -> parsed
+
+  val reset_base_overrides : parsed -> parsed
+
+  val set_user_default : S.Value.t -> parsed -> parsed
+
+  val add_user_override : S.Key.t -> S.Value.t -> parsed -> parsed
+
+  val parse : string -> string -> parsed ref -> unit
+
+  type parse_result =
+    | Ok
+    | Parse_failed of exn
+
+  val parse_no_error : string -> parsed ref -> parse_result
+
+  val get : key:S.Key.t -> parsed -> S.Value.t
+end
diff --git a/upstream/ocaml_413/utils/binutils.ml b/upstream/ocaml_413/utils/binutils.ml
new file mode 100644
index 0000000..cf8a53e
--- /dev/null
+++ b/upstream/ocaml_413/utils/binutils.ml
@@ -0,0 +1,684 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                        Nicolas Ojeda Bar, LexiFi                       *)
+(*                                                                        *)
+(*   Copyright 2020 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+let char_to_hex c =
+  Printf.sprintf "0x%02x" (Char.code c)
+
+let int_to_hex n =
+  Printf.sprintf "0x%x" n
+
+type error =
+  | Truncated_file
+  | Unrecognized of string
+  | Unsupported of string * int64
+  | Out_of_range of string
+
+let error_to_string = function
+  | Truncated_file ->
+      "Truncated file"
+  | Unrecognized magic ->
+      Printf.sprintf "Unrecognized magic: %s"
+        (String.concat " "
+           (List.init (String.length magic)
+              (fun i -> char_to_hex magic.[i])))
+  | Unsupported (s, n) ->
+      Printf.sprintf "Unsupported: %s: 0x%Lx" s n
+  | Out_of_range s ->
+      Printf.sprintf "Out of range constant: %s" s
+
+exception Error of error
+
+let name_at ?max_len buf start =
+  if start < 0 || start > Bytes.length buf then
+    raise (Error (Out_of_range (int_to_hex start)));
+  let max_pos =
+    match max_len with
+    | None -> Bytes.length buf
+    | Some n -> Int.min (Bytes.length buf) (start + n)
+  in
+  let rec loop pos =
+    if pos >= max_pos || Bytes.get buf pos = '\000'
+    then
+      Bytes.sub_string buf start (pos - start)
+    else
+      loop (succ pos)
+  in
+  loop start
+
+let array_find_map f a =
+  let rec loop i =
+    if i >= Array.length a then None
+    else begin
+      match f a.(i) with
+      | None -> loop (succ i)
+      | Some _ as r -> r
+    end
+  in
+  loop 0
+
+let array_find f a =
+  array_find_map (fun x -> if f x then Some x else None) a
+
+let really_input_bytes ic len =
+  let buf = Bytes.create len in
+  really_input ic buf 0 len;
+  buf
+
+let uint64_of_uint32 n =
+  Int64.(logand (of_int32 n) 0xffffffffL)
+
+type endianness =
+  | LE
+  | BE
+
+type bitness =
+  | B32
+  | B64
+
+type decoder =
+  {
+    ic: in_channel;
+    endianness: endianness;
+    bitness: bitness;
+  }
+
+let word_size = function
+  | {bitness = B64; _} -> 8
+  | {bitness = B32; _} -> 4
+
+let get_uint16 {endianness; _} buf idx =
+  match endianness with
+  | LE -> Bytes.get_uint16_le buf idx
+  | BE -> Bytes.get_uint16_be buf idx
+
+let get_uint32 {endianness; _} buf idx =
+  match endianness with
+  | LE -> Bytes.get_int32_le buf idx
+  | BE -> Bytes.get_int32_be buf idx
+
+let get_uint s d buf idx =
+  let n = get_uint32 d buf idx in
+  match Int32.unsigned_to_int n with
+  | None -> raise (Error (Unsupported (s, Int64.of_int32 n)))
+  | Some n -> n
+
+let get_uint64 {endianness; _} buf idx =
+  match endianness with
+  | LE -> Bytes.get_int64_le buf idx
+  | BE -> Bytes.get_int64_be buf idx
+
+let get_word d buf idx =
+  match d.bitness with
+  | B64 -> get_uint64 d buf idx
+  | B32 -> uint64_of_uint32 (get_uint32 d buf idx)
+
+let uint64_to_int s n =
+  match Int64.unsigned_to_int n with
+  | None -> raise (Error (Unsupported (s, n)))
+  | Some n -> n
+
+let load_bytes d off len =
+  LargeFile.seek_in d.ic off;
+  really_input_bytes d.ic len
+
+type t =
+  {
+    defines_symbol: string -> bool;
+    symbol_offset: string -> int64 option;
+  }
+
+module ELF = struct
+
+  (* Reference: http://man7.org/linux/man-pages/man5/elf.5.html *)
+
+  let header_size d =
+    40 + 3 * word_size d
+
+  type header =
+    {
+      e_shoff: int64;
+      e_shentsize: int;
+      e_shnum: int;
+      e_shstrndx: int;
+    }
+
+  let read_header d =
+    let buf = load_bytes d 0L (header_size d) in
+    let word_size = word_size d in
+    let e_shnum = get_uint16 d buf (36 + 3 * word_size) in
+    let e_shentsize = get_uint16 d buf (34 + 3 * word_size) in
+    let e_shoff = get_word d buf (24 + 2 * word_size) in
+    let e_shstrndx = get_uint16 d buf (38 + 3 * word_size) in
+    {e_shnum; e_shentsize; e_shoff; e_shstrndx}
+
+  type sh_type =
+    | SHT_STRTAB
+    | SHT_DYNSYM
+    | SHT_OTHER
+
+  type section =
+    {
+      sh_name: int;
+      sh_type: sh_type;
+      sh_addr: int64;
+      sh_offset: int64;
+      sh_size: int;
+      sh_entsize: int;
+      sh_name_str: string;
+    }
+
+  let load_section_body d {sh_offset; sh_size; _} =
+    load_bytes d sh_offset sh_size
+
+  let read_sections d {e_shoff; e_shnum; e_shentsize; e_shstrndx; _} =
+    let buf = load_bytes d e_shoff (e_shnum * e_shentsize) in
+    let word_size = word_size d in
+    let mk i =
+      let base = i * e_shentsize in
+      let sh_name = get_uint "sh_name" d buf (base + 0) in
+      let sh_type =
+        match get_uint32 d buf (base + 4) with
+        | 3l -> SHT_STRTAB
+        | 11l -> SHT_DYNSYM
+        | _ -> SHT_OTHER
+      in
+      let sh_addr = get_word d buf (base + 8 + word_size) in
+      let sh_offset = get_word d buf (base + 8 + 2 * word_size) in
+      let sh_size =
+        uint64_to_int "sh_size"
+          (get_word d buf (base + 8 + 3 * word_size))
+      in
+      let sh_entsize =
+        uint64_to_int "sh_entsize"
+          (get_word d buf (base + 16 + 5 * word_size))
+      in
+      {sh_name; sh_type; sh_addr; sh_offset;
+       sh_size; sh_entsize; sh_name_str = ""}
+    in
+    let sections = Array.init e_shnum mk in
+    if e_shstrndx = 0 then
+      (* no string table *)
+      sections
+    else
+      let shstrtbl = load_section_body d sections.(e_shstrndx) in
+      let set_name sec =
+        let sh_name_str = name_at shstrtbl sec.sh_name in
+        {sec with sh_name_str}
+      in
+      Array.map set_name sections
+
+  let read_sections d h =
+    let {e_shoff; e_shentsize; e_shnum; e_shstrndx} = h in
+    if e_shoff = 0L then
+      [||]
+    else begin
+      let buf = lazy (load_bytes d e_shoff e_shentsize) in
+      let word_size = word_size d in
+      let e_shnum =
+        if e_shnum = 0 then
+          (* The real e_shnum is the sh_size of the initial section.*)
+          uint64_to_int "e_shnum"
+            (get_word d (Lazy.force buf) (8 + 3 * word_size))
+        else
+          e_shnum
+      in
+      let e_shstrndx =
+        if e_shstrndx = 0xffff then
+          (* The real e_shstrndx is the sh_link of the initial section. *)
+          get_uint "e_shstrndx" d (Lazy.force buf) (8 + 4 * word_size)
+        else
+          e_shstrndx
+      in
+      read_sections d {h with e_shnum; e_shstrndx}
+    end
+
+  type symbol =
+    {
+      st_name: string;
+      st_value: int64;
+      st_shndx: int;
+    }
+
+  let find_section sections type_ sectname =
+    let f {sh_type; sh_name_str; _} =
+      sh_type = type_ && sh_name_str = sectname
+    in
+    array_find f sections
+
+  let read_symbols d sections =
+    match find_section sections SHT_DYNSYM ".dynsym" with
+    | None -> [| |]
+    | Some {sh_entsize = 0; _} ->
+        raise (Error (Out_of_range "sh_entsize=0"))
+    | Some dynsym ->
+        begin match find_section sections SHT_STRTAB ".dynstr" with
+        | None -> [| |]
+        | Some dynstr ->
+            let strtbl = load_section_body d dynstr in
+            let buf = load_section_body d dynsym in
+            let word_size = word_size d in
+            let mk i =
+              let base = i * dynsym.sh_entsize in
+              let st_name = name_at strtbl (get_uint "st_name" d buf base) in
+              let st_value = get_word d buf (base + word_size (* ! *)) in
+              let st_shndx =
+                let off = match d.bitness with B64 -> 6 | B32 -> 14 in
+                get_uint16 d buf (base + off)
+              in
+              {st_name; st_value; st_shndx}
+            in
+            Array.init (dynsym.sh_size / dynsym.sh_entsize) mk
+        end
+
+  let find_symbol symbols symname =
+    let f = function
+      | {st_shndx = 0; _} -> false
+      | {st_name; _} -> st_name = symname
+    in
+    array_find f symbols
+
+  let symbol_offset sections symbols symname =
+    match find_symbol symbols symname with
+    | None ->
+        None
+    | Some {st_shndx; st_value; _} ->
+        (* st_value in executables and shared objects holds a virtual (absolute)
+           address. See https://refspecs.linuxfoundation.org/elf/elf.pdf, page
+           1-21, "Symbol Values". *)
+        Some Int64.(add sections.(st_shndx).sh_offset
+                      (sub st_value sections.(st_shndx).sh_addr))
+
+  let defines_symbol symbols symname =
+    Option.is_some (find_symbol symbols symname)
+
+  let read ic =
+    seek_in ic 0;
+    let identification = really_input_bytes ic 16 in
+    let bitness =
+      match Bytes.get identification 4 with
+      | '\x01' -> B32
+      | '\x02' -> B64
+      | _ as c ->
+          raise (Error (Unsupported ("ELFCLASS", Int64.of_int (Char.code c))))
+    in
+    let endianness =
+      match Bytes.get identification 5 with
+      | '\x01' -> LE
+      | '\x02' -> BE
+      | _ as c ->
+          raise (Error (Unsupported ("ELFDATA", Int64.of_int (Char.code c))))
+    in
+    let d = {ic; bitness; endianness} in
+    let header = read_header d in
+    let sections = read_sections d header in
+    let symbols = read_symbols d sections in
+    let symbol_offset = symbol_offset sections symbols in
+    let defines_symbol = defines_symbol symbols in
+    {symbol_offset; defines_symbol}
+end
+
+module Mach_O = struct
+
+  (* Reference:
+     https://github.com/aidansteele/osx-abi-macho-file-format-reference *)
+
+  let size_int = 4
+
+  let header_size {bitness; _} =
+    (match bitness with B64 -> 6 | B32 -> 5) * 4 + 2 * size_int
+
+  type header =
+    {
+      ncmds: int;
+      sizeofcmds: int;
+    }
+
+  let read_header d =
+    let buf = load_bytes d 0L (header_size d) in
+    let ncmds = get_uint "ncmds" d buf (8 + 2 * size_int) in
+    let sizeofcmds = get_uint "sizeofcmds" d buf (12 + 2 * size_int) in
+    {ncmds; sizeofcmds}
+
+  type lc_symtab =
+    {
+      symoff: int32;
+      nsyms: int;
+      stroff: int32;
+      strsize: int;
+    }
+
+  type load_command =
+    | LC_SYMTAB of lc_symtab
+    | OTHER
+
+  let read_load_commands d {ncmds; sizeofcmds} =
+    let buf = load_bytes d (Int64.of_int (header_size d)) sizeofcmds in
+    let base = ref 0 in
+    let mk _ =
+      let cmd = get_uint32 d buf (!base + 0) in
+      let cmdsize = get_uint "cmdsize" d buf (!base + 4) in
+      let lc =
+        match cmd with
+        | 0x2l ->
+            let symoff = get_uint32 d buf (!base + 8) in
+            let nsyms = get_uint "nsyms" d buf (!base + 12) in
+            let stroff = get_uint32 d buf (!base + 16) in
+            let strsize = get_uint "strsize" d buf (!base + 20) in
+            LC_SYMTAB {symoff; nsyms; stroff; strsize}
+        | _ ->
+            OTHER
+      in
+      base := !base + cmdsize;
+      lc
+    in
+    Array.init ncmds mk
+
+  type symbol =
+    {
+      n_name: string;
+      n_type: int;
+      n_value: int64;
+    }
+
+  let size_nlist d =
+    8 + word_size d
+
+  let read_symbols d load_commands =
+    match
+      (* Can it happen there be more than one LC_SYMTAB? *)
+      array_find_map (function
+          | LC_SYMTAB symtab -> Some symtab
+          | _ -> None
+        ) load_commands
+    with
+    | None -> [| |]
+    | Some {symoff; nsyms; stroff; strsize} ->
+        let strtbl = load_bytes d (uint64_of_uint32 stroff) strsize in
+        let buf =
+          load_bytes d (uint64_of_uint32 symoff) (nsyms * size_nlist d) in
+        let size_nlist = size_nlist d in
+        let mk i =
+          let base = i * size_nlist in
+          let n_name = name_at strtbl (get_uint "n_name" d buf (base + 0)) in
+          let n_type = Bytes.get_uint8 buf (base + 4) in
+          let n_value = get_word d buf (base + 8) in
+          {n_name; n_type; n_value}
+        in
+        Array.init nsyms mk
+
+  let fix symname =
+    "_" ^ symname
+
+  let find_symbol symbols symname =
+    let f {n_name; n_type; _} =
+      n_type land 0b1111 = 0b1111 (* N_EXT + N_SECT *) &&
+      n_name = symname
+    in
+    array_find f symbols
+
+  let symbol_offset symbols symname =
+    let symname = fix symname in
+    match find_symbol symbols symname with
+    | None -> None
+    | Some {n_value; _} -> Some n_value
+
+  let defines_symbol symbols symname =
+    let symname = fix symname in
+    Option.is_some (find_symbol symbols symname)
+
+  type magic =
+    | MH_MAGIC
+    | MH_CIGAM
+    | MH_MAGIC_64
+    | MH_CIGAM_64
+
+  let read ic =
+    seek_in ic 0;
+    let magic = really_input_bytes ic 4 in
+    let magic =
+      match Bytes.get_int32_ne magic 0 with
+      | 0xFEEDFACEl -> MH_MAGIC
+      | 0xCEFAEDFEl -> MH_CIGAM
+      | 0xFEEDFACFl -> MH_MAGIC_64
+      | 0xCFFAEDFEl -> MH_CIGAM_64
+      | _ -> (* should not happen *)
+          raise (Error (Unrecognized (Bytes.to_string magic)))
+    in
+    let bitness =
+      match magic with
+      | MH_MAGIC | MH_CIGAM -> B32
+      | MH_MAGIC_64 | MH_CIGAM_64 -> B64
+    in
+    let endianness =
+      match magic, Sys.big_endian with
+      | (MH_MAGIC | MH_MAGIC_64), false
+      | (MH_CIGAM | MH_CIGAM_64), true -> LE
+      | (MH_MAGIC | MH_MAGIC_64), true
+      | (MH_CIGAM | MH_CIGAM_64), false -> BE
+    in
+    let d = {ic; endianness; bitness} in
+    let header = read_header d in
+    let load_commands = read_load_commands d header in
+    let symbols = read_symbols d load_commands in
+    let symbol_offset = symbol_offset symbols in
+    let defines_symbol = defines_symbol symbols in
+    {symbol_offset; defines_symbol}
+end
+
+module FlexDLL = struct
+
+  (* Reference:
+     https://docs.microsoft.com/en-us/windows/win32/debug/pe-format *)
+
+  let header_size = 24
+
+  type header =
+    {
+      e_lfanew: int64;
+      number_of_sections: int;
+      size_of_optional_header: int;
+      _characteristics: int;
+    }
+
+  let read_header e_lfanew d buf =
+    let number_of_sections = get_uint16 d buf 6 in
+    let size_of_optional_header = get_uint16 d buf 20 in
+    let _characteristics = get_uint16 d buf 22 in
+    {e_lfanew; number_of_sections; size_of_optional_header; _characteristics}
+
+  type optional_header_magic =
+    | PE32
+    | PE32PLUS
+
+  type optional_header =
+    {
+      _magic: optional_header_magic;
+      image_base: int64;
+    }
+
+  let read_optional_header d {e_lfanew; size_of_optional_header; _} =
+    if size_of_optional_header = 0 then
+      raise (Error (Unrecognized "SizeOfOptionalHeader=0"));
+    let buf =
+      load_bytes d Int64.(add e_lfanew (of_int header_size))
+        size_of_optional_header
+    in
+    let _magic, image_base =
+      match get_uint16 d buf 0 with
+      | 0x10b -> PE32, uint64_of_uint32 (get_uint32 d buf 28)
+      | 0x20b -> PE32PLUS, get_uint64 d buf 24
+      | n ->
+          raise (Error (Unsupported ("optional_header_magic", Int64.of_int n)))
+    in
+    {_magic; image_base}
+
+  type section =
+    {
+      name: string;
+      _virtual_size: int;
+      virtual_address: int64;
+      size_of_raw_data: int;
+      pointer_to_raw_data: int64;
+    }
+
+  let section_header_size = 40
+
+  let read_sections d
+      {e_lfanew; number_of_sections; size_of_optional_header; _} =
+    let buf =
+      load_bytes d
+        Int64.(add e_lfanew (of_int (header_size + size_of_optional_header)))
+        (number_of_sections * section_header_size)
+    in
+    let mk i =
+      let base = i * section_header_size in
+      let name = name_at ~max_len:8 buf (base + 0) in
+      let _virtual_size = get_uint "virtual_size" d buf (base + 8) in
+      let virtual_address = uint64_of_uint32 (get_uint32 d buf (base + 12)) in
+      let size_of_raw_data = get_uint "size_of_raw_data" d buf (base + 16) in
+      let pointer_to_raw_data =
+        uint64_of_uint32 (get_uint32 d buf (base + 20)) in
+      {name; _virtual_size; virtual_address;
+       size_of_raw_data; pointer_to_raw_data}
+    in
+    Array.init number_of_sections mk
+
+  type symbol =
+    {
+      name: string;
+      address: int64;
+    }
+
+  let load_section_body d {size_of_raw_data; pointer_to_raw_data; _} =
+    load_bytes d pointer_to_raw_data size_of_raw_data
+
+  let find_section sections sectname =
+    array_find (function ({name; _} : section) -> name = sectname) sections
+
+  (* We extract the list of exported symbols as encoded by flexlink, see
+     https://github.com/alainfrisch/flexdll/blob/bd636def70d941674275b2f4b6c13a34ba23f9c9/reloc.ml
+     #L500-L525 *)
+
+  let read_symbols d {image_base; _} sections =
+    match find_section sections ".exptbl" with
+    | None -> [| |]
+    | Some ({virtual_address; _} as exptbl) ->
+        let buf = load_section_body d exptbl in
+        let numexports =
+          uint64_to_int "numexports" (get_word d buf 0)
+        in
+        let word_size = word_size d in
+        let mk i =
+          let address = get_word d buf (word_size * (2 * i + 1)) in
+          let nameoff = get_word d buf (word_size * (2 * i + 2)) in
+          let name =
+            let off = Int64.(sub nameoff (add virtual_address image_base)) in
+            name_at buf (uint64_to_int "exptbl name offset" off)
+          in
+          {name; address}
+        in
+        Array.init numexports mk
+
+  let symbol_offset {image_base; _} sections symbols =
+    match find_section sections ".data" with
+    | None -> Fun.const None
+    | Some {virtual_address; pointer_to_raw_data; _} ->
+        fun symname ->
+          begin match
+            array_find (function {name; _} -> name = symname) symbols
+          with
+          | None -> None
+          | Some {address; _} ->
+              Some Int64.(add pointer_to_raw_data
+                            (sub address (add virtual_address image_base)))
+          end
+
+  let defines_symbol symbols symname =
+    Array.exists (fun {name; _} -> name = symname) symbols
+
+  type machine_type =
+    | IMAGE_FILE_MACHINE_ARM
+    | IMAGE_FILE_MACHINE_ARM64
+    | IMAGE_FILE_MACHINE_AMD64
+    | IMAGE_FILE_MACHINE_I386
+
+  let read ic =
+    let e_lfanew =
+      seek_in ic 0x3c;
+      let buf = really_input_bytes ic 4 in
+      uint64_of_uint32 (Bytes.get_int32_le buf 0)
+    in
+    LargeFile.seek_in ic e_lfanew;
+    let buf = really_input_bytes ic header_size in
+    let magic = Bytes.sub_string buf 0 4 in
+    if magic <> "PE\000\000" then raise (Error (Unrecognized magic));
+    let machine =
+      match Bytes.get_uint16_le buf 4 with
+      | 0x1c0 -> IMAGE_FILE_MACHINE_ARM
+      | 0xaa64 -> IMAGE_FILE_MACHINE_ARM64
+      | 0x8664 -> IMAGE_FILE_MACHINE_AMD64
+      | 0x14c -> IMAGE_FILE_MACHINE_I386
+      | n -> raise (Error (Unsupported ("MACHINETYPE", Int64.of_int n)))
+    in
+    let bitness =
+      match machine with
+      | IMAGE_FILE_MACHINE_AMD64
+      | IMAGE_FILE_MACHINE_ARM64 -> B64
+      | IMAGE_FILE_MACHINE_I386
+      | IMAGE_FILE_MACHINE_ARM -> B32
+    in
+    let d = {ic; endianness = LE; bitness} in
+    let header = read_header e_lfanew d buf in
+    let opt_header = read_optional_header d header in
+    let sections = read_sections d header in
+    let symbols = read_symbols d opt_header sections in
+    let symbol_offset = symbol_offset opt_header sections symbols in
+    let defines_symbol = defines_symbol symbols in
+    {symbol_offset; defines_symbol}
+end
+
+let read ic =
+  seek_in ic 0;
+  let magic = really_input_string ic 4 in
+  match magic.[0], magic.[1], magic.[2], magic.[3] with
+  | '\x7F', 'E', 'L', 'F' ->
+      ELF.read ic
+  | '\xFE', '\xED', '\xFA', '\xCE'
+  | '\xCE', '\xFA', '\xED', '\xFE'
+  | '\xFE', '\xED', '\xFA', '\xCF'
+  | '\xCF', '\xFA', '\xED', '\xFE' ->
+      Mach_O.read ic
+  | 'M', 'Z', _, _ ->
+      FlexDLL.read ic
+  | _ ->
+      raise (Error (Unrecognized magic))
+
+let with_open_in fn f =
+  let ic = open_in_bin fn in
+  Fun.protect ~finally:(fun () -> close_in_noerr ic) (fun () -> f ic)
+
+let read filename =
+  match with_open_in filename read with
+  | t -> Ok t
+  | exception End_of_file ->
+      Result.Error Truncated_file
+  | exception Error err ->
+      Result.Error err
+
+let defines_symbol {defines_symbol; _} symname =
+  defines_symbol symname
+
+let symbol_offset {symbol_offset; _} symname =
+  symbol_offset symname
diff --git a/upstream/ocaml_413/utils/binutils.mli b/upstream/ocaml_413/utils/binutils.mli
new file mode 100644
index 0000000..44e17fe
--- /dev/null
+++ b/upstream/ocaml_413/utils/binutils.mli
@@ -0,0 +1,30 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                        Nicolas Ojeda Bar, LexiFi                       *)
+(*                                                                        *)
+(*   Copyright 2020 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type error =
+  | Truncated_file
+  | Unrecognized of string
+  | Unsupported of string * int64
+  | Out_of_range of string
+
+val error_to_string: error -> string
+
+type t
+
+val read: string -> (t, error) Result.t
+
+val defines_symbol: t -> string -> bool
+
+val symbol_offset: t -> string -> int64 option
diff --git a/upstream/ocaml_413/utils/build_path_prefix_map.ml b/upstream/ocaml_413/utils/build_path_prefix_map.ml
new file mode 100644
index 0000000..c204d3a
--- /dev/null
+++ b/upstream/ocaml_413/utils/build_path_prefix_map.ml
@@ -0,0 +1,119 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*            Gabriel Scherer, projet Parsifal, INRIA Saclay              *)
+(*                                                                        *)
+(*   Copyright 2017 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type path = string
+type path_prefix = string
+type error_message = string
+
+let errorf fmt = Printf.kprintf (fun err -> Error err) fmt
+
+let encode_prefix str =
+  let buf = Buffer.create (String.length str) in
+  let push_char = function
+    | '%' -> Buffer.add_string buf "%#"
+    | '=' -> Buffer.add_string buf "%+"
+    | ':' -> Buffer.add_string buf "%."
+    | c -> Buffer.add_char buf c
+  in
+  String.iter push_char str;
+  Buffer.contents buf
+
+let decode_prefix str =
+  let buf = Buffer.create (String.length str) in
+  let rec loop i =
+    if i >= String.length str
+    then Ok (Buffer.contents buf)
+    else match str.[i] with
+      | ('=' | ':') as c ->
+        errorf "invalid character '%c' in key or value" c
+      | '%' ->
+        let push c = Buffer.add_char buf c; loop (i + 2) in
+        if i + 1 = String.length str then
+          errorf "invalid encoded string %S (trailing '%%')" str
+        else begin match str.[i + 1] with
+            | '#' -> push '%'
+            | '+' -> push '='
+            | '.' -> push ':'
+            | c -> errorf "invalid %%-escaped character '%c'" c
+        end
+      | c ->
+        Buffer.add_char buf c;
+        loop (i + 1)
+  in loop 0
+
+type pair = { target: path_prefix; source : path_prefix }
+
+let encode_pair { target; source } =
+  String.concat "=" [encode_prefix target; encode_prefix source]
+
+let decode_pair str =
+  match String.index str '=' with
+  | exception Not_found ->
+    errorf "invalid key/value pair %S, no '=' separator" str
+  | equal_pos ->
+    let encoded_target = String.sub str 0 equal_pos in
+    let encoded_source =
+      String.sub str (equal_pos + 1) (String.length str - equal_pos - 1) in
+    match decode_prefix encoded_target, decode_prefix encoded_source with
+    | Ok target, Ok source -> Ok { target; source }
+    | ((Error _ as err), _) | (_, (Error _ as err)) -> err
+
+type map = pair option list
+
+let encode_map map =
+  let encode_elem = function
+    | None -> ""
+    | Some pair -> encode_pair pair
+  in
+  List.map encode_elem map
+  |> String.concat ":"
+
+let decode_map str =
+  let exception Shortcut of error_message in
+  let decode_or_empty = function
+    | "" -> None
+    | pair ->
+      begin match decode_pair pair with
+        | Ok str -> Some str
+        | Error err -> raise (Shortcut err)
+      end
+  in
+  let pairs = String.split_on_char ':' str in
+  match List.map decode_or_empty pairs with
+  | exception (Shortcut err) -> Error err
+  | map -> Ok map
+
+let rewrite_opt prefix_map path =
+  let is_prefix = function
+    | None -> false
+    | Some { target = _; source } ->
+      String.length source <= String.length path
+      && String.equal source (String.sub path 0 (String.length source))
+  in
+  match
+    List.find is_prefix
+      (* read key/value pairs from right to left, as the spec demands *)
+      (List.rev prefix_map)
+  with
+  | exception Not_found -> None
+  | None -> None
+  | Some { source; target } ->
+      Some (target ^ (String.sub path (String.length source)
+                       (String.length path - String.length source)))
+
+let rewrite prefix_map path =
+  match rewrite_opt prefix_map path with
+  | None -> path
+  | Some path -> path
diff --git a/upstream/ocaml_413/utils/build_path_prefix_map.mli b/upstream/ocaml_413/utils/build_path_prefix_map.mli
new file mode 100644
index 0000000..dbcc8dc
--- /dev/null
+++ b/upstream/ocaml_413/utils/build_path_prefix_map.mli
@@ -0,0 +1,47 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*            Gabriel Scherer, projet Parsifal, INRIA Saclay              *)
+(*                                                                        *)
+(*   Copyright 2017 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Rewrite paths for reproducible builds
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+
+type path = string
+type path_prefix = string
+type error_message = string
+
+val encode_prefix : path_prefix -> string
+val decode_prefix : string -> (path_prefix, error_message) result
+
+type pair = { target: path_prefix; source : path_prefix }
+
+val encode_pair : pair -> string
+val decode_pair : string -> (pair, error_message) result
+
+type map = pair option list
+
+val encode_map : map -> string
+val decode_map : string -> (map, error_message) result
+
+val rewrite_opt : map -> path -> path option
+(** [rewrite_opt map path] tries to find a source in [map]
+    that is a prefix of the input [path]. If it succeeds,
+    it replaces this prefix with the corresponding target.
+    If it fails, it just returns [None]. *)
+
+val rewrite : map -> path -> path
diff --git a/upstream/ocaml_413/utils/ccomp.ml b/upstream/ocaml_413/utils/ccomp.ml
new file mode 100644
index 0000000..955968d
--- /dev/null
+++ b/upstream/ocaml_413/utils/ccomp.ml
@@ -0,0 +1,213 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Compiling C files and building C libraries *)
+
+let command cmdline =
+  if !Clflags.verbose then begin
+    prerr_string "+ ";
+    prerr_string cmdline;
+    prerr_newline()
+  end;
+  let res = Sys.command cmdline in
+  if res = 127 then raise (Sys_error cmdline);
+  res
+
+let run_command cmdline = ignore(command cmdline)
+
+(* Build @responsefile to work around OS limitations on
+   command-line length.
+   Under Windows, the max length is 8187 minus the length of the
+   COMSPEC variable (or 7 if it's not set).  To be on the safe side,
+   we'll use a response file if we need to pass 4096 or more bytes of
+   arguments.
+   For Unix-like systems, the threshold is 2^16 (64 KiB), which is
+   within the lowest observed limits (2^17 per argument under Linux;
+   between 70000 and 80000 for macOS).
+*)
+
+let build_diversion lst =
+  let (responsefile, oc) = Filename.open_temp_file "camlresp" "" in
+  List.iter (fun f -> Printf.fprintf oc "%s\n" f) lst;
+  close_out oc;
+  at_exit (fun () -> Misc.remove_file responsefile);
+  "@" ^ responsefile
+
+let quote_files lst =
+  let lst = List.filter (fun f -> f <> "") lst in
+  let quoted = List.map Filename.quote lst in
+  let s = String.concat " " quoted in
+  if String.length s >= 65536
+  || (String.length s >= 4096 && Sys.os_type = "Win32")
+  then build_diversion quoted
+  else s
+
+let quote_prefixed pr lst =
+  let lst = List.filter (fun f -> f <> "") lst in
+  let lst = List.map (fun f -> pr ^ f) lst in
+  quote_files lst
+
+let quote_optfile = function
+  | None -> ""
+  | Some f -> Filename.quote f
+
+let display_msvc_output file name =
+  let c = open_in file in
+  try
+    let first = input_line c in
+    if first <> Filename.basename name then
+      print_endline first;
+    while true do
+      print_endline (input_line c)
+    done
+  with _ ->
+    close_in c;
+    Sys.remove file
+
+let compile_file ?output ?(opt="") ?stable_name name =
+  let (pipe, file) =
+    if Config.ccomp_type = "msvc" && not !Clflags.verbose then
+      try
+        let (t, c) = Filename.open_temp_file "msvc" "stdout" in
+        close_out c;
+        (Printf.sprintf " > %s" (Filename.quote t), t)
+      with _ ->
+        ("", "")
+    else
+      ("", "") in
+  let debug_prefix_map =
+    match stable_name with
+    | Some stable when Config.c_has_debug_prefix_map ->
+      Printf.sprintf " -fdebug-prefix-map=%s=%s" name stable
+    | Some _ | None -> "" in
+  let exit =
+    command
+      (Printf.sprintf
+         "%s%s %s %s -c %s %s %s %s %s%s"
+         (match !Clflags.c_compiler with
+          | Some cc -> cc
+          | None ->
+              (* #7678: ocamlopt only calls the C compiler to process .c files
+                 from the command line, and the behaviour between
+                 ocamlc/ocamlopt should be identical. *)
+              (String.concat " " [Config.c_compiler;
+                                  Config.ocamlc_cflags;
+                                  Config.ocamlc_cppflags]))
+         debug_prefix_map
+         (match output with
+          | None -> ""
+          | Some o -> Printf.sprintf "%s%s" Config.c_output_obj o)
+         opt
+         (if !Clflags.debug && Config.ccomp_type <> "msvc" then "-g" else "")
+         (String.concat " " (List.rev !Clflags.all_ccopts))
+         (quote_prefixed "-I"
+            (List.map (Misc.expand_directory Config.standard_library)
+               (List.rev !Clflags.include_dirs)))
+         (Clflags.std_include_flag "-I")
+         (Filename.quote name)
+         (* cl tediously includes the name of the C file as the first thing it
+            outputs (in fairness, the tedious thing is that there's no switch to
+            disable this behaviour). In the absence of the Unix module, use
+            a temporary file to filter the output (cannot pipe the output to a
+            filter because this removes the exit status of cl, which is wanted.
+          *)
+         pipe) in
+  if pipe <> ""
+  then display_msvc_output file name;
+  exit
+
+let create_archive archive file_list =
+  Misc.remove_file archive;
+  let quoted_archive = Filename.quote archive in
+  if file_list = [] then
+    0 (* Don't call the archiver: #6550/#1094/#9011 *)
+  else
+    match Config.ccomp_type with
+      "msvc" ->
+        command(Printf.sprintf "link /lib /nologo /out:%s %s"
+                               quoted_archive (quote_files file_list))
+    | _ ->
+        assert(String.length Config.ar > 0);
+        let r1 =
+          command(Printf.sprintf "%s rc %s %s"
+                  Config.ar quoted_archive (quote_files file_list)) in
+        if r1 <> 0 || String.length Config.ranlib = 0
+        then r1
+        else command(Config.ranlib ^ " " ^ quoted_archive)
+
+let expand_libname cclibs =
+  cclibs |> List.map (fun cclib ->
+    if String.starts_with ~prefix:"-l" cclib then
+      let libname =
+        "lib" ^ String.sub cclib 2 (String.length cclib - 2) ^ Config.ext_lib in
+      try
+        Load_path.find libname
+      with Not_found ->
+        libname
+    else cclib)
+
+type link_mode =
+  | Exe
+  | Dll
+  | MainDll
+  | Partial
+
+let remove_Wl cclibs =
+  cclibs |> List.map (fun cclib ->
+    (* -Wl,-foo,bar -> -foo bar *)
+    if String.length cclib >= 4 && "-Wl," = String.sub cclib 0 4 then
+      String.map (function ',' -> ' ' | c -> c)
+                 (String.sub cclib 4 (String.length cclib - 4))
+    else cclib)
+
+let call_linker mode output_name files extra =
+  Profile.record_call "c-linker" (fun () ->
+    let cmd =
+      if mode = Partial then
+        let (l_prefix, files) =
+          match Config.ccomp_type with
+          | "msvc" -> ("/libpath:", expand_libname files)
+          | _ -> ("-L", files)
+        in
+        Printf.sprintf "%s%s %s %s %s"
+          Config.native_pack_linker
+          (Filename.quote output_name)
+          (quote_prefixed l_prefix (Load_path.get_paths ()))
+          (quote_files (remove_Wl files))
+          extra
+      else
+        Printf.sprintf "%s -o %s %s %s %s %s %s"
+          (match !Clflags.c_compiler, mode with
+          | Some cc, _ -> cc
+          | None, Exe -> Config.mkexe
+          | None, Dll -> Config.mkdll
+          | None, MainDll -> Config.mkmaindll
+          | None, Partial -> assert false
+          )
+          (Filename.quote output_name)
+          ""  (*(Clflags.std_include_flag "-I")*)
+          (quote_prefixed "-L" (Load_path.get_paths ()))
+          (String.concat " " (List.rev !Clflags.all_ccopts))
+          (quote_files files)
+          extra
+    in
+    command cmd
+  )
+
+let linker_is_flexlink =
+  (* Config.mkexe, Config.mkdll and Config.mkmaindll are all flexlink
+     invocations for the native Windows ports and for Cygwin, if shared library
+     support is enabled. *)
+  Sys.win32 || Config.supports_shared_libraries && Sys.cygwin
diff --git a/upstream/ocaml_413/utils/ccomp.mli b/upstream/ocaml_413/utils/ccomp.mli
new file mode 100644
index 0000000..46f58a9
--- /dev/null
+++ b/upstream/ocaml_413/utils/ccomp.mli
@@ -0,0 +1,40 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Compiling C files and building C libraries
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+val command: string -> int
+val run_command: string -> unit
+val compile_file:
+  ?output:string -> ?opt:string -> ?stable_name:string -> string -> int
+val create_archive: string -> string list -> int
+val quote_files: string list -> string
+val quote_optfile: string option -> string
+(*val make_link_options: string list -> string*)
+
+type link_mode =
+  | Exe
+  | Dll
+  | MainDll
+  | Partial
+
+val call_linker: link_mode -> string -> string list -> string -> int
+
+val linker_is_flexlink : bool
diff --git a/upstream/ocaml_413/utils/clflags.ml b/upstream/ocaml_413/utils/clflags.ml
new file mode 100644
index 0000000..b9f60cb
--- /dev/null
+++ b/upstream/ocaml_413/utils/clflags.ml
@@ -0,0 +1,575 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Command-line parameters *)
+
+module Int_arg_helper = Arg_helper.Make (struct
+  module Key = struct
+    include Numbers.Int
+    let of_string = int_of_string
+  end
+
+  module Value = struct
+    include Numbers.Int
+    let of_string = int_of_string
+  end
+end)
+module Float_arg_helper = Arg_helper.Make (struct
+  module Key = struct
+    include Numbers.Int
+    let of_string = int_of_string
+  end
+
+  module Value = struct
+    include Numbers.Float
+    let of_string = float_of_string
+  end
+end)
+
+let objfiles = ref ([] : string list)   (* .cmo and .cma files *)
+and ccobjs = ref ([] : string list)     (* .o, .a, .so and -cclib -lxxx *)
+and dllibs = ref ([] : string list)     (* .so and -dllib -lxxx *)
+
+let compile_only = ref false            (* -c *)
+and output_name = ref (None : string option) (* -o *)
+and include_dirs = ref ([] : string list)(* -I *)
+and no_std_include = ref false          (* -nostdlib *)
+and print_types = ref false             (* -i *)
+and make_archive = ref false            (* -a *)
+and debug = ref false                   (* -g *)
+and debug_full = ref false              (* For full DWARF support *)
+and unsafe = ref false                  (* -unsafe *)
+and use_linscan = ref false             (* -linscan *)
+and link_everything = ref false         (* -linkall *)
+and custom_runtime = ref false          (* -custom *)
+and no_check_prims = ref false          (* -no-check-prims *)
+and bytecode_compatible_32 = ref false  (* -compat-32 *)
+and output_c_object = ref false         (* -output-obj *)
+and output_complete_object = ref false  (* -output-complete-obj *)
+and output_complete_executable = ref false  (* -output-complete-exe *)
+and all_ccopts = ref ([] : string list)     (* -ccopt *)
+and classic = ref false                 (* -nolabels *)
+and nopervasives = ref false            (* -nopervasives *)
+and match_context_rows = ref 32         (* -match-context-rows *)
+and preprocessor = ref(None : string option) (* -pp *)
+and all_ppx = ref ([] : string list)        (* -ppx *)
+let absname = ref false                 (* -absname *)
+let annotations = ref false             (* -annot *)
+let binary_annotations = ref false      (* -annot *)
+and use_threads = ref false             (* -thread *)
+and noassert = ref false                (* -noassert *)
+and verbose = ref false                 (* -verbose *)
+and noversion = ref false               (* -no-version *)
+and noprompt = ref false                (* -noprompt *)
+and nopromptcont = ref false            (* -nopromptcont *)
+and init_file = ref (None : string option)   (* -init *)
+and noinit = ref false                  (* -noinit *)
+and open_modules = ref []               (* -open *)
+and use_prims = ref ""                  (* -use-prims ... *)
+and use_runtime = ref ""                (* -use-runtime ... *)
+and plugin = ref false                  (* -plugin ... *)
+and principal = ref false               (* -principal *)
+and real_paths = ref true               (* -short-paths *)
+and recursive_types = ref false         (* -rectypes *)
+and strict_sequence = ref false         (* -strict-sequence *)
+and strict_formats = ref false          (* -strict-formats *)
+and applicative_functors = ref true     (* -no-app-funct *)
+and make_runtime = ref false            (* -make-runtime *)
+and c_compiler = ref (None: string option) (* -cc *)
+and no_auto_link = ref false            (* -noautolink *)
+and dllpaths = ref ([] : string list)   (* -dllpath *)
+and make_package = ref false            (* -pack *)
+and for_package = ref (None: string option) (* -for-pack *)
+and error_size = ref 500                (* -error-size *)
+and float_const_prop = ref true         (* -no-float-const-prop *)
+and transparent_modules = ref false     (* -trans-mod *)
+let unique_ids = ref true               (* -d(no-)unique-ds *)
+let locations = ref true                (* -d(no-)locations *)
+let dump_source = ref false             (* -dsource *)
+let dump_parsetree = ref false          (* -dparsetree *)
+and dump_typedtree = ref false          (* -dtypedtree *)
+and dump_rawlambda = ref false          (* -drawlambda *)
+and dump_lambda = ref false             (* -dlambda *)
+and dump_rawclambda = ref false         (* -drawclambda *)
+and dump_clambda = ref false            (* -dclambda *)
+and dump_rawflambda = ref false            (* -drawflambda *)
+and dump_flambda = ref false            (* -dflambda *)
+and dump_flambda_let = ref (None : int option) (* -dflambda-let=... *)
+and dump_flambda_verbose = ref false    (* -dflambda-verbose *)
+and dump_instr = ref false              (* -dinstr *)
+and keep_camlprimc_file = ref false     (* -dcamlprimc *)
+
+let keep_asm_file = ref false           (* -S *)
+let optimize_for_speed = ref true       (* -compact *)
+and opaque = ref false                  (* -opaque *)
+
+and dump_cmm = ref false                (* -dcmm *)
+let dump_selection = ref false          (* -dsel *)
+let dump_cse = ref false                (* -dcse *)
+let dump_live = ref false               (* -dlive *)
+let dump_spill = ref false              (* -dspill *)
+let dump_split = ref false              (* -dsplit *)
+let dump_interf = ref false             (* -dinterf *)
+let dump_prefer = ref false             (* -dprefer *)
+let dump_regalloc = ref false           (* -dalloc *)
+let dump_reload = ref false             (* -dreload *)
+let dump_scheduling = ref false         (* -dscheduling *)
+let dump_linear = ref false             (* -dlinear *)
+let dump_interval = ref false           (* -dinterval *)
+let keep_startup_file = ref false       (* -dstartup *)
+let dump_combine = ref false            (* -dcombine *)
+let profile_columns : Profile.column list ref = ref [] (* -dprofile/-dtimings *)
+
+let native_code = ref false             (* set to true under ocamlopt *)
+
+let force_slash = ref false             (* for ocamldep *)
+let clambda_checks = ref false          (* -clambda-checks *)
+let cmm_invariants =
+  ref Config.with_cmm_invariants        (* -dcmm-invariants *)
+
+let flambda_invariant_checks =
+  ref Config.with_flambda_invariants    (* -flambda-(no-)invariants *)
+
+let dont_write_files = ref false        (* set to true under ocamldoc *)
+
+let insn_sched_default = true
+let insn_sched = ref insn_sched_default (* -[no-]insn-sched *)
+
+let std_include_flag prefix =
+  if !no_std_include then ""
+  else (prefix ^ (Filename.quote Config.standard_library))
+;;
+
+let std_include_dir () =
+  if !no_std_include then [] else [Config.standard_library]
+;;
+
+let shared = ref false (* -shared *)
+let dlcode = ref true (* not -nodynlink *)
+
+let pic_code = ref (match Config.architecture with (* -fPIC *)
+                     | "amd64" -> true
+                     | _       -> false)
+
+let runtime_variant = ref "";;      (* -runtime-variant *)
+let with_runtime = ref true;;         (* -with-runtime *)
+
+let keep_docs = ref false              (* -keep-docs *)
+let keep_locs = ref true               (* -keep-locs *)
+let unsafe_string =
+  if Config.safe_string then ref false
+  else ref (not Config.default_safe_string)
+                                   (* -safe-string / -unsafe-string *)
+
+let classic_inlining = ref false       (* -Oclassic *)
+let inlining_report = ref false    (* -inlining-report *)
+
+let afl_instrument = ref Config.afl_instrument (* -afl-instrument *)
+let afl_inst_ratio = ref 100           (* -afl-inst-ratio *)
+
+let function_sections = ref false      (* -function-sections *)
+
+let simplify_rounds = ref None        (* -rounds *)
+let default_simplify_rounds = ref 1        (* -rounds *)
+let rounds () =
+  match !simplify_rounds with
+  | None -> !default_simplify_rounds
+  | Some r -> r
+
+let default_inline_threshold = if Config.flambda then 10. else 10. /. 8.
+let inline_toplevel_multiplier = 16
+let default_inline_toplevel_threshold =
+  int_of_float ((float inline_toplevel_multiplier) *. default_inline_threshold)
+let default_inline_call_cost = 5
+let default_inline_alloc_cost = 7
+let default_inline_prim_cost = 3
+let default_inline_branch_cost = 5
+let default_inline_indirect_cost = 4
+let default_inline_branch_factor = 0.1
+let default_inline_lifting_benefit = 1300
+let default_inline_max_unroll = 0
+let default_inline_max_depth = 1
+
+let inline_threshold = ref (Float_arg_helper.default default_inline_threshold)
+let inline_toplevel_threshold =
+  ref (Int_arg_helper.default default_inline_toplevel_threshold)
+let inline_call_cost = ref (Int_arg_helper.default default_inline_call_cost)
+let inline_alloc_cost = ref (Int_arg_helper.default default_inline_alloc_cost)
+let inline_prim_cost = ref (Int_arg_helper.default default_inline_prim_cost)
+let inline_branch_cost =
+  ref (Int_arg_helper.default default_inline_branch_cost)
+let inline_indirect_cost =
+  ref (Int_arg_helper.default default_inline_indirect_cost)
+let inline_branch_factor =
+  ref (Float_arg_helper.default default_inline_branch_factor)
+let inline_lifting_benefit =
+  ref (Int_arg_helper.default default_inline_lifting_benefit)
+let inline_max_unroll =
+  ref (Int_arg_helper.default default_inline_max_unroll)
+let inline_max_depth =
+  ref (Int_arg_helper.default default_inline_max_depth)
+
+
+let unbox_specialised_args = ref true   (* -no-unbox-specialised-args *)
+let unbox_free_vars_of_closures = ref true
+let unbox_closures = ref false          (* -unbox-closures *)
+let default_unbox_closures_factor = 10
+let unbox_closures_factor =
+  ref default_unbox_closures_factor      (* -unbox-closures-factor *)
+let remove_unused_arguments = ref false (* -remove-unused-arguments *)
+
+type inlining_arguments = {
+  inline_call_cost : int option;
+  inline_alloc_cost : int option;
+  inline_prim_cost : int option;
+  inline_branch_cost : int option;
+  inline_indirect_cost : int option;
+  inline_lifting_benefit : int option;
+  inline_branch_factor : float option;
+  inline_max_depth : int option;
+  inline_max_unroll : int option;
+  inline_threshold : float option;
+  inline_toplevel_threshold : int option;
+}
+
+let set_int_arg round (arg:Int_arg_helper.parsed ref) default value =
+  let value : int =
+    match value with
+    | None -> default
+    | Some value -> value
+  in
+  match round with
+  | None ->
+    arg := Int_arg_helper.set_base_default value
+             (Int_arg_helper.reset_base_overrides !arg)
+  | Some round ->
+    arg := Int_arg_helper.add_base_override round value !arg
+
+let set_float_arg round (arg:Float_arg_helper.parsed ref) default value =
+  let value =
+    match value with
+    | None -> default
+    | Some value -> value
+  in
+  match round with
+  | None ->
+    arg := Float_arg_helper.set_base_default value
+             (Float_arg_helper.reset_base_overrides !arg)
+  | Some round ->
+    arg := Float_arg_helper.add_base_override round value !arg
+
+let use_inlining_arguments_set ?round (arg:inlining_arguments) =
+  let set_int = set_int_arg round in
+  let set_float = set_float_arg round in
+  set_int inline_call_cost default_inline_call_cost arg.inline_call_cost;
+  set_int inline_alloc_cost default_inline_alloc_cost arg.inline_alloc_cost;
+  set_int inline_prim_cost default_inline_prim_cost arg.inline_prim_cost;
+  set_int inline_branch_cost
+    default_inline_branch_cost arg.inline_branch_cost;
+  set_int inline_indirect_cost
+    default_inline_indirect_cost arg.inline_indirect_cost;
+  set_int inline_lifting_benefit
+    default_inline_lifting_benefit arg.inline_lifting_benefit;
+  set_float inline_branch_factor
+    default_inline_branch_factor arg.inline_branch_factor;
+  set_int inline_max_depth
+    default_inline_max_depth arg.inline_max_depth;
+  set_int inline_max_unroll
+    default_inline_max_unroll arg.inline_max_unroll;
+  set_float inline_threshold
+    default_inline_threshold arg.inline_threshold;
+  set_int inline_toplevel_threshold
+    default_inline_toplevel_threshold arg.inline_toplevel_threshold
+
+(* o1 is the default *)
+let o1_arguments = {
+  inline_call_cost = None;
+  inline_alloc_cost = None;
+  inline_prim_cost = None;
+  inline_branch_cost = None;
+  inline_indirect_cost = None;
+  inline_lifting_benefit = None;
+  inline_branch_factor = None;
+  inline_max_depth = None;
+  inline_max_unroll = None;
+  inline_threshold = None;
+  inline_toplevel_threshold = None;
+}
+
+let classic_arguments = {
+  inline_call_cost = None;
+  inline_alloc_cost = None;
+  inline_prim_cost = None;
+  inline_branch_cost = None;
+  inline_indirect_cost = None;
+  inline_lifting_benefit = None;
+  inline_branch_factor = None;
+  inline_max_depth = None;
+  inline_max_unroll = None;
+  (* [inline_threshold] matches the current compiler's default.
+     Note that this particular fraction can be expressed exactly in
+     floating point. *)
+  inline_threshold = Some (10. /. 8.);
+  (* [inline_toplevel_threshold] is not used in classic mode. *)
+  inline_toplevel_threshold = Some 1;
+}
+
+let o2_arguments = {
+  inline_call_cost = Some (2 * default_inline_call_cost);
+  inline_alloc_cost = Some (2 * default_inline_alloc_cost);
+  inline_prim_cost = Some (2 * default_inline_prim_cost);
+  inline_branch_cost = Some (2 * default_inline_branch_cost);
+  inline_indirect_cost = Some (2 * default_inline_indirect_cost);
+  inline_lifting_benefit = None;
+  inline_branch_factor = None;
+  inline_max_depth = Some 2;
+  inline_max_unroll = None;
+  inline_threshold = Some 25.;
+  inline_toplevel_threshold = Some (25 * inline_toplevel_multiplier);
+}
+
+let o3_arguments = {
+  inline_call_cost = Some (3 * default_inline_call_cost);
+  inline_alloc_cost = Some (3 * default_inline_alloc_cost);
+  inline_prim_cost = Some (3 * default_inline_prim_cost);
+  inline_branch_cost = Some (3 * default_inline_branch_cost);
+  inline_indirect_cost = Some (3 * default_inline_indirect_cost);
+  inline_lifting_benefit = None;
+  inline_branch_factor = Some 0.;
+  inline_max_depth = Some 3;
+  inline_max_unroll = Some 1;
+  inline_threshold = Some 50.;
+  inline_toplevel_threshold = Some (50 * inline_toplevel_multiplier);
+}
+
+let all_passes = ref []
+let dumped_passes_list = ref []
+let dumped_pass s =
+  assert(List.mem s !all_passes);
+  List.mem s !dumped_passes_list
+
+let set_dumped_pass s enabled =
+  if (List.mem s !all_passes) then begin
+    let passes_without_s = List.filter ((<>) s) !dumped_passes_list in
+    let dumped_passes =
+      if enabled then
+        s :: passes_without_s
+      else
+        passes_without_s
+    in
+    dumped_passes_list := dumped_passes
+  end
+
+let dump_into_file = ref false (* -dump-into-file *)
+
+type 'a env_reader = {
+  parse : string -> 'a option;
+  print : 'a -> string;
+  usage : string;
+  env_var : string;
+}
+
+let color = ref None (* -color *)
+
+let color_reader = {
+  parse = (function
+    | "auto" -> Some Misc.Color.Auto
+    | "always" -> Some Misc.Color.Always
+    | "never" -> Some Misc.Color.Never
+    | _ -> None);
+  print = (function
+    | Misc.Color.Auto -> "auto"
+    | Misc.Color.Always -> "always"
+    | Misc.Color.Never -> "never");
+  usage = "expected \"auto\", \"always\" or \"never\"";
+  env_var = "OCAML_COLOR";
+}
+
+let error_style = ref None (* -error-style *)
+
+let error_style_reader = {
+  parse = (function
+    | "contextual" -> Some Misc.Error_style.Contextual
+    | "short" -> Some Misc.Error_style.Short
+    | _ -> None);
+  print = (function
+    | Misc.Error_style.Contextual -> "contextual"
+    | Misc.Error_style.Short -> "short");
+  usage = "expected \"contextual\" or \"short\"";
+  env_var = "OCAML_ERROR_STYLE";
+}
+
+let unboxed_types = ref false
+
+(* This is used by the -save-ir-after option. *)
+module Compiler_ir = struct
+  type t = Linear
+
+  let all = [
+    Linear;
+  ]
+
+  let extension t =
+    let ext =
+    match t with
+      | Linear -> "linear"
+    in
+    ".cmir-" ^ ext
+
+  (** [extract_extension_with_pass filename] returns the IR whose extension
+      is a prefix of the extension of [filename], and the suffix,
+      which can be used to distinguish different passes on the same IR.
+      For example, [extract_extension_with_pass "foo.cmir-linear123"]
+      returns [Some (Linear, "123")]. *)
+  let extract_extension_with_pass filename =
+    let ext = Filename.extension filename in
+    let ext_len = String.length ext in
+    if ext_len <= 0 then None
+    else begin
+      let is_prefix ir =
+        let s = extension ir in
+        let s_len = String.length s in
+        s_len <= ext_len && s = String.sub ext 0 s_len
+      in
+      let drop_prefix ir =
+        let s = extension ir in
+        let s_len = String.length s in
+        String.sub ext s_len (ext_len - s_len)
+      in
+      let ir = List.find_opt is_prefix all in
+      match ir with
+      | None -> None
+      | Some ir -> Some (ir, drop_prefix ir)
+    end
+end
+
+(* This is used by the -stop-after option. *)
+module Compiler_pass = struct
+  (* If you add a new pass, the following must be updated:
+     - the variable `passes` below
+     - the manpages in man/ocaml{c,opt}.m
+     - the manual manual/src/cmds/unified-options.etex
+  *)
+  type t = Parsing | Typing | Scheduling | Emit
+
+  let to_string = function
+    | Parsing -> "parsing"
+    | Typing -> "typing"
+    | Scheduling -> "scheduling"
+    | Emit -> "emit"
+
+  let of_string = function
+    | "parsing" -> Some Parsing
+    | "typing" -> Some Typing
+    | "scheduling" -> Some Scheduling
+    | "emit" -> Some Emit
+    | _ -> None
+
+  let rank = function
+    | Parsing -> 0
+    | Typing -> 1
+    | Scheduling -> 50
+    | Emit -> 60
+
+  let passes = [
+    Parsing;
+    Typing;
+    Scheduling;
+    Emit;
+  ]
+  let is_compilation_pass _ = true
+  let is_native_only = function
+    | Scheduling -> true
+    | Emit -> true
+    | _ -> false
+
+  let enabled is_native t = not (is_native_only t) || is_native
+  let can_save_ir_after = function
+    | Scheduling -> true
+    | _ -> false
+
+  let available_pass_names ~filter ~native =
+    passes
+    |> List.filter (enabled native)
+    |> List.filter filter
+    |> List.map to_string
+
+  let compare a b =
+    compare (rank a) (rank b)
+
+  let to_output_filename t ~prefix =
+    match t with
+    | Scheduling -> prefix ^ Compiler_ir.(extension Linear)
+    | _ -> Misc.fatal_error "Not supported"
+
+  let of_input_filename name =
+    match Compiler_ir.extract_extension_with_pass name with
+    | Some (Linear, _) -> Some Emit
+    | None -> None
+end
+
+let stop_after = ref None (* -stop-after *)
+
+let should_stop_after pass =
+  if Compiler_pass.(rank Typing <= rank pass) && !print_types then true
+  else
+    match !stop_after with
+    | None -> false
+    | Some stop -> Compiler_pass.rank stop <= Compiler_pass.rank pass
+
+let save_ir_after = ref []
+
+let should_save_ir_after pass =
+  List.mem pass !save_ir_after
+
+let set_save_ir_after pass enabled =
+  let other_passes = List.filter ((<>) pass) !save_ir_after in
+  let new_passes =
+    if enabled then
+      pass :: other_passes
+    else
+      other_passes
+  in
+  save_ir_after := new_passes
+
+module String = Misc.Stdlib.String
+
+let arg_spec = ref []
+let arg_names = ref String.Map.empty
+
+let reset_arguments () =
+  arg_spec := [];
+  arg_names := String.Map.empty
+
+let add_arguments loc args =
+  List.iter (function (arg_name, _, _) as arg ->
+    try
+      let loc2 = String.Map.find arg_name !arg_names in
+      Printf.eprintf
+        "Warning: compiler argument %s is already defined:\n" arg_name;
+      Printf.eprintf "   First definition: %s\n" loc2;
+      Printf.eprintf "   New definition: %s\n" loc;
+    with Not_found ->
+      arg_spec := !arg_spec @ [ arg ];
+      arg_names := String.Map.add arg_name loc !arg_names
+  ) args
+
+let create_usage_msg program =
+  Printf.sprintf "Usage: %s <options> <files>\n\
+    Try '%s --help' for more information." program program
+
+
+let print_arguments program =
+  Arg.usage !arg_spec (create_usage_msg program)
diff --git a/upstream/ocaml_413/utils/clflags.mli b/upstream/ocaml_413/utils/clflags.mli
new file mode 100644
index 0000000..06b478d
--- /dev/null
+++ b/upstream/ocaml_413/utils/clflags.mli
@@ -0,0 +1,270 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2005 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+
+
+(** Command line flags *)
+
+(** Optimization parameters represented as ints indexed by round number. *)
+module Int_arg_helper : sig
+  type parsed
+
+  val parse : string -> string -> parsed ref -> unit
+
+  type parse_result =
+    | Ok
+    | Parse_failed of exn
+  val parse_no_error : string -> parsed ref -> parse_result
+
+  val get : key:int -> parsed -> int
+end
+
+(** Optimization parameters represented as floats indexed by round number. *)
+module Float_arg_helper : sig
+  type parsed
+
+  val parse : string -> string -> parsed ref -> unit
+
+  type parse_result =
+    | Ok
+    | Parse_failed of exn
+  val parse_no_error : string -> parsed ref -> parse_result
+
+  val get : key:int -> parsed -> float
+end
+
+type inlining_arguments = {
+  inline_call_cost : int option;
+  inline_alloc_cost : int option;
+  inline_prim_cost : int option;
+  inline_branch_cost : int option;
+  inline_indirect_cost : int option;
+  inline_lifting_benefit : int option;
+  inline_branch_factor : float option;
+  inline_max_depth : int option;
+  inline_max_unroll : int option;
+  inline_threshold : float option;
+  inline_toplevel_threshold : int option;
+}
+
+val classic_arguments : inlining_arguments
+val o1_arguments : inlining_arguments
+val o2_arguments : inlining_arguments
+val o3_arguments : inlining_arguments
+
+(** Set all the inlining arguments for a round.
+    The default is set if no round is provided. *)
+val use_inlining_arguments_set : ?round:int -> inlining_arguments -> unit
+
+val objfiles : string list ref
+val ccobjs : string list ref
+val dllibs : string list ref
+val compile_only : bool ref
+val output_name : string option ref
+val include_dirs : string list ref
+val no_std_include : bool ref
+val print_types : bool ref
+val make_archive : bool ref
+val debug : bool ref
+val debug_full : bool ref
+val unsafe : bool ref
+val use_linscan : bool ref
+val link_everything : bool ref
+val custom_runtime : bool ref
+val no_check_prims : bool ref
+val bytecode_compatible_32 : bool ref
+val output_c_object : bool ref
+val output_complete_object : bool ref
+val output_complete_executable : bool ref
+val all_ccopts : string list ref
+val classic : bool ref
+val nopervasives : bool ref
+val match_context_rows : int ref
+val open_modules : string list ref
+val preprocessor : string option ref
+val all_ppx : string list ref
+val absname : bool ref
+val annotations : bool ref
+val binary_annotations : bool ref
+val use_threads : bool ref
+val noassert : bool ref
+val verbose : bool ref
+val noprompt : bool ref
+val nopromptcont : bool ref
+val init_file : string option ref
+val noinit : bool ref
+val noversion : bool ref
+val use_prims : string ref
+val use_runtime : string ref
+val plugin : bool ref
+val principal : bool ref
+val real_paths : bool ref
+val recursive_types : bool ref
+val strict_sequence : bool ref
+val strict_formats : bool ref
+val applicative_functors : bool ref
+val make_runtime : bool ref
+val c_compiler : string option ref
+val no_auto_link : bool ref
+val dllpaths : string list ref
+val make_package : bool ref
+val for_package : string option ref
+val error_size : int ref
+val float_const_prop : bool ref
+val transparent_modules : bool ref
+val unique_ids : bool ref
+val locations : bool ref
+val dump_source : bool ref
+val dump_parsetree : bool ref
+val dump_typedtree : bool ref
+val dump_rawlambda : bool ref
+val dump_lambda : bool ref
+val dump_rawclambda : bool ref
+val dump_clambda : bool ref
+val dump_rawflambda : bool ref
+val dump_flambda : bool ref
+val dump_flambda_let : int option ref
+val dump_instr : bool ref
+val keep_camlprimc_file : bool ref
+val keep_asm_file : bool ref
+val optimize_for_speed : bool ref
+val dump_cmm : bool ref
+val dump_selection : bool ref
+val dump_cse : bool ref
+val dump_live : bool ref
+val dump_spill : bool ref
+val dump_split : bool ref
+val dump_interf : bool ref
+val dump_prefer : bool ref
+val dump_regalloc : bool ref
+val dump_reload : bool ref
+val dump_scheduling : bool ref
+val dump_linear : bool ref
+val dump_interval : bool ref
+val keep_startup_file : bool ref
+val dump_combine : bool ref
+val native_code : bool ref
+val default_inline_threshold : float
+val inline_threshold : Float_arg_helper.parsed ref
+val inlining_report : bool ref
+val simplify_rounds : int option ref
+val default_simplify_rounds : int ref
+val rounds : unit -> int
+val default_inline_max_unroll : int
+val inline_max_unroll : Int_arg_helper.parsed ref
+val default_inline_toplevel_threshold : int
+val inline_toplevel_threshold : Int_arg_helper.parsed ref
+val default_inline_call_cost : int
+val default_inline_alloc_cost : int
+val default_inline_prim_cost : int
+val default_inline_branch_cost : int
+val default_inline_indirect_cost : int
+val default_inline_lifting_benefit : int
+val inline_call_cost : Int_arg_helper.parsed ref
+val inline_alloc_cost : Int_arg_helper.parsed ref
+val inline_prim_cost : Int_arg_helper.parsed ref
+val inline_branch_cost : Int_arg_helper.parsed ref
+val inline_indirect_cost : Int_arg_helper.parsed ref
+val inline_lifting_benefit : Int_arg_helper.parsed ref
+val default_inline_branch_factor : float
+val inline_branch_factor : Float_arg_helper.parsed ref
+val dont_write_files : bool ref
+val std_include_flag : string -> string
+val std_include_dir : unit -> string list
+val shared : bool ref
+val dlcode : bool ref
+val pic_code : bool ref
+val runtime_variant : string ref
+val with_runtime : bool ref
+val force_slash : bool ref
+val keep_docs : bool ref
+val keep_locs : bool ref
+val unsafe_string : bool ref
+val opaque : bool ref
+val profile_columns : Profile.column list ref
+val flambda_invariant_checks : bool ref
+val unbox_closures : bool ref
+val unbox_closures_factor : int ref
+val default_unbox_closures_factor : int
+val unbox_free_vars_of_closures : bool ref
+val unbox_specialised_args : bool ref
+val clambda_checks : bool ref
+val cmm_invariants : bool ref
+val default_inline_max_depth : int
+val inline_max_depth : Int_arg_helper.parsed ref
+val remove_unused_arguments : bool ref
+val dump_flambda_verbose : bool ref
+val classic_inlining : bool ref
+val afl_instrument : bool ref
+val afl_inst_ratio : int ref
+val function_sections : bool ref
+
+val all_passes : string list ref
+val dumped_pass : string -> bool
+val set_dumped_pass : string -> bool -> unit
+
+val dump_into_file : bool ref
+
+(* Support for flags that can also be set from an environment variable *)
+type 'a env_reader = {
+  parse : string -> 'a option;
+  print : 'a -> string;
+  usage : string;
+  env_var : string;
+}
+
+val color : Misc.Color.setting option ref
+val color_reader : Misc.Color.setting env_reader
+
+val error_style : Misc.Error_style.setting option ref
+val error_style_reader : Misc.Error_style.setting env_reader
+
+val unboxed_types : bool ref
+
+val insn_sched : bool ref
+val insn_sched_default : bool
+
+module Compiler_pass : sig
+  type t = Parsing | Typing | Scheduling | Emit
+  val of_string : string -> t option
+  val to_string : t -> string
+  val is_compilation_pass : t -> bool
+  val available_pass_names : filter:(t -> bool) -> native:bool -> string list
+  val can_save_ir_after : t -> bool
+  val compare : t -> t -> int
+  val to_output_filename: t -> prefix:string -> string
+  val of_input_filename: string -> t option
+end
+val stop_after : Compiler_pass.t option ref
+val should_stop_after : Compiler_pass.t -> bool
+val set_save_ir_after : Compiler_pass.t -> bool -> unit
+val should_save_ir_after : Compiler_pass.t -> bool
+
+val arg_spec : (string * Arg.spec * string) list ref
+
+(* [add_arguments __LOC__ args] will add the arguments from [args] at
+   the end of [arg_spec], checking that they have not already been
+   added by [add_arguments] before. A warning is printed showing the
+   locations of the function from which the argument was previously
+   added. *)
+val add_arguments : string -> (string * Arg.spec * string) list -> unit
+
+(* [create_usage_msg program] creates a usage message for [program] *)
+val create_usage_msg: string -> string
+(* [print_arguments usage] print the standard usage message *)
+val print_arguments : string -> unit
+
+(* [reset_arguments ()] clear all declared arguments *)
+val reset_arguments : unit -> unit
diff --git a/upstream/ocaml_413/utils/config.mli b/upstream/ocaml_413/utils/config.mli
new file mode 100644
index 0000000..33dc043
--- /dev/null
+++ b/upstream/ocaml_413/utils/config.mli
@@ -0,0 +1,266 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** System configuration
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+val version: string
+(** The current version number of the system *)
+
+val bindir: string
+(** The directory containing the binary programs *)
+
+val standard_library: string
+(** The directory containing the standard libraries *)
+
+val ccomp_type: string
+(** The "kind" of the C compiler, assembler and linker used: one of
+    "cc" (for Unix-style C compilers)
+    "msvc" (for Microsoft Visual C++ and MASM) *)
+
+val c_compiler: string
+(** The compiler to use for compiling C files *)
+
+val c_output_obj: string
+(** Name of the option of the C compiler for specifying the output
+    file *)
+
+val c_has_debug_prefix_map : bool
+(** Whether the C compiler supports -fdebug-prefix-map *)
+
+val as_has_debug_prefix_map : bool
+(** Whether the assembler supports --debug-prefix-map *)
+
+val ocamlc_cflags : string
+(** The flags ocamlc should pass to the C compiler *)
+
+val ocamlc_cppflags : string
+(** The flags ocamlc should pass to the C preprocessor *)
+
+val ocamlopt_cflags : string
+  [@@ocaml.deprecated "Use ocamlc_cflags instead."]
+(** @deprecated {!ocamlc_cflags} should be used instead.
+    The flags ocamlopt should pass to the C compiler *)
+
+val ocamlopt_cppflags : string
+  [@@ocaml.deprecated "Use ocamlc_cppflags instead."]
+(** @deprecated {!ocamlc_cppflags} should be used instead.
+    The flags ocamlopt should pass to the C preprocessor *)
+
+val bytecomp_c_libraries: string
+(** The C libraries to link with custom runtimes *)
+
+val native_c_libraries: string
+(** The C libraries to link with native-code programs *)
+
+val native_pack_linker: string
+(** The linker to use for packaging (ocamlopt -pack) and for partial
+    links (ocamlopt -output-obj). *)
+
+val mkdll: string
+(** The linker command line to build dynamic libraries. *)
+
+val mkexe: string
+(** The linker command line to build executables. *)
+
+val mkmaindll: string
+(** The linker command line to build main programs as dlls. *)
+
+val ranlib: string
+(** Command to randomize a library, or "" if not needed *)
+
+val default_rpath: string
+(** Option to add a directory to be searched for libraries at runtime
+    (used by ocamlmklib) *)
+
+val mksharedlibrpath: string
+(** Option to add a directory to be searched for shared libraries at runtime
+    (used by ocamlmklib) *)
+
+val ar: string
+(** Name of the ar command, or "" if not needed  (MSVC) *)
+
+val interface_suffix: string ref
+(** Suffix for interface file names *)
+
+val exec_magic_number: string
+(** Magic number for bytecode executable files *)
+
+val cmi_magic_number: string
+(** Magic number for compiled interface files *)
+
+val cmo_magic_number: string
+(** Magic number for object bytecode files *)
+
+val cma_magic_number: string
+(** Magic number for archive files *)
+
+val cmx_magic_number: string
+(** Magic number for compilation unit descriptions *)
+
+val cmxa_magic_number: string
+(** Magic number for libraries of compilation unit descriptions *)
+
+val ast_intf_magic_number: string
+(** Magic number for file holding an interface syntax tree *)
+
+val ast_impl_magic_number: string
+(** Magic number for file holding an implementation syntax tree *)
+
+val cmxs_magic_number: string
+(** Magic number for dynamically-loadable plugins *)
+
+val cmt_magic_number: string
+(** Magic number for compiled interface files *)
+
+val linear_magic_number: string
+(** Magic number for Linear internal representation files *)
+
+val max_tag: int
+(** Biggest tag that can be stored in the header of a regular block. *)
+
+val lazy_tag : int
+(** Normally the same as Obj.lazy_tag.  Separate definition because
+    of technical reasons for bootstrapping. *)
+
+val max_young_wosize: int
+(** Maximal size of arrays that are directly allocated in the
+    minor heap *)
+
+val stack_threshold: int
+(** Size in words of safe area at bottom of VM stack,
+    see runtime/caml/config.h *)
+
+val stack_safety_margin: int
+(** Size in words of the safety margin between the bottom of
+    the stack and the stack pointer. This margin can be used by
+    intermediate computations of some instructions, or the event
+    handler. *)
+
+val architecture: string
+(** Name of processor type for the native-code compiler *)
+
+val model: string
+(** Name of processor submodel for the native-code compiler *)
+
+val system: string
+(** Name of operating system for the native-code compiler *)
+
+val asm: string
+(** The assembler (and flags) to use for assembling
+    ocamlopt-generated code. *)
+
+val asm_cfi_supported: bool
+(** Whether assembler understands CFI directives *)
+
+val with_frame_pointers : bool
+(** Whether assembler should maintain frame pointers *)
+
+val ext_obj: string
+(** Extension for object files, e.g. [.o] under Unix. *)
+
+val ext_asm: string
+(** Extension for assembler files, e.g. [.s] under Unix. *)
+
+val ext_lib: string
+(** Extension for library files, e.g. [.a] under Unix. *)
+
+val ext_dll: string
+(** Extension for dynamically-loaded libraries, e.g. [.so] under Unix.*)
+
+val ext_exe: string
+(** Extension for executable programs, e.g. [.exe] under Windows.
+
+    @since 4.12.0 *)
+
+val default_executable_name: string
+(** Name of executable produced by linking if none is given with -o,
+    e.g. [a.out] under Unix. *)
+
+val systhread_supported : bool
+(** Whether the system thread library is implemented *)
+
+val flexdll_dirs : string list
+(** Directories needed for the FlexDLL objects *)
+
+val host : string
+(** Whether the compiler is a cross-compiler *)
+
+val target : string
+(** Whether the compiler is a cross-compiler *)
+
+val flambda : bool
+(** Whether the compiler was configured for flambda *)
+
+val with_flambda_invariants : bool
+(** Whether the invariants checks for flambda are enabled *)
+
+val with_cmm_invariants : bool
+(** Whether the invariants checks for Cmm are enabled *)
+
+val profinfo : bool
+(** Whether the compiler was configured for profiling *)
+
+val profinfo_width : int
+(** How many bits are to be used in values' headers for profiling
+    information *)
+
+val safe_string: bool
+(** Whether the compiler was configured with -force-safe-string;
+    in that case, the -unsafe-string compile-time option is unavailable
+
+    @since 4.05.0 *)
+
+val default_safe_string: bool
+(** Whether the compiler was configured to use the -safe-string
+    or -unsafe-string compile-time option by default.
+
+    @since 4.06.0 *)
+
+val flat_float_array : bool
+(** Whether the compiler and runtime automagically flatten float
+    arrays *)
+
+val function_sections : bool
+(** Whether the compiler was configured to generate
+    each function in a separate section *)
+
+val windows_unicode: bool
+(** Whether Windows Unicode runtime is enabled *)
+
+val supports_shared_libraries: bool
+(** Whether shared libraries are supported
+
+    @since 4.08.0 *)
+
+val afl_instrument : bool
+(** Whether afl-fuzz instrumentation is generated by default *)
+
+
+(** Access to configuration values *)
+val print_config : out_channel -> unit
+
+val config_var : string -> string option
+(** the configuration value of a variable, if it exists *)
+
+(**/**)
+
+val merlin : bool
+
+(**/**)
diff --git a/upstream/ocaml_413/utils/config.mlp b/upstream/ocaml_413/utils/config.mlp
new file mode 100644
index 0000000..bbb3c56
--- /dev/null
+++ b/upstream/ocaml_413/utils/config.mlp
@@ -0,0 +1,246 @@
+#2 "utils/config.mlp"
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* The main OCaml version string has moved to ../VERSION *)
+let version = Sys.ocaml_version
+
+let bindir = "%%BINDIR%%"
+
+let standard_library_default = "%%LIBDIR%%"
+
+let standard_library =
+  try
+    Sys.getenv "OCAMLLIB"
+  with Not_found ->
+  try
+    Sys.getenv "CAMLLIB"
+  with Not_found ->
+    standard_library_default
+
+let ccomp_type = "%%CCOMPTYPE%%"
+let c_compiler = "%%CC%%"
+let c_output_obj = "%%OUTPUTOBJ%%"
+let c_has_debug_prefix_map = %%CC_HAS_DEBUG_PREFIX_MAP%%
+let as_has_debug_prefix_map = %%AS_HAS_DEBUG_PREFIX_MAP%%
+let ocamlc_cflags = "%%OCAMLC_CFLAGS%%"
+let ocamlc_cppflags = "%%OCAMLC_CPPFLAGS%%"
+(* #7678: ocamlopt uses these only to compile .c files, and the behaviour for
+          the two drivers should be identical. *)
+let ocamlopt_cflags = "%%OCAMLC_CFLAGS%%"
+let ocamlopt_cppflags = "%%OCAMLOPT_CPPFLAGS%%"
+let bytecomp_c_libraries = "%%BYTECCLIBS%%"
+(* bytecomp_c_compiler and native_c_compiler have been supported for a
+   long time and are retained for backwards compatibility.
+   For programs that don't need compatibility with older OCaml releases
+   the recommended approach is to use the constituent variables
+   c_compiler, ocamlc_cflags, ocamlc_cppflags etc., directly.
+*)
+let bytecomp_c_compiler =
+  c_compiler ^ " " ^ ocamlc_cflags ^ " " ^ ocamlc_cppflags
+let native_c_compiler =
+  c_compiler ^ " " ^ ocamlopt_cflags ^ " " ^ ocamlopt_cppflags
+let native_c_libraries = "%%NATIVECCLIBS%%"
+let native_pack_linker = "%%PACKLD%%"
+let ranlib = "%%RANLIBCMD%%"
+let default_rpath = "%%RPATH%%"
+let mksharedlibrpath = "%%MKSHAREDLIBRPATH%%"
+let ar = "%%ARCMD%%"
+let supports_shared_libraries = %%SUPPORTS_SHARED_LIBRARIES%%
+let mkdll, mkexe, mkmaindll =
+  (* @@DRA Cygwin - but only if shared libraries are enabled, which we
+     should be able to detect? *)
+  if Sys.win32 || Sys.cygwin && supports_shared_libraries then
+    try
+      let flexlink =
+        let flexlink = Sys.getenv "OCAML_FLEXLINK" in
+        let f i =
+          let c = flexlink.[i] in
+          if c = '/' && Sys.win32 then '\\' else c in
+        (String.init (String.length flexlink) f) ^ " %%FLEXLINK_FLAGS%%" in
+      flexlink ^ "%%FLEXLINK_DLL_LDFLAGS%%",
+      flexlink ^ " -exe%%FLEXLINK_LDFLAGS%%",
+      flexlink ^ " -maindll%%FLEXLINK_DLL_LDFLAGS%%"
+    with Not_found ->
+      "%%MKDLL%%", "%%MKEXE%%", "%%MKMAINDLL%%"
+  else
+    "%%MKDLL%%", "%%MKEXE%%", "%%MKMAINDLL%%"
+
+let flambda = %%FLAMBDA%%
+let with_flambda_invariants = %%WITH_FLAMBDA_INVARIANTS%%
+let with_cmm_invariants = %%WITH_CMM_INVARIANTS%%
+let safe_string = %%FORCE_SAFE_STRING%%
+let default_safe_string = %%DEFAULT_SAFE_STRING%%
+let windows_unicode = %%WINDOWS_UNICODE%% != 0
+
+let flat_float_array = %%FLAT_FLOAT_ARRAY%%
+
+let function_sections = %%FUNCTION_SECTIONS%%
+let afl_instrument = %%AFL_INSTRUMENT%%
+
+let exec_magic_number = "Caml1999X030"
+    (* exec_magic_number is duplicated in runtime/caml/exec.h *)
+and cmi_magic_number = "Caml1999I030"
+and cmo_magic_number = "Caml1999O030"
+and cma_magic_number = "Caml1999A030"
+and cmx_magic_number =
+  if flambda then
+    "Caml1999y030"
+  else
+    "Caml1999Y030"
+and cmxa_magic_number =
+  if flambda then
+    "Caml1999z030"
+  else
+    "Caml1999Z030"
+and ast_impl_magic_number = "Caml1999M030"
+and ast_intf_magic_number = "Caml1999N030"
+and cmxs_magic_number = "Caml1999D030"
+and cmt_magic_number = "Caml1999T030"
+and linear_magic_number = "Caml1999L030"
+
+let interface_suffix = ref ".mli"
+
+let max_tag = 245
+(* This is normally the same as in obj.ml, but we have to define it
+   separately because it can differ when we're in the middle of a
+   bootstrapping phase. *)
+let lazy_tag = 246
+
+let max_young_wosize = 256
+let stack_threshold = 256 (* see runtime/caml/config.h *)
+let stack_safety_margin = 60
+
+let architecture = "%%ARCH%%"
+let model = "%%MODEL%%"
+let system = "%%SYSTEM%%"
+
+let asm = "%%ASM%%"
+let asm_cfi_supported = %%ASM_CFI_SUPPORTED%%
+let with_frame_pointers = %%WITH_FRAME_POINTERS%%
+let profinfo = %%WITH_PROFINFO%%
+let profinfo_width = %%PROFINFO_WIDTH%%
+
+let ext_exe = "%%EXE%%"
+let ext_obj = "%%EXT_OBJ%%"
+let ext_asm = "%%EXT_ASM%%"
+let ext_lib = "%%EXT_LIB%%"
+let ext_dll = "%%EXT_DLL%%"
+
+let host = "%%HOST%%"
+let target = "%%TARGET%%"
+
+let default_executable_name =
+  match Sys.os_type with
+    "Unix" -> "a.out"
+  | "Win32" | "Cygwin" -> "camlprog.exe"
+  | _ -> "camlprog"
+
+let systhread_supported = %%SYSTHREAD_SUPPORT%%;;
+
+let flexdll_dirs = [%%FLEXDLL_DIR%%];;
+
+type configuration_value =
+  | String of string
+  | Int of int
+  | Bool of bool
+
+let configuration_variables =
+  let p x v = (x, String v) in
+  let p_int x v = (x, Int v) in
+  let p_bool x v = (x, Bool v) in
+[
+  p "version" version;
+  p "standard_library_default" standard_library_default;
+  p "standard_library" standard_library;
+  p "ccomp_type" ccomp_type;
+  p "c_compiler" c_compiler;
+  p "ocamlc_cflags" ocamlc_cflags;
+  p "ocamlc_cppflags" ocamlc_cppflags;
+  p "ocamlopt_cflags" ocamlopt_cflags;
+  p "ocamlopt_cppflags" ocamlopt_cppflags;
+  p "bytecomp_c_compiler" bytecomp_c_compiler;
+  p "native_c_compiler" native_c_compiler;
+  p "bytecomp_c_libraries" bytecomp_c_libraries;
+  p "native_c_libraries" native_c_libraries;
+  p "native_pack_linker" native_pack_linker;
+  p "ranlib" ranlib;
+  p "architecture" architecture;
+  p "model" model;
+  p_int "int_size" Sys.int_size;
+  p_int "word_size" Sys.word_size;
+  p "system" system;
+  p "asm" asm;
+  p_bool "asm_cfi_supported" asm_cfi_supported;
+  p_bool "with_frame_pointers" with_frame_pointers;
+  p "ext_exe" ext_exe;
+  p "ext_obj" ext_obj;
+  p "ext_asm" ext_asm;
+  p "ext_lib" ext_lib;
+  p "ext_dll" ext_dll;
+  p "os_type" Sys.os_type;
+  p "default_executable_name" default_executable_name;
+  p_bool "systhread_supported" systhread_supported;
+  p "host" host;
+  p "target" target;
+  p_bool "flambda" flambda;
+  p_bool "safe_string" safe_string;
+  p_bool "default_safe_string" default_safe_string;
+  p_bool "flat_float_array" flat_float_array;
+  p_bool "function_sections" function_sections;
+  p_bool "afl_instrument" afl_instrument;
+  p_bool "windows_unicode" windows_unicode;
+  p_bool "supports_shared_libraries" supports_shared_libraries;
+
+  p "exec_magic_number" exec_magic_number;
+  p "cmi_magic_number" cmi_magic_number;
+  p "cmo_magic_number" cmo_magic_number;
+  p "cma_magic_number" cma_magic_number;
+  p "cmx_magic_number" cmx_magic_number;
+  p "cmxa_magic_number" cmxa_magic_number;
+  p "ast_impl_magic_number" ast_impl_magic_number;
+  p "ast_intf_magic_number" ast_intf_magic_number;
+  p "cmxs_magic_number" cmxs_magic_number;
+  p "cmt_magic_number" cmt_magic_number;
+  p "linear_magic_number" linear_magic_number;
+]
+
+let print_config_value oc = function
+  | String s ->
+      Printf.fprintf oc "%s" s
+  | Int n ->
+      Printf.fprintf oc "%d" n
+  | Bool p ->
+      Printf.fprintf oc "%B" p
+
+let print_config oc =
+  let print (x, v) =
+    Printf.fprintf oc "%s: %a\n" x print_config_value v in
+  List.iter print configuration_variables;
+  flush oc;
+;;
+
+let config_var x =
+  match List.assoc_opt x configuration_variables with
+  | None -> None
+  | Some v ->
+      let s = match v with
+        | String s -> s
+        | Int n -> Int.to_string n
+        | Bool b -> string_of_bool b
+      in
+      Some s
+
+let merlin = false
diff --git a/upstream/ocaml_413/utils/consistbl.ml b/upstream/ocaml_413/utils/consistbl.ml
new file mode 100644
index 0000000..b329911
--- /dev/null
+++ b/upstream/ocaml_413/utils/consistbl.ml
@@ -0,0 +1,97 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Consistency tables: for checking consistency of module CRCs *)
+
+open Misc
+
+module Make (Module_name : sig
+  type t
+  module Set : Set.S with type elt = t
+  module Map : Map.S with type key = t
+  module Tbl : Hashtbl.S with type key = t
+  val compare : t -> t -> int
+end) = struct
+  type t = (Digest.t * filepath) Module_name.Tbl.t
+
+  let create () = Module_name.Tbl.create 13
+
+  let clear = Module_name.Tbl.clear
+
+  exception Inconsistency of {
+    unit_name : Module_name.t;
+    inconsistent_source : string;
+    original_source : string;
+  }
+
+  exception Not_available of Module_name.t
+
+  let check_ tbl name crc source =
+    let (old_crc, old_source) = Module_name.Tbl.find tbl name in
+    if crc <> old_crc then raise(Inconsistency {
+        unit_name = name;
+        inconsistent_source = source;
+        original_source = old_source;
+      })
+
+  let check tbl name crc source =
+    try check_ tbl name crc source
+    with Not_found ->
+      Module_name.Tbl.add tbl name (crc, source)
+
+  let check_noadd tbl name crc source =
+    try check_ tbl name crc source
+    with Not_found ->
+      raise (Not_available name)
+
+  let set tbl name crc source = Module_name.Tbl.add tbl name (crc, source)
+
+  let source tbl name = snd (Module_name.Tbl.find tbl name)
+
+  let extract l tbl =
+    let l = List.sort_uniq Module_name.compare l in
+    List.fold_left
+      (fun assc name ->
+         try
+           let (crc, _) = Module_name.Tbl.find tbl name in
+             (name, Some crc) :: assc
+         with Not_found ->
+           (name, None) :: assc)
+      [] l
+
+  let extract_map mod_names tbl =
+    Module_name.Set.fold
+      (fun name result ->
+         try
+           let (crc, _) = Module_name.Tbl.find tbl name in
+           Module_name.Map.add name (Some crc) result
+         with Not_found ->
+           Module_name.Map.add name None result)
+      mod_names
+      Module_name.Map.empty
+
+  let filter p tbl =
+    let to_remove = ref [] in
+    Module_name.Tbl.iter
+      (fun name _ ->
+        if not (p name) then to_remove := name :: !to_remove)
+      tbl;
+    List.iter
+      (fun name ->
+         while Module_name.Tbl.mem tbl name do
+           Module_name.Tbl.remove tbl name
+         done)
+      !to_remove
+end
diff --git a/upstream/ocaml_413/utils/consistbl.mli b/upstream/ocaml_413/utils/consistbl.mli
new file mode 100644
index 0000000..5067add
--- /dev/null
+++ b/upstream/ocaml_413/utils/consistbl.mli
@@ -0,0 +1,82 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Consistency tables: for checking consistency of module CRCs
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+open Misc
+
+module Make (Module_name : sig
+  type t
+  module Set : Set.S with type elt = t
+  module Map : Map.S with type key = t
+  module Tbl : Hashtbl.S with type key = t
+  val compare : t -> t -> int
+end) : sig
+  type t
+
+  val create: unit -> t
+
+  val clear: t -> unit
+
+  val check: t -> Module_name.t -> Digest.t -> filepath -> unit
+        (* [check tbl name crc source]
+             checks consistency of ([name], [crc]) with infos previously
+             stored in [tbl].  If no CRC was previously associated with
+             [name], record ([name], [crc]) in [tbl].
+             [source] is the name of the file from which the information
+             comes from.  This is used for error reporting. *)
+
+  val check_noadd: t -> Module_name.t -> Digest.t -> filepath -> unit
+        (* Same as [check], but raise [Not_available] if no CRC was previously
+             associated with [name]. *)
+
+  val set: t -> Module_name.t -> Digest.t -> filepath -> unit
+        (* [set tbl name crc source] forcefully associates [name] with
+           [crc] in [tbl], even if [name] already had a different CRC
+           associated with [name] in [tbl]. *)
+
+  val source: t -> Module_name.t -> filepath
+        (* [source tbl name] returns the file name associated with [name]
+           if the latter has an associated CRC in [tbl].
+           Raise [Not_found] otherwise. *)
+
+  val extract: Module_name.t list -> t -> (Module_name.t * Digest.t option) list
+        (* [extract tbl names] returns an associative list mapping each string
+           in [names] to the CRC associated with it in [tbl]. If no CRC is
+           associated with a name then it is mapped to [None]. *)
+
+  val extract_map : Module_name.Set.t -> t -> Digest.t option Module_name.Map.t
+        (* Like [extract] but with a more sophisticated type. *)
+
+  val filter: (Module_name.t -> bool) -> t -> unit
+        (* [filter pred tbl] removes from [tbl] table all (name, CRC) pairs
+           such that [pred name] is [false]. *)
+
+  exception Inconsistency of {
+    unit_name : Module_name.t;
+    inconsistent_source : string;
+    original_source : string;
+  }
+  (* Raised by [check] when a CRC mismatch is detected. *)
+
+  exception Not_available of Module_name.t
+        (* Raised by [check_noadd] when a name doesn't have an associated
+           CRC. *)
+end
diff --git a/upstream/ocaml_413/utils/diffing.ml b/upstream/ocaml_413/utils/diffing.ml
new file mode 100644
index 0000000..b12f101
--- /dev/null
+++ b/upstream/ocaml_413/utils/diffing.ml
@@ -0,0 +1,370 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Gabriel Radanne, projet Cambium, Inria Paris               *)
+(*                                                                        *)
+(*   Copyright 2020 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@warning "-16"]
+
+(* This module implements a modified version of Wagner-Fischer
+   See <https://en.wikipedia.org/wiki/Wagner%E2%80%93Fischer_algorithm>
+   for preliminary reading.
+
+   The main extensions is that:
+   - State is computed based on the optimal patch so far.
+   - The lists can be extended at each state computation.
+
+   We add the constraint that extensions can only be in one side
+   (either the left or right list). This is enforced by the external API.
+
+*)
+
+let (let*) = Option.bind
+let (let+) x f = Option.map f x
+let (let*!) x f = Option.iter f x
+
+type ('left, 'right, 'eq, 'diff) change =
+  | Delete of 'left
+  | Insert of 'right
+  | Keep of 'left * 'right * 'eq
+  | Change of 'left * 'right * 'diff
+
+type ('l, 'r, 'eq, 'diff) patch = ('l, 'r, 'eq, 'diff) change list
+
+let map f g = function
+  | Delete x -> Delete (f x)
+  | Insert x -> Insert (g x)
+  | Keep (x,y,k) -> Keep (f x, g y, k)
+  | Change (x,y,k) -> Change (f x, g y, k)
+
+type ('st,'left,'right) full_state = {
+  line: 'left array;
+  column: 'right array;
+  state: 'st
+}
+
+(* The matrix supporting our dynamic programming implementation.
+
+   Each cell contains:
+   - The diff and its weight
+   - The state computed so far
+   - The lists, potentially extended locally.
+
+   The matrix can also be reshaped.
+*)
+module Matrix : sig
+
+  type shape = { l : int ; c : int }
+
+  type ('state,'left,'right,'eq,'diff) t
+
+  val make : shape -> ('st,'l,'r,'e,'d) t
+  val reshape : shape -> ('st,'l,'r,'e,'d) t -> ('st,'l,'r,'e,'d) t
+
+  (** accessor functions *)
+  val diff : (_,'l,'r,'e,'d) t -> int -> int -> ('l,'r,'e,'d) change option
+  val state :
+    ('st,'l,'r,'e,'d) t -> int -> int -> ('st, 'l, 'r) full_state option
+  val weight : _ t -> int -> int -> int
+
+  val line : (_,'l,_,_,_) t -> int -> int -> 'l option
+  val column : (_,_,'r,_,_) t -> int -> int -> 'r option
+
+  val set :
+    ('st,'l,'r,'e,'d) t -> int -> int ->
+    diff:('l,'r,'e,'d) change option ->
+    weight:int ->
+    state:('st, 'l, 'r) full_state ->
+    unit
+
+  (** the shape when starting filling the matrix *)
+  val shape : _ t -> shape
+
+  (** [shape m i j] is the shape as seen from the state at position (i,j)
+      after some possible extensions
+  *)
+  val shape_at : _ t -> int -> int -> shape option
+
+  (** the maximal shape on the whole matrix *)
+  val real_shape : _ t -> shape
+
+  (** debugging printer *)
+  val[@warning "-32"] pp : Format.formatter -> _ t -> unit
+
+end = struct
+
+  type shape = { l : int ; c : int }
+
+  type ('state,'left,'right,'eq,'diff) t =
+    { states: ('state,'left,'right) full_state option array array;
+      weight: int array array;
+      diff: ('left,'right,'eq,'diff) change option array array;
+      columns: int;
+      lines: int;
+    }
+  let opt_get a n =
+    if n < Array.length a then Some (Array.unsafe_get a n) else None
+  let line m i j = let* st = m.states.(i).(j) in opt_get st.line i
+  let column m i j = let* st = m.states.(i).(j) in opt_get st.column j
+  let diff m i j = m.diff.(i).(j)
+  let weight m i j = m.weight.(i).(j)
+  let state m i j = m.states.(i).(j)
+  let shape m = { l = m.lines ; c = m.columns }
+
+  let set m i j ~diff ~weight ~state =
+    m.weight.(i).(j) <- weight;
+    m.states.(i).(j) <- Some state;
+    m.diff.(i).(j) <- diff;
+    ()
+
+  let shape_at tbl i j =
+    let+ st = tbl.states.(i).(j) in
+    let l = Array.length st.line in
+    let c = Array.length st.column in
+    { l ; c }
+
+  let real_shape tbl =
+    let lines = ref tbl.lines in
+    let columns = ref tbl.columns in
+    for i = 0 to tbl.lines do
+      for j = 0 to tbl.columns do
+        let*! {l; c} = shape_at tbl i j in
+        if l > !lines then lines := l;
+        if c > !columns then columns := c
+      done;
+    done;
+    { l = !lines ; c = !columns }
+
+  let make { l = lines ; c = columns } =
+    { states = Array.make_matrix (lines + 1) (columns + 1) None;
+      weight = Array.make_matrix (lines + 1) (columns + 1) max_int;
+      diff = Array.make_matrix (lines + 1) (columns + 1) None;
+      lines;
+      columns;
+    }
+
+  let reshape { l = lines ; c = columns } m =
+    let copy default a =
+      Array.init (1+lines) (fun i -> Array.init (1+columns) (fun j ->
+          if i <= m.lines && j <= m.columns then
+            a.(i).(j)
+          else default) ) in
+    { states = copy None m.states;
+      weight = copy max_int m.weight;
+      diff = copy None m.diff;
+      lines;
+      columns
+    }
+
+  let pp ppf m =
+    let { l ; c } = shape m in
+    Format.eprintf "Shape : %i, %i@." l c;
+    for i = 0 to l do
+      for j = 0 to c do
+        let d = diff m i j in
+        match d with
+        | None ->
+            Format.fprintf ppf "    "
+        | Some diff ->
+            let sdiff = match diff with
+              | Insert _ -> "\u{2190}"
+              | Delete _ -> "\u{2191}"
+              | Keep _ -> "\u{2196}"
+              | Change _ -> "\u{21F1}"
+            in
+            let w = weight m i j in
+            Format.fprintf ppf "%s%i " sdiff w
+      done;
+      Format.pp_print_newline ppf ()
+    done
+
+end
+
+(* Computation of new cells *)
+
+let select_best_proposition l =
+  let compare_proposition curr prop =
+    match curr, prop with
+    | None, o | o, None -> o
+    | Some (curr_m, curr_res), Some (m, res) ->
+        Some (if curr_m <= m then curr_m, curr_res else m,res)
+  in
+  List.fold_left compare_proposition None l
+
+(* Boundary cell update *)
+let compute_column0 ~weight ~update tbl i =
+  let*! st = Matrix.state tbl (i-1) 0 in
+  let*! line = Matrix.line tbl (i-1) 0 in
+  let diff = Delete line in
+  Matrix.set tbl i 0
+    ~weight:(weight diff + Matrix.weight tbl (i-1) 0)
+    ~state:(update diff st)
+    ~diff:(Some diff)
+
+let compute_line0 ~weight ~update tbl j =
+  let*! st = Matrix.state tbl 0 (j-1) in
+  let*! column = Matrix.column tbl 0 (j-1) in
+  let diff = Insert column in
+  Matrix.set tbl 0 j
+    ~weight:(weight diff + Matrix.weight tbl 0 (j-1))
+    ~state:(update diff st)
+    ~diff:(Some diff)
+
+let compute_inner_cell ~weight ~test ~update tbl i j =
+  let compute_proposition i j diff =
+    let* diff = diff in
+    let+ localstate = Matrix.state tbl i j in
+    weight diff + Matrix.weight tbl i j, (diff, localstate)
+  in
+  let del =
+    let diff = let+ x = Matrix.line tbl (i-1) j in Delete x in
+    compute_proposition (i-1) j diff
+  in
+  let insert =
+    let diff = let+ x = Matrix.column tbl i (j-1) in Insert x in
+    compute_proposition i (j-1) diff
+  in
+  let diag =
+    let diff =
+      let* state = Matrix.state tbl (i-1) (j-1) in
+      let* line = Matrix.line tbl (i-1) (j-1) in
+      let* column = Matrix.column tbl (i-1) (j-1) in
+      match test state.state line column with
+      | Ok ok -> Some (Keep (line, column, ok))
+      | Error err -> Some (Change (line, column, err))
+    in
+    compute_proposition (i-1) (j-1) diff
+  in
+  let*! newweight, (diff, localstate) =
+    select_best_proposition [diag;del;insert]
+  in
+  let state = update diff localstate in
+  Matrix.set tbl i j ~weight:newweight ~state ~diff:(Some diff)
+
+let compute_cell ~weight ~test ~update m i j =
+  match i, j with
+  | _ when Matrix.diff m i j <> None -> ()
+  | 0,0 -> ()
+  | 0,j -> compute_line0 ~update ~weight m j
+  | i,0 -> compute_column0 ~update ~weight m i;
+  | _ -> compute_inner_cell ~weight ~test ~update m i j
+
+(* Filling the matrix
+
+   We fill the whole matrix, as in vanilla Wagner-Fischer.
+   At this point, the lists in some states might have been extended.
+   If any list have been extended, we need to reshape the matrix
+   and repeat the process
+*)
+let compute_matrix ~weight ~test ~update state0 =
+  let m0 = Matrix.make { l = 0 ; c = 0 } in
+  Matrix.set m0 0 0 ~weight:0 ~state:state0 ~diff:None;
+  let rec loop m =
+    let shape = Matrix.shape m in
+    let new_shape = Matrix.real_shape m in
+    if new_shape.l > shape.l || new_shape.c > shape.c then
+      let m = Matrix.reshape new_shape m in
+      for i = 0 to new_shape.l do
+        for j = 0 to new_shape.c do
+          compute_cell ~update ~test ~weight m i j
+        done
+      done;
+      loop m
+    else
+      m
+  in
+  loop m0
+
+(* Building the patch.
+
+   We first select the best final cell. A potential final cell
+   is a cell where the local shape (i.e., the size of the strings) correspond
+   to its position in the matrix. In other words: it's at the end of both its
+   strings. We select the final cell with the smallest weight.
+
+   We then build the patch by walking backward from the final cell to the
+   origin.
+*)
+
+let select_final_state m0 =
+  let maybe_final i j =
+    match Matrix.shape_at m0 i j with
+    | Some shape_here -> shape_here.l = i && shape_here.c = j
+    | None -> false
+  in
+  let best_state (i0,j0,weigth0) (i,j) =
+    let weight = Matrix.weight m0 i j in
+    if weight < weigth0 then (i,j,weight) else (i0,j0,weigth0)
+  in
+  let res = ref (0,0,max_int) in
+  let shape = Matrix.shape m0 in
+  for i = 0 to shape.l do
+    for j = 0 to shape.c do
+      if maybe_final i j then
+        res := best_state !res (i,j)
+    done
+  done;
+  let i_final, j_final, _ = !res in
+  assert (i_final <> 0 || j_final <> 0);
+  (i_final, j_final)
+
+let construct_patch m0 =
+  let rec aux acc (i, j) =
+    if i = 0 && j = 0 then
+      acc
+    else
+      match Matrix.diff m0 i j with
+      | None -> assert false
+      | Some d ->
+          let next = match d with
+            | Keep _ | Change _ -> (i-1, j-1)
+            | Delete _ -> (i-1, j)
+            | Insert _ -> (i, j-1)
+          in
+          aux (d::acc) next
+  in
+  aux [] (select_final_state m0)
+
+let diff ~weight ~test ~update state line column =
+  let update d fs = { fs with state = update d fs.state } in
+  let fullstate = { line; column; state } in
+  compute_matrix ~weight ~test ~update fullstate
+  |> construct_patch
+
+type ('l, 'r, 'e, 'd, 'state) update =
+  | Without_extensions of (('l,'r,'e,'d) change -> 'state -> 'state)
+  | With_left_extensions of
+      (('l,'r,'e,'d) change -> 'state -> 'state * 'l array)
+  | With_right_extensions of
+      (('l,'r,'e,'d) change -> 'state -> 'state * 'r array)
+
+let variadic_diff ~weight ~test ~(update:_ update) state line column =
+  let may_append x = function
+    | [||] -> x
+    | y -> Array.append x y in
+  let update = match update with
+    | Without_extensions up ->
+        fun d fs ->
+          let state = up d fs.state in
+          { fs with state }
+    | With_left_extensions up ->
+        fun d fs ->
+          let state, a = up d fs.state in
+          { fs with state ; line = may_append fs.line a }
+    | With_right_extensions up ->
+        fun d fs ->
+          let state, a = up d fs.state in
+          { fs with state ; column = may_append fs.column a }
+  in
+  let fullstate = { line; column; state } in
+  compute_matrix ~weight ~test ~update fullstate
+  |> construct_patch
diff --git a/upstream/ocaml_413/utils/diffing.mli b/upstream/ocaml_413/utils/diffing.mli
new file mode 100644
index 0000000..51f4858
--- /dev/null
+++ b/upstream/ocaml_413/utils/diffing.mli
@@ -0,0 +1,112 @@
+
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Gabriel Radanne, projet Cambium, Inria Paris               *)
+(*                                                                        *)
+(*   Copyright 2020 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** {0 Parametric diffing}
+
+    This module implements diffing over lists of arbitrary content.
+    It is parameterized by
+    - The content of the two lists
+    - The equality witness when an element is kept
+    - The diffing witness when an element is changed
+
+    Diffing is extended to maintain state depending on the
+    computed changes while walking through the two lists.
+
+    The underlying algorithm is a modified Wagner-Fischer algorithm
+    (see <https://en.wikipedia.org/wiki/Wagner%E2%80%93Fischer_algorithm>).
+
+    We provide the following guarantee:
+    Given two lists [l] and [r], if different patches result in different
+    states, we say that the state diverges.
+    - We always return the optimal patch on prefixes of [l] and [r]
+      on which state does not diverge.
+    - Otherwise, we return a correct but non-optimal patch where subpatches
+      with no divergent states are optimal for the given initial state.
+
+    More precisely, the optimality of Wagner-Fischer depends on the property
+    that the edit-distance between a k-prefix of the left input and a l-prefix
+    of the right input d(k,l) satisfies
+
+    d(k,l) = min (
+     del_cost + d(k-1,l),
+     insert_cost + d(k,l-1),
+     change_cost + d(k-1,l-1)
+    )
+
+   Under this hypothesis, it is optimal to choose greedily the state of the
+   minimal patch transforming the left k-prefix into the right l-prefix as a
+   representative of the states of all possible patches transforming the left
+   k-prefix into the right l-prefix.
+
+   If this property is not satisfied, we can still choose greedily a
+   representative state. However, the computed patch is no more guaranteed to
+   be globally optimal.
+   Nevertheless, it is still a correct patch, which is even optimal among all
+   explored patches.
+
+*)
+
+(** The type of potential changes on a list. *)
+type ('left, 'right, 'eq, 'diff) change =
+  | Delete of 'left
+  | Insert of 'right
+  | Keep of 'left * 'right * 'eq
+  | Change of 'left * 'right * 'diff
+
+val map :
+  ('l1 -> 'l2) -> ('r1 -> 'r2) ->
+  ('l1, 'r1, 'eq, 'diff) change ->
+  ('l2, 'r2, 'eq, 'diff) change
+
+(** A patch is an ordered list of changes. *)
+type ('l, 'r, 'eq, 'diff) patch = ('l, 'r, 'eq, 'diff) change list
+
+(** [diff ~weight ~test ~update state l r] computes
+    the diff between [l] and [r], using the initial state [state].
+    - [test st xl xr] tests if the elements [xl] and [xr] are
+      compatible ([Ok]) or not ([Error]).
+    - [weight ch] returns the weight of the change [ch].
+      Used to find the smallest patch.
+    - [update ch st] returns the new state after applying a change.
+*)
+val diff :
+  weight:(('l, 'r, 'eq, 'diff) change -> int) ->
+  test:('state -> 'l -> 'r -> ('eq, 'diff) result) ->
+  update:(('l, 'r, 'eq, 'diff) change -> 'state -> 'state) ->
+  'state -> 'l array -> 'r array -> ('l, 'r, 'eq, 'diff) patch
+
+(** {1 Variadic diffing}
+
+    Variadic diffing allows to expand the lists being diffed during diffing.
+*)
+
+type ('l, 'r, 'e, 'd, 'state) update =
+  | Without_extensions of (('l,'r,'e,'d) change -> 'state -> 'state)
+  | With_left_extensions of
+      (('l,'r,'e,'d) change -> 'state -> 'state * 'l array)
+  | With_right_extensions of
+      (('l,'r,'e,'d) change -> 'state -> 'state * 'r array)
+
+(** [variadic_diff ~weight ~test ~update state l r] behaves as [diff]
+    with the following difference:
+    - [update] must now be an {!update} which indicates in which direction
+      the expansion takes place.
+*)
+val variadic_diff :
+  weight:(('l, 'r, 'eq, 'diff) change -> int) ->
+  test:('state -> 'l -> 'r -> ('eq, 'diff) result) ->
+  update:('l, 'r, 'eq, 'diff, 'state) update ->
+  'state -> 'l array -> 'r array -> ('l, 'r, 'eq, 'diff) patch
diff --git a/upstream/ocaml_413/utils/domainstate.ml.c b/upstream/ocaml_413/utils/domainstate.ml.c
new file mode 100644
index 0000000..7ece1ad
--- /dev/null
+++ b/upstream/ocaml_413/utils/domainstate.ml.c
@@ -0,0 +1,34 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*      KC Sivaramakrishnan, Indian Institute of Technology, Madras       */
+/*                 Stephen Dolan, University of Cambridge                 */
+/*                                                                        */
+/*   Copyright 2019 Indian Institute of Technology, Madras                */
+/*   Copyright 2019 University of Cambridge                               */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+type t =
+#define DOMAIN_STATE(type, name) | Domain_##name
+#include "domain_state.tbl"
+#undef DOMAIN_STATE
+
+let idx_of_field =
+  let curr = 0 in
+#define DOMAIN_STATE(type, name) \
+  let idx__##name = curr in \
+  let curr = curr + 1 in
+#include "domain_state.tbl"
+#undef DOMAIN_STATE
+  let _ = curr in
+  function
+#define DOMAIN_STATE(type, name) \
+  | Domain_##name -> idx__##name
+#include "domain_state.tbl"
+#undef DOMAIN_STATE
diff --git a/upstream/ocaml_413/utils/domainstate.mli.c b/upstream/ocaml_413/utils/domainstate.mli.c
new file mode 100644
index 0000000..1da60c9
--- /dev/null
+++ b/upstream/ocaml_413/utils/domainstate.mli.c
@@ -0,0 +1,22 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*      KC Sivaramakrishnan, Indian Institute of Technology, Madras       */
+/*                Stephen Dolan, University of Cambridge                  */
+/*                                                                        */
+/*   Copyright 2019 Indian Institute of Technology, Madras                */
+/*   Copyright 2019 University of Cambridge                               */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+type t =
+#define DOMAIN_STATE(type, name) | Domain_##name
+#include "domain_state.tbl"
+#undef DOMAIN_STATE
+
+val idx_of_field : t -> int
diff --git a/upstream/ocaml_413/utils/identifiable.ml b/upstream/ocaml_413/utils/identifiable.ml
new file mode 100644
index 0000000..9bbfb65
--- /dev/null
+++ b/upstream/ocaml_413/utils/identifiable.ml
@@ -0,0 +1,249 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+module type Thing = sig
+  type t
+
+  include Hashtbl.HashedType with type t := t
+  include Map.OrderedType with type t := t
+
+  val output : out_channel -> t -> unit
+  val print : Format.formatter -> t -> unit
+end
+
+module type Set = sig
+  module T : Set.OrderedType
+  include Set.S
+    with type elt = T.t
+     and type t = Set.Make (T).t
+
+  val output : out_channel -> t -> unit
+  val print : Format.formatter -> t -> unit
+  val to_string : t -> string
+  val of_list : elt list -> t
+  val map : (elt -> elt) -> t -> t
+end
+
+module type Map = sig
+  module T : Map.OrderedType
+  include Map.S
+    with type key = T.t
+     and type 'a t = 'a Map.Make (T).t
+
+  val of_list : (key * 'a) list -> 'a t
+
+  val disjoint_union :
+    ?eq:('a -> 'a -> bool) -> ?print:(Format.formatter -> 'a -> unit) -> 'a t ->
+    'a t -> 'a t
+
+  val union_right : 'a t -> 'a t -> 'a t
+
+  val union_left : 'a t -> 'a t -> 'a t
+
+  val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
+  val rename : key t -> key -> key
+  val map_keys : (key -> key) -> 'a t -> 'a t
+  val keys : 'a t -> Set.Make(T).t
+  val data : 'a t -> 'a list
+  val of_set : (key -> 'a) -> Set.Make(T).t -> 'a t
+  val transpose_keys_and_data : key t -> key t
+  val transpose_keys_and_data_set : key t -> Set.Make(T).t t
+  val print :
+    (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
+end
+
+module type Tbl = sig
+  module T : sig
+    type t
+    include Map.OrderedType with type t := t
+    include Hashtbl.HashedType with type t := t
+  end
+  include Hashtbl.S
+    with type key = T.t
+     and type 'a t = 'a Hashtbl.Make (T).t
+
+  val to_list : 'a t -> (T.t * 'a) list
+  val of_list : (T.t * 'a) list -> 'a t
+
+  val to_map : 'a t -> 'a Map.Make(T).t
+  val of_map : 'a Map.Make(T).t -> 'a t
+  val memoize : 'a t -> (key -> 'a) -> key -> 'a
+  val map : 'a t -> ('a -> 'b) -> 'b t
+end
+
+module Pair (A : Thing) (B : Thing) : Thing with type t = A.t * B.t = struct
+  type t = A.t * B.t
+
+  let compare (a1, b1) (a2, b2) =
+    let c = A.compare a1 a2 in
+    if c <> 0 then c
+    else B.compare b1 b2
+
+  let output oc (a, b) = Printf.fprintf oc " (%a, %a)" A.output a B.output b
+  let hash (a, b) = Hashtbl.hash (A.hash a, B.hash b)
+  let equal (a1, b1) (a2, b2) = A.equal a1 a2 && B.equal b1 b2
+  let print ppf (a, b) = Format.fprintf ppf " (%a, @ %a)" A.print a B.print b
+end
+
+module Make_map (T : Thing) = struct
+  include Map.Make (T)
+
+  let of_list l =
+    List.fold_left (fun map (id, v) -> add id v map) empty l
+
+  let disjoint_union ?eq ?print m1 m2 =
+    union (fun id v1 v2 ->
+        let ok = match eq with
+          | None -> false
+          | Some eq -> eq v1 v2
+        in
+        if not ok then
+          let err =
+            match print with
+            | None ->
+              Format.asprintf "Map.disjoint_union %a" T.print id
+            | Some print ->
+              Format.asprintf "Map.disjoint_union %a => %a <> %a"
+                T.print id print v1 print v2
+          in
+          Misc.fatal_error err
+        else Some v1)
+      m1 m2
+
+  let union_right m1 m2 =
+    merge (fun _id x y -> match x, y with
+        | None, None -> None
+        | None, Some v
+        | Some v, None
+        | Some _, Some v -> Some v)
+      m1 m2
+
+  let union_left m1 m2 = union_right m2 m1
+
+  let union_merge f m1 m2 =
+    let aux _ m1 m2 =
+      match m1, m2 with
+      | None, m | m, None -> m
+      | Some m1, Some m2 -> Some (f m1 m2)
+    in
+    merge aux m1 m2
+
+  let rename m v =
+    try find v m
+    with Not_found -> v
+
+  let map_keys f m =
+    of_list (List.map (fun (k, v) -> f k, v) (bindings m))
+
+  let print f ppf s =
+    let elts ppf s = iter (fun id v ->
+        Format.fprintf ppf "@ (@[%a@ %a@])" T.print id f v) s in
+    Format.fprintf ppf "@[<1>{@[%a@ @]}@]" elts s
+
+  module T_set = Set.Make (T)
+
+  let keys map = fold (fun k _ set -> T_set.add k set) map T_set.empty
+
+  let data t = List.map snd (bindings t)
+
+  let of_set f set = T_set.fold (fun e map -> add e (f e) map) set empty
+
+  let transpose_keys_and_data map = fold (fun k v m -> add v k m) map empty
+  let transpose_keys_and_data_set map =
+    fold (fun k v m ->
+        let set =
+          match find v m with
+          | exception Not_found ->
+            T_set.singleton k
+          | set ->
+            T_set.add k set
+        in
+        add v set m)
+      map empty
+end
+
+module Make_set (T : Thing) = struct
+  include Set.Make (T)
+
+  let output oc s =
+    Printf.fprintf oc " ( ";
+    iter (fun v -> Printf.fprintf oc "%a " T.output v) s;
+    Printf.fprintf oc ")"
+
+  let print ppf s =
+    let elts ppf s = iter (fun e -> Format.fprintf ppf "@ %a" T.print e) s in
+    Format.fprintf ppf "@[<1>{@[%a@ @]}@]" elts s
+
+  let to_string s = Format.asprintf "%a" print s
+
+  let of_list l = match l with
+    | [] -> empty
+    | [t] -> singleton t
+    | t :: q -> List.fold_left (fun acc e -> add e acc) (singleton t) q
+
+  let map f s = of_list (List.map f (elements s))
+end
+
+module Make_tbl (T : Thing) = struct
+  include Hashtbl.Make (T)
+
+  module T_map = Make_map (T)
+
+  let to_list t =
+    fold (fun key datum elts -> (key, datum)::elts) t []
+
+  let of_list elts =
+    let t = create 42 in
+    List.iter (fun (key, datum) -> add t key datum) elts;
+    t
+
+  let to_map v = fold T_map.add v T_map.empty
+
+  let of_map m =
+    let t = create (T_map.cardinal m) in
+    T_map.iter (fun k v -> add t k v) m;
+    t
+
+  let memoize t f = fun key ->
+    try find t key with
+    | Not_found ->
+      let r = f key in
+      add t key r;
+      r
+
+  let map t f =
+    of_map (T_map.map f (to_map t))
+end
+
+module type S = sig
+  type t
+
+  module T : Thing with type t = t
+  include Thing with type t := T.t
+
+  module Set : Set with module T := T
+  module Map : Map with module T := T
+  module Tbl : Tbl with module T := T
+end
+
+module Make (T : Thing) = struct
+  module T = T
+  include T
+
+  module Set = Make_set (T)
+  module Map = Make_map (T)
+  module Tbl = Make_tbl (T)
+end
diff --git a/upstream/ocaml_413/utils/identifiable.mli b/upstream/ocaml_413/utils/identifiable.mli
new file mode 100644
index 0000000..0da5a66
--- /dev/null
+++ b/upstream/ocaml_413/utils/identifiable.mli
@@ -0,0 +1,113 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Uniform interface for common data structures over various things.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+module type Thing = sig
+  type t
+
+  include Hashtbl.HashedType with type t := t
+  include Map.OrderedType with type t := t
+
+  val output : out_channel -> t -> unit
+  val print : Format.formatter -> t -> unit
+end
+
+module Pair : functor (A : Thing) (B : Thing) -> Thing with type t = A.t * B.t
+
+module type Set = sig
+  module T : Set.OrderedType
+  include Set.S
+    with type elt = T.t
+     and type t = Set.Make (T).t
+
+  val output : out_channel -> t -> unit
+  val print : Format.formatter -> t -> unit
+  val to_string : t -> string
+  val of_list : elt list -> t
+  val map : (elt -> elt) -> t -> t
+end
+
+module type Map = sig
+  module T : Map.OrderedType
+  include Map.S
+    with type key = T.t
+     and type 'a t = 'a Map.Make (T).t
+
+  val of_list : (key * 'a) list -> 'a t
+
+  (** [disjoint_union m1 m2] contains all bindings from [m1] and
+      [m2]. If some binding is present in both and the associated
+      value is not equal, a Fatal_error is raised *)
+  val disjoint_union :
+    ?eq:('a -> 'a -> bool) -> ?print:(Format.formatter -> 'a -> unit) -> 'a t ->
+    'a t -> 'a t
+
+  (** [union_right m1 m2] contains all bindings from [m1] and [m2]. If
+      some binding is present in both, the one from [m2] is taken *)
+  val union_right : 'a t -> 'a t -> 'a t
+
+  (** [union_left m1 m2 = union_right m2 m1] *)
+  val union_left : 'a t -> 'a t -> 'a t
+
+  val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
+  val rename : key t -> key -> key
+  val map_keys : (key -> key) -> 'a t -> 'a t
+  val keys : 'a t -> Set.Make(T).t
+  val data : 'a t -> 'a list
+  val of_set : (key -> 'a) -> Set.Make(T).t -> 'a t
+  val transpose_keys_and_data : key t -> key t
+  val transpose_keys_and_data_set : key t -> Set.Make(T).t t
+  val print :
+    (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
+end
+
+module type Tbl = sig
+  module T : sig
+    type t
+    include Map.OrderedType with type t := t
+    include Hashtbl.HashedType with type t := t
+  end
+  include Hashtbl.S
+    with type key = T.t
+     and type 'a t = 'a Hashtbl.Make (T).t
+
+  val to_list : 'a t -> (T.t * 'a) list
+  val of_list : (T.t * 'a) list -> 'a t
+
+  val to_map : 'a t -> 'a Map.Make(T).t
+  val of_map : 'a Map.Make(T).t -> 'a t
+  val memoize : 'a t -> (key -> 'a) -> key -> 'a
+  val map : 'a t -> ('a -> 'b) -> 'b t
+end
+
+module type S = sig
+  type t
+
+  module T : Thing with type t = t
+  include Thing with type t := T.t
+
+  module Set : Set with module T := T
+  module Map : Map with module T := T
+  module Tbl : Tbl with module T := T
+end
+
+module Make (T : Thing) : S with type t := T.t
diff --git a/upstream/ocaml_413/utils/int_replace_polymorphic_compare.ml b/upstream/ocaml_413/utils/int_replace_polymorphic_compare.ml
new file mode 100644
index 0000000..7cd6bf1
--- /dev/null
+++ b/upstream/ocaml_413/utils/int_replace_polymorphic_compare.ml
@@ -0,0 +1,8 @@
+let ( = )   : int -> int -> bool = Stdlib.( = )
+let ( <> )  : int -> int -> bool = Stdlib.( <> )
+let ( < )   : int -> int -> bool = Stdlib.( < )
+let ( > )   : int -> int -> bool = Stdlib.( > )
+let ( <= )  : int -> int -> bool = Stdlib.( <= )
+let ( >= )  : int -> int -> bool = Stdlib.( >= )
+
+let compare : int -> int -> int  = Stdlib.compare
diff --git a/upstream/ocaml_413/utils/int_replace_polymorphic_compare.mli b/upstream/ocaml_413/utils/int_replace_polymorphic_compare.mli
new file mode 100644
index 0000000..689e741
--- /dev/null
+++ b/upstream/ocaml_413/utils/int_replace_polymorphic_compare.mli
@@ -0,0 +1,8 @@
+val ( = )   : int -> int -> bool
+val ( <> )  : int -> int -> bool
+val ( < )   : int -> int -> bool
+val ( > )   : int -> int -> bool
+val ( <= )  : int -> int -> bool
+val ( >= )  : int -> int -> bool
+
+val compare : int -> int -> int
diff --git a/upstream/ocaml_413/utils/lazy_backtrack.ml b/upstream/ocaml_413/utils/lazy_backtrack.ml
new file mode 100644
index 0000000..a867013
--- /dev/null
+++ b/upstream/ocaml_413/utils/lazy_backtrack.ml
@@ -0,0 +1,81 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type ('a,'b) t = ('a,'b) eval ref
+
+and ('a,'b) eval =
+  | Done of 'b
+  | Raise of exn
+  | Thunk of 'a
+
+type undo =
+  | Nil
+  | Cons : ('a, 'b) t * 'a * undo -> undo
+
+type log = undo ref
+
+let force f x =
+  match !x with
+  | Done x -> x
+  | Raise e -> raise e
+  | Thunk e ->
+      match f e with
+      | y ->
+        x := Done y;
+        y
+      | exception e ->
+        x := Raise e;
+        raise e
+
+let get_arg x =
+  match !x with Thunk a -> Some a | _ -> None
+
+let create x =
+  ref (Thunk x)
+
+let create_forced y =
+  ref (Done y)
+
+let create_failed e =
+  ref (Raise e)
+
+let log () =
+  ref Nil
+
+let force_logged log f x =
+  match !x with
+  | Done x -> x
+  | Raise e -> raise e
+  | Thunk e ->
+    match f e with
+    | (Error _ as err : _ result) ->
+        x := Done err;
+        log := Cons(x, e, !log);
+        err
+    | Ok _ as res ->
+        x := Done res;
+        res
+    | exception e ->
+        x := Raise e;
+        raise e
+
+let backtrack log =
+  let rec loop = function
+    | Nil -> ()
+    | Cons(x, e, rest) ->
+        x := Thunk e;
+        loop rest
+  in
+  loop !log
diff --git a/upstream/ocaml_413/utils/lazy_backtrack.mli b/upstream/ocaml_413/utils/lazy_backtrack.mli
new file mode 100644
index 0000000..b3673be
--- /dev/null
+++ b/upstream/ocaml_413/utils/lazy_backtrack.mli
@@ -0,0 +1,33 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type ('a,'b) t
+
+type log
+
+val force : ('a -> 'b) -> ('a,'b) t -> 'b
+val create : 'a -> ('a,'b) t
+val get_arg : ('a,'b) t -> 'a option
+val create_forced : 'b -> ('a, 'b) t
+val create_failed : exn -> ('a, 'b) t
+
+(* [force_logged log f t] is equivalent to [force f t] but if [f]
+   returns [Error _] then [t] is recorded in [log]. [backtrack log]
+   will then reset all the recorded [t]s back to their original
+   state. *)
+val log : unit -> log
+val force_logged :
+  log -> ('a -> ('b, 'c) result) -> ('a,('b, 'c) result) t -> ('b, 'c) result
+val backtrack : log -> unit
diff --git a/upstream/ocaml_413/utils/load_path.ml b/upstream/ocaml_413/utils/load_path.ml
new file mode 100644
index 0000000..2b1d026
--- /dev/null
+++ b/upstream/ocaml_413/utils/load_path.ml
@@ -0,0 +1,124 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2018 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Local_store
+
+module STbl = Misc.Stdlib.String.Tbl
+
+(* Mapping from basenames to full filenames *)
+type registry = string STbl.t
+
+let files : registry ref = s_table STbl.create 42
+let files_uncap : registry ref = s_table STbl.create 42
+
+module Dir = struct
+  type t = {
+    path : string;
+    files : string list;
+  }
+
+  let path t = t.path
+  let files t = t.files
+
+  (* For backward compatibility reason, simulate the behavior of
+     [Misc.find_in_path]: silently ignore directories that don't exist
+     + treat [""] as the current directory. *)
+  let readdir_compat dir =
+    try
+      Sys.readdir (if dir = "" then Filename.current_dir_name else dir)
+    with Sys_error _ ->
+      [||]
+
+  let create path =
+    { path; files = Array.to_list (readdir_compat path) }
+end
+
+let dirs = s_ref []
+
+let reset () =
+  assert (not Config.merlin || Local_store.is_bound ());
+  STbl.clear !files;
+  STbl.clear !files_uncap;
+  dirs := []
+
+let get () = List.rev !dirs
+let get_paths () = List.rev_map Dir.path !dirs
+
+(* Optimized version of [add] below, for use in [init] and [remove_dir]: since
+   we are starting from an empty cache, we can avoid checking whether a unit
+   name already exists in the cache simply by adding entries in reverse
+   order. *)
+let prepend_add dir =
+  List.iter (fun base ->
+      let fn = Filename.concat dir.Dir.path base in
+      STbl.replace !files base fn;
+      STbl.replace !files_uncap (String.uncapitalize_ascii base) fn
+    ) dir.Dir.files
+
+let init l =
+  reset ();
+  dirs := List.rev_map Dir.create l;
+  List.iter prepend_add !dirs
+
+let remove_dir dir =
+  assert (not Config.merlin || Local_store.is_bound ());
+  let new_dirs = List.filter (fun d -> Dir.path d <> dir) !dirs in
+  if List.compare_lengths new_dirs !dirs <> 0 then begin
+    reset ();
+    List.iter prepend_add new_dirs;
+    dirs := new_dirs
+  end
+
+(* General purpose version of function to add a new entry to load path: We only
+   add a basename to the cache if it is not already present in the cache, in
+   order to enforce left-to-right precedence. *)
+let add dir =
+  assert (not Config.merlin || Local_store.is_bound ());
+  List.iter
+    (fun base ->
+       let fn = Filename.concat dir.Dir.path base in
+       if not (STbl.mem !files base) then
+         STbl.replace !files base fn;
+       let ubase = String.uncapitalize_ascii base in
+       if not (STbl.mem !files_uncap ubase) then
+         STbl.replace !files_uncap ubase fn)
+    dir.Dir.files;
+  dirs := dir :: !dirs
+
+let append_dir = add
+
+let add_dir dir = add (Dir.create dir)
+
+(* Add the directory at the start of load path - so basenames are
+   unconditionally added. *)
+let prepend_dir dir =
+  assert (not Config.merlin || Local_store.is_bound ());
+  prepend_add dir;
+  dirs := !dirs @ [dir]
+
+let is_basename fn = Filename.basename fn = fn
+
+let find fn =
+  assert (not Config.merlin || Local_store.is_bound ());
+  if is_basename fn && not !Sys.interactive then
+    STbl.find !files fn
+  else
+    Misc.find_in_path (get_paths ()) fn
+
+let find_uncap fn =
+  assert (not Config.merlin || Local_store.is_bound ());
+  if is_basename fn && not !Sys.interactive then
+    STbl.find !files_uncap (String.uncapitalize_ascii fn)
+  else
+    Misc.find_in_path_uncap (get_paths ()) fn
diff --git a/upstream/ocaml_413/utils/load_path.mli b/upstream/ocaml_413/utils/load_path.mli
new file mode 100644
index 0000000..1f9aba2
--- /dev/null
+++ b/upstream/ocaml_413/utils/load_path.mli
@@ -0,0 +1,75 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2018 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Management of include directories.
+
+    This module offers a high level interface to locating files in the
+    load path, which is constructed from [-I] command line flags and a few
+    other parameters.
+
+    It makes the assumption that the contents of include directories
+    doesn't change during the execution of the compiler.
+*)
+
+val add_dir : string -> unit
+(** Add a directory to the end of the load path (i.e. at lowest priority.) *)
+
+val remove_dir : string -> unit
+(** Remove a directory from the load path *)
+
+val reset : unit -> unit
+(** Remove all directories *)
+
+val init : string list -> unit
+(** [init l] is the same as [reset (); List.iter add_dir (List.rev l)] *)
+
+val get_paths : unit -> string list
+(** Return the list of directories passed to [add_dir] so far. *)
+
+val find : string -> string
+(** Locate a file in the load path. Raise [Not_found] if the file
+    cannot be found. This function is optimized for the case where the
+    filename is a basename, i.e. doesn't contain a directory
+    separator. *)
+
+val find_uncap : string -> string
+(** Same as [find], but search also for uncapitalized name, i.e.  if
+    name is Foo.ml, allow /path/Foo.ml and /path/foo.ml to match. *)
+
+module Dir : sig
+  type t
+  (** Represent one directory in the load path. *)
+
+  val create : string -> t
+
+  val path : t -> string
+
+  val files : t -> string list
+  (** All the files in that directory. This doesn't include files in
+      sub-directories of this directory. *)
+end
+
+val[@deprecated] add : Dir.t -> unit
+(** Old name for {!append_dir} *)
+
+val append_dir : Dir.t -> unit
+(** [append_dir d] adds [d] to the end of the load path (i.e. at lowest
+    priority. *)
+
+val prepend_dir : Dir.t -> unit
+(** [prepend_dir d] adds [d] to the start of the load path (i.e. at highest
+    priority. *)
+
+val get : unit -> Dir.t list
+(** Same as [get_paths ()], except that it returns a [Dir.t list]. *)
diff --git a/upstream/ocaml_413/utils/local_store.ml b/upstream/ocaml_413/utils/local_store.ml
new file mode 100644
index 0000000..4babf61
--- /dev/null
+++ b/upstream/ocaml_413/utils/local_store.ml
@@ -0,0 +1,74 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                        Frederic Bour, Tarides                          *)
+(*                         Thomas Refis, Tarides                          *)
+(*                                                                        *)
+(*   Copyright 2020 Tarides                                               *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type ref_and_reset =
+  | Table : { ref: 'a ref; init: unit -> 'a } -> ref_and_reset
+  | Ref : { ref: 'a ref; mutable snapshot: 'a } -> ref_and_reset
+
+type bindings = {
+  mutable refs: ref_and_reset list;
+  mutable frozen : bool;
+  mutable is_bound: bool;
+}
+
+let global_bindings =
+  { refs = []; is_bound = false; frozen = false }
+
+let is_bound () = global_bindings.is_bound
+
+let reset () =
+  assert (is_bound ());
+  List.iter (function
+    | Table { ref; init } -> ref := init ()
+    | Ref { ref; snapshot } -> ref := snapshot
+  ) global_bindings.refs
+
+let s_table create size =
+  let init () = create size in
+  let ref = ref (init ()) in
+  assert (not global_bindings.frozen);
+  global_bindings.refs <- (Table { ref; init }) :: global_bindings.refs;
+  ref
+
+let s_ref k =
+  let ref = ref k in
+  assert (not global_bindings.frozen);
+  global_bindings.refs <-
+    (Ref { ref; snapshot = k }) :: global_bindings.refs;
+  ref
+
+type slot = Slot : { ref : 'a ref; mutable value : 'a } -> slot
+type store = slot list
+
+let fresh () =
+  let slots =
+    List.map (function
+      | Table { ref; init } -> Slot {ref; value = init ()}
+      | Ref r ->
+          if not global_bindings.frozen then r.snapshot <- !(r.ref);
+          Slot { ref = r.ref; value = r.snapshot }
+    ) global_bindings.refs
+  in
+  global_bindings.frozen <- true;
+  slots
+
+let with_store slots f =
+  assert (not global_bindings.is_bound);
+  global_bindings.is_bound <- true;
+  List.iter (fun (Slot {ref;value}) -> ref := value) slots;
+  Fun.protect f ~finally:(fun () ->
+    List.iter (fun (Slot s) -> s.value <- !(s.ref)) slots;
+    global_bindings.is_bound <- false;
+  )
diff --git a/upstream/ocaml_413/utils/local_store.mli b/upstream/ocaml_413/utils/local_store.mli
new file mode 100644
index 0000000..f39cd12
--- /dev/null
+++ b/upstream/ocaml_413/utils/local_store.mli
@@ -0,0 +1,66 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                        Frederic Bour, Tarides                          *)
+(*                         Thomas Refis, Tarides                          *)
+(*                                                                        *)
+(*   Copyright 2020 Tarides                                               *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** This module provides some facilities for creating references (and hash
+    tables) which can easily be snapshoted and restored to an arbitrary version.
+
+    It is used throughout the frontend (read: typechecker), to register all
+    (well, hopefully) the global state. Thus making it easy for tools like
+    Merlin to go back and forth typechecking different files. *)
+
+(** {1 Creators} *)
+
+val s_ref : 'a -> 'a ref
+(** Similar to {!ref}, except the allocated reference is registered into the
+    store. *)
+
+val s_table : ('a -> 'b) -> 'a -> 'b ref
+(** Used to register hash tables. Those also need to be placed into refs to be
+    easily swapped out, but one can't just "snapshot" the initial value to
+    create fresh instances, so instead an initializer is required.
+
+    Use it like this:
+    {[
+      let my_table = s_table Hashtbl.create 42
+    ]}
+*)
+
+(** {1 State management}
+
+    Note: all the following functions are currently unused inside the compiler
+    codebase. Merlin is their only user at the moment. *)
+
+type store
+
+val fresh : unit -> store
+(** Returns a fresh instance of the store.
+
+    The first time this function is called, it snapshots the value of all the
+    registered references, later calls to [fresh] will return instances
+    initialized to those values. *)
+
+val with_store : store -> (unit -> 'a) -> 'a
+(** [with_scope s f] resets all the registered references to the value they have
+    in [s] for the run of [f].
+    If [f] updates any of the registered refs, [s] is updated to remember those
+    changes. *)
+
+val reset : unit -> unit
+(** Resets all the references to the initial snapshot (i.e. to the same values
+    that new instances start with). *)
+
+val is_bound : unit -> bool
+(** Returns [true] when a scope is active (i.e. when called from the callback
+    passed to {!with_scope}), [false] otherwise. *)
diff --git a/upstream/ocaml_413/utils/misc.ml b/upstream/ocaml_413/utils/misc.ml
new file mode 100644
index 0000000..c5bfadf
--- /dev/null
+++ b/upstream/ocaml_413/utils/misc.ml
@@ -0,0 +1,1118 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Errors *)
+
+exception Fatal_error
+
+let fatal_errorf fmt =
+  Format.kfprintf
+    (fun _ -> raise Fatal_error)
+    Format.err_formatter
+    ("@?>> Fatal error: " ^^ fmt ^^ "@.")
+
+let fatal_error msg = fatal_errorf "%s" msg
+
+(* Exceptions *)
+
+let try_finally ?(always=(fun () -> ())) ?(exceptionally=(fun () -> ())) work =
+  match work () with
+    | result ->
+      begin match always () with
+        | () -> result
+        | exception always_exn ->
+          let always_bt = Printexc.get_raw_backtrace () in
+          exceptionally ();
+          Printexc.raise_with_backtrace always_exn always_bt
+      end
+    | exception work_exn ->
+      let work_bt = Printexc.get_raw_backtrace () in
+      begin match always () with
+        | () ->
+          exceptionally ();
+          Printexc.raise_with_backtrace work_exn work_bt
+        | exception always_exn ->
+          let always_bt = Printexc.get_raw_backtrace () in
+          exceptionally ();
+          Printexc.raise_with_backtrace always_exn always_bt
+      end
+
+let reraise_preserving_backtrace e f =
+  let bt = Printexc.get_raw_backtrace () in
+  f ();
+  Printexc.raise_with_backtrace e bt
+
+type ref_and_value = R : 'a ref * 'a -> ref_and_value
+
+let protect_refs =
+  let set_refs l = List.iter (fun (R (r, v)) -> r := v) l in
+  fun refs f ->
+    let backup = List.map (fun (R (r, _)) -> R (r, !r)) refs in
+    set_refs refs;
+    Fun.protect ~finally:(fun () -> set_refs backup) f
+
+(* List functions *)
+
+let rec map_end f l1 l2 =
+  match l1 with
+    [] -> l2
+  | hd::tl -> f hd :: map_end f tl l2
+
+let rec map_left_right f = function
+    [] -> []
+  | hd::tl -> let res = f hd in res :: map_left_right f tl
+
+let rec for_all2 pred l1 l2 =
+  match (l1, l2) with
+    ([], []) -> true
+  | (hd1::tl1, hd2::tl2) -> pred hd1 hd2 && for_all2 pred tl1 tl2
+  | (_, _) -> false
+
+let rec replicate_list elem n =
+  if n <= 0 then [] else elem :: replicate_list elem (n-1)
+
+let rec list_remove x = function
+    [] -> []
+  | hd :: tl ->
+      if hd = x then tl else hd :: list_remove x tl
+
+let rec split_last = function
+    [] -> assert false
+  | [x] -> ([], x)
+  | hd :: tl ->
+      let (lst, last) = split_last tl in
+      (hd :: lst, last)
+
+module Stdlib = struct
+  module List = struct
+    type 'a t = 'a list
+
+    let rec compare cmp l1 l2 =
+      match l1, l2 with
+      | [], [] -> 0
+      | [], _::_ -> -1
+      | _::_, [] -> 1
+      | h1::t1, h2::t2 ->
+        let c = cmp h1 h2 in
+        if c <> 0 then c
+        else compare cmp t1 t2
+
+    let rec equal eq l1 l2 =
+      match l1, l2 with
+      | ([], []) -> true
+      | (hd1 :: tl1, hd2 :: tl2) -> eq hd1 hd2 && equal eq tl1 tl2
+      | (_, _) -> false
+
+    let map2_prefix f l1 l2 =
+      let rec aux acc l1 l2 =
+        match l1, l2 with
+        | [], _ -> (List.rev acc, l2)
+        | _ :: _, [] -> raise (Invalid_argument "map2_prefix")
+        | h1::t1, h2::t2 ->
+          let h = f h1 h2 in
+          aux (h :: acc) t1 t2
+      in
+      aux [] l1 l2
+
+    let some_if_all_elements_are_some l =
+      let rec aux acc l =
+        match l with
+        | [] -> Some (List.rev acc)
+        | None :: _ -> None
+        | Some h :: t -> aux (h :: acc) t
+      in
+      aux [] l
+
+    let split_at n l =
+      let rec aux n acc l =
+        if n = 0
+        then List.rev acc, l
+        else
+          match l with
+          | [] -> raise (Invalid_argument "split_at")
+          | t::q -> aux (n-1) (t::acc) q
+      in
+      aux n [] l
+
+    let rec is_prefix ~equal t ~of_ =
+      match t, of_ with
+      | [], [] -> true
+      | _::_, [] -> false
+      | [], _::_ -> true
+      | x1::t, x2::of_ -> equal x1 x2 && is_prefix ~equal t ~of_
+
+    type 'a longest_common_prefix_result = {
+      longest_common_prefix : 'a list;
+      first_without_longest_common_prefix : 'a list;
+      second_without_longest_common_prefix : 'a list;
+    }
+
+    let find_and_chop_longest_common_prefix ~equal ~first ~second =
+      let rec find_prefix ~longest_common_prefix_rev l1 l2 =
+        match l1, l2 with
+        | elt1 :: l1, elt2 :: l2 when equal elt1 elt2 ->
+          let longest_common_prefix_rev = elt1 :: longest_common_prefix_rev in
+          find_prefix ~longest_common_prefix_rev l1 l2
+        | l1, l2 ->
+          { longest_common_prefix = List.rev longest_common_prefix_rev;
+            first_without_longest_common_prefix = l1;
+            second_without_longest_common_prefix = l2;
+          }
+      in
+      find_prefix ~longest_common_prefix_rev:[] first second
+  end
+
+  module Option = struct
+    type 'a t = 'a option
+
+    let print print_contents ppf t =
+      match t with
+      | None -> Format.pp_print_string ppf "None"
+      | Some contents ->
+        Format.fprintf ppf "@[(Some@ %a)@]" print_contents contents
+  end
+
+  module Array = struct
+    let exists2 p a1 a2 =
+      let n = Array.length a1 in
+      if Array.length a2 <> n then invalid_arg "Misc.Stdlib.Array.exists2";
+      let rec loop i =
+        if i = n then false
+        else if p (Array.unsafe_get a1 i) (Array.unsafe_get a2 i) then true
+        else loop (succ i) in
+      loop 0
+
+    let for_alli p a =
+      let n = Array.length a in
+      let rec loop i =
+        if i = n then true
+        else if p i (Array.unsafe_get a i) then loop (succ i)
+        else false in
+      loop 0
+
+    let all_somes a =
+      try
+        Some (Array.map (function None -> raise_notrace Exit | Some x -> x) a)
+      with
+      | Exit -> None
+  end
+
+  module String = struct
+    include String
+    module Set = Set.Make(String)
+    module Map = Map.Make(String)
+    module Tbl = Hashtbl.Make(struct
+      include String
+      let hash = Hashtbl.hash
+    end)
+
+    let for_all f t =
+      let len = String.length t in
+      let rec loop i =
+        i = len || (f t.[i] && loop (i + 1))
+      in
+      loop 0
+
+    let print ppf t =
+      Format.pp_print_string ppf t
+  end
+
+  external compare : 'a -> 'a -> int = "%compare"
+end
+
+(* File functions *)
+
+let find_in_path path name =
+  if not (Filename.is_implicit name) then
+    if Sys.file_exists name then name else raise Not_found
+  else begin
+    let rec try_dir = function
+      [] -> raise Not_found
+    | dir::rem ->
+        let fullname = Filename.concat dir name in
+        if Sys.file_exists fullname then fullname else try_dir rem
+    in try_dir path
+  end
+
+let find_in_path_rel path name =
+  let rec simplify s =
+    let open Filename in
+    let base = basename s in
+    let dir = dirname s in
+    if dir = s then dir
+    else if base = current_dir_name then simplify dir
+    else concat (simplify dir) base
+  in
+  let rec try_dir = function
+    [] -> raise Not_found
+  | dir::rem ->
+      let fullname = simplify (Filename.concat dir name) in
+      if Sys.file_exists fullname then fullname else try_dir rem
+  in try_dir path
+
+let find_in_path_uncap path name =
+  let uname = String.uncapitalize_ascii name in
+  let rec try_dir = function
+    [] -> raise Not_found
+  | dir::rem ->
+      let fullname = Filename.concat dir name
+      and ufullname = Filename.concat dir uname in
+      if Sys.file_exists ufullname then ufullname
+      else if Sys.file_exists fullname then fullname
+      else try_dir rem
+  in try_dir path
+
+let remove_file filename =
+  try
+    if Sys.file_exists filename
+    then Sys.remove filename
+  with Sys_error _msg ->
+    ()
+
+(* Expand a -I option: if it starts with +, make it relative to the standard
+   library directory *)
+
+let expand_directory alt s =
+  if String.length s > 0 && s.[0] = '+'
+  then Filename.concat alt
+                       (String.sub s 1 (String.length s - 1))
+  else s
+
+let path_separator =
+  match Sys.os_type with
+  | "Win32" -> ';'
+  | _ -> ':'
+
+let split_path_contents ?(sep = path_separator) = function
+  | "" -> []
+  | s -> String.split_on_char sep s
+
+(* Hashtable functions *)
+
+let create_hashtable size init =
+  let tbl = Hashtbl.create size in
+  List.iter (fun (key, data) -> Hashtbl.add tbl key data) init;
+  tbl
+
+(* File copy *)
+
+let copy_file ic oc =
+  let buff = Bytes.create 0x1000 in
+  let rec copy () =
+    let n = input ic buff 0 0x1000 in
+    if n = 0 then () else (output oc buff 0 n; copy())
+  in copy()
+
+let copy_file_chunk ic oc len =
+  let buff = Bytes.create 0x1000 in
+  let rec copy n =
+    if n <= 0 then () else begin
+      let r = input ic buff 0 (Int.min n 0x1000) in
+      if r = 0 then raise End_of_file else (output oc buff 0 r; copy(n-r))
+    end
+  in copy len
+
+let string_of_file ic =
+  let b = Buffer.create 0x10000 in
+  let buff = Bytes.create 0x1000 in
+  let rec copy () =
+    let n = input ic buff 0 0x1000 in
+    if n = 0 then Buffer.contents b else
+      (Buffer.add_subbytes b buff 0 n; copy())
+  in copy()
+
+let output_to_file_via_temporary ?(mode = [Open_text]) filename fn =
+  let (temp_filename, oc) =
+    Filename.open_temp_file
+       ~mode ~perms:0o666 ~temp_dir:(Filename.dirname filename)
+       (Filename.basename filename) ".tmp" in
+    (* The 0o666 permissions will be modified by the umask.  It's just
+       like what [open_out] and [open_out_bin] do.
+       With temp_dir = dirname filename, we ensure that the returned
+       temp file is in the same directory as filename itself, making
+       it safe to rename temp_filename to filename later.
+       With prefix = basename filename, we are almost certain that
+       the first generated name will be unique.  A fixed prefix
+       would work too but might generate more collisions if many
+       files are being produced simultaneously in the same directory. *)
+  match fn temp_filename oc with
+  | res ->
+      close_out oc;
+      begin try
+        Sys.rename temp_filename filename; res
+      with exn ->
+        remove_file temp_filename; raise exn
+      end
+  | exception exn ->
+      close_out oc; remove_file temp_filename; raise exn
+
+let protect_writing_to_file ~filename ~f =
+  let outchan = open_out_bin filename in
+  try_finally ~always:(fun () -> close_out outchan)
+    ~exceptionally:(fun () -> remove_file filename)
+    (fun () -> f outchan)
+
+(* Integer operations *)
+
+let rec log2 n =
+  if n <= 1 then 0 else 1 + log2(n asr 1)
+
+let align n a =
+  if n >= 0 then (n + a - 1) land (-a) else n land (-a)
+
+let no_overflow_add a b = (a lxor b) lor (a lxor (lnot (a+b))) < 0
+
+let no_overflow_sub a b = (a lxor (lnot b)) lor (b lxor (a-b)) < 0
+
+(* Taken from Hacker's Delight, chapter "Overflow Detection" *)
+let no_overflow_mul a b =
+  not ((a = min_int && b < 0) || (b <> 0 && (a * b) / b <> a))
+
+let no_overflow_lsl a k =
+  0 <= k && k < Sys.word_size - 1 && min_int asr k <= a && a <= max_int asr k
+
+module Int_literal_converter = struct
+  (* To convert integer literals, allowing max_int + 1 (PR#4210) *)
+  let cvt_int_aux str neg of_string =
+    if String.length str = 0 || str.[0]= '-'
+    then of_string str
+    else neg (of_string ("-" ^ str))
+  let int s = cvt_int_aux s (~-) int_of_string
+  let int32 s = cvt_int_aux s Int32.neg Int32.of_string
+  let int64 s = cvt_int_aux s Int64.neg Int64.of_string
+  let nativeint s = cvt_int_aux s Nativeint.neg Nativeint.of_string
+end
+
+(* String operations *)
+
+let chop_extensions file =
+  let dirname = Filename.dirname file and basename = Filename.basename file in
+  try
+    let pos = String.index basename '.' in
+    let basename = String.sub basename 0 pos in
+    if Filename.is_implicit file && dirname = Filename.current_dir_name then
+      basename
+    else
+      Filename.concat dirname basename
+  with Not_found -> file
+
+let search_substring pat str start =
+  let rec search i j =
+    if j >= String.length pat then i
+    else if i + j >= String.length str then raise Not_found
+    else if str.[i + j] = pat.[j] then search i (j+1)
+    else search (i+1) 0
+  in search start 0
+
+let replace_substring ~before ~after str =
+  let rec search acc curr =
+    match search_substring before str curr with
+      | next ->
+         let prefix = String.sub str curr (next - curr) in
+         search (prefix :: acc) (next + String.length before)
+      | exception Not_found ->
+        let suffix = String.sub str curr (String.length str - curr) in
+        List.rev (suffix :: acc)
+  in String.concat after (search [] 0)
+
+let rev_split_words s =
+  let rec split1 res i =
+    if i >= String.length s then res else begin
+      match s.[i] with
+        ' ' | '\t' | '\r' | '\n' -> split1 res (i+1)
+      | _ -> split2 res i (i+1)
+    end
+  and split2 res i j =
+    if j >= String.length s then String.sub s i (j-i) :: res else begin
+      match s.[j] with
+        ' ' | '\t' | '\r' | '\n' -> split1 (String.sub s i (j-i) :: res) (j+1)
+      | _ -> split2 res i (j+1)
+    end
+  in split1 [] 0
+
+let get_ref r =
+  let v = !r in
+  r := []; v
+
+let set_or_ignore f opt x =
+  match f x with
+  | None -> ()
+  | Some y -> opt := Some y
+
+let fst3 (x, _, _) = x
+let snd3 (_,x,_) = x
+let thd3 (_,_,x) = x
+
+let fst4 (x, _, _, _) = x
+let snd4 (_,x,_, _) = x
+let thd4 (_,_,x,_) = x
+let for4 (_,_,_,x) = x
+
+
+module LongString = struct
+  type t = bytes array
+
+  let create str_size =
+    let tbl_size = str_size / Sys.max_string_length + 1 in
+    let tbl = Array.make tbl_size Bytes.empty in
+    for i = 0 to tbl_size - 2 do
+      tbl.(i) <- Bytes.create Sys.max_string_length;
+    done;
+    tbl.(tbl_size - 1) <- Bytes.create (str_size mod Sys.max_string_length);
+    tbl
+
+  let length tbl =
+    let tbl_size = Array.length tbl in
+    Sys.max_string_length * (tbl_size - 1) + Bytes.length tbl.(tbl_size - 1)
+
+  let get tbl ind =
+    Bytes.get tbl.(ind / Sys.max_string_length) (ind mod Sys.max_string_length)
+
+  let set tbl ind c =
+    Bytes.set tbl.(ind / Sys.max_string_length) (ind mod Sys.max_string_length)
+              c
+
+  let blit src srcoff dst dstoff len =
+    for i = 0 to len - 1 do
+      set dst (dstoff + i) (get src (srcoff + i))
+    done
+
+  let blit_string src srcoff dst dstoff len =
+    for i = 0 to len - 1 do
+      set dst (dstoff + i) (String.get src (srcoff + i))
+    done
+
+  let output oc tbl pos len =
+    for i = pos to pos + len - 1 do
+      output_char oc (get tbl i)
+    done
+
+  let input_bytes_into tbl ic len =
+    let count = ref len in
+    Array.iter (fun str ->
+      let chunk = Int.min !count (Bytes.length str) in
+      really_input ic str 0 chunk;
+      count := !count - chunk) tbl
+
+  let input_bytes ic len =
+    let tbl = create len in
+    input_bytes_into tbl ic len;
+    tbl
+end
+
+
+let edit_distance a b cutoff =
+  let la, lb = String.length a, String.length b in
+  let cutoff =
+    (* using max_int for cutoff would cause overflows in (i + cutoff + 1);
+       we bring it back to the (max la lb) worstcase *)
+    Int.min (Int.max la lb) cutoff in
+  if abs (la - lb) > cutoff then None
+  else begin
+    (* initialize with 'cutoff + 1' so that not-yet-written-to cases have
+       the worst possible cost; this is useful when computing the cost of
+       a case just at the boundary of the cutoff diagonal. *)
+    let m = Array.make_matrix (la + 1) (lb + 1) (cutoff + 1) in
+    m.(0).(0) <- 0;
+    for i = 1 to la do
+      m.(i).(0) <- i;
+    done;
+    for j = 1 to lb do
+      m.(0).(j) <- j;
+    done;
+    for i = 1 to la do
+      for j = Int.max 1 (i - cutoff - 1) to Int.min lb (i + cutoff + 1) do
+        let cost = if a.[i-1] = b.[j-1] then 0 else 1 in
+        let best =
+          (* insert, delete or substitute *)
+          Int.min (1 + Int.min m.(i-1).(j) m.(i).(j-1)) (m.(i-1).(j-1) + cost)
+        in
+        let best =
+          (* swap two adjacent letters; we use "cost" again in case of
+             a swap between two identical letters; this is slightly
+             redundant as this is a double-substitution case, but it
+             was done this way in most online implementations and
+             imitation has its virtues *)
+          if not (i > 1 && j > 1 && a.[i-1] = b.[j-2] && a.[i-2] = b.[j-1])
+          then best
+          else Int.min best (m.(i-2).(j-2) + cost)
+        in
+        m.(i).(j) <- best
+      done;
+    done;
+    let result = m.(la).(lb) in
+    if result > cutoff
+    then None
+    else Some result
+  end
+
+let spellcheck env name =
+  let cutoff =
+    match String.length name with
+      | 1 | 2 -> 0
+      | 3 | 4 -> 1
+      | 5 | 6 -> 2
+      | _ -> 3
+  in
+  let compare target acc head =
+    match edit_distance target head cutoff with
+      | None -> acc
+      | Some dist ->
+         let (best_choice, best_dist) = acc in
+         if dist < best_dist then ([head], dist)
+         else if dist = best_dist then (head :: best_choice, dist)
+         else acc
+  in
+  let env = List.sort_uniq (fun s1 s2 -> String.compare s2 s1) env in
+  fst (List.fold_left (compare name) ([], max_int) env)
+
+let did_you_mean ppf get_choices =
+  (* flush now to get the error report early, in the (unheard of) case
+     where the search in the get_choices function would take a bit of
+     time; in the worst case, the user has seen the error, she can
+     interrupt the process before the spell-checking terminates. *)
+  Format.fprintf ppf "@?";
+  match get_choices () with
+  | [] -> ()
+  | choices ->
+     let rest, last = split_last choices in
+     Format.fprintf ppf "@\nHint: Did you mean %s%s%s?@?"
+       (String.concat ", " rest)
+       (if rest = [] then "" else " or ")
+       last
+
+let cut_at s c =
+  let pos = String.index s c in
+  String.sub s 0 pos, String.sub s (pos+1) (String.length s - pos - 1)
+
+(* Color handling *)
+module Color = struct
+  (* use ANSI color codes, see https://en.wikipedia.org/wiki/ANSI_escape_code *)
+  type color =
+    | Black
+    | Red
+    | Green
+    | Yellow
+    | Blue
+    | Magenta
+    | Cyan
+    | White
+  ;;
+
+  type style =
+    | FG of color (* foreground *)
+    | BG of color (* background *)
+    | Bold
+    | Reset
+
+  let ansi_of_color = function
+    | Black -> "0"
+    | Red -> "1"
+    | Green -> "2"
+    | Yellow -> "3"
+    | Blue -> "4"
+    | Magenta -> "5"
+    | Cyan -> "6"
+    | White -> "7"
+
+  let code_of_style = function
+    | FG c -> "3" ^ ansi_of_color c
+    | BG c -> "4" ^ ansi_of_color c
+    | Bold -> "1"
+    | Reset -> "0"
+
+  let ansi_of_style_l l =
+    let s = match l with
+      | [] -> code_of_style Reset
+      | [s] -> code_of_style s
+      | _ -> String.concat ";" (List.map code_of_style l)
+    in
+    "\x1b[" ^ s ^ "m"
+
+
+  type Format.stag += Style of style list
+  type styles = {
+    error: style list;
+    warning: style list;
+    loc: style list;
+  }
+
+  let default_styles = {
+    warning = [Bold; FG Magenta];
+    error = [Bold; FG Red];
+    loc = [Bold];
+  }
+
+  let cur_styles = ref default_styles
+  let get_styles () = !cur_styles
+  let set_styles s = cur_styles := s
+
+  (* map a tag to a style, if the tag is known.
+     @raise Not_found otherwise *)
+  let style_of_tag s = match s with
+    | Format.String_tag "error" -> (!cur_styles).error
+    | Format.String_tag "warning" -> (!cur_styles).warning
+    | Format.String_tag "loc" -> (!cur_styles).loc
+    | Style s -> s
+    | _ -> raise Not_found
+
+  let color_enabled = ref true
+
+  (* either prints the tag of [s] or delegates to [or_else] *)
+  let mark_open_tag ~or_else s =
+    try
+      let style = style_of_tag s in
+      if !color_enabled then ansi_of_style_l style else ""
+    with Not_found -> or_else s
+
+  let mark_close_tag ~or_else s =
+    try
+      let _ = style_of_tag s in
+      if !color_enabled then ansi_of_style_l [Reset] else ""
+    with Not_found -> or_else s
+
+  (* add color handling to formatter [ppf] *)
+  let set_color_tag_handling ppf =
+    let open Format in
+    let functions = pp_get_formatter_stag_functions ppf () in
+    let functions' = {functions with
+      mark_open_stag=(mark_open_tag ~or_else:functions.mark_open_stag);
+      mark_close_stag=(mark_close_tag ~or_else:functions.mark_close_stag);
+    } in
+    pp_set_mark_tags ppf true; (* enable tags *)
+    pp_set_formatter_stag_functions ppf functions';
+    ()
+
+  external isatty : out_channel -> bool = "caml_sys_isatty"
+
+  (* reasonable heuristic on whether colors should be enabled *)
+  let should_enable_color () =
+    let term = try Sys.getenv "TERM" with Not_found -> "" in
+    term <> "dumb"
+    && term <> ""
+    && isatty stderr
+
+  type setting = Auto | Always | Never
+
+  let default_setting = Auto
+
+  let setup =
+    let first = ref true in (* initialize only once *)
+    let formatter_l =
+      [Format.std_formatter; Format.err_formatter; Format.str_formatter]
+    in
+    let enable_color = function
+      | Auto -> should_enable_color ()
+      | Always -> true
+      | Never -> false
+    in
+    fun o ->
+      if !first then (
+        first := false;
+        Format.set_mark_tags true;
+        List.iter set_color_tag_handling formatter_l;
+        color_enabled := (match o with
+          | Some s -> enable_color s
+          | None -> enable_color default_setting)
+      );
+      ()
+end
+
+module Error_style = struct
+  type setting =
+    | Contextual
+    | Short
+
+  let default_setting = Contextual
+end
+
+let normalise_eol s =
+  let b = Buffer.create 80 in
+    for i = 0 to String.length s - 1 do
+      if s.[i] <> '\r' then Buffer.add_char b s.[i]
+    done;
+    Buffer.contents b
+
+let delete_eol_spaces src =
+  let len_src = String.length src in
+  let dst = Bytes.create len_src in
+  let rec loop i_src i_dst =
+    if i_src = len_src then
+      i_dst
+    else
+      match src.[i_src] with
+      | ' ' | '\t' ->
+        loop_spaces 1 (i_src + 1) i_dst
+      | c ->
+        Bytes.set dst i_dst c;
+        loop (i_src + 1) (i_dst + 1)
+  and loop_spaces spaces i_src i_dst =
+    if i_src = len_src then
+      i_dst
+    else
+      match src.[i_src] with
+      | ' ' | '\t' ->
+        loop_spaces (spaces + 1) (i_src + 1) i_dst
+      | '\n' ->
+        Bytes.set dst i_dst '\n';
+        loop (i_src + 1) (i_dst + 1)
+      | _ ->
+        for n = 0 to spaces do
+          Bytes.set dst (i_dst + n) src.[i_src - spaces + n]
+        done;
+        loop (i_src + 1) (i_dst + spaces + 1)
+  in
+  let stop = loop 0 0 in
+  Bytes.sub_string dst 0 stop
+
+let pp_two_columns ?(sep = "|") ?max_lines ppf (lines: (string * string) list) =
+  let left_column_size =
+    List.fold_left (fun acc (s, _) -> Int.max acc (String.length s)) 0 lines in
+  let lines_nb = List.length lines in
+  let ellipsed_first, ellipsed_last =
+    match max_lines with
+    | Some max_lines when lines_nb > max_lines ->
+        let printed_lines = max_lines - 1 in (* the ellipsis uses one line *)
+        let lines_before = printed_lines / 2 + printed_lines mod 2 in
+        let lines_after = printed_lines / 2 in
+        (lines_before, lines_nb - lines_after - 1)
+    | _ -> (-1, -1)
+  in
+  Format.fprintf ppf "@[<v>";
+  List.iteri (fun k (line_l, line_r) ->
+    if k = ellipsed_first then Format.fprintf ppf "...@,";
+    if ellipsed_first <= k && k <= ellipsed_last then ()
+    else Format.fprintf ppf "%*s %s %s@," left_column_size line_l sep line_r
+  ) lines;
+  Format.fprintf ppf "@]"
+
+(* showing configuration and configuration variables *)
+let show_config_and_exit () =
+  Config.print_config stdout;
+  exit 0
+
+let show_config_variable_and_exit x =
+  match Config.config_var x with
+  | Some v ->
+      (* we intentionally don't print a newline to avoid Windows \r
+         issues: bash only strips the trailing \n when using a command
+         substitution $(ocamlc -config-var foo), so a trailing \r would
+         remain if printing a newline under Windows and scripts would
+         have to use $(ocamlc -config-var foo | tr -d '\r')
+         for portability. Ugh. *)
+      print_string v;
+      exit 0
+  | None ->
+      exit 2
+
+let get_build_path_prefix_map =
+  let init = ref false in
+  let map_cache = ref None in
+  fun () ->
+    if not !init then begin
+      init := true;
+      match Sys.getenv "BUILD_PATH_PREFIX_MAP" with
+      | exception Not_found -> ()
+      | encoded_map ->
+        match Build_path_prefix_map.decode_map encoded_map with
+          | Error err ->
+              fatal_errorf
+                "Invalid value for the environment variable \
+                 BUILD_PATH_PREFIX_MAP: %s" err
+          | Ok map -> map_cache := Some map
+    end;
+    !map_cache
+
+let debug_prefix_map_flags () =
+  if not Config.as_has_debug_prefix_map then
+    []
+  else begin
+    match get_build_path_prefix_map () with
+    | None -> []
+    | Some map ->
+      List.fold_right
+        (fun map_elem acc ->
+           match map_elem with
+           | None -> acc
+           | Some { Build_path_prefix_map.target; source; } ->
+             (Printf.sprintf "--debug-prefix-map %s=%s"
+                (Filename.quote source)
+                (Filename.quote target)) :: acc)
+        map
+        []
+  end
+
+let print_if ppf flag printer arg =
+  if !flag then Format.fprintf ppf "%a@." printer arg;
+  arg
+
+
+type filepath = string
+type modname = string
+type crcs = (modname * Digest.t option) list
+
+type alerts = string Stdlib.String.Map.t
+
+module Magic_number = struct
+  type native_obj_config = {
+    flambda : bool;
+  }
+  let native_obj_config = {
+    flambda = Config.flambda;
+  }
+
+  type version = int
+
+  type kind =
+    | Exec
+    | Cmi | Cmo | Cma
+    | Cmx of native_obj_config | Cmxa of native_obj_config
+    | Cmxs
+    | Cmt
+    | Ast_impl | Ast_intf
+
+  (* please keep up-to-date, this is used for sanity checking *)
+  let all_native_obj_configs = [
+      {flambda = true};
+      {flambda = false};
+    ]
+  let all_kinds = [
+    Exec;
+    Cmi; Cmo; Cma;
+  ]
+  @ List.map (fun conf -> Cmx conf) all_native_obj_configs
+  @ List.map (fun conf -> Cmxa conf) all_native_obj_configs
+  @ [
+    Cmt;
+    Ast_impl; Ast_intf;
+  ]
+
+  type raw = string
+  type info = {
+    kind: kind;
+    version: version;
+  }
+
+  type raw_kind = string
+
+  let parse_kind : raw_kind -> kind option = function
+    | "Caml1999X" -> Some Exec
+    | "Caml1999I" -> Some Cmi
+    | "Caml1999O" -> Some Cmo
+    | "Caml1999A" -> Some Cma
+    | "Caml1999y" -> Some (Cmx {flambda = true})
+    | "Caml1999Y" -> Some (Cmx {flambda = false})
+    | "Caml1999z" -> Some (Cmxa {flambda = true})
+    | "Caml1999Z" -> Some (Cmxa {flambda = false})
+
+    (* Caml2007D and Caml2012T were used instead of the common Caml1999 prefix
+       between the introduction of those magic numbers and October 2017
+       (8ba70ff194b66c0a50ffb97d41fe9c4bdf9362d6).
+
+       We accept them here, but will always produce/show kind prefixes
+       that follow the current convention, Caml1999{D,T}. *)
+    | "Caml2007D" | "Caml1999D" -> Some Cmxs
+    | "Caml2012T" | "Caml1999T" -> Some Cmt
+
+    | "Caml1999M" -> Some Ast_impl
+    | "Caml1999N" -> Some Ast_intf
+    | _ -> None
+
+  (* note: over time the magic kind number has changed for certain kinds;
+     this function returns them as they are produced by the current compiler,
+     but [parse_kind] accepts older formats as well. *)
+  let raw_kind : kind -> raw = function
+    | Exec -> "Caml1999X"
+    | Cmi -> "Caml1999I"
+    | Cmo -> "Caml1999O"
+    | Cma -> "Caml1999A"
+    | Cmx config ->
+       if config.flambda
+       then "Caml1999y"
+       else "Caml1999Y"
+    | Cmxa config ->
+       if config.flambda
+       then "Caml1999z"
+       else "Caml1999Z"
+    | Cmxs -> "Caml1999D"
+    | Cmt -> "Caml1999T"
+    | Ast_impl -> "Caml1999M"
+    | Ast_intf -> "Caml1999N"
+
+  let string_of_kind : kind -> string = function
+    | Exec -> "exec"
+    | Cmi -> "cmi"
+    | Cmo -> "cmo"
+    | Cma -> "cma"
+    | Cmx _ -> "cmx"
+    | Cmxa _ -> "cmxa"
+    | Cmxs -> "cmxs"
+    | Cmt -> "cmt"
+    | Ast_impl -> "ast_impl"
+    | Ast_intf -> "ast_intf"
+
+  let human_description_of_native_obj_config : native_obj_config -> string =
+    fun[@warning "+9"] {flambda} ->
+      if flambda then "flambda" else "non flambda"
+
+  let human_name_of_kind : kind -> string = function
+    | Exec -> "executable"
+    | Cmi -> "compiled interface file"
+    | Cmo -> "bytecode object file"
+    | Cma -> "bytecode library"
+    | Cmx config ->
+       Printf.sprintf "native compilation unit description (%s)"
+         (human_description_of_native_obj_config config)
+    | Cmxa config ->
+       Printf.sprintf "static native library (%s)"
+         (human_description_of_native_obj_config config)
+    | Cmxs -> "dynamic native library"
+    | Cmt -> "compiled typedtree file"
+    | Ast_impl -> "serialized implementation AST"
+    | Ast_intf -> "serialized interface AST"
+
+  let kind_length = 9
+  let version_length = 3
+  let magic_length =
+    kind_length + version_length
+
+  type parse_error =
+    | Truncated of string
+    | Not_a_magic_number of string
+
+  let explain_parse_error kind_opt error =
+       Printf.sprintf
+         "We expected a valid %s, but the file %s."
+         (Option.fold ~none:"object file" ~some:human_name_of_kind kind_opt)
+         (match error with
+            | Truncated "" -> "is empty"
+            | Truncated _ -> "is truncated"
+            | Not_a_magic_number _ -> "has a different format")
+
+  let parse s : (info, parse_error) result =
+    if String.length s = magic_length then begin
+      let raw_kind = String.sub s 0 kind_length in
+      let raw_version = String.sub s kind_length version_length in
+      match parse_kind raw_kind with
+      | None -> Error (Not_a_magic_number s)
+      | Some kind ->
+          begin match int_of_string raw_version with
+          | exception _ -> Error (Truncated s)
+          | version -> Ok { kind; version }
+          end
+    end
+    else begin
+      (* a header is "truncated" if it starts like a valid magic number,
+         that is if its longest segment of length at most [kind_length]
+         is a prefix of [raw_kind kind] for some kind [kind] *)
+      let sub_length = Int.min kind_length (String.length s) in
+      let starts_as kind =
+        String.sub s 0 sub_length = String.sub (raw_kind kind) 0 sub_length
+      in
+      if List.exists starts_as all_kinds then Error (Truncated s)
+      else Error (Not_a_magic_number s)
+    end
+
+  let read_info ic =
+    let header = Buffer.create magic_length in
+    begin
+      try Buffer.add_channel header ic magic_length
+      with End_of_file -> ()
+    end;
+    parse (Buffer.contents header)
+
+  let raw { kind; version; } =
+    Printf.sprintf "%s%03d" (raw_kind kind) version
+
+  let current_raw kind =
+    let open Config in
+    match[@warning "+9"] kind with
+      | Exec -> exec_magic_number
+      | Cmi -> cmi_magic_number
+      | Cmo -> cmo_magic_number
+      | Cma -> cma_magic_number
+      | Cmx config ->
+         (* the 'if' guarantees that in the common case
+            we return the "trusted" value from Config. *)
+         let reference = cmx_magic_number in
+         if config = native_obj_config then reference
+         else
+           (* otherwise we stitch together the magic number
+              for a different configuration by concatenating
+              the right magic kind at this configuration
+              and the rest of the current raw number for our configuration. *)
+           let raw_kind = raw_kind kind in
+           let len = String.length raw_kind in
+           raw_kind ^ String.sub reference len (String.length reference - len)
+      | Cmxa config ->
+         let reference = cmxa_magic_number in
+         if config = native_obj_config then reference
+         else
+           let raw_kind = raw_kind kind in
+           let len = String.length raw_kind in
+           raw_kind ^ String.sub reference len (String.length reference - len)
+      | Cmxs -> cmxs_magic_number
+      | Cmt -> cmt_magic_number
+      | Ast_intf -> ast_intf_magic_number
+      | Ast_impl -> ast_impl_magic_number
+
+  (* it would seem more direct to define current_version with the
+     correct numbers and current_raw on top of it, but for now we
+     consider the Config.foo values to be ground truth, and don't want
+     to trust the present module instead. *)
+  let current_version kind =
+    let raw = current_raw kind in
+    try int_of_string (String.sub raw kind_length version_length)
+    with _ -> assert false
+
+  type 'a unexpected = { expected : 'a; actual : 'a }
+  type unexpected_error =
+    | Kind of kind unexpected
+    | Version of kind * version unexpected
+
+  let explain_unexpected_error = function
+    | Kind { actual; expected } ->
+        Printf.sprintf "We expected a %s (%s) but got a %s (%s) instead."
+          (human_name_of_kind expected) (string_of_kind expected)
+          (human_name_of_kind actual) (string_of_kind actual)
+    | Version (kind, { actual; expected }) ->
+        Printf.sprintf "This seems to be a %s (%s) for %s version of OCaml."
+          (human_name_of_kind kind) (string_of_kind kind)
+          (if actual < expected then "an older" else "a newer")
+
+  let check_current expected_kind { kind; version } : _ result =
+    if kind <> expected_kind then begin
+      let actual, expected = kind, expected_kind in
+      Error (Kind { actual; expected })
+    end else begin
+      let actual, expected = version, current_version kind in
+      if actual <> expected
+      then Error (Version (kind, { actual; expected }))
+      else Ok ()
+    end
+
+  type error =
+    | Parse_error of parse_error
+    | Unexpected_error of unexpected_error
+
+  let read_current_info ~expected_kind ic =
+    match read_info ic with
+      | Error err -> Error (Parse_error err)
+      | Ok info ->
+         let kind = Option.value ~default:info.kind expected_kind in
+         match check_current kind info with
+           | Error err -> Error (Unexpected_error err)
+           | Ok () -> Ok info
+end
diff --git a/upstream/ocaml_413/utils/misc.mli b/upstream/ocaml_413/utils/misc.mli
new file mode 100644
index 0000000..741ebf7
--- /dev/null
+++ b/upstream/ocaml_413/utils/misc.mli
@@ -0,0 +1,667 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Miscellaneous useful types and functions
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+val fatal_error: string -> 'a
+val fatal_errorf: ('a, Format.formatter, unit, 'b) format4 -> 'a
+exception Fatal_error
+
+val try_finally :
+  ?always:(unit -> unit) ->
+  ?exceptionally:(unit -> unit) ->
+  (unit -> 'a) -> 'a
+(** [try_finally work ~always ~exceptionally] is designed to run code
+    in [work] that may fail with an exception, and has two kind of
+    cleanup routines: [always], that must be run after any execution
+    of the function (typically, freeing system resources), and
+    [exceptionally], that should be run only if [work] or [always]
+    failed with an exception (typically, undoing user-visible state
+    changes that would only make sense if the function completes
+    correctly). For example:
+
+    {[
+      let objfile = outputprefix ^ ".cmo" in
+      let oc = open_out_bin objfile in
+      Misc.try_finally
+        (fun () ->
+           bytecode
+           ++ Timings.(accumulate_time (Generate sourcefile))
+               (Emitcode.to_file oc modulename objfile);
+           Warnings.check_fatal ())
+        ~always:(fun () -> close_out oc)
+        ~exceptionally:(fun _exn -> remove_file objfile);
+    ]}
+
+    If [exceptionally] fail with an exception, it is propagated as
+    usual.
+
+    If [always] or [exceptionally] use exceptions internally for
+    control-flow but do not raise, then [try_finally] is careful to
+    preserve any exception backtrace coming from [work] or [always]
+    for easier debugging.
+*)
+
+val reraise_preserving_backtrace : exn -> (unit -> unit) -> 'a
+(** [reraise_preserving_backtrace e f] is (f (); raise e) except that the
+    current backtrace is preserved, even if [f] uses exceptions internally. *)
+
+
+val map_end: ('a -> 'b) -> 'a list -> 'b list -> 'b list
+        (* [map_end f l t] is [map f l @ t], just more efficient. *)
+val map_left_right: ('a -> 'b) -> 'a list -> 'b list
+        (* Like [List.map], with guaranteed left-to-right evaluation order *)
+val for_all2: ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+        (* Same as [List.for_all] but for a binary predicate.
+           In addition, this [for_all2] never fails: given two lists
+           with different lengths, it returns false. *)
+val replicate_list: 'a -> int -> 'a list
+        (* [replicate_list elem n] is the list with [n] elements
+           all identical to [elem]. *)
+val list_remove: 'a -> 'a list -> 'a list
+        (* [list_remove x l] returns a copy of [l] with the first
+           element equal to [x] removed. *)
+val split_last: 'a list -> 'a list * 'a
+        (* Return the last element and the other elements of the given list. *)
+
+type ref_and_value = R : 'a ref * 'a -> ref_and_value
+
+val protect_refs : ref_and_value list -> (unit -> 'a) -> 'a
+(** [protect_refs l f] temporarily sets [r] to [v] for each [R (r, v)] in [l]
+    while executing [f]. The previous contents of the references is restored
+    even if [f] raises an exception, without altering the exception backtrace.
+*)
+
+module Stdlib : sig
+  module List : sig
+    type 'a t = 'a list
+
+    val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
+    (** The lexicographic order supported by the provided order.
+        There is no constraint on the relative lengths of the lists. *)
+
+    val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+    (** Returns [true] if and only if the given lists have the same length and
+        content with respect to the given equality function. *)
+
+    val some_if_all_elements_are_some : 'a option t -> 'a t option
+    (** If all elements of the given list are [Some _] then [Some xs]
+        is returned with the [xs] being the contents of those [Some]s, with
+        order preserved.  Otherwise return [None]. *)
+
+    val map2_prefix : ('a -> 'b -> 'c) -> 'a t -> 'b t -> ('c t * 'b t)
+    (** [let r1, r2 = map2_prefix f l1 l2]
+        If [l1] is of length n and [l2 = h2 @ t2] with h2 of length n,
+        r1 is [List.map2 f l1 h1] and r2 is t2. *)
+
+    val split_at : int -> 'a t -> 'a t * 'a t
+    (** [split_at n l] returns the pair [before, after] where [before] is
+        the [n] first elements of [l] and [after] the remaining ones.
+        If [l] has less than [n] elements, raises Invalid_argument. *)
+
+    val is_prefix
+       : equal:('a -> 'a -> bool)
+      -> 'a list
+      -> of_:'a list
+      -> bool
+    (** Returns [true] if and only if the given list, with respect to the given
+        equality function on list members, is a prefix of the list [of_]. *)
+
+    type 'a longest_common_prefix_result = private {
+      longest_common_prefix : 'a list;
+      first_without_longest_common_prefix : 'a list;
+      second_without_longest_common_prefix : 'a list;
+    }
+
+    val find_and_chop_longest_common_prefix
+       : equal:('a -> 'a -> bool)
+      -> first:'a list
+      -> second:'a list
+      -> 'a longest_common_prefix_result
+    (** Returns the longest list that, with respect to the provided equality
+        function, is a prefix of both of the given lists.  The input lists,
+        each with such longest common prefix removed, are also returned. *)
+  end
+
+  module Option : sig
+    type 'a t = 'a option
+
+    val print
+       : (Format.formatter -> 'a -> unit)
+      -> Format.formatter
+      -> 'a t
+      -> unit
+  end
+
+  module Array : sig
+    val exists2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
+    (* Same as [Array.exists], but for a two-argument predicate. Raise
+       Invalid_argument if the two arrays are determined to have
+       different lengths. *)
+
+    val for_alli : (int -> 'a -> bool) -> 'a array -> bool
+    (** Same as {!Array.for_all}, but the
+        function is applied with the index of the element as first argument,
+        and the element itself as second argument. *)
+
+    val all_somes : 'a option array -> 'a array option
+  end
+
+  module String : sig
+    include module type of String
+    module Set : Set.S with type elt = string
+    module Map : Map.S with type key = string
+    module Tbl : Hashtbl.S with type key = string
+
+    val print : Format.formatter -> t -> unit
+
+    val for_all : (char -> bool) -> t -> bool
+  end
+
+  external compare : 'a -> 'a -> int = "%compare"
+end
+
+val find_in_path: string list -> string -> string
+        (* Search a file in a list of directories. *)
+val find_in_path_rel: string list -> string -> string
+        (* Search a relative file in a list of directories. *)
+val find_in_path_uncap: string list -> string -> string
+        (* Same, but search also for uncapitalized name, i.e.
+           if name is Foo.ml, allow /path/Foo.ml and /path/foo.ml
+           to match. *)
+val remove_file: string -> unit
+        (* Delete the given file if it exists. Never raise an error. *)
+val expand_directory: string -> string -> string
+        (* [expand_directory alt file] eventually expands a [+] at the
+           beginning of file into [alt] (an alternate root directory) *)
+
+val split_path_contents: ?sep:char -> string -> string list
+(* [split_path_contents ?sep s] interprets [s] as the value of a "PATH"-like
+   variable and returns the corresponding list of directories. [s] is split
+   using the platform-specific delimiter, or [~sep] if it is passed.
+
+   Returns the empty list if [s] is empty. *)
+
+val create_hashtable: int -> ('a * 'b) list -> ('a, 'b) Hashtbl.t
+        (* Create a hashtable of the given size and fills it with the
+           given bindings. *)
+
+val copy_file: in_channel -> out_channel -> unit
+        (* [copy_file ic oc] reads the contents of file [ic] and copies
+           them to [oc]. It stops when encountering EOF on [ic]. *)
+val copy_file_chunk: in_channel -> out_channel -> int -> unit
+        (* [copy_file_chunk ic oc n] reads [n] bytes from [ic] and copies
+           them to [oc]. It raises [End_of_file] when encountering
+           EOF on [ic]. *)
+val string_of_file: in_channel -> string
+        (* [string_of_file ic] reads the contents of file [ic] and copies
+           them to a string. It stops when encountering EOF on [ic]. *)
+val output_to_file_via_temporary:
+      ?mode:open_flag list -> string -> (string -> out_channel -> 'a) -> 'a
+        (* Produce output in temporary file, then rename it
+           (as atomically as possible) to the desired output file name.
+           [output_to_file_via_temporary filename fn] opens a temporary file
+           which is passed to [fn] (name + output channel).  When [fn] returns,
+           the channel is closed and the temporary file is renamed to
+           [filename]. *)
+
+(** Open the given [filename] for writing (in binary mode), pass the
+    [out_channel] to the given function, then close the channel. If the function
+    raises an exception then [filename] will be removed. *)
+val protect_writing_to_file
+   : filename:string
+  -> f:(out_channel -> 'a)
+  -> 'a
+
+val log2: int -> int
+        (* [log2 n] returns [s] such that [n = 1 lsl s]
+           if [n] is a power of 2*)
+val align: int -> int -> int
+        (* [align n a] rounds [n] upwards to a multiple of [a]
+           (a power of 2). *)
+val no_overflow_add: int -> int -> bool
+        (* [no_overflow_add n1 n2] returns [true] if the computation of
+           [n1 + n2] does not overflow. *)
+val no_overflow_sub: int -> int -> bool
+        (* [no_overflow_sub n1 n2] returns [true] if the computation of
+           [n1 - n2] does not overflow. *)
+val no_overflow_mul: int -> int -> bool
+        (* [no_overflow_mul n1 n2] returns [true] if the computation of
+           [n1 * n2] does not overflow. *)
+val no_overflow_lsl: int -> int -> bool
+        (* [no_overflow_lsl n k] returns [true] if the computation of
+           [n lsl k] does not overflow. *)
+
+module Int_literal_converter : sig
+  val int : string -> int
+  val int32 : string -> int32
+  val int64 : string -> int64
+  val nativeint : string -> nativeint
+end
+
+val chop_extensions: string -> string
+        (* Return the given file name without its extensions. The extensions
+           is the longest suffix starting with a period and not including
+           a directory separator, [.xyz.uvw] for instance.
+
+           Return the given name if it does not contain an extension. *)
+
+val search_substring: string -> string -> int -> int
+        (* [search_substring pat str start] returns the position of the first
+           occurrence of string [pat] in string [str].  Search starts
+           at offset [start] in [str].  Raise [Not_found] if [pat]
+           does not occur. *)
+
+val replace_substring: before:string -> after:string -> string -> string
+        (* [replace_substring ~before ~after str] replaces all
+           occurrences of [before] with [after] in [str] and returns
+           the resulting string. *)
+
+val rev_split_words: string -> string list
+        (* [rev_split_words s] splits [s] in blank-separated words, and returns
+           the list of words in reverse order. *)
+
+val get_ref: 'a list ref -> 'a list
+        (* [get_ref lr] returns the content of the list reference [lr] and reset
+           its content to the empty list. *)
+
+val set_or_ignore : ('a -> 'b option) -> 'b option ref -> 'a -> unit
+        (* [set_or_ignore f opt x] sets [opt] to [f x] if it returns [Some _],
+           or leaves it unmodified if it returns [None]. *)
+
+val fst3: 'a * 'b * 'c -> 'a
+val snd3: 'a * 'b * 'c -> 'b
+val thd3: 'a * 'b * 'c -> 'c
+
+val fst4: 'a * 'b * 'c * 'd -> 'a
+val snd4: 'a * 'b * 'c * 'd -> 'b
+val thd4: 'a * 'b * 'c * 'd -> 'c
+val for4: 'a * 'b * 'c * 'd -> 'd
+
+module LongString :
+  sig
+    type t = bytes array
+    val create : int -> t
+    val length : t -> int
+    val get : t -> int -> char
+    val set : t -> int -> char -> unit
+    val blit : t -> int -> t -> int -> int -> unit
+    val blit_string : string -> int -> t -> int -> int -> unit
+    val output : out_channel -> t -> int -> int -> unit
+    val input_bytes_into : t -> in_channel -> int -> unit
+    val input_bytes : in_channel -> int -> t
+  end
+
+val edit_distance : string -> string -> int -> int option
+(** [edit_distance a b cutoff] computes the edit distance between
+    strings [a] and [b]. To help efficiency, it uses a cutoff: if the
+    distance [d] is smaller than [cutoff], it returns [Some d], else
+    [None].
+
+    The distance algorithm currently used is Damerau-Levenshtein: it
+    computes the number of insertion, deletion, substitution of
+    letters, or swapping of adjacent letters to go from one word to the
+    other. The particular algorithm may change in the future.
+*)
+
+val spellcheck : string list -> string -> string list
+(** [spellcheck env name] takes a list of names [env] that exist in
+    the current environment and an erroneous [name], and returns a
+    list of suggestions taken from [env], that are close enough to
+    [name] that it may be a typo for one of them. *)
+
+val did_you_mean : Format.formatter -> (unit -> string list) -> unit
+(** [did_you_mean ppf get_choices] hints that the user may have meant
+    one of the option returned by calling [get_choices]. It does nothing
+    if the returned list is empty.
+
+    The [unit -> ...] thunking is meant to delay any potentially-slow
+    computation (typically computing edit-distance with many things
+    from the current environment) to when the hint message is to be
+    printed. You should print an understandable error message before
+    calling [did_you_mean], so that users get a clear notification of
+    the failure even if producing the hint is slow.
+*)
+
+val cut_at : string -> char -> string * string
+(** [String.cut_at s c] returns a pair containing the sub-string before
+   the first occurrence of [c] in [s], and the sub-string after the
+   first occurrence of [c] in [s].
+   [let (before, after) = String.cut_at s c in
+    before ^ String.make 1 c ^ after] is the identity if [s] contains [c].
+
+   Raise [Not_found] if the character does not appear in the string
+   @since 4.01
+*)
+
+(* Color handling *)
+module Color : sig
+  type color =
+    | Black
+    | Red
+    | Green
+    | Yellow
+    | Blue
+    | Magenta
+    | Cyan
+    | White
+  ;;
+
+  type style =
+    | FG of color (* foreground *)
+    | BG of color (* background *)
+    | Bold
+    | Reset
+
+  type Format.stag += Style of style list
+
+  val ansi_of_style_l : style list -> string
+  (* ANSI escape sequence for the given style *)
+
+  type styles = {
+    error: style list;
+    warning: style list;
+    loc: style list;
+  }
+
+  val default_styles: styles
+  val get_styles: unit -> styles
+  val set_styles: styles -> unit
+
+  type setting = Auto | Always | Never
+
+  val default_setting : setting
+
+  val setup : setting option -> unit
+  (* [setup opt] will enable or disable color handling on standard formatters
+     according to the value of color setting [opt].
+     Only the first call to this function has an effect. *)
+
+  val set_color_tag_handling : Format.formatter -> unit
+  (* adds functions to support color tags to the given formatter. *)
+end
+
+(* See the -error-style option *)
+module Error_style : sig
+  type setting =
+    | Contextual
+    | Short
+
+  val default_setting : setting
+end
+
+val normalise_eol : string -> string
+(** [normalise_eol s] returns a fresh copy of [s] with any '\r' characters
+   removed. Intended for pre-processing text which will subsequently be printed
+   on a channel which performs EOL transformations (i.e. Windows) *)
+
+val delete_eol_spaces : string -> string
+(** [delete_eol_spaces s] returns a fresh copy of [s] with any end of
+   line spaces removed. Intended to normalize the output of the
+   toplevel for tests. *)
+
+val pp_two_columns :
+  ?sep:string -> ?max_lines:int ->
+  Format.formatter -> (string * string) list -> unit
+(** [pp_two_columns ?sep ?max_lines ppf l] prints the lines in [l] as two
+   columns separated by [sep] ("|" by default). [max_lines] can be used to
+   indicate a maximum number of lines to print -- an ellipsis gets inserted at
+   the middle if the input has too many lines.
+
+   Example:
+
+    {v pp_two_columns ~max_lines:3 Format.std_formatter [
+      "abc", "hello";
+      "def", "zzz";
+      "a"  , "bllbl";
+      "bb" , "dddddd";
+    ] v}
+
+    prints
+
+    {v
+    abc | hello
+    ...
+    bb  | dddddd
+    v}
+*)
+
+(** configuration variables *)
+val show_config_and_exit : unit -> unit
+val show_config_variable_and_exit : string -> unit
+
+val get_build_path_prefix_map: unit -> Build_path_prefix_map.map option
+(** Returns the map encoded in the [BUILD_PATH_PREFIX_MAP] environment
+    variable. *)
+
+val debug_prefix_map_flags: unit -> string list
+(** Returns the list of [--debug-prefix-map] flags to be passed to the
+    assembler, built from the [BUILD_PATH_PREFIX_MAP] environment variable. *)
+
+val print_if :
+  Format.formatter -> bool ref -> (Format.formatter -> 'a -> unit) -> 'a -> 'a
+(** [print_if ppf flag fmt x] prints [x] with [fmt] on [ppf] if [b] is true. *)
+
+
+type filepath = string
+type modname = string
+type crcs = (modname * Digest.t option) list
+
+type alerts = string Stdlib.String.Map.t
+
+
+module Magic_number : sig
+  (** a typical magic number is "Caml1999I011"; it is formed of an
+      alphanumeric prefix, here Caml1990I, followed by a version,
+      here 011. The prefix identifies the kind of the versioned data:
+      here the I indicates that it is the magic number for .cmi files.
+
+      All magic numbers have the same byte length, [magic_length], and
+      this is important for users as it gives them the number of bytes
+      to read to obtain the byte sequence that should be a magic
+      number. Typical user code will look like:
+      {[
+        let ic = open_in_bin path in
+        let magic =
+          try really_input_string ic Magic_number.magic_length
+          with End_of_file -> ... in
+        match Magic_number.parse magic with
+        | Error parse_error -> ...
+        | Ok info -> ...
+      ]}
+
+      A given compiler version expects one specific version for each
+      kind of object file, and will fail if given an unsupported
+      version. Because versions grow monotonically, you can compare
+      the parsed version with the expected "current version" for
+      a kind, to tell whether the wrong-magic object file comes from
+      the past or from the future.
+
+      An example of code block that expects the "currently supported version"
+      of a given kind of magic numbers, here [Cmxa], is as follows:
+      {[
+        let ic = open_in_bin path in
+        begin
+          try Magic_number.(expect_current Cmxa (get_info ic)) with
+          | Parse_error error -> ...
+          | Unexpected error -> ...
+        end;
+        ...
+      ]}
+
+      Parse errors distinguish inputs that are [Not_a_magic_number str],
+      which are likely to come from the file being completely
+      different, and [Truncated str], raised by headers that are the
+      (possibly empty) prefix of a valid magic number.
+
+      Unexpected errors correspond to valid magic numbers that are not
+      the one expected, either because it corresponds to a different
+      kind, or to a newer or older version.
+
+      The helper functions [explain_parse_error] and [explain_unexpected_error]
+      will generate a textual explanation of each error,
+      for use in error messages.
+
+      @since 4.11.0
+  *)
+
+  type native_obj_config = {
+    flambda : bool;
+  }
+  (** native object files have a format and magic number that depend
+     on certain native-compiler configuration parameters. This
+     configuration space is expressed by the [native_obj_config]
+     type. *)
+
+  val native_obj_config : native_obj_config
+  (** the native object file configuration of the active/configured compiler. *)
+
+  type version = int
+
+  type kind =
+    | Exec
+    | Cmi | Cmo | Cma
+    | Cmx of native_obj_config | Cmxa of native_obj_config
+    | Cmxs
+    | Cmt | Ast_impl | Ast_intf
+
+  type info = {
+    kind: kind;
+    version: version;
+    (** Note: some versions of the compiler use the same [version] suffix
+        for all kinds, but others use different versions counters for different
+        kinds. We may only assume that versions are growing monotonically
+        (not necessarily always by one) between compiler versions. *)
+  }
+
+  type raw = string
+  (** the type of raw magic numbers,
+      such as "Caml1999A027" for the .cma files of OCaml 4.10 *)
+
+  (** {3 Parsing magic numbers} *)
+
+  type parse_error =
+    | Truncated of string
+    | Not_a_magic_number of string
+
+  val explain_parse_error : kind option -> parse_error -> string
+  (** Produces an explanation for a parse error. If no kind is provided,
+      we use an unspecific formulation suggesting that any compiler-produced
+      object file would have been satisfying. *)
+
+  val parse : raw -> (info, parse_error) result
+  (** Parses a raw magic number *)
+
+  val read_info : in_channel -> (info, parse_error) result
+  (** Read a raw magic number from an input channel.
+
+      If the data read [str] is not a valid magic number, it can be
+      recovered from the [Truncated str | Not_a_magic_number str]
+      payload of the [Error parse_error] case.
+
+      If parsing succeeds with an [Ok info] result, we know that
+      exactly [magic_length] bytes have been consumed from the
+      input_channel.
+
+      If you also wish to enforce that the magic number
+      is at the current version, see {!read_current_info} below.
+   *)
+
+  val magic_length : int
+  (** all magic numbers take the same number of bytes *)
+
+
+  (** {3 Checking that magic numbers are current} *)
+
+  type 'a unexpected = { expected : 'a; actual : 'a }
+  type unexpected_error =
+    | Kind of kind unexpected
+    | Version of kind * version unexpected
+
+  val check_current : kind -> info -> (unit, unexpected_error) result
+  (** [check_current kind info] checks that the provided magic [info]
+      is the current version of [kind]'s magic header. *)
+
+  val explain_unexpected_error : unexpected_error -> string
+  (** Provides an explanation of the [unexpected_error]. *)
+
+  type error =
+    | Parse_error of parse_error
+    | Unexpected_error of unexpected_error
+
+  val read_current_info :
+    expected_kind:kind option -> in_channel -> (info, error) result
+  (** Read a magic number as [read_info],
+      and check that it is the current version as its kind.
+      If the [expected_kind] argument is [None], any kind is accepted. *)
+
+
+  (** {3 Information on magic numbers} *)
+
+  val string_of_kind : kind -> string
+  (** a user-printable string for a kind, eg. "exec" or "cmo", to use
+      in error messages. *)
+
+  val human_name_of_kind : kind -> string
+  (** a user-meaningful name for a kind, eg. "executable file" or
+      "bytecode object file", to use in error messages. *)
+
+  val current_raw : kind -> raw
+  (** the current magic number of each kind *)
+
+  val current_version : kind -> version
+  (** the current version of each kind *)
+
+
+  (** {3 Raw representations}
+
+      Mainly for internal usage and testing. *)
+
+  type raw_kind = string
+  (** the type of raw magic numbers kinds,
+      such as "Caml1999A" for .cma files *)
+
+  val parse_kind : raw_kind -> kind option
+  (** parse a raw kind into a kind *)
+
+  val raw_kind : kind -> raw_kind
+  (** the current raw representation of a kind.
+
+      In some cases the raw representation of a kind has changed
+      over compiler versions, so other files of the same kind
+      may have different raw kinds.
+      Note that all currently known cases are parsed correctly by [parse_kind].
+  *)
+
+  val raw : info -> raw
+  (** A valid raw representation of the magic number.
+
+      Due to past and future changes in the string representation of
+      magic numbers, we cannot guarantee that the raw strings returned
+      for past and future versions actually match the expectations of
+      those compilers. The representation is accurate for current
+      versions, and it is correctly parsed back into the desired
+      version by the parsing functions above.
+   *)
+
+  (**/**)
+
+  val all_kinds : kind list
+end
diff --git a/upstream/ocaml_413/utils/numbers.ml b/upstream/ocaml_413/utils/numbers.ml
new file mode 100644
index 0000000..1680675
--- /dev/null
+++ b/upstream/ocaml_413/utils/numbers.ml
@@ -0,0 +1,88 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Int_base = Identifiable.Make (struct
+  type t = int
+
+  let compare x y = x - y
+  let output oc x = Printf.fprintf oc "%i" x
+  let hash i = i
+  let equal (i : int) j = i = j
+  let print = Format.pp_print_int
+end)
+
+module Int = struct
+  type t = int
+
+  include Int_base
+
+  let rec zero_to_n n =
+    if n < 0 then Set.empty else Set.add n (zero_to_n (n-1))
+
+  let to_string n = Int.to_string n
+end
+
+module Int8 = struct
+  type t = int
+
+  let zero = 0
+  let one = 1
+
+  let of_int_exn i =
+    if i < -(1 lsl 7) || i > ((1 lsl 7) - 1) then
+      Misc.fatal_errorf "Int8.of_int_exn: %d is out of range" i
+    else
+      i
+
+  let to_int i = i
+end
+
+module Int16 = struct
+  type t = int
+
+  let of_int_exn i =
+    if i < -(1 lsl 15) || i > ((1 lsl 15) - 1) then
+      Misc.fatal_errorf "Int16.of_int_exn: %d is out of range" i
+    else
+      i
+
+  let lower_int64 = Int64.neg (Int64.shift_left Int64.one 15)
+  let upper_int64 = Int64.sub (Int64.shift_left Int64.one 15) Int64.one
+
+  let of_int64_exn i =
+    if Int64.compare i lower_int64 < 0
+        || Int64.compare i upper_int64 > 0
+    then
+      Misc.fatal_errorf "Int16.of_int64_exn: %Ld is out of range" i
+    else
+      Int64.to_int i
+
+  let to_int t = t
+end
+
+module Float = struct
+  type t = float
+
+  include Identifiable.Make (struct
+    type t = float
+
+    let compare x y = Stdlib.compare x y
+    let output oc x = Printf.fprintf oc "%f" x
+    let hash f = Hashtbl.hash f
+    let equal (i : float) j = i = j
+    let print = Format.pp_print_float
+  end)
+end
diff --git a/upstream/ocaml_413/utils/numbers.mli b/upstream/ocaml_413/utils/numbers.mli
new file mode 100644
index 0000000..fa565e6
--- /dev/null
+++ b/upstream/ocaml_413/utils/numbers.mli
@@ -0,0 +1,51 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Modules about numbers, some of which satisfy {!Identifiable.S}.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+module Int : sig
+  include Identifiable.S with type t = int
+
+  (** [zero_to_n n] is the set of numbers \{0, ..., n\} (inclusive). *)
+  val zero_to_n : int -> Set.t
+  val to_string : int -> string
+end
+
+module Int8 : sig
+  type t
+
+  val zero : t
+  val one : t
+
+  val of_int_exn : int -> t
+  val to_int : t -> int
+end
+
+module Int16 : sig
+  type t
+
+  val of_int_exn : int -> t
+  val of_int64_exn : Int64.t -> t
+
+  val to_int : t -> int
+end
+
+module Float : Identifiable.S with type t = float
diff --git a/upstream/ocaml_413/utils/profile.ml b/upstream/ocaml_413/utils/profile.ml
new file mode 100644
index 0000000..27c92a5
--- /dev/null
+++ b/upstream/ocaml_413/utils/profile.ml
@@ -0,0 +1,335 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Pierre Chambart, OCamlPro                         *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-18-40-42-48"]
+
+type file = string
+
+external time_include_children: bool -> float = "caml_sys_time_include_children"
+let cpu_time () = time_include_children true
+
+module Measure = struct
+  type t = {
+    time : float;
+    allocated_words : float;
+    top_heap_words : int;
+  }
+  let create () =
+    let stat = Gc.quick_stat () in
+    {
+      time = cpu_time ();
+      allocated_words = stat.minor_words +. stat.major_words;
+      top_heap_words = stat.top_heap_words;
+    }
+  let zero = { time = 0.; allocated_words = 0.; top_heap_words = 0 }
+end
+
+module Measure_diff = struct
+  let timestamp = let r = ref (-1) in fun () -> incr r; !r
+  type t = {
+    timestamp : int;
+    duration : float;
+    allocated_words : float;
+    top_heap_words_increase : int;
+  }
+  let zero () = {
+    timestamp = timestamp ();
+    duration = 0.;
+    allocated_words = 0.;
+    top_heap_words_increase = 0;
+  }
+  let accumulate t (m1 : Measure.t) (m2 : Measure.t) = {
+    timestamp = t.timestamp;
+    duration = t.duration +. (m2.time -. m1.time);
+    allocated_words =
+      t.allocated_words +. (m2.allocated_words -. m1.allocated_words);
+    top_heap_words_increase =
+      t.top_heap_words_increase + (m2.top_heap_words - m1.top_heap_words);
+  }
+  let of_diff m1 m2 =
+    accumulate (zero ()) m1 m2
+end
+
+type hierarchy =
+  | E of (string, Measure_diff.t * hierarchy) Hashtbl.t
+[@@unboxed]
+
+let create () = E (Hashtbl.create 2)
+let hierarchy = ref (create ())
+let initial_measure = ref None
+let reset () = hierarchy := create (); initial_measure := None
+
+let record_call ?(accumulate = false) name f =
+  let E prev_hierarchy = !hierarchy in
+  let start_measure = Measure.create () in
+  if !initial_measure = None then initial_measure := Some start_measure;
+  let this_measure_diff, this_table =
+    (* We allow the recording of multiple categories by the same name, for tools
+       like ocamldoc that use the compiler libs but don't care about profile
+       information, and so may record, say, "parsing" multiple times. *)
+    if accumulate
+    then
+      match Hashtbl.find prev_hierarchy name with
+      | exception Not_found -> Measure_diff.zero (), Hashtbl.create 2
+      | measure_diff, E table ->
+        Hashtbl.remove prev_hierarchy name;
+        measure_diff, table
+    else Measure_diff.zero (), Hashtbl.create 2
+  in
+  hierarchy := E this_table;
+  Misc.try_finally f
+    ~always:(fun () ->
+        hierarchy := E prev_hierarchy;
+        let end_measure = Measure.create () in
+        let measure_diff =
+          Measure_diff.accumulate this_measure_diff start_measure end_measure in
+        Hashtbl.add prev_hierarchy name (measure_diff, E this_table))
+
+let record ?accumulate pass f x = record_call ?accumulate pass (fun () -> f x)
+
+type display = {
+  to_string : max:float -> width:int -> string;
+  worth_displaying : max:float -> bool;
+}
+
+let time_display v : display =
+  (* Because indentation is meaningful, and because the durations are
+     the first element of each row, we can't pad them with spaces. *)
+  let to_string_without_unit v ~width = Printf.sprintf "%0*.03f" width v in
+  let to_string ~max:_ ~width =
+    to_string_without_unit v ~width:(width - 1) ^ "s" in
+  let worth_displaying ~max:_ =
+    float_of_string (to_string_without_unit v ~width:0) <> 0. in
+  { to_string; worth_displaying }
+
+let memory_word_display =
+  (* To make memory numbers easily comparable across rows, we choose a single
+     scale for an entire column. To keep the display compact and not overly
+     precise (no one cares about the exact number of bytes), we pick the largest
+     scale we can and we only show 3 digits. Avoiding showing tiny numbers also
+     allows us to avoid displaying passes that barely allocate compared to the
+     rest of the compiler.  *)
+  let bytes_of_words words = words *. float_of_int (Sys.word_size / 8) in
+  let to_string_without_unit v ~width scale =
+    let precision = 3 and precision_power = 1e3 in
+    let v_rescaled = bytes_of_words v /. scale in
+    let v_rounded =
+      floor (v_rescaled *. precision_power +. 0.5) /. precision_power in
+    let v_str = Printf.sprintf "%.*f" precision v_rounded in
+    let index_of_dot = String.index v_str '.' in
+    let v_str_truncated =
+      String.sub v_str 0
+        (if index_of_dot >= precision
+         then index_of_dot
+         else precision + 1)
+    in
+    Printf.sprintf "%*s" width v_str_truncated
+  in
+  let choose_memory_scale =
+    let units = [|"B"; "kB"; "MB"; "GB"|] in
+    fun words ->
+      let bytes = bytes_of_words words in
+      let scale = ref (Array.length units - 1) in
+      while !scale > 0 && bytes < 1024. ** float_of_int !scale do
+        decr scale
+      done;
+      1024. ** float_of_int !scale, units.(!scale)
+  in
+  fun ?previous v : display ->
+    let to_string ~max ~width =
+      let scale, scale_str = choose_memory_scale max in
+      let width = width - String.length scale_str in
+      to_string_without_unit v ~width scale ^ scale_str
+    in
+    let worth_displaying ~max =
+      let scale, _ = choose_memory_scale max in
+      float_of_string (to_string_without_unit v ~width:0 scale) <> 0.
+      && match previous with
+      | None -> true
+      | Some p ->
+         (* This branch is for numbers that represent absolute quantity, rather
+            than differences. It allows us to skip displaying the same absolute
+            quantity many times in a row. *)
+         to_string_without_unit p ~width:0 scale
+         <> to_string_without_unit v ~width:0 scale
+    in
+    { to_string; worth_displaying }
+
+let profile_list (E table) =
+  let l = Hashtbl.fold (fun k d l -> (k, d) :: l) table [] in
+  List.sort (fun (_, (p1, _)) (_, (p2, _)) ->
+    compare p1.Measure_diff.timestamp p2.Measure_diff.timestamp) l
+
+let compute_other_category (E table : hierarchy) (total : Measure_diff.t) =
+  let r = ref total in
+  Hashtbl.iter (fun _pass ((p2 : Measure_diff.t), _) ->
+    let p1 = !r in
+    r := {
+      timestamp = p1.timestamp;
+      duration = p1.duration -. p2.duration;
+      allocated_words = p1.allocated_words -. p2.allocated_words;
+      top_heap_words_increase =
+        p1.top_heap_words_increase - p2.top_heap_words_increase;
+    }
+  ) table;
+  !r
+
+type row = R of string * (float * display) list * row list
+type column = [ `Time | `Alloc | `Top_heap | `Abs_top_heap ]
+
+let rec rows_of_hierarchy ~nesting make_row name measure_diff hierarchy env =
+  let rows =
+    rows_of_hierarchy_list
+      ~nesting:(nesting + 1) make_row hierarchy measure_diff env in
+  let values, env =
+    make_row env measure_diff ~toplevel_other:(nesting = 0 && name = "other") in
+  R (name, values, rows), env
+
+and rows_of_hierarchy_list ~nesting make_row hierarchy total env =
+  let list = profile_list hierarchy in
+  let list =
+    if list <> [] || nesting = 0
+    then list @ [ "other", (compute_other_category hierarchy total, create ()) ]
+    else []
+  in
+  let env = ref env in
+  List.map (fun (name, (measure_diff, hierarchy)) ->
+    let a, env' =
+      rows_of_hierarchy ~nesting make_row name measure_diff hierarchy !env in
+    env := env';
+    a
+  ) list
+
+let rows_of_hierarchy hierarchy measure_diff initial_measure columns =
+  (* Computing top heap size is a bit complicated: if the compiler applies a
+     list of passes n times (rather than applying pass1 n times, then pass2 n
+     times etc), we only show one row for that pass but what does "top heap
+     size at the end of that pass" even mean?
+     It seems the only sensible answer is to pretend the compiler applied pass1
+     n times, pass2 n times by accumulating all the heap size increases that
+     happened during each pass, and then compute what the heap size would have
+     been. So that's what we do.
+     There's a bit of extra complication, which is that the heap can increase in
+     between measurements. So the heap sizes can be a bit off until the "other"
+     rows account for what's missing. We special case the toplevel "other" row
+     so that any increases that happened before the start of the compilation is
+     correctly reported, as a lot of code may run before the start of the
+     compilation (eg functor applications). *)
+    let make_row prev_top_heap_words (p : Measure_diff.t) ~toplevel_other =
+      let top_heap_words =
+        prev_top_heap_words
+        + p.top_heap_words_increase
+        - if toplevel_other
+          then initial_measure.Measure.top_heap_words
+          else 0
+      in
+      let make value ~f = value, f value in
+      List.map (function
+        | `Time ->
+          make p.duration ~f:time_display
+        | `Alloc ->
+          make p.allocated_words ~f:memory_word_display
+        | `Top_heap ->
+          make (float_of_int p.top_heap_words_increase) ~f:memory_word_display
+        | `Abs_top_heap ->
+          make (float_of_int top_heap_words)
+           ~f:(memory_word_display ~previous:(float_of_int prev_top_heap_words))
+      ) columns,
+      top_heap_words
+  in
+  rows_of_hierarchy_list ~nesting:0 make_row hierarchy measure_diff
+    initial_measure.top_heap_words
+
+let max_by_column ~n_columns rows =
+  let a = Array.make n_columns 0. in
+  let rec loop (R (_, values, rows)) =
+    List.iteri (fun i (v, _) -> a.(i) <- Float.max a.(i) v) values;
+    List.iter loop rows
+  in
+  List.iter loop rows;
+  a
+
+let width_by_column ~n_columns ~display_cell rows =
+  let a = Array.make n_columns 1 in
+  let rec loop (R (_, values, rows)) =
+    List.iteri (fun i cell ->
+      let _, str = display_cell i cell ~width:0 in
+      a.(i) <- Int.max a.(i) (String.length str)
+    ) values;
+    List.iter loop rows;
+  in
+  List.iter loop rows;
+  a
+
+let display_rows ppf rows =
+  let n_columns =
+    match rows with
+    | [] -> 0
+    | R (_, values, _) :: _ -> List.length values
+  in
+  let maxs = max_by_column ~n_columns rows in
+  let display_cell i (_, c) ~width =
+    let display_cell = c.worth_displaying ~max:maxs.(i) in
+    display_cell, if display_cell
+                  then c.to_string ~max:maxs.(i) ~width
+                  else String.make width '-'
+  in
+  let widths = width_by_column ~n_columns ~display_cell rows in
+  let rec loop (R (name, values, rows)) ~indentation =
+    let worth_displaying, cell_strings =
+      values
+      |> List.mapi (fun i cell -> display_cell i cell ~width:widths.(i))
+      |> List.split
+    in
+    if List.exists (fun b -> b) worth_displaying then
+      Format.fprintf ppf "%s%s %s@\n"
+        indentation (String.concat " " cell_strings) name;
+    List.iter (loop ~indentation:("  " ^ indentation)) rows;
+  in
+  List.iter (loop ~indentation:"") rows
+
+let print ppf columns =
+  match columns with
+  | [] -> ()
+  | _ :: _ ->
+     let initial_measure =
+       match !initial_measure with
+       | Some v -> v
+       | None -> Measure.zero
+     in
+     let total = Measure_diff.of_diff Measure.zero (Measure.create ()) in
+     display_rows ppf
+       (rows_of_hierarchy !hierarchy total initial_measure columns)
+
+let column_mapping = [
+  "time", `Time;
+  "alloc", `Alloc;
+  "top-heap", `Top_heap;
+  "absolute-top-heap", `Abs_top_heap;
+]
+
+let column_names = List.map fst column_mapping
+
+let options_doc =
+  Printf.sprintf
+    " Print performance information for each pass\
+   \n    The columns are: %s."
+    (String.concat " " column_names)
+
+let all_columns = List.map snd column_mapping
+
+let generate = "generate"
+let transl = "transl"
+let typing = "typing"
diff --git a/upstream/ocaml_413/utils/profile.mli b/upstream/ocaml_413/utils/profile.mli
new file mode 100644
index 0000000..7eff695
--- /dev/null
+++ b/upstream/ocaml_413/utils/profile.mli
@@ -0,0 +1,49 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Pierre Chambart, OCamlPro                         *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Compiler performance recording
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type file = string
+
+val reset : unit -> unit
+(** erase all recorded profile information *)
+
+val record_call : ?accumulate:bool -> string -> (unit -> 'a) -> 'a
+(** [record_call pass f] calls [f] and records its profile information. *)
+
+val record : ?accumulate:bool -> string -> ('a -> 'b) -> 'a -> 'b
+(** [record pass f arg] records the profile information of [f arg] *)
+
+type column = [ `Time | `Alloc | `Top_heap | `Abs_top_heap ]
+
+val print : Format.formatter -> column list -> unit
+(** Prints the selected recorded profiling information to the formatter. *)
+
+(** Command line flags *)
+
+val options_doc : string
+val all_columns : column list
+
+(** A few pass names that are needed in several places, and shared to
+    avoid typos. *)
+
+val generate : string
+val transl : string
+val typing : string
diff --git a/upstream/ocaml_413/utils/strongly_connected_components.ml b/upstream/ocaml_413/utils/strongly_connected_components.ml
new file mode 100644
index 0000000..eb1501c
--- /dev/null
+++ b/upstream/ocaml_413/utils/strongly_connected_components.ml
@@ -0,0 +1,195 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Int = Numbers.Int
+
+module Kosaraju : sig
+  type component_graph =
+    { sorted_connected_components : int list array;
+      component_edges : int list array;
+    }
+
+  val component_graph : int list array -> component_graph
+end = struct
+  let transpose graph =
+    let size = Array.length graph in
+    let transposed = Array.make size [] in
+    let add src dst = transposed.(src) <- dst :: transposed.(src) in
+    Array.iteri (fun src dsts -> List.iter (fun dst -> add dst src) dsts)
+      graph;
+    transposed
+
+  let depth_first_order (graph : int list array) : int array =
+    let size = Array.length graph in
+    let marked = Array.make size false in
+    let stack = Array.make size ~-1 in
+    let pos = ref 0 in
+    let push i =
+      stack.(!pos) <- i;
+      incr pos
+    in
+    let rec aux node =
+      if not marked.(node)
+      then begin
+        marked.(node) <- true;
+        List.iter aux graph.(node);
+        push node
+      end
+    in
+    for i = 0 to size - 1 do
+      aux i
+    done;
+    stack
+
+  let mark order graph =
+    let size = Array.length graph in
+    let graph = transpose graph in
+    let marked = Array.make size false in
+    let id = Array.make size ~-1 in
+    let count = ref 0 in
+    let rec aux node =
+      if not marked.(node)
+      then begin
+        marked.(node) <- true;
+        id.(node) <- !count;
+        List.iter aux graph.(node)
+      end
+    in
+    for i = size - 1 downto 0 do
+      let node = order.(i) in
+      if not marked.(node)
+      then begin
+        aux order.(i);
+        incr count
+      end
+    done;
+    id, !count
+
+  let kosaraju graph =
+    let dfo = depth_first_order graph in
+    let components, ncomponents = mark dfo graph in
+    ncomponents, components
+
+  type component_graph =
+    { sorted_connected_components : int list array;
+      component_edges : int list array;
+    }
+
+  let component_graph graph =
+    let ncomponents, components = kosaraju graph in
+    let id_scc = Array.make ncomponents [] in
+    let component_graph = Array.make ncomponents Int.Set.empty in
+    let add_component_dep node set =
+      let node_deps = graph.(node) in
+      List.fold_left (fun set dep -> Int.Set.add components.(dep) set)
+        set node_deps
+    in
+    Array.iteri (fun node component ->
+        id_scc.(component) <- node :: id_scc.(component);
+        component_graph.(component) <-
+          add_component_dep node (component_graph.(component)))
+      components;
+    { sorted_connected_components = id_scc;
+      component_edges = Array.map Int.Set.elements component_graph;
+    }
+end
+
+module type S = sig
+  module Id : Identifiable.S
+
+  type directed_graph = Id.Set.t Id.Map.t
+
+  type component =
+    | Has_loop of Id.t list
+    | No_loop of Id.t
+
+  val connected_components_sorted_from_roots_to_leaf
+     : directed_graph
+    -> component array
+
+  val component_graph : directed_graph -> (component * int list) array
+end
+
+module Make (Id : Identifiable.S) = struct
+  type directed_graph = Id.Set.t Id.Map.t
+
+  type component =
+    | Has_loop of Id.t list
+    | No_loop of Id.t
+
+  (* Ensure that the dependency graph does not have external dependencies. *)
+  (* Note: this function is currently not used. *)
+  let _check dependencies =
+    Id.Map.iter (fun id set ->
+        Id.Set.iter (fun v ->
+            if not (Id.Map.mem v dependencies)
+            then
+              Misc.fatal_errorf "Strongly_connected_components.check: the \
+                  graph has external dependencies (%a -> %a)"
+               Id.print id Id.print v)
+          set)
+      dependencies
+
+  let number graph =
+    let size = Id.Map.cardinal graph in
+    let bindings = Id.Map.bindings graph in
+    let a = Array.of_list bindings in
+    let forth = Array.map fst a in
+    let back =
+      let back = ref Id.Map.empty in
+      for i = 0 to size - 1 do
+        back := Id.Map.add forth.(i) i !back;
+      done;
+      !back
+    in
+    let integer_graph =
+      Array.init size (fun i ->
+        let _, dests = a.(i) in
+        Id.Set.fold (fun dest acc ->
+            let v =
+              try Id.Map.find dest back
+              with Not_found ->
+                Misc.fatal_errorf
+                  "Strongly_connected_components: missing dependency %a"
+                  Id.print dest
+            in
+            v :: acc)
+          dests [])
+    in
+    forth, integer_graph
+
+  let component_graph graph =
+    let forth, integer_graph = number graph in
+    let { Kosaraju. sorted_connected_components;
+          component_edges } =
+      Kosaraju.component_graph integer_graph
+    in
+    Array.mapi (fun component nodes ->
+        match nodes with
+        | [] -> assert false
+        | [node] ->
+          (if List.mem node integer_graph.(node)
+           then Has_loop [forth.(node)]
+           else No_loop forth.(node)),
+            component_edges.(component)
+        | _::_ ->
+          (Has_loop (List.map (fun node -> forth.(node)) nodes)),
+            component_edges.(component))
+      sorted_connected_components
+
+  let connected_components_sorted_from_roots_to_leaf graph =
+    Array.map fst (component_graph graph)
+end
diff --git a/upstream/ocaml_413/utils/strongly_connected_components.mli b/upstream/ocaml_413/utils/strongly_connected_components.mli
new file mode 100644
index 0000000..e700952
--- /dev/null
+++ b/upstream/ocaml_413/utils/strongly_connected_components.mli
@@ -0,0 +1,43 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Kosaraju's algorithm for strongly connected components.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+module type S = sig
+  module Id : Identifiable.S
+
+  type directed_graph = Id.Set.t Id.Map.t
+  (** If (a -> set) belongs to the map, it means that there are edges
+      from [a] to every element of [set].  It is assumed that no edge
+      points to a vertex not represented in the map. *)
+
+  type component =
+    | Has_loop of Id.t list
+    | No_loop of Id.t
+
+  val connected_components_sorted_from_roots_to_leaf
+     : directed_graph
+    -> component array
+
+  val component_graph : directed_graph -> (component * int list) array
+end
+
+module Make (Id : Identifiable.S) : S with module Id := Id
diff --git a/upstream/ocaml_413/utils/targetint.ml b/upstream/ocaml_413/utils/targetint.ml
new file mode 100644
index 0000000..9d15a2f
--- /dev/null
+++ b/upstream/ocaml_413/utils/targetint.ml
@@ -0,0 +1,104 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                        Nicolas Ojeda Bar, LexiFi                       *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type repr =
+  | Int32 of int32
+  | Int64 of int64
+
+module type S = sig
+  type t
+  val zero : t
+  val one : t
+  val minus_one : t
+  val neg : t -> t
+  val add : t -> t -> t
+  val sub : t -> t -> t
+  val mul : t -> t -> t
+  val div : t -> t -> t
+  val unsigned_div : t -> t -> t
+  val rem : t -> t -> t
+  val unsigned_rem : t -> t -> t
+  val succ : t -> t
+  val pred : t -> t
+  val abs : t -> t
+  val max_int : t
+  val min_int : t
+  val logand : t -> t -> t
+  val logor : t -> t -> t
+  val logxor : t -> t -> t
+  val lognot : t -> t
+  val shift_left : t -> int -> t
+  val shift_right : t -> int -> t
+  val shift_right_logical : t -> int -> t
+  val of_int : int -> t
+  val of_int_exn : int -> t
+  val to_int : t -> int
+  val of_float : float -> t
+  val to_float : t -> float
+  val of_int32 : int32 -> t
+  val to_int32 : t -> int32
+  val of_int64 : int64 -> t
+  val to_int64 : t -> int64
+  val of_string : string -> t
+  val to_string : t -> string
+  val compare: t -> t -> int
+  val unsigned_compare : t -> t -> int
+  val equal: t -> t -> bool
+  val repr: t -> repr
+  val print : Format.formatter -> t -> unit
+end
+
+let size = Sys.word_size
+(* Later, this will be set by the configure script
+   in order to support cross-compilation. *)
+
+module Int32 = struct
+  include Int32
+  let of_int_exn =
+    match Sys.word_size with (* size of [int] *)
+    | 32 ->
+        Int32.of_int
+    | 64 ->
+        fun n ->
+          if n < Int32.(to_int min_int) || n > Int32.(to_int max_int) then
+            Misc.fatal_errorf "Targetint.of_int_exn: 0x%x out of range" n
+          else
+            Int32.of_int n
+    | _ ->
+        assert false
+  let of_int32 x = x
+  let to_int32 x = x
+  let of_int64 = Int64.to_int32
+  let to_int64 = Int64.of_int32
+  let repr x = Int32 x
+  let print ppf t = Format.fprintf ppf "%ld" t
+end
+
+module Int64 = struct
+  include Int64
+  let of_int_exn = Int64.of_int
+  let of_int64 x = x
+  let to_int64 x = x
+  let repr x = Int64 x
+  let print ppf t = Format.fprintf ppf "%Ld" t
+end
+
+include (val
+          (match size with
+           | 32 -> (module Int32)
+           | 64 -> (module Int64)
+           | _ -> assert false
+          ) : S)
diff --git a/upstream/ocaml_413/utils/targetint.mli b/upstream/ocaml_413/utils/targetint.mli
new file mode 100644
index 0000000..72d464d
--- /dev/null
+++ b/upstream/ocaml_413/utils/targetint.mli
@@ -0,0 +1,207 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                        Nicolas Ojeda Bar, LexiFi                       *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Target processor-native integers.
+
+   This module provides operations on the type of
+   signed 32-bit integers (on 32-bit target platforms) or
+   signed 64-bit integers (on 64-bit target platforms).
+   This integer type has exactly the same width as that of a
+   pointer type in the C compiler.  All arithmetic operations over
+   are taken modulo 2{^32} or 2{^64} depending
+   on the word size of the target architecture.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type t
+(** The type of target integers. *)
+
+val zero : t
+(** The target integer 0.*)
+
+val one : t
+(** The target integer 1.*)
+
+val minus_one : t
+(** The target integer -1.*)
+
+val neg : t -> t
+(** Unary negation. *)
+
+val add : t -> t -> t
+(** Addition. *)
+
+val sub : t -> t -> t
+(** Subtraction. *)
+
+val mul : t -> t -> t
+(** Multiplication. *)
+
+val div : t -> t -> t
+(** Integer division.  Raise [Division_by_zero] if the second
+   argument is zero.  This division rounds the real quotient of
+   its arguments towards zero, as specified for {!Stdlib.(/)}. *)
+
+val unsigned_div : t -> t -> t
+(** Same as {!div}, except that arguments and result are interpreted as {e
+    unsigned} integers. *)
+
+val rem : t -> t -> t
+(** Integer remainder.  If [y] is not zero, the result
+   of [Targetint.rem x y] satisfies the following properties:
+   [Targetint.zero <= Nativeint.rem x y < Targetint.abs y] and
+   [x = Targetint.add (Targetint.mul (Targetint.div x y) y)
+                      (Targetint.rem x y)].
+   If [y = 0], [Targetint.rem x y] raises [Division_by_zero]. *)
+
+val unsigned_rem : t -> t -> t
+(** Same as {!rem}, except that arguments and result are interpreted as {e
+    unsigned} integers. *)
+
+val succ : t -> t
+(** Successor.
+   [Targetint.succ x] is [Targetint.add x Targetint.one]. *)
+
+val pred : t -> t
+(** Predecessor.
+   [Targetint.pred x] is [Targetint.sub x Targetint.one]. *)
+
+val abs : t -> t
+(** Return the absolute value of its argument. *)
+
+val size : int
+(** The size in bits of a target native integer. *)
+
+val max_int : t
+(** The greatest representable target integer,
+    either 2{^31} - 1 on a 32-bit platform,
+    or 2{^63} - 1 on a 64-bit platform. *)
+
+val min_int : t
+(** The smallest representable target integer,
+   either -2{^31} on a 32-bit platform,
+   or -2{^63} on a 64-bit platform. *)
+
+val logand : t -> t -> t
+(** Bitwise logical and. *)
+
+val logor : t -> t -> t
+(** Bitwise logical or. *)
+
+val logxor : t -> t -> t
+(** Bitwise logical exclusive or. *)
+
+val lognot : t -> t
+(** Bitwise logical negation. *)
+
+val shift_left : t -> int -> t
+(** [Targetint.shift_left x y] shifts [x] to the left by [y] bits.
+    The result is unspecified if [y < 0] or [y >= bitsize],
+    where [bitsize] is [32] on a 32-bit platform and
+    [64] on a 64-bit platform. *)
+
+val shift_right : t -> int -> t
+(** [Targetint.shift_right x y] shifts [x] to the right by [y] bits.
+    This is an arithmetic shift: the sign bit of [x] is replicated
+    and inserted in the vacated bits.
+    The result is unspecified if [y < 0] or [y >= bitsize]. *)
+
+val shift_right_logical : t -> int -> t
+(** [Targetint.shift_right_logical x y] shifts [x] to the right
+    by [y] bits.
+    This is a logical shift: zeroes are inserted in the vacated bits
+    regardless of the sign of [x].
+    The result is unspecified if [y < 0] or [y >= bitsize]. *)
+
+val of_int : int -> t
+(** Convert the given integer (type [int]) to a target integer
+    (type [t]), module the target word size. *)
+
+val of_int_exn : int -> t
+(** Convert the given integer (type [int]) to a target integer
+    (type [t]).  Raises a fatal error if the conversion is not exact. *)
+
+val to_int : t -> int
+(** Convert the given target integer (type [t]) to an
+    integer (type [int]).  The high-order bit is lost during
+    the conversion. *)
+
+val of_float : float -> t
+(** Convert the given floating-point number to a target integer,
+   discarding the fractional part (truncate towards 0).
+   The result of the conversion is undefined if, after truncation,
+   the number is outside the range
+   \[{!Targetint.min_int}, {!Targetint.max_int}\]. *)
+
+val to_float : t -> float
+(** Convert the given target integer to a floating-point number. *)
+
+val of_int32 : int32 -> t
+(** Convert the given 32-bit integer (type [int32])
+    to a target integer. *)
+
+val to_int32 : t -> int32
+(** Convert the given target integer to a
+    32-bit integer (type [int32]).  On 64-bit platforms,
+    the 64-bit native integer is taken modulo 2{^32},
+    i.e. the top 32 bits are lost.  On 32-bit platforms,
+    the conversion is exact. *)
+
+val of_int64 : int64 -> t
+(** Convert the given 64-bit integer (type [int64])
+    to a target integer. *)
+
+val to_int64 : t -> int64
+(** Convert the given target integer to a
+    64-bit integer (type [int64]). *)
+
+val of_string : string -> t
+(** Convert the given string to a target integer.
+    The string is read in decimal (by default) or in hexadecimal,
+    octal or binary if the string begins with [0x], [0o] or [0b]
+    respectively.
+    Raise [Failure "int_of_string"] if the given string is not
+    a valid representation of an integer, or if the integer represented
+    exceeds the range of integers representable in type [nativeint]. *)
+
+val to_string : t -> string
+(** Return the string representation of its argument, in decimal. *)
+
+val compare: t -> t -> int
+(** The comparison function for target integers, with the same specification as
+    {!Stdlib.compare}.  Along with the type [t], this function [compare]
+    allows the module [Targetint] to be passed as argument to the functors
+    {!Set.Make} and {!Map.Make}. *)
+
+val unsigned_compare: t -> t -> int
+(** Same as {!compare}, except that arguments are interpreted as {e unsigned}
+    integers. *)
+
+val equal: t -> t -> bool
+(** The equal function for target ints. *)
+
+type repr =
+  | Int32 of int32
+  | Int64 of int64
+
+val repr : t -> repr
+(** The concrete representation of a native integer. *)
+
+val print : Format.formatter -> t -> unit
+(** Print a target integer to a formatter. *)
diff --git a/upstream/ocaml_413/utils/terminfo.ml b/upstream/ocaml_413/utils/terminfo.ml
new file mode 100644
index 0000000..1b4a357
--- /dev/null
+++ b/upstream/ocaml_413/utils/terminfo.ml
@@ -0,0 +1,45 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Paris                  *)
+(*                                                                        *)
+(*   Copyright 2017 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Printf
+
+external isatty : out_channel -> bool = "caml_sys_isatty"
+external terminfo_rows: out_channel -> int = "caml_terminfo_rows"
+
+type status =
+  | Uninitialised
+  | Bad_term
+  | Good_term
+
+let setup oc =
+  let term = try Sys.getenv "TERM" with Not_found -> "" in
+  (* Same heuristics as in Misc.Color.should_enable_color *)
+  if term <> "" && term <> "dumb" && isatty oc
+  then Good_term
+  else Bad_term
+
+let num_lines oc =
+  let rows = terminfo_rows oc in
+  if rows > 0 then rows else 24
+    (* 24 is a reasonable default for an ANSI-style terminal *)
+
+let backup oc n =
+  if n >= 1 then fprintf oc "\027[%dA%!" n
+
+let resume oc n =
+  if n >= 1 then fprintf oc "\027[%dB%!" n
+
+let standout oc b =
+  output_string oc (if b then "\027[4m" else "\027[0m"); flush oc
diff --git a/upstream/ocaml_413/utils/terminfo.mli b/upstream/ocaml_413/utils/terminfo.mli
new file mode 100644
index 0000000..10f5f54
--- /dev/null
+++ b/upstream/ocaml_413/utils/terminfo.mli
@@ -0,0 +1,32 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Basic interface to the terminfo database
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type status =
+  | Uninitialised
+  | Bad_term
+  | Good_term
+
+val setup : out_channel -> status
+val num_lines : out_channel -> int
+val backup : out_channel -> int -> unit
+val standout : out_channel -> bool -> unit
+val resume : out_channel -> int -> unit
diff --git a/upstream/ocaml_413/utils/warnings.ml b/upstream/ocaml_413/utils/warnings.ml
new file mode 100644
index 0000000..d19874b
--- /dev/null
+++ b/upstream/ocaml_413/utils/warnings.ml
@@ -0,0 +1,1032 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Pierre Weis && Damien Doligez, INRIA Rocquencourt          *)
+(*                                                                        *)
+(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* When you change this, you need to update:
+   - the list 'description' at the bottom of this file
+   - man/ocamlc.m
+*)
+
+type loc = {
+  loc_start: Lexing.position;
+  loc_end: Lexing.position;
+  loc_ghost: bool;
+}
+
+type field_usage_warning =
+  | Unused
+  | Not_read
+  | Not_mutated
+
+type constructor_usage_warning =
+  | Unused
+  | Not_constructed
+  | Only_exported_private
+
+type t =
+  | Comment_start                           (*  1 *)
+  | Comment_not_end                         (*  2 *)
+(*| Deprecated --> alert "deprecated" *)    (*  3 *)
+  | Fragile_match of string                 (*  4 *)
+  | Ignored_partial_application             (*  5 *)
+  | Labels_omitted of string list           (*  6 *)
+  | Method_override of string list          (*  7 *)
+  | Partial_match of string                 (*  8 *)
+  | Missing_record_field_pattern of string  (*  9 *)
+  | Non_unit_statement                      (* 10 *)
+  | Redundant_case                          (* 11 *)
+  | Redundant_subpat                        (* 12 *)
+  | Instance_variable_override of string list (* 13 *)
+  | Illegal_backslash                       (* 14 *)
+  | Implicit_public_methods of string list  (* 15 *)
+  | Unerasable_optional_argument            (* 16 *)
+  | Undeclared_virtual_method of string     (* 17 *)
+  | Not_principal of string                 (* 18 *)
+  | Non_principal_labels of string          (* 19 *)
+  | Ignored_extra_argument                  (* 20 *)
+  | Nonreturning_statement                  (* 21 *)
+  | Preprocessor of string                  (* 22 *)
+  | Useless_record_with                     (* 23 *)
+  | Bad_module_name of string               (* 24 *)
+  | All_clauses_guarded                     (* 8, used to be 25 *)
+  | Unused_var of string                    (* 26 *)
+  | Unused_var_strict of string             (* 27 *)
+  | Wildcard_arg_to_constant_constr         (* 28 *)
+  | Eol_in_string                           (* 29 *)
+  | Duplicate_definitions of string * string * string * string (*30 *)
+  | Module_linked_twice of string * string * string (* 31 *)
+  | Unused_value_declaration of string      (* 32 *)
+  | Unused_open of string                   (* 33 *)
+  | Unused_type_declaration of string       (* 34 *)
+  | Unused_for_index of string              (* 35 *)
+  | Unused_ancestor of string               (* 36 *)
+  | Unused_constructor of string * constructor_usage_warning (* 37 *)
+  | Unused_extension of string * bool * constructor_usage_warning (* 38 *)
+  | Unused_rec_flag                         (* 39 *)
+  | Name_out_of_scope of string * string list * bool (* 40 *)
+  | Ambiguous_name of string list * string list *  bool * string (* 41 *)
+  | Disambiguated_name of string            (* 42 *)
+  | Nonoptional_label of string             (* 43 *)
+  | Open_shadow_identifier of string * string (* 44 *)
+  | Open_shadow_label_constructor of string * string (* 45 *)
+  | Bad_env_variable of string * string     (* 46 *)
+  | Attribute_payload of string * string    (* 47 *)
+  | Eliminated_optional_arguments of string list (* 48 *)
+  | No_cmi_file of string * string option   (* 49 *)
+  | Unexpected_docstring of bool            (* 50 *)
+  | Wrong_tailcall_expectation of bool      (* 51 *)
+  | Fragile_literal_pattern                 (* 52 *)
+  | Misplaced_attribute of string           (* 53 *)
+  | Duplicated_attribute of string          (* 54 *)
+  | Inlining_impossible of string           (* 55 *)
+  | Unreachable_case                        (* 56 *)
+  | Ambiguous_var_in_pattern_guard of string list (* 57 *)
+  | No_cmx_file of string                   (* 58 *)
+  | Flambda_assignment_to_non_mutable_value (* 59 *)
+  | Unused_module of string                 (* 60 *)
+  | Unboxable_type_in_prim_decl of string   (* 61 *)
+  | Constraint_on_gadt                      (* 62 *)
+  | Erroneous_printed_signature of string   (* 63 *)
+  | Unsafe_array_syntax_without_parsing     (* 64 *)
+  | Redefining_unit of string               (* 65 *)
+  | Unused_open_bang of string              (* 66 *)
+  | Unused_functor_parameter of string      (* 67 *)
+  | Match_on_mutable_state_prevent_uncurry  (* 68 *)
+  | Unused_field of string * field_usage_warning (* 69 *)
+  | Missing_mli                             (* 70 *)
+;;
+
+(* If you remove a warning, leave a hole in the numbering.  NEVER change
+   the numbers of existing warnings.
+   If you add a new warning, add it at the end with a new number;
+   do NOT reuse one of the holes.
+*)
+
+type alert = {kind:string; message:string; def:loc; use:loc}
+
+let number = function
+  | Comment_start -> 1
+  | Comment_not_end -> 2
+  | Fragile_match _ -> 4
+  | Ignored_partial_application -> 5
+  | Labels_omitted _ -> 6
+  | Method_override _ -> 7
+  | Partial_match _ -> 8
+  | Missing_record_field_pattern _ -> 9
+  | Non_unit_statement -> 10
+  | Redundant_case -> 11
+  | Redundant_subpat -> 12
+  | Instance_variable_override _ -> 13
+  | Illegal_backslash -> 14
+  | Implicit_public_methods _ -> 15
+  | Unerasable_optional_argument -> 16
+  | Undeclared_virtual_method _ -> 17
+  | Not_principal _ -> 18
+  | Non_principal_labels _ -> 19
+  | Ignored_extra_argument -> 20
+  | Nonreturning_statement -> 21
+  | Preprocessor _ -> 22
+  | Useless_record_with -> 23
+  | Bad_module_name _ -> 24
+  | All_clauses_guarded -> 8 (* used to be 25 *)
+  | Unused_var _ -> 26
+  | Unused_var_strict _ -> 27
+  | Wildcard_arg_to_constant_constr -> 28
+  | Eol_in_string -> 29
+  | Duplicate_definitions _ -> 30
+  | Module_linked_twice _ -> 31
+  | Unused_value_declaration _ -> 32
+  | Unused_open _ -> 33
+  | Unused_type_declaration _ -> 34
+  | Unused_for_index _ -> 35
+  | Unused_ancestor _ -> 36
+  | Unused_constructor _ -> 37
+  | Unused_extension _ -> 38
+  | Unused_rec_flag -> 39
+  | Name_out_of_scope _ -> 40
+  | Ambiguous_name _ -> 41
+  | Disambiguated_name _ -> 42
+  | Nonoptional_label _ -> 43
+  | Open_shadow_identifier _ -> 44
+  | Open_shadow_label_constructor _ -> 45
+  | Bad_env_variable _ -> 46
+  | Attribute_payload _ -> 47
+  | Eliminated_optional_arguments _ -> 48
+  | No_cmi_file _ -> 49
+  | Unexpected_docstring _ -> 50
+  | Wrong_tailcall_expectation _ -> 51
+  | Fragile_literal_pattern -> 52
+  | Misplaced_attribute _ -> 53
+  | Duplicated_attribute _ -> 54
+  | Inlining_impossible _ -> 55
+  | Unreachable_case -> 56
+  | Ambiguous_var_in_pattern_guard _ -> 57
+  | No_cmx_file _ -> 58
+  | Flambda_assignment_to_non_mutable_value -> 59
+  | Unused_module _ -> 60
+  | Unboxable_type_in_prim_decl _ -> 61
+  | Constraint_on_gadt -> 62
+  | Erroneous_printed_signature _ -> 63
+  | Unsafe_array_syntax_without_parsing -> 64
+  | Redefining_unit _ -> 65
+  | Unused_open_bang _ -> 66
+  | Unused_functor_parameter _ -> 67
+  | Match_on_mutable_state_prevent_uncurry -> 68
+  | Unused_field _ -> 69
+  | Missing_mli -> 70
+;;
+
+let last_warning_number = 70
+;;
+
+(* Third component of each tuple is the list of names for each warning. The
+   first element of the list is the current name, any following ones are
+   deprecated. The current name should always be derived mechanically from the
+   constructor name. *)
+
+let descriptions =
+  [
+    1, "Suspicious-looking start-of-comment mark.",
+    ["comment-start"];
+    2, "Suspicious-looking end-of-comment mark.",
+    ["comment-not-end"];
+    3, "Deprecated synonym for the 'deprecated' alert.",
+    [];
+    4, "Fragile pattern matching: matching that will remain complete even\n\
+       \    if additional constructors are added to one of the variant types\n\
+       \    matched.",
+    ["fragile-match"];
+    5, "Partially applied function: expression whose result has function\n\
+       \    type and is ignored.",
+    ["ignored-partial-application"];
+    6, "Label omitted in function application.",
+    ["labels-omitted"];
+    7, "Method overridden.",
+    ["method-override"];
+    8, "Partial match: missing cases in pattern-matching.",
+    ["partial-match"];
+    9, "Missing fields in a record pattern.",
+    ["missing-record-field-pattern"];
+    10,
+    "Expression on the left-hand side of a sequence that doesn't have type\n\
+    \    \"unit\" (and that is not a function, see warning number 5).",
+    ["non-unit-statement"];
+    11, "Redundant case in a pattern matching (unused match case).",
+    ["redundant-case"];
+    12, "Redundant sub-pattern in a pattern-matching.",
+    ["redundant-subpat"];
+    13, "Instance variable overridden.",
+    ["instance-variable-override"];
+    14, "Illegal backslash escape in a string constant.",
+    ["illegal-backslash"];
+    15, "Private method made public implicitly.",
+    ["implicit-public-methods"];
+    16, "Unerasable optional argument.",
+    ["unerasable-optional-argument"];
+    17, "Undeclared virtual method.",
+    ["undeclared-virtual-method"];
+    18, "Non-principal type.",
+    ["not-principal"];
+    19, "Type without principality.",
+    ["non-principal-labels"];
+    20, "Unused function argument.",
+    ["ignored-extra-argument"];
+    21, "Non-returning statement.",
+    ["nonreturning-statement"];
+    22, "Preprocessor warning.",
+    ["preprocessor"];
+    23, "Useless record \"with\" clause.",
+    ["useless-record-with"];
+    24,
+    "Bad module name: the source file name is not a valid OCaml module name.",
+    ["bad-module-name"];
+    25, "Ignored: now part of warning 8.",
+    [];
+    26,
+    "Suspicious unused variable: unused variable that is bound\n\
+    \    with \"let\" or \"as\", and doesn't start with an underscore (\"_\")\n\
+    \    character.",
+    ["unused-var"];
+    27, "Innocuous unused variable: unused variable that is not bound with\n\
+        \    \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\
+        \    character.",
+    ["unused-var-strict"];
+    28, "Wildcard pattern given as argument to a constant constructor.",
+    ["wildcard-arg-to-constant-constr"];
+    29, "Unescaped end-of-line in a string constant (non-portable code).",
+    ["eol-in-string"];
+    30, "Two labels or constructors of the same name are defined in two\n\
+        \    mutually recursive types.",
+    ["duplicate-definitions"];
+    31, "A module is linked twice in the same executable.",
+    ["module-linked-twice"];
+    32, "Unused value declaration.",
+    ["unused-value-declaration"];
+    33, "Unused open statement.",
+    ["unused-open"];
+    34, "Unused type declaration.",
+    ["unused-type-declaration"];
+    35, "Unused for-loop index.",
+    ["unused-for-index"];
+    36, "Unused ancestor variable.",
+    ["unused-ancestor"];
+    37, "Unused constructor.",
+    ["unused-constructor"];
+    38, "Unused extension constructor.",
+    ["unused-extension"];
+    39, "Unused rec flag.",
+    ["unused-rec-flag"];
+    40, "Constructor or label name used out of scope.",
+    ["name-out-of-scope"];
+    41, "Ambiguous constructor or label name.",
+    ["ambiguous-name"];
+    42, "Disambiguated constructor or label name (compatibility warning).",
+    ["disambiguated-name"];
+    43, "Nonoptional label applied as optional.",
+    ["nonoptional-label"];
+    44, "Open statement shadows an already defined identifier.",
+    ["open-shadow-identifier"];
+    45, "Open statement shadows an already defined label or constructor.",
+    ["open-shadow-label-constructor"];
+    46, "Error in environment variable.",
+    ["bad-env-variable"];
+    47, "Illegal attribute payload.",
+    ["attribute-payload"];
+    48, "Implicit elimination of optional arguments.",
+    ["eliminated-optional-arguments"];
+    49, "Absent cmi file when looking up module alias.",
+    ["no-cmi-file"];
+    50, "Unexpected documentation comment.",
+    ["unexpected-docstring"];
+    51, "Function call annotated with an incorrect @tailcall attribute",
+    ["wrong-tailcall-expectation"];
+    52, "Fragile constant pattern.",
+    ["fragile-literal-pattern"];
+    53, "Attribute cannot appear in this context.",
+    ["misplaced-attribute"];
+    54, "Attribute used more than once on an expression.",
+    ["duplicated-attribute"];
+    55, "Inlining impossible.",
+    ["inlining-impossible"];
+    56, "Unreachable case in a pattern-matching (based on type information).",
+    ["unreachable-case"];
+    57, "Ambiguous or-pattern variables under guard.",
+    ["ambiguous-var-in-pattern-guard"];
+    58, "Missing cmx file.",
+    ["no-cmx-file"];
+    59, "Assignment to non-mutable value.",
+    ["flambda-assignment-to-non-mutable-value"];
+    60, "Unused module declaration.",
+    ["unused-module"];
+    61, "Unboxable type in primitive declaration.",
+    ["unboxable-type-in-prim-decl"];
+    62, "Type constraint on GADT type declaration.",
+    ["constraint-on-gadt"];
+    63, "Erroneous printed signature.",
+    ["erroneous-printed-signature"];
+    64, "-unsafe used with a preprocessor returning a syntax tree.",
+    ["unsafe-array-syntax-without-parsing"];
+    65, "Type declaration defining a new '()' constructor.",
+    ["redefining-unit"];
+    66, "Unused open! statement.",
+    ["unused-open-bang"];
+    67, "Unused functor parameter.",
+    ["unused-functor-parameter"];
+    68, "Pattern-matching depending on mutable state prevents the remaining \
+         arguments from being uncurried.",
+    ["match-on-mutable-state-prevent-uncurry"];
+    69, "Unused record field.",
+    ["unused-field"];
+    70, "Missing interface file.",
+    ["missing-mli"]
+  ]
+;;
+
+let name_to_number =
+  let h = Hashtbl.create last_warning_number in
+  List.iter (fun (num, _, names) ->
+      List.iter (fun name -> Hashtbl.add h name num) names
+    ) descriptions;
+  fun s -> Hashtbl.find_opt h s
+;;
+
+(* Must be the max number returned by the [number] function. *)
+
+let letter = function
+  | 'a' ->
+     let rec loop i = if i = 0 then [] else i :: loop (i - 1) in
+     loop last_warning_number
+  | 'b' -> []
+  | 'c' -> [1; 2]
+  | 'd' -> [3]
+  | 'e' -> [4]
+  | 'f' -> [5]
+  | 'g' -> []
+  | 'h' -> []
+  | 'i' -> []
+  | 'j' -> []
+  | 'k' -> [32; 33; 34; 35; 36; 37; 38; 39]
+  | 'l' -> [6]
+  | 'm' -> [7]
+  | 'n' -> []
+  | 'o' -> []
+  | 'p' -> [8]
+  | 'q' -> []
+  | 'r' -> [9]
+  | 's' -> [10]
+  | 't' -> []
+  | 'u' -> [11; 12]
+  | 'v' -> [13]
+  | 'w' -> []
+  | 'x' -> [14; 15; 16; 17; 18; 19; 20; 21; 22; 23; 24; 30]
+  | 'y' -> [26]
+  | 'z' -> [27]
+  | _ -> assert false
+;;
+
+type state =
+  {
+    active: bool array;
+    error: bool array;
+    alerts: (Misc.Stdlib.String.Set.t * bool); (* false:set complement *)
+    alert_errors: (Misc.Stdlib.String.Set.t * bool); (* false:set complement *)
+  }
+
+let current =
+  ref
+    {
+      active = Array.make (last_warning_number + 1) true;
+      error = Array.make (last_warning_number + 1) false;
+      alerts = (Misc.Stdlib.String.Set.empty, false); (* all enabled *)
+      alert_errors = (Misc.Stdlib.String.Set.empty, true); (* all soft *)
+    }
+
+let disabled = ref false
+
+let without_warnings f =
+  Misc.protect_refs [Misc.R(disabled, true)] f
+
+let backup () = !current
+
+let restore x = current := x
+
+let is_active x =
+  not !disabled && (!current).active.(number x)
+
+let is_error x =
+  not !disabled && (!current).error.(number x)
+
+let alert_is_active {kind; _} =
+  not !disabled &&
+  let (set, pos) = (!current).alerts in
+  Misc.Stdlib.String.Set.mem kind set = pos
+
+let alert_is_error {kind; _} =
+  not !disabled &&
+  let (set, pos) = (!current).alert_errors in
+  Misc.Stdlib.String.Set.mem kind set = pos
+
+let mk_lazy f =
+  let state = backup () in
+  lazy
+    (
+      let prev = backup () in
+      restore state;
+      try
+        let r = f () in
+        restore prev;
+        r
+      with exn ->
+        restore prev;
+        raise exn
+    )
+
+let set_alert ~error ~enable s =
+  let upd =
+    match s with
+    | "all" ->
+        (Misc.Stdlib.String.Set.empty, not enable)
+    | s ->
+        let (set, pos) =
+          if error then (!current).alert_errors else (!current).alerts
+        in
+        let f =
+          if enable = pos
+          then Misc.Stdlib.String.Set.add
+          else Misc.Stdlib.String.Set.remove
+        in
+        (f s set, pos)
+  in
+  if error then
+    current := {(!current) with alert_errors=upd}
+  else
+    current := {(!current) with alerts=upd}
+
+let parse_alert_option s =
+  let n = String.length s in
+  let id_char = function
+    | 'a'..'z' | 'A'..'Z' | '_' | '\'' | '0'..'9' -> true
+    | _ -> false
+  in
+  let rec parse_id i =
+    if i < n && id_char s.[i] then parse_id (i + 1) else i
+  in
+  let rec scan i =
+    if i = n then ()
+    else if i + 1 = n then raise (Arg.Bad "Ill-formed list of alert settings")
+    else match s.[i], s.[i+1] with
+      | '+', '+' -> id (set_alert ~error:true ~enable:true) (i + 2)
+      | '+', _ -> id (set_alert ~error:false ~enable:true) (i + 1)
+      | '-', '-' -> id (set_alert ~error:true ~enable:false) (i + 2)
+      | '-', _ -> id (set_alert ~error:false ~enable:false) (i + 1)
+      | '@', _ ->
+          id (fun s ->
+              set_alert ~error:true ~enable:true s;
+              set_alert ~error:false ~enable:true s)
+            (i + 1)
+      | _ -> raise (Arg.Bad "Ill-formed list of alert settings")
+  and id f i =
+    let j = parse_id i in
+    if j = i then raise (Arg.Bad "Ill-formed list of alert settings");
+    let id = String.sub s i (j - i) in
+    f id;
+    scan j
+  in
+  scan 0
+
+type modifier =
+  | Set (** +a *)
+  | Clear (** -a *)
+  | Set_all (** @a *)
+
+type token =
+  | Letter of char * modifier option
+  | Num of int * int * modifier
+
+let letter_alert tokens =
+  let print_warning_char ppf c =
+    let lowercase = Char.lowercase_ascii c = c in
+    Format.fprintf ppf "%c%c"
+      (if lowercase then '-' else '+') c
+  in
+  let print_modifier ppf = function
+    | Set_all -> Format.fprintf ppf "@"
+    | Clear -> Format.fprintf ppf "-"
+    | Set -> Format.fprintf ppf "+"
+  in
+  let print_token ppf = function
+    | Num (a,b,m) -> if a = b then
+          Format.fprintf ppf "%a%d" print_modifier m a
+        else
+          Format.fprintf ppf "%a%d..%d" print_modifier m a b
+    | Letter(l,Some m) -> Format.fprintf ppf "%a%c" print_modifier m l
+    | Letter(l,None) -> print_warning_char ppf l
+  in
+  let consecutive_letters =
+    (* we are tracking sequences of 2 or more consecutive unsigned letters
+       in warning strings, for instance in '-w "not-principa"'. *)
+    let commit_chunk l = function
+      | [] | [ _ ] -> l
+      | _ :: _ :: _ as chunk -> List.rev chunk :: l
+    in
+    let group_consecutive_letters (l,current) = function
+    | Letter (x, None) -> (l, x::current)
+    | _ -> (commit_chunk l current, [])
+    in
+    let l, on_going =
+      List.fold_left group_consecutive_letters ([],[]) tokens
+    in
+    commit_chunk l on_going
+  in
+  match consecutive_letters with
+  | [] -> None
+  | example :: _  ->
+      let pos = { Lexing.dummy_pos with pos_fname = "_none_" } in
+      let nowhere = { loc_start=pos; loc_end=pos; loc_ghost=true } in
+      let spelling_hint ppf =
+        let max_seq_len =
+          List.fold_left (fun l x -> Int.max l (List.length x))
+            0 consecutive_letters
+        in
+        if max_seq_len >= 5 then
+          Format.fprintf ppf
+            "@ @[Hint: Did you make a spelling mistake \
+             when using a mnemonic name?@]"
+        else
+          ()
+      in
+      let message =
+        Format.asprintf
+          "@[<v>@[Setting a warning with a sequence of lowercase \
+           or uppercase letters,@ like '%a',@ is deprecated.@]@ \
+           @[Use the equivalent signed form:@ %t.@]@ \
+           @[Hint: Enabling or disabling a warning by its mnemonic name \
+           requires a + or - prefix.@]\
+           %t@?@]"
+          Format.(pp_print_list ~pp_sep:(fun _ -> ignore) pp_print_char) example
+          (fun ppf -> List.iter (print_token ppf) tokens)
+          spelling_hint
+      in
+      Some {
+        kind="ocaml_deprecated_cli";
+        use=nowhere; def=nowhere;
+        message
+      }
+
+
+let parse_warnings s =
+  let error () = raise (Arg.Bad "Ill-formed list of warnings") in
+  let rec get_num n i =
+    if i >= String.length s then i, n
+    else match s.[i] with
+    | '0'..'9' -> get_num (10 * n + Char.code s.[i] - Char.code '0') (i + 1)
+    | _ -> i, n
+  in
+  let get_range i =
+    let i, n1 = get_num 0 i in
+    if i + 2 < String.length s && s.[i] = '.' && s.[i + 1] = '.' then
+      let i, n2 = get_num 0 (i + 2) in
+      if n2 < n1 then error ();
+      i, n1, n2
+    else
+      i, n1, n1
+  in
+  let rec loop tokens i =
+    if i >= String.length s then List.rev tokens else
+    match s.[i] with
+    | 'A' .. 'Z' | 'a' .. 'z' ->
+        loop (Letter(s.[i],None)::tokens) (i+1)
+    | '+' -> loop_letter_num tokens Set (i+1)
+    | '-' -> loop_letter_num tokens Clear (i+1)
+    | '@' -> loop_letter_num tokens Set_all (i+1)
+    | _ -> error ()
+  and loop_letter_num tokens modifier i =
+    if i >= String.length s then error () else
+    match s.[i] with
+    | '0' .. '9' ->
+        let i, n1, n2 = get_range i in
+        loop (Num(n1,n2,modifier)::tokens) i
+    | 'A' .. 'Z' | 'a' .. 'z' ->
+       loop (Letter(s.[i],Some modifier)::tokens) (i+1)
+    | _ -> error ()
+  in
+  loop [] 0
+
+let parse_opt error active errflag s =
+  let flags = if errflag then error else active in
+  let action modifier i = match modifier with
+    | Set ->
+        if i = 3 then set_alert ~error:errflag ~enable:true "deprecated"
+        else flags.(i) <- true
+    | Clear ->
+        if i = 3 then set_alert ~error:errflag ~enable:false "deprecated"
+        else flags.(i) <- false
+    | Set_all ->
+        if i = 3 then begin
+          set_alert ~error:false ~enable:true "deprecated";
+          set_alert ~error:true ~enable:true "deprecated"
+        end
+        else begin
+          active.(i) <- true;
+          error.(i) <- true
+        end
+  in
+  let eval = function
+    | Letter(c, m) ->
+        let lc = Char.lowercase_ascii c in
+        let modifier = match m with
+          | None -> if c = lc then Clear else Set
+          | Some m -> m
+        in
+        List.iter (action modifier) (letter lc)
+    | Num(n1,n2,modifier) ->
+        for n = n1 to Int.min n2 last_warning_number do action modifier n done
+  in
+  let parse_and_eval s =
+    let tokens = parse_warnings s in
+    List.iter eval tokens;
+    letter_alert tokens
+  in
+   match name_to_number s with
+  | Some n -> action Set n; None
+  | None ->
+      if s = "" then parse_and_eval s
+      else begin
+        let rest = String.sub s 1 (String.length s - 1) in
+        match s.[0], name_to_number rest with
+        | '+', Some n -> action Set n; None
+        | '-', Some n -> action Clear n; None
+        | '@', Some n -> action Set_all n; None
+        | _ -> parse_and_eval s
+      end
+;;
+
+let parse_options errflag s =
+  let error = Array.copy (!current).error in
+  let active = Array.copy (!current).active in
+  let alerts = parse_opt error active errflag s in
+  current := {(!current) with error; active};
+  alerts
+
+(* If you change these, don't forget to change them in man/ocamlc.m *)
+let defaults_w = "+a-4-7-9-27-29-30-32..42-44-45-48-50-60-66..70";;
+let defaults_warn_error = "-a+31";;
+
+let () = ignore @@ parse_options false defaults_w;;
+let () = ignore @@ parse_options true defaults_warn_error;;
+
+let ref_manual_explanation () =
+  (* manual references are checked a posteriori by the manual
+     cross-reference consistency check in manual/tests*)
+  let[@manual.ref "s:comp-warnings"] chapter, section = 11, 5 in
+  Printf.sprintf "(See manual section %d.%d)" chapter section
+
+let message = function
+  | Comment_start ->
+      "this `(*' is the start of a comment.\n\
+       Hint: Did you forget spaces when writing the infix operator `( * )'?"
+  | Comment_not_end -> "this is not the end of a comment."
+  | Fragile_match "" ->
+      "this pattern-matching is fragile."
+  | Fragile_match s ->
+      "this pattern-matching is fragile.\n\
+       It will remain exhaustive when constructors are added to type " ^ s ^ "."
+  | Ignored_partial_application ->
+      "this function application is partial,\n\
+       maybe some arguments are missing."
+  | Labels_omitted [] -> assert false
+  | Labels_omitted [l] ->
+     "label " ^ l ^ " was omitted in the application of this function."
+  | Labels_omitted ls ->
+     "labels " ^ String.concat ", " ls ^
+       " were omitted in the application of this function."
+  | Method_override [lab] ->
+      "the method " ^ lab ^ " is overridden."
+  | Method_override (cname :: slist) ->
+      String.concat " "
+        ("the following methods are overridden by the class"
+         :: cname  :: ":\n " :: slist)
+  | Method_override [] -> assert false
+  | Partial_match "" -> "this pattern-matching is not exhaustive."
+  | Partial_match s ->
+      "this pattern-matching is not exhaustive.\n\
+       Here is an example of a case that is not matched:\n" ^ s
+  | Missing_record_field_pattern s ->
+      "the following labels are not bound in this record pattern:\n" ^ s ^
+      "\nEither bind these labels explicitly or add '; _' to the pattern."
+  | Non_unit_statement ->
+      "this expression should have type unit."
+  | Redundant_case -> "this match case is unused."
+  | Redundant_subpat -> "this sub-pattern is unused."
+  | Instance_variable_override [lab] ->
+      "the instance variable " ^ lab ^ " is overridden.\n" ^
+      "The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)"
+  | Instance_variable_override (cname :: slist) ->
+      String.concat " "
+        ("the following instance variables are overridden by the class"
+         :: cname  :: ":\n " :: slist) ^
+      "\nThe behaviour changed in ocaml 3.10 (previous behaviour was hiding.)"
+  | Instance_variable_override [] -> assert false
+  | Illegal_backslash -> "illegal backslash escape in string."
+  | Implicit_public_methods l ->
+      "the following private methods were made public implicitly:\n "
+      ^ String.concat " " l ^ "."
+  | Unerasable_optional_argument -> "this optional argument cannot be erased."
+  | Undeclared_virtual_method m -> "the virtual method "^m^" is not declared."
+  | Not_principal s -> s^" is not principal."
+  | Non_principal_labels s -> s^" without principality."
+  | Ignored_extra_argument -> "this argument will not be used by the function."
+  | Nonreturning_statement ->
+      "this statement never returns (or has an unsound type.)"
+  | Preprocessor s -> s
+  | Useless_record_with ->
+      "all the fields are explicitly listed in this record:\n\
+       the 'with' clause is useless."
+  | Bad_module_name (modname) ->
+      "bad source file name: \"" ^ modname ^ "\" is not a valid module name."
+  | All_clauses_guarded ->
+      "this pattern-matching is not exhaustive.\n\
+       All clauses in this pattern-matching are guarded."
+  | Unused_var v | Unused_var_strict v -> "unused variable " ^ v ^ "."
+  | Wildcard_arg_to_constant_constr ->
+     "wildcard pattern given as argument to a constant constructor"
+  | Eol_in_string ->
+     "unescaped end-of-line in a string constant (non-portable code)"
+  | Duplicate_definitions (kind, cname, tc1, tc2) ->
+      Printf.sprintf "the %s %s is defined in both types %s and %s."
+        kind cname tc1 tc2
+  | Module_linked_twice(modname, file1, file2) ->
+      Printf.sprintf
+        "files %s and %s both define a module named %s"
+        file1 file2 modname
+  | Unused_value_declaration v -> "unused value " ^ v ^ "."
+  | Unused_open s -> "unused open " ^ s ^ "."
+  | Unused_open_bang s -> "unused open! " ^ s ^ "."
+  | Unused_type_declaration s -> "unused type " ^ s ^ "."
+  | Unused_for_index s -> "unused for-loop index " ^ s ^ "."
+  | Unused_ancestor s -> "unused ancestor variable " ^ s ^ "."
+  | Unused_constructor (s, Unused) -> "unused constructor " ^ s ^ "."
+  | Unused_constructor (s, Not_constructed) ->
+      "constructor " ^ s ^
+      " is never used to build values.\n\
+        (However, this constructor appears in patterns.)"
+  | Unused_constructor (s, Only_exported_private) ->
+      "constructor " ^ s ^
+      " is never used to build values.\n\
+        Its type is exported as a private type."
+  | Unused_extension (s, is_exception, complaint) ->
+     let kind =
+       if is_exception then "exception" else "extension constructor" in
+     let name = kind ^ " " ^ s in
+     begin match complaint with
+       | Unused -> "unused " ^ name
+       | Not_constructed ->
+          name ^
+          " is never used to build values.\n\
+           (However, this constructor appears in patterns.)"
+       | Only_exported_private ->
+          name ^
+          " is never used to build values.\n\
+            It is exported or rebound as a private extension."
+     end
+  | Unused_rec_flag ->
+      "unused rec flag."
+  | Name_out_of_scope (ty, [nm], false) ->
+      nm ^ " was selected from type " ^ ty ^
+      ".\nIt is not visible in the current scope, and will not \n\
+       be selected if the type becomes unknown."
+  | Name_out_of_scope (_, _, false) -> assert false
+  | Name_out_of_scope (ty, slist, true) ->
+      "this record of type "^ ty ^" contains fields that are \n\
+       not visible in the current scope: "
+      ^ String.concat " " slist ^ ".\n\
+       They will not be selected if the type becomes unknown."
+  | Ambiguous_name ([s], tl, false, expansion) ->
+      s ^ " belongs to several types: " ^ String.concat " " tl ^
+      "\nThe first one was selected. Please disambiguate if this is wrong."
+      ^ expansion
+  | Ambiguous_name (_, _, false, _ ) -> assert false
+  | Ambiguous_name (_slist, tl, true, expansion) ->
+      "these field labels belong to several types: " ^
+      String.concat " " tl ^
+      "\nThe first one was selected. Please disambiguate if this is wrong."
+      ^ expansion
+  | Disambiguated_name s ->
+      "this use of " ^ s ^ " relies on type-directed disambiguation,\n\
+       it will not compile with OCaml 4.00 or earlier."
+  | Nonoptional_label s ->
+      "the label " ^ s ^ " is not optional."
+  | Open_shadow_identifier (kind, s) ->
+      Printf.sprintf
+        "this open statement shadows the %s identifier %s (which is later used)"
+        kind s
+  | Open_shadow_label_constructor (kind, s) ->
+      Printf.sprintf
+        "this open statement shadows the %s %s (which is later used)"
+        kind s
+  | Bad_env_variable (var, s) ->
+      Printf.sprintf "illegal environment variable %s : %s" var s
+  | Attribute_payload (a, s) ->
+      Printf.sprintf "illegal payload for attribute '%s'.\n%s" a s
+  | Eliminated_optional_arguments sl ->
+      Printf.sprintf "implicit elimination of optional argument%s %s"
+        (if List.length sl = 1 then "" else "s")
+        (String.concat ", " sl)
+  | No_cmi_file(name, None) ->
+      "no cmi file was found in path for module " ^ name
+  | No_cmi_file(name, Some msg) ->
+      Printf.sprintf
+        "no valid cmi file was found in path for module %s. %s"
+        name msg
+  | Unexpected_docstring unattached ->
+      if unattached then "unattached documentation comment (ignored)"
+      else "ambiguous documentation comment"
+  | Wrong_tailcall_expectation b ->
+      Printf.sprintf "expected %s"
+        (if b then "tailcall" else "non-tailcall")
+  | Fragile_literal_pattern ->
+      Printf.sprintf
+        "Code should not depend on the actual values of\n\
+         this constructor's arguments. They are only for information\n\
+         and may change in future versions. %t" ref_manual_explanation
+  | Unreachable_case ->
+      "this match case is unreachable.\n\
+       Consider replacing it with a refutation case '<pat> -> .'"
+  | Misplaced_attribute attr_name ->
+      Printf.sprintf "the %S attribute cannot appear in this context" attr_name
+  | Duplicated_attribute attr_name ->
+      Printf.sprintf "the %S attribute is used more than once on this \
+          expression"
+        attr_name
+  | Inlining_impossible reason ->
+      Printf.sprintf "Cannot inline: %s" reason
+  | Ambiguous_var_in_pattern_guard vars ->
+      let msg =
+        let vars = List.sort String.compare vars in
+        match vars with
+        | [] -> assert false
+        | [x] -> "variable " ^ x
+        | _::_ ->
+            "variables " ^ String.concat "," vars in
+      Printf.sprintf
+        "Ambiguous or-pattern variables under guard;\n\
+         %s may match different arguments. %t"
+        msg ref_manual_explanation
+  | No_cmx_file name ->
+      Printf.sprintf
+        "no cmx file was found in path for module %s, \
+         and its interface was not compiled with -opaque" name
+  | Flambda_assignment_to_non_mutable_value ->
+      "A potential assignment to a non-mutable value was detected \n\
+        in this source file.  Such assignments may generate incorrect code \n\
+        when using Flambda."
+  | Unused_module s -> "unused module " ^ s ^ "."
+  | Unboxable_type_in_prim_decl t ->
+      Printf.sprintf
+        "This primitive declaration uses type %s, whose representation\n\
+         may be either boxed or unboxed. Without an annotation to indicate\n\
+         which representation is intended, the boxed representation has been\n\
+         selected by default. This default choice may change in future\n\
+         versions of the compiler, breaking the primitive implementation.\n\
+         You should explicitly annotate the declaration of %s\n\
+         with [@@boxed] or [@@unboxed], so that its external interface\n\
+         remains stable in the future." t t
+  | Constraint_on_gadt ->
+      "Type constraints do not apply to GADT cases of variant types."
+  | Erroneous_printed_signature s ->
+      "The printed interface differs from the inferred interface.\n\
+       The inferred interface contained items which could not be printed\n\
+       properly due to name collisions between identifiers."
+     ^ s
+     ^ "\nBeware that this warning is purely informational and will not catch\n\
+        all instances of erroneous printed interface."
+  | Unsafe_array_syntax_without_parsing ->
+     "option -unsafe used with a preprocessor returning a syntax tree"
+  | Redefining_unit name ->
+      Printf.sprintf
+        "This type declaration is defining a new '()' constructor\n\
+         which shadows the existing one.\n\
+         Hint: Did you mean 'type %s = unit'?" name
+  | Unused_functor_parameter s -> "unused functor parameter " ^ s ^ "."
+  | Match_on_mutable_state_prevent_uncurry ->
+    "This pattern depends on mutable state.\n\
+     It prevents the remaining arguments from being uncurried, which will \
+     cause additional closure allocations."
+  | Unused_field (s, Unused) -> "unused record field " ^ s ^ "."
+  | Unused_field (s, Not_read) ->
+      "record field " ^ s ^
+      " is never read.\n\
+        (However, this field is used to build or mutate values.)"
+  | Unused_field (s, Not_mutated) ->
+      "mutable record field " ^ s ^
+      " is never mutated."
+  | Missing_mli ->
+    "Cannot find interface file."
+;;
+
+let nerrors = ref 0;;
+
+type reporting_information =
+  { id : string
+  ; message : string
+  ; is_error : bool
+  ; sub_locs : (loc * string) list;
+  }
+
+let id_name w =
+  let n = number w in
+  match List.find_opt (fun (m, _, _) -> m = n) descriptions with
+  | Some (_, _, s :: _) ->
+      Printf.sprintf "%d [%s]" n s
+  | _ ->
+      string_of_int n
+
+let report w =
+  match is_active w with
+  | false -> `Inactive
+  | true ->
+     if is_error w then incr nerrors;
+     `Active
+       { id = id_name w;
+         message = message w;
+         is_error = is_error w;
+         sub_locs = [];
+       }
+
+let report_alert (alert : alert) =
+  match alert_is_active alert with
+  | false -> `Inactive
+  | true ->
+      let is_error = alert_is_error alert in
+      if is_error then incr nerrors;
+      let message = Misc.normalise_eol alert.message in
+       (* Reduce \r\n to \n:
+           - Prevents any \r characters being printed on Unix when processing
+             Windows sources
+           - Prevents \r\r\n being generated on Windows, which affects the
+             testsuite
+       *)
+      let sub_locs =
+        if not alert.def.loc_ghost && not alert.use.loc_ghost then
+          [
+            alert.def, "Definition";
+            alert.use, "Expected signature";
+          ]
+        else
+          []
+      in
+      `Active
+        {
+          id = alert.kind;
+          message;
+          is_error;
+          sub_locs;
+        }
+
+exception Errors;;
+
+let reset_fatal () =
+  nerrors := 0
+
+let check_fatal () =
+  if !nerrors > 0 then begin
+    nerrors := 0;
+    raise Errors;
+  end;
+;;
+
+let help_warnings () =
+  List.iter
+    (fun (i, s, names) ->
+       let name =
+         match names with
+         | s :: _ -> " [" ^ s ^ "]"
+         | [] -> ""
+       in
+       Printf.printf "%3i%s %s\n" i name s)
+    descriptions;
+  print_endline "  A all warnings";
+  for i = Char.code 'b' to Char.code 'z' do
+    let c = Char.chr i in
+    match letter c with
+    | [] -> ()
+    | [n] ->
+        Printf.printf "  %c Alias for warning %i.\n" (Char.uppercase_ascii c) n
+    | l ->
+        Printf.printf "  %c warnings %s.\n"
+          (Char.uppercase_ascii c)
+          (String.concat ", " (List.map Int.to_string l))
+  done;
+  exit 0
+;;
diff --git a/upstream/ocaml_413/utils/warnings.mli b/upstream/ocaml_413/utils/warnings.mli
new file mode 100644
index 0000000..0430b89
--- /dev/null
+++ b/upstream/ocaml_413/utils/warnings.mli
@@ -0,0 +1,153 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Pierre Weis && Damien Doligez, INRIA Rocquencourt          *)
+(*                                                                        *)
+(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Warning definitions
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type loc = {
+  loc_start: Lexing.position;
+  loc_end: Lexing.position;
+  loc_ghost: bool;
+}
+
+type field_usage_warning =
+  | Unused
+  | Not_read
+  | Not_mutated
+
+type constructor_usage_warning =
+  | Unused
+  | Not_constructed
+  | Only_exported_private
+
+type t =
+  | Comment_start                           (*  1 *)
+  | Comment_not_end                         (*  2 *)
+(*| Deprecated --> alert "deprecated" *)    (*  3 *)
+  | Fragile_match of string                 (*  4 *)
+  | Ignored_partial_application             (*  5 *)
+  | Labels_omitted of string list           (*  6 *)
+  | Method_override of string list          (*  7 *)
+  | Partial_match of string                 (*  8 *)
+  | Missing_record_field_pattern of string  (*  9 *)
+  | Non_unit_statement                      (* 10 *)
+  | Redundant_case                          (* 11 *)
+  | Redundant_subpat                        (* 12 *)
+  | Instance_variable_override of string list (* 13 *)
+  | Illegal_backslash                       (* 14 *)
+  | Implicit_public_methods of string list  (* 15 *)
+  | Unerasable_optional_argument            (* 16 *)
+  | Undeclared_virtual_method of string     (* 17 *)
+  | Not_principal of string                 (* 18 *)
+  | Non_principal_labels of string          (* 19 *)
+  | Ignored_extra_argument                  (* 20 *)
+  | Nonreturning_statement                  (* 21 *)
+  | Preprocessor of string                  (* 22 *)
+  | Useless_record_with                     (* 23 *)
+  | Bad_module_name of string               (* 24 *)
+  | All_clauses_guarded                     (* 8, used to be 25 *)
+  | Unused_var of string                    (* 26 *)
+  | Unused_var_strict of string             (* 27 *)
+  | Wildcard_arg_to_constant_constr         (* 28 *)
+  | Eol_in_string                           (* 29 *)
+  | Duplicate_definitions of string * string * string * string (* 30 *)
+  | Module_linked_twice of string * string * string (* 31 *)
+  | Unused_value_declaration of string      (* 32 *)
+  | Unused_open of string                   (* 33 *)
+  | Unused_type_declaration of string       (* 34 *)
+  | Unused_for_index of string              (* 35 *)
+  | Unused_ancestor of string               (* 36 *)
+  | Unused_constructor of string * constructor_usage_warning (* 37 *)
+  | Unused_extension of string * bool * constructor_usage_warning (* 38 *)
+  | Unused_rec_flag                         (* 39 *)
+  | Name_out_of_scope of string * string list * bool   (* 40 *)
+  | Ambiguous_name of string list * string list * bool * string (* 41 *)
+  | Disambiguated_name of string            (* 42 *)
+  | Nonoptional_label of string             (* 43 *)
+  | Open_shadow_identifier of string * string (* 44 *)
+  | Open_shadow_label_constructor of string * string (* 45 *)
+  | Bad_env_variable of string * string     (* 46 *)
+  | Attribute_payload of string * string    (* 47 *)
+  | Eliminated_optional_arguments of string list (* 48 *)
+  | No_cmi_file of string * string option   (* 49 *)
+  | Unexpected_docstring of bool            (* 50 *)
+  | Wrong_tailcall_expectation of bool      (* 51 *)
+  | Fragile_literal_pattern                 (* 52 *)
+  | Misplaced_attribute of string           (* 53 *)
+  | Duplicated_attribute of string          (* 54 *)
+  | Inlining_impossible of string           (* 55 *)
+  | Unreachable_case                        (* 56 *)
+  | Ambiguous_var_in_pattern_guard of string list (* 57 *)
+  | No_cmx_file of string                   (* 58 *)
+  | Flambda_assignment_to_non_mutable_value (* 59 *)
+  | Unused_module of string                 (* 60 *)
+  | Unboxable_type_in_prim_decl of string   (* 61 *)
+  | Constraint_on_gadt                      (* 62 *)
+  | Erroneous_printed_signature of string   (* 63 *)
+  | Unsafe_array_syntax_without_parsing     (* 64 *)
+  | Redefining_unit of string               (* 65 *)
+  | Unused_open_bang of string              (* 66 *)
+  | Unused_functor_parameter of string      (* 67 *)
+  | Match_on_mutable_state_prevent_uncurry  (* 68 *)
+  | Unused_field of string * field_usage_warning (* 69 *)
+  | Missing_mli                             (* 70 *)
+;;
+
+type alert = {kind:string; message:string; def:loc; use:loc}
+
+val parse_options : bool -> string -> alert option;;
+
+val parse_alert_option: string -> unit
+  (** Disable/enable alerts based on the parameter to the -alert
+      command-line option.  Raises [Arg.Bad] if the string is not a
+      valid specification.
+  *)
+
+val without_warnings : (unit -> 'a) -> 'a
+  (** Run the thunk with all warnings and alerts disabled. *)
+
+val is_active : t -> bool;;
+val is_error : t -> bool;;
+
+val defaults_w : string;;
+val defaults_warn_error : string;;
+
+type reporting_information =
+  { id : string
+  ; message : string
+  ; is_error : bool
+  ; sub_locs : (loc * string) list;
+  }
+
+val report : t -> [ `Active of reporting_information | `Inactive ]
+val report_alert : alert -> [ `Active of reporting_information | `Inactive ]
+
+exception Errors;;
+
+val check_fatal : unit -> unit;;
+val reset_fatal: unit -> unit
+
+val help_warnings: unit -> unit
+
+type state
+val backup: unit -> state
+val restore: state -> unit
+val mk_lazy: (unit -> 'a) -> 'a Lazy.t
+    (** Like [Lazy.of_fun], but the function is applied with
+        the warning/alert settings at the time [mk_lazy] is called. *)
diff --git a/vim/merlin/autoload/ctrlp/locate.vim b/vim/merlin/autoload/ctrlp/locate.vim
new file mode 100644
index 0000000..b5efe4b
--- /dev/null
+++ b/vim/merlin/autoload/ctrlp/locate.vim
@@ -0,0 +1,80 @@
+" merlin extension to CtrlP <https://github.com/ctrlpvim/ctrlp.vim>
+
+" Init {{{1
+if exists('g:loaded_ctrlp_locate') && g:loaded_ctrlp_locate
+	fini
+en
+let g:loaded_ctrlp_locate = 1
+
+MerlinPy <<EOF
+import vim
+import merlin
+
+merlin_ctrlp_locate_line = 0
+merlin_ctrlp_locate_col = 0
+
+def merlin_ctrlp_locate_update_cursor_pos():
+    global merlin_ctrlp_locate_pos
+    merlin_ctrlp_locate_pos = vim.current.window.cursor
+
+def merlin_ctrlp_locate_do_expand(base, vimvar):
+    try:
+        pos = (merlin_ctrlp_locate_pos[0], merlin_ctrlp_locate_pos[1])
+        l = merlin.command("expand-prefix", "-prefix", base, 
+                           "-position", merlin.fmtpos(pos))
+        l = l['entries']
+        l = map(lambda prop: prop['name'], l)
+        l = merlin.uniq(sorted(l))
+        for prop in l:
+          name = prop.replace("'", "''")
+          vim.command("call add(%s, '%s')" % (vimvar, name))
+    except merlin.MerlinExc as e:
+        merlin.try_print_error(e)
+
+EOF
+
+cal add(g:ctrlp_ext_vars, {
+	\ 'init': 'ctrlp#locate#init()',
+	\ 'accept': 'ctrlp#locate#accept',
+	\ 'lname': 'locate',
+	\ 'sname': 'ml',
+	\ 'type': 'tabs',
+	\ 'sort': 0,
+	\ 'nolim': 1,
+	\ })
+
+let s:id = g:ctrlp_builtins + len(g:ctrlp_ext_vars)
+let s:init_string = "(* Start typing to get a list of identifiers. *)"
+
+" Public {{{1
+function! ctrlp#locate#update_cursor_pos()
+  MerlinPy merlin_ctrlp_locate_update_cursor_pos()
+endfunction
+
+
+function! ctrlp#locate#init()
+  return [s:init_string]
+endfunction
+
+function! ctrlp#locate#filter(items, str, limit, mmode, ispath, crfile, regex)
+  let l:compl = []
+  MerlinPy merlin_ctrlp_locate_do_expand(vim.eval("a:str"), "l:compl")
+  return l:compl
+endfunction
+
+fu! ctrlp#locate#accept(mode, str)
+  call ctrlp#exit()
+  if a:str == s:init_string
+    " do nothing
+  else
+    MerlinPy merlin.vim_locate_at_cursor(vim.eval("a:str"))
+    silent! normal! zvzz
+  endif
+endf
+
+fu! ctrlp#locate#id()
+	retu s:id
+endf
+"}}}
+
+" vim:fen:fdm=marker:fmr={{{,}}}:fdl=0:fdc=1:ts=2:sw=2:sts=2
diff --git a/vim/merlin/autoload/ctrlp/outline.vim b/vim/merlin/autoload/ctrlp/outline.vim
new file mode 100644
index 0000000..0794e68
--- /dev/null
+++ b/vim/merlin/autoload/ctrlp/outline.vim
@@ -0,0 +1,93 @@
+" merlin extension to CtrlP <https://github.com/ctrlpvim/ctrlp.vim>
+
+" Init {{{1
+if exists('g:loaded_ctrlp_outline') && g:loaded_ctrlp_outline
+  fini
+en
+let g:loaded_ctrlp_outline = 1
+
+MerlinPy <<EOF
+
+import vim
+import merlin
+
+merlin_ctrlp_outlines = []
+merlin_ctrlp_context = None
+
+def merlin_ctrlp_linearize(prefix, lst):
+    global merlin_ctrlp_outlines
+    for x in lst:
+        name = "%s%s" % (prefix, x['name'])
+        merlin_ctrlp_outlines.append(
+          {'name': name, 'pos': x['start'], 'kind': x['kind']})
+        merlin_ctrlp_linearize(name + ".", x['children'])
+
+def merlin_ctrlp_get_outlines():
+    global merlin_ctrlp_outlines
+    merlin_ctrlp_outlines[:] = []
+    merlin_ctrlp_linearize("", merlin.command2(["outline"], context=merlin_ctrlp_context))
+    merlin_ctrlp_outlines.sort(key = lambda x: len(x['name']))
+
+def merlin_ctrlp_outline_init():
+    merlin_ctrlp_get_outlines()
+    if len(merlin_ctrlp_outlines) == 0:
+        return
+    longest = len(merlin_ctrlp_outlines[-1]['name'])
+    i = 0
+    for x in merlin_ctrlp_outlines:
+        name = x['name'].replace("'", "''")
+        vim.command("call add(l:modules, '%4d : %*s\t--\t%s')" %
+                    (i, longest, name, x['kind']))
+        i += 1
+
+def merlin_ctrlp_outline_accept():
+    idx = int(vim.eval("a:str").strip().split(' ')[0])
+    try:
+        x = merlin_ctrlp_outlines[idx]
+        l = x['pos']['line']
+        c = x['pos']['col']
+        vim.current.window.cursor = (l, c)
+    except KeyError as e:
+        print(str(e))
+
+def merlin_ctrlp_preinit():
+  global merlin_ctrlp_context
+  merlin_ctrlp_context = merlin.current_context()
+
+EOF
+
+cal add(g:ctrlp_ext_vars, {
+	\ 'init': 'ctrlp#outline#init()',
+	\ 'accept': 'ctrlp#outline#accept',
+	\ 'lname': 'outline',
+	\ 'sname': 'ml',
+	\ 'type': 'tabs',
+	\ 'sort': 0,
+	\ 'nolim': 1,
+	\ })
+
+let s:id = g:ctrlp_builtins + len(g:ctrlp_ext_vars)
+
+fu! ctrlp#outline#preinit()
+  MerlinPy merlin_ctrlp_preinit()
+endf
+
+" Public {{{1
+fu! ctrlp#outline#init()
+  let l:modules = []
+  MerlinPy merlin_ctrlp_outline_init() 
+  return l:modules
+endf
+
+fu! ctrlp#outline#accept(mode, str)
+  call ctrlp#exit()
+  MerlinPy merlin_ctrlp_outline_accept()
+  silent! normal! zvzz
+endf
+
+fu! ctrlp#outline#id()
+	retu s:id
+endf
+"}}}
+
+" vim:fen:fdm=marker:fmr={{{,}}}:fdl=0:fdc=1:ts=2:sw=2:sts=2
diff --git a/vim/merlin/autoload/merlin.py b/vim/merlin/autoload/merlin.py
new file mode 100644
index 0000000..41c1aab
--- /dev/null
+++ b/vim/merlin/autoload/merlin.py
@@ -0,0 +1,901 @@
+import subprocess
+import json
+import vim
+import re
+import os
+import sys
+from sys import platform
+
+enclosing_types = [] # nothing to see here
+current_enclosing = -1
+atom_bound = re.compile('[a-z_0-9A-Z\'`.]')
+re_wspaces = re.compile("[\n ]+")
+re_spaces = re.compile(" +")
+re_spaces_around_nl = re.compile(" *\n *")
+re_error_warning = re.compile(r"Error \(warning (\d+)\): ")
+
+protocol_version = 3
+
+######## ERROR MANAGEMENT
+
+class MerlinExc(Exception):
+    def __init__(self, value):
+        self.value = value
+    def __str__(self):
+        return repr(self.value)
+
+class Failure(MerlinExc):
+    pass
+
+class Error(MerlinExc):
+    pass
+
+class MerlinException(MerlinExc):
+    pass
+
+def vimprint(msg):
+    msg = msg.replace('"',r'\"')
+    vim.command("call merlin#ShortEcho(\"%s\")" % msg)
+
+def try_print_error(e, msg=None):
+    try:
+        raise e
+    except Error as e:
+        if msg: vimprint(msg)
+        else: vimprint(e.value)
+    except Exception as e:
+        # Always print to stdout
+        # vim try to be 'smart' and prepend a backtrace when writing to stderr
+        # WTF?!
+        if msg: vimprint(msg)
+        else:
+            msg = str(e)
+            if re.search('Not_found',msg):
+                vimprint("error: Not found")
+                return None
+            elif re.search('Cmi_format.Error', msg):
+                if vim.eval('exists("b:merlin_incompatible_version")') == '0':
+                    vim.command('let b:merlin_incompatible_version = 1')
+                    vimprint("The version of merlin you're using doesn't support this version of ocaml")
+                return None
+            vimprint(msg)
+
+def vim_codec():
+    # Vim passed incorrectly encoded strings to python2.
+    # This could be worked around by manually decoding using the buffer
+    # encoding.
+    # However, python3 handling of unicode is a bit better, so "str()"
+    # shouldn't be decoded. So we assume that vim did the right thing before.
+    if sys.version_info >= (3,0):
+        return ((lambda str: str), (lambda str: str))
+    else:
+        encoding = vim.eval("&fileencoding") or \
+                   vim.eval("&encoding") or \
+                   "ascii"
+        return ((lambda str: str.encode(encoding)), \
+                (lambda str: str.decode(encoding)))
+
+def catch_and_print(f, msg=None):
+    try:
+        return f()
+    except MerlinExc as e:
+        try_print_error(e, msg=msg)
+
+def concat_map(f, args):
+    return [item for arg in args for item in f(arg)]
+
+######## PROCESS MANAGEMENT
+
+def current_context():
+    filename = vim.eval("expand('%:p')")
+    content = "\n".join(vim.current.buffer) + "\n"
+    return (filename, content)
+
+last_commands = []
+
+def merlin_exec(args, input=""):
+    global last_commands
+    env = os.environ
+    path = vim.eval("merlin#SelectBinary()")
+    if vim.eval("exists('b:merlin_env')") == '1':
+        env = env.copy()
+        newenv = vim.eval("b:merlin_env")
+        for key in newenv:
+            env[key] = newenv[key]
+    else:
+        env = os.environ
+    try:
+        cmd = [path] + list(args)
+        last_commands.insert(0, cmd)
+        if len(last_commands) > 5: last_commands.pop()
+        # As for OCaml, 64-bit Python still has sys.platform == win32
+        # Note that owing to a long-standing bug in Python, stderr must be given
+        # (see https://bugs.python.org/issue3905)
+        if platform == "win32":
+            info = subprocess.STARTUPINFO()
+            info.dwFlags |= subprocess.STARTF_USESHOWWINDOW
+            info.wShowWindow = subprocess.SW_HIDE
+            process = subprocess.Popen(
+                    cmd,
+                    stdin=subprocess.PIPE,
+                    stdout=subprocess.PIPE,
+                    stderr=subprocess.PIPE,
+                    startupinfo=info,
+                    universal_newlines=True,
+                    env=env
+                    )
+        else:
+            process = subprocess.Popen(
+                    cmd,
+                    stdin=subprocess.PIPE,
+                    stdout=subprocess.PIPE,
+                    stderr=subprocess.PIPE,
+                    universal_newlines=True,
+                    env=env
+                    )
+        # Send buffer content
+        (response, errors) = process.communicate(input=input)
+        if errors:
+            buf = int(vim.eval("merlin#LogBuffer()"))
+            vim.buffers[buf].append(errors.split('\n'))
+        return response
+    except OSError as e:
+        vimprint("Failed starting ocamlmerlin. Please ensure that ocamlmerlin binary is executable.")
+        raise e
+
+verbosity_counter = (None,None)
+
+def command2(args, context=None, track_verbosity=None):
+    global verbosity_counter
+    if track_verbosity:
+        if track_verbosity is True:
+            track_verbosity = args
+        if verbosity_counter[0] == track_verbosity:
+            verbosity_counter = (track_verbosity,verbosity_counter[1]+1)
+        else:
+            verbosity_counter = (track_verbosity,0)
+        verbosity = ["-verbosity",str(verbosity_counter[1])]
+    else:
+        verbosity = []
+    (filename, content) = context or current_context()
+    if vim_is_set("g:merlin_debug"):
+        log_errors = ["-log-file", "-"]
+    else:
+        log_errors = []
+    cmdline = ["server"] + list(args) + ["-filename",filename] + verbosity + \
+            concat_map(lambda ext: ("-extension",ext), vim_list_if_set("b:merlin_extensions")) + \
+            concat_map(lambda pkg: ("-I",pkg), vim_list_if_set("b:merlin_packages_path")) + \
+            concat_map(lambda dm: ("-dot-merlin",dm), vim_list_if_set("b:merlin_dot_merlins")) + \
+            log_errors + \
+            vim.eval('g:merlin_binary_flags') + \
+            vim_list_if_set('b:merlin_flags')
+
+    result = json.loads(merlin_exec(cmdline,input=content))
+    if result['notifications']:
+        notifications = "\n".join(result['notifications'])
+        vimprint("(merlin) notifications:\n" + notifications)
+    class_ = result['class']
+    value = result['value']
+    if class_ == "return":
+        return value
+    elif class_ == "failure":
+        raise Failure(value)
+    elif class_ == "error":
+        raise Error(value)
+    elif class_ == "exception":
+        raise MerlinException(value)
+
+def command(*args):
+    return command2(args)
+
+def uniq(seq):
+    seen = set()
+    seen_add = seen.add
+    return [ x for x in seq if not (x in seen or seen_add(x))]
+
+def vim_is_set(name, default=False):
+    if not vim.eval('exists("%s")' % name):
+        return default
+    return not (vim.eval(name) in ["", "0", "false"])
+
+def vim_list_if_set(name):
+    return vim.eval('exists("{0}") ? {0} : []'.format(name))
+
+def fmtpos(arg):
+    if arg is None:
+        return "end"
+    elif isinstance(arg, dict):
+        line = arg['line']
+        col = arg['col']
+    elif isinstance(arg, tuple) or isinstance(arg, list):
+        (line, col) = arg
+    else:
+        raise ValueError("fmtpos takes None, (line,col) or { 'line' : _, 'col' : _ }")
+    return "{0}:{1}".format(line, col)
+
+######## BASIC COMMANDS
+
+def command_version():
+    try:
+        str = merlin_exec(["-version"])
+        print(str)
+    except MerlinExc as e:
+        try_print_error(e)
+
+def display_load_failures(result):
+    if 'failures' in result and result['failures']:
+        failures = ", ".join(result['failures'])
+        vimprint("merlin: " + failures)
+
+def command_complete_cursor(base,pos):
+    with_doc = vim_is_set('g:merlin_completion_with_doc', default=True)
+    cmd = ["complete-prefix", "-position", fmtpos(pos), "-prefix", base,
+           "-doc", (with_doc and "y" or "n")]
+    return command2(cmd,track_verbosity=True)
+
+def command_document(path, pos):
+    try:
+        if path is not None:
+            cmd = ["document", "-identifier", path, "-position", fmtpos(pos)]
+        else:
+            cmd = ["document", "-position", fmtpos(pos)]
+        print(command2(cmd))
+    except MerlinExc as e:
+        try_print_error(e)
+
+def differs_from_current_file(path):
+    buf_path = vim.eval("expand('%:p')")
+    return buf_path != path
+
+def vim_fnameescape(s):
+    return vim.eval("fnameescape('%s')" % s.replace("'","''"))
+
+def goto_file_and_point(pos_or_err):
+    if not isinstance(pos_or_err, dict):
+        print(pos_or_err)
+    else:
+        l = pos_or_err['pos']['line']
+        c = pos_or_err['pos']['col']
+        split_method = vim.eval('g:merlin_split_method')
+        # save the current position in the jump list
+        vim.command("normal! m'")
+        if "file" in pos_or_err and differs_from_current_file(pos_or_err['file']):
+            fname = vim_fnameescape(pos_or_err['file'])
+            if split_method == "never":
+                vim.command(":keepjumps e %s" % fname)
+            elif "tab" in split_method:
+                if "always" in split_method:
+                    vim.command(":keepjumps tab split %s" % fname)
+                else:
+                    vim.command(":keepjumps tab drop %s" % fname)
+            elif "vertical" in split_method:
+                vim.command(":keepjumps vsplit %s" % fname)
+            else:
+                vim.command(":keepjumps split %s" % fname)
+        elif "always" in split_method:
+            if "tab" in split_method:
+                vim.command(":tab split")
+            elif "vertical" in split_method:
+                vim.command(":vsplit")
+            else:
+                vim.command(":split")
+        # TODO: move the cursor using vimscript, so we can :keepjumps?
+        vim.current.window.cursor = (l, c)
+
+def command_locate(path, pos):
+    try:
+        choice = vim.eval('g:merlin_locate_preference')
+        if pos is None:
+            return command("locate", "-prefix", path, "-look-for", choice)
+        else:
+            if path is None:
+                pos_or_err = command("locate", "-look-for", choice, "-position", fmtpos(pos))
+            else:
+                pos_or_err = command("locate", "-prefix", path, "-look-for", choice, "-position", fmtpos(pos))
+        goto_file_and_point(pos_or_err)
+    except MerlinExc as e:
+        try_print_error(e)
+
+
+def command_locate_type(pos):
+    try:
+        pos_or_err = command("locate-type", "-position", fmtpos(pos))
+        goto_file_and_point(pos_or_err)
+            
+    except MerlinExc as e:
+        try_print_error(e)
+
+def command_motion(cmd, target, pos):
+    try:
+        pos_or_err = command(cmd, "-target", target, "-position", fmtpos(pos))
+        if not isinstance(pos_or_err, dict):
+            print(pos_or_err)
+        else:
+            l = pos_or_err['pos']['line']
+            c = pos_or_err['pos']['col']
+            # save the current position in the jump list
+            vim.command("normal! m'")
+            # TODO: move the cursor using vimscript, so we can :keepjumps?
+            try:
+                vim.current.window.cursor = (l, c)
+            except:
+                vim.command("$")
+    except MerlinExc as e:
+        try_print_error(e)
+
+def command_occurrences(pos):
+    try:
+        lst_or_err = command("occurrences", "-identifier-at", fmtpos(pos))
+        if not isinstance(lst_or_err, list):
+            print(lst_or_err)
+        else:
+            return lst_or_err
+    except MerlinExc as e:
+        try_print_error(e)
+
+def command_holes():
+    try:
+        lst_or_err = command("holes")
+        if not isinstance(lst_or_err, list):
+            print(lst_or_err)
+        else:
+            return lst_or_err
+    except MerlinExc as e:
+        try_print_error(e)
+
+######## VIM FRONTEND
+
+def vim_complete_prepare(str):
+    return re.sub(re_wspaces, " ", str).replace("'", "''").strip()
+
+def vim_complete_prepare_preserve_newlines(str):
+    return re.sub(re_spaces_around_nl, "\n", re.sub(re_spaces, " ", str)).replace("'", "''").strip()
+
+def vim_fillentries(entries, vimvar):
+    prep = vim_complete_prepare
+    prep_nl = vim_complete_prepare_preserve_newlines
+    for prop in entries:
+        vim.command("let tmp = {'word':'%s','menu':'%s','info':'%s','kind':'%s'}" %
+                (prep(prop['name']),prep(prop['desc']),prep_nl(prop['info']),prep(prop['kind'][:1])))
+        vim.command("call add(%s, tmp)" % vimvar)
+
+# Complete
+def vim_complete_cursor(base, suffix, vimvar):
+    vim.command("let %s = []" % vimvar)
+    try:
+        completions = command_complete_cursor(base,vim.current.window.cursor)
+        nb_entries = len(completions['entries'])
+        prep = vim_complete_prepare
+        if completions['context'] and completions['context'][0] == 'application':
+            app = completions['context'][1]
+            if not base or base == suffix:
+                for label in app['labels']:
+                    name = label['name']
+                    if not name.startswith(suffix): name = name.replace("?","~")
+                    if name.startswith(suffix):
+                        nb_entries = nb_entries + 1
+                        vim.command("let l:tmp = {'word':'%s','menu':'%s','info':'%s','kind':'%s'}" %
+                                (prep(name),prep(label['name'] + ':' + label['type']),'','~'))
+                        vim.command("call add(%s, l:tmp)" % vimvar)
+            show_argtype = vim.eval("g:merlin_completion_argtype")
+            if ((show_argtype == 'always' or (show_argtype == 'several' and nb_entries > 1))
+                    and (not suffix or atom_bound.match(suffix[0]))
+                    and app['argument_type'] != "'_a"):
+                vim.command("let l:tmp = {'word':'%s','abbr':'<type>','kind':':','menu':'%s','empty':1}" %
+                        (prep(suffix),prep(app['argument_type'])))
+                vim.command("call insert(%s, l:tmp)" % vimvar)
+        vim_fillentries(completions['entries'], vimvar)
+        return (nb_entries > 0)
+    except MerlinExc as e:
+        try_print_error(e)
+        return False
+
+def vim_expand_prefix(base, vimvar, kinds=[]):
+    vim.command("let %s = []" % vimvar)
+    try:
+        kinds = concat_map(lambda kind: ("-kind",kind), kinds)
+        args = ["expand-prefix",
+                "-position", fmtpos(vim.current.window.cursor),
+                "-prefix", base] + kinds
+        l = command2(args)
+        l = l['entries']
+        l = map(lambda prop: prop['name'], l)
+        l = uniq(sorted(l))
+        for prop in l:
+            name = prop.replace("'", "''")
+            vim.command("call add(%s, '%s')" % (vimvar, name))
+    except MerlinExc as e:
+        try_print_error(e)
+
+def vim_polarity_search(query, vimvar):
+    vim.command("let %s = []" % vimvar)
+    try:
+        l = command("search-by-polarity", "-query", query, "-position", fmtpos(vim.current.window.cursor))
+        vim_fillentries(l['entries'], vimvar)
+    except MerlinExc as e:
+        try_print_error(e)
+
+# Error listing
+def vim_loclist(vimvar, ignore_warnings):
+    vim.command("let %s = []" % vimvar)
+    errors = command("errors")
+    bufnr = vim.current.buffer.number
+    nr = 0
+    for error in errors:
+        ty = 'E'
+        if error['type'] == 'warning':
+            if vim.eval(ignore_warnings) == 'true':
+                continue
+            ty = 'W'
+        msg = re.sub(re_wspaces, " ", error['message']).replace("'", "''")
+        if msg.startswith("Warning "):
+            msg = msg[8:]
+        elif msg.startswith("Error: "):
+            msg = msg[7:]
+        elif msg.startswith("Error (warning"):
+            msg = re.sub(re_error_warning, r"\1: ", msg)
+        lnum = 1
+        col = 1
+        if 'start' in error:
+            lnum = error['start']['line']
+            col = error['start']['col'] + 1
+        end_lnum = 1
+        end_col = 1
+        if 'end' in error:
+            end_lnum = error['end']['line']
+            end_col = error['end']['col']
+        vim.command("let l:tmp = {'bufnr':%d,'lnum':%d,'col':%d,'end_lnum':%d,'end_col':%d,'vcol':0,'nr':%d,'pattern':'','text':'%s','type':'%s','valid':1}" %
+                (bufnr, lnum, col, end_lnum, end_col, nr, msg, ty))
+        nr = nr + 1
+        vim.command("call add(%s, l:tmp)" % vimvar)
+
+# Locate
+def vim_locate_at_cursor(path):
+    command_locate(path, vim.current.window.cursor)
+
+def vim_locate_under_cursor():
+    vim_locate_at_cursor(None)
+
+def vim_locate_type_at_cursor():
+    command_locate_type(vim.current.window.cursor)
+
+# Jump and Phrase motion
+def vim_jump_to(target):
+    command_motion("jump", target, vim.current.window.cursor)
+
+def vim_jump_default():
+  vim_jump_to("fun let module match")
+
+def vim_phrase_prev():
+    command_motion("phrase", "prev", vim.current.window.cursor)
+
+def vim_phrase_next():
+    command_motion("phrase", "next", vim.current.window.cursor)
+
+# Document
+def vim_document_at_cursor(path):
+    command_document(path, vim.current.window.cursor)
+
+def vim_document_under_cursor():
+    vim_document_at_cursor(None)
+
+# Occurrences
+def vim_occurrences(vimvar):
+    vim.command("let %s = []" % vimvar)
+    line, col = vim.current.window.cursor
+    lst = command_occurrences((line, col))
+    lst = map(lambda x: x['start'], lst)
+    bufnr = vim.current.buffer.number
+    nr = 0
+    cursorpos = 0
+    for pos in lst:
+        lnum = pos['line']
+        lcol = pos['col']
+        if (lnum, lcol) <= (line, col): cursorpos = nr
+        text = vim.current.buffer[lnum - 1]
+        text = text.replace("'", "''")
+        vim.command("let l:tmp = {'bufnr':%d,'lnum':%d,'col':%d,'vcol':0,'nr':%d,'pattern':'','text':'%s','type':'I','valid':1}" %
+                (bufnr, lnum, lcol + 1, nr, text))
+        nr = nr + 1
+        vim.command("call add(%s, l:tmp)" % vimvar)
+    return cursorpos + 1
+
+def vim_occurrences_search():
+    line, col = vim.current.window.cursor
+    lst = command_occurrences((line, col))
+    result = ""
+    over = ""
+    start_col = 0
+    for pos in lst:
+        current = easy_matcher_wide(pos['start'], pos['end'])
+        l1 = pos['start']['line']
+        c1 = pos['start']['col']
+        c2 = pos['end']['col']
+        if line == l1 and col >= c1 and col <= c2:
+            over = current
+            start_col = c1
+        elif result == "":
+            result = current
+        else:
+            result = result + "\\|" + current
+    return "[%s, '%s', '%s']" % (start_col, over, result)
+
+def vim_occurrences_replace(content):
+    cursor = vim.current.window.cursor
+    lst = command_occurrences(cursor)
+    lst.reverse()
+    for pos in lst:
+        if pos['start']['line'] == pos['end']['line']:
+            mlen = pos['end']['col'] - pos['start']['col']
+            matcher = make_matcher(pos['start'], pos['end'])
+            query = ":%s/{0}.\\{{{1}\\}}/{2}/".format(matcher,mlen,content)
+            vim.command(query)
+    vim.current.window.cursor = cursor
+
+def vim_refactor_open(mode):
+    cursor = vim.current.window.cursor
+    lst = command("refactor-open","-position",fmtpos(cursor),"-action",mode)
+    lst.reverse()
+    for pos in lst:
+        if pos['start']['line'] == pos['end']['line']:
+            mlen = pos['end']['col'] - pos['start']['col']
+        matcher = make_matcher(pos['start'], pos['end'])
+        query = ":%s/{0}.\\{{{1}\\}}/{2}/".format(matcher,mlen,pos['content'])
+        vim.command(query)
+    vim.current.window.cursor = cursor
+
+# Expression typing
+def vim_type(expr):
+    cmd = ["type-expression",
+            "-expression", expr,
+            "-position", fmtpos(vim.current.window.cursor)]
+    try:
+        ty = command2(cmd)
+        res = {'type': str(ty), 'matcher': '', 'tail_info':''}
+        return json.dumps(res)
+    except MerlinExc as e:
+        if re.search('Not_found',str(e)):
+            return '{}'
+        else:
+            try_print_error(e)
+            return '{}'
+
+def bounds_of_ocaml_atom_at_pos(to_line, col):
+    line = vim.current.buffer[to_line]
+    start = col
+    stop = col
+    while start > 0:
+        if atom_bound.match(line[start - 1]) is None:
+            break
+        else:
+            start -= 1
+    while stop < len(line):
+        if atom_bound.match(line[stop]) is None:
+            break
+        else:
+            stop += 1
+    return (line[start:stop], start, stop)
+
+def vim_type_reset():
+    global enclosing_types
+    global current_enclosing
+    enclosing_types = [] # reset
+    current_enclosing = -1
+
+def replace_buffer_portion(start, end, txt, jump = True):
+    (encode,decode) = vim_codec()
+
+    start_line = start['line'] - 1
+    b = vim.current.buffer
+
+    fst_line = b[start_line]
+    lst_line = b[end['line'] - 1]
+
+    prefix = fst_line[0:start['col']]
+    suffix = lst_line[end['col']:len(lst_line)]
+
+    del b[start_line:end['line']]
+
+    txt = decode(prefix) + txt + decode(suffix)
+    lines = txt.split('\n')
+    lines.reverse()
+    nb_lines = 0
+    for line in lines:
+        nb_lines += 1
+        b[start_line:start_line] = [ encode(line) ]
+
+    # Properly reindent the modified lines
+    vim.current.window.cursor = (start['line'], 0)
+    vim.command('silent normal %d==' % nb_lines)
+
+    if jump:
+      # We look for a hole to move the cursor to in the range we replaced
+      vim_next_hole(start_line, start_line + nb_lines)
+
+def vim_case_analysis():
+    global enclosing_types
+    global current_enclosing
+
+    if enclosing_types == []:
+        to_line, to_col = vim.current.window.cursor
+        try:
+            enclosing_types = command("type-enclosing", "-position", fmtpos((to_line,to_col)))
+            if enclosing_types != []:
+                current_enclosing = 0
+            else:
+                atom, _, _ = bounds_of_ocaml_atom_at_pos(to_line - 1, to_col)
+                print("didn't manage to destruct '%s'" % atom)
+                return
+        except MerlinExc as e:
+            try_print_error(e)
+            return
+
+    tmp = enclosing_types[current_enclosing]
+    try:
+        result = command("case-analysis", "-start", fmtpos(tmp['start']),
+                                          "-end", fmtpos(tmp['end']))
+        tmp = result[0]
+        txt = result[1]
+        replace_buffer_portion(tmp['start'], tmp['end'], txt)
+
+
+    except MerlinExc as e:
+        try_print_error(e)
+
+    vim_type_reset()
+
+def type_enclosing_at_pos(to_line, to_col):
+    global enclosing_types
+    global current_enclosing
+    vim_type_reset()
+    try:
+        enclosing_types = command2(
+                ["type-enclosing",
+                 "-position", fmtpos((to_line, to_col)),
+                 "-index", "0"
+                ],
+                track_verbosity=True
+                )
+        if enclosing_types != []:
+            return vim_next_enclosing()
+        else:
+            atom, start, stop = bounds_of_ocaml_atom_at_pos(to_line - 1, to_col)
+            tmp = {'start': {'line':to_line, 'col':start},
+                   'end':   {'line':to_line, 'col':stop }}
+            tmp['matcher'] = make_matcher(tmp['start'], tmp['end'])
+            tmp['atom'] = atom
+            return json.dumps(tmp)
+    except MerlinExc as e:
+        try_print_error(e)
+        return '{}'
+
+def vim_type_enclosing_at_mouse():
+    bufnr = vim.vvars['beval_bufnr']
+    if bufnr != vim.current.buffer.number:
+        return '{}'
+    line = vim.vvars['beval_lnum']
+    col = vim.vvars['beval_col']
+    return type_enclosing_at_pos(line, col)
+
+def vim_type_enclosing():
+    to_line, to_col = vim.current.window.cursor
+    return type_enclosing_at_pos(to_line, to_col)
+
+def move_cursor_and_type(line, col):
+    vim.current.window.cursor = (line, col)
+    typ = json.loads(vim_type_enclosing())
+    return typ['type']
+
+def vim_previous_hole():
+    line, col = vim.current.window.cursor
+    holes = command_holes()
+    holes.reverse()
+    for hole in holes:
+      hline = hole['start']['line']
+      hcol = hole['start']['col']
+      if (hline, hcol) < (line, col):
+        vim.current.window.cursor = (hline, hcol)
+        print(hole['type'])
+        return
+    # If no hole was found before the cursor we jump
+    # to the last hole of the file if any.
+    if len(holes) > 0:
+      hline = holes[0]['start']['line']
+      hcol = holes[0]['start']['col']
+      vim.current.window.cursor = (hline, hcol)
+      print(holes[0]['type'])
+
+def vim_next_hole(min = 0, max = float('inf')):
+    min = float(min)
+    max = float(max)
+    line, col = vim.current.window.cursor
+    holes = command_holes()
+
+    for hole in holes:
+      hline = hole['start']['line']
+      hcol = hole['start']['col']
+      if hline >= min and (hline, hcol) >= (line, col) and hline <= max:
+        vim.current.window.cursor = (hline, hcol)
+        print(hole['type'])
+        return
+
+    # If no hole was found after the cursor we jump
+    # to the first hole of the file if any.
+    if max == float('inf') and len(holes) > 0:
+      hline = holes[0]['start']['line']
+      hcol = holes[0]['start']['col']
+      vim.current.window.cursor = (hline, hcol)
+      print(holes[0]['type'])
+
+def vim_construct(depth):
+    vimvar = "b:constr_result"
+    vim.command("let %s = []" % vimvar)
+    line, col = vim.current.window.cursor
+    try:
+      result = command(
+        "construct",
+        "-max-depth", depth,
+        "-position", fmtpos((line, col)))
+      loc = result[0]
+      txts = result[1]
+
+      if len(txts) == 1:
+        # If there is only one answer we replace it immediately
+        vim.current.window.cursor = (loc['start']['line'], loc['start']['col'])
+        replace_buffer_portion(loc['start'], loc['end'], txts[0])
+
+      elif len(txts) > 1:
+        # If there is more we remove the hole
+        replace_buffer_portion(loc['start'], loc['end'], " ", jump = False)
+        vim.current.window.cursor = (loc['start']['line'], loc['start']['col'])
+
+        # and write the alternatives in the b:constr_result list:
+        for txt in txts:
+          vim.command("call add(%s, {'word':'%s'})" % (vimvar, txt))
+
+    except MerlinExc as e:
+      try_print_error(e)
+
+def easy_matcher_wide(start, stop):
+    startl = ""
+    startc = ""
+    if start['line'] > 0:
+        startl = "\%{0}l".format(start['line'])
+    if start['col'] > 0:
+        startc = "\%{0}c".format(start['col'] + 1)
+    return '{0}{1}.*\%{2}l\%{3}c'.format(startl, startc, stop['line'], stop['col'] + 1)
+
+def easy_matcher(start, stop):
+    startl = ""
+    startc = ""
+    if start['line'] > 0:
+        startl = "\%>{0}l".format(start['line'] - 1)
+    if start['col'] > 0:
+        startc = "\%>{0}c".format(start['col'])
+    return '{0}{1}\%<{2}l\%<{3}c'.format(startl, startc, stop['line'] + 1, stop['col'] + 1)
+
+def hard_matcher(start, stop):
+    first_start = {'line' : start['line'], 'col' : start['col']}
+    first_stop =  {'line' : start['line'], 'col' : 4242}
+    first_line = easy_matcher(first_start, first_stop)
+    mid_start = {'line' : start['line']+1, 'col' : 0}
+    mid_stop =  {'line' : stop['line']-1 , 'col' : 4242}
+    middle = easy_matcher(mid_start, mid_stop)
+    last_start = {'line' : stop['line'], 'col' : 0}
+    last_stop =  {'line' : stop['line'], 'col' : stop['col']}
+    last_line = easy_matcher(last_start, last_stop)
+    return "{0}\|{1}\|{2}".format(first_line, middle, last_line)
+
+def make_matcher(start, stop):
+    if start['line'] == stop['line']:
+        return easy_matcher(start, stop)
+    else:
+        return hard_matcher(start, stop)
+
+def enclosing_tail_info(record):
+    if record['tail'] == 'call': return ' (* tail call *)'
+    if record['tail'] == 'position': return ' (* tail position *)'
+    return ''
+
+def enclosing_type_text(record):
+    global enclosing_types
+
+    # The server has an undocumented functionality where it still returns *all*
+    # enclosing nodes when the `type-enclosing` command is passed `-index` (this
+    # is contrary to the documentation of the protocol); with only the requested
+    # element having an actual type-string attached. The remaining elements do
+    # not have their type calculated (which *is* in line with the protocol
+    # documentation); and instead simply have their *index in the response*
+    # reported in the `type` field.
+    #
+    # tl;dr If our `enclosing_types` cache has an `int` value in `type`, then
+    # the actual value has to be requested from the server again.
+    if isinstance(record['type'], int):
+        # The indexes in the cache correspond to the *innermost* request - but
+        # changing the cursor-postion of the request, will change the indexes of
+        # the response. Thus, I re-use the position of the innermost cached
+        # enclosing-type.
+        innermost_type = enclosing_types[0]
+
+        types = command2(
+                ["type-enclosing",
+                 "-position", fmtpos(innermost_type['start']),
+                 "-index", str(record['type'])
+                ],
+                track_verbosity=True
+                )
+
+        record['type'] = types[record['type']]['type']
+
+def vim_current_enclosing():
+    global enclosing_types
+    global current_enclosing
+    tmp = enclosing_types[current_enclosing]
+    tmp['matcher'] = make_matcher(tmp['start'], tmp['end'])
+
+    enclosing_type_text(tmp)
+
+    tmp['tail_info'] = enclosing_tail_info(tmp)
+    return json.dumps(tmp)
+
+def vim_next_enclosing():
+    if enclosing_types != []:
+        global current_enclosing
+        if current_enclosing < len(enclosing_types):
+            current_enclosing += 1
+        if current_enclosing < len(enclosing_types):
+            return vim_current_enclosing()
+    return '{}'
+
+def vim_prev_enclosing():
+    if enclosing_types != []:
+        global current_enclosing
+        if current_enclosing >= 0:
+            current_enclosing -= 1
+        if current_enclosing >= 0:
+            return vim_current_enclosing()
+    return '{}'
+
+# Finding files
+def vim_which(name,exts):
+    if not isinstance(exts, list): exts = [exts]
+    files = concat_map(lambda ext: ("-file",name+"."+ext), exts)
+    return command('path-of-source', *files)
+
+def vim_which_ext(exts,vimvar):
+    files = command('list-modules', *concat_map(lambda ext: ("-ext",ext), exts))
+    vim.command("let %s = []" % vimvar)
+    for f in sorted(set(files)):
+        vim.command("call add(%s, '%s')" % (vimvar, f))
+
+# Options listing
+def vim_flags_list(vimvar):
+    for x in command('flags-list'):
+        vim.command("call add(%s, '%s')" % (vimvar, x))
+
+def vim_extension_list(vimvar):
+    for x in command('extension-list'):
+        vim.command("call add(%s, '%s')" % (vimvar, x))
+
+def vim_findlib_list(vimvar):
+    for x in command('findlib-list'):
+        vim.command("call add(%s, '%s')" % (vimvar, x))
+
+# Stuff
+
+def setup_merlin():
+    result = command("check-configuration")
+    display_load_failures(result)
+    vim.command('let b:dotmerlin=[]')
+    # Tell merlin the content of the buffer.
+    # This allows merlin idle-job to preload content if nothing else is requested.
+    if 'dot_merlins' in result:
+        fnames = ','.join(map(lambda fname: '"'+fname+'"', result['dot_merlins']))
+        (enc, dec) = vim_codec()
+        fnames = enc(fnames)
+        vim.command('let b:dotmerlin=[{0}]'.format(fnames))
+
+def vim_last_commands():
+    global last_commands
+    args = map(lambda x: " ".join(x), last_commands)
+    print("Last merlin commands:\n" + "\n".join(args))
diff --git a/vim/merlin/autoload/merlin.vim b/vim/merlin/autoload/merlin.vim
new file mode 100644
index 0000000..c743c60
--- /dev/null
+++ b/vim/merlin/autoload/merlin.vim
@@ -0,0 +1,899 @@
+if !exists('g:merlin') | let g:merlin = {} | endif | let s:c = g:merlin
+
+if !exists('g:merlin_python_version')
+  if has('python3')
+    let g:merlin_python_version = 3
+  elseif has('python') || has('python2')
+    let g:merlin_python_version = 2
+  else
+    echoerr "Error: Required vim compiled with +python or +python3"
+    finish
+  endif
+endif
+
+if g:merlin_python_version == 3
+  command! -nargs=1 MerlinPy python3 <args>
+elseif g:merlin_python_version == 2
+  command! -nargs=1 MerlinPy python <args>
+else
+  echoerr "Error: Unknown version of python, expecting 2 or 3 (g:merlin_python_version = " . g:merlin_python_version . ")"
+  finish
+endif
+
+if !exists('g:merlin_split_method')
+  let g:merlin_split_method = 'horizontal'
+endif
+
+if !exists('g:merlin_locate_preference')
+  let g:merlin_locate_preference = 'ml'
+endif
+
+if !exists('g:merlin_binary_flags')
+  let g:merlin_binary_flags = []
+endif
+
+if !exists("g:merlin_ignore_warnings")
+  " strings are ugly, but at least I'm sure it's not converted in some weird
+  " value when passing it to python
+  let g:merlin_ignore_warnings = "false"
+endif
+
+if !exists("g:merlin_display_occurrence_list")
+  let g:merlin_display_occurrence_list = 1
+endif
+
+if !exists("g:merlin_display_error_list")
+  let g:merlin_display_error_list = 1
+endif
+
+if !exists("g:merlin_close_error_list")
+  let g:merlin_close_error_list = 1
+endif
+
+if !exists("g:merlin_type_history_height")
+  let g:merlin_type_history_height = 5
+endif
+
+if !exists("g:merlin_type_history_auto_open")
+  let g:merlin_type_history_auto_open = 5
+endif
+
+if !exists("g:merlin_completion_dwim")
+  let g:merlin_completion_dwim = 1
+endif
+
+if !exists("g:merlin_completion_argtype")
+  let g:merlin_completion_argtype = 'several'
+endif
+
+if !exists("g:merlin_completion_with_doc")
+  let g:merlin_completion_with_doc = "false"
+endif
+
+if !exists("g:merlin_disable_default_keybindings")
+  let g:merlin_disable_default_keybindings = 0
+endif
+
+if !exists('g:merlin_debug')
+  let g:merlin_debug = 0
+endif
+
+let s:current_dir=expand("<sfile>:p:h")
+silent! MerlinPy import sys, vim
+MerlinPy if not vim.eval("s:current_dir") in sys.path:
+\    sys.path.append(vim.eval("s:current_dir"))
+
+MerlinPy import merlin
+
+function! s:get_visual_selection()
+  let [lnum1, col1] = getpos("'<")[1:2]
+  let [lnum2, col2] = getpos("'>")[1:2]
+  let lines = getline(lnum1, lnum2)
+  let lines[-1] = lines[-1][: col2 - 1]
+  let lines[0] = lines[0][col1 - 1:]
+  return join(lines, "\n")
+endfunction
+
+function! merlin#WordUnderCursor()
+  return substitute(substitute(expand("<cWORD>"),"[;:),]*$","",""), "^[;:(,]*", "", "")
+endfunction
+
+function! merlin#FindFile(ext,file)
+  MerlinPy <<EOF
+fname = merlin.catch_and_print(lambda: merlin.vim_which(vim.eval("a:file"), vim.eval("a:ext")))
+if fname != None: vim.command("e "+ fname.replace(' ','\\ '))
+EOF
+endfunction
+
+function! merlin#Version()
+  MerlinPy merlin.command_version()
+endfunction
+
+function! merlin#Path(var,...)
+  if !exists("b:merlin_flags")
+    let b:merlin_flags = []
+  endif
+
+  for i in a:000
+    call add(b:merlin_flags, a:var)
+    call add(b:merlin_flags, fnameescape(i))
+  endfor
+endfunction
+
+function! merlin#MLList(ArgLead, CmdLine, CursorPos)
+  let l:files = []
+  MerlinPy merlin.vim_which_ext([".ml",".mli"], "l:files")
+  return join(l:files, "\n")
+endfunction
+
+function! merlin#MLIList(ArgLead, CmdLine, CursorPos)
+  let l:files = []
+  MerlinPy merlin.vim_which_ext([".mli",".ml"], "l:files")
+  return join(l:files, "\n")
+endfunction
+
+function! merlin#ExpandPrefix(ArgLead, CmdLine, CursorPos)
+  let l:compl = []
+  MerlinPy merlin.vim_expand_prefix(vim.eval("a:ArgLead"), "l:compl")
+  return l:compl
+endfunction
+
+function! merlin#ExpandTypePrefix(ArgLead, CmdLine, CursorPos)
+  let l:compl = []
+  MerlinPy merlin.vim_expand_prefix(vim.eval("a:ArgLead"), "l:compl",kinds=["type"])
+  return l:compl
+endfunction
+
+function! s:MakeCompletionList(var, pyfun)
+  let l:all = []
+  execute 'MerlinPy ' . a:pyfun . '("l:all")'
+  if exists(a:var)
+    let l:existing = copy(eval(a:var))
+    let l:all = filter(l:all, "index(l:existing, v:val) == -1")
+    call insert(l:all, join(map(l:existing, "fnameescape(v:val)"), " "))
+  endif
+  return join(l:all, "\n")
+endfunction
+
+function! merlin#CompleteExtensions(ArgLead, CmdLine, CursorPos)
+  return s:MakeCompletionList("b:merlin_extensions", "merlin.vim_extension_list")
+endfunction
+
+function! merlin#Extensions(...)
+  let b:merlin_extensions = a:000
+endfunction
+
+function! merlin#CompletePackages(ArgLead, CmdLine, CursorPos)
+  let l:all = map(systemlist("ocamlfind list"), "split(v:val)[0]")
+  if exists("b:merlin_packages")
+    let l:existing = copy(b:merlin_packages)
+    let l:all = filter(l:all, "index(l:existing, v:val) == -1")
+    call insert(l:all, join(map(l:existing, "fnameescape(v:val)"), " "))
+  endif
+  return join(l:all, "\n")
+endfunction
+
+function! merlin#Packages(...)
+  let b:merlin_packages = copy(a:000)
+  let arguments = join(map(b:merlin_packages, "shellescape(v:val)"), ' ')
+  let cmd = 'ocamlfind query ' . arguments
+  let b:merlin_packages_path = systemlist(cmd)
+endfunction
+
+function! merlin#CompleteFlags(ArgLead, CmdLine, CursorPos)
+  return s:MakeCompletionList("b:merlin_flags", "merlin.vim_flags_list")
+endfunction
+
+function! merlin#Flags(...)
+  let b:merlin_flags = a:000
+endfunction
+
+function! merlin#LogBuffer() abort
+  let l:filename = ":merlin-log:"
+  let l:buffer = bufnr(l:filename)
+
+  if l:buffer == -1
+    let l:buffer = bufnr(l:filename, v:true)
+
+    " Set up the buffer
+    call setbufvar(l:buffer, "&buftype", "nofile")
+    call setbufvar(l:buffer, "&bufhidden", "hide")
+    " 1 is 'noswapfile'
+    call setbufvar(l:buffer, "&swapfile", 0)
+  endif
+
+  return l:buffer
+endfunction
+
+function! merlin#DebugEnable()
+  let g:merlin_debug=1
+  split
+  execute "buffer " . merlin#LogBuffer()
+endfunction
+
+function! merlin#DebugDisable()
+  let g:merlin_debug=0
+endfunction
+
+function! s:ShowTypeEnclosing(type)
+  call s:StopHighlight()
+  if empty(a:type)
+    return
+  endif
+
+  let w:enclosing_zone = matchadd('EnclosingExpr', a:type['matcher'])
+  augroup MerlinHighlighting
+    au!
+    autocmd InsertEnter <buffer> call merlin#StopHighlight()
+    autocmd BufWinLeave <buffer> call merlin#StopHighlight()
+  augroup END
+
+  if ! has_key(a:type, 'type')
+    echohl WarningMsg
+    echo "didn't manage to type '" . a:type['atom'] . "'"
+    echohl None
+    return
+  endif
+
+  let g:merlin_latest_type = a:type['type']
+
+  if g:merlin_type_history_height <= 0 || v:version <= 703 || !has("patch-7.4.424")
+    echo a:type['type'] . a:type['tail_info']
+    return
+  endif
+
+  call merlin_type#Show(a:type['type'], a:type['tail_info'])
+endfunction
+
+function! merlin#YankLatestType()
+  if ! exists("g:merlin_latest_type")
+    echohl ErrorMsg | echo "no type available" | echohl None
+    return
+  endif
+  call setreg(v:register, g:merlin_latest_type)
+  echo "yanked" g:merlin_latest_type
+endfunction
+
+function! merlin#TypeOf(...)
+    if (a:0 > 1)
+        echoerr "TypeOf: too many arguments (expected 0 or 1)"
+    elseif (a:0 == 0) || (a:1 == "")
+        MerlinPy vim.command("let l:type = " + merlin.vim_type_enclosing())
+        call s:ShowTypeEnclosing(l:type)
+    else
+        MerlinPy vim.command("let l:type = " + merlin.vim_type(vim.eval("a:1")))
+        call s:ShowTypeEnclosing(l:type)
+    endif
+endfunction
+
+function! merlin#TypeOfSel()
+  call merlin#TypeOf(s:get_visual_selection())
+endfunction
+
+function! merlin#TypeAtBalloon()
+	MerlinPy vim.command("let l:type = " + merlin.vim_type_enclosing_at_mouse())
+	return get(l:type, 'type', '')
+endfunction
+
+function! merlin#ShowTypeAtBalloon()
+	echo merlin#TypeAtBalloon()
+	return ''
+endfunction
+
+function! merlin#PolaritySearch(debug,query)
+  let s:search_result = []
+  MerlinPy merlin.vim_polarity_search(vim.eval("a:query"), "s:search_result")
+  if a:debug != 1 && s:search_result != []
+    call feedkeys("i=merlin#PolarityComplete()\<CR>","n")
+  endif
+endfunction
+
+function! merlin#PolarityComplete()
+  call complete(col('.'), s:search_result)
+  return ''
+endfunction
+
+function! s:StopHighlight()
+  if exists('w:enclosing_zone') && w:enclosing_zone != -1
+    call matchdelete(w:enclosing_zone)
+    let w:enclosing_zone = -1
+  endif
+endfunction
+
+function! merlin#StopHighlight()
+  MerlinPy merlin.vim_type_reset()
+  call s:StopHighlight()
+  augroup MerlinHighlighting
+    au!
+  augroup END
+endfunction
+
+function! merlin#GrowEnclosing()
+  MerlinPy vim.command("let l:type = " + merlin.vim_next_enclosing())
+  call s:ShowTypeEnclosing(l:type)
+endfunction
+
+function! merlin#ShrinkEnclosing()
+  MerlinPy vim.command("let l:type = " + merlin.vim_prev_enclosing())
+  call s:ShowTypeEnclosing(l:type)
+endfunction
+
+function! merlin#Complete(findstart,base)
+  if a:findstart
+    " Synchronize merlin before completion, since vim modify the buffer
+    " (prefix is removed)
+    " Locate the start of the item, including ".", "->" and "[...]".
+    let line = getline('.')
+    let start = col('.') - 1
+    let lastword = -1
+    while start > 0
+      if line[start - 1] =~ '\(\w\|''\)'
+        let start -= 1
+      elseif line[start - 1] =~ '\.'
+        if lastword == -1
+          let lastword = start
+        endif
+        let start -= 1
+      else
+        break
+      endif
+    endwhile
+    if start > 0 && line[start - 1] =~ '[~?`]'
+      let start -= 1
+    endif
+
+    let s:compl_base = strpart(line, start, col('.') - 1 - start)
+
+    " Return the column of the last word, which is going to be changed.
+    " Remember the text that comes before it in s:compl_prefix.
+    if lastword == -1
+      let s:compl_prefix = ''
+      let s:compl_suffix = s:compl_base
+    else
+      let s:compl_prefix = strpart(line, start, lastword - start)
+      let s:compl_suffix = strpart(line, lastword, col('.') - 1 - lastword)
+    endif
+
+    " Query completion
+    let s:compl_result = []
+    MerlinPy vim.command("let l:compl_succeed = %d" %
+\    merlin.vim_complete_cursor(vim.eval("s:compl_base"),vim.eval("s:compl_suffix"),"s:compl_result"))
+
+    " If empty, switch to dwim
+    let s:compl_dwim = g:merlin_completion_dwim && !l:compl_succeed
+    if s:compl_dwim
+      let s:compl_prefix = ''
+      MerlinPy merlin.vim_expand_prefix(vim.eval("s:compl_base"),"s:compl_result")
+    endif
+
+    if lastword == -1 || s:compl_dwim
+      return start
+    else
+      return lastword
+    end
+  endif
+
+  " If prefix changed, update completion
+  let base = s:compl_prefix . a:base
+  if base != s:compl_base
+    let s:compl_base = base
+    if s:compl_dwim
+      MerlinPy merlin.vim_expand_prefix(vim.eval("base"),"s:compl_result")
+    else
+      MerlinPy merlin.vim_complete_cursor(vim.eval("base"),vim.eval("s:compl_suffix"),"s:compl_result")
+    endif
+  endif
+
+  " Workaround https://github.com/ocaml/merlin/issues/223 vim 704
+  return s:compl_result
+  "if v:version <= 703
+  "  return l:props
+  "else
+  "  return {'words': l:props, 'refresh': 'always'}
+  "endif
+endfunction
+
+function! merlin#Locate(...)
+  if (a:0 > 1)
+    echoerr "Locate: too many arguments (expected 0 or 1)"
+  elseif (a:0 == 0) || (a:1 == "")
+    MerlinPy merlin.vim_locate_under_cursor()
+  else
+    MerlinPy merlin.vim_locate_at_cursor(vim.eval("a:1"))
+  endif
+endfunction
+
+function! merlin#LocateType()
+  MerlinPy merlin.vim_locate_type_at_cursor()
+endfunction
+
+function! merlin#LocateImpl(...)
+  let l:pref = g:merlin_locate_preference
+  let g:merlin_locate_preference = 'implementation'
+  call call("merlin#Locate", a:000)
+  let g:merlin_locate_preference = l:pref
+endfunction
+
+function! merlin#LocateIntf(...)
+  let l:pref = g:merlin_locate_preference
+  let g:merlin_locate_preference = 'interface'
+  call call("merlin#Locate", a:000)
+  let g:merlin_locate_preference = l:pref
+endfunction
+
+function! merlin#Jump(...)
+  if (a:0 > 1)
+    echoerr "Jump: too many arguments (expected 0 or 1)"
+  elseif (a:0 == 0) || (a:1 == "")
+    MerlinPy merlin.vim_jump_default()
+  else
+    MerlinPy merlin.vim_jump_to(vim.eval("a:1"))
+  endif
+endfunction
+
+function! merlin#PhrasePrev()
+  MerlinPy merlin.vim_phrase_prev()
+endfunction
+
+function! merlin#PhraseNext()
+  MerlinPy merlin.vim_phrase_next()
+endfunction
+
+function! merlin#Document(...)
+  if (a:0 > 1)
+    echoerr "Document: to many arguments (expected 0 or 1)"
+  elseif (a:0 == 0) || (a:1 == "")
+    MerlinPy merlin.vim_document_under_cursor()
+  else
+    MerlinPy merlin.vim_document_at_cursor(vim.eval("a:1"))
+  endif
+endfunction
+
+function! merlin#InteractiveLocate()
+  if !exists('g:loaded_ctrlp')
+    echo "This function requires the CtrlP plugin to work"
+    " ctrl doesn't exist? Exiting.
+  else
+    if exists('g:ctrlp_match_func')
+        let l:match_fun = g:ctrlp_match_func
+    else
+        let l:match_fun = {}
+    endif
+
+    call ctrlp#locate#update_cursor_pos()
+
+    let g:ctrlp_match_func = { 'match': 'ctrlp#locate#filter' }
+    call ctrlp#init(ctrlp#locate#id())
+    let g:ctrlp_match_func = l:match_fun
+  endif
+endfunction
+
+function! merlin#Outline()
+  if !exists('g:loaded_ctrlp')
+    echo "This function requires the CtrlP plugin to work"
+    " ctrl doesn't exist? Exiting.
+  else
+    call ctrlp#outline#preinit()
+    call ctrlp#init(ctrlp#outline#id())
+  endif
+endfunction
+
+function! merlin#Occurrences()
+  let l:occurrences = []
+  let l:pos = 0
+  MerlinPy vim.command ("let l:pos = %d" % merlin.vim_occurrences("l:occurrences"))
+
+  if l:occurrences == []
+    return
+  endif
+
+  call setloclist(0, l:occurrences)
+  execute ":ll! " . l:pos
+  if g:merlin_display_occurrence_list
+    lopen
+  endif
+endfunction
+
+function! merlin#OccurrencesRename(text)
+  MerlinPy merlin.vim_occurrences_replace(vim.eval("a:text"))
+endfunction
+
+function! merlin#RefactorOpen(str)
+  MerlinPy merlin.vim_refactor_open(vim.eval("a:str"))
+endfunction
+
+function! merlin#ErrorLocList()
+  let l:errors = []
+  if !exists('b:merlin_error_check') || b:merlin_error_check == 1
+    MerlinPy <<EOF
+try:
+  merlin.vim_loclist("l:errors", "g:merlin_ignore_warnings")
+except merlin.MerlinException as e:
+  merlin.try_print_error(e)
+EOF
+  endif
+  return l:errors
+endfunction
+
+function! merlin#Errors()
+  let l:errors = merlin#ErrorLocList()
+  call setloclist(0, l:errors)
+  if len(l:errors) > 0
+    if g:merlin_display_error_list
+      lopen
+    endif
+  else
+    if g:merlin_close_error_list
+      lclose
+    endif
+  endif
+endfunction
+
+function! merlin#Destruct()
+  MerlinPy merlin.vim_case_analysis()
+endfunction
+
+function! merlin#PreviousHole()
+  MerlinPy merlin.vim_previous_hole()
+endfunction
+
+function! merlin#NextHole()
+  MerlinPy merlin.vim_next_hole()
+endfunction
+
+"'''''''''''"
+" CONSTRUCT "
+"'''''''''''"
+
+let b:merlin_construct_depth = 1
+let b:merlin_construct_done = 1
+let b:merlin_construct_lines_before = 0
+
+function! merlin#ConstructComplete(findstart, base)
+  " The function is called in two different ways:
+  " - First the function is called to find the start of the text to be completed.
+  " - Later the function is called to actually find the matches.
+  if a:findstart
+    let start = col('.') - 1
+    return start
+  endif
+  return b:constr_result
+endfunction
+
+function! merlin#ConstructDone()
+  if b:merlin_construct_done
+    " After the substitution we try to go to the the next hole
+    " TODO Don't if no substitution happened and rewrite the hole
+    call setpos('.', b:construct_saved_pos)
+    let start_line = b:construct_saved_pos[1]
+    let end_line = start_line + line('$') - b:merlin_construct_lines_before
+    MerlinPy merlin.vim_next_hole(vim.eval("start_line"), vim.eval("end_line"))
+    :call feedkeys("\<esc>")
+    :call feedkeys("\<Right>")
+
+    " We reset the depth and the mappings
+    let b:merlin_construct_depth = 1
+    :iunmap <buffer><expr> <c-i>
+    :iunmap <buffer><expr> <c-u>
+
+    " And we hook back the standard completion
+    setlocal omnifunc=merlin#Complete
+  else
+    let b:merlin_construct_done = 1
+  endif
+endfunction
+
+function! merlin#ConstructMore()
+  let b:merlin_construct_depth += 1
+  let b:merlin_construct_done = 0
+
+  " We cancel the previous omnicomplete and trigger a new Construct
+  return "\<c-e>\_\<esc>:MerlinConstruct\<enter>"
+endfunction
+
+function! merlin#ConstructLess()
+  if b:merlin_construct_depth > 1
+    let b:merlin_construct_depth -= 1
+    let b:merlin_construct_done = 0
+
+    " We cancel the previous omnicomplete and trigger a new Construct
+    return "\<c-e>\_\<esc>:MerlinConstruct\<enter>"
+  else
+    return ""
+  endif
+endfunction
+
+function! merlin#Construct()
+  " We save the number of lines in the file for future comparison
+  let b:merlin_construct_lines_before = line('$')
+
+  " We call construct
+  MerlinPy merlin.vim_construct(vim.eval("b:merlin_construct_depth"))
+  let b:construct_saved_pos = getpos(".")
+
+  " If multiple choices where found they are in the b:constr_result list
+  if len(b:constr_result) > 0
+    " We start Omnicomplete with the custom complete function
+    setlocal omnifunc=merlin#ConstructComplete
+    startinsert
+    call feedkeys("\<c-x>\<c-o>")
+
+    " Map keys for more or less
+    " TODO better choice of keys ?
+    :inoremap <buffer><expr> <c-i> merlin#ConstructMore()
+    :inoremap <buffer><expr> <c-u> merlin#ConstructLess()
+
+    " When it's done we switch back to merlin default completion
+    augroup MerlinConstruct
+      au!
+      autocmd CompleteDone <buffer> call merlin#ConstructDone()
+    augroup END
+  endif
+endfunction
+
+function! merlin#PreviousHole()
+  MerlinPy merlin.vim_previous_hole()
+endfunction
+
+function! merlin#NextHole()
+  MerlinPy merlin.vim_next_hole()
+endfunction
+
+function! merlin#Restart()
+  MerlinPy merlin.vim_restart()
+endfunction
+
+function! merlin#Reload()
+  MerlinPy merlin.vim_reload()
+endfunction
+
+" Copy-pasted from
+" https://github.com/ngn/dotfiles/blob/master/vim/autoload/ngn/common.vim
+function! merlin#setVisualSelection(a, b)
+" Save existing positions of marks 'a and 'b
+  let markASave = getpos("'a")
+  let markBSave = getpos("'b")
+" Move to a, enter visual mode, and move to b
+  call setpos("'a", [0, a:a[0], a:a[1], 0])
+  call setpos("'b", [0, a:b[0], a:b[1], 0])
+  normal! `bv`a
+" Restore positions of marks 'a and 'b
+  call setpos("'a", markASave)
+  call setpos("'b", markBSave)
+endfunction
+
+let s:phrase_counter = 0
+
+function! merlin#Phrase()
+  if s:phrase_counter
+      let s:phrase_counter = s:phrase_counter - 1
+  else
+    let [l1, c1] = getpos("'<")[1:2]
+    let [l2, c2] = getpos("'>")[1:2]
+    let s:phrase_counter = l2 - l1
+    MerlinPy merlin.vim_selectphrase("l1","c1","l2","c2")
+    call merlin#setVisualSelection([l1,c1],[l2,c2])
+  endif
+endfunction
+
+function! merlin#Register()
+  if @% == ":merlin-type-history:"
+    return
+  endif
+
+  """ Version  -----------------------------------------------------------------
+  command! -buffer -nargs=0 MerlinVersion call merlin#Version()
+
+  """ Error reporting  ---------------------------------------------------------
+  command! -buffer -nargs=0 MerlinErrorCheck call merlin#Errors()
+
+  """ Completion  --------------------------------------------------------------
+  setlocal omnifunc=merlin#Complete
+
+  """ TypeOf  ------------------------------------------------------------------
+  command! -buffer -complete=customlist,merlin#ExpandPrefix -nargs=? MerlinTypeOf call merlin#TypeOf(<q-args>)
+  command! -buffer -range -nargs=0 MerlinTypeOfSel call merlin#TypeOfSel()
+
+  command! -buffer -nargs=0 MerlinClearEnclosing  call merlin#StopHighlight()
+  command! -buffer -nargs=0 MerlinGrowEnclosing   call merlin#GrowEnclosing()
+  command! -buffer -nargs=0 MerlinShrinkEnclosing call merlin#ShrinkEnclosing()
+
+  command! -buffer -nargs=0 MerlinYankLatestType    call merlin#YankLatestType()
+  command! -buffer -nargs=0 MerlinToggleTypeHistory call merlin_type#ToggleTypeHistory()
+
+  if !exists('g:merlin_disable_default_keybindings') || !g:merlin_disable_default_keybindings
+    map  <silent><buffer> <LocalLeader>t :MerlinTypeOf<return>
+    map  <silent><buffer> <LocalLeader>n :MerlinGrowEnclosing<return>
+    map  <silent><buffer> <LocalLeader>p :MerlinShrinkEnclosing<return>
+    vmap <silent><buffer> <LocalLeader>t :MerlinTypeOfSel<return>
+  endif
+
+  """ Destruct  ----------------------------------------------------------------
+  command! -buffer -nargs=0 MerlinDestruct call merlin#Destruct()
+
+  """ Holes  ---------------------------------------------------------------
+  command! -buffer -nargs=0 MerlinNextHole call merlin#NextHole()
+  command! -buffer -nargs=0 MerlinPreviousHole call merlin#PreviousHole()
+
+  """ Construct  ---------------------------------------------------------------
+  command! -buffer -nargs=0 MerlinNextHole call merlin#NextHole()
+  command! -buffer -nargs=0 MerlinPreviousHole call merlin#PreviousHole()
+  command! -buffer -nargs=0 MerlinConstruct call merlin#Construct()
+
+  """ Locate  ------------------------------------------------------------------
+  command! -buffer -complete=customlist,merlin#ExpandPrefix -nargs=? MerlinLocate call merlin#Locate(<q-args>)
+  command! -buffer -complete=customlist,merlin#ExpandPrefix -nargs=? MerlinLocateImpl call merlin#LocateImpl(<q-args>)
+  command! -buffer -complete=customlist,merlin#ExpandPrefix -nargs=? MerlinLocateIntf call merlin#LocateIntf(<q-args>)
+  command! -buffer -nargs=0 MerlinILocate call merlin#InteractiveLocate()
+  command! -buffer -nargs=0 MerlinLocateType call merlin#LocateType()
+
+  if !exists('g:merlin_disable_default_keybindings') || !g:merlin_disable_default_keybindings
+    nmap <silent><buffer> gd  :MerlinLocate<return>
+  endif
+
+  """ Jump and Phrase motion ---------------------------------------------------
+  command! -buffer -complete=customlist,merlin#ExpandPrefix -nargs=? MerlinJump call merlin#Jump(<q-args>)
+  command! -buffer MerlinPhrasePrev call merlin#PhrasePrev()
+  command! -buffer MerlinPhraseNext call merlin#PhraseNext()
+  nmap <silent><buffer> [[ :MerlinPhrasePrev<cr>
+  nmap <silent><buffer> ]] :MerlinPhraseNext<cr>
+
+  """ Document  ----------------------------------------------------------------
+  command! -buffer -complete=customlist,merlin#ExpandPrefix -nargs=? MerlinDocument call merlin#Document(<q-args>)
+
+  """ Outline  -----------------------------------------------------------------
+  command! -buffer -nargs=0 MerlinOutline call merlin#Outline()
+
+  """ Occurrences  -------------------------------------------------------------
+  " Search
+  command! -buffer -nargs=0 MerlinOccurrences call merlin#Occurrences()
+  nmap <silent><buffer> <Plug>(MerlinSearchOccurrencesForward)  :call merlin_find#OccurrencesSearch('/')<cr>:let v:searchforward=1<cr>
+  nmap <silent><buffer> <Plug>(MerlinSearchOccurrencesBackward) :call merlin_find#OccurrencesSearch('?')<cr>:let v:searchforward=0<cr>
+
+  " Rename
+  command! -buffer -nargs=* MerlinRename call merlin#OccurrencesRename(<f-args>)
+  nmap <silent><buffer> <Plug>(MerlinRename) :call merlin_find#IncrementalRename()<cr>//<cr>c//e<cr>
+  nmap <silent><buffer> <Plug>(MerlinRenameAppend) :call merlin_find#IncrementalRename()<cr>//e<cr>a
+
+  " Text Objects
+  if exists("g:merlin_textobject_grow") && g:merlin_textobject_grow != ''
+    let l:k = g:merlin_textobject_grow
+
+    exe "vmap <silent><buffer>  " . l:k ":<C-U>call merlin_visual#Grow('v')<return>"
+    exe "vmap <silent><buffer> a" . l:k ":<C-U>call merlin_visual#GrowAround('v')<return>"
+    exe "vmap <silent><buffer> i" . l:k ":<C-U>call merlin_visual#GrowInside('v')<return>"
+
+    exe "omap <silent><buffer>  " . l:k ":<C-U>call merlin_visual#Grow('o')<return>"
+    exe "omap <silent><buffer> a" . l:k ":<C-U>call merlin_visual#GrowAround('o')<return>"
+    exe "omap <silent><buffer> i" . l:k ":<C-U>call merlin_visual#GrowInside('o')<return>"
+  endif
+
+  if exists("g:merlin_textobject_shrink") && g:merlin_textobject_shrink != ''
+    let l:k = g:merlin_textobject_shrink
+
+    exe "vmap <silent><buffer>  " . l:k ":<C-U>call merlin_visual#Shrink('v')<return>"
+    exe "vmap <silent><buffer> a" . l:k ":<C-U>call merlin_visual#ShrinkAround('v')<return>"
+    exe "vmap <silent><buffer> i" . l:k ":<C-U>call merlin_visual#ShrinkInside('v')<return>"
+
+    exe "omap <silent><buffer>  " . l:k ":<C-U>call merlin_visual#Shrink('o')<return>"
+    exe "omap <silent><buffer> i" . l:k ":<C-U>call merlin_visual#ShrinkInside('o')<return>"
+    exe "omap <silent><buffer> a" . l:k ":<C-U>call merlin_visual#ShrinkAround('o')<return>"
+  endif
+
+  """ Open / Unopen ------------------------------------------------------------
+  command! -buffer -nargs=0 MerlinRefactorOpen call merlin#RefactorOpen("unqualify")
+  command! -buffer -nargs=0 MerlinRefactorOpenQualify call merlin#RefactorOpen("qualify")
+
+  """ Path management  ---------------------------------------------------------
+  command! -buffer -nargs=* -complete=dir MerlinSourcePath call merlin#Path("-source-path", <f-args>)
+  command! -buffer -nargs=* -complete=dir MerlinBuildPath  call merlin#Path("-build-path", <f-args>)
+
+  """ Findlib  -----------------------------------------------------------------
+  command! -buffer -complete=custom,merlin#CompletePackages -nargs=* MerlinPackages call merlin#Packages(<f-args>)
+  " Backward compatibility
+  command! -buffer -complete=custom,merlin#CompletePackages -nargs=* MerlinUse      call merlin#Packages(<f-args>)
+
+  """ Flags management  --------------------------------------------------------
+  command! -buffer -complete=custom,merlin#CompleteFlags -nargs=* MerlinFlags    call merlin#Flags(<f-args>)
+  " Backward compatibility
+  command! -buffer -complete=custom,merlin#CompleteFlags -nargs=* MerlinSetFlags call merlin#Flags(<f-args>)
+
+  """ Extensions  --------------------------------------------------------------
+  command! -buffer -complete=custom,merlin#CompleteExtensions -nargs=* MerlinExtensions  call merlin#Extensions(<f-args>)
+
+  """ .merlin  -----------------------------------------------------------------
+  command! -buffer -nargs=0 GotoDotMerlin call merlin#GotoDotMerlin()
+  command! -buffer -nargs=0 EchoDotMerlin call merlin#EchoDotMerlin()
+  command! -buffer -nargs=0 MerlinGotoDotMerlin call merlin#GotoDotMerlin()
+  command! -buffer -nargs=0 MerlinEchoDotMerlin call merlin#EchoDotMerlin()
+
+  """ 'semantic movement'  -----------------------------------------------------
+  " TODO: bind (,),{,} ?
+  command! -buffer -nargs=0 MerlinPhrase call merlin#Phrase()
+
+  """ Polarity search
+  command! -buffer -complete=customlist,merlin#ExpandTypePrefix -nargs=+ MerlinSearch call merlin#PolaritySearch(0,<q-args>)
+
+  """ debug --------------------------------------------------------------------
+  command! -buffer -nargs=0 MerlinDebugLastCommands MerlinPy merlin.vim_last_commands()
+  command! -buffer -nargs=0 MerlinDebugDisable call merlin#DebugDisable()
+  command! -buffer -nargs=0 MerlinDebugEnable  call merlin#DebugEnable()
+
+  if !exists('g:merlin_disable_default_keybindings') || !g:merlin_disable_default_keybindings
+    vmap <silent><buffer> <TAB>         :<C-u>MerlinPhrase<return>
+  endif
+
+  call merlin#LoadProject()
+endfunction
+
+function! merlin#LoadProject()
+  if isdirectory(expand('%:p:h'))
+    MerlinPy merlin.setup_merlin()
+    if exists("b:dotmerlin") && exists("g:merlin_move_to_project") && g:merlin_move_to_project && len(b:dotmerlin) > 0
+      execute ":lchdir " . fnamemodify(b:dotmerlin[0], ":p:h")
+    endif
+  endif
+endfunction
+
+function! merlin#EchoDotMerlin()
+  if exists("b:dotmerlin")
+    echom "Using .merlin: " . join(b:dotmerlin, ', ')
+  else
+    echo "No .merlin found"
+  endif
+endfunction
+
+function! merlin#GotoDotMerlin()
+    if exists("b:dotmerlin")
+        execute ":e " . b:dotmerlin[0]
+    " TODO : it's plausible to create an empty one here instead by guessing
+    " where it should be located
+    else
+        echo "No .merlin found"
+    endif
+endfunction
+
+function! merlin#FindBinary()
+  if !has_key(s:c, 'ocamlmerlin_path')
+    if !has_key(s:c, 'merlin_home') || !has_key(s:c, 'merlin_parent')
+      runtime plugin/merlin.vim
+    endif
+    let s:choices = map(['ocamlmerlin','ocamlmerlin.native'], 's:c.merlin_parent."/bin/".v:val') + map(['ocamlmerlin','ocamlmerlin.native'], 's:c.merlin_home."/".v:val')
+    let s:available_choices = filter(s:choices, 'filereadable(v:val)')
+    if len(s:available_choices) > 0
+      let s:c.ocamlmerlin_path =  s:available_choices[0]
+    elseif executable('ocamlmerlin')
+      let s:c.ocamlmerlin_path = 'ocamlmerlin'
+    else
+      echoe "ocamlmerlin not found!"
+    endif
+    unlet s:choices
+  endif
+  return s:c.ocamlmerlin_path
+endfunction
+
+function! merlin#SelectBinary()
+  if !exists("b:merlin_path")
+    if exists("*MerlinSelectBinary")
+      let l:merlin_path = MerlinSelectBinary()
+      if !exists("b:merlin_path")
+        let b:merlin_path = l:merlin_path
+      end
+    else
+      let b:merlin_path = merlin#FindBinary()
+    end
+  endif
+  return b:merlin_path
+endfunction
+
+function! merlin#ShortEcho(msg)
+  " From http://vim.wikia.com/wiki/Get_shortened_messages_from_using_echomsg
+  " Suggested by @jordwalke
+  let saved=&shortmess
+  set shortmess+=T
+  exe "norm :echomsg a:msg\n"
+  let &shortmess=saved
+endfunction
+
+command! -nargs=1 -complete=custom,merlin#MLList  ML  call merlin#FindFile(["ml","mli"],<f-args>)
+command! -nargs=1 -complete=custom,merlin#MLIList MLI call merlin#FindFile(["mli","ml"],<f-args>)
diff --git a/vim/merlin/autoload/merlin_find.vim b/vim/merlin/autoload/merlin_find.vim
new file mode 100644
index 0000000..2ddd50b
--- /dev/null
+++ b/vim/merlin/autoload/merlin_find.vim
@@ -0,0 +1,46 @@
+function! merlin_find#OccurrencesSearch(mode)
+  MerlinPy vim.command("let [l:start_col, l:current, l:target] = " + merlin.vim_occurrences_search())
+  if l:target ==# ""
+    return
+  endif
+  let l:search = l:current . "\\|" . l:target
+  let @/ = l:search
+  execute "normal " . a:mode . l:search . "\<cr>"
+endfunction
+
+function! merlin_find#IncrementalRename()
+  MerlinPy vim.command("let [w:start_rename_col,w:current_target,w:rename_target] = " + merlin.vim_occurrences_search())
+  if w:rename_target ==# ""
+    echoerr "No occurrences found!"
+    return
+  endif
+  let l:edit_target = '\%' . line(".") . 'l\%' . (w:start_rename_col + 1) . 'c' . '.*\%#'
+  let w:enclosing_rename = matchadd('EnclosingExpr', l:edit_target . '\|' . w:rename_target)
+  let @/ = w:current_target
+  call merlin#StopHighlight()
+  augroup MerlinAutocmd
+    au!
+    autocmd InsertEnter <buffer> :let @/=''
+    autocmd InsertLeave <buffer> :silent call s:IncrementalRenameTerminate()
+  augroup END
+endfunction
+
+function! s:IncrementalRenameTerminate()
+  if !exists('w:enclosing_rename') || w:enclosing_rename ==# -1
+    return
+  endif
+  call matchdelete(w:enclosing_rename)
+  let w:enclosing_rename = -1
+  augroup MerlinAutocmd
+    au!
+  augroup END
+  let [l:buffer,l:line,l:col,l:off] = getpos(".")
+  let l:inserted = strpart(getline("."), w:start_rename_col, l:col - w:start_rename_col)
+  silent! undo
+  let l:target = w:current_target . '\|' . w:rename_target
+  let l:prev_gd=&gdefault
+  let &gdefault=0
+  silent execute '%sm/' . l:target . '/' . l:inserted . '/g'
+  let &gdefault=l:prev_gd
+  call setpos(".", [l:buffer, l:line, w:start_rename_col + 1, l:off])
+endfunction
diff --git a/vim/merlin/autoload/merlin_type.vim b/vim/merlin/autoload/merlin_type.vim
new file mode 100644
index 0000000..866fd83
--- /dev/null
+++ b/vim/merlin/autoload/merlin_type.vim
@@ -0,0 +1,254 @@
+function! s:CreateTypeHistory()
+  if exists("g:merlin_type_history")
+    return
+  endif
+  let t:merlin_restore_windows = winrestcmd()
+  silent execute "bot " . g:merlin_type_history_height . "split :merlin-type-history:"
+  setlocal filetype=ocaml
+  setlocal buftype=nofile
+  setlocal bufhidden=hide
+  setlocal noswapfile
+  setlocal nobuflisted
+  setlocal nonumber norelativenumber
+  let g:merlin_type_history = bufnr("%")
+endfunction
+
+function! merlin_type#HideTypeHistory(force)
+  let l:win = bufwinnr(g:merlin_type_history)
+  let l:cur = winnr()
+  if l:win >=# 0 && (a:force || l:cur !=# l:win)
+    exe l:win . "wincmd w"
+    close
+    exe l:cur . "wincmd w"
+    exe t:merlin_restore_windows
+    augroup MerlinTypeHistory
+      au!
+    augroup END
+  endif
+endfunction
+
+function! merlin_type#ShowTypeHistory()
+  call s:CreateTypeHistory()
+  let l:win = bufwinnr(g:merlin_type_history)
+  if l:win <# 0
+    let t:merlin_restore_windows = winrestcmd()
+    silent execute "bot " . g:merlin_type_history_height . "split"
+    silent execute "buffer" g:merlin_type_history
+  elseif winnr() !=# l:win
+    exe l:win . "wincmd w"
+  endif
+  normal! Gzb
+endfunction
+
+function! merlin_type#ToggleTypeHistory()
+  let l:exists = exists("g:merlin_type_history") && bufexists(g:merlin_type_history)
+  call s:CreateTypeHistory()
+  let l:win = bufwinnr(g:merlin_type_history)
+  if l:win <# 0 || !l:exists
+    call merlin_type#ShowTypeHistory()
+  else
+    call merlin_type#HideTypeHistory(1)
+  endif
+endfunction
+
+function! s:RecordType(type)
+  if ! exists("g:merlin_type_history")
+    let l:cur = winnr()
+    silent call s:CreateTypeHistory()
+    close
+    exe l:cur . "wincmd w"
+    exe t:merlin_restore_windows
+  endif
+
+  let l:view = winsaveview()
+
+  " vimscript can't append to a buffer without a refresh (?!)
+  MerlinPy << EOF
+idx = int(vim.eval("g:merlin_type_history"))
+typ = vim.eval("a:type")
+buf = None
+for buffer in vim.buffers:
+  if buffer.number == idx:
+    buf = buffer
+    break
+assert buf, "s:RecordType tried to access a nonexistent buffer"
+# nous souhaitons informer notre aimable clientèle qu'un combat d'infirme se
+# déroule à la ligne suivante
+typ = list(map(lambda x: " " if (x == "") else x, typ))
+l = len(buf)
+if l > 1:
+    # The following is an ugly hack: if we clear the buffer vim deletes it, so
+    # the user don't get to see every other type.
+    del buf[1:len(buf)]
+    buf.append(typ)
+else:
+    buf.append(typ)
+
+# Note that this leaves a blank line at the beginning of the buffer, but
+# it is apparently the desired behavior.
+
+EOF
+
+  call winrestview(l:view)
+endfunction
+
+function! merlin_type#Show(type, tail_info)
+
+  let l:user_lazyredraw = &lazyredraw
+  if l:user_lazyredraw ==# 0
+    set lazyredraw
+  endif
+
+  let l:msg = a:type . a:tail_info
+  let l:lines = split(l:msg, '\n')
+  call s:RecordType(l:lines)
+
+  if exists("t:merlin_autohide") && t:merlin_autohide == 1
+    let t:merlin_autohide = 0
+    call merlin_type#HideTypeHistory(0)
+  endif
+
+  let l:length = len(l:lines)
+
+  let l:win = bufwinnr(g:merlin_type_history)
+  let l:cur = winnr()
+  if l:win >=# 0
+    exe l:win . "wincmd w"
+    call s:TemporaryResize(l:length)
+    normal! Gzb
+  elseif l:length >=# g:merlin_type_history_auto_open
+    call merlin_type#ShowTypeHistory()
+    call s:TemporaryResize(l:length)
+    let t:merlin_autohide=1
+    normal! Gzb
+    let t:merlin_hide_type_history = 1
+  else
+    silent call merlin_type#ShowTypeHistory()
+    let l:end = line("$")
+    let l:start = l:end - l:length + 1
+    let l:msg = merlin_type#ShowLines(l:start, l:end)
+    close
+    exe t:merlin_restore_windows
+    " The message isn't always visible if we don't force a refresh here (?!)
+    redrawstatus
+    execute l:msg
+  endif
+  exe l:cur . "wincmd w"
+  augroup MerlinTypeHistory
+    au!
+    if gettabvar(tabpagenr(), "merlin_restore_type_history_height", 0)
+      autocmd CursorMoved,InsertEnter * call s:RestoreTypeHistoryHeight()
+    endif
+    if gettabvar(tabpagenr(), "merlin_hide_type_history", 0)
+      autocmd CursorMoved,InsertEnter * call merlin_type#HideTypeHistory(0)
+    endif
+  augroup END
+  unlet! t:merlin_restore_type_history_height
+  unlet! t:merlin_hide_type_history
+
+  if l:user_lazyredraw ==# 0
+    set nolazyredraw
+  endif
+endfunction
+
+function! s:TemporaryResize(height)
+  let l:win = bufwinnr(g:merlin_type_history)
+  let t:merlin_type_history_height = winheight(l:win)
+  let target_height = max([ g:merlin_type_history_height, a:height ])
+  let target_height = min([ target_height, line("$") - 1 ])
+  if t:merlin_type_history_height !=# target_height
+    execute "resize" . target_height
+  endif
+  if target_height ># g:merlin_type_history_height
+    let t:merlin_restore_type_history_height = 1
+  endif
+endfunction
+
+function! s:RestoreTypeHistoryHeight()
+  if ! exists("t:merlin_type_history_height")
+    return
+  endif
+  let l:win = bufwinnr(g:merlin_type_history)
+  let l:cur = winnr()
+  if l:win >=# 0 && l:cur !=# l:win
+    execute "normal! " . l:win . "\<c-w>w"
+    execute "resize" t:merlin_type_history_height
+    normal! Gzb
+    execute "normal! " . l:cur . "\<c-w>w"
+    augroup MerlinTypeHistory
+      au!
+    augroup END
+  endif
+endfunction
+
+" Adapted from http://www.vim.org/scripts/script.php?script_id=381
+" Originally created by Gary Holloway
+function! merlin_type#ShowLines(start, end)
+
+  let l:start = a:start
+  let l:end = a:end
+
+  let cmd        = ''
+  let prev_group = ' x '     " Something that won't match any syntax group name.
+
+  let show = a:end - a:start + 1
+  if &cmdheight <# show
+    let g:merlin_previous_cmdheight = &cmdheight
+    augroup MerlinCleanupCommandHeight
+      au!
+      autocmd CursorMoved * call s:RestoreCmdHeight()
+    augroup END
+    let &cmdheight = show
+  endif
+
+  let shown = 0
+  let index = l:start
+  while index <=# l:end
+    if shown ># 0
+      let cmd = cmd . '\n'
+    endif
+
+    let shown  = shown + 1
+    let current_line = getline(index)
+    let length = strlen(current_line)
+    let column = 1
+
+    if length ==# 0
+      let cmd = cmd . 'echon "'
+    endif
+
+    while column <=# length "{
+      let group = synIDattr(synID(index, column, 1), 'name')
+      if group !=# prev_group
+        if cmd !=# ''
+             let cmd = cmd . '"|'
+        endif
+        let cmd = cmd . 'echohl ' . (group ==# '' ? 'NONE' : group) . '|echon "'
+        let prev_group = group
+      endif
+      let char = strpart(current_line, column - 1, 1)
+      if char ==# '"' || char ==# "\\"
+        let char = '\' . char
+      endif
+      let cmd = cmd . char
+      let column = column + 1
+    endwhile "}
+
+    if shown ==# &cmdheight
+         break
+    endif
+
+    let index = index + 1
+  endwhile "}
+
+  let cmd = cmd . '"|echohl NONE'
+  return cmd
+endfunction
+
+function! s:RestoreCmdHeight()
+  let &cmdheight = g:merlin_previous_cmdheight
+  echo ""
+  augroup MerlinCleanupCommandHeight
+    au!
+  augroup END
+endfunction
diff --git a/vim/merlin/autoload/merlin_visual.vim b/vim/merlin/autoload/merlin_visual.vim
new file mode 100644
index 0000000..e146899
--- /dev/null
+++ b/vim/merlin/autoload/merlin_visual.vim
@@ -0,0 +1,283 @@
+function! s:GetVisualEnclosing()
+  return [ w:visual_enclosing['start']['line'],
+         \ w:visual_enclosing['start']['col'],
+         \ w:visual_enclosing['end']['line'],
+         \ w:visual_enclosing['end']['col'] ]
+endfunction
+
+function! s:IsLeaf(expr)
+  return match(a:expr, "^[-a-zA-Z0-9._'`]*$") >=# 0
+    \ || match(a:expr, '^".*"$') >=# 0
+    \ || match(a:expr, '^[-+*/%<>@!]*$') >=# 0
+endfunction
+
+function! merlin_visual#GrowEnclosing(mode)
+  let max_count = max([1, v:count])
+  let [l1, c1] = getpos("'<")[1:2]
+  let [l2, c2] = getpos("'>")[1:2]
+
+  let init = 0
+
+  if a:mode ==# 'v' && exists('w:l1') && w:l1 !=# -1
+    if w:l1 ==# l1 && abs(w:c1 - c1) <=# 1 && w:l2 ==# l2 && abs(w:c2 - c2) <=# 1
+      let c1 = c1 - 1
+    else
+      MerlinPy merlin.vim_type_reset()
+      let init = 1
+    endif
+  else
+    let init = 1
+  endif
+
+  let kill_loop = 0
+
+  if init
+    let max_count = max_count - 1
+    MerlinPy vim.command("let w:visual_enclosing = %s" % merlin.vim_type_enclosing())
+    if empty(w:visual_enclosing)
+      return
+    endif
+    let [l1, c1, l2, c2] = s:GetVisualEnclosing()
+    if l1 ==# l2
+      let selection = getline(l1)
+      let expr = strpart(selection, c1, c2 - c1)
+      if s:IsLeaf(expr)
+        " Selecting a word-like thing can be done with M or a standard
+        " vim text object. We skip over it so that the initial selection
+        " captures a bigger expression.
+        let max_count = max_count + 1
+        let kill_loop = kill_loop + 1
+      endif
+    endif
+  endif
+
+  while max_count ># 0 && kill_loop <# 5
+    let max_count = max_count - 1
+    let prev_l1 = l1
+    let prev_l2 = l2
+    let prev_c1 = c1
+    let prev_c2 = c2
+    MerlinPy vim.command("let w:visual_enclosing = %s" % merlin.vim_next_enclosing())
+    if empty(w:visual_enclosing)
+      break
+    endif
+    let [l1, c1, l2, c2] = s:GetVisualEnclosing()
+    if l1 ==# l2
+      let selection = getline(l1)
+      let expr = strpart(selection, c1, c2 - c1)
+      if s:IsLeaf(expr)
+        " Selecting a word-like thing can be done with M or a standard
+        " vim text object. We skip over it so that the initial selection
+        " captures a bigger expression.
+        let max_count = max_count + 1
+        let kill_loop = kill_loop + 1
+      endif
+    elseif prev_l1 ==# l1 && prev_c1 ==# c1 && prev_l2 ==# l2 && prev_c2 ==# c2
+      " Merlin doesn't always expand the selection: When the argument under
+      " the cursor is polymorphic, it will show it twice (with and without
+      " the type instantiation.) We don't want that for selections, so we
+      " expand it one more time.
+      let max_count = max_count + 1
+      " And sometimes, it's just not possible to expand more.
+      let kill_loop = kill_loop + 1
+    else
+      let kill_loop = 0
+    endif
+  endwhile
+  
+  if !(exists('w:l1') && w:l1 ==# l1 && w:c1 ==# c1 && w:l2 ==# l2 && w:c2 ==# c2)
+    let w:l1 = l1
+    let w:c1 = c1 + 1
+    let w:l2 = l2
+    let w:c2 = c2
+  endif
+
+endfunction
+
+function! merlin_visual#ShrinkEnclosing(mode)
+  let max_count = max([1, v:count])
+  let [l1, c1] = getpos("'<")[1:2]
+  let [l2, c2] = getpos("'>")[1:2]
+
+  let init = 0
+
+  if a:mode ==# 'v' && exists('w:l1') && w:l1 !=# -1
+    if w:l1 ==# l1 && abs(w:c1 - c1) <=# 1 && w:l2 ==# l2 && abs(w:c2 - c2) <=# 1
+    else
+      MerlinPy merlin.vim_type_reset()
+      let init = 1
+    endif
+  else
+    let init = 1
+  endif
+
+  if init ==# 1
+    MerlinPy vim.command("let w:visual_enclosing = %s" % merlin.vim_type_enclosing())
+    if empty(w:visual_enclosing)
+      return
+    endif
+    let [l1, c1, l2, c2] = s:GetVisualEnclosing()
+  endif
+
+  while max_count ># 0
+    let max_count = max_count - 1
+    MerlinPy vim.command("let w:visual_enclosing = %s" % merlin.vim_prev_enclosing())
+    if empty(w:visual_enclosing)
+      break
+    endif
+    let [l1, c1, l2, c2] = s:GetVisualEnclosing()
+  endwhile
+  
+  if !(exists('w:l1') && w:l1 ==# l1 && w:c1 ==# c1 && w:l2 ==# l2 && w:c2 ==# c2)
+    let w:l1 = l1
+    let w:c1 = c1 + 1
+    let w:l2 = l2
+    let w:c2 = c2
+  endif
+endfunction
+
+function! merlin_visual#GrowLeftSpaces()
+  while w:l1 ># 0
+    let left = getline(w:l1)
+    while w:c1 ># 1 && left[w:c1 - 2] ==# ' '
+      let w:c1 = w:c1 - 1
+    endwhile
+    if w:l1 ># 0 && w:c1 <=# 1
+      let w:l1 = w:l1 - 1
+      let w:c1 = strlen(getline(w:l1)) + 1
+    else
+      break
+    endif
+  endwhile
+endfunction
+
+function! merlin_visual#GrowRightSpaces()
+  let max_line = line('$')
+  while w:l2 <=# max_line
+    let right = getline(w:l2)
+    let line_length = strlen(right)
+    while w:c2 <# line_length && right[w:c2] ==# ' '
+      let w:c2 = w:c2 + 1
+    endwhile
+    if line_length ==# 0 || w:c2 >=# line_length
+      if w:l2 ==# max_line
+        break
+      endif
+      let right = getline(w:l2 + 1)
+      if strlen(right) ># 0 && right[0] !=# ' '
+        break
+      endif
+      let w:l2 = w:l2 + 1
+      let w:c2 = 0
+    else
+      break
+    endif
+  endwhile
+endfunction
+
+function! merlin_visual#ShrinkLeftSpaces()
+  while 1
+    let left = getline(w:l1)
+    let len = strlen(left) - 1
+    while w:c1 <=# len && left[w:c1 - 1] ==# ' '
+      let w:c1 = w:c1 + 1
+    endwhile
+    if len <=# 0 || w:c1 >=# len
+      let w:l1 = w:l1 + 1
+      let w:c1 = 1
+    else
+      break
+    endif
+  endwhile
+endfunction
+
+function! merlin_visual#ShrinkRightSpaces()
+  while 1
+    let right = getline(w:l2)
+    let len = strlen(right)
+    while w:c2 >=# 1 && right[w:c2 - 1] ==# ' '
+      let w:c2 = w:c2 - 1
+    endwhile
+    if len ==# 0 || w:c2 <=# 1
+      let w:l2 = w:l2 - 1
+      let w:c2 = strlen(getline(w:l2))
+    else
+      break
+    endif
+  endwhile
+endfunction
+
+function! merlin_visual#AroundSpaces()
+  call merlin_visual#GrowLeftSpaces()
+  call merlin_visual#GrowRightSpaces()
+
+  let left = getline(w:l1)
+  let l = left[w:c1 - 2]
+  if l !=# '(' && l !=# '['
+    let w:c1 = w:c1 + 1
+  endif
+
+  let right = getline(w:l2)
+  let r = left[w:c2]
+  if r !=# ')' && r !=# ']' && w:c2 >=# 1
+    let w:c2 = w:c2 - 1
+  endif
+endfunction
+
+function! merlin_visual#InsideSpaces()
+  while 1
+    call merlin_visual#ShrinkLeftSpaces()
+    call merlin_visual#ShrinkRightSpaces()
+
+    let left = getline(w:l1)
+    let right = getline(w:l2)
+    let l = left[w:c1 - 1]
+    let r = right[w:c2 - 1]
+    if l ==# '(' && r ==# ')'
+      let w:c1 = w:c1 + 1
+      let w:c2 = w:c2 - 1
+    elseif strpart(left, w:c1 - 1, 5) ==# "begin" && strpart(right, w:c2 - 3, 3) ==# "end"
+      let w:c1 = w:c1 + 4
+      let w:c2 = w:c2 - 3
+    elseif strpart(left, w:c1 - 1, 6) ==# "struct" && strpart(right, w:c2 - 3, 3) ==# "end"
+      let w:c1 = w:c1 + 5
+      let w:c2 = w:c2 - 3
+    else
+      break
+    endif
+  endwhile
+endfunction
+
+function! merlin_visual#Grow(mode)
+  call merlin_visual#GrowEnclosing(a:mode)
+  call merlin#setVisualSelection([w:l1,w:c1],[w:l2,w:c2])
+endfunction
+
+function! merlin_visual#GrowAround(mode)
+  call merlin_visual#GrowEnclosing(a:mode)
+  call merlin_visual#AroundSpaces()
+  call merlin#setVisualSelection([w:l1,w:c1],[w:l2,w:c2])
+endfunction
+
+function! merlin_visual#GrowInside(mode)
+  call merlin_visual#GrowEnclosing(a:mode)
+  call merlin_visual#InsideSpaces()
+  call merlin#setVisualSelection([w:l1,w:c1],[w:l2,w:c2])
+endfunction
+
+function! merlin_visual#Shrink(mode)
+  call merlin_visual#ShrinkEnclosing(a:mode)
+  call merlin#setVisualSelection([w:l1,w:c1],[w:l2,w:c2])
+endfunction
+
+function! merlin_visual#ShrinkAround(mode)
+  call merlin_visual#ShrinkEnclosing(a:mode)
+  call merlin_visual#AroundSpaces()
+  call merlin#setVisualSelection([w:l1,w:c1],[w:l2,w:c2])
+endfunction
+
+function! merlin_visual#ShrinkInside(mode)
+  call merlin_visual#ShrinkEnclosing(a:mode)
+  call merlin_visual#InsideSpaces()
+  call merlin#setVisualSelection([w:l1,w:c1],[w:l2,w:c2])
+endfunction
diff --git a/vim/merlin/autoload/neomake/makers/ft/ocaml.vim b/vim/merlin/autoload/neomake/makers/ft/ocaml.vim
new file mode 100644
index 0000000..a921dde
--- /dev/null
+++ b/vim/merlin/autoload/neomake/makers/ft/ocaml.vim
@@ -0,0 +1,11 @@
+function! neomake#makers#ft#ocaml#EnabledMakers() abort
+  return ['merlin']
+endfunction
+
+function! neomake#makers#ft#ocaml#merlin() abort
+  let maker = {}
+  function! maker.get_list_entries(jobinfo)
+    return merlin#ErrorLocList()
+  endfunction
+  return maker
+endfunction
diff --git a/vim/merlin/doc/merlin.txt b/vim/merlin/doc/merlin.txt
new file mode 100644
index 0000000..b741bc9
--- /dev/null
+++ b/vim/merlin/doc/merlin.txt
@@ -0,0 +1,405 @@
+*merlin.txt*	For Vim version 7.3 	Last change: 2013 March 30
+
+                                Merlin ~
+
+                Context sensitive completion for OCaml. ~
+
+==============================================================================
+COMMANDS                                                     *merlin-commands*
+
+:MerlinSourcePath [dir]                                    *:MerlinSourcePath*
+
+When dir is given adds, for the current session, the directory to the list of
+directories where merlin looks for ml[i] files.
+
+If no argument is given, it will list those directories.
+
+:MerlinBuildPath [dir]                                      *:MerlinBuildPath*
+
+Same as |:MerlinSourcePath| but for cmi files.
+
+:MerlinUse package [, package]*                                   *:MerlinUse*
+
+Loads findlib packages (with completion) by adjusting buildpath to find files
+from packages.
+
+Tab completion on packages name is provided.
+
+:MerlinLocate                                                  *:MerlinLocate*
+
+When called with no arguments tries to jump at the definition of the identifier
+under the cursor.
+
+When called with one argument tries to jump at the definition of the given
+identifier, using the environment available at the cursor position.
+
+Bound to gd by default in normal mode.
+
+:ML[I]                                                                   *:ML*
+
+Quick switch to a source (resp. interface) file.
+For instance, given moduleA.ml and moduleB.mli in source path, use: >
+    :ML ModuleA
+    :MLI ModuleB
+<
+
+:MerlinTypeOf [expr]                                           *:MerlinTypeOf*
+
+If given an expression, returns its type.
+Otherwise, highlights the expression under the cursor and prints its type.
+Use in conjunction with |:MerlinGrowEnclosing| and |:MerlinShrinkEnclosing|.
+
+Bound to <LocalLeader>t by default in normal mode.
+
+:MerlinTypeOfSel                                            *:MerlinTypeOfSel*
+
+In visual mode, returns the type of the selected expression.
+
+Bound to <LocalLeader>t by default in visual mode.
+
+:MerlinGrowEnclosing                                    *:MerlinGrowEnclosing*
+
+When |:MerlinTypeOf| has been called, select the smallest expression
+containing the previously highlighted expression.
+
+Bound to <LocalLeader>n by default in normal mode.
+
+:MerlinShrinkEnclosing                                *:MerlinShrinkEnclosing*
+
+When |:MerlinGrowEnclosing| has been called, revert to the previously selected
+expression. (i.e. the largest expression, centered around the position where
+|:MerlinTypeOf| was called, which is contained in the currently highlighted
+expression).
+
+Bound to <LocalLeader>p by default in normal mode.
+
+["r] :MerlinYankLatestType                             *:MerlinYankLatestType*
+
+Copy the latest shown type into register `"r`, or `""` if unspecified.
+
+:MerlinToggleTypeHistory                            *:MerlinToggleTypeHistory*
+
+Reveals or hides a buffer containing a trace of all computed types.
+See |merlin_type_history_height| and |merlin_type_history_auto_open|.
+
+:MerlinOccurrences                                         *:MerlinOccurences*
+
+List all occurrences of identifier under cursor in current buffer.
+See |merlin_display_occurrence_list|.
+Add these bindings to integrate the results into vim search (see |star|) >
+  nmap <LocalLeader>*  <Plug>(MerlinSearchOccurrencesForward)
+  nmap <LocalLeader>#  <Plug>(MerlinSearchOccurrencesBackward)
+<
+
+:MerlinRename <ident>                                          *:MerlinRename*
+
+Rename all occurrences of identifier under cursor to <ident>.
+Add these bindings to rename interactively: >
+  nmap <LocalLeader>r  <Plug>(MerlinRename)
+  nmap <LocalLeader>R  <Plug>(MerlinRenameAppend)
+<
+
+:MerlinDestruct                                              *:MerlinDestruct*
+
+"destructs" the thing under the cursor, i.e.
+- if the thing under the cursor is an expression, generates a pattern matching
+  on it.
+- if the thing under the cursor is a non-exhaustive pattern matching, makes
+  the matching exhaustive
+- if the thing under the cursor is a pattern variable or a pattern wildcard,
+  refines that pattern (if possible).
+
+See https://ocaml.github.io/merlin/destruct.ogv
+
+:MerlinConstruct                                            *:MerlinConstruct*
+
+When called from a hole "_", attempts to construct terms matching the hole's
+type. If only one result is found the hole is replaced immediately. If multiple
+results are found a list will appear. It is possible to ask for more or less
+deep results in that list using the shortcuts  "<c-i>" and "<c-u>".
+
+:MerlinOutline                                                *:MerlinOutline*
+
+Gives an "outline" of the current buffer, i.e. lists all the "definitions"
+made in the buffer along with their kind (type definition, value definition,
+module, etc.) and allows one to quickly jump at the (interactively) selected
+definition.
+
+The rendering (and interactivity) is provided by
+[ctrl-p](https://github.com/ctrlpvim/ctrlp.vim).
+
+:MerlinNextHole                                              *:MerlinNextHole*
+
+Moves the cursor forward to the closest hole "_". If there is no hole after the
+cursor the search will restart at the beginning of the buffer.
+
+:MerlinPreviousHole                                      *:MerlinPreviousHole*
+
+Moves the cursor backwards to the closest hole "_". If there is no hole before
+the cursor the search will restart at the end of the buffer.
+
+:MerlinILocate                                                *:MerlinILocate*
+
+This is an interactive version of |:MerlinLocate|, which relies on
+[ctrl-p](https://github.com/ctrlpvim/ctrlp.vim).
+It expects some input from the user, and then will list things in the
+environment which name matches the user input.
+
+Hitting enter will move you to the definition of the selected element.
+
+:MerlinPhrase                                                *:MerlinPhrase*
+Selects the current phrase.
+
+
+Bound to <TAB> by default in visual mode.
+
+:MerlinErrorCheck                                            *:MerlinErrorCheck*
+
+Perform a fast type check of the current file, displaying the error
+messages in a new quickfix window.
+
+:MerlinPy                                                    *:MerlinPy*
+
+Act either as *:py* or *:py3* depending on the version of python is used
+by the vim plugin.
+This is only useful if you want to write custom merlin extensions. 
+
+==============================================================================
+OPTIONS                                                       *merlin-options*
+
+
+                                                    *'merlin_ignore_warnings'*
+Default: false.
+If you are using syntastic and don't want warnings notified, set the following
+variable to {"true"} >
+  let g:merlin_ignore_warnings = "false"
+<
+
+                                                         *merlin_highlighting*
+
+The |:TypeEnclosing| commands highlights the expression under the cursor, the
+related match group is {EnclosingExpr}. You can customize the highlighting
+with the |:highlight| command, e.g. >
+    hi EnclosingExpr ctermbg=17 guibg=LightGreen
+<
+
+                                                    *'merlin_move_to_project'*
+
+Default: false.
+If set to true, merlin will automatically change local directory of an ocaml
+buffer to the root of the ".merlin" file. >
+  let g:merlin_move_to_project = "true"
+<
+                                             *'merlin_display_occurrence_list'*
+
+Default: true.
+If set to true, merlin automatically displays the list of occurrences in a
+separate window after a :MerlinOccurrences command. >
+  let g:merlin_display_occurrence_list = 0
+<
+
+                                                  *'merlin_display_error_list'*
+
+Default: true.
+If set to true, merlin automatically displays the list of errors in a
+separate window after a :MerlinErrorCheck command. >
+  let g:merlin_display_error_list = 0
+<
+
+                                                    *'merlin_close_error_list'*
+
+Default: true.
+If set to true, merlin automatically closes the list of errors if no error
+was found after a :MerlinErrorCheck command. >
+  let g:merlin_close_error_list = 0
+<
+                                                 *'merlin_type_history_height'*
+
+Default: 5.
+The default height of the type history window.  If set to zero, merlin never
+records any types in the history buffer. >
+  let g:merlin_type_history_height = 0
+<
+                                              *'merlin_type_history_auto_open'*
+
+Default: 5.
+The maximum number of type lines to print in the statusbar before opening the
+type history window.  If set to a very large number, merlin will never open
+the type history window automatically. >
+  let g:merlin_type_history_auto_open = 9999
+<
+
+                                                     *'merlin_textobject_grow'*
+                                                   *'merlin_textobject_shrink'*
+Default: unset.
+Binds |text-objects| on the ocaml AST. For example: >
+  let g:merlin_textobject_grow   = 'm'
+  let g:merlin_textobject_shrink = 'M'
+<
+On their first call, `M` selects the current node while `m` selects something
+bigger than a leaf.  Repeated use of `m` grow the selection and `M` shrinks
+it back.  The variants `im` and `aM` behave similarly, but reduce the
+selection by avoiding spaces and parenthesis; while `am` and `aM` expand it by
+capturing the surrounding spaces.
+
+In the following illustration, the cursor is represented by `[n]`:
+>
+                       ┌── aM ──┐
+                       │ ┌─ M ─┐│
+                       ↓ ↓     ↓↓
+  let def = outer     (  in[n]er  stuff  )    more
+            ↑     ↑   ↑  ↑            ↑  ↑  ↑    ↑
+            │     │   │  └─ im ───────┘  │  │    │
+            │     │   └────  m ──────────┘  │    │
+            │     └──────── am ─────────────┘    │
+            └────────────── 2m ──────────────────┘
+                        (or mm)
+<
+
+                                                     *'merlin_completion_dwim'*
+Default: true.
+Whether to enable "smart" (a.k.a "do what I mean") completion.
+If true, `L.m` will expand to >
+  List.map
+  List.m...
+  ListLabels.map
+  ...
+<
+if `L` doesn't exist.
+
+Disable with: >
+  let g:merlin_completion_dwim = 0
+<
+
+                                                 *'merlin_completion_arg_type'*
+Default: "several".
+Whether merlin should print the type of the expected parameter when completing
+in an application context.
+Possible options are:
+>
+  " always show the expected type
+  let g:merlin_completion_arg_type = "always"
+
+  " only show the expected type when there are more than one candidate
+  let g:merlin_completion_arg_type = "several"
+
+  " never show the expected type
+  let g:merlin_completion_arg_type = "never"
+<
+
+
+                                                   *'merlin_locate_preference'*
+Default: "ml".
+Specifies whether you'd prefer |:MerlinLocate| and |:MerlinILocate| to take you
+to .ml or .mli files. >
+    let g:merlin_locate_preference = 'mli'
+<
+                                         *'merlin_disable_default_keybindings'*
+Default: false.
+Specifies whether merlin should skip setting default keybindings.
+>
+    let g:merlin_disable_default_keybindings = 1
+<
+                                                        *'merlin_split_method'*
+Default: "horizontal".
+Specifies how the layout should be adjusted to display the result of a
+locate query (the target file and line).
+Possible values are:
+>
+  " Layout is never split, target is displayed in current window
+  let g:merlin_split_method = "never"
+
+  " Target is displayed in a new tab
+  let g:merlin_split_method = "tab"
+
+  " Target is displayed in a new horizontal split
+  let g:merlin_split_method = "horizontal"
+
+  " Target is displayed in a new vertical split
+  let g:merlin_split_method = "vertical"
+
+  " If the target is in the same file, the current window is used by default.
+  " You can prepend "always" to force a layout split.
+  let g:merlin_split_method = "always tab"
+  let g:merlin_split_method = "always horizontal"
+  let g:merlin_split_method = "always vertical"
+< 
+
+==============================================================================
+EXTRAS                                                         *merlin-extras*
+
+Type-on-hover~
+
+To display the type of the ocaml expression at the current mouse cursor, use Vim's |ballon-eval|
+functionality: >
+    au FileType ocaml setlocal balloonexpr=merlin#TypeAtBalloon()
+displays the type in a small popup. Alternatively, >
+    au FileType ocaml setlocal balloonexpr=merlin#ShowTypeAtBalloon()
+displays the type in the status line, similar to |MerlinTypeOf|. To switch
+this feature on, use >
+    set balloonveval
+when using a GUI version of Vim or >
+    set balloonvevalterm 
+in a terminal.
+
+
+Syntastic ~
+
+To use merlin with syntastic set the following option: >
+    let g:syntastic_ocaml_checkers=['merlin']
+<
+
+Neocomplcache ~
+
+(Note that Neocomplcache has been superseded by Neocomplete
+    in later versions of Vim)
+Integration with [neocomplcache](https://github.com/Shougo/neocomplcache)
+for automatic completion can be enabled with: >
+
+    if !exists('g:neocomplcache_force_omni_patterns')
+      let g:neocomplcache_force_omni_patterns = {}
+    endif
+    let g:neocomplcache_force_omni_patterns.ocaml = '[^. *\t]\.\w*\|\h\w*|#'
+
+
+Neocomplete ~
+
+Integration with [neocomplete](https://github.com/Shougo/neocomplete) for
+automatic completion can be enabled with: >
+
+    if !exists('g:neocomplete#sources#omni#input_patterns')
+      let g:neocomplete#sources#omni#input_patterns = {}
+    endif
+    let g:neocomplete#sources#omni#input_patterns.ocaml = '[^. *\t]\.\w*\|\h\w*|#'
+
+
+Deoplete ~
+
+Integration with [deoplete](https://github.com/Shougo/deoplete.nvim)
+for automatic, asynchronous completion with NeoVim can be enabled with: >
+
+    if !exists('g:deoplete#omni_patterns')
+      let g:deoplete#omni#input_patterns = {}
+    endif
+    let g:deoplete#omni#input_patterns.ocaml = '[^. *\t]\.\w*|\s\w*|#'
+
+Supertab ~
+
+People using Supertab can do: >
+    au FileType ocaml call SuperTabSetDefaultCompletionType("<c-x><c-o>")
+<
+
+As suggested in the Supertab documentation.
+
+CtrlP ~
+
+Some "interactive" commands (|:MerlinIlocate|, |:MerlinOutline|) depend on
+[ctrlp](https://github.com/ctrlpvim/ctrlp.vim).
+If the plugin is installed, they will work out of the box.
+
+Contact us ~
+
+If you have any comment, question or bug to report, you can contact us through
+github : https://github.com/ocaml/merlin/issues
+
+ vim:tw=78:et:ft=help:norl:
diff --git a/vim/merlin/dune b/vim/merlin/dune
new file mode 100644
index 0000000..40c3348
--- /dev/null
+++ b/vim/merlin/dune
@@ -0,0 +1,21 @@
+(install
+ (package merlin)
+ (section share)
+ (files (autoload/ctrlp/locate.vim as vim/autoload/ctrlp/locate.vim)
+        (autoload/ctrlp/outline.vim as vim/autoload/ctrlp/outline.vim)
+        (autoload/neomake/makers/ft/ocaml.vim as vim/autoload/neomake/makers/ft/ocaml.vim)
+        (autoload/merlin_find.vim as vim/autoload/merlin_find.vim)
+        (autoload/merlin.py as vim/autoload/merlin.py)
+        (autoload/merlin_type.vim as vim/autoload/merlin_type.vim)
+        (autoload/merlin.vim as vim/autoload/merlin.vim)
+        (autoload/merlin_visual.vim as vim/autoload/merlin_visual.vim)
+        (doc/merlin.txt as vim/doc/merlin.txt)
+        (ftdetect/merlin.vim as vim/ftdetect/merlin.vim)
+        (ftplugin/merlin.vim as vim/ftplugin/merlin.vim)
+        (ftplugin/ocaml.vim as vim/ftplugin/ocaml.vim)
+        (ftplugin/omlet.vim as vim/ftplugin/omlet.vim)
+        (ftplugin/reason.vim as vim/ftplugin/reason.vim)
+        (plugin/merlin.vim as vim/plugin/merlin.vim)
+        (syntax_checkers/ocaml/merlin.vim as vim/syntax_checkers/ocaml/merlin.vim)
+        (syntax_checkers/omlet/merlin.vim as vim/syntax_checkers/omlet/merlin.vim)
+        (syntax/merlin.vim as vim/syntax/merlin.vim)))
diff --git a/vim/merlin/ftdetect/merlin.vim b/vim/merlin/ftdetect/merlin.vim
new file mode 100644
index 0000000..3075f58
--- /dev/null
+++ b/vim/merlin/ftdetect/merlin.vim
@@ -0,0 +1 @@
+au BufNewFile,BufRead .merlin       set ft=merlin
diff --git a/vim/merlin/ftplugin/merlin.vim b/vim/merlin/ftplugin/merlin.vim
new file mode 100644
index 0000000..ab9bc21
--- /dev/null
+++ b/vim/merlin/ftplugin/merlin.vim
@@ -0,0 +1,2 @@
+setlocal commentstring=#\ %s
+setlocal comments=:#
diff --git a/vim/merlin/ftplugin/ocaml.vim b/vim/merlin/ftplugin/ocaml.vim
new file mode 100644
index 0000000..2e33e14
--- /dev/null
+++ b/vim/merlin/ftplugin/ocaml.vim
@@ -0,0 +1,2 @@
+" Activate merlin on current buffer
+call merlin#Register()
diff --git a/vim/merlin/ftplugin/omlet.vim b/vim/merlin/ftplugin/omlet.vim
new file mode 100644
index 0000000..2e33e14
--- /dev/null
+++ b/vim/merlin/ftplugin/omlet.vim
@@ -0,0 +1,2 @@
+" Activate merlin on current buffer
+call merlin#Register()
diff --git a/vim/merlin/ftplugin/reason.vim b/vim/merlin/ftplugin/reason.vim
new file mode 100644
index 0000000..2e33e14
--- /dev/null
+++ b/vim/merlin/ftplugin/reason.vim
@@ -0,0 +1,2 @@
+" Activate merlin on current buffer
+call merlin#Register()
diff --git a/vim/merlin/plugin/merlin.vim b/vim/merlin/plugin/merlin.vim
new file mode 100644
index 0000000..5c94a71
--- /dev/null
+++ b/vim/merlin/plugin/merlin.vim
@@ -0,0 +1,16 @@
+" If the mode didn't work for you, ensure that ocamlmerlin binary can be found
+" in PATH. 
+" Most commands are accessible only from omlet/ocaml buffers, check from an
+" appropriate buffer if merlin.vim is effectively loaded.
+
+" If you are using syntastic and don't want warnings notified, set the following
+" variable to "true"
+
+if !exists('g:merlin') | let g:merlin = {} | endif | let s:c = g:merlin
+let g:merlin_ignore_warnings = "false"
+
+let s:c.merlin_home = expand('<sfile>:h:h:h:h')
+let s:c.merlin_parent = expand('<sfile>:h:h:h:h:h')
+
+" Highlight the expression which type is given
+hi def link EnclosingExpr IncSearch
diff --git a/vim/merlin/syntax/merlin.vim b/vim/merlin/syntax/merlin.vim
new file mode 100644
index 0000000..df49a73
--- /dev/null
+++ b/vim/merlin/syntax/merlin.vim
@@ -0,0 +1,13 @@
+" Vim syntax file for editing merlin project files
+if exists("b:current_syntax")
+  finish
+endif
+
+syn keyword merlinKeyword S B SUFFIX PKG REC EXT PRJ FLG CMI CMT
+syn match merlinComment "\v#.*$"
+
+hi link merlinKeyword Keyword
+hi link merlinComment Comment
+
+let b:current_syntax = "merlin"
+
diff --git a/vim/merlin/syntax_checkers/ocaml/merlin.vim b/vim/merlin/syntax_checkers/ocaml/merlin.vim
new file mode 100644
index 0000000..309cfed
--- /dev/null
+++ b/vim/merlin/syntax_checkers/ocaml/merlin.vim
@@ -0,0 +1,23 @@
+" Enable Syntastic support
+" Make sure syntax_checkers directory is on runtime path, then set
+" :let g:syntastic_ocaml_checkers=['merlin']
+
+function! SyntaxCheckers_ocaml_merlin_IsAvailable()
+  if !exists("*merlin#SelectBinary")
+    return 0
+  endif
+  try
+    let l:path = merlin#SelectBinary()
+    return executable(l:path)
+  catch
+    return 0
+  endtry
+endfunction
+
+function! SyntaxCheckers_ocaml_merlin_GetLocList()
+  return merlin#ErrorLocList()
+endfunction
+
+call g:SyntasticRegistry.CreateAndRegisterChecker({
+    \ 'filetype': 'ocaml',
+    \ 'name': 'merlin'})
diff --git a/vim/merlin/syntax_checkers/omlet/merlin.vim b/vim/merlin/syntax_checkers/omlet/merlin.vim
new file mode 100644
index 0000000..62f7299
--- /dev/null
+++ b/vim/merlin/syntax_checkers/omlet/merlin.vim
@@ -0,0 +1,23 @@
+" Enable Syntastic support for omlet mode
+" Make sure syntax_checkers directory is on runtime path, then set
+" :let g:syntastic_omlet_checkers=['merlin']
+
+function! SyntaxCheckers_omlet_merlin_IsAvailable()
+  if !exists("*merlin#SelectBinary")
+    return 0
+  endif
+  try
+    let l:path = merlin#SelectBinary()
+    return executable(l:path)
+  catch
+    return 0
+  endtry
+endfunction
+
+function! SyntaxCheckers_omlet_merlin_GetLocList()
+  return merlin#ErrorLocList()
+endfunction
+
+call g:SyntasticRegistry.CreateAndRegisterChecker({
+    \ 'filetype': 'omlet',
+    \ 'name': 'merlin'})